Mercurial > hg > xemacs-beta
changeset 209:41ff10fd062f r20-4b3
Import from CVS: tag r20-4b3
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 10:04:58 +0200 |
| parents | f427b8ec4379 |
| children | 49f55ca3ba57 |
| files | CHANGES-beta ChangeLog configure configure.in etc/BETA etc/CHARSETS etc/CODINGS etc/DISTRIB etc/NEWS etc/TUTORIAL etc/TUTORIAL.de etc/TUTORIAL.fr etc/TUTORIAL.hr etc/TUTORIAL.ja etc/TUTORIAL.jp etc/TUTORIAL.ko etc/TUTORIAL.kr etc/TUTORIAL.no etc/e/README etc/e/emancs etc/e/emancs.ti etc/e/eterm etc/e/eterm.ti etc/hypb-mouse.txt etc/ida-logo.xpm lib-src/ChangeLog lib-src/update-autoloads.sh lib-src/update-custom.sh lib-src/update-elc.sh lisp/ChangeLog lisp/abbrev.el lisp/apel/ChangeLog lisp/apel/ChangeLog.emu lisp/apel/alist.el lisp/apel/atype.el lisp/apel/auto-autoloads.el lisp/apel/emu-e19.el lisp/apel/emu-x20.el lisp/apel/emu-xemacs.el lisp/apel/emu.el lisp/apel/file-detect.el lisp/apel/filename.el lisp/apel/install.el lisp/apel/mule-caesar.el lisp/apel/richtext.el lisp/apel/std11-parse.el lisp/apel/std11.el lisp/apel/tinyrich.el lisp/auto-autoloads.el lisp/auto-save.el lisp/auto-show.el lisp/backquote.el lisp/buff-menu.el lisp/buffer.el lisp/byte-optimize.el lisp/bytecomp-runtime.el lisp/bytecomp.el lisp/bytecomp/auto-autoloads.el lisp/bytecomp/byte-optimize.el lisp/bytecomp/bytecomp-runtime.el lisp/bytecomp/bytecomp.el lisp/bytecomp/disass.el lisp/cc-mode/auto-autoloads.el lisp/cc-mode/cc-align.el lisp/cc-mode/cc-cmds.el lisp/cc-mode/cc-compat.el lisp/cc-mode/cc-defs.el lisp/cc-mode/cc-engine.el lisp/cc-mode/cc-langs.el lisp/cc-mode/cc-menus.el lisp/cc-mode/cc-mode.el lisp/cc-mode/cc-styles.el lisp/cc-mode/cc-vars.el lisp/cc-mode/custom-load.el lisp/cl-compat.el lisp/cl-extra.el lisp/cl-macs.el lisp/cl-seq.el lisp/cl.el lisp/cl/auto-autoloads.el lisp/cl/cl-compat.el lisp/cl/cl-extra.el lisp/cl/cl-macs.el lisp/cl/cl-seq.el lisp/cl/cl.el lisp/cmdloop.el lisp/comint/auto-autoloads.el lisp/comint/background.el lisp/comint/comint-xemacs.el lisp/comint/comint.el lisp/comint/custom-load.el lisp/comint/dbx.el lisp/comint/gdb-highlight.el lisp/comint/gdb.el lisp/comint/gdbsrc.el lisp/comint/gud.el lisp/comint/history.el lisp/comint/inf-lisp.el lisp/comint/kermit.el lisp/comint/rlogin.el lisp/comint/shell.el lisp/comint/ssh.el lisp/comint/telnet.el lisp/console.el lisp/cus-dep.el lisp/cus-edit.el lisp/cus-face.el lisp/cus-load.el lisp/cus-start.el lisp/custom-load.el lisp/custom.el lisp/custom/auto-autoloads.el lisp/custom/cus-dep.el lisp/custom/cus-edit.el lisp/custom/cus-face.el lisp/custom/cus-load.el lisp/custom/cus-start.el lisp/custom/custom-load.el lisp/custom/custom.el lisp/custom/wid-browse.el lisp/custom/wid-edit.el lisp/custom/widget.el lisp/derived.el lisp/device.el lisp/dialog.el lisp/disass.el lisp/easymenu.el lisp/edebug/Makefile lisp/edebug/README lisp/edebug/advise-eval-region.el lisp/edebug/auto-autoloads.el lisp/edebug/cl-read.el lisp/edebug/cl-specs.el lisp/edebug/cust-print.el lisp/edebug/custom-load.el lisp/edebug/edebug-cl-read.el lisp/edebug/edebug-history lisp/edebug/edebug-test.el lisp/edebug/edebug.el lisp/edebug/eval-reg.el lisp/electric/auto-autoloads.el lisp/electric/ebuff-menu.el lisp/electric/echistory.el lisp/electric/ehelp.el lisp/electric/electric.el lisp/electric/helper.el lisp/eos/sun-eos-toolbar.el lisp/eterm/ChangeLog lisp/eterm/QUESTIONS lisp/eterm/README.term lisp/eterm/TODO.term lisp/eterm/auto-autoloads.el lisp/eterm/custom-load.el lisp/eterm/term.el lisp/eterm/tgud.el lisp/eterm/tshell.el lisp/events.el lisp/extents.el lisp/faces.el lisp/files-nomule.el lisp/files.el lisp/fill.el lisp/float-sup.el lisp/format.el lisp/frame.el lisp/glyphs.el lisp/gui.el lisp/help-nomule.el lisp/help.el lisp/hyperbole/ChangeLog lisp/hyperbole/ChangeLog.1 lisp/hyperbole/DEMO lisp/hyperbole/Makefile lisp/hyperbole/README lisp/hyperbole/auto-autoloads.el lisp/hyperbole/file-newer lisp/hyperbole/h-skip-bytec.lsp lisp/hyperbole/hact.el lisp/hyperbole/hactypes.el lisp/hyperbole/hargs.el lisp/hyperbole/hbdata.el lisp/hyperbole/hbmap.el lisp/hyperbole/hbut.el lisp/hyperbole/hgnus.el lisp/hyperbole/hhist.el lisp/hyperbole/hib-doc-id.el lisp/hyperbole/hib-kbd.el lisp/hyperbole/hibtypes.el lisp/hyperbole/hinit.el lisp/hyperbole/hlvar.el lisp/hyperbole/hmail.el lisp/hyperbole/hmh.el lisp/hyperbole/hmoccur.el lisp/hyperbole/hmous-info.el lisp/hyperbole/hmouse-drv.el lisp/hyperbole/hmouse-key.el lisp/hyperbole/hmouse-mod.el lisp/hyperbole/hmouse-reg.el lisp/hyperbole/hmouse-sh.el lisp/hyperbole/hmouse-tag.el lisp/hyperbole/hpath.el lisp/hyperbole/hrmail.el lisp/hyperbole/hsite-ex.el lisp/hyperbole/hsmail.el lisp/hyperbole/hsys-hbase.el lisp/hyperbole/hsys-w3.el lisp/hyperbole/hsys-wais.el lisp/hyperbole/hsys-www.el lisp/hyperbole/htz.el lisp/hyperbole/hui-em19-b.el lisp/hyperbole/hui-ep-but.el lisp/hyperbole/hui-epV4-b.el lisp/hyperbole/hui-menu.el lisp/hyperbole/hui-mini.el lisp/hyperbole/hui-mouse.el lisp/hyperbole/hui-window.el lisp/hyperbole/hui-xe-but.el lisp/hyperbole/hui.el lisp/hyperbole/hvar.el lisp/hyperbole/hversion.el lisp/hyperbole/hvm.el lisp/hyperbole/hypb.el lisp/hyperbole/hyperbole.el lisp/hyperbole/kotl/EXAMPLE.kotl lisp/hyperbole/kotl/kfile.el lisp/hyperbole/kotl/kfill.el lisp/hyperbole/kotl/kimport.el lisp/hyperbole/kotl/klabel.el lisp/hyperbole/kotl/klink.el lisp/hyperbole/kotl/kmenu.el lisp/hyperbole/kotl/knode.el lisp/hyperbole/kotl/kotl-mode.el lisp/hyperbole/kotl/kotl.el lisp/hyperbole/kotl/kprop-em.el lisp/hyperbole/kotl/kprop-xe.el lisp/hyperbole/kotl/kproperty.el lisp/hyperbole/kotl/kview.el lisp/hyperbole/kotl/kvspec.el lisp/hyperbole/set.el lisp/hyperbole/smart-clib-sym lisp/hyperbole/wconfig.el lisp/hyperbole/wrolo-logic.el lisp/hyperbole/wrolo-menu.el lisp/hyperbole/wrolo.el lisp/ilisp/ACKNOWLEDGMENTS lisp/ilisp/COPYING lisp/ilisp/GETTING-ILISP lisp/ilisp/HISTORY lisp/ilisp/INSTALLATION lisp/ilisp/Makefile lisp/ilisp/README lisp/ilisp/Welcome lisp/ilisp/allegro.lisp lisp/ilisp/bridge.el lisp/ilisp/cl-ilisp.lisp lisp/ilisp/cmulisp.lisp lisp/ilisp/comint-ipc.el lisp/ilisp/comint-v18.el lisp/ilisp/completer.el lisp/ilisp/completer.new.el lisp/ilisp/completer.no-fun.el lisp/ilisp/ilcompat.el lisp/ilisp/ild.mail lisp/ilisp/ilfsf18.el lisp/ilisp/ilfsf19.el lisp/ilisp/ilisp-acl.el lisp/ilisp/ilisp-aut.el lisp/ilisp/ilisp-bat.el lisp/ilisp/ilisp-bug.el lisp/ilisp/ilisp-chs.el lisp/ilisp/ilisp-cl.el lisp/ilisp/ilisp-cmp.el lisp/ilisp/ilisp-cmt.el lisp/ilisp/ilisp-cmu.el lisp/ilisp/ilisp-cpat.el lisp/ilisp/ilisp-def.el lisp/ilisp/ilisp-dia.el lisp/ilisp/ilisp-doc.el lisp/ilisp/ilisp-el.el lisp/ilisp/ilisp-ext.el lisp/ilisp/ilisp-hi.el lisp/ilisp/ilisp-hlw.el lisp/ilisp/ilisp-hnd.el lisp/ilisp/ilisp-ind.el lisp/ilisp/ilisp-inp.el lisp/ilisp/ilisp-kcl.el lisp/ilisp/ilisp-key.el lisp/ilisp/ilisp-kil.el lisp/ilisp/ilisp-low.el lisp/ilisp/ilisp-luc.el lisp/ilisp/ilisp-mak.el lisp/ilisp/ilisp-menu.el lisp/ilisp/ilisp-mnb.el lisp/ilisp/ilisp-mod.el lisp/ilisp/ilisp-mov.el lisp/ilisp/ilisp-out.el lisp/ilisp/ilisp-pkg.lisp lisp/ilisp/ilisp-prc.el lisp/ilisp/ilisp-prn.el lisp/ilisp/ilisp-rng.el lisp/ilisp/ilisp-s2c.el lisp/ilisp/ilisp-sch.el lisp/ilisp/ilisp-snd.el lisp/ilisp/ilisp-src.el lisp/ilisp/ilisp-sym.el lisp/ilisp/ilisp-utl.el lisp/ilisp/ilisp-val.el lisp/ilisp/ilisp-xfr.el lisp/ilisp/ilisp-xls.el lisp/ilisp/ilisp.el lisp/ilisp/ilisp.emacs lisp/ilisp/illuc19.el lisp/ilisp/ilxemacs.el lisp/ilisp/lispworks.lisp lisp/ilisp/lucid.lisp lisp/ilisp/scheme2c.mail lisp/indent.el lisp/isearch-mode.el lisp/iso/auto-autoloads.el lisp/iso/iso-acc.el lisp/iso/iso-ascii.el lisp/iso/iso-cvt.el lisp/iso/iso-insert.el lisp/iso/iso-swed.el lisp/iso/iso-syntax.el lisp/iso/iso8859-1.el lisp/iso/swedish.el lisp/iso8859-1.el lisp/itimer-autosave.el lisp/itimer.el lisp/keydefs.el lisp/keymap.el lisp/language/cyrillic.el lisp/language/european.el lisp/language/japanese.el lisp/language/korean.el lisp/lib-complete.el lisp/lisp-mode.el lisp/lisp.el lisp/list-mode.el lisp/loaddefs.el lisp/loadup-el.el lisp/loadup.el lisp/make-docfile.el lisp/map-ynp.el lisp/menubar.el lisp/minibuf.el lisp/misc.el lisp/mode-motion.el lisp/modeline.el lisp/modes/abbrev.el lisp/modes/ada-mode.el lisp/modes/ada-stmt.el lisp/modes/arc-mode.el lisp/modes/asm-mode.el lisp/modes/auto-show.el lisp/modes/cperl-mode.el lisp/modes/custom-load.el lisp/modes/f90.el lisp/modes/fortran-misc.el lisp/modes/fortran.el lisp/modes/ksh-mode.el lisp/modes/lazy-shot.el lisp/modes/lisp-mode.el lisp/modes/list-mode.el lisp/modes/m4-mode.el lisp/modes/sendmail.el lisp/modes/sh-script.el lisp/modes/simula.el lisp/modes/strokes.el lisp/modes/tcl.el lisp/modes/text-mode.el lisp/modes/verilog-mode.el lisp/modes/view-process-xemacs.el lisp/modes/view.el lisp/modes/vrml-mode.el lisp/modes/whitespace-mode.el lisp/modes/winmgr-mode.el lisp/modes/xpm-mode.el lisp/modes/xrdb-mode.el lisp/mouse.el lisp/mule/mule-cmds.el lisp/mule/mule-help.el lisp/mule/mule-init.el lisp/objects.el lisp/obsolete.el lisp/packages.el lisp/packages/auto-save.el lisp/packages/balloon-help.el lisp/packages/buff-menu.el lisp/packages/custom-load.el lisp/packages/desktop.el lisp/packages/font-lock.el lisp/packages/hyper-apropos.el lisp/packages/info.el lisp/packages/ps-print.el lisp/packages/rcompile.el lisp/packages/remote.el lisp/packages/tar-mode.el lisp/packages/time.el lisp/page.el lisp/paragraphs.el lisp/paths.el lisp/pcl-cvs/ChangeLog lisp/pcl-cvs/INSTALL lisp/pcl-cvs/NEWS lisp/pcl-cvs/README lisp/pcl-cvs/auto-autoloads.el lisp/pcl-cvs/cookie.el lisp/pcl-cvs/dll-debug.el lisp/pcl-cvs/dll.el lisp/pcl-cvs/elib-node.el lisp/pcl-cvs/pcl-cvs-startup.el lisp/pcl-cvs/pcl-cvs-xemacs.el lisp/pcl-cvs/pcl-cvs.el lisp/prim/about.el lisp/prim/advocacy.el lisp/prim/auto-autoloads.el lisp/prim/backquote.el lisp/prim/buffer.el lisp/prim/cmdloop.el lisp/prim/console.el lisp/prim/custom-load.el lisp/prim/device.el lisp/prim/dialog.el lisp/prim/dumped-lisp.el lisp/prim/events.el lisp/prim/extents.el lisp/prim/faces.el lisp/prim/files-nomule.el lisp/prim/files.el lisp/prim/fill.el lisp/prim/float-sup.el lisp/prim/format.el lisp/prim/frame.el lisp/prim/glyphs.el lisp/prim/gui.el lisp/prim/help-nomule.el lisp/prim/help.el lisp/prim/indent.el lisp/prim/isearch-mode.el lisp/prim/itimer-autosave.el lisp/prim/itimer.el lisp/prim/keydefs.el lisp/prim/keymap.el lisp/prim/lisp.el lisp/prim/loaddefs.el lisp/prim/loadup-el.el lisp/prim/loadup.el lisp/prim/make-docfile.el lisp/prim/menubar.el lisp/prim/minibuf.el lisp/prim/misc.el lisp/prim/mode-motion.el lisp/prim/modeline.el lisp/prim/mouse.el lisp/prim/objects.el lisp/prim/obsolete.el lisp/prim/packages.el lisp/prim/page.el lisp/prim/paragraphs.el lisp/prim/process.el lisp/prim/register.el lisp/prim/replace.el lisp/prim/scrollbar.el lisp/prim/simple.el lisp/prim/sound.el lisp/prim/specifier.el lisp/prim/startup.el lisp/prim/subr.el lisp/prim/syntax.el lisp/prim/toolbar.el lisp/prim/undo-stack.el lisp/prim/update-elc.el lisp/prim/window-xemacs.el lisp/prim/window.el lisp/prim/winnt.el lisp/process.el lisp/register.el lisp/replace.el lisp/scrollbar.el lisp/simple.el lisp/specifier.el lisp/startup.el lisp/subr.el lisp/syntax.el lisp/term/tty-init.el lisp/text-mode.el lisp/text-props.el lisp/toolbar.el lisp/tty-init.el lisp/undo-stack.el lisp/update-elc.el lisp/utils/auto-autoloads.el lisp/utils/custom-load.el lisp/utils/derived.el lisp/utils/easymenu.el lisp/utils/edit-toolbar.el lisp/utils/facemenu.el lisp/utils/finder.el lisp/utils/floating-toolbar.el lisp/utils/lib-complete.el lisp/utils/map-ynp.el lisp/utils/shadow.el lisp/utils/shadowfile.el lisp/utils/speedbar.el lisp/utils/speedbspec.el lisp/utils/text-props.el lisp/version.el lisp/vm/.autoload lisp/w32/w32-faces.el lisp/w32/w32-init.el lisp/wid-browse.el lisp/wid-edit.el lisp/widget.el lisp/window-xemacs.el lisp/window.el lisp/x-compose.el lisp/x-faces.el lisp/x-font-menu.el lisp/x-init.el lisp/x-iso8859-1.el lisp/x-menubar.el lisp/x-misc.el lisp/x-mouse.el lisp/x-scrollbar.el lisp/x-select.el lisp/x-toolbar.el lisp/x-win-sun.el lisp/x-win-xfree86.el lisp/x11/auto-autoloads.el lisp/x11/custom-load.el lisp/x11/x-compose.el lisp/x11/x-faces.el lisp/x11/x-font-menu.el lisp/x11/x-init.el lisp/x11/x-iso8859-1.el lisp/x11/x-menubar.el lisp/x11/x-misc.el lisp/x11/x-mouse.el lisp/x11/x-scrollbar.el lisp/x11/x-select.el lisp/x11/x-toolbar.el lisp/x11/x-win-sun.el lisp/x11/x-win-xfree86.el lwlib/lwlib-Xaw.c lwlib/lwlib-Xm.c man/ChangeLog man/Makefile man/cc-mode.texi man/hyperbole.texi man/ilisp.texi man/internals/internals.texi man/pcl-cvs.texi man/widget.texi man/xemacs/mule.texi src/ChangeLog src/Makefile.in.in src/abbrev.c src/balloon_help.c src/balloon_help.h src/buffer.c src/buffer.h src/callproc.c src/console-w32.c src/console-w32.h src/console.h src/data.c src/database.c src/device-w32.c src/device-x.c src/dired.c src/doc.c src/emacs.c src/event-stream.c src/event-w32.c src/event-w32.h src/events-mod.h src/events.c src/events.h src/faces.c src/fileio.c src/fns.c src/frame-w32.c src/frame-x.c src/frame.c src/general.c src/getloadavg.c src/getpagesize.h src/glyphs-x.c src/linuxplay.c src/lisp.h src/lread.c src/m/vax.h src/malloc.c src/mule-coding.c src/mule-mcpath.h src/ndir.h src/nt.c src/nt.h src/ntheap.c src/ntheap.h src/ntproc.c src/objects-w32.c src/objects-w32.h src/offix.h src/process.c src/process.h src/redisplay-output.c src/redisplay-tty.c src/redisplay-w32.c src/redisplay-x.c src/redisplay.c src/regex.c src/regex.h src/s/aix3-1.h src/s/cxux.h src/s/freebsd.h src/s/msdos.h src/s/template.h src/s/umax.h src/s/xenix.h src/signal.c src/symsinit.h src/sysdep.c src/sysdep.h src/sysfile.h src/sysfloat.h src/sysproc.h src/syspwd.h src/syssignal.h src/systime.h src/systty.h src/termcap.c src/unexnt.c src/w32-proc.c src/window.c version.sh w32/ChangeLog w32/README w32/Todo w32/config.h w32/inc/arpa/inet.h w32/inc/netdb.h w32/inc/netinet/in.h w32/inc/pwd.h w32/inc/sys/dir.h w32/inc/sys/file.h w32/inc/sys/ioctl.h w32/inc/sys/param.h w32/inc/sys/socket.h w32/inc/sys/time.h w32/inc/unistd.h w32/paths.h w32/puresize-adjust.h w32/runemacs.c w32/xemacs.mak |
| diffstat | 656 files changed, 77902 insertions(+), 213314 deletions(-) [+] |
line wrap: on
line diff
--- a/CHANGES-beta Mon Aug 13 10:03:54 2007 +0200 +++ b/CHANGES-beta Mon Aug 13 10:04:58 2007 +0200 @@ -1,4 +1,59 @@ -*- indented-text -*- +to 20.4 beta3 "Altai Mountain" +-- query-replace and query-replace-regexp will only replace the region if the + zmacs region is active. +-- iso-acc.el has been packaged +-- iso-ascii.el has been packaged +-- iso-cvt.el has been packaged +-- iso-insert.el has been packaged +-- iso-swed.el has been packaged +-- iso-syntax.el has been packaged +-- swedish.el has been packaged +-- edebug has been packaged +-- ebuff-menu.el has been packaged +-- echistory.el has been packaged +-- ehelp.el has been packaged +-- electric.el has been packaged +-- helper.el has been packaged +-- arc-mode.el has been packaged +-- ada-stmt.el has been packaged +-- ada-mode.el has been packaged +-- fortran.el has been packaged +-- fortran-misc.el has been packaged +-- f90.el has been packaged +-- ksh-mode.el has been packaged +-- m4-mode.el has been packaged +-- strokes.el has been packaged +-- sh-script.el has been packaged +-- simula.el has been packaged +-- tcl.el has been packaged +-- verilog-mode.el has been packaged +-- view.el has been packaged +-- vrml-mode.el has been packaged +-- whitespace-mode.el has been packaged +-- winmgr-mode.el has been packaged +-- xpm-mode.el has been packaged +-- xrdb-mode.el has been packaged +-- Suppress shadowing message if no shadows were found. +-- Moved dumped lisp into top-level lisp directory +-- bug fixes from Didier Verna, Jens-Ulrik Holger Petersen, Martin Buchholz, + and Tomasz Cholewo. +-- Lazy shot updates from Jan Vroonhof +-- Numerous bug fixes from Hrvoje Niksic +-- Numerous bug fixes from Kyle Jones +-- Mule changes courtesy of MORIOKA Tomohiko +-- speedbar has been packaged (and updated courtesy of Hrvoje Niksic) +-- Initial Native MS Windows support courtesy of Jonathan Harris +-- comint has been packaged +-- pcl-cvs has been packaged +-- cc-mode has been packaged +-- ilisp has been packaged +-- apel has been packaged +-- hyperbole has been packaged +-- eterm has been packaged +-- Elimination of broken VMS code courtesy of Andreas Jaeger +-- Miscellaneous bug fixes + to 20.4 beta2 "Alpine" -- hm--html-mode has been packaged -- viper has been packaged @@ -14,7 +69,7 @@ -- Norwegian tutorial update courtesy of Stig Bjorlykkee -- ediff & viper updates courtesy of Michael Kifer -- Canna & Wnn integrated with LEIM courtesy of Stephen Turnbull --- Berkeley DB 2.x support courtesy of Andreas Jaegar +-- Berkeley DB 2.x support courtesy of Andreas Jaeger -- tm has been packaged -- calendar has been packaged -- Build tweak: finder-inf is not aggressively rebuilt
--- a/ChangeLog Mon Aug 13 10:03:54 2007 +0200 +++ b/ChangeLog Mon Aug 13 10:04:58 2007 +0200 @@ -1,6 +1,106 @@ +1997-11-08 SL Baur <steve@altair.xemacs.org> + + * XEmacs 20.4-beta3 is released. + * XEmacs 20.3-pre2 is released. + +Wed November 05 23:40:00 1997 <jhar@tardis.ed.ac.uk> + + * w32/xemacs.mak: moved building the DOC file to after the .elcs. + +Sun November 01 12:00:00 1997 <jhar@tardis.ed.ac.uk> + + * Files split from nt to new w32 directory: + ChangeLog, README, Todo, paths.h, config.h, inc/*, runemacs.c, + xemacs.mak. + +1997-11-05 Didier Verna <verna@inf.enst.fr> + + * configure.in: Added the --site-prefixes options for the configure + script. You give a colon or space separated list of prefixes, and + subdirectories include/ and lib/ will be added with -I and -L. + +1997-11-05 Martin Buchholz <Martin Buchholz <martin@xemacs.org>> + + * configure.in: AIX + gcc fixes. + - Don't wrap -B. aixflags changed to start_flags. + +1997-11-04 SL Baur <steve@altair.xemacs.org> + + * lwlib/lwlib-Xm.c(update_one_menu_entry): Add missing variable. + From Skip Montanaro <skip@calendar.com> + +1997-11-04 Adrian Aichner <aichner@ecf.teradyne.com> + + * etc/TUTORIAL.de: + Updated copyright information. Translated most of the COPYING + section. Translated the <<.*>> didactic line. + +1997-10-22 Adrian Aichner <aichner@ecf.teradyne.com> + + * etc/TUTORIAL.de: Fixed two issues reported by + Achim Oppelt <aoppelt@theorie3.physik.uni-erlangen.de> + + * etc/TUTORIAL.de: + Manually applied rejected patch hunks from Marc Aurel's patch. + Some more fixes. + + * etc/TUTORIAL.de: + Applied patches supplied by Marc Aurel <4-tea-2@bong.saar.de>. + They fix yet more typos and quite a few awkward sentences. + +1997-10-21 Adrian Aichner <aichner@ecf.teradyne.com> + + * etc/TUTORIAL.de: Manually merged a few more corrections by + Carsten Leonhardt <leo@arioch.oche.de> + +1997-10-20 Adrian Aichner <aichner@ecf.teradyne.com> + + * etc/TUTORIAL.de: + Applied patches from Andreas Jaeger <aj@arthur.rhein-neckar.de> to 1.2, + then merged them with 1.3 via ediff-buffers. + Andreas found some quite nasty typos still and added many missing commas. + + * etc/TUTORIAL.de: Re-fill-ed paragraphs after patching. + + * etc/TUTORIAL.de: Applied the excellent patches courtesy of + Carsten Leonhardt <leo@arioch.oche.de>. + +1997-11-03 MORIOKA Tomohiko <morioka@jaist.ac.jp> + + * Delete etc/TUTORIAL.th because Thai is not supported yet. + +1997-11-02 MORIOKA Tomohiko <morioka@jaist.ac.jp> + + * etc/TUTORIAL.ko: Renamed from etc/TUTORIAL.kr to fit with ISO + 639 (two letter language code). + + * etc/TUTORIAL.ja: Renamed from etc/TUTORIAL.jp to fit with ISO + 639 (two letter language code). + +1997-11-02 SL Baur <steve@altair.xemacs.org> + + * etc/CHARSETS: New file imported from Emacs 20.1. + +1997-11-02 Kyle Jones <kyle_jones@wonderworks.com> + + * lwlib/lwlib-Xaw.c (xaw_pop_instance): Don't use parent + window's coordinates and dimensions to center the + dialog box unless its mapped_when_managed property is + true. This should avoid the top level widget that the + HAVE_SESSION code creates, which is unmapped and + useless for this purpose. + +1997-11-01 SL Baur <steve@altair.xemacs.org> + + * XEmacs 20.3-pre1 is released. + 1997-10-31 SL Baur <steve@altair.xemacs.org> - * XEmacs 20.4-beta2 + * XEmacs 19.16 is released. + +1997-10-31 SL Baur <steve@altair.xemacs.org> + + * XEmacs 20.4-beta2 is released. 1997-10-30 SL Baur <steve@altair.xemacs.org>
--- a/configure Mon Aug 13 10:03:54 2007 +0200 +++ b/configure Mon Aug 13 10:04:58 2007 +0200 @@ -283,6 +283,9 @@ --cflags=FLAGS Compiler flags. Overrides environment variable CFLAGS. --site-includes=PATH List of directories to search first for header files. --site-libraries=PATH List of directories to search first for libraries. +--site-prefixes=PATH List of directories to search for include/ and lib/ + subdirectories, just after 'site-includes' and + 'site-libraries'. --site-runtime-libraries=PATH List of ALL directories to search for dynamically linked libraries at run time. @@ -583,6 +586,7 @@ x_libraries | \ site_includes | \ site_libraries | \ + site_prefixes | \ site_runtime_libraries ) if test "$valomitted" = "yes" ; then if test "$#" = 0 ; then @@ -810,6 +814,7 @@ 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" @@ -868,7 +873,7 @@ esac echo $ac_n "checking whether ln -s works""... $ac_c" 1>&6 -echo "configure:872: checking whether ln -s works" >&5 +echo "configure:877: checking whether ln -s works" >&5 rm -f conftestdata if ln -s X conftestdata 2>/dev/null @@ -1045,7 +1050,7 @@ echo "checking "the configuration name"" 1>&6 -echo "configure:1049: checking "the configuration name"" >&5 +echo "configure:1054: checking "the configuration name"" >&5 internal_configuration=`echo $configuration | sed 's/-\(energize\|workshop\)//'` if canonical=`$srcdir/config.sub "$internal_configuration"` ; then : ; else exit $? @@ -1501,7 +1506,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:1505: checking for $ac_word" >&5 +echo "configure:1510: checking for $ac_word" >&5 if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. @@ -1527,7 +1532,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:1531: checking for $ac_word" >&5 +echo "configure:1536: checking for $ac_word" >&5 if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. @@ -1572,7 +1577,7 @@ fi echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works""... $ac_c" 1>&6 -echo "configure:1576: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5 +echo "configure:1581: 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' @@ -1584,11 +1589,11 @@ cross_compiling=no cat > conftest.$ac_ext <<EOF -#line 1588 "configure" +#line 1593 "configure" #include "confdefs.h" main(){return(0);} EOF -if { (eval echo configure:1592: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:1597: \"$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 @@ -1608,19 +1613,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:1612: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5 +echo "configure:1617: 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:1617: checking whether we are using GNU C" >&5 +echo "configure:1622: checking whether we are using GNU C" >&5 cat > conftest.c <<EOF #ifdef __GNUC__ yes; #endif EOF -if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:1624: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then +if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:1629: \"$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 @@ -1634,7 +1639,7 @@ ac_save_CFLAGS="$CFLAGS" CFLAGS= echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6 -echo "configure:1638: checking whether ${CC-cc} accepts -g" >&5 +echo "configure:1643: checking whether ${CC-cc} accepts -g" >&5 echo 'void f(){}' > conftest.c if test -z "`${CC-cc} -g -c conftest.c 2>&1`"; then @@ -1663,7 +1668,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:1667: checking for $ac_word" >&5 +echo "configure:1672: checking for $ac_word" >&5 if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. @@ -1689,7 +1694,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:1693: checking for $ac_word" >&5 +echo "configure:1698: checking for $ac_word" >&5 if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. @@ -1734,7 +1739,7 @@ fi echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works""... $ac_c" 1>&6 -echo "configure:1738: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5 +echo "configure:1743: 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' @@ -1746,11 +1751,11 @@ cross_compiling=no cat > conftest.$ac_ext <<EOF -#line 1750 "configure" +#line 1755 "configure" #include "confdefs.h" main(){return(0);} EOF -if { (eval echo configure:1754: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:1759: \"$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 @@ -1770,19 +1775,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:1774: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5 +echo "configure:1779: 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:1779: checking whether we are using GNU C" >&5 +echo "configure:1784: checking whether we are using GNU C" >&5 cat > conftest.c <<EOF #ifdef __GNUC__ yes; #endif EOF -if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:1786: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then +if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:1791: \"$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 @@ -1796,7 +1801,7 @@ ac_save_CFLAGS="$CFLAGS" CFLAGS= echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6 -echo "configure:1800: checking whether ${CC-cc} accepts -g" >&5 +echo "configure:1805: checking whether ${CC-cc} accepts -g" >&5 echo 'void f(){}' > conftest.c if test -z "`${CC-cc} -g -c conftest.c 2>&1`"; then @@ -1825,7 +1830,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:1829: checking for $ac_word" >&5 +echo "configure:1834: checking for $ac_word" >&5 if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. @@ -1851,7 +1856,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:1855: checking for $ac_word" >&5 +echo "configure:1860: checking for $ac_word" >&5 if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. @@ -1896,7 +1901,7 @@ fi echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works""... $ac_c" 1>&6 -echo "configure:1900: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5 +echo "configure:1905: 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' @@ -1908,11 +1913,11 @@ cross_compiling=no cat > conftest.$ac_ext <<EOF -#line 1912 "configure" +#line 1917 "configure" #include "confdefs.h" main(){return(0);} EOF -if { (eval echo configure:1916: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:1921: \"$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 @@ -1932,19 +1937,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:1936: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5 +echo "configure:1941: 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:1941: checking whether we are using GNU C" >&5 +echo "configure:1946: checking whether we are using GNU C" >&5 cat > conftest.c <<EOF #ifdef __GNUC__ yes; #endif EOF -if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:1948: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then +if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:1953: \"$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 @@ -1958,7 +1963,7 @@ ac_save_CFLAGS="$CFLAGS" CFLAGS= echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6 -echo "configure:1962: checking whether ${CC-cc} accepts -g" >&5 +echo "configure:1967: checking whether ${CC-cc} accepts -g" >&5 echo 'void f(){}' > conftest.c if test -z "`${CC-cc} -g -c conftest.c 2>&1`"; then @@ -1991,7 +1996,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:1995: checking how to run the C preprocessor" >&5 +echo "configure:2000: checking how to run the C preprocessor" >&5 # On Suns, sometimes $CPP names a directory. if test -n "$CPP" && test -d "$CPP"; then CPP= @@ -2004,13 +2009,13 @@ # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. cat > conftest.$ac_ext <<EOF -#line 2008 "configure" +#line 2013 "configure" #include "confdefs.h" #include <assert.h> Syntax Error EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:2014: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:2019: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then : @@ -2021,13 +2026,13 @@ rm -rf conftest* CPP="${CC-cc} -E -traditional-cpp" cat > conftest.$ac_ext <<EOF -#line 2025 "configure" +#line 2030 "configure" #include "confdefs.h" #include <assert.h> Syntax Error EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:2031: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:2036: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then : @@ -2050,9 +2055,9 @@ echo $ac_n "checking for AIX""... $ac_c" 1>&6 -echo "configure:2054: checking for AIX" >&5 -cat > conftest.$ac_ext <<EOF -#line 2056 "configure" +echo "configure:2059: checking for AIX" >&5 +cat > conftest.$ac_ext <<EOF +#line 2061 "configure" #include "confdefs.h" #ifdef _AIX yes @@ -2079,9 +2084,9 @@ echo $ac_n "checking whether we are using SunPro C""... $ac_c" 1>&6 -echo "configure:2083: checking whether we are using SunPro C" >&5 -cat > conftest.$ac_ext <<EOF -#line 2085 "configure" +echo "configure:2088: checking whether we are using SunPro C" >&5 +cat > conftest.$ac_ext <<EOF +#line 2090 "configure" #include "confdefs.h" int main() { @@ -2092,7 +2097,7 @@ ; return 0; } EOF -if { (eval echo configure:2096: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:2101: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* __sunpro_c=yes else @@ -2328,7 +2333,7 @@ ld_switch_system_tmp="$ld_switch_system"; ld_switch_system="" for arg in $ld_switch_system_tmp; do case "$arg" in - -L* | -l* | -R* | -u* | -Wl* | -f* | -B*) ld_switch_system="$ld_switch_system $arg" ;; + -L* | -l* | -R* | -u* | -Wl* | -f*) ld_switch_system="$ld_switch_system $arg" ;; -Xlinker* ) ;; * ) ld_switch_system="$ld_switch_system -Xlinker $arg" ;; esac @@ -2336,7 +2341,7 @@ ld_switch_machine_tmp="$ld_switch_machine"; ld_switch_machine="" for arg in $ld_switch_machine_tmp; do case "$arg" in - -L* | -l* | -R* | -u* | -Wl* | -f* | -B*) ld_switch_machine="$ld_switch_machine $arg" ;; + -L* | -l* | -R* | -u* | -Wl* | -f*) ld_switch_machine="$ld_switch_machine $arg" ;; -Xlinker* ) ;; * ) ld_switch_machine="$ld_switch_machine -Xlinker $arg" ;; esac @@ -2344,7 +2349,7 @@ LDFLAGS_tmp="$LDFLAGS"; LDFLAGS="" for arg in $LDFLAGS_tmp; do case "$arg" in - -L* | -l* | -R* | -u* | -Wl* | -f* | -B*) LDFLAGS="$LDFLAGS $arg" ;; + -L* | -l* | -R* | -u* | -Wl* | -f*) LDFLAGS="$LDFLAGS $arg" ;; -Xlinker* ) ;; * ) LDFLAGS="$LDFLAGS -Xlinker $arg" ;; esac @@ -2352,7 +2357,7 @@ ld_call_shared_tmp="$ld_call_shared"; ld_call_shared="" for arg in $ld_call_shared_tmp; do case "$arg" in - -L* | -l* | -R* | -u* | -Wl* | -f* | -B*) ld_call_shared="$ld_call_shared $arg" ;; + -L* | -l* | -R* | -u* | -Wl* | -f*) ld_call_shared="$ld_call_shared $arg" ;; -Xlinker* ) ;; * ) ld_call_shared="$ld_call_shared -Xlinker $arg" ;; esac @@ -2370,7 +2375,7 @@ fi echo $ac_n "checking for dynodump""... $ac_c" 1>&6 -echo "configure:2374: checking for dynodump" >&5 +echo "configure:2379: checking for dynodump" >&5 if test "$unexec" != "unexsol2.o"; then echo "$ac_t""no" 1>&6 else @@ -2396,7 +2401,7 @@ if test "$unexec" = "unexaix.o"; then start_flags="-Wl,-bnso,-bnodelcsect" - test "$GCC" = "yes" && start_flags="-B/bin/ ${aixflags}" + test "$GCC" = "yes" && start_flags="-B/bin/ ${start_flags}" for f in "/lib/syscalls.exp" "$srcdir/src/m/ibmrs6000.inp"; do if test -r "$f"; then start_flags="${start_flags},-bI:${f}"; fi done @@ -2419,6 +2424,18 @@ + +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 + if test -n "$site_libraries"; then for arg in $site_libraries; do case "$arg" in -* ) ;; * ) arg="-L${arg}" ;; esac @@ -2454,19 +2471,19 @@ if test "$add_runtime_path" = "yes"; then echo $ac_n "checking "for runtime libraries flag"""... $ac_c" 1>&6 -echo "configure:2458: checking "for runtime libraries flag"" >&5 +echo "configure:2475: checking "for runtime libraries flag"" >&5 dash_r="" for try_dash_r in "-R" "-R " "-rpath "; do xe_check_libs="${try_dash_r}/no/such/file-or-directory" cat > conftest.$ac_ext <<EOF -#line 2463 "configure" +#line 2480 "configure" #include "confdefs.h" int main() { ; return 0; } EOF -if { (eval echo configure:2470: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:2487: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* dash_r="$try_dash_r" else @@ -2564,7 +2581,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:2568: checking for $ac_word" >&5 +echo "configure:2585: checking for $ac_word" >&5 if test -n "$RANLIB"; then ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test. @@ -2617,7 +2634,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:2621: checking for a BSD compatible install" >&5 +echo "configure:2638: checking for a BSD compatible install" >&5 if test -z "$INSTALL"; then IFS="${IFS= }"; ac_save_IFS="$IFS"; IFS="${IFS}:" @@ -2668,7 +2685,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:2672: checking for $ac_word" >&5 +echo "configure:2689: checking for $ac_word" >&5 if test -n "$YACC"; then ac_cv_prog_YACC="$YACC" # Let the user override the test. @@ -2699,15 +2716,15 @@ do ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 -echo "configure:2703: checking for $ac_hdr" >&5 - -cat > conftest.$ac_ext <<EOF -#line 2706 "configure" +echo "configure:2720: checking for $ac_hdr" >&5 + +cat > conftest.$ac_ext <<EOF +#line 2723 "configure" #include "confdefs.h" #include <$ac_hdr> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:2711: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:2728: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -2740,15 +2757,15 @@ do ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 -echo "configure:2744: checking for $ac_hdr" >&5 - -cat > conftest.$ac_ext <<EOF -#line 2747 "configure" +echo "configure:2761: checking for $ac_hdr" >&5 + +cat > conftest.$ac_ext <<EOF +#line 2764 "configure" #include "confdefs.h" #include <$ac_hdr> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:2752: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:2769: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -2781,15 +2798,15 @@ do ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 -echo "configure:2785: checking for $ac_hdr" >&5 - -cat > conftest.$ac_ext <<EOF -#line 2788 "configure" +echo "configure:2802: checking for $ac_hdr" >&5 + +cat > conftest.$ac_ext <<EOF +#line 2805 "configure" #include "confdefs.h" #include <$ac_hdr> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:2793: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:2810: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -2819,10 +2836,10 @@ done echo $ac_n "checking for sys/wait.h that is POSIX.1 compatible""... $ac_c" 1>&6 -echo "configure:2823: checking for sys/wait.h that is POSIX.1 compatible" >&5 - -cat > conftest.$ac_ext <<EOF -#line 2826 "configure" +echo "configure:2840: checking for sys/wait.h that is POSIX.1 compatible" >&5 + +cat > conftest.$ac_ext <<EOF +#line 2843 "configure" #include "confdefs.h" #include <sys/types.h> #include <sys/wait.h> @@ -2838,7 +2855,7 @@ s = WIFEXITED (s) ? WEXITSTATUS (s) : 1; ; return 0; } EOF -if { (eval echo configure:2842: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:2859: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_header_sys_wait_h=yes else @@ -2862,10 +2879,10 @@ fi echo $ac_n "checking for ANSI C header files""... $ac_c" 1>&6 -echo "configure:2866: checking for ANSI C header files" >&5 - -cat > conftest.$ac_ext <<EOF -#line 2869 "configure" +echo "configure:2883: checking for ANSI C header files" >&5 + +cat > conftest.$ac_ext <<EOF +#line 2886 "configure" #include "confdefs.h" #include <stdlib.h> #include <stdarg.h> @@ -2873,7 +2890,7 @@ #include <float.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:2877: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:2894: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -2890,7 +2907,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 -#line 2894 "configure" +#line 2911 "configure" #include "confdefs.h" #include <string.h> EOF @@ -2908,7 +2925,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 -#line 2912 "configure" +#line 2929 "configure" #include "confdefs.h" #include <stdlib.h> EOF @@ -2926,7 +2943,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 <<EOF -#line 2930 "configure" +#line 2947 "configure" #include "confdefs.h" #include <ctype.h> #define ISLOWER(c) ('a' <= (c) && (c) <= 'z') @@ -2937,7 +2954,7 @@ exit (0); } EOF -if { (eval echo configure:2941: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:2958: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then : else @@ -2962,10 +2979,10 @@ fi echo $ac_n "checking whether time.h and sys/time.h may both be included""... $ac_c" 1>&6 -echo "configure:2966: checking whether time.h and sys/time.h may both be included" >&5 - -cat > conftest.$ac_ext <<EOF -#line 2969 "configure" +echo "configure:2983: checking whether time.h and sys/time.h may both be included" >&5 + +cat > conftest.$ac_ext <<EOF +#line 2986 "configure" #include "confdefs.h" #include <sys/types.h> #include <sys/time.h> @@ -2974,7 +2991,7 @@ struct tm *tp; ; return 0; } EOF -if { (eval echo configure:2978: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:2995: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_header_time=yes else @@ -2998,10 +3015,10 @@ fi echo $ac_n "checking for sys_siglist declaration in signal.h or unistd.h""... $ac_c" 1>&6 -echo "configure:3002: checking for sys_siglist declaration in signal.h or unistd.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 3005 "configure" +echo "configure:3019: checking for sys_siglist declaration in signal.h or unistd.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 3022 "configure" #include "confdefs.h" #include <sys/types.h> #include <signal.h> @@ -3013,7 +3030,7 @@ char *msg = *(sys_siglist + 1); ; return 0; } EOF -if { (eval echo configure:3017: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3034: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_decl_sys_siglist=yes else @@ -3038,9 +3055,9 @@ echo $ac_n "checking for struct utimbuf""... $ac_c" 1>&6 -echo "configure:3042: checking for struct utimbuf" >&5 -cat > conftest.$ac_ext <<EOF -#line 3044 "configure" +echo "configure:3059: checking for struct utimbuf" >&5 +cat > conftest.$ac_ext <<EOF +#line 3061 "configure" #include "confdefs.h" #ifdef TIME_WITH_SYS_TIME #include <sys/time.h> @@ -3059,7 +3076,7 @@ static struct utimbuf x; x.actime = x.modtime; ; return 0; } EOF -if { (eval echo configure:3063: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3080: \"$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 @@ -3079,10 +3096,10 @@ rm -f conftest* echo $ac_n "checking return type of signal handlers""... $ac_c" 1>&6 -echo "configure:3083: checking return type of signal handlers" >&5 - -cat > conftest.$ac_ext <<EOF -#line 3086 "configure" +echo "configure:3100: checking return type of signal handlers" >&5 + +cat > conftest.$ac_ext <<EOF +#line 3103 "configure" #include "confdefs.h" #include <sys/types.h> #include <signal.h> @@ -3099,7 +3116,7 @@ int i; ; return 0; } EOF -if { (eval echo configure:3103: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3120: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_type_signal=void else @@ -3121,10 +3138,10 @@ echo $ac_n "checking for size_t""... $ac_c" 1>&6 -echo "configure:3125: checking for size_t" >&5 - -cat > conftest.$ac_ext <<EOF -#line 3128 "configure" +echo "configure:3142: checking for size_t" >&5 + +cat > conftest.$ac_ext <<EOF +#line 3145 "configure" #include "confdefs.h" #include <sys/types.h> #if STDC_HEADERS @@ -3155,10 +3172,10 @@ fi echo $ac_n "checking for pid_t""... $ac_c" 1>&6 -echo "configure:3159: checking for pid_t" >&5 - -cat > conftest.$ac_ext <<EOF -#line 3162 "configure" +echo "configure:3176: checking for pid_t" >&5 + +cat > conftest.$ac_ext <<EOF +#line 3179 "configure" #include "confdefs.h" #include <sys/types.h> #if STDC_HEADERS @@ -3189,10 +3206,10 @@ fi echo $ac_n "checking for uid_t in sys/types.h""... $ac_c" 1>&6 -echo "configure:3193: checking for uid_t in sys/types.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 3196 "configure" +echo "configure:3210: checking for uid_t in sys/types.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 3213 "configure" #include "confdefs.h" #include <sys/types.h> EOF @@ -3228,10 +3245,10 @@ fi echo $ac_n "checking for mode_t""... $ac_c" 1>&6 -echo "configure:3232: checking for mode_t" >&5 - -cat > conftest.$ac_ext <<EOF -#line 3235 "configure" +echo "configure:3249: checking for mode_t" >&5 + +cat > conftest.$ac_ext <<EOF +#line 3252 "configure" #include "confdefs.h" #include <sys/types.h> #if STDC_HEADERS @@ -3262,10 +3279,10 @@ fi echo $ac_n "checking for off_t""... $ac_c" 1>&6 -echo "configure:3266: checking for off_t" >&5 - -cat > conftest.$ac_ext <<EOF -#line 3269 "configure" +echo "configure:3283: checking for off_t" >&5 + +cat > conftest.$ac_ext <<EOF +#line 3286 "configure" #include "confdefs.h" #include <sys/types.h> #if STDC_HEADERS @@ -3297,9 +3314,9 @@ echo $ac_n "checking for struct timeval""... $ac_c" 1>&6 -echo "configure:3301: checking for struct timeval" >&5 -cat > conftest.$ac_ext <<EOF -#line 3303 "configure" +echo "configure:3318: checking for struct timeval" >&5 +cat > conftest.$ac_ext <<EOF +#line 3320 "configure" #include "confdefs.h" #ifdef TIME_WITH_SYS_TIME #include <sys/time.h> @@ -3315,7 +3332,7 @@ static struct timeval x; x.tv_sec = x.tv_usec; ; return 0; } EOF -if { (eval echo configure:3319: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3336: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* echo "$ac_t""yes" 1>&6 HAVE_TIMEVAL=yes @@ -3337,10 +3354,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:3341: checking whether struct tm is in sys/time.h or time.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 3344 "configure" +echo "configure:3358: checking whether struct tm is in sys/time.h or time.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 3361 "configure" #include "confdefs.h" #include <sys/types.h> #include <time.h> @@ -3348,7 +3365,7 @@ struct tm *tp; tp->tm_sec; ; return 0; } EOF -if { (eval echo configure:3352: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3369: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_struct_tm=time.h else @@ -3372,10 +3389,10 @@ fi echo $ac_n "checking for tm_zone in struct tm""... $ac_c" 1>&6 -echo "configure:3376: checking for tm_zone in struct tm" >&5 - -cat > conftest.$ac_ext <<EOF -#line 3379 "configure" +echo "configure:3393: checking for tm_zone in struct tm" >&5 + +cat > conftest.$ac_ext <<EOF +#line 3396 "configure" #include "confdefs.h" #include <sys/types.h> #include <$ac_cv_struct_tm> @@ -3383,7 +3400,7 @@ struct tm tm; tm.tm_zone; ; return 0; } EOF -if { (eval echo configure:3387: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3404: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_struct_tm_zone=yes else @@ -3406,10 +3423,10 @@ else echo $ac_n "checking for tzname""... $ac_c" 1>&6 -echo "configure:3410: checking for tzname" >&5 - -cat > conftest.$ac_ext <<EOF -#line 3413 "configure" +echo "configure:3427: checking for tzname" >&5 + +cat > conftest.$ac_ext <<EOF +#line 3430 "configure" #include "confdefs.h" #include <time.h> #ifndef tzname /* For SGI. */ @@ -3419,7 +3436,7 @@ atoi(*tzname); ; return 0; } EOF -if { (eval echo configure:3423: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:3440: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* ac_cv_var_tzname=yes else @@ -3445,10 +3462,10 @@ echo $ac_n "checking for working const""... $ac_c" 1>&6 -echo "configure:3449: checking for working const" >&5 - -cat > conftest.$ac_ext <<EOF -#line 3452 "configure" +echo "configure:3466: checking for working const" >&5 + +cat > conftest.$ac_ext <<EOF +#line 3469 "configure" #include "confdefs.h" int main() { @@ -3497,7 +3514,7 @@ ; return 0; } EOF -if { (eval echo configure:3501: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3518: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_c_const=yes else @@ -3522,7 +3539,7 @@ echo $ac_n "checking whether ${MAKE-make} sets \${MAKE}""... $ac_c" 1>&6 -echo "configure:3526: checking whether ${MAKE-make} sets \${MAKE}" >&5 +echo "configure:3543: checking whether ${MAKE-make} sets \${MAKE}" >&5 set dummy ${MAKE-make}; ac_make=`echo "$2" | sed 'y%./+-%__p_%'` cat > conftestmake <<\EOF @@ -3547,12 +3564,12 @@ echo $ac_n "checking whether byte ordering is bigendian""... $ac_c" 1>&6 -echo "configure:3551: checking whether byte ordering is bigendian" >&5 +echo "configure:3568: checking whether byte ordering is bigendian" >&5 ac_cv_c_bigendian=unknown # See if sys/param.h defines the BYTE_ORDER macro. cat > conftest.$ac_ext <<EOF -#line 3556 "configure" +#line 3573 "configure" #include "confdefs.h" #include <sys/types.h> #include <sys/param.h> @@ -3563,11 +3580,11 @@ #endif ; return 0; } EOF -if { (eval echo configure:3567: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3584: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* # It does; now see whether it defined to BIG_ENDIAN or not. cat > conftest.$ac_ext <<EOF -#line 3571 "configure" +#line 3588 "configure" #include "confdefs.h" #include <sys/types.h> #include <sys/param.h> @@ -3578,7 +3595,7 @@ #endif ; return 0; } EOF -if { (eval echo configure:3582: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3599: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_c_bigendian=yes else @@ -3595,7 +3612,7 @@ rm -f conftest* if test $ac_cv_c_bigendian = unknown; then cat > conftest.$ac_ext <<EOF -#line 3599 "configure" +#line 3616 "configure" #include "confdefs.h" main () { /* Are we little or big endian? From Harbison&Steele. */ @@ -3608,7 +3625,7 @@ exit (u.c[sizeof (long) - 1] == 1); } EOF -if { (eval echo configure:3612: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:3629: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ac_cv_c_bigendian=no else @@ -3634,10 +3651,10 @@ echo $ac_n "checking size of short""... $ac_c" 1>&6 -echo "configure:3638: checking size of short" >&5 - -cat > conftest.$ac_ext <<EOF -#line 3641 "configure" +echo "configure:3655: checking size of short" >&5 + +cat > conftest.$ac_ext <<EOF +#line 3658 "configure" #include "confdefs.h" #include <stdio.h> main() @@ -3648,7 +3665,7 @@ exit(0); } EOF -if { (eval echo configure:3652: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:3669: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ac_cv_sizeof_short=`cat conftestval` else @@ -3675,10 +3692,10 @@ exit 1 fi echo $ac_n "checking size of int""... $ac_c" 1>&6 -echo "configure:3679: checking size of int" >&5 - -cat > conftest.$ac_ext <<EOF -#line 3682 "configure" +echo "configure:3696: checking size of int" >&5 + +cat > conftest.$ac_ext <<EOF +#line 3699 "configure" #include "confdefs.h" #include <stdio.h> main() @@ -3689,7 +3706,7 @@ exit(0); } EOF -if { (eval echo configure:3693: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:3710: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ac_cv_sizeof_int=`cat conftestval` else @@ -3710,10 +3727,10 @@ echo $ac_n "checking size of long""... $ac_c" 1>&6 -echo "configure:3714: checking size of long" >&5 - -cat > conftest.$ac_ext <<EOF -#line 3717 "configure" +echo "configure:3731: checking size of long" >&5 + +cat > conftest.$ac_ext <<EOF +#line 3734 "configure" #include "confdefs.h" #include <stdio.h> main() @@ -3724,7 +3741,7 @@ exit(0); } EOF -if { (eval echo configure:3728: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:3745: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ac_cv_sizeof_long=`cat conftestval` else @@ -3745,10 +3762,10 @@ echo $ac_n "checking size of long long""... $ac_c" 1>&6 -echo "configure:3749: checking size of long long" >&5 - -cat > conftest.$ac_ext <<EOF -#line 3752 "configure" +echo "configure:3766: checking size of long long" >&5 + +cat > conftest.$ac_ext <<EOF +#line 3769 "configure" #include "confdefs.h" #include <stdio.h> main() @@ -3759,7 +3776,7 @@ exit(0); } EOF -if { (eval echo configure:3763: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:3780: \"$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 @@ -3780,10 +3797,10 @@ echo $ac_n "checking size of void *""... $ac_c" 1>&6 -echo "configure:3784: checking size of void *" >&5 - -cat > conftest.$ac_ext <<EOF -#line 3787 "configure" +echo "configure:3801: checking size of void *" >&5 + +cat > conftest.$ac_ext <<EOF +#line 3804 "configure" #include "confdefs.h" #include <stdio.h> main() @@ -3794,7 +3811,7 @@ exit(0); } EOF -if { (eval echo configure:3798: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:3815: \"$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 @@ -3816,7 +3833,7 @@ echo $ac_n "checking for long file names""... $ac_c" 1>&6 -echo "configure:3820: checking for long file names" >&5 +echo "configure:3837: 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: @@ -3863,12 +3880,12 @@ echo $ac_n "checking for sin in -lm""... $ac_c" 1>&6 -echo "configure:3867: checking for sin in -lm" >&5 +echo "configure:3884: checking for sin in -lm" >&5 ac_lib_var=`echo m'_'sin | sed 'y%./+-%__p_%'` xe_check_libs=" -lm " cat > conftest.$ac_ext <<EOF -#line 3872 "configure" +#line 3889 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -3879,7 +3896,7 @@ sin() ; return 0; } EOF -if { (eval echo configure:3883: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:3900: \"$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 @@ -3921,7 +3938,7 @@ echo "checking type of mail spool file locking" 1>&6 -echo "configure:3925: checking type of mail spool file locking" >&5 +echo "configure:3942: 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 @@ -3945,12 +3962,12 @@ echo $ac_n "checking for kstat_open in -lkstat""... $ac_c" 1>&6 -echo "configure:3949: checking for kstat_open in -lkstat" >&5 +echo "configure:3966: checking for kstat_open in -lkstat" >&5 ac_lib_var=`echo kstat'_'kstat_open | sed 'y%./+-%__p_%'` xe_check_libs=" -lkstat " cat > conftest.$ac_ext <<EOF -#line 3954 "configure" +#line 3971 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -3961,7 +3978,7 @@ kstat_open() ; return 0; } EOF -if { (eval echo configure:3965: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:3982: \"$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 @@ -3995,12 +4012,12 @@ echo $ac_n "checking for kvm_read in -lkvm""... $ac_c" 1>&6 -echo "configure:3999: checking for kvm_read in -lkvm" >&5 +echo "configure:4016: checking for kvm_read in -lkvm" >&5 ac_lib_var=`echo kvm'_'kvm_read | sed 'y%./+-%__p_%'` xe_check_libs=" -lkvm " cat > conftest.$ac_ext <<EOF -#line 4004 "configure" +#line 4021 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -4011,7 +4028,7 @@ kvm_read() ; return 0; } EOF -if { (eval echo configure:4015: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4032: \"$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 @@ -4045,12 +4062,12 @@ echo $ac_n "checking for cma_open in -lpthreads""... $ac_c" 1>&6 -echo "configure:4049: checking for cma_open in -lpthreads" >&5 +echo "configure:4066: checking for cma_open in -lpthreads" >&5 ac_lib_var=`echo pthreads'_'cma_open | sed 'y%./+-%__p_%'` xe_check_libs=" -lpthreads " cat > conftest.$ac_ext <<EOF -#line 4054 "configure" +#line 4071 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -4061,7 +4078,7 @@ cma_open() ; return 0; } EOF -if { (eval echo configure:4065: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4082: \"$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 @@ -4097,7 +4114,7 @@ fi echo $ac_n "checking whether the -xildoff compiler flag is required""... $ac_c" 1>&6 -echo "configure:4101: checking whether the -xildoff compiler flag is required" >&5 +echo "configure:4118: 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; @@ -4108,7 +4125,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:4112: checking for \"-z ignore\" linker flag" >&5 +echo "configure:4129: 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 ;; @@ -4118,7 +4135,7 @@ echo "checking "for specified window system"" 1>&6 -echo "configure:4122: checking "for specified window system"" >&5 +echo "configure:4139: checking "for specified window system"" >&5 if test "$with_x11" != "no"; then test "$x_includes $x_libraries" != "NONE NONE" && \ @@ -4148,7 +4165,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:4152: checking for X" >&5 +echo "configure:4169: checking for X" >&5 # Check whether --with-x or --without-x was given. if test "${with_x+set}" = set; then @@ -4208,12 +4225,12 @@ # First, try using that file with no special directory specified. cat > conftest.$ac_ext <<EOF -#line 4212 "configure" +#line 4229 "configure" #include "confdefs.h" #include <$x_direct_test_include> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:4217: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:4234: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -4282,14 +4299,14 @@ ac_save_LIBS="$LIBS" LIBS="-l$x_direct_test_library $LIBS" cat > conftest.$ac_ext <<EOF -#line 4286 "configure" +#line 4303 "configure" #include "confdefs.h" int main() { ${x_direct_test_function}() ; return 0; } EOF -if { (eval echo configure:4293: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4310: \"$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. @@ -4398,17 +4415,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:4402: checking whether -R must be followed by a space" >&5 +echo "configure:4419: checking whether -R must be followed by a space" >&5 ac_xsave_LIBS="$LIBS"; LIBS="$LIBS -R$x_libraries" cat > conftest.$ac_ext <<EOF -#line 4405 "configure" +#line 4422 "configure" #include "confdefs.h" int main() { ; return 0; } EOF -if { (eval echo configure:4412: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4429: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* ac_R_nospace=yes else @@ -4424,14 +4441,14 @@ else LIBS="$ac_xsave_LIBS -R $x_libraries" cat > conftest.$ac_ext <<EOF -#line 4428 "configure" +#line 4445 "configure" #include "confdefs.h" int main() { ; return 0; } EOF -if { (eval echo configure:4435: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4452: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* ac_R_space=yes else @@ -4467,12 +4484,12 @@ else echo $ac_n "checking for dnet_ntoa in -ldnet""... $ac_c" 1>&6 -echo "configure:4471: checking for dnet_ntoa in -ldnet" >&5 +echo "configure:4488: checking for dnet_ntoa in -ldnet" >&5 ac_lib_var=`echo dnet'_'dnet_ntoa | sed 'y%./+-%__p_%'` xe_check_libs=" -ldnet " cat > conftest.$ac_ext <<EOF -#line 4476 "configure" +#line 4493 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -4483,7 +4500,7 @@ dnet_ntoa() ; return 0; } EOF -if { (eval echo configure:4487: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4504: \"$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 @@ -4507,12 +4524,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:4511: checking for dnet_ntoa in -ldnet_stub" >&5 +echo "configure:4528: checking for dnet_ntoa in -ldnet_stub" >&5 ac_lib_var=`echo dnet_stub'_'dnet_ntoa | sed 'y%./+-%__p_%'` xe_check_libs=" -ldnet_stub " cat > conftest.$ac_ext <<EOF -#line 4516 "configure" +#line 4533 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -4523,7 +4540,7 @@ dnet_ntoa() ; return 0; } EOF -if { (eval echo configure:4527: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4544: \"$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 @@ -4552,10 +4569,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:4556: checking for gethostbyname" >&5 - -cat > conftest.$ac_ext <<EOF -#line 4559 "configure" +echo "configure:4573: checking for gethostbyname" >&5 + +cat > conftest.$ac_ext <<EOF +#line 4576 "configure" #include "confdefs.h" /* System header to define __stub macros and hopefully few prototypes, which can conflict with char gethostbyname(); below. */ @@ -4578,7 +4595,7 @@ ; return 0; } EOF -if { (eval echo configure:4582: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4599: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_gethostbyname=yes" else @@ -4599,12 +4616,12 @@ if test $ac_cv_func_gethostbyname = no; then echo $ac_n "checking for gethostbyname in -lnsl""... $ac_c" 1>&6 -echo "configure:4603: checking for gethostbyname in -lnsl" >&5 +echo "configure:4620: checking for gethostbyname in -lnsl" >&5 ac_lib_var=`echo nsl'_'gethostbyname | sed 'y%./+-%__p_%'` xe_check_libs=" -lnsl " cat > conftest.$ac_ext <<EOF -#line 4608 "configure" +#line 4625 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -4615,7 +4632,7 @@ gethostbyname() ; return 0; } EOF -if { (eval echo configure:4619: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4636: \"$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 @@ -4645,10 +4662,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:4649: checking for connect" >&5 - -cat > conftest.$ac_ext <<EOF -#line 4652 "configure" +echo "configure:4666: checking for connect" >&5 + +cat > conftest.$ac_ext <<EOF +#line 4669 "configure" #include "confdefs.h" /* System header to define __stub macros and hopefully few prototypes, which can conflict with char connect(); below. */ @@ -4671,7 +4688,7 @@ ; return 0; } EOF -if { (eval echo configure:4675: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4692: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_connect=yes" else @@ -4694,12 +4711,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:4698: checking "$xe_msg_checking"" >&5 +echo "configure:4715: checking "$xe_msg_checking"" >&5 ac_lib_var=`echo socket'_'connect | sed 'y%./+-%__p_%'` xe_check_libs=" -lsocket $X_EXTRA_LIBS" cat > conftest.$ac_ext <<EOF -#line 4703 "configure" +#line 4720 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -4710,7 +4727,7 @@ connect() ; return 0; } EOF -if { (eval echo configure:4714: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4731: \"$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 @@ -4734,10 +4751,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:4738: checking for remove" >&5 - -cat > conftest.$ac_ext <<EOF -#line 4741 "configure" +echo "configure:4755: checking for remove" >&5 + +cat > conftest.$ac_ext <<EOF +#line 4758 "configure" #include "confdefs.h" /* System header to define __stub macros and hopefully few prototypes, which can conflict with char remove(); below. */ @@ -4760,7 +4777,7 @@ ; return 0; } EOF -if { (eval echo configure:4764: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4781: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_remove=yes" else @@ -4781,12 +4798,12 @@ if test $ac_cv_func_remove = no; then echo $ac_n "checking for remove in -lposix""... $ac_c" 1>&6 -echo "configure:4785: checking for remove in -lposix" >&5 +echo "configure:4802: checking for remove in -lposix" >&5 ac_lib_var=`echo posix'_'remove | sed 'y%./+-%__p_%'` xe_check_libs=" -lposix " cat > conftest.$ac_ext <<EOF -#line 4790 "configure" +#line 4807 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -4797,7 +4814,7 @@ remove() ; return 0; } EOF -if { (eval echo configure:4801: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4818: \"$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 @@ -4821,10 +4838,10 @@ # BSDI BSD/OS 2.1 needs -lipc for XOpenDisplay. echo $ac_n "checking for shmat""... $ac_c" 1>&6 -echo "configure:4825: checking for shmat" >&5 - -cat > conftest.$ac_ext <<EOF -#line 4828 "configure" +echo "configure:4842: checking for shmat" >&5 + +cat > conftest.$ac_ext <<EOF +#line 4845 "configure" #include "confdefs.h" /* System header to define __stub macros and hopefully few prototypes, which can conflict with char shmat(); below. */ @@ -4847,7 +4864,7 @@ ; return 0; } EOF -if { (eval echo configure:4851: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4868: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_shmat=yes" else @@ -4868,12 +4885,12 @@ if test $ac_cv_func_shmat = no; then echo $ac_n "checking for shmat in -lipc""... $ac_c" 1>&6 -echo "configure:4872: checking for shmat in -lipc" >&5 +echo "configure:4889: checking for shmat in -lipc" >&5 ac_lib_var=`echo ipc'_'shmat | sed 'y%./+-%__p_%'` xe_check_libs=" -lipc " cat > conftest.$ac_ext <<EOF -#line 4877 "configure" +#line 4894 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -4884,7 +4901,7 @@ shmat() ; return 0; } EOF -if { (eval echo configure:4888: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4905: \"$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 @@ -4918,12 +4935,12 @@ # --interran@uluru.Stanford.EDU, kb@cs.umb.edu. echo $ac_n "checking for IceConnectionNumber in -lICE""... $ac_c" 1>&6 -echo "configure:4922: checking for IceConnectionNumber in -lICE" >&5 +echo "configure:4939: checking for IceConnectionNumber in -lICE" >&5 ac_lib_var=`echo ICE'_'IceConnectionNumber | sed 'y%./+-%__p_%'` xe_check_libs=" -lICE " cat > conftest.$ac_ext <<EOF -#line 4927 "configure" +#line 4944 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -4934,7 +4951,7 @@ IceConnectionNumber() ; return 0; } EOF -if { (eval echo configure:4938: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4955: \"$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 @@ -5067,7 +5084,7 @@ fi echo "checking for X defines extracted by xmkmf" 1>&6 -echo "configure:5071: checking for X defines extracted by xmkmf" >&5 +echo "configure:5088: checking for X defines extracted by xmkmf" >&5 rm -fr conftestdir if mkdir conftestdir; then cd conftestdir @@ -5099,15 +5116,15 @@ ac_safe=`echo "X11/Intrinsic.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for X11/Intrinsic.h""... $ac_c" 1>&6 -echo "configure:5103: checking for X11/Intrinsic.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 5106 "configure" +echo "configure:5120: checking for X11/Intrinsic.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 5123 "configure" #include "confdefs.h" #include <X11/Intrinsic.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:5111: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:5128: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -5131,12 +5148,12 @@ echo $ac_n "checking for XOpenDisplay in -lX11""... $ac_c" 1>&6 -echo "configure:5135: checking for XOpenDisplay in -lX11" >&5 +echo "configure:5152: checking for XOpenDisplay in -lX11" >&5 ac_lib_var=`echo X11'_'XOpenDisplay | sed 'y%./+-%__p_%'` xe_check_libs=" -lX11 " cat > conftest.$ac_ext <<EOF -#line 5140 "configure" +#line 5157 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -5147,7 +5164,7 @@ XOpenDisplay() ; return 0; } EOF -if { (eval echo configure:5151: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5168: \"$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 @@ -5172,12 +5189,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:5176: checking "$xe_msg_checking"" >&5 +echo "configure:5193: checking "$xe_msg_checking"" >&5 ac_lib_var=`echo X11'_'XGetFontProperty | sed 'y%./+-%__p_%'` xe_check_libs=" -lX11 -b i486-linuxaout" cat > conftest.$ac_ext <<EOF -#line 5181 "configure" +#line 5198 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -5188,7 +5205,7 @@ XGetFontProperty() ; return 0; } EOF -if { (eval echo configure:5192: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5209: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5215,12 +5232,12 @@ echo $ac_n "checking for XShapeSelectInput in -lXext""... $ac_c" 1>&6 -echo "configure:5219: checking for XShapeSelectInput in -lXext" >&5 +echo "configure:5236: checking for XShapeSelectInput in -lXext" >&5 ac_lib_var=`echo Xext'_'XShapeSelectInput | sed 'y%./+-%__p_%'` xe_check_libs=" -lXext " cat > conftest.$ac_ext <<EOF -#line 5224 "configure" +#line 5241 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -5231,7 +5248,7 @@ XShapeSelectInput() ; return 0; } EOF -if { (eval echo configure:5235: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5252: \"$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 @@ -5254,12 +5271,12 @@ echo $ac_n "checking for XtOpenDisplay in -lXt""... $ac_c" 1>&6 -echo "configure:5258: checking for XtOpenDisplay in -lXt" >&5 +echo "configure:5275: checking for XtOpenDisplay in -lXt" >&5 ac_lib_var=`echo Xt'_'XtOpenDisplay | sed 'y%./+-%__p_%'` xe_check_libs=" -lXt " cat > conftest.$ac_ext <<EOF -#line 5263 "configure" +#line 5280 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -5270,7 +5287,7 @@ XtOpenDisplay() ; return 0; } EOF -if { (eval echo configure:5274: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5291: \"$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 @@ -5293,14 +5310,14 @@ echo $ac_n "checking the version of X11 being used""... $ac_c" 1>&6 -echo "configure:5297: checking the version of X11 being used" >&5 +echo "configure:5314: checking the version of X11 being used" >&5 cat > conftest.$ac_ext <<EOF -#line 5299 "configure" +#line 5316 "configure" #include "confdefs.h" #include <X11/Intrinsic.h> main(int c, char* v[]) { return c>1 ? XlibSpecificationRelease : 0; } EOF -if { (eval echo configure:5304: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:5321: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ./conftest foobar; x11_release=$? else @@ -5324,15 +5341,15 @@ do ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 -echo "configure:5328: checking for $ac_hdr" >&5 - -cat > conftest.$ac_ext <<EOF -#line 5331 "configure" +echo "configure:5345: checking for $ac_hdr" >&5 + +cat > conftest.$ac_ext <<EOF +#line 5348 "configure" #include "confdefs.h" #include <$ac_hdr> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:5336: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:5353: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -5363,7 +5380,7 @@ echo $ac_n "checking for XFree86""... $ac_c" 1>&6 -echo "configure:5367: checking for XFree86" >&5 +echo "configure:5384: checking for XFree86" >&5 if test -d "/usr/X386/include" -o \ -f "/etc/XF86Config" -o \ -f "/etc/X11/XF86Config" -o \ @@ -5383,12 +5400,12 @@ test -z "$with_xmu" && { echo $ac_n "checking for XmuReadBitmapDataFromFile in -lXmu""... $ac_c" 1>&6 -echo "configure:5387: checking for XmuReadBitmapDataFromFile in -lXmu" >&5 +echo "configure:5404: checking for XmuReadBitmapDataFromFile in -lXmu" >&5 ac_lib_var=`echo Xmu'_'XmuReadBitmapDataFromFile | sed 'y%./+-%__p_%'` xe_check_libs=" -lXmu " cat > conftest.$ac_ext <<EOF -#line 5392 "configure" +#line 5409 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -5399,7 +5416,7 @@ XmuReadBitmapDataFromFile() ; return 0; } EOF -if { (eval echo configure:5403: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5420: \"$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 @@ -5438,19 +5455,19 @@ echo $ac_n "checking for main in -lXbsd""... $ac_c" 1>&6 -echo "configure:5442: checking for main in -lXbsd" >&5 +echo "configure:5459: checking for main in -lXbsd" >&5 ac_lib_var=`echo Xbsd'_'main | sed 'y%./+-%__p_%'` xe_check_libs=" -lXbsd " cat > conftest.$ac_ext <<EOF -#line 5447 "configure" +#line 5464 "configure" #include "confdefs.h" int main() { main() ; return 0; } EOF -if { (eval echo configure:5454: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5471: \"$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 @@ -5504,7 +5521,7 @@ esac echo "checking for session-management option" 1>&6 -echo "configure:5508: checking for session-management option" >&5; +echo "configure:5525: checking for session-management option" >&5; if test "$with_session" != "no"; then { test "$extra_verbose" = "yes" && cat << \EOF Defining HAVE_SESSION @@ -5519,15 +5536,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:5523: checking for X11/Xauth.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 5526 "configure" +echo "configure:5540: checking for X11/Xauth.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 5543 "configure" #include "confdefs.h" #include <X11/Xauth.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:5531: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:5548: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -5550,12 +5567,12 @@ } test -z "$with_xauth" && { echo $ac_n "checking for XauGetAuthByAddr in -lXau""... $ac_c" 1>&6 -echo "configure:5554: checking for XauGetAuthByAddr in -lXau" >&5 +echo "configure:5571: checking for XauGetAuthByAddr in -lXau" >&5 ac_lib_var=`echo Xau'_'XauGetAuthByAddr | sed 'y%./+-%__p_%'` xe_check_libs=" -lXau " cat > conftest.$ac_ext <<EOF -#line 5559 "configure" +#line 5576 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -5566,7 +5583,7 @@ XauGetAuthByAddr() ; return 0; } EOF -if { (eval echo configure:5570: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5587: \"$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 @@ -5626,15 +5643,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:5630: checking for ${dir}tt_c.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 5633 "configure" +echo "configure:5647: checking for ${dir}tt_c.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 5650 "configure" #include "confdefs.h" #include <${dir}tt_c.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:5638: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:5655: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -5663,12 +5680,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:5667: checking "$xe_msg_checking"" >&5 +echo "configure:5684: checking "$xe_msg_checking"" >&5 ac_lib_var=`echo tt'_'tt_message_create | sed 'y%./+-%__p_%'` xe_check_libs=" -ltt $extra_libs" cat > conftest.$ac_ext <<EOF -#line 5672 "configure" +#line 5689 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -5679,7 +5696,7 @@ tt_message_create() ; return 0; } EOF -if { (eval echo configure:5683: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5700: \"$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 @@ -5728,15 +5745,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:5732: checking for Dt/Dt.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 5735 "configure" +echo "configure:5749: checking for Dt/Dt.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 5752 "configure" #include "confdefs.h" #include <Dt/Dt.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:5740: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:5757: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -5759,12 +5776,12 @@ } test -z "$with_cde" && { echo $ac_n "checking for DtDndDragStart in -lDtSvc""... $ac_c" 1>&6 -echo "configure:5763: checking for DtDndDragStart in -lDtSvc" >&5 +echo "configure:5780: checking for DtDndDragStart in -lDtSvc" >&5 ac_lib_var=`echo DtSvc'_'DtDndDragStart | sed 'y%./+-%__p_%'` xe_check_libs=" -lDtSvc " cat > conftest.$ac_ext <<EOF -#line 5768 "configure" +#line 5785 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -5775,7 +5792,7 @@ DtDndDragStart() ; return 0; } EOF -if { (eval echo configure:5779: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5796: \"$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 @@ -5822,19 +5839,19 @@ echo $ac_n "checking for main in -lenergize""... $ac_c" 1>&6 -echo "configure:5826: checking for main in -lenergize" >&5 +echo "configure:5843: checking for main in -lenergize" >&5 ac_lib_var=`echo energize'_'main | sed 'y%./+-%__p_%'` xe_check_libs=" -lenergize " cat > conftest.$ac_ext <<EOF -#line 5831 "configure" +#line 5848 "configure" #include "confdefs.h" int main() { main() ; return 0; } EOF -if { (eval echo configure:5838: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5855: \"$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 @@ -5866,19 +5883,19 @@ if test -z "$energize_version"; then echo $ac_n "checking for main in -lconn""... $ac_c" 1>&6 -echo "configure:5870: checking for main in -lconn" >&5 +echo "configure:5887: checking for main in -lconn" >&5 ac_lib_var=`echo conn'_'main | sed 'y%./+-%__p_%'` xe_check_libs=" -lconn " cat > conftest.$ac_ext <<EOF -#line 5875 "configure" +#line 5892 "configure" #include "confdefs.h" int main() { main() ; return 0; } EOF -if { (eval echo configure:5882: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5899: \"$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 @@ -5911,15 +5928,15 @@ fi ac_safe=`echo "editorconn.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for editorconn.h""... $ac_c" 1>&6 -echo "configure:5915: checking for editorconn.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 5918 "configure" +echo "configure:5932: checking for editorconn.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 5935 "configure" #include "confdefs.h" #include <editorconn.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:5923: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:5940: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -5963,12 +5980,12 @@ if test "$with_x11" = "yes"; then echo "checking for X11 graphics libraries" 1>&6 -echo "configure:5967: checking for X11 graphics libraries" >&5 +echo "configure:5984: checking for X11 graphics libraries" >&5 echo $ac_n "checking for Xpm - no older than 3.4f""... $ac_c" 1>&6 -echo "configure:5969: checking for Xpm - no older than 3.4f" >&5 +echo "configure:5986: checking for Xpm - no older than 3.4f" >&5 xe_check_libs=-lXpm test -z "$with_xpm" && { cat > conftest.$ac_ext <<EOF -#line 5972 "configure" +#line 5989 "configure" #include "confdefs.h" #include <X11/xpm.h> int main(int c, char **v) { @@ -5978,7 +5995,7 @@ 0 ; } EOF -if { (eval echo configure:5982: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:5999: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ./conftest foobar; xpm_status=$?; if test "$xpm_status" = "0"; then with_xpm=yes; else with_xpm=no; fi; @@ -6016,15 +6033,15 @@ 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:6020: checking for compface.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 6023 "configure" +echo "configure:6037: checking for compface.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 6040 "configure" #include "confdefs.h" #include <compface.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:6028: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:6045: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -6047,12 +6064,12 @@ } test -z "$with_xface" && { echo $ac_n "checking for UnGenFace in -lcompface""... $ac_c" 1>&6 -echo "configure:6051: checking for UnGenFace in -lcompface" >&5 +echo "configure:6068: checking for UnGenFace in -lcompface" >&5 ac_lib_var=`echo compface'_'UnGenFace | sed 'y%./+-%__p_%'` xe_check_libs=" -lcompface " cat > conftest.$ac_ext <<EOF -#line 6056 "configure" +#line 6073 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -6063,7 +6080,7 @@ UnGenFace() ; return 0; } EOF -if { (eval echo configure:6067: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6084: \"$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 @@ -6097,17 +6114,17 @@ libs_x="-lcompface $libs_x" && if test "$extra_verbose" = "yes"; then echo " Prepending \"-lcompface\" to \$libs_x"; fi fi - test -z "$with_imagick" && { ac_safe=`echo "magick.h" | sed 'y%./+-%__p_%'` -echo $ac_n "checking for magick.h""... $ac_c" 1>&6 -echo "configure:6103: checking for magick.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 6106 "configure" -#include "confdefs.h" -#include <magick.h> + test -z "$with_imagick" && { ac_safe=`echo "magick/magick.h" | sed 'y%./+-%__p_%'` +echo $ac_n "checking for magick/magick.h""... $ac_c" 1>&6 +echo "configure:6120: checking for magick/magick.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 6123 "configure" +#include "confdefs.h" +#include <magick/magick.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:6111: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:6128: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -6130,12 +6147,12 @@ } test -z "$with_imagick" && { echo $ac_n "checking for MogrifyImage in -lMagick""... $ac_c" 1>&6 -echo "configure:6134: checking for MogrifyImage in -lMagick" >&5 +echo "configure:6151: checking for MogrifyImage in -lMagick" >&5 ac_lib_var=`echo Magick'_'MogrifyImage | sed 'y%./+-%__p_%'` xe_check_libs=" -lMagick " cat > conftest.$ac_ext <<EOF -#line 6139 "configure" +#line 6156 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -6146,7 +6163,7 @@ MogrifyImage() ; return 0; } EOF -if { (eval echo configure:6150: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6167: \"$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 @@ -6182,12 +6199,12 @@ echo $ac_n "checking for XawScrollbarSetThumb in -lXaw""... $ac_c" 1>&6 -echo "configure:6186: checking for XawScrollbarSetThumb in -lXaw" >&5 +echo "configure:6203: checking for XawScrollbarSetThumb in -lXaw" >&5 ac_lib_var=`echo Xaw'_'XawScrollbarSetThumb | sed 'y%./+-%__p_%'` xe_check_libs=" -lXaw " cat > conftest.$ac_ext <<EOF -#line 6191 "configure" +#line 6208 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -6198,7 +6215,7 @@ XawScrollbarSetThumb() ; return 0; } EOF -if { (eval echo configure:6202: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6219: \"$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 @@ -6222,15 +6239,15 @@ if test "$have_xaw" = "yes"; then ac_safe=`echo "X11/Xaw/Reports.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for X11/Xaw/Reports.h""... $ac_c" 1>&6 -echo "configure:6226: checking for X11/Xaw/Reports.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 6229 "configure" +echo "configure:6243: checking for X11/Xaw/Reports.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 6246 "configure" #include "confdefs.h" #include <X11/Xaw/Reports.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:6234: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:6251: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -6256,15 +6273,15 @@ ac_safe=`echo "Xm/Xm.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for Xm/Xm.h""... $ac_c" 1>&6 -echo "configure:6260: checking for Xm/Xm.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 6263 "configure" +echo "configure:6277: checking for Xm/Xm.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 6280 "configure" #include "confdefs.h" #include <Xm/Xm.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:6268: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:6285: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -6281,12 +6298,12 @@ echo "$ac_t""yes" 1>&6 echo $ac_n "checking for XmStringFree in -lXm""... $ac_c" 1>&6 -echo "configure:6285: checking for XmStringFree in -lXm" >&5 +echo "configure:6302: checking for XmStringFree in -lXm" >&5 ac_lib_var=`echo Xm'_'XmStringFree | sed 'y%./+-%__p_%'` xe_check_libs=" -lXm " cat > conftest.$ac_ext <<EOF -#line 6290 "configure" +#line 6307 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -6297,7 +6314,7 @@ XmStringFree() ; return 0; } EOF -if { (eval echo configure:6301: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6318: \"$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 @@ -6553,7 +6570,7 @@ if test "$with_mule" = "yes" ; then echo "checking for Mule-related features" 1>&6 -echo "configure:6557: checking for Mule-related features" >&5 +echo "configure:6574: checking for Mule-related features" >&5 { test "$extra_verbose" = "yes" && cat << \EOF Defining MULE EOF @@ -6570,15 +6587,15 @@ do ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 -echo "configure:6574: checking for $ac_hdr" >&5 - -cat > conftest.$ac_ext <<EOF -#line 6577 "configure" +echo "configure:6591: checking for $ac_hdr" >&5 + +cat > conftest.$ac_ext <<EOF +#line 6594 "configure" #include "confdefs.h" #include <$ac_hdr> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:6582: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:6599: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -6609,12 +6626,12 @@ echo $ac_n "checking for strerror in -lintl""... $ac_c" 1>&6 -echo "configure:6613: checking for strerror in -lintl" >&5 +echo "configure:6630: checking for strerror in -lintl" >&5 ac_lib_var=`echo intl'_'strerror | sed 'y%./+-%__p_%'` xe_check_libs=" -lintl " cat > conftest.$ac_ext <<EOF -#line 6618 "configure" +#line 6635 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -6625,7 +6642,7 @@ strerror() ; return 0; } EOF -if { (eval echo configure:6629: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6646: \"$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 @@ -6658,19 +6675,19 @@ echo "checking for Mule input methods" 1>&6 -echo "configure:6662: checking for Mule input methods" >&5 +echo "configure:6679: checking for Mule input methods" >&5 test -z "$with_xim" -a "$opsys" != "sol2" && with_xim=no case "$with_xim" in "" | "yes" ) echo "checking for XIM" 1>&6 -echo "configure:6666: checking for XIM" >&5 +echo "configure:6683: checking for XIM" >&5 echo $ac_n "checking for XmImMbLookupString in -lXm""... $ac_c" 1>&6 -echo "configure:6669: checking for XmImMbLookupString in -lXm" >&5 +echo "configure:6686: checking for XmImMbLookupString in -lXm" >&5 ac_lib_var=`echo Xm'_'XmImMbLookupString | sed 'y%./+-%__p_%'` xe_check_libs=" -lXm " cat > conftest.$ac_ext <<EOF -#line 6674 "configure" +#line 6691 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -6681,7 +6698,7 @@ XmImMbLookupString() ; return 0; } EOF -if { (eval echo configure:6685: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6702: \"$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 @@ -6744,15 +6761,15 @@ fi else case "$with_xfs" in "yes" ) echo "checking for XFontSet" 1>&6 -echo "configure:6748: checking for XFontSet" >&5 +echo "configure:6765: checking for XFontSet" >&5 echo $ac_n "checking for XmbDrawString in -lX11""... $ac_c" 1>&6 -echo "configure:6751: checking for XmbDrawString in -lX11" >&5 +echo "configure:6768: checking for XmbDrawString in -lX11" >&5 ac_lib_var=`echo X11'_'XmbDrawString | sed 'y%./+-%__p_%'` xe_check_libs=" -lX11 " cat > conftest.$ac_ext <<EOF -#line 6756 "configure" +#line 6773 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -6763,7 +6780,7 @@ XmbDrawString() ; return 0; } EOF -if { (eval echo configure:6767: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6784: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -6802,15 +6819,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:6806: checking for wnn/jllib.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 6809 "configure" +echo "configure:6823: checking for wnn/jllib.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 6826 "configure" #include "confdefs.h" #include <wnn/jllib.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:6814: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:6831: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -6835,10 +6852,10 @@ for ac_func in crypt do echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 -echo "configure:6839: checking for $ac_func" >&5 - -cat > conftest.$ac_ext <<EOF -#line 6842 "configure" +echo "configure:6856: checking for $ac_func" >&5 + +cat > conftest.$ac_ext <<EOF +#line 6859 "configure" #include "confdefs.h" /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func(); below. */ @@ -6861,7 +6878,7 @@ ; return 0; } EOF -if { (eval echo configure:6865: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6882: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else @@ -6890,12 +6907,12 @@ test "$ac_cv_func_crypt" != "yes" && { echo $ac_n "checking for crypt in -lcrypt""... $ac_c" 1>&6 -echo "configure:6894: checking for crypt in -lcrypt" >&5 +echo "configure:6911: checking for crypt in -lcrypt" >&5 ac_lib_var=`echo crypt'_'crypt | sed 'y%./+-%__p_%'` xe_check_libs=" -lcrypt " cat > conftest.$ac_ext <<EOF -#line 6899 "configure" +#line 6916 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -6906,7 +6923,7 @@ crypt() ; return 0; } EOF -if { (eval echo configure:6910: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6927: \"$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 @@ -6940,12 +6957,12 @@ fi test -z "$with_wnn" && { echo $ac_n "checking for jl_dic_list_e in -lwnn""... $ac_c" 1>&6 -echo "configure:6944: checking for jl_dic_list_e in -lwnn" >&5 +echo "configure:6961: checking for jl_dic_list_e in -lwnn" >&5 ac_lib_var=`echo wnn'_'jl_dic_list_e | sed 'y%./+-%__p_%'` xe_check_libs=" -lwnn " cat > conftest.$ac_ext <<EOF -#line 6949 "configure" +#line 6966 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -6956,7 +6973,7 @@ jl_dic_list_e() ; return 0; } EOF -if { (eval echo configure:6960: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6977: \"$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 @@ -6993,12 +7010,12 @@ fi echo $ac_n "checking for jl_fi_dic_list in -lwnn""... $ac_c" 1>&6 -echo "configure:6997: checking for jl_fi_dic_list in -lwnn" >&5 +echo "configure:7014: checking for jl_fi_dic_list in -lwnn" >&5 ac_lib_var=`echo wnn'_'jl_fi_dic_list | sed 'y%./+-%__p_%'` xe_check_libs=" -lwnn " cat > conftest.$ac_ext <<EOF -#line 7002 "configure" +#line 7019 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -7009,7 +7026,7 @@ jl_fi_dic_list() ; return 0; } EOF -if { (eval echo configure:7013: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7030: \"$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 @@ -7041,15 +7058,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:7045: checking for canna/RK.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 7048 "configure" +echo "configure:7062: checking for canna/RK.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 7065 "configure" #include "confdefs.h" #include <canna/RK.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:7053: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:7070: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -7072,12 +7089,12 @@ } test -z "$with_canna" && { echo $ac_n "checking for RkBgnBun in -lRKC""... $ac_c" 1>&6 -echo "configure:7076: checking for RkBgnBun in -lRKC" >&5 +echo "configure:7093: checking for RkBgnBun in -lRKC" >&5 ac_lib_var=`echo RKC'_'RkBgnBun | sed 'y%./+-%__p_%'` xe_check_libs=" -lRKC " cat > conftest.$ac_ext <<EOF -#line 7081 "configure" +#line 7098 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -7088,7 +7105,7 @@ RkBgnBun() ; return 0; } EOF -if { (eval echo configure:7092: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7109: \"$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 @@ -7111,12 +7128,12 @@ } test -z "$with_canna" && { echo $ac_n "checking for jrKanjiControl in -lcanna""... $ac_c" 1>&6 -echo "configure:7115: checking for jrKanjiControl in -lcanna" >&5 +echo "configure:7132: checking for jrKanjiControl in -lcanna" >&5 ac_lib_var=`echo canna'_'jrKanjiControl | sed 'y%./+-%__p_%'` xe_check_libs=" -lcanna " cat > conftest.$ac_ext <<EOF -#line 7120 "configure" +#line 7137 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -7127,7 +7144,7 @@ jrKanjiControl() ; return 0; } EOF -if { (eval echo configure:7131: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7148: \"$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 @@ -7176,12 +7193,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:7180: checking for layout_object_getvalue in -li18n" >&5 +echo "configure:7197: checking for layout_object_getvalue in -li18n" >&5 ac_lib_var=`echo i18n'_'layout_object_getvalue | sed 'y%./+-%__p_%'` xe_check_libs=" -li18n " cat > conftest.$ac_ext <<EOF -#line 7185 "configure" +#line 7202 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -7192,7 +7209,7 @@ layout_object_getvalue() ; return 0; } EOF -if { (eval echo configure:7196: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7213: \"$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 @@ -7265,10 +7282,10 @@ for ac_func in acosh asinh atanh 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 strcasecmp strerror tzset ulimit usleep utimes waitpid do echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 -echo "configure:7269: checking for $ac_func" >&5 - -cat > conftest.$ac_ext <<EOF -#line 7272 "configure" +echo "configure:7286: checking for $ac_func" >&5 + +cat > conftest.$ac_ext <<EOF +#line 7289 "configure" #include "confdefs.h" /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func(); below. */ @@ -7291,7 +7308,7 @@ ; return 0; } EOF -if { (eval echo configure:7295: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7312: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else @@ -7321,17 +7338,17 @@ case "$opsys" in - linux* | decosf4-0* | aix4* ) extra_objs="$extra_objs realpath.o" && if test "$extra_verbose" = "yes"; then + linuxaout* | bsdos3* | freebsd* | decosf4-0* | aix4* ) extra_objs="$extra_objs realpath.o" && if test "$extra_verbose" = "yes"; then echo " xemacs will be linked with \"realpath.o\"" fi ;; * ) for ac_func in realpath do echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 -echo "configure:7332: checking for $ac_func" >&5 - -cat > conftest.$ac_ext <<EOF -#line 7335 "configure" +echo "configure:7349: checking for $ac_func" >&5 + +cat > conftest.$ac_ext <<EOF +#line 7352 "configure" #include "confdefs.h" /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func(); below. */ @@ -7354,7 +7371,7 @@ ; return 0; } EOF -if { (eval echo configure:7358: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7375: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else @@ -7387,16 +7404,16 @@ esac echo $ac_n "checking whether netdb declares h_errno""... $ac_c" 1>&6 -echo "configure:7391: checking whether netdb declares h_errno" >&5 -cat > conftest.$ac_ext <<EOF -#line 7393 "configure" +echo "configure:7408: checking whether netdb declares h_errno" >&5 +cat > conftest.$ac_ext <<EOF +#line 7410 "configure" #include "confdefs.h" #include <netdb.h> int main() { return h_errno; ; return 0; } EOF -if { (eval echo configure:7400: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7417: \"$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 @@ -7416,16 +7433,16 @@ rm -f conftest* echo $ac_n "checking for sigsetjmp""... $ac_c" 1>&6 -echo "configure:7420: checking for sigsetjmp" >&5 -cat > conftest.$ac_ext <<EOF -#line 7422 "configure" +echo "configure:7437: checking for sigsetjmp" >&5 +cat > conftest.$ac_ext <<EOF +#line 7439 "configure" #include "confdefs.h" #include <setjmp.h> int main() { sigjmp_buf bar; sigsetjmp (bar, 0); ; return 0; } EOF -if { (eval echo configure:7429: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:7446: \"$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 @@ -7445,11 +7462,11 @@ rm -f conftest* echo $ac_n "checking whether localtime caches TZ""... $ac_c" 1>&6 -echo "configure:7449: checking whether localtime caches TZ" >&5 +echo "configure:7466: checking whether localtime caches TZ" >&5 if test "$ac_cv_func_tzset" = "yes"; then cat > conftest.$ac_ext <<EOF -#line 7453 "configure" +#line 7470 "configure" #include "confdefs.h" #include <time.h> #if STDC_HEADERS @@ -7484,7 +7501,7 @@ exit (0); } EOF -if { (eval echo configure:7488: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:7505: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then emacs_cv_localtime_cache=no else @@ -7513,9 +7530,9 @@ if test "$HAVE_TIMEVAL" = "yes"; then echo $ac_n "checking whether gettimeofday cannot accept two arguments""... $ac_c" 1>&6 -echo "configure:7517: checking whether gettimeofday cannot accept two arguments" >&5 -cat > conftest.$ac_ext <<EOF -#line 7519 "configure" +echo "configure:7534: checking whether gettimeofday cannot accept two arguments" >&5 +cat > conftest.$ac_ext <<EOF +#line 7536 "configure" #include "confdefs.h" #ifdef TIME_WITH_SYS_TIME @@ -7537,7 +7554,7 @@ ; return 0; } EOF -if { (eval echo configure:7541: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7558: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* echo "$ac_t""no" 1>&6 else @@ -7558,9 +7575,9 @@ fi echo $ac_n "checking whether the timezone variable is already declared""... $ac_c" 1>&6 -echo "configure:7562: checking whether the timezone variable is already declared" >&5 -cat > conftest.$ac_ext <<EOF -#line 7564 "configure" +echo "configure:7579: checking whether the timezone variable is already declared" >&5 +cat > conftest.$ac_ext <<EOF +#line 7581 "configure" #include "confdefs.h" #ifdef TIME_WITH_SYS_TIME @@ -7580,7 +7597,7 @@ ; return 0; } EOF -if { (eval echo configure:7584: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7601: \"$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 @@ -7602,19 +7619,19 @@ echo $ac_n "checking for inline""... $ac_c" 1>&6 -echo "configure:7606: checking for inline" >&5 +echo "configure:7623: checking for inline" >&5 ac_cv_c_inline=no for ac_kw in inline __inline__ __inline; do cat > conftest.$ac_ext <<EOF -#line 7611 "configure" +#line 7628 "configure" #include "confdefs.h" int main() { } $ac_kw foo() { ; return 0; } EOF -if { (eval echo configure:7618: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:7635: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_c_inline=$ac_kw; break else @@ -7664,17 +7681,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:7668: checking for working alloca.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 7671 "configure" +echo "configure:7685: checking for working alloca.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 7688 "configure" #include "confdefs.h" #include <alloca.h> int main() { char *p = alloca(2 * sizeof(int)); ; return 0; } EOF -if { (eval echo configure:7678: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7695: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* ac_cv_header_alloca_h=yes else @@ -7698,10 +7715,10 @@ fi echo $ac_n "checking for alloca""... $ac_c" 1>&6 -echo "configure:7702: checking for alloca" >&5 - -cat > conftest.$ac_ext <<EOF -#line 7705 "configure" +echo "configure:7719: checking for alloca" >&5 + +cat > conftest.$ac_ext <<EOF +#line 7722 "configure" #include "confdefs.h" #ifdef __GNUC__ @@ -7724,7 +7741,7 @@ char *p = (char *) alloca(1); ; return 0; } EOF -if { (eval echo configure:7728: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7745: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* ac_cv_func_alloca_works=yes else @@ -7763,10 +7780,10 @@ echo $ac_n "checking whether alloca needs Cray hooks""... $ac_c" 1>&6 -echo "configure:7767: checking whether alloca needs Cray hooks" >&5 - -cat > conftest.$ac_ext <<EOF -#line 7770 "configure" +echo "configure:7784: checking whether alloca needs Cray hooks" >&5 + +cat > conftest.$ac_ext <<EOF +#line 7787 "configure" #include "confdefs.h" #if defined(CRAY) && ! defined(CRAY2) webecray @@ -7790,10 +7807,10 @@ if test $ac_cv_os_cray = yes; then for ac_func in _getb67 GETB67 getb67; do echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 -echo "configure:7794: checking for $ac_func" >&5 - -cat > conftest.$ac_ext <<EOF -#line 7797 "configure" +echo "configure:7811: checking for $ac_func" >&5 + +cat > conftest.$ac_ext <<EOF +#line 7814 "configure" #include "confdefs.h" /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func(); below. */ @@ -7816,7 +7833,7 @@ ; return 0; } EOF -if { (eval echo configure:7820: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7837: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else @@ -7846,10 +7863,10 @@ fi echo $ac_n "checking stack direction for C alloca""... $ac_c" 1>&6 -echo "configure:7850: checking stack direction for C alloca" >&5 - -cat > conftest.$ac_ext <<EOF -#line 7853 "configure" +echo "configure:7867: checking stack direction for C alloca" >&5 + +cat > conftest.$ac_ext <<EOF +#line 7870 "configure" #include "confdefs.h" find_stack_direction () { @@ -7868,7 +7885,7 @@ exit (find_stack_direction() < 0); } EOF -if { (eval echo configure:7872: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:7889: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ac_cv_c_stack_direction=1 else @@ -7896,15 +7913,15 @@ ac_safe=`echo "vfork.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for vfork.h""... $ac_c" 1>&6 -echo "configure:7900: checking for vfork.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 7903 "configure" +echo "configure:7917: checking for vfork.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 7920 "configure" #include "confdefs.h" #include <vfork.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:7908: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:7925: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -7932,10 +7949,10 @@ fi echo $ac_n "checking for working vfork""... $ac_c" 1>&6 -echo "configure:7936: checking for working vfork" >&5 - -cat > conftest.$ac_ext <<EOF -#line 7939 "configure" +echo "configure:7953: checking for working vfork" >&5 + +cat > conftest.$ac_ext <<EOF +#line 7956 "configure" #include "confdefs.h" /* Thanks to Paul Eggert for this test. */ #include <stdio.h> @@ -8030,7 +8047,7 @@ } } EOF -if { (eval echo configure:8034: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:8051: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ac_cv_func_vfork_works=yes else @@ -8055,10 +8072,10 @@ echo $ac_n "checking for working strcoll""... $ac_c" 1>&6 -echo "configure:8059: checking for working strcoll" >&5 - -cat > conftest.$ac_ext <<EOF -#line 8062 "configure" +echo "configure:8076: checking for working strcoll" >&5 + +cat > conftest.$ac_ext <<EOF +#line 8079 "configure" #include "confdefs.h" #include <string.h> main () @@ -8068,7 +8085,7 @@ strcoll ("123", "456") >= 0); } EOF -if { (eval echo configure:8072: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:8089: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ac_cv_func_strcoll_works=yes else @@ -8095,10 +8112,10 @@ for ac_func in getpgrp do echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 -echo "configure:8099: checking for $ac_func" >&5 - -cat > conftest.$ac_ext <<EOF -#line 8102 "configure" +echo "configure:8116: checking for $ac_func" >&5 + +cat > conftest.$ac_ext <<EOF +#line 8119 "configure" #include "confdefs.h" /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func(); below. */ @@ -8121,7 +8138,7 @@ ; return 0; } EOF -if { (eval echo configure:8125: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8142: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else @@ -8149,10 +8166,10 @@ done echo $ac_n "checking whether getpgrp takes no argument""... $ac_c" 1>&6 -echo "configure:8153: checking whether getpgrp takes no argument" >&5 - -cat > conftest.$ac_ext <<EOF -#line 8156 "configure" +echo "configure:8170: checking whether getpgrp takes no argument" >&5 + +cat > conftest.$ac_ext <<EOF +#line 8173 "configure" #include "confdefs.h" /* @@ -8207,7 +8224,7 @@ } EOF -if { (eval echo configure:8211: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:8228: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ac_cv_func_getpgrp_void=yes else @@ -8233,10 +8250,10 @@ echo $ac_n "checking for working mmap""... $ac_c" 1>&6 -echo "configure:8237: checking for working mmap" >&5 +echo "configure:8254: checking for working mmap" >&5 case "$opsys" in ultrix* ) have_mmap=no ;; *) cat > conftest.$ac_ext <<EOF -#line 8240 "configure" +#line 8257 "configure" #include "confdefs.h" #include <stdio.h> #include <unistd.h> @@ -8269,7 +8286,7 @@ return 1; } EOF -if { (eval echo configure:8273: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:8290: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then have_mmap=yes else @@ -8303,15 +8320,15 @@ ac_safe=`echo "termios.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for termios.h""... $ac_c" 1>&6 -echo "configure:8307: checking for termios.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 8310 "configure" +echo "configure:8324: checking for termios.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 8327 "configure" #include "confdefs.h" #include <termios.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8315: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8332: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8354,15 +8371,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:8358: checking for termio.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 8361 "configure" +echo "configure:8375: checking for termio.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 8378 "configure" #include "confdefs.h" #include <termio.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8366: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8383: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8394,10 +8411,10 @@ echo $ac_n "checking for socket""... $ac_c" 1>&6 -echo "configure:8398: checking for socket" >&5 - -cat > conftest.$ac_ext <<EOF -#line 8401 "configure" +echo "configure:8415: checking for socket" >&5 + +cat > conftest.$ac_ext <<EOF +#line 8418 "configure" #include "confdefs.h" /* System header to define __stub macros and hopefully few prototypes, which can conflict with char socket(); below. */ @@ -8420,7 +8437,7 @@ ; return 0; } EOF -if { (eval echo configure:8424: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8441: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_socket=yes" else @@ -8435,15 +8452,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:8439: checking for netinet/in.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 8442 "configure" +echo "configure:8456: checking for netinet/in.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 8459 "configure" #include "confdefs.h" #include <netinet/in.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8447: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8464: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8460,15 +8477,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:8464: checking for arpa/inet.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 8467 "configure" +echo "configure:8481: checking for arpa/inet.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 8484 "configure" #include "confdefs.h" #include <arpa/inet.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8472: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8489: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8493,9 +8510,9 @@ } echo $ac_n "checking "for sun_len member in struct sockaddr_un"""... $ac_c" 1>&6 -echo "configure:8497: checking "for sun_len member in struct sockaddr_un"" >&5 +echo "configure:8514: checking "for sun_len member in struct sockaddr_un"" >&5 cat > conftest.$ac_ext <<EOF -#line 8499 "configure" +#line 8516 "configure" #include "confdefs.h" #include <sys/types.h> @@ -8506,7 +8523,7 @@ static struct sockaddr_un x; x.sun_len = 1; ; return 0; } EOF -if { (eval echo configure:8510: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8527: \"$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 @@ -8537,10 +8554,10 @@ echo $ac_n "checking for msgget""... $ac_c" 1>&6 -echo "configure:8541: checking for msgget" >&5 - -cat > conftest.$ac_ext <<EOF -#line 8544 "configure" +echo "configure:8558: checking for msgget" >&5 + +cat > conftest.$ac_ext <<EOF +#line 8561 "configure" #include "confdefs.h" /* System header to define __stub macros and hopefully few prototypes, which can conflict with char msgget(); below. */ @@ -8563,7 +8580,7 @@ ; return 0; } EOF -if { (eval echo configure:8567: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8584: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_msgget=yes" else @@ -8578,15 +8595,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:8582: checking for sys/ipc.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 8585 "configure" +echo "configure:8599: checking for sys/ipc.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 8602 "configure" #include "confdefs.h" #include <sys/ipc.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8590: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8607: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8603,15 +8620,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:8607: checking for sys/msg.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 8610 "configure" +echo "configure:8624: checking for sys/msg.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 8627 "configure" #include "confdefs.h" #include <sys/msg.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8615: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8632: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8649,15 +8666,15 @@ ac_safe=`echo "dirent.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for dirent.h""... $ac_c" 1>&6 -echo "configure:8653: checking for dirent.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 8656 "configure" +echo "configure:8670: checking for dirent.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 8673 "configure" #include "confdefs.h" #include <dirent.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8661: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8678: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8684,15 +8701,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:8688: checking for sys/dir.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 8691 "configure" +echo "configure:8705: checking for sys/dir.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 8708 "configure" #include "confdefs.h" #include <sys/dir.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8696: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8713: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8725,15 +8742,15 @@ ac_safe=`echo "nlist.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for nlist.h""... $ac_c" 1>&6 -echo "configure:8729: checking for nlist.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 8732 "configure" +echo "configure:8746: checking for nlist.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 8749 "configure" #include "confdefs.h" #include <nlist.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8737: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8754: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8763,7 +8780,7 @@ echo "checking "for sound support"" 1>&6 -echo "configure:8767: checking "for sound support"" >&5 +echo "configure:8784: checking "for sound support"" >&5 case "$with_sound" in native | both ) with_native_sound=yes;; nas | no ) with_native_sound=no;; @@ -8774,15 +8791,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:8778: checking for multimedia/audio_device.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 8781 "configure" +echo "configure:8795: checking for multimedia/audio_device.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 8798 "configure" #include "confdefs.h" #include <multimedia/audio_device.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8786: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8803: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8830,12 +8847,12 @@ if test -z "$native_sound_lib"; then echo $ac_n "checking for ALopenport in -laudio""... $ac_c" 1>&6 -echo "configure:8834: checking for ALopenport in -laudio" >&5 +echo "configure:8851: checking for ALopenport in -laudio" >&5 ac_lib_var=`echo audio'_'ALopenport | sed 'y%./+-%__p_%'` xe_check_libs=" -laudio " cat > conftest.$ac_ext <<EOF -#line 8839 "configure" +#line 8856 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -8846,7 +8863,7 @@ ALopenport() ; return 0; } EOF -if { (eval echo configure:8850: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8867: \"$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 @@ -8877,12 +8894,12 @@ if test -z "$native_sound_lib"; then echo $ac_n "checking for AOpenAudio in -lAlib""... $ac_c" 1>&6 -echo "configure:8881: checking for AOpenAudio in -lAlib" >&5 +echo "configure:8898: checking for AOpenAudio in -lAlib" >&5 ac_lib_var=`echo Alib'_'AOpenAudio | sed 'y%./+-%__p_%'` xe_check_libs=" -lAlib " cat > conftest.$ac_ext <<EOF -#line 8886 "configure" +#line 8903 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -8893,7 +8910,7 @@ AOpenAudio() ; return 0; } EOF -if { (eval echo configure:8897: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8914: \"$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 @@ -8931,15 +8948,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:8935: checking for ${dir}/soundcard.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 8938 "configure" +echo "configure:8952: checking for ${dir}/soundcard.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 8955 "configure" #include "confdefs.h" #include <${dir}/soundcard.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8943: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8960: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -9009,7 +9026,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 -#line 9013 "configure" +#line 9030 "configure" #include "confdefs.h" #include <audio/Xtutil.h> EOF @@ -9036,7 +9053,7 @@ if test "$with_tty" = "yes" ; then echo "checking for TTY-related features" 1>&6 -echo "configure:9040: checking for TTY-related features" >&5 +echo "configure:9057: checking for TTY-related features" >&5 { test "$extra_verbose" = "yes" && cat << \EOF Defining HAVE_TTY EOF @@ -9052,12 +9069,12 @@ if test -z "$with_ncurses"; then echo $ac_n "checking for tgetent in -lncurses""... $ac_c" 1>&6 -echo "configure:9056: checking for tgetent in -lncurses" >&5 +echo "configure:9073: checking for tgetent in -lncurses" >&5 ac_lib_var=`echo ncurses'_'tgetent | sed 'y%./+-%__p_%'` xe_check_libs=" -lncurses " cat > conftest.$ac_ext <<EOF -#line 9061 "configure" +#line 9078 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -9068,7 +9085,7 @@ tgetent() ; return 0; } EOF -if { (eval echo configure:9072: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9089: \"$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 @@ -9101,15 +9118,15 @@ ac_safe=`echo "ncurses/curses.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for ncurses/curses.h""... $ac_c" 1>&6 -echo "configure:9105: checking for ncurses/curses.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 9108 "configure" +echo "configure:9122: checking for ncurses/curses.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 9125 "configure" #include "confdefs.h" #include <ncurses/curses.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:9113: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:9130: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -9131,15 +9148,15 @@ ac_safe=`echo "ncurses/term.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for ncurses/term.h""... $ac_c" 1>&6 -echo "configure:9135: checking for ncurses/term.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 9138 "configure" +echo "configure:9152: checking for ncurses/term.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 9155 "configure" #include "confdefs.h" #include <ncurses/term.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:9143: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:9160: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -9169,15 +9186,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:9173: checking for ncurses/curses.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 9176 "configure" +echo "configure:9190: checking for ncurses/curses.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 9193 "configure" #include "confdefs.h" #include <ncurses/curses.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:9181: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:9198: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -9212,12 +9229,12 @@ for lib in curses termlib termcap; do echo $ac_n "checking for tgetent in -l$lib""... $ac_c" 1>&6 -echo "configure:9216: checking for tgetent in -l$lib" >&5 +echo "configure:9233: checking for tgetent in -l$lib" >&5 ac_lib_var=`echo $lib'_'tgetent | sed 'y%./+-%__p_%'` xe_check_libs=" -l$lib " cat > conftest.$ac_ext <<EOF -#line 9221 "configure" +#line 9238 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -9228,7 +9245,7 @@ tgetent() ; return 0; } EOF -if { (eval echo configure:9232: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9249: \"$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 @@ -9259,12 +9276,12 @@ else echo $ac_n "checking for tgetent in -lcurses""... $ac_c" 1>&6 -echo "configure:9263: checking for tgetent in -lcurses" >&5 +echo "configure:9280: checking for tgetent in -lcurses" >&5 ac_lib_var=`echo curses'_'tgetent | sed 'y%./+-%__p_%'` xe_check_libs=" -lcurses " cat > conftest.$ac_ext <<EOF -#line 9268 "configure" +#line 9285 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -9275,7 +9292,7 @@ tgetent() ; return 0; } EOF -if { (eval echo configure:9279: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9296: \"$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 @@ -9293,12 +9310,12 @@ else echo "$ac_t""no" 1>&6 echo $ac_n "checking for tgetent in -ltermcap""... $ac_c" 1>&6 -echo "configure:9297: checking for tgetent in -ltermcap" >&5 +echo "configure:9314: checking for tgetent in -ltermcap" >&5 ac_lib_var=`echo termcap'_'tgetent | sed 'y%./+-%__p_%'` xe_check_libs=" -ltermcap " cat > conftest.$ac_ext <<EOF -#line 9302 "configure" +#line 9319 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -9309,7 +9326,7 @@ tgetent() ; return 0; } EOF -if { (eval echo configure:9313: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9330: \"$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 @@ -9357,15 +9374,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:9361: checking for gpm.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 9364 "configure" +echo "configure:9378: checking for gpm.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 9381 "configure" #include "confdefs.h" #include <gpm.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:9369: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:9386: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -9388,12 +9405,12 @@ } test -z "$with_gpm" && { echo $ac_n "checking for Gpm_Open in -lgpm""... $ac_c" 1>&6 -echo "configure:9392: checking for Gpm_Open in -lgpm" >&5 +echo "configure:9409: checking for Gpm_Open in -lgpm" >&5 ac_lib_var=`echo gpm'_'Gpm_Open | sed 'y%./+-%__p_%'` xe_check_libs=" -lgpm " cat > conftest.$ac_ext <<EOF -#line 9397 "configure" +#line 9414 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -9404,7 +9421,7 @@ Gpm_Open() ; return 0; } EOF -if { (eval echo configure:9408: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9425: \"$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 @@ -9453,17 +9470,17 @@ echo "checking for database support" 1>&6 -echo "configure:9457: checking for database support" >&5 +echo "configure:9474: checking for database support" >&5 if test "$with_database_gnudbm" != "no"; then echo $ac_n "checking for dbm_open in -lgdbm""... $ac_c" 1>&6 -echo "configure:9462: checking for dbm_open in -lgdbm" >&5 +echo "configure:9479: checking for dbm_open in -lgdbm" >&5 ac_lib_var=`echo gdbm'_'dbm_open | sed 'y%./+-%__p_%'` xe_check_libs=" -lgdbm " cat > conftest.$ac_ext <<EOF -#line 9467 "configure" +#line 9484 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -9474,7 +9491,7 @@ dbm_open() ; return 0; } EOF -if { (eval echo configure:9478: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9495: \"$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 @@ -9496,10 +9513,10 @@ if test "$with_database_gnudbm" != "yes"; then echo $ac_n "checking for dbm_open""... $ac_c" 1>&6 -echo "configure:9500: checking for dbm_open" >&5 - -cat > conftest.$ac_ext <<EOF -#line 9503 "configure" +echo "configure:9517: checking for dbm_open" >&5 + +cat > conftest.$ac_ext <<EOF +#line 9520 "configure" #include "confdefs.h" /* System header to define __stub macros and hopefully few prototypes, which can conflict with char dbm_open(); below. */ @@ -9522,7 +9539,7 @@ ; return 0; } EOF -if { (eval echo configure:9526: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9543: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_dbm_open=yes" else @@ -9558,10 +9575,10 @@ if test "$with_database_dbm" != "no"; then echo $ac_n "checking for dbm_open""... $ac_c" 1>&6 -echo "configure:9562: checking for dbm_open" >&5 - -cat > conftest.$ac_ext <<EOF -#line 9565 "configure" +echo "configure:9579: checking for dbm_open" >&5 + +cat > conftest.$ac_ext <<EOF +#line 9582 "configure" #include "confdefs.h" /* System header to define __stub macros and hopefully few prototypes, which can conflict with char dbm_open(); below. */ @@ -9584,7 +9601,7 @@ ; return 0; } EOF -if { (eval echo configure:9588: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9605: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_dbm_open=yes" else @@ -9605,12 +9622,12 @@ if test "$need_libdbm" != "no"; then echo $ac_n "checking for dbm_open in -ldbm""... $ac_c" 1>&6 -echo "configure:9609: checking for dbm_open in -ldbm" >&5 +echo "configure:9626: checking for dbm_open in -ldbm" >&5 ac_lib_var=`echo dbm'_'dbm_open | sed 'y%./+-%__p_%'` xe_check_libs=" -ldbm " cat > conftest.$ac_ext <<EOF -#line 9614 "configure" +#line 9631 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -9621,7 +9638,7 @@ dbm_open() ; return 0; } EOF -if { (eval echo configure:9625: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9642: \"$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 @@ -9658,10 +9675,10 @@ if test "$with_database_berkdb" != "no"; then echo $ac_n "checking for dbopen""... $ac_c" 1>&6 -echo "configure:9662: checking for dbopen" >&5 - -cat > conftest.$ac_ext <<EOF -#line 9665 "configure" +echo "configure:9679: checking for dbopen" >&5 + +cat > conftest.$ac_ext <<EOF +#line 9682 "configure" #include "confdefs.h" /* System header to define __stub macros and hopefully few prototypes, which can conflict with char dbopen(); below. */ @@ -9684,7 +9701,7 @@ ; return 0; } EOF -if { (eval echo configure:9688: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9705: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_dbopen=yes" else @@ -9705,12 +9722,12 @@ if test "$need_libdb" != "no"; then echo $ac_n "checking for dbopen in -ldb""... $ac_c" 1>&6 -echo "configure:9709: checking for dbopen in -ldb" >&5 +echo "configure:9726: checking for dbopen in -ldb" >&5 ac_lib_var=`echo db'_'dbopen | sed 'y%./+-%__p_%'` xe_check_libs=" -ldb " cat > conftest.$ac_ext <<EOF -#line 9714 "configure" +#line 9731 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -9721,7 +9738,7 @@ dbopen() ; return 0; } EOF -if { (eval echo configure:9725: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9742: \"$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 @@ -9745,7 +9762,7 @@ if test "$with_database_berkdb" = "yes"; then for path in "db/db.h" "db.h"; do cat > conftest.$ac_ext <<EOF -#line 9749 "configure" +#line 9766 "configure" #include "confdefs.h" #ifdef HAVE_INTTYPES_H #define __BIT_TYPES_DEFINED__ @@ -9763,7 +9780,7 @@ ; return 0; } EOF -if { (eval echo configure:9767: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:9784: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* db_h_path="$path"; break else @@ -9815,12 +9832,12 @@ if test "$with_socks" = "yes"; then echo $ac_n "checking for SOCKSinit in -lsocks""... $ac_c" 1>&6 -echo "configure:9819: checking for SOCKSinit in -lsocks" >&5 +echo "configure:9836: checking for SOCKSinit in -lsocks" >&5 ac_lib_var=`echo socks'_'SOCKSinit | sed 'y%./+-%__p_%'` xe_check_libs=" -lsocks " cat > conftest.$ac_ext <<EOF -#line 9824 "configure" +#line 9841 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -9831,7 +9848,7 @@ SOCKSinit() ; return 0; } EOF -if { (eval echo configure:9835: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9852: \"$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 @@ -10317,6 +10334,9 @@ if test -n "$site_libraries"; then echo " Additional libraries: $site_libraries" fi +if test -n "$site_prefixes"; then + echo " Additional prefixes: $site_prefixes" +fi if test -n "$runpath"; then echo " Runtime library search path: $runpath" fi @@ -10349,7 +10369,7 @@ test "$with_database_berkdb" = yes && echo " Compiling in support for Berkeley DB." test "$with_database_dbm" = yes && echo " Compiling in support for DBM." -test "$with_database_gnudbm" = yes && echo " Compiling in support for GNU DBM." +test "$with_database_gnudbm" = yes && echo " Compiling in support for DBM." test "$with_ncurses" = yes && echo " Compiling in support for ncurses." test "$with_gpm" = yes && echo " Compiling in support for GPM (General Purpose Mouse)."
--- a/configure.in Mon Aug 13 10:03:54 2007 +0200 +++ b/configure.in Mon Aug 13 10:04:58 2007 +0200 @@ -399,6 +399,9 @@ --cflags=FLAGS Compiler flags. Overrides environment variable CFLAGS. --site-includes=PATH List of directories to search first for header files. --site-libraries=PATH List of directories to search first for libraries. +--site-prefixes=PATH List of directories to search for include/ and lib/ + subdirectories, just after 'site-includes' and + 'site-libraries'. --site-runtime-libraries=PATH List of ALL directories to search for dynamically linked libraries at run time. @@ -731,6 +734,7 @@ x_libraries | \ site_includes | \ site_libraries | \ + site_prefixes | \ site_runtime_libraries ) dnl If the value was omitted, get it from the next argument. if test "$valomitted" = "yes" ; then @@ -975,6 +979,7 @@ [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 @@ -1894,7 +1899,7 @@ [[$1_tmp]="$[$1]"; [$1]="" for arg in $[$1_tmp]; do case "$arg" in - -L* | -l* | -R* | -u* | -Wl* | -f* | -B*) [$1]="$[$1] $arg" ;; + -L* | -l* | -R* | -u* | -Wl* | -f*) [$1]="$[$1] $arg" ;; -Xlinker* ) ;; * ) [$1]="$[$1] -Xlinker $arg" ;; esac @@ -1934,7 +1939,7 @@ dnl AIX needs various hacks to make static linking work. dnl This can go away if we ever figure out how to get dynamic linking on AIX. start_flags="-Wl,-bnso,-bnodelcsect" - test "$GCC" = "yes" && start_flags="-B/bin/ ${aixflags}" + test "$GCC" = "yes" && start_flags="-B/bin/ ${start_flags}" for f in "/lib/syscalls.exp" "$srcdir/src/m/ibmrs6000.inp"; do if test -r "$f"; then start_flags="${start_flags},-bI:${f}"; fi done @@ -1960,6 +1965,23 @@ 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 --site-libraries (multiple dirs) if test -n "$site_libraries"; then for arg in $site_libraries; do @@ -2591,7 +2613,7 @@ fi dnl autodetect ImageMagick - test -z "$with_imagick" && { AC_CHECK_HEADER(magick.h, ,with_imagick=no) } + test -z "$with_imagick" && { AC_CHECK_HEADER(magick/magick.h, ,with_imagick=no) } test -z "$with_imagick" && { AC_CHECK_LIB(Magick, MogrifyImage,[:],with_imagick=no) } test -z "$with_imagick" && with_imagick=yes if test "$with_imagick" = "yes"; then @@ -2795,10 +2817,12 @@ dnl realpath is buggy on linux, decosf and aix4 dnl The realpath() in linux libc (4.6.27) sometimes fails with ELOOP. +dnl The realpath in ELF linux libc's is O.K. dnl For example, call realpath on a file thirty-five or so directories deep dnl and you get ELOOP even if no symlinks at all are involved. +dnl Reports as of 11/1997 indicate BSDi has problems too. case "$opsys" in - linux* | decosf4-0* | aix4* ) XE_ADD_OBJS(realpath.o) ;; + linuxaout* | bsdos3* | freebsd* | decosf4-0* | aix4* ) XE_ADD_OBJS(realpath.o) ;; * ) AC_CHECK_FUNCS(realpath) test "$ac_cv_func_realpath" != "yes" && XE_ADD_OBJS(realpath.o) ;; @@ -3512,6 +3536,9 @@ if test -n "$site_libraries"; then echo " Additional libraries: $site_libraries" fi +if test -n "$site_prefixes"; then + echo " Additional prefixes: $site_prefixes" +fi if test -n "$runpath"; then echo " Runtime library search path: $runpath" fi @@ -3544,7 +3571,7 @@ test "$with_database_berkdb" = yes && echo " Compiling in support for Berkeley DB." test "$with_database_dbm" = yes && echo " Compiling in support for DBM." -test "$with_database_gnudbm" = yes && echo " Compiling in support for GNU DBM." +test "$with_database_gnudbm" = yes && echo " Compiling in support for DBM." test "$with_ncurses" = yes && echo " Compiling in support for ncurses." test "$with_gpm" = yes && echo " Compiling in support for GPM (General Purpose Mouse)."
--- a/etc/BETA Mon Aug 13 10:03:54 2007 +0200 +++ b/etc/BETA Mon Aug 13 10:04:58 2007 +0200 @@ -217,9 +217,9 @@ M-x cd to the appropriate directory, and issue the command `C-u M-!' from within XEmacs. -* XEmacs 20.3 packages +* XEmacs 20.4 packages -XEmacs 20.3 has added the concept of installable packages searched prior +XEmacs 20.4 has added the concept of installable packages searched prior to dump time when building. Packages are searched by default under /usr/local/lib/xemacs/packages/. @@ -254,7 +254,7 @@ AUCTeX and Gnus have package tarballs in - ftp://ftp.xemacs.org/pub/beta/packages-20.3/ + ftp://ftp.xemacs.org/pub/beta/xemacs-20.4/packages/ that you can simply untar in a package directory to install. Karl Hegbloom has a set of packages in @@ -265,7 +265,7 @@ ===================================== The packages directory - ftp://ftp.xemacs.org/pub/xemacs/beta/packages-20.3/ + ftp://ftp.xemacs.org/pub/xemacs/beta/xemacs-20.4/packages/ is divided into subdirectory by the major type of package. @@ -294,7 +294,7 @@ ** Binary package installation (binary-packages) ================================================ -Prerequisite: XEmacs 20.3-beta28. +Prerequisite: XEmacs 20.4-b1. Binary packages are complete entities that can be untarred at the top level of an XEmacs package hierarchy and work at runtime. To install files @@ -304,7 +304,7 @@ ** Single file package installation =================================== -Prerequisite: XEmacs 20.3-beta28. +Prerequisite: XEmacs 20.4-b1. These are single file, self-contained lisp packages that don't need a separate directory. To install something from this directory, run
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/CHARSETS Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,57 @@ +######################### +## LIST OF CHARSETS +## Each line corresponds to one charset. +## The following attributes are listed in this order +## separated by a colon `:' in one line. +## CHARSET-SYMBOL-NAME, +## CHARSET-ID, +## DIMENSION (1 or 2) +## CHARS (94 or 96) +## BYTES (of multibyte form: 1, 2, 3, or 4), +## WIDTH (occupied column numbers: 1 or 2), +## DIRECTION (0:left-to-right, 1:right-to-left), +## ISO-FINAL-CHAR (character code of ISO-2022's final character) +## ISO-GRAPHIC-PLANE (ISO-2022's graphic plane, 0:GL, 1:GR) +## DESCRIPTION (describing string of the charset) +tibetan-1-column:241:2:94:4:1:0:56:0:Tibetan 1 column glyph +tibetan:252:2:94:4:2:0:55:0:Tibetan characters +lao:167:1:94:3:1:0:49:0:Lao characters (ISO10646 0E80..0EDF) +indian-1-column:240:2:94:4:1:0:54:0:Indian charset for 2-column width glypps +indian-2-column:251:2:94:4:2:0:53:0:Indian charset for 2-column width glyphs +indian-is13194:225:1:94:3:2:0:53:1:Generic Indian charset for data exchange with IS 13194 +ascii-right-to-left:166:1:94:3:1:1:66:0:ASCII (left half of ISO8859-1) with right-to-left direction +chinese-cns11643-7:250:2:94:4:2:0:77:0:CNS11643 Plane 7 Chinese Traditional +chinese-cns11643-6:249:2:94:4:2:0:76:0:CNS11643 Plane 6 Chinese Traditional +chinese-cns11643-5:248:2:94:4:2:0:75:0:CNS11643 Plane 5 Chinese Traditional +chinese-cns11643-4:247:2:94:4:2:0:74:0:CNS11643 Plane 4 Chinese Traditional +chinese-cns11643-3:246:2:94:4:2:0:73:0:CNS11643 Plane 3 Chinese Traditional +ethiopic:245:2:94:4:2:0:51:0:Ethiopic characters +arabic-2-column:224:1:94:3:2:1:52:0:Arabic 2-column +arabic-1-column:165:1:94:3:1:1:51:0:Arabic 1-column +arabic-digit:164:1:94:3:1:0:50:0:Arabic digit +vietnamese-viscii-upper:163:1:96:3:1:0:50:1:VISCII1.1 upper-case +vietnamese-viscii-lower:162:1:96:3:1:0:49:1:VISCII1.1 lower-case +ipa:161:1:96:3:1:0:48:1:IPA (International Phonetic Association) +chinese-sisheng:160:1:94:3:1:0:48:0:SiSheng characters for PinYin/ZhuYin +chinese-big5-2:153:2:94:3:2:0:49:0:Big5 Level-2 Chinese traditional +chinese-big5-1:152:2:94:3:2:0:48:0:Big5 Level-1 Chinese traditional +chinese-cns11643-2:150:2:94:3:2:0:72:0:CNS11643 Plane 2 Chinese traditional +chinese-cns11643-1:149:2:94:3:2:0:71:0:CNS11643 Plane 1 Chinese traditional +japanese-jisx0212:148:2:94:3:2:0:68:0:JISX0212 Japanese supplement +korean-ksc5601:147:2:94:3:2:0:67:0:KSC5601 Korean Hangul and Hanja +japanese-jisx0208:146:2:94:3:2:0:66:0:JISX0208.1983/1990 Japanese Kanji +chinese-gb2312:145:2:94:3:2:0:65:0:GB2312 Chinese simplified +japanese-jisx0208-1978:144:2:94:3:2:0:64:0:JISX0208.1978 Japanese Kanji (so called "old JIS") +latin-iso8859-9:141:1:96:2:1:0:77:1:ISO8859-9 (Latin-5) +cyrillic-iso8859-5:140:1:96:2:1:0:76:1:ISO8859-5 (Cyrillic) +latin-jisx0201:138:1:94:2:1:0:74:0:JISX0201.1976 Japanese Roman +katakana-jisx0201:137:1:94:2:1:0:73:1:JISX0201.1976 Japanese Kana +hebrew-iso8859-8:136:1:96:2:1:1:72:1:ISO8859-8 (Hebrew) +arabic-iso8859-6:135:1:96:2:1:1:71:1:ISO8859-6 (Arabic) +greek-iso8859-7:134:1:96:2:1:0:70:1:ISO8859-7 (Greek) +thai-tis620:133:1:96:2:1:0:84:1:TIS620.2529 (Thai) +latin-iso8859-4:132:1:96:2:1:0:68:1:ISO8859-4 (Latin-4) +latin-iso8859-3:131:1:96:2:1:0:67:1:ISO8859-3 (Latin-3) +latin-iso8859-2:130:1:96:2:1:0:66:1:ISO8859-2 (Latin-2) +latin-iso8859-1:129:1:96:2:1:0:65:1:ISO8859-1 (Latin-1) +ascii:000:1:94:1:1:0:66:0:ASCII (ISO646 IRV)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/CODINGS Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,74 @@ +######################### +## LIST OF CODING SYSTEMS +## Each line corresponds to one coding system +## Format of a line is: +## NAME:TYPE:MNEMONIC:EOL:FLAGS:DOCSTRING, +## where +## TYPE = nil (no conversion), t (auto conversion), +## 0 (Mule internal), 1 (SJIS), 2 (ISO2022), 3 (BIG5), or 4 (CCL) +## EOL = 0 (LF), 1 (CRLF), 2 (CR), or 3 (Automatic detection) +## FLAGS = +## if TYPE = 2 then +## comma (`,') separated data of the followings: +## G0, G1, G2, G3, SHORT-FORM, ASCII-EOL, ASCII-CNTL, SEVEN, +## LOCKING-SHIFT, SINGLE-SHIFT, USE-ROMAN, USE-OLDJIS, NO-ISO6429 +## else if TYPE = 4 then +## comma (`,') separated CCL programs for read and write +## else +## 0 +## +no-conversion:nil:=:0:0:Do no conversion +undecided:t:+:3:0:Detect coding-system automatically +hz:0:z:3:0:Codins-system of Hz/ZW used for Chinese (GB). +emacs-mule:0:=:3:0:Internal coding system used in a buffer. +shift_jis:1:S:3:0:Coding-system of Shift-JIS used in Japan. +sjis:1:S:3:0:Coding-system of Shift-JIS used in Japan. +euc-japan-1990:2:E:3:ascii,japanese-jisx0208,katakana-jisx0201,japanese-jisx0212,1,1,1,0,0,1,0,0,0:Coding-system of Japanese EUC (Extended Unix Code). +iso-2022-lock:2:i:3:(ascii,t),-2,-1,-1,0,1,1,1,0,0,0,0,0:ISO-2022 coding system using Locking-Shift for 96-charset. +iso-2022-ss2-7:2:I:3:(ascii,t),-1,-2,-1,1,1,1,1,0,1,0,0,0:ISO-2022 coding system using SS2 for 96-charset in 7-bit code. +iso-2022-ss2-8:2:I:3:(ascii,t),-1,-2,-1,0,1,1,0,0,1,0,0,0:ISO-2022 coding system using SS2 for 96-charset in 8-bit code. +iso-2022-cjk:2:I:3:(ascii,t),(nil,korean-ksc5601,chinese-gb2312,chinese-cns11643-1,t),(nil,chinese-cns11643-2),(nil,chinese-cns11643-3,chinese-cns11643-4,chinese-cns11643-5,chinese-cns11643-6,chinese-cns11643-7),1,1,1,1,1,1,0,0,0:Mixture of ISO-2022-JP, ISO-2022-KR, and ISO-2022-CN +cn-gb-2312:2:C:3:(ascii,t),chinese-gb2312,chinese-sisheng,-1,0,1,1,0,0,1,0,0,0:Coding-system of Chinese EUC (so called GB Encoding). +lao:2:T:3:(ascii,t),(lao,t),-1,-1,0,1,0,0,0,0,0,0,0:Coding-system used for ASCII(MSB=0) & LAO(MSB=1). +iso-2022-jp-1978-irv:2:J:3:(ascii,t),-1,-1,-1,1,1,1,1,0,0,1,1,0:Coding-system used for old jis terminal. +junet:2:J:3:(ascii,t),-1,-1,-1,1,1,1,1,0,0,0,0,0:Coding system based on ISO2022 7-bit encoding. +tis620:2:T:3:(ascii,t),(thai-tis620,t),-1,-1,0,1,0,0,0,0,0,0,0:Coding-system used for ASCII(MSB=0) & TIS620(MSB=1). +euc-japan:2:E:3:ascii,japanese-jisx0208,katakana-jisx0201,japanese-jisx0212,1,1,1,0,0,1,0,0,0:Coding-system of Japanese EUC (Extended Unix Code). +iso-2022-int-1:2:I:3:(ascii,t),(korean-ksc5601,t),-1,-1,1,1,1,1,1,0,0,0,0:ISO-2022-INT-1 +euc-china:2:C:3:(ascii,t),chinese-gb2312,chinese-sisheng,-1,0,1,1,0,0,1,0,0,0:Coding-system of Chinese EUC (so called GB Encoding). +old-jis:2:J:3:(ascii,t),-1,-1,-1,1,1,1,1,0,0,1,1,0:Coding-system used for old jis terminal. +iso-2022-7:2:J:3:(ascii,t),-1,-1,-1,1,1,1,1,0,0,0,0,0:Coding system based on ISO2022 7-bit encoding. +iso-2022-cn:2:C:3:ascii,(nil,chinese-gb2312,chinese-cns11643-1),(nil,chinese-cns11643-2),(nil,chinese-cns11643-3,chinese-cns11643-4,chinese-cns11643-5,chinese-cns11643-6,chinese-cns11643-7),0,1,1,1,1,1,0,0,0:Coding system ISO-2022-CN for Chinese (GB and CNS character sets). +ctext:2:X:3:(ascii,t),(latin-iso8859-1,t),-1,-1,0,1,1,0,0,0,0,0,0:MIME ISO-8859-1 Compound Text Encoding. +iso-2022-jp:2:J:3:(ascii,t),-1,-1,-1,1,1,1,1,0,0,0,0,0:Coding system based on ISO2022 7-bit encoding. +iso-2022-kr:2:k:3:ascii,(nil,korean-ksc5601),-1,-1,0,1,1,1,1,0,0,0,0:MIME ISO-2022-KR +iso-2022-cn-ext:2:C:3:ascii,(nil,chinese-gb2312,chinese-cns11643-1),(nil,chinese-cns11643-2),(nil,chinese-cns11643-3,chinese-cns11643-4,chinese-cns11643-5,chinese-cns11643-6,chinese-cns11643-7),0,1,1,1,1,1,0,0,0:Coding system ISO-2022-CN for Chinese (GB and CNS character sets). +iso-8859-1:2:X:3:(ascii,t),(latin-iso8859-1,t),-1,-1,0,1,1,0,0,0,0,0,0:MIME ISO-8859-1 Compound Text Encoding. +iso-8859-2:2:2:3:(ascii,t),(latin-iso8859-2,t),-1,-1,0,1,1,0,0,0,0,0,0:MIME ISO-8859-2 +iso-8859-3:2:3:3:(ascii,t),(latin-iso8859-3,t),-1,-1,0,1,1,0,0,0,0,0,0:MIME ISO-8859-3 +iso-8859-4:2:4:3:(ascii,t),(latin-iso8859-4,t),-1,-1,0,1,1,0,0,0,0,0,0:MIME ISO-8859-4 +iso-8859-5:2:5:3:(ascii,t),(cyrillic-iso8859-5,t),-1,-1,0,1,1,0,0,0,0,0,0:MIME ISO-8859-5 +iso-8859-7:2:7:3:(ascii,t),(greek-iso8859-7,t),-1,-1,0,1,1,0,0,0,0,0,0:MIME ISO-8859-7 +iso-8859-8:2:8:3:(ascii,t),(hebrew-iso8859-8,t),-1,-1,0,1,1,0,0,0,0,0,1:MIME ISO-8859-8 +iso-8859-9:2:9:3:(ascii,t),(latin-iso8859-9,t),-1,-1,0,1,1,0,0,0,0,0,0:MIME ISO-8859-9 +euc-kr:2:K:3:(ascii,t),korean-ksc5601,-1,-1,0,1,1,0,0,0,0,0,0:Coding-system of Korean EUC (Extended Unix Code). +euc-korea:2:K:3:(ascii,t),korean-ksc5601,-1,-1,0,1,1,0,0,0,0,0,0:Coding-system of Korean EUC (Extended Unix Code). +cn-big5:3:B:3:0:Coding-system of BIG5. +big5:3:B:3:0:Coding-system of BIG5. +viscii:4:V:3: 3 106 e ffffff0b 100 0 1 19c6 3 4 19c7 19e7 7 8 9 a b c d e f 10 11 12 13 19d6 15 16 17 18 19db 1a 1b 1c 1d 19dc 1f 20 21 22 23 24 25 26 27 28 29 2a 2b 2c 2d 2e 2f 30 31 32 33 34 35 36 37 38 39 3a 3b 3c 3d 3e 3f 40 41 42 43 44 45 46 47 48 49 4a 4b 4c 4d 4e 4f 50 51 52 53 54 55 56 57 58 59 5a 5b 5c 5d 5e 5f 60 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f 70 71 72 73 74 75 76 77 78 79 7a 7b 7c 7d 7e 7f 19d5 19a1 19a2 19a3 19a4 19a5 19a6 19a7 19a8 19a9 19aa 19ab 19ac 19ad 19ae 19af 19b0 19b1 19b2 19b5 19fe 19be 19b6 19b7 19b8 19f6 19f7 19ef 19fc 19fb 19f8 19cf 19f5 1921 1922 1923 1924 1925 1926 1927 1928 1929 192a 192b 192c 192d 192e 192f 1930 1931 1932 19de 19bd 1935 1936 1937 1938 19f1 19d1 19d7 19d8 193d 193e 19df 19e0 19e1 19e2 19e3 19e4 19e5 1946 1947 19e8 19e9 19ea 19eb 19ec 19ed 19ee 194f 19f0 1951 19f2 19f3 19f4 1955 1956 1957 1958 19f9 19fa 195b 195c 19fd 195e 195f 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 196a 196b 196c 196d 196e 196f 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 197a 197b 197c 197d 197e 19e6 fffefd0c 16, 1 121 e 41b 10 80 fffffc07 fffffb0c 41b 15 9a fffff707 fffff60c 881d 12 a2 e 4017 80 ffffef0b 80 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 a1 a2 a3 a4 a5 a6 a7 a8 a9 aa ab ac ad ae af b0 b1 b2 0 0 b5 b6 b7 b8 0 0 0 0 bd be 0 0 0 0 0 0 0 c6 c7 0 0 0 0 0 0 0 cf 0 d1 0 0 0 d5 d6 d7 d8 0 0 db dc 0 de df e0 e1 e2 e3 e4 e5 e6 e7 e8 e9 ea eb ec ed ee ef f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 fa fb fc fd fe 0 ffff6d0c 881b 12 a3 e 4017 80 ffff660b 80 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 81 82 83 84 85 86 87 88 89 8a 8b 8c 8d 8e 8f 90 91 92 0 0 93 96 97 98 0 0 0 0 b4 95 0 0 0 0 0 0 0 2 5 0 0 0 0 0 0 0 9f 0 ba 0 0 0 80 14 bb bc 0 0 19 1e 0 b3 bf c0 c1 c2 c3 c4 c5 ff 6 c8 c9 ca cb cc cd ce 9b d0 b9 d2 d3 d4 a0 99 9a 9e d9 da 9d 9c dd 94 0 fffee40c fffee307 fffee20c 16:Coding-system used for VISCII 1.1. +koi8:4:K:3: 3 106 e ffffff0b 100 0 1 2 3 4 5 6 7 8 9 a b c d e f 10 11 12 13 14 15 16 17 18 19 1a 1b 1c 1d 1e 1f 20 21 22 23 24 25 26 27 28 29 2a 2b 2c 2d 2e 2f 30 31 32 33 34 35 36 37 38 39 3a 3b 3c 3d 3e 3f 40 41 42 43 44 45 46 47 48 49 4a 4b 4c 4d 4e 4f 50 51 52 53 54 55 56 57 58 59 5a 5b 5c 5d 5e 5f 60 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f 70 71 72 73 74 75 76 77 78 79 7a 7b 7c 7d 7e 7f 80 81 82 83 84 85 86 87 88 89 8a 8b 8c 8d 8e 8f 90 91 92 93 94 95 96 97 98 99 9a 9b 9c 9d 9e 9f 20 20 20 e71 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 e21 20 20 20 20 20 20 20 20 20 20 20 20 e6e e50 e51 e66 e54 e55 e64 e53 e65 e58 e59 e5a e5b e5c e5d e5e e5f e6f e60 e61 e62 e63 e56 e52 e6c e6b e57 e68 e6d e69 e67 e6a e4e e30 e31 e46 e34 e35 e44 e33 e45 e38 e39 e3a e3b e3c e3d e3e e3f e4f e40 e41 e42 e43 e36 e32 e4c e4b e37 e48 e4d e49 e47 e4a fffefd0c 16, 1 6e e 41b 15 8c fffffc07 fffffb0c e 4017 a0 fffff70b 60 20 b3 20 20 20 20 20 20 20 20 20 20 20 20 20 20 e1 e2 f7 e7 e4 e5 f6 fa e9 ea eb ec ed ee ef f0 f2 f3 f4 f5 e6 e8 e3 fe fb fd ff f9 f8 fc e0 f1 c1 c2 d7 c7 c4 c5 d6 da c9 ca cb cc cd ce cf d0 d2 d3 d4 d5 c6 c8 c3 de db dd df d9 d8 dc c0 d1 20 a3 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ffff950c 16:Coding-system used for KOI8. +koi8-r:4:K:3: 3 106 e ffffff0b 100 0 1 2 3 4 5 6 7 8 9 a b c d e f 10 11 12 13 14 15 16 17 18 19 1a 1b 1c 1d 1e 1f 20 21 22 23 24 25 26 27 28 29 2a 2b 2c 2d 2e 2f 30 31 32 33 34 35 36 37 38 39 3a 3b 3c 3d 3e 3f 40 41 42 43 44 45 46 47 48 49 4a 4b 4c 4d 4e 4f 50 51 52 53 54 55 56 57 58 59 5a 5b 5c 5d 5e 5f 60 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f 70 71 72 73 74 75 76 77 78 79 7a 7b 7c 7d 7e 7f 80 81 82 83 84 85 86 87 88 89 8a 8b 8c 8d 8e 8f 90 91 92 93 94 95 96 97 98 99 9a 9b 9c 9d 9e 9f 20 20 20 e71 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 e21 20 20 20 20 20 20 20 20 20 20 20 20 e6e e50 e51 e66 e54 e55 e64 e53 e65 e58 e59 e5a e5b e5c e5d e5e e5f e6f e60 e61 e62 e63 e56 e52 e6c e6b e57 e68 e6d e69 e67 e6a e4e e30 e31 e46 e34 e35 e44 e33 e45 e38 e39 e3a e3b e3c e3d e3e e3f e4f e40 e41 e42 e43 e36 e32 e4c e4b e37 e48 e4d e49 e47 e4a fffefd0c 16, 1 6e e 41b 15 8c fffffc07 fffffb0c e 4017 a0 fffff70b 60 20 b3 20 20 20 20 20 20 20 20 20 20 20 20 20 20 e1 e2 f7 e7 e4 e5 f6 fa e9 ea eb ec ed ee ef f0 f2 f3 f4 f5 e6 e8 e3 fe fb fd ff f9 f8 fc e0 f1 c1 c2 d7 c7 c4 c5 d6 da c9 ca cb cc cd ce cf d0 d2 d3 d4 d5 c6 c8 c3 de db dd df d9 d8 dc c0 d1 20 a3 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ffff950c 16:Coding-system used for KOI8. +alternativnyj:4:A:3: 3 106 e ffffff0b 100 0 1 2 3 4 5 6 7 8 9 a b c d e f 10 11 12 13 14 15 16 17 18 19 1a 1b 1c 1d 1e 1f 20 21 22 23 24 25 26 27 28 29 2a 2b 2c 2d 2e 2f 30 31 32 33 34 35 36 37 38 39 3a 3b 3c 3d 3e 3f 40 41 42 43 44 45 46 47 48 49 4a 4b 4c 4d 4e 4f 50 51 52 53 54 55 56 57 58 59 5a 5b 5c 5d 5e 5f 60 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f 70 71 72 73 74 75 76 77 78 79 7a 7b 7c 7d 7e 7f e30 e31 e32 e33 e34 e35 e36 e37 e38 e39 e3a e3b e3c e3d e3e e3f e40 e41 e42 e43 e44 e45 e46 e47 e48 e49 e4a e4b e4c e4d e4e e4f e50 e51 e52 e53 e54 e55 e56 e57 e58 e59 e5a e5b e5c e5d e5e e5f 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 e60 e61 e62 e63 e64 e65 e66 e67 e68 e69 e6a e6b e6c e6d e6e e6f e21 e71 20 20 20 20 20 20 20 20 20 20 20 20 20 e70 fffefd0c 16, 1 6e e 41b 15 8c fffffc07 fffffb0c e 4017 a0 fffff70b 60 20 f0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 80 81 82 83 84 85 86 87 88 89 8a 8b 8c 8d 8e 8f 90 91 92 93 94 95 96 97 98 99 9a 9b 9c 9d 9e 9f a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 aa ab ac ad ae af e0 e1 e2 e3 e4 e5 e6 e7 e8 e9 ea eb ec ed ee ef ff f1 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ffff950c 16:Coding-system used for Alternativnyj +vscii:4:V:3: 3 106 e ffffff0b 100 0 19fa 19f8 3 19d7 19d8 19e6 7 8 9 a b c d e f 10 19d1 19df 19cf 19d6 19db 19fd 19dc 18 19 1a 1b 1c 1d 1e 1f 20 21 22 23 24 25 26 27 28 29 2a 2b 2c 2d 2e 2f 30 31 32 33 34 35 36 37 38 39 3a 3b 3c 3d 3e 3f 40 41 42 43 44 45 46 47 48 49 4a 4b 4c 4d 4e 4f 50 51 52 53 54 55 56 57 58 59 5a 5b 5c 5d 5e 5f 60 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f 70 71 72 73 74 75 76 77 78 79 7a 7b 7c 7d 7e 7f 19e0 19e4 19e3 19e1 19d5 19a3 19a7 19e8 19eb 19a8 19e9 19a9 19ae 19ec 19ef 19ee 19ed 19b8 19f2 19f6 19f5 19f3 19f7 19b5 19b6 19b7 19de 19be 19fe 19f9 19fc 19fb a0 19e5 19e2 19ea 19f4 19bd 19df 19f0 1965 1962 196a 1974 193e 1979 1970 19a2 c0 c1 c2 c3 c4 1960 1964 1963 1961 1955 19c6 1922 1946 1947 1921 19c7 19a1 19a5 19a6 19e7 19a5 19ab 1923 1925 1926 1967 1924 1927 1968 19ac 196b 1928 1969 1929 192b 192c 192d 192a 192e 196c 196f 19ad 19aa 19b0 196e 196d 1938 1972 19b1 1976 1975 1973 1977 1930 1931 1932 192f 1935 1936 1937 195e 193e 197e 1979 19b2 197c 197b 197a 1978 1957 1958 1966 1951 1971 194f 1956 195b 197d 195c 19af fffefd0c 16, 1 121 e 41b 10 80 fffffc07 fffffb0c 41b 15 9a fffff707 fffff60c 881d 12 a2 e 4017 80 ffffef0b 80 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 be bb c6 ca c7 c8 cb cf d1 d5 d2 d3 d4 d6 e8 e5 e6 e7 0 0 e9 ea eb de 0 0 0 0 0 ed 0 0 0 0 0 0 0 bc bd 0 0 0 0 0 0 0 fa 0 f8 0 0 0 b9 fb f5 f6 0 0 fc fe 0 ec 0 b5 b8 a9 b7 b6 a8 f7 c9 cc d0 aa ce d7 dd dc d8 ae f9 df e3 ab e2 e1 e4 f4 ef f3 f2 f1 fd ee 0 ffff6d0c 881b 12 a3 e 4017 80 ffff660b 80 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 81 82 83 84 85 86 87 88 89 8a 8b 8c 8d 8e 8f 90 91 92 0 0 93 96 97 98 0 0 0 0 b4 95 0 0 0 0 0 0 0 2 5 0 0 0 0 0 0 0 9f 0 ba 0 0 0 80 14 bb bc 0 0 19 1e 0 b3 bf c0 c1 c2 c3 c4 c5 ff 6 c8 c9 ca cb cc cd ce 9b d0 b9 d2 d3 d4 a0 99 9a 9e d9 da 9d 9c dd 94 0 fffee40c fffee307 fffee20c 16:Coding-system used for VSCII-1. +############################ +## LIST OF CODING CATEGORIES (ordered by priority) +## CATEGORY:CODING-SYSTEM +## +coding-category-iso-7:iso-2022-7 +coding-category-iso-8-1:iso-8859-1 +coding-category-iso-8-2:iso-8859-1 +coding-category-iso-else:iso-2022-lock +coding-category-emacs-mule:emacs-mule +coding-category-sjis:sjis +coding-category-big5:big5 +coding-category-binary:no-conversion
--- a/etc/DISTRIB Mon Aug 13 10:03:54 2007 +0200 +++ b/etc/DISTRIB Mon Aug 13 10:04:58 2007 +0200 @@ -8,22 +8,22 @@ ftp.xemacs.org is the primary distribution point, but you may find copies of it at other sites as well. Some sites to try include: - ftp://ftp.ai.mit.edu:/pub/xemacs/ - ftp://ftp-digital.cern.ch:/pub/beta/xemacs-20.0/ - ftp://ftp.uu.net:/systems/gnu/xemacs/ - ftp://ftp.sunet.se:/pub/gnu/xemacs/ - ftp://ftp.cenatls.cena.dgac.fr:/pub/Emacs/xemacs/ - ftp://ftp.th-darmstadt.de:/pub/editors/xemacs/ - ftp://sunsite.doc.ic.ac.uk:/gnu/xemacs/ - ftp://ftp.ibp.fr:/pub/emacs/xemacs/ - ftp://uiarchive.cso.uiuc.edu:/pub/packages/xemacs/ - ftp://ftp.technion.ac.il:/pub/unsupported/gnu/xemacs/ - ftp://thphys.irb.hr:/pub/xemacs/ + ftp://ftp2.xemacs.org/pub/xemacs/ + ftp://ftp.ai.mit.edu/pub/xemacs/ + ftp://ftp.uu.net/systems/gnu/xemacs/ + ftp://ftp.sunet.se/pub/gnu/xemacs/ + ftp://ftp.cenatls.cena.dgac.fr/pub/Emacs/xemacs/ + ftp://ftp.th-darmstadt.de/pub/editors/xemacs/ + ftp://sunsite.doc.ic.ac.uk/gnu/xemacs/ + ftp://ftp.ibp.fr/pub/emacs/xemacs/ + ftp://uiarchive.cso.uiuc.edu/pub/packages/xemacs/ + ftp://ftp.technion.ac.il/pub/unsupported/gnu/xemacs/ + ftp://thphys.irb.hr/pub/xemacs/ ftp://sunsite.cnlab-switch.ch/mirror/xemacs/ - ftp://ftp.unicamp.br:/pub/xemacs/ - ftp://ftp.usyd.edu.au:/pub/Xemacs/ + ftp://ftp.unicamp.br/pub/xemacs/ + ftp://ftp.usyd.edu.au/pub/Xemacs/ ftp://ftp.lab.kdd.co.jp/xemacs/ - ftp://SunSITE.sut.ac.jp/pub/archives/xemacs/ + ftp://SunSITE.sut.ac.jp/pub/archives/packages/xemacs/ ftp://sunsite.icm.edu.pl/pub/unix/xemacs The most up-to-date list of distribution sites can always be found on
--- a/etc/NEWS Mon Aug 13 10:03:54 2007 +0200 +++ b/etc/NEWS Mon Aug 13 10:04:58 2007 +0200 @@ -106,6 +106,19 @@ *** More user-level documentation on using Mule. +* Changes in XEmacs 20.4 +======================== + +** An arbitrary keystroke can be generated by entering `C-x @ k +<keysym-name> RET' where <keysym-name> is a spelled out name of the +desired keysym. For example a sequence: + + C-x @ c C-x @ k b a c k s p a c e RET + +will result in a `C-backspace' keystroke. This feature is especially +useful on terminal emulators having key redefinition capability. + + * Changes in XEmacs 20.3 ======================== @@ -223,6 +236,13 @@ sequence. This feature is especially useful on text terminals where it allows one to enter keystrokes like, e.g., `M-home'. +** An arbitrary keystroke can be generated by entering `C-x @ k +<keysym-name> RET'. For example a sequence: + + C-x @ c C-x @ k b a c k s p a c e RET + +will result in a `C-backspace' keystroke even on text terminals. + ** Customize changes. *** Customize has undergone a massive speedup, and should now operate
--- a/etc/TUTORIAL Mon Aug 13 10:03:54 2007 +0200 +++ b/etc/TUTORIAL Mon Aug 13 10:04:58 2007 +0200 @@ -19,7 +19,7 @@ Important note: to end the Emacs session, type C-x C-c. (Two characters.) The characters ">>" at the left margin indicate directions for you to try using a command. For instance: -<<Blank lines inserted here by startup of help-with-tutorial>> +<<Middle of page left blank for didactic purposes. Text continues below.>> >> Now type C-v (View next screen) to move to the next screen. (go ahead, do it by holding down the control key while typing v). From now on, you should do this again whenever you finish
--- a/etc/TUTORIAL.de Mon Aug 13 10:03:54 2007 +0200 +++ b/etc/TUTORIAL.de Mon Aug 13 10:04:58 2007 +0200 @@ -1,3 +1,5 @@ +Copyright (c) 1997, Adrian Aichner <aichner@ecf.teradyne.com>. + Copyright (c) 1985, 1996 Free Software Foundation, Inc. See end for conditions. Du betrachtest das Emacs Tutorial. @@ -21,7 +23,7 @@ Wichtig: Tippe C-x C-c, um die Emacs-Sitzung zu beenden (zwei Zeichen). Die ">>" am linken Seitenrand deuten auf Anweisungen, die Du probieren solltest. so z.B: -<<Blank lines inserted here by startup of help-with-tutorial>> +<<Seitenmitte aus didaktischen Gründen leer. Text wird unten fortgesetzt.>> >> Tippe nun C-v (Betrachte nächste Seite) um die nächste Seite zu betrachten. (Also, halte die CONTROL-Taste gedrückt während Du v tippst.) @@ -1124,12 +1126,18 @@ ANFERTIGEN VON KOPIEN --------------------- -This tutorial descends from a long line of Emacs tutorials -starting with the one written by Stuart Cracraft for the original Emacs. -Ben Wing updated the tutorial for X Windows. +Dieses Tutorial stammt, über eine lange Linie von Emacs Tutorials, von +dem von Stuart Cracraft für den ursprünglichen Emacs geschriebenen ab. +Ben Wing hat das Tutorial für X Windows erweitert. Martin Buchholz +und Hrvoje Niksic haben weitere Korrekturen für XEmacs beigetragen. +Ins Deutsche übertragen wurde es von Adrian Aichner +<aichner@ecf.teradyne.com>. -This version of the tutorial, like GNU Emacs, is copyrighted, and -comes with permission to distribute copies on certain conditions: +Diese Version des Tutorials ist, wie GNU Emacs selbst, +urheberrechtlich geschützt und erlaubt die Verteilung von Kopien unter +bestimmten Voraussetzungen: + +Copyright (c) 1997, Adrian Aichner <aichner@ecf.teradyne.com>. Copyright (c) 1985, 1996 Free Software Foundation @@ -1144,7 +1152,8 @@ under the above conditions, provided also that they carry prominent notices stating who last altered them. -The conditions for copying Emacs itself are more complex, but in the -same spirit. Please read the file COPYING and then do give copies of -GNU Emacs to your friends. Help stamp out software obstructionism -("ownership") by using, writing, and sharing free software! +Die Bedingungen zum Kopieren von Emacs sind komplexer, entsprechen +aber dem selben Geist. Bitte lies die Datei COPYING und gib doch +Kopien von GNU Emacs an Freunde weiter. Hilf mit bei der Beseitigung +von Software-Verhinderungspolitik ("Besitz") durch das Verwenden, +Schreiben and Weitergeben von kostenloser Software!
--- a/etc/TUTORIAL.fr Mon Aug 13 10:03:54 2007 +0200 +++ b/etc/TUTORIAL.fr Mon Aug 13 10:04:58 2007 +0200 @@ -30,8 +30,8 @@ NOTE IMPORTANTE: pour quitter Emacs, tapez C-x C-c (deux caractères). Quand vous trouvez les caractères >> au début d'une ligne, cette ligne -vous donne des directives pour essayer une commande. Par exemple, -<<Blank lines inserted here by startup of help-with-tutorial>> +vous donne des directives pour essayer une commande. Par exemple: +<<Lignes blanches à but pédagogique. Le texte continue ci-dessous.>> >> Maintenant, tapez C-v («view next screen») pour passer à l'écran suivant. (Faites le vraiment! Maintenez la touche <Control> enfoncée et tapez 'v'). À partir de maintenant, refaites la même
--- a/etc/TUTORIAL.hr Mon Aug 13 10:03:54 2007 +0200 +++ b/etc/TUTORIAL.hr Mon Aug 13 10:04:58 2007 +0200 @@ -19,7 +19,7 @@ Napomena: za izlazak iz Emacsa, utipkajte C-x C-c. (Dva znaka.) Znakovi ">>" na lijevom rubu naznaèuju uputstva da poku¹ate koristiti neku naredbu. Na primjer: -<<Blank lines inserted here by startup of help-with-tutorial>> +<<Sredina stranice namjerno ostavljena prazna. Tekst se nastavlja dolje.>> >> Sad utipkajte C-v za pomak na sljedeæi ekran. (samo naprijed, uèinite to tako da dr¾ite tipku control i pritisnite 'v'). Od sad, ovo trebate napraviti kad god zavr¹ite
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/TUTORIAL.ja Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,741 @@ + ============================== + $BF|K\8l(B GNUEMACS(Mule) $BF~LgJT(B + ============================== + +$BCm0U!'(B $B$3$NF~LgJT$O!"!V=,$&$h$j47$l$m!W$r%b%C%H!<$K:n@.$5$l$F$$$^(B + $B$9!#(B">>" $B$+$i;O$^$k9T$O!"$=$N;~2?$r$9$Y$-$+$r;X<($7$F$$$^$9!#(B + + + Mule $B$N%3%^%s%I$rF~NO$9$k$H$-$K$O!"0lHLE*$K%3%s%H%m!<%k!&%-!<!J%-!<!&(B +$B%H%C%W$K!"(BCTRL $B$"$k$$$O!"(BCTL $B$H=q$$$F$"$k!K$d%a%?!&%-!<!JIaDL!"%(%9%1!<%W!&(B +$B%-!<$r;H$&!K$,;H$o$l$^$9!#$=$3$G!"(BCONTROL $B$H$+(B META $B$H$+=q$/Be$o$j$K!"<!$N(B +$B$h$&$J5-9f$r;H$&$3$H$K$7$^$9!#(B + +C-<$BJ8;z(B> $B%3%s%H%m!<%k!&%-!<$r2!$7$?$^$^!"(B<$BJ8;z(B>$B%-!<$r2!$7$^$9!#Nc$($P!"(B + C-f $B$O!"%3%s%H%m!<%k!&%-!<$r2!$7$J$,$i(B f $B$N%-!<$r2!$9$3$H$r(B + $B0UL#$7$^$9!#(B +<<Blank lines inserted here by startup of help-with-tutorial>> + >> $B$=$l$G$O!"(BC-v$B!J(BView Next Screen; $B<!$N2hLL$r8+$k!K$r%?%$%W$7$F(B + $B$_$F2<$5$$!#<!$N2hLL$K?J$`$3$H$,$G$-$^$9!#(B + $B0J9_!"0l2hLL$rFI$_=*$($k$?$S$KF1MM$K$7$F<!$N2hLL$KFI$_?J$s$G(B + $B2<$5$$!#(B + +ESC <$BJ8;z(B> $B%(%9%1!<%W!&%-!<$r2!$7$F$+$iN%$7!"$=$l$+$i(B<$BJ8;z(B>$B%-!<$r2!$7$^(B + $B$9!#(B + +$BCm0U!'(B <$BJ8;z(B>$B$O!"BgJ8;z$G$b>.J8;z$G$b%3%^%s%I$H$7$F$OF1$80UL#$K$J$j(B + $B$^$9!#%a%?%-!<$,;H$($k$J$i$P(B ESC <$BJ8;z(B> $B$NBe$o$j$K(B M-<$BJ8;z(B> + ($B%a%?%-!<$r2!$7$?$^$^(B<$BJ8;z(B>$B%-!<$r2!$9(B) $B$,;H$($^$9!#(B + +$B=EMW$G$9!'(B Emacs$B$r=*N;$5$;$?$$;~$O!"(BC-x C-c $B$r%?%$%W$7$^$9!#(BEmacs$B$r(Bcsh + $B$+$i5/F0$7$F$$$k>l9g!"%5%9%Z%s%I$9$k!J0l;~E*$K;_$a$k(B)$B$3$H$,(B + $B=PMh$^$9!#(BEmacs$B$r%5%9%Z%s%I$9$k$K$O!"(BC-z$B$r%?%$%W$7$^$9!#(B + + + $B$5$F!"$3$l$+$i$O!"0l2hLLJ,FI$_=*$($?$i!"(BC-v $B$rF~NO$7$F9T$C$F2<$5$$!#(B + + $BA0$N2hLL$H<!$N2hLL$H$G$O!"I=<($5$l$kFbMF$K2?9TJ8$+$N=E$J$j$,$"$j$^$9!#(B +$B$3$l$O!"I=<($5$l$F$$$kFbMF$,O"B3$7$F$$$k$3$H$,$9$0H=$k$h$&$K$9$k$?$a$G$9!#(B + + + $B$^$:$O!"%U%!%$%k$NCf$r0\F0$7$F9T$/J}K!$rCN$kI,MW$,$"$j$^$9!#(BC-v $B$K$h(B +$B$C$F@h$K?J$`$3$H$O$b$&H=$j$^$7$?!#85$KLa$k$K$O!"(BESC v $B$r%?%$%W$7$^$9!#(B + + >> ESC v $B$H(B C-v $B$r;H$C$F!"A08e$K0\F0$9$k$3$H$r2?2s$+;n$7$F$_$J$5$$!#(B + +$BMWLs(B +==== + $B%U%!%$%k$r2hLLKh$K8+$F9T$/$K$O!"<!$N%3%^%s%I$r;H$$$^$9!#(B + + C-v $BA0$K0l2hLLJ,?J$`(B + ESC v $B8e$m$K0l2hLLJ,La$k(B + C-l $B2hLL$r=q$-D>$9!#$3$N$H$-!"85%+!<%=%k$N$"$C$?9T$,(B + $B2hLL$NCf1{$K$/$k$h$&$K$9$k(B + + >> $B:#%+!<%=%k$,$I$3$K$"$k$+!"$=$N6a$/$K$I$s$J%F%-%9%H$,=q$+$l$F$$$k(B + $B$+$r3P$($J$5$$!#(BC-l $B$r%?%$%W$7!"%+!<%=%k$,$I$3$K0\F0$7$?$+!"$=$N(B + $B6a$/$N%F%-%9%H$O$I$&$J$C$?$+$rD4$Y$F$_$J$5$$!#(B + +$B4pK\E*$J%+!<%=%k$N@)8f(B +====================== + + $B2hLLKh$N0\F0$O$G$-$k$h$&$K$J$j$^$7$?!#:#EY$O!"2hLL$NCf$G!"FCDj$N>l=j$K(B +$B0\F0$9$k$?$a$NJ}K!$r21$($^$7$g$&!#$3$l$K$O$$$/$D$+$N$d$jJ}$,$"$j$^$9!#0l$D(B +$B$NJ}K!$O!"A0(B(previous)$B<!(B(next)$B@h(B(forward)$B8e(B(backward)$B$K0\F0$9$k%3%^%s%I$r;H(B +$B$&$3$H$G$9!#$3$l$i$N%3%^%s%I$O$=$l$>$l!"(BC-p, C-n, C-f,C-b $B$K3d$jEv$F$i$l$F(B +$B$*$j!"8=:_$N>l=j$+$i?7$7$$>l=j$K%+!<%=%k$r0\F0$5$;$^$9!#?^$G=q$1$P!"(B + + + $BA0$N9T!$(BC-p + : + : + $B8e$NJ8;z!$(BC-b .... $B8=:_$N%+!<%=%k0LCV(B .... $B@h$NJ8;z!$(BC-f + : + : + $B<!$N9T!$(BC-n + + + $B$3$l$i$O!"$=$l$>$l!"(BPrevious, Next, Backward, Forward $B$NF,J8;z$K$J$C$F(B +$B$$$k$N$G!"21$($d$9$$$G$7$g$&!#$3$l$i$O!"4pK\E*$J%+!<%=%k0\F0%3%^%s%I$G$"$j!"(B +$B$$$D$G$b;H$&$b$N$G$9!#(B + + >> C-n $B$r2?2s$+%?%$%W$7!"!J:#!"$"$J$?$,FI$s$G$$$k!K$3$N9T$^$G%+!<%=(B + $B%k$r0\F0$5$;$J$5$$!#(B + + >> C-f $B$r;H$C$F9T$NCf$[$I$K0\F0$7!"(BC-p $B$G2?9T$+>e$K0\F0$7$F$_$J$5(B + $B$$!#%+!<%=%k$N0LCV$NJQ2=$KCm0U$7$J$5$$!#(B + + >> $B9T$N@hF,$G(B C-b $B$r%?%$%W$7$F$_$J$5$$!#%+!<%=%k$O$I$3$K0\F0$7$^$9$+(B + $B!)$5$i$K$b$&>/$7(B C-b $B$r%?%$%W$7!":#EY$O(B C-f $B$G9TKv$NJ}$KLa$j$J$5(B + $B$$!#%+!<%=%k$,9TKv$r1[$($k$H$I$&$J$j$^$9$+!)(B + + + $B2hLL$N@hF,$dKvHx$r1[$($F%+!<%=%k$r0\F0$5$;$h$&$H$9$k$H!"$=$NJ}8~$K$"$k(B +$B%F%-%9%H$,0\F0$7$FMh$F!"%+!<%=%k$O>o$K2hLLFb$K$"$k$h$&$K$5$l$^$9!#(B + + >> C-n $B$r;H$C$F!"%+!<%=%k$r2hLL$N2<C<$h$j2<$K0\F0$5$;$F$_$J$5$$!#2?(B + $B$,5/$3$j$^$7$?$+!)%+!<%=%k$N0LCV$O$I$&JQ$j$^$7$?$+!)(B + + $B0lJ8;zC10L$N0\F0$G$O$^$I$m$C$3$7$$$H;W$&$J$i!"C18lC10L$G0\F0$9$k$3$H$b(B +$B$G$-$^$9!#(BESC f $B$G0lC18lJ,@h$K?J$_!"(BESC b $B$G0lC18lJ,A0$KLa$j$^$9!#(B + +$BCm0U!'(B $BF|K\8l$K$D$$$F$O!"C18l$N@Z$lL\$rG'<1$9$k$3$H$O$G$-$^$;$s$,!"(B + $B5?;wE*$JJ8@a$rC18l$N@Z$lL\$H$7$F$$$^$9!#(B + + >> ESC f $B$d(B ESC b $B$r2?2s$+%?%$%W$7$F$_$J$5$$!#(BC-f $B$d(B C-b $B$HJ;MQ$7$F(B + $B$_$J$5$$!#(B + + C-f $B$d(B C-b $B$KBP$9$k!"(BESC f $B$d(B ESC b $B$NN`;w@-$KCmL\$7$^$7$g$&!#B?$/$N(B +$B>l9g!"(BESC <$BJ8;z(B>$B$OJ8=q4X78$N=hM}$K;H$o$l!"0lJ}(BC-<$BJ8;z(B>$B$O$=$l$h$j$b$b$C$H4p(B +$BK\E*$JBP>]!JJ8;z$H$+9T$H$+!K$KBP$9$kA`:n$K;H$o$l$^$9!#(B + + C-a $B$H(B C-e $B$bCN$C$F$$$FJXMx$J%3%^%s%I$G$9!#(BC-a $B$O%+!<%=%k$r9T$N@hF,$K(B +$B0\F0$5$;!"(BC-e $B$O9T$NKvHx$K0\F0$5$;$^$9!#(B + + + >> C-a $B$r#22s!"$=$l$+$i(B C-e $B$r#22sF~NO$7$F$_$J$5$$!#$3$l$i$N%3%^%s%I(B + $B$r#22s0J>e7+JV$7$F$b!"%+!<%=%k$O$=$l0J>e0\F0$7$J$$$3$H$KCm0U!#(B + + $B$"$HFs$D!"4JC1$J%+!<%=%k0\F0%3%^%s%I$,$"$j$^$9!#%U%!%$%k$N@hF,$K0\F0$9(B +$B$k(B ESC < $B$H!"%U%!%$%k$NKvHx$K0\F0$9$k(B ESC > $B$G$9!#(B + + $B%F%-%9%HCf$G%+!<%=%k$NB8:_$9$k0LCV$r!V%]%$%s%H!W$H8F$S$^$9!#8@$$$+$($l(B +$B$P!"%+!<%=%k$O!"%F%-%9%H$N$I$3$K%]%$%s%H$,$"$k$+$r2hLL>e$G<($7$F$$$k$N$G$9!#(B + + $B0J2<$KC1=c$J0\F0A`:n$K$D$$$FMWLs$7$^$9!#$3$N$J$+$K$O!"C18l$d9TC10L$G$N(B +$B0\F0%3%^%s%I$b4^$^$l$F$$$^$9!#(B + + C-f $B0lJ8;z@h$K?J$`(B + C-b $B0lJ8;z8e$KLa$k(B + + ESC f $B0lC18l@h$K?J$`(B + ESC b $B0lC18l8e$KLa$k(B + + C-n $B<!$N9T$K0\F0(B + C-p $BA0$N9T$K0\F0(B + + ESC ] $BCJMn$N=*$o$j$K0\F0(B + ESC [ $BCJMn$N@hF,$K0\F0(B + + C-a $B9T$N:G=i$K0\F0(B + C-e $B9T$N:G8e$K0\F0(B + + ESC < $B%U%!%$%k$N:G=i$K0\F0(B + ESC > $B%U%!%$%k$N:G8e$K0\F0(B + + >> $B3F!9$N%3%^%s%I$r;n$7$F$_$J$5$$!#$3$l$i$N%3%^%s%I$O!":G$b$7$P$7$P(B + $B;H$o$l$k$b$N$G$9!#:G8e$NFs$D$G$O!"$3$N>l=j$H$ON%$l$?$H$3$m$K0\F0(B + $B$9$k$N$G!"(B C-v $B$d(B ESC v $B$r;H$C$F$3$3$KLa$C$FMh$k$h$&$K$7$J$5$$!#(B + + Emacs$B$NB>$N%3%^%s%I$HF1MM$K!"$3$l$i$N%3%^%s%I$K$O!"7+$jJV$7$N2s?t$r;X(B +$BDj$9$k0z?t(B $B$rM?$($k$3$H$,$G$-$^$9!#$=$N$?$a$K$O!"%3%^%s%I$rF~NO$9$kA0$K!"(B +C-u$B$KB3$$$F7+$jJV$92s?t$rF~NO$7$^$9!#(B + + $BNc$($P!"(BC-u 8 C-f $B$H$9$k$H!"#8J8;zJ,@h$K0\F0$7$^$9!#(B + + >> C-n $B$"$k$$$O(B C-p $B$KE,Ev$J0z?t$r;XDj$7$F!"0l2s$N0\F0$G$J$k$Y$/$3(B + $B$N9T$N6a$/$KMh$k$h$&$K$7$F$_$J$5$$!#(B + + C-v $B$d(B ESC v $B$K$D$$$F$O>/$70c$$$^$9!#$3$N>l9g!";XDj$5$l$??t$N9T$@$12h(B +$BLL$r0\F0$9$k$3$H$K$J$j$^$9!#(B + + >> C-u 3 C-v $B$HF~NO$7$F$_$J$5$$!#(B + + $B85$KLa$k$K$O!"(BC-u 3 ESC v $B$r;H$($P$h$$$N$G$9!#(B + +$BCf;_%3%^%s%I(B +============ + + C-g $B$H$$$&%3%^%s%I$G!"F~NO$rI,MW$H$9$k$h$&$J%3%^%s%I$rCf;_$9$k$3$H$,(B +$B$G$-$^$9!#Nc$($P!"0z?t$rF~NO$7$F$$$kESCf$d!"#2$D0J>e$N%-!<F~NO$rI,MW$H$9$k(B +$B%3%^%s%I$rF~NO$7$F$$$k:GCf$K!"$=$l$r$d$a$?$/$J$C$?$i!"(BC-g $B$r;H$($PNI$$$N$G(B +$B$9!#(B + + >> C-u 100 $B$r%?%$%W$7$F0z?t$r#1#0#0$K@_Dj$7!"(BC-g $B$r%?%$%W$7$J$5$$!#(B + $B$=$N$"$H$G(B C-f $B$r%?%$%W$7$F$_$J$5$$!#2?J8;z0\F0$7$^$7$?$+!)$b$7(B + $B4V0c$C$F(B ESC $B$rF~NO$7$F$7$^$C$?;~$b!"(BC-g $B$rF~NO$9$l$P<h$j>C$;$^(B + $B$9!#(B + +$B%(%i!<(B +====== + + $B;~$K$O!"(BEmacs$B$G5v$5$l$F$$$J$$A`:n$r$7$F$7$^$&$3$H$,$"$j$^$9!#Nc$($P!"(B +$B%3%^%s%I$NDj5A$5$l$F$$$J$$%3%s%H%m!<%k!&%-!<$rF~NO$7$F$7$^$C$?;~$K$O!"(BEmacs +$B$O%Y%k$rLD$i$7!"$5$i$K!"2hLL$N0lHV2<$K!"2?$,0-$+$C$?$+$rI=<($7$^$9!#(B + + Emacs$B$N%P!<%8%g%s$K$h$C$F$O!"$3$NF~LgJT$K=q$+$l$F$$$k$3$H$r<B9T$G$-$J(B +$B$$>l9g$,$"$jF@$^$9!#$=$NMM$J>l9g$K$O!"%(%i!<%a%C%;!<%8$,I=<($5$l$^$9$+$i!"(B +$B2?$+%+!<%=%k0\F0%-!<$r2!$7$F!"$=$N<!$NItJ,$K?J$s$G2<$5$$!#(B + +$B%&%#%s%I%&(B +========== + + Emacs$B$O4v$D$b$N%&%#%s%I%&$r;}$D$3$H$H!"$=$N$=$l$>$l$KBP$7$F%F%-%9%H$r(B +$BI=<($9$k$3$H$,$G$-$^$9!#%X%k%W$d!"4v$D$+$N%3%^%s%I$+$i$N=PNO$rI=<($9$k$?$a(B +$B$K8=$l$?M>J,$J%&%#%s%I%&$r>C$9$?$a$K!"<!$N%3%^%s%I$rCN$kI,MW$,$"$j$^$9!#(B + + C-x 1 $B%&%#%s%I%&$r#1$D$K$9$k!#(B + + C-x 1 $B$O!"B>$N%&%#%s%I%&$r>C$7$F!"%+!<%=%k$N$"$k%&%#%s%I%&$r!"2hLLA4BN(B +$B$K9-$2$^$9!#(B + + >> $B%+!<%=%k$r$3$N9T$K;}$C$F$-$F!"(BC-u 0 C-l $B$H%?%$%W$7$^$9!#(B + + >> C-h k C-f $B$H%?%$%W$7$J$5$$!#?7$7$$%&%#%s%I%&$,(B C-f $B%3%^%s%I$N%I%-(B + $B%e%a%s%H$rI=<($9$k$?$a$K8=$l$k$HF1;~$K!"$3$N%&%#%s%I%&$,$I$N$h$&(B + $B$K=L$`$+$r4Q;!$7$J$5$$!#(B + + >> C-x 1$B$H%?%$%W$7$F!"%I%-%e%a%s%H$N8=$o$l$F$$$?%&%#%s%I%&$r>C$7$J$5(B + $B$$!#(B + +$BA^F~$H:o=|(B +========== + + $B%F%-%9%H$r%?%$%W$7$?$1$l$P!"C1$K$=$l$r%?%$%W$9$k$@$1$G9=$$$^$;$s!#L\$K(B +$B8+$($kJ8;z!J(B'A','7','*','$B$"(B'$B$J$I!K$O(BEmacs$B$K$h$C$F%F%-%9%H$G$"$k$H$_$J$5$l!"(B +$B$=$N$^$^A^F~$5$l$^$9!#9T$N=*$o$j$O2~9TJ8;z$GI=$5$l!"$3$l$rF~NO$9$k$K$O(B +<Return> $B$r%?%$%W$7$^$9!#(B + + $BD>A0$KF~NO$7$?J8;z$r:o=|$9$k$K$O!"(B<Delete> $B$rF~NO$7$^$9!#(B<Delete> $B$O!"(B +$B%-!<%\!<%I$G!V(BDelete$B!W$H=q$$$F$"$k%-!<$r2!$7$FF~NO$7$^$9!#!V(BDelete$B!W$N$+$o(B +$B$j$K!V(BRubout$B!W$H=q$$$F$"$k$+$bCN$l$^$;$s!#$h$j0lHLE*$K$O!"(B<Delete> $B$O!"8=:_(B +$B%+!<%=%k$N$"$k0LCV$ND>A0$NJ8;z$r:o=|$7$^$9!#(B + + >> $BJ8;z$r$$$/$D$+%?%$%W$7!"$=$l$+$i$=$l$i$r(B <Delete> $B$r;H$C$F:o=|$7(B + $B$J$5$$!#(B + + >> $B1&%^!<%8%s$r1[$($k$^$G%F%-%9%H$r%?%$%W$7$J$5$$!#%F%-%9%H$,0l9T$N(B + $BI}0J>e$KD9$/$J$k$H!"$=$N9T$O2hLL$+$i$O$_=P$7$F!V7QB3!W$5$l$^$9!#(B + $B1&C<$K$"$k(B'\'$B5-9f$O!"$=$N9T$,7QB3$5$l$F$$$k$3$H$rI=$7$F$$$^$9!#(B + Emacs$B$O!"8=:_JT=8Cf$N0LCV$,8+$($k$h$&$K9T$r%9%/%m!<%k$7$^$9!#2hLL(B + $B$N1&$"$k$$$O:8$NC<$K$"$k(B'\'$B5-9f$O!"$=$NJ}8~$K9T$,$^$@B3$$$F$$$k$3(B + $B$H$rI=$7$F$$$^$9!#(B + + $B$3$l$O!"J8>O$G@bL@$9$k$h$j<B:]$K$d$C$?J}$,$h$/H=$k$G$7$g$&!#(B + + >> $B@h$[$IF~NO$7$?!"7QB3$5$l$?9T$N>e$K%+!<%=%k$r$b$C$F$$$-!"(BC-d $B$G%F(B + $B%-%9%H$r:o=|$7$F!"%F%-%9%H$,0l9T$K<}$^$k$h$&$K$7$F$_$J$5$$!#7QB3(B + $B$rI=$9(B'\'$B5-9f$O>C$($^$7$?$M!#(B + + >> $B%+!<%=%k$r9T$N@hF,$K0\F0$7!"(B<Delete> $B$rF~NO$7$J$5$$!#$3$l$O$=$N9T(B + $B$ND>A0$N9T6g@Z$j$r:o=|$9$k$N$G!"$=$N9T$,A0$N9T$H$D$J$,$C$F$7$^$$(B + $B$^$9!#$D$J$,$C$?9T$,2hLL$NI}$h$jD9$/$J$k$H!"7QB3$NI=<($,$5$l$k$G(B + $B$7$g$&!#(B + + >> <Return> $B$r2!$7$F!"$b$&0lEY9T6g@Z$j$rA^F~$7$J$5$$!#(B + + Emacs$B$N$[$H$s$I$N%3%^%s%I$O!"7+$jJV$7$N2s?t$rM?$($k$3$H$,$G$-$^$9!#$3(B +$B$N$3$H$O!"J8;z$NA^F~$K$D$$$F$bEv$F$O$^$j$^$9!#(B + + >> C-u 8 * $B$HF~NO$7$F$_$J$5$$!#$I$&$J$j$^$7$?$+!#(B + + $BFs$D$N9T$N4V$K6uGr9T$r:n$j$?$$>l9g$K$O!"FsHVL\$N9T$N@hF,$K9T$-!"(BC-o $B$r(B +$BF~NO$7$^$9!#(B + + >> $BE,Ev$J9T$N@hF,$K9T$-!"$=$3$G(B C-o $B$rF~NO$7$F$_$J$5$$!#(B + + $B$3$l$G!"(BEmacs$B$G!"%F%-%9%H$rF~NO$7!"$^$?4V0c$$$r=$@5$9$k$b$C$H$b4pK\E*(B +$B$JJ}K!$r3X$s$@$3$H$K$J$j$^$9!#J8;z$HF1$8MM$K!"C18l$d9T$b:o=|$9$k$3$H$,$G$-(B +$B$^$9!#:o=|A`:n$K$D$$$FMWLs$9$k$H<!$N$h$&$K$J$j$^$9!#(B + + <Delete> $B%+!<%=%k$ND>A0$NJ8;z$r:o=|(B + C-d $B%+!<%=%k$N$"$kJ8;z$r:o=|(B + + ESC <Delete> $B%+!<%=%k$ND>A0$NC18l$r:o=|(B + ESC d $B%+!<%=%k0LCV0J9_$K$"$kC18l$r:o=|(B + + C-k $B%+!<%=%k0LCV$+$i9TKv$^$G$r:o=|(B + + $B2?$+$r:o=|$7$?8e$G!"$=$l$r85$KLa$7$?$/$J$k$3$H$,$"$j$^$9!#(BEmacs$B$O!"0l(B +$BJ8;z$h$j$bBg$-$$C10L$G:o=|$r9T$C$?;~$K$O!":o=|$7$?FbMF$rJ]B8$7$F$*$-$^$9!#(B +$B85$KLa$9$K$O!"(BC-y $B$r;H$$$^$9!#Cm0U$7$?$$$N$O!"(BC-y $B$r:o=|$r9T$C$?>l=j$@$1$G(B +$B$O$J$/!"$I$3$K$G$b=PMh$k$3$H$G$9!#(BC-y $B$O!"J]B8$5$l$?%F%-%9%H$r8=:_%+!<%=%k(B +$B$N$"$k>l=j$KA^F~$9$k$?$a$N%3%^%s%I$G$9$+$i!"$3$l$r;H$C$F%F%-%9%H$N0\F0$r9T(B +$B$&$3$H$,$G$-$^$9!#(B + + $B:o=|$r9T$&%3%^%s%I$K$O!"(B"Delete" $B%3%^%s%I$H!"(B"Kill" $B%3%^%s%I$H$,$"$j$^(B +$B$9!#(B"Kill" $B%3%^%s%I$G$O:o=|$5$l$?$b$N$OJ]B8$5$l$^$9$,!"(B"Delete" $B%3%^%s%I$G(B +$B$OJ]B8$5$l$^$;$s!#$?$@$7!"7+$jJV$72s?t$,M?$($i$l$k$H!"J]B8$5$l$^$9!#(B + + >> C-n $B$r#22s$[$I%?%$%W$7$F!"2hLL$NE,Ev$J>l=j$K0\F0$7$J$5$$!#$=$7$F!"(B + C-k $B$G!"$=$N9T$r:o=|$7$J$5$$!#(B + + $B0l2sL\$N(B C-k $B$G$=$N9T$NFbMF$,:o=|$5$l!"$b$&0lEY(B C-k $B$rF~NO$9$k$H!"$=$N(B +$B9T<+?H$,:o=|$5$l$^$9!#$b$7!"(BC-k $B$K7+$jJV$72s?t$r;XDj$7$?>l9g$K$O!"$=$N2s?t(B +$B$@$1$N9T$,!JFbMF$H9T<+?H$H$,F1;~$K!K:o=|$5$l$^$9!#(B + + $B:#:o=|$5$l$?%F%-%9%H$O!"J]B8$5$l$F$$$k$N$G!"$=$l$r<h$j=P$9$3$H$,$G$-$^(B +$B$9!#$=$N$?$a$K$O!"(BC-y $B$r%?%$%W$7$^$9!#(B + + >> C-y $B$r;n$7$F$_$J$5$$!#(B + + C-k $B$r2?EY$bB3$1$F9T$&$H!":o=|$5$l$k%F%-%9%H$O!"$^$H$a$FJ]B8$5$l!"(BC-y +$B$G!"$=$NA4$F$,<h$j=P$5$l$^$9!#(B + + >> C-k $B$r2?EY$b%?%$%W$7$F$_$J$5$$!#(B + + >> $B%F%-%9%H$r<h$j=P$9$K$O!"(BC-y $B$G$9!#%+!<%=%k$r?t9T2<$K0\F0$5$;!"$b(B + $B$&0lEY(B C-y $B$r%?%$%W$7$F$_$J$5$$!#$3$l$G%F%-%9%H$N%3%T!<$,$G$-$k$o(B + $B$1$G$9!#(B + + $B8=:_2?$+$N%F%-%9%H$,J]B8$5$l$F$$$F!"$5$i$KB>$N%F%-%9%H$r:o=|$9$k$H$I$&(B +$B$J$k$G$7$g$&$+!#(BC-y $B$O!"$b$C$H$b:G6a:o=|$5$l$?$b$N$r<h$j=P$7$^$9!#(B + + + >> $B9T$r:o=|$7!"%+!<%=%k$r0\F0$5$;!"JL$N9T$r:o=|$7$J$5$$!#(BC-y $B$r9T$&(B + $B$H!"#2HVL\$N9T$,F@$i$l$^$9!#(B + +$B<h$j>C$7(B(UNDO) +============== + + $B$$$D$G$b!"%F%-%9%H$rJQ99$7$?$1$l$I$b!"$=$l$r$b$H$KLa$7$?$$$H$-$O(BC-x u +$B$GD>$j$^$9!#IaDL$O4V0c$($?%3%^%s%I$rL58z$K$9$kF/$-$r$7$^$9!#7+$jJV$7$F(BUNDO +$B$r9T$J$*$&$H$9$k;~$O!"2?EY$b$=$N%3%^%s%I$r9T$J$($P=PMh$k$h$&$K$J$C$F$$$^$9!#(B + + >> $B$3$N9T$r(BC-k$B$G>C$7$F2<$5$$!#$=$7$F!"(BC-x u$B$GLa$7$F2<$5$$!#(B + + C-_$B$O!"(BUNDO$B$r9T$J$&!"$b$&0l$D$N%3%^%s%I$G$9!#5!G=$O!"(BC-x u$B$HF1$8$G$9!#(B + + C-_$B$d(BC-x u$B$K(BUNDO$B$N2s?t$r!"M?$($k$3$H$,=PMh$^$9!#(B + + +$B%U%!%$%k(B +======== + + $B%F%-%9%H$X$NJQ99$r1J5WE*$K$9$k$?$a$K$O!"$=$l$r%U%!%$%k$KJ]B8$7$J$1$l$P(B +$B$J$j$^$;$s!#J]B8$5$l$J$$$H!"$[$I$3$7$?JQ99$O!"(BEmacs$B$r=*N;$9$k$HF1;~$K<:$o$l(B +$B$F$7$^$$$^$9!#(B + + $B$$$^8+$F$$$k%U%!%$%k$KBP$7$F!"$"$J$?$NJT=8$r9T$C$?$b$N$r=q$-9~$_$^$9!#(B +$B$$$^8+$F$$$k%U%!%$%k$H$O!"4JC1$K$$$($PJT=8$7$F$$$k%U%!%$%k<+BN$N$3$H$G$9!#(B + + $B$"$J$?$,%U%!%$%k$r%;!<%V!JJ]B8$9$k!K$9$k$^$G!":#$^$G$NJQ99$OJT=8$7$F$$(B +$B$k%U%!%$%k$K=q$-9~$^$l$k;v$O$"$j$^$;$s!#$=$l$O!"$"$J$?$,$=$N$h$&$K9T$$$?$/(B +$B$J$$$N$K!"ESCf$^$GJQ99$r2C$($?$b$N$,>!<j$K=q$-9~$^$l$k$h$&$J;v$,$J$$$h$&$K(B +$B$G$9!#(B + + $B%;!<%V$r9T$C$?8e$G$5$(JQ99$7$?$b$N$,4V0c$C$F$$$?;~$N$?$a$K(BEmacs$B$OL>A0(B +$B$rJQ$($F%*%j%8%J%k$N%U%!%$%k$r;D$7$^$9!#(B + +$BHw9M(B: $B$^$?!"(BEmacs$B$OITB,$N;vBV$KBP$7!"0lDj$N%?%$%_%s%0$4$H$K<+F0E*(B + $B$KJT=8$7$F$$$k%U%!%$%k$NFbMF$rL>A0$rJQ$($?%U%!%$%k$K%;!<%V$7(B + $B$^$9!#$3$l$K$h$C$F!"K|0l$N>l9g$O9T$C$?$NJQ99$KBP$7:G>.8B$NHo(B + $B32$G:Q$`$h$&$K$J$C$F$$$^$9!#(B + + $B2hLL$N2<$NJ}$r8+$k$H!"$3$N$h$&$J46$8$G%b!<%I%i%$%s$,I=<($5$l$F$$$k$H;W(B +$B$$$^$9!#(B + + +($BNc(B) [--]J:--**-Mule: MULE.tut (Fundamental) ---55%-------------- + + + $B$3$N(BEmacs$B%A%e!<%H%j%"%k$N%3%T!<$O(BMULE.tut$B$H8F$P$l$F$$$^$9!#%U%!%$%k$r(B +$B%U%!%$%s%I!J%U%!%$%k$r8+$D$1$F%P%C%U%!$KFI$_9~$`$3$H!K$9$k$H!"(BMULE.tut$B$NIt(B +$BJ,$KI=<($5$l$^$9!#Nc$($P!"(Bnew-file$B$H$$$&L>A0$N%U%!%$%k$r%U%!%$%s%I$7$?$J$i(B +$B$P!"(B"Mule: new-file"$B$H$$$&%b!<%I%i%$%s$K$J$k$G$7$g$&!#(B + +$BCm0U!'(B $B%b!<%I%i%$%s$K$D$$$F$O8e$[$I@bL@$7$^$9!#>/$7$*BT$A$r!#(B + + $B%U%!%$%k$r%U%!%$%s%I$7$?$j!"%;!<%V$7$?$j$9$k%3%^%s%I$O!"$3$l$^$G$N$b$N(B +$B$H$O0c$$!"#2$D$NJ8;z$+$i$J$C$F$$$^$9!#(BC-x $B$KB3$$$FF~NO$9$kJ8;z$,!"%U%!%$%k(B +$B$KBP$7$F9T$&A`:n$rI=$7$^$9!#(B + + $B$b$&0l$D$3$l$^$G$N$b$N$H0c$&E@$O!"%U%!%$%s%I$N;~!"%U%!%$%kL>$r(BEmacs$B$K(B +$BLd$o$l$^$9!#$3$N$3$H$r!"C<Kv$+$i0z?t$rFI$_9~$s$G$/$k%3%^%s%I$H8@$C$F$$$^$9!#(B + +$BCm0U!'(B $B$3$N>l9g$O%U%!%$%kL>$G$9!#(B + + C-x C-f $B%U%!%$%k$r8+$D$1$k!J%U%!%$%s%I$9$k!K(B + + Emacs$B$O%U%!%$%kL>$rJ9$$$F$-$^$9!#$=$l$O!"2hLL$N2<$N9T$K8=$l$^$9!#%U%!(B +$B%$%kL>$r;XDj$7$F$$$kItJ,$O!"%_%K%P%C%U%!$H8F$P$l$k$b$N$G$9!#%_%K%P%C%U%!$O(B +$B$3$NMM$J;H$o$lJ}$r$7$^$9!#%U%!%$%kL>$KB3$$$F!"%j%?!<%s%-!<$r2!$9$H!"%_%K%P(B +$B%C%U%!$KI=<($5$l$F$$$?FbMF$O$b$&I,MW$G$O$J$/$J$k$N$G>C$($F$7$^$$$^$9!#(B + + >> C-x C-f$B$H%?%$%W$7$?8e$K(BC-g$B$H%?%$%W$7$F2<$5$$!#%_%K%P%C%U%!$NFbMF(B + $B$r<h$j>C$7!"$^$?!"(BC-x C-f$B%3%^%s%I$b<h$j>C$7$^$9!#$H8@$&Lu$G!"2?$b(B + $B%U%!%$%k$r8+$D$1$k$h$&$J$3$H$O$7$^$;$s!#(B + + $B:#EY$O%U%!%$%k$r%;!<%V$7$F$_$^$7$g$&!#:#$^$G$NJQ99$rJ]B8$9$k$?$a$K$O<!(B +$B$N$h$&$J%3%^%s%I$r;H$$$^$9!#(B + + C-x C-s $B%U%!%$%k$r%;!<%V$9$k(B + + Emacs$B$NFbMF$O%U%!%$%k$K=q$-=P$5$l$^$9!#%;!<%V$9$k;~!"%*%j%8%J%k$N(B +$B%U%!%$%k$O?7$7$$L>A0$r$D$1$i$l$F;D$5$l$F$$$k$N$GFbMF$O<:$o$l$^$;$s!#$=(B +$B$N?7$7$$L>A0$O%*%j%8%J%k$N%U%!%$%k$NL>A0$K(B'~'$B$r$D$1$?$b$N$G$9!#(B + + $B%;!<%V$,=*$o$k$H!"(BEmacs$B$O%;!<%V$7$?%U%!%$%k$NL>A0$rI=<($7$^$9!#(B + + >> C-x C-s$B$H%?%$%W$7$F%A%e!<%H%j%"%k$N%3%T!<$r%;!<%V$7$F2<$5$$!#$=$N(B + $B;~!"2hLL$N2<$NJ}$K(B"Wrote ...../MULE.tut"$B$HI=<($5$l$^$9!#(B + + $B?7$7$$%U%!%$%k$r:n$k;~!"$"$?$+$b0JA0$+$i$"$C$?%U%!%$%k$r%U%!%$%s%I$9$k(B +$B$h$&$J%U%j$r$7$^$9!#$=$&$7$F!"$=$N%U%!%$%s%I$7$?%U%!%$%k$K%?%$%W$7$F$$$-$^(B +$B$9!#(B + + $B%U%!%$%k$r%;!<%V$7$h$&$H$7$?;~$K=i$a$F!"(BEmacs$B$O:#$^$GJT=8$7$F$$$?FbMF(B +$B$r%U%!%$%k$NCf$K=q$-9~$_$^$9!#(B + + +$B%P%C%U%!(B +======== + + $B$b$7!"#2HVL\$N%U%!%$%k$r(B C-x C-f $B$G<h$j=P$9$H!"#1HVL\$N%U%!%$%k$O(BEmacs +$BFbIt$K;D$j$^$9!#(BEmacs$BFbIt$K$"$k%U%!%$%k$+$i%F%-%9%H$rFI$_9~$s$GJ]B8$7$F$$$k(B +$B$b$N$O%P%C%U%!$H8F$P$l$^$9!#%U%!%$%k$N<h$j=P$7$O!"(BEmacs$BFbIt$K?7$7$$%P%C%U%!(B +$B$r:n$j$^$9!#(B + + Emacs$B$NCf$KJ]B8$7$F$$$k%P%C%U%!$N%j%9%H$r8+$k$K$O!"<!$N$h$&$K%?%$%W$7(B +$B$^$9!#(B + + C-x C-b + + >> C-x C-b $B$H%?%$%W$7$J$5$$!#$=$l$>$l$N%P%C%U%!$,$I$N$h$&$KL>A0$r;}(B + $B$C$F$$$k$+!"$=$7$F!"$I$N$h$&$J%U%!%$%kL>$r$D$1$F$$$k$N$+4Q;!$7$J(B + $B$5$$!#(B + + $B%P%C%U%!$K$O%U%!%$%k$H0lCW$J$$$b$N$b$"$j$^$9!#$?$H$($P!"(B +"*Buffer List*" $B$H$$$&%U%!%$%k$O$"$j$^$;$s!#$3$l$O(B C-x C-b $B$K$h$C$F:n$i$l(B +$B$?%P%C%U%!%j%9%H$KBP$7$F$N%P%C%U%!$G$9!#(B + + $B$"$J$?$,8+$F$$$k(BEmacs$B%&%#%s%I%&Fb$K$"$k!"$I$s$J%F%-%9%H$G$b!"$$$:$l$+(B +$B$N%P%C%U%!Fb$K$"$j$^$9!#(B + + >> $B%P%C%U%!%j%9%H$r>C$9$?$a(B C-x 1 $B$H%?%$%W$7$J$5$$!#(B + + $B$b$7!"$"$k%U%!%$%k$N%F%-%9%H$KJQ99$r9T$J$C$F$+$i!"B>$N%U%!%$%k$r<h$j=P(B +$B$7$?$H$7$?$i!":G=i$N%U%!%$%k$O%;!<%V$5$l$F$$$^$;$s!#$=$NJQ99$O(BEmacs$BFbIt$N%U(B +$B%!%$%k$HBP1~$9$k%P%C%U%!$NCf$@$1$K9T$J$o$l$F$$$^$9!#(B + + $B#2HVL\$N%U%!%$%k$KBP1~$9$k%P%C%U%!$r:n$C$?$j!"%(%G%#%C%H$7$?$j$7$F$b!"(B +$B#1HVL\$N%U%!%$%k$KBP1~$9$k%P%C%U%!$K$O2?$b1F6A$rM?$($^$;$s!#$3$l$O$H$F$b;H(B +$B$$0W$/!"$^$?!"#1HVL\$N%U%!%$%k$KBP1~$9$k%P%C%U%!$r<h$C$F$*$/$?$a$KLr$KN)$D(B +$BJ}K!$G$9!#(B + + C-x C-s $B$G%P%C%U%!$r%;!<%V$9$k$?$a$K(B C-x C-f $B$G%P%C%U%!$r@Z$jBX$($k$N(B +$B$OLq2p$G$9!#$=$3$G<!$N%3%^%s%I$r;H$$$^$9!#(B + + C-x s $B8=:_$"$k%P%C%U%!$r%;!<%V$9$k!#(B + + C-x s $B$OFbMF$rJQ$($?%P%C%U%!A4$F$r%U%!%$%k$K%;!<%V$7$^$9!#$3$N;~!"$R$H(B +$B$D$R$H$D$N(B($B%;!<%V$5$l$k$Y$-(B)$B%P%C%U%!$KBP$7$F!"%;!<%V$9$k$+!"$7$J$$$+$r(By$B$+(Bn +$B$GLd$o$l$^$9!#$3$NI=<($O2hLL$N2<$N9T$KI=<($5$l$^$9!#Nc$($P!"$3$N$h$&$K$G$9!#(B + + Save file /usr/private/yours/MULE.tut? (y or n) + + + +$B%3%^%s%I$N3HD%(B +============== + + $B%(%G%#%?$K$O!"%3%s%H%m!<%k!&%-!<$d%a%?!&%-!<$GF~NO$G$-$k$b$N$h$j$b$:$C(B +$B$HB?$/$N%3%^%s%I$,$"$j$^$9!#$3$l$i$r07$&$?$a$K!"3HD%!J(BeXtend$B!K%3%^%s%I$r(B +$B;H$$$^$9!#$=$l$K$O!"0J2<$N#2$D$N<oN`$,$"$j$^$9!#(B + + C-x $BJ8;z$K$h$k3HD%!#B3$1$F0lJ8;z$rF~NO$7$^$9!#(B + ESC x $BL>A0$K$h$k3HD%!#B3$1$F%3%^%s%I$NL>A0$rF~NO$7$^$9!#(B + + $B$3$l$i$O0lHL$K!"JXMx$@$1$l$I$b!"$3$l$^$G8+$F$-$?$b$N$[$IIQHK$K$OMQ$$$i(B +$B$l$J$$%3%^%s%I$N$?$a$N$b$N$G$9!#(BC-x C-f $B!J%U%!%$%s%I!K$d(B C-x C-s$B!J%;!<%V!K(B +$B$O$3$NCg4V$G$9!#B>$K!"(BC-x C-c$B!J%(%G%#%?$N=*N;!K$b$=$&$G$9!#(B + + C-z$B$O(BEmacs$B$rH4$1$k$N$KNI$/;H$o$l$kJ}K!$G$9!#(BEmacs$B$r=*N;$9$k$3$H$J$/!"(B +$B0lC6!"(Bcsh$B$N%l%Y%k$KLa$k$K$O0lHVNI$$J}K!$H8@$($k$G$7$g$&!#(BC-z$B$r9T$J$o$l$F$b(B +Emacs$B$O%9%H%C%W$7$F$$$k$@$1$G!"FbMF$,GK2u$5$l$k$H$$$&$3$H$O$"$j$^$;$s!#(B + +$BCm0U(B: $B$?$@$7(BX-window$B$G9T$J$C$F$$$k>l9g!"$b$7$/$O;HMQ$7$F$$$k%7%'%k(B + $B$,(Bsh$B$N;~$O!"$3$N8B$j$G$O$"$j$^$;$s!#(B + + + C-x $B%3%^%s%I$O!"$?$/$5$s$"$j$^$9!#$9$G$K3X$s$@$b$N$O0J2<$N$b$N$G$9!#(B + + C-x C-f $B%U%!%$%k$NJT=8!J(BFind$B!K(B + C-x C-s $B%U%!%$%k$NJ]B8!J(BSave$B!K(B + C-x C-b $B%P%C%U%!%j%9%H$NI=<((B + C-x C-c $B%(%G%#%?$r=*N;$9$k!#%U%!%$%k$NJ]B8$O!"<+F0E*$K$O9T$o$l$^$;(B + $B$s!#$7$+$7!"$b$7%U%!%$%k$,JQ99$5$l$F$$$l$P!"%U%!%$%k$NJ]B8(B + $B$r$9$k$N$+$I$&$+$rJ9$$$F$-$^$9!#J]B8$7$F=*N;$9$kIaDL$NJ}K!(B + $B$O!"(BC-x C-s C-x C-c $B$H$9$k$3$H$G$9!#(B + + $BL>A0$K$h$k3HD%%3%^%s%I$K$O!"$"$^$j;H$o$l$J$$$b$N$d!"FCDj$N%b!<%I$G$7$+(B +$B;H$o$J$$$b$N$J$I$,$"$j$^$9!#Nc$H$7$F!"(B"command-apropos" $B$r$H$j$"$2$^$9!#$3(B +$B$N%3%^%s%I$O%-!<%o!<%I$rF~NO$5$;!"$=$l$K%^%C%A$9$kA4$F$N%3%^%s%I$NL>A0$rI=(B +$B<($7$^$9!#(BESC x $B$H%?%$%W$9$k$H!"%9%/%j!<%s$N2<$K(B "M-x" $B$,I=<($5$l$^$9!#$3$l(B +$B$KBP$7$F!"<B9T$9$k%3%^%s%I$NL>A0!J:#$N>l9g!"(B"command-apropos"$B!K$rF~NO$7$^$9!#(B +"command-a" $B$^$GF~NO$7$?8e%9%Z!<%9$rF~$l$l$P!"8e$NItJ,$O<+F0E*$KJd$o$l$^$9!#(B +$B$3$N8e!"%-!<%o!<%I$rJ9$+$l$^$9$+$i!"CN$j$?$$J8;zNs$r%?%$%W$7$^$9!#$J$*!"%-!<(B +$B%o!<%I$rF~$l$J$$$H!"A4$F$N%3%^%s%I$,I=<($5$l$^$9!#(B + + >> ESC x $B$r%?%$%W$7!"B3$1$F!"(B"command-apropos<Return>" $B$"$k$$$O(B + "command-a<Space><Return>" $B$H%?%$%W$7$^$9!#<!$K!"(B"kanji<Return>" + $B$H%?%$%W$7$^$9!#(B + + $B8=$l$?!V%&%#%s%I%&!W$r>C$9$K$O!"(BC-x 1 $B$H%?%$%W$7$^$9!#(B + +$B%b!<%I%i%$%s(B +============ + + $B$b$7$f$C$/$j$H%3%^%s%I$rBG$C$?$J$i$P!"2hLL$N2<Dl$N%(%3!<%(%j%"$H8F$P$l(B +$B$k>l=j$KBG$C$?$b$N$,I=<($5$l$^$9!#%(%3!<%(%j%"$O2hLL$N(B1$B$P$s2<$N9T$G$9!#$=$N(B +$B$9$0>e$N9T$O!"%b!<%I%i%$%s$H8F$P$l$F$$$^$9!#%b!<%I%i%$%s$O$3$s$JIw$KI=<($5(B +$B$l$F$$$k$G$7$g$&!#(B + + [--]J:--**-Mule: MULE.tut (Fundamental) ---NN%-------------- + + +$BCm0U(B: NN%$B$N(BNN$B$O?t;z$,F~$C$F$$$^$9!#$"$J$?$,;H$C$F$$$k(BEmacs$B$N%b!<(B + $B%I%i%$%s$H0c$&$+$bCN$l$J$$$1$I!"92$F$J$$$h$&$K!#Nc$($P!";~4V(B + $B$d(Buptime$B$,I=<($5$l$F$$$k$N$O!"(Bdisplay-time$B$H$$$&5!G=$,F0$$$F(B + $B$$$k$+$i$G$9!#(B + + $B$3$N9T$K$h$C$FB?$/$NM-MQ$J>pJs$,F@$i$l$^$9!#(B + + + $B:#!"$"$J$?$,8+$F$$$k%U%!%$%kL>$rI=<($7$F$$$^$9!#(BNN%$B$O8=:_%9%/%j!<%s>e(B +$B$K%U%!%$%k$N0lHV>e$+$i2?%Q!<%;%s%HL\$,I=<($5$l$F$$$k$+$r<($7$F$$$^$9!#%U%!(B +$B%$%k$N0lHV:G=i$rI=<($7$F$$$k$J$i$P!"(B--Top--$B$HI=<($5$l$F$^$9!#%U%!%$%k$N0lHV(B +$B:G8e$rI=<($7$F$$$k$J$i$P!"(B--Bot--$B$HI=<($5$l$^$9!#2hLL$NCf$K%U%!%$%k$NA4$F$,(B +$BI=<($5$l$F$$$k$J$i$P!"(B--All--$B$HI=<($5$l$^$9!#(B + + $B%b!<%I%i%$%s$N>.3g8L$NCf$O!":#$I$s$J%b!<%I$KF~$C$F$$$k$+$r<($7$F$$$^$9!#(B +$B8=:_$O!"%G%U%)%k%H$N(BFundamental$B$KF~$C$F$$$^$9!#$3$l$b%a%8%c!<%b!<%I$N0lNc$G(B +$B$9!#(B + + Emacs$B$O(BLisp mode$B$d(BText mode$B$N$h$&$J$3$H$J$k%W%m%0%i%`8@8l$d%F%-%9%H$K(B +$BBP$7$F%(%G%#%C%H$r9T$&$?$a$N4v$D$+$N%a%8%c!<%b!<%I$r;}$C$F$$$^$9!#$I$s$J;~(B +$B$G$bI,$:$$$:$l$+$N%a%8%c!<%b!<%I$N>uBV$K$J$C$F$$$^$9!#(B + + $B$=$l$>$l$N%a%8%c!<%b!<%I$O4v$D$+$N%3%^%s%I$rA4$/0c$&?6$kIq$$$K$7$F$7$^(B +$B$$$^$9!#Nc$r>e$2$F$_$^$7$g$&!#%W%m%0%i%`$NCf$K%3%a%s%H$r:n$k%3%^%s%I$,$"$j(B +$B$^$9!#%3%a%s%H$r$I$NMM$J7A<0$K$9$k$+$O!"3F%W%m%0%i%`8@8l$K$h$C$F0c$$$^$9$,!"(B +$B$=$l$>$l$N%a%8%c!<%b!<%I$O!"$-$A$s$HF~$l$F$/$l$^$9!#(B + + $B$=$l$>$l$N%a%8%c!<%b!<%I$KF~$k$?$a$N%3%^%s%I$O%b!<%IL>$N3HD%$5$l$?$b$N(B +$B$K$J$C$F$$$^$9!#Nc$($P!"(BM-x fundamental-mode$B$O(BFundamental$B$KF~$k$?$a$N$b$N$G(B +$B$9!#(B + + $B$b$7!"1Q8l$r%(%G%#%C%H$9$k$J$i$P!"(BText mode$B$KF~$j$^$9!#(B + + >> M-x text-mode <Retuen>$B$H%?%$%W$7$J$5$$!#(B + + $B8=:_$N%a%8%c!<%b!<%I$K$D$$$F$N%I%-%e%a%s%H$r8+$?$$;~$O!"(BC-h m$B$H%?%$%W(B +$B$7$^$9!#(B + + >> C-h m $B$r;H$C$F(BText mode$B$H(BFundamental mode$B$N0c$$$rD4$Y$J$5$$!#(B + + >> C-x 1$B$G%I%-%e%a%s%H$r2hLL$+$i>C$7$J$5$$!#(B + + $B:8C<$N(B '[--]' $B$O8=:_$N%-!<F~NO$N%b!<%I$r<($7$F$$$^$9!#(B[--] $B$N;~$K$O(B +$B1Q8l%"%k%U%!%Y%C%H$,$=$N$^$^F~NO$G$-$^$9!#F~NO%b!<%I$K$D$$$F$N>\$7$$@bL@$O(B +$B!V$?$^$4!W$N%^%K%e%"%k$rD4$Y$F2<$5$$!#(B + + $B$=$N$9$01&$K$O%3!<%IBN7O(B (coding-system) $B$K4X$9$k%U%i%0$N>uBV$,I=(B +$B<($5$l$F$$$^$9!#(BMule $B$O!"%U%!%$%kF~=PNO!"F~NO!"2hLL=PNO$K$D$$$F!"$=$l$>$lFH(B +$BN)$K%3!<%IBN7O$r;XDj$5$;$k$3$H$,=PMh$^$9$,!"DL>o$O%U%!%$%kMQ$N%3!<%IBN7O$N(B +$B%K!<%b%K%C%/$N$_I=<($7$F$$$^$9!#(B + + >> $B%b!<%I%i%$%s>e$K(B"J:","S:",$B$b$7$/$O(B "E:"$B$,I=<($5$l$F$$$k$+$I$&$+3N(B + $BG'$7$J$5$$!#(B + + $B:G=i$N0lJ8;z$,%3!<%IBN7O$N%K!<%b%K%C%/!"<!$N(B ':' $B$,8=:_1Q8l0J30$NJ8;z(B +$B!JF|K\8l!"Cf9q8l$J$I!K$b$A$c$s$HI=<($9$k$H$$$&$3$H$r<($7$F$$$^$9!#(BJ$B$O(BJUNET +$B$G;H$o$l$F$$$k(B JIS $B%3!<%I!"(BS $B$O(B Shift-JIS$B!"(BE $B$OF|K\8l(BEUC $B$r<($7$F$$$^$9!#(B +$BB?9q8l$NI=<($NM-L5$O(B C-x C-k t $B$G(B ON/OFF$B$N%H%0%k$,$G$-$^$9!#(B + + $B<!$NNc$O!"0lEYB?9q8lI=<($r(BOFF$B$7$F$+$i!"$b$&0lEY(BON$B$r9T$C$F$_$^$9!#(B + + >> C-x C-k t$B$r(B2$BEY9T$$$J$5$$!#(B + + $BF~NO%b!<%I$,(BJIS$B%3!<%I$N@_Dj$H$J$C$F$$$k;~!"$b$7$"$J$?$N;H$C$F$$$kC<Kv(B +$B$K%a%?!&%-!<$,IU$$$F$$$k$J$i!"%(%9%1!<%W!&%-!<$NBe$o$j$K$=$l$r;H$&$3$H$,=P(B +$BMh$^$9!#$=$N;~!"%a%?!&%-!<$N;H$$J}$O%3%s%H%m!<%k!&%-!<$HF1MM$K2!$7$J$,$iJ8(B +$B;z$r%?%$%W$7$^$9!#(BESC <$BJ8;z(B>$B$b(BM-<$BJ8;z(B>$B$bF1$8F/$-$r$7$^$9!#:#$^$G$N@bL@$G(BESC +<$BJ8;z(B>$B$H9T$J$C$F$$$?$H$3$m$,!"(BM-<$BJ8;z(B>$B$H$J$j$^$9!#Cm0U$7$J$1$l$P$J$i$J$$$N(B +$B$O!"%7%U%H(BJIS$B$d(BEUC$B%3!<%I$N;~$O;HMQ$G$-$^$;$s!#(B + + $B%3!<%IBN7O$N$N@Z$jBX$($O!"3F!9$N%P%C%U%!$KBP$7$F$N$_M-8z$G$9!#$=$l$>$l(B +$B$N!"%3!<%IBN7O;XDj$K$D$$$F$O!"(BC-h a coding-system <Return>$B$G8+$k$3$H(B +$B$,=PMh$^$9!#(B + + >> C-h a coding-system <Return>$B$G=P$F$/$k%I%-%e%a%s%HCf$N!"(B + set-display-coding-system, set-file-coding-system, + set-process-coding-system $B$N@bL@$rFI$_$J$5$$!#(B + +$B8!:w(B +===== + + $BJ8;zNs$r!"%U%!%$%kFb$G!"A0J}Kt$O8eJ}$K!"C5$9;v$,$G$-$^$9!#8!:w$r;O$a$k(B +$B%3%^%s%I$O!"%+!<%=%k0LCV0J9_$r8!:w$9$k$J$i$P(B C-s$B!"%+!<%=%k0LCV0JA0$J$i$P(B +C-r $B$G$9!#(BC-s $B$r%?%$%W$9$k$H!"%(%3!<%(%j%"$K(B "I-search:"$B$H$$$&J8;zNs$,%W%m(B +$B%s%W%H$H$7$FI=<($5$l$^$9!#(BESC$B$r2!$9$H!"=*N;$G$-$^$9!#(B + + + >> C-s$B$G8!:w$,;O$^$j$^$9!#$=$l$+$i!"$f$C$/$j$H#1J8;z$:$D(B"cursor"$B$H$$(B + $B$&C18l$rF~NO$7$^$9!##1J8;zF~NO$9$k$4$H$K!"%+!<%=%k$O!"$I$s$JF0$-(B + $B$r$7$^$9$+(B? + + >> $B$b$EY(B C-s $B$r%?%$%W$9$k$H!"<!$N(B"cursor"$B$r8+$D$1$i$l$^$9!#(B + + >> <Delete>$B$r#42sF~NO$7$F!"%+!<%=%k$NF0$-$r8+$J$5$$!#(B + + >> ESC$B$r2!$7$F!"=*N;$7$^$9!#(B + + $BC5$7$?$$J8;zNs$r%?%$%WCf$G$b!"%?%$%W$7$?J8;zItJ,$@$1$G!"8!:w$r;O$a$^$9!#(B +$B<!$NJ8;z$rC5$9$K$O!":F$S(BC-s$B$r%?%$%W$7$^$9!#$b$7!"J8;zNs$,B8:_$7$J$+$C$?$i!"(B +$B%a%C%;!<%8$,I=<($5$l$^$9!#(BC-g $B$G$b=*N;$G$-$^$9!#(B + + $B8!:w<B9TCf$K(B<Delete>$B$rF~NO$9$k$H!"8!:wJ8;zNs$N#1HV8e$m$NJ8;z$,>C$($^$9!#(B +$B$=$7$F!"%+!<%=%k$O!"A02s$N0LCV$KLa$j$^$9!#$?$H$($P!"(B"cu"$B$H%?%$%W$7$F!":G=i(B +$B$N(B"cu"$B$N0LCV$K%+!<%=%k$,F0$$$?$H$7$^$9!#$3$3$G(B<Delete>$B$rF~NO$9$k$H!"%5!<%A(B +$B%i%$%s$N(B'u'$B$,>C$(!"%+!<%=%k$O!"(B'u'$B$r%?%$%W$9$kA0$K!"%+!<%=%k$,$"$C$?(B'c'$B$N0L(B +$BCV$K!"0\F0$7$^$9!#(B + + $B8!:w<B9TCf$K!"(BC-s $B$d(B C-r $B0J30$N%3%s%H%m!<%kJ8;z$r%?%$%W$9$k$H!"8!:w$O(B +$B=*N;$7$^$9!#(B + + C-s $B$O!"8=:_$N%+!<%=%k0LCV0J9_$K=P$F$/$k8!:wJ8;zNs$rC5$7$^$9!#$b$7!"A0(B +$B$NJ}$rC5$7$?$+$C$?$i!"(BC-r $B$r%?%$%W$9$k$3$H$G!"5UJ}8~8!:w$,$G$-$^$9!#(BC-s $B$H(B +C-r $B$O!"8!:w$NJ}8~$,H?BP$J$@$1$G!"A4$FF1$8F/$-$r$7$^$9!#(B + +$B%j%+!<%7%V(B $B%(%G%#%F%#%s%0(B $B%l%Y%k(B + + $B$H$-$I$-!"!JITK\0U$K!K%j%+!<%7%V(B $B%(%G%#%F%#%s%0(B $B%l%Y%k$H8F$P$l$k>uBV$K(B +$BF~$k$3$H$,$"$j$^$9!#%a%8%c!<%b!<%I$N>.3g8L(B'()'$B$N2s$j$rCf3g8L(B'[]'$B$G0O$s$@$b(B +$B$N$,%b!<%I%i%$%s>e$KI=<($5$l$^$9!#Nc$($P!"(B(Fundamental)$B$HI=<($5$l$kBe$o$j$K(B +[(Fundamental)]$B$N$h$&$K$J$j$^$9!#(B + +$BCm0U(B: $B$3$3$G$O%j%+!<%7%V(B $B%(%G%#%F%#%s%0(B $B%l%Y%k<+BN$K$D$$$F$O@bL@$7(B + $B$^$;$s!#(B + + $B%j%+!<%7%V(B $B%(%G%#%F%#%s%0(B $B%l%Y%k$+$iH4$1$G$k$?$a$K$O!"(BM-x top-level +<Return>$B$H%?%$%W$7$^$9!#(B + + >> $B;n$7$F$_$F2<$5$$!#%9%/%j!<%s$NDl$K(B"Back to top level"$B$HI=<($5$l$^(B + $B$9!#(B + + $BK\Ev$O!"$3$N;n$_$,9T$o$l$?;~$O!"$9$G$K%H%C%W%l%Y%k$K$$$?$N$G$9!#(BM-x +top-level$B$O!"2?$b1F6A$rM?$($F$$$^$;$s!#(B + + $B%j%+!<%7%V(B $B%(%G%#%F%#%s%0(B $B%l%Y%k$+$iH4$1=P$k$N$KBP$7$F$O(BC-g$B$O8z$-$^$;(B +$B$s!#(B + + +$B%X%k%W(B +====== + + Emacs$B$K$O!"$?$/$5$s$NLr$KN)$D5!G=$,$"$j!"$3$3$G!"$9$Y$F$r@bL@$9$k$3$H(B +$B$O!"IT2DG=$G$9!#$7$+$7!"$^$@CN$i$J$$B?$/$N5!G=$r3X$V$?$a$K$O!"(B<HELP>$B$H8F$P(B +$B$l$k(B C-h $B$r%?%$%W$9$k$3$H$G!"$?$/$5$s$N>pJs$r<j$KF~$l$k$3$H$,$G$-$^$9!#(B + + $B;H$$J}$O!"(BC-h $B$r%?%$%W$7!"B3$$$FI,MW$J%*%W%7%g%s$r#1J8;z%?%$%W$7$^$9!#(B +$B$o$+$i$J$1$l$P!"(BC-h ? $B$H%?%$%W$9$k$H!"$I$s$J%*%W%7%g%s$,$"$k$N$+I=<($5$l$^(B +$B$9!#$b$7!"(BC-h $B$r%?%$%W$7$F$+$i5$$,JQ$o$C$?$i!"(BC-g $B$r%?%$%W$9$l$P!"<h$j>C$9(B +$B$3$H$,$G$-$^$9!#(B + + $B:G$b4pK\E*$J$b$N$O!"(BC-h c $B$G$9!#$3$l$KB3$$$F%-!<$rF~NO$9$k$H!"$=$N%3%^(B +$B%s%I$K$D$$$F$NC;$$@bL@$rI=<($7$^$9!#(B + + >> C-h c C-p $B$H%?%$%W$7$F$_$J$5$$!#(B"C-p runs the command previous- + line"$B$N$h$&$J%a%C%;!<%8$,I=<($5$l$k$O$:$G$9!#(B + + $B8+$?$3$H$O$"$k$,!"3P$($F$O$$$J$$%3%^%s%I$b;W$$=P$;$k$N$G$9!#(BC-x C-s $B$N(B +$B$h$&$JJ#?t$G#1$D$N%3%^%s%I$b(BC-h c $B$N8e$m$KB3$1$i$l$^$9!#(B + + $B$b$C$H>\$7$/CN$j$?$+$C$?$i!"(Bc $B$NBe$o$j$K(B k $B$r;XDj$7$^$9!#(B + + >> C-h k C-p $B$H%?%$%W$7$F$_$J$5$$!#(B + + Emacs$B$N%&%#%s%I%&$K!"%3%^%s%I$NL>A0$H5!G=$,I=<($5$l$^$9!#FI$_=*$($?$i!"(B +C-x 1 $B$H%?%$%W$9$k$H!"H4$1$i$l$^$9!#(B + + $BB>$K$bLr$KN)$D%*%W%7%g%s$,$"$j$^$9!#(B + + C-h f $B%U%!%s%/%7%g%sL>$rF~NO$9$k$H!"%U%!%s%/%7%g%s$rI=<($7$^$9!#(B + + >> C-h f previous-line $B$r%?%$%W$7!"(B<Return> $B$r2!$7$J$5$$!#(BC-p $B%3%^%s(B + $B%I$r<B9T$9$k%U%!%s%/%7%g%s$K$D$$$F$N>pJs$rI=<($7$^$9!#(B + + C-h a $B%-!<%o!<%I$rF~NO$9$k$H!"L>A0$K$=$N%-!<%o!<%I$r4^$`!"A4$F$N%3(B + $B%^%s%I$rI=<($7$^$9!#$3$l$i$N%3%^%s%I$O$9$Y$F(BESC x $B$G<B9T$G$-(B + $B$^$9!#(B + + >> C-h a file $B$H%?%$%W$7!"(B<Return>$B$r2!$7$J$5$$!#L>A0$K(B"file"$B$H$$$&J8(B + $B;z$r;}$DA4$F$N%3%^%s%I$rI=<($7$^$9!#$^$?!"(Bfind-file $B$d(B write-file + $B$H$$$&L>$N(B C-x C-f $B$d(B C-x C-w $B$N$h$&$J%3%^%s%I$bI=<($5$l$^$9!#(B + +$B$*$o$j$K(B +======== + +$BK:$l$:$K!'(B $B=*N;$9$k$K$O!"(BC-x C-c $B$H$7$^$9!#(B + + + $B$3$NF~LgJT$O!"$^$C$?$/$N=i?4<T$K$b$o$+$j$d$9$$$h$&$K$H0U?^$7$F$$$^$9!#(B +$B$G$9$+$i!"$b$72?$+$o$+$j$K$/$$E@$,$"$C$?$J$i!"0l?M$G6rCT$r8@$&$N$G$O$J$/!"(B +$BJ86g$r$D$1$F2<$5$$!#(B + + + $B$b$7!"(BEMACS $B$r2?F|$+$G$b;H$C$F$_$l$P!"$=$l$r$d$a$F$7$^$&$3$H$J$I$G$-$J(B +$B$/$J$k$G$7$g$&!#:G=i$O8MOG$&$+$bCN$l$^$;$s!#$7$+$7!"$=$l$O$I$s$J%(%G%#%?$G(B +$B$bF1MM$G$9!#(BEMACS $B$N$h$&$K!"Hs>o$KB?$/$N$3$H$,$G$-$k>l9g$K$OFC$K$=$&$G$7$g(B +$B$&!#$=$7$F!"(BEMACS $B$G$O!"<B:]!"2?$G$b$G$-$k$N$G$9$+$i!#(B + + + +$B<U<-(B +===== + $B$3$NJ8=q$O!"(BJUNET$B$GN.$5$l$?(B"$BF|K\8l(B MicroEMACS (kemacs) $BF~LgJT(B" $B$r(BGNUE- +macs (Nemacs)$B$N(BTutorial$BMQ$K=q$-49$($?$b$N$G$9!#(B + + Jonathan Payne $B$K$h$k(B "JOVE Tutorial" (19 January 86) $B$rJQ99$7$?$b$N$G(B + $B$"$j!"$=$l$O$b$H$b$H$O!"(BCCA-UNIX$B$N(BSteve Zimmerman $B$K$h$C$FJQ99$5$l$?!"(B + MIT $B$N(B "Teach-Emacs" $BF~LgJT(B (31 October 85) $B$r!J$5$i$K!KJQ99$7$?$b$N$G(B + $B$7$?!#(B + + Update - February 1986 by Dana Hoggatt. + + Update - December 1986 by Kim Leburg. + + Update/Translate - July 1987 by SANETO Takanori + +$BFCJL$J<U<-(B +========== + + $B:G=i$K$3$l$NF|K\8lLu$r:n$i$l$?!"(BSANETO Takanori$B$5$s!#$3$NJ8>O$O(BGMW + +Wnn + Nemacs$B$r;H$C$F=q$-$^$7$?!#$=$N$h$&$JAG@2$i$7$$%W%m%0%i%`$r:n$C$?J}!9(B +$B$X46<U$N0U$rI=$7$?$$$H;W$$$^$9!#K]Lu$H$+!"F~NO$H$+$r?'!9$H<jEA$C$F$/$l$?!"(B +$BF#86>M;R$5$s!"$I$&$b$"$j$,$H$&!#(B + + + + + +$B8mLu!"13!"$=$NB>!"$NJ8@U$O!"0J2<$N<T$K$"$j$^$9!#(B + + $BNkLZM5?.(B hironobu@sra.co.jp + + +Update/Add - December 1987 by Hironobu Suzuki +Update/Add - November 1989 by Ken'ichi Handa +Update/Add - January 1990 by Shigeki Yoshida +Update/Add - March 1992 by Kenichi HANDA
--- a/etc/TUTORIAL.jp Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,741 +0,0 @@ - ============================== - $BF|K\8l(B GNUEMACS(Mule) $BF~LgJT(B - ============================== - -$BCm0U!'(B $B$3$NF~LgJT$O!"!V=,$&$h$j47$l$m!W$r%b%C%H!<$K:n@.$5$l$F$$$^(B - $B$9!#(B">>" $B$+$i;O$^$k9T$O!"$=$N;~2?$r$9$Y$-$+$r;X<($7$F$$$^$9!#(B - - - Mule $B$N%3%^%s%I$rF~NO$9$k$H$-$K$O!"0lHLE*$K%3%s%H%m!<%k!&%-!<!J%-!<!&(B -$B%H%C%W$K!"(BCTRL $B$"$k$$$O!"(BCTL $B$H=q$$$F$"$k!K$d%a%?!&%-!<!JIaDL!"%(%9%1!<%W!&(B -$B%-!<$r;H$&!K$,;H$o$l$^$9!#$=$3$G!"(BCONTROL $B$H$+(B META $B$H$+=q$/Be$o$j$K!"<!$N(B -$B$h$&$J5-9f$r;H$&$3$H$K$7$^$9!#(B - -C-<$BJ8;z(B> $B%3%s%H%m!<%k!&%-!<$r2!$7$?$^$^!"(B<$BJ8;z(B>$B%-!<$r2!$7$^$9!#Nc$($P!"(B - C-f $B$O!"%3%s%H%m!<%k!&%-!<$r2!$7$J$,$i(B f $B$N%-!<$r2!$9$3$H$r(B - $B0UL#$7$^$9!#(B -<<Blank lines inserted here by startup of help-with-tutorial>> - >> $B$=$l$G$O!"(BC-v$B!J(BView Next Screen; $B<!$N2hLL$r8+$k!K$r%?%$%W$7$F(B - $B$_$F2<$5$$!#<!$N2hLL$K?J$`$3$H$,$G$-$^$9!#(B - $B0J9_!"0l2hLL$rFI$_=*$($k$?$S$KF1MM$K$7$F<!$N2hLL$KFI$_?J$s$G(B - $B2<$5$$!#(B - -ESC <$BJ8;z(B> $B%(%9%1!<%W!&%-!<$r2!$7$F$+$iN%$7!"$=$l$+$i(B<$BJ8;z(B>$B%-!<$r2!$7$^(B - $B$9!#(B - -$BCm0U!'(B <$BJ8;z(B>$B$O!"BgJ8;z$G$b>.J8;z$G$b%3%^%s%I$H$7$F$OF1$80UL#$K$J$j(B - $B$^$9!#%a%?%-!<$,;H$($k$J$i$P(B ESC <$BJ8;z(B> $B$NBe$o$j$K(B M-<$BJ8;z(B> - ($B%a%?%-!<$r2!$7$?$^$^(B<$BJ8;z(B>$B%-!<$r2!$9(B) $B$,;H$($^$9!#(B - -$B=EMW$G$9!'(B Emacs$B$r=*N;$5$;$?$$;~$O!"(BC-x C-c $B$r%?%$%W$7$^$9!#(BEmacs$B$r(Bcsh - $B$+$i5/F0$7$F$$$k>l9g!"%5%9%Z%s%I$9$k!J0l;~E*$K;_$a$k(B)$B$3$H$,(B - $B=PMh$^$9!#(BEmacs$B$r%5%9%Z%s%I$9$k$K$O!"(BC-z$B$r%?%$%W$7$^$9!#(B - - - $B$5$F!"$3$l$+$i$O!"0l2hLLJ,FI$_=*$($?$i!"(BC-v $B$rF~NO$7$F9T$C$F2<$5$$!#(B - - $BA0$N2hLL$H<!$N2hLL$H$G$O!"I=<($5$l$kFbMF$K2?9TJ8$+$N=E$J$j$,$"$j$^$9!#(B -$B$3$l$O!"I=<($5$l$F$$$kFbMF$,O"B3$7$F$$$k$3$H$,$9$0H=$k$h$&$K$9$k$?$a$G$9!#(B - - - $B$^$:$O!"%U%!%$%k$NCf$r0\F0$7$F9T$/J}K!$rCN$kI,MW$,$"$j$^$9!#(BC-v $B$K$h(B -$B$C$F@h$K?J$`$3$H$O$b$&H=$j$^$7$?!#85$KLa$k$K$O!"(BESC v $B$r%?%$%W$7$^$9!#(B - - >> ESC v $B$H(B C-v $B$r;H$C$F!"A08e$K0\F0$9$k$3$H$r2?2s$+;n$7$F$_$J$5$$!#(B - -$BMWLs(B -==== - $B%U%!%$%k$r2hLLKh$K8+$F9T$/$K$O!"<!$N%3%^%s%I$r;H$$$^$9!#(B - - C-v $BA0$K0l2hLLJ,?J$`(B - ESC v $B8e$m$K0l2hLLJ,La$k(B - C-l $B2hLL$r=q$-D>$9!#$3$N$H$-!"85%+!<%=%k$N$"$C$?9T$,(B - $B2hLL$NCf1{$K$/$k$h$&$K$9$k(B - - >> $B:#%+!<%=%k$,$I$3$K$"$k$+!"$=$N6a$/$K$I$s$J%F%-%9%H$,=q$+$l$F$$$k(B - $B$+$r3P$($J$5$$!#(BC-l $B$r%?%$%W$7!"%+!<%=%k$,$I$3$K0\F0$7$?$+!"$=$N(B - $B6a$/$N%F%-%9%H$O$I$&$J$C$?$+$rD4$Y$F$_$J$5$$!#(B - -$B4pK\E*$J%+!<%=%k$N@)8f(B -====================== - - $B2hLLKh$N0\F0$O$G$-$k$h$&$K$J$j$^$7$?!#:#EY$O!"2hLL$NCf$G!"FCDj$N>l=j$K(B -$B0\F0$9$k$?$a$NJ}K!$r21$($^$7$g$&!#$3$l$K$O$$$/$D$+$N$d$jJ}$,$"$j$^$9!#0l$D(B -$B$NJ}K!$O!"A0(B(previous)$B<!(B(next)$B@h(B(forward)$B8e(B(backward)$B$K0\F0$9$k%3%^%s%I$r;H(B -$B$&$3$H$G$9!#$3$l$i$N%3%^%s%I$O$=$l$>$l!"(BC-p, C-n, C-f,C-b $B$K3d$jEv$F$i$l$F(B -$B$*$j!"8=:_$N>l=j$+$i?7$7$$>l=j$K%+!<%=%k$r0\F0$5$;$^$9!#?^$G=q$1$P!"(B - - - $BA0$N9T!$(BC-p - : - : - $B8e$NJ8;z!$(BC-b .... $B8=:_$N%+!<%=%k0LCV(B .... $B@h$NJ8;z!$(BC-f - : - : - $B<!$N9T!$(BC-n - - - $B$3$l$i$O!"$=$l$>$l!"(BPrevious, Next, Backward, Forward $B$NF,J8;z$K$J$C$F(B -$B$$$k$N$G!"21$($d$9$$$G$7$g$&!#$3$l$i$O!"4pK\E*$J%+!<%=%k0\F0%3%^%s%I$G$"$j!"(B -$B$$$D$G$b;H$&$b$N$G$9!#(B - - >> C-n $B$r2?2s$+%?%$%W$7!"!J:#!"$"$J$?$,FI$s$G$$$k!K$3$N9T$^$G%+!<%=(B - $B%k$r0\F0$5$;$J$5$$!#(B - - >> C-f $B$r;H$C$F9T$NCf$[$I$K0\F0$7!"(BC-p $B$G2?9T$+>e$K0\F0$7$F$_$J$5(B - $B$$!#%+!<%=%k$N0LCV$NJQ2=$KCm0U$7$J$5$$!#(B - - >> $B9T$N@hF,$G(B C-b $B$r%?%$%W$7$F$_$J$5$$!#%+!<%=%k$O$I$3$K0\F0$7$^$9$+(B - $B!)$5$i$K$b$&>/$7(B C-b $B$r%?%$%W$7!":#EY$O(B C-f $B$G9TKv$NJ}$KLa$j$J$5(B - $B$$!#%+!<%=%k$,9TKv$r1[$($k$H$I$&$J$j$^$9$+!)(B - - - $B2hLL$N@hF,$dKvHx$r1[$($F%+!<%=%k$r0\F0$5$;$h$&$H$9$k$H!"$=$NJ}8~$K$"$k(B -$B%F%-%9%H$,0\F0$7$FMh$F!"%+!<%=%k$O>o$K2hLLFb$K$"$k$h$&$K$5$l$^$9!#(B - - >> C-n $B$r;H$C$F!"%+!<%=%k$r2hLL$N2<C<$h$j2<$K0\F0$5$;$F$_$J$5$$!#2?(B - $B$,5/$3$j$^$7$?$+!)%+!<%=%k$N0LCV$O$I$&JQ$j$^$7$?$+!)(B - - $B0lJ8;zC10L$N0\F0$G$O$^$I$m$C$3$7$$$H;W$&$J$i!"C18lC10L$G0\F0$9$k$3$H$b(B -$B$G$-$^$9!#(BESC f $B$G0lC18lJ,@h$K?J$_!"(BESC b $B$G0lC18lJ,A0$KLa$j$^$9!#(B - -$BCm0U!'(B $BF|K\8l$K$D$$$F$O!"C18l$N@Z$lL\$rG'<1$9$k$3$H$O$G$-$^$;$s$,!"(B - $B5?;wE*$JJ8@a$rC18l$N@Z$lL\$H$7$F$$$^$9!#(B - - >> ESC f $B$d(B ESC b $B$r2?2s$+%?%$%W$7$F$_$J$5$$!#(BC-f $B$d(B C-b $B$HJ;MQ$7$F(B - $B$_$J$5$$!#(B - - C-f $B$d(B C-b $B$KBP$9$k!"(BESC f $B$d(B ESC b $B$NN`;w@-$KCmL\$7$^$7$g$&!#B?$/$N(B -$B>l9g!"(BESC <$BJ8;z(B>$B$OJ8=q4X78$N=hM}$K;H$o$l!"0lJ}(BC-<$BJ8;z(B>$B$O$=$l$h$j$b$b$C$H4p(B -$BK\E*$JBP>]!JJ8;z$H$+9T$H$+!K$KBP$9$kA`:n$K;H$o$l$^$9!#(B - - C-a $B$H(B C-e $B$bCN$C$F$$$FJXMx$J%3%^%s%I$G$9!#(BC-a $B$O%+!<%=%k$r9T$N@hF,$K(B -$B0\F0$5$;!"(BC-e $B$O9T$NKvHx$K0\F0$5$;$^$9!#(B - - - >> C-a $B$r#22s!"$=$l$+$i(B C-e $B$r#22sF~NO$7$F$_$J$5$$!#$3$l$i$N%3%^%s%I(B - $B$r#22s0J>e7+JV$7$F$b!"%+!<%=%k$O$=$l0J>e0\F0$7$J$$$3$H$KCm0U!#(B - - $B$"$HFs$D!"4JC1$J%+!<%=%k0\F0%3%^%s%I$,$"$j$^$9!#%U%!%$%k$N@hF,$K0\F0$9(B -$B$k(B ESC < $B$H!"%U%!%$%k$NKvHx$K0\F0$9$k(B ESC > $B$G$9!#(B - - $B%F%-%9%HCf$G%+!<%=%k$NB8:_$9$k0LCV$r!V%]%$%s%H!W$H8F$S$^$9!#8@$$$+$($l(B -$B$P!"%+!<%=%k$O!"%F%-%9%H$N$I$3$K%]%$%s%H$,$"$k$+$r2hLL>e$G<($7$F$$$k$N$G$9!#(B - - $B0J2<$KC1=c$J0\F0A`:n$K$D$$$FMWLs$7$^$9!#$3$N$J$+$K$O!"C18l$d9TC10L$G$N(B -$B0\F0%3%^%s%I$b4^$^$l$F$$$^$9!#(B - - C-f $B0lJ8;z@h$K?J$`(B - C-b $B0lJ8;z8e$KLa$k(B - - ESC f $B0lC18l@h$K?J$`(B - ESC b $B0lC18l8e$KLa$k(B - - C-n $B<!$N9T$K0\F0(B - C-p $BA0$N9T$K0\F0(B - - ESC ] $BCJMn$N=*$o$j$K0\F0(B - ESC [ $BCJMn$N@hF,$K0\F0(B - - C-a $B9T$N:G=i$K0\F0(B - C-e $B9T$N:G8e$K0\F0(B - - ESC < $B%U%!%$%k$N:G=i$K0\F0(B - ESC > $B%U%!%$%k$N:G8e$K0\F0(B - - >> $B3F!9$N%3%^%s%I$r;n$7$F$_$J$5$$!#$3$l$i$N%3%^%s%I$O!":G$b$7$P$7$P(B - $B;H$o$l$k$b$N$G$9!#:G8e$NFs$D$G$O!"$3$N>l=j$H$ON%$l$?$H$3$m$K0\F0(B - $B$9$k$N$G!"(B C-v $B$d(B ESC v $B$r;H$C$F$3$3$KLa$C$FMh$k$h$&$K$7$J$5$$!#(B - - Emacs$B$NB>$N%3%^%s%I$HF1MM$K!"$3$l$i$N%3%^%s%I$K$O!"7+$jJV$7$N2s?t$r;X(B -$BDj$9$k0z?t(B $B$rM?$($k$3$H$,$G$-$^$9!#$=$N$?$a$K$O!"%3%^%s%I$rF~NO$9$kA0$K!"(B -C-u$B$KB3$$$F7+$jJV$92s?t$rF~NO$7$^$9!#(B - - $BNc$($P!"(BC-u 8 C-f $B$H$9$k$H!"#8J8;zJ,@h$K0\F0$7$^$9!#(B - - >> C-n $B$"$k$$$O(B C-p $B$KE,Ev$J0z?t$r;XDj$7$F!"0l2s$N0\F0$G$J$k$Y$/$3(B - $B$N9T$N6a$/$KMh$k$h$&$K$7$F$_$J$5$$!#(B - - C-v $B$d(B ESC v $B$K$D$$$F$O>/$70c$$$^$9!#$3$N>l9g!";XDj$5$l$??t$N9T$@$12h(B -$BLL$r0\F0$9$k$3$H$K$J$j$^$9!#(B - - >> C-u 3 C-v $B$HF~NO$7$F$_$J$5$$!#(B - - $B85$KLa$k$K$O!"(BC-u 3 ESC v $B$r;H$($P$h$$$N$G$9!#(B - -$BCf;_%3%^%s%I(B -============ - - C-g $B$H$$$&%3%^%s%I$G!"F~NO$rI,MW$H$9$k$h$&$J%3%^%s%I$rCf;_$9$k$3$H$,(B -$B$G$-$^$9!#Nc$($P!"0z?t$rF~NO$7$F$$$kESCf$d!"#2$D0J>e$N%-!<F~NO$rI,MW$H$9$k(B -$B%3%^%s%I$rF~NO$7$F$$$k:GCf$K!"$=$l$r$d$a$?$/$J$C$?$i!"(BC-g $B$r;H$($PNI$$$N$G(B -$B$9!#(B - - >> C-u 100 $B$r%?%$%W$7$F0z?t$r#1#0#0$K@_Dj$7!"(BC-g $B$r%?%$%W$7$J$5$$!#(B - $B$=$N$"$H$G(B C-f $B$r%?%$%W$7$F$_$J$5$$!#2?J8;z0\F0$7$^$7$?$+!)$b$7(B - $B4V0c$C$F(B ESC $B$rF~NO$7$F$7$^$C$?;~$b!"(BC-g $B$rF~NO$9$l$P<h$j>C$;$^(B - $B$9!#(B - -$B%(%i!<(B -====== - - $B;~$K$O!"(BEmacs$B$G5v$5$l$F$$$J$$A`:n$r$7$F$7$^$&$3$H$,$"$j$^$9!#Nc$($P!"(B -$B%3%^%s%I$NDj5A$5$l$F$$$J$$%3%s%H%m!<%k!&%-!<$rF~NO$7$F$7$^$C$?;~$K$O!"(BEmacs -$B$O%Y%k$rLD$i$7!"$5$i$K!"2hLL$N0lHV2<$K!"2?$,0-$+$C$?$+$rI=<($7$^$9!#(B - - Emacs$B$N%P!<%8%g%s$K$h$C$F$O!"$3$NF~LgJT$K=q$+$l$F$$$k$3$H$r<B9T$G$-$J(B -$B$$>l9g$,$"$jF@$^$9!#$=$NMM$J>l9g$K$O!"%(%i!<%a%C%;!<%8$,I=<($5$l$^$9$+$i!"(B -$B2?$+%+!<%=%k0\F0%-!<$r2!$7$F!"$=$N<!$NItJ,$K?J$s$G2<$5$$!#(B - -$B%&%#%s%I%&(B -========== - - Emacs$B$O4v$D$b$N%&%#%s%I%&$r;}$D$3$H$H!"$=$N$=$l$>$l$KBP$7$F%F%-%9%H$r(B -$BI=<($9$k$3$H$,$G$-$^$9!#%X%k%W$d!"4v$D$+$N%3%^%s%I$+$i$N=PNO$rI=<($9$k$?$a(B -$B$K8=$l$?M>J,$J%&%#%s%I%&$r>C$9$?$a$K!"<!$N%3%^%s%I$rCN$kI,MW$,$"$j$^$9!#(B - - C-x 1 $B%&%#%s%I%&$r#1$D$K$9$k!#(B - - C-x 1 $B$O!"B>$N%&%#%s%I%&$r>C$7$F!"%+!<%=%k$N$"$k%&%#%s%I%&$r!"2hLLA4BN(B -$B$K9-$2$^$9!#(B - - >> $B%+!<%=%k$r$3$N9T$K;}$C$F$-$F!"(BC-u 0 C-l $B$H%?%$%W$7$^$9!#(B - - >> C-h k C-f $B$H%?%$%W$7$J$5$$!#?7$7$$%&%#%s%I%&$,(B C-f $B%3%^%s%I$N%I%-(B - $B%e%a%s%H$rI=<($9$k$?$a$K8=$l$k$HF1;~$K!"$3$N%&%#%s%I%&$,$I$N$h$&(B - $B$K=L$`$+$r4Q;!$7$J$5$$!#(B - - >> C-x 1$B$H%?%$%W$7$F!"%I%-%e%a%s%H$N8=$o$l$F$$$?%&%#%s%I%&$r>C$7$J$5(B - $B$$!#(B - -$BA^F~$H:o=|(B -========== - - $B%F%-%9%H$r%?%$%W$7$?$1$l$P!"C1$K$=$l$r%?%$%W$9$k$@$1$G9=$$$^$;$s!#L\$K(B -$B8+$($kJ8;z!J(B'A','7','*','$B$"(B'$B$J$I!K$O(BEmacs$B$K$h$C$F%F%-%9%H$G$"$k$H$_$J$5$l!"(B -$B$=$N$^$^A^F~$5$l$^$9!#9T$N=*$o$j$O2~9TJ8;z$GI=$5$l!"$3$l$rF~NO$9$k$K$O(B -<Return> $B$r%?%$%W$7$^$9!#(B - - $BD>A0$KF~NO$7$?J8;z$r:o=|$9$k$K$O!"(B<Delete> $B$rF~NO$7$^$9!#(B<Delete> $B$O!"(B -$B%-!<%\!<%I$G!V(BDelete$B!W$H=q$$$F$"$k%-!<$r2!$7$FF~NO$7$^$9!#!V(BDelete$B!W$N$+$o(B -$B$j$K!V(BRubout$B!W$H=q$$$F$"$k$+$bCN$l$^$;$s!#$h$j0lHLE*$K$O!"(B<Delete> $B$O!"8=:_(B -$B%+!<%=%k$N$"$k0LCV$ND>A0$NJ8;z$r:o=|$7$^$9!#(B - - >> $BJ8;z$r$$$/$D$+%?%$%W$7!"$=$l$+$i$=$l$i$r(B <Delete> $B$r;H$C$F:o=|$7(B - $B$J$5$$!#(B - - >> $B1&%^!<%8%s$r1[$($k$^$G%F%-%9%H$r%?%$%W$7$J$5$$!#%F%-%9%H$,0l9T$N(B - $BI}0J>e$KD9$/$J$k$H!"$=$N9T$O2hLL$+$i$O$_=P$7$F!V7QB3!W$5$l$^$9!#(B - $B1&C<$K$"$k(B'\'$B5-9f$O!"$=$N9T$,7QB3$5$l$F$$$k$3$H$rI=$7$F$$$^$9!#(B - Emacs$B$O!"8=:_JT=8Cf$N0LCV$,8+$($k$h$&$K9T$r%9%/%m!<%k$7$^$9!#2hLL(B - $B$N1&$"$k$$$O:8$NC<$K$"$k(B'\'$B5-9f$O!"$=$NJ}8~$K9T$,$^$@B3$$$F$$$k$3(B - $B$H$rI=$7$F$$$^$9!#(B - - $B$3$l$O!"J8>O$G@bL@$9$k$h$j<B:]$K$d$C$?J}$,$h$/H=$k$G$7$g$&!#(B - - >> $B@h$[$IF~NO$7$?!"7QB3$5$l$?9T$N>e$K%+!<%=%k$r$b$C$F$$$-!"(BC-d $B$G%F(B - $B%-%9%H$r:o=|$7$F!"%F%-%9%H$,0l9T$K<}$^$k$h$&$K$7$F$_$J$5$$!#7QB3(B - $B$rI=$9(B'\'$B5-9f$O>C$($^$7$?$M!#(B - - >> $B%+!<%=%k$r9T$N@hF,$K0\F0$7!"(B<Delete> $B$rF~NO$7$J$5$$!#$3$l$O$=$N9T(B - $B$ND>A0$N9T6g@Z$j$r:o=|$9$k$N$G!"$=$N9T$,A0$N9T$H$D$J$,$C$F$7$^$$(B - $B$^$9!#$D$J$,$C$?9T$,2hLL$NI}$h$jD9$/$J$k$H!"7QB3$NI=<($,$5$l$k$G(B - $B$7$g$&!#(B - - >> <Return> $B$r2!$7$F!"$b$&0lEY9T6g@Z$j$rA^F~$7$J$5$$!#(B - - Emacs$B$N$[$H$s$I$N%3%^%s%I$O!"7+$jJV$7$N2s?t$rM?$($k$3$H$,$G$-$^$9!#$3(B -$B$N$3$H$O!"J8;z$NA^F~$K$D$$$F$bEv$F$O$^$j$^$9!#(B - - >> C-u 8 * $B$HF~NO$7$F$_$J$5$$!#$I$&$J$j$^$7$?$+!#(B - - $BFs$D$N9T$N4V$K6uGr9T$r:n$j$?$$>l9g$K$O!"FsHVL\$N9T$N@hF,$K9T$-!"(BC-o $B$r(B -$BF~NO$7$^$9!#(B - - >> $BE,Ev$J9T$N@hF,$K9T$-!"$=$3$G(B C-o $B$rF~NO$7$F$_$J$5$$!#(B - - $B$3$l$G!"(BEmacs$B$G!"%F%-%9%H$rF~NO$7!"$^$?4V0c$$$r=$@5$9$k$b$C$H$b4pK\E*(B -$B$JJ}K!$r3X$s$@$3$H$K$J$j$^$9!#J8;z$HF1$8MM$K!"C18l$d9T$b:o=|$9$k$3$H$,$G$-(B -$B$^$9!#:o=|A`:n$K$D$$$FMWLs$9$k$H<!$N$h$&$K$J$j$^$9!#(B - - <Delete> $B%+!<%=%k$ND>A0$NJ8;z$r:o=|(B - C-d $B%+!<%=%k$N$"$kJ8;z$r:o=|(B - - ESC <Delete> $B%+!<%=%k$ND>A0$NC18l$r:o=|(B - ESC d $B%+!<%=%k0LCV0J9_$K$"$kC18l$r:o=|(B - - C-k $B%+!<%=%k0LCV$+$i9TKv$^$G$r:o=|(B - - $B2?$+$r:o=|$7$?8e$G!"$=$l$r85$KLa$7$?$/$J$k$3$H$,$"$j$^$9!#(BEmacs$B$O!"0l(B -$BJ8;z$h$j$bBg$-$$C10L$G:o=|$r9T$C$?;~$K$O!":o=|$7$?FbMF$rJ]B8$7$F$*$-$^$9!#(B -$B85$KLa$9$K$O!"(BC-y $B$r;H$$$^$9!#Cm0U$7$?$$$N$O!"(BC-y $B$r:o=|$r9T$C$?>l=j$@$1$G(B -$B$O$J$/!"$I$3$K$G$b=PMh$k$3$H$G$9!#(BC-y $B$O!"J]B8$5$l$?%F%-%9%H$r8=:_%+!<%=%k(B -$B$N$"$k>l=j$KA^F~$9$k$?$a$N%3%^%s%I$G$9$+$i!"$3$l$r;H$C$F%F%-%9%H$N0\F0$r9T(B -$B$&$3$H$,$G$-$^$9!#(B - - $B:o=|$r9T$&%3%^%s%I$K$O!"(B"Delete" $B%3%^%s%I$H!"(B"Kill" $B%3%^%s%I$H$,$"$j$^(B -$B$9!#(B"Kill" $B%3%^%s%I$G$O:o=|$5$l$?$b$N$OJ]B8$5$l$^$9$,!"(B"Delete" $B%3%^%s%I$G(B -$B$OJ]B8$5$l$^$;$s!#$?$@$7!"7+$jJV$72s?t$,M?$($i$l$k$H!"J]B8$5$l$^$9!#(B - - >> C-n $B$r#22s$[$I%?%$%W$7$F!"2hLL$NE,Ev$J>l=j$K0\F0$7$J$5$$!#$=$7$F!"(B - C-k $B$G!"$=$N9T$r:o=|$7$J$5$$!#(B - - $B0l2sL\$N(B C-k $B$G$=$N9T$NFbMF$,:o=|$5$l!"$b$&0lEY(B C-k $B$rF~NO$9$k$H!"$=$N(B -$B9T<+?H$,:o=|$5$l$^$9!#$b$7!"(BC-k $B$K7+$jJV$72s?t$r;XDj$7$?>l9g$K$O!"$=$N2s?t(B -$B$@$1$N9T$,!JFbMF$H9T<+?H$H$,F1;~$K!K:o=|$5$l$^$9!#(B - - $B:#:o=|$5$l$?%F%-%9%H$O!"J]B8$5$l$F$$$k$N$G!"$=$l$r<h$j=P$9$3$H$,$G$-$^(B -$B$9!#$=$N$?$a$K$O!"(BC-y $B$r%?%$%W$7$^$9!#(B - - >> C-y $B$r;n$7$F$_$J$5$$!#(B - - C-k $B$r2?EY$bB3$1$F9T$&$H!":o=|$5$l$k%F%-%9%H$O!"$^$H$a$FJ]B8$5$l!"(BC-y -$B$G!"$=$NA4$F$,<h$j=P$5$l$^$9!#(B - - >> C-k $B$r2?EY$b%?%$%W$7$F$_$J$5$$!#(B - - >> $B%F%-%9%H$r<h$j=P$9$K$O!"(BC-y $B$G$9!#%+!<%=%k$r?t9T2<$K0\F0$5$;!"$b(B - $B$&0lEY(B C-y $B$r%?%$%W$7$F$_$J$5$$!#$3$l$G%F%-%9%H$N%3%T!<$,$G$-$k$o(B - $B$1$G$9!#(B - - $B8=:_2?$+$N%F%-%9%H$,J]B8$5$l$F$$$F!"$5$i$KB>$N%F%-%9%H$r:o=|$9$k$H$I$&(B -$B$J$k$G$7$g$&$+!#(BC-y $B$O!"$b$C$H$b:G6a:o=|$5$l$?$b$N$r<h$j=P$7$^$9!#(B - - - >> $B9T$r:o=|$7!"%+!<%=%k$r0\F0$5$;!"JL$N9T$r:o=|$7$J$5$$!#(BC-y $B$r9T$&(B - $B$H!"#2HVL\$N9T$,F@$i$l$^$9!#(B - -$B<h$j>C$7(B(UNDO) -============== - - $B$$$D$G$b!"%F%-%9%H$rJQ99$7$?$1$l$I$b!"$=$l$r$b$H$KLa$7$?$$$H$-$O(BC-x u -$B$GD>$j$^$9!#IaDL$O4V0c$($?%3%^%s%I$rL58z$K$9$kF/$-$r$7$^$9!#7+$jJV$7$F(BUNDO -$B$r9T$J$*$&$H$9$k;~$O!"2?EY$b$=$N%3%^%s%I$r9T$J$($P=PMh$k$h$&$K$J$C$F$$$^$9!#(B - - >> $B$3$N9T$r(BC-k$B$G>C$7$F2<$5$$!#$=$7$F!"(BC-x u$B$GLa$7$F2<$5$$!#(B - - C-_$B$O!"(BUNDO$B$r9T$J$&!"$b$&0l$D$N%3%^%s%I$G$9!#5!G=$O!"(BC-x u$B$HF1$8$G$9!#(B - - C-_$B$d(BC-x u$B$K(BUNDO$B$N2s?t$r!"M?$($k$3$H$,=PMh$^$9!#(B - - -$B%U%!%$%k(B -======== - - $B%F%-%9%H$X$NJQ99$r1J5WE*$K$9$k$?$a$K$O!"$=$l$r%U%!%$%k$KJ]B8$7$J$1$l$P(B -$B$J$j$^$;$s!#J]B8$5$l$J$$$H!"$[$I$3$7$?JQ99$O!"(BEmacs$B$r=*N;$9$k$HF1;~$K<:$o$l(B -$B$F$7$^$$$^$9!#(B - - $B$$$^8+$F$$$k%U%!%$%k$KBP$7$F!"$"$J$?$NJT=8$r9T$C$?$b$N$r=q$-9~$_$^$9!#(B -$B$$$^8+$F$$$k%U%!%$%k$H$O!"4JC1$K$$$($PJT=8$7$F$$$k%U%!%$%k<+BN$N$3$H$G$9!#(B - - $B$"$J$?$,%U%!%$%k$r%;!<%V!JJ]B8$9$k!K$9$k$^$G!":#$^$G$NJQ99$OJT=8$7$F$$(B -$B$k%U%!%$%k$K=q$-9~$^$l$k;v$O$"$j$^$;$s!#$=$l$O!"$"$J$?$,$=$N$h$&$K9T$$$?$/(B -$B$J$$$N$K!"ESCf$^$GJQ99$r2C$($?$b$N$,>!<j$K=q$-9~$^$l$k$h$&$J;v$,$J$$$h$&$K(B -$B$G$9!#(B - - $B%;!<%V$r9T$C$?8e$G$5$(JQ99$7$?$b$N$,4V0c$C$F$$$?;~$N$?$a$K(BEmacs$B$OL>A0(B -$B$rJQ$($F%*%j%8%J%k$N%U%!%$%k$r;D$7$^$9!#(B - -$BHw9M(B: $B$^$?!"(BEmacs$B$OITB,$N;vBV$KBP$7!"0lDj$N%?%$%_%s%0$4$H$K<+F0E*(B - $B$KJT=8$7$F$$$k%U%!%$%k$NFbMF$rL>A0$rJQ$($?%U%!%$%k$K%;!<%V$7(B - $B$^$9!#$3$l$K$h$C$F!"K|0l$N>l9g$O9T$C$?$NJQ99$KBP$7:G>.8B$NHo(B - $B32$G:Q$`$h$&$K$J$C$F$$$^$9!#(B - - $B2hLL$N2<$NJ}$r8+$k$H!"$3$N$h$&$J46$8$G%b!<%I%i%$%s$,I=<($5$l$F$$$k$H;W(B -$B$$$^$9!#(B - - -($BNc(B) [--]J:--**-Mule: MULE.tut (Fundamental) ---55%-------------- - - - $B$3$N(BEmacs$B%A%e!<%H%j%"%k$N%3%T!<$O(BMULE.tut$B$H8F$P$l$F$$$^$9!#%U%!%$%k$r(B -$B%U%!%$%s%I!J%U%!%$%k$r8+$D$1$F%P%C%U%!$KFI$_9~$`$3$H!K$9$k$H!"(BMULE.tut$B$NIt(B -$BJ,$KI=<($5$l$^$9!#Nc$($P!"(Bnew-file$B$H$$$&L>A0$N%U%!%$%k$r%U%!%$%s%I$7$?$J$i(B -$B$P!"(B"Mule: new-file"$B$H$$$&%b!<%I%i%$%s$K$J$k$G$7$g$&!#(B - -$BCm0U!'(B $B%b!<%I%i%$%s$K$D$$$F$O8e$[$I@bL@$7$^$9!#>/$7$*BT$A$r!#(B - - $B%U%!%$%k$r%U%!%$%s%I$7$?$j!"%;!<%V$7$?$j$9$k%3%^%s%I$O!"$3$l$^$G$N$b$N(B -$B$H$O0c$$!"#2$D$NJ8;z$+$i$J$C$F$$$^$9!#(BC-x $B$KB3$$$FF~NO$9$kJ8;z$,!"%U%!%$%k(B -$B$KBP$7$F9T$&A`:n$rI=$7$^$9!#(B - - $B$b$&0l$D$3$l$^$G$N$b$N$H0c$&E@$O!"%U%!%$%s%I$N;~!"%U%!%$%kL>$r(BEmacs$B$K(B -$BLd$o$l$^$9!#$3$N$3$H$r!"C<Kv$+$i0z?t$rFI$_9~$s$G$/$k%3%^%s%I$H8@$C$F$$$^$9!#(B - -$BCm0U!'(B $B$3$N>l9g$O%U%!%$%kL>$G$9!#(B - - C-x C-f $B%U%!%$%k$r8+$D$1$k!J%U%!%$%s%I$9$k!K(B - - Emacs$B$O%U%!%$%kL>$rJ9$$$F$-$^$9!#$=$l$O!"2hLL$N2<$N9T$K8=$l$^$9!#%U%!(B -$B%$%kL>$r;XDj$7$F$$$kItJ,$O!"%_%K%P%C%U%!$H8F$P$l$k$b$N$G$9!#%_%K%P%C%U%!$O(B -$B$3$NMM$J;H$o$lJ}$r$7$^$9!#%U%!%$%kL>$KB3$$$F!"%j%?!<%s%-!<$r2!$9$H!"%_%K%P(B -$B%C%U%!$KI=<($5$l$F$$$?FbMF$O$b$&I,MW$G$O$J$/$J$k$N$G>C$($F$7$^$$$^$9!#(B - - >> C-x C-f$B$H%?%$%W$7$?8e$K(BC-g$B$H%?%$%W$7$F2<$5$$!#%_%K%P%C%U%!$NFbMF(B - $B$r<h$j>C$7!"$^$?!"(BC-x C-f$B%3%^%s%I$b<h$j>C$7$^$9!#$H8@$&Lu$G!"2?$b(B - $B%U%!%$%k$r8+$D$1$k$h$&$J$3$H$O$7$^$;$s!#(B - - $B:#EY$O%U%!%$%k$r%;!<%V$7$F$_$^$7$g$&!#:#$^$G$NJQ99$rJ]B8$9$k$?$a$K$O<!(B -$B$N$h$&$J%3%^%s%I$r;H$$$^$9!#(B - - C-x C-s $B%U%!%$%k$r%;!<%V$9$k(B - - Emacs$B$NFbMF$O%U%!%$%k$K=q$-=P$5$l$^$9!#%;!<%V$9$k;~!"%*%j%8%J%k$N(B -$B%U%!%$%k$O?7$7$$L>A0$r$D$1$i$l$F;D$5$l$F$$$k$N$GFbMF$O<:$o$l$^$;$s!#$=(B -$B$N?7$7$$L>A0$O%*%j%8%J%k$N%U%!%$%k$NL>A0$K(B'~'$B$r$D$1$?$b$N$G$9!#(B - - $B%;!<%V$,=*$o$k$H!"(BEmacs$B$O%;!<%V$7$?%U%!%$%k$NL>A0$rI=<($7$^$9!#(B - - >> C-x C-s$B$H%?%$%W$7$F%A%e!<%H%j%"%k$N%3%T!<$r%;!<%V$7$F2<$5$$!#$=$N(B - $B;~!"2hLL$N2<$NJ}$K(B"Wrote ...../MULE.tut"$B$HI=<($5$l$^$9!#(B - - $B?7$7$$%U%!%$%k$r:n$k;~!"$"$?$+$b0JA0$+$i$"$C$?%U%!%$%k$r%U%!%$%s%I$9$k(B -$B$h$&$J%U%j$r$7$^$9!#$=$&$7$F!"$=$N%U%!%$%s%I$7$?%U%!%$%k$K%?%$%W$7$F$$$-$^(B -$B$9!#(B - - $B%U%!%$%k$r%;!<%V$7$h$&$H$7$?;~$K=i$a$F!"(BEmacs$B$O:#$^$GJT=8$7$F$$$?FbMF(B -$B$r%U%!%$%k$NCf$K=q$-9~$_$^$9!#(B - - -$B%P%C%U%!(B -======== - - $B$b$7!"#2HVL\$N%U%!%$%k$r(B C-x C-f $B$G<h$j=P$9$H!"#1HVL\$N%U%!%$%k$O(BEmacs -$BFbIt$K;D$j$^$9!#(BEmacs$BFbIt$K$"$k%U%!%$%k$+$i%F%-%9%H$rFI$_9~$s$GJ]B8$7$F$$$k(B -$B$b$N$O%P%C%U%!$H8F$P$l$^$9!#%U%!%$%k$N<h$j=P$7$O!"(BEmacs$BFbIt$K?7$7$$%P%C%U%!(B -$B$r:n$j$^$9!#(B - - Emacs$B$NCf$KJ]B8$7$F$$$k%P%C%U%!$N%j%9%H$r8+$k$K$O!"<!$N$h$&$K%?%$%W$7(B -$B$^$9!#(B - - C-x C-b - - >> C-x C-b $B$H%?%$%W$7$J$5$$!#$=$l$>$l$N%P%C%U%!$,$I$N$h$&$KL>A0$r;}(B - $B$C$F$$$k$+!"$=$7$F!"$I$N$h$&$J%U%!%$%kL>$r$D$1$F$$$k$N$+4Q;!$7$J(B - $B$5$$!#(B - - $B%P%C%U%!$K$O%U%!%$%k$H0lCW$J$$$b$N$b$"$j$^$9!#$?$H$($P!"(B -"*Buffer List*" $B$H$$$&%U%!%$%k$O$"$j$^$;$s!#$3$l$O(B C-x C-b $B$K$h$C$F:n$i$l(B -$B$?%P%C%U%!%j%9%H$KBP$7$F$N%P%C%U%!$G$9!#(B - - $B$"$J$?$,8+$F$$$k(BEmacs$B%&%#%s%I%&Fb$K$"$k!"$I$s$J%F%-%9%H$G$b!"$$$:$l$+(B -$B$N%P%C%U%!Fb$K$"$j$^$9!#(B - - >> $B%P%C%U%!%j%9%H$r>C$9$?$a(B C-x 1 $B$H%?%$%W$7$J$5$$!#(B - - $B$b$7!"$"$k%U%!%$%k$N%F%-%9%H$KJQ99$r9T$J$C$F$+$i!"B>$N%U%!%$%k$r<h$j=P(B -$B$7$?$H$7$?$i!":G=i$N%U%!%$%k$O%;!<%V$5$l$F$$$^$;$s!#$=$NJQ99$O(BEmacs$BFbIt$N%U(B -$B%!%$%k$HBP1~$9$k%P%C%U%!$NCf$@$1$K9T$J$o$l$F$$$^$9!#(B - - $B#2HVL\$N%U%!%$%k$KBP1~$9$k%P%C%U%!$r:n$C$?$j!"%(%G%#%C%H$7$?$j$7$F$b!"(B -$B#1HVL\$N%U%!%$%k$KBP1~$9$k%P%C%U%!$K$O2?$b1F6A$rM?$($^$;$s!#$3$l$O$H$F$b;H(B -$B$$0W$/!"$^$?!"#1HVL\$N%U%!%$%k$KBP1~$9$k%P%C%U%!$r<h$C$F$*$/$?$a$KLr$KN)$D(B -$BJ}K!$G$9!#(B - - C-x C-s $B$G%P%C%U%!$r%;!<%V$9$k$?$a$K(B C-x C-f $B$G%P%C%U%!$r@Z$jBX$($k$N(B -$B$OLq2p$G$9!#$=$3$G<!$N%3%^%s%I$r;H$$$^$9!#(B - - C-x s $B8=:_$"$k%P%C%U%!$r%;!<%V$9$k!#(B - - C-x s $B$OFbMF$rJQ$($?%P%C%U%!A4$F$r%U%!%$%k$K%;!<%V$7$^$9!#$3$N;~!"$R$H(B -$B$D$R$H$D$N(B($B%;!<%V$5$l$k$Y$-(B)$B%P%C%U%!$KBP$7$F!"%;!<%V$9$k$+!"$7$J$$$+$r(By$B$+(Bn -$B$GLd$o$l$^$9!#$3$NI=<($O2hLL$N2<$N9T$KI=<($5$l$^$9!#Nc$($P!"$3$N$h$&$K$G$9!#(B - - Save file /usr/private/yours/MULE.tut? (y or n) - - - -$B%3%^%s%I$N3HD%(B -============== - - $B%(%G%#%?$K$O!"%3%s%H%m!<%k!&%-!<$d%a%?!&%-!<$GF~NO$G$-$k$b$N$h$j$b$:$C(B -$B$HB?$/$N%3%^%s%I$,$"$j$^$9!#$3$l$i$r07$&$?$a$K!"3HD%!J(BeXtend$B!K%3%^%s%I$r(B -$B;H$$$^$9!#$=$l$K$O!"0J2<$N#2$D$N<oN`$,$"$j$^$9!#(B - - C-x $BJ8;z$K$h$k3HD%!#B3$1$F0lJ8;z$rF~NO$7$^$9!#(B - ESC x $BL>A0$K$h$k3HD%!#B3$1$F%3%^%s%I$NL>A0$rF~NO$7$^$9!#(B - - $B$3$l$i$O0lHL$K!"JXMx$@$1$l$I$b!"$3$l$^$G8+$F$-$?$b$N$[$IIQHK$K$OMQ$$$i(B -$B$l$J$$%3%^%s%I$N$?$a$N$b$N$G$9!#(BC-x C-f $B!J%U%!%$%s%I!K$d(B C-x C-s$B!J%;!<%V!K(B -$B$O$3$NCg4V$G$9!#B>$K!"(BC-x C-c$B!J%(%G%#%?$N=*N;!K$b$=$&$G$9!#(B - - C-z$B$O(BEmacs$B$rH4$1$k$N$KNI$/;H$o$l$kJ}K!$G$9!#(BEmacs$B$r=*N;$9$k$3$H$J$/!"(B -$B0lC6!"(Bcsh$B$N%l%Y%k$KLa$k$K$O0lHVNI$$J}K!$H8@$($k$G$7$g$&!#(BC-z$B$r9T$J$o$l$F$b(B -Emacs$B$O%9%H%C%W$7$F$$$k$@$1$G!"FbMF$,GK2u$5$l$k$H$$$&$3$H$O$"$j$^$;$s!#(B - -$BCm0U(B: $B$?$@$7(BX-window$B$G9T$J$C$F$$$k>l9g!"$b$7$/$O;HMQ$7$F$$$k%7%'%k(B - $B$,(Bsh$B$N;~$O!"$3$N8B$j$G$O$"$j$^$;$s!#(B - - - C-x $B%3%^%s%I$O!"$?$/$5$s$"$j$^$9!#$9$G$K3X$s$@$b$N$O0J2<$N$b$N$G$9!#(B - - C-x C-f $B%U%!%$%k$NJT=8!J(BFind$B!K(B - C-x C-s $B%U%!%$%k$NJ]B8!J(BSave$B!K(B - C-x C-b $B%P%C%U%!%j%9%H$NI=<((B - C-x C-c $B%(%G%#%?$r=*N;$9$k!#%U%!%$%k$NJ]B8$O!"<+F0E*$K$O9T$o$l$^$;(B - $B$s!#$7$+$7!"$b$7%U%!%$%k$,JQ99$5$l$F$$$l$P!"%U%!%$%k$NJ]B8(B - $B$r$9$k$N$+$I$&$+$rJ9$$$F$-$^$9!#J]B8$7$F=*N;$9$kIaDL$NJ}K!(B - $B$O!"(BC-x C-s C-x C-c $B$H$9$k$3$H$G$9!#(B - - $BL>A0$K$h$k3HD%%3%^%s%I$K$O!"$"$^$j;H$o$l$J$$$b$N$d!"FCDj$N%b!<%I$G$7$+(B -$B;H$o$J$$$b$N$J$I$,$"$j$^$9!#Nc$H$7$F!"(B"command-apropos" $B$r$H$j$"$2$^$9!#$3(B -$B$N%3%^%s%I$O%-!<%o!<%I$rF~NO$5$;!"$=$l$K%^%C%A$9$kA4$F$N%3%^%s%I$NL>A0$rI=(B -$B<($7$^$9!#(BESC x $B$H%?%$%W$9$k$H!"%9%/%j!<%s$N2<$K(B "M-x" $B$,I=<($5$l$^$9!#$3$l(B -$B$KBP$7$F!"<B9T$9$k%3%^%s%I$NL>A0!J:#$N>l9g!"(B"command-apropos"$B!K$rF~NO$7$^$9!#(B -"command-a" $B$^$GF~NO$7$?8e%9%Z!<%9$rF~$l$l$P!"8e$NItJ,$O<+F0E*$KJd$o$l$^$9!#(B -$B$3$N8e!"%-!<%o!<%I$rJ9$+$l$^$9$+$i!"CN$j$?$$J8;zNs$r%?%$%W$7$^$9!#$J$*!"%-!<(B -$B%o!<%I$rF~$l$J$$$H!"A4$F$N%3%^%s%I$,I=<($5$l$^$9!#(B - - >> ESC x $B$r%?%$%W$7!"B3$1$F!"(B"command-apropos<Return>" $B$"$k$$$O(B - "command-a<Space><Return>" $B$H%?%$%W$7$^$9!#<!$K!"(B"kanji<Return>" - $B$H%?%$%W$7$^$9!#(B - - $B8=$l$?!V%&%#%s%I%&!W$r>C$9$K$O!"(BC-x 1 $B$H%?%$%W$7$^$9!#(B - -$B%b!<%I%i%$%s(B -============ - - $B$b$7$f$C$/$j$H%3%^%s%I$rBG$C$?$J$i$P!"2hLL$N2<Dl$N%(%3!<%(%j%"$H8F$P$l(B -$B$k>l=j$KBG$C$?$b$N$,I=<($5$l$^$9!#%(%3!<%(%j%"$O2hLL$N(B1$B$P$s2<$N9T$G$9!#$=$N(B -$B$9$0>e$N9T$O!"%b!<%I%i%$%s$H8F$P$l$F$$$^$9!#%b!<%I%i%$%s$O$3$s$JIw$KI=<($5(B -$B$l$F$$$k$G$7$g$&!#(B - - [--]J:--**-Mule: MULE.tut (Fundamental) ---NN%-------------- - - -$BCm0U(B: NN%$B$N(BNN$B$O?t;z$,F~$C$F$$$^$9!#$"$J$?$,;H$C$F$$$k(BEmacs$B$N%b!<(B - $B%I%i%$%s$H0c$&$+$bCN$l$J$$$1$I!"92$F$J$$$h$&$K!#Nc$($P!";~4V(B - $B$d(Buptime$B$,I=<($5$l$F$$$k$N$O!"(Bdisplay-time$B$H$$$&5!G=$,F0$$$F(B - $B$$$k$+$i$G$9!#(B - - $B$3$N9T$K$h$C$FB?$/$NM-MQ$J>pJs$,F@$i$l$^$9!#(B - - - $B:#!"$"$J$?$,8+$F$$$k%U%!%$%kL>$rI=<($7$F$$$^$9!#(BNN%$B$O8=:_%9%/%j!<%s>e(B -$B$K%U%!%$%k$N0lHV>e$+$i2?%Q!<%;%s%HL\$,I=<($5$l$F$$$k$+$r<($7$F$$$^$9!#%U%!(B -$B%$%k$N0lHV:G=i$rI=<($7$F$$$k$J$i$P!"(B--Top--$B$HI=<($5$l$F$^$9!#%U%!%$%k$N0lHV(B -$B:G8e$rI=<($7$F$$$k$J$i$P!"(B--Bot--$B$HI=<($5$l$^$9!#2hLL$NCf$K%U%!%$%k$NA4$F$,(B -$BI=<($5$l$F$$$k$J$i$P!"(B--All--$B$HI=<($5$l$^$9!#(B - - $B%b!<%I%i%$%s$N>.3g8L$NCf$O!":#$I$s$J%b!<%I$KF~$C$F$$$k$+$r<($7$F$$$^$9!#(B -$B8=:_$O!"%G%U%)%k%H$N(BFundamental$B$KF~$C$F$$$^$9!#$3$l$b%a%8%c!<%b!<%I$N0lNc$G(B -$B$9!#(B - - Emacs$B$O(BLisp mode$B$d(BText mode$B$N$h$&$J$3$H$J$k%W%m%0%i%`8@8l$d%F%-%9%H$K(B -$BBP$7$F%(%G%#%C%H$r9T$&$?$a$N4v$D$+$N%a%8%c!<%b!<%I$r;}$C$F$$$^$9!#$I$s$J;~(B -$B$G$bI,$:$$$:$l$+$N%a%8%c!<%b!<%I$N>uBV$K$J$C$F$$$^$9!#(B - - $B$=$l$>$l$N%a%8%c!<%b!<%I$O4v$D$+$N%3%^%s%I$rA4$/0c$&?6$kIq$$$K$7$F$7$^(B -$B$$$^$9!#Nc$r>e$2$F$_$^$7$g$&!#%W%m%0%i%`$NCf$K%3%a%s%H$r:n$k%3%^%s%I$,$"$j(B -$B$^$9!#%3%a%s%H$r$I$NMM$J7A<0$K$9$k$+$O!"3F%W%m%0%i%`8@8l$K$h$C$F0c$$$^$9$,!"(B -$B$=$l$>$l$N%a%8%c!<%b!<%I$O!"$-$A$s$HF~$l$F$/$l$^$9!#(B - - $B$=$l$>$l$N%a%8%c!<%b!<%I$KF~$k$?$a$N%3%^%s%I$O%b!<%IL>$N3HD%$5$l$?$b$N(B -$B$K$J$C$F$$$^$9!#Nc$($P!"(BM-x fundamental-mode$B$O(BFundamental$B$KF~$k$?$a$N$b$N$G(B -$B$9!#(B - - $B$b$7!"1Q8l$r%(%G%#%C%H$9$k$J$i$P!"(BText mode$B$KF~$j$^$9!#(B - - >> M-x text-mode <Retuen>$B$H%?%$%W$7$J$5$$!#(B - - $B8=:_$N%a%8%c!<%b!<%I$K$D$$$F$N%I%-%e%a%s%H$r8+$?$$;~$O!"(BC-h m$B$H%?%$%W(B -$B$7$^$9!#(B - - >> C-h m $B$r;H$C$F(BText mode$B$H(BFundamental mode$B$N0c$$$rD4$Y$J$5$$!#(B - - >> C-x 1$B$G%I%-%e%a%s%H$r2hLL$+$i>C$7$J$5$$!#(B - - $B:8C<$N(B '[--]' $B$O8=:_$N%-!<F~NO$N%b!<%I$r<($7$F$$$^$9!#(B[--] $B$N;~$K$O(B -$B1Q8l%"%k%U%!%Y%C%H$,$=$N$^$^F~NO$G$-$^$9!#F~NO%b!<%I$K$D$$$F$N>\$7$$@bL@$O(B -$B!V$?$^$4!W$N%^%K%e%"%k$rD4$Y$F2<$5$$!#(B - - $B$=$N$9$01&$K$O%3!<%IBN7O(B (coding-system) $B$K4X$9$k%U%i%0$N>uBV$,I=(B -$B<($5$l$F$$$^$9!#(BMule $B$O!"%U%!%$%kF~=PNO!"F~NO!"2hLL=PNO$K$D$$$F!"$=$l$>$lFH(B -$BN)$K%3!<%IBN7O$r;XDj$5$;$k$3$H$,=PMh$^$9$,!"DL>o$O%U%!%$%kMQ$N%3!<%IBN7O$N(B -$B%K!<%b%K%C%/$N$_I=<($7$F$$$^$9!#(B - - >> $B%b!<%I%i%$%s>e$K(B"J:","S:",$B$b$7$/$O(B "E:"$B$,I=<($5$l$F$$$k$+$I$&$+3N(B - $BG'$7$J$5$$!#(B - - $B:G=i$N0lJ8;z$,%3!<%IBN7O$N%K!<%b%K%C%/!"<!$N(B ':' $B$,8=:_1Q8l0J30$NJ8;z(B -$B!JF|K\8l!"Cf9q8l$J$I!K$b$A$c$s$HI=<($9$k$H$$$&$3$H$r<($7$F$$$^$9!#(BJ$B$O(BJUNET -$B$G;H$o$l$F$$$k(B JIS $B%3!<%I!"(BS $B$O(B Shift-JIS$B!"(BE $B$OF|K\8l(BEUC $B$r<($7$F$$$^$9!#(B -$BB?9q8l$NI=<($NM-L5$O(B C-x C-k t $B$G(B ON/OFF$B$N%H%0%k$,$G$-$^$9!#(B - - $B<!$NNc$O!"0lEYB?9q8lI=<($r(BOFF$B$7$F$+$i!"$b$&0lEY(BON$B$r9T$C$F$_$^$9!#(B - - >> C-x C-k t$B$r(B2$BEY9T$$$J$5$$!#(B - - $BF~NO%b!<%I$,(BJIS$B%3!<%I$N@_Dj$H$J$C$F$$$k;~!"$b$7$"$J$?$N;H$C$F$$$kC<Kv(B -$B$K%a%?!&%-!<$,IU$$$F$$$k$J$i!"%(%9%1!<%W!&%-!<$NBe$o$j$K$=$l$r;H$&$3$H$,=P(B -$BMh$^$9!#$=$N;~!"%a%?!&%-!<$N;H$$J}$O%3%s%H%m!<%k!&%-!<$HF1MM$K2!$7$J$,$iJ8(B -$B;z$r%?%$%W$7$^$9!#(BESC <$BJ8;z(B>$B$b(BM-<$BJ8;z(B>$B$bF1$8F/$-$r$7$^$9!#:#$^$G$N@bL@$G(BESC -<$BJ8;z(B>$B$H9T$J$C$F$$$?$H$3$m$,!"(BM-<$BJ8;z(B>$B$H$J$j$^$9!#Cm0U$7$J$1$l$P$J$i$J$$$N(B -$B$O!"%7%U%H(BJIS$B$d(BEUC$B%3!<%I$N;~$O;HMQ$G$-$^$;$s!#(B - - $B%3!<%IBN7O$N$N@Z$jBX$($O!"3F!9$N%P%C%U%!$KBP$7$F$N$_M-8z$G$9!#$=$l$>$l(B -$B$N!"%3!<%IBN7O;XDj$K$D$$$F$O!"(BC-h a coding-system <Return>$B$G8+$k$3$H(B -$B$,=PMh$^$9!#(B - - >> C-h a coding-system <Return>$B$G=P$F$/$k%I%-%e%a%s%HCf$N!"(B - set-display-coding-system, set-file-coding-system, - set-process-coding-system $B$N@bL@$rFI$_$J$5$$!#(B - -$B8!:w(B -===== - - $BJ8;zNs$r!"%U%!%$%kFb$G!"A0J}Kt$O8eJ}$K!"C5$9;v$,$G$-$^$9!#8!:w$r;O$a$k(B -$B%3%^%s%I$O!"%+!<%=%k0LCV0J9_$r8!:w$9$k$J$i$P(B C-s$B!"%+!<%=%k0LCV0JA0$J$i$P(B -C-r $B$G$9!#(BC-s $B$r%?%$%W$9$k$H!"%(%3!<%(%j%"$K(B "I-search:"$B$H$$$&J8;zNs$,%W%m(B -$B%s%W%H$H$7$FI=<($5$l$^$9!#(BESC$B$r2!$9$H!"=*N;$G$-$^$9!#(B - - - >> C-s$B$G8!:w$,;O$^$j$^$9!#$=$l$+$i!"$f$C$/$j$H#1J8;z$:$D(B"cursor"$B$H$$(B - $B$&C18l$rF~NO$7$^$9!##1J8;zF~NO$9$k$4$H$K!"%+!<%=%k$O!"$I$s$JF0$-(B - $B$r$7$^$9$+(B? - - >> $B$b$EY(B C-s $B$r%?%$%W$9$k$H!"<!$N(B"cursor"$B$r8+$D$1$i$l$^$9!#(B - - >> <Delete>$B$r#42sF~NO$7$F!"%+!<%=%k$NF0$-$r8+$J$5$$!#(B - - >> ESC$B$r2!$7$F!"=*N;$7$^$9!#(B - - $BC5$7$?$$J8;zNs$r%?%$%WCf$G$b!"%?%$%W$7$?J8;zItJ,$@$1$G!"8!:w$r;O$a$^$9!#(B -$B<!$NJ8;z$rC5$9$K$O!":F$S(BC-s$B$r%?%$%W$7$^$9!#$b$7!"J8;zNs$,B8:_$7$J$+$C$?$i!"(B -$B%a%C%;!<%8$,I=<($5$l$^$9!#(BC-g $B$G$b=*N;$G$-$^$9!#(B - - $B8!:w<B9TCf$K(B<Delete>$B$rF~NO$9$k$H!"8!:wJ8;zNs$N#1HV8e$m$NJ8;z$,>C$($^$9!#(B -$B$=$7$F!"%+!<%=%k$O!"A02s$N0LCV$KLa$j$^$9!#$?$H$($P!"(B"cu"$B$H%?%$%W$7$F!":G=i(B -$B$N(B"cu"$B$N0LCV$K%+!<%=%k$,F0$$$?$H$7$^$9!#$3$3$G(B<Delete>$B$rF~NO$9$k$H!"%5!<%A(B -$B%i%$%s$N(B'u'$B$,>C$(!"%+!<%=%k$O!"(B'u'$B$r%?%$%W$9$kA0$K!"%+!<%=%k$,$"$C$?(B'c'$B$N0L(B -$BCV$K!"0\F0$7$^$9!#(B - - $B8!:w<B9TCf$K!"(BC-s $B$d(B C-r $B0J30$N%3%s%H%m!<%kJ8;z$r%?%$%W$9$k$H!"8!:w$O(B -$B=*N;$7$^$9!#(B - - C-s $B$O!"8=:_$N%+!<%=%k0LCV0J9_$K=P$F$/$k8!:wJ8;zNs$rC5$7$^$9!#$b$7!"A0(B -$B$NJ}$rC5$7$?$+$C$?$i!"(BC-r $B$r%?%$%W$9$k$3$H$G!"5UJ}8~8!:w$,$G$-$^$9!#(BC-s $B$H(B -C-r $B$O!"8!:w$NJ}8~$,H?BP$J$@$1$G!"A4$FF1$8F/$-$r$7$^$9!#(B - -$B%j%+!<%7%V(B $B%(%G%#%F%#%s%0(B $B%l%Y%k(B - - $B$H$-$I$-!"!JITK\0U$K!K%j%+!<%7%V(B $B%(%G%#%F%#%s%0(B $B%l%Y%k$H8F$P$l$k>uBV$K(B -$BF~$k$3$H$,$"$j$^$9!#%a%8%c!<%b!<%I$N>.3g8L(B'()'$B$N2s$j$rCf3g8L(B'[]'$B$G0O$s$@$b(B -$B$N$,%b!<%I%i%$%s>e$KI=<($5$l$^$9!#Nc$($P!"(B(Fundamental)$B$HI=<($5$l$kBe$o$j$K(B -[(Fundamental)]$B$N$h$&$K$J$j$^$9!#(B - -$BCm0U(B: $B$3$3$G$O%j%+!<%7%V(B $B%(%G%#%F%#%s%0(B $B%l%Y%k<+BN$K$D$$$F$O@bL@$7(B - $B$^$;$s!#(B - - $B%j%+!<%7%V(B $B%(%G%#%F%#%s%0(B $B%l%Y%k$+$iH4$1$G$k$?$a$K$O!"(BM-x top-level -<Return>$B$H%?%$%W$7$^$9!#(B - - >> $B;n$7$F$_$F2<$5$$!#%9%/%j!<%s$NDl$K(B"Back to top level"$B$HI=<($5$l$^(B - $B$9!#(B - - $BK\Ev$O!"$3$N;n$_$,9T$o$l$?;~$O!"$9$G$K%H%C%W%l%Y%k$K$$$?$N$G$9!#(BM-x -top-level$B$O!"2?$b1F6A$rM?$($F$$$^$;$s!#(B - - $B%j%+!<%7%V(B $B%(%G%#%F%#%s%0(B $B%l%Y%k$+$iH4$1=P$k$N$KBP$7$F$O(BC-g$B$O8z$-$^$;(B -$B$s!#(B - - -$B%X%k%W(B -====== - - Emacs$B$K$O!"$?$/$5$s$NLr$KN)$D5!G=$,$"$j!"$3$3$G!"$9$Y$F$r@bL@$9$k$3$H(B -$B$O!"IT2DG=$G$9!#$7$+$7!"$^$@CN$i$J$$B?$/$N5!G=$r3X$V$?$a$K$O!"(B<HELP>$B$H8F$P(B -$B$l$k(B C-h $B$r%?%$%W$9$k$3$H$G!"$?$/$5$s$N>pJs$r<j$KF~$l$k$3$H$,$G$-$^$9!#(B - - $B;H$$J}$O!"(BC-h $B$r%?%$%W$7!"B3$$$FI,MW$J%*%W%7%g%s$r#1J8;z%?%$%W$7$^$9!#(B -$B$o$+$i$J$1$l$P!"(BC-h ? $B$H%?%$%W$9$k$H!"$I$s$J%*%W%7%g%s$,$"$k$N$+I=<($5$l$^(B -$B$9!#$b$7!"(BC-h $B$r%?%$%W$7$F$+$i5$$,JQ$o$C$?$i!"(BC-g $B$r%?%$%W$9$l$P!"<h$j>C$9(B -$B$3$H$,$G$-$^$9!#(B - - $B:G$b4pK\E*$J$b$N$O!"(BC-h c $B$G$9!#$3$l$KB3$$$F%-!<$rF~NO$9$k$H!"$=$N%3%^(B -$B%s%I$K$D$$$F$NC;$$@bL@$rI=<($7$^$9!#(B - - >> C-h c C-p $B$H%?%$%W$7$F$_$J$5$$!#(B"C-p runs the command previous- - line"$B$N$h$&$J%a%C%;!<%8$,I=<($5$l$k$O$:$G$9!#(B - - $B8+$?$3$H$O$"$k$,!"3P$($F$O$$$J$$%3%^%s%I$b;W$$=P$;$k$N$G$9!#(BC-x C-s $B$N(B -$B$h$&$JJ#?t$G#1$D$N%3%^%s%I$b(BC-h c $B$N8e$m$KB3$1$i$l$^$9!#(B - - $B$b$C$H>\$7$/CN$j$?$+$C$?$i!"(Bc $B$NBe$o$j$K(B k $B$r;XDj$7$^$9!#(B - - >> C-h k C-p $B$H%?%$%W$7$F$_$J$5$$!#(B - - Emacs$B$N%&%#%s%I%&$K!"%3%^%s%I$NL>A0$H5!G=$,I=<($5$l$^$9!#FI$_=*$($?$i!"(B -C-x 1 $B$H%?%$%W$9$k$H!"H4$1$i$l$^$9!#(B - - $BB>$K$bLr$KN)$D%*%W%7%g%s$,$"$j$^$9!#(B - - C-h f $B%U%!%s%/%7%g%sL>$rF~NO$9$k$H!"%U%!%s%/%7%g%s$rI=<($7$^$9!#(B - - >> C-h f previous-line $B$r%?%$%W$7!"(B<Return> $B$r2!$7$J$5$$!#(BC-p $B%3%^%s(B - $B%I$r<B9T$9$k%U%!%s%/%7%g%s$K$D$$$F$N>pJs$rI=<($7$^$9!#(B - - C-h a $B%-!<%o!<%I$rF~NO$9$k$H!"L>A0$K$=$N%-!<%o!<%I$r4^$`!"A4$F$N%3(B - $B%^%s%I$rI=<($7$^$9!#$3$l$i$N%3%^%s%I$O$9$Y$F(BESC x $B$G<B9T$G$-(B - $B$^$9!#(B - - >> C-h a file $B$H%?%$%W$7!"(B<Return>$B$r2!$7$J$5$$!#L>A0$K(B"file"$B$H$$$&J8(B - $B;z$r;}$DA4$F$N%3%^%s%I$rI=<($7$^$9!#$^$?!"(Bfind-file $B$d(B write-file - $B$H$$$&L>$N(B C-x C-f $B$d(B C-x C-w $B$N$h$&$J%3%^%s%I$bI=<($5$l$^$9!#(B - -$B$*$o$j$K(B -======== - -$BK:$l$:$K!'(B $B=*N;$9$k$K$O!"(BC-x C-c $B$H$7$^$9!#(B - - - $B$3$NF~LgJT$O!"$^$C$?$/$N=i?4<T$K$b$o$+$j$d$9$$$h$&$K$H0U?^$7$F$$$^$9!#(B -$B$G$9$+$i!"$b$72?$+$o$+$j$K$/$$E@$,$"$C$?$J$i!"0l?M$G6rCT$r8@$&$N$G$O$J$/!"(B -$BJ86g$r$D$1$F2<$5$$!#(B - - - $B$b$7!"(BEMACS $B$r2?F|$+$G$b;H$C$F$_$l$P!"$=$l$r$d$a$F$7$^$&$3$H$J$I$G$-$J(B -$B$/$J$k$G$7$g$&!#:G=i$O8MOG$&$+$bCN$l$^$;$s!#$7$+$7!"$=$l$O$I$s$J%(%G%#%?$G(B -$B$bF1MM$G$9!#(BEMACS $B$N$h$&$K!"Hs>o$KB?$/$N$3$H$,$G$-$k>l9g$K$OFC$K$=$&$G$7$g(B -$B$&!#$=$7$F!"(BEMACS $B$G$O!"<B:]!"2?$G$b$G$-$k$N$G$9$+$i!#(B - - - -$B<U<-(B -===== - $B$3$NJ8=q$O!"(BJUNET$B$GN.$5$l$?(B"$BF|K\8l(B MicroEMACS (kemacs) $BF~LgJT(B" $B$r(BGNUE- -macs (Nemacs)$B$N(BTutorial$BMQ$K=q$-49$($?$b$N$G$9!#(B - - Jonathan Payne $B$K$h$k(B "JOVE Tutorial" (19 January 86) $B$rJQ99$7$?$b$N$G(B - $B$"$j!"$=$l$O$b$H$b$H$O!"(BCCA-UNIX$B$N(BSteve Zimmerman $B$K$h$C$FJQ99$5$l$?!"(B - MIT $B$N(B "Teach-Emacs" $BF~LgJT(B (31 October 85) $B$r!J$5$i$K!KJQ99$7$?$b$N$G(B - $B$7$?!#(B - - Update - February 1986 by Dana Hoggatt. - - Update - December 1986 by Kim Leburg. - - Update/Translate - July 1987 by SANETO Takanori - -$BFCJL$J<U<-(B -========== - - $B:G=i$K$3$l$NF|K\8lLu$r:n$i$l$?!"(BSANETO Takanori$B$5$s!#$3$NJ8>O$O(BGMW + -Wnn + Nemacs$B$r;H$C$F=q$-$^$7$?!#$=$N$h$&$JAG@2$i$7$$%W%m%0%i%`$r:n$C$?J}!9(B -$B$X46<U$N0U$rI=$7$?$$$H;W$$$^$9!#K]Lu$H$+!"F~NO$H$+$r?'!9$H<jEA$C$F$/$l$?!"(B -$BF#86>M;R$5$s!"$I$&$b$"$j$,$H$&!#(B - - - - - -$B8mLu!"13!"$=$NB>!"$NJ8@U$O!"0J2<$N<T$K$"$j$^$9!#(B - - $BNkLZM5?.(B hironobu@sra.co.jp - - -Update/Add - December 1987 by Hironobu Suzuki -Update/Add - November 1989 by Ken'ichi Handa -Update/Add - January 1990 by Shigeki Yoshida -Update/Add - March 1992 by Kenichi HANDA
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/TUTORIAL.ko Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,776 @@ + ============================== + $(C@O:;>n(B GNUEMACS(Mule) $(C@T9.Fm(B + ============================== + +$(CAV@G(B: $(C@L(B $(C@T9.Fm@:(B, "$(C9h?l1b:84Y(B $(C@M<wGXAv1b(B"$(C8&(B $(C8pEd7N(B $(C@[<:5G>n(B + $(C@V=@4O4Y(B. ">>" $(C7N:NEM(B $(C=C@[GO4B(B $(CG`@:(B, $(C1W(B $(C6'(B $(C9+>y@;(B $(CGX>_(B + $(CGO4B0!8&(B $(CAv=CGO0m(B $(C@V=@4O4Y(B. + + Mule $(C@G(B $(C8m7I>n8&(B $(C@T7BGR(B $(C6'?!4B(B, $(C@O9]@{@87N(B $(CD\F.7Q(B*$(CE0(B($(CE0(B*$(CEi?!(B, +CTRL $(C6G4B(B, CTL $(C6s0m(B $(C=a@V4Y(B)$(C3*(B $(C8^E8(B*$(CE0(B($(C:8Ek(B, $(C@L=:DI@LGA(B*$(CE08&(B $(C;g?kGQ4Y(B)$(C0!(B +$(C;g?k5K4O4Y(B. $(C1W7!<-(B, CONTROL $(C@L6s5g0!(B META $(C6s0m(B $(C>24B(B $(C4k=E?!(B, $(C4Y@=0z00@:(B +$(C1bH#8&(B $(C;g?kGO4B(B $(C0M@87N(B $(CGU4O4Y(B. + +C-<$(C9.@Z(B> $(CD\F.7Q(B*$(CE08&(B $(C4)8%C$(B, <$(C9.@Z(B>$(CE08&(B $(C4)8(4O4Y(B. $(C?98&(B $(C5i8i(B, + C-f $(C4B(B, $(CD\F.7Q(B*$(CE08&(B $(C4)8#8i<-(B f $(CE08&(B $(C4)8#4B(B $(C0M@;(B + $(C@G9LGU4O4Y(B. +<<Blank lines inserted here by startup of help-with-tutorial>> + >> $(C1W7/8i(B, C-v (View Next Screen; $(C4Y@=@G(B $(CH-8i@;(B $(C:;4Y(B) $(C8&(B $(CE8@LGA(B + $(CGO?)(B $(C:8<<?d(B. $(C4Y@=@G(B $(CH-8i@87N(B $(C0%(B $(C<v(B $(C@V=@4O4Y(B. + From now on, you'll be expected to do this whenever you finish + reading the screen. + +ESC <$(C9.@Z(B> $(C@L=:DI@LGA(B*$(CE08&(B $(C4)8#0m3*<-(B, $(C1W(B $(C5Z(B <$(C9.@Z(B>$(CE08&(B $(C4)8(4O4Y(B. + +$(CAV@G(B: <$(C9.@Z(B>$(C4B(B, $(C4k9.@Z3*(B $(C<R9.@Z4B(B $(C8m7I>n7N<-4B(B $(C00@:(B $(C@G9L0!(B + $(C5K4O4Y(B. $(C8^E8E08&(B $(C;g?kGR(B $(C<v(B $(C@V@88i(B ESC <$(C9.@Z(B> $(C4k=E?!(B M- + <$(C9.@Z(B> ($(C8^E8E08&(B $(C4)8%C$(B<$(C9.@Z(B>$(CE08&(B $(C4)8%4Y(B) $(C8&(B $(C;g?kGR(B $(C<v(B + $(C@V=@4O4Y(B. + +$(CA_?dGU4O4Y(B: Emacs$(C8&(B $(CA>7a=CE00m(B $(C=M@;(B $(C6'4B(B, C-x C-c $(C8&(B $(CE8@LGAGU4O4Y(B. + Emacs$(C8&(B csh$(C7N:NEM(B $(C1b5?GO0m(B $(C@V4B(B $(C0f?l(B, $(C<-=:Ff5eGO4B(B($(C@O=C(B + $(C@{@87N(B $(CA_4\GQ4Y(B)$(CGR(B $(C<v0!(B $(C@V=@4O4Y(B. Emacs$(C8&(B $(C<-=:Ff5eGO4B(B + $(C5%4B(B, C-z$(C8&(B $(CE8@LGAGU4O4Y(B. + + $(C1W7/8i(B, $(C@LA&:NEM4B(B, $(CGQH-8i@;(B $(C4Y(B $(C@P>z@88i(B, C-v $(C8&(B $(C@T7BGO?)(B $(CAV<<?d(B. + + $(C>U@G(B $(CH-8i0z(B $(C4Y@=(B $(CH-8i?!4B(B, $(CG%=C5G4B(B $(C3;?k?!(B $(C8nG`@G(B $(C9.@L(B $(CA_:95G0m(B +$(C@V=@4O4Y(B. $(CG%=C5G0m(B $(C@V4B(B $(C3;?k@L(B $(C?,<S5G>n(B $(C@V4B(B $(C0M@;(B $(C>K(B $(C<v(B $(C@V557O(B $(CGO1b(B $(C@'(B +$(CGQ(B $(C0M@T4O4Y(B. + + + $(C$^8U@z(B, $(CH-@O(B $(C<S@;(B $(C@L5?GO?)(B $(C0!4B(B $(C9f9}@;(B $(C>K(B $(CGJ?d0!(B $(C@V=@4O4Y(B. C-v +$(C?!(B $(C@GGO?)(B $(C>U@87N(B $(CAxG`GO4B(B $(C0M@:(B $(C@L9L(B $(C>K>R=@4O4Y(B. $(C?x7!@G(B $(C@Z8.7N(B $(C5G59>F(B +$(C0!4B5%4B(B, ESC v $(C8&(B $(CE8@LGAGU4O4Y(B. + + >> ESC v $(C?M(B C-v $(C8&(B $(C;g?kGO?)(B, $(C@|HD7N(B $(C@L5?GO4B(B $(C0M@;(B $(C8n9x(B $(C=C55GO?)(B + $(C:8<<?d(B. + +$(C?d>`(B +==== + $(CH-@O@;(B $(CH-8i4\@'7N(B $(C:80m(B $(C0!4B5%4B(B, $(C4Y@=@G(B $(C8m7I>n8&(B $(C;g?kGU4O4Y(B. + + C-v $(C>U@87N(B $(CGQ(B $(CH-8i:P(B $(CAxG`GQ4Y(B + ESC v $(C5Z7N(B $(CGQ(B $(CH-8i:P(B $(C5G59>F0#4Y(B + C-l $(CH-8i@;(B $(C4Y=C>44Y(B. $(C@L(B $(C6'(B, $(C?x7!(B $(CD?<-0!(B $(C@V>z4x(B $(CG`@L(B + $(CH-8i@G(B $(CA_>S?!(B $(C?@557O(B $(CGQ4Y(B + + >> $(CAv1](B $(CD?<-0!(B $(C>n5p?!(B $(C@V4B0!(B, $(C1W(B $(C1YC3?!(B $(C>n62(B $(CEX=:F.0!(B $(C=aA.(B $(C@V4B(B + $(C0!8&(B $(C1b>oGO<<?d(B. C-l $(C8&(B $(CE8@LGAGO0m(B, $(CD?<-0!(B $(C>n5p7N(B $(C@L5?GO?44B(B + $(C0!(B, $(C1W(B $(C1YC3@G(B $(CEX=:F.4B(B $(C>n6;0T(B $(C5G>z4B0!8&(B $(CA6;gGO?)(B $(C:8<<?d(B. + +$(C1b:;@{@N(B $(CD?<-@G(B $(CA&>n(B +====================== + + $(CH-8i4\@'@G(B $(C@L5?@:(B $(CGR(B $(C<v(B $(C@V0T(B $(C5G>z=@4O4Y(B. $(C@LA&4B(B, $(CH-8i(B $(C3;?!<-(B, $(CF/(B +$(CA$@G(B $(C@e<R7N(B $(C@L5?GO1b(B $(C@'GQ(B $(C9f9}@;(B $(C@MH|=C4Y(B. $(C@L0M?!4B(B $(C8n0!Av@G(B $(C9f9}@L(B $(C@V(B +$(C=@4O4Y(B. $(CGQ0!Av(B $(C9f9}@:(B, $(C@|(B(previous)$(CHD(B(next)$(C>U(B(forward)$(C5Z(B(backward)$(C7N(B +$(C@L5?GO4B(B $(C8m7I>n8&(B $(C;g?kGO4B(B $(C0M@T4O4Y(B. $(C@L5i@G(B $(C8m7I>n4B(B $(C0"0"(B, C-p, C-n, +C-f, C-b $(C?!(B $(CGR4g5G>n(B $(C@V0m(B, $(CGv@g@G(B $(C@e<R7N:NEM(B $(C;u7N?n(B $(C@e<R7N(B $(CD?<-8&(B $(C@L5?(B +$(C=CE54O4Y(B. $(C1W82@87N(B $(C1W8.8i(B, + + + $(C@L@|@G(B $(CG`(B, C-p + : + : + $(C5Z@G(B $(C9.@Z(B, C-b .... $(CGv@g@G(B $(CD?<-@'D!(B .... $(C@|9f@G(B $(C9.@Z(B, C-f + : + : + $(C4Y@=(B $(CG`(B, C-n + + + $(C@L5i@:(B, $(C0"0"(B, Previous, Next, Backward, Forward $(C@G(B $(C8S8.9.@Z7N(B $(C5G(B +$(C>n(B $(C@V@89G7N(B, $(C?\?l1b(B $(C=,?o(B $(C0M@T4O4Y(B. $(C@L5i@:(B, $(C1b:;@{@N(B $(CD?<-@L5?(B $(C8m7I>n@L0m(B +, $(C@ZAV(B $(C;g?kGO4B(B $(C0M@T4O4Y(B. + + >> C-n $(C@;(B $(C8nH8A$55(B $(CE8@LGAGO0m(B, ($(CAv1](B, $(C4g=E@L(B $(C@P0m(B $(C@V4B(B) $(C@L(B $(CG`1n(B + $(CAv(B $(CD?<-8&(B $(C@L5?=CE0<<?d(B. + + >> C-f $(C8&(B $(C;g?kGO?)(B $(CG`@G(B $(CA_0#A$557N(B $(C@L5?GO0m(B, C-p $(C@87N(B $(C8nG`A$55(B + $(C@'7N(B $(C@L5?GO?)(B $(C:8<<?d(B. $(CD?<-@'D!@G(B $(C:/H-?!(B $(CAV@GGO<<?d(B. + + >> $(CG`@G(B $(C<15N?!<-(B C-b $(C8&(B $(CE8@LGAGO?)(B $(C:8<<?d(B. $(CD?<-4B(B $(C>n5p7N(B $(C@L5?GU(B + $(C4O1n(B? $(C4Y=C(B $(CA61](B $(C4u(B C-b $(C8&(B $(CE8@LGAGO0m(B, $(C@L9x@:(B C-f $(C7N(B $(CG`3!(B $(CBJ(B + $(C@87N(B $(C5G59>F0!<<?d(B. $(CD?<-0!(B $(CG`3!@;(B $(C3Q@88i(B $(C>n6;0T(B $(C5K4O1n(B? + + + $(CH-8i@G(B $(C<15N3*(B $(C8;9L8&(B $(C3Q>n<-(B $(CD?<-8&(B $(C@L5?=CE07A0m(B $(CGO8i(B, $(C1W(B $(C9fGb?!(B +$(C@V4B(B $(CEX=:F.0!(B $(C@L5?GO?)(B $(C?@0m(B, $(CD?<-4B(B $(CGW;s(B $(CH-8i3;?!(B $(C@V557O(B $(C5K4O4Y(B. + + >> C-n $(C@;(B $(C;g?kGO?)(B, $(CD?<-8&(B $(CH-8i@G(B $(CGO4\:84Y(B $(C9X@87N(B $(C@L5?=CDQ(B $(C:8<<(B + $(C?d(B. $(C9+>y@L(B $(C@O>n334O1n(B? $(CD?<-@G(B $(C@'D!4B(B $(C>n6;0T(B $(C:/GO?4=@4O1n(B? + + $(CGQ9.@Z(B $(C4\@'@G(B $(C@L5?@87N4B(B $(C9x0E7S4Y0m(B $(C;}0"5G8i(B, $(C4\>n4\@'7N(B $(C@L5?GR(B +$(C<v55(B $(C@V=@4O4Y(B. ESC f $(C7N(B $(CGQ(B $(C4\>n:P(B $(C>U@87N(B $(CAxG`GO0m(B, ESC b $(C7N(B $(CGQ(B $(C4\>n:P(B +$(C@L@|@87N(B $(C5G59>F0)4O4Y(B. + +$(CAV@G(B: $(C@O:;>n?!(B $(C4kGX<-4B(B, $(C4\>n@G(B $(C2w4B(B $(C4\@'@;(B $(C@N=DGR(B $(C<v(B $(C>x=@4O(B + $(C4Y88(B, $(C@G;g@{@N(B $(C9.@}@;(B $(C4\>n@G(B $(C2w4B(B $(C4\@'7N<-(B $(CGO0m(B $(C@V=@4O(B + $(C4Y(B. + + >> ESC f $(C3*(B ESC b $(C8&(B $(C8nH8A$55(B $(CE8@LGAGO?)(B $(C:8<<?d(B. C-f $(C3*(B C-b $(C?M(B + $(C:4?kGO?)(B $(C:8<<?d(B. + + C-f $(C3*(B C-b $(C?!(B $(C4kGQ(B, ESC f $(C3*(B ESC b $(C@G(B $(C@/;g<:?!(B $(CAV8qGO<<?d(B. $(C4k:N:P(B +$(C@G(B $(C0f?l(B, ESC <$(C9.@Z(B>$(C4B(B $(C9.<-0|0h@G(B $(CC38.?!(B $(C;g?k5G0m(B, $(CGQFm(B C-<$(C9.@Z(B>$(C4B(B $(C1W0M(B +$(C:84Y55(B $(C4u?m(B $(C1b:;@{@N(B $(C4k;s(B($(C9.@Z6s5g0!(B $(CG`@L6s5g0!(B)$(C?!(B $(C4kGQ(B $(CA6@[?!(B $(C;g?k5K(B +$(C4O4Y(B. + + C-a $(C?M(B C-e $(C55(B $(C>K0m(B $(C@V@88i(B $(CFm8.GQ(B $(C8m7I>n@T4O4Y(B. C-a $(C4B(B $(CD?<-8&(B $(CG`@G(B +$(C<15N7N(B $(C@L5?=CE00m(B, C-e $(C4B(B $(CG`@G(B $(C3!@87N(B $(C@L5?=CE54O4Y(B. + + >> C-a $(C8&(B 2$(CH8(B, $(C1W8.0m3*<-(B C-e $(C8&(B 2$(CH8(B $(C@T7BGO?)(B $(C:8<<?d(B. $(C@L5i@G(B $(C8m(B + $(C7I>n8&(B 2$(CH8@L;s(B $(C9]:9GO4u6s55(B, $(CD?<-4B(B $(C1W(B $(C@L;s(B $(C@L5?GOAv(B $(C>J4B(B $(C0M(B + $(C?!(B $(CAV@G(B. + + $(C5N0!Av(B $(C4u(B, $(C0#4\GQ(B $(CD?<-(B $(C@L5?(B $(C8m7I>n0!(B $(C@V=@4O4Y(B. $(CH-@O@G(B $(C<15N7N(B $(C@L5?(B +$(CGO4B(B ESC < $(C?M(B, $(CH-@O@G(B $(C3!@87N(B $(C@L5?GO4B(B ESC > $(C@T4O4Y(B. + + $(CEX=:F.(B $(C3;?!<-(B, $(CD?<-0!(B $(CA8@gGO4B(B $(C@'D!8&(B "$(CFw@NF.(B"$(C6s0m(B $(C:N8(4O4Y(B. $(C9Y2Y(B +$(C>n(B $(C8;GO8i(B, $(CD?<-4B(B, $(CEX=:F.@G(B $(C>n5p?!(B $(C@V4B0!8&(B $(CH-8i@'?!(B $(C3*E83;0m(B $(C@V4B(B $(C0M(B +$(C@T4O4Y(B. + + $(C>F7!?!(B $(C4\<xGQ(B $(C@L5?A6@[?!(B $(C4kGX<-(B $(C?d>`GU4O4Y(B. $(C@L(B $(CA_?!4B(B, $(C4\>n3*(B $(CG`(B +$(C4\@'7N@G(B $(C@L5?8m7I>n55(B $(CFwGT5G>n(B $(C@V=@4O4Y(B. + + C-f $(CGQ(B $(C9.@Z(B $(C>U@87N(B $(CAxG`GQ4Y(B + C-b $(CGQ(B $(C9.@Z(B $(C5Z7N(B $(C5G59>F0#4Y(B + + ESC f $(CGQ(B $(C4\>n(B $(C>U@87N(B $(CAxG`GQ4Y(B + ESC b $(CGQ(B $(C4\>n(B $(C5Z7N(B $(C5G59>F0#4Y(B + + C-n $(C4Y@=(B $(CG`@87N(B $(C@L5?(B + C-p $(C@L@|(B $(CG`@87N(B $(C@L5?(B + + ESC ] $(C4\6t@G(B $(C3!@87N(B $(C@L5?(B + ESC [ $(C4\6t@G(B $(C<15N7N(B $(C@L5?(B + + C-a $(CG`@G(B $(CCVCJ7N(B $(C@L5?(B + C-e $(CG`@G(B $(CCVHD7N(B $(C@L5?(B + + ESC < $(CH-@O@G(B $(CCVCJ7N(B $(C@L5?(B + ESC > $(CH-@O@G(B $(CCVHD7N(B $(C@L5?(B + + >> $(C0"0"@G(B $(C8m7I>n8&(B $(C=C55GO?)(B $(C:8<<?d(B. $(C@L5i@G(B $(C8m7I>n4B(B, $(C0!@e(B $(C@ZAV(B + $(C;g?k5G4B(B $(C0M@T4O4Y(B. $(CCVHD@G(B $(C5N0!Av4B(B, $(C@L(B $(C@e<R?M4B(B $(C63>nAx(B $(C0w@8(B + $(C7N(B $(C@L5?GO1b(B $(C6'9.?!(B, C-v $(C3*(B ESC v $(C8&(B $(C;g?kGO?)(B $(C?)1b7N(B $(C5G59>F(B + $(C?@557O(B $(CGO<<?d(B. + + Emacs$(C@G(B $(C4Y8%(B $(C8m7I?M(B $(C6H00@L(B, $(C@L5i@G(B $(C8m7I>n?!4B(B, $(C9]:9H8<v8&(B $(CAvA$GO(B +$(C4B(B $(C@N<v8&(B $(CAY(B $(C<v(B $(C@V=@4O4Y(B. $(C@L8&(B $(C@'GX<-4B(B, $(C8m7I>n8&(B $(C@T7BGO1b(B $(C@|?!(B, C-u +$(C?!(B $(C@L>n<-(B $(C9]:9GO4B(B $(CH8<v8&(B $(C@T7BGU4O4Y(B. + + $(CNc?98&(B $(C5i8i(B, C-u 8 C-f $(C6s0m(B $(CGO8i(B, 8$(C9.@Z:P(B $(C>U@87N(B $(C@L5?GU4O4Y(B. + + >> C-n $(CH$@:(B C-p $(C?!(B $(C@{4gGQ(B $(C@N<v8&(B $(CAvA$GO0m(B, $(C@OH8@G(B $(C@L5?@87N(B $(C0!4I(B + $(CGQGQ(B, $(C@L(B $(CG`@G(B $(C1YC3?!(B $(C?@557O(B $(CGO?)(B $(C:8<<?d(B. + + C-v $(C3*(B ESC v $(C?!(B $(C4kGX<-4B(B $(CA61](B $(C4Y8(4O4Y(B. $(C@L(B $(C0f?l(B, $(CAvA$5H(B $(C<v@G(B $(CG`88(B +$(CH-8i@;(B $(C@L5?GO4B(B $(C0M@L(B $(C5K4O4Y(B. + + >> C-u 3 C-v $(C6s0m(B $(C@T7BGO?)(B $(C:8<<?d(B. + + $(C?x7!(B $(C@Z8.7N(B $(C5G59>F0!4B5%4B(B, C-u 3 ESC v $(C8&(B $(C;g?kGO8i(B $(C5K4O4Y(B. + +$(CA_Av8m7I>n(B +========== + + C-g $(C6s4B(B $(C8m7I>n@L8g(B, $(C@T7B@;(B $(CGJ?d7N(B $(CGO4B(B $(C0M0z(B $(C00@:(B $(C8m7I>n8&(B $(CA_AvGR(B +$(C<v(B $(C@V=@4O4Y(B. $(C?98&(B $(C5i8i(B, $(C@N<v8&(B $(C@T7BGO0m(B $(C@V4B(B $(C55A_@L3*(B, 2$(C03(B $(C@L;s@G(B $(CE0@T(B +$(C7B@;(B $(CGJ?d7N(B $(CGO4B(B $(C8m7I>n8&(B $(CGQC"(B $(C@T7BGO0m(B $(C@V4B(B $(C55A_?!(B, $(C1W0M@;(B $(CA_AvGO0m(B $(C=M(B +$(C@88i(B, C-g $(C8&;g?kGO8i(B $(C5K4O4Y(B. + + >> C-u 100 $(C8&(B $(CE8@LGAGO?)(B $(C@N<v8&(B 100$(C@87N(B $(C<3A$GO0m(B, C-g $(C8&(B $(CE8@LGA(B + $(CGO<<?d(B. $(C1W(B $(C5Z?!(B C-f $(C8&(B $(CE8@LGAGO?)(B $(C:8<<?d(B. $(C8n9.@Z(B $(C@L5?GO?4=@(B + $(C4O1n(B? $(C88>`(B, $(C@_8xGO?)(B ESC $(C8&(B $(C@T7BGX(B $(C9v7H@;(B $(C6'55(B, C-g $(C8&(B $(C@T7BGO(B + $(C8i(B $(CCk<R=CE3(B $(C<v(B $(C@V=@4O4Y(B. + +$(C?!7/(B +==== + + $(C6'7N4B(B, Emacs$(C?!<-(B $(CGc?k5G0m(B $(C@VAv(B $(C>J4B(B $(CA6@[@;(B $(CGX9v8.4B(B $(C@{@L(B $(C@V=@4O(B +$(C4Y(B. $(C?98&(B $(C5i8i(B, $(C8m7I>n0!(B $(CA$@G5G>n(B $(C@VAv(B $(C>J4B(B $(CD\F.7Q(B*$(CE08&(B $(C@T7BGX(B $(C9v80(B $(C6'(B +$(C?!4B(B, Emacs$(C4B(B $(C:'@;(B $(C?o8.0m(B, $(C1W8.0m(B, $(CH-8i@G(B $(CA&@O(B $(C9X?!(B, $(C9+>y@L(B $(C3*;&4B(B $(C0!(B +$(C8&(B $(CG%=CGU4O4Y(B. + + Emacs $(C9vA/?!(B $(C5{6s<-4B(B, $(C@L(B $(C@T9.Fm?!(B $(C>2?)A.(B $(C@V4B(B $(C0M@;(B $(C=GG`GR(B $(C<v(B $(C>x(B +$(C4B(B $(C0f?l0!(B $(C@V@;(B $(C<v(B $(C@V=@4O4Y(B. $(C1W?M(B $(C00@:(B $(C0f?l?!4B(B, $(C?!7/8^<<Av0!(B $(CG%=C5G9G(B +$(C7N(B, $(C>n4@(B $(C0M@N0!(B $(C@L5?E08&(B $(C4)8#0m(B, $(C1W(B $(C4Y@=@G(B $(C:N:P@87N(B $(CAxG`GO?)(B $(CAV<<?d(B. + +$(C@)55?l(B +====== + + Emacs$(C4B(B $(C8n03@G(B $(C@)55?l8&(B $(C0!Av4B(B $(C0M0z(B, $(C1W(B $(C0"0"?!(B $(C4kGO?)(B $(CEX=:F.8&(B $(CG%(B +$(C=CGR(B $(C<v(B $(C@V=@4O4Y(B. $(CGoGA3*(B, $(C8n0!Av@G(B $(C8m7I>n7N:NEM@G(B $(CCb7B@;(B $(CG%=CGO1b(B $(C@'GO(B +$(C?)(B $(C3*E83-(B $(C?):P@G(B $(C@)55?l8&(B $(CAv?l1b(B $(C@'GO?)(B, $(C4Y@=@G(B $(C8m7I>n8&(B $(C>K(B $(CGJ?d0!(B $(C@V=@(B +$(C4O4Y(B. + + C-x 1 $(C@)55?l8&(B 1$(C037N(B $(CGQ4Y(B. + + C-x 1 $(C4B(B, $(C4Y8%(B $(C@)55?l8&(B $(CAv?l0m(B, $(CD?<-0!(B $(C@V4B(B $(C@)55?l8&(B, $(CH-8i@|C<7N(B +$(CH.@eGU4O4Y(B. + + >> $(CD?<-8&(B $(C@L(B $(CG`?!(B $(C0.0m(B $(C?M<-(B, C-u 0 C-l $(C@L6s0m(B $(CE8@LGAGU4O4Y(B. + + >> C-h k C-f $(C6s0m(B $(CE8@LGAGO<<?d(B. $(C;u7N?n(B $(C@)55?l0!(B C-f $(C8m7I>n@G(B $(C55(B + $(CE%8UF.8&(B $(CG%=CGO1b(B $(C@'GO?)(B $(C3*E8320z(B $(C5?=C?!(B, $(C@L(B $(C@)55?l0!(B $(C>n6;0T(B + $(CAY>n5e4B0!(B $(C0|B{GO<<?d(B. + + >> C-x 1$(C@L6s0m(B $(CE8@LGAGO0m(B, $(C55E%8UF.0!(B $(C3*E8354x(B $(C@)55?l8&(B $(CAv?l<<(B + $(C?d(B. + +$(C;p@T0z(B $(C;hA&(B +=========== + + $(CEX=:F.8&(B $(CE8@LGAGO0m(B $(C=M@88i(B, $(C4\<xHw(B $(C1W0M@;(B $(CE8@LGAGO4B(B $(C0M88@87N(B $(C1&(B +$(CBz=@4O4Y(B. $(C4+?!(B $(C:8@L4B(B $(C9.@Z(B ('A','7','*','$(C$"(B'$(C5n(B)$(C@:(B Emacs$(C?!(B $(C@GGO?)(B $(CEX=:(B +$(CF.6s0m(B $(C0#AV5G0m(B,$(C1W4k7N(B $(C;p@T5K4O4Y(B. $(CG`@G(B $(C3!@:(B $(C03G`9.@Z7N(B $(C3*E83*0m(B, $(C@L(B +$(C0M@;(B $(C@T7BGO4B5%4B(B<Return> $(C@;(B $(CE8@LGAGU4O4Y(B. + + $(CAw@|?!(B $(C@T7BGQ(B $(C9.@Z8&(B $(C;hA&GO4B5%4B(B, <Delete> $(C8&(B $(C@T7BGU4O4Y(B. +<Delete> $(C4B(B,$(CE0:85e?!<-(B "Delete"$(C6s0m(B $(C=a@V4B(B $(CE08&(B $(C4-7/<-(B $(C@T7BGU4O4Y(B. +"Delete" $(C4k=E?!(B"Rubout"$(C6s0m(B $(C=a@V@;(B $(CAv55(B $(C8p8(4O4Y(B. $(C:84Y(B $(C@O9]@{@87N(B, +<Delete> $(C4B(B, $(CGv@gD?<-0!(B $(C@V4B(B $(C@'D!@G(B $(CAw@|@G(B $(C9.@Z8&(B $(C;hA&GU4O4Y(B. + + >> $(C9.@Z8&(B $(C8n03A$55(B $(CE8@LGAGO0m(B, $(C1W8.0m3*<-(B $(C1W0M@;(B <Delete> $(C8&(B $(C;g(B + $(C?kGO?)(B $(C;hA&GO<<?d(B. + + >> $(C?@8%BJ86Ax@;(B $(C3Q@;(B $(C6'1nAv(B $(CEX=:F.8&(B $(CE8@LGAGO<<?d(B. $(CEX=:F.0!(B $(CGQ(B + $(CG`@G(B $(CFx(B $(C@L;s@87N(B $(C1f0T(B $(C5G8i(B, $(C1W(B $(CG`@:(B $(CH-8i@87N:NEM(B $(C:q>nA.3*?M(B + "$(C0h<S(B"$(C5K4O4Y(B. $(C?l4\?!(B $(C@V4B(B '\'$(C1bH#4B(B, $(C1W(B $(CG`@L(B $(C0h<S5G0m(B $(C@V4B(B + $(C0M@;(B $(C3*E83;0m(B $(C@V=@4O4Y(B. Emacs$(C4B(B, $(CGv@g(B $(CFmA}A_@G(B $(C@'D!0!(B $(C:8@L(B + $(C557O(B $(CG`@;(B $(C=:E)7QGU4O4Y(B. $(CH-8i@G(B $(C?@8%BJ(B $(CH$@:(B $(C?^BJ@G(B $(C3!?!(B $(C@V4B(B + '\'$(C1bH#4B(B, $(C1W(B $(C9fGb?!(B $(CG`@L(B $(C>FAw(B $(C@L>nAv0m(B $(C@V4B(B $(C0M@;(B $(C3*E83;0m(B + $(C@V=@4O4Y(B. + + $(C@L0M@:(B, $(C1[7N(B $(C<38mGO4B(B $(C0M:84Y(B $(C=GA&7N(B $(CGX:84B(B $(CFm@L(B $(C@_(B $(C>K(B $(C<v(B $(C@V0ZAv?d(B. + + >> $(CA61]@|(B $(C@T7BGQ(B, $(C0h<S5H(B $(CG`@G(B $(C@'?!(B $(CD?<-8&(B $(C0.0m0!<-(B, C-d $(C7N(B $(CEX(B + $(C=:F.8&(B $(C;hA&GO0m(B, $(CEX=:F.0!(B $(CGQG`?!(B $(C5i>n0!557O(B $(CGX:8<<?d(B. $(C0h<S@;(B + $(C3*E83;4B(B '\'$(C1bH#4B(B $(CAv?vA3Av?d(B? + + >> $(CD?<-8&(B $(CG`@G(B $(C<15N7N(B $(C@L5?GO0m(B, <Delete> $(C8&(B $(C@T7BGO<<?d(B. $(C@L0M@:(B + $(C1W(B $(CG`@G(B $(CAw@|@G(B $(CG`(B $(C4\6tAv@=@;(B $(C;hA&GO9G7N(B, $(C1W(B $(CG`@L(B $(C>U@G(B $(CG`0z(B + $(C@L>nA.(B $(C9v834O4Y(B. $(C@L>nAx(B $(CG`@L(B $(CH-8i@G(B $(CFx:84Y(B $(C1f0T(B $(C5G8i(B, $(C0h<S(B + $(CG%=C0!(B $(C5G0ZAv?d(B. + + >> <Return> $(C8&(B $(C4)8#0m(B, $(CGQ9x(B $(C4u(B $(CG`4\6tAv@=@;(B $(C;p@TGO<<?d(B. + + Emacs$(C@G(B $(C4k:N:P@G(B $(C8m7I>n4B(B, $(C9]:9(B $(CH8<v8&(B $(CAY(B $(C<v(B $(C@V=@4O4Y(B. $(C@L0M@:(B, $(C9.(B +$(C@Z(B $(C;p@T?!(B $(C4kGX<-55(B $(C@{?k5K4O4Y(B. + + >> C-u 8 * $(C6s0m(B $(C@T7BGO?)(B $(C:8<<?d(B. $(C>n6;0T(B $(C5G>z=@4O1n(B? + + $(C5N03@G(B $(CG`(B $(C;g@L?!(B $(C0x9iG`@;(B $(C885i0m(B $(C=M@:(B $(C0f?l?!4B(B, $(C5N9xB0(B $(CG`@G(B $(C<15N(B +$(C7N(B $(C0!<-(B, C-o $(C8&(B $(C@T7BGU4O4Y(B. + + >> $(C@{4gHw(B $(CG`@G(B $(C<15N?!(B $(C0!<-(B, $(C0E1b<-(B C-o $(C8&(B $(C@T7BGO?)(B $(C:8<<?d(B. + + $(C@L0M@87N(B, Emacs$(C?!<-(B, $(CEX=:F.8&(B $(C@T7BGO0m(B, $(C6GGQ(B $(CF280(B $(C0M@;(B $(C<vA$GO4B(B +$(C0!@e(B $(C1b:;@{@N(B $(C9f9}@;(B $(C9h?n(B $(C0M@L(B $(C5G>z=@4O4Y(B. $(C9.@Z?M(B $(C00@L(B, $(C4\>n3*(B $(CG`55(B +$(C;hA&GR(B $(C<v(B $(C@V=@4O4Y(B. $(C;hA&A6@[?!(B $(C4kGX<-(B $(C?d>`GO8i(B $(C4Y@=0z(B $(C00=@4O4Y(B. + + <Delete> $(CD?<-Aw@|@G(B $(C9.@Z8&(B $(C;hA&(B + C-d $(CD?<-0!(B $(C@V4B(B $(C9.@Z8&(B $(C;hA&(B + + ESC <Delete> $(CD?<-Aw@|@G(B $(C4\>n8&(B $(C;hA&(B + ESC d $(CD?<-@'D!(B $(C@LHD?!(B $(C@V4B(B $(C4\>n8&(B $(C;hA&(B + + C-k $(CD?<-@'D!7N:NEM(B $(CG`3!1nAv8&(B $(C;hA&(B + + $(C9+>y@N0!8&(B $(C;hA&GQ(B $(CHD?!(B, $(C1W0M@;(B $(C?x7!4k7N(B $(C5G598.0m(B $(C=M@;(B $(C6'0!(B $(C@V=@4O(B +$(C4Y(B. Emacs$(C4B(B, $(CGQ9.@Z:84Y(B $(CE+(B $(C4\@'7N(B $(C;hA&8&(B $(CG`GQ(B $(C6'?!4B(B, $(C;hA&GQ(B $(C3;?k@;(B +$(C:8A8GO?)(B $(C5S4O4Y(B. $(C?x7!4k7N(B $(C5G598.4B5%4B(B, C-y $(C8&(B $(C;g?kGU4O4Y(B. $(CAV@GGX>_(B +$(CGO4B(B $(C0M@:(B, C-y $(C8&(B $(C;hA&8&(B $(CG`GQ(B $(C@e<R88@L(B $(C>F4O6s(B, $(C>n5p?!<-6s55(B $(CGR(B $(C<v(B $(C@V4Y(B +$(C4B(B $(C0M@T4O4Y(B. C-y $(C4B(B, $(C:8A85H(B $(CEX=:F.8&(B $(CGv@g(B $(CD?<-0!(B $(C@V4B(B $(C@e<R?!(B $(C;p@TGO1b(B +$(C@'GQ(B $(C8m7I>n@L9G7N(B, $(C@L0M@;(B $(C;g?kGO?)(B $(CEX=:F.8&(B $(C@L5?GR(B $(C<v(B $(C@V=@4O4Y(B. + + $(C;hA&8&(B $(CG`GO4B(B $(C8m7I>n?!4B(B, "Delete" $(C8m7I>n?M(B, "Kill" $(C8m7I>n0!(B $(C@V=@(B +$(C4O4Y(B. "Kill" $(C8m7I>n?!<-4B(B $(C;hA&5H(B $(C0M@:(B $(C:8A85GAv88(B, "Delete"$(C?!<-4B(B $(C:8A8(B +$(C5GAv(B $(C>J=@4O4Y(B. $(C4\(B, $(C9]:9H8<v0!(B $(CAV>nAv8i(B, $(C:8A85K4O4Y(B. + + >> C-n $(C@;(B 2$(CH8(B $(CA$55(B $(CE8@LGAGO0m(B, $(CH-8i@G(B $(C@{4gGQ(B $(C@e<R7N(B $(C@L5?GO<<?d(B. + $(C1W8.0m(B, C-k $(C7N(B, $(C1W(B $(CG`@;(B $(C;hA&GO<<?d(B. + + $(CC99xB0@G(B C-k $(C7N(B $(C1W(B $(CG`@G(B $(C3;?k@L(B $(C;hA&5G0m(B, $(CGQ9x4u(B C-k $(C8&(B $(C@T7BGO8i(B, +$(C1W(B $(CG`(B $(C@Z=E@L(B $(C;hA&5K4O4Y(B. $(C88>`(B, C-k $(C?!(B $(C9]:9H8<v8&(B $(CAvA$GQ(B $(C0f?l?!4B(B, $(C1W(B +$(CH8<v88E-@G(B $(CG`@L(B($(C3;?k0z(B $(CG`@Z=E0!(B $(C5?=C?!(B)$(C;hA&5K4O4Y(B. + + $(CAv1](B $(C;hA&5H(B $(CEX=:F.4B(B, $(C:8A85G0m(B $(C@V@89G7N(B, $(C1W0M@;(B $(C2t3>(B $(C<v(B $(C@V=@4O4Y(B. +$(C@L8&(B $(C@'GX<-4B(B, C-y $(C8&(B $(CE8@LGAGU4O4Y(B. + + >> C-y $(C8&(B $(C=CGhGO?)(B $(C:8<<?d(B. + + C-k $(C8&(B $(C8n9x@L3*(B $(C0h<SGO?)(B $(CG`GO8i(B, $(C;hA&5H(B $(CEX=:F.4B(B, $(CA$8.5G>n(B $(C:8A85G(B +$(C0m(B, C-y$(C7N(B, $(C1W(B $(C@|:N0!(B $(C2t3;>nA}4O4Y(B. + + >> C-k $(C8&(B $(C8n9x(B $(CE8@LGAGO?)(B $(C:8<<?d(B. + + >> $(CEX=:F.8&(B $(C2t3;4B5%4B(B, C-y $(C@T4O4Y(B. $(CD?<-8&(B $(C8nG`(B $(C9X@87N(B $(C@L5?=CE0(B + $(C0m(B, $(CGQ9x(B $(C4u(B C-y $(C8&(B $(CE8@LGAGO?)(B $(C:8<<?d(B. $(C@L0M@87N(B $(CEX=:F.@G(B $(C:9;g(B + $(C0!(B $(C5K4O4Y(B. + + $(CGv@g(B $(C>n62(B $(CEX=:F.0!(B $(C:8A85G>n(B $(C@V0m(B, $(C4u183*(B $(C4Y8%(B $(CEX=:F.8&(B $(C;hA&GO8i(B +$(C>n6;0T(B $(C5G0Z=@4O1n(B? C-y$(C4B(B, $(C0!@e(B $(CCV1Y(B $(C;hA&5H(B $(C0M@;(B $(C2tA}>n3@4O4Y(B. + + >> $(CG`@;(B $(C;hA&GO0m(B, $(CD?<-8&(B $(C@L5?=CE00m(B, $(C4Y8%(B $(CG`@;(B $(C;hA&GO<<?d(B. C-y + $(C8&(B $(CG`GO8i(B, 2$(C9xB0@G(B $(CG`@L(B $(C3*?I4O4Y(B. + +$(CCk<R(B(UNDO) +========== + + $(C>pA&6s55(B, $(CEX=:F.8&(B $(C:/0fGO?4Av88(B, $(C1W0M@;(B $(C?x7!4k7N(B $(C5G598.0m(B $(C=M@;(B $(C6'(B +$(C4B(B C-x u$(C7N(B $(C0mD(4O4Y(B. $(C:8Ek@:(B $(C@_8x5H(B $(C8m7I>n8&(B $(C9+H?7N(B $(CGO4B(B $(C@[5?@;(B $(CGU4O4Y(B. +$(C9]:9GX<-(B UNDO$(C8&(B $(CG`GO7A0m(B $(CGR(B $(C6'4B(B, $(C8n9x@L3*(B $(C1W(B $(C8m7I>n8&(B $(CG`GO8i(B $(C5G557O(B +$(C5G>n(B $(C@V=@4O4Y(B. + + >> $(C@L(B $(CG`@;(B C-k$(C7N(B $(CAv?l<<?d(B. $(C1W8.0m(B, C-x u$(C7N(B $(C5G598.<<?d(B. + + C-_$(C4B(B, UNDO$(C8&(B $(CG`GO4B(B, $(C6G(B $(CGO3*@G(B $(C8m7I>n@T4O4Y(B. $(C1b4I@:(B, C-x u$(C?M(B $(C00(B + $(C=@4O4Y(B. + + C-_$(C3*(B C-x u$(C?!(B UNDO$(C@G(B $(CH8<v8&(B $(CAY(B $(C<v(B $(C@V=@4O4Y(B. + + +$(CH-@O(B +==== + + $(CEX=:F.@G(B $(C:/0f@;(B $(C?518@{@87N(B $(CGO1b(B $(C@'GX<-4B(B, $(C1W0M@;(B $(CH-@O?!(B $(C:8A8GO?)(B +$(C>_(B $(CGU4O4Y(B. $(C:8A8GOAv(B $(C>J@88i(B, $(CG`GQ(B $(C:/0f@:(B, Emacs$(C8&(B $(CA>7aGO8i(B $(C5?=C?!(B $(C@R>n(B +$(C9v8.0T(B $(C5K4O4Y(B. + + $(CAv1](B $(C:80m(B $(C@V4B(B $(CH-@O?!(B $(C4kGX<-(B, $(C4g=E@L(B $(CFmA}@;(B $(CG`GQ(B $(C0M@;(B $(C=a3V=@4O4Y(B. +$(CAv1](B, $(C:80m(B $(C@V4B(B $(CH-@O@L6u(B $(C0M@:(B, $(C0#4\Hw(B $(C8;GO8i(B $(CFmA}GO0m(B $(C@V4B(B $(CH-@O(B $(C@ZC<@T(B +$(C4O4Y(B. + + $(C4g=E@L(B $(CH-@O@;(B $(C<<@L:j(B($(C:8A8GQ4Y(B)$(CGO1b(B $(C1nAv(B, $(CAv1]1nAv@G(B $(C:/0f@:(B $(CFmA}GO(B +$(C0m@V4B(B $(CH-@O?!(B $(C=a3V4B(B $(C0M@:(B $(C>F4U4O4Y(B. $(C1W0M@:(B, $(C4g=E@L(B $(C@L?M(B $(C00@L(B $(C:/0fGO0m(B +$(C=MAv(B $(C>J@:5%55(B, $(C55A_1nAv(B $(C:/0f@;(B $(C0!GQ(B $(C0M@L(B $(CA&8Z4k7N(B $(C=a3V>nAv4B(B $(C@O@L(B $(C>x55(B +$(C7O(B $(CGO1b(B $(C@'GX<-(B $(C@T4O4Y(B. + + $(C<<@L:j@;(B $(CG`GQ(B $(C5ZA6Bw(B $(C:/0fGQ(B $(C0M@L(B $(C@_8x(B $(C5G>n(B $(C@V@;(B $(C6'8&(B $(C@'GO?)(B Emacs +$(C4B(B $(C@L8'@;(B $(C:/0fGO?)(B $(C?x:;(B $(CH-@O@;(B $(C321i4O4Y(B. + +$(C:q0m(B: $(C6GGQ(B, Emacs$(C4B(B $(C?9CxGR(B $(C<v(B $(C>x4B(B $(C;sEB?!(B $(C4k:qGO?)(B, $(C@OA$GQ(B $(C=C(B + $(C0#0#0]@87N(B $(C@Z5?@{@87N(B $(CFmA}GO0m(B $(C@V4B(B $(CH-@O@G(B $(C3;?k@;(B $(C@L8'(B + $(C@;(B $(C:/0fGQ(B $(CH-@O?!(B $(C<<@L:jGU4O4Y(B. $(C@L0M?!(B $(C@GGX(B, $(C88@O@G(B $(C0f?l(B + $(C4B(B $(CG`GQ(B $(C:/0f?!(B $(C4kGO?)(B $(CCV<RGQ@G(B $(CGGGX7N(B $(C3!3;557O(B $(CGO0m(B $(C@V(B + $(C=@4O4Y(B. + + $(CH-8i@G(B $(C>F7!(B $(CBJ@;(B $(C:88i(B, $(C@L?M(B $(C00@:(B $(C6f@87N(B $(C8p5e6s@N@L(B $(CG%=C5G>n(B $(C@V4Y(B +$(C0m(B $(C;}0"GU4O4Y(B. + +($(C?9(B) [--]J:--**-Mule: MULE.tut (Fundamental) ---55%-------------- + + + $(C@L(B Emacs$(CF)Ed8.>s@G(B $(C:9;g:;@:(B MULE.tut$(C@L6s0m(B $(C:R8.0m(B $(C@V=@4O4Y(B. $(CH-@O(B +$(C@;(B $(CH-@N5e(B($(CH-@O@;(B $(CC#>F<-(B $(C9vF[?!(B $(C@P>n3V4B(B $(C0M(B)$(CGO8i(B, MULE.tut$(C@G(B $(C:N:P?!(B $(CG%=C(B +$(C5K4O4Y(B. $(C?98&(B $(C5i8i(B, new-file$(C@L6s4B(B $(C@L8'@G(B $(CH-@O@;(B $(CH-@N5eGO?44Y8i(B, "Mule: +new-file"$(C@L6s4B(B $(C8p5e6s@N@L(B $(C5G0ZAv?d(B. + +$(CAV@G(B: $(C8p5e6s@N?!(B $(C4kGX<-4B(B $(C3*A_?!(B $(C<38mGO0Z=@4O4Y(B. $(C@a1q(B $(C1b4Y8.=C(B + $(C1b8&(B. + + $(CH-@O@;(B $(CH-@N5eGO0E3*(B, $(C<<@L:jGO4B(B $(C8m7I>n4B(B, $(CAv1]1nAv@G(B $(C0M0z4B(B $(C4^8.(B, +2$(C03@G(B $(C9.@Z7N(B $(C5G>n(B $(C@V=@4O4Y(B. C-x $(C?!(B $(C@L>n<-(B $(C@T7BGO4B(B $(C9.@Z0!(B, $(CH-@O?!(B $(C4kGX(B +$(C<-(B $(CG`GO4B(B $(CA6@[@;(B $(C3*E83@4O4Y(B. + + $(CGQ0!Av(B $(C4u(B, $(CAv1]1nAv@G(B $(C0M0z(B $(C4Y8%(B $(CA!@:(B, $(CH-@N5e(B $(C=C(B, $(CH-@O8m@;(B Emacs$(C0!(B +$(C90>n:>4O4Y(B. $(C@L0M@;(B, $(C4\8;7N:NEM(B $(C@N<v8&(B $(C@P>n5i?)?@4B(B $(C8m7I>n6s0m(B $(C8;GO0m(B +$(C@V=@4O4Y(B. + + +$(CAV@G(B: $(C@L(B $(C0f?l4B(B $(CH-@O8m(B $(C@T4O4Y(B. + + C-x C-f $(CH-@O@;(B $(CC#4B4Y(B($(CH-@N5eGQ4Y(B) + + Emacs$(C4B(B $(CH-@O8m@;(B $(C90>n?I4O4Y(B. $(C@L0M@:(B, $(CH-8i9X@G(B $(CG`?!(B $(C3*E8334O4Y(B. +$(CH-@O8m@;(B $(CAvA$GO0m(B $(C@V4B(B $(C:N:P@:(B, $(C9L4O9vF[6s0m(B $(C:R8.?l4B(B $(C0M@T4O4Y(B. $(C9L4O9v(B +$(CF[4B(B $(C@L?M(B $(C00@L(B $(C;g?k5K4O4Y(B. $(CH-@O8m?!(B $(C@L>n<-(B, $(C8.4xE08&(B $(C4)8#8i(B, $(C9L4O9vF[(B +$(C?!(B $(CG%=C5G>nAx(B $(C3;?k@:(B $(C4u(B $(CGJ?dGOAv(B $(C>J1b(B $(C6'9.?!(B $(CAv?vA.(B $(C9v834O4Y(B. + + >> C-x C-f$(C6s0m(B $(CE8@LGAGQ(B $(C5Z?!(B C-g$(C6s0m(B $(CE8@LGAGO<<?d(B. $(C9L4O9vF[@G(B + $(C3;?k@;(B $(CCk<RGO0m(B, $(C6GGQ(B, C-x C-f$(C8m7I>n55(B $(CCk<RGU4O4Y(B. $(C@L780T(B + $(CGO?)(B, $(C>n62(B $(CH-@O55(B $(CC#Av(B $(C>J=@4O4Y(B. + + $(C@L9x?!4B(B $(CH-@O@;(B $(C<<@L:jGO?)(B $(C:8<<?d(B. $(CAv1]1nAv@G(B $(C:/0f@;(B $(C:8A8GO1b(B $(C@'(B +$(CGX<-4B(B $(C4Y@=0z(B $(C00@:(B $(C8m7I>n8&(B $(C;g?kGU4O4Y(B. + + C-x C-s $(CH-@O@;(B $(C<<@L:jGQ4Y(B + + Emacs$(C@G(B $(C3;?k@:(B $(CH-@O?!(B $(C=a3;>nA}4O4Y(B. $(C<<@L:jGR(B $(C6'(B, $(C?x:;@G(B $(CH-@O@:(B $(C;u(B +$(C7N?n(B $(C@L8'@;(B $(C:Y?)<-(B $(C320\Av1b(B $(C@V@89G7N(B $(C3;?k@:(B $(C>x>nAvAv(B $(C>J=@4O4Y(B. $(C@L(B $(C;u(B +$(C7N?n(B $(C@L8'@:(B $(C?x:;@G(B $(CH-@O@G(B $(C@L8'?!(B '~'$(C8&(B $(C:Y@N(B $(C0M@T4O4Y(B. + + $(C%;<<@L:j0!(B $(C3!3*8i(B, Emacs$(C4B(B $(C<<@L:jGQ(B $(CH-@O@G(B $(C@L8'@;(B $(CG%=CGU4O4Y(B. + + >> C-x C-s$(C6s0m(B $(CE8@LGAGO0m(B $(CF)Ed8.>s@G(B $(C:9;g:;@;(B $(C<<@L:jGO<<?d(B. + $(C@L(B $(C6'(B, $(CH-8i(B $(C9XBJ?!(B "Wrote ...../MULE.tut"$(C6s0m(B $(CG%=C5K4O4Y(B. + + $(C;u7N?n(B $(CH-@O@;(B $(C885i(B $(C6'(B, $(C86D!(B $(C@L@|:NEM(B $(C@V4x(B $(CH-@O@;(B $(CH-@N5eGO4B(B $(C5mGQ(B +$(C5?@[@;(B $(CGU4O4Y(B. $(C1W780T(B $(CGO?)(B, $(CH-@N5eGQ(B $(CH-@O?!(B $(CE8@LGAGO?)(B $(C0)4O4Y(B. + + $(C%UH-@O@;(B $(C<<@L:jGO7A0m(B $(CG_@;(B $(C4k(B $(C:q7N<R(B, Emacs$(C4B(B $(CAv1]1nAv(B $(CFmA}GO0m(B +$(C@V4x(B $(C3;?k@;(B $(CH-@O(B $(C3;?!(B $(C=a3V=@4O4Y(B. + + +$(C9vF[(B +==== + + $(C88>`(B, 2$(C9xB0@G(B $(CH-@O@;(B C-x C-f $(C7N(B $(C2(3;8i(B, 1$(C9xB0@G(B $(CH-@O@:(B Emacs$(C3;:N(B +$(C?!(B $(C32=@4O4Y(B. Emacs$(C3;:N?!(B $(C@V4B(B $(CH-@O7N:NEM(B $(CEX=:F.8&(B $(C@P>n3V>n(B $(C:8A8GO0m@V(B +$(C4B(B $(C0M@:(B $(C9vF[6s0m(B $(C:R8.?s4O4Y(B. $(CH-@O@;(B $(C2(3;4B(B $(C0M@:(B, Emacs$(C3;:N?!(B $(C;u7N?n(B +$(C9vF[8&(B $(C885l4O4Y(B. + + Emacs $(C3;?!(B $(C:8A8GO0m(B $(C@V4B(B $(C9vF[@G(B $(C8.=:F.8&(B $(C:84B5%4B(B, $(C4Y@=0z(B $(C00@L(B +$(CE8@LGAGU4O4Y(B. + + C-x C-b + + >> C-x C-b $(C6s0m(B $(CE8@LGAGO<<?d(B. $(C0"0"@G(B $(C9vF[0!(B $(C>n60GQ(B $(C@L8'@;(B $(C0.(B + $(C0m(B $(C@V4B0!(B, $(C1W8.0m(B, $(C>n60GQ(B $(CH-@O8m@;(B $(C:Y@L0m(B $(C@V4B(B $(C0M@N0!(B $(C0|B{(B + $(CGO<<?d(B. + + $(C9vF[?!4B(B $(CH-@O0z(B $(C@OD!GOAv(B $(C>J4B(B $(C0M55(B $(C@V=@4O4Y(B. $(C?98&(B $(C5i8i(B, "*Buffer +List*" $(C6s4B(B $(CH-@O@:(B $(C>x=@4O4Y(B. $(C@L0M@:(B C-x C-b $(C?!(B $(C@GGO?)(B $(C885i>nAx(B $(C9vF[8.(B +$(C=:F.?!(B $(C4kGQ(B $(C9vF[@T4O4Y(B. + + $(C4g=E@L(B $(C:80m(B $(C@V4B(B Emacs$(C@)55?l3;?!(B $(C@V4B(B, $(C>n60GQ(B $(CEX=:F.6s55(B, $(C>n4@0M(B +$(C@N0!@G(B $(C9vF[3;?!(B $(C@V=@4O4Y(B. + + >> $(C9vF[8.=:F.8&(B $(CAv?l1b(B $(C@'GX(B C-x 1 $(C6s0m(B $(CE8@LGAGO<<?d(B. + + $(C88>`(B, $(C>n62(B $(CH-@O@G(B $(CEX=:F.?!(B $(C:/0f@;(B $(CG`GO0m3*<-(B, $(C4Y8%(B $(CH-@O@;(B $(C2(3;>z(B +$(C4Y0m(B $(CG_4Y8i(B, $(CCVCJ@G(B $(CH-@O@:(B $(C<<@L:j5G>n(B $(C@VAv(B $(C>J=@4O4Y(B. $(C1W(B $(C:/0f@:(B Emacs +$(C3;:N@G(B $(CH-@O0z(B $(C4k@@GO4B(B $(C9vF[(B $(C3;?!88(B $(CG`GO?)A.(B $(C@V=@4O4Y(B. + + 2$(C9xB0@G(B $(CH-@O?!(B $(C4k@@GO4B(B $(C9vF[8&(B $(C885i1b55GO0m(B, $(C?!5pF.GO4u6s55(B, 1$(C9x(B +$(CB0@G(B $(CH-@O?!(B $(C4k@@GO4B(B $(C9vF[?!4B(B $(C>F9+71(B $(C?5Gb@;(B $(CAVAv(B $(C>J=@4O4Y(B. $(C@L0M@:(B $(C4k(B +$(C4\Hw(B $(C;g?kGO1b(B $(C=10T(B, $(C6GGQ(B, 1$(C9xB0@G(B $(CH-@O?!(B $(C4k@@GO4B(B $(C9vF[8&(B $(CH.:8GO?)(B $(C5N(B +$(C1b(B $(C@'GO?)(B $(C55?r@L(B $(C5G4B(B $(C9f9}@T4O4Y(B. + + C-x C-s $(C7N(B $(C9vF[8&(B $(C<<@L:jGO1b(B $(C@'GO?)(B C-x C-f $(C7N(B $(C9vF[8&(B $(C13C<GO4B(B $(C0M(B +$(C@:(B $(C1MBz=@4O4Y(B. $(C1W7!<-(B $(C>F7!@G(B $(C8m7I>n8&(B $(C;g?kGU4O4Y(B. + + C-x s $(CGv@g(B $(C@V4B(B $(C9vF[8&(B $(C<<@L:jGQ4Y(B. + + C-x s $(C4B(B $(C3;?k@;(B $(C9Y2[(B $(C9vF[(B $(C@|C<8&(B $(CH-@O?!(B $(C<<@L:jGU4O4Y(B. $(C@L(B $(C6'(B, $(CGO3*(B +$(CGO3*@G(B ($(C<<@L:j5G>n>_(B $(CGR(B)$(C9vF[?!(B $(C4kGO?)(B, $(C<<@L:jGO4B0!(B, $(CGOAv(B $(C>J4B0!8&(B y$(C3*(B +n$(C@87N(B $(C9/=@4O4Y(B. $(C@L(B $(CG%=C4B(B $(CH-8i(B $(C9X@G(B $(CG`?!(B $(CG%=C5K4O4Y(B. $(C?98&(B $(C5i8i(B, $(C>F7!?M(B +$(C00=@4O4Y(B. + + Save file /usr/private/yours/MULE.tut? (y or n) + + + +$(C8m7I>n@G(B $(CH.@e(B +============= + + $(C?!5pEM?!4B(B, $(CD\F.7Q(B*$(CE03*(B $(C8^EM(B*$(CE07N(B $(C@T7BGR(B $(C<v(B $(C@V4B(B $(C0M:84Y55(B $(CHN>@(B +$(C89@:(B $(C8m7I>n0!(B $(C@V=@4O4Y(B. $(C@L0M5i@;(B $(C4Y7g1b(B $(C@'GO?)(B, $(CH.@e(B(eXtend) $(C8m7I>n8&(B +$(C;g?kGU4O4Y(B. $(C@L0M?!4B(B, $(C>F7!@G(B 2$(C0!Av(B $(CA>7y0!(B $(C@V=@4O4Y(B. + + C-x $(C9.@Z?!(B $(C@GGQ(B $(CH.@e(B. $(C@L>n<-(B $(CGQ9.@Z8&(B $(C@T7BGU4O4Y(B. + ESC x $(C@L8'?!(B $(C@GGQ(B $(CH.@e(B. $(C@L>n<-(B $(C8m7I>n@G(B $(C@L8'@;(B $(C@T7BGU4O4Y(B. + + $(C@L0M5i@:(B $(C@O9]@{@87N(B, $(CFm8.GOAv88(B, $(CAv1]1nAv(B $(C:8>F?B(B $(C0M0z(B $(CA61](B $(C:s9xGO(B +$(C0T4B(B $(C;g?k5GAv(B $(C>J4B(B $(C8m7I>n8&(B $(C@'GQ(B $(C0M@T4O4Y(B. C-x C-f ($(CH-@N5e(B)$(C3*(B C-x C-s +($(C<<@L:j(B)$(C4B(B $(C@L(B $(C:N7y@T4O4Y(B. $(C@L?\?!(B, C-x C-c($(C?!5pEM@G(B $(CA>7a(B)$(C55(B $(C1W78=@4O4Y(B. + + C-z$(C4B(B Emacs$(C?!<-(B $(C:|A.3*?@4@5%?!(B $(C@ZAV(B $(C;g?k5G4B(B $(C9f9}@T4O4Y(B. Emacs$(C8&(B +$(CA>7aGO4B(B $(C0M@L(B $(C>F4O6s(B, $(C@O4\(B, csh$(C@G(B $(C79:'?!(B $(C5G59>F0!4B5%?!4B(B $(CA&@O(B $(CAA@:(B $(C9f(B +$(C9}@L6s0m(B $(C8;GR(B $(C<v@V0ZAv?d(B. C-z$(C8&(B $(CG`GO4u6s55(B Emacs$(C4B(B $(C=:EiGO0m(B $(C@V@;(B $(C;S(B, +$(C3;?k@L(B $(CFD1+5G4B(B $(C0M@:>F4U4O4Y(B. + +$(CAV@G(B: $(C4\(B, X-window$(C?!<-(B $(CG`GO0m(B $(C@V4B(B $(C0f?l(B, $(CH$@:(B $(C;g?kGO0m(B $(C@V4B(B + $(C=)@L(B sh$(C@O(B $(C6'4B(B, $(C1W78Av(B $(C>J=@4O4Y(B. + + C-x $(C8m7I>n4B(B,$(C89@L(B $(C@V=@4O4Y(B. $(C@L9L(B $(C9h?n(B $(C0M@:(B $(C>F7!@G(B $(C0M@T4O4Y(B. + + C-x C-f $(CH-@O@G(B $(CFmA}(B(Find) + C-x C-s $(CH-@O@G(B $(C:8A8(B(Save) + C-x C-b $(C9vF[8.=:F.@G(B $(CG%=C(B + C-x C-c $(C?!F<EM8&(B $(CA>7aGQ4Y(B. $(CH-@O@G(B $(C:8A8@:(B, $(C@Z5?@{@87N4B(B $(CG`GO?)(B + $(CAvAv(B $(C>J4B4Y(B. $(C1W7/3*(B, $(CH-@O@L(B $(C:/0f5G>n(B $(C@V@88i(B, $(CH-@O@G(B $(C:8(B + $(CA8@;(B $(CGO4B0!(B, $(C>F4Q0!8&(B $(C90>n?I4O4Y(B. $(C:8A8GO?)(B $(CA>7aGO4B(B $(C:8(B + $(CEk@G(B $(C9f9}(B, C-x C-s C-x C-c $(C7N(B $(CGO4B(B $(C0M@T4O4Y(B. + + $(C@L8'?!(B $(C@GGQ(B $(CH.@e8m7I>n?!4B(B, $(C1W4YAv(B $(C;g?k5GAv(B $(C>J4B(B $(C0M@L3*(B, $(CF/A$@G(B +$(C8p5e?!<-9[?!(B $(C;g?k5GAv(B $(C>J4B(B $(C0M5n@L(B $(C@V=@4O4Y(B. $(C?97N<-(B, "command-apropos" +$(C8&(B $(C5l4O4Y(B. $(C@L(B $(C8m7I>n4B(B $(CE0?v5e8&(B $(C@T7B=CE00m(B, $(C1W0M?!(B $(C8ED!GO4B(B $(C8p5g(B $(C8m7I(B +$(C>n@G(B $(C@L8'@;(B $(CG%=CGU4O4Y(B. ESC x $(C6s0m(B $(CE8@LGAGO8i(B, $(C=:E)80(B $(C9X?!(B "M-x" $(C0!(B $(CG%(B +$(C=C5K4O4Y(B. $(C@L0M?!(B $(C4kGO?)(B, $(C=GG`GO4B(B $(C8m7I>n@G(B $(C@L8'(B($(CAv1]@G(B $(C0f?l(B, +"command-apropos")$(C8&(B $(C@T7BGU4O4Y(B. "command-a" $(C1nAv(B $(C@T7BGQ(B $(C5Z(B $(C=:Fd@L=:(B +$(C8&(B $(CD!8i(B, $(C5Z@G(B $(C:N:P@:(B $(C@Z5?@{@87N(B $(C8^?vA}4O4Y(B. $(C@L(B $(CHD(B, $(CE0?v5e8&(B $(C90@89G7N(B, +$(C>K0m(B $(C=M@:(B $(C9.@Z?-@;(B $(CE8@LGAGU4O4Y(B. $(C6GGQ(B, $(CE0?v5e8&(B $(C@T7BGOAv(B $(C>J@88i(B, $(C8p5g(B +$(C8m7I>n0!(B $(CG%=C5K4O4Y(B. + + >> ESC x $(C8&(B $(CE8@LGAGO0m(B, $(C@L>n<-(B, "command-apropos<Return>" $(CH$@:(B + "command-a<Space><Return>" $(C@L6s0m(B $(CE8@LGAGU4O4Y(B. $(C4Y@=?!(B, + "kanji<Return>"$(C@L6s0m(B $(CE8@LGAGU4O4Y(B. + + $(C3*E83-(B "$(C@)55?l(B"$(C8&(B $(CAv?l4B5%4B(B, C-x 1 $(C@L6s0m(B $(CE8@LGAGU4O4Y(B. + +$(C8p5e6s@N(B +======== + + $(C88>`(B $(CC5C5Hw(B $(C8m7I>n8&(B $(CCF4Y8i(B, $(CH-8i@G(B $(C9XBJ@G(B $(C?!DZ?!8.>n6s0m(B $(C:R8.4B(B +$(C@e<R?!(B, $(CD#(B $(C0M@L(B $(CG%=C5K4O4Y(B. $(C?!DZ?!8.>n4B(B $(CH-8i@G(B $(CA&@O(B $(C9X(B $(CG`@T4O4Y(B. $(C1W(B +$(C9Y7N(B $(C@'@G(B $(CG`@:(B, $(C8p5e6s@N@L6s0m(B $(C:R8.0m(B $(C@V=@4O4Y(B. $(C8p5e6s@N@:(B $(C@L7/GQ(B $(C=D@8(B +$(C7N(B $(CG%=C5G>n(B $(C@V0ZAv?d(B. + + [--]J:--**-Mule: MULE.tut (Fundamental) ---NN%-------------- + + +$(CAV@G(B: NN%$(C@G(B NN$(C@:(B $(C<}@Z0!(B $(C5i>n(B $(C@V=@4O4Y(B. $(C4g=E@L(B $(C;g?kGO0m(B $(C@V4B(B + Emacs$(C@G(B $(C8p5e6s@N0z(B $(C4Y8&(B $(CAv55(B $(C8p8#Av88(B, $(C4gH2GOAv(B $(C8;557O(B. + $(C?98&(B $(C5i8i(B, $(C=C0#@L3*(B uptime$(C@L(B $(CG%=C5G0m(B $(C@V4B(B $(C0M@:(B, + display-time$(C@L6s4B(B $(C1b4I@L(B $(C@[5?GO0m(B $(C@V1b(B $(C6'9.@T4O4Y(B. + + $(C@L(B $(CG`?!(B $(C@GGO?)(B $(C89@:(B $(C@/?kGQ(B $(CA$:80!(B $(C>r>nA}4O4Y(B. + + + $(CAv1](B, $(C4g=E@L(B $(C:80m(B $(C@V4B(B $(CH-@O8m@;(B $(CG%=CGO0m(B $(C@V=@4O4Y(B. NN%$(C@:(B $(CGv@g(B $(C=:(B +$(CE)80@'?!(B $(CH-@O@G(B $(CA&@O(B $(C@'?!<-:NEM(B $(C8n(B $(CF[<>F.B00!(B $(CG%=C5G0m(B $(C@V4B(B $(C0!8&(B $(C3*E8(B +$(C3;0m(B $(C@V=@4O4Y(B. $(CH-@O@G(B $(C0!@e(B $(CCVCJ8&(B $(CG%=CGO0m(B $(C@V@88i(B, --Top--$(C6s0m(B $(CG%=C5K(B +$(C4O4Y(B. $(CH-@O@G(B $(C0!@e(B $(CCVHD8&(B $(CG%=CGO0m(B $(C@V4Y8i(B, --Bot--$(C6s0m(B $(CG%=C5K4O4Y(B. $(CH-8i(B +$(C3;?!(B $(CH-@O(B $(C@|:N0!(B $(CG%=C5G0m(B $(C@V4Y8i(B, --All--$(C6s0m(B $(CG%=C5K4O4Y(B. + + $(C8p5e6s@N@G(B $(C<R0}H#(B $(C3;?!4B(B, $(CAv1](B $(C>n60GQ(B $(C8p5e?!(B $(C5i>n@V4B(B $(C0!8&(B $(C3*E8(B +$(C3;0m(B $(C@V=@4O4Y(B. $(CGv@g4B(B, $(C5pFzF.@N(B Fundamental$(C?!(B $(C5i>n0!(B $(C@V=@4O4Y(B. $(C@L0M55(B +$(C8^@LA.8p5e@G(B $(CGO3*@G(B $(C?9@T4O4Y(B. + + Emacs$(C4B(B Lisp mode$(C3*(B Text mode$(C?M(B $(C00@L(B, $(C4Y8%(B $(CGA7N1W7%>p>n3*(B $(CEX=:F.(B +$(C?!(B $(C4kGO?)(B $(C?!5pF.8&(B $(CG`GO1b(B $(C@'GQ(B $(C8n0!Av@G(B $(C8^@LA.8p5e8&(B $(C0.0m(B $(C@V=@4O4Y(B. +$(C>n62(B $(C6'6s55(B $(C9]5e=C(B $(C>n4@0M@N0!@G(B $(C8^@LA.8p5e@G(B $(C;sEB7N(B $(C5G>n(B $(C@V=@4O4Y(B. + + $(C0"0"@G(B $(C8^@LA.8p5e4B(B $(C8n0!Av@G(B $(C8m7I>n8&(B $(C@|Gt(B $(C4Y8%(B $(CG`5?@87N(B $(CGO?)(B $(C9v(B +$(C834O4Y(B. $(C?98&(B $(C5i>n(B $(C:8=J4O4Y(B. $(CGA7N1W7%(B $(C3;?!(B $(C8m7I>n8&(B $(C885e4B(B $(C8m7I>n0!(B $(C@V(B +$(C=@4O4Y(B. $(C8m7I>n8&(B $(C>n60GQ(B $(CG|=D@87N(B $(CGO4B0!4B(B, $(C0"(B $(CGA7N1W7%>p>n?!(B $(C5{6s<-(B +$(C4Y8#Av88(B, $(C0"0"@G(B $(C8^@LA.8p5e4B(B, $(C9]5e=C(B $(C3V>nA]4O4Y(B. + + $(C0"0"@G(B $(C8^@LA.8p5e?!(B $(C5i>n0!1b(B $(C@'GQ(B $(C8m7I>n4B(B $(C8p5e8m@L(B $(CH.@e5H(B $(C0M@87N(B +$(C5G>n(B $(C@V=@4O4Y(B. $(C?98&(B $(C5i8i(B, M-x fundamental-mode$(C4B(B Fundamental$(C7N(B $(C5i>n0!(B +$(C1b(B $(C@'GQ(B $(C0M@T4O4Y(B. + + $(C88>`(B, $(C?5>n8&(B $(C?!5pF.GQ4Y8i(B, Text mode$(C7N(B $(C5i>n0)4O4Y(B. + + >> M-x text-mode <Return>$(C6s0m(B $(CE8@LGAGO<<?d(B. + + $(CGv@g@G(B $(C8^@LA.8p5e?!(B $(C4kGQ(B $(C55E%8UF.8&(B $(C:80m(B $(C=M@;(B $(C6'4B(B, C-h m$(C@L6s0m(B +$(CE8@LGAGU4O4Y(B. + + >> C-h m $(C8&(B $(C;g?kGO?)(B Text mode$(C?M(B Fundamental mode$(C@G(B $(CBw@L8&(B $(C>K>F(B + $(C:8<<?d(B. + + >> C-x 1$(C7N(B $(C55E%8UF.8&(B $(CH-8i@87N:NEM(B $(CAv?l<<?d(B. + + $(C?^BJ(B $(C3!@G(B '[--]' $(C@:(B $(CGv@g@G(B $(CE0@T7B@G(B $(C8p5e8&(B $(C3*E83;0m(B $(C@V=@4O4Y(B. +[--] $(C@N(B $(C6'?!4B?5>n(B $(C>KFD:*@;(B $(C1W4k7N(B $(C@T7BGR(B $(C<v(B $(C@V=@4O4Y(B. $(C@T7B8p5e?!(B $(C4kGQ(B +$(C;s<<GQ(B $(C<38m@:(B "$(CE8860m(B" $(C8^4:>s@;(B $(C:8<<?d(B. + + $(C1W(B $(C9Y7N(B $(C?@8%BJ?!4B(B $(CDZ5eC<0T(B (coding-system) $(C?!(B $(C0|GQ(B $(CGA7!1W@G(B $(C;sEB(B +$(C0!(B $(CG%=C5G>n(B $(C@V=@4O4Y(B. Mule $(C@:(B, $(CH-@O@TCb7B(B, $(C@T7B(B, $(CH-8iCb7B?!(B $(C4kGO?)(B, $(C0"(B +$(C0"(B $(C5683@{@87N(B $(CDZ5eC<0h8&(B $(CAvA$=CE3(B $(C<v(B $(C@VAv88(B, $(CEk;s@:(B $(CH-@O?k@G(B $(CDZ5eC<0h@G(B +$(C4:8p4P88(B $(CG%=CGO0m@V=@4O4Y(B. + + >> $(C8p5e6s@N(B $(C@'?!(B "J:","S:", $(CH$@:(B "E:"$(C0!(B $(CG%=C5G>n(B $(C@V4B0!(B $(CH.@N(B + $(CGO<<?d(B. + + $(CCVCJ@G(B $(CGQ(B $(C9.@Z0!(B $(CDZ5eC<0h@G(B $(C4:8p4P(B, $(C4Y@=@G(B ':' $(C0!(B $(CGv@g(B $(C?5>n(B $(C@L?\(B +$(C@G(B $(C9.@Z(B($(C@O:;>n(B, $(CGQ19>n5n(B)$(C55(B $(CG%=CGQ4Y4B(B $(C0M@;(B $(C3*E83;0m(B $(C@V=@4O4Y(B. J$(C4B(B +JUNET$(C@87N(B $(C;g?k5G0m(B $(C@V4B(B JIS $(CDZ5e(B, S $(C4B(B Shift-JIS, E $(C4B(B $(C@O:;>n(BEUC $(C8&(B $(C3*(B +$(CE83;0m(B $(C@V=@4O4Y(B. $(C4Y19>n(B $(CG%=C@G(B $(C@/9+4B(B C-x C-k t $(C7N(B ON/OFF$(C@G(B $(CEd1[@L(B $(C0!(B +$(C4IGU4O4Y(B. + + $(C4Y@=@G(B $(C?94B(B, $(C@O4\(B $(C4Y19>nG%=C8&(B OFF$(CGO0m3*<-(B, $(C4Y=C(B $(CGQ9x(B ON$(C@;(B $(CG`GO?)(B +$(C:>4O4Y(B. + + >> C-x C-k t$(C8&(B 2$(C9x(B $(CG`GO<<?d(B. + + $(C@T7B8p5e0!(B JIS$(CDZ5e@G(B $(C<3A$@L(B $(C5G>n(B $(C@V@;(B $(C6'(B, $(C88>`(B $(C4g=E@L(B $(C;g?kGO0m(B $(C@V(B +$(C4B(B $(C4\8;?!(B $(C8^EM(B*$(CE00!(B $(C:Y>n(B $(C@V@88i(B, $(C@L=:DI@LGA(B*$(CE0(B $(C4k=E?!(B $(C1W0M@;(B $(C;g?kGO4B(B +$(C0M@L(B $(C0!4IGU4O4Y(B. $(C@L(B $(C6'(B, $(C8^EM(B*$(CE0@G(B $(C;g?k9f9}@:(B $(CD\F.7Q(B*$(CE0?M(B $(C00@L(B $(C4)8#8i<-(B +$(C9.@Z8&(B $(CE8@LGAGU4O4Y(B. ESC <$(C9.@Z(B>$(C55(B M-<$(C9.@Z(B>$(C55(B $(C00@:(B $(C@[5?@;(B $(CGU4O4Y(B. $(CAv1](B +$(C1nAv@G(B $(C<38m?!<-(B ESC <$(C9.@Z(B>$(C6s0m(B $(CG`GO0m(B $(C@V4x(B $(C0w@L(B, M-<$(C9.@Z(B>$(C7N(B $(C5K4O4Y(B. $(CAV(B +$(C@GGX>_(B $(CGO4B(B $(C0M@:(B, $(C=,GAF.(BJIS$(C3*(B EUC$(CDZ5e(B $(C6'4B(B $(C;g?kGR(B $(C<v(B $(C>x=@4O4Y(B. + + $(CDZ5eC<0h@G(B $(C13C<4B(B, $(C0"0"@G(B $(C9vF[?!(B $(C4kGX<-88(B $(C@/H?GU4O4Y(B. $(C0"0"@G(B, $(CDZ(B +$(C5eC<0h(B $(CAvA$?!(B $(C4kGX<-4B(B, C-h a coding-system <Return>$(C@87N:<(B $(C<v(B $(C@V=@4O4Y(B. + + >> C-h a coding-system <Return>$(C@87N(B $(C3*?@4B(B $(C55E%8UF.(B $(C3;@G(B, + set-display-coding-system, set-file-coding-system, + set-process-coding-system $(C@G(B $(C<38m@;(B $(C@P>n:8<<?d(B. + +$(C0K;v(B +==== + + $(C9.@Z?-@;(B, $(CH-@O3;?!<-(B, $(C@|9f(B $(CH$@:(B $(CHD9f@87N(B, $(CC#@;(B $(C<v(B $(C@V=@4O4Y(B. $(C0K;v(B +$(C@;(B $(C=C@[GO4B(B $(C8m7I>n4B(B, $(CD?<-@'D!(B $(C@LHD8&(B $(C0K;vGQ4Y8i(B, C-s, $(CD?<-@'D!(B $(C@L@|@L(B +$(C6s8i(B C-r $(C@T4O4Y(B. C-s $(C8&(B $(CE8@LGAGO8i(B, $(C?!DZ?!8.>n?!(B "I-search:"$(C6s4B(B $(C9.@Z?-(B +$(C@L(B $(CGA7RF.7N<-(B $(CG%=C5K4O4Y(B. ESC$(C8&(B $(C4)8#8i(B, $(CA>7a5K4O4Y(B. + + + >> C-s$(C7N(B $(C0K;v@L(B $(C=C@[5K4O4Y(B. $(C1W8.0m(B, $(CC5C5Hw(B 1$(C9.@Z>?(B "cursor"$(C6s4B(B + $(C4\>n8&(B $(C@T7BGU4O4Y(B. 1$(C9.@Z(B $(C@T7BGR(B $(C6'864Y(B, $(CD?<-4B(B, $(C>n6;0T(B $(C?rAw(B + $(C@T4O1n(B? + + >> $(CGQ9x(B $(C4u(B C-s $(C8&(B $(CE8@LGAGO8i(B, $(C4Y@=@G(B "cursor"$(C8&(B $(CC#@;(B $(C<v(B $(C@V=@4O4Y(B. + + >> <Delete>$(C8&(B 4$(CH8(B $(C@T7BGO0m(B, $(CD?<-@G(B $(C?rAw@S@;(B $(C:8<<?d(B. + + >> ESC$(C8&(B $(C4)8#0m(B, $(CA>7aGU4O4Y(B. + + $(CC#0m(B $(C=M@:(B $(C9.@Z?-@;(B $(CE8@LGAA_?!55(B, $(CE8@LGAGQ(B $(C9.@Z:N:P88@87N(B, $(C0K;v@;(B +$(C=C@[GU4O4Y(B. $(C4Y@=(B $(C9.@Z8&(B $(CC#4B5%4B(B, $(C4Y=C(B C-s$(C8&(B $(CE8@LGAGU4O4Y(B. $(C88>`(B, $(C9.@Z(B +$(C?-@L(B $(CA8@gGOAv(B $(C>J@88i(B, $(C8^<<Av0!(B $(CG%=C5K4O4Y(B. C-g $(C7N55(B $(CA>7a5K4O4Y(B. + + $(C0K;v=GG`A_?!(B, <Delete>$(C8&(B $(C@T7BGO8i(B, $(C0K;v9.@Z?-@G(B $(CA&@O(B $(C5Z@G(B $(C9.@Z0!(B +$(CAv?vA}4O4Y(B. $(C1W8.0m3*<-(B, $(CD?<-4B(B, $(C@L@|9x@G(B $(C@'D!7N(B $(C5G59>F0)4O4Y(B. $(C?98&(B $(C5i(B +$(C8i(B, "cu"$(C6s0m(B $(CE8@LGAGO0m(B, $(CCVCJ@G(B "cu"$(C@G(B $(C@'D!?!(B $(CD?<-0!(B $(C?rAw?44Y0m(B $(CGU=C4Y(B. +$(C?)1b?!<-(B <Delete>$(C8&(B $(C@T7BGO8i(B, $(C<-D!6s@N@G(B 'u'$(C0!(B $(CAv?vAv0m(B, $(CD?<-4B(B 'u'$(C8&(B +$(CE8@LGAGO1b(B $(C@|?!(B, $(CD?<-0!(B $(C@V>z4x(B 'c'$(C@G(B $(C@'D!7N(B,$(C@L5?GU4O4Y(B. + + $(C0K;v=GG`A_?!(B, C-s $(C3*(B C-r $(C@L?\@G(B $(CD\F.7Q9.@Z8&(B $(CE8@LGAGO8i(B, $(C0K;v@:(B +$(CA>7aGU4O4Y(B. + + C-s $(C4B(B, $(CGv@g@G(B $(CD?<-@'D!(B $(C@LHD?!(B $(C3*?@4B(B $(C0K;v9.@Z?-@;(B $(CC#=@4O4Y(B. $(C88>`(B, +$(C@L@|(B $(CBJ@;(B $(CC#0m(B $(C=M@88i(B, C-r $(C@;(B $(CE8@LGAGO4B(B $(C0M@87N(B, $(C?*9fGb0K;v@L(B $(C0!4IGU4O(B +$(C4Y(B. C-s $(C?M(BC-r $(C4B(B, $(C0K;v@G(B $(C9fGb@L(B $(C9]4k@O(B $(C;S(B, $(C@|:N(B $(C00@:(B $(C?rAw@S@;(B $(CGU4O4Y(B. + +$(C8.D?=C:j(B $(C?!5pFC(B $(C79:'(B + + $(C6'6'7N(B, ($(C:;@G(B $(C>F4O0T(B) $(C8.D?=C:j(B $(C?!5pFC(B $(C79:'@L6s0m(B $(C:R8.4B(B $(C;sEB?!(B $(C5i(B +$(C>n0!4B(B $(C6'0!(B $(C@V=@4O4Y(B. $(C8^@LA.8p5e@G(B $(C<R0}H#(B'()'$(C@G(B $(CAV@'8&(B $(CA_0}H#(B'[]'$(C7N(B $(C5Q(B +$(C7/=Q(B $(C0M@L(B $(C8p5e6s@N(B $(C@'?!(B $(CG%=C5K4O4Y(B. $(C?98&(B $(C5i8i(B, (Fundamental)$(C@L6s0m(B $(CG%=C(B +$(C5G4B(B $(C4k=E?!(B[(Fundamental)]$(C?M(B $(C00@L(B $(C5K4O4Y(B. + +$(CAV@G(B: $(C?)1b?!<-4B(B $(C8.D?=C:j(B $(C?!5pFC(B $(C79:'(B $(C@ZC<?!(B $(C4kGX<-4B(B $(C<38mGOAv(B + $(C>J=@4O4Y(B. + + $(C8.D?=C:j(B $(C?!5pFC(B $(C79:'7N:NEM(B $(C:|A.3*?@1b(B $(C@'GX<-4B(B, M-x top-level +<Return>$(C@L6s0m(B $(CE8@LGAGU4O4Y(B. + + >> $(C=CGhGO?)(B $(C:8<<?d(B. $(C=:E)80(B $(C9X?!(B "Back to top level"$(C6s0m(B $(CG%=C5K(B + $(C4O4Y(B. + + $(CK\;g=G@:(B, $(C@L(B $(C=C550!(B $(CG`GO?)A3@;(B $(C6'4B(B, $(C@L9L(B $(CEi79:'?!(B $(C@V>z4x(B $(C0M@T4O(B +$(C4Y(B. M-x top-level$(C@:(B, $(C>F9+71(B $(C?5Gb@;(B $(CAV0m(B $(C@VAv(B $(C>J=@4O4Y(B. + + $(C8.D?=C:j(B $(C?!5pFC(B $(C79:'7N:NEM(B $(C:|A.3*?@4B(B $(C0M?!(B $(C4kGX<-4B(B C-g$(C4B(B $(C5hAv(B $(C>J(B +$(C=@4O4Y(B. + + +$(CGoGA(B +==== + + Emacs$(C?!4B(B, $(C89@:(B $(C55?r1b4I@L(B $(C@V0m(B, $(C?)1b?!<-(B, $(C@|:N8&(B $(C<38mGO4B(B $(C0M@:(B +$(C:R0!4IGU4O4Y(B. $(C1W7/3*(B, $(C>FAw(B $(C8p8#4B(B $(C89@:(B $(C1b4I@;(B $(C9h?l1b(B $(C@'GX<-4B(B, <HELP> +$(C6s0m(B $(C:R8.4B(B C-h $(C8&(B $(CE8@LGAGO4B(B $(C0M@87N(B, $(C89@:(B $(CA$:88&(B $(C@T<vGR(B $(C<v(B $(C@V=@4O4Y(B. + + $(C;g?k9f9}@:(B, C-h $(C8&(B $(CE8@LGAGO0m(B, $(C@L>n<-(B $(CGJ?dGQ(B $(C?I<G@;(B 1$(C9.@Z(B $(CE8@LGA(B +$(CGU4O4Y(B. $(C8p8#0Z@88i(B, C-h ? $(C6s0m(B $(CE8@LGAGO8i(B, $(C>n62(B $(C?I<G@L(B $(C@V4B0!(B $(CG%=C5K(B +$(C4O4Y(B. $(C88>`(B, C-h $(C8&(B $(CE8@LGAGO0m3*<-(B $(C86@=@L(B $(C:/G_4Y8i(B, C-g $(C8&(B $(CE8@LGAGO8i(B, +$(CCk<RGR<v(B $(C@V=@4O4Y(B. + + $(C0!@e(B $(C1b:;@{@N(B $(C0M@:(B, C-h c $(C@T4O4Y(B. $(C@L0M?!(B $(C@L>n<-(B $(CE08&(B $(C@T7BGO8i(B, $(C1W(B +$(C8m7I>n?!(B $(C4kGQ(B $(CB*@:(B $(C<38m@;(B $(CG%=CGU4O4Y(B. + + >> C-h c C-p $(C6s0m(B $(CE8@LGAGO?)(B $(C:8<<?d(B. "C-p runs the command + previous-line"$(C0z(B $(C00@:(B $(C8^<<Av0!(B $(CG%=C5K4O4Y(B. + + $(C:;(B $(C@{@:(B $(C@VAv88(B, $(C1b>oGO0m(B $(C@VAv(B $(C>J@:(B $(C8m7I>n55(B $(C;}0"GX(B $(C3>(B $(C<v(B $(C@V4B(B $(C0M(B +$(C@T4O4Y(B. C-x C-s $(C?M(B $(C00@:(B $(C:9<v@L8i<-(B 1$(C03@G(B $(C8m7I>n55(B C-h c $(C@G(B $(C5Z?!(B $(C@L>n(B +$(CA}4O4Y(B. + + $(C4u?m(B $(C;s<<GO0T(B $(C>K0m(B $(C=M@88i(B, c $(C4k=E?!(B k $(C8&(B $(CAvA$GU4O4Y(B. + + >> C-h k C-p $(C6s0m(B $(CE8@LGAGO?)(B $(C:8<<?d(B. + + Emacs$(C@G(B $(C@)55?l?!(B, $(C8m7I>n@G(B $(C@L8'0z(B $(C1b4I@L(B $(CG%=C5K4O4Y(B. $(C4Y(B $(C@P>z@88i(B, +C-x 1 $(C6s0m(B $(CE8@LGAGO8i(B, $(C:|A.3*?I4O4Y(B. + + $(C@L?\?!55(B $(C55?r@L(B $(C5G4B(B $(C?I<G@L(B $(C@V=@4O4Y(B. + + C-h f $(CFc<G8m@;(B $(C@T7BGO8i(B, $(CFc<G@;(B $(CG%=CGU4O4Y(B. + + >> C-h f previous-line $(C@;(B $(CE8@LGAGO0m(B, <Return> $(C@;(B $(C4)8#<<?d(B. C-p + $(C8m7I>n8&(B $(C=GG`GO4B(B $(CFc<G?!(B $(C4kGQ(B $(CA$:88&(B $(CG%=CGU4O4Y(B. + + C-h a $(CE0?v5e8&(B $(C@T7BGO8i(B, $(C@L8'?!(B $(C1W(B $(CE0?v5e8&(B $(CFwGTGO0m(B, $(C8p5g(B $(C8m(B + $(C7I>n8&(B $(CG%=CGU4O4Y(B. $(C@L(B $(C8m7I>n5i@:(B $(C8p5N(B ESC x $(C7N(B $(C=GG`GR(B + $(C<v(B $(C@V=@4O4Y(B. + + >> C-h a file $(C>K0m(B $(CE8@LGAGO0m(B, <Return>$(C@;(B $(C4)8#<<?d(B. $(C@L8'?!(B + "file"$(C@L6s4B(B $(C9.@Z8&(B $(C0.4B(B $(C8p5g(B $(C8m7I>n8&(B $(CG%=CGU4O4Y(B. $(C6GGQ(B, + find-file $(C@L3*(B write-file$(C6s4B(B $(C@L8'@G(B C-x C-f $(C3*(B C-x C-w $(C?M(B $(C00(B + $(C@:(B $(C8m7I>n55(B $(CG%=C5K4O4Y(B. + +$(C3!@87N(B +====== + +$(C@XAv8;0m(B: $(CA>7aGO4B5%4B(B, C-x C-c $(C6s0m(B $(CGU4O4Y(B. + + + $(C@L(B $(C@T9.Fm@:(B, $(CCJ=I@Z?!0T55(B $(C>K1b(B $(C=10T(B $(CGO557O(B $(C@G55GO0m(B $(C@V=@4O4Y(B. +$(C1W7/9G7N(B, $(CH$=C(B $(C9+>y@N0!(B $(C@LGXGO1b(B $(C>n7A?n(B $(CA!@L(B $(C@V4Y8i(B, $(CH%@Z<-(B $(CG*3d(B +$(CGOAv(B $(C8;0m(B, $(CF.A}@;(B $(C@b>F(B $(CAV<<?d(B. + + + $(C88>`(B, EMACS $(C8&(B $(C8n@OA$55(B $(C;g?kGO0m(B $(C:88i(B, $(C1W0M@;(B $(C1W885P4Y4B(B $(C0M@:(B +$(C8xGO0T(B $(C5I(B $(C0M@T4O4Y(B. $(CCVCJ?!4B(B $(C>n8.5U@}GR(B $(CAv55(B $(C8p8#0Z=@4O4Y(B. $(C1W7/3*(B, +$(C1W0M@:(B $(C>n60GQ(B $(C?!5pEM6s55(B $(C6H(B $(C00=@4O4Y(B. EMACS $(C?M(B $(C00@L(B, $(C4k4\Hw(B $(C89@:(B $(C0M@L(B +$(C0!4IGQ(B $(C0f?l?!4B(B $(CF/Hw(B $(C1W780ZAv?d(B. $(C1W8.0m(B, EMACS $(C?!<-4B(B, $(C=GA&7N(B, $(C9+>y@L(B +$(C3*(B $(CGR(B $(C<v(B $(C@V1b(B $(C6'9.?!(B. + + +$(C0(;g(B +==== + $(C@L(B $(C9.<-4B(B, JUNET$(C?!<-(B $(C9hFw5H(B "$(C@O:;>n(B MicroEMACS (kemacs) $(C@T9.Fm(B" +$(C@;(B GNUE- macs (Nemacs)$(C@G(B Tutorial$(C?k@87N(B $(C0mCD>4(B $(C0M@T4O4Y(B. + + Jonathan Payne $(C?!(B $(C@GGQ(B "JOVE Tutorial" (19 January 86) $(C@;(B $(C:/0fGQ(B + $(C0M@L0m(B, $(C1W0M@:(B $(C?x7!(B, CCA-UNIX$(C@G(B Steve Zimmerman $(C?!(B $(C@GGX<-(B $(C:/0f5H(B, + MIT $(C@G(B "Teach-Emacs" $(C@T9.Fm(B (31 October 85) $(C@;(B ($(C4u?m(B) $(C:/0fGQ(B $(C0M@L(B + $(C>z=@4O4Y(B. + + Update - February 1986 by Dana Hoggatt. + + Update - December 1986 by Kim Leburg. + + Update/Translate - July 1987 by SANETO Takanori + +$(CF/:0GQ(B $(C0(;g(B +=========== + + $(CCVCJ?!(B $(C@L(B $(C@O:;>n9x?*@;(B $(C@[<:GQ(B, SANETO Takanori$(C>>(B. $(C@L(B $(C9.@e@:(B GMW + +Wnn + Nemacs$(C@;(B $(C;g?kGO?)(B $(C@[<:G_=@4O4Y(B. $(C1W?M(B $(C00@:(B $(CHG8"GQ(B $(CGA7N1W7%@;(B $(C885g(B +$(C8p5g(B $(C:P?!0T(B $(C0(;g@G(B $(C6f@;(B $(CG%GO0m(B $(C=M=@4O4Y(B. $(C9x?*@L6s5g0!(B, $(C@T7B(B $(C5n(B +$(C?)7/8p7N(B $(C55?M(B $(CAX(B $(CHDAvGO6s<n?l2?>>(B, $(C4k4\Hw(B $(C0(;gGU4O4Y(B. + + + +$(C?@?*(B, $(C0EA~(B, $(C@L(B $(C?\@G(B $(C9.C%@:(B $(C>F7!@G(B $(C;g6w?!0T(B $(C@V=@4O4Y(B. + + $BNkLZM5?.(B hironobu@sra.co.jp + + +Update/Add - December 1987 by Hironobu Suzuki +Update/Add - November 1989 by Ken'ichi Handa +Update/Add - January 1990 by Shigeki Yoshida +Update/Add - March 1992 by Kenichi HANDA + + +$(C6G4Y8%(B $(C0(;g(B +=========== + + $(C@L(B $(C9.<-4B(B "$(C@O:;>n(B GNUEMACS(Mule) $(C@T9.Fm(B"$(C@;(B $(CGQ19>n7N(B $(C9x?*GO?)(B, +hemacs$(C7N(B $(C@[<:GQ(B $(C0M@T4O4Y(B. $(C@O:;>n9x?*@;(B $(C4c4gGQ(B $(C8p5g(B $(C:P(B, hemacs$(C8&(B +$(C039_GO?)(B $(CAV=E(B $(C:P(B, $(CF/Hw(B Mule$(C0z(B hemacs$(C@G(B $(CH/0f18C`?!(B $(C89@:(B $(C55?r@;(B $(CAX(B +$(C136G4kGP(B $(C3*0!?@?,18=G(B $(CA9>w;}@N(B Masashi SHIMBO$(C>>?M(B Katsuyoshi +Yamagami$(C>>?!0T(B $(C0(;g@G(B $(C6f@;(B $(C@|GU4O4Y(B. + + 1993. 9. 25 + + $(C136G4kGP(B $(C0xGP:N(B $(C@|1b0xGP0z(B $(C3*0!?@?,18=G(B + Dosam HWANG hwang@forest.kuee.kyoto-u.ac.jp
--- a/etc/TUTORIAL.kr Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,776 +0,0 @@ - ============================== - $(C@O:;>n(B GNUEMACS(Mule) $(C@T9.Fm(B - ============================== - -$(CAV@G(B: $(C@L(B $(C@T9.Fm@:(B, "$(C9h?l1b:84Y(B $(C@M<wGXAv1b(B"$(C8&(B $(C8pEd7N(B $(C@[<:5G>n(B - $(C@V=@4O4Y(B. ">>" $(C7N:NEM(B $(C=C@[GO4B(B $(CG`@:(B, $(C1W(B $(C6'(B $(C9+>y@;(B $(CGX>_(B - $(CGO4B0!8&(B $(CAv=CGO0m(B $(C@V=@4O4Y(B. - - Mule $(C@G(B $(C8m7I>n8&(B $(C@T7BGR(B $(C6'?!4B(B, $(C@O9]@{@87N(B $(CD\F.7Q(B*$(CE0(B($(CE0(B*$(CEi?!(B, -CTRL $(C6G4B(B, CTL $(C6s0m(B $(C=a@V4Y(B)$(C3*(B $(C8^E8(B*$(CE0(B($(C:8Ek(B, $(C@L=:DI@LGA(B*$(CE08&(B $(C;g?kGQ4Y(B)$(C0!(B -$(C;g?k5K4O4Y(B. $(C1W7!<-(B, CONTROL $(C@L6s5g0!(B META $(C6s0m(B $(C>24B(B $(C4k=E?!(B, $(C4Y@=0z00@:(B -$(C1bH#8&(B $(C;g?kGO4B(B $(C0M@87N(B $(CGU4O4Y(B. - -C-<$(C9.@Z(B> $(CD\F.7Q(B*$(CE08&(B $(C4)8%C$(B, <$(C9.@Z(B>$(CE08&(B $(C4)8(4O4Y(B. $(C?98&(B $(C5i8i(B, - C-f $(C4B(B, $(CD\F.7Q(B*$(CE08&(B $(C4)8#8i<-(B f $(CE08&(B $(C4)8#4B(B $(C0M@;(B - $(C@G9LGU4O4Y(B. -<<Blank lines inserted here by startup of help-with-tutorial>> - >> $(C1W7/8i(B, C-v (View Next Screen; $(C4Y@=@G(B $(CH-8i@;(B $(C:;4Y(B) $(C8&(B $(CE8@LGA(B - $(CGO?)(B $(C:8<<?d(B. $(C4Y@=@G(B $(CH-8i@87N(B $(C0%(B $(C<v(B $(C@V=@4O4Y(B. - From now on, you'll be expected to do this whenever you finish - reading the screen. - -ESC <$(C9.@Z(B> $(C@L=:DI@LGA(B*$(CE08&(B $(C4)8#0m3*<-(B, $(C1W(B $(C5Z(B <$(C9.@Z(B>$(CE08&(B $(C4)8(4O4Y(B. - -$(CAV@G(B: <$(C9.@Z(B>$(C4B(B, $(C4k9.@Z3*(B $(C<R9.@Z4B(B $(C8m7I>n7N<-4B(B $(C00@:(B $(C@G9L0!(B - $(C5K4O4Y(B. $(C8^E8E08&(B $(C;g?kGR(B $(C<v(B $(C@V@88i(B ESC <$(C9.@Z(B> $(C4k=E?!(B M- - <$(C9.@Z(B> ($(C8^E8E08&(B $(C4)8%C$(B<$(C9.@Z(B>$(CE08&(B $(C4)8%4Y(B) $(C8&(B $(C;g?kGR(B $(C<v(B - $(C@V=@4O4Y(B. - -$(CA_?dGU4O4Y(B: Emacs$(C8&(B $(CA>7a=CE00m(B $(C=M@;(B $(C6'4B(B, C-x C-c $(C8&(B $(CE8@LGAGU4O4Y(B. - Emacs$(C8&(B csh$(C7N:NEM(B $(C1b5?GO0m(B $(C@V4B(B $(C0f?l(B, $(C<-=:Ff5eGO4B(B($(C@O=C(B - $(C@{@87N(B $(CA_4\GQ4Y(B)$(CGR(B $(C<v0!(B $(C@V=@4O4Y(B. Emacs$(C8&(B $(C<-=:Ff5eGO4B(B - $(C5%4B(B, C-z$(C8&(B $(CE8@LGAGU4O4Y(B. - - $(C1W7/8i(B, $(C@LA&:NEM4B(B, $(CGQH-8i@;(B $(C4Y(B $(C@P>z@88i(B, C-v $(C8&(B $(C@T7BGO?)(B $(CAV<<?d(B. - - $(C>U@G(B $(CH-8i0z(B $(C4Y@=(B $(CH-8i?!4B(B, $(CG%=C5G4B(B $(C3;?k?!(B $(C8nG`@G(B $(C9.@L(B $(CA_:95G0m(B -$(C@V=@4O4Y(B. $(CG%=C5G0m(B $(C@V4B(B $(C3;?k@L(B $(C?,<S5G>n(B $(C@V4B(B $(C0M@;(B $(C>K(B $(C<v(B $(C@V557O(B $(CGO1b(B $(C@'(B -$(CGQ(B $(C0M@T4O4Y(B. - - - $(C$^8U@z(B, $(CH-@O(B $(C<S@;(B $(C@L5?GO?)(B $(C0!4B(B $(C9f9}@;(B $(C>K(B $(CGJ?d0!(B $(C@V=@4O4Y(B. C-v -$(C?!(B $(C@GGO?)(B $(C>U@87N(B $(CAxG`GO4B(B $(C0M@:(B $(C@L9L(B $(C>K>R=@4O4Y(B. $(C?x7!@G(B $(C@Z8.7N(B $(C5G59>F(B -$(C0!4B5%4B(B, ESC v $(C8&(B $(CE8@LGAGU4O4Y(B. - - >> ESC v $(C?M(B C-v $(C8&(B $(C;g?kGO?)(B, $(C@|HD7N(B $(C@L5?GO4B(B $(C0M@;(B $(C8n9x(B $(C=C55GO?)(B - $(C:8<<?d(B. - -$(C?d>`(B -==== - $(CH-@O@;(B $(CH-8i4\@'7N(B $(C:80m(B $(C0!4B5%4B(B, $(C4Y@=@G(B $(C8m7I>n8&(B $(C;g?kGU4O4Y(B. - - C-v $(C>U@87N(B $(CGQ(B $(CH-8i:P(B $(CAxG`GQ4Y(B - ESC v $(C5Z7N(B $(CGQ(B $(CH-8i:P(B $(C5G59>F0#4Y(B - C-l $(CH-8i@;(B $(C4Y=C>44Y(B. $(C@L(B $(C6'(B, $(C?x7!(B $(CD?<-0!(B $(C@V>z4x(B $(CG`@L(B - $(CH-8i@G(B $(CA_>S?!(B $(C?@557O(B $(CGQ4Y(B - - >> $(CAv1](B $(CD?<-0!(B $(C>n5p?!(B $(C@V4B0!(B, $(C1W(B $(C1YC3?!(B $(C>n62(B $(CEX=:F.0!(B $(C=aA.(B $(C@V4B(B - $(C0!8&(B $(C1b>oGO<<?d(B. C-l $(C8&(B $(CE8@LGAGO0m(B, $(CD?<-0!(B $(C>n5p7N(B $(C@L5?GO?44B(B - $(C0!(B, $(C1W(B $(C1YC3@G(B $(CEX=:F.4B(B $(C>n6;0T(B $(C5G>z4B0!8&(B $(CA6;gGO?)(B $(C:8<<?d(B. - -$(C1b:;@{@N(B $(CD?<-@G(B $(CA&>n(B -====================== - - $(CH-8i4\@'@G(B $(C@L5?@:(B $(CGR(B $(C<v(B $(C@V0T(B $(C5G>z=@4O4Y(B. $(C@LA&4B(B, $(CH-8i(B $(C3;?!<-(B, $(CF/(B -$(CA$@G(B $(C@e<R7N(B $(C@L5?GO1b(B $(C@'GQ(B $(C9f9}@;(B $(C@MH|=C4Y(B. $(C@L0M?!4B(B $(C8n0!Av@G(B $(C9f9}@L(B $(C@V(B -$(C=@4O4Y(B. $(CGQ0!Av(B $(C9f9}@:(B, $(C@|(B(previous)$(CHD(B(next)$(C>U(B(forward)$(C5Z(B(backward)$(C7N(B -$(C@L5?GO4B(B $(C8m7I>n8&(B $(C;g?kGO4B(B $(C0M@T4O4Y(B. $(C@L5i@G(B $(C8m7I>n4B(B $(C0"0"(B, C-p, C-n, -C-f, C-b $(C?!(B $(CGR4g5G>n(B $(C@V0m(B, $(CGv@g@G(B $(C@e<R7N:NEM(B $(C;u7N?n(B $(C@e<R7N(B $(CD?<-8&(B $(C@L5?(B -$(C=CE54O4Y(B. $(C1W82@87N(B $(C1W8.8i(B, - - - $(C@L@|@G(B $(CG`(B, C-p - : - : - $(C5Z@G(B $(C9.@Z(B, C-b .... $(CGv@g@G(B $(CD?<-@'D!(B .... $(C@|9f@G(B $(C9.@Z(B, C-f - : - : - $(C4Y@=(B $(CG`(B, C-n - - - $(C@L5i@:(B, $(C0"0"(B, Previous, Next, Backward, Forward $(C@G(B $(C8S8.9.@Z7N(B $(C5G(B -$(C>n(B $(C@V@89G7N(B, $(C?\?l1b(B $(C=,?o(B $(C0M@T4O4Y(B. $(C@L5i@:(B, $(C1b:;@{@N(B $(CD?<-@L5?(B $(C8m7I>n@L0m(B -, $(C@ZAV(B $(C;g?kGO4B(B $(C0M@T4O4Y(B. - - >> C-n $(C@;(B $(C8nH8A$55(B $(CE8@LGAGO0m(B, ($(CAv1](B, $(C4g=E@L(B $(C@P0m(B $(C@V4B(B) $(C@L(B $(CG`1n(B - $(CAv(B $(CD?<-8&(B $(C@L5?=CE0<<?d(B. - - >> C-f $(C8&(B $(C;g?kGO?)(B $(CG`@G(B $(CA_0#A$557N(B $(C@L5?GO0m(B, C-p $(C@87N(B $(C8nG`A$55(B - $(C@'7N(B $(C@L5?GO?)(B $(C:8<<?d(B. $(CD?<-@'D!@G(B $(C:/H-?!(B $(CAV@GGO<<?d(B. - - >> $(CG`@G(B $(C<15N?!<-(B C-b $(C8&(B $(CE8@LGAGO?)(B $(C:8<<?d(B. $(CD?<-4B(B $(C>n5p7N(B $(C@L5?GU(B - $(C4O1n(B? $(C4Y=C(B $(CA61](B $(C4u(B C-b $(C8&(B $(CE8@LGAGO0m(B, $(C@L9x@:(B C-f $(C7N(B $(CG`3!(B $(CBJ(B - $(C@87N(B $(C5G59>F0!<<?d(B. $(CD?<-0!(B $(CG`3!@;(B $(C3Q@88i(B $(C>n6;0T(B $(C5K4O1n(B? - - - $(CH-8i@G(B $(C<15N3*(B $(C8;9L8&(B $(C3Q>n<-(B $(CD?<-8&(B $(C@L5?=CE07A0m(B $(CGO8i(B, $(C1W(B $(C9fGb?!(B -$(C@V4B(B $(CEX=:F.0!(B $(C@L5?GO?)(B $(C?@0m(B, $(CD?<-4B(B $(CGW;s(B $(CH-8i3;?!(B $(C@V557O(B $(C5K4O4Y(B. - - >> C-n $(C@;(B $(C;g?kGO?)(B, $(CD?<-8&(B $(CH-8i@G(B $(CGO4\:84Y(B $(C9X@87N(B $(C@L5?=CDQ(B $(C:8<<(B - $(C?d(B. $(C9+>y@L(B $(C@O>n334O1n(B? $(CD?<-@G(B $(C@'D!4B(B $(C>n6;0T(B $(C:/GO?4=@4O1n(B? - - $(CGQ9.@Z(B $(C4\@'@G(B $(C@L5?@87N4B(B $(C9x0E7S4Y0m(B $(C;}0"5G8i(B, $(C4\>n4\@'7N(B $(C@L5?GR(B -$(C<v55(B $(C@V=@4O4Y(B. ESC f $(C7N(B $(CGQ(B $(C4\>n:P(B $(C>U@87N(B $(CAxG`GO0m(B, ESC b $(C7N(B $(CGQ(B $(C4\>n:P(B -$(C@L@|@87N(B $(C5G59>F0)4O4Y(B. - -$(CAV@G(B: $(C@O:;>n?!(B $(C4kGX<-4B(B, $(C4\>n@G(B $(C2w4B(B $(C4\@'@;(B $(C@N=DGR(B $(C<v(B $(C>x=@4O(B - $(C4Y88(B, $(C@G;g@{@N(B $(C9.@}@;(B $(C4\>n@G(B $(C2w4B(B $(C4\@'7N<-(B $(CGO0m(B $(C@V=@4O(B - $(C4Y(B. - - >> ESC f $(C3*(B ESC b $(C8&(B $(C8nH8A$55(B $(CE8@LGAGO?)(B $(C:8<<?d(B. C-f $(C3*(B C-b $(C?M(B - $(C:4?kGO?)(B $(C:8<<?d(B. - - C-f $(C3*(B C-b $(C?!(B $(C4kGQ(B, ESC f $(C3*(B ESC b $(C@G(B $(C@/;g<:?!(B $(CAV8qGO<<?d(B. $(C4k:N:P(B -$(C@G(B $(C0f?l(B, ESC <$(C9.@Z(B>$(C4B(B $(C9.<-0|0h@G(B $(CC38.?!(B $(C;g?k5G0m(B, $(CGQFm(B C-<$(C9.@Z(B>$(C4B(B $(C1W0M(B -$(C:84Y55(B $(C4u?m(B $(C1b:;@{@N(B $(C4k;s(B($(C9.@Z6s5g0!(B $(CG`@L6s5g0!(B)$(C?!(B $(C4kGQ(B $(CA6@[?!(B $(C;g?k5K(B -$(C4O4Y(B. - - C-a $(C?M(B C-e $(C55(B $(C>K0m(B $(C@V@88i(B $(CFm8.GQ(B $(C8m7I>n@T4O4Y(B. C-a $(C4B(B $(CD?<-8&(B $(CG`@G(B -$(C<15N7N(B $(C@L5?=CE00m(B, C-e $(C4B(B $(CG`@G(B $(C3!@87N(B $(C@L5?=CE54O4Y(B. - - >> C-a $(C8&(B 2$(CH8(B, $(C1W8.0m3*<-(B C-e $(C8&(B 2$(CH8(B $(C@T7BGO?)(B $(C:8<<?d(B. $(C@L5i@G(B $(C8m(B - $(C7I>n8&(B 2$(CH8@L;s(B $(C9]:9GO4u6s55(B, $(CD?<-4B(B $(C1W(B $(C@L;s(B $(C@L5?GOAv(B $(C>J4B(B $(C0M(B - $(C?!(B $(CAV@G(B. - - $(C5N0!Av(B $(C4u(B, $(C0#4\GQ(B $(CD?<-(B $(C@L5?(B $(C8m7I>n0!(B $(C@V=@4O4Y(B. $(CH-@O@G(B $(C<15N7N(B $(C@L5?(B -$(CGO4B(B ESC < $(C?M(B, $(CH-@O@G(B $(C3!@87N(B $(C@L5?GO4B(B ESC > $(C@T4O4Y(B. - - $(CEX=:F.(B $(C3;?!<-(B, $(CD?<-0!(B $(CA8@gGO4B(B $(C@'D!8&(B "$(CFw@NF.(B"$(C6s0m(B $(C:N8(4O4Y(B. $(C9Y2Y(B -$(C>n(B $(C8;GO8i(B, $(CD?<-4B(B, $(CEX=:F.@G(B $(C>n5p?!(B $(C@V4B0!8&(B $(CH-8i@'?!(B $(C3*E83;0m(B $(C@V4B(B $(C0M(B -$(C@T4O4Y(B. - - $(C>F7!?!(B $(C4\<xGQ(B $(C@L5?A6@[?!(B $(C4kGX<-(B $(C?d>`GU4O4Y(B. $(C@L(B $(CA_?!4B(B, $(C4\>n3*(B $(CG`(B -$(C4\@'7N@G(B $(C@L5?8m7I>n55(B $(CFwGT5G>n(B $(C@V=@4O4Y(B. - - C-f $(CGQ(B $(C9.@Z(B $(C>U@87N(B $(CAxG`GQ4Y(B - C-b $(CGQ(B $(C9.@Z(B $(C5Z7N(B $(C5G59>F0#4Y(B - - ESC f $(CGQ(B $(C4\>n(B $(C>U@87N(B $(CAxG`GQ4Y(B - ESC b $(CGQ(B $(C4\>n(B $(C5Z7N(B $(C5G59>F0#4Y(B - - C-n $(C4Y@=(B $(CG`@87N(B $(C@L5?(B - C-p $(C@L@|(B $(CG`@87N(B $(C@L5?(B - - ESC ] $(C4\6t@G(B $(C3!@87N(B $(C@L5?(B - ESC [ $(C4\6t@G(B $(C<15N7N(B $(C@L5?(B - - C-a $(CG`@G(B $(CCVCJ7N(B $(C@L5?(B - C-e $(CG`@G(B $(CCVHD7N(B $(C@L5?(B - - ESC < $(CH-@O@G(B $(CCVCJ7N(B $(C@L5?(B - ESC > $(CH-@O@G(B $(CCVHD7N(B $(C@L5?(B - - >> $(C0"0"@G(B $(C8m7I>n8&(B $(C=C55GO?)(B $(C:8<<?d(B. $(C@L5i@G(B $(C8m7I>n4B(B, $(C0!@e(B $(C@ZAV(B - $(C;g?k5G4B(B $(C0M@T4O4Y(B. $(CCVHD@G(B $(C5N0!Av4B(B, $(C@L(B $(C@e<R?M4B(B $(C63>nAx(B $(C0w@8(B - $(C7N(B $(C@L5?GO1b(B $(C6'9.?!(B, C-v $(C3*(B ESC v $(C8&(B $(C;g?kGO?)(B $(C?)1b7N(B $(C5G59>F(B - $(C?@557O(B $(CGO<<?d(B. - - Emacs$(C@G(B $(C4Y8%(B $(C8m7I?M(B $(C6H00@L(B, $(C@L5i@G(B $(C8m7I>n?!4B(B, $(C9]:9H8<v8&(B $(CAvA$GO(B -$(C4B(B $(C@N<v8&(B $(CAY(B $(C<v(B $(C@V=@4O4Y(B. $(C@L8&(B $(C@'GX<-4B(B, $(C8m7I>n8&(B $(C@T7BGO1b(B $(C@|?!(B, C-u -$(C?!(B $(C@L>n<-(B $(C9]:9GO4B(B $(CH8<v8&(B $(C@T7BGU4O4Y(B. - - $(CNc?98&(B $(C5i8i(B, C-u 8 C-f $(C6s0m(B $(CGO8i(B, 8$(C9.@Z:P(B $(C>U@87N(B $(C@L5?GU4O4Y(B. - - >> C-n $(CH$@:(B C-p $(C?!(B $(C@{4gGQ(B $(C@N<v8&(B $(CAvA$GO0m(B, $(C@OH8@G(B $(C@L5?@87N(B $(C0!4I(B - $(CGQGQ(B, $(C@L(B $(CG`@G(B $(C1YC3?!(B $(C?@557O(B $(CGO?)(B $(C:8<<?d(B. - - C-v $(C3*(B ESC v $(C?!(B $(C4kGX<-4B(B $(CA61](B $(C4Y8(4O4Y(B. $(C@L(B $(C0f?l(B, $(CAvA$5H(B $(C<v@G(B $(CG`88(B -$(CH-8i@;(B $(C@L5?GO4B(B $(C0M@L(B $(C5K4O4Y(B. - - >> C-u 3 C-v $(C6s0m(B $(C@T7BGO?)(B $(C:8<<?d(B. - - $(C?x7!(B $(C@Z8.7N(B $(C5G59>F0!4B5%4B(B, C-u 3 ESC v $(C8&(B $(C;g?kGO8i(B $(C5K4O4Y(B. - -$(CA_Av8m7I>n(B -========== - - C-g $(C6s4B(B $(C8m7I>n@L8g(B, $(C@T7B@;(B $(CGJ?d7N(B $(CGO4B(B $(C0M0z(B $(C00@:(B $(C8m7I>n8&(B $(CA_AvGR(B -$(C<v(B $(C@V=@4O4Y(B. $(C?98&(B $(C5i8i(B, $(C@N<v8&(B $(C@T7BGO0m(B $(C@V4B(B $(C55A_@L3*(B, 2$(C03(B $(C@L;s@G(B $(CE0@T(B -$(C7B@;(B $(CGJ?d7N(B $(CGO4B(B $(C8m7I>n8&(B $(CGQC"(B $(C@T7BGO0m(B $(C@V4B(B $(C55A_?!(B, $(C1W0M@;(B $(CA_AvGO0m(B $(C=M(B -$(C@88i(B, C-g $(C8&;g?kGO8i(B $(C5K4O4Y(B. - - >> C-u 100 $(C8&(B $(CE8@LGAGO?)(B $(C@N<v8&(B 100$(C@87N(B $(C<3A$GO0m(B, C-g $(C8&(B $(CE8@LGA(B - $(CGO<<?d(B. $(C1W(B $(C5Z?!(B C-f $(C8&(B $(CE8@LGAGO?)(B $(C:8<<?d(B. $(C8n9.@Z(B $(C@L5?GO?4=@(B - $(C4O1n(B? $(C88>`(B, $(C@_8xGO?)(B ESC $(C8&(B $(C@T7BGX(B $(C9v7H@;(B $(C6'55(B, C-g $(C8&(B $(C@T7BGO(B - $(C8i(B $(CCk<R=CE3(B $(C<v(B $(C@V=@4O4Y(B. - -$(C?!7/(B -==== - - $(C6'7N4B(B, Emacs$(C?!<-(B $(CGc?k5G0m(B $(C@VAv(B $(C>J4B(B $(CA6@[@;(B $(CGX9v8.4B(B $(C@{@L(B $(C@V=@4O(B -$(C4Y(B. $(C?98&(B $(C5i8i(B, $(C8m7I>n0!(B $(CA$@G5G>n(B $(C@VAv(B $(C>J4B(B $(CD\F.7Q(B*$(CE08&(B $(C@T7BGX(B $(C9v80(B $(C6'(B -$(C?!4B(B, Emacs$(C4B(B $(C:'@;(B $(C?o8.0m(B, $(C1W8.0m(B, $(CH-8i@G(B $(CA&@O(B $(C9X?!(B, $(C9+>y@L(B $(C3*;&4B(B $(C0!(B -$(C8&(B $(CG%=CGU4O4Y(B. - - Emacs $(C9vA/?!(B $(C5{6s<-4B(B, $(C@L(B $(C@T9.Fm?!(B $(C>2?)A.(B $(C@V4B(B $(C0M@;(B $(C=GG`GR(B $(C<v(B $(C>x(B -$(C4B(B $(C0f?l0!(B $(C@V@;(B $(C<v(B $(C@V=@4O4Y(B. $(C1W?M(B $(C00@:(B $(C0f?l?!4B(B, $(C?!7/8^<<Av0!(B $(CG%=C5G9G(B -$(C7N(B, $(C>n4@(B $(C0M@N0!(B $(C@L5?E08&(B $(C4)8#0m(B, $(C1W(B $(C4Y@=@G(B $(C:N:P@87N(B $(CAxG`GO?)(B $(CAV<<?d(B. - -$(C@)55?l(B -====== - - Emacs$(C4B(B $(C8n03@G(B $(C@)55?l8&(B $(C0!Av4B(B $(C0M0z(B, $(C1W(B $(C0"0"?!(B $(C4kGO?)(B $(CEX=:F.8&(B $(CG%(B -$(C=CGR(B $(C<v(B $(C@V=@4O4Y(B. $(CGoGA3*(B, $(C8n0!Av@G(B $(C8m7I>n7N:NEM@G(B $(CCb7B@;(B $(CG%=CGO1b(B $(C@'GO(B -$(C?)(B $(C3*E83-(B $(C?):P@G(B $(C@)55?l8&(B $(CAv?l1b(B $(C@'GO?)(B, $(C4Y@=@G(B $(C8m7I>n8&(B $(C>K(B $(CGJ?d0!(B $(C@V=@(B -$(C4O4Y(B. - - C-x 1 $(C@)55?l8&(B 1$(C037N(B $(CGQ4Y(B. - - C-x 1 $(C4B(B, $(C4Y8%(B $(C@)55?l8&(B $(CAv?l0m(B, $(CD?<-0!(B $(C@V4B(B $(C@)55?l8&(B, $(CH-8i@|C<7N(B -$(CH.@eGU4O4Y(B. - - >> $(CD?<-8&(B $(C@L(B $(CG`?!(B $(C0.0m(B $(C?M<-(B, C-u 0 C-l $(C@L6s0m(B $(CE8@LGAGU4O4Y(B. - - >> C-h k C-f $(C6s0m(B $(CE8@LGAGO<<?d(B. $(C;u7N?n(B $(C@)55?l0!(B C-f $(C8m7I>n@G(B $(C55(B - $(CE%8UF.8&(B $(CG%=CGO1b(B $(C@'GO?)(B $(C3*E8320z(B $(C5?=C?!(B, $(C@L(B $(C@)55?l0!(B $(C>n6;0T(B - $(CAY>n5e4B0!(B $(C0|B{GO<<?d(B. - - >> C-x 1$(C@L6s0m(B $(CE8@LGAGO0m(B, $(C55E%8UF.0!(B $(C3*E8354x(B $(C@)55?l8&(B $(CAv?l<<(B - $(C?d(B. - -$(C;p@T0z(B $(C;hA&(B -=========== - - $(CEX=:F.8&(B $(CE8@LGAGO0m(B $(C=M@88i(B, $(C4\<xHw(B $(C1W0M@;(B $(CE8@LGAGO4B(B $(C0M88@87N(B $(C1&(B -$(CBz=@4O4Y(B. $(C4+?!(B $(C:8@L4B(B $(C9.@Z(B ('A','7','*','$(C$"(B'$(C5n(B)$(C@:(B Emacs$(C?!(B $(C@GGO?)(B $(CEX=:(B -$(CF.6s0m(B $(C0#AV5G0m(B,$(C1W4k7N(B $(C;p@T5K4O4Y(B. $(CG`@G(B $(C3!@:(B $(C03G`9.@Z7N(B $(C3*E83*0m(B, $(C@L(B -$(C0M@;(B $(C@T7BGO4B5%4B(B<Return> $(C@;(B $(CE8@LGAGU4O4Y(B. - - $(CAw@|?!(B $(C@T7BGQ(B $(C9.@Z8&(B $(C;hA&GO4B5%4B(B, <Delete> $(C8&(B $(C@T7BGU4O4Y(B. -<Delete> $(C4B(B,$(CE0:85e?!<-(B "Delete"$(C6s0m(B $(C=a@V4B(B $(CE08&(B $(C4-7/<-(B $(C@T7BGU4O4Y(B. -"Delete" $(C4k=E?!(B"Rubout"$(C6s0m(B $(C=a@V@;(B $(CAv55(B $(C8p8(4O4Y(B. $(C:84Y(B $(C@O9]@{@87N(B, -<Delete> $(C4B(B, $(CGv@gD?<-0!(B $(C@V4B(B $(C@'D!@G(B $(CAw@|@G(B $(C9.@Z8&(B $(C;hA&GU4O4Y(B. - - >> $(C9.@Z8&(B $(C8n03A$55(B $(CE8@LGAGO0m(B, $(C1W8.0m3*<-(B $(C1W0M@;(B <Delete> $(C8&(B $(C;g(B - $(C?kGO?)(B $(C;hA&GO<<?d(B. - - >> $(C?@8%BJ86Ax@;(B $(C3Q@;(B $(C6'1nAv(B $(CEX=:F.8&(B $(CE8@LGAGO<<?d(B. $(CEX=:F.0!(B $(CGQ(B - $(CG`@G(B $(CFx(B $(C@L;s@87N(B $(C1f0T(B $(C5G8i(B, $(C1W(B $(CG`@:(B $(CH-8i@87N:NEM(B $(C:q>nA.3*?M(B - "$(C0h<S(B"$(C5K4O4Y(B. $(C?l4\?!(B $(C@V4B(B '\'$(C1bH#4B(B, $(C1W(B $(CG`@L(B $(C0h<S5G0m(B $(C@V4B(B - $(C0M@;(B $(C3*E83;0m(B $(C@V=@4O4Y(B. Emacs$(C4B(B, $(CGv@g(B $(CFmA}A_@G(B $(C@'D!0!(B $(C:8@L(B - $(C557O(B $(CG`@;(B $(C=:E)7QGU4O4Y(B. $(CH-8i@G(B $(C?@8%BJ(B $(CH$@:(B $(C?^BJ@G(B $(C3!?!(B $(C@V4B(B - '\'$(C1bH#4B(B, $(C1W(B $(C9fGb?!(B $(CG`@L(B $(C>FAw(B $(C@L>nAv0m(B $(C@V4B(B $(C0M@;(B $(C3*E83;0m(B - $(C@V=@4O4Y(B. - - $(C@L0M@:(B, $(C1[7N(B $(C<38mGO4B(B $(C0M:84Y(B $(C=GA&7N(B $(CGX:84B(B $(CFm@L(B $(C@_(B $(C>K(B $(C<v(B $(C@V0ZAv?d(B. - - >> $(CA61]@|(B $(C@T7BGQ(B, $(C0h<S5H(B $(CG`@G(B $(C@'?!(B $(CD?<-8&(B $(C0.0m0!<-(B, C-d $(C7N(B $(CEX(B - $(C=:F.8&(B $(C;hA&GO0m(B, $(CEX=:F.0!(B $(CGQG`?!(B $(C5i>n0!557O(B $(CGX:8<<?d(B. $(C0h<S@;(B - $(C3*E83;4B(B '\'$(C1bH#4B(B $(CAv?vA3Av?d(B? - - >> $(CD?<-8&(B $(CG`@G(B $(C<15N7N(B $(C@L5?GO0m(B, <Delete> $(C8&(B $(C@T7BGO<<?d(B. $(C@L0M@:(B - $(C1W(B $(CG`@G(B $(CAw@|@G(B $(CG`(B $(C4\6tAv@=@;(B $(C;hA&GO9G7N(B, $(C1W(B $(CG`@L(B $(C>U@G(B $(CG`0z(B - $(C@L>nA.(B $(C9v834O4Y(B. $(C@L>nAx(B $(CG`@L(B $(CH-8i@G(B $(CFx:84Y(B $(C1f0T(B $(C5G8i(B, $(C0h<S(B - $(CG%=C0!(B $(C5G0ZAv?d(B. - - >> <Return> $(C8&(B $(C4)8#0m(B, $(CGQ9x(B $(C4u(B $(CG`4\6tAv@=@;(B $(C;p@TGO<<?d(B. - - Emacs$(C@G(B $(C4k:N:P@G(B $(C8m7I>n4B(B, $(C9]:9(B $(CH8<v8&(B $(CAY(B $(C<v(B $(C@V=@4O4Y(B. $(C@L0M@:(B, $(C9.(B -$(C@Z(B $(C;p@T?!(B $(C4kGX<-55(B $(C@{?k5K4O4Y(B. - - >> C-u 8 * $(C6s0m(B $(C@T7BGO?)(B $(C:8<<?d(B. $(C>n6;0T(B $(C5G>z=@4O1n(B? - - $(C5N03@G(B $(CG`(B $(C;g@L?!(B $(C0x9iG`@;(B $(C885i0m(B $(C=M@:(B $(C0f?l?!4B(B, $(C5N9xB0(B $(CG`@G(B $(C<15N(B -$(C7N(B $(C0!<-(B, C-o $(C8&(B $(C@T7BGU4O4Y(B. - - >> $(C@{4gHw(B $(CG`@G(B $(C<15N?!(B $(C0!<-(B, $(C0E1b<-(B C-o $(C8&(B $(C@T7BGO?)(B $(C:8<<?d(B. - - $(C@L0M@87N(B, Emacs$(C?!<-(B, $(CEX=:F.8&(B $(C@T7BGO0m(B, $(C6GGQ(B $(CF280(B $(C0M@;(B $(C<vA$GO4B(B -$(C0!@e(B $(C1b:;@{@N(B $(C9f9}@;(B $(C9h?n(B $(C0M@L(B $(C5G>z=@4O4Y(B. $(C9.@Z?M(B $(C00@L(B, $(C4\>n3*(B $(CG`55(B -$(C;hA&GR(B $(C<v(B $(C@V=@4O4Y(B. $(C;hA&A6@[?!(B $(C4kGX<-(B $(C?d>`GO8i(B $(C4Y@=0z(B $(C00=@4O4Y(B. - - <Delete> $(CD?<-Aw@|@G(B $(C9.@Z8&(B $(C;hA&(B - C-d $(CD?<-0!(B $(C@V4B(B $(C9.@Z8&(B $(C;hA&(B - - ESC <Delete> $(CD?<-Aw@|@G(B $(C4\>n8&(B $(C;hA&(B - ESC d $(CD?<-@'D!(B $(C@LHD?!(B $(C@V4B(B $(C4\>n8&(B $(C;hA&(B - - C-k $(CD?<-@'D!7N:NEM(B $(CG`3!1nAv8&(B $(C;hA&(B - - $(C9+>y@N0!8&(B $(C;hA&GQ(B $(CHD?!(B, $(C1W0M@;(B $(C?x7!4k7N(B $(C5G598.0m(B $(C=M@;(B $(C6'0!(B $(C@V=@4O(B -$(C4Y(B. Emacs$(C4B(B, $(CGQ9.@Z:84Y(B $(CE+(B $(C4\@'7N(B $(C;hA&8&(B $(CG`GQ(B $(C6'?!4B(B, $(C;hA&GQ(B $(C3;?k@;(B -$(C:8A8GO?)(B $(C5S4O4Y(B. $(C?x7!4k7N(B $(C5G598.4B5%4B(B, C-y $(C8&(B $(C;g?kGU4O4Y(B. $(CAV@GGX>_(B -$(CGO4B(B $(C0M@:(B, C-y $(C8&(B $(C;hA&8&(B $(CG`GQ(B $(C@e<R88@L(B $(C>F4O6s(B, $(C>n5p?!<-6s55(B $(CGR(B $(C<v(B $(C@V4Y(B -$(C4B(B $(C0M@T4O4Y(B. C-y $(C4B(B, $(C:8A85H(B $(CEX=:F.8&(B $(CGv@g(B $(CD?<-0!(B $(C@V4B(B $(C@e<R?!(B $(C;p@TGO1b(B -$(C@'GQ(B $(C8m7I>n@L9G7N(B, $(C@L0M@;(B $(C;g?kGO?)(B $(CEX=:F.8&(B $(C@L5?GR(B $(C<v(B $(C@V=@4O4Y(B. - - $(C;hA&8&(B $(CG`GO4B(B $(C8m7I>n?!4B(B, "Delete" $(C8m7I>n?M(B, "Kill" $(C8m7I>n0!(B $(C@V=@(B -$(C4O4Y(B. "Kill" $(C8m7I>n?!<-4B(B $(C;hA&5H(B $(C0M@:(B $(C:8A85GAv88(B, "Delete"$(C?!<-4B(B $(C:8A8(B -$(C5GAv(B $(C>J=@4O4Y(B. $(C4\(B, $(C9]:9H8<v0!(B $(CAV>nAv8i(B, $(C:8A85K4O4Y(B. - - >> C-n $(C@;(B 2$(CH8(B $(CA$55(B $(CE8@LGAGO0m(B, $(CH-8i@G(B $(C@{4gGQ(B $(C@e<R7N(B $(C@L5?GO<<?d(B. - $(C1W8.0m(B, C-k $(C7N(B, $(C1W(B $(CG`@;(B $(C;hA&GO<<?d(B. - - $(CC99xB0@G(B C-k $(C7N(B $(C1W(B $(CG`@G(B $(C3;?k@L(B $(C;hA&5G0m(B, $(CGQ9x4u(B C-k $(C8&(B $(C@T7BGO8i(B, -$(C1W(B $(CG`(B $(C@Z=E@L(B $(C;hA&5K4O4Y(B. $(C88>`(B, C-k $(C?!(B $(C9]:9H8<v8&(B $(CAvA$GQ(B $(C0f?l?!4B(B, $(C1W(B -$(CH8<v88E-@G(B $(CG`@L(B($(C3;?k0z(B $(CG`@Z=E0!(B $(C5?=C?!(B)$(C;hA&5K4O4Y(B. - - $(CAv1](B $(C;hA&5H(B $(CEX=:F.4B(B, $(C:8A85G0m(B $(C@V@89G7N(B, $(C1W0M@;(B $(C2t3>(B $(C<v(B $(C@V=@4O4Y(B. -$(C@L8&(B $(C@'GX<-4B(B, C-y $(C8&(B $(CE8@LGAGU4O4Y(B. - - >> C-y $(C8&(B $(C=CGhGO?)(B $(C:8<<?d(B. - - C-k $(C8&(B $(C8n9x@L3*(B $(C0h<SGO?)(B $(CG`GO8i(B, $(C;hA&5H(B $(CEX=:F.4B(B, $(CA$8.5G>n(B $(C:8A85G(B -$(C0m(B, C-y$(C7N(B, $(C1W(B $(C@|:N0!(B $(C2t3;>nA}4O4Y(B. - - >> C-k $(C8&(B $(C8n9x(B $(CE8@LGAGO?)(B $(C:8<<?d(B. - - >> $(CEX=:F.8&(B $(C2t3;4B5%4B(B, C-y $(C@T4O4Y(B. $(CD?<-8&(B $(C8nG`(B $(C9X@87N(B $(C@L5?=CE0(B - $(C0m(B, $(CGQ9x(B $(C4u(B C-y $(C8&(B $(CE8@LGAGO?)(B $(C:8<<?d(B. $(C@L0M@87N(B $(CEX=:F.@G(B $(C:9;g(B - $(C0!(B $(C5K4O4Y(B. - - $(CGv@g(B $(C>n62(B $(CEX=:F.0!(B $(C:8A85G>n(B $(C@V0m(B, $(C4u183*(B $(C4Y8%(B $(CEX=:F.8&(B $(C;hA&GO8i(B -$(C>n6;0T(B $(C5G0Z=@4O1n(B? C-y$(C4B(B, $(C0!@e(B $(CCV1Y(B $(C;hA&5H(B $(C0M@;(B $(C2tA}>n3@4O4Y(B. - - >> $(CG`@;(B $(C;hA&GO0m(B, $(CD?<-8&(B $(C@L5?=CE00m(B, $(C4Y8%(B $(CG`@;(B $(C;hA&GO<<?d(B. C-y - $(C8&(B $(CG`GO8i(B, 2$(C9xB0@G(B $(CG`@L(B $(C3*?I4O4Y(B. - -$(CCk<R(B(UNDO) -========== - - $(C>pA&6s55(B, $(CEX=:F.8&(B $(C:/0fGO?4Av88(B, $(C1W0M@;(B $(C?x7!4k7N(B $(C5G598.0m(B $(C=M@;(B $(C6'(B -$(C4B(B C-x u$(C7N(B $(C0mD(4O4Y(B. $(C:8Ek@:(B $(C@_8x5H(B $(C8m7I>n8&(B $(C9+H?7N(B $(CGO4B(B $(C@[5?@;(B $(CGU4O4Y(B. -$(C9]:9GX<-(B UNDO$(C8&(B $(CG`GO7A0m(B $(CGR(B $(C6'4B(B, $(C8n9x@L3*(B $(C1W(B $(C8m7I>n8&(B $(CG`GO8i(B $(C5G557O(B -$(C5G>n(B $(C@V=@4O4Y(B. - - >> $(C@L(B $(CG`@;(B C-k$(C7N(B $(CAv?l<<?d(B. $(C1W8.0m(B, C-x u$(C7N(B $(C5G598.<<?d(B. - - C-_$(C4B(B, UNDO$(C8&(B $(CG`GO4B(B, $(C6G(B $(CGO3*@G(B $(C8m7I>n@T4O4Y(B. $(C1b4I@:(B, C-x u$(C?M(B $(C00(B - $(C=@4O4Y(B. - - C-_$(C3*(B C-x u$(C?!(B UNDO$(C@G(B $(CH8<v8&(B $(CAY(B $(C<v(B $(C@V=@4O4Y(B. - - -$(CH-@O(B -==== - - $(CEX=:F.@G(B $(C:/0f@;(B $(C?518@{@87N(B $(CGO1b(B $(C@'GX<-4B(B, $(C1W0M@;(B $(CH-@O?!(B $(C:8A8GO?)(B -$(C>_(B $(CGU4O4Y(B. $(C:8A8GOAv(B $(C>J@88i(B, $(CG`GQ(B $(C:/0f@:(B, Emacs$(C8&(B $(CA>7aGO8i(B $(C5?=C?!(B $(C@R>n(B -$(C9v8.0T(B $(C5K4O4Y(B. - - $(CAv1](B $(C:80m(B $(C@V4B(B $(CH-@O?!(B $(C4kGX<-(B, $(C4g=E@L(B $(CFmA}@;(B $(CG`GQ(B $(C0M@;(B $(C=a3V=@4O4Y(B. -$(CAv1](B, $(C:80m(B $(C@V4B(B $(CH-@O@L6u(B $(C0M@:(B, $(C0#4\Hw(B $(C8;GO8i(B $(CFmA}GO0m(B $(C@V4B(B $(CH-@O(B $(C@ZC<@T(B -$(C4O4Y(B. - - $(C4g=E@L(B $(CH-@O@;(B $(C<<@L:j(B($(C:8A8GQ4Y(B)$(CGO1b(B $(C1nAv(B, $(CAv1]1nAv@G(B $(C:/0f@:(B $(CFmA}GO(B -$(C0m@V4B(B $(CH-@O?!(B $(C=a3V4B(B $(C0M@:(B $(C>F4U4O4Y(B. $(C1W0M@:(B, $(C4g=E@L(B $(C@L?M(B $(C00@L(B $(C:/0fGO0m(B -$(C=MAv(B $(C>J@:5%55(B, $(C55A_1nAv(B $(C:/0f@;(B $(C0!GQ(B $(C0M@L(B $(CA&8Z4k7N(B $(C=a3V>nAv4B(B $(C@O@L(B $(C>x55(B -$(C7O(B $(CGO1b(B $(C@'GX<-(B $(C@T4O4Y(B. - - $(C<<@L:j@;(B $(CG`GQ(B $(C5ZA6Bw(B $(C:/0fGQ(B $(C0M@L(B $(C@_8x(B $(C5G>n(B $(C@V@;(B $(C6'8&(B $(C@'GO?)(B Emacs -$(C4B(B $(C@L8'@;(B $(C:/0fGO?)(B $(C?x:;(B $(CH-@O@;(B $(C321i4O4Y(B. - -$(C:q0m(B: $(C6GGQ(B, Emacs$(C4B(B $(C?9CxGR(B $(C<v(B $(C>x4B(B $(C;sEB?!(B $(C4k:qGO?)(B, $(C@OA$GQ(B $(C=C(B - $(C0#0#0]@87N(B $(C@Z5?@{@87N(B $(CFmA}GO0m(B $(C@V4B(B $(CH-@O@G(B $(C3;?k@;(B $(C@L8'(B - $(C@;(B $(C:/0fGQ(B $(CH-@O?!(B $(C<<@L:jGU4O4Y(B. $(C@L0M?!(B $(C@GGX(B, $(C88@O@G(B $(C0f?l(B - $(C4B(B $(CG`GQ(B $(C:/0f?!(B $(C4kGO?)(B $(CCV<RGQ@G(B $(CGGGX7N(B $(C3!3;557O(B $(CGO0m(B $(C@V(B - $(C=@4O4Y(B. - - $(CH-8i@G(B $(C>F7!(B $(CBJ@;(B $(C:88i(B, $(C@L?M(B $(C00@:(B $(C6f@87N(B $(C8p5e6s@N@L(B $(CG%=C5G>n(B $(C@V4Y(B -$(C0m(B $(C;}0"GU4O4Y(B. - -($(C?9(B) [--]J:--**-Mule: MULE.tut (Fundamental) ---55%-------------- - - - $(C@L(B Emacs$(CF)Ed8.>s@G(B $(C:9;g:;@:(B MULE.tut$(C@L6s0m(B $(C:R8.0m(B $(C@V=@4O4Y(B. $(CH-@O(B -$(C@;(B $(CH-@N5e(B($(CH-@O@;(B $(CC#>F<-(B $(C9vF[?!(B $(C@P>n3V4B(B $(C0M(B)$(CGO8i(B, MULE.tut$(C@G(B $(C:N:P?!(B $(CG%=C(B -$(C5K4O4Y(B. $(C?98&(B $(C5i8i(B, new-file$(C@L6s4B(B $(C@L8'@G(B $(CH-@O@;(B $(CH-@N5eGO?44Y8i(B, "Mule: -new-file"$(C@L6s4B(B $(C8p5e6s@N@L(B $(C5G0ZAv?d(B. - -$(CAV@G(B: $(C8p5e6s@N?!(B $(C4kGX<-4B(B $(C3*A_?!(B $(C<38mGO0Z=@4O4Y(B. $(C@a1q(B $(C1b4Y8.=C(B - $(C1b8&(B. - - $(CH-@O@;(B $(CH-@N5eGO0E3*(B, $(C<<@L:jGO4B(B $(C8m7I>n4B(B, $(CAv1]1nAv@G(B $(C0M0z4B(B $(C4^8.(B, -2$(C03@G(B $(C9.@Z7N(B $(C5G>n(B $(C@V=@4O4Y(B. C-x $(C?!(B $(C@L>n<-(B $(C@T7BGO4B(B $(C9.@Z0!(B, $(CH-@O?!(B $(C4kGX(B -$(C<-(B $(CG`GO4B(B $(CA6@[@;(B $(C3*E83@4O4Y(B. - - $(CGQ0!Av(B $(C4u(B, $(CAv1]1nAv@G(B $(C0M0z(B $(C4Y8%(B $(CA!@:(B, $(CH-@N5e(B $(C=C(B, $(CH-@O8m@;(B Emacs$(C0!(B -$(C90>n:>4O4Y(B. $(C@L0M@;(B, $(C4\8;7N:NEM(B $(C@N<v8&(B $(C@P>n5i?)?@4B(B $(C8m7I>n6s0m(B $(C8;GO0m(B -$(C@V=@4O4Y(B. - - -$(CAV@G(B: $(C@L(B $(C0f?l4B(B $(CH-@O8m(B $(C@T4O4Y(B. - - C-x C-f $(CH-@O@;(B $(CC#4B4Y(B($(CH-@N5eGQ4Y(B) - - Emacs$(C4B(B $(CH-@O8m@;(B $(C90>n?I4O4Y(B. $(C@L0M@:(B, $(CH-8i9X@G(B $(CG`?!(B $(C3*E8334O4Y(B. -$(CH-@O8m@;(B $(CAvA$GO0m(B $(C@V4B(B $(C:N:P@:(B, $(C9L4O9vF[6s0m(B $(C:R8.?l4B(B $(C0M@T4O4Y(B. $(C9L4O9v(B -$(CF[4B(B $(C@L?M(B $(C00@L(B $(C;g?k5K4O4Y(B. $(CH-@O8m?!(B $(C@L>n<-(B, $(C8.4xE08&(B $(C4)8#8i(B, $(C9L4O9vF[(B -$(C?!(B $(CG%=C5G>nAx(B $(C3;?k@:(B $(C4u(B $(CGJ?dGOAv(B $(C>J1b(B $(C6'9.?!(B $(CAv?vA.(B $(C9v834O4Y(B. - - >> C-x C-f$(C6s0m(B $(CE8@LGAGQ(B $(C5Z?!(B C-g$(C6s0m(B $(CE8@LGAGO<<?d(B. $(C9L4O9vF[@G(B - $(C3;?k@;(B $(CCk<RGO0m(B, $(C6GGQ(B, C-x C-f$(C8m7I>n55(B $(CCk<RGU4O4Y(B. $(C@L780T(B - $(CGO?)(B, $(C>n62(B $(CH-@O55(B $(CC#Av(B $(C>J=@4O4Y(B. - - $(C@L9x?!4B(B $(CH-@O@;(B $(C<<@L:jGO?)(B $(C:8<<?d(B. $(CAv1]1nAv@G(B $(C:/0f@;(B $(C:8A8GO1b(B $(C@'(B -$(CGX<-4B(B $(C4Y@=0z(B $(C00@:(B $(C8m7I>n8&(B $(C;g?kGU4O4Y(B. - - C-x C-s $(CH-@O@;(B $(C<<@L:jGQ4Y(B - - Emacs$(C@G(B $(C3;?k@:(B $(CH-@O?!(B $(C=a3;>nA}4O4Y(B. $(C<<@L:jGR(B $(C6'(B, $(C?x:;@G(B $(CH-@O@:(B $(C;u(B -$(C7N?n(B $(C@L8'@;(B $(C:Y?)<-(B $(C320\Av1b(B $(C@V@89G7N(B $(C3;?k@:(B $(C>x>nAvAv(B $(C>J=@4O4Y(B. $(C@L(B $(C;u(B -$(C7N?n(B $(C@L8'@:(B $(C?x:;@G(B $(CH-@O@G(B $(C@L8'?!(B '~'$(C8&(B $(C:Y@N(B $(C0M@T4O4Y(B. - - $(C%;<<@L:j0!(B $(C3!3*8i(B, Emacs$(C4B(B $(C<<@L:jGQ(B $(CH-@O@G(B $(C@L8'@;(B $(CG%=CGU4O4Y(B. - - >> C-x C-s$(C6s0m(B $(CE8@LGAGO0m(B $(CF)Ed8.>s@G(B $(C:9;g:;@;(B $(C<<@L:jGO<<?d(B. - $(C@L(B $(C6'(B, $(CH-8i(B $(C9XBJ?!(B "Wrote ...../MULE.tut"$(C6s0m(B $(CG%=C5K4O4Y(B. - - $(C;u7N?n(B $(CH-@O@;(B $(C885i(B $(C6'(B, $(C86D!(B $(C@L@|:NEM(B $(C@V4x(B $(CH-@O@;(B $(CH-@N5eGO4B(B $(C5mGQ(B -$(C5?@[@;(B $(CGU4O4Y(B. $(C1W780T(B $(CGO?)(B, $(CH-@N5eGQ(B $(CH-@O?!(B $(CE8@LGAGO?)(B $(C0)4O4Y(B. - - $(C%UH-@O@;(B $(C<<@L:jGO7A0m(B $(CG_@;(B $(C4k(B $(C:q7N<R(B, Emacs$(C4B(B $(CAv1]1nAv(B $(CFmA}GO0m(B -$(C@V4x(B $(C3;?k@;(B $(CH-@O(B $(C3;?!(B $(C=a3V=@4O4Y(B. - - -$(C9vF[(B -==== - - $(C88>`(B, 2$(C9xB0@G(B $(CH-@O@;(B C-x C-f $(C7N(B $(C2(3;8i(B, 1$(C9xB0@G(B $(CH-@O@:(B Emacs$(C3;:N(B -$(C?!(B $(C32=@4O4Y(B. Emacs$(C3;:N?!(B $(C@V4B(B $(CH-@O7N:NEM(B $(CEX=:F.8&(B $(C@P>n3V>n(B $(C:8A8GO0m@V(B -$(C4B(B $(C0M@:(B $(C9vF[6s0m(B $(C:R8.?s4O4Y(B. $(CH-@O@;(B $(C2(3;4B(B $(C0M@:(B, Emacs$(C3;:N?!(B $(C;u7N?n(B -$(C9vF[8&(B $(C885l4O4Y(B. - - Emacs $(C3;?!(B $(C:8A8GO0m(B $(C@V4B(B $(C9vF[@G(B $(C8.=:F.8&(B $(C:84B5%4B(B, $(C4Y@=0z(B $(C00@L(B -$(CE8@LGAGU4O4Y(B. - - C-x C-b - - >> C-x C-b $(C6s0m(B $(CE8@LGAGO<<?d(B. $(C0"0"@G(B $(C9vF[0!(B $(C>n60GQ(B $(C@L8'@;(B $(C0.(B - $(C0m(B $(C@V4B0!(B, $(C1W8.0m(B, $(C>n60GQ(B $(CH-@O8m@;(B $(C:Y@L0m(B $(C@V4B(B $(C0M@N0!(B $(C0|B{(B - $(CGO<<?d(B. - - $(C9vF[?!4B(B $(CH-@O0z(B $(C@OD!GOAv(B $(C>J4B(B $(C0M55(B $(C@V=@4O4Y(B. $(C?98&(B $(C5i8i(B, "*Buffer -List*" $(C6s4B(B $(CH-@O@:(B $(C>x=@4O4Y(B. $(C@L0M@:(B C-x C-b $(C?!(B $(C@GGO?)(B $(C885i>nAx(B $(C9vF[8.(B -$(C=:F.?!(B $(C4kGQ(B $(C9vF[@T4O4Y(B. - - $(C4g=E@L(B $(C:80m(B $(C@V4B(B Emacs$(C@)55?l3;?!(B $(C@V4B(B, $(C>n60GQ(B $(CEX=:F.6s55(B, $(C>n4@0M(B -$(C@N0!@G(B $(C9vF[3;?!(B $(C@V=@4O4Y(B. - - >> $(C9vF[8.=:F.8&(B $(CAv?l1b(B $(C@'GX(B C-x 1 $(C6s0m(B $(CE8@LGAGO<<?d(B. - - $(C88>`(B, $(C>n62(B $(CH-@O@G(B $(CEX=:F.?!(B $(C:/0f@;(B $(CG`GO0m3*<-(B, $(C4Y8%(B $(CH-@O@;(B $(C2(3;>z(B -$(C4Y0m(B $(CG_4Y8i(B, $(CCVCJ@G(B $(CH-@O@:(B $(C<<@L:j5G>n(B $(C@VAv(B $(C>J=@4O4Y(B. $(C1W(B $(C:/0f@:(B Emacs -$(C3;:N@G(B $(CH-@O0z(B $(C4k@@GO4B(B $(C9vF[(B $(C3;?!88(B $(CG`GO?)A.(B $(C@V=@4O4Y(B. - - 2$(C9xB0@G(B $(CH-@O?!(B $(C4k@@GO4B(B $(C9vF[8&(B $(C885i1b55GO0m(B, $(C?!5pF.GO4u6s55(B, 1$(C9x(B -$(CB0@G(B $(CH-@O?!(B $(C4k@@GO4B(B $(C9vF[?!4B(B $(C>F9+71(B $(C?5Gb@;(B $(CAVAv(B $(C>J=@4O4Y(B. $(C@L0M@:(B $(C4k(B -$(C4\Hw(B $(C;g?kGO1b(B $(C=10T(B, $(C6GGQ(B, 1$(C9xB0@G(B $(CH-@O?!(B $(C4k@@GO4B(B $(C9vF[8&(B $(CH.:8GO?)(B $(C5N(B -$(C1b(B $(C@'GO?)(B $(C55?r@L(B $(C5G4B(B $(C9f9}@T4O4Y(B. - - C-x C-s $(C7N(B $(C9vF[8&(B $(C<<@L:jGO1b(B $(C@'GO?)(B C-x C-f $(C7N(B $(C9vF[8&(B $(C13C<GO4B(B $(C0M(B -$(C@:(B $(C1MBz=@4O4Y(B. $(C1W7!<-(B $(C>F7!@G(B $(C8m7I>n8&(B $(C;g?kGU4O4Y(B. - - C-x s $(CGv@g(B $(C@V4B(B $(C9vF[8&(B $(C<<@L:jGQ4Y(B. - - C-x s $(C4B(B $(C3;?k@;(B $(C9Y2[(B $(C9vF[(B $(C@|C<8&(B $(CH-@O?!(B $(C<<@L:jGU4O4Y(B. $(C@L(B $(C6'(B, $(CGO3*(B -$(CGO3*@G(B ($(C<<@L:j5G>n>_(B $(CGR(B)$(C9vF[?!(B $(C4kGO?)(B, $(C<<@L:jGO4B0!(B, $(CGOAv(B $(C>J4B0!8&(B y$(C3*(B -n$(C@87N(B $(C9/=@4O4Y(B. $(C@L(B $(CG%=C4B(B $(CH-8i(B $(C9X@G(B $(CG`?!(B $(CG%=C5K4O4Y(B. $(C?98&(B $(C5i8i(B, $(C>F7!?M(B -$(C00=@4O4Y(B. - - Save file /usr/private/yours/MULE.tut? (y or n) - - - -$(C8m7I>n@G(B $(CH.@e(B -============= - - $(C?!5pEM?!4B(B, $(CD\F.7Q(B*$(CE03*(B $(C8^EM(B*$(CE07N(B $(C@T7BGR(B $(C<v(B $(C@V4B(B $(C0M:84Y55(B $(CHN>@(B -$(C89@:(B $(C8m7I>n0!(B $(C@V=@4O4Y(B. $(C@L0M5i@;(B $(C4Y7g1b(B $(C@'GO?)(B, $(CH.@e(B(eXtend) $(C8m7I>n8&(B -$(C;g?kGU4O4Y(B. $(C@L0M?!4B(B, $(C>F7!@G(B 2$(C0!Av(B $(CA>7y0!(B $(C@V=@4O4Y(B. - - C-x $(C9.@Z?!(B $(C@GGQ(B $(CH.@e(B. $(C@L>n<-(B $(CGQ9.@Z8&(B $(C@T7BGU4O4Y(B. - ESC x $(C@L8'?!(B $(C@GGQ(B $(CH.@e(B. $(C@L>n<-(B $(C8m7I>n@G(B $(C@L8'@;(B $(C@T7BGU4O4Y(B. - - $(C@L0M5i@:(B $(C@O9]@{@87N(B, $(CFm8.GOAv88(B, $(CAv1]1nAv(B $(C:8>F?B(B $(C0M0z(B $(CA61](B $(C:s9xGO(B -$(C0T4B(B $(C;g?k5GAv(B $(C>J4B(B $(C8m7I>n8&(B $(C@'GQ(B $(C0M@T4O4Y(B. C-x C-f ($(CH-@N5e(B)$(C3*(B C-x C-s -($(C<<@L:j(B)$(C4B(B $(C@L(B $(C:N7y@T4O4Y(B. $(C@L?\?!(B, C-x C-c($(C?!5pEM@G(B $(CA>7a(B)$(C55(B $(C1W78=@4O4Y(B. - - C-z$(C4B(B Emacs$(C?!<-(B $(C:|A.3*?@4@5%?!(B $(C@ZAV(B $(C;g?k5G4B(B $(C9f9}@T4O4Y(B. Emacs$(C8&(B -$(CA>7aGO4B(B $(C0M@L(B $(C>F4O6s(B, $(C@O4\(B, csh$(C@G(B $(C79:'?!(B $(C5G59>F0!4B5%?!4B(B $(CA&@O(B $(CAA@:(B $(C9f(B -$(C9}@L6s0m(B $(C8;GR(B $(C<v@V0ZAv?d(B. C-z$(C8&(B $(CG`GO4u6s55(B Emacs$(C4B(B $(C=:EiGO0m(B $(C@V@;(B $(C;S(B, -$(C3;?k@L(B $(CFD1+5G4B(B $(C0M@:>F4U4O4Y(B. - -$(CAV@G(B: $(C4\(B, X-window$(C?!<-(B $(CG`GO0m(B $(C@V4B(B $(C0f?l(B, $(CH$@:(B $(C;g?kGO0m(B $(C@V4B(B - $(C=)@L(B sh$(C@O(B $(C6'4B(B, $(C1W78Av(B $(C>J=@4O4Y(B. - - C-x $(C8m7I>n4B(B,$(C89@L(B $(C@V=@4O4Y(B. $(C@L9L(B $(C9h?n(B $(C0M@:(B $(C>F7!@G(B $(C0M@T4O4Y(B. - - C-x C-f $(CH-@O@G(B $(CFmA}(B(Find) - C-x C-s $(CH-@O@G(B $(C:8A8(B(Save) - C-x C-b $(C9vF[8.=:F.@G(B $(CG%=C(B - C-x C-c $(C?!F<EM8&(B $(CA>7aGQ4Y(B. $(CH-@O@G(B $(C:8A8@:(B, $(C@Z5?@{@87N4B(B $(CG`GO?)(B - $(CAvAv(B $(C>J4B4Y(B. $(C1W7/3*(B, $(CH-@O@L(B $(C:/0f5G>n(B $(C@V@88i(B, $(CH-@O@G(B $(C:8(B - $(CA8@;(B $(CGO4B0!(B, $(C>F4Q0!8&(B $(C90>n?I4O4Y(B. $(C:8A8GO?)(B $(CA>7aGO4B(B $(C:8(B - $(CEk@G(B $(C9f9}(B, C-x C-s C-x C-c $(C7N(B $(CGO4B(B $(C0M@T4O4Y(B. - - $(C@L8'?!(B $(C@GGQ(B $(CH.@e8m7I>n?!4B(B, $(C1W4YAv(B $(C;g?k5GAv(B $(C>J4B(B $(C0M@L3*(B, $(CF/A$@G(B -$(C8p5e?!<-9[?!(B $(C;g?k5GAv(B $(C>J4B(B $(C0M5n@L(B $(C@V=@4O4Y(B. $(C?97N<-(B, "command-apropos" -$(C8&(B $(C5l4O4Y(B. $(C@L(B $(C8m7I>n4B(B $(CE0?v5e8&(B $(C@T7B=CE00m(B, $(C1W0M?!(B $(C8ED!GO4B(B $(C8p5g(B $(C8m7I(B -$(C>n@G(B $(C@L8'@;(B $(CG%=CGU4O4Y(B. ESC x $(C6s0m(B $(CE8@LGAGO8i(B, $(C=:E)80(B $(C9X?!(B "M-x" $(C0!(B $(CG%(B -$(C=C5K4O4Y(B. $(C@L0M?!(B $(C4kGO?)(B, $(C=GG`GO4B(B $(C8m7I>n@G(B $(C@L8'(B($(CAv1]@G(B $(C0f?l(B, -"command-apropos")$(C8&(B $(C@T7BGU4O4Y(B. "command-a" $(C1nAv(B $(C@T7BGQ(B $(C5Z(B $(C=:Fd@L=:(B -$(C8&(B $(CD!8i(B, $(C5Z@G(B $(C:N:P@:(B $(C@Z5?@{@87N(B $(C8^?vA}4O4Y(B. $(C@L(B $(CHD(B, $(CE0?v5e8&(B $(C90@89G7N(B, -$(C>K0m(B $(C=M@:(B $(C9.@Z?-@;(B $(CE8@LGAGU4O4Y(B. $(C6GGQ(B, $(CE0?v5e8&(B $(C@T7BGOAv(B $(C>J@88i(B, $(C8p5g(B -$(C8m7I>n0!(B $(CG%=C5K4O4Y(B. - - >> ESC x $(C8&(B $(CE8@LGAGO0m(B, $(C@L>n<-(B, "command-apropos<Return>" $(CH$@:(B - "command-a<Space><Return>" $(C@L6s0m(B $(CE8@LGAGU4O4Y(B. $(C4Y@=?!(B, - "kanji<Return>"$(C@L6s0m(B $(CE8@LGAGU4O4Y(B. - - $(C3*E83-(B "$(C@)55?l(B"$(C8&(B $(CAv?l4B5%4B(B, C-x 1 $(C@L6s0m(B $(CE8@LGAGU4O4Y(B. - -$(C8p5e6s@N(B -======== - - $(C88>`(B $(CC5C5Hw(B $(C8m7I>n8&(B $(CCF4Y8i(B, $(CH-8i@G(B $(C9XBJ@G(B $(C?!DZ?!8.>n6s0m(B $(C:R8.4B(B -$(C@e<R?!(B, $(CD#(B $(C0M@L(B $(CG%=C5K4O4Y(B. $(C?!DZ?!8.>n4B(B $(CH-8i@G(B $(CA&@O(B $(C9X(B $(CG`@T4O4Y(B. $(C1W(B -$(C9Y7N(B $(C@'@G(B $(CG`@:(B, $(C8p5e6s@N@L6s0m(B $(C:R8.0m(B $(C@V=@4O4Y(B. $(C8p5e6s@N@:(B $(C@L7/GQ(B $(C=D@8(B -$(C7N(B $(CG%=C5G>n(B $(C@V0ZAv?d(B. - - [--]J:--**-Mule: MULE.tut (Fundamental) ---NN%-------------- - - -$(CAV@G(B: NN%$(C@G(B NN$(C@:(B $(C<}@Z0!(B $(C5i>n(B $(C@V=@4O4Y(B. $(C4g=E@L(B $(C;g?kGO0m(B $(C@V4B(B - Emacs$(C@G(B $(C8p5e6s@N0z(B $(C4Y8&(B $(CAv55(B $(C8p8#Av88(B, $(C4gH2GOAv(B $(C8;557O(B. - $(C?98&(B $(C5i8i(B, $(C=C0#@L3*(B uptime$(C@L(B $(CG%=C5G0m(B $(C@V4B(B $(C0M@:(B, - display-time$(C@L6s4B(B $(C1b4I@L(B $(C@[5?GO0m(B $(C@V1b(B $(C6'9.@T4O4Y(B. - - $(C@L(B $(CG`?!(B $(C@GGO?)(B $(C89@:(B $(C@/?kGQ(B $(CA$:80!(B $(C>r>nA}4O4Y(B. - - - $(CAv1](B, $(C4g=E@L(B $(C:80m(B $(C@V4B(B $(CH-@O8m@;(B $(CG%=CGO0m(B $(C@V=@4O4Y(B. NN%$(C@:(B $(CGv@g(B $(C=:(B -$(CE)80@'?!(B $(CH-@O@G(B $(CA&@O(B $(C@'?!<-:NEM(B $(C8n(B $(CF[<>F.B00!(B $(CG%=C5G0m(B $(C@V4B(B $(C0!8&(B $(C3*E8(B -$(C3;0m(B $(C@V=@4O4Y(B. $(CH-@O@G(B $(C0!@e(B $(CCVCJ8&(B $(CG%=CGO0m(B $(C@V@88i(B, --Top--$(C6s0m(B $(CG%=C5K(B -$(C4O4Y(B. $(CH-@O@G(B $(C0!@e(B $(CCVHD8&(B $(CG%=CGO0m(B $(C@V4Y8i(B, --Bot--$(C6s0m(B $(CG%=C5K4O4Y(B. $(CH-8i(B -$(C3;?!(B $(CH-@O(B $(C@|:N0!(B $(CG%=C5G0m(B $(C@V4Y8i(B, --All--$(C6s0m(B $(CG%=C5K4O4Y(B. - - $(C8p5e6s@N@G(B $(C<R0}H#(B $(C3;?!4B(B, $(CAv1](B $(C>n60GQ(B $(C8p5e?!(B $(C5i>n@V4B(B $(C0!8&(B $(C3*E8(B -$(C3;0m(B $(C@V=@4O4Y(B. $(CGv@g4B(B, $(C5pFzF.@N(B Fundamental$(C?!(B $(C5i>n0!(B $(C@V=@4O4Y(B. $(C@L0M55(B -$(C8^@LA.8p5e@G(B $(CGO3*@G(B $(C?9@T4O4Y(B. - - Emacs$(C4B(B Lisp mode$(C3*(B Text mode$(C?M(B $(C00@L(B, $(C4Y8%(B $(CGA7N1W7%>p>n3*(B $(CEX=:F.(B -$(C?!(B $(C4kGO?)(B $(C?!5pF.8&(B $(CG`GO1b(B $(C@'GQ(B $(C8n0!Av@G(B $(C8^@LA.8p5e8&(B $(C0.0m(B $(C@V=@4O4Y(B. -$(C>n62(B $(C6'6s55(B $(C9]5e=C(B $(C>n4@0M@N0!@G(B $(C8^@LA.8p5e@G(B $(C;sEB7N(B $(C5G>n(B $(C@V=@4O4Y(B. - - $(C0"0"@G(B $(C8^@LA.8p5e4B(B $(C8n0!Av@G(B $(C8m7I>n8&(B $(C@|Gt(B $(C4Y8%(B $(CG`5?@87N(B $(CGO?)(B $(C9v(B -$(C834O4Y(B. $(C?98&(B $(C5i>n(B $(C:8=J4O4Y(B. $(CGA7N1W7%(B $(C3;?!(B $(C8m7I>n8&(B $(C885e4B(B $(C8m7I>n0!(B $(C@V(B -$(C=@4O4Y(B. $(C8m7I>n8&(B $(C>n60GQ(B $(CG|=D@87N(B $(CGO4B0!4B(B, $(C0"(B $(CGA7N1W7%>p>n?!(B $(C5{6s<-(B -$(C4Y8#Av88(B, $(C0"0"@G(B $(C8^@LA.8p5e4B(B, $(C9]5e=C(B $(C3V>nA]4O4Y(B. - - $(C0"0"@G(B $(C8^@LA.8p5e?!(B $(C5i>n0!1b(B $(C@'GQ(B $(C8m7I>n4B(B $(C8p5e8m@L(B $(CH.@e5H(B $(C0M@87N(B -$(C5G>n(B $(C@V=@4O4Y(B. $(C?98&(B $(C5i8i(B, M-x fundamental-mode$(C4B(B Fundamental$(C7N(B $(C5i>n0!(B -$(C1b(B $(C@'GQ(B $(C0M@T4O4Y(B. - - $(C88>`(B, $(C?5>n8&(B $(C?!5pF.GQ4Y8i(B, Text mode$(C7N(B $(C5i>n0)4O4Y(B. - - >> M-x text-mode <Return>$(C6s0m(B $(CE8@LGAGO<<?d(B. - - $(CGv@g@G(B $(C8^@LA.8p5e?!(B $(C4kGQ(B $(C55E%8UF.8&(B $(C:80m(B $(C=M@;(B $(C6'4B(B, C-h m$(C@L6s0m(B -$(CE8@LGAGU4O4Y(B. - - >> C-h m $(C8&(B $(C;g?kGO?)(B Text mode$(C?M(B Fundamental mode$(C@G(B $(CBw@L8&(B $(C>K>F(B - $(C:8<<?d(B. - - >> C-x 1$(C7N(B $(C55E%8UF.8&(B $(CH-8i@87N:NEM(B $(CAv?l<<?d(B. - - $(C?^BJ(B $(C3!@G(B '[--]' $(C@:(B $(CGv@g@G(B $(CE0@T7B@G(B $(C8p5e8&(B $(C3*E83;0m(B $(C@V=@4O4Y(B. -[--] $(C@N(B $(C6'?!4B?5>n(B $(C>KFD:*@;(B $(C1W4k7N(B $(C@T7BGR(B $(C<v(B $(C@V=@4O4Y(B. $(C@T7B8p5e?!(B $(C4kGQ(B -$(C;s<<GQ(B $(C<38m@:(B "$(CE8860m(B" $(C8^4:>s@;(B $(C:8<<?d(B. - - $(C1W(B $(C9Y7N(B $(C?@8%BJ?!4B(B $(CDZ5eC<0T(B (coding-system) $(C?!(B $(C0|GQ(B $(CGA7!1W@G(B $(C;sEB(B -$(C0!(B $(CG%=C5G>n(B $(C@V=@4O4Y(B. Mule $(C@:(B, $(CH-@O@TCb7B(B, $(C@T7B(B, $(CH-8iCb7B?!(B $(C4kGO?)(B, $(C0"(B -$(C0"(B $(C5683@{@87N(B $(CDZ5eC<0h8&(B $(CAvA$=CE3(B $(C<v(B $(C@VAv88(B, $(CEk;s@:(B $(CH-@O?k@G(B $(CDZ5eC<0h@G(B -$(C4:8p4P88(B $(CG%=CGO0m@V=@4O4Y(B. - - >> $(C8p5e6s@N(B $(C@'?!(B "J:","S:", $(CH$@:(B "E:"$(C0!(B $(CG%=C5G>n(B $(C@V4B0!(B $(CH.@N(B - $(CGO<<?d(B. - - $(CCVCJ@G(B $(CGQ(B $(C9.@Z0!(B $(CDZ5eC<0h@G(B $(C4:8p4P(B, $(C4Y@=@G(B ':' $(C0!(B $(CGv@g(B $(C?5>n(B $(C@L?\(B -$(C@G(B $(C9.@Z(B($(C@O:;>n(B, $(CGQ19>n5n(B)$(C55(B $(CG%=CGQ4Y4B(B $(C0M@;(B $(C3*E83;0m(B $(C@V=@4O4Y(B. J$(C4B(B -JUNET$(C@87N(B $(C;g?k5G0m(B $(C@V4B(B JIS $(CDZ5e(B, S $(C4B(B Shift-JIS, E $(C4B(B $(C@O:;>n(BEUC $(C8&(B $(C3*(B -$(CE83;0m(B $(C@V=@4O4Y(B. $(C4Y19>n(B $(CG%=C@G(B $(C@/9+4B(B C-x C-k t $(C7N(B ON/OFF$(C@G(B $(CEd1[@L(B $(C0!(B -$(C4IGU4O4Y(B. - - $(C4Y@=@G(B $(C?94B(B, $(C@O4\(B $(C4Y19>nG%=C8&(B OFF$(CGO0m3*<-(B, $(C4Y=C(B $(CGQ9x(B ON$(C@;(B $(CG`GO?)(B -$(C:>4O4Y(B. - - >> C-x C-k t$(C8&(B 2$(C9x(B $(CG`GO<<?d(B. - - $(C@T7B8p5e0!(B JIS$(CDZ5e@G(B $(C<3A$@L(B $(C5G>n(B $(C@V@;(B $(C6'(B, $(C88>`(B $(C4g=E@L(B $(C;g?kGO0m(B $(C@V(B -$(C4B(B $(C4\8;?!(B $(C8^EM(B*$(CE00!(B $(C:Y>n(B $(C@V@88i(B, $(C@L=:DI@LGA(B*$(CE0(B $(C4k=E?!(B $(C1W0M@;(B $(C;g?kGO4B(B -$(C0M@L(B $(C0!4IGU4O4Y(B. $(C@L(B $(C6'(B, $(C8^EM(B*$(CE0@G(B $(C;g?k9f9}@:(B $(CD\F.7Q(B*$(CE0?M(B $(C00@L(B $(C4)8#8i<-(B -$(C9.@Z8&(B $(CE8@LGAGU4O4Y(B. ESC <$(C9.@Z(B>$(C55(B M-<$(C9.@Z(B>$(C55(B $(C00@:(B $(C@[5?@;(B $(CGU4O4Y(B. $(CAv1](B -$(C1nAv@G(B $(C<38m?!<-(B ESC <$(C9.@Z(B>$(C6s0m(B $(CG`GO0m(B $(C@V4x(B $(C0w@L(B, M-<$(C9.@Z(B>$(C7N(B $(C5K4O4Y(B. $(CAV(B -$(C@GGX>_(B $(CGO4B(B $(C0M@:(B, $(C=,GAF.(BJIS$(C3*(B EUC$(CDZ5e(B $(C6'4B(B $(C;g?kGR(B $(C<v(B $(C>x=@4O4Y(B. - - $(CDZ5eC<0h@G(B $(C13C<4B(B, $(C0"0"@G(B $(C9vF[?!(B $(C4kGX<-88(B $(C@/H?GU4O4Y(B. $(C0"0"@G(B, $(CDZ(B -$(C5eC<0h(B $(CAvA$?!(B $(C4kGX<-4B(B, C-h a coding-system <Return>$(C@87N:<(B $(C<v(B $(C@V=@4O4Y(B. - - >> C-h a coding-system <Return>$(C@87N(B $(C3*?@4B(B $(C55E%8UF.(B $(C3;@G(B, - set-display-coding-system, set-file-coding-system, - set-process-coding-system $(C@G(B $(C<38m@;(B $(C@P>n:8<<?d(B. - -$(C0K;v(B -==== - - $(C9.@Z?-@;(B, $(CH-@O3;?!<-(B, $(C@|9f(B $(CH$@:(B $(CHD9f@87N(B, $(CC#@;(B $(C<v(B $(C@V=@4O4Y(B. $(C0K;v(B -$(C@;(B $(C=C@[GO4B(B $(C8m7I>n4B(B, $(CD?<-@'D!(B $(C@LHD8&(B $(C0K;vGQ4Y8i(B, C-s, $(CD?<-@'D!(B $(C@L@|@L(B -$(C6s8i(B C-r $(C@T4O4Y(B. C-s $(C8&(B $(CE8@LGAGO8i(B, $(C?!DZ?!8.>n?!(B "I-search:"$(C6s4B(B $(C9.@Z?-(B -$(C@L(B $(CGA7RF.7N<-(B $(CG%=C5K4O4Y(B. ESC$(C8&(B $(C4)8#8i(B, $(CA>7a5K4O4Y(B. - - - >> C-s$(C7N(B $(C0K;v@L(B $(C=C@[5K4O4Y(B. $(C1W8.0m(B, $(CC5C5Hw(B 1$(C9.@Z>?(B "cursor"$(C6s4B(B - $(C4\>n8&(B $(C@T7BGU4O4Y(B. 1$(C9.@Z(B $(C@T7BGR(B $(C6'864Y(B, $(CD?<-4B(B, $(C>n6;0T(B $(C?rAw(B - $(C@T4O1n(B? - - >> $(CGQ9x(B $(C4u(B C-s $(C8&(B $(CE8@LGAGO8i(B, $(C4Y@=@G(B "cursor"$(C8&(B $(CC#@;(B $(C<v(B $(C@V=@4O4Y(B. - - >> <Delete>$(C8&(B 4$(CH8(B $(C@T7BGO0m(B, $(CD?<-@G(B $(C?rAw@S@;(B $(C:8<<?d(B. - - >> ESC$(C8&(B $(C4)8#0m(B, $(CA>7aGU4O4Y(B. - - $(CC#0m(B $(C=M@:(B $(C9.@Z?-@;(B $(CE8@LGAA_?!55(B, $(CE8@LGAGQ(B $(C9.@Z:N:P88@87N(B, $(C0K;v@;(B -$(C=C@[GU4O4Y(B. $(C4Y@=(B $(C9.@Z8&(B $(CC#4B5%4B(B, $(C4Y=C(B C-s$(C8&(B $(CE8@LGAGU4O4Y(B. $(C88>`(B, $(C9.@Z(B -$(C?-@L(B $(CA8@gGOAv(B $(C>J@88i(B, $(C8^<<Av0!(B $(CG%=C5K4O4Y(B. C-g $(C7N55(B $(CA>7a5K4O4Y(B. - - $(C0K;v=GG`A_?!(B, <Delete>$(C8&(B $(C@T7BGO8i(B, $(C0K;v9.@Z?-@G(B $(CA&@O(B $(C5Z@G(B $(C9.@Z0!(B -$(CAv?vA}4O4Y(B. $(C1W8.0m3*<-(B, $(CD?<-4B(B, $(C@L@|9x@G(B $(C@'D!7N(B $(C5G59>F0)4O4Y(B. $(C?98&(B $(C5i(B -$(C8i(B, "cu"$(C6s0m(B $(CE8@LGAGO0m(B, $(CCVCJ@G(B "cu"$(C@G(B $(C@'D!?!(B $(CD?<-0!(B $(C?rAw?44Y0m(B $(CGU=C4Y(B. -$(C?)1b?!<-(B <Delete>$(C8&(B $(C@T7BGO8i(B, $(C<-D!6s@N@G(B 'u'$(C0!(B $(CAv?vAv0m(B, $(CD?<-4B(B 'u'$(C8&(B -$(CE8@LGAGO1b(B $(C@|?!(B, $(CD?<-0!(B $(C@V>z4x(B 'c'$(C@G(B $(C@'D!7N(B,$(C@L5?GU4O4Y(B. - - $(C0K;v=GG`A_?!(B, C-s $(C3*(B C-r $(C@L?\@G(B $(CD\F.7Q9.@Z8&(B $(CE8@LGAGO8i(B, $(C0K;v@:(B -$(CA>7aGU4O4Y(B. - - C-s $(C4B(B, $(CGv@g@G(B $(CD?<-@'D!(B $(C@LHD?!(B $(C3*?@4B(B $(C0K;v9.@Z?-@;(B $(CC#=@4O4Y(B. $(C88>`(B, -$(C@L@|(B $(CBJ@;(B $(CC#0m(B $(C=M@88i(B, C-r $(C@;(B $(CE8@LGAGO4B(B $(C0M@87N(B, $(C?*9fGb0K;v@L(B $(C0!4IGU4O(B -$(C4Y(B. C-s $(C?M(BC-r $(C4B(B, $(C0K;v@G(B $(C9fGb@L(B $(C9]4k@O(B $(C;S(B, $(C@|:N(B $(C00@:(B $(C?rAw@S@;(B $(CGU4O4Y(B. - -$(C8.D?=C:j(B $(C?!5pFC(B $(C79:'(B - - $(C6'6'7N(B, ($(C:;@G(B $(C>F4O0T(B) $(C8.D?=C:j(B $(C?!5pFC(B $(C79:'@L6s0m(B $(C:R8.4B(B $(C;sEB?!(B $(C5i(B -$(C>n0!4B(B $(C6'0!(B $(C@V=@4O4Y(B. $(C8^@LA.8p5e@G(B $(C<R0}H#(B'()'$(C@G(B $(CAV@'8&(B $(CA_0}H#(B'[]'$(C7N(B $(C5Q(B -$(C7/=Q(B $(C0M@L(B $(C8p5e6s@N(B $(C@'?!(B $(CG%=C5K4O4Y(B. $(C?98&(B $(C5i8i(B, (Fundamental)$(C@L6s0m(B $(CG%=C(B -$(C5G4B(B $(C4k=E?!(B[(Fundamental)]$(C?M(B $(C00@L(B $(C5K4O4Y(B. - -$(CAV@G(B: $(C?)1b?!<-4B(B $(C8.D?=C:j(B $(C?!5pFC(B $(C79:'(B $(C@ZC<?!(B $(C4kGX<-4B(B $(C<38mGOAv(B - $(C>J=@4O4Y(B. - - $(C8.D?=C:j(B $(C?!5pFC(B $(C79:'7N:NEM(B $(C:|A.3*?@1b(B $(C@'GX<-4B(B, M-x top-level -<Return>$(C@L6s0m(B $(CE8@LGAGU4O4Y(B. - - >> $(C=CGhGO?)(B $(C:8<<?d(B. $(C=:E)80(B $(C9X?!(B "Back to top level"$(C6s0m(B $(CG%=C5K(B - $(C4O4Y(B. - - $(CK\;g=G@:(B, $(C@L(B $(C=C550!(B $(CG`GO?)A3@;(B $(C6'4B(B, $(C@L9L(B $(CEi79:'?!(B $(C@V>z4x(B $(C0M@T4O(B -$(C4Y(B. M-x top-level$(C@:(B, $(C>F9+71(B $(C?5Gb@;(B $(CAV0m(B $(C@VAv(B $(C>J=@4O4Y(B. - - $(C8.D?=C:j(B $(C?!5pFC(B $(C79:'7N:NEM(B $(C:|A.3*?@4B(B $(C0M?!(B $(C4kGX<-4B(B C-g$(C4B(B $(C5hAv(B $(C>J(B -$(C=@4O4Y(B. - - -$(CGoGA(B -==== - - Emacs$(C?!4B(B, $(C89@:(B $(C55?r1b4I@L(B $(C@V0m(B, $(C?)1b?!<-(B, $(C@|:N8&(B $(C<38mGO4B(B $(C0M@:(B -$(C:R0!4IGU4O4Y(B. $(C1W7/3*(B, $(C>FAw(B $(C8p8#4B(B $(C89@:(B $(C1b4I@;(B $(C9h?l1b(B $(C@'GX<-4B(B, <HELP> -$(C6s0m(B $(C:R8.4B(B C-h $(C8&(B $(CE8@LGAGO4B(B $(C0M@87N(B, $(C89@:(B $(CA$:88&(B $(C@T<vGR(B $(C<v(B $(C@V=@4O4Y(B. - - $(C;g?k9f9}@:(B, C-h $(C8&(B $(CE8@LGAGO0m(B, $(C@L>n<-(B $(CGJ?dGQ(B $(C?I<G@;(B 1$(C9.@Z(B $(CE8@LGA(B -$(CGU4O4Y(B. $(C8p8#0Z@88i(B, C-h ? $(C6s0m(B $(CE8@LGAGO8i(B, $(C>n62(B $(C?I<G@L(B $(C@V4B0!(B $(CG%=C5K(B -$(C4O4Y(B. $(C88>`(B, C-h $(C8&(B $(CE8@LGAGO0m3*<-(B $(C86@=@L(B $(C:/G_4Y8i(B, C-g $(C8&(B $(CE8@LGAGO8i(B, -$(CCk<RGR<v(B $(C@V=@4O4Y(B. - - $(C0!@e(B $(C1b:;@{@N(B $(C0M@:(B, C-h c $(C@T4O4Y(B. $(C@L0M?!(B $(C@L>n<-(B $(CE08&(B $(C@T7BGO8i(B, $(C1W(B -$(C8m7I>n?!(B $(C4kGQ(B $(CB*@:(B $(C<38m@;(B $(CG%=CGU4O4Y(B. - - >> C-h c C-p $(C6s0m(B $(CE8@LGAGO?)(B $(C:8<<?d(B. "C-p runs the command - previous-line"$(C0z(B $(C00@:(B $(C8^<<Av0!(B $(CG%=C5K4O4Y(B. - - $(C:;(B $(C@{@:(B $(C@VAv88(B, $(C1b>oGO0m(B $(C@VAv(B $(C>J@:(B $(C8m7I>n55(B $(C;}0"GX(B $(C3>(B $(C<v(B $(C@V4B(B $(C0M(B -$(C@T4O4Y(B. C-x C-s $(C?M(B $(C00@:(B $(C:9<v@L8i<-(B 1$(C03@G(B $(C8m7I>n55(B C-h c $(C@G(B $(C5Z?!(B $(C@L>n(B -$(CA}4O4Y(B. - - $(C4u?m(B $(C;s<<GO0T(B $(C>K0m(B $(C=M@88i(B, c $(C4k=E?!(B k $(C8&(B $(CAvA$GU4O4Y(B. - - >> C-h k C-p $(C6s0m(B $(CE8@LGAGO?)(B $(C:8<<?d(B. - - Emacs$(C@G(B $(C@)55?l?!(B, $(C8m7I>n@G(B $(C@L8'0z(B $(C1b4I@L(B $(CG%=C5K4O4Y(B. $(C4Y(B $(C@P>z@88i(B, -C-x 1 $(C6s0m(B $(CE8@LGAGO8i(B, $(C:|A.3*?I4O4Y(B. - - $(C@L?\?!55(B $(C55?r@L(B $(C5G4B(B $(C?I<G@L(B $(C@V=@4O4Y(B. - - C-h f $(CFc<G8m@;(B $(C@T7BGO8i(B, $(CFc<G@;(B $(CG%=CGU4O4Y(B. - - >> C-h f previous-line $(C@;(B $(CE8@LGAGO0m(B, <Return> $(C@;(B $(C4)8#<<?d(B. C-p - $(C8m7I>n8&(B $(C=GG`GO4B(B $(CFc<G?!(B $(C4kGQ(B $(CA$:88&(B $(CG%=CGU4O4Y(B. - - C-h a $(CE0?v5e8&(B $(C@T7BGO8i(B, $(C@L8'?!(B $(C1W(B $(CE0?v5e8&(B $(CFwGTGO0m(B, $(C8p5g(B $(C8m(B - $(C7I>n8&(B $(CG%=CGU4O4Y(B. $(C@L(B $(C8m7I>n5i@:(B $(C8p5N(B ESC x $(C7N(B $(C=GG`GR(B - $(C<v(B $(C@V=@4O4Y(B. - - >> C-h a file $(C>K0m(B $(CE8@LGAGO0m(B, <Return>$(C@;(B $(C4)8#<<?d(B. $(C@L8'?!(B - "file"$(C@L6s4B(B $(C9.@Z8&(B $(C0.4B(B $(C8p5g(B $(C8m7I>n8&(B $(CG%=CGU4O4Y(B. $(C6GGQ(B, - find-file $(C@L3*(B write-file$(C6s4B(B $(C@L8'@G(B C-x C-f $(C3*(B C-x C-w $(C?M(B $(C00(B - $(C@:(B $(C8m7I>n55(B $(CG%=C5K4O4Y(B. - -$(C3!@87N(B -====== - -$(C@XAv8;0m(B: $(CA>7aGO4B5%4B(B, C-x C-c $(C6s0m(B $(CGU4O4Y(B. - - - $(C@L(B $(C@T9.Fm@:(B, $(CCJ=I@Z?!0T55(B $(C>K1b(B $(C=10T(B $(CGO557O(B $(C@G55GO0m(B $(C@V=@4O4Y(B. -$(C1W7/9G7N(B, $(CH$=C(B $(C9+>y@N0!(B $(C@LGXGO1b(B $(C>n7A?n(B $(CA!@L(B $(C@V4Y8i(B, $(CH%@Z<-(B $(CG*3d(B -$(CGOAv(B $(C8;0m(B, $(CF.A}@;(B $(C@b>F(B $(CAV<<?d(B. - - - $(C88>`(B, EMACS $(C8&(B $(C8n@OA$55(B $(C;g?kGO0m(B $(C:88i(B, $(C1W0M@;(B $(C1W885P4Y4B(B $(C0M@:(B -$(C8xGO0T(B $(C5I(B $(C0M@T4O4Y(B. $(CCVCJ?!4B(B $(C>n8.5U@}GR(B $(CAv55(B $(C8p8#0Z=@4O4Y(B. $(C1W7/3*(B, -$(C1W0M@:(B $(C>n60GQ(B $(C?!5pEM6s55(B $(C6H(B $(C00=@4O4Y(B. EMACS $(C?M(B $(C00@L(B, $(C4k4\Hw(B $(C89@:(B $(C0M@L(B -$(C0!4IGQ(B $(C0f?l?!4B(B $(CF/Hw(B $(C1W780ZAv?d(B. $(C1W8.0m(B, EMACS $(C?!<-4B(B, $(C=GA&7N(B, $(C9+>y@L(B -$(C3*(B $(CGR(B $(C<v(B $(C@V1b(B $(C6'9.?!(B. - - -$(C0(;g(B -==== - $(C@L(B $(C9.<-4B(B, JUNET$(C?!<-(B $(C9hFw5H(B "$(C@O:;>n(B MicroEMACS (kemacs) $(C@T9.Fm(B" -$(C@;(B GNUE- macs (Nemacs)$(C@G(B Tutorial$(C?k@87N(B $(C0mCD>4(B $(C0M@T4O4Y(B. - - Jonathan Payne $(C?!(B $(C@GGQ(B "JOVE Tutorial" (19 January 86) $(C@;(B $(C:/0fGQ(B - $(C0M@L0m(B, $(C1W0M@:(B $(C?x7!(B, CCA-UNIX$(C@G(B Steve Zimmerman $(C?!(B $(C@GGX<-(B $(C:/0f5H(B, - MIT $(C@G(B "Teach-Emacs" $(C@T9.Fm(B (31 October 85) $(C@;(B ($(C4u?m(B) $(C:/0fGQ(B $(C0M@L(B - $(C>z=@4O4Y(B. - - Update - February 1986 by Dana Hoggatt. - - Update - December 1986 by Kim Leburg. - - Update/Translate - July 1987 by SANETO Takanori - -$(CF/:0GQ(B $(C0(;g(B -=========== - - $(CCVCJ?!(B $(C@L(B $(C@O:;>n9x?*@;(B $(C@[<:GQ(B, SANETO Takanori$(C>>(B. $(C@L(B $(C9.@e@:(B GMW + -Wnn + Nemacs$(C@;(B $(C;g?kGO?)(B $(C@[<:G_=@4O4Y(B. $(C1W?M(B $(C00@:(B $(CHG8"GQ(B $(CGA7N1W7%@;(B $(C885g(B -$(C8p5g(B $(C:P?!0T(B $(C0(;g@G(B $(C6f@;(B $(CG%GO0m(B $(C=M=@4O4Y(B. $(C9x?*@L6s5g0!(B, $(C@T7B(B $(C5n(B -$(C?)7/8p7N(B $(C55?M(B $(CAX(B $(CHDAvGO6s<n?l2?>>(B, $(C4k4\Hw(B $(C0(;gGU4O4Y(B. - - - -$(C?@?*(B, $(C0EA~(B, $(C@L(B $(C?\@G(B $(C9.C%@:(B $(C>F7!@G(B $(C;g6w?!0T(B $(C@V=@4O4Y(B. - - $BNkLZM5?.(B hironobu@sra.co.jp - - -Update/Add - December 1987 by Hironobu Suzuki -Update/Add - November 1989 by Ken'ichi Handa -Update/Add - January 1990 by Shigeki Yoshida -Update/Add - March 1992 by Kenichi HANDA - - -$(C6G4Y8%(B $(C0(;g(B -=========== - - $(C@L(B $(C9.<-4B(B "$(C@O:;>n(B GNUEMACS(Mule) $(C@T9.Fm(B"$(C@;(B $(CGQ19>n7N(B $(C9x?*GO?)(B, -hemacs$(C7N(B $(C@[<:GQ(B $(C0M@T4O4Y(B. $(C@O:;>n9x?*@;(B $(C4c4gGQ(B $(C8p5g(B $(C:P(B, hemacs$(C8&(B -$(C039_GO?)(B $(CAV=E(B $(C:P(B, $(CF/Hw(B Mule$(C0z(B hemacs$(C@G(B $(CH/0f18C`?!(B $(C89@:(B $(C55?r@;(B $(CAX(B -$(C136G4kGP(B $(C3*0!?@?,18=G(B $(CA9>w;}@N(B Masashi SHIMBO$(C>>?M(B Katsuyoshi -Yamagami$(C>>?!0T(B $(C0(;g@G(B $(C6f@;(B $(C@|GU4O4Y(B. - - 1993. 9. 25 - - $(C136G4kGP(B $(C0xGP:N(B $(C@|1b0xGP0z(B $(C3*0!?@?,18=G(B - Dosam HWANG hwang@forest.kuee.kyoto-u.ac.jp
--- a/etc/TUTORIAL.no Mon Aug 13 10:03:54 2007 +0200 +++ b/etc/TUTORIAL.no Mon Aug 13 10:04:58 2007 +0200 @@ -24,7 +24,7 @@ Viktig: for å avslutte Emacs trykker du C-x C-c. (To tegn.) Tegnene ">>" helt til venstre angir en veiledning slik at du kan prøve ut en kommando. For eksempel: -<<Blank lines inserted here by startup of help-with-tutorial>> +<<Blanke linjer, av pedagogiske grunner. Teksten fortsetter nedenfor>> >> Trykk C-v (View next screen) for å hoppe til neste skjermbilde. (kom igjen, hold ned control-tasten og trykk v). Fra nå av bør du gjøre dette hver gang du er ferdig med å lese et
--- a/etc/e/README Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2 +0,0 @@ -Rebuild terminfo files with -TERMINFO=<Full-Path-To-XEmacs-tree>/etc tic *.ti
--- a/etc/e/emancs.ti Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,7 +0,0 @@ -emancs, - cols#80, - sgr0=\003, - smso=\001, - smul=\002, - rmul=\003, - it#1,
--- a/etc/e/eterm.ti Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,18 +0,0 @@ -# These are ordered as in the O'Reilly "termcap and terminfo" book. -eterm, - lines#24,cols#80, - cuu1=\E[A,cud1=\n,cub1=\b,cuf1=\E[C,home=\E[H,cr=\r, - cuu=\E[%p1%dA,cud=\E[%p1%dB,cub=\E[%p1%dD,cuf=\E[%p1%dC, - cup=\E[%i%p1%d;%p2%dH, - ind=\n,csr=\E[%i%p1%d;%p2%dr, - il1=\E[L,il=\E[%p1%dL, - clear=\E[H\E[J,ed=\\E[J,el=\E[K, - dl1=\E[M,dl=\E[%p1%dM,dch1=\E[P,dch=\E[%p1%dP, - kcub1=\E[D,kcuf1=\E[C,kcuu1=\E[A,kcud1=\E[B, - smir=\E[4h,rmir=\E[4l,ich=\E[%p1%d@,mir, - smcup=\E7\E[?47h,rmcup=\E[2J\E[?47l\E8, - ht=\t, - smso=\E[7m,rmso=\E[m, - smul=\E[4m,rmul=\E[m, - rev=\E[7m,bold=\E[1m,sgr0=\E[m, - bel=^G,xenl,am,
--- a/etc/hypb-mouse.txt Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,69 +0,0 @@ -============================================================================== - Smart Keys -Context Action Key Assist Key -============================================================================== -Hyperbole - On a menu item Item is activated Item help - On an explicit button Button is activated Button help - Reading argument - 1st press at an arg value Value copied to minibuffer <- same - 2nd press at an arg value Value used as argument <- same - In minibuffer Minibuf arg is applied Completion help - On an implicit button Button is activated Button help - Within an outline cell Collapses and expands Shows tree props - Left of an outline cell Creates a klink Moves a tree - Wrolo Match Buffer Edits entries and mails to e-mail addresses - -Mouse or Keyboard Display Control - Line end, not end of buffer - smart-scroll-proportional - = t (default) Makes curr line top line Bottom line - = nil Scrolls up a windowful Scrolls down - End of Any Help buffer Screen restored to previous state - -Mouse-only Control - Modeline down & wind release Resize window height <- same - Drag from shared window side - or from left of scroll bar Resize window width <- same - Drag between windows Create/modify a link but Swap window buffers - Horizontal drag within window - Left to right Scroll to buffer end Split window across - Right to left Scroll to buffer begin Delete window - Vertical drag within window Split window sideways <- same - Diagonal drag within window Save ring screen-config Restore ring config - Click in modeline - Left window edge Bury buffer Unbury bottom buf - Right window edge Info Smart Key summary - Otherwise Action Key Hook Assist Key Hook - -Special Modes - C,C++,Objective-C,Java Modes Jumps to id/include def Jumps to next def - Java Cross-Reference Tag Jumps to identifier def Jumps to next def - Assembly Language Mode Jumps to id/include def Jumps to next def - Any Lisp or Fortran Mode Jumps to id def Jumps to next def - Emacs Lisp Compiler Error Jumps to def with error <- same - Grep or Occur Match Jumps to match source line <- same - Multi-buffer Occur Match Jumps to match source line <- same - Outline Major/Minor Modes Collapses, expands, and moves outline entries - Man Apropos Displays man page entry <- same - Man Pages Follows cross refs, file refs and C code refs - Buffer Menu Saves, deletes and displays buffers - -Emacs Info Reader - Menu Entry or Cross Ref Jumps to referent <- same - Up, Next or Prev Header Jumps to referent Jumps to prior node - File entry of Header Jumps to top node Jumps to (DIR) node - End of current node Jumps to next node Jumps to prev node - Anywhere else Scrolls up a windowful Scrolls down a wind - -Subsystems - Calendar Scrolls or shows appts Scrolls/marks dates - Dired Mode Views and deletes files from directory listing - GNUS News Reader Toggles group subscriptions, gets new news, - and browses articles - Mail reader and Summaries Browses, deletes and expunges messages - OO-Browser Browses classes and elements - Tar Mode Views and edits files from tar archive files - -Any other context (defaults) Hyperbole top menu Smart Key summary -==============================================================================
--- a/etc/ida-logo.xpm Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,198 +0,0 @@ -/* XPM */ -static char * ida_name [] = { -"368 98 95 2", -/* pixels*/ -"a0 c #131313131313", -"a1 c #3d3d3d3d3d3d", -"a2 c #3e3e3e3e3e3e", -"a3 c #3c3c3c3c3c3c", -"a4 c #0e0e0e0e0e0e", -"a5 c #f0f0f0f0f0f0", -"a6 c #cfcfcfcfcfcf", -"a7 c #d2d2d2d2d2d2", -"a8 c #d5d5d5d5d5d5", -"a9 c #d3d3d3d3d3d3", -"b0 c #d6d6d6d6d6d6", -"b1 c #c7c7c7c7c7c7", -"b2 c #090909090909", -"b3 c #f1f1f1f1f1f1", -"b4 c #1a1a1a1a1a1a", -"b5 c #1c1c1c1c1c1c", -"b6 c #212121212121", -"b7 c #f4f4f4f4f4f4", -"b8 c #202020202020", -"b9 c #797979797979", -"c0 c #696969696969", -"c1 c #6b6b6b6b6b6b", -"c2 c #6f6f6f6f6f6f", -"c3 c #646464646464", -"c4 c #686868686868", -"c5 c #707070707070", -"c6 c #6e6e6e6e6e6e", -"c7 c #747474747474", -"c8 c #737373737373", -"c9 c #767676767676", -"d0 c #6c6c6c6c6c6c", -"d1 c #676767676767", -"d2 c #828282828282", -"d3 c #7b7b7b7b7b7b", -"d4 c #666666666666", -"d5 c #636363636363", -"d6 c #757575757575", -"d7 c #727272727272", -"d8 c #5f5f5f5f5f5f", -"d9 c #787878787878", -"e0 c #5c5c5c5c5c5c", -"e1 c #595959595959", -"e2 c #7d7d7d7d7d7d", -"e3 c #717171717171", -"e4 c #7a7a7a7a7a7a", -"e5 c #6a6a6a6a6a6a", -"e6 c #6d6d6d6d6d6d", -"e7 c #777777777777", -"e8 c #1f1f1f1f1f1f", -"e9 c #232323232323", -"f0 c #222222222222", -"f1 c #555555555555", -"f2 c #7c7c7c7c7c7c", -"f3 c #808080808080", -"f4 c #888888888888", -"f5 c #606060606060", -"f6 c #656565656565", -"f7 c #242424242424", -"f8 c #1e1e1e1e1e1e", -"f9 c #8e8e8e8e8e8e", -"g0 c #1d1d1d1d1d1d", -"g1 c #252525252525", -"g2 c #616161616161", -"g3 c #626262626262", -"g4 c #282828282828", -"g5 c #424242424242", -"g6 c #7e7e7e7e7e7e", -"g7 c #4f4f4f4f4f4f", -"g8 c #838383838383", -"g9 c #a5a5a5a5a5a5", -"h0 c #dfdfdfdfdfdf", -"h1 c #ffffffffffff", -"h2 c #b2b2b2b2b2b2", -"h3 c #f8f8f8f8f8f8", -"h4 c #fcfcfcfcfcfc", -"h5 c #ebebebebebeb", -"h6 c #969696969696", -"h7 c #c5c5c5c5c5c5", -"h8 c #b1b1b1b1b1b1", -"h9 c #2f2f2f2f2f2f", -"i0 c #e4e4e4e4e4e4", -"i1 c #363636363636", -"i2 c #000000000000", -"i3 c #4b4b4b4b4b4b", -"i4 c #060606060606", -"i5 c #2a2a2a2a2a2a", -"i6 c #474747474747", -"i7 c #323232323232", -"i8 c #525252525252", -"i9 c #3a3a3a3a3a3a", -"j0 c #2d2d2d2d2d2d", -"j1 c #343434343434", -"j2 c #1b1b1b1b1b1b", -"j3 c #181818181818", -"j4 c #171717171717", -"a0a1a1a2a2a2a2a2a2a2a1a2a2a2a2a2a2a2a2a2a1a2a2a2a1a2a2a2a2a2a1a1a1a2a2a2a1a2a2a2a2a2a2a2a2a2a2a2a1a2a2a1a2a2a2a2a1a1a2a2a2a2a2a2a2a2a2a1a2a2a2a2a2a2a2a2a2a2a2a2a2a2a2a2a1a1a2a2a2a2a2a2a2a2a2a2a2a1a1a2a2a2a2a2a2a2a2a2a2a2a2a2a2a2a2a2a1a2a2a2a1a2a2a2a2a2a1a1a1a2a2a2a1a2a2a2a2a2a2a2a2a2a2a2a1a2a2a1a2a2a2a2a1a1a2a2a2a2a2a2a2a2a2a1a2a2a2a2a2a2a2a2a2a2a2a2a2a2a2a2a1a1a2a2a2a2a2a2a2a2a2a2a2a1a1a2a2a2a2a2a2a2a2a2a2a2a2a2a2a2a2a2a1a2a2a1a1a2a2a2a2a2a1a1a1a2a2a2a1a2a2a2a2a2a2a2a2a2a2a2a1a2a2a1a2a2a2a2a1a1a2a2a2a2a2a2a2a2a2a2a2a2a2a2a2a2a2a2a2a2a2a2a2a2a2a2a1a1a2a2a2a2a2a2a2a2a2a2a2a2a1a2a2a2a2a2a2a2a2a2a2a2a2a2a2a2a2a2a1a2a2a1a1a2a2a2a2a2a1a1a1a2a2a2a2a2a2a2a2a2a2a2a2a2a2a2a2a2a2a1a2a2a2a2a1a3a2a2a2a2a2a2a2a2a2a1a2a2a2a2a2a2a2a2a2a2a2a4", -"a2a5a6a6a7a6a8a7a7a7a7a7a8a6a7a7a9a9a7a9a7a8a8a7a7b0b0b0a9a6a6a6a8a9a7a7a7a9a7a7a9a8a6a8a8a6a9a8a6a6b0a6a7a8a7a9a7a6a9a8b0a8a9a7a8a9a7a7a7a7a8a8a8a7b0b0a8a8b0a8a8a9a8b0a6a6b0a7a7b0a8b0a8a9a8a9a9a6a6a6a7a6a8a7a7a7a7a7a8a6a7a7a9a9a7a9a7a8a8a7a7b0b0b0a9a6a6a6a8a9a7a7a7a9a7a7a9a8a6a8a8a6a9a8a6a6b0a6a7a8a7a9a7a6a9a8b0a8a9a7a8a9a7a7a7a7a8a8a8a7b0b0a8b0b0a8a8a9a8b0a6a6b0a7a7b0a8b0a8a9a8a9a9a6a6a6a7a6a8a7a7a7a7a7a8a6a7a7a9a9a7a9a7a8a8a7a7b0b0b0a7a6a6a6a8a9a7a7a7a9a7a7a9a8a6a8a8a6a8a8a6a6b0a6a7a8a7a9a7a6a9a8b0a8a9a7a8a9a7a7a7a7a8a8a8a7b0b0a8b0b0a8a8a9a8b0a6a6b0a7a7b0a8b0a8a8a9a9a9a6a6a6a7a6a8a7a7a7a7a7a8a6a7a7a9a9a7a9a7a8a8a7a7b0b0b0a9a6a6a6a8a9a7a7a7a9a7a7a8a9a6a8a8a6a8a8a6a6b0a6a7a8a7a9a7a6a9a8b0a8a8a7a8a9a7a7a7a7a8a8a8a7b0b0a8a9b1b2", -"a1a6b3a8a7a7a7a6a6b0a7a6a7a7a7a7a7a8a7a8a9a8b0a7a9b0b0b0a7a6a8a7b0b0b0a8a7a6a6a9a8b0a8a7b0a6a6a6a7a7a6a7a7a6a8a7a6a7a8a8b0b0a8a9a7a7a9a7a7a7a9a8a8a7a8b0b0a8a8b0a8b0b0a7a6a6b0b0a8b0b0b0a8a9a8a8a6a6a9a8a7a7a7a6a6b0a7a6a7a7a7a7a7a8a7a8a9a8b0a7a9b0b0b0a7a6a8a7b0b0b0a8a7a6a6a9a8b0a8a7b0a6a6a6a7a7a6a7a7a6a8a7a6a7a8a8b0b0a8a9a7a7a9a7a7a7a9a8a8a7a8b0b0a8a8b0a8b0b0a7a6a6b0b0a8b0b0b0a8a9a8a8a6a6a9a8a7a7a7a6a6b0a7a6a7a7a7a7a7a8a7a8a9a8b0a7a9b0b0b0a7a6a8a7b0b0b0a8a7a6a6a9a8b0a8a7b0a6a6a6a7a7a6a7a7a6a8a7a6a7a8a8b0b0a8a9a7a7a8a7a7a7a9a8a8a7a8b0b0a8a8b0a8b0b0a7a6a6b0b0a8b0b0b0a8a9a8a8a6a6a9a8a7a7a7a6a6b0a7a6a7a7a7a7a7a8a7a8a9a8b0a7a9b0b0b0a7a6a8a7b0b0b0a8a7a6a6a9a8b0a9a7b0a6a6a6a7a7a6a7a7a6a8a7a6a7a8a8b0b0a8a8a7a7a9a7a7a7a9a8a8a7a8b0b0b1b4b2", -"a1a6b0b3a8a9a7a6a6b0a9a6a7a7a7a7a7a8a7a8a9b0b0a9a7b0b0b0a6a6b0a8a9b0b0a8a8a9a7a8b0b0a9a6b1a6a7a7a7a9a6a7a8a7a8a7b1a8a8b0a8a8a8a7a8a7a7a7a8a8b0a8a8a9a8a8b0a7a8a9a9b0b0a7a6a7a8b0b0b0b0a8a8a9a8a8a6a6b0a8a8a9a7a6a6b0a9a6a7a7a7a7a7a8a7a8a9b0b0a9a7b0b0b0a6a6b0a8a9b0b0a8a8a9a7a8b0b0a9a6b1a6a7a7a7a9a6a7a8a7a8a7b1a8a8b0a8a8a8a7a8a7a7a7a8a8b0a8a8a8a8a8b0a7a8a9a9b0b0a7a6a7a8b0b0b0b0a8a8a9a8a8a6a6b0a8a8a9a7a6a6b0a9a6a7a7a7a7a7a8a7a8a9b0b0a9a7b0b0b0a7a6b0a8a9b0b0a8a8a9a7a8b0b0a8a6b1b1a7a7a7a9a6a7a8a7a8a7b1a8a8b0a8a8a8a7a8a7a7a7a8a8b0a8a8a9a8a8b0a7a8a9a9b0b0a7a6a7a8b0b0b0b0a8a8a9a8a8a6a6b0a8a8a9a7a6a6b0a9a6a7a7a7a7a7a8a7a8a9b0b0a9a7b0b0b0a6a6b0a8a9b0b0a8a8a9a7a8b0b0a8a6b1b1a7a7a7a9a6a7a8a7a8a7b1a8a8b0a8a8a9a7a7a7a7a7a8a8b0a8a8a8a9a7b1b5b6b2", -"a2a7a8a7b3b3b3b3a5a5b3b3b3b3b3b3b3b3b3b3b3b7b3b3b3b3b7b7b3a5a5b3b3b3b3b3b3b3b3b3b7b3b3b3a5a5a5b3b3b3a5b3a5b3b3a5a5b3b3b7b3b3b3b3b3b3b3b7b3b3b3b3b3b3b3b7b3b3b3b3b3b3b3b3a5a5b3b3b3b7b7b3b3b3b3b7b3a5b3b3b3b3b3b3a5a5b3b3b3b3b3b3b3b3b3b3b3b7b3b3b3b3b7b7b3a5a5b3b3b3b3b3b3b3b3b3b7b3b3b3a5a5a5b3b3b3a5b3a5b3b3a5a5b3b3b7b3b3b3b3b3b3b3b7b3b3b3b3b3b3b3b7b3b3b3b3b3b3b3b3a5a5b3b3b3b7b7b3b3b3b3b7b3a5b3b3b3b3b3b3a5a5b3b3b3b3b3b3b3b3b3b3b3b7b3b3b3b3b7b7a5a5a5b3b3b3b3b3b3b3b3b3b7b7b3b3a5b3b3b3b3b3a5b3a5b3b3a5a5b3b3b7b3b3b3b3b3b3b3b7b3b3b3b3b3b3b3b7b3b3b3b3b3b3b3b3a5a5b3b3b3b7b7b3b3b3b3b7b3a5b3b3b3b3b3b3a5a5b3b3b3b3b3b3b3b3b3b3b3b7b3b3b3b3b7b7a5a5a5b3b3b3b3b3b3b3b3b3b7b7b3b3a5b3b3b3b3b3a5b3a5b3b3a5a5b3b7b3b7b3b3b3b3b7b3b7b3b3b3b3b3b3b3b1b4b5b8b2", -"a2a7b0a8b3b9c0c1c2c2c3c1c4c2c5c4b9c6c2c7c6c8c9d0d1d2d3d2d4d5c3c9d2d3c9c5d6b9d7c8c1c8c1d8c5c6c6c1d8d9c3c6c2c4e0e1c5c5c0e2b9c4b9c4d7e3b9c4c5b9c5c1c1c1d7e3e2e4d7e5e5d7e6e6d8c4e5c3e7c7e3c6c2e3d6c7e5c4e2d7e4b9c0c1c2c2c3c1c4c2c5c4b9c6c2c7c6c8c9d0d1d2d3d2d4d5c3c9d2d3c9c5d6b9d7c8c1c8c1d8c5c6c6c1d8d9c3c6c2c4e0e1c5c5c0e2b9c4b9c4d7e3b9c4c5b9c5c1c1c1d7e3e2e4d7e5e5d7e6e6d8c4e5c3e7c7e3c6c2e3d6c7e5c4e2d7e4b9c0c1c2c2c3c1c4c2c5c4b9c6c2c7c6c8c9d0d1d2d3d2d4d5c3c9d2d3c9c5d6b9d7c8c1c8c1d8c5c6c6c1d8d9c3c6c2c4e0e1c5c5c0e2b9c4b9c4d7e3b9c4c5b9c5c1c1c1d7e3e2e4d7e5e5d7e6e6d8c4e5c3e7c7e3c6c2e3d6c7e5c4e2d7e4b9c0c1c2c2c3c1c4c2c5c4b9c6c2c7c6c8c9d0d1d2d3d2d4d5c3c9d2d3c9c5d6b9d7c8c1c8c1d8c5c6c6c1d8d9c3c6c2c4e0e1c5c5c0e2b9c4b9c4d7c2b9c4c5b9c5c1c1c1d7e8e9f0b6b2", -"a2b0a8a8b7c5c8c1c6c1c1d5f1c1c0b9c0c7c6c7c2d6e7c4e6f2d3f3c7e3d5d6d2f4b9e6c9c9c8c1d2e4d7d5c2e6c1d8c5d8c7d7c8d8c4c2e4b9b9c5e4c5b9b9c1c1e2c5c5d7c1c1c1c4d7d7b9e6d4d5e3e5e3e5c0f5e5f6c8c7c6c2c2d7d3c7e2e4b9d7e4c5c8c1c6c1c1d5f1c1c0b9c0c7c6c7c2d6e7c4e6f2d3f3c7e3d5d6d2f4b9e6c9c9c8c1d2e4d7d5c2e6c1d8c5d8c7d7c8d8c4c2e4b9b9c5e4c5b9b9c1c1e2c5c5d7c1c1c1c4d7d7b9e6d4d5e3e5e3e5c0f5e5f6c8c7c6c2c2d7d3c7e2e4b9d7e4c5c8c1c6c1c1d5f1c1c0b9c0c7c6c7c2d6e7c4e6f2d3f3c7e3d5d6d2f4b9e6c9c9c8c1d2e4d7d5c2e6c1d8c5d8c7d7c8d8c4c2e4b9b9c5e4c5b9b9c1c1e2c5c5d7c1c1c1c4d7d7b9e6d4d5e3e5e3e5c0f5e5f6c8c7c6c2c2d7d3c7e2e4b9d7e4c5c8c1c6c1c1d5f1c1c0b9c0c7c6c7c2d6e7c4e6f2d3f3c7e3d5d6d2f4b9e6c9c9c8c1d2e4d7d5c2e6c1d8c5d8c7d7c8d8c4c2e4b9b9c5e4c5b9b9c1c1e2c5c5d7c1c1c1c4d7b6f7b8f8b2", -"a2b0b0a9b3c5c6c6c2d5c3c3d5c5c4c4e4c8b9c9d7c9d6d5e6c2d9d2c8e6d4c5f9d7c6c9e6f2c1b9d2d3e5c1c0c2d5c2e1e5c8c6e5c2d4b9c5c0d7b9c5e4c2c5c1d5b9c5c4c5c1d7e3c6c6b9d7c4f5f5c1d4c3d6d1e1d4d7b9b9d7c1c9d6c7c7e2b9e4c5c5c5c6c6c2d5c3c3d5c5c4c4e4c8b9c9d7c9d6d5e6c2d9d2c8e6d4c5f9d7c6c9e6f2c1b9d2d3e5c1c0c2d5c2e1e5c8c6e5c2d4b9c5c0d7b9c5e4c2c5c1d5b9c5c4c5c1d7e3c6c6b9d7c4f5f5c1d4c3d6d1e1d4d7b9b9d7c1c9d6c7c7e2b9e4c5c5c5c6c6c2d5c3c3d5c5c4c4e4c8b9c9d7c9d6d5e6c2d9d2c8e6d4c5f9d7c6c9e6f2c1b9d2d3e5c1d4c2d5c2e1e5c8c6e5c2d4b9c5c0d7b9c5e4c2c5c1d5b9c5c4c5c1d7e3c6c6b9d7c4f5f5c1d4c3d6d1e1d4d7b9b9d7c1c9d6c7c7e2b9e4c5c5c5c6c6c2d5c3c3d5c5c4c4e4c8b9c9d7c9d6d5e6c2d9d2c8e6d4c5f9d7c6c9e6f2c1b9d2d3e5c1d4c2d5c2e1e5c8c6e5c2d4b9c5c0d7b9c5e4c2c5c1d5b9c5c4c5c1d7e3c6c6f7b6g0b5b2", -"a2a8a8a7b3b9c8c1c1c3c1c3b9c5c5d5c5c8c5d6c8d6c9f5d0d1c5e7c1d4e6d2f4b9c2e3c8d9e6e4b9d9c2d5e0d8e0c5c4c5c1c8d8c2c5c5c4c5e4c5b9b9c1c1d5c1d7c5c5c5c5c5c6c1c4d7f2e6c3d7d1d5d1d1d5f5d5c8d9c8e5c5d7d7c5e6e2b9c5c4c5b9c8c1c1c3c1c3b9c5c5d5c5c8c5d6c8d6c9f5d0d1c5e7c1d4e6d2f4b9c2e3c8d9e6e4b9d9c2d5e0d8e0c5c4c5c1c8d8c2c5c5c4c5e4c5b9b9c1c1d5c1d7c5c5c5c5c5c6c1c4d7f2e6c3d7d1d5d1d1d5f5d5c8d9c8e5c5d7d7c5e6e2b9c5c4c5b9c8c1c1c3c1c3b9c5c5d5c5c8c5d6c8d6c9f5d0d1c5e7c1d4e6d2f4b9c2e3c8d9e6e4b9d9c2d5e0d8e0c5c4c5c1c8d8c2c5c5c4c5e4c5b9b9c1c1d5c1d7c5c5c5c5c5c6c1c4d7f2e6c3d7d1d5d1d1d5f5d5c8d9c8e5c5d7d7c5e6e2b9c5c4c5b9c8c1c1c3c1c3b9c5c5d5c5c8c5d6c8d6c9f5d0d1c5e7c1d4e6d2f4b9c2e3c8d9e6e4b9d9c2d5e0d8e0c5c4c5c1c8d8c2c5c5c4c5e4c5b9b9c1c1d5c1d7c5c5c5c5c5c6c1c4b6g1e8g0b2", -"a2a8a8b0b3c4c4e0c1d7b9b9c5c5c4c4c2c1d7d6c9e3c6c7c0e5c2d6e6d4e5d2d2c9d7e6d7b9c1b9d2c6d0d4d8c4d8c5e4c8c6e5c4d5c5c5c5c5b9d7c4c4c5c4c1c4c5d4b9d7c5c5c1e5c6d7c1e5c0d4c4d4c8c7e1d8d4d6c7d7e5c8c1d7c1e2b9c5b9e2c5c4c4e0c1d7b9b9c5c5c4c4c2c1d7d6c9e3c6c7c0e5c2d6e6d4e5d2d2c9d7e6d7b9c1b9d2c6d0d4d8c4d8c5e4c8c6e5c4d5c5c5c5c5b9d7c4c4c5c4c1c4c5d4b9d7c5c5c1e5c6d7c1e5c0d4c4d4c8c7e1d8d4d6c7d7e5c8c1d7c1e2b9c5b9e2c5c4c4e0c1d7b9b9c5c5c4c4c2c1d7d6c9e3c6c7c0e5c2d6e6d4e5d2d2c9d7e6d7b9c1b9d2c6d0d4d8c4d8c5e4c8c6e5c4d5c5c5c5c5b9d7c4c4c5c4c1c4c5d4b9d7c5c5c1e5c6d7c1e5c0d4c4d4c8c7e1d8d4d6c7d7e5c8c1d7c1e2b9c5b9e2c5c4c4e0c1d7b9b9c5c5c4c4c2c1d7d6c9e3c6c7c0e5c2d6e6d4e5d2d2c9d7e6d7b9c1b9d2c6d0d4d8c4d8c5e4c8c6e5c4d5c5c5c5c5b9d7c4c4c5c4c1c4c5d4b9d7c5c5c1e5c6b6e8e8e8b2", -"a2a8a8a7b3c2c4c4d7f2b9c4c5c1c4c4c5c4c5c9d7e3c2c5c3e5e6c6c0f5d4b9e4d7c2c5c1e2c2g2e2e5c1c1e0b9c4c5b9c8c6e1c2e0c2c4d7c5d7b9b9c4c1c1c5b9c5e4c5b9d7c5e5c1d1e4c1e5e4c3d4d7e3d7f6d5d7d6c8e6c5c8c1e6e4b9c5d7d7c4c8c2c4c4d7f2b9c4c5c1c4c4c5c4c5c9d7e3c2c5c3e5e6c6c0f5d4b9e4d7c2c5c1e2c2g2e2e5c1c1e0b9c4c5b9c8c6e1c2e0c2c4d7c5d7b9b9c4c1c1c5b9c5e4c5b9d7c5e5c1d1e4c1e5e4c3d4d7e3d7f6d5d7d6c8e6c5c8c1e6e4b9c5d7d7c4c8c2c4c4d7f2b9c4c5c1c4c4c5c4c5c9d7e3c2c5c3e5e6c6c0f5d4b9e4d7c2c5c1e2c2g2e2e5c1c1e0b9c4c5b9c8c6e1c2e0c2c4d7c5d7b9b9c4c1c1c5b9c5e4c5b9d7c5e5c1d1e4c1e5e4c3d4d7e3d7f6d5d7d6c8e6c5c8c1e6e4b9c5d7d7c4c8c2c4c4d7f2b9c4c5c1c4c4c5c4c5c9d7e3c2c5c3e5e6c6c0f5d4b9e4d7c2c5c1e2c2g2e2e5c1c1e0b9c4c5b9c8c6e1c2e0c2c4d7c5d7b9b9c4c1c1c5b9c5e4c5b9d7c5e5c1d1f0e8f8f0b2", -"a2a8a7a7b3c2d7b9d7d4c5c4c1c4c5c1c0c1c4c5c2c1e5c9c5e6c1c2e6g3f5e6c6e6c6c2d7e4c3c2e2d0c4d4e0c5c5c5c5c2d0c4c4e1c1c1c4d7b9d7c5c1d8c4c5c4b9c5d7c1d7c1e5c7e2b9e6c2f3c1d1c8c8c2c4g3d7c7c2d1d7e5e6b9d7c5c4c5c4c4c8c2d7b9d7d4c5c4c1c4c5c1c0c1c4c5c2c1e5c9c5e6c1c2e6g3f5e6c6e6c6c2d7e4c3c2e2d0c4d4e0c5c5c5c5c2d0c4c4e1c1c1c4d7b9d7c5c1d8c4c5c4b9c5d7c1d7c1e5c7e2b9e6c2f3c1d1c8c8c2c4g3d7c7c2d1d7e5e6b9d7c5c4c5c4c4c8c2d7b9d7d4c5c4c1c4c5c1c0c1c4c5c2c1e5c9c5e6c1c2e6g3f5e6c6e6c6c2d7e4c3c2e2d0c4d4e0c5c5c5c5c2d0c4c4e1c1c1c4d7b9d7c5c1d8c4c5c4b9c5d7c1d7c1e5c7e2b9e6c2f3c1d1c8c8c2c4g3d7c7c2d1d7e5e6b9d7c5c4c5c4c4c8c2d7b9d7d4c5c4c1c4c5c1c0c1c4c5c2c1e5c9c5e6c1c2e6g3f5e6c6e6c6c2d7e4c3c2e2d0c4d4e0c5c5c5c5c2d0c4c4e1c1c1c4d7b9d7c5c1d8c4c5c4b9c5d7c1d7c1e5c7e2f7e8b6g1b2", -"a2a7a9a7b3c6c2c2d5c5c5c5e2c2c5d7c5c1c2d7c6d7d7c8c9e6c1e3e6c3d5c1c6d0f6d5c8b9c4c5d7c1c1e0e1c5c5c5c4c2c8c2d5e0c1c1c4d7b9b9d5d5g3d7c1c4c5d7c5c4b9d7c5c5e2d3c0c2e5e6e5c7c9d7d1d5d7d0c6e6c9c1c1e2c5c5c5c4c5c6c2c6c2c2d5c5c5c5e2c2c5d7c5c1c2d7c6d7d7c8c9e6c1e3e6c3d5c1c6d0f6d5c8b9c4c5d7c1c1e0e1c5c5c5c4c2c8c2d5e0c1c1c4d7b9b9d5d5g3d7c1c4c5d7c5c4b9d7c5c5e2d3c0c2e5e6e5c7c9d7d1d5d7d0c6e6c9c1c1e2c5c5c5c4c5c6c2c6c2c2d5c5c5c5e2c2c5d7c5c1c2d7c6d7d7c8c9e6c1e3e6c3d5c1c6d0f6d5c8b9c4c5d7c1c1e0e1c5c5c5c4c2c8c2d5e0c1c1c4d7b9b9d5d5g3d7c1c4c5d7c5c4b9d7c5c5e2d3c0c2e5e6e5c7c9d7d1d5d7d0c6e6c9c1c1e2c5c5c5c4c5c6c2c6c2c2d5c5c5c5e2c2c5d7c5c1c2d7c6d7d7c8c9e6c1e3e6c3d5c1c6d0f6d5c8b9c4c5d7c1c1e0e1c5c5c5c4c2c8c2d5e0c1c1c4d7b9b9d5d5g3d7c1c4c5d7c5c4b9d7c5c5e2f7f8b6e8b2", -"a2a7a7a7b3c2c1d5c5c5c4d7c5c5c5b9c4c4c5d7c6c2e6c1c5e5d4d6e5e5c6d0c6d7g3f6e4e4c2d4c1c1d0f1e0c4c5c5c4c8c6g2e1c4c1d5c5c4e2c5c3c4d5c4c5c5d7b9c5d7c5d7c5e4d6d0c1c5c1c0c8c7e3c6f5g2e5e5e3e3c5c4c1b9c4c1c1c4c1c4c1c2c1d5c5c5c4d7c5c5c5b9c4c4c5d7c6c2e6c1c5e5d4d6e5e5c6d0c6d7g3f6e4e4c2d4c1c1d0f1e0c4c5c5c4c8c6g2e1c4c1d5c5c4e2c5c3c4d5c4c5c5d7b9c5d7c5d7c5e4d6d0c1c5c1c0c8c7e3c6f5g2e5e5e3e3c5c4c1b9c4c1c1c4c1c4c1c2c1d5c5c5c4d7c5c5c5b9c4c4c5d7c6c2e6c1c5e5d4d6e5e5c6d0c6d7g3f6e4e4c2d4c1c1d0f1e0c4c5c5c4c8c6g2e1c4c1d5c5c4e2c5c3c4d5c4c5c5d7b9c5d7c5d7c5e4d6d0c1c5c1c0c8c7e3c6f5g2e5e5e3e3c5c4c1b9c4c1c1c4c1c4c1c2c1d5c5c5c4d7c5c5c5b9c4c4c5d7c6c2e6c1c5e5d4d6e5e5c6d0c6d7g3f6e4e4c2d4c1c1d0f1e0c4c5c5c4c8c6g2e1c4c1d5c5c4e2c5c3c4d5c4c5c5d7b9c5d7c5d7c5e4d6e8e8b6e8b2", -"a2a6a7a8b3c6c5c4c1c5d7e2d7c4c5c5c4c5c6c2d7c2e6d7c6d1c1c0c1d1d4c3d8c3c1e5d2e4e2f9c4c8c6c5c1d5c5c4c4c8d7g2c2c1d5c1d7c5e4c5c5d5c1d7c5c5c5c1c1d7c5c5b9c7e2c4c4d3e7c7c7c2c6d0d4f5g2b9e3c2d2c4d1d7c5c4e0e0c1c2c6c2c5c4c1c5d7e2d7c4c5c5c4c5c6c2d7c2e6d7c6d1c1c0c1d1d4c3d8c3c1e5d2e4e2f9c4c8c6c5c1d5c5c4c4c8d7g2c2c1d5c1d7c5e4c5c5d5c1d7c5c5c5c1c1d7c5c5b9c7e2c4c4d3e7c7c7c2c6d0d4f5g2b9e3c2d2c4d1d7c5c4e0e0c1c2c6c2c5c4c1c5d7e2d7c4c5c5c4c5c6c2d7c2e6d7c6d1c1c0c1d1d4c3d8c3c1e5d2e4e2f9c4c8c6c5c1d5c5c4c4c8d7g2c2c1d5c1d7c5e4c5c5d5c1d7c5c5c5c1c1d7c5c5b9c7e2c4c4d3e7c7c7c2c6d0d4f5g2b9e3c2d2c4d1d7c5c4e0e0c1c2c6c2c5c4c1c5d7e2d7c4c5c5c4c5c6c2d7c2e6d7c6d1c1c0c1d1d4c3d8c3c1e5d2e4e2f9c4c8c6c5c1d5c5c4c4c8d7g2c2c1d5c1d7c5e4c5c5d5c1d7c5c5c5c1c1d7c5c5b9c7e2f8f8f7f0b2", -"a2a6a6a7b3c2b9d5c4e4e4c5e4c5b9c4b9c4c1c9d0c1d1e6d7d7d5c5e5f6e0d8d8c1e6d2e4e2f2d7c5c5c5c4c1d5c1c4c2c8e5c1c4d5d5c4e4b9c5d7c4c1c1c0c5c5d7c1c4c5c5d7c7e7d9c4c3d2f4d3d9b9c7c5f6f5e4d2c5c4f4e6d1d7c5c4e0g2c3c1c6c2b9d5c4e4e4c5e4c5b9c4b9c4c1c9d0c1d1e6d7d7d5c5e5f6e0d8d8c1e6d2e4e2f2d7c5c5c5c4c1d5c1c4c2c8e5c1c4d5d5c4e4b9c5d7c4c1c1c0c5c5d7c1c4c5c5d7c7e7d9c4c3d2f4d3d9b9c7c5f6f5e4d2c5c4f4e6d1d7c5c4e0g2c3c1c6c2b9d5c4e4e4c5e4c5b9c4b9c4c1c9d0c1d1e6d7d7d5c5e5f6e0d8d8c1e6d2e4e2f2d7c5c5c5c4c1d5c1c4c2c8e5c1c4d5d5c4e4b9c5d7c4c1c1c0c5c5d7c1c4c5c5d7c7e7d9c4c3d2f4d3d9b9c7c5f6f5e4d2c5c4f4e6d1d7c5c4e0g2c3c1c6c2b9d5c4e4e4c5e4c5b9c4b9c4c1c9d0c1d1e6d7d7d5c5e5f6e0d8d8c1e6d2e4e2f2d7c5c5c5c4c1d5c1c4c2c8e5c1c4d5d5c4e4b9c5d7c4c1c1c0c5c5d7c1c4c5c5d7c7e7b9g0g0g1g4b2", -"a2a7a7a7b3d0c4c5b9c1c4c1b9c1b9c3c2e3c2c8c0e5g2d0c2c6g2c5e5c3d8c4d0d6c0d3d2c2e4b9g5e5c5c4c4c5c1e5c5c2e5c5c4c4c1b9c4e4c5c5c4c4c4c1d7c5c5c4c5c5c5d7c5d7d7d1d4d2d2d3b9c7c7c8c2c1f2f3b9d5b9c1e3c8c7c5e5d1d1c1c2c1c4c5b9c1c4c1b9c1b9c3c2e3c2c8c0e5g2d0c2c6g2c5e5c3d8c4d0d6c0d3d2c2e4b9g5e5c5c4c4c5c1e5c5c2e5c5c4c4c1b9c4e4c5c5c4c4c4c1d7c5c5c4c5c5c5d7c5d7d7d1d4d2d2d3b9c7c7c8c2c1f2f3b9d5b9c1e3c8c7c5e5d1d1c1c2c1c4c5b9c1c4c1b9c1b9c3c2e3c2c8c0e5g2d0c2c6g2c5e5c3d8c4d0d6c0d3d2c2e4b9g5e5c5c4c4c5c1e5c5c2e5c5c4c4c1b9c4e4c5c5c4c4c4c1d7c5c5c4c5c5c5d7c5d7d7d1d4d2d2d3b9c7c7c8c2c1f2f3b9d5b9c1e3c8c7c5e5d1d1c1c2c1c4c5b9c1c4c1b9c1b9c3c2e3c2c8c0e5g2d0c2c6g2c5e5c3d8c4d0d6c0d3d2c2e4b9g5e5c5c4c4c5c1e5c5c2e5c5c4c4c1b9c4e4c5c5c4c4c4c1d7c5c5c4c5c5c5d7c5d7d7f8g0g1g4b2", -"a2a6a7a7b3c2d5c3c1c5c5c1c5c1c4d7e3e3c6c3c1c0c4d1c6c6d4e5c0d4c1c6c5c9b9g6d3e2b9b9b9c5c5c1c4c3c5e5c3d1e5c4c1e0c2b9c0b9c5b9d5d5d4c1c1d7b9c4d7c5d7b9c5d7c8d5c0d6b9d3b9c7c5c8c6d7e4c5c5b9d6d7c2e6c1e5g2c4d1c1c4c2d5c3c1c5c5c1c5c1c4d7e3e3c6c3c1c0c4d1c6c6d4e5c0d4c1c6c5c9b9g6d3e2b9b9b9c5c5c1c4c3c5e5c3d1e5c4c1e0c2b9c0b9c5b9d5d5d4c1c1d7b9c4d7c5d7b9c5d7c8d5c0d6b9d3b9c7c5c8c6d7e4c5c5b9d6d7c2e6c1e5g2c4d1c1c4c2d5c3c1c5c5c1c5c1c4d7e3e3c6c3c1c0c4d1c6c6d4e5c0d4c1c6c5c9b9g6d3e2b9b9b9c5c5c1c4c3c5e5c3d1e5c4c1e0c2b9c0b9c5b9d5d5d4c1c1d7b9c4d7c5d7b9c5d7c8d5c0d6b9d3b9c7c5c8c6d7e4c5c5b9d6d7c2e6c1e5g2c4d1c1c4c2d5c3c1c5c5c1c5c1c4d7e3e3c6c3c1c0c4d1c6c6d4e5c0d4c1c6c5c9b9g6d3e2b9b9b9c5c5c1c4c3c5e5c3d1e5c4c1e0c2b9c0b9c5b9d5d5d4c1c1d7b9c4d7c5d7b9c5d7c8b5g0f0e9b2", -"a2a6a8a7b3b9c1c2c2e4c5c1c0d5c6c9d6c6c6c0c1c4g2d1c6d1c4c0d4c4e6e6e3c2c9c8g6e4c5b9b9d7c5c2c5c2c3d8e1d4c8e0d8d5b9c5d7b9c5d7c5c1c4c1c4e2c5c5d7c5d7d7d7c8b9f6c3d9b9e7c8b9c7c5c5c6b9e4c5b9d3d7c2c0c3d5g2c4c2c4c5b9c1c2c2e4c5c1c0d5c6c9d6c6c6c0c1c4g2d1c6d1c4c0d4c4e6e6e3c2c9c8g6e4c5b9b9d7c5c2c5c2c3d8e1d4c8e0d8d5b9c5d7b9c5d7c5c1c4c1c4e2c5c5d7c5d7d7d7c8b9f6c3d9b9e7c8b9c7c5c5c6b9e4c5b9d3d7c2c0c3d5g2c4c2c4c5b9c1c2c2e4c5c1c0d5c6c9d6c6c6c0c1c4g2d1c6d1c4c0d4c4e6e6e3c2c9c8g6e4c5b9b9d7c5c2c5c2c3d8e1d4c8e0d8d5b9c5d7b9c5d7c5c1c4c1c4e2c5c5d7c5d7d7d7c8b9f6c3d9b9e7c8b9c7c5c5c6b9e4c5b9d3d7c2c0c3d5g2c4c2c4c5b9c1c2c2e4c5c1c0d5c6c9d6c6c6c0c1c4g2d1c6d1c4c0d4c4e6e6e3c2c9c8g6e4c5b9b9d7c5c2c5c2c3d8e1d4c8e0d8d5b9c5d7b9c5d7c5c1c4c1c4e2c5c5d7c5d7d7d7c8b9g0g0f0f7b2", -"a2a7a9a7b3c4c5f2e5d7c5d5c4c1c1c6c6c0d5c5c0d5d5d5c8c2d4c2d0e5c1e6c6e6c0c1e4e4c2c5d7c5c5c5d5c4c5c5c3c2c1e0d8c1b9b9b9d2e4e4c5c4c5c5c5b9c4c5d7c5d7b9c8d7d7c7c5c5c6b9d7b9c5c7c2e6e2b9d7c5d9e6c1d4c3e6d1d1c2c4c5c4c5f2e5d7c5d5c4c1c1c6c6c0d5c5c0d5d5d5c8c2d4c2d0e5c1e6c6e6c0c1e4e4c2c5d7c5c5c5d5c4c5c5c3c2c1e0d8c1b9b9b9d2e4e4c5c4c5c5c5b9c4c5d7c5d7b9c8d7d7c7c5c5c6b9d7b9c5c7c2e6e2b9d7c5d9e6c1d4c3e6d1d1c2c4c5c4c5f2e5d7c5d5c4c1c1c6c6c0d5c5c0d5d5d5c8c2d4c2d0e5c1e6c6e6c0c1e4e4c2c5d7c5c5c5d5c4c5c5c3c2c1e0d8c1b9b9b9d2e4e4c5c4c5c5c5b9c4c5d7c5d7b9c8d7d7c7c5c5c6b9d7b9c5c7c2e6e2b9d7c5d9e6c1d4c3e6d1d1c2c4c5c4c5f2e5d7c5d5c4c1c1c6c6c0d5c5c0d5d5d5c8c2d4c2d0e5c1e6c6e6c0c1e4e4c2c5d7c5c5c5d5c4c5c5c3c2c1e0d8c1b9b9b9d2e4e4c5c4c5c5c5b9c4c5d7c5d7b9c8d7c7b6b6e8b6b2", -"a2a7a6a7b3c5d5c4c5d5b9d7c4c6d1c2c2c4d5b9c4d5d8e5b9d7d0d7c0e5c1c6e3c5e5c1e4e4d5c4e2b9c5c1c4d5e0e1c2c2e6d5d5d4b9b9c0e4b9b9c4e2e4c5e2c5c5c1d7c4e4b9c5e6e3d7c5e6d3e2c2d7e5b9c6c5d7c5c5f4b9c1d1c0d1c1d1c1g2c1c4c5d5c4c5d5b9d7c4c6d1c2c2c4d5b9c4d5d8e5b9d7d0d7c0e5c1c6e3c5e5c1e4e4d5c4e2b9c5c1c4d5e0e1c2c2e6d5d5d4b9b9c0e4b9b9c4e2e4c5e2c5c5c1d7c4e4b9c5e6e3d7c5e6d3e2c2d7e5b9c6c5d7c5c5f4b9c1d1c0d1c1d1c1g2c1c4c5d5c4c5d5b9d7c4c6d1c2c2c4d5b9c4d5d8e5b9d7d0d7c0e5c1c6e3c5e5c1e4e4d5c4e2b9c5c1c4d5e0e1c2c2e6d5d5d4b9b9c0e4b9b9c4e2e4c5e2c5c5c1d7c4e4b9c5e6e3d7c5e6d3e2c2d7e5b9c6c5d7c5c5f4b9c1d1c0d1c1d1c1g2c1c4c5d5c4c5d5b9d7c4c6d1c2c2c4d5b9c4d5d8e5b9d7d0d7c0e5c1c6e3c5e5c1e4e4d5c4e2b9c5c1c4d5e0e1c2c2e6d5d5d4b9b9c0e4b9b9c4e2e4c5e2c5c5c1d7c4e4b9c5e6e3b6e8b8f7b2", -"a2a7a7a7b3c0c0c5c4d5d5c1d5c6c1e6c5f5d5c4d7c2e6e6d6d6c5d1c1c1e6c0e3e3d0c2e4b9c4b9c5c4c5b9c4e0e0e1c4e5c6d5d5c5c0d7e4b9b9b9c5c5e2b9c4c5c4c5d7c5e2e2c5d7d7c5c1c5g6d3e7c2b9d7c6c7e2c5d7f9d6c1d4d4d5e5d1e5c4c1b9c0c0c5c4d5d5c1d5c6c1e6c5f5d5c4d7c2e6e6d6d6c5d1c1c1e6c0e3e3d0c2e4b9c4b9c5c4c5b9c4e0e0e1c4e5c6d5d5c5c0d7e4b9b9b9c5c5e2b9c4c5c4c5d7c5e2e2c5d7d7c5c1c5g6d3e7c2b9d7c6c7e2c5d7f9d6c1d4d4d5e5d1e5c4c1b9c0c0c5c4d5d5c1d5c6c1e6c5f5d5c4d7c2e6e6d6d6c5d1c1c1e6c0e3e3d0c2e4b9c4b9c5c4c5b9c4e0e0e1c4e5c6d5d5c5c0d7e4b9b9b9c5c5e2b9c4c5c4c5d7c5e2e2c5d7d7c5c1c5g6d3e7c2b9d7c6c7e2c5d7f9d6c1d4d4d5e5d1e5c4c1b9c0c0c5c4d5d5c1d5c6c1e6c5f5d5c4d7c2e6e6d6d6c5d1c1c1e6c0e3e3d0c2e4b9c4b9c5c4c5b9c4e0e0e1c4e5c6d5d5c5c0d7e4b9b9b9c5c5e2b9c4c5c4c5d7c5e2e2c5d7d7e8b8e8g1b2", -"a1a9a7a6b3b9c5c1c4c4d8d5c2c6c5d0c2g2d5c5c9c2d7c6c8c8c8g7c1e6d1c0c5c2c5d4d0e4e2c5c5c5c9d7c4d5e1d5c1e5d1e0c5c4c5c5c5c5c4b9d7c5e2e2c2c5c1c4c5b9d7b9e6d7c5d7c5e5d2b9d6e5d7d6c5d7e7c8b9c7c7c1e5d5d1c0c3c2d1d5c4b9c5c1c4c4d8d5c2c6c5d0c2g2d5c5c9c2d7c6c8c8c8g7c1e6d1c0c5c2c5d4d0e4e2c5c5c5c9d7c4d5e1d5c1e5d1e0c5c4c5c5c5c5c4b9d7c5e2e2c2c5c1c4c5b9d7b9e6d7c5d7c5e5d2b9d6e5d7d6c5d7e7c8b9c7c7c1e5d5d1c0c3c2d1d5c4b9c5c1c4c4d8d5c2c6c5d0c2g2d5c5c9c2d7c6c8c8c8g7c1e6d1c0c5c2c5d4d0e4e2c5c5c5c9d7c4d5e1d5c1e5d1e0c5c4c5c5c5c5c4b9d7c5e2e2c2c5c1c4c5b9d7b9e6d7c5d7c5e5d2b9d6e5d7d6c5d7e7c8b9c7c7c1e5d5d1c0c3c2d1d5c4b9c5c1c4c4d8d5c2c6c5d0c2g2d5c5c9c2d7c6c8c8c8g7c1e6d1c0c5c2c5d4d0e4e2c5c5c5c9d7c4d5e1d5c1e5d1e0c5c4c5c5c5c5c4b9d7c5e2e2c2c5c1c4c5b9d7b9e6d7c5b6e8e8g1b2", -"a2a7a7a7b3b9c5c4c1c1c4c4c4d7e6d0c1f5d5c6c9d7e3c2c2d7c2f1d7d7c4e5d7c4e4d7c4e2e2c5c4d7d9d7d5c4e0d5e0e5c8e4c5c5c2c5e4c5c5c5b9d7e2b9c1c4e2b9b9e2b9c1c5d6d9e5e5c2b9c7c8c6e5c7e4c7b9c7d2d3c1e5c0c3c3c4d1d1c4c4c5b9c5c4c1c1c4c4c4d7e6d0c1f5d5c6c9d7e3c2c2d7c2f1d7d7c4e5d7c4e4d7c4e2e2c5c4d7d9d7d5c4e0d5e0e5c8e4c5c5c2c5e4c5c5c5b9d7e2b9c1c4e2b9b9e2b9c1c5d6d9e5e5c2b9c7c8c6e5c7e4c7b9c7d2d3c1e5c0c3c3c4d1d1c4c4c5b9c5c4c1c1c4c4c4d7e6d0c1f5d5c6c9d7e3c2c2d7c2f1d7d7c4e5d7c4e4d7c4e2e2c5c4d7d9d7d5c4e0d5e0e5c8e4c5c5c2c5e4c5c5c5b9d7e2b9c1c4e2b9b9e2b9c1c5d6d9e5e5c2b9c7c8c6e5c7e4c7b9c7d2d3c1e5c0c3c3c4d1d1c4c4c5b9c5c4c1c1c4c4c4d7e6d0c1f5d5c6c9d7e3c2c2d7c2f1d7d7c4e5d7c4e4d7c4e2e2c5c4d7d9d7d5c4e0d5e0e5c8e4c5c5c2c5e4c5c5c5b9d7e2b9c1c4e2b9b9e2b9c1c5d6d9e8e8e8f0b2", -"a1a7a7a7b3c5c0c2c1d5c5d7d4c6c2e6e1c4c1b9c9c6e3c6c2d9e4f1b9d7b9e5d6c4e4d7c4e2e2c5c2d7c6c4d5e0d5e0c5b9f2e4b9c5c1b9b9d5c1c4e4b9b9c5c4c5c5d7c5e2b9c5d7d6d7c1e6d7c5d7c6e5d7e7d7c5b9c5e2b9d7c0c3d1d1d1d5c0c3c1c4c5c0c2c1d5c5d7d4c6c2e6e1c4c1b9c9c6e3c6c2d9e4f1b9d7b9e5d6c4e4d7c4e2e2c5c2d7c6c4d5e0d5e0c5b9f2e4b9c5c1b9b9d5c1c4e4b9b9c5c4c5c5d7c5e2b9c5d7d6d7c1e6d7c5d7c6e5d7e7d7c5b9c5e2b9d7c0c3d1d1d1d5c0c3c1c4c5c0c2c1d5c5d7d4c6c2e6e1c4c1b9c9c6e3c6c2d9e4f1b9d7b9e5d6c4e4d7c4e2e2c5c2d7c6c4d5e0d5e0c5b9f2e4b9c5c1b9b9d5c1c4e4b9b9c5c4c5c5d7c5e2b9c5d7d6d7c1e6d7c5d7c6e5d7e7d7c5b9c5e2b9d7c0c3d1d1d1d5c0c3c1c4c5c0c2c1d5c5d7d4c6c2e6e1c4c1b9c9c6e3c6c2d9e4f1b9d7b9e5d6c4e4d7c4e2e2c5c2d7c6c4d5e0d5e0c5b9f2e4b9c5c1b9b9d5c1c4e4b9b9c5c4c5c5d7c5e2b9c5d7d6d7b8b8b6b6b2", -"a2a7a7a6b3c5c4c2c1d5c5e2d5c1c2d1c3c0c4c2c6c2c2c2c2d7c5f1c2d7b9e4d7c2c5c6e5b9c2d7c9c6c5c1d5d8e0d8f2b9b9e4b9b9b9c0c5c4d7b9c5e2b9c4d4d7c1c5d7e2b9c5c4d7c5e5d7d7c7c2d7c5d3d3d7c1e2c5d7d9c2c0c0c5d4d4d1c0e5d5c4c5c4c2c1d5c5e2d5c1c2d1c3c0c4c2c6c2c2c2c2d7c5f1c2d7b9e4d7c2c5c6e5b9c2d7c9c6c5c1d5d8e0d8f2b9b9e4b9b9b9c0c5c4d7b9c5e2b9c4d4d7c1c5d7e2b9c5c4d7c5e5d7d7c7c2d7c5d3d3d7c1e2c5d7d9c2c0c0c5d4d4d1c0e5d5c4c5c4c2c1d5c5e2d5c1c2d1c3c0c4c2c6c2c2c2c2d7c5f1c2d7b9e4d7c2c5c6e5b9c2d7c9c6c5c1d5d8e0d8f2b9b9e4b9b9b9c0c5c4d7b9c5e2b9c4d4d7c1c5d7e2b9c5c4d7c5e5d7d7c7c2d7c5d3d3d7c1e2c5d7d9c2c0c0c5d4d4d1c0e5d5c4c5c4c2c1d5c5e2d5c1c2d1c3c0c4c2c6c2c2c2c2d7c5f1c2d7b9e4d7c2c5c6e5b9c2d7c9c6c5c1d5d8e0d8f2b9b9e4b9b9b9c0c5c4d7b9c5e2b9c4d4d7c1c5d7e2b9c5c4d7c5e8b6b6b6b2", -"a2a7a6a7b3c5c5c1c2d8c1d7c1d5c1d1d1f6f5c2c1d1c3d7d7c5d8f1c6c9c6d7d7d6c9d9d5e5c5c2d7d7c4d8c1c4d9d2b9c8f2c5e4c2b9c4c4c5c2c5b9c5e2c1e5c5c1c4d7b9b9d7d7e7c9e2b9e2d3d3b9b9g6e4e2b9d7e5c8d3b9c0c0d7d7d1c2c0g2c4c2c5c5c1c2d8c1d7c1d5c1d1d1f6f5c2c1d1c3d7d7c5d8f1c6c9c6d7d7d6c9d9d5e5c5c2d7d7c4d8c1c4d9d2b9c8f2c5e4c2b9c4c4c5c2c5b9c5e2c1e5c5c1c4d7b9b9d7d7e7c9e2b9e2d3d3b9b9g6e4e2b9d7e5c8d3b9c0c0d7d7d1c2c0g2c4c2c5c5c1c2d8c1d7c1d5c1d1d1f6f5c2c1d1c3d7d7c5d8f1c6c9c6d7d7d6c9d9d5e5c5c2d7d7c4d8c1c4d9d2b9c8f2c5e4c2b9c4c4c5c2c5b9c5e2c1e5c5c1c4d7b9b9d7d7e7c9e2b9e2d3d3b9b9g6e4e2b9d7e5c8d3b9c0c0d7d7d1c2c0g2c4c2c5c5c1c2d8c1d7c1d5c1d1d1f6f5c2c1d1c3d7d7c5d8f1c6c9c6d7d7d6c9d9d5e5c5c2d7d7c4d8c1c4d9d2b9c8f2c5e4c2b9c4c4c5c2c5b9c5e2c1e5c5c1c4d7b9b9d7d7e7c9e9f7e9f7b2", -"a2a7a6a9b3c5b9c6c1d8c2d6e6c2c3d4d7e1d8c2c6d5d1d5d1c4c1d7c6d6d7c9c9c8e2d9d5e5b9c5c5c5c4c4d5d6e4b9c5e4c5c5b9c4c4c1c1e2c5c5d7e2e4c4e4c5c1c4f2b9d7c5b9b9c5b9c9e7d3b9e4e4f2e2e2e3d7e5d7d9e6c1d4c5c2c1c2c0f5e6c4c5b9c6c1d8c2d6e6c2c3d4d7e1d8c2c6d5d1d5d1c4c1d7c6d6d7c9c9c8e2d9d5e5b9c5c5c5c4c4d5d6e4b9c5e4c5c5b9c4c4c1c1e2c5c5d7e2e4c4e4c5c1c4f2b9d7c5b9b9c5b9c9e7d3b9e4e4f2e2e2e3d7e5d7d9e6c1d4c5c2c1c2c0f5e6c4c5b9c6c1d8c2d6e6c2c3d4d7e1d8c2c6d5d1d5d1c4c1d7c6d6d7c9c9c8e2d9d5e5b9c5c5c5c4c4d5d6e4b9c5e4c5c5b9c4c4c1c1e2c5c5d7e2e4c4e4c5c1c4f2b9d7c5b9b9c5b9c9e7d3b9e4e4f2e2e2e3d7e5d7d9e6c1d4c5c2c1c2c0f5e6c4c5b9c6c1d8c2d6e6c2c3d4d7e1d8c2c6d5d1d5d1c4c1d7c6d6d7c9c9c8e2d9d5e5b9c5c5c5c4c4d5d6e4b9c5e4c5c5b9c4c4c1c1e2c5c5d7e2e4c4e4c5c1c4f2b9d7c5b9b9c5f7f0e9g1b2", -"a2a7a6a7b3c5b9c2c2c1c1c2c2e3d0c3c8d8c2c2c4d5d5d1d5d4c1c5d7c9c5c8d6e7d9b9c4d0d4c2c5c4c2c5c1b9e4b9c9d7e3c5c6c6c1c1d1c1c5d7d6c7e3e6c6c5c1c5b9c5d2d7d7c5d7c5d7e7d2f3b9b9e2f2d7c2c1c4d7f2e5f6e6c5c6c2c0c4f5c1d8c5b9c2c2c1c1c2c2e3d0c3c8d8c2c2c4d5d5d1d5d4c1c5d7c9c5c8d6e7d9b9c4d0d4c2c5c4c2c5c1b9e4b9c9d7e3c5c6c6c1c1d1c1c5d7d6c7e3e6c6c5c1c5b9c5d2d7d7c5d7c5d7e7d2f3b9b9e2f2d7c2c1c4d7f2e5f6e6c5c6c2c0c4f5c1d8c5b9c2c2c1c1c2c2e3d0c3c8d8c2c2c4d5d5d1d5d4c1c5d7c9c5c8d6e7d9b9c4d0d4c2c5c4c2c5c1b9e4b9c9d7e3c5c6c6c1c1d1c1c5d7d6c7e3e6c6c5c1c5b9c5d2d7d7c5d7c5d7e7d2f3b9b9e2f2d7c2c1c4d7f2e5f6e6c5c6c2c0c4f5c1d8c5b9c2c2c1c1c2c2e3d0c3c8d8c2c2c4d5d5d1d5d4c1c5d7c9c5c8d6e7d9b9c4d0d4c2c5c4c2c5c1b9e4b9c9d7e3c5c6c6c1c1d1c1c5d7d6c7e3e6c6c5c1c5b9c5d2d7d7c5d7b8b6e9g1b2", -"a2a6a7a9a5c5b9c6c6d8c1c1d7e5e6d5c4d8c6c6d5d4d1d5d1d7c5c1e3c5c1c2c8e7e4b9e4e0d5d8c5b9e4b9f2b9c5e2d7d7c5e6e6e6c1c6c2e3c5e3d6c9d6c6c1c4c4c1c1b9d7e2c5d7c5d7e7e4b9e2b9d2e3c1c2c6d7d0d9e5d1c3c5c2d7c6c0c3c4c2e0c5b9c6c6d8c1c1d7e5e6d5c4d8c6c6d5d4d1d5d1d7c5c1e3c5c1c2c8e7e4b9e4e0d5d8c5b9e4b9f2b9c5e2d7d7c5e6e6e6c1c6c2e3c5e3d6c9d6c6c1c4c4c1c1b9d7e2c5d7c5d7e7e4b9e2b9d2e3c1c2c6d7d0d9e5d1c3c5c2d7c6c0c3c4c2e0c5b9c6c6d8c1c1d7e5e6d5c4d8c6c6d5d4d1d5d1d7c5c1e3c5c1c2c8e7e4b9e4e0d5d8c5b9e4b9f2b9c5e2d7d7c5e6e6e6c1c6c2e3c5e3d6c9d6c6c1c4c4c1c1b9d7e2c5d7c5d7e7e4b9e2b9d2e3c1c2c6d7d0d9e5d1c3c5c2d7c6c0c3c4c2e0c5b9c6c6d8c1c1d7e5e6d5c4d8c6c6d5d4d1d5d1d7c5c1e3c5c1c2c8e7e4b9e4e0d5d8c5b9e4b9f2b9c5e2d7d7c5e6e6e6c1c6c2e3c5e3d6c9d6c6c1c4c4c1c1b9d7e2c5d7c5b6e9f0f0b2", -"a2a6a7a9a5d5c4d9c2e6c1c2c5e5c2d1c1d5c1d5d5d1c4c4c1d7c1c9c8e3e5e6c6c2c9d9c5d8d5f5e4c2e4b9e4c5d7f2d7d7c5c1c1c1c1c2d7e3d7e3d6e7b9c2c2c1c1c4b9b9c4e4d7c5c5c9b9c5b9d3f2c5c2d7c2b9d7d0c1e5c0c4d7e5d7c6e5g2d1c2d5d5c4d9c2e6c1c2c5e5c2d1c1d5c1d5d5d1c4c4c1d7c1c9c8e3e5e6c6c2c9d9c5d8d5f5e4c2e4b9e4c5d7f2d7d7c5c1c1c1c1c2d7e3d7e3d6e7b9c2c2c1c1c4b9b9c4e4d7c5c5c9b9c5b9d3f2c5c2d7c2b9d7d0c1e5c0c4d7e5d7c6e5g2d1c2d5d5c4d9c2e6c1c2c5e5c2d1c1d5c1d5d5d1c4c4c1d7c1c9c8e3e5e6c6c2c9d9c5d8d5f5e4c2e4b9e4c5d7f2d7d7c5c1c1c1c1c2d7e3d7e3d6e7b9c2c2c1c1c4b9b9c4e4d7c5c5c9b9c5b9d3f2c5c2d7c2b9d7d0c1e5c0c4d7e5d7c6e5g2d1c2d5d5c4d9c2e6c1c2c5e5c2d1c1d5c1d5d5d1c4c4c1d7c1c9c8e3e5e6c6c2c9d9c5d8d5f5e4c2e4b9e4c5d7f2d7d7c5c1c1c1c1c2d7e3d7e3d6e7b9c2c2c1c1c4b9b9c4e4d7c5c5f0f0b6f0b2", -"a2a7a7a7b3c4d5c2d1d7e6d7c4c2e0d5c1c6c2c4c2c1c1d5d7d7c2d7c5f6g3c1c0c4d9b9f5e5c4d5b9b9d5b9e4e4e4b9c2e3c6c1c1c4d0c2c6e3c9c9c8c9b9c8d7c4c1c4e2c4b9c5e4c5c2b9d7b9d3d2g8d6c2c2e4e2d7d0c6e5e2c1c2c1c1c6c1d1d1c4c1c4d5c2d1d7e6d7c4c2e0d5c1c6c2c4c2c1c1d5d7d7c2d7c5f6g3c1c0c4d9b9f5e5c4d5b9b9d5b9e4e4e4b9c2e3c6c1c1c4d0c2c6e3c9c9c8c9b9c8d7c4c1c4e2c4b9c5e4c5c2b9d7b9d3d2g8d6c2c2e4e2d7d0c6e5e2c1c2c1c1c6c1d1d1c4c1c4d5c2d1d7e6d7c4c2e0d5c1c6c2c4c2c1c1d5d7d7c2d7c5f6g3c1c0c4d9b9f5e5c4d5b9b9d5b9e4e4e4b9c2e3c6c1c1c4d0c2c6e3c9c9c8c9b9c8d7c4c1c4e2c4b9c5e4c5c2b9d7b9d3d2g8d6c2c2e4e2d7d0c6e5e2c1c2c1c1c6c1d1d1c4c1c4d5c2d1d7e6d7c4c2e0d5c1c6c2c4c2c1c1d5d7d7c2d7c5f6g3c1c0c4d9b9f5e5c4d5b9b9d5b9e4e4e4b9c2e3c6c1c1c4d0c2c6e3c9c9c8c9b9c8d7c4c1c4e2c4b9c5e4c5c2f0b6f0e9b2", -"a2a7a6a6a5c1c6d1d5d0d1e0c2d7d7c1c5c9d9g9h0b0d2d5d5d8c6d5d7d1c2c6c1c4c2c1c5c1d5e5c5e4c2c2c2e4b9c5c6c6c1d1c2b1b0h1a5a7g6f2d6c7d6d6d6c1c5c1c4c5c5d7c5d7c5d7e4b9g6e4e2b9c5h2b1h2h2h2h2h2h2h2h2f4e4d1c0d1d4c3d5c1c6d1d5d0d1e0c2d7d7c1c5c9d9c5c5c1c0d5d5d8c6d5d7d1c2c6c1c4c2c1c5c1d5e5c5e4c2c2c2e4b9c5c6c6c1d1d1g9h2h2c3d9g6f2d6c7d6d6d6c1c5c1c4c5c5d7c5d7c5d7e4b9g6e4e2b9c5e2e2e4d0c1c6e5h2h2h2g6d4d1c0d1d4c3d5c1c6d1d5d0d1e0c2d7d7c1c5c9d9c5c5c1c0d5d5d8c6d5d7d1c2c6c1c4c2c1c5c1d5e5c5e4c2c2c2e4b9c5c6c6c1d1d1d4c5c5c0d9g6f2d6c7d6d6d6c1c5c1c4c5c5d7c5d7c5d7e4b9g6e4e2b9c5e2e2e4d0g9h2h2d7c2c1e5c4d1c0d1d4c3d5c1c6d1d5d0d1e0c2d7d7c1c5c9d9c5c5c1c0d5d5d8c6d5d7d1c2c6c1c4c2c1c5c1d5e5c5e4c2c2c2e4b9c5c6c6c1d1d1d4c5c5c0d9g6f2d6c7d6d6d6c1c5c1c4c5c5d7c5d7c5b6e9f0g1b2", -"a2a8a6a7a5c2c2e1d5e6d5f1c2c1c5c5b9c2c9b1h3a5b0b9e1e1c1c2c4d5c1c5c4c1c3d5c4c2f6d5b9e5c5b9c5b9b9c4e6e6c1d2b7h4b7a5h5h5b0e4d7d7d6d6c8c1c4c4c5c5d7e4c5c9b9b9d7d9e2f9e4e4d9b3h3b7b7h3b7b7h3b7b7b7h3b3b1f4c3e5e0c2c2e1d5e6d5f1c2c1c5c5b9c2c9b9c5c2c4f6e1e1c1c2c4d5c1c5c4c1c3d5c4c2f6d5b9e5c5b9c5b9b9c4e6e6c1d4d5a5h5a5h6g6f3e4d7d7d6d6c8c1c4c4c5c5d7e4c5c9b9b9d7d9e2f9e4e4b9c5e4b9e5e5c5h2h1b7b7h7d6c0c0c5c3e5e0c2c2e1d5e6d5f1c2c1c5c5b9c2c9b9c5c2c4f6e1e1c1c2c4d5c1c5c4c1c3d5c4c2f6d5b9e5c5b9c5b9b9c4e6e6c1d4d1c1d7c6c1f3f3e4d7d7d6d6c8c1c4c4c5c5d7e4c5c9b9b9d7d9e2f9e4e4b9c5e4b9e5h1h3b7h8d1e5c1d4c0c0c5c3e5e0c2c2e1d5e6d5f1c2c1c5c5b9c2c9b9c5c2c4f6e1e1c1c2c4d5c1c5c4c1c3d5c4c2f6d5b9e5c5b9c5b9b9c4e6e6c1d4d1c1d7c6c1f3f3e4d7d7d6d6c8c1c4c4c5c5d7e4c5c9b9f0b6f0g1b2", -"a2a7a6a7a5e6c1f1d0c1d1e0d7c2c1c5c1d7c9h0a5h5h5h9g5e1c0c5d7c1f1d5d1e1d8c3c2c4d5d5b9c4d9c6c2b9c4b9e6c6c1h0h4h5h5h5h5h5i0f0e6d0d7e7c9c4c4c5c1e4c5c5e4c4d7c4e2b9g6d2d3b9d2h1h5h5h5h5h5h5h5h5h5h5h5h5h5b7a8d7d5c6c1f1d0c1d1e0d7c2c1c5c1d7c9e4c4c8c4d8e1d8e6d7d7c1f1d5d1e1d8c3c2c4d5d5b9c4d9c6c2b9c4b9e6c6c1c4c1h1h5i0h8g7f2b9c8e3c8e7c9c4c4c5c1e4c5c5e4c4d7c4e2b9g6d2d3b9e4b9e2b9e5c4f3b7b7h5h5h5g8e1d4c4d5c4d5c6c1f1d0c1d1e0d7c2c1c5c1d7c9e4c4c8c4d8e1d8e6d7d7c1f1d5d1e1d8c3c2c4d5d5b9c4d9c6c2b9c4b9e6c6c1c4c1e3c5c1c6f3d2e4c7e3c8e7c9c4c4c5c1e4c5c5e4c4d7c4e2b9g6d2d3b9e4b9e2b9d2h1h5h5b0i1c3c4d4d1c0c4c3d4d5c6c1f1d0c1d1e0d7c2c1c5c1d7c9e4c4c8c4d8e1d8e6d7d7c1f1d5d1e1d8c3c2c4d5d5b9c4d9c6c2b9c4b9e6c6c1c4c1e3c5c1c6f3d2e4c7e3c8e7c9c4c4c5c1e4c5c5e4c4d7f8g1f0g1b2", -"a2a7a7a7b3c2c1e0e6c6c1d5c2d7b9c1d5c5d7b7a5h5h5i2i3f6e5d7d2e3f1f6c4d8d8g3c1b9f5d0c4d5c2f2b9b9c0e2c6c1d2h1h5h5i0h8c9g2e1i2e1f5d4c5c9c5b9c4c5b9c0c5d3c8b9c0e2e4d2f9e4d9f9h1h5h5h5h5h5h5h5h5h5h5h5h5h5h5h5i0d2d0e5e0e6c6c1d5c2d7b9c1d5c5d7e4b9d5e5d4d5c9c9c9f9e3f1f6c4d8d8g3c1b9f5d0c4d5c2f2b9b9c0e2c6c1d4d0f9h1h5h5c9g1e6e6e6c2e3c7c9c5b9c4c5b9c0c5d3c8b9c0e2e4d2f9e4b9c5c4b9c2c1c4b1h1h5h5h5h5h6h9e0d8d5d4c4c2c1e0e6c6c1d5c2d7b9c1d5c5d7e4b9d5e5d4d5c9c9c9f9e3f1f6c4d8d8g3c1b9f5d0c4d5c2f2b9b9c0e2c6c1d4c1c6e3d0c2g6d2g6b9c7d7e3c7c9c5b9c4c5b9c0c5d3c8b9c0e2e4d2f9e4b9c5c4b9c2d2h2h5h5h8i4g2e1e0f5c0d1d1c4c4c2c1e0e6c6c1d5c2d7b9c1d5c5d7e4b9d6e5d4d5c9c9c9f9e3f1f6c4d8d8g3c1b9f5d0c4d5c2f2b9b9c0e2c6c1d4c1c6e3d0c2g6d2g6b9c7d7e3c7c9c5b9c4c5b9c0c5d3c8b9b8e9f0g1b2", -"a2a7a7a6b3c2d7c4d7c2d1c5d7d7c5d5e5d7f4h1h5h5h8i2i3g7g7e1e7c6c4e5c1d5d8e1f5c2c2d5d5c4c2c2c2d7e4c2e5d4h2h4h5h5c9i2b5i5g1g1g5i6f1d4d7c4c4c2c5c0e2b9b9b9c5e2b9c5d7d2e2c2h2h4h5h5g2i2i2i2i2i2i2i5e1g8h5h5h5h5b0c2c0d5c5c2d1c5d7d7c5d5e5d7b9c9f6d4d8e5e3e7c6e5d3c2c4e5c1d5d8e1f5c2c2d5d5c4c2c2c2d7e4c2e5d4d8c1h2h3h5h5i3i7e1e1d8c0c6c8c9c4c4c2c5c0e2b9b9b9c5e2b9c5d7f3e2c2b9c5c1c2c3f4h1a5h5i0h8h5b0a0g5i8d8e0c4c2d7c4d7c2d1c5d7d7c5d5e5d7b9c9f6d4d8e5e3e7c6e5d3c2c4e5c1d5d8e1f5c2c2d5d5c4c2c2c2d7e4c2e5d4d8c1c5c1e3e4d2d2g6b9d7e3d7c8c9c4c4c2c5c0e2b9b9b9c5e2b9c5d7f3e2c2b9c5c1c2c3g8h8c9i3a0i6g5i3d8f6c0c1f5c4c2d7c4d7c2d1c5d7d7c5d5e5d7b9h2a5a8c2e5e3e7c6e5d3c2c4e5c1d5d8e1f5c2c2d5d5c4c2c2c2d7e4c2e5d4d8c1c5c1e3e4d2d2g6b9d7e3d7c8c9c4c4c2c5c0e2b9b9b9c5e9f7b6b6b2", -"a2a7a9a6a5c4e6d1c2c2c1c5c9c9d5b9c6c5g9h4h5h5g8a0i1i7i9f1d4e6d1e5c4c0c0d5d5g2c4g3e5e0d9c5c5c2b9c5d1f5a6b7h5h5g0j0i6i1i5g1g4h9g5e1e5c4c5c5c5c5e4d7d3c8b9e4b9c5d9b9d3d6b1b7h5h5i9f7i7j0g4g4i5i5g0g0b8h6h5h5h5h8i6e0c0e6c1c5c9c9d5b9c6d6d9b9d5d1c0d0c9d6c1d6c9e3e5e5c4c0c0d5d5g2c4g3e5e0d9c5c5c2b9c5d4d5g3c5h2h3h5h5g0i1i9a2g7e0c1e3c9c4c5c5c5c5e4d7d3c8b9e4b9c5d9b9d3d7c6d7c1e5c1b0h4h5h5c9g8h5h5a0h9i9g7f1d5c4e6d1c2c2c1c5c9c9d5b9c6d6d9b9d5d1c0d0c9d6c1d6c9e3e5e5c4c0c0d5d5g2c4g3e5e0d9c5c5c2b9c5d4g3d5c6c6c4d3d2f4f3b9c9c7e3e3c8c9c4c5c5c5c5e4d7d3c8b9e4b9c5d9b9d3d7c6d7c1e5c1d1e1i7i5i5j1j1a2g7d8c4c6d5c4c4e6d1c2c2c1c5c9c9d5b9c6c7d9b7h5i0b0d8c9d6c1d6c9e3e5e5c4c0c0d5d5g2c4g3e5e0d9c5c5c2b9c5d4g3d5c6c6c4d3d2f4f3b9c9c7e3e3c8c9c4c5c5c5c5e4d7d3c8b9f0f0b8f0b2", -"a2a8a9a6b3c1c4e6c5c1c5e4c9e6c1c1c9d9h2h3h5h5c9a4f7f0j0g5e1c4d8c1e6e6e5e6c3d5d8d5c4d5c5b9d5c2e2c2c4c1a5a5h5h8i4a2j1e8j2b4g0e9j1i6f5e5d7d9c4c5c5d9b9d7e4d7b9b9c9c8e7c9b0b7h5h5a4g1f0j2b4j2b4j3g0g0g0j3g8h5h5h5c9g7d8d5e6e4c9e6c1c1c9d9b9d6c9d4c4g2d5c5d6c5c8c6d5e5e6e6e5e6c3d5d8d5c4d5c5b9d5c2e2c2c4e6c7c8h0b7h5h5i2i7i5g4i9g7f5c1e3c6c8d9c4c5c5d9b9d7e4d7b9b9c9c8e7c9c5e6e5c4g9h1a5h5b0i2g9h5h5i9b8h9g5i3g2c0d4c6c5c1c5e4c9e6c1c1c9d9b9d6c9d4c4g2d5c5d6c5c8c6d5e5e6e6e5e6c3d5d8d5c4d5c5b9d5c2e2c2c4e6d6d7c1c6d2d2g6c9d7e3c5c5c6c5e3c6c8d9c4c5c5d9b9d7e4d7b9b9c9c8e7c9c5e6e5c4c6c1e5f6g7i9i5g1i7g5e1c6c2g3c1c1c4e6c5c1c5e4c9e6c1c1c9d9f4h1h5h5g8a0d8e5c5c5c8c6d5e5e6e6e5e6c3d5d8d5c4d5c5b9d5c2e2c2c4e6d6d7c1c6d2d2g6c9d7e3c5c5c6c5e3c6c8d9c4c5c5d9b9d7e4b6f0f0f0b2", -"a2a7a7a6b3c1c0c2d7e6c5d7d7c6c6c1c9d7a7b7h5h5i9b4e8j2g1i1f1e0f5c6c2e5e6d1c9d5c4f5f6b9e5e2c1c2e4c5c1c8h1h5h5h8a0i9f0b4b4f8f0i5i1i6d8c6d9c9c5d7b9d9d9b9b9e2e4c5c5c9d6c9h1h5h5i0i2i5g0j4j4j2e8g0g0g0g0g0i9b0h5h5b0g0i3e1c4c5d7c6c6c1c9d7d3b9e6d5f5f5f6c7d7c6c8c3f5c6c2e5e6d1c9d5c4f5f6b9e5e2c1c2e4c5c1c8f2e3b3a5h5h8i2i7b8b8j0i6e0c0c2c8d9c9c5d7b9d9d9b9b9e2e4c5c5c9d6c9e3e6c4c9a5b7h5h5i3b2h3h5h5c9a4b8h9a2e1d4c0c2d7e6c5d7d7c6c6c1c9d7d3b9e6d5f5f5f6c7d7c6c8c3f5c6c2e5e6d1c9d5c4f5f6b9e5e2c1c2e4c5c1c8f2e3d0d7f3g6b9c2e3c2e6c6e6c6c2c8d9c9c5d7b9d9d9b9b9e2e4c5c5c9d6c9e3e6c0c6e5c4d0d5f1g5h9g1j0i9f1f6c6d8c1c1c0c2d7e6c5d7d7c6c6c1c9c2g9h4h5h5g2b8i8f5d4d1c8c3f5c6c2e5e6d1c9d5c4f5f6b9e5e2c1c2e4c5c1c8f2e3d0d7f3g6b9c2e3c2e6c6e6c6c2c8d9c9c5d7b9d9d9b9b9e9f0b8b8b2", -"a2a9a8a6b3c6c4c8d7c2c2c5d7d7c5c0f2c9h0b7h5h5a4b8g0b4f7i8f3f4f5d5d9h2b0h0h0b0h2d4c4c0c5b9c3e4f9f9f9h2h1h5h5c9f0e5i9j4f8g4j1g5i6i8c8h2b0b0a5h0b1f9d7e7c6c2b9d7c5e2c5f9h1h5h5h8i2j0b5j4b5g1j0i7h9h9h9i7i7b1h5h5h5i5i9i6d8d1c5d7c5c0g9a6h0a5a8b0h2e5d4c9c7c2e3c3d5d5d4c2c6d7g6h2a7b0a5b0h2f4d4e4c5c1c5d9f2b9h1h5h5h6a4i5g0b5i5g5e0f9f9f9f3e6b9b9c0c7c2b9c6c2b9d7c5e2c5d3d7d4e5h2h1h5h5h8i2i7a6h5h5h8b2g0i5i1e1c0e5d7d7c2c2c5h2a6b0h0h0h0a6d3d5g2c1c3f6c9c7c2e3c3e6h2b0b0h0h0b0h2e5d8c4c0c5b9c3e4c5c1c5d9f4h2b0h0a5h0b1f9c5d0e6c6c6c1e6c5d9e6b9b9c0g9b1h0a5b0a6g9e3e2c5d3d7d4e5d6f9f9d2c4d8i8g5i7j1g5e1g9a7b0a5b0a6h2f2c2c2c5d7d7d9f4g9f9a6h3h5h5i9g5e6f1f1g2c1c3d5d5d4f4b1b0h0b0b0h2f4c0c5b9c3e4c5c1c5d9f2e3d2b1h0h0h0h0b0g9e6c6c6c1e6c5d9e6b9b9c0c7c2b9c6f0f0b6b6b2", -"a2a8b0a6b3c6c6f5c2d0c5c5d9c0b9c0d9e7h1h5h5b0i2g1b5b4g1b1h4h3g8h2b7h4b7a5a5a5a5b7d2c5c0d7c5d2h1h3h3h4b7h5h5c9f9h3f9j1e9i9i3f1c2a6h1h4b7a5a5h5a5a5h5c9c2c2e4c9b9d7e4g9h4h5h5c9a4g4b4b4g1i1i6g7g7i3i3g7f1f9a5h5h5g2b8j1i3f5c7c3h2b7h1h3a5a5h5a5a5h5g9d7c8d7d4d1c4e5c1c9c7b1h1h4b7a5a5h5a5b7h2c4e0e0d6d9c7f9h4h5h5g2j3i5b4b5j0e6h0h1h4h7g8d7c4c5b9c6c2c6c2c2e4c9b9d7c9d3c9b9e4b7b7h5h5i9a0i9g9a5h5h5i4j3g4i7g7c3d0f5c2e6g9b3h1h3a5a5h5a5a5a5b1c3f6c3d4d7c8d7g2b1h1h1b7a5a5a5a5a5b7g9g3c5c0d7c5c4e0e0f4a8h1h4b7a5a5h5a5a5a8c7c6e6e6c1c1c4c1c1c4f9a5h1h3a5a5h5a5a5h5f9c9d3c9b9c0f9h1h3g9b9d5d5f1g7i6f9b7h1h3a5a5h5a5a5b7g9c5c5d9c3h2h1h4h3h4a5h5h5i3b1h3d7i3f1e0c3e5f4b0h1h3b7a5a5a5a5b7b1c0d7c5c4e0e0d6d9g6b0h1h4b7a5a5a5a5a5b7f4e6c1c1c4c1c1c4c5b9c6e3c6e6f0f0f7f0b2", -"a2a7b0a6b3d7c0e1c3c3d7b9c4d8d5e2b9f9h1h5h5h8i4g1b4b5g4a7a5h5h5b1h5h5h5h5h5h5h5h5i0d3d6e6c5f9h4h5h5h5h5h5h5h5h5h5h5g2i5i6e0d2b7h4a5h5h5h5h5h5h5h5h5b0e2e6e6d6c9c9c9h2h3h5h5e1g0f7j3g0i5g5e1f5d5d8f5c3c4h2b7i0h5c9a4g1i9e1d8b1h1h3h5h5h5h5h5h5h5h5i0h7c0b9d1c0c1e6e6f4h0h4b7h5h5h5h5h5h5h5h5h7c3e5d6c9e3h2h4h5h5i9b8g1j3f8f3b7h4h5h5h5h6e1g2d9c5c8e6d7c8c2c5d6c9c9c9e7c2e5b1h4h5h5h6i2i7j0d9b7h5h5i5j3f7i5g7c3d1e1c3b1h1h3h5h5h5h5h5h5h5h5h5h7d8c3d1c7e3d2h0h1b7h5h5h5h5h5h5h5h5i0g9e6c9c5c5c4c1f4b7h4a5h5h5h5h5h5h5h5h5b0b9e5c1c0c6d7d7c1h2h1h3h5h5h5h5h5h5h5h5b0h6d7e6e5c4g9h4h5h5g8d8d4d5d8g9h1h3h5h5h5h5h5h5h5h5i0h6c9d4d8h2h5h5h5h5h5h5h5h5h5h5h5i9g7f1c3g9h1h4a5h5h5h5h5h5h5h5h5h7e5e6c4c1e5d9f9b7h1a5h5h5h5h5h5h5h5h5i0g8f6e6d7d7c1c4e4c5c8e6d7c8b8b6f0f0b2", -"a2a8b0a6b3d7c1e0c1c3c5c4e5f5c4e3e4g9h4h5h5c9a4f7b5g0j0b7a5h5h8h6h5h5h8c9c9h8b0h5h5b0i3f6c0e6g8h5h5h5h5h5h5h5h5h5h5i9f8i6e4h1h4h5h5h5b0h6c9c9h8h5h5i0b0c3d4d6e6c2b9b0b7h5h5i9e9b6j4e8i7g7d5d0d0e5e5d7d3f9b7h5h5c9a4g0j0g5b1h1a5h5h5h5h8c9c9c9b0h5h5h5g8d4g2d1c1e6c7a5h4a5h5h5b0h8c9c9h8h5h5h5c9e6c2d7e3b1b7h5h5a4j0f0f0h2h1h3i0h5i0i9i2j1c3c6d7c2e6c1c6c5c5b9e6e3c9c9c7f9h1a5h5b0g0b5i1b6a1b7h5h5g2j4f7g4i6d5c0e0f9h1a5h5h5i0h8c9c9c9b0h5h5h5e5e1e3c2d7h2h1h5h5h5b0h6c9c9c9b0h5h5h5f1d5c4e6c2d3h1h4h5h5h5b0h6c9c9h8h5h5i0b0d5c3f6e6d7c2h2h1b7h5h5h5h8c9c9h6b0h5h5b0e0e5d1e6h2h3h5h5g0g5d5c3f4h1b7h5h5i0h8c9c9c9b0h5h5i0g5d8e1c4h8h5h5h5h5h5h5h5h5h5h5i2j1g7f4h1b7h5h5i0b0h8c9h6h8h5h5h5h6d5e5d8e4c9h0h4h5h5h5b0c9c9c9h6h5h5i0b0i6f6c6c6c7c2b9b9c2e6c1c6b6b8f0b8b2", -"a2b0b0a6b3e3e6g2e6c1e5e4c4f5c2f2c2h2h3h5h5e1j3b8b4b6i7h1h5h5h5h5h8h9i4j3f0g0i3h8h5h5i9e1e1g7c0e1i2i2h8h5h8i2i2i2i2i2b6g7a5h3h5h5h5c9i2i4g0e9b4g5i0h5i0c9i8d1e6c8c9a5a5h5h5i2e9e8j4e8j1e1d5c1e6e5c1f2f3h2h3h5h5c9a0b5f0f9h1a5h5h5h8h9i4a0j0i5j3h6h5h5b0i9e1g3e6e6b1h4h5h5h5h6i2i2a0i5b6f1h5h5i0i9e0d4c1b0a5h5b0i4i7i6b0h1b7h5h5h8b2i4g5f1f1g2d5c1c4d7c8e5c5c7d7d6c9c7c4b0h3h5h5c9i4i9i5g0j4a5h5h5h6a0b8f7i6d8d4g3a7h3h5h5h8a0i2b4f0b6b8h6h5h5h8i5e0c1e3b7b7h5h5g8b2i4g0g4g1j1h8h5h5c9g5f6g2d8a5h3h5h5h5c9i2i4g0b8j2g5i0h5i0c9i8e0c0c2d2b7b7h5h5b0i5b2j3b8g0h9h8i0h5c9i3e0f5b0b7h5h5i2i6e1e1b0h3h5h5h8a4i2b4f7f8f0h8i0h5g2i3g7c3d6i1i2i2h5h5c9i2i2i2i2i2i7g7a5h3h5h5b0g2i2i2a0b8j3c9i0h5h5g5g5f5d9f4h1a5h5h5e1i2a4f7b8g0g7i0h5h5i9i8g2c1c8b9e2d7c8e5c7c8f8b6f0f0b2", -"a2b0b0b0b3c8c5c5d7c2c5e5d5c4c4d9c8h0b7h5h5i9f7e9b4e8e5h1h5h5h5h8a0b2i7a2i9h9f7h5h5h5c9g4g7e1g3e2e6h1h5h5h6b2f8b4j4j2f0g9h1h5h5h5e1i2g1i6i1i7i5b8h2h5h5b0g0e1c3c2d7h1h5h5h8i2j0b5b4g1i9d8e6d0c6c4e6f2f2b1b7h5h5c9a0g0a2b7b7h5h5h8a4a0i1i1i9h9g4e1b0h5h5g2a2f5d6f4h1b7h5h5e1i2g0a2h9j1i5e4b0h5h5i9a2f1f5h1a5h5h8i4f4h1h4h5h5h5c9i2j3g5g5i9i1i6g7e0e1c8c5c3e5d3c9c9d6d7g9h1a5h5b0a4g1i7f0j2j2b1h5h5b0a4f0j0a2e1e5e3h1a5h5h5a4a4g5a2i7h9b8d7h5h5h8a4i6i8f4h1h5h5h8i4g0g5i1h9g4j0g9h5h5c9f8g5e1h2h1h5h5h5e1i2g1i9j1j0g4b8h2h5h5b0f8i3e0c3h0h4h5h5h8a4i4g5i9i5i5i5a8h5h5h8f8i6e1b7a5h5h8i2a2a2g3a7h5h5i0a0a0g7a2i7i5g1h4h5h5c9g0g5i8e6c1g9h4h5h5e1a0f8b4j3g0g0b1h4h5h5i0g0i4j0g5j1i5b8g4h7h5h5h6j1i8c0h2h3h5h5c9i2h9g5j1i5g1a2h8h5h5i9j0i3e0c5e3b9c2c1d8d6c5g0f8e9f7b2", -"a2b0b0b0b7d1e3d9c2d6e4c4c4b9b9d9b9a5a5h5h5i2g4b8j3f0f4h3h5h5b0g0b2b8i5g4f7e8g0h4h5h5c9a0j0i6d8c6f4h4h5h5g2b2j3j4j4j4a2h1b7h5h5g2i2h9i9i5g1g0b4j3f4b0h5h5g0i9g7g3f9h1h5h5h8b2g4j2b5g4a2d5d7e6e6e5c1f2g6h0b7h5h5i9a0g0b1b7h5h5b0a4a0g5h9g1g1f8g0b5h3i0h5g8g0i3g3a5h3h5h5h8i2i7i9i7g1g0j2a2a8h5h5i9b8i9d9h1h5h5c9h9h1b7h5i0b0f7i2g4i6i7i5f7g4i7g5i8f1e6d6d8e2c8d6c2d6g6a5h3h5h5e1i4a2i5j2b5g1f9a5h5h5a4f7g1i9i6d1c9h1h5h5h8i2i6j1i5b6j2b4j2e5c9e1b2h9a2d2h3h5h5c9a0i9i5g1e8b5j2f8g8c9i9a0i7f5h1b7h5h5g2i2i5i1i5b6b5b4b4f4h5i0h5g0i1g7f9h1a5h5h5h9a0i1j1i5b5f8b5g9b0h5h8b2j1i8h1h5h5h6a4i7h9j1e1h8h8g2i4g7i9g4g0b5g0h1h5h5c9a0i1i3g3e5h2h3h5h5i5a0j3j3j4b4a2h1a5h5h5i9i4g5i9i5b6b5b5g0b1i0h5h8a4i9e1h2b7h5h5i9g1i9i5b8b5b4b5i1c9c9g0g0j1g7f5e3c2e3e5d8c5d6j2e9b6f0b2", -"a2b0b0b0b7d1d7d9c8b9b9e5e5e4b9f3d9h1h5h5h8i2i7e8g0g1g9h3h5h5c9i4b5j3j3g0b5b5b8h1h5h5c9a4e9j1i3e1h2h3h5h5i9a4j4j4j4j4g9h4h5h5h8i2i5j1g1b5b4b4g0f0g3b7h5h5g2g1i1g7g9h3h5i0c9a0g4j3g0i5i6c8e3e6d0c4c1d2f4h1a5h5h5i5f0g4h1a5h5h5i3b2g5h9e8b4g0e8f0g1b1h5h5i0a4j1e6h1h5h5b0b2b4a2i5f0j2j2e8g0i3h8h8i5j3j0e4h4h5h5e1f4a5h5i0h8a4b2i9i9h9f7g0b4b6j0g5i8g2e6c7d8c2c8c1d7c6h2h4h5h5h8i2i5i7e8b4f0j0f3b7h5h5i3b6f0i9i6d4c8b7h5h5b0h9i6g1f8j2g0f8f7h9g0a0j4e9h9e5h3h5i0h8a2g4g0j4j2f8b6g1i5a0a0b4g0h2h3h5h5h8i2i5i1g4b5j4b4g0g0d8b7h5h5g2b8i9b1h3h5h5c9i2i9h9f7b5a0j2e8b8h6h8c9b2g4e6h4h5h5c9j3i5g1g1i9i3b5b4i7a2g4g0j4g0e1h1h5h5c9a4g4i1f1g3b0b7h5h5i2j4b4j3b4g0g9h4h5h5c9i2i7h9g4g0j3j2f8g1b1h5h5h5b2i5i9g9b7h5h5e5i6g4g0j3j4g0b6g1f7a0a4g0g1i1i6f6c1d7c1c4c2c7j2f0b6b8b2", -"a2b0b0b0b3d0b9c9c6d9e4e5d0c5b9g6g9h1h5h5h8b2h9g0j2j0a7b7h5h5g0j3b8a0j4j2b6g1e5h1h5h5c9a4f8g1i9i8b1b7h5h5a4j3j3j4b4f0h0b7h5h5i9a4i9g1g0j3j2b6i5j0e6h4h5h5c9a0g4i9h2h3h5h5i3g0f0j4e8h9i6c4e3c8d0e5e3g6h2h1h5h5b0i4b6d9h1h5h5h8i2i1i1f7j4j4b6j0j1i9a6a5h5h5i2g1h2b3h5h5c9b2g5j0f8j2j2b6g1h9i1h9a4b2j3b6g9h3h5h5c9b0h5h5g2i2a4i9j1g4b8b4j2e8i5i9i3g7d5c7c7d8c2d6c1c5d2b7b7h5h5i9a0i9g4b4b4g1i9e5h3h5h5c9j3b6i5g5d5c8g9h5h5i0i0h5b1f4i9g4j0i1i3i3a2h9g1g4i1h2h5h5h5b0h5h2c2h9j0j1i9i6a2i1g4b8h0b7h5h5i9a0i9g4b5j4j3b8g4i7e6h4h5h5c9a0j1h1a5h5h5a4g1j0f0g0b4j3e9i7j1i9g0a0a0b8f4h3h5h5i9g0f7b5f0i1i3g9b1b0h1h1h1h1h1h1h3h5h5i9a0e8g4a2d8a5a5h5h8i4f0b4b4b8g1h0b7h5h5b8g7g9f4f4f4f4f4g9g9h0a5h5b0i4b8i5i9h5h5h5h5b0h0h2g3g0g4i7i9i9i9j0i5b8j0g5e1e5e6d8c1d6c7j2b6f0e8b2", -"a2h0a6a6b3e6b9c7c8d3b9c1e4b9c0e5h2h3h5i0c9j4j0b4f8h9b3a5i0b0i2g4e8a0j4e8j0i9f4h3h5h5i3a0g0f8i7i6b0a5h5i0i2b8b5b4g0e1h1h5h5b0i2i5i5g0b4b4b8i7g5a2f3h3h5h5c9a0f8j0a6b7h5h5i5f7e8j4e8i7g7d0e6c5e5c1d6f4a6b7h5i0h8i2f0b1b7h5h5e1a0i1f0j2j4b5i7a2i8f1a8a5h5h5i2f0h0b7h5h5i5f7i1b8b4g0f0j0i9i6g7i8g7i9g4b4b1b7h5h5h5h5b0i5i2a0i5i5f7b5j2j2f7j0i9i8f5e1e5c7d7d8c5d6c4c1b1h4h5i0h8i2i7j0f8j4b5h9a2e1h3h5h5h8a0b4g4a2g3e6e7g9h5h5h5h5h5a5b7h0g9e1c0e5f5i6j1j0i7g5h8h5h5i0h5h5a5h3h0f4f1g3d8g7i9f1h1h5h5b0i2h9j0g0j4j3b6h9i9i6e4h3h5h5c9a4d9h1h5i0h8i2i9f0b5b4g0f0i1i3i3e1i8i6j1f0h2b7h5h5a4g1b6j2b6e4h0h1h3a5a5h5h5h5h5h5h5h5h5g0g1b6g0h9g5h1h5h5h8a4j0j2j2g1g3h1h5h5b0c9h5h5b7h3b7h3h3h5h3h5h5h5h8i2b6b6j0g7b0h5h5h5h5i0b7h3b1d9i8f1g7g5i9j0i5i1g7d4d7d8d0c9c8j2b8f0f8b2", -"a2b0a6a6b7e6e5b9d7c6c2c5f2e2c5d7b1b7h5h5i3b8f0b4g0a2h1h5h5g8b2i5g0j4b4i5a2i6h2h3h5h5g0g0g0j2i5g5h1a5h5h8i2i5b5j2f0e6h4h5h5c9b2h9b8j3j3b8i5g5e1i8h2h3h5h5i3a0g0f0b3a5h5h5i2g1f8j4g1i1f1c4d0c5c2e5e6d2h1a5h5h5i3a0g1b1a5h5h5b2f7i5g0j2j2g1g5d8f5c3b7a5h5h8i4f7h1h5h5b0i2j1i5j3j4f0i7g5i8e0d8g2e0i3i9i5h0a5h5b0h5h5b0a4a0b5b8b5b5j3b5f7i7g5i3g3e6d8c1d6c5d8d8e5d6f9h1b7h5h5j3g7h1h1h1h1h1h1h1h1h1i0h5h5i4b4j0i1i8c6e3d7c2h8h5h5h5h5h5h5h5b7f4f2c3e1i6i9i9g5e1c9b0h5h5h5h5h5h5a5h5c1e6c3g7c2h4h5h5c9b2i1e9j3a0b8h9g5g7d8g9h4h5h5i3a4f4h3h5h5i3j3i7b5j3g0g1h9a2e1d1c3f5f5i6j1a6b7h5b0i2h9e8b4h2h1h3h5h5h5h5h5h5h5h5h5h5h5h5i2j0f0b5h9d9h1h5h5c9a0g4j2b5j0f9h4h5h5h5h5h5h5h5h5h5h5h5h5h5h5h5h5h8b2b8b5i5g5c3c9i0i0h5h5h5h5i0a5h7f5c3f1i3i9i9g5i3c3c5d8d0d6c2j2j2b8f0b2", -"a2a8a9a7b3d4e6c2e3c8c0c2d3c5d9d0b0b7h5h5g0g4b6j3f0e6h4h5h5c9b4g4b5j4f8i1i8e1b0b7h5h5i2g4b5j2g4d4h1h5h5c9a4i5g0j2g4f4h3h5h5i3g0g4b4j4b8i5g5e1c0e1h0b7h5h5i9b8b8j0h1h5h5h8i2i5j2b4g1a2e1e5e6c6c5e6c4b1h1h5h5i0i4f0e8a5a5h5h8i2j1f0j4g0f0j1f1c0c4g9h1h5h5h8b2g1h1h5h5h8b2j1f0j4b4j0a2e1d8f5g2d4f6d8g7a2h1h5i0h8h6h5h5h8j3j3j3a0j3g0g4i7i3e1d5e6c5f5c6c8d7d5c1d6c9b0h3h5h5h5h5h5h5h5h5h5h5h5h5h5h5h5h5h5i5f8g0h9g7c3e6c8d4i9i9g2h8h5h5h5h5h5i0b9c0d4e0i8i8g7e1e5h9i9g8h8h5h5h5h5h5b0e6e6e1g9h3h5h5i3g0j0f8a0f8i5g5i8e0c3h0b7h5h5i9f0f4b7h5h5i9g1g4j4j3f0i7g5e1c6d7c1d1f5f5a3h1a5h5h8i4h9g0e4h1b7h5h5h5b0c9c9e1i9i9i9h8h5h8i2j0g0g0j0f9h3h5h5i9f0g1b4f0i7h2b7h5h5h8h8h8h8h8h8h8h8h8h8h8h8h8h8c9b2b8b4g1g5e1i3h9i3g8b0h5h5h5h5h5h8d8f5e1i3g7g7e0c0e3f5c1c8d7b5b8f0f0b2", -"a2a8a7a7a5d4c1e6c8c2c7c2d6d3f2e6b7a5h5h5i2j0f8j3g4f4h4h5h5i9g0g1j2b4g1i6d5e1b7a5h5h8i2i5b4j2g4f3h4h5h5e1g0g4b4b8i5h2h5h5h5i9b8f7j3j3g1i9i8d4e3c6h1a5h5b0i2f7b8e1h1h5h5h6a4g4b4b5g4a2d8c4d0e5e3e6d2h1b7h5h5c9i2i5g0h1h5h5h8a4i7b5j4f0j0g5g3c2c6b1h3h5h5g2a4i6h1h5h5c9b2j0f8j4f8i9i8d1d5f5f5e5e5c4c0f3h1h5h5c9a0b0h5h5g8j3a0g0g0j0i9i3d8f6c1e3d7c3c1d6e6e0d8c9h2h1a5h5h5h5h5h5h5h5h5h5h5h5h5h5h5h5h5h5g2j3b5i5i6e0c5c2c2g2g7h9a0a0e1g8h5h5h5h8i3f5e6d5d4e1g3d7f1g5f7a4b8g2h8h5h5h5c9d8e1h2h5h5h5i9i5g4j2j4b8i9i8c3g2c8h1a5h5b0i2f0h2b7h5h5i2g1f7a0b5j0g5i3e1d6c7d0c4c4c3d7h1h5h5c9a0i5j0b3h5h5h5b0i9i2b2j3a0j3a2b1h5h5c9a4f0b5b6i5h2h3h5h5g0i5f7j3f0i1h2h5h5h5i9b2b2i4i4i4b2b2b2a4a4a4a4a4a4a0g0b4g1i9f1i8i3i9g0b2i5c9b0i0h5h5g5d8g2e1g3f5d1c6d7c3c6d6e6b5j2f0b6b2", -"a2b0a7a7a5d5c7d7c4d0c1d0g6d2f4f3h1h5h5h8i2h9b5g0g1b1b7h5h5a4g1b6b4f8j0g7d1e5h1h5h5h6a4i5b5g0g4h2h3h5h5i9b8f7b4g0i7g9b7h5h5i9b8g0j3g0h9i6e1c1e5b1h4h5h5h6i4i5g0f4h3h5h5c9a0g1j2g0i5i6d8c4c6c1c1f3b7h3h5h5b0a4e8g4j3h1h5h5h8a4h9j2b4g4i1i3d0d6d3h1b7h5h5g0g0g3h4h5h5c9j4g4b4j4g1i6f1d5f9h2h2d7c9c9c2g9h3h5h5i3g0g7i0h5h5g2j3g0i5g5i8e1c1c5e5c2d0d8e5c7c6e0f5d7h0h3h5h5c9i9i9i9i9i9i9i9i9i9i9i9i9g2h5h5h6a4b4g1i6d8d5d0e5c3c3i8i9f7g0g0g8h5h5i0a0e1d8d0e3c3c4f2d8i8g5i5b8e8e8h8h5h5h8f0g7h2b7h5h5i9g4b6j3f8i5i6f5g2c1b1h4h5h5h6i4g4b1b7h5h5i2i5f8a0b8j1g7g7e5h2h2f9d7c5e5g9h4h5h5e1j2g4e6h1h5h5h8b2b2i9i1i5f0j2h2h3h5h5e5a4g0j2f0j0a6b7h5h5i2i7f8g0f0i9h2b7h5h5i9g1b8a0a0j2b8b8g1h9f4f9f4g1e9b8j2j2g1i9f1g2e1g7i9i5b8j3i9b0h5h5c9i9i8d8c1c6c0c2d0d8d1c7c6b5b5f8f8b2", -"a2b0a7a7a5d4e4c1c1c6c1f6f3e2f4f9h4h5h5h6a4g1b5b5g4a6b7h5b0i2h9f8b4b8i1f1c3f4h1h5h5g2j3i5b4b8i7b1b7h5h5i2g1f7b4b8i1f4b7h5h5g2b8g0j3b8i1f1g2e5f4h1a5h5h5i9j3g4b4h2h5h5h5i9j3f7j3g0h9e1g3e5e6c2f4a5h4h5h5h5i3i4j1e8j4b0h5h5b0a4j0b4j2i7g5i8d7c1b0h4h5h5h8i4j0j0h3h5h5h6a0b8j3b5h9i6d8e6b7h3b7h8d6b9d7b1h5h5h5g0b8b8f9h5h5b0i9i5i9g7d5d5e3d7c1e5c0e0e5c9c8c1d1h2h1h5h5b0a4b8f7j3a0a4a4b4g0b8f7g1g1h2h5h5b0i4j4g7a6a7g9e6e5d5c9d5f1j1g1g4h0i0h5h5i2i9f9b0h0f3e6d1d4d8f1i9h9g4a3h4h5h5h8b2i9f4b7h5h5g2f7e8j3b8i1f1d5g3f9h1b7h5h5i9g0g1g9a5h5h5g0g1j2a0e9g5e1g3h2h1b7h7h6d7e3h2h3h5h5i9b8j0f4h3h5h5e1a4g5i9f7f8b4j1h1b7h5h5i9b2b5b4g1i7b7a5h5h8i2j0e8j2g4a2g9h5h5h5i5b8e8a0j3b4j2b4b5e1h1h3h7c9b5g0g9b1b1a3f1e0d4c3g7j1j0b8d9h5i0h5c9j4g5i3d5c6c1e5c0d8d1c9c8g0f8e8f8b2", -"a2a7a7a9a5c3b9c2e6c2c0c4d2e4f3h2h3h5h5g2a0g4b4f8h9h1h5h5h8i4j0e8j2f7i9f5e6h2h3h5h5i9b8f7b4f0j1a5a5h5h8i2i7e8j4e9i9i8h5h5i0h8j3b5j3g1a2e0d4e3a5h3h5h5h8i4f7f0b4b1a5h5h5a4g1b6j4e8i7i8d5d0d7h2h1h3h5h5h5h6i2g1j0g0a0f4h5h5h5h9g4j3e8i9i3d8d1h2h1a5h5h5i9a4h9g0h2h5h5b0a4f0j3e8i9i6d8b1h1h5h5h8a2c9c5b0b7h5h5i2i5g0j4h8h5h5h8i5g5f1d8e5e6c8e6e5c1d8e5c9c7d5d9b7b7h5h5e1b2i9g1g0a0a0j3j3b5g0g0e8b4h2h5h5h5a4a0e1h4a5b0h6c0c4f2c2e5i6a2f4h1h5h5b0i2g4g9h3a5b0g8c4c0e6c3i8i6a3h2h4h5h5g8b2j0i9h5h5i0h8b4b5j3g1g5e1d8c7a5h3h5h5h8i4g1f0a2b7h5h5e1b8b4j3g4i6f5f2b7b7h5h5g2i8e6a7b7h5h5i2g1f0f4b7h5h5a4i5i7e8j2j4a0h2h4h5h5h5a4a0b5g0g4a2h1h5h5c9a4h9g0g0j0i6e6b7h5h5g2f7g0j4b4b6f7f7a2h0h3h5h5c9a0f0b1b7a5h8g7d4e3c0f1g7a2i1h0b7h5h5e1a4i5a2i8d1e5e5c1d8e5c9c7b5g0e8e8b2", -"a2a7a7a7a5d7c2c2c9c7c1f5b9d2e2b1b7h5h5i9g0b8j3b8g7h1h5h5c9a0i5e8e8g4g5c3d9a6b7h5h5a4i5g1j3e9i1h1h5h5h8b2j0b5j3g4g5e1b1i0h5b0g0g0b5j0i6d8d2h0h1h5h5b0g0a4h9b8j4h1a5h5b0i4i5f8j4f0i9d8f9a6b7h1b7h5h5h5g8i4j3i7b8b4b4a2b7h5h5c9g0b4f0i9e0g3h2h1b7h5h5c9i4j0g1j4f4a5i0h5i9b8g0i5i1i8h2h1a5h5h5e1g0g2f5b7a5h5h8i2j0f8j2j0h7h5h5h8j0g7g2c2e3e3c6c1e5e1c6c9d6d8b1h4h5h5h8i2h9j0e8j3j3j3b5g0b5b6e8g0b5f4b7i0h5i3a0h9h3h5h5g8g5d8d7g6c8g3f4b7h3h5h5c9i2f8e6b7h5h5i3i3d1d9c9d8e1h2h1b7h5h5i9a4b8j0h2h5h5b0g0g0j3i5i6e1f3h0h1h5h5b0g0a4h9b8j4h5h5h5h8a0j3j3j0i8d9a5h4h5h5b0i2i3c4h0a5h5b0i2i7b6f4h3h5h5a4j1g4b4j4j2h2b7b7h5h5b0i4b5b5g0g4e6h1h5h5c9g0g4b5g0h9g7f5h0h5h5h8b8e8j3e8i7a3c2b7h4h5h5b0i2b4h9h2a5h5h5j3d4c1f6f5c3e5b1h1h5h5b0a4a0b8i7g5d8f6c1e5e1c1c9d6j2g0b8b8b2", -"a2a7a7a7a5e3c2e5c8e5g3f5d2c9e4b0b7h5h5a4f0e8j4f0d9h4h5h5g2j3g1f8b6j0g5e5b9h0a5h5i0i2i7b6b4g1e6h1h5h5c9a0i5b5b5j0g7e1f2a5h5h5h8c2e1g3f3b1h1h4h5h5h5g2i4h9g1g0a2h1h5h5h8b2a6b1b1h1h1h1h1h3a5h5h5h5h5c9i4g0h9g1j2j4g0j0h2h5h5h5f3f1d8c2g9a5h1b7h5h5b0a0f7i9f8a0f0h5h5h5h8d9e1e5f4a5h1b7h5h5h8i2i7i3e1h1h5h5h6a4j0b5f8f7i3b0h5h5c9i9f1g2c6e3c3c6c1e1c2d6b9f4h1a5h5h5i9a0i9f7b5j4b5g1i5i5j0i7j0j0j0i8b7h5h5c9a4g0h0h5h5i0c7f3f9f9h2b0h1h3h5h5b0a4a0g0a1h3h5h5h8f3f4f4g9g9a5h1b7h5h5h8i2j3g0f0g7a5h5h5h8c2e1e5f3b1h1h4h5h5h5g2i4h9g1j2j4f4h5h5h5d7c2f1c2b1h1h4h5h5h5i3b2g7i8h1h5h5h6b2j0j2e1b7h5h5c9g3e1i8f4h0b7a5h5h5h5h8i2g0g0g0j0e6h3h5h5c9j1g3i1b8j1f1c3h2h5h5h5h6f4e5g3e4b1h1h3h5h5h5i9b2i9j1e4b7h5h5h6f9f4f9f4b1b7h1a5h5h5c9i4g0b5f0i1g7e1e5c1e1c2c9e7b5f8f8f0b2", -"a2a7a7a6a5f2c2c4c4c6c3d1d2d9d3h1a5h5b0i4g4g0b4f0g9h3h5h5i9b8g4g0e9h9i6e6g6h1a5h5h8i2i7b6g0g4f4h3h5h5i3g0g1j3f8h9g7f5e5g9i0h5h5b0h5h3h4h3a5h5h5h5c9i4i5i5g0j4e5h4h5h5b0h8a5a5a5a5h5h5h5h5h5h5h5h8i5i2f0i7f7e8j4b4f0i1i3h7h5h5h5h7h4h4h3h5h5h5h5b0b8b2a2i5b4b4f0d4b0h5h5b0b7b3h3b7h5h5h5b0a4a0i9i1e6h1h5h5g2j3g1b5g0j0i9e2i0h5h5e1g5f1d1e3f5c1c1f1b9b9d7b0h3h5h5h6i2h9i5f8b4j2g1i1g5i6i6i3i6i6i6g7h4h5h5h8a4b6i8h5h5h5b0a5b3h3h3h3a5h5h5b0i5i4i5b5b4f4h5h5h5b0h5h3h4h3h5h5h5h5h8a4a4f7f8g0j0d3i0h5h5b0h5h3h3h3a5h5h5h5c9i4i5h9g0j3b4g1h7h5h5h5h7h3h3h3a5h5h5h5g2i2i7i1e5h1h5h5c9a0i5b4j2h2h5h5h5h7h3b7h3h3i0i0b0h5h5g8a4b8b5f8i7i8h3h5h5b0g9h3f9i9i9e1c2d7h2h5h5h5b0h5h3h3h3a5h5h5b0e1i2i1i1j0i7h7h5h5h5h7b7h3h3h3b7h5h5h5h6i2b5f7j3g0h9i3i8c0c1f1b9b9d7b5f8f8b8b2", -"a2a7a6a9b3e4c1c6c6c1c1c1d2c9f3h2h5h5h8i4j0g0g0g4f3h7h5h5i2g4g1j2g1i7g7c8d2b1h5h5c9a4h9f8g0g4d9h7h5h5g0f7b6j3f7i7g7e0c4c2b9i0h5h5h5h5h5h5h5h5i0i3i4f7i1e9b4j4e1h2h5h5h5h5h5h5h5h5h5h5h5h5b0h6i5i2a0i7i5g1j2g0b4b8i7i6e1c3h8h5h5h5h5h5h5h5h5i0h8a4b2j1i7b8b4g0i5g5d7i0h5h5h5h5h5h5h5i0b0i5b2i9j0f0g3g9h5h5i9g0g4j3e8j0i6f1h6h5h5b0i9i6e0f6d8d4d1c6c8c9d2h2b0h5h5g0b5j1f0j2b4f0j1i3f1e1d8d4d8e1g3g3g9h5h5h5b2b6f0e1i0h5i0i0h5h5h5h5h5h5h8i5i4i1g4f8j4f7g8h5h5i0h5h5h5h5h5h5h5h6a4a4i7f7g0b5g4i9c2i0h5h5h5h5h5h5h5h5i0i3i4b8i7f7j3j4g0i7i6h8h5h5h5h5h5h5h5h5h5c9i2i5j1f7a2g9h5h5i3e8f0b4g0h9h8h5h5h5h5h5h5h5i0h8j3h5h5c9a4j2j2f0i7i6f9i0h5h5h5h5h5e5j1f1c5e7c7h6h5h5h5h5h5h5h5h5h5b0i5i4i7i9g4b6j0a3h8h5h5h5h5h5h5h5h5h5b0c9i2b5h9f8j4b5j0g5g7d5d1c6c8c9c2e8e8e8b6b2", -"a2a7a6a7b3f3c9d4d1e6g2f6c9e2c9c8h8c9i9a4i5j2g0j0i6h6g8c9i2j1b6j2g4i1i8d7d2d3h8c9i9g0i5b4f8h9i3g8h6c9i2g4f8j4e9i1f1f5d5c4c3i3c9i0h5h5h5h5h8e5b2i4i7i9b8b4j4g0i5c2h6c9c9c9c9c9c9c9c9c9i3j3i2i4j3i9i1g4g0b4g0g0f0i5i9f1e1f5e6e1h8h5h5h5h5b0h6i9i2j4i9i7f0b4j2f0i1g7g3i3g8i0i0h5h5h5h8e1i2i4i7j0b8b4f8g2g8c9a4f7b8j3f0i7i3e0e1c1c9c9i3i5i3e1g3d1e3c5c5c9g2d7h8g8i3i2j1g4j2j4f8j0g5e1d5c4d7e6e6c4e5g6c2h6c9c9a4b6f0h9i9c9i0h5h5h5h5b0g8i5i4a0i9i7e9j2j2g4i9g5h6h5h5h5h5h5h8c9g0i2g0i7i5g0j2b5i5g5e1i3c9i0h5h5h5h5h8e5b2i4i5i1g1b5j4j3g4i9f1e1e1h8h5h5h5h5b0g8b8i4g1i9g1j2j3i9g8c9g0f7f0j4f0j1g7e1h8h5h5h5h5h6i9i2j1h6c9i9a4j4j3e9i1g7g3h6h8h5h5h5h5i5f7f1d5e6d6e6g2h8i0h5h5h5b0h8i3i2b2j1i9g1b5j2e9i1i3i3h8h5h5h5h5h5h8e1a4i4f7j1g1j3j4g0h9i6e1c3e3c5c5c9e0b5g0f0f0b2", -"a2a6a6a7b7f2c1d5d5d1g3c9d3c5d9e5d5i1j0h9g4j2g0i7g7d5i3i7g4i7e8f8j0i9f1d9e4e7e0j0g1i5g4j2e8j1g7c3i8i5b6h9b5j3g1i9i8d8c1c3e6e1i3j3i2i9g0i2i4a4g4i9h9b8b5j3j3g4i1g7g5h9f7j3a4b2a4a4j4b5g0g1h9h9h9i7g1j2a0j4b6g4j0i9i3f5g2c9d7e0h9b2g0i9i2i2i4j3i7i1h9b8b5b4e8j0i6d8d0e1i3g0i2i9i2i2i2a4i5i9i5e8b4b4b6i5i9i5b8h9b8j3b6j1i8e1e5e1h9j3a0g0i9i3d8c3c5c7c0d4d5c4e1i9h9i1j1f0j4b4g1i1f1d8e5d7e4c8e3c1d6f4c9f6j1f7g0f0g0g4i9g5j3i2i5g0i2i2a4g0i9i9i7f7b5b4b6j0i6i8i3a0i2i9a4i2i4a4i5i9i7g1g0j3b4f7i7g7f5d5g7j3i2i9g0i2i4a4f7i7h9b8g0j4j3b8i7i6e0d8e1i5b2g0g0i2i2b2j3i9i7g1b5b4j2g4i9f7f7i5f0b4g4i9i8e1i9a4i5a4i2i2g0i9i9i5a0a4a4b4j2f0i9g7d5d9i6a0i5a4i2i2i5i6e1d4d7c2d5i9a4g0i5i2i2i2a0i5j1j0g1g0j3b5g1g5i8g7i7b2a4i9i2i2i2a4i5i7j1g1b5j3j3b8i1i3f5d4c5c7c0d4d5e8b8f0b6b2", -"a2a6a6a7b3d2d0e0c1e5f6d2d7d9c4d1c4c8f1g5g4g0f0i7i8c4e6c3i3i7f0f0i5a2e1d9e4d9d4e0i8i1i5g0f7j1i8d4c2e1i3i7b8b5i5g5i8d4f6d0c2c3f1g5i7b8b4e9j0h9j0i5b5j3j4j4b8i7i6e1c4f5g7j1b6j4j4j2e8e9g1b8e8e8e8b6j4a0j3e8j0a2g5i6g2c3d5d2c2d0g7i1g4b8b5j0h9h9j0f0e8j2b4e8g4i9f1e6d4g3f1f1i9i5j4b6g4g4i5e9f8j3j4g0i5i9g7e1i3j1f7g0g1i9i8d4e6c3f1g5i5g1h9g5e1c0d7e7d5d5d4d8c5e5e1i6h9e8b4e8h9i6e1e5e6d6c7e5e5c5d6d2e6d8e1i8a2j0g0f7i9i3g5g5i5g0g0g1i5i7i5g4b8b5j2b5i5a2i8d5e1g5j1g1j3b8g4j1i7j0b6b4j4j4b8j0g5i8g3e5e0g5i7f7j3b8j0i5i5f7g0b5j3j3b6h9g5g7c1c5d1e1g5h9b4b4f7g1i5g1e8j2j3b4f0h9i6g7i3i9f7g0g4i9i8g3d8i8i5j4j2g1i7j1g4g0g0j3j3g0j2g4i9g7g3b9d4e1a2b8b5b5g1j1i6f1d5c4c0g3a2i5g0e8i5h9i5g1f7g0b5b4b5e9i7i3f5e1i8i9i5g0j3g1i5i5i5g1b8b5j3j3e8j0i6f5e5d7c8e7d5d5d4j2b8b8e8b2", -"a1a6a6a8b7e5c4f6c1e6c2d6c9e7d1c0d7c5d8i3i1g1g4a2e1d4e6d8g7i9i5j0h9i6d4f2d7c7d4d5f1g5j1e9i5a2i8d4d4g2g7i1i5g1i7i3f1d5e5d0c2c4d5i8g5j1g4f7e8e8f8b4b4b5e8b8j1i6e1c3c1e6f1a2i5e8b5f8f8b6g0b5j2g0b6f0b5e8g4j1i6i6i8e1d4c1c2d6c7d6e1i3a2h9f7b6b6e8j2b5j2b5f0i5i9g7d8d6c3d4e6d4g7i9f7e8b5j2g0j3j3b4f8i5i1i3e1e1g7g5j0e9i5g5e1c4c2c4d8i8i9i7j0i9g7f6e3e5c2c8d7c4c5d7d8i3i1g4f0i5i9i8d5c5d7d3c2e6e6c9d2d2d5d8d5g3e1i7f7g4i9g7f1g7i1i5f8b5b8e8b5b5j2g0b6j0i9g7d8d5f5e1g5i1f0f8e8b6g0g0j3j3b4e8h9i9g7g2c0e5g2i8g5j0g1b8g0g0j3j3j3j3g0f7h9a2g7c3c2c8c2c0e1i9j0e9b6g0g0g0j3b4b5g1i7g5i8d8f1g5i7g4h9i6e1c1c8d5i1g4b6b6f0b5j3j3g0g0e9g1f7i7i9f1c1c9d0c3g7i1g1b8f8f0h9g5f1d1e5c2i3a2i7g4f0e8j2b4j3j3b5f8g1j1i6e1g2c3e0i3i9j0b6f8j2g0b4b5j2j3g0b6i5g5e1c1c2c9b9e6c2c8d7g0b8f0e8b2", -"a1a6a9a8b7e5c3e6e6c6c5d9c9e5e5d1d6c5c0d8i6i9i9i6e0d4c2d5f5i6i9i9i9g7d0d9f2d7d4f5e0g7i6i1i9g7f5d1d4d4e1i3i9i7i9i8g2d4c3c6c2g2e1f5e0g7i1j0g1f0e8e8f0g4i7a2i6e1f5e6d6d0g3i3i9h9j0h9j0h9i5j0i5j0i7h9j0h9g5g7c3d8e0e5e6c6c5d9c9c4d4e0f1g5i7j0g1b8b6b6f0i5i7a3i8e1d4c9e5d1c8e3d4g7i7g4b6e8b6b8f0g4i7i9i3e1e0f6e1i3i9i9i9i3e1e6c2g2e1d8e0i6i9i9i3f5e5c2d7d6b9b9c0e6g3e1i6i9j1i9i3d8e6g6d7f2e3c8e3c9g6d7g3f5e3e5e5g5i7i1g5e1g3d5g7i1i5f7f0b6b6f0g4j0j1a2g7e0c4c3c2f5f1g7i7g4g1f7f0f0f8b6g4i7i6i8f5c1e3e6f6f5g7i6j1g4e9b8f8f8g0g1j0i7i9i8c0d7c6d7d7e3g2i8g5j1i5g1f8b6e8g1h9i1i6i8d8d5d5d8g5a2a2i8d5c8d9d4i6i1j1i5g4e8g0f0i5h9i1i9i1i1i6e1c5c8e3c5g3i6i9g4f0f0j0i9f1e0c0c7d8g7i6i9j0f0f8b5f8b6i5h9i9g7f5f6c3c4f5d8g7i9i7g1b6g0g0b8f7b6g1j1i3e0c3c6d7c9c5d7d7c8b9f0b8b8e8b2", -"a1a6a8a8b3c4d4c1e6c7e6e7e7c0e5d9e4c7d7c0f5i8g7f1f5d1c3e5c0e1g7i8g7f1d0c9d9d9f6d5f5e0f1g7i8e0d4d1c2e5f6e1g7i6g7e0c3c3c6d0c5e1e0d4e1d8i8i6i9j1i1j1i1g5i6f1d8g3d0c7d7c5d1d8g7i6i6g7i6g5g5i3i6g7g5a2g5g7d8g3d4c3c3e6e6c7e6e7e7c0e5c2e6d8g7g5i9i1i7j1i1a2i6i8d5c4e5c9d1f6d7d6e6d4i6a2j1h9i7j1i9g5i3g7f5f6c1g3d5e1i8i6g7i8f6d0c5e1e0d4f1e1g7g7f1d8e6d7d7c8c7c9d7c1c1c0e1g7i3g7e1c3e3f2d9c2e6f2e4e2e5d5f5e5c8c2d5f1i6i3i8c3d1c2d4i3g5a2i9i1i1i1a2i6i3f1f5c3d5e6c2c4g3f5i6i9i9i1i1i1i7j1a2i6e1c3c2c7d7c1c2c4c3e1g7i9i9i7i7j0j1i9i6g5g7d5d8c2c5d7c8c2e6e5e1g7g5i9j1i7j1a2i6i8e1f5c4c4e6e6d8g7g7c3c5f2c4d8f1f1i3a2i1h9h9i1g5g7g7f1i8i6f1e6c9c9d9c5c6g3i3a2i1i7j1g5e1c3e5d6c3e1e0i8i6i9h9j0h9i7g5i3e1d5c1d1c2c1d0f5d8g7i3i9i1h9h9i7i1i7i9g7g7d4d0d7c8c2d7d7d7d6c7f7b6e8b6b2", -"a1b0a8a9b3f6d7c2c6d7d7e7c4d4e5e7d9e2e4d7c6e6g3d1c2c4c1d4c6c0d8e1d8d8c9b9c6d6f6c4d5d8d1d4d4c0d4c6c2c2c2f5g2e1d5g2c1c1c6c1c3c4e6d1e5g2d5f5e1i8i6g7i8g3d8c1c1c1c7c5d7e6c4c3d5e1d1g3e1e1e1g3d4d4e1e1f1c5c2c6c1f6d7c2c6d7d7e7c4d4e5d6c7c8e5d8e1e1i8i8e0f1e0f5c1c2c0d1d0d5e7b9c6c2e1f1i3i6i8i8e1e0e0c3c1e6c5c3c1g2g2e0d5d5c1c1c3c4d0d1e5g2d5c3f6c4g3c2c2e4c5c9e3e6c7c1c1d8d8d8e5e5f2c7c2d0d0d9d3b9e6g3f5e4c7e3c4d8f6d8f5c1c2c9d5e0e1e0e1e1e1e1e0c3d4e5c2c0c1d4c2c2d4f5d8g7d8e1g7f1i3g7i8f1e5c6c7d7c1c6c2c5c6f5g2f1i8i3g7i3i8f1e1d8d4c3c2d1c5c7c8d7c3c1d4e5f1e1i8g7f1f1d8d8c3c4e6d0e4c5c3d8d8e6d9b9e6d5d8c2c3e1g7i6i8i8e1g3f6c0e1e1g2d7d9e2e4c9d7c2d5d8e1i3g7i8c3c0d4d1e5f5c5c0e1e1i6i3i6i3e1f5c1c2e5c6c2c2c5c3e5d8f5i8i8i3g7g7i3i8e1d8d4c3c2c8c8d7d1c2c2b9c5f7b6e8f0b2", -"a1b0a8a7b3d5c5c6e3d7d9e5d4d1e7d6f2f3d2e4d7c5d0c4e5d1e5c2d7e5e5e5d4c2e3e7c8e3d4d1d5f5e3c6c2c1c2e5e3e6e5e5c3e5g2e5e3c6e6c2g2c2c2c5c5c0c6e5e0d5e1d5c0c4e6c1e3c6c7b9c7c7c8d0e6c2c7d4c4c4e6c8d9d2d5e1d8b9c7e5c1d5c5c6e3d7d9e5d4d1b9d6g6g6e4d7e6d1c3g3c3g2d4c6d7e5c6d0c0e3c8e7c8e3c3g3e0e1d4d1c0c0c1c4e3e6e5c1d4c2g2c4c2c1d0c2g2c2c2c5c5c0c6e6e0c1d5c2c8d7c5e6d7c6d7b9e3c5c2c1c6d7e7e6d0e6c7b9g6d2d4d8d8b9c9e5c1d5d0e5c6e3d6e5c3c3d7e6c5d7d9c6c2e6e6c0d0d1e5c2d7e5c6d0d4c1c0c1c4c3e0d8d8d8d7e3d7c5c5e5e3e6e5e5c3e5e0g2d4c3c3d4e0c2e6c5c5e5c5c2f5e6d5c6d7e6c1c3d4d5e5d7c2c5c8e6c5d7e7d0c1c4c2b9e4d2c3d8d8b9d7d5g3e1d4d4c1c6d6d1d5c3d6d6f2f3d2b9d9d7d0d5d5e0g2d1c6d1c6d0e5e3c8d7d0c0e0e0e1e1e6c6e3c2c2e5e3e6e5c1d1c2e0d1c4c3d5c3e1c1c1c6c5e5c5c2f5e6d5c6c8d7c5e8b6e8f0b2", -"a1a8a7a9b3b9e3c5c8c8e2e5d1d3g6e4d2g6d2g6d3d2d9d6c6c0d7d1c5d0f5c0e3e7d7e7d6d6e5c3d5d5d7c8c7e3c1c1d7c6c6c2d4c3c6c4c3e5c6c1c2c7e3d0c4d7c3g2c3e5d5c1c8d3c5c5c8d9d6c8e3c5d7e5e6e6c2d0c1e3b9d7c9d2d5d8d4c9d1d0e6b9e3c5c8c8e2e5d1d3g6e4d2g6d2g6d3g6d6c7c1e5d7d1c5c1f5c0e3e7d7e7d6d6e5c3d5f5c5d7c7e3c1c1d7c6c6c2d4c3c6c4c3e5c6c1c2d7e3d0c4d7c3g2d4e6d5d0c7d3c5c5c8d9e7d7e3c5d7e5e6e6c5d0c1c5b9d7c9d2d5f5d4d6d1d0e6d9e3c5c8c8e2d0d1d3g6e4d2f2f3g6d3d2d9d6c6c0d7d1c5c1f5c0e3e7d7e7c7d6e5c3d5f5d7c8c7e3c1c1d7c6c6c2d4c3c2d1d5e5c6c1c2d7e3d0c4d7c3g2d4d0d5d0c7d3c5c5d7d6e7d7e3c5d7e5e6e6c5e6c1c5e4d7e7d2d5f5d4c9d1d0c1b9e3c5c8c8d2c0d1b9g6e4d2g6d2g6d3d2d9d6d0c0c5d1c5d0f5e5e3e7d7e7d6c7c4g3d5d5d7c8c7e3c1c1d7c6c6c2d4c3c5c4c3e5c6c1c2c7e3d0c4c5d4g2d4d0d5d0c7d3c5b6b6f0f7b2", -"a2a8a6a7b3d9c2c2c8c8c1e5c4g6d9e2d2d2d2e4d3d2b9c1e5c5c3c5d1c7f5d0g6c9b9d6c2e7e5f5c3c0e7d6c9e6d7c1d7e3c6d4d0e5c1c6c1e3e6c1c8c5c8c1d7d4e5f6c2c1e6d7b9c5e3d7e4c9c7d7d7c2d0e6c6d0e5d0e6b9e4d6c2e4d8d5c7c9c3c4e5d9c2c2c8c8c1e5c4g6d9e2d2d2d2e4e4d2b9c1e5c5c3c5d1c7f5d0g6c9b9d6c2e7c4d8f6c0e7d6c9e6d7c1d7e3c6d4d0e5c1c6c1e3e6e5c8c5c8c1d7d4e5f6c6c1e6d7b9c5e3d7e4c9c7d7d7c2d0e6e6d0d0d0e6b9e4d6d7e4g3d5c7c9c3c4e5d9c2c2c8c8c1e5c4g6d9e2g6d2d2e4e4d2b9c1e5c5c3c5d1c7f5d0g6c9b9d6c2e7e5f5f6c0e7d6c9e6d7c1d7e3c6d4d0e5c1c6c1e3e6c1c8c5c8c1d7d4e5f6c6c1e6d7b9c5e3d7e4c9c7d7d7c2d0e6e6d0d0d0e6e7f2c9c2e4d5d8c7c9c3c4e5d9c2c2c8c8e5c1c4g6d9e2d2d2d2d3d3d2b9c1e5c5c3c5d1c7f5d0g6c9b9d6c2e7c1f5f6c0e7d6c9e6d7c1d7e3c6d4d0e5c1c6c1e3e6e5c8c5c8c1d7d1e5f6c6c1e6d7b9c5e3b6f0f0b6b2", -"a2a8a7a6b3c8e6d9e3c7f6c0c9d3c9g6f3d2f3e4d2d2b9e6c6c9e2c5c5b9d0e5d2g6d3b9d6c9c6d8d4c9c9d6d6c2e3d0e3c2c0c2f6c6d4c2c8c1e6c6e3c1c5c3d4d1d4c5e6e5c7d7e3c2c2b9d3b9d6c8c2d6c1c5d0d0d0e6e3f2c9c8c8d2d5d8c8c9c4f6c7c8e6d9e3c7f6c0c9d3c9g6f3d2d2b9d2d2b9e6c6c9e2c5c5b9d0e5d2g6d3b9d6c9c6d8d1c9c9d6d6c2e3d0e3c2c0c2f6c6d4c2c8c1e6c6e3c1c5c3d4d1d4c5e6e5c7d7e3c2c2b9d3b9d6c8c2d6c1c5d0d0c1e6e3f2c9d7c8d2d5d8c8c9c4f6c7c8e6d9e3c7f6c0c9d3d9g6f3d2d2b9d2d2b9e6c6c9e2c5c5b9d0e5d2g6d3b9d6c9c6d8d4c9c9d6d6c2e3d0e3c2c0c2d4c6d4c2c8c1e6c6e3c1c5c3d4d1d4c5e6e5c7d7e3c2c2b9d3b9d6c8c2d6c1c5d0d0c1e6e3f2c9d7c7d2d5d8c8c9c4f6c7c8e6d9e3c7f6c0c9d3d9g6f3d2f3b9d2d2b9e6c6c9e2c5c5b9d0e5d2g6d3b9d6c9c6d8d4c9c9d6d6c2e3d0e3c2c0c2f6c6d4c2c8c1e6c6e3c1c5c3d4d1d4c5e6e5c7d7e3c2c2f0f0f0f0b2", -"a2b0b0a8b3d5d5c1e3d4e5d1d6d7d9d3d2e2d2g6g6e3d7e7d7c9e4c4e2b9c4c3f4b9c2c9e3d4c4d8c1c7d6c9c2d7c6c1c1e5c2d1c1c1e5c6c7e3e6c5c2d8e0e0f6c4e6c0d4c3c7c2c2c2c9d7d3b9c7c2c2d7e6d7d0e6e3d7d6d7c7c8e7d0e6d4c8d6b9d7c8d5d5c1e3d4e5d1d6d7d9d3d2e2d2g6g6e3d7e7d7c9e4c4e2b9c4c3f4b9c2c9e3d4c4d8c1c7d6c9c2d7c6c1c1e5c2d1c1c1e5c6c7e3e6c5c2d8e0e0f6c4e6c0d4c3c7c2c2c2c9d7d3b9c7c2c2d7e6d7d0e6e3d7d6d7c7c8e7d0e6d4c8d6b9d7c8d5d5c1e3d4e5d1d6d7b9d3d2f2d2g6g6e3d7e7d7c9e4c4e2b9c4c3f4b9c2c9e3d4c4d8c1c7d6c9c2d7c6c1c1e5c2d1e5c1e5c6c7e3e6c5c2d8e0e0f6c4e6c0d4c3c7c2c2c2c9d7d3b9c7c2c2d7e6d7d0e6e3d7d6d7c7c8e7d0e6d4c8d6b9d7c8d5d5c1e3d4e5d1d6d7b9d3d2e2d2g6g6e3d7e7d7c9e4c4e2b9c4c3f4b9c2c9e3d4c4d8c1c7d6c9c2d7c6c1c1e5c2d1c1c1e5c6c7e3e6c5c2d8e0e0f6c4e6c0d4c3c7c2c2c2c9b6f7f0f0b2", -"a2b0b0a8a5g2f5c8c2d4c4d9d7d7d2f2d2d2g6e4f2c5d7b9e6d3c5d7e4c4f5e5c9c6c2d7d5d1e5c1c4c9d7c6d7e6e6c6d4d4e5c6d0d4e3e3c6c6d7c2d0c3e0c2d0c1c4d5d5d1c2e6c2e7e3d9d3d2b9b9c9d3c8b9e3f2c9b9b9e2c7c7d2e3c1c9c8f3d3d7f5g2f5c8c2d4c4d9d7d7d2f2d2d2g6e4f2c5d7b9e6d3c5d7e4c4f5e5c9c6c2d7d5d1e5c1c4c9d7c6d7e6e6c6d4d4e5c6d0d4e3e3c6c6d7c2d0c3e0c2d0c1c4d5d5d1c2e6c2e7e3d9d3d2b9b9c9d3c8b9e3f2c9b9b9e2c7c7d2c5c1c9c8f3d3d7f5g2f5c8c2d4c4d9d7d7d2f2d2d2g6e4f2d7d7b9e6d3c5d7e4c4f5e5c9c6c2d7d5d1e5c1c4c9d7c6d7e6e6c6d4d4e5c2d0d4e3e3c6c6d7c2d0c3e0c2d0c1c4d5d5d1c2e6c2e7e3d9d3d2b9b9c9d3c8b9e3f2c9b9b9e2c7c7d2e3e6c9c8f3d3d7f5g2f5c8c2d4c4d9d7d7d2f2d2d2g6e4f2c5d7b9e6d3c5d7e4c4f5e5c9c6c2d7d5d1e5c1c4c9d7c6d7e6e6c6d4d4e5c6d0d4e3e3c6c6d7c2d0c3e0c2d0c1c4d5d5d1c2e6c2e7e3f0e9g1f7b2", -"a2b0b0a8a5c3c8c6c5e3c9c7d7f3d3d2g6g6d2e4b9b9d7d7b9d7c0b9c5c4e5c5b9b9d7d7c3c4c0c1c4d9c2c6c5e3c6e5d4d1c4c3c1d4c6c4d4d6c2d6c6d5f1d8e3e3e5d5d5c1c7c7c7c9e3c9d3b9f2b9d6b9d6b9d3e2b9g6c9f2b9d2d2e6c1c7c8e4b9c8d5c3c8c6c5e3c9c7d7f3d3d2g6g6d2e4b9b9d7d7b9d7c0b9c5c4e5c5b9b9d7d7c3c4c0c1c4d9c2c6c5e3c6e5d4d1c4c3c1d4c6c4d4d6c2d6c6d5f1d8e3e3e5d5d5c1c7c7c7c9e3c9d3b9f2b9d6b9d6b9d3e2b9g6c9f2b9d2d2e6c1c7c8e4b9c8d5c3c8c6c5e3c9c7d7f3d3d2g6g6d2f2b9b9d7d7b9d7c0b9c5c4e5c5b9b9d7d7c3c4c0c1c4d9c2c6c5e3c6e5d4d1c4c3c1d4c6c4d4d6c2d6c6d5f1d8e3e3e5d5d5c1c7c7c7c9e3c9d3b9f2b9d6b9d6b9d3e2b9g6c9f2b9d2d2e5c1c7c8e4b9c8d5c3c8c6c5e3c9c7d7f3d3d2g6g6d2e4b9b9d7d7b9d7c0b9c5c4e5c5b9b9d7d7c3c4c0c1c4d9c2c6c5e3c6e5d4d1c4c3c1d4c6c4d4d6c2d6c6d5f1d8e3e3e5d5d5c1c7c7c7c9d7f0e9f7g1b2", -"a2b0b0a8b3c6c6e5c5e3c7c8f2d2g6b9b9d2b9e4d6d7c5c9c0b9b9c0d0e5f5e3d7c3f5e0d8d5e5c0c0d9c7e3d7d6e5e6d4d1c6d4c5c0c3c2d7c7d7c2c1d8d8e5c6d7c2c0c3d7c9d6e3d7c9b9c9d6b9b9c8c8e4b9c7d3e2d6d3b9b9d2d2f4b9c5c7e2c9d7e5c6c6e5c5e3c7c8f2d2g6b9d3d2b9e4d6d7c5c9c0b9b9c0d0e5f5e3d7c3f5e0d8d5e5c0c0d9c7e3d7d6e5e6d4d1c6d4c5c0c3c2d7c7d7c2c1d8d8e5c6d7c2c0c3d7c9d6e3d7c9b9c9d6b9b9c8c8e4b9c7d3e2d6d3b9b9d2d2f4b9c5c7e2c9d7e5c6c6e5c5e3c7c8f2d2g6b9d3d2b9e4d6d7c5c9c0b9b9c0d0e5f5e3d7c3f5e0d8d5e5c0c0d9c7e3d7d6e5e6d4d1c6d4c5c0c3c2d7c7d7c2c1d8d8e5c6d7c2c0c3d7c9d6e3d7c9b9c9d6b9b9c8c8e4b9c7d3e2d6d3b9b9d2d2f4f2c5d7e2c9d7e5c6c6e5c5e3c7c8f2d2g6b9b9d2b9e4d6d7c5c9c0b9b9c0d0e5f5e3d7c3f5e0d8d5e5c0c0d9c7e3d7d6e5e6d4d1c6d4c5c0c3c2d7c7d7c2c1d8d8e5c6d7c2c0c3d7c9d6e3d7c9f7f0b6f0b2", -"a2b0a7a6b3d0e5e3e3e3c6c8d6c4d0e2b9g6d6d6d7e6b9c0d7c1b9b9d5c3d4c6g2d8d8d8e0c7e5e5f2c9d7d7d7e7c2d1d1d4d0d1d0e5c6c6e6c1d7d7c3e1c2c4e6c2e5f6d4c8c7c8c6c5e3d9c9c9e4d7c8b9f2c9d9d3c9c8e4b9b9e3c5g6e4e6c2e2d4d4c6d0e5e3e3e3c6c8d6c4d0e2f2f2d6d6d7e6b9c0d7c1b9b9d5c3d4c6g2d8d8d8e0c7e5e5f2c9d7d7d7e7c2d1d1d4d0d1d0e5c6c6e6c1d7d7c3e1c2c4e6c2e5f6d4c8c7c8c6c5e3d9c9c9e4d7c8b9f2c9d9d3c9c8e4b9b9e3c5g6e4e6c2e2d4d4c6d0e5e3e3e3c6c8d6c4d0e2f2f2d6d6d7e6b9c0d7c1b9b9d5c3d4c6g2d8d8d8e0c7e5e5f2c9d7d7d7e7c2d1d1d4d0d1d0e5c6c6e6c1d7d7c3e1c2c4e6c2e5f6d4c8c7c8c6c5e3d9c9c9e4d7c8b9f2c9d9d3c9c8e4b9b9c5c8g6e4e6c2e2d4d4c6d0e5e3e3e3c6c8d6c4d0e2b9g6d6d6d7e6b9c0d7c1b9b9d5c3d4c6g2d8d8d8e0c7e5e5f2c9d7d7d7e7c2d1d1d4d0d1d0e5c6c6e6c1d7d7c3e1c2c4e6c2e5f6d4c8c7c8c6c5e3f0e9f0f0b2", -"a2a8a7a6b3c2c6c9c8e3d7d7g6e6e6g6f3f2d7c7e3c2c5c2c5d7c1e5f5g3g3c2f5d8e6c1e6c6d5c6d2d2c6c2e7d9e3c3c3e5c1f6c6c1c8c5d0e5c0d7c2f6b9c2e5e6d1d4c2c7e3e3c1c1c1c8d6e7d7c7d6b9d3d6d3c9c7c9b9b9c8e6c8c9c7e3c1b9c4c4c2c2c6c9c8e3d7d7g6e6e6g6g6f2d7c7e3c2c5c2c5d7c1e5f5g3g3c2f5d8e6c1e6c6d5c6d2d2c6c2e7d9e3c3c3e5c1f6c6c1c8c5d0e5c0d7c2f6b9c2e5e6d1d4c2c7e3e3c1c1c1c8d6e7d7c7d6b9d3d6d3c9c7c9b9b9c8e6c8c9c7e3c1b9c4c4c2c2c6c9c8e3d7d7g6e6e6g6g6f2d7c7e3c2c5c2c5d7c1e5f5g3g3c2f5d8e6c1e6c6d5c6d2d2c6c2e7d9e3c3c3e5c1f6c6c1c8c5d0e5c0d7c2f6b9c2e5e6d1d4c2c7e3e3c1c1c1c8d6e7d7c7d6b9d3d6d3c9c7c9b9b9d7e6c8c9c7e3c1b9c4c4c2c2c6c9c8e3d7d7g6e6e6g6f3f2d7c7e3c2c5c2c5d7c1e5f5g3g3c2f5d8e6c1e6c6d5c6d2d2c6c2e7d9e3c3c3e5c1f6c6c1c8c5d0e5c0d7c2f6b9c2e5e6d1d4c2c7e3e3c1c1c1b6f0f7b6b2", -"a2a8a6a6b3c8d9d6c8c7d2f3e6e6e6f3c8c5e6e3d7d7d9c7c2e5c2e6d8d8c5d7c6c6d0c2c1e6d5c3c8c1d7d7e3c1f6d1g3c1e5g2d4c6c5c2d4c1c1e3e6c5c3c2d5d5g2e6d7c9c2c6c1c1e5c9e4d6d6e4c7c7d7c8c9e7c9b9d6c2e6c2d3c9f2e6d3e3f5c3d6c8d9d6c8c7d2f3e6e6e6f3c7c5e6e3d7d7d9c7c2e5c2e6d8d8c5d7c6c6d0c2c1e6d5c3c8c1d7d7e3c1f6d1g3c1e5g2d4c6c5c2d4c1c1e3e6c5c3c2d5d5g2e6d7c9c2c6c1c1e5c9e4d6d6e4c7c7d7c8c9e7c9b9d6c2e6c2d3c9f2e6d3e3f5c3d6c8d9d6c8c7d2f3e6e6e6f3c7c5e6e3d7d7d9c7c2e5c2e6d8d8c5d7c6c6d0c2c1e6d5c3c8c1d7d7e3c1f6d1g3c1e5g2d4c6c5c2d4c1c1e3e6c5c3c2d5d5g2e6d7c9c2c6c1c1e5c9e4d6d6e4c7c7d7c8c9e7c9b9d6c2e6c2d3c9f2e6d3e3f5c3d6c8d9d6c8c7d2f3e6e6e6f3c8c5e6e3d7d7d9c7c2e5c2e6d8d8c5d7c6c6d0c2c1e6d5c3c8c1d7d7e3c1f6d1g3c1e5g2d4c6c5c2d4c1c1e3e6c5c3c2d5d5g2e6d7c9c2c6c1c1e5f0f0f0f0b2", -"a2a7a6a7b3c8e7e7c8c7d2g6e6e6g6d9e5c5d7c2d7c6d9c9c2c0d1d1c6c1d7c6f6c4c0c5c4d7d7c7c2c4c5e6c5e5c3c3c3c4d0g2c4c3d7c2e6e6c6c5c1c2d5c5c4d5c1c6c5e3c6c1c2c5c6c2d7d6d7c8e2d7c7c9d9d7d9e3c5c2e3c1e4f2g6c9d3e5d5c6d6c8e7e7c8c7d2g6e6e6g6d9e5c5d7c2d7c6d9c9c2c0d1d1c6c1d7c6f6c4c0c5c4d7d7c7c2c4c5e6c5e5c3c3c3c4d0g2c4c3d7c2e6e6c6c5c1c2d5c5c4d5c1c6c5e3c6c1c2c5c6c2d7d6d7c8e2d7c7c9d9d7d9e3c5c2e3c1e4f2g6c9d3e5d5c6d6c8e7e7c8c7d2g6e6e6g6d9e5c5d7c2d7c6d9c9c2c0d1d1c6c1d7c6f6c4c0c5c4d7d7c7c2c4c5e6c5e5c3c3c3c4d0g2c4c3d7c2e6e6c6c5c1c2d5c5c4d5c1c6c5e3c6c1c2c5c6c2d7d6d7c8e2d7c7c9d9d7d9e3c5c2e3c1e4f2g6c9d3e5d5c6d6c8e7e7c8c7d2g6e6e6g6d9e5c5d7c2d7c6d9c9c2c0d1d1c6c1d7c6f6c4c0c5c4d7d7c7c2c4c5e6c5e5c3c3c3c4d0g2c4c3d7c2e6e6c6c5c1c2d5c5c4d5c1c6c5e3c6c1c2c5c6b8b6f0b6b2", -"a2a7a9a8b3c7c9c7d7c7g6e5e6c1f2d9c4c4e6e3c5c5b9b9e5e5d9c1e5e5e3c3c6e5c1e5d0d1c8c5e5c6e5e6c1e5d4c0d5c3c0d8e5e5c2e3d6c6c5d6c2c7e4b9c2c2c1c2c6c2c1c1e3c5c6c4b9e5b9d7c7e3c5f2d7d9c7e6d0c5d2e4b9g6d2d3e5c4e3d7d6c7c9c7d7c7g6e5e6c1f2d9c4c4e6e3c5c5b9b9e5e5d9c1e5e5e3c3c6e5c1e5d0d1c8c5e5c6e5e6c1e5d4c0d5c3c0d8e5e5c2e3d6c6c5d6c2c7e4b9c2c2c1c2c6c2c1c1e3c5c6c4b9e5b9d7c7e3c5f2d7d9c7e6d0c5d2e4b9g6d2d3e5c4e3d7d6c7c9c7d7c7g6e5e6c1f2d9c4c4e6e3c5c5b9b9e5e5d9c1e5e5e3c3c6e5c1e5d0d1c8c5e5c6e5e6c1e5d4c0d5c3c0d8e5e5c2e3d6c6c5d6c2c7e4b9c2c2c1c2c6c2c1c1e3c5c6c4b9e5b9d7c7e3c5f2d7d9c7e6d0c5d2e4b9g6d2d3e5c4e3d7d6c7c9c7d7c7g6e5e6c1f2d9c4c4e6e3c5c5b9b9e5e5d9c1e5e5e3c3c6e5c1e5d0d1c8c5e5c6e5e6c1e5d4c0d5c3c0d8e5e5c2e3d6c6c5d6c2c7e4b9c2c2c1c2c6c2c1c1e3c5c6f8f0b8f0b2", -"a2a7a9a8b3d9c7c8d7c8c7d4e6g6e4c1c4c8e5d7d9c7c8c1b9c0e1d8g2c0d5e5c0c6e6c1c1e5d7c8c4c2e5g2d5d1d0e3c1c4d5c3c8d6c0c8d7c7c2d6c5e7b9b9d6d7c6c1c8e3e6e6c5c6e6e3e5d0c9c6c7c9c9d7d7c2c1d4d0c9d3b9d2e2f4d6c2e5d0c7c9d9c7c8d7c8c7d4e6g6e4c1c4c8e5d7d9c7c8c1b9c0e1d8g2c0d5e5c0c6e6c1c1e5d7c8c4c2e5g2d5d1d0e3c1c4d5c3c8d6c0c8d7c7c2d6c5e7b9b9d6d7c6c1c8e3e6e6c5c6e6e3e5d0c9c6c7c9c9d7d7c2c1d4d0c9d3b9d2e2f4d6c2e5d0c7c9d9c7c8d7c8c7d4e6g6e4c1c4c8e5d7d9c7c8c1b9c0e1d8g2c0d5e5c0c6e6c1c1e5d7c8c4c2e5g2d5d1d0e3c1c4d5c3c8d6c0c8d7c7c2d6c5e7b9b9d6d7c6c1c8e3e6e6c5c6e6e3e5d0c9c6c7c9c9d7d7c2c1d4d0c9d3b9d2e2f4d6c2e5d0c7c9d9c7c8d7c8c7d4e6g6e4c1c4c8e5d7d9c7c8c1b9c0e1d8g2c0d5e5c0c6e6c1c1e5d7c8c4c2e5g2d5d1d0e3c1c4d5c3c8d6c0c8d7c7c2d6c5e7b9b9d6d7c6c1c8e3e6e6c5c6e6b8b8b8f0b2", -"a1a7a9b0b3d6e7c5e3g6c1d4c7d2e2d6c5c2c5c7c8c5c0c1c5e5c4e0c4e3c0e6c1d0c8c4c1f6c2d4c5c1d5c6e6c6e3e3c5d5f5c1c1d6c1c6d7c8b9d9c7c9b9c2c2c5g2d4c5c3c4c5d7c1c1c8e5d1c6d6c5b9c5d6e3d1c1c2d7d3b9d6d2c9d3c4c2e5c6c7c9d6e7c5e3g6c1d4c7d2e2d6c5c2c5c7c8c5c0c1c5e5c4e0c4e3c0e6c1d0c8c4c1f6c2d4c5c1d5c6e6c6e3e3c5d5f5c1c1d6c1c6d7c8b9d9c7c9b9c2c2c5g2d4c5c3c4c5d7c1c1c8e5d1c6d6c5b9c5d6e3d1c1c2d7d3b9d6d2c9d3c4c2e5c6c7c9d6e7c5e3g6c1d4c7d2e2d6c5c2c5c7c8c5c0c1c5e5c4e0c4e3c0e6c1d0c8c4c1f6c2d4c5c1d5c6e6c6e3e3c5d5f5c1c1d6c1c6d7c8b9d9c7c9b9c2c2c5g2d4c5c3c4c5d7c1c1c8e5d1c6d6c5b9c5d6e3d1c1c2d7d3b9d6d2c9d3c4c2e5c6c7c9d6e7c5e3g6c1d4c7d2e2d6c5c2c5c7c8c5c0c1c5e5c4e0c4e3c0e6c1d0c8c4c1f6c2d4c5c1d5c6e6c6e3e3c5d5f5c1c1d6c1c6d7c8b9d9c7c9b9c2c2c5g2d4c5c3c4c5d7c1e5b6b8f8b8b2", -"a2b0a9a8b3c8e7e3c2c4c8c8d2d2g6c5e6e6c6c7d7c2c5c1e5c0d4e5e3c7g2c3e6e3c4c2e3c6c0f6f5e5c1c5c6d7e3e3c4f6g2e5c7c1c0c7d7c1d7d6c9c8g6c2d5c1e1g2d4c1b9c4c2d5d4c2d0c0e6c2c2b9c1d6c1d1c2g2c1b9b9c1e6d3c2d5d6d3d0c7c7c7e7e3c2c4c8c8d2d2g6c5e6e6c6c7d7c2c5c1e5c0d4e5e3c7g2c3e6e3c4c2e3c6c0f6f5e5c1c5c6d7e3e3c4f6g2e5c7c1c0c7d7c1d7d6c9c8g6c2d5c1e1g2d4c1b9c4c2d5d4c2d0c0e6c2c2b9c1d6c1d1c2g2c1b9b9c1e6d3c2d5d6d3d0c7c7c7e7e3c2c4c8c8d2d2g6c5e6e6c6c7d7c2c5c1e5c0d4e5e3c7g2c3e6e3c4c2e3c6c0f6f5e5c1c5c6d7e3e3c4f6g2e5c7c1c0c7d7c1d7d6c9c8g6c2d5c1e1g2d4c1b9c4c2d5d4c2d0c0e6c2c2b9c1d6c1d1c2g2c1b9b9c1e6d3c2d5d6d3d0c7c7c7e7e3c2c4c8c8d2d2g6c5e6e6c6c7d7c2c5c1e5c0d4e5e3c7g2c3e6e3c4c2e3c6c0f6f5e5c1c5c6d7e3e3c4f6g2e5c7c1c0c7d7c1d7d6c9c8g6c2d5c1e1g2d4c1b9c4c2d5d4b8b8e8b8b2", -"a2b0a9a9b3c7e3c5c8e6c5f9e4e7d7e5c8c8d7c7c2c2c1d4c5c6c2c6c0e5c4d4c4e3c2d7d7e3c0e5c5d7c6c2c5d0c5d5c4d4d1c5d6c8d5c1c2e6d5c6c7f2e4e1e1e0e0d5d4c4c1c4c1c1e5c4d7c9c5e6g3c6c6c0e6e6e7c2e6b9c1f5d5b9d5d5d9d3e6d7c7c7e3c5c8e6c5f9e4e7d7e5c8c8d7c7c2c2c1d4c5c6c2c6c0e5c4d4c4e3c2d7d7e3c0e5c5d7c6c2c5d0c5d5c4d4d1c5d6c8d5c1c2e6d5c6c7f2e4e1e1e0e0d5d4c4c1c4c1c1e5c4d7c9c5e6g3c6c6c0e6e6e7c2e6b9c1f5d5b9d5d5d9d3e6d7c7c7e3c5c8e6c5f9e4e7d7e5c8c8d7c7c2c2c1d4c5c6c2c6c0e5c4d4c4e3c2d7d7e3c0e5c5d7c6c2c5d0c5d5c4d4d1c5d6c8d5c1c2e6d5c6c7f2e4e1e1e0e0d5d4c4c1c4c1c1e5c4d7c9c5e6g3c6c6c0e6e6e7c2e6b9c1f5d5b9d5d5d9d3e6d7c7c7e3c5c8e6c5f9e4e7d7e5c8c8d7c7c2c2c1d4c5c6c2c6c0e5c4d4c4e3c2d7d7e3c0e5c5d7c6c2c5d0c5d5c4d4d1c5d6c8d5c1c2e6d5c6c7f2e4e1e1e0e0d5d4c4c1c4c1c1c0f8b6f7b8b2", -"a2b0a9a9b3d2c5c7d2e6c4e2d6d7e3d1c2e3c8c9d7d8d4c6c6c9c8c2c5c2c4d1c4c3d7c2c1c1e5c0c5c5c6c1e3e6e3c1c1c3f5e6c5c8d4c3c7c6d5c3b9c5b9e1e1c4g2c1c4c1b9c1c4c4c6c2c5c9c0d4c1c0f6d4e6g6d2e2d2e6d8d5e6d6f5f6f9d9e3c5e2d2c5c7d2e6c4e2d6d7e3d1c2e3c8c9d7d8d4c6c6c9c8c2c5c2c4d1c4c3d7c2c1c1e5c0c5c5c6c1e3e6e3c1c1c3f5e6c5c8d4c3c7c6d5c3b9c5b9e1e1c4g2c1c4c1b9c1c4c4c6c2c5c9c0d4c1c0f6d4e6g6d2e2d2e6d8d5e6d6f5f6f9d9e3c5e2d2c5c7d2e6c4e2d6d7e3d1c2e3c8c9d7d8d4c6c6c9c8c2c5c2c4d1c4c3d7c2c1c1e5c0c5c5c6c1e3e6e3c1c1c3f5e6c5c8d4c3c7c6d5c3b9c5b9e1e1c4g2c1c4c1b9c1c4c4c6c2c5c9c0d4c1c0f6d4e6g6d2e2d2e6d8d5e6d6f5f6f9d9e3c5e2d2c5c7d2e6c4e2d6d7e3d1c2e3c8c9d7d8d4c6c6c9c8c2c5c2c4d1c4c3d7c2c1c1e5c0c5c5c6c1e3e6e3c1c1c3f5e6c5c8d4c3c7c6d5c3b9c5b9e1e1c4g2c1c4c1b9c1c4c4c6b8b8f0f8b2", -"a2a8a9a9b7c5c7c9c9c9d9e4c7c5c6c1c3c2d6e3d7d5c1d7d7c8d6c8e7e6c5d5e6d1c6d6d0c1c0c1c2e3c4c0c6d7d6c6c3c4g2d7c5c6g2d4c8d7f6e1f2c4c3i3c1d5c4c5c5c3d5c4e4c5e6d9e5c9c1c3e6c0f6f6d6d2d2f2d2f5d8e6f2e4d5d5f9e7c5d7e4c5c7c9c9c9d9e4c7c5c6c1c3c2d6e3d7d5c1d7d7c8d6c8e7e6c5d5e6d1c6d6d0c1c0c1c2e3c4c0c6d7d6c6c3c4g2d7c5c6g2d4c8d7f6e1f2c4c3i3c1d5c4c5c5c3d5c4e4c5e6d9e5c9c1c3e6c0f6f6d6d2d2f2d2f5d8e6f2e4d5d5f9e7c5d7e4c5c7c9c9c9d9e4c7c5c6c1c3c2d6e3d7d5c1d7d7c8d6c8e7e6c5d5e6d1c6d6d0c1c0c1c2e3c4c0c6d7d6c6c3c4g2d7c5c6g2d4c8d7f6e1f2c4c3i3c1d5c4c5c5c3d5c4e4c5e6d9e5c9c1c3e6c0f6f6d6d2d2f2d2f5d8e6f2e4d5d5f9e7c5d7e4c5c7c9c9c9d9e4c7c5c6c1c3c2d6e3d7d5c1d7d7c8d6c8e7e6c5d5e6d1c6d6d0c1c0c1c2e3c4c0c6d7d6c6c3c4g2d7c5c6g2d4c8d7f6e1f2c4c3i3c1d5c4c5c5c3d5c4e4c5c6f0b8b6b8b2", -"a2b0a9a8b3c5c7d4e5d9d9e4e4e6e5e6c1e3c7c5e6c8c8c1c1c8c8e5e5d8f5c4c2d7d6c7d0c4d5c5d7e3c6c5c1d0d5c3d4d5c5c2g2e6c0e0c6f6g2e6c5d5e1g2c4c2c1c4c2c5b9c4d7b9c2c5e6c6c2d0d1c0c4c6e7c5e6c1c2g3e1e5d2g6d8f5f9d9c2d7d7d7c8d4e5d9d9e4e4e6e5e6c1e3c7c5e6c8c8c1c1c8c8e5e5d8f5c4c2d7d6c7d0c4d5c5d7e3c6c5c1d0d5c3d4d5c5c2g2e6c0e0c6f6g2e6c5d5e1g2c4c2c1c4c2c5b9c4d7b9c2c5e6c6c2d0d1c0c4c6e7c5e6c1c2g3e1e5d2g6d8f5f9d9c2d7d7d7c8d4e5d9d9e4e4e6e5e6c1e3c7c5e6c8c8c1c1c8c8e5e5d8f5c4c2d7d6c7d0c4d5c5d7e3c6c5c1d0d5c3d4d5c5c2g2e6c0e0c6f6g2e6c5d5e1g2c4c2c1c4c2c5b9c4d7b9c2c5e6c6c2d0d1c0c4c6e7c5e6c1c2g3e1e5d2g6d8f5f9d9c2d7d7d7c8d4e5d9d9e4e4e6e5e6c1e3c7c5e6c8c8c1c1c8c8e5e5d8f5c4c2d7d6c7d0c4d5c5d7e3c6c5c1d0d5c3d4d5c5c2g2e6c0e0c6f6g2e6c5d5e1g2c4c2c1c4c2c5b9c4d7b9c2b6b8b8b8b2", -"a2a8a9a8b3c4b9d4f6c7d9g6g6c9d7c2d7c2d7e6c4c6e5c1e5d3e3c6e1e1f5c2e6d6e7d6d1c3c1e3c2e6c5c6c1d4f6d5c3e6c1e5e1d4d7c3d0d1d4c2c1e1e1c2c5c4c1c4c5b9c0c5c5b9e5c5d9e5e6d1c6e5c1c1b9c8c4e5c1d8f5g6d2c2d8d5d2c8c2c7e6e5b9d4f6c7d9g6g6c9d7c2d7c2d7e6c4c6e5c1e5d3e3c6e1e1f5c2e6d6e7d6d1c3c1e3c2e6c5c6c1d4f6d5c3e6c1e5e1d4d7c3d0d1d4c2c1e1e1c2c5c4c1c4c5b9c0c5c5b9e5c5d9e5e6d1c6e5c1c1b9c8c4e5c1d8f5g6d2c2d8d5d2c8c2c7e6e5b9d4f6c7d9g6g6c9d7c2d7c2d7e6c4c6e5c1e5d3e3c6e1e1f5c2e6d6e7d6d1c3c1e3c2e6c5c6c1d4f6d5c3e6c1e5e1d4d7c3d0d1d4c2c1e1e1c2c5c4c1c4c5b9c0c5c5b9e5c5d9e5e6d1c6e5c1c1b9c8c4e5c1d8f5g6d2c2d8d5d2c8c2c7e6e5b9d4f6c7d9g6g6c9d7c2d7c2d7e6c4c6e5c1e5d3e3c6e1e1f5c2e6d6e7d6d1c3c1e3c2e6c5c6c1d4f6d5c3e6c1e5e1d4d7c3d0d1d4c2c1e1e1c2c5c4c1c4c5b9c0c5c5b9e5b8f7b8e8b2", -"a2a8a8a8b3c7e7d5e5b9d9g6f2f2f2d7d7d6c1d7c4c3e5c3e4b9c7e5e0g2g2e6c7d7d6c6c3e6d0c5c1c0c2e6c3c4d5c3d4c1c6g2e1e0c2f5c3c1g3d7d1e1c4b9c4c5c5b9c4c2c5b9c4e2b9c5c6c5d1d1c9c5c5d7d6d7d6c1e6d5d0e4d2d1c3c6g6c7c7d7c5c7e7d5e5b9d9g6f2f2f2d7d7d6c1d7c4c3e5c3e4b9c7e5e0g2g2e6c7d7d6c6c3e6d0c5c1c0c2e6c3c4d5c3d4c1c6g2e1e0c2f5c3c1g3d7d1e1c4b9c4c5c5b9c4c2c5b9c4e2b9c5c6c5d1d1c9c5c5d7d6d7d6c1e6d5d0e4d2d1c3c6g6c7c7d7c5c7e7d5e5b9d9g6f2f2f2d7d7d6c1d7c4c3e5c3e4b9c7e5e0g2g2e6c7d7d6c6c3e6d0c5c1c0c2e6c3c4d5c3d4c1c6g2e1e0c2f5c3c1g3d7d1e1c4b9c4c5c5b9c4c2c5b9c4e2b9c5c6c5d1d1c9c5c5d7d6d7d6c1e6d5d0e4d2d1c3c6g6c7c7d7c5c7e7d5e5b9d9g6f2f2f2d7d7d6c1d7c4c3e5c3e4b9c7e5e0g2g2e6c7d7d6c6c3e6d0c5c1c0c2e6c3c4d5c3d4c1c6g2e1e0c2f5c3c1g3d7d1e1c4b9c4c5c5b9c4c2c5b9c4e2b9b8b8b8g0b2", -"a2b0a8b0b3e6e3e6d7d6f3g6b9e7d6d7d7d7c2c1f6f6d1d1c0d9c5e1d8e0d0c7d4f6c1c4e6c5c1e3d5e5e6d5g3d5c4e5c0c2e6e0d8d5e0c8d9d7c2c9e0c4c2b9c4c5c4c2c4c5b9c4c5b9c7e5c5e5c6b9d6c5e6b9c6e3c1d0c2g6e7e4e5c1d5e3f2e7e7d9c7e6e3e6d7d6f3g6b9e7d6d7d7d7c2c1f6f6d1d1c0d9c5e1d8e0d0c7d4f6c1c4e6c5c1e3d5e5e6d5g3d5c4e5c0c2e6e0d8d5e0c8d9d7c2c9e0c4c2b9c4c5c4c2c4c5b9c4c5b9c7e5c5e5c6b9d6c5e6b9c6e3c1d0c2g6e7e4e5c1d5e3f2e7e7d9c7e6e3e6d7d6f3g6b9e7d6d7d7d7c2c1f6f6d1d1c0d9c5e1d8e0d0c7d4f6c1c4e6c5c1e3d5e5e6d5g3d5c4e5c0c2e6e0d8d5e0c8d9d7c2c9e0c4c2b9c4c5c4c2c4c5b9c4c5b9c7e5c5e5c6b9d6c5e6b9c6e3c1d0c2g6e7e4e5c1d5e3f2e7e7d9c7e6e3e6d7d6f3g6b9e7d6d7d7d7c2c1f6f6d1d1c0d9c5e1d8e0d0c7d4f6c1c4e6c5c1e3d5e5e6d5g3d5c4e5c0c2e6e0d8d5e0c8d9d7c2c9e0c4c2b9c4c5c4c2c4c5b9c4c5b9c7b8b8e8b8b2", -"a2b0b0b0b7d4d4e6e3c9f2d9d7c4d7d1c7c5c2c2d1e5d4d5c2e5d1g3d8c6c9d1c3d5c1c6c1c1d1c0d5c0c6d5g2e0c1c6e3c6e5d5f1d5e0b9c8c5c2b9e1c2d7c5c4c2c1c1e5b9c4c4c5c4c9d3f4d2f9g6e6c2d6c7e6f5d4c1d2d2d6d2e5c6c8d7f9e2d9d2d6d4d4e6e3c9f2d9d7c4d7d1c7c5c2c2d1e5d4d5c2e5d1g3d8c6c9d1c3d5c1c6c1c1d1c0d5c0c6d5g2e0c1c6e3c6e5d5f1d5e0b9c8c5c2b9e1c2d7c5c4c2c1c1e5b9c4c4c5c4c9d3f4d2f9g6e6c2d6c7e6f5d4c1d2d2d6d2e5c6c8d7f9e2d9d2d6d4d4e6e3c9f2d9d7c4d7d1c7c5c2c2d1e5d4d5c2e5d1g3d8c6c9d1c3d5c1c6c1c1d1c0d5c0c6d5g2e0c1c6e3c6e5d5f1d5e0b9c8c5c2b9e1c2d7c5c4c2c1c1e5b9c4c4c5c4c9d3f4d2f9g6e6c2d6c7e6f5d4c1d2d2d6d2e5c6c8d7f9e2d9d2d6d4d4e6e3c9f2d9d7c4d7d1c7c5c2c2d1e5d4d5c2e5d1g3d8c6c9d1c3d5c1c6c1c1d1c0d5c0c6d5g2e0c1c6e3c6e5d5f1d5e0b9c8c5c2b9e1c2d7c5c4c2c1c1e5b9c4c4c5c4c9e9g4g1g4b2", -"a2b0a8b0a5d4d1c6c1e6f2d9c8c4c2c6c7d6e5d0f6d1e0c8c2e6f6d8e1b9c7d4d5d0c0c6d0c4d5c3e6c1e6f5d8c1c8e6d6e6c4e0d5e5d8c6d7c2c5d5c2c5b9c5c4c2c1c4c2c4c4c2c4e4e3d2d2f4d2b9c6e6c9d7g3f5g3c9e5e6c9d3c7c5e5c9f2f4d7d6d4d4d1c6c1e6f2d9c8c4c2c6c7d6e5d0f6d1e0c8c2e6f6d8e1b9c7d4d5d0c0c6d0c4d5c3e6c1e6f5d8c1c8e6d6e6c4e0d5e5d8c6d7c2c5d5c2c5b9c5c4c2c1c4c2c4c4c2c4e4e3d2d2f4d2b9c6e6c9d7g3f5g3c9e5e6c9d3c7c5e5c9f2f4d7d6d4d4d1c6c1e6f2d9c8c4c2c6c7d6e5d0f6d1e0c8c2e6f6d8e1b9c7d4d5d0c0c6d0c4d5c3e6c1e6f5d8c1c8e6d6e6c4e0d5e5d8c6d7c2c5d5c2c5b9c5c4c2c1c4c2c4c4c2c4e4e3d2d2f4d2b9c6e6c9d7g3f5g3c9e5e6c9d3c7c5e5c9f2f4d7d6d4d4d1c6c1e6f2d9c8c4c2c6c7d6e5d0f6d1e0c8c2e6f6d8e1b9c7d4d5d0c0c6d0c4d5c3e6c1e6f5d8c1c8e6d6e6c4e0d5e5d8c6d7c2c5d5c2c5b9c5c4c2c1c4c2c4c4c2c4e4c5g1g4g4g4b2", -"a2b0b0a7a5c4d7c6c1d0e5d6c8e6c2c7c9e3c1c1d1d8c8c2e6f6d1c4c9g6d5d1e5e6c2c2c1d1c3d4c1c1c4c1g2c4c6d0c6c7e6f1c5b9c5c8c8c2e1e1c6c5c5c4c2c4d8c1c4c5c4b9c5d7c9e7d2d2d3c7c1c1d0c4d8d1f2c3f5d4c2e7b9e3d7c9e2d3c7d4d4c4d7c6c1d0e5d6c8e6c2c7c9e3c1c1d1d8c8c2e6f6d1c4c9g6d5d1e5e6c2c2c1d1c3d4c1c1c4c1g2c4c6d0c6c7e6f1c5b9c5c8c8c2e1e1c6c5c5c4c2c4d8c1c4c5c4b9c5d7c9e7d2d2d3c7c1c1d0c4d8d1f2c3f5d4c2e7b9e3d7c9e2d3c7d4d4c4d7c6c1d0e5d6c8e6c2c7c9e3c1c1d1d8c8c2e6f6d1c4c9g6d5d1e5e6c2c2c1d1c3d4c1c1c4c1g2c4c6d0c6c7e6f1c5b9c5c8c8c2e1e1c6c5c5c4c2c4d8c1c4c5c4b9c5d7c9e7d2d2d3c7c1c1d0c4d8d1f2c3f5d4c2e7b9e3d7c9e2d3c7d4d4c4d7c6c1d0e5d6c8e6c2c7c9e3c1c1d1d8c8c2e6f6d1c4c9g6d5d1e5e6c2c2c1d1c3d4c1c1c4c1g2c4c6d0c6c7e6f1c5b9c5c8c8c2e1e1c6c5c5c4c2c4d8c1c4c5c4b9c5d7c9f0g1g1f0b2", -"a2b0a6a6b1g4e9e9b6e8f0f0b8b8b8f0b8b8g0f8g0b8b8f8b5g0b5f0f0e9g0f8f0f8e8e8g0e8g0g0e8e8f8b8b5e8e8b6f8b6e8j2f0f0b8b8f0g0j3j3b8f0b8b8b8b5b8b8b8b8b8f8f0f0f0g1g1f0b6f8e8e8b8f8j2g0g1b8b8b8b8b8f0f0b6b6f0g1e8f8f8g4e9e9b6e8f0f0b8b8b8f0b8b8g0f8g0b8b8f8b5g0b5f0f0e9g0f8f0f8e8e8g0e8g0g0e8e8f8b8b5e8e8b6f8b6e8j2f0f0b8b8f0g0j3j3b8f0b8b8b8b5b8b8b8b8b8f8f0f0f0g1g1f0b6f8e8e8b8f8j2g0g1b8b8b8b8b8f0f0b6b6f0g1e8f8f8g4e9e9b6e8f0f0b8b8b8f0b8b8g0f8g0b8b8f8b5g0b5f0f0e9g0f8f0f8e8e8g0e8g0g0e8e8f8b8b5e8e8b6f8b6e8j2f0f0b8b8f0g0j3j3b8f0b8b8b8b5b8b8b8b8b8f8f0f0f0g1g1f0b6f8e8e8b8f8j2g0g1b8b8b8b8b8f0f0b6b6f0g1e8f8f8g4e9e9b6e8f0f0b8b8b8f0b8b8g0f8g0b8b8f8b5g0b5f0f0e9g0f8f0f8e8e8g0e8g0g0e8e8f8b8b5e8e8b6f8b6e8j2f0f0b8b8f0g0j3j3b8f0b8b8b8b5b8b8b8b8b8f8f0f0f0b2g1f0b6b2", -"a2b0a7b1b4f0g1e9f0b8f0g1b6b8b6b8b6j3g0b8j3b8f8b6g0f8g0f7f0f8b5j2b6b6b6e8g0f8f8e8e8g0e8f8e8b8b6g0b6b6b6j2j2b8f0f8g0b5j3g0e8f8e9b6b8f8f0f0f8f8b8b6b8e9f7f7f7f7b8b8e8b8b6b6e8e8g1g0g0f0b8b8b6b6b6b6f0f0f8f8b6g1g1e9f0b8f0g1b6b8b6b8b6j3g0b8j3b8f8b6g0f8g0f7f0f8b5j2b6b6b6e8g0f8f8e8e8g0e8f8e8b8b6g0b6b6b6j2j2b8f0f8g0b5j3g0e8f8e9b6b8f8f0f0f8f8b8b6b8e9f7f7f7f7b8b8e8b8b6b6e8e8g1g0g0f0b8b8b6b6b6b6f0f0f8f8b6g1g1e9f0b8f0g1b6b8b6b8b6j3g0b8j3b8f8b6g0f8g0f7f0f8b5j2b6b6b6e8g0f8f8e8e8g0e8f8e8b8b6g0b6b6b6j2j2b8f0f8g0b5j3g0e8f8e9b6b8f8f0f0f8f8b8b6b8e9f7f7f7f7b8b8e8b8b6b6e8e8g1g0g0f0b8b8b6b6b6b6f0f0f8f8b6g1g1e9f0b8f0g1b6b8b6b8b6j3g0b8j3b8f8b6g0f8g0f7f0f8b5j2b6b6b6e8g0f8f8e8e8g0e8f8e8b8b6g0b6b6b6j2j2b8f0f8g0b5j3g0e8f8e9b6b8f8f0f0f8f8b8b6b8e9f7g1b2f0b8b2", -"a1a6b1b4g0b6b5b8e9b5b6b6b8f0b8b8f8j2b8b8f8b5e8b6f8b5f0f7f0f7j2b5g0b8e8b8b8e8g0b8f8e8f8f0b5b6f0e8b8b6j2b6g0b6f8b8b5b4g0f7f8g1b8f0b6f0f7b8b5b8f7b8b6b6g1e9g1f0b6e9f0e9e8b6f8b6g1f8e8e9b8f0e8e8b6b6b6g0g0g0g0b8b5b8e9b5b6b6b8f0b8b8f8j2b8b8f8b5e8b6f8b5f0f7f0f7j2b5g0b8e8b8b8e8g0b8f8e8f8f0b5b6f0e8b8b6j2b6g0b6f8b8b5b4g0f7f8g1b8f0b6f0f7b8b5b8f7b8b6b6g1e9g1f0b6e9f0e9e8b6f8b6g1f8e8e9b8f0e8e8b6b6b6g0g0g0g0b8b5b8e9b5b6b6b8f0b8b8f8j2b8b8f8b5e8b6f8b5f0f7f0f7j2b5g0b8e8b8b8e8g0b8f8e8f8f0b5b6f0e8b8b6j2b6g0b6f8b8b5b4g0f7f8g1b8f0b6f0f7b8b5b8f7b8b6b6g1e9g1f0b6e9f0e9e8b6f8b6g1f8e8e9b8f0e8e8b6b6b6g0g0g0g0b8b5b8e9b5b6b6b8f0b8b8f8j2b8b8f8b5e8b6f8b5f0f7f0f7j2b5g0b8e8b8b8e8g0b8f8e8f8f0b5b6f0e8b8b6j2b6g0b6f8b8b5b4g0f7f8g1b8f0b6f0f7b8b5b8f7b8b6b6g1e9g1b2b6b2", -"a2b1a0j2e8e8f8b8b8b8f8b8b8b6b8b6b8g0b8b8b5b6b6f8f8f8g1e9g1g1j2b5b5f7f0g0g0b8g0e8b6b8b8b6f8b6f0b6b5b8b8f8b8e8e8f8j2j3b8b8f0g1b6f8b6g1b8g0f8b8f0f0f7b8b6e9g1e9f7f7e9e8f0e8g0b5g1f8e8g1b6b6b6b6b6b6g0j2b5f8e8b8f8b8b8b8f8b8b8b6b8b6b8g0b8b8b5b6b6f8f8f8g1e9g1g1j2b5b5f7f0g0g0b8g0e8b6b8b8b6f8b6f0b6b5b8b8f8b8e8e8f8j2j3b8b8f0g1b6f8b6g1b8g0f8b8f0f0f7b8b6e9g1e9f7f7e9e8f0e8g0b5g1f8e8g1b6b6b6b6b6b6g0j2b5f8e8b8f8b8b8b8f8b8b8b6b8b6b8g0b8b8b5b6b6f8f8f8g1e9g1g1j2b5b5f7f0g0g0b8g0e8b6b8b8b6f8b6f0b6b5b8b8f8b8e8e8f8j2j3b8b8f0g1b6f8b6g1b8g0f8b8f0f0f7b8b6e9g1e9f7f7e9e8f0e8g0b5g1f8e8g1b6b6b6b6b6b6g0j2b5f8e8b8f8b8b8b8f8b8b8b6b8b6b8g0b8b8b5b6b6f8f8f8g1e9g1g1j2b5b5f7f0g0g0b8g0e8b6b8b8b6f8b6f0b6b5b8b8f8b8e8e8f8j2j3b8b8f0g1b6f8b6g1b8g0f8b8f0f0f7b8b6e9g1e9b2b2", -"a4i4i4b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2i4b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2i4b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2i4b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2i4b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2b2i2", -};
--- a/lib-src/ChangeLog Mon Aug 13 10:03:54 2007 +0200 +++ b/lib-src/ChangeLog Mon Aug 13 10:04:58 2007 +0200 @@ -1,3 +1,13 @@ +1997-11-02 SL Baur <steve@altair.xemacs.org> + + * update-custom.sh (dirs): Remove packaged directories. + + * update-elc.sh (ignore_pattern): Hyperbole, oobr and ilisp are + now packaged. + + * update-autoloads.sh (mule_p): Hyperbole and oobr are now + packaged. + 1997-10-30 SL Baur <steve@altair.xemacs.org> * update-autoloads.sh (mule_p): EFS has been packaged.
--- a/lib-src/update-autoloads.sh Mon Aug 13 10:03:54 2007 +0200 +++ b/lib-src/update-autoloads.sh Mon Aug 13 10:04:58 2007 +0200 @@ -94,9 +94,11 @@ # EFS is now packaged #make_special efs autoloads #make_special eos autoloads # EOS doesn't have custom or autoloads -make_special hyperbole autoloads +# Hyperbole is now packaged +# make_special hyperbole autoloads # make_special ilisp autoloads -make_special oobr HYPB_ELC='' autoloads +# oobr is now packaged +# make_special oobr HYPB_ELC='' autoloads ## W3 is a package now ##make_special w3 autoloads
--- a/lib-src/update-custom.sh Mon Aug 13 10:03:54 2007 +0200 +++ b/lib-src/update-custom.sh Mon Aug 13 10:04:58 2007 +0200 @@ -65,8 +65,8 @@ # These directories don't have customizations, or are partially broken. # If some of the packages listed here are customized, don't forget to # remove the directory! -ignore_dirs="cl egg eos ilisp its language locale mel mu sunpro term \ -tooltalk iso mailcrypt oobr tl tm mh-e hyperbole electric apel \ +ignore_dirs="cl egg eos its language locale sunpro term \ +tooltalk iso electric \ hm--html-menus gnats pcl-cvs vm" # Only use Mule XEmacs to build Mule-specific autoloads & custom-loads.
--- a/lib-src/update-elc.sh Mon Aug 13 10:03:54 2007 +0200 +++ b/lib-src/update-elc.sh Mon Aug 13 10:04:58 2007 +0200 @@ -106,8 +106,8 @@ # first recompile the byte-compiler, so that the other compiles take place # with the latest version (assuming we're compiling the lisp dir of the emacs # we're running, which might not be the case, but often is.) -echo "Checking the byte compiler..." -$BYTECOMP -f batch-byte-recompile-directory lisp/bytecomp +#echo "Checking the byte compiler..." +#$BYTECOMP -f batch-byte-recompile-directory lisp/bytecomp # Prepare for byte-compiling directories with directory-specific instructions make_special_commands='' @@ -131,11 +131,14 @@ # make_special efs x20 make_special eos -k # not strictly necessary... ## make_special gnus some # Now this is a package. -make_special hyperbole elc +# hyperbole is now packaged +# make_special hyperbole elc # We're not ready for the following, yet. #make_special ilisp XEmacsELC=custom-load.elc elc -make_special ilisp elc -make_special oobr HYPB_ELC='' elc +# ilisp is now packaged +# make_special ilisp elc +# oobr is now packaged +# make_special oobr HYPB_ELC='' elc ## W3 is a package now. #make_special w3 xemacs-w3
--- a/lisp/ChangeLog Mon Aug 13 10:03:54 2007 +0200 +++ b/lisp/ChangeLog Mon Aug 13 10:04:58 2007 +0200 @@ -1,3 +1,476 @@ +1997-11-08 SL Baur <steve@altair.xemacs.org> + + * prim/about.el (about-hackers): New entries. + + * utils/shadow.el (list-load-path-shadows): Supress message when + no shadowings are found. + + * loadup.el: Modify algorithm for finding initial lisp directories + since the search now starts from lisp/ not lisp/prim/. + * update-elc.el: Ditto. + * make-docfile.el: Ditto. + +1997-11-07 SL Baur <steve@altair.xemacs.org> + + * prim/dumped-lisp.el: "lib-complete" is not dumped with InfoDock. + * utils/finder.el (finder-known-keywords): New keyword -- `dumped'. + + * version.el: Cleaned up Lisp comments. + * paths.el: Ditto. + * x-menubar.el: Ditto. + * x-faces.el: Ditto. + * x-iso8859-1.el: Ditto. + * x-mouse.el: Ditto. + * x-select.el: Ditto. + * x-scrollbar.el: Ditto. + * x-misc.el: Ditto. + * x-init.el: Ditto. + * x-toolbar.el: Ditto. + + * backquote.el: Moved to top-level. Cleaned up Lisp comments. + * packages.el: Ditto. + * subr.el: Ditto. + * replace.el: Ditto. + * cl.el: Ditto. + * cl-extra.el: Ditto. + * cl-seq.el: Ditto. + * widget.el: Ditto. + * custom.el: Ditto. + * cus-start.el: Ditto. + * cmdloop.el: Ditto. + * keymap.el: Ditto. + * syntax.el: Ditto. + * device.el: Ditto. + * console.el: Ditto. + * obsolete.el: Ditto. + * specifier.el: Ditto. + * faces.el: Ditto. + * glyphs.el: Ditto. + * objects.el: Ditto. + * extents.el: Ditto. + * events.el: Ditto. + * text-props.el: Ditto. + * process.el: Ditto. + * frame.el: Ditto. + * map-ynp.el: Ditto. + * simple.el: Ditto. + * keydefs.el: Ditto. + * abbrev.el: Ditto. + * derived.el: Ditto. + * minibuf.el: Ditto. + * list-mode.el: Ditto. + * modeline.el: Ditto. + * startup.el: Ditto. + * misc.el: Ditto. + * help-nomule.el: Ditto. + * help.el: Ditto. + * files-nomule.el: Ditto. + * files.el: Ditto. + * lib-complete.el: Ditto. + * format.el: Ditto. + * indent.el: Ditto. + * isearch-mode.el: Ditto. + * buffer.el: Ditto. + * buff-menu.el: Ditto. + * undo-stack.el: Ditto. + * window.el: Ditto. + * window-xemacs.el: Ditto. + * lisp.el: Ditto. + * page.el: Ditto. + * register.el: Ditto. + * iso8859-1.el: Ditto. + * paragraphs.el: Ditto. + * easymenu.el: Ditto. + * lisp-mode.el: Ditto. + * text-mode.el: Ditto. + * fill.el: Ditto. + * auto-save.el: Ditto. + * float-sup.el: Ditto. + * itimer.el: Ditto. + * itimer-autosave.el: Ditto. + * toolbar.el: Ditto. + * scrollbar.el: Ditto. + * menubar.el: Ditto. + * dialog.el: Ditto. + * gui.el: Ditto. + * mode-motion.el: Ditto. + * mouse.el: Ditto. + * tty-init.el: Ditto. + * auto-show.el: Ditto. + +1997-11-07 Kyle Jones <kyle_jones@wonderworks.com> + + * modes/abbrev.el (abbrev-prefix-mark): Instead of + inserting a dash to indicate the start of the abbrev, + add an extent with a begin-glyph that contains a dash. + +Wed Nov 05 23:40:00 1997 Jonathan Harris <jhar@tardis.ed.ac.uk> + + * faces.el: init-other-random-faces + Reinstated code that uses (mono x) as a specifer tag, but + conditioned it on (featurep 'x) because x is not a valid + specifier tag under native-win32. + + * Added file headers to: + w32-faces.el, w32-init.el + +Sun Nov 01 12:00:00 1997 Jonathan Harris <jhar@tardis.ed.ac.uk> + + * make-docfile.el: Fixed typo when dumped file does not exist. + + * device.el: make-w32-device added. + + * dumped-lisp: added w32-faces and w32-init to list. + + * faces.el: + - make-face-*: Added calls to appropriate w32 functions + conditioned on (featurep 'w32). Made existing X calls + conditioned on (featurep 'x). + - init-other-random-faces: Hacked out a piece of code which used + (mono x) as a specifier because it made w32 unhappy. + + * New files: + w32-faces.el, w32-init.el + +1997-11-07 Hrvoje Niksic <hniksic@srce.hr> + + * prim/mouse.el (default-mouse-motion-handler): When over + modeline, correctly dehighlight the last extent. + +1997-11-07 Hrvoje Niksic <hniksic@srce.hr> + + * prim/minibuf.el (mouse-read-file-name-1): Ditto. + + * packages/balloon-help.el (balloon-help-make-help-frame): Ditto. + + * games/life.el (life-setup): Check for scrollbars before using + them. + +1997-11-07 Hrvoje Niksic <hniksic@srce.hr> + + * hm--html-menus/hm--html-mode.el (hm--html-minor-mode): Ditto. + + * hm--html-menus/hm--html-menu.el ((adapt-xemacsp)): Ditto. + + * comint/gud.el (gdb-install-menubar): Ditto. + + * calendar/calendar.el (calendar-mode): Ditto. + + * auctex/bib-cite.el (bib-cite-initialize): Ditto. + + * utils/floating-toolbar.el (floating-toolbar): Ditto. + + * utils/edit-toolbar.el (edit-toolbar-mode): Ditto. + + * utils/browse-cltl2.el (cltl2-lisp-mode-install): Ditto. + + * modes/view-process-xemacs.el + (View-process-install-pulldown-menu): Ditto. + + * modes/verilog-mode.el (verilog-mode): Ditto. + + * modes/tcl.el (tcl-mode): Ditto. + + * modes/f90.el (f90-mode): Ditto. + + * packages/emerge.el (emerge-set-keys): Ditto. + + * packages/tar-mode.el (tar-mode): Check for menubars. + +1997-11-07 Kyle Jones <kyle_jones@wonderworks.com> + + * lisp/prim/modeline.el (mouse-drag-modeline): Don't + allow the window size to shrink to a size that is not a + multiple of the height of the default face's font. + + * lisp/prim/modeline.el (mouse-drag-modeline): Don't + discard timeout events. + +1997-11-07 SL Baur <steve@altair.xemacs.org> + + * prim/simple.el (universal-argument-minus): Retain zmacs region. + +1997-11-07 Hrvoje Niksic <hniksic@srce.hr> + + * packages/hyper-apropos.el (hyper-apropos-grok-functions): Ignore + errors when fetching documentation. + + * prim/about.el (about-maintainer-glyph): Handle not having XPM or + XBM gracefully. + + * custom/wid-edit.el (widget-glyph-find): Allow glyphs without + window-system, when TAG is nil. + +1997-11-05 Jens-Ulrik Holger Petersen <petersen@kurims.kyoto-u.ac.jp> + + * mule/mule-cmds.el (set-default-coding-systems): Make + add-hook to `comint-exec-hook' be an append, for when the user + changes language environment say. + +1997-11-05 SL Baur <steve@altair.xemacs.org> + + * prim/winnt.el: Use a cleaner method for getting Text/Binary file + type in the mode-line for MS Windows. + +1997-11-06 Hrvoje Niksic <hniksic@srce.hr> + + * prim/mouse.el: Removed "junk me" functions. + + * prim/mouse.el (default-mouse-motion-handler): Make events over + modeline invalidate `point'. + + * prim/mouse.el (mouse-line-length): Use point-at-eol and + point-at-bol. + (default-mouse-track-normalize-point): Highlight the whole symbol + only if the mouse is on a symbol-constituent. + + * custom/wid-edit.el (widget-specify-field): Make sure the extent + is end-open. + + * prim/keymap.el (next-key-event): Use `next-command-event'. + +1997-11-05 Hrvoje Niksic <hniksic@srce.hr> + + * utils/easymenu.el (easy-menu-add): Check with `equal' whether + the menu already belongs to all-popups. + +1997-11-05 Jan Vroonhof <vroonhof@math.ethz.ch> + + * packages/font-lock.el (font-lock-thing-lock-cleanup): + Provisionally add lazy-shot + + * modes/lazy-shot.el (lazy-shot-mode): Unstall lazy-shot only if + needed. + (lazy-shot-fontify-internal): Functionality put in seperate function. + (lazy-shot-lock-extent): Use it. + (lazy-shot-fontify-region): Dumb implementation added. + (lazy-shot-unstall-after-fontify): Needed to disable lazy + fontifying after fontify-buffer. + (lazy-shot-unstall): Make sure buffer is left in a fontified state if + needed. Take optional argument. + + + * packages/ps-print.el (ps-print-ensure-fontified): Added + temporary support for lazy-shot. + +1997-11-05 Hrvoje Niksic <hniksic@srce.hr> + + * utils/text-props.el (set-text-properties): Updated docstring. + +1997-11-04 Didier Verna <verna@inf.enst.fr> + + * mule/mule-cmds.el (set-default-coding-systems): + The coding-system argument to comint-exec-hook wasn't evaluated + before building the lambda expression. + +1997-11-04 Jens-Ulrik Holger Petersen <petersen@kurims.kyoto-u.ac.jp> + + * packages/time.el: Change all occurences of ballon to balloon. + +1997-11-04 Jens-Ulrik Holger Petersen <petersen@kurims.kyoto-u.ac.jp> + + * prim/help.el (function-at-point-function): Remove this variable. + (function-at-point): Remove use of `function-at-point-function'. + + * packages/info.el (Info-elisp-ref): Change call to + `find-function-function' to `function-at-point'. + +1997-11-04 Jens-Ulrik Holger Petersen <petersen@kurims.kyoto-u.ac.jp> + + * packages/info.el (Info-elisp-ref): Really change call to + `find-function-function' to `function-at-point'. + +1997-11-04 Hrvoje Niksic <hniksic@srce.hr> + + * packages/auto-save.el: Updated commentary; changed default + autosave fallback to "~/.autosave". Minor changes to compile + without warnings. + +1997-11-03 Hrvoje Niksic <hniksic@srce.hr> + + * prim/subr.el (function-interactive): New function. + +1997-11-03 SL Baur <steve@altair.xemacs.org> + + * prim/dumped-lisp.el: Dump auto-save with XEmacs. + + * prim/loadup.el: Make sure top level lisp directory gets a + trailing slash when added to load-path. + * prim/make-docfile.el: Ditto. + +1997-11-03 MORIOKA Tomohiko <morioka@jaist.ac.jp> + + * prim/simple.el (interprogram-cut-function, + interprogram-paste-function): New variable (imported from Emacs + 20.2). + (kill-new): Use `interprogram-cut-function' if it is not nil. + (current-kill): Use `interprogram-paste-function' if it is not + nil. + +1997-11-03 MORIOKA Tomohiko <morioka@jaist.ac.jp> + + * locale/ja/locale-start.el (startup-splash-frame-body): Modify to + be more natural Japanese. + + * x11/x-menubar.el: Delete "language environment" menu of + "Options" menu. + +1997-11-02 MORIOKA Tomohiko <morioka@jaist.ac.jp> + + * language/korean.el: Rename TUTORIAL.kr -> TUTORIAL.ko to fit + with ISO 639 (two letter language code). + + * prim/dumped-lisp.el: Don't dump language/vietnamese.el because + language/viet-util.el was removed temporary. + + * language/japanese.el: Rename TUTORIAL.jp -> TUTORIAL.ja to fit + with ISO 639 (two letter language code). + +1997-10-31 Pete Ware <ware@cis.ohio-state.edu> + + * shell.el (shell-chdrive-regexp): New for DOS/NT + (shell-mode): Added shell-font-lock-keywrods + (shell-mode): Use $PWD for ksh + (shell-directory-tracker): Use dirs and dirtrack-toggle. This may + cause problems at is interferes with "dired" + (shell-snarf-envar): NEW + (shell-copy-environment-variable): NEW + +1997-10-30 Pete Ware <ware@cis.ohio-state.edu> + + * comint.el (comint-mode-map): Rearranged menus so they have a + meaningful name. + +1997-10-30 Pete Ware <ware@cis.ohio-state.edu> + + * comint.el (comint-find-source-file-hook): + (comint-goto-source-line-hook): + (comint-find-source-code): + (comint-default-find-source-file): + (comint-fixup-source-file-name): + (comint-default-goto-source-line): Removed. compile.el does a + better job of this stuff. + + * comint.el + (comint-file-name-chars): Support for msdos/nt + - Let easymenu deal with whether menubar is available. + - Use ^d for delchar or maybe eof. + - Use "dumb" as the terminal type if on a system using terminfo + (comint-output-filter): Removed replacement of ^M -- use filter + (comint-dynamic-complete-as-filename): Don't set + file-name-handler-alist to nil. This makes remote path + completion work! + +1997-11-02 SL Baur <steve@altair.xemacs.org> + + * prim/advocacy.el (xemacs-praise-sound-file): Don't default to + using a hardcoded directory. + + * eterm/term.el (term-is-xemacs): Match against XEmacs instead of + Lucid. + + * eos/sun-eos-toolbar.el (eos::toolbar-icon-directory): Use + `locate-data-directory' instead of data-directory. + * eterm/term.el (term-exec-1): Ditto. + * packages/time.el (display-time-icons-dir): Ditto. + * prim/advocacy.el (praise-be-unto-xemacs): Ditto. + * prim/sound.el (default-sound-directory): Ditto. + * prim/toolbar.el (init-toolbar-location): Ditto. + +1997-10-31 Hrvoje Niksic <hniksic@srce.hr> + + * custom/wid-edit.el (widget-color-complete): Use + `read-color-completion-table' directly. + + * prim/subr.el (rplaca): Warn against the return value. + (replace-in-string): Use `wrong-type-argument'. Use standard + error message. + (functionp): Would bug out on certain types of objects; synch with + FSF. + (with-output-to-string): Use new-style backquotes. + (with-temp-buffer): Update docstring references. + + * prim/minibuf.el (reset-buffer): Use `with-current-buffer'. + (read-color-completion-table): Ditto. + (read-color-completion-table): Complete TTY colors on TTY devices. + + * custom/cus-start.el: Customize `scroll-conservatively'. + Customize `help-char' correctly. + +1997-11-02 SL Baur <steve@altair.xemacs.org> + + * packages/desktop.el (toplevel): Don't require dired or reporter + when byte compiling. + +1997-11-02 Hrvoje Niksic <hniksic@srce.hr> + + * prim/keymap.el (synthesize-keysym): Collect a list of + characters, instead of consing a string each time. + (synthesize-keysym): Better error checking. + + * prim/keymap.el (synthesize-keysym): Don't bug out when reading a + non-character event. + +1997-11-02 Tomasz Cholewo <tjchol01@mecca.spd.louisville.edu> + + * prim/keymap.el (synthesize-keysym): New function bound to C-x @ k. + +1997-11-02 Kyle Jones <kyle_jones@wonderworks.com> + + * modes/sendmail.el: Don't (require 'vm-misc). Change + mail-do-fcc-vm-internal to not compile the chunk of code + that uses VM internal macros. This prevents the byte + compiler from compiling such references into function + calls that Fbyte_code will complain about later when it + discovers that the references are macros. + + * modes/sendmail.el: added defvars for + rmail-summary-buffer and rmail-total-messages to get + rid of compiler warnings. +1997-11-01 Hrvoje Niksic <hniksic@srce.hr> + + * prim/subr.el (lambda): Moved from `packages.el'. + + * prim/packages.el: Updated commentary. + (packages-useful-lisp): Added `cl-macs'. + +1997-10-27 Didier Verna <verna@inf.enst.fr> + + * prim/help-nomule.el (help-with-tutorial): The 'didactic' blank + lines message is now taken directly from each tutorial, and thus + can appear in different languages. + + * mule/mule-help.el (help-with-tutorial): idem + +1997-10-26 Karl M. Hegbloom <karlheg@inetarena.com> + + * utils/shadowfile.el (shadow-clusters): Customized. + (shadow-read-files): replace obsolete `eval-current-buffer' + (shadow-parse-fullpath): `efs-ftp-name' doesn't exist. change to + `efs-ftp-path' + +1997-11-01 SL Baur <steve@altair.xemacs.org> + + * x11/x-menubar.el: Change Viper menu item to use + `toggle-viper-mode'. + Suggested by Michael Kifer <kifer@CS.SunySB.EDU> + + * mule/mule-init.el: Remove `help-with-tutorial-for-mule'. + Suggested by Didier Verna <verna@inf.enst.fr> + + * Disable Cyrillic CCL until CCL engine gets fixed. + From: Martin Buchholz <mrb@Eng.Sun.COM> + +1997-10-30 Colin Rafferty <craffert@ml.com> + + * prim/startup.el (command-line-early): Made it recognize + --vanilla and --no-packages, as is already done in emacs.c. + +1997-10-30 Karl M. Hegbloom <karlheg@inetarena.com> + + * modes/cperl-mode.el: Add Commentary and Code statements to + comment header for finder. + 1997-10-30 SL Baur <steve@altair.xemacs.org> * vm/vm-vars.el (vm-image-directory): Use locate-data-directory if
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/abbrev.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,535 @@ +;;; abbrev.el --- abbrev mode commands for Emacs + +;; Copyright (C) 1985, 1986, 1987, 1992, 1997 Free Software Foundation, Inc. + +;; Maintainer: XEmacs Development Team +;; Keywords: abbrev, dumped + +;; 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.34 (With some additions) + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;; This facility is documented in the Emacs Manual. + +;;; Code: + +;jwz: this is preloaded so don't ;;;###autoload +(defcustom only-global-abbrevs nil "\ +*Non-nil means user plans to use global abbrevs only. +Makes the commands to define mode-specific abbrevs define global ones instead." + :type 'boolean + :group 'abbrev) + +;;; XEmacs: the following block of code is not in FSF +(defvar abbrev-table-name-list '() + "List of symbols whose values are abbrev tables.") + +(defvar abbrevs-changed nil + "Set non-nil by defining or altering any word abbrevs. +This causes `save-some-buffers' to offer to save the abbrevs.") + +(defun make-abbrev-table () + "Create a new, empty abbrev table object." + (make-vector 59 0)) ; 59 is prime + +(defun clear-abbrev-table (table) + "Undefine all abbrevs in abbrev table TABLE, leaving it empty." + (fillarray table 0) + (setq abbrevs-changed t) + nil) + + +(defun define-abbrev-table (name defs) + "Define TABNAME (a symbol) as an abbrev table name. +Define abbrevs in it according to DEFINITIONS, which is a list of elements +of the form (ABBREVNAME EXPANSION HOOK USECOUNT)." + (let ((table (and (boundp name) (symbol-value name)))) + (cond ((vectorp table)) + ((not table) + (setq table (make-abbrev-table)) + (set name table) + (setq abbrev-table-name-list (cons name abbrev-table-name-list))) + (t + (setq table (signal 'wrong-type-argument (list 'vectorp table))) + (set name table))) + (while defs + (apply (function define-abbrev) table (car defs)) + (setq defs (cdr defs))))) + +(defun define-abbrev (table name &optional expansion hook count) + "Define an abbrev in TABLE named NAME, to expand to EXPANSION or call HOOK. +NAME and EXPANSION are strings. Hook is a function or `nil'. +To undefine an abbrev, define it with an expansion of `nil'." + (or (not expansion) + (stringp expansion) + (setq expansion (signal 'wrong-type-argument + (list 'stringp expansion)))) + (or (not count) + (integerp count) + (setq count (signal 'wrong-type-argument + (list 'fixnump count)))) + (or (vectorp table) + (setq table (signal 'wrong-type-argument + (list 'vectorp table)))) + (let* ((sym (intern name table)) + (oexp (and (boundp sym) (symbol-value sym))) + (ohook (and (fboundp sym) (symbol-function sym)))) + (unless (and (equal ohook hook) + (stringp oexp) + (stringp expansion) + (string-equal oexp expansion)) + (setq abbrevs-changed t) + ;; If there is a non-word character in the string, set the flag. + (if (string-match "\\W" name) + (set (intern " " table) nil))) + (set sym expansion) + (fset sym hook) + (setplist sym (or count 0)) + name)) + + +;; Fixup stuff from bootstrap def of define-abbrev-table in subr.el +(let ((l abbrev-table-name-list)) + (while l + (let ((fixup (car l))) + (if (consp fixup) + (progn + (setq abbrev-table-name-list (delq fixup abbrev-table-name-list)) + (define-abbrev-table (car fixup) (cdr fixup)))) + (setq l (cdr l)))) + ;; These are no longer initialised by C code + (if (not global-abbrev-table) + (progn + (setq global-abbrev-table (make-abbrev-table)) + (setq abbrev-table-name-list (cons 'global-abbrev-table + abbrev-table-name-list)))) + (if (not fundamental-mode-abbrev-table) + (progn + (setq fundamental-mode-abbrev-table (make-abbrev-table)) + (setq abbrev-table-name-list (cons 'fundamental-mode-abbrev-table + abbrev-table-name-list)))) + (and (eq major-mode 'fundamental-mode) + (not local-abbrev-table) + (setq local-abbrev-table fundamental-mode-abbrev-table))) + + +(defun define-global-abbrev (name expansion) + "Define ABBREV as a global abbreviation for EXPANSION." + (interactive "sDefine global abbrev: \nsExpansion for %s: ") + (define-abbrev global-abbrev-table + (downcase name) expansion nil 0)) + +(defun define-mode-abbrev (name expansion) + "Define ABBREV as a mode-specific abbreviation for EXPANSION." + (interactive "sDefine mode abbrev: \nsExpansion for %s: ") + (define-abbrev (or local-abbrev-table + (error "Major mode has no abbrev table")) + (downcase name) expansion nil 0)) + +(defun abbrev-symbol (abbrev &optional table) + "Return the symbol representing abbrev named ABBREV. +This symbol's name is ABBREV, but it is not the canonical symbol of that name; +it is interned in an abbrev-table rather than the normal obarray. +The value is nil if that abbrev is not defined. +Optional second arg TABLE is abbrev table to look it up in. +The default is to try buffer's mode-specific abbrev table, then global table." + (let ((frob (function (lambda (table) + (let ((sym (intern-soft abbrev table))) + (if (and (boundp sym) + (stringp (symbol-value sym))) + sym + nil)))))) + (if table + (funcall frob table) + (or (and local-abbrev-table + (funcall frob local-abbrev-table)) + (funcall frob global-abbrev-table))))) + +(defun abbrev-expansion (abbrev &optional table) + "Return the string that ABBREV expands into in the current buffer. +Optionally specify an abbrev table as second arg; +then ABBREV is looked up in that table only." + (let ((sym (abbrev-symbol abbrev table))) + (if sym + (symbol-value sym) + nil))) + +(defun unexpand-abbrev () + "Undo the expansion of the last abbrev that expanded. +This differs from ordinary undo in that other editing done since then +is not undone." + (interactive) + (if (or (< last-abbrev-location (point-min)) + (> last-abbrev-location (point-max)) + (not (stringp last-abbrev-text))) + nil + (let* ((opoint (point)) + (val (symbol-value last-abbrev)) + (adjust (length val))) + ;; This isn't correct if (symbol-function last-abbrev-text) + ;; was used to do the expansion + (goto-char last-abbrev-location) + (delete-region last-abbrev-location (+ last-abbrev-location adjust)) + (insert last-abbrev-text) + (setq adjust (- adjust (length last-abbrev-text))) + (setq last-abbrev-text nil) + (if (< last-abbrev-location opoint) + (goto-char (- opoint adjust)) + (goto-char opoint))))) + + + +(defun insert-abbrev-table-description (name human-readable) + "Insert before point a full description of abbrev table named NAME. +NAME is a symbol whose value is an abbrev table. +If optional 2nd arg HUMAN is non-nil, insert a human-readable description. +Otherwise the description is an expression, +a call to `define-abbrev-table', which would +define the abbrev table NAME exactly as it is currently defined." + (let ((table (symbol-value name)) + (stream (current-buffer))) + (message "Abbrev-table %s..." name) + (if human-readable + (progn + (prin1 (list name) stream) + ;; Need two terpri's or cretinous edit-abbrevs blows out + (terpri stream) + (terpri stream) + (mapatoms (function (lambda (sym) + (if (symbol-value sym) + (let* ((n (prin1-to-string (symbol-name sym))) + (pos (length n))) + (princ n stream) + (while (< pos 14) + (write-char ?\ stream) + (setq pos (1+ pos))) + (princ (format " %-5S " (symbol-plist sym)) + stream) + (if (not (symbol-function sym)) + (prin1 (symbol-value sym) stream) + (progn + (setq n (prin1-to-string (symbol-value sym)) + pos (+ pos 6 (length n))) + (princ n stream) + (while (< pos 45) + (write-char ?\ stream) + (setq pos (1+ pos))) + (prin1 (symbol-function sym) stream))) + (terpri stream))))) + table) + (terpri stream)) + (progn + (princ "\(define-abbrev-table '" stream) + (prin1 name stream) + (princ " '\(\n" stream) + (mapatoms (function (lambda (sym) + (if (symbol-value sym) + (progn + (princ " " stream) + (prin1 (list (symbol-name sym) + (symbol-value sym) + (symbol-function sym) + (symbol-plist sym)) + stream) + (terpri stream))))) + table) + (princ " \)\)\n" stream))) + (terpri stream)) + (message "")) +;;; End code not in FSF + +(defun abbrev-mode (arg) + "Toggle abbrev mode. +With argument ARG, turn abbrev mode on iff ARG is positive. +In abbrev mode, inserting an abbreviation causes it to expand +and be replaced by its expansion." + (interactive "P") + (setq abbrev-mode + (if (null arg) (not abbrev-mode) + (> (prefix-numeric-value arg) 0))) + ;; XEmacs change + (redraw-modeline)) + + +(defvar edit-abbrevs-map nil + "Keymap used in edit-abbrevs.") +(if edit-abbrevs-map + nil + (setq edit-abbrevs-map (make-sparse-keymap)) + ;; XEmacs change + (set-keymap-name edit-abbrevs-map 'edit-abbrevs-map) + (define-key edit-abbrevs-map "\C-x\C-s" 'edit-abbrevs-redefine) + (define-key edit-abbrevs-map "\C-c\C-c" 'edit-abbrevs-redefine)) + +(defun kill-all-abbrevs () + "Undefine all defined abbrevs." + (interactive) + (let ((tables abbrev-table-name-list)) + (while tables + (clear-abbrev-table (symbol-value (car tables))) + (setq tables (cdr tables))))) + +(defun insert-abbrevs () + "Insert after point a description of all defined abbrevs. +Mark is set after the inserted text." + (interactive) + (push-mark + (save-excursion + (let ((tables abbrev-table-name-list)) + (while tables + (insert-abbrev-table-description (car tables) t) + (setq tables (cdr tables)))) + (point)))) + +(defun list-abbrevs () + "Display a list of all defined abbrevs." + (interactive) + (display-buffer (prepare-abbrev-list-buffer))) + +(defun prepare-abbrev-list-buffer () + (save-excursion + (set-buffer (get-buffer-create "*Abbrevs*")) + (erase-buffer) + (let ((tables abbrev-table-name-list)) + (while tables + (insert-abbrev-table-description (car tables) t) + (setq tables (cdr tables)))) + (goto-char (point-min)) + (set-buffer-modified-p nil) + (edit-abbrevs-mode)) + (get-buffer-create "*Abbrevs*")) + +(defun edit-abbrevs-mode () + "Major mode for editing the list of abbrev definitions. +\\{edit-abbrevs-map}" + (interactive) + (setq major-mode 'edit-abbrevs-mode) + (setq mode-name "Edit-Abbrevs") + (use-local-map edit-abbrevs-map)) + +(defun edit-abbrevs () + "Alter abbrev definitions by editing a list of them. +Selects a buffer containing a list of abbrev definitions. +You can edit them and type \\<edit-abbrevs-map>\\[edit-abbrevs-redefine] to redefine abbrevs +according to your editing. +Buffer contains a header line for each abbrev table, + which is the abbrev table name in parentheses. +This is followed by one line per abbrev in that table: +NAME USECOUNT EXPANSION HOOK +where NAME and EXPANSION are strings with quotes, +USECOUNT is an integer, and HOOK is any valid function +or may be omitted (it is usually omitted)." + (interactive) + (switch-to-buffer (prepare-abbrev-list-buffer))) + +(defun edit-abbrevs-redefine () + "Redefine abbrevs according to current buffer contents." + (interactive) + (define-abbrevs t) + (set-buffer-modified-p nil)) + +(defun define-abbrevs (&optional arg) + "Define abbrevs according to current visible buffer contents. +See documentation of `edit-abbrevs' for info on the format of the +text you must have in the buffer. +With argument, eliminate all abbrev definitions except +the ones defined from the buffer now." + (interactive "P") + (if arg (kill-all-abbrevs)) + (save-excursion + (goto-char (point-min)) + (while (and (not (eobp)) (re-search-forward "^(" nil t)) + (let* ((buf (current-buffer)) + (table (read buf)) + abbrevs name hook exp count) + (forward-line 1) + (while (progn (forward-line 1) + (not (eolp))) + (setq name (read buf) count (read buf) exp (read buf)) + (skip-chars-backward " \t\n\f") + (setq hook (if (not (eolp)) (read buf))) + (skip-chars-backward " \t\n\f") + (setq abbrevs (cons (list name exp hook count) abbrevs))) + (define-abbrev-table table abbrevs))))) + +(defun read-abbrev-file (&optional file quietly) + "Read abbrev definitions from file written with `write-abbrev-file'. +Optional argument FILE is the name of the file to read; +it defaults to the value of `abbrev-file-name'. +Optional second argument QUIETLY non-nil means don't print anything." + (interactive "fRead abbrev file: ") + (load (if (and file (> (length file) 0)) file abbrev-file-name) + nil quietly) + (setq save-abbrevs t abbrevs-changed nil)) + +(defun quietly-read-abbrev-file (&optional file) + "Read abbrev definitions from file written with write-abbrev-file. +Optional argument FILE is the name of the file to read; +it defaults to the value of `abbrev-file-name'. +Does not print anything." + ;(interactive "fRead abbrev file: ") + (read-abbrev-file file t)) + +(defun write-abbrev-file (file) + "Write all abbrev definitions to a file of Lisp code. +The file written can be loaded in another session to define the same abbrevs. +The argument FILE is the file name to write." + (interactive + (list + (read-file-name "Write abbrev file: " + (file-name-directory (expand-file-name abbrev-file-name)) + abbrev-file-name))) + (or (and file (> (length file) 0)) + (setq file abbrev-file-name)) + (save-excursion + (set-buffer (get-buffer-create " write-abbrev-file")) + (erase-buffer) + (let ((tables abbrev-table-name-list)) + (while tables + (insert-abbrev-table-description (car tables) nil) + (setq tables (cdr tables)))) + (write-region 1 (point-max) file) + (erase-buffer))) + +(defun add-mode-abbrev (arg) + "Define mode-specific abbrev for last word(s) before point. +Argument is how many words before point form the expansion; +or zero means the region is the expansion. +A negative argument means to undefine the specified abbrev. +Reads the abbreviation in the minibuffer. + +Don't use this function in a Lisp program; use `define-abbrev' instead." + ;; XEmacs change: + (interactive "P") + (add-abbrev + (if only-global-abbrevs + global-abbrev-table + (or local-abbrev-table + (error "No per-mode abbrev table"))) + "Mode" arg)) + +(defun add-global-abbrev (arg) + "Define global (all modes) abbrev for last word(s) before point. +The prefix argument specifies the number of words before point that form the +expansion; or zero means the region is the expansion. +A negative argument means to undefine the specified abbrev. +This command uses the minibuffer to read the abbreviation. + +Don't use this function in a Lisp program; use `define-abbrev' instead." + ;; XEmacs change: + (interactive "P") + (add-abbrev global-abbrev-table "Global" arg)) + +(defun add-abbrev (table type arg) + ;; XEmacs change: + (if (and (not arg) (region-active-p)) (setq arg 0) + (setq arg (prefix-numeric-value arg))) + (let ((exp (and (>= arg 0) + (buffer-substring + (point) + (if (= arg 0) (mark) + (save-excursion (forward-word (- arg)) (point)))))) + name) + (setq name + (read-string (format (if exp "%s abbrev for \"%s\": " + "Undefine %s abbrev: ") + type exp))) + (set-text-properties 0 (length name) nil name) + (if (or (null exp) + (not (abbrev-expansion name table)) + (y-or-n-p (format "%s expands to \"%s\"; redefine? " + name (abbrev-expansion name table)))) + (define-abbrev table (downcase name) exp)))) + +(defun inverse-add-mode-abbrev (arg) + "Define last word before point as a mode-specific abbrev. +With prefix argument N, defines the Nth word before point. +This command uses the minibuffer to read the expansion. +Expands the abbreviation after defining it." + (interactive "p") + (inverse-add-abbrev + (if only-global-abbrevs + global-abbrev-table + (or local-abbrev-table + (error "No per-mode abbrev table"))) + "Mode" arg)) + +(defun inverse-add-global-abbrev (arg) + "Define last word before point as a global (mode-independent) abbrev. +With prefix argument N, defines the Nth word before point. +This command uses the minibuffer to read the expansion. +Expands the abbreviation after defining it." + (interactive "p") + (inverse-add-abbrev global-abbrev-table "Global" arg)) + +(defun inverse-add-abbrev (table type arg) + (let (name nameloc exp) + (save-excursion + (forward-word (- arg)) + (setq name (buffer-substring (point) (progn (forward-word 1) + (setq nameloc (point)))))) + (set-text-properties 0 (length name) nil name) + (setq exp (read-string (format "%s expansion for \"%s\": " + type name))) + (if (or (not (abbrev-expansion name table)) + (y-or-n-p (format "%s expands to \"%s\"; redefine? " + name (abbrev-expansion name table)))) + (progn + (define-abbrev table (downcase name) exp) + (save-excursion + (goto-char nameloc) + (expand-abbrev)))))) + +(defun abbrev-prefix-mark (&optional arg) + "Mark current point as the beginning of an abbrev. +Abbrev to be expanded starts here rather than at beginning of word. +This way, you can expand an abbrev with a prefix: insert the prefix, +use this command, then insert the abbrev." + (interactive "P") + (or arg (expand-abbrev)) + (setq abbrev-start-location (point-marker) + abbrev-start-location-buffer (current-buffer)) + (let ((e (make-extent (point) (point)))) + (set-extent-begin-glyph e (make-glyph [string :data "-"])))) + +(defun expand-region-abbrevs (start end &optional noquery) + "For abbrev occurrence in the region, offer to expand it. +The user is asked to type y or n for each occurrence. +A prefix argument means don't query; expand all abbrevs. +If called from a Lisp program, arguments are START END &optional NOQUERY." + (interactive "r\nP") + (save-excursion + (goto-char start) + (let ((lim (- (point-max) end)) + pnt string) + (while (and (not (eobp)) + (progn (forward-word 1) + (<= (setq pnt (point)) (- (point-max) lim)))) + (if (abbrev-expansion + (setq string + (buffer-substring + (save-excursion (forward-word -1) (point)) + pnt))) + (if (or noquery (y-or-n-p (format "Expand `%s'? " string))) + (expand-abbrev))))))) + +;;; abbrev.el ends here
--- a/lisp/apel/ChangeLog Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,166 +0,0 @@ -1997-07-14 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu: Version 7.44 was released. - * APEL: Version 3.4 was released. - -1997-07-13 MORIOKA Tomohiko <morioka@mousai> - - * std11-parse.el (std11-parse-ascii-token): Allow non-ASCII - characters in comments. - -1997-06-28 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * file-detect.el: Add autoload comments for function `add-path', - `add-latest-path', `get-latest-path', `file-installed-p', - `exec-installed-p', `module-installed-p' and variable - `exec-suffix-list'. - -Sat May 10 19:39:12 1997 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * README.en (What's APEL?): Add std11 and mule-caesar.el. - - -1997-05-09 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu: Version 7.43.1 was released. - * APEL: Version 3.3.2 was released. - -Fri May 9 01:23:44 1997 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * APEL-ELS: Add mule-caesar.el. - - * mule-caesar.el: New file. - - -1997-04-30 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu: Version 7.43 was released. - * APEL: Version 3.3.1 was released. - -Wed Apr 30 12:40:32 1997 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * Makefile: add `release'. - -Mon Apr 28 16:47:30 1997 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * Makefile: `TARFILE' was abolished. - -Thu Apr 3 17:14:39 1997 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * APEL-ELS: std11.el and std11-parse.el were moved from mu/. - - -1997-03-20 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * APEL: Version 3.3 was released. - - * APEL-CFG (EMU_PREFIX, EMU_DIR): New variables. - * APEL-MK: install emu. - -Thu Mar 20 06:09:03 1997 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * Makefile: Add README.en. - -Thu Mar 20 06:08:29 1997 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * file-detect.el: Header and DOC-strings were modified. - -Thu Mar 20 06:03:51 1997 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * README.en: New file. - -Thu Mar 20 05:48:02 1997 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * filename.el: Add DOC-strings. - - * APEL-MK (install-apel): Use `compile-apel'. - - * Makefile (install): Don't depend on `elc'. - -Thu Mar 20 02:04:19 1997 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * APEL-MK: Setting for load-path and requiring install were moved - from APEL-CFG. - - (install-apel): Compile apel-modules. - - * APEL-CFG: Setting for load-path and requiring install were moved - to APEL-MK. - - -1997-03-14 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * APEL: Version 3.2 was released. - -Fri Mar 14 09:54:04 1997 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * file-detect.el (get-latest-path): Check directory is exist or not. - -Fri Mar 14 09:25:15 1997 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * APEL-ELS: Add install.el. - -Fri Mar 14 07:24:37 1997 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * Makefile, APEL-MK, APEL-CFG: New file. - -1997-03-10 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * atype.el (field-unify): fixed. - -1997-03-10 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * filename.el (filename-filters): Use `exec-installed-p' instead - of `file-installed-p' to search "kakasi". - -1997-03-10 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * file-detect.el (module-installed-p): Use function - `exec-installed-p'. - - * file-detect.el (exec-suffix-list): New variable. - (exec-installed-p): New function. - -1997-03-04 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * APEL-ELS (apel-modules): Add filename.el. - - * APEL-ELS: Initial revision - -1997-03-04 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * filename.el (filename-replacement-alist): Don't use function - `string-to-char-list' and `expand-char-ranges'; Don't require - tl-str. - (filename-special-filter): Use function `assoc-if' instead of - `ASSOC'; Require cl instead of tl-list. - (poly-funcall): New inline-function; copied from tl-list.el. - -1997-03-03 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * atype.el: Alias `fetch-field', `fetch-field-value', `put-field' - and `delete-field' were abolished. - - Don't require tl-str and tl-list. - - Require alist. - - (field-unify): Don't use function `symbol-concat'. - (assoc-unify): Use function `assoc' directly; use function - `put-alist' directly; use function `del-alist' directly. - - * atype.el: Function `put-fields' was abolished. - - * atype.el: tl-atype.el was renamed to atype.el. - -1997-03-03 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * atype.el: tl-atype.el was renamed to atype.el. - -1997-03-03 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * file-detect.el (file-installed-p): Fixed DOC-string. - -1997-02-28 Tomohiko Morioka <tmorioka@mule.etl.go.jp> - - * alist.el: New module; separated from tl-list.el.
--- a/lisp/apel/ChangeLog.emu Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,352 +0,0 @@ -1997-08-25 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu-x20.el (mime-charset-coding-system-alist): iso-2022-jp-2 is - defined as coding-system. - - -1997-07-14 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu: Version 7.44 was released. - -1997-07-13 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu-e20.el (mime-charset-coding-system-alist): `iso-2022-ss2-7' - -> `iso-2022-7bit-ss2'. (for Emacs 20.0.90) - -1997-06-28 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * richtext.el: Add autoload comments for `richtext-encode' and - `richtext-decode'. - - * emu.el: Check richtext.el is bundled. - -1997-06-08 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu-x20.el (mime-charset-coding-system-alist): iso-8859-1, - hz-gb-2312, cn-gb-2312, gb2312, cn-big5 and koi8-r were defined as - coding-system. - - * emu-x20.el: Don't require cyrillic. - -Thu May 22 04:46:57 1997 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu-mule.el (make-char): New alias. - - * emu-e20.el: Alias `make-character' was abolished. - - -1997-05-09 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu: Version 7.43.1 was released. - -Thu May 8 22:21:36 1997 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu-x20.el: Use `binary' instead of `no-conversion' temporary. - - -1997-04-30 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu: Version 7.43 was released. - - * emu-x20.el: several changes for XEmacs 20.1-b12. - -Tue Apr 8 09:47:40 1997 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu.el (point-at-eol): New function. - -Sat Apr 5 16:23:23 1997 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu-nemacs.el: `tl:available-face-attribute-alist' -> - `emu:available-face-attribute-alist'. - - * emu-nemacs.el, emu-mule.el: `tl:make-overlay' -> `make-overlay'; - `tl:overlay-put' -> `overlay-put'. - -Sat Apr 5 06:50:48 1997 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu-xemacs.el: Alias `tl:make-overlay', `tl:overlay-put' and - `tl:overlay-buffer' were abolished; Function `tl:move-overlay' - were abolished. - - * emu-19.el: Alias `tl:make-overlay', `tl:overlay-put' and - `tl:overlay-buffer' were abolished. - - * emu-18.el: `tl:overlay-buffer' -> `overlay-buffer'. - - * emu-xemacs.el: Require overlay. - - * emu.el (char-or-char-int-p): New XEmacs 20 emulating alias. - - * emu.el (minibuffer-prompt-width): New function for Emacs 18 and - XEmacs. - - -1997-03-14 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu: Version 7.40.1 was released. - -Fri Mar 14 07:19:59 1997 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * Makefile, EMU-MK: New file. - - * EMU-ELS: rearrangement. - - * EMU-CFG: New file - -Wed Mar 12 14:18:27 1997 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu-x20.el: Modified for changing XEmacs/mule API about - `file-coding-system' -> `buffer-file-coding-system'. - - -1997-03-10 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu: Version 7.40 was released. - - * emu-x20.el (as-binary-process, as-binary-output-file): Use - `coding-system-for-write' instead of `file-coding-system'. - - (as-binary-input-file, insert-binary-file-contents-literally): Use - `coding-system-for-read' instead of `file-coding-system-for-read'. - - * emu-e20.el (mime-charset-coding-system-alist): Delete - `iso-2022-int-1' and `shift_jis'. - -1997-03-06 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu.el (defmacro-maybe): New macro. - (save-selected-window): Use `defmacro-maybe'. - - * emu-18.el (defsubst): New macro. - -1997-03-06 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu-x20.el: Constant `*ctext*', `*hz*', `*big5', `*euc-kr*' and - `*koi8*' were abolished. - -1997-03-06 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu-19.el: Alias `tl:add-text-properties' was abolished. - - * emu-18.el, emu-xemacs.el: Function `tl:add-text-properties' was - abolished. - -1997-03-06 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu.el (buffer-substring-no-properties): Use - `set-text-properties' instead of `tl:set-text-properties'. - - * emu-19.el: Alias `tl:set-text-properties' was abolished. - - * emu-18.el, emu-xemacs.el: Function `tl:set-text-properties' was - abolished. - -1997-03-04 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu-19.el (find-face): New function. - - -1997-03-03 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu: Version 7.38.1 was released. - -1997-03-03 Oscar Figueiredo <Oscar.Figueiredo@di.epfl.ch> - - * emu-xemacs.el (tl:add-text-properties): In tm-ew-d.el, the - function mime/decode-encoded-word calls tl:add-text-properties - with 4 parameters while it is defined in emu-xemacs.el to take 3 - parameters only. (cf. [bug-tm-en:1246]) - - -1997-02-13 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu: Version 7.38 was released. - - * emu.el: Function `insert-binary-file-contents-literally' was - moved to emu-{nemacs|e19|mule|x20|e20}.el. - - * emu-x20.el, emu-e20.el, emu-mule.el, emu-e19.el, emu-nemacs.el - (insert-binary-file-contents-literally): New function; moved from - emu.el. - - -1997-02-12 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu: Version 7.37.7 was released. - -1997-02-12 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu-x20.el: Variable `xemacs-beta-version' was abolished. - -1997-02-12 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu-x20.el (as-binary-process): Variable `file-coding-system' is - effective for `call-process-region'. - - -1997-01-31 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu: Version 7.37.6 was released. - -Thu Jan 30 16:55:00 1997 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * richtext.el (richtext-decode): Variable - `enriched-fill-after-visiting' is not found in enriched.el bundled - in Emacs 19.34.91-delta. - - -1997-01-30 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu: Version 7.37.5 was released. - -Wed Jan 29 15:48:26 1997 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu-x20.el, emu-e20.el, emu-e19.el, emu-mule.el, emu-nemacs.el - (as-binary-output-file): New macro. - -Mon Jan 27 12:11:32 1997 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu-e20.el (mime-charset-coding-system-alist): Modified for GNU - MULE 19.34.91-delta. - (mime-charset-to-coding-system): Modified for GNU MULE - 19.34.91-delta. - - -1997-01-21 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu: Version 7.37.4 was released. - -Sat Jan 18 09:44:43 1997 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu-x20.el (charsets-mime-charset-alist): Sync with emu-e20.el - 7.9. - (default-mime-charset): Default was changed to `x-ctext'. - (mime-charset-coding-system-alist): Add `x-ctext', `hz-gb-2312', - `cn-gb-2312' and `cn-big5'; `x-iso-2022-jp-2' and `x-shiftjis' was - abolished. - -Sat Jan 18 09:35:35 1997 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu-e20.el: Function `regulate-latin-char' and - `regulate-latin-string' were abolished. - - * emu-e20.el (sset): Function `string-embed-string' was renamed to - `store-substring'. - -Wed Jan 15 18:01:13 1997 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu-e20.el (fontset-pixel-size): modified for GNU MULE 19.34.91. - -Wed Jan 15 16:42:47 1997 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu-e20.el: Alias `charset-columns' was abolished. - Function `charset-iso-class' was abolished. - - * emu-e20.el: for GNU MULE 19.34.91. - -Tue Jan 14 06:35:53 1997 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu-x20.el: Alias `charset-description', `find-charset-string', - `find-charset-region', `char-width', `string-width' and `sref' has - been defined in XEmacs/mule. - - Function `find-non-ascii-charset-string', - `find-non-ascii-charset-region', `char-bytes', `char-length', - `char-columns', `string-columns' and `truncate-string' has been - defined in XEmacs/mule. - - -Mon Dec 23 14:56:40 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu: Version 7.37.3 was released. - -Wed Dec 18 13:12:15 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu-e20.el (as-binary-process): Fixed. - - -Mon Dec 16 14:57:02 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu: Version 7.37.2 was released. - -Thu Dec 12 02:29:18 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu-e20.el: Header was modified. - - -Tue Dec 10 14:41:46 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu: Version 7.37.1 was released. - - * emu-e19.el: `charset-latin-1' -> `charset-latin-iso8859-1'. - - * emu-e19.el: Constants to emulate MULE 2.3 leading-char were - abolished. - (find-charset-string, find-charset-region): Use constant - `charset-latin-1' instead of `lc-ltn1'. - -Sat Dec 7 06:07:15 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu-x20.el: Constants to emulate MULE 2.3 leading-char were - abolished. - - * emu-x20.el: Sync with patch about charset naming rule - (cf. [xemacs-beta:91]) - -Thu Dec 5 15:15:39 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu-x20.el: Sync with XEmacs 20.0 b30. - - -Wed Dec 4 04:55:36 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu: Version 7.37 was released. - -Fri Nov 29 21:22:25 1996 Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp> - - * emu.el (match-string): New function for Emacs 19.28 or earlier. - -Thu Nov 28 19:25:12 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * richtext.el (richtext-decode): Unused local variable `nc' was - abolished. - - * richtext.el (richtext-decode): Unused local variable `pc' was - abolished. - -Thu Nov 28 19:16:18 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu.el (defun-maybe): New macro. - (buffer-substring-no-properties, add-to-list, buffer-live-p, - functionp): Use macro `defun-maybe' instead of `sysdep-defun'. - - * emu-xemacs.el: Don't use sysdep.el. - - * emu-18.el, emu-19.el: Function `sysdep-defun' was abolished. - -Thu Nov 28 18:02:42 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu.el (buffer-substring-no-properties, add-to-list, - buffer-live-p, functionp): Use `sysdep-defun'. - -Thu Nov 28 17:59:45 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu-xemacs.el: Use sysdep.el. - - * emu-19.el, emu-18.el (sysdep-defun): New macro. - -Wed Nov 27 13:40:42 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu-e20.el (fontset-pixel-size): Renamed from - `fontset-pixel-height'. - - -Sat Nov 16 08:37:04 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu: Version 7.34 was released. - -Fri Nov 15 13:59:53 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * emu-xemacs.el: Redefine `file-relative-name' if it is broken. - - * EMU-ELS: New file.
--- a/lisp/apel/alist.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,101 +0,0 @@ -;;; alist.el --- utility functions about assoc-list - -;; Copyright (C) 1993,1994,1995,1996 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Version: -;; $Id: alist.el,v 1.1 1997/06/03 04:18:34 steve Exp $ -;; Keywords: alist - -;; This file is part of SEMI (SEMI is Emacs MIME Interfaces). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(defun put-alist (item value alist) - "Modify ALIST to set VALUE to ITEM. -If there is a pair whose car is ITEM, replace its cdr by VALUE. -If there is not such pair, create new pair (ITEM . VALUE) and -return new alist whose car is the new pair and cdr is ALIST. -\[tomo's ELIS like function]" - (let ((pair (assoc item alist))) - (if pair - (progn - (setcdr pair value) - alist) - (cons (cons item value) alist) - ))) - -(defun del-alist (item alist) - "If there is a pair whose key is ITEM, delete it from ALIST. -\[tomo's ELIS emulating function]" - (if (equal item (car (car alist))) - (cdr alist) - (let ((pr alist) - (r (cdr alist)) - ) - (catch 'tag - (while (not (null r)) - (if (equal item (car (car r))) - (progn - (rplacd pr (cdr r)) - (throw 'tag alist))) - (setq pr r) - (setq r (cdr r)) - ) - alist)))) - -(defun set-alist (symbol item value) - "Modify a alist indicated by SYMBOL to set VALUE to ITEM." - (or (boundp symbol) - (set symbol nil) - ) - (set symbol (put-alist item value (symbol-value symbol))) - ) - -(defun remove-alist (symbol item) - "Remove ITEM from the alist indicated by SYMBOL." - (and (boundp symbol) - (set symbol (del-alist item (symbol-value symbol))) - )) - -(defun modify-alist (modifier default) - "Modify alist DEFAULT into alist MODIFIER." - (mapcar (function - (lambda (as) - (setq default (put-alist (car as)(cdr as) default)) - )) - modifier) - default) - -(defun set-modified-alist (sym modifier) - "Modify a value of a symbol SYM into alist MODIFIER. -The symbol SYM should be alist. If it is not bound, -its value regard as nil." - (if (not (boundp sym)) - (set sym nil) - ) - (set sym (modify-alist modifier (eval sym))) - ) - - -;;; @ end -;;; - -(provide 'alist) - -;;; alist.el ends here
--- a/lisp/apel/atype.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,189 +0,0 @@ -;;; atype.el --- atype functions - -;; Copyright (C) 1994,1995,1996,1997 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Version: $Id: atype.el,v 1.1 1997/06/03 04:18:34 steve Exp $ -;; Keywords: atype - -;; This file is part of APEL (A Portable Emacs Library). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'emu) -(require 'alist) - - -;;; @ field unifier -;;; - -(defun field-unifier-for-default (a b) - (let ((ret - (cond ((equal a b) a) - ((null (cdr b)) a) - ((null (cdr a)) b) - ))) - (if ret - (list nil ret nil) - ))) - -(defun field-unify (a b) - (let ((f - (let ((type (car a))) - (and (symbolp type) - (intern (concat "field-unifier-for-" (symbol-name type))) - )))) - (or (fboundp f) - (setq f (function field-unifier-for-default)) - ) - (funcall f a b) - )) - - -;;; @ type unifier -;;; - -(defun assoc-unify (class instance) - (catch 'tag - (let ((cla (copy-alist class)) - (ins (copy-alist instance)) - (r class) - cell aret ret prev rest) - (while r - (setq cell (car r)) - (setq aret (assoc (car cell) ins)) - (if aret - (if (setq ret (field-unify cell aret)) - (progn - (if (car ret) - (setq prev (put-alist (car (car ret)) - (cdr (car ret)) - prev)) - ) - (if (nth 2 ret) - (setq rest (put-alist (car (nth 2 ret)) - (cdr (nth 2 ret)) - rest)) - ) - (setq cla (put-alist (car cell)(cdr (nth 1 ret)) cla)) - (setq ins (del-alist (car cell) ins)) - ) - (throw 'tag nil) - )) - (setq r (cdr r)) - ) - (setq r (copy-alist ins)) - (while r - (setq cell (car r)) - (setq aret (assoc (car cell) cla)) - (if aret - (if (setq ret (field-unify cell aret)) - (progn - (if (car ret) - (setq prev (put-alist (car (car ret)) - (cdr (car ret)) - prev)) - ) - (if (nth 2 ret) - (setq rest (put-alist (car (nth 2 ret)) - (cdr (nth 2 ret)) - rest)) - ) - (setq cla (del-alist (car cell) cla)) - (setq ins (put-alist (car cell)(cdr (nth 1 ret)) ins)) - ) - (throw 'tag nil) - )) - (setq r (cdr r)) - ) - (list prev (append cla ins) rest) - ))) - -(defun get-unified-alist (db al) - (let ((r db) ret) - (catch 'tag - (while r - (if (setq ret (nth 1 (assoc-unify (car r) al))) - (throw 'tag ret) - ) - (setq r (cdr r)) - )))) - - -;;; @ utilities -;;; - -(defun delete-atype (atl al) - (let* ((r atl) ret oal) - (setq oal - (catch 'tag - (while r - (if (setq ret (nth 1 (assoc-unify (car r) al))) - (throw 'tag (car r)) - ) - (setq r (cdr r)) - ))) - (delete oal atl) - )) - -(defun remove-atype (sym al) - (and (boundp sym) - (set sym (delete-atype (eval sym) al)) - )) - -(defun replace-atype (atl old-al new-al) - (let* ((r atl) ret oal) - (if (catch 'tag - (while r - (if (setq ret (nth 1 (assoc-unify (car r) old-al))) - (throw 'tag (rplaca r new-al)) - ) - (setq r (cdr r)) - )) - atl))) - -(defun set-atype (sym al &rest options) - (if (null (boundp sym)) - (set sym al) - (let* ((replacement (memq 'replacement options)) - (ignore-fields (car (cdr (memq 'ignore options)))) - (remove (or (car (cdr (memq 'remove options))) - (let ((ral (copy-alist al))) - (mapcar (function - (lambda (type) - (setq ral (del-alist type ral)) - )) - ignore-fields) - ral))) - ) - (set sym - (or (if replacement - (replace-atype (eval sym) remove al) - ) - (cons al - (delete-atype (eval sym) remove) - ) - ))))) - - -;;; @ end -;;; - -(provide 'atype) - -;;; atype.el ends here
--- a/lisp/apel/auto-autoloads.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,61 +0,0 @@ -;;; DO NOT MODIFY THIS FILE -(if (featurep 'apel-autoloads) (error "Already loaded")) - -;;;### (autoloads (module-installed-p exec-installed-p file-installed-p get-latest-path add-latest-path add-path) "file-detect" "apel/file-detect.el") - -(autoload 'add-path "file-detect" "\ -Add PATH to `load-path' if it exists under `default-load-path' -directories and it does not exist in `load-path'. - -You can use following PATH styles: - load-path relative: \"PATH/\" - (it is searched from `defaul-load-path') - home directory relative: \"~/PATH/\" \"~USER/PATH/\" - absolute path: \"/HOO/BAR/BAZ/\" - -You can specify following OPTIONS: - 'all-paths search from `load-path' - instead of `default-load-path' - 'append add PATH to the last of `load-path'" nil nil) - -(autoload 'add-latest-path "file-detect" "\ -Add latest path matched by PATTERN to `load-path' -if it exists under `default-load-path' directories -and it does not exist in `load-path'. - -If optional argument ALL-PATHS is specified, it is searched from all -of load-path instead of default-load-path. [file-detect.el]" nil nil) - -(autoload 'get-latest-path "file-detect" "\ -Return latest directory in default-load-path -which is matched to regexp PATTERN. -If optional argument ALL-PATHS is specified, -it is searched from all of load-path instead of default-load-path." nil nil) - -(autoload 'file-installed-p "file-detect" "\ -Return absolute-path of FILE if FILE exists in PATHS. -If PATHS is omitted, `load-path' is used." nil nil) - -(defvar exec-suffix-list '("") "\ -*List of suffixes for executable.") - -(autoload 'exec-installed-p "file-detect" "\ -Return absolute-path of FILE if FILE exists in PATHS. -If PATHS is omitted, `exec-path' is used. -If suffixes is omitted, `exec-suffix-list' is used." nil nil) - -(autoload 'module-installed-p "file-detect" "\ -Return t if module is provided or exists in PATHS. -If PATHS is omitted, `load-path' is used." nil nil) - -;;;*** - -;;;### (autoloads (richtext-decode richtext-encode) "richtext" "apel/richtext.el") - -(autoload 'richtext-encode "richtext" nil nil nil) - -(autoload 'richtext-decode "richtext" nil nil nil) - -;;;*** - -(provide 'apel-autoloads)
--- a/lisp/apel/emu-e19.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,285 +0,0 @@ -;;; emu-e19.el --- emu module for Emacs 19 and XEmacs 19 - -;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Version: $Id: emu-e19.el,v 1.1 1997/06/03 04:18:35 steve Exp $ -;; Keywords: emulation, compatibility, mule, Latin-1 - -;; This file is part of emu. - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -;;; @ version and variant specific features -;;; - -(cond (running-xemacs - (require 'emu-xemacs)) - (running-emacs-19 - (require 'emu-19) - )) - - -;;; @ character set -;;; - -(defconst charset-ascii 0 "Character set of ASCII") -(defconst charset-latin-iso8859-1 129 "Character set of ISO-8859-1") - -(defun charset-description (charset) - "Return description of CHARSET. [emu-e19.el]" - (if (< charset 128) - (documentation-property 'charset-ascii 'variable-documentation) - (documentation-property 'charset-latin-iso8859-1 'variable-documentation) - )) - -(defun charset-registry (charset) - "Return registry name of CHARSET. [emu-e19.el]" - (if (< charset 128) - "ASCII" - "ISO8859-1")) - -(defun charset-columns (charset) - "Return number of columns a CHARSET occupies when displayed. -\[emu-e19.el]" - 1) - -(defun charset-direction (charset) - "Return the direction of a character of CHARSET by - 0 (left-to-right) or 1 (right-to-left). [emu-e19.el]" - 0) - -(defun find-charset-string (str) - "Return a list of charsets in the string. -\[emu-e19.el; Mule emulating function]" - (if (string-match "[\200-\377]" str) - (list charset-latin-iso8859-1) - )) - -(defalias 'find-non-ascii-charset-string 'find-charset-string) - -(defun find-charset-region (start end) - "Return a list of charsets in the region between START and END. -\[emu-e19.el; Mule emulating function]" - (if (save-excursion - (save-restriction - (narrow-to-region start end) - (goto-char start) - (re-search-forward "[\200-\377]" nil t) - )) - (list charset-latin-iso8859-1) - )) - -(defalias 'find-non-ascii-charset-region 'find-charset-region) - - -;;; @ coding-system -;;; - -(defconst *internal* nil) -(defconst *ctext* nil) -(defconst *noconv* nil) - -(defun decode-coding-string (string coding-system) - "Decode the STRING which is encoded in CODING-SYSTEM. -\[emu-e19.el; Emacs 20 emulating function]" - string) - -(defun encode-coding-string (string coding-system) - "Encode the STRING as CODING-SYSTEM. -\[emu-e19.el; Emacs 20 emulating function]" - string) - -(defun decode-coding-region (start end coding-system) - "Decode the text between START and END which is encoded in CODING-SYSTEM. -\[emu-e19.el; Emacs 20 emulating function]" - 0) - -(defun encode-coding-region (start end coding-system) - "Encode the text between START and END to CODING-SYSTEM. -\[emu-e19.el; Emacs 20 emulating function]" - 0) - -(defun detect-coding-region (start end) - "Detect coding-system of the text in the region between START and END. -\[emu-e19.el; Emacs 20 emulating function]" - ) - -(defun set-buffer-file-coding-system (coding-system &optional force) - "Set buffer-file-coding-system of the current buffer to CODING-SYSTEM. -\[emu-e19.el; Emacs 20 emulating function]" - ) - -(defmacro as-binary-process (&rest body) - (` (let (selective-display) ; Disable ^M to nl translation. - (,@ body) - ))) - -(defmacro as-binary-input-file (&rest body) - (` (let ((emx-binary-mode t)) ; Stop CRLF to LF conversion in OS/2 - (,@ body) - ))) - -(defmacro as-binary-output-file (&rest body) - (` (let ((emx-binary-mode t)) ; Stop CRLF to LF conversion in OS/2 - (,@ body) - ))) - - -;;; @@ for old MULE emulation -;;; - -(defun code-convert-string (str ic oc) - "Convert code in STRING from SOURCE code to TARGET code, -On successful converion, returns the result string, -else returns nil. [emu-e19.el; old MULE emulating function]" - str) - -(defun code-convert-region (beg end ic oc) - "Convert code of the text between BEGIN and END from SOURCE -to TARGET. On successful conversion returns t, -else returns nil. [emu-e19.el; old MULE emulating function]" - t) - - -;;; @ binary access -;;; - -(defun insert-binary-file-contents-literally - (filename &optional visit beg end replace) - "Like `insert-file-contents-literally', q.v., but don't code conversion. -A buffer may be modified in several ways after reading into the buffer due -to advanced Emacs features, such as file-name-handlers, format decoding, -find-file-hooks, etc. - This function ensures that none of these modifications will take place." - (let ((emx-binary-mode t)) - (insert-file-contents-literally filename visit beg end replace) - )) - - -;;; @ MIME charset -;;; - -(defvar charsets-mime-charset-alist - (list (cons (list charset-ascii) 'us-ascii))) - -(defvar default-mime-charset 'iso-8859-1) - -(defun mime-charset-to-coding-system (charset) - (if (stringp charset) - (setq charset (intern (downcase charset))) - ) - (and (memq charset (list 'us-ascii default-mime-charset)) - charset) - ) - -(defun detect-mime-charset-region (start end) - "Return MIME charset for region between START and END. -\[emu-e19.el]" - (if (save-excursion - (save-restriction - (narrow-to-region start end) - (goto-char start) - (re-search-forward "[\200-\377]" nil t) - )) - default-mime-charset - 'us-ascii)) - -(defun encode-mime-charset-region (start end charset) - "Encode the text between START and END as MIME CHARSET. -\[emu-e19.el]" - ) - -(defun decode-mime-charset-region (start end charset) - "Decode the text between START and END as MIME CHARSET. -\[emu-e19.el]" - ) - -(defun encode-mime-charset-string (string charset) - "Encode the STRING as MIME CHARSET. [emu-e19.el]" - string) - -(defun decode-mime-charset-string (string charset) - "Decode the STRING as MIME CHARSET. [emu-e19.el]" - string) - - -;;; @ character -;;; - -(defun char-charset (chr) - "Return the character set of char CHR. -\[emu-e19.el; XEmacs 20 emulating function]" - (if (< chr 128) - charset-ascii - charset-latin-iso8859-1)) - -(defun char-bytes (char) - "Return number of bytes a character in CHAR occupies in a buffer. -\[emu-e19.el; MULE emulating function]" - 1) - -(defalias 'char-length 'char-bytes) - -(defun char-columns (character) - "Return number of columns a CHARACTER occupies when displayed. -\[emu-e19.el]" - 1) - -;;; @@ for old MULE emulation -;;; - -(defalias 'char-width 'char-columns) - -(defalias 'char-leading-char 'char-charset) - - -;;; @ string -;;; - -(defalias 'string-columns 'length) - -(defun string-to-char-list (str) - (mapcar (function identity) str) - ) - -(defalias 'string-to-int-list 'string-to-char-list) - -(defalias 'sref 'aref) - -(defun truncate-string (str width &optional start-column) - "Truncate STR to fit in WIDTH columns. -Optional non-nil arg START-COLUMN specifies the starting column. -\[emu-e19.el; MULE 2.3 emulating function]" - (or start-column - (setq start-column 0)) - (substring str start-column width) - ) - -;;; @@ for old MULE emulation -;;; - -(defalias 'string-width 'length) - - -;;; @ end -;;; - -(provide 'emu-e19) - -;;; emu-e19.el ends here
--- a/lisp/apel/emu-x20.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,192 +0,0 @@ -;;; emu-x20.el --- emu API implementation for XEmacs 20 with mule - -;; Copyright (C) 1994,1995,1996,1997 MORIOKA Tomohiko - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Version: $Id: emu-x20.el,v 1.3 1997/09/03 02:55:28 steve Exp $ -;; Keywords: emulation, compatibility, Mule, XEmacs - -;; 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. - -;;; Commentary: - -;; This module requires XEmacs 20.3-b5 or later with mule. - -;;; Code: - -(require 'emu-xemacs) - - -;;; @ coding-system -;;; - -(defconst *noconv* 'binary) - -(defmacro as-binary-process (&rest body) - `(let (selective-display ; Disable ^M to nl translation. - (coding-system-for-read 'binary) - (coding-system-for-write 'binary)) - ,@body)) - -(defmacro as-binary-input-file (&rest body) - `(let ((coding-system-for-read 'binary)) - ,@body)) - -(defmacro as-binary-output-file (&rest body) - `(let ((coding-system-for-write 'binary)) - ,@body)) - - -;;; @ binary access -;;; - -(defun insert-binary-file-contents-literally - (filename &optional visit beg end replace) - "Like `insert-file-contents-literally', q.v., but don't code conversion. -A buffer may be modified in several ways after reading into the buffer due -to advanced Emacs features, such as file-name-handlers, format decoding, -find-file-hooks, etc. - This function ensures that none of these modifications will take place." - (let ((coding-system-for-read 'binary)) - (insert-file-contents-literally filename visit beg end replace) - )) - - -;;; @ MIME charset -;;; - -(defvar charsets-mime-charset-alist - '(((ascii) . us-ascii) - ((ascii latin-iso8859-1) . iso-8859-1) - ((ascii latin-iso8859-2) . iso-8859-2) - ((ascii latin-iso8859-3) . iso-8859-3) - ((ascii latin-iso8859-4) . iso-8859-4) -;;; ((ascii cyrillic-iso8859-5) . iso-8859-5) - ((ascii cyrillic-iso8859-5) . koi8-r) - ((ascii arabic-iso8859-6) . iso-8859-6) - ((ascii greek-iso8859-7) . iso-8859-7) - ((ascii hebrew-iso8859-8) . iso-8859-8) - ((ascii latin-iso8859-9) . iso-8859-9) - ((ascii latin-jisx0201 - japanese-jisx0208-1978 japanese-jisx0208) . iso-2022-jp) - ((ascii korean-ksc5601) . euc-kr) - ((ascii chinese-gb2312) . cn-gb-2312) - ((ascii chinese-big5-1 chinese-big5-2) . cn-big5) - ((ascii latin-iso8859-1 greek-iso8859-7 - latin-jisx0201 japanese-jisx0208-1978 - chinese-gb2312 japanese-jisx0208 - korean-ksc5601 japanese-jisx0212) . iso-2022-jp-2) - ((ascii latin-iso8859-1 greek-iso8859-7 - latin-jisx0201 japanese-jisx0208-1978 - chinese-gb2312 japanese-jisx0208 - korean-ksc5601 japanese-jisx0212 - chinese-cns11643-1 chinese-cns11643-2) . iso-2022-int-1) - ((ascii latin-iso8859-1 latin-iso8859-2 - cyrillic-iso8859-5 greek-iso8859-7 - latin-jisx0201 japanese-jisx0208-1978 - chinese-gb2312 japanese-jisx0208 - korean-ksc5601 japanese-jisx0212 - chinese-cns11643-1 chinese-cns11643-2 - chinese-cns11643-3 chinese-cns11643-4 - chinese-cns11643-5 chinese-cns11643-6 - chinese-cns11643-7) . iso-2022-int-1) - )) - -(defvar default-mime-charset 'x-ctext) - -(defvar mime-charset-coding-system-alist - '((x-ctext . ctext)) - "Alist MIME CHARSET vs CODING-SYSTEM. -MIME CHARSET and CODING-SYSTEM must be symbol.") - -(defun mime-charset-to-coding-system (charset) - "Return coding-system by MIME charset." - (if (stringp charset) - (setq charset (intern (downcase charset))) - ) - (or (cdr (assq charset mime-charset-coding-system-alist)) - (and (memq charset (coding-system-list)) charset) - )) - -(defun detect-mime-charset-region (start end) - "Return MIME charset for region between START and END." - (charsets-to-mime-charset (charsets-in-region start end))) - -(defun encode-mime-charset-region (start end charset) - "Encode the text between START and END as MIME CHARSET." - (let ((cs (mime-charset-to-coding-system charset))) - (if cs - (encode-coding-region start end cs) - ))) - -(defun decode-mime-charset-region (start end charset) - "Decode the text between START and END as MIME CHARSET." - (let ((cs (mime-charset-to-coding-system charset))) - (if cs - (decode-coding-region start end cs) - ))) - -(defun encode-mime-charset-string (string charset) - "Encode the STRING as MIME CHARSET." - (let ((cs (mime-charset-to-coding-system charset))) - (if cs - (encode-coding-string string cs) - string))) - -(defun decode-mime-charset-string (string charset) - "Decode the STRING as MIME CHARSET." - (let ((cs (mime-charset-to-coding-system charset))) - (if cs - (decode-coding-string string cs) - string))) - - -;;; @ character -;;; - -;;; @@ Mule emulating aliases -;;; -;;; You should not use them. - -(defalias 'char-leading-char 'char-charset) - -(defun char-category (character) - "Return string of category mnemonics for CHAR in TABLE. -CHAR can be any multilingual character -TABLE defaults to the current buffer's category table." - (mapconcat (lambda (chr) - (char-to-string (int-char chr)) - ) - (char-category-list character) - "")) - - -;;; @ string -;;; - -(defun string-to-int-list (str) - (mapcar #'char-int str) - ) - - -;;; @ end -;;; - -(provide 'emu-x20) - -;;; emu-x20.el ends here
--- a/lisp/apel/emu-xemacs.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,160 +0,0 @@ -;;; emu-xemacs.el --- emu API implementation for XEmacs - -;; Copyright (C) 1995 Free Software Foundation, Inc. -;; Copyright (C) 1995,1996,1997 MORIOKA Tomohiko - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Version: -;; $Id: emu-xemacs.el,v 1.1 1997/06/03 04:18:35 steve Exp $ -;; Keywords: emulation, compatibility, XEmacs - -;; This file is part of XEmacs. - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Code: - -;;; @ face -;;; - -(or (fboundp 'face-list) - (defalias 'face-list 'list-faces) - ) - -(or (memq 'underline (face-list)) - (and (fboundp 'make-face) - (make-face 'underline) - )) - -(or (face-differs-from-default-p 'underline) - (set-face-underline-p 'underline t)) - - -;;; @ overlay -;;; - -(condition-case err - (require 'overlay) - (error (defalias 'make-overlay 'make-extent) - (defalias 'overlay-put 'set-extent-property) - (defalias 'overlay-buffer 'extent-buffer) - (defun move-overlay (extent start end &optional buffer) - (set-extent-endpoints extent start end) - ) - )) - - -;;; @ visible/invisible -;;; - -(defmacro enable-invisible ()) - -(defmacro end-of-invisible ()) - -(defun invisible-region (start end) - (if (save-excursion - (goto-char start) - (eq (following-char) ?\n) - ) - (setq start (1+ start)) - ) - (put-text-property start end 'invisible t) - ) - -(defun visible-region (start end) - (put-text-property start end 'invisible nil) - ) - -(defun invisible-p (pos) - (if (save-excursion - (goto-char pos) - (eq (following-char) ?\n) - ) - (setq pos (1+ pos)) - ) - (get-text-property pos 'invisible) - ) - -(defun next-visible-point (pos) - (save-excursion - (if (save-excursion - (goto-char pos) - (eq (following-char) ?\n) - ) - (setq pos (1+ pos)) - ) - (or (next-single-property-change pos 'invisible) - (point-max)) - )) - - -;;; @ mouse -;;; - -(defvar mouse-button-1 'button1) -(defvar mouse-button-2 'button2) -(defvar mouse-button-3 'button3) - - -;;; @ dired -;;; - -(or (fboundp 'dired-other-frame) - (defun dired-other-frame (dirname &optional switches) - "\"Edit\" directory DIRNAME. Like `dired' but makes a new frame." - (interactive (dired-read-dir-and-switches "in other frame ")) - (switch-to-buffer-other-frame (dired-noselect dirname switches)) - ) - ) - - -;;; @ string -;;; - -(defmacro char-list-to-string (char-list) - "Convert list of character CHAR-LIST to string. [emu-xemacs.el]" - `(mapconcat #'char-to-string ,char-list "")) - - -;;; @@ to avoid bug of XEmacs 19.14 -;;; - -(or (string-match "^../" - (file-relative-name "/usr/local/share" "/usr/local/lib")) - ;; This function was imported from Emacs 19.33. - (defun file-relative-name (filename &optional directory) - "Convert FILENAME to be relative to DIRECTORY -(default: default-directory). [emu-xemacs.el]" - (setq filename (expand-file-name filename) - directory (file-name-as-directory - (expand-file-name - (or directory default-directory)))) - (let ((ancestor "")) - (while (not (string-match (concat "^" (regexp-quote directory)) - filename)) - (setq directory (file-name-directory (substring directory 0 -1)) - ancestor (concat "../" ancestor))) - (concat ancestor (substring filename (match-end 0))) - )) - ) - - -;;; @ end -;;; - -(provide 'emu-xemacs) - -;;; emu-xemacs.el ends here
--- a/lisp/apel/emu.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,321 +0,0 @@ -;;; emu.el --- Emulation module for each Emacs variants - -;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Version: $Id: emu.el,v 1.2 1997/06/29 23:12:06 steve Exp $ -;; Keywords: emulation, compatibility, NEmacs, MULE, Emacs/mule, XEmacs - -;; This file is part of emu. - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(defmacro defun-maybe (name &rest everything-else) - (or (and (fboundp name) - (not (get name 'defun-maybe)) - ) - (` (or (fboundp (quote (, name))) - (progn - (defun (, name) (,@ everything-else)) - (put (quote (, name)) 'defun-maybe t) - )) - ))) - -(defmacro defmacro-maybe (name &rest everything-else) - (or (and (fboundp name) - (not (get name 'defmacro-maybe)) - ) - (` (or (fboundp (quote (, name))) - (progn - (defmacro (, name) (,@ everything-else)) - (put (quote (, name)) 'defmacro-maybe t) - )) - ))) - -(put 'defun-maybe 'lisp-indent-function 'defun) -(put 'defmacro-maybe 'lisp-indent-function 'defun) - - -(or (boundp 'emacs-major-version) - (defconst emacs-major-version (string-to-int emacs-version))) -(or (boundp 'emacs-minor-version) - (defconst emacs-minor-version - (string-to-int - (substring - emacs-version - (string-match (format "%d\\." emacs-major-version) emacs-version) - )))) - -(defvar running-emacs-18 (<= emacs-major-version 18)) -(defvar running-xemacs (string-match "XEmacs" emacs-version)) - -(defvar running-mule-merged-emacs (and (not (boundp 'MULE)) - (not running-xemacs) (featurep 'mule))) -(defvar running-xemacs-with-mule (and running-xemacs (featurep 'mule))) - -(defvar running-emacs-19 (and (not running-xemacs) (= emacs-major-version 19))) -(defvar running-emacs-19_29-or-later - (or (and running-emacs-19 (>= emacs-minor-version 29)) - (and (not running-xemacs)(>= emacs-major-version 20)))) - -(defvar running-xemacs-19 (and running-xemacs - (= emacs-major-version 19))) -(defvar running-xemacs-20-or-later (and running-xemacs - (>= emacs-major-version 20))) -(defvar running-xemacs-19_14-or-later - (or (and running-xemacs-19 (>= emacs-minor-version 14)) - running-xemacs-20-or-later)) - -(cond (running-mule-merged-emacs - ;; for mule merged EMACS - (require 'emu-e20) - ) - (running-xemacs-with-mule - ;; for XEmacs/mule - (require 'emu-x20) - ) - ((boundp 'MULE) - ;; for MULE 1.* and 2.* - (require 'emu-mule) - ) - ((boundp 'NEMACS) - ;; for NEmacs and NEpoch - (require 'emu-nemacs) - ) - (t - ;; for EMACS 19 and XEmacs 19 (without mule) - (require 'emu-e19) - )) - - -;;; @ MIME charset -;;; - -(defun charsets-to-mime-charset (charsets) - "Return MIME charset from list of charset CHARSETS. -This function refers variable `charsets-mime-charset-alist' -and `default-mime-charset'. [emu.el]" - (if charsets - (or (catch 'tag - (let ((rest charsets-mime-charset-alist) - cell csl) - (while (setq cell (car rest)) - (if (catch 'not-subset - (let ((set1 charsets) - (set2 (car cell)) - obj) - (while set1 - (setq obj (car set1)) - (or (memq obj set2) - (throw 'not-subset nil) - ) - (setq set1 (cdr set1)) - ) - t)) - (throw 'tag (cdr cell)) - ) - (setq rest (cdr rest)) - ))) - default-mime-charset))) - - -;;; @ Emacs 19 emulation -;;; - -(defun-maybe minibuffer-prompt-width () - "Return the display width of the minibuffer prompt." - (save-excursion - (set-buffer (window-buffer (minibuffer-window))) - (current-column) - )) - - -;;; @ Emacs 19.29 emulation -;;; - -(defvar path-separator ":" - "Character used to separate concatenated paths.") - -(defun-maybe buffer-substring-no-properties (start end) - "Return the characters of part of the buffer, without the text properties. -The two arguments START and END are character positions; -they can be in either order. [Emacs 19.29 emulating function]" - (let ((string (buffer-substring start end))) - (set-text-properties 0 (length string) nil string) - string)) - -(defun-maybe match-string (num &optional string) - "Return string of text matched by last search. -NUM specifies which parenthesized expression in the last regexp. - Value is nil if NUMth pair didn't match, or there were less than NUM pairs. -Zero means the entire text matched by the whole regexp or whole string. -STRING should be given if the last search was by `string-match' on STRING. -\[Emacs 19.29 emulating function]" - (if (match-beginning num) - (if string - (substring string (match-beginning num) (match-end num)) - (buffer-substring (match-beginning num) (match-end num))))) - -(or running-emacs-19_29-or-later - running-xemacs - ;; for Emacs 19.28 or earlier - (fboundp 'si:read-string) - (progn - (fset 'si:read-string (symbol-function 'read-string)) - - (defun read-string (prompt &optional initial-input history) - "Read a string from the minibuffer, prompting with string PROMPT. -If non-nil, second arg INITIAL-INPUT is a string to insert before reading. -The third arg HISTORY, is dummy for compatibility. [emu.el] -See `read-from-minibuffer' for details of HISTORY argument." - (si:read-string prompt initial-input) - ) - )) - - -;;; @ Emacs 19.30 emulation -;;; - -;; This function was imported Emacs 19.30. -(defun-maybe add-to-list (list-var element) - "Add to the value of LIST-VAR the element ELEMENT if it isn't there yet. -If you want to use `add-to-list' on a variable that is not defined -until a certain package is loaded, you should put the call to `add-to-list' -into a hook function that will be run only after loading the package. -\[Emacs 19.30 emulating function]" - (or (member element (symbol-value list-var)) - (set list-var (cons element (symbol-value list-var))) - )) - -(cond ((fboundp 'insert-file-contents-literally) - ) - ((boundp 'file-name-handler-alist) - (defun insert-file-contents-literally - (filename &optional visit beg end replace) - "Like `insert-file-contents', q.v., but only reads in the file. -A buffer may be modified in several ways after reading into the buffer due -to advanced Emacs features, such as file-name-handlers, format decoding, -find-file-hooks, etc. - This function ensures that none of these modifications will take place. -\[Emacs 19.30 emulating function]" - (let (file-name-handler-alist) - (insert-file-contents filename visit beg end replace) - )) - ) - (t - (defalias 'insert-file-contents-literally 'insert-file-contents) - )) - - -;;; @ Emacs 19.31 emulation -;;; - -(defun-maybe buffer-live-p (object) - "Return non-nil if OBJECT is a buffer which has not been killed. -Value is nil if OBJECT is not a buffer or if it has been killed. -\[Emacs 19.31 emulating function]" - (and object - (get-buffer object) - (buffer-name (get-buffer object)) - )) - -;; This macro was imported Emacs 19.33. -(defmacro-maybe save-selected-window (&rest body) - "Execute BODY, then select the window that was selected before BODY. -\[Emacs 19.31 emulating function]" - (list 'let - '((save-selected-window-window (selected-window))) - (list 'unwind-protect - (cons 'progn body) - (list 'select-window 'save-selected-window-window)))) - - -;;; @ XEmacs emulation -;;; - -(defun-maybe functionp (obj) - "Returns t if OBJ is a function, nil otherwise. -\[XEmacs emulating function]" - (or (subrp obj) - (byte-code-function-p obj) - (and (symbolp obj)(fboundp obj)) - (and (consp obj)(eq (car obj) 'lambda)) - )) - -(defun-maybe point-at-eol (&optional arg buffer) - "Return the character position of the last character on the current line. -With argument N not nil or 1, move forward N - 1 lines first. -If scan reaches end of buffer, return that position. -This function does not move point. [XEmacs emulating function]" - (save-excursion - (if buffer - (set-buffer buffer) - ) - (if arg - (forward-line (1- arg)) - ) - (end-of-line) - (point) - )) - - -;;; @ for XEmacs 20 -;;; - -(or (fboundp 'char-int) - (fset 'char-int (symbol-function 'identity)) - ) -(or (fboundp 'int-char) - (fset 'int-char (symbol-function 'identity)) - ) -(or (fboundp 'char-or-char-int-p) - (fset 'char-or-char-int-p (symbol-function 'integerp)) - ) - - -;;; @ for text/richtext and text/enriched -;;; - -(cond ((fboundp 'richtext-decode) - ;; have richtext.el - ) - ((or running-emacs-19_29-or-later running-xemacs-19_14-or-later) - ;; have enriched.el - (autoload 'richtext-decode "richtext") - (or (assq 'text/richtext format-alist) - (setq format-alist - (cons - (cons 'text/richtext - '("Extended MIME text/richtext format." - "Content-[Tt]ype:[ \t]*text/richtext" - richtext-decode richtext-encode t enriched-mode)) - format-alist))) - ) - (t - ;; don't have enriched.el - (autoload 'richtext-decode "tinyrich") - (autoload 'enriched-decode "tinyrich") - )) - - -;;; @ end -;;; - -(provide 'emu) - -;;; emu.el ends here
--- a/lisp/apel/file-detect.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,168 +0,0 @@ -;;; file-detect.el --- Emacs Lisp file detection utility - -;; Copyright (C) 1996,1997 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Version: -;; $Id: file-detect.el,v 1.2 1997/06/29 23:12:06 steve Exp $ -;; Keywords: install, module - -;; This file is part of APEL (A Portable Emacs Library). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(defvar default-load-path load-path) - -;;;###autoload -(defun add-path (path &rest options) - "Add PATH to `load-path' if it exists under `default-load-path' -directories and it does not exist in `load-path'. - -You can use following PATH styles: - load-path relative: \"PATH/\" - (it is searched from `defaul-load-path') - home directory relative: \"~/PATH/\" \"~USER/PATH/\" - absolute path: \"/HOO/BAR/BAZ/\" - -You can specify following OPTIONS: - 'all-paths search from `load-path' - instead of `default-load-path' - 'append add PATH to the last of `load-path'" - (let ((rest (if (memq 'all-paths options) - load-path - default-load-path)) - p) - (if (and (catch 'tag - (while rest - (setq p (expand-file-name path (car rest))) - (if (file-directory-p p) - (throw 'tag p) - ) - (setq rest (cdr rest)) - )) - (not (member p load-path)) - ) - (setq load-path - (if (memq 'append options) - (append load-path (list p)) - (cons p load-path) - )) - ))) - -;;;###autoload -(defun add-latest-path (pattern &optional all-paths) - "Add latest path matched by PATTERN to `load-path' -if it exists under `default-load-path' directories -and it does not exist in `load-path'. - -If optional argument ALL-PATHS is specified, it is searched from all -of load-path instead of default-load-path. [file-detect.el]" - (let ((path (get-latest-path pattern all-paths))) - (if path - (add-to-list 'load-path path) - ))) - -;;;###autoload -(defun get-latest-path (pattern &optional all-paths) - "Return latest directory in default-load-path -which is matched to regexp PATTERN. -If optional argument ALL-PATHS is specified, -it is searched from all of load-path instead of default-load-path." - (catch 'tag - (let ((paths (if all-paths - load-path - default-load-path)) - dir) - (while (setq dir (car paths)) - (if (and (file-exists-p dir) - (file-directory-p dir) - ) - (let ((files (sort (directory-files dir t pattern t) - (function file-newer-than-file-p))) - file) - (while (setq file (car files)) - (if (file-directory-p file) - (throw 'tag file) - ) - (setq files (cdr files)) - ))) - (setq paths (cdr paths)) - )))) - -;;;###autoload -(defun file-installed-p (file &optional paths) - "Return absolute-path of FILE if FILE exists in PATHS. -If PATHS is omitted, `load-path' is used." - (if (null paths) - (setq paths load-path) - ) - (catch 'tag - (let (path) - (while paths - (setq path (expand-file-name file (car paths))) - (if (file-exists-p path) - (throw 'tag path) - ) - (setq paths (cdr paths)) - )))) - -;;;###autoload -(defvar exec-suffix-list '("") - "*List of suffixes for executable.") - -;;;###autoload -(defun exec-installed-p (file &optional paths suffixes) - "Return absolute-path of FILE if FILE exists in PATHS. -If PATHS is omitted, `exec-path' is used. -If suffixes is omitted, `exec-suffix-list' is used." - (or paths - (setq paths exec-path) - ) - (or suffixes - (setq suffixes exec-suffix-list) - ) - (catch 'tag - (while paths - (let ((stem (expand-file-name file (car paths))) - (sufs suffixes) - ) - (while sufs - (let ((file (concat stem (car sufs)))) - (if (file-exists-p file) - (throw 'tag file) - )) - (setq sufs (cdr sufs)) - )) - (setq paths (cdr paths)) - ))) - -;;;###autoload -(defun module-installed-p (module &optional paths) - "Return t if module is provided or exists in PATHS. -If PATHS is omitted, `load-path' is used." - (or (featurep module) - (exec-installed-p (symbol-name module) load-path '(".elc" ".el")) - )) - - -;;; @ end -;;; - -(provide 'file-detect) - -;;; file-detect.el ends here
--- a/lisp/apel/filename.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,162 +0,0 @@ -;;; filename.el --- file name filter - -;; Copyright (C) 1996,1997 MORIOKA Tomohiko - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Version: $Id: filename.el,v 1.1 1997/06/03 04:18:35 steve Exp $ -;; Keywords: file name, string - -;; This file is part of APEL (A Portable Emacs Library). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'emu) -(require 'cl) - -(defsubst poly-funcall (functions argument) - "Apply initial ARGUMENT to sequence of FUNCTIONS. -FUNCTIONS is list of functions. - -(poly-funcall '(f1 f2 .. fn) arg) is as same as -(fn .. (f2 (f1 arg)) ..). - -For example, (poly-funcall '(car number-to-string) '(100)) returns -\"100\"." - (while functions - (setq argument (funcall (car functions) argument) - functions (cdr functions)) - ) - argument) - - -;;; @ variables -;;; - -(defvar filename-limit-length 21 "Limit size of file-name.") - -(defvar filename-replacement-alist - '(((?\ ?\t) . "_") - ((?! ?\" ?# ?$ ?% ?& ?' ?\( ?\) ?* ?/ - ?: ?\; ?< ?> ?? ?\[ ?\\ ?\] ?` ?{ ?| ?}) . "_") - (filename-control-p . "") - ) - "Alist list of characters vs. string as replacement. -List of characters represents characters not allowed as file-name.") - -(defvar filename-filters - (let ((filters '(filename-special-filter - filename-eliminate-top-low-lines - filename-canonicalize-low-lines - filename-maybe-truncate-by-size - filename-eliminate-bottom-low-lines - ))) - (require 'file-detect) - (if (exec-installed-p "kakasi") - (cons 'filename-japanese-to-roman-string filters) - filters)) - "List of functions for file-name filter.") - - -;;; @ filters -;;; - -(defun filename-japanese-to-roman-string (str) - (save-excursion - (set-buffer (get-buffer-create " *temp kakasi*")) - (erase-buffer) - (insert str) - (call-process-region (point-min)(point-max) "kakasi" t t t - "-Ha" "-Ka" "-Ja" "-Ea" "-ka") - (buffer-string) - )) - -(defun filename-control-p (character) - (let ((code (char-int character))) - (or (< code 32)(= code 127)) - )) - -(defun filename-special-filter (string) - (let (dest - (i 0) - (len (length string)) - (b 0) - ) - (while (< i len) - (let* ((chr (sref string i)) - (ret (assoc-if (function - (lambda (key) - (if (functionp key) - (funcall key chr) - (memq chr key) - ))) - filename-replacement-alist)) - ) - (if ret - (setq dest (concat dest (substring string b i)(cdr ret)) - i (+ i (char-length chr)) - b i) - (setq i (+ i (char-length chr))) - ))) - (concat dest (substring string b)) - )) - -(defun filename-eliminate-top-low-lines (string) - (if (string-match "^_+" string) - (substring string (match-end 0)) - string)) - -(defun filename-canonicalize-low-lines (string) - (let (dest) - (while (string-match "__+" string) - (setq dest (concat dest (substring string 0 (1+ (match-beginning 0))))) - (setq string (substring string (match-end 0))) - ) - (concat dest string) - )) - -(defun filename-maybe-truncate-by-size (string) - (if (and (> (length string) filename-limit-length) - (string-match "_" string filename-limit-length) - ) - (substring string 0 (match-beginning 0)) - string)) - -(defun filename-eliminate-bottom-low-lines (string) - (if (string-match "_+$" string) - (substring string 0 (match-beginning 0)) - string)) - - -;;; @ interface -;;; - -(defun replace-as-filename (string) - "Return safety filename from STRING. -It refers variable `filename-filters' and default filters refers -`filename-limit-length', `filename-replacement-alist'." - (and string - (poly-funcall filename-filters string) - )) - - -;;; @ end -;;; - -(provide 'filename) - -;;; filename.el ends here
--- a/lisp/apel/install.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,204 +0,0 @@ -;;; install.el --- Emacs Lisp package install utility - -;; Copyright (C) 1996 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Created: 1996/8/18 -;; Version: $Id: install.el,v 1.1 1997/06/03 04:18:35 steve Exp $ -;; Keywords: install - -;; This file is part of tl (Tiny Library). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'emu) -(require 'file-detect) - -;;; @ compile Emacs Lisp files -;;; - -(defun compile-elisp-module (module &optional path every-time) - (setq module (expand-file-name (symbol-name module) path)) - (let ((el-file (concat module ".el")) - (elc-file (concat module ".elc")) - ) - (if (or every-time - (file-newer-than-file-p el-file elc-file)) - (byte-compile-file el-file) - ) - )) - -(defun compile-elisp-modules (modules &optional path every-time) - (mapcar (function - (lambda (module) - (compile-elisp-module module path every-time) - )) - modules)) - - -;;; @ install files -;;; - -(defvar install-overwritten-file-modes (+ (* 64 6)(* 8 4) 4)) - -(defun install-file (file src dest &optional move overwrite) - (let ((src-file (expand-file-name file src))) - (if (file-exists-p src-file) - (let ((full-path (expand-file-name file dest))) - (if (and (file-exists-p full-path) overwrite) - (delete-file full-path) - ) - (copy-file src-file full-path t t) - (if move - (catch 'tag - (while (and (file-exists-p src-file) - (file-writable-p src-file)) - (condition-case err - (progn - (delete-file src-file) - (throw 'tag nil) - ) - (error (princ (format "%s\n" (nth 1 err)))) - )))) - (princ (format "%s -> %s\n" file dest)) - )) - )) - -(defun install-files (files src dest &optional move overwrite) - (or (file-exists-p dest) - (make-directory dest t) - ) - (mapcar (function (lambda (file) - (install-file file src dest move overwrite) - )) - files)) - - -;;; @@ install Emacs Lisp files -;;; - -(defun install-elisp-module (module src dest) - (let (el-file elc-file) - (let ((name (symbol-name module))) - (setq el-file (concat name ".el")) - (setq elc-file (concat name ".elc")) - ) - (let ((src-file (expand-file-name el-file src))) - (if (file-exists-p src-file) - (let ((full-path (expand-file-name el-file dest))) - (if (file-exists-p full-path) - (delete-file full-path) - ) - (copy-file src-file full-path t t) - (princ (format "%s -> %s\n" el-file dest)) - )) - (setq src-file (expand-file-name elc-file src)) - (if (file-exists-p src-file) - (let ((full-path (expand-file-name elc-file dest))) - (if (file-exists-p full-path) - (delete-file full-path) - ) - (copy-file src-file full-path t t) - (catch 'tag - (while (file-exists-p src-file) - (condition-case err - (progn - (delete-file src-file) - (throw 'tag nil) - ) - (error (princ (format "%s\n" (nth 1 err)))) - ))) - (princ (format "%s -> %s\n" elc-file dest)) - )) - ))) - -(defun install-elisp-modules (modules src dest) - (or (file-exists-p dest) - (make-directory dest t) - ) - (mapcar (function (lambda (module) - (install-elisp-module module src dest) - )) - modules)) - - -;;; @ detect install path -;;; - -(defvar install-prefix - (if (or running-emacs-18 running-xemacs) - (expand-file-name "../../.." exec-directory) - (expand-file-name "../../../.." data-directory) - )) ; install to shared directory (maybe "/usr/local") - -(defvar install-elisp-prefix - (if (>= emacs-major-version 19) - "site-lisp" - "local.lisp")) - -(defun install-detect-elisp-directory (&optional prefix elisp-prefix - allow-version-specific) - (or prefix - (setq prefix install-prefix) - ) - (or elisp-prefix - (setq elisp-prefix install-elisp-prefix) - ) - (or - (catch 'tag - (let ((rest default-load-path) - dir) - (while (setq dir (car rest)) - (if (string-match - (concat "^" - (expand-file-name (concat ".*/" elisp-prefix) prefix) - "$") - dir) - (if (or allow-version-specific - (not (string-match (format "%d\\.%d" - emacs-major-version - emacs-minor-version) dir)) - ) - (throw 'tag dir) - )) - (setq rest (cdr rest)) - ))) - (expand-file-name (concat - (if running-emacs-19_29-or-later - "share/" - "lib/") - (cond ((boundp 'NEMACS) "nemacs/") - ((boundp 'MULE) "mule/") - (running-xemacs - (if (featurep 'mule) - "xmule/" - "xemacs/")) - (t "emacs/")) - elisp-prefix) prefix) - )) - -(defvar install-default-elisp-directory - (install-detect-elisp-directory)) - - -;;; @ end -;;; - -(provide 'install) - -;;; install.el ends here
--- a/lisp/apel/mule-caesar.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,94 +0,0 @@ -;;; mule-caesar.el --- ROT 13-47 Caesar rotation utility - -;; Copyright (C) 1997 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Version: $Id: mule-caesar.el,v 1.1 1997/06/03 04:18:36 steve Exp $ -;; Keywords: ROT 13-47, caesar, mail, news, text/x-rot13-47 - -;; This file is part of APEL (A Portable Emacs Library). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(defun char-to-octet-list (character) - "Return list of octets in code table of graphic character set." - (let* ((code (char-int character)) - (dim (charset-dimension (char-charset code))) - dest) - (while (> dim 0) - (setq dest (cons (logand code 127) dest) - dim (1- dim) - code (lsh code -7)) - ) - dest)) - -(defun mule-caesar-region (start end &optional stride-ascii) - "Caesar rotation of current region. -Optional argument STRIDE-ASCII is rotation-size for Latin alphabet -\(A-Z and a-z). For non-ASCII text, ROT-N/2 will be performed in any -case (N=charset-chars; 94 for 94 or 94x94 graphic character set; 96 -for 96 or 96x96 graphic character set)." - (interactive "r\nP") - (setq stride-ascii (if stride-ascii - (mod stride-ascii 26) - 13)) - (save-excursion - (save-restriction - (narrow-to-region start end) - (goto-char start) - (while (< (point)(point-max)) - (let* ((chr (char-after (point))) - (charset (char-charset chr)) - ) - (if (eq charset 'ascii) - (cond ((and (<= ?A chr) (<= chr ?Z)) - (setq chr (+ chr stride-ascii)) - (if (> chr ?Z) - (setq chr (- chr 26)) - ) - (delete-char 1) - (insert chr) - ) - ((and (<= ?a chr) (<= chr ?z)) - (setq chr (+ chr stride-ascii)) - (if (> chr ?z) - (setq chr (- chr 26)) - ) - (delete-char 1) - (insert chr) - ) - (t - (forward-char) - )) - (let* ((stride (lsh (charset-chars charset) -1)) - (ret (mapcar (function - (lambda (octet) - (if (< octet 80) - (+ octet stride) - (- octet stride) - ))) - (char-to-octet-list chr)))) - (delete-char 1) - (insert (make-char (char-charset chr) - (car ret)(car (cdr ret)))) - ))))))) - - -(provide 'mule-caesar) - -;;; mule-caesar.el ends here
--- a/lisp/apel/richtext.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,184 +0,0 @@ -;;; richtext.el -- read and save files in text/richtext format - -;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Created: 1995/7/15 -;; Version: $Id: richtext.el,v 1.2 1997/06/29 23:12:06 steve Exp $ -;; Keywords: wp, faces, MIME, multimedia - -;; This file is not part of GNU Emacs yet. - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'enriched) - - -;;; @ variables -;;; - -(defconst richtext-initial-annotation - (lambda () - (format "Content-Type: text/richtext\nText-Width: %d\n\n" - (enriched-text-width))) - "What to insert at the start of a text/richtext file. -If this is a string, it is inserted. If it is a list, it should be a lambda -expression, which is evaluated to get the string to insert.") - -(defconst richtext-annotation-regexp - "[ \t\n]*\\(<\\(/\\)?\\([-A-za-z0-9]+\\)>\\)[ \t\n]*" - "Regular expression matching richtext annotations.") - -(defconst richtext-translations - '((face (bold-italic "bold" "italic") - (bold "bold") - (italic "italic") - (underline "underline") - (fixed "fixed") - (excerpt "excerpt") - (default ) - (nil enriched-encode-other-face)) - (invisible (t "comment")) - (left-margin (4 "indent")) - (right-margin (4 "indentright")) - (justification (right "flushright") - (left "flushleft") - (full "flushboth") - (center "center")) - ;; The following are not part of the standard: - (FUNCTION (enriched-decode-foreground "x-color") - (enriched-decode-background "x-bg-color")) - (read-only (t "x-read-only")) - (unknown (nil format-annotate-value)) -; (font-size (2 "bigger") ; unimplemented -; (-2 "smaller")) -) - "List of definitions of text/richtext annotations. -See `format-annotate-region' and `format-deannotate-region' for the definition -of this structure.") - - -;;; @ encoder -;;; - -;;;###autoload -(defun richtext-encode (from to) - (if enriched-verbose (message "Richtext: encoding document...")) - (save-restriction - (narrow-to-region from to) - (delete-to-left-margin) - (unjustify-region) - (goto-char from) - (format-replace-strings '(("<" . "<lt>"))) - (format-insert-annotations - (format-annotate-region from (point-max) richtext-translations - 'enriched-make-annotation enriched-ignore)) - (goto-char from) - (insert (if (stringp enriched-initial-annotation) - richtext-initial-annotation - (funcall richtext-initial-annotation))) - (enriched-map-property-regions 'hard - (lambda (v b e) - (goto-char b) - (if (eolp) - (while (search-forward "\n" nil t) - (replace-match "<nl>\n") - ))) - (point) nil) - (if enriched-verbose (message nil)) - ;; Return new end. - (point-max))) - - -;;; @ decoder -;;; - -(defun richtext-next-annotation () - "Find and return next text/richtext annotation. -Return value is \(begin end name positive-p), or nil if none was found." - (catch 'tag - (while (re-search-forward richtext-annotation-regexp nil t) - (let* ((beg0 (match-beginning 0)) - (end0 (match-end 0)) - (beg (match-beginning 1)) - (end (match-end 1)) - (name (downcase (buffer-substring - (match-beginning 3) (match-end 3)))) - (pos (not (match-beginning 2))) - ) - (cond ((equal name "lt") - (delete-region beg end) - (goto-char beg) - (insert "<") - ) - ((equal name "comment") - (if pos - (throw 'tag (list beg0 end name pos)) - (throw 'tag (list beg end0 name pos)) - ) - ) - (t - (throw 'tag (list beg end name pos)) - )) - )))) - -;;;###autoload -(defun richtext-decode (from to) - (if enriched-verbose (message "Richtext: decoding document...")) - (save-excursion - (save-restriction - (narrow-to-region from to) - (goto-char from) - (let ((file-width (enriched-get-file-width)) - (use-hard-newlines t)) - (enriched-remove-header) - - (goto-char from) - (while (re-search-forward "\n\n+" nil t) - (replace-match "\n") - ) - - ;; Deal with newlines - (goto-char from) - (while (re-search-forward "[ \t\n]*<nl>[ \t\n]*" nil t) - (replace-match "\n") - (put-text-property (match-beginning 0) (point) 'hard t) - (put-text-property (match-beginning 0) (point) 'front-sticky nil) - ) - - ;; Translate annotations - (format-deannotate-region from (point-max) richtext-translations - 'richtext-next-annotation) - - ;; Fill paragraphs - (if (and file-width ; possible reasons not to fill: - (= file-width (enriched-text-width))) ; correct wd. - ;; Minimally, we have to insert indentation and justification. - (enriched-insert-indentation) - (if enriched-verbose (message "Filling paragraphs...")) - (fill-region (point-min) (point-max)))) - (if enriched-verbose (message nil)) - (point-max)))) - - -;;; @ end -;;; - -(provide 'richtext) - -;;; richtext.el ends here
--- a/lisp/apel/std11-parse.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,442 +0,0 @@ -;;; std11-parse.el --- STD 11 parser for GNU Emacs - -;; Copyright (C) 1995,1996 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Keywords: mail, news, RFC 822, STD 11 -;; Version: -;; $Id: std11-parse.el,v 1.2 1997/07/26 22:09:37 steve Exp $ - -;; This file is part of MU (Message Utilities). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'std11) -(require 'emu) - - -;;; @ lexical analyze -;;; - -(defconst std11-space-chars " \t\n") -(defconst std11-spaces-regexp (concat "[" std11-space-chars "]+")) -(defconst std11-special-chars "][()<>@,;:\\<>.\"") -(defconst std11-atom-regexp - (concat "^[^" std11-special-chars std11-space-chars "]+")) - -(defun std11-analyze-spaces (string) - (if (and (string-match std11-spaces-regexp string) - (= (match-beginning 0) 0)) - (let ((end (match-end 0))) - (cons (cons 'spaces (substring string 0 end)) - (substring string end) - )))) - -(defun std11-analyze-special (str) - (if (and (> (length str) 0) - (find (aref str 0) std11-special-chars) - ) - (cons (cons 'specials (substring str 0 1)) - (substring str 1) - ))) - -(defun std11-analyze-atom (str) - (if (string-match std11-atom-regexp str) - (let ((end (match-end 0))) - (cons (cons 'atom (substring str 0 end)) - (substring str end) - )))) - -(defun std11-check-enclosure (str open close &optional recursive from) - (let ((len (length str)) - (i (or from 0)) - ) - (if (and (> len i) - (eq (aref str i) open)) - (let (p chr) - (setq i (1+ i)) - (catch 'tag - (while (< i len) - (setq chr (aref str i)) - (cond ((eq chr ?\\) - (setq i (1+ i)) - (if (>= i len) - (throw 'tag nil) - ) - (setq i (1+ i)) - ) - ((eq chr close) - (throw 'tag (1+ i)) - ) - ((eq chr open) - (if (and recursive - (setq p (std11-check-enclosure - str open close recursive i)) - ) - (setq i p) - (throw 'tag nil) - )) - (t - (setq i (1+ i)) - )) - )))))) - -(defun std11-analyze-quoted-string (str) - (let ((p (std11-check-enclosure str ?\" ?\"))) - (if p - (cons (cons 'quoted-string (substring str 1 (1- p))) - (substring str p)) - ))) - -(defun std11-analyze-domain-literal (str) - (let ((p (std11-check-enclosure str ?\[ ?\]))) - (if p - (cons (cons 'domain-literal (substring str 1 (1- p))) - (substring str p)) - ))) - -(defun std11-analyze-comment (str) - (let ((p (std11-check-enclosure str ?\( ?\) t))) - (if p - (cons (cons 'comment (substring str 1 (1- p))) - (substring str p)) - ))) - -(defun std11-lexical-analyze (str) - (let (dest ret) - (while (not (string-equal str "")) - (setq ret - (or (std11-analyze-quoted-string str) - (std11-analyze-domain-literal str) - (std11-analyze-comment str) - (std11-analyze-spaces str) - (std11-analyze-special str) - (std11-analyze-atom str) - '((error) . "") - )) - (setq dest (cons (car ret) dest)) - (setq str (cdr ret)) - ) - (nreverse dest) - )) - - -;;; @ parser -;;; - -(defun std11-ignored-token-p (token) - (let ((type (car token))) - (or (eq type 'spaces)(eq type 'comment)) - )) - -(defun std11-parse-token (lal) - (let (token itl) - (while (and lal - (progn - (setq token (car lal)) - (std11-ignored-token-p token) - )) - (setq lal (cdr lal)) - (setq itl (cons token itl)) - ) - (cons (nreverse (cons token itl)) - (cdr lal)) - )) - -(defun std11-parse-ascii-token (lal) - (let (token itl parsed token-value) - (while (and lal - (setq token (car lal)) - (or (std11-ignored-token-p token) - (if (and (setq token-value (cdr token)) - (find-non-ascii-charset-string token-value) - ) - (setq token nil) - ))) - (setq lal (cdr lal)) - (setq itl (cons token itl)) - ) - (if (and token - (setq parsed (nreverse (cons token itl))) - ) - (cons parsed (cdr lal)) - ))) - -(defun std11-parse-token-or-comment (lal) - (let (token itl) - (while (and lal - (progn - (setq token (car lal)) - (eq (car token) 'spaces) - )) - (setq lal (cdr lal)) - (setq itl (cons token itl)) - ) - (cons (nreverse (cons token itl)) - (cdr lal)) - )) - -(defun std11-parse-word (lal) - (let ((ret (std11-parse-ascii-token lal))) - (if ret - (let ((elt (car ret)) - (rest (cdr ret)) - ) - (if (or (assq 'atom elt) - (assq 'quoted-string elt)) - (cons (cons 'word elt) rest) - ))))) - -(defun std11-parse-word-or-comment (lal) - (let ((ret (std11-parse-token-or-comment lal))) - (if ret - (let ((elt (car ret)) - (rest (cdr ret)) - ) - (cond ((or (assq 'atom elt) - (assq 'quoted-string elt)) - (cons (cons 'word elt) rest) - ) - ((assq 'comment elt) - (cons (cons 'comment-word elt) rest) - )) - )))) - -(defun std11-parse-phrase (lal) - (let (ret phrase) - (while (setq ret (std11-parse-word-or-comment lal)) - (setq phrase (append phrase (cdr (car ret)))) - (setq lal (cdr ret)) - ) - (if phrase - (cons (cons 'phrase phrase) lal) - ))) - -(defun std11-parse-local-part (lal) - (let ((ret (std11-parse-word lal))) - (if ret - (let ((local-part (cdr (car ret))) dot) - (setq lal (cdr ret)) - (while (and (setq ret (std11-parse-ascii-token lal)) - (setq dot (car ret)) - (string-equal (cdr (assq 'specials dot)) ".") - (setq ret (std11-parse-word (cdr ret))) - (setq local-part - (append local-part dot (cdr (car ret))) - ) - (setq lal (cdr ret)) - )) - (cons (cons 'local-part local-part) lal) - )))) - -(defun std11-parse-sub-domain (lal) - (let ((ret (std11-parse-ascii-token lal))) - (if ret - (let ((sub-domain (car ret))) - (if (or (assq 'atom sub-domain) - (assq 'domain-literal sub-domain) - ) - (cons (cons 'sub-domain sub-domain) - (cdr ret) - ) - ))))) - -(defun std11-parse-domain (lal) - (let ((ret (std11-parse-sub-domain lal))) - (if ret - (let ((domain (cdr (car ret))) dot) - (setq lal (cdr ret)) - (while (and (setq ret (std11-parse-ascii-token lal)) - (setq dot (car ret)) - (string-equal (cdr (assq 'specials dot)) ".") - (setq ret (std11-parse-sub-domain (cdr ret))) - (setq domain - (append domain dot (cdr (car ret))) - ) - (setq lal (cdr ret)) - )) - (cons (cons 'domain domain) lal) - )))) - -(defun std11-parse-at-domain (lal) - (let ((ret (std11-parse-ascii-token lal)) at-sign) - (if (and ret - (setq at-sign (car ret)) - (string-equal (cdr (assq 'specials at-sign)) "@") - (setq ret (std11-parse-domain (cdr ret))) - ) - (cons (cons 'at-domain (append at-sign (cdr (car ret)))) - (cdr ret)) - ))) - -(defun std11-parse-addr-spec (lal) - (let ((ret (std11-parse-local-part lal)) - addr) - (if (and ret - (prog1 - (setq addr (cdr (car ret))) - (setq lal (cdr ret)) - (and (setq ret (std11-parse-at-domain lal)) - (setq addr (append addr (cdr (car ret)))) - (setq lal (cdr ret)) - ))) - (cons (cons 'addr-spec addr) lal) - ))) - -(defun std11-parse-route (lal) - (let ((ret (std11-parse-at-domain lal)) - route comma colon) - (if (and ret - (progn - (setq route (cdr (car ret))) - (setq lal (cdr ret)) - (while (and (setq ret (std11-parse-ascii-token lal)) - (setq comma (car ret)) - (string-equal (cdr (assq 'specials comma)) ",") - (setq ret (std11-parse-at-domain (cdr ret))) - ) - (setq route (append route comma (cdr (car ret)))) - (setq lal (cdr ret)) - ) - (and (setq ret (std11-parse-ascii-token lal)) - (setq colon (car ret)) - (string-equal (cdr (assq 'specials colon)) ":") - (setq route (append route colon)) - ) - )) - (cons (cons 'route route) - (cdr ret) - ) - ))) - -(defun std11-parse-route-addr (lal) - (let ((ret (std11-parse-ascii-token lal)) - < route addr-spec >) - (if (and ret - (setq < (car ret)) - (string-equal (cdr (assq 'specials <)) "<") - (setq lal (cdr ret)) - (progn (and (setq ret (std11-parse-route lal)) - (setq route (cdr (car ret))) - (setq lal (cdr ret)) - ) - (setq ret (std11-parse-addr-spec lal)) - ) - (setq addr-spec (cdr (car ret))) - (setq lal (cdr ret)) - (setq ret (std11-parse-ascii-token lal)) - (setq > (car ret)) - (string-equal (cdr (assq 'specials >)) ">") - ) - (cons (cons 'route-addr (append route addr-spec)) - (cdr ret) - ) - ))) - -(defun std11-parse-phrase-route-addr (lal) - (let ((ret (std11-parse-phrase lal)) phrase) - (if ret - (progn - (setq phrase (cdr (car ret))) - (setq lal (cdr ret)) - )) - (if (setq ret (std11-parse-route-addr lal)) - (cons (list 'phrase-route-addr - phrase - (cdr (car ret))) - (cdr ret)) - ))) - -(defun std11-parse-mailbox (lal) - (let ((ret (or (std11-parse-phrase-route-addr lal) - (std11-parse-addr-spec lal))) - mbox comment) - (if (and ret - (prog1 - (setq mbox (car ret)) - (setq lal (cdr ret)) - (if (and (setq ret (std11-parse-token-or-comment lal)) - (setq comment (cdr (assq 'comment (car ret)))) - ) - (setq lal (cdr ret)) - ))) - (cons (list 'mailbox mbox comment) - lal) - ))) - -(defun std11-parse-group (lal) - (let ((ret (std11-parse-phrase lal)) - phrase colon comma mbox semicolon) - (if (and ret - (setq phrase (cdr (car ret))) - (setq lal (cdr ret)) - (setq ret (std11-parse-ascii-token lal)) - (setq colon (car ret)) - (string-equal (cdr (assq 'specials colon)) ":") - (setq lal (cdr ret)) - (progn - (and (setq ret (std11-parse-mailbox lal)) - (setq mbox (list (car ret))) - (setq lal (cdr ret)) - (progn - (while (and (setq ret (std11-parse-ascii-token lal)) - (setq comma (car ret)) - (string-equal - (cdr (assq 'specials comma)) ",") - (setq lal (cdr ret)) - (setq ret (std11-parse-mailbox lal)) - (setq mbox (cons (car ret) mbox)) - (setq lal (cdr ret)) - ) - ))) - (and (setq ret (std11-parse-ascii-token lal)) - (setq semicolon (car ret)) - (string-equal (cdr (assq 'specials semicolon)) ";") - ))) - (cons (list 'group phrase (nreverse mbox)) - (cdr ret) - ) - ))) - -(defun std11-parse-address (lal) - (or (std11-parse-group lal) - (std11-parse-mailbox lal) - )) - -(defun std11-parse-addresses (lal) - (let ((ret (std11-parse-address lal))) - (if ret - (let ((dest (list (car ret)))) - (setq lal (cdr ret)) - (while (and (setq ret (std11-parse-ascii-token lal)) - (string-equal (cdr (assq 'specials (car ret))) ",") - (setq ret (std11-parse-address (cdr ret))) - ) - (setq dest (cons (car ret) dest)) - (setq lal (cdr ret)) - ) - (nreverse dest) - )))) - - -;;; @ end -;;; - -(provide 'std11-parse) - -;;; std11-parse.el ends here
--- a/lisp/apel/std11.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,373 +0,0 @@ -;;; std11.el --- STD 11 functions for GNU Emacs - -;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Keywords: mail, news, RFC 822, STD 11 -;; Version: $Id: std11.el,v 1.1 1997/06/03 04:18:36 steve Exp $ - -;; This file is part of MU (Message Utilities). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(autoload 'buffer-substring-no-properties "emu") -(autoload 'member "emu") - - -;;; @ field -;;; - -(defconst std11-field-name-regexp "[!-9;-~]+") -(defconst std11-field-head-regexp - (concat "^" std11-field-name-regexp ":")) -(defconst std11-next-field-head-regexp - (concat "\n" std11-field-name-regexp ":")) - -(defun std11-field-end () - "Move to end of field and return this point. [std11.el]" - (if (re-search-forward std11-next-field-head-regexp nil t) - (goto-char (match-beginning 0)) - (if (re-search-forward "^$" nil t) - (goto-char (1- (match-beginning 0))) - (end-of-line) - )) - (point) - ) - -(defun std11-field-body (name &optional boundary) - "Return body of field NAME. -If BOUNDARY is not nil, it is used as message header separator. -\[std11.el]" - (save-excursion - (save-restriction - (std11-narrow-to-header boundary) - (goto-char (point-min)) - (let ((case-fold-search t)) - (if (re-search-forward (concat "^" name ":[ \t]*") nil t) - (buffer-substring-no-properties (match-end 0) (std11-field-end)) - ))))) - -(defun std11-find-field-body (field-names &optional boundary) - "Return the first found field-body specified by FIELD-NAMES -of the message header in current buffer. If BOUNDARY is not nil, it is -used as message header separator. [std11.el]" - (save-excursion - (save-restriction - (std11-narrow-to-header boundary) - (let ((case-fold-search t) - field-name) - (catch 'tag - (while (setq field-name (car field-names)) - (goto-char (point-min)) - (if (re-search-forward (concat "^" field-name ":[ \t]*") nil t) - (throw 'tag - (buffer-substring-no-properties - (match-end 0) (std11-field-end))) - ) - (setq field-names (cdr field-names)) - )))))) - -(defun std11-field-bodies (field-names &optional default-value boundary) - "Return list of each field-bodies of FIELD-NAMES of the message header -in current buffer. If BOUNDARY is not nil, it is used as message -header separator. [std11.el]" - (save-excursion - (save-restriction - (std11-narrow-to-header boundary) - (let* ((case-fold-search t) - (dest (make-list (length field-names) default-value)) - (s-rest field-names) - (d-rest dest) - field-name) - (while (setq field-name (car s-rest)) - (goto-char (point-min)) - (if (re-search-forward (concat "^" field-name ":[ \t]*") nil t) - (setcar d-rest - (buffer-substring-no-properties - (match-end 0) (std11-field-end))) - ) - (setq s-rest (cdr s-rest) - d-rest (cdr d-rest)) - ) - dest)))) - - -;;; @ unfolding -;;; - -(defun std11-unfold-string (string) - "Unfold STRING as message header field. [std11.el]" - (let ((dest "")) - (while (string-match "\n\\([ \t]\\)" string) - (setq dest (concat dest - (substring string 0 (match-beginning 0)) - (match-string 1 string) - )) - (setq string (substring string (match-end 0))) - ) - (concat dest string) - )) - - -;;; @ header -;;; - -(defun std11-narrow-to-header (&optional boundary) - "Narrow to the message header. -If BOUNDARY is not nil, it is used as message header separator. -\[std11.el]" - (narrow-to-region - (goto-char (point-min)) - (if (re-search-forward - (concat "^\\(" (regexp-quote (or boundary "")) "\\)?$") - nil t) - (match-beginning 0) - (point-max) - ))) - -(defun std11-header-string (regexp &optional boundary) - "Return string of message header fields matched by REGEXP. -If BOUNDARY is not nil, it is used as message header separator. -\[std11.el]" - (let ((case-fold-search t)) - (save-excursion - (save-restriction - (std11-narrow-to-header boundary) - (goto-char (point-min)) - (let (field header) - (while (re-search-forward std11-field-head-regexp nil t) - (setq field - (buffer-substring (match-beginning 0) (std11-field-end))) - (if (string-match regexp field) - (setq header (concat header field "\n")) - )) - header) - )))) - -(defun std11-header-string-except (regexp &optional boundary) - "Return string of message header fields not matched by REGEXP. -If BOUNDARY is not nil, it is used as message header separator. -\[std11.el]" - (let ((case-fold-search t)) - (save-excursion - (save-restriction - (std11-narrow-to-header boundary) - (goto-char (point-min)) - (let (field header) - (while (re-search-forward std11-field-head-regexp nil t) - (setq field - (buffer-substring (match-beginning 0) (std11-field-end))) - (if (not (string-match regexp field)) - (setq header (concat header field "\n")) - )) - header) - )))) - -(defun std11-collect-field-names (&optional boundary) - "Return list of all field-names of the message header in current buffer. -If BOUNDARY is not nil, it is used as message header separator. -\[std11.el]" - (save-excursion - (save-restriction - (std11-narrow-to-header boundary) - (goto-char (point-min)) - (let (dest name) - (while (re-search-forward std11-field-head-regexp nil t) - (setq name (buffer-substring-no-properties - (match-beginning 0)(1- (match-end 0)))) - (or (member name dest) - (setq dest (cons name dest)) - ) - ) - dest)))) - - -;;; @ quoted-string -;;; - -(defun std11-wrap-as-quoted-pairs (string specials) - (let (dest - (i 0) - (b 0) - (len (length string)) - ) - (while (< i len) - (let ((chr (aref string i))) - (if (memq chr specials) - (setq dest (concat dest (substring string b i) "\\") - b i) - )) - (setq i (1+ i)) - ) - (concat dest (substring string b)) - )) - -(defconst std11-non-qtext-char-list '(?\" ?\\ ?\r ?\n)) - -(defun std11-wrap-as-quoted-string (string) - "Wrap STRING as RFC 822 quoted-string. [std11.el]" - (concat "\"" - (std11-wrap-as-quoted-pairs string std11-non-qtext-char-list) - "\"")) - -(defun std11-strip-quoted-pair (string) - "Strip quoted-pairs in STRING. [std11.el]" - (let (dest - (b 0) - (i 0) - (len (length string)) - ) - (while (< i len) - (let ((chr (aref string i))) - (if (eq chr ?\\) - (setq dest (concat dest (substring string b i)) - b (1+ i) - i (+ i 2)) - (setq i (1+ i)) - ))) - (concat dest (substring string b)) - )) - -(defun std11-strip-quoted-string (string) - "Strip quoted-string STRING. [std11.el]" - (let ((len (length string))) - (or (and (>= len 2) - (let ((max (1- len))) - (and (eq (aref string 0) ?\") - (eq (aref string max) ?\") - (std11-strip-quoted-pair (substring string 1 max)) - ))) - string))) - - -;;; @ composer -;;; - -(defun std11-addr-to-string (seq) - "Return string from lexical analyzed list SEQ -represents addr-spec of RFC 822. [std11.el]" - (mapconcat (function - (lambda (token) - (let ((name (car token))) - (cond - ((eq name 'spaces) "") - ((eq name 'comment) "") - ((eq name 'quoted-string) - (concat "\"" (cdr token) "\"")) - (t (cdr token))) - ))) - seq "") - ) - -(defun std11-address-string (address) - "Return string of address part from parsed ADDRESS of RFC 822. -\[std11.el]" - (cond ((eq (car address) 'group) - (mapconcat (function std11-address-string) - (car (cdr address)) - ", ") - ) - ((eq (car address) 'mailbox) - (let ((addr (nth 1 address))) - (std11-addr-to-string - (if (eq (car addr) 'phrase-route-addr) - (nth 2 addr) - (cdr addr) - ) - ))))) - -(defun std11-full-name-string (address) - "Return string of full-name part from parsed ADDRESS of RFC 822. -\[std11.el]" - (cond ((eq (car address) 'group) - (mapconcat (function - (lambda (token) - (cdr token) - )) - (nth 1 address) "") - ) - ((eq (car address) 'mailbox) - (let ((addr (nth 1 address)) - (comment (nth 2 address)) - phrase) - (if (eq (car addr) 'phrase-route-addr) - (setq phrase - (mapconcat - (function - (lambda (token) - (let ((type (car token))) - (cond ((eq type 'quoted-string) - (std11-strip-quoted-pair (cdr token)) - ) - ((eq type 'comment) - (concat - "(" - (std11-strip-quoted-pair (cdr token)) - ")") - ) - (t - (cdr token) - ))))) - (nth 1 addr) "")) - ) - (cond ((> (length phrase) 0) phrase) - (comment (std11-strip-quoted-pair comment)) - ) - )))) - - -;;; @ parser -;;; - -(defun std11-parse-address-string (string) - "Parse STRING as mail address. [std11.el]" - (std11-parse-address (std11-lexical-analyze string)) - ) - -(defun std11-parse-addresses-string (string) - "Parse STRING as mail address list. [std11.el]" - (std11-parse-addresses (std11-lexical-analyze string)) - ) - -(defun std11-extract-address-components (string) - "Extract full name and canonical address from STRING. -Returns a list of the form (FULL-NAME CANONICAL-ADDRESS). -If no name can be extracted, FULL-NAME will be nil. [std11.el]" - (let* ((structure (car (std11-parse-address-string - (std11-unfold-string string)))) - (phrase (std11-full-name-string structure)) - (address (std11-address-string structure)) - ) - (list phrase address) - )) - -(provide 'std11) - -(mapcar (function - (lambda (func) - (autoload func "std11-parse") - )) - '(std11-lexical-analyze - std11-parse-address std11-parse-addresses - std11-parse-address-string)) - - -;;; @ end -;;; - -;;; std11.el ends here
--- a/lisp/apel/tinyrich.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,166 +0,0 @@ -;;; -;;; $Id: tinyrich.el,v 1.2 1997/07/26 22:09:38 steve Exp $ -;;; -;;; by MORIOKA Tomohiko <morioka@jaist.ac.jp> -;;; modified by YAMATE Keiichirou <ics9118@sem1.info.osaka-cu.ac.jp> -;;; - -(defvar mime-viewer/face-list-for-text/enriched - (cond ((and (>= emacs-major-version 19) window-system) - '(bold italic fixed underline) - ) - ((and (boundp 'NEMACS) NEMACS) - '("bold" "italic" "underline") - ))) - -(defun enriched-decode (beg end) - (interactive "*r") - (save-excursion - (save-restriction - (narrow-to-region beg end) - (goto-char beg) - (while (re-search-forward "[ \t]*\\(\n+\\)[ \t]*" nil t) - (let ((str (buffer-substring (match-beginning 1) - (match-end 1)))) - (if (string= str "\n") - (replace-match " ") - (replace-match (substring str 1)) - ))) - (goto-char beg) - (let (cmd sym str (fb (point)) fe b e) - (while (re-search-forward "<\\(<\\|[^<>\n\r \t]+>\\)" nil t) - (setq b (match-beginning 0)) - (setq cmd (buffer-substring b (match-end 0))) - (if (string= cmd "<<") - (replace-match "<") - (replace-match "") - (setq cmd (downcase (substring cmd 1 (- (length cmd) 1)))) - ) - (setq sym (intern cmd)) - (cond ((eq sym 'param) - (setq b (point)) - (save-excursion - (save-restriction - (if (search-forward "</param>" nil t) - (progn - (replace-match "") - (setq e (point)) - ) - (setq e end) - ))) - (delete-region b e) - ) - ((memq sym mime-viewer/face-list-for-text/enriched) - (setq b (point)) - (save-excursion - (save-restriction - (if (re-search-forward (concat "</" cmd ">") nil t) - (progn - (replace-match "") - (setq e (point)) - ) - (setq e end) - ))) - (tm:set-face-region b e sym) - ))) - (goto-char (point-max)) - (if (not (eq (preceding-char) ?\n)) - (insert "\n") - ) - )))) - - -;;; @ text/richtext <-> text/enriched converter -;;; - -(defun richtext-to-enriched-region (beg end) - "Convert the region of text/richtext style to text/enriched style." - (save-excursion - (save-restriction - (narrow-to-region beg end) - (goto-char (point-min)) - (let (b e i) - (while (re-search-forward "[ \t]*<comment>" nil t) - (setq b (match-beginning 0)) - (delete-region b - (if (re-search-forward "</comment>[ \t]*" nil t) - (match-end 0) - (point-max) - )) - ) - (goto-char (point-min)) - (while (re-search-forward "\n\n+" nil t) - (replace-match "\n") - ) - (goto-char (point-min)) - (while (re-search-forward "[ \t\n]*<nl>[ \t\n]*" nil t) - (setq b (match-beginning 0)) - (setq e (match-end 0)) - (setq i 1) - (while (looking-at "[ \t\n]*<nl>[ \t\n]*") - (setq e (match-end 0)) - (setq i (1+ i)) - (goto-char e) - ) - (delete-region b e) - (while (>= i 0) - (insert "\n") - (setq i (1- i)) - )) - (goto-char (point-min)) - (while (search-forward "<lt>" nil t) - (replace-match "<<") - ) - )))) - -(defun enriched-to-richtext-region (beg end) - "Convert the region of text/enriched style to text/richtext style." - (save-excursion - (save-restriction - (goto-char beg) - (and (search-forward "text/enriched") - (replace-match "text/richtext")) - (search-forward "\n\n") - (narrow-to-region (match-end 0) end) - (let (str n) - (goto-char (point-min)) - (while (re-search-forward "\n\n+" nil t) - (setq str (buffer-substring (match-beginning 0) - (match-end 0))) - (setq n (1- (length str))) - (setq str "") - (while (> n 0) - (setq str (concat str "<nl>\n")) - (setq n (1- n)) - ) - (replace-match str) - ) - (goto-char (point-min)) - (while (search-forward "<<" nil t) - (replace-match "<lt>") - ) - )))) - - -;;; @ encoder and decoder -;;; - -(defun richtext-decode (beg end) - (save-restriction - (narrow-to-region beg end) - (richtext-to-enriched-region beg (point-max)) - (enriched-decode beg (point-max)) - )) - -;; (defun richtext-encode (beg end) -;; (save-restriction -;; (narrow-to-region beg end) -;; (enriched-encode beg (point-max)) -;; (enriched-to-richtext-region beg (point-max)) -;; )) - - -;;; @ end -;;; - -(provide 'tinyrich)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/auto-autoloads.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,638 @@ +;;; DO NOT MODIFY THIS FILE +(if (featurep 'TopLevel-autoloads) (error "Already loaded")) + +;;;### (autoloads (batch-byte-recompile-directory batch-byte-recompile-directory-norecurse batch-byte-compile display-call-tree byte-compile-sexp byte-compile compile-defun byte-compile-file byte-recompile-file byte-recompile-directory byte-force-recompile) "bytecomp" "lisp/bytecomp.el") + +(autoload 'byte-force-recompile "bytecomp" "\ +Recompile every `.el' file in DIRECTORY that already has a `.elc' file. +Files in subdirectories of DIRECTORY are processed also." t nil) + +(autoload 'byte-recompile-directory "bytecomp" "\ +Recompile every `.el' file in DIRECTORY that needs recompilation. +This is if a `.elc' file exists but is older than the `.el' file. +Files in subdirectories of DIRECTORY are processed also unless argument +NORECURSION is non-nil. + +If the `.elc' file does not exist, normally the `.el' file is *not* compiled. +But a prefix argument (optional second arg) means ask user, +for each such `.el' file, whether to compile it. Prefix argument 0 means +don't ask and compile the file anyway. + +A nonzero prefix argument also means ask about each subdirectory. + +If the fourth argument FORCE is non-nil, +recompile every `.el' file that already has a `.elc' file." t nil) + +(autoload 'byte-recompile-file "bytecomp" "\ +Recompile a file of Lisp code named FILENAME if it needs recompilation. +This is if the `.elc' file exists but is older than the `.el' file. + +If the `.elc' file does not exist, normally the `.el' file is *not* +compiled. But a prefix argument (optional second arg) means ask user +whether to compile it. Prefix argument 0 don't ask and recompile anyway." t nil) + +(autoload 'byte-compile-file "bytecomp" "\ +Compile a file of Lisp code named FILENAME into a file of byte code. +The output file's name is made by appending `c' to the end of FILENAME. +With prefix arg (noninteractively: 2nd arg), load the file after compiling." t nil) + +(autoload 'compile-defun "bytecomp" "\ +Compile and evaluate the current top-level form. +Print the result in the minibuffer. +With argument, insert value in current buffer after the form." t nil) + +(autoload 'byte-compile "bytecomp" "\ +If FORM is a symbol, byte-compile its function definition. +If FORM is a lambda or a macro, byte-compile it as a function." nil nil) + +(autoload 'byte-compile-sexp "bytecomp" "\ +Compile and return SEXP." nil nil) + +(autoload 'display-call-tree "bytecomp" "\ +Display a call graph of a specified file. +This lists which functions have been called, what functions called +them, and what functions they call. The list includes all functions +whose definitions have been compiled in this Emacs session, as well as +all functions called by those functions. + +The call graph does not include macros, inline functions, or +primitives that the byte-code interpreter knows about directly (eq, +cons, etc.). + +The call tree also lists those functions which are not known to be called +\(that is, to which no calls have been compiled), and which cannot be +invoked interactively." t nil) + +(autoload 'batch-byte-compile "bytecomp" "\ +Run `byte-compile-file' 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 \"emacs -batch -f batch-byte-compile $emacs/ ~/*.el\"" nil nil) + +(autoload 'batch-byte-recompile-directory-norecurse "bytecomp" "\ +Same as `batch-byte-recompile-directory' but without recursion." nil nil) + +(autoload 'batch-byte-recompile-directory "bytecomp" "\ +Runs `byte-recompile-directory' on the dirs remaining on the command line. +Must be used only with `-batch', and kills Emacs on completion. +For example, invoke `xemacs -batch -f batch-byte-recompile-directory .'." nil nil) + +;;;*** + +;;;### (autoloads (compiler-macroexpand define-compiler-macro ignore-errors assert check-type typep deftype cl-struct-setf-expander defstruct define-modify-macro callf2 callf letf* letf rotatef shiftf remf cl-do-pop psetf setf get-setf-method defsetf define-setf-method declare the locally multiple-value-setq multiple-value-bind lexical-let* lexical-let symbol-macrolet macrolet labels flet progv psetq do-all-symbols do-symbols dotimes dolist do* do loop return-from return block etypecase typecase ecase case load-time-value eval-when destructuring-bind function* defmacro* defun* gentemp gensym cl-compile-time-init) "cl-macs" "lisp/cl-macs.el") + +(autoload 'cl-compile-time-init "cl-macs" nil nil nil) + +(autoload 'gensym "cl-macs" "\ +Generate a new uninterned symbol. +The name is made by appending a number to PREFIX, default \"G\"." nil nil) + +(autoload 'gentemp "cl-macs" "\ +Generate a new interned symbol with a unique name. +The name is made by appending a number to PREFIX, default \"G\"." nil nil) + +(autoload 'defun* "cl-macs" "\ +(defun* NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function. +Like normal `defun', except ARGLIST allows full Common Lisp conventions, +and BODY is implicitly surrounded by (block NAME ...)." nil 'macro) + +(autoload 'defmacro* "cl-macs" "\ +(defmacro* NAME ARGLIST [DOCSTRING] BODY...): define NAME as a macro. +Like normal `defmacro', except ARGLIST allows full Common Lisp conventions, +and BODY is implicitly surrounded by (block NAME ...)." nil 'macro) + +(autoload 'function* "cl-macs" "\ +(function* SYMBOL-OR-LAMBDA): introduce a function. +Like normal `function', except that if argument is a lambda form, its +ARGLIST allows full Common Lisp conventions." nil 'macro) + +(autoload 'destructuring-bind "cl-macs" nil nil 'macro) + +(autoload 'eval-when "cl-macs" "\ +(eval-when (WHEN...) BODY...): control when BODY is evaluated. +If `compile' is in WHEN, BODY is evaluated when compiled at top-level. +If `load' is in WHEN, BODY is evaluated when loaded after top-level compile. +If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level." nil 'macro) + +(autoload 'load-time-value "cl-macs" "\ +Like `progn', but evaluates the body at load time. +The result of the body appears to the compiler as a quoted constant." nil 'macro) + +(autoload 'case "cl-macs" "\ +(case EXPR CLAUSES...): evals EXPR, chooses from CLAUSES on that value. +Each clause looks like (KEYLIST BODY...). EXPR is evaluated and compared +against each key in each KEYLIST; the corresponding BODY is evaluated. +If no clause succeeds, case returns nil. A single atom may be used in +place of a KEYLIST of one atom. A KEYLIST of `t' or `otherwise' is +allowed only in the final clause, and matches if no other keys match. +Key values are compared by `eql'." nil 'macro) + +(autoload 'ecase "cl-macs" "\ +(ecase EXPR CLAUSES...): like `case', but error if no case fits. +`otherwise'-clauses are not allowed." nil 'macro) + +(autoload 'typecase "cl-macs" "\ +(typecase EXPR CLAUSES...): evals EXPR, chooses from CLAUSES on that value. +Each clause looks like (TYPE BODY...). EXPR is evaluated and, if it +satisfies TYPE, the corresponding BODY is evaluated. If no clause succeeds, +typecase returns nil. A TYPE of `t' or `otherwise' is allowed only in the +final clause, and matches if no other keys match." nil 'macro) + +(autoload 'etypecase "cl-macs" "\ +(etypecase EXPR CLAUSES...): like `typecase', but error if no case fits. +`otherwise'-clauses are not allowed." nil 'macro) + +(autoload 'block "cl-macs" "\ +(block NAME BODY...): define a lexically-scoped block named NAME. +NAME may be any symbol. Code inside the BODY forms can call `return-from' +to jump prematurely out of the block. This differs from `catch' and `throw' +in two respects: First, the NAME is an unevaluated symbol rather than a +quoted symbol or other form; and second, NAME is lexically rather than +dynamically scoped: Only references to it within BODY will work. These +references may appear inside macro expansions, but not inside functions +called from BODY." nil 'macro) + +(autoload 'return "cl-macs" "\ +(return [RESULT]): return from the block named nil. +This is equivalent to `(return-from nil RESULT)'." nil 'macro) + +(autoload 'return-from "cl-macs" "\ +(return-from NAME [RESULT]): return from the block named NAME. +This jump out to the innermost enclosing `(block NAME ...)' form, +returning RESULT from that form (or nil if RESULT is omitted). +This is compatible with Common Lisp, but note that `defun' and +`defmacro' do not create implicit blocks as they do in Common Lisp." nil 'macro) + +(autoload 'loop "cl-macs" "\ +(loop CLAUSE...): The Common Lisp `loop' macro. +Valid clauses are: + for VAR from/upfrom/downfrom NUM to/upto/downto/above/below NUM by NUM, + for VAR in LIST by FUNC, for VAR on LIST by FUNC, for VAR = INIT then EXPR, + for VAR across ARRAY, repeat NUM, with VAR = INIT, while COND, until COND, + always COND, never COND, thereis COND, collect EXPR into VAR, + append EXPR into VAR, nconc EXPR into VAR, sum EXPR into VAR, + count EXPR into VAR, maximize EXPR into VAR, minimize EXPR into VAR, + if COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...], + unless COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...], + do EXPRS..., initially EXPRS..., finally EXPRS..., return EXPR, + finally return EXPR, named NAME." nil 'macro) + +(autoload 'do "cl-macs" "\ +The Common Lisp `do' loop. +Format is: (do ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" nil 'macro) + +(autoload 'do* "cl-macs" "\ +The Common Lisp `do*' loop. +Format is: (do* ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" nil 'macro) + +(autoload 'dolist "cl-macs" "\ +(dolist (VAR LIST [RESULT]) BODY...): loop over a list. +Evaluate BODY with VAR bound to each `car' from LIST, in turn. +Then evaluate RESULT to get return value, default nil." nil 'macro) + +(autoload 'dotimes "cl-macs" "\ +(dotimes (VAR COUNT [RESULT]) BODY...): loop a certain number of times. +Evaluate BODY with VAR bound to successive integers from 0, inclusive, +to COUNT, exclusive. Then evaluate RESULT to get return value, default +nil." nil 'macro) + +(autoload 'do-symbols "cl-macs" "\ +(dosymbols (VAR [OBARRAY [RESULT]]) BODY...): loop over all symbols. +Evaluate BODY with VAR bound to each interned symbol, or to each symbol +from OBARRAY." nil 'macro) + +(autoload 'do-all-symbols "cl-macs" nil nil 'macro) + +(autoload 'psetq "cl-macs" "\ +(psetq SYM VAL SYM VAL ...): set SYMs to the values VALs in parallel. +This is like `setq', except that all VAL forms are evaluated (in order) +before assigning any symbols SYM to the corresponding values." nil 'macro) + +(autoload 'progv "cl-macs" "\ +(progv SYMBOLS VALUES BODY...): bind SYMBOLS to VALUES dynamically in BODY. +The forms SYMBOLS and VALUES are evaluated, and must evaluate to lists. +Each SYMBOL in the first list is bound to the corresponding VALUE in the +second list (or made unbound if VALUES is shorter than SYMBOLS); then the +BODY forms are executed and their result is returned. This is much like +a `let' form, except that the list of symbols can be computed at run-time." nil 'macro) + +(autoload 'flet "cl-macs" "\ +(flet ((FUNC ARGLIST BODY...) ...) FORM...): make temporary function defns. +This is an analogue of `let' that operates on the function cell of FUNC +rather than its value cell. The FORMs are evaluated with the specified +function definitions in place, then the definitions are undone (the FUNCs +go back to their previous definitions, or lack thereof)." nil 'macro) + +(autoload 'labels "cl-macs" "\ +(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." nil 'macro) + +(autoload 'macrolet "cl-macs" "\ +(macrolet ((NAME ARGLIST BODY...) ...) FORM...): make temporary macro defns. +This is like `flet', but for macros instead of functions." nil 'macro) + +(autoload 'symbol-macrolet "cl-macs" "\ +(symbol-macrolet ((NAME EXPANSION) ...) FORM...): make symbol macro defns. +Within the body FORMs, references to the variable NAME will be replaced +by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...)." nil 'macro) + +(autoload 'lexical-let "cl-macs" "\ +(lexical-let BINDINGS BODY...): like `let', but lexically scoped. +The main visible difference is that lambdas inside BODY will create +lexical closures as in Common Lisp." nil 'macro) + +(autoload 'lexical-let* "cl-macs" "\ +(lexical-let* BINDINGS BODY...): like `let*', but lexically scoped. +The main visible difference is that lambdas inside BODY will create +lexical closures as in Common Lisp." nil 'macro) + +(autoload 'multiple-value-bind "cl-macs" "\ +(multiple-value-bind (SYM SYM...) FORM BODY): collect multiple return values. +FORM must return a list; the BODY is then executed with the first N elements +of this list bound (`let'-style) to each of the symbols SYM in turn. This +is analogous to the Common Lisp `multiple-value-bind' macro, using lists to +simulate true multiple return values. For compatibility, (values A B C) is +a synonym for (list A B C)." nil 'macro) + +(autoload 'multiple-value-setq "cl-macs" "\ +(multiple-value-setq (SYM SYM...) FORM): collect multiple return values. +FORM must return a list; the first N elements of this list are stored in +each of the symbols SYM in turn. This is analogous to the Common Lisp +`multiple-value-setq' macro, using lists to simulate true multiple return +values. For compatibility, (values A B C) is a synonym for (list A B C)." nil 'macro) + +(autoload 'locally "cl-macs" nil nil 'macro) + +(autoload 'the "cl-macs" nil nil 'macro) + +(autoload 'declare "cl-macs" nil nil 'macro) + +(autoload 'define-setf-method "cl-macs" "\ +(define-setf-method NAME ARGLIST BODY...): define a `setf' method. +This method shows how to handle `setf's to places of the form (NAME ARGS...). +The argument forms ARGS are bound according to ARGLIST, as if NAME were +going to be expanded as a macro, then the BODY forms are executed and must +return a list of five elements: a temporary-variables list, a value-forms +list, a store-variables list (of length one), a store-form, and an access- +form. See `defsetf' for a simpler way to define most setf-methods." nil 'macro) + +(autoload 'defsetf "cl-macs" "\ +(defsetf NAME FUNC): define a `setf' method. +This macro is an easy-to-use substitute for `define-setf-method' that works +well for simple place forms. In the simple `defsetf' form, `setf's of +the form (setf (NAME ARGS...) VAL) are transformed to function or macro +calls of the form (FUNC ARGS... VAL). Example: (defsetf aref aset). +Alternate form: (defsetf NAME ARGLIST (STORE) BODY...). +Here, the above `setf' call is expanded by binding the argument forms ARGS +according to ARGLIST, binding the value form VAL to STORE, then executing +BODY, which must return a Lisp form that does the necessary `setf' operation. +Actually, ARGLIST and STORE may be bound to temporary variables which are +introduced automatically to preserve proper execution order of the arguments. +Example: (defsetf nth (n x) (v) (list 'setcar (list 'nthcdr n x) v))." nil 'macro) + +(autoload 'get-setf-method "cl-macs" "\ +Return a list of five values describing the setf-method for PLACE. +PLACE may be any Lisp form which can appear as the PLACE argument to +a macro like `setf' or `incf'." nil nil) + +(autoload 'setf "cl-macs" "\ +(setf PLACE VAL PLACE VAL ...): set each PLACE to the value of its VAL. +This is a generalized version of `setq'; the PLACEs may be symbolic +references such as (car x) or (aref x i), as well as plain symbols. +For example, (setf (cadar x) y) is equivalent to (setcar (cdar x) y). +The return value is the last VAL in the list." nil 'macro) + +(autoload 'psetf "cl-macs" "\ +(psetf PLACE VAL PLACE VAL ...): set PLACEs to the values VALs in parallel. +This is like `setf', except that all VAL forms are evaluated (in order) +before assigning any PLACEs to the corresponding values." nil 'macro) + +(autoload 'cl-do-pop "cl-macs" nil nil nil) + +(autoload 'remf "cl-macs" "\ +(remf PLACE TAG): remove TAG from property list PLACE. +PLACE may be a symbol, or any generalized variable allowed by `setf'. +The form returns true if TAG was found and removed, nil otherwise." nil 'macro) + +(autoload 'shiftf "cl-macs" "\ +(shiftf PLACE PLACE... VAL): shift left among PLACEs. +Example: (shiftf A B C) sets A to B, B to C, and returns the old A. +Each PLACE may be a symbol, or any generalized variable allowed by `setf'." nil 'macro) + +(autoload 'rotatef "cl-macs" "\ +(rotatef PLACE...): rotate left among PLACEs. +Example: (rotatef A B C) sets A to B, B to C, and C to A. It returns nil. +Each PLACE may be a symbol, or any generalized variable allowed by `setf'." nil 'macro) + +(autoload 'letf "cl-macs" "\ +(letf ((PLACE VALUE) ...) BODY...): temporarily bind to PLACEs. +This is the analogue of `let', but with generalized variables (in the +sense of `setf') for the PLACEs. Each PLACE is set to the corresponding +VALUE, then the BODY forms are executed. On exit, either normally or +because of a `throw' or error, the PLACEs are set back to their original +values. Note that this macro is *not* available in Common Lisp. +As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)', +the PLACE is not modified before executing BODY." nil 'macro) + +(autoload 'letf* "cl-macs" "\ +(letf* ((PLACE VALUE) ...) BODY...): temporarily bind to PLACEs. +This is the analogue of `let*', but with generalized variables (in the +sense of `setf') for the PLACEs. Each PLACE is set to the corresponding +VALUE, then the BODY forms are executed. On exit, either normally or +because of a `throw' or error, the PLACEs are set back to their original +values. Note that this macro is *not* available in Common Lisp. +As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)', +the PLACE is not modified before executing BODY." nil 'macro) + +(autoload 'callf "cl-macs" "\ +(callf FUNC PLACE ARGS...): set PLACE to (FUNC PLACE ARGS...). +FUNC should be an unquoted function name. PLACE may be a symbol, +or any generalized variable allowed by `setf'." nil 'macro) + +(autoload 'callf2 "cl-macs" "\ +(callf2 FUNC ARG1 PLACE ARGS...): set PLACE to (FUNC ARG1 PLACE ARGS...). +Like `callf', but PLACE is the second argument of FUNC, not the first." nil 'macro) + +(autoload 'define-modify-macro "cl-macs" "\ +(define-modify-macro NAME ARGLIST FUNC): define a `setf'-like modify macro. +If NAME is called, it combines its PLACE argument with the other arguments +from ARGLIST using FUNC: (define-modify-macro incf (&optional (n 1)) +)" nil 'macro) + +(autoload 'defstruct "cl-macs" "\ +(defstruct (NAME OPTIONS...) (SLOT SLOT-OPTS...)...): define a struct type. +This macro defines a new Lisp data type called NAME, which contains data +stored in SLOTs. This defines a `make-NAME' constructor, a `copy-NAME' +copier, a `NAME-p' predicate, and setf-able `NAME-SLOT' accessors." nil 'macro) + +(autoload 'cl-struct-setf-expander "cl-macs" nil nil nil) + +(autoload 'deftype "cl-macs" "\ +(deftype NAME ARGLIST BODY...): define NAME as a new data type. +The type name can then be used in `typecase', `check-type', etc." nil 'macro) + +(autoload 'typep "cl-macs" "\ +Check that OBJECT is of type TYPE. +TYPE is a Common Lisp-style type specifier." nil nil) + +(autoload 'check-type "cl-macs" "\ +Verify that FORM is of type TYPE; signal an error if not. +STRING is an optional description of the desired type." nil 'macro) + +(autoload 'assert "cl-macs" "\ +Verify that FORM returns non-nil; signal an error if not. +Second arg SHOW-ARGS means to include arguments of FORM in message. +Other args STRING and ARGS... are arguments to be passed to `error'. +They are not evaluated unless the assertion fails. If STRING is +omitted, a default message listing FORM itself is used." nil 'macro) + +(autoload 'ignore-errors "cl-macs" "\ +Execute FORMS; if an error occurs, return nil. +Otherwise, return result of last FORM." nil 'macro) + +(autoload 'define-compiler-macro "cl-macs" "\ +(define-compiler-macro FUNC ARGLIST BODY...): Define a compiler-only macro. +This is like `defmacro', but macro expansion occurs only if the call to +FUNC is compiled (i.e., not interpreted). Compiler macros should be used +for optimizing the way calls to FUNC are compiled; the form returned by +BODY should do the same thing as a call to the normal function called +FUNC, though possibly more efficiently. Note that, like regular macros, +compiler macros are expanded repeatedly until no further expansions are +possible. Unlike regular macros, BODY can decide to \"punt\" and leave the +original function call alone by declaring an initial `&whole foo' parameter +and then returning foo." nil 'macro) + +(autoload 'compiler-macroexpand "cl-macs" nil nil nil) + +;;;*** + +;;;### (autoloads (Custom-make-dependencies) "cus-dep" "lisp/cus-dep.el") + +(autoload 'Custom-make-dependencies "cus-dep" "\ +Extract custom dependencies from .el files in SUBDIRS. +SUBDIRS is a list of directories. If it is nil, the command-line +arguments are used. If it is a string, only that directory is +processed. This function is especially useful in batch mode. + +Batch usage: xemacs -batch -l cus-dep.el -f Custom-make-dependencies DIRS" t nil) + +;;;*** + +;;;### (autoloads (customize-menu-create custom-menu-create custom-save-all customize-save-customized customize-browse custom-buffer-create-other-window custom-buffer-create customize-apropos-groups customize-apropos-faces customize-apropos-options customize-apropos customize-saved customize-customized customize-face-other-window customize-face customize-option-other-window customize-variable customize-other-window customize customize-save-variable customize-set-variable customize-set-value) "cus-edit" "lisp/cus-edit.el") + +(autoload 'customize-set-value "cus-edit" "\ +Set VARIABLE to VALUE. VALUE is a Lisp object. + +If VARIABLE has a `variable-interactive' property, that is used as if +it were the arg to `interactive' (which see) to interactively read the value. + +If VARIABLE has a `custom-type' property, it must be a widget and the +`:prompt-value' property of that widget will be used for reading the value." t nil) + +(autoload 'customize-set-variable "cus-edit" "\ +Set the default for VARIABLE to VALUE. VALUE is a Lisp object. + +If VARIABLE has a `custom-set' property, that is used for setting +VARIABLE, otherwise `set-default' is used. + +The `customized-value' property of the VARIABLE will be set to a list +with a quoted VALUE as its sole list member. + +If VARIABLE has a `variable-interactive' property, that is used as if +it were the arg to `interactive' (which see) to interactively read the value. + +If VARIABLE has a `custom-type' property, it must be a widget and the +`:prompt-value' property of that widget will be used for reading the value. " t nil) + +(autoload 'customize-save-variable "cus-edit" "\ +Set the default for VARIABLE to VALUE, and save it for future sessions. +If VARIABLE has a `custom-set' property, that is used for setting +VARIABLE, otherwise `set-default' is used. + +The `customized-value' property of the VARIABLE will be set to a list +with a quoted VALUE as its sole list member. + +If VARIABLE has a `variable-interactive' property, that is used as if +it were the arg to `interactive' (which see) to interactively read the value. + +If VARIABLE has a `custom-type' property, it must be a widget and the +`:prompt-value' property of that widget will be used for reading the value. " t nil) + +(autoload 'customize "cus-edit" "\ +Select a customization buffer which you can use to set user options. +User options are structured into \"groups\". +The default group is `Emacs'." t nil) + +(defalias 'customize-group 'customize) + +(autoload 'customize-other-window "cus-edit" "\ +Customize SYMBOL, which must be a customization group." t nil) + +(defalias 'customize-group-other-window 'customize-other-window) + +(defalias 'customize-option 'customize-variable) + +(autoload 'customize-variable "cus-edit" "\ +Customize SYMBOL, which must be a user option variable." t nil) + +(defalias 'customize-variable-other-window 'customize-option-other-window) + +(autoload 'customize-option-other-window "cus-edit" "\ +Customize SYMBOL, which must be a user option variable. +Show the buffer in another window, but don't select it." t nil) + +(autoload 'customize-face "cus-edit" "\ +Customize SYMBOL, which should be a face name or nil. +If SYMBOL is nil, customize all faces." t nil) + +(autoload 'customize-face-other-window "cus-edit" "\ +Show customization buffer for FACE in other window." t nil) + +(autoload 'customize-customized "cus-edit" "\ +Customize all user options set since the last save in this session." t nil) + +(autoload 'customize-saved "cus-edit" "\ +Customize all already saved user options." t nil) + +(autoload 'customize-apropos "cus-edit" "\ +Customize all user options matching REGEXP. +If ALL is `options', include only options. +If ALL is `faces', include only faces. +If ALL is `groups', include only groups. +If ALL is t (interactively, with prefix arg), include options which are not +user-settable, as well as faces and groups." t nil) + +(autoload 'customize-apropos-options "cus-edit" "\ +Customize all user options matching REGEXP. +With prefix arg, include options which are not user-settable." t nil) + +(autoload 'customize-apropos-faces "cus-edit" "\ +Customize all user faces matching REGEXP." t nil) + +(autoload 'customize-apropos-groups "cus-edit" "\ +Customize all user groups matching REGEXP." t nil) + +(autoload 'custom-buffer-create "cus-edit" "\ +Create a buffer containing OPTIONS. +Optional NAME is the name of the buffer. +OPTIONS should be an alist of the form ((SYMBOL WIDGET)...), where +SYMBOL is a customization option, and WIDGET is a widget for editing +that option." nil nil) + +(autoload 'custom-buffer-create-other-window "cus-edit" "\ +Create a buffer containing OPTIONS. +Optional NAME is the name of the buffer. +OPTIONS should be an alist of the form ((SYMBOL WIDGET)...), where +SYMBOL is a customization option, and WIDGET is a widget for editing +that option." nil nil) + +(autoload 'customize-browse "cus-edit" "\ +Create a tree browser for the customize hierarchy." t nil) + +(defcustom custom-file (if (boundp 'emacs-user-extension-dir) (concat "~" init-file-user emacs-user-extension-dir "options.el") "~/.emacs") "File used for storing customization information.\nIf you change this from the default \"~/.emacs\" you need to\nexplicitly load that file for the settings to take effect." :type 'file :group 'customize) + +(autoload 'customize-save-customized "cus-edit" "\ +Save all user options which have been set in this session." t nil) + +(autoload 'custom-save-all "cus-edit" "\ +Save all customizations in `custom-file'." nil nil) + +(autoload 'custom-menu-create "cus-edit" "\ +Create menu for customization group SYMBOL. +The menu is in a format applicable to `easy-menu-define'." nil nil) + +(autoload 'customize-menu-create "cus-edit" "\ +Return a customize menu for customization group SYMBOL. +If optional NAME is given, use that as the name of the menu. +Otherwise the menu will be named `Customize'. +The format is suitable for use with `easy-menu-define'." nil nil) + +;;;*** + +;;;### (autoloads (custom-set-faces custom-declare-face) "cus-face" "lisp/cus-face.el") + +(autoload 'custom-declare-face "cus-face" "\ +Like `defface', but FACE is evaluated as a normal argument." nil nil) + +(autoload 'custom-set-faces "cus-face" "\ +Initialize faces according to user preferences. +The arguments should be a list where each entry has the form: + + (FACE SPEC [NOW]) + +SPEC will be stored as the saved value for FACE. If NOW is present +and non-nil, FACE will also be created according to SPEC. + +See `defface' for the format of SPEC." nil nil) + +;;;*** + +;;;### (autoloads (disassemble) "disass" "lisp/disass.el") + +(autoload 'disassemble "disass" "\ +Print disassembled code for OBJECT in (optional) BUFFER. +OBJECT can be a symbol defined as a function, or a function itself +\(a lambda expression or a compiled-function object). +If OBJECT is not already compiled, we compile it, but do not +redefine OBJECT if it is a symbol." t nil) + +;;;*** + +;;;### (autoloads (widget-minor-mode widget-browse-other-window widget-browse widget-browse-at) "wid-browse" "lisp/wid-browse.el") + +(autoload 'widget-browse-at "wid-browse" "\ +Browse the widget under point." t nil) + +(autoload 'widget-browse "wid-browse" "\ +Create a widget browser for WIDGET." t nil) + +(autoload 'widget-browse-other-window "wid-browse" "\ +Show widget browser for WIDGET in other window." t nil) + +(autoload 'widget-minor-mode "wid-browse" "\ +Togle minor mode for traversing widgets. +With arg, turn widget mode on if and only if arg is positive." t nil) + +;;;*** + +;;;### (autoloads (widget-delete widget-create widget-prompt-value) "wid-edit" "lisp/wid-edit.el") + +(autoload 'widget-prompt-value "wid-edit" "\ +Prompt for a value matching WIDGET, using PROMPT. +The current value is assumed to be VALUE, unless UNBOUND is non-nil." nil nil) + +(autoload 'widget-create "wid-edit" "\ +Create widget of TYPE. +The optional ARGS are additional keyword arguments." nil nil) + +(autoload 'widget-delete "wid-edit" "\ +Delete WIDGET." nil nil) + +;;;*** + +;;;### (autoloads (font-menu-weight-constructor font-menu-size-constructor font-menu-family-constructor reset-device-font-menus) "x-font-menu" "lisp/x-font-menu.el") + +(defcustom font-menu-ignore-scaled-fonts t "*If non-nil, then the font menu will try to show only bitmap fonts." :type 'boolean :group 'x) + +(defcustom font-menu-this-frame-only-p nil "*If non-nil, then changing the default font from the font menu will only\naffect one frame instead of all frames." :type 'boolean :group 'x) + +(fset 'install-font-menus 'reset-device-font-menus) + +(autoload 'reset-device-font-menus "x-font-menu" "\ +Generates the `Font', `Size', and `Weight' submenus for the Options menu. +This is run the first time that a font-menu is needed for each device. +If you don't like the lazy invocation of this function, you can add it to +`create-device-hook' and that will make the font menus respond more quickly +when they are selected for the first time. If you add fonts to your system, +or if you change your font path, you can call this to re-initialize the menus." nil nil) + +(autoload 'font-menu-family-constructor "x-font-menu" nil nil nil) + +(autoload 'font-menu-size-constructor "x-font-menu" nil nil nil) + +(autoload 'font-menu-weight-constructor "x-font-menu" nil nil nil) + +;;;*** + +(provide 'TopLevel-autoloads)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/auto-save.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,547 @@ +;;; auto-save.el -- Safer autosaving for EFS and tmp. + +;; Copyright (C) 1997 Free Software Foundation, Inc. +;; Copyright (C) 1992 by Sebastian Kremer <sk@thp.uni-koeln.de> + +;; Author: Sebastian Kremer <sk@thp.uni-koeln.de> +;; Maintainer: XEmacs Development Team +;; Keywords: extensions, dumped +;; Version: 1.26 + +;; 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 1, 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: + +;; This file is dumped with XEmacs. + +;; Combines autosaving for efs (to a local or remote directory) +;; with the ability to do autosaves to a fixed directory on a local +;; disk, in case NFS is slow. The auto-save file used for +;; /usr/foo/bar/baz.txt +;; will be +;; AUTOSAVE/#\!usr\!foo\!bar\!baz.txt# +;; assuming AUTOSAVE is the non-nil value of the variable +;; `auto-save-directory'. + +;; Takes care that autosave files for non-file-buffers (e.g. *mail*) +;; from two simultaneous Emacses don't collide. + +;; Autosaves even if the current directory is not writable. + +;; Can limit autosave names to 14 characters using a hash function, +;; see `auto-save-hash-p'. + +;; See `auto-save-directory' and `make-auto-save-file-name' and +;; references therein for complete documentation. + +;; `M-x recover-all-files' will effectively do recover-file on all +;; files whose autosave file is newer (one of the benefits of having +;; all autosave files in the same place). + +;; This file is dumped with XEmacs. + +;; If you want to autosave in the fixed directory /tmp/USER-autosave/ +;; (setq auto-save-directory +;; (concat "/tmp/" (user-login-name) "-autosave/")) + +;; If you don't want to save in /tmp (e.g., because it is swap +;; mounted) but rather in ~/autosave/ +;; (setq auto-save-directory (expand-file-name "~/.autosave/")) + +;; If you want to save each file in its own directory (the default) +;; (setq auto-save-directory nil) +;; You still can take advantage of autosaving efs remote files +;; in a fixed local directory, `auto-save-directory-fallback' will +;; be used. + +;; If you want to use 14 character hashed autosave filenames +;; (setq auto-save-hash-p t) + +;; Finally, put this line after the others in your ~/.emacs: +;; (require 'auto-save) + + +;;; Acknowledgement: + +;; This code is loosely derived from autosave-in-tmp.el by Jamie +;; Zawinski <jwz@netscape.com> (the version I had was last modified 22 +;; dec 90 jwz) and code submitted to ange-ftp-lovers on Sun, 5 Apr +;; 92 23:20:47 EDT by drw@BOURBAKI.MIT.EDU (Dale R. Worley). +;; auto-save.el tries to cover the functionality of those two +;; packages. + +;; Valuable comments and help from Dale Worley, Andy Norman, Jamie +;; Zawinski and Sandy Rutherford are gratefully acknowledged. + +(defconst auto-save-version "1.26" + "Version number of auto-save.") + +(provide 'auto-save) + + +;;; Customization: + +(defgroup auto-save nil + "Autosaving with support for efs and /tmp." + :group 'data) + +(put 'auto-save-interval 'custom-type 'integer) +(put 'auto-save-interval 'factory-value '(300)) +(custom-add-to-group 'auto-save 'auto-save-interval 'custom-variable) + +(defcustom auto-save-directory nil + + ;; Don't make this user-variable-p, it should be set in .emacs and + ;; left at that. In particular, it should remain constant across + ;; several Emacs session to make recover-all-files work. + + ;; However, it's OK for it to be customizable, as most of the + ;; customizable variables are set at the time `.emacs' is read. + ;; -hniksic + + "If non-nil, fixed directory for autosaving: all autosave files go +there. If this directory does not yet exist at load time, it is +created and its mode is set to 0700 so that nobody else can read your +autosave files. + +If nil, each autosave files goes into the same directory as its +corresponding visited file. + +A non-nil `auto-save-directory' could be on a local disk such as in +/tmp, then auto-saves will always be fast, even if NFS or the +automounter is slow. In the usual case of /tmp being locally mounted, +note that if you run emacs on two different machines, they will not +see each other's auto-save files. + +The value \(expand-file-name \"~/.autosave/\"\) might be better if /tmp +is mounted from swap (possible in SunOS, type `df /tmp' to find out) +and thus vanishes after a reboot, or if your system is particularly +thorough when cleaning up /tmp, clearing even non-empty subdirectories. + +It should never be an efs remote filename because that would +defeat `efs-auto-save-remotely'. + +Unless you set `auto-save-hash-p', you shouldn't set this to a +directory in a filesystem that does not support long filenames, since +a file named + + /home/sk/lib/emacs/lisp/auto-save.el + +will have a longish filename like + + AUTO-SAVE-DIRECTORY/#\\!home\\!sk\\!lib\\!emacs\\!lisp\\!auto-save.el# + +as auto save file. + +See also variables `auto-save-directory-fallback', +`efs-auto-save' and `efs-auto-save-remotely'." + :type '(choice (const :tag "Same as file" nil) + directory) + :group 'auto-save) + + +(defcustom auto-save-hash-p nil + "If non-nil, hashed autosave names of length 14 are used. +This is to avoid autosave filenames longer than 14 characters. +The directory used is `auto-save-hash-directory' regardless of +`auto-save-directory'. +Hashing defeats `recover-all-files', you have to recover files +individually by doing `recover-file'." + :type 'boolean + :group 'auto-save) + +;;; This defvar is in efs.el now, but doesn't hurt to give it here as +;;; well so that loading first auto-save.el does not abort. + +;; #### Now that `auto-save' is dumped, this is looks obnoxious. +(or (boundp 'efs-auto-save) (defvar efs-auto-save 0)) +(or (boundp 'efs-auto-save-remotely) (defvar efs-auto-save-remotely nil)) + +(defcustom auto-save-offer-delete nil + "*If non-nil, `recover-all-files' offers to delete autosave files +that are out of date or were dismissed for recovering. +Special value 'always deletes those files silently." + :type '(choice (const :tag "on" t) + (const :tag "off" nil) + (const :tag "Delete silently" always)) + :group 'auto-save) + +;;;; end of customization + + +;;; Preparations to be done at load time + +(defvar auto-save-directory-fallback (expand-file-name "~/.autosave/") + ;; not user-variable-p, see above + "Directory used for local autosaving of remote files if +both `auto-save-directory' and `efs-auto-save-remotely' are nil. +Also used if a working directory to be used for autosaving is not writable. +This *must* always be the name of directory that exists or can be +created by you, never nil.") + +(defvar auto-save-hash-directory + (expand-file-name "hash/" (or auto-save-directory + auto-save-directory-fallback)) + "If non-nil, directory used for hashed autosave filenames.") + +(defun auto-save-check-directory (var) + (let ((dir (symbol-value var))) + (if (null dir) + nil + ;; Expand and store back into the variable + (set var (setq dir (expand-file-name dir))) + ;; Make sure directory exists + (if (file-directory-p dir) + nil + ;; Else we create and chmod 0700 the directory + (setq dir (directory-file-name dir)) ; some systems need this + (make-directory dir) + (set-file-modes dir #o700))))) + +(mapc #'auto-save-check-directory + '(auto-save-directory auto-save-directory-fallback)) + +(and auto-save-hash-p + (auto-save-check-directory 'auto-save-hash-directory)) + + +;;; Computing an autosave name for a file and vice versa + +;; #### Now that this file is dumped, we should turn off the routine +;; from files.el. But it would make it harder to remove it! + +(defun make-auto-save-file-name (&optional file-name);; redefines files.el + ;; auto-save-file-name-p need not be redefined. + + "Return file name to use for auto-saves of current buffer. +Does not consider `auto-save-visited-file-name'; that is checked +before calling this function. + +Offers to autosave all files in the same `auto-save-directory'. All +autosave files can then be recovered at once with function +`recover-all-files'. + +Takes care to make autosave files for files accessed through efs +be local files if variable `efs-auto-save-remotely' is nil. + +Takes care of slashes in buffer names to prevent autosave errors. + +Takes care that autosave files for buffers not visiting any file (such +as `*mail*') from two simultaneous Emacses don't collide by prepending +the Emacs pid. + +Uses 14 character autosave names if `auto-save-hash-p' is true. + +Autosaves even if the current directory is not writable, using +directory `auto-save-directory-fallback'. + +You can redefine this for customization (he he :-). +See also function `auto-save-file-name-p'." + + ;; We have to be very careful about not signalling an error in this + ;; function since files.el does not provide for this (e.g. find-file + ;; would fail for each new file). + + (setq file-name (or file-name + buffer-file-truename + (and buffer-file-name + (expand-file-name buffer-file-name)))) + (condition-case error-data + (let ( + ;; So autosavename looks like #%...#, roughly as with the + ;; old make-auto-save-file-name function. The + ;; make-temp-name inserts the pid of this Emacs: this + ;; avoids autosaving from two Emacses into the same file. + ;; It cannot be recovered automatically then because in + ;; the next Emacs session (the one after the crash) the + ;; pid will be different, but file-less buffers like + ;; *mail* must be recovered manually anyway. + + ;; jwz: putting the emacs PID in the auto-save file name is bad + ;; news, because that defeats auto-save-recovery of *mail* + ;; buffers -- the (sensible) code in sendmail.el calls + ;; (make-auto-save-file-name) to determine whether there is + ;; unsent, auto-saved mail to recover. If that mail came from a + ;; previous emacs process (far and away the most likely case) + ;; then this can never succeed as the pid differs. + ;;(name-prefix (if file-name nil (make-temp-name "#%"))) + (name-prefix (if file-name nil "#%")) + + (save-name (or file-name + ;; Prevent autosave errors. Buffername + ;; (to become non-dir part of filename) will + ;; be unslashified twice. Don't care. + (auto-save-unslashify-name (buffer-name)))) + (remote-p (and (stringp file-name) + (fboundp 'efs-ftp-path) + (efs-ftp-path file-name)))) + ;; Return the appropriate auto save file name: + (expand-file-name;; a buffername needs this, a filename not + (cond (remote-p + (if efs-auto-save-remotely + (auto-save-name-in-same-directory save-name) + ;; We have to use the `fixed-directory' now since the + ;; `same-directory' would be remote. + ;; It will use the fallback if needed. + (auto-save-name-in-fixed-directory save-name))) + ;; Else it is a local file (or a buffer without a file, + ;; hence the name-prefix). + ((or auto-save-directory auto-save-hash-p) + ;; Hashed files always go into the special hash dir, + ;; never in the same directory, to make recognizing + ;; reliable. + (auto-save-name-in-fixed-directory save-name name-prefix)) + (t + (auto-save-name-in-same-directory save-name name-prefix))))) + + ;; If any error occurs in the above code, return what the old + ;; version of this function would have done. It is not ok to + ;; return nil, e.g., when after-find-file tests + ;; file-newer-than-file-p, nil would bomb. + + (error (warn "Error caught in `make-auto-save-file-name':\n%s" + (error-message-string error-data)) + (if buffer-file-name + (concat (file-name-directory buffer-file-name) + "#" + (file-name-nondirectory buffer-file-name) + "#") + (expand-file-name (concat "#%" (buffer-name) "#")))))) + +(defun auto-save-original-name (savename) + "Reverse of `make-auto-save-file-name'. +Returns nil if SAVENAME was not associated with a file (e.g., it came +from an autosaved `*mail*' buffer) or does not appear to be an +autosave file at all. +Hashed files are not understood, see `auto-save-hash-p'." + (let ((basename (file-name-nondirectory savename)) + (savedir (file-name-directory savename))) + (cond ((or (not (auto-save-file-name-p basename)) + (string-match "^#%" basename)) + nil) + ;; now we know it looks like #...# thus substring is safe to use + ((or (equal savedir auto-save-directory) ; 2nd arg may be nil + (equal savedir auto-save-directory-fallback)) + ;; it is of the `-fixed-directory' type + (auto-save-slashify-name (substring basename 1 -1))) + (t + ;; else it is of `-same-directory' type + (concat savedir (substring basename 1 -1)))))) + +(defun auto-save-name-in-fixed-directory (filename &optional prefix) + ;; Unslashify and enclose the whole FILENAME in `#' to make an auto + ;; save file in the auto-save-directory, or if that is nil, in + ;; auto-save-directory-fallback (which must be the name of an + ;; existing directory). If the results would be too long for 14 + ;; character filenames, and `auto-save-hash-p' is set, hash FILENAME + ;; into a shorter name. + ;; Optional PREFIX is string to use instead of "#" to prefix name. + (let ((base-name (concat (or prefix "#") + (auto-save-unslashify-name filename) + "#"))) + (if (and auto-save-hash-p + auto-save-hash-directory + (> (length base-name) 14)) + (expand-file-name (auto-save-cyclic-hash-14 filename) + auto-save-hash-directory) + (expand-file-name base-name + (or auto-save-directory + auto-save-directory-fallback))))) + +(defun auto-save-name-in-same-directory (filename &optional prefix) + ;; Enclose the non-directory part of FILENAME in `#' to make an auto + ;; save file in the same directory as FILENAME. But if this + ;; directory is not writable, use auto-save-directory-fallback. + ;; FILENAME is assumed to be in non-directory form (no trailing slash). + ;; It may be a name without a directory part (pesumably it really + ;; comes from a buffer name then), the fallback is used then. + ;; Optional PREFIX is string to use instead of "#" to prefix name. + (let ((directory (file-name-directory filename))) + (or (null directory) + (file-writable-p directory) + (setq directory auto-save-directory-fallback)) + (concat directory ; (concat nil) is "" + (or prefix "#") + (file-name-nondirectory filename) + "#"))) + +;; #### The following two should probably use `replace-in-string'. + +(defun auto-save-unslashify-name (s) + ;; "Quote any slashes in string S by replacing them with the two + ;;characters `\\!'. + ;;Also, replace any backslash by double backslash, to make it one-to-one." + (let ((limit 0)) + (while (string-match "[/\\]" s limit) + (setq s (concat (substring s 0 (match-beginning 0)) + (if (string= (substring s + (match-beginning 0) + (match-end 0)) + "/") + "\\!" + "\\\\") + (substring s (match-end 0)))) + (setq limit (1+ (match-end 0))))) + s) + +(defun auto-save-slashify-name (s) + ;;"Reverse of `auto-save-unslashify-name'." + (let (pos) + (while (setq pos (string-match "\\\\[\\!]" s pos)) + (setq s (concat (substring s 0 pos) + (if (eq ?! (aref s (1+ pos))) "/" "\\") + (substring s (+ pos 2))) + pos (1+ pos)))) + s) + + +;;; Hashing for autosave names + +;;; Hashing function contributed by Andy Norman <ange@hplb.hpl.hp.com> +;;; based upon C code from pot@fly.cnuce.cnr.IT (Francesco Potorti`). + +(defun auto-save-cyclic-hash-14 (s) + ;; "Hash string S into a string of length 14. + ;; A 7-bytes cyclic code for burst correction is calculated on a + ;; byte-by-byte basis. The polynomial used is D^7 + D^6 + D^3 +1. + ;; The resulting string consists of hexadecimal digits [0-9a-f]. + ;; In particular, it contains no slash, so it can be used as autosave name." + (let ((crc (make-string 7 ?\0))) + (mapc + (lambda (new) + (setq new (+ new (aref crc 6))) + (aset crc 6 (+ (aref crc 5) new)) + (aset crc 5 (aref crc 4)) + (aset crc 4 (aref crc 3)) + (aset crc 3 (+ (aref crc 2) new)) + (aset crc 2 (aref crc 1)) + (aset crc 1 (aref crc 0)) + (aset crc 0 new)) + s) + (format "%02x%02x%02x%02x%02x%02x%02x" + (aref crc 0) + (aref crc 1) + (aref crc 2) + (aref crc 3) + (aref crc 4) + (aref crc 5) + (aref crc 6)))) + +;; #### It is unclear to me how the following function is useful. It +;; should be used in `auto-save-name-in-same-directory', if anywhere. +;; -hniksic + +;; This leaves two characters that could be used to wrap it in `#' or +;; make two filenames from it: one for autosaving, and another for a +;; file containing the name of the autosaved filed, to make hashing +;; reversible. +;(defun auto-save-cyclic-hash-12 (s) +; "Outputs the 12-characters ascii hex representation of a 6-bytes +;cyclic code for burst correction calculated on STRING on a +;byte-by-byte basis. The used polynomial is D^6 + D^5 + D^4 + D^3 +1." +; (let ((crc (make-string 6 0))) +; (mapc +; (lambda (new) +; (setq new (+ new (aref crc 5))) +; (aset crc 5 (+ (aref crc 4) new)) +; (aset crc 4 (+ (aref crc 3) new)) +; (aset crc 3 (+ (aref crc 2) new)) +; (aset crc 2 (aref crc 1)) +; (aset crc 1 (aref crc 0)) +; (aset crc 0 new)) +; s) +; (format "%02x%02x%02x%02x%02x%02x" +; (aref crc 0) +; (aref crc 1) +; (aref crc 2) +; (aref crc 3) +; (aref crc 4) +; (aref crc 5)))) + + + +;;; Recovering files + +(defun recover-all-files (&optional silent) + "Do recover-file for all autosave files which are current. +Only works if you have a non-nil `auto-save-directory'. + +Optional prefix argument SILENT means to be silent about non-current +autosave files. This is useful if invoked automatically at Emacs +startup. + +If `auto-save-offer-delete' is t, this function will offer to delete +old or rejected autosave files. + +Hashed files (see `auto-save-hash-p') are not understood, use +`recover-file' to recover them individually." + (interactive "P") + (let ((savefiles (directory-files auto-save-directory + t "\\`#" nil t)) + afile ; the auto save file + file ; its original file + (total 0) ; # of files offered to recover + (count 0)) ; # of files actually recovered + (or (equal auto-save-directory auto-save-directory-fallback) + (setq savefiles + (nconc savefiles + (directory-files auto-save-directory-fallback + t "\\`#" nil t)))) + (while savefiles + (setq afile (car savefiles) + file (auto-save-original-name afile) + savefiles (cdr savefiles)) + (cond ((and file (not (file-newer-than-file-p afile file))) + (warn "Autosave file \"%s\" is not current." afile)) + (t + (incf total) + (with-output-to-temp-buffer "*Directory*" + (apply 'call-process "ls" nil standard-output nil + "-l" afile (if file (list file)))) + (if (yes-or-no-p (format "Recover %s from auto save file? " + (or file "non-file buffer"))) + (let* ((obuf (current-buffer))) + (set-buffer (if file + (find-file-noselect file t) + (generate-new-buffer "*recovered*"))) + (setq buffer-read-only nil) + (erase-buffer) + (insert-file-contents afile nil) + (ignore-errors + (after-find-file nil)) + (setq buffer-auto-save-file-name nil) + (incf count) + (message "\ +Auto-save off in buffer \"%s\" till you do M-x auto-save-mode." + (buffer-name)) + (set-buffer obuf) + (sit-for 1)) + ;; If not used for recovering, offer to delete + ;; autosave file + (and auto-save-offer-delete + (or (eq 'always auto-save-offer-delete) + (yes-or-no-p + (format "Delete autosave file for `%s'? " file))) + (delete-file afile)))))) + (if (zerop total) + (or silent (message "Nothing to recover.")) + (message "%d/%d file%s recovered." count total (if (= count 1) "" "s")))) + (and (get-buffer "*Directory*") + (kill-buffer "*Directory*"))) + +;;; auto-save.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/auto-show.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,203 @@ +;;; auto-show.el --- perform automatic horizontal scrolling as point moves + +;; Copyright (C) 1997 Free Software Foundation, Inc. +;; This file is in the public domain. + +;; Author: Pete Ware <ware@cis.ohio-state.edu> +;; Maintainer: XEmacs Development Team +;; Keywords: extensions, internal, dumped + +;; 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: Emacs/Mule zeta. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;; Modified by: Ben Wing <wing@666.com> + +;; This file provides functions that +;; automatically scroll the window horizontally when the point moves +;; off the left or right side of the window. + +;; Once this library is loaded, automatic horizontal scrolling +;; occurs whenever long lines are being truncated. +;; To request truncation of long lines, set the variable +;; Setting the variable `truncate-lines' to non-nil. +;; You can do this for all buffers as follows: +;; +;; (set-default 'truncate-lines t) + +;; Here is how to do it for C mode only: +;; +;; (set-default 'truncate-lines nil) ; this is the original value +;; (defun my-c-mode-hook () +;; "Run when C-mode starts up. Changes ..." +;; ... set various personal preferences ... +;; (setq truncate-lines t)) +;; (add-hook 'c-mode-hook 'my-c-mode-hook) +;; +;; +;; As a finer level of control, you can still have truncated lines but +;; without the automatic horizontal scrolling by setting the buffer +;; local variable `auto-show-mode' to nil. The default value is t. +;; The command `auto-show-mode' toggles the value of the variable +;; `auto-show-mode'. + +;;; Code: + +(defgroup auto-show nil + "Perform automatic horizontal scrolling as point moves." + :group 'display + :group 'extensions) + +;; This is preloaded, so we don't need special :set, :require, etc. +(defcustom auto-show-mode t + "*Non-nil enables automatic horizontal scrolling, when lines are truncated. +The default value is t. To change the default, do this: + (set-default 'auto-show-mode nil) +See also command `auto-show-mode'. +This variable has no effect when lines are not being truncated. +This variable is automatically local in each buffer where it is set." + :type 'boolean + :group 'auto-show) + +(make-variable-buffer-local 'auto-show-mode) + +(defcustom auto-show-shift-amount 8 + "*Extra columns to scroll. for automatic horizontal scrolling." + :type 'integer + :group 'auto-show) + +(defcustom auto-show-show-left-margin-threshold 50 + "*Threshold column for automatic horizontal scrolling to the right. +If point is before this column, we try to scroll to make the left margin +visible. Setting this to 0 disables this feature." + :type 'number + :group 'auto-show) + +(defun auto-show-truncationp () + "True if line truncation is enabled for the selected window." + ;; XEmacs change (use specifiers) + ;; ### There should be a more straightforward way to do this from elisp. + (or truncate-lines + (and truncate-partial-width-windows + (< (+ (window-width) + (specifier-instance left-margin-width) + (specifier-instance right-margin-width)) + (frame-width))))) + +(defun auto-show-mode (arg) + "Turn automatic horizontal scroll mode on or off. +With arg, turn auto scrolling on if arg is positive, off otherwise. +This mode is enabled or disabled for each buffer individually. +It takes effect only when `truncate-lines' is non-nil." + (interactive "P") + (setq auto-show-mode + (if (null arg) + (not auto-show-mode) + (> (prefix-numeric-value arg) 0)))) + +;; XEmacs addition: +(defvar auto-show-inhibiting-commands + '(scrollbar-char-left + scrollbar-char-right + scrollbar-page-left + scrollbar-page-right + scrollbar-to-left + scrollbar-to-right + scrollbar-horizontal-drag) + "Commands that inhibit auto-show behavior. +This normally includes the horizontal scrollbar commands.") + +;; XEmacs addition: +(defun auto-show-should-take-action-p () + (and auto-show-mode (auto-show-truncationp) + (equal (window-buffer) (current-buffer)) + (not (memq this-command auto-show-inhibiting-commands)))) + +;; XEmacs addition: +(defun auto-show-make-region-visible (start end) + "Move point in such a way that the region (START, END) is visible. +This only does anything if auto-show-mode is enabled, and it doesn't +actually do any horizontal scrolling; rather, it just sets things up so +that the region will be visible when `auto-show-make-point-visible' +is next called (this happens after every command)." + (if (auto-show-should-take-action-p) + (let* ((col (current-column)) ;column on line point is at + (scroll (window-hscroll));how far window is scrolled + (w-width (- (window-width) + (if (> scroll 0) + 2 1))) ;how wide window is on the screen + (right-col (+ scroll w-width)) + (start-col (save-excursion (goto-char start) (current-column))) + (end-col (save-excursion (goto-char end) (current-column)))) + (cond ((and (>= start-col scroll) + (<= end-col right-col)) + ;; already completely visible + nil) + ((< start-col scroll) + (scroll-right (- scroll start-col))) + (t + (scroll-left (- end-col right-col))))))) + +(defun auto-show-make-point-visible (&optional ignore-arg) + "Scroll horizontally to make point visible, if that is enabled. +This function only does something if `auto-show-mode' is non-nil +and longlines are being truncated in the selected window. +See also the command `auto-show-mode'." + (interactive) + ;; XEmacs change + (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 + (w-width (- (window-width) + (if (> scroll 0) + 2 1))) ;how wide window is on the screen + (right-col (+ scroll w-width))) + (if (and (< col auto-show-show-left-margin-threshold) + (< col (window-width)) + (> scroll 0)) + (scroll-right scroll) + (if (< col scroll) ;to the left of the screen + (scroll-right (+ (- scroll col) auto-show-shift-amount)) + (if (or (> col right-col) ;to the right of the screen + (and (= col right-col) + (not (eolp)))) + (scroll-left (+ auto-show-shift-amount + (- col (+ scroll w-width)))))))))) + +;; XEmacs change: +;; #### instead of this, we kludgily call it from the C code, to make sure +;; that it's done after any other things on post-command-hook (which might +;; move point). +;; Do auto-scrolling after commands. +;;(add-hook 'post-command-hook 'auto-show-make-point-visible) + +;; If being dumped, turn it on right away. +(when (boundp 'load-gc) + (auto-show-mode 1)) + +;; Do auto-scrolling in comint buffers after process output also. +; XEmacs -- don't do this now, it messes up comint. +;(add-hook 'comint-output-filter-functions 'auto-show-make-point-visible t) + +(provide 'auto-show) + +;;; auto-show.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/backquote.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,304 @@ +;;; backquote.el --- Full backquote support for elisp. Reverse compatible too. + +;; Copyright (C) 1997 Free Software Foundation, Inc. + +;; Maintainer: XEmacs Development Team +;; Keywords: extensions, dumped + +;; 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 synched with FSF. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;; The bulk of the code is originally from CMU Common Lisp (original notice +;; below). + +;; It correctly supports nested backquotes and backquoted vectors. + +;; Converted to work with elisp by Miles Bader <miles@cogsci.ed.ac.uk> + +;; Changes by Jonathan Stigelman <Stig@hackvan.com>: +;; - Documentation added +;; - support for old-backquote-compatibility-hook nixed because the +;; old-backquote compatibility is now done in the reader... +;; - nixed support for |,.| because +;; (a) it's not in CLtl2 +;; (b) ",.foo" is the same as ". ,foo" +;; (c) because RMS isn't interested in using this version of backquote.el +;; +;; wing@666.com; added ,. support back in: +;; (a) yes, it is in CLtl2. Read closely on page 529. +;; (b) RMS in 19.30 adds C support for ,. even if it's not really +;; handled. +;; +;; ********************************************************************** +;; This code was written as part of the CMU Common Lisp project at +;; Carnegie Mellon University, and has been placed in the public domain. +;; If you want to use this code or any part of CMU Common Lisp, please contact +;; Scott Fahlman or slisp-group@cs.cmu.edu. +;; +;; ********************************************************************** +;; +;; BACKQUOTE: Code Spice Lispified by Lee Schumacher. +;; +;; The flags passed back by BQ-PROCESS-2 can be interpreted as follows: +;; +;; |`,|: [a] => a +;; NIL: [a] => a ;the NIL flag is used only when a is NIL +;; T: [a] => a ;the T flag is used when a is self-evaluating +;; QUOTE: [a] => (QUOTE a) +;; APPEND: [a] => (APPEND . a) +;; NCONC: [a] => (NCONC . a) +;; LIST: [a] => (LIST . a) +;; LIST*: [a] => (LIST* . a) +;; +;; The flags are combined according to the following set of rules: +;; ([a] means that a should be converted according to the previous table) +;; +;; \ car || otherwise | QUOTE or | |`,@| | |`,.| +;;cdr \ || | T or NIL | | +;;============================================================================ +;; |`,| ||LIST* ([a] [d]) |LIST* ([a] [d]) |APPEND (a [d]) |NCONC (a [d]) +;; NIL ||LIST ([a]) |QUOTE (a) |<hair> a |<hair> a +;;QUOTE or T||LIST* ([a] [d]) |QUOTE (a . d) |APPEND (a [d]) |NCONC (a [d]) +;; APPEND ||LIST* ([a] [d]) |LIST* ([a] [d]) |APPEND (a . d) |NCONC (a [d]) +;; NCONC ||LIST* ([a] [d]) |LIST* ([a] [d]) |APPEND (a [d]) |NCONC (a . d) +;; LIST ||LIST ([a] . d) |LIST ([a] . d) |APPEND (a [d]) |NCONC (a [d]) +;; LIST* ||LIST* ([a] . d) |LIST* ([a] . d) |APPEND (a [d]) |NCONC (a [d]) +;; +;;<hair> involves starting over again pretending you had read ".,a)" instead +;; of ",@a)" +;; + +;; These are the forms it expects: |backquote| |`| |,| |,@| and |,.|. + +;;; Code: + +(defconst bq-backquote-marker 'backquote) +(defconst bq-backtick-marker '\`) ; remnant of the old lossage +(defconst bq-comma-marker '\,) +(defconst bq-at-marker '\,@) +(defconst bq-dot-marker '\,\.) + +;;; ---------------------------------------------------------------- + +(fset '\` 'backquote) + +(defmacro backquote (template) + "Expand the internal representation of a backquoted TEMPLATE into a lisp form. + +The backquote character is like the quote character in that it prevents the +template which follows it from being evaluated, except that backquote +permits you to evaluate portions of the quoted template. A comma character +inside TEMPLATE indicates that the following item should be evaluated. A +comma character may be followed by an at-sign, which indicates that the form +which follows should be evaluated and inserted and \"spliced\" into the +template. Forms following ,@ must evaluate to lists. + +Here is how to use backquotes: + (setq p 'b + q '(c d e)) + `(a ,p ,@q) -> (a b c d e) + `(a . b) -> (a . b) + `(a . ,p) -> (a . b) + +The XEmacs lisp reader expands lisp backquotes as it reads them. +Examples: + `atom is read as (backquote atom) + `(a ,b ,@(c d e)) is read as (backquote (a (\\, b) (\\,\\@ (c d e)))) + `(a . ,p) is read as (backquote (a \\, p)) + +\(backquote TEMPLATE) is a macro that produces code to construct TEMPLATE. +Note that this is very slow in interpreted code, but fast if you compile. +TEMPLATE is one or more nested lists or vectors, which are `almost quoted'. +They are copied recursively, with elements preceded by comma evaluated. + (backquote (a b)) == (list 'a 'b) + (backquote (a [b c])) == (list 'a (vector 'b 'c)) + +However, certain special lists are not copied. They specify substitution. +Lists that look like (\\, EXP) are evaluated and the result is substituted. + (backquote (a (\\, (+ x 5)))) == (list 'a (+ x 5)) + +Elements of the form (\\,\\@ EXP) are evaluated and then all the elements +of the result are substituted. This result must be a list; it may +be `nil'. + +Elements of the form (\\,\\. EXP) are evaluated and then all the elements +of the result are concatenated to the list of preceding elements in the list. +They must occur as the last element of a list (not a vector). +EXP may evaluate to nil. + +As an example, a simple macro `push' could be written: + (defmacro push (v l) + `(setq ,l (cons ,@(list v l)))) +or as + (defmacro push (v l) + `(setq ,l (cons ,v ,l))) + +For backwards compatibility, old-style emacs-lisp backquotes are still read. + OLD STYLE NEW STYLE + (` (foo (, bar) (,@ bing))) `(foo ,bar ,@bing) + +Because of the old-style backquote support, you cannot use a new-style +backquoted form as the first element of a list. Perhaps some day this +restriction will go away, but for now you should be wary of it: + (`(this ,will ,@fail)) + ((` (but (, this) will (,@ work)))) +This is an extremely rare thing to need to do in lisp." + (bq-process template)) + +;;; ---------------------------------------------------------------- + +(defconst bq-comma-flag 'unquote) +(defconst bq-at-flag 'unquote-splicing) +(defconst bq-dot-flag 'unquote-nconc-splicing) + +(defun bq-process (form) + (let* ((flag-result (bq-process-2 form)) + (flag (car flag-result)) + (result (cdr flag-result))) + (cond ((eq flag bq-at-flag) + (error ",@ after ` in form: %s" form)) + ((eq flag bq-dot-flag) + (error ",. after ` in form: %s" form)) + (t + (bq-process-1 flag result))))) + +;;; ---------------------------------------------------------------- + +(defun bq-vector-contents (vec) + (let ((contents nil) + (n (length vec))) + (while (> n 0) + (setq n (1- n)) + (setq contents (cons (aref vec n) contents))) + contents)) + +;;; This does the expansion from table 2. +(defun bq-process-2 (code) + (cond ((vectorp code) + (let* ((dflag-d + (bq-process-2 (bq-vector-contents code)))) + (cons 'vector (bq-process-1 (car dflag-d) (cdr dflag-d))))) + ((atom code) + (cond ((null code) (cons nil nil)) + ((or (numberp code) (eq code t)) + (cons t code)) + (t (cons 'quote code)))) + ((eq (car code) bq-at-marker) + (cons bq-at-flag (nth 1 code))) + ((eq (car code) bq-dot-marker) + (cons bq-dot-flag (nth 1 code))) + ((eq (car code) bq-comma-marker) + (bq-comma (nth 1 code))) + ((or (eq (car code) bq-backquote-marker) + (eq (car code) bq-backtick-marker)) ; old lossage + (bq-process-2 (bq-process (nth 1 code)))) + (t (let* ((aflag-a (bq-process-2 (car code))) + (aflag (car aflag-a)) + (a (cdr aflag-a))) + (let* ((dflag-d (bq-process-2 (cdr code))) + (dflag (car dflag-d)) + (d (cdr dflag-d))) + (if (eq dflag bq-at-flag) + ;; get the errors later. + (error ",@ after dot in %s" code)) + (if (eq dflag bq-dot-flag) + (error ",. after dot in %s" code)) + (cond + ((eq aflag bq-at-flag) + (if (null dflag) + (bq-comma a) + (cons 'append + (cond ((eq dflag 'append) + (cons a d )) + (t (list a (bq-process-1 dflag d))))))) + ((eq aflag bq-dot-flag) + (if (null dflag) + (bq-comma a) + (cons 'nconc + (cond ((eq dflag 'nconc) + (cons a d)) + (t (list a (bq-process-1 dflag d))))))) + ((null dflag) + (if (memq aflag '(quote t nil)) + (cons 'quote (list a)) + (cons 'list (list (bq-process-1 aflag a))))) + ((memq dflag '(quote t)) + (if (memq aflag '(quote t nil)) + (cons 'quote (cons a d )) + (cons 'list* (list (bq-process-1 aflag a) + (bq-process-1 dflag d))))) + (t (setq a (bq-process-1 aflag a)) + (if (memq dflag '(list list*)) + (cons dflag (cons a d)) + (cons 'list* + (list a (bq-process-1 dflag d))))))))))) + +;;; This handles the <hair> cases +(defun bq-comma (code) + (cond ((atom code) + (cond ((null code) + (cons nil nil)) + ((or (numberp code) (eq code 't)) + (cons t code)) + (t (cons bq-comma-flag code)))) + ((eq (car code) 'quote) + (cons (car code) (car (cdr code)))) + ((memq (car code) '(append list list* nconc)) + (cons (car code) (cdr code))) + ((eq (car code) 'cons) + (cons 'list* (cdr code))) + (t (cons bq-comma-flag code)))) + +;;; This handles table 1. +(defun bq-process-1 (flag thing) + (cond ((or (eq flag bq-comma-flag) + (memq flag '(t nil))) + thing) + ((eq flag 'quote) + (list 'quote thing)) + ((eq flag 'vector) + (list 'apply '(function vector) thing)) + (t (cons (cdr + (assq flag + '((cons . cons) + (list* . bq-list*) + (list . list) + (append . append) + (nconc . nconc)))) + thing)))) + +;;; ---------------------------------------------------------------- + +(defmacro bq-list* (&rest args) + "Returns a list of its arguments with last cons a dotted pair." + (setq args (reverse args)) + (let ((result (car args))) + (setq args (cdr args)) + (while args + (setq result (list 'cons (car args) result)) + (setq args (cdr args))) + result)) + +(provide 'backquote) + +;;; backquote.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/buff-menu.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,639 @@ +;;; buff-menu.el --- buffer menu main function and support functions. + +;; Copyright (C) 1985, 86, 87, 93, 94, 95 Free Software Foundation, Inc. + +;; Maintainer: FSF +;; Keywords: extensions, dumped + +;; 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.34 except as noted. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;; Edit, delete, or change attributes of all currently active Emacs +;; buffers from a list summarizing their state. A good way to browse +;; any special or scratch buffers you have loaded, since you can't find +;; them by filename. The single entry point is `Buffer-menu-mode', +;; normally bound to C-x C-b. + +;;; Change Log: + +;; Merged by esr with recent mods to Emacs 19 buff-menu, 23 Mar 1993 +;; +;; Modified by Bob Weiner, Motorola, Inc., 4/14/89 +;; +;; Added optional backup argument to 'Buffer-menu-unmark' to make it undelete +;; current entry and then move to previous one. +;; +;; Based on FSF code dating back to 1985. + +;;; Code: + +;;;Trying to preserve the old window configuration works well in +;;;simple scenarios, when you enter the buffer menu, use it, and exit it. +;;;But it does strange things when you switch back to the buffer list buffer +;;;with C-x b, later on, when the window configuration is different. +;;;The choice seems to be, either restore the window configuration +;;;in all cases, or in no cases. +;;;I decided it was better not to restore the window config at all. -- rms. + +;;;But since then, I changed buffer-menu to use the selected window, +;;;so q now once again goes back to the previous window configuration. + +;;;(defvar Buffer-menu-window-config nil +;;; "Window configuration saved from entry to `buffer-menu'.") + +; Put buffer *Buffer List* into proper mode right away +; so that from now on even list-buffers is enough to get a buffer menu. + +(defvar Buffer-menu-buffer-column 4) + +(defvar Buffer-menu-mode-map nil "") + +(if Buffer-menu-mode-map + () + (setq Buffer-menu-mode-map (make-keymap)) + (suppress-keymap Buffer-menu-mode-map t) + (set-keymap-name Buffer-menu-mode-map 'Buffer-menu-mode-map) ; XEmacs + (define-key Buffer-menu-mode-map "q" 'Buffer-menu-quit) + (define-key Buffer-menu-mode-map "v" 'Buffer-menu-select) + (define-key Buffer-menu-mode-map "2" 'Buffer-menu-2-window) + (define-key Buffer-menu-mode-map "1" 'Buffer-menu-1-window) + (define-key Buffer-menu-mode-map "f" 'Buffer-menu-this-window) + (define-key Buffer-menu-mode-map "\C-m" 'Buffer-menu-this-window) + (define-key Buffer-menu-mode-map "o" 'Buffer-menu-other-window) + (define-key Buffer-menu-mode-map "\C-o" 'Buffer-menu-switch-other-window) + (define-key Buffer-menu-mode-map "s" 'Buffer-menu-save) + (define-key Buffer-menu-mode-map "d" 'Buffer-menu-delete) + (define-key Buffer-menu-mode-map "k" 'Buffer-menu-delete) + (define-key Buffer-menu-mode-map "\C-d" 'Buffer-menu-delete-backwards) + (define-key Buffer-menu-mode-map "\C-k" 'Buffer-menu-delete) + (define-key Buffer-menu-mode-map "x" 'Buffer-menu-execute) + (define-key Buffer-menu-mode-map " " 'next-line) + (define-key Buffer-menu-mode-map "n" 'next-line) + (define-key Buffer-menu-mode-map "p" 'previous-line) + (define-key Buffer-menu-mode-map 'backspace 'Buffer-menu-backup-unmark) + (define-key Buffer-menu-mode-map 'delete 'Buffer-menu-backup-unmark) + (define-key Buffer-menu-mode-map "~" 'Buffer-menu-not-modified) + (define-key Buffer-menu-mode-map "?" 'describe-mode) + (define-key Buffer-menu-mode-map "u" 'Buffer-menu-unmark) + (define-key Buffer-menu-mode-map "m" 'Buffer-menu-mark) + (define-key Buffer-menu-mode-map "t" 'Buffer-menu-visit-tags-table) + (define-key Buffer-menu-mode-map "%" 'Buffer-menu-toggle-read-only) + (define-key Buffer-menu-mode-map "g" 'revert-buffer) + (define-key Buffer-menu-mode-map 'button2 'Buffer-menu-mouse-select) + (define-key Buffer-menu-mode-map 'button3 'Buffer-menu-popup-menu) + ) + +;; Buffer Menu mode is suitable only for specially formatted data. +(put 'Buffer-menu-mode 'mode-class 'special) + +(defun Buffer-menu-mode () + "Major mode for editing a list of buffers. +Each line describes one of the buffers in Emacs. +Letters do not insert themselves; instead, they are commands. +\\<Buffer-menu-mode-map> +\\[Buffer-menu-mouse-select] -- select buffer you click on, in place of the buffer menu. +\\[Buffer-menu-this-window] -- select current line's buffer in place of the buffer menu. +\\[Buffer-menu-other-window] -- select that buffer in another window, + so the buffer menu buffer remains visible in its window. +\\[Buffer-menu-switch-other-window] -- make another window display that buffer. +\\[Buffer-menu-mark] -- mark current line's buffer to be displayed. +\\[Buffer-menu-select] -- select current line's buffer. + Also show buffers marked with m, in other windows. +\\[Buffer-menu-1-window] -- select that buffer in full-frame window. +\\[Buffer-menu-2-window] -- select that buffer in one window, + together with buffer selected before this one in another window. +\\[Buffer-menu-visit-tags-table] -- visit-tags-table this buffer. +\\[Buffer-menu-not-modified] -- clear modified-flag on that buffer. +\\[Buffer-menu-save] -- mark that buffer to be saved, and move down. +\\[Buffer-menu-delete] -- mark that buffer to be deleted, and move down. +\\[Buffer-menu-delete-backwards] -- mark that buffer to be deleted, and move up. +\\[Buffer-menu-execute] -- delete or save marked buffers. +\\[Buffer-menu-unmark] -- remove all kinds of marks from current line. + With prefix argument, also move up one line. +\\[Buffer-menu-backup-unmark] -- back up a line and remove marks. +\\[Buffer-menu-toggle-read-only] -- toggle read-only status of buffer on this line." + (kill-all-local-variables) + (use-local-map Buffer-menu-mode-map) + (setq major-mode 'Buffer-menu-mode) + (setq mode-name "Buffer Menu") + (make-local-variable 'revert-buffer-function) + (setq revert-buffer-function 'Buffer-menu-revert-function) + (setq truncate-lines t) + (setq buffer-read-only t) + (make-local-variable 'mouse-track-click-hook) ; XEmacs + (add-hook 'mouse-track-click-hook 'Buffer-menu-maybe-mouse-select) ; XEmacs + (run-hooks 'buffer-menu-mode-hook)) + +(defun Buffer-menu-revert-function (ignore1 ignore2) + (list-buffers)) + +(defun Buffer-menu-buffer (error-if-non-existent-p) + "Return buffer described by this line of buffer menu." + (let* ((where (save-excursion + (beginning-of-line) + (+ (point) Buffer-menu-buffer-column))) + (name (and (not (eobp)) (get-text-property where 'buffer-name)))) + (if name + (or (get-buffer name) + (if error-if-non-existent-p + (error "No buffer named `%s'" name) + nil)) + (if error-if-non-existent-p + (error "No buffer on this line") + nil)))) + +(defun buffer-menu (&optional arg) + "Make a menu of buffers so you can save, delete or select them. +With argument, show only buffers that are visiting files. +Type ? after invocation to get help on commands available. +Type q immediately to make the buffer menu go away." + (interactive "P") +;;; (setq Buffer-menu-window-config (current-window-configuration)) + (switch-to-buffer (list-buffers-noselect arg)) + (message + "Commands: d, s, x, u; f, o, 1, 2, m, v; ~, %%; q to quit; ? for help.")) + +(defun buffer-menu-other-window (&optional arg) + "Display a list of buffers in another window. +With the buffer list buffer, you can save, delete or select the buffers. +With argument, show only buffers that are visiting files. +Type ? after invocation to get help on commands available. +Type q immediately to make the buffer menu go away." + (interactive "P") +;;; (setq Buffer-menu-window-config (current-window-configuration)) + (switch-to-buffer-other-window (list-buffers-noselect arg)) + (message + "Commands: d, s, x, u; f, o, 1, 2, m, v; ~, %%; q to quit; ? for help.")) + +(defun Buffer-menu-quit () + "Quit the buffer menu." + (interactive) + (let ((buffer (current-buffer))) + ;; Switch away from the buffer menu and bury it. + (switch-to-buffer (other-buffer)) + (bury-buffer buffer))) + +(defun Buffer-menu-mark () + "Mark buffer on this line for being displayed by \\<Buffer-menu-mode-map>\\[Buffer-menu-select] command." + (interactive) + (beginning-of-line) + (if (looking-at " [-M]") + (ding) + (let ((buffer-read-only nil)) + (delete-char 1) + (insert ?>) + (forward-line 1)))) + +(defun Buffer-menu-unmark (&optional backup) + "Cancel all requested operations on buffer on this line and move down. +Optional ARG means move up." + (interactive "P") + (beginning-of-line) + (if (looking-at " [-M]") + (ding) + (let* ((buf (Buffer-menu-buffer t)) + (mod (buffer-modified-p buf)) + (readonly (save-excursion (set-buffer buf) buffer-read-only)) + (buffer-read-only nil)) + (delete-char 3) + (insert (if readonly (if mod " *%" " %") (if mod " * " " "))))) + (forward-line (if backup -1 1))) + +(defun Buffer-menu-backup-unmark () + "Move up and cancel all requested operations on buffer on line above." + (interactive) + (forward-line -1) + (Buffer-menu-unmark) + (forward-line -1)) + +(defun Buffer-menu-delete (&optional arg) + "Mark buffer on this line to be deleted by \\<Buffer-menu-mode-map>\\[Buffer-menu-execute] command. +Prefix arg is how many buffers to delete. +Negative arg means delete backwards." + (interactive "p") + (beginning-of-line) + (if (looking-at " [-M]") ;header lines + (ding) + (let ((buffer-read-only nil)) + (if (or (null arg) (= arg 0)) + (setq arg 1)) + (while (> arg 0) + (delete-char 1) + (insert ?D) + (forward-line 1) + (setq arg (1- arg))) + (while (< arg 0) + (delete-char 1) + (insert ?D) + (forward-line -1) + (setq arg (1+ arg)))))) + +(defun Buffer-menu-delete-backwards (&optional arg) + "Mark buffer on this line to be deleted by \\<Buffer-menu-mode-map>\\[Buffer-menu-execute] command +and then move up one line. Prefix arg means move that many lines." + (interactive "p") + (Buffer-menu-delete (- (or arg 1))) + (while (looking-at " [-M]") + (forward-line 1))) + +(defun Buffer-menu-save () + "Mark buffer on this line to be saved by \\<Buffer-menu-mode-map>\\[Buffer-menu-execute] command." + (interactive) + (beginning-of-line) + (if (looking-at " [-M]") ;header lines + (ding) + (let ((buffer-read-only nil)) + (forward-char 1) + (delete-char 1) + (insert ?S) + (forward-line 1)))) + +(defun Buffer-menu-not-modified (&optional arg) + "Mark buffer on this line as unmodified (no changes to save)." + (interactive "P") + (save-excursion + (set-buffer (Buffer-menu-buffer t)) + (set-buffer-modified-p arg)) + (save-excursion + (beginning-of-line) + (forward-char 1) + (if (= (char-after (point)) (if arg ? ?*)) + (let ((buffer-read-only nil)) + (delete-char 1) + (insert (if arg ?* ? )))))) + +(defun Buffer-menu-execute () + "Save and/or delete buffers marked with \\<Buffer-menu-mode-map>\\[Buffer-menu-save] or \\<Buffer-menu-mode-map>\\[Buffer-menu-delete] commands." + (interactive) + (save-excursion + (goto-char (point-min)) + (forward-line 1) + (while (re-search-forward "^.S" nil t) + (let ((modp nil)) + (save-excursion + (set-buffer (Buffer-menu-buffer t)) + (save-buffer) + (setq modp (buffer-modified-p))) + (let ((buffer-read-only nil)) + (delete-char -1) + (insert (if modp ?* ? )))))) + (save-excursion + (goto-char (point-min)) + (forward-line 1) + (let ((buff-menu-buffer (current-buffer)) + (buffer-read-only nil)) + (while (search-forward "\nD" nil t) + (forward-char -1) + (let ((buf (Buffer-menu-buffer nil))) + (or (eq buf nil) + (eq buf buff-menu-buffer) + (save-excursion (kill-buffer buf)))) + (if (Buffer-menu-buffer nil) + (progn (delete-char 1) + (insert ? )) + (delete-region (point) (progn (forward-line 1) (point))) + (forward-char -1)))))) + +(defun Buffer-menu-select () + "Select this line's buffer; also display buffers marked with `>'. +You can mark buffers with the \\<Buffer-menu-mode-map>\\[Buffer-menu-mark] command. +This command deletes and replaces all the previously existing windows +in the selected frame." + (interactive) + (let ((buff (Buffer-menu-buffer t)) + (menu (current-buffer)) + (others ()) + tem) + (goto-char (point-min)) + (while (search-forward "\n>" nil t) + (setq tem (Buffer-menu-buffer t)) + (let ((buffer-read-only nil)) + (delete-char -1) + (insert ?\ )) + (or (eq tem buff) (memq tem others) (setq others (cons tem others)))) + (setq others (nreverse others) + tem (/ (1- (frame-height)) (1+ (length others)))) + (delete-other-windows) + (switch-to-buffer buff) + (or (eq menu buff) + (bury-buffer menu)) + (if (equal (length others) 0) + (progn +;;; ;; Restore previous window configuration before displaying +;;; ;; selected buffers. +;;; (if Buffer-menu-window-config +;;; (progn +;;; (set-window-configuration Buffer-menu-window-config) +;;; (setq Buffer-menu-window-config nil))) + (switch-to-buffer buff)) + (while others + (split-window nil tem) + (other-window 1) + (switch-to-buffer (car others)) + (setq others (cdr others))) + (other-window 1) ;back to the beginning! +))) + + + +(defun Buffer-menu-visit-tags-table () + "Visit the tags table in the buffer on this line. See `visit-tags-table'." + (interactive) + (let ((file (buffer-file-name (Buffer-menu-buffer t)))) + (if file + (visit-tags-table file) + (error "Specified buffer has no file")))) + +(defun Buffer-menu-1-window () + "Select this line's buffer, alone, in full frame." + (interactive) + (switch-to-buffer (Buffer-menu-buffer t)) + (bury-buffer (other-buffer)) + (delete-other-windows) + ;; XEmacs: + ;; This is to get w->force_start set to nil. Don't ask me, I only work here. + (set-window-buffer (selected-window) (current-buffer))) + +(defun Buffer-menu-mouse-select (event) + "Select the buffer whose line you click on." + (interactive "e") + (let (buffer) + (save-excursion + (set-buffer (event-buffer event)) ; XEmacs + (save-excursion + (goto-char (event-point event)) ; XEmacs + (setq buffer (Buffer-menu-buffer t)))) + (select-window (event-window event)) ; XEmacs + (if (and (window-dedicated-p (selected-window)) + (eq (selected-window) (frame-root-window))) + (switch-to-buffer-other-frame buffer) + (switch-to-buffer buffer)))) + +;; XEmacs +(defun Buffer-menu-maybe-mouse-select (event &optional click-count) + (interactive "e") + (and (>= click-count 2) + (let ((buffer (current-buffer)) + (point (point)) + (config (current-window-configuration))) + (condition-case nil + (progn + (Buffer-menu-mouse-select event) + t) + (error + (set-window-configuration config) + (set-buffer buffer) + (goto-char point) + nil))))) + +(defun Buffer-menu-this-window () + "Select this line's buffer in this window." + (interactive) + (switch-to-buffer (Buffer-menu-buffer t))) + +(defun Buffer-menu-other-window () + "Select this line's buffer in other window, leaving buffer menu visible." + (interactive) + (switch-to-buffer-other-window (Buffer-menu-buffer t))) + +(defun Buffer-menu-switch-other-window () + "Make the other window select this line's buffer. +The current window remains selected." + (interactive) + (display-buffer (Buffer-menu-buffer t))) + +(defun Buffer-menu-2-window () + "Select this line's buffer, with previous buffer in second window." + (interactive) + (let ((buff (Buffer-menu-buffer t)) + (menu (current-buffer)) + (pop-up-windows t)) + (delete-other-windows) + (switch-to-buffer (other-buffer)) + (pop-to-buffer buff) + (bury-buffer menu))) + +(defun Buffer-menu-toggle-read-only () + "Toggle read-only status of buffer on this line, perhaps via version control." + (interactive) + (let (char) + (save-excursion + (set-buffer (Buffer-menu-buffer t)) + (vc-toggle-read-only) + (setq char (if buffer-read-only ?% ? ))) + (save-excursion + (beginning-of-line) + (forward-char 2) + (if (/= (following-char) char) + (let (buffer-read-only) + (delete-char 1) + (insert char)))))) + +;; XEmacs +(defvar Buffer-menu-popup-menu + '("Buffer Commands" + ["Select Buffer" Buffer-menu-select t] + ["Select buffer Other Window" Buffer-menu-other-window t] + ["Clear Buffer Modification Flag" Buffer-menu-not-modified t] + "----" + ["Mark Buffer for Selection" Buffer-menu-mark t] + ["Mark Buffer for Save" Buffer-menu-save t] + ["Mark Buffer for Deletion" Buffer-menu-delete t] + ["Unmark Buffer" Buffer-menu-unmark t] + "----" + ["Delete/Save Marked Buffers" Buffer-menu-execute t] + )) + +;; XEmacs +(defun Buffer-menu-popup-menu (event) + (interactive "e") + (mouse-set-point event) + (beginning-of-line) + (let ((buffer (Buffer-menu-buffer nil))) + (if buffer + (popup-menu + (nconc (list (car Buffer-menu-popup-menu) + (concat + "Commands on buffer \"" (buffer-name buffer) "\":") + "----") + (cdr Buffer-menu-popup-menu))) + (error "no buffer on this line")))) + + +;; XEmacs +(defvar list-buffers-header-line + (purecopy (concat " MR Buffer Size Mode File\n" + " -- ------ ---- ---- ----\n"))) + +;; XEmacs +(defvar list-buffers-identification 'default-list-buffers-identification + "String used to identify this buffer, or a function of one argument +to generate such a string. This variable is always buffer-local.") +(make-variable-buffer-local 'list-buffers-identification) + +;; XEmacs +;;;###autoload +(defvar list-buffers-directory nil) + +;;;###autoload +(make-variable-buffer-local 'list-buffers-directory) + +;; #### not synched +(defun default-list-buffers-identification (output) + (save-excursion + (let ((file (or (buffer-file-name (current-buffer)) + (and (boundp 'list-buffers-directory) + list-buffers-directory))) + (size (buffer-size)) + (mode mode-name) + eob p s col) + (set-buffer output) + (end-of-line) + (setq eob (point)) + (prin1 size output) + (setq p (point)) + ;; right-justify the size + (move-to-column 19 t) + (setq col (point)) + (if (> eob col) + (goto-char eob)) + (setq s (- 6 (- p col))) + (while (> s 0) ; speed/consing tradeoff... + (insert ? ) + (setq s (1- s))) + (end-of-line) + (indent-to 27 1) + (insert mode) + (if (not file) + nil + ;; if the mode-name is really long, clip it for the filename + (if (> 0 (setq s (- 39 (current-column)))) + (delete-char (max s (- eob (point))))) + (indent-to 40 1) + (insert file))))) + +;; #### not synched +(defun list-buffers-internal (output &optional predicate) + (let ((current (current-buffer)) + (buffers (buffer-list))) + (save-excursion + (set-buffer output) + (setq buffer-read-only nil) + (erase-buffer) + (buffer-disable-undo output) + (insert list-buffers-header-line) + + (while buffers + (let* ((col1 19) + (buffer (car buffers)) + (name (buffer-name buffer)) + this-buffer-line-start) + (setq buffers (cdr buffers)) + (cond ((null name)) ;deleted buffer + ((and predicate + (not (if (stringp predicate) + (string-match predicate name) + (funcall predicate buffer)))) + nil) + (t + (set-buffer buffer) + (let ((ro buffer-read-only) + (id list-buffers-identification)) + (set-buffer output) + (setq this-buffer-line-start (point)) + (insert (if (eq buffer current) + (progn (setq current (point)) ?\.) + ?\ )) + (insert (if (buffer-modified-p buffer) + ?\* + ?\ )) + (insert (if ro + ?\% + ?\ )) + (if (string-match "[\n\"\\ \t]" name) + (let ((print-escape-newlines t)) + (prin1 name output)) + (insert ?\ name)) + (indent-to col1 1) + (cond ((stringp id) + (insert id)) + (id + (set-buffer buffer) + (condition-case e + (funcall id output) + (error + (princ "***" output) (prin1 e output))) + (set-buffer output) + (goto-char (point-max))))) + (put-nonduplicable-text-property this-buffer-line-start + (point) + 'buffer-name name) + (put-nonduplicable-text-property this-buffer-line-start + (point) + 'highlight t) + (insert ?\n))))) + + (Buffer-menu-mode) + (if (not (bufferp current)) + (goto-char current))))) +;(define-key ctl-x-map "\C-b" 'list-buffers) + +(defun list-buffers (&optional files-only) + "Display a list of names of existing buffers. +The list is displayed in a buffer named `*Buffer List*'. +Note that buffers with names starting with spaces are omitted. +Non-null optional arg FILES-ONLY means mention only file buffers. + +The M column contains a * for buffers that are modified. +The R column contains a % for buffers that are read-only." + (interactive (list (if current-prefix-arg t nil))) ; XEmacs + (display-buffer (list-buffers-noselect files-only))) + +;; #### not synched +(defun list-buffers-noselect (&optional files-only) + "Create and return a buffer with a list of names of existing buffers. +The buffer is named `*Buffer List*'. +Note that buffers with names starting with spaces are omitted. +Non-null optional arg FILES-ONLY means mention only file buffers. + +The M column contains a * for buffers that are modified. +The R column contains a % for buffers that are read-only." + (let ((buffer (get-buffer-create "*Buffer List*"))) + (list-buffers-internal buffer + (if (memq files-only '(t nil)) + #'(lambda (b) + (let ((n (buffer-name b))) + (cond ((and (/= 0 (length n)) + (= (aref n 0) ?\ )) + ;;don't mention if starts with " " + nil) + (files-only + (buffer-file-name b)) + (t + t)))) + files-only)) + buffer)) + +(provide 'buff-menu) + +;;; buff-menu.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/buffer.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,112 @@ +;;; buffer.el --- buffer routines taken from C + +;; Copyright (C) 1985-1989, 1992-1995, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1995 Sun Microsystems. +;; Copyright (C) 1995, 1996 Ben Wing. + +;; Maintainer: XEmacs Development Team +;; Keywords: internal, dumped + +;; 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, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: FSF 19.30 buffer.c. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;;; Code: + +(defun switch-to-buffer (bufname &optional norecord) + "Select buffer BUFNAME in the current window. +BUFNAME may be a buffer or a buffer name. +Optional second arg NORECORD non-nil means +do not put this buffer at the front of the list of recently selected ones. + +WARNING: This is NOT the way to work on another buffer temporarily +within a Lisp program! Use `set-buffer' instead. That avoids messing with +the window-buffer correspondences." + (interactive "BSwitch to buffer: ") + ;; #ifdef I18N3 + ;; #### Doc string should indicate that the buffer name will get + ;; translated. + ;; #endif + (if (eq (minibuffer-window) (selected-window)) + (error "Cannot switch buffers in minibuffer window")) + (if (window-dedicated-p (selected-window)) + (error "Cannot switch buffers in a dedicated window")) + (let (buf) + (if (null bufname) + (setq buf (other-buffer (current-buffer))) + (setq buf (get-buffer bufname)) + (if (null buf) + (progn + (setq buf (get-buffer-create bufname)) + (set-buffer-major-mode buf)))) + (push-window-configuration) + (set-buffer buf) + (or norecord (record-buffer buf)) + (set-window-buffer (if (eq (selected-window) (minibuffer-window)) + (next-window (minibuffer-window)) + (selected-window)) + buf) + buf)) + +(defun pop-to-buffer (bufname &optional not-this-window-p on-frame) + "Select buffer BUFNAME in some window, preferably a different one. +If BUFNAME is nil, then some other buffer is chosen. +If `pop-up-windows' is non-nil, windows can be split to do this. +If optional second arg NOT-THIS-WINDOW-P is non-nil, insist on finding +another window even if BUFNAME is already visible in the selected window. +If optional third arg is non-nil, it is the frame to pop to this +buffer on. +If `focus-follows-mouse' is non-nil, keyboard focus is left unchanged." + ;; #ifdef I18N3 + ;; #### Doc string should indicate that the buffer name will get + ;; translated. + ;; #endif + ;; This is twisted. It is evil to throw the keyboard focus around + ;; willy-nilly if the user wants focus-follows-mouse. + (let ((oldbuf (current-buffer)) + buf window frame) + (if (null bufname) + (setq buf (other-buffer (current-buffer))) + (setq buf (get-buffer bufname)) + (if (null buf) + (progn + (setq buf (get-buffer-create bufname)) + (set-buffer-major-mode buf)))) + (push-window-configuration) + (set-buffer buf) + (setq window (display-buffer buf not-this-window-p on-frame)) + (setq frame (window-frame window)) + ;; if the display-buffer hook decided to show this buffer in another + ;; frame, then select that frame, (unless obeying focus-follows-mouse -sb). + (if (and (not focus-follows-mouse) + (not (eq frame (selected-frame)))) + (select-frame frame)) + (record-buffer buf) + (if (and focus-follows-mouse + on-frame + (not (eq on-frame (selected-frame)))) + (set-buffer oldbuf) + ;; select-window will modify the internal keyboard focus of XEmacs + (select-window window)) + buf)) + +;;; buffer.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/byte-optimize.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,1956 @@ +;;; byte-opt.el --- the optimization passes of the emacs-lisp byte compiler. + +;;; Copyright (c) 1991, 1994 Free Software Foundation, Inc. + +;; Author: Jamie Zawinski <jwz@netscape.com> +;; Hallvard Furuseth <hbf@ulrik.uio.no> +;; Keywords: internal + +;; 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. + +;;; Commentary: + +;;; ======================================================================== +;;; "No matter how hard you try, you can't make a racehorse out of a pig. +;;; You can, however, make a faster pig." +;;; +;;; Or, to put it another way, the emacs byte compiler is a VW Bug. This code +;;; makes it be a VW Bug with fuel injection and a turbocharger... You're +;;; still not going to make it go faster than 70 mph, but it might be easier +;;; to get it there. +;;; + +;;; TO DO: +;;; +;;; (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 +;;; (let ( v1 v2 ... vM vN ) <...dynamically-safe...> ) ==> +;;; (let ( v1 v2 ... vM ) vN <...dynamically-safe...> ) +;;; by recursing on this, we might be able to eliminate the entire let. +;;; However certain variables should never have their bindings optimized +;;; away, because they affect everything. +;;; (put 'debug-on-error 'binding-is-magic t) +;;; (put 'debug-on-abort 'binding-is-magic t) +;;; (put 'debug-on-next-call 'binding-is-magic t) +;;; (put 'mocklisp-arguments 'binding-is-magic t) +;;; (put 'inhibit-quit 'binding-is-magic t) +;;; (put 'quit-flag 'binding-is-magic t) +;;; (put 't 'binding-is-magic t) +;;; (put 'nil 'binding-is-magic t) +;;; possibly also +;;; (put 'gc-cons-threshold 'binding-is-magic t) +;;; (put 'track-mouse 'binding-is-magic t) +;;; others? +;;; +;;; Simple defsubsts often produce forms like +;;; (let ((v1 (f1)) (v2 (f2)) ...) +;;; (FN v1 v2 ...)) +;;; It would be nice if we could optimize this to +;;; (FN (f1) (f2) ...) +;;; but we can't unless FN is dynamically-safe (it might be dynamically +;;; referring to the bindings that the lambda arglist established.) +;;; One of the uncountable lossages introduced by dynamic scope... +;;; +;;; Maybe there should be a control-structure that says "turn on +;;; fast-and-loose type-assumptive optimizations here." Then when +;;; we see a form like (car foo) we can from then on assume that +;;; the variable foo is of type cons, and optimize based on that. +;;; But, this won't win much because of (you guessed it) dynamic +;;; scope. Anything down the stack could change the value. +;;; (Another reason it doesn't work is that it is perfectly valid +;;; to call car with a null argument.) A better approach might +;;; be to allow type-specification of the form +;;; (put 'foo 'arg-types '(float (list integer) dynamic)) +;;; (put 'foo 'result-type 'bool) +;;; It should be possible to have these types checked to a certain +;;; degree. +;;; +;;; collapse common subexpressions +;;; +;;; It would be nice if redundant sequences could be factored out as well, +;;; when they are known to have no side-effects: +;;; (list (+ a b c) (+ a b c)) --> a b add c add dup list-2 +;;; but beware of traps like +;;; (cons (list x y) (list x y)) +;;; +;;; Tail-recursion elimination is not really possible in Emacs Lisp. +;;; Tail-recursion elimination is almost always impossible when all variables +;;; have dynamic scope, but given that the "return" byteop requires the +;;; binding stack to be empty (rather than emptying it itself), there can be +;;; no truly tail-recursive Emacs Lisp functions that take any arguments or +;;; make any bindings. +;;; +;;; Here is an example of an Emacs Lisp function which could safely be +;;; byte-compiled tail-recursively: +;;; +;;; (defun tail-map (fn list) +;;; (cond (list +;;; (funcall fn (car list)) +;;; (tail-map fn (cdr list))))) +;;; +;;; However, if there was even a single let-binding around the COND, +;;; it could not be byte-compiled, because there would be an "unbind" +;;; byte-op between the final "call" and "return." Adding a +;;; Bunbind_all byteop would fix this. +;;; +;;; (defun foo (x y z) ... (foo a b c)) +;;; ... (const foo) (varref a) (varref b) (varref c) (call 3) END: (return) +;;; ... (varref a) (varbind x) (varref b) (varbind y) (varref c) (varbind z) (goto 0) END: (unbind-all) (return) +;;; ... (varref a) (varset x) (varref b) (varset y) (varref c) (varset z) (goto 0) END: (return) +;;; +;;; this also can be considered tail recursion: +;;; +;;; ... (const foo) (varref a) (call 1) (goto X) ... X: (return) +;;; could generalize this by doing the optimization +;;; (goto X) ... X: (return) --> (return) +;;; +;;; But this doesn't solve all of the problems: although by doing tail- +;;; recursion elimination in this way, the call-stack does not grow, the +;;; binding-stack would grow with each recursive step, and would eventually +;;; overflow. I don't believe there is any way around this without lexical +;;; scope. +;;; +;;; Wouldn't it be nice if Emacs Lisp had lexical scope. +;;; +;;; Idea: the form (lexical-scope) in a file means that the file may be +;;; compiled lexically. This proclamation is file-local. Then, within +;;; that file, "let" would establish lexical bindings, and "let-dynamic" +;;; would do things the old way. (Or we could use CL "declare" forms.) +;;; We'd have to notice defvars and defconsts, since those variables should +;;; always be dynamic, and attempting to do a lexical binding of them +;;; should simply do a dynamic binding instead. +;;; But! We need to know about variables that were not necessarily defvarred +;;; in the file being compiled (doing a boundp check isn't good enough.) +;;; Fdefvar() would have to be modified to add something to the plist. +;;; +;;; A major disadvantage of this scheme is that the interpreter and compiler +;;; would have different semantics for files compiled with (dynamic-scope). +;;; Since this would be a file-local optimization, there would be no way to +;;; modify the interpreter to obey this (unless the loader was hacked +;;; in some grody way, but that's a really bad idea.) +;;; +;;; HA! HA! HA! RMS removed the following paragraph from his version of +;;; byte-opt.el, proving once again his stubborn refusal to accept any +;;; developments in computer science that occurred after the late 1970's. +;;; +;;; Really the Right Thing is to make lexical scope the default across +;;; the board, in the interpreter and compiler, and just FIX all of +;;; the code that relies on dynamic scope of non-defvarred variables. + +;; Other things to consider: + +;;;;; Associative math should recognize subcalls to identical function: +;;;(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)))) +;;;;; 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)))) +;;;;; When +;;;;; - all but one arguments to a function are constant +;;;;; - the non-constant argument is an if-expression (cond-expression?) +;;;;; then the outer function can be distributed. If the guarding +;;;;; condition is side-effect-free [assignment-free] then the other +;;;;; 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)))) + +;;;;; (car (cons A B)) -> (progn B A) +;;;(disassemble (lambda (x) (car (cons (foo) 42)))) + +;;;;; (cdr (cons A B)) -> (progn A B) +;;;(disassemble (lambda (x) (cdr (cons 42 (foo))))) + +;;;;; (car (list A B ...)) -> (progn B ... A) +;;;(disassemble (lambda (x) (car (list (foo) 42 (bar))))) + +;;;;; (cdr (list A B ...)) -> (progn A (list B ...)) +;;;(disassemble (lambda (x) (cdr (list 42 (foo) (bar))))) + + +;;; Code: + +(require 'byte-compile "bytecomp") + +(defun byte-compile-log-lap-1 (format &rest args) + (if (aref byte-code-vector 0) + (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))))) + +(defmacro byte-compile-log-lap (format-string &rest args) + (list 'and + '(memq byte-optimize-log '(t byte)) + (cons 'byte-compile-log-lap-1 + (cons format-string args)))) + + +;;; byte-compile optimizers to support inlining + +(put 'inline 'byte-optimizer 'byte-optimize-inline-handler) + +(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)))) + + +;; Splice the given lap code into the current instruction stream. +;; If it has any labels in it, you're responsible for making sure there +;; are no collisions, and that byte-compile-tag-number is reasonable +;; after this is spliced in. The provided list is destroyed. +(defun byte-inline-lapcode (lap) + (setq byte-compile-output (nconc (nreverse lap) byte-compile-output))) + + +(defun byte-compile-inline-expand (form) + (let* ((name (car form)) + (fn (or (cdr (assq name byte-compile-function-environment)) + (and (fboundp name) (symbol-function name))))) + (if (null fn) + (progn + (byte-compile-warn "attempt to inline %s before it was defined" name) + form) + ;; else + (if (and (consp fn) (eq (car fn) 'autoload)) + (progn + (load (nth 1 fn)) + (setq fn (or (cdr (assq name byte-compile-function-environment)) + (and (fboundp name) (symbol-function name)))))) + (if (and (consp fn) (eq (car fn) 'autoload)) + (error "file \"%s\" didn't define \"%s\"" (nth 1 fn) name)) + (if (symbolp fn) + (byte-compile-inline-expand (cons fn (cdr form))) + (if (compiled-function-p fn) + (progn + (fetch-bytecode fn) + (cons (list 'lambda (compiled-function-arglist fn) + (list 'byte-code + (compiled-function-instructions fn) + (compiled-function-constants fn) + (compiled-function-stack-depth fn))) + (cdr form))) + (if (not (eq (car fn) 'lambda)) (error "%s is not a lambda" name)) + (cons fn (cdr form))))))) + +;;; ((lambda ...) ...) +;;; +(defun byte-compile-unfold-lambda (form &optional name) + (or name (setq name "anonymous lambda")) + (let ((lambda (car form)) + (values (cdr form))) + (if (compiled-function-p lambda) + (setq lambda (list 'lambda (compiled-function-arglist lambda) + (list 'byte-code + (compiled-function-instructions lambda) + (compiled-function-constants lambda) + (compiled-function-stack-depth lambda))))) + (let ((arglist (nth 1 lambda)) + (body (cdr (cdr lambda))) + optionalp restp + bindings) + (if (and (stringp (car body)) (cdr body)) + (setq body (cdr body))) + (if (and (consp (car body)) (eq 'interactive (car (car body)))) + (setq body (cdr body))) + (while arglist + (cond ((eq (car arglist) '&optional) + ;; ok, I'll let this slide because funcall_lambda() does... + ;; (if optionalp (error "multiple &optional keywords in %s" name)) + (if restp (error "&optional found after &rest in %s" name)) + (if (null (cdr arglist)) + (error "nothing after &optional in %s" name)) + (setq optionalp t)) + ((eq (car arglist) '&rest) + ;; ...but it is by no stretch of the imagination a reasonable + ;; thing that funcall_lambda() allows (&rest x y) and + ;; (&rest x &optional y) in arglists. + (if (null (cdr arglist)) + (error "nothing after &rest in %s" name)) + (if (cdr (cdr arglist)) + (error "multiple vars after &rest in %s" name)) + (setq restp t)) + (restp + (setq bindings (cons (list (car arglist) + (and values (cons 'list values))) + bindings) + values nil)) + ((and (not optionalp) (null values)) + (byte-compile-warn "attempt to open-code %s with too few arguments" name) + (setq arglist nil values 'too-few)) + (t + (setq bindings (cons (list (car arglist) (car values)) + bindings) + values (cdr values)))) + (setq arglist (cdr arglist))) + (if values + (progn + (or (eq values 'too-few) + (byte-compile-warn + "attempt to open-code %s with too many arguments" name)) + form) + (let ((newform + (if bindings + (cons 'let (cons (nreverse bindings) body)) + (cons 'progn body)))) + (byte-compile-log " %s\t==>\t%s" form newform) + newform))))) + + +;;; implementing source-level optimizers + +(defun byte-optimize-form-code-walker (form for-effect) + ;; + ;; For normal function calls, We can just mapcar the optimizer the cdr. But + ;; we need to have special knowledge of the syntax of the special forms + ;; like let and defun (that's why they're special forms :-). (Actually, + ;; the important aspect is that they are subrs that don't evaluate all of + ;; their args.) + ;; + (let ((fn (car-safe form)) + tmp) + (cond ((not (consp form)) + (if (not (and for-effect + (or byte-compile-delete-errors + (not (symbolp form)) + (eq form t)))) + form)) + ((eq fn 'quote) + (if (cdr (cdr form)) + (byte-compile-warn "malformed quote form: %s" + (prin1-to-string form))) + ;; map (quote nil) to nil to simplify optimizer logic. + ;; map quoted constants to nil if for-effect (just because). + (and (nth 1 form) + (not for-effect) + form)) + ((or (compiled-function-p fn) + (eq 'lambda (car-safe fn))) + (byte-compile-unfold-lambda form)) + ((memq fn '(let let*)) + ;; recursively enter the optimizer for the bindings and body + ;; of a let or let*. This for depth-firstness: forms that + ;; 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)) + (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)))) + ((eq fn 'progn) + ;; as an extra added bonus, this simplifies (progn <x>) --> <x> + (if (cdr (cdr form)) + (progn + (setq tmp (byte-optimize-body (cdr form) for-effect)) + (if (cdr tmp) (cons 'progn tmp) (car tmp))) + (byte-optimize-form (nth 1 form) for-effect))) + ((eq fn 'prog1) + (if (cdr (cdr form)) + (cons 'prog1 + (cons (byte-optimize-form (nth 1 form) for-effect) + (byte-optimize-body (cdr (cdr form)) t))) + (byte-optimize-form (nth 1 form) for-effect))) + ((eq fn 'prog2) + (cons 'prog2 + (cons (byte-optimize-form (nth 1 form) t) + (cons (byte-optimize-form (nth 2 form) for-effect) + (byte-optimize-body (cdr (cdr (cdr form))) t))))) + + ((memq fn '(save-excursion save-restriction save-current-buffer)) + ;; those subrs which have an implicit progn; it's not quite good + ;; enough to treat these like normal function calls. + ;; This can turn (save-excursion ...) into (save-excursion) which + ;; will be optimized away in the lap-optimize pass. + (cons fn (byte-optimize-body (cdr form) for-effect))) + + ((eq fn 'with-output-to-temp-buffer) + ;; this is just like the above, except for the first argument. + (cons fn + (cons + (byte-optimize-form (nth 1 form) nil) + (byte-optimize-body (cdr (cdr form)) for-effect)))) + + ((eq fn 'if) + (cons fn + (cons (byte-optimize-form (nth 1 form) nil) + (cons + (byte-optimize-form (nth 2 form) for-effect) + (byte-optimize-body (nthcdr 3 form) for-effect))))) + + ((memq fn '(and or)) ; remember, and/or are control structures. + ;; take forms off the back until we can't any more. + ;; In the future it could conceivably be a problem that the + ;; subexpressions of these forms are optimized in the reverse + ;; order, but it's ok for now. + (if for-effect + (let ((backwards (reverse (cdr form)))) + (while (and backwards + (null (setcar backwards + (byte-optimize-form (car backwards) + for-effect)))) + (setq backwards (cdr backwards))) + (if (and (cdr form) (null backwards)) + (byte-compile-log + " all subforms of %s called for effect; deleted" form)) + (and backwards + (cons fn (nreverse backwards)))) + (cons fn (mapcar 'byte-optimize-form (cdr form))))) + + ((eq fn 'interactive) + (byte-compile-warn "misplaced interactive spec: %s" + (prin1-to-string form)) + nil) + + ((memq fn '(defun defmacro function + condition-case save-window-excursion)) + ;; These forms are compiled as constants or by breaking out + ;; all the subexpressions and compiling them separately. + form) + + ((eq fn 'unwind-protect) + ;; the "protected" part of an unwind-protect is compiled (and thus + ;; optimized) as a top-level form, so don't do it here. But the + ;; non-protected part has the same for-effect status as the + ;; unwind-protect itself. (The protected part is always for effect, + ;; but that isn't handled properly yet.) + (cons fn + (cons (byte-optimize-form (nth 1 form) for-effect) + (cdr (cdr form))))) + + ((eq fn 'catch) + ;; the body of a catch is compiled (and thus optimized) as a + ;; top-level form, so don't do it here. The tag is never + ;; for-effect. The body should have the same for-effect status + ;; as the catch form itself, but that isn't handled properly yet. + (cons fn + (cons (byte-optimize-form (nth 1 form) nil) + (cdr (cdr form))))) + + ;; If optimization is on, this is the only place that macros are + ;; expanded. If optimization is off, then macroexpansion happens + ;; in byte-compile-form. Otherwise, the macros are already expanded + ;; by the time that is reached. + ((not (eq form + (setq form (macroexpand form + byte-compile-macro-environment)))) + (byte-optimize-form form for-effect)) + + ((not (symbolp fn)) + (or (eq 'mocklisp (car-safe fn)) ; ha! + (byte-compile-warn "%s is a malformed function" + (prin1-to-string fn))) + form) + + ((and for-effect (setq tmp (get fn 'side-effect-free)) + (or byte-compile-delete-errors + (eq tmp 'error-free) + (progn + (byte-compile-warn "%s called for effect" + (prin1-to-string form)) + nil))) + (byte-compile-log " %s called for effect; deleted" fn) + ;; appending a nil here might not be necessary, but it can't hurt. + (byte-optimize-form + (cons 'progn (append (cdr form) '(nil))) t)) + + (t + ;; Otherwise, no args can be considered to be for-effect, + ;; even if the called function is for-effect, because we + ;; don't know anything about that function. + (cons fn (mapcar 'byte-optimize-form (cdr form))))))) + + +(defun byte-optimize-form (form &optional for-effect) + "The source-level pass of the optimizer." + ;; + ;; 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 + ;; 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. + ;; + (let (opt new) + (if (and (consp form) + (symbolp (car form)) + (or (and for-effect + ;; we don't have any of these yet, but we might. + (setq opt (get (car form) 'byte-for-effect-optimizer))) + (setq opt (get (car form) 'byte-optimizer))) + (not (eq form (setq new (funcall opt form))))) + (progn +;; (if (equal form new) (error "bogus optimizer -- %s" opt)) + (byte-compile-log " %s\t==>\t%s" form new) + (setq new (byte-optimize-form new for-effect)) + new) + form))) + + +(defun byte-optimize-body (forms all-for-effect) + ;; optimize the cdr of a progn or implicit progn; all 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. + (let ((rest forms) + (result nil) + fe new) + (while rest + (setq fe (or all-for-effect (cdr rest))) + (setq new (and (car rest) (byte-optimize-form (car rest) fe))) + (if (or new (not fe)) + (setq result (cons new result))) + (setq rest (cdr rest))) + (nreverse result))) + + +;;; some source-level optimizers +;;; +;;; when writing optimizers, be VERY careful that the optimizer returns +;;; something not EQ to its argument if and ONLY if it has made a change. +;;; This implies that you cannot simply destructively modify the list; +;;; you must return something not EQ to it if you make an optimization. +;;; +;;; It is now safe to optimize code such that it introduces new bindings. + +;; 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))))) + +;; If the function is being called with constant numeric args, +;; evaluate as much as possible at compile-time. This optimizer +;; assumes that the function is associative, like + or *. +(defun byte-optimize-associative-math (form) + (let ((args nil) + (constants nil) + (rest (cdr form))) + (while rest + (if (numberp (car rest)) + (setq constants (cons (car rest) constants)) + (setq args (cons (car rest) args))) + (setq rest (cdr rest))) + (if (cdr constants) + (if args + (list (car form) + (apply (car form) constants) + (if (cdr args) + (cons (car form) (nreverse args)) + (car args))) + (apply (car form) constants)) + form))) + +;; If the function is being called with constant numeric args, +;; evaluate as much as possible at compile-time. This optimizer +;; assumes that the function satisfies +;; (op x1 x2 ... xn) == (op ...(op (op x1 x2) x3) ...xn) +;; like - and /. +(defun byte-optimize-nonassociative-math (form) + (if (or (not (numberp (car (cdr form)))) + (not (numberp (car (cdr (cdr form)))))) + form + (let ((constant (car (cdr form))) + (rest (cdr (cdr form)))) + (while (numberp (car rest)) + (setq constant (funcall (car form) constant (car rest)) + rest (cdr rest))) + (if rest + (cons (car form) (cons constant rest)) + constant)))) + +;;(defun byte-optimize-associative-two-args-math (form) +;; (setq form (byte-optimize-associative-math form)) +;; (if (consp form) +;; (byte-optimize-two-args-left form) +;; form)) + +;;(defun byte-optimize-nonassociative-two-args-math (form) +;; (setq form (byte-optimize-nonassociative-math form)) +;; (if (consp form) +;; (byte-optimize-two-args-right form) +;; form)) + +;; jwz: (byte-optimize-approx-equal 0.0 0.0) was returning nil +;; in xemacs 19.15 because it used < instead of <=. +(defun byte-optimize-approx-equal (x y) + (<= (* (abs (- x y)) 100) (abs (+ x y)))) + +;; Collect all the constants from FORM, after the STARTth arg, +;; and apply FUN to them to make one argument at the end. +;; For functions that can handle floats, that optimization +;; can be incorrect because reordering can cause an overflow +;; that would otherwise be avoided by encountering an arg that is a float. +;; We avoid this problem by (1) not moving float constants and +;; (2) not moving anything if it would cause an overflow. +(defun byte-optimize-delay-constants-math (form start fun) + ;; Merge all FORM's constants from number START, call FUN on them + ;; and put the result at the end. + (let ((rest (nthcdr (1- start) form)) + (orig form) + ;; t means we must check for overflow. + (overflow (memq fun '(+ *)))) + (while (cdr (setq rest (cdr rest))) + (if (integerp (car rest)) + (let (constants) + (setq form (copy-sequence form) + rest (nthcdr (1- start) form)) + (while (setq rest (cdr rest)) + (cond ((integerp (car rest)) + (setq constants (cons (car rest) constants)) + (setcar rest nil)))) + ;; If necessary, check now for overflow + ;; that might be caused by reordering. + (if (and overflow + ;; We have overflow if the result of doing the arithmetic + ;; on floats is not even close to the result + ;; of doing it on integers. + (not (byte-optimize-approx-equal + (apply fun (mapcar 'float constants)) + (float (apply fun constants))))) + (setq form orig) + (setq form (nconc (delq nil form) + (list (apply fun (nreverse constants))))))))) + form)) + +(defun byte-optimize-plus (form) + (setq form (byte-optimize-delay-constants-math form 1 '+)) + (if (memq 0 form) (setq form (delq 0 (copy-sequence form)))) + ;;(setq form (byte-optimize-associative-two-args-math form)) + (cond ((null (cdr form)) + (condition-case () + (eval form) + (error form))) + + ;; `add1' and `sub1' are a marginally fewer instructions + ;; than `plus' and `minus', so use them when possible. + ((and (null (nthcdr 3 form)) + (eq (nth 2 form) 1)) + (list '1+ (nth 1 form))) ; (+ x 1) --> (1+ x) + ((and (null (nthcdr 3 form)) + (eq (nth 1 form) 1)) + (list '1+ (nth 2 form))) ; (+ 1 x) --> (1+ x) + ((and (null (nthcdr 3 form)) + (eq (nth 2 form) -1)) + (list '1- (nth 1 form))) ; (+ x -1) --> (1- x) + ((and (null (nthcdr 3 form)) + (eq (nth 1 form) -1)) + (list '1- (nth 2 form))) ; (+ -1 x) --> (1- x) + +;;; It is not safe to delete the function entirely +;;; (actually, it would be safe if we know the sole arg +;;; is not a marker). +;; ((null (cdr (cdr form))) (nth 1 form)) + (t form))) + +(defun byte-optimize-minus (form) + ;; Put constants at the end, except the last constant. + (setq form (byte-optimize-delay-constants-math form 2 '+)) + ;; Now only first and last element can be a number. + (let ((last (car (reverse (nthcdr 3 form))))) + (cond ((eq 0 last) + ;; (- x y ... 0) --> (- x y ...) + (setq form (copy-sequence form)) + (setcdr (cdr (cdr form)) (delq 0 (nthcdr 3 form)))) + ;; If form is (- CONST foo... CONST), merge first and last. + ((and (numberp (nth 1 form)) + (numberp last)) + (setq form (nconc (list '- (- (nth 1 form) last) (nth 2 form)) + (delq last (copy-sequence (nthcdr 3 form)))))))) + (setq form +;;; It is not safe to delete the function entirely +;;; (actually, it would be safe if we know the sole arg +;;; is not a marker). +;;; (if (eq (nth 2 form) 0) +;;; (nth 1 form) ; (- x 0) --> x + (byte-optimize-predicate + (if (and (null (cdr (cdr (cdr form)))) + (eq (nth 1 form) 0)) ; (- 0 x) --> (- x) + (cons (car form) (cdr (cdr form))) + form)) +;;; ) + ) + + ;; `add1' and `sub1' are a marginally fewer instructions than `plus' + ;; and `minus', so use them when possible. + (cond ((and (null (nthcdr 3 form)) + (eq (nth 2 form) 1)) + (list '1- (nth 1 form))) ; (- x 1) --> (1- x) + ((and (null (nthcdr 3 form)) + (eq (nth 2 form) -1)) + (list '1+ (nth 1 form))) ; (- x -1) --> (1+ x) + (t + form)) + ) + +(defun byte-optimize-multiply (form) + (setq form (byte-optimize-delay-constants-math form 1 '*)) + ;; If there is a constant in FORM, it is now the last element. + (cond ((null (cdr form)) 1) +;;; It is not safe to delete the function entirely +;;; (actually, it would be safe if we know the sole arg +;;; is not a marker or if it appears in other arithmetic). +;;; ((null (cdr (cdr form))) (nth 1 form)) + ((let ((last (car (reverse form)))) + (cond ((eq 0 last) (cons 'progn (cdr form))) + ((eq 1 last) (delq 1 (copy-sequence form))) + ((eq -1 last) (list '- (delq -1 (copy-sequence form)))) + ((and (eq 2 last) + (memq t (mapcar 'symbolp (cdr form)))) + (prog1 (setq form (delq 2 (copy-sequence form))) + (while (not (symbolp (car (setq form (cdr form)))))) + (setcar form (list '+ (car form) (car form))))) + (form)))))) + +(defsubst byte-compile-butlast (form) + (nreverse (cdr (reverse form)))) + +(defun byte-optimize-divide (form) + (setq form (byte-optimize-delay-constants-math form 2 '*)) + (let ((last (car (reverse (cdr (cdr form)))))) + (if (numberp last) + (cond ((= (length form) 3) + (if (and (numberp (nth 1 form)) + (not (zerop last)) + (condition-case nil + (/ (nth 1 form) last) + (error nil))) + (setq form (list 'progn (/ (nth 1 form) last))))) + ((= last 1) + (setq form (byte-compile-butlast form))) + ((numberp (nth 1 form)) + (setq form (cons (car form) + (cons (/ (nth 1 form) last) + (byte-compile-butlast (cdr (cdr form))))) + last nil)))) + (cond +;;; ((null (cdr (cdr form))) +;;; (nth 1 form)) + ((eq (nth 1 form) 0) + (append '(progn) (cdr (cdr form)) '(0))) + ((eq last -1) + (list '- (if (nthcdr 3 form) + (byte-compile-butlast form) + (nth 1 form)))) + (form)))) + +(defun byte-optimize-logmumble (form) + (setq form (byte-optimize-delay-constants-math form 1 (car form))) + (byte-optimize-predicate + (cond ((memq 0 form) + (setq form (if (eq (car form) 'logand) + (cons 'progn (cdr form)) + (delq 0 (copy-sequence form))))) + ((and (eq (car-safe form) 'logior) + (memq -1 form)) + (cons 'progn (cdr form))) + (form)))) + + +(defun byte-optimize-binary-predicate (form) + (if (byte-compile-constp (nth 1 form)) + (if (byte-compile-constp (nth 2 form)) + (condition-case () + (list 'quote (eval form)) + (error form)) + ;; This can enable some lapcode optimizations. + (list (car form) (nth 2 form) (nth 1 form))) + form)) + +(defun byte-optimize-predicate (form) + (let ((ok t) + (rest (cdr form))) + (while (and rest ok) + (setq ok (byte-compile-constp (car rest)) + rest (cdr rest))) + (if ok + (condition-case () + (list 'quote (eval form)) + (error form)) + form))) + +(defun byte-optimize-identity (form) + (if (and (cdr form) (null (cdr (cdr form)))) + (nth 1 form) + (byte-compile-warn "identity called with %d arg%s, but requires 1" + (length (cdr form)) + (if (= 1 (length (cdr form))) "" "s")) + form)) + +(put 'identity 'byte-optimizer 'byte-optimize-identity) + +(put '+ 'byte-optimizer 'byte-optimize-plus) +(put '* 'byte-optimizer 'byte-optimize-multiply) +(put '- 'byte-optimizer 'byte-optimize-minus) +(put '/ 'byte-optimizer 'byte-optimize-divide) +(put 'max 'byte-optimizer 'byte-optimize-associative-math) +(put 'min 'byte-optimizer 'byte-optimize-associative-math) + +(put '= 'byte-optimizer 'byte-optimize-binary-predicate) +(put 'eq 'byte-optimizer 'byte-optimize-binary-predicate) +(put 'eql 'byte-optimizer 'byte-optimize-binary-predicate) +(put 'equal 'byte-optimizer 'byte-optimize-binary-predicate) +(put 'string= 'byte-optimizer 'byte-optimize-binary-predicate) +(put 'string-equal 'byte-optimizer 'byte-optimize-binary-predicate) + +(put '< 'byte-optimizer 'byte-optimize-predicate) +(put '> 'byte-optimizer 'byte-optimize-predicate) +(put '<= 'byte-optimizer 'byte-optimize-predicate) +(put '>= 'byte-optimizer 'byte-optimize-predicate) +(put '1+ 'byte-optimizer 'byte-optimize-predicate) +(put '1- 'byte-optimizer 'byte-optimize-predicate) +(put 'not 'byte-optimizer 'byte-optimize-predicate) +(put 'null 'byte-optimizer 'byte-optimize-predicate) +(put 'memq 'byte-optimizer 'byte-optimize-predicate) +(put 'consp 'byte-optimizer 'byte-optimize-predicate) +(put 'listp 'byte-optimizer 'byte-optimize-predicate) +(put 'symbolp 'byte-optimizer 'byte-optimize-predicate) +(put 'stringp 'byte-optimizer 'byte-optimize-predicate) +(put 'string< 'byte-optimizer 'byte-optimize-predicate) +(put 'string-lessp 'byte-optimizer 'byte-optimize-predicate) + +(put 'logand 'byte-optimizer 'byte-optimize-logmumble) +(put 'logior 'byte-optimizer 'byte-optimize-logmumble) +(put 'logxor 'byte-optimizer 'byte-optimize-logmumble) +(put 'lognot 'byte-optimizer 'byte-optimize-predicate) + +(put 'car 'byte-optimizer 'byte-optimize-predicate) +(put 'cdr 'byte-optimizer 'byte-optimize-predicate) +(put 'car-safe 'byte-optimizer 'byte-optimize-predicate) +(put 'cdr-safe 'byte-optimizer 'byte-optimize-predicate) + + +;; 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, +;; so arithmetic optimizers recognize the numeric constant. - Hallvard +(put 'quote 'byte-optimizer 'byte-optimize-quote) +(defun byte-optimize-quote (form) + (if (or (consp (nth 1 form)) + (and (symbolp (nth 1 form)) + ;; XEmacs addition: + (not (keywordp (nth 1 form))) + (not (memq (nth 1 form) '(nil t))))) + form + (nth 1 form))) + +(defun byte-optimize-zerop (form) + (cond ((numberp (nth 1 form)) + (eval form)) + (byte-compile-delete-errors + (list '= (nth 1 form) 0)) + (form))) + +(put 'zerop 'byte-optimizer 'byte-optimize-zerop) + +(defun byte-optimize-and (form) + ;; Simplify if less than 2 args. + ;; if there is a literal nil in the args to `and', throw it and following + ;; forms away, and surround the `and' with (progn ... nil). + (cond ((null (cdr form))) + ((memq nil form) + (list 'progn + (byte-optimize-and + (prog1 (setq form (copy-sequence form)) + (while (nth 1 form) + (setq form (cdr form))) + (setcdr form nil))) + nil)) + ((null (cdr (cdr form))) + (nth 1 form)) + ((byte-optimize-predicate form)))) + +(defun byte-optimize-or (form) + ;; Throw away nil's, and simplify if less than 2 args. + ;; If there is a literal non-nil constant in the args to `or', throw away all + ;; following forms. + (if (memq nil form) + (setq form (delq nil (copy-sequence form)))) + (let ((rest form)) + (while (cdr (setq rest (cdr rest))) + (if (byte-compile-trueconstp (car rest)) + (setq form (copy-sequence form) + rest (setcdr (memq (car rest) form) nil)))) + (if (cdr (cdr form)) + (byte-optimize-predicate form) + (nth 1 form)))) + +(defun byte-optimize-cond (form) + ;; if any clauses have a literal nil as their test, throw them away. + ;; if any clause has a literal non-nil constant as its test, throw + ;; away all following clauses. + (let (rest) + ;; This must be first, to reduce (cond (t ...) (nil)) to (progn t ...) + (while (setq rest (assq nil (cdr form))) + (setq form (delq rest (copy-sequence form)))) + (if (memq nil (cdr form)) + (setq form (delq nil (copy-sequence form)))) + (setq rest form) + (while (setq rest (cdr rest)) + (cond ((byte-compile-trueconstp (car-safe (car rest))) + (cond ((eq rest (cdr form)) + (setq form + (if (cdr (car rest)) + (if (cdr (cdr (car rest))) + (cons 'progn (cdr (car rest))) + (nth 1 (car rest))) + (car (car rest))))) + ((cdr rest) + (setq form (copy-sequence form)) + (setcdr (memq (car rest) form) nil))) + (setq rest nil))))) + ;; + ;; Turn (cond (( <x> )) ... ) into (or <x> (cond ... )) + (if (eq 'cond (car-safe form)) + (let ((clauses (cdr form))) + (if (and (consp (car clauses)) + (null (cdr (car clauses)))) + (list 'or (car (car clauses)) + (byte-optimize-cond + (cons (car form) (cdr (cdr form))))) + form)) + form)) + +(defun byte-optimize-if (form) + ;; (if <true-constant> <then> <else...>) ==> <then> + ;; (if <false-constant> <then> <else...>) ==> (progn <else...>) + ;; (if <test> nil <else...>) ==> (if (not <test>) (progn <else...>)) + ;; (if <test> <then> nil) ==> (if <test> <then>) + (let ((clause (nth 1 form))) + (cond ((byte-compile-trueconstp clause) + (nth 2 form)) + ((null clause) + (if (nthcdr 4 form) + (cons 'progn (nthcdr 3 form)) + (nth 3 form))) + ((nth 2 form) + (if (equal '(nil) (nthcdr 3 form)) + (list 'if clause (nth 2 form)) + form)) + ((or (nth 3 form) (nthcdr 4 form)) + (list 'if + ;; Don't make a double negative; + ;; instead, take away the one that is there. + (if (and (consp clause) (memq (car clause) '(not null)) + (= (length clause) 2)) ; (not xxxx) or (not (xxxx)) + (nth 1 clause) + (list 'not clause)) + (if (nthcdr 4 form) + (cons 'progn (nthcdr 3 form)) + (nth 3 form)))) + (t + (list 'progn clause nil))))) + +(defun byte-optimize-while (form) + (if (nth 1 form) + form)) + +(put 'and 'byte-optimizer 'byte-optimize-and) +(put 'or 'byte-optimizer 'byte-optimize-or) +(put 'cond 'byte-optimizer 'byte-optimize-cond) +(put 'if 'byte-optimizer 'byte-optimize-if) +(put 'while 'byte-optimizer 'byte-optimize-while) + +;; byte-compile-negation-optimizer lives in bytecomp.el +(put '/= 'byte-optimizer 'byte-compile-negation-optimizer) +(put 'atom 'byte-optimizer 'byte-compile-negation-optimizer) +(put 'nlistp 'byte-optimizer 'byte-compile-negation-optimizer) + + +(defun byte-optimize-funcall (form) + ;; (funcall '(lambda ...) ...) ==> ((lambda ...) ...) + ;; (funcall 'foo ...) ==> (foo ...) + (let ((fn (nth 1 form))) + (if (memq (car-safe fn) '(quote function)) + (cons (nth 1 fn) (cdr (cdr form))) + form))) + +(defun byte-optimize-apply (form) + ;; If the last arg is a literal constant, turn this into a funcall. + ;; The funcall optimizer can then transform (funcall 'foo ...) -> (foo ...). + (let ((fn (nth 1 form)) + (last (nth (1- (length form)) form))) ; I think this really is fastest + (or (if (or (null last) + (eq (car-safe last) 'quote)) + (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)))) + (byte-compile-warn + "last arg to apply can't be a literal atom: %s" + (prin1-to-string last)) + nil)) + form))) + +(put 'funcall 'byte-optimizer 'byte-optimize-funcall) +(put 'apply 'byte-optimizer 'byte-optimize-apply) + + +(put 'let 'byte-optimizer 'byte-optimize-letX) +(put 'let* 'byte-optimizer 'byte-optimize-letX) +(defun byte-optimize-letX (form) + (cond ((null (nth 1 form)) + ;; No bindings + (cons 'progn (cdr (cdr form)))) + ((or (nth 2 form) (nthcdr 3 form)) + form) + ;; The body is nil + ((eq (car form) 'let) + (append '(progn) (mapcar 'car-safe (mapcar 'cdr-safe (nth 1 form))) + '(nil))) + (t + (let ((binds (reverse (nth 1 form)))) + (list 'let* (reverse (cdr binds)) (nth 1 (car binds)) nil))))) + + +(put 'nth 'byte-optimizer 'byte-optimize-nth) +(defun byte-optimize-nth (form) + (if (and (= (safe-length form) 3) (memq (nth 1 form) '(0 1))) + (list 'car (if (zerop (nth 1 form)) + (nth 2 form) + (list 'cdr (nth 2 form)))) + (byte-optimize-predicate form))) + +(put 'nthcdr 'byte-optimizer 'byte-optimize-nthcdr) +(defun byte-optimize-nthcdr (form) + (if (and (= (safe-length form) 3) (not (memq (nth 1 form) '(0 1 2)))) + (byte-optimize-predicate form) + (let ((count (nth 1 form))) + (setq form (nth 2 form)) + (while (>= (setq count (1- count)) 0) + (setq form (list 'cdr form))) + form))) + +;;; enumerating those functions which need not be called if the returned +;;; value is not used. That is, something like +;;; (progn (list (something-with-side-effects) (yow)) +;;; (foo)) +;;; may safely be turned into +;;; (progn (progn (something-with-side-effects) (yow)) +;;; (foo)) +;;; Further optimizations will turn (progn (list 1 2 3) 'foo) into 'foo. + +;;; I wonder if I missed any :-\) +(let ((side-effect-free-fns + '(% * + - / /= 1+ 1- < <= = > >= abs acos append aref ash asin atan + assoc assq + boundp buffer-file-name buffer-local-variables buffer-modified-p + buffer-substring + capitalize car-less-than-car car cdr ceiling concat + ;; coordinates-in-window-p not in XEmacs + copy-marker cos count-lines + default-boundp default-value documentation downcase + elt exp expt fboundp featurep + file-directory-p file-exists-p file-locked-p file-name-absolute-p + 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 + int-to-string + length log log10 logand logb logior lognot logxor lsh + marker-buffer max member memq min mod + next-window nth nthcdr number-to-string + parse-colon-path previous-window + radians-to-degrees rassq regexp-quote reverse round + sin sqrt string< string= string-equal string-lessp string-to-char + string-to-int string-to-number substring symbol-plist + tan upcase user-variable-p vconcat + ;; 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)) + (side-effect-and-error-free-fns + '(arrayp atom + bobp bolp buffer-end buffer-list buffer-size buffer-string bufferp + car-safe case-table-p cdr-safe char-or-string-p char-table-p + characterp commandp cons + consolep console-live-p consp + current-buffer + ;; XEmacs: extent functions, frame-live-p, various other stuff + devicep device-live-p + dot dot-marker eobp eolp eq eql equal eventp extentp + extent-live-p floatp framep frame-live-p + get-largest-window get-lru-window + identity ignore integerp integer-or-marker-p interactive-p + invocation-directory invocation-name + ;; keymapp may autoload in XEmacs, so not on this list! + list listp + make-marker mark mark-marker markerp memory-limit minibuffer-window + ;; mouse-movement-p not in XEmacs + natnump nlistp not null number-or-marker-p numberp + one-window-p ;; overlayp not in XEmacs + point point-marker point-min point-max processp + range-table-p + selected-window sequencep stringp subrp symbolp syntax-table-p + 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) + + +(defun byte-compile-splice-in-already-compiled-code (form) + ;; form is (byte-code "..." [...] n) + (if (not (memq byte-optimize '(t lap))) + (byte-compile-normal-call form) + (byte-inline-lapcode + (byte-decompile-bytecode-1 (nth 1 form) (nth 2 form) t)) + (setq byte-compile-maxdepth (max (+ byte-compile-depth (nth 3 form)) + byte-compile-maxdepth)) + (setq byte-compile-depth (1+ byte-compile-depth)))) + +(put 'byte-code 'byte-compile 'byte-compile-splice-in-already-compiled-code) + + +(defconst byte-constref-ops + '(byte-constant byte-constant2 byte-varref byte-varset byte-varbind)) + +;;; This function extracts the bitfields from variable-length opcodes. +;;; Originally defined in disass.el (which no longer uses it.) + +(defun disassemble-offset () + "Don't call this!" + ;; fetch and return the offset for the current opcode. + ;; return NIL if this opcode has no offset + ;; OP, PTR and BYTES are used and set dynamically + (defvar op) + (defvar ptr) + (defvar bytes) + (cond ((< op byte-nth) + (let ((tem (logand op 7))) + (setq op (logand op 248)) + (cond ((eq tem 6) + (setq ptr (1+ ptr)) ;offset in next byte + ;; char-to-int to avoid downstream problems + ;; caused by chars appearing where ints are + ;; expected. In bytecode the bytes in the + ;; opcode string are always interpreted as ints. + (char-to-int (aref bytes ptr))) + ((eq tem 7) + (setq ptr (1+ ptr)) ;offset in next 2 bytes + (+ (aref bytes ptr) + (progn (setq ptr (1+ ptr)) + (lsh (aref bytes ptr) 8)))) + (t tem)))) ;offset was in opcode + ((>= op byte-constant) + (prog1 (- op byte-constant) ;offset in opcode + (setq op byte-constant))) + ((and (>= op byte-constant2) + (<= op byte-goto-if-not-nil-else-pop)) + (setq ptr (1+ ptr)) ;offset in next 2 bytes + (+ (aref bytes ptr) + (progn (setq ptr (1+ ptr)) + (lsh (aref bytes ptr) 8)))) + ;; XEmacs: this code was here before. FSF's first comparison + ;; is (>= op byte-listN). It appears that the rel-goto stuff + ;; does not exist in FSF 19.30. It doesn't exist in 19.28 + ;; either, so I'm going to assume that this is an improvement + ;; on our part and leave it in. --ben + ((and (>= op byte-rel-goto) + (<= op byte-insertN)) + (setq ptr (1+ ptr)) ;offset in next byte + ;; Use char-to-int to avoid downstream problems caused by + ;; chars appearing where ints are expected. In bytecode + ;; the bytes in the opcode string are always interpreted as + ;; ints. + (char-to-int (aref bytes ptr))))) + + +;;; This de-compiler is used for inline expansion of compiled functions, +;;; and by the disassembler. +;;; +;;; This list contains numbers, which are pc values, +;;; before each instruction. +(defun byte-decompile-bytecode (bytes constvec) + "Turns BYTECODE into lapcode, referring to CONSTVEC." + (let ((byte-compile-constants nil) + (byte-compile-variables nil) + (byte-compile-tag-number 0)) + (byte-decompile-bytecode-1 bytes constvec))) + +;; As byte-decompile-bytecode, but updates +;; byte-compile-{constants, variables, tag-number}. +;; If MAKE-SPLICEABLE is true, then `return' opcodes are replaced +;; with `goto's destined for the end of the code. +;; That is for use by the compiler. +;; If MAKE-SPLICEABLE is nil, we are being called for the disassembler. +;; In that case, we put a pc value into the list +;; before each insn (or its label). +(defun byte-decompile-bytecode-1 (bytes constvec &optional make-spliceable) + (let ((length (length bytes)) + (ptr 0) optr tags op offset + ;; tag unused + lap tmp + endtag + ;; (retcount 0) unused + ) + (while (not (= ptr length)) + (or make-spliceable + (setq lap (cons ptr lap))) + (setq op (aref bytes ptr) + optr ptr + offset (disassemble-offset)) ; this does dynamic-scope magic + (setq op (aref byte-code-vector op)) + ;; XEmacs: the next line in FSF 19.30 reads + ;; (cond ((memq op byte-goto-ops) + ;; see the comment above about byte-rel-goto in XEmacs. + (cond ((or (memq op byte-goto-ops) + (cond ((memq op byte-rel-goto-ops) + (setq op (aref byte-code-vector + (- (symbol-value op) + (- byte-rel-goto byte-goto)))) + (setq offset (+ ptr (- offset 127))) + t))) + ;; it's a pc + (setq offset + (cdr (or (assq offset tags) + (car (setq tags + (cons (cons offset + (byte-compile-make-tag)) + tags))))))) + ((cond ((eq op 'byte-constant2) (setq op 'byte-constant) t) + ((memq op byte-constref-ops))) + (setq tmp (aref constvec offset) + offset (if (eq op 'byte-constant) + (byte-compile-get-constant tmp) + (or (assq tmp byte-compile-variables) + (car (setq byte-compile-variables + (cons (list tmp) + byte-compile-variables))))))) + ((and make-spliceable + (eq op 'byte-return)) + (if (= ptr (1- length)) + (setq op nil) + (setq offset (or endtag (setq endtag (byte-compile-make-tag))) + op 'byte-goto)))) + ;; lap = ( [ (pc . (op . arg)) ]* ) + (setq lap (cons (cons optr (cons op (or offset 0))) + lap)) + (setq ptr (1+ ptr))) + ;; take off the dummy nil op that we replaced a trailing "return" with. + (let ((rest lap)) + (while rest + (cond ((numberp (car rest))) + ((setq tmp (assq (car (car rest)) tags)) + ;; this addr is jumped to + (setcdr rest (cons (cons nil (cdr tmp)) + (cdr rest))) + (setq tags (delq tmp tags)) + (setq rest (cdr rest)))) + (setq rest (cdr rest)))) + (if tags (error "optimizer error: missed tags %s" tags)) + (if (null (car (cdr (car lap)))) + (setq lap (cdr lap))) + (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)))) + (nreverse lap)))) + + +;;; peephole optimizer + +(defconst byte-tagref-ops (cons 'TAG byte-goto-ops)) + +(defconst byte-conditional-ops + '(byte-goto-if-nil byte-goto-if-not-nil byte-goto-if-nil-else-pop + byte-goto-if-not-nil-else-pop)) + +(defconst byte-after-unbind-ops + '(byte-constant byte-dup + byte-symbolp byte-consp byte-stringp byte-listp byte-numberp byte-integerp + byte-eq byte-equal byte-not + byte-cons byte-list1 byte-list2 ; byte-list3 byte-list4 + byte-interactive-p) + ;; How about other side-effect-free-ops? Is it safe to move an + ;; error invocation (such as from nth) out of an unwind-protect? + "Byte-codes that can be moved past an unbind.") + +(defconst byte-compile-side-effect-and-error-free-ops + '(byte-constant byte-dup byte-symbolp byte-consp byte-stringp byte-listp + byte-integerp byte-numberp byte-eq byte-equal byte-not byte-car-safe + byte-cdr-safe byte-cons byte-list1 byte-list2 byte-point byte-point-max + byte-point-min byte-following-char byte-preceding-char + byte-current-column byte-eolp byte-eobp byte-bolp byte-bobp + byte-current-buffer byte-interactive-p)) + +(defconst byte-compile-side-effect-free-ops + (nconc + '(byte-varref byte-nth byte-memq byte-car byte-cdr byte-length byte-aref + byte-symbol-value byte-get byte-concat2 byte-concat3 byte-sub1 byte-add1 + byte-eqlsign byte-gtr byte-lss byte-leq byte-geq byte-diff byte-negate + byte-plus byte-max byte-min byte-mult byte-char-after byte-char-syntax + byte-buffer-substring byte-string= byte-string< byte-nthcdr byte-elt + byte-member byte-assq byte-quo byte-rem) + byte-compile-side-effect-and-error-free-ops)) + +;;; This piece of shit is because of the way DEFVAR_BOOL() variables work. +;;; Consider the code +;;; +;;; (defun foo (flag) +;;; (let ((old-pop-ups pop-up-windows) +;;; (pop-up-windows flag)) +;;; (cond ((not (eq pop-up-windows old-pop-ups)) +;;; (setq old-pop-ups pop-up-windows) +;;; ...)))) +;;; +;;; Uncompiled, old-pop-ups will always be set to nil or t, even if FLAG is +;;; something else. But if we optimize +;;; +;;; varref flag +;;; varbind pop-up-windows +;;; varref pop-up-windows +;;; not +;;; to +;;; varref flag +;;; dup +;;; varbind pop-up-windows +;;; not +;;; +;;; we break the program, because it will appear that pop-up-windows and +;;; old-pop-ups are not EQ when really they are. So we have to know what +;;; the BOOL variables are, and not perform this optimization on them. +;;; +(defconst byte-boolean-vars + '(abbrev-all-caps purify-flag find-file-compare-truenames + find-file-use-truenames find-file-visit-truename + find-file-existing-other-name byte-metering-on + zmacs-regions zmacs-region-active-p zmacs-region-stays + atomic-extent-goto-char-p suppress-early-error-handler + noninteractive ignore-kernel debug-on-quit debug-on-next-call + modifier-keys-are-sticky x-allow-sendevents vms-stmlf-recfm + disable-auto-save-when-buffer-shrinks indent-tabs-mode + load-in-progress load-warn-when-source-newer load-warn-when-source-only + load-ignore-elc-files load-force-doc-strings + fail-on-bucky-bit-character-escapes popup-menu-titles + menubar-show-keybindings completion-ignore-case + canna-empty-info canna-through-info canna-underline + canna-inhibit-hankakukana x-handle-non-fully-specified-fonts + print-escape-newlines print-readably print-gensym + delete-exited-processes truncate-partial-width-windows + visible-bell no-redraw-on-reenter cursor-in-echo-area + inhibit-warning-display parse-sexp-ignore-comments words-include-escapes + scroll-on-clipped-lines pop-up-frames pop-up-windows) + "DEFVAR_BOOL variables. Giving these any non-nil value sets them to t. +If this does not enumerate all DEFVAR_BOOL variables, the byte-optimizer +may generate incorrect code.") + +(defun byte-optimize-lapcode (lap &optional for-effect) + "Simple peephole optimizer. LAP is both modified and returned." + (let (lap0 ;; off0 unused + lap1 ;; off1 + lap2 ;; off2 + (keep-going 'first-time) + (add-depth 0) + rest tmp tmp2 tmp3 + (side-effect-free (if byte-compile-delete-errors + byte-compile-side-effect-free-ops + byte-compile-side-effect-and-error-free-ops))) + (while keep-going + (or (eq keep-going 'first-time) + (byte-compile-log-lap " ---- next pass")) + (setq rest lap + keep-going nil) + (while rest + (setq lap0 (car rest) + lap1 (nth 1 rest) + lap2 (nth 2 rest)) + + ;; You may notice that sequences like "dup varset discard" are + ;; optimized but sequences like "dup varset TAG1: discard" are not. + ;; You may be tempted to change this; resist that temptation. + (cond ;; + ;; <side-effect-free> pop --> <deleted> + ;; ...including: + ;; const-X pop --> <deleted> + ;; varref-X pop --> <deleted> + ;; dup pop --> <deleted> + ;; + ((and (eq 'byte-discard (car lap1)) + (memq (car lap0) side-effect-free)) + (setq keep-going t) + (setq tmp (aref byte-stack+-info (symbol-value (car lap0)))) + (setq rest (cdr rest)) + (cond ((= tmp 1) + (byte-compile-log-lap + " %s discard\t-->\t<deleted>" lap0) + (setq lap (delq lap0 (delq lap1 lap)))) + ((= tmp 0) + (byte-compile-log-lap + " %s discard\t-->\t<deleted> discard" lap0) + (setq lap (delq lap0 lap))) + ((= tmp -1) + (byte-compile-log-lap + " %s discard\t-->\tdiscard discard" lap0) + (setcar lap0 'byte-discard) + (setcdr lap0 0)) + ((error "Optimizer error: too much on the stack")))) + ;; + ;; goto*-X X: --> X: + ;; + ((and (memq (car lap0) byte-goto-ops) + (eq (cdr lap0) lap1)) + (cond ((eq (car lap0) 'byte-goto) + (setq lap (delq lap0 lap)) + (setq tmp "<deleted>")) + ((memq (car lap0) byte-goto-always-pop-ops) + (setcar lap0 (setq tmp 'byte-discard)) + (setcdr lap0 0)) + ((error "Depth conflict at tag %d" (nth 2 lap0)))) + (and (memq byte-optimize-log '(t byte)) + (byte-compile-log " (goto %s) %s:\t-->\t%s %s:" + (nth 1 lap1) (nth 1 lap1) + tmp (nth 1 lap1))) + (setq keep-going t)) + ;; + ;; varset-X varref-X --> dup varset-X + ;; varbind-X varref-X --> dup varbind-X + ;; const/dup varset-X varref-X --> const/dup varset-X const/dup + ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup + ;; The latter two can enable other optimizations. + ;; + ((and (eq 'byte-varref (car lap2)) + (eq (cdr lap1) (cdr lap2)) + (memq (car lap1) '(byte-varset byte-varbind))) + (if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars)) + (not (eq (car lap0) 'byte-constant))) + nil + (setq keep-going t) + (if (memq (car lap0) '(byte-constant byte-dup)) + (progn + (setq tmp (if (or (not tmp) + (memq (car (cdr lap0)) '(nil t))) + (cdr lap0) + (byte-compile-get-constant t))) + (byte-compile-log-lap " %s %s %s\t-->\t%s %s %s" + lap0 lap1 lap2 lap0 lap1 + (cons (car lap0) tmp)) + (setcar lap2 (car lap0)) + (setcdr lap2 tmp)) + (byte-compile-log-lap " %s %s\t-->\tdup %s" lap1 lap2 lap1) + (setcar lap2 (car lap1)) + (setcar lap1 'byte-dup) + (setcdr lap1 0) + ;; The stack depth gets locally increased, so we will + ;; increase maxdepth in case depth = maxdepth here. + ;; This can cause the third argument to byte-code to + ;; be larger than necessary. + (setq add-depth 1)))) + ;; + ;; dup varset-X discard --> varset-X + ;; dup varbind-X discard --> varbind-X + ;; (the varbind variant can emerge from other optimizations) + ;; + ((and (eq 'byte-dup (car lap0)) + (eq 'byte-discard (car lap2)) + (memq (car lap1) '(byte-varset byte-varbind))) + (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1) + (setq keep-going t + rest (cdr rest)) + (setq lap (delq lap0 (delq lap2 lap)))) + ;; + ;; not goto-X-if-nil --> goto-X-if-non-nil + ;; not goto-X-if-non-nil --> goto-X-if-nil + ;; + ;; it is wrong to do the same thing for the -else-pop variants. + ;; + ((and (eq 'byte-not (car lap0)) + (or (eq 'byte-goto-if-nil (car lap1)) + (eq 'byte-goto-if-not-nil (car lap1)))) + (byte-compile-log-lap " not %s\t-->\t%s" + lap1 + (cons + (if (eq (car lap1) 'byte-goto-if-nil) + 'byte-goto-if-not-nil + 'byte-goto-if-nil) + (cdr lap1))) + (setcar lap1 (if (eq (car lap1) 'byte-goto-if-nil) + 'byte-goto-if-not-nil + 'byte-goto-if-nil)) + (setq lap (delq lap0 lap)) + (setq keep-going t)) + ;; + ;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X: + ;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X: + ;; + ;; it is wrong to do the same thing for the -else-pop variants. + ;; + ((and (or (eq 'byte-goto-if-nil (car lap0)) + (eq 'byte-goto-if-not-nil (car lap0))) ; gotoX + (eq 'byte-goto (car lap1)) ; gotoY + (eq (cdr lap0) lap2)) ; TAG X + (let ((inverse (if (eq 'byte-goto-if-nil (car lap0)) + 'byte-goto-if-not-nil 'byte-goto-if-nil))) + (byte-compile-log-lap " %s %s %s:\t-->\t%s %s:" + lap0 lap1 lap2 + (cons inverse (cdr lap1)) lap2) + (setq lap (delq lap0 lap)) + (setcar lap1 inverse) + (setq keep-going t))) + ;; + ;; const goto-if-* --> whatever + ;; + ((and (eq 'byte-constant (car lap0)) + (memq (car lap1) byte-conditional-ops)) + (cond ((if (or (eq (car lap1) 'byte-goto-if-nil) + (eq (car lap1) 'byte-goto-if-nil-else-pop)) + (car (cdr lap0)) + (not (car (cdr lap0)))) + (byte-compile-log-lap " %s %s\t-->\t<deleted>" + lap0 lap1) + (setq rest (cdr rest) + lap (delq lap0 (delq lap1 lap)))) + (t + (if (memq (car lap1) byte-goto-always-pop-ops) + (progn + (byte-compile-log-lap " %s %s\t-->\t%s" + lap0 lap1 (cons 'byte-goto (cdr lap1))) + (setq lap (delq lap0 lap))) + (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 + (cons 'byte-goto (cdr lap1)))) + (setcar lap1 'byte-goto))) + (setq keep-going t)) + ;; + ;; varref-X varref-X --> varref-X dup + ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup + ;; We don't optimize the const-X variations on this here, + ;; because that would inhibit some goto optimizations; we + ;; optimize the const-X case after all other optimizations. + ;; + ((and (eq 'byte-varref (car lap0)) + (progn + (setq tmp (cdr rest)) + (while (eq (car (car tmp)) 'byte-dup) + (setq tmp (cdr tmp))) + t) + (eq (cdr lap0) (cdr (car tmp))) + (eq 'byte-varref (car (car tmp)))) + (if (memq byte-optimize-log '(t byte)) + (let ((str "")) + (setq tmp2 (cdr rest)) + (while (not (eq tmp tmp2)) + (setq tmp2 (cdr tmp2) + str (concat str " dup"))) + (byte-compile-log-lap " %s%s %s\t-->\t%s%s dup" + lap0 str lap0 lap0 str))) + (setq keep-going t) + (setcar (car tmp) 'byte-dup) + (setcdr (car tmp) 0) + (setq rest tmp)) + ;; + ;; TAG1: TAG2: --> TAG1: <deleted> + ;; (and other references to TAG2 are replaced with TAG1) + ;; + ((and (eq (car lap0) 'TAG) + (eq (car lap1) 'TAG)) + (and (memq byte-optimize-log '(t byte)) + (byte-compile-log " adjacent tags %d and %d merged" + (nth 1 lap1) (nth 1 lap0))) + (setq tmp3 lap) + (while (setq tmp2 (rassq lap0 tmp3)) + (setcdr tmp2 lap1) + (setq tmp3 (cdr (memq tmp2 tmp3)))) + (setq lap (delq lap0 lap) + keep-going t)) + ;; + ;; unused-TAG: --> <deleted> + ;; + ((and (eq 'TAG (car lap0)) + (not (rassq lap0 lap))) + (and (memq byte-optimize-log '(t byte)) + (byte-compile-log " unused tag %d removed" (nth 1 lap0))) + (setq lap (delq lap0 lap) + keep-going t)) + ;; + ;; goto ... --> goto <delete until TAG or end> + ;; return ... --> return <delete until TAG or end> + ;; + ((and (memq (car lap0) '(byte-goto byte-return)) + (not (memq (car lap1) '(TAG nil)))) + (setq tmp rest) + (let ((i 0) + (opt-p (memq byte-optimize-log '(t lap))) + str deleted) + (while (and (setq tmp (cdr tmp)) + (not (eq 'TAG (car (car tmp))))) + (if opt-p (setq deleted (cons (car tmp) deleted) + str (concat str " %s") + i (1+ i)))) + (if opt-p + (let ((tagstr + (if (eq 'TAG (car (car tmp))) + (format "%d:" (car (cdr (car tmp)))) + (or (car tmp) "")))) + (if (< i 6) + (apply 'byte-compile-log-lap-1 + (concat " %s" str + " %s\t-->\t%s <deleted> %s") + lap0 + (nconc (nreverse deleted) + (list tagstr lap0 tagstr))) + (byte-compile-log-lap + " %s <%d unreachable op%s> %s\t-->\t%s <deleted> %s" + lap0 i (if (= i 1) "" "s") + tagstr lap0 tagstr)))) + (rplacd rest tmp)) + (setq keep-going t)) + ;; + ;; <safe-op> unbind --> unbind <safe-op> + ;; (this may enable other optimizations.) + ;; + ((and (eq 'byte-unbind (car lap1)) + (memq (car lap0) byte-after-unbind-ops)) + (byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0) + (setcar rest lap1) + (setcar (cdr rest) lap0) + (setq keep-going t)) + ;; + ;; varbind-X unbind-N --> discard unbind-(N-1) + ;; save-excursion unbind-N --> unbind-(N-1) + ;; save-restriction unbind-N --> unbind-(N-1) + ;; + ((and (eq 'byte-unbind (car lap1)) + (memq (car lap0) '(byte-varbind byte-save-excursion + byte-save-restriction)) + (< 0 (cdr lap1))) + (if (zerop (setcdr lap1 (1- (cdr lap1)))) + (delq lap1 rest)) + (if (eq (car lap0) 'byte-varbind) + (setcar rest (cons 'byte-discard 0)) + (setq lap (delq lap0 lap))) + (byte-compile-log-lap " %s %s\t-->\t%s %s" + lap0 (cons (car lap1) (1+ (cdr lap1))) + (if (eq (car lap0) 'byte-varbind) + (car rest) + (car (cdr rest))) + (if (and (/= 0 (cdr lap1)) + (eq (car lap0) 'byte-varbind)) + (car (cdr rest)) + "")) + (setq keep-going t)) + ;; + ;; goto*-X ... X: goto-Y --> goto*-Y + ;; goto-X ... X: return --> return + ;; + ((and (memq (car lap0) byte-goto-ops) + (memq (car (setq tmp (nth 1 (memq (cdr lap0) lap)))) + '(byte-goto byte-return))) + (cond ((and (not (eq tmp lap0)) + (or (eq (car lap0) 'byte-goto) + (eq (car tmp) 'byte-goto))) + (byte-compile-log-lap " %s [%s]\t-->\t%s" + (car lap0) tmp tmp) + (if (eq (car tmp) 'byte-return) + (setcar lap0 'byte-return)) + (setcdr lap0 (cdr tmp)) + (setq keep-going t)))) + ;; + ;; goto-*-else-pop X ... X: goto-if-* --> whatever + ;; goto-*-else-pop X ... X: discard --> whatever + ;; + ((and (memq (car lap0) '(byte-goto-if-nil-else-pop + byte-goto-if-not-nil-else-pop)) + (memq (car (car (setq tmp (cdr (memq (cdr lap0) lap))))) + (eval-when-compile + (cons 'byte-discard byte-conditional-ops))) + (not (eq lap0 (car tmp)))) + (setq tmp2 (car tmp)) + (setq tmp3 (assq (car lap0) '((byte-goto-if-nil-else-pop + byte-goto-if-nil) + (byte-goto-if-not-nil-else-pop + byte-goto-if-not-nil)))) + (if (memq (car tmp2) tmp3) + (progn (setcar lap0 (car tmp2)) + (setcdr lap0 (cdr tmp2)) + (byte-compile-log-lap " %s-else-pop [%s]\t-->\t%s" + (car lap0) tmp2 lap0)) + ;; Get rid of the -else-pop's and jump one step further. + (or (eq 'TAG (car (nth 1 tmp))) + (setcdr tmp (cons (byte-compile-make-tag) + (cdr tmp)))) + (byte-compile-log-lap " %s [%s]\t-->\t%s <skip>" + (car lap0) tmp2 (nth 1 tmp3)) + (setcar lap0 (nth 1 tmp3)) + (setcdr lap0 (nth 1 tmp))) + (setq keep-going t)) + ;; + ;; const goto-X ... X: goto-if-* --> whatever + ;; const goto-X ... X: discard --> whatever + ;; + ((and (eq (car lap0) 'byte-constant) + (eq (car lap1) 'byte-goto) + (memq (car (car (setq tmp (cdr (memq (cdr lap1) lap))))) + (eval-when-compile + (cons 'byte-discard byte-conditional-ops))) + (not (eq lap1 (car tmp)))) + (setq tmp2 (car tmp)) + (cond ((memq (car tmp2) + (if (null (car (cdr lap0))) + '(byte-goto-if-nil byte-goto-if-nil-else-pop) + '(byte-goto-if-not-nil + byte-goto-if-not-nil-else-pop))) + (byte-compile-log-lap " %s goto [%s]\t-->\t%s %s" + lap0 tmp2 lap0 tmp2) + (setcar lap1 (car tmp2)) + (setcdr lap1 (cdr tmp2)) + ;; Let next step fix the (const,goto-if*) sequence. + (setq rest (cons nil rest))) + (t + ;; Jump one step further + (byte-compile-log-lap + " %s goto [%s]\t-->\t<deleted> goto <skip>" + lap0 tmp2) + (or (eq 'TAG (car (nth 1 tmp))) + (setcdr tmp (cons (byte-compile-make-tag) + (cdr tmp)))) + (setcdr lap1 (car (cdr tmp))) + (setq lap (delq lap0 lap)))) + (setq keep-going t)) + ;; + ;; X: varref-Y ... varset-Y goto-X --> + ;; X: varref-Y Z: ... dup varset-Y goto-Z + ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.) + ;; (This is so usual for while loops that it is worth handling). + ;; + ((and (eq (car lap1) 'byte-varset) + (eq (car lap2) 'byte-goto) + (not (memq (cdr lap2) rest)) ;Backwards jump + (eq (car (car (setq tmp (cdr (memq (cdr lap2) lap))))) + 'byte-varref) + (eq (cdr (car tmp)) (cdr lap1)) + (not (memq (car (cdr lap1)) byte-boolean-vars))) + ;;(byte-compile-log-lap " Pulled %s to end of loop" (car tmp)) + (let ((newtag (byte-compile-make-tag))) + (byte-compile-log-lap + " %s: %s ... %s %s\t-->\t%s: %s %s: ... %s %s %s" + (nth 1 (cdr lap2)) (car tmp) + lap1 lap2 + (nth 1 (cdr lap2)) (car tmp) + (nth 1 newtag) 'byte-dup lap1 + (cons 'byte-goto newtag) + ) + (setcdr rest (cons (cons 'byte-dup 0) (cdr rest))) + (setcdr tmp (cons (setcdr lap2 newtag) (cdr tmp)))) + (setq add-depth 1) + (setq keep-going t)) + ;; + ;; goto-X Y: ... X: goto-if*-Y --> goto-if-not-*-X+1 Y: + ;; (This can pull the loop test to the end of the loop) + ;; + ((and (eq (car lap0) 'byte-goto) + (eq (car lap1) 'TAG) + (eq lap1 + (cdr (car (setq tmp (cdr (memq (cdr lap0) lap)))))) + (memq (car (car tmp)) + '(byte-goto byte-goto-if-nil byte-goto-if-not-nil + byte-goto-if-nil-else-pop))) +;; (byte-compile-log-lap " %s %s, %s %s --> moved conditional" +;; lap0 lap1 (cdr lap0) (car tmp)) + (let ((newtag (byte-compile-make-tag))) + (byte-compile-log-lap + "%s %s: ... %s: %s\t-->\t%s ... %s:" + lap0 (nth 1 lap1) (nth 1 (cdr lap0)) (car tmp) + (cons (cdr (assq (car (car tmp)) + '((byte-goto-if-nil . byte-goto-if-not-nil) + (byte-goto-if-not-nil . byte-goto-if-nil) + (byte-goto-if-nil-else-pop . + byte-goto-if-not-nil-else-pop) + (byte-goto-if-not-nil-else-pop . + byte-goto-if-nil-else-pop)))) + newtag) + + (nth 1 newtag) + ) + (setcdr tmp (cons (setcdr lap0 newtag) (cdr tmp))) + (if (eq (car (car tmp)) 'byte-goto-if-nil-else-pop) + ;; We can handle this case but not the -if-not-nil case, + ;; because we won't know which non-nil constant to push. + (setcdr rest (cons (cons 'byte-constant + (byte-compile-get-constant nil)) + (cdr rest)))) + (setcar lap0 (nth 1 (memq (car (car tmp)) + '(byte-goto-if-nil-else-pop + byte-goto-if-not-nil + byte-goto-if-nil + byte-goto-if-not-nil + byte-goto byte-goto)))) + ) + (setq keep-going t)) + ) + (setq rest (cdr rest))) + ) + ;; Cleanup stage: + ;; Rebuild byte-compile-constants / byte-compile-variables. + ;; Simple optimizations that would inhibit other optimizations if they + ;; were done in the optimizing loop, and optimizations which there is no + ;; need to do more than once. + (setq byte-compile-constants nil + byte-compile-variables nil) + (setq rest lap) + (while rest + (setq lap0 (car rest) + lap1 (nth 1 rest)) + (if (memq (car lap0) byte-constref-ops) + (if (eq (cdr lap0) 'byte-constant) + (or (memq (cdr lap0) byte-compile-variables) + (setq byte-compile-variables (cons (cdr lap0) + byte-compile-variables))) + (or (memq (cdr lap0) byte-compile-constants) + (setq byte-compile-constants (cons (cdr lap0) + byte-compile-constants))))) + (cond (;; + ;; const-C varset-X const-C --> const-C dup varset-X + ;; const-C varbind-X const-C --> const-C dup varbind-X + ;; + (and (eq (car lap0) 'byte-constant) + (eq (car (nth 2 rest)) 'byte-constant) + (eq (cdr lap0) (car (nth 2 rest))) + (memq (car lap1) '(byte-varbind byte-varset))) + (byte-compile-log-lap " %s %s %s\t-->\t%s dup %s" + lap0 lap1 lap0 lap0 lap1) + (setcar (cdr (cdr rest)) (cons (car lap1) (cdr lap1))) + (setcar (cdr rest) (cons 'byte-dup 0)) + (setq add-depth 1)) + ;; + ;; const-X [dup/const-X ...] --> const-X [dup ...] dup + ;; varref-X [dup/varref-X ...] --> varref-X [dup ...] dup + ;; + ((memq (car lap0) '(byte-constant byte-varref)) + (setq tmp rest + tmp2 nil) + (while (progn + (while (eq 'byte-dup (car (car (setq tmp (cdr tmp)))))) + (and (eq (cdr lap0) (cdr (car tmp))) + (eq (car lap0) (car (car tmp))))) + (setcar tmp (cons 'byte-dup 0)) + (setq tmp2 t)) + (if tmp2 + (byte-compile-log-lap + " %s [dup/%s]...\t-->\t%s dup..." lap0 lap0 lap0))) + ;; + ;; unbind-N unbind-M --> unbind-(N+M) + ;; + ((and (eq 'byte-unbind (car lap0)) + (eq 'byte-unbind (car lap1))) + (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 + (cons 'byte-unbind + (+ (cdr lap0) (cdr lap1)))) + (setq keep-going t) + (setq lap (delq lap0 lap)) + (setcdr lap1 (+ (cdr lap1) (cdr lap0)))) + ) + (setq rest (cdr rest))) + (setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth))) + lap) + +(provide 'byte-optimize) + + +;; To avoid "lisp nesting exceeds max-lisp-eval-depth" when this file compiles +;; itself, compile some of its most used recursive functions (at load time). +;; +(eval-when-compile + (or (compiled-function-p (symbol-function 'byte-optimize-form)) + (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)))) + nil) + +;;; byte-optimize.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/bytecomp-runtime.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,241 @@ +;;; bytecomp-runtime.el --- byte-compiler support for inlining + +;; Copyright (C) 1992, 1997 Free Software Foundation, Inc. + +;; Author: Jamie Zawinski <jwz@netscape.com> +;; Author: Hallvard Furuseth <hbf@ulrik.uio.no> +;; Maintainer: XEmacs Development Team +;; Keywords: internal, dumped + +;; 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. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;; The code in this file should always be loaded, because it defines things +;; like "defsubst" which should work interpreted as well. The code in +;; bytecomp.el and byte-optimize.el can be loaded as needed. + +;; interface to selectively inlining functions. +;; This only happens when source-code optimization is turned on. + +;;; Code: + +;; Redefined in byte-optimize.el. +;; This is not documented--it's not clear that we should promote it. +(fset 'inline 'progn) +(put 'inline 'lisp-indent-hook 0) + + +;;; Interface to inline functions. + +;; FSF comments the next two out, but I see no reason to do so. --ben +(defmacro proclaim-inline (&rest fns) + "Cause the named functions to be open-coded when called from compiled code. +They will only be compiled open-coded when byte-optimize is true." + (cons 'eval-and-compile + (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)))) + fns)))) + + +(defmacro proclaim-notinline (&rest fns) + "Cause the named functions to no longer be open-coded." + (cons 'eval-and-compile + (apply + 'nconc + (mapcar + '(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. +(defmacro defsubst (name arglist &rest body) + "Define an inline function. The syntax is just like that of `defun'." + (or (memq (get name 'byte-optimizer) + '(nil byte-compile-inline-expand)) + (error "`%s' is a primitive" name)) + (list 'prog1 + (cons 'defun (cons name (cons arglist body))) + (list 'proclaim-inline name))) +; Instead of the above line, FSF has this: +; (list 'eval-and-compile +; (list 'put (list 'quote name) +; ''byte-optimizer ''byte-compile-inline-expand)))) + +(defun make-obsolete (fn new) + "Make the byte-compiler warn that FUNCTION is obsolete. +The warning will say that NEW should be used instead. +If NEW is a string, that is the `use instead' message." + (interactive "aMake function obsolete: \nxObsoletion replacement: ") + (let ((handler (get fn 'byte-compile))) + (if (eq 'byte-compile-obsolete handler) + (setcar (get fn 'byte-obsolete-info) new) + (put fn 'byte-obsolete-info (cons new handler)) + (put fn 'byte-compile 'byte-compile-obsolete))) + fn) + +(defun make-obsolete-variable (var new) + "Make the byte-compiler warn that VARIABLE is obsolete, +and NEW should be used instead. If NEW is a string, then that is the +`use instead' message." + (interactive + (list + (let ((str (completing-read "Make variable obsolete: " obarray 'boundp t))) + (if (equal str "") (error "")) + (intern str)) + (car (read-from-string (read-string "Obsoletion replacement: "))))) + (put var 'byte-obsolete-variable new) + var) + +;; By overwhelming demand, we separate out truly obsolete symbols from +;; those that are present for GNU Emacs compatibility. +(defun make-compatible (fn new) + "Make the byte-compiler know that FUNCTION is provided for compatibility. +The warning will say that NEW should be used instead. +If NEW is a string, that is the `use instead' message." + (interactive "aMake function compatible: \nxCompatible replacement: ") + (let ((handler (get fn 'byte-compile))) + (if (eq 'byte-compile-compatible handler) + (setcar (get fn 'byte-compatible-info) new) + (put fn 'byte-compatible-info (cons new handler)) + (put fn 'byte-compile 'byte-compile-compatible))) + fn) + +(defun make-compatible-variable (var new) + "Make the byte-compiler know that VARIABLE is provided for compatibility. +and NEW should be used instead. If NEW is a string, then that is the +`use instead' message." + (interactive + (list + (let ((str (completing-read "Make variable compatible: " + obarray 'boundp t))) + (if (equal str "") (error "")) + (intern str)) + (car (read-from-string (read-string "Compatible replacement: "))))) + (put var 'byte-compatible-variable new) + var) + +(put 'dont-compile 'lisp-indent-hook 0) +(defmacro dont-compile (&rest body) + "Like `progn', but the body always runs interpreted (not compiled). +If you think you need this, you're probably making a mistake somewhere." + (list 'eval (list 'quote (if (cdr body) (cons 'progn body) (car body))))) + + +;;; interface to evaluating things at compile time and/or load time +;;; these macro must come after any uses of them in this file, as their +;;; definition in the file overrides the magic definitions on the +;;; byte-compile-macro-environment. + +(put 'eval-when-compile 'lisp-indent-hook 0) +(defmacro eval-when-compile (&rest body) + "Like `progn', but evaluates the body at compile time. +The result of the body appears to the compiler as a quoted constant." + ;; Not necessary because we have it in b-c-initial-macro-environment + ;; (list 'quote (eval (cons 'progn body))) + (cons 'progn body)) + +(put 'eval-and-compile 'lisp-indent-hook 0) +(defmacro eval-and-compile (&rest body) + "Like `progn', but evaluates the body at compile time and at load time." + ;; Remember, it's magic. + (cons 'progn body)) + +;;; From Emacs 20. +(put 'eval-when-feature 'lisp-indent-hook 1) +(defmacro eval-when-feature (feature &rest body) + "Run the body forms when FEATURE is featurep, be it now or later. +Called (eval-when-feature (FEATURE [. FILENAME]) BODYFORMS...). +If (featurep 'FEATURE), evals now; otherwise adds an elt to +`after-load-alist' (which see), using FEATURE as filename if FILENAME is nil." + (let ((file (or (cdr feature) (symbol-name (car feature))))) + `(let ((bodythunk (function (lambda () ,@body)))) + (if (featurep ',(car feature)) + (funcall bodythunk) + (setq after-load-alist (cons '(,file . (list 'lambda '() bodythunk)) + after-load-alist)))))) + + + +;;; Interface to file-local byte-compiler parameters. +;;; Redefined in bytecomp.el. + +;;; The great RMS speaketh: +;;; +;;; I nuked this because it's not a good idea for users to think of +;;; using it. These options are a matter of installation preference, +;;; and have nothing to do with particular source files; it's a +;;; mistake to suggest to users that they should associate these with +;;; particular source files. There is hardly any reason to change +;;; these parameters, anyway. --rms. +;;; +;;; But I'll leave this stuff alone. --ben + +(put 'byte-compiler-options 'lisp-indent-hook 0) +(defmacro byte-compiler-options (&rest args) + "Set some compilation-parameters for this file. +This will affect only the file in which it appears; this does nothing when +evaluated, or when loaded from a .el file. + +Each argument to this macro must be a list of a key and a value. + + Keys: Values: Corresponding variable: + + verbose t, nil byte-compile-verbose + optimize t, nil, source, byte byte-optimize + warnings list of warnings byte-compile-warnings + file-format emacs19, emacs20 byte-compile-emacs19-compatibility + +The value specified with the `warnings' option must be a list, containing +some subset of the following flags: + + free-vars references to variables not in the current lexical scope. + 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. + redefine function cell redefined from a macro to a lambda or vice + versa, or redefined to take a different number of arguments. + +If the first element if the list is `+' or `-' then the specified elements +are added to or removed from the current set of warnings, instead of the +entire set of warnings being overwritten. + +For example, something like this might appear at the top of a source file: + + (byte-compiler-options + (optimize t) + (warnings (- callargs)) ; Don't warn about arglist mismatch + (warnings (+ unused-vars)) ; Do warn about unused bindings + (file-format emacs19))" + nil) + +;;; bytecomp-runtime.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/bytecomp.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,4100 @@ +;;; bytecomp.el --- compilation of Lisp code into byte code. + +;;; Copyright (C) 1985-1987, 1991-1994 Free Software Foundation, Inc. +;;; Copyright (C) 1996 Ben Wing. + +;; Author: Jamie Zawinski <jwz@netscape.com> +;; Hallvard Furuseth <hbf@ulrik.uio.no> +;; Keywords: internal + +;; Subsequently modified by RMS and others. + +(defconst byte-compile-version (purecopy "2.25 XEmacs; 22-Mar-96.")) + +;; 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. + +;;; Commentary: + +;; The Emacs Lisp byte compiler. This crunches lisp source into a sort +;; of p-code which takes up less space and can be interpreted faster. +;; The user entry points are byte-compile-file and byte-recompile-directory. + +;;; Code: + +;;; ======================================================================== +;;; Entry points: +;;; byte-recompile-directory, byte-compile-file, +;;; batch-byte-compile, batch-byte-recompile-directory, +;;; byte-compile, compile-defun, +;;; display-call-tree +;;; RMS says: +;;; (byte-compile-buffer and byte-compile-and-load-file were turned off +;;; because they are not terribly useful and get in the way of completion.) +;;; But I'm leaving them. --ben + +;;; This version of the byte compiler has the following improvements: +;;; + optimization of compiled code: +;;; - removal of unreachable code; +;;; - removal of calls to side-effectless functions whose return-value +;;; is unused; +;;; - compile-time evaluation of safe constant forms, such as (consp nil) +;;; and (ash 1 6); +;;; - open-coding of literal lambdas; +;;; - peephole optimization of emitted code; +;;; - trivial functions are left uncompiled for speed. +;;; + support for inline functions; +;;; + compile-time evaluation of arbitrary expressions; +;;; + compile-time warning messages for: +;;; - functions being redefined with incompatible arglists; +;;; - functions being redefined as macros, or vice-versa; +;;; - functions or macros defined multiple times in the same file; +;;; - functions being called with the incorrect number of arguments; +;;; - functions being called which are not defined globally, in the +;;; file, or as autoloads; +;;; - assignment and reference of undeclared free variables; +;;; - various syntax errors; +;;; + correct compilation of nested defuns, defmacros, defvars and defsubsts; +;;; + correct compilation of top-level uses of macros; +;;; + the ability to generate a histogram of functions called. + +;;; User customization variables: +;;; +;;; byte-compile-verbose Whether to report the function currently being +;;; compiled in the minibuffer; +;;; byte-optimize Whether to do optimizations; this may be +;;; t, nil, 'source, or 'byte; +;;; byte-optimize-log Whether to report (in excruciating detail) +;;; exactly which optimizations have been made. +;;; This may be t, nil, 'source, or 'byte; +;;; byte-compile-error-on-warn Whether to stop compilation when a warning is +;;; produced; +;;; byte-compile-delete-errors Whether the optimizer may delete calls or +;;; variable references that are side-effect-free +;;; except that they may return an error. +;;; byte-compile-generate-call-tree Whether to generate a histogram of +;;; function calls. This can be useful for +;;; finding unused functions, as well as simple +;;; performance metering. +;;; byte-compile-warnings List of warnings to issue, or t. May contain +;;; 'free-vars (references to variables not in the +;;; current lexical scope) +;;; 'unused-vars (non-global variables bound but +;;; not referenced) +;;; 'unresolved (calls to unknown functions) +;;; 'callargs (lambda calls with args that don't +;;; match the lambda's definition) +;;; 'redefine (function cell redefined from +;;; a macro to a lambda or vice versa, +;;; or redefined to take other args) +;;; 'obsolete (obsolete variables and functions) +;;; 'pedantic (references to Emacs-compatible +;;; symbols) +;;; byte-compile-emacs19-compatibility Whether the compiler should +;;; generate .elc files which can be loaded into +;;; generic emacs 19. +;;; emacs-lisp-file-regexp Regexp for the extension of source-files; +;;; see also the function byte-compile-dest-file. +;;; byte-compile-overwrite-file If nil, delete old .elc files before saving. +;;; +;;; Most of the above parameters can also be set on a file-by-file basis; see +;;; the documentation of the `byte-compiler-options' macro. + +;;; New Features: +;;; +;;; o The form `defsubst' is just like `defun', except that the function +;;; generated will be open-coded in compiled code which uses it. This +;;; means that no function call will be generated, it will simply be +;;; spliced in. Lisp functions calls are very slow, so this can be a +;;; big win. +;;; +;;; You can generally accomplish the same thing with `defmacro', but in +;;; that case, the defined procedure can't be used as an argument to +;;; mapcar, etc. +;;; +;;; o You can make a given function be inline even if it has already been +;;; defined with `defun' by using the `proclaim-inline' form like so: +;;; (proclaim-inline my-function) +;;; This is, in fact, exactly what `defsubst' does. To make a function no +;;; longer be inline, you must use `proclaim-notinline'. Beware that if +;;; you define a function with `defsubst' and later redefine it with +;;; `defun', it will still be open-coded until you use proclaim-notinline. +;;; +;;; o You can also open-code one particular call to a function without +;;; open-coding all calls. Use the 'inline' form to do this, like so: +;;; +;;; (inline (foo 1 2 3)) ;; `foo' will be open-coded +;;; or... +;;; (inline ;; `foo' and `baz' will be +;;; (foo 1 2 3 (bar 5)) ;; open-coded, but `bar' will not. +;;; (baz 0)) +;;; +;;; o It is possible to open-code a function in the same file it is defined +;;; in without having to load that file before compiling it. the +;;; byte-compiler has been modified to remember function definitions in +;;; the compilation environment in the same way that it remembers macro +;;; definitions. +;;; +;;; o Forms like ((lambda ...) ...) are open-coded. +;;; +;;; o The form `eval-when-compile' is like progn, except that the body +;;; is evaluated at compile-time. When it appears at top-level, this +;;; is analogous to the Common Lisp idiom (eval-when (compile) ...). +;;; When it does not appear at top-level, it is similar to the +;;; Common Lisp #. reader macro (but not in interpreted code). +;;; +;;; o The form `eval-and-compile' is similar to eval-when-compile, but +;;; the whole form is evalled both at compile-time and at run-time. +;;; +;;; o The command M-x byte-compile-and-load-file does what you'd think. +;;; +;;; o The command compile-defun is analogous to eval-defun. +;;; +;;; o If you run byte-compile-file on a filename which is visited in a +;;; 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 +;;; generated by this compiler: +;;; +;;; 0 string ;ELC GNU Emacs Lisp compiled file, +;;; >4 byte x version %d +;;; +;;; TO DO: +;;; +;;; o Should implement declarations and proclamations, notably special, +;;; unspecial, and ignore. Do this in such a way as to not break cl.el. +;;; o The bound-but-not-used warnings are not issued for variables whose +;;; bindings were established in the arglist, due to the lack of an +;;; ignore declaration. Once ignore exists, this should be turned on. +;;; o Warn about functions and variables defined but not used? +;;; Maybe add some kind of `export' declaration for this? +;;; (With interactive functions being automatically exported?) +;;; o Any reference to a variable, even one which is a no-op, will cause +;;; the warning not to be given. Possibly we could use the for-effect +;;; flag to determine when this reference is useless; possibly more +;;; complex flow analysis would be necessary. +;;; o If the optimizer deletes a variable reference, we might be left with +;;; a bound-but-not-referenced warning. Generally this is ok, but not if +;;; it's a synergistic result of macroexpansion. Need some way to note +;;; that a varref is being optimized away? Of course it would be nice to +;;; optimize away the binding too, someday, but it's unsafe today. +;;; o (See byte-optimize.el for the optimization TODO list.) + +(require 'backquote) + +(or (fboundp 'defsubst) + ;; This really ought to be loaded already! + (load-library "bytecomp-runtime")) + +(eval-when-compile + (defvar byte-compile-single-version nil + "If this is true, the choice of emacs version (v19 or v20) byte-codes will +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))) + ) + +(defvar emacs-lisp-file-regexp (if (eq system-type 'vax-vms) + (purecopy "\\.EL\\(;[0-9]+\\)?$") + (purecopy "\\.el$")) + "*Regexp which matches Emacs Lisp source files. +You may want to redefine `byte-compile-dest-file' if you change this.") + +;; This enables file name handlers such as jka-compr +;; to remove parts of the file name that should not be copied +;; through to the output file name. +(defun byte-compiler-base-file-name (filename) + (let ((handler (find-file-name-handler filename + 'byte-compiler-base-file-name))) + (if handler + (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"))))) + +;; This can be the 'byte-compile property of any symbol. +(autoload 'byte-compile-inline-expand "byte-optimize") + +;; This is the entrypoint to the lapcode optimizer pass1. +(autoload 'byte-optimize-form "byte-optimize") +;; This is the entrypoint to the lapcode optimizer pass2. +(autoload 'byte-optimize-lapcode "byte-optimize") +(autoload 'byte-compile-unfold-lambda "byte-optimize") + +;; This is the entry point to the decompiler, which is used by the +;; 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") + +(defvar byte-compile-verbose + (and (not noninteractive) (> (device-baud-rate) search-slow-speed)) + "*Non-nil means print messages describing progress of byte-compiler.") + +(defvar byte-compile-emacs19-compatibility + (not (emacs-version>= 20)) + "*Non-nil means generate output that can run in Emacs 19.") + +(defvar byte-optimize t + "*Enables optimization in the byte compiler. +nil means don't do any optimization. +t means do all optimizations. +`source' means do source-level optimizations only. +`byte' means do code-level optimizations only.") + +(defvar byte-compile-delete-errors t + "*If non-nil, the optimizer may delete forms that may signal an error. +This includes variable references and calls to functions such as `car'.") + +;; XEmacs addition +(defvar byte-compile-new-bytecodes nil + "This is completely ignored. It is only around for backwards +compatibility.") + + +;; FSF enables byte-compile-dynamic-docstrings but not byte-compile-dynamic +;; by default. This would be a reasonable conservative approach except +;; for the fact that if you enable either of these, you get incompatible +;; byte code that can't be read by XEmacs 19.13 or before or FSF 19.28 or +;; before. +;; +;; Therefore, neither is enabled for 19.14. Both are enabled for 20.0 +;; because we have no reason to be conservative about changing the +;; way things work. (Ben) + +;; However, I don't think that defaulting byte-compile-dynamic to nil +;; is a compatibility issue - rather it is a performance issue. +;; Therefore I am setting byte-compile-dynamic back to nil. (mrb) + +(defvar byte-compile-dynamic nil + "*If non-nil, compile function bodies so they load lazily. +They are hidden comments in the compiled file, and brought into core when the +function is called. + +To enable this option, make it a file-local variable +in the source file you want it to apply to. +For example, add -*-byte-compile-dynamic: t;-*- on the first line. + +When this option is true, if you load the compiled file and then move it, +the functions you loaded will not be able to run.") + +(defvar byte-compile-dynamic-docstrings (emacs-version>= 20) + "*If non-nil, compile doc strings for lazy access. +We bury the doc strings of functions and variables +inside comments in the file, and bring them into core only when they +are actually needed. + +When this option is true, if you load the compiled file and then move it, +you won't be able to find the documentation of anything in that file. + +To disable this option for a certain file, make it a file-local variable +in the source file. For example, add this to the first line: + -*-byte-compile-dynamic-docstrings:nil;-*- +You can also set the variable globally. + +This option is enabled by default because it reduces Emacs memory usage.") + +(defvar byte-optimize-log nil + "*If true, the byte-compiler will log its optimizations into *Compile-Log*. +If this is 'source, then only source-level optimizations will be logged. +If it is 'byte, then only byte-level optimizations will be logged.") + +(defvar byte-compile-error-on-warn nil + "*If true, the byte-compiler reports warnings with `error'.") + +;; byte-compile-warning-types in FSF. +(defvar byte-compile-default-warnings + '(redefine callargs free-vars unresolved unused-vars obsolete) + "*The warnings used when byte-compile-warnings is t.") + +(defvar byte-compile-warnings t + "*List of warnings that the compiler should issue (t for the default set). +Elements of the list may be: + + free-vars references to variables not in the current lexical scope. + 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. + 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. + pedantic warn of use of compatible symbols. + +The default set is specified by `byte-compile-default-warnings' and +normally encompasses all possible warnings. + +See also the macro `byte-compiler-options'.") + +(defvar byte-compile-generate-call-tree nil + "*Non-nil means collect call-graph information when compiling. +This records functions were called and from where. +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. + +The call tree only lists functions called, not macros used. Those functions +which the byte-code interpreter knows about directly (eq, cons, etc.) are +not reported. + +The call tree also lists those functions which are not known to be called +\(that is, to which no calls have been compiled). Functions which can be +invoked interactively are excluded from this list.") + +(defconst byte-compile-call-tree nil "Alist of functions and their call tree. +Each element looks like + + \(FUNCTION CALLERS CALLS\) + +where CALLERS is a list of functions that call FUNCTION, and CALLS +is a list of functions for which calls were generated while compiling +FUNCTION.") + +(defvar byte-compile-call-tree-sort 'name + "*If non-nil, sort the call tree. +The values `name', `callers', `calls', `calls+callers' +specify different fields to sort on.") + +(defvar byte-compile-overwrite-file t + "If nil, old .elc files are deleted before the new is saved, and .elc +files will have the same modes as the corresponding .el file. Otherwise, +existing .elc files will simply be overwritten, and the existing modes +will not be changed. If this variable is nil, then an .elc file which +is a symbolic link will be turned into a normal file, instead of the file +which the link points to being overwritten.") + +(defvar byte-recompile-directory-ignore-errors-p nil + "If true, then `byte-recompile-directory' will continue compiling even +when an error occurs in a file. This is bound to t by +`batch-byte-recompile-directory'.") + +(defvar byte-recompile-directory-recursively t + "*If true, then `byte-recompile-directory' will recurse on subdirectories.") + +(defvar byte-compile-constants nil + "list of all constants encountered during compilation of this form") +(defvar byte-compile-variables nil + "list of all variables encountered during compilation of this form") +(defvar byte-compile-bound-variables nil + "Alist of variables bound in the context of the current form, +that is, the current lexical environment. This list lives partly +on the specbind stack. The cdr of each cell is an integer bitmask.") + +(defconst byte-compile-referenced-bit 1) +(defconst byte-compile-assigned-bit 2) +(defconst byte-compile-arglist-bit 4) +(defconst byte-compile-global-bit 8) + +(defvar byte-compile-free-references) +(defvar byte-compile-free-assignments) + +(defvar byte-compiler-error-flag) + +(defconst byte-compile-initial-macro-environment + (purecopy + '((byte-compiler-options . (lambda (&rest forms) + (apply 'byte-compiler-options-handler forms))) + (eval-when-compile . (lambda (&rest body) + (list 'quote (eval (byte-compile-top-level + (cons 'progn body)))))) + (eval-and-compile . (lambda (&rest body) + (eval (cons 'progn body)) + (cons 'progn body))))) + "The default macro-environment passed to macroexpand by the compiler. +Placing a macro here will cause a macro to have different semantics when +expanded by the compiler as when expanded by the interpreter.") + +(defvar byte-compile-macro-environment byte-compile-initial-macro-environment + "Alist of macros defined in the file being compiled. +Each element looks like (MACRONAME . DEFINITION). It is +\(MACRONAME . nil) when a macro is redefined as a function.") + +(defvar byte-compile-function-environment nil + "Alist of functions defined in the file being compiled. +This is so we can inline them when necessary. +Each element looks like (FUNCTIONNAME . DEFINITION). It is +\(FUNCTIONNAME . nil) when a function is redefined as a macro.") + +(defvar byte-compile-autoload-environment nil + "Alist of functions and macros defined by autoload in the file being compiled. +This is so we can suppress warnings about calls to these functions, even though +they do not have `real' definitions. +Each element looks like (FUNCTIONNAME . CALL-TO-AUTOLOAD).") + +(defvar byte-compile-unresolved-functions nil + "Alist of undefined functions to which calls have been compiled (used for +warnings when the function is later defined with incorrect args).") + +(defvar byte-compile-file-domain) ; domain of file being compiled + +(defvar byte-compile-tag-number 0) +(defvar byte-compile-output nil + "Alist describing contents to put in byte code string. +Each element is (INDEX . VALUE)") +(defvar byte-compile-depth 0 "Current depth of execution stack.") +(defvar byte-compile-maxdepth 0 "Maximum depth of execution stack.") + + +;;; The byte codes; this information is duplicated in bytecode.c + +(defconst byte-code-vector nil + "An array containing byte-code names indexed by byte-code values.") + +(defconst byte-stack+-info nil + "An array with the stack adjustment for each byte-code.") + +(defmacro byte-defop (opcode stack-adjust opname &optional docstring) + ;; This is a speed-hack for building the byte-code-vector at compile-time. + ;; We fill in the vector at macroexpand-time, and then after the last call + ;; to byte-defop, we write the vector out as a constant instead of writing + ;; out a bunch of calls to aset. + ;; Actually, we don't fill in the vector itself, because that could make + ;; it problematic to compile big changes to this compiler; we store the + ;; values on its plist, and remove them later in -extrude. + (let ((v1 (or (get 'byte-code-vector 'tmp-compile-time-value) + (put 'byte-code-vector 'tmp-compile-time-value + (make-vector 256 nil)))) + (v2 (or (get 'byte-stack+-info 'tmp-compile-time-value) + (put 'byte-stack+-info 'tmp-compile-time-value + (make-vector 256 nil))))) + (aset v1 opcode opname) + (aset v2 opcode stack-adjust)) + (if docstring + (list 'defconst opname opcode (concat "Byte code opcode " docstring ".")) + (list 'defconst opname opcode))) + +(defmacro byte-extrude-byte-code-vectors () + (prog1 (list 'setq 'byte-code-vector + (get 'byte-code-vector 'tmp-compile-time-value) + 'byte-stack+-info + (get 'byte-stack+-info 'tmp-compile-time-value)) + (remprop 'byte-code-vector 'tmp-compile-time-value) + (remprop 'byte-stack+-info 'tmp-compile-time-value))) + + +;; unused: 0-7 + +;; These opcodes are special in that they pack their argument into the +;; opcode word. +;; +(byte-defop 8 1 byte-varref "for variable reference") +(byte-defop 16 -1 byte-varset "for setting a variable") +(byte-defop 24 -1 byte-varbind "for binding a variable") +(byte-defop 32 0 byte-call "for calling a function") +(byte-defop 40 0 byte-unbind "for unbinding special bindings") +;; codes 8-47 are consumed by the preceding opcodes + +;; unused: 48-55 + +(byte-defop 56 -1 byte-nth) +(byte-defop 57 0 byte-symbolp) +(byte-defop 58 0 byte-consp) +(byte-defop 59 0 byte-stringp) +(byte-defop 60 0 byte-listp) +(byte-defop 61 -1 byte-old-eq) +(byte-defop 62 -1 byte-old-memq) +(byte-defop 63 0 byte-not) +(byte-defop 64 0 byte-car) +(byte-defop 65 0 byte-cdr) +(byte-defop 66 -1 byte-cons) +(byte-defop 67 0 byte-list1) +(byte-defop 68 -1 byte-list2) +(byte-defop 69 -2 byte-list3) +(byte-defop 70 -3 byte-list4) +(byte-defop 71 0 byte-length) +(byte-defop 72 -1 byte-aref) +(byte-defop 73 -2 byte-aset) +(byte-defop 74 0 byte-symbol-value) +(byte-defop 75 0 byte-symbol-function) ; this was commented out +(byte-defop 76 -1 byte-set) +(byte-defop 77 -1 byte-fset) ; this was commented out +(byte-defop 78 -1 byte-get) +(byte-defop 79 -2 byte-substring) +(byte-defop 80 -1 byte-concat2) +(byte-defop 81 -2 byte-concat3) +(byte-defop 82 -3 byte-concat4) +(byte-defop 83 0 byte-sub1) +(byte-defop 84 0 byte-add1) +(byte-defop 85 -1 byte-eqlsign) +(byte-defop 86 -1 byte-gtr) +(byte-defop 87 -1 byte-lss) +(byte-defop 88 -1 byte-leq) +(byte-defop 89 -1 byte-geq) +(byte-defop 90 -1 byte-diff) +(byte-defop 91 0 byte-negate) +(byte-defop 92 -1 byte-plus) +(byte-defop 93 -1 byte-max) +(byte-defop 94 -1 byte-min) +(byte-defop 95 -1 byte-mult) +(byte-defop 96 1 byte-point) +(byte-defop 97 -1 byte-eq) ; new as of v20 +(byte-defop 98 0 byte-goto-char) +(byte-defop 99 0 byte-insert) +(byte-defop 100 1 byte-point-max) +(byte-defop 101 1 byte-point-min) +(byte-defop 102 0 byte-char-after) +(byte-defop 103 1 byte-following-char) +(byte-defop 104 1 byte-preceding-char) +(byte-defop 105 1 byte-current-column) +(byte-defop 106 0 byte-indent-to) +(byte-defop 107 -1 byte-equal) ; new as of v20 +(byte-defop 108 1 byte-eolp) +(byte-defop 109 1 byte-eobp) +(byte-defop 110 1 byte-bolp) +(byte-defop 111 1 byte-bobp) +(byte-defop 112 1 byte-current-buffer) +(byte-defop 113 0 byte-set-buffer) +(byte-defop 114 0 byte-save-current-buffer + "To make a binding to record the current buffer.") +;;(byte-defop 114 1 byte-read-char-OBSOLETE) ;obsolete as of v19 +(byte-defop 115 -1 byte-memq) ; new as of v20 +(byte-defop 116 1 byte-interactive-p) + +(byte-defop 117 0 byte-forward-char) +(byte-defop 118 0 byte-forward-word) +(byte-defop 119 -1 byte-skip-chars-forward) +(byte-defop 120 -1 byte-skip-chars-backward) +(byte-defop 121 0 byte-forward-line) +(byte-defop 122 0 byte-char-syntax) +(byte-defop 123 -1 byte-buffer-substring) +(byte-defop 124 -1 byte-delete-region) +(byte-defop 125 -1 byte-narrow-to-region) +(byte-defop 126 1 byte-widen) +(byte-defop 127 0 byte-end-of-line) + +;; unused: 128 + +;; These store their argument in the next two bytes +(byte-defop 129 1 byte-constant2 + "for reference to a constant with vector index >= byte-constant-limit") +(byte-defop 130 0 byte-goto "for unconditional jump") +(byte-defop 131 -1 byte-goto-if-nil "to pop value and jump if it's nil") +(byte-defop 132 -1 byte-goto-if-not-nil + "to pop value and jump if it's not nil") +(byte-defop 133 -1 byte-goto-if-nil-else-pop + "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, +otherwise pop it") + +(byte-defop 135 -1 byte-return "to pop a value and return it from `byte-code'") +(byte-defop 136 -1 byte-discard "to discard one value from stack") +(byte-defop 137 1 byte-dup "to duplicate the top of the stack") + +(byte-defop 138 0 byte-save-excursion + "to make a binding to record the buffer, point and mark") +(byte-defop 139 0 byte-save-window-excursion + "to make a binding to record entire window configuration") +(byte-defop 140 0 byte-save-restriction + "to make a binding to record the current buffer clipping restrictions") +(byte-defop 141 -1 byte-catch + "for catch. Takes, on stack, the tag and an expression for the body") +(byte-defop 142 -1 byte-unwind-protect + "for unwind-protect. Takes, on stack, an expression for the unwind-action") + +;; For condition-case. Takes, on stack, the variable to bind, +;; an expression for the body, and a list of clauses. +(byte-defop 143 -2 byte-condition-case) + +;; For entry to with-output-to-temp-buffer. +;; Takes, on stack, the buffer name. +;; Binds standard-output and does some other things. +;; Returns with temp buffer on the stack in place of buffer name. +(byte-defop 144 0 byte-temp-output-buffer-setup) + +;; For exit from with-output-to-temp-buffer. +;; Expects the temp buffer on the stack underneath value to return. +;; Pops them both, then pushes the value back on. +;; Unbinds standard-output and makes the temp buffer visible. +(byte-defop 145 -1 byte-temp-output-buffer-show) + +;; To unbind back to the beginning of this frame. +;; Not used yet, but will be needed for tail-recursion elimination. +(byte-defop 146 0 byte-unbind-all) + +(byte-defop 147 -2 byte-set-marker) +(byte-defop 148 0 byte-match-beginning) +(byte-defop 149 0 byte-match-end) +(byte-defop 150 0 byte-upcase) +(byte-defop 151 0 byte-downcase) +(byte-defop 152 -1 byte-string=) +(byte-defop 153 -1 byte-string<) +(byte-defop 154 -1 byte-old-equal) +(byte-defop 155 -1 byte-nthcdr) +(byte-defop 156 -1 byte-elt) +(byte-defop 157 -1 byte-old-member) +(byte-defop 158 -1 byte-old-assq) +(byte-defop 159 0 byte-nreverse) +(byte-defop 160 -1 byte-setcar) +(byte-defop 161 -1 byte-setcdr) +(byte-defop 162 0 byte-car-safe) +(byte-defop 163 0 byte-cdr-safe) +(byte-defop 164 -1 byte-nconc) +(byte-defop 165 -1 byte-quo) +(byte-defop 166 -1 byte-rem) +(byte-defop 167 0 byte-numberp) +(byte-defop 168 0 byte-integerp) + +;; unused: 169 + +;; These are not present in FSF. +;; +(byte-defop 170 0 byte-rel-goto) +(byte-defop 171 -1 byte-rel-goto-if-nil) +(byte-defop 172 -1 byte-rel-goto-if-not-nil) +(byte-defop 173 -1 byte-rel-goto-if-nil-else-pop) +(byte-defop 174 -1 byte-rel-goto-if-not-nil-else-pop) + +(byte-defop 175 nil byte-listN) +(byte-defop 176 nil byte-concatN) +(byte-defop 177 nil byte-insertN) + +;; unused: 178-181 + +;; these ops are new to v20 +(byte-defop 182 -1 byte-member) +(byte-defop 183 -1 byte-assq) + +;; unused: 184-191 + +(byte-defop 192 1 byte-constant "for reference to a constant") +;; codes 193-255 are consumed by byte-constant. +(defconst byte-constant-limit 64 + "Exclusive maximum index usable in the `byte-constant' opcode.") + +(defconst byte-goto-ops (purecopy + '(byte-goto byte-goto-if-nil byte-goto-if-not-nil + byte-goto-if-nil-else-pop + byte-goto-if-not-nil-else-pop)) + "List of byte-codes whose offset is a pc.") + +(defconst byte-goto-always-pop-ops + (purecopy '(byte-goto-if-nil byte-goto-if-not-nil))) + +(defconst byte-rel-goto-ops + (purecopy '(byte-rel-goto byte-rel-goto-if-nil byte-rel-goto-if-not-nil + byte-rel-goto-if-nil-else-pop byte-rel-goto-if-not-nil-else-pop)) + "byte-codes for relative jumps.") + +(byte-extrude-byte-code-vectors) + +;;; lapcode generator +;;; +;;; the byte-compiler now does source -> lapcode -> bytecode instead of +;;; source -> bytecode, because it's a lot easier to make optimizations +;;; on lapcode than on bytecode. +;;; +;;; Elements of the lapcode list are of the form (<instruction> . <parameter>) +;;; where instruction is a symbol naming a byte-code instruction, +;;; and parameter is an argument to that instruction, if any. +;;; +;;; The instruction can be the pseudo-op TAG, which means that this position +;;; in the instruction stream is a target of a goto. (car PARAMETER) will be +;;; the PC for this location, and the whole instruction "(TAG pc)" will be the +;;; parameter for some goto op. +;;; +;;; If the operation is varbind, varref, varset or push-constant, then the +;;; parameter is (variable/constant . index_in_constant_vector). +;;; +;;; First, the source code is macroexpanded and optimized in various ways. +;;; Then the resultant code is compiled into lapcode. Another set of +;;; optimizations are then run over the lapcode. Then the variables and +;;; constants referenced by the lapcode are collected and placed in the +;;; constants-vector. (This happens now so that variables referenced by dead +;;; code don't consume space.) And finally, the lapcode is transformed into +;;; compacted byte-code. +;;; +;;; A distinction is made between variables and constants because the variable- +;;; referencing instructions are more sensitive to the variables being near the +;;; front of the constants-vector than the constant-referencing instructions. +;;; Also, this lets us notice references to free variables. + +(defun byte-compile-lapcode (lap) + "Turns lapcode into bytecode. The lapcode is destroyed." + ;; Lapcode modifications: changes the ID of a tag to be the tag's PC. + (let ((pc 0) ; Program counter + op off ; Operation & offset + (bytes '()) ; Put the output bytes here + (patchlist nil) ; List of tags and goto's to patch + rest rel tmp) + (while lap + (setq op (car (car lap)) + off (cdr (car lap))) + (cond ((not (symbolp op)) + (error "Non-symbolic opcode `%s'" op)) + ((eq op 'TAG) + (setcar off pc) + (setq patchlist (cons 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))) + (t + (setq bytes + (cond ((cond ((consp off) + ;; Variable or constant reference + (setq off (cdr off)) + (eq op 'byte-constant))) + (cond ((< off byte-constant-limit) + (setq pc (1+ pc)) + (cons (+ byte-constant off) bytes)) + (t + (setq pc (+ 3 pc)) + (cons (lsh off -8) + (cons (logand off 255) + (cons byte-constant2 bytes)))))) + ((and (<= byte-listN (symbol-value op)) + (<= (symbol-value op) byte-insertN)) + (setq pc (+ 2 pc)) + (cons off (cons (symbol-value op) bytes))) + ((< off 6) + (setq pc (1+ pc)) + (cons (+ (symbol-value op) off) bytes)) + ((< off 256) + (setq pc (+ 2 pc)) + (cons off (cons (+ (symbol-value op) 6) bytes))) + (t + (setq pc (+ 3 pc)) + (cons (lsh off -8) + (cons (logand off 255) + (cons (+ (symbol-value op) 7) + bytes)))))))) + (setq lap (cdr lap))) + ;;(if (not (= pc (length bytes))) + ;; (error "Compiler error: pc mismatch - %s %s" pc (length bytes))) + (cond (t ;; starting with Emacs 19. + ;; Make relative jumps + (setq patchlist (nreverse patchlist)) + (while (progn + (setq off 0) ; PC change because of deleted bytes + (setq rest patchlist) + (while rest + (setq tmp (car rest)) + (and (consp (car tmp)) ; Jump + (prog1 (null (nth 1 tmp)) ; Absolute jump + (setq tmp (car tmp))) + (progn + (setq rel (- (car (cdr tmp)) (car tmp))) + (and (<= -129 rel) (< rel 128))) + (progn + ;; Convert to relative jump. + (setcdr (car rest) (cdr (cdr (car rest)))) + (setcar (cdr (car rest)) + (+ (car (cdr (car rest))) + (- byte-rel-goto byte-goto))) + (setq off (1- off)))) + (setcar tmp (+ (car tmp) off)) ; Adjust PC + (setq rest (cdr rest))) + ;; If optimizing, repeat until no change. + (and byte-optimize + (not (zerop off))))))) + ;; Patch PC into jumps + (let (bytes) + (while patchlist + (setq bytes (car patchlist)) + (cond ((atom (car bytes))) ; Tag + ((nth 1 bytes) ; Relative jump + (setcar bytes (+ (- (car (cdr (car bytes))) (car (car bytes))) + 128))) + (t ; Absolute jump + (setq pc (car (cdr (car bytes)))) ; Pick PC from tag + (setcar (cdr bytes) (logand pc 255)) + (setcar bytes (lsh pc -8)))) + (setq patchlist (cdr patchlist)))) + (concat (nreverse bytes)))) + + +;;; byte compiler messages + +(defvar byte-compile-current-form nil) +(defvar byte-compile-current-file nil) +(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) + +;; 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*")) + (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"))) + (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))) + +;; 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)))) + +(defun byte-compile-warn (format &rest args) + (setq format (apply 'format format args)) + (if byte-compile-error-on-warn + (error "%s" format) ; byte-compile-file catches and logs it + (byte-compile-log-1 (concat "** " format) t) +;;; RMS says: +;;; It is useless to flash warnings too fast to be read. +;;; Besides, they will all be shown at the end. +;;; and comments out the next two lines. + (or noninteractive ; already written on stdout. + (message "Warning: %s" format)))) + +;;; This function should be used to report errors that have halted +;;; compilation of the current file. +(defun byte-compile-report-error (error-info) + (setq byte-compiler-error-flag t) + (byte-compile-log-1 + (concat "!! " + (format (if (cdr error-info) "%s (%s)" "%s") + (get (car error-info) 'error-message) + (prin1-to-string (cdr error-info)))))) + +;;; Used by make-obsolete. +(defun byte-compile-obsolete (form) + (let ((new (get (car form) 'byte-obsolete-info))) + (if (memq 'obsolete byte-compile-warnings) + (byte-compile-warn "%s is an obsolete function; %s" (car form) + (if (stringp (car new)) + (car new) + (format "use %s instead." (car new))))) + (funcall (or (cdr new) 'byte-compile-normal-call) form))) + +;;; Used by make-obsolete. +(defun byte-compile-compatible (form) + (let ((new (get (car form) 'byte-compatible-info))) + (if (memq 'pedantic byte-compile-warnings) + (byte-compile-warn "%s is provided for compatibility; %s" (car form) + (if (stringp (car new)) + (car new) + (format "use %s instead." (car new))))) + (funcall (or (cdr new) 'byte-compile-normal-call) form))) + +;; Compiler options + +(defconst byte-compiler-legal-options + '((optimize byte-optimize (t nil source byte) val) + (file-format byte-compile-emacs19-compatibility (emacs19 emacs20) + (eq val 'emacs19)) + (delete-errors byte-compile-delete-errors (t nil) val) + (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)) + val))) + +;; XEmacs addition +(defconst byte-compiler-obsolete-options + '((new-bytecodes t))) + +;; Inhibit v19/v20 selectors if the version is hardcoded. +;; #### This should print a warning if the user tries to change something +;; than can't be changed because the running compiler doesn't support it. +(cond + ((byte-compile-single-version) + (setcar (cdr (cdr (assq 'file-format byte-compiler-legal-options))) + (if (byte-compile-version-cond byte-compile-emacs19-compatibility) + '(emacs19) '(emacs20))))) + +;; now we can copy it. +(setq byte-compiler-legal-options (purecopy byte-compiler-legal-options)) + +(defun byte-compiler-options-handler (&rest args) + (let (key val desc choices) + (while args + (if (or (atom (car args)) (nthcdr 2 (car args)) (null (cdr (car args)))) + (error "malformed byte-compiler-option %s" (car args))) + (setq key (car (car args)) + val (car (cdr (car args))) + desc (assq key byte-compiler-legal-options)) + (or desc + (error "unknown byte-compiler option %s" key)) + (if (assq key byte-compiler-obsolete-options) + (byte-compile-warn "%s is an obsolete byte-compiler option." key)) + (setq choices (nth 2 desc)) + (if (consp (car choices)) + (let* (this + (handler 'cons) + (var (nth 1 desc)) + (ret (and (memq (car val) '(+ -)) + (copy-sequence (if (eq t (symbol-value var)) + (car choices) + (symbol-value var)))))) + (setq choices (car choices)) + (while val + (setq this (car val)) + (cond ((memq this choices) + (setq ret (funcall handler this ret))) + ((eq this '+) (setq handler 'cons)) + ((eq this '-) (setq handler 'delq)) + ((error "%s only accepts %s." key choices))) + (setq val (cdr val))) + (set (nth 1 desc) ret)) + (or (memq val choices) + (error "%s must be one of %s." key choices)) + (set (nth 1 desc) (eval (nth 3 desc)))) + (setq args (cdr args))) + nil)) + +;;; sanity-checking arglists + +(defun byte-compile-fdefinition (name macro-p) + (let* ((list (if (memq macro-p '(nil subr)) + byte-compile-function-environment + byte-compile-macro-environment)) + (env (cdr (assq name list)))) + (or env + (let ((fn name)) + (while (and (symbolp fn) + (fboundp fn) + (or (symbolp (symbol-function fn)) + (consp (symbol-function fn)) + (and (not macro-p) + (compiled-function-p (symbol-function fn))) + (and (eq macro-p 'subr) (subrp fn)))) + (setq fn (symbol-function fn))) + (if (or (and (not macro-p) (compiled-function-p fn)) + (and (eq macro-p 'subr) (subrp fn))) + fn + (and (consp fn) + (not (eq macro-p 'subr)) + (if (eq 'macro (car fn)) + (cdr fn) + (if macro-p + nil + (if (eq 'autoload (car fn)) + nil + fn))))))))) + +(defun byte-compile-arglist-signature (arglist) + (let ((args 0) + opts + restp) + (while arglist + (cond ((eq (car arglist) '&optional) + (or opts (setq opts 0))) + ((eq (car arglist) '&rest) + (if (cdr arglist) + (setq restp t + arglist nil))) + (t + (if opts + (setq opts (1+ opts)) + (setq args (1+ args))))) + (setq arglist (cdr arglist))) + (cons args (if restp nil (if opts (+ args opts) args))))) + + +(defun byte-compile-arglist-signatures-congruent-p (old new) + (not (or + (> (car new) (car old)) ; requires more args now + (and (null (cdr old)) ; tooks rest-args, doesn't any more + (cdr new)) + (and (cdr new) (cdr old) ; can't take as many args now + (< (cdr new) (cdr old))) + ))) + +(defun byte-compile-arglist-signature-string (signature) + (cond ((null (cdr signature)) + (format "%d+" (car signature))) + ((= (car signature) (cdr signature)) + (format "%d" (car signature))) + (t (format "%d-%d" (car signature) (cdr signature))))) + + +;; Warn if the form is calling a function with the wrong number of arguments. +(defun byte-compile-callargs-warn (form) + (let* ((def (or (byte-compile-fdefinition (car form) nil) + (byte-compile-fdefinition (car form) t))) + (sig (and def (byte-compile-arglist-signature + (if (eq 'lambda (car-safe def)) + (nth 1 def) + (if (compiled-function-p def) + (compiled-function-arglist def) + '(&rest def)))))) + (ncall (length (cdr form)))) + (if (and (null def) + (fboundp 'subr-min-args) + (setq def (byte-compile-fdefinition (car form) 'subr))) + (setq sig (cons (subr-min-args def) (subr-max-args def)))) + (if sig + (if (or (< ncall (car sig)) + (and (cdr sig) (> ncall (cdr sig)))) + (byte-compile-warn + "%s called with %d argument%s, but %s %s" + (car form) ncall + (if (= 1 ncall) "" "s") + (if (< ncall (car sig)) + "requires" + "accepts only") + (byte-compile-arglist-signature-string sig))) + (or (fboundp (car form)) ; might be a subr or autoload. + ;; ## this doesn't work with recursion. + (eq (car form) byte-compile-current-form) + ;; It's a currently-undefined function. + ;; Remember number of args in call. + (let ((cons (assq (car form) byte-compile-unresolved-functions)) + (n (length (cdr form)))) + (if cons + (or (memq n (cdr cons)) + (setcdr cons (cons n (cdr cons)))) + (setq byte-compile-unresolved-functions + (cons (list (car form) n) + byte-compile-unresolved-functions)))))))) + +;; Warn if the function or macro is being redefined with a different +;; number of arguments. +(defun byte-compile-arglist-warn (form macrop) + (let ((old (byte-compile-fdefinition (nth 1 form) macrop))) + (if old + (let ((sig1 (byte-compile-arglist-signature + (if (eq 'lambda (car-safe old)) + (nth 1 old) + (if (compiled-function-p old) + (compiled-function-arglist old) + '(&rest def))))) + (sig2 (byte-compile-arglist-signature (nth 2 form)))) + (or (byte-compile-arglist-signatures-congruent-p sig1 sig2) + (byte-compile-warn "%s %s used to take %s %s, now takes %s" + (if (eq (car form) 'defun) "function" "macro") + (nth 1 form) + (byte-compile-arglist-signature-string sig1) + (if (equal sig1 '(1 . 1)) "argument" "arguments") + (byte-compile-arglist-signature-string sig2)))) + ;; This is the first definition. See if previous calls are compatible. + (let ((calls (assq (nth 1 form) byte-compile-unresolved-functions)) + nums sig min max) + (if calls + (progn + (setq sig (byte-compile-arglist-signature (nth 2 form)) + nums (sort (copy-sequence (cdr calls)) (function <)) + min (car nums) + max (car (nreverse nums))) + (if (or (< min (car sig)) + (and (cdr sig) (> max (cdr sig)))) + (byte-compile-warn + "%s being defined to take %s%s, but was previously called with %s" + (nth 1 form) + (byte-compile-arglist-signature-string sig) + (if (equal sig '(1 . 1)) " arg" " args") + (byte-compile-arglist-signature-string (cons min max)))) + + (setq byte-compile-unresolved-functions + (delq calls byte-compile-unresolved-functions))))) + ))) + +;; If we have compiled any calls to functions which are not known to be +;; defined, issue a warning enumerating them. +;; `unresolved' in the list `byte-compile-warnings' disables this. +(defun byte-compile-warn-about-unresolved-functions (&optional msg) + (if (memq 'unresolved byte-compile-warnings) + (let ((byte-compile-current-form (or msg "the end of the data"))) + ;; First delete the autoloads from the list. + (if byte-compile-autoload-environment + (let ((rest byte-compile-unresolved-functions)) + (while rest + (if (assq (car (car rest)) byte-compile-autoload-environment) + (setq byte-compile-unresolved-functions + (delq (car rest) byte-compile-unresolved-functions))) + (setq rest (cdr rest))))) + ;; Now warn. + (if (cdr byte-compile-unresolved-functions) + (let* ((str "The following functions are not known to be defined: ") + (L (+ (length str) 5)) + (rest (reverse byte-compile-unresolved-functions)) + s) + (while rest + (setq s (symbol-name (car (car rest))) + L (+ L (length s) 2) + rest (cdr rest)) + (if (<= L (1- fill-column)) + (setq str (concat str " " s (and rest ","))) + (setq str (concat str "\n " s (and rest ",")) + L (+ (length s) 4)))) + (byte-compile-warn "%s" str)) + (if byte-compile-unresolved-functions + (byte-compile-warn "the function %s is not known to be defined." + (car (car byte-compile-unresolved-functions))))))) + nil) + +(defun byte-compile-defvar-p (var) + ;; Whether the byte compiler thinks that nonexical references to this + ;; variable are ok. + (or (globally-boundp var) + (let ((rest byte-compile-bound-variables)) + (while (and rest var) + (if (and (eq var (car-safe (car rest))) + (not (= 0 (logand (cdr (car rest)) + byte-compile-global-bit)))) + (setq var nil)) + (setq rest (cdr rest))) + ;; if var is nil at this point, it's a defvar in this file. + (not var)))) + + +;;; If we have compiled bindings of variables which have no referents, warn. +(defun byte-compile-warn-about-unused-variables () + (let ((rest byte-compile-bound-variables) + (unreferenced '()) + cell) + (while (and rest + ;; only warn about variables whose lifetime is now ending, + ;; that is, variables from the lexical scope that is now + ;; terminating. (Think nested lets.) + (not (eq (car rest) 'new-scope))) + (setq cell (car rest)) + (if (and (= 0 (logand byte-compile-referenced-bit (cdr cell))) + ;; Don't warn about declared-but-unused arguments, + ;; for two reasons: first, the arglist structure + ;; might be imposed by external forces, and we don't + ;; 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 + ;; containing a reference to arg, so every inline + ;; expansion would generate a warning. (If we had + ;; `ignore' then inline expansion could emit an + ;; ignore declaration.) + (= 0 (logand byte-compile-arglist-bit (cdr cell))) + ;; Don't warn about defvars because this is a + ;; legitimate special binding. + (not (byte-compile-defvar-p (car cell)))) + (setq unreferenced (cons (car cell) unreferenced))) + (setq rest (cdr rest))) + (setq unreferenced (nreverse unreferenced)) + (while unreferenced + (byte-compile-warn + (format "variable %s bound but not referenced" (car unreferenced))) + (setq unreferenced (cdr unreferenced))))) + + +(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)))))) + +(defmacro byte-compile-close-variables (&rest body) + (cons 'let + (cons '(;; + ;; Close over these variables to encapsulate the + ;; compilation state + ;; + (byte-compile-macro-environment + ;; Copy it because the compiler may patch into the + ;; macroenvironment. + (copy-alist byte-compile-initial-macro-environment)) + (byte-compile-function-environment nil) + (byte-compile-autoload-environment nil) + (byte-compile-unresolved-functions nil) + (byte-compile-bound-variables nil) + (byte-compile-free-references nil) + (byte-compile-free-assignments nil) + ;; + ;; Close over these variables so that `byte-compiler-options' + ;; can change them on a per-file basis. + ;; + (byte-compile-verbose byte-compile-verbose) + (byte-optimize byte-optimize) + (byte-compile-emacs19-compatibility + byte-compile-emacs19-compatibility) + (byte-compile-dynamic byte-compile-dynamic) + (byte-compile-dynamic-docstrings + byte-compile-dynamic-docstrings) + (byte-compile-warnings (if (eq byte-compile-warnings t) + byte-compile-default-warnings + byte-compile-warnings)) + (byte-compile-file-domain nil) + ) + (list + (list 'prog1 (cons 'progn body) + '(if (memq 'unused-vars byte-compile-warnings) + ;; done compiling in this scope, warn now. + (byte-compile-warn-about-unused-variables))))))) + + +(defvar byte-compile-warnings-point-max nil) +(defmacro displaying-byte-compile-warnings (&rest body) + (list 'let + '((byte-compile-warnings-point-max byte-compile-warnings-point-max)) + ;; Log the file 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)))) + (list 'unwind-protect + (list 'condition-case 'error-info + (cons '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 + (select-window + (prog1 (selected-window) + (select-window (display-buffer (current-buffer))) + (goto-char byte-compile-warnings-point-max) + (recenter 1)))))))) + + +;;;###autoload +(defun byte-force-recompile (directory) + "Recompile every `.el' file in DIRECTORY that already has a `.elc' file. +Files in subdirectories of DIRECTORY are processed also." + (interactive "DByte force recompile (directory): ") + (byte-recompile-directory directory nil t)) + +;;;###autoload +(defun byte-recompile-directory (directory &optional arg norecursion force) + "Recompile every `.el' file in DIRECTORY that needs recompilation. +This is if a `.elc' file exists but is older than the `.el' file. +Files in subdirectories of DIRECTORY are processed also unless argument +NORECURSION is non-nil. + +If the `.elc' file does not exist, normally the `.el' file is *not* compiled. +But a prefix argument (optional second arg) means ask user, +for each such `.el' file, whether to compile it. Prefix argument 0 means +don't ask and compile the file anyway. + +A nonzero prefix argument also means ask about each subdirectory. + +If the fourth argument FORCE is non-nil, +recompile every `.el' file that already has a `.elc' file." + (interactive "DByte recompile directory: \nP") + (if arg + (setq arg (prefix-numeric-value arg))) + (if noninteractive + nil + (save-some-buffers) + (redraw-modeline)) + (let ((directories (list (expand-file-name directory))) + (file-count 0) + (dir-count 0) + last-dir) + (displaying-byte-compile-warnings + (while directories + (setq directory (file-name-as-directory (car directories))) + (or noninteractive (message "Checking %s..." directory)) + (let ((files (directory-files directory)) + source dest) + (while files + (setq source (expand-file-name (car files) directory)) + (if (and (not (member (car files) '("." ".." "RCS" "CVS" "SCCS"))) + ;; Stay away from directory back-links, etc: + (not (file-symlink-p source)) + (file-directory-p source) + byte-recompile-directory-recursively) + ;; This file is a subdirectory. Handle them differently. + (if (or (null arg) + (eq arg 0) + (y-or-n-p (concat "Check " source "? "))) + (setq directories + (nconc directories (list source)))) + ;; It is an ordinary file. Decide whether to compile it. + (if (and (string-match emacs-lisp-file-regexp source) + (not (auto-save-file-name-p source)) + (setq dest (byte-compile-dest-file source)) + (if (file-exists-p dest) + ;; File was already compiled. + (or force (file-newer-than-file-p source dest)) + ;; No compiled file exists yet. + (and arg + (or (eq 0 arg) + (y-or-n-p (concat "Compile " source "? ")))))) + (progn ;(if (and noninteractive (not byte-compile-verbose)) + ; (message "Compiling %s..." source)) + ; we do this in byte-compile-file. + (if byte-recompile-directory-ignore-errors-p + (batch-byte-compile-1 source) + (byte-compile-file source)) + (or noninteractive + (message "Checking %s..." directory)) + (setq file-count (1+ file-count)) + (if (not (eq last-dir directory)) + (setq last-dir directory + dir-count (1+ dir-count))) + ))) + (setq files (cdr files)))) + (setq directories (cdr directories)))) + (message "Done (Total of %d file%s compiled%s)" + file-count (if (= file-count 1) "" "s") + (if (> dir-count 1) (format " in %d directories" dir-count) "")))) + +;;;###autoload +(defun byte-recompile-file (filename &optional force) + "Recompile a file of Lisp code named FILENAME if it needs recompilation. +This is if the `.elc' file exists but is older than the `.el' file. + +If the `.elc' file does not exist, normally the `.el' file is *not* +compiled. But a prefix argument (optional second arg) means ask user +whether to compile it. Prefix argument 0 don't ask and recompile anyway." + (interactive "fByte recompile file: \nP") + (let ((dest)) + (if (and (string-match emacs-lisp-file-regexp filename) + (not (auto-save-file-name-p filename)) + (setq dest (byte-compile-dest-file filename)) + (if (file-exists-p dest) + (file-newer-than-file-p filename dest) + (and force + (or (eq 0 force) + (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. +The output file's name is made by appending `c' to the end of FILENAME. +With prefix arg (noninteractively: 2nd arg), load the file after compiling." +;; (interactive "fByte compile file: \nP") + (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 (if current-prefix-arg + "Byte compile and load file: " + "Byte compile file: ") + file-dir nil nil file-name) + current-prefix-arg))) + ;; Expand now so we get the current buffer's defaults + (setq filename (expand-file-name filename)) + + ;; If we're compiling 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 byte-compile-verbose) ; XEmacs change + (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)) + (setq byte-compile-dest-file target-file) + (save-excursion + (setq input-buffer (get-buffer-create " *Compiler 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))) + (setq byte-compiler-error-flag nil) + ;; It is important that input-buffer not be current at this call, + ;; so that the value of point set in input-buffer + ;; within byte-compile-from-buffer lingers in that buffer. + (setq output-buffer (byte-compile-from-buffer input-buffer filename)) + (if byte-compiler-error-flag + nil + (if byte-compile-verbose + (message "Compiling %s...done" filename)) + (kill-buffer input-buffer) + (save-excursion + (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)))) + (kill-buffer (current-buffer))) + (if (and byte-compile-generate-call-tree + (or (eq t byte-compile-generate-call-tree) + (y-or-n-p (format "Report call tree for %s? " filename)))) + (save-excursion + (display-call-tree filename))) + (if load + (load target-file)) + t))) + +;; RMS comments the next two out. +(defun byte-compile-and-load-file (&optional filename) + "Compile a file of Lisp code named FILENAME into a file of byte code, +and then load it. The output file's name is made by appending \"c\" to +the end of FILENAME." + (interactive) + (if filename ; I don't get it, (interactive-p) doesn't always work + (byte-compile-file filename t) + (let ((current-prefix-arg '(4))) + (call-interactively 'byte-compile-file)))) + +(defun byte-compile-buffer (&optional buffer) + "Byte-compile and evaluate contents of BUFFER (default: the current buffer)." + (interactive "bByte compile buffer: ") + (setq buffer (if buffer (get-buffer buffer) (current-buffer))) + (message "Compiling %s..." (buffer-name buffer)) + (let* ((filename (or (buffer-file-name buffer) + (concat "#<buffer " (buffer-name buffer) ">"))) + (byte-compile-current-file buffer)) + (byte-compile-from-buffer buffer filename t)) + (message "Compiling %s...done" (buffer-name buffer)) + t) + +;;; compiling a single function +;;;###autoload +(defun compile-defun (&optional arg) + "Compile and evaluate the current top-level form. +Print the result in the minibuffer. +With argument, insert value in current buffer after the form." + (interactive "P") + (save-excursion + (end-of-defun) + (beginning-of-defun) + (let* ((byte-compile-current-file (buffer-file-name)) + (load-file-name (buffer-file-name)) + (byte-compile-last-warned-form 'nothing) + (value (eval (displaying-byte-compile-warnings + (byte-compile-sexp (read (current-buffer)) + "toplevel forms"))))) + (cond (arg + (message "Compiling from buffer... done.") + (prin1 value (current-buffer)) + (insert "\n")) + ((message "%s" (prin1-to-string value))))))) + +(defvar byte-compile-inbuffer) +(defvar byte-compile-outbuffer) + +(defun byte-compile-from-buffer (byte-compile-inbuffer filename &optional eval) + ;; buffer --> output-buffer, or buffer --> eval form, return nil + (let (byte-compile-outbuffer + ;; Prevent truncation of flonums and lists as we read and print them + (float-output-format nil) + (case-fold-search nil) + (print-length nil) + (print-level nil) + ;; Simulate entry to byte-compile-top-level + (byte-compile-constants nil) + (byte-compile-variables nil) + (byte-compile-tag-number 0) + (byte-compile-depth 0) + (byte-compile-maxdepth 0) + (byte-compile-output nil) + ;; #### This is bound in b-c-close-variables. + ;; (byte-compile-warnings (if (eq byte-compile-warnings t) + ;; byte-compile-warning-types + ;; byte-compile-warnings)) + ) + (byte-compile-close-variables + (save-excursion + (setq byte-compile-outbuffer + (set-buffer (get-buffer-create " *Compiler Output*"))) + (erase-buffer) + ;; (emacs-lisp-mode) + (setq case-fold-search nil) + (and filename + (not eval) + (byte-compile-insert-header filename + byte-compile-inbuffer + byte-compile-outbuffer)) + + ;; This is a kludge. Some operating systems (OS/2, DOS) need to + ;; write files containing binary information specially. + ;; Under most circumstances, such files will be in binary + ;; overwrite mode, so those OS's use that flag to guess how + ;; they should write their data. Advise them that .elc files + ;; need to be written carefully. + (setq overwrite-mode 'overwrite-mode-binary)) + (displaying-byte-compile-warnings + (save-excursion + (set-buffer byte-compile-inbuffer) + (goto-char 1) + + ;; Compile the forms from the input buffer. + (while (progn + (while (progn (skip-chars-forward " \t\n\^l") + (looking-at ";")) + (forward-line 1)) + (not (eobp))) + (byte-compile-file-form (read byte-compile-inbuffer))) + + ;; Compile pending forms at end of file. + (byte-compile-flush-pending) + (byte-compile-warn-about-unresolved-functions) + ;; SHould we always do this? When calling multiple files, it + ;; would be useful to delay this warning until all have + ;; been compiled. + (setq byte-compile-unresolved-functions nil))) + (save-excursion + (set-buffer byte-compile-outbuffer) + (goto-char (point-min)))) + (if (not eval) + byte-compile-outbuffer + (let (form) + (while (condition-case nil + (progn (setq form (read byte-compile-outbuffer)) + t) + (end-of-file nil)) + (eval form))) + (kill-buffer byte-compile-outbuffer) + nil))) + +(defun byte-compile-insert-header (filename byte-compile-inbuffer + byte-compile-outbuffer) + (set-buffer byte-compile-inbuffer) + (let ((dynamic-docstrings byte-compile-dynamic-docstrings)) + (set-buffer byte-compile-outbuffer) + (goto-char 1) + ;; + ;; The magic number of .elc files is ";ELC", or 0x3B454C43. After that is + ;; the file-format version number (19 or 20) as a byte, followed by some + ;; nulls. The primary motivation for doing this is to get some binary + ;; characters up in the first line of the file so that `diff' will simply + ;; say "Binary files differ" instead of actually doing a diff of two .elc + ;; files. An extra benefit is that you can add this to /etc/magic: + ;; + ;; 0 string ;ELC GNU Emacs Lisp compiled file, + ;; >4 byte x version %d + ;; + (insert + ";ELC" + (if (byte-compile-version-cond byte-compile-emacs19-compatibility) 19 20) + "\000\000\000\n" + ) + (insert ";;; compiled by " + (or (and (boundp 'user-mail-address) user-mail-address) + (concat (user-login-name) "@" (system-name))) + " on " + (current-time-string) "\n;;; from file " filename "\n") + (insert ";;; emacs version " emacs-version ".\n") + (insert ";;; bytecomp version " byte-compile-version "\n;;; " + (cond + ((eq byte-optimize 'source) "source-level optimization only") + ((eq byte-optimize 'byte) "byte-level optimization only") + (byte-optimize "optimization is on") + (t "optimization is off")) + (if (byte-compile-version-cond byte-compile-emacs19-compatibility) + "; compiled with Emacs 19 compatibility.\n" + ".\n")) + (if (not (byte-compile-version-cond byte-compile-emacs19-compatibility)) + (insert ";;; this file uses opcodes which do not exist in Emacs 19.\n" + ;; Have to check if emacs-version is bound so that this works + ;; in files loaded early in loadup.el. + "\n(if (and (boundp 'emacs-version)\n" + "\t (or (and (boundp 'epoch::version) epoch::version)\n" + "\t (string-lessp emacs-version \"20\")))\n" + " (error \"`" + ;; prin1-to-string is used to quote backslashes. + (substring (prin1-to-string (file-name-nondirectory filename)) + 1 -1) + "' was compiled for Emacs 20\"))\n\n")) + (insert "(or (boundp 'current-load-list) (setq current-load-list nil))\n" + "\n") + (if (and (byte-compile-version-cond byte-compile-emacs19-compatibility) + dynamic-docstrings) + (insert ";;; this file uses opcodes which do not exist prior to\n" + ";;; XEmacs 19.14/GNU Emacs 19.29 or later." + ;; Have to check if emacs-version is bound so that this works + ;; in files loaded early in loadup.el. + "\n(if (and (boundp 'emacs-version)\n" + "\t (or (and (boundp 'epoch::version) epoch::version)\n" + "\t (and (not (string-match \"XEmacs\" emacs-version))\n" + "\t (string-lessp emacs-version \"19.29\"))\n" + "\t (string-lessp emacs-version \"19.14\")))\n" + " (error \"`" + ;; prin1-to-string is used to quote backslashes. + (substring (prin1-to-string (file-name-nondirectory filename)) + 1 -1) + "' was compiled for XEmacs 19.14/Emacs 19.29 or later\"))\n\n" + ) + )) + + ;; back in the inbuffer; determine and set the coding system for the .elc + ;; file if under Mule. If there are any extended characters in the + ;; input file, use `escape-quoted' to make sure that both binary and + ;; 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 + (set-buffer byte-compile-inbuffer) + (setq byte-compile-dynamic nil + byte-compile-dynamic-docstrings nil)) + ;;(external-debugging-output (prin1-to-string (buffer-local-variables)))) + )) + ) + + +(defun byte-compile-output-file-form (form) + ;; writes the given form to the output buffer, being careful of docstrings + ;; in defun, defmacro, defvar, defconst and autoload because make-docfile is + ;; so amazingly stupid. + ;; defalias calls are output directly by byte-compile-file-form-defmumble; + ;; it does not pay to first build the defalias in defmumble and then parse + ;; it here. + (if (and (memq (car-safe form) '(defun defmacro defvar defconst autoload)) + (stringp (nth 3 form))) + (byte-compile-output-docform nil nil '("\n(" 3 ")") form nil + (eq (car form) 'autoload)) + (let ((print-escape-newlines t) + (print-length nil) + (print-level nil) + (print-readably t) ; print #[] for bytecode, 'x for (quote x) + (print-gensym nil)) ; this is too dangerous for now + (princ "\n" byte-compile-outbuffer) + (prin1 form byte-compile-outbuffer) + nil))) + +(defun byte-compile-output-docform (preface name info form specindex quoted) + "Print a form with a doc string. INFO is (prefix doc-index postfix). +If PREFACE and NAME are non-nil, print them too, +before INFO and the FORM but after the doc string itself. +If SPECINDEX is non-nil, it is the index in FORM +of the function bytecode string. In that case, +we output that argument and the following argument (the constants vector) +together, for lazy loading. +QUOTED says that we have to put a quote before the +list that represents a doc string reference. +`autoload' needs that." + ;; We need to examine byte-compile-dynamic-docstrings + ;; in the input buffer (now current), not in the output buffer. + (let ((dynamic-docstrings byte-compile-dynamic-docstrings)) + (set-buffer + (prog1 (current-buffer) + (set-buffer byte-compile-outbuffer) + (let (position) + + ;; Insert the doc string, and make it a comment with #@LENGTH. + (and (>= (nth 1 info) 0) + dynamic-docstrings + (progn + ;; Make the doc string start at beginning of line + ;; for make-docfile's sake. + (insert "\n") + (setq position + (byte-compile-output-as-comment + (nth (nth 1 info) form) nil)) + ;; If the doc string starts with * (a user variable), + ;; negate POSITION. + (if (and (stringp (nth (nth 1 info) form)) + (> (length (nth (nth 1 info) form)) 0) + (char= (aref (nth (nth 1 info) form) 0) ?*)) + (setq position (- position))))) + + (if preface + (progn + (insert preface) + (prin1 name byte-compile-outbuffer))) + (insert (car info)) + (let ((print-escape-newlines t) + (print-readably t) ; print #[] for bytecode, 'x for (quote x) + (print-gensym nil) ; this is too dangerous for now + (index 0)) + (prin1 (car form) byte-compile-outbuffer) + (while (setq form (cdr form)) + (setq index (1+ index)) + (insert " ") + (cond ((and (numberp specindex) (= index specindex)) + (let ((position + (byte-compile-output-as-comment + (cons (car form) (nth 1 form)) + t))) + (princ (format "(#$ . %d) nil" position) + byte-compile-outbuffer) + (setq form (cdr form)) + (setq index (1+ index)))) + ((= index (nth 1 info)) + (if position + (princ (format (if quoted "'(#$ . %d)" "(#$ . %d)") + position) + byte-compile-outbuffer) + (let ((print-escape-newlines nil)) + (goto-char (prog1 (1+ (point)) + (prin1 (car form) + byte-compile-outbuffer))) + (insert "\\\n") + (goto-char (point-max))))) + (t + (prin1 (car form) byte-compile-outbuffer))))) + (insert (nth 2 info)))))) + nil) + +(defvar for-effect) ; ## Kludge! This should be an arg, not a special. + +(defun byte-compile-keep-pending (form &optional handler) + (if (memq byte-optimize '(t source)) + (setq form (byte-optimize-form form t))) + (if handler + (let ((for-effect t)) + ;; To avoid consing up monstrously large forms at load time, we split + ;; the output regularly. + (and (memq (car-safe form) '(fset defalias define-function)) + (nthcdr 300 byte-compile-output) + (byte-compile-flush-pending)) + (funcall handler form) + (if for-effect + (byte-compile-discard))) + (byte-compile-form form t)) + nil) + +(defun byte-compile-flush-pending () + (if byte-compile-output + (let ((form (byte-compile-out-toplevel t 'file))) + (cond ((eq (car-safe form) 'progn) + (mapcar 'byte-compile-output-file-form (cdr form))) + (form + (byte-compile-output-file-form form))) + (setq byte-compile-constants nil + byte-compile-variables nil + byte-compile-depth 0 + byte-compile-maxdepth 0 + byte-compile-output nil)))) + +(defun byte-compile-file-form (form) + (let ((byte-compile-current-form nil) ; close over this for warnings. + handler) + (cond + ((not (consp form)) + (byte-compile-keep-pending form)) + ((and (symbolp (car form)) + (setq handler (get (car form) 'byte-hunk-handler))) + (cond ((setq form (funcall handler form)) + (byte-compile-flush-pending) + (byte-compile-output-file-form form)))) + ((eq form (setq form (macroexpand form byte-compile-macro-environment))) + (byte-compile-keep-pending form)) + (t + (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 +;; as byte-code. + +(put 'defsubst 'byte-hunk-handler 'byte-compile-file-form-defsubst) +(defun byte-compile-file-form-defsubst (form) + (cond ((assq (nth 1 form) byte-compile-unresolved-functions) + (setq byte-compile-current-form (nth 1 form)) + (byte-compile-warn "defsubst %s was used before it was defined" + (nth 1 form)))) + (byte-compile-file-form + (macroexpand form byte-compile-macro-environment)) + ;; Return nil so the form is not output twice. + nil) + +(put 'autoload 'byte-hunk-handler 'byte-compile-file-form-autoload) +(defun byte-compile-file-form-autoload (form) + ;; + ;; If this is an autoload of a macro, and all arguments are constants (that + ;; is, there is no hairy computation going on here) then evaluate the form + ;; at compile-time. This is so that we can make use of macros which we + ;; have autoloaded from the file being compiled. Normal function autoloads + ;; are not automatically evaluated at compile time, because there's not + ;; much point to it (so why bother cluttering up the compile-time namespace.) + ;; + ;; If this is an autoload of a function, then record its definition in the + ;; byte-compile-autoload-environment to suppress any `not known to be + ;; defined' warnings at the end of this file (this only matters for + ;; functions which are autoloaded and compiled in the same file, if the + ;; autoload already exists in the compilation environment, we wouldn't have + ;; warned anyway.) + ;; + (let* ((name (if (byte-compile-constp (nth 1 form)) + (eval (nth 1 form)))) + ;; In v19, the 5th arg to autoload can be t, nil, 'macro, or 'keymap. + (macrop (and (byte-compile-constp (nth 5 form)) + (memq (eval (nth 5 form)) '(t macro)))) +;; (functionp (and (byte-compile-constp (nth 5 form)) +;; (eq 'nil (eval (nth 5 form))))) + ) + (if (and macrop + (let ((form form)) + ;; all forms are constant + (while (if (setq form (cdr form)) + (byte-compile-constp (car form)))) + (null form))) + ;; eval the macro autoload into the compilation enviroment + (eval form)) + + (if name + (let ((old (assq name byte-compile-autoload-environment))) + (cond (old + (if (memq 'redefine byte-compile-warnings) + (byte-compile-warn "multiple autoloads for %s" name)) + (setcdr old form)) + (t + ;; We only use the names in the autoload environment, but + ;; it might be useful to have the bodies some day. + (setq byte-compile-autoload-environment + (cons (cons name form) + byte-compile-autoload-environment))))))) + ;; + ;; Now output the form. + (if (stringp (nth 3 form)) + form + ;; No doc string, so we can compile this as a normal form. + (byte-compile-keep-pending form 'byte-compile-normal-call))) + +(put 'defvar 'byte-hunk-handler 'byte-compile-file-form-defvar) +(put 'defconst 'byte-hunk-handler 'byte-compile-file-form-defvar) +(defun byte-compile-file-form-defvar (form) + (if (> (length form) 4) + (byte-compile-warn "%s used with too many args (%s)" + (car form) (nth 1 form))) + (if (and (> (length form) 3) (not (stringp (nth 3 form)))) + (byte-compile-warn "Third arg to %s %s is not a string: %s" + (car form) (nth 1 form) (nth 3 form))) + (if (null (nth 3 form)) + ;; Since there is no doc string, we can compile this as a normal form, + ;; and not do a file-boundary. + (byte-compile-keep-pending form) + (if (memq 'free-vars byte-compile-warnings) + (setq byte-compile-bound-variables + (cons (cons (nth 1 form) byte-compile-global-bit) + byte-compile-bound-variables))) + (cond ((consp (nth 2 form)) + (setq form (copy-sequence form)) + (setcar (cdr (cdr form)) + (byte-compile-top-level (nth 2 form) nil 'file)))) + + ;; The following turns out not to be necessary, since we emit a call to + ;; defvar, which can hack Vfile_domain by itself! + ;; + ;; If a file domain has been set, emit (put 'VAR 'variable-domain ...) + ;; after this defvar. +; (if byte-compile-file-domain +; (progn +; ;; Actually, this will emit the (put ...) before the (defvar ...) +; ;; but I don't think that can matter in this case. +; (byte-compile-keep-pending +; (list 'put (list 'quote (nth 1 form)) ''variable-domain +; (list 'quote byte-compile-file-domain))))) + form)) + +(put 'require 'byte-hunk-handler 'byte-compile-file-form-eval-boundary) +(defun byte-compile-file-form-eval-boundary (form) + (eval form) + (byte-compile-keep-pending form 'byte-compile-normal-call)) + +(put 'progn 'byte-hunk-handler 'byte-compile-file-form-progn) +(put 'prog1 'byte-hunk-handler 'byte-compile-file-form-progn) +(put 'prog2 'byte-hunk-handler 'byte-compile-file-form-progn) +(defun byte-compile-file-form-progn (form) + (mapcar 'byte-compile-file-form (cdr form)) + ;; Return nil so the forms are not output twice. + nil) + +;; This handler is not necessary, but it makes the output from dont-compile +;; and similar macros cleaner. +(put 'eval 'byte-hunk-handler 'byte-compile-file-form-eval) +(defun byte-compile-file-form-eval (form) + (if (eq (car-safe (nth 1 form)) 'quote) + (nth 1 (nth 1 form)) + (byte-compile-keep-pending form))) + +(put 'defun 'byte-hunk-handler 'byte-compile-file-form-defun) +(defun byte-compile-file-form-defun (form) + (byte-compile-file-form-defmumble form nil)) + +(put 'defmacro 'byte-hunk-handler 'byte-compile-file-form-defmacro) +(defun byte-compile-file-form-defmacro (form) + (byte-compile-file-form-defmumble form t)) + +(defun byte-compile-compiled-obj-to-list (obj) + ;; #### this is fairly disgusting. Rewrite the code instead + ;; so that it doesn't create compiled objects in the first place! + ;; Much better than creating them and then "uncreating" them + ;; like this. + (read (concat "(" + (substring (let ((print-readably t)) + (prin1-to-string obj)) + 2 -1) + ")"))) + +(defun byte-compile-file-form-defmumble (form macrop) + (let* ((name (car (cdr form))) + (this-kind (if macrop 'byte-compile-macro-environment + 'byte-compile-function-environment)) + (that-kind (if macrop 'byte-compile-function-environment + 'byte-compile-macro-environment)) + (this-one (assq name (symbol-value this-kind))) + (that-one (assq name (symbol-value that-kind))) + (byte-compile-free-references nil) + (byte-compile-free-assignments nil)) + + ;; When a function or macro is defined, add it to the call tree so that + ;; we can tell when functions are not used. + (if byte-compile-generate-call-tree + (or (assq name byte-compile-call-tree) + (setq byte-compile-call-tree + (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))) + (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))) + (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)))) + ((and (fboundp name) + (or (subrp (symbol-function name)) + (eq (car-safe (symbol-function name)) + (if macrop 'lambda 'macro)))) + (if (memq 'redefine byte-compile-warnings) + (byte-compile-warn "%s %s being redefined as a %s" + (if (subrp (symbol-function name)) + "subr" + (if macrop "function" "macro")) + (nth 1 form) + (if macrop "macro" "function"))) + ;; shadow existing definition + (set 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))) + (car-safe (cdr-safe body)) + (stringp (car-safe (cdr-safe (cdr-safe body))))) + (byte-compile-warn "Probable `\"' without `\\' in doc string of %s" + (nth 1 form)))) + (let* ((new-one (byte-compile-lambda (cons 'lambda (nthcdr 2 form)))) + (code (byte-compile-byte-code-maker new-one))) + (if this-one + (setcdr this-one new-one) + (set this-kind + (cons (cons name new-one) (symbol-value this-kind)))) + (if (and (stringp (nth 3 form)) + (eq 'quote (car-safe code)) + (eq 'lambda (car-safe (nth 1 code)))) + (cons (car form) + (cons name (cdr (nth 1 code)))) + (byte-compile-flush-pending) + (if (not (stringp (nth 3 form))) + ;; No doc string. Provide -1 as the "doc string index" + ;; so that no element will be treated as a doc string. + (byte-compile-output-docform + "\n(defalias '" + name + (cond ((atom code) + (if macrop '(" '(macro . #[" -1 "])") '(" #[" -1 "]"))) + ((eq (car code) 'quote) + (setq code new-one) + (if macrop '(" '(macro " -1 ")") '(" '(" -1 ")"))) + ((if macrop '(" (cons 'macro (" -1 "))") '(" (" -1 ")")))) + ;; FSF just calls `(append code nil)' here but that relies + ;; on horrible C kludges in concat() that accept byte- + ;; compiled objects and pretend they're vectors. + (if (compiled-function-p code) + (byte-compile-compiled-obj-to-list code) + (append code nil)) + (and (atom code) byte-compile-dynamic + 1) + nil) + ;; Output the form by hand, that's much simpler than having + ;; b-c-output-file-form analyze the defalias. + (byte-compile-output-docform + "\n(defalias '" + name + (cond ((atom code) ; compiled-function-p + (if macrop '(" '(macro . #[" 4 "])") '(" #[" 4 "]"))) + ((eq (car code) 'quote) + (setq code new-one) + (if macrop '(" '(macro " 2 ")") '(" '(" 2 ")"))) + ((if macrop '(" (cons 'macro (" 5 "))") '(" (" 5 ")")))) + ;; The result of byte-compile-byte-code-maker is either a + ;; compiled-function object, or a list of some kind. If it's + ;; not a cons, we must coerce it into a list of the elements + ;; to be printed to the file. + (if (consp code) + code + (nconc (list + (compiled-function-arglist code) + (compiled-function-instructions code) + (compiled-function-constants code) + (compiled-function-stack-depth code)) + (let ((doc (documentation code t))) + (if doc (list doc))) + (if (commandp code) + (list (nth 1 (compiled-function-interactive code)))))) + (and (atom code) byte-compile-dynamic + 1) + nil)) + (princ ")" byte-compile-outbuffer) + nil)))) + +;; Print Lisp object EXP in the output file, inside a comment, +;; and return the file position it will have. +;; If QUOTED is non-nil, print with quoting; otherwise, print without quoting. +(defun byte-compile-output-as-comment (exp quoted) + (let ((position (point))) + (set-buffer + (prog1 (current-buffer) + (set-buffer byte-compile-outbuffer) + + ;; Insert EXP, and make it a comment with #@LENGTH. + (insert " ") + (if quoted + (prin1 exp byte-compile-outbuffer) + (princ exp byte-compile-outbuffer)) + (goto-char position) + ;; Quote certain special characters as needed. + ;; get_doc_string in doc.c does the unquoting. + (while (search-forward "\^A" nil t) + (replace-match "\^A\^A" t t)) + (goto-char position) + (while (search-forward "\000" nil t) + (replace-match "\^A0" t t)) + (goto-char position) + (while (search-forward "\037" nil t) + (replace-match "\^A_" t t)) + (goto-char (point-max)) + (insert "\037") + (goto-char position) + (insert "#@" (format "%d" (- (point-max) position))) + + ;; Save the file position of the object. + ;; Note we should add 1 to skip the space + ;; that we inserted before the actual doc string, + ;; and subtract 1 to convert from an 1-origin Emacs position + ;; to a file position; they cancel. + (setq position (point)) + (goto-char (point-max)))) + position)) + + + +;; The `domain' declaration. This is legal only at top-level in a file, and +;; should generally be the first form in the file. It is not legal inside +;; function bodies. + +(put 'domain 'byte-hunk-handler 'byte-compile-file-form-domain) +(defun byte-compile-file-form-domain (form) + (if (not (null (cdr (cdr form)))) + (byte-compile-warn "domain used with too many arguments: %s" form)) + (let ((domain (nth 1 form))) + (or (null domain) + (stringp domain) + (progn + (byte-compile-warn + "argument to `domain' declaration must be a literal string: %s" + form) + (setq domain nil))) + (setq byte-compile-file-domain domain)) + (byte-compile-keep-pending form 'byte-compile-normal-call)) + +(defun byte-compile-domain (form) + (byte-compile-warn "The `domain' declaration is legal only at top-level: %s" + (let ((print-escape-newlines t) + (print-level 4) + (print-length 4)) + (prin1-to-string form))) + (byte-compile-normal-call + (list 'signal ''error + (list 'quote (list "`domain' used inside a function" form))))) + +;; This is part of bytecomp.el in 19.35: +(put 'custom-declare-variable 'byte-hunk-handler + 'byte-compile-file-form-custom-declare-variable) +(defun byte-compile-file-form-custom-declare-variable (form) + (if (memq 'free-vars byte-compile-warnings) + (setq byte-compile-bound-variables + (cons (cons (nth 1 (nth 1 form)) + byte-compile-global-bit) + byte-compile-bound-variables))) + form) + + +;;;###autoload +(defun byte-compile (form) + "If FORM is a symbol, byte-compile its function definition. +If FORM is a lambda or a macro, byte-compile it as a function." + (displaying-byte-compile-warnings + (byte-compile-close-variables + (let* ((fun (if (symbolp form) + (and (fboundp form) (symbol-function form)) + form)) + (macro (eq (car-safe fun) 'macro))) + (if macro + (setq fun (cdr fun))) + (cond ((eq (car-safe fun) 'lambda) + (setq fun (if macro + (cons 'macro (byte-compile-lambda fun)) + (byte-compile-lambda fun))) + (if (symbolp form) + (defalias form fun) + fun))))))) + +;;;###autoload +(defun byte-compile-sexp (sexp &optional msg) + "Compile and return SEXP." + (displaying-byte-compile-warnings + (byte-compile-close-variables + (prog1 + (byte-compile-top-level sexp) + (byte-compile-warn-about-unresolved-functions msg))))) + +;; Given a function made by byte-compile-lambda, make a form which produces it. +(defun byte-compile-byte-code-maker (fun) + (cond + ;; ## atom is faster than compiled-func-p. + ((atom fun) ; compiled-function-p + fun) + ;; b-c-lambda didn't produce a compiled-function, so it must be a trivial + ;; function. + ((let (tmp) + (if (and (setq tmp (assq 'byte-code (cdr-safe (cdr fun)))) + (null (cdr (memq tmp fun)))) + ;; Generate a make-byte-code call. + (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 + (cond ((stringp (nth 2 fun)) + (list (nth 2 fun))) ;doc + (interactive + (list nil))) + (cond (interactive + (list (if (or (null (nth 1 interactive)) + (stringp (nth 1 interactive))) + (nth 1 interactive) + ;; Interactive spec is a list or a variable + ;; (if it is correct). + (list 'quote (nth 1 interactive)))))))) + ;; a non-compiled function (probably trivial) + (list 'quote fun)))))) + +;; Byte-compile a lambda-expression and return a valid function. +;; The value is usually a compiled function but may be the original +;; lambda-expression. +(defun byte-compile-lambda (fun) + (or (eq 'lambda (car-safe fun)) + (error "not a lambda -- %s" (prin1-to-string fun))) + (let* ((arglist (nth 1 fun)) + (byte-compile-bound-variables + (let ((new-bindings + (mapcar (function (lambda (x) + (cons x byte-compile-arglist-bit))) + (and (memq 'free-vars byte-compile-warnings) + (delq '&rest (delq '&optional + (copy-sequence arglist))))))) + (nconc new-bindings + (cons 'new-scope byte-compile-bound-variables)))) + (body (cdr (cdr fun))) + (doc (if (stringp (car body)) + (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)))) + (cond (int + ;; Skip (interactive) if it is in front (the most usual location). + (if (eq int (car body)) + (setq body (cdr body))) + (cond ((consp (cdr int)) + (if (cdr (cdr int)) + (byte-compile-warn "malformed interactive spec: %s" + (prin1-to-string int))) + ;; If the interactive spec is a call to `list', + ;; don't compile it, because `call-interactively' + ;; looks at the args of `list'. + (let ((form (nth 1 int))) + (while (or (eq (car-safe form) 'let) + (eq (car-safe form) 'let*) + (eq (car-safe form) 'save-excursion)) + (while (consp (cdr form)) + (setq form (cdr form))) + (setq form (car form))) + (or (eq (car-safe form) 'list) + (setq int (list 'interactive + (byte-compile-top-level (nth 1 int))))))) + ((cdr int) + (byte-compile-warn "malformed interactive spec: %s" + (prin1-to-string int)))))) + (let ((compiled (byte-compile-top-level (cons 'progn body) nil 'lambda))) + (if (memq 'unused-vars byte-compile-warnings) + ;; done compiling in this scope, warn now. + (byte-compile-warn-about-unused-variables)) + (if (eq 'byte-code (car-safe compiled)) + (apply 'make-byte-code + (append (list arglist) + ;; byte-string, constants-vector, stack depth + (cdr compiled) + ;; optionally, the doc string. + (if (or doc int) + (list doc)) + ;; optionally, the interactive spec. + (if int + (list (nth 1 int))))) + (setq compiled + (nconc (if int (list int)) + (cond ((eq (car-safe compiled) 'progn) (cdr compiled)) + (compiled (list compiled))))) + (nconc (list 'lambda arglist) + (if (or doc (stringp (car compiled))) + (cons doc (cond (compiled) + (body (list nil)))) + compiled)))))) + +(defun byte-compile-constants-vector () + ;; Builds the constants-vector from the current variables and constants. + ;; This modifies the constants from (const . nil) to (const . offset). + ;; To keep the byte-codes to look up the vector as short as possible: + ;; First 6 elements are vars, as there are one-byte varref codes for those. + ;; Next up to byte-constant-limit are constants, still with one-byte codes. + ;; Next variables again, to get 2-byte codes for variable lookup. + ;; The rest of the constants and variables need 3-byte byte-codes. + (let* ((i -1) + (rest (nreverse byte-compile-variables)) ; nreverse because the first + (other (nreverse byte-compile-constants)) ; vars often are used most. + ret tmp + (limits '(5 ; Use the 1-byte varref codes, + 63 ; 1-constlim ; 1-byte byte-constant codes, + 255 ; 2-byte varref codes, + 65535)) ; 3-byte codes for the rest. + limit) + (while (or rest other) + (setq limit (car limits)) + (while (and rest (not (eq i limit))) + (if (setq tmp (assq (car (car rest)) ret)) + (setcdr (car rest) (cdr tmp)) + (setcdr (car rest) (setq i (1+ i))) + (setq ret (cons (car rest) ret))) + (setq rest (cdr rest))) + (setq limits (cdr limits) + rest (prog1 other + (setq other rest)))) + (apply 'vector (nreverse (mapcar 'car ret))))) + +;; Given an expression FORM, compile it and return an equivalent byte-code +;; expression (a call to the function byte-code). +(defun byte-compile-top-level (form &optional for-effect output-type) + ;; OUTPUT-TYPE advises about how form is expected to be used: + ;; 'eval or nil -> a single form, + ;; 'progn or t -> a list of forms, + ;; 'lambda -> body of a lambda, + ;; 'file -> used at file-level. + (let ((byte-compile-constants nil) + (byte-compile-variables nil) + (byte-compile-tag-number 0) + (byte-compile-depth 0) + (byte-compile-maxdepth 0) + (byte-compile-output nil)) + (if (memq byte-optimize '(t source)) + (setq form (byte-optimize-form form for-effect))) + (while (and (eq (car-safe form) 'progn) (null (cdr (cdr form)))) + (setq form (nth 1 form))) + (if (and (eq 'byte-code (car-safe form)) + (not (memq byte-optimize '(t byte))) + (stringp (nth 1 form)) + (vectorp (nth 2 form)) + (natnump (nth 3 form))) + form + (byte-compile-form form for-effect) + (byte-compile-out-toplevel for-effect output-type)))) + +(defun byte-compile-out-toplevel (&optional for-effect output-type) + (if for-effect + ;; The stack is empty. Push a value to be returned from (byte-code ..). + (if (eq (car (car byte-compile-output)) 'byte-discard) + (setq byte-compile-output (cdr byte-compile-output)) + (byte-compile-push-constant + ;; Push any constant - preferably one which already is used, and + ;; a number or symbol - ie not some big sequence. The return value + ;; isn't returned, but it would be a shame if some textually large + ;; constant was not optimized away because we chose to return it. + (and (not (assq nil byte-compile-constants)) ; Nil is often there. + (let ((tmp (reverse byte-compile-constants))) + (while (and tmp (not (or (symbolp (car (car tmp))) + (numberp (car (car tmp)))))) + (setq tmp (cdr tmp))) + (car (car tmp))))))) + (byte-compile-out 'byte-return 0) + (setq byte-compile-output (nreverse byte-compile-output)) + (if (memq byte-optimize '(t byte)) + (setq byte-compile-output + (byte-optimize-lapcode byte-compile-output for-effect))) + + ;; Decompile trivial functions: + ;; only constants and variables, or a single funcall except in lambdas. + ;; Except for Lisp_Compiled objects, forms like (foo "hi") + ;; are still quicker than (byte-code "..." [foo "hi"] 2). + ;; Note that even (quote foo) must be parsed just as any subr by the + ;; interpreter, so quote should be compiled into byte-code in some contexts. + ;; What to leave uncompiled: + ;; lambda -> never. we used to leave it uncompiled if the body was + ;; a single atom, but that causes confusion if the docstring + ;; uses the (file . pos) syntax. Besides, now that we have + ;; the Lisp_Compiled type, the compiled form is faster. + ;; eval -> atom, quote or (function atom atom atom) + ;; progn -> as <<same-as-eval>> or (progn <<same-as-eval>> atom) + ;; file -> as progn, but takes both quotes and atoms, and longer forms. + (let (rest + (maycall (not (eq output-type 'lambda))) ; t if we may make a funcall. + tmp body) + (cond + ;; #### This should be split out into byte-compile-nontrivial-function-p. + ((or (eq output-type 'lambda) + (nthcdr (if (eq output-type 'file) 50 8) byte-compile-output) + (assq 'TAG byte-compile-output) ; Not necessary, but speeds up a bit. + (not (setq tmp (assq 'byte-return byte-compile-output))) + (progn + (setq rest (nreverse + (cdr (memq tmp (reverse byte-compile-output))))) + (while (cond + ((memq (car (car rest)) '(byte-varref byte-constant)) + (setq tmp (car (cdr (car rest)))) + (if (if (eq (car (car rest)) 'byte-constant) + (or (consp tmp) + (and (symbolp tmp) + (not (keywordp tmp)) + (not (memq tmp '(nil t)))))) + (if maycall + (setq body (cons (list 'quote tmp) body))) + (setq body (cons tmp body)))) + ((and maycall + ;; Allow a funcall if at most one atom follows it. + (null (nthcdr 3 rest)) + (setq tmp + ;; XEmacs change for rms funs + (or (and + (byte-compile-version-cond + byte-compile-emacs19-compatibility) + (get (car (car rest)) + 'byte-opcode19-invert)) + (get (car (car rest)) + 'byte-opcode-invert))) + (or (null (cdr rest)) + (and (memq output-type '(file progn t)) + (cdr (cdr rest)) + (eq (car (nth 1 rest)) 'byte-discard) + (progn (setq rest (cdr rest)) t)))) + (setq maycall nil) ; Only allow one real function call. + (setq body (nreverse body)) + (setq body (list + (if (and (eq tmp 'funcall) + (eq (car-safe (car body)) 'quote)) + (cons (nth 1 (car body)) (cdr body)) + (cons tmp body)))) + (or (eq output-type 'file) + (not (delq nil (mapcar 'consp (cdr (car body)))))))) + (setq rest (cdr rest))) + rest)) + (let ((byte-compile-vector (byte-compile-constants-vector))) + (list 'byte-code (byte-compile-lapcode byte-compile-output) + byte-compile-vector byte-compile-maxdepth))) + ;; it's a trivial function + ((cdr body) (cons 'progn (nreverse body))) + ((car body))))) + +;; Given BODY, compile it and return a new body. +(defun byte-compile-top-level-body (body &optional for-effect) + (setq body (byte-compile-top-level (cons 'progn body) for-effect t)) + (cond ((eq (car-safe body) 'progn) + (cdr body)) + (body + (list body)))) + +;; This is the recursive entry point for compiling each subform of an +;; expression. +;; If for-effect is non-nil, byte-compile-form will output a byte-discard +;; before terminating (ie no value will be left on the stack). +;; 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). +;; If a handler wants to call another handler, it should do so via +;; byte-compile-form, or take extreme care to handle for-effect correctly. +;; (Use byte-compile-form-do-effect to reset the for-effect flag too.) +;; +(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))) + (byte-compile-constant form)) + ((and for-effect byte-compile-delete-errors) + (setq for-effect nil)) + (t (byte-compile-variable-ref 'byte-varref form)))) + ((symbolp (car form)) + (let* ((fn (car form)) + (handler (get fn 'byte-compile))) + (if (memq fn '(t nil)) + (byte-compile-warn "%s called as a function" fn)) + (if (and handler + (or (not (byte-compile-version-cond + byte-compile-emacs19-compatibility)) + (not (get (get fn 'byte-opcode) 'emacs20-opcode)))) + (funcall handler form) + (if (memq 'callargs byte-compile-warnings) + (byte-compile-callargs-warn form)) + (byte-compile-normal-call form)))) + ((and (or (compiled-function-p (car form)) + (eq (car-safe (car form)) 'lambda)) + ;; if the form comes out the same way it went in, that's + ;; because it was malformed, and we couldn't unfold it. + (not (eq form (setq form (byte-compile-unfold-lambda form))))) + (byte-compile-form form for-effect) + (setq for-effect nil)) + ((byte-compile-normal-call form))) + (if for-effect + (byte-compile-discard))) + +(defun byte-compile-normal-call (form) + (if byte-compile-generate-call-tree + (byte-compile-annotate-call-tree form)) + (byte-compile-push-constant (car form)) + (mapcar 'byte-compile-form (cdr form)) ; wasteful, but faster. + (byte-compile-out 'byte-call (length (cdr form)))) + +;; kludge added to XEmacs to work around the bogosities of a nonlexical lisp. +(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 (and (get var 'byte-obsolete-variable) + (memq 'obsolete byte-compile-warnings)) + (let ((ob (get var 'byte-obsolete-variable))) + (byte-compile-warn "%s is an obsolete variable; %s" var + (if (stringp ob) + ob + (format "use %s instead." ob))))) + (if (and (get var 'byte-compatible-variable) + (memq 'pedantic byte-compile-warnings)) + (let ((ob (get var 'byte-compatible-variable))) + (byte-compile-warn "%s is provided for compatibility; %s" var + (if (stringp ob) + ob + (format "use %s instead." ob))))) + (if (memq 'free-vars byte-compile-warnings) + (if (eq base-op 'byte-varbind) + (setq byte-compile-bound-variables + (cons (cons var (or varbind-flags 0)) + byte-compile-bound-variables)) + (or (globally-boundp var) + (let ((cell (assq var byte-compile-bound-variables))) + (if cell (setcdr cell + (logior (cdr cell) + (if (eq base-op 'byte-varset) + byte-compile-assigned-bit + byte-compile-referenced-bit))))) + (if (eq base-op 'byte-varset) + (or (memq var byte-compile-free-assignments) + (progn + (byte-compile-warn "assignment to free variable %s" + var) + (setq byte-compile-free-assignments + (cons var byte-compile-free-assignments)))) + (or (memq var byte-compile-free-references) + (progn + (byte-compile-warn "reference to free variable %s" var) + (setq byte-compile-free-references + (cons var byte-compile-free-references))))))))) + (let ((tmp (assq var byte-compile-variables))) + (or tmp + (setq tmp (list var) + byte-compile-variables (cons tmp byte-compile-variables))) + (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)))))) + +;; Use this when the value of a form is a constant. This obeys for-effect. +(defun byte-compile-constant (const) + (if for-effect + (setq for-effect nil) + (byte-compile-out 'byte-constant (byte-compile-get-constant const)))) + +;; Use this for a constant that is not the value of its containing form. +;; This ignores for-effect. +(defun byte-compile-push-constant (const) + (let ((for-effect nil)) + (inline (byte-compile-constant const)))) + + +;; Compile those primitive ordinary functions +;; which have special byte codes just for speed. + +(defmacro byte-defop-compiler (function &optional compile-handler) + ;; add a compiler-form for FUNCTION. + ;; If function is a symbol, then the variable "byte-SYMBOL" must name + ;; the opcode to be used. If function is a list, the first element + ;; is the function and the second element is the bytecode-symbol. + ;; COMPILE-HANDLER is the function to use to compile this byte-op, or + ;; may be the abbreviations 0, 1, 2, 3, 0-1, 1-2, 2-3, 0+1, 1+1, 2+1, + ;; 0-1+1, 1-2+1, 2-3+1, 0+2, or 1+2. If it is nil, then the handler is + ;; "byte-compile-SYMBOL." + (let (opcode) + (if (symbolp function) + (setq opcode (intern (concat "byte-" (symbol-name function)))) + (setq opcode (car (cdr function)) + function (car function))) + (let ((fnform + (list 'put (list 'quote function) ''byte-compile + (list 'quote + (or (cdr (assq compile-handler + '((0 . byte-compile-no-args) + (1 . byte-compile-one-arg) + (2 . byte-compile-two-args) + (3 . byte-compile-three-args) + (0-1 . byte-compile-zero-or-one-arg) + (1-2 . byte-compile-one-or-two-args) + (2-3 . byte-compile-two-or-three-args) + (0+1 . byte-compile-no-args-with-one-extra) + (1+1 . byte-compile-one-arg-with-one-extra) + (2+1 . byte-compile-two-args-with-one-extra) + (0-1+1 . byte-compile-zero-or-one-arg-with-one-extra) + (1-2+1 . byte-compile-one-or-two-args-with-one-extra) + (2-3+1 . byte-compile-two-or-three-args-with-one-extra) + (0+2 . byte-compile-no-args-with-two-extra) + (1+2 . byte-compile-one-arg-with-two-extra) + + ))) + compile-handler + (intern (concat "byte-compile-" + (symbol-name function)))))))) + (if opcode + (list 'progn fnform + (list 'put (list 'quote function) + ''byte-opcode (list 'quote opcode)) + (list 'put (list 'quote opcode) + ''byte-opcode-invert (list 'quote function))) + fnform)))) + +(defmacro byte-defop-compiler20 (function &optional compile-handler) + ;; Just like byte-defop-compiler, but defines an opcode that will only + ;; be used when byte-compile-emacs19-compatibility is false. + (if (and (byte-compile-single-version) + byte-compile-emacs19-compatibility) + ;; #### instead of doing nothing, this should do some remprops, + ;; #### to protect against the case where a single-version compiler + ;; #### is loaded into a world that has contained a multi-version one. + nil + (list 'progn + (list 'put + (list 'quote + (or (car (cdr-safe function)) + (intern (concat "byte-" + (symbol-name (or (car-safe function) function)))))) + ''emacs20-opcode t) + (list 'byte-defop-compiler function compile-handler)))) + +;; XEmacs addition: +(defmacro byte-defop-compiler-rmsfun (function &optional compile-handler) + ;; for functions like `eq' that compile into different opcodes depending + ;; on the Emacs version: byte-old-eq for v19, byte-eq for v20. + (let ((opcode (intern (concat "byte-" (symbol-name function)))) + (opcode19 (intern (concat "byte-old-" (symbol-name function)))) + (fnform + (list 'put (list 'quote function) ''byte-compile + (list 'quote + (or (cdr (assq compile-handler + '((2 . byte-compile-two-args-19->20) + ))) + compile-handler + (intern (concat "byte-compile-" + (symbol-name function)))))))) + (list 'progn fnform + (list 'put (list 'quote function) + ''byte-opcode (list 'quote opcode)) + (list 'put (list 'quote function) + ''byte-opcode19 (list 'quote opcode19)) + (list 'put (list 'quote opcode) + ''byte-opcode-invert (list 'quote function)) + (list 'put (list 'quote opcode19) + ''byte-opcode19-invert (list 'quote function))))) + +(defmacro byte-defop-compiler-1 (function &optional compile-handler) + (list 'byte-defop-compiler (list function nil) compile-handler)) + + +(put 'byte-call 'byte-opcode-invert 'funcall) +(put 'byte-list1 'byte-opcode-invert 'list) +(put 'byte-list2 'byte-opcode-invert 'list) +(put 'byte-list3 'byte-opcode-invert 'list) +(put 'byte-list4 'byte-opcode-invert 'list) +(put 'byte-listN 'byte-opcode-invert 'list) +(put 'byte-concat2 'byte-opcode-invert 'concat) +(put 'byte-concat3 'byte-opcode-invert 'concat) +(put 'byte-concat4 'byte-opcode-invert 'concat) +(put 'byte-concatN 'byte-opcode-invert 'concat) +(put 'byte-insertN 'byte-opcode-invert 'insert) + +(byte-defop-compiler (dot byte-point) 0+1) +(byte-defop-compiler (dot-max byte-point-max) 0+1) +(byte-defop-compiler (dot-min byte-point-min) 0+1) +(byte-defop-compiler point 0+1) +(byte-defop-compiler-rmsfun eq 2) +(byte-defop-compiler point-max 0+1) +(byte-defop-compiler point-min 0+1) +(byte-defop-compiler following-char 0+1) +(byte-defop-compiler preceding-char 0+1) +(byte-defop-compiler current-column 0+1) +;; FSF has special function here; generalized here by the 1+2 stuff. +(byte-defop-compiler (indent-to-column byte-indent-to) 1+2) +(byte-defop-compiler indent-to 1+2) +(byte-defop-compiler-rmsfun equal 2) +(byte-defop-compiler eolp 0+1) +(byte-defop-compiler eobp 0+1) +(byte-defop-compiler bolp 0+1) +(byte-defop-compiler bobp 0+1) +(byte-defop-compiler current-buffer 0) +;;(byte-defop-compiler read-char 0) ;; obsolete +(byte-defop-compiler-rmsfun memq 2) +(byte-defop-compiler interactive-p 0) +(byte-defop-compiler widen 0+1) +(byte-defop-compiler end-of-line 0-1+1) +(byte-defop-compiler forward-char 0-1+1) +(byte-defop-compiler forward-line 0-1+1) +(byte-defop-compiler symbolp 1) +(byte-defop-compiler consp 1) +(byte-defop-compiler stringp 1) +(byte-defop-compiler listp 1) +(byte-defop-compiler not 1) +(byte-defop-compiler (null byte-not) 1) +(byte-defop-compiler car 1) +(byte-defop-compiler cdr 1) +(byte-defop-compiler length 1) +(byte-defop-compiler symbol-value 1) +(byte-defop-compiler symbol-function 1) +(byte-defop-compiler (1+ byte-add1) 1) +(byte-defop-compiler (1- byte-sub1) 1) +(byte-defop-compiler goto-char 1+1) +(byte-defop-compiler char-after 0-1+1) +(byte-defop-compiler set-buffer 1) +;;(byte-defop-compiler set-mark 1) ;; obsolete +(byte-defop-compiler forward-word 1+1) +(byte-defop-compiler char-syntax 1+1) +(byte-defop-compiler nreverse 1) +(byte-defop-compiler car-safe 1) +(byte-defop-compiler cdr-safe 1) +(byte-defop-compiler numberp 1) +(byte-defop-compiler integerp 1) +(byte-defop-compiler skip-chars-forward 1-2+1) +(byte-defop-compiler skip-chars-backward 1-2+1) +(byte-defop-compiler (eql byte-eq) 2) +(byte-defop-compiler20 old-eq 2) +(byte-defop-compiler20 old-memq 2) +(byte-defop-compiler cons 2) +(byte-defop-compiler aref 2) +(byte-defop-compiler (= byte-eqlsign) 2) +(byte-defop-compiler (< byte-lss) 2) +(byte-defop-compiler (> byte-gtr) 2) +(byte-defop-compiler (<= byte-leq) 2) +(byte-defop-compiler (>= byte-geq) 2) +(byte-defop-compiler get 2+1) +(byte-defop-compiler nth 2) +(byte-defop-compiler substring 2-3) +(byte-defop-compiler (move-marker byte-set-marker) 2-3) +(byte-defop-compiler set-marker 2-3) +(byte-defop-compiler match-beginning 1) +(byte-defop-compiler match-end 1) +(byte-defop-compiler upcase 1+1) +(byte-defop-compiler downcase 1+1) +(byte-defop-compiler string= 2) +(byte-defop-compiler string< 2) +(byte-defop-compiler (string-equal byte-string=) 2) +(byte-defop-compiler (string-lessp byte-string<) 2) +(byte-defop-compiler20 old-equal 2) +(byte-defop-compiler nthcdr 2) +(byte-defop-compiler elt 2) +(byte-defop-compiler20 old-member 2) +(byte-defop-compiler20 old-assq 2) +(byte-defop-compiler (rplaca byte-setcar) 2) +(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) +(byte-defop-compiler aset 3) + +(byte-defop-compiler-rmsfun member 2) +(byte-defop-compiler-rmsfun assq 2) + +(byte-defop-compiler max byte-compile-associative) +(byte-defop-compiler min byte-compile-associative) +(byte-defop-compiler (+ byte-plus) byte-compile-associative) +(byte-defop-compiler (* byte-mult) byte-compile-associative) + +;;####(byte-defop-compiler move-to-column 1) +(byte-defop-compiler-1 interactive byte-compile-noop) +(byte-defop-compiler-1 domain byte-compile-domain) + +;; As of GNU Emacs 19.18 and Lucid Emacs 19.8, mod and % are different: `%' +;; means integral remainder and may have a negative result; `mod' is always +;; positive, and accepts floating point args. All code which uses `mod' and +;; requires the new interpretation must be compiled with bytecomp version 2.18 +;; or newer, or the emitted code will run the byte-code for `%' instead of an +;; actual call to `mod'. So be careful of compiling new code with an old +;; compiler. Note also that `%' is more efficient than `mod' because the +;; former is byte-coded and the latter is not. +;;(byte-defop-compiler (mod byte-rem) 2) + + +(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) + ;; 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))) + +(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))) + +(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))) + +(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))) + +(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"))))) + +(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"))))) + +(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"))))) + +;; from Ben Wing <wing@666.com>: some inlined functions have extra +;; optional args added to them in XEmacs 19.12. Changing the byte +;; interpreter to deal with these args would be wrong and cause +;; incompatibility, so we generate non-inlined calls for those cases. +;; Without the following functions, spurious warnings will be generated; +;; however, they would still compile correctly because +;; `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"))))) + +(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"))))) + +(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"))))) + +(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"))))) + +(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"))))) + +(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"))))) + +(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"))))) + +(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"))))) + +;; XEmacs: used for functions that have a different opcode in v19 than v20. +;; this includes `eq', `equal', and other old-ified functions. +(defun byte-compile-two-args-19->20 (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)) + (if (byte-compile-version-cond byte-compile-emacs19-compatibility) + (byte-compile-out (get (car form) 'byte-opcode19) 0) + (byte-compile-out (get (car form) 'byte-opcode) 0)))) + +(defun byte-compile-noop (form) + (byte-compile-constant nil)) + +(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)))) + + +;; more complicated compiler macros + +(byte-defop-compiler list) +(byte-defop-compiler concat) +(byte-defop-compiler fset) +(byte-defop-compiler insert) +(byte-defop-compiler-1 function byte-compile-function-form) +(byte-defop-compiler-1 - byte-compile-minus) +(byte-defop-compiler (/ byte-quo) byte-compile-quo) +(byte-defop-compiler nconc) +(byte-defop-compiler-1 beginning-of-line) + +(defun byte-compile-buffer-substring (form) + (let ((len (length form))) + ;; buffer-substring used to take exactly two args, but now takes 0-3. + ;; convert 0-2 to two args and use special bytecode operand. + ;; convert 3 args to a normal call. + (cond ((= len 1) (setq form (append form '(nil nil))) + (= len 2) (setq form (append form '(nil))))) + (cond ((= len 3) (byte-compile-two-args form)) + ((= len 4) (byte-compile-normal-call form)) + (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))))) + +(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))))) + +(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)))) + +(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)))))) + +(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)))))) + +(defun byte-compile-fset (form) + ;; warn about forms like (fset 'foo '(lambda () ...)) + ;; (where the lambda expression is non-trivial...) + ;; Except don't warn if the first argument is 'make-byte-code, because + ;; 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 + not what you want, as that lambda cannot be compiled. Consider using + the syntax (function (lambda (...) ...)) instead."))))) + (byte-compile-two-args form)) + +(defun byte-compile-funarg (form) + ;; (mapcar '(lambda (x) ..) ..) ==> (mapcar (function (lambda (x) ..)) ..) + ;; for cases where it's guaranteed that first arg will be used as a lambda. + (byte-compile-normal-call + (let ((fn (nth 1 form))) + (if (and (eq (car-safe fn) 'quote) + (eq (car-safe (nth 1 fn)) 'lambda)) + (cons (car form) + (cons (cons 'function (cdr fn)) + (cdr (cdr form)))) + form)))) + +;; (function foo) must compile like 'foo, not like (symbol-function 'foo). +;; Otherwise it will be incompatible with the interpreter, +;; and (funcall (function foo)) will lose with autoloads. + +(defun byte-compile-function-form (form) + (byte-compile-constant + (cond ((symbolp (nth 1 form)) + (nth 1 form)) + ((byte-compile-lambda (nth 1 form)))))) + +(defun byte-compile-insert (form) + (cond ((null (cdr form)) + (byte-compile-constant nil)) + ((<= (length form) 256) + (mapcar 'byte-compile-form (cdr form)) + (if (cdr (cdr form)) + (byte-compile-out 'byte-insertN (length (cdr form))) + (byte-compile-out 'byte-insert 0))) + ((memq t (mapcar 'consp (cdr (cdr form)))) + (byte-compile-normal-call form)) + ;; We can split it; there is no function call after inserting 1st arg. + (t + (while (setq form (cdr form)) + (byte-compile-form (car form)) + (byte-compile-out 'byte-insert 0) + (if (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 +;; (beginning-of-line nil buffer) because it buggily doesn't +;; check the number of arguments passed to beginning-of-line. + +(defun byte-compile-beginning-of-line (form) + (let ((len (length form))) + (cond ((> len 3) + (byte-compile-subr-wrong-args form "0-2")) + ((or (= len 3) (not (byte-compile-constp (nth 1 form)))) + (byte-compile-normal-call form)) + (t + (byte-compile-form + (list 'forward-line + (if (integerp (setq form (or (eval (nth 1 form)) 1))) + (1- form) + (byte-compile-warn + "Non-numeric arg to beginning-of-line: %s" form) + (list '1- (list 'quote form)))) + t) + (byte-compile-constant nil))))) + + +(byte-defop-compiler set) +(byte-defop-compiler-1 setq) +(byte-defop-compiler-1 set-default) +(byte-defop-compiler-1 setq-default) + +(byte-defop-compiler-1 quote) +(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)) + (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))) + +(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))))) + +(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)))))) + +(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))))) + + +(defun byte-compile-quote (form) + (byte-compile-constant (car (cdr form)))) + +(defun byte-compile-quote-form (form) + (byte-compile-constant (byte-compile-top-level (nth 1 form)))) + + +;;; control structures + +(defun byte-compile-body (body &optional for-effect) + (while (cdr body) + (byte-compile-form (car body) t) + (setq body (cdr body))) + (byte-compile-form (car body) for-effect)) + +(proclaim-inline byte-compile-body-do-effect) +(defun byte-compile-body-do-effect (body) + (byte-compile-body body for-effect) + (setq for-effect nil)) + +(proclaim-inline byte-compile-form-do-effect) +(defun byte-compile-form-do-effect (form) + (byte-compile-form form for-effect) + (setq for-effect nil)) + +(byte-defop-compiler-1 inline byte-compile-progn) +(byte-defop-compiler-1 progn) +(byte-defop-compiler-1 prog1) +(byte-defop-compiler-1 prog2) +(byte-defop-compiler-1 if) +(byte-defop-compiler-1 cond) +(byte-defop-compiler-1 and) +(byte-defop-compiler-1 or) +(byte-defop-compiler-1 while) +(byte-defop-compiler-1 funcall) +(byte-defop-compiler-1 apply byte-compile-funarg) +(byte-defop-compiler-1 mapcar byte-compile-funarg) +(byte-defop-compiler-1 mapatoms byte-compile-funarg) +(byte-defop-compiler-1 mapconcat byte-compile-funarg) +(byte-defop-compiler-1 let) +(byte-defop-compiler-1 let*) + +(defun byte-compile-progn (form) + (byte-compile-body-do-effect (cdr form))) + +(defun byte-compile-prog1 (form) + (byte-compile-form-do-effect (car (cdr form))) + (byte-compile-body (cdr (cdr form)) t)) + +(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)) + +(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)))) + +(defun byte-compile-if (form) + (byte-compile-form (car (cdr form))) + (if (null (nthcdr 3 form)) + ;; No else-forms + (let ((donetag (byte-compile-make-tag))) + (byte-compile-goto-if nil for-effect donetag) + (byte-compile-form (nth 2 form) for-effect) + (byte-compile-out-tag donetag)) + (let ((donetag (byte-compile-make-tag)) (elsetag (byte-compile-make-tag))) + (byte-compile-goto 'byte-goto-if-nil elsetag) + (byte-compile-form (nth 2 form) for-effect) + (byte-compile-goto 'byte-goto donetag) + (byte-compile-out-tag elsetag) + (byte-compile-body (cdr (cdr (cdr form))) for-effect) + (byte-compile-out-tag donetag))) + (setq for-effect nil)) + +(defun byte-compile-cond (clauses) + (let ((donetag (byte-compile-make-tag)) + nexttag clause) + (while (setq clauses (cdr clauses)) + (setq clause (car clauses)) + (cond ((or (eq (car clause) t) + (and (eq (car-safe (car clause)) 'quote) + (car-safe (cdr-safe (car clause))))) + ;; Unconditional clause + (setq clause (cons t clause) + clauses nil)) + ((cdr clauses) + (byte-compile-form (car clause)) + (if (null (cdr clause)) + ;; First clause is a singleton. + (byte-compile-goto-if t for-effect donetag) + (setq nexttag (byte-compile-make-tag)) + (byte-compile-goto 'byte-goto-if-nil nexttag) + (byte-compile-body (cdr clause) for-effect) + (byte-compile-goto 'byte-goto donetag) + (byte-compile-out-tag nexttag))))) + ;; Last clause + (and (cdr clause) (not (eq (car clause) t)) + (progn (byte-compile-form (car clause)) + (byte-compile-goto-if nil for-effect donetag) + (setq clause (cdr clause)))) + (byte-compile-body-do-effect clause) + (byte-compile-out-tag donetag))) + +(defun byte-compile-and (form) + (let ((failtag (byte-compile-make-tag)) + (args (cdr form))) + (if (null args) + (byte-compile-form-do-effect t) + (while (cdr args) + (byte-compile-form (car args)) + (byte-compile-goto-if nil for-effect failtag) + (setq args (cdr args))) + (byte-compile-form-do-effect (car args)) + (byte-compile-out-tag failtag)))) + +(defun byte-compile-or (form) + (let ((wintag (byte-compile-make-tag)) + (args (cdr form))) + (if (null args) + (byte-compile-form-do-effect nil) + (while (cdr args) + (byte-compile-form (car args)) + (byte-compile-goto-if t for-effect wintag) + (setq args (cdr args))) + (byte-compile-form-do-effect (car args)) + (byte-compile-out-tag wintag)))) + +(defun byte-compile-while (form) + (let ((endtag (byte-compile-make-tag)) + (looptag (byte-compile-make-tag))) + (byte-compile-out-tag looptag) + (byte-compile-form (car (cdr form))) + (byte-compile-goto-if nil for-effect endtag) + (byte-compile-body (cdr (cdr form)) t) + (byte-compile-goto 'byte-goto looptag) + (byte-compile-out-tag endtag) + (setq for-effect nil))) + +(defun byte-compile-funcall (form) + (mapcar 'byte-compile-form (cdr form)) + (byte-compile-out 'byte-call (length (cdr (cdr form))))) + + +(defun byte-compile-let (form) + ;; First compute the binding values in the old scope. + (let ((varlist (car (cdr form)))) + (while varlist + (if (consp (car varlist)) + (byte-compile-form (car (cdr (car varlist)))) + (byte-compile-push-constant nil)) + (setq varlist (cdr varlist)))) + (let ((byte-compile-bound-variables + (cons 'new-scope byte-compile-bound-variables)) + (varlist (reverse (car (cdr form)))) + (extra-flags + ;; If this let is of the form (let (...) (byte-code ...)) + ;; then assume that it is the result of a transformation of + ;; ((lambda (...) (byte-code ... )) ...) and thus compile + ;; the variable bindings as if they were arglist bindings + ;; (which matters for what warnings.) + (if (eq 'byte-code (car-safe (nth 2 form))) + byte-compile-arglist-bit + nil))) + (while varlist + (byte-compile-variable-ref 'byte-varbind + (if (consp (car varlist)) + (car (car varlist)) + (car varlist)) + extra-flags) + (setq varlist (cdr varlist))) + (byte-compile-body-do-effect (cdr (cdr form))) + (if (memq 'unused-vars byte-compile-warnings) + ;; done compiling in this scope, warn now. + (byte-compile-warn-about-unused-variables)) + (byte-compile-out 'byte-unbind (length (car (cdr form)))))) + +(defun byte-compile-let* (form) + (let ((byte-compile-bound-variables + (cons 'new-scope byte-compile-bound-variables)) + (varlist (copy-sequence (car (cdr form))))) + (while varlist + (if (atom (car varlist)) + (byte-compile-push-constant nil) + (byte-compile-form (car (cdr (car varlist)))) + (setcar varlist (car (car varlist)))) + (byte-compile-variable-ref 'byte-varbind (car varlist)) + (setq varlist (cdr varlist))) + (byte-compile-body-do-effect (cdr (cdr form))) + (if (memq 'unused-vars byte-compile-warnings) + ;; done compiling in this scope, warn now. + (byte-compile-warn-about-unused-variables)) + (byte-compile-out 'byte-unbind (length (car (cdr form)))))) + + +(byte-defop-compiler-1 /= byte-compile-negated) +(byte-defop-compiler-1 atom byte-compile-negated) +(byte-defop-compiler-1 nlistp byte-compile-negated) + +(put '/= 'byte-compile-negated-op '=) +(put 'atom 'byte-compile-negated-op 'consp) +(put 'nlistp 'byte-compile-negated-op 'listp) + +(defun byte-compile-negated (form) + (byte-compile-form-do-effect (byte-compile-negation-optimizer form))) + +;; Even when optimization is off, /= is optimized to (not (= ...)). +(defun byte-compile-negation-optimizer (form) + ;; an optimizer for forms where <form1> is less efficient than (not <form2>) + (list 'not + (cons (or (get (car form) 'byte-compile-negated-op) + (error + "Compiler error: `%s' has no `byte-compile-negated-op' property" + (car form))) + (cdr form)))) + +;;; other tricky macro-like special-forms + +(byte-defop-compiler-1 catch) +(byte-defop-compiler-1 unwind-protect) +(byte-defop-compiler-1 condition-case) +(byte-defop-compiler-1 save-excursion) +(byte-defop-compiler-1 save-current-buffer) +(byte-defop-compiler-1 save-restriction) +(byte-defop-compiler-1 save-window-excursion) +(byte-defop-compiler-1 with-output-to-temp-buffer) +;; no track-mouse. + +(defun byte-compile-catch (form) + (byte-compile-form (car (cdr form))) + (byte-compile-push-constant + (byte-compile-top-level (cons 'progn (cdr (cdr form))) for-effect)) + (byte-compile-out 'byte-catch 0)) + +(defun byte-compile-unwind-protect (form) + (byte-compile-push-constant + (byte-compile-top-level-body (cdr (cdr form)) t)) + (byte-compile-out 'byte-unwind-protect 0) + (byte-compile-form-do-effect (car (cdr form))) + (byte-compile-out 'byte-unbind 1)) + +;;(defun byte-compile-track-mouse (form) +;; (byte-compile-form +;; (list +;; 'funcall +;; (list 'quote +;; (list 'lambda nil +;; (cons 'track-mouse +;; (byte-compile-top-level-body (cdr form)))))))) + +(defun byte-compile-condition-case (form) + (let* ((var (nth 1 form)) + (byte-compile-bound-variables + (if var + (cons (cons var 0) + (cons 'new-scope byte-compile-bound-variables)) + (cons 'new-scope byte-compile-bound-variables)))) + (or (symbolp var) + (byte-compile-warn + "%s is not a variable-name or nil (in condition-case)" + (prin1-to-string var))) + (byte-compile-push-constant var) + (byte-compile-push-constant (byte-compile-top-level + (nth 2 form) for-effect)) + (let ((clauses (cdr (cdr (cdr form)))) + compiled-clauses) + (while clauses + (let* ((clause (car clauses)) + (condition (car clause))) + (cond ((not (or (symbolp condition) + (and (listp condition) + (let ((syms condition) (ok t)) + (while syms + (if (not (symbolp (car syms))) + (setq ok nil)) + (setq syms (cdr syms))) + ok)))) + (byte-compile-warn + "%s is not a symbol naming a condition or a list of such (in condition-case)" + (prin1-to-string condition))) +;; ((not (or (eq condition 't) +;; (and (stringp (get condition 'error-message)) +;; (consp (get condition 'error-conditions))))) +;; (byte-compile-warn +;; "%s is not a known condition name (in condition-case)" +;; condition)) + ) + (setq compiled-clauses + (cons (cons condition + (byte-compile-top-level-body + (cdr clause) for-effect)) + compiled-clauses))) + (setq clauses (cdr clauses))) + (byte-compile-push-constant (nreverse compiled-clauses))) + (if (memq 'unused-vars byte-compile-warnings) + ;; done compiling in this scope, warn now. + (byte-compile-warn-about-unused-variables)) + (byte-compile-out 'byte-condition-case 0))) + + +(defun byte-compile-save-excursion (form) + (byte-compile-out 'byte-save-excursion 0) + (byte-compile-body-do-effect (cdr form)) + (byte-compile-out 'byte-unbind 1)) + +(defun byte-compile-save-restriction (form) + (byte-compile-out 'byte-save-restriction 0) + (byte-compile-body-do-effect (cdr form)) + (byte-compile-out 'byte-unbind 1)) + +(defun byte-compile-save-current-buffer (form) + (if (byte-compile-version-cond byte-compile-emacs19-compatibility) + ;; `save-current-buffer' special form is not available in XEmacs 19. + (byte-compile-form + `(let ((_byte_compiler_save_buffer_emulation_closure_ (current-buffer))) + (unwind-protect + (progn ,@(cdr form)) + (and (buffer-live-p _byte_compiler_save_buffer_emulation_closure_) + (set-buffer _byte_compiler_save_buffer_emulation_closure_))))) + (byte-compile-out 'byte-save-current-buffer 0) + (byte-compile-body-do-effect (cdr form)) + (byte-compile-out 'byte-unbind 1))) + +(defun byte-compile-save-window-excursion (form) + (byte-compile-push-constant + (byte-compile-top-level-body (cdr form) for-effect)) + (byte-compile-out 'byte-save-window-excursion 0)) + +(defun byte-compile-with-output-to-temp-buffer (form) + (byte-compile-form (car (cdr form))) + (byte-compile-out 'byte-temp-output-buffer-setup 0) + (byte-compile-body (cdr (cdr form))) + (byte-compile-out 'byte-temp-output-buffer-show 0)) + + +;;; top-level forms elsewhere + +(byte-defop-compiler-1 defun) +(byte-defop-compiler-1 defmacro) +(byte-defop-compiler-1 defvar) +(byte-defop-compiler-1 defconst byte-compile-defvar) +(byte-defop-compiler-1 autoload) +;; According to Mly this can go now that lambda is a macro +;(byte-defop-compiler-1 lambda byte-compile-lambda-form) +(byte-defop-compiler-1 defalias) +(byte-defop-compiler-1 define-function) + +(defun byte-compile-defun (form) + ;; This is not used for file-level defuns with doc strings. + (byte-compile-two-args ; Use this to avoid byte-compile-fset's warning. + (list 'fset (list 'quote (nth 1 form)) + (byte-compile-byte-code-maker + (byte-compile-lambda (cons 'lambda (cdr (cdr form))))))) + (byte-compile-discard) + (byte-compile-constant (nth 1 form))) + +(defun byte-compile-defmacro (form) + ;; This is not used for file-level defmacros with doc strings. + (byte-compile-body-do-effect + (list (list 'fset (list 'quote (nth 1 form)) + (let ((code (byte-compile-byte-code-maker + (byte-compile-lambda + (cons 'lambda (cdr (cdr form))))))) + (if (eq (car-safe code) 'make-byte-code) + (list 'cons ''macro code) + (list 'quote (cons 'macro (eval code)))))) + (list 'quote (nth 1 form))))) + +(defun byte-compile-defvar (form) + ;; This is not used for file-level defvar/consts with doc strings: + ;; byte-compile-file-form-defvar will be used in that case. + (let ((var (nth 1 form)) + (value (nth 2 form)) + (string (nth 3 form))) + (if (> (length form) 4) + (byte-compile-warn "%s used with too many args" (car form))) + (if (memq 'free-vars byte-compile-warnings) + (setq byte-compile-bound-variables + (cons (cons var byte-compile-global-bit) + byte-compile-bound-variables))) + (byte-compile-body-do-effect + (list (if (cdr (cdr form)) + (if (eq (car form) 'defconst) + (list 'setq var value) + (list 'or (list 'boundp (list 'quote var)) + (list 'setq var value)))) + ;; Put the defined variable in this library's load-history entry + ;; just as a real defvar would. + (list 'setq 'current-load-list + (list 'cons (list 'quote var) + 'current-load-list)) + (if string + (list 'put (list 'quote var) ''variable-documentation string)) + (list 'quote var))))) + +(defun byte-compile-autoload (form) + (and (byte-compile-constp (nth 1 form)) + (byte-compile-constp (nth 5 form)) + (memq (eval (nth 5 form)) '(t macro)) ; macro-p + (not (fboundp (eval (nth 1 form)))) + (byte-compile-warn + "The compiler ignores `autoload' except at top level. You should + probably put the autoload of the macro `%s' at top-level." + (eval (nth 1 form)))) + (byte-compile-normal-call form)) + +;; Lambda's in valid places are handled as special cases by various code. +;; The ones that remain are errors. +;; According to Mly this can go now that lambda is a macro +;(defun byte-compile-lambda-form (form) +; (byte-compile-warn +; "`lambda' used in function position is invalid: probably you mean #'%s" +; (let ((print-escape-newlines t) +; (print-level 4) +; (print-length 4)) +; (prin1-to-string form))) +; (byte-compile-normal-call +; (list 'signal ''error +; (list 'quote (list "`lambda' used in function position" form))))) + +;; Compile normally, but deal with warnings for the function being defined. +(defun byte-compile-defalias (form) + (if (and (consp (cdr form)) (consp (nth 1 form)) + (eq (car (nth 1 form)) 'quote) + (consp (cdr (nth 1 form))) + (symbolp (nth 1 (nth 1 form))) + (consp (nthcdr 2 form)) + (consp (nth 2 form)) + (eq (car (nth 2 form)) 'quote) + (consp (cdr (nth 2 form))) + (symbolp (nth 1 (nth 2 form)))) + (progn + (byte-compile-defalias-warn (nth 1 (nth 1 form)) + (nth 1 (nth 2 form))) + (setq byte-compile-function-environment + (cons (cons (nth 1 (nth 1 form)) + (nth 1 (nth 2 form))) + byte-compile-function-environment)))) + (byte-compile-normal-call form)) + +(defun byte-compile-define-function (form) + (byte-compile-defalias form)) + +;; Turn off warnings about prior calls to the function being defalias'd. +;; This could be smarter and compare those calls with +;; the function it is being aliased to. +(defun byte-compile-defalias-warn (new alias) + (let ((calls (assq new byte-compile-unresolved-functions))) + (if calls + (setq byte-compile-unresolved-functions + (delq calls byte-compile-unresolved-functions))))) + +;;; tags + +;; Note: Most operations will strip off the 'TAG, but it speeds up +;; optimization to have the 'TAG as a part of the tag. +;; Tags will be (TAG . (tag-number . stack-depth)). +(defun byte-compile-make-tag () + (list 'TAG (setq byte-compile-tag-number (1+ byte-compile-tag-number)))) + + +(defun byte-compile-out-tag (tag) + (setq byte-compile-output (cons tag byte-compile-output)) + (if (cdr (cdr tag)) + (progn + ;; ## remove this someday + (and byte-compile-depth + (not (= (cdr (cdr tag)) byte-compile-depth)) + (error "Compiler bug: depth conflict at tag %d" (car (cdr tag)))) + (setq byte-compile-depth (cdr (cdr tag)))) + (setcdr (cdr tag) byte-compile-depth))) + +(defun byte-compile-goto (opcode tag) + (setq byte-compile-output (cons (cons opcode tag) byte-compile-output)) + (setcdr (cdr tag) (if (memq opcode byte-goto-always-pop-ops) + (1- byte-compile-depth) + byte-compile-depth)) + (setq byte-compile-depth (and (not (eq opcode 'byte-goto)) + (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)))) + ;;(if (< byte-compile-depth 0) (error "Compiler error: stack underflow")) + ) + + +;;; call tree stuff + +(defun byte-compile-annotate-call-tree (form) + (let (entry) + ;; annotate the current call + (if (setq entry (assq (car form) byte-compile-call-tree)) + (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))) + ;; 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))) + )) + +;; Renamed from byte-compile-report-call-tree +;; to avoid interfering with completion of byte-compile-file. +;;;###autoload +(defun display-call-tree (&optional filename) + "Display a call graph of a specified file. +This lists which functions have been called, what functions called +them, and what functions they call. The list includes all functions +whose definitions have been compiled in this Emacs session, as well as +all functions called by those functions. + +The call graph does not include macros, inline functions, or +primitives that the byte-code interpreter knows about directly \(eq, +cons, etc.\). + +The call tree also lists those functions which are not known to be called +\(that is, to which no calls have been compiled\), and which cannot be +invoked interactively." + (interactive) + (message "Generating call tree...") + (with-output-to-temp-buffer "*Call-Tree*" + (set-buffer "*Call-Tree*") + (erase-buffer) + (message "Generating call tree... (sorting on %s)" + byte-compile-call-tree-sort) + (insert "Call tree for " + (cond ((null byte-compile-current-file) (or filename "???")) + ((stringp byte-compile-current-file) + byte-compile-current-file) + (t (buffer-name byte-compile-current-file))) + " sorted on " + (prin1-to-string byte-compile-call-tree-sort) + ":\n\n") + (if byte-compile-call-tree-sort + (setq byte-compile-call-tree + (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)))))) + ((eq byte-compile-call-tree-sort 'calls) + (function (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))))))) + ((eq byte-compile-call-tree-sort 'name) + (function (lambda (x y) (string< (car x) + (car y))))) + (t (error + "`byte-compile-call-tree-sort': `%s' - unknown sort mode" + byte-compile-call-tree-sort)))))) + (message "Generating call tree...") + (let ((rest byte-compile-call-tree) + (b (current-buffer)) + f p + callers calls) + (while rest + (prin1 (car (car rest)) b) + (setq callers (nth 1 (car rest)) + calls (nth 2 (car rest))) + (insert "\t" + (cond ((not (fboundp (setq f (car (car rest))))) + (if (null f) + " <top level>";; shouldn't insert nil then, actually -sk + " <not defined>")) + ((subrp (setq f (symbol-function f))) + " <subr>") + ((symbolp f) + (format " ==> %s" f)) + ((compiled-function-p f) + "<compiled function>") + ((not (consp f)) + "<malformed function>") + ((eq 'macro (car f)) + (if (or (compiled-function-p (cdr f)) + (assq 'byte-code (cdr (cdr (cdr f))))) + " <compiled macro>" + " <macro>")) + ((assq 'byte-code (cdr (cdr f))) + "<compiled lambda>") + ((eq 'lambda (car f)) + "<function>") + (t "???")) + (format " (%d callers + %d calls = %d)" + ;; Does the optimizer eliminate common subexpressions?-sk + (length callers) + (length calls) + (+ (length callers) (length calls))) + "\n") + (if callers + (progn + (insert " called by:\n") + (setq p (point)) + (insert " " (if (car callers) + (mapconcat 'symbol-name callers ", ") + "<top level>")) + (let ((fill-prefix " ")) + (fill-region-as-paragraph p (point))))) + (if calls + (progn + (insert " calls:\n") + (setq p (point)) + (insert " " (mapconcat 'symbol-name calls ", ")) + (let ((fill-prefix " ")) + (fill-region-as-paragraph p (point))))) + (insert "\n") + (setq rest (cdr rest))) + + (message "Generating call tree...(finding uncalled functions...)") + (setq rest byte-compile-call-tree) + (let ((uncalled nil)) + (while rest + (or (nth 1 (car rest)) + (null (setq f (car (car rest)))) + (byte-compile-fdefinition f t) + (commandp (byte-compile-fdefinition f nil)) + (setq uncalled (cons f uncalled))) + (setq rest (cdr rest))) + (if uncalled + (let ((fill-prefix " ")) + (insert "Noninteractive functions not known to be called:\n ") + (setq p (point)) + (insert (mapconcat 'symbol-name (nreverse uncalled) ", ")) + (fill-region-as-paragraph p (point))))) + ) + (message "Generating call tree...done.") + )) + + +;;; by crl@newton.purdue.edu +;;; Only works noninteractively. +;;;###autoload +(defun batch-byte-compile () + "Run `byte-compile-file' 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 \"emacs -batch -f batch-byte-compile $emacs/ ~/*.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-byte-compile' is to be used only with -batch")) + (let ((error nil) + (debug-issue-ebola-notices 0)) ; Hack -slb + (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))) + source dest) + (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) + (car command-line-args-left))) + (setq dest (byte-compile-dest-file source)) + (file-exists-p dest) + (file-newer-than-file-p source dest)) + (if (null (batch-byte-compile-1 source)) + (setq error t))) + (setq files (cdr files)))) + (if (null (batch-byte-compile-1 (car command-line-args-left))) + (setq error t))) + (setq command-line-args-left (cdr command-line-args-left))) + (message "Done") + (kill-emacs (if error 1 0)))) + +(defun batch-byte-compile-1 (file) + (condition-case err + (progn (byte-compile-file file) t) + (error + (princ ">>Error occurred processing ") + (princ file) + (princ ": ") + (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))) + (princ "\n") + nil))) + +;;;###autoload +(defun batch-byte-recompile-directory-norecurse () + "Same as `batch-byte-recompile-directory' but without recursion." + (setq byte-recompile-directory-recursively nil) + (batch-byte-recompile-directory)) + +;;;###autoload +(defun batch-byte-recompile-directory () + "Runs `byte-recompile-directory' on the dirs remaining on the command line. +Must be used only with `-batch', and kills Emacs on completion. +For example, invoke `xemacs -batch -f batch-byte-recompile-directory .'." + ;; command-line-args-left is what is left of the command line (startup.el) + (defvar command-line-args-left) ;Avoid 'free variable' warning + (if (not noninteractive) + (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)) + (while command-line-args-left + (byte-recompile-directory (car command-line-args-left)) + (setq command-line-args-left (cdr command-line-args-left)))) + (kill-emacs 0)) + +(make-obsolete 'elisp-compile-defun 'compile-defun) +(make-obsolete 'byte-compile-report-call-tree 'display-call-tree) + +;; other make-obsolete calls in obsolete.el. + +(provide 'byte-compile) +(provide 'bytecomp) + + +;;; report metering (see the hacks in bytecode.c) + +(if (boundp 'byte-code-meter) + (defun byte-compile-report-ops () + (defvar byte-code-meter) + (with-output-to-temp-buffer "*Meter*" + (set-buffer "*Meter*") + (let ((i 0) n op off) + (while (< i 256) + (setq n (aref (aref byte-code-meter 0) i) + off nil) + (if t ;(not (zerop n)) + (progn + (setq op i) + (setq off nil) + (cond ((< op byte-nth) + (setq off (logand op 7)) + (setq op (logand op 248))) + ((>= op byte-constant) + (setq off (- op byte-constant) + op byte-constant))) + (setq op (aref byte-code-vector op)) + (insert (format "%-4d" i)) + (insert (symbol-name op)) + (if off (insert " [" (int-to-string off) "]")) + (indent-to 40) + (insert (int-to-string n) "\n"))) + (setq i (1+ i))))))) + + +;; To avoid "lisp nesting exceeds max-lisp-eval-depth" when bytecomp compiles +;; itself, compile some of its most used recursive functions (at load time). +;; +(eval-when-compile + (or (compiled-function-p (symbol-function 'byte-compile-form)) + (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))) + '(byte-compile-normal-call + byte-compile-form + byte-compile-body + ;; Inserted some more than necessary, to speed it up. + byte-compile-top-level + byte-compile-out-toplevel + byte-compile-constant + byte-compile-variable-ref)))) + nil) + +;;; bytecomp.el ends here
--- a/lisp/bytecomp/auto-autoloads.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,94 +0,0 @@ -;;; DO NOT MODIFY THIS FILE -(if (featurep 'bytecomp-autoloads) (error "Already loaded")) - -;;;### (autoloads (batch-byte-recompile-directory batch-byte-recompile-directory-norecurse batch-byte-compile display-call-tree byte-compile-sexp byte-compile compile-defun byte-compile-file byte-recompile-file byte-recompile-directory byte-force-recompile) "bytecomp" "bytecomp/bytecomp.el") - -(autoload 'byte-force-recompile "bytecomp" "\ -Recompile every `.el' file in DIRECTORY that already has a `.elc' file. -Files in subdirectories of DIRECTORY are processed also." t nil) - -(autoload 'byte-recompile-directory "bytecomp" "\ -Recompile every `.el' file in DIRECTORY that needs recompilation. -This is if a `.elc' file exists but is older than the `.el' file. -Files in subdirectories of DIRECTORY are processed also unless argument -NORECURSION is non-nil. - -If the `.elc' file does not exist, normally the `.el' file is *not* compiled. -But a prefix argument (optional second arg) means ask user, -for each such `.el' file, whether to compile it. Prefix argument 0 means -don't ask and compile the file anyway. - -A nonzero prefix argument also means ask about each subdirectory. - -If the fourth argument FORCE is non-nil, -recompile every `.el' file that already has a `.elc' file." t nil) - -(autoload 'byte-recompile-file "bytecomp" "\ -Recompile a file of Lisp code named FILENAME if it needs recompilation. -This is if the `.elc' file exists but is older than the `.el' file. - -If the `.elc' file does not exist, normally the `.el' file is *not* -compiled. But a prefix argument (optional second arg) means ask user -whether to compile it. Prefix argument 0 don't ask and recompile anyway." t nil) - -(autoload 'byte-compile-file "bytecomp" "\ -Compile a file of Lisp code named FILENAME into a file of byte code. -The output file's name is made by appending `c' to the end of FILENAME. -With prefix arg (noninteractively: 2nd arg), load the file after compiling." t nil) - -(autoload 'compile-defun "bytecomp" "\ -Compile and evaluate the current top-level form. -Print the result in the minibuffer. -With argument, insert value in current buffer after the form." t nil) - -(autoload 'byte-compile "bytecomp" "\ -If FORM is a symbol, byte-compile its function definition. -If FORM is a lambda or a macro, byte-compile it as a function." nil nil) - -(autoload 'byte-compile-sexp "bytecomp" "\ -Compile and return SEXP." nil nil) - -(autoload 'display-call-tree "bytecomp" "\ -Display a call graph of a specified file. -This lists which functions have been called, what functions called -them, and what functions they call. The list includes all functions -whose definitions have been compiled in this Emacs session, as well as -all functions called by those functions. - -The call graph does not include macros, inline functions, or -primitives that the byte-code interpreter knows about directly (eq, -cons, etc.). - -The call tree also lists those functions which are not known to be called -\(that is, to which no calls have been compiled), and which cannot be -invoked interactively." t nil) - -(autoload 'batch-byte-compile "bytecomp" "\ -Run `byte-compile-file' 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 \"emacs -batch -f batch-byte-compile $emacs/ ~/*.el\"" nil nil) - -(autoload 'batch-byte-recompile-directory-norecurse "bytecomp" "\ -Same as `batch-byte-recompile-directory' but without recursion." nil nil) - -(autoload 'batch-byte-recompile-directory "bytecomp" "\ -Runs `byte-recompile-directory' on the dirs remaining on the command line. -Must be used only with `-batch', and kills Emacs on completion. -For example, invoke `xemacs -batch -f batch-byte-recompile-directory .'." nil nil) - -;;;*** - -;;;### (autoloads (disassemble) "disass" "bytecomp/disass.el") - -(autoload 'disassemble "disass" "\ -Print disassembled code for OBJECT in (optional) BUFFER. -OBJECT can be a symbol defined as a function, or a function itself -\(a lambda expression or a compiled-function object). -If OBJECT is not already compiled, we compile it, but do not -redefine OBJECT if it is a symbol." t nil) - -;;;*** - -(provide 'bytecomp-autoloads)
--- a/lisp/bytecomp/byte-optimize.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1956 +0,0 @@ -;;; byte-opt.el --- the optimization passes of the emacs-lisp byte compiler. - -;;; Copyright (c) 1991, 1994 Free Software Foundation, Inc. - -;; Author: Jamie Zawinski <jwz@netscape.com> -;; Hallvard Furuseth <hbf@ulrik.uio.no> -;; Keywords: internal - -;; 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. - -;;; Commentary: - -;;; ======================================================================== -;;; "No matter how hard you try, you can't make a racehorse out of a pig. -;;; You can, however, make a faster pig." -;;; -;;; Or, to put it another way, the emacs byte compiler is a VW Bug. This code -;;; makes it be a VW Bug with fuel injection and a turbocharger... You're -;;; still not going to make it go faster than 70 mph, but it might be easier -;;; to get it there. -;;; - -;;; TO DO: -;;; -;;; (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 -;;; (let ( v1 v2 ... vM vN ) <...dynamically-safe...> ) ==> -;;; (let ( v1 v2 ... vM ) vN <...dynamically-safe...> ) -;;; by recursing on this, we might be able to eliminate the entire let. -;;; However certain variables should never have their bindings optimized -;;; away, because they affect everything. -;;; (put 'debug-on-error 'binding-is-magic t) -;;; (put 'debug-on-abort 'binding-is-magic t) -;;; (put 'debug-on-next-call 'binding-is-magic t) -;;; (put 'mocklisp-arguments 'binding-is-magic t) -;;; (put 'inhibit-quit 'binding-is-magic t) -;;; (put 'quit-flag 'binding-is-magic t) -;;; (put 't 'binding-is-magic t) -;;; (put 'nil 'binding-is-magic t) -;;; possibly also -;;; (put 'gc-cons-threshold 'binding-is-magic t) -;;; (put 'track-mouse 'binding-is-magic t) -;;; others? -;;; -;;; Simple defsubsts often produce forms like -;;; (let ((v1 (f1)) (v2 (f2)) ...) -;;; (FN v1 v2 ...)) -;;; It would be nice if we could optimize this to -;;; (FN (f1) (f2) ...) -;;; but we can't unless FN is dynamically-safe (it might be dynamically -;;; referring to the bindings that the lambda arglist established.) -;;; One of the uncountable lossages introduced by dynamic scope... -;;; -;;; Maybe there should be a control-structure that says "turn on -;;; fast-and-loose type-assumptive optimizations here." Then when -;;; we see a form like (car foo) we can from then on assume that -;;; the variable foo is of type cons, and optimize based on that. -;;; But, this won't win much because of (you guessed it) dynamic -;;; scope. Anything down the stack could change the value. -;;; (Another reason it doesn't work is that it is perfectly valid -;;; to call car with a null argument.) A better approach might -;;; be to allow type-specification of the form -;;; (put 'foo 'arg-types '(float (list integer) dynamic)) -;;; (put 'foo 'result-type 'bool) -;;; It should be possible to have these types checked to a certain -;;; degree. -;;; -;;; collapse common subexpressions -;;; -;;; It would be nice if redundant sequences could be factored out as well, -;;; when they are known to have no side-effects: -;;; (list (+ a b c) (+ a b c)) --> a b add c add dup list-2 -;;; but beware of traps like -;;; (cons (list x y) (list x y)) -;;; -;;; Tail-recursion elimination is not really possible in Emacs Lisp. -;;; Tail-recursion elimination is almost always impossible when all variables -;;; have dynamic scope, but given that the "return" byteop requires the -;;; binding stack to be empty (rather than emptying it itself), there can be -;;; no truly tail-recursive Emacs Lisp functions that take any arguments or -;;; make any bindings. -;;; -;;; Here is an example of an Emacs Lisp function which could safely be -;;; byte-compiled tail-recursively: -;;; -;;; (defun tail-map (fn list) -;;; (cond (list -;;; (funcall fn (car list)) -;;; (tail-map fn (cdr list))))) -;;; -;;; However, if there was even a single let-binding around the COND, -;;; it could not be byte-compiled, because there would be an "unbind" -;;; byte-op between the final "call" and "return." Adding a -;;; Bunbind_all byteop would fix this. -;;; -;;; (defun foo (x y z) ... (foo a b c)) -;;; ... (const foo) (varref a) (varref b) (varref c) (call 3) END: (return) -;;; ... (varref a) (varbind x) (varref b) (varbind y) (varref c) (varbind z) (goto 0) END: (unbind-all) (return) -;;; ... (varref a) (varset x) (varref b) (varset y) (varref c) (varset z) (goto 0) END: (return) -;;; -;;; this also can be considered tail recursion: -;;; -;;; ... (const foo) (varref a) (call 1) (goto X) ... X: (return) -;;; could generalize this by doing the optimization -;;; (goto X) ... X: (return) --> (return) -;;; -;;; But this doesn't solve all of the problems: although by doing tail- -;;; recursion elimination in this way, the call-stack does not grow, the -;;; binding-stack would grow with each recursive step, and would eventually -;;; overflow. I don't believe there is any way around this without lexical -;;; scope. -;;; -;;; Wouldn't it be nice if Emacs Lisp had lexical scope. -;;; -;;; Idea: the form (lexical-scope) in a file means that the file may be -;;; compiled lexically. This proclamation is file-local. Then, within -;;; that file, "let" would establish lexical bindings, and "let-dynamic" -;;; would do things the old way. (Or we could use CL "declare" forms.) -;;; We'd have to notice defvars and defconsts, since those variables should -;;; always be dynamic, and attempting to do a lexical binding of them -;;; should simply do a dynamic binding instead. -;;; But! We need to know about variables that were not necessarily defvarred -;;; in the file being compiled (doing a boundp check isn't good enough.) -;;; Fdefvar() would have to be modified to add something to the plist. -;;; -;;; A major disadvantage of this scheme is that the interpreter and compiler -;;; would have different semantics for files compiled with (dynamic-scope). -;;; Since this would be a file-local optimization, there would be no way to -;;; modify the interpreter to obey this (unless the loader was hacked -;;; in some grody way, but that's a really bad idea.) -;;; -;;; HA! HA! HA! RMS removed the following paragraph from his version of -;;; byte-opt.el, proving once again his stubborn refusal to accept any -;;; developments in computer science that occurred after the late 1970's. -;;; -;;; Really the Right Thing is to make lexical scope the default across -;;; the board, in the interpreter and compiler, and just FIX all of -;;; the code that relies on dynamic scope of non-defvarred variables. - -;; Other things to consider: - -;;;;; Associative math should recognize subcalls to identical function: -;;;(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)))) -;;;;; 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)))) -;;;;; When -;;;;; - all but one arguments to a function are constant -;;;;; - the non-constant argument is an if-expression (cond-expression?) -;;;;; then the outer function can be distributed. If the guarding -;;;;; condition is side-effect-free [assignment-free] then the other -;;;;; 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)))) - -;;;;; (car (cons A B)) -> (progn B A) -;;;(disassemble (lambda (x) (car (cons (foo) 42)))) - -;;;;; (cdr (cons A B)) -> (progn A B) -;;;(disassemble (lambda (x) (cdr (cons 42 (foo))))) - -;;;;; (car (list A B ...)) -> (progn B ... A) -;;;(disassemble (lambda (x) (car (list (foo) 42 (bar))))) - -;;;;; (cdr (list A B ...)) -> (progn A (list B ...)) -;;;(disassemble (lambda (x) (cdr (list 42 (foo) (bar))))) - - -;;; Code: - -(require 'byte-compile "bytecomp") - -(defun byte-compile-log-lap-1 (format &rest args) - (if (aref byte-code-vector 0) - (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))))) - -(defmacro byte-compile-log-lap (format-string &rest args) - (list 'and - '(memq byte-optimize-log '(t byte)) - (cons 'byte-compile-log-lap-1 - (cons format-string args)))) - - -;;; byte-compile optimizers to support inlining - -(put 'inline 'byte-optimizer 'byte-optimize-inline-handler) - -(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)))) - - -;; Splice the given lap code into the current instruction stream. -;; If it has any labels in it, you're responsible for making sure there -;; are no collisions, and that byte-compile-tag-number is reasonable -;; after this is spliced in. The provided list is destroyed. -(defun byte-inline-lapcode (lap) - (setq byte-compile-output (nconc (nreverse lap) byte-compile-output))) - - -(defun byte-compile-inline-expand (form) - (let* ((name (car form)) - (fn (or (cdr (assq name byte-compile-function-environment)) - (and (fboundp name) (symbol-function name))))) - (if (null fn) - (progn - (byte-compile-warn "attempt to inline %s before it was defined" name) - form) - ;; else - (if (and (consp fn) (eq (car fn) 'autoload)) - (progn - (load (nth 1 fn)) - (setq fn (or (cdr (assq name byte-compile-function-environment)) - (and (fboundp name) (symbol-function name)))))) - (if (and (consp fn) (eq (car fn) 'autoload)) - (error "file \"%s\" didn't define \"%s\"" (nth 1 fn) name)) - (if (symbolp fn) - (byte-compile-inline-expand (cons fn (cdr form))) - (if (compiled-function-p fn) - (progn - (fetch-bytecode fn) - (cons (list 'lambda (compiled-function-arglist fn) - (list 'byte-code - (compiled-function-instructions fn) - (compiled-function-constants fn) - (compiled-function-stack-depth fn))) - (cdr form))) - (if (not (eq (car fn) 'lambda)) (error "%s is not a lambda" name)) - (cons fn (cdr form))))))) - -;;; ((lambda ...) ...) -;;; -(defun byte-compile-unfold-lambda (form &optional name) - (or name (setq name "anonymous lambda")) - (let ((lambda (car form)) - (values (cdr form))) - (if (compiled-function-p lambda) - (setq lambda (list 'lambda (compiled-function-arglist lambda) - (list 'byte-code - (compiled-function-instructions lambda) - (compiled-function-constants lambda) - (compiled-function-stack-depth lambda))))) - (let ((arglist (nth 1 lambda)) - (body (cdr (cdr lambda))) - optionalp restp - bindings) - (if (and (stringp (car body)) (cdr body)) - (setq body (cdr body))) - (if (and (consp (car body)) (eq 'interactive (car (car body)))) - (setq body (cdr body))) - (while arglist - (cond ((eq (car arglist) '&optional) - ;; ok, I'll let this slide because funcall_lambda() does... - ;; (if optionalp (error "multiple &optional keywords in %s" name)) - (if restp (error "&optional found after &rest in %s" name)) - (if (null (cdr arglist)) - (error "nothing after &optional in %s" name)) - (setq optionalp t)) - ((eq (car arglist) '&rest) - ;; ...but it is by no stretch of the imagination a reasonable - ;; thing that funcall_lambda() allows (&rest x y) and - ;; (&rest x &optional y) in arglists. - (if (null (cdr arglist)) - (error "nothing after &rest in %s" name)) - (if (cdr (cdr arglist)) - (error "multiple vars after &rest in %s" name)) - (setq restp t)) - (restp - (setq bindings (cons (list (car arglist) - (and values (cons 'list values))) - bindings) - values nil)) - ((and (not optionalp) (null values)) - (byte-compile-warn "attempt to open-code %s with too few arguments" name) - (setq arglist nil values 'too-few)) - (t - (setq bindings (cons (list (car arglist) (car values)) - bindings) - values (cdr values)))) - (setq arglist (cdr arglist))) - (if values - (progn - (or (eq values 'too-few) - (byte-compile-warn - "attempt to open-code %s with too many arguments" name)) - form) - (let ((newform - (if bindings - (cons 'let (cons (nreverse bindings) body)) - (cons 'progn body)))) - (byte-compile-log " %s\t==>\t%s" form newform) - newform))))) - - -;;; implementing source-level optimizers - -(defun byte-optimize-form-code-walker (form for-effect) - ;; - ;; For normal function calls, We can just mapcar the optimizer the cdr. But - ;; we need to have special knowledge of the syntax of the special forms - ;; like let and defun (that's why they're special forms :-). (Actually, - ;; the important aspect is that they are subrs that don't evaluate all of - ;; their args.) - ;; - (let ((fn (car-safe form)) - tmp) - (cond ((not (consp form)) - (if (not (and for-effect - (or byte-compile-delete-errors - (not (symbolp form)) - (eq form t)))) - form)) - ((eq fn 'quote) - (if (cdr (cdr form)) - (byte-compile-warn "malformed quote form: %s" - (prin1-to-string form))) - ;; map (quote nil) to nil to simplify optimizer logic. - ;; map quoted constants to nil if for-effect (just because). - (and (nth 1 form) - (not for-effect) - form)) - ((or (compiled-function-p fn) - (eq 'lambda (car-safe fn))) - (byte-compile-unfold-lambda form)) - ((memq fn '(let let*)) - ;; recursively enter the optimizer for the bindings and body - ;; of a let or let*. This for depth-firstness: forms that - ;; 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)) - (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)))) - ((eq fn 'progn) - ;; as an extra added bonus, this simplifies (progn <x>) --> <x> - (if (cdr (cdr form)) - (progn - (setq tmp (byte-optimize-body (cdr form) for-effect)) - (if (cdr tmp) (cons 'progn tmp) (car tmp))) - (byte-optimize-form (nth 1 form) for-effect))) - ((eq fn 'prog1) - (if (cdr (cdr form)) - (cons 'prog1 - (cons (byte-optimize-form (nth 1 form) for-effect) - (byte-optimize-body (cdr (cdr form)) t))) - (byte-optimize-form (nth 1 form) for-effect))) - ((eq fn 'prog2) - (cons 'prog2 - (cons (byte-optimize-form (nth 1 form) t) - (cons (byte-optimize-form (nth 2 form) for-effect) - (byte-optimize-body (cdr (cdr (cdr form))) t))))) - - ((memq fn '(save-excursion save-restriction save-current-buffer)) - ;; those subrs which have an implicit progn; it's not quite good - ;; enough to treat these like normal function calls. - ;; This can turn (save-excursion ...) into (save-excursion) which - ;; will be optimized away in the lap-optimize pass. - (cons fn (byte-optimize-body (cdr form) for-effect))) - - ((eq fn 'with-output-to-temp-buffer) - ;; this is just like the above, except for the first argument. - (cons fn - (cons - (byte-optimize-form (nth 1 form) nil) - (byte-optimize-body (cdr (cdr form)) for-effect)))) - - ((eq fn 'if) - (cons fn - (cons (byte-optimize-form (nth 1 form) nil) - (cons - (byte-optimize-form (nth 2 form) for-effect) - (byte-optimize-body (nthcdr 3 form) for-effect))))) - - ((memq fn '(and or)) ; remember, and/or are control structures. - ;; take forms off the back until we can't any more. - ;; In the future it could conceivably be a problem that the - ;; subexpressions of these forms are optimized in the reverse - ;; order, but it's ok for now. - (if for-effect - (let ((backwards (reverse (cdr form)))) - (while (and backwards - (null (setcar backwards - (byte-optimize-form (car backwards) - for-effect)))) - (setq backwards (cdr backwards))) - (if (and (cdr form) (null backwards)) - (byte-compile-log - " all subforms of %s called for effect; deleted" form)) - (and backwards - (cons fn (nreverse backwards)))) - (cons fn (mapcar 'byte-optimize-form (cdr form))))) - - ((eq fn 'interactive) - (byte-compile-warn "misplaced interactive spec: %s" - (prin1-to-string form)) - nil) - - ((memq fn '(defun defmacro function - condition-case save-window-excursion)) - ;; These forms are compiled as constants or by breaking out - ;; all the subexpressions and compiling them separately. - form) - - ((eq fn 'unwind-protect) - ;; the "protected" part of an unwind-protect is compiled (and thus - ;; optimized) as a top-level form, so don't do it here. But the - ;; non-protected part has the same for-effect status as the - ;; unwind-protect itself. (The protected part is always for effect, - ;; but that isn't handled properly yet.) - (cons fn - (cons (byte-optimize-form (nth 1 form) for-effect) - (cdr (cdr form))))) - - ((eq fn 'catch) - ;; the body of a catch is compiled (and thus optimized) as a - ;; top-level form, so don't do it here. The tag is never - ;; for-effect. The body should have the same for-effect status - ;; as the catch form itself, but that isn't handled properly yet. - (cons fn - (cons (byte-optimize-form (nth 1 form) nil) - (cdr (cdr form))))) - - ;; If optimization is on, this is the only place that macros are - ;; expanded. If optimization is off, then macroexpansion happens - ;; in byte-compile-form. Otherwise, the macros are already expanded - ;; by the time that is reached. - ((not (eq form - (setq form (macroexpand form - byte-compile-macro-environment)))) - (byte-optimize-form form for-effect)) - - ((not (symbolp fn)) - (or (eq 'mocklisp (car-safe fn)) ; ha! - (byte-compile-warn "%s is a malformed function" - (prin1-to-string fn))) - form) - - ((and for-effect (setq tmp (get fn 'side-effect-free)) - (or byte-compile-delete-errors - (eq tmp 'error-free) - (progn - (byte-compile-warn "%s called for effect" - (prin1-to-string form)) - nil))) - (byte-compile-log " %s called for effect; deleted" fn) - ;; appending a nil here might not be necessary, but it can't hurt. - (byte-optimize-form - (cons 'progn (append (cdr form) '(nil))) t)) - - (t - ;; Otherwise, no args can be considered to be for-effect, - ;; even if the called function is for-effect, because we - ;; don't know anything about that function. - (cons fn (mapcar 'byte-optimize-form (cdr form))))))) - - -(defun byte-optimize-form (form &optional for-effect) - "The source-level pass of the optimizer." - ;; - ;; 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 - ;; 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. - ;; - (let (opt new) - (if (and (consp form) - (symbolp (car form)) - (or (and for-effect - ;; we don't have any of these yet, but we might. - (setq opt (get (car form) 'byte-for-effect-optimizer))) - (setq opt (get (car form) 'byte-optimizer))) - (not (eq form (setq new (funcall opt form))))) - (progn -;; (if (equal form new) (error "bogus optimizer -- %s" opt)) - (byte-compile-log " %s\t==>\t%s" form new) - (setq new (byte-optimize-form new for-effect)) - new) - form))) - - -(defun byte-optimize-body (forms all-for-effect) - ;; optimize the cdr of a progn or implicit progn; all 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. - (let ((rest forms) - (result nil) - fe new) - (while rest - (setq fe (or all-for-effect (cdr rest))) - (setq new (and (car rest) (byte-optimize-form (car rest) fe))) - (if (or new (not fe)) - (setq result (cons new result))) - (setq rest (cdr rest))) - (nreverse result))) - - -;;; some source-level optimizers -;;; -;;; when writing optimizers, be VERY careful that the optimizer returns -;;; something not EQ to its argument if and ONLY if it has made a change. -;;; This implies that you cannot simply destructively modify the list; -;;; you must return something not EQ to it if you make an optimization. -;;; -;;; It is now safe to optimize code such that it introduces new bindings. - -;; 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))))) - -;; If the function is being called with constant numeric args, -;; evaluate as much as possible at compile-time. This optimizer -;; assumes that the function is associative, like + or *. -(defun byte-optimize-associative-math (form) - (let ((args nil) - (constants nil) - (rest (cdr form))) - (while rest - (if (numberp (car rest)) - (setq constants (cons (car rest) constants)) - (setq args (cons (car rest) args))) - (setq rest (cdr rest))) - (if (cdr constants) - (if args - (list (car form) - (apply (car form) constants) - (if (cdr args) - (cons (car form) (nreverse args)) - (car args))) - (apply (car form) constants)) - form))) - -;; If the function is being called with constant numeric args, -;; evaluate as much as possible at compile-time. This optimizer -;; assumes that the function satisfies -;; (op x1 x2 ... xn) == (op ...(op (op x1 x2) x3) ...xn) -;; like - and /. -(defun byte-optimize-nonassociative-math (form) - (if (or (not (numberp (car (cdr form)))) - (not (numberp (car (cdr (cdr form)))))) - form - (let ((constant (car (cdr form))) - (rest (cdr (cdr form)))) - (while (numberp (car rest)) - (setq constant (funcall (car form) constant (car rest)) - rest (cdr rest))) - (if rest - (cons (car form) (cons constant rest)) - constant)))) - -;;(defun byte-optimize-associative-two-args-math (form) -;; (setq form (byte-optimize-associative-math form)) -;; (if (consp form) -;; (byte-optimize-two-args-left form) -;; form)) - -;;(defun byte-optimize-nonassociative-two-args-math (form) -;; (setq form (byte-optimize-nonassociative-math form)) -;; (if (consp form) -;; (byte-optimize-two-args-right form) -;; form)) - -;; jwz: (byte-optimize-approx-equal 0.0 0.0) was returning nil -;; in xemacs 19.15 because it used < instead of <=. -(defun byte-optimize-approx-equal (x y) - (<= (* (abs (- x y)) 100) (abs (+ x y)))) - -;; Collect all the constants from FORM, after the STARTth arg, -;; and apply FUN to them to make one argument at the end. -;; For functions that can handle floats, that optimization -;; can be incorrect because reordering can cause an overflow -;; that would otherwise be avoided by encountering an arg that is a float. -;; We avoid this problem by (1) not moving float constants and -;; (2) not moving anything if it would cause an overflow. -(defun byte-optimize-delay-constants-math (form start fun) - ;; Merge all FORM's constants from number START, call FUN on them - ;; and put the result at the end. - (let ((rest (nthcdr (1- start) form)) - (orig form) - ;; t means we must check for overflow. - (overflow (memq fun '(+ *)))) - (while (cdr (setq rest (cdr rest))) - (if (integerp (car rest)) - (let (constants) - (setq form (copy-sequence form) - rest (nthcdr (1- start) form)) - (while (setq rest (cdr rest)) - (cond ((integerp (car rest)) - (setq constants (cons (car rest) constants)) - (setcar rest nil)))) - ;; If necessary, check now for overflow - ;; that might be caused by reordering. - (if (and overflow - ;; We have overflow if the result of doing the arithmetic - ;; on floats is not even close to the result - ;; of doing it on integers. - (not (byte-optimize-approx-equal - (apply fun (mapcar 'float constants)) - (float (apply fun constants))))) - (setq form orig) - (setq form (nconc (delq nil form) - (list (apply fun (nreverse constants))))))))) - form)) - -(defun byte-optimize-plus (form) - (setq form (byte-optimize-delay-constants-math form 1 '+)) - (if (memq 0 form) (setq form (delq 0 (copy-sequence form)))) - ;;(setq form (byte-optimize-associative-two-args-math form)) - (cond ((null (cdr form)) - (condition-case () - (eval form) - (error form))) - - ;; `add1' and `sub1' are a marginally fewer instructions - ;; than `plus' and `minus', so use them when possible. - ((and (null (nthcdr 3 form)) - (eq (nth 2 form) 1)) - (list '1+ (nth 1 form))) ; (+ x 1) --> (1+ x) - ((and (null (nthcdr 3 form)) - (eq (nth 1 form) 1)) - (list '1+ (nth 2 form))) ; (+ 1 x) --> (1+ x) - ((and (null (nthcdr 3 form)) - (eq (nth 2 form) -1)) - (list '1- (nth 1 form))) ; (+ x -1) --> (1- x) - ((and (null (nthcdr 3 form)) - (eq (nth 1 form) -1)) - (list '1- (nth 2 form))) ; (+ -1 x) --> (1- x) - -;;; It is not safe to delete the function entirely -;;; (actually, it would be safe if we know the sole arg -;;; is not a marker). -;; ((null (cdr (cdr form))) (nth 1 form)) - (t form))) - -(defun byte-optimize-minus (form) - ;; Put constants at the end, except the last constant. - (setq form (byte-optimize-delay-constants-math form 2 '+)) - ;; Now only first and last element can be a number. - (let ((last (car (reverse (nthcdr 3 form))))) - (cond ((eq 0 last) - ;; (- x y ... 0) --> (- x y ...) - (setq form (copy-sequence form)) - (setcdr (cdr (cdr form)) (delq 0 (nthcdr 3 form)))) - ;; If form is (- CONST foo... CONST), merge first and last. - ((and (numberp (nth 1 form)) - (numberp last)) - (setq form (nconc (list '- (- (nth 1 form) last) (nth 2 form)) - (delq last (copy-sequence (nthcdr 3 form)))))))) - (setq form -;;; It is not safe to delete the function entirely -;;; (actually, it would be safe if we know the sole arg -;;; is not a marker). -;;; (if (eq (nth 2 form) 0) -;;; (nth 1 form) ; (- x 0) --> x - (byte-optimize-predicate - (if (and (null (cdr (cdr (cdr form)))) - (eq (nth 1 form) 0)) ; (- 0 x) --> (- x) - (cons (car form) (cdr (cdr form))) - form)) -;;; ) - ) - - ;; `add1' and `sub1' are a marginally fewer instructions than `plus' - ;; and `minus', so use them when possible. - (cond ((and (null (nthcdr 3 form)) - (eq (nth 2 form) 1)) - (list '1- (nth 1 form))) ; (- x 1) --> (1- x) - ((and (null (nthcdr 3 form)) - (eq (nth 2 form) -1)) - (list '1+ (nth 1 form))) ; (- x -1) --> (1+ x) - (t - form)) - ) - -(defun byte-optimize-multiply (form) - (setq form (byte-optimize-delay-constants-math form 1 '*)) - ;; If there is a constant in FORM, it is now the last element. - (cond ((null (cdr form)) 1) -;;; It is not safe to delete the function entirely -;;; (actually, it would be safe if we know the sole arg -;;; is not a marker or if it appears in other arithmetic). -;;; ((null (cdr (cdr form))) (nth 1 form)) - ((let ((last (car (reverse form)))) - (cond ((eq 0 last) (cons 'progn (cdr form))) - ((eq 1 last) (delq 1 (copy-sequence form))) - ((eq -1 last) (list '- (delq -1 (copy-sequence form)))) - ((and (eq 2 last) - (memq t (mapcar 'symbolp (cdr form)))) - (prog1 (setq form (delq 2 (copy-sequence form))) - (while (not (symbolp (car (setq form (cdr form)))))) - (setcar form (list '+ (car form) (car form))))) - (form)))))) - -(defsubst byte-compile-butlast (form) - (nreverse (cdr (reverse form)))) - -(defun byte-optimize-divide (form) - (setq form (byte-optimize-delay-constants-math form 2 '*)) - (let ((last (car (reverse (cdr (cdr form)))))) - (if (numberp last) - (cond ((= (length form) 3) - (if (and (numberp (nth 1 form)) - (not (zerop last)) - (condition-case nil - (/ (nth 1 form) last) - (error nil))) - (setq form (list 'progn (/ (nth 1 form) last))))) - ((= last 1) - (setq form (byte-compile-butlast form))) - ((numberp (nth 1 form)) - (setq form (cons (car form) - (cons (/ (nth 1 form) last) - (byte-compile-butlast (cdr (cdr form))))) - last nil)))) - (cond -;;; ((null (cdr (cdr form))) -;;; (nth 1 form)) - ((eq (nth 1 form) 0) - (append '(progn) (cdr (cdr form)) '(0))) - ((eq last -1) - (list '- (if (nthcdr 3 form) - (byte-compile-butlast form) - (nth 1 form)))) - (form)))) - -(defun byte-optimize-logmumble (form) - (setq form (byte-optimize-delay-constants-math form 1 (car form))) - (byte-optimize-predicate - (cond ((memq 0 form) - (setq form (if (eq (car form) 'logand) - (cons 'progn (cdr form)) - (delq 0 (copy-sequence form))))) - ((and (eq (car-safe form) 'logior) - (memq -1 form)) - (cons 'progn (cdr form))) - (form)))) - - -(defun byte-optimize-binary-predicate (form) - (if (byte-compile-constp (nth 1 form)) - (if (byte-compile-constp (nth 2 form)) - (condition-case () - (list 'quote (eval form)) - (error form)) - ;; This can enable some lapcode optimizations. - (list (car form) (nth 2 form) (nth 1 form))) - form)) - -(defun byte-optimize-predicate (form) - (let ((ok t) - (rest (cdr form))) - (while (and rest ok) - (setq ok (byte-compile-constp (car rest)) - rest (cdr rest))) - (if ok - (condition-case () - (list 'quote (eval form)) - (error form)) - form))) - -(defun byte-optimize-identity (form) - (if (and (cdr form) (null (cdr (cdr form)))) - (nth 1 form) - (byte-compile-warn "identity called with %d arg%s, but requires 1" - (length (cdr form)) - (if (= 1 (length (cdr form))) "" "s")) - form)) - -(put 'identity 'byte-optimizer 'byte-optimize-identity) - -(put '+ 'byte-optimizer 'byte-optimize-plus) -(put '* 'byte-optimizer 'byte-optimize-multiply) -(put '- 'byte-optimizer 'byte-optimize-minus) -(put '/ 'byte-optimizer 'byte-optimize-divide) -(put 'max 'byte-optimizer 'byte-optimize-associative-math) -(put 'min 'byte-optimizer 'byte-optimize-associative-math) - -(put '= 'byte-optimizer 'byte-optimize-binary-predicate) -(put 'eq 'byte-optimizer 'byte-optimize-binary-predicate) -(put 'eql 'byte-optimizer 'byte-optimize-binary-predicate) -(put 'equal 'byte-optimizer 'byte-optimize-binary-predicate) -(put 'string= 'byte-optimizer 'byte-optimize-binary-predicate) -(put 'string-equal 'byte-optimizer 'byte-optimize-binary-predicate) - -(put '< 'byte-optimizer 'byte-optimize-predicate) -(put '> 'byte-optimizer 'byte-optimize-predicate) -(put '<= 'byte-optimizer 'byte-optimize-predicate) -(put '>= 'byte-optimizer 'byte-optimize-predicate) -(put '1+ 'byte-optimizer 'byte-optimize-predicate) -(put '1- 'byte-optimizer 'byte-optimize-predicate) -(put 'not 'byte-optimizer 'byte-optimize-predicate) -(put 'null 'byte-optimizer 'byte-optimize-predicate) -(put 'memq 'byte-optimizer 'byte-optimize-predicate) -(put 'consp 'byte-optimizer 'byte-optimize-predicate) -(put 'listp 'byte-optimizer 'byte-optimize-predicate) -(put 'symbolp 'byte-optimizer 'byte-optimize-predicate) -(put 'stringp 'byte-optimizer 'byte-optimize-predicate) -(put 'string< 'byte-optimizer 'byte-optimize-predicate) -(put 'string-lessp 'byte-optimizer 'byte-optimize-predicate) - -(put 'logand 'byte-optimizer 'byte-optimize-logmumble) -(put 'logior 'byte-optimizer 'byte-optimize-logmumble) -(put 'logxor 'byte-optimizer 'byte-optimize-logmumble) -(put 'lognot 'byte-optimizer 'byte-optimize-predicate) - -(put 'car 'byte-optimizer 'byte-optimize-predicate) -(put 'cdr 'byte-optimizer 'byte-optimize-predicate) -(put 'car-safe 'byte-optimizer 'byte-optimize-predicate) -(put 'cdr-safe 'byte-optimizer 'byte-optimize-predicate) - - -;; 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, -;; so arithmetic optimizers recognize the numeric constant. - Hallvard -(put 'quote 'byte-optimizer 'byte-optimize-quote) -(defun byte-optimize-quote (form) - (if (or (consp (nth 1 form)) - (and (symbolp (nth 1 form)) - ;; XEmacs addition: - (not (keywordp (nth 1 form))) - (not (memq (nth 1 form) '(nil t))))) - form - (nth 1 form))) - -(defun byte-optimize-zerop (form) - (cond ((numberp (nth 1 form)) - (eval form)) - (byte-compile-delete-errors - (list '= (nth 1 form) 0)) - (form))) - -(put 'zerop 'byte-optimizer 'byte-optimize-zerop) - -(defun byte-optimize-and (form) - ;; Simplify if less than 2 args. - ;; if there is a literal nil in the args to `and', throw it and following - ;; forms away, and surround the `and' with (progn ... nil). - (cond ((null (cdr form))) - ((memq nil form) - (list 'progn - (byte-optimize-and - (prog1 (setq form (copy-sequence form)) - (while (nth 1 form) - (setq form (cdr form))) - (setcdr form nil))) - nil)) - ((null (cdr (cdr form))) - (nth 1 form)) - ((byte-optimize-predicate form)))) - -(defun byte-optimize-or (form) - ;; Throw away nil's, and simplify if less than 2 args. - ;; If there is a literal non-nil constant in the args to `or', throw away all - ;; following forms. - (if (memq nil form) - (setq form (delq nil (copy-sequence form)))) - (let ((rest form)) - (while (cdr (setq rest (cdr rest))) - (if (byte-compile-trueconstp (car rest)) - (setq form (copy-sequence form) - rest (setcdr (memq (car rest) form) nil)))) - (if (cdr (cdr form)) - (byte-optimize-predicate form) - (nth 1 form)))) - -(defun byte-optimize-cond (form) - ;; if any clauses have a literal nil as their test, throw them away. - ;; if any clause has a literal non-nil constant as its test, throw - ;; away all following clauses. - (let (rest) - ;; This must be first, to reduce (cond (t ...) (nil)) to (progn t ...) - (while (setq rest (assq nil (cdr form))) - (setq form (delq rest (copy-sequence form)))) - (if (memq nil (cdr form)) - (setq form (delq nil (copy-sequence form)))) - (setq rest form) - (while (setq rest (cdr rest)) - (cond ((byte-compile-trueconstp (car-safe (car rest))) - (cond ((eq rest (cdr form)) - (setq form - (if (cdr (car rest)) - (if (cdr (cdr (car rest))) - (cons 'progn (cdr (car rest))) - (nth 1 (car rest))) - (car (car rest))))) - ((cdr rest) - (setq form (copy-sequence form)) - (setcdr (memq (car rest) form) nil))) - (setq rest nil))))) - ;; - ;; Turn (cond (( <x> )) ... ) into (or <x> (cond ... )) - (if (eq 'cond (car-safe form)) - (let ((clauses (cdr form))) - (if (and (consp (car clauses)) - (null (cdr (car clauses)))) - (list 'or (car (car clauses)) - (byte-optimize-cond - (cons (car form) (cdr (cdr form))))) - form)) - form)) - -(defun byte-optimize-if (form) - ;; (if <true-constant> <then> <else...>) ==> <then> - ;; (if <false-constant> <then> <else...>) ==> (progn <else...>) - ;; (if <test> nil <else...>) ==> (if (not <test>) (progn <else...>)) - ;; (if <test> <then> nil) ==> (if <test> <then>) - (let ((clause (nth 1 form))) - (cond ((byte-compile-trueconstp clause) - (nth 2 form)) - ((null clause) - (if (nthcdr 4 form) - (cons 'progn (nthcdr 3 form)) - (nth 3 form))) - ((nth 2 form) - (if (equal '(nil) (nthcdr 3 form)) - (list 'if clause (nth 2 form)) - form)) - ((or (nth 3 form) (nthcdr 4 form)) - (list 'if - ;; Don't make a double negative; - ;; instead, take away the one that is there. - (if (and (consp clause) (memq (car clause) '(not null)) - (= (length clause) 2)) ; (not xxxx) or (not (xxxx)) - (nth 1 clause) - (list 'not clause)) - (if (nthcdr 4 form) - (cons 'progn (nthcdr 3 form)) - (nth 3 form)))) - (t - (list 'progn clause nil))))) - -(defun byte-optimize-while (form) - (if (nth 1 form) - form)) - -(put 'and 'byte-optimizer 'byte-optimize-and) -(put 'or 'byte-optimizer 'byte-optimize-or) -(put 'cond 'byte-optimizer 'byte-optimize-cond) -(put 'if 'byte-optimizer 'byte-optimize-if) -(put 'while 'byte-optimizer 'byte-optimize-while) - -;; byte-compile-negation-optimizer lives in bytecomp.el -(put '/= 'byte-optimizer 'byte-compile-negation-optimizer) -(put 'atom 'byte-optimizer 'byte-compile-negation-optimizer) -(put 'nlistp 'byte-optimizer 'byte-compile-negation-optimizer) - - -(defun byte-optimize-funcall (form) - ;; (funcall '(lambda ...) ...) ==> ((lambda ...) ...) - ;; (funcall 'foo ...) ==> (foo ...) - (let ((fn (nth 1 form))) - (if (memq (car-safe fn) '(quote function)) - (cons (nth 1 fn) (cdr (cdr form))) - form))) - -(defun byte-optimize-apply (form) - ;; If the last arg is a literal constant, turn this into a funcall. - ;; The funcall optimizer can then transform (funcall 'foo ...) -> (foo ...). - (let ((fn (nth 1 form)) - (last (nth (1- (length form)) form))) ; I think this really is fastest - (or (if (or (null last) - (eq (car-safe last) 'quote)) - (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)))) - (byte-compile-warn - "last arg to apply can't be a literal atom: %s" - (prin1-to-string last)) - nil)) - form))) - -(put 'funcall 'byte-optimizer 'byte-optimize-funcall) -(put 'apply 'byte-optimizer 'byte-optimize-apply) - - -(put 'let 'byte-optimizer 'byte-optimize-letX) -(put 'let* 'byte-optimizer 'byte-optimize-letX) -(defun byte-optimize-letX (form) - (cond ((null (nth 1 form)) - ;; No bindings - (cons 'progn (cdr (cdr form)))) - ((or (nth 2 form) (nthcdr 3 form)) - form) - ;; The body is nil - ((eq (car form) 'let) - (append '(progn) (mapcar 'car-safe (mapcar 'cdr-safe (nth 1 form))) - '(nil))) - (t - (let ((binds (reverse (nth 1 form)))) - (list 'let* (reverse (cdr binds)) (nth 1 (car binds)) nil))))) - - -(put 'nth 'byte-optimizer 'byte-optimize-nth) -(defun byte-optimize-nth (form) - (if (and (= (safe-length form) 3) (memq (nth 1 form) '(0 1))) - (list 'car (if (zerop (nth 1 form)) - (nth 2 form) - (list 'cdr (nth 2 form)))) - (byte-optimize-predicate form))) - -(put 'nthcdr 'byte-optimizer 'byte-optimize-nthcdr) -(defun byte-optimize-nthcdr (form) - (if (and (= (safe-length form) 3) (not (memq (nth 1 form) '(0 1 2)))) - (byte-optimize-predicate form) - (let ((count (nth 1 form))) - (setq form (nth 2 form)) - (while (>= (setq count (1- count)) 0) - (setq form (list 'cdr form))) - form))) - -;;; enumerating those functions which need not be called if the returned -;;; value is not used. That is, something like -;;; (progn (list (something-with-side-effects) (yow)) -;;; (foo)) -;;; may safely be turned into -;;; (progn (progn (something-with-side-effects) (yow)) -;;; (foo)) -;;; Further optimizations will turn (progn (list 1 2 3) 'foo) into 'foo. - -;;; I wonder if I missed any :-\) -(let ((side-effect-free-fns - '(% * + - / /= 1+ 1- < <= = > >= abs acos append aref ash asin atan - assoc assq - boundp buffer-file-name buffer-local-variables buffer-modified-p - buffer-substring - capitalize car-less-than-car car cdr ceiling concat - ;; coordinates-in-window-p not in XEmacs - copy-marker cos count-lines - default-boundp default-value documentation downcase - elt exp expt fboundp featurep - file-directory-p file-exists-p file-locked-p file-name-absolute-p - 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 - int-to-string - length log log10 logand logb logior lognot logxor lsh - marker-buffer max member memq min mod - next-window nth nthcdr number-to-string - parse-colon-path previous-window - radians-to-degrees rassq regexp-quote reverse round - sin sqrt string< string= string-equal string-lessp string-to-char - string-to-int string-to-number substring symbol-plist - tan upcase user-variable-p vconcat - ;; 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)) - (side-effect-and-error-free-fns - '(arrayp atom - bobp bolp buffer-end buffer-list buffer-size buffer-string bufferp - car-safe case-table-p cdr-safe char-or-string-p char-table-p - characterp commandp cons - consolep console-live-p consp - current-buffer - ;; XEmacs: extent functions, frame-live-p, various other stuff - devicep device-live-p - dot dot-marker eobp eolp eq eql equal eventp extentp - extent-live-p floatp framep frame-live-p - get-largest-window get-lru-window - identity ignore integerp integer-or-marker-p interactive-p - invocation-directory invocation-name - ;; keymapp may autoload in XEmacs, so not on this list! - list listp - make-marker mark mark-marker markerp memory-limit minibuffer-window - ;; mouse-movement-p not in XEmacs - natnump nlistp not null number-or-marker-p numberp - one-window-p ;; overlayp not in XEmacs - point point-marker point-min point-max processp - range-table-p - selected-window sequencep stringp subrp symbolp syntax-table-p - 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) - - -(defun byte-compile-splice-in-already-compiled-code (form) - ;; form is (byte-code "..." [...] n) - (if (not (memq byte-optimize '(t lap))) - (byte-compile-normal-call form) - (byte-inline-lapcode - (byte-decompile-bytecode-1 (nth 1 form) (nth 2 form) t)) - (setq byte-compile-maxdepth (max (+ byte-compile-depth (nth 3 form)) - byte-compile-maxdepth)) - (setq byte-compile-depth (1+ byte-compile-depth)))) - -(put 'byte-code 'byte-compile 'byte-compile-splice-in-already-compiled-code) - - -(defconst byte-constref-ops - '(byte-constant byte-constant2 byte-varref byte-varset byte-varbind)) - -;;; This function extracts the bitfields from variable-length opcodes. -;;; Originally defined in disass.el (which no longer uses it.) - -(defun disassemble-offset () - "Don't call this!" - ;; fetch and return the offset for the current opcode. - ;; return NIL if this opcode has no offset - ;; OP, PTR and BYTES are used and set dynamically - (defvar op) - (defvar ptr) - (defvar bytes) - (cond ((< op byte-nth) - (let ((tem (logand op 7))) - (setq op (logand op 248)) - (cond ((eq tem 6) - (setq ptr (1+ ptr)) ;offset in next byte - ;; char-to-int to avoid downstream problems - ;; caused by chars appearing where ints are - ;; expected. In bytecode the bytes in the - ;; opcode string are always interpreted as ints. - (char-to-int (aref bytes ptr))) - ((eq tem 7) - (setq ptr (1+ ptr)) ;offset in next 2 bytes - (+ (aref bytes ptr) - (progn (setq ptr (1+ ptr)) - (lsh (aref bytes ptr) 8)))) - (t tem)))) ;offset was in opcode - ((>= op byte-constant) - (prog1 (- op byte-constant) ;offset in opcode - (setq op byte-constant))) - ((and (>= op byte-constant2) - (<= op byte-goto-if-not-nil-else-pop)) - (setq ptr (1+ ptr)) ;offset in next 2 bytes - (+ (aref bytes ptr) - (progn (setq ptr (1+ ptr)) - (lsh (aref bytes ptr) 8)))) - ;; XEmacs: this code was here before. FSF's first comparison - ;; is (>= op byte-listN). It appears that the rel-goto stuff - ;; does not exist in FSF 19.30. It doesn't exist in 19.28 - ;; either, so I'm going to assume that this is an improvement - ;; on our part and leave it in. --ben - ((and (>= op byte-rel-goto) - (<= op byte-insertN)) - (setq ptr (1+ ptr)) ;offset in next byte - ;; Use char-to-int to avoid downstream problems caused by - ;; chars appearing where ints are expected. In bytecode - ;; the bytes in the opcode string are always interpreted as - ;; ints. - (char-to-int (aref bytes ptr))))) - - -;;; This de-compiler is used for inline expansion of compiled functions, -;;; and by the disassembler. -;;; -;;; This list contains numbers, which are pc values, -;;; before each instruction. -(defun byte-decompile-bytecode (bytes constvec) - "Turns BYTECODE into lapcode, referring to CONSTVEC." - (let ((byte-compile-constants nil) - (byte-compile-variables nil) - (byte-compile-tag-number 0)) - (byte-decompile-bytecode-1 bytes constvec))) - -;; As byte-decompile-bytecode, but updates -;; byte-compile-{constants, variables, tag-number}. -;; If MAKE-SPLICEABLE is true, then `return' opcodes are replaced -;; with `goto's destined for the end of the code. -;; That is for use by the compiler. -;; If MAKE-SPLICEABLE is nil, we are being called for the disassembler. -;; In that case, we put a pc value into the list -;; before each insn (or its label). -(defun byte-decompile-bytecode-1 (bytes constvec &optional make-spliceable) - (let ((length (length bytes)) - (ptr 0) optr tags op offset - ;; tag unused - lap tmp - endtag - ;; (retcount 0) unused - ) - (while (not (= ptr length)) - (or make-spliceable - (setq lap (cons ptr lap))) - (setq op (aref bytes ptr) - optr ptr - offset (disassemble-offset)) ; this does dynamic-scope magic - (setq op (aref byte-code-vector op)) - ;; XEmacs: the next line in FSF 19.30 reads - ;; (cond ((memq op byte-goto-ops) - ;; see the comment above about byte-rel-goto in XEmacs. - (cond ((or (memq op byte-goto-ops) - (cond ((memq op byte-rel-goto-ops) - (setq op (aref byte-code-vector - (- (symbol-value op) - (- byte-rel-goto byte-goto)))) - (setq offset (+ ptr (- offset 127))) - t))) - ;; it's a pc - (setq offset - (cdr (or (assq offset tags) - (car (setq tags - (cons (cons offset - (byte-compile-make-tag)) - tags))))))) - ((cond ((eq op 'byte-constant2) (setq op 'byte-constant) t) - ((memq op byte-constref-ops))) - (setq tmp (aref constvec offset) - offset (if (eq op 'byte-constant) - (byte-compile-get-constant tmp) - (or (assq tmp byte-compile-variables) - (car (setq byte-compile-variables - (cons (list tmp) - byte-compile-variables))))))) - ((and make-spliceable - (eq op 'byte-return)) - (if (= ptr (1- length)) - (setq op nil) - (setq offset (or endtag (setq endtag (byte-compile-make-tag))) - op 'byte-goto)))) - ;; lap = ( [ (pc . (op . arg)) ]* ) - (setq lap (cons (cons optr (cons op (or offset 0))) - lap)) - (setq ptr (1+ ptr))) - ;; take off the dummy nil op that we replaced a trailing "return" with. - (let ((rest lap)) - (while rest - (cond ((numberp (car rest))) - ((setq tmp (assq (car (car rest)) tags)) - ;; this addr is jumped to - (setcdr rest (cons (cons nil (cdr tmp)) - (cdr rest))) - (setq tags (delq tmp tags)) - (setq rest (cdr rest)))) - (setq rest (cdr rest)))) - (if tags (error "optimizer error: missed tags %s" tags)) - (if (null (car (cdr (car lap)))) - (setq lap (cdr lap))) - (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)))) - (nreverse lap)))) - - -;;; peephole optimizer - -(defconst byte-tagref-ops (cons 'TAG byte-goto-ops)) - -(defconst byte-conditional-ops - '(byte-goto-if-nil byte-goto-if-not-nil byte-goto-if-nil-else-pop - byte-goto-if-not-nil-else-pop)) - -(defconst byte-after-unbind-ops - '(byte-constant byte-dup - byte-symbolp byte-consp byte-stringp byte-listp byte-numberp byte-integerp - byte-eq byte-equal byte-not - byte-cons byte-list1 byte-list2 ; byte-list3 byte-list4 - byte-interactive-p) - ;; How about other side-effect-free-ops? Is it safe to move an - ;; error invocation (such as from nth) out of an unwind-protect? - "Byte-codes that can be moved past an unbind.") - -(defconst byte-compile-side-effect-and-error-free-ops - '(byte-constant byte-dup byte-symbolp byte-consp byte-stringp byte-listp - byte-integerp byte-numberp byte-eq byte-equal byte-not byte-car-safe - byte-cdr-safe byte-cons byte-list1 byte-list2 byte-point byte-point-max - byte-point-min byte-following-char byte-preceding-char - byte-current-column byte-eolp byte-eobp byte-bolp byte-bobp - byte-current-buffer byte-interactive-p)) - -(defconst byte-compile-side-effect-free-ops - (nconc - '(byte-varref byte-nth byte-memq byte-car byte-cdr byte-length byte-aref - byte-symbol-value byte-get byte-concat2 byte-concat3 byte-sub1 byte-add1 - byte-eqlsign byte-gtr byte-lss byte-leq byte-geq byte-diff byte-negate - byte-plus byte-max byte-min byte-mult byte-char-after byte-char-syntax - byte-buffer-substring byte-string= byte-string< byte-nthcdr byte-elt - byte-member byte-assq byte-quo byte-rem) - byte-compile-side-effect-and-error-free-ops)) - -;;; This piece of shit is because of the way DEFVAR_BOOL() variables work. -;;; Consider the code -;;; -;;; (defun foo (flag) -;;; (let ((old-pop-ups pop-up-windows) -;;; (pop-up-windows flag)) -;;; (cond ((not (eq pop-up-windows old-pop-ups)) -;;; (setq old-pop-ups pop-up-windows) -;;; ...)))) -;;; -;;; Uncompiled, old-pop-ups will always be set to nil or t, even if FLAG is -;;; something else. But if we optimize -;;; -;;; varref flag -;;; varbind pop-up-windows -;;; varref pop-up-windows -;;; not -;;; to -;;; varref flag -;;; dup -;;; varbind pop-up-windows -;;; not -;;; -;;; we break the program, because it will appear that pop-up-windows and -;;; old-pop-ups are not EQ when really they are. So we have to know what -;;; the BOOL variables are, and not perform this optimization on them. -;;; -(defconst byte-boolean-vars - '(abbrev-all-caps purify-flag find-file-compare-truenames - find-file-use-truenames find-file-visit-truename - find-file-existing-other-name byte-metering-on - zmacs-regions zmacs-region-active-p zmacs-region-stays - atomic-extent-goto-char-p suppress-early-error-handler - noninteractive ignore-kernel debug-on-quit debug-on-next-call - modifier-keys-are-sticky x-allow-sendevents vms-stmlf-recfm - disable-auto-save-when-buffer-shrinks indent-tabs-mode - load-in-progress load-warn-when-source-newer load-warn-when-source-only - load-ignore-elc-files load-force-doc-strings - fail-on-bucky-bit-character-escapes popup-menu-titles - menubar-show-keybindings completion-ignore-case - canna-empty-info canna-through-info canna-underline - canna-inhibit-hankakukana x-handle-non-fully-specified-fonts - print-escape-newlines print-readably print-gensym - delete-exited-processes truncate-partial-width-windows - visible-bell no-redraw-on-reenter cursor-in-echo-area - inhibit-warning-display parse-sexp-ignore-comments words-include-escapes - scroll-on-clipped-lines pop-up-frames pop-up-windows) - "DEFVAR_BOOL variables. Giving these any non-nil value sets them to t. -If this does not enumerate all DEFVAR_BOOL variables, the byte-optimizer -may generate incorrect code.") - -(defun byte-optimize-lapcode (lap &optional for-effect) - "Simple peephole optimizer. LAP is both modified and returned." - (let (lap0 ;; off0 unused - lap1 ;; off1 - lap2 ;; off2 - (keep-going 'first-time) - (add-depth 0) - rest tmp tmp2 tmp3 - (side-effect-free (if byte-compile-delete-errors - byte-compile-side-effect-free-ops - byte-compile-side-effect-and-error-free-ops))) - (while keep-going - (or (eq keep-going 'first-time) - (byte-compile-log-lap " ---- next pass")) - (setq rest lap - keep-going nil) - (while rest - (setq lap0 (car rest) - lap1 (nth 1 rest) - lap2 (nth 2 rest)) - - ;; You may notice that sequences like "dup varset discard" are - ;; optimized but sequences like "dup varset TAG1: discard" are not. - ;; You may be tempted to change this; resist that temptation. - (cond ;; - ;; <side-effect-free> pop --> <deleted> - ;; ...including: - ;; const-X pop --> <deleted> - ;; varref-X pop --> <deleted> - ;; dup pop --> <deleted> - ;; - ((and (eq 'byte-discard (car lap1)) - (memq (car lap0) side-effect-free)) - (setq keep-going t) - (setq tmp (aref byte-stack+-info (symbol-value (car lap0)))) - (setq rest (cdr rest)) - (cond ((= tmp 1) - (byte-compile-log-lap - " %s discard\t-->\t<deleted>" lap0) - (setq lap (delq lap0 (delq lap1 lap)))) - ((= tmp 0) - (byte-compile-log-lap - " %s discard\t-->\t<deleted> discard" lap0) - (setq lap (delq lap0 lap))) - ((= tmp -1) - (byte-compile-log-lap - " %s discard\t-->\tdiscard discard" lap0) - (setcar lap0 'byte-discard) - (setcdr lap0 0)) - ((error "Optimizer error: too much on the stack")))) - ;; - ;; goto*-X X: --> X: - ;; - ((and (memq (car lap0) byte-goto-ops) - (eq (cdr lap0) lap1)) - (cond ((eq (car lap0) 'byte-goto) - (setq lap (delq lap0 lap)) - (setq tmp "<deleted>")) - ((memq (car lap0) byte-goto-always-pop-ops) - (setcar lap0 (setq tmp 'byte-discard)) - (setcdr lap0 0)) - ((error "Depth conflict at tag %d" (nth 2 lap0)))) - (and (memq byte-optimize-log '(t byte)) - (byte-compile-log " (goto %s) %s:\t-->\t%s %s:" - (nth 1 lap1) (nth 1 lap1) - tmp (nth 1 lap1))) - (setq keep-going t)) - ;; - ;; varset-X varref-X --> dup varset-X - ;; varbind-X varref-X --> dup varbind-X - ;; const/dup varset-X varref-X --> const/dup varset-X const/dup - ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup - ;; The latter two can enable other optimizations. - ;; - ((and (eq 'byte-varref (car lap2)) - (eq (cdr lap1) (cdr lap2)) - (memq (car lap1) '(byte-varset byte-varbind))) - (if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars)) - (not (eq (car lap0) 'byte-constant))) - nil - (setq keep-going t) - (if (memq (car lap0) '(byte-constant byte-dup)) - (progn - (setq tmp (if (or (not tmp) - (memq (car (cdr lap0)) '(nil t))) - (cdr lap0) - (byte-compile-get-constant t))) - (byte-compile-log-lap " %s %s %s\t-->\t%s %s %s" - lap0 lap1 lap2 lap0 lap1 - (cons (car lap0) tmp)) - (setcar lap2 (car lap0)) - (setcdr lap2 tmp)) - (byte-compile-log-lap " %s %s\t-->\tdup %s" lap1 lap2 lap1) - (setcar lap2 (car lap1)) - (setcar lap1 'byte-dup) - (setcdr lap1 0) - ;; The stack depth gets locally increased, so we will - ;; increase maxdepth in case depth = maxdepth here. - ;; This can cause the third argument to byte-code to - ;; be larger than necessary. - (setq add-depth 1)))) - ;; - ;; dup varset-X discard --> varset-X - ;; dup varbind-X discard --> varbind-X - ;; (the varbind variant can emerge from other optimizations) - ;; - ((and (eq 'byte-dup (car lap0)) - (eq 'byte-discard (car lap2)) - (memq (car lap1) '(byte-varset byte-varbind))) - (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1) - (setq keep-going t - rest (cdr rest)) - (setq lap (delq lap0 (delq lap2 lap)))) - ;; - ;; not goto-X-if-nil --> goto-X-if-non-nil - ;; not goto-X-if-non-nil --> goto-X-if-nil - ;; - ;; it is wrong to do the same thing for the -else-pop variants. - ;; - ((and (eq 'byte-not (car lap0)) - (or (eq 'byte-goto-if-nil (car lap1)) - (eq 'byte-goto-if-not-nil (car lap1)))) - (byte-compile-log-lap " not %s\t-->\t%s" - lap1 - (cons - (if (eq (car lap1) 'byte-goto-if-nil) - 'byte-goto-if-not-nil - 'byte-goto-if-nil) - (cdr lap1))) - (setcar lap1 (if (eq (car lap1) 'byte-goto-if-nil) - 'byte-goto-if-not-nil - 'byte-goto-if-nil)) - (setq lap (delq lap0 lap)) - (setq keep-going t)) - ;; - ;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X: - ;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X: - ;; - ;; it is wrong to do the same thing for the -else-pop variants. - ;; - ((and (or (eq 'byte-goto-if-nil (car lap0)) - (eq 'byte-goto-if-not-nil (car lap0))) ; gotoX - (eq 'byte-goto (car lap1)) ; gotoY - (eq (cdr lap0) lap2)) ; TAG X - (let ((inverse (if (eq 'byte-goto-if-nil (car lap0)) - 'byte-goto-if-not-nil 'byte-goto-if-nil))) - (byte-compile-log-lap " %s %s %s:\t-->\t%s %s:" - lap0 lap1 lap2 - (cons inverse (cdr lap1)) lap2) - (setq lap (delq lap0 lap)) - (setcar lap1 inverse) - (setq keep-going t))) - ;; - ;; const goto-if-* --> whatever - ;; - ((and (eq 'byte-constant (car lap0)) - (memq (car lap1) byte-conditional-ops)) - (cond ((if (or (eq (car lap1) 'byte-goto-if-nil) - (eq (car lap1) 'byte-goto-if-nil-else-pop)) - (car (cdr lap0)) - (not (car (cdr lap0)))) - (byte-compile-log-lap " %s %s\t-->\t<deleted>" - lap0 lap1) - (setq rest (cdr rest) - lap (delq lap0 (delq lap1 lap)))) - (t - (if (memq (car lap1) byte-goto-always-pop-ops) - (progn - (byte-compile-log-lap " %s %s\t-->\t%s" - lap0 lap1 (cons 'byte-goto (cdr lap1))) - (setq lap (delq lap0 lap))) - (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 - (cons 'byte-goto (cdr lap1)))) - (setcar lap1 'byte-goto))) - (setq keep-going t)) - ;; - ;; varref-X varref-X --> varref-X dup - ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup - ;; We don't optimize the const-X variations on this here, - ;; because that would inhibit some goto optimizations; we - ;; optimize the const-X case after all other optimizations. - ;; - ((and (eq 'byte-varref (car lap0)) - (progn - (setq tmp (cdr rest)) - (while (eq (car (car tmp)) 'byte-dup) - (setq tmp (cdr tmp))) - t) - (eq (cdr lap0) (cdr (car tmp))) - (eq 'byte-varref (car (car tmp)))) - (if (memq byte-optimize-log '(t byte)) - (let ((str "")) - (setq tmp2 (cdr rest)) - (while (not (eq tmp tmp2)) - (setq tmp2 (cdr tmp2) - str (concat str " dup"))) - (byte-compile-log-lap " %s%s %s\t-->\t%s%s dup" - lap0 str lap0 lap0 str))) - (setq keep-going t) - (setcar (car tmp) 'byte-dup) - (setcdr (car tmp) 0) - (setq rest tmp)) - ;; - ;; TAG1: TAG2: --> TAG1: <deleted> - ;; (and other references to TAG2 are replaced with TAG1) - ;; - ((and (eq (car lap0) 'TAG) - (eq (car lap1) 'TAG)) - (and (memq byte-optimize-log '(t byte)) - (byte-compile-log " adjacent tags %d and %d merged" - (nth 1 lap1) (nth 1 lap0))) - (setq tmp3 lap) - (while (setq tmp2 (rassq lap0 tmp3)) - (setcdr tmp2 lap1) - (setq tmp3 (cdr (memq tmp2 tmp3)))) - (setq lap (delq lap0 lap) - keep-going t)) - ;; - ;; unused-TAG: --> <deleted> - ;; - ((and (eq 'TAG (car lap0)) - (not (rassq lap0 lap))) - (and (memq byte-optimize-log '(t byte)) - (byte-compile-log " unused tag %d removed" (nth 1 lap0))) - (setq lap (delq lap0 lap) - keep-going t)) - ;; - ;; goto ... --> goto <delete until TAG or end> - ;; return ... --> return <delete until TAG or end> - ;; - ((and (memq (car lap0) '(byte-goto byte-return)) - (not (memq (car lap1) '(TAG nil)))) - (setq tmp rest) - (let ((i 0) - (opt-p (memq byte-optimize-log '(t lap))) - str deleted) - (while (and (setq tmp (cdr tmp)) - (not (eq 'TAG (car (car tmp))))) - (if opt-p (setq deleted (cons (car tmp) deleted) - str (concat str " %s") - i (1+ i)))) - (if opt-p - (let ((tagstr - (if (eq 'TAG (car (car tmp))) - (format "%d:" (car (cdr (car tmp)))) - (or (car tmp) "")))) - (if (< i 6) - (apply 'byte-compile-log-lap-1 - (concat " %s" str - " %s\t-->\t%s <deleted> %s") - lap0 - (nconc (nreverse deleted) - (list tagstr lap0 tagstr))) - (byte-compile-log-lap - " %s <%d unreachable op%s> %s\t-->\t%s <deleted> %s" - lap0 i (if (= i 1) "" "s") - tagstr lap0 tagstr)))) - (rplacd rest tmp)) - (setq keep-going t)) - ;; - ;; <safe-op> unbind --> unbind <safe-op> - ;; (this may enable other optimizations.) - ;; - ((and (eq 'byte-unbind (car lap1)) - (memq (car lap0) byte-after-unbind-ops)) - (byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0) - (setcar rest lap1) - (setcar (cdr rest) lap0) - (setq keep-going t)) - ;; - ;; varbind-X unbind-N --> discard unbind-(N-1) - ;; save-excursion unbind-N --> unbind-(N-1) - ;; save-restriction unbind-N --> unbind-(N-1) - ;; - ((and (eq 'byte-unbind (car lap1)) - (memq (car lap0) '(byte-varbind byte-save-excursion - byte-save-restriction)) - (< 0 (cdr lap1))) - (if (zerop (setcdr lap1 (1- (cdr lap1)))) - (delq lap1 rest)) - (if (eq (car lap0) 'byte-varbind) - (setcar rest (cons 'byte-discard 0)) - (setq lap (delq lap0 lap))) - (byte-compile-log-lap " %s %s\t-->\t%s %s" - lap0 (cons (car lap1) (1+ (cdr lap1))) - (if (eq (car lap0) 'byte-varbind) - (car rest) - (car (cdr rest))) - (if (and (/= 0 (cdr lap1)) - (eq (car lap0) 'byte-varbind)) - (car (cdr rest)) - "")) - (setq keep-going t)) - ;; - ;; goto*-X ... X: goto-Y --> goto*-Y - ;; goto-X ... X: return --> return - ;; - ((and (memq (car lap0) byte-goto-ops) - (memq (car (setq tmp (nth 1 (memq (cdr lap0) lap)))) - '(byte-goto byte-return))) - (cond ((and (not (eq tmp lap0)) - (or (eq (car lap0) 'byte-goto) - (eq (car tmp) 'byte-goto))) - (byte-compile-log-lap " %s [%s]\t-->\t%s" - (car lap0) tmp tmp) - (if (eq (car tmp) 'byte-return) - (setcar lap0 'byte-return)) - (setcdr lap0 (cdr tmp)) - (setq keep-going t)))) - ;; - ;; goto-*-else-pop X ... X: goto-if-* --> whatever - ;; goto-*-else-pop X ... X: discard --> whatever - ;; - ((and (memq (car lap0) '(byte-goto-if-nil-else-pop - byte-goto-if-not-nil-else-pop)) - (memq (car (car (setq tmp (cdr (memq (cdr lap0) lap))))) - (eval-when-compile - (cons 'byte-discard byte-conditional-ops))) - (not (eq lap0 (car tmp)))) - (setq tmp2 (car tmp)) - (setq tmp3 (assq (car lap0) '((byte-goto-if-nil-else-pop - byte-goto-if-nil) - (byte-goto-if-not-nil-else-pop - byte-goto-if-not-nil)))) - (if (memq (car tmp2) tmp3) - (progn (setcar lap0 (car tmp2)) - (setcdr lap0 (cdr tmp2)) - (byte-compile-log-lap " %s-else-pop [%s]\t-->\t%s" - (car lap0) tmp2 lap0)) - ;; Get rid of the -else-pop's and jump one step further. - (or (eq 'TAG (car (nth 1 tmp))) - (setcdr tmp (cons (byte-compile-make-tag) - (cdr tmp)))) - (byte-compile-log-lap " %s [%s]\t-->\t%s <skip>" - (car lap0) tmp2 (nth 1 tmp3)) - (setcar lap0 (nth 1 tmp3)) - (setcdr lap0 (nth 1 tmp))) - (setq keep-going t)) - ;; - ;; const goto-X ... X: goto-if-* --> whatever - ;; const goto-X ... X: discard --> whatever - ;; - ((and (eq (car lap0) 'byte-constant) - (eq (car lap1) 'byte-goto) - (memq (car (car (setq tmp (cdr (memq (cdr lap1) lap))))) - (eval-when-compile - (cons 'byte-discard byte-conditional-ops))) - (not (eq lap1 (car tmp)))) - (setq tmp2 (car tmp)) - (cond ((memq (car tmp2) - (if (null (car (cdr lap0))) - '(byte-goto-if-nil byte-goto-if-nil-else-pop) - '(byte-goto-if-not-nil - byte-goto-if-not-nil-else-pop))) - (byte-compile-log-lap " %s goto [%s]\t-->\t%s %s" - lap0 tmp2 lap0 tmp2) - (setcar lap1 (car tmp2)) - (setcdr lap1 (cdr tmp2)) - ;; Let next step fix the (const,goto-if*) sequence. - (setq rest (cons nil rest))) - (t - ;; Jump one step further - (byte-compile-log-lap - " %s goto [%s]\t-->\t<deleted> goto <skip>" - lap0 tmp2) - (or (eq 'TAG (car (nth 1 tmp))) - (setcdr tmp (cons (byte-compile-make-tag) - (cdr tmp)))) - (setcdr lap1 (car (cdr tmp))) - (setq lap (delq lap0 lap)))) - (setq keep-going t)) - ;; - ;; X: varref-Y ... varset-Y goto-X --> - ;; X: varref-Y Z: ... dup varset-Y goto-Z - ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.) - ;; (This is so usual for while loops that it is worth handling). - ;; - ((and (eq (car lap1) 'byte-varset) - (eq (car lap2) 'byte-goto) - (not (memq (cdr lap2) rest)) ;Backwards jump - (eq (car (car (setq tmp (cdr (memq (cdr lap2) lap))))) - 'byte-varref) - (eq (cdr (car tmp)) (cdr lap1)) - (not (memq (car (cdr lap1)) byte-boolean-vars))) - ;;(byte-compile-log-lap " Pulled %s to end of loop" (car tmp)) - (let ((newtag (byte-compile-make-tag))) - (byte-compile-log-lap - " %s: %s ... %s %s\t-->\t%s: %s %s: ... %s %s %s" - (nth 1 (cdr lap2)) (car tmp) - lap1 lap2 - (nth 1 (cdr lap2)) (car tmp) - (nth 1 newtag) 'byte-dup lap1 - (cons 'byte-goto newtag) - ) - (setcdr rest (cons (cons 'byte-dup 0) (cdr rest))) - (setcdr tmp (cons (setcdr lap2 newtag) (cdr tmp)))) - (setq add-depth 1) - (setq keep-going t)) - ;; - ;; goto-X Y: ... X: goto-if*-Y --> goto-if-not-*-X+1 Y: - ;; (This can pull the loop test to the end of the loop) - ;; - ((and (eq (car lap0) 'byte-goto) - (eq (car lap1) 'TAG) - (eq lap1 - (cdr (car (setq tmp (cdr (memq (cdr lap0) lap)))))) - (memq (car (car tmp)) - '(byte-goto byte-goto-if-nil byte-goto-if-not-nil - byte-goto-if-nil-else-pop))) -;; (byte-compile-log-lap " %s %s, %s %s --> moved conditional" -;; lap0 lap1 (cdr lap0) (car tmp)) - (let ((newtag (byte-compile-make-tag))) - (byte-compile-log-lap - "%s %s: ... %s: %s\t-->\t%s ... %s:" - lap0 (nth 1 lap1) (nth 1 (cdr lap0)) (car tmp) - (cons (cdr (assq (car (car tmp)) - '((byte-goto-if-nil . byte-goto-if-not-nil) - (byte-goto-if-not-nil . byte-goto-if-nil) - (byte-goto-if-nil-else-pop . - byte-goto-if-not-nil-else-pop) - (byte-goto-if-not-nil-else-pop . - byte-goto-if-nil-else-pop)))) - newtag) - - (nth 1 newtag) - ) - (setcdr tmp (cons (setcdr lap0 newtag) (cdr tmp))) - (if (eq (car (car tmp)) 'byte-goto-if-nil-else-pop) - ;; We can handle this case but not the -if-not-nil case, - ;; because we won't know which non-nil constant to push. - (setcdr rest (cons (cons 'byte-constant - (byte-compile-get-constant nil)) - (cdr rest)))) - (setcar lap0 (nth 1 (memq (car (car tmp)) - '(byte-goto-if-nil-else-pop - byte-goto-if-not-nil - byte-goto-if-nil - byte-goto-if-not-nil - byte-goto byte-goto)))) - ) - (setq keep-going t)) - ) - (setq rest (cdr rest))) - ) - ;; Cleanup stage: - ;; Rebuild byte-compile-constants / byte-compile-variables. - ;; Simple optimizations that would inhibit other optimizations if they - ;; were done in the optimizing loop, and optimizations which there is no - ;; need to do more than once. - (setq byte-compile-constants nil - byte-compile-variables nil) - (setq rest lap) - (while rest - (setq lap0 (car rest) - lap1 (nth 1 rest)) - (if (memq (car lap0) byte-constref-ops) - (if (eq (cdr lap0) 'byte-constant) - (or (memq (cdr lap0) byte-compile-variables) - (setq byte-compile-variables (cons (cdr lap0) - byte-compile-variables))) - (or (memq (cdr lap0) byte-compile-constants) - (setq byte-compile-constants (cons (cdr lap0) - byte-compile-constants))))) - (cond (;; - ;; const-C varset-X const-C --> const-C dup varset-X - ;; const-C varbind-X const-C --> const-C dup varbind-X - ;; - (and (eq (car lap0) 'byte-constant) - (eq (car (nth 2 rest)) 'byte-constant) - (eq (cdr lap0) (car (nth 2 rest))) - (memq (car lap1) '(byte-varbind byte-varset))) - (byte-compile-log-lap " %s %s %s\t-->\t%s dup %s" - lap0 lap1 lap0 lap0 lap1) - (setcar (cdr (cdr rest)) (cons (car lap1) (cdr lap1))) - (setcar (cdr rest) (cons 'byte-dup 0)) - (setq add-depth 1)) - ;; - ;; const-X [dup/const-X ...] --> const-X [dup ...] dup - ;; varref-X [dup/varref-X ...] --> varref-X [dup ...] dup - ;; - ((memq (car lap0) '(byte-constant byte-varref)) - (setq tmp rest - tmp2 nil) - (while (progn - (while (eq 'byte-dup (car (car (setq tmp (cdr tmp)))))) - (and (eq (cdr lap0) (cdr (car tmp))) - (eq (car lap0) (car (car tmp))))) - (setcar tmp (cons 'byte-dup 0)) - (setq tmp2 t)) - (if tmp2 - (byte-compile-log-lap - " %s [dup/%s]...\t-->\t%s dup..." lap0 lap0 lap0))) - ;; - ;; unbind-N unbind-M --> unbind-(N+M) - ;; - ((and (eq 'byte-unbind (car lap0)) - (eq 'byte-unbind (car lap1))) - (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 - (cons 'byte-unbind - (+ (cdr lap0) (cdr lap1)))) - (setq keep-going t) - (setq lap (delq lap0 lap)) - (setcdr lap1 (+ (cdr lap1) (cdr lap0)))) - ) - (setq rest (cdr rest))) - (setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth))) - lap) - -(provide 'byte-optimize) - - -;; To avoid "lisp nesting exceeds max-lisp-eval-depth" when this file compiles -;; itself, compile some of its most used recursive functions (at load time). -;; -(eval-when-compile - (or (compiled-function-p (symbol-function 'byte-optimize-form)) - (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)))) - nil) - -;;; byte-optimize.el ends here
--- a/lisp/bytecomp/bytecomp-runtime.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,238 +0,0 @@ -;;; byte-run.el --- byte-compiler support for inlining - -;; Copyright (C) 1992 Free Software Foundation, Inc. - -;; Author: Jamie Zawinski <jwz@netscape.com> -;; Hallvard Furuseth <hbf@ulrik.uio.no> -;; Keywords: internal - -;; The code in this file should always be loaded, because it defines things -;; like "defsubst" which should work interpreted as well. The code in -;; bytecomp.el and byte-optimize.el can be loaded as needed. -;; -;; 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. - -;;; Commentary: - -;;; interface to selectively inlining functions. -;;; This only happens when source-code optimization is turned on. - -;;; Code: - -;; Redefined in byte-optimize.el. -;; This is not documented--it's not clear that we should promote it. -(fset 'inline 'progn) -(put 'inline 'lisp-indent-hook 0) - - -;;; Interface to inline functions. - -;; FSF comments the next two out, but I see no reason to do so. --ben -(defmacro proclaim-inline (&rest fns) - "Cause the named functions to be open-coded when called from compiled code. -They will only be compiled open-coded when byte-optimize is true." - (cons 'eval-and-compile - (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)))) - fns)))) - - -(defmacro proclaim-notinline (&rest fns) - "Cause the named functions to no longer be open-coded." - (cons 'eval-and-compile - (apply - 'nconc - (mapcar - '(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. -(defmacro defsubst (name arglist &rest body) - "Define an inline function. The syntax is just like that of `defun'." - (or (memq (get name 'byte-optimizer) - '(nil byte-compile-inline-expand)) - (error "`%s' is a primitive" name)) - (list 'prog1 - (cons 'defun (cons name (cons arglist body))) - (list 'proclaim-inline name))) -; Instead of the above line, FSF has this: -; (list 'eval-and-compile -; (list 'put (list 'quote name) -; ''byte-optimizer ''byte-compile-inline-expand)))) - -(defun make-obsolete (fn new) - "Make the byte-compiler warn that FUNCTION is obsolete. -The warning will say that NEW should be used instead. -If NEW is a string, that is the `use instead' message." - (interactive "aMake function obsolete: \nxObsoletion replacement: ") - (let ((handler (get fn 'byte-compile))) - (if (eq 'byte-compile-obsolete handler) - (setcar (get fn 'byte-obsolete-info) new) - (put fn 'byte-obsolete-info (cons new handler)) - (put fn 'byte-compile 'byte-compile-obsolete))) - fn) - -(defun make-obsolete-variable (var new) - "Make the byte-compiler warn that VARIABLE is obsolete, -and NEW should be used instead. If NEW is a string, then that is the -`use instead' message." - (interactive - (list - (let ((str (completing-read "Make variable obsolete: " obarray 'boundp t))) - (if (equal str "") (error "")) - (intern str)) - (car (read-from-string (read-string "Obsoletion replacement: "))))) - (put var 'byte-obsolete-variable new) - var) - -;; By overwhelming demand, we separate out truly obsolete symbols from -;; those that are present for GNU Emacs compatibility. -(defun make-compatible (fn new) - "Make the byte-compiler know that FUNCTION is provided for compatibility. -The warning will say that NEW should be used instead. -If NEW is a string, that is the `use instead' message." - (interactive "aMake function compatible: \nxCompatible replacement: ") - (let ((handler (get fn 'byte-compile))) - (if (eq 'byte-compile-compatible handler) - (setcar (get fn 'byte-compatible-info) new) - (put fn 'byte-compatible-info (cons new handler)) - (put fn 'byte-compile 'byte-compile-compatible))) - fn) - -(defun make-compatible-variable (var new) - "Make the byte-compiler know that VARIABLE is provided for compatibility. -and NEW should be used instead. If NEW is a string, then that is the -`use instead' message." - (interactive - (list - (let ((str (completing-read "Make variable compatible: " - obarray 'boundp t))) - (if (equal str "") (error "")) - (intern str)) - (car (read-from-string (read-string "Compatible replacement: "))))) - (put var 'byte-compatible-variable new) - var) - -(put 'dont-compile 'lisp-indent-hook 0) -(defmacro dont-compile (&rest body) - "Like `progn', but the body always runs interpreted (not compiled). -If you think you need this, you're probably making a mistake somewhere." - (list 'eval (list 'quote (if (cdr body) (cons 'progn body) (car body))))) - - -;;; interface to evaluating things at compile time and/or load time -;;; these macro must come after any uses of them in this file, as their -;;; definition in the file overrides the magic definitions on the -;;; byte-compile-macro-environment. - -(put 'eval-when-compile 'lisp-indent-hook 0) -(defmacro eval-when-compile (&rest body) - "Like `progn', but evaluates the body at compile time. -The result of the body appears to the compiler as a quoted constant." - ;; Not necessary because we have it in b-c-initial-macro-environment - ;; (list 'quote (eval (cons 'progn body))) - (cons 'progn body)) - -(put 'eval-and-compile 'lisp-indent-hook 0) -(defmacro eval-and-compile (&rest body) - "Like `progn', but evaluates the body at compile time and at load time." - ;; Remember, it's magic. - (cons 'progn body)) - -;;; From Emacs 20. -(put 'eval-when-feature 'lisp-indent-hook 1) -(defmacro eval-when-feature (feature &rest body) - "Run the body forms when FEATURE is featurep, be it now or later. -Called (eval-when-feature (FEATURE [. FILENAME]) BODYFORMS...). -If (featurep 'FEATURE), evals now; otherwise adds an elt to -`after-load-alist' (which see), using FEATURE as filename if FILENAME is nil." - (let ((file (or (cdr feature) (symbol-name (car feature))))) - `(let ((bodythunk (function (lambda () ,@body)))) - (if (featurep ',(car feature)) - (funcall bodythunk) - (setq after-load-alist (cons '(,file . (list 'lambda '() bodythunk)) - after-load-alist)))))) - - - -;;; Interface to file-local byte-compiler parameters. -;;; Redefined in bytecomp.el. - -;;; The great RMS speaketh: -;;; -;;; I nuked this because it's not a good idea for users to think of -;;; using it. These options are a matter of installation preference, -;;; and have nothing to do with particular source files; it's a -;;; mistake to suggest to users that they should associate these with -;;; particular source files. There is hardly any reason to change -;;; these parameters, anyway. --rms. -;;; -;;; But I'll leave this stuff alone. --ben - -(put 'byte-compiler-options 'lisp-indent-hook 0) -(defmacro byte-compiler-options (&rest args) - "Set some compilation-parameters for this file. -This will affect only the file in which it appears; this does nothing when -evaluated, or when loaded from a .el file. - -Each argument to this macro must be a list of a key and a value. - - Keys: Values: Corresponding variable: - - verbose t, nil byte-compile-verbose - optimize t, nil, source, byte byte-optimize - warnings list of warnings byte-compile-warnings - file-format emacs19, emacs20 byte-compile-emacs19-compatibility - -The value specified with the `warnings' option must be a list, containing -some subset of the following flags: - - free-vars references to variables not in the current lexical scope. - 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. - redefine function cell redefined from a macro to a lambda or vice - versa, or redefined to take a different number of arguments. - -If the first element if the list is `+' or `-' then the specified elements -are added to or removed from the current set of warnings, instead of the -entire set of warnings being overwritten. - -For example, something like this might appear at the top of a source file: - - (byte-compiler-options - (optimize t) - (warnings (- callargs)) ; Don't warn about arglist mismatch - (warnings (+ unused-vars)) ; Do warn about unused bindings - (file-format emacs19))" - nil) - -;;; bytecomp-runtime.el ends here
--- a/lisp/bytecomp/bytecomp.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,4100 +0,0 @@ -;;; bytecomp.el --- compilation of Lisp code into byte code. - -;;; Copyright (C) 1985-1987, 1991-1994 Free Software Foundation, Inc. -;;; Copyright (C) 1996 Ben Wing. - -;; Author: Jamie Zawinski <jwz@netscape.com> -;; Hallvard Furuseth <hbf@ulrik.uio.no> -;; Keywords: internal - -;; Subsequently modified by RMS and others. - -(defconst byte-compile-version (purecopy "2.25 XEmacs; 22-Mar-96.")) - -;; 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. - -;;; Commentary: - -;; The Emacs Lisp byte compiler. This crunches lisp source into a sort -;; of p-code which takes up less space and can be interpreted faster. -;; The user entry points are byte-compile-file and byte-recompile-directory. - -;;; Code: - -;;; ======================================================================== -;;; Entry points: -;;; byte-recompile-directory, byte-compile-file, -;;; batch-byte-compile, batch-byte-recompile-directory, -;;; byte-compile, compile-defun, -;;; display-call-tree -;;; RMS says: -;;; (byte-compile-buffer and byte-compile-and-load-file were turned off -;;; because they are not terribly useful and get in the way of completion.) -;;; But I'm leaving them. --ben - -;;; This version of the byte compiler has the following improvements: -;;; + optimization of compiled code: -;;; - removal of unreachable code; -;;; - removal of calls to side-effectless functions whose return-value -;;; is unused; -;;; - compile-time evaluation of safe constant forms, such as (consp nil) -;;; and (ash 1 6); -;;; - open-coding of literal lambdas; -;;; - peephole optimization of emitted code; -;;; - trivial functions are left uncompiled for speed. -;;; + support for inline functions; -;;; + compile-time evaluation of arbitrary expressions; -;;; + compile-time warning messages for: -;;; - functions being redefined with incompatible arglists; -;;; - functions being redefined as macros, or vice-versa; -;;; - functions or macros defined multiple times in the same file; -;;; - functions being called with the incorrect number of arguments; -;;; - functions being called which are not defined globally, in the -;;; file, or as autoloads; -;;; - assignment and reference of undeclared free variables; -;;; - various syntax errors; -;;; + correct compilation of nested defuns, defmacros, defvars and defsubsts; -;;; + correct compilation of top-level uses of macros; -;;; + the ability to generate a histogram of functions called. - -;;; User customization variables: -;;; -;;; byte-compile-verbose Whether to report the function currently being -;;; compiled in the minibuffer; -;;; byte-optimize Whether to do optimizations; this may be -;;; t, nil, 'source, or 'byte; -;;; byte-optimize-log Whether to report (in excruciating detail) -;;; exactly which optimizations have been made. -;;; This may be t, nil, 'source, or 'byte; -;;; byte-compile-error-on-warn Whether to stop compilation when a warning is -;;; produced; -;;; byte-compile-delete-errors Whether the optimizer may delete calls or -;;; variable references that are side-effect-free -;;; except that they may return an error. -;;; byte-compile-generate-call-tree Whether to generate a histogram of -;;; function calls. This can be useful for -;;; finding unused functions, as well as simple -;;; performance metering. -;;; byte-compile-warnings List of warnings to issue, or t. May contain -;;; 'free-vars (references to variables not in the -;;; current lexical scope) -;;; 'unused-vars (non-global variables bound but -;;; not referenced) -;;; 'unresolved (calls to unknown functions) -;;; 'callargs (lambda calls with args that don't -;;; match the lambda's definition) -;;; 'redefine (function cell redefined from -;;; a macro to a lambda or vice versa, -;;; or redefined to take other args) -;;; 'obsolete (obsolete variables and functions) -;;; 'pedantic (references to Emacs-compatible -;;; symbols) -;;; byte-compile-emacs19-compatibility Whether the compiler should -;;; generate .elc files which can be loaded into -;;; generic emacs 19. -;;; emacs-lisp-file-regexp Regexp for the extension of source-files; -;;; see also the function byte-compile-dest-file. -;;; byte-compile-overwrite-file If nil, delete old .elc files before saving. -;;; -;;; Most of the above parameters can also be set on a file-by-file basis; see -;;; the documentation of the `byte-compiler-options' macro. - -;;; New Features: -;;; -;;; o The form `defsubst' is just like `defun', except that the function -;;; generated will be open-coded in compiled code which uses it. This -;;; means that no function call will be generated, it will simply be -;;; spliced in. Lisp functions calls are very slow, so this can be a -;;; big win. -;;; -;;; You can generally accomplish the same thing with `defmacro', but in -;;; that case, the defined procedure can't be used as an argument to -;;; mapcar, etc. -;;; -;;; o You can make a given function be inline even if it has already been -;;; defined with `defun' by using the `proclaim-inline' form like so: -;;; (proclaim-inline my-function) -;;; This is, in fact, exactly what `defsubst' does. To make a function no -;;; longer be inline, you must use `proclaim-notinline'. Beware that if -;;; you define a function with `defsubst' and later redefine it with -;;; `defun', it will still be open-coded until you use proclaim-notinline. -;;; -;;; o You can also open-code one particular call to a function without -;;; open-coding all calls. Use the 'inline' form to do this, like so: -;;; -;;; (inline (foo 1 2 3)) ;; `foo' will be open-coded -;;; or... -;;; (inline ;; `foo' and `baz' will be -;;; (foo 1 2 3 (bar 5)) ;; open-coded, but `bar' will not. -;;; (baz 0)) -;;; -;;; o It is possible to open-code a function in the same file it is defined -;;; in without having to load that file before compiling it. the -;;; byte-compiler has been modified to remember function definitions in -;;; the compilation environment in the same way that it remembers macro -;;; definitions. -;;; -;;; o Forms like ((lambda ...) ...) are open-coded. -;;; -;;; o The form `eval-when-compile' is like progn, except that the body -;;; is evaluated at compile-time. When it appears at top-level, this -;;; is analogous to the Common Lisp idiom (eval-when (compile) ...). -;;; When it does not appear at top-level, it is similar to the -;;; Common Lisp #. reader macro (but not in interpreted code). -;;; -;;; o The form `eval-and-compile' is similar to eval-when-compile, but -;;; the whole form is evalled both at compile-time and at run-time. -;;; -;;; o The command M-x byte-compile-and-load-file does what you'd think. -;;; -;;; o The command compile-defun is analogous to eval-defun. -;;; -;;; o If you run byte-compile-file on a filename which is visited in a -;;; 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 -;;; generated by this compiler: -;;; -;;; 0 string ;ELC GNU Emacs Lisp compiled file, -;;; >4 byte x version %d -;;; -;;; TO DO: -;;; -;;; o Should implement declarations and proclamations, notably special, -;;; unspecial, and ignore. Do this in such a way as to not break cl.el. -;;; o The bound-but-not-used warnings are not issued for variables whose -;;; bindings were established in the arglist, due to the lack of an -;;; ignore declaration. Once ignore exists, this should be turned on. -;;; o Warn about functions and variables defined but not used? -;;; Maybe add some kind of `export' declaration for this? -;;; (With interactive functions being automatically exported?) -;;; o Any reference to a variable, even one which is a no-op, will cause -;;; the warning not to be given. Possibly we could use the for-effect -;;; flag to determine when this reference is useless; possibly more -;;; complex flow analysis would be necessary. -;;; o If the optimizer deletes a variable reference, we might be left with -;;; a bound-but-not-referenced warning. Generally this is ok, but not if -;;; it's a synergistic result of macroexpansion. Need some way to note -;;; that a varref is being optimized away? Of course it would be nice to -;;; optimize away the binding too, someday, but it's unsafe today. -;;; o (See byte-optimize.el for the optimization TODO list.) - -(require 'backquote) - -(or (fboundp 'defsubst) - ;; This really ought to be loaded already! - (load-library "bytecomp-runtime")) - -(eval-when-compile - (defvar byte-compile-single-version nil - "If this is true, the choice of emacs version (v19 or v20) byte-codes will -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))) - ) - -(defvar emacs-lisp-file-regexp (if (eq system-type 'vax-vms) - (purecopy "\\.EL\\(;[0-9]+\\)?$") - (purecopy "\\.el$")) - "*Regexp which matches Emacs Lisp source files. -You may want to redefine `byte-compile-dest-file' if you change this.") - -;; This enables file name handlers such as jka-compr -;; to remove parts of the file name that should not be copied -;; through to the output file name. -(defun byte-compiler-base-file-name (filename) - (let ((handler (find-file-name-handler filename - 'byte-compiler-base-file-name))) - (if handler - (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"))))) - -;; This can be the 'byte-compile property of any symbol. -(autoload 'byte-compile-inline-expand "byte-optimize") - -;; This is the entrypoint to the lapcode optimizer pass1. -(autoload 'byte-optimize-form "byte-optimize") -;; This is the entrypoint to the lapcode optimizer pass2. -(autoload 'byte-optimize-lapcode "byte-optimize") -(autoload 'byte-compile-unfold-lambda "byte-optimize") - -;; This is the entry point to the decompiler, which is used by the -;; 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") - -(defvar byte-compile-verbose - (and (not noninteractive) (> (device-baud-rate) search-slow-speed)) - "*Non-nil means print messages describing progress of byte-compiler.") - -(defvar byte-compile-emacs19-compatibility - (not (emacs-version>= 20)) - "*Non-nil means generate output that can run in Emacs 19.") - -(defvar byte-optimize t - "*Enables optimization in the byte compiler. -nil means don't do any optimization. -t means do all optimizations. -`source' means do source-level optimizations only. -`byte' means do code-level optimizations only.") - -(defvar byte-compile-delete-errors t - "*If non-nil, the optimizer may delete forms that may signal an error. -This includes variable references and calls to functions such as `car'.") - -;; XEmacs addition -(defvar byte-compile-new-bytecodes nil - "This is completely ignored. It is only around for backwards -compatibility.") - - -;; FSF enables byte-compile-dynamic-docstrings but not byte-compile-dynamic -;; by default. This would be a reasonable conservative approach except -;; for the fact that if you enable either of these, you get incompatible -;; byte code that can't be read by XEmacs 19.13 or before or FSF 19.28 or -;; before. -;; -;; Therefore, neither is enabled for 19.14. Both are enabled for 20.0 -;; because we have no reason to be conservative about changing the -;; way things work. (Ben) - -;; However, I don't think that defaulting byte-compile-dynamic to nil -;; is a compatibility issue - rather it is a performance issue. -;; Therefore I am setting byte-compile-dynamic back to nil. (mrb) - -(defvar byte-compile-dynamic nil - "*If non-nil, compile function bodies so they load lazily. -They are hidden comments in the compiled file, and brought into core when the -function is called. - -To enable this option, make it a file-local variable -in the source file you want it to apply to. -For example, add -*-byte-compile-dynamic: t;-*- on the first line. - -When this option is true, if you load the compiled file and then move it, -the functions you loaded will not be able to run.") - -(defvar byte-compile-dynamic-docstrings (emacs-version>= 20) - "*If non-nil, compile doc strings for lazy access. -We bury the doc strings of functions and variables -inside comments in the file, and bring them into core only when they -are actually needed. - -When this option is true, if you load the compiled file and then move it, -you won't be able to find the documentation of anything in that file. - -To disable this option for a certain file, make it a file-local variable -in the source file. For example, add this to the first line: - -*-byte-compile-dynamic-docstrings:nil;-*- -You can also set the variable globally. - -This option is enabled by default because it reduces Emacs memory usage.") - -(defvar byte-optimize-log nil - "*If true, the byte-compiler will log its optimizations into *Compile-Log*. -If this is 'source, then only source-level optimizations will be logged. -If it is 'byte, then only byte-level optimizations will be logged.") - -(defvar byte-compile-error-on-warn nil - "*If true, the byte-compiler reports warnings with `error'.") - -;; byte-compile-warning-types in FSF. -(defvar byte-compile-default-warnings - '(redefine callargs free-vars unresolved unused-vars obsolete) - "*The warnings used when byte-compile-warnings is t.") - -(defvar byte-compile-warnings t - "*List of warnings that the compiler should issue (t for the default set). -Elements of the list may be: - - free-vars references to variables not in the current lexical scope. - 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. - 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. - pedantic warn of use of compatible symbols. - -The default set is specified by `byte-compile-default-warnings' and -normally encompasses all possible warnings. - -See also the macro `byte-compiler-options'.") - -(defvar byte-compile-generate-call-tree nil - "*Non-nil means collect call-graph information when compiling. -This records functions were called and from where. -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. - -The call tree only lists functions called, not macros used. Those functions -which the byte-code interpreter knows about directly (eq, cons, etc.) are -not reported. - -The call tree also lists those functions which are not known to be called -\(that is, to which no calls have been compiled). Functions which can be -invoked interactively are excluded from this list.") - -(defconst byte-compile-call-tree nil "Alist of functions and their call tree. -Each element looks like - - \(FUNCTION CALLERS CALLS\) - -where CALLERS is a list of functions that call FUNCTION, and CALLS -is a list of functions for which calls were generated while compiling -FUNCTION.") - -(defvar byte-compile-call-tree-sort 'name - "*If non-nil, sort the call tree. -The values `name', `callers', `calls', `calls+callers' -specify different fields to sort on.") - -(defvar byte-compile-overwrite-file t - "If nil, old .elc files are deleted before the new is saved, and .elc -files will have the same modes as the corresponding .el file. Otherwise, -existing .elc files will simply be overwritten, and the existing modes -will not be changed. If this variable is nil, then an .elc file which -is a symbolic link will be turned into a normal file, instead of the file -which the link points to being overwritten.") - -(defvar byte-recompile-directory-ignore-errors-p nil - "If true, then `byte-recompile-directory' will continue compiling even -when an error occurs in a file. This is bound to t by -`batch-byte-recompile-directory'.") - -(defvar byte-recompile-directory-recursively t - "*If true, then `byte-recompile-directory' will recurse on subdirectories.") - -(defvar byte-compile-constants nil - "list of all constants encountered during compilation of this form") -(defvar byte-compile-variables nil - "list of all variables encountered during compilation of this form") -(defvar byte-compile-bound-variables nil - "Alist of variables bound in the context of the current form, -that is, the current lexical environment. This list lives partly -on the specbind stack. The cdr of each cell is an integer bitmask.") - -(defconst byte-compile-referenced-bit 1) -(defconst byte-compile-assigned-bit 2) -(defconst byte-compile-arglist-bit 4) -(defconst byte-compile-global-bit 8) - -(defvar byte-compile-free-references) -(defvar byte-compile-free-assignments) - -(defvar byte-compiler-error-flag) - -(defconst byte-compile-initial-macro-environment - (purecopy - '((byte-compiler-options . (lambda (&rest forms) - (apply 'byte-compiler-options-handler forms))) - (eval-when-compile . (lambda (&rest body) - (list 'quote (eval (byte-compile-top-level - (cons 'progn body)))))) - (eval-and-compile . (lambda (&rest body) - (eval (cons 'progn body)) - (cons 'progn body))))) - "The default macro-environment passed to macroexpand by the compiler. -Placing a macro here will cause a macro to have different semantics when -expanded by the compiler as when expanded by the interpreter.") - -(defvar byte-compile-macro-environment byte-compile-initial-macro-environment - "Alist of macros defined in the file being compiled. -Each element looks like (MACRONAME . DEFINITION). It is -\(MACRONAME . nil) when a macro is redefined as a function.") - -(defvar byte-compile-function-environment nil - "Alist of functions defined in the file being compiled. -This is so we can inline them when necessary. -Each element looks like (FUNCTIONNAME . DEFINITION). It is -\(FUNCTIONNAME . nil) when a function is redefined as a macro.") - -(defvar byte-compile-autoload-environment nil - "Alist of functions and macros defined by autoload in the file being compiled. -This is so we can suppress warnings about calls to these functions, even though -they do not have `real' definitions. -Each element looks like (FUNCTIONNAME . CALL-TO-AUTOLOAD).") - -(defvar byte-compile-unresolved-functions nil - "Alist of undefined functions to which calls have been compiled (used for -warnings when the function is later defined with incorrect args).") - -(defvar byte-compile-file-domain) ; domain of file being compiled - -(defvar byte-compile-tag-number 0) -(defvar byte-compile-output nil - "Alist describing contents to put in byte code string. -Each element is (INDEX . VALUE)") -(defvar byte-compile-depth 0 "Current depth of execution stack.") -(defvar byte-compile-maxdepth 0 "Maximum depth of execution stack.") - - -;;; The byte codes; this information is duplicated in bytecode.c - -(defconst byte-code-vector nil - "An array containing byte-code names indexed by byte-code values.") - -(defconst byte-stack+-info nil - "An array with the stack adjustment for each byte-code.") - -(defmacro byte-defop (opcode stack-adjust opname &optional docstring) - ;; This is a speed-hack for building the byte-code-vector at compile-time. - ;; We fill in the vector at macroexpand-time, and then after the last call - ;; to byte-defop, we write the vector out as a constant instead of writing - ;; out a bunch of calls to aset. - ;; Actually, we don't fill in the vector itself, because that could make - ;; it problematic to compile big changes to this compiler; we store the - ;; values on its plist, and remove them later in -extrude. - (let ((v1 (or (get 'byte-code-vector 'tmp-compile-time-value) - (put 'byte-code-vector 'tmp-compile-time-value - (make-vector 256 nil)))) - (v2 (or (get 'byte-stack+-info 'tmp-compile-time-value) - (put 'byte-stack+-info 'tmp-compile-time-value - (make-vector 256 nil))))) - (aset v1 opcode opname) - (aset v2 opcode stack-adjust)) - (if docstring - (list 'defconst opname opcode (concat "Byte code opcode " docstring ".")) - (list 'defconst opname opcode))) - -(defmacro byte-extrude-byte-code-vectors () - (prog1 (list 'setq 'byte-code-vector - (get 'byte-code-vector 'tmp-compile-time-value) - 'byte-stack+-info - (get 'byte-stack+-info 'tmp-compile-time-value)) - (remprop 'byte-code-vector 'tmp-compile-time-value) - (remprop 'byte-stack+-info 'tmp-compile-time-value))) - - -;; unused: 0-7 - -;; These opcodes are special in that they pack their argument into the -;; opcode word. -;; -(byte-defop 8 1 byte-varref "for variable reference") -(byte-defop 16 -1 byte-varset "for setting a variable") -(byte-defop 24 -1 byte-varbind "for binding a variable") -(byte-defop 32 0 byte-call "for calling a function") -(byte-defop 40 0 byte-unbind "for unbinding special bindings") -;; codes 8-47 are consumed by the preceding opcodes - -;; unused: 48-55 - -(byte-defop 56 -1 byte-nth) -(byte-defop 57 0 byte-symbolp) -(byte-defop 58 0 byte-consp) -(byte-defop 59 0 byte-stringp) -(byte-defop 60 0 byte-listp) -(byte-defop 61 -1 byte-old-eq) -(byte-defop 62 -1 byte-old-memq) -(byte-defop 63 0 byte-not) -(byte-defop 64 0 byte-car) -(byte-defop 65 0 byte-cdr) -(byte-defop 66 -1 byte-cons) -(byte-defop 67 0 byte-list1) -(byte-defop 68 -1 byte-list2) -(byte-defop 69 -2 byte-list3) -(byte-defop 70 -3 byte-list4) -(byte-defop 71 0 byte-length) -(byte-defop 72 -1 byte-aref) -(byte-defop 73 -2 byte-aset) -(byte-defop 74 0 byte-symbol-value) -(byte-defop 75 0 byte-symbol-function) ; this was commented out -(byte-defop 76 -1 byte-set) -(byte-defop 77 -1 byte-fset) ; this was commented out -(byte-defop 78 -1 byte-get) -(byte-defop 79 -2 byte-substring) -(byte-defop 80 -1 byte-concat2) -(byte-defop 81 -2 byte-concat3) -(byte-defop 82 -3 byte-concat4) -(byte-defop 83 0 byte-sub1) -(byte-defop 84 0 byte-add1) -(byte-defop 85 -1 byte-eqlsign) -(byte-defop 86 -1 byte-gtr) -(byte-defop 87 -1 byte-lss) -(byte-defop 88 -1 byte-leq) -(byte-defop 89 -1 byte-geq) -(byte-defop 90 -1 byte-diff) -(byte-defop 91 0 byte-negate) -(byte-defop 92 -1 byte-plus) -(byte-defop 93 -1 byte-max) -(byte-defop 94 -1 byte-min) -(byte-defop 95 -1 byte-mult) -(byte-defop 96 1 byte-point) -(byte-defop 97 -1 byte-eq) ; new as of v20 -(byte-defop 98 0 byte-goto-char) -(byte-defop 99 0 byte-insert) -(byte-defop 100 1 byte-point-max) -(byte-defop 101 1 byte-point-min) -(byte-defop 102 0 byte-char-after) -(byte-defop 103 1 byte-following-char) -(byte-defop 104 1 byte-preceding-char) -(byte-defop 105 1 byte-current-column) -(byte-defop 106 0 byte-indent-to) -(byte-defop 107 -1 byte-equal) ; new as of v20 -(byte-defop 108 1 byte-eolp) -(byte-defop 109 1 byte-eobp) -(byte-defop 110 1 byte-bolp) -(byte-defop 111 1 byte-bobp) -(byte-defop 112 1 byte-current-buffer) -(byte-defop 113 0 byte-set-buffer) -(byte-defop 114 0 byte-save-current-buffer - "To make a binding to record the current buffer.") -;;(byte-defop 114 1 byte-read-char-OBSOLETE) ;obsolete as of v19 -(byte-defop 115 -1 byte-memq) ; new as of v20 -(byte-defop 116 1 byte-interactive-p) - -(byte-defop 117 0 byte-forward-char) -(byte-defop 118 0 byte-forward-word) -(byte-defop 119 -1 byte-skip-chars-forward) -(byte-defop 120 -1 byte-skip-chars-backward) -(byte-defop 121 0 byte-forward-line) -(byte-defop 122 0 byte-char-syntax) -(byte-defop 123 -1 byte-buffer-substring) -(byte-defop 124 -1 byte-delete-region) -(byte-defop 125 -1 byte-narrow-to-region) -(byte-defop 126 1 byte-widen) -(byte-defop 127 0 byte-end-of-line) - -;; unused: 128 - -;; These store their argument in the next two bytes -(byte-defop 129 1 byte-constant2 - "for reference to a constant with vector index >= byte-constant-limit") -(byte-defop 130 0 byte-goto "for unconditional jump") -(byte-defop 131 -1 byte-goto-if-nil "to pop value and jump if it's nil") -(byte-defop 132 -1 byte-goto-if-not-nil - "to pop value and jump if it's not nil") -(byte-defop 133 -1 byte-goto-if-nil-else-pop - "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, -otherwise pop it") - -(byte-defop 135 -1 byte-return "to pop a value and return it from `byte-code'") -(byte-defop 136 -1 byte-discard "to discard one value from stack") -(byte-defop 137 1 byte-dup "to duplicate the top of the stack") - -(byte-defop 138 0 byte-save-excursion - "to make a binding to record the buffer, point and mark") -(byte-defop 139 0 byte-save-window-excursion - "to make a binding to record entire window configuration") -(byte-defop 140 0 byte-save-restriction - "to make a binding to record the current buffer clipping restrictions") -(byte-defop 141 -1 byte-catch - "for catch. Takes, on stack, the tag and an expression for the body") -(byte-defop 142 -1 byte-unwind-protect - "for unwind-protect. Takes, on stack, an expression for the unwind-action") - -;; For condition-case. Takes, on stack, the variable to bind, -;; an expression for the body, and a list of clauses. -(byte-defop 143 -2 byte-condition-case) - -;; For entry to with-output-to-temp-buffer. -;; Takes, on stack, the buffer name. -;; Binds standard-output and does some other things. -;; Returns with temp buffer on the stack in place of buffer name. -(byte-defop 144 0 byte-temp-output-buffer-setup) - -;; For exit from with-output-to-temp-buffer. -;; Expects the temp buffer on the stack underneath value to return. -;; Pops them both, then pushes the value back on. -;; Unbinds standard-output and makes the temp buffer visible. -(byte-defop 145 -1 byte-temp-output-buffer-show) - -;; To unbind back to the beginning of this frame. -;; Not used yet, but will be needed for tail-recursion elimination. -(byte-defop 146 0 byte-unbind-all) - -(byte-defop 147 -2 byte-set-marker) -(byte-defop 148 0 byte-match-beginning) -(byte-defop 149 0 byte-match-end) -(byte-defop 150 0 byte-upcase) -(byte-defop 151 0 byte-downcase) -(byte-defop 152 -1 byte-string=) -(byte-defop 153 -1 byte-string<) -(byte-defop 154 -1 byte-old-equal) -(byte-defop 155 -1 byte-nthcdr) -(byte-defop 156 -1 byte-elt) -(byte-defop 157 -1 byte-old-member) -(byte-defop 158 -1 byte-old-assq) -(byte-defop 159 0 byte-nreverse) -(byte-defop 160 -1 byte-setcar) -(byte-defop 161 -1 byte-setcdr) -(byte-defop 162 0 byte-car-safe) -(byte-defop 163 0 byte-cdr-safe) -(byte-defop 164 -1 byte-nconc) -(byte-defop 165 -1 byte-quo) -(byte-defop 166 -1 byte-rem) -(byte-defop 167 0 byte-numberp) -(byte-defop 168 0 byte-integerp) - -;; unused: 169 - -;; These are not present in FSF. -;; -(byte-defop 170 0 byte-rel-goto) -(byte-defop 171 -1 byte-rel-goto-if-nil) -(byte-defop 172 -1 byte-rel-goto-if-not-nil) -(byte-defop 173 -1 byte-rel-goto-if-nil-else-pop) -(byte-defop 174 -1 byte-rel-goto-if-not-nil-else-pop) - -(byte-defop 175 nil byte-listN) -(byte-defop 176 nil byte-concatN) -(byte-defop 177 nil byte-insertN) - -;; unused: 178-181 - -;; these ops are new to v20 -(byte-defop 182 -1 byte-member) -(byte-defop 183 -1 byte-assq) - -;; unused: 184-191 - -(byte-defop 192 1 byte-constant "for reference to a constant") -;; codes 193-255 are consumed by byte-constant. -(defconst byte-constant-limit 64 - "Exclusive maximum index usable in the `byte-constant' opcode.") - -(defconst byte-goto-ops (purecopy - '(byte-goto byte-goto-if-nil byte-goto-if-not-nil - byte-goto-if-nil-else-pop - byte-goto-if-not-nil-else-pop)) - "List of byte-codes whose offset is a pc.") - -(defconst byte-goto-always-pop-ops - (purecopy '(byte-goto-if-nil byte-goto-if-not-nil))) - -(defconst byte-rel-goto-ops - (purecopy '(byte-rel-goto byte-rel-goto-if-nil byte-rel-goto-if-not-nil - byte-rel-goto-if-nil-else-pop byte-rel-goto-if-not-nil-else-pop)) - "byte-codes for relative jumps.") - -(byte-extrude-byte-code-vectors) - -;;; lapcode generator -;;; -;;; the byte-compiler now does source -> lapcode -> bytecode instead of -;;; source -> bytecode, because it's a lot easier to make optimizations -;;; on lapcode than on bytecode. -;;; -;;; Elements of the lapcode list are of the form (<instruction> . <parameter>) -;;; where instruction is a symbol naming a byte-code instruction, -;;; and parameter is an argument to that instruction, if any. -;;; -;;; The instruction can be the pseudo-op TAG, which means that this position -;;; in the instruction stream is a target of a goto. (car PARAMETER) will be -;;; the PC for this location, and the whole instruction "(TAG pc)" will be the -;;; parameter for some goto op. -;;; -;;; If the operation is varbind, varref, varset or push-constant, then the -;;; parameter is (variable/constant . index_in_constant_vector). -;;; -;;; First, the source code is macroexpanded and optimized in various ways. -;;; Then the resultant code is compiled into lapcode. Another set of -;;; optimizations are then run over the lapcode. Then the variables and -;;; constants referenced by the lapcode are collected and placed in the -;;; constants-vector. (This happens now so that variables referenced by dead -;;; code don't consume space.) And finally, the lapcode is transformed into -;;; compacted byte-code. -;;; -;;; A distinction is made between variables and constants because the variable- -;;; referencing instructions are more sensitive to the variables being near the -;;; front of the constants-vector than the constant-referencing instructions. -;;; Also, this lets us notice references to free variables. - -(defun byte-compile-lapcode (lap) - "Turns lapcode into bytecode. The lapcode is destroyed." - ;; Lapcode modifications: changes the ID of a tag to be the tag's PC. - (let ((pc 0) ; Program counter - op off ; Operation & offset - (bytes '()) ; Put the output bytes here - (patchlist nil) ; List of tags and goto's to patch - rest rel tmp) - (while lap - (setq op (car (car lap)) - off (cdr (car lap))) - (cond ((not (symbolp op)) - (error "Non-symbolic opcode `%s'" op)) - ((eq op 'TAG) - (setcar off pc) - (setq patchlist (cons 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))) - (t - (setq bytes - (cond ((cond ((consp off) - ;; Variable or constant reference - (setq off (cdr off)) - (eq op 'byte-constant))) - (cond ((< off byte-constant-limit) - (setq pc (1+ pc)) - (cons (+ byte-constant off) bytes)) - (t - (setq pc (+ 3 pc)) - (cons (lsh off -8) - (cons (logand off 255) - (cons byte-constant2 bytes)))))) - ((and (<= byte-listN (symbol-value op)) - (<= (symbol-value op) byte-insertN)) - (setq pc (+ 2 pc)) - (cons off (cons (symbol-value op) bytes))) - ((< off 6) - (setq pc (1+ pc)) - (cons (+ (symbol-value op) off) bytes)) - ((< off 256) - (setq pc (+ 2 pc)) - (cons off (cons (+ (symbol-value op) 6) bytes))) - (t - (setq pc (+ 3 pc)) - (cons (lsh off -8) - (cons (logand off 255) - (cons (+ (symbol-value op) 7) - bytes)))))))) - (setq lap (cdr lap))) - ;;(if (not (= pc (length bytes))) - ;; (error "Compiler error: pc mismatch - %s %s" pc (length bytes))) - (cond (t ;; starting with Emacs 19. - ;; Make relative jumps - (setq patchlist (nreverse patchlist)) - (while (progn - (setq off 0) ; PC change because of deleted bytes - (setq rest patchlist) - (while rest - (setq tmp (car rest)) - (and (consp (car tmp)) ; Jump - (prog1 (null (nth 1 tmp)) ; Absolute jump - (setq tmp (car tmp))) - (progn - (setq rel (- (car (cdr tmp)) (car tmp))) - (and (<= -129 rel) (< rel 128))) - (progn - ;; Convert to relative jump. - (setcdr (car rest) (cdr (cdr (car rest)))) - (setcar (cdr (car rest)) - (+ (car (cdr (car rest))) - (- byte-rel-goto byte-goto))) - (setq off (1- off)))) - (setcar tmp (+ (car tmp) off)) ; Adjust PC - (setq rest (cdr rest))) - ;; If optimizing, repeat until no change. - (and byte-optimize - (not (zerop off))))))) - ;; Patch PC into jumps - (let (bytes) - (while patchlist - (setq bytes (car patchlist)) - (cond ((atom (car bytes))) ; Tag - ((nth 1 bytes) ; Relative jump - (setcar bytes (+ (- (car (cdr (car bytes))) (car (car bytes))) - 128))) - (t ; Absolute jump - (setq pc (car (cdr (car bytes)))) ; Pick PC from tag - (setcar (cdr bytes) (logand pc 255)) - (setcar bytes (lsh pc -8)))) - (setq patchlist (cdr patchlist)))) - (concat (nreverse bytes)))) - - -;;; byte compiler messages - -(defvar byte-compile-current-form nil) -(defvar byte-compile-current-file nil) -(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) - -;; 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*")) - (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"))) - (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))) - -;; 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)))) - -(defun byte-compile-warn (format &rest args) - (setq format (apply 'format format args)) - (if byte-compile-error-on-warn - (error "%s" format) ; byte-compile-file catches and logs it - (byte-compile-log-1 (concat "** " format) t) -;;; RMS says: -;;; It is useless to flash warnings too fast to be read. -;;; Besides, they will all be shown at the end. -;;; and comments out the next two lines. - (or noninteractive ; already written on stdout. - (message "Warning: %s" format)))) - -;;; This function should be used to report errors that have halted -;;; compilation of the current file. -(defun byte-compile-report-error (error-info) - (setq byte-compiler-error-flag t) - (byte-compile-log-1 - (concat "!! " - (format (if (cdr error-info) "%s (%s)" "%s") - (get (car error-info) 'error-message) - (prin1-to-string (cdr error-info)))))) - -;;; Used by make-obsolete. -(defun byte-compile-obsolete (form) - (let ((new (get (car form) 'byte-obsolete-info))) - (if (memq 'obsolete byte-compile-warnings) - (byte-compile-warn "%s is an obsolete function; %s" (car form) - (if (stringp (car new)) - (car new) - (format "use %s instead." (car new))))) - (funcall (or (cdr new) 'byte-compile-normal-call) form))) - -;;; Used by make-obsolete. -(defun byte-compile-compatible (form) - (let ((new (get (car form) 'byte-compatible-info))) - (if (memq 'pedantic byte-compile-warnings) - (byte-compile-warn "%s is provided for compatibility; %s" (car form) - (if (stringp (car new)) - (car new) - (format "use %s instead." (car new))))) - (funcall (or (cdr new) 'byte-compile-normal-call) form))) - -;; Compiler options - -(defconst byte-compiler-legal-options - '((optimize byte-optimize (t nil source byte) val) - (file-format byte-compile-emacs19-compatibility (emacs19 emacs20) - (eq val 'emacs19)) - (delete-errors byte-compile-delete-errors (t nil) val) - (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)) - val))) - -;; XEmacs addition -(defconst byte-compiler-obsolete-options - '((new-bytecodes t))) - -;; Inhibit v19/v20 selectors if the version is hardcoded. -;; #### This should print a warning if the user tries to change something -;; than can't be changed because the running compiler doesn't support it. -(cond - ((byte-compile-single-version) - (setcar (cdr (cdr (assq 'file-format byte-compiler-legal-options))) - (if (byte-compile-version-cond byte-compile-emacs19-compatibility) - '(emacs19) '(emacs20))))) - -;; now we can copy it. -(setq byte-compiler-legal-options (purecopy byte-compiler-legal-options)) - -(defun byte-compiler-options-handler (&rest args) - (let (key val desc choices) - (while args - (if (or (atom (car args)) (nthcdr 2 (car args)) (null (cdr (car args)))) - (error "malformed byte-compiler-option %s" (car args))) - (setq key (car (car args)) - val (car (cdr (car args))) - desc (assq key byte-compiler-legal-options)) - (or desc - (error "unknown byte-compiler option %s" key)) - (if (assq key byte-compiler-obsolete-options) - (byte-compile-warn "%s is an obsolete byte-compiler option." key)) - (setq choices (nth 2 desc)) - (if (consp (car choices)) - (let* (this - (handler 'cons) - (var (nth 1 desc)) - (ret (and (memq (car val) '(+ -)) - (copy-sequence (if (eq t (symbol-value var)) - (car choices) - (symbol-value var)))))) - (setq choices (car choices)) - (while val - (setq this (car val)) - (cond ((memq this choices) - (setq ret (funcall handler this ret))) - ((eq this '+) (setq handler 'cons)) - ((eq this '-) (setq handler 'delq)) - ((error "%s only accepts %s." key choices))) - (setq val (cdr val))) - (set (nth 1 desc) ret)) - (or (memq val choices) - (error "%s must be one of %s." key choices)) - (set (nth 1 desc) (eval (nth 3 desc)))) - (setq args (cdr args))) - nil)) - -;;; sanity-checking arglists - -(defun byte-compile-fdefinition (name macro-p) - (let* ((list (if (memq macro-p '(nil subr)) - byte-compile-function-environment - byte-compile-macro-environment)) - (env (cdr (assq name list)))) - (or env - (let ((fn name)) - (while (and (symbolp fn) - (fboundp fn) - (or (symbolp (symbol-function fn)) - (consp (symbol-function fn)) - (and (not macro-p) - (compiled-function-p (symbol-function fn))) - (and (eq macro-p 'subr) (subrp fn)))) - (setq fn (symbol-function fn))) - (if (or (and (not macro-p) (compiled-function-p fn)) - (and (eq macro-p 'subr) (subrp fn))) - fn - (and (consp fn) - (not (eq macro-p 'subr)) - (if (eq 'macro (car fn)) - (cdr fn) - (if macro-p - nil - (if (eq 'autoload (car fn)) - nil - fn))))))))) - -(defun byte-compile-arglist-signature (arglist) - (let ((args 0) - opts - restp) - (while arglist - (cond ((eq (car arglist) '&optional) - (or opts (setq opts 0))) - ((eq (car arglist) '&rest) - (if (cdr arglist) - (setq restp t - arglist nil))) - (t - (if opts - (setq opts (1+ opts)) - (setq args (1+ args))))) - (setq arglist (cdr arglist))) - (cons args (if restp nil (if opts (+ args opts) args))))) - - -(defun byte-compile-arglist-signatures-congruent-p (old new) - (not (or - (> (car new) (car old)) ; requires more args now - (and (null (cdr old)) ; tooks rest-args, doesn't any more - (cdr new)) - (and (cdr new) (cdr old) ; can't take as many args now - (< (cdr new) (cdr old))) - ))) - -(defun byte-compile-arglist-signature-string (signature) - (cond ((null (cdr signature)) - (format "%d+" (car signature))) - ((= (car signature) (cdr signature)) - (format "%d" (car signature))) - (t (format "%d-%d" (car signature) (cdr signature))))) - - -;; Warn if the form is calling a function with the wrong number of arguments. -(defun byte-compile-callargs-warn (form) - (let* ((def (or (byte-compile-fdefinition (car form) nil) - (byte-compile-fdefinition (car form) t))) - (sig (and def (byte-compile-arglist-signature - (if (eq 'lambda (car-safe def)) - (nth 1 def) - (if (compiled-function-p def) - (compiled-function-arglist def) - '(&rest def)))))) - (ncall (length (cdr form)))) - (if (and (null def) - (fboundp 'subr-min-args) - (setq def (byte-compile-fdefinition (car form) 'subr))) - (setq sig (cons (subr-min-args def) (subr-max-args def)))) - (if sig - (if (or (< ncall (car sig)) - (and (cdr sig) (> ncall (cdr sig)))) - (byte-compile-warn - "%s called with %d argument%s, but %s %s" - (car form) ncall - (if (= 1 ncall) "" "s") - (if (< ncall (car sig)) - "requires" - "accepts only") - (byte-compile-arglist-signature-string sig))) - (or (fboundp (car form)) ; might be a subr or autoload. - ;; ## this doesn't work with recursion. - (eq (car form) byte-compile-current-form) - ;; It's a currently-undefined function. - ;; Remember number of args in call. - (let ((cons (assq (car form) byte-compile-unresolved-functions)) - (n (length (cdr form)))) - (if cons - (or (memq n (cdr cons)) - (setcdr cons (cons n (cdr cons)))) - (setq byte-compile-unresolved-functions - (cons (list (car form) n) - byte-compile-unresolved-functions)))))))) - -;; Warn if the function or macro is being redefined with a different -;; number of arguments. -(defun byte-compile-arglist-warn (form macrop) - (let ((old (byte-compile-fdefinition (nth 1 form) macrop))) - (if old - (let ((sig1 (byte-compile-arglist-signature - (if (eq 'lambda (car-safe old)) - (nth 1 old) - (if (compiled-function-p old) - (compiled-function-arglist old) - '(&rest def))))) - (sig2 (byte-compile-arglist-signature (nth 2 form)))) - (or (byte-compile-arglist-signatures-congruent-p sig1 sig2) - (byte-compile-warn "%s %s used to take %s %s, now takes %s" - (if (eq (car form) 'defun) "function" "macro") - (nth 1 form) - (byte-compile-arglist-signature-string sig1) - (if (equal sig1 '(1 . 1)) "argument" "arguments") - (byte-compile-arglist-signature-string sig2)))) - ;; This is the first definition. See if previous calls are compatible. - (let ((calls (assq (nth 1 form) byte-compile-unresolved-functions)) - nums sig min max) - (if calls - (progn - (setq sig (byte-compile-arglist-signature (nth 2 form)) - nums (sort (copy-sequence (cdr calls)) (function <)) - min (car nums) - max (car (nreverse nums))) - (if (or (< min (car sig)) - (and (cdr sig) (> max (cdr sig)))) - (byte-compile-warn - "%s being defined to take %s%s, but was previously called with %s" - (nth 1 form) - (byte-compile-arglist-signature-string sig) - (if (equal sig '(1 . 1)) " arg" " args") - (byte-compile-arglist-signature-string (cons min max)))) - - (setq byte-compile-unresolved-functions - (delq calls byte-compile-unresolved-functions))))) - ))) - -;; If we have compiled any calls to functions which are not known to be -;; defined, issue a warning enumerating them. -;; `unresolved' in the list `byte-compile-warnings' disables this. -(defun byte-compile-warn-about-unresolved-functions (&optional msg) - (if (memq 'unresolved byte-compile-warnings) - (let ((byte-compile-current-form (or msg "the end of the data"))) - ;; First delete the autoloads from the list. - (if byte-compile-autoload-environment - (let ((rest byte-compile-unresolved-functions)) - (while rest - (if (assq (car (car rest)) byte-compile-autoload-environment) - (setq byte-compile-unresolved-functions - (delq (car rest) byte-compile-unresolved-functions))) - (setq rest (cdr rest))))) - ;; Now warn. - (if (cdr byte-compile-unresolved-functions) - (let* ((str "The following functions are not known to be defined: ") - (L (+ (length str) 5)) - (rest (reverse byte-compile-unresolved-functions)) - s) - (while rest - (setq s (symbol-name (car (car rest))) - L (+ L (length s) 2) - rest (cdr rest)) - (if (<= L (1- fill-column)) - (setq str (concat str " " s (and rest ","))) - (setq str (concat str "\n " s (and rest ",")) - L (+ (length s) 4)))) - (byte-compile-warn "%s" str)) - (if byte-compile-unresolved-functions - (byte-compile-warn "the function %s is not known to be defined." - (car (car byte-compile-unresolved-functions))))))) - nil) - -(defun byte-compile-defvar-p (var) - ;; Whether the byte compiler thinks that nonexical references to this - ;; variable are ok. - (or (globally-boundp var) - (let ((rest byte-compile-bound-variables)) - (while (and rest var) - (if (and (eq var (car-safe (car rest))) - (not (= 0 (logand (cdr (car rest)) - byte-compile-global-bit)))) - (setq var nil)) - (setq rest (cdr rest))) - ;; if var is nil at this point, it's a defvar in this file. - (not var)))) - - -;;; If we have compiled bindings of variables which have no referents, warn. -(defun byte-compile-warn-about-unused-variables () - (let ((rest byte-compile-bound-variables) - (unreferenced '()) - cell) - (while (and rest - ;; only warn about variables whose lifetime is now ending, - ;; that is, variables from the lexical scope that is now - ;; terminating. (Think nested lets.) - (not (eq (car rest) 'new-scope))) - (setq cell (car rest)) - (if (and (= 0 (logand byte-compile-referenced-bit (cdr cell))) - ;; Don't warn about declared-but-unused arguments, - ;; for two reasons: first, the arglist structure - ;; might be imposed by external forces, and we don't - ;; 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 - ;; containing a reference to arg, so every inline - ;; expansion would generate a warning. (If we had - ;; `ignore' then inline expansion could emit an - ;; ignore declaration.) - (= 0 (logand byte-compile-arglist-bit (cdr cell))) - ;; Don't warn about defvars because this is a - ;; legitimate special binding. - (not (byte-compile-defvar-p (car cell)))) - (setq unreferenced (cons (car cell) unreferenced))) - (setq rest (cdr rest))) - (setq unreferenced (nreverse unreferenced)) - (while unreferenced - (byte-compile-warn - (format "variable %s bound but not referenced" (car unreferenced))) - (setq unreferenced (cdr unreferenced))))) - - -(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)))))) - -(defmacro byte-compile-close-variables (&rest body) - (cons 'let - (cons '(;; - ;; Close over these variables to encapsulate the - ;; compilation state - ;; - (byte-compile-macro-environment - ;; Copy it because the compiler may patch into the - ;; macroenvironment. - (copy-alist byte-compile-initial-macro-environment)) - (byte-compile-function-environment nil) - (byte-compile-autoload-environment nil) - (byte-compile-unresolved-functions nil) - (byte-compile-bound-variables nil) - (byte-compile-free-references nil) - (byte-compile-free-assignments nil) - ;; - ;; Close over these variables so that `byte-compiler-options' - ;; can change them on a per-file basis. - ;; - (byte-compile-verbose byte-compile-verbose) - (byte-optimize byte-optimize) - (byte-compile-emacs19-compatibility - byte-compile-emacs19-compatibility) - (byte-compile-dynamic byte-compile-dynamic) - (byte-compile-dynamic-docstrings - byte-compile-dynamic-docstrings) - (byte-compile-warnings (if (eq byte-compile-warnings t) - byte-compile-default-warnings - byte-compile-warnings)) - (byte-compile-file-domain nil) - ) - (list - (list 'prog1 (cons 'progn body) - '(if (memq 'unused-vars byte-compile-warnings) - ;; done compiling in this scope, warn now. - (byte-compile-warn-about-unused-variables))))))) - - -(defvar byte-compile-warnings-point-max nil) -(defmacro displaying-byte-compile-warnings (&rest body) - (list 'let - '((byte-compile-warnings-point-max byte-compile-warnings-point-max)) - ;; Log the file 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)))) - (list 'unwind-protect - (list 'condition-case 'error-info - (cons '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 - (select-window - (prog1 (selected-window) - (select-window (display-buffer (current-buffer))) - (goto-char byte-compile-warnings-point-max) - (recenter 1)))))))) - - -;;;###autoload -(defun byte-force-recompile (directory) - "Recompile every `.el' file in DIRECTORY that already has a `.elc' file. -Files in subdirectories of DIRECTORY are processed also." - (interactive "DByte force recompile (directory): ") - (byte-recompile-directory directory nil t)) - -;;;###autoload -(defun byte-recompile-directory (directory &optional arg norecursion force) - "Recompile every `.el' file in DIRECTORY that needs recompilation. -This is if a `.elc' file exists but is older than the `.el' file. -Files in subdirectories of DIRECTORY are processed also unless argument -NORECURSION is non-nil. - -If the `.elc' file does not exist, normally the `.el' file is *not* compiled. -But a prefix argument (optional second arg) means ask user, -for each such `.el' file, whether to compile it. Prefix argument 0 means -don't ask and compile the file anyway. - -A nonzero prefix argument also means ask about each subdirectory. - -If the fourth argument FORCE is non-nil, -recompile every `.el' file that already has a `.elc' file." - (interactive "DByte recompile directory: \nP") - (if arg - (setq arg (prefix-numeric-value arg))) - (if noninteractive - nil - (save-some-buffers) - (redraw-modeline)) - (let ((directories (list (expand-file-name directory))) - (file-count 0) - (dir-count 0) - last-dir) - (displaying-byte-compile-warnings - (while directories - (setq directory (file-name-as-directory (car directories))) - (or noninteractive (message "Checking %s..." directory)) - (let ((files (directory-files directory)) - source dest) - (while files - (setq source (expand-file-name (car files) directory)) - (if (and (not (member (car files) '("." ".." "RCS" "CVS" "SCCS"))) - ;; Stay away from directory back-links, etc: - (not (file-symlink-p source)) - (file-directory-p source) - byte-recompile-directory-recursively) - ;; This file is a subdirectory. Handle them differently. - (if (or (null arg) - (eq arg 0) - (y-or-n-p (concat "Check " source "? "))) - (setq directories - (nconc directories (list source)))) - ;; It is an ordinary file. Decide whether to compile it. - (if (and (string-match emacs-lisp-file-regexp source) - (not (auto-save-file-name-p source)) - (setq dest (byte-compile-dest-file source)) - (if (file-exists-p dest) - ;; File was already compiled. - (or force (file-newer-than-file-p source dest)) - ;; No compiled file exists yet. - (and arg - (or (eq 0 arg) - (y-or-n-p (concat "Compile " source "? ")))))) - (progn ;(if (and noninteractive (not byte-compile-verbose)) - ; (message "Compiling %s..." source)) - ; we do this in byte-compile-file. - (if byte-recompile-directory-ignore-errors-p - (batch-byte-compile-1 source) - (byte-compile-file source)) - (or noninteractive - (message "Checking %s..." directory)) - (setq file-count (1+ file-count)) - (if (not (eq last-dir directory)) - (setq last-dir directory - dir-count (1+ dir-count))) - ))) - (setq files (cdr files)))) - (setq directories (cdr directories)))) - (message "Done (Total of %d file%s compiled%s)" - file-count (if (= file-count 1) "" "s") - (if (> dir-count 1) (format " in %d directories" dir-count) "")))) - -;;;###autoload -(defun byte-recompile-file (filename &optional force) - "Recompile a file of Lisp code named FILENAME if it needs recompilation. -This is if the `.elc' file exists but is older than the `.el' file. - -If the `.elc' file does not exist, normally the `.el' file is *not* -compiled. But a prefix argument (optional second arg) means ask user -whether to compile it. Prefix argument 0 don't ask and recompile anyway." - (interactive "fByte recompile file: \nP") - (let ((dest)) - (if (and (string-match emacs-lisp-file-regexp filename) - (not (auto-save-file-name-p filename)) - (setq dest (byte-compile-dest-file filename)) - (if (file-exists-p dest) - (file-newer-than-file-p filename dest) - (and force - (or (eq 0 force) - (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. -The output file's name is made by appending `c' to the end of FILENAME. -With prefix arg (noninteractively: 2nd arg), load the file after compiling." -;; (interactive "fByte compile file: \nP") - (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 (if current-prefix-arg - "Byte compile and load file: " - "Byte compile file: ") - file-dir nil nil file-name) - current-prefix-arg))) - ;; Expand now so we get the current buffer's defaults - (setq filename (expand-file-name filename)) - - ;; If we're compiling 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 byte-compile-verbose) ; XEmacs change - (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)) - (setq byte-compile-dest-file target-file) - (save-excursion - (setq input-buffer (get-buffer-create " *Compiler 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))) - (setq byte-compiler-error-flag nil) - ;; It is important that input-buffer not be current at this call, - ;; so that the value of point set in input-buffer - ;; within byte-compile-from-buffer lingers in that buffer. - (setq output-buffer (byte-compile-from-buffer input-buffer filename)) - (if byte-compiler-error-flag - nil - (if byte-compile-verbose - (message "Compiling %s...done" filename)) - (kill-buffer input-buffer) - (save-excursion - (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)))) - (kill-buffer (current-buffer))) - (if (and byte-compile-generate-call-tree - (or (eq t byte-compile-generate-call-tree) - (y-or-n-p (format "Report call tree for %s? " filename)))) - (save-excursion - (display-call-tree filename))) - (if load - (load target-file)) - t))) - -;; RMS comments the next two out. -(defun byte-compile-and-load-file (&optional filename) - "Compile a file of Lisp code named FILENAME into a file of byte code, -and then load it. The output file's name is made by appending \"c\" to -the end of FILENAME." - (interactive) - (if filename ; I don't get it, (interactive-p) doesn't always work - (byte-compile-file filename t) - (let ((current-prefix-arg '(4))) - (call-interactively 'byte-compile-file)))) - -(defun byte-compile-buffer (&optional buffer) - "Byte-compile and evaluate contents of BUFFER (default: the current buffer)." - (interactive "bByte compile buffer: ") - (setq buffer (if buffer (get-buffer buffer) (current-buffer))) - (message "Compiling %s..." (buffer-name buffer)) - (let* ((filename (or (buffer-file-name buffer) - (concat "#<buffer " (buffer-name buffer) ">"))) - (byte-compile-current-file buffer)) - (byte-compile-from-buffer buffer filename t)) - (message "Compiling %s...done" (buffer-name buffer)) - t) - -;;; compiling a single function -;;;###autoload -(defun compile-defun (&optional arg) - "Compile and evaluate the current top-level form. -Print the result in the minibuffer. -With argument, insert value in current buffer after the form." - (interactive "P") - (save-excursion - (end-of-defun) - (beginning-of-defun) - (let* ((byte-compile-current-file (buffer-file-name)) - (load-file-name (buffer-file-name)) - (byte-compile-last-warned-form 'nothing) - (value (eval (displaying-byte-compile-warnings - (byte-compile-sexp (read (current-buffer)) - "toplevel forms"))))) - (cond (arg - (message "Compiling from buffer... done.") - (prin1 value (current-buffer)) - (insert "\n")) - ((message "%s" (prin1-to-string value))))))) - -(defvar byte-compile-inbuffer) -(defvar byte-compile-outbuffer) - -(defun byte-compile-from-buffer (byte-compile-inbuffer filename &optional eval) - ;; buffer --> output-buffer, or buffer --> eval form, return nil - (let (byte-compile-outbuffer - ;; Prevent truncation of flonums and lists as we read and print them - (float-output-format nil) - (case-fold-search nil) - (print-length nil) - (print-level nil) - ;; Simulate entry to byte-compile-top-level - (byte-compile-constants nil) - (byte-compile-variables nil) - (byte-compile-tag-number 0) - (byte-compile-depth 0) - (byte-compile-maxdepth 0) - (byte-compile-output nil) - ;; #### This is bound in b-c-close-variables. - ;; (byte-compile-warnings (if (eq byte-compile-warnings t) - ;; byte-compile-warning-types - ;; byte-compile-warnings)) - ) - (byte-compile-close-variables - (save-excursion - (setq byte-compile-outbuffer - (set-buffer (get-buffer-create " *Compiler Output*"))) - (erase-buffer) - ;; (emacs-lisp-mode) - (setq case-fold-search nil) - (and filename - (not eval) - (byte-compile-insert-header filename - byte-compile-inbuffer - byte-compile-outbuffer)) - - ;; This is a kludge. Some operating systems (OS/2, DOS) need to - ;; write files containing binary information specially. - ;; Under most circumstances, such files will be in binary - ;; overwrite mode, so those OS's use that flag to guess how - ;; they should write their data. Advise them that .elc files - ;; need to be written carefully. - (setq overwrite-mode 'overwrite-mode-binary)) - (displaying-byte-compile-warnings - (save-excursion - (set-buffer byte-compile-inbuffer) - (goto-char 1) - - ;; Compile the forms from the input buffer. - (while (progn - (while (progn (skip-chars-forward " \t\n\^l") - (looking-at ";")) - (forward-line 1)) - (not (eobp))) - (byte-compile-file-form (read byte-compile-inbuffer))) - - ;; Compile pending forms at end of file. - (byte-compile-flush-pending) - (byte-compile-warn-about-unresolved-functions) - ;; SHould we always do this? When calling multiple files, it - ;; would be useful to delay this warning until all have - ;; been compiled. - (setq byte-compile-unresolved-functions nil))) - (save-excursion - (set-buffer byte-compile-outbuffer) - (goto-char (point-min)))) - (if (not eval) - byte-compile-outbuffer - (let (form) - (while (condition-case nil - (progn (setq form (read byte-compile-outbuffer)) - t) - (end-of-file nil)) - (eval form))) - (kill-buffer byte-compile-outbuffer) - nil))) - -(defun byte-compile-insert-header (filename byte-compile-inbuffer - byte-compile-outbuffer) - (set-buffer byte-compile-inbuffer) - (let ((dynamic-docstrings byte-compile-dynamic-docstrings)) - (set-buffer byte-compile-outbuffer) - (goto-char 1) - ;; - ;; The magic number of .elc files is ";ELC", or 0x3B454C43. After that is - ;; the file-format version number (19 or 20) as a byte, followed by some - ;; nulls. The primary motivation for doing this is to get some binary - ;; characters up in the first line of the file so that `diff' will simply - ;; say "Binary files differ" instead of actually doing a diff of two .elc - ;; files. An extra benefit is that you can add this to /etc/magic: - ;; - ;; 0 string ;ELC GNU Emacs Lisp compiled file, - ;; >4 byte x version %d - ;; - (insert - ";ELC" - (if (byte-compile-version-cond byte-compile-emacs19-compatibility) 19 20) - "\000\000\000\n" - ) - (insert ";;; compiled by " - (or (and (boundp 'user-mail-address) user-mail-address) - (concat (user-login-name) "@" (system-name))) - " on " - (current-time-string) "\n;;; from file " filename "\n") - (insert ";;; emacs version " emacs-version ".\n") - (insert ";;; bytecomp version " byte-compile-version "\n;;; " - (cond - ((eq byte-optimize 'source) "source-level optimization only") - ((eq byte-optimize 'byte) "byte-level optimization only") - (byte-optimize "optimization is on") - (t "optimization is off")) - (if (byte-compile-version-cond byte-compile-emacs19-compatibility) - "; compiled with Emacs 19 compatibility.\n" - ".\n")) - (if (not (byte-compile-version-cond byte-compile-emacs19-compatibility)) - (insert ";;; this file uses opcodes which do not exist in Emacs 19.\n" - ;; Have to check if emacs-version is bound so that this works - ;; in files loaded early in loadup.el. - "\n(if (and (boundp 'emacs-version)\n" - "\t (or (and (boundp 'epoch::version) epoch::version)\n" - "\t (string-lessp emacs-version \"20\")))\n" - " (error \"`" - ;; prin1-to-string is used to quote backslashes. - (substring (prin1-to-string (file-name-nondirectory filename)) - 1 -1) - "' was compiled for Emacs 20\"))\n\n")) - (insert "(or (boundp 'current-load-list) (setq current-load-list nil))\n" - "\n") - (if (and (byte-compile-version-cond byte-compile-emacs19-compatibility) - dynamic-docstrings) - (insert ";;; this file uses opcodes which do not exist prior to\n" - ";;; XEmacs 19.14/GNU Emacs 19.29 or later." - ;; Have to check if emacs-version is bound so that this works - ;; in files loaded early in loadup.el. - "\n(if (and (boundp 'emacs-version)\n" - "\t (or (and (boundp 'epoch::version) epoch::version)\n" - "\t (and (not (string-match \"XEmacs\" emacs-version))\n" - "\t (string-lessp emacs-version \"19.29\"))\n" - "\t (string-lessp emacs-version \"19.14\")))\n" - " (error \"`" - ;; prin1-to-string is used to quote backslashes. - (substring (prin1-to-string (file-name-nondirectory filename)) - 1 -1) - "' was compiled for XEmacs 19.14/Emacs 19.29 or later\"))\n\n" - ) - )) - - ;; back in the inbuffer; determine and set the coding system for the .elc - ;; file if under Mule. If there are any extended characters in the - ;; input file, use `escape-quoted' to make sure that both binary and - ;; 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 - (set-buffer byte-compile-inbuffer) - (setq byte-compile-dynamic nil - byte-compile-dynamic-docstrings nil)) - ;;(external-debugging-output (prin1-to-string (buffer-local-variables)))) - )) - ) - - -(defun byte-compile-output-file-form (form) - ;; writes the given form to the output buffer, being careful of docstrings - ;; in defun, defmacro, defvar, defconst and autoload because make-docfile is - ;; so amazingly stupid. - ;; defalias calls are output directly by byte-compile-file-form-defmumble; - ;; it does not pay to first build the defalias in defmumble and then parse - ;; it here. - (if (and (memq (car-safe form) '(defun defmacro defvar defconst autoload)) - (stringp (nth 3 form))) - (byte-compile-output-docform nil nil '("\n(" 3 ")") form nil - (eq (car form) 'autoload)) - (let ((print-escape-newlines t) - (print-length nil) - (print-level nil) - (print-readably t) ; print #[] for bytecode, 'x for (quote x) - (print-gensym nil)) ; this is too dangerous for now - (princ "\n" byte-compile-outbuffer) - (prin1 form byte-compile-outbuffer) - nil))) - -(defun byte-compile-output-docform (preface name info form specindex quoted) - "Print a form with a doc string. INFO is (prefix doc-index postfix). -If PREFACE and NAME are non-nil, print them too, -before INFO and the FORM but after the doc string itself. -If SPECINDEX is non-nil, it is the index in FORM -of the function bytecode string. In that case, -we output that argument and the following argument (the constants vector) -together, for lazy loading. -QUOTED says that we have to put a quote before the -list that represents a doc string reference. -`autoload' needs that." - ;; We need to examine byte-compile-dynamic-docstrings - ;; in the input buffer (now current), not in the output buffer. - (let ((dynamic-docstrings byte-compile-dynamic-docstrings)) - (set-buffer - (prog1 (current-buffer) - (set-buffer byte-compile-outbuffer) - (let (position) - - ;; Insert the doc string, and make it a comment with #@LENGTH. - (and (>= (nth 1 info) 0) - dynamic-docstrings - (progn - ;; Make the doc string start at beginning of line - ;; for make-docfile's sake. - (insert "\n") - (setq position - (byte-compile-output-as-comment - (nth (nth 1 info) form) nil)) - ;; If the doc string starts with * (a user variable), - ;; negate POSITION. - (if (and (stringp (nth (nth 1 info) form)) - (> (length (nth (nth 1 info) form)) 0) - (char= (aref (nth (nth 1 info) form) 0) ?*)) - (setq position (- position))))) - - (if preface - (progn - (insert preface) - (prin1 name byte-compile-outbuffer))) - (insert (car info)) - (let ((print-escape-newlines t) - (print-readably t) ; print #[] for bytecode, 'x for (quote x) - (print-gensym nil) ; this is too dangerous for now - (index 0)) - (prin1 (car form) byte-compile-outbuffer) - (while (setq form (cdr form)) - (setq index (1+ index)) - (insert " ") - (cond ((and (numberp specindex) (= index specindex)) - (let ((position - (byte-compile-output-as-comment - (cons (car form) (nth 1 form)) - t))) - (princ (format "(#$ . %d) nil" position) - byte-compile-outbuffer) - (setq form (cdr form)) - (setq index (1+ index)))) - ((= index (nth 1 info)) - (if position - (princ (format (if quoted "'(#$ . %d)" "(#$ . %d)") - position) - byte-compile-outbuffer) - (let ((print-escape-newlines nil)) - (goto-char (prog1 (1+ (point)) - (prin1 (car form) - byte-compile-outbuffer))) - (insert "\\\n") - (goto-char (point-max))))) - (t - (prin1 (car form) byte-compile-outbuffer))))) - (insert (nth 2 info)))))) - nil) - -(defvar for-effect) ; ## Kludge! This should be an arg, not a special. - -(defun byte-compile-keep-pending (form &optional handler) - (if (memq byte-optimize '(t source)) - (setq form (byte-optimize-form form t))) - (if handler - (let ((for-effect t)) - ;; To avoid consing up monstrously large forms at load time, we split - ;; the output regularly. - (and (memq (car-safe form) '(fset defalias define-function)) - (nthcdr 300 byte-compile-output) - (byte-compile-flush-pending)) - (funcall handler form) - (if for-effect - (byte-compile-discard))) - (byte-compile-form form t)) - nil) - -(defun byte-compile-flush-pending () - (if byte-compile-output - (let ((form (byte-compile-out-toplevel t 'file))) - (cond ((eq (car-safe form) 'progn) - (mapcar 'byte-compile-output-file-form (cdr form))) - (form - (byte-compile-output-file-form form))) - (setq byte-compile-constants nil - byte-compile-variables nil - byte-compile-depth 0 - byte-compile-maxdepth 0 - byte-compile-output nil)))) - -(defun byte-compile-file-form (form) - (let ((byte-compile-current-form nil) ; close over this for warnings. - handler) - (cond - ((not (consp form)) - (byte-compile-keep-pending form)) - ((and (symbolp (car form)) - (setq handler (get (car form) 'byte-hunk-handler))) - (cond ((setq form (funcall handler form)) - (byte-compile-flush-pending) - (byte-compile-output-file-form form)))) - ((eq form (setq form (macroexpand form byte-compile-macro-environment))) - (byte-compile-keep-pending form)) - (t - (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 -;; as byte-code. - -(put 'defsubst 'byte-hunk-handler 'byte-compile-file-form-defsubst) -(defun byte-compile-file-form-defsubst (form) - (cond ((assq (nth 1 form) byte-compile-unresolved-functions) - (setq byte-compile-current-form (nth 1 form)) - (byte-compile-warn "defsubst %s was used before it was defined" - (nth 1 form)))) - (byte-compile-file-form - (macroexpand form byte-compile-macro-environment)) - ;; Return nil so the form is not output twice. - nil) - -(put 'autoload 'byte-hunk-handler 'byte-compile-file-form-autoload) -(defun byte-compile-file-form-autoload (form) - ;; - ;; If this is an autoload of a macro, and all arguments are constants (that - ;; is, there is no hairy computation going on here) then evaluate the form - ;; at compile-time. This is so that we can make use of macros which we - ;; have autoloaded from the file being compiled. Normal function autoloads - ;; are not automatically evaluated at compile time, because there's not - ;; much point to it (so why bother cluttering up the compile-time namespace.) - ;; - ;; If this is an autoload of a function, then record its definition in the - ;; byte-compile-autoload-environment to suppress any `not known to be - ;; defined' warnings at the end of this file (this only matters for - ;; functions which are autoloaded and compiled in the same file, if the - ;; autoload already exists in the compilation environment, we wouldn't have - ;; warned anyway.) - ;; - (let* ((name (if (byte-compile-constp (nth 1 form)) - (eval (nth 1 form)))) - ;; In v19, the 5th arg to autoload can be t, nil, 'macro, or 'keymap. - (macrop (and (byte-compile-constp (nth 5 form)) - (memq (eval (nth 5 form)) '(t macro)))) -;; (functionp (and (byte-compile-constp (nth 5 form)) -;; (eq 'nil (eval (nth 5 form))))) - ) - (if (and macrop - (let ((form form)) - ;; all forms are constant - (while (if (setq form (cdr form)) - (byte-compile-constp (car form)))) - (null form))) - ;; eval the macro autoload into the compilation enviroment - (eval form)) - - (if name - (let ((old (assq name byte-compile-autoload-environment))) - (cond (old - (if (memq 'redefine byte-compile-warnings) - (byte-compile-warn "multiple autoloads for %s" name)) - (setcdr old form)) - (t - ;; We only use the names in the autoload environment, but - ;; it might be useful to have the bodies some day. - (setq byte-compile-autoload-environment - (cons (cons name form) - byte-compile-autoload-environment))))))) - ;; - ;; Now output the form. - (if (stringp (nth 3 form)) - form - ;; No doc string, so we can compile this as a normal form. - (byte-compile-keep-pending form 'byte-compile-normal-call))) - -(put 'defvar 'byte-hunk-handler 'byte-compile-file-form-defvar) -(put 'defconst 'byte-hunk-handler 'byte-compile-file-form-defvar) -(defun byte-compile-file-form-defvar (form) - (if (> (length form) 4) - (byte-compile-warn "%s used with too many args (%s)" - (car form) (nth 1 form))) - (if (and (> (length form) 3) (not (stringp (nth 3 form)))) - (byte-compile-warn "Third arg to %s %s is not a string: %s" - (car form) (nth 1 form) (nth 3 form))) - (if (null (nth 3 form)) - ;; Since there is no doc string, we can compile this as a normal form, - ;; and not do a file-boundary. - (byte-compile-keep-pending form) - (if (memq 'free-vars byte-compile-warnings) - (setq byte-compile-bound-variables - (cons (cons (nth 1 form) byte-compile-global-bit) - byte-compile-bound-variables))) - (cond ((consp (nth 2 form)) - (setq form (copy-sequence form)) - (setcar (cdr (cdr form)) - (byte-compile-top-level (nth 2 form) nil 'file)))) - - ;; The following turns out not to be necessary, since we emit a call to - ;; defvar, which can hack Vfile_domain by itself! - ;; - ;; If a file domain has been set, emit (put 'VAR 'variable-domain ...) - ;; after this defvar. -; (if byte-compile-file-domain -; (progn -; ;; Actually, this will emit the (put ...) before the (defvar ...) -; ;; but I don't think that can matter in this case. -; (byte-compile-keep-pending -; (list 'put (list 'quote (nth 1 form)) ''variable-domain -; (list 'quote byte-compile-file-domain))))) - form)) - -(put 'require 'byte-hunk-handler 'byte-compile-file-form-eval-boundary) -(defun byte-compile-file-form-eval-boundary (form) - (eval form) - (byte-compile-keep-pending form 'byte-compile-normal-call)) - -(put 'progn 'byte-hunk-handler 'byte-compile-file-form-progn) -(put 'prog1 'byte-hunk-handler 'byte-compile-file-form-progn) -(put 'prog2 'byte-hunk-handler 'byte-compile-file-form-progn) -(defun byte-compile-file-form-progn (form) - (mapcar 'byte-compile-file-form (cdr form)) - ;; Return nil so the forms are not output twice. - nil) - -;; This handler is not necessary, but it makes the output from dont-compile -;; and similar macros cleaner. -(put 'eval 'byte-hunk-handler 'byte-compile-file-form-eval) -(defun byte-compile-file-form-eval (form) - (if (eq (car-safe (nth 1 form)) 'quote) - (nth 1 (nth 1 form)) - (byte-compile-keep-pending form))) - -(put 'defun 'byte-hunk-handler 'byte-compile-file-form-defun) -(defun byte-compile-file-form-defun (form) - (byte-compile-file-form-defmumble form nil)) - -(put 'defmacro 'byte-hunk-handler 'byte-compile-file-form-defmacro) -(defun byte-compile-file-form-defmacro (form) - (byte-compile-file-form-defmumble form t)) - -(defun byte-compile-compiled-obj-to-list (obj) - ;; #### this is fairly disgusting. Rewrite the code instead - ;; so that it doesn't create compiled objects in the first place! - ;; Much better than creating them and then "uncreating" them - ;; like this. - (read (concat "(" - (substring (let ((print-readably t)) - (prin1-to-string obj)) - 2 -1) - ")"))) - -(defun byte-compile-file-form-defmumble (form macrop) - (let* ((name (car (cdr form))) - (this-kind (if macrop 'byte-compile-macro-environment - 'byte-compile-function-environment)) - (that-kind (if macrop 'byte-compile-function-environment - 'byte-compile-macro-environment)) - (this-one (assq name (symbol-value this-kind))) - (that-one (assq name (symbol-value that-kind))) - (byte-compile-free-references nil) - (byte-compile-free-assignments nil)) - - ;; When a function or macro is defined, add it to the call tree so that - ;; we can tell when functions are not used. - (if byte-compile-generate-call-tree - (or (assq name byte-compile-call-tree) - (setq byte-compile-call-tree - (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))) - (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))) - (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)))) - ((and (fboundp name) - (or (subrp (symbol-function name)) - (eq (car-safe (symbol-function name)) - (if macrop 'lambda 'macro)))) - (if (memq 'redefine byte-compile-warnings) - (byte-compile-warn "%s %s being redefined as a %s" - (if (subrp (symbol-function name)) - "subr" - (if macrop "function" "macro")) - (nth 1 form) - (if macrop "macro" "function"))) - ;; shadow existing definition - (set 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))) - (car-safe (cdr-safe body)) - (stringp (car-safe (cdr-safe (cdr-safe body))))) - (byte-compile-warn "Probable `\"' without `\\' in doc string of %s" - (nth 1 form)))) - (let* ((new-one (byte-compile-lambda (cons 'lambda (nthcdr 2 form)))) - (code (byte-compile-byte-code-maker new-one))) - (if this-one - (setcdr this-one new-one) - (set this-kind - (cons (cons name new-one) (symbol-value this-kind)))) - (if (and (stringp (nth 3 form)) - (eq 'quote (car-safe code)) - (eq 'lambda (car-safe (nth 1 code)))) - (cons (car form) - (cons name (cdr (nth 1 code)))) - (byte-compile-flush-pending) - (if (not (stringp (nth 3 form))) - ;; No doc string. Provide -1 as the "doc string index" - ;; so that no element will be treated as a doc string. - (byte-compile-output-docform - "\n(defalias '" - name - (cond ((atom code) - (if macrop '(" '(macro . #[" -1 "])") '(" #[" -1 "]"))) - ((eq (car code) 'quote) - (setq code new-one) - (if macrop '(" '(macro " -1 ")") '(" '(" -1 ")"))) - ((if macrop '(" (cons 'macro (" -1 "))") '(" (" -1 ")")))) - ;; FSF just calls `(append code nil)' here but that relies - ;; on horrible C kludges in concat() that accept byte- - ;; compiled objects and pretend they're vectors. - (if (compiled-function-p code) - (byte-compile-compiled-obj-to-list code) - (append code nil)) - (and (atom code) byte-compile-dynamic - 1) - nil) - ;; Output the form by hand, that's much simpler than having - ;; b-c-output-file-form analyze the defalias. - (byte-compile-output-docform - "\n(defalias '" - name - (cond ((atom code) ; compiled-function-p - (if macrop '(" '(macro . #[" 4 "])") '(" #[" 4 "]"))) - ((eq (car code) 'quote) - (setq code new-one) - (if macrop '(" '(macro " 2 ")") '(" '(" 2 ")"))) - ((if macrop '(" (cons 'macro (" 5 "))") '(" (" 5 ")")))) - ;; The result of byte-compile-byte-code-maker is either a - ;; compiled-function object, or a list of some kind. If it's - ;; not a cons, we must coerce it into a list of the elements - ;; to be printed to the file. - (if (consp code) - code - (nconc (list - (compiled-function-arglist code) - (compiled-function-instructions code) - (compiled-function-constants code) - (compiled-function-stack-depth code)) - (let ((doc (documentation code t))) - (if doc (list doc))) - (if (commandp code) - (list (nth 1 (compiled-function-interactive code)))))) - (and (atom code) byte-compile-dynamic - 1) - nil)) - (princ ")" byte-compile-outbuffer) - nil)))) - -;; Print Lisp object EXP in the output file, inside a comment, -;; and return the file position it will have. -;; If QUOTED is non-nil, print with quoting; otherwise, print without quoting. -(defun byte-compile-output-as-comment (exp quoted) - (let ((position (point))) - (set-buffer - (prog1 (current-buffer) - (set-buffer byte-compile-outbuffer) - - ;; Insert EXP, and make it a comment with #@LENGTH. - (insert " ") - (if quoted - (prin1 exp byte-compile-outbuffer) - (princ exp byte-compile-outbuffer)) - (goto-char position) - ;; Quote certain special characters as needed. - ;; get_doc_string in doc.c does the unquoting. - (while (search-forward "\^A" nil t) - (replace-match "\^A\^A" t t)) - (goto-char position) - (while (search-forward "\000" nil t) - (replace-match "\^A0" t t)) - (goto-char position) - (while (search-forward "\037" nil t) - (replace-match "\^A_" t t)) - (goto-char (point-max)) - (insert "\037") - (goto-char position) - (insert "#@" (format "%d" (- (point-max) position))) - - ;; Save the file position of the object. - ;; Note we should add 1 to skip the space - ;; that we inserted before the actual doc string, - ;; and subtract 1 to convert from an 1-origin Emacs position - ;; to a file position; they cancel. - (setq position (point)) - (goto-char (point-max)))) - position)) - - - -;; The `domain' declaration. This is legal only at top-level in a file, and -;; should generally be the first form in the file. It is not legal inside -;; function bodies. - -(put 'domain 'byte-hunk-handler 'byte-compile-file-form-domain) -(defun byte-compile-file-form-domain (form) - (if (not (null (cdr (cdr form)))) - (byte-compile-warn "domain used with too many arguments: %s" form)) - (let ((domain (nth 1 form))) - (or (null domain) - (stringp domain) - (progn - (byte-compile-warn - "argument to `domain' declaration must be a literal string: %s" - form) - (setq domain nil))) - (setq byte-compile-file-domain domain)) - (byte-compile-keep-pending form 'byte-compile-normal-call)) - -(defun byte-compile-domain (form) - (byte-compile-warn "The `domain' declaration is legal only at top-level: %s" - (let ((print-escape-newlines t) - (print-level 4) - (print-length 4)) - (prin1-to-string form))) - (byte-compile-normal-call - (list 'signal ''error - (list 'quote (list "`domain' used inside a function" form))))) - -;; This is part of bytecomp.el in 19.35: -(put 'custom-declare-variable 'byte-hunk-handler - 'byte-compile-file-form-custom-declare-variable) -(defun byte-compile-file-form-custom-declare-variable (form) - (if (memq 'free-vars byte-compile-warnings) - (setq byte-compile-bound-variables - (cons (cons (nth 1 (nth 1 form)) - byte-compile-global-bit) - byte-compile-bound-variables))) - form) - - -;;;###autoload -(defun byte-compile (form) - "If FORM is a symbol, byte-compile its function definition. -If FORM is a lambda or a macro, byte-compile it as a function." - (displaying-byte-compile-warnings - (byte-compile-close-variables - (let* ((fun (if (symbolp form) - (and (fboundp form) (symbol-function form)) - form)) - (macro (eq (car-safe fun) 'macro))) - (if macro - (setq fun (cdr fun))) - (cond ((eq (car-safe fun) 'lambda) - (setq fun (if macro - (cons 'macro (byte-compile-lambda fun)) - (byte-compile-lambda fun))) - (if (symbolp form) - (defalias form fun) - fun))))))) - -;;;###autoload -(defun byte-compile-sexp (sexp &optional msg) - "Compile and return SEXP." - (displaying-byte-compile-warnings - (byte-compile-close-variables - (prog1 - (byte-compile-top-level sexp) - (byte-compile-warn-about-unresolved-functions msg))))) - -;; Given a function made by byte-compile-lambda, make a form which produces it. -(defun byte-compile-byte-code-maker (fun) - (cond - ;; ## atom is faster than compiled-func-p. - ((atom fun) ; compiled-function-p - fun) - ;; b-c-lambda didn't produce a compiled-function, so it must be a trivial - ;; function. - ((let (tmp) - (if (and (setq tmp (assq 'byte-code (cdr-safe (cdr fun)))) - (null (cdr (memq tmp fun)))) - ;; Generate a make-byte-code call. - (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 - (cond ((stringp (nth 2 fun)) - (list (nth 2 fun))) ;doc - (interactive - (list nil))) - (cond (interactive - (list (if (or (null (nth 1 interactive)) - (stringp (nth 1 interactive))) - (nth 1 interactive) - ;; Interactive spec is a list or a variable - ;; (if it is correct). - (list 'quote (nth 1 interactive)))))))) - ;; a non-compiled function (probably trivial) - (list 'quote fun)))))) - -;; Byte-compile a lambda-expression and return a valid function. -;; The value is usually a compiled function but may be the original -;; lambda-expression. -(defun byte-compile-lambda (fun) - (or (eq 'lambda (car-safe fun)) - (error "not a lambda -- %s" (prin1-to-string fun))) - (let* ((arglist (nth 1 fun)) - (byte-compile-bound-variables - (let ((new-bindings - (mapcar (function (lambda (x) - (cons x byte-compile-arglist-bit))) - (and (memq 'free-vars byte-compile-warnings) - (delq '&rest (delq '&optional - (copy-sequence arglist))))))) - (nconc new-bindings - (cons 'new-scope byte-compile-bound-variables)))) - (body (cdr (cdr fun))) - (doc (if (stringp (car body)) - (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)))) - (cond (int - ;; Skip (interactive) if it is in front (the most usual location). - (if (eq int (car body)) - (setq body (cdr body))) - (cond ((consp (cdr int)) - (if (cdr (cdr int)) - (byte-compile-warn "malformed interactive spec: %s" - (prin1-to-string int))) - ;; If the interactive spec is a call to `list', - ;; don't compile it, because `call-interactively' - ;; looks at the args of `list'. - (let ((form (nth 1 int))) - (while (or (eq (car-safe form) 'let) - (eq (car-safe form) 'let*) - (eq (car-safe form) 'save-excursion)) - (while (consp (cdr form)) - (setq form (cdr form))) - (setq form (car form))) - (or (eq (car-safe form) 'list) - (setq int (list 'interactive - (byte-compile-top-level (nth 1 int))))))) - ((cdr int) - (byte-compile-warn "malformed interactive spec: %s" - (prin1-to-string int)))))) - (let ((compiled (byte-compile-top-level (cons 'progn body) nil 'lambda))) - (if (memq 'unused-vars byte-compile-warnings) - ;; done compiling in this scope, warn now. - (byte-compile-warn-about-unused-variables)) - (if (eq 'byte-code (car-safe compiled)) - (apply 'make-byte-code - (append (list arglist) - ;; byte-string, constants-vector, stack depth - (cdr compiled) - ;; optionally, the doc string. - (if (or doc int) - (list doc)) - ;; optionally, the interactive spec. - (if int - (list (nth 1 int))))) - (setq compiled - (nconc (if int (list int)) - (cond ((eq (car-safe compiled) 'progn) (cdr compiled)) - (compiled (list compiled))))) - (nconc (list 'lambda arglist) - (if (or doc (stringp (car compiled))) - (cons doc (cond (compiled) - (body (list nil)))) - compiled)))))) - -(defun byte-compile-constants-vector () - ;; Builds the constants-vector from the current variables and constants. - ;; This modifies the constants from (const . nil) to (const . offset). - ;; To keep the byte-codes to look up the vector as short as possible: - ;; First 6 elements are vars, as there are one-byte varref codes for those. - ;; Next up to byte-constant-limit are constants, still with one-byte codes. - ;; Next variables again, to get 2-byte codes for variable lookup. - ;; The rest of the constants and variables need 3-byte byte-codes. - (let* ((i -1) - (rest (nreverse byte-compile-variables)) ; nreverse because the first - (other (nreverse byte-compile-constants)) ; vars often are used most. - ret tmp - (limits '(5 ; Use the 1-byte varref codes, - 63 ; 1-constlim ; 1-byte byte-constant codes, - 255 ; 2-byte varref codes, - 65535)) ; 3-byte codes for the rest. - limit) - (while (or rest other) - (setq limit (car limits)) - (while (and rest (not (eq i limit))) - (if (setq tmp (assq (car (car rest)) ret)) - (setcdr (car rest) (cdr tmp)) - (setcdr (car rest) (setq i (1+ i))) - (setq ret (cons (car rest) ret))) - (setq rest (cdr rest))) - (setq limits (cdr limits) - rest (prog1 other - (setq other rest)))) - (apply 'vector (nreverse (mapcar 'car ret))))) - -;; Given an expression FORM, compile it and return an equivalent byte-code -;; expression (a call to the function byte-code). -(defun byte-compile-top-level (form &optional for-effect output-type) - ;; OUTPUT-TYPE advises about how form is expected to be used: - ;; 'eval or nil -> a single form, - ;; 'progn or t -> a list of forms, - ;; 'lambda -> body of a lambda, - ;; 'file -> used at file-level. - (let ((byte-compile-constants nil) - (byte-compile-variables nil) - (byte-compile-tag-number 0) - (byte-compile-depth 0) - (byte-compile-maxdepth 0) - (byte-compile-output nil)) - (if (memq byte-optimize '(t source)) - (setq form (byte-optimize-form form for-effect))) - (while (and (eq (car-safe form) 'progn) (null (cdr (cdr form)))) - (setq form (nth 1 form))) - (if (and (eq 'byte-code (car-safe form)) - (not (memq byte-optimize '(t byte))) - (stringp (nth 1 form)) - (vectorp (nth 2 form)) - (natnump (nth 3 form))) - form - (byte-compile-form form for-effect) - (byte-compile-out-toplevel for-effect output-type)))) - -(defun byte-compile-out-toplevel (&optional for-effect output-type) - (if for-effect - ;; The stack is empty. Push a value to be returned from (byte-code ..). - (if (eq (car (car byte-compile-output)) 'byte-discard) - (setq byte-compile-output (cdr byte-compile-output)) - (byte-compile-push-constant - ;; Push any constant - preferably one which already is used, and - ;; a number or symbol - ie not some big sequence. The return value - ;; isn't returned, but it would be a shame if some textually large - ;; constant was not optimized away because we chose to return it. - (and (not (assq nil byte-compile-constants)) ; Nil is often there. - (let ((tmp (reverse byte-compile-constants))) - (while (and tmp (not (or (symbolp (car (car tmp))) - (numberp (car (car tmp)))))) - (setq tmp (cdr tmp))) - (car (car tmp))))))) - (byte-compile-out 'byte-return 0) - (setq byte-compile-output (nreverse byte-compile-output)) - (if (memq byte-optimize '(t byte)) - (setq byte-compile-output - (byte-optimize-lapcode byte-compile-output for-effect))) - - ;; Decompile trivial functions: - ;; only constants and variables, or a single funcall except in lambdas. - ;; Except for Lisp_Compiled objects, forms like (foo "hi") - ;; are still quicker than (byte-code "..." [foo "hi"] 2). - ;; Note that even (quote foo) must be parsed just as any subr by the - ;; interpreter, so quote should be compiled into byte-code in some contexts. - ;; What to leave uncompiled: - ;; lambda -> never. we used to leave it uncompiled if the body was - ;; a single atom, but that causes confusion if the docstring - ;; uses the (file . pos) syntax. Besides, now that we have - ;; the Lisp_Compiled type, the compiled form is faster. - ;; eval -> atom, quote or (function atom atom atom) - ;; progn -> as <<same-as-eval>> or (progn <<same-as-eval>> atom) - ;; file -> as progn, but takes both quotes and atoms, and longer forms. - (let (rest - (maycall (not (eq output-type 'lambda))) ; t if we may make a funcall. - tmp body) - (cond - ;; #### This should be split out into byte-compile-nontrivial-function-p. - ((or (eq output-type 'lambda) - (nthcdr (if (eq output-type 'file) 50 8) byte-compile-output) - (assq 'TAG byte-compile-output) ; Not necessary, but speeds up a bit. - (not (setq tmp (assq 'byte-return byte-compile-output))) - (progn - (setq rest (nreverse - (cdr (memq tmp (reverse byte-compile-output))))) - (while (cond - ((memq (car (car rest)) '(byte-varref byte-constant)) - (setq tmp (car (cdr (car rest)))) - (if (if (eq (car (car rest)) 'byte-constant) - (or (consp tmp) - (and (symbolp tmp) - (not (keywordp tmp)) - (not (memq tmp '(nil t)))))) - (if maycall - (setq body (cons (list 'quote tmp) body))) - (setq body (cons tmp body)))) - ((and maycall - ;; Allow a funcall if at most one atom follows it. - (null (nthcdr 3 rest)) - (setq tmp - ;; XEmacs change for rms funs - (or (and - (byte-compile-version-cond - byte-compile-emacs19-compatibility) - (get (car (car rest)) - 'byte-opcode19-invert)) - (get (car (car rest)) - 'byte-opcode-invert))) - (or (null (cdr rest)) - (and (memq output-type '(file progn t)) - (cdr (cdr rest)) - (eq (car (nth 1 rest)) 'byte-discard) - (progn (setq rest (cdr rest)) t)))) - (setq maycall nil) ; Only allow one real function call. - (setq body (nreverse body)) - (setq body (list - (if (and (eq tmp 'funcall) - (eq (car-safe (car body)) 'quote)) - (cons (nth 1 (car body)) (cdr body)) - (cons tmp body)))) - (or (eq output-type 'file) - (not (delq nil (mapcar 'consp (cdr (car body)))))))) - (setq rest (cdr rest))) - rest)) - (let ((byte-compile-vector (byte-compile-constants-vector))) - (list 'byte-code (byte-compile-lapcode byte-compile-output) - byte-compile-vector byte-compile-maxdepth))) - ;; it's a trivial function - ((cdr body) (cons 'progn (nreverse body))) - ((car body))))) - -;; Given BODY, compile it and return a new body. -(defun byte-compile-top-level-body (body &optional for-effect) - (setq body (byte-compile-top-level (cons 'progn body) for-effect t)) - (cond ((eq (car-safe body) 'progn) - (cdr body)) - (body - (list body)))) - -;; This is the recursive entry point for compiling each subform of an -;; expression. -;; If for-effect is non-nil, byte-compile-form will output a byte-discard -;; before terminating (ie no value will be left on the stack). -;; 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). -;; If a handler wants to call another handler, it should do so via -;; byte-compile-form, or take extreme care to handle for-effect correctly. -;; (Use byte-compile-form-do-effect to reset the for-effect flag too.) -;; -(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))) - (byte-compile-constant form)) - ((and for-effect byte-compile-delete-errors) - (setq for-effect nil)) - (t (byte-compile-variable-ref 'byte-varref form)))) - ((symbolp (car form)) - (let* ((fn (car form)) - (handler (get fn 'byte-compile))) - (if (memq fn '(t nil)) - (byte-compile-warn "%s called as a function" fn)) - (if (and handler - (or (not (byte-compile-version-cond - byte-compile-emacs19-compatibility)) - (not (get (get fn 'byte-opcode) 'emacs20-opcode)))) - (funcall handler form) - (if (memq 'callargs byte-compile-warnings) - (byte-compile-callargs-warn form)) - (byte-compile-normal-call form)))) - ((and (or (compiled-function-p (car form)) - (eq (car-safe (car form)) 'lambda)) - ;; if the form comes out the same way it went in, that's - ;; because it was malformed, and we couldn't unfold it. - (not (eq form (setq form (byte-compile-unfold-lambda form))))) - (byte-compile-form form for-effect) - (setq for-effect nil)) - ((byte-compile-normal-call form))) - (if for-effect - (byte-compile-discard))) - -(defun byte-compile-normal-call (form) - (if byte-compile-generate-call-tree - (byte-compile-annotate-call-tree form)) - (byte-compile-push-constant (car form)) - (mapcar 'byte-compile-form (cdr form)) ; wasteful, but faster. - (byte-compile-out 'byte-call (length (cdr form)))) - -;; kludge added to XEmacs to work around the bogosities of a nonlexical lisp. -(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 (and (get var 'byte-obsolete-variable) - (memq 'obsolete byte-compile-warnings)) - (let ((ob (get var 'byte-obsolete-variable))) - (byte-compile-warn "%s is an obsolete variable; %s" var - (if (stringp ob) - ob - (format "use %s instead." ob))))) - (if (and (get var 'byte-compatible-variable) - (memq 'pedantic byte-compile-warnings)) - (let ((ob (get var 'byte-compatible-variable))) - (byte-compile-warn "%s is provided for compatibility; %s" var - (if (stringp ob) - ob - (format "use %s instead." ob))))) - (if (memq 'free-vars byte-compile-warnings) - (if (eq base-op 'byte-varbind) - (setq byte-compile-bound-variables - (cons (cons var (or varbind-flags 0)) - byte-compile-bound-variables)) - (or (globally-boundp var) - (let ((cell (assq var byte-compile-bound-variables))) - (if cell (setcdr cell - (logior (cdr cell) - (if (eq base-op 'byte-varset) - byte-compile-assigned-bit - byte-compile-referenced-bit))))) - (if (eq base-op 'byte-varset) - (or (memq var byte-compile-free-assignments) - (progn - (byte-compile-warn "assignment to free variable %s" - var) - (setq byte-compile-free-assignments - (cons var byte-compile-free-assignments)))) - (or (memq var byte-compile-free-references) - (progn - (byte-compile-warn "reference to free variable %s" var) - (setq byte-compile-free-references - (cons var byte-compile-free-references))))))))) - (let ((tmp (assq var byte-compile-variables))) - (or tmp - (setq tmp (list var) - byte-compile-variables (cons tmp byte-compile-variables))) - (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)))))) - -;; Use this when the value of a form is a constant. This obeys for-effect. -(defun byte-compile-constant (const) - (if for-effect - (setq for-effect nil) - (byte-compile-out 'byte-constant (byte-compile-get-constant const)))) - -;; Use this for a constant that is not the value of its containing form. -;; This ignores for-effect. -(defun byte-compile-push-constant (const) - (let ((for-effect nil)) - (inline (byte-compile-constant const)))) - - -;; Compile those primitive ordinary functions -;; which have special byte codes just for speed. - -(defmacro byte-defop-compiler (function &optional compile-handler) - ;; add a compiler-form for FUNCTION. - ;; If function is a symbol, then the variable "byte-SYMBOL" must name - ;; the opcode to be used. If function is a list, the first element - ;; is the function and the second element is the bytecode-symbol. - ;; COMPILE-HANDLER is the function to use to compile this byte-op, or - ;; may be the abbreviations 0, 1, 2, 3, 0-1, 1-2, 2-3, 0+1, 1+1, 2+1, - ;; 0-1+1, 1-2+1, 2-3+1, 0+2, or 1+2. If it is nil, then the handler is - ;; "byte-compile-SYMBOL." - (let (opcode) - (if (symbolp function) - (setq opcode (intern (concat "byte-" (symbol-name function)))) - (setq opcode (car (cdr function)) - function (car function))) - (let ((fnform - (list 'put (list 'quote function) ''byte-compile - (list 'quote - (or (cdr (assq compile-handler - '((0 . byte-compile-no-args) - (1 . byte-compile-one-arg) - (2 . byte-compile-two-args) - (3 . byte-compile-three-args) - (0-1 . byte-compile-zero-or-one-arg) - (1-2 . byte-compile-one-or-two-args) - (2-3 . byte-compile-two-or-three-args) - (0+1 . byte-compile-no-args-with-one-extra) - (1+1 . byte-compile-one-arg-with-one-extra) - (2+1 . byte-compile-two-args-with-one-extra) - (0-1+1 . byte-compile-zero-or-one-arg-with-one-extra) - (1-2+1 . byte-compile-one-or-two-args-with-one-extra) - (2-3+1 . byte-compile-two-or-three-args-with-one-extra) - (0+2 . byte-compile-no-args-with-two-extra) - (1+2 . byte-compile-one-arg-with-two-extra) - - ))) - compile-handler - (intern (concat "byte-compile-" - (symbol-name function)))))))) - (if opcode - (list 'progn fnform - (list 'put (list 'quote function) - ''byte-opcode (list 'quote opcode)) - (list 'put (list 'quote opcode) - ''byte-opcode-invert (list 'quote function))) - fnform)))) - -(defmacro byte-defop-compiler20 (function &optional compile-handler) - ;; Just like byte-defop-compiler, but defines an opcode that will only - ;; be used when byte-compile-emacs19-compatibility is false. - (if (and (byte-compile-single-version) - byte-compile-emacs19-compatibility) - ;; #### instead of doing nothing, this should do some remprops, - ;; #### to protect against the case where a single-version compiler - ;; #### is loaded into a world that has contained a multi-version one. - nil - (list 'progn - (list 'put - (list 'quote - (or (car (cdr-safe function)) - (intern (concat "byte-" - (symbol-name (or (car-safe function) function)))))) - ''emacs20-opcode t) - (list 'byte-defop-compiler function compile-handler)))) - -;; XEmacs addition: -(defmacro byte-defop-compiler-rmsfun (function &optional compile-handler) - ;; for functions like `eq' that compile into different opcodes depending - ;; on the Emacs version: byte-old-eq for v19, byte-eq for v20. - (let ((opcode (intern (concat "byte-" (symbol-name function)))) - (opcode19 (intern (concat "byte-old-" (symbol-name function)))) - (fnform - (list 'put (list 'quote function) ''byte-compile - (list 'quote - (or (cdr (assq compile-handler - '((2 . byte-compile-two-args-19->20) - ))) - compile-handler - (intern (concat "byte-compile-" - (symbol-name function)))))))) - (list 'progn fnform - (list 'put (list 'quote function) - ''byte-opcode (list 'quote opcode)) - (list 'put (list 'quote function) - ''byte-opcode19 (list 'quote opcode19)) - (list 'put (list 'quote opcode) - ''byte-opcode-invert (list 'quote function)) - (list 'put (list 'quote opcode19) - ''byte-opcode19-invert (list 'quote function))))) - -(defmacro byte-defop-compiler-1 (function &optional compile-handler) - (list 'byte-defop-compiler (list function nil) compile-handler)) - - -(put 'byte-call 'byte-opcode-invert 'funcall) -(put 'byte-list1 'byte-opcode-invert 'list) -(put 'byte-list2 'byte-opcode-invert 'list) -(put 'byte-list3 'byte-opcode-invert 'list) -(put 'byte-list4 'byte-opcode-invert 'list) -(put 'byte-listN 'byte-opcode-invert 'list) -(put 'byte-concat2 'byte-opcode-invert 'concat) -(put 'byte-concat3 'byte-opcode-invert 'concat) -(put 'byte-concat4 'byte-opcode-invert 'concat) -(put 'byte-concatN 'byte-opcode-invert 'concat) -(put 'byte-insertN 'byte-opcode-invert 'insert) - -(byte-defop-compiler (dot byte-point) 0+1) -(byte-defop-compiler (dot-max byte-point-max) 0+1) -(byte-defop-compiler (dot-min byte-point-min) 0+1) -(byte-defop-compiler point 0+1) -(byte-defop-compiler-rmsfun eq 2) -(byte-defop-compiler point-max 0+1) -(byte-defop-compiler point-min 0+1) -(byte-defop-compiler following-char 0+1) -(byte-defop-compiler preceding-char 0+1) -(byte-defop-compiler current-column 0+1) -;; FSF has special function here; generalized here by the 1+2 stuff. -(byte-defop-compiler (indent-to-column byte-indent-to) 1+2) -(byte-defop-compiler indent-to 1+2) -(byte-defop-compiler-rmsfun equal 2) -(byte-defop-compiler eolp 0+1) -(byte-defop-compiler eobp 0+1) -(byte-defop-compiler bolp 0+1) -(byte-defop-compiler bobp 0+1) -(byte-defop-compiler current-buffer 0) -;;(byte-defop-compiler read-char 0) ;; obsolete -(byte-defop-compiler-rmsfun memq 2) -(byte-defop-compiler interactive-p 0) -(byte-defop-compiler widen 0+1) -(byte-defop-compiler end-of-line 0-1+1) -(byte-defop-compiler forward-char 0-1+1) -(byte-defop-compiler forward-line 0-1+1) -(byte-defop-compiler symbolp 1) -(byte-defop-compiler consp 1) -(byte-defop-compiler stringp 1) -(byte-defop-compiler listp 1) -(byte-defop-compiler not 1) -(byte-defop-compiler (null byte-not) 1) -(byte-defop-compiler car 1) -(byte-defop-compiler cdr 1) -(byte-defop-compiler length 1) -(byte-defop-compiler symbol-value 1) -(byte-defop-compiler symbol-function 1) -(byte-defop-compiler (1+ byte-add1) 1) -(byte-defop-compiler (1- byte-sub1) 1) -(byte-defop-compiler goto-char 1+1) -(byte-defop-compiler char-after 0-1+1) -(byte-defop-compiler set-buffer 1) -;;(byte-defop-compiler set-mark 1) ;; obsolete -(byte-defop-compiler forward-word 1+1) -(byte-defop-compiler char-syntax 1+1) -(byte-defop-compiler nreverse 1) -(byte-defop-compiler car-safe 1) -(byte-defop-compiler cdr-safe 1) -(byte-defop-compiler numberp 1) -(byte-defop-compiler integerp 1) -(byte-defop-compiler skip-chars-forward 1-2+1) -(byte-defop-compiler skip-chars-backward 1-2+1) -(byte-defop-compiler (eql byte-eq) 2) -(byte-defop-compiler20 old-eq 2) -(byte-defop-compiler20 old-memq 2) -(byte-defop-compiler cons 2) -(byte-defop-compiler aref 2) -(byte-defop-compiler (= byte-eqlsign) 2) -(byte-defop-compiler (< byte-lss) 2) -(byte-defop-compiler (> byte-gtr) 2) -(byte-defop-compiler (<= byte-leq) 2) -(byte-defop-compiler (>= byte-geq) 2) -(byte-defop-compiler get 2+1) -(byte-defop-compiler nth 2) -(byte-defop-compiler substring 2-3) -(byte-defop-compiler (move-marker byte-set-marker) 2-3) -(byte-defop-compiler set-marker 2-3) -(byte-defop-compiler match-beginning 1) -(byte-defop-compiler match-end 1) -(byte-defop-compiler upcase 1+1) -(byte-defop-compiler downcase 1+1) -(byte-defop-compiler string= 2) -(byte-defop-compiler string< 2) -(byte-defop-compiler (string-equal byte-string=) 2) -(byte-defop-compiler (string-lessp byte-string<) 2) -(byte-defop-compiler20 old-equal 2) -(byte-defop-compiler nthcdr 2) -(byte-defop-compiler elt 2) -(byte-defop-compiler20 old-member 2) -(byte-defop-compiler20 old-assq 2) -(byte-defop-compiler (rplaca byte-setcar) 2) -(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) -(byte-defop-compiler aset 3) - -(byte-defop-compiler-rmsfun member 2) -(byte-defop-compiler-rmsfun assq 2) - -(byte-defop-compiler max byte-compile-associative) -(byte-defop-compiler min byte-compile-associative) -(byte-defop-compiler (+ byte-plus) byte-compile-associative) -(byte-defop-compiler (* byte-mult) byte-compile-associative) - -;;####(byte-defop-compiler move-to-column 1) -(byte-defop-compiler-1 interactive byte-compile-noop) -(byte-defop-compiler-1 domain byte-compile-domain) - -;; As of GNU Emacs 19.18 and Lucid Emacs 19.8, mod and % are different: `%' -;; means integral remainder and may have a negative result; `mod' is always -;; positive, and accepts floating point args. All code which uses `mod' and -;; requires the new interpretation must be compiled with bytecomp version 2.18 -;; or newer, or the emitted code will run the byte-code for `%' instead of an -;; actual call to `mod'. So be careful of compiling new code with an old -;; compiler. Note also that `%' is more efficient than `mod' because the -;; former is byte-coded and the latter is not. -;;(byte-defop-compiler (mod byte-rem) 2) - - -(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) - ;; 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))) - -(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))) - -(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))) - -(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))) - -(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"))))) - -(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"))))) - -(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"))))) - -;; from Ben Wing <wing@666.com>: some inlined functions have extra -;; optional args added to them in XEmacs 19.12. Changing the byte -;; interpreter to deal with these args would be wrong and cause -;; incompatibility, so we generate non-inlined calls for those cases. -;; Without the following functions, spurious warnings will be generated; -;; however, they would still compile correctly because -;; `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"))))) - -(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"))))) - -(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"))))) - -(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"))))) - -(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"))))) - -(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"))))) - -(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"))))) - -(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"))))) - -;; XEmacs: used for functions that have a different opcode in v19 than v20. -;; this includes `eq', `equal', and other old-ified functions. -(defun byte-compile-two-args-19->20 (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)) - (if (byte-compile-version-cond byte-compile-emacs19-compatibility) - (byte-compile-out (get (car form) 'byte-opcode19) 0) - (byte-compile-out (get (car form) 'byte-opcode) 0)))) - -(defun byte-compile-noop (form) - (byte-compile-constant nil)) - -(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)))) - - -;; more complicated compiler macros - -(byte-defop-compiler list) -(byte-defop-compiler concat) -(byte-defop-compiler fset) -(byte-defop-compiler insert) -(byte-defop-compiler-1 function byte-compile-function-form) -(byte-defop-compiler-1 - byte-compile-minus) -(byte-defop-compiler (/ byte-quo) byte-compile-quo) -(byte-defop-compiler nconc) -(byte-defop-compiler-1 beginning-of-line) - -(defun byte-compile-buffer-substring (form) - (let ((len (length form))) - ;; buffer-substring used to take exactly two args, but now takes 0-3. - ;; convert 0-2 to two args and use special bytecode operand. - ;; convert 3 args to a normal call. - (cond ((= len 1) (setq form (append form '(nil nil))) - (= len 2) (setq form (append form '(nil))))) - (cond ((= len 3) (byte-compile-two-args form)) - ((= len 4) (byte-compile-normal-call form)) - (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))))) - -(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))))) - -(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)))) - -(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)))))) - -(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)))))) - -(defun byte-compile-fset (form) - ;; warn about forms like (fset 'foo '(lambda () ...)) - ;; (where the lambda expression is non-trivial...) - ;; Except don't warn if the first argument is 'make-byte-code, because - ;; 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 - not what you want, as that lambda cannot be compiled. Consider using - the syntax (function (lambda (...) ...)) instead."))))) - (byte-compile-two-args form)) - -(defun byte-compile-funarg (form) - ;; (mapcar '(lambda (x) ..) ..) ==> (mapcar (function (lambda (x) ..)) ..) - ;; for cases where it's guaranteed that first arg will be used as a lambda. - (byte-compile-normal-call - (let ((fn (nth 1 form))) - (if (and (eq (car-safe fn) 'quote) - (eq (car-safe (nth 1 fn)) 'lambda)) - (cons (car form) - (cons (cons 'function (cdr fn)) - (cdr (cdr form)))) - form)))) - -;; (function foo) must compile like 'foo, not like (symbol-function 'foo). -;; Otherwise it will be incompatible with the interpreter, -;; and (funcall (function foo)) will lose with autoloads. - -(defun byte-compile-function-form (form) - (byte-compile-constant - (cond ((symbolp (nth 1 form)) - (nth 1 form)) - ((byte-compile-lambda (nth 1 form)))))) - -(defun byte-compile-insert (form) - (cond ((null (cdr form)) - (byte-compile-constant nil)) - ((<= (length form) 256) - (mapcar 'byte-compile-form (cdr form)) - (if (cdr (cdr form)) - (byte-compile-out 'byte-insertN (length (cdr form))) - (byte-compile-out 'byte-insert 0))) - ((memq t (mapcar 'consp (cdr (cdr form)))) - (byte-compile-normal-call form)) - ;; We can split it; there is no function call after inserting 1st arg. - (t - (while (setq form (cdr form)) - (byte-compile-form (car form)) - (byte-compile-out 'byte-insert 0) - (if (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 -;; (beginning-of-line nil buffer) because it buggily doesn't -;; check the number of arguments passed to beginning-of-line. - -(defun byte-compile-beginning-of-line (form) - (let ((len (length form))) - (cond ((> len 3) - (byte-compile-subr-wrong-args form "0-2")) - ((or (= len 3) (not (byte-compile-constp (nth 1 form)))) - (byte-compile-normal-call form)) - (t - (byte-compile-form - (list 'forward-line - (if (integerp (setq form (or (eval (nth 1 form)) 1))) - (1- form) - (byte-compile-warn - "Non-numeric arg to beginning-of-line: %s" form) - (list '1- (list 'quote form)))) - t) - (byte-compile-constant nil))))) - - -(byte-defop-compiler set) -(byte-defop-compiler-1 setq) -(byte-defop-compiler-1 set-default) -(byte-defop-compiler-1 setq-default) - -(byte-defop-compiler-1 quote) -(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)) - (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))) - -(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))))) - -(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)))))) - -(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))))) - - -(defun byte-compile-quote (form) - (byte-compile-constant (car (cdr form)))) - -(defun byte-compile-quote-form (form) - (byte-compile-constant (byte-compile-top-level (nth 1 form)))) - - -;;; control structures - -(defun byte-compile-body (body &optional for-effect) - (while (cdr body) - (byte-compile-form (car body) t) - (setq body (cdr body))) - (byte-compile-form (car body) for-effect)) - -(proclaim-inline byte-compile-body-do-effect) -(defun byte-compile-body-do-effect (body) - (byte-compile-body body for-effect) - (setq for-effect nil)) - -(proclaim-inline byte-compile-form-do-effect) -(defun byte-compile-form-do-effect (form) - (byte-compile-form form for-effect) - (setq for-effect nil)) - -(byte-defop-compiler-1 inline byte-compile-progn) -(byte-defop-compiler-1 progn) -(byte-defop-compiler-1 prog1) -(byte-defop-compiler-1 prog2) -(byte-defop-compiler-1 if) -(byte-defop-compiler-1 cond) -(byte-defop-compiler-1 and) -(byte-defop-compiler-1 or) -(byte-defop-compiler-1 while) -(byte-defop-compiler-1 funcall) -(byte-defop-compiler-1 apply byte-compile-funarg) -(byte-defop-compiler-1 mapcar byte-compile-funarg) -(byte-defop-compiler-1 mapatoms byte-compile-funarg) -(byte-defop-compiler-1 mapconcat byte-compile-funarg) -(byte-defop-compiler-1 let) -(byte-defop-compiler-1 let*) - -(defun byte-compile-progn (form) - (byte-compile-body-do-effect (cdr form))) - -(defun byte-compile-prog1 (form) - (byte-compile-form-do-effect (car (cdr form))) - (byte-compile-body (cdr (cdr form)) t)) - -(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)) - -(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)))) - -(defun byte-compile-if (form) - (byte-compile-form (car (cdr form))) - (if (null (nthcdr 3 form)) - ;; No else-forms - (let ((donetag (byte-compile-make-tag))) - (byte-compile-goto-if nil for-effect donetag) - (byte-compile-form (nth 2 form) for-effect) - (byte-compile-out-tag donetag)) - (let ((donetag (byte-compile-make-tag)) (elsetag (byte-compile-make-tag))) - (byte-compile-goto 'byte-goto-if-nil elsetag) - (byte-compile-form (nth 2 form) for-effect) - (byte-compile-goto 'byte-goto donetag) - (byte-compile-out-tag elsetag) - (byte-compile-body (cdr (cdr (cdr form))) for-effect) - (byte-compile-out-tag donetag))) - (setq for-effect nil)) - -(defun byte-compile-cond (clauses) - (let ((donetag (byte-compile-make-tag)) - nexttag clause) - (while (setq clauses (cdr clauses)) - (setq clause (car clauses)) - (cond ((or (eq (car clause) t) - (and (eq (car-safe (car clause)) 'quote) - (car-safe (cdr-safe (car clause))))) - ;; Unconditional clause - (setq clause (cons t clause) - clauses nil)) - ((cdr clauses) - (byte-compile-form (car clause)) - (if (null (cdr clause)) - ;; First clause is a singleton. - (byte-compile-goto-if t for-effect donetag) - (setq nexttag (byte-compile-make-tag)) - (byte-compile-goto 'byte-goto-if-nil nexttag) - (byte-compile-body (cdr clause) for-effect) - (byte-compile-goto 'byte-goto donetag) - (byte-compile-out-tag nexttag))))) - ;; Last clause - (and (cdr clause) (not (eq (car clause) t)) - (progn (byte-compile-form (car clause)) - (byte-compile-goto-if nil for-effect donetag) - (setq clause (cdr clause)))) - (byte-compile-body-do-effect clause) - (byte-compile-out-tag donetag))) - -(defun byte-compile-and (form) - (let ((failtag (byte-compile-make-tag)) - (args (cdr form))) - (if (null args) - (byte-compile-form-do-effect t) - (while (cdr args) - (byte-compile-form (car args)) - (byte-compile-goto-if nil for-effect failtag) - (setq args (cdr args))) - (byte-compile-form-do-effect (car args)) - (byte-compile-out-tag failtag)))) - -(defun byte-compile-or (form) - (let ((wintag (byte-compile-make-tag)) - (args (cdr form))) - (if (null args) - (byte-compile-form-do-effect nil) - (while (cdr args) - (byte-compile-form (car args)) - (byte-compile-goto-if t for-effect wintag) - (setq args (cdr args))) - (byte-compile-form-do-effect (car args)) - (byte-compile-out-tag wintag)))) - -(defun byte-compile-while (form) - (let ((endtag (byte-compile-make-tag)) - (looptag (byte-compile-make-tag))) - (byte-compile-out-tag looptag) - (byte-compile-form (car (cdr form))) - (byte-compile-goto-if nil for-effect endtag) - (byte-compile-body (cdr (cdr form)) t) - (byte-compile-goto 'byte-goto looptag) - (byte-compile-out-tag endtag) - (setq for-effect nil))) - -(defun byte-compile-funcall (form) - (mapcar 'byte-compile-form (cdr form)) - (byte-compile-out 'byte-call (length (cdr (cdr form))))) - - -(defun byte-compile-let (form) - ;; First compute the binding values in the old scope. - (let ((varlist (car (cdr form)))) - (while varlist - (if (consp (car varlist)) - (byte-compile-form (car (cdr (car varlist)))) - (byte-compile-push-constant nil)) - (setq varlist (cdr varlist)))) - (let ((byte-compile-bound-variables - (cons 'new-scope byte-compile-bound-variables)) - (varlist (reverse (car (cdr form)))) - (extra-flags - ;; If this let is of the form (let (...) (byte-code ...)) - ;; then assume that it is the result of a transformation of - ;; ((lambda (...) (byte-code ... )) ...) and thus compile - ;; the variable bindings as if they were arglist bindings - ;; (which matters for what warnings.) - (if (eq 'byte-code (car-safe (nth 2 form))) - byte-compile-arglist-bit - nil))) - (while varlist - (byte-compile-variable-ref 'byte-varbind - (if (consp (car varlist)) - (car (car varlist)) - (car varlist)) - extra-flags) - (setq varlist (cdr varlist))) - (byte-compile-body-do-effect (cdr (cdr form))) - (if (memq 'unused-vars byte-compile-warnings) - ;; done compiling in this scope, warn now. - (byte-compile-warn-about-unused-variables)) - (byte-compile-out 'byte-unbind (length (car (cdr form)))))) - -(defun byte-compile-let* (form) - (let ((byte-compile-bound-variables - (cons 'new-scope byte-compile-bound-variables)) - (varlist (copy-sequence (car (cdr form))))) - (while varlist - (if (atom (car varlist)) - (byte-compile-push-constant nil) - (byte-compile-form (car (cdr (car varlist)))) - (setcar varlist (car (car varlist)))) - (byte-compile-variable-ref 'byte-varbind (car varlist)) - (setq varlist (cdr varlist))) - (byte-compile-body-do-effect (cdr (cdr form))) - (if (memq 'unused-vars byte-compile-warnings) - ;; done compiling in this scope, warn now. - (byte-compile-warn-about-unused-variables)) - (byte-compile-out 'byte-unbind (length (car (cdr form)))))) - - -(byte-defop-compiler-1 /= byte-compile-negated) -(byte-defop-compiler-1 atom byte-compile-negated) -(byte-defop-compiler-1 nlistp byte-compile-negated) - -(put '/= 'byte-compile-negated-op '=) -(put 'atom 'byte-compile-negated-op 'consp) -(put 'nlistp 'byte-compile-negated-op 'listp) - -(defun byte-compile-negated (form) - (byte-compile-form-do-effect (byte-compile-negation-optimizer form))) - -;; Even when optimization is off, /= is optimized to (not (= ...)). -(defun byte-compile-negation-optimizer (form) - ;; an optimizer for forms where <form1> is less efficient than (not <form2>) - (list 'not - (cons (or (get (car form) 'byte-compile-negated-op) - (error - "Compiler error: `%s' has no `byte-compile-negated-op' property" - (car form))) - (cdr form)))) - -;;; other tricky macro-like special-forms - -(byte-defop-compiler-1 catch) -(byte-defop-compiler-1 unwind-protect) -(byte-defop-compiler-1 condition-case) -(byte-defop-compiler-1 save-excursion) -(byte-defop-compiler-1 save-current-buffer) -(byte-defop-compiler-1 save-restriction) -(byte-defop-compiler-1 save-window-excursion) -(byte-defop-compiler-1 with-output-to-temp-buffer) -;; no track-mouse. - -(defun byte-compile-catch (form) - (byte-compile-form (car (cdr form))) - (byte-compile-push-constant - (byte-compile-top-level (cons 'progn (cdr (cdr form))) for-effect)) - (byte-compile-out 'byte-catch 0)) - -(defun byte-compile-unwind-protect (form) - (byte-compile-push-constant - (byte-compile-top-level-body (cdr (cdr form)) t)) - (byte-compile-out 'byte-unwind-protect 0) - (byte-compile-form-do-effect (car (cdr form))) - (byte-compile-out 'byte-unbind 1)) - -;;(defun byte-compile-track-mouse (form) -;; (byte-compile-form -;; (list -;; 'funcall -;; (list 'quote -;; (list 'lambda nil -;; (cons 'track-mouse -;; (byte-compile-top-level-body (cdr form)))))))) - -(defun byte-compile-condition-case (form) - (let* ((var (nth 1 form)) - (byte-compile-bound-variables - (if var - (cons (cons var 0) - (cons 'new-scope byte-compile-bound-variables)) - (cons 'new-scope byte-compile-bound-variables)))) - (or (symbolp var) - (byte-compile-warn - "%s is not a variable-name or nil (in condition-case)" - (prin1-to-string var))) - (byte-compile-push-constant var) - (byte-compile-push-constant (byte-compile-top-level - (nth 2 form) for-effect)) - (let ((clauses (cdr (cdr (cdr form)))) - compiled-clauses) - (while clauses - (let* ((clause (car clauses)) - (condition (car clause))) - (cond ((not (or (symbolp condition) - (and (listp condition) - (let ((syms condition) (ok t)) - (while syms - (if (not (symbolp (car syms))) - (setq ok nil)) - (setq syms (cdr syms))) - ok)))) - (byte-compile-warn - "%s is not a symbol naming a condition or a list of such (in condition-case)" - (prin1-to-string condition))) -;; ((not (or (eq condition 't) -;; (and (stringp (get condition 'error-message)) -;; (consp (get condition 'error-conditions))))) -;; (byte-compile-warn -;; "%s is not a known condition name (in condition-case)" -;; condition)) - ) - (setq compiled-clauses - (cons (cons condition - (byte-compile-top-level-body - (cdr clause) for-effect)) - compiled-clauses))) - (setq clauses (cdr clauses))) - (byte-compile-push-constant (nreverse compiled-clauses))) - (if (memq 'unused-vars byte-compile-warnings) - ;; done compiling in this scope, warn now. - (byte-compile-warn-about-unused-variables)) - (byte-compile-out 'byte-condition-case 0))) - - -(defun byte-compile-save-excursion (form) - (byte-compile-out 'byte-save-excursion 0) - (byte-compile-body-do-effect (cdr form)) - (byte-compile-out 'byte-unbind 1)) - -(defun byte-compile-save-restriction (form) - (byte-compile-out 'byte-save-restriction 0) - (byte-compile-body-do-effect (cdr form)) - (byte-compile-out 'byte-unbind 1)) - -(defun byte-compile-save-current-buffer (form) - (if (byte-compile-version-cond byte-compile-emacs19-compatibility) - ;; `save-current-buffer' special form is not available in XEmacs 19. - (byte-compile-form - `(let ((_byte_compiler_save_buffer_emulation_closure_ (current-buffer))) - (unwind-protect - (progn ,@(cdr form)) - (and (buffer-live-p _byte_compiler_save_buffer_emulation_closure_) - (set-buffer _byte_compiler_save_buffer_emulation_closure_))))) - (byte-compile-out 'byte-save-current-buffer 0) - (byte-compile-body-do-effect (cdr form)) - (byte-compile-out 'byte-unbind 1))) - -(defun byte-compile-save-window-excursion (form) - (byte-compile-push-constant - (byte-compile-top-level-body (cdr form) for-effect)) - (byte-compile-out 'byte-save-window-excursion 0)) - -(defun byte-compile-with-output-to-temp-buffer (form) - (byte-compile-form (car (cdr form))) - (byte-compile-out 'byte-temp-output-buffer-setup 0) - (byte-compile-body (cdr (cdr form))) - (byte-compile-out 'byte-temp-output-buffer-show 0)) - - -;;; top-level forms elsewhere - -(byte-defop-compiler-1 defun) -(byte-defop-compiler-1 defmacro) -(byte-defop-compiler-1 defvar) -(byte-defop-compiler-1 defconst byte-compile-defvar) -(byte-defop-compiler-1 autoload) -;; According to Mly this can go now that lambda is a macro -;(byte-defop-compiler-1 lambda byte-compile-lambda-form) -(byte-defop-compiler-1 defalias) -(byte-defop-compiler-1 define-function) - -(defun byte-compile-defun (form) - ;; This is not used for file-level defuns with doc strings. - (byte-compile-two-args ; Use this to avoid byte-compile-fset's warning. - (list 'fset (list 'quote (nth 1 form)) - (byte-compile-byte-code-maker - (byte-compile-lambda (cons 'lambda (cdr (cdr form))))))) - (byte-compile-discard) - (byte-compile-constant (nth 1 form))) - -(defun byte-compile-defmacro (form) - ;; This is not used for file-level defmacros with doc strings. - (byte-compile-body-do-effect - (list (list 'fset (list 'quote (nth 1 form)) - (let ((code (byte-compile-byte-code-maker - (byte-compile-lambda - (cons 'lambda (cdr (cdr form))))))) - (if (eq (car-safe code) 'make-byte-code) - (list 'cons ''macro code) - (list 'quote (cons 'macro (eval code)))))) - (list 'quote (nth 1 form))))) - -(defun byte-compile-defvar (form) - ;; This is not used for file-level defvar/consts with doc strings: - ;; byte-compile-file-form-defvar will be used in that case. - (let ((var (nth 1 form)) - (value (nth 2 form)) - (string (nth 3 form))) - (if (> (length form) 4) - (byte-compile-warn "%s used with too many args" (car form))) - (if (memq 'free-vars byte-compile-warnings) - (setq byte-compile-bound-variables - (cons (cons var byte-compile-global-bit) - byte-compile-bound-variables))) - (byte-compile-body-do-effect - (list (if (cdr (cdr form)) - (if (eq (car form) 'defconst) - (list 'setq var value) - (list 'or (list 'boundp (list 'quote var)) - (list 'setq var value)))) - ;; Put the defined variable in this library's load-history entry - ;; just as a real defvar would. - (list 'setq 'current-load-list - (list 'cons (list 'quote var) - 'current-load-list)) - (if string - (list 'put (list 'quote var) ''variable-documentation string)) - (list 'quote var))))) - -(defun byte-compile-autoload (form) - (and (byte-compile-constp (nth 1 form)) - (byte-compile-constp (nth 5 form)) - (memq (eval (nth 5 form)) '(t macro)) ; macro-p - (not (fboundp (eval (nth 1 form)))) - (byte-compile-warn - "The compiler ignores `autoload' except at top level. You should - probably put the autoload of the macro `%s' at top-level." - (eval (nth 1 form)))) - (byte-compile-normal-call form)) - -;; Lambda's in valid places are handled as special cases by various code. -;; The ones that remain are errors. -;; According to Mly this can go now that lambda is a macro -;(defun byte-compile-lambda-form (form) -; (byte-compile-warn -; "`lambda' used in function position is invalid: probably you mean #'%s" -; (let ((print-escape-newlines t) -; (print-level 4) -; (print-length 4)) -; (prin1-to-string form))) -; (byte-compile-normal-call -; (list 'signal ''error -; (list 'quote (list "`lambda' used in function position" form))))) - -;; Compile normally, but deal with warnings for the function being defined. -(defun byte-compile-defalias (form) - (if (and (consp (cdr form)) (consp (nth 1 form)) - (eq (car (nth 1 form)) 'quote) - (consp (cdr (nth 1 form))) - (symbolp (nth 1 (nth 1 form))) - (consp (nthcdr 2 form)) - (consp (nth 2 form)) - (eq (car (nth 2 form)) 'quote) - (consp (cdr (nth 2 form))) - (symbolp (nth 1 (nth 2 form)))) - (progn - (byte-compile-defalias-warn (nth 1 (nth 1 form)) - (nth 1 (nth 2 form))) - (setq byte-compile-function-environment - (cons (cons (nth 1 (nth 1 form)) - (nth 1 (nth 2 form))) - byte-compile-function-environment)))) - (byte-compile-normal-call form)) - -(defun byte-compile-define-function (form) - (byte-compile-defalias form)) - -;; Turn off warnings about prior calls to the function being defalias'd. -;; This could be smarter and compare those calls with -;; the function it is being aliased to. -(defun byte-compile-defalias-warn (new alias) - (let ((calls (assq new byte-compile-unresolved-functions))) - (if calls - (setq byte-compile-unresolved-functions - (delq calls byte-compile-unresolved-functions))))) - -;;; tags - -;; Note: Most operations will strip off the 'TAG, but it speeds up -;; optimization to have the 'TAG as a part of the tag. -;; Tags will be (TAG . (tag-number . stack-depth)). -(defun byte-compile-make-tag () - (list 'TAG (setq byte-compile-tag-number (1+ byte-compile-tag-number)))) - - -(defun byte-compile-out-tag (tag) - (setq byte-compile-output (cons tag byte-compile-output)) - (if (cdr (cdr tag)) - (progn - ;; ## remove this someday - (and byte-compile-depth - (not (= (cdr (cdr tag)) byte-compile-depth)) - (error "Compiler bug: depth conflict at tag %d" (car (cdr tag)))) - (setq byte-compile-depth (cdr (cdr tag)))) - (setcdr (cdr tag) byte-compile-depth))) - -(defun byte-compile-goto (opcode tag) - (setq byte-compile-output (cons (cons opcode tag) byte-compile-output)) - (setcdr (cdr tag) (if (memq opcode byte-goto-always-pop-ops) - (1- byte-compile-depth) - byte-compile-depth)) - (setq byte-compile-depth (and (not (eq opcode 'byte-goto)) - (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)))) - ;;(if (< byte-compile-depth 0) (error "Compiler error: stack underflow")) - ) - - -;;; call tree stuff - -(defun byte-compile-annotate-call-tree (form) - (let (entry) - ;; annotate the current call - (if (setq entry (assq (car form) byte-compile-call-tree)) - (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))) - ;; 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))) - )) - -;; Renamed from byte-compile-report-call-tree -;; to avoid interfering with completion of byte-compile-file. -;;;###autoload -(defun display-call-tree (&optional filename) - "Display a call graph of a specified file. -This lists which functions have been called, what functions called -them, and what functions they call. The list includes all functions -whose definitions have been compiled in this Emacs session, as well as -all functions called by those functions. - -The call graph does not include macros, inline functions, or -primitives that the byte-code interpreter knows about directly \(eq, -cons, etc.\). - -The call tree also lists those functions which are not known to be called -\(that is, to which no calls have been compiled\), and which cannot be -invoked interactively." - (interactive) - (message "Generating call tree...") - (with-output-to-temp-buffer "*Call-Tree*" - (set-buffer "*Call-Tree*") - (erase-buffer) - (message "Generating call tree... (sorting on %s)" - byte-compile-call-tree-sort) - (insert "Call tree for " - (cond ((null byte-compile-current-file) (or filename "???")) - ((stringp byte-compile-current-file) - byte-compile-current-file) - (t (buffer-name byte-compile-current-file))) - " sorted on " - (prin1-to-string byte-compile-call-tree-sort) - ":\n\n") - (if byte-compile-call-tree-sort - (setq byte-compile-call-tree - (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)))))) - ((eq byte-compile-call-tree-sort 'calls) - (function (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))))))) - ((eq byte-compile-call-tree-sort 'name) - (function (lambda (x y) (string< (car x) - (car y))))) - (t (error - "`byte-compile-call-tree-sort': `%s' - unknown sort mode" - byte-compile-call-tree-sort)))))) - (message "Generating call tree...") - (let ((rest byte-compile-call-tree) - (b (current-buffer)) - f p - callers calls) - (while rest - (prin1 (car (car rest)) b) - (setq callers (nth 1 (car rest)) - calls (nth 2 (car rest))) - (insert "\t" - (cond ((not (fboundp (setq f (car (car rest))))) - (if (null f) - " <top level>";; shouldn't insert nil then, actually -sk - " <not defined>")) - ((subrp (setq f (symbol-function f))) - " <subr>") - ((symbolp f) - (format " ==> %s" f)) - ((compiled-function-p f) - "<compiled function>") - ((not (consp f)) - "<malformed function>") - ((eq 'macro (car f)) - (if (or (compiled-function-p (cdr f)) - (assq 'byte-code (cdr (cdr (cdr f))))) - " <compiled macro>" - " <macro>")) - ((assq 'byte-code (cdr (cdr f))) - "<compiled lambda>") - ((eq 'lambda (car f)) - "<function>") - (t "???")) - (format " (%d callers + %d calls = %d)" - ;; Does the optimizer eliminate common subexpressions?-sk - (length callers) - (length calls) - (+ (length callers) (length calls))) - "\n") - (if callers - (progn - (insert " called by:\n") - (setq p (point)) - (insert " " (if (car callers) - (mapconcat 'symbol-name callers ", ") - "<top level>")) - (let ((fill-prefix " ")) - (fill-region-as-paragraph p (point))))) - (if calls - (progn - (insert " calls:\n") - (setq p (point)) - (insert " " (mapconcat 'symbol-name calls ", ")) - (let ((fill-prefix " ")) - (fill-region-as-paragraph p (point))))) - (insert "\n") - (setq rest (cdr rest))) - - (message "Generating call tree...(finding uncalled functions...)") - (setq rest byte-compile-call-tree) - (let ((uncalled nil)) - (while rest - (or (nth 1 (car rest)) - (null (setq f (car (car rest)))) - (byte-compile-fdefinition f t) - (commandp (byte-compile-fdefinition f nil)) - (setq uncalled (cons f uncalled))) - (setq rest (cdr rest))) - (if uncalled - (let ((fill-prefix " ")) - (insert "Noninteractive functions not known to be called:\n ") - (setq p (point)) - (insert (mapconcat 'symbol-name (nreverse uncalled) ", ")) - (fill-region-as-paragraph p (point))))) - ) - (message "Generating call tree...done.") - )) - - -;;; by crl@newton.purdue.edu -;;; Only works noninteractively. -;;;###autoload -(defun batch-byte-compile () - "Run `byte-compile-file' 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 \"emacs -batch -f batch-byte-compile $emacs/ ~/*.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-byte-compile' is to be used only with -batch")) - (let ((error nil) - (debug-issue-ebola-notices 0)) ; Hack -slb - (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))) - source dest) - (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) - (car command-line-args-left))) - (setq dest (byte-compile-dest-file source)) - (file-exists-p dest) - (file-newer-than-file-p source dest)) - (if (null (batch-byte-compile-1 source)) - (setq error t))) - (setq files (cdr files)))) - (if (null (batch-byte-compile-1 (car command-line-args-left))) - (setq error t))) - (setq command-line-args-left (cdr command-line-args-left))) - (message "Done") - (kill-emacs (if error 1 0)))) - -(defun batch-byte-compile-1 (file) - (condition-case err - (progn (byte-compile-file file) t) - (error - (princ ">>Error occurred processing ") - (princ file) - (princ ": ") - (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))) - (princ "\n") - nil))) - -;;;###autoload -(defun batch-byte-recompile-directory-norecurse () - "Same as `batch-byte-recompile-directory' but without recursion." - (setq byte-recompile-directory-recursively nil) - (batch-byte-recompile-directory)) - -;;;###autoload -(defun batch-byte-recompile-directory () - "Runs `byte-recompile-directory' on the dirs remaining on the command line. -Must be used only with `-batch', and kills Emacs on completion. -For example, invoke `xemacs -batch -f batch-byte-recompile-directory .'." - ;; command-line-args-left is what is left of the command line (startup.el) - (defvar command-line-args-left) ;Avoid 'free variable' warning - (if (not noninteractive) - (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)) - (while command-line-args-left - (byte-recompile-directory (car command-line-args-left)) - (setq command-line-args-left (cdr command-line-args-left)))) - (kill-emacs 0)) - -(make-obsolete 'elisp-compile-defun 'compile-defun) -(make-obsolete 'byte-compile-report-call-tree 'display-call-tree) - -;; other make-obsolete calls in obsolete.el. - -(provide 'byte-compile) -(provide 'bytecomp) - - -;;; report metering (see the hacks in bytecode.c) - -(if (boundp 'byte-code-meter) - (defun byte-compile-report-ops () - (defvar byte-code-meter) - (with-output-to-temp-buffer "*Meter*" - (set-buffer "*Meter*") - (let ((i 0) n op off) - (while (< i 256) - (setq n (aref (aref byte-code-meter 0) i) - off nil) - (if t ;(not (zerop n)) - (progn - (setq op i) - (setq off nil) - (cond ((< op byte-nth) - (setq off (logand op 7)) - (setq op (logand op 248))) - ((>= op byte-constant) - (setq off (- op byte-constant) - op byte-constant))) - (setq op (aref byte-code-vector op)) - (insert (format "%-4d" i)) - (insert (symbol-name op)) - (if off (insert " [" (int-to-string off) "]")) - (indent-to 40) - (insert (int-to-string n) "\n"))) - (setq i (1+ i))))))) - - -;; To avoid "lisp nesting exceeds max-lisp-eval-depth" when bytecomp compiles -;; itself, compile some of its most used recursive functions (at load time). -;; -(eval-when-compile - (or (compiled-function-p (symbol-function 'byte-compile-form)) - (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))) - '(byte-compile-normal-call - byte-compile-form - byte-compile-body - ;; Inserted some more than necessary, to speed it up. - byte-compile-top-level - byte-compile-out-toplevel - byte-compile-constant - byte-compile-variable-ref)))) - nil) - -;;; bytecomp.el ends here
--- a/lisp/bytecomp/disass.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,272 +0,0 @@ -;;; disass.el --- disassembler for compiled Emacs Lisp code - -;;; Copyright (C) 1986, 1991-1994 Free Software Foundation, Inc. - -;; Author: Doug Cutting <doug@csli.stanford.edu> -;; Jamie Zawinski <jwz@netscape.com> -;; Maintainer: Jamie Zawinski <jwz@netscape.com> -;; Keywords: internal - -;; 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.28. - -;;; Commentary: - -;; The single entry point, `disassemble', disassembles a code object generated -;; by the Emacs Lisp byte-compiler. This doesn't invert the compilation -;; operation, not by a long shot, but it's useful for debugging. - -;; -;; Original version by Doug Cutting (doug@csli.stanford.edu) -;; Substantially modified by Jamie Zawinski for -;; the new lapcode-based byte compiler. - -;;; 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. -OBJECT can be a symbol defined as a function, or a function itself -\(a lambda expression or a compiled-function object). -If OBJECT is not already compiled, we compile it, but do not -redefine OBJECT if it is a symbol." - (interactive (list (intern (completing-read "Disassemble function: " - obarray 'fboundp t)) - nil 0 t)) - (if (eq (car-safe object) 'byte-code) - (setq object (list 'lambda () object))) - (or indent (setq indent 0)) ;Default indent to zero - (save-excursion - (if (or interactive-p (null buffer)) - (with-output-to-temp-buffer "*Disassemble*" - (set-buffer "*Disassemble*") - (disassemble-internal object indent (not interactive-p))) - (set-buffer buffer) - (disassemble-internal object indent nil))) - nil) - - -(defun disassemble-internal (obj indent interactive-p) - (let ((macro 'nil) - (name 'nil) - args) - (while (symbolp obj) - (setq name obj - obj (symbol-function obj))) - (if (subrp obj) - (error "Can't disassemble #<subr %s>" name)) - (if (eq (car-safe obj) 'autoload) - (progn - (load (elt obj 1)) - (setq obj (symbol-function name)))) - (if (eq (car-safe obj) 'macro) ;handle macros - (setq macro t - obj (cdr obj))) - (if (and (listp obj) (eq (car obj) 'byte-code)) - (setq obj (list 'lambda nil obj))) - (if (and (listp obj) (not (eq (car obj) 'lambda))) - (error "not a function")) - (if (consp obj) - (if (assq 'byte-code obj) - nil - (if interactive-p (message (if name - "Compiling %s's definition..." - "Compiling definition...") - name)) - (setq obj (byte-compile obj)) - (if interactive-p (message "Done compiling. Disassembling...")))) - (cond ((consp obj) - (setq obj (cdr obj)) ;throw lambda away - (setq args (car obj)) ;save arg list - (setq obj (cdr obj))) - (t - (setq args (compiled-function-arglist obj)))) - (if (zerop indent) ; not a nested function - (progn - (indent-to indent) - (insert (format "byte code%s%s%s:\n" - (if (or macro name) " for" "") - (if macro " macro" "") - (if name (format " %s" name) ""))))) - (let ((doc (if (consp obj) - (and (stringp (car obj)) (car obj)) - (condition-case error - (documentation obj) - (error (format "%S" error)))))) - (if (and doc (stringp doc)) - (progn (and (consp obj) (setq obj (cdr obj))) - (indent-to indent) - (princ " doc: " (current-buffer)) - (let ((frobbed nil)) - (if (string-match "\n" doc) - (setq doc (substring doc 0 (match-beginning 0)) - frobbed t)) - (if (> (length doc) 70) - (setq doc (substring doc 0 65) frobbed t)) - (if frobbed (setq doc (concat doc " ...")))) - (insert doc "\n")))) - (indent-to indent) - (insert " args: ") - (prin1 args (current-buffer)) - (insert "\n") - (if (condition-case () - (commandp obj) ; ie interactivep - (error nil)) - (let ((interactive (if (consp obj) - (elt (assq 'interactive obj) 1) - (elt (compiled-function-interactive obj) 1)))) - (if (eq (car-safe (car-safe obj)) 'interactive) - (setq obj (cdr obj))) - (indent-to indent) - (insert " interactive: ") - (if (eq (car-safe interactive) 'byte-code) - (progn - (insert "\n") - (disassemble-1 interactive - (+ indent disassemble-recursive-indent))) - (let ((print-escape-newlines t)) - (prin1 interactive (current-buffer)))) - (insert "\n"))) - (cond ((and (consp obj) (assq 'byte-code obj)) - (disassemble-1 (assq 'byte-code obj) indent)) - ((compiled-function-p obj) - (disassemble-1 obj indent)) - (t - (insert "Uncompiled body: ") - (let ((print-escape-newlines t)) - (prin1 (if (cdr obj) (cons 'progn obj) (car obj)) - (current-buffer)))))) - (if interactive-p - (message nil))) - - -(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." - (let (bytes constvec) - (if (consp obj) - (setq bytes (car (cdr obj)) ; the byte code - constvec (car (cdr (cdr obj)))) ; constant vector - (setq bytes (compiled-function-instructions obj) - constvec (compiled-function-constants obj))) - (let ((lap (byte-decompile-bytecode bytes constvec)) - op arg opname pc-value) - (let ((tagno 0) - tmp - (lap lap)) - (while (setq tmp (assq 'TAG lap)) - (setcar (cdr tmp) (setq tagno (1+ tagno))) - (setq lap (cdr (memq tmp lap))))) - (while lap - ;; Take off the pc value of the next thing - ;; and put it in pc-value. - (setq pc-value nil) - (if (numberp (car lap)) - (setq pc-value (car lap) - lap (cdr lap))) - ;; Fetch the next op and its arg. - (setq op (car (car lap)) - arg (cdr (car lap))) - (setq lap (cdr lap)) - (indent-to indent) - (if (eq 'TAG op) - (progn - ;; We have a label. Display it, but first its pc value. - (if pc-value - (insert (format "%d:" pc-value))) - (insert (int-to-string (car arg)))) - ;; We have an instruction. Display its pc value first. - (if pc-value - (insert (format "%d" pc-value))) - (indent-to (+ indent disassemble-column-1-indent)) - (if (and op - (string-match "^byte-" (setq opname (symbol-name op)))) - (setq opname (substring opname 5)) - (setq opname "<not-an-opcode>")) - (if (eq op 'byte-constant2) - (insert " #### shouldn't have seen constant2 here!\n ")) - (insert opname) - (indent-to (+ indent disassemble-column-1-indent - disassemble-column-2-indent - -1)) - (insert " ") - (cond ((memq op byte-goto-ops) - (insert (int-to-string (nth 1 arg)))) - ((memq op '(byte-call byte-unbind - byte-listN byte-concatN byte-insertN)) - (insert (int-to-string arg))) - ((memq op '(byte-varref byte-varset byte-varbind)) - (prin1 (car arg) (current-buffer))) - ((memq op '(byte-constant byte-constant2)) - ;; it's a constant - (setq arg (car arg)) - ;; but if the value of the constant is compiled code, then - ;; recursively disassemble it. - (cond ((or (compiled-function-p arg) - (and (eq (car-safe arg) 'lambda) - (assq 'byte-code arg)) - (and (eq (car-safe arg) 'macro) - (or (compiled-function-p (cdr arg)) - (and (eq (car-safe (cdr arg)) 'lambda) - (assq 'byte-code (cdr arg)))))) - (cond ((compiled-function-p arg) - (insert "<compiled-function>\n")) - ((eq (car-safe arg) 'lambda) - (insert "<compiled lambda>")) - (t (insert "<compiled macro>\n"))) - (disassemble-internal - arg - (+ indent disassemble-recursive-indent 1) - nil)) - ((eq (car-safe arg) 'byte-code) - (insert "<byte code>\n") - (disassemble-1 ;recurse on byte-code object - arg - (+ indent disassemble-recursive-indent))) - ((eq (car-safe (car-safe arg)) 'byte-code) - (insert "(<byte code>...)\n") - (mapcar ;recurse on list of byte-code objects - '(lambda (obj) - (disassemble-1 - obj - (+ indent disassemble-recursive-indent))) - arg)) - (t - ;; really just a constant - (let ((print-escape-newlines t)) - (prin1 arg (current-buffer)))))) - ) - (insert "\n"))))) - nil) - -(provide 'disass) - -;;; disass.el ends here
--- a/lisp/cc-mode/auto-autoloads.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,145 +0,0 @@ -;;; DO NOT MODIFY THIS FILE -(if (featurep 'cc-mode-autoloads) (error "Already loaded")) - -;;;### (autoloads nil "cc-langs" "cc-mode/cc-langs.el") - -(defvar c-mode-syntax-table nil "\ -Syntax table used in c-mode buffers.") - -(defvar c++-mode-syntax-table nil "\ -Syntax table used in c++-mode buffers.") - -(defvar objc-mode-syntax-table nil "\ -Syntax table used in objc-mode buffers.") - -(defvar java-mode-syntax-table nil "\ -Syntax table used in java-mode buffers.") - -(defvar idl-mode-syntax-table nil "\ -Syntax table used in idl-mode buffers.") - -;;;*** - -;;;### (autoloads (idl-mode java-mode objc-mode c++-mode c-mode c-initialize-cc-mode) "cc-mode" "cc-mode/cc-mode.el") - -(autoload 'c-initialize-cc-mode "cc-mode" nil nil nil) - -(autoload 'c-mode "cc-mode" "\ -Major mode for editing K&R and ANSI C code. -To submit a problem report, enter `\\[c-submit-bug-report]' from a -c-mode buffer. This automatically sets up a mail buffer with version -information already added. You just need to add a description of the -problem, including a reproducible test case and send the message. - -To see what version of CC Mode you are running, enter `\\[c-version]'. - -The hook variable `c-mode-hook' is run with no args, if that value is -bound and has a non-nil value. Also the hook `c-mode-common-hook' is -run first. - -Key bindings: -\\{c-mode-map}" t nil) - -(autoload 'c++-mode "cc-mode" "\ -Major mode for editing C++ code. -To submit a problem report, enter `\\[c-submit-bug-report]' from a -c++-mode buffer. This automatically sets up a mail buffer with -version information already added. You just need to add a description -of the problem, including a reproducible test case, and send the -message. - -To see what version of CC Mode you are running, enter `\\[c-version]'. - -The hook variable `c++-mode-hook' is run with no args, if that -variable is bound and has a non-nil value. Also the hook -`c-mode-common-hook' is run first. - -Key bindings: -\\{c++-mode-map}" t nil) - -(autoload 'objc-mode "cc-mode" "\ -Major mode for editing Objective C code. -To submit a problem report, enter `\\[c-submit-bug-report]' from an -objc-mode buffer. This automatically sets up a mail buffer with -version information already added. You just need to add a description -of the problem, including a reproducible test case, and send the -message. - -To see what version of CC Mode you are running, enter `\\[c-version]'. - -The hook variable `objc-mode-hook' is run with no args, if that value -is bound and has a non-nil value. Also the hook `c-mode-common-hook' -is run first. - -Key bindings: -\\{objc-mode-map}" t nil) - -(autoload 'java-mode "cc-mode" "\ -Major mode for editing Java code. -To submit a problem report, enter `\\[c-submit-bug-report]' from a -java-mode buffer. This automatically sets up a mail buffer with -version information already added. You just need to add a description -of the problem, including a reproducible test case and send the -message. - -To see what version of CC Mode you are running, enter `\\[c-version]'. - -The hook variable `java-mode-hook' is run with no args, if that value -is bound and has a non-nil value. Also the common hook -`c-mode-common-hook' is run first. Note that this mode automatically -sets the \"java\" style before calling any hooks so be careful if you -set styles in `c-mode-common-hook'. - -Key bindings: -\\{java-mode-map}" t nil) - -(autoload 'idl-mode "cc-mode" "\ -Major mode for editing CORBA's IDL code. -To submit a problem report, enter `\\[c-submit-bug-report]' from a -idl-mode buffer. This automatically sets up a mail buffer with -version information already added. You just need to add a description -of the problem, including a reproducible test case, and send the -message. - -To see what version of CC Mode you are running, enter `\\[c-version]'. - -The hook variable `idl-mode-hook' is run with no args, if that -variable is bound and has a non-nil value. Also the hook -`c-mode-common-hook' is run first. - -Key bindings: -\\{idl-mode-map}" t nil) - -;;;*** - -;;;### (autoloads (c-set-offset c-add-style c-set-style) "cc-styles" "cc-mode/cc-styles.el") - -(autoload 'c-set-style "cc-styles" "\ -Set CC Mode variables to use one of several different indentation styles. -STYLENAME is a string representing the desired style from the list of -styles described in the variable `c-style-alist'. See that variable -for details of setting up styles. - -The variable `c-indentation-style' always contains the buffer's current -style name." t nil) - -(autoload 'c-add-style "cc-styles" "\ -Adds a style to `c-style-alist', or updates an existing one. -STYLE is a string identifying the style to add or update. DESCRIP is -an association list describing the style and must be of the form: - - ([BASESTYLE] (VARIABLE . VALUE) [(VARIABLE . VALUE) ...]) - -See the variable `c-style-alist' for the semantics of BASESTYLE, -VARIABLE and VALUE. This function also sets the current style to -STYLE using `c-set-style' if the optional SET-P flag is non-nil." t nil) - -(autoload 'c-set-offset "cc-styles" "\ -Change the value of a syntactic element symbol in `c-offsets-alist'. -SYMBOL is the syntactic element symbol to change and OFFSET is the new -offset for that syntactic element. Optional ADD says to add SYMBOL to -`c-offsets-alist' if it doesn't already appear there." t nil) - -;;;*** - -(provide 'cc-mode-autoloads)
--- a/lisp/cc-mode/cc-align.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,393 +0,0 @@ -;;; cc-align.el --- custom indentation functions for CC Mode - -;; Copyright (C) 1985,87,92,93,94,95,96,97 Free Software Foundation, Inc. - -;; Authors: 1992-1997 Barry A. Warsaw -;; 1987 Dave Detlefs and Stewart Clamen -;; 1985 Richard M. Stallman -;; Maintainer: cc-mode-help@python.org -;; Created: 22-Apr-1997 (split from cc-mode.el) -;; Version: See cc-mode.el -;; Keywords: c languages oop - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -(eval-when-compile - (require 'cc-defs) - (require 'cc-vars) - (require 'cc-engine) - (require 'cc-langs)) - - -;; Standard indentation line-ups -(defun c-lineup-arglist (langelem) - ;; lineup the current arglist line with the arglist appearing just - ;; after the containing paren which starts the arglist. - (save-excursion - (let* ((containing-sexp - (save-excursion - ;; arglist-cont-nonempty gives relpos == - ;; to boi of containing-sexp paren. This - ;; is good when offset is +, but bad - ;; when it is c-lineup-arglist, so we - ;; have to special case a kludge here. - (if (memq (car langelem) '(arglist-intro arglist-cont-nonempty)) - (progn - (beginning-of-line) - (backward-up-list 1) - (skip-chars-forward " \t" (c-point 'eol))) - (goto-char (cdr langelem))) - (point))) - (langelem-col (c-langelem-col langelem t))) - (if (save-excursion - (beginning-of-line) - (looking-at "[ \t]*)")) - (progn (goto-char (match-end 0)) - (forward-sexp -1) - (forward-char 1) - (c-forward-syntactic-ws) - (- (current-column) langelem-col)) - (goto-char containing-sexp) - (or (eolp) - (not (memq (char-after) '(?{ ?\( ))) - (let ((eol (c-point 'eol)) - (here (progn - (forward-char 1) - (skip-chars-forward " \t") - (point)))) - (c-forward-syntactic-ws) - (if (< (point) eol) - (goto-char here)))) - (- (current-column) langelem-col) - )))) - -(defun c-lineup-arglist-intro-after-paren (langelem) - ;; lineup an arglist-intro line to just after the open paren - (save-excursion - (let ((langelem-col (c-langelem-col langelem t)) - (ce-curcol (save-excursion - (beginning-of-line) - (backward-up-list 1) - (skip-chars-forward " \t" (c-point 'eol)) - (current-column)))) - (- ce-curcol langelem-col -1)))) - -(defun c-lineup-arglist-close-under-paren (langelem) - ;; lineup an arglist-intro line to just after the open paren - (save-excursion - (let ((langelem-col (c-langelem-col langelem t)) - (ce-curcol (save-excursion - (beginning-of-line) - (backward-up-list 1) - (current-column)))) - (- ce-curcol langelem-col)))) - -(defun c-lineup-streamop (langelem) - ;; lineup stream operators - (save-excursion - (let ((langelem-col (c-langelem-col langelem))) - (re-search-forward "<<\\|>>" (c-point 'eol) 'move) - (goto-char (match-beginning 0)) - (- (current-column) langelem-col)))) - -(defun c-lineup-multi-inher (langelem) - ;; line up multiple inheritance lines - (save-excursion - (let ((eol (c-point 'eol)) - (here (point)) - (langelem-col (c-langelem-col langelem))) - (skip-chars-forward "^:" eol) - (skip-chars-forward " \t:" eol) - (if (or (eolp) - (looking-at c-comment-start-regexp)) - (c-forward-syntactic-ws here)) - (- (current-column) langelem-col) - ))) - -(defun c-lineup-java-inher (langelem) - ;; line up Java implements and extends continuations - (save-excursion - (let ((langelem-col (c-langelem-col langelem))) - (forward-word 1) - (if (looking-at "[ \t]*$") - langelem-col - (c-forward-syntactic-ws) - (- (current-column) langelem-col))))) - -(defun c-lineup-java-throws (langelem) - ;; lineup func-decl-cont's in Java which are continuations of throws - ;; declarations. If `throws' starts the previous line, line up to - ;; just after that keyword. If not, lineup under the previous line. - (save-excursion - (let ((iopl (c-point 'iopl)) - (langelem-col (c-langelem-col langelem t)) - (extra 0)) - (back-to-indentation) - (cond - ((looking-at "throws[ \t\n]") - (goto-char (cdr langelem)) - (setq extra c-basic-offset)) - ((and (goto-char iopl) - (looking-at "throws[ \t\n]")) - (forward-word 1) - (skip-chars-forward " \t") - (if (eolp) - (progn - (back-to-indentation) - (setq extra c-basic-offset)))) - (t (goto-char iopl))) - (+ (- (current-column) langelem-col) extra)))) - -(defun c-lineup-C-comments (langelem) - ;; line up C block comment continuation lines - (save-excursion - (let ((here (point)) - (stars (progn (back-to-indentation) - (skip-chars-forward "*"))) - (langelem-col (c-langelem-col langelem))) - (back-to-indentation) - (if (not (re-search-forward "/\\([*]+\\)" (c-point 'eol) t)) - (progn - (if (not (looking-at "[*]+")) - (progn - ;; we now have to figure out where this comment begins. - (goto-char here) - (back-to-indentation) - (if (looking-at "[*]+/") - (progn (goto-char (match-end 0)) - (forward-comment -1)) - (goto-char (cdr langelem)) - (back-to-indentation)))) - (- (current-column) langelem-col)) - (if (zerop stars) - (progn - (skip-chars-forward " \t") - (- (current-column) langelem-col)) - ;; how many stars on comment opening line? if greater than - ;; on current line, align left. if less than or equal, - ;; align right. this should also pick up Javadoc style - ;; comments. - (if (> (length (match-string 1)) stars) - (progn - (back-to-indentation) - (- (current-column) -1 langelem-col)) - (- (current-column) stars langelem-col)) - ))))) - -(defun c-lineup-comment (langelem) - ;; support old behavior for comment indentation. we look at - ;; c-comment-only-line-offset to decide how to indent comment - ;; only-lines - (save-excursion - (back-to-indentation) - ;; this highly kludgiforous flag prevents the mapcar over - ;; c-syntactic-context from entering an infinite loop - (let ((recurse-prevention-flag (boundp 'recurse-prevention-flag))) - (cond - ;; CASE 1: preserve comment-column - (recurse-prevention-flag 0) - ((= (current-column) comment-column) - ;; we have to subtract out all other indentation - (- comment-column (apply '+ (mapcar 'c-get-offset - c-syntactic-context)))) - ;; indent as specified by c-comment-only-line-offset - ((not (bolp)) - (or (car-safe c-comment-only-line-offset) - c-comment-only-line-offset)) - (t - (or (cdr-safe c-comment-only-line-offset) - (car-safe c-comment-only-line-offset) - -1000)) ;jam it against the left side - )))) - -(defun c-lineup-runin-statements (langelem) - ;; line up statements in coding standards which place the first - ;; statement on the same line as the block opening brace. - (if (eq (char-after (cdr langelem)) ?{) - (save-excursion - (let ((langelem-col (c-langelem-col langelem))) - (forward-char 1) - (skip-chars-forward " \t") - (- (current-column) langelem-col))) - 0)) - -(defun c-lineup-math (langelem) - ;; line up math statement-cont after the equals - (save-excursion - (let ((equalp (save-excursion - (goto-char (c-point 'boi)) - (skip-chars-forward "^=" (c-point 'eol)) - (and (eq (char-after) ?=) - (- (point) (c-point 'boi))))) - (langelem-col (c-langelem-col langelem)) - donep) - (while (and (not donep) - (< (point) (c-point 'eol))) - (skip-chars-forward "^=" (c-point 'eol)) - (if (c-in-literal (cdr langelem)) - (forward-char 1) - (setq donep t))) - (if (not (eq (char-after) ?=)) - ;; there's no equal sign on the line - c-basic-offset - ;; calculate indentation column after equals and ws, unless - ;; our line contains an equals sign - (if (not equalp) - (progn - (forward-char 1) - (skip-chars-forward " \t") - (setq equalp 0))) - (- (current-column) equalp langelem-col)) - ))) - -(defun c-lineup-ObjC-method-call (langelem) - ;; Line up methods args as elisp-mode does with function args: go to - ;; the position right after the message receiver, and if you are at - ;; (eolp) indent the current line by a constant offset from the - ;; opening bracket; otherwise we are looking at the first character - ;; of the first method call argument, so lineup the current line - ;; with it. - (save-excursion - (let* ((extra (save-excursion - (back-to-indentation) - (c-backward-syntactic-ws (cdr langelem)) - (if (eq (char-before) ?:) - (- c-basic-offset) - 0))) - (open-bracket-pos (cdr langelem)) - (open-bracket-col (progn - (goto-char open-bracket-pos) - (current-column))) - (target-col (progn - (forward-char) - (forward-sexp) - (skip-chars-forward " \t") - (if (eolp) - (+ open-bracket-col c-basic-offset) - (current-column)))) - ) - (- target-col open-bracket-col extra)))) - -(defun c-lineup-ObjC-method-args (langelem) - ;; Line up the colons that separate args. This is done trying to - ;; align colons vertically. - (save-excursion - (let* ((here (c-point 'boi)) - (curcol (progn (goto-char here) (current-column))) - (eol (c-point 'eol)) - (relpos (cdr langelem)) - (first-col-column (progn - (goto-char relpos) - (skip-chars-forward "^:" eol) - (and (eq (char-after) ?:) - (current-column))))) - (if (not first-col-column) - c-basic-offset - (goto-char here) - (skip-chars-forward "^:" eol) - (if (eq (char-after) ?:) - (+ curcol (- first-col-column (current-column))) - c-basic-offset))))) - -(defun c-lineup-ObjC-method-args-2 (langelem) - ;; Line up the colons that separate args. This is done trying to - ;; align the colon on the current line with the previous one. - (save-excursion - (let* ((here (c-point 'boi)) - (curcol (progn (goto-char here) (current-column))) - (eol (c-point 'eol)) - (relpos (cdr langelem)) - (prev-col-column (progn - (skip-chars-backward "^:" relpos) - (and (eq (char-before) ?:) - (- (current-column) 1))))) - (if (not prev-col-column) - c-basic-offset - (goto-char here) - (skip-chars-forward "^:" eol) - (if (eq (char-after) ?:) - (+ curcol (- prev-col-column (current-column))) - c-basic-offset))))) - -(defun c-snug-do-while (syntax pos) - "Dynamically calculate brace hanginess for do-while statements. -Using this function, `while' clauses that end a `do-while' block will -remain on the same line as the brace that closes that block. - -See `c-hanging-braces-alist' for how to utilize this function as an -ACTION associated with `block-close' syntax." - (save-excursion - (let (langelem) - (if (and (eq syntax 'block-close) - (setq langelem (assq 'block-close c-syntactic-context)) - (progn (goto-char (cdr langelem)) - (if (eq (char-after) ?{) - (c-safe (forward-sexp -1))) - (looking-at "\\<do\\>[^_]"))) - '(before) - '(before after))))) - -(defun c-gnu-impose-minimum () - "Imposes a minimum indentation for lines inside a top-level construct. -The variable `c-label-minimum-indentation' specifies the minimum -indentation amount." - (let ((non-top-levels '(defun-block-intro statement statement-cont - statement-block-intro statement-case-intro - statement-case-open substatement substatement-open - case-label label do-while-closure else-clause - )) - (syntax c-syntactic-context) - langelem) - (while syntax - (setq langelem (car (car syntax)) - syntax (cdr syntax)) - ;; don't adjust comment-only lines - (cond ((eq langelem 'comment-intro) - (setq syntax nil)) - ((memq langelem non-top-levels) - (save-excursion - (setq syntax nil) - (back-to-indentation) - (if (zerop (current-column)) - (insert (make-string c-label-minimum-indentation 32))) - )) - )))) - - -;; Useful for c-hanging-semi&comma-criteria -(defun c-semi&comma-inside-parenlist () - "Determine if a newline should be added after a semicolon. -If a comma was inserted, no determination is made. If a semicolon was -inserted inside a parenthesis list, no newline is added otherwise a -newline is added. In either case, checking is stopped. This supports -exactly the old newline insertion behavior." - ;; newline only after semicolon, but only if that semicolon is not - ;; inside a parenthesis list (e.g. a for loop statement) - (if (not (eq last-command-char ?\;)) - nil ; continue checking - (if (condition-case nil - (save-excursion - (up-list -1) - (not (eq (char-after) ?\())) - (error t)) - t - 'stop))) - - -(provide 'cc-align) -;;; cc-align.el ends here
--- a/lisp/cc-mode/cc-cmds.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1444 +0,0 @@ -;;; cc-cmds.el --- user level commands for CC Mode - -;; Copyright (C) 1985,87,92,93,94,95,96,97 Free Software Foundation, Inc. - -;; Authors: 1992-1997 Barry A. Warsaw -;; 1987 Dave Detlefs and Stewart Clamen -;; 1985 Richard M. Stallman -;; Maintainer: cc-mode-help@python.org -;; Created: 22-Apr-1997 (split from cc-mode.el) -;; Version: See cc-mode.el -;; Keywords: c languages oop - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -(eval-when-compile - (require 'cc-defs)) - - -(defun c-calculate-state (arg prevstate) - ;; Calculate the new state of PREVSTATE, t or nil, based on arg. If - ;; arg is nil or zero, toggle the state. If arg is negative, turn - ;; the state off, and if arg is positive, turn the state on - (if (or (not arg) - (zerop (setq arg (prefix-numeric-value arg)))) - (not prevstate) - (> arg 0))) - -;; Auto-newline and hungry-delete -(defun c-toggle-auto-state (arg) - "Toggle auto-newline feature. -Optional numeric ARG, if supplied turns on auto-newline when positive, -turns it off when negative, and just toggles it when zero. - -When the auto-newline feature is enabled (as evidenced by the `/a' or -`/ah' on the modeline after the mode name) newlines are automatically -inserted after special characters such as brace, comma, semi-colon, -and colon." - (interactive "P") - (setq c-auto-newline (c-calculate-state arg c-auto-newline)) - (c-update-modeline) - (c-keep-region-active)) - -(defun c-toggle-hungry-state (arg) - "Toggle hungry-delete-key feature. -Optional numeric ARG, if supplied turns on hungry-delete when positive, -turns it off when negative, and just toggles it when zero. - -When the hungry-delete-key feature is enabled (as evidenced by the -`/h' or `/ah' on the modeline after the mode name) the delete key -gobbles all preceding whitespace in one fell swoop." - (interactive "P") - (setq c-hungry-delete-key (c-calculate-state arg c-hungry-delete-key)) - (c-update-modeline) - (c-keep-region-active)) - -(defun c-toggle-auto-hungry-state (arg) - "Toggle auto-newline and hungry-delete-key features. -Optional numeric ARG, if supplied turns on auto-newline and -hungry-delete when positive, turns them off when negative, and just -toggles them when zero. - -See `c-toggle-auto-state' and `c-toggle-hungry-state' for details." - (interactive "P") - (setq c-auto-newline (c-calculate-state arg c-auto-newline)) - (setq c-hungry-delete-key (c-calculate-state arg c-hungry-delete-key)) - (c-update-modeline) - (c-keep-region-active)) - - -;; Electric keys - -;; Note: In XEmacs 20.3 the Delete and BackSpace keysyms have been -;; separated and "\177" is no longer an alias for both keys. Also, -;; the variable delete-key-deletes-forward controls in which direction -;; the Delete keysym deletes characters. The functions -;; c-electric-delete and c-electric-backspace attempt to deal with -;; this new functionality. For Emacs 19 and XEmacs 19 backwards -;; compatibility, the old behavior has moved to c-electric-backspace -;; and c-backspace-function. - -(defun c-electric-backspace (arg) - "Deletes preceding character or whitespace. -If `c-hungry-delete-key' is non-nil, as evidenced by the \"/h\" or -\"/ah\" string on the mode line, then all preceding whitespace is -consumed. If however an ARG is supplied, or `c-hungry-delete-key' is -nil, or point is inside a literal then the function in the variable -`c-backspace-function' is called. - -See also \\[c-electric-delete]." - (interactive "P") - (if (or (not c-hungry-delete-key) - arg - (c-in-literal)) - (funcall c-backspace-function (prefix-numeric-value arg)) - (let ((here (point))) - (skip-chars-backward " \t\n") - (if (/= (point) here) - (delete-region (point) here) - (funcall c-backspace-function 1) - )))) - -(defun c-electric-delete (arg) - "Deletes preceding or following character or whitespace. - -The behavior of this function depends on the variable -`delete-key-deletes-forward'. If this variable is nil (or does not -exist, as in older Emacsen), then this function behaves identical to -\\[c-electric-backspace]. - -If `delete-key-deletes-forward' is non-nil, then deletion occurs in -the forward direction. So if `c-hungry-delete-key' is non-nil, as -evidenced by the \"/h\" or \"/ah\" string on the mode line, then all -following whitespace is consumed. If however an ARG is supplied, or -`c-hungry-delete-key' is nil, or point is inside a literal then the -function in the variable `c-delete-function' is called." - (interactive "P") - (if (and (boundp 'delete-key-deletes-forward) - delete-key-deletes-forward) - (if (or (not c-hungry-delete-key) - arg - (c-in-literal)) - (funcall c-delete-function (prefix-numeric-value arg)) - (let ((here (point))) - (skip-chars-forward " \t\n") - (if (/= (point) here) - (delete-region (point) here) - (funcall c-delete-function 1)))) - ;; act just like c-electric-backspace - (c-electric-backspace arg))) - -(defun c-electric-pound (arg) - "Electric pound (`#') insertion. -Inserts a `#' character specially depending on the variable -`c-electric-pound-behavior'. If a numeric ARG is supplied, or if -point is inside a literal, nothing special happens." - (interactive "P") - (if (or (c-in-literal) - arg - (not (memq 'alignleft c-electric-pound-behavior))) - ;; do nothing special - (self-insert-command (prefix-numeric-value arg)) - ;; place the pound character at the left edge - (let ((pos (- (point-max) (point))) - (bolp (bolp))) - (beginning-of-line) - (delete-horizontal-space) - (insert-char last-command-char 1) - (and (not bolp) - (goto-char (- (point-max) pos))) - ))) - -(defun c-electric-brace (arg) - "Insert a brace. - -If the auto-newline feature is turned on, as evidenced by the \"/a\" -or \"/ah\" string on the mode line, newlines are inserted before and -after braces based on the value of `c-hanging-braces-alist'. - -Also, the line is re-indented unless a numeric ARG is supplied, there -are non-whitespace characters present on the line after the brace, or -the brace is inserted inside a literal." - (interactive "P") - (let* ((c-state-cache (c-parse-state)) - (safepos (c-safe-position (point) c-state-cache)) - (literal (c-in-literal safepos))) - ;; if we're in a literal, or we're not at the end of the line, or - ;; a numeric arg is provided, or auto-newlining is turned off, - ;; then just insert the character. - (if (or literal arg -; (not c-auto-newline) - (not (looking-at "[ \t]*$"))) - (self-insert-command (prefix-numeric-value arg)) - (let* ((syms '(class-open class-close defun-open defun-close - inline-open inline-close brace-list-open brace-list-close - brace-list-intro brace-list-entry block-open block-close - substatement-open statement-case-open - extern-lang-open extern-lang-close)) - ;; we want to inhibit blinking the paren since this will - ;; be most disruptive. we'll blink it ourselves later on - (old-blink-paren blink-paren-function) - blink-paren-function - (insertion-point (point)) - delete-temp-newline - (preserve-p (and (not (bobp)) - (eq ?\ (char-syntax (char-before))))) - ;; shut this up too - (c-echo-syntactic-information-p nil) - (syntax (progn - ;; only insert a newline if there is - ;; non-whitespace behind us - (if (save-excursion - (skip-chars-backward " \t") - (not (bolp))) - (progn (newline) - (setq delete-temp-newline t))) - (self-insert-command (prefix-numeric-value arg)) - ;; state cache doesn't change - (c-guess-basic-syntax))) - (newlines (and - c-auto-newline - (or (c-lookup-lists syms syntax c-hanging-braces-alist) - '(ignore before after))))) - ;; If syntax is a function symbol, then call it using the - ;; defined semantics. - (if (and (not (consp (cdr newlines))) - (functionp (cdr newlines))) - (let ((c-syntactic-context syntax)) - (setq newlines - (funcall (cdr newlines) (car newlines) insertion-point)))) - ;; does a newline go before the open brace? - (if (memq 'before newlines) - ;; we leave the newline we've put in there before, - ;; but we need to re-indent the line above - (let ((pos (- (point-max) (point))) - (here (point)) - (c-state-cache c-state-cache)) - (forward-line -1) - ;; we may need to update the cache. this should still be - ;; faster than recalculating the state in many cases - (save-excursion - (save-restriction - (narrow-to-region here (point)) - (if (and (c-safe (progn (backward-up-list -1) t)) - (memq (char-before) '(?\) ?})) - (progn (widen) - (c-safe (progn (forward-sexp -1) t)))) - (setq c-state-cache - (c-hack-state (point) 'open c-state-cache)) - (if (and (car c-state-cache) - (not (consp (car c-state-cache))) - (<= (point) (car c-state-cache))) - (setq c-state-cache (cdr c-state-cache)) - )))) - (let ((here (point)) - (shift (c-indent-line))) - (setq c-state-cache (c-adjust-state (c-point 'bol) here - (- shift) c-state-cache))) - (goto-char (- (point-max) pos)) - ;; if the buffer has changed due to the indentation, we - ;; need to recalculate syntax for the current line, but - ;; we won't need to update the state cache. - (if (/= (point) here) - (setq syntax (c-guess-basic-syntax)))) - ;; must remove the newline we just stuck in (if we really did it) - (and delete-temp-newline - (save-excursion - ;; if there is whitespace before point, then preserve - ;; at least one space. - (delete-indentation) - (just-one-space) - (if (not preserve-p) - (delete-char -1)))) - ;; since we're hanging the brace, we need to recalculate - ;; syntax. Update the state to accurately reflect the - ;; beginning of the line. We punt if we cross any open or - ;; closed parens because its just too hard to modify the - ;; known state. This limitation will be fixed in v5. - (save-excursion - (let ((bol (c-point 'bol))) - (if (zerop (car (parse-partial-sexp bol (1- (point))))) - (setq c-state-cache (c-whack-state bol c-state-cache) - syntax (c-guess-basic-syntax)) - ;; gotta punt. this requires some horrible kludgery - (beginning-of-line) - (makunbound 'c-state-cache) - (setq c-state-cache (c-parse-state) - syntax nil)))) - ) - ;; now adjust the line's indentation. don't update the state - ;; cache since c-guess-basic-syntax isn't called when the - ;; syntax is passed to c-indent-line - (let ((here (point)) - (shift (c-indent-line syntax))) - (setq c-state-cache (c-adjust-state (c-point 'bol) here - (- shift) c-state-cache))) - ;; Do all appropriate clean ups - (let ((here (point)) - (pos (- (point-max) (point))) - mbeg mend) - ;; clean up empty defun braces - (if (and c-auto-newline - (memq 'empty-defun-braces c-cleanup-list) - (eq last-command-char ?\}) - (c-intersect-lists '(defun-close class-close inline-close) - syntax) - (progn - (forward-char -1) - (skip-chars-backward " \t\n") - (eq (char-before) ?\{)) - ;; make sure matching open brace isn't in a comment - (not (c-in-literal))) - (delete-region (point) (1- here))) - ;; clean up brace-else-brace - (if (and c-auto-newline - (memq 'brace-else-brace c-cleanup-list) - (eq last-command-char ?\{) - (re-search-backward "}[ \t\n]*else[ \t\n]*{" nil t) - (progn - (setq mbeg (match-beginning 0) - mend (match-end 0)) - (= mend here)) - (not (c-in-literal))) - (progn - (delete-region mbeg mend) - (insert "} else {"))) - ;; clean up brace-elseif-brace - (if (and c-auto-newline - (memq 'brace-elseif-brace c-cleanup-list) - (eq last-command-char ?\{) - (re-search-backward "}[ \t\n]*else[ \t\n]+if[ \t\n]*" nil t) - (save-excursion - (goto-char (match-end 0)) - (c-safe (forward-sexp 1)) - (skip-chars-forward " \t\n") - (setq mbeg (match-beginning 0) - mend (match-end 0)) - (= here (1+ (point)))) - (not (c-in-literal))) - (progn - (delete-region mbeg mend) - (insert "} else if "))) - (goto-char (- (point-max) pos)) - ) - ;; does a newline go after the brace? - (if (memq 'after newlines) - (progn - (newline) - ;; update on c-state-cache - (let* ((bufpos (- (point) 2)) - (which (if (eq (char-after bufpos) ?{) 'open 'close)) - (c-state-cache (c-hack-state bufpos which c-state-cache))) - (c-indent-line)))) - ;; blink the paren - (and (eq last-command-char ?\}) - old-blink-paren - (save-excursion - (c-backward-syntactic-ws safepos) - (funcall old-blink-paren))) - )))) - -(defun c-electric-slash (arg) - "Insert a slash character. - -Indent the line as a comment, if: - - 1. The slash is second of a `//' line oriented comment introducing - token and we are on a comment-only-line, or - - 2. The slash is part of a `*/' token that closes a block oriented - comment. - -If numeric ARG is supplied or point is inside a literal, indentation -is inhibited." - (interactive "P") - (let* ((ch (char-before)) - (indentp (and (not arg) - (eq last-command-char ?/) - (or (and (eq ch ?/) - (not (c-in-literal))) - (and (eq ch ?*) - (c-in-literal))) - )) - ;; shut this up - (c-echo-syntactic-information-p nil)) - (self-insert-command (prefix-numeric-value arg)) - (if indentp - (c-indent-line)))) - -(defun c-electric-star (arg) - "Insert a star character. -If the star is the second character of a C style comment introducing -construct, and we are on a comment-only-line, indent line as comment. -If numeric ARG is supplied or point is inside a literal, indentation -is inhibited." - (interactive "P") - (self-insert-command (prefix-numeric-value arg)) - ;; if we are in a literal, or if arg is given do not re-indent the - ;; current line, unless this star introduces a comment-only line. - (if (and (not arg) - (memq (c-in-literal) '(c)) - (eq (char-before) ?*) - (save-excursion - (forward-char -1) - (skip-chars-backward "*") - (if (eq (char-before) ?/) - (forward-char -1)) - (skip-chars-backward " \t") - (bolp))) - ;; shut this up - (let (c-echo-syntactic-information-p) - (c-indent-line)) - )) - -(defun c-electric-semi&comma (arg) - "Insert a comma or semicolon. -When the auto-newline feature is turned on, as evidenced by the \"/a\" -or \"/ah\" string on the mode line, a newline might be inserted. See -the variable `c-hanging-semi&comma-criteria' for how newline insertion -is determined. - -When semicolon is inserted, the line is re-indented unless a numeric -arg is supplied, point is inside a literal, or there are -non-whitespace characters on the line following the semicolon." - (interactive "P") - (let* ((lim (c-most-enclosing-brace (c-parse-state))) - (literal (c-in-literal lim)) - (here (point)) - ;; shut this up - (c-echo-syntactic-information-p nil)) - (if (or literal - arg - (not (looking-at "[ \t]*$"))) - (self-insert-command (prefix-numeric-value arg)) - ;; do some special stuff with the character - (self-insert-command (prefix-numeric-value arg)) - ;; do all cleanups, reindentations, and newline insertions, but - ;; only if c-auto-newline is turned on - (if (not c-auto-newline) nil - ;; clean ups - (let ((pos (- (point-max) (point)))) - (if (and (or (and - (eq last-command-char ?,) - (memq 'list-close-comma c-cleanup-list)) - (and - (eq last-command-char ?\;) - (memq 'defun-close-semi c-cleanup-list))) - (progn - (forward-char -1) - (skip-chars-backward " \t\n") - (eq (char-before) ?})) - ;; make sure matching open brace isn't in a comment - (not (c-in-literal lim))) - (delete-region (point) here)) - (goto-char (- (point-max) pos))) - ;; re-indent line - (c-indent-line) - ;; check to see if a newline should be added - (let ((criteria c-hanging-semi&comma-criteria) - answer add-newline-p) - (while criteria - (setq answer (funcall (car criteria))) - ;; only nil value means continue checking - (if (not answer) - (setq criteria (cdr criteria)) - (setq criteria nil) - ;; only 'stop specifically says do not add a newline - (setq add-newline-p (not (eq answer 'stop))) - )) - (if add-newline-p - (progn (newline) - (c-indent-line))) - ))))) - -(defun c-electric-colon (arg) - "Insert a colon. - -If the auto-newline feature is turned on, as evidenced by the \"/a\" -or \"/ah\" string on the mode line, newlines are inserted before and -after colons based on the value of `c-hanging-colons-alist'. - -Also, the line is re-indented unless a numeric ARG is supplied, there -are non-whitespace characters present on the line after the colon, or -the colon is inserted inside a literal. - -This function cleans up double colon scope operators based on the -value of `c-cleanup-list'." - (interactive "P") - (let* ((bod (c-point 'bod)) - (literal (c-in-literal bod)) - syntax newlines - ;; shut this up - (c-echo-syntactic-information-p nil)) - (if (or literal - arg - (not (looking-at "[ \t]*$"))) - (self-insert-command (prefix-numeric-value arg)) - ;; insert the colon, then do any specified cleanups - (self-insert-command (prefix-numeric-value arg)) - (let ((pos (- (point-max) (point))) - (here (point))) - (if (and c-auto-newline - (memq 'scope-operator c-cleanup-list) - (eq (char-before) ?:) - (progn - (forward-char -1) - (skip-chars-backward " \t\n") - (eq (char-before) ?:)) - (not (c-in-literal)) - (not (eq (char-after (- (point) 2)) ?:))) - (delete-region (point) (1- here))) - (goto-char (- (point-max) pos))) - ;; lets do some special stuff with the colon character - (setq syntax (c-guess-basic-syntax) - ;; some language elements can only be determined by - ;; checking the following line. Lets first look for ones - ;; that can be found when looking on the line with the - ;; colon - newlines - (and c-auto-newline - (or (c-lookup-lists '(case-label label access-label) - syntax c-hanging-colons-alist) - (c-lookup-lists '(member-init-intro inher-intro) - (prog2 - (insert "\n") - (c-guess-basic-syntax) - (delete-char -1)) - c-hanging-colons-alist)))) - ;; indent the current line - (c-indent-line syntax) - ;; does a newline go before the colon? Watch out for already - ;; non-hung colons. However, we don't unhang them because that - ;; would be a cleanup (and anti-social). - (if (and (memq 'before newlines) - (save-excursion - (skip-chars-backward ": \t") - (not (bolp)))) - (let ((pos (- (point-max) (point)))) - (forward-char -1) - (newline) - (c-indent-line) - (goto-char (- (point-max) pos)))) - ;; does a newline go after the colon? - (if (memq 'after (cdr-safe newlines)) - (progn - (newline) - (c-indent-line))) - ))) - -(defun c-electric-lt-gt (arg) - "Insert a less-than, or greater-than character. -When the auto-newline feature is turned on, as evidenced by the \"/a\" -or \"/ah\" string on the mode line, the line will be re-indented if -the character inserted is the second of a C++ style stream operator -and the buffer is in C++ mode. - -The line will also not be re-indented if a numeric argument is -supplied, or point is inside a literal." - (interactive "P") - (let ((indentp (and (not arg) - (eq (char-before) last-command-char) - (not (c-in-literal)))) - ;; shut this up - (c-echo-syntactic-information-p nil)) - (self-insert-command (prefix-numeric-value arg)) - (if indentp - (c-indent-line)))) - - - -;; better movement routines for ThisStyleOfVariablesCommonInCPlusPlus -;; originally contributed by Terry_Glanfield.Southern@rxuk.xerox.com -(defun c-forward-into-nomenclature (&optional arg) - "Move forward to end of a nomenclature section or word. -With arg, to it arg times." - (interactive "p") - (let ((case-fold-search nil)) - (if (> arg 0) - (re-search-forward "\\W*\\([A-Z]*[a-z0-9]*\\)" (point-max) t arg) - (while (and (< arg 0) - (re-search-backward - "\\(\\(\\W\\|[a-z0-9]\\)[A-Z]+\\|\\W\\w+\\)" - (point-min) 0)) - (forward-char 1) - (setq arg (1+ arg))))) - (c-keep-region-active)) - -(defun c-backward-into-nomenclature (&optional arg) - "Move backward to beginning of a nomenclature section or word. -With optional ARG, move that many times. If ARG is negative, move -forward." - (interactive "p") - (c-forward-into-nomenclature (- arg)) - (c-keep-region-active)) - -(defun c-scope-operator () - "Insert a double colon scope operator at point. -No indentation or other \"electric\" behavior is performed." - (interactive) - (insert "::")) - - -(defun c-beginning-of-statement (&optional count lim sentence-flag) - "Go to the beginning of the innermost C statement. -With prefix arg, go back N - 1 statements. If already at the -beginning of a statement then go to the beginning of the preceding -one. If within a string or comment, or next to a comment (only -whitespace between), move by sentences instead of statements. - -When called from a program, this function takes 3 optional args: the -repetition count, a buffer position limit which is the farthest back -to search, and a flag saying whether to do sentence motion when in a -comment." - (interactive (list (prefix-numeric-value current-prefix-arg) - nil t)) - (let ((here (point)) - (count (or count 1)) - (lim (or lim (c-point 'bod))) - state) - (save-excursion - (goto-char lim) - (setq state (parse-partial-sexp (point) here nil nil))) - (if (and sentence-flag - (or (nth 3 state) - (nth 4 state) - ;; skipping forward into a comment? - (and (> 0 count) - (save-excursion - (skip-chars-forward " \t\n") - (or (eobp) - (looking-at comment-start-skip)))) - (and (< 0 count) - (save-excursion - (skip-chars-backward " \t\n") - (goto-char (- (point) 2)) - (looking-at "\\*/"))))) - (forward-sentence (- count)) - (while (> count 0) - (c-beginning-of-statement-1 lim) - (setq count (1- count))) - (while (< count 0) - (c-end-of-statement-1) - (setq count (1+ count)))) - ;; its possible we've been left up-buf of lim - (goto-char (max (point) lim)) - ) - (c-keep-region-active)) - -(defun c-end-of-statement (&optional count lim sentence-flag) - "Go to the end of the innermost C statement. - -With prefix arg, go forward N - 1 statements. Move forward to end of -the next statement if already at end. If within a string or comment, -move by sentences instead of statements. - -When called from a program, this function takes 3 optional args: the -repetition count, a buffer position limit which is the farthest back -to search, and a flag saying whether to do sentence motion when in a -comment." - (interactive (list (prefix-numeric-value current-prefix-arg) - nil t)) - (c-beginning-of-statement (- (or count 1)) lim sentence-flag) - (c-keep-region-active)) - - -;; set up electric character functions to work with pending-del, -;; (a.k.a. delsel) mode. All symbols get the t value except -;; the functions which delete, which gets 'supersede. -(mapcar - (function - (lambda (sym) - (put sym 'delete-selection t) ; for delsel (Emacs) - (put sym 'pending-delete t))) ; for pending-del (XEmacs) - '(c-electric-pound - c-electric-brace - c-electric-slash - c-electric-star - c-electric-semi&comma - c-electric-lt-gt - c-electric-colon)) -(put 'c-electric-delete 'delete-selection 'supersede) ; delsel -(put 'c-electric-delete 'pending-delete 'supersede) ; pending-del -(put 'c-electric-backspace 'delete-selection 'supersede) ; delsel -(put 'c-electric-backspace 'pending-delete 'supersede) ; pending-del - - -;; This is used by indent-for-comment to decide how much to indent a -;; comment in C code based on its context. -(defun c-comment-indent () - (if (looking-at (concat "^\\(" c-comment-start-regexp "\\)")) - 0 ;Existing comment at bol stays there. - (let ((opoint (point)) - placeholder) - (save-excursion - (beginning-of-line) - (cond - ;; CASE 1: A comment following a solitary close-brace should - ;; have only one space. - ((looking-at (concat "[ \t]*}[ \t]*\\($\\|" - c-comment-start-regexp - "\\)")) - (search-forward "}") - (1+ (current-column))) - ;; CASE 2: 2 spaces after #endif - ((or (looking-at "^#[ \t]*endif[ \t]*") - (looking-at "^#[ \t]*else[ \t]*")) - 7) - ;; CASE 3: when comment-column is nil, calculate the offset - ;; according to c-offsets-alist. E.g. identical to hitting - ;; TAB. - ((and c-indent-comments-syntactically-p - (save-excursion - (skip-chars-forward " \t") - (or (looking-at comment-start) - (eolp)))) - (let ((syntax (c-guess-basic-syntax))) - ;; BOGOSITY ALERT: if we're looking at the eol, its - ;; because indent-for-comment hasn't put the comment-start - ;; in the buffer yet. this will screw up the syntactic - ;; analysis so we kludge in the necessary info. Another - ;; kludge is that if we're at the bol, then we really want - ;; to ignore any anchoring as specified by - ;; c-comment-only-line-offset since it doesn't apply here. - (if (save-excursion - (beginning-of-line) - (skip-chars-forward " \t") - (eolp)) - (c-add-syntax 'comment-intro)) - (let ((c-comment-only-line-offset - (if (consp c-comment-only-line-offset) - c-comment-only-line-offset - (cons c-comment-only-line-offset - c-comment-only-line-offset)))) - (apply '+ (mapcar 'c-get-offset syntax))))) - ;; CASE 4: use comment-column if previous line is a - ;; comment-only line indented to the left of comment-column - ((save-excursion - (beginning-of-line) - (and (not (bobp)) - (forward-line -1)) - (skip-chars-forward " \t") - (prog1 - (looking-at c-comment-start-regexp) - (setq placeholder (point)))) - (goto-char placeholder) - (if (< (current-column) comment-column) - comment-column - (current-column))) - ;; CASE 5: If comment-column is 0, and nothing but space - ;; before the comment, align it at 0 rather than 1. - ((progn - (goto-char opoint) - (skip-chars-backward " \t") - (and (= comment-column 0) (bolp))) - 0) - ;; CASE 6: indent at comment column except leave at least one - ;; space. - (t (max (1+ (current-column)) - comment-column)) - ))))) - - -;; for proposed new variable comment-line-break-function -(defun c-comment-line-break-function (&optional soft) - ;; we currently don't do anything with soft line breaks - (let ((literal (c-in-literal)) - at-comment-col) - (cond - ((eq literal 'string)) - ((or (not c-comment-continuation-stars) - (not literal)) - (indent-new-comment-line soft)) - (t (let ((here (point)) - (leader c-comment-continuation-stars)) - (back-to-indentation) - ;; comment could be hanging - (if (not (c-in-literal)) - (progn - (forward-line 1) - (forward-comment -1) - (setq at-comment-col (= (current-column) comment-column)))) - ;; are we looking at a block or lines style comment? - (if (and (looking-at (concat "\\(" c-comment-start-regexp - "\\)[ \t]+")) - (string-equal (match-string 1) "//")) - ;; line style - (setq leader "// ")) - (goto-char here) - (delete-region (progn (skip-chars-backward " \t") (point)) - (progn (skip-chars-forward " \t") (point))) - (newline) - ;; to avoid having an anchored comment that c-indent-line will - ;; trip up on - (insert " " leader) - (if at-comment-col - (indent-for-comment)) - (c-indent-line)))))) - -;; advice for indent-new-comment-line for older Emacsen -(if (boundp 'comment-line-break-function) - nil - (require 'advice) - (defadvice indent-new-comment-line (around c-line-break-advice activate) - (if (or (not c-buffer-is-cc-mode) - (not (c-in-literal)) - (not c-comment-continuation-stars)) - ad-do-it - (c-comment-line-break-function (ad-get-arg 0))))) - -;; used by outline-minor-mode -(defun c-outline-level () - (save-excursion - (skip-chars-forward "\t ") - (current-column))) - - -(defun c-up-conditional (count) - "Move back to the containing preprocessor conditional, leaving mark behind. -A prefix argument acts as a repeat count. With a negative argument, -move forward to the end of the containing preprocessor conditional. -When going backwards, `#elif' is treated like `#else' followed by -`#if'. When going forwards, `#elif' is ignored." - (interactive "p") - (c-forward-conditional (- count) t) - (c-keep-region-active)) - -(defun c-backward-conditional (count &optional up-flag) - "Move back across a preprocessor conditional, leaving mark behind. -A prefix argument acts as a repeat count. With a negative argument, -move forward across a preprocessor conditional." - (interactive "p") - (c-forward-conditional (- count) up-flag) - (c-keep-region-active)) - -(defun c-forward-conditional (count &optional up-flag) - "Move forward across a preprocessor conditional, leaving mark behind. -A prefix argument acts as a repeat count. With a negative argument, -move backward across a preprocessor conditional." - (interactive "p") - (let* ((forward (> count 0)) - (increment (if forward -1 1)) - (search-function (if forward 're-search-forward 're-search-backward)) - (new)) - (save-excursion - (while (/= count 0) - (let ((depth (if up-flag 0 -1)) found) - (save-excursion - ;; Find the "next" significant line in the proper direction. - (while (and (not found) - ;; Rather than searching for a # sign that - ;; comes at the beginning of a line aside from - ;; whitespace, search first for a string - ;; starting with # sign. Then verify what - ;; precedes it. This is faster on account of - ;; the fastmap feature of the regexp matcher. - (funcall search-function - "#[ \t]*\\(if\\|elif\\|endif\\)" - nil t)) - (beginning-of-line) - ;; Now verify it is really a preproc line. - (if (looking-at "^[ \t]*#[ \t]*\\(if\\|elif\\|endif\\)") - (let ((prev depth)) - ;; Update depth according to what we found. - (beginning-of-line) - (cond ((looking-at "[ \t]*#[ \t]*endif") - (setq depth (+ depth increment))) - ((looking-at "[ \t]*#[ \t]*elif") - (if (and forward (= depth 0)) - (setq found (point)))) - (t (setq depth (- depth increment)))) - ;; If we are trying to move across, and we find an - ;; end before we find a beginning, get an error. - (if (and (< prev 0) (< depth prev)) - (error (if forward - "No following conditional at this level" - "No previous conditional at this level"))) - ;; When searching forward, start from next line so - ;; that we don't find the same line again. - (if forward (forward-line 1)) - ;; If this line exits a level of conditional, exit - ;; inner loop. - (if (< depth 0) - (setq found (point)))) - ;; else - (if forward (forward-line 1)) - ))) - (or found - (error "No containing preprocessor conditional")) - (goto-char (setq new found))) - (setq count (+ count increment)))) - (push-mark) - (goto-char new)) - (c-keep-region-active)) - - -;; commands to indent lines, regions, defuns, and expressions -(defun c-indent-command (&optional whole-exp) - "Indent current line as C code, and/or insert some whitespace. - -If `c-tab-always-indent' is t, always just indent the current line. -If nil, indent the current line only if point is at the left margin or -in the line's indentation; otherwise insert some whitespace[*]. If -other than nil or t, then some whitespace[*] is inserted only within -literals (comments and strings) and inside preprocessor directives, -but the line is always reindented. - -A numeric argument, regardless of its value, means indent rigidly all -the lines of the expression starting after point so that this line -becomes properly indented. The relative indentation among the lines -of the expression are preserved. - - [*] The amount and kind of whitespace inserted is controlled by the - variable `c-insert-tab-function', which is called to do the actual - insertion of whitespace. Normally the function in this variable - just inserts a tab character, or the equivalent number of spaces, - depending on the variable `indent-tabs-mode'." - - (interactive "P") - (let ((bod (c-point 'bod))) - (if whole-exp - ;; If arg, always indent this line as C - ;; and shift remaining lines of expression the same amount. - (let ((shift-amt (c-indent-line)) - beg end) - (save-excursion - (if (eq c-tab-always-indent t) - (beginning-of-line)) - (setq beg (point)) - (forward-sexp 1) - (setq end (point)) - (goto-char beg) - (forward-line 1) - (setq beg (point))) - (if (> end beg) - (indent-code-rigidly beg end (- shift-amt) "#"))) - ;; No arg supplied, use c-tab-always-indent to determine - ;; behavior - (cond - ;; CASE 1: indent when at column zero or in lines indentation, - ;; otherwise insert a tab - ((not c-tab-always-indent) - (if (save-excursion - (skip-chars-backward " \t") - (not (bolp))) - (funcall c-insert-tab-function) - (c-indent-line))) - ;; CASE 2: just indent the line - ((eq c-tab-always-indent t) - (c-indent-line)) - ;; CASE 3: if in a literal, insert a tab, but always indent the - ;; line - (t - (if (c-in-literal bod) - (funcall c-insert-tab-function)) - (c-indent-line) - ))))) - -(defun c-indent-exp (&optional shutup-p) - "Indent each line in balanced expression following point. -Optional SHUTUP-P if non-nil, inhibits message printing and error checking." - (interactive "P") - (let ((here (point)) - end progress-p) - (unwind-protect - (let ((c-echo-syntactic-information-p nil) ;keep quiet for speed - (start (progn - ;; try to be smarter about finding the range of - ;; lines to indent. skip all following - ;; whitespace. failing that, try to find any - ;; opening brace on the current line - (skip-chars-forward " \t\n") - (if (memq (char-after) '(?\( ?\[ ?\{)) - (point) - (let ((state (parse-partial-sexp (point) - (c-point 'eol)))) - (and (nth 1 state) - (goto-char (nth 1 state)) - (memq (char-after) '(?\( ?\[ ?\{)) - (point))))))) - ;; find balanced expression end - (setq end (and (c-safe (progn (forward-sexp 1) t)) - (point-marker))) - ;; sanity check - (and (not start) - (not shutup-p) - (error "Cannot find start of balanced expression to indent.")) - (and (not end) - (not shutup-p) - (error "Cannot find end of balanced expression to indent.")) - (c-progress-init start end 'c-indent-exp) - (setq progress-p t) - (goto-char start) - (beginning-of-line) - (while (< (point) end) - (if (not (looking-at "[ \t]*$")) - (c-indent-line)) - (c-progress-update) - (forward-line 1))) - ;; make sure marker is deleted - (and end - (set-marker end nil)) - (and progress-p - (c-progress-fini 'c-indent-exp)) - (goto-char here)))) - -(defun c-indent-defun () - "Re-indents the current top-level function def, struct or class declaration." - (interactive) - (let ((here (point-marker)) - (c-echo-syntactic-information-p nil) - (brace (c-least-enclosing-brace (c-parse-state)))) - (if brace - (goto-char brace) - (beginning-of-defun)) - ;; if we're sitting at b-o-b, it might be because there was no - ;; least enclosing brace and we were sitting on the defun's open - ;; brace. - (if (and (bobp) (not (eq (char-after) ?\{))) - (goto-char here)) - ;; if defun-prompt-regexp is non-nil, b-o-d might not leave us at - ;; the open brace. I consider this an Emacs bug. - (and (boundp 'defun-prompt-regexp) - defun-prompt-regexp - (looking-at defun-prompt-regexp) - (goto-char (match-end 0))) - ;; catch all errors in c-indent-exp so we can 1. give more - ;; meaningful error message, and 2. restore point - (unwind-protect - (c-indent-exp) - (goto-char here) - (set-marker here nil)))) - -(defun c-indent-region (start end) - ;; Indent every line whose first char is between START and END inclusive. - (save-excursion - (goto-char start) - ;; Advance to first nonblank line. - (skip-chars-forward " \t\n") - (beginning-of-line) - (let (endmark) - (unwind-protect - (let ((c-tab-always-indent t) - ;; shut up any echo msgs on indiv lines - (c-echo-syntactic-information-p nil) - fence) - (c-progress-init start end 'c-indent-region) - (setq endmark (copy-marker end)) - (while (and (bolp) - (not (eobp)) - (< (point) endmark)) - ;; update progress - (c-progress-update) - ;; Indent one line as with TAB. - (let (nextline sexpend sexpbeg) - ;; skip blank lines - (skip-chars-forward " \t\n") - (beginning-of-line) - ;; indent the current line - (c-indent-line) - (setq fence (point)) - (if (save-excursion - (beginning-of-line) - (looking-at "[ \t]*#")) - (forward-line 1) - (save-excursion - ;; Find beginning of following line. - (setq nextline (c-point 'bonl)) - ;; Find first beginning-of-sexp for sexp extending past - ;; this line. - (beginning-of-line) - (while (< (point) nextline) - (condition-case nil - (progn - (forward-sexp 1) - (setq sexpend (point))) - (error (setq sexpend nil) - (goto-char nextline))) - (c-forward-syntactic-ws)) - (if sexpend - (progn - ;; make sure the sexp we found really starts on the - ;; current line and extends past it - (goto-char sexpend) - (setq sexpend (point-marker)) - (c-safe (backward-sexp 1)) - (setq sexpbeg (point)))) - (if (and sexpbeg (< sexpbeg fence)) - (setq sexpbeg fence))) - ;; check to see if the next line starts a - ;; comment-only line - (save-excursion - (forward-line 1) - (skip-chars-forward " \t") - (if (looking-at c-comment-start-regexp) - (setq sexpbeg (c-point 'bol)))) - ;; If that sexp ends within the region, indent it all at - ;; once, fast. - (condition-case nil - (if (and sexpend - (> sexpend nextline) - (<= sexpend endmark)) - (progn - (goto-char sexpbeg) - (c-indent-exp 'shutup) - (c-progress-update) - (goto-char sexpend))) - (error - (goto-char sexpbeg) - (c-indent-line))) - ;; Move to following line and try again. - (and sexpend - (markerp sexpend) - (set-marker sexpend nil)) - (forward-line 1) - (setq fence (point)))))) - (set-marker endmark nil) - (c-progress-fini 'c-indent-region) - (c-echo-parsing-error) - )))) - -(defun c-mark-function () - "Put mark at end of a C, C++, or Objective-C defun, point at beginning." - (interactive) - (let ((here (point)) - ;; there should be a c-point position for 'eod - (eod (save-excursion (end-of-defun) (point))) - (state (c-parse-state)) - brace) - (while state - (setq brace (car state)) - (if (consp brace) - (goto-char (cdr brace)) - (goto-char brace)) - (setq state (cdr state))) - (if (eq (char-after) ?{) - (progn - (forward-line -1) - (while (not (or (bobp) - (looking-at "[ \t]*$"))) - (forward-line -1))) - (forward-line 1) - (skip-chars-forward " \t\n")) - (push-mark here) - (push-mark eod nil t))) - - -;; for progress reporting -(defvar c-progress-info nil) - -(defun c-progress-init (start end context) - (cond - ;; Be silent - ((not c-progress-interval)) - ;; Start the progress update messages. If this Emacs doesn't have - ;; a built-in timer, just be dumb about it. - ((not (fboundp 'current-time)) - (message "indenting region... (this may take a while)")) - ;; If progress has already been initialized, do nothing. otherwise - ;; initialize the counter with a vector of: - ;; [start end lastsec context] - (c-progress-info) - (t (setq c-progress-info (vector start - (save-excursion - (goto-char end) - (point-marker)) - (nth 1 (current-time)) - context)) - (message "indenting region...")) - )) - -(defun c-progress-update () - ;; update progress - (if (not (and c-progress-info c-progress-interval)) - nil - (let ((now (nth 1 (current-time))) - (start (aref c-progress-info 0)) - (end (aref c-progress-info 1)) - (lastsecs (aref c-progress-info 2))) - ;; should we update? currently, update happens every 2 seconds, - ;; what's the right value? - (if (< c-progress-interval (- now lastsecs)) - (progn - (message "indenting region... (%d%% complete)" - (/ (* 100 (- (point) start)) (- end start))) - (aset c-progress-info 2 now))) - ))) - -(defun c-progress-fini (context) - ;; finished - (if (not c-progress-interval) - nil - (if (or (eq context (aref c-progress-info 3)) - (eq context t)) - (progn - (set-marker (aref c-progress-info 1) nil) - (setq c-progress-info nil) - (message "indenting region...done"))))) - - - -;;; This page handles insertion and removal of backslashes for C macros. - -(defun c-backslash-region (from to delete-flag) - "Insert, align, or delete end-of-line backslashes on the lines in the region. -With no argument, inserts backslashes and aligns existing backslashes. -With an argument, deletes the backslashes. - -This function does not modify blank lines at the start of the region. -If the region ends at the start of a line, it always deletes the -backslash (if any) at the end of the previous line. - -You can put the region around an entire macro definition and use this -command to conveniently insert and align the necessary backslashes." - (interactive "r\nP") - (save-excursion - (goto-char from) - (let ((column c-backslash-column) - (endmark (make-marker))) - (move-marker endmark to) - ;; Compute the smallest column number past the ends of all the lines. - (if (not delete-flag) - (while (< (point) to) - (end-of-line) - (if (eq (char-before) ?\\) - (progn (forward-char -1) - (skip-chars-backward " \t"))) - (setq column (max column (1+ (current-column)))) - (forward-line 1))) - ;; Adjust upward to a tab column, if that doesn't push past the margin. - (if (> (% column tab-width) 0) - (let ((adjusted (* (/ (+ column tab-width -1) tab-width) tab-width))) - (if (< adjusted (window-width)) - (setq column adjusted)))) - ;; Don't modify blank lines at start of region. - (goto-char from) - (while (and (< (point) endmark) (eolp)) - (forward-line 1)) - ;; Add or remove backslashes on all the lines. - (while (< (point) endmark) - (if (and (not delete-flag) - ;; Un-backslashify the last line - ;; if the region ends right at the start of the next line. - (save-excursion - (forward-line 1) - (< (point) endmark))) - (c-append-backslash column) - (c-delete-backslash)) - (forward-line 1)) - (move-marker endmark nil))) - (c-keep-region-active)) - -(defun c-append-backslash (column) - (end-of-line) - (if (eq (char-before) ?\\) - (progn (forward-char -1) - (delete-horizontal-space) - (indent-to column)) - (indent-to column) - (insert "\\"))) - -(defun c-delete-backslash () - (end-of-line) - (or (bolp) - (progn - (forward-char -1) - (if (looking-at "\\\\") - (delete-region (1+ (point)) - (progn (skip-chars-backward " \t") (point))))))) - - -(defun c-fill-paragraph (&optional arg) - "Like \\[fill-paragraph] but handles C and C++ style comments. -If any of the current line is a comment or within a comment, -fill the comment or the paragraph of it that point is in, -preserving the comment indentation or line-starting decorations. - -Optional prefix ARG means justify paragraph as well." - (interactive "P") - (let* (comment-start-place - (first-line - ;; Check for obvious entry to comment. - (save-excursion - (beginning-of-line) - (skip-chars-forward " \t\n") - (and (looking-at comment-start-skip) - (setq comment-start-place (point))))) - (re1 "\\|[ \t]*/\\*[ \t]*$\\|[ \t]*\\*/[ \t]*$\\|[ \t/*]*$")) - (if (save-excursion - (beginning-of-line) - (looking-at ".*//")) - (let ((fill-prefix fill-prefix) - ;; Lines containing just a comment start or just an end - ;; should not be filled into paragraphs they are next - ;; to. - (paragraph-start (concat paragraph-start re1)) - (paragraph-separate (concat paragraph-separate re1))) - (save-excursion - (beginning-of-line) - ;; Move up to first line of this comment. - (while (and (not (bobp)) - (looking-at "[ \t]*//[ \t]*[^ \t\n]")) - (forward-line -1)) - (if (not (looking-at ".*//[ \t]*[^ \t\n]")) - (forward-line 1)) - ;; Find the comment start in this line. - (re-search-forward "[ \t]*//[ \t]*") - ;; Set the fill-prefix to be what all lines except the first - ;; should start with. But do not alter a user set fill-prefix. - (if (null fill-prefix) - (setq fill-prefix (buffer-substring (match-beginning 0) - (match-end 0)))) - (save-restriction - ;; Narrow down to just the lines of this comment. - (narrow-to-region (c-point 'bol) - (save-excursion - (forward-line 1) - (while (looking-at fill-prefix) - (forward-line 1)) - (point))) - (fill-paragraph arg) - t))) - ;; else C style comments - (if (or first-line - ;; t if we enter a comment between start of function and - ;; this line. - (eq (c-in-literal) 'c) - ;; t if this line contains a comment starter. - (setq first-line - (save-excursion - (beginning-of-line) - (prog1 - (re-search-forward comment-start-skip - (save-excursion (end-of-line) - (point)) - t) - (setq comment-start-place (point)))))) - ;; Inside a comment: fill one comment paragraph. - (let ((fill-prefix - ;; The prefix for each line of this paragraph - ;; is the appropriate part of the start of this line, - ;; up to the column at which text should be indented. - (save-excursion - (beginning-of-line) - (if (looking-at "[ \t]*/\\*.*\\*/") - (progn (re-search-forward comment-start-skip) - (make-string (current-column) ?\ )) - (if first-line (forward-line 1)) - - (let ((line-width (progn (end-of-line) (current-column)))) - (beginning-of-line) - (prog1 - (buffer-substring - (point) - - ;; How shall we decide where the end of the - ;; fill-prefix is? - (progn - (beginning-of-line) - (skip-chars-forward " \t*" (c-point 'eol)) - ;; kludge alert, watch out for */, in - ;; which case fill-prefix should *not* - ;; be "*"! - (if (and (eq (char-after) ?/) - (eq (char-before) ?*)) - (forward-char -1)) - (point))) - - ;; If the comment is only one line followed - ;; by a blank line, calling move-to-column - ;; above may have added some spaces and tabs - ;; to the end of the line; the fill-paragraph - ;; function will then delete it and the - ;; newline following it, so we'll lose a - ;; blank line when we shouldn't. So delete - ;; anything move-to-column added to the end - ;; of the line. We record the line width - ;; instead of the position of the old line - ;; end because move-to-column might break a - ;; tab into spaces, and the new characters - ;; introduced there shouldn't be deleted. - - ;; If you can see a better way to do this, - ;; please make the change. This seems very - ;; messy to me. - (delete-region (progn (move-to-column line-width) - (point)) - (progn (end-of-line) (point)))))))) - - ;; Lines containing just a comment start or just an end - ;; should not be filled into paragraphs they are next - ;; to. - (paragraph-start (concat paragraph-start re1)) - (paragraph-separate (concat paragraph-separate re1)) - (chars-to-delete 0) - ) - (save-restriction - ;; Don't fill the comment together with the code - ;; following it. So temporarily exclude everything - ;; before the comment start, and everything after the - ;; line where the comment ends. If comment-start-place - ;; is non-nil, the comment starter is there. Otherwise, - ;; point is inside the comment. - (narrow-to-region (save-excursion - (if comment-start-place - (goto-char comment-start-place) - (search-backward "/*")) - (if (and (not c-hanging-comment-starter-p) - (looking-at - (concat c-comment-start-regexp - "[ \t]*$"))) - (forward-line 1)) - ;; Protect text before the comment - ;; start by excluding it. Add - ;; spaces to bring back proper - ;; indentation of that point. - (let ((column (current-column))) - (prog1 (point) - (setq chars-to-delete column) - (insert-char ?\ column)))) - (save-excursion - (if comment-start-place - (goto-char (+ comment-start-place 2))) - (search-forward "*/" nil 'move) - (forward-line 1) - (point))) - (fill-paragraph arg) - (save-excursion - ;; Delete the chars we inserted to avoid clobbering - ;; the stuff before the comment start. - (goto-char (point-min)) - (if (> chars-to-delete 0) - (delete-region (point) (+ (point) chars-to-delete))) - ;; Find the comment ender (should be on last line of - ;; buffer, given the narrowing) and don't leave it on - ;; its own line, unless that's the style that's desired. - (goto-char (point-max)) - (forward-line -1) - (search-forward "*/" nil 'move) - (beginning-of-line) - (if (and c-hanging-comment-ender-p - (looking-at "[ \t]*\\*/")) - ;(delete-indentation))))) - (let ((fill-column (+ fill-column 9999))) - (forward-line -1) - (fill-region-as-paragraph (point) (point-max)))))) - t))))) - - -(provide 'cc-cmds) -;;; cc-cmds.el ends here
--- a/lisp/cc-mode/cc-compat.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,149 +0,0 @@ -;;; cc-compat.el --- cc-mode compatibility with c-mode.el confusion - -;; Copyright (C) 1985,87,92,93,94,95,96,97 Free Software Foundation, Inc. - -;; Author: 1994-1997 Barry A. Warsaw -;; Maintainer: cc-mode-help@python.org -;; Created: August 1994, split from cc-mode.el -;; Version: See cc-mode.el -;; Keywords: c languages oop - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: -;; -;; Boring old c-mode.el (BOCM) is confusion and brain melt. cc-mode.el -;; is clarity of thought and purity of chi. If you are still unwilling -;; to accept enlightenment, this might help, or it may prolong your -;; agony. -;; -;; To use, add the following to your c-mode-hook: -;; -;; (require 'cc-compat) -;; (c-set-style "BOCM") - -;;; Code: - -(eval-when-compile - (require 'cc-styles) - (require 'cc-engine)) - - -;; In case c-mode.el isn't loaded -(defvar c-indent-level 2 - "*Indentation of C statements with respect to containing block.") -(defvar c-brace-imaginary-offset 0 - "*Imagined indentation of a C open brace that actually follows a statement.") -(defvar c-brace-offset 0 - "*Extra indentation for braces, compared with other text in same context.") -(defvar c-argdecl-indent 5 - "*Indentation level of declarations of C function arguments.") -(defvar c-label-offset -2 - "*Offset of C label lines and case statements relative to usual indentation.") -(defvar c-continued-statement-offset 2 - "*Extra indent for lines not starting new statements.") -(defvar c-continued-brace-offset 0 - "*Extra indent for substatements that start with open-braces. -This is in addition to c-continued-statement-offset.") - - - -;; these offsets are taken by brute force testing c-mode.el, since -;; there's no logic to what it does. -(let* ((offsets '(c-offsets-alist . - ((defun-block-intro . cc-block-intro-offset) - (statement-block-intro . cc-block-intro-offset) - (defun-open . 0) - (class-open . 0) - (inline-open . c-brace-offset) - (block-open . c-brace-offset) - (block-close . cc-block-close-offset) - (brace-list-open . c-brace-offset) - (substatement-open . cc-substatement-open-offset) - (substatement . c-continued-statement-offset) - (knr-argdecl-intro . c-argdecl-indent) - (case-label . c-label-offset) - (access-label . c-label-offset) - (label . c-label-offset) - )))) - (c-add-style "BOCM" offsets)) - - -(defun cc-block-intro-offset (langelem) - ;; taken directly from calculate-c-indent confusion - (save-excursion - (c-backward-syntactic-ws) - (if (eq (char-before) ?{) - (forward-char -1) - (goto-char (cdr langelem))) - (let* ((curcol (save-excursion - (goto-char (cdr langelem)) - (current-column))) - (bocm-lossage - ;; If no previous statement, indent it relative to line - ;; brace is on. For open brace in column zero, don't let - ;; statement start there too. If c-indent-level is zero, - ;; use c-brace-offset + c-continued-statement-offset - ;; instead. For open-braces not the first thing in a line, - ;; add in c-brace-imaginary-offset. - (+ (if (and (bolp) (zerop c-indent-level)) - (+ c-brace-offset c-continued-statement-offset) - c-indent-level) - ;; Move back over whitespace before the openbrace. If - ;; openbrace is not first nonwhite thing on the line, - ;; add the c-brace-imaginary-offset. - (progn (skip-chars-backward " \t") - (if (bolp) 0 c-brace-imaginary-offset)) - ;; If the openbrace is preceded by a parenthesized exp, - ;; move to the beginning of that; possibly a different - ;; line - (progn - (if (eq (char-before) ?\)) - (forward-sexp -1)) - ;; Get initial indentation of the line we are on. - (current-indentation))))) - (- bocm-lossage curcol)))) - - -(defun cc-block-close-offset (langelem) - (save-excursion - (let* ((here (point)) - bracep - (curcol (progn - (goto-char (cdr langelem)) - (current-column))) - (bocm-lossage (progn - (goto-char (cdr langelem)) - (if (eq (char-after) ?{) - (setq bracep t) - (goto-char here) - (beginning-of-line) - (backward-up-list 1) - (forward-char 1) - (c-forward-syntactic-ws)) - (current-column)))) - (- bocm-lossage curcol - (if bracep 0 c-indent-level))))) - - -(defun cc-substatement-open-offset (langelem) - (+ c-continued-statement-offset c-continued-brace-offset)) - - -(provide 'cc-compat) -;;; cc-compat.el ends here
--- a/lisp/cc-mode/cc-defs.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,175 +0,0 @@ -;;; cc-defs.el --- definitions for CC Mode - -;; Copyright (C) 1985,87,92,93,94,95,96,97 Free Software Foundation, Inc. - -;; Authors: 1992-1997 Barry A. Warsaw -;; 1987 Dave Detlefs and Stewart Clamen -;; 1985 Richard M. Stallman -;; Maintainer: cc-mode-help@python.org -;; Created: 22-Apr-1997 (split from cc-mode.el) -;; Version: See cc-mode.el -;; Keywords: c languages oop - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - - -;; Figure out what features this Emacs has -(defconst c-emacs-features - (let ((infodock-p (boundp 'infodock-version)) - (comments - ;; XEmacs 19 and beyond use 8-bit modify-syntax-entry flags. - ;; Emacs 19 uses a 1-bit flag. We will have to set up our - ;; syntax tables differently to handle this. - (let ((table (copy-syntax-table)) - entry) - (modify-syntax-entry ?a ". 12345678" table) - (cond - ;; XEmacs 19, and beyond Emacs 19.34 - ((arrayp table) - (setq entry (aref table ?a)) - ;; In Emacs, table entries are cons cells - (if (consp entry) (setq entry (car entry)))) - ;; XEmacs 20 - ((fboundp 'get-char-table) (setq entry (get-char-table ?a table))) - ;; before and including Emacs 19.34 - ((and (fboundp 'char-table-p) - (char-table-p table)) - (setq entry (car (char-table-range table [?a])))) - ;; incompatible - (t (error "CC Mode is incompatible with this version of Emacs"))) - (if (= (logand (lsh entry -16) 255) 255) - '8-bit - '1-bit)))) - (if infodock-p - (list comments 'infodock) - (list comments))) - "A list of features extant in the Emacs you are using. -There are many flavors of Emacs out there, each with different -features supporting those needed by CC Mode. Here's the current -supported list, along with the values for this variable: - - XEmacs 19: (8-bit) - XEmacs 20: (8-bit) - Emacs 19: (1-bit) - -Infodock (based on XEmacs) has an additional symbol on this list: -'infodock.") - - - -(defsubst c-point (position) - ;; Returns the value of point at certain commonly referenced POSITIONs. - ;; POSITION can be one of the following symbols: - ;; - ;; bol -- beginning of line - ;; eol -- end of line - ;; bod -- beginning of defun - ;; boi -- back to indentation - ;; ionl -- indentation of next line - ;; iopl -- indentation of previous line - ;; bonl -- beginning of next line - ;; bopl -- beginning of previous line - ;; - ;; This function does not modify point or mark. - (let ((here (point))) - (cond - ((eq position 'bol) (beginning-of-line)) - ((eq position 'eol) (end-of-line)) - ((eq position 'bod) - (beginning-of-defun) - ;; if defun-prompt-regexp is non-nil, b-o-d won't leave us at - ;; the open brace. - (and defun-prompt-regexp - (looking-at defun-prompt-regexp) - (goto-char (match-end 0))) - ) - ((eq position 'boi) (back-to-indentation)) - ((eq position 'bonl) (forward-line 1)) - ((eq position 'bopl) (forward-line -1)) - ((eq position 'iopl) - (forward-line -1) - (back-to-indentation)) - ((eq position 'ionl) - (forward-line 1) - (back-to-indentation)) - (t (error "unknown buffer position requested: %s" position)) - ) - (prog1 - (point) - (goto-char here)))) - -(defmacro c-safe (&rest body) - ;; safely execute BODY, return nil if an error occurred - (` (condition-case nil - (progn (,@ body)) - (error nil)))) - -(defmacro c-add-syntax (symbol &optional relpos) - ;; a simple macro to append the syntax in symbol to the syntax list. - ;; try to increase performance by using this macro - (` (setq syntax (cons (cons (, symbol) (, relpos)) syntax)))) - -(defsubst c-auto-newline () - ;; if auto-newline feature is turned on, insert a newline character - ;; and return t, otherwise return nil. - (and c-auto-newline - (not (c-in-literal)) - (not (newline)))) - -(defsubst c-intersect-lists (list alist) - ;; return the element of ALIST that matches the first element found - ;; in LIST. Uses assq. - (let (match) - (while (and list - (not (setq match (assq (car list) alist)))) - (setq list (cdr list))) - match)) - -(defsubst c-lookup-lists (list alist1 alist2) - ;; first, find the first entry from LIST that is present in ALIST1, - ;; then find the entry in ALIST2 for that entry. - (assq (car (c-intersect-lists list alist1)) alist2)) - -(defsubst c-langelem-col (langelem &optional preserve-point) - ;; convenience routine to return the column of langelem's relpos. - ;; Leaves point at the relpos unless preserve-point is non-nil. - (let ((here (point))) - (goto-char (cdr langelem)) - (prog1 (current-column) - (if preserve-point - (goto-char here)) - ))) - -(defsubst c-update-modeline () - ;; set the c-auto-hungry-string for the correct designation on the modeline - (setq c-auto-hungry-string - (if c-auto-newline - (if c-hungry-delete-key "/ah" "/a") - (if c-hungry-delete-key "/h" nil))) - (force-mode-line-update)) - -(defsubst c-keep-region-active () - ;; Do whatever is necessary to keep the region active in XEmacs. - ;; Ignore byte-compiler warnings you might see. This is not needed - ;; for Emacs. - (and (boundp 'zmacs-region-stays) - (setq zmacs-region-stays t))) - - -(provide 'cc-defs) -;;; cc-defs.el ends here
--- a/lisp/cc-mode/cc-engine.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1722 +0,0 @@ -;;; cc-engine.el --- core syntax guessing engine for CC mode - -;; Copyright (C) 1985,87,92,93,94,95,96,97 Free Software Foundation, Inc. - -;; Authors: 1992-1997 Barry A. Warsaw -;; 1987 Dave Detlefs and Stewart Clamen -;; 1985 Richard M. Stallman -;; Maintainer: cc-mode-help@python.org -;; Created: 22-Apr-1997 (split from cc-mode.el) -;; Version: See cc-mode.el -;; Keywords: c languages oop - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - - -;; KLUDGE ALERT: c-maybe-labelp is used to pass information between -;; c-crosses-statement-barrier-p and c-beginning-of-statement-1. A -;; better way should be implemented, but this will at least shut up -;; the byte compiler. -(defvar c-maybe-labelp nil) - -;; WARNING WARNING WARNING -;; -;; Be *exceptionally* careful about modifications to this function! -;; Much of CC Mode depends on this Doing The Right Thing. If you -;; break it you will be sorry. If you think you know how this works, -;; you probably don't. No human on Earth does! :-) -;; -;; WARNING WARNING WARNING - -(defun c-beginning-of-statement-1 (&optional lim) - ;; move to the start of the current statement, or the previous - ;; statement if already at the beginning of one. - (let ((firstp t) - (substmt-p t) - donep c-in-literal-cache saved - (last-begin (point))) - ;; first check for bare semicolon - (if (and (progn (c-backward-syntactic-ws lim) - (eq (char-before) ?\;)) - (c-safe (progn (forward-char -1) - (setq saved (point)) - t)) - (progn (c-backward-syntactic-ws lim) - (memq (char-before) '(?\; ?{ ?:))) - ) - (setq last-begin saved) - (goto-char last-begin) - (while (not donep) - ;; stop at beginning of buffer - (if (bobp) (setq donep t) - ;; go backwards one balanced expression, but be careful of - ;; unbalanced paren being reached - (if (not (c-safe (progn (backward-sexp 1) t))) - (progn - (if firstp - (backward-up-list 1) - (goto-char last-begin)) - ;; skip over any unary operators, or other special - ;; characters appearing at front of identifier - (save-excursion - (c-backward-syntactic-ws lim) - (skip-chars-backward "-+!*&:.~ \t\n") - (if (eq (char-before) ?\() - (setq last-begin (point)))) - (goto-char last-begin) - (setq last-begin (point) - donep t))) - - (setq c-maybe-labelp nil) - ;; see if we're in a literal. if not, then this bufpos may be - ;; a candidate for stopping - (cond - ;; CASE 0: did we hit the error condition above? - (donep) - ;; CASE 1: are we in a literal? - ((eq (c-in-literal lim) 'pound) - (beginning-of-line)) - ;; CASE 2: some other kind of literal? - ((c-in-literal lim)) - ;; CASE 3: are we looking at a conditional keyword? - ((or (looking-at c-conditional-key) - (and (eq (char-after) ?\() - (save-excursion - (forward-sexp 1) - (c-forward-syntactic-ws) - (not (eq (char-after) ?\;))) - (let ((here (point)) - (foundp (progn - (c-backward-syntactic-ws lim) - (forward-word -1) - (and lim - (<= lim (point)) - (not (c-in-literal lim)) - (not (eq (char-before) ?_)) - (looking-at c-conditional-key) - )))) - ;; did we find a conditional? - (if (not foundp) - (goto-char here)) - foundp))) - ;; are we in the middle of an else-if clause? - (if (save-excursion - (and (not substmt-p) - (c-safe (progn (forward-sexp -1) t)) - (looking-at "\\<else\\>[ \t\n]+\\<if\\>") - (not (c-in-literal lim)))) - (progn - (forward-sexp -1) - (c-backward-to-start-of-if lim))) - ;; are we sitting at an else clause, that we are not a - ;; substatement of? - (if (and (not substmt-p) - (looking-at "\\<else\\>[^_]")) - (c-backward-to-start-of-if lim)) - ;; are we sitting at the while of a do-while? - (if (and (looking-at "\\<while\\>[^_]") - (c-backward-to-start-of-do lim)) - (setq substmt-p nil)) - (setq last-begin (point) - donep substmt-p)) - ;; CASE 4: are we looking at a label? - ((looking-at c-label-key)) - ;; CASE 5: is this the first time we're checking? - (firstp (setq firstp nil - substmt-p (not (c-crosses-statement-barrier-p - (point) last-begin)) - last-begin (point))) - ;; CASE 6: have we crossed a statement barrier? - ((c-crosses-statement-barrier-p (point) last-begin) - (setq donep t)) - ;; CASE 7: ignore labels - ((and c-maybe-labelp - (or (and c-access-key (looking-at c-access-key)) - ;; with switch labels, we have to go back further - ;; to try to pick up the case or default - ;; keyword. Potential bogosity alert: we assume - ;; `case' or `default' is first thing on line - (let ((here (point))) - (beginning-of-line) - (c-forward-syntactic-ws) - (if (looking-at c-switch-label-key) - t - (goto-char here) - nil)) - (looking-at c-label-key)))) - ;; CASE 8: ObjC or Java method def - ((and c-method-key - (setq last-begin (c-in-method-def-p))) - (setq donep t)) - ;; CASE 9: nothing special - (t (setq last-begin (point))) - )))) - (goto-char last-begin) - ;; we always do want to skip over non-whitespace modifier - ;; characters that didn't get skipped above - (skip-chars-backward "-+!*&:.~" (c-point 'boi)))) - -(defun c-end-of-statement-1 () - (condition-case nil - (let (beg end found) - (while (and (not (eobp)) - (progn - (setq beg (point)) - (forward-sexp 1) - (setq end (point)) - (goto-char beg) - (setq found nil) - (while (and (not found) - (re-search-forward "[;{}]" end t)) - (if (not (c-in-literal beg)) - (setq found t))) - (not found))) - (goto-char end)) - (re-search-backward "[;{}]") - (forward-char 1)) - (error - (let ((beg (point))) - (c-safe (backward-up-list -1)) - (let ((end (point))) - (goto-char beg) - (search-forward ";" end 'move))) - ))) - - -(defun c-crosses-statement-barrier-p (from to) - ;; Does buffer positions FROM to TO cross a C statement boundary? - (let ((here (point)) - (lim from) - crossedp) - (condition-case () - (progn - (goto-char from) - (while (and (not crossedp) - (< (point) to)) - (skip-chars-forward "^;{}:" to) - (if (not (c-in-literal lim)) - (progn - (if (memq (char-after) '(?\; ?{ ?})) - (setq crossedp t) - (if (eq (char-after) ?:) - (setq c-maybe-labelp t)) - (forward-char 1)) - (setq lim (point))) - (forward-char 1)))) - (error (setq crossedp nil))) - (goto-char here) - crossedp)) - - -;; Skipping of "syntactic whitespace", defined as lexical whitespace, -;; C and C++ style comments, and preprocessor directives. Search no -;; farther back or forward than optional LIM. If LIM is omitted, -;; `beginning-of-defun' is used for backward skipping, point-max is -;; used for forward skipping. - -(defun c-forward-syntactic-ws (&optional lim) - ;; Forward skip of syntactic whitespace for Emacs 19. - (save-restriction - (let* ((lim (or lim (point-max))) - (here lim) - (hugenum (point-max))) - (narrow-to-region lim (point)) - (while (/= here (point)) - (setq here (point)) - (forward-comment hugenum) - ;; skip preprocessor directives - (if (and (eq (char-after) ?#) - (= (c-point 'boi) (point))) - (end-of-line) - ))))) - -(defun c-backward-syntactic-ws (&optional lim) - ;; Backward skip over syntactic whitespace for Emacs 19. - (save-restriction - (let* ((lim (or lim (c-point 'bod))) - (here lim) - (hugenum (- (point-max)))) - (if (< lim (point)) - (progn - (narrow-to-region lim (point)) - (while (/= here (point)) - (setq here (point)) - (forward-comment hugenum) - (if (eq (c-in-literal lim) 'pound) - (beginning-of-line)) - ))) - ))) - - -;; Return `c' if in a C-style comment, `c++' if in a C++ style -;; comment, `string' if in a string literal, `pound' if on a -;; preprocessor line, or nil if not in a comment at all. Optional LIM -;; is used as the backward limit of the search. If omitted, or nil, -;; `beginning-of-defun' is used." - -(defun c-in-literal (&optional lim) - ;; Determine if point is in a C++ literal. we cache the last point - ;; calculated if the cache is enabled - (if (and (boundp 'c-in-literal-cache) - c-in-literal-cache - (= (point) (aref c-in-literal-cache 0))) - (aref c-in-literal-cache 1) - (let ((rtn (save-excursion - (let* ((lim (or lim (c-point 'bod))) - (here (point)) - (state (parse-partial-sexp lim (point)))) - (cond - ((nth 3 state) 'string) - ((nth 4 state) (if (nth 7 state) 'c++ 'c)) - ((progn - (goto-char here) - (beginning-of-line) - (looking-at "[ \t]*#")) - 'pound) - (t nil)))))) - ;; cache this result if the cache is enabled - (and (boundp 'c-in-literal-cache) - (setq c-in-literal-cache (vector (point) rtn))) - rtn))) - - -;; utilities for moving and querying around syntactic elements -(defvar c-parsing-error nil) - -(defun c-parse-state () - ;; Finds and records all open parens between some important point - ;; earlier in the file and point. - ;; - ;; if there's a state cache, return it - (setq c-parsing-error nil) - (if (boundp 'c-state-cache) c-state-cache - (let* (at-bob - (pos (save-excursion - ;; go back 2 bods, but ignore any bogus positions - ;; returned by beginning-of-defun (i.e. open paren - ;; in column zero) - (let ((cnt 2)) - (while (not (or at-bob (zerop cnt))) - (beginning-of-defun) - (if (eq (char-after) ?\{) - (setq cnt (1- cnt))) - (if (bobp) - (setq at-bob t)))) - (point))) - (here (save-excursion - ;;(skip-chars-forward " \t}") - (point))) - (last-bod pos) (last-pos pos) - placeholder state sexp-end) - ;; cache last bod position - (while (catch 'backup-bod - (setq state nil) - (while (and pos (< pos here)) - (setq last-pos pos) - (if (and (setq pos (c-safe (scan-lists pos 1 -1))) - (<= pos here)) - (progn - (setq sexp-end (c-safe (scan-sexps (1- pos) 1))) - (if (and sexp-end - (<= sexp-end here)) - ;; we want to record both the start and end - ;; of this sexp, but we only want to record - ;; the last-most of any of them before here - (progn - (if (eq (char-after (1- pos)) ?\{) - (setq state (cons (cons (1- pos) sexp-end) - (if (consp (car state)) - (cdr state) - state)))) - (setq pos sexp-end)) - ;; we're contained in this sexp so put pos on - ;; front of list - (setq state (cons (1- pos) state)))) - ;; something bad happened. check to see if we - ;; crossed an unbalanced close brace. if so, we - ;; didn't really find the right `important bufpos' - ;; so lets back up and try again - (if (and (not pos) (not at-bob) - (setq placeholder - (c-safe (scan-lists last-pos 1 1))) - ;;(char-after (1- placeholder)) - (<= placeholder here) - (eq (char-after (1- placeholder)) ?\})) - (while t - (setq last-bod (c-safe (scan-lists last-bod -1 1))) - (if (not last-bod) - (progn - ;; bogus, but what can we do here? - (setq c-parsing-error (1- placeholder)) - (throw 'backup-bod nil)) - (setq at-bob (= last-bod (point-min)) - pos last-bod) - (if (= (char-after last-bod) ?\{) - (throw 'backup-bod t))) - )) ;end-if - )) ;end-while - nil)) - state))) - -(defun c-whack-state (bufpos state) - ;; whack off any state information that appears on STATE which lies - ;; after the bounds of BUFPOS. - (let (newstate car) - (while state - (setq car (car state) - state (cdr state)) - (if (consp car) - ;; just check the car, because in a balanced brace - ;; expression, it must be impossible for the corresponding - ;; close brace to be before point, but the open brace to be - ;; after. - (if (<= bufpos (car car)) - nil ; whack it off - ;; its possible that the open brace is before bufpos, but - ;; the close brace is after. In that case, convert this - ;; to a non-cons element. - (if (<= bufpos (cdr car)) - (setq newstate (append newstate (list (car car)))) - ;; we know that both the open and close braces are - ;; before bufpos, so we also know that everything else - ;; on state is before bufpos, so we can glom up the - ;; whole thing and exit. - (setq newstate (append newstate (list car) state) - state nil))) - (if (<= bufpos car) - nil ; whack it off - ;; it's before bufpos, so everything else should too - (setq newstate (append newstate (list car) state) - state nil)))) - newstate)) - -(defun c-hack-state (bufpos which state) - ;; Using BUFPOS buffer position, and WHICH (must be 'open or - ;; 'close), hack the c-parse-state STATE and return the results. - (if (eq which 'open) - (let ((car (car state))) - (if (or (null car) - (consp car) - (/= bufpos car)) - (cons bufpos state) - state)) - (if (not (eq which 'close)) - (error "c-hack-state, bad argument: %s" which)) - ;; 'close brace - (let ((car (car state)) - (cdr (cdr state))) - (if (consp car) - (setq car (car cdr) - cdr (cdr cdr))) - ;; TBD: is this test relevant??? - (if (consp car) - state ;on error, don't change - ;; watch out for balanced expr already on cdr of list - (cons (cons car bufpos) - (if (consp (car cdr)) - (cdr cdr) cdr)) - )))) - -(defun c-adjust-state (from to shift state) - ;; Adjust all points in state that lie in the region FROM..TO by - ;; SHIFT amount (as would be returned by c-indent-line). - (mapcar - (function - (lambda (e) - (if (consp e) - (let ((car (car e)) - (cdr (cdr e))) - (if (and (<= from car) (< car to)) - (setcar e (+ shift car))) - (if (and (<= from cdr) (< cdr to)) - (setcdr e (+ shift cdr)))) - (if (and (<= from e) (< e to)) - (setq e (+ shift e)))) - e)) - state)) - - -(defun c-beginning-of-inheritance-list (&optional lim) - ;; Go to the first non-whitespace after the colon that starts a - ;; multiple inheritance introduction. Optional LIM is the farthest - ;; back we should search. - (let ((lim (or lim (c-point 'bod))) - (placeholder (progn - (back-to-indentation) - (point)))) - (c-backward-syntactic-ws lim) - (while (and (> (point) lim) - (memq (char-before) '(?, ?:)) - (progn - (beginning-of-line) - (setq placeholder (point)) - (skip-chars-forward " \t") - (not (looking-at c-class-key)) - )) - (c-backward-syntactic-ws lim)) - (goto-char placeholder) - (skip-chars-forward "^:" (c-point 'eol)))) - -(defun c-beginning-of-macro (&optional lim) - ;; Go to the beginning of the macro. Right now we don't support - ;; multi-line macros too well - (back-to-indentation)) - -(defun c-in-method-def-p () - ;; Return nil if we aren't in a method definition, otherwise the - ;; position of the initial [+-]. - (save-excursion - (beginning-of-line) - (and c-method-key - (looking-at c-method-key) - (point)) - )) - -(defun c-just-after-func-arglist-p (&optional containing) - ;; Return t if we are between a function's argument list closing - ;; paren and its opening brace. Note that the list close brace - ;; could be followed by a "const" specifier or a member init hanging - ;; colon. Optional CONTAINING is position of containing s-exp open - ;; brace. If not supplied, point is used as search start. - (save-excursion - (c-backward-syntactic-ws) - (let ((checkpoint (or containing (point)))) - (goto-char checkpoint) - ;; could be looking at const specifier - (if (and (eq (char-before) ?t) - (forward-word -1) - (looking-at "\\<const\\>")) - (c-backward-syntactic-ws) - ;; otherwise, we could be looking at a hanging member init - ;; colon - (goto-char checkpoint) - (if (and (eq (char-before) ?:) - (progn - (forward-char -1) - (c-backward-syntactic-ws) - (looking-at "[ \t\n]*:\\([^:]+\\|$\\)"))) - nil - (goto-char checkpoint)) - ) - (and (eq (char-before) ?\)) - ;; check if we are looking at a method def - (or (not c-method-key) - (progn - (forward-sexp -1) - (forward-char -1) - (c-backward-syntactic-ws) - (not (or (memq (char-before) '(?- ?+)) - ;; or a class category - (progn - (forward-sexp -2) - (looking-at c-class-key)) - ))))) - ))) - -;; defuns to look backwards for things -(defun c-backward-to-start-of-do (&optional lim) - ;; Move to the start of the last "unbalanced" do expression. - ;; Optional LIM is the farthest back to search. If none is found, - ;; nil is returned and point is left unchanged, otherwise t is returned. - (let ((do-level 1) - (case-fold-search nil) - (lim (or lim (c-point 'bod))) - (here (point)) - foundp) - (while (not (zerop do-level)) - ;; we protect this call because trying to execute this when the - ;; while is not associated with a do will throw an error - (condition-case nil - (progn - (backward-sexp 1) - (cond - ((memq (c-in-literal lim) '(c c++))) - ((looking-at "while\\b[^_]") - (setq do-level (1+ do-level))) - ((looking-at "do\\b[^_]") - (if (zerop (setq do-level (1- do-level))) - (setq foundp t))) - ((<= (point) lim) - (setq do-level 0) - (goto-char lim)))) - (error - (goto-char lim) - (setq do-level 0)))) - (if (not foundp) - (goto-char here)) - foundp)) - -(defun c-backward-to-start-of-if (&optional lim) - ;; Move to the start of the last "unbalanced" if and return t. If - ;; none is found, and we are looking at an if clause, nil is - ;; returned. If none is found and we are looking at an else clause, - ;; an error is thrown. - (let ((if-level 1) - (here (c-point 'bol)) - (case-fold-search nil) - (lim (or lim (c-point 'bod))) - (at-if (looking-at "if\\b[^_]"))) - (catch 'orphan-if - (while (and (not (bobp)) - (not (zerop if-level))) - (c-backward-syntactic-ws) - (condition-case nil - (backward-sexp 1) - (error - (if at-if - (throw 'orphan-if nil) - (error "No matching `if' found for `else' on line %d." - (1+ (count-lines 1 here)))))) - (cond - ((looking-at "else\\b[^_]") - (setq if-level (1+ if-level))) - ((looking-at "if\\b[^_]") - ;; check for else if... skip over - (let ((here (point))) - (c-safe (forward-sexp -1)) - (if (looking-at "\\<else\\>[ \t]+\\<if\\>") - nil - (setq if-level (1- if-level)) - (goto-char here)))) - ((< (point) lim) - (setq if-level 0) - (goto-char lim)) - )) - t))) - -(defun c-skip-conditional () - ;; skip forward over conditional at point, including any predicate - ;; statements in parentheses. No error checking is performed. - (forward-sexp (cond - ;; else if() - ((looking-at "\\<else\\>[ \t]+\\<if\\>") 3) - ;; do, else, try, finally - ((looking-at "\\<\\(do\\|else\\|try\\|finally\\)\\>") 1) - ;; for, if, while, switch, catch, synchronized - (t 2)))) - -(defun c-skip-case-statement-forward (state &optional lim) - ;; skip forward over case/default bodies, with optional maximal - ;; limit. if no next case body is found, nil is returned and point - ;; is not moved - (let ((lim (or lim (point-max))) - (here (point)) - donep foundp bufpos - (safepos (point)) - (balanced (car state))) - ;; search until we've passed the limit, or we've found our match - (while (and (< (point) lim) - (not donep)) - (setq safepos (point)) - ;; see if we can find a case statement, not in a literal - (if (and (re-search-forward c-switch-label-key lim 'move) - (setq bufpos (match-beginning 0)) - (not (c-in-literal safepos)) - (/= bufpos here)) - ;; if we crossed into a balanced sexp, we know the case is - ;; not part of our switch statement, so just bound over the - ;; sexp and keep looking. - (if (and (consp balanced) - (> bufpos (car balanced)) - (< bufpos (cdr balanced))) - (goto-char (cdr balanced)) - (goto-char bufpos) - (setq donep t - foundp t)))) - (if (not foundp) - (goto-char here)) - foundp)) - -(defun c-search-uplist-for-classkey (brace-state) - ;; search for the containing class, returning a 2 element vector if - ;; found. aref 0 contains the bufpos of the class key, and aref 1 - ;; contains the bufpos of the open brace. - (if (null brace-state) - ;; no brace-state means we cannot be inside a class - nil - (let ((carcache (car brace-state)) - search-start search-end) - (if (consp carcache) - ;; a cons cell in the first element means that there is some - ;; balanced sexp before the current bufpos. this we can - ;; ignore. the nth 1 and nth 2 elements define for us the - ;; search boundaries - (setq search-start (nth 2 brace-state) - search-end (nth 1 brace-state)) - ;; if the car was not a cons cell then nth 0 and nth 1 define - ;; for us the search boundaries - (setq search-start (nth 1 brace-state) - search-end (nth 0 brace-state))) - ;; search-end cannot be a cons cell - (and (consp search-end) - (error "consp search-end: %s" search-end)) - ;; if search-end is nil, or if the search-end character isn't an - ;; open brace, we are definitely not in a class - (if (or (not search-end) - (< search-end (point-min)) - (not (eq (char-after search-end) ?{))) - nil - ;; now, we need to look more closely at search-start. if - ;; search-start is nil, then our start boundary is really - ;; point-min. - (if (not search-start) - (setq search-start (point-min)) - ;; if search-start is a cons cell, then we can start - ;; searching from the end of the balanced sexp just ahead of - ;; us - (if (consp search-start) - (setq search-start (cdr search-start)))) - ;; now we can do a quick regexp search from search-start to - ;; search-end and see if we can find a class key. watch for - ;; class like strings in literals - (save-excursion - (save-restriction - (goto-char search-start) - (let ((search-key (concat c-class-key "\\|extern[^_]")) - foundp class match-end) - (while (and (not foundp) - (progn - (c-forward-syntactic-ws) - (> search-end (point))) - (re-search-forward search-key search-end t)) - (setq class (match-beginning 0) - match-end (match-end 0)) - (if (c-in-literal search-start) - nil ; its in a comment or string, ignore - (goto-char class) - (skip-chars-forward " \t\n") - (setq foundp (vector (c-point 'boi) search-end)) - (cond - ;; check for embedded keywords - ((let ((char (char-after (1- class)))) - (and char - (memq (char-syntax char) '(?w ?_)))) - (goto-char match-end) - (setq foundp nil)) - ;; make sure we're really looking at the start of a - ;; class definition, and not a forward decl, return - ;; arg, template arg list, or an ObjC or Java method. - ((and c-method-key - (re-search-forward c-method-key search-end t)) - (setq foundp nil)) - ;; Its impossible to define a regexp for this, and - ;; nearly so to do it programmatically. - ;; - ;; ; picks up forward decls - ;; = picks up init lists - ;; ) picks up return types - ;; > picks up templates, but remember that we can - ;; inherit from templates! - ((let ((skipchars "^;=)")) - ;; try to see if we found the `class' keyword - ;; inside a template arg list - (save-excursion - (skip-chars-backward "^<>" search-start) - (if (eq (char-before) ?<) - (setq skipchars (concat skipchars ">")))) - (skip-chars-forward skipchars search-end) - (/= (point) search-end)) - (setq foundp nil)) - ))) - foundp)) - ))))) - -(defun c-inside-bracelist-p (containing-sexp brace-state) - ;; return the buffer position of the beginning of the brace list - ;; statement if we're inside a brace list, otherwise return nil. - ;; CONTAINING-SEXP is the buffer pos of the innermost containing - ;; paren. BRACE-STATE is the remainder of the state of enclosing braces - ;; - ;; N.B.: This algorithm can potentially get confused by cpp macros - ;; places in inconvenient locations. Its a trade-off we make for - ;; speed. - (or - ;; this will pick up enum lists - (condition-case () - (save-excursion - (goto-char containing-sexp) - (forward-sexp -1) - (if (and (or (looking-at "enum[\t\n ]+") - (progn (forward-sexp -1) - (looking-at "enum[\t\n ]+"))) - (progn (c-end-of-statement-1) - (> (point) containing-sexp))) - (point))) - (error nil)) - ;; this will pick up array/aggregate init lists, even if they are nested. - (save-excursion - (let (bufpos failedp) - (while (and (not bufpos) - containing-sexp) - (if (consp containing-sexp) - (setq containing-sexp (car brace-state) - brace-state (cdr brace-state)) - ;; see if significant character just before brace is an equal - (goto-char containing-sexp) - (setq failedp nil) - (condition-case () - (progn - (forward-sexp -1) - (forward-sexp 1) - (c-forward-syntactic-ws containing-sexp)) - (error (setq failedp t))) - (if (or failedp (not (eq (char-after) ?=))) - ;; lets see if we're nested. find the most nested - ;; containing brace - (setq containing-sexp (car brace-state) - brace-state (cdr brace-state)) - ;; we've hit the beginning of the aggregate list - (c-beginning-of-statement-1 (c-most-enclosing-brace brace-state)) - (setq bufpos (point))) - )) - bufpos)) - )) - - -(defun c-most-enclosing-brace (state) - ;; return the bufpos of the most enclosing brace that hasn't been - ;; narrowed out by any enclosing class, or nil if none was found - (let (enclosingp) - (while (and state (not enclosingp)) - (setq enclosingp (car state) - state (cdr state)) - (if (consp enclosingp) - (setq enclosingp nil) - (if (> (point-min) enclosingp) - (setq enclosingp nil)) - (setq state nil))) - enclosingp)) - -(defun c-least-enclosing-brace (state) - ;; return the bufpos of the least (highest) enclosing brace that - ;; hasn't been narrowed out by any enclosing class, or nil if none - ;; was found. - (c-most-enclosing-brace (nreverse state))) - -(defun c-safe-position (bufpos state) - ;; return the closest known safe position higher up than point - (let ((safepos nil)) - (while state - (setq safepos - (if (consp (car state)) - (cdr (car state)) - (car state))) - (if (< safepos bufpos) - (setq state nil) - (setq state (cdr state)))) - safepos)) - -(defun c-narrow-out-enclosing-class (state lim) - ;; narrow the buffer so that the enclosing class is hidden - (let (inclass-p) - (and state - (setq inclass-p (c-search-uplist-for-classkey state)) - (narrow-to-region - (progn - (goto-char (1+ (aref inclass-p 1))) - (skip-chars-forward " \t\n" lim) - ;; if point is now left of the class opening brace, we're - ;; hosed, so try a different tact - (if (<= (point) (aref inclass-p 1)) - (progn - (goto-char (1+ (aref inclass-p 1))) - (c-forward-syntactic-ws lim))) - (point)) - ;; end point is the end of the current line - (progn - (goto-char lim) - (c-point 'eol)))) - ;; return the class vector - inclass-p)) - - -;; This function implements the main decision tree for determining the -;; syntactic analysis of the current line of code. Yes, it's huge and -;; bloated! - -(defun c-guess-basic-syntax () - (save-excursion - (save-restriction - (beginning-of-line) - (let* ((indent-point (point)) - (case-fold-search nil) - (fullstate (c-parse-state)) - (state fullstate) - (in-method-intro-p (and (eq major-mode 'objc-mode) - c-method-key - (looking-at c-method-key))) - literal containing-sexp char-before-ip char-after-ip lim - syntax placeholder c-in-literal-cache inswitch-p - injava-inher - ;; narrow out any enclosing class or extern "C" block - (inclass-p (c-narrow-out-enclosing-class state indent-point)) - (inextern-p (and inclass-p - (save-excursion - (save-restriction - (widen) - (goto-char (aref inclass-p 0)) - (looking-at "extern[^_]"))))) - ) - - ;; get the buffer position of the most nested opening brace, - ;; if there is one, and it hasn't been narrowed out - (save-excursion - (goto-char indent-point) - (skip-chars-forward " \t}") - (skip-chars-backward " \t") - (while (and state - (not in-method-intro-p) - (not containing-sexp)) - (setq containing-sexp (car state) - state (cdr state)) - (if (consp containing-sexp) - ;; if cdr == point, then containing sexp is the brace - ;; that opens the sexp we close - (if (= (cdr containing-sexp) (point)) - (setq containing-sexp (car containing-sexp)) - ;; otherwise, ignore this element - (setq containing-sexp nil)) - ;; ignore the bufpos if its been narrowed out by the - ;; containing class - (if (<= containing-sexp (point-min)) - (setq containing-sexp nil))))) - - ;; set the limit on the farthest back we need to search - (setq lim (or containing-sexp - (if (consp (car fullstate)) - (cdr (car fullstate)) - nil) - (point-min))) - - ;; cache char before and after indent point, and move point to - ;; the most likely position to perform the majority of tests - (goto-char indent-point) - (skip-chars-forward " \t") - (setq char-after-ip (char-after)) - (c-backward-syntactic-ws lim) - (setq char-before-ip (char-before)) - (goto-char indent-point) - (skip-chars-forward " \t") - - ;; are we in a literal? - (setq literal (c-in-literal lim)) - - ;; now figure out syntactic qualities of the current line - (cond - ;; CASE 1: in a string. - ((memq literal '(string)) - (c-add-syntax 'string (c-point 'bopl))) - ;; CASE 2: in a C or C++ style comment. - ((memq literal '(c c++)) - ;; we need to catch multi-paragraph C comments - (while (and (zerop (forward-line -1)) - (looking-at "^[ \t]*$"))) - (c-add-syntax literal (c-point 'boi))) - ;; CASE 3: in a cpp preprocessor - ((eq literal 'pound) - (c-beginning-of-macro lim) - (c-add-syntax 'cpp-macro (c-point 'boi))) - ;; CASE 4: in an objective-c method intro - (in-method-intro-p - (c-add-syntax 'objc-method-intro (c-point 'boi))) - ;; CASE 5: Line is at top level. - ((null containing-sexp) - (cond - ;; CASE 5A: we are looking at a defun, class, or - ;; inline-inclass method opening brace - ((eq char-after-ip ?{) - (cond - ;; CASE 5A.1: extern declaration - ((save-excursion - (goto-char indent-point) - (skip-chars-forward " \t") - (and (c-safe (progn (backward-sexp 2) t)) - (looking-at "extern[^_]") - (progn - (setq placeholder (point)) - (forward-sexp 1) - (c-forward-syntactic-ws) - (eq (char-after) ?\")))) - (goto-char placeholder) - (c-add-syntax 'extern-lang-open (c-point 'boi))) - ;; CASE 5A.2: we are looking at a class opening brace - ((save-excursion - (goto-char indent-point) - (skip-chars-forward " \t{") - ;; TBD: watch out! there could be a bogus - ;; c-state-cache in place when we get here. we have - ;; to go through much chicanery to ignore the cache. - ;; But of course, there may not be! BLECH! BOGUS! - (let ((decl - (if (boundp 'c-state-cache) - (let ((old-cache c-state-cache)) - (prog2 - (makunbound 'c-state-cache) - (c-search-uplist-for-classkey (c-parse-state)) - (setq c-state-cache old-cache))) - (c-search-uplist-for-classkey (c-parse-state)) - ))) - (and decl - (setq placeholder (aref decl 0))) - )) - (c-add-syntax 'class-open placeholder)) - ;; CASE 5A.3: brace list open - ((save-excursion - (c-beginning-of-statement-1 lim) - ;; c-b-o-s could have left us at point-min - (and (bobp) - (c-forward-syntactic-ws indent-point)) - (if (looking-at "typedef[^_]") - (progn (forward-sexp 1) - (c-forward-syntactic-ws indent-point))) - (setq placeholder (c-point 'boi)) - (and (or (looking-at "enum[ \t\n]+") - (eq char-before-ip ?=)) - (save-excursion - (skip-chars-forward "^;(" indent-point) - (not (memq (char-after) '(?\; ?\())) - ))) - (c-add-syntax 'brace-list-open placeholder)) - ;; CASE 5A.4: inline defun open - ((and inclass-p (not inextern-p)) - (c-add-syntax 'inline-open) - (c-add-syntax 'inclass (aref inclass-p 0))) - ;; CASE 5A.5: ordinary defun open - (t - (goto-char placeholder) - (c-add-syntax 'defun-open (c-point 'bol)) - ))) - ;; CASE 5B: first K&R arg decl or member init - ((c-just-after-func-arglist-p) - (cond - ;; CASE 5B.1: a member init - ((or (eq char-before-ip ?:) - (eq char-after-ip ?:)) - ;; this line should be indented relative to the beginning - ;; of indentation for the topmost-intro line that contains - ;; the prototype's open paren - ;; TBD: is the following redundant? - (if (eq char-before-ip ?:) - (forward-char -1)) - (c-backward-syntactic-ws lim) - ;; TBD: is the preceding redundant? - (if (eq (char-before) ?:) - (progn (forward-char -1) - (c-backward-syntactic-ws lim))) - (if (eq (char-before) ?\)) - (backward-sexp 1)) - (setq placeholder (point)) - (save-excursion - (and (c-safe (backward-sexp 1) t) - (looking-at "throw[^_]") - (c-safe (backward-sexp 1) t) - (setq placeholder (point)))) - (goto-char placeholder) - (c-add-syntax 'member-init-intro (c-point 'boi)) - ;; we don't need to add any class offset since this - ;; should be relative to the ctor's indentation - ) - ;; CASE 5B.2: K&R arg decl intro - (c-recognize-knr-p - (c-add-syntax 'knr-argdecl-intro (c-point 'boi)) - (and inclass-p (c-add-syntax 'inclass (aref inclass-p 0)))) - ;; CASE 5B.3: Nether region after a C++ or Java func - ;; decl, which could include a `throws' declaration. - (t - (c-beginning-of-statement-1 lim) - (c-add-syntax 'func-decl-cont (c-point 'boi)) - ))) - ;; CASE 5C: inheritance line. could be first inheritance - ;; line, or continuation of a multiple inheritance - ((or (and c-baseclass-key (looking-at c-baseclass-key)) - (and (or (eq char-before-ip ?:) - ;; watch out for scope operator - (save-excursion - (and (eq char-after-ip ?:) - (c-safe (progn (forward-char 1) t)) - (not (eq (char-after) ?:)) - ))) - (save-excursion - (c-backward-syntactic-ws lim) - (if (eq char-before-ip ?:) - (progn - (forward-char -1) - (c-backward-syntactic-ws lim))) - (back-to-indentation) - (looking-at c-class-key))) - ;; for Java - (and (eq major-mode 'java-mode) - (let ((fence (save-excursion - (c-beginning-of-statement-1 lim) - (point))) - cont done) - (save-excursion - (while (not done) - (cond ((looking-at c-Java-special-key) - (setq injava-inher (cons cont (point)) - done t)) - ((or (not (c-safe (forward-sexp -1) t)) - (<= (point) fence)) - (setq done t)) - ) - (setq cont t))) - injava-inher) - (not (c-crosses-statement-barrier-p (cdr injava-inher) - (point))) - )) - (cond - ;; CASE 5C.1: non-hanging colon on an inher intro - ((eq char-after-ip ?:) - (c-backward-syntactic-ws lim) - (c-add-syntax 'inher-intro (c-point 'boi)) - ;; don't add inclass symbol since relative point already - ;; contains any class offset - ) - ;; CASE 5C.2: hanging colon on an inher intro - ((eq char-before-ip ?:) - (c-add-syntax 'inher-intro (c-point 'boi)) - (and inclass-p (c-add-syntax 'inclass (aref inclass-p 0)))) - ;; CASE 5C.3: in a Java implements/extends - (injava-inher - (let ((where (cdr injava-inher)) - (cont (car injava-inher))) - (goto-char where) - (cond ((looking-at "throws[ \t\n]") - (c-add-syntax 'func-decl-cont - (progn (c-beginning-of-statement-1 lim) - (c-point 'boi)))) - (cont (c-add-syntax 'inher-cont where)) - (t (c-add-syntax 'inher-intro - (progn (goto-char (cdr injava-inher)) - (c-beginning-of-statement-1 lim) - (point)))) - ))) - ;; CASE 5C.4: a continued inheritance line - (t - (c-beginning-of-inheritance-list lim) - (c-add-syntax 'inher-cont (point)) - ;; don't add inclass symbol since relative point already - ;; contains any class offset - ))) - ;; CASE 5D: this could be a top-level compound statement or a - ;; member init list continuation - ((eq char-before-ip ?,) - (goto-char indent-point) - (c-backward-syntactic-ws lim) - (while (and (< lim (point)) - (eq (char-before) ?,)) - ;; this will catch member inits with multiple - ;; line arglists - (forward-char -1) - (c-backward-syntactic-ws (c-point 'bol)) - (if (eq (char-before) ?\)) - (backward-sexp 1)) - ;; now continue checking - (beginning-of-line) - (c-backward-syntactic-ws lim)) - (cond - ;; CASE 5D.1: hanging member init colon, but watch out - ;; for bogus matches on access specifiers inside classes. - ((and (eq (char-before) ?:) - (save-excursion - (forward-word -1) - (not (looking-at c-access-key)))) - (goto-char indent-point) - (c-backward-syntactic-ws lim) - (c-safe (backward-sexp 1)) - (c-add-syntax 'member-init-cont (c-point 'boi)) - ;; we do not need to add class offset since relative - ;; point is the member init above us - ) - ;; CASE 5D.2: non-hanging member init colon - ((progn - (c-forward-syntactic-ws indent-point) - (eq (char-after) ?:)) - (skip-chars-forward " \t:") - (c-add-syntax 'member-init-cont (point))) - ;; CASE 5D.3: perhaps a multiple inheritance line? - ((looking-at c-inher-key) - (c-add-syntax 'inher-cont (c-point 'boi))) - ;; CASE 5D.4: perhaps a template list continuation? - ((save-excursion - (goto-char indent-point) - (skip-chars-backward "^<" lim) - ;; not sure if this is the right test, but it should - ;; be fast and mostly accurate. - (and (eq (char-before) ?<) - (not (c-in-literal lim)))) - ;; we can probably indent it just like an arglist-cont - (c-add-syntax 'template-args-cont (point))) - ;; CASE 5D.5: perhaps a top-level statement-cont - (t - (c-beginning-of-statement-1 lim) - ;; skip over any access-specifiers - (and inclass-p c-access-key - (while (looking-at c-access-key) - (forward-line 1))) - ;; skip over comments, whitespace - (c-forward-syntactic-ws indent-point) - (c-add-syntax 'statement-cont (c-point 'boi))) - )) - ;; CASE 5E: we are looking at a access specifier - ((and inclass-p - c-access-key - (looking-at c-access-key)) - (c-add-syntax 'access-label (c-point 'bonl)) - (c-add-syntax 'inclass (aref inclass-p 0))) - ;; CASE 5F: extern-lang-close? - ((and inextern-p - (eq char-after-ip ?})) - (c-add-syntax 'extern-lang-close (aref inclass-p 0))) - ;; CASE 5G: we are looking at the brace which closes the - ;; enclosing nested class decl - ((and inclass-p - (eq char-after-ip ?}) - (save-excursion - (save-restriction - (widen) - (forward-char 1) - (and - (condition-case nil - (progn (backward-sexp 1) t) - (error nil)) - (= (point) (aref inclass-p 1)) - )))) - (save-restriction - (widen) - (goto-char (aref inclass-p 0)) - (c-add-syntax 'class-close (c-point 'boi)))) - ;; CASE 5H: we could be looking at subsequent knr-argdecls - ((and c-recognize-knr-p - ;; here we essentially use the hack that is used in - ;; Emacs' c-mode.el to limit how far back we should - ;; look. The assumption is made that argdecls are - ;; indented at least one space and that function - ;; headers are not indented. - (let ((limit (save-excursion - (re-search-backward "^[^ \^L\t\n#]" nil 'move) - (point)))) - (save-excursion - (c-backward-syntactic-ws limit) - (setq placeholder (point)) - (while (and (memq (char-before) '(?\; ?,)) - (> (point) limit)) - (beginning-of-line) - (setq placeholder (point)) - (c-backward-syntactic-ws limit)) - (and (eq (char-before) ?\)) - (or (not c-method-key) - (progn - (forward-sexp -1) - (forward-char -1) - (c-backward-syntactic-ws) - (not (or (memq (char-before) '(?- ?+)) - ;; or a class category - (progn - (forward-sexp -2) - (looking-at c-class-key)) - ))))) - )) - (save-excursion - (c-beginning-of-statement-1) - (not (looking-at "typedef[ \t\n]+")))) - (goto-char placeholder) - (c-add-syntax 'knr-argdecl (c-point 'boi))) - ;; CASE 5I: we are at the topmost level, make sure we skip - ;; back past any access specifiers - ((progn - (c-backward-syntactic-ws lim) - (while (and inclass-p - c-access-key - (not (bobp)) - (save-excursion - (c-safe (progn (backward-sexp 1) t)) - (looking-at c-access-key))) - (backward-sexp 1) - (c-backward-syntactic-ws lim)) - (or (bobp) - (memq (char-before) '(?\; ?\})))) - ;; real beginning-of-line could be narrowed out due to - ;; enclosure in a class block - (save-restriction - (widen) - (c-add-syntax 'topmost-intro (c-point 'bol)) - (if inclass-p - (progn - (goto-char (aref inclass-p 1)) - (or (= (point) (c-point 'boi)) - (goto-char (aref inclass-p 0))) - (if inextern-p - (c-add-syntax 'inextern-lang) - (c-add-syntax 'inclass (c-point 'boi))))) - )) - ;; CASE 5J: we are at an ObjC or Java method definition - ;; continuation line. - ((and c-method-key - (progn - (c-beginning-of-statement-1 lim) - (beginning-of-line) - (looking-at c-method-key))) - (c-add-syntax 'objc-method-args-cont (point))) - ;; CASE 5K: we are at a topmost continuation line - (t - (c-beginning-of-statement-1 lim) - (c-forward-syntactic-ws) - (c-add-syntax 'topmost-intro-cont (c-point 'boi))) - )) ; end CASE 5 - ;; CASE 6: line is an expression, not a statement. Most - ;; likely we are either in a function prototype or a function - ;; call argument list - ((not (eq (char-after containing-sexp) ?{)) - (c-backward-syntactic-ws containing-sexp) - (cond - ;; CASE 6A: we are looking at the arglist closing paren - ((and (not (eq char-before-ip ?,)) - (memq char-after-ip '(?\) ?\]))) - (goto-char containing-sexp) - (c-add-syntax 'arglist-close (c-point 'boi))) - ;; CASE 6B: we are looking at the first argument in an empty - ;; argument list. Use arglist-close if we're actually - ;; looking at a close paren or bracket. - ((memq char-before-ip '(?\( ?\[)) - (goto-char containing-sexp) - (c-add-syntax 'arglist-intro (c-point 'boi))) - ;; CASE 6C: we are inside a conditional test clause. treat - ;; these things as statements - ((save-excursion - (goto-char containing-sexp) - (and (c-safe (progn (forward-sexp -1) t)) - (looking-at "\\<for\\>[^_]"))) - (goto-char (1+ containing-sexp)) - (c-forward-syntactic-ws indent-point) - (c-beginning-of-statement-1 containing-sexp) - (if (eq char-before-ip ?\;) - (c-add-syntax 'statement (point)) - (c-add-syntax 'statement-cont (point)) - )) - ;; CASE 6D: maybe a continued method call. This is the case - ;; when we are inside a [] bracketed exp, and what precede - ;; the opening bracket is not an identifier. - ((and c-method-key - (eq (char-after containing-sexp) ?\[) - (save-excursion - (goto-char (1- containing-sexp)) - (c-backward-syntactic-ws (c-point 'bod)) - (if (not (looking-at c-symbol-key)) - (c-add-syntax 'objc-method-call-cont containing-sexp)) - ))) - ;; CASE 6E: we are looking at an arglist continuation line, - ;; but the preceding argument is on the same line as the - ;; opening paren. This case includes multi-line - ;; mathematical paren groupings, but we could be on a - ;; for-list continuation line - ((and (save-excursion - (goto-char (1+ containing-sexp)) - (skip-chars-forward " \t") - (not (eolp))) - (save-excursion - (c-beginning-of-statement-1 lim) - (skip-chars-backward " \t([") - (<= (point) containing-sexp))) - (goto-char containing-sexp) - (c-add-syntax 'arglist-cont-nonempty (c-point 'boi))) - ;; CASE 6F: we are looking at just a normal arglist - ;; continuation line - (t (c-beginning-of-statement-1 containing-sexp) - (forward-char 1) - (c-forward-syntactic-ws indent-point) - (c-add-syntax 'arglist-cont (c-point 'boi))) - )) - ;; CASE 7: func-local multi-inheritance line - ((and c-baseclass-key - (save-excursion - (goto-char indent-point) - (skip-chars-forward " \t") - (looking-at c-baseclass-key))) - (goto-char indent-point) - (skip-chars-forward " \t") - (cond - ;; CASE 7A: non-hanging colon on an inher intro - ((eq char-after-ip ?:) - (c-backward-syntactic-ws lim) - (c-add-syntax 'inher-intro (c-point 'boi))) - ;; CASE 7B: hanging colon on an inher intro - ((eq char-before-ip ?:) - (c-add-syntax 'inher-intro (c-point 'boi))) - ;; CASE 7C: a continued inheritance line - (t - (c-beginning-of-inheritance-list lim) - (c-add-syntax 'inher-cont (point)) - ))) - ;; CASE 8: we are inside a brace-list - ((setq placeholder (c-inside-bracelist-p containing-sexp state)) - (cond - ;; CASE 8A: brace-list-close brace - ((and (eq char-after-ip ?}) - (c-safe (progn (forward-char 1) - (backward-sexp 1) - t)) - (= (point) containing-sexp)) - (c-add-syntax 'brace-list-close (c-point 'boi))) - ;; CASE 8B: we're looking at the first line in a brace-list - ((save-excursion - (goto-char indent-point) - (c-backward-syntactic-ws containing-sexp) - (= (point) (1+ containing-sexp))) - (goto-char containing-sexp) - (c-add-syntax 'brace-list-intro (c-point 'boi)) - ) - ;;)) ; end CASE 8B - ;; CASE 8C: this is just a later brace-list-entry - (t (goto-char (1+ containing-sexp)) - (c-forward-syntactic-ws indent-point) - (if (eq char-after-ip ?{) - (c-add-syntax 'brace-list-open (point)) - (c-add-syntax 'brace-list-entry (point)) - )) ; end CASE 8C - )) ; end CASE 8 - ;; CASE 9: A continued statement - ((and (not (memq char-before-ip '(?\; ?} ?:))) - (> (point) - (save-excursion - (c-beginning-of-statement-1 containing-sexp) - (setq placeholder (point)))) - (/= placeholder containing-sexp)) - (goto-char indent-point) - (skip-chars-forward " \t") - (let ((after-cond-placeholder - (save-excursion - (goto-char placeholder) - (if (looking-at c-conditional-key) - (progn - (c-safe (c-skip-conditional)) - (c-forward-syntactic-ws) - (if (eq (char-after) ?\;) - (progn - (forward-char 1) - (c-forward-syntactic-ws))) - (point)) - nil)))) - (cond - ;; CASE 9A: substatement - ((and after-cond-placeholder - (>= after-cond-placeholder indent-point)) - (goto-char placeholder) - (if (eq char-after-ip ?{) - (c-add-syntax 'substatement-open (c-point 'boi)) - (c-add-syntax 'substatement (c-point 'boi)))) - ;; CASE 9B: open braces for class or brace-lists - ((eq char-after-ip ?{) - (cond - ;; CASE 9B.1: class-open - ((save-excursion - (goto-char indent-point) - (skip-chars-forward " \t{") - (let ((decl (c-search-uplist-for-classkey (c-parse-state)))) - (and decl - (setq placeholder (aref decl 0))) - )) - (c-add-syntax 'class-open placeholder)) - ;; CASE 9B.2: brace-list-open - ((or (save-excursion - (goto-char placeholder) - (looking-at "\\<enum\\>")) - (eq char-before-ip ?=)) - (c-add-syntax 'brace-list-open placeholder)) - ;; CASE 9B.3: catch-all for unknown construct. - (t - ;; Can and should I add an extensibility hook here? - ;; Something like c-recognize-hook so support for - ;; unknown constructs could be added. It's probably a - ;; losing proposition, so I dunno. - (goto-char placeholder) - (c-add-syntax 'statement-cont (c-point 'boi)) - (c-add-syntax 'block-open)) - )) - ;; CASE 9C: iostream insertion or extraction operator - ((looking-at "<<\\|>>") - (goto-char placeholder) - (and after-cond-placeholder - (goto-char after-cond-placeholder)) - (while (and (re-search-forward "<<\\|>>" indent-point 'move) - (c-in-literal placeholder))) - ;; if we ended up at indent-point, then the first - ;; streamop is on a separate line. Indent the line like - ;; a statement-cont instead - (if (/= (point) indent-point) - (c-add-syntax 'stream-op (c-point 'boi)) - (c-backward-syntactic-ws lim) - (c-add-syntax 'statement-cont (c-point 'boi)))) - ;; CASE 9D: continued statement. find the accurate - ;; beginning of statement or substatement - (t - (c-beginning-of-statement-1 after-cond-placeholder) - ;; KLUDGE ALERT! c-beginning-of-statement-1 can leave - ;; us before the lim we're passing in. It should be - ;; fixed, but I'm worried about side-effects at this - ;; late date. Fix for v5. - (goto-char (or (and after-cond-placeholder - (max after-cond-placeholder (point))) - (point))) - (c-add-syntax 'statement-cont (point))) - ))) - ;; CASE 10: an else clause? - ((looking-at "\\<else\\>[^_]") - (c-backward-to-start-of-if containing-sexp) - (c-add-syntax 'else-clause (c-point 'boi))) - ;; CASE 11: Statement. But what kind? Lets see if its a - ;; while closure of a do/while construct - ((progn - (goto-char indent-point) - (skip-chars-forward " \t") - (and (looking-at "while\\b[^_]") - (save-excursion - (c-backward-to-start-of-do containing-sexp) - (setq placeholder (point)) - (looking-at "do\\b[^_]")) - )) - (c-add-syntax 'do-while-closure placeholder)) - ;; CASE 12: A case or default label - ((looking-at c-switch-label-key) - (goto-char containing-sexp) - ;; check for hanging braces - (if (/= (point) (c-point 'boi)) - (forward-sexp -1)) - (c-add-syntax 'case-label (c-point 'boi))) - ;; CASE 13: any other label - ((looking-at c-label-key) - (goto-char containing-sexp) - (c-add-syntax 'label (c-point 'boi))) - ;; CASE 14: block close brace, possibly closing the defun or - ;; the class - ((eq char-after-ip ?}) - (let* ((lim (c-safe-position containing-sexp fullstate)) - (relpos (save-excursion - (goto-char containing-sexp) - (if (/= (point) (c-point 'boi)) - (c-beginning-of-statement-1 lim)) - (c-point 'boi)))) - (cond - ;; CASE 14A: does this close an inline? - ((let ((inclass-p (progn - (goto-char containing-sexp) - (c-search-uplist-for-classkey state)))) - ;; inextern-p in higher level let* - (setq inextern-p (and inclass-p - (progn - (goto-char (aref inclass-p 0)) - (looking-at "extern[^_]")))) - (and inclass-p (not inextern-p))) - (c-add-syntax 'inline-close relpos)) - ;; CASE 14B: if there an enclosing brace that hasn't - ;; been narrowed out by a class, then this is a - ;; block-close - ((and (not inextern-p) - (c-most-enclosing-brace state)) - (c-add-syntax 'block-close relpos)) - ;; CASE 14C: find out whether we're closing a top-level - ;; class or a defun - (t - (save-restriction - (narrow-to-region (point-min) indent-point) - (let ((decl (c-search-uplist-for-classkey (c-parse-state)))) - (if decl - (c-add-syntax 'class-close (aref decl 0)) - (c-add-syntax 'defun-close relpos))))) - ))) - ;; CASE 15: statement catchall - (t - ;; we know its a statement, but we need to find out if it is - ;; the first statement in a block - (goto-char containing-sexp) - (forward-char 1) - (c-forward-syntactic-ws indent-point) - ;; now skip forward past any case/default clauses we might find. - (while (or (c-skip-case-statement-forward fullstate indent-point) - (and (looking-at c-switch-label-key) - (not inswitch-p))) - (setq inswitch-p t)) - ;; we want to ignore non-case labels when skipping forward - (while (and (looking-at c-label-key) - (goto-char (match-end 0))) - (c-forward-syntactic-ws indent-point)) - (cond - ;; CASE 15A: we are inside a case/default clause inside a - ;; switch statement. find out if we are at the statement - ;; just after the case/default label. - ((and inswitch-p - (progn - (goto-char indent-point) - (c-backward-syntactic-ws containing-sexp) - (back-to-indentation) - (setq placeholder (point)) - (looking-at c-switch-label-key))) - (goto-char indent-point) - (skip-chars-forward " \t") - (if (eq (char-after) ?{) - (c-add-syntax 'statement-case-open placeholder) - (c-add-syntax 'statement-case-intro placeholder))) - ;; CASE 15B: continued statement - ((eq char-before-ip ?,) - (c-add-syntax 'statement-cont (c-point 'boi))) - ;; CASE 15C: a question/colon construct? But make sure - ;; what came before was not a label, and what comes after - ;; is not a globally scoped function call! - ((or (and (memq char-before-ip '(?: ??)) - (save-excursion - (goto-char indent-point) - (c-backward-syntactic-ws lim) - (back-to-indentation) - (not (looking-at c-label-key)))) - (and (memq char-after-ip '(?: ??)) - (save-excursion - (goto-char indent-point) - (skip-chars-forward " \t") - ;; watch out for scope operator - (not (looking-at "::"))))) - (c-add-syntax 'statement-cont (c-point 'boi))) - ;; CASE 15D: any old statement - ((< (point) indent-point) - (let ((safepos (c-most-enclosing-brace fullstate)) - relpos done) - (goto-char indent-point) - (c-beginning-of-statement-1 safepos) - ;; It is possible we're on the brace that opens a nested - ;; function. - (if (and (eq (char-after) ?{) - (save-excursion - (c-backward-syntactic-ws safepos) - (not (eq (char-before) ?\;)))) - (c-beginning-of-statement-1 safepos)) - (if (and inswitch-p - (looking-at c-switch-label-key)) - (progn - (goto-char placeholder) - (end-of-line) - (forward-sexp -1))) - (setq relpos (c-point 'boi)) - (while (and (not done) - (<= safepos (point)) - (/= relpos (point))) - (c-beginning-of-statement-1 safepos) - (if (= relpos (c-point 'boi)) - (setq done t)) - (setq relpos (c-point 'boi))) - (c-add-syntax 'statement relpos) - (if (eq char-after-ip ?{) - (c-add-syntax 'block-open)))) - ;; CASE 15E: first statement in an inline, or first - ;; statement in a top-level defun. we can tell this is it - ;; if there are no enclosing braces that haven't been - ;; narrowed out by a class (i.e. don't use bod here!) - ((save-excursion - (save-restriction - (widen) - (goto-char containing-sexp) - (c-narrow-out-enclosing-class state containing-sexp) - (not (c-most-enclosing-brace state)))) - (goto-char containing-sexp) - ;; if not at boi, then defun-opening braces are hung on - ;; right side, so we need a different relpos - (if (/= (point) (c-point 'boi)) - (progn - (c-backward-syntactic-ws) - (c-safe (forward-sexp (if (eq (char-before) ?\)) - -1 -2))) - ;; looking at a Java throws clause following a - ;; method's parameter list - (c-beginning-of-statement-1) - )) - (c-add-syntax 'defun-block-intro (c-point 'boi))) - ;; CASE 15F: first statement in a block - (t (goto-char containing-sexp) - (if (/= (point) (c-point 'boi)) - (c-beginning-of-statement-1 - (if (= (point) lim) - (c-safe-position (point) state) lim))) - (c-add-syntax 'statement-block-intro (c-point 'boi)) - (if (eq char-after-ip ?{) - (c-add-syntax 'block-open))) - )) - ) - - ;; now we need to look at any modifiers - (goto-char indent-point) - (skip-chars-forward " \t") - ;; are we looking at a comment only line? - (if (looking-at c-comment-start-regexp) - (c-add-syntax 'comment-intro)) - ;; we might want to give additional offset to friends (in C++). - (if (and (eq major-mode 'c++-mode) - (looking-at c-C++-friend-key)) - (c-add-syntax 'friend)) - ;; return the syntax - syntax)))) - - -(defun c-echo-parsing-error () - (if (not c-parsing-error) - nil - (message "unbalanced close brace at bufpos %d -- INDENTATION IS SUSPECT!" - c-parsing-error) - (ding)) - c-parsing-error) - -;; indent via syntactic language elements -(defun c-indent-line (&optional syntax) - ;; indent the current line as C/C++/ObjC code. Optional SYNTAX is the - ;; syntactic information for the current line. Returns the amount of - ;; indentation change - (let* ((c-syntactic-context (or syntax (c-guess-basic-syntax))) - (pos (- (point-max) (point))) - (indent (apply '+ (mapcar 'c-get-offset c-syntactic-context))) - (shift-amt (- (current-indentation) indent))) - (and c-echo-syntactic-information-p - (not (c-echo-parsing-error)) - (message "syntax: %s, indent= %d" c-syntactic-context indent)) - (if (zerop shift-amt) - nil - (delete-region (c-point 'bol) (c-point 'boi)) - (beginning-of-line) - (indent-to indent)) - (if (< (point) (c-point 'boi)) - (back-to-indentation) - ;; If initial point was within line's indentation, position after - ;; the indentation. Else stay at same point in text. - (if (> (- (point-max) pos) (point)) - (goto-char (- (point-max) pos))) - ) - (run-hooks 'c-special-indent-hook) - shift-amt)) - -(defun c-show-syntactic-information (arg) - "Show syntactic information for current line. -With universal argument, inserts the analysis as a comment on that line." - (interactive "P") - (let ((syntax (c-guess-basic-syntax))) - (if (not (consp arg)) - (if (not (c-echo-parsing-error)) - (message "syntactic analysis: %s" syntax)) - (indent-for-comment) - (insert (format "%s" syntax)) - )) - (c-keep-region-active)) - - -(provide 'cc-engine) -;;; cc-engine.el ends here
--- a/lisp/cc-mode/cc-langs.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,563 +0,0 @@ -;;; cc-langs.el --- specific language support for CC Mode - -;; Copyright (C) 1985,87,92,93,94,95,96,97 Free Software Foundation, Inc. - -;; Authors: 1992-1997 Barry A. Warsaw -;; 1987 Dave Detlefs and Stewart Clamen -;; 1985 Richard M. Stallman -;; Maintainer: cc-mode-help@python.org -;; Created: 22-Apr-1997 (split from cc-mode.el) -;; Version: See cc-mode.el -;; Keywords: c languages oop - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -(require 'cc-defs) - - -;; Regular expressions and other values which must be parameterized on -;; a per-language basis. - -;; Keywords defining protection levels -(defconst c-protection-key "\\<\\(public\\|protected\\|private\\)\\>") - -;; Regex describing a `symbol' in all languages. We cannot use just -;; `word' syntax class since `_' cannot be in word class. Putting -;; underscore in word class breaks forward word movement behavior that -;; users are familiar with. Besides, this runs counter to Emacs -;; convention. -;; -;; I suspect this definition isn't correct in light of Java's -;; definition of a symbol as being Unicode. I know so little about -;; I18N (except how to sound cool and say I18N :-) that I'm willing to -;; punt on this for now. - -(defconst c-symbol-key "[_a-zA-Z]\\(\\w\\|\\s_\\)*") - - -;; keywords introducing class definitions. language specific -(defconst c-C-class-key "\\(struct\\|union\\)") -(defconst c-C++-class-key "\\(class\\|struct\\|union\\)") - -(defconst c-ObjC-class-key - (concat - "@\\(interface\\|implementation\\)\\s +" - c-symbol-key ;name of the class - "\\(\\s *:\\s *" c-symbol-key "\\)?" ;maybe followed by the superclass - "\\(\\s *<[^>]+>\\)?" ;and maybe the adopted protocols list - )) - -(defconst c-Java-class-key - (concat - "\\(" c-protection-key "\\s +\\)?" - "\\(interface\\|class\\)\\s +" - c-symbol-key ;name of the class - "\\(\\s *extends\\s *" c-symbol-key "\\)?" ;maybe followed by superclass - ;;"\\(\\s *implements *[^{]+{\\)?" ;maybe the adopted protocols list - )) - -(defvar c-class-key c-C-class-key) -(make-variable-buffer-local 'c-class-key) - - -;; regexp describing access protection clauses. language specific -(defvar c-access-key nil) -(make-variable-buffer-local 'c-access-key) -(defconst c-C++-access-key (concat c-protection-key "[ \t]*:")) -(defconst c-ObjC-access-key (concat "@" c-protection-key)) -(defconst c-Java-access-key nil) - - -;; keywords introducing conditional blocks -(defconst c-C-conditional-key nil) -(defconst c-C++-conditional-key nil) -(defconst c-Java-conditional-key nil) - -(let ((all-kws "for\\|if\\|do\\|else\\|while\\|switch") - (exc-kws "\\|try\\|catch") - (thr-kws "\\|finally\\|synchronized") - (front "\\b\\(") - (back "\\)\\b[^_]")) - (setq c-C-conditional-key (concat front all-kws back) - c-C++-conditional-key (concat front all-kws exc-kws back) - c-Java-conditional-key (concat front all-kws exc-kws thr-kws back))) - -(defvar c-conditional-key c-C-conditional-key) -(make-variable-buffer-local 'c-conditional-key) - - -;; keywords describing method definition introductions -(defvar c-method-key nil) -(make-variable-buffer-local 'c-method-key) - -(defconst c-ObjC-method-key - (concat - "^\\s *[+-]\\s *" - "\\(([^)]*)\\)?" ; return type - ;; \\s- in objc syntax table does not include \n - ;; since it is considered the end of //-comments. - "[ \t\n]*" c-symbol-key)) - -(defconst c-Java-method-key - (concat - "^\\s *[+-]\\s *" - "\\(([^)]*)\\)?" ; return type - ;; \\s- in java syntax table does not include \n - ;; since it is considered the end of //-comments. - "[ \t\n]*" c-symbol-key)) - - -;; comment starter definitions for various languages. language specific -(defconst c-C++-comment-start-regexp "/[/*]") -;; We need to match all 3 Java style comments -;; 1) Traditional C block; 2) javadoc /** ...; 3) C++ style -(defconst c-Java-comment-start-regexp "/\\(/\\|[*][*]?\\)") -(defvar c-comment-start-regexp c-C++-comment-start-regexp) -(make-variable-buffer-local 'c-comment-start-regexp) - - - -;; Regexp describing a switch's case or default label for all languages -(defconst c-switch-label-key "\\(\\(case[( \t]+\\S .*\\)\\|default[ \t]*\\):") -;; Regexp describing any label. -(defconst c-label-key (concat c-symbol-key ":\\([^:]\\|$\\)")) - -;; Regexp describing class inheritance declarations. TBD: this should -;; be language specific, and only makes sense for C++ -(defconst c-inher-key - (concat "\\(\\<static\\>\\s +\\)?" - c-C++-class-key "[ \t]+" c-symbol-key - "\\([ \t]*:[ \t]*\\)\\s *[^;]")) - -;; Regexp describing C++ base classes in a derived class definition. -;; TBD: this should be language specific, and only makes sense for C++ -(defvar c-baseclass-key - (concat - ":?[ \t]*\\(virtual[ \t]+\\)?\\(" - c-protection-key "[ \t]+\\)" c-symbol-key)) -(make-variable-buffer-local 'c-baseclass-key) - -;; Regexp describing friend declarations in C++ classes. -(defconst c-C++-friend-key - "friend[ \t]+\\|template[ \t]*<.+>[ \t]*friend[ \t]+") - -;; Regexp describing Java inheritance and throws clauses. -(defconst c-Java-special-key "\\(implements\\|extends\\|throws\\)[^_]") - -;; Regexp describing the beginning of a Java top-level definition. -(defconst c-Java-defun-prompt-regexp - "^[ \t]*\\(\\(\\(public\\|protected\\|private\\|const\\|abstract\\|synchronized\\|final\\|static\\|threadsafe\\|transient\\|native\\|volatile\\)\\s-+\\)*\\(\\(\\([[a-zA-Z][][_$.a-zA-Z0-9]*[][_$.a-zA-Z0-9]+\\|[[a-zA-Z]\\)\\s-*\\)\\s-+\\)\\)?\\(\\([[a-zA-Z][][_$.a-zA-Z0-9]*\\s-+\\)\\s-*\\)?\\([_a-zA-Z][^][ \t:;.,{}()=]*\\|\\([_$a-zA-Z][_$.a-zA-Z0-9]*\\)\\)\\s-*\\(([^);{}]*)\\)?\\([] \t]*\\)\\(\\s-*\\<throws\\>\\s-*\\(\\([_$a-zA-Z][_$.a-zA-Z0-9]*\\)[, \t\n\r\f]*\\)+\\)?\\s-*") - - - -;; internal state variables - -;; Internal state of hungry delete key feature -(defvar c-hungry-delete-key nil) -(make-variable-buffer-local 'c-hungry-delete-key) - -;; Internal state of auto newline feature. -(defvar c-auto-newline nil) -(make-variable-buffer-local 'c-auto-newline) - -;; Internal auto-newline/hungry-delete designation string for mode line. -(defvar c-auto-hungry-string nil) -(make-variable-buffer-local 'c-auto-hungry-string) - -;; Non-nil means K&R style argument declarations are valid. -(defvar c-recognize-knr-p t) -(make-variable-buffer-local 'c-recognize-knr-p) - - - -(defun c-use-java-style () - "Institutes `java' indentation style. -For use with the variable `java-mode-hook'." - (c-set-style "java")) - -(defun c-common-init () - ;; Common initializations for all modes. - ;; these variables should always be buffer local; they do not affect - ;; indentation style. - (make-local-variable 'paragraph-start) - (make-local-variable 'paragraph-separate) - (make-local-variable 'paragraph-ignore-fill-prefix) - (make-local-variable 'require-final-newline) - (make-local-variable 'parse-sexp-ignore-comments) - (make-local-variable 'indent-line-function) - (make-local-variable 'indent-region-function) - (make-local-variable 'comment-start) - (make-local-variable 'comment-end) - (make-local-variable 'comment-column) - (make-local-variable 'comment-start-skip) - (make-local-variable 'comment-multi-line) - (make-local-variable 'outline-regexp) - (make-local-variable 'outline-level) - (make-local-variable 'adaptive-fill-regexp) - (make-local-variable 'imenu-generic-expression) ;set in the mode functions - ;; X/Emacs 20 only - (and (boundp 'comment-line-break-function) - (make-local-variable 'comment-line-break-function)) - ;; Emacs 19.30 and beyond only, AFAIK - (if (boundp 'fill-paragraph-function) - (progn - (make-local-variable 'fill-paragraph-function) - (setq fill-paragraph-function 'c-fill-paragraph))) - ;; now set their values - (setq paragraph-start (concat page-delimiter "\\|$") - paragraph-separate paragraph-start - paragraph-ignore-fill-prefix t - require-final-newline t - parse-sexp-ignore-comments t - indent-line-function 'c-indent-line - indent-region-function 'c-indent-region - outline-regexp "[^#\n\^M]" - outline-level 'c-outline-level - comment-column 32 - comment-start-skip "/\\*+ *\\|// *" - comment-multi-line nil - comment-line-break-function 'c-comment-line-break-function - adaptive-fill-regexp nil) - ;; we have to do something special for c-offsets-alist so that the - ;; buffer local value has its own alist structure. - (setq c-offsets-alist (copy-alist c-offsets-alist)) - ;; setup the comment indent variable in a Emacs version portable way - ;; ignore any byte compiler warnings you might get here - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'c-comment-indent) - ;; add menus to menubar - (easy-menu-add (c-mode-menu mode-name)) - ;; put auto-hungry designators onto minor-mode-alist, but only once - (or (assq 'c-auto-hungry-string minor-mode-alist) - (setq minor-mode-alist - (cons '(c-auto-hungry-string c-auto-hungry-string) - minor-mode-alist)))) - -(defun c-postprocess-file-styles () - "Function that post processes relevant file local variables. -Currently, this function simply applies any style and offset settings -found in the file's Local Variable list. It first applies any style -setting found in `c-file-style', then it applies any offset settings -it finds in `c-file-offsets'." - ;; apply file styles and offsets - (and c-file-style - (c-set-style c-file-style)) - (and c-file-offsets - (mapcar - (function - (lambda (langentry) - (let ((langelem (car langentry)) - (offset (cdr langentry))) - (c-set-offset langelem offset) - ))) - c-file-offsets))) - -(add-hook 'hack-local-variables-hook 'c-postprocess-file-styles) - - -;; Common routines -(defun c-make-inherited-keymap () - (let ((map (make-sparse-keymap))) - (cond - ;; XEmacs 19 & 20 - ((fboundp 'set-keymap-parents) - (set-keymap-parents map c-mode-base-map)) - ;; Emacs 19 - ((fboundp 'set-keymap-parent) - (set-keymap-parent map c-mode-base-map)) - ;; incompatible - (t (error "CC Mode is incompatible with this version of Emacs"))) - map)) - -(defun c-populate-syntax-table (table) - ;; Populate the syntax TABLE - ;; DO NOT TRY TO SET _ (UNDERSCORE) TO WORD CLASS! - (modify-syntax-entry ?_ "_" table) - (modify-syntax-entry ?\\ "\\" table) - (modify-syntax-entry ?+ "." table) - (modify-syntax-entry ?- "." table) - (modify-syntax-entry ?= "." table) - (modify-syntax-entry ?% "." table) - (modify-syntax-entry ?< "." table) - (modify-syntax-entry ?> "." table) - (modify-syntax-entry ?& "." table) - (modify-syntax-entry ?| "." table) - (modify-syntax-entry ?\' "\"" table) - ;; Set up block and line oriented comments. The new C standard - ;; mandates both comment styles even in C, so since all languages - ;; now require dual comments, we make this the default. - (cond - ;; XEmacs 19 & 20 - ((memq '8-bit c-emacs-features) - (modify-syntax-entry ?/ ". 1456" table) - (modify-syntax-entry ?* ". 23" table)) - ;; Emacs 19 & 20 - ((memq '1-bit c-emacs-features) - (modify-syntax-entry ?/ ". 124b" table) - (modify-syntax-entry ?* ". 23" table)) - ;; incompatible - (t (error "CC Mode is incompatible with this version of Emacs")) - ) - (modify-syntax-entry ?\n "> b" table) - ;; Give CR the same syntax as newline, for selective-display - (modify-syntax-entry ?\^m "> b" table)) - - -(defvar c-mode-base-map () - "Keymap shared by all CC Mode related modes.") - -(if c-mode-base-map - nil - ;; TBD: should we even worry about naming this keymap. My vote: no, - ;; because Emacs and XEmacs do it differently. - (setq c-mode-base-map (make-sparse-keymap)) - ;; put standard keybindings into MAP - ;; the following mappings correspond more or less directly to BOCM - (define-key c-mode-base-map "{" 'c-electric-brace) - (define-key c-mode-base-map "}" 'c-electric-brace) - (define-key c-mode-base-map ";" 'c-electric-semi&comma) - (define-key c-mode-base-map "#" 'c-electric-pound) - (define-key c-mode-base-map ":" 'c-electric-colon) - ;; Lucid Emacs 19.9 defined these two, the second of which was - ;; commented out... - ;; (define-key c-mode-base-map "\e{" 'c-insert-braces) - ;; Commented out electric square brackets because nobody likes them. - ;; (define-key c-mode-base-map "[" 'c-insert-brackets) - (define-key c-mode-base-map "\C-c\C-m" 'c-mark-function) - (define-key c-mode-base-map "\e\C-q" 'c-indent-exp) - (define-key c-mode-base-map "\ea" 'c-beginning-of-statement) - (define-key c-mode-base-map "\ee" 'c-end-of-statement) - (define-key c-mode-base-map "\C-c\C-n" 'c-forward-conditional) - (define-key c-mode-base-map "\C-c\C-p" 'c-backward-conditional) - (define-key c-mode-base-map "\C-c\C-u" 'c-up-conditional) - (define-key c-mode-base-map "\t" 'c-indent-command) - ;; Caution! Enter here at your own risk. We are trying to support - ;; several behaviors and it gets disgusting. :-( - ;; - ;; In XEmacs 19, Emacs 19, and Emacs 20, we use this to bind - ;; backwards deletion behavior to DEL, which both Delete and - ;; Backspace get translated to. There's no way to separate this - ;; behavior in a clean way, so deal with it! Besides, it's been - ;; this way since the dawn of BOCM. - (if (not (boundp 'delete-key-deletes-forward)) - (define-key c-mode-base-map "\177" 'c-electric-backspace) - ;; However, XEmacs 20 actually achieved enlightenment. It is - ;; possible to sanely define both backward and forward deletion - ;; behavior under X separately (TTYs are forever beyond hope, but - ;; who cares? XEmacs 20 does the right thing with these too). - (define-key c-mode-base-map [delete] 'c-electric-delete) - (define-key c-mode-base-map [backspace] 'c-electric-backspace)) - ;; these are new keybindings, with no counterpart to BOCM - (define-key c-mode-base-map "," 'c-electric-semi&comma) - (define-key c-mode-base-map "*" 'c-electric-star) - (define-key c-mode-base-map "/" 'c-electric-slash) - (define-key c-mode-base-map "\C-c\C-q" 'c-indent-defun) - (define-key c-mode-base-map "\C-c\C-\\" 'c-backslash-region) - ;; TBD: where if anywhere, to put c-backward|forward-into-nomenclature - (define-key c-mode-base-map "\C-c\C-a" 'c-toggle-auto-state) - (define-key c-mode-base-map "\C-c\C-b" 'c-submit-bug-report) - (define-key c-mode-base-map "\C-c\C-c" 'comment-region) - (define-key c-mode-base-map "\C-c\C-d" 'c-toggle-hungry-state) - (define-key c-mode-base-map "\C-c\C-o" 'c-set-offset) - (define-key c-mode-base-map "\C-c\C-s" 'c-show-syntactic-information) - (define-key c-mode-base-map "\C-c\C-t" 'c-toggle-auto-hungry-state) - (define-key c-mode-base-map "\C-c." 'c-set-style) - ;; conflicts with OOBR - ;;(define-key c-mode-base-map "\C-c\C-v" 'c-version) - ) - -;; menu support for both XEmacs and Emacs. If you don't have easymenu -;; with your version of Emacs, you are incompatible! -(require 'easymenu) - -(defvar c-c-menu nil) -(defvar c-c++-menu nil) -(defvar c-objc-menu nil) -(defvar c-java-menu nil) - -(defun c-mode-menu (modestr) - (let ((m - '(["Comment Out Region" comment-region (mark)] - ["Uncomment Region" - (comment-region (region-beginning) (region-end) '(4)) - (mark)] - ["Fill Comment Paragraph" c-fill-paragraph t] - "---" - ["Indent Expression" c-indent-exp - (memq (char-after) '(?\( ?\[ ?\{))] - ["Indent Line" c-indent-command t] - ["Up Conditional" c-up-conditional t] - ["Backward Conditional" c-backward-conditional t] - ["Forward Conditional" c-forward-conditional t] - ["Backward Statement" c-beginning-of-statement t] - ["Forward Statement" c-end-of-statement t] - "---" - ["Macro Expand Region" c-macro-expand (mark)] - ["Backslashify" c-backslash-region (mark)] - ))) - (cons modestr m))) - - - -;; Support for C - -(defvar c-mode-abbrev-table nil - "Abbreviation table used in c-mode buffers.") -(define-abbrev-table 'c-mode-abbrev-table ()) - -(defvar c-mode-map () - "Keymap used in c-mode buffers.") -(if c-mode-map - nil - (setq c-mode-map (c-make-inherited-keymap)) - ;; add bindings which are only useful for C - (define-key c-mode-map "\C-c\C-e" 'c-macro-expand) - ) - -;;;###autoload -(defvar c-mode-syntax-table nil - "Syntax table used in c-mode buffers.") -(if c-mode-syntax-table - () - (setq c-mode-syntax-table (make-syntax-table)) - (c-populate-syntax-table c-mode-syntax-table)) - -(easy-menu-define c-c-menu c-mode-map "C Mode Commands" - (c-mode-menu "C")) - - -;; Support for C++ - -(defvar c++-mode-abbrev-table nil - "Abbreviation table used in c++-mode buffers.") -(define-abbrev-table 'c++-mode-abbrev-table ()) - -(defvar c++-mode-map () - "Keymap used in c++-mode buffers.") -(if c++-mode-map - nil - (setq c++-mode-map (c-make-inherited-keymap)) - ;; add bindings which are only useful for C++ - (define-key c++-mode-map "\C-c\C-e" 'c-macro-expand) - (define-key c++-mode-map "\C-c:" 'c-scope-operator) - (define-key c++-mode-map "<" 'c-electric-lt-gt) - (define-key c++-mode-map ">" 'c-electric-lt-gt)) - -;;;###autoload -(defvar c++-mode-syntax-table nil - "Syntax table used in c++-mode buffers.") -(if c++-mode-syntax-table - () - (setq c++-mode-syntax-table (make-syntax-table)) - (c-populate-syntax-table c++-mode-syntax-table) - ;; TBD: does it make sense for colon to be symbol class in C++? - ;; I'm not so sure, since c-label-key is busted on lines like: - ;; Foo::bar( i ); - ;; maybe c-label-key should be fixed instead of commenting this out, - ;; but it also bothers me that this only seems appropriate for C++ - ;; and not C. - ;;(modify-syntax-entry ?: "_" c++-mode-syntax-table) - ) - -(easy-menu-define c-c++-menu c++-mode-map "C++ Mode Commands" - (c-mode-menu "C++")) - - -;; Support for Objective-C - -(defvar objc-mode-abbrev-table nil - "Abbreviation table used in objc-mode buffers.") -(define-abbrev-table 'objc-mode-abbrev-table ()) - -(defvar objc-mode-map () - "Keymap used in objc-mode buffers.") -(if objc-mode-map - nil - (setq objc-mode-map (c-make-inherited-keymap)) - ;; add bindings which are only useful for Objective-C - (define-key objc-mode-map "\C-c\C-e" 'c-macro-expand)) - -;;;###autoload -(defvar objc-mode-syntax-table nil - "Syntax table used in objc-mode buffers.") -(if objc-mode-syntax-table - () - (setq objc-mode-syntax-table (make-syntax-table)) - (c-populate-syntax-table objc-mode-syntax-table) - ;; add extra Objective-C only syntax - (modify-syntax-entry ?@ "_" objc-mode-syntax-table)) - -(easy-menu-define c-objc-menu objc-mode-map "ObjC Mode Commands" - (c-mode-menu "ObjC")) - - -;; Support for Java - -(defvar java-mode-abbrev-table nil - "Abbreviation table used in java-mode buffers.") -(define-abbrev-table 'java-mode-abbrev-table ()) - -(defvar java-mode-map () - "Keymap used in java-mode buffers.") -(if java-mode-map - nil - (setq java-mode-map (c-make-inherited-keymap)) - ;; add bindings which are only useful for Java - ) - -;;;###autoload -(defvar java-mode-syntax-table nil - "Syntax table used in java-mode buffers.") -(if java-mode-syntax-table - () - (setq java-mode-syntax-table (make-syntax-table)) - (c-populate-syntax-table java-mode-syntax-table)) - -(easy-menu-define c-java-menu java-mode-map "Java Mode Commands" - (c-mode-menu "Java")) - - -;; Support for CORBA's IDL language - -(defvar idl-mode-abbrev-table nil - "Abbreviation table used in idl-mode buffers.") -(define-abbrev-table 'idl-mode-abbrev-table ()) - -(defvar idl-mode-map () - "Keymap used in idl-mode buffers.") -(if idl-mode-map - nil - (setq idl-mode-map (c-make-inherited-keymap)) - ;; add bindings which are only useful for IDL - ) - -;;;###autoload -(defvar idl-mode-syntax-table nil - "Syntax table used in idl-mode buffers.") -(if idl-mode-syntax-table - nil - (setq idl-mode-syntax-table (make-syntax-table)) - (c-populate-syntax-table idl-mode-syntax-table)) - -(easy-menu-define c-idl-menu idl-mode-map "IDL Mode Commands" - (c-mode-menu "IDL")) - - - -(provide 'cc-langs) -;;; cc-langs.el ends here
--- a/lisp/cc-mode/cc-menus.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,364 +0,0 @@ -;;; cc-menus.el --- imenu support for CC Mode - -;; Copyright (C) 1985,87,92,93,94,95,96,97 Free Software Foundation, Inc. - -;; Authors: 1992-1997 Barry A. Warsaw -;; 1987 Dave Detlefs and Stewart Clamen -;; 1985 Richard M. Stallman -;; Maintainer: cc-mode-help@python.org -;; Created: 22-Apr-1997 (split from cc-mode.el) -;; Version: See cc-mode.el -;; Keywords: c languages oop - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - - -;; imenu integration -(defvar cc-imenu-c-prototype-macro-regexp nil - "RE matching macro names used to conditionally specify function prototypes. - -For example: - - #ifdef __STDC__ - #define _P(x) x - #else - #define _P(x) /*nothing*/ - #endif - - int main _P( (int argc, char *argv[]) ) - -A sample value might look like: `\\(_P\\|_PROTO\\)'.") - -(defvar cc-imenu-c++-generic-expression - (` - ( - ;; Try to match ::operator definitions first. Otherwise `X::operator new ()' - ;; will be incorrectly recognised as function `new ()' because the regexps - ;; work by backtracking from the end of the definition. - (nil - (, - (concat - "^\\<.*" - "[^a-zA-Z0-9_:<>~]" ; match any non-identifier char - ; (note: this can be `\n') - "\\(" - "\\([a-zA-Z0-9_:<>~]*::\\)?" ; match an operator - "operator\\>[ \t]*" - "\\(()\\|[^(]*\\)" ; special case for `()' operator - "\\)" - - "[ \t]*([^)]*)[ \t]*[^ \t;]" ; followed by ws, arg list, - ; require something other than - ; a `;' after the (...) to - ; avoid prototypes. Can't - ; catch cases with () inside - ; the parentheses surrounding - ; the parameters. e.g.: - ; `int foo(int a=bar()) {...}' - )) 1) - ;; Special case to match a line like `main() {}' - ;; e.g. no return type, not even on the previous line. - (nil - (, - (concat - "^" - "\\([a-zA-Z_][a-zA-Z0-9_:<>~]*\\)" ; match function name - "[ \t]*([^)]*)[ \t]*[^ \t;]" ; see above - )) 1) - ;; General function name regexp - (nil - (, - (concat - "^\\<.*" ; line MUST start with word char - "[^a-zA-Z0-9_:<>~]" ; match any non-identifier char - "\\([a-zA-Z_][a-zA-Z0-9_:<>~]*\\)" ; match function name - "[ \t]*(" ; see above, BUT - "[ \t]*[^ \t(][^)]*)[ \t]*[^ \t;]" ; the argument list must not start - ; with a parentheses - )) 1) - ;; Special case for definitions using phony prototype macros like: - ;; `int main _PROTO( (int argc,char *argv[]) )'. - ;; This case is only included if cc-imenu-c-prototype-macro-regexp is set. - ;; Only supported in c-code, so no `:<>~' chars in function name! - (,@ (if cc-imenu-c-prototype-macro-regexp - (` ((nil - (, - (concat - "^\\<.*" ; line MUST start with word char - "[^a-zA-Z0-9_]" ; match any non-identifier char - "\\([a-zA-Z_][a-zA-Z0-9_]*\\)" ; match function name - "[ \t]*" ; whitespace before macro name - cc-imenu-c-prototype-macro-regexp - "[ \t]*(" ; ws followed by first paren. - "[ \t]*([^)]*)[ \t]*)[ \t]*[^ \t;]" ; see above - )) 1))))) - ;; Class definitions - ("Class" - (, (concat - "^" ; beginning of line is required - "\\(template[ \t]*<[^>]+>[ \t]*\\)?" ; there may be a `template <...>' - "class[ \t]+" - "\\([a-zA-Z0-9_]+\\)" ; the string we want to get - "[ \t]*[:{]" - )) 2))) - "Imenu generic expression for C++ mode. See `imenu-generic-expression'.") - -(defvar cc-imenu-c-generic-expression - cc-imenu-c++-generic-expression - "Imenu generic expression for C mode. See `imenu-generic-expression'.") - -(defvar cc-imenu-java-generic-expression - (` - ((nil - (, - (concat - "^\\([ \t]\\)*" - "\\([A-Za-z0-9_-]+[ \t]+\\)?" ; type specs; there can be - "\\([A-Za-z0-9_-]+[ \t]+\\)?" ; more than 3 tokens, right? - "\\([A-Za-z0-9_-]+[ \t]*[[]?[]]?\\)" - "\\([ \t]\\)" - "\\([A-Za-z0-9_-]+\\)" ; the string we want to get - "\\([ \t]*\\)+(" - "\\([a-zA-Z,_1-9\n \t]*[[]?[]]?\\)*" ; arguments - ")[ \t]*" -; "[^;(]" - "[,a-zA-Z_1-9\n \t]*{" - )) 6))) - "Imenu generic expression for Java mode. See `imenu-generic-expression'.") - -(defvar cc-imenu-objc-generic-expression - (concat - ;; - ;; For C - ;; *Warning for developers* - ;; This expression elements depend on `cc-imenu-c++-generic-expression'. - ;; - ;; > Special case to match a line like `main() {}' - ;; > e.g. no return type, not even on the previous line. - ;; Pick a token by (match-string 1) - (car (cdr (nth 1 cc-imenu-c++-generic-expression))) ; - "\\|" - ;; > General function name regexp - ;; Pick a token by (match-string 2) - (car (cdr (nth 2 cc-imenu-c++-generic-expression))) - ;; > Special case for definitions using phony prototype macros like: - ;; > `int main _PROTO( (int argc,char *argv[]) )'. - ;; Pick a token by (match-string 3) - (if cc-imenu-c-prototype-macro-regexp - (concat - "\\|" - (car (cdr (nth 3 cc-imenu-c++-generic-expression)))) - "") - ;; - ;; For Objective-C - ;; Pick a token by (match-string 3 or 4) - ;; - "\\|\\(" - "^[-+][:a-zA-Z0-9()*_<>\n\t ]*[;{]" ; Methods - "\\|" - "^@interface[\t ]+[a-zA-Z0-9_]+[\t ]*:" - "\\|" - "^@interface[\t ]+[a-zA-Z0-9_]+[\t ]*([a-zA-Z0-9_]+)" - "\\|" - ;; For NSObject, NSProxy and Object... They don't have super class. - "^@interface[\t ]+[a-zA-Z0-9_]+[\t ]*.*$" - "\\|" - "^@implementation[\t ]+[a-zA-Z0-9_]+[\t ]*([a-zA-Z0-9_]+)" - "\\|" - "^@implementation[\t ]+[a-zA-Z0-9_]+" - "\\|" - "^@protocol[\t ]+[a-zA-Z0-9_]+" "\\)") - "Imenu generic expression for ObjC mode. See `imenu-generic-expression'.") - - -;; Imenu support for objective-c uses functions. -(defsubst cc-imenu-objc-method-to-selector (method) - "Return the objc selector style string of METHOD. -Example: -- perform: (SEL)aSelector withObject: object1 withObject: object2; /* METHOD */ -=> --perform:withObject:withObject:withObject: /* selector */" - (let ((return "") ; String to be returned - (p 0) ; Current scanning position in METHOD - (pmax (length method)) ; - char ; Current scanning target - (betweenparen 0) ; CHAR is in parentheses. - argreq ; An argument is required. - inargvar) ; position of CHAR is in an argument variable. - (while (< p pmax) - (setq char (aref method p) - p (1+ p)) - (cond - ;; Is CHAR part of a objc token? - ((and (not inargvar) ; Ignore if CHAR is part of an argument variable. - (eq 0 betweenparen) ; Ignore if CHAR is in parentheses. - (or (and (<= ?a char) (<= char ?z)) - (and (<= ?A char) (<= char ?Z)) - (and (<= ?0 char) (<= char ?9)) - (= ?_ char))) - (if argreq - (setq inargvar t - argreq nil) - (setq return (concat return (char-to-string char))))) - ;; Or a white space? - ((and inargvar (or (eq ?\ char) (eq ?\n char)) - (setq inargvar nil))) - ;; Or a method separator? - ;; If a method separator, the next token will be an argument variable. - ((eq ?: char) - (setq argreq t - return (concat return (char-to-string char)))) - ;; Or an open parentheses? - ((eq ?\( char) - (setq betweenparen (1+ betweenparen))) - ;; Or a close parentheses? - ((eq ?\) char) - (setq betweenparen (1- betweenparen))))) - return)) - -(defun cc-imenu-objc-remove-white-space (str) - "Remove all spaces and tabs from STR." - (let ((return "") - (p 0) - (max (length str)) - char) - (while (< p max) - (setq char (aref str p)) - (setq p (1+ p)) - (if (or (= char ?\ ) (= char ?\t)) - () - (setq return (concat return (char-to-string char))))) - return)) - -(defun cc-imenu-objc-function () - "imenu supports for objc-mode." - (let (methodlist - clist - ;; - ;; OBJC, C1, C2, C3 are constants. - ;; - ;; *Warning for developers* - ;; These constants depend on `cc-imenu-c++-generic-expression'. - ;; - (OBJC - (if cc-imenu-c-prototype-macro-regexp 4 3)) - (C1 ; > Special case to match a line like `main() {}' - 1) - (C2 ; > General function name regexp - 2) - (C3 ; > Special case for definitions using phony prototype macros like: - 3) - langnum - ;; - (classcount 0) - toplist - stupid - str - str2 - (intflen (length "@interface")) - (implen (length "@implementation")) - (prtlen (length "@protocol")) - bufsubst-fun) - ;; - ;; Does this emacs has buffer-substring-no-properties? - ;; - (fset 'bufsubst-fun (if (fboundp 'buffer-substring-no-properties) - (symbol-function 'buffer-substring-no-properties) - (symbol-function 'buffer-substring))) - (goto-char (point-max)) - (imenu-progress-message stupid 0) - ;; - (while (re-search-backward cc-imenu-objc-generic-expression nil t) - (imenu-progress-message stupid) - (setq langnum (if (match-beginning OBJC) - OBJC - (cond - ((match-beginning C3) C3) - ((match-beginning C2) C2) - ((match-beginning C1) C1)))) - (setq str (bufsubst-fun (match-beginning langnum) (match-end langnum))) - ;; - (cond - ;; - ;; C - ;; - ((not (eq langnum OBJC)) - (setq clist (cons (cons str (match-beginning langnum)) clist))) - ;; - ;; ObjC - ;; - ;; An instance Method - ((eq (aref str 0) ?-) - (setq str (concat "-" (cc-imenu-objc-method-to-selector str))) - (setq methodlist (cons (cons str - (match-beginning langnum)) - methodlist))) - ;; A factory Method - ((eq (aref str 0) ?+) - (setq str (concat "+" (cc-imenu-objc-method-to-selector str))) - (setq methodlist (cons (cons str - (match-beginning langnum)) - methodlist))) - ;; Interface or implementation or protocol - ((eq (aref str 0) ?@) - (setq classcount (1+ classcount)) - (cond - ((and (> (length str) implen) - (string= (substring str 0 implen) "@implementation")) - (setq str (substring str implen) - str2 "@implementation")) - ((string= (substring str 0 intflen) "@interface") - (setq str (substring str intflen) - str2 "@interface")) - ((string= (substring str 0 prtlen) "@protocol") - (setq str (substring str prtlen) - str2 "@protocol"))) - (setq str (cc-imenu-objc-remove-white-space str)) - (setq methodlist (cons (cons str2 - (match-beginning langnum)) - methodlist)) - (setq toplist (cons nil (cons (cons str - methodlist) toplist)) - methodlist nil)))) - ;; - (imenu-progress-message stupid 100) - (if (eq (car toplist) nil) - (setq toplist (cdr toplist))) - - ;; In this buffer, there is only one or zero @{interface|implementation|protocol}. - (if (< classcount 2) - (let ((classname (car (car toplist))) - (p (cdr (car (cdr (car toplist))))) - last) - (setq toplist (cons (cons classname p) (cdr (cdr (car toplist))))) - ;; Add C lang token - (if clist - (progn - (setq last toplist) - (while (cdr last) - (setq last (cdr last))) - (setcdr last clist)))) - ;; Add C lang tokens as a sub menu - (setq toplist (cons (cons "C" clist) toplist))) - ;; - toplist - )) - - -(provide 'cc-menus) -;;; cc-menus.el ends here
--- a/lisp/cc-mode/cc-mode.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,412 +0,0 @@ -;;; cc-mode.el --- major mode for editing C, C++, Objective-C, and Java code - -;; Copyright (C) 1985,87,92,93,94,95,96,97 Free Software Foundation, Inc. - -;; Authors: 1992-1997 Barry A. Warsaw -;; 1987 Dave Detlefs and Stewart Clamen -;; 1985 Richard M. Stallman -;; Maintainer: cc-mode-help@python.org -;; Created: a long, long, time ago. adapted from the original c-mode.el -;; Keywords: c languages oop - -(defconst c-version "5.19" - "CC Mode version number.") - -;; NOTE: Read the commentary below for the right way to submit bug reports! -;; NOTE: See the accompanying texinfo manual for details on using this mode! - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This package provides GNU Emacs major modes for editing C, C++, -;; Objective-C, Java and IDL code. As of the latest Emacs and XEmacs -;; releases, it is the default package for editing these languages. -;; This package is called "CC Mode", and should be spelled exactly -;; this way. It supports K&R and ANSI C, ANSI C++, Objective-C, Java, -;; and CORBA's IDL with a consistent indentation model across all -;; modes. This indentation model is intuitive and very flexible, so -;; that almost any desired style of indentation can be supported. -;; Installation, usage, and programming details are contained in an -;; accompanying texinfo manual. - -;; CC Mode's immediate ancestors were, c++-mode.el, cplus-md.el, and -;; cplus-md1.el.. - -;; NOTE: This mode does not perform font-locking (a.k.a syntactic -;; coloring, keyword highlighting, etc.) for any of the supported -;; modes. Typically this is done by a package called font-lock.el -;; which I do *not* maintain. You should contact the Emacs -;; maintainers for questions about coloring or highlighting in any -;; language mode. - -;; To submit bug reports, type "C-c C-b". These will be sent to -;; bug-gnu-emacs@prep.ai.mit.edu as well as cc-mode-help@python.org, -;; and I'll read about them there (the former is mirrored as the -;; Usenet newsgroup gnu.emacs.bug). Questions can sent to -;; help-gnu-emacs@prep.ai.mit.edu (mirrored as gnu.emacs.help) and/or -;; cc-mode-help@python.org. Please do not send bugs or questions to -;; my personal account. - -;; Many, many thanks go out to all the folks on the beta test list. -;; Without their patience, testing, insight, code contributions, and -;; encouragement CC Mode would be a far inferior package. - -;; You can get the latest version of CC Mode, including PostScript -;; documentation and separate individual files from: -;; -;; http://www.python.org/ftp/emacs/ - -;; Or if you don't have access to the World Wide Web, through -;; anonymous ftp from: -;; -;; ftp://ftp.python.org/pub/emacs - -;;; Code: - -(eval-when-compile - (require 'cc-menus)) -(require 'cc-defs) - -(defvar c-buffer-is-cc-mode nil - "Non-nil for all buffers with a `major-mode' derived from CC Mode. -Otherwise, this variable is nil. I.e. this variable is non-nil for -`c-mode', `c++-mode', `objc-mode', `java-mode', `idl-mode', and any -other non-CC Mode mode that calls `c-initialize-cc-mode' -\(e.g. `awk-mode').") -(make-variable-buffer-local 'c-buffer-is-cc-mode) -(put 'c-buffer-is-cc-mode 'permanent-local t) - - -;; Other modes and packages which depend on CC Mode should do the -;; following to make sure everything is loaded and available for their -;; use: -;; -;; (require 'cc-mode) -;; (c-initialize-cc-mode) - -;;;###autoload -(defun c-initialize-cc-mode () - (setq c-buffer-is-cc-mode t) - ;; sigh. give in to the pressure, but make really sure all the - ;; definitions we need are here - (if (or (not (fboundp 'functionp)) - (not (fboundp 'char-before)) - (not (c-safe (char-after) t))) - (require 'cc-mode-19)) - ;; make sure all necessary components of CC Mode are loaded in. - (let ((initprop 'cc-mode-is-initialized)) - (require 'cc-vars) - (require 'cc-engine) - (require 'cc-langs) - (require 'cc-menus) - (require 'cc-align) - (require 'cc-styles) - (require 'cc-cmds) - ;; run the initialization hook, but only once - (or (get 'c-initialize-cc-mode initprop) - (progn - (c-initialize-builtin-style) - (run-hooks 'c-initialization-hook) - (put 'c-initialize-cc-mode initprop t))) - )) - - -;;;###autoload -(defun c-mode () - "Major mode for editing K&R and ANSI C code. -To submit a problem report, enter `\\[c-submit-bug-report]' from a -c-mode buffer. This automatically sets up a mail buffer with version -information already added. You just need to add a description of the -problem, including a reproducible test case and send the message. - -To see what version of CC Mode you are running, enter `\\[c-version]'. - -The hook variable `c-mode-hook' is run with no args, if that value is -bound and has a non-nil value. Also the hook `c-mode-common-hook' is -run first. - -Key bindings: -\\{c-mode-map}" - (interactive) - (c-initialize-cc-mode) - (kill-all-local-variables) - (set-syntax-table c-mode-syntax-table) - (setq major-mode 'c-mode - mode-name "C" - local-abbrev-table c-mode-abbrev-table) - (use-local-map c-mode-map) - (c-common-init) - (setq comment-start "/* " - comment-end " */" - c-conditional-key c-C-conditional-key - c-class-key c-C-class-key - c-baseclass-key nil - c-comment-start-regexp c-C++-comment-start-regexp - imenu-generic-expression cc-imenu-c-generic-expression) - (run-hooks 'c-mode-common-hook) - (run-hooks 'c-mode-hook) - (c-update-modeline)) - - -;;;###autoload -(defun c++-mode () - "Major mode for editing C++ code. -To submit a problem report, enter `\\[c-submit-bug-report]' from a -c++-mode buffer. This automatically sets up a mail buffer with -version information already added. You just need to add a description -of the problem, including a reproducible test case, and send the -message. - -To see what version of CC Mode you are running, enter `\\[c-version]'. - -The hook variable `c++-mode-hook' is run with no args, if that -variable is bound and has a non-nil value. Also the hook -`c-mode-common-hook' is run first. - -Key bindings: -\\{c++-mode-map}" - (interactive) - (c-initialize-cc-mode) - (kill-all-local-variables) - (set-syntax-table c++-mode-syntax-table) - (setq major-mode 'c++-mode - mode-name "C++" - local-abbrev-table c++-mode-abbrev-table) - (use-local-map c++-mode-map) - (c-common-init) - (setq comment-start "// " - comment-end "" - c-conditional-key c-C++-conditional-key - c-comment-start-regexp c-C++-comment-start-regexp - c-class-key c-C++-class-key - c-access-key c-C++-access-key - c-recognize-knr-p nil - imenu-generic-expression cc-imenu-c++-generic-expression) - (run-hooks 'c-mode-common-hook) - (run-hooks 'c++-mode-hook) - (c-update-modeline)) - - -;;;###autoload -(defun objc-mode () - "Major mode for editing Objective C code. -To submit a problem report, enter `\\[c-submit-bug-report]' from an -objc-mode buffer. This automatically sets up a mail buffer with -version information already added. You just need to add a description -of the problem, including a reproducible test case, and send the -message. - -To see what version of CC Mode you are running, enter `\\[c-version]'. - -The hook variable `objc-mode-hook' is run with no args, if that value -is bound and has a non-nil value. Also the hook `c-mode-common-hook' -is run first. - -Key bindings: -\\{objc-mode-map}" - (interactive) - (c-initialize-cc-mode) - (kill-all-local-variables) - (set-syntax-table objc-mode-syntax-table) - (setq major-mode 'objc-mode - mode-name "ObjC" - local-abbrev-table objc-mode-abbrev-table) - (use-local-map objc-mode-map) - (c-common-init) - (setq comment-start "// " - comment-end "" - c-conditional-key c-C-conditional-key - c-comment-start-regexp c-C++-comment-start-regexp - c-class-key c-ObjC-class-key - c-baseclass-key nil - c-access-key c-ObjC-access-key - c-method-key c-ObjC-method-key - imenu-create-index-function 'cc-imenu-objc-function) - (run-hooks 'c-mode-common-hook) - (run-hooks 'objc-mode-hook) - (c-update-modeline)) - - -;;;###autoload -(defun java-mode () - "Major mode for editing Java code. -To submit a problem report, enter `\\[c-submit-bug-report]' from a -java-mode buffer. This automatically sets up a mail buffer with -version information already added. You just need to add a description -of the problem, including a reproducible test case and send the -message. - -To see what version of CC Mode you are running, enter `\\[c-version]'. - -The hook variable `java-mode-hook' is run with no args, if that value -is bound and has a non-nil value. Also the common hook -`c-mode-common-hook' is run first. Note that this mode automatically -sets the \"java\" style before calling any hooks so be careful if you -set styles in `c-mode-common-hook'. - -Key bindings: -\\{java-mode-map}" - (interactive) - (c-initialize-cc-mode) - (kill-all-local-variables) - (set-syntax-table java-mode-syntax-table) - (setq major-mode 'java-mode - mode-name "Java" - local-abbrev-table java-mode-abbrev-table) - (use-local-map java-mode-map) - (c-common-init) - (setq comment-start "// " - comment-end "" - c-conditional-key c-Java-conditional-key - c-comment-start-regexp c-Java-comment-start-regexp - c-class-key c-Java-class-key - c-method-key c-Java-method-key - c-baseclass-key nil - c-recognize-knr-p nil - c-access-key c-Java-access-key - ;defun-prompt-regexp c-Java-defun-prompt-regexp - imenu-generic-expression cc-imenu-java-generic-expression - ) - (c-set-style "java") - (run-hooks 'c-mode-common-hook) - (run-hooks 'java-mode-hook) - (c-update-modeline)) - - -;;;###autoload -(defun idl-mode () - "Major mode for editing CORBA's IDL code. -To submit a problem report, enter `\\[c-submit-bug-report]' from a -idl-mode buffer. This automatically sets up a mail buffer with -version information already added. You just need to add a description -of the problem, including a reproducible test case, and send the -message. - -To see what version of CC Mode you are running, enter `\\[c-version]'. - -The hook variable `idl-mode-hook' is run with no args, if that -variable is bound and has a non-nil value. Also the hook -`c-mode-common-hook' is run first. - -Key bindings: -\\{idl-mode-map}" - (interactive) - (c-initialize-cc-mode) - (kill-all-local-variables) - (set-syntax-table idl-mode-syntax-table) - (setq major-mode 'idl-mode - mode-name "IDL" - local-abbrev-table idl-mode-abbrev-table) - (use-local-map idl-mode-map) - (c-common-init) - (setq comment-start "// " - comment-end "" - c-conditional-key c-C++-conditional-key - c-comment-start-regexp c-C++-comment-start-regexp - c-class-key c-C++-class-key - c-access-key c-C++-access-key - c-recognize-knr-p nil) -;; imenu-generic-expression cc-imenu-c++-generic-expression) - (run-hooks 'c-mode-common-hook) - (run-hooks 'idl-mode-hook) - (c-update-modeline)) - - -;; bug reporting - -(defconst c-mode-help-address - "bug-gnu-emacs@prep.ai.mit.edu, cc-mode-help@python.org" - "Address for CC Mode bug reports.") - -(defun c-version () - "Echo the current version of CC Mode in the minibuffer." - (interactive) - (message "Using CC Mode version %s" c-version) - (c-keep-region-active)) - -;; Get reporter-submit-bug-report when byte-compiling -(eval-when-compile - (require 'reporter)) - -(defun c-submit-bug-report () - "Submit via mail a bug report on CC Mode." - (interactive) - (require 'cc-vars) - ;; load in reporter - (let ((reporter-prompt-for-summary-p t) - (reporter-dont-compact-list '(c-offsets-alist)) - (style c-indentation-style) - (hook c-special-indent-hook) - (c-features c-emacs-features)) - (and - (if (y-or-n-p "Do you want to submit a report on CC Mode? ") - t (message "") nil) - (require 'reporter) - (reporter-submit-bug-report - c-mode-help-address - (concat "CC Mode " c-version " (" - (cond ((eq major-mode 'c++-mode) "C++") - ((eq major-mode 'c-mode) "C") - ((eq major-mode 'objc-mode) "ObjC") - ((eq major-mode 'java-mode) "Java") - ) - ")") - (let ((vars (list - ;; report only the vars that affect indentation - 'c-basic-offset - 'c-offsets-alist - 'c-cleanup-list - 'c-comment-only-line-offset - 'c-backslash-column - 'c-delete-function - 'c-electric-pound-behavior - 'c-hanging-braces-alist - 'c-hanging-colons-alist - 'c-hanging-comment-starter-p - 'c-hanging-comment-ender-p - 'c-indent-comments-syntactically-p - 'c-tab-always-indent - 'c-comment-continuation-stars - 'c-label-minimum-indentation - 'defun-prompt-regexp - 'tab-width - ))) - (if (not (boundp 'defun-prompt-regexp)) - (delq 'defun-prompt-regexp vars) - vars)) - (function - (lambda () - (insert - "Buffer Style: " style "\n\n" - (if hook - (concat "\n@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n" - "c-special-indent-hook is set to '" - (format "%s" hook) - ".\nPerhaps this is your problem?\n" - "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n\n") - "\n") - (format "c-emacs-features: %s\n" c-features) - ))) - nil - "Dear Barry," - )))) - - -(provide 'cc-mode) -;;; cc-mode.el ends here
--- a/lisp/cc-mode/cc-styles.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,645 +0,0 @@ -;;; cc-styles.el --- support for styles in CC Mode - -;; Copyright (C) 1985,87,92,93,94,95,96,97 Free Software Foundation, Inc. - -;; Authors: 1992-1997 Barry A. Warsaw -;; 1987 Dave Detlefs and Stewart Clamen -;; 1985 Richard M. Stallman -;; Maintainer: cc-mode-help@python.org -;; Created: 22-Apr-1997 (split from cc-mode.el) -;; Version: See cc-mode.el -;; Keywords: c languages oop - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - - - -(defconst c-style-alist - '(("gnu" - (c-basic-offset . 2) - (c-comment-only-line-offset . (0 . 0)) - (c-offsets-alist . ((statement-block-intro . +) - (knr-argdecl-intro . 5) - (substatement-open . +) - (label . 0) - (statement-case-open . +) - (statement-cont . +) - (arglist-intro . c-lineup-arglist-intro-after-paren) - (arglist-close . c-lineup-arglist) - )) - (c-special-indent-hook . c-gnu-impose-minimum) - (c-comment-continuation-stars . "") - (c-hanging-comment-ender-p . t) - ) - ("k&r" - (c-basic-offset . 5) - (c-comment-only-line-offset . 0) - (c-offsets-alist . ((statement-block-intro . +) - (knr-argdecl-intro . 0) - (substatement-open . 0) - (label . 0) - (statement-cont . +) - )) - ) - ("bsd" - (c-basic-offset . 4) - (c-comment-only-line-offset . 0) - (c-offsets-alist . ((statement-block-intro . +) - (knr-argdecl-intro . +) - (substatement-open . 0) - (label . 0) - (statement-cont . +) - )) - ) - ("stroustrup" - (c-basic-offset . 4) - (c-comment-only-line-offset . 0) - (c-offsets-alist . ((statement-block-intro . +) - (substatement-open . 0) - (label . 0) - (statement-cont . +) - )) - ) - ("whitesmith" - (c-basic-offset . 4) - (c-comment-only-line-offset . 0) - (c-offsets-alist . ((statement-block-intro . +) - (knr-argdecl-intro . +) - (substatement-open . 0) - (label . 0) - (statement-cont . +) - )) - - ) - ("ellemtel" - (c-basic-offset . 3) - (c-comment-only-line-offset . 0) - (c-hanging-braces-alist . ((substatement-open before after))) - (c-offsets-alist . ((topmost-intro . 0) - (topmost-intro-cont . 0) - (substatement . +) - (substatement-open . 0) - (case-label . +) - (access-label . -) - (inclass . ++) - (inline-open . 0) - )) - ) - ("linux" - (c-basic-offset . 8) - (c-comment-only-line-offset . 0) - (c-hanging-braces-alist . ((brace-list-open) - (substatement-open after) - (block-close . c-snug-do-while))) - (c-cleanup-list . (brace-else-brace)) - (c-offsets-alist . ((statement-block-intro . +) - (knr-argdecl-intro . 0) - (substatement-open . 0) - (label . 0) - (statement-cont . +) - )) - ) - ("python" - (indent-tabs-mode . t) - (fill-column . 72) - (c-basic-offset . 8) - (c-offsets-alist . ((substatement-open . 0) - (inextern-lang . 0) - (arglist-intro . +) - (knr-argdecl-intro . +) - )) - (c-hanging-braces-alist . ((brace-list-open) - (brace-list-intro) - (brace-list-close) - (substatement-open after) - (block-close . c-snug-do-while) - )) - (c-comment-continuation-stars . "") - (c-hanging-comment-ender-p . nil) - (fill-column . 78) - ) - ("java" - (c-basic-offset . 2) - (c-comment-only-line-offset . (0 . 0)) - ;; the following preserves Javadoc starter lines - (c-hanging-comment-starter-p . nil) - (c-offsets-alist . ((topmost-intro-cont . +) - (statement-block-intro . +) - (knr-argdecl-intro . 5) - (substatement-open . +) - (label . 0) - (statement-case-open . +) - (statement-cont . +) - (arglist-intro . c-lineup-arglist-intro-after-paren) - (arglist-close . c-lineup-arglist) - (access-label . 0) - (inher-cont . c-lineup-java-inher) - (func-decl-cont . c-lineup-java-throws) - )) - - ) - ) - "Styles of indentation. -Elements of this alist are of the form: - - (STYLE-STRING [BASE-STYLE] (VARIABLE . VALUE) [(VARIABLE . VALUE) ...]) - -where STYLE-STRING is a short descriptive string used to select a -style, VARIABLE is any Emacs variable, and VALUE is the intended value -for that variable when using the selected style. - -Optional BASE-STYLE if present, is a string and must follow -STYLE-STRING. BASE-STYLE names a style that this style inherits from. -By default, all styles inherit from the \"cc-mode\" style, which is -computed at run time. Style loops generate errors. - -Two variables are treated specially. When VARIABLE is -`c-offsets-alist', the VALUE is a list containing elements of the -form: - - (SYNTACTIC-SYMBOL . OFFSET) - -as described in `c-offsets-alist'. These are passed directly to -`c-set-offset' so there is no need to set every syntactic symbol in -your style, only those that are different from the default. - -When VARIABLE is `c-special-indent-hook', its VALUE is added to -`c-special-indent-hook' using `add-hook'. If VALUE is a list, each -element of the list is added with `add-hook'. - -Do not change this variable directly. Use the function `c-add-style' -to add new styles or modify existing styles (it is not a good idea to -modify existing styles -- you should create a new style that inherits -the existing style.") - - -;; Functions that manipulate styles -(defun c-set-style-1 (conscell) - ;; Set the style for one variable - (let ((attr (car conscell)) - (val (cdr conscell))) - (cond - ;; first special variable - ((eq attr 'c-offsets-alist) - (mapcar - (function - (lambda (langentry) - (let ((langelem (car langentry)) - (offset (cdr langentry))) - (c-set-offset langelem offset) - ))) - val)) - ;; second special variable - ((eq attr 'c-special-indent-hook) - (if (listp val) - (while val - (add-hook 'c-special-indent-hook (car val)) - (setq val (cdr val))) - (add-hook 'c-special-indent-hook val))) - ;; all other variables - (t (set attr val))) - )) - -(defun c-set-style-2 (style basestyles) - ;; Recursively set the base style. If no base style is given, the - ;; default base style is "cc-mode" and the recursion stops. Be sure - ;; to detect loops. - (let ((vars (cdr (or (assoc (downcase style) c-style-alist) - (assoc (upcase style) c-style-alist) - (assoc style c-style-alist) - (error "Undefined style: %s" style))))) - (if (not (string-equal style "cc-mode")) - (let ((base (if (stringp (car vars)) - (prog1 - (downcase (car vars)) - (setq vars (cdr vars))) - "cc-mode"))) - (if (memq base basestyles) - (error "Style loop detected: %s in %s" base basestyles)) - (c-set-style-2 base (cons base basestyles)))) - (mapcar 'c-set-style-1 vars))) - -(defvar c-set-style-history nil) - -;;;###autoload -(defun c-set-style (stylename) - "Set CC Mode variables to use one of several different indentation styles. -STYLENAME is a string representing the desired style from the list of -styles described in the variable `c-style-alist'. See that variable -for details of setting up styles. - -The variable `c-indentation-style' always contains the buffer's current -style name." - (interactive (list (let ((completion-ignore-case t) - (prompt (format "Which %s indentation style? " - mode-name))) - (completing-read prompt c-style-alist nil t - (cons c-indentation-style 0) - 'c-set-style-history)))) - (c-initialize-builtin-style) - (c-set-style-2 stylename nil) - (setq c-indentation-style stylename) - (c-keep-region-active)) - -;;;###autoload -(defun c-add-style (style descrip &optional set-p) - "Adds a style to `c-style-alist', or updates an existing one. -STYLE is a string identifying the style to add or update. DESCRIP is -an association list describing the style and must be of the form: - - ([BASESTYLE] (VARIABLE . VALUE) [(VARIABLE . VALUE) ...]) - -See the variable `c-style-alist' for the semantics of BASESTYLE, -VARIABLE and VALUE. This function also sets the current style to -STYLE using `c-set-style' if the optional SET-P flag is non-nil." - (interactive - (let ((stylename (completing-read "Style to add: " c-style-alist - nil nil nil 'c-set-style-history)) - (description (eval-minibuffer "Style description: "))) - (list stylename description - (y-or-n-p "Set the style too? ")))) - (setq style (downcase style)) - (let ((s (assoc style c-style-alist))) - (if s - (setcdr s (copy-alist descrip)) ; replace - (setq c-style-alist (cons (cons style descrip) c-style-alist)))) - (and set-p (c-set-style style))) - - - -(defconst c-offsets-alist - '((string . -1000) - (c . c-lineup-C-comments) - (defun-open . 0) - (defun-close . 0) - (defun-block-intro . +) - (class-open . 0) - (class-close . 0) - (inline-open . +) - (inline-close . 0) - (func-decl-cont . +) - (knr-argdecl-intro . +) - (knr-argdecl . 0) - (topmost-intro . 0) - (topmost-intro-cont . 0) - (member-init-intro . +) - (member-init-cont . 0) - (inher-intro . +) - (inher-cont . c-lineup-multi-inher) - (block-open . 0) - (block-close . 0) - (brace-list-open . 0) - (brace-list-close . 0) - (brace-list-intro . +) - (brace-list-entry . 0) - (statement . 0) - ;; some people might prefer - ;;(statement . c-lineup-runin-statements) - (statement-cont . +) - ;; some people might prefer - ;;(statement-cont . c-lineup-math) - (statement-block-intro . +) - (statement-case-intro . +) - (statement-case-open . 0) - (substatement . +) - (substatement-open . +) - (case-label . 0) - (access-label . -) - (label . 2) - (do-while-closure . 0) - (else-clause . 0) - (comment-intro . c-lineup-comment) - (arglist-intro . +) - (arglist-cont . 0) - (arglist-cont-nonempty . c-lineup-arglist) - (arglist-close . +) - (stream-op . c-lineup-streamop) - (inclass . +) - (cpp-macro . -1000) - (friend . 0) - (objc-method-intro . -1000) - (objc-method-args-cont . c-lineup-ObjC-method-args) - (objc-method-call-cont . c-lineup-ObjC-method-call) - (extern-lang-open . 0) - (extern-lang-close . 0) - (inextern-lang . +) - (template-args-cont . +) - ) - "Association list of syntactic element symbols and indentation offsets. -As described below, each cons cell in this list has the form: - - (SYNTACTIC-SYMBOL . OFFSET) - -When a line is indented, CC Mode first determines the syntactic -context of the line by generating a list of symbols called syntactic -elements. This list can contain more than one syntactic element and -the global variable `c-syntactic-context' contains the context list -for the line being indented. Each element in this list is actually a -cons cell of the syntactic symbol and a buffer position. This buffer -position is called the relative indent point for the line. Some -syntactic symbols may not have a relative indent point associated with -them. - -After the syntactic context list for a line is generated, CC Mode -calculates the absolute indentation for the line by looking at each -syntactic element in the list. First, it compares the syntactic -element against the SYNTACTIC-SYMBOL's in `c-offsets-alist'. When it -finds a match, it adds the OFFSET to the column of the relative indent -point. The sum of this calculation for each element in the syntactic -list is the absolute offset for line being indented. - -If the syntactic element does not match any in the `c-offsets-alist', -an error is generated if `c-strict-syntax-p' is non-nil, otherwise the -element is ignored. - -Actually, OFFSET can be an integer, a function, a variable, or one of -the following symbols: `+', `-', `++', `--', `*', or `/'. These -latter designate positive or negative multiples of `c-basic-offset', -respectively: 1, -1, 2, -2, 0.5, and -0.5. If OFFSET is a function, it -is called with a single argument containing the cons of the syntactic -element symbol and the relative indent point. The function should -return an integer offset. - -Here is the current list of valid syntactic element symbols: - - string -- inside multi-line string - c -- inside a multi-line C style block comment - defun-open -- brace that opens a function definition - defun-close -- brace that closes a function definition - defun-block-intro -- the first line in a top-level defun - class-open -- brace that opens a class definition - class-close -- brace that closes a class definition - inline-open -- brace that opens an in-class inline method - inline-close -- brace that closes an in-class inline method - func-decl-cont -- the region between a function definition's - argument list and the function opening brace - (excluding K&R argument declarations). In C, you - cannot put anything but whitespace and comments - between them; in C++ and Java, throws declarations - and other things can appear in this context. - knr-argdecl-intro -- first line of a K&R C argument declaration - knr-argdecl -- subsequent lines in a K&R C argument declaration - topmost-intro -- the first line in a topmost construct definition - topmost-intro-cont -- topmost definition continuation lines - member-init-intro -- first line in a member initialization list - member-init-cont -- subsequent member initialization list lines - inher-intro -- first line of a multiple inheritance list - inher-cont -- subsequent multiple inheritance lines - block-open -- statement block open brace - block-close -- statement block close brace - brace-list-open -- open brace of an enum or static array list - brace-list-close -- close brace of an enum or static array list - brace-list-intro -- first line in an enum or static array list - brace-list-entry -- subsequent lines in an enum or static array list - statement -- a C (or like) statement - statement-cont -- a continuation of a C (or like) statement - statement-block-intro -- the first line in a new statement block - statement-case-intro -- the first line in a case \"block\" - statement-case-open -- the first line in a case block starting with brace - substatement -- the first line after an if/while/for/do/else - substatement-open -- the brace that opens a substatement block - case-label -- a `case' or `default' label - access-label -- C++ private/protected/public access label - label -- any ordinary label - do-while-closure -- the `while' that ends a do/while construct - else-clause -- the `else' of an if/else construct - comment-intro -- a line containing only a comment introduction - arglist-intro -- the first line in an argument list - arglist-cont -- subsequent argument list lines when no - arguments follow on the same line as the - arglist opening paren - arglist-cont-nonempty -- subsequent argument list lines when at - least one argument follows on the same - line as the arglist opening paren - arglist-close -- the solo close paren of an argument list - stream-op -- lines continuing a stream operator construct - inclass -- the construct is nested inside a class definition - cpp-macro -- the start of a cpp macro - friend -- a C++ friend declaration - objc-method-intro -- the first line of an Objective-C method definition - objc-method-args-cont -- lines continuing an Objective-C method definition - objc-method-call-cont -- lines continuing an Objective-C method call - extern-lang-open -- brace that opens an external language block - extern-lang-close -- brace that closes an external language block - inextern-lang -- analogous to `inclass' syntactic symbol - template-args-cont -- C++ template argument list continuations -") - -(defun c-get-offset (langelem) - ;; Get offset from LANGELEM which is a cons cell of the form: - ;; (SYMBOL . RELPOS). The symbol is matched against - ;; c-offsets-alist and the offset found there is either returned, - ;; or added to the indentation at RELPOS. If RELPOS is nil, then - ;; the offset is simply returned. - (let* ((symbol (car langelem)) - (relpos (cdr langelem)) - (match (assq symbol c-offsets-alist)) - (offset (cdr-safe match))) - ;; offset can be a number, a function, a variable, or one of the - ;; symbols + or - - (cond - ((not match) - (if c-strict-syntax-p - (error "don't know how to indent a %s" symbol) - (setq offset 0 - relpos 0))) - ((eq offset '+) (setq offset c-basic-offset)) - ((eq offset '-) (setq offset (- c-basic-offset))) - ((eq offset '++) (setq offset (* 2 c-basic-offset))) - ((eq offset '--) (setq offset (* 2 (- c-basic-offset)))) - ((eq offset '*) (setq offset (/ c-basic-offset 2))) - ((eq offset '/) (setq offset (/ (- c-basic-offset) 2))) - ((functionp offset) (setq offset (funcall offset langelem))) - ((not (numberp offset)) (setq offset (symbol-value offset))) - ) - (+ (if (and relpos - (< relpos (c-point 'bol))) - (save-excursion - (goto-char relpos) - (current-column)) - 0) - offset))) - - -(defvar c-read-offset-history nil) - -(defun c-read-offset (langelem) - ;; read new offset value for LANGELEM from minibuffer. return a - ;; legal value only - (let* ((oldoff (cdr-safe (assq langelem c-offsets-alist))) - (defstr (format "(default %s): " oldoff)) - (errmsg (concat "Offset must be int, func, var, " - "or in [+,-,++,--,*,/] " - defstr)) - (prompt (concat "Offset " defstr)) - offset input interned raw) - (while (not offset) - (setq input (completing-read prompt obarray 'fboundp nil nil - 'c-read-offset-history) - offset (cond ((string-equal "" input) oldoff) ; default - ((string-equal "+" input) '+) - ((string-equal "-" input) '-) - ((string-equal "++" input) '++) - ((string-equal "--" input) '--) - ((string-equal "*" input) '*) - ((string-equal "/" input) '/) - ((string-match "^-?[0-9]+$" input) - (string-to-int input)) - ;; a symbol with a function binding - ((fboundp (setq interned (intern input))) - interned) - ;; a lambda function - ((c-safe (functionp (setq raw (read input)))) - raw) - ;; a symbol with variable binding - ((boundp interned) interned) - ;; error, but don't signal one, keep trying - ;; to read an input value - (t (ding) - (setq prompt errmsg) - nil)))) - offset)) - -;;;###autoload -(defun c-set-offset (symbol offset &optional add-p) - "Change the value of a syntactic element symbol in `c-offsets-alist'. -SYMBOL is the syntactic element symbol to change and OFFSET is the new -offset for that syntactic element. Optional ADD says to add SYMBOL to -`c-offsets-alist' if it doesn't already appear there." - (interactive - (let* ((langelem - (intern (completing-read - (concat "Syntactic symbol to change" - (if current-prefix-arg " or add" "") - ": ") - (mapcar - #'(lambda (langelem) - (cons (format "%s" (car langelem)) nil)) - c-offsets-alist) - nil (not current-prefix-arg) - ;; initial contents tries to be the last element - ;; on the syntactic analysis list for the current - ;; line - (let* ((syntax (c-guess-basic-syntax)) - (len (length syntax)) - (ic (format "%s" (car (nth (1- len) syntax))))) - (cons ic 0)) - ))) - (offset (c-read-offset langelem))) - (list langelem offset current-prefix-arg))) - ;; sanity check offset - (or (eq offset '+) - (eq offset '-) - (eq offset '++) - (eq offset '--) - (eq offset '*) - (eq offset '/) - (integerp offset) - (functionp offset) - (boundp offset) - (error "Offset must be int, func, var, or in [+,-,++,--,*,/]: %s" - offset)) - (let ((entry (assq symbol c-offsets-alist))) - (if entry - (setcdr entry offset) - (if add-p - (setq c-offsets-alist (cons (cons symbol offset) c-offsets-alist)) - (error "%s is not a valid syntactic symbol." symbol)))) - (c-keep-region-active)) - - - -(defun c-initialize-builtin-style () - ;; Dynamically append the default value of most variables. This is - ;; crucial because future c-set-style calls will always reset the - ;; variables first to the `cc-mode' style before instituting the new - ;; style. Only do this once! - (or (assoc "cc-mode" c-style-alist) - (let (copyfunc) - ;; use built-in copy-tree if its there. - (if (and (fboundp 'copy-tree) - (functionp (symbol-function 'copy-tree))) - (setq copyfunc (symbol-function 'copy-tree)) - (setq copyfunc (lambda (tree) - (if (consp tree) - (cons (funcall copyfunc (car tree)) - (funcall copyfunc (cdr tree))) - tree)))) - (c-add-style "cc-mode" - (mapcar - (function - (lambda (var) - (let ((val (symbol-value var))) - (cons var (if (atom val) - val - (funcall copyfunc val) - )) - ))) - '(c-backslash-column - c-basic-offset - c-cleanup-list - c-comment-only-line-offset - c-electric-pound-behavior - c-hanging-braces-alist - c-hanging-colons-alist - c-hanging-comment-starter-p - c-hanging-comment-ender-p - c-offsets-alist - ))) - ;; the default style is now GNU. This can be overridden in - ;; c-mode-common-hook or {c,c++,objc,java}-mode-hook. - (c-set-style c-site-default-style))) - (if c-style-variables-are-local-p - (c-make-styles-buffer-local))) - - -(defun c-make-styles-buffer-local () - "Make all CC Mode style variables buffer local. -If you edit primarily one style of C (or C++, Objective-C, Java) code, -you probably want style variables to be global. This is the default. - -If you edit many different styles of C (or C++, Objective-C, Java) at -the same time, you probably want the CC Mode style variables to be -buffer local. If you do, then you will need to set any CC Mode style -variables in a hook function (e.g. off of c-mode-common-hook), instead -of at the top level of your ~/.emacs file. - -This function makes all the CC Mode style variables buffer local. -Call it after CC Mode is loaded into your Emacs environment. -Conversely, set the variable `c-style-variables-are-local-p' to t in -your .emacs file, before CC Mode is loaded, and this function will be -automatically called when CC Mode is loaded." - ;; style variables - (make-variable-buffer-local 'c-offsets-alist) - (make-variable-buffer-local 'c-basic-offset) - (make-variable-buffer-local 'c-file-style) - (make-variable-buffer-local 'c-file-offsets) - (make-variable-buffer-local 'c-comment-only-line-offset) - (make-variable-buffer-local 'c-cleanup-list) - (make-variable-buffer-local 'c-hanging-braces-alist) - (make-variable-buffer-local 'c-hanging-colons-alist) - (make-variable-buffer-local 'c-hanging-comment-starter-p) - (make-variable-buffer-local 'c-hanging-comment-ender-p) - (make-variable-buffer-local 'c-backslash-column) - (make-variable-buffer-local 'c-label-minimum-indentation) - (make-variable-buffer-local 'c-special-indent-hook) - (make-variable-buffer-local 'c-indentation-style)) - - -(provide 'cc-styles) -;;; cc-styles.el ends here
--- a/lisp/cc-mode/cc-vars.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,415 +0,0 @@ -;;; cc-vars.el --- user customization variables for CC Mode - -;; Copyright (C) 1985,87,92,93,94,95,96,97 Free Software Foundation, Inc. - -;; Authors: 1992-1997 Barry A. Warsaw -;; 1987 Dave Detlefs and Stewart Clamen -;; 1985 Richard M. Stallman -;; Maintainer: cc-mode-help@python.org -;; Created: 22-Apr-1997 (split from cc-mode.el) -;; Version: See cc-mode.el -;; Keywords: c languages oop - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -(require 'custom) - - -(defcustom c-strict-syntax-p nil - "*If non-nil, all syntactic symbols must be found in `c-offsets-alist'. -If the syntactic symbol for a particular line does not match a symbol -in the offsets alist, an error is generated, otherwise no error is -reported and the syntactic symbol is ignored." - :type 'boolean - :group 'c) - -(defcustom c-echo-syntactic-information-p nil - "*If non-nil, syntactic info is echoed when the line is indented." - :type 'boolean - :group 'c) - -(defcustom c-basic-offset 4 - "*Amount of basic offset used by + and - symbols in `c-offsets-alist'." - :type 'integer - :group 'c) - -(defcustom c-tab-always-indent t - "*Controls the operation of the TAB key. -If t, hitting TAB always just indents the current line. If nil, -hitting TAB indents the current line if point is at the left margin or -in the line's indentation, otherwise it insert a `real' tab character -\(see note\). If other than nil or t, then tab is inserted only -within literals -- defined as comments and strings -- and inside -preprocessor directives, but line is always reindented. - -Note: The value of `indent-tabs-mode' will determine whether a real -tab character will be inserted, or the equivalent number of space. -When inserting a tab, actually the function stored in the variable -`c-insert-tab-function' is called. - -Note: indentation of lines containing only comments is also controlled -by the `c-comment-only-line-offset' variable." - :type '(radio - :extra-offset 8 - :format "%{C Tab Always Indent%}:\n The TAB key:\n%v" - (const :tag "always indents, never inserts TAB" t) - (const :tag "indents in left margin, otherwise inserts TAB" nil) - (const :tag "inserts TAB in literals, otherwise indent" other)) - :group 'c) - -(defcustom c-insert-tab-function 'insert-tab - "*Function used when inserting a tab for \\[TAB]. -Only used when `c-tab-always-indent' indicates a `real' tab character -should be inserted. Value must be a function taking no arguments." - :type 'function - :group 'c) - -(defcustom c-comment-only-line-offset 0 - "*Extra offset for line which contains only the start of a comment. -Can contain an integer or a cons cell of the form: - - (NON-ANCHORED-OFFSET . ANCHORED-OFFSET) - -Where NON-ANCHORED-OFFSET is the amount of offset given to -non-column-zero anchored comment-only lines, and ANCHORED-OFFSET is -the amount of offset to give column-zero anchored comment-only lines. -Just an integer as value is equivalent to (<val> . -1000)." - :type '(choice (integer :tag "Non-anchored offset") - (cons :tag "Non-anchored & anchored offset" - :value (0 . 0) - :extra-offset 8 - (integer :tag "Non-anchored offset") - (integer :tag "Anchored offset"))) - :group 'c) - -(defcustom c-indent-comments-syntactically-p nil - "*Specifies how comment-only lines should be indented. -When this variable is non-nil, comment-only lines are indented -according to syntactic analysis via `c-offsets-alist', even when -\\[indent-for-comment] is used." - :type 'boolean - :group 'c) - -(defcustom c-comment-continuation-stars "* " - "*Specifies the leader of continued block comments. -You should set this variable to the literal string that gets inserted -at the front of continued block style comment lines. This should -either be the empty string, or some number of stars followed by a -single space. Note that for line style comments, this variable is not -used." - :type '(choice (const :tag "Use old semantics" nil) - string) - :group 'c) - -(defcustom c-cleanup-list '(scope-operator) - "*List of various C/C++/ObjC constructs to \"clean up\". -These clean ups only take place when the auto-newline feature is -turned on, as evidenced by the `/a' or `/ah' appearing next to the -mode name. Valid symbols are: - - brace-else-brace -- cleans up `} else {' constructs by placing entire - construct on a single line. This clean up - only takes place when there is nothing but - white space between the braces and the `else'. - Clean up occurs when the open-brace after the - `else' is typed. - brace-elseif-brace -- similar to brace-else-brace, but cleans up - `} else if {' constructs. - empty-defun-braces -- cleans up empty defun braces by placing the - braces on the same line. Clean up occurs when - the defun closing brace is typed. - defun-close-semi -- cleans up the terminating semi-colon on defuns - by placing the semi-colon on the same line as - the closing brace. Clean up occurs when the - semi-colon is typed. - list-close-comma -- cleans up commas following braces in array - and aggregate initializers. Clean up occurs - when the comma is typed. - scope-operator -- cleans up double colons which may designate - a C++ scope operator split across multiple - lines. Note that certain C++ constructs can - generate ambiguous situations. This clean up - only takes place when there is nothing but - whitespace between colons. Clean up occurs - when the second colon is typed." - :type '(set - :extra-offset 8 - (const :tag "Put `} else {' on one line" brace-else-brace) - (const :tag "Put `} else if {' on one line" brace-elseif-brace) - (const :tag "Put empty defun braces on one line" empty-defun-braces) - (const :tag "Put `},' in aggregates on one line" list-close-comma) - (const :tag "Put C++ style `::' on one line" scope-operator)) - :group 'c) - -(defcustom c-hanging-braces-alist '((brace-list-open) - (substatement-open after) - (block-close . c-snug-do-while) - (extern-lang-open after) - ) - "*Controls the insertion of newlines before and after braces. -This variable contains an association list with elements of the -following form: (SYNTACTIC-SYMBOL . ACTION). - -When a brace (either opening or closing) is inserted, the syntactic -context it defines is looked up in this list, and if found, the -associated ACTION is used to determine where newlines are inserted. -If the context is not found, the default is to insert a newline both -before and after the brace. - -SYNTACTIC-SYMBOL can be any of: defun-open, defun-close, class-open, -class-close, inline-open, inline-close, block-open, block-close, -substatement-open, statement-case-open, extern-lang-open, -extern-lang-close, brace-list-open, brace-list-close, -brace-list-intro, or brace-list-entry. See `c-offsets-alist' for -details. - -ACTION can be either a function symbol or a list containing any -combination of the symbols `before' or `after'. If the list is empty, -no newlines are inserted either before or after the brace. - -When ACTION is a function symbol, the function is called with a two -arguments: the syntactic symbol for the brace and the buffer position -at which the brace was inserted. The function must return a list as -described in the preceding paragraph. Note that during the call to -the function, the variable `c-syntactic-context' is set to the entire -syntactic context for the brace line." - :type '(repeat - (cons :format "%v" - (choice :tag "Syntax" - (const defun-open) (const defun-close) - (const class-open) (const class-close) - (const inline-open) (const inline-close) - (const block-open) (const block-close) - (const substatement-open) (const statement-case-open) - (const extern-lang-open) (const extern-lang-close) - (const brace-list-open) (const brace-list-close) - (const brace-list-intro) (const brace-list-entry)) - (choice :tag "Action" - (set :format "Insert a newline %v" - :extra-offset 38 - (const :tag "before brace" before) - (const :tag "after brace" after)) - (function :format "Run function %v" :value c-) - ))) - :group 'c) - -(defcustom c-hanging-colons-alist nil - "*Controls the insertion of newlines before and after certain colons. -This variable contains an association list with elements of the -following form: (SYNTACTIC-SYMBOL . ACTION). - -SYNTACTIC-SYMBOL can be any of: case-label, label, access-label, -member-init-intro, or inher-intro. - -See the variable `c-hanging-braces-alist' for the semantics of this -variable. Note however that making ACTION a function symbol is -currently not supported for this variable." - :type '(repeat - (cons :format "%v" - (choice :tag "Syntax" - (const case-label) (const label) (const access-label) - (const member-init-intro) (const inher-intro)) - (set :tag "Action" - :format "%t: %v" - :extra-offset 8 - (const before) (const after)))) - :group 'c) - -(defcustom c-hanging-semi&comma-criteria '(c-semi&comma-inside-parenlist) - "*List of functions that decide whether to insert a newline or not. -The functions in this list are called, in order, whenever the -auto-newline minor mode is activated (as evidenced by a `/a' or `/ah' -string in the mode line), and a semicolon or comma is typed (see -`c-electric-semi&comma'). Each function in this list is called with -no arguments, and should return one of the following values: - - nil -- no determination made, continue checking - 'stop -- do not insert a newline, and stop checking - (anything else) -- insert a newline, and stop checking - -If every function in the list is called with no determination made, -then no newline is inserted." - :type '(repeat function) - :group 'c) - -(defcustom c-hanging-comment-ender-p t - "*Controls what \\[fill-paragraph] does to C block comment enders. -When set to nil, C block comment enders are left on their own line. -When set to t, block comment enders will be placed at the end of the -previous line (i.e. they `hang' on that line)." - :type 'boolean - :group 'c) - -(defcustom c-hanging-comment-starter-p t - "*Controls what \\[fill-paragraph] does to C block comment starters. -When set to nil, C block comment starters are left on their own line. -When set to t, text that follows a block comment starter will be -placed on the same line as the block comment starter (i.e. the text -`hangs' on that line)." - :type 'boolean - :group 'c) - -(defcustom c-backslash-column 48 - "*Column to insert backslashes when macroizing a region." - :type 'integer - :group 'c) - -(defcustom c-special-indent-hook nil - "*Hook for user defined special indentation adjustments. -This hook gets called after a line is indented by the mode." - :type 'hook - :group 'c) - -(defcustom c-backspace-function 'backward-delete-char-untabify - "*Function called by `c-electric-backspace' when deleting backwards." - :type 'function - :group 'c) - -(defcustom c-delete-function 'delete-char - "*Function called by `c-electric-delete' when deleting forwards." - :type 'function - :group 'c) - -(defcustom c-electric-pound-behavior nil - "*List of behaviors for electric pound insertion. -Only currently supported behavior is `alignleft'." - :type '(set :extra-offset 8 (const alignleft)) - :group 'c) - -(defcustom c-label-minimum-indentation 1 - "*Minimum indentation for lines inside of top-level constructs. -This variable typically only affects code using the `gnu' style, which -mandates a minimum of one space in front of every line inside -top-level constructs. Specifically, the function -`c-gnu-impose-minimum' on your `c-special-indent-hook' is what -enforces this." - :type 'integer - :group 'c) - -(defcustom c-progress-interval 5 - "*Interval used to update progress status during long re-indentation. -If a number, percentage complete gets updated after each interval of -that many seconds. To inhibit all messages during indentation, set -this variable to nil." - :type 'integer - :group 'c) - -(defcustom c-site-default-style "gnu" - "Default style for your site. -To change the default style at your site, you can set this variable to -any style defined in `c-style-alist'. However, if CC Mode is usually -loaded into your Emacs at compile time, you will need to set this -variable in the `site-init.el' file before CC Mode is loaded, then -re-dump Emacs." - :type 'string - :group 'c) - -(defcustom c-style-variables-are-local-p nil - "*Whether style variables should be buffer local by default. -If non-nil, then all indentation style related variables will be made -buffer local by default. If nil, they will remain global. Variables -are made buffer local when this file is loaded, and once buffer -localized, they cannot be made global again. - -The list of variables to buffer localize are: - c-offsets-alist - c-basic-offset - c-file-style - c-file-offsets - c-comment-only-line-offset - c-cleanup-list - c-hanging-braces-alist - c-hanging-colons-alist - c-hanging-comment-starter-p - c-hanging-comment-ender-p - c-backslash-column - c-label-minimum-indentation - c-special-indent-hook - c-indentation-style" - :type 'boolean - :group 'c) - -(defcustom c-mode-hook nil - "*Hook called by `c-mode'." - :type '(hook :format "%{C Mode Hook%}:\n%v") - :group 'c) - -(defcustom c++-mode-hook nil - "*Hook called by `c++-mode'." - :type 'hook - :group 'c) - -(defcustom objc-mode-hook nil - "*Hook called by `objc-mode'." - :type 'hook - :group 'c) - -(defcustom java-mode-hook nil - "*Hook called by `java-mode'." - :type 'hook - :group 'c) - -(defcustom idl-mode-hook nil - "*Hook called by `idl-mode'." - :type 'hook - :group 'c) - -(defcustom c-mode-common-hook nil - "*Hook called by all CC Mode modes for common initializations." - :type '(hook :format "%{CC Mode Common Hook%}:\n%v") - :group 'c) - -(defcustom c-initialization-hook nil - "*Hook called when the CC Mode package gets initialized. -This hook is only run once per Emacs session and can be used as a -`load-hook' or in place of using `eval-after-load'." - :type 'hook - :group 'c) - - - -;; Non-customizable variables, still part of the interface to CC Mode -(defvar c-file-style nil - "Variable interface for setting style via File Local Variables. -In a file's Local Variable section, you can set this variable to a -string suitable for `c-set-style'. When the file is visited, CC Mode -will set the style of the file to this value automatically. - -Note that file style settings are applied before file offset settings -as designated in the variable `c-file-offsets'.") - -(defvar c-file-offsets nil - "Variable interface for setting offsets via File Local Variables. -In a file's Local Variable section, you can set this variable to an -association list similar to the values allowed in `c-offsets-alist'. -When the file is visited, CC Mode will institute these offset settings -automatically. - -Note that file offset settings are applied after file style settings -as designated in the variable `c-file-style'.") - -(defvar c-syntactic-context nil - "Variable containing syntactic analysis list during indentation.") - -(defvar c-indentation-style c-site-default-style - "Name of style installed in the current buffer.") - - - -(provide 'cc-vars) -;;; cc-vars.el ends here
--- a/lisp/cc-mode/custom-load.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,8 +0,0 @@ -;;; custom-load.el --- automatically extracted custom dependencies - - -;;; Code: - -(custom-add-loads 'c '("cc-vars")) - -;;; custom-load.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cl-compat.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,194 @@ +;;; cl-compat.el --- Common Lisp extensions for GNU Emacs Lisp (compatibility) + +;; Copyright (C) 1993 Free Software Foundation, Inc. + +;; Author: Dave Gillespie <daveg@synaptics.com> +;; Version: 2.02 +;; Keywords: extensions + +;; 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.34. + +;;; Commentary: + +;; These are extensions to Emacs Lisp that provide a degree of +;; Common Lisp compatibility, beyond what is already built-in +;; in Emacs Lisp. +;; +;; This package was written by Dave Gillespie; it is a complete +;; rewrite of Cesar Quiroz's original cl.el package of December 1986. +;; +;; This package works with Emacs 18, Emacs 19, and XEmacs/Lucid Emacs 19. +;; +;; Bug reports, comments, and suggestions are welcome! + +;; This file contains emulations of internal routines of the older +;; CL package which users may have called directly from their code. +;; Use (require 'cl-compat) to get these routines. + +;; See cl.el for Change Log. + + +;;; Code: + +;; Require at load-time, but not when compiling cl-compat. +(or (featurep 'cl) (require 'cl)) + + +;;; Keyword routines not supported by new package. + +(defmacro defkeyword (x &optional doc) + (list* 'defconst x (list 'quote x) (and doc (list doc)))) + +(defun keywordp (sym) + (and (symbolp sym) (eq (aref (symbol-name sym) 0) ?\:) (set sym sym))) + +(defun keyword-of (sym) + (or (keywordp sym) (keywordp (intern (format ":%s" sym))))) + + +;;; Multiple values. Note that the new package uses a different +;;; convention for multiple values. The following definitions +;;; emulate the old convention; all function names have been changed +;;; by capitalizing the first letter: Values, Multiple-value-*, +;;; to avoid conflict with the new-style definitions in cl-macs. + +(put 'Multiple-value-bind 'lisp-indent-function 2) +(put 'Multiple-value-setq 'lisp-indent-function 2) +(put 'Multiple-value-call 'lisp-indent-function 1) +(put 'Multiple-value-prog1 'lisp-indent-function 1) + +(defvar *mvalues-values* nil) + +(defun Values (&rest val-forms) + (setq *mvalues-values* val-forms) + (car val-forms)) + +(defun Values-list (val-forms) + (apply 'values val-forms)) + +(defmacro Multiple-value-list (form) + (list 'let* (list '(*mvalues-values* nil) (list '*mvalues-temp* form)) + '(or (and (eq *mvalues-temp* (car *mvalues-values*)) *mvalues-values*) + (list *mvalues-temp*)))) + +(defmacro Multiple-value-call (function &rest args) + (list 'apply function + (cons 'append + (mapcar (function (lambda (x) (list 'Multiple-value-list x))) + args)))) + +(defmacro Multiple-value-bind (vars form &rest body) + (list* 'multiple-value-bind vars (list 'Multiple-value-list form) body)) + +(defmacro Multiple-value-setq (vars form) + (list 'multiple-value-setq vars (list 'Multiple-value-list form))) + +(defmacro Multiple-value-prog1 (form &rest body) + (list 'prog1 form (list* 'let '((*mvalues-values* nil)) body))) + + +;;; Routines for parsing keyword arguments. + +(defun build-klist (arglist keys &optional allow-others) + (let ((res (Multiple-value-call 'mapcar* 'cons (unzip-lists arglist)))) + (or allow-others + (let ((bad (set-difference (mapcar 'car res) keys))) + (if bad (error "Bad keywords: %s not in %s" bad keys)))) + res)) + +(defun extract-from-klist (klist key &optional def) + (let ((res (assq key klist))) (if res (cdr res) def))) + +(defun keyword-argument-supplied-p (klist key) + (assq key klist)) + +(defun elt-satisfies-test-p (item elt klist) + (let ((test-not (cdr (assq ':test-not klist))) + (test (cdr (assq ':test klist))) + (key (cdr (assq ':key klist)))) + (if key (setq elt (funcall key elt))) + (if test-not (not (funcall test-not item elt)) + (funcall (or test 'eql) item elt)))) + + +;;; Rounding functions with old-style multiple value returns. + +(defun cl-floor (a &optional b) (Values-list (floor* a b))) +(defun cl-ceiling (a &optional b) (Values-list (ceiling* a b))) +(defun cl-round (a &optional b) (Values-list (round* a b))) +(defun cl-truncate (a &optional b) (Values-list (truncate* a b))) + +(defun safe-idiv (a b) + (let* ((q (/ (abs a) (abs b))) + (s (* (signum a) (signum b)))) + (Values q (- a (* s q b)) s))) + + +;; Internal routines. + +(defun pair-with-newsyms (oldforms) + (let ((newsyms (mapcar (function (lambda (x) (gensym))) oldforms))) + (Values (mapcar* 'list newsyms oldforms) newsyms))) + +(defun zip-lists (evens odds) + (mapcan 'list evens odds)) + +(defun unzip-lists (list) + (let ((e nil) (o nil)) + (while list + (setq e (cons (car list) e) o (cons (cadr list) o) list (cddr list))) + (Values (nreverse e) (nreverse o)))) + +(defun reassemble-argslists (list) + (let ((n (apply 'min (mapcar 'length list))) (res nil)) + (while (>= (setq n (1- n)) 0) + (setq res (cons (mapcar (function (lambda (x) (elt x n))) list) res))) + res)) + +(defun duplicate-symbols-p (list) + (let ((res nil)) + (while list + (if (memq (car list) (cdr list)) (setq res (cons (car list) res))) + (setq list (cdr list))) + res)) + + +;;; Setf internals. + +(defun setnth (n list x) + (setcar (nthcdr n list) x)) + +(defun setnthcdr (n list x) + (setcdr (nthcdr (1- n) list) x)) + +(defun setelt (seq n x) + (if (consp seq) (setcar (nthcdr n seq) x) (aset seq n x))) + + +;;; Functions omitted: case-clausify, check-do-stepforms, check-do-endforms, +;;; extract-do-inits, extract-do[*]-steps, select-stepping-forms, +;;; elt-satisfies-if[-not]-p, with-keyword-args, mv-bind-clausify, +;;; all names with embedded `$'. + + +(provide 'cl-compat) + +;;; cl-compat.el ends here +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cl-extra.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,939 @@ +;;; cl-extra.el --- Common Lisp extensions for GNU Emacs Lisp (part two) + +;; Copyright (C) 1993 Free Software Foundation, Inc. + +;; Author: Dave Gillespie <daveg@synaptics.com> +;; Maintainer: XEmacs Development Team +;; Version: 2.02 +;; Keywords: extensions, dumped + +;; 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.34. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;; These are extensions to Emacs Lisp that provide a degree of +;; Common Lisp compatibility, beyond what is already built-in +;; in Emacs Lisp. +;; +;; This package was written by Dave Gillespie; it is a complete +;; rewrite of Cesar Quiroz's original cl.el package of December 1986. +;; +;; This package works with Emacs 18, Emacs 19, and XEmacs/Lucid Emacs 19. +;; +;; Bug reports, comments, and suggestions are welcome! + +;; This file contains portions of the Common Lisp extensions +;; package which are autoloaded since they are relatively obscure. + +;; See cl.el for Change Log. + + +;;; Code: + +(or (memq 'cl-19 features) + (error "Tried to load `cl-extra' before `cl'!")) + + +;;; We define these here so that this file can compile without having +;;; loaded the cl.el file already. + +(defmacro cl-push (x place) (list 'setq place (list 'cons x place))) +(defmacro cl-pop (place) + (list 'car (list 'prog1 place (list 'setq place (list 'cdr place))))) + +(defvar cl-emacs-type) + + +;;; Type coercion. + +(defun coerce (x type) + "Coerce OBJECT to type TYPE. +TYPE is a Common Lisp type specifier." + (cond ((eq type 'list) (if (listp x) x (append x nil))) + ((eq type 'vector) (if (vectorp x) x (vconcat x))) + ((eq type 'string) (if (stringp x) x (concat x))) + ((eq type 'array) (if (arrayp x) x (vconcat x))) + ((and (eq type 'character) (stringp x) (= (length x) 1)) (aref x 0)) + ((and (eq type 'character) (symbolp x)) (coerce (symbol-name x) type)) + ((eq type 'float) (float x)) + ((typep x type) x) + (t (error "Can't coerce %s to type %s" x type)))) + + +;;; Predicates. + +(defun equalp (x y) + "T if two Lisp objects have similar structures and contents. +This is like `equal', except that it accepts numerically equal +numbers of different types (float vs. integer), and also compares +strings case-insensitively." + (cond ((eq x y) t) + ((stringp x) + (and (stringp y) (= (length x) (length y)) + (or (string-equal x y) + (string-equal (downcase x) (downcase y))))) ; lazy but simple! + ((numberp x) + (and (numberp y) (= x y))) + ((consp x) + ;; XEmacs change + (while (and (consp x) (consp y) (equalp (cl-pop x) (cl-pop y)))) + (and (not (consp x)) (equalp x y))) + ((vectorp x) + (and (vectorp y) (= (length x) (length y)) + (let ((i (length x))) + (while (and (>= (setq i (1- i)) 0) + (equalp (aref x i) (aref y i)))) + (< i 0)))) + (t (equal x y)))) + + +;;; Control structures. + +(defun cl-mapcar-many (cl-func cl-seqs) + (if (cdr (cdr cl-seqs)) + (let* ((cl-res nil) + (cl-n (apply 'min (mapcar 'length cl-seqs))) + (cl-i 0) + (cl-args (copy-sequence cl-seqs)) + cl-p1 cl-p2) + (setq cl-seqs (copy-sequence cl-seqs)) + (while (< cl-i cl-n) + (setq cl-p1 cl-seqs cl-p2 cl-args) + (while cl-p1 + (setcar cl-p2 + (if (consp (car cl-p1)) + (prog1 (car (car cl-p1)) + (setcar cl-p1 (cdr (car cl-p1)))) + (aref (car cl-p1) cl-i))) + (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2))) + (cl-push (apply cl-func cl-args) cl-res) + (setq cl-i (1+ cl-i))) + (nreverse cl-res)) + (let ((cl-res nil) + (cl-x (car cl-seqs)) + (cl-y (nth 1 cl-seqs))) + (let ((cl-n (min (length cl-x) (length cl-y))) + (cl-i -1)) + (while (< (setq cl-i (1+ cl-i)) cl-n) + (cl-push (funcall cl-func + (if (consp cl-x) (cl-pop cl-x) (aref cl-x cl-i)) + (if (consp cl-y) (cl-pop cl-y) (aref cl-y cl-i))) + cl-res))) + (nreverse cl-res)))) + +(defun map (cl-type cl-func cl-seq &rest cl-rest) + "Map a function across one or more sequences, returning a sequence. +TYPE is the sequence type to return, FUNC is the function, and SEQS +are the argument sequences." + (let ((cl-res (apply 'mapcar* cl-func cl-seq cl-rest))) + (and cl-type (coerce cl-res cl-type)))) + +(defun maplist (cl-func cl-list &rest cl-rest) + "Map FUNC to each sublist of LIST or LISTS. +Like `mapcar', except applies to lists and their cdr's rather than to +the elements themselves." + (if cl-rest + (let ((cl-res nil) + (cl-args (cons cl-list (copy-sequence cl-rest))) + cl-p) + (while (not (memq nil cl-args)) + (cl-push (apply cl-func cl-args) cl-res) + (setq cl-p cl-args) + (while cl-p (setcar cl-p (cdr (cl-pop cl-p)) ))) + (nreverse cl-res)) + (let ((cl-res nil)) + (while cl-list + (cl-push (funcall cl-func cl-list) cl-res) + (setq cl-list (cdr cl-list))) + (nreverse cl-res)))) + + +;; mapc is now in C, renamed from `mapc-internal'. + +;(defun mapc (cl-func cl-seq &rest cl-rest) +; "Like `mapcar', but does not accumulate values returned by the function." +; (if cl-rest +; (apply 'map nil cl-func cl-seq cl-rest) +; ;; XEmacs change: we call mapc-internal, which really doesn't +; ;; accumulate any results. +; (mapc-internal cl-func cl-seq)) +; cl-seq) + +(defun mapl (cl-func cl-list &rest cl-rest) + "Like `maplist', but does not accumulate values returned by the function." + (if cl-rest + (apply 'maplist cl-func cl-list cl-rest) + (let ((cl-p cl-list)) + (while cl-p (funcall cl-func cl-p) (setq cl-p (cdr cl-p))))) + cl-list) + +(defun mapcan (cl-func cl-seq &rest cl-rest) + "Like `mapcar', but nconc's together the values returned by the function." + (apply 'nconc (apply 'mapcar* cl-func cl-seq cl-rest))) + +(defun mapcon (cl-func cl-list &rest cl-rest) + "Like `maplist', but nconc's together the values returned by the function." + (apply 'nconc (apply 'maplist cl-func cl-list cl-rest))) + +(defun some (cl-pred cl-seq &rest cl-rest) + "Return true if PREDICATE is true of any element of SEQ or SEQs. +If so, return the true (non-nil) value returned by PREDICATE." + (if (or cl-rest (nlistp cl-seq)) + (catch 'cl-some + (apply 'map nil + (function (lambda (&rest cl-x) + (let ((cl-res (apply cl-pred cl-x))) + (if cl-res (throw 'cl-some cl-res))))) + cl-seq cl-rest) nil) + (let ((cl-x nil)) + (while (and cl-seq (not (setq cl-x (funcall cl-pred (cl-pop cl-seq)))))) + cl-x))) + +(defun every (cl-pred cl-seq &rest cl-rest) + "Return true if PREDICATE is true of every element of SEQ or SEQs." + (if (or cl-rest (nlistp cl-seq)) + (catch 'cl-every + (apply 'map nil + (function (lambda (&rest cl-x) + (or (apply cl-pred cl-x) (throw 'cl-every nil)))) + cl-seq cl-rest) t) + (while (and cl-seq (funcall cl-pred (car cl-seq))) + (setq cl-seq (cdr cl-seq))) + (null cl-seq))) + +(defun notany (cl-pred cl-seq &rest cl-rest) + "Return true if PREDICATE is false of every element of SEQ or SEQs." + (not (apply 'some cl-pred cl-seq cl-rest))) + +(defun notevery (cl-pred cl-seq &rest cl-rest) + "Return true if PREDICATE is false of some element of SEQ or SEQs." + (not (apply 'every cl-pred cl-seq cl-rest))) + +;;; Support for `loop'. +(defun cl-map-keymap (cl-func cl-map) + (while (symbolp cl-map) (setq cl-map (symbol-function cl-map))) + (if (eq cl-emacs-type 'lucid) (funcall 'map-keymap cl-func cl-map) + (if (listp cl-map) + (let ((cl-p cl-map)) + (while (consp (setq cl-p (cdr cl-p))) + (cond ((consp (car cl-p)) + (funcall cl-func (car (car cl-p)) (cdr (car cl-p)))) + ((vectorp (car cl-p)) + (cl-map-keymap cl-func (car cl-p))) + ((eq (car cl-p) 'keymap) + (setq cl-p nil))))) + (let ((cl-i -1)) + (while (< (setq cl-i (1+ cl-i)) (length cl-map)) + (if (aref cl-map cl-i) + (funcall cl-func cl-i (aref cl-map cl-i)))))))) + +(defun cl-map-keymap-recursively (cl-func-rec cl-map &optional cl-base) + (or cl-base + (setq cl-base (copy-sequence (if (eq cl-emacs-type 18) "0" [0])))) + (cl-map-keymap + (function + (lambda (cl-key cl-bind) + (aset cl-base (1- (length cl-base)) cl-key) + (if (keymapp cl-bind) + (cl-map-keymap-recursively + cl-func-rec cl-bind + (funcall (if (eq cl-emacs-type 18) 'concat 'vconcat) + cl-base (list 0))) + (funcall cl-func-rec cl-base cl-bind)))) + cl-map)) + +(defun cl-map-intervals (cl-func &optional cl-what cl-prop cl-start cl-end) + (or cl-what (setq cl-what (current-buffer))) + (if (bufferp cl-what) + (let (cl-mark cl-mark2 (cl-next t) cl-next2) + (save-excursion + (set-buffer cl-what) + (setq cl-mark (copy-marker (or cl-start (point-min)))) + (setq cl-mark2 (and cl-end (copy-marker cl-end)))) + (while (and cl-next (or (not cl-mark2) (< cl-mark cl-mark2))) + (setq cl-next (and (fboundp 'next-property-change) + (if cl-prop (next-single-property-change + cl-mark cl-prop cl-what) + (next-property-change cl-mark cl-what))) + cl-next2 (or cl-next (save-excursion + (set-buffer cl-what) (point-max)))) + (funcall cl-func (prog1 (marker-position cl-mark) + (set-marker cl-mark cl-next2)) + (if cl-mark2 (min cl-next2 cl-mark2) cl-next2))) + (set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil))) + (or cl-start (setq cl-start 0)) + (or cl-end (setq cl-end (length cl-what))) + (while (< cl-start cl-end) + (let ((cl-next (or (and (fboundp 'next-property-change) + (if cl-prop (next-single-property-change + cl-start cl-prop cl-what) + (next-property-change cl-start cl-what))) + cl-end))) + (funcall cl-func cl-start (min cl-next cl-end)) + (setq cl-start cl-next))))) + +(defun cl-map-overlays (cl-func &optional cl-buffer cl-start cl-end cl-arg) + (or cl-buffer (setq cl-buffer (current-buffer))) + (if (fboundp 'overlay-lists) + + ;; This is the preferred algorithm, though overlay-lists is undocumented. + (let (cl-ovl) + (save-excursion + (set-buffer cl-buffer) + (setq cl-ovl (overlay-lists)) + (if cl-start (setq cl-start (copy-marker cl-start))) + (if cl-end (setq cl-end (copy-marker cl-end)))) + (setq cl-ovl (nconc (car cl-ovl) (cdr cl-ovl))) + (while (and cl-ovl + (or (not (overlay-start (car cl-ovl))) + (and cl-end (>= (overlay-start (car cl-ovl)) cl-end)) + (and cl-start (<= (overlay-end (car cl-ovl)) cl-start)) + (not (funcall cl-func (car cl-ovl) cl-arg)))) + (setq cl-ovl (cdr cl-ovl))) + (if cl-start (set-marker cl-start nil)) + (if cl-end (set-marker cl-end nil))) + + ;; This alternate algorithm fails to find zero-length overlays. + (let ((cl-mark (save-excursion (set-buffer cl-buffer) + (copy-marker (or cl-start (point-min))))) + (cl-mark2 (and cl-end (save-excursion (set-buffer cl-buffer) + (copy-marker cl-end)))) + cl-pos cl-ovl) + (while (save-excursion + (and (setq cl-pos (marker-position cl-mark)) + (< cl-pos (or cl-mark2 (point-max))) + (progn + (set-buffer cl-buffer) + (setq cl-ovl (overlays-at cl-pos)) + (set-marker cl-mark (next-overlay-change cl-pos))))) + (while (and cl-ovl + (or (/= (overlay-start (car cl-ovl)) cl-pos) + (not (and (funcall cl-func (car cl-ovl) cl-arg) + (set-marker cl-mark nil))))) + (setq cl-ovl (cdr cl-ovl)))) + (set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil))))) + +;;; Support for `setf'. +(defun cl-set-frame-visible-p (frame val) + (cond ((null val) (make-frame-invisible frame)) + ((eq val 'icon) (iconify-frame frame)) + (t (make-frame-visible frame))) + val) + +;;; Support for `progv'. +(defvar cl-progv-save) +(defun cl-progv-before (syms values) + (while syms + (cl-push (if (boundp (car syms)) + (cons (car syms) (symbol-value (car syms))) + (car syms)) cl-progv-save) + (if values + (set (cl-pop syms) (cl-pop values)) + (makunbound (cl-pop syms))))) + +(defun cl-progv-after () + (while cl-progv-save + (if (consp (car cl-progv-save)) + (set (car (car cl-progv-save)) (cdr (car cl-progv-save))) + (makunbound (car cl-progv-save))) + (cl-pop cl-progv-save))) + + +;;; Numbers. + +(defun gcd (&rest args) + "Return the greatest common divisor of the arguments." + (let ((a (abs (or (cl-pop args) 0)))) + (while args + (let ((b (abs (cl-pop args)))) + (while (> b 0) (setq b (% a (setq a b)))))) + a)) + +(defun lcm (&rest args) + "Return the least common multiple of the arguments." + (if (memq 0 args) + 0 + (let ((a (abs (or (cl-pop args) 1)))) + (while args + (let ((b (abs (cl-pop args)))) + (setq a (* (/ a (gcd a b)) b)))) + a))) + +(defun isqrt (a) + "Return the integer square root of the argument." + (if (and (integerp a) (> a 0)) + ;; XEmacs change + (let ((g (cond ((>= a 1000000) 10000) ((>= a 10000) 1000) + ((>= a 100) 100) (t 10))) + g2) + (while (< (setq g2 (/ (+ g (/ a g)) 2)) g) + (setq g g2)) + g) + (if (eq a 0) 0 (signal 'arith-error nil)))) + +(defun cl-expt (x y) + "Return X raised to the power of Y. Works only for integer arguments." + (if (<= y 0) (if (= y 0) 1 (if (memq x '(-1 1)) (cl-expt x (- y)) 0)) + (* (if (= (% y 2) 0) 1 x) (cl-expt (* x x) (/ y 2))))) +(or (and (fboundp 'expt) (subrp (symbol-function 'expt))) + (defalias 'expt 'cl-expt)) + +(defun floor* (x &optional y) + "Return a list of the floor of X and the fractional part of X. +With two arguments, return floor and remainder of their quotient." + (let ((q (floor x y))) + (list q (- x (if y (* y q) q))))) + +(defun ceiling* (x &optional y) + "Return a list of the ceiling of X and the fractional part of X. +With two arguments, return ceiling and remainder of their quotient." + (let ((res (floor* x y))) + (if (= (car (cdr res)) 0) res + (list (1+ (car res)) (- (car (cdr res)) (or y 1)))))) + +(defun truncate* (x &optional y) + "Return a list of the integer part of X and the fractional part of X. +With two arguments, return truncation and remainder of their quotient." + (if (eq (>= x 0) (or (null y) (>= y 0))) + (floor* x y) (ceiling* x y))) + +(defun round* (x &optional y) + "Return a list of X rounded to the nearest integer and the remainder. +With two arguments, return rounding and remainder of their quotient." + (if y + (if (and (integerp x) (integerp y)) + (let* ((hy (/ y 2)) + (res (floor* (+ x hy) y))) + (if (and (= (car (cdr res)) 0) + (= (+ hy hy) y) + (/= (% (car res) 2) 0)) + (list (1- (car res)) hy) + (list (car res) (- (car (cdr res)) hy)))) + (let ((q (round (/ x y)))) + (list q (- x (* q y))))) + (if (integerp x) (list x 0) + (let ((q (round x))) + (list q (- x q)))))) + +(defun mod* (x y) + "The remainder of X divided by Y, with the same sign as Y." + (nth 1 (floor* x y))) + +(defun rem* (x y) + "The remainder of X divided by Y, with the same sign as X." + (nth 1 (truncate* x y))) + +(defun signum (a) + "Return 1 if A is positive, -1 if negative, 0 if zero." + (cond ((> a 0) 1) ((< a 0) -1) (t 0))) + + +;; Random numbers. + +(defvar *random-state*) +(defun random* (lim &optional state) + "Return a random nonnegative number less than LIM, an integer or float. +Optional second arg STATE is a random-state object." + (or state (setq state *random-state*)) + ;; 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) + (aset state 3 (setq vec (make-vector 55 nil))) + (aset vec 0 j) + (while (> (setq i (% (+ i 21) 55)) 0) + (aset vec i (setq j (prog1 k (setq k (- j k)))))) + (while (< (setq i (1+ i)) 200) (random* 2 state)))) + (let* ((i (aset state 1 (% (1+ (aref state 1)) 55))) + (j (aset state 2 (% (1+ (aref state 2)) 55))) + (n (logand 8388607 (aset vec i (- (aref vec i) (aref vec j)))))) + (if (integerp lim) + (if (<= lim 512) (% n lim) + (if (> lim 8388607) (setq n (+ (lsh n 9) (random* 512 state)))) + (let ((mask 1023)) + (while (< mask (1- lim)) (setq mask (1+ (+ mask mask)))) + (if (< (setq n (logand n mask)) lim) n (random* lim state)))) + (* (/ n '8388608e0) lim))))) + +(defun make-random-state (&optional state) + "Return a copy of random-state STATE, or of `*random-state*' if omitted. +If STATE is t, return a new state object seeded from the time of day." + (cond ((null state) (make-random-state *random-state*)) + ((vectorp state) (cl-copy-tree state t)) + ((integerp state) (vector 'cl-random-state-tag -1 30 state)) + (t (make-random-state (cl-random-time))))) + +(defun random-state-p (object) + "Return t if OBJECT is a random-state object." + (and (vectorp object) (= (length object) 4) + (eq (aref object 0) 'cl-random-state-tag))) + + +;; Implementation limits. + +(defun cl-finite-do (func a b) + (condition-case err + (let ((res (funcall func a b))) ; check for IEEE infinity + (and (numberp res) (/= res (/ res 2)) res)) + (arith-error nil))) + +(defvar most-positive-float) +(defvar most-negative-float) +(defvar least-positive-float) +(defvar least-negative-float) +(defvar least-positive-normalized-float) +(defvar least-negative-normalized-float) +(defvar float-epsilon) +(defvar float-negative-epsilon) + +(defun cl-float-limits () + (or most-positive-float (not (numberp '2e1)) + (let ((x '2e0) y z) + ;; Find maximum exponent (first two loops are optimizations) + (while (cl-finite-do '* x x) (setq x (* x x))) + (while (cl-finite-do '* x (/ x 2)) (setq x (* x (/ x 2)))) + (while (cl-finite-do '+ x x) (setq x (+ x x))) + (setq z x y (/ x 2)) + ;; Now fill in 1's in the mantissa. + (while (and (cl-finite-do '+ x y) (/= (+ x y) x)) + (setq x (+ x y) y (/ y 2))) + (setq most-positive-float x + 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)) + (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)) + (setq x (/ x 2))) + (setq least-positive-float x + least-negative-float (- x)) + (setq x '1e0) + (while (/= (+ '1e0 x) '1e0) (setq x (/ x 2))) + (setq float-epsilon (* x 2)) + (setq x '1e0) + (while (/= (- '1e0 x) '1e0) (setq x (/ x 2))) + (setq float-negative-epsilon (* x 2)))) + nil) + + +;;; Sequence functions. + +;XEmacs -- our built-in is more powerful. +;(defun subseq (seq start &optional end) +; "Return the subsequence of SEQ from START to END. +;If END is omitted, it defaults to the length of the sequence. +;If START or END is negative, it counts from the end." +; (if (stringp seq) (substring seq start end) +; (let (len) +; (and end (< end 0) (setq end (+ end (setq len (length seq))))) +; (if (< start 0) (setq start (+ start (or len (setq len (length seq)))))) +; (cond ((listp seq) +; (if (> start 0) (setq seq (nthcdr start seq))) +; (if end +; (let ((res nil)) +; (while (>= (setq end (1- end)) start) +; (cl-push (cl-pop seq) res)) +; (nreverse res)) +; (copy-sequence seq))) +; (t +; (or end (setq end (or len (length seq)))) +; (let ((res (make-vector (max (- end start) 0) nil)) +; (i 0)) +; (while (< start end) +; (aset res i (aref seq start)) +; (setq i (1+ i) start (1+ start))) +; res)))))) + +(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)))) + + +;;; List functions. + +(defun revappend (x y) + "Equivalent to (append (reverse X) Y)." + (nconc (reverse x) y)) + +(defun nreconc (x y) + "Equivalent to (nconc (nreverse X) Y)." + (nconc (nreverse x) y)) + +(defun list-length (x) + "Return the length of a list. Return nil if list is circular." + (let ((n 0) (fast x) (slow x)) + (while (and (cdr fast) (not (and (eq fast slow) (> n 0)))) + (setq n (+ n 2) fast (cdr (cdr fast)) slow (cdr slow))) + (if fast (if (cdr fast) nil (1+ n)) n))) + +(defun tailp (sublist list) + "Return true if SUBLIST is a tail of LIST." + (while (and (consp list) (not (eq sublist list))) + (setq list (cdr list))) + (if (numberp sublist) (equal sublist list) (eq sublist list))) + +(defun cl-copy-tree (tree &optional vecp) + "Make a copy of TREE. +If TREE is a cons cell, this recursively copies both its car and its cdr. +Contrast to copy-sequence, which copies only along the cdrs. With second +argument VECP, this copies vectors as well as conses." + (if (consp tree) + (let ((p (setq tree (copy-list tree)))) + (while (consp p) + (if (or (consp (car p)) (and vecp (vectorp (car p)))) + (setcar p (cl-copy-tree (car p) vecp))) + (or (listp (cdr p)) (setcdr p (cl-copy-tree (cdr p) vecp))) + (cl-pop p))) + (if (and vecp (vectorp tree)) + (let ((i (length (setq tree (copy-sequence tree))))) + (while (>= (setq i (1- i)) 0) + (aset tree i (cl-copy-tree (aref tree i) vecp)))))) + tree) +(or (and (fboundp 'copy-tree) (subrp (symbol-function 'copy-tree))) + (defalias 'copy-tree 'cl-copy-tree)) + + +;;; Property lists. + +(defun get* (sym tag &optional def) ; See compiler macro in cl-macs.el + "Return the value of SYMBOL's PROPNAME property, or DEFAULT if none." + (or (get sym tag) + (and def + (let ((plist (symbol-plist sym))) + (while (and plist (not (eq (car plist) tag))) + (setq plist (cdr (cdr plist)))) + (if plist (car (cdr plist)) def))))) + +(defun getf (plist tag &optional def) + "Search PROPLIST for property PROPNAME; return its value or DEFAULT. +PROPLIST is a list of the sort returned by `symbol-plist'." + (setplist '--cl-getf-symbol-- plist) + (or (get '--cl-getf-symbol-- tag) + (and def (get* '--cl-getf-symbol-- tag def)))) + +(defun cl-set-getf (plist tag val) + (let ((p plist)) + (while (and p (not (eq (car p) tag))) (setq p (cdr (cdr p)))) + (if p (progn (setcar (cdr p) val) plist) (list* tag val plist)))) + +(defun cl-do-remf (plist tag) + (let ((p (cdr plist))) + (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p)))) + (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t)))) + +(defun cl-remprop (sym tag) + "Remove from SYMBOL's plist the property PROP and its value." + (let ((plist (symbol-plist sym))) + (if (and plist (eq tag (car plist))) + (progn (setplist sym (cdr (cdr plist))) t) + (cl-do-remf plist tag)))) +(or (and (fboundp 'remprop) (subrp (symbol-function 'remprop))) + (defalias 'remprop 'cl-remprop)) + + + +;;; 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 (eq (car-safe x) 'cl-hash-table-tag) + (and (vectorp x) (= (length x) 4) (eq (aref x 0) cl-lucid-hash-tag)) + (and (fboundp 'hashtablep) (funcall 'hashtablep x)))) + +(defun cl-not-hash-table (x &optional y &rest z) + (signal 'wrong-type-argument (list 'hash-table-p (or y x)))) + +(defun cl-hash-lookup (key table) + (or (eq (car-safe table) 'cl-hash-table-tag) (cl-not-hash-table table)) + (let* ((array (nth 2 table)) (test (car (cdr table))) (str key) sym) + (if (symbolp array) (setq str nil sym (symbol-value array)) + (while (or (consp str) (and (vectorp str) (> (length str) 0))) + (setq str (elt str 0))) + (cond ((stringp str) (if (eq test 'equalp) (setq str (downcase str)))) + ((symbolp str) (setq str (symbol-name str))) + ((and (numberp str) (> str -8000000) (< str 8000000)) + (or (integerp str) (setq str (truncate str))) + (setq str (aref ["0" "1" "2" "3" "4" "5" "6" "7" "8" "9" "10" + "11" "12" "13" "14" "15"] (logand str 15)))) + (t (setq str "*"))) + (setq sym (symbol-value (intern-soft str array)))) + (list (and sym (cond ((or (eq test 'eq) + (and (eq test 'eql) (not (numberp key)))) + (assq key sym)) + ((memq test '(eql equal)) (assoc key sym)) + (t (assoc* key sym ':test test)))) + sym str))) + +(defvar cl-builtin-gethash + (if (and (fboundp 'gethash) (subrp (symbol-function 'gethash))) + (symbol-function 'gethash) 'cl-not-hash-table)) +(defvar cl-builtin-remhash + (if (and (fboundp 'remhash) (subrp (symbol-function 'remhash))) + (symbol-function 'remhash) 'cl-not-hash-table)) +(defvar cl-builtin-clrhash + (if (and (fboundp 'clrhash) (subrp (symbol-function 'clrhash))) + (symbol-function 'clrhash) 'cl-not-hash-table)) +(defvar cl-builtin-maphash + (if (and (fboundp 'maphash) (subrp (symbol-function 'maphash))) + (symbol-function 'maphash) 'cl-not-hash-table)) + +(defun cl-gethash (key table &optional def) + "Look up KEY in HASH-TABLE; return corresponding value, or DEFAULT." + (if (consp table) + (let ((found (cl-hash-lookup key table))) + (if (car found) (cdr (car found)) def)) + (funcall cl-builtin-gethash key table def))) +(defalias 'gethash 'cl-gethash) + +(defun cl-puthash (key val table) + (if (consp table) + (let ((found (cl-hash-lookup key table))) + (if (car found) (setcdr (car found) val) + (if (nth 2 found) + (progn + (if (> (nth 3 table) (* (length (nth 2 table)) 3)) + (let ((new-table (make-vector (nth 3 table) 0))) + (mapatoms (function + (lambda (sym) + (set (intern (symbol-name sym) new-table) + (symbol-value sym)))) + (nth 2 table)) + (setcar (cdr (cdr table)) new-table))) + (set (intern (nth 2 found) (nth 2 table)) + (cons (cons key val) (nth 1 found)))) + (set (nth 2 table) (cons (cons key val) (nth 1 found)))) + (setcar (cdr (cdr (cdr table))) (1+ (nth 3 table))))) + (funcall 'puthash key val table)) val) + +(defun cl-remhash (key table) + "Remove KEY from HASH-TABLE." + (if (consp table) + (let ((found (cl-hash-lookup key table))) + (and (car found) + (let ((del (delq (car found) (nth 1 found)))) + (setcar (cdr (cdr (cdr table))) (1- (nth 3 table))) + (if (nth 2 found) (set (intern (nth 2 found) (nth 2 table)) del) + (set (nth 2 table) del)) t))) + (prog1 (not (eq (funcall cl-builtin-gethash key table '--cl--) '--cl--)) + (funcall cl-builtin-remhash key table)))) +(defalias 'remhash 'cl-remhash) + +(defun cl-clrhash (table) + "Clear HASH-TABLE." + (if (consp table) + (progn + (or (hash-table-p table) (cl-not-hash-table table)) + (if (symbolp (nth 2 table)) (set (nth 2 table) nil) + (setcar (cdr (cdr table)) (make-vector (length (nth 2 table)) 0))) + (setcar (cdr (cdr (cdr table))) 0)) + (funcall cl-builtin-clrhash table)) + nil) +(defalias 'clrhash 'cl-clrhash) + +(defun cl-maphash (cl-func cl-table) + "Call FUNCTION on keys and values from HASH-TABLE." + (or (hash-table-p cl-table) (cl-not-hash-table cl-table)) + (if (consp cl-table) + (mapatoms (function (lambda (cl-x) + (setq cl-x (symbol-value cl-x)) + (while cl-x + (funcall cl-func (car (car cl-x)) + (cdr (car cl-x))) + (setq cl-x (cdr cl-x))))) + (if (symbolp (nth 2 cl-table)) + (vector (nth 2 cl-table)) (nth 2 cl-table))) + (funcall cl-builtin-maphash cl-func cl-table))) +(defalias 'maphash 'cl-maphash) + +(defun hash-table-count (table) + "Return the number of entries in HASH-TABLE." + (or (hash-table-p table) (cl-not-hash-table table)) + (if (consp table) (nth 3 table) (funcall 'hashtable-fullness table))) + + +;;; Some debugging aids. + +(defun cl-prettyprint (form) + "Insert a pretty-printed rendition of a Lisp FORM in current buffer." + (let ((pt (point)) last) + (insert "\n" (prin1-to-string form) "\n") + (setq last (point)) + (goto-char (1+ pt)) + (while (search-forward "(quote " last t) + (delete-backward-char 7) + (insert "'") + (forward-sexp) + (delete-char 1)) + (goto-char (1+ pt)) + (cl-do-prettyprint))) + +(defun cl-do-prettyprint () + (skip-chars-forward " ") + (if (looking-at "(") + (let ((skip (or (looking-at "((") (looking-at "(prog") + (looking-at "(unwind-protect ") + (looking-at "(function (") + (looking-at "(cl-block-wrapper "))) + (two (or (looking-at "(defun ") (looking-at "(defmacro "))) + (let (or (looking-at "(let\\*? ") (looking-at "(while "))) + (set (looking-at "(p?set[qf] "))) + (if (or skip let + (progn + (forward-sexp) + (and (>= (current-column) 78) (progn (backward-sexp) t)))) + (let ((nl t)) + (forward-char 1) + (cl-do-prettyprint) + (or skip (looking-at ")") (cl-do-prettyprint)) + (or (not two) (looking-at ")") (cl-do-prettyprint)) + (while (not (looking-at ")")) + (if set (setq nl (not nl))) + (if nl (insert "\n")) + (lisp-indent-line) + (cl-do-prettyprint)) + (forward-char 1)))) + (forward-sexp))) + +(defvar cl-macroexpand-cmacs nil) +(defvar cl-closure-vars nil) + +(defun cl-macroexpand-all (form &optional env) + "Expand all macro calls through a Lisp FORM. +This also does some trivial optimizations to make the form prettier." + (while (or (not (eq form (setq form (macroexpand form env)))) + (and cl-macroexpand-cmacs + (not (eq form (setq form (compiler-macroexpand form))))))) + (cond ((not (consp form)) form) + ((memq (car form) '(let let*)) + (if (null (nth 1 form)) + (cl-macroexpand-all (cons 'progn (cddr form)) env) + (let ((letf nil) (res nil) (lets (cadr form))) + (while lets + (cl-push (if (consp (car lets)) + (let ((exp (cl-macroexpand-all (caar lets) env))) + (or (symbolp exp) (setq letf t)) + (cons exp (cl-macroexpand-body (cdar lets) env))) + (let ((exp (cl-macroexpand-all (car lets) env))) + (if (symbolp exp) exp + (setq letf t) (list exp nil)))) res) + (setq lets (cdr lets))) + (list* (if letf (if (eq (car form) 'let) 'letf 'letf*) (car form)) + (nreverse res) (cl-macroexpand-body (cddr form) env))))) + ((eq (car form) 'cond) + (cons (car form) + (mapcar (function (lambda (x) (cl-macroexpand-body x env))) + (cdr form)))) + ((eq (car form) 'condition-case) + (list* (car form) (nth 1 form) (cl-macroexpand-all (nth 2 form) env) + (mapcar (function + (lambda (x) + (cons (car x) (cl-macroexpand-body (cdr x) env)))) + (cdddr form)))) + ((memq (car form) '(quote function)) + (if (eq (car-safe (nth 1 form)) 'lambda) + (let ((body (cl-macroexpand-body (cddadr form) env))) + (if (and cl-closure-vars (eq (car form) 'function) + (cl-expr-contains-any body cl-closure-vars)) + (let* ((new (mapcar 'gensym cl-closure-vars)) + (sub (pairlis cl-closure-vars new)) (decls nil)) + (while (or (stringp (car body)) + (eq (car-safe (car body)) 'interactive)) + (cl-push (list 'quote (cl-pop body)) decls)) + (put (car (last cl-closure-vars)) 'used t) + (append + (list 'list '(quote lambda) '(quote (&rest --cl-rest--))) + (sublis sub (nreverse decls)) + (list + (list* 'list '(quote apply) + (list 'list '(quote quote) + (list 'function + (list* 'lambda + (append new (cadadr form)) + (sublis sub body)))) + (nconc (mapcar (function + (lambda (x) + (list 'list '(quote quote) x))) + cl-closure-vars) + '((quote --cl-rest--))))))) + (list (car form) (list* 'lambda (cadadr form) body)))) + (let ((found (assq (cadr form) env))) + (if (eq (cadr (caddr found)) 'cl-labels-args) + (cl-macroexpand-all (cadr (caddr (cadddr found))) env) + form)))) + ((memq (car form) '(defun defmacro)) + (list* (car form) (nth 1 form) (cl-macroexpand-body (cddr form) env))) + ((and (eq (car form) 'progn) (not (cddr form))) + (cl-macroexpand-all (nth 1 form) env)) + ((eq (car form) 'setq) + (let* ((args (cl-macroexpand-body (cdr form) env)) (p args)) + (while (and p (symbolp (car p))) (setq p (cddr p))) + (if p (cl-macroexpand-all (cons 'setf args)) (cons 'setq args)))) + (t (cons (car form) (cl-macroexpand-body (cdr form) env))))) + +(defun cl-macroexpand-body (body &optional env) + (mapcar (function (lambda (x) (cl-macroexpand-all x env))) body)) + +(defun cl-prettyexpand (form &optional full) + (message "Expanding...") + (let ((cl-macroexpand-cmacs full) (cl-compiling-file full) + (byte-compile-macro-environment nil)) + (setq form (cl-macroexpand-all form + (and (not full) '((block) (eval-when))))) + (message "Formatting...") + (prog1 (cl-prettyprint form) + (message "")))) + + + +(run-hooks 'cl-extra-load-hook) + +(provide 'cl-extra) + +;;; cl-extra.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cl-macs.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,2766 @@ +;;; cl-macs.el --- Common Lisp extensions for GNU Emacs Lisp (part four) + +;; Copyright (C) 1993 Free Software Foundation, Inc. + +;; Author: Dave Gillespie <daveg@synaptics.com> +;; Version: 2.02 +;; Keywords: extensions + +;; 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.34. + +;;; Commentary: + +;; These are extensions to Emacs Lisp that provide a degree of +;; Common Lisp compatibility, beyond what is already built-in +;; in Emacs Lisp. +;; +;; This package was written by Dave Gillespie; it is a complete +;; rewrite of Cesar Quiroz's original cl.el package of December 1986. +;; +;; This package works with Emacs 18, Emacs 19, and Lucid Emacs 19. +;; +;; Bug reports, comments, and suggestions are welcome! + +;; This file contains the portions of the Common Lisp extensions +;; package which should be autoloaded, but need only be present +;; if the compiler or interpreter is used---this file is not +;; necessary for executing compiled code. + +;; See cl.el for Change Log. + + +;;; Code: + +(or (memq 'cl-19 features) + (error "Tried to load `cl-macs' before `cl'!")) + + +;;; We define these here so that this file can compile without having +;;; loaded the cl.el file already. + +(defmacro cl-push (x place) (list 'setq place (list 'cons x place))) +(defmacro cl-pop (place) + (list 'car (list 'prog1 place (list 'setq place (list 'cdr place))))) +(defmacro cl-pop2 (place) + (list 'prog1 (list 'car (list 'cdr place)) + (list 'setq place (list 'cdr (list 'cdr place))))) +(put 'cl-push 'edebug-form-spec 'edebug-sexps) +(put 'cl-pop 'edebug-form-spec 'edebug-sexps) +(put 'cl-pop2 'edebug-form-spec 'edebug-sexps) + +(defvar cl-emacs-type) +(defvar cl-optimize-safety) +(defvar cl-optimize-speed) + + +;;; This kludge allows macros which use cl-transform-function-property +;;; to be called at compile-time. + +(require + (progn + (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))))))) + (car (or features (setq features (list 'cl-kludge)))))) + + +;;; Initialization. + +(defvar cl-old-bc-file-form nil) + +;; Patch broken Emacs 18 compiler (re top-level macros). +;; Emacs 19 compiler doesn't need this patch. +;; Also, undo broken definition of `eql' that uses same bytecode as `eq'. + +;;;###autoload +(defun cl-compile-time-init () + (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)))))) + (put 'eql 'byte-compile 'cl-byte-compile-compiler-macro) + (run-hooks 'cl-hack-bytecomp-hook)) + + +;;; Symbols. + +(defvar *gensym-counter*) + +;;;###autoload +(defun gensym (&optional arg) + "Generate a new uninterned symbol. +The name is made by appending a number to PREFIX, default \"G\"." + (let ((prefix (if (stringp arg) arg "G")) + (num (if (integerp arg) arg + (prog1 *gensym-counter* + (setq *gensym-counter* (1+ *gensym-counter*)))))) + (make-symbol (format "%s%d" prefix num)))) + +;;;###autoload +(defun gentemp (&optional arg) + "Generate a new interned symbol with a unique name. +The name is made by appending a number to PREFIX, default \"G\"." + (let ((prefix (if (stringp arg) arg "G")) + name) + (while (intern-soft (setq name (format "%s%d" prefix *gensym-counter*))) + (setq *gensym-counter* (1+ *gensym-counter*))) + (intern name))) + + +;;; Program structure. + +;;;###autoload +(defmacro defun* (name args &rest body) + "(defun* NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function. +Like normal `defun', except ARGLIST allows full Common Lisp conventions, +and BODY is implicitly surrounded by (block NAME ...)." + (let* ((res (cl-transform-lambda (cons args body) name)) + (form (list* 'defun name (cdr res)))) + (if (car res) (list 'progn (car res) form) form))) + +;;;###autoload +(defmacro defmacro* (name args &rest body) + "(defmacro* NAME ARGLIST [DOCSTRING] BODY...): define NAME as a macro. +Like normal `defmacro', except ARGLIST allows full Common Lisp conventions, +and BODY is implicitly surrounded by (block NAME ...)." + (let* ((res (cl-transform-lambda (cons args body) name)) + (form (list* 'defmacro name (cdr res)))) + (if (car res) (list 'progn (car res) form) form))) + +;;;###autoload +(defmacro function* (func) + "(function* SYMBOL-OR-LAMBDA): introduce a function. +Like normal `function', except that if argument is a lambda form, its +ARGLIST allows full Common Lisp conventions." + (if (eq (car-safe func) 'lambda) + (let* ((res (cl-transform-lambda (cdr func) 'cl-none)) + (form (list 'function (cons 'lambda (cdr res))))) + (if (car res) (list 'progn (car res) form) form)) + (list 'function func))) + +(defun cl-transform-function-property (func prop form) + (let ((res (cl-transform-lambda form func))) + (append '(progn) (cdr (cdr (car res))) + (list (list 'put (list 'quote func) (list 'quote prop) + (list 'function (cons 'lambda (cdr res)))))))) + +(defconst lambda-list-keywords + '(&optional &rest &key &allow-other-keys &aux &whole &body &environment)) + +(defvar cl-macro-environment nil) +(defvar bind-block) (defvar bind-defs) (defvar bind-enquote) +(defvar bind-inits) (defvar bind-lets) (defvar bind-forms) + +(defun cl-transform-lambda (form bind-block) + (let* ((args (car form)) (body (cdr form)) + (bind-defs nil) (bind-enquote nil) + (bind-inits nil) (bind-lets nil) (bind-forms nil) + (header nil) (simple-args nil)) + (while (or (stringp (car body)) (eq (car-safe (car body)) 'interactive)) + (cl-push (cl-pop body) header)) + (setq args (if (listp args) (copy-list args) (list '&rest args))) + (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p))))) + (if (setq bind-defs (cadr (memq '&cl-defs args))) + (setq args (delq '&cl-defs (delq bind-defs args)) + bind-defs (cadr bind-defs))) + (if (setq bind-enquote (memq '&cl-quote args)) + (setq args (delq '&cl-quote args))) + (if (memq '&whole args) (error "&whole not currently implemented")) + (let* ((p (memq '&environment args)) (v (cadr p))) + (if p (setq args (nconc (delq (car p) (delq v args)) + (list '&aux (list v 'cl-macro-environment)))))) + (while (and args (symbolp (car args)) + (not (memq (car args) '(nil &rest &body &key &aux))) + (not (and (eq (car args) '&optional) + (or bind-defs (consp (cadr args)))))) + (cl-push (cl-pop args) simple-args)) + (or (eq bind-block 'cl-none) + (setq body (list (list* 'block bind-block body)))) + (if (null args) + (list* nil (nreverse simple-args) (nconc (nreverse header) body)) + (if (memq '&optional simple-args) (cl-push '&optional args)) + (cl-do-arglist args nil (- (length simple-args) + (if (memq '&optional simple-args) 1 0))) + (setq bind-lets (nreverse bind-lets)) + (list* (and bind-inits (list* 'eval-when '(compile load eval) + (nreverse bind-inits))) + (nconc (nreverse simple-args) + (list '&rest (car (cl-pop bind-lets)))) + (nconc (nreverse header) + (list (nconc (list 'let* bind-lets) + (nreverse bind-forms) body))))))) + +(defun cl-do-arglist (args expr &optional num) ; uses bind-* + (if (nlistp args) + (if (or (memq args lambda-list-keywords) (not (symbolp args))) + (error "Invalid argument name: %s" args) + (cl-push (list args expr) bind-lets)) + (setq args (copy-list args)) + (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p))))) + (let ((p (memq '&body args))) (if p (setcar p '&rest))) + (if (memq '&environment args) (error "&environment used incorrectly")) + (let ((save-args args) + (restarg (memq '&rest args)) + (safety (if (cl-compiling-file) cl-optimize-safety 3)) + (keys nil) + (laterarg nil) (exactarg nil) minarg) + (or num (setq num 0)) + (if (listp (cadr restarg)) + (setq restarg (gensym "--rest--")) + (setq restarg (cadr restarg))) + (cl-push (list restarg expr) bind-lets) + (if (eq (car args) '&whole) + (cl-push (list (cl-pop2 args) restarg) bind-lets)) + (let ((p args)) + (setq minarg restarg) + (while (and p (not (memq (car p) lambda-list-keywords))) + (or (eq p args) (setq minarg (list 'cdr minarg))) + (setq p (cdr p))) + (if (memq (car p) '(nil &aux)) + (setq minarg (list '= (list 'length restarg) + (length (ldiff args p))) + exactarg (not (eq args p))))) + (while (and args (not (memq (car args) lambda-list-keywords))) + (let ((poparg (list (if (or (cdr args) (not exactarg)) 'pop 'car) + restarg))) + (cl-do-arglist + (cl-pop args) + (if (or laterarg (= safety 0)) poparg + (list 'if minarg poparg + (list 'signal '(quote wrong-number-of-arguments) + (list 'list (and (not (eq bind-block 'cl-none)) + (list 'quote bind-block)) + (list 'length restarg))))))) + (setq num (1+ num) laterarg t)) + (while (and (eq (car args) '&optional) (cl-pop args)) + (while (and args (not (memq (car args) lambda-list-keywords))) + (let ((arg (cl-pop args))) + (or (consp arg) (setq arg (list arg))) + (if (cddr arg) (cl-do-arglist (nth 2 arg) (list 'and restarg t))) + (let ((def (if (cdr arg) (nth 1 arg) + (or (car bind-defs) + (nth 1 (assq (car arg) bind-defs))))) + (poparg (list 'pop restarg))) + (and def bind-enquote (setq def (list 'quote def))) + (cl-do-arglist (car arg) + (if def (list 'if restarg poparg def) poparg)) + (setq num (1+ num)))))) + (if (eq (car args) '&rest) + (let ((arg (cl-pop2 args))) + (if (consp arg) (cl-do-arglist arg restarg))) + (or (eq (car args) '&key) (= safety 0) exactarg + (cl-push (list 'if restarg + (list 'signal '(quote wrong-number-of-arguments) + (list 'list + (and (not (eq bind-block 'cl-none)) + (list 'quote bind-block)) + (list '+ num (list 'length restarg))))) + bind-forms))) + (while (and (eq (car args) '&key) (cl-pop args)) + (while (and args (not (memq (car args) lambda-list-keywords))) + (let ((arg (cl-pop args))) + (or (consp arg) (setq arg (list arg))) + (let* ((karg (if (consp (car arg)) (caar arg) + (intern (format ":%s" (car arg))))) + (varg (if (consp (car arg)) (cadar arg) (car arg))) + (def (if (cdr arg) (cadr arg) + (or (car bind-defs) (cadr (assq varg bind-defs))))) + (look (list 'memq (list 'quote karg) restarg))) + (and def bind-enquote (setq def (list 'quote def))) + (if (cddr arg) + (let* ((temp (or (nth 2 arg) (gensym))) + (val (list 'car (list 'cdr temp)))) + (cl-do-arglist temp look) + (cl-do-arglist varg + (list 'if temp + (list 'prog1 val (list 'setq temp t)) + def))) + (cl-do-arglist + varg + (list 'car + (list 'cdr + (if (null def) + look + (list 'or look + (if (eq (cl-const-expr-p def) t) + (list + 'quote + (list nil (cl-const-expr-val def))) + (list 'list nil def)))))))) + (cl-push karg keys) + (if (= (aref (symbol-name karg) 0) ?:) + (progn (set karg karg) + (cl-push (list 'setq karg (list 'quote karg)) + bind-inits))))))) + (setq keys (nreverse keys)) + (or (and (eq (car args) '&allow-other-keys) (cl-pop args)) + (null keys) (= safety 0) + (let* ((var (gensym "--keys--")) + (allow '(:allow-other-keys)) + (check (list + 'while var + (list + 'cond + (list (list 'memq (list 'car var) + (list 'quote (append keys allow))) + (list 'setq var (list 'cdr (list 'cdr var)))) + (list (list 'car + (list 'cdr + (list 'memq (cons 'quote allow) + restarg))) + (list 'setq var nil)) + (list t + (list + 'error + (format "Keyword argument %%s not one of %s" + keys) + (list 'car var))))))) + (cl-push (list 'let (list (list var restarg)) check) bind-forms))) + (while (and (eq (car args) '&aux) (cl-pop args)) + (while (and args (not (memq (car args) lambda-list-keywords))) + (if (consp (car args)) + (if (and bind-enquote (cadar args)) + (cl-do-arglist (caar args) + (list 'quote (cadr (cl-pop args)))) + (cl-do-arglist (caar args) (cadr (cl-pop args)))) + (cl-do-arglist (cl-pop args) nil)))) + (if args (error "Malformed argument list %s" save-args))))) + +(defun cl-arglist-args (args) + (if (nlistp args) (list args) + (let ((res nil) (kind nil) arg) + (while (consp args) + (setq arg (cl-pop args)) + (if (memq arg lambda-list-keywords) (setq kind arg) + (if (eq arg '&cl-defs) (cl-pop args) + (and (consp arg) kind (setq arg (car arg))) + (and (consp arg) (cdr arg) (eq kind '&key) (setq arg (cadr arg))) + (setq res (nconc res (cl-arglist-args arg)))))) + (nconc res (and args (list args)))))) + +;;;###autoload +(defmacro destructuring-bind (args expr &rest body) + (let* ((bind-lets nil) (bind-forms nil) (bind-inits nil) + (bind-defs nil) (bind-block 'cl-none)) + (cl-do-arglist (or args '(&aux)) expr) + (append '(progn) bind-inits + (list (nconc (list 'let* (nreverse bind-lets)) + (nreverse bind-forms) body))))) + + +;;; The `eval-when' form. + +(defvar cl-not-toplevel nil) + +;;;###autoload +(defmacro eval-when (when &rest body) + "(eval-when (WHEN...) BODY...): control when BODY is evaluated. +If `compile' is in WHEN, BODY is evaluated when compiled at top-level. +If `load' is in WHEN, BODY is evaluated when loaded after top-level compile. +If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level." + (if (and (fboundp 'cl-compiling-file) (cl-compiling-file) + (not cl-not-toplevel) (not (boundp 'for-effect))) ; horrible kludge + (let ((comp (or (memq 'compile when) (memq ':compile-toplevel when))) + (cl-not-toplevel t)) + (if (or (memq 'load when) (memq ':load-toplevel when)) + (if comp (cons 'progn (mapcar 'cl-compile-time-too body)) + (list* 'if nil nil body)) + (progn (if comp (eval (cons 'progn body))) nil))) + (and (or (memq 'eval when) (memq ':execute when)) + (cons 'progn body)))) + +(defun cl-compile-time-too (form) + (or (and (symbolp (car-safe form)) (get (car-safe form) 'byte-hunk-handler)) + (setq form (macroexpand + form (cons '(eval-when) byte-compile-macro-environment)))) + (cond ((eq (car-safe form) 'progn) + (cons 'progn (mapcar 'cl-compile-time-too (cdr form)))) + ((eq (car-safe form) 'eval-when) + (let ((when (nth 1 form))) + (if (or (memq 'eval when) (memq ':execute when)) + (list* 'eval-when (cons 'compile when) (cddr form)) + form))) + (t (eval form) form))) + +(or (and (fboundp 'eval-when-compile) + (not (eq (car-safe (symbol-function 'eval-when-compile)) 'autoload))) + (eval '(defmacro eval-when-compile (&rest body) + "Like `progn', but evaluates the body at compile time. +The result of the body appears to the compiler as a quoted constant." + (list 'quote (eval (cons 'progn body)))))) + +;;;###autoload +(defmacro load-time-value (form &optional read-only) + "Like `progn', but evaluates the body at load time. +The result of the body appears to the compiler as a quoted constant." + (if (cl-compiling-file) + (let* ((temp (gentemp "--cl-load-time--")) + (set (list 'set (list 'quote temp) form))) + (if (and (fboundp 'byte-compile-file-form-defmumble) + (boundp 'this-kind) (boundp 'that-one)) + (fset 'byte-compile-file-form + (list 'lambda '(form) + (list 'fset '(quote byte-compile-file-form) + (list 'quote + (symbol-function 'byte-compile-file-form))) + (list 'byte-compile-file-form (list 'quote set)) + '(byte-compile-file-form form))) + ;; XEmacs change + (print set (symbol-value ;;'outbuffer + 'byte-compile-output-buffer + ))) + (list 'symbol-value (list 'quote temp))) + (list 'quote (eval form)))) + + +;;; Conditional control structures. + +;;;###autoload +(defmacro case (expr &rest clauses) + "(case EXPR CLAUSES...): evals EXPR, chooses from CLAUSES on that value. +Each clause looks like (KEYLIST BODY...). EXPR is evaluated and compared +against each key in each KEYLIST; the corresponding BODY is evaluated. +If no clause succeeds, case returns nil. A single atom may be used in +place of a KEYLIST of one atom. A KEYLIST of `t' or `otherwise' is +allowed only in the final clause, and matches if no other keys match. +Key values are compared by `eql'." + (let* ((temp (if (cl-simple-expr-p expr 3) expr (gensym))) + (head-list nil) + (body (cons + 'cond + (mapcar + (function + (lambda (c) + (cons (cond ((memq (car c) '(t otherwise)) 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)))) + +;;;###autoload +(defmacro ecase (expr &rest clauses) + "(ecase EXPR CLAUSES...): like `case', but error if no case fits. +`otherwise'-clauses are not allowed." + (list* 'case expr (append clauses '((ecase-error-flag))))) + +;;;###autoload +(defmacro typecase (expr &rest clauses) + "(typecase EXPR CLAUSES...): evals EXPR, chooses from CLAUSES on that value. +Each clause looks like (TYPE BODY...). EXPR is evaluated and, if it +satisfies TYPE, the corresponding BODY is evaluated. If no clause succeeds, +typecase returns nil. A TYPE of `t' or `otherwise' is allowed only in the +final clause, and matches if no other keys match." + (let* ((temp (if (cl-simple-expr-p expr 3) expr (gensym))) + (type-list nil) + (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))))) + clauses)))) + (if (eq temp expr) body + (list 'let (list (list temp expr)) body)))) + +;;;###autoload +(defmacro etypecase (expr &rest clauses) + "(etypecase EXPR CLAUSES...): like `typecase', but error if no case fits. +`otherwise'-clauses are not allowed." + (list* 'typecase expr (append clauses '((ecase-error-flag))))) + + +;;; Blocks and exits. + +;;;###autoload +(defmacro block (name &rest body) + "(block NAME BODY...): define a lexically-scoped block named NAME. +NAME may be any symbol. Code inside the BODY forms can call `return-from' +to jump prematurely out of the block. This differs from `catch' and `throw' +in two respects: First, the NAME is an unevaluated symbol rather than a +quoted symbol or other form; and second, NAME is lexically rather than +dynamically scoped: Only references to it within BODY will work. These +references may appear inside macro expansions, but not inside functions +called from BODY." + (if (cl-safe-expr-p (cons 'progn body)) (cons 'progn body) + (list 'cl-block-wrapper + (list* 'catch (list 'quote (intern (format "--cl-block-%s--" name))) + body)))) + +(defvar cl-active-block-names nil) + +(put 'cl-block-wrapper 'byte-compile 'cl-byte-compile-block) +(defun cl-byte-compile-block (cl-form) + (if (fboundp 'byte-compile-form-do-effect) ; Check for optimizing compiler + (progn + (let* ((cl-entry (cons (nth 1 (nth 1 (nth 1 cl-form))) nil)) + (cl-active-block-names (cons cl-entry cl-active-block-names)) + (cl-body (byte-compile-top-level + (cons 'progn (cddr (nth 1 cl-form)))))) + (if (cdr cl-entry) + (byte-compile-form (list 'catch (nth 1 (nth 1 cl-form)) cl-body)) + (byte-compile-form cl-body)))) + (byte-compile-form (nth 1 cl-form)))) + +(put 'cl-block-throw 'byte-compile 'cl-byte-compile-throw) +(defun cl-byte-compile-throw (cl-form) + (let ((cl-found (assq (nth 1 (nth 1 cl-form)) cl-active-block-names))) + (if cl-found (setcdr cl-found t))) + (byte-compile-normal-call (cons 'throw (cdr cl-form)))) + +;;;###autoload +(defmacro return (&optional res) + "(return [RESULT]): return from the block named nil. +This is equivalent to `(return-from nil RESULT)'." + (list 'return-from nil res)) + +;;;###autoload +(defmacro return-from (name &optional res) + "(return-from NAME [RESULT]): return from the block named NAME. +This jump out to the innermost enclosing `(block NAME ...)' form, +returning RESULT from that form (or nil if RESULT is omitted). +This is compatible with Common Lisp, but note that `defun' and +`defmacro' do not create implicit blocks as they do in Common Lisp." + (let ((name2 (intern (format "--cl-block-%s--" name)))) + (list 'cl-block-throw (list 'quote name2) res))) + + +;;; The "loop" macro. + +(defvar args) (defvar loop-accum-var) (defvar loop-accum-vars) +(defvar loop-bindings) (defvar loop-body) (defvar loop-destr-temps) +(defvar loop-finally) (defvar loop-finish-flag) (defvar loop-first-flag) +(defvar loop-initially) (defvar loop-map-form) (defvar loop-name) +(defvar loop-result) (defvar loop-result-explicit) +(defvar loop-result-var) (defvar loop-steps) (defvar loop-symbol-macs) + +;;;###autoload +(defmacro loop (&rest args) + "(loop CLAUSE...): The Common Lisp `loop' macro. +Valid clauses are: + for VAR from/upfrom/downfrom NUM to/upto/downto/above/below NUM by NUM, + for VAR in LIST by FUNC, for VAR on LIST by FUNC, for VAR = INIT then EXPR, + for VAR across ARRAY, repeat NUM, with VAR = INIT, while COND, until COND, + always COND, never COND, thereis COND, collect EXPR into VAR, + append EXPR into VAR, nconc EXPR into VAR, sum EXPR into VAR, + count EXPR into VAR, maximize EXPR into VAR, minimize EXPR into VAR, + if COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...], + unless COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...], + do EXPRS..., initially EXPRS..., finally EXPRS..., return EXPR, + finally return EXPR, named NAME." + (if (not (memq t (mapcar 'symbolp (delq nil (delq t (copy-list args)))))) + (list 'block nil (list* 'while t args)) + (let ((loop-name nil) (loop-bindings nil) + (loop-body nil) (loop-steps nil) + (loop-result nil) (loop-result-explicit nil) + (loop-result-var nil) (loop-finish-flag nil) + (loop-accum-var nil) (loop-accum-vars nil) + (loop-initially nil) (loop-finally nil) + (loop-map-form nil) (loop-first-flag nil) + (loop-destr-temps nil) (loop-symbol-macs nil)) + (setq args (append args '(cl-end-loop))) + (while (not (eq (car args) 'cl-end-loop)) (cl-parse-loop-clause)) + (if loop-finish-flag + (cl-push (list (list loop-finish-flag t)) loop-bindings)) + (if loop-first-flag + (progn (cl-push (list (list loop-first-flag t)) loop-bindings) + (cl-push (list 'setq loop-first-flag nil) loop-steps))) + (let* ((epilogue (nconc (nreverse loop-finally) + (list (or loop-result-explicit loop-result)))) + (ands (cl-loop-build-ands (nreverse loop-body))) + (while-body (nconc (cadr ands) (nreverse loop-steps))) + (body (append + (nreverse loop-initially) + (list (if loop-map-form + (list 'block '--cl-finish-- + (subst + (if (eq (car ands) t) while-body + (cons (list 'or (car ands) + '(return-from --cl-finish-- + nil)) + while-body)) + '--cl-map loop-map-form)) + (list* 'while (car ands) while-body))) + (if loop-finish-flag + (if (equal epilogue '(nil)) (list loop-result-var) + (list (list 'if loop-finish-flag + (cons 'progn epilogue) loop-result-var))) + epilogue)))) + (if loop-result-var (cl-push (list loop-result-var) loop-bindings)) + (while loop-bindings + (if (cdar loop-bindings) + (setq body (list (cl-loop-let (cl-pop loop-bindings) body t))) + (let ((lets nil)) + (while (and loop-bindings + (not (cdar loop-bindings))) + (cl-push (car (cl-pop loop-bindings)) lets)) + (setq body (list (cl-loop-let lets body nil)))))) + (if loop-symbol-macs + (setq body (list (list* 'symbol-macrolet loop-symbol-macs body)))) + (list* 'block loop-name body))))) + +(defun cl-parse-loop-clause () ; uses args, loop-* + (let ((word (cl-pop args)) + (hash-types '(hash-key hash-keys hash-value hash-values)) + (key-types '(key-code key-codes key-seq key-seqs + key-binding key-bindings))) + (cond + + ((null args) + (error "Malformed `loop' macro")) + + ((eq word 'named) + (setq loop-name (cl-pop args))) + + ((eq word 'initially) + (if (memq (car args) '(do doing)) (cl-pop args)) + (or (consp (car args)) (error "Syntax error on `initially' clause")) + (while (consp (car args)) + (cl-push (cl-pop args) loop-initially))) + + ((eq word 'finally) + (if (eq (car args) 'return) + (setq loop-result-explicit (or (cl-pop2 args) '(quote nil))) + (if (memq (car args) '(do doing)) (cl-pop args)) + (or (consp (car args)) (error "Syntax error on `finally' clause")) + (if (and (eq (caar args) 'return) (null loop-name)) + (setq loop-result-explicit (or (nth 1 (cl-pop args)) '(quote nil))) + (while (consp (car args)) + (cl-push (cl-pop args) loop-finally))))) + + ((memq word '(for as)) + (let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil) + (ands nil)) + (while + (let ((var (or (cl-pop args) (gensym)))) + (setq word (cl-pop args)) + (if (eq word 'being) (setq word (cl-pop args))) + (if (memq word '(the each)) (setq word (cl-pop args))) + (if (memq word '(buffer buffers)) + (setq word 'in args (cons '(buffer-list) args))) + (cond + + ((memq word '(from downfrom upfrom to downto upto + above below by)) + (cl-push word args) + (if (memq (car args) '(downto above)) + (error "Must specify `from' value for downward loop")) + (let* ((down (or (eq (car args) 'downfrom) + (memq (caddr args) '(downto above)))) + (excl (or (memq (car args) '(above below)) + (memq (caddr args) '(above below)))) + (start (and (memq (car args) '(from upfrom downfrom)) + (cl-pop2 args))) + (end (and (memq (car args) + '(to upto downto above below)) + (cl-pop2 args))) + (step (and (eq (car args) 'by) (cl-pop2 args))) + (end-var (and (not (cl-const-expr-p end)) (gensym))) + (step-var (and (not (cl-const-expr-p step)) + (gensym)))) + (and step (numberp step) (<= step 0) + (error "Loop `by' value is not positive: %s" step)) + (cl-push (list var (or start 0)) loop-for-bindings) + (if end-var (cl-push (list end-var end) loop-for-bindings)) + (if step-var (cl-push (list step-var step) + loop-for-bindings)) + (if end + (cl-push (list + (if down (if excl '> '>=) (if excl '< '<=)) + var (or end-var end)) loop-body)) + (cl-push (list var (list (if down '- '+) var + (or step-var step 1))) + loop-for-steps))) + + ((memq word '(in in-ref on)) + (let* ((on (eq word 'on)) + (temp (if (and on (symbolp var)) var (gensym)))) + (cl-push (list temp (cl-pop args)) loop-for-bindings) + (cl-push (list 'consp temp) loop-body) + (if (eq word 'in-ref) + (cl-push (list var (list 'car temp)) loop-symbol-macs) + (or (eq temp var) + (progn + (cl-push (list var nil) loop-for-bindings) + (cl-push (list var (if on temp (list 'car temp))) + loop-for-sets)))) + (cl-push (list temp + (if (eq (car args) 'by) + (let ((step (cl-pop2 args))) + (if (and (memq (car-safe step) + '(quote function + function*)) + (symbolp (nth 1 step))) + (list (nth 1 step) temp) + (list 'funcall step temp))) + (list 'cdr temp))) + loop-for-steps))) + + ((eq word '=) + (let* ((start (cl-pop args)) + (then (if (eq (car args) 'then) (cl-pop2 args) start))) + (cl-push (list var nil) loop-for-bindings) + (if (or ands (eq (car args) 'and)) + (progn + (cl-push (list var + (list 'if + (or loop-first-flag + (setq loop-first-flag + (gensym))) + start var)) + loop-for-sets) + (cl-push (list var then) loop-for-steps)) + (cl-push (list var + (if (eq start then) start + (list 'if + (or loop-first-flag + (setq loop-first-flag (gensym))) + start then))) + loop-for-sets)))) + + ((memq word '(across across-ref)) + (let ((temp-vec (gensym)) (temp-idx (gensym))) + (cl-push (list temp-vec (cl-pop args)) loop-for-bindings) + (cl-push (list temp-idx -1) loop-for-bindings) + (cl-push (list '< (list 'setq temp-idx (list '1+ temp-idx)) + (list 'length temp-vec)) loop-body) + (if (eq word 'across-ref) + (cl-push (list var (list 'aref temp-vec temp-idx)) + loop-symbol-macs) + (cl-push (list var nil) loop-for-bindings) + (cl-push (list var (list 'aref temp-vec temp-idx)) + loop-for-sets)))) + + ((memq word '(element elements)) + (let ((ref (or (memq (car args) '(in-ref of-ref)) + (and (not (memq (car args) '(in of))) + (error "Expected `of'")))) + (seq (cl-pop2 args)) + (temp-seq (gensym)) + (temp-idx (if (eq (car args) 'using) + (if (and (= (length (cadr args)) 2) + (eq (caadr args) 'index)) + (cadr (cl-pop2 args)) + (error "Bad `using' clause")) + (gensym)))) + (cl-push (list temp-seq seq) loop-for-bindings) + (cl-push (list temp-idx 0) loop-for-bindings) + (if ref + (let ((temp-len (gensym))) + (cl-push (list temp-len (list 'length temp-seq)) + loop-for-bindings) + (cl-push (list var (list 'elt temp-seq temp-idx)) + loop-symbol-macs) + (cl-push (list '< temp-idx temp-len) loop-body)) + (cl-push (list var nil) loop-for-bindings) + (cl-push (list 'and temp-seq + (list 'or (list 'consp temp-seq) + (list '< temp-idx + (list 'length temp-seq)))) + loop-body) + (cl-push (list var (list 'if (list 'consp temp-seq) + (list 'pop temp-seq) + (list 'aref temp-seq temp-idx))) + loop-for-sets)) + (cl-push (list temp-idx (list '1+ temp-idx)) + loop-for-steps))) + + ((memq word hash-types) + (or (memq (car args) '(in of)) (error "Expected `of'")) + (let* ((table (cl-pop2 args)) + (other (if (eq (car args) 'using) + (if (and (= (length (cadr args)) 2) + (memq (caadr args) hash-types) + (not (eq (caadr args) word))) + (cadr (cl-pop2 args)) + (error "Bad `using' clause")) + (gensym)))) + (if (memq word '(hash-value hash-values)) + (setq var (prog1 other (setq other var)))) + (setq loop-map-form + (list 'maphash (list 'function + (list* 'lambda (list var other) + '--cl-map)) table)))) + + ((memq word '(symbol present-symbol external-symbol + symbols present-symbols external-symbols)) + (let ((ob (and (memq (car args) '(in of)) (cl-pop2 args)))) + (setq loop-map-form + (list 'mapatoms (list 'function + (list* 'lambda (list var) + '--cl-map)) ob)))) + + ((memq word '(overlay overlays extent extents)) + (let ((buf nil) (from nil) (to nil)) + (while (memq (car args) '(in of from to)) + (cond ((eq (car args) 'from) (setq from (cl-pop2 args))) + ((eq (car args) 'to) (setq to (cl-pop2 args))) + (t (setq buf (cl-pop2 args))))) + (setq loop-map-form + (list 'cl-map-extents + (list 'function (list 'lambda (list var (gensym)) + '(progn . --cl-map) nil)) + buf from to)))) + + ((memq word '(interval intervals)) + (let ((buf nil) (prop nil) (from nil) (to nil) + (var1 (gensym)) (var2 (gensym))) + (while (memq (car args) '(in of property from to)) + (cond ((eq (car args) 'from) (setq from (cl-pop2 args))) + ((eq (car args) 'to) (setq to (cl-pop2 args))) + ((eq (car args) 'property) + (setq prop (cl-pop2 args))) + (t (setq buf (cl-pop2 args))))) + (if (and (consp var) (symbolp (car var)) (symbolp (cdr var))) + (setq var1 (car var) var2 (cdr var)) + (cl-push (list var (list 'cons var1 var2)) loop-for-sets)) + (setq loop-map-form + (list 'cl-map-intervals + (list 'function (list 'lambda (list var1 var2) + '(progn . --cl-map))) + buf prop from to)))) + + ((memq word key-types) + (or (memq (car args) '(in of)) (error "Expected `of'")) + (let ((map (cl-pop2 args)) + (other (if (eq (car args) 'using) + (if (and (= (length (cadr args)) 2) + (memq (caadr args) key-types) + (not (eq (caadr args) word))) + (cadr (cl-pop2 args)) + (error "Bad `using' clause")) + (gensym)))) + (if (memq word '(key-binding key-bindings)) + (setq var (prog1 other (setq other var)))) + (setq loop-map-form + (list (if (memq word '(key-seq key-seqs)) + 'cl-map-keymap-recursively 'cl-map-keymap) + (list 'function (list* 'lambda (list var other) + '--cl-map)) map)))) + + ((memq word '(frame frames screen screens)) + (let ((temp (gensym))) + (cl-push (list var (if (eq cl-emacs-type 'lucid) + '(selected-screen) '(selected-frame))) + loop-for-bindings) + (cl-push (list temp nil) loop-for-bindings) + (cl-push (list 'prog1 (list 'not (list 'eq var temp)) + (list 'or temp (list 'setq temp var))) + loop-body) + (cl-push (list var (list (if (eq cl-emacs-type 'lucid) + 'next-screen 'next-frame) var)) + loop-for-steps))) + + ((memq word '(window windows)) + (let ((scr (and (memq (car args) '(in of)) (cl-pop2 args))) + (temp (gensym))) + (cl-push (list var (if scr + (list (if (eq cl-emacs-type 'lucid) + 'screen-selected-window + 'frame-selected-window) scr) + '(selected-window))) + loop-for-bindings) + (cl-push (list temp nil) loop-for-bindings) + (cl-push (list 'prog1 (list 'not (list 'eq var temp)) + (list 'or temp (list 'setq temp var))) + loop-body) + (cl-push (list var (list 'next-window var)) loop-for-steps))) + + (t + (let ((handler (and (symbolp word) + (get word 'cl-loop-for-handler)))) + (if handler + (funcall handler var) + (error "Expected a `for' preposition, found %s" word))))) + (eq (car args) 'and)) + (setq ands t) + (cl-pop args)) + (if (and ands loop-for-bindings) + (cl-push (nreverse loop-for-bindings) loop-bindings) + (setq loop-bindings (nconc (mapcar 'list loop-for-bindings) + loop-bindings))) + (if loop-for-sets + (cl-push (list 'progn + (cl-loop-let (nreverse loop-for-sets) 'setq ands) + t) loop-body)) + (if loop-for-steps + (cl-push (cons (if ands 'psetq 'setq) + (apply 'append (nreverse loop-for-steps))) + loop-steps)))) + + ((eq word 'repeat) + (let ((temp (gensym))) + (cl-push (list (list temp (cl-pop args))) loop-bindings) + (cl-push (list '>= (list 'setq temp (list '1- temp)) 0) loop-body))) + + ((eq word 'collect) + (let ((what (cl-pop args)) + (var (cl-loop-handle-accum nil 'nreverse))) + (if (eq var loop-accum-var) + (cl-push (list 'progn (list 'push what var) t) loop-body) + (cl-push (list 'progn + (list 'setq var (list 'nconc var (list 'list what))) + t) loop-body)))) + + ((memq word '(nconc nconcing append appending)) + (let ((what (cl-pop args)) + (var (cl-loop-handle-accum nil 'nreverse))) + (cl-push (list 'progn + (list 'setq var + (if (eq var loop-accum-var) + (list 'nconc + (list (if (memq word '(nconc nconcing)) + 'nreverse 'reverse) + what) + var) + (list (if (memq word '(nconc nconcing)) + 'nconc 'append) + var what))) t) loop-body))) + + ((memq word '(concat concating)) + (let ((what (cl-pop args)) + (var (cl-loop-handle-accum ""))) + (cl-push (list 'progn (list 'callf 'concat var what) t) loop-body))) + + ((memq word '(vconcat vconcating)) + (let ((what (cl-pop args)) + (var (cl-loop-handle-accum []))) + (cl-push (list 'progn (list 'callf 'vconcat var what) t) loop-body))) + + ((memq word '(sum summing)) + (let ((what (cl-pop args)) + (var (cl-loop-handle-accum 0))) + (cl-push (list 'progn (list 'incf var what) t) loop-body))) + + ((memq word '(count counting)) + (let ((what (cl-pop args)) + (var (cl-loop-handle-accum 0))) + (cl-push (list 'progn (list 'if what (list 'incf var)) t) loop-body))) + + ((memq word '(minimize minimizing maximize maximizing)) + (let* ((what (cl-pop args)) + (temp (if (cl-simple-expr-p what) what (gensym))) + (var (cl-loop-handle-accum nil)) + (func (intern (substring (symbol-name word) 0 3))) + (set (list 'setq var (list 'if var (list func var temp) temp)))) + (cl-push (list 'progn (if (eq temp what) set + (list 'let (list (list temp what)) set)) + t) loop-body))) + + ((eq word 'with) + (let ((bindings nil)) + (while (progn (cl-push (list (cl-pop args) + (and (eq (car args) '=) (cl-pop2 args))) + bindings) + (eq (car args) 'and)) + (cl-pop args)) + (cl-push (nreverse bindings) loop-bindings))) + + ((eq word 'while) + (cl-push (cl-pop args) loop-body)) + + ((eq word 'until) + (cl-push (list 'not (cl-pop args)) loop-body)) + + ((eq word 'always) + (or loop-finish-flag (setq loop-finish-flag (gensym))) + (cl-push (list 'setq loop-finish-flag (cl-pop args)) loop-body) + (setq loop-result t)) + + ((eq word 'never) + (or loop-finish-flag (setq loop-finish-flag (gensym))) + (cl-push (list 'setq loop-finish-flag (list 'not (cl-pop args))) + loop-body) + (setq loop-result t)) + + ((eq word 'thereis) + (or loop-finish-flag (setq loop-finish-flag (gensym))) + (or loop-result-var (setq loop-result-var (gensym))) + (cl-push (list 'setq loop-finish-flag + (list 'not (list 'setq loop-result-var (cl-pop args)))) + loop-body)) + + ((memq word '(if when unless)) + (let* ((cond (cl-pop args)) + (then (let ((loop-body nil)) + (cl-parse-loop-clause) + (cl-loop-build-ands (nreverse loop-body)))) + (else (let ((loop-body nil)) + (if (eq (car args) 'else) + (progn (cl-pop args) (cl-parse-loop-clause))) + (cl-loop-build-ands (nreverse loop-body)))) + (simple (and (eq (car then) t) (eq (car else) t)))) + (if (eq (car args) 'end) (cl-pop args)) + (if (eq word 'unless) (setq then (prog1 else (setq else then)))) + (let ((form (cons (if simple (cons 'progn (nth 1 then)) (nth 2 then)) + (if simple (nth 1 else) (list (nth 2 else)))))) + (if (cl-expr-contains form 'it) + (let ((temp (gensym))) + (cl-push (list temp) loop-bindings) + (setq form (list* 'if (list 'setq temp cond) + (subst temp 'it form)))) + (setq form (list* 'if cond form))) + (cl-push (if simple (list 'progn form t) form) loop-body)))) + + ((memq word '(do doing)) + (let ((body nil)) + (or (consp (car args)) (error "Syntax error on `do' clause")) + (while (consp (car args)) (cl-push (cl-pop args) body)) + (cl-push (cons 'progn (nreverse (cons t body))) loop-body))) + + ((eq word 'return) + (or loop-finish-flag (setq loop-finish-flag (gensym))) + (or loop-result-var (setq loop-result-var (gensym))) + (cl-push (list 'setq loop-result-var (cl-pop args) + loop-finish-flag nil) loop-body)) + + (t + (let ((handler (and (symbolp word) (get word 'cl-loop-handler)))) + (or handler (error "Expected a loop keyword, found %s" word)) + (funcall handler)))) + (if (eq (car args) 'and) + (progn (cl-pop args) (cl-parse-loop-clause))))) + +(defun cl-loop-let (specs body par) ; uses loop-* + (let ((p specs) (temps nil) (new nil)) + (while (and p (or (symbolp (car-safe (car p))) (null (cadar p)))) + (setq p (cdr p))) + (and par p + (progn + (setq par nil p specs) + (while p + (or (cl-const-expr-p (cadar p)) + (let ((temp (gensym))) + (cl-push (list temp (cadar p)) temps) + (setcar (cdar p) temp))) + (setq p (cdr p))))) + (while specs + (if (and (consp (car specs)) (listp (caar specs))) + (let* ((spec (caar specs)) (nspecs nil) + (expr (cadr (cl-pop specs))) + (temp (cdr (or (assq spec loop-destr-temps) + (car (cl-push (cons spec (or (last spec 0) + (gensym))) + loop-destr-temps)))))) + (cl-push (list temp expr) new) + (while (consp spec) + (cl-push (list (cl-pop spec) + (and expr (list (if spec 'pop 'car) temp))) + nspecs)) + (setq specs (nconc (nreverse nspecs) specs))) + (cl-push (cl-pop specs) new))) + (if (eq body 'setq) + (let ((set (cons (if par 'psetq 'setq) (apply 'nconc (nreverse new))))) + (if temps (list 'let* (nreverse temps) set) set)) + (list* (if par 'let 'let*) + (nconc (nreverse temps) (nreverse new)) body)))) + +(defun cl-loop-handle-accum (def &optional func) ; uses args, loop-* + (if (eq (car args) 'into) + (let ((var (cl-pop2 args))) + (or (memq var loop-accum-vars) + (progn (cl-push (list (list var def)) loop-bindings) + (cl-push var loop-accum-vars))) + var) + (or loop-accum-var + (progn + (cl-push (list (list (setq loop-accum-var (gensym)) def)) + loop-bindings) + (setq loop-result (if func (list func loop-accum-var) + loop-accum-var)) + loop-accum-var)))) + +(defun cl-loop-build-ands (clauses) + (let ((ands nil) + (body nil)) + (while clauses + (if (and (eq (car-safe (car clauses)) 'progn) + (eq (car (last (car clauses))) t)) + (if (cdr clauses) + (setq clauses (cons (nconc (butlast (car clauses)) + (if (eq (car-safe (cadr clauses)) + 'progn) + (cdadr clauses) + (list (cadr clauses)))) + (cddr clauses))) + (setq body (cdr (butlast (cl-pop clauses))))) + (cl-push (cl-pop clauses) ands))) + (setq ands (or (nreverse ands) (list t))) + (list (if (cdr ands) (cons 'and ands) (car ands)) + body + (let ((full (if body + (append ands (list (cons 'progn (append body '(t))))) + ands))) + (if (cdr full) (cons 'and full) (car full)))))) + + +;;; Other iteration control structures. + +;;;###autoload +(defmacro do (steps endtest &rest body) + "The Common Lisp `do' loop. +Format is: (do ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" + (cl-expand-do-loop steps endtest body nil)) + +;;;###autoload +(defmacro do* (steps endtest &rest body) + "The Common Lisp `do*' loop. +Format is: (do* ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" + (cl-expand-do-loop steps endtest body t)) + +(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))) + 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))))) + steps))) + (setq sets (delq nil sets)) + (and sets + (list (cons (if (or star (not (cdr sets))) + 'setq 'psetq) + (apply 'append sets))))))) + (or (cdr endtest) '(nil))))) + +;;;###autoload +(defmacro dolist (spec &rest body) + "(dolist (VAR LIST [RESULT]) BODY...): loop over a list. +Evaluate BODY with VAR bound to each `car' from LIST, in turn. +Then evaluate RESULT to get return value, default nil." + (let ((temp (gensym "--dolist-temp--"))) + (list 'block nil + (list* 'let (list (list temp (nth 1 spec)) (car spec)) + (list* 'while temp (list 'setq (car spec) (list 'car temp)) + (append body (list (list 'setq temp + (list 'cdr temp))))) + (if (cdr (cdr spec)) + (cons (list 'setq (car spec) nil) (cdr (cdr spec))) + '(nil)))))) + +;;;###autoload +(defmacro dotimes (spec &rest body) + "(dotimes (VAR COUNT [RESULT]) BODY...): loop a certain number of times. +Evaluate BODY with VAR bound to successive integers from 0, inclusive, +to COUNT, exclusive. Then evaluate RESULT to get return value, default +nil." + (let ((temp (gensym "--dotimes-temp--"))) + (list 'block nil + (list* 'let (list (list temp (nth 1 spec)) (list (car spec) 0)) + (list* 'while (list '< (car spec) temp) + (append body (list (list 'incf (car spec))))) + (or (cdr (cdr spec)) '(nil)))))) + +;;;###autoload +(defmacro do-symbols (spec &rest body) + "(dosymbols (VAR [OBARRAY [RESULT]]) BODY...): loop over all symbols. +Evaluate BODY with VAR bound to each interned symbol, or to each symbol +from OBARRAY." + ;; Apparently this doesn't have an implicit block. + (list 'block nil + (list 'let (list (car spec)) + (list* 'mapatoms + (list 'function (list* 'lambda (list (car spec)) body)) + (and (cadr spec) (list (cadr spec)))) + (caddr spec)))) + +;;;###autoload +(defmacro do-all-symbols (spec &rest body) + (list* 'do-symbols (list (car spec) nil (cadr spec)) body)) + + +;;; Assignments. + +;;;###autoload +(defmacro psetq (&rest args) + "(psetq SYM VAL SYM VAL ...): set SYMs to the values VALs in parallel. +This is like `setq', except that all VAL forms are evaluated (in order) +before assigning any symbols SYM to the corresponding values." + (cons 'psetf args)) + + +;;; Binding control structures. + +;;;###autoload +(defmacro progv (symbols values &rest body) + "(progv SYMBOLS VALUES BODY...): bind SYMBOLS to VALUES dynamically in BODY. +The forms SYMBOLS and VALUES are evaluated, and must evaluate to lists. +Each SYMBOL in the first list is bound to the corresponding VALUE in the +second list (or made unbound if VALUES is shorter than SYMBOLS); then the +BODY forms are executed and their result is returned. This is much like +a `let' form, except that the list of symbols can be computed at run-time." + (list 'let '((cl-progv-save nil)) + (list 'unwind-protect + (list* 'progn (list 'cl-progv-before symbols values) body) + '(cl-progv-after)))) + +;;; This should really have some way to shadow 'byte-compile properties, etc. +;;;###autoload +(defmacro flet (bindings &rest body) + "(flet ((FUNC ARGLIST BODY...) ...) FORM...): make temporary function defns. +This is an analogue of `let' that operates on the function cell of FUNC +rather than its value cell. The FORMs are evaluated with the specified +function definitions in place, then the definitions are undone (the FUNCs +go back to their previous definitions, or lack thereof)." + (list* 'letf* + (mapcar + (function + (lambda (x) + (if (or (and (fboundp (car x)) + (eq (car-safe (symbol-function (car x))) 'macro)) + (cdr (assq (car x) cl-macro-environment))) + (error "Use `labels', not `flet', to rebind macro names")) + (let ((func (list 'function* + (list 'lambda (cadr x) + (list* 'block (car x) (cddr x)))))) + (if (and (cl-compiling-file) + (boundp 'byte-compile-function-environment)) + (cl-push (cons (car x) (eval func)) + byte-compile-function-environment)) + (list (list 'symbol-function (list 'quote (car x))) func)))) + bindings) + body)) + +;;;###autoload +(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." + (let ((vars nil) (sets nil) (cl-macro-environment cl-macro-environment)) + (while bindings + (let ((var (gensym))) + (cl-push var vars) + (cl-push (list 'function* (cons 'lambda (cdar bindings))) sets) + (cl-push var sets) + (cl-push (list (car (cl-pop bindings)) 'lambda '(&rest cl-labels-args) + (list 'list* '(quote funcall) (list 'quote var) + 'cl-labels-args)) + cl-macro-environment))) + (cl-macroexpand-all (list* 'lexical-let vars (cons (cons 'setq sets) body)) + cl-macro-environment))) + +;; The following ought to have a better definition for use with newer +;; byte compilers. +;;;###autoload +(defmacro macrolet (bindings &rest body) + "(macrolet ((NAME ARGLIST BODY...) ...) FORM...): make temporary macro defns. +This is like `flet', but for macros instead of functions." + (if (cdr bindings) + (list 'macrolet + (list (car bindings)) (list* 'macrolet (cdr bindings) body)) + (if (null bindings) (cons 'progn body) + (let* ((name (caar bindings)) + (res (cl-transform-lambda (cdar bindings) name))) + (eval (car res)) + (cl-macroexpand-all (cons 'progn body) + (cons (list* name 'lambda (cdr res)) + cl-macro-environment)))))) + +;;;###autoload +(defmacro symbol-macrolet (bindings &rest body) + "(symbol-macrolet ((NAME EXPANSION) ...) FORM...): make symbol macro defns. +Within the body FORMs, references to the variable NAME will be replaced +by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...)." + (if (cdr bindings) + (list 'symbol-macrolet + (list (car bindings)) (list* 'symbol-macrolet (cdr bindings) body)) + (if (null bindings) (cons 'progn body) + (cl-macroexpand-all (cons 'progn body) + (cons (list (symbol-name (caar bindings)) + (cadar bindings)) + cl-macro-environment))))) + +(defvar cl-closure-vars nil) +;;;###autoload +(defmacro lexical-let (bindings &rest body) + "(lexical-let BINDINGS BODY...): like `let', but lexically scoped. +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)))) + bindings)) + (ebody + (cl-macroexpand-all + (cons 'progn body) + (nconc (mapcar (function (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))))) + vars) + ebody)) + (list 'let (mapcar (function (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)))) + vars)) + ebody)))) + +;;;###autoload +(defmacro lexical-let* (bindings &rest body) + "(lexical-let* BINDINGS BODY...): like `let*', but lexically scoped. +The main visible difference is that lambdas inside BODY will create +lexical closures as in Common Lisp." + (if (null bindings) (cons 'progn body) + (setq bindings (reverse bindings)) + (while bindings + (setq body (list (list* 'lexical-let (list (cl-pop bindings)) body)))) + (car body))) + +(defun cl-defun-expander (func &rest rest) + (list 'progn + (list 'defalias (list 'quote func) + (list 'function (cons 'lambda rest))) + (list 'quote func))) + + +;;; Multiple values. + +;;;###autoload +(defmacro multiple-value-bind (vars form &rest body) + "(multiple-value-bind (SYM SYM...) FORM BODY): collect multiple return values. +FORM must return a list; the BODY is then executed with the first N elements +of this list bound (`let'-style) to each of the symbols SYM in turn. This +is analogous to the Common Lisp `multiple-value-bind' macro, using lists to +simulate true multiple return values. For compatibility, (values A B C) is +a synonym for (list A B C)." + (let ((temp (gensym)) (n -1)) + (list* 'let* (cons (list temp form) + (mapcar (function + (lambda (v) + (list v (list 'nth (setq n (1+ n)) temp)))) + vars)) + body))) + +;;;###autoload +(defmacro multiple-value-setq (vars form) + "(multiple-value-setq (SYM SYM...) FORM): collect multiple return values. +FORM must return a list; the first N elements of this list are stored in +each of the symbols SYM in turn. This is analogous to the Common Lisp +`multiple-value-setq' macro, using lists to simulate true multiple return +values. For compatibility, (values A B C) is a synonym for (list A B C)." + (cond ((null vars) (list 'progn form nil)) + ((null (cdr vars)) (list 'setq (car vars) (list 'car form))) + (t + (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))))))))) + + +;;; Declarations. + +;;;###autoload +(defmacro locally (&rest body) (cons 'progn body)) +;;;###autoload +(defmacro the (type form) form) + +(defvar cl-proclaim-history t) ; for future compilers +(defvar cl-declare-stack t) ; for future compilers + +(defun cl-do-proclaim (spec hist) + (and hist (listp cl-proclaim-history) (cl-push spec cl-proclaim-history)) + (cond ((eq (car-safe spec) 'special) + (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)) + (cdr spec)) + byte-compile-bound-variables)))) + + ((eq (car-safe spec) 'inline) + (while (setq spec (cdr spec)) + (or (memq (get (car spec) 'byte-optimizer) + '(nil byte-compile-inline-expand)) + (error "%s already has a byte-optimizer, can't make it inline" + (car spec))) + (put (car spec) 'byte-optimizer 'byte-compile-inline-expand))) + + ((eq (car-safe spec) 'notinline) + (while (setq spec (cdr spec)) + (if (eq (get (car spec) 'byte-optimizer) + 'byte-compile-inline-expand) + (put (car spec) 'byte-optimizer nil)))) + + ((eq (car-safe spec) 'optimize) + (let ((speed (assq (nth 1 (assq 'speed (cdr spec))) + '((0 nil) (1 t) (2 t) (3 t)))) + (safety (assq (nth 1 (assq 'safety (cdr spec))) + '((0 t) (1 t) (2 t) (3 nil))))) + (if speed (setq cl-optimize-speed (car speed) + byte-optimize (nth 1 speed))) + (if safety (setq cl-optimize-safety (car safety) + byte-compile-delete-errors (nth 1 safety))))) + + ((and (eq (car-safe spec) 'warn) (boundp 'byte-compile-warnings)) + (if (eq byte-compile-warnings t) + ;; XEmacs change + (setq byte-compile-warnings byte-compile-default-warnings)) + (while (setq spec (cdr spec)) + (if (consp (car spec)) + (if (eq (cadar spec) 0) + (setq byte-compile-warnings + (delq (caar spec) byte-compile-warnings)) + (setq byte-compile-warnings + (adjoin (caar spec) byte-compile-warnings))))))) + nil) + +;;; Process any proclamations made before cl-macs was loaded. +(defvar cl-proclaims-deferred) +(let ((p (reverse cl-proclaims-deferred))) + (while p (cl-do-proclaim (cl-pop p) t)) + (setq cl-proclaims-deferred nil)) + +;;;###autoload +(defmacro declare (&rest specs) + (if (cl-compiling-file) + (while specs + (if (listp cl-declare-stack) (cl-push (car specs) cl-declare-stack)) + (cl-do-proclaim (cl-pop specs) nil))) + nil) + + + +;;; Generalized variables. + +;;;###autoload +(defmacro define-setf-method (func args &rest body) + "(define-setf-method NAME ARGLIST BODY...): define a `setf' method. +This method shows how to handle `setf's to places of the form (NAME ARGS...). +The argument forms ARGS are bound according to ARGLIST, as if NAME were +going to be expanded as a macro, then the BODY forms are executed and must +return a list of five elements: a temporary-variables list, a value-forms +list, a store-variables list (of length one), a store-form, and an access- +form. See `defsetf' for a simpler way to define most setf-methods." + (append '(eval-when (compile load eval)) + (if (stringp (car body)) + (list (list 'put (list 'quote func) '(quote setf-documentation) + (cl-pop body)))) + (list (cl-transform-function-property + func 'setf-method (cons args body))))) + +;;;###autoload +(defmacro defsetf (func arg1 &rest args) + "(defsetf NAME FUNC): define a `setf' method. +This macro is an easy-to-use substitute for `define-setf-method' that works +well for simple place forms. In the simple `defsetf' form, `setf's of +the form (setf (NAME ARGS...) VAL) are transformed to function or macro +calls of the form (FUNC ARGS... VAL). Example: (defsetf aref aset). +Alternate form: (defsetf NAME ARGLIST (STORE) BODY...). +Here, the above `setf' call is expanded by binding the argument forms ARGS +according to ARGLIST, binding the value form VAL to STORE, then executing +BODY, which must return a Lisp form that does the necessary `setf' operation. +Actually, ARGLIST and STORE may be bound to temporary variables which are +introduced automatically to preserve proper execution order of the arguments. +Example: (defsetf nth (n x) (v) (list 'setcar (list 'nthcdr n x) v))." + (if (listp arg1) + (let* ((largs nil) (largsr nil) + (temps nil) (tempsr nil) + (restarg nil) (rest-temps nil) + (store-var (car (prog1 (car args) (setq args (cdr args))))) + (store-temp (intern (format "--%s--temp--" store-var))) + (lets1 nil) (lets2 nil) + (docstr nil) (p arg1)) + (if (stringp (car args)) + (setq docstr (prog1 (car args) (setq args (cdr args))))) + (while (and p (not (eq (car p) '&aux))) + (if (eq (car p) '&rest) + (setq p (cdr p) restarg (car p)) + (or (memq (car p) '(&optional &key &allow-other-keys)) + (setq largs (cons (if (consp (car p)) (car (car p)) (car p)) + largs) + temps (cons (intern (format "--%s--temp--" (car largs))) + temps)))) + (setq p (cdr p))) + (setq largs (nreverse largs) temps (nreverse temps)) + (if restarg + (setq largsr (append largs (list restarg)) + rest-temps (intern (format "--%s--temp--" restarg)) + tempsr (append temps (list rest-temps))) + (setq largsr largs tempsr temps)) + (let ((p1 largs) (p2 temps)) + (while p1 + (setq lets1 (cons (list (car p2) + (list 'gensym (format "--%s--" (car p1)))) + lets1) + lets2 (cons (list (car p1) (car p2)) lets2) + p1 (cdr p1) p2 (cdr p2)))) + (if restarg (setq lets2 (cons (list restarg rest-temps) lets2))) + (append (list 'define-setf-method func arg1) + (and docstr (list docstr)) + (list + (list 'let* + (nreverse + (cons (list store-temp + (list 'gensym (format "--%s--" store-var))) + (if restarg + (append + (list + (list rest-temps + (list 'mapcar '(quote gensym) + restarg))) + lets1) + lets1))) + (list 'list ; 'values + (cons (if restarg 'list* 'list) tempsr) + (cons (if restarg 'list* 'list) largsr) + (list 'list store-temp) + (cons 'let* + (cons (nreverse + (cons (list store-var store-temp) + lets2)) + args)) + (cons (if restarg 'list* 'list) + (cons (list 'quote func) tempsr))))))) + (list 'defsetf func '(&rest args) '(store) + (let ((call (list 'cons (list 'quote arg1) + '(append args (list store))))) + (if (car args) + (list 'list '(quote progn) call 'store) + call))))) + +;;; Some standard place types from Common Lisp. +(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 nth (n x) (store) (list 'setcar (list 'nthcdr n x) store)) +(defsetf subseq (seq start &optional end) (new) + (list 'progn (list 'replace seq new ':start1 start ':end1 end) new)) +(defsetf symbol-function fset) +(defsetf symbol-plist setplist) +(defsetf symbol-value set) + +;;; Various car/cdr aliases. Note that `cadr' is handled specially. +(defsetf first setcar) +(defsetf second (x) (store) (list 'setcar (list 'cdr x) store)) +(defsetf third (x) (store) (list 'setcar (list 'cddr x) store)) +(defsetf fourth (x) (store) (list 'setcar (list 'cdddr x) store)) +(defsetf fifth (x) (store) (list 'setcar (list 'nthcdr 4 x) store)) +(defsetf sixth (x) (store) (list 'setcar (list 'nthcdr 5 x) store)) +(defsetf seventh (x) (store) (list 'setcar (list 'nthcdr 6 x) store)) +(defsetf eighth (x) (store) (list 'setcar (list 'nthcdr 7 x) store)) +(defsetf ninth (x) (store) (list 'setcar (list 'nthcdr 8 x) store)) +(defsetf tenth (x) (store) (list 'setcar (list 'nthcdr 9 x) store)) +(defsetf rest setcdr) + +;;; Some more Emacs-related place types. +(defsetf buffer-file-name set-visited-file-name t) +(defsetf buffer-modified-p set-buffer-modified-p t) +(defsetf buffer-name rename-buffer t) +(defsetf buffer-string () (store) + (list 'progn '(erase-buffer) (list 'insert store))) +(defsetf buffer-substring cl-set-buffer-substring) +(defsetf current-buffer set-buffer) +(defsetf current-case-table set-case-table) +(defsetf current-column move-to-column t) +(defsetf current-global-map use-global-map t) +(defsetf current-input-mode () (store) + (list 'progn (list 'apply 'set-input-mode store) store)) +(defsetf current-local-map use-local-map t) +(defsetf current-window-configuration set-window-configuration t) +(defsetf default-file-modes set-default-file-modes t) +(defsetf default-value set-default) +(defsetf documentation-property put) +(defsetf extent-data set-extent-data) ; obsolete +(defsetf extent-face set-extent-face) +(defsetf extent-priority set-extent-priority) +(defsetf extent-property (x y &optional d) (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) + store) store)) +(defsetf extent-start-position (ext) (store) + (list 'progn (list 'set-extent-endpoints store + (list 'extent-end-position ext)) store)) +(defsetf face-background (f &optional s) (x) (list 'set-face-background f x s)) +(defsetf face-background-pixmap (f &optional s) (x) + (list 'set-face-background-pixmap f x s)) +(defsetf face-font (f &optional s) (x) (list 'set-face-font f x s)) +(defsetf face-foreground (f &optional s) (x) (list 'set-face-foreground f x s)) +(defsetf face-underline-p (f &optional s) (x) + (list 'set-face-underline-p f x s)) +(defsetf file-modes set-file-modes t) +(defsetf frame-parameters modify-frame-parameters t) +(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) + `(progn (set-frame-property ,f ,v) ,p)) +(defsetf frame-width (&optional f) (v) + `(progn (set-frame-width ,f ,v) ,v)) +(defsetf frame-height (&optional f) (v) + `(progn (set-frame-height ,f ,v) ,v)) +(defsetf current-frame-configuration set-frame-configuration) + +;; XEmacs: new stuff +;; Consoles +(defsetf selected-console select-console t) +(defsetf selected-device select-device t) +(defsetf device-baud-rate (&optional d) (v) + `(set-device-baud-rate ,d ,v)) +(defsetf specifier-instance (spec &optional dom def nof) (val) + `(set-specifier ,spec ,val ,dom)) + +;; Annotations +(defsetf annotation-glyph set-annotation-glyph) +(defsetf annotation-down-glyph set-annotation-down-glyph) +(defsetf annotation-face set-annotation-face) +(defsetf annotation-layout set-annotation-layout) +(defsetf annotation-data set-annotation-data) +(defsetf annotation-action set-annotation-action) +(defsetf annotation-menu set-annotation-menu) +;; Widget +(defsetf widget-get widget-put t) +(defsetf widget-value widget-value-set t) + +;; Misc +(defsetf recent-keys-ring-size set-recent-keys-ring-size) +(defsetf symbol-value-in-buffer (s b &optional u) (store) + `(with-current-buffer ,b (set ,s ,store))) +(defsetf symbol-value-in-console (s c &optional u) (store) + `(letf (((selected-console) ,c)) + (set ,s ,store))) + +(defsetf getenv setenv t) +(defsetf get-register set-register) +(defsetf global-key-binding global-set-key) +(defsetf keymap-parent set-keymap-parent) +(defsetf keymap-name set-keymap-name) +(defsetf keymap-prompt set-keymap-prompt) +(defsetf keymap-default-binding set-keymap-default-binding) +(defsetf local-key-binding local-set-key) +(defsetf mark set-mark t) +(defsetf mark-marker set-mark t) +(defsetf marker-position set-marker t) +(defsetf match-data store-match-data t) +(defsetf mouse-position (scr) (store) + (list 'set-mouse-position scr (list 'car store) (list 'cadr store) + (list 'cddr store))) +(defsetf overlay-get overlay-put) +(defsetf overlay-start (ov) (store) + (list 'progn (list 'move-overlay ov store (list 'overlay-end ov)) store)) +(defsetf overlay-end (ov) (store) + (list 'progn (list 'move-overlay ov (list 'overlay-start ov) store) store)) +(defsetf point goto-char) +(defsetf point-marker goto-char t) +(defsetf point-max () (store) + (list 'progn (list 'narrow-to-region '(point-min) store) store)) +(defsetf point-min () (store) + (list 'progn (list 'narrow-to-region store '(point-max)) store)) +(defsetf process-buffer set-process-buffer) +(defsetf process-filter set-process-filter) +(defsetf process-sentinel set-process-sentinel) +(defsetf read-mouse-position (scr) (store) + (list 'set-mouse-position scr (list 'car store) (list 'cdr store))) +(defsetf screen-height set-screen-height t) +(defsetf screen-width set-screen-width t) +(defsetf selected-window select-window) +(defsetf selected-screen select-screen) +(defsetf selected-frame select-frame) +(defsetf standard-case-table set-standard-case-table) +(defsetf syntax-table set-syntax-table) +(defsetf visited-file-modtime set-visited-file-modtime t) +(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-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 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) +(defsetf x-get-selection x-own-selection t) + +;;; More complex setf-methods. +;;; These should take &environment arguments, but since full arglists aren't +;;; available while compiling cl-macs, we fake it by referring to the global +;;; variable cl-macro-environment directly. + +(define-setf-method apply (func arg1 &rest rest) + (or (and (memq (car-safe func) '(quote function function*)) + (symbolp (car-safe (cdr-safe func)))) + (error "First arg to apply in setf is not (function SYM): %s" func)) + (let* ((form (cons (nth 1 func) (cons arg1 rest))) + (method (get-setf-method form cl-macro-environment))) + (list (car method) (nth 1 method) (nth 2 method) + (cl-setf-make-apply (nth 3 method) (cadr func) (car method)) + (cl-setf-make-apply (nth 4 method) (cadr func) (car method))))) + +(defun cl-setf-make-apply (form func temps) + (if (eq (car form) 'progn) + (list* 'progn (cl-setf-make-apply (cadr form) func temps) (cddr form)) + (or (equal (last form) (last temps)) + (error "%s is not suitable for use with setf-of-apply" func)) + (list* 'apply (list 'quote (car form)) (cdr form)))) + +(define-setf-method nthcdr (n place) + (let ((method (get-setf-method place cl-macro-environment)) + (n-temp (gensym "--nthcdr-n--")) + (store-temp (gensym "--nthcdr-store--"))) + (list (cons n-temp (car method)) + (cons n (nth 1 method)) + (list store-temp) + (list 'let (list (list (car (nth 2 method)) + (list 'cl-set-nthcdr n-temp (nth 4 method) + store-temp))) + (nth 3 method) store-temp) + (list 'nthcdr n-temp (nth 4 method))))) + +(define-setf-method getf (place tag &optional def) + (let ((method (get-setf-method place cl-macro-environment)) + (tag-temp (gensym "--getf-tag--")) + (def-temp (gensym "--getf-def--")) + (store-temp (gensym "--getf-store--"))) + (list (append (car method) (list tag-temp def-temp)) + (append (nth 1 method) (list tag def)) + (list store-temp) + (list 'let (list (list (car (nth 2 method)) + (list 'cl-set-getf (nth 4 method) + tag-temp store-temp))) + (nth 3 method) store-temp) + (list 'getf (nth 4 method) tag-temp def-temp)))) + +(define-setf-method substring (place from &optional to) + (let ((method (get-setf-method place cl-macro-environment)) + (from-temp (gensym "--substring-from--")) + (to-temp (gensym "--substring-to--")) + (store-temp (gensym "--substring-store--"))) + (list (append (car method) (list from-temp to-temp)) + (append (nth 1 method) (list from to)) + (list store-temp) + (list 'let (list (list (car (nth 2 method)) + (list 'cl-set-substring (nth 4 method) + from-temp to-temp store-temp))) + (nth 3 method) store-temp) + (list 'substring (nth 4 method) from-temp to-temp)))) + +(define-setf-method values (&rest args) + (let ((methods (mapcar #'(lambda (x) + (get-setf-method x cl-macro-environment)) + args)) + (store-temp (gensym "--values-store--"))) + (list (apply 'append (mapcar 'first methods)) + (apply 'append (mapcar 'second methods)) + (list store-temp) + (cons 'list + (mapcar #'(lambda (m) + (cl-setf-do-store (cons (car (third m)) (fourth m)) + (list 'pop store-temp))) + methods)) + (cons 'list (mapcar 'fifth methods))))) + +;;; Getting and optimizing setf-methods. +;;;###autoload +(defun get-setf-method (place &optional env) + "Return a list of five values describing the setf-method for PLACE. +PLACE may be any Lisp form which can appear as the PLACE argument to +a macro like `setf' or `incf'." + (if (symbolp place) + (let ((temp (gensym "--setf--"))) + (list nil nil (list temp) (list 'setq place temp) place)) + (or (and (symbolp (car place)) + (let* ((func (car place)) + (name (symbol-name func)) + (method (get func 'setf-method)) + (case-fold-search nil)) + (or (and method + (let ((cl-macro-environment env)) + (setq method (apply method (cdr place)))) + (if (and (consp method) (= (length method) 5)) + method + (error "Setf-method for %s returns malformed method" + func))) + (and (save-match-data + (string-match "\\`c[ad][ad][ad]?[ad]?r\\'" name)) + (get-setf-method (compiler-macroexpand place))) + (and (eq func 'edebug-after) + (get-setf-method (nth (1- (length place)) place) + env))))) + (if (eq place (setq place (macroexpand place env))) + (if (and (symbolp (car place)) (fboundp (car place)) + (symbolp (symbol-function (car place)))) + (get-setf-method (cons (symbol-function (car place)) + (cdr place)) env) + (error "No setf-method known for %s" (car place))) + (get-setf-method place env))))) + +(defun cl-setf-do-modify (place opt-expr) + (let* ((method (get-setf-method place cl-macro-environment)) + (temps (car method)) (values (nth 1 method)) + (lets nil) (subs nil) + (optimize (and (not (eq opt-expr 'no-opt)) + (or (and (not (eq opt-expr 'unsafe)) + (cl-safe-expr-p opt-expr)) + (cl-setf-simple-store-p (car (nth 2 method)) + (nth 3 method))))) + (simple (and optimize (consp place) (cl-simple-exprs-p (cdr place))))) + (while values + (if (or simple (cl-const-expr-p (car values))) + (cl-push (cons (cl-pop temps) (cl-pop values)) subs) + (cl-push (list (cl-pop temps) (cl-pop values)) lets))) + (list (nreverse lets) + (cons (car (nth 2 method)) (sublis subs (nth 3 method))) + (sublis subs (nth 4 method))))) + +(defun cl-setf-do-store (spec val) + (let ((sym (car spec)) + (form (cdr spec))) + (if (or (cl-const-expr-p val) + (and (cl-simple-expr-p val) (eq (cl-expr-contains form sym) 1)) + (cl-setf-simple-store-p sym form)) + (subst val sym form) + (list 'let (list (list sym val)) form)))) + +(defun cl-setf-simple-store-p (sym form) + (and (consp form) (eq (cl-expr-contains form sym) 1) + (eq (nth (1- (length form)) form) sym) + (symbolp (car form)) (fboundp (car form)) + (not (eq (car-safe (symbol-function (car form))) 'macro)))) + +;;; The standard modify macros. +;;;###autoload +(defmacro setf (&rest args) + "(setf PLACE VAL PLACE VAL ...): set each PLACE to the value of its VAL. +This is a generalized version of `setq'; the PLACEs may be symbolic +references such as (car x) or (aref x i), as well as plain symbols. +For example, (setf (cadar x) y) is equivalent to (setcar (cdar x) y). +The return value is the last VAL in the list." + (if (cdr (cdr args)) + (let ((sets nil)) + (while args (cl-push (list 'setf (cl-pop args) (cl-pop args)) sets)) + (cons 'progn (nreverse sets))) + (if (symbolp (car args)) + (and args (cons 'setq args)) + (let* ((method (cl-setf-do-modify (car args) (nth 1 args))) + (store (cl-setf-do-store (nth 1 method) (nth 1 args)))) + (if (car method) (list 'let* (car method) store) store))))) + +;;;###autoload +(defmacro psetf (&rest args) + "(psetf PLACE VAL PLACE VAL ...): set PLACEs to the values VALs in parallel. +This is like `setf', except that all VAL forms are evaluated (in order) +before assigning any PLACEs to the corresponding values." + (let ((p args) (simple t) (vars nil)) + (while p + (if (or (not (symbolp (car p))) (cl-expr-depends-p (nth 1 p) vars)) + (setq simple nil)) + (if (memq (car p) vars) + (error "Destination duplicated in psetf: %s" (car p))) + (cl-push (cl-pop p) vars) + (or p (error "Odd number of arguments to psetf")) + (cl-pop p)) + (if simple + (list 'progn (cons 'setf args) nil) + (setq args (reverse args)) + (let ((expr (list 'setf (cadr args) (car args)))) + (while (setq args (cddr args)) + (setq expr (list 'setf (cadr args) (list 'prog1 (car args) expr)))) + (list 'progn expr nil))))) + +;;;###autoload +(defun cl-do-pop (place) + (if (cl-simple-expr-p place) + (list 'prog1 (list 'car place) (list 'setf place (list 'cdr place))) + (let* ((method (cl-setf-do-modify place t)) + (temp (gensym "--pop--"))) + (list 'let* + (append (car method) + (list (list temp (nth 2 method)))) + (list 'prog1 + (list 'car temp) + (cl-setf-do-store (nth 1 method) (list 'cdr temp))))))) + +;;;###autoload +(defmacro remf (place tag) + "(remf PLACE TAG): remove TAG from property list PLACE. +PLACE may be a symbol, or any generalized variable allowed by `setf'. +The form returns true if TAG was found and removed, nil otherwise." + (let* ((method (cl-setf-do-modify place t)) + (tag-temp (and (not (cl-const-expr-p tag)) (gensym "--remf-tag--"))) + (val-temp (and (not (cl-simple-expr-p place)) + (gensym "--remf-place--"))) + (ttag (or tag-temp tag)) + (tval (or val-temp (nth 2 method)))) + (list 'let* + (append (car method) + (and val-temp (list (list val-temp (nth 2 method)))) + (and tag-temp (list (list tag-temp tag)))) + (list 'if (list 'eq ttag (list 'car tval)) + (list 'progn + (cl-setf-do-store (nth 1 method) (list 'cddr tval)) + t) + (list 'cl-do-remf tval ttag))))) + +;;;###autoload +(defmacro shiftf (place &rest args) + "(shiftf PLACE PLACE... VAL): shift left among PLACEs. +Example: (shiftf A B C) sets A to B, B to C, and returns the old A. +Each PLACE may be a symbol, or any generalized variable allowed by `setf'." + (if (not (memq nil (mapcar 'symbolp (butlast (cons place args))))) + (list* 'prog1 place + (let ((sets nil)) + (while args + (cl-push (list 'setq place (car args)) sets) + (setq place (cl-pop args))) + (nreverse sets))) + (let* ((places (reverse (cons place args))) + (form (cl-pop places))) + (while places + (let ((method (cl-setf-do-modify (cl-pop places) 'unsafe))) + (setq form (list 'let* (car method) + (list 'prog1 (nth 2 method) + (cl-setf-do-store (nth 1 method) form)))))) + form))) + +;;;###autoload +(defmacro rotatef (&rest args) + "(rotatef PLACE...): rotate left among PLACEs. +Example: (rotatef A B C) sets A to B, B to C, and C to A. It returns nil. +Each PLACE may be a symbol, or any generalized variable allowed by `setf'." + (if (not (memq nil (mapcar 'symbolp args))) + (and (cdr args) + (let ((sets nil) + (first (car args))) + (while (cdr args) + (setq sets (nconc sets (list (cl-pop args) (car args))))) + (nconc (list 'psetf) sets (list (car args) first)))) + (let* ((places (reverse args)) + (temp (gensym "--rotatef--")) + (form temp)) + (while (cdr places) + (let ((method (cl-setf-do-modify (cl-pop places) 'unsafe))) + (setq form (list 'let* (car method) + (list 'prog1 (nth 2 method) + (cl-setf-do-store (nth 1 method) form)))))) + (let ((method (cl-setf-do-modify (car places) 'unsafe))) + (list 'let* (append (car method) (list (list temp (nth 2 method)))) + (cl-setf-do-store (nth 1 method) form) nil))))) + +;;;###autoload +(defmacro letf (bindings &rest body) + "(letf ((PLACE VALUE) ...) BODY...): temporarily bind to PLACEs. +This is the analogue of `let', but with generalized variables (in the +sense of `setf') for the PLACEs. Each PLACE is set to the corresponding +VALUE, then the BODY forms are executed. On exit, either normally or +because of a `throw' or error, the PLACEs are set back to their original +values. Note that this macro is *not* available in Common Lisp. +As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)', +the PLACE is not modified before executing BODY." + (if (and (not (cdr bindings)) (cdar bindings) (symbolp (caar bindings))) + (list* 'let bindings body) + (let ((lets nil) (sets nil) + (unsets nil) (rev (reverse bindings))) + (while rev + (let* ((place (if (symbolp (caar rev)) + (list 'symbol-value (list 'quote (caar rev))) + (caar rev))) + (value (cadar rev)) + (method (cl-setf-do-modify place 'no-opt)) + (save (gensym "--letf-save--")) + (bound (and (memq (car place) '(symbol-value symbol-function)) + (gensym "--letf-bound--"))) + (temp (and (not (cl-const-expr-p value)) (cdr bindings) + (gensym "--letf-val--")))) + (setq lets (nconc (car method) + (if bound + (list (list bound + (list (if (eq (car place) + 'symbol-value) + 'boundp 'fboundp) + (nth 1 (nth 2 method)))) + (list save (list 'and bound + (nth 2 method)))) + (list (list save (nth 2 method)))) + (and temp (list (list temp value))) + lets) + body (list + (list 'unwind-protect + (cons 'progn + (if (cdr (car rev)) + (cons (cl-setf-do-store (nth 1 method) + (or temp value)) + body) + body)) + (if bound + (list 'if bound + (cl-setf-do-store (nth 1 method) save) + (list (if (eq (car place) 'symbol-value) + 'makunbound 'fmakunbound) + (nth 1 (nth 2 method)))) + (cl-setf-do-store (nth 1 method) save)))) + rev (cdr rev)))) + (list* 'let* lets body)))) + +;;;###autoload +(defmacro letf* (bindings &rest body) + "(letf* ((PLACE VALUE) ...) BODY...): temporarily bind to PLACEs. +This is the analogue of `let*', but with generalized variables (in the +sense of `setf') for the PLACEs. Each PLACE is set to the corresponding +VALUE, then the BODY forms are executed. On exit, either normally or +because of a `throw' or error, the PLACEs are set back to their original +values. Note that this macro is *not* available in Common Lisp. +As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)', +the PLACE is not modified before executing BODY." + (if (null bindings) + (cons 'progn body) + (setq bindings (reverse bindings)) + (while bindings + (setq body (list (list* 'letf (list (cl-pop bindings)) body)))) + (car body))) + +;;;###autoload +(defmacro callf (func place &rest args) + "(callf FUNC PLACE ARGS...): set PLACE to (FUNC PLACE ARGS...). +FUNC should be an unquoted function name. PLACE may be a symbol, +or any generalized variable allowed by `setf'." + (let* ((method (cl-setf-do-modify place (cons 'list args))) + (rargs (cons (nth 2 method) args))) + (list 'let* (car method) + (cl-setf-do-store (nth 1 method) + (if (symbolp func) (cons func rargs) + (list* 'funcall (list 'function func) + rargs)))))) + +;;;###autoload +(defmacro callf2 (func arg1 place &rest args) + "(callf2 FUNC ARG1 PLACE ARGS...): set PLACE to (FUNC ARG1 PLACE ARGS...). +Like `callf', but PLACE is the second argument of FUNC, not the first." + (if (and (cl-safe-expr-p arg1) (cl-simple-expr-p place) (symbolp func)) + (list 'setf place (list* func arg1 place args)) + (let* ((method (cl-setf-do-modify place (cons 'list args))) + (temp (and (not (cl-const-expr-p arg1)) (gensym "--arg1--"))) + (rargs (list* (or temp arg1) (nth 2 method) args))) + (list 'let* (append (and temp (list (list temp arg1))) (car method)) + (cl-setf-do-store (nth 1 method) + (if (symbolp func) (cons func rargs) + (list* 'funcall (list 'function func) + rargs))))))) + +;;;###autoload +(defmacro define-modify-macro (name arglist func &optional doc) + "(define-modify-macro NAME ARGLIST FUNC): define a `setf'-like modify macro. +If NAME is called, it combines its PLACE argument with the other arguments +from ARGLIST using FUNC: (define-modify-macro incf (&optional (n 1)) +)" + (if (memq '&key arglist) (error "&key not allowed in define-modify-macro")) + (let ((place (gensym "--place--"))) + (list 'defmacro* name (cons place arglist) doc + (list* (if (memq '&rest arglist) 'list* 'list) + '(quote callf) (list 'quote func) place + (cl-arglist-args arglist))))) + + +;;; Structures. + +;;;###autoload +(defmacro defstruct (struct &rest descs) + "(defstruct (NAME OPTIONS...) (SLOT SLOT-OPTS...)...): define a struct type. +This macro defines a new Lisp data type called NAME, which contains data +stored in SLOTs. This defines a `make-NAME' constructor, a `copy-NAME' +copier, a `NAME-p' predicate, and setf-able `NAME-SLOT' accessors." + (let* ((name (if (consp struct) (car struct) struct)) + (opts (cdr-safe struct)) + (slots nil) + (defaults nil) + (conc-name (concat (symbol-name name) "-")) + (constructor (intern (format "make-%s" name))) + (constrs nil) + (copier (intern (format "copy-%s" name))) + (predicate (intern (format "%s-p" name))) + (print-func nil) (print-auto nil) + (safety (if (cl-compiling-file) cl-optimize-safety 3)) + (include nil) + (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) + (forms nil) + pred-form pred-check) + (if (stringp (car descs)) + (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)))) + descs))) + (while opts + (let ((opt (if (consp (car opts)) (caar opts) (car opts))) + (args (cdr-safe (cl-pop opts)))) + (cond ((eq opt ':conc-name) + (if args + (setq conc-name (if (car args) + (symbol-name (car args)) "")))) + ((eq opt ':constructor) + (if (cdr args) + (cl-push args constrs) + (if args (setq constructor (car args))))) + ((eq opt ':copier) + (if args (setq copier (car args)))) + ((eq opt ':predicate) + (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)))) + ((eq opt ':print-function) + (setq print-func (car args))) + ((eq opt ':type) + (setq type (car args))) + ((eq opt ':named) + (setq named t)) + ((eq opt ':initial-offset) + (setq descs (nconc (make-list (car args) '(cl-skip-slot)) + descs))) + (t + (error "Slot option %s unrecognized" opt))))) + (if print-func + (setq print-func (list 'progn + (list 'funcall (list 'function print-func) + 'cl-x 'cl-s 'cl-n) t)) + (or type (and include (not (get include 'cl-struct-print))) + (setq print-auto t + print-func (and (or (not (or include type)) (null print-func)) + (list 'progn + (list 'princ (format "#S(%s" name) + 'cl-s)))))) + (if include + (let ((inc-type (get include 'cl-struct-type)) + (old-descs (get include 'cl-struct-slots))) + (or inc-type (error "%s is not a struct name" include)) + (and type (not (eq (car inc-type) type)) + (error ":type disagrees with :include for %s" name)) + (while include-descs + (setcar (memq (or (assq (caar include-descs) old-descs) + (error "No slot %s in included struct %s" + (caar include-descs) include)) + old-descs) + (cl-pop include-descs))) + (setq descs (append old-descs (delq (assq 'cl-tag-slot descs) descs)) + type (car inc-type) + named (assq 'cl-tag-slot descs)) + (if (cadr inc-type) (setq tag name named t)) + (let ((incl include)) + (while incl + (cl-push (list 'pushnew (list 'quote tag) + (intern (format "cl-struct-%s-tags" incl))) + forms) + (setq incl (get incl 'cl-struct-include))))) + (if type + (progn + (or (memq type '(vector list)) + (error "Illegal :type specifier: %s" type)) + (if named (setq tag name))) + (setq type 'vector named 'true))) + (or named (setq descs (delq (assq 'cl-tag-slot descs) descs))) + (cl-push (list 'defvar tag-symbol) forms) + (setq pred-form (and named + (let ((pos (- (length descs) + (length (memq (assq 'cl-tag-slot descs) + descs))))) + (if (eq type 'vector) + (list 'and '(vectorp cl-x) + (list '>= '(length cl-x) (length descs)) + (list 'memq (list 'aref 'cl-x pos) + tag-symbol)) + (if (= pos 0) + (list 'memq '(car-safe cl-x) tag-symbol) + (list 'and '(consp cl-x) + (list 'memq (list 'nth pos 'cl-x) + tag-symbol)))))) + pred-check (and pred-form (> safety 0) + (if (and (eq (caadr pred-form) 'vectorp) + (= safety 1)) + (cons 'and (cdddr pred-form)) pred-form))) + (let ((pos 0) (descp descs)) + (while descp + (let* ((desc (cl-pop descp)) + (slot (car desc))) + (if (memq slot '(cl-tag-slot cl-skip-slot)) + (progn + (cl-push nil slots) + (cl-push (and (eq slot 'cl-tag-slot) (list 'quote tag)) + defaults)) + (if (assq slot descp) + (error "Duplicate slots named %s in %s" slot name)) + (let ((accessor (intern (format "%s%s" conc-name slot)))) + (cl-push slot slots) + (cl-push (nth 1 desc) defaults) + (cl-push (list* + 'defsubst* accessor '(cl-x) + (append + (and pred-check + (list (list 'or pred-check + (list 'error + (format "%s accessing a non-%s" + accessor name) + 'cl-x)))) + (list (if (eq type 'vector) (list 'aref 'cl-x pos) + (if (= pos 0) '(car cl-x) + (list 'nth pos 'cl-x)))))) forms) + (cl-push (cons accessor t) side-eff) + (cl-push (list 'define-setf-method accessor '(cl-x) + (if (cadr (memq ':read-only (cddr desc))) + (list 'error (format "%s is a read-only slot" + accessor)) + (list 'cl-struct-setf-expander 'cl-x + (list 'quote name) (list 'quote accessor) + (and pred-check (list 'quote pred-check)) + pos))) + forms) + (if print-auto + (nconc print-func + (list (list 'princ (format " %s" slot) 'cl-s) + (list 'prin1 (list accessor 'cl-x) 'cl-s))))))) + (setq pos (1+ pos)))) + (setq slots (nreverse slots) + defaults (nreverse defaults)) + (and predicate pred-form + (progn (cl-push (list 'defsubst* predicate '(cl-x) + (if (eq (car pred-form) 'and) + (append pred-form '(t)) + (list 'and pred-form t))) forms) + (cl-push (cons predicate 'error-free) side-eff))) + (and copier + (progn (cl-push (list 'defun copier '(x) '(copy-sequence x)) forms) + (cl-push (cons copier t) side-eff))) + (if constructor + (cl-push (list constructor + (cons '&key (delq nil (copy-sequence slots)))) + constrs)) + (while constrs + (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))) + slots defaults))) + (cl-push (list 'defsubst* name + (list* '&cl-defs (list 'quote (cons nil descs)) args) + (cons type make)) forms) + (if (cl-safe-expr-p (cons 'progn (mapcar 'second descs))) + (cl-push (cons name t) side-eff)))) + (if print-auto (nconc print-func (list '(princ ")" cl-s) t))) + (if print-func + (cl-push (list 'push + (list 'function + (list 'lambda '(cl-x cl-s cl-n) + (list 'and pred-form print-func))) + 'custom-print-functions) forms)) + (cl-push (list 'setq tag-symbol (list 'list (list 'quote tag))) forms) + (cl-push (list* 'eval-when '(compile load eval) + (list 'put (list 'quote name) '(quote cl-struct-slots) + (list 'quote descs)) + (list 'put (list 'quote name) '(quote cl-struct-type) + (list 'quote (list type (eq named t)))) + (list 'put (list 'quote name) '(quote cl-struct-include) + (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))))) + side-eff)) + forms) + (cons 'progn (nreverse (cons (list 'quote name) forms))))) + +;;;###autoload +(defun cl-struct-setf-expander (x name accessor pred-form pos) + (let* ((temp (gensym "--x--")) (store (gensym "--store--"))) + (list (list temp) (list x) (list store) + (append '(progn) + (and pred-form + (list (list 'or (subst temp 'cl-x pred-form) + (list 'error + (format + "%s storing a non-%s" accessor name) + temp)))) + (list (if (eq (car (get name 'cl-struct-type)) 'vector) + (list 'aset temp pos store) + (list 'setcar + (if (<= pos 5) + (let ((xx temp)) + (while (>= (setq pos (1- pos)) 0) + (setq xx (list 'cdr xx))) + xx) + (list 'nthcdr pos temp)) + store)))) + (list accessor temp)))) + + +;;; Types and assertions. + +;;;###autoload +(defmacro deftype (name args &rest body) + "(deftype NAME ARGLIST BODY...): define NAME as a new data type. +The type name can then be used in `typecase', `check-type', etc." + (list 'eval-when '(compile load eval) + (cl-transform-function-property + name 'cl-deftype-handler (cons (list* '&cl-defs ''('*) args) body)))) + +(defun cl-make-type-test (val type) + (if (symbolp type) + (cond ((get type 'cl-deftype-handler) + (cl-make-type-test val (funcall (get type 'cl-deftype-handler)))) + ((memq type '(nil t)) type) + ((eq type 'string-char) (list 'characterp val)) + ((eq type 'null) (list 'null val)) + ((eq type 'float) (list 'floatp-safe val)) + ((eq type 'real) (list 'numberp val)) + ((eq type 'fixnum) (list 'integerp val)) + (t + (let* ((name (symbol-name type)) + (namep (intern (concat name "p")))) + (if (fboundp namep) (list namep val) + (list (intern (concat name "-p")) val))))) + (cond ((get (car type) 'cl-deftype-handler) + (cl-make-type-test val (apply (get (car type) 'cl-deftype-handler) + (cdr type)))) + ((memq (car-safe type) '(integer float real number)) + (delq t (list 'and (cl-make-type-test val (car type)) + (if (memq (cadr type) '(* nil)) t + (if (consp (cadr type)) (list '> val (caadr type)) + (list '>= val (cadr type)))) + (if (memq (caddr type) '(* nil)) t + (if (consp (caddr type)) (list '< val (caaddr type)) + (list '<= val (caddr type))))))) + ((memq (car-safe type) '(and or not)) + (cons (car type) + (mapcar (function (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)) + ((eq (car-safe type) 'satisfies) (list (cadr type) val)) + (t (error "Bad type spec: %s" type))))) + +;;;###autoload +(defun typep (val type) ; See compiler macro below. + "Check that OBJECT is of type TYPE. +TYPE is a Common Lisp-style type specifier." + (eval (cl-make-type-test 'val type))) + +;;;###autoload +(defmacro check-type (form type &optional string) + "Verify that FORM is of type TYPE; signal an error if not. +STRING is an optional description of the desired type." + (and (or (not (cl-compiling-file)) + (< cl-optimize-speed 3) (= cl-optimize-safety 3)) + (let* ((temp (if (cl-simple-expr-p form 3) form (gensym))) + (body (list 'or (cl-make-type-test temp type) + (list 'signal '(quote wrong-type-argument) + (list 'list (or string (list 'quote type)) + temp (list 'quote form)))))) + (if (eq temp form) (list 'progn body nil) + (list 'let (list (list temp form)) body nil))))) + +;;;###autoload +(defmacro assert (form &optional show-args string &rest args) + "Verify that FORM returns non-nil; signal an error if not. +Second arg SHOW-ARGS means to include arguments of FORM in message. +Other args STRING and ARGS... are arguments to be passed to `error'. +They are not evaluated unless the assertion fails. If STRING is +omitted, a default message listing FORM itself is used." + (and (or (not (cl-compiling-file)) + (< cl-optimize-speed 3) (= cl-optimize-safety 3)) + (let ((sargs (and show-args (delq nil (mapcar + (function + (lambda (x) + (and (not (cl-const-expr-p x)) + x))) (cdr form)))))) + (list 'progn + (list 'or form + (if string + (list* 'error string (append sargs args)) + (list 'signal '(quote cl-assertion-failed) + (list* 'list (list 'quote form) sargs)))) + nil)))) + +;;;###autoload +(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))) + + +;;; Some predicates for analyzing Lisp forms. These are used by various +;;; macro expanders to optimize the results in certain common cases. + +(defconst cl-simple-funcs '(car cdr nth aref elt if and or + - 1+ 1- min max + car-safe cdr-safe progn prog1 prog2)) +(defconst cl-safe-funcs '(* / % length memq list vector vectorp + < > <= >= = error)) + +;;; Check if no side effects, and executes quickly. +(defun cl-simple-expr-p (x &optional size) + (or size (setq size 10)) + (if (and (consp x) (not (memq (car x) '(quote function function*)))) + (and (symbolp (car x)) + (or (memq (car x) cl-simple-funcs) + (get (car x) 'side-effect-free)) + (progn + (setq size (1- size)) + (while (and (setq x (cdr x)) + (setq size (cl-simple-expr-p (car x) size)))) + (and (null x) (>= size 0) size))) + (and (> size 0) (1- size)))) + +(defun cl-simple-exprs-p (xs) + (while (and xs (cl-simple-expr-p (car xs))) + (setq xs (cdr xs))) + (not xs)) + +;;; Check if no side effects. +(defun cl-safe-expr-p (x) + (or (not (and (consp x) (not (memq (car x) '(quote function function*))))) + (and (symbolp (car x)) + (or (memq (car x) cl-simple-funcs) + (memq (car x) cl-safe-funcs) + (get (car x) 'side-effect-free)) + (progn + (while (and (setq x (cdr x)) (cl-safe-expr-p (car x)))) + (null x))))) + +;;; Check if constant (i.e., no side effects or dependencies). +(defun cl-const-expr-p (x) + (cond ((consp x) + (or (eq (car x) 'quote) + (and (memq (car x) '(function function*)) + (or (symbolp (nth 1 x)) + (and (eq (car-safe (nth 1 x)) 'lambda) 'func))))) + ((symbolp x) (and (memq x '(nil t)) t)) + (t t))) + +(defun cl-const-exprs-p (xs) + (while (and xs (cl-const-expr-p (car xs))) + (setq xs (cdr xs))) + (not xs)) + +(defun cl-const-expr-val (x) + (and (eq (cl-const-expr-p x) t) (if (consp x) (nth 1 x) x))) + +(defun cl-expr-access-order (x v) + (if (cl-const-expr-p x) v + (if (consp x) + (progn + (while (setq x (cdr x)) (setq v (cl-expr-access-order (car x) v))) + v) + (if (eq x (car v)) (cdr v) '(t))))) + +;;; Count number of times X refers to Y. Return NIL for 0 times. +(defun cl-expr-contains (x y) + (cond ((equal y x) 1) + ((and (consp x) (not (memq (car-safe x) '(quote function function*)))) + (let ((sum 0)) + (while x + (setq sum (+ sum (or (cl-expr-contains (cl-pop x) y) 0)))) + (and (> sum 0) sum))) + (t nil))) + +(defun cl-expr-contains-any (x y) + (while (and y (not (cl-expr-contains x (car y)))) (cl-pop y)) + y) + +;;; Check whether X may depend on any of the symbols in Y. +(defun cl-expr-depends-p (x y) + (and (not (cl-const-expr-p x)) + (or (not (cl-safe-expr-p x)) (cl-expr-contains-any x y)))) + + +;;; Compiler macros. + +;;;###autoload +(defmacro define-compiler-macro (func args &rest body) + "(define-compiler-macro FUNC ARGLIST BODY...): Define a compiler-only macro. +This is like `defmacro', but macro expansion occurs only if the call to +FUNC is compiled (i.e., not interpreted). Compiler macros should be used +for optimizing the way calls to FUNC are compiled; the form returned by +BODY should do the same thing as a call to the normal function called +FUNC, though possibly more efficiently. Note that, like regular macros, +compiler macros are expanded repeatedly until no further expansions are +possible. Unlike regular macros, BODY can decide to \"punt\" and leave the +original function call alone by declaring an initial `&whole foo' parameter +and then returning foo." + (let ((p (if (listp args) args (list '&rest args))) (res nil)) + (while (consp p) (cl-push (cl-pop p) res)) + (setq args (nreverse res)) (setcdr res (and p (list '&rest p)))) + (list 'eval-when '(compile load eval) + (cl-transform-function-property + func 'cl-compiler-macro + (cons (if (memq '&whole args) (delq '&whole args) + (cons '--cl-whole-arg-- args)) body)) + (list 'or (list 'get (list 'quote func) '(quote byte-compile)) + (list 'put (list 'quote func) '(quote byte-compile) + '(quote cl-byte-compile-compiler-macro))))) + +;;;###autoload +(defun compiler-macroexpand (form) + (while + (let ((func (car-safe form)) (handler nil)) + (while (and (symbolp func) + (not (setq handler (get func 'cl-compiler-macro))) + (fboundp func) + (or (not (eq (car-safe (symbol-function func)) 'autoload)) + (load (nth 1 (symbol-function func))))) + (setq func (symbol-function func))) + (and handler + (not (eq form (setq form (apply handler form (cdr form)))))))) + form) + +(defun cl-byte-compile-compiler-macro (form) + (if (eq form (setq form (compiler-macroexpand form))) + (byte-compile-normal-call form) + (byte-compile-form form))) + +(defmacro defsubst* (name args &rest body) + "(defsubst* NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function. +Like `defun', except the function is automatically declared `inline', +ARGLIST allows full Common Lisp conventions, and BODY is implicitly +surrounded by (block NAME ...)." + (let* ((argns (cl-arglist-args args)) (p argns) + (pbody (cons 'progn body)) + (unsafe (not (cl-safe-expr-p pbody)))) + (while (and p (eq (cl-expr-contains args (car p)) 1)) (cl-pop p)) + (list 'progn + (if p nil ; give up if defaults refer to earlier args + (list 'define-compiler-macro name + (list* '&whole 'cl-whole '&cl-quote args) + (list* 'cl-defsubst-expand (list 'quote argns) + (list 'quote (list* 'block name body)) + (not (or unsafe (cl-expr-access-order pbody argns))) + (and (memq '&key args) 'cl-whole) unsafe argns))) + (list* 'defun* name args body)))) + +(defun cl-defsubst-expand (argns body simple whole unsafe &rest argvs) + (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)))) + argns argvs)))) + (if lets (list 'let lets body) body)))) + + +;;; Compile-time optimizations for some functions defined in this package. +;;; Note that cl.el arranges to force cl-macs to be loaded at compile-time, +;;; mainly to make sure these macros will be present. + +(put 'eql 'byte-compile nil) +(define-compiler-macro eql (&whole form a b) + (cond ((eq (cl-const-expr-p a) t) + (let ((val (cl-const-expr-val a))) + (if (and (numberp val) (not (integerp val))) + (list 'equal a b) + (list 'eq a b)))) + ((eq (cl-const-expr-p b) t) + (let ((val (cl-const-expr-val b))) + (if (and (numberp val) (not (integerp val))) + (list 'equal a b) + (list 'eq a b)))) + ((cl-simple-expr-p a 5) + (list 'if (list 'numberp a) + (list 'equal a b) + (list 'eq a b))) + ((and (cl-safe-expr-p a) + (cl-simple-expr-p b 5)) + (list 'if (list 'numberp b) + (list 'equal a b) + (list 'eq a b))) + (t form))) + +(define-compiler-macro member* (&whole form a list &rest keys) + (let ((test (and (= (length keys) 2) (eq (car keys) ':test) + (cl-const-expr-val (nth 1 keys))))) + (cond ((eq test 'eq) (list 'memq a list)) + ((eq test 'equal) (list 'member a list)) + ((or (null keys) (eq test 'eql)) + (if (eq (cl-const-expr-p a) t) + (list (if (floatp-safe (cl-const-expr-val a)) 'member 'memq) + a list) + (if (eq (cl-const-expr-p list) t) + (let ((p (cl-const-expr-val list)) (mb nil) (mq nil)) + (if (not (cdr p)) + (and p (list 'eql a (list 'quote (car p)))) + (while p + (if (floatp-safe (car p)) (setq mb t) + (or (integerp (car p)) (symbolp (car p)) (setq mq t))) + (setq p (cdr p))) + (if (not mb) (list 'memq a list) + (if (not mq) (list 'member a list) form)))) + form))) + (t form)))) + +(define-compiler-macro assoc* (&whole form a list &rest keys) + (let ((test (and (= (length keys) 2) (eq (car keys) ':test) + (cl-const-expr-val (nth 1 keys))))) + (cond ((eq test 'eq) (list 'assq a list)) + ((eq test 'equal) (list 'assoc a list)) + ((and (eq (cl-const-expr-p a) t) (or (null keys) (eq test 'eql))) + (if (floatp-safe (cl-const-expr-val a)) + (list 'assoc a list) (list 'assq a list))) + (t form)))) + +(define-compiler-macro adjoin (&whole form a list &rest keys) + (if (and (cl-simple-expr-p a) (cl-simple-expr-p list) + (not (memq ':key keys))) + (list 'if (list* 'member* a list keys) list (list 'cons a list)) + form)) + +(define-compiler-macro list* (arg &rest others) + (let* ((args (reverse (cons arg others))) + (form (car args))) + (while (setq args (cdr args)) + (setq form (list 'cons (car args) form))) + form)) + +(define-compiler-macro get* (sym prop &optional def) + (if def + (list 'getf (list 'symbol-plist sym) prop def) + (list 'get sym prop))) + +(define-compiler-macro typep (&whole form val type) + (if (cl-const-expr-p type) + (let ((res (cl-make-type-test val (cl-const-expr-val type)))) + (if (or (memq (cl-expr-contains res val) '(nil 1)) + (cl-simple-expr-p val)) res + (let ((temp (gensym))) + (list 'let (list (list temp val)) (subst temp val res))))) + 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) )) + +;;; Things that are inline. +(proclaim '(inline floatp-safe acons map concatenate notany notevery +;; XEmacs change + cl-set-elt revappend nreconc)) + +;;; Things that are side-effect-free. +(mapcar (function (lambda (x) (put x 'side-effect-free t))) + '(oddp evenp abs expt signum last butlast ldiff pairlis gcd lcm + isqrt floor* ceiling* truncate* round* mod* rem* subseq + list-length get* getf gethash hash-table-count)) + +;;; Things that are side-effect-and-error-free. +(mapcar (function (lambda (x) (put x 'side-effect-free 'error-free))) + '(eql floatp-safe list* subst acons equalp random-state-p + copy-tree sublis hash-table-p)) + + +(run-hooks 'cl-macs-load-hook) + +;;; cl-macs.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cl-seq.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,938 @@ +;;; cl-seq.el --- Common Lisp extensions for GNU Emacs Lisp (part three) + +;; Copyright (C) 1993 Free Software Foundation, Inc. + +;; Author: Dave Gillespie <daveg@synaptics.com> +;; Maintainer: XEmacs Development Team +;; Version: 2.02 +;; Keywords: extensions, dumped + +;; 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.34. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;; These are extensions to Emacs Lisp that provide a degree of +;; Common Lisp compatibility, beyond what is already built-in +;; in Emacs Lisp. +;; +;; This package was written by Dave Gillespie; it is a complete +;; rewrite of Cesar Quiroz's original cl.el package of December 1986. +;; +;; This package works with Emacs 18, Emacs 19, and Lucid Emacs 19. +;; +;; Bug reports, comments, and suggestions are welcome! + +;; This file contains the Common Lisp sequence and list functions +;; which take keyword arguments. + +;; See cl.el for Change Log. + + +;;; Code: + +(or (memq 'cl-19 features) + (error "Tried to load `cl-seq' before `cl'!")) + + +;;; We define these here so that this file can compile without having +;;; loaded the cl.el file already. + +(defmacro cl-push (x place) (list 'setq place (list 'cons x place))) +(defmacro cl-pop (place) + (list 'car (list 'prog1 place (list 'setq place (list 'cdr place))))) + + +;;; Keyword parsing. This is special-cased here so that we can compile +;;; this file independent from cl-macs. + +(defmacro cl-parsing-keywords (kwords other-keys &rest body) + (cons + 'let* + (cons (mapcar + (function + (lambda (x) + (let* ((var (if (consp x) (car x) x)) + (mem (list 'car (list 'cdr (list 'memq (list 'quote var) + 'cl-keys))))) + (if (eq var ':test-not) + (setq mem (list 'and mem (list 'setq 'cl-test mem) t))) + (if (eq var ':if-not) + (setq mem (list 'and mem (list 'setq 'cl-if mem) t))) + (list (intern + (format "cl-%s" (substring (symbol-name var) 1))) + (if (consp x) (list 'or mem (car (cdr x))) mem))))) + kwords) + (append + (and (not (eq other-keys t)) + (list + (list 'let '((cl-keys-temp cl-keys)) + (list 'while 'cl-keys-temp + (list 'or (list 'memq '(car cl-keys-temp) + (list 'quote + (mapcar + (function + (lambda (x) + (if (consp x) + (car x) x))) + (append kwords + other-keys)))) + '(car (cdr (memq (quote :allow-other-keys) + cl-keys))) + '(error "Bad keyword argument %s" + (car cl-keys-temp))) + '(setq cl-keys-temp (cdr (cdr cl-keys-temp))))))) + body)))) +(put 'cl-parsing-keywords 'lisp-indent-function 2) +(put 'cl-parsing-keywords 'edebug-form-spec '(sexp sexp &rest form)) + +(defmacro cl-check-key (x) + (list 'if 'cl-key (list 'funcall 'cl-key x) x)) + +(defmacro cl-check-test-nokey (item x) + (list 'cond + (list 'cl-test + (list 'eq (list 'not (list 'funcall 'cl-test item x)) + 'cl-test-not)) + (list 'cl-if + (list 'eq (list 'not (list 'funcall 'cl-if x)) 'cl-if-not)) + (list 't (list 'if (list 'numberp item) + (list 'equal item x) (list 'eq item x))))) + +(defmacro cl-check-test (item x) + (list 'cl-check-test-nokey item (list 'cl-check-key x))) + +(defmacro cl-check-match (x y) + (setq x (list 'cl-check-key x) y (list 'cl-check-key y)) + (list 'if 'cl-test + (list 'eq (list 'not (list 'funcall 'cl-test x y)) 'cl-test-not) + (list 'if (list 'numberp x) + (list 'equal x y) (list 'eq x y)))) + +(put 'cl-check-key 'edebug-form-spec 'edebug-forms) +(put 'cl-check-test 'edebug-form-spec 'edebug-forms) +(put 'cl-check-test-nokey 'edebug-form-spec 'edebug-forms) +(put 'cl-check-match 'edebug-form-spec 'edebug-forms) + +(defvar cl-test) (defvar cl-test-not) +(defvar cl-if) (defvar cl-if-not) +(defvar cl-key) + + +(defun reduce (cl-func cl-seq &rest cl-keys) + "Reduce two-argument FUNCTION across SEQUENCE. +Keywords supported: :start :end :from-end :initial-value :key" + (cl-parsing-keywords (:from-end (:start 0) :end :initial-value :key) () + (or (listp cl-seq) (setq cl-seq (append cl-seq nil))) + (setq cl-seq (subseq cl-seq cl-start cl-end)) + (if cl-from-end (setq cl-seq (nreverse cl-seq))) + (let ((cl-accum (cond ((memq ':initial-value cl-keys) cl-initial-value) + (cl-seq (cl-check-key (cl-pop cl-seq))) + (t (funcall cl-func))))) + (if cl-from-end + (while cl-seq + (setq cl-accum (funcall cl-func (cl-check-key (cl-pop cl-seq)) + cl-accum))) + (while cl-seq + (setq cl-accum (funcall cl-func cl-accum + (cl-check-key (cl-pop cl-seq)))))) + cl-accum))) + +(defun fill (seq item &rest cl-keys) + "Fill the elements of SEQ with ITEM. +Keywords supported: :start :end" + (cl-parsing-keywords ((:start 0) :end) () + (if (listp seq) + (let ((p (nthcdr cl-start seq)) + (n (if cl-end (- cl-end cl-start) 8000000))) + (while (and p (>= (setq n (1- n)) 0)) + (setcar p item) + (setq p (cdr p)))) + (or cl-end (setq cl-end (length seq))) + (if (and (= cl-start 0) (= cl-end (length seq))) + (fillarray seq item) + (while (< cl-start cl-end) + (aset seq cl-start item) + (setq cl-start (1+ cl-start))))) + seq)) + +(defun replace (cl-seq1 cl-seq2 &rest cl-keys) + "Replace the elements of SEQ1 with the elements of SEQ2. +SEQ1 is destructively modified, then returned. +Keywords supported: :start1 :end1 :start2 :end2" + (cl-parsing-keywords ((:start1 0) :end1 (:start2 0) :end2) () + (if (and (eq cl-seq1 cl-seq2) (<= cl-start2 cl-start1)) + (or (= cl-start1 cl-start2) + (let* ((cl-len (length cl-seq1)) + (cl-n (min (- (or cl-end1 cl-len) cl-start1) + (- (or cl-end2 cl-len) cl-start2)))) + (while (>= (setq cl-n (1- cl-n)) 0) + (cl-set-elt cl-seq1 (+ cl-start1 cl-n) + (elt cl-seq2 (+ cl-start2 cl-n)))))) + (if (listp cl-seq1) + (let ((cl-p1 (nthcdr cl-start1 cl-seq1)) + (cl-n1 (if cl-end1 (- cl-end1 cl-start1) 4000000))) + (if (listp cl-seq2) + (let ((cl-p2 (nthcdr cl-start2 cl-seq2)) + (cl-n (min cl-n1 + (if cl-end2 (- cl-end2 cl-start2) 4000000)))) + (while (and cl-p1 cl-p2 (>= (setq cl-n (1- cl-n)) 0)) + (setcar cl-p1 (car cl-p2)) + (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2)))) + (setq cl-end2 (min (or cl-end2 (length cl-seq2)) + (+ cl-start2 cl-n1))) + (while (and cl-p1 (< cl-start2 cl-end2)) + (setcar cl-p1 (aref cl-seq2 cl-start2)) + (setq cl-p1 (cdr cl-p1) cl-start2 (1+ cl-start2))))) + (setq cl-end1 (min (or cl-end1 (length cl-seq1)) + (+ cl-start1 (- (or cl-end2 (length cl-seq2)) + cl-start2)))) + (if (listp cl-seq2) + (let ((cl-p2 (nthcdr cl-start2 cl-seq2))) + (while (< cl-start1 cl-end1) + (aset cl-seq1 cl-start1 (car cl-p2)) + (setq cl-p2 (cdr cl-p2) cl-start1 (1+ cl-start1)))) + (while (< cl-start1 cl-end1) + (aset cl-seq1 cl-start1 (aref cl-seq2 cl-start2)) + (setq cl-start2 (1+ cl-start2) cl-start1 (1+ cl-start1)))))) + cl-seq1)) + +(defun remove* (cl-item cl-seq &rest cl-keys) + "Remove all occurrences of ITEM in SEQ. +This is a non-destructive function; it makes a copy of SEQ if necessary +to avoid corrupting the original SEQ. +Keywords supported: :test :test-not :key :count :start :end :from-end" + (cl-parsing-keywords (:test :test-not :key :if :if-not :count :from-end + (:start 0) :end) () + (if (<= (or cl-count (setq cl-count 8000000)) 0) + cl-seq + (if (or (nlistp cl-seq) (and cl-from-end (< cl-count 4000000))) + (let ((cl-i (cl-position cl-item cl-seq cl-start cl-end + cl-from-end))) + (if cl-i + (let ((cl-res (apply 'delete* cl-item (append cl-seq nil) + (append (if cl-from-end + (list ':end (1+ cl-i)) + (list ':start cl-i)) + cl-keys)))) + (if (listp cl-seq) cl-res + (if (stringp cl-seq) (concat cl-res) (vconcat cl-res)))) + cl-seq)) + (setq cl-end (- (or cl-end 8000000) cl-start)) + (if (= cl-start 0) + (while (and cl-seq (> cl-end 0) + (cl-check-test cl-item (car cl-seq)) + (setq cl-end (1- cl-end) cl-seq (cdr cl-seq)) + (> (setq cl-count (1- cl-count)) 0)))) + (if (and (> cl-count 0) (> cl-end 0)) + (let ((cl-p (if (> cl-start 0) (nthcdr cl-start cl-seq) + (setq cl-end (1- cl-end)) (cdr cl-seq)))) + (while (and cl-p (> cl-end 0) + (not (cl-check-test cl-item (car cl-p)))) + (setq cl-p (cdr cl-p) cl-end (1- cl-end))) + (if (and cl-p (> cl-end 0)) + (nconc (ldiff cl-seq cl-p) + (if (= cl-count 1) (cdr cl-p) + (and (cdr cl-p) + (apply 'delete* cl-item + (copy-sequence (cdr cl-p)) + ':start 0 ':end (1- cl-end) + ':count (1- cl-count) cl-keys)))) + cl-seq)) + cl-seq))))) + +(defun remove-if (cl-pred cl-list &rest cl-keys) + "Remove all items satisfying PREDICATE in SEQ. +This is a non-destructive function; it makes a copy of SEQ if necessary +to avoid corrupting the original SEQ. +Keywords supported: :key :count :start :end :from-end" + (apply 'remove* nil cl-list ':if cl-pred cl-keys)) + +(defun remove-if-not (cl-pred cl-list &rest cl-keys) + "Remove all items not satisfying PREDICATE in SEQ. +This is a non-destructive function; it makes a copy of SEQ if necessary +to avoid corrupting the original SEQ. +Keywords supported: :key :count :start :end :from-end" + (apply 'remove* nil cl-list ':if-not cl-pred cl-keys)) + +(defun delete* (cl-item cl-seq &rest cl-keys) + "Remove all occurrences of ITEM in SEQ. +This is a destructive function; it reuses the storage of SEQ whenever possible. +Keywords supported: :test :test-not :key :count :start :end :from-end" + (cl-parsing-keywords (:test :test-not :key :if :if-not :count :from-end + (:start 0) :end) () + (if (<= (or cl-count (setq cl-count 8000000)) 0) + cl-seq + (if (listp cl-seq) + (if (and cl-from-end (< cl-count 4000000)) + (let (cl-i) + (while (and (>= (setq cl-count (1- cl-count)) 0) + (setq cl-i (cl-position cl-item cl-seq cl-start + cl-end cl-from-end))) + (if (= cl-i 0) (setq cl-seq (cdr cl-seq)) + (let ((cl-tail (nthcdr (1- cl-i) cl-seq))) + (setcdr cl-tail (cdr (cdr cl-tail))))) + (setq cl-end cl-i)) + cl-seq) + (setq cl-end (- (or cl-end 8000000) cl-start)) + (if (= cl-start 0) + (progn + (while (and cl-seq + (> cl-end 0) + (cl-check-test cl-item (car cl-seq)) + (setq cl-end (1- cl-end) cl-seq (cdr cl-seq)) + (> (setq cl-count (1- cl-count)) 0))) + (setq cl-end (1- cl-end))) + (setq cl-start (1- cl-start))) + (if (and (> cl-count 0) (> cl-end 0)) + (let ((cl-p (nthcdr cl-start cl-seq))) + (while (and (cdr cl-p) (> cl-end 0)) + (if (cl-check-test cl-item (car (cdr cl-p))) + (progn + (setcdr cl-p (cdr (cdr cl-p))) + (if (= (setq cl-count (1- cl-count)) 0) + (setq cl-end 1))) + (setq cl-p (cdr cl-p))) + (setq cl-end (1- cl-end))))) + cl-seq) + (apply 'remove* cl-item cl-seq cl-keys))))) + +(defun delete-if (cl-pred cl-list &rest cl-keys) + "Remove all items satisfying PREDICATE in SEQ. +This is a destructive function; it reuses the storage of SEQ whenever possible. +Keywords supported: :key :count :start :end :from-end" + (apply 'delete* nil cl-list ':if cl-pred cl-keys)) + +(defun delete-if-not (cl-pred cl-list &rest cl-keys) + "Remove all items not satisfying PREDICATE in SEQ. +This is a destructive function; it reuses the storage of SEQ whenever possible. +Keywords supported: :key :count :start :end :from-end" + (apply 'delete* nil cl-list ':if-not cl-pred cl-keys)) + +(or (and (fboundp 'delete) (subrp (symbol-function 'delete))) + (defalias 'delete (function (lambda (x y) (delete* x y ':test 'equal))))) + +(defun remove (cl-item cl-seq) + "Remove all occurrences of ITEM in SEQ, testing with `equal' +This is a non-destructive function; it makes a copy of SEQ if necessary +to avoid corrupting the original SEQ. +Also see: `remove*', `delete', `delete*'" + (remove* cl-item cl-seq ':test 'equal)) + +(defun remq (cl-elt cl-list) + "Remove all occurances of ELT in LIST, comparing with `eq'. +This is a non-destructive function; it makes a copy of LIST to avoid +corrupting the original LIST. +Also see: `delq', `delete', `delete*', `remove', `remove*'." + (if (memq cl-elt cl-list) + (delq cl-elt (copy-list cl-list)) + cl-list)) + +(defun remove-duplicates (cl-seq &rest cl-keys) + "Return a copy of SEQ with all duplicate elements removed. +Keywords supported: :test :test-not :key :start :end :from-end" + (cl-delete-duplicates cl-seq cl-keys t)) + +(defun delete-duplicates (cl-seq &rest cl-keys) + "Remove all duplicate elements from SEQ (destructively). +Keywords supported: :test :test-not :key :start :end :from-end" + (cl-delete-duplicates cl-seq cl-keys nil)) + +(defun cl-delete-duplicates (cl-seq cl-keys cl-copy) + (if (listp cl-seq) + (cl-parsing-keywords (:test :test-not :key (:start 0) :end :from-end :if) + () + (if cl-from-end + (let ((cl-p (nthcdr cl-start cl-seq)) cl-i) + (setq cl-end (- (or cl-end (length cl-seq)) cl-start)) + (while (> cl-end 1) + (setq cl-i 0) + (while (setq cl-i (cl-position (cl-check-key (car cl-p)) + (cdr cl-p) cl-i (1- cl-end))) + (if cl-copy (setq cl-seq (copy-sequence cl-seq) + cl-p (nthcdr cl-start cl-seq) cl-copy nil)) + (let ((cl-tail (nthcdr cl-i cl-p))) + (setcdr cl-tail (cdr (cdr cl-tail)))) + (setq cl-end (1- cl-end))) + (setq cl-p (cdr cl-p) cl-end (1- cl-end) + cl-start (1+ cl-start))) + cl-seq) + (setq cl-end (- (or cl-end (length cl-seq)) cl-start)) + (while (and (cdr cl-seq) (= cl-start 0) (> cl-end 1) + (cl-position (cl-check-key (car cl-seq)) + (cdr cl-seq) 0 (1- cl-end))) + (setq cl-seq (cdr cl-seq) cl-end (1- cl-end))) + (let ((cl-p (if (> cl-start 0) (nthcdr (1- cl-start) cl-seq) + (setq cl-end (1- cl-end) cl-start 1) cl-seq))) + (while (and (cdr (cdr cl-p)) (> cl-end 1)) + (if (cl-position (cl-check-key (car (cdr cl-p))) + (cdr (cdr cl-p)) 0 (1- cl-end)) + (progn + (if cl-copy (setq cl-seq (copy-sequence cl-seq) + cl-p (nthcdr (1- cl-start) cl-seq) + cl-copy nil)) + (setcdr cl-p (cdr (cdr cl-p)))) + (setq cl-p (cdr cl-p))) + (setq cl-end (1- cl-end) cl-start (1+ cl-start))) + cl-seq))) + (let ((cl-res (cl-delete-duplicates (append cl-seq nil) cl-keys nil))) + (if (stringp cl-seq) (concat cl-res) (vconcat cl-res))))) + +(defun substitute (cl-new cl-old cl-seq &rest cl-keys) + "Substitute NEW for OLD in SEQ. +This is a non-destructive function; it makes a copy of SEQ if necessary +to avoid corrupting the original SEQ. +Keywords supported: :test :test-not :key :count :start :end :from-end" + (cl-parsing-keywords (:test :test-not :key :if :if-not :count + (:start 0) :end :from-end) () + (if (or (eq cl-old cl-new) + (<= (or cl-count (setq cl-from-end nil cl-count 8000000)) 0)) + cl-seq + (let ((cl-i (cl-position cl-old cl-seq cl-start cl-end))) + (if (not cl-i) + cl-seq + (setq cl-seq (copy-sequence cl-seq)) + (or cl-from-end + (progn (cl-set-elt cl-seq cl-i cl-new) + (setq cl-i (1+ cl-i) cl-count (1- cl-count)))) + (apply 'nsubstitute cl-new cl-old cl-seq ':count cl-count + ':start cl-i cl-keys)))))) + +(defun substitute-if (cl-new cl-pred cl-list &rest cl-keys) + "Substitute NEW for all items satisfying PREDICATE in SEQ. +This is a non-destructive function; it makes a copy of SEQ if necessary +to avoid corrupting the original SEQ. +Keywords supported: :key :count :start :end :from-end" + (apply 'substitute cl-new nil cl-list ':if cl-pred cl-keys)) + +(defun substitute-if-not (cl-new cl-pred cl-list &rest cl-keys) + "Substitute NEW for all items not satisfying PREDICATE in SEQ. +This is a non-destructive function; it makes a copy of SEQ if necessary +to avoid corrupting the original SEQ. +Keywords supported: :key :count :start :end :from-end" + (apply 'substitute cl-new nil cl-list ':if-not cl-pred cl-keys)) + +(defun nsubstitute (cl-new cl-old cl-seq &rest cl-keys) + "Substitute NEW for OLD in SEQ. +This is a destructive function; it reuses the storage of SEQ whenever possible. +Keywords supported: :test :test-not :key :count :start :end :from-end" + (cl-parsing-keywords (:test :test-not :key :if :if-not :count + (:start 0) :end :from-end) () + (or (eq cl-old cl-new) (<= (or cl-count (setq cl-count 8000000)) 0) + (if (and (listp cl-seq) (or (not cl-from-end) (> cl-count 4000000))) + (let ((cl-p (nthcdr cl-start cl-seq))) + (setq cl-end (- (or cl-end 8000000) cl-start)) + (while (and cl-p (> cl-end 0) (> cl-count 0)) + (if (cl-check-test cl-old (car cl-p)) + (progn + (setcar cl-p cl-new) + (setq cl-count (1- cl-count)))) + (setq cl-p (cdr cl-p) cl-end (1- cl-end)))) + (or cl-end (setq cl-end (length cl-seq))) + (if cl-from-end + (while (and (< cl-start cl-end) (> cl-count 0)) + (setq cl-end (1- cl-end)) + (if (cl-check-test cl-old (elt cl-seq cl-end)) + (progn + (cl-set-elt cl-seq cl-end cl-new) + (setq cl-count (1- cl-count))))) + (while (and (< cl-start cl-end) (> cl-count 0)) + (if (cl-check-test cl-old (aref cl-seq cl-start)) + (progn + (aset cl-seq cl-start cl-new) + (setq cl-count (1- cl-count)))) + (setq cl-start (1+ cl-start)))))) + cl-seq)) + +(defun nsubstitute-if (cl-new cl-pred cl-list &rest cl-keys) + "Substitute NEW for all items satisfying PREDICATE in SEQ. +This is a destructive function; it reuses the storage of SEQ whenever possible. +Keywords supported: :key :count :start :end :from-end" + (apply 'nsubstitute cl-new nil cl-list ':if cl-pred cl-keys)) + +(defun nsubstitute-if-not (cl-new cl-pred cl-list &rest cl-keys) + "Substitute NEW for all items not satisfying PREDICATE in SEQ. +This is a destructive function; it reuses the storage of SEQ whenever possible. +Keywords supported: :key :count :start :end :from-end" + (apply 'nsubstitute cl-new nil cl-list ':if-not cl-pred cl-keys)) + +(defun find (cl-item cl-seq &rest cl-keys) + "Find the first occurrence of ITEM in LIST. +Return the matching ITEM, or nil if not found. +Keywords supported: :test :test-not :key :start :end :from-end" + (let ((cl-pos (apply 'position cl-item cl-seq cl-keys))) + (and cl-pos (elt cl-seq cl-pos)))) + +(defun find-if (cl-pred cl-list &rest cl-keys) + "Find the first item satisfying PREDICATE in LIST. +Return the matching ITEM, or nil if not found. +Keywords supported: :key :start :end :from-end" + (apply 'find nil cl-list ':if cl-pred cl-keys)) + +(defun find-if-not (cl-pred cl-list &rest cl-keys) + "Find the first item not satisfying PREDICATE in LIST. +Return the matching ITEM, or nil if not found. +Keywords supported: :key :start :end :from-end" + (apply 'find nil cl-list ':if-not cl-pred cl-keys)) + +(defun position (cl-item cl-seq &rest cl-keys) + "Find the first occurrence of ITEM in LIST. +Return the index of the matching item, or nil if not found. +Keywords supported: :test :test-not :key :start :end :from-end" + (cl-parsing-keywords (:test :test-not :key :if :if-not + (:start 0) :end :from-end) () + (cl-position cl-item cl-seq cl-start cl-end cl-from-end))) + +(defun cl-position (cl-item cl-seq cl-start &optional cl-end cl-from-end) + (if (listp cl-seq) + (let ((cl-p (nthcdr cl-start cl-seq))) + (or cl-end (setq cl-end 8000000)) + (let ((cl-res nil)) + (while (and cl-p (< cl-start cl-end) (or (not cl-res) cl-from-end)) + (if (cl-check-test cl-item (car cl-p)) + (setq cl-res cl-start)) + (setq cl-p (cdr cl-p) cl-start (1+ cl-start))) + cl-res)) + (or cl-end (setq cl-end (length cl-seq))) + (if cl-from-end + (progn + (while (and (>= (setq cl-end (1- cl-end)) cl-start) + (not (cl-check-test cl-item (aref cl-seq cl-end))))) + (and (>= cl-end cl-start) cl-end)) + (while (and (< cl-start cl-end) + (not (cl-check-test cl-item (aref cl-seq cl-start)))) + (setq cl-start (1+ cl-start))) + (and (< cl-start cl-end) cl-start)))) + +(defun position-if (cl-pred cl-list &rest cl-keys) + "Find the first item satisfying PREDICATE in LIST. +Return the index of the matching item, or nil if not found. +Keywords supported: :key :start :end :from-end" + (apply 'position nil cl-list ':if cl-pred cl-keys)) + +(defun position-if-not (cl-pred cl-list &rest cl-keys) + "Find the first item not satisfying PREDICATE in LIST. +Return the index of the matching item, or nil if not found. +Keywords supported: :key :start :end :from-end" + (apply 'position nil cl-list ':if-not cl-pred cl-keys)) + +(defun count (cl-item cl-seq &rest cl-keys) + "Count the number of occurrences of ITEM in LIST. +Keywords supported: :test :test-not :key :start :end" + (cl-parsing-keywords (:test :test-not :key :if :if-not (:start 0) :end) () + (let ((cl-count 0) cl-x) + (or cl-end (setq cl-end (length cl-seq))) + (if (consp cl-seq) (setq cl-seq (nthcdr cl-start cl-seq))) + (while (< cl-start cl-end) + (setq cl-x (if (consp cl-seq) (cl-pop cl-seq) (aref cl-seq cl-start))) + (if (cl-check-test cl-item cl-x) (setq cl-count (1+ cl-count))) + (setq cl-start (1+ cl-start))) + cl-count))) + +(defun count-if (cl-pred cl-list &rest cl-keys) + "Count the number of items satisfying PREDICATE in LIST. +Keywords supported: :key :start :end" + (apply 'count nil cl-list ':if cl-pred cl-keys)) + +(defun count-if-not (cl-pred cl-list &rest cl-keys) + "Count the number of items not satisfying PREDICATE in LIST. +Keywords supported: :key :start :end" + (apply 'count nil cl-list ':if-not cl-pred cl-keys)) + +(defun mismatch (cl-seq1 cl-seq2 &rest cl-keys) + "Compare SEQ1 with SEQ2, return index of first mismatching element. +Return nil if the sequences match. If one sequence is a prefix of the +other, the return value indicates the end of the shorted sequence. +Keywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end" + (cl-parsing-keywords (:test :test-not :key :from-end + (:start1 0) :end1 (:start2 0) :end2) () + (or cl-end1 (setq cl-end1 (length cl-seq1))) + (or cl-end2 (setq cl-end2 (length cl-seq2))) + (if cl-from-end + (progn + (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2) + (cl-check-match (elt cl-seq1 (1- cl-end1)) + (elt cl-seq2 (1- cl-end2)))) + (setq cl-end1 (1- cl-end1) cl-end2 (1- cl-end2))) + (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2)) + (1- cl-end1))) + (let ((cl-p1 (and (listp cl-seq1) (nthcdr cl-start1 cl-seq1))) + (cl-p2 (and (listp cl-seq2) (nthcdr cl-start2 cl-seq2)))) + (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2) + (cl-check-match (if cl-p1 (car cl-p1) + (aref cl-seq1 cl-start1)) + (if cl-p2 (car cl-p2) + (aref cl-seq2 cl-start2)))) + (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2) + cl-start1 (1+ cl-start1) cl-start2 (1+ cl-start2))) + (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2)) + cl-start1))))) + +(defun search (cl-seq1 cl-seq2 &rest cl-keys) + "Search for SEQ1 as a subsequence of SEQ2. +Return the index of the leftmost element of the first match found; +return nil if there are no matches. +Keywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end" + (cl-parsing-keywords (:test :test-not :key :from-end + (:start1 0) :end1 (:start2 0) :end2) () + (or cl-end1 (setq cl-end1 (length cl-seq1))) + (or cl-end2 (setq cl-end2 (length cl-seq2))) + (if (>= cl-start1 cl-end1) + (if cl-from-end cl-end2 cl-start2) + (let* ((cl-len (- cl-end1 cl-start1)) + (cl-first (cl-check-key (elt cl-seq1 cl-start1))) + (cl-if nil) cl-pos) + (setq cl-end2 (- cl-end2 (1- cl-len))) + (while (and (< cl-start2 cl-end2) + (setq cl-pos (cl-position cl-first cl-seq2 + cl-start2 cl-end2 cl-from-end)) + (apply 'mismatch cl-seq1 cl-seq2 + ':start1 (1+ cl-start1) ':end1 cl-end1 + ':start2 (1+ cl-pos) ':end2 (+ cl-pos cl-len) + ':from-end nil cl-keys)) + (if cl-from-end (setq cl-end2 cl-pos) (setq cl-start2 (1+ cl-pos)))) + (and (< cl-start2 cl-end2) cl-pos))))) + +(defun sort* (cl-seq cl-pred &rest cl-keys) + "Sort the argument SEQUENCE according to PREDICATE. +This is a destructive function; it reuses the storage of SEQUENCE if possible. +Keywords supported: :key" + (if (nlistp cl-seq) + (replace cl-seq (apply 'sort* (append cl-seq nil) cl-pred cl-keys)) + (cl-parsing-keywords (:key) () + (if (memq cl-key '(nil identity)) + (sort cl-seq cl-pred) + (sort cl-seq (function (lambda (cl-x cl-y) + (funcall cl-pred (funcall cl-key cl-x) + (funcall cl-key cl-y))))))))) + +(defun stable-sort (cl-seq cl-pred &rest cl-keys) + "Sort the argument SEQUENCE stably according to PREDICATE. +This is a destructive function; it reuses the storage of SEQUENCE if possible. +Keywords supported: :key" + (apply 'sort* cl-seq cl-pred cl-keys)) + +(defun merge (cl-type cl-seq1 cl-seq2 cl-pred &rest cl-keys) + "Destructively merge the two sequences to produce a new sequence. +TYPE is the sequence type to return, SEQ1 and SEQ2 are the two +argument sequences, and PRED is a `less-than' predicate on the elements. +Keywords supported: :key" + (or (listp cl-seq1) (setq cl-seq1 (append cl-seq1 nil))) + (or (listp cl-seq2) (setq cl-seq2 (append cl-seq2 nil))) + (cl-parsing-keywords (:key) () + (let ((cl-res nil)) + (while (and cl-seq1 cl-seq2) + (if (funcall cl-pred (cl-check-key (car cl-seq2)) + (cl-check-key (car cl-seq1))) + (cl-push (cl-pop cl-seq2) cl-res) + (cl-push (cl-pop cl-seq1) cl-res))) + (coerce (nconc (nreverse cl-res) cl-seq1 cl-seq2) cl-type)))) + +;;; See compiler macro in cl-macs.el +(defun member* (cl-item cl-list &rest cl-keys) + "Find the first occurrence of ITEM in LIST. +Return the sublist of LIST whose car is ITEM. +Keywords supported: :test :test-not :key" + (if cl-keys + (cl-parsing-keywords (:test :test-not :key :if :if-not) () + (while (and cl-list (not (cl-check-test cl-item (car cl-list)))) + (setq cl-list (cdr cl-list))) + cl-list) + (if (and (numberp cl-item) (not (integerp cl-item))) + (member cl-item cl-list) + (memq cl-item cl-list)))) + +(defun member-if (cl-pred cl-list &rest cl-keys) + "Find the first item satisfying PREDICATE in LIST. +Return the sublist of LIST whose car matches. +Keywords supported: :key" + (apply 'member* nil cl-list ':if cl-pred cl-keys)) + +(defun member-if-not (cl-pred cl-list &rest cl-keys) + "Find the first item not satisfying PREDICATE in LIST. +Return the sublist of LIST whose car matches. +Keywords supported: :key" + (apply 'member* nil cl-list ':if-not cl-pred cl-keys)) + +(defun cl-adjoin (cl-item cl-list &rest cl-keys) + (if (cl-parsing-keywords (:key) t + (apply 'member* (cl-check-key cl-item) cl-list cl-keys)) + cl-list + (cons cl-item cl-list))) + +;;; See compiler macro in cl-macs.el +(defun assoc* (cl-item cl-alist &rest cl-keys) + "Find the first item whose car matches ITEM in LIST. +Keywords supported: :test :test-not :key" + (if cl-keys + (cl-parsing-keywords (:test :test-not :key :if :if-not) () + (while (and cl-alist + (or (not (consp (car cl-alist))) + (not (cl-check-test cl-item (car (car cl-alist)))))) + (setq cl-alist (cdr cl-alist))) + (and cl-alist (car cl-alist))) + (if (and (numberp cl-item) (not (integerp cl-item))) + (assoc cl-item cl-alist) + (assq cl-item cl-alist)))) + +(defun assoc-if (cl-pred cl-list &rest cl-keys) + "Find the first item whose car satisfies PREDICATE in LIST. +Keywords supported: :key" + (apply 'assoc* nil cl-list ':if cl-pred cl-keys)) + +(defun assoc-if-not (cl-pred cl-list &rest cl-keys) + "Find the first item whose car does not satisfy PREDICATE in LIST. +Keywords supported: :key" + (apply 'assoc* nil cl-list ':if-not cl-pred cl-keys)) + +(defun rassoc* (cl-item cl-alist &rest cl-keys) + "Find the first item whose cdr matches ITEM in LIST. +Keywords supported: :test :test-not :key" + (if (or cl-keys (numberp cl-item)) + (cl-parsing-keywords (:test :test-not :key :if :if-not) () + (while (and cl-alist + (or (not (consp (car cl-alist))) + (not (cl-check-test cl-item (cdr (car cl-alist)))))) + (setq cl-alist (cdr cl-alist))) + (and cl-alist (car cl-alist))) + (rassq cl-item cl-alist))) + +(defun rassoc-if (cl-pred cl-list &rest cl-keys) + "Find the first item whose cdr satisfies PREDICATE in LIST. +Keywords supported: :key" + (apply 'rassoc* nil cl-list ':if cl-pred cl-keys)) + +(defun rassoc-if-not (cl-pred cl-list &rest cl-keys) + "Find the first item whose cdr does not satisfy PREDICATE in LIST. +Keywords supported: :key" + (apply 'rassoc* nil cl-list ':if-not cl-pred cl-keys)) + +(defun union (cl-list1 cl-list2 &rest cl-keys) + "Combine LIST1 and LIST2 using a set-union operation. +The result list contains all items that appear in either LIST1 or LIST2. +This is a non-destructive function; it makes a copy of the data if necessary +to avoid corrupting the original LIST1 and LIST2. +Keywords supported: :test :test-not :key" + (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) + ((equal cl-list1 cl-list2) cl-list1) + (t + (or (>= (length cl-list1) (length cl-list2)) + (setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1)))) + (while cl-list2 + (if (or cl-keys (numberp (car cl-list2))) + (setq cl-list1 (apply 'adjoin (car cl-list2) cl-list1 cl-keys)) + (or (memq (car cl-list2) cl-list1) + (cl-push (car cl-list2) cl-list1))) + (cl-pop cl-list2)) + cl-list1))) + +(defun nunion (cl-list1 cl-list2 &rest cl-keys) + "Combine LIST1 and LIST2 using a set-union operation. +The result list contains all items that appear in either LIST1 or LIST2. +This is a destructive function; it reuses the storage of LIST1 and LIST2 +whenever possible. +Keywords supported: :test :test-not :key" + (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) + (t (apply 'union cl-list1 cl-list2 cl-keys)))) + +(defun intersection (cl-list1 cl-list2 &rest cl-keys) + "Combine LIST1 and LIST2 using a set-intersection operation. +The result list contains all items that appear in both LIST1 and LIST2. +This is a non-destructive function; it makes a copy of the data if necessary +to avoid corrupting the original LIST1 and LIST2. +Keywords supported: :test :test-not :key" + (and cl-list1 cl-list2 + (if (equal cl-list1 cl-list2) cl-list1 + (cl-parsing-keywords (:key) (:test :test-not) + (let ((cl-res nil)) + (or (>= (length cl-list1) (length cl-list2)) + (setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1)))) + (while cl-list2 + (if (if (or cl-keys (numberp (car cl-list2))) + (apply 'member* (cl-check-key (car cl-list2)) + cl-list1 cl-keys) + (memq (car cl-list2) cl-list1)) + (cl-push (car cl-list2) cl-res)) + (cl-pop cl-list2)) + cl-res))))) + +(defun nintersection (cl-list1 cl-list2 &rest cl-keys) + "Combine LIST1 and LIST2 using a set-intersection operation. +The result list contains all items that appear in both LIST1 and LIST2. +This is a destructive function; it reuses the storage of LIST1 and LIST2 +whenever possible. +Keywords supported: :test :test-not :key" + (and cl-list1 cl-list2 (apply 'intersection cl-list1 cl-list2 cl-keys))) + +(defun set-difference (cl-list1 cl-list2 &rest cl-keys) + "Combine LIST1 and LIST2 using a set-difference operation. +The result list contains all items that appear in LIST1 but not LIST2. +This is a non-destructive function; it makes a copy of the data if necessary +to avoid corrupting the original LIST1 and LIST2. +Keywords supported: :test :test-not :key" + (if (or (null cl-list1) (null cl-list2)) cl-list1 + (cl-parsing-keywords (:key) (:test :test-not) + (let ((cl-res nil)) + (while cl-list1 + (or (if (or cl-keys (numberp (car cl-list1))) + (apply 'member* (cl-check-key (car cl-list1)) + cl-list2 cl-keys) + (memq (car cl-list1) cl-list2)) + (cl-push (car cl-list1) cl-res)) + (cl-pop cl-list1)) + cl-res)))) + +(defun nset-difference (cl-list1 cl-list2 &rest cl-keys) + "Combine LIST1 and LIST2 using a set-difference operation. +The result list contains all items that appear in LIST1 but not LIST2. +This is a destructive function; it reuses the storage of LIST1 and LIST2 +whenever possible. +Keywords supported: :test :test-not :key" + (if (or (null cl-list1) (null cl-list2)) cl-list1 + (apply 'set-difference cl-list1 cl-list2 cl-keys))) + +(defun set-exclusive-or (cl-list1 cl-list2 &rest cl-keys) + "Combine LIST1 and LIST2 using a set-exclusive-or operation. +The result list contains all items that appear in exactly one of LIST1, LIST2. +This is a non-destructive function; it makes a copy of the data if necessary +to avoid corrupting the original LIST1 and LIST2. +Keywords supported: :test :test-not :key" + (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) + ((equal cl-list1 cl-list2) nil) + (t (append (apply 'set-difference cl-list1 cl-list2 cl-keys) + (apply 'set-difference cl-list2 cl-list1 cl-keys))))) + +(defun nset-exclusive-or (cl-list1 cl-list2 &rest cl-keys) + "Combine LIST1 and LIST2 using a set-exclusive-or operation. +The result list contains all items that appear in exactly one of LIST1, LIST2. +This is a destructive function; it reuses the storage of LIST1 and LIST2 +whenever possible. +Keywords supported: :test :test-not :key" + (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) + ((equal cl-list1 cl-list2) nil) + (t (nconc (apply 'nset-difference cl-list1 cl-list2 cl-keys) + (apply 'nset-difference cl-list2 cl-list1 cl-keys))))) + +(defun subsetp (cl-list1 cl-list2 &rest cl-keys) + "True if LIST1 is a subset of LIST2. +I.e., if every element of LIST1 also appears in LIST2. +Keywords supported: :test :test-not :key" + (cond ((null cl-list1) t) ((null cl-list2) nil) + ((equal cl-list1 cl-list2) t) + (t (cl-parsing-keywords (:key) (:test :test-not) + (while (and cl-list1 + (apply 'member* (cl-check-key (car cl-list1)) + cl-list2 cl-keys)) + (cl-pop cl-list1)) + (null cl-list1))))) + +(defun subst-if (cl-new cl-pred cl-tree &rest cl-keys) + "Substitute NEW for elements matching PREDICATE in TREE (non-destructively). +Return a copy of TREE with all matching elements replaced by NEW. +Keywords supported: :key" + (apply 'sublis (list (cons nil cl-new)) cl-tree ':if cl-pred cl-keys)) + +(defun subst-if-not (cl-new cl-pred cl-tree &rest cl-keys) + "Substitute NEW for elts not matching PREDICATE in TREE (non-destructively). +Return a copy of TREE with all non-matching elements replaced by NEW. +Keywords supported: :key" + (apply 'sublis (list (cons nil cl-new)) cl-tree ':if-not cl-pred cl-keys)) + +(defun nsubst (cl-new cl-old cl-tree &rest cl-keys) + "Substitute NEW for OLD everywhere in TREE (destructively). +Any element of TREE which is `eql' to OLD is changed to NEW (via a call +to `setcar'). +Keywords supported: :test :test-not :key" + (apply 'nsublis (list (cons cl-old cl-new)) cl-tree cl-keys)) + +(defun nsubst-if (cl-new cl-pred cl-tree &rest cl-keys) + "Substitute NEW for elements matching PREDICATE in TREE (destructively). +Any element of TREE which matches is changed to NEW (via a call to `setcar'). +Keywords supported: :key" + (apply 'nsublis (list (cons nil cl-new)) cl-tree ':if cl-pred cl-keys)) + +(defun nsubst-if-not (cl-new cl-pred cl-tree &rest cl-keys) + "Substitute NEW for elements not matching PREDICATE in TREE (destructively). +Any element of TREE which matches is changed to NEW (via a call to `setcar'). +Keywords supported: :key" + (apply 'nsublis (list (cons nil cl-new)) cl-tree ':if-not cl-pred cl-keys)) + +(defun sublis (cl-alist cl-tree &rest cl-keys) + "Perform substitutions indicated by ALIST in TREE (non-destructively). +Return a copy of TREE with all matching elements replaced. +Keywords supported: :test :test-not :key" + (cl-parsing-keywords (:test :test-not :key :if :if-not) () + (cl-sublis-rec cl-tree))) + +(defvar cl-alist) +(defun cl-sublis-rec (cl-tree) ; uses cl-alist/key/test*/if* + (let ((cl-temp (cl-check-key cl-tree)) (cl-p cl-alist)) + (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp))) + (setq cl-p (cdr cl-p))) + (if cl-p (cdr (car cl-p)) + (if (consp cl-tree) + (let ((cl-a (cl-sublis-rec (car cl-tree))) + (cl-d (cl-sublis-rec (cdr cl-tree)))) + (if (and (eq cl-a (car cl-tree)) (eq cl-d (cdr cl-tree))) + cl-tree + (cons cl-a cl-d))) + cl-tree)))) + +(defun nsublis (cl-alist cl-tree &rest cl-keys) + "Perform substitutions indicated by ALIST in TREE (destructively). +Any matching element of TREE is changed via a call to `setcar'. +Keywords supported: :test :test-not :key" + (cl-parsing-keywords (:test :test-not :key :if :if-not) () + (let ((cl-hold (list cl-tree))) + (cl-nsublis-rec cl-hold) + (car cl-hold)))) + +(defun cl-nsublis-rec (cl-tree) ; uses cl-alist/temp/p/key/test*/if* + (while (consp cl-tree) + (let ((cl-temp (cl-check-key (car cl-tree))) (cl-p cl-alist)) + (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp))) + (setq cl-p (cdr cl-p))) + (if cl-p (setcar cl-tree (cdr (car cl-p))) + (if (consp (car cl-tree)) (cl-nsublis-rec (car cl-tree)))) + (setq cl-temp (cl-check-key (cdr cl-tree)) cl-p cl-alist) + (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp))) + (setq cl-p (cdr cl-p))) + (if cl-p + (progn (setcdr cl-tree (cdr (car cl-p))) (setq cl-tree nil)) + (setq cl-tree (cdr cl-tree)))))) + +(defun tree-equal (cl-x cl-y &rest cl-keys) + "T if trees X and Y have `eql' leaves. +Atoms are compared by `eql'; cons cells are compared recursively. +Keywords supported: :test :test-not :key" + (cl-parsing-keywords (:test :test-not :key) () + (cl-tree-equal-rec cl-x cl-y))) + +(defun cl-tree-equal-rec (cl-x cl-y) + (while (and (consp cl-x) (consp cl-y) + (cl-tree-equal-rec (car cl-x) (car cl-y))) + (setq cl-x (cdr cl-x) cl-y (cdr cl-y))) + (and (not (consp cl-x)) (not (consp cl-y)) (cl-check-match cl-x cl-y))) + + +(run-hooks 'cl-seq-load-hook) + +;;; cl-seq.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cl.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,739 @@ +;;; cl.el --- Common Lisp extensions for GNU Emacs Lisp + +;; Copyright (C) 1993, 1997 Free Software Foundation, Inc. + +;; Author: Dave Gillespie <daveg@synaptics.com> +;; Maintainer: XEmacs Development Team +;; Version: 2.02 +;; Keywords: extensions, dumped, lisp + +;; 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.34. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;; These are extensions to Emacs Lisp that provide a degree of +;; Common Lisp compatibility, beyond what is already built-in +;; in Emacs Lisp. +;; +;; This package was written by Dave Gillespie; it is a complete +;; rewrite of Cesar Quiroz's original cl.el package of December 1986. +;; +;; This package works with Emacs 18, Emacs 19, and XEmacs/Lucid Emacs 19. +;; +;; Bug reports, comments, and suggestions are welcome! + +;; This file contains the portions of the Common Lisp extensions +;; package which should always be present. + + +;;; Future notes: + +;; Once Emacs 19 becomes standard, many things in this package which are +;; messy for reasons of compatibility can be greatly simplified. For now, +;; I prefer to maintain one unified version. + + +;;; Change Log: + +;; Version 2.02 (30 Jul 93): +;; * Added "cl-compat.el" file, extra compatibility with old package. +;; * Added `lexical-let' and `lexical-let*'. +;; * Added `define-modify-macro', `callf', and `callf2'. +;; * Added `ignore-errors'. +;; * Changed `(setf (nthcdr N PLACE) X)' to work when N is zero. +;; * Merged `*gentemp-counter*' into `*gensym-counter*'. +;; * Extended `subseq' to allow negative START and END like `substring'. +;; * Added `in-ref', `across-ref', `elements of-ref' loop clauses. +;; * Added `concat', `vconcat' loop clauses. +;; * Cleaned up a number of compiler warnings. + +;; Version 2.01 (7 Jul 93): +;; * Added support for FSF version of Emacs 19. +;; * Added `add-hook' for Emacs 18 users. +;; * Added `defsubst*' and `symbol-macrolet'. +;; * Added `maplist', `mapc', `mapl', `mapcan', `mapcon'. +;; * Added `map', `concatenate', `reduce', `merge'. +;; * Added `revappend', `nreconc', `tailp', `tree-equal'. +;; * Added `assert', `check-type', `typecase', `typep', and `deftype'. +;; * Added destructuring and `&environment' support to `defmacro*'. +;; * Added destructuring to `loop', and added the following clauses: +;; `elements', `frames', `overlays', `intervals', `buffers', `key-seqs'. +;; * Renamed `delete' to `delete*' and `remove' to `remove*'. +;; * Completed support for all keywords in `remove*', `substitute', etc. +;; * Added `most-positive-float' and company. +;; * Fixed hash tables to work with latest Lucid Emacs. +;; * `proclaim' forms are no longer compile-time-evaluating; use `declaim'. +;; * Syntax for `warn' declarations has changed. +;; * Improved implementation of `random*'. +;; * Moved most sequence functions to a new file, cl-seq.el. +;; * Moved `eval-when' into cl-macs.el. +;; * Moved `pushnew' and `adjoin' to cl.el for most common cases. +;; * Moved `provide' forms down to ends of files. +;; * Changed expansion of `pop' to something that compiles to better code. +;; * Changed so that no patch is required for Emacs 19 byte compiler. +;; * Made more things dependent on `optimize' declarations. +;; * Added a partial implementation of struct print functions. +;; * Miscellaneous minor changes. + +;; Version 2.00: +;; * First public release of this package. + + +;;; Code: + +(defvar cl-emacs-type (cond ((or (and (fboundp 'epoch::version) + (symbol-value 'epoch::version)) + (string-lessp emacs-version "19")) 18) + ((string-match "XEmacs" emacs-version) + 'lucid) + (t 19))) + +(or (fboundp 'defalias) (fset 'defalias 'fset)) + +(defvar cl-optimize-speed 1) +(defvar cl-optimize-safety 1) + + +;;; Keywords used in this package. + +;;; XEmacs - keywords are done in Fintern(). +;;; +;;; (defconst :test ':test) +;;; (defconst :test-not ':test-not) +;;; (defconst :key ':key) +;;; (defconst :start ':start) +;;; (defconst :start1 ':start1) +;;; (defconst :start2 ':start2) +;;; (defconst :end ':end) +;;; (defconst :end1 ':end1) +;;; (defconst :end2 ':end2) +;;; (defconst :count ':count) +;;; (defconst :initial-value ':initial-value) +;;; (defconst :size ':size) +;;; (defconst :from-end ':from-end) +;;; (defconst :rehash-size ':rehash-size) +;;; (defconst :rehash-threshold ':rehash-threshold) +;;; (defconst :allow-other-keys ':allow-other-keys) + + +(defvar custom-print-functions nil + "This is a list of functions that format user objects for printing. +Each function is called in turn with three arguments: the object, the +stream, and the print level (currently ignored). If it is able to +print the object it returns true; otherwise it returns nil and the +printer proceeds to the next function on the list. + +This variable is not used at present, but it is defined in hopes that +a future Emacs interpreter will be able to use it.") + + +;;; Predicates. + +(defun eql (a b) ; See compiler macro in cl-macs.el + "T if the two args are the same Lisp object. +Floating-point numbers of equal value are `eql', but they may not be `eq'." + (if (numberp a) + (equal a b) + (eq a b))) + + +;;; Generalized variables. These macros are defined here so that they +;;; can safely be used in .emacs files. + +(defmacro incf (place &optional x) + "(incf PLACE [X]): increment PLACE by X (1 by default). +PLACE may be a symbol, or any generalized variable allowed by `setf'. +The return value is the incremented value of PLACE." + (if (symbolp place) + (list 'setq place (if x (list '+ place x) (list '1+ place))) + (list 'callf '+ place (or x 1)))) + +(defmacro decf (place &optional x) + "(decf PLACE [X]): decrement PLACE by X (1 by default). +PLACE may be a symbol, or any generalized variable allowed by `setf'. +The return value is the decremented value of PLACE." + (if (symbolp place) + (list 'setq place (if x (list '- place x) (list '1- place))) + (list 'callf '- place (or x 1)))) + +(defmacro pop (place) + "(pop PLACE): remove and return the head of the list stored in PLACE. +Analogous to (prog1 (car PLACE) (setf PLACE (cdr PLACE))), though more +careful about evaluating each argument only once and in the right order. +PLACE may be a symbol, or any generalized variable allowed by `setf'." + (if (symbolp place) + (list 'car (list 'prog1 place (list 'setq place (list 'cdr place)))) + (cl-do-pop place))) + +(defmacro push (x place) + "(push X PLACE): insert X at the head of the list stored in PLACE. +Analogous to (setf PLACE (cons X PLACE)), though more careful about +evaluating each argument only once and in the right order. PLACE may +be a symbol, or any generalized variable allowed by `setf'." + (if (symbolp place) (list 'setq place (list 'cons x place)) + (list 'callf2 'cons x place))) + +(defmacro pushnew (x place &rest keys) + "(pushnew X PLACE): insert X at the head of the list if not already there. +Like (push X PLACE), except that the list is unmodified if X is `eql' to +an element already on the list. +Keywords supported: :test :test-not :key" + (if (symbolp place) (list 'setq place (list* 'adjoin x place keys)) + (list* 'callf2 'adjoin x place keys))) + +(defun cl-set-elt (seq n val) + (if (listp seq) (setcar (nthcdr n seq) val) (aset seq n val))) + +(defun cl-set-nthcdr (n list x) + (if (<= n 0) x (setcdr (nthcdr (1- n) list) x) list)) + +(defun cl-set-buffer-substring (start end val) + (save-excursion (delete-region start end) + (goto-char start) + (insert val) + val)) + +(defun cl-set-substring (str start end val) + (if end (if (< end 0) (incf end (length str))) + (setq end (length str))) + (if (< start 0) (incf start str)) + (concat (and (> start 0) (substring str 0 start)) + val + (and (< end (length str)) (substring str end)))) + + +;;; 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. + +(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)))) + +(defun cl-map-extents (&rest cl-args) + (if (fboundp 'next-overlay-at) (apply 'cl-map-overlays cl-args) + (if (fboundp 'map-extents) (apply 'map-extents cl-args)))) + + +;;; Blocks and exits. + +(defalias 'cl-block-wrapper 'identity) +(defalias 'cl-block-throw 'throw) + + +;;; Multiple values. True multiple values are not supported, or even +;;; simulated. Instead, multiple-value-bind and friends simply expect +;;; the target form to return the values as a list. + +(defalias 'values 'list) +(defalias 'values-list 'identity) +(defalias 'multiple-value-list 'identity) +(defalias 'multiple-value-call 'apply) ; only works for one arg +(defalias 'nth-value 'nth) + + +;;; Macros. + +(defvar cl-macro-environment nil) +;; XEmacs: we renamed the internal function to macroexpand-internal +;; to avoid doc-file problems. +(defvar cl-old-macroexpand (prog1 (symbol-function 'macroexpand-internal) + (defalias 'macroexpand 'cl-macroexpand))) + +(defun cl-macroexpand (cl-macro &optional cl-env) + "Return result of expanding macros at top level of FORM. +If FORM is not a macro call, it is returned unchanged. +Otherwise, the macro is expanded and the expansion is considered +in place of FORM. When a non-macro-call results, it is returned. + +The second optional arg ENVIRONMENT species an environment of macro +definitions to shadow the loaded ones for use in file byte-compilation." + (let ((cl-macro-environment cl-env)) + (while (progn (setq cl-macro (funcall cl-old-macroexpand cl-macro cl-env)) + (and (symbolp cl-macro) + (cdr (assq (symbol-name cl-macro) cl-env)))) + (setq cl-macro (cadr (assq (symbol-name cl-macro) cl-env)))) + cl-macro)) + + +;;; Declarations. + +(defvar cl-compiling-file nil) +(defun cl-compiling-file () + (or cl-compiling-file + ;; XEmacs change +; (and (boundp 'outbuffer) (bufferp (symbol-value 'outbuffer)) +; (equal (buffer-name (symbol-value 'outbuffer)) +; " *Compiler Output*")) + (and (boundp 'byte-compile-outbuffer) + (bufferp (symbol-value 'byte-compile-outbuffer)) + (equal (buffer-name (symbol-value 'byte-compile-outbuffer)) + " *Compiler Output*")) + )) + +(defvar cl-proclaims-deferred nil) + +(defun proclaim (spec) + (if (fboundp 'cl-do-proclaim) (cl-do-proclaim spec t) + (push spec cl-proclaims-deferred)) + nil) + +(defmacro declaim (&rest specs) + (let ((body (mapcar (function (lambda (x) (list 'proclaim (list 'quote x)))) + specs))) + (if (cl-compiling-file) (list* 'eval-when '(compile load eval) body) + (cons 'progn body)))) ; avoid loading cl-macs.el for eval-when + + +;;; Symbols. + +(defun cl-random-time () + (let* ((time (copy-sequence (current-time-string))) (i (length time)) (v 0)) + (while (>= (decf i) 0) (setq v (+ (* v 3) (aref time i)))) + v)) + +(defvar *gensym-counter* (* (logand (cl-random-time) 1023) 100)) + + +;;; Numbers. + +(defun floatp-safe (x) + "T if OBJECT is a floating point number. +On Emacs versions that lack floating-point support, this function +always returns nil." + (and (numberp x) (not (integerp x)))) + +(defun plusp (x) + "T if NUMBER is positive." + (> x 0)) + +(defun minusp (x) + "T if NUMBER is negative." + (< x 0)) + +(defun oddp (x) + "T if INTEGER is odd." + (eq (logand x 1) 1)) + +(defun evenp (x) + "T if INTEGER is even." + (eq (logand x 1) 0)) + +(defun cl-abs (x) + "Return the absolute value of ARG." + (if (>= x 0) x (- x))) +(or (fboundp 'abs) (defalias 'abs 'cl-abs)) ; This is built-in to Emacs 19 + +(defvar *random-state* (vector 'cl-random-state-tag -1 30 (cl-random-time))) + +;;; We use `eval' in case VALBITS differs from compile-time to load-time. +(defconst most-positive-fixnum (eval '(lsh -1 -1))) +(defconst most-negative-fixnum (eval '(- -1 (lsh -1 -1)))) + +;;; The following are actually set by cl-float-limits. +(defconst most-positive-float nil) +(defconst most-negative-float nil) +(defconst least-positive-float nil) +(defconst least-negative-float nil) +(defconst least-positive-normalized-float nil) +(defconst least-negative-normalized-float nil) +(defconst float-epsilon nil) +(defconst float-negative-epsilon nil) + + +;;; Sequence functions. + +(defalias 'copy-seq 'copy-sequence) + +(defun mapcar* (cl-func cl-x &rest cl-rest) + "Apply FUNCTION to each element of SEQ, and make a list of the results. +If there are several SEQs, FUNCTION is called with that many arguments, +and mapping stops as soon as the shortest list runs out. With just one +SEQ, this is like `mapcar'. With several, it is like the Common Lisp +`mapcar' function extended to arbitrary sequence types." + (if cl-rest + (if (or (cdr cl-rest) (nlistp cl-x) (nlistp (car cl-rest))) + (cl-mapcar-many cl-func (cons cl-x cl-rest)) + (let ((cl-res nil) (cl-y (car cl-rest))) + (while (and cl-x cl-y) + (push (funcall cl-func (pop cl-x) (pop cl-y)) cl-res)) + (nreverse cl-res))) + (mapcar cl-func cl-x))) + + +;;; List functions. + +(defalias 'first 'car) +(defalias 'rest 'cdr) +(defalias 'endp 'null) + +(defun second (x) + "Return the second element of the list LIST." + (car (cdr x))) + +(defun third (x) + "Return the third element of the list LIST." + (car (cdr (cdr x)))) + +(defun fourth (x) + "Return the fourth element of the list LIST." + (nth 3 x)) + +(defun fifth (x) + "Return the fifth element of the list LIST." + (nth 4 x)) + +(defun sixth (x) + "Return the sixth element of the list LIST." + (nth 5 x)) + +(defun seventh (x) + "Return the seventh element of the list LIST." + (nth 6 x)) + +(defun eighth (x) + "Return the eighth element of the list LIST." + (nth 7 x)) + +(defun ninth (x) + "Return the ninth element of the list LIST." + (nth 8 x)) + +(defun tenth (x) + "Return the tenth element of the list LIST." + (nth 9 x)) + +(defun caar (x) + "Return the `car' of the `car' of X." + (car (car x))) + +(defun cadr (x) + "Return the `car' of the `cdr' of X." + (car (cdr x))) + +(defun cdar (x) + "Return the `cdr' of the `car' of X." + (cdr (car x))) + +(defun cddr (x) + "Return the `cdr' of the `cdr' of X." + (cdr (cdr x))) + +(defun caaar (x) + "Return the `car' of the `car' of the `car' of X." + (car (car (car x)))) + +(defun caadr (x) + "Return the `car' of the `car' of the `cdr' of X." + (car (car (cdr x)))) + +(defun cadar (x) + "Return the `car' of the `cdr' of the `car' of X." + (car (cdr (car x)))) + +(defun caddr (x) + "Return the `car' of the `cdr' of the `cdr' of X." + (car (cdr (cdr x)))) + +(defun cdaar (x) + "Return the `cdr' of the `car' of the `car' of X." + (cdr (car (car x)))) + +(defun cdadr (x) + "Return the `cdr' of the `car' of the `cdr' of X." + (cdr (car (cdr x)))) + +(defun cddar (x) + "Return the `cdr' of the `cdr' of the `car' of X." + (cdr (cdr (car x)))) + +(defun cdddr (x) + "Return the `cdr' of the `cdr' of the `cdr' of X." + (cdr (cdr (cdr x)))) + +(defun caaaar (x) + "Return the `car' of the `car' of the `car' of the `car' of X." + (car (car (car (car x))))) + +(defun caaadr (x) + "Return the `car' of the `car' of the `car' of the `cdr' of X." + (car (car (car (cdr x))))) + +(defun caadar (x) + "Return the `car' of the `car' of the `cdr' of the `car' of X." + (car (car (cdr (car x))))) + +(defun caaddr (x) + "Return the `car' of the `car' of the `cdr' of the `cdr' of X." + (car (car (cdr (cdr x))))) + +(defun cadaar (x) + "Return the `car' of the `cdr' of the `car' of the `car' of X." + (car (cdr (car (car x))))) + +(defun cadadr (x) + "Return the `car' of the `cdr' of the `car' of the `cdr' of X." + (car (cdr (car (cdr x))))) + +(defun caddar (x) + "Return the `car' of the `cdr' of the `cdr' of the `car' of X." + (car (cdr (cdr (car x))))) + +(defun cadddr (x) + "Return the `car' of the `cdr' of the `cdr' of the `cdr' of X." + (car (cdr (cdr (cdr x))))) + +(defun cdaaar (x) + "Return the `cdr' of the `car' of the `car' of the `car' of X." + (cdr (car (car (car x))))) + +(defun cdaadr (x) + "Return the `cdr' of the `car' of the `car' of the `cdr' of X." + (cdr (car (car (cdr x))))) + +(defun cdadar (x) + "Return the `cdr' of the `car' of the `cdr' of the `car' of X." + (cdr (car (cdr (car x))))) + +(defun cdaddr (x) + "Return the `cdr' of the `car' of the `cdr' of the `cdr' of X." + (cdr (car (cdr (cdr x))))) + +(defun cddaar (x) + "Return the `cdr' of the `cdr' of the `car' of the `car' of X." + (cdr (cdr (car (car x))))) + +(defun cddadr (x) + "Return the `cdr' of the `cdr' of the `car' of the `cdr' of X." + (cdr (cdr (car (cdr x))))) + +(defun cdddar (x) + "Return the `cdr' of the `cdr' of the `cdr' of the `car' of X." + (cdr (cdr (cdr (car x))))) + +(defun cddddr (x) + "Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X." + (cdr (cdr (cdr (cdr x))))) + +(defun last (x &optional n) + "Returns the last link in the list LIST. +With optional argument N, returns 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) + "Returns 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) + "Modifies 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. +Thus, `(list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to +`(cons A (cons B (cons C D)))'." + (cond ((not rest) arg) + ((not (cdr rest)) (cons arg (car rest))) + (t (let* ((n (length rest)) + (copy (copy-sequence rest)) + (last (nthcdr (- n 2) copy))) + (setcdr last (car (cdr last))) + (cons arg copy))))) + +(defun ldiff (list sublist) + "Return a copy of LIST with the tail SUBLIST removed." + (let ((res nil)) + (while (and (consp list) (not (eq list sublist))) + (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))) + +(defun cl-maclisp-member (item list) + (while (and list (not (equal item (car list)))) (setq list (cdr list))) + list) + +;;; Define an Emacs 19-compatible `member' for the benefit of Emacs 18 users. +(or (and (fboundp 'member) (subrp (symbol-function 'member))) + (defalias 'member 'cl-maclisp-member)) + +(defalias 'cl-member 'memq) ; for compatibility with old CL package +(defalias 'cl-floor 'floor*) +(defalias 'cl-ceiling 'ceiling*) +(defalias 'cl-truncate 'truncate*) +(defalias 'cl-round 'round*) +(defalias 'cl-mod 'mod*) + +(defun adjoin (cl-item cl-list &rest cl-keys) ; See compiler macro in cl-macs + "Return ITEM consed onto the front of LIST only if it's not already there. +Otherwise, return LIST unmodified. +Keywords supported: :test :test-not :key" + (cond ((or (equal cl-keys '(:test eq)) + (and (null cl-keys) (not (numberp cl-item)))) + (if (memq cl-item cl-list) cl-list (cons cl-item cl-list))) + ((or (equal cl-keys '(:test equal)) (null cl-keys)) + (if (member cl-item cl-list) cl-list (cons cl-item cl-list))) + (t (apply 'cl-adjoin cl-item cl-list cl-keys)))) + +(defun subst (cl-new cl-old cl-tree &rest cl-keys) + "Substitute NEW for OLD everywhere in TREE (non-destructively). +Return a copy of TREE with all elements `eql' to OLD replaced by NEW. +Keywords supported: :test :test-not :key" + (if (or cl-keys (and (numberp cl-old) (not (integerp cl-old)))) + (apply 'sublis (list (cons cl-old cl-new)) cl-tree cl-keys) + (cl-do-subst cl-new cl-old cl-tree))) + +(defun cl-do-subst (cl-new cl-old cl-tree) + (cond ((eq cl-tree cl-old) cl-new) + ((consp cl-tree) + (let ((a (cl-do-subst cl-new cl-old (car cl-tree))) + (d (cl-do-subst cl-new cl-old (cdr cl-tree)))) + (if (and (eq a (car cl-tree)) (eq d (cdr cl-tree))) + cl-tree (cons a d)))) + (t cl-tree))) + +(defun acons (a b c) (cons (cons a b) c)) +(defun pairlis (a b &optional c) (nconc (mapcar* 'cons a b) c)) + + +;;; Miscellaneous. + +;; XEmacs change +(define-error 'cl-assertion-failed "Assertion failed") + +;;; This is defined in Emacs 19; define it here for Emacs 18 users. +(defun cl-add-hook (hook func &optional append) + "Add to hook variable HOOK the function FUNC. +FUNC is not added if it already appears on the list stored in HOOK." + (let ((old (and (boundp hook) (symbol-value hook)))) + (and (listp old) (not (eq (car old) 'lambda)) + (setq old (list old))) + (and (not (member func old)) + (set hook (if append (nconc old (list func)) (cons func old)))))) +(or (fboundp 'add-hook) (defalias 'add-hook 'cl-add-hook)) + +;; XEmacs change +;(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)))) + + +;;; This goes here so that cl-macs can find it if it loads right now. +(provide 'cl-19) ; usage: (require 'cl-19 "cl") + + +;;; Things to do after byte-compiler is loaded. +;;; As a side effect, we cause cl-macs to be loaded when compiling, so +;;; that the compiler-macros defined there will be present. + +(defvar cl-hacked-flag nil) +(defun cl-hack-byte-compiler () + (if (and (not cl-hacked-flag) (fboundp 'byte-compile-file-form)) + (progn + (cl-compile-time-init) ; in cl-macs.el + (setq cl-hacked-flag t)))) + +;;; Try it now in case the compiler has already been loaded. +(cl-hack-byte-compiler) + +;;; Also make a hook in case compiler is loaded after this file. +;;; The compiler doesn't call any hooks when it loads or runs, but +;;; we can take advantage of the fact that emacs-lisp-mode will be +;;; called when the compiler reads in the file to be compiled. +;;; BUG: If the first compilation is `byte-compile' rather than +;;; `byte-compile-file', we lose. Oh, well. +(add-hook 'emacs-lisp-mode-hook 'cl-hack-byte-compiler) + + +;;; The following ensures that packages which expect the old-style cl.el +;;; will be happy with this one. + +(provide 'cl) + +(provide 'mini-cl) ; for Epoch + +(run-hooks 'cl-load-hook) + +;;; cl.el ends here
--- a/lisp/cl/auto-autoloads.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,331 +0,0 @@ -;;; DO NOT MODIFY THIS FILE -(if (featurep 'cl-autoloads) (error "Already loaded")) - -(provide 'cl-autoloads) - -;;;### (autoloads (compiler-macroexpand define-compiler-macro ignore-errors assert check-type typep deftype cl-struct-setf-expander defstruct define-modify-macro callf2 callf letf* letf rotatef shiftf remf cl-do-pop psetf setf get-setf-method defsetf define-setf-method declare the locally multiple-value-setq multiple-value-bind lexical-let* lexical-let symbol-macrolet macrolet labels flet progv psetq do-all-symbols do-symbols dotimes dolist do* do loop return-from return block etypecase typecase ecase case load-time-value eval-when destructuring-bind function* defmacro* defun* gentemp gensym cl-compile-time-init) "cl-macs" "cl/cl-macs.el") - -(autoload 'cl-compile-time-init "cl-macs" nil nil nil) - -(autoload 'gensym "cl-macs" "\ -Generate a new uninterned symbol. -The name is made by appending a number to PREFIX, default \"G\"." nil nil) - -(autoload 'gentemp "cl-macs" "\ -Generate a new interned symbol with a unique name. -The name is made by appending a number to PREFIX, default \"G\"." nil nil) - -(autoload 'defun* "cl-macs" "\ -(defun* NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function. -Like normal `defun', except ARGLIST allows full Common Lisp conventions, -and BODY is implicitly surrounded by (block NAME ...)." nil 'macro) - -(autoload 'defmacro* "cl-macs" "\ -(defmacro* NAME ARGLIST [DOCSTRING] BODY...): define NAME as a macro. -Like normal `defmacro', except ARGLIST allows full Common Lisp conventions, -and BODY is implicitly surrounded by (block NAME ...)." nil 'macro) - -(autoload 'function* "cl-macs" "\ -(function* SYMBOL-OR-LAMBDA): introduce a function. -Like normal `function', except that if argument is a lambda form, its -ARGLIST allows full Common Lisp conventions." nil 'macro) - -(autoload 'destructuring-bind "cl-macs" nil nil 'macro) - -(autoload 'eval-when "cl-macs" "\ -(eval-when (WHEN...) BODY...): control when BODY is evaluated. -If `compile' is in WHEN, BODY is evaluated when compiled at top-level. -If `load' is in WHEN, BODY is evaluated when loaded after top-level compile. -If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level." nil 'macro) - -(autoload 'load-time-value "cl-macs" "\ -Like `progn', but evaluates the body at load time. -The result of the body appears to the compiler as a quoted constant." nil 'macro) - -(autoload 'case "cl-macs" "\ -(case EXPR CLAUSES...): evals EXPR, chooses from CLAUSES on that value. -Each clause looks like (KEYLIST BODY...). EXPR is evaluated and compared -against each key in each KEYLIST; the corresponding BODY is evaluated. -If no clause succeeds, case returns nil. A single atom may be used in -place of a KEYLIST of one atom. A KEYLIST of `t' or `otherwise' is -allowed only in the final clause, and matches if no other keys match. -Key values are compared by `eql'." nil 'macro) - -(autoload 'ecase "cl-macs" "\ -(ecase EXPR CLAUSES...): like `case', but error if no case fits. -`otherwise'-clauses are not allowed." nil 'macro) - -(autoload 'typecase "cl-macs" "\ -(typecase EXPR CLAUSES...): evals EXPR, chooses from CLAUSES on that value. -Each clause looks like (TYPE BODY...). EXPR is evaluated and, if it -satisfies TYPE, the corresponding BODY is evaluated. If no clause succeeds, -typecase returns nil. A TYPE of `t' or `otherwise' is allowed only in the -final clause, and matches if no other keys match." nil 'macro) - -(autoload 'etypecase "cl-macs" "\ -(etypecase EXPR CLAUSES...): like `typecase', but error if no case fits. -`otherwise'-clauses are not allowed." nil 'macro) - -(autoload 'block "cl-macs" "\ -(block NAME BODY...): define a lexically-scoped block named NAME. -NAME may be any symbol. Code inside the BODY forms can call `return-from' -to jump prematurely out of the block. This differs from `catch' and `throw' -in two respects: First, the NAME is an unevaluated symbol rather than a -quoted symbol or other form; and second, NAME is lexically rather than -dynamically scoped: Only references to it within BODY will work. These -references may appear inside macro expansions, but not inside functions -called from BODY." nil 'macro) - -(autoload 'return "cl-macs" "\ -(return [RESULT]): return from the block named nil. -This is equivalent to `(return-from nil RESULT)'." nil 'macro) - -(autoload 'return-from "cl-macs" "\ -(return-from NAME [RESULT]): return from the block named NAME. -This jump out to the innermost enclosing `(block NAME ...)' form, -returning RESULT from that form (or nil if RESULT is omitted). -This is compatible with Common Lisp, but note that `defun' and -`defmacro' do not create implicit blocks as they do in Common Lisp." nil 'macro) - -(autoload 'loop "cl-macs" "\ -(loop CLAUSE...): The Common Lisp `loop' macro. -Valid clauses are: - for VAR from/upfrom/downfrom NUM to/upto/downto/above/below NUM by NUM, - for VAR in LIST by FUNC, for VAR on LIST by FUNC, for VAR = INIT then EXPR, - for VAR across ARRAY, repeat NUM, with VAR = INIT, while COND, until COND, - always COND, never COND, thereis COND, collect EXPR into VAR, - append EXPR into VAR, nconc EXPR into VAR, sum EXPR into VAR, - count EXPR into VAR, maximize EXPR into VAR, minimize EXPR into VAR, - if COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...], - unless COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...], - do EXPRS..., initially EXPRS..., finally EXPRS..., return EXPR, - finally return EXPR, named NAME." nil 'macro) - -(autoload 'do "cl-macs" "\ -The Common Lisp `do' loop. -Format is: (do ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" nil 'macro) - -(autoload 'do* "cl-macs" "\ -The Common Lisp `do*' loop. -Format is: (do* ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" nil 'macro) - -(autoload 'dolist "cl-macs" "\ -(dolist (VAR LIST [RESULT]) BODY...): loop over a list. -Evaluate BODY with VAR bound to each `car' from LIST, in turn. -Then evaluate RESULT to get return value, default nil." nil 'macro) - -(autoload 'dotimes "cl-macs" "\ -(dotimes (VAR COUNT [RESULT]) BODY...): loop a certain number of times. -Evaluate BODY with VAR bound to successive integers from 0, inclusive, -to COUNT, exclusive. Then evaluate RESULT to get return value, default -nil." nil 'macro) - -(autoload 'do-symbols "cl-macs" "\ -(dosymbols (VAR [OBARRAY [RESULT]]) BODY...): loop over all symbols. -Evaluate BODY with VAR bound to each interned symbol, or to each symbol -from OBARRAY." nil 'macro) - -(autoload 'do-all-symbols "cl-macs" nil nil 'macro) - -(autoload 'psetq "cl-macs" "\ -(psetq SYM VAL SYM VAL ...): set SYMs to the values VALs in parallel. -This is like `setq', except that all VAL forms are evaluated (in order) -before assigning any symbols SYM to the corresponding values." nil 'macro) - -(autoload 'progv "cl-macs" "\ -(progv SYMBOLS VALUES BODY...): bind SYMBOLS to VALUES dynamically in BODY. -The forms SYMBOLS and VALUES are evaluated, and must evaluate to lists. -Each SYMBOL in the first list is bound to the corresponding VALUE in the -second list (or made unbound if VALUES is shorter than SYMBOLS); then the -BODY forms are executed and their result is returned. This is much like -a `let' form, except that the list of symbols can be computed at run-time." nil 'macro) - -(autoload 'flet "cl-macs" "\ -(flet ((FUNC ARGLIST BODY...) ...) FORM...): make temporary function defns. -This is an analogue of `let' that operates on the function cell of FUNC -rather than its value cell. The FORMs are evaluated with the specified -function definitions in place, then the definitions are undone (the FUNCs -go back to their previous definitions, or lack thereof)." nil 'macro) - -(autoload 'labels "cl-macs" "\ -(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." nil 'macro) - -(autoload 'macrolet "cl-macs" "\ -(macrolet ((NAME ARGLIST BODY...) ...) FORM...): make temporary macro defns. -This is like `flet', but for macros instead of functions." nil 'macro) - -(autoload 'symbol-macrolet "cl-macs" "\ -(symbol-macrolet ((NAME EXPANSION) ...) FORM...): make symbol macro defns. -Within the body FORMs, references to the variable NAME will be replaced -by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...)." nil 'macro) - -(autoload 'lexical-let "cl-macs" "\ -(lexical-let BINDINGS BODY...): like `let', but lexically scoped. -The main visible difference is that lambdas inside BODY will create -lexical closures as in Common Lisp." nil 'macro) - -(autoload 'lexical-let* "cl-macs" "\ -(lexical-let* BINDINGS BODY...): like `let*', but lexically scoped. -The main visible difference is that lambdas inside BODY will create -lexical closures as in Common Lisp." nil 'macro) - -(autoload 'multiple-value-bind "cl-macs" "\ -(multiple-value-bind (SYM SYM...) FORM BODY): collect multiple return values. -FORM must return a list; the BODY is then executed with the first N elements -of this list bound (`let'-style) to each of the symbols SYM in turn. This -is analogous to the Common Lisp `multiple-value-bind' macro, using lists to -simulate true multiple return values. For compatibility, (values A B C) is -a synonym for (list A B C)." nil 'macro) - -(autoload 'multiple-value-setq "cl-macs" "\ -(multiple-value-setq (SYM SYM...) FORM): collect multiple return values. -FORM must return a list; the first N elements of this list are stored in -each of the symbols SYM in turn. This is analogous to the Common Lisp -`multiple-value-setq' macro, using lists to simulate true multiple return -values. For compatibility, (values A B C) is a synonym for (list A B C)." nil 'macro) - -(autoload 'locally "cl-macs" nil nil 'macro) - -(autoload 'the "cl-macs" nil nil 'macro) - -(autoload 'declare "cl-macs" nil nil 'macro) - -(autoload 'define-setf-method "cl-macs" "\ -(define-setf-method NAME ARGLIST BODY...): define a `setf' method. -This method shows how to handle `setf's to places of the form (NAME ARGS...). -The argument forms ARGS are bound according to ARGLIST, as if NAME were -going to be expanded as a macro, then the BODY forms are executed and must -return a list of five elements: a temporary-variables list, a value-forms -list, a store-variables list (of length one), a store-form, and an access- -form. See `defsetf' for a simpler way to define most setf-methods." nil 'macro) - -(autoload 'defsetf "cl-macs" "\ -(defsetf NAME FUNC): define a `setf' method. -This macro is an easy-to-use substitute for `define-setf-method' that works -well for simple place forms. In the simple `defsetf' form, `setf's of -the form (setf (NAME ARGS...) VAL) are transformed to function or macro -calls of the form (FUNC ARGS... VAL). Example: (defsetf aref aset). -Alternate form: (defsetf NAME ARGLIST (STORE) BODY...). -Here, the above `setf' call is expanded by binding the argument forms ARGS -according to ARGLIST, binding the value form VAL to STORE, then executing -BODY, which must return a Lisp form that does the necessary `setf' operation. -Actually, ARGLIST and STORE may be bound to temporary variables which are -introduced automatically to preserve proper execution order of the arguments. -Example: (defsetf nth (n x) (v) (list 'setcar (list 'nthcdr n x) v))." nil 'macro) - -(autoload 'get-setf-method "cl-macs" "\ -Return a list of five values describing the setf-method for PLACE. -PLACE may be any Lisp form which can appear as the PLACE argument to -a macro like `setf' or `incf'." nil nil) - -(autoload 'setf "cl-macs" "\ -(setf PLACE VAL PLACE VAL ...): set each PLACE to the value of its VAL. -This is a generalized version of `setq'; the PLACEs may be symbolic -references such as (car x) or (aref x i), as well as plain symbols. -For example, (setf (cadar x) y) is equivalent to (setcar (cdar x) y). -The return value is the last VAL in the list." nil 'macro) - -(autoload 'psetf "cl-macs" "\ -(psetf PLACE VAL PLACE VAL ...): set PLACEs to the values VALs in parallel. -This is like `setf', except that all VAL forms are evaluated (in order) -before assigning any PLACEs to the corresponding values." nil 'macro) - -(autoload 'cl-do-pop "cl-macs" nil nil nil) - -(autoload 'remf "cl-macs" "\ -(remf PLACE TAG): remove TAG from property list PLACE. -PLACE may be a symbol, or any generalized variable allowed by `setf'. -The form returns true if TAG was found and removed, nil otherwise." nil 'macro) - -(autoload 'shiftf "cl-macs" "\ -(shiftf PLACE PLACE... VAL): shift left among PLACEs. -Example: (shiftf A B C) sets A to B, B to C, and returns the old A. -Each PLACE may be a symbol, or any generalized variable allowed by `setf'." nil 'macro) - -(autoload 'rotatef "cl-macs" "\ -(rotatef PLACE...): rotate left among PLACEs. -Example: (rotatef A B C) sets A to B, B to C, and C to A. It returns nil. -Each PLACE may be a symbol, or any generalized variable allowed by `setf'." nil 'macro) - -(autoload 'letf "cl-macs" "\ -(letf ((PLACE VALUE) ...) BODY...): temporarily bind to PLACEs. -This is the analogue of `let', but with generalized variables (in the -sense of `setf') for the PLACEs. Each PLACE is set to the corresponding -VALUE, then the BODY forms are executed. On exit, either normally or -because of a `throw' or error, the PLACEs are set back to their original -values. Note that this macro is *not* available in Common Lisp. -As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)', -the PLACE is not modified before executing BODY." nil 'macro) - -(autoload 'letf* "cl-macs" "\ -(letf* ((PLACE VALUE) ...) BODY...): temporarily bind to PLACEs. -This is the analogue of `let*', but with generalized variables (in the -sense of `setf') for the PLACEs. Each PLACE is set to the corresponding -VALUE, then the BODY forms are executed. On exit, either normally or -because of a `throw' or error, the PLACEs are set back to their original -values. Note that this macro is *not* available in Common Lisp. -As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)', -the PLACE is not modified before executing BODY." nil 'macro) - -(autoload 'callf "cl-macs" "\ -(callf FUNC PLACE ARGS...): set PLACE to (FUNC PLACE ARGS...). -FUNC should be an unquoted function name. PLACE may be a symbol, -or any generalized variable allowed by `setf'." nil 'macro) - -(autoload 'callf2 "cl-macs" "\ -(callf2 FUNC ARG1 PLACE ARGS...): set PLACE to (FUNC ARG1 PLACE ARGS...). -Like `callf', but PLACE is the second argument of FUNC, not the first." nil 'macro) - -(autoload 'define-modify-macro "cl-macs" "\ -(define-modify-macro NAME ARGLIST FUNC): define a `setf'-like modify macro. -If NAME is called, it combines its PLACE argument with the other arguments -from ARGLIST using FUNC: (define-modify-macro incf (&optional (n 1)) +)" nil 'macro) - -(autoload 'defstruct "cl-macs" "\ -(defstruct (NAME OPTIONS...) (SLOT SLOT-OPTS...)...): define a struct type. -This macro defines a new Lisp data type called NAME, which contains data -stored in SLOTs. This defines a `make-NAME' constructor, a `copy-NAME' -copier, a `NAME-p' predicate, and setf-able `NAME-SLOT' accessors." nil 'macro) - -(autoload 'cl-struct-setf-expander "cl-macs" nil nil nil) - -(autoload 'deftype "cl-macs" "\ -(deftype NAME ARGLIST BODY...): define NAME as a new data type. -The type name can then be used in `typecase', `check-type', etc." nil 'macro) - -(autoload 'typep "cl-macs" "\ -Check that OBJECT is of type TYPE. -TYPE is a Common Lisp-style type specifier." nil nil) - -(autoload 'check-type "cl-macs" "\ -Verify that FORM is of type TYPE; signal an error if not. -STRING is an optional description of the desired type." nil 'macro) - -(autoload 'assert "cl-macs" "\ -Verify that FORM returns non-nil; signal an error if not. -Second arg SHOW-ARGS means to include arguments of FORM in message. -Other args STRING and ARGS... are arguments to be passed to `error'. -They are not evaluated unless the assertion fails. If STRING is -omitted, a default message listing FORM itself is used." nil 'macro) - -(autoload 'ignore-errors "cl-macs" "\ -Execute FORMS; if an error occurs, return nil. -Otherwise, return result of last FORM." nil 'macro) - -(autoload 'define-compiler-macro "cl-macs" "\ -(define-compiler-macro FUNC ARGLIST BODY...): Define a compiler-only macro. -This is like `defmacro', but macro expansion occurs only if the call to -FUNC is compiled (i.e., not interpreted). Compiler macros should be used -for optimizing the way calls to FUNC are compiled; the form returned by -BODY should do the same thing as a call to the normal function called -FUNC, though possibly more efficiently. Note that, like regular macros, -compiler macros are expanded repeatedly until no further expansions are -possible. Unlike regular macros, BODY can decide to \"punt\" and leave the -original function call alone by declaring an initial `&whole foo' parameter -and then returning foo." nil 'macro) - -(autoload 'compiler-macroexpand "cl-macs" nil nil nil) - -;;;***
--- a/lisp/cl/cl-compat.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,194 +0,0 @@ -;;; cl-compat.el --- Common Lisp extensions for GNU Emacs Lisp (compatibility) - -;; Copyright (C) 1993 Free Software Foundation, Inc. - -;; Author: Dave Gillespie <daveg@synaptics.com> -;; Version: 2.02 -;; Keywords: extensions - -;; 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.34. - -;;; Commentary: - -;; These are extensions to Emacs Lisp that provide a degree of -;; Common Lisp compatibility, beyond what is already built-in -;; in Emacs Lisp. -;; -;; This package was written by Dave Gillespie; it is a complete -;; rewrite of Cesar Quiroz's original cl.el package of December 1986. -;; -;; This package works with Emacs 18, Emacs 19, and XEmacs/Lucid Emacs 19. -;; -;; Bug reports, comments, and suggestions are welcome! - -;; This file contains emulations of internal routines of the older -;; CL package which users may have called directly from their code. -;; Use (require 'cl-compat) to get these routines. - -;; See cl.el for Change Log. - - -;;; Code: - -;; Require at load-time, but not when compiling cl-compat. -(or (featurep 'cl) (require 'cl)) - - -;;; Keyword routines not supported by new package. - -(defmacro defkeyword (x &optional doc) - (list* 'defconst x (list 'quote x) (and doc (list doc)))) - -(defun keywordp (sym) - (and (symbolp sym) (eq (aref (symbol-name sym) 0) ?\:) (set sym sym))) - -(defun keyword-of (sym) - (or (keywordp sym) (keywordp (intern (format ":%s" sym))))) - - -;;; Multiple values. Note that the new package uses a different -;;; convention for multiple values. The following definitions -;;; emulate the old convention; all function names have been changed -;;; by capitalizing the first letter: Values, Multiple-value-*, -;;; to avoid conflict with the new-style definitions in cl-macs. - -(put 'Multiple-value-bind 'lisp-indent-function 2) -(put 'Multiple-value-setq 'lisp-indent-function 2) -(put 'Multiple-value-call 'lisp-indent-function 1) -(put 'Multiple-value-prog1 'lisp-indent-function 1) - -(defvar *mvalues-values* nil) - -(defun Values (&rest val-forms) - (setq *mvalues-values* val-forms) - (car val-forms)) - -(defun Values-list (val-forms) - (apply 'values val-forms)) - -(defmacro Multiple-value-list (form) - (list 'let* (list '(*mvalues-values* nil) (list '*mvalues-temp* form)) - '(or (and (eq *mvalues-temp* (car *mvalues-values*)) *mvalues-values*) - (list *mvalues-temp*)))) - -(defmacro Multiple-value-call (function &rest args) - (list 'apply function - (cons 'append - (mapcar (function (lambda (x) (list 'Multiple-value-list x))) - args)))) - -(defmacro Multiple-value-bind (vars form &rest body) - (list* 'multiple-value-bind vars (list 'Multiple-value-list form) body)) - -(defmacro Multiple-value-setq (vars form) - (list 'multiple-value-setq vars (list 'Multiple-value-list form))) - -(defmacro Multiple-value-prog1 (form &rest body) - (list 'prog1 form (list* 'let '((*mvalues-values* nil)) body))) - - -;;; Routines for parsing keyword arguments. - -(defun build-klist (arglist keys &optional allow-others) - (let ((res (Multiple-value-call 'mapcar* 'cons (unzip-lists arglist)))) - (or allow-others - (let ((bad (set-difference (mapcar 'car res) keys))) - (if bad (error "Bad keywords: %s not in %s" bad keys)))) - res)) - -(defun extract-from-klist (klist key &optional def) - (let ((res (assq key klist))) (if res (cdr res) def))) - -(defun keyword-argument-supplied-p (klist key) - (assq key klist)) - -(defun elt-satisfies-test-p (item elt klist) - (let ((test-not (cdr (assq ':test-not klist))) - (test (cdr (assq ':test klist))) - (key (cdr (assq ':key klist)))) - (if key (setq elt (funcall key elt))) - (if test-not (not (funcall test-not item elt)) - (funcall (or test 'eql) item elt)))) - - -;;; Rounding functions with old-style multiple value returns. - -(defun cl-floor (a &optional b) (Values-list (floor* a b))) -(defun cl-ceiling (a &optional b) (Values-list (ceiling* a b))) -(defun cl-round (a &optional b) (Values-list (round* a b))) -(defun cl-truncate (a &optional b) (Values-list (truncate* a b))) - -(defun safe-idiv (a b) - (let* ((q (/ (abs a) (abs b))) - (s (* (signum a) (signum b)))) - (Values q (- a (* s q b)) s))) - - -;; Internal routines. - -(defun pair-with-newsyms (oldforms) - (let ((newsyms (mapcar (function (lambda (x) (gensym))) oldforms))) - (Values (mapcar* 'list newsyms oldforms) newsyms))) - -(defun zip-lists (evens odds) - (mapcan 'list evens odds)) - -(defun unzip-lists (list) - (let ((e nil) (o nil)) - (while list - (setq e (cons (car list) e) o (cons (cadr list) o) list (cddr list))) - (Values (nreverse e) (nreverse o)))) - -(defun reassemble-argslists (list) - (let ((n (apply 'min (mapcar 'length list))) (res nil)) - (while (>= (setq n (1- n)) 0) - (setq res (cons (mapcar (function (lambda (x) (elt x n))) list) res))) - res)) - -(defun duplicate-symbols-p (list) - (let ((res nil)) - (while list - (if (memq (car list) (cdr list)) (setq res (cons (car list) res))) - (setq list (cdr list))) - res)) - - -;;; Setf internals. - -(defun setnth (n list x) - (setcar (nthcdr n list) x)) - -(defun setnthcdr (n list x) - (setcdr (nthcdr (1- n) list) x)) - -(defun setelt (seq n x) - (if (consp seq) (setcar (nthcdr n seq) x) (aset seq n x))) - - -;;; Functions omitted: case-clausify, check-do-stepforms, check-do-endforms, -;;; extract-do-inits, extract-do[*]-steps, select-stepping-forms, -;;; elt-satisfies-if[-not]-p, with-keyword-args, mv-bind-clausify, -;;; all names with embedded `$'. - - -(provide 'cl-compat) - -;;; cl-compat.el ends here -
--- a/lisp/cl/cl-extra.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,936 +0,0 @@ -;;; cl-extra.el --- Common Lisp extensions for GNU Emacs Lisp (part two) - -;; Copyright (C) 1993 Free Software Foundation, Inc. - -;; Author: Dave Gillespie <daveg@synaptics.com> -;; Version: 2.02 -;; Keywords: extensions - -;; 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.34. - -;;; Commentary: - -;; These are extensions to Emacs Lisp that provide a degree of -;; Common Lisp compatibility, beyond what is already built-in -;; in Emacs Lisp. -;; -;; This package was written by Dave Gillespie; it is a complete -;; rewrite of Cesar Quiroz's original cl.el package of December 1986. -;; -;; This package works with Emacs 18, Emacs 19, and XEmacs/Lucid Emacs 19. -;; -;; Bug reports, comments, and suggestions are welcome! - -;; This file contains portions of the Common Lisp extensions -;; package which are autoloaded since they are relatively obscure. - -;; See cl.el for Change Log. - - -;;; Code: - -(or (memq 'cl-19 features) - (error "Tried to load `cl-extra' before `cl'!")) - - -;;; We define these here so that this file can compile without having -;;; loaded the cl.el file already. - -(defmacro cl-push (x place) (list 'setq place (list 'cons x place))) -(defmacro cl-pop (place) - (list 'car (list 'prog1 place (list 'setq place (list 'cdr place))))) - -(defvar cl-emacs-type) - - -;;; Type coercion. - -(defun coerce (x type) - "Coerce OBJECT to type TYPE. -TYPE is a Common Lisp type specifier." - (cond ((eq type 'list) (if (listp x) x (append x nil))) - ((eq type 'vector) (if (vectorp x) x (vconcat x))) - ((eq type 'string) (if (stringp x) x (concat x))) - ((eq type 'array) (if (arrayp x) x (vconcat x))) - ((and (eq type 'character) (stringp x) (= (length x) 1)) (aref x 0)) - ((and (eq type 'character) (symbolp x)) (coerce (symbol-name x) type)) - ((eq type 'float) (float x)) - ((typep x type) x) - (t (error "Can't coerce %s to type %s" x type)))) - - -;;; Predicates. - -(defun equalp (x y) - "T if two Lisp objects have similar structures and contents. -This is like `equal', except that it accepts numerically equal -numbers of different types (float vs. integer), and also compares -strings case-insensitively." - (cond ((eq x y) t) - ((stringp x) - (and (stringp y) (= (length x) (length y)) - (or (string-equal x y) - (string-equal (downcase x) (downcase y))))) ; lazy but simple! - ((numberp x) - (and (numberp y) (= x y))) - ((consp x) - ;; XEmacs change - (while (and (consp x) (consp y) (equalp (cl-pop x) (cl-pop y)))) - (and (not (consp x)) (equalp x y))) - ((vectorp x) - (and (vectorp y) (= (length x) (length y)) - (let ((i (length x))) - (while (and (>= (setq i (1- i)) 0) - (equalp (aref x i) (aref y i)))) - (< i 0)))) - (t (equal x y)))) - - -;;; Control structures. - -(defun cl-mapcar-many (cl-func cl-seqs) - (if (cdr (cdr cl-seqs)) - (let* ((cl-res nil) - (cl-n (apply 'min (mapcar 'length cl-seqs))) - (cl-i 0) - (cl-args (copy-sequence cl-seqs)) - cl-p1 cl-p2) - (setq cl-seqs (copy-sequence cl-seqs)) - (while (< cl-i cl-n) - (setq cl-p1 cl-seqs cl-p2 cl-args) - (while cl-p1 - (setcar cl-p2 - (if (consp (car cl-p1)) - (prog1 (car (car cl-p1)) - (setcar cl-p1 (cdr (car cl-p1)))) - (aref (car cl-p1) cl-i))) - (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2))) - (cl-push (apply cl-func cl-args) cl-res) - (setq cl-i (1+ cl-i))) - (nreverse cl-res)) - (let ((cl-res nil) - (cl-x (car cl-seqs)) - (cl-y (nth 1 cl-seqs))) - (let ((cl-n (min (length cl-x) (length cl-y))) - (cl-i -1)) - (while (< (setq cl-i (1+ cl-i)) cl-n) - (cl-push (funcall cl-func - (if (consp cl-x) (cl-pop cl-x) (aref cl-x cl-i)) - (if (consp cl-y) (cl-pop cl-y) (aref cl-y cl-i))) - cl-res))) - (nreverse cl-res)))) - -(defun map (cl-type cl-func cl-seq &rest cl-rest) - "Map a function across one or more sequences, returning a sequence. -TYPE is the sequence type to return, FUNC is the function, and SEQS -are the argument sequences." - (let ((cl-res (apply 'mapcar* cl-func cl-seq cl-rest))) - (and cl-type (coerce cl-res cl-type)))) - -(defun maplist (cl-func cl-list &rest cl-rest) - "Map FUNC to each sublist of LIST or LISTS. -Like `mapcar', except applies to lists and their cdr's rather than to -the elements themselves." - (if cl-rest - (let ((cl-res nil) - (cl-args (cons cl-list (copy-sequence cl-rest))) - cl-p) - (while (not (memq nil cl-args)) - (cl-push (apply cl-func cl-args) cl-res) - (setq cl-p cl-args) - (while cl-p (setcar cl-p (cdr (cl-pop cl-p)) ))) - (nreverse cl-res)) - (let ((cl-res nil)) - (while cl-list - (cl-push (funcall cl-func cl-list) cl-res) - (setq cl-list (cdr cl-list))) - (nreverse cl-res)))) - - -;; mapc is now in C, renamed from `mapc-internal'. - -;(defun mapc (cl-func cl-seq &rest cl-rest) -; "Like `mapcar', but does not accumulate values returned by the function." -; (if cl-rest -; (apply 'map nil cl-func cl-seq cl-rest) -; ;; XEmacs change: we call mapc-internal, which really doesn't -; ;; accumulate any results. -; (mapc-internal cl-func cl-seq)) -; cl-seq) - -(defun mapl (cl-func cl-list &rest cl-rest) - "Like `maplist', but does not accumulate values returned by the function." - (if cl-rest - (apply 'maplist cl-func cl-list cl-rest) - (let ((cl-p cl-list)) - (while cl-p (funcall cl-func cl-p) (setq cl-p (cdr cl-p))))) - cl-list) - -(defun mapcan (cl-func cl-seq &rest cl-rest) - "Like `mapcar', but nconc's together the values returned by the function." - (apply 'nconc (apply 'mapcar* cl-func cl-seq cl-rest))) - -(defun mapcon (cl-func cl-list &rest cl-rest) - "Like `maplist', but nconc's together the values returned by the function." - (apply 'nconc (apply 'maplist cl-func cl-list cl-rest))) - -(defun some (cl-pred cl-seq &rest cl-rest) - "Return true if PREDICATE is true of any element of SEQ or SEQs. -If so, return the true (non-nil) value returned by PREDICATE." - (if (or cl-rest (nlistp cl-seq)) - (catch 'cl-some - (apply 'map nil - (function (lambda (&rest cl-x) - (let ((cl-res (apply cl-pred cl-x))) - (if cl-res (throw 'cl-some cl-res))))) - cl-seq cl-rest) nil) - (let ((cl-x nil)) - (while (and cl-seq (not (setq cl-x (funcall cl-pred (cl-pop cl-seq)))))) - cl-x))) - -(defun every (cl-pred cl-seq &rest cl-rest) - "Return true if PREDICATE is true of every element of SEQ or SEQs." - (if (or cl-rest (nlistp cl-seq)) - (catch 'cl-every - (apply 'map nil - (function (lambda (&rest cl-x) - (or (apply cl-pred cl-x) (throw 'cl-every nil)))) - cl-seq cl-rest) t) - (while (and cl-seq (funcall cl-pred (car cl-seq))) - (setq cl-seq (cdr cl-seq))) - (null cl-seq))) - -(defun notany (cl-pred cl-seq &rest cl-rest) - "Return true if PREDICATE is false of every element of SEQ or SEQs." - (not (apply 'some cl-pred cl-seq cl-rest))) - -(defun notevery (cl-pred cl-seq &rest cl-rest) - "Return true if PREDICATE is false of some element of SEQ or SEQs." - (not (apply 'every cl-pred cl-seq cl-rest))) - -;;; Support for `loop'. -(defun cl-map-keymap (cl-func cl-map) - (while (symbolp cl-map) (setq cl-map (symbol-function cl-map))) - (if (eq cl-emacs-type 'lucid) (funcall 'map-keymap cl-func cl-map) - (if (listp cl-map) - (let ((cl-p cl-map)) - (while (consp (setq cl-p (cdr cl-p))) - (cond ((consp (car cl-p)) - (funcall cl-func (car (car cl-p)) (cdr (car cl-p)))) - ((vectorp (car cl-p)) - (cl-map-keymap cl-func (car cl-p))) - ((eq (car cl-p) 'keymap) - (setq cl-p nil))))) - (let ((cl-i -1)) - (while (< (setq cl-i (1+ cl-i)) (length cl-map)) - (if (aref cl-map cl-i) - (funcall cl-func cl-i (aref cl-map cl-i)))))))) - -(defun cl-map-keymap-recursively (cl-func-rec cl-map &optional cl-base) - (or cl-base - (setq cl-base (copy-sequence (if (eq cl-emacs-type 18) "0" [0])))) - (cl-map-keymap - (function - (lambda (cl-key cl-bind) - (aset cl-base (1- (length cl-base)) cl-key) - (if (keymapp cl-bind) - (cl-map-keymap-recursively - cl-func-rec cl-bind - (funcall (if (eq cl-emacs-type 18) 'concat 'vconcat) - cl-base (list 0))) - (funcall cl-func-rec cl-base cl-bind)))) - cl-map)) - -(defun cl-map-intervals (cl-func &optional cl-what cl-prop cl-start cl-end) - (or cl-what (setq cl-what (current-buffer))) - (if (bufferp cl-what) - (let (cl-mark cl-mark2 (cl-next t) cl-next2) - (save-excursion - (set-buffer cl-what) - (setq cl-mark (copy-marker (or cl-start (point-min)))) - (setq cl-mark2 (and cl-end (copy-marker cl-end)))) - (while (and cl-next (or (not cl-mark2) (< cl-mark cl-mark2))) - (setq cl-next (and (fboundp 'next-property-change) - (if cl-prop (next-single-property-change - cl-mark cl-prop cl-what) - (next-property-change cl-mark cl-what))) - cl-next2 (or cl-next (save-excursion - (set-buffer cl-what) (point-max)))) - (funcall cl-func (prog1 (marker-position cl-mark) - (set-marker cl-mark cl-next2)) - (if cl-mark2 (min cl-next2 cl-mark2) cl-next2))) - (set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil))) - (or cl-start (setq cl-start 0)) - (or cl-end (setq cl-end (length cl-what))) - (while (< cl-start cl-end) - (let ((cl-next (or (and (fboundp 'next-property-change) - (if cl-prop (next-single-property-change - cl-start cl-prop cl-what) - (next-property-change cl-start cl-what))) - cl-end))) - (funcall cl-func cl-start (min cl-next cl-end)) - (setq cl-start cl-next))))) - -(defun cl-map-overlays (cl-func &optional cl-buffer cl-start cl-end cl-arg) - (or cl-buffer (setq cl-buffer (current-buffer))) - (if (fboundp 'overlay-lists) - - ;; This is the preferred algorithm, though overlay-lists is undocumented. - (let (cl-ovl) - (save-excursion - (set-buffer cl-buffer) - (setq cl-ovl (overlay-lists)) - (if cl-start (setq cl-start (copy-marker cl-start))) - (if cl-end (setq cl-end (copy-marker cl-end)))) - (setq cl-ovl (nconc (car cl-ovl) (cdr cl-ovl))) - (while (and cl-ovl - (or (not (overlay-start (car cl-ovl))) - (and cl-end (>= (overlay-start (car cl-ovl)) cl-end)) - (and cl-start (<= (overlay-end (car cl-ovl)) cl-start)) - (not (funcall cl-func (car cl-ovl) cl-arg)))) - (setq cl-ovl (cdr cl-ovl))) - (if cl-start (set-marker cl-start nil)) - (if cl-end (set-marker cl-end nil))) - - ;; This alternate algorithm fails to find zero-length overlays. - (let ((cl-mark (save-excursion (set-buffer cl-buffer) - (copy-marker (or cl-start (point-min))))) - (cl-mark2 (and cl-end (save-excursion (set-buffer cl-buffer) - (copy-marker cl-end)))) - cl-pos cl-ovl) - (while (save-excursion - (and (setq cl-pos (marker-position cl-mark)) - (< cl-pos (or cl-mark2 (point-max))) - (progn - (set-buffer cl-buffer) - (setq cl-ovl (overlays-at cl-pos)) - (set-marker cl-mark (next-overlay-change cl-pos))))) - (while (and cl-ovl - (or (/= (overlay-start (car cl-ovl)) cl-pos) - (not (and (funcall cl-func (car cl-ovl) cl-arg) - (set-marker cl-mark nil))))) - (setq cl-ovl (cdr cl-ovl)))) - (set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil))))) - -;;; Support for `setf'. -(defun cl-set-frame-visible-p (frame val) - (cond ((null val) (make-frame-invisible frame)) - ((eq val 'icon) (iconify-frame frame)) - (t (make-frame-visible frame))) - val) - -;;; Support for `progv'. -(defvar cl-progv-save) -(defun cl-progv-before (syms values) - (while syms - (cl-push (if (boundp (car syms)) - (cons (car syms) (symbol-value (car syms))) - (car syms)) cl-progv-save) - (if values - (set (cl-pop syms) (cl-pop values)) - (makunbound (cl-pop syms))))) - -(defun cl-progv-after () - (while cl-progv-save - (if (consp (car cl-progv-save)) - (set (car (car cl-progv-save)) (cdr (car cl-progv-save))) - (makunbound (car cl-progv-save))) - (cl-pop cl-progv-save))) - - -;;; Numbers. - -(defun gcd (&rest args) - "Return the greatest common divisor of the arguments." - (let ((a (abs (or (cl-pop args) 0)))) - (while args - (let ((b (abs (cl-pop args)))) - (while (> b 0) (setq b (% a (setq a b)))))) - a)) - -(defun lcm (&rest args) - "Return the least common multiple of the arguments." - (if (memq 0 args) - 0 - (let ((a (abs (or (cl-pop args) 1)))) - (while args - (let ((b (abs (cl-pop args)))) - (setq a (* (/ a (gcd a b)) b)))) - a))) - -(defun isqrt (a) - "Return the integer square root of the argument." - (if (and (integerp a) (> a 0)) - ;; XEmacs change - (let ((g (cond ((>= a 1000000) 10000) ((>= a 10000) 1000) - ((>= a 100) 100) (t 10))) - g2) - (while (< (setq g2 (/ (+ g (/ a g)) 2)) g) - (setq g g2)) - g) - (if (eq a 0) 0 (signal 'arith-error nil)))) - -(defun cl-expt (x y) - "Return X raised to the power of Y. Works only for integer arguments." - (if (<= y 0) (if (= y 0) 1 (if (memq x '(-1 1)) (cl-expt x (- y)) 0)) - (* (if (= (% y 2) 0) 1 x) (cl-expt (* x x) (/ y 2))))) -(or (and (fboundp 'expt) (subrp (symbol-function 'expt))) - (defalias 'expt 'cl-expt)) - -(defun floor* (x &optional y) - "Return a list of the floor of X and the fractional part of X. -With two arguments, return floor and remainder of their quotient." - (let ((q (floor x y))) - (list q (- x (if y (* y q) q))))) - -(defun ceiling* (x &optional y) - "Return a list of the ceiling of X and the fractional part of X. -With two arguments, return ceiling and remainder of their quotient." - (let ((res (floor* x y))) - (if (= (car (cdr res)) 0) res - (list (1+ (car res)) (- (car (cdr res)) (or y 1)))))) - -(defun truncate* (x &optional y) - "Return a list of the integer part of X and the fractional part of X. -With two arguments, return truncation and remainder of their quotient." - (if (eq (>= x 0) (or (null y) (>= y 0))) - (floor* x y) (ceiling* x y))) - -(defun round* (x &optional y) - "Return a list of X rounded to the nearest integer and the remainder. -With two arguments, return rounding and remainder of their quotient." - (if y - (if (and (integerp x) (integerp y)) - (let* ((hy (/ y 2)) - (res (floor* (+ x hy) y))) - (if (and (= (car (cdr res)) 0) - (= (+ hy hy) y) - (/= (% (car res) 2) 0)) - (list (1- (car res)) hy) - (list (car res) (- (car (cdr res)) hy)))) - (let ((q (round (/ x y)))) - (list q (- x (* q y))))) - (if (integerp x) (list x 0) - (let ((q (round x))) - (list q (- x q)))))) - -(defun mod* (x y) - "The remainder of X divided by Y, with the same sign as Y." - (nth 1 (floor* x y))) - -(defun rem* (x y) - "The remainder of X divided by Y, with the same sign as X." - (nth 1 (truncate* x y))) - -(defun signum (a) - "Return 1 if A is positive, -1 if negative, 0 if zero." - (cond ((> a 0) 1) ((< a 0) -1) (t 0))) - - -;; Random numbers. - -(defvar *random-state*) -(defun random* (lim &optional state) - "Return a random nonnegative number less than LIM, an integer or float. -Optional second arg STATE is a random-state object." - (or state (setq state *random-state*)) - ;; 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) - (aset state 3 (setq vec (make-vector 55 nil))) - (aset vec 0 j) - (while (> (setq i (% (+ i 21) 55)) 0) - (aset vec i (setq j (prog1 k (setq k (- j k)))))) - (while (< (setq i (1+ i)) 200) (random* 2 state)))) - (let* ((i (aset state 1 (% (1+ (aref state 1)) 55))) - (j (aset state 2 (% (1+ (aref state 2)) 55))) - (n (logand 8388607 (aset vec i (- (aref vec i) (aref vec j)))))) - (if (integerp lim) - (if (<= lim 512) (% n lim) - (if (> lim 8388607) (setq n (+ (lsh n 9) (random* 512 state)))) - (let ((mask 1023)) - (while (< mask (1- lim)) (setq mask (1+ (+ mask mask)))) - (if (< (setq n (logand n mask)) lim) n (random* lim state)))) - (* (/ n '8388608e0) lim))))) - -(defun make-random-state (&optional state) - "Return a copy of random-state STATE, or of `*random-state*' if omitted. -If STATE is t, return a new state object seeded from the time of day." - (cond ((null state) (make-random-state *random-state*)) - ((vectorp state) (cl-copy-tree state t)) - ((integerp state) (vector 'cl-random-state-tag -1 30 state)) - (t (make-random-state (cl-random-time))))) - -(defun random-state-p (object) - "Return t if OBJECT is a random-state object." - (and (vectorp object) (= (length object) 4) - (eq (aref object 0) 'cl-random-state-tag))) - - -;; Implementation limits. - -(defun cl-finite-do (func a b) - (condition-case err - (let ((res (funcall func a b))) ; check for IEEE infinity - (and (numberp res) (/= res (/ res 2)) res)) - (arith-error nil))) - -(defvar most-positive-float) -(defvar most-negative-float) -(defvar least-positive-float) -(defvar least-negative-float) -(defvar least-positive-normalized-float) -(defvar least-negative-normalized-float) -(defvar float-epsilon) -(defvar float-negative-epsilon) - -(defun cl-float-limits () - (or most-positive-float (not (numberp '2e1)) - (let ((x '2e0) y z) - ;; Find maximum exponent (first two loops are optimizations) - (while (cl-finite-do '* x x) (setq x (* x x))) - (while (cl-finite-do '* x (/ x 2)) (setq x (* x (/ x 2)))) - (while (cl-finite-do '+ x x) (setq x (+ x x))) - (setq z x y (/ x 2)) - ;; Now fill in 1's in the mantissa. - (while (and (cl-finite-do '+ x y) (/= (+ x y) x)) - (setq x (+ x y) y (/ y 2))) - (setq most-positive-float x - 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)) - (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)) - (setq x (/ x 2))) - (setq least-positive-float x - least-negative-float (- x)) - (setq x '1e0) - (while (/= (+ '1e0 x) '1e0) (setq x (/ x 2))) - (setq float-epsilon (* x 2)) - (setq x '1e0) - (while (/= (- '1e0 x) '1e0) (setq x (/ x 2))) - (setq float-negative-epsilon (* x 2)))) - nil) - - -;;; Sequence functions. - -;XEmacs -- our built-in is more powerful. -;(defun subseq (seq start &optional end) -; "Return the subsequence of SEQ from START to END. -;If END is omitted, it defaults to the length of the sequence. -;If START or END is negative, it counts from the end." -; (if (stringp seq) (substring seq start end) -; (let (len) -; (and end (< end 0) (setq end (+ end (setq len (length seq))))) -; (if (< start 0) (setq start (+ start (or len (setq len (length seq)))))) -; (cond ((listp seq) -; (if (> start 0) (setq seq (nthcdr start seq))) -; (if end -; (let ((res nil)) -; (while (>= (setq end (1- end)) start) -; (cl-push (cl-pop seq) res)) -; (nreverse res)) -; (copy-sequence seq))) -; (t -; (or end (setq end (or len (length seq)))) -; (let ((res (make-vector (max (- end start) 0) nil)) -; (i 0)) -; (while (< start end) -; (aset res i (aref seq start)) -; (setq i (1+ i) start (1+ start))) -; res)))))) - -(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)))) - - -;;; List functions. - -(defun revappend (x y) - "Equivalent to (append (reverse X) Y)." - (nconc (reverse x) y)) - -(defun nreconc (x y) - "Equivalent to (nconc (nreverse X) Y)." - (nconc (nreverse x) y)) - -(defun list-length (x) - "Return the length of a list. Return nil if list is circular." - (let ((n 0) (fast x) (slow x)) - (while (and (cdr fast) (not (and (eq fast slow) (> n 0)))) - (setq n (+ n 2) fast (cdr (cdr fast)) slow (cdr slow))) - (if fast (if (cdr fast) nil (1+ n)) n))) - -(defun tailp (sublist list) - "Return true if SUBLIST is a tail of LIST." - (while (and (consp list) (not (eq sublist list))) - (setq list (cdr list))) - (if (numberp sublist) (equal sublist list) (eq sublist list))) - -(defun cl-copy-tree (tree &optional vecp) - "Make a copy of TREE. -If TREE is a cons cell, this recursively copies both its car and its cdr. -Contrast to copy-sequence, which copies only along the cdrs. With second -argument VECP, this copies vectors as well as conses." - (if (consp tree) - (let ((p (setq tree (copy-list tree)))) - (while (consp p) - (if (or (consp (car p)) (and vecp (vectorp (car p)))) - (setcar p (cl-copy-tree (car p) vecp))) - (or (listp (cdr p)) (setcdr p (cl-copy-tree (cdr p) vecp))) - (cl-pop p))) - (if (and vecp (vectorp tree)) - (let ((i (length (setq tree (copy-sequence tree))))) - (while (>= (setq i (1- i)) 0) - (aset tree i (cl-copy-tree (aref tree i) vecp)))))) - tree) -(or (and (fboundp 'copy-tree) (subrp (symbol-function 'copy-tree))) - (defalias 'copy-tree 'cl-copy-tree)) - - -;;; Property lists. - -(defun get* (sym tag &optional def) ; See compiler macro in cl-macs.el - "Return the value of SYMBOL's PROPNAME property, or DEFAULT if none." - (or (get sym tag) - (and def - (let ((plist (symbol-plist sym))) - (while (and plist (not (eq (car plist) tag))) - (setq plist (cdr (cdr plist)))) - (if plist (car (cdr plist)) def))))) - -(defun getf (plist tag &optional def) - "Search PROPLIST for property PROPNAME; return its value or DEFAULT. -PROPLIST is a list of the sort returned by `symbol-plist'." - (setplist '--cl-getf-symbol-- plist) - (or (get '--cl-getf-symbol-- tag) - (and def (get* '--cl-getf-symbol-- tag def)))) - -(defun cl-set-getf (plist tag val) - (let ((p plist)) - (while (and p (not (eq (car p) tag))) (setq p (cdr (cdr p)))) - (if p (progn (setcar (cdr p) val) plist) (list* tag val plist)))) - -(defun cl-do-remf (plist tag) - (let ((p (cdr plist))) - (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p)))) - (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t)))) - -(defun cl-remprop (sym tag) - "Remove from SYMBOL's plist the property PROP and its value." - (let ((plist (symbol-plist sym))) - (if (and plist (eq tag (car plist))) - (progn (setplist sym (cdr (cdr plist))) t) - (cl-do-remf plist tag)))) -(or (and (fboundp 'remprop) (subrp (symbol-function 'remprop))) - (defalias 'remprop 'cl-remprop)) - - - -;;; 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 (eq (car-safe x) 'cl-hash-table-tag) - (and (vectorp x) (= (length x) 4) (eq (aref x 0) cl-lucid-hash-tag)) - (and (fboundp 'hashtablep) (funcall 'hashtablep x)))) - -(defun cl-not-hash-table (x &optional y &rest z) - (signal 'wrong-type-argument (list 'hash-table-p (or y x)))) - -(defun cl-hash-lookup (key table) - (or (eq (car-safe table) 'cl-hash-table-tag) (cl-not-hash-table table)) - (let* ((array (nth 2 table)) (test (car (cdr table))) (str key) sym) - (if (symbolp array) (setq str nil sym (symbol-value array)) - (while (or (consp str) (and (vectorp str) (> (length str) 0))) - (setq str (elt str 0))) - (cond ((stringp str) (if (eq test 'equalp) (setq str (downcase str)))) - ((symbolp str) (setq str (symbol-name str))) - ((and (numberp str) (> str -8000000) (< str 8000000)) - (or (integerp str) (setq str (truncate str))) - (setq str (aref ["0" "1" "2" "3" "4" "5" "6" "7" "8" "9" "10" - "11" "12" "13" "14" "15"] (logand str 15)))) - (t (setq str "*"))) - (setq sym (symbol-value (intern-soft str array)))) - (list (and sym (cond ((or (eq test 'eq) - (and (eq test 'eql) (not (numberp key)))) - (assq key sym)) - ((memq test '(eql equal)) (assoc key sym)) - (t (assoc* key sym ':test test)))) - sym str))) - -(defvar cl-builtin-gethash - (if (and (fboundp 'gethash) (subrp (symbol-function 'gethash))) - (symbol-function 'gethash) 'cl-not-hash-table)) -(defvar cl-builtin-remhash - (if (and (fboundp 'remhash) (subrp (symbol-function 'remhash))) - (symbol-function 'remhash) 'cl-not-hash-table)) -(defvar cl-builtin-clrhash - (if (and (fboundp 'clrhash) (subrp (symbol-function 'clrhash))) - (symbol-function 'clrhash) 'cl-not-hash-table)) -(defvar cl-builtin-maphash - (if (and (fboundp 'maphash) (subrp (symbol-function 'maphash))) - (symbol-function 'maphash) 'cl-not-hash-table)) - -(defun cl-gethash (key table &optional def) - "Look up KEY in HASH-TABLE; return corresponding value, or DEFAULT." - (if (consp table) - (let ((found (cl-hash-lookup key table))) - (if (car found) (cdr (car found)) def)) - (funcall cl-builtin-gethash key table def))) -(defalias 'gethash 'cl-gethash) - -(defun cl-puthash (key val table) - (if (consp table) - (let ((found (cl-hash-lookup key table))) - (if (car found) (setcdr (car found) val) - (if (nth 2 found) - (progn - (if (> (nth 3 table) (* (length (nth 2 table)) 3)) - (let ((new-table (make-vector (nth 3 table) 0))) - (mapatoms (function - (lambda (sym) - (set (intern (symbol-name sym) new-table) - (symbol-value sym)))) - (nth 2 table)) - (setcar (cdr (cdr table)) new-table))) - (set (intern (nth 2 found) (nth 2 table)) - (cons (cons key val) (nth 1 found)))) - (set (nth 2 table) (cons (cons key val) (nth 1 found)))) - (setcar (cdr (cdr (cdr table))) (1+ (nth 3 table))))) - (funcall 'puthash key val table)) val) - -(defun cl-remhash (key table) - "Remove KEY from HASH-TABLE." - (if (consp table) - (let ((found (cl-hash-lookup key table))) - (and (car found) - (let ((del (delq (car found) (nth 1 found)))) - (setcar (cdr (cdr (cdr table))) (1- (nth 3 table))) - (if (nth 2 found) (set (intern (nth 2 found) (nth 2 table)) del) - (set (nth 2 table) del)) t))) - (prog1 (not (eq (funcall cl-builtin-gethash key table '--cl--) '--cl--)) - (funcall cl-builtin-remhash key table)))) -(defalias 'remhash 'cl-remhash) - -(defun cl-clrhash (table) - "Clear HASH-TABLE." - (if (consp table) - (progn - (or (hash-table-p table) (cl-not-hash-table table)) - (if (symbolp (nth 2 table)) (set (nth 2 table) nil) - (setcar (cdr (cdr table)) (make-vector (length (nth 2 table)) 0))) - (setcar (cdr (cdr (cdr table))) 0)) - (funcall cl-builtin-clrhash table)) - nil) -(defalias 'clrhash 'cl-clrhash) - -(defun cl-maphash (cl-func cl-table) - "Call FUNCTION on keys and values from HASH-TABLE." - (or (hash-table-p cl-table) (cl-not-hash-table cl-table)) - (if (consp cl-table) - (mapatoms (function (lambda (cl-x) - (setq cl-x (symbol-value cl-x)) - (while cl-x - (funcall cl-func (car (car cl-x)) - (cdr (car cl-x))) - (setq cl-x (cdr cl-x))))) - (if (symbolp (nth 2 cl-table)) - (vector (nth 2 cl-table)) (nth 2 cl-table))) - (funcall cl-builtin-maphash cl-func cl-table))) -(defalias 'maphash 'cl-maphash) - -(defun hash-table-count (table) - "Return the number of entries in HASH-TABLE." - (or (hash-table-p table) (cl-not-hash-table table)) - (if (consp table) (nth 3 table) (funcall 'hashtable-fullness table))) - - -;;; Some debugging aids. - -(defun cl-prettyprint (form) - "Insert a pretty-printed rendition of a Lisp FORM in current buffer." - (let ((pt (point)) last) - (insert "\n" (prin1-to-string form) "\n") - (setq last (point)) - (goto-char (1+ pt)) - (while (search-forward "(quote " last t) - (delete-backward-char 7) - (insert "'") - (forward-sexp) - (delete-char 1)) - (goto-char (1+ pt)) - (cl-do-prettyprint))) - -(defun cl-do-prettyprint () - (skip-chars-forward " ") - (if (looking-at "(") - (let ((skip (or (looking-at "((") (looking-at "(prog") - (looking-at "(unwind-protect ") - (looking-at "(function (") - (looking-at "(cl-block-wrapper "))) - (two (or (looking-at "(defun ") (looking-at "(defmacro "))) - (let (or (looking-at "(let\\*? ") (looking-at "(while "))) - (set (looking-at "(p?set[qf] "))) - (if (or skip let - (progn - (forward-sexp) - (and (>= (current-column) 78) (progn (backward-sexp) t)))) - (let ((nl t)) - (forward-char 1) - (cl-do-prettyprint) - (or skip (looking-at ")") (cl-do-prettyprint)) - (or (not two) (looking-at ")") (cl-do-prettyprint)) - (while (not (looking-at ")")) - (if set (setq nl (not nl))) - (if nl (insert "\n")) - (lisp-indent-line) - (cl-do-prettyprint)) - (forward-char 1)))) - (forward-sexp))) - -(defvar cl-macroexpand-cmacs nil) -(defvar cl-closure-vars nil) - -(defun cl-macroexpand-all (form &optional env) - "Expand all macro calls through a Lisp FORM. -This also does some trivial optimizations to make the form prettier." - (while (or (not (eq form (setq form (macroexpand form env)))) - (and cl-macroexpand-cmacs - (not (eq form (setq form (compiler-macroexpand form))))))) - (cond ((not (consp form)) form) - ((memq (car form) '(let let*)) - (if (null (nth 1 form)) - (cl-macroexpand-all (cons 'progn (cddr form)) env) - (let ((letf nil) (res nil) (lets (cadr form))) - (while lets - (cl-push (if (consp (car lets)) - (let ((exp (cl-macroexpand-all (caar lets) env))) - (or (symbolp exp) (setq letf t)) - (cons exp (cl-macroexpand-body (cdar lets) env))) - (let ((exp (cl-macroexpand-all (car lets) env))) - (if (symbolp exp) exp - (setq letf t) (list exp nil)))) res) - (setq lets (cdr lets))) - (list* (if letf (if (eq (car form) 'let) 'letf 'letf*) (car form)) - (nreverse res) (cl-macroexpand-body (cddr form) env))))) - ((eq (car form) 'cond) - (cons (car form) - (mapcar (function (lambda (x) (cl-macroexpand-body x env))) - (cdr form)))) - ((eq (car form) 'condition-case) - (list* (car form) (nth 1 form) (cl-macroexpand-all (nth 2 form) env) - (mapcar (function - (lambda (x) - (cons (car x) (cl-macroexpand-body (cdr x) env)))) - (cdddr form)))) - ((memq (car form) '(quote function)) - (if (eq (car-safe (nth 1 form)) 'lambda) - (let ((body (cl-macroexpand-body (cddadr form) env))) - (if (and cl-closure-vars (eq (car form) 'function) - (cl-expr-contains-any body cl-closure-vars)) - (let* ((new (mapcar 'gensym cl-closure-vars)) - (sub (pairlis cl-closure-vars new)) (decls nil)) - (while (or (stringp (car body)) - (eq (car-safe (car body)) 'interactive)) - (cl-push (list 'quote (cl-pop body)) decls)) - (put (car (last cl-closure-vars)) 'used t) - (append - (list 'list '(quote lambda) '(quote (&rest --cl-rest--))) - (sublis sub (nreverse decls)) - (list - (list* 'list '(quote apply) - (list 'list '(quote quote) - (list 'function - (list* 'lambda - (append new (cadadr form)) - (sublis sub body)))) - (nconc (mapcar (function - (lambda (x) - (list 'list '(quote quote) x))) - cl-closure-vars) - '((quote --cl-rest--))))))) - (list (car form) (list* 'lambda (cadadr form) body)))) - (let ((found (assq (cadr form) env))) - (if (eq (cadr (caddr found)) 'cl-labels-args) - (cl-macroexpand-all (cadr (caddr (cadddr found))) env) - form)))) - ((memq (car form) '(defun defmacro)) - (list* (car form) (nth 1 form) (cl-macroexpand-body (cddr form) env))) - ((and (eq (car form) 'progn) (not (cddr form))) - (cl-macroexpand-all (nth 1 form) env)) - ((eq (car form) 'setq) - (let* ((args (cl-macroexpand-body (cdr form) env)) (p args)) - (while (and p (symbolp (car p))) (setq p (cddr p))) - (if p (cl-macroexpand-all (cons 'setf args)) (cons 'setq args)))) - (t (cons (car form) (cl-macroexpand-body (cdr form) env))))) - -(defun cl-macroexpand-body (body &optional env) - (mapcar (function (lambda (x) (cl-macroexpand-all x env))) body)) - -(defun cl-prettyexpand (form &optional full) - (message "Expanding...") - (let ((cl-macroexpand-cmacs full) (cl-compiling-file full) - (byte-compile-macro-environment nil)) - (setq form (cl-macroexpand-all form - (and (not full) '((block) (eval-when))))) - (message "Formatting...") - (prog1 (cl-prettyprint form) - (message "")))) - - - -(run-hooks 'cl-extra-load-hook) - -(provide 'cl-extra) - -;;; cl-extra.el ends here
--- a/lisp/cl/cl-macs.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2761 +0,0 @@ -;;; cl-macs.el --- Common Lisp extensions for GNU Emacs Lisp (part four) - -;; Copyright (C) 1993 Free Software Foundation, Inc. - -;; Author: Dave Gillespie <daveg@synaptics.com> -;; Version: 2.02 -;; Keywords: extensions - -;; 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.34. - -;;; Commentary: - -;; These are extensions to Emacs Lisp that provide a degree of -;; Common Lisp compatibility, beyond what is already built-in -;; in Emacs Lisp. -;; -;; This package was written by Dave Gillespie; it is a complete -;; rewrite of Cesar Quiroz's original cl.el package of December 1986. -;; -;; This package works with Emacs 18, Emacs 19, and Lucid Emacs 19. -;; -;; Bug reports, comments, and suggestions are welcome! - -;; This file contains the portions of the Common Lisp extensions -;; package which should be autoloaded, but need only be present -;; if the compiler or interpreter is used---this file is not -;; necessary for executing compiled code. - -;; See cl.el for Change Log. - - -;;; Code: - -(or (memq 'cl-19 features) - (error "Tried to load `cl-macs' before `cl'!")) - - -;;; We define these here so that this file can compile without having -;;; loaded the cl.el file already. - -(defmacro cl-push (x place) (list 'setq place (list 'cons x place))) -(defmacro cl-pop (place) - (list 'car (list 'prog1 place (list 'setq place (list 'cdr place))))) -(defmacro cl-pop2 (place) - (list 'prog1 (list 'car (list 'cdr place)) - (list 'setq place (list 'cdr (list 'cdr place))))) -(put 'cl-push 'edebug-form-spec 'edebug-sexps) -(put 'cl-pop 'edebug-form-spec 'edebug-sexps) -(put 'cl-pop2 'edebug-form-spec 'edebug-sexps) - -(defvar cl-emacs-type) -(defvar cl-optimize-safety) -(defvar cl-optimize-speed) - - -;;; This kludge allows macros which use cl-transform-function-property -;;; to be called at compile-time. - -(require - (progn - (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))))))) - (car (or features (setq features (list 'cl-kludge)))))) - - -;;; Initialization. - -(defvar cl-old-bc-file-form nil) - -;; Patch broken Emacs 18 compiler (re top-level macros). -;; Emacs 19 compiler doesn't need this patch. -;; Also, undo broken definition of `eql' that uses same bytecode as `eq'. - -;;;###autoload -(defun cl-compile-time-init () - (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)))))) - (put 'eql 'byte-compile 'cl-byte-compile-compiler-macro) - (run-hooks 'cl-hack-bytecomp-hook)) - - -;;; Symbols. - -(defvar *gensym-counter*) - -;;;###autoload -(defun gensym (&optional arg) - "Generate a new uninterned symbol. -The name is made by appending a number to PREFIX, default \"G\"." - (let ((prefix (if (stringp arg) arg "G")) - (num (if (integerp arg) arg - (prog1 *gensym-counter* - (setq *gensym-counter* (1+ *gensym-counter*)))))) - (make-symbol (format "%s%d" prefix num)))) - -;;;###autoload -(defun gentemp (&optional arg) - "Generate a new interned symbol with a unique name. -The name is made by appending a number to PREFIX, default \"G\"." - (let ((prefix (if (stringp arg) arg "G")) - name) - (while (intern-soft (setq name (format "%s%d" prefix *gensym-counter*))) - (setq *gensym-counter* (1+ *gensym-counter*))) - (intern name))) - - -;;; Program structure. - -;;;###autoload -(defmacro defun* (name args &rest body) - "(defun* NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function. -Like normal `defun', except ARGLIST allows full Common Lisp conventions, -and BODY is implicitly surrounded by (block NAME ...)." - (let* ((res (cl-transform-lambda (cons args body) name)) - (form (list* 'defun name (cdr res)))) - (if (car res) (list 'progn (car res) form) form))) - -;;;###autoload -(defmacro defmacro* (name args &rest body) - "(defmacro* NAME ARGLIST [DOCSTRING] BODY...): define NAME as a macro. -Like normal `defmacro', except ARGLIST allows full Common Lisp conventions, -and BODY is implicitly surrounded by (block NAME ...)." - (let* ((res (cl-transform-lambda (cons args body) name)) - (form (list* 'defmacro name (cdr res)))) - (if (car res) (list 'progn (car res) form) form))) - -;;;###autoload -(defmacro function* (func) - "(function* SYMBOL-OR-LAMBDA): introduce a function. -Like normal `function', except that if argument is a lambda form, its -ARGLIST allows full Common Lisp conventions." - (if (eq (car-safe func) 'lambda) - (let* ((res (cl-transform-lambda (cdr func) 'cl-none)) - (form (list 'function (cons 'lambda (cdr res))))) - (if (car res) (list 'progn (car res) form) form)) - (list 'function func))) - -(defun cl-transform-function-property (func prop form) - (let ((res (cl-transform-lambda form func))) - (append '(progn) (cdr (cdr (car res))) - (list (list 'put (list 'quote func) (list 'quote prop) - (list 'function (cons 'lambda (cdr res)))))))) - -(defconst lambda-list-keywords - '(&optional &rest &key &allow-other-keys &aux &whole &body &environment)) - -(defvar cl-macro-environment nil) -(defvar bind-block) (defvar bind-defs) (defvar bind-enquote) -(defvar bind-inits) (defvar bind-lets) (defvar bind-forms) - -(defun cl-transform-lambda (form bind-block) - (let* ((args (car form)) (body (cdr form)) - (bind-defs nil) (bind-enquote nil) - (bind-inits nil) (bind-lets nil) (bind-forms nil) - (header nil) (simple-args nil)) - (while (or (stringp (car body)) (eq (car-safe (car body)) 'interactive)) - (cl-push (cl-pop body) header)) - (setq args (if (listp args) (copy-list args) (list '&rest args))) - (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p))))) - (if (setq bind-defs (cadr (memq '&cl-defs args))) - (setq args (delq '&cl-defs (delq bind-defs args)) - bind-defs (cadr bind-defs))) - (if (setq bind-enquote (memq '&cl-quote args)) - (setq args (delq '&cl-quote args))) - (if (memq '&whole args) (error "&whole not currently implemented")) - (let* ((p (memq '&environment args)) (v (cadr p))) - (if p (setq args (nconc (delq (car p) (delq v args)) - (list '&aux (list v 'cl-macro-environment)))))) - (while (and args (symbolp (car args)) - (not (memq (car args) '(nil &rest &body &key &aux))) - (not (and (eq (car args) '&optional) - (or bind-defs (consp (cadr args)))))) - (cl-push (cl-pop args) simple-args)) - (or (eq bind-block 'cl-none) - (setq body (list (list* 'block bind-block body)))) - (if (null args) - (list* nil (nreverse simple-args) (nconc (nreverse header) body)) - (if (memq '&optional simple-args) (cl-push '&optional args)) - (cl-do-arglist args nil (- (length simple-args) - (if (memq '&optional simple-args) 1 0))) - (setq bind-lets (nreverse bind-lets)) - (list* (and bind-inits (list* 'eval-when '(compile load eval) - (nreverse bind-inits))) - (nconc (nreverse simple-args) - (list '&rest (car (cl-pop bind-lets)))) - (nconc (nreverse header) - (list (nconc (list 'let* bind-lets) - (nreverse bind-forms) body))))))) - -(defun cl-do-arglist (args expr &optional num) ; uses bind-* - (if (nlistp args) - (if (or (memq args lambda-list-keywords) (not (symbolp args))) - (error "Invalid argument name: %s" args) - (cl-push (list args expr) bind-lets)) - (setq args (copy-list args)) - (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p))))) - (let ((p (memq '&body args))) (if p (setcar p '&rest))) - (if (memq '&environment args) (error "&environment used incorrectly")) - (let ((save-args args) - (restarg (memq '&rest args)) - (safety (if (cl-compiling-file) cl-optimize-safety 3)) - (keys nil) - (laterarg nil) (exactarg nil) minarg) - (or num (setq num 0)) - (if (listp (cadr restarg)) - (setq restarg (gensym "--rest--")) - (setq restarg (cadr restarg))) - (cl-push (list restarg expr) bind-lets) - (if (eq (car args) '&whole) - (cl-push (list (cl-pop2 args) restarg) bind-lets)) - (let ((p args)) - (setq minarg restarg) - (while (and p (not (memq (car p) lambda-list-keywords))) - (or (eq p args) (setq minarg (list 'cdr minarg))) - (setq p (cdr p))) - (if (memq (car p) '(nil &aux)) - (setq minarg (list '= (list 'length restarg) - (length (ldiff args p))) - exactarg (not (eq args p))))) - (while (and args (not (memq (car args) lambda-list-keywords))) - (let ((poparg (list (if (or (cdr args) (not exactarg)) 'pop 'car) - restarg))) - (cl-do-arglist - (cl-pop args) - (if (or laterarg (= safety 0)) poparg - (list 'if minarg poparg - (list 'signal '(quote wrong-number-of-arguments) - (list 'list (and (not (eq bind-block 'cl-none)) - (list 'quote bind-block)) - (list 'length restarg))))))) - (setq num (1+ num) laterarg t)) - (while (and (eq (car args) '&optional) (cl-pop args)) - (while (and args (not (memq (car args) lambda-list-keywords))) - (let ((arg (cl-pop args))) - (or (consp arg) (setq arg (list arg))) - (if (cddr arg) (cl-do-arglist (nth 2 arg) (list 'and restarg t))) - (let ((def (if (cdr arg) (nth 1 arg) - (or (car bind-defs) - (nth 1 (assq (car arg) bind-defs))))) - (poparg (list 'pop restarg))) - (and def bind-enquote (setq def (list 'quote def))) - (cl-do-arglist (car arg) - (if def (list 'if restarg poparg def) poparg)) - (setq num (1+ num)))))) - (if (eq (car args) '&rest) - (let ((arg (cl-pop2 args))) - (if (consp arg) (cl-do-arglist arg restarg))) - (or (eq (car args) '&key) (= safety 0) exactarg - (cl-push (list 'if restarg - (list 'signal '(quote wrong-number-of-arguments) - (list 'list - (and (not (eq bind-block 'cl-none)) - (list 'quote bind-block)) - (list '+ num (list 'length restarg))))) - bind-forms))) - (while (and (eq (car args) '&key) (cl-pop args)) - (while (and args (not (memq (car args) lambda-list-keywords))) - (let ((arg (cl-pop args))) - (or (consp arg) (setq arg (list arg))) - (let* ((karg (if (consp (car arg)) (caar arg) - (intern (format ":%s" (car arg))))) - (varg (if (consp (car arg)) (cadar arg) (car arg))) - (def (if (cdr arg) (cadr arg) - (or (car bind-defs) (cadr (assq varg bind-defs))))) - (look (list 'memq (list 'quote karg) restarg))) - (and def bind-enquote (setq def (list 'quote def))) - (if (cddr arg) - (let* ((temp (or (nth 2 arg) (gensym))) - (val (list 'car (list 'cdr temp)))) - (cl-do-arglist temp look) - (cl-do-arglist varg - (list 'if temp - (list 'prog1 val (list 'setq temp t)) - def))) - (cl-do-arglist - varg - (list 'car - (list 'cdr - (if (null def) - look - (list 'or look - (if (eq (cl-const-expr-p def) t) - (list - 'quote - (list nil (cl-const-expr-val def))) - (list 'list nil def)))))))) - (cl-push karg keys) - (if (= (aref (symbol-name karg) 0) ?:) - (progn (set karg karg) - (cl-push (list 'setq karg (list 'quote karg)) - bind-inits))))))) - (setq keys (nreverse keys)) - (or (and (eq (car args) '&allow-other-keys) (cl-pop args)) - (null keys) (= safety 0) - (let* ((var (gensym "--keys--")) - (allow '(:allow-other-keys)) - (check (list - 'while var - (list - 'cond - (list (list 'memq (list 'car var) - (list 'quote (append keys allow))) - (list 'setq var (list 'cdr (list 'cdr var)))) - (list (list 'car - (list 'cdr - (list 'memq (cons 'quote allow) - restarg))) - (list 'setq var nil)) - (list t - (list - 'error - (format "Keyword argument %%s not one of %s" - keys) - (list 'car var))))))) - (cl-push (list 'let (list (list var restarg)) check) bind-forms))) - (while (and (eq (car args) '&aux) (cl-pop args)) - (while (and args (not (memq (car args) lambda-list-keywords))) - (if (consp (car args)) - (if (and bind-enquote (cadar args)) - (cl-do-arglist (caar args) - (list 'quote (cadr (cl-pop args)))) - (cl-do-arglist (caar args) (cadr (cl-pop args)))) - (cl-do-arglist (cl-pop args) nil)))) - (if args (error "Malformed argument list %s" save-args))))) - -(defun cl-arglist-args (args) - (if (nlistp args) (list args) - (let ((res nil) (kind nil) arg) - (while (consp args) - (setq arg (cl-pop args)) - (if (memq arg lambda-list-keywords) (setq kind arg) - (if (eq arg '&cl-defs) (cl-pop args) - (and (consp arg) kind (setq arg (car arg))) - (and (consp arg) (cdr arg) (eq kind '&key) (setq arg (cadr arg))) - (setq res (nconc res (cl-arglist-args arg)))))) - (nconc res (and args (list args)))))) - -;;;###autoload -(defmacro destructuring-bind (args expr &rest body) - (let* ((bind-lets nil) (bind-forms nil) (bind-inits nil) - (bind-defs nil) (bind-block 'cl-none)) - (cl-do-arglist (or args '(&aux)) expr) - (append '(progn) bind-inits - (list (nconc (list 'let* (nreverse bind-lets)) - (nreverse bind-forms) body))))) - - -;;; The `eval-when' form. - -(defvar cl-not-toplevel nil) - -;;;###autoload -(defmacro eval-when (when &rest body) - "(eval-when (WHEN...) BODY...): control when BODY is evaluated. -If `compile' is in WHEN, BODY is evaluated when compiled at top-level. -If `load' is in WHEN, BODY is evaluated when loaded after top-level compile. -If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level." - (if (and (fboundp 'cl-compiling-file) (cl-compiling-file) - (not cl-not-toplevel) (not (boundp 'for-effect))) ; horrible kludge - (let ((comp (or (memq 'compile when) (memq ':compile-toplevel when))) - (cl-not-toplevel t)) - (if (or (memq 'load when) (memq ':load-toplevel when)) - (if comp (cons 'progn (mapcar 'cl-compile-time-too body)) - (list* 'if nil nil body)) - (progn (if comp (eval (cons 'progn body))) nil))) - (and (or (memq 'eval when) (memq ':execute when)) - (cons 'progn body)))) - -(defun cl-compile-time-too (form) - (or (and (symbolp (car-safe form)) (get (car-safe form) 'byte-hunk-handler)) - (setq form (macroexpand - form (cons '(eval-when) byte-compile-macro-environment)))) - (cond ((eq (car-safe form) 'progn) - (cons 'progn (mapcar 'cl-compile-time-too (cdr form)))) - ((eq (car-safe form) 'eval-when) - (let ((when (nth 1 form))) - (if (or (memq 'eval when) (memq ':execute when)) - (list* 'eval-when (cons 'compile when) (cddr form)) - form))) - (t (eval form) form))) - -(or (and (fboundp 'eval-when-compile) - (not (eq (car-safe (symbol-function 'eval-when-compile)) 'autoload))) - (eval '(defmacro eval-when-compile (&rest body) - "Like `progn', but evaluates the body at compile time. -The result of the body appears to the compiler as a quoted constant." - (list 'quote (eval (cons 'progn body)))))) - -;;;###autoload -(defmacro load-time-value (form &optional read-only) - "Like `progn', but evaluates the body at load time. -The result of the body appears to the compiler as a quoted constant." - (if (cl-compiling-file) - (let* ((temp (gentemp "--cl-load-time--")) - (set (list 'set (list 'quote temp) form))) - (if (and (fboundp 'byte-compile-file-form-defmumble) - (boundp 'this-kind) (boundp 'that-one)) - (fset 'byte-compile-file-form - (list 'lambda '(form) - (list 'fset '(quote byte-compile-file-form) - (list 'quote - (symbol-function 'byte-compile-file-form))) - (list 'byte-compile-file-form (list 'quote set)) - '(byte-compile-file-form form))) - ;; XEmacs change - (print set (symbol-value ;;'outbuffer - 'byte-compile-output-buffer - ))) - (list 'symbol-value (list 'quote temp))) - (list 'quote (eval form)))) - - -;;; Conditional control structures. - -;;;###autoload -(defmacro case (expr &rest clauses) - "(case EXPR CLAUSES...): evals EXPR, chooses from CLAUSES on that value. -Each clause looks like (KEYLIST BODY...). EXPR is evaluated and compared -against each key in each KEYLIST; the corresponding BODY is evaluated. -If no clause succeeds, case returns nil. A single atom may be used in -place of a KEYLIST of one atom. A KEYLIST of `t' or `otherwise' is -allowed only in the final clause, and matches if no other keys match. -Key values are compared by `eql'." - (let* ((temp (if (cl-simple-expr-p expr 3) expr (gensym))) - (head-list nil) - (body (cons - 'cond - (mapcar - (function - (lambda (c) - (cons (cond ((memq (car c) '(t otherwise)) 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)))) - -;;;###autoload -(defmacro ecase (expr &rest clauses) - "(ecase EXPR CLAUSES...): like `case', but error if no case fits. -`otherwise'-clauses are not allowed." - (list* 'case expr (append clauses '((ecase-error-flag))))) - -;;;###autoload -(defmacro typecase (expr &rest clauses) - "(typecase EXPR CLAUSES...): evals EXPR, chooses from CLAUSES on that value. -Each clause looks like (TYPE BODY...). EXPR is evaluated and, if it -satisfies TYPE, the corresponding BODY is evaluated. If no clause succeeds, -typecase returns nil. A TYPE of `t' or `otherwise' is allowed only in the -final clause, and matches if no other keys match." - (let* ((temp (if (cl-simple-expr-p expr 3) expr (gensym))) - (type-list nil) - (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))))) - clauses)))) - (if (eq temp expr) body - (list 'let (list (list temp expr)) body)))) - -;;;###autoload -(defmacro etypecase (expr &rest clauses) - "(etypecase EXPR CLAUSES...): like `typecase', but error if no case fits. -`otherwise'-clauses are not allowed." - (list* 'typecase expr (append clauses '((ecase-error-flag))))) - - -;;; Blocks and exits. - -;;;###autoload -(defmacro block (name &rest body) - "(block NAME BODY...): define a lexically-scoped block named NAME. -NAME may be any symbol. Code inside the BODY forms can call `return-from' -to jump prematurely out of the block. This differs from `catch' and `throw' -in two respects: First, the NAME is an unevaluated symbol rather than a -quoted symbol or other form; and second, NAME is lexically rather than -dynamically scoped: Only references to it within BODY will work. These -references may appear inside macro expansions, but not inside functions -called from BODY." - (if (cl-safe-expr-p (cons 'progn body)) (cons 'progn body) - (list 'cl-block-wrapper - (list* 'catch (list 'quote (intern (format "--cl-block-%s--" name))) - body)))) - -(defvar cl-active-block-names nil) - -(put 'cl-block-wrapper 'byte-compile 'cl-byte-compile-block) -(defun cl-byte-compile-block (cl-form) - (if (fboundp 'byte-compile-form-do-effect) ; Check for optimizing compiler - (progn - (let* ((cl-entry (cons (nth 1 (nth 1 (nth 1 cl-form))) nil)) - (cl-active-block-names (cons cl-entry cl-active-block-names)) - (cl-body (byte-compile-top-level - (cons 'progn (cddr (nth 1 cl-form)))))) - (if (cdr cl-entry) - (byte-compile-form (list 'catch (nth 1 (nth 1 cl-form)) cl-body)) - (byte-compile-form cl-body)))) - (byte-compile-form (nth 1 cl-form)))) - -(put 'cl-block-throw 'byte-compile 'cl-byte-compile-throw) -(defun cl-byte-compile-throw (cl-form) - (let ((cl-found (assq (nth 1 (nth 1 cl-form)) cl-active-block-names))) - (if cl-found (setcdr cl-found t))) - (byte-compile-normal-call (cons 'throw (cdr cl-form)))) - -;;;###autoload -(defmacro return (&optional res) - "(return [RESULT]): return from the block named nil. -This is equivalent to `(return-from nil RESULT)'." - (list 'return-from nil res)) - -;;;###autoload -(defmacro return-from (name &optional res) - "(return-from NAME [RESULT]): return from the block named NAME. -This jump out to the innermost enclosing `(block NAME ...)' form, -returning RESULT from that form (or nil if RESULT is omitted). -This is compatible with Common Lisp, but note that `defun' and -`defmacro' do not create implicit blocks as they do in Common Lisp." - (let ((name2 (intern (format "--cl-block-%s--" name)))) - (list 'cl-block-throw (list 'quote name2) res))) - - -;;; The "loop" macro. - -(defvar args) (defvar loop-accum-var) (defvar loop-accum-vars) -(defvar loop-bindings) (defvar loop-body) (defvar loop-destr-temps) -(defvar loop-finally) (defvar loop-finish-flag) (defvar loop-first-flag) -(defvar loop-initially) (defvar loop-map-form) (defvar loop-name) -(defvar loop-result) (defvar loop-result-explicit) -(defvar loop-result-var) (defvar loop-steps) (defvar loop-symbol-macs) - -;;;###autoload -(defmacro loop (&rest args) - "(loop CLAUSE...): The Common Lisp `loop' macro. -Valid clauses are: - for VAR from/upfrom/downfrom NUM to/upto/downto/above/below NUM by NUM, - for VAR in LIST by FUNC, for VAR on LIST by FUNC, for VAR = INIT then EXPR, - for VAR across ARRAY, repeat NUM, with VAR = INIT, while COND, until COND, - always COND, never COND, thereis COND, collect EXPR into VAR, - append EXPR into VAR, nconc EXPR into VAR, sum EXPR into VAR, - count EXPR into VAR, maximize EXPR into VAR, minimize EXPR into VAR, - if COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...], - unless COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...], - do EXPRS..., initially EXPRS..., finally EXPRS..., return EXPR, - finally return EXPR, named NAME." - (if (not (memq t (mapcar 'symbolp (delq nil (delq t (copy-list args)))))) - (list 'block nil (list* 'while t args)) - (let ((loop-name nil) (loop-bindings nil) - (loop-body nil) (loop-steps nil) - (loop-result nil) (loop-result-explicit nil) - (loop-result-var nil) (loop-finish-flag nil) - (loop-accum-var nil) (loop-accum-vars nil) - (loop-initially nil) (loop-finally nil) - (loop-map-form nil) (loop-first-flag nil) - (loop-destr-temps nil) (loop-symbol-macs nil)) - (setq args (append args '(cl-end-loop))) - (while (not (eq (car args) 'cl-end-loop)) (cl-parse-loop-clause)) - (if loop-finish-flag - (cl-push (list (list loop-finish-flag t)) loop-bindings)) - (if loop-first-flag - (progn (cl-push (list (list loop-first-flag t)) loop-bindings) - (cl-push (list 'setq loop-first-flag nil) loop-steps))) - (let* ((epilogue (nconc (nreverse loop-finally) - (list (or loop-result-explicit loop-result)))) - (ands (cl-loop-build-ands (nreverse loop-body))) - (while-body (nconc (cadr ands) (nreverse loop-steps))) - (body (append - (nreverse loop-initially) - (list (if loop-map-form - (list 'block '--cl-finish-- - (subst - (if (eq (car ands) t) while-body - (cons (list 'or (car ands) - '(return-from --cl-finish-- - nil)) - while-body)) - '--cl-map loop-map-form)) - (list* 'while (car ands) while-body))) - (if loop-finish-flag - (if (equal epilogue '(nil)) (list loop-result-var) - (list (list 'if loop-finish-flag - (cons 'progn epilogue) loop-result-var))) - epilogue)))) - (if loop-result-var (cl-push (list loop-result-var) loop-bindings)) - (while loop-bindings - (if (cdar loop-bindings) - (setq body (list (cl-loop-let (cl-pop loop-bindings) body t))) - (let ((lets nil)) - (while (and loop-bindings - (not (cdar loop-bindings))) - (cl-push (car (cl-pop loop-bindings)) lets)) - (setq body (list (cl-loop-let lets body nil)))))) - (if loop-symbol-macs - (setq body (list (list* 'symbol-macrolet loop-symbol-macs body)))) - (list* 'block loop-name body))))) - -(defun cl-parse-loop-clause () ; uses args, loop-* - (let ((word (cl-pop args)) - (hash-types '(hash-key hash-keys hash-value hash-values)) - (key-types '(key-code key-codes key-seq key-seqs - key-binding key-bindings))) - (cond - - ((null args) - (error "Malformed `loop' macro")) - - ((eq word 'named) - (setq loop-name (cl-pop args))) - - ((eq word 'initially) - (if (memq (car args) '(do doing)) (cl-pop args)) - (or (consp (car args)) (error "Syntax error on `initially' clause")) - (while (consp (car args)) - (cl-push (cl-pop args) loop-initially))) - - ((eq word 'finally) - (if (eq (car args) 'return) - (setq loop-result-explicit (or (cl-pop2 args) '(quote nil))) - (if (memq (car args) '(do doing)) (cl-pop args)) - (or (consp (car args)) (error "Syntax error on `finally' clause")) - (if (and (eq (caar args) 'return) (null loop-name)) - (setq loop-result-explicit (or (nth 1 (cl-pop args)) '(quote nil))) - (while (consp (car args)) - (cl-push (cl-pop args) loop-finally))))) - - ((memq word '(for as)) - (let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil) - (ands nil)) - (while - (let ((var (or (cl-pop args) (gensym)))) - (setq word (cl-pop args)) - (if (eq word 'being) (setq word (cl-pop args))) - (if (memq word '(the each)) (setq word (cl-pop args))) - (if (memq word '(buffer buffers)) - (setq word 'in args (cons '(buffer-list) args))) - (cond - - ((memq word '(from downfrom upfrom to downto upto - above below by)) - (cl-push word args) - (if (memq (car args) '(downto above)) - (error "Must specify `from' value for downward loop")) - (let* ((down (or (eq (car args) 'downfrom) - (memq (caddr args) '(downto above)))) - (excl (or (memq (car args) '(above below)) - (memq (caddr args) '(above below)))) - (start (and (memq (car args) '(from upfrom downfrom)) - (cl-pop2 args))) - (end (and (memq (car args) - '(to upto downto above below)) - (cl-pop2 args))) - (step (and (eq (car args) 'by) (cl-pop2 args))) - (end-var (and (not (cl-const-expr-p end)) (gensym))) - (step-var (and (not (cl-const-expr-p step)) - (gensym)))) - (and step (numberp step) (<= step 0) - (error "Loop `by' value is not positive: %s" step)) - (cl-push (list var (or start 0)) loop-for-bindings) - (if end-var (cl-push (list end-var end) loop-for-bindings)) - (if step-var (cl-push (list step-var step) - loop-for-bindings)) - (if end - (cl-push (list - (if down (if excl '> '>=) (if excl '< '<=)) - var (or end-var end)) loop-body)) - (cl-push (list var (list (if down '- '+) var - (or step-var step 1))) - loop-for-steps))) - - ((memq word '(in in-ref on)) - (let* ((on (eq word 'on)) - (temp (if (and on (symbolp var)) var (gensym)))) - (cl-push (list temp (cl-pop args)) loop-for-bindings) - (cl-push (list 'consp temp) loop-body) - (if (eq word 'in-ref) - (cl-push (list var (list 'car temp)) loop-symbol-macs) - (or (eq temp var) - (progn - (cl-push (list var nil) loop-for-bindings) - (cl-push (list var (if on temp (list 'car temp))) - loop-for-sets)))) - (cl-push (list temp - (if (eq (car args) 'by) - (let ((step (cl-pop2 args))) - (if (and (memq (car-safe step) - '(quote function - function*)) - (symbolp (nth 1 step))) - (list (nth 1 step) temp) - (list 'funcall step temp))) - (list 'cdr temp))) - loop-for-steps))) - - ((eq word '=) - (let* ((start (cl-pop args)) - (then (if (eq (car args) 'then) (cl-pop2 args) start))) - (cl-push (list var nil) loop-for-bindings) - (if (or ands (eq (car args) 'and)) - (progn - (cl-push (list var - (list 'if - (or loop-first-flag - (setq loop-first-flag - (gensym))) - start var)) - loop-for-sets) - (cl-push (list var then) loop-for-steps)) - (cl-push (list var - (if (eq start then) start - (list 'if - (or loop-first-flag - (setq loop-first-flag (gensym))) - start then))) - loop-for-sets)))) - - ((memq word '(across across-ref)) - (let ((temp-vec (gensym)) (temp-idx (gensym))) - (cl-push (list temp-vec (cl-pop args)) loop-for-bindings) - (cl-push (list temp-idx -1) loop-for-bindings) - (cl-push (list '< (list 'setq temp-idx (list '1+ temp-idx)) - (list 'length temp-vec)) loop-body) - (if (eq word 'across-ref) - (cl-push (list var (list 'aref temp-vec temp-idx)) - loop-symbol-macs) - (cl-push (list var nil) loop-for-bindings) - (cl-push (list var (list 'aref temp-vec temp-idx)) - loop-for-sets)))) - - ((memq word '(element elements)) - (let ((ref (or (memq (car args) '(in-ref of-ref)) - (and (not (memq (car args) '(in of))) - (error "Expected `of'")))) - (seq (cl-pop2 args)) - (temp-seq (gensym)) - (temp-idx (if (eq (car args) 'using) - (if (and (= (length (cadr args)) 2) - (eq (caadr args) 'index)) - (cadr (cl-pop2 args)) - (error "Bad `using' clause")) - (gensym)))) - (cl-push (list temp-seq seq) loop-for-bindings) - (cl-push (list temp-idx 0) loop-for-bindings) - (if ref - (let ((temp-len (gensym))) - (cl-push (list temp-len (list 'length temp-seq)) - loop-for-bindings) - (cl-push (list var (list 'elt temp-seq temp-idx)) - loop-symbol-macs) - (cl-push (list '< temp-idx temp-len) loop-body)) - (cl-push (list var nil) loop-for-bindings) - (cl-push (list 'and temp-seq - (list 'or (list 'consp temp-seq) - (list '< temp-idx - (list 'length temp-seq)))) - loop-body) - (cl-push (list var (list 'if (list 'consp temp-seq) - (list 'pop temp-seq) - (list 'aref temp-seq temp-idx))) - loop-for-sets)) - (cl-push (list temp-idx (list '1+ temp-idx)) - loop-for-steps))) - - ((memq word hash-types) - (or (memq (car args) '(in of)) (error "Expected `of'")) - (let* ((table (cl-pop2 args)) - (other (if (eq (car args) 'using) - (if (and (= (length (cadr args)) 2) - (memq (caadr args) hash-types) - (not (eq (caadr args) word))) - (cadr (cl-pop2 args)) - (error "Bad `using' clause")) - (gensym)))) - (if (memq word '(hash-value hash-values)) - (setq var (prog1 other (setq other var)))) - (setq loop-map-form - (list 'maphash (list 'function - (list* 'lambda (list var other) - '--cl-map)) table)))) - - ((memq word '(symbol present-symbol external-symbol - symbols present-symbols external-symbols)) - (let ((ob (and (memq (car args) '(in of)) (cl-pop2 args)))) - (setq loop-map-form - (list 'mapatoms (list 'function - (list* 'lambda (list var) - '--cl-map)) ob)))) - - ((memq word '(overlay overlays extent extents)) - (let ((buf nil) (from nil) (to nil)) - (while (memq (car args) '(in of from to)) - (cond ((eq (car args) 'from) (setq from (cl-pop2 args))) - ((eq (car args) 'to) (setq to (cl-pop2 args))) - (t (setq buf (cl-pop2 args))))) - (setq loop-map-form - (list 'cl-map-extents - (list 'function (list 'lambda (list var (gensym)) - '(progn . --cl-map) nil)) - buf from to)))) - - ((memq word '(interval intervals)) - (let ((buf nil) (prop nil) (from nil) (to nil) - (var1 (gensym)) (var2 (gensym))) - (while (memq (car args) '(in of property from to)) - (cond ((eq (car args) 'from) (setq from (cl-pop2 args))) - ((eq (car args) 'to) (setq to (cl-pop2 args))) - ((eq (car args) 'property) - (setq prop (cl-pop2 args))) - (t (setq buf (cl-pop2 args))))) - (if (and (consp var) (symbolp (car var)) (symbolp (cdr var))) - (setq var1 (car var) var2 (cdr var)) - (cl-push (list var (list 'cons var1 var2)) loop-for-sets)) - (setq loop-map-form - (list 'cl-map-intervals - (list 'function (list 'lambda (list var1 var2) - '(progn . --cl-map))) - buf prop from to)))) - - ((memq word key-types) - (or (memq (car args) '(in of)) (error "Expected `of'")) - (let ((map (cl-pop2 args)) - (other (if (eq (car args) 'using) - (if (and (= (length (cadr args)) 2) - (memq (caadr args) key-types) - (not (eq (caadr args) word))) - (cadr (cl-pop2 args)) - (error "Bad `using' clause")) - (gensym)))) - (if (memq word '(key-binding key-bindings)) - (setq var (prog1 other (setq other var)))) - (setq loop-map-form - (list (if (memq word '(key-seq key-seqs)) - 'cl-map-keymap-recursively 'cl-map-keymap) - (list 'function (list* 'lambda (list var other) - '--cl-map)) map)))) - - ((memq word '(frame frames screen screens)) - (let ((temp (gensym))) - (cl-push (list var (if (eq cl-emacs-type 'lucid) - '(selected-screen) '(selected-frame))) - loop-for-bindings) - (cl-push (list temp nil) loop-for-bindings) - (cl-push (list 'prog1 (list 'not (list 'eq var temp)) - (list 'or temp (list 'setq temp var))) - loop-body) - (cl-push (list var (list (if (eq cl-emacs-type 'lucid) - 'next-screen 'next-frame) var)) - loop-for-steps))) - - ((memq word '(window windows)) - (let ((scr (and (memq (car args) '(in of)) (cl-pop2 args))) - (temp (gensym))) - (cl-push (list var (if scr - (list (if (eq cl-emacs-type 'lucid) - 'screen-selected-window - 'frame-selected-window) scr) - '(selected-window))) - loop-for-bindings) - (cl-push (list temp nil) loop-for-bindings) - (cl-push (list 'prog1 (list 'not (list 'eq var temp)) - (list 'or temp (list 'setq temp var))) - loop-body) - (cl-push (list var (list 'next-window var)) loop-for-steps))) - - (t - (let ((handler (and (symbolp word) - (get word 'cl-loop-for-handler)))) - (if handler - (funcall handler var) - (error "Expected a `for' preposition, found %s" word))))) - (eq (car args) 'and)) - (setq ands t) - (cl-pop args)) - (if (and ands loop-for-bindings) - (cl-push (nreverse loop-for-bindings) loop-bindings) - (setq loop-bindings (nconc (mapcar 'list loop-for-bindings) - loop-bindings))) - (if loop-for-sets - (cl-push (list 'progn - (cl-loop-let (nreverse loop-for-sets) 'setq ands) - t) loop-body)) - (if loop-for-steps - (cl-push (cons (if ands 'psetq 'setq) - (apply 'append (nreverse loop-for-steps))) - loop-steps)))) - - ((eq word 'repeat) - (let ((temp (gensym))) - (cl-push (list (list temp (cl-pop args))) loop-bindings) - (cl-push (list '>= (list 'setq temp (list '1- temp)) 0) loop-body))) - - ((eq word 'collect) - (let ((what (cl-pop args)) - (var (cl-loop-handle-accum nil 'nreverse))) - (if (eq var loop-accum-var) - (cl-push (list 'progn (list 'push what var) t) loop-body) - (cl-push (list 'progn - (list 'setq var (list 'nconc var (list 'list what))) - t) loop-body)))) - - ((memq word '(nconc nconcing append appending)) - (let ((what (cl-pop args)) - (var (cl-loop-handle-accum nil 'nreverse))) - (cl-push (list 'progn - (list 'setq var - (if (eq var loop-accum-var) - (list 'nconc - (list (if (memq word '(nconc nconcing)) - 'nreverse 'reverse) - what) - var) - (list (if (memq word '(nconc nconcing)) - 'nconc 'append) - var what))) t) loop-body))) - - ((memq word '(concat concating)) - (let ((what (cl-pop args)) - (var (cl-loop-handle-accum ""))) - (cl-push (list 'progn (list 'callf 'concat var what) t) loop-body))) - - ((memq word '(vconcat vconcating)) - (let ((what (cl-pop args)) - (var (cl-loop-handle-accum []))) - (cl-push (list 'progn (list 'callf 'vconcat var what) t) loop-body))) - - ((memq word '(sum summing)) - (let ((what (cl-pop args)) - (var (cl-loop-handle-accum 0))) - (cl-push (list 'progn (list 'incf var what) t) loop-body))) - - ((memq word '(count counting)) - (let ((what (cl-pop args)) - (var (cl-loop-handle-accum 0))) - (cl-push (list 'progn (list 'if what (list 'incf var)) t) loop-body))) - - ((memq word '(minimize minimizing maximize maximizing)) - (let* ((what (cl-pop args)) - (temp (if (cl-simple-expr-p what) what (gensym))) - (var (cl-loop-handle-accum nil)) - (func (intern (substring (symbol-name word) 0 3))) - (set (list 'setq var (list 'if var (list func var temp) temp)))) - (cl-push (list 'progn (if (eq temp what) set - (list 'let (list (list temp what)) set)) - t) loop-body))) - - ((eq word 'with) - (let ((bindings nil)) - (while (progn (cl-push (list (cl-pop args) - (and (eq (car args) '=) (cl-pop2 args))) - bindings) - (eq (car args) 'and)) - (cl-pop args)) - (cl-push (nreverse bindings) loop-bindings))) - - ((eq word 'while) - (cl-push (cl-pop args) loop-body)) - - ((eq word 'until) - (cl-push (list 'not (cl-pop args)) loop-body)) - - ((eq word 'always) - (or loop-finish-flag (setq loop-finish-flag (gensym))) - (cl-push (list 'setq loop-finish-flag (cl-pop args)) loop-body) - (setq loop-result t)) - - ((eq word 'never) - (or loop-finish-flag (setq loop-finish-flag (gensym))) - (cl-push (list 'setq loop-finish-flag (list 'not (cl-pop args))) - loop-body) - (setq loop-result t)) - - ((eq word 'thereis) - (or loop-finish-flag (setq loop-finish-flag (gensym))) - (or loop-result-var (setq loop-result-var (gensym))) - (cl-push (list 'setq loop-finish-flag - (list 'not (list 'setq loop-result-var (cl-pop args)))) - loop-body)) - - ((memq word '(if when unless)) - (let* ((cond (cl-pop args)) - (then (let ((loop-body nil)) - (cl-parse-loop-clause) - (cl-loop-build-ands (nreverse loop-body)))) - (else (let ((loop-body nil)) - (if (eq (car args) 'else) - (progn (cl-pop args) (cl-parse-loop-clause))) - (cl-loop-build-ands (nreverse loop-body)))) - (simple (and (eq (car then) t) (eq (car else) t)))) - (if (eq (car args) 'end) (cl-pop args)) - (if (eq word 'unless) (setq then (prog1 else (setq else then)))) - (let ((form (cons (if simple (cons 'progn (nth 1 then)) (nth 2 then)) - (if simple (nth 1 else) (list (nth 2 else)))))) - (if (cl-expr-contains form 'it) - (let ((temp (gensym))) - (cl-push (list temp) loop-bindings) - (setq form (list* 'if (list 'setq temp cond) - (subst temp 'it form)))) - (setq form (list* 'if cond form))) - (cl-push (if simple (list 'progn form t) form) loop-body)))) - - ((memq word '(do doing)) - (let ((body nil)) - (or (consp (car args)) (error "Syntax error on `do' clause")) - (while (consp (car args)) (cl-push (cl-pop args) body)) - (cl-push (cons 'progn (nreverse (cons t body))) loop-body))) - - ((eq word 'return) - (or loop-finish-flag (setq loop-finish-flag (gensym))) - (or loop-result-var (setq loop-result-var (gensym))) - (cl-push (list 'setq loop-result-var (cl-pop args) - loop-finish-flag nil) loop-body)) - - (t - (let ((handler (and (symbolp word) (get word 'cl-loop-handler)))) - (or handler (error "Expected a loop keyword, found %s" word)) - (funcall handler)))) - (if (eq (car args) 'and) - (progn (cl-pop args) (cl-parse-loop-clause))))) - -(defun cl-loop-let (specs body par) ; uses loop-* - (let ((p specs) (temps nil) (new nil)) - (while (and p (or (symbolp (car-safe (car p))) (null (cadar p)))) - (setq p (cdr p))) - (and par p - (progn - (setq par nil p specs) - (while p - (or (cl-const-expr-p (cadar p)) - (let ((temp (gensym))) - (cl-push (list temp (cadar p)) temps) - (setcar (cdar p) temp))) - (setq p (cdr p))))) - (while specs - (if (and (consp (car specs)) (listp (caar specs))) - (let* ((spec (caar specs)) (nspecs nil) - (expr (cadr (cl-pop specs))) - (temp (cdr (or (assq spec loop-destr-temps) - (car (cl-push (cons spec (or (last spec 0) - (gensym))) - loop-destr-temps)))))) - (cl-push (list temp expr) new) - (while (consp spec) - (cl-push (list (cl-pop spec) - (and expr (list (if spec 'pop 'car) temp))) - nspecs)) - (setq specs (nconc (nreverse nspecs) specs))) - (cl-push (cl-pop specs) new))) - (if (eq body 'setq) - (let ((set (cons (if par 'psetq 'setq) (apply 'nconc (nreverse new))))) - (if temps (list 'let* (nreverse temps) set) set)) - (list* (if par 'let 'let*) - (nconc (nreverse temps) (nreverse new)) body)))) - -(defun cl-loop-handle-accum (def &optional func) ; uses args, loop-* - (if (eq (car args) 'into) - (let ((var (cl-pop2 args))) - (or (memq var loop-accum-vars) - (progn (cl-push (list (list var def)) loop-bindings) - (cl-push var loop-accum-vars))) - var) - (or loop-accum-var - (progn - (cl-push (list (list (setq loop-accum-var (gensym)) def)) - loop-bindings) - (setq loop-result (if func (list func loop-accum-var) - loop-accum-var)) - loop-accum-var)))) - -(defun cl-loop-build-ands (clauses) - (let ((ands nil) - (body nil)) - (while clauses - (if (and (eq (car-safe (car clauses)) 'progn) - (eq (car (last (car clauses))) t)) - (if (cdr clauses) - (setq clauses (cons (nconc (butlast (car clauses)) - (if (eq (car-safe (cadr clauses)) - 'progn) - (cdadr clauses) - (list (cadr clauses)))) - (cddr clauses))) - (setq body (cdr (butlast (cl-pop clauses))))) - (cl-push (cl-pop clauses) ands))) - (setq ands (or (nreverse ands) (list t))) - (list (if (cdr ands) (cons 'and ands) (car ands)) - body - (let ((full (if body - (append ands (list (cons 'progn (append body '(t))))) - ands))) - (if (cdr full) (cons 'and full) (car full)))))) - - -;;; Other iteration control structures. - -;;;###autoload -(defmacro do (steps endtest &rest body) - "The Common Lisp `do' loop. -Format is: (do ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" - (cl-expand-do-loop steps endtest body nil)) - -;;;###autoload -(defmacro do* (steps endtest &rest body) - "The Common Lisp `do*' loop. -Format is: (do* ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" - (cl-expand-do-loop steps endtest body t)) - -(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))) - 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))))) - steps))) - (setq sets (delq nil sets)) - (and sets - (list (cons (if (or star (not (cdr sets))) - 'setq 'psetq) - (apply 'append sets))))))) - (or (cdr endtest) '(nil))))) - -;;;###autoload -(defmacro dolist (spec &rest body) - "(dolist (VAR LIST [RESULT]) BODY...): loop over a list. -Evaluate BODY with VAR bound to each `car' from LIST, in turn. -Then evaluate RESULT to get return value, default nil." - (let ((temp (gensym "--dolist-temp--"))) - (list 'block nil - (list* 'let (list (list temp (nth 1 spec)) (car spec)) - (list* 'while temp (list 'setq (car spec) (list 'car temp)) - (append body (list (list 'setq temp - (list 'cdr temp))))) - (if (cdr (cdr spec)) - (cons (list 'setq (car spec) nil) (cdr (cdr spec))) - '(nil)))))) - -;;;###autoload -(defmacro dotimes (spec &rest body) - "(dotimes (VAR COUNT [RESULT]) BODY...): loop a certain number of times. -Evaluate BODY with VAR bound to successive integers from 0, inclusive, -to COUNT, exclusive. Then evaluate RESULT to get return value, default -nil." - (let ((temp (gensym "--dotimes-temp--"))) - (list 'block nil - (list* 'let (list (list temp (nth 1 spec)) (list (car spec) 0)) - (list* 'while (list '< (car spec) temp) - (append body (list (list 'incf (car spec))))) - (or (cdr (cdr spec)) '(nil)))))) - -;;;###autoload -(defmacro do-symbols (spec &rest body) - "(dosymbols (VAR [OBARRAY [RESULT]]) BODY...): loop over all symbols. -Evaluate BODY with VAR bound to each interned symbol, or to each symbol -from OBARRAY." - ;; Apparently this doesn't have an implicit block. - (list 'block nil - (list 'let (list (car spec)) - (list* 'mapatoms - (list 'function (list* 'lambda (list (car spec)) body)) - (and (cadr spec) (list (cadr spec)))) - (caddr spec)))) - -;;;###autoload -(defmacro do-all-symbols (spec &rest body) - (list* 'do-symbols (list (car spec) nil (cadr spec)) body)) - - -;;; Assignments. - -;;;###autoload -(defmacro psetq (&rest args) - "(psetq SYM VAL SYM VAL ...): set SYMs to the values VALs in parallel. -This is like `setq', except that all VAL forms are evaluated (in order) -before assigning any symbols SYM to the corresponding values." - (cons 'psetf args)) - - -;;; Binding control structures. - -;;;###autoload -(defmacro progv (symbols values &rest body) - "(progv SYMBOLS VALUES BODY...): bind SYMBOLS to VALUES dynamically in BODY. -The forms SYMBOLS and VALUES are evaluated, and must evaluate to lists. -Each SYMBOL in the first list is bound to the corresponding VALUE in the -second list (or made unbound if VALUES is shorter than SYMBOLS); then the -BODY forms are executed and their result is returned. This is much like -a `let' form, except that the list of symbols can be computed at run-time." - (list 'let '((cl-progv-save nil)) - (list 'unwind-protect - (list* 'progn (list 'cl-progv-before symbols values) body) - '(cl-progv-after)))) - -;;; This should really have some way to shadow 'byte-compile properties, etc. -;;;###autoload -(defmacro flet (bindings &rest body) - "(flet ((FUNC ARGLIST BODY...) ...) FORM...): make temporary function defns. -This is an analogue of `let' that operates on the function cell of FUNC -rather than its value cell. The FORMs are evaluated with the specified -function definitions in place, then the definitions are undone (the FUNCs -go back to their previous definitions, or lack thereof)." - (list* 'letf* - (mapcar - (function - (lambda (x) - (if (or (and (fboundp (car x)) - (eq (car-safe (symbol-function (car x))) 'macro)) - (cdr (assq (car x) cl-macro-environment))) - (error "Use `labels', not `flet', to rebind macro names")) - (let ((func (list 'function* - (list 'lambda (cadr x) - (list* 'block (car x) (cddr x)))))) - (if (and (cl-compiling-file) - (boundp 'byte-compile-function-environment)) - (cl-push (cons (car x) (eval func)) - byte-compile-function-environment)) - (list (list 'symbol-function (list 'quote (car x))) func)))) - bindings) - body)) - -;;;###autoload -(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." - (let ((vars nil) (sets nil) (cl-macro-environment cl-macro-environment)) - (while bindings - (let ((var (gensym))) - (cl-push var vars) - (cl-push (list 'function* (cons 'lambda (cdar bindings))) sets) - (cl-push var sets) - (cl-push (list (car (cl-pop bindings)) 'lambda '(&rest cl-labels-args) - (list 'list* '(quote funcall) (list 'quote var) - 'cl-labels-args)) - cl-macro-environment))) - (cl-macroexpand-all (list* 'lexical-let vars (cons (cons 'setq sets) body)) - cl-macro-environment))) - -;; The following ought to have a better definition for use with newer -;; byte compilers. -;;;###autoload -(defmacro macrolet (bindings &rest body) - "(macrolet ((NAME ARGLIST BODY...) ...) FORM...): make temporary macro defns. -This is like `flet', but for macros instead of functions." - (if (cdr bindings) - (list 'macrolet - (list (car bindings)) (list* 'macrolet (cdr bindings) body)) - (if (null bindings) (cons 'progn body) - (let* ((name (caar bindings)) - (res (cl-transform-lambda (cdar bindings) name))) - (eval (car res)) - (cl-macroexpand-all (cons 'progn body) - (cons (list* name 'lambda (cdr res)) - cl-macro-environment)))))) - -;;;###autoload -(defmacro symbol-macrolet (bindings &rest body) - "(symbol-macrolet ((NAME EXPANSION) ...) FORM...): make symbol macro defns. -Within the body FORMs, references to the variable NAME will be replaced -by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...)." - (if (cdr bindings) - (list 'symbol-macrolet - (list (car bindings)) (list* 'symbol-macrolet (cdr bindings) body)) - (if (null bindings) (cons 'progn body) - (cl-macroexpand-all (cons 'progn body) - (cons (list (symbol-name (caar bindings)) - (cadar bindings)) - cl-macro-environment))))) - -(defvar cl-closure-vars nil) -;;;###autoload -(defmacro lexical-let (bindings &rest body) - "(lexical-let BINDINGS BODY...): like `let', but lexically scoped. -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)))) - bindings)) - (ebody - (cl-macroexpand-all - (cons 'progn body) - (nconc (mapcar (function (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))))) - vars) - ebody)) - (list 'let (mapcar (function (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)))) - vars)) - ebody)))) - -;;;###autoload -(defmacro lexical-let* (bindings &rest body) - "(lexical-let* BINDINGS BODY...): like `let*', but lexically scoped. -The main visible difference is that lambdas inside BODY will create -lexical closures as in Common Lisp." - (if (null bindings) (cons 'progn body) - (setq bindings (reverse bindings)) - (while bindings - (setq body (list (list* 'lexical-let (list (cl-pop bindings)) body)))) - (car body))) - -(defun cl-defun-expander (func &rest rest) - (list 'progn - (list 'defalias (list 'quote func) - (list 'function (cons 'lambda rest))) - (list 'quote func))) - - -;;; Multiple values. - -;;;###autoload -(defmacro multiple-value-bind (vars form &rest body) - "(multiple-value-bind (SYM SYM...) FORM BODY): collect multiple return values. -FORM must return a list; the BODY is then executed with the first N elements -of this list bound (`let'-style) to each of the symbols SYM in turn. This -is analogous to the Common Lisp `multiple-value-bind' macro, using lists to -simulate true multiple return values. For compatibility, (values A B C) is -a synonym for (list A B C)." - (let ((temp (gensym)) (n -1)) - (list* 'let* (cons (list temp form) - (mapcar (function - (lambda (v) - (list v (list 'nth (setq n (1+ n)) temp)))) - vars)) - body))) - -;;;###autoload -(defmacro multiple-value-setq (vars form) - "(multiple-value-setq (SYM SYM...) FORM): collect multiple return values. -FORM must return a list; the first N elements of this list are stored in -each of the symbols SYM in turn. This is analogous to the Common Lisp -`multiple-value-setq' macro, using lists to simulate true multiple return -values. For compatibility, (values A B C) is a synonym for (list A B C)." - (cond ((null vars) (list 'progn form nil)) - ((null (cdr vars)) (list 'setq (car vars) (list 'car form))) - (t - (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))))))))) - - -;;; Declarations. - -;;;###autoload -(defmacro locally (&rest body) (cons 'progn body)) -;;;###autoload -(defmacro the (type form) form) - -(defvar cl-proclaim-history t) ; for future compilers -(defvar cl-declare-stack t) ; for future compilers - -(defun cl-do-proclaim (spec hist) - (and hist (listp cl-proclaim-history) (cl-push spec cl-proclaim-history)) - (cond ((eq (car-safe spec) 'special) - (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)) - (cdr spec)) - byte-compile-bound-variables)))) - - ((eq (car-safe spec) 'inline) - (while (setq spec (cdr spec)) - (or (memq (get (car spec) 'byte-optimizer) - '(nil byte-compile-inline-expand)) - (error "%s already has a byte-optimizer, can't make it inline" - (car spec))) - (put (car spec) 'byte-optimizer 'byte-compile-inline-expand))) - - ((eq (car-safe spec) 'notinline) - (while (setq spec (cdr spec)) - (if (eq (get (car spec) 'byte-optimizer) - 'byte-compile-inline-expand) - (put (car spec) 'byte-optimizer nil)))) - - ((eq (car-safe spec) 'optimize) - (let ((speed (assq (nth 1 (assq 'speed (cdr spec))) - '((0 nil) (1 t) (2 t) (3 t)))) - (safety (assq (nth 1 (assq 'safety (cdr spec))) - '((0 t) (1 t) (2 t) (3 nil))))) - (if speed (setq cl-optimize-speed (car speed) - byte-optimize (nth 1 speed))) - (if safety (setq cl-optimize-safety (car safety) - byte-compile-delete-errors (nth 1 safety))))) - - ((and (eq (car-safe spec) 'warn) (boundp 'byte-compile-warnings)) - (if (eq byte-compile-warnings t) - ;; XEmacs change - (setq byte-compile-warnings byte-compile-default-warnings)) - (while (setq spec (cdr spec)) - (if (consp (car spec)) - (if (eq (cadar spec) 0) - (setq byte-compile-warnings - (delq (caar spec) byte-compile-warnings)) - (setq byte-compile-warnings - (adjoin (caar spec) byte-compile-warnings))))))) - nil) - -;;; Process any proclamations made before cl-macs was loaded. -(defvar cl-proclaims-deferred) -(let ((p (reverse cl-proclaims-deferred))) - (while p (cl-do-proclaim (cl-pop p) t)) - (setq cl-proclaims-deferred nil)) - -;;;###autoload -(defmacro declare (&rest specs) - (if (cl-compiling-file) - (while specs - (if (listp cl-declare-stack) (cl-push (car specs) cl-declare-stack)) - (cl-do-proclaim (cl-pop specs) nil))) - nil) - - - -;;; Generalized variables. - -;;;###autoload -(defmacro define-setf-method (func args &rest body) - "(define-setf-method NAME ARGLIST BODY...): define a `setf' method. -This method shows how to handle `setf's to places of the form (NAME ARGS...). -The argument forms ARGS are bound according to ARGLIST, as if NAME were -going to be expanded as a macro, then the BODY forms are executed and must -return a list of five elements: a temporary-variables list, a value-forms -list, a store-variables list (of length one), a store-form, and an access- -form. See `defsetf' for a simpler way to define most setf-methods." - (append '(eval-when (compile load eval)) - (if (stringp (car body)) - (list (list 'put (list 'quote func) '(quote setf-documentation) - (cl-pop body)))) - (list (cl-transform-function-property - func 'setf-method (cons args body))))) - -;;;###autoload -(defmacro defsetf (func arg1 &rest args) - "(defsetf NAME FUNC): define a `setf' method. -This macro is an easy-to-use substitute for `define-setf-method' that works -well for simple place forms. In the simple `defsetf' form, `setf's of -the form (setf (NAME ARGS...) VAL) are transformed to function or macro -calls of the form (FUNC ARGS... VAL). Example: (defsetf aref aset). -Alternate form: (defsetf NAME ARGLIST (STORE) BODY...). -Here, the above `setf' call is expanded by binding the argument forms ARGS -according to ARGLIST, binding the value form VAL to STORE, then executing -BODY, which must return a Lisp form that does the necessary `setf' operation. -Actually, ARGLIST and STORE may be bound to temporary variables which are -introduced automatically to preserve proper execution order of the arguments. -Example: (defsetf nth (n x) (v) (list 'setcar (list 'nthcdr n x) v))." - (if (listp arg1) - (let* ((largs nil) (largsr nil) - (temps nil) (tempsr nil) - (restarg nil) (rest-temps nil) - (store-var (car (prog1 (car args) (setq args (cdr args))))) - (store-temp (intern (format "--%s--temp--" store-var))) - (lets1 nil) (lets2 nil) - (docstr nil) (p arg1)) - (if (stringp (car args)) - (setq docstr (prog1 (car args) (setq args (cdr args))))) - (while (and p (not (eq (car p) '&aux))) - (if (eq (car p) '&rest) - (setq p (cdr p) restarg (car p)) - (or (memq (car p) '(&optional &key &allow-other-keys)) - (setq largs (cons (if (consp (car p)) (car (car p)) (car p)) - largs) - temps (cons (intern (format "--%s--temp--" (car largs))) - temps)))) - (setq p (cdr p))) - (setq largs (nreverse largs) temps (nreverse temps)) - (if restarg - (setq largsr (append largs (list restarg)) - rest-temps (intern (format "--%s--temp--" restarg)) - tempsr (append temps (list rest-temps))) - (setq largsr largs tempsr temps)) - (let ((p1 largs) (p2 temps)) - (while p1 - (setq lets1 (cons (list (car p2) - (list 'gensym (format "--%s--" (car p1)))) - lets1) - lets2 (cons (list (car p1) (car p2)) lets2) - p1 (cdr p1) p2 (cdr p2)))) - (if restarg (setq lets2 (cons (list restarg rest-temps) lets2))) - (append (list 'define-setf-method func arg1) - (and docstr (list docstr)) - (list - (list 'let* - (nreverse - (cons (list store-temp - (list 'gensym (format "--%s--" store-var))) - (if restarg - (append - (list - (list rest-temps - (list 'mapcar '(quote gensym) - restarg))) - lets1) - lets1))) - (list 'list ; 'values - (cons (if restarg 'list* 'list) tempsr) - (cons (if restarg 'list* 'list) largsr) - (list 'list store-temp) - (cons 'let* - (cons (nreverse - (cons (list store-var store-temp) - lets2)) - args)) - (cons (if restarg 'list* 'list) - (cons (list 'quote func) tempsr))))))) - (list 'defsetf func '(&rest args) '(store) - (let ((call (list 'cons (list 'quote arg1) - '(append args (list store))))) - (if (car args) - (list 'list '(quote progn) call 'store) - call))))) - -;;; Some standard place types from Common Lisp. -(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 nth (n x) (store) (list 'setcar (list 'nthcdr n x) store)) -(defsetf subseq (seq start &optional end) (new) - (list 'progn (list 'replace seq new ':start1 start ':end1 end) new)) -(defsetf symbol-function fset) -(defsetf symbol-plist setplist) -(defsetf symbol-value set) - -;;; Various car/cdr aliases. Note that `cadr' is handled specially. -(defsetf first setcar) -(defsetf second (x) (store) (list 'setcar (list 'cdr x) store)) -(defsetf third (x) (store) (list 'setcar (list 'cddr x) store)) -(defsetf fourth (x) (store) (list 'setcar (list 'cdddr x) store)) -(defsetf fifth (x) (store) (list 'setcar (list 'nthcdr 4 x) store)) -(defsetf sixth (x) (store) (list 'setcar (list 'nthcdr 5 x) store)) -(defsetf seventh (x) (store) (list 'setcar (list 'nthcdr 6 x) store)) -(defsetf eighth (x) (store) (list 'setcar (list 'nthcdr 7 x) store)) -(defsetf ninth (x) (store) (list 'setcar (list 'nthcdr 8 x) store)) -(defsetf tenth (x) (store) (list 'setcar (list 'nthcdr 9 x) store)) -(defsetf rest setcdr) - -;;; Some more Emacs-related place types. -(defsetf buffer-file-name set-visited-file-name t) -(defsetf buffer-modified-p set-buffer-modified-p t) -(defsetf buffer-name rename-buffer t) -(defsetf buffer-string () (store) - (list 'progn '(erase-buffer) (list 'insert store))) -(defsetf buffer-substring cl-set-buffer-substring) -(defsetf current-buffer set-buffer) -(defsetf current-case-table set-case-table) -(defsetf current-column move-to-column t) -(defsetf current-global-map use-global-map t) -(defsetf current-input-mode () (store) - (list 'progn (list 'apply 'set-input-mode store) store)) -(defsetf current-local-map use-local-map t) -(defsetf current-window-configuration set-window-configuration t) -(defsetf default-file-modes set-default-file-modes t) -(defsetf default-value set-default) -(defsetf documentation-property put) -(defsetf extent-data set-extent-data) ; obsolete -(defsetf extent-face set-extent-face) -(defsetf extent-priority set-extent-priority) -(defsetf extent-property (x y &optional d) (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) - store) store)) -(defsetf extent-start-position (ext) (store) - (list 'progn (list 'set-extent-endpoints store - (list 'extent-end-position ext)) store)) -(defsetf face-background (f &optional s) (x) (list 'set-face-background f x s)) -(defsetf face-background-pixmap (f &optional s) (x) - (list 'set-face-background-pixmap f x s)) -(defsetf face-font (f &optional s) (x) (list 'set-face-font f x s)) -(defsetf face-foreground (f &optional s) (x) (list 'set-face-foreground f x s)) -(defsetf face-underline-p (f &optional s) (x) - (list 'set-face-underline-p f x s)) -(defsetf file-modes set-file-modes t) -(defsetf frame-parameters modify-frame-parameters t) -(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) - `(progn (set-frame-property ,f ,v) ,p)) -(defsetf frame-width (&optional f) (v) - `(progn (set-frame-width ,f ,v) ,v)) -(defsetf frame-height (&optional f) (v) - `(progn (set-frame-height ,f ,v) ,v)) -(defsetf current-frame-configuration set-frame-configuration) - -;; XEmacs: new stuff -;; Consoles -(defsetf selected-console select-console t) -(defsetf selected-device select-device t) -(defsetf device-baud-rate (&optional d) (v) - `(set-device-baud-rate ,d ,v)) -(defsetf specifier-instance (spec &optional dom def nof) (val) - `(set-specifier ,spec ,val ,dom)) - -;; Annotations -(defsetf annotation-glyph set-annotation-glyph) -(defsetf annotation-down-glyph set-annotation-down-glyph) -(defsetf annotation-face set-annotation-face) -(defsetf annotation-layout set-annotation-layout) -(defsetf annotation-data set-annotation-data) -(defsetf annotation-action set-annotation-action) -(defsetf annotation-menu set-annotation-menu) -;; Widget -(defsetf widget-get widget-put t) -(defsetf widget-value widget-value-set t) - -;; Misc -(defsetf recent-keys-ring-size set-recent-keys-ring-size) - -(defsetf getenv setenv t) -(defsetf get-register set-register) -(defsetf global-key-binding global-set-key) -(defsetf keymap-parent set-keymap-parent) -(defsetf keymap-name set-keymap-name) -(defsetf keymap-prompt set-keymap-prompt) -(defsetf keymap-default-binding set-keymap-default-binding) -(defsetf local-key-binding local-set-key) -(defsetf mark set-mark t) -(defsetf mark-marker set-mark t) -(defsetf marker-position set-marker t) -(defsetf match-data store-match-data t) -(defsetf mouse-position (scr) (store) - (list 'set-mouse-position scr (list 'car store) (list 'cadr store) - (list 'cddr store))) -(defsetf overlay-get overlay-put) -(defsetf overlay-start (ov) (store) - (list 'progn (list 'move-overlay ov store (list 'overlay-end ov)) store)) -(defsetf overlay-end (ov) (store) - (list 'progn (list 'move-overlay ov (list 'overlay-start ov) store) store)) -(defsetf point goto-char) -(defsetf point-marker goto-char t) -(defsetf point-max () (store) - (list 'progn (list 'narrow-to-region '(point-min) store) store)) -(defsetf point-min () (store) - (list 'progn (list 'narrow-to-region store '(point-max)) store)) -(defsetf process-buffer set-process-buffer) -(defsetf process-filter set-process-filter) -(defsetf process-sentinel set-process-sentinel) -(defsetf read-mouse-position (scr) (store) - (list 'set-mouse-position scr (list 'car store) (list 'cdr store))) -(defsetf screen-height set-screen-height t) -(defsetf screen-width set-screen-width t) -(defsetf selected-window select-window) -(defsetf selected-screen select-screen) -(defsetf selected-frame select-frame) -(defsetf standard-case-table set-standard-case-table) -(defsetf syntax-table set-syntax-table) -(defsetf visited-file-modtime set-visited-file-modtime t) -(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-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 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) -(defsetf x-get-selection x-own-selection t) - -;;; More complex setf-methods. -;;; These should take &environment arguments, but since full arglists aren't -;;; available while compiling cl-macs, we fake it by referring to the global -;;; variable cl-macro-environment directly. - -(define-setf-method apply (func arg1 &rest rest) - (or (and (memq (car-safe func) '(quote function function*)) - (symbolp (car-safe (cdr-safe func)))) - (error "First arg to apply in setf is not (function SYM): %s" func)) - (let* ((form (cons (nth 1 func) (cons arg1 rest))) - (method (get-setf-method form cl-macro-environment))) - (list (car method) (nth 1 method) (nth 2 method) - (cl-setf-make-apply (nth 3 method) (cadr func) (car method)) - (cl-setf-make-apply (nth 4 method) (cadr func) (car method))))) - -(defun cl-setf-make-apply (form func temps) - (if (eq (car form) 'progn) - (list* 'progn (cl-setf-make-apply (cadr form) func temps) (cddr form)) - (or (equal (last form) (last temps)) - (error "%s is not suitable for use with setf-of-apply" func)) - (list* 'apply (list 'quote (car form)) (cdr form)))) - -(define-setf-method nthcdr (n place) - (let ((method (get-setf-method place cl-macro-environment)) - (n-temp (gensym "--nthcdr-n--")) - (store-temp (gensym "--nthcdr-store--"))) - (list (cons n-temp (car method)) - (cons n (nth 1 method)) - (list store-temp) - (list 'let (list (list (car (nth 2 method)) - (list 'cl-set-nthcdr n-temp (nth 4 method) - store-temp))) - (nth 3 method) store-temp) - (list 'nthcdr n-temp (nth 4 method))))) - -(define-setf-method getf (place tag &optional def) - (let ((method (get-setf-method place cl-macro-environment)) - (tag-temp (gensym "--getf-tag--")) - (def-temp (gensym "--getf-def--")) - (store-temp (gensym "--getf-store--"))) - (list (append (car method) (list tag-temp def-temp)) - (append (nth 1 method) (list tag def)) - (list store-temp) - (list 'let (list (list (car (nth 2 method)) - (list 'cl-set-getf (nth 4 method) - tag-temp store-temp))) - (nth 3 method) store-temp) - (list 'getf (nth 4 method) tag-temp def-temp)))) - -(define-setf-method substring (place from &optional to) - (let ((method (get-setf-method place cl-macro-environment)) - (from-temp (gensym "--substring-from--")) - (to-temp (gensym "--substring-to--")) - (store-temp (gensym "--substring-store--"))) - (list (append (car method) (list from-temp to-temp)) - (append (nth 1 method) (list from to)) - (list store-temp) - (list 'let (list (list (car (nth 2 method)) - (list 'cl-set-substring (nth 4 method) - from-temp to-temp store-temp))) - (nth 3 method) store-temp) - (list 'substring (nth 4 method) from-temp to-temp)))) - -(define-setf-method values (&rest args) - (let ((methods (mapcar #'(lambda (x) - (get-setf-method x cl-macro-environment)) - args)) - (store-temp (gensym "--values-store--"))) - (list (apply 'append (mapcar 'first methods)) - (apply 'append (mapcar 'second methods)) - (list store-temp) - (cons 'list - (mapcar #'(lambda (m) - (cl-setf-do-store (cons (car (third m)) (fourth m)) - (list 'pop store-temp))) - methods)) - (cons 'list (mapcar 'fifth methods))))) - -;;; Getting and optimizing setf-methods. -;;;###autoload -(defun get-setf-method (place &optional env) - "Return a list of five values describing the setf-method for PLACE. -PLACE may be any Lisp form which can appear as the PLACE argument to -a macro like `setf' or `incf'." - (if (symbolp place) - (let ((temp (gensym "--setf--"))) - (list nil nil (list temp) (list 'setq place temp) place)) - (or (and (symbolp (car place)) - (let* ((func (car place)) - (name (symbol-name func)) - (method (get func 'setf-method)) - (case-fold-search nil)) - (or (and method - (let ((cl-macro-environment env)) - (setq method (apply method (cdr place)))) - (if (and (consp method) (= (length method) 5)) - method - (error "Setf-method for %s returns malformed method" - func))) - (and (save-match-data - (string-match "\\`c[ad][ad][ad]?[ad]?r\\'" name)) - (get-setf-method (compiler-macroexpand place))) - (and (eq func 'edebug-after) - (get-setf-method (nth (1- (length place)) place) - env))))) - (if (eq place (setq place (macroexpand place env))) - (if (and (symbolp (car place)) (fboundp (car place)) - (symbolp (symbol-function (car place)))) - (get-setf-method (cons (symbol-function (car place)) - (cdr place)) env) - (error "No setf-method known for %s" (car place))) - (get-setf-method place env))))) - -(defun cl-setf-do-modify (place opt-expr) - (let* ((method (get-setf-method place cl-macro-environment)) - (temps (car method)) (values (nth 1 method)) - (lets nil) (subs nil) - (optimize (and (not (eq opt-expr 'no-opt)) - (or (and (not (eq opt-expr 'unsafe)) - (cl-safe-expr-p opt-expr)) - (cl-setf-simple-store-p (car (nth 2 method)) - (nth 3 method))))) - (simple (and optimize (consp place) (cl-simple-exprs-p (cdr place))))) - (while values - (if (or simple (cl-const-expr-p (car values))) - (cl-push (cons (cl-pop temps) (cl-pop values)) subs) - (cl-push (list (cl-pop temps) (cl-pop values)) lets))) - (list (nreverse lets) - (cons (car (nth 2 method)) (sublis subs (nth 3 method))) - (sublis subs (nth 4 method))))) - -(defun cl-setf-do-store (spec val) - (let ((sym (car spec)) - (form (cdr spec))) - (if (or (cl-const-expr-p val) - (and (cl-simple-expr-p val) (eq (cl-expr-contains form sym) 1)) - (cl-setf-simple-store-p sym form)) - (subst val sym form) - (list 'let (list (list sym val)) form)))) - -(defun cl-setf-simple-store-p (sym form) - (and (consp form) (eq (cl-expr-contains form sym) 1) - (eq (nth (1- (length form)) form) sym) - (symbolp (car form)) (fboundp (car form)) - (not (eq (car-safe (symbol-function (car form))) 'macro)))) - -;;; The standard modify macros. -;;;###autoload -(defmacro setf (&rest args) - "(setf PLACE VAL PLACE VAL ...): set each PLACE to the value of its VAL. -This is a generalized version of `setq'; the PLACEs may be symbolic -references such as (car x) or (aref x i), as well as plain symbols. -For example, (setf (cadar x) y) is equivalent to (setcar (cdar x) y). -The return value is the last VAL in the list." - (if (cdr (cdr args)) - (let ((sets nil)) - (while args (cl-push (list 'setf (cl-pop args) (cl-pop args)) sets)) - (cons 'progn (nreverse sets))) - (if (symbolp (car args)) - (and args (cons 'setq args)) - (let* ((method (cl-setf-do-modify (car args) (nth 1 args))) - (store (cl-setf-do-store (nth 1 method) (nth 1 args)))) - (if (car method) (list 'let* (car method) store) store))))) - -;;;###autoload -(defmacro psetf (&rest args) - "(psetf PLACE VAL PLACE VAL ...): set PLACEs to the values VALs in parallel. -This is like `setf', except that all VAL forms are evaluated (in order) -before assigning any PLACEs to the corresponding values." - (let ((p args) (simple t) (vars nil)) - (while p - (if (or (not (symbolp (car p))) (cl-expr-depends-p (nth 1 p) vars)) - (setq simple nil)) - (if (memq (car p) vars) - (error "Destination duplicated in psetf: %s" (car p))) - (cl-push (cl-pop p) vars) - (or p (error "Odd number of arguments to psetf")) - (cl-pop p)) - (if simple - (list 'progn (cons 'setf args) nil) - (setq args (reverse args)) - (let ((expr (list 'setf (cadr args) (car args)))) - (while (setq args (cddr args)) - (setq expr (list 'setf (cadr args) (list 'prog1 (car args) expr)))) - (list 'progn expr nil))))) - -;;;###autoload -(defun cl-do-pop (place) - (if (cl-simple-expr-p place) - (list 'prog1 (list 'car place) (list 'setf place (list 'cdr place))) - (let* ((method (cl-setf-do-modify place t)) - (temp (gensym "--pop--"))) - (list 'let* - (append (car method) - (list (list temp (nth 2 method)))) - (list 'prog1 - (list 'car temp) - (cl-setf-do-store (nth 1 method) (list 'cdr temp))))))) - -;;;###autoload -(defmacro remf (place tag) - "(remf PLACE TAG): remove TAG from property list PLACE. -PLACE may be a symbol, or any generalized variable allowed by `setf'. -The form returns true if TAG was found and removed, nil otherwise." - (let* ((method (cl-setf-do-modify place t)) - (tag-temp (and (not (cl-const-expr-p tag)) (gensym "--remf-tag--"))) - (val-temp (and (not (cl-simple-expr-p place)) - (gensym "--remf-place--"))) - (ttag (or tag-temp tag)) - (tval (or val-temp (nth 2 method)))) - (list 'let* - (append (car method) - (and val-temp (list (list val-temp (nth 2 method)))) - (and tag-temp (list (list tag-temp tag)))) - (list 'if (list 'eq ttag (list 'car tval)) - (list 'progn - (cl-setf-do-store (nth 1 method) (list 'cddr tval)) - t) - (list 'cl-do-remf tval ttag))))) - -;;;###autoload -(defmacro shiftf (place &rest args) - "(shiftf PLACE PLACE... VAL): shift left among PLACEs. -Example: (shiftf A B C) sets A to B, B to C, and returns the old A. -Each PLACE may be a symbol, or any generalized variable allowed by `setf'." - (if (not (memq nil (mapcar 'symbolp (butlast (cons place args))))) - (list* 'prog1 place - (let ((sets nil)) - (while args - (cl-push (list 'setq place (car args)) sets) - (setq place (cl-pop args))) - (nreverse sets))) - (let* ((places (reverse (cons place args))) - (form (cl-pop places))) - (while places - (let ((method (cl-setf-do-modify (cl-pop places) 'unsafe))) - (setq form (list 'let* (car method) - (list 'prog1 (nth 2 method) - (cl-setf-do-store (nth 1 method) form)))))) - form))) - -;;;###autoload -(defmacro rotatef (&rest args) - "(rotatef PLACE...): rotate left among PLACEs. -Example: (rotatef A B C) sets A to B, B to C, and C to A. It returns nil. -Each PLACE may be a symbol, or any generalized variable allowed by `setf'." - (if (not (memq nil (mapcar 'symbolp args))) - (and (cdr args) - (let ((sets nil) - (first (car args))) - (while (cdr args) - (setq sets (nconc sets (list (cl-pop args) (car args))))) - (nconc (list 'psetf) sets (list (car args) first)))) - (let* ((places (reverse args)) - (temp (gensym "--rotatef--")) - (form temp)) - (while (cdr places) - (let ((method (cl-setf-do-modify (cl-pop places) 'unsafe))) - (setq form (list 'let* (car method) - (list 'prog1 (nth 2 method) - (cl-setf-do-store (nth 1 method) form)))))) - (let ((method (cl-setf-do-modify (car places) 'unsafe))) - (list 'let* (append (car method) (list (list temp (nth 2 method)))) - (cl-setf-do-store (nth 1 method) form) nil))))) - -;;;###autoload -(defmacro letf (bindings &rest body) - "(letf ((PLACE VALUE) ...) BODY...): temporarily bind to PLACEs. -This is the analogue of `let', but with generalized variables (in the -sense of `setf') for the PLACEs. Each PLACE is set to the corresponding -VALUE, then the BODY forms are executed. On exit, either normally or -because of a `throw' or error, the PLACEs are set back to their original -values. Note that this macro is *not* available in Common Lisp. -As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)', -the PLACE is not modified before executing BODY." - (if (and (not (cdr bindings)) (cdar bindings) (symbolp (caar bindings))) - (list* 'let bindings body) - (let ((lets nil) (sets nil) - (unsets nil) (rev (reverse bindings))) - (while rev - (let* ((place (if (symbolp (caar rev)) - (list 'symbol-value (list 'quote (caar rev))) - (caar rev))) - (value (cadar rev)) - (method (cl-setf-do-modify place 'no-opt)) - (save (gensym "--letf-save--")) - (bound (and (memq (car place) '(symbol-value symbol-function)) - (gensym "--letf-bound--"))) - (temp (and (not (cl-const-expr-p value)) (cdr bindings) - (gensym "--letf-val--")))) - (setq lets (nconc (car method) - (if bound - (list (list bound - (list (if (eq (car place) - 'symbol-value) - 'boundp 'fboundp) - (nth 1 (nth 2 method)))) - (list save (list 'and bound - (nth 2 method)))) - (list (list save (nth 2 method)))) - (and temp (list (list temp value))) - lets) - body (list - (list 'unwind-protect - (cons 'progn - (if (cdr (car rev)) - (cons (cl-setf-do-store (nth 1 method) - (or temp value)) - body) - body)) - (if bound - (list 'if bound - (cl-setf-do-store (nth 1 method) save) - (list (if (eq (car place) 'symbol-value) - 'makunbound 'fmakunbound) - (nth 1 (nth 2 method)))) - (cl-setf-do-store (nth 1 method) save)))) - rev (cdr rev)))) - (list* 'let* lets body)))) - -;;;###autoload -(defmacro letf* (bindings &rest body) - "(letf* ((PLACE VALUE) ...) BODY...): temporarily bind to PLACEs. -This is the analogue of `let*', but with generalized variables (in the -sense of `setf') for the PLACEs. Each PLACE is set to the corresponding -VALUE, then the BODY forms are executed. On exit, either normally or -because of a `throw' or error, the PLACEs are set back to their original -values. Note that this macro is *not* available in Common Lisp. -As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)', -the PLACE is not modified before executing BODY." - (if (null bindings) - (cons 'progn body) - (setq bindings (reverse bindings)) - (while bindings - (setq body (list (list* 'letf (list (cl-pop bindings)) body)))) - (car body))) - -;;;###autoload -(defmacro callf (func place &rest args) - "(callf FUNC PLACE ARGS...): set PLACE to (FUNC PLACE ARGS...). -FUNC should be an unquoted function name. PLACE may be a symbol, -or any generalized variable allowed by `setf'." - (let* ((method (cl-setf-do-modify place (cons 'list args))) - (rargs (cons (nth 2 method) args))) - (list 'let* (car method) - (cl-setf-do-store (nth 1 method) - (if (symbolp func) (cons func rargs) - (list* 'funcall (list 'function func) - rargs)))))) - -;;;###autoload -(defmacro callf2 (func arg1 place &rest args) - "(callf2 FUNC ARG1 PLACE ARGS...): set PLACE to (FUNC ARG1 PLACE ARGS...). -Like `callf', but PLACE is the second argument of FUNC, not the first." - (if (and (cl-safe-expr-p arg1) (cl-simple-expr-p place) (symbolp func)) - (list 'setf place (list* func arg1 place args)) - (let* ((method (cl-setf-do-modify place (cons 'list args))) - (temp (and (not (cl-const-expr-p arg1)) (gensym "--arg1--"))) - (rargs (list* (or temp arg1) (nth 2 method) args))) - (list 'let* (append (and temp (list (list temp arg1))) (car method)) - (cl-setf-do-store (nth 1 method) - (if (symbolp func) (cons func rargs) - (list* 'funcall (list 'function func) - rargs))))))) - -;;;###autoload -(defmacro define-modify-macro (name arglist func &optional doc) - "(define-modify-macro NAME ARGLIST FUNC): define a `setf'-like modify macro. -If NAME is called, it combines its PLACE argument with the other arguments -from ARGLIST using FUNC: (define-modify-macro incf (&optional (n 1)) +)" - (if (memq '&key arglist) (error "&key not allowed in define-modify-macro")) - (let ((place (gensym "--place--"))) - (list 'defmacro* name (cons place arglist) doc - (list* (if (memq '&rest arglist) 'list* 'list) - '(quote callf) (list 'quote func) place - (cl-arglist-args arglist))))) - - -;;; Structures. - -;;;###autoload -(defmacro defstruct (struct &rest descs) - "(defstruct (NAME OPTIONS...) (SLOT SLOT-OPTS...)...): define a struct type. -This macro defines a new Lisp data type called NAME, which contains data -stored in SLOTs. This defines a `make-NAME' constructor, a `copy-NAME' -copier, a `NAME-p' predicate, and setf-able `NAME-SLOT' accessors." - (let* ((name (if (consp struct) (car struct) struct)) - (opts (cdr-safe struct)) - (slots nil) - (defaults nil) - (conc-name (concat (symbol-name name) "-")) - (constructor (intern (format "make-%s" name))) - (constrs nil) - (copier (intern (format "copy-%s" name))) - (predicate (intern (format "%s-p" name))) - (print-func nil) (print-auto nil) - (safety (if (cl-compiling-file) cl-optimize-safety 3)) - (include nil) - (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) - (forms nil) - pred-form pred-check) - (if (stringp (car descs)) - (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)))) - descs))) - (while opts - (let ((opt (if (consp (car opts)) (caar opts) (car opts))) - (args (cdr-safe (cl-pop opts)))) - (cond ((eq opt ':conc-name) - (if args - (setq conc-name (if (car args) - (symbol-name (car args)) "")))) - ((eq opt ':constructor) - (if (cdr args) - (cl-push args constrs) - (if args (setq constructor (car args))))) - ((eq opt ':copier) - (if args (setq copier (car args)))) - ((eq opt ':predicate) - (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)))) - ((eq opt ':print-function) - (setq print-func (car args))) - ((eq opt ':type) - (setq type (car args))) - ((eq opt ':named) - (setq named t)) - ((eq opt ':initial-offset) - (setq descs (nconc (make-list (car args) '(cl-skip-slot)) - descs))) - (t - (error "Slot option %s unrecognized" opt))))) - (if print-func - (setq print-func (list 'progn - (list 'funcall (list 'function print-func) - 'cl-x 'cl-s 'cl-n) t)) - (or type (and include (not (get include 'cl-struct-print))) - (setq print-auto t - print-func (and (or (not (or include type)) (null print-func)) - (list 'progn - (list 'princ (format "#S(%s" name) - 'cl-s)))))) - (if include - (let ((inc-type (get include 'cl-struct-type)) - (old-descs (get include 'cl-struct-slots))) - (or inc-type (error "%s is not a struct name" include)) - (and type (not (eq (car inc-type) type)) - (error ":type disagrees with :include for %s" name)) - (while include-descs - (setcar (memq (or (assq (caar include-descs) old-descs) - (error "No slot %s in included struct %s" - (caar include-descs) include)) - old-descs) - (cl-pop include-descs))) - (setq descs (append old-descs (delq (assq 'cl-tag-slot descs) descs)) - type (car inc-type) - named (assq 'cl-tag-slot descs)) - (if (cadr inc-type) (setq tag name named t)) - (let ((incl include)) - (while incl - (cl-push (list 'pushnew (list 'quote tag) - (intern (format "cl-struct-%s-tags" incl))) - forms) - (setq incl (get incl 'cl-struct-include))))) - (if type - (progn - (or (memq type '(vector list)) - (error "Illegal :type specifier: %s" type)) - (if named (setq tag name))) - (setq type 'vector named 'true))) - (or named (setq descs (delq (assq 'cl-tag-slot descs) descs))) - (cl-push (list 'defvar tag-symbol) forms) - (setq pred-form (and named - (let ((pos (- (length descs) - (length (memq (assq 'cl-tag-slot descs) - descs))))) - (if (eq type 'vector) - (list 'and '(vectorp cl-x) - (list '>= '(length cl-x) (length descs)) - (list 'memq (list 'aref 'cl-x pos) - tag-symbol)) - (if (= pos 0) - (list 'memq '(car-safe cl-x) tag-symbol) - (list 'and '(consp cl-x) - (list 'memq (list 'nth pos 'cl-x) - tag-symbol)))))) - pred-check (and pred-form (> safety 0) - (if (and (eq (caadr pred-form) 'vectorp) - (= safety 1)) - (cons 'and (cdddr pred-form)) pred-form))) - (let ((pos 0) (descp descs)) - (while descp - (let* ((desc (cl-pop descp)) - (slot (car desc))) - (if (memq slot '(cl-tag-slot cl-skip-slot)) - (progn - (cl-push nil slots) - (cl-push (and (eq slot 'cl-tag-slot) (list 'quote tag)) - defaults)) - (if (assq slot descp) - (error "Duplicate slots named %s in %s" slot name)) - (let ((accessor (intern (format "%s%s" conc-name slot)))) - (cl-push slot slots) - (cl-push (nth 1 desc) defaults) - (cl-push (list* - 'defsubst* accessor '(cl-x) - (append - (and pred-check - (list (list 'or pred-check - (list 'error - (format "%s accessing a non-%s" - accessor name) - 'cl-x)))) - (list (if (eq type 'vector) (list 'aref 'cl-x pos) - (if (= pos 0) '(car cl-x) - (list 'nth pos 'cl-x)))))) forms) - (cl-push (cons accessor t) side-eff) - (cl-push (list 'define-setf-method accessor '(cl-x) - (if (cadr (memq ':read-only (cddr desc))) - (list 'error (format "%s is a read-only slot" - accessor)) - (list 'cl-struct-setf-expander 'cl-x - (list 'quote name) (list 'quote accessor) - (and pred-check (list 'quote pred-check)) - pos))) - forms) - (if print-auto - (nconc print-func - (list (list 'princ (format " %s" slot) 'cl-s) - (list 'prin1 (list accessor 'cl-x) 'cl-s))))))) - (setq pos (1+ pos)))) - (setq slots (nreverse slots) - defaults (nreverse defaults)) - (and predicate pred-form - (progn (cl-push (list 'defsubst* predicate '(cl-x) - (if (eq (car pred-form) 'and) - (append pred-form '(t)) - (list 'and pred-form t))) forms) - (cl-push (cons predicate 'error-free) side-eff))) - (and copier - (progn (cl-push (list 'defun copier '(x) '(copy-sequence x)) forms) - (cl-push (cons copier t) side-eff))) - (if constructor - (cl-push (list constructor - (cons '&key (delq nil (copy-sequence slots)))) - constrs)) - (while constrs - (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))) - slots defaults))) - (cl-push (list 'defsubst* name - (list* '&cl-defs (list 'quote (cons nil descs)) args) - (cons type make)) forms) - (if (cl-safe-expr-p (cons 'progn (mapcar 'second descs))) - (cl-push (cons name t) side-eff)))) - (if print-auto (nconc print-func (list '(princ ")" cl-s) t))) - (if print-func - (cl-push (list 'push - (list 'function - (list 'lambda '(cl-x cl-s cl-n) - (list 'and pred-form print-func))) - 'custom-print-functions) forms)) - (cl-push (list 'setq tag-symbol (list 'list (list 'quote tag))) forms) - (cl-push (list* 'eval-when '(compile load eval) - (list 'put (list 'quote name) '(quote cl-struct-slots) - (list 'quote descs)) - (list 'put (list 'quote name) '(quote cl-struct-type) - (list 'quote (list type (eq named t)))) - (list 'put (list 'quote name) '(quote cl-struct-include) - (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))))) - side-eff)) - forms) - (cons 'progn (nreverse (cons (list 'quote name) forms))))) - -;;;###autoload -(defun cl-struct-setf-expander (x name accessor pred-form pos) - (let* ((temp (gensym "--x--")) (store (gensym "--store--"))) - (list (list temp) (list x) (list store) - (append '(progn) - (and pred-form - (list (list 'or (subst temp 'cl-x pred-form) - (list 'error - (format - "%s storing a non-%s" accessor name) - temp)))) - (list (if (eq (car (get name 'cl-struct-type)) 'vector) - (list 'aset temp pos store) - (list 'setcar - (if (<= pos 5) - (let ((xx temp)) - (while (>= (setq pos (1- pos)) 0) - (setq xx (list 'cdr xx))) - xx) - (list 'nthcdr pos temp)) - store)))) - (list accessor temp)))) - - -;;; Types and assertions. - -;;;###autoload -(defmacro deftype (name args &rest body) - "(deftype NAME ARGLIST BODY...): define NAME as a new data type. -The type name can then be used in `typecase', `check-type', etc." - (list 'eval-when '(compile load eval) - (cl-transform-function-property - name 'cl-deftype-handler (cons (list* '&cl-defs ''('*) args) body)))) - -(defun cl-make-type-test (val type) - (if (symbolp type) - (cond ((get type 'cl-deftype-handler) - (cl-make-type-test val (funcall (get type 'cl-deftype-handler)))) - ((memq type '(nil t)) type) - ((eq type 'string-char) (list 'characterp val)) - ((eq type 'null) (list 'null val)) - ((eq type 'float) (list 'floatp-safe val)) - ((eq type 'real) (list 'numberp val)) - ((eq type 'fixnum) (list 'integerp val)) - (t - (let* ((name (symbol-name type)) - (namep (intern (concat name "p")))) - (if (fboundp namep) (list namep val) - (list (intern (concat name "-p")) val))))) - (cond ((get (car type) 'cl-deftype-handler) - (cl-make-type-test val (apply (get (car type) 'cl-deftype-handler) - (cdr type)))) - ((memq (car-safe type) '(integer float real number)) - (delq t (list 'and (cl-make-type-test val (car type)) - (if (memq (cadr type) '(* nil)) t - (if (consp (cadr type)) (list '> val (caadr type)) - (list '>= val (cadr type)))) - (if (memq (caddr type) '(* nil)) t - (if (consp (caddr type)) (list '< val (caaddr type)) - (list '<= val (caddr type))))))) - ((memq (car-safe type) '(and or not)) - (cons (car type) - (mapcar (function (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)) - ((eq (car-safe type) 'satisfies) (list (cadr type) val)) - (t (error "Bad type spec: %s" type))))) - -;;;###autoload -(defun typep (val type) ; See compiler macro below. - "Check that OBJECT is of type TYPE. -TYPE is a Common Lisp-style type specifier." - (eval (cl-make-type-test 'val type))) - -;;;###autoload -(defmacro check-type (form type &optional string) - "Verify that FORM is of type TYPE; signal an error if not. -STRING is an optional description of the desired type." - (and (or (not (cl-compiling-file)) - (< cl-optimize-speed 3) (= cl-optimize-safety 3)) - (let* ((temp (if (cl-simple-expr-p form 3) form (gensym))) - (body (list 'or (cl-make-type-test temp type) - (list 'signal '(quote wrong-type-argument) - (list 'list (or string (list 'quote type)) - temp (list 'quote form)))))) - (if (eq temp form) (list 'progn body nil) - (list 'let (list (list temp form)) body nil))))) - -;;;###autoload -(defmacro assert (form &optional show-args string &rest args) - "Verify that FORM returns non-nil; signal an error if not. -Second arg SHOW-ARGS means to include arguments of FORM in message. -Other args STRING and ARGS... are arguments to be passed to `error'. -They are not evaluated unless the assertion fails. If STRING is -omitted, a default message listing FORM itself is used." - (and (or (not (cl-compiling-file)) - (< cl-optimize-speed 3) (= cl-optimize-safety 3)) - (let ((sargs (and show-args (delq nil (mapcar - (function - (lambda (x) - (and (not (cl-const-expr-p x)) - x))) (cdr form)))))) - (list 'progn - (list 'or form - (if string - (list* 'error string (append sargs args)) - (list 'signal '(quote cl-assertion-failed) - (list* 'list (list 'quote form) sargs)))) - nil)))) - -;;;###autoload -(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))) - - -;;; Some predicates for analyzing Lisp forms. These are used by various -;;; macro expanders to optimize the results in certain common cases. - -(defconst cl-simple-funcs '(car cdr nth aref elt if and or + - 1+ 1- min max - car-safe cdr-safe progn prog1 prog2)) -(defconst cl-safe-funcs '(* / % length memq list vector vectorp - < > <= >= = error)) - -;;; Check if no side effects, and executes quickly. -(defun cl-simple-expr-p (x &optional size) - (or size (setq size 10)) - (if (and (consp x) (not (memq (car x) '(quote function function*)))) - (and (symbolp (car x)) - (or (memq (car x) cl-simple-funcs) - (get (car x) 'side-effect-free)) - (progn - (setq size (1- size)) - (while (and (setq x (cdr x)) - (setq size (cl-simple-expr-p (car x) size)))) - (and (null x) (>= size 0) size))) - (and (> size 0) (1- size)))) - -(defun cl-simple-exprs-p (xs) - (while (and xs (cl-simple-expr-p (car xs))) - (setq xs (cdr xs))) - (not xs)) - -;;; Check if no side effects. -(defun cl-safe-expr-p (x) - (or (not (and (consp x) (not (memq (car x) '(quote function function*))))) - (and (symbolp (car x)) - (or (memq (car x) cl-simple-funcs) - (memq (car x) cl-safe-funcs) - (get (car x) 'side-effect-free)) - (progn - (while (and (setq x (cdr x)) (cl-safe-expr-p (car x)))) - (null x))))) - -;;; Check if constant (i.e., no side effects or dependencies). -(defun cl-const-expr-p (x) - (cond ((consp x) - (or (eq (car x) 'quote) - (and (memq (car x) '(function function*)) - (or (symbolp (nth 1 x)) - (and (eq (car-safe (nth 1 x)) 'lambda) 'func))))) - ((symbolp x) (and (memq x '(nil t)) t)) - (t t))) - -(defun cl-const-exprs-p (xs) - (while (and xs (cl-const-expr-p (car xs))) - (setq xs (cdr xs))) - (not xs)) - -(defun cl-const-expr-val (x) - (and (eq (cl-const-expr-p x) t) (if (consp x) (nth 1 x) x))) - -(defun cl-expr-access-order (x v) - (if (cl-const-expr-p x) v - (if (consp x) - (progn - (while (setq x (cdr x)) (setq v (cl-expr-access-order (car x) v))) - v) - (if (eq x (car v)) (cdr v) '(t))))) - -;;; Count number of times X refers to Y. Return NIL for 0 times. -(defun cl-expr-contains (x y) - (cond ((equal y x) 1) - ((and (consp x) (not (memq (car-safe x) '(quote function function*)))) - (let ((sum 0)) - (while x - (setq sum (+ sum (or (cl-expr-contains (cl-pop x) y) 0)))) - (and (> sum 0) sum))) - (t nil))) - -(defun cl-expr-contains-any (x y) - (while (and y (not (cl-expr-contains x (car y)))) (cl-pop y)) - y) - -;;; Check whether X may depend on any of the symbols in Y. -(defun cl-expr-depends-p (x y) - (and (not (cl-const-expr-p x)) - (or (not (cl-safe-expr-p x)) (cl-expr-contains-any x y)))) - - -;;; Compiler macros. - -;;;###autoload -(defmacro define-compiler-macro (func args &rest body) - "(define-compiler-macro FUNC ARGLIST BODY...): Define a compiler-only macro. -This is like `defmacro', but macro expansion occurs only if the call to -FUNC is compiled (i.e., not interpreted). Compiler macros should be used -for optimizing the way calls to FUNC are compiled; the form returned by -BODY should do the same thing as a call to the normal function called -FUNC, though possibly more efficiently. Note that, like regular macros, -compiler macros are expanded repeatedly until no further expansions are -possible. Unlike regular macros, BODY can decide to \"punt\" and leave the -original function call alone by declaring an initial `&whole foo' parameter -and then returning foo." - (let ((p (if (listp args) args (list '&rest args))) (res nil)) - (while (consp p) (cl-push (cl-pop p) res)) - (setq args (nreverse res)) (setcdr res (and p (list '&rest p)))) - (list 'eval-when '(compile load eval) - (cl-transform-function-property - func 'cl-compiler-macro - (cons (if (memq '&whole args) (delq '&whole args) - (cons '--cl-whole-arg-- args)) body)) - (list 'or (list 'get (list 'quote func) '(quote byte-compile)) - (list 'put (list 'quote func) '(quote byte-compile) - '(quote cl-byte-compile-compiler-macro))))) - -;;;###autoload -(defun compiler-macroexpand (form) - (while - (let ((func (car-safe form)) (handler nil)) - (while (and (symbolp func) - (not (setq handler (get func 'cl-compiler-macro))) - (fboundp func) - (or (not (eq (car-safe (symbol-function func)) 'autoload)) - (load (nth 1 (symbol-function func))))) - (setq func (symbol-function func))) - (and handler - (not (eq form (setq form (apply handler form (cdr form)))))))) - form) - -(defun cl-byte-compile-compiler-macro (form) - (if (eq form (setq form (compiler-macroexpand form))) - (byte-compile-normal-call form) - (byte-compile-form form))) - -(defmacro defsubst* (name args &rest body) - "(defsubst* NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function. -Like `defun', except the function is automatically declared `inline', -ARGLIST allows full Common Lisp conventions, and BODY is implicitly -surrounded by (block NAME ...)." - (let* ((argns (cl-arglist-args args)) (p argns) - (pbody (cons 'progn body)) - (unsafe (not (cl-safe-expr-p pbody)))) - (while (and p (eq (cl-expr-contains args (car p)) 1)) (cl-pop p)) - (list 'progn - (if p nil ; give up if defaults refer to earlier args - (list 'define-compiler-macro name - (list* '&whole 'cl-whole '&cl-quote args) - (list* 'cl-defsubst-expand (list 'quote argns) - (list 'quote (list* 'block name body)) - (not (or unsafe (cl-expr-access-order pbody argns))) - (and (memq '&key args) 'cl-whole) unsafe argns))) - (list* 'defun* name args body)))) - -(defun cl-defsubst-expand (argns body simple whole unsafe &rest argvs) - (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)))) - argns argvs)))) - (if lets (list 'let lets body) body)))) - - -;;; Compile-time optimizations for some functions defined in this package. -;;; Note that cl.el arranges to force cl-macs to be loaded at compile-time, -;;; mainly to make sure these macros will be present. - -(put 'eql 'byte-compile nil) -(define-compiler-macro eql (&whole form a b) - (cond ((eq (cl-const-expr-p a) t) - (let ((val (cl-const-expr-val a))) - (if (and (numberp val) (not (integerp val))) - (list 'equal a b) - (list 'eq a b)))) - ((eq (cl-const-expr-p b) t) - (let ((val (cl-const-expr-val b))) - (if (and (numberp val) (not (integerp val))) - (list 'equal a b) - (list 'eq a b)))) - ((cl-simple-expr-p a 5) - (list 'if (list 'numberp a) - (list 'equal a b) - (list 'eq a b))) - ((and (cl-safe-expr-p a) - (cl-simple-expr-p b 5)) - (list 'if (list 'numberp b) - (list 'equal a b) - (list 'eq a b))) - (t form))) - -(define-compiler-macro member* (&whole form a list &rest keys) - (let ((test (and (= (length keys) 2) (eq (car keys) ':test) - (cl-const-expr-val (nth 1 keys))))) - (cond ((eq test 'eq) (list 'memq a list)) - ((eq test 'equal) (list 'member a list)) - ((or (null keys) (eq test 'eql)) - (if (eq (cl-const-expr-p a) t) - (list (if (floatp-safe (cl-const-expr-val a)) 'member 'memq) - a list) - (if (eq (cl-const-expr-p list) t) - (let ((p (cl-const-expr-val list)) (mb nil) (mq nil)) - (if (not (cdr p)) - (and p (list 'eql a (list 'quote (car p)))) - (while p - (if (floatp-safe (car p)) (setq mb t) - (or (integerp (car p)) (symbolp (car p)) (setq mq t))) - (setq p (cdr p))) - (if (not mb) (list 'memq a list) - (if (not mq) (list 'member a list) form)))) - form))) - (t form)))) - -(define-compiler-macro assoc* (&whole form a list &rest keys) - (let ((test (and (= (length keys) 2) (eq (car keys) ':test) - (cl-const-expr-val (nth 1 keys))))) - (cond ((eq test 'eq) (list 'assq a list)) - ((eq test 'equal) (list 'assoc a list)) - ((and (eq (cl-const-expr-p a) t) (or (null keys) (eq test 'eql))) - (if (floatp-safe (cl-const-expr-val a)) - (list 'assoc a list) (list 'assq a list))) - (t form)))) - -(define-compiler-macro adjoin (&whole form a list &rest keys) - (if (and (cl-simple-expr-p a) (cl-simple-expr-p list) - (not (memq ':key keys))) - (list 'if (list* 'member* a list keys) list (list 'cons a list)) - form)) - -(define-compiler-macro list* (arg &rest others) - (let* ((args (reverse (cons arg others))) - (form (car args))) - (while (setq args (cdr args)) - (setq form (list 'cons (car args) form))) - form)) - -(define-compiler-macro get* (sym prop &optional def) - (if def - (list 'getf (list 'symbol-plist sym) prop def) - (list 'get sym prop))) - -(define-compiler-macro typep (&whole form val type) - (if (cl-const-expr-p type) - (let ((res (cl-make-type-test val (cl-const-expr-val type)))) - (if (or (memq (cl-expr-contains res val) '(nil 1)) - (cl-simple-expr-p val)) res - (let ((temp (gensym))) - (list 'let (list (list temp val)) (subst temp val res))))) - 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) )) - -;;; Things that are inline. -(proclaim '(inline floatp-safe acons map concatenate notany notevery -;; XEmacs change - cl-set-elt revappend nreconc)) - -;;; Things that are side-effect-free. -(mapcar (function (lambda (x) (put x 'side-effect-free t))) - '(oddp evenp abs expt signum last butlast ldiff pairlis gcd lcm - isqrt floor* ceiling* truncate* round* mod* rem* subseq - list-length get* getf gethash hash-table-count)) - -;;; Things that are side-effect-and-error-free. -(mapcar (function (lambda (x) (put x 'side-effect-free 'error-free))) - '(eql floatp-safe list* subst acons equalp random-state-p - copy-tree sublis hash-table-p)) - - -(run-hooks 'cl-macs-load-hook) - -;;; cl-macs.el ends here
--- a/lisp/cl/cl-seq.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,935 +0,0 @@ -;;; cl-seq.el --- Common Lisp extensions for GNU Emacs Lisp (part three) - -;; Copyright (C) 1993 Free Software Foundation, Inc. - -;; Author: Dave Gillespie <daveg@synaptics.com> -;; Version: 2.02 -;; Keywords: extensions - -;; 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.34. - -;;; Commentary: - -;; These are extensions to Emacs Lisp that provide a degree of -;; Common Lisp compatibility, beyond what is already built-in -;; in Emacs Lisp. -;; -;; This package was written by Dave Gillespie; it is a complete -;; rewrite of Cesar Quiroz's original cl.el package of December 1986. -;; -;; This package works with Emacs 18, Emacs 19, and Lucid Emacs 19. -;; -;; Bug reports, comments, and suggestions are welcome! - -;; This file contains the Common Lisp sequence and list functions -;; which take keyword arguments. - -;; See cl.el for Change Log. - - -;;; Code: - -(or (memq 'cl-19 features) - (error "Tried to load `cl-seq' before `cl'!")) - - -;;; We define these here so that this file can compile without having -;;; loaded the cl.el file already. - -(defmacro cl-push (x place) (list 'setq place (list 'cons x place))) -(defmacro cl-pop (place) - (list 'car (list 'prog1 place (list 'setq place (list 'cdr place))))) - - -;;; Keyword parsing. This is special-cased here so that we can compile -;;; this file independent from cl-macs. - -(defmacro cl-parsing-keywords (kwords other-keys &rest body) - (cons - 'let* - (cons (mapcar - (function - (lambda (x) - (let* ((var (if (consp x) (car x) x)) - (mem (list 'car (list 'cdr (list 'memq (list 'quote var) - 'cl-keys))))) - (if (eq var ':test-not) - (setq mem (list 'and mem (list 'setq 'cl-test mem) t))) - (if (eq var ':if-not) - (setq mem (list 'and mem (list 'setq 'cl-if mem) t))) - (list (intern - (format "cl-%s" (substring (symbol-name var) 1))) - (if (consp x) (list 'or mem (car (cdr x))) mem))))) - kwords) - (append - (and (not (eq other-keys t)) - (list - (list 'let '((cl-keys-temp cl-keys)) - (list 'while 'cl-keys-temp - (list 'or (list 'memq '(car cl-keys-temp) - (list 'quote - (mapcar - (function - (lambda (x) - (if (consp x) - (car x) x))) - (append kwords - other-keys)))) - '(car (cdr (memq (quote :allow-other-keys) - cl-keys))) - '(error "Bad keyword argument %s" - (car cl-keys-temp))) - '(setq cl-keys-temp (cdr (cdr cl-keys-temp))))))) - body)))) -(put 'cl-parsing-keywords 'lisp-indent-function 2) -(put 'cl-parsing-keywords 'edebug-form-spec '(sexp sexp &rest form)) - -(defmacro cl-check-key (x) - (list 'if 'cl-key (list 'funcall 'cl-key x) x)) - -(defmacro cl-check-test-nokey (item x) - (list 'cond - (list 'cl-test - (list 'eq (list 'not (list 'funcall 'cl-test item x)) - 'cl-test-not)) - (list 'cl-if - (list 'eq (list 'not (list 'funcall 'cl-if x)) 'cl-if-not)) - (list 't (list 'if (list 'numberp item) - (list 'equal item x) (list 'eq item x))))) - -(defmacro cl-check-test (item x) - (list 'cl-check-test-nokey item (list 'cl-check-key x))) - -(defmacro cl-check-match (x y) - (setq x (list 'cl-check-key x) y (list 'cl-check-key y)) - (list 'if 'cl-test - (list 'eq (list 'not (list 'funcall 'cl-test x y)) 'cl-test-not) - (list 'if (list 'numberp x) - (list 'equal x y) (list 'eq x y)))) - -(put 'cl-check-key 'edebug-form-spec 'edebug-forms) -(put 'cl-check-test 'edebug-form-spec 'edebug-forms) -(put 'cl-check-test-nokey 'edebug-form-spec 'edebug-forms) -(put 'cl-check-match 'edebug-form-spec 'edebug-forms) - -(defvar cl-test) (defvar cl-test-not) -(defvar cl-if) (defvar cl-if-not) -(defvar cl-key) - - -(defun reduce (cl-func cl-seq &rest cl-keys) - "Reduce two-argument FUNCTION across SEQUENCE. -Keywords supported: :start :end :from-end :initial-value :key" - (cl-parsing-keywords (:from-end (:start 0) :end :initial-value :key) () - (or (listp cl-seq) (setq cl-seq (append cl-seq nil))) - (setq cl-seq (subseq cl-seq cl-start cl-end)) - (if cl-from-end (setq cl-seq (nreverse cl-seq))) - (let ((cl-accum (cond ((memq ':initial-value cl-keys) cl-initial-value) - (cl-seq (cl-check-key (cl-pop cl-seq))) - (t (funcall cl-func))))) - (if cl-from-end - (while cl-seq - (setq cl-accum (funcall cl-func (cl-check-key (cl-pop cl-seq)) - cl-accum))) - (while cl-seq - (setq cl-accum (funcall cl-func cl-accum - (cl-check-key (cl-pop cl-seq)))))) - cl-accum))) - -(defun fill (seq item &rest cl-keys) - "Fill the elements of SEQ with ITEM. -Keywords supported: :start :end" - (cl-parsing-keywords ((:start 0) :end) () - (if (listp seq) - (let ((p (nthcdr cl-start seq)) - (n (if cl-end (- cl-end cl-start) 8000000))) - (while (and p (>= (setq n (1- n)) 0)) - (setcar p item) - (setq p (cdr p)))) - (or cl-end (setq cl-end (length seq))) - (if (and (= cl-start 0) (= cl-end (length seq))) - (fillarray seq item) - (while (< cl-start cl-end) - (aset seq cl-start item) - (setq cl-start (1+ cl-start))))) - seq)) - -(defun replace (cl-seq1 cl-seq2 &rest cl-keys) - "Replace the elements of SEQ1 with the elements of SEQ2. -SEQ1 is destructively modified, then returned. -Keywords supported: :start1 :end1 :start2 :end2" - (cl-parsing-keywords ((:start1 0) :end1 (:start2 0) :end2) () - (if (and (eq cl-seq1 cl-seq2) (<= cl-start2 cl-start1)) - (or (= cl-start1 cl-start2) - (let* ((cl-len (length cl-seq1)) - (cl-n (min (- (or cl-end1 cl-len) cl-start1) - (- (or cl-end2 cl-len) cl-start2)))) - (while (>= (setq cl-n (1- cl-n)) 0) - (cl-set-elt cl-seq1 (+ cl-start1 cl-n) - (elt cl-seq2 (+ cl-start2 cl-n)))))) - (if (listp cl-seq1) - (let ((cl-p1 (nthcdr cl-start1 cl-seq1)) - (cl-n1 (if cl-end1 (- cl-end1 cl-start1) 4000000))) - (if (listp cl-seq2) - (let ((cl-p2 (nthcdr cl-start2 cl-seq2)) - (cl-n (min cl-n1 - (if cl-end2 (- cl-end2 cl-start2) 4000000)))) - (while (and cl-p1 cl-p2 (>= (setq cl-n (1- cl-n)) 0)) - (setcar cl-p1 (car cl-p2)) - (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2)))) - (setq cl-end2 (min (or cl-end2 (length cl-seq2)) - (+ cl-start2 cl-n1))) - (while (and cl-p1 (< cl-start2 cl-end2)) - (setcar cl-p1 (aref cl-seq2 cl-start2)) - (setq cl-p1 (cdr cl-p1) cl-start2 (1+ cl-start2))))) - (setq cl-end1 (min (or cl-end1 (length cl-seq1)) - (+ cl-start1 (- (or cl-end2 (length cl-seq2)) - cl-start2)))) - (if (listp cl-seq2) - (let ((cl-p2 (nthcdr cl-start2 cl-seq2))) - (while (< cl-start1 cl-end1) - (aset cl-seq1 cl-start1 (car cl-p2)) - (setq cl-p2 (cdr cl-p2) cl-start1 (1+ cl-start1)))) - (while (< cl-start1 cl-end1) - (aset cl-seq1 cl-start1 (aref cl-seq2 cl-start2)) - (setq cl-start2 (1+ cl-start2) cl-start1 (1+ cl-start1)))))) - cl-seq1)) - -(defun remove* (cl-item cl-seq &rest cl-keys) - "Remove all occurrences of ITEM in SEQ. -This is a non-destructive function; it makes a copy of SEQ if necessary -to avoid corrupting the original SEQ. -Keywords supported: :test :test-not :key :count :start :end :from-end" - (cl-parsing-keywords (:test :test-not :key :if :if-not :count :from-end - (:start 0) :end) () - (if (<= (or cl-count (setq cl-count 8000000)) 0) - cl-seq - (if (or (nlistp cl-seq) (and cl-from-end (< cl-count 4000000))) - (let ((cl-i (cl-position cl-item cl-seq cl-start cl-end - cl-from-end))) - (if cl-i - (let ((cl-res (apply 'delete* cl-item (append cl-seq nil) - (append (if cl-from-end - (list ':end (1+ cl-i)) - (list ':start cl-i)) - cl-keys)))) - (if (listp cl-seq) cl-res - (if (stringp cl-seq) (concat cl-res) (vconcat cl-res)))) - cl-seq)) - (setq cl-end (- (or cl-end 8000000) cl-start)) - (if (= cl-start 0) - (while (and cl-seq (> cl-end 0) - (cl-check-test cl-item (car cl-seq)) - (setq cl-end (1- cl-end) cl-seq (cdr cl-seq)) - (> (setq cl-count (1- cl-count)) 0)))) - (if (and (> cl-count 0) (> cl-end 0)) - (let ((cl-p (if (> cl-start 0) (nthcdr cl-start cl-seq) - (setq cl-end (1- cl-end)) (cdr cl-seq)))) - (while (and cl-p (> cl-end 0) - (not (cl-check-test cl-item (car cl-p)))) - (setq cl-p (cdr cl-p) cl-end (1- cl-end))) - (if (and cl-p (> cl-end 0)) - (nconc (ldiff cl-seq cl-p) - (if (= cl-count 1) (cdr cl-p) - (and (cdr cl-p) - (apply 'delete* cl-item - (copy-sequence (cdr cl-p)) - ':start 0 ':end (1- cl-end) - ':count (1- cl-count) cl-keys)))) - cl-seq)) - cl-seq))))) - -(defun remove-if (cl-pred cl-list &rest cl-keys) - "Remove all items satisfying PREDICATE in SEQ. -This is a non-destructive function; it makes a copy of SEQ if necessary -to avoid corrupting the original SEQ. -Keywords supported: :key :count :start :end :from-end" - (apply 'remove* nil cl-list ':if cl-pred cl-keys)) - -(defun remove-if-not (cl-pred cl-list &rest cl-keys) - "Remove all items not satisfying PREDICATE in SEQ. -This is a non-destructive function; it makes a copy of SEQ if necessary -to avoid corrupting the original SEQ. -Keywords supported: :key :count :start :end :from-end" - (apply 'remove* nil cl-list ':if-not cl-pred cl-keys)) - -(defun delete* (cl-item cl-seq &rest cl-keys) - "Remove all occurrences of ITEM in SEQ. -This is a destructive function; it reuses the storage of SEQ whenever possible. -Keywords supported: :test :test-not :key :count :start :end :from-end" - (cl-parsing-keywords (:test :test-not :key :if :if-not :count :from-end - (:start 0) :end) () - (if (<= (or cl-count (setq cl-count 8000000)) 0) - cl-seq - (if (listp cl-seq) - (if (and cl-from-end (< cl-count 4000000)) - (let (cl-i) - (while (and (>= (setq cl-count (1- cl-count)) 0) - (setq cl-i (cl-position cl-item cl-seq cl-start - cl-end cl-from-end))) - (if (= cl-i 0) (setq cl-seq (cdr cl-seq)) - (let ((cl-tail (nthcdr (1- cl-i) cl-seq))) - (setcdr cl-tail (cdr (cdr cl-tail))))) - (setq cl-end cl-i)) - cl-seq) - (setq cl-end (- (or cl-end 8000000) cl-start)) - (if (= cl-start 0) - (progn - (while (and cl-seq - (> cl-end 0) - (cl-check-test cl-item (car cl-seq)) - (setq cl-end (1- cl-end) cl-seq (cdr cl-seq)) - (> (setq cl-count (1- cl-count)) 0))) - (setq cl-end (1- cl-end))) - (setq cl-start (1- cl-start))) - (if (and (> cl-count 0) (> cl-end 0)) - (let ((cl-p (nthcdr cl-start cl-seq))) - (while (and (cdr cl-p) (> cl-end 0)) - (if (cl-check-test cl-item (car (cdr cl-p))) - (progn - (setcdr cl-p (cdr (cdr cl-p))) - (if (= (setq cl-count (1- cl-count)) 0) - (setq cl-end 1))) - (setq cl-p (cdr cl-p))) - (setq cl-end (1- cl-end))))) - cl-seq) - (apply 'remove* cl-item cl-seq cl-keys))))) - -(defun delete-if (cl-pred cl-list &rest cl-keys) - "Remove all items satisfying PREDICATE in SEQ. -This is a destructive function; it reuses the storage of SEQ whenever possible. -Keywords supported: :key :count :start :end :from-end" - (apply 'delete* nil cl-list ':if cl-pred cl-keys)) - -(defun delete-if-not (cl-pred cl-list &rest cl-keys) - "Remove all items not satisfying PREDICATE in SEQ. -This is a destructive function; it reuses the storage of SEQ whenever possible. -Keywords supported: :key :count :start :end :from-end" - (apply 'delete* nil cl-list ':if-not cl-pred cl-keys)) - -(or (and (fboundp 'delete) (subrp (symbol-function 'delete))) - (defalias 'delete (function (lambda (x y) (delete* x y ':test 'equal))))) - -(defun remove (cl-item cl-seq) - "Remove all occurrences of ITEM in SEQ, testing with `equal' -This is a non-destructive function; it makes a copy of SEQ if necessary -to avoid corrupting the original SEQ. -Also see: `remove*', `delete', `delete*'" - (remove* cl-item cl-seq ':test 'equal)) - -(defun remq (cl-elt cl-list) - "Remove all occurances of ELT in LIST, comparing with `eq'. -This is a non-destructive function; it makes a copy of LIST to avoid -corrupting the original LIST. -Also see: `delq', `delete', `delete*', `remove', `remove*'." - (if (memq cl-elt cl-list) - (delq cl-elt (copy-list cl-list)) - cl-list)) - -(defun remove-duplicates (cl-seq &rest cl-keys) - "Return a copy of SEQ with all duplicate elements removed. -Keywords supported: :test :test-not :key :start :end :from-end" - (cl-delete-duplicates cl-seq cl-keys t)) - -(defun delete-duplicates (cl-seq &rest cl-keys) - "Remove all duplicate elements from SEQ (destructively). -Keywords supported: :test :test-not :key :start :end :from-end" - (cl-delete-duplicates cl-seq cl-keys nil)) - -(defun cl-delete-duplicates (cl-seq cl-keys cl-copy) - (if (listp cl-seq) - (cl-parsing-keywords (:test :test-not :key (:start 0) :end :from-end :if) - () - (if cl-from-end - (let ((cl-p (nthcdr cl-start cl-seq)) cl-i) - (setq cl-end (- (or cl-end (length cl-seq)) cl-start)) - (while (> cl-end 1) - (setq cl-i 0) - (while (setq cl-i (cl-position (cl-check-key (car cl-p)) - (cdr cl-p) cl-i (1- cl-end))) - (if cl-copy (setq cl-seq (copy-sequence cl-seq) - cl-p (nthcdr cl-start cl-seq) cl-copy nil)) - (let ((cl-tail (nthcdr cl-i cl-p))) - (setcdr cl-tail (cdr (cdr cl-tail)))) - (setq cl-end (1- cl-end))) - (setq cl-p (cdr cl-p) cl-end (1- cl-end) - cl-start (1+ cl-start))) - cl-seq) - (setq cl-end (- (or cl-end (length cl-seq)) cl-start)) - (while (and (cdr cl-seq) (= cl-start 0) (> cl-end 1) - (cl-position (cl-check-key (car cl-seq)) - (cdr cl-seq) 0 (1- cl-end))) - (setq cl-seq (cdr cl-seq) cl-end (1- cl-end))) - (let ((cl-p (if (> cl-start 0) (nthcdr (1- cl-start) cl-seq) - (setq cl-end (1- cl-end) cl-start 1) cl-seq))) - (while (and (cdr (cdr cl-p)) (> cl-end 1)) - (if (cl-position (cl-check-key (car (cdr cl-p))) - (cdr (cdr cl-p)) 0 (1- cl-end)) - (progn - (if cl-copy (setq cl-seq (copy-sequence cl-seq) - cl-p (nthcdr (1- cl-start) cl-seq) - cl-copy nil)) - (setcdr cl-p (cdr (cdr cl-p)))) - (setq cl-p (cdr cl-p))) - (setq cl-end (1- cl-end) cl-start (1+ cl-start))) - cl-seq))) - (let ((cl-res (cl-delete-duplicates (append cl-seq nil) cl-keys nil))) - (if (stringp cl-seq) (concat cl-res) (vconcat cl-res))))) - -(defun substitute (cl-new cl-old cl-seq &rest cl-keys) - "Substitute NEW for OLD in SEQ. -This is a non-destructive function; it makes a copy of SEQ if necessary -to avoid corrupting the original SEQ. -Keywords supported: :test :test-not :key :count :start :end :from-end" - (cl-parsing-keywords (:test :test-not :key :if :if-not :count - (:start 0) :end :from-end) () - (if (or (eq cl-old cl-new) - (<= (or cl-count (setq cl-from-end nil cl-count 8000000)) 0)) - cl-seq - (let ((cl-i (cl-position cl-old cl-seq cl-start cl-end))) - (if (not cl-i) - cl-seq - (setq cl-seq (copy-sequence cl-seq)) - (or cl-from-end - (progn (cl-set-elt cl-seq cl-i cl-new) - (setq cl-i (1+ cl-i) cl-count (1- cl-count)))) - (apply 'nsubstitute cl-new cl-old cl-seq ':count cl-count - ':start cl-i cl-keys)))))) - -(defun substitute-if (cl-new cl-pred cl-list &rest cl-keys) - "Substitute NEW for all items satisfying PREDICATE in SEQ. -This is a non-destructive function; it makes a copy of SEQ if necessary -to avoid corrupting the original SEQ. -Keywords supported: :key :count :start :end :from-end" - (apply 'substitute cl-new nil cl-list ':if cl-pred cl-keys)) - -(defun substitute-if-not (cl-new cl-pred cl-list &rest cl-keys) - "Substitute NEW for all items not satisfying PREDICATE in SEQ. -This is a non-destructive function; it makes a copy of SEQ if necessary -to avoid corrupting the original SEQ. -Keywords supported: :key :count :start :end :from-end" - (apply 'substitute cl-new nil cl-list ':if-not cl-pred cl-keys)) - -(defun nsubstitute (cl-new cl-old cl-seq &rest cl-keys) - "Substitute NEW for OLD in SEQ. -This is a destructive function; it reuses the storage of SEQ whenever possible. -Keywords supported: :test :test-not :key :count :start :end :from-end" - (cl-parsing-keywords (:test :test-not :key :if :if-not :count - (:start 0) :end :from-end) () - (or (eq cl-old cl-new) (<= (or cl-count (setq cl-count 8000000)) 0) - (if (and (listp cl-seq) (or (not cl-from-end) (> cl-count 4000000))) - (let ((cl-p (nthcdr cl-start cl-seq))) - (setq cl-end (- (or cl-end 8000000) cl-start)) - (while (and cl-p (> cl-end 0) (> cl-count 0)) - (if (cl-check-test cl-old (car cl-p)) - (progn - (setcar cl-p cl-new) - (setq cl-count (1- cl-count)))) - (setq cl-p (cdr cl-p) cl-end (1- cl-end)))) - (or cl-end (setq cl-end (length cl-seq))) - (if cl-from-end - (while (and (< cl-start cl-end) (> cl-count 0)) - (setq cl-end (1- cl-end)) - (if (cl-check-test cl-old (elt cl-seq cl-end)) - (progn - (cl-set-elt cl-seq cl-end cl-new) - (setq cl-count (1- cl-count))))) - (while (and (< cl-start cl-end) (> cl-count 0)) - (if (cl-check-test cl-old (aref cl-seq cl-start)) - (progn - (aset cl-seq cl-start cl-new) - (setq cl-count (1- cl-count)))) - (setq cl-start (1+ cl-start)))))) - cl-seq)) - -(defun nsubstitute-if (cl-new cl-pred cl-list &rest cl-keys) - "Substitute NEW for all items satisfying PREDICATE in SEQ. -This is a destructive function; it reuses the storage of SEQ whenever possible. -Keywords supported: :key :count :start :end :from-end" - (apply 'nsubstitute cl-new nil cl-list ':if cl-pred cl-keys)) - -(defun nsubstitute-if-not (cl-new cl-pred cl-list &rest cl-keys) - "Substitute NEW for all items not satisfying PREDICATE in SEQ. -This is a destructive function; it reuses the storage of SEQ whenever possible. -Keywords supported: :key :count :start :end :from-end" - (apply 'nsubstitute cl-new nil cl-list ':if-not cl-pred cl-keys)) - -(defun find (cl-item cl-seq &rest cl-keys) - "Find the first occurrence of ITEM in LIST. -Return the matching ITEM, or nil if not found. -Keywords supported: :test :test-not :key :start :end :from-end" - (let ((cl-pos (apply 'position cl-item cl-seq cl-keys))) - (and cl-pos (elt cl-seq cl-pos)))) - -(defun find-if (cl-pred cl-list &rest cl-keys) - "Find the first item satisfying PREDICATE in LIST. -Return the matching ITEM, or nil if not found. -Keywords supported: :key :start :end :from-end" - (apply 'find nil cl-list ':if cl-pred cl-keys)) - -(defun find-if-not (cl-pred cl-list &rest cl-keys) - "Find the first item not satisfying PREDICATE in LIST. -Return the matching ITEM, or nil if not found. -Keywords supported: :key :start :end :from-end" - (apply 'find nil cl-list ':if-not cl-pred cl-keys)) - -(defun position (cl-item cl-seq &rest cl-keys) - "Find the first occurrence of ITEM in LIST. -Return the index of the matching item, or nil if not found. -Keywords supported: :test :test-not :key :start :end :from-end" - (cl-parsing-keywords (:test :test-not :key :if :if-not - (:start 0) :end :from-end) () - (cl-position cl-item cl-seq cl-start cl-end cl-from-end))) - -(defun cl-position (cl-item cl-seq cl-start &optional cl-end cl-from-end) - (if (listp cl-seq) - (let ((cl-p (nthcdr cl-start cl-seq))) - (or cl-end (setq cl-end 8000000)) - (let ((cl-res nil)) - (while (and cl-p (< cl-start cl-end) (or (not cl-res) cl-from-end)) - (if (cl-check-test cl-item (car cl-p)) - (setq cl-res cl-start)) - (setq cl-p (cdr cl-p) cl-start (1+ cl-start))) - cl-res)) - (or cl-end (setq cl-end (length cl-seq))) - (if cl-from-end - (progn - (while (and (>= (setq cl-end (1- cl-end)) cl-start) - (not (cl-check-test cl-item (aref cl-seq cl-end))))) - (and (>= cl-end cl-start) cl-end)) - (while (and (< cl-start cl-end) - (not (cl-check-test cl-item (aref cl-seq cl-start)))) - (setq cl-start (1+ cl-start))) - (and (< cl-start cl-end) cl-start)))) - -(defun position-if (cl-pred cl-list &rest cl-keys) - "Find the first item satisfying PREDICATE in LIST. -Return the index of the matching item, or nil if not found. -Keywords supported: :key :start :end :from-end" - (apply 'position nil cl-list ':if cl-pred cl-keys)) - -(defun position-if-not (cl-pred cl-list &rest cl-keys) - "Find the first item not satisfying PREDICATE in LIST. -Return the index of the matching item, or nil if not found. -Keywords supported: :key :start :end :from-end" - (apply 'position nil cl-list ':if-not cl-pred cl-keys)) - -(defun count (cl-item cl-seq &rest cl-keys) - "Count the number of occurrences of ITEM in LIST. -Keywords supported: :test :test-not :key :start :end" - (cl-parsing-keywords (:test :test-not :key :if :if-not (:start 0) :end) () - (let ((cl-count 0) cl-x) - (or cl-end (setq cl-end (length cl-seq))) - (if (consp cl-seq) (setq cl-seq (nthcdr cl-start cl-seq))) - (while (< cl-start cl-end) - (setq cl-x (if (consp cl-seq) (cl-pop cl-seq) (aref cl-seq cl-start))) - (if (cl-check-test cl-item cl-x) (setq cl-count (1+ cl-count))) - (setq cl-start (1+ cl-start))) - cl-count))) - -(defun count-if (cl-pred cl-list &rest cl-keys) - "Count the number of items satisfying PREDICATE in LIST. -Keywords supported: :key :start :end" - (apply 'count nil cl-list ':if cl-pred cl-keys)) - -(defun count-if-not (cl-pred cl-list &rest cl-keys) - "Count the number of items not satisfying PREDICATE in LIST. -Keywords supported: :key :start :end" - (apply 'count nil cl-list ':if-not cl-pred cl-keys)) - -(defun mismatch (cl-seq1 cl-seq2 &rest cl-keys) - "Compare SEQ1 with SEQ2, return index of first mismatching element. -Return nil if the sequences match. If one sequence is a prefix of the -other, the return value indicates the end of the shorted sequence. -Keywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end" - (cl-parsing-keywords (:test :test-not :key :from-end - (:start1 0) :end1 (:start2 0) :end2) () - (or cl-end1 (setq cl-end1 (length cl-seq1))) - (or cl-end2 (setq cl-end2 (length cl-seq2))) - (if cl-from-end - (progn - (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2) - (cl-check-match (elt cl-seq1 (1- cl-end1)) - (elt cl-seq2 (1- cl-end2)))) - (setq cl-end1 (1- cl-end1) cl-end2 (1- cl-end2))) - (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2)) - (1- cl-end1))) - (let ((cl-p1 (and (listp cl-seq1) (nthcdr cl-start1 cl-seq1))) - (cl-p2 (and (listp cl-seq2) (nthcdr cl-start2 cl-seq2)))) - (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2) - (cl-check-match (if cl-p1 (car cl-p1) - (aref cl-seq1 cl-start1)) - (if cl-p2 (car cl-p2) - (aref cl-seq2 cl-start2)))) - (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2) - cl-start1 (1+ cl-start1) cl-start2 (1+ cl-start2))) - (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2)) - cl-start1))))) - -(defun search (cl-seq1 cl-seq2 &rest cl-keys) - "Search for SEQ1 as a subsequence of SEQ2. -Return the index of the leftmost element of the first match found; -return nil if there are no matches. -Keywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end" - (cl-parsing-keywords (:test :test-not :key :from-end - (:start1 0) :end1 (:start2 0) :end2) () - (or cl-end1 (setq cl-end1 (length cl-seq1))) - (or cl-end2 (setq cl-end2 (length cl-seq2))) - (if (>= cl-start1 cl-end1) - (if cl-from-end cl-end2 cl-start2) - (let* ((cl-len (- cl-end1 cl-start1)) - (cl-first (cl-check-key (elt cl-seq1 cl-start1))) - (cl-if nil) cl-pos) - (setq cl-end2 (- cl-end2 (1- cl-len))) - (while (and (< cl-start2 cl-end2) - (setq cl-pos (cl-position cl-first cl-seq2 - cl-start2 cl-end2 cl-from-end)) - (apply 'mismatch cl-seq1 cl-seq2 - ':start1 (1+ cl-start1) ':end1 cl-end1 - ':start2 (1+ cl-pos) ':end2 (+ cl-pos cl-len) - ':from-end nil cl-keys)) - (if cl-from-end (setq cl-end2 cl-pos) (setq cl-start2 (1+ cl-pos)))) - (and (< cl-start2 cl-end2) cl-pos))))) - -(defun sort* (cl-seq cl-pred &rest cl-keys) - "Sort the argument SEQUENCE according to PREDICATE. -This is a destructive function; it reuses the storage of SEQUENCE if possible. -Keywords supported: :key" - (if (nlistp cl-seq) - (replace cl-seq (apply 'sort* (append cl-seq nil) cl-pred cl-keys)) - (cl-parsing-keywords (:key) () - (if (memq cl-key '(nil identity)) - (sort cl-seq cl-pred) - (sort cl-seq (function (lambda (cl-x cl-y) - (funcall cl-pred (funcall cl-key cl-x) - (funcall cl-key cl-y))))))))) - -(defun stable-sort (cl-seq cl-pred &rest cl-keys) - "Sort the argument SEQUENCE stably according to PREDICATE. -This is a destructive function; it reuses the storage of SEQUENCE if possible. -Keywords supported: :key" - (apply 'sort* cl-seq cl-pred cl-keys)) - -(defun merge (cl-type cl-seq1 cl-seq2 cl-pred &rest cl-keys) - "Destructively merge the two sequences to produce a new sequence. -TYPE is the sequence type to return, SEQ1 and SEQ2 are the two -argument sequences, and PRED is a `less-than' predicate on the elements. -Keywords supported: :key" - (or (listp cl-seq1) (setq cl-seq1 (append cl-seq1 nil))) - (or (listp cl-seq2) (setq cl-seq2 (append cl-seq2 nil))) - (cl-parsing-keywords (:key) () - (let ((cl-res nil)) - (while (and cl-seq1 cl-seq2) - (if (funcall cl-pred (cl-check-key (car cl-seq2)) - (cl-check-key (car cl-seq1))) - (cl-push (cl-pop cl-seq2) cl-res) - (cl-push (cl-pop cl-seq1) cl-res))) - (coerce (nconc (nreverse cl-res) cl-seq1 cl-seq2) cl-type)))) - -;;; See compiler macro in cl-macs.el -(defun member* (cl-item cl-list &rest cl-keys) - "Find the first occurrence of ITEM in LIST. -Return the sublist of LIST whose car is ITEM. -Keywords supported: :test :test-not :key" - (if cl-keys - (cl-parsing-keywords (:test :test-not :key :if :if-not) () - (while (and cl-list (not (cl-check-test cl-item (car cl-list)))) - (setq cl-list (cdr cl-list))) - cl-list) - (if (and (numberp cl-item) (not (integerp cl-item))) - (member cl-item cl-list) - (memq cl-item cl-list)))) - -(defun member-if (cl-pred cl-list &rest cl-keys) - "Find the first item satisfying PREDICATE in LIST. -Return the sublist of LIST whose car matches. -Keywords supported: :key" - (apply 'member* nil cl-list ':if cl-pred cl-keys)) - -(defun member-if-not (cl-pred cl-list &rest cl-keys) - "Find the first item not satisfying PREDICATE in LIST. -Return the sublist of LIST whose car matches. -Keywords supported: :key" - (apply 'member* nil cl-list ':if-not cl-pred cl-keys)) - -(defun cl-adjoin (cl-item cl-list &rest cl-keys) - (if (cl-parsing-keywords (:key) t - (apply 'member* (cl-check-key cl-item) cl-list cl-keys)) - cl-list - (cons cl-item cl-list))) - -;;; See compiler macro in cl-macs.el -(defun assoc* (cl-item cl-alist &rest cl-keys) - "Find the first item whose car matches ITEM in LIST. -Keywords supported: :test :test-not :key" - (if cl-keys - (cl-parsing-keywords (:test :test-not :key :if :if-not) () - (while (and cl-alist - (or (not (consp (car cl-alist))) - (not (cl-check-test cl-item (car (car cl-alist)))))) - (setq cl-alist (cdr cl-alist))) - (and cl-alist (car cl-alist))) - (if (and (numberp cl-item) (not (integerp cl-item))) - (assoc cl-item cl-alist) - (assq cl-item cl-alist)))) - -(defun assoc-if (cl-pred cl-list &rest cl-keys) - "Find the first item whose car satisfies PREDICATE in LIST. -Keywords supported: :key" - (apply 'assoc* nil cl-list ':if cl-pred cl-keys)) - -(defun assoc-if-not (cl-pred cl-list &rest cl-keys) - "Find the first item whose car does not satisfy PREDICATE in LIST. -Keywords supported: :key" - (apply 'assoc* nil cl-list ':if-not cl-pred cl-keys)) - -(defun rassoc* (cl-item cl-alist &rest cl-keys) - "Find the first item whose cdr matches ITEM in LIST. -Keywords supported: :test :test-not :key" - (if (or cl-keys (numberp cl-item)) - (cl-parsing-keywords (:test :test-not :key :if :if-not) () - (while (and cl-alist - (or (not (consp (car cl-alist))) - (not (cl-check-test cl-item (cdr (car cl-alist)))))) - (setq cl-alist (cdr cl-alist))) - (and cl-alist (car cl-alist))) - (rassq cl-item cl-alist))) - -(defun rassoc-if (cl-pred cl-list &rest cl-keys) - "Find the first item whose cdr satisfies PREDICATE in LIST. -Keywords supported: :key" - (apply 'rassoc* nil cl-list ':if cl-pred cl-keys)) - -(defun rassoc-if-not (cl-pred cl-list &rest cl-keys) - "Find the first item whose cdr does not satisfy PREDICATE in LIST. -Keywords supported: :key" - (apply 'rassoc* nil cl-list ':if-not cl-pred cl-keys)) - -(defun union (cl-list1 cl-list2 &rest cl-keys) - "Combine LIST1 and LIST2 using a set-union operation. -The result list contains all items that appear in either LIST1 or LIST2. -This is a non-destructive function; it makes a copy of the data if necessary -to avoid corrupting the original LIST1 and LIST2. -Keywords supported: :test :test-not :key" - (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) - ((equal cl-list1 cl-list2) cl-list1) - (t - (or (>= (length cl-list1) (length cl-list2)) - (setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1)))) - (while cl-list2 - (if (or cl-keys (numberp (car cl-list2))) - (setq cl-list1 (apply 'adjoin (car cl-list2) cl-list1 cl-keys)) - (or (memq (car cl-list2) cl-list1) - (cl-push (car cl-list2) cl-list1))) - (cl-pop cl-list2)) - cl-list1))) - -(defun nunion (cl-list1 cl-list2 &rest cl-keys) - "Combine LIST1 and LIST2 using a set-union operation. -The result list contains all items that appear in either LIST1 or LIST2. -This is a destructive function; it reuses the storage of LIST1 and LIST2 -whenever possible. -Keywords supported: :test :test-not :key" - (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) - (t (apply 'union cl-list1 cl-list2 cl-keys)))) - -(defun intersection (cl-list1 cl-list2 &rest cl-keys) - "Combine LIST1 and LIST2 using a set-intersection operation. -The result list contains all items that appear in both LIST1 and LIST2. -This is a non-destructive function; it makes a copy of the data if necessary -to avoid corrupting the original LIST1 and LIST2. -Keywords supported: :test :test-not :key" - (and cl-list1 cl-list2 - (if (equal cl-list1 cl-list2) cl-list1 - (cl-parsing-keywords (:key) (:test :test-not) - (let ((cl-res nil)) - (or (>= (length cl-list1) (length cl-list2)) - (setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1)))) - (while cl-list2 - (if (if (or cl-keys (numberp (car cl-list2))) - (apply 'member* (cl-check-key (car cl-list2)) - cl-list1 cl-keys) - (memq (car cl-list2) cl-list1)) - (cl-push (car cl-list2) cl-res)) - (cl-pop cl-list2)) - cl-res))))) - -(defun nintersection (cl-list1 cl-list2 &rest cl-keys) - "Combine LIST1 and LIST2 using a set-intersection operation. -The result list contains all items that appear in both LIST1 and LIST2. -This is a destructive function; it reuses the storage of LIST1 and LIST2 -whenever possible. -Keywords supported: :test :test-not :key" - (and cl-list1 cl-list2 (apply 'intersection cl-list1 cl-list2 cl-keys))) - -(defun set-difference (cl-list1 cl-list2 &rest cl-keys) - "Combine LIST1 and LIST2 using a set-difference operation. -The result list contains all items that appear in LIST1 but not LIST2. -This is a non-destructive function; it makes a copy of the data if necessary -to avoid corrupting the original LIST1 and LIST2. -Keywords supported: :test :test-not :key" - (if (or (null cl-list1) (null cl-list2)) cl-list1 - (cl-parsing-keywords (:key) (:test :test-not) - (let ((cl-res nil)) - (while cl-list1 - (or (if (or cl-keys (numberp (car cl-list1))) - (apply 'member* (cl-check-key (car cl-list1)) - cl-list2 cl-keys) - (memq (car cl-list1) cl-list2)) - (cl-push (car cl-list1) cl-res)) - (cl-pop cl-list1)) - cl-res)))) - -(defun nset-difference (cl-list1 cl-list2 &rest cl-keys) - "Combine LIST1 and LIST2 using a set-difference operation. -The result list contains all items that appear in LIST1 but not LIST2. -This is a destructive function; it reuses the storage of LIST1 and LIST2 -whenever possible. -Keywords supported: :test :test-not :key" - (if (or (null cl-list1) (null cl-list2)) cl-list1 - (apply 'set-difference cl-list1 cl-list2 cl-keys))) - -(defun set-exclusive-or (cl-list1 cl-list2 &rest cl-keys) - "Combine LIST1 and LIST2 using a set-exclusive-or operation. -The result list contains all items that appear in exactly one of LIST1, LIST2. -This is a non-destructive function; it makes a copy of the data if necessary -to avoid corrupting the original LIST1 and LIST2. -Keywords supported: :test :test-not :key" - (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) - ((equal cl-list1 cl-list2) nil) - (t (append (apply 'set-difference cl-list1 cl-list2 cl-keys) - (apply 'set-difference cl-list2 cl-list1 cl-keys))))) - -(defun nset-exclusive-or (cl-list1 cl-list2 &rest cl-keys) - "Combine LIST1 and LIST2 using a set-exclusive-or operation. -The result list contains all items that appear in exactly one of LIST1, LIST2. -This is a destructive function; it reuses the storage of LIST1 and LIST2 -whenever possible. -Keywords supported: :test :test-not :key" - (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) - ((equal cl-list1 cl-list2) nil) - (t (nconc (apply 'nset-difference cl-list1 cl-list2 cl-keys) - (apply 'nset-difference cl-list2 cl-list1 cl-keys))))) - -(defun subsetp (cl-list1 cl-list2 &rest cl-keys) - "True if LIST1 is a subset of LIST2. -I.e., if every element of LIST1 also appears in LIST2. -Keywords supported: :test :test-not :key" - (cond ((null cl-list1) t) ((null cl-list2) nil) - ((equal cl-list1 cl-list2) t) - (t (cl-parsing-keywords (:key) (:test :test-not) - (while (and cl-list1 - (apply 'member* (cl-check-key (car cl-list1)) - cl-list2 cl-keys)) - (cl-pop cl-list1)) - (null cl-list1))))) - -(defun subst-if (cl-new cl-pred cl-tree &rest cl-keys) - "Substitute NEW for elements matching PREDICATE in TREE (non-destructively). -Return a copy of TREE with all matching elements replaced by NEW. -Keywords supported: :key" - (apply 'sublis (list (cons nil cl-new)) cl-tree ':if cl-pred cl-keys)) - -(defun subst-if-not (cl-new cl-pred cl-tree &rest cl-keys) - "Substitute NEW for elts not matching PREDICATE in TREE (non-destructively). -Return a copy of TREE with all non-matching elements replaced by NEW. -Keywords supported: :key" - (apply 'sublis (list (cons nil cl-new)) cl-tree ':if-not cl-pred cl-keys)) - -(defun nsubst (cl-new cl-old cl-tree &rest cl-keys) - "Substitute NEW for OLD everywhere in TREE (destructively). -Any element of TREE which is `eql' to OLD is changed to NEW (via a call -to `setcar'). -Keywords supported: :test :test-not :key" - (apply 'nsublis (list (cons cl-old cl-new)) cl-tree cl-keys)) - -(defun nsubst-if (cl-new cl-pred cl-tree &rest cl-keys) - "Substitute NEW for elements matching PREDICATE in TREE (destructively). -Any element of TREE which matches is changed to NEW (via a call to `setcar'). -Keywords supported: :key" - (apply 'nsublis (list (cons nil cl-new)) cl-tree ':if cl-pred cl-keys)) - -(defun nsubst-if-not (cl-new cl-pred cl-tree &rest cl-keys) - "Substitute NEW for elements not matching PREDICATE in TREE (destructively). -Any element of TREE which matches is changed to NEW (via a call to `setcar'). -Keywords supported: :key" - (apply 'nsublis (list (cons nil cl-new)) cl-tree ':if-not cl-pred cl-keys)) - -(defun sublis (cl-alist cl-tree &rest cl-keys) - "Perform substitutions indicated by ALIST in TREE (non-destructively). -Return a copy of TREE with all matching elements replaced. -Keywords supported: :test :test-not :key" - (cl-parsing-keywords (:test :test-not :key :if :if-not) () - (cl-sublis-rec cl-tree))) - -(defvar cl-alist) -(defun cl-sublis-rec (cl-tree) ; uses cl-alist/key/test*/if* - (let ((cl-temp (cl-check-key cl-tree)) (cl-p cl-alist)) - (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp))) - (setq cl-p (cdr cl-p))) - (if cl-p (cdr (car cl-p)) - (if (consp cl-tree) - (let ((cl-a (cl-sublis-rec (car cl-tree))) - (cl-d (cl-sublis-rec (cdr cl-tree)))) - (if (and (eq cl-a (car cl-tree)) (eq cl-d (cdr cl-tree))) - cl-tree - (cons cl-a cl-d))) - cl-tree)))) - -(defun nsublis (cl-alist cl-tree &rest cl-keys) - "Perform substitutions indicated by ALIST in TREE (destructively). -Any matching element of TREE is changed via a call to `setcar'. -Keywords supported: :test :test-not :key" - (cl-parsing-keywords (:test :test-not :key :if :if-not) () - (let ((cl-hold (list cl-tree))) - (cl-nsublis-rec cl-hold) - (car cl-hold)))) - -(defun cl-nsublis-rec (cl-tree) ; uses cl-alist/temp/p/key/test*/if* - (while (consp cl-tree) - (let ((cl-temp (cl-check-key (car cl-tree))) (cl-p cl-alist)) - (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp))) - (setq cl-p (cdr cl-p))) - (if cl-p (setcar cl-tree (cdr (car cl-p))) - (if (consp (car cl-tree)) (cl-nsublis-rec (car cl-tree)))) - (setq cl-temp (cl-check-key (cdr cl-tree)) cl-p cl-alist) - (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp))) - (setq cl-p (cdr cl-p))) - (if cl-p - (progn (setcdr cl-tree (cdr (car cl-p))) (setq cl-tree nil)) - (setq cl-tree (cdr cl-tree)))))) - -(defun tree-equal (cl-x cl-y &rest cl-keys) - "T if trees X and Y have `eql' leaves. -Atoms are compared by `eql'; cons cells are compared recursively. -Keywords supported: :test :test-not :key" - (cl-parsing-keywords (:test :test-not :key) () - (cl-tree-equal-rec cl-x cl-y))) - -(defun cl-tree-equal-rec (cl-x cl-y) - (while (and (consp cl-x) (consp cl-y) - (cl-tree-equal-rec (car cl-x) (car cl-y))) - (setq cl-x (cdr cl-x) cl-y (cdr cl-y))) - (and (not (consp cl-x)) (not (consp cl-y)) (cl-check-match cl-x cl-y))) - - -(run-hooks 'cl-seq-load-hook) - -;;; cl-seq.el ends here
--- a/lisp/cl/cl.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,736 +0,0 @@ -;;; cl.el --- Common Lisp extensions for GNU Emacs Lisp - -;; Copyright (C) 1993 Free Software Foundation, Inc. - -;; Author: Dave Gillespie <daveg@synaptics.com> -;; Version: 2.02 -;; Keywords: extensions, lisp - -;; 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.34. - -;;; Commentary: - -;; These are extensions to Emacs Lisp that provide a degree of -;; Common Lisp compatibility, beyond what is already built-in -;; in Emacs Lisp. -;; -;; This package was written by Dave Gillespie; it is a complete -;; rewrite of Cesar Quiroz's original cl.el package of December 1986. -;; -;; This package works with Emacs 18, Emacs 19, and XEmacs/Lucid Emacs 19. -;; -;; Bug reports, comments, and suggestions are welcome! - -;; This file contains the portions of the Common Lisp extensions -;; package which should always be present. - - -;;; Future notes: - -;; Once Emacs 19 becomes standard, many things in this package which are -;; messy for reasons of compatibility can be greatly simplified. For now, -;; I prefer to maintain one unified version. - - -;;; Change Log: - -;; Version 2.02 (30 Jul 93): -;; * Added "cl-compat.el" file, extra compatibility with old package. -;; * Added `lexical-let' and `lexical-let*'. -;; * Added `define-modify-macro', `callf', and `callf2'. -;; * Added `ignore-errors'. -;; * Changed `(setf (nthcdr N PLACE) X)' to work when N is zero. -;; * Merged `*gentemp-counter*' into `*gensym-counter*'. -;; * Extended `subseq' to allow negative START and END like `substring'. -;; * Added `in-ref', `across-ref', `elements of-ref' loop clauses. -;; * Added `concat', `vconcat' loop clauses. -;; * Cleaned up a number of compiler warnings. - -;; Version 2.01 (7 Jul 93): -;; * Added support for FSF version of Emacs 19. -;; * Added `add-hook' for Emacs 18 users. -;; * Added `defsubst*' and `symbol-macrolet'. -;; * Added `maplist', `mapc', `mapl', `mapcan', `mapcon'. -;; * Added `map', `concatenate', `reduce', `merge'. -;; * Added `revappend', `nreconc', `tailp', `tree-equal'. -;; * Added `assert', `check-type', `typecase', `typep', and `deftype'. -;; * Added destructuring and `&environment' support to `defmacro*'. -;; * Added destructuring to `loop', and added the following clauses: -;; `elements', `frames', `overlays', `intervals', `buffers', `key-seqs'. -;; * Renamed `delete' to `delete*' and `remove' to `remove*'. -;; * Completed support for all keywords in `remove*', `substitute', etc. -;; * Added `most-positive-float' and company. -;; * Fixed hash tables to work with latest Lucid Emacs. -;; * `proclaim' forms are no longer compile-time-evaluating; use `declaim'. -;; * Syntax for `warn' declarations has changed. -;; * Improved implementation of `random*'. -;; * Moved most sequence functions to a new file, cl-seq.el. -;; * Moved `eval-when' into cl-macs.el. -;; * Moved `pushnew' and `adjoin' to cl.el for most common cases. -;; * Moved `provide' forms down to ends of files. -;; * Changed expansion of `pop' to something that compiles to better code. -;; * Changed so that no patch is required for Emacs 19 byte compiler. -;; * Made more things dependent on `optimize' declarations. -;; * Added a partial implementation of struct print functions. -;; * Miscellaneous minor changes. - -;; Version 2.00: -;; * First public release of this package. - - -;;; Code: - -(defvar cl-emacs-type (cond ((or (and (fboundp 'epoch::version) - (symbol-value 'epoch::version)) - (string-lessp emacs-version "19")) 18) - ((string-match "XEmacs" emacs-version) - 'lucid) - (t 19))) - -(or (fboundp 'defalias) (fset 'defalias 'fset)) - -(defvar cl-optimize-speed 1) -(defvar cl-optimize-safety 1) - - -;;; Keywords used in this package. - -;;; XEmacs - keywords are done in Fintern(). -;;; -;;; (defconst :test ':test) -;;; (defconst :test-not ':test-not) -;;; (defconst :key ':key) -;;; (defconst :start ':start) -;;; (defconst :start1 ':start1) -;;; (defconst :start2 ':start2) -;;; (defconst :end ':end) -;;; (defconst :end1 ':end1) -;;; (defconst :end2 ':end2) -;;; (defconst :count ':count) -;;; (defconst :initial-value ':initial-value) -;;; (defconst :size ':size) -;;; (defconst :from-end ':from-end) -;;; (defconst :rehash-size ':rehash-size) -;;; (defconst :rehash-threshold ':rehash-threshold) -;;; (defconst :allow-other-keys ':allow-other-keys) - - -(defvar custom-print-functions nil - "This is a list of functions that format user objects for printing. -Each function is called in turn with three arguments: the object, the -stream, and the print level (currently ignored). If it is able to -print the object it returns true; otherwise it returns nil and the -printer proceeds to the next function on the list. - -This variable is not used at present, but it is defined in hopes that -a future Emacs interpreter will be able to use it.") - - -;;; Predicates. - -(defun eql (a b) ; See compiler macro in cl-macs.el - "T if the two args are the same Lisp object. -Floating-point numbers of equal value are `eql', but they may not be `eq'." - (if (numberp a) - (equal a b) - (eq a b))) - - -;;; Generalized variables. These macros are defined here so that they -;;; can safely be used in .emacs files. - -(defmacro incf (place &optional x) - "(incf PLACE [X]): increment PLACE by X (1 by default). -PLACE may be a symbol, or any generalized variable allowed by `setf'. -The return value is the incremented value of PLACE." - (if (symbolp place) - (list 'setq place (if x (list '+ place x) (list '1+ place))) - (list 'callf '+ place (or x 1)))) - -(defmacro decf (place &optional x) - "(decf PLACE [X]): decrement PLACE by X (1 by default). -PLACE may be a symbol, or any generalized variable allowed by `setf'. -The return value is the decremented value of PLACE." - (if (symbolp place) - (list 'setq place (if x (list '- place x) (list '1- place))) - (list 'callf '- place (or x 1)))) - -(defmacro pop (place) - "(pop PLACE): remove and return the head of the list stored in PLACE. -Analogous to (prog1 (car PLACE) (setf PLACE (cdr PLACE))), though more -careful about evaluating each argument only once and in the right order. -PLACE may be a symbol, or any generalized variable allowed by `setf'." - (if (symbolp place) - (list 'car (list 'prog1 place (list 'setq place (list 'cdr place)))) - (cl-do-pop place))) - -(defmacro push (x place) - "(push X PLACE): insert X at the head of the list stored in PLACE. -Analogous to (setf PLACE (cons X PLACE)), though more careful about -evaluating each argument only once and in the right order. PLACE may -be a symbol, or any generalized variable allowed by `setf'." - (if (symbolp place) (list 'setq place (list 'cons x place)) - (list 'callf2 'cons x place))) - -(defmacro pushnew (x place &rest keys) - "(pushnew X PLACE): insert X at the head of the list if not already there. -Like (push X PLACE), except that the list is unmodified if X is `eql' to -an element already on the list. -Keywords supported: :test :test-not :key" - (if (symbolp place) (list 'setq place (list* 'adjoin x place keys)) - (list* 'callf2 'adjoin x place keys))) - -(defun cl-set-elt (seq n val) - (if (listp seq) (setcar (nthcdr n seq) val) (aset seq n val))) - -(defun cl-set-nthcdr (n list x) - (if (<= n 0) x (setcdr (nthcdr (1- n) list) x) list)) - -(defun cl-set-buffer-substring (start end val) - (save-excursion (delete-region start end) - (goto-char start) - (insert val) - val)) - -(defun cl-set-substring (str start end val) - (if end (if (< end 0) (incf end (length str))) - (setq end (length str))) - (if (< start 0) (incf start str)) - (concat (and (> start 0) (substring str 0 start)) - val - (and (< end (length str)) (substring str end)))) - - -;;; 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. - -(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)))) - -(defun cl-map-extents (&rest cl-args) - (if (fboundp 'next-overlay-at) (apply 'cl-map-overlays cl-args) - (if (fboundp 'map-extents) (apply 'map-extents cl-args)))) - - -;;; Blocks and exits. - -(defalias 'cl-block-wrapper 'identity) -(defalias 'cl-block-throw 'throw) - - -;;; Multiple values. True multiple values are not supported, or even -;;; simulated. Instead, multiple-value-bind and friends simply expect -;;; the target form to return the values as a list. - -(defalias 'values 'list) -(defalias 'values-list 'identity) -(defalias 'multiple-value-list 'identity) -(defalias 'multiple-value-call 'apply) ; only works for one arg -(defalias 'nth-value 'nth) - - -;;; Macros. - -(defvar cl-macro-environment nil) -;; XEmacs: we renamed the internal function to macroexpand-internal -;; to avoid doc-file problems. -(defvar cl-old-macroexpand (prog1 (symbol-function 'macroexpand-internal) - (defalias 'macroexpand 'cl-macroexpand))) - -(defun cl-macroexpand (cl-macro &optional cl-env) - "Return result of expanding macros at top level of FORM. -If FORM is not a macro call, it is returned unchanged. -Otherwise, the macro is expanded and the expansion is considered -in place of FORM. When a non-macro-call results, it is returned. - -The second optional arg ENVIRONMENT species an environment of macro -definitions to shadow the loaded ones for use in file byte-compilation." - (let ((cl-macro-environment cl-env)) - (while (progn (setq cl-macro (funcall cl-old-macroexpand cl-macro cl-env)) - (and (symbolp cl-macro) - (cdr (assq (symbol-name cl-macro) cl-env)))) - (setq cl-macro (cadr (assq (symbol-name cl-macro) cl-env)))) - cl-macro)) - - -;;; Declarations. - -(defvar cl-compiling-file nil) -(defun cl-compiling-file () - (or cl-compiling-file - ;; XEmacs change -; (and (boundp 'outbuffer) (bufferp (symbol-value 'outbuffer)) -; (equal (buffer-name (symbol-value 'outbuffer)) -; " *Compiler Output*")) - (and (boundp 'byte-compile-outbuffer) - (bufferp (symbol-value 'byte-compile-outbuffer)) - (equal (buffer-name (symbol-value 'byte-compile-outbuffer)) - " *Compiler Output*")) - )) - -(defvar cl-proclaims-deferred nil) - -(defun proclaim (spec) - (if (fboundp 'cl-do-proclaim) (cl-do-proclaim spec t) - (push spec cl-proclaims-deferred)) - nil) - -(defmacro declaim (&rest specs) - (let ((body (mapcar (function (lambda (x) (list 'proclaim (list 'quote x)))) - specs))) - (if (cl-compiling-file) (list* 'eval-when '(compile load eval) body) - (cons 'progn body)))) ; avoid loading cl-macs.el for eval-when - - -;;; Symbols. - -(defun cl-random-time () - (let* ((time (copy-sequence (current-time-string))) (i (length time)) (v 0)) - (while (>= (decf i) 0) (setq v (+ (* v 3) (aref time i)))) - v)) - -(defvar *gensym-counter* (* (logand (cl-random-time) 1023) 100)) - - -;;; Numbers. - -(defun floatp-safe (x) - "T if OBJECT is a floating point number. -On Emacs versions that lack floating-point support, this function -always returns nil." - (and (numberp x) (not (integerp x)))) - -(defun plusp (x) - "T if NUMBER is positive." - (> x 0)) - -(defun minusp (x) - "T if NUMBER is negative." - (< x 0)) - -(defun oddp (x) - "T if INTEGER is odd." - (eq (logand x 1) 1)) - -(defun evenp (x) - "T if INTEGER is even." - (eq (logand x 1) 0)) - -(defun cl-abs (x) - "Return the absolute value of ARG." - (if (>= x 0) x (- x))) -(or (fboundp 'abs) (defalias 'abs 'cl-abs)) ; This is built-in to Emacs 19 - -(defvar *random-state* (vector 'cl-random-state-tag -1 30 (cl-random-time))) - -;;; We use `eval' in case VALBITS differs from compile-time to load-time. -(defconst most-positive-fixnum (eval '(lsh -1 -1))) -(defconst most-negative-fixnum (eval '(- -1 (lsh -1 -1)))) - -;;; The following are actually set by cl-float-limits. -(defconst most-positive-float nil) -(defconst most-negative-float nil) -(defconst least-positive-float nil) -(defconst least-negative-float nil) -(defconst least-positive-normalized-float nil) -(defconst least-negative-normalized-float nil) -(defconst float-epsilon nil) -(defconst float-negative-epsilon nil) - - -;;; Sequence functions. - -(defalias 'copy-seq 'copy-sequence) - -(defun mapcar* (cl-func cl-x &rest cl-rest) - "Apply FUNCTION to each element of SEQ, and make a list of the results. -If there are several SEQs, FUNCTION is called with that many arguments, -and mapping stops as soon as the shortest list runs out. With just one -SEQ, this is like `mapcar'. With several, it is like the Common Lisp -`mapcar' function extended to arbitrary sequence types." - (if cl-rest - (if (or (cdr cl-rest) (nlistp cl-x) (nlistp (car cl-rest))) - (cl-mapcar-many cl-func (cons cl-x cl-rest)) - (let ((cl-res nil) (cl-y (car cl-rest))) - (while (and cl-x cl-y) - (push (funcall cl-func (pop cl-x) (pop cl-y)) cl-res)) - (nreverse cl-res))) - (mapcar cl-func cl-x))) - - -;;; List functions. - -(defalias 'first 'car) -(defalias 'rest 'cdr) -(defalias 'endp 'null) - -(defun second (x) - "Return the second element of the list LIST." - (car (cdr x))) - -(defun third (x) - "Return the third element of the list LIST." - (car (cdr (cdr x)))) - -(defun fourth (x) - "Return the fourth element of the list LIST." - (nth 3 x)) - -(defun fifth (x) - "Return the fifth element of the list LIST." - (nth 4 x)) - -(defun sixth (x) - "Return the sixth element of the list LIST." - (nth 5 x)) - -(defun seventh (x) - "Return the seventh element of the list LIST." - (nth 6 x)) - -(defun eighth (x) - "Return the eighth element of the list LIST." - (nth 7 x)) - -(defun ninth (x) - "Return the ninth element of the list LIST." - (nth 8 x)) - -(defun tenth (x) - "Return the tenth element of the list LIST." - (nth 9 x)) - -(defun caar (x) - "Return the `car' of the `car' of X." - (car (car x))) - -(defun cadr (x) - "Return the `car' of the `cdr' of X." - (car (cdr x))) - -(defun cdar (x) - "Return the `cdr' of the `car' of X." - (cdr (car x))) - -(defun cddr (x) - "Return the `cdr' of the `cdr' of X." - (cdr (cdr x))) - -(defun caaar (x) - "Return the `car' of the `car' of the `car' of X." - (car (car (car x)))) - -(defun caadr (x) - "Return the `car' of the `car' of the `cdr' of X." - (car (car (cdr x)))) - -(defun cadar (x) - "Return the `car' of the `cdr' of the `car' of X." - (car (cdr (car x)))) - -(defun caddr (x) - "Return the `car' of the `cdr' of the `cdr' of X." - (car (cdr (cdr x)))) - -(defun cdaar (x) - "Return the `cdr' of the `car' of the `car' of X." - (cdr (car (car x)))) - -(defun cdadr (x) - "Return the `cdr' of the `car' of the `cdr' of X." - (cdr (car (cdr x)))) - -(defun cddar (x) - "Return the `cdr' of the `cdr' of the `car' of X." - (cdr (cdr (car x)))) - -(defun cdddr (x) - "Return the `cdr' of the `cdr' of the `cdr' of X." - (cdr (cdr (cdr x)))) - -(defun caaaar (x) - "Return the `car' of the `car' of the `car' of the `car' of X." - (car (car (car (car x))))) - -(defun caaadr (x) - "Return the `car' of the `car' of the `car' of the `cdr' of X." - (car (car (car (cdr x))))) - -(defun caadar (x) - "Return the `car' of the `car' of the `cdr' of the `car' of X." - (car (car (cdr (car x))))) - -(defun caaddr (x) - "Return the `car' of the `car' of the `cdr' of the `cdr' of X." - (car (car (cdr (cdr x))))) - -(defun cadaar (x) - "Return the `car' of the `cdr' of the `car' of the `car' of X." - (car (cdr (car (car x))))) - -(defun cadadr (x) - "Return the `car' of the `cdr' of the `car' of the `cdr' of X." - (car (cdr (car (cdr x))))) - -(defun caddar (x) - "Return the `car' of the `cdr' of the `cdr' of the `car' of X." - (car (cdr (cdr (car x))))) - -(defun cadddr (x) - "Return the `car' of the `cdr' of the `cdr' of the `cdr' of X." - (car (cdr (cdr (cdr x))))) - -(defun cdaaar (x) - "Return the `cdr' of the `car' of the `car' of the `car' of X." - (cdr (car (car (car x))))) - -(defun cdaadr (x) - "Return the `cdr' of the `car' of the `car' of the `cdr' of X." - (cdr (car (car (cdr x))))) - -(defun cdadar (x) - "Return the `cdr' of the `car' of the `cdr' of the `car' of X." - (cdr (car (cdr (car x))))) - -(defun cdaddr (x) - "Return the `cdr' of the `car' of the `cdr' of the `cdr' of X." - (cdr (car (cdr (cdr x))))) - -(defun cddaar (x) - "Return the `cdr' of the `cdr' of the `car' of the `car' of X." - (cdr (cdr (car (car x))))) - -(defun cddadr (x) - "Return the `cdr' of the `cdr' of the `car' of the `cdr' of X." - (cdr (cdr (car (cdr x))))) - -(defun cdddar (x) - "Return the `cdr' of the `cdr' of the `cdr' of the `car' of X." - (cdr (cdr (cdr (car x))))) - -(defun cddddr (x) - "Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X." - (cdr (cdr (cdr (cdr x))))) - -(defun last (x &optional n) - "Returns the last link in the list LIST. -With optional argument N, returns 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) - "Returns 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) - "Modifies 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. -Thus, `(list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to -`(cons A (cons B (cons C D)))'." - (cond ((not rest) arg) - ((not (cdr rest)) (cons arg (car rest))) - (t (let* ((n (length rest)) - (copy (copy-sequence rest)) - (last (nthcdr (- n 2) copy))) - (setcdr last (car (cdr last))) - (cons arg copy))))) - -(defun ldiff (list sublist) - "Return a copy of LIST with the tail SUBLIST removed." - (let ((res nil)) - (while (and (consp list) (not (eq list sublist))) - (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))) - -(defun cl-maclisp-member (item list) - (while (and list (not (equal item (car list)))) (setq list (cdr list))) - list) - -;;; Define an Emacs 19-compatible `member' for the benefit of Emacs 18 users. -(or (and (fboundp 'member) (subrp (symbol-function 'member))) - (defalias 'member 'cl-maclisp-member)) - -(defalias 'cl-member 'memq) ; for compatibility with old CL package -(defalias 'cl-floor 'floor*) -(defalias 'cl-ceiling 'ceiling*) -(defalias 'cl-truncate 'truncate*) -(defalias 'cl-round 'round*) -(defalias 'cl-mod 'mod*) - -(defun adjoin (cl-item cl-list &rest cl-keys) ; See compiler macro in cl-macs - "Return ITEM consed onto the front of LIST only if it's not already there. -Otherwise, return LIST unmodified. -Keywords supported: :test :test-not :key" - (cond ((or (equal cl-keys '(:test eq)) - (and (null cl-keys) (not (numberp cl-item)))) - (if (memq cl-item cl-list) cl-list (cons cl-item cl-list))) - ((or (equal cl-keys '(:test equal)) (null cl-keys)) - (if (member cl-item cl-list) cl-list (cons cl-item cl-list))) - (t (apply 'cl-adjoin cl-item cl-list cl-keys)))) - -(defun subst (cl-new cl-old cl-tree &rest cl-keys) - "Substitute NEW for OLD everywhere in TREE (non-destructively). -Return a copy of TREE with all elements `eql' to OLD replaced by NEW. -Keywords supported: :test :test-not :key" - (if (or cl-keys (and (numberp cl-old) (not (integerp cl-old)))) - (apply 'sublis (list (cons cl-old cl-new)) cl-tree cl-keys) - (cl-do-subst cl-new cl-old cl-tree))) - -(defun cl-do-subst (cl-new cl-old cl-tree) - (cond ((eq cl-tree cl-old) cl-new) - ((consp cl-tree) - (let ((a (cl-do-subst cl-new cl-old (car cl-tree))) - (d (cl-do-subst cl-new cl-old (cdr cl-tree)))) - (if (and (eq a (car cl-tree)) (eq d (cdr cl-tree))) - cl-tree (cons a d)))) - (t cl-tree))) - -(defun acons (a b c) (cons (cons a b) c)) -(defun pairlis (a b &optional c) (nconc (mapcar* 'cons a b) c)) - - -;;; Miscellaneous. - -;; XEmacs change -(define-error 'cl-assertion-failed "Assertion failed") - -;;; This is defined in Emacs 19; define it here for Emacs 18 users. -(defun cl-add-hook (hook func &optional append) - "Add to hook variable HOOK the function FUNC. -FUNC is not added if it already appears on the list stored in HOOK." - (let ((old (and (boundp hook) (symbol-value hook)))) - (and (listp old) (not (eq (car old) 'lambda)) - (setq old (list old))) - (and (not (member func old)) - (set hook (if append (nconc old (list func)) (cons func old)))))) -(or (fboundp 'add-hook) (defalias 'add-hook 'cl-add-hook)) - -;; XEmacs change -;(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)))) - - -;;; This goes here so that cl-macs can find it if it loads right now. -(provide 'cl-19) ; usage: (require 'cl-19 "cl") - - -;;; Things to do after byte-compiler is loaded. -;;; As a side effect, we cause cl-macs to be loaded when compiling, so -;;; that the compiler-macros defined there will be present. - -(defvar cl-hacked-flag nil) -(defun cl-hack-byte-compiler () - (if (and (not cl-hacked-flag) (fboundp 'byte-compile-file-form)) - (progn - (cl-compile-time-init) ; in cl-macs.el - (setq cl-hacked-flag t)))) - -;;; Try it now in case the compiler has already been loaded. -(cl-hack-byte-compiler) - -;;; Also make a hook in case compiler is loaded after this file. -;;; The compiler doesn't call any hooks when it loads or runs, but -;;; we can take advantage of the fact that emacs-lisp-mode will be -;;; called when the compiler reads in the file to be compiled. -;;; BUG: If the first compilation is `byte-compile' rather than -;;; `byte-compile-file', we lose. Oh, well. -(add-hook 'emacs-lisp-mode-hook 'cl-hack-byte-compiler) - - -;;; The following ensures that packages which expect the old-style cl.el -;;; will be happy with this one. - -(provide 'cl) - -(provide 'mini-cl) ; for Epoch - -(run-hooks 'cl-load-hook) - -;;; cl.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cmdloop.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,549 @@ +;;; cmdloop.el --- support functions for the top-level command loop. + +;; Copyright (C) 1992-4, 1997 Free Software Foundation, Inc. + +;; Author: Richard Mlynarik +;; Date: 8-Jul-92 +;; Maintainer: XEmacs Development Team +;; Keywords: internal, dumped + +;; 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, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: FSF 19.30. (Some of the stuff below is in FSF's subr.el.) + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;;; Code: + +(defun recursion-depth () + "Return the current depth in recursive edits." + (+ command-loop-level (minibuffer-depth))) + +(defun top-level () + "Exit all recursive editing levels." + (interactive) + (throw 'top-level nil)) + +(defun exit-recursive-edit () + "Exit from the innermost recursive edit or minibuffer." + (interactive) + (if (> (recursion-depth) 0) + (throw 'exit nil)) + (error "No recursive edit is in progress")) + +(defun abort-recursive-edit () + "Abort the command that requested this recursive edit or minibuffer input." + (interactive) + (if (> (recursion-depth) 0) + (throw 'exit t)) + (error "No recursive edit is in progress")) + +;; (defun keyboard-quit () +;; "Signal a `quit' condition." +;; (interactive) +;; (deactivate-mark) +;; (signal 'quit nil)) + +;; moved here from pending-del. +(defun keyboard-quit () + "Signal a `quit' condition. +If this character is typed while lisp code is executing, it will be treated + as an interrupt. +If this character is typed at top-level, this simply beeps. +If `zmacs-regions' is true, and the zmacs region is active in this buffer, +then this key deactivates the region without beeping or signalling." + (interactive) + (if (and (region-active-p) + (eq (current-buffer) (zmacs-region-buffer))) + ;; pseudo-zmacs compatibility: don't beep if this ^G is simply + ;; deactivating the region. If it is inactive, beep. + nil + (signal 'quit nil))) + +(defvar buffer-quit-function nil + "Function to call to \"quit\" the current buffer, or nil if none. +\\[keyboard-escape-quit] calls this function when its more local actions +\(such as cancelling a prefix argument, minibuffer or region) do not apply.") + +(defun keyboard-escape-quit () + "Exit the current \"mode\" (in a generalized sense of the word). +This command can exit an interactive command such as `query-replace', +can clear out a prefix argument or a region, +can get out of the minibuffer or other recursive edit, +cancel the use of the current buffer (for special-purpose buffers), +or go back to just one window (by deleting all but the selected window)." + (interactive) + (cond ((eq last-command 'mode-exited) nil) + ((> (minibuffer-depth) 0) + (abort-recursive-edit)) + (current-prefix-arg + nil) + ((region-active-p) + (zmacs-deactivate-region)) + ((> (recursion-depth) 0) + (exit-recursive-edit)) + (buffer-quit-function + (funcall buffer-quit-function)) + ((not (one-window-p t)) + (delete-other-windows)) + ((string-match "^ \\*" (buffer-name (current-buffer))) + (bury-buffer)))) + +;;#### This should really be a ring of last errors. +(defvar last-error nil + "#### Document me.") + +;; #### Provisionally turned on for XEmacs 20.3beta. +(defcustom errors-deactivate-region nil + "*Non-nil means that errors will cause the region to be deactivated." + :type 'boolean + :group 'editing-basics) + +(defun command-error (error-object) + (let ((inhibit-quit t) + (debug-on-error nil) + (etype (car-safe error-object))) + (setq quit-flag nil) + (setq standard-output t) + (setq standard-input t) + (setq executing-kbd-macro nil) + (and errors-deactivate-region + (zmacs-deactivate-region)) + (discard-input) + + (setq last-error error-object) + + (message nil) + (ding nil (cond ((eq etype 'undefined-keystroke-sequence) + (if (and (vectorp (nth 1 error-object)) + (/= 0 (length (nth 1 error-object))) + (button-event-p (aref (nth 1 error-object) 0))) + 'undefined-click + 'undefined-key)) + ((eq etype 'quit) + 'quit) + ((memq etype '(end-of-buffer beginning-of-buffer)) + 'buffer-bound) + ((eq etype 'buffer-read-only) + 'read-only) + (t 'command-error))) + (display-error error-object t) + + (if (noninteractive) + (progn + (message "XEmacs exiting.") + (kill-emacs -1))) + t)) + +(defun describe-last-error () + "Redisplay the last error-message. See the variable `last-error'." + (interactive) + (with-displaying-help-buffer + (lambda () + (princ "Last error was:\n" standard-output) + (display-error last-error standard-output)))) + + +;;#### Must be done later in the loadup sequence +;(define-key (symbol-function 'help-command) "e" 'describe-last-error) + + +(defun truncate-command-history-for-gc () + (let ((tail (nthcdr 30 command-history))) + (if tail (setcdr tail nil))) + (let ((tail (nthcdr 30 values))) + (if tail (setcdr tail nil))) + ) + +(add-hook 'pre-gc-hook 'truncate-command-history-for-gc) + + +;;;; Object-oriented programming at its finest + +;; Now in src/print.c; used by Ferror_message_string and others +;(defun display-error (error-object stream) ;(defgeneric report-condition ...) +; "Display `error-object' on `stream' in a user-friendly way." +; (funcall (or (let ((type (car-safe error-object))) +; (catch 'error +; (and (consp error-object) +; (symbolp type) +; ;;(stringp (get type 'error-message)) +; (consp (get type 'error-conditions)) +; (let ((tail (cdr error-object))) +; (while (not (null tail)) +; (if (consp tail) +; (setq tail (cdr tail)) +; (throw 'error nil))) +; t) +; ;; (check-type condition condition) +; (get type 'error-conditions) +; ;; Search class hierarchy +; (let ((tail (get type 'error-conditions))) +; (while (not (null tail)) +; (cond ((not (and (consp tail) +; (symbolp (car tail)))) +; (throw 'error nil)) +; ((get (car tail) 'display-error) +; (throw 'error (get (car tail) +; 'display-error))) +; (t +; (setq tail (cdr tail))))) +; ;; Default method +; #'(lambda (error-object stream) +; (let ((type (car error-object)) +; (tail (cdr error-object)) +; (first t) +; (print-message-label 'error)) +; (if (eq type 'error) +; (progn (princ (car tail) stream) +; (setq tail (cdr tail))) +; (princ (or (gettext (get type 'error-message)) type) +; stream)) +; (while tail +; (princ (if first ": " ", ") stream) +; (prin1 (car tail) stream) +; (setq tail (cdr tail) +; first nil)))))))) +; #'(lambda (error-object stream) +; (princ (gettext "Peculiar error ") stream) +; (prin1 error-object stream))) +; error-object stream)) + +(put 'file-error 'display-error + #'(lambda (error-object stream) + (let ((tail (cdr error-object)) + (first t)) + (princ (car tail) stream) + (while (setq tail (cdr tail)) + (princ (if first ": " ", ") stream) + (princ (car tail) stream) + (setq first nil))))) + +(put 'undefined-keystroke-sequence 'display-error + #'(lambda (error-object stream) + (princ (key-description (car (cdr error-object))) stream) + ;; #### I18N3: doesn't localize properly. + (princ (gettext " not defined.") stream) ; doo dah, doo dah. + )) + + +(defcustom teach-extended-commands-p t + "*If true, then `\\[execute-extended-command]' will teach you keybindings. +Any time you execute a command with \\[execute-extended-command] which has a +shorter keybinding, you will be shown the alternate binding before the +command executes. There is a short pause after displaying the binding, +before executing it; the length can be controlled by +`teach-extended-commands-timeout'." + :type 'boolean + :group 'keyboard) + +(defcustom teach-extended-commands-timeout 4 + "*How long to pause after displaying a keybinding before executing. +The value is measured in seconds. This only applies if +`teach-extended-commands-p' is true." + :type 'number + :group 'keyboard) + +;That damn RMS went off and implemented something differently, after +;we had already implemented it. We can't support both properly until +;we have Lisp magic variables. +;(defvar suggest-key-bindings t +; "*FSFmacs equivalent of `teach-extended-commands-*'. +;Provided for compatibility only. +;Non-nil means show the equivalent key-binding when M-x command has one. +;The value can be a length of time to show the message for. +;If the value is non-nil and not a number, we wait 2 seconds.") +; +;(make-obsolete-variable 'suggest-key-bindings 'teach-extended-commands-p) + +(defun execute-extended-command (prefix-arg) + "Read a command name from the minibuffer using 'completing-read'. +Then call the specified command using 'command-execute' and return its +return value. If the command asks for a prefix argument, supply the +value of the current raw prefix argument, or the value of PREFIX-ARG +when called from Lisp." + (interactive "P") + ;; Note: This doesn't hack "this-command-keys" + (let ((prefix-arg prefix-arg)) + (setq this-command (read-command + ;; Note: this has the hard-wired + ;; "C-u" and "M-x" string bug in common + ;; with all GNU Emacs's. + ;; (i.e. it prints C-u and M-x regardless of + ;; whether some other keys were actually bound + ;; to `execute-extended-command' and + ;; `universal-argument'. + (cond ((eq prefix-arg '-) + "- M-x ") + ((equal prefix-arg '(4)) + "C-u M-x ") + ((integerp prefix-arg) + (format "%d M-x " prefix-arg)) + ((and (consp prefix-arg) + (integerp (car prefix-arg))) + (format "%d M-x " (car prefix-arg))) + (t + "M-x "))))) + + (if (and teach-extended-commands-p + (interactive-p)) + ;; We need to fiddle with keys: remember the keys, run the + ;; command, and show the keys (if any). + (let ((_execute_command_keys_ (where-is-internal this-command)) + (_execute_command_name_ this-command)) ; the name can change + (command-execute this-command t) + (when (and _execute_command_keys_ + ;; Wait for a while, so the user can see a message + ;; printed, if any. + (sit-for 1)) + (display-message + 'no-log + (format "Command `%s' is bound to key%s: %s" + _execute_command_name_ + (if (cdr _execute_command_keys_) "s" "") + (sorted-key-descriptions _execute_command_keys_))) + (sit-for teach-extended-commands-timeout) + (clear-message 'no-log))) + ;; Else, just run the command. + (command-execute this-command t))) + + +;;; C code calls this; the underscores in the variable names are to avoid +;;; cluttering the specbind namespace (lexical scope! lexical scope!) +;;; Putting this in Lisp instead of C slows kbd macros by 50%. +;(defun command-execute (_command &optional _record-flag) +; "Execute CMD as an editor command. +;CMD must be a symbol that satisfies the `commandp' predicate. +;Optional second arg RECORD-FLAG non-nil +;means unconditionally put this command in `command-history'. +;Otherwise, that is done only if an arg is read using the minibuffer." +; (let ((_prefix prefix-arg) +; (_cmd (indirect-function _command))) +; (setq prefix-arg nil +; this-command _command +; current-prefix-arg _prefix +; zmacs-region-stays nil) +; ;; #### debug_on_next_call = 0; +; (cond ((and (symbolp _command) +; (get _command 'disabled)) +; (run-hooks disabled-command-hook)) +; ((or (stringp _cmd) (vectorp _cmd)) +; ;; If requested, place the macro in the command history. +; ;; For other sorts of commands, call-interactively takes +; ;; care of this. +; (if _record-flag +; (setq command-history +; (cons (list 'execute-kbd-macro _cmd _prefix) +; command-history))) +; (execute-kbd-macro _cmd _prefix)) +; (t +; (call-interactively _command _record-flag))))) + +(defun y-or-n-p-minibuf (prompt) + "Ask user a \"y or n\" question. Return t if answer is \"y\". +Takes one argument, which is the string to display to ask the question. +It should end in a space; `y-or-n-p' adds `(y or n) ' to it. +No confirmation of the answer is requested; a single character is enough. +Also accepts Space to mean yes, or Delete to mean no." + (save-excursion + (let* ((pre "") + (yn (gettext "(y or n) ")) + ;; we need to translate the prompt ourselves because of the + ;; strange way we handle it. + (prompt (gettext prompt)) + event) + (while (stringp yn) + (if (let ((cursor-in-echo-area t) + (inhibit-quit t)) + (message "%s%s%s" pre prompt yn) + (setq event (next-command-event event)) + (condition-case nil + (prog1 + (or quit-flag (eq 'keyboard-quit (key-binding event))) + (setq quit-flag nil)) + (wrong-type-argument t))) + (progn + (message "%s%s%s%s" pre prompt yn (single-key-description event)) + (setq quit-flag nil) + (signal 'quit '()))) + (let* ((keys (events-to-keys (vector event))) + (def (lookup-key query-replace-map keys))) + (cond ((eq def 'skip) + (message "%s%sNo" prompt yn) + (setq yn nil)) + ((eq def 'act) + (message "%s%sYes" prompt yn) + (setq yn t)) + ((eq def 'recenter) + (recenter)) + ((or (eq def 'quit) (eq def 'exit-prefix)) + (signal 'quit '())) + ((button-release-event-p event) ; ignore them + nil) + (t + (message "%s%s%s%s" pre prompt yn + (single-key-description event)) + (ding nil 'y-or-n-p) + (discard-input) + (if (= (length pre) 0) + (setq pre (gettext "Please answer y or n. "))))))) + yn))) + +(defun yes-or-no-p-minibuf (prompt) + "Ask user a yes-or-no question. Return t if answer is yes. +Takes one argument, which is the string to display to ask the question. +It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it. +The user must confirm the answer with RET, +and can edit it until it has been confirmed." + (save-excursion + (let ((p (concat (gettext prompt) (gettext "(yes or no) "))) + (ans "")) + (while (stringp ans) + (setq ans (downcase (read-string p nil t))) ;no history + (cond ((string-equal ans (gettext "yes")) + (setq ans 't)) + ((string-equal ans (gettext "no")) + (setq ans 'nil)) + (t + (ding nil 'yes-or-no-p) + (discard-input) + (message "Please answer yes or no.") + (sleep-for 2)))) + ans))) + +;; these may be redefined later, but make the original def easily encapsulable +(define-function 'yes-or-no-p 'yes-or-no-p-minibuf) +(define-function 'y-or-n-p 'y-or-n-p-minibuf) + + +(defun read-char () + "Read a character from the command input (keyboard or macro). +If a mouse click or non-ASCII character is detected, an error is +signalled. The character typed is returned as an ASCII value. This +is most likely the wrong thing for you to be using: consider using +the `next-command-event' function instead." + (save-excursion + (let* ((inhibit-quit t) + (event (next-command-event))) + (prog1 (or (event-to-character event) + ;; Kludge. If the event we read was a mouse-release, + ;; discard it and read the next one. + (if (button-release-event-p event) + (event-to-character (next-command-event event))) + (error "Key read has no ASCII equivalent %S" event)) + ;; this is not necessary, but is marginally more efficient than GC. + (deallocate-event event))))) + +(defun read-char-exclusive () + "Read a character from the command input (keyboard or macro). +If a mouse click or non-ASCII character is detected, it is discarded. +The character typed is returned as an ASCII value. This is most likely +the wrong thing for you to be using: consider using the +`next-command-event' function instead." + (let ((inhibit-quit t) + event ch) + (while (progn + (setq event (next-command-event)) + (setq ch (event-to-character event)) + (deallocate-event event) + (null ch))) + ch)) + +(defun read-quoted-char (&optional prompt) + "Like `read-char', except that if the first character read is an octal +digit, we read up to two more octal digits and return the character +represented by the octal number consisting of those digits. +Optional argument PROMPT specifies a string to use to prompt the user." + (save-excursion + (let ((count 0) (code 0) + (prompt (and prompt (gettext prompt))) + char event) + (while (< count 3) + (let ((inhibit-quit (zerop count)) + ;; Don't let C-h get the help message--only help function keys. + (help-char nil) + (help-form + "Type the special character you want to use, +or three octal digits representing its character code.")) + (and prompt (display-message 'prompt (format "%s-" prompt))) + (setq event (next-command-event) + char (or (event-to-character event nil nil t) + (error "key read cannot be inserted in a buffer: %S" + event))) + (if inhibit-quit (setq quit-flag nil))) + (cond ((null char)) + ((and (<= ?0 char) (<= char ?7)) + (setq code (+ (* code 8) (- char ?0)) + count (1+ count)) + (and prompt (display-message + 'prompt + (setq prompt (format "%s %c" prompt char))))) + ((> count 0) + (setq unread-command-event event + count 259)) + (t (setq code char count 259)))) + ;; Turn a meta-character into a character with the 0200 bit set. + (logior (if (/= (logand code ?\M-\^@) 0) 128 0) + (logand 255 code))))) + +(defun momentary-string-display (string pos &optional exit-char message) + "Momentarily display STRING in the buffer at POS. +Display remains until next character is typed. +If the char is EXIT-CHAR (optional third arg, default is SPC) it is swallowed; +otherwise it is then available as input (as a command if nothing else). +Display MESSAGE (optional fourth arg) in the echo area. +If MESSAGE is nil, instructions to type EXIT-CHAR are displayed there." + (or exit-char (setq exit-char ?\ )) + (let ((buffer-read-only nil) + ;; Don't modify the undo list at all. + (buffer-undo-list t) + (modified (buffer-modified-p)) + (name buffer-file-name) + insert-end) + (unwind-protect + (progn + (save-excursion + (goto-char pos) + ;; defeat file locking... don't try this at home, kids! + (setq buffer-file-name nil) + (insert-before-markers (gettext string)) + (setq insert-end (point)) + ;; If the message end is off frame, recenter now. + (if (> (window-end) insert-end) + (recenter (/ (window-height) 2))) + ;; If that pushed message start off the frame, + ;; scroll to start it at the top of the frame. + (move-to-window-line 0) + (if (> (point) pos) + (progn + (goto-char pos) + (recenter 0)))) + (message (or message (gettext "Type %s to continue editing.")) + (single-key-description exit-char)) + (let ((event (save-excursion (next-command-event)))) + (or (eq (event-to-character event) exit-char) + (setq unread-command-event event)))) + (if insert-end + (save-excursion + (delete-region pos insert-end))) + (setq buffer-file-name name) + (set-buffer-modified-p modified)))) + +;;; cmdloop.el ends here
--- a/lisp/comint/auto-autoloads.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,252 +0,0 @@ -;;; DO NOT MODIFY THIS FILE -(if (featurep 'comint-autoloads) (error "Already loaded")) - -;;;### (autoloads (background) "background" "comint/background.el") - -(autoload 'background "background" "\ -Run COMMAND in the background like csh. -A message is displayed when the job starts and finishes. The buffer is in -comint mode, so you can send input and signals to the job. The process object -is returned if anyone cares. See also comint-mode and the variables -background-show and background-select. - -Optional second argument BUFFER-NAME is a buffer to insert the output into. -If omitted, a buffer name is constructed from the command run." t nil) - -;;;*** - -;;;### (autoloads (comint-dynamic-list-completions comint-dynamic-complete comint-run make-comint) "comint" "comint/comint.el") - -(autoload 'make-comint "comint" "\ -Make a comint process NAME in a buffer, running PROGRAM. -The name of the buffer is made by surrounding NAME with `*'s. -PROGRAM should be either a string denoting an executable program to create -via `start-process', or a cons pair of the form (HOST . SERVICE) denoting a TCP -connection to be opened via `open-network-stream'. If there is already a -running process in that buffer, it is not restarted. Optional third arg -STARTFILE is the name of a file to send the contents of to the process. - -If PROGRAM is a string, any more args are arguments to PROGRAM." nil nil) - -(autoload 'comint-run "comint" "\ -Run PROGRAM in a comint buffer and switch to it. -The buffer name is made by surrounding the file name of PROGRAM with `*'s. -The file name is used to make a symbol name, such as `comint-sh-hook', and any -hooks on this symbol are run in the buffer. -See `make-comint' and `comint-exec'." t nil) - -(autoload 'comint-dynamic-complete "comint" "\ -Dynamically perform completion at point. -Calls the functions in `comint-dynamic-complete-functions' to perform -completion until a function returns non-nil, at which point completion is -assumed to have occurred." t nil) - -(autoload 'comint-dynamic-list-completions "comint" "\ -List in help buffer sorted COMPLETIONS. -Typing SPC flushes the help buffer." nil nil) - -;;;*** - -;;;### (autoloads (gdb-with-core gdb) "gdb" "comint/gdb.el") - -(defvar gdb-command-name "gdb" "\ -Pathname for executing gdb.") - -(autoload 'gdb "gdb" "\ -Run gdb on program FILE in buffer *gdb-FILE*. -The directory containing FILE becomes the initial working directory -and source-file directory for GDB. If you wish to change this, use -the GDB commands `cd DIR' and `directory'." t nil) - -(autoload 'gdb-with-core "gdb" "\ -Debug a program using a corefile." t nil) - -;;;*** - -;;;### (autoloads (gdbsrc) "gdbsrc" "comint/gdbsrc.el") - -(autoload 'gdbsrc "gdbsrc" "\ -Activates a gdb session with gdbsrc-mode turned on. A numeric prefix -argument can be used to specify a running process to attach, and a non-numeric -prefix argument will cause you to be prompted for a core file to debug." t nil) - -;;;*** - -;;;### (autoloads (perldb xdb dbx sdb) "gud" "comint/gud.el") - -(autoload 'sdb "gud" "\ -Run sdb on program FILE in buffer *gud-FILE*. -The directory containing FILE becomes the initial working directory -and source-file directory for your debugger." t nil) - -(autoload 'dbx "gud" "\ -Run dbx on program FILE in buffer *gud-FILE*. -The directory containing FILE becomes the initial working directory -and source-file directory for your debugger." t nil) - -(autoload 'xdb "gud" "\ -Run xdb on program FILE in buffer *gud-FILE*. -The directory containing FILE becomes the initial working directory -and source-file directory for your debugger. - -You can set the variable 'gud-xdb-directories' to a list of program source -directories if your program contains sources from more than one directory." t nil) - -(autoload 'perldb "gud" "\ -Run perldb on program FILE in buffer *gud-FILE*. -The directory containing FILE becomes the initial working directory -and source-file directory for your debugger." t nil) - -;;;*** - -;;;### (autoloads nil "inf-lisp" "comint/inf-lisp.el") - -(add-hook 'same-window-buffer-names "*inferior-lisp*") - -;;;*** - -;;;### (autoloads (rlogin) "rlogin" "comint/rlogin.el") - -(add-hook 'same-window-regexps "^\\*rlogin-.*\\*\\(\\|<[0-9]+>\\)") - -(autoload 'rlogin "rlogin" "\ -Open a network login connection to HOST via the `rlogin' program. -Input is sent line-at-a-time to the remote connection. - -Communication with the remote host is recorded in a buffer `*rlogin-HOST*' -\(or `*rlogin-USER@HOST*' if the remote username differs). -If a prefix argument is given and the buffer `*rlogin-HOST*' already exists, -a new buffer with a different connection will be made. - -When called from a program, if the optional second argument is a string or -buffer, it names the buffer to use. - -The variable `rlogin-program' contains the name of the actual program to -run. It can be a relative or absolute path. - -The variable `rlogin-explicit-args' is a list of arguments to give to -the rlogin when starting. They are added after any arguments given in -INPUT-ARGS. - -If the default value of `rlogin-directory-tracking-mode' is t, then the -default directory in that buffer is set to a remote (FTP) file name to -access your home directory on the remote machine. Occasionally this causes -an error, if you cannot access the home directory on that machine. This -error is harmless as long as you don't try to use that default directory. - -If `rlogin-directory-tracking-mode' is neither t nor nil, then the default -directory is initially set up to your (local) home directory. -This is useful if the remote machine and your local machine -share the same files via NFS. This is the default. - -If you wish to change directory tracking styles during a session, use the -function `rlogin-directory-tracking-mode' rather than simply setting the -variable." t nil) - -;;;*** - -;;;### (autoloads (shell) "shell" "comint/shell.el") - -(defvar shell-prompt-pattern (purecopy "^[^#$%>\n]*[#$%>] *") "\ -Regexp to match prompts in the inferior shell. -Defaults to \"^[^#$%>\\n]*[#$%>] *\", which works pretty well. -This variable is used to initialise `comint-prompt-regexp' in the -shell buffer. - -The pattern should probably not match more than one line. If it does, -shell-mode may become confused trying to distinguish prompt from input -on lines which don't start with a prompt. - -This is a fine thing to set in your `.emacs' file.") - -(autoload 'shell "shell" "\ -Run an inferior shell, with I/O through buffer *shell*. -If buffer exists but shell process is not running, make new shell. -If buffer exists and shell process is running, - just switch to buffer `*shell*'. -Program used comes from variable `explicit-shell-file-name', - or (if that is nil) from the ESHELL environment variable, - or else from SHELL if there is no ESHELL. -If a file `~/.emacs_SHELLNAME' exists, it is given as initial input - (Note that this may lose due to a timing error if the shell - discards input when it starts up.) -The buffer is put in Shell mode, giving commands for sending input -and controlling the subjobs of the shell. See `shell-mode'. -See also the variable `shell-prompt-pattern'. - -The shell file name (sans directories) is used to make a symbol name -such as `explicit-csh-args'. If that symbol is a variable, -its value is used as a list of arguments when invoking the shell. -Otherwise, one argument `-i' is passed to the shell. - -\(Type \\[describe-mode] in the shell buffer for a list of commands.)" t nil) - -(add-hook 'same-window-buffer-names "*shell*") - -;;;*** - -;;;### (autoloads (ssh) "ssh" "comint/ssh.el") - -(add-hook 'same-window-regexps "^\\*ssh-.*\\*\\(\\|<[0-9]+>\\)") - -(autoload 'ssh "ssh" "\ -Open a network login connection via `ssh' with args INPUT-ARGS. -INPUT-ARGS should start with a host name; it may also contain -other arguments for `ssh'. - -Input is sent line-at-a-time to the remote connection. - -Communication with the remote host is recorded in a buffer `*ssh-HOST*' -\(or `*ssh-USER@HOST*' if the remote username differs). -If a prefix argument is given and the buffer `*ssh-HOST*' already exists, -a new buffer with a different connection will be made. - -When called from a program, if the optional second argument BUFFER is -a string or buffer, it specifies the buffer to use. - -The variable `ssh-program' contains the name of the actual program to -run. It can be a relative or absolute path. - -The variable `ssh-explicit-args' is a list of arguments to give to -the ssh when starting. They are prepended to any arguments given in -INPUT-ARGS. - -If the default value of `ssh-directory-tracking-mode' is t, then the -default directory in that buffer is set to a remote (FTP) file name to -access your home directory on the remote machine. Occasionally this causes -an error, if you cannot access the home directory on that machine. This -error is harmless as long as you don't try to use that default directory. - -If `ssh-directory-tracking-mode' is neither t nor nil, then the default -directory is initially set up to your (local) home directory. -This is useful if the remote machine and your local machine -share the same files via NFS. This is the default. - -If you wish to change directory tracking styles during a session, use the -function `ssh-directory-tracking-mode' rather than simply setting the -variable." t nil) - -;;;*** - -;;;### (autoloads (rsh telnet) "telnet" "comint/telnet.el") - -(add-hook 'same-window-regexps "\\*telnet-.*\\*\\(\\|<[0-9]+>\\)") - -(autoload 'telnet "telnet" "\ -Open a network login connection to host named HOST (a string). -With a prefix argument, prompts for the port name or number as well. -Communication with HOST is recorded in a buffer `*HOST-telnet*'. -Normally input is edited in Emacs and sent a line at a time. -See also `\\[rsh]'." t nil) - -(add-hook 'same-window-regexps "\\*rsh-[^-]*\\*\\(\\|<[0-9]*>\\)") - -(autoload 'rsh "telnet" "\ -Open a network login connection to host named HOST (a string). -Communication with HOST is recorded in a buffer `*rsh-HOST*'. -Normally input is edited in Emacs and sent a line at a time. -See also `\\[telnet]'." t nil) - -;;;*** - -(provide 'comint-autoloads)
--- a/lisp/comint/background.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,137 +0,0 @@ -;;; background.el --- fun with background jobs - -;; Copyright (C) 1988 Joe Keane <jk3k+@andrew.cmu.edu> -;; Keywords: processes - -;; 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 of the License, 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; 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: - -;; - Adapted to use comint and cleaned up somewhat. Olin Shivers 5/90 -;; - Background failed to set the process buffer's working directory -;; in some cases. Fixed. Olin 6/14/90 -;; - Background failed to strip leading cd's off the command string -;; after performing them. This screwed up relative pathnames. -;; Furthermore, the proc buffer's default dir wasn't initialised -;; to the user's buffer's default dir before doing the leading cd. -;; This also screwed up relative pathnames if the proc buffer already -;; existed and was set to a different default dir. Hopefully we've -;; finally got it right. The pwd is now reported in the buffer -;; just to let the user know. Bug reported by Piet Van Oostrum. -;; Olin 10/19/90 -;; - Fixed up the sentinel to protect match-data around invocations. -;; Also slightly rearranged the cd match code for similar reasons. -;; Olin 7/16/91 -;; - Dec 29 1995: changed for new stuff (shell-command-switch, second -;; arg to shell-command --> BUFFER-NAME arg to background) from -;; FSF 19.30. Ben Wing - -;;; Code: - -(provide 'background) -(require 'comint) - -(defgroup background nil - "Fun with background jobs" - :group 'processes) - - -;; user variables -(defcustom background-show t - "*If non-nil, background jobs' buffers are shown when they're started." - :type 'boolean - :group 'background) -(defcustom background-select nil - "*If non-nil, background jobs' buffers are selected when they're started." - :type 'boolean - :group 'background) - -;;;###autoload -(defun background (command &optional buffer-name) - "Run COMMAND in the background like csh. -A message is displayed when the job starts and finishes. The buffer is in -comint mode, so you can send input and signals to the job. The process object -is returned if anyone cares. See also comint-mode and the variables -background-show and background-select. - -Optional second argument BUFFER-NAME is a buffer to insert the output into. -If omitted, a buffer name is constructed from the command run." - (interactive "s%% ") - (let ((job-number 1) - job-name - (dir default-directory)) - (while (get-process (setq job-name (format "background-%d" job-number))) - (setq job-number (1+ job-number))) - (or buffer-name - (setq buffer-name (format "*%s*" job-name))) - (if background-select (pop-to-buffer buffer-name) - (if background-show (with-output-to-temp-buffer buffer-name)) ; cute - (set-buffer (get-buffer-create buffer-name))) - (erase-buffer) - - (setq default-directory dir) ; Do this first, in case cd is relative path. - (if (string-match "^cd[\t ]+\\([^\t ;]+\\)[\t ]*;[\t ]*" command) - (let ((dir (substring command (match-beginning 1) (match-end 1)))) - (setq command (substring command (match-end 0))) - (setq default-directory - (file-name-as-directory (expand-file-name dir))))) - - (insert "--- working directory: " default-directory - "\n% " command ?\n) - - (let ((proc (get-buffer-process - (comint-exec buffer-name job-name shell-file-name - nil (list shell-command-switch command))))) - (comint-mode) - ;; COND because the proc may have died before the G-B-P is called. - (cond (proc (set-process-sentinel proc 'background-sentinel) - (message "[%d] %d" job-number (process-id proc)))) - (setq mode-name "Background") - proc))) - - -(defun background-sentinel (process msg) - "Called when a background job changes state." - (let ((ms (match-data))) ; barf - (unwind-protect - (let ((msg (cond ((string= msg "finished\n") "Done") - ((string-match "^exited" msg) - (concat "Exit " (substring msg 28 -1))) - ((zerop (length msg)) "Continuing") - (t (concat (upcase (substring msg 0 1)) - (substring msg 1 -1)))))) - (message "[%s] %s %s" (process-name process) - msg - (nth 2 (process-command process))) - (if (null (buffer-name (process-buffer process))) - (set-process-buffer process nil) ; WHY? Olin. - (if (memq (process-status process) '(signal exit)) - (save-excursion - (set-buffer (process-buffer process)) - (let ((at-end (eobp))) - (save-excursion - (goto-char (point-max)) - (insert ?\n msg ? - (substring (current-time-string) 11 19) ?\n)) - (if at-end (goto-char (point-max)))) - (set-buffer-modified-p nil))))) - (store-match-data ms)))) - -;;; background.el ends here
--- a/lisp/comint/comint-xemacs.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,53 +0,0 @@ -;;; comint-xemacs.el --- Face customizations for comint - -;; Copyright (C) 1997 by Free Software Foundation, Inc. - -;; Author: Steven L Baur <steve@altair.xemacs.org> -;; Keywords: help, faces - -;; 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: - -;; Declare customizable faces for comint outside the main code so it can -;; be dumped with XEmacs. - -;;; Code: - -(defgroup comint nil - "General command interpreter in a window stuff." - :group 'processes) - -(defface comint-input-face '((((class color) - (background dark)) - (:foreground "red")) - (((class color) - (background light)) - (:foreground "blue")) - (t - (:bold t))) - "How to display user input for comint shells." - :group 'comint) - - - -(provide 'comint-xemacs) - -;;; comint-xemacs.el ends here
--- a/lisp/comint/comint.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2855 +0,0 @@ -;;; comint.el --- general command interpreter in a window stuff - -;; Copyright (C) 1988, 90, 92, 93, 94, 95 Free Software Foundation, Inc. - -;; Author: Olin Shivers <shivers@cs.cmu.edu> -;; Adapted-by: Simon Marshall <simon@gnu.ai.mit.edu> -;; Keywords: processes - -;; 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. - -;;; Commentary: - -;;; Please send me bug reports, bug fixes, and extensions, so that I can -;;; merge them into the master source. -;;; - Olin Shivers (shivers@cs.cmu.edu) -;;; - Simon Marshall (simon@gnu.ai.mit.edu) - -;;; This file defines a general command-interpreter-in-a-buffer package -;;; (comint mode). The idea is that you can build specific process-in-a-buffer -;;; modes on top of comint mode -- e.g., lisp, shell, scheme, T, soar, .... -;;; This way, all these specific packages share a common base functionality, -;;; and a common set of bindings, which makes them easier to use (and -;;; saves code, implementation time, etc., etc.). - -;;; Several packages are already defined using comint mode: -;;; - shell.el defines a shell-in-a-buffer mode. -;;; - cmulisp.el defines a simple lisp-in-a-buffer mode. -;;; -;;; - The file cmuscheme.el defines a scheme-in-a-buffer mode. -;;; - The file tea.el tunes scheme and inferior-scheme modes for T. -;;; - The file soar.el tunes lisp and inferior-lisp modes for Soar. -;;; - cmutex.el defines tex and latex modes that invoke tex, latex, bibtex, -;;; previewers, and printers from within emacs. -;;; - background.el allows csh-like job control inside emacs. -;;; It is pretty easy to make new derived modes for other processes. - -;;; For documentation on the functionality provided by comint mode, and -;;; the hooks available for customising it, see the comments below. -;;; For further information on the standard derived modes (shell, -;;; inferior-lisp, inferior-scheme, ...), see the relevant source files. - -;;; For hints on converting existing process modes (e.g., tex-mode, -;;; background, dbx, gdb, kermit, prolog, telnet) to use comint-mode -;;; instead of shell-mode, see the notes at the end of this file. - - -;;; Brief Command Documentation: -;;;============================================================================ -;;; Comint Mode Commands: (common to all derived modes, like shell & cmulisp -;;; mode) -;;; -;;; XEmacs - FSF19 binds M-p/M-n to comint-{previous,next}-input instead of -;;; comint-{previous,next}-matching-input-from-input. -;;; XEmacs is mo' better. -;;; -;;; -;;; m-p comint-previous-matching-input-from-input Cycle backwards in input history -;;; m-n comint-next-matching-input-from-input Cycle forwards -;;; m-r comint-previous-matching-input Previous input matching a regexp -;;; m-s comint-next-matching-input Next input that matches -;;; XEmacs - remove evil binding of M-C-l. It's already bound to C-c C-r. -;;; NOT: m-c-l comint-show-output Show last batch of process output -;;; m-c-r comint-previous-input-matching Search backwards in input history -;;; return comint-send-input -;;; XEmacs - fsf nuked the binding for ^A, and we nuked the binding for ^D -;;; c-a comint-bol Beginning of line; skip prompt -;;; NOT: c-d comint-delchar-or-maybe-eof Delete char unless at end of buff -;;; c-c c-a comint-bol Beginning of line; skip prompt -;;; c-c c-d comint-send-eof ^d -;;; c-c c-u comint-kill-input ^u -;;; c-c c-w backward-kill-word ^w -;;; c-c c-c comint-interrupt-subjob ^c -;;; c-c c-z comint-stop-subjob ^z -;;; c-c c-\ comint-quit-subjob ^\ -;;; c-c c-o comint-kill-output Delete last batch of process output -;;; c-c c-r comint-show-output Show last batch of process output -;;; c-c c-l comint-dynamic-list-input-ring List input history -;;; -;;; Not bound by default in comint-mode (some are in shell mode) -;;; comint-run Run a program under comint-mode -;;; send-invisible Read a line w/o echo, and send to proc -;;; comint-dynamic-complete-filename Complete filename at point. -;;; comint-dynamic-complete-variable Complete variable name at point. -;;; comint-dynamic-list-filename-completions List completions in help buffer. -;;; comint-replace-by-expanded-filename Expand and complete filename at point; -;;; replace with expanded/completed name. -;;; comint-replace-by-expanded-history Expand history at point; -;;; replace with expanded name. -;;; comint-magic-space Expand history and add (a) space(s). -;;; comint-kill-subjob No mercy. -;;; comint-show-maximum-output Show as much output as possible. -;;; comint-continue-subjob Send CONT signal to buffer's process -;;; group. Useful if you accidentally -;;; suspend your process (with C-c C-z). - -;;; comint-mode-hook is the comint mode hook. Basically for your keybindings. - -;;; Code: - -(require 'ring) - -;;; Buffer Local Variables: -;;;============================================================================ -;;; Comint mode buffer local variables: -;;; comint-prompt-regexp - string comint-bol uses to match prompt -;;; comint-delimiter-argument-list - list For delimiters and arguments -;;; comint-last-input-start - marker Handy if inferior always echoes -;;; comint-last-input-end - marker For comint-kill-output command -;;; comint-input-ring-size - integer For the input history -;;; comint-input-ring - ring mechanism -;;; comint-input-ring-index - number ... -;;; comint-input-autoexpand - symbol ... -;;; comint-input-ignoredups - boolean ... -;;; comint-last-input-match - string ... -;;; comint-dynamic-complete-functions - hook For the completion mechanism -;;; comint-completion-fignore - list ... -;;; comint-file-name-quote-list - list ... -;;; comint-get-old-input - function Hooks for specific -;;; comint-input-filter-functions - hook process-in-a-buffer -;;; comint-output-filter-functions - hook function modes. -;;; comint-input-filter - function ... -;;; comint-input-sender - function ... -;;; comint-eol-on-send - boolean ... -;;; comint-process-echoes - boolean ... -;;; comint-scroll-to-bottom-on-input - symbol For scroll behavior -;;; comint-scroll-to-bottom-on-output - symbol ... -;;; comint-scroll-show-maximum-output - boolean... -;;; -;;; Comint mode non-buffer local variables: -;;; comint-completion-addsuffix - boolean/cons For file name completion -;;; comint-completion-autolist - boolean behavior -;;; comint-completion-recexact - boolean ... - -(require 'easymenu) - -(defgroup comint nil - "General command interpreter in a window stuff." - :group 'processes) - -(defgroup comint-completion nil - "Completion facilities in comint" - :group 'comint) - -(defgroup comint-source nil - "Source finding facilities in comint" - :prefix "comint-" - :group 'comint) - - -(defvar comint-prompt-regexp "^" - "Regexp to recognise prompts in the inferior process. -Defaults to \"^\", the null string at BOL. - -Good choices: - Canonical Lisp: \"^[^> \\n]*>+:? *\" (Lucid, franz, kcl, T, cscheme, oaklisp) - Lucid Common Lisp: \"^\\\\(>\\\\|\\\\(->\\\\)+\\\\) *\" - franz: \"^\\\\(->\\\\|<[0-9]*>:\\\\) *\" - kcl: \"^>+ *\" - shell: \"^[^#$%>\\n]*[#$%>] *\" - T: \"^>+ *\" - -The pattern should begin with \"^\". It can match text on more than one line. -This pattern gets handed to re-search-backward, not looking-at. - -This is a good thing to set in mode hooks.") - -(defvar comint-delimiter-argument-list () - "List of characters to recognise as separate arguments in input. -Strings comprising a character in this list will separate the arguments -surrounding them, and also be regarded as arguments in their own right (unlike -whitespace). See `comint-arguments'. -Defaults to the empty list. - -For shells, a good value is (?\\| ?& ?< ?> ?\\( ?\\) ?;). - -This is a good thing to set in mode hooks.") - -;; #### BUG: this loser mangles history; when one types -;; find /tmp \( -name foo \) -print -;; one gets find /tmp \ ( -name foo \ ) -print -;; -;; XEmacs - So turn this off by default. -- jwz -;; -(defcustom comint-input-autoexpand nil - "*If non-nil, expand input command history references on completion. -This mirrors the optional behavior of tcsh (its autoexpand and histlit). - -If the value is `input', then the expansion is seen on input. -If the value is `history', then the expansion is only when inserting -into the buffer's input ring. See also `comint-magic-space' and -`comint-dynamic-complete'. - -This variable is buffer-local." - :type '(choice (const :tag "off" nil) - (const :tag "on" t) - (const input) - (const history)) - :group 'comint) - -;; XEmacs - this should default to t for consistency with minibuffer history. -jwz -(defcustom comint-input-ignoredups t - "*If non-nil, don't add input matching the last on the input ring. -This mirrors the optional behavior of bash. - -This variable is buffer-local." - :type 'boolean - :group 'comint) - -(defcustom comint-input-ring-file-name nil - "*If non-nil, name of the file to read/write input history. -See also `comint-read-input-ring' and `comint-write-input-ring'. - -This variable is buffer-local, and is a good thing to set in mode hooks." - :type '(choice (const :tag "None" nil) - (file)) - :group 'comint) - -(defcustom comint-scroll-to-bottom-on-input nil - "*Controls whether input to interpreter causes window to scroll. -If nil, then do not scroll. If t or `all', scroll all windows showing buffer. -If `this', scroll only the selected window. - -The default is nil. - -See `comint-preinput-scroll-to-bottom'. This variable is buffer-local." - :type '(choice (const :tag "off" nil) - (const t) - (const all) - (const this)) - :group 'comint) - -(defcustom comint-scroll-to-bottom-on-output nil - "*Controls whether interpreter output causes window to scroll. -If nil, then do not scroll. If t or `all', scroll all windows showing buffer. -If `this', scroll only the selected window. -If `others', scroll only those that are not the selected window. - -The default is nil. - -See variable `comint-scroll-show-maximum-output' and function -`comint-postoutput-scroll-to-bottom'. This variable is buffer-local." - :type '(choice (const :tag "off" nil) - (const t) - (const all) - (const this) - (const others)) - :group 'comint) - -(defcustom comint-scroll-show-maximum-output t - "*Controls how interpreter output causes window to scroll. -If non-nil, then show the maximum output when the window is scrolled. - -You may set this to an integer number of lines to keep shown, or a -floating point percentage of the window size to keep filled. -A negative number expresses a distance from the bottom, as when using -a prefix argument with `recenter' (bound to `\\[recenter]'). - -See variable `comint-scroll-to-bottom-on-output' and function -`comint-postoutput-scroll-to-bottom'. This variable is buffer-local." - :type '(choice (const :tag "Off" nil) - (const :tag "On" t) - (integer :tag "Number of lines" 20) - (number :tag "Decimal Percent of window" .85)) - :group 'comint) - -(defcustom comint-buffer-maximum-size 1024 - "*The maximum size in lines for comint buffers. -Comint buffers are truncated from the top to be no greater than this number, if -the function `comint-truncate-buffer' is on `comint-output-filter-functions'." - :type 'integer - :group 'comint) - -(defvar comint-input-ring-size 32 - "Size of input history ring.") - -(defcustom comint-process-echoes nil - "*If non-nil, assume that the subprocess echoes any input. -If so, delete one copy of the input so that only one copy eventually -appears in the buffer. - -This variable is buffer-local." - :type 'boolean - :group 'comint) - -;; AIX puts the name of the person being su'd to in from of the prompt. -(defcustom comint-password-prompt-regexp - (if (eq system-type 'aix-v3) - "\\(\\([Oo]ld \\|[Nn]ew \\|^\\|^..*s\\)[Pp]assword\\|pass phrase\\):\\s *\\'" - "\\(\\([Oo]ld \\|[Nn]ew \\|^\\)[Pp]assword\\|pass phrase\\):\\s *\\'") - "*Regexp matching prompts for passwords in the inferior process. -This is used by `comint-watch-for-password-prompt'." - :type 'regexp - :group 'comint) - -;;; Here are the per-interpreter hooks. -(defvar comint-get-old-input (function comint-get-old-input-default) - "Function that returns old text in comint mode. -This function is called when return is typed while the point is in old text. -It returns the text to be submitted as process input. The default is -`comint-get-old-input-default', which grabs the current line, and strips off -leading text matching `comint-prompt-regexp'.") - -;; XEmacs - fsf doesn't have this, and I think it ought to default to 't' -;; because it's good idiot-proof interface. --stig -(defcustom comint-append-old-input t - "*If nil, old text selected by \\[comint-send-input] is re-sent immediately. -If non-nil, the old text is appended to the end of the buffer, -and a prompting message is printed. - -This flag does not affect the behavior of \\[comint-send-input] -after the process output mark." - :type 'boolean - :group 'comint) - -(defvar comint-dynamic-complete-functions - '(comint-replace-by-expanded-history comint-dynamic-complete-filename) - "List of functions called to perform completion. -Functions should return non-nil if completion was performed. -See also `comint-dynamic-complete'. - -This is a good thing to set in mode hooks.") - -(defvar comint-input-filter - #'(lambda (str) - (and (not (string-match "\\`\\s *\\'" str)) - ;; XEmacs - ignore '!!' and kin - (> (length str) 2))) - "Predicate for filtering additions to input history. -Takes one argument, the input. If non-nil, the input may be saved on the input -history list. Default is to save anything longer than two characters -that isn't all whitespace.") - -(defvar comint-input-filter-functions '() - "Functions to call before input is sent to the process. -These functions get one argument, a string containing the text to send. - -This variable is buffer-local.") - -(defvar comint-output-filter-functions '(comint-postoutput-scroll-to-bottom - ;; XEmacs - not here by default for FSF - comint-watch-for-password-prompt) - "Functions to call after output is inserted into the buffer. -One possible function is `comint-postoutput-scroll-to-bottom'. -These functions get one argument, a string containing the text just inserted. - -This variable is buffer-local.") - -(defvar comint-input-sender (function comint-simple-send) - "Function to actually send to PROCESS the STRING submitted by user. -Usually this is just `comint-simple-send', but if your mode needs to -massage the input string, put a different function here. -`comint-simple-send' just sends the string plus a newline. -This is called from the user command `comint-send-input'.") - -(defcustom comint-eol-on-send t - "*Non-nil means go to the end of the line before sending input. -See `comint-send-input'." - :type 'boolean - :group 'comint) - -(defcustom comint-mode-hook '() - "Called upon entry into comint-mode -This is run before the process is cranked up." - :type 'hook - :group 'comint) - -;; This is initialized by the various language environments, do not -;; Custom-ize it. -(defvar comint-exec-hook '() - "Called each time a process is exec'd by `comint-exec'. -This is called after the process is cranked up. It is useful for things that -must be done each time a process is executed in a comint mode buffer (e.g., -`(process-kill-without-query)'). In contrast, the `comint-mode-hook' is only -executed once when the buffer is created.") - -(defvar comint-mode-map nil) - -(defvar comint-ptyp t - "Non-nil if communications via pty; false if by pipe. Buffer local. -This is to work around a bug in Emacs process signalling.") - -(defvar comint-input-ring nil) -(defvar comint-last-input-start) -(defvar comint-last-input-end) -(defvar comint-last-output-start) -(defvar comint-input-ring-index nil - "Index of last matched history element.") -(defvar comint-matching-input-from-input-string "" - "Input previously used to match input history.") - -(put 'comint-input-ring 'permanent-local t) -(put 'comint-input-ring-index 'permanent-local t) -(put 'comint-input-autoexpand 'permanent-local t) -(put 'comint-input-filter-functions 'permanent-local t) -(put 'comint-output-filter-functions 'permanent-local t) -(put 'comint-scroll-to-bottom-on-input 'permanent-local t) -(put 'comint-scroll-to-bottom-on-output 'permanent-local t) -(put 'comint-scroll-show-maximum-output 'permanent-local t) -(put 'comint-ptyp 'permanent-local t) - -(defvar comint-1-menubar-menu nil) -(defconst comint-1-menubar-menu-1 - (purecopy - '("Comint1" - ["Previous Matching Current Input" - comint-previous-matching-input-from-input t] - ["Next Matching Current Input" comint-next-matching-input-from-input t] - ["Previous Input" comint-previous-input t] - ["Next Input" comint-next-input t] - ["Previous Input Matching Regexp..." comint-previous-matching-input t] - ["Next Input Matching Regexp..." comint-next-matching-input t] - ["Backward Matching Input..." comint-backward-matching-input t] - ["Forward Matching Input..." comint-forward-matching-input t] - "---" - ["Copy Old Input" comint-copy-old-input t] - ["Kill Current Input" comint-kill-input t] - ["Show Current Output Group" comint-show-output t] - ["Show Maximum Output" comint-show-maximum-output t] - ["Goto Previous Prompt" comint-previous-prompt t] - ["Goto Next Prompt" comint-next-prompt t] - ["Kill Command Output" comint-kill-output t] - ))) - -(defvar comint-2-menubar-menu nil) -(defconst comint-2-menubar-menu-1 - (purecopy - '("Comint2" - ["Complete Before Point" comint-dynamic-complete t] - ["Complete File Name" comint-dynamic-complete-filename t] - ["File Completion Listing" comint-dynamic-list-filename-completions t] - ["Expand File Name" comint-replace-by-expanded-filename t] - ;; this is cheesy but the easiest way to get this. - ["Complete Env. Variable Name" shell-dynamic-complete-environment-variable - :active t :included (eq 'shell-mode major-mode)] - ["Expand Directory Reference" shell-replace-by-expanded-directory - :active t :included (eq 'shell-mode major-mode)] - "---" - ["Send INT" comint-interrupt-subjob t] - ["Send STOP" comint-stop-subjob t] - ["Send CONT" comint-continue-subjob t] - ["Send QUIT" comint-quit-subjob t] - ["Send KILL" comint-kill-subjob t] - ["Send EOF" comint-send-eof t] - ))) - -(defvar comint-history-menubar-menu nil) -(defconst comint-history-menubar-menu-1 - (purecopy - '("History" - :filter comint-history-menu-filter - ["Expand History Before Point" comint-replace-by-expanded-history - comint-input-autoexpand] - ["List Input History" comint-dynamic-list-input-ring t] - "---" - ))) - - -(defun comint-mode () - "Major mode for interacting with an inferior interpreter. -Interpreter name is same as buffer name, sans the asterisks. -Return at end of buffer sends line as input. -Return not at end copies rest of line to end and sends it. -Setting variable `comint-eol-on-send' means jump to the end of the line -before submitting new input. - -This mode is customised to create major modes such as Inferior Lisp -mode, Shell mode, etc. This can be done by setting the hooks -`comint-input-filter-functions', `comint-input-filter', `comint-input-sender' -and `comint-get-old-input' to appropriate functions, and the variable -`comint-prompt-regexp' to the appropriate regular expression. - -An input history is maintained of size `comint-input-ring-size', and -can be accessed with the commands \\[comint-next-input], \\[comint-previous-input], and \\[comint-dynamic-list-input-ring]. -Input ring history expansion can be achieved with the commands -\\[comint-replace-by-expanded-history] or \\[comint-magic-space]. -Input ring expansion is controlled by the variable `comint-input-autoexpand', -and addition is controlled by the variable `comint-input-ignoredups'. - -Commands with no default key bindings include `send-invisible', -`comint-dynamic-complete', `comint-dynamic-list-filename-completions', and -`comint-magic-space'. - -Input to, and output from, the subprocess can cause the window to scroll to -the end of the buffer. See variables `comint-output-filter-functions', -`comint-scroll-to-bottom-on-input', and `comint-scroll-to-bottom-on-output'. - -If you accidentally suspend your process, use \\[comint-continue-subjob] -to continue it. - -\\{comint-mode-map} - -Entry to this mode runs the hooks on `comint-mode-hook'." - (interactive) - ;; Do not remove this. All major modes must do this. - (kill-all-local-variables) - (setq major-mode 'comint-mode) - (setq mode-name "Comint") - (setq mode-line-process '(": %s")) ; XEmacs - (use-local-map comint-mode-map) - (make-local-variable 'comint-last-input-start) - (setq comint-last-input-start (make-marker)) - (set-marker comint-last-input-start (point-min)) - (make-local-variable 'comint-last-input-end) - (setq comint-last-input-end (make-marker)) - (set-marker comint-last-input-end (point-min)) - (make-local-variable 'comint-last-output-start) - (setq comint-last-output-start (make-marker)) - (make-local-variable 'comint-prompt-regexp) ; Don't set; default - (make-local-variable 'comint-input-ring-size) ; ...to global val. - (make-local-variable 'comint-input-ring) - (make-local-variable 'comint-input-ring-file-name) - (or (and (boundp 'comint-input-ring) comint-input-ring) - (setq comint-input-ring (make-ring comint-input-ring-size))) - (make-local-variable 'comint-input-ring-index) - (or (and (boundp 'comint-input-ring-index) comint-input-ring-index) - (setq comint-input-ring-index nil)) - (make-local-variable 'comint-matching-input-from-input-string) - (make-local-variable 'comint-input-autoexpand) - (make-local-variable 'comint-input-ignoredups) - (make-local-variable 'comint-delimiter-argument-list) - (make-local-hook 'comint-dynamic-complete-functions) - (make-local-variable 'comint-completion-fignore) - (make-local-variable 'comint-get-old-input) - (make-local-hook 'comint-input-filter-functions) - (make-local-variable 'comint-input-filter) - (make-local-variable 'comint-input-sender) - (make-local-variable 'comint-eol-on-send) - (make-local-variable 'comint-scroll-to-bottom-on-input) - (make-local-variable 'comint-scroll-to-bottom-on-output) - (make-local-variable 'comint-scroll-show-maximum-output) - (make-local-hook 'pre-command-hook) - (add-hook 'pre-command-hook 'comint-preinput-scroll-to-bottom nil t) - (make-local-hook 'comint-output-filter-functions) - (make-local-variable 'comint-ptyp) - (make-local-hook 'comint-exec-hook) - (make-local-variable 'comint-process-echoes) - (make-local-variable 'comint-file-name-quote-list) - (if (featurep 'menubar) - (progn - ;; make a local copy of the menubar, so our modes don't - ;; change the global menubar - ;; (set-buffer-menubar current-menubar) - ;; (add-submenu nil comint-1-menubar-menu) - (unless comint-1-menubar-menu - (easy-menu-define comint-1-menubar-menu nil "" - comint-1-menubar-menu-1)) - (easy-menu-add comint-1-menubar-menu) - ;; (add-submenu nil comint-2-menubar-menu) - (unless comint-2-menubar-menu - (easy-menu-define comint-2-menubar-menu nil "" - comint-2-menubar-menu-1)) - (easy-menu-add comint-2-menubar-menu) - ;; (add-submenu nil comint-history-menubar-menu))) - (unless comint-history-menubar-menu - (easy-menu-define comint-history-menubar-menu nil "" - comint-history-menubar-menu-1)) - (easy-menu-add comint-history-menubar-menu))) - (run-hooks 'comint-mode-hook)) - -(if comint-mode-map - nil - ;; Keys: - (setq comint-mode-map (make-sparse-keymap)) - (set-keymap-name comint-mode-map 'comint-mode-map) ; XEmacs - - ;; XEmacs - The FSF19 party line - ;;(define-key comint-mode-map "\ep" 'comint-previous-input) - ;;(define-key comint-mode-map "\en" 'comint-next-input) - - ;; The Lucid party line - (define-key comint-mode-map "\ep" 'comint-previous-matching-input-from-input) - (define-key comint-mode-map "\en" 'comint-next-matching-input-from-input) - (define-key comint-mode-map '(control up) - 'comint-previous-matching-input-from-input) - (define-key comint-mode-map '(control down) - 'comint-next-matching-input-from-input) - - (define-key comint-mode-map "\er" 'comint-previous-matching-input) - (define-key comint-mode-map "\es" 'comint-next-matching-input) - ;; XEmacs - alt-meta-anything is a horrible binding. Some keyboards don't have - ;; meta keys, so we use alt as meta. Consequently, alt-meta will not exist on - ;; all keyboards. Just blow this. These functions are on M-n and M-p. --stig - ;;(define-key comint-mode-map [?\A-\M-r] 'comint-previous-matching-input-from-input) - ;;(define-key comint-mode-map [?\A-\M-s] 'comint-next-matching-input-from-input) - ;; XEmacs: Yuck yuck. C-M-l has a perfectly good normal binding. - ;;(define-key comint-mode-map "\e\C-l" 'comint-show-output) - (define-key comint-mode-map "\C-m" 'comint-send-input) - ;; XEmacs - Use ^C^D instead of ^D. Jamie & Stig think this is too un-emacs. - ;;(define-key comint-mode-map "\C-d" 'comint-delchar-or-maybe-eof) - ;; XEmacs - FSF nuked this, but we're gonna keep it.... - (define-key comint-mode-map "\C-a" 'comint-bol) - ;; yuck, this is evil. - ;;(define-key comint-mode-map "\C-u" 'comint-universal-argument) ; XEmacs - (define-key comint-mode-map "\C-c\C-a" 'comint-bol) - (define-key comint-mode-map "\C-c\C-u" 'comint-kill-input) - (define-key comint-mode-map "\C-c\C-w" 'backward-kill-word) - (define-key comint-mode-map "\C-c\C-c" 'comint-interrupt-subjob) - (define-key comint-mode-map "\C-c\C-z" 'comint-stop-subjob) - (define-key comint-mode-map "\C-c\C-\\" 'comint-quit-subjob) - (define-key comint-mode-map "\C-c\C-m" 'comint-copy-old-input) - (define-key comint-mode-map "\C-c\C-o" 'comint-kill-output) - (define-key comint-mode-map "\C-c\C-r" 'comint-show-output) - (define-key comint-mode-map "\C-c\C-e" 'comint-show-maximum-output) - (define-key comint-mode-map "\C-c\C-l" 'comint-dynamic-list-input-ring) - (define-key comint-mode-map "\C-c\C-d" 'comint-send-eof) - - (define-key comint-mode-map "\C-c\C-n" 'comint-next-prompt) - (define-key comint-mode-map "\C-c\C-p" 'comint-previous-prompt) - ;; John Rose's suggestion - (define-key comint-mode-map "\e}" 'comint-next-prompt) - (define-key comint-mode-map "\e{" 'comint-previous-prompt) - - #-infodock (define-key comint-mode-map 'button3 'comint-popup-menu) - ) - -;;(defconst comint-popup-menu -;; '("Command Interpreter Commands" -;; ["Kill Command Output" comint-kill-output t] -;; ["Goto Next Prompt" comint-next-prompt t] -;; ["Goto Previous Prompt" comint-previous-prompt t] -;; ["Kill Input" comint-kill-input t] -;; "----" -;; ["Previous Input" comint-previous-matching-input-from-input t] -;; ["Next Input" comint-next-matching-input-from-input t] -;; ["Previous Input matching Regexp..." 'comint-previous-matching-input t] -;; ["Next Input matching Regexp..." 'comint-next-matching-input t] -;; ["List Command History" comint-dynamic-list-input-ring t] -;; "----" -;; ["Send INT" comint-interrupt-subjob t] -;; ["Send STOP" comint-stop-subjob t] -;; ["Send CONT" comint-continue-subjob t] -;; ["Send QUIT" comint-quit-subjob t] -;; ["Send KILL" comint-kill-subjob t] -;; ["Send EOF" comint-send-eof t] -;; )) - -(defun comint-popup-menu (event) - "Display the comint-mode menu." - (interactive "@e") - (let ((history (comint-make-history-menu))) - (popup-menu (if history - (append mode-popup-menu - (list "---" (cons "Command History" history))) - mode-popup-menu)))) - -(defcustom comint-history-menu-max 40 - "*Maximum number of entries to display on the Comint command-history menu." - :type 'integer - :group 'comint) - -(defun comint-history-menu-filter (menu) - (append menu (comint-make-history-menu))) - -(defun comint-make-history-menu () - (if (or (not (ringp comint-input-ring)) - (ring-empty-p comint-input-ring)) - nil - (let ((menu nil) - hist - (index (1- (ring-length comint-input-ring))) - (count 0)) - ;; We have to build up a list ourselves from the ring vector. - ;; We don't want the entries to get translated in a Mule - ;; environment, so we use the `suffix' field of the menu entries. - (while (and (>= index 0) - (and comint-history-menu-max - (< count comint-history-menu-max))) - (setq hist (ring-ref comint-input-ring index) - menu (cons (vector "" (list 'comint-menu-history hist) t hist) - menu) - count (1+ count) - index (1- index))) - menu))) - -(defun comint-menu-history (string) - (goto-char (point-max)) - (delete-region (process-mark (get-buffer-process (current-buffer))) (point)) - (insert string)) - -(defun comint-check-proc (buffer) - "Return t if there is a living process associated w/buffer BUFFER. -Living means the status is `open', `run', or `stop'. -BUFFER can be either a buffer or the name of one." - (let ((proc (get-buffer-process buffer))) - (and proc (memq (process-status proc) '(open run stop))))) - -;;; Note that this guy, unlike shell.el's make-shell, barfs if you pass it () -;;; for the second argument (program). -;;;###autoload -(defun make-comint (name program &optional startfile &rest switches) - "Make a comint process NAME in a buffer, running PROGRAM. -The name of the buffer is made by surrounding NAME with `*'s. -PROGRAM should be either a string denoting an executable program to create -via `start-process', or a cons pair of the form (HOST . SERVICE) denoting a TCP -connection to be opened via `open-network-stream'. If there is already a -running process in that buffer, it is not restarted. Optional third arg -STARTFILE is the name of a file to send the contents of to the process. - -If PROGRAM is a string, any more args are arguments to PROGRAM." - (or (fboundp 'start-process) - (error "Multiple processes are not supported for this system")) - (let ((buffer (get-buffer-create (concat "*" name "*")))) - ;; If no process, or nuked process, crank up a new one and put buffer in - ;; comint mode. Otherwise, leave buffer and existing process alone. - (cond ((not (comint-check-proc buffer)) - (save-excursion - (set-buffer buffer) - (comint-mode)) ; Install local vars, mode, keymap, ... - (comint-exec buffer name program startfile switches))) - buffer)) - -;;;###autoload -(defun comint-run (program) - "Run PROGRAM in a comint buffer and switch to it. -The buffer name is made by surrounding the file name of PROGRAM with `*'s. -The file name is used to make a symbol name, such as `comint-sh-hook', and any -hooks on this symbol are run in the buffer. -See `make-comint' and `comint-exec'." - (interactive "sRun program: ") - (let ((name (file-name-nondirectory program))) - (switch-to-buffer (make-comint name program)) - (run-hooks (intern-soft (concat "comint-" name "-hook"))))) - -(defun comint-exec (buffer name command startfile switches) - "Start up a process in buffer BUFFER for comint modes. -Blasts any old process running in the buffer. Doesn't set the buffer mode. -You can use this to cheaply run a series of processes in the same comint -buffer. The hook `comint-exec-hook' is run after each exec." - (save-excursion - (set-buffer buffer) - (let ((proc (get-buffer-process buffer))) ; Blast any old process. - (if proc (delete-process proc))) - ;; Crank up a new process - (let ((proc - (if (consp command) - (open-network-stream name buffer (car command) (cdr command)) - (comint-exec-1 name buffer command switches)))) - (set-process-filter proc 'comint-output-filter) - (make-local-variable 'comint-ptyp) - (setq comint-ptyp process-connection-type) ; T if pty, NIL if pipe. - ;; Jump to the end, and set the process mark. - (goto-char (point-max)) - (set-marker (process-mark proc) (point)) - ;; Feed it the startfile. - (cond (startfile - ;;This is guaranteed to wait long enough - ;;but has bad results if the comint does not prompt at all - ;; (while (= size (buffer-size)) - ;; (sleep-for 1)) - ;;I hope 1 second is enough! - (sleep-for 1) - (goto-char (point-max)) - (insert-file-contents startfile) - (setq startfile (buffer-substring (point) (point-max))) - (delete-region (point) (point-max)) - (comint-send-string proc startfile))) - (run-hooks 'comint-exec-hook) - buffer))) - -;;; This auxiliary function cranks up the process for comint-exec in -;;; the appropriate environment. - -(defun comint-exec-1 (name buffer command switches) - (let ((process-environment - (nconc - ;; If using termcap, we specify `emacs' as the terminal type - ;; because that lets us specify a width. - ;; If using terminfo, we specify `unknown' because that is - ;; a defined terminal type. `emacs' is not a defined terminal type - ;; and there is no way for us to define it here. - ;; Some programs that use terminfo get very confused - ;; if TERM is not a valid terminal type. - (if (and (boundp 'system-uses-terminfo) system-uses-terminfo) - (list "TERM=unknown" - (format "COLUMNS=%d" (frame-width))) - (list "TERM=emacs" - (format "TERMCAP=emacs:co#%d:tc=unknown:" (frame-width)))) - (if (getenv "EMACS") nil (list "EMACS=t")) - process-environment)) - (default-directory - (if (file-directory-p default-directory) - default-directory - "/"))) - (apply 'start-process name buffer command switches))) - -;;; Input history processing in a buffer -;;; =========================================================================== -;;; Useful input history functions, courtesy of the Ergo group. - -;;; Eleven commands: -;;; comint-dynamic-list-input-ring List history in help buffer. -;;; comint-previous-input Previous input... -;;; comint-previous-matching-input ...matching a string. -;;; comint-previous-matching-input-from-input ... matching the current input. -;;; comint-next-input Next input... -;;; comint-next-matching-input ...matching a string. -;;; comint-next-matching-input-from-input ... matching the current input. -;;; comint-backward-matching-input Backwards input... -;;; comint-forward-matching-input ...matching a string. -;;; comint-replace-by-expanded-history Expand history at point; -;;; replace with expanded history. -;;; comint-magic-space Expand history and insert space. -;;; -;;; Three functions: -;;; comint-read-input-ring Read into comint-input-ring... -;;; comint-write-input-ring Write to comint-input-ring-file-name. -;;; comint-replace-by-expanded-history-before-point Workhorse function. - -(defun comint-read-input-ring (&optional silent) - "Sets the buffer's `comint-input-ring' from a history file. -The name of the file is given by the variable `comint-input-ring-file-name'. -The history ring is of size `comint-input-ring-size', regardless of file size. -If `comint-input-ring-file-name' is nil this function does nothing. - -If the optional argument SILENT is non-nil, we say nothing about a -failure to read the history file. - -This function is useful for major mode commands and mode hooks. - -The structure of the history file should be one input command per line, -with the most recent command last. -See also `comint-input-ignoredups' and `comint-write-input-ring'." - (cond ((or (null comint-input-ring-file-name) - (equal comint-input-ring-file-name "")) - nil) - ((not (file-readable-p comint-input-ring-file-name)) - (or silent - (message "Cannot read history file %s" - comint-input-ring-file-name))) - (t - (let ((history-buf (get-buffer-create " *comint-history*")) - (file comint-input-ring-file-name) - (count 0) - (ring (make-ring comint-input-ring-size))) - (unwind-protect - (save-excursion - (set-buffer history-buf) - (widen) - (erase-buffer) - (insert-file-contents file) - ;; Save restriction in case file is already visited... - ;; Watch for those date stamps in history files! - (goto-char (point-max)) - (while (and (< count comint-input-ring-size) - (re-search-backward "^[ \t]*\\([^#\n].*\\)[ \t]*$" - nil t)) - (let ((history (buffer-substring (match-beginning 1) - (match-end 1)))) - (if (or (null comint-input-ignoredups) - (ring-empty-p ring) - (not (string-equal (ring-ref ring 0) history))) - (ring-insert-at-beginning ring history))) - (setq count (1+ count)))) - (kill-buffer history-buf)) - (setq comint-input-ring ring - comint-input-ring-index nil))))) - -(defun comint-write-input-ring () - "Writes the buffer's `comint-input-ring' to a history file. -The name of the file is given by the variable `comint-input-ring-file-name'. -The original contents of the file are lost if `comint-input-ring' is not empty. -If `comint-input-ring-file-name' is nil this function does nothing. - -Useful within process sentinels. - -See also `comint-read-input-ring'." - (cond ((or (null comint-input-ring-file-name) - (equal comint-input-ring-file-name "") - (null comint-input-ring) (ring-empty-p comint-input-ring)) - nil) - ((not (file-writable-p comint-input-ring-file-name)) - (message "Cannot write history file %s" comint-input-ring-file-name)) - (t - (let* ((history-buf (get-buffer-create " *Temp Input History*")) - (ring comint-input-ring) - (file comint-input-ring-file-name) - (index (ring-length ring))) - ;; Write it all out into a buffer first. Much faster, but messier, - ;; than writing it one line at a time. - (save-excursion - (set-buffer history-buf) - (erase-buffer) - (while (> index 0) - (setq index (1- index)) - (insert (ring-ref ring index) ?\n)) - (write-region (buffer-string) nil file nil 'no-message) - (kill-buffer nil)))))) - -;; XEmacs - FSF doesn't have this. -(defun comint-restore-window-config (conf &optional message) - ;; Don't obscure buffer being edited - (or (eq (selected-window) (minibuffer-window)) - (message "%s" (or message "Press space to flush"))) - (sit-for 0) - (if (if (fboundp 'next-command-event) - ;; lemacs - (let ((ch (next-command-event))) - (if (eq (event-to-character ch) ?\ ) - t - (progn (setq unread-command-event ch) - nil))) - ;; v19 FSFmacs - (let ((ch (read-event))) - (if (eq ch ?\ ) - t - (progn (setq unread-command-events (list ch)) - nil)))) - (set-window-configuration conf))) - - -(defun comint-dynamic-list-input-ring () - "List in help buffer the buffer's input history." - (interactive) - (if (or (not (ringp comint-input-ring)) - (ring-empty-p comint-input-ring)) - (message "No history") - (let ((history nil) - (history-buffer " *Input History*") - (index (1- (ring-length comint-input-ring))) - (conf (current-window-configuration))) - ;; We have to build up a list ourselves from the ring vector. - (while (>= index 0) - (setq history (cons (ring-ref comint-input-ring index) history) - index (1- index))) - ;; Change "completion" to "history reference" - ;; to make the display accurate. - (with-output-to-temp-buffer history-buffer - (display-completion-list history) - (set-buffer history-buffer) - (forward-line 3) - (let ((buffer-read-only nil)) - (while (search-backward "completion" nil 'move) - (replace-match "history reference")))) - (comint-restore-window-config conf)))) - -(defun comint-regexp-arg (prompt) - ;; Return list of regexp and prefix arg using PROMPT. - (let* ((minibuffer-history-sexp-flag nil) - ;; Don't clobber this. - (last-command last-command) - (regexp (read-from-minibuffer prompt nil nil nil - 'minibuffer-history-search-history))) - (list (if (string-equal regexp "") - (setcar minibuffer-history-search-history - (nth 1 minibuffer-history-search-history)) - regexp) - (prefix-numeric-value current-prefix-arg)))) - -(defun comint-search-arg (arg) - ;; First make sure there is a ring and that we are after the process mark - (cond ((not (comint-after-pmark-p)) - (error "Not at command line")) - ((or (null comint-input-ring) - (ring-empty-p comint-input-ring)) - (error "Empty input ring")) - ((zerop arg) - ;; arg of zero resets search from beginning, and uses arg of 1 - (setq comint-input-ring-index nil) - 1) - (t - arg))) - -(defun comint-search-start (arg) - ;; Index to start a directional search, starting at comint-input-ring-index - (if comint-input-ring-index - ;; If a search is running, offset by 1 in direction of arg - (mod (+ comint-input-ring-index (if (> arg 0) 1 -1)) - (ring-length comint-input-ring)) - ;; For a new search, start from beginning or end, as appropriate - (if (>= arg 0) - 0 ; First elt for forward search - (1- (ring-length comint-input-ring))))) ; Last elt for backward search - -(defun comint-previous-input-string (arg) - "Return the string ARG places along the input ring. -Moves relative to `comint-input-ring-index'." - (ring-ref comint-input-ring (if comint-input-ring-index - (mod (+ arg comint-input-ring-index) - (ring-length comint-input-ring)) - arg))) - -(defun comint-previous-input (arg) - "Cycle backwards through input history." - (interactive "*p") - (comint-previous-matching-input "." arg)) - -(defun comint-next-input (arg) - "Cycle forwards through input history." - (interactive "*p") - (comint-previous-input (- arg))) - -(defun comint-previous-matching-input-string (regexp arg) - "Return the string matching REGEXP ARG places along the input ring. -Moves relative to `comint-input-ring-index'." - (let* ((pos (comint-previous-matching-input-string-position regexp arg))) - (if pos (ring-ref comint-input-ring pos)))) - -(defun comint-previous-matching-input-string-position (regexp arg &optional start) - "Return the index matching REGEXP ARG places along the input ring. -Moves relative to START, or `comint-input-ring-index'." - (if (or (not (ringp comint-input-ring)) - (ring-empty-p comint-input-ring)) - (error "No history")) - (let* ((len (ring-length comint-input-ring)) - (motion (if (> arg 0) 1 -1)) - (n (mod (- (or start (comint-search-start arg)) motion) len)) - (tried-each-ring-item nil) - (prev nil)) - ;; Do the whole search as many times as the argument says. - (while (and (/= arg 0) (not tried-each-ring-item)) - ;; Step once. - (setq prev n - n (mod (+ n motion) len)) - ;; If we haven't reached a match, step some more. - (while (and (< n len) (not tried-each-ring-item) - (not (string-match regexp (ring-ref comint-input-ring n)))) - (setq n (mod (+ n motion) len) - ;; If we have gone all the way around in this search. - tried-each-ring-item (= n prev))) - (setq arg (if (> arg 0) (1- arg) (1+ arg)))) - ;; Now that we know which ring element to use, if we found it, return that. - (if (string-match regexp (ring-ref comint-input-ring n)) - n))) - -(defun comint-previous-matching-input (regexp arg) - "Search backwards through input history for match for REGEXP. -\(Previous history elements are earlier commands.) -With prefix argument N, search for Nth previous match. -If N is negative, find the next or Nth next match." - (interactive (comint-regexp-arg "Previous input matching (regexp): ")) - (setq arg (comint-search-arg arg)) - (let ((pos (comint-previous-matching-input-string-position regexp arg))) - ;; Has a match been found? - (if (null pos) - (error "Not found") - (setq comint-input-ring-index pos) - (message "History item: %d" (1+ pos)) - (delete-region - ;; Can't use kill-region as it sets this-command - (process-mark (get-buffer-process (current-buffer))) (point)) - (insert (ring-ref comint-input-ring pos))))) - -(defun comint-next-matching-input (regexp arg) - "Search forwards through input history for match for REGEXP. -\(Later history elements are more recent commands.) -With prefix argument N, search for Nth following match. -If N is negative, find the previous or Nth previous match." - (interactive (comint-regexp-arg "Next input matching (regexp): ")) - (comint-previous-matching-input regexp (- arg))) - -(defun comint-previous-matching-input-from-input (arg) - "Search backwards through input history for match for current input. -\(Previous history elements are earlier commands.) -With prefix argument N, search for Nth previous match. -If N is negative, search forwards for the -Nth following match." - (interactive "p") - (if (not (memq last-command '(comint-previous-matching-input-from-input - comint-next-matching-input-from-input))) - ;; Starting a new search - (setq comint-matching-input-from-input-string - (buffer-substring - (process-mark (get-buffer-process (current-buffer))) - (point)) - comint-input-ring-index nil)) - (comint-previous-matching-input - (concat "^" (regexp-quote comint-matching-input-from-input-string)) - arg)) - -(defun comint-next-matching-input-from-input (arg) - "Search forwards through input history for match for current input. -\(Following history elements are more recent commands.) -With prefix argument N, search for Nth following match. -If N is negative, search backwards for the -Nth previous match." - (interactive "p") - (comint-previous-matching-input-from-input (- arg))) - - -(defun comint-replace-by-expanded-history (&optional silent) - "Expand input command history references before point. -Expansion is dependent on the value of `comint-input-autoexpand'. - -This function depends on the buffer's idea of the input history, which may not -match the command interpreter's idea, assuming it has one. - -Assumes history syntax is like typical Un*x shells'. However, since emacs -cannot know the interpreter's idea of input line numbers, assuming it has one, -it cannot expand absolute input line number references. - -If the optional argument SILENT is non-nil, never complain -even if history reference seems erroneous. - -See `comint-magic-space' and `comint-replace-by-expanded-history-before-point'. - -Returns t if successful." - (interactive) - (if (and comint-input-autoexpand - (string-match "!\\|^\\^" (funcall comint-get-old-input)) - (save-excursion (beginning-of-line) - (looking-at comint-prompt-regexp))) - ;; Looks like there might be history references in the command. - (let ((previous-modified-tick (buffer-modified-tick))) - (message "Expanding history references...") - (comint-replace-by-expanded-history-before-point silent) - (/= previous-modified-tick (buffer-modified-tick))))) - - -(defun comint-replace-by-expanded-history-before-point (silent) - "Expand directory stack reference before point. -See `comint-replace-by-expanded-history'. Returns t if successful." - (save-excursion - (let ((toend (- (save-excursion (end-of-line nil) (point)) (point))) - (start (progn (comint-bol nil) (point)))) - ;; XEmacs - fsf has something weird and complex here that does the same thing. - (while (re-search-forward - "[!^]" (save-excursion (end-of-line nil) (- (point) toend)) t) - ;; This seems a bit complex. We look for references such as !!, !-num, - ;; !foo, !?foo, !{bar}, !?{bar}, ^oh, ^my^, ^god^it, ^never^ends^. - ;; If that wasn't enough, the plings can be suffixed with argument - ;; range specifiers. - ;; Argument ranges are complex too, so we hive off the input line, - ;; referenced with plings, with the range string to `comint-args'. - (setq comint-input-ring-index nil) - (goto-char (match-beginning 0)) ; XEmacs - (cond ((or (= (preceding-char) ?\\) - (comint-within-quotes start (point))) - ;; The history is quoted, or we're in quotes. - (goto-char (match-end 0))) ; XEmacs - ((looking-at "![0-9]+\\($\\|[^-]\\)") - ;; We cannot know the interpreter's idea of input line numbers. - (goto-char (match-end 0)) - (message "Absolute reference cannot be expanded")) - ((looking-at "!-\\([0-9]+\\)\\(:?[0-9^$*-]+\\)?") - ;; Just a number of args from `number' lines backward. - (let ((number (1- (string-to-number - (buffer-substring (match-beginning 1) - (match-end 1)))))) - (if (<= number (ring-length comint-input-ring)) - (progn - (replace-match - (comint-args (comint-previous-input-string number) - (match-beginning 2) (match-end 2)) - t t) - (setq comint-input-ring-index number) - (message "History item: %d" (1+ number))) - (goto-char (match-end 0)) - (message "Relative reference exceeds input history size")))) - ((or (looking-at "!!?:?\\([0-9^$*-]+\\)") (looking-at "!!")) - ;; Just a number of args from the previous input line. - (replace-match - (comint-args (comint-previous-input-string 0) - (match-beginning 1) (match-end 1)) t t) - (message "History item: previous")) - ((looking-at - "!\\??\\({\\(.+\\)}\\|\\(\\sw+\\)\\)\\(:?[0-9^$*-]+\\)?") - ;; Most recent input starting with or containing (possibly - ;; protected) string, maybe just a number of args. Phew. - (let* ((mb1 (match-beginning 1)) (me1 (match-end 1)) - (mb2 (match-beginning 2)) (me2 (match-end 2)) - (exp (buffer-substring (or mb2 mb1) (or me2 me1))) - (pref (if (save-match-data (looking-at "!\\?")) "" "^")) - (pos (save-match-data - (comint-previous-matching-input-string-position - (concat pref (regexp-quote exp)) 1)))) - (if (null pos) - (progn - (goto-char (match-end 0)) - (or silent - (progn (message "Not found") - (ding)))) - (setq comint-input-ring-index pos) - (replace-match - (comint-args (ring-ref comint-input-ring pos) - (match-beginning 4) (match-end 4)) - t t) - (message "History item: %d" (1+ pos))))) - ((looking-at "\\^\\([^^]+\\)\\^?\\([^^]*\\)\\^?") - ;; Quick substitution on the previous input line. - (let ((old (buffer-substring (match-beginning 1) (match-end 1))) - (new (buffer-substring (match-beginning 2) (match-end 2))) - (pos nil)) - (replace-match (comint-previous-input-string 0) t t) - (setq pos (point)) - (goto-char (match-beginning 0)) - (if (not (search-forward old pos t)) - (or silent - (error "Not found")) - (replace-match new t t) - (message "History item: substituted")))) - (t - (goto-char (match-end 0)))))))) - - -(defun comint-magic-space (arg) - "Expand input history references before point and insert ARG spaces. -A useful command to bind to SPC. See `comint-replace-by-expanded-history'." - (interactive "p") - (comint-replace-by-expanded-history) - (self-insert-command arg)) - -(defun comint-within-quotes (beg end) - "Return t if the number of quotes between BEG and END is odd. -Quotes are single and double." - (let ((countsq (comint-how-many-region "\\(^\\|[^\\\\]\\)\'" beg end)) - (countdq (comint-how-many-region "\\(^\\|[^\\\\]\\)\"" beg end))) - (or (= (mod countsq 2) 1) (= (mod countdq 2) 1)))) - -(defun comint-how-many-region (regexp beg end) - "Return number of matches for REGEXP from BEG to END." - (let ((count 0)) - (save-excursion - (save-match-data - (goto-char beg) - (while (re-search-forward regexp end t) - (setq count (1+ count))))) - count)) - -(defun comint-args (string begin end) - ;; From STRING, return the args depending on the range specified in the text - ;; from BEGIN to END. If BEGIN is nil, assume all args. Ignore leading `:'. - ;; Range can be x-y, x-, -y, where x/y can be [0-9], *, ^, $. - (save-match-data - (if (null begin) - (comint-arguments string 0 nil) - (let* ((range (buffer-substring - (if (eq (char-after begin) ?:) (1+ begin) begin) end)) - (nth (cond ((string-match "^[*^]" range) 1) - ((string-match "^-" range) 0) - ((string-equal range "$") nil) - (t (string-to-number range)))) - (mth (cond ((string-match "[-*$]$" range) nil) - ((string-match "-" range) - (string-to-number (substring range (match-end 0)))) - (t nth)))) - (comint-arguments string nth mth))))) - -;; Return a list of arguments from ARG. Break it up at the -;; delimiters in comint-delimiter-argument-list. Returned list is backwards. -(defun comint-delim-arg (arg) - (if (null comint-delimiter-argument-list) - (list arg) - (let ((args nil) - (pos 0) - (len (length arg))) - (while (< pos len) - (let ((char (aref arg pos)) - (start pos)) - (if (memq char comint-delimiter-argument-list) - (while (and (< pos len) (eq (aref arg pos) char)) - (setq pos (1+ pos))) - (while (and (< pos len) - (not (memq (aref arg pos) - comint-delimiter-argument-list))) - (setq pos (1+ pos)))) - (setq args (cons (substring arg start pos) args)))) - args))) - -(defun comint-arguments (string nth mth) - "Return from STRING the NTH to MTH arguments. -NTH and/or MTH can be nil, which means the last argument. -Returned arguments are separated by single spaces. -We assume whitespace separates arguments, except within quotes. -Also, a run of one or more of a single character -in `comint-delimiter-argument-list' is a separate argument. -Argument 0 is the command name." - (let ((argpart "[^ \n\t\"'`]+\\|\\(\"[^\"]*\"\\|'[^']*'\\|`[^`]*`\\)") - (args ()) (pos 0) - (count 0) - beg str quotes) - ;; Build a list of all the args until we have as many as we want. - (while (and (or (null mth) (<= count mth)) - (string-match argpart string pos)) - (if (and beg (= pos (match-beginning 0))) - ;; It's contiguous, part of the same arg. - (setq pos (match-end 0) - quotes (or quotes (match-beginning 1))) - ;; It's a new separate arg. - (if beg - ;; Put the previous arg, if there was one, onto ARGS. - (setq str (substring string beg pos) - args (if quotes (cons str args) - (nconc (comint-delim-arg str) args)) - count (1+ count))) - (setq quotes (match-beginning 1)) - (setq beg (match-beginning 0)) - (setq pos (match-end 0)))) - (if beg - (setq str (substring string beg pos) - args (if quotes (cons str args) - (nconc (comint-delim-arg str) args)) - count (1+ count))) - (let ((n (or nth (1- count))) - (m (if mth (1- (- count mth)) 0))) - (mapconcat - (function (lambda (a) a)) (nthcdr n (nreverse (nthcdr m args))) " ")))) - -;;; -;;; Input processing stuff -;;; - -(defun comint-send-input () - "Send input to process. -After the process output mark, sends all text from the process mark to -point as input to the process. Before the process output mark, calls value -of variable `comint-get-old-input' to retrieve old input, copies it to the -process mark, and sends it. If variable `comint-process-echoes' is nil, -a terminal newline is also inserted into the buffer and sent to the process -\(if it is non-nil, all text from the process mark to point is deleted, -since it is assumed the remote process will re-echo it). - -Any history reference may be expanded depending on the value of the variable -`comint-input-autoexpand'. The list of function names contained in the value -of `comint-input-filter-functions' is called on the input before sending it. -The input is entered into the input history ring, if the value of variable -`comint-input-filter' returns non-nil when called on the input. - -If variable `comint-eol-on-send' is non-nil, then point is moved to the -end of line before sending the input. - -If variable `comint-append-old-input' is non-nil, then the results of -calling `comint-get-old-input' are appended to the end of the buffer. -The new input will combine with any partially-typed text already present -after the process output mark. Point is moved just before the newly -appended input, and a message is displayed prompting the user to type -\\[comint-send-input] again. - -The values of `comint-get-old-input', `comint-input-filter-functions' and -`comint-input-filter' are chosen according to the command interpreter running -in the buffer. E.g., - -If the interpreter is the csh, - comint-get-old-input is the default: take the current line, discard any - initial string matching regexp comint-prompt-regexp. - comint-input-filter-functions monitors input for \"cd\", \"pushd\", and - \"popd\" commands. When it sees one, it cd's the buffer. - comint-input-filter is the default: returns t if the input isn't all white - space. - -If the comint is Lucid Common Lisp, - comint-get-old-input snarfs the sexp ending at point. - comint-input-filter-functions does nothing. - comint-input-filter returns nil if the input matches input-filter-regexp, - which matches (1) all whitespace (2) :a, :c, etc. - -Similarly for Soar, Scheme, etc." - (interactive) - ;; Note that the input string does not include its terminal newline. - (let ((proc (get-buffer-process (current-buffer)))) - (if (not proc) (error "Current buffer has no process") - (let* ((pmark (process-mark proc)) - (pmark-val (marker-position pmark)) - ;; XEmacs - change by John Rose: confirm before sending input if - ;; not after process mark. - (append-here nil) - (intxt (if (>= (point) pmark-val) - (progn (if comint-eol-on-send (end-of-line)) - (buffer-substring pmark (point))) - (let ((copy (funcall comint-get-old-input))) - (push-mark) - (if (not comint-append-old-input) - (goto-char pmark-val) - (setq append-here (point-max)) - (goto-char append-here)) - (insert copy) - copy))) - (input (if (not (eq comint-input-autoexpand 'input)) - ;; Just whatever's already there - intxt - ;; Expand and leave it visible in buffer - (comint-replace-by-expanded-history t) - (buffer-substring pmark (point)))) - (history (if (not (eq comint-input-autoexpand 'history)) - (if (eq comint-input-autoexpand nil) - ;; XEmacs - nil means leave it alone! - input - (comint-arguments input 0 nil)) - ;; This is messy 'cos ultimately the original - ;; functions used do insertion, rather than return - ;; strings. We have to expand, then insert back. - (comint-replace-by-expanded-history t) - (let ((copy (buffer-substring pmark (point)))) - (delete-region pmark (point)) - (insert input) - (comint-arguments copy 0 nil))))) - (if append-here - (progn - (goto-char append-here) - (message - (substitute-command-keys - "(\\[comint-send-input] to confirm)"))) - (if comint-process-echoes - (delete-region pmark (point)) - (insert ?\n)) - (if (and (funcall comint-input-filter history) - (or (null comint-input-ignoredups) - (not (ringp comint-input-ring)) - (ring-empty-p comint-input-ring) - (not (string-equal (ring-ref comint-input-ring 0) - history)))) - (ring-insert comint-input-ring history)) - ;; XEmacs - run the input filters on the history instead - ;; of the input, so that the input sentinel is called on the - ;; history-expanded text and sees "cd foo" instead of "cd !$". - (run-hook-with-args 'comint-input-filter-functions - (concat history "\n")) - (setq comint-input-ring-index nil) - ;; Update the markers before we send the input - ;; in case we get output amidst sending the input. - (set-marker comint-last-input-start pmark) - (set-marker comint-last-input-end (point)) - (set-marker (process-mark proc) (point)) - (comint-input-done) - (funcall comint-input-sender proc input) - (comint-input-setup) - ;; XEmacs - A kludge to prevent the delay between insert and - ;; process output affecting the display. A case for a - ;; comint-send-input-hook? - (run-hook-with-args 'comint-output-filter-functions - (concat input "\n")) - (comint-output-filter proc "") - ))))) -(defun comint-input-done () - "Finalized comint-input-extent so nothing more is added." - (if (not comint-input-extent) - (comint-input-setup)) - (set-extent-property comint-input-extent 'start-closed nil) - (set-extent-property comint-input-extent 'end-closed nil) - (set-extent-property comint-input-extent 'detachable t) - ) - -(defun comint-input-setup () - "Insure the comint-input-extent is ready." - (require 'comint-xemacs) - (setq comint-input-extent (make-extent (point) (point-max))) - (set-extent-property comint-input-extent 'detachable nil) - (set-extent-property comint-input-extent 'start-closed t) - (set-extent-property comint-input-extent 'end-closed t) - (set-extent-face comint-input-extent 'comint-input-face) - ) - -(defvar comint-input-extent nil - "Current extent used for displaying text in buffer."); -(make-variable-buffer-local 'comint-input-extent) - -;; The purpose of using this filter for comint processes -;; is to keep comint-last-input-end from moving forward -;; when output is inserted. -(defun comint-output-filter (process string) - ;; First check for killed buffer - (let ((oprocbuf (process-buffer process))) - (if (and oprocbuf (buffer-name oprocbuf)) - (let ((obuf (current-buffer)) - (opoint nil) (obeg nil) (oend nil)) - (set-buffer oprocbuf) - (setq string (replace-in-string string "\^M" "") - opoint (point) - obeg (point-min) - oend (point-max)) - ;; Keep stuff being output (before input) from using input-extent - (if comint-input-extent - (set-extent-property comint-input-extent 'start-closed nil)) - (let ((buffer-read-only nil) - (nchars (length string)) - (ostart nil)) - (widen) - (goto-char (process-mark process)) - (setq ostart (point)) - (if (<= (point) opoint) - (setq opoint (+ opoint nchars))) - ;; Insert after old_begv, but before old_zv. - (if (< (point) obeg) - (setq obeg (+ obeg nchars))) - (if (<= (point) oend) - (setq oend (+ oend nchars))) - (insert-before-markers string) - ;; Don't insert initial prompt outside the top of the window. - (if (= (window-start (selected-window)) (point)) - (set-window-start (selected-window) (- (point) (length string)))) - (if (and comint-last-input-end - (marker-buffer comint-last-input-end) - (= (point) comint-last-input-end)) - (set-marker comint-last-input-end (- comint-last-input-end nchars))) - (set-marker comint-last-output-start ostart) - (set-marker (process-mark process) (point)) - (redraw-modeline)) - ;; Now insure everything inserted after (user input) is in extent - (if (not comint-input-extent) - (comint-input-setup)) - (set-extent-endpoints comint-input-extent (point) (point-max)) - (set-extent-property comint-input-extent 'start-closed t) - - (narrow-to-region obeg oend) - (goto-char opoint) - (run-hook-with-args 'comint-output-filter-functions string) - (set-buffer obuf))))) - -;; XEmacs - Use a variable for this so that new commands can be added easily. -(defvar comint-scroll-to-bottom-on-input-commands - '(self-insert-command - mouse-yank - mouse-yank-at-click - x-insert-selection - comint-previous-input - comint-next-input - comint-previous-matching-input - comint-next-matching-input - comint-previous-matching-input-from-input - comint-next-matching-input-from-input - ) - "List of functions which will cause the point to move to the end of comint buffers.") - -(defun comint-preinput-scroll-to-bottom () - "Go to the end of buffer in all windows showing it. -Movement occurs if point in the selected window is not after the process mark, -and `this-command' is an insertion command. Insertion commands recognised -are those in `comint-scroll-to-bottom-on-input-commands'. -Depends on the value of `comint-scroll-to-bottom-on-input'. - -This function should be a pre-command hook." - (if (and comint-scroll-to-bottom-on-input - (memq this-command comint-scroll-to-bottom-on-input-commands)) - (let* ((selected (selected-window)) - (current (current-buffer)) - (process (get-buffer-process current)) - (scroll comint-scroll-to-bottom-on-input)) - (if (and process (< (point) (process-mark process)) - scroll (not (window-minibuffer-p selected))) - (if (eq scroll 'this) - (goto-char (point-max)) - (walk-windows - (function (lambda (window) - (if (and (eq (window-buffer window) current) - (or (eq scroll t) (eq scroll 'all))) - ;; XEmacs - fsf does this the hard way. - (set-window-point window (point-max)) - ))) - 'not-minibuf t)))))) - -(defun comint-postoutput-scroll-to-bottom (string) - "Go to the end of buffer in all windows showing it. -Does not scroll if the current line is the last line in the buffer. -Depends on the value of `comint-scroll-to-bottom-on-output' and -`comint-scroll-show-maximum-output'. - -This function should be in the list `comint-output-filter-functions'." - (let* ((selected (selected-window)) - (current (current-buffer)) - (process (get-buffer-process current)) - (scroll comint-scroll-to-bottom-on-output)) - ;; XEmacs - don't select windows as they're walked. - (if process - (walk-windows - (function (lambda (window) - (if (eq (window-buffer window) current) - (progn - (if (and (< (window-point window) - (process-mark process)) - (or (eq scroll t) (eq scroll 'all) - ;; Maybe user wants point to jump to the end. - (and (eq scroll 'this) - (eq selected window)) - (and (eq scroll 'others) - (not (eq selected window))) - ;; If point was at the end, keep it at the end. - (>= (window-point window) - (- (process-mark process) (length string))))) - (set-window-point window (process-mark process))) - ;; Optionally scroll so that the text - ;; ends at the bottom of the window. - (if (and comint-scroll-show-maximum-output - (>= (window-point window) - (process-mark process)) - ;; XEmacs - lemacs addition - (not (pos-visible-in-window-p (point-max) window))) - (save-excursion - (set-window-point window (point-max)) - (recenter - ;; XEmacs - lemacs addition - (cond ((integerp comint-scroll-show-maximum-output) - comint-scroll-show-maximum-output) - ((floatp comint-scroll-show-maximum-output) - (floor (* (window-height window) - comint-scroll-show-maximum-output) - 1)) - (t - -1)) - window - ))) - )))) - nil t)))) - -(defun comint-truncate-buffer (&optional string) - "Truncate the buffer to `comint-buffer-maximum-size'. -This function could be on `comint-output-filter-functions' or bound to a key." - (interactive) - (save-excursion - (goto-char (point-max)) - (forward-line (- comint-buffer-maximum-size)) - (beginning-of-line) - (delete-region (point-min) (point)))) - -(defun comint-strip-ctrl-m (&optional string) - "Strip trailing `^M' characters from the current output group. -This function could be on `comint-output-filter-functions' or bound to a key." - (interactive) - (let ((pmark (process-mark (get-buffer-process (current-buffer))))) - (save-excursion - (goto-char - (if (interactive-p) comint-last-input-end comint-last-output-start)) - (while (re-search-forward "\r+$" pmark t) - (replace-match "" t t))))) -(defalias 'shell-strip-ctrl-m 'comint-strip-ctrl-m) - -(defun comint-show-maximum-output () - "Put the end of the buffer at the bottom of the window." - (interactive) - (goto-char (point-max)) - (recenter -1)) - -(defun comint-get-old-input-default () - "Default for `comint-get-old-input'. -Take the current line, and discard any initial text matching -`comint-prompt-regexp'." - (save-excursion - (beginning-of-line) - (comint-skip-prompt) - (let ((beg (point))) - (end-of-line) - (buffer-substring beg (point))))) - -(defun comint-copy-old-input () - "Insert after prompt old input at point as new input to be edited. -Calls `comint-get-old-input' to get old input." - (interactive) - (let ((input (funcall comint-get-old-input)) - (process (get-buffer-process (current-buffer)))) - (if (not process) - (error "Current buffer has no process") - (goto-char (process-mark process)) - (insert input)))) - -(defun comint-skip-prompt () - "Skip past the text matching regexp `comint-prompt-regexp'. -If this takes us past the end of the current line, don't skip at all." - (let ((eol (save-excursion (end-of-line) (point))) - ;; XEmacs - Arbitrary limit: prompt can be up to 10 lines long. - (search-limit (save-excursion (forward-line -10) (point)))) - (if (and (save-excursion - (goto-char eol) - (re-search-backward comint-prompt-regexp search-limit t)) - (<= (match-beginning 0) (point)) - (> (match-end 0) (point)) - (<= (match-end 0) eol)) - (goto-char (match-end 0))))) - -(defun comint-after-pmark-p () - "Return t if point is after the process output marker." - (let ((pmark (process-mark (get-buffer-process (current-buffer))))) - (<= (marker-position pmark) (point)))) - -(defun comint-simple-send (proc string) - "Default function for sending to PROC input STRING. -This just sends STRING plus a newline. To override this, -set the hook `comint-input-sender'." - (comint-send-string proc string) - (comint-send-string proc "\n")) - -;; XEmacs - fsf doesn't bind this to ^A, but we do. There is some merit to -;; their change, so we change the behavior of the function to act the same -;; as normal ^A unless we're after the process mark. For the old behavior, -;; use ^C^A as in FSF. --Stig -(defun comint-bol (arg) - "Goes to the beginning of line, then skips past the prompt, if any. -If prefix argument is given (\\[universal-argument]) the prompt is not skipped. - -The prompt skip is done by skipping text matching the regular expression -`comint-prompt-regexp', a buffer local variable." - (interactive "_P") - (let ((skip (and (null arg) - (or (not (eq (lookup-key global-map (this-command-keys)) - 'beginning-of-line)) - ;; If the buffer's process has gone bye-bye - ;; revert to being just beginning-of-line. - (not (get-buffer-process (current-buffer))) - (comint-after-pmark-p))))) - (beginning-of-line) - (if skip (comint-skip-prompt)))) - -;; XEmacs - more like an xterm interaction model... -(defun comint-universal-argument () - "Erase the current line of input, or begin a numeric argument. - -In buffers with interactive subprocesses, this modified version of -`universal-argument' erases the current line of user input just as ^U erases a -line of text at the UNIX command prompt. - -Otherwise, begin a numeric argument for the following command. -Digits or minus sign following \\[universal-argument] make up the numeric argument. -\\[universal-argument] following the digits or minus sign ends the argument. -\\[universal-argument] without digits or minus sign provides 4 as argument. -Repeating \\[universal-argument] without digits or minus sign - multiplies the argument by 4 each time." - (interactive) - (let ((proc (get-buffer-process (current-buffer)))) - (if (and proc (> (point) (process-mark proc))) - (progn (comint-bol nil) - (kill-region (point) (save-excursion (end-of-line) (point)))) - (let (key) - (setq key (read-key-sequence nil t)) - (while (equal (key-binding key) 'universal-argument) - (setq key (read-key-sequence nil t))))))) - -;;; These three functions are for entering text you don't want echoed or -;;; saved -- typically passwords to ftp, telnet, or somesuch. -;;; Just enter m-x send-invisible and type in your line, or add -;;; `comint-watch-for-password-prompt' to `comint-output-filter-functions'. - -;; XEmacs has a standard function for this. -(defun comint-read-noecho (prompt &optional stars) - "Read a password from the user. -See documentation of `read-passwd' for more info." - (read-passwd prompt)) - -(defun send-invisible (str) - "Read a string without echoing. -Then send it to the process running in the current buffer. A new-line -is additionally sent. String is not saved on comint input history list. -Security bug: your string can still be temporarily recovered with -\\[view-lossage]." - (interactive "P") ; Defeat snooping via C-x esc - (let ((proc (get-buffer-process (current-buffer)))) - (if (not proc) - (error "Current buffer has no process") - (comint-send-string - proc (if (stringp str) str (comint-read-noecho "Non-echoed text: " t))) - (comint-send-string proc "\n")))) - -(defun comint-watch-for-password-prompt (string) - "Prompt in the minibuffer for password and send without echoing. -This function uses `send-invisible' to read and send a password to the buffer's -process if STRING contains a password prompt defined by -`comint-password-prompt-regexp'. - -This function could be in the list `comint-output-filter-functions'." - (if (string-match comint-password-prompt-regexp string) - (send-invisible nil))) - -;;; Low-level process communication - -(defalias 'comint-send-string 'process-send-string) -(defalias 'comint-send-region 'process-send-region) - -;;; Random input hackage - -(defun comint-kill-output () - "Kill all output from interpreter since last input. -Does not delete the prompt." - (interactive) - (let ((proc (get-buffer-process (current-buffer))) - (replacement nil)) - (save-excursion - (let ((pmark (progn (goto-char (process-mark proc)) - (beginning-of-line nil) - (point-marker)))) - ;; XEmacs - kill in case we want it back... - (kill-region comint-last-input-end pmark) - (goto-char (process-mark proc)) - (setq replacement (concat "*** output flushed ***\n" - (buffer-substring pmark (point)))) - (delete-region pmark (point)))) - ;; Output message and put back prompt - (comint-output-filter proc replacement))) - -;; XEmacs - don't move cursor unless necessary... -(defun comint-show-output () - "Display start of this batch of interpreter output at top of window. -Also put cursor there if the current position is not visible. -If the cursor is moved, then a mark is set at its old location." - (interactive) - (let ((pos (point))) - (goto-char (or (marker-position comint-last-input-end) (point-max))) - (beginning-of-line 0) - (set-window-start (selected-window) (point)) - (if (pos-visible-in-window-p pos) - (goto-char pos) - (save-excursion - (goto-char pos) - (push-mark)) - (comint-skip-prompt)))) - -(defun comint-interrupt-subjob () - "Interrupt the current subjob." - (interactive) - (interrupt-process nil comint-ptyp)) - -(defun comint-kill-subjob () - "Send kill signal to the current subjob." - (interactive) - (kill-process nil comint-ptyp)) - -(defun comint-quit-subjob () - "Send quit signal to the current subjob." - (interactive) - (quit-process nil comint-ptyp)) - -(defun comint-stop-subjob () - "Stop the current subjob. -WARNING: if there is no current subjob, you can end up suspending -the top-level process running in the buffer. If you accidentally do -this, use \\[comint-continue-subjob] to resume the process. (This -is not a problem with most shells, since they ignore this signal.)" - (interactive) - (stop-process nil comint-ptyp)) - -(defun comint-continue-subjob () - "Send CONT signal to process buffer's process group. -Useful if you accidentally suspend the top-level process." - (interactive) - (continue-process nil comint-ptyp)) - -(defun comint-kill-input () - "Kill all text from last stuff output by interpreter to point." - (interactive) - (let ((pmark (process-mark (get-buffer-process (current-buffer))))) - (if (> (point) (marker-position pmark)) - (kill-region pmark (point))))) - -(defun comint-delchar-or-maybe-eof (arg) - "Delete ARG characters forward, or (if at eob) send an EOF to subprocess." - (interactive "p") - (if (eobp) - (process-send-eof) - (delete-char arg))) - -(defun comint-send-eof () - "Send an EOF to the current buffer's process." - (interactive) - (process-send-eof)) - - -(defun comint-backward-matching-input (regexp arg) - "Search backward through buffer for match for REGEXP. -Matches are searched for on lines that match `comint-prompt-regexp'. -With prefix argument N, search for Nth previous match. -If N is negative, find the next or Nth next match." - (interactive (comint-regexp-arg "Backward input matching (regexp): ")) - (let* ((re (concat comint-prompt-regexp ".*" regexp)) - (pos (save-excursion (end-of-line (if (> arg 0) 0 1)) - (if (re-search-backward re nil t arg) - (point))))) - (if (null pos) - (progn (message "Not found") - (ding)) - (goto-char pos) - (comint-bol nil)))) - -(defun comint-forward-matching-input (regexp arg) - "Search forward through buffer for match for REGEXP. -Matches are searched for on lines that match `comint-prompt-regexp'. -With prefix argument N, search for Nth following match. -If N is negative, find the previous or Nth previous match." - (interactive (comint-regexp-arg "Forward input matching (regexp): ")) - (comint-backward-matching-input regexp (- arg))) - - -(defun comint-next-prompt (n) - "Move to end of Nth next prompt in the buffer. -See `comint-prompt-regexp'." - (interactive "_p") ; XEmacs - zmacs-regions - (let ((paragraph-start comint-prompt-regexp)) - (end-of-line (if (> n 0) 1 0)) - (forward-paragraph n) - (comint-skip-prompt))) - -(defun comint-previous-prompt (n) - "Move to end of Nth previous prompt in the buffer. -See `comint-prompt-regexp'." - (interactive "_p") ; XEmacs - (comint-next-prompt (- n))) - -;;; Support for source-file processing commands. -;;;============================================================================ -;;; Many command-interpreters (e.g., Lisp, Scheme, Soar) have -;;; commands that process files of source text (e.g. loading or compiling -;;; files). So the corresponding process-in-a-buffer modes have commands -;;; for doing this (e.g., lisp-load-file). The functions below are useful -;;; for defining these commands. -;;; -;;; Alas, these guys don't do exactly the right thing for Lisp, Scheme -;;; and Soar, in that they don't know anything about file extensions. -;;; So the compile/load interface gets the wrong default occasionally. -;;; The load-file/compile-file default mechanism could be smarter -- it -;;; doesn't know about the relationship between filename extensions and -;;; whether the file is source or executable. If you compile foo.lisp -;;; with compile-file, then the next load-file should use foo.bin for -;;; the default, not foo.lisp. This is tricky to do right, particularly -;;; because the extension for executable files varies so much (.o, .bin, -;;; .lbin, .mo, .vo, .ao, ...). - - -;;; COMINT-SOURCE-DEFAULT -- determines defaults for source-file processing -;;; commands. -;;; -;;; COMINT-CHECK-SOURCE -- if FNAME is in a modified buffer, asks you if you -;;; want to save the buffer before issuing any process requests to the command -;;; interpreter. -;;; -;;; COMINT-GET-SOURCE -- used by the source-file processing commands to prompt -;;; for the file to process. - -;;; (COMINT-SOURCE-DEFAULT previous-dir/file source-modes) -;;;============================================================================ -;;; This function computes the defaults for the load-file and compile-file -;;; commands for tea, soar, cmulisp, and cmuscheme modes. -;;; -;;; - PREVIOUS-DIR/FILE is a pair (directory . filename) from the last -;;; source-file processing command. NIL if there hasn't been one yet. -;;; - SOURCE-MODES is a list used to determine what buffers contain source -;;; files: if the major mode of the buffer is in SOURCE-MODES, it's source. -;;; Typically, (lisp-mode) or (scheme-mode). -;;; -;;; If the command is given while the cursor is inside a string, *and* -;;; the string is an existing filename, *and* the filename is not a directory, -;;; then the string is taken as default. This allows you to just position -;;; your cursor over a string that's a filename and have it taken as default. -;;; -;;; If the command is given in a file buffer whose major mode is in -;;; SOURCE-MODES, then the filename is the default file, and the -;;; file's directory is the default directory. -;;; -;;; If the buffer isn't a source file buffer (e.g., it's the process buffer), -;;; then the default directory & file are what was used in the last source-file -;;; processing command (i.e., PREVIOUS-DIR/FILE). If this is the first time -;;; the command has been run (PREVIOUS-DIR/FILE is nil), the default directory -;;; is the cwd, with no default file. (\"no default file\" = nil) -;;; -;;; SOURCE-REGEXP is typically going to be something like (tea-mode) -;;; for T programs, (lisp-mode) for Lisp programs, (soar-mode lisp-mode) -;;; for Soar programs, etc. -;;; -;;; The function returns a pair: (default-directory . default-file). - -(defun comint-source-default (previous-dir/file source-modes) - (cond ((and buffer-file-name (memq major-mode source-modes)) - (cons (file-name-directory buffer-file-name) - (file-name-nondirectory buffer-file-name))) - (previous-dir/file) - (t - (cons default-directory nil)))) - - -;;; (COMINT-CHECK-SOURCE fname) -;;;============================================================================ -;;; Prior to loading or compiling (or otherwise processing) a file (in the CMU -;;; process-in-a-buffer modes), this function can be called on the filename. -;;; If the file is loaded into a buffer, and the buffer is modified, the user -;;; is queried to see if he wants to save the buffer before proceeding with -;;; the load or compile. - -(defun comint-check-source (fname) - (let ((buff (get-file-buffer fname))) - (if (and buff - (buffer-modified-p buff) - (y-or-n-p (format "Save buffer %s first? " (buffer-name buff)))) - ;; save BUFF. - (let ((old-buffer (current-buffer))) - (set-buffer buff) - (save-buffer) - (set-buffer old-buffer))))) - - -;;; (COMINT-GET-SOURCE prompt prev-dir/file source-modes mustmatch-p) -;;;============================================================================ -;;; COMINT-GET-SOURCE is used to prompt for filenames in command-interpreter -;;; commands that process source files (like loading or compiling a file). -;;; It prompts for the filename, provides a default, if there is one, -;;; and returns the result filename. -;;; -;;; See COMINT-SOURCE-DEFAULT for more on determining defaults. -;;; -;;; PROMPT is the prompt string. PREV-DIR/FILE is the (directory . file) pair -;;; from the last source processing command. SOURCE-MODES is a list of major -;;; modes used to determine what file buffers contain source files. (These -;;; two arguments are used for determining defaults). If MUSTMATCH-P is true, -;;; then the filename reader will only accept a file that exists. -;;; -;;; A typical use: -;;; (interactive (comint-get-source "Compile file: " prev-lisp-dir/file -;;; '(lisp-mode) t)) - -;;; This is pretty stupid about strings. It decides we're in a string -;;; if there's a quote on both sides of point on the current line. -(defun comint-extract-string () - "Return string around POINT that starts the current line, or nil." - (save-excursion - (let* ((point (point)) - (bol (progn (beginning-of-line) (point))) - (eol (progn (end-of-line) (point))) - (start (progn (goto-char point) - (and (search-backward "\"" bol t) - (1+ (point))))) - (end (progn (goto-char point) - (and (search-forward "\"" eol t) - (1- (point)))))) - (and start end - (buffer-substring start end))))) - -(defun comint-get-source (prompt prev-dir/file source-modes mustmatch-p) - (let* ((def (comint-source-default prev-dir/file source-modes)) - (stringfile (comint-extract-string)) - (sfile-p (and stringfile - (condition-case () - (file-exists-p stringfile) - (error nil)) - (not (file-directory-p stringfile)))) - (defdir (if sfile-p (file-name-directory stringfile) - (car def))) - (deffile (if sfile-p (file-name-nondirectory stringfile) - (cdr def))) - (ans (read-file-name (if deffile (format "%s(default %s) " - prompt deffile) - prompt) - defdir - (concat defdir deffile) - mustmatch-p))) - (list (expand-file-name (substitute-in-file-name ans))))) - -;;; I am somewhat divided on this string-default feature. It seems -;;; to violate the principle-of-least-astonishment, in that it makes -;;; the default harder to predict, so you actually have to look and see -;;; what the default really is before choosing it. This can trip you up. -;;; On the other hand, it can be useful, I guess. I would appreciate feedback -;;; on this. -;;; -Olin - - -;;; Simple process query facility. -;;; =========================================================================== -;;; This function is for commands that want to send a query to the process -;;; and show the response to the user. For example, a command to get the -;;; arglist for a Common Lisp function might send a "(arglist 'foo)" query -;;; to an inferior Common Lisp process. -;;; -;;; This simple facility just sends strings to the inferior process and pops -;;; up a window for the process buffer so you can see what the process -;;; responds with. We don't do anything fancy like try to intercept what the -;;; process responds with and put it in a pop-up window or on the message -;;; line. We just display the buffer. Low tech. Simple. Works good. - -;;; Send to the inferior process PROC the string STR. Pop-up but do not select -;;; a window for the inferior process so that its response can be seen. -(defun comint-proc-query (proc str) - (let* ((proc-buf (process-buffer proc)) - (proc-mark (process-mark proc))) - (display-buffer proc-buf) - (set-buffer proc-buf) ; but it's not the selected *window* - (let ((proc-win (get-buffer-window proc-buf)) - (proc-pt (marker-position proc-mark))) - (comint-send-string proc str) ; send the query - (accept-process-output proc) ; wait for some output - ;; Try to position the proc window so you can see the answer. - ;; This is bogus code. If you delete the (sit-for 0), it breaks. - ;; I don't know why. Wizards invited to improve it. - (if (not (pos-visible-in-window-p proc-pt proc-win)) - (let ((opoint (window-point proc-win))) - (set-window-point proc-win proc-mark) - (sit-for 0) - (if (not (pos-visible-in-window-p opoint proc-win)) - (push-mark opoint) - (set-window-point proc-win opoint))))))) - - -;;; Filename/command/history completion in a buffer -;;; =========================================================================== -;;; Useful completion functions, courtesy of the Ergo group. - -;;; Six commands: -;;; comint-dynamic-complete Complete or expand command, filename, -;;; history at point. -;;; comint-dynamic-complete-filename Complete filename at point. -;;; comint-dynamic-list-filename-completions List completions in help buffer. -;;; comint-replace-by-expanded-filename Expand and complete filename at point; -;;; replace with expanded/completed name. -;;; comint-dynamic-simple-complete Complete stub given candidates. - -;;; These are not installed in the comint-mode keymap. But they are -;;; available for people who want them. Shell-mode installs them: -;;; (define-key shell-mode-map "\t" 'comint-dynamic-complete) -;;; (define-key shell-mode-map "\M-?" -;;; 'comint-dynamic-list-filename-completions))) -;;; -;;; Commands like this are fine things to put in load hooks if you -;;; want them present in specific modes. - -(defcustom comint-completion-autolist nil - "*If non-nil, automatically list possibilities on partial completion. -This mirrors the optional behavior of tcsh." - :type 'boolean - :group 'comint-completion) - -(defcustom comint-completion-addsuffix t - "*If non-nil, add a `/' to completed directories, ` ' to file names. -If a cons pair, it should be of the form (DIRSUFFIX . FILESUFFIX) where -DIRSUFFIX and FILESUFFIX are strings added on unambiguous or exact completion. -This mirrors the optional behavior of tcsh." - :type 'boolean - :group 'comint-completion) - -(defcustom comint-completion-recexact nil - "*If non-nil, use shortest completion if characters cannot be added. -This mirrors the optional behavior of tcsh. - -A non-nil value is useful if `comint-completion-autolist' is non-nil too." - :type 'boolean - :group 'comint-completion) - -(defcustom comint-completion-fignore nil - "*List of suffixes to be disregarded during file completion. -This mirrors the optional behavior of bash and tcsh. - -Note that this applies to `comint-dynamic-complete-filename' only." - :type '(repeat (string :tag "Suffix")) - :group 'comint-completion) - -(defvar comint-file-name-prefix "" - "Prefix prepended to absolute file names taken from process input. -This is used by comint's and shell's completion functions, and by shell's -directory tracking functions.") - -(defvar comint-file-name-quote-list nil - "List of characters to quote with `\' when in a file name. - -This is a good thing to set in mode hooks.") - - -(defun comint-directory (directory) - ;; Return expanded DIRECTORY, with `comint-file-name-prefix' if absolute. - (expand-file-name (if (file-name-absolute-p directory) - (concat comint-file-name-prefix directory) - directory))) - - -(defun comint-word (word-chars) - "Return the word of WORD-CHARS at point, or nil if non is found. -Word constituents are considered to be those in WORD-CHARS, which is like the -inside of a \"[...]\" (see `skip-chars-forward')." - (save-excursion - (let ((non-word-chars (concat "[^\\\\" word-chars "]")) (here (point))) - (while (and (re-search-backward non-word-chars nil 'move) - ;(memq (char-after (point)) shell-file-name-quote-list) - (eq (preceding-char) ?\\)) - (backward-char 1)) - ;; Don't go forward over a word-char (this can happen if we're at bob). - (if (or (not (bobp)) (looking-at non-word-chars)) - (forward-char 1)) - ;; Set match-data to match the entire string. - (if (< (point) here) - (progn (store-match-data (list (point) here)) - (match-string 0)))))) - -(defun comint-extract-current-pathname () - "Return the file name at point. -`@' or `.' are not valid characters at the end of the filename." - (save-excursion - (re-search-forward "@?\\([^-A-Za-z0-9_,/+%.~]\\|$\\)") - (goto-char (match-beginning 0)) - (re-search-backward - "[^-A-Za-z0-9_,/+%.@~][-A-Za-z0-9_,/+%.@~]+[-A-Za-z0-9_+%~]" - nil t) - (buffer-substring (1+ (match-beginning 0)) (match-end 0)))) - -(defun comint-match-partial-filename () - "Return the filename at point, or nil if none is found. -Environment variables are substituted. See `comint-word'." - (let ((filename (comint-word "~/A-Za-z0-9+@:_.$#%,={}-"))) - (and filename (substitute-in-file-name (comint-unquote-filename filename))))) - - -(defun comint-quote-filename (filename) - "Return FILENAME with magic characters quoted. -Magic characters are those in `comint-file-name-quote-list'." - (if (null comint-file-name-quote-list) - filename - (let ((regexp - (format "\\(^\\|[^\\]\\)\\([%s]\\)" - (mapconcat 'char-to-string comint-file-name-quote-list "")))) - (save-match-data - (while (string-match regexp filename) - (setq filename (replace-match "\\1\\\\\\2" nil nil filename))) - filename)))) - -(defun comint-unquote-filename (filename) - "Return FILENAME with quoted characters unquoted." - (if (null comint-file-name-quote-list) - filename - (save-match-data - (while (string-match "\\\\\\(.\\)" filename) - (setq filename (replace-match "\\1" nil nil filename))) - filename))) - - -;;;###autoload -(defun comint-dynamic-complete () - "Dynamically perform completion at point. -Calls the functions in `comint-dynamic-complete-functions' to perform -completion until a function returns non-nil, at which point completion is -assumed to have occurred." - (interactive) - (run-hook-with-args-until-success 'comint-dynamic-complete-functions)) - - -(defun comint-dynamic-complete-filename () - "Dynamically complete the filename at point. -Completes if after a filename. See `comint-match-partial-filename' and -`comint-dynamic-complete-as-filename'. -This function is similar to `comint-replace-by-expanded-filename', except that -it won't change parts of the filename already entered in the buffer; it just -adds completion characters to the end of the filename. A completions listing -may be shown in a help buffer if completion is ambiguous. - -Completion is dependent on the value of `comint-completion-addsuffix', -`comint-completion-recexact' and `comint-completion-fignore', and the timing of -completions listing is dependent on the value of `comint-completion-autolist'. - -Returns t if successful." - (interactive) - (if (comint-match-partial-filename) - (prog2 (or (window-minibuffer-p (selected-window)) - (message "Completing file name...")) - (comint-dynamic-complete-as-filename)))) - - -(defun comint-dynamic-complete-as-filename () - "Dynamically complete at point as a filename. -See `comint-dynamic-complete-filename'. Returns t if successful." - (let* ((completion-ignore-case nil) - (completion-ignored-extensions comint-completion-fignore) - (file-name-handler-alist nil) - (minibuffer-p (window-minibuffer-p (selected-window))) - (success t) - (dirsuffix (cond ((not comint-completion-addsuffix) "") - ((not (consp comint-completion-addsuffix)) "/") - (t (car comint-completion-addsuffix)))) - (filesuffix (cond ((not comint-completion-addsuffix) "") - ((not (consp comint-completion-addsuffix)) " ") - (t (cdr comint-completion-addsuffix)))) - (filename (or (comint-match-partial-filename) "")) - (pathdir (file-name-directory filename)) - (pathnondir (file-name-nondirectory filename)) - (directory (if pathdir (comint-directory pathdir) default-directory)) - (completion (file-name-completion pathnondir directory))) - (cond ((null completion) - (if minibuffer-p (ding) (message "No completions of %s" filename)) - (setq success nil)) - ((eq completion t) ; Means already completed "file". - (insert filesuffix) - (or minibuffer-p (message "Sole completion"))) - ((string-equal completion "") ; Means completion on "directory/". - (comint-dynamic-list-filename-completions)) - (t ; Completion string returned. - (let ((file (concat (file-name-as-directory directory) completion))) - (insert (comint-quote-filename - (substring (directory-file-name completion) - (length pathnondir)))) - (cond ((symbolp (file-name-completion completion directory)) - ;; We inserted a unique completion. - (insert (if (file-directory-p file) dirsuffix filesuffix)) - (or minibuffer-p (message "Completed"))) - ((and comint-completion-recexact comint-completion-addsuffix - (string-equal pathnondir completion) - (file-exists-p file)) - ;; It's not unique, but user wants shortest match. - (insert (if (file-directory-p file) dirsuffix filesuffix)) - (or minibuffer-p (message "Completed shortest"))) - ((or comint-completion-autolist - (string-equal pathnondir completion)) - ;; It's not unique, list possible completions. - (comint-dynamic-list-filename-completions)) - (t - (or minibuffer-p (message "Partially completed"))))))) - success)) - - -(defun comint-replace-by-expanded-filename () - "Dynamically expand and complete the filename at point. -Replace the filename with an expanded, canonicalised and completed replacement. -\"Expanded\" means environment variables (e.g., $HOME) and `~'s are replaced -with the corresponding directories. \"Canonicalised\" means `..' and `.' are -removed, and the filename is made absolute instead of relative. For expansion -see `expand-file-name' and `substitute-in-file-name'. For completion see -`comint-dynamic-complete-filename'." - (interactive) - (replace-match (expand-file-name (comint-match-partial-filename)) t t) - (comint-dynamic-complete-filename)) - - -(defun comint-dynamic-simple-complete (stub candidates) - "Dynamically complete STUB from CANDIDATES list. -This function inserts completion characters at point by completing STUB from -the strings in CANDIDATES. A completions listing may be shown in a help buffer -if completion is ambiguous. - -Returns nil if no completion was inserted. -Returns `sole' if completed with the only completion match. -Returns `shortest' if completed with the shortest of the completion matches. -Returns `partial' if completed as far as possible with the completion matches. -Returns `listed' if a completion listing was shown. - -See also `comint-dynamic-complete-filename'." - (let* ((completion-ignore-case nil) - (suffix (cond ((not comint-completion-addsuffix) "") - ((not (consp comint-completion-addsuffix)) " ") - (t (cdr comint-completion-addsuffix)))) - (candidates (mapcar (function (lambda (x) (list x))) candidates)) - (completions (all-completions stub candidates))) - (cond ((null completions) - (message "No completions of %s" stub) - nil) - ((= 1 (length completions)) ; Gotcha! - (let ((completion (car completions))) - (if (string-equal completion stub) - (message "Sole completion") - (insert (substring completion (length stub))) - (message "Completed")) - (insert suffix) - 'sole)) - (t ; There's no unique completion. - (let ((completion (try-completion stub candidates))) - ;; Insert the longest substring. - (insert (substring completion (length stub))) - (cond ((and comint-completion-recexact comint-completion-addsuffix - (string-equal stub completion) - (member completion completions)) - ;; It's not unique, but user wants shortest match. - (insert suffix) - (message "Completed shortest") - 'shortest) - ((or comint-completion-autolist - (string-equal stub completion)) - ;; It's not unique, list possible completions. - (comint-dynamic-list-completions completions) - 'listed) - (t - (message "Partially completed") - 'partial))))))) - - -(defun comint-dynamic-list-filename-completions () - "List in help buffer possible completions of the filename at point." - (interactive) - (let* ((completion-ignore-case nil) - (file-name-handler-alist nil) - (filename (or (comint-match-partial-filename) "")) - (pathdir (file-name-directory filename)) - (pathnondir (file-name-nondirectory filename)) - (directory (if pathdir (comint-directory pathdir) default-directory)) - (completions (file-name-all-completions pathnondir directory))) - (if (not completions) - (message "No completions of %s" filename) - (comint-dynamic-list-completions - (mapcar 'comint-quote-filename completions))))) - - -;;;###autoload -(defun comint-dynamic-list-completions (completions) - "List in help buffer sorted COMPLETIONS. -Typing SPC flushes the help buffer." - (let ((conf (current-window-configuration))) - (with-output-to-temp-buffer "*Completions*" - (display-completion-list (sort completions 'string-lessp))) - ;; XEmacs - centralize this - (comint-restore-window-config conf))) - -;; #### - FSFmacs doesn't have this and I'm not gonna nuke it just yet, but -;; it seems awfully redundant to have this here when compile.el does pretty -;; much the same thing. --Stig - -;;; Filename and source location extraction from a buffer. -;;; lemacs change by John Rose -;;; =========================================================================== -;;; Functions for recognizing and extracting file names and line numbers. -;;; C-c C-f attempts to extract a location from the current line, and -;;; go to that location. - -;;; One command: -;;; comint-find-source-code Extract source location and follow it. - -;;; This should be installed globally, since file names and source locations -;;; are ubiquitous. However, don't overwrite an existing key binding. -(if (not (lookup-key global-map "\C-c\C-f")) - (global-set-key "\C-c\C-f" 'comint-find-source-code)) - -;;; Utility functions: -;;; comint-extract-source-location Parse source loc. from buffer or string. -;;; comint-extract-current-pathname Extract potential pathname around point. -;;; comint-match-partial-pathname Match a potential pathname before point. - -(defconst comint-source-location-patterns - '(;; grep (and cpp): file.c: 10: - ("\\(^\\|[ \t]\\)\\([^ \t\n]+\\): *\\([0-9]+\\):[ \t]*\\(.*\\)" (grep cpp) (2 3 4)) - ;; cpp: #line 10 "file.c" - ("#\\(line\\)? *\\([0-9]+\\) *\"\\([^\"\n]+\\)\"" cpp (3 2)) - ;; cc: "file.c", line 10 - ("\"\\([^\"\n]+\\)\", line +\\([0-9]+\\)\\(:[ \t]+\\(.*\\)\\)?" cc (1 2 4)) - ;; f77: line 10 of file.c - ("line +\\([0-9]+\\) +of +\\([^ \t\n]+\\)\\(:[ \t]+\\(.*\\)\\)?" f77 (2 1 4)) - ;; perl: ...at file.c line 10. - ;; perl: ...at file.c line 10, near "foo" - ("^\\(.*\\) at \\([^ \t\n]+\\) line +\\([0-9]+\\)\\(\\.$\\|, \\)" - perl (2 3 1)) - ;; dbx: line 10 in "file.c" - ("\\(^\\(.*\\)[ \t]+at \\)?line +\\([0-9]+\\) +[in of file]+ +\"\\([^\"\n]+\\)\"" - dbx (4 3 2)) - ;; dbx: "file.c":10 - ("\"\\([^\"\n]+\\)\":\\([0-9]+\\)" dbx (1 2)) - ;; centerline: "file.c:10" - ("\"\\([^\"\n]+\\):\\([0-9]+\\)\"" centerline (1 2)) - ;; lint: : file.c(10) - (": *\\([^ \t\n)]+\\) *(\\([0-9]+\\))" lint (1 2)) - ;; lint: file.c(10) : - ("\\(^\\|[ \t]\\)\\([^ \t\n)]+\\) *(\\([0-9]+\\)) *:" lint (2 3)) - ;; lint: ( file.c(10) ) - ("( +\\([^ \t\n)]+\\) *(\\([0-9]+\\)) +)" lint (1 2)) - ;; troff: `file.c', line 10 - ("[\"`']\\([^\"`'\n]+\\)[\"`'], line +\\([0-9]+\\)" troff (1 2)) - ;; ri: "file.c" 10: - ("\"\\([^\"\n]+\\)\" *\\([0-9]+\\):" ri (1 2)) ;;Never heard of ri. - ;; mod: File file.c, line 10 - ("[Ff]ile +\\([^ \t\n]+\\), line +\\([0-9]+\\)" mod (1 2)) - ;; ksh: file.c[10] : - ("\\(^\\|[ \t]\\)\\([^ \t\n)]+\\) *\\[\\([0-9]+\\)\\] *:[ \t]+\\(.*\\)" - ksh (2 3 4)) - ;; shell: file.c: syntax error at line 10 - ("\\(^\\|[ \t]\\)\\([^ \t\n:]+\\):[ \t]+\\(.*\\)[ \t]+[, at]*line +\\([0-9]+\\)" - sh (2 4 3) -1) - ) - "Series of regexps matching file number locations. -Each list entry is a 3-list of a regexp, a program name, and up to 3 numbers. -The numbers name regexp fields which will hold the file, line number, -and associated diagnostic message (if any). -The program name is a symbol or list of symbols, and -is returned unexamined from `comint-extract-source-location'; -it should be a guess at who produced the message, e.g., 'cc'. - -In the case of multiple matches, `comint-extract-source-location' -will return the leftmost, longest match of the highest priority. -The priority of most patterns is 0, but a fourth element on -the list, if present, specifies a different priority. - -The regexps initially stored here are based on the one in compile.el -\(although the pattern containing 'of' must also contain 'line'). -They are also drawn from the Unix filters 'error' and 'fwarn'. -The patterns are known to recognize errors from the following -Un*x language processors: - cpp, cc, dbx, lex, f77, Centerline C, sh (Bourne), lint, mod -The following language processors do not incorporate file names -in every error message, and so are more difficult to accomodate: - yacc, pc, csh - ") - -(defun comint-extract-source-location (&optional start end commands markers) - "Return a 6-list of (file line command diagnostic mstart mend), -obtained by parsing the current buffer between START and END, -which default to the bounds of the current line. - -Use the list comint-source-location-patterns to guide parsing. - -The match returned will be on the latest line containing a match, but -will be the earliest possible match on that line. - -START can also be a string, in which case it inserted in the buffer -\"*Extract File and Line*\" and parsed there. - -COMMANDS is an optional list of pattern types, which has the effect of -temporarily reducing the list comint-source-location-patterns -to only those entries which apply to the given commands. - -Return NIL if there is no recognizable source location. - -MSTART and MEND give the limits of the matched source location. - -If MARKERS is true, return no strings, but rather cons cells -of the form (beg-marker . end-marker). -" - (if (not start) - (progn - (setq start (save-excursion (beginning-of-line) (point))) - (setq end (save-excursion (end-of-line) (point))))) - (if (stringp start) - (save-excursion - (set-buffer (get-buffer-create "*Extract File and Line*")) - (erase-buffer) - (insert start) - (comint-extract-source-location (point-min) (point-max) commands markers)) - (let ((ptr (if (and (consp commands) - (consp (car commands))) - (prog1 commands (setq commands nil)) - comint-source-location-patterns)) - pat - (found-bol (- (point-min) 1)) - (found-prio -999999) - found-beg - found-end - found-pat - found-data - set-found-data) - (setq set-found-data - (function (lambda (data) - (while found-data - (let ((m (car found-data))) - (if (markerp m) (set-marker m nil))) - (setq found-data (cdr found-data))) - (setq found-data data)))) - (if (and commands (not (listp commands))) - (setq commands (list commands))) - (save-excursion - (save-restriction - (narrow-to-region start end) - (while ptr - (setq pat (car ptr) ptr (cdr ptr)) - (goto-char (point-max)) - (if (and (or (null commands) - (if (consp (nth 1 pat)) - (member (nth 1 pat) commands) - ;; If (cadr pat) is a list, each list element - ;; is a command that might produce this. - (let ((ptr (nth 1 pat)) - (ismem nil)) - (while (and ptr (not ismem)) - (if (member (car ptr) commands) - (setq ismem t)) - (setq ptr (cdr ptr))) - ismem))) - (re-search-backward (nth 0 pat) found-bol t)) - (let (beg end bol prio) - (setq beg (match-beginning 0)) - (setq end (match-end 0)) - (beginning-of-line) - (setq bol (point)) - (re-search-forward (nth 0 pat)) - (if (> (match-beginning 0) beg) - (error "comint-extract-source-location botch")) - (setq beg (match-beginning 0)) - (setq end (match-end 0)) - (setq prio (or (nth 3 pat) 0)) - (if (or (> bol found-bol) - (and (= bol found-bol) - (or (> prio found-prio) - (and (= prio found-prio) - (or (< beg found-beg) - (and (= beg found-beg) - (> end found-end))))))) - (progn - (setq found-bol bol) - (setq found-prio prio) - (setq found-beg beg) - (setq found-end end) - (setq found-pat pat) - (funcall set-found-data (match-data))))))))) - (and found-data - (let* ((command (nth 1 found-pat)) - (fields (nth 2 found-pat)) - (f1 (nth 0 fields)) - (f2 (nth 1 fields)) - (f3 (nth 2 fields)) - (get-field - (function - (lambda (fn) - (and fn - (let ((beg (match-beginning fn)) - (end (match-end fn))) - (and beg end (> end beg) - (if markers - (cons (copy-marker beg) (copy-marker end)) - (buffer-substring beg end))))))))) - (store-match-data found-data) - (funcall set-found-data nil) - (let ((file (funcall get-field f1)) - (line (funcall get-field f2)) - (diagnostic (funcall get-field f3)) - (mstart (match-beginning 0)) - (mend (match-end 0))) - ;; (carefully use all match-data before calling string-match) - (list - file - (if (and (stringp line) - (prog1 - (string-match "\\`[0-9]+\\'" line) - (store-match-data found-data))) - (string-to-int line) - line) - command - diagnostic - mstart - mend - )))) - ))) - -;;; Commands for extracting source locations: - -(defcustom comint-find-source-code-max-lines 100 - "*Maximum number of lines to search backward for a source location, -when using \\[comint-find-source-code\\] with an interactive prefix." - :type 'integer - :group 'comint-source) - -(defcustom comint-find-source-file-hook nil - "*Function to call instead of comint-default-find-source-file -when comint-find-source-code parses out a file name and then wants to -visit its buffer. The sole argument is the file name. The function -must find the file, setting the current buffer, and return the file -name. It may also adjust the file name. If you change this variable, -make it buffer local." - :type 'function - :group 'comint-source) - -(defcustom comint-goto-source-line-hook nil - "*Function to call instead of comint-default-goto-source-line -after comint-find-source-code finds a file and then wants to -go to a line number mentioned in a source location. -The sole argument is the line number. The function must -return the line number, possibly adjusted. If you change -this variable, make it buffer local." - :type 'function - :group 'comint-source) - -(defun comint-find-source-code (multi-line) - "Search backward from point for a source location. -If a source location is found in the current line, -go to that location. - -If MULTI-LINE is false (this is the interactive prefix flag), -then only look for source locations in the current line. -Otherwise, look within comint-find-source-code-max-lines -before point. If a source location is found on a previous line, move -point to that location, so that another use of \\[comint-find-source-code\\] -will go to the indicated place. - -If no source location is found, then try to extract a filename -around the point, using comint-extract-current-pathname. - -In any case, if the file does not exist, prompt the user for -a pathname that does. Sometimes the file's directory needs -hand adjustment. - -This command uses comint-extract-source-location, which is customizable. -Also, once a source file and line have been extracted, it uses -comint-find-source-file-hook and comint-goto-source-line-hook -to interpret them." - (interactive "P") - (let* ((beg (save-excursion - (if multi-line - (forward-line (min 0 (- comint-find-source-code-max-lines))) - (beginning-of-line)) - (point))) - (end (save-excursion (end-of-line) (point))) - (res (or (comint-extract-source-location beg end) - (let ((file (comint-extract-current-pathname))) - (and file - (list file nil nil nil - (match-beginning 0) - (match-end 0)))) - (error "Not sitting on a source location.")))) - (let ((file (nth 0 res)) - (line (nth 1 res)) - ;;(cmd (nth 2 res)) - (info (nth 3 res)) - (mbeg (nth 4 res)) - (mend (nth 5 res)) - dofind) - (setq dofind - (not (and multi-line - mend - (< mend (save-excursion (beginning-of-line) (point)))))) - (if (not dofind) - (goto-char mbeg) - (progn - (setq file - (funcall (or comint-find-source-file-hook - 'comint-default-find-source-file) - file)) - (if line - (setq line - (funcall (or comint-goto-source-line-hook - 'comint-default-goto-source-line) - line))) - )) - (message "%s%s of %s%s%s" - (if dofind - "" (substitute-command-keys - "Hit \\[comint-find-source-code] for ")) - (cond ((null line) "current line") - ((numberp line) (format "line %s" line)) - (t line)) - (file-name-nondirectory file) - (if info ": " "") (or info ""))))) - - -(defun comint-default-find-source-file (file) - "Action taken by \\[comint-find-source-code] when find-source-file-hook is nil. -It calls substitute-in-file-name. If the file does not exist, it prompts -for the right pathname, using a similar pathname derived from a nearby -buffer as a default. It then calls find-file-other-window and returns the -amended file name." - (setq file (substitute-in-file-name file)) - (if (not (file-readable-p file)) - (setq file (comint-fixup-source-file-name file))) - (find-file-other-window file) - file) - -(defun comint-fixup-source-file-name (file) - (let (dir ptr nondir bfile res) - (setq nondir (file-name-nondirectory file)) - (setq ptr (buffer-list)) - (while (and ptr (not dir)) - (setq bfile (buffer-file-name (car ptr))) - (if (and bfile (equal (file-name-nondirectory bfile) nondir)) - (setq dir (file-name-directory bfile) - file (file-name-nondirectory bfile))) - (setq ptr (cdr ptr))) - (setq res - (read-file-name "Source file: " dir t nil file)) - (if (eq res t) - (expand-file-name file dir) - res))) - -(defun comint-default-goto-source-line (line) - "Action taken by \\[comint-find-source-code] when goto-source-line-hook is nil. -It widens & pushes the mark, then does goto-line in the current buffer. -It returns its line argument." - (widen) - (setq line (max line 0)) - (setq line (min line (+ 1 (count-lines (point-min) (point-max))))) - (push-mark) - (goto-line line) - line) - -;;; Converting process modes to use comint mode -;;; =========================================================================== -;;; The code in the Emacs 19 distribution has all been modified to use comint -;;; where needed. However, there are `third-party' packages out there that -;;; still use the old shell mode. Here's a guide to conversion. -;;; -;;; Renaming variables -;;; Most of the work is renaming variables and functions. These are the common -;;; ones: -;;; Local variables: -;;; last-input-start comint-last-input-start -;;; last-input-end comint-last-input-end -;;; shell-prompt-pattern comint-prompt-regexp -;;; shell-set-directory-error-hook <no equivalent> -;;; Miscellaneous: -;;; shell-set-directory <unnecessary> -;;; shell-mode-map comint-mode-map -;;; Commands: -;;; shell-send-input comint-send-input -;;; shell-send-eof comint-delchar-or-maybe-eof -;;; kill-shell-input comint-kill-input -;;; interrupt-shell-subjob comint-interrupt-subjob -;;; stop-shell-subjob comint-stop-subjob -;;; quit-shell-subjob comint-quit-subjob -;;; kill-shell-subjob comint-kill-subjob -;;; kill-output-from-shell comint-kill-output -;;; show-output-from-shell comint-show-output -;;; copy-last-shell-input Use comint-previous-input/comint-next-input -;;; -;;; SHELL-SET-DIRECTORY is gone, its functionality taken over by -;;; SHELL-DIRECTORY-TRACKER, the shell mode's comint-input-filter-functions. -;;; Comint mode does not provide functionality equivalent to -;;; shell-set-directory-error-hook; it is gone. -;;; -;;; comint-last-input-start is provided for modes which want to munge -;;; the buffer after input is sent, perhaps because the inferior -;;; insists on echoing the input. The LAST-INPUT-START variable in -;;; the old shell package was used to implement a history mechanism, -;;; but you should think twice before using comint-last-input-start -;;; for this; the input history ring often does the job better. -;;; -;;; If you are implementing some process-in-a-buffer mode, called foo-mode, do -;;; *not* create the comint-mode local variables in your foo-mode function. -;;; This is not modular. Instead, call comint-mode, and let *it* create the -;;; necessary comint-specific local variables. Then create the -;;; foo-mode-specific local variables in foo-mode. Set the buffer's keymap to -;;; be foo-mode-map, and its mode to be foo-mode. Set the comint-mode hooks -;;; (comint-{prompt-regexp, input-filter, input-filter-functions, -;;; get-old-input) that need to be different from the defaults. Call -;;; foo-mode-hook, and you're done. Don't run the comint-mode hook yourself; -;;; comint-mode will take care of it. The following example, from shell.el, -;;; is typical: -;;; -;;; (defvar shell-mode-map '()) -;;; (cond ((not shell-mode-map) -;;; (setq shell-mode-map (copy-keymap comint-mode-map)) -;;; (define-key shell-mode-map "\C-c\C-f" 'shell-forward-command) -;;; (define-key shell-mode-map "\C-c\C-b" 'shell-backward-command) -;;; (define-key shell-mode-map "\t" 'comint-dynamic-complete) -;;; (define-key shell-mode-map "\M-?" -;;; 'comint-dynamic-list-filename-completions))) -;;; -;;; (defun shell-mode () -;;; (interactive) -;;; (comint-mode) -;;; (setq comint-prompt-regexp shell-prompt-pattern) -;;; (setq major-mode 'shell-mode) -;;; (setq mode-name "Shell") -;;; (use-local-map shell-mode-map) -;;; (make-local-variable 'shell-directory-stack) -;;; (setq shell-directory-stack nil) -;;; (add-hook 'comint-input-filter-functions 'shell-directory-tracker) -;;; (run-hooks 'shell-mode-hook)) -;;; -;;; -;;; Note that make-comint is different from make-shell in that it -;;; doesn't have a default program argument. If you give make-shell -;;; a program name of NIL, it cleverly chooses one of explicit-shell-name, -;;; $ESHELL, $SHELL, or /bin/sh. If you give make-comint a program argument -;;; of NIL, it barfs. Adjust your code accordingly... -;;; -;;; Completion for comint-mode users -;;; -;;; For modes that use comint-mode, comint-dynamic-complete-functions is the -;;; hook to add completion functions to. Functions on this list should return -;;; non-nil if completion occurs (i.e., further completion should not occur). -;;; You could use comint-dynamic-simple-complete to do the bulk of the -;;; completion job. - - -;;; Do the user's customisation... - -(defvar comint-load-hook nil - "This hook is run when comint is loaded in. -This is a good place to put keybindings.") - -(run-hooks 'comint-load-hook) - - -(provide 'comint) - -;;; comint.el ends here
--- a/lisp/comint/custom-load.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,19 +0,0 @@ -;;; custom-load.el --- automatically extracted custom dependencies - - -;;; Code: - -(custom-add-loads 'ssh '("ssh")) -(custom-add-loads 'telnet '("telnet")) -(custom-add-loads 'shell '("shell")) -(custom-add-loads 'comint-completion '("comint")) -(custom-add-loads 'comint '("comint-xemacs" "comint" "telnet")) -(custom-add-loads 'rlogin '("rlogin")) -(custom-add-loads 'shell-faces '("shell")) -(custom-add-loads 'shell-directories '("shell")) -(custom-add-loads 'comint-source '("comint")) -(custom-add-loads 'processes '("background" "comint" "rlogin" "shell" "ssh")) -(custom-add-loads 'background '("background")) -(custom-add-loads 'unix '("rlogin" "shell" "ssh")) - -;;; custom-load.el ends here
--- a/lisp/comint/dbx.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,173 +0,0 @@ -;;; dbx.el --- run dbx under Emacs - -;; Copyright (C) 1988 Free Software Foundation, Inc. - -;; Author: Masanobu UMEDA (umerin@flab.fujitsu.junet) -;; Keywords: c, unix, tools, debugging - -;; 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 - -;;; Code: - -(require 'comint) - -(defvar dbx-trace-flag nil - "Dbx trace switch.") - -(defvar dbx-process nil - "The process in which dbx is running.") - -(defvar dbx-break-point - "stopped in .* at line \\([0-9]*\\) in file \"\\([^\"]*\\)\"" - "Regexp of pattern that dbx writes at break point.") - -(defvar inferior-dbx-mode-map nil) -(if inferior-dbx-mode-map - nil - (setq inferior-dbx-mode-map (make-sparse-keymap)) - (set-keymap-name inferior-dbx-mode-map 'inferior-dbx-mode-map) - (set-keymap-parent inferior-dbx-mode-map comint-mode-map) - (define-key inferior-dbx-mode-map "\C-c\C-w" 'dbx-where) - (define-key inferior-dbx-mode-map "\C-c\C-t" 'dbx-trace-mode) - (define-key ctl-x-map " " 'dbx-stop-at)) - -(defun inferior-dbx-mode () - "Major mode for interacting with an inferior dbx process. - -The following commands are available: -\\{inferior-dbx-mode-map} - -Entry to this mode calls the value of dbx-mode-hook with no arguments, -if that value is non-nil. Likewise with the value of comint-mode-hook. -dbx-mode-hook is called after comint-mode-hook. - -You can display the debugging program in other window and point out -where you are looking at using the command \\[dbx-where]. - -\\[dbx-trace-mode] toggles dbx-trace mode. In dbx-trace mode, -debugging program is automatically traced using output from dbx. - -The command \\[dbx-stop-at] sets break point at current line of the -program in the buffer. Major mode name of the buffer must be in -dbx-language-mode-list. - -Commands: - -Return at end of buffer sends line as input. -Return not at end copies line, sans any dbx prompt, to end and sends it. -\\[shell-send-eof] sends end-of-file as input. -\\[comint-kill-input] and \\[backward-kill-word] are kill commands, imitating normal Unix input editing. -\\[comint-interrupt-subjob] interrupts the shell or its current subjob if any. -\\[comint-stop-subjob] stops, likewise. \\[comint-quit-subjob] sends quit signal, likewise. -\\[dbx-where] displays debugging program in other window and - points out where you are looking at. -\\[dbx-trace-mode] toggles dbx-trace mode. -\\[dbx-stop-at] sets break point at current line." - (interactive) - (kill-all-local-variables) - (comint-mode) - (use-local-map inferior-dbx-mode-map) - (setq major-mode 'inferior-dbx-mode - mode-name "Inferior dbx" - comint-prompt-regexp "^[^)]*dbx) *") - (make-local-variable 'dbx-trace-flag) - (or (assq 'dbx-trace-flag minor-mode-alist) - (setq minor-mode-alist - (cons '(dbx-trace-flag " Trace") minor-mode-alist))) - (run-hooks 'dbx-mode-hook)) - -(defun run-dbx (path) - "Run inferior dbx process on PROGRAM, with I/O via buffer *dbx-PROGRAM*." - (interactive "fProgram to debug: ") - (setq path (expand-file-name path)) - (let ((file (file-name-nondirectory path))) - (switch-to-buffer (concat "*dbx-" file "*")) - (setq default-directory (file-name-directory path)) - (switch-to-buffer (make-comint (concat "dbx-" file) "dbx" nil file))) - (setq dbx-process (get-buffer-process (current-buffer))) - (set-process-filter dbx-process 'dbx-filter) - (inferior-dbx-mode)) - -(defun dbx-trace-mode (arg) - "Toggle dbx-trace mode. -With arg, turn dbx-trace mode on iff arg is positive. -In dbx-trace mode, user program is automatically traced." - (interactive "P") - (if (not (eql major-mode 'inferior-dbx-mode)) - (error "dbx-trace mode is effective in inferior-dbx mode only.")) - (setq dbx-trace-flag - (if (null arg) - (not dbx-trace-flag) - (> (prefix-numeric-value arg) 0))) - ;; Force mode line redisplay - (set-buffer-modified-p (buffer-modified-p))) - -(defun dbx-filter (process string) - "Trace debugging program automatically if dbx-trace-flag is not nil." - (save-excursion - (set-buffer (process-buffer process)) - (goto-char (point-max)) - (let ((beg (point))) - (insert-before-markers string) - (if dbx-trace-flag ;Trace mode is on? - (dbx-where beg t))) - (if (process-mark process) - (set-marker (process-mark process) (point-max)))) - (if (eq (process-buffer process) - (current-buffer)) - (goto-char (point-max))) - ) - -(defun dbx-where (&optional begin quiet) - "Display dbx'ed program in other window and point out where you are looking. -BEGIN bounds the search. If QUIET, just return nil (no error) if fail." - (interactive) - (let (file line) - (save-excursion - (if (re-search-backward dbx-break-point begin quiet) - (progn - (setq line (buffer-substring (match-beginning 1) (match-end 1))) - (setq file (buffer-substring (match-beginning 2) (match-end 2))) - ))) - (if (and file line) ;Find break point? - (progn - (find-file-other-window (expand-file-name file nil)) - (goto-line (string-to-int line)) ;Jump to the line - (beginning-of-line) - (setq overlay-arrow-string "=>") - (or overlay-arrow-position - (setq overlay-arrow-position (make-marker))) - (set-marker overlay-arrow-position (point) (current-buffer)) - (other-window 1)) ;Return to dbx - ))) - -(defun dbx-stop-at () - "Set break point at current line." - (interactive) - (let ((file-name (file-name-nondirectory buffer-file-name)) - (line (save-restriction - (widen) - (1+ (count-lines 1 (point)))))) - (process-send-string dbx-process - (concat "stop at \"" file-name "\":" line "\n")))) - -(provide 'dbx) - -;;; dbx.el ends here
--- a/lisp/comint/gdb-highlight.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1588 +0,0 @@ -;;; gdb-highlight.el --- make gdb buffers be mouse-sensitive. - -;;; Copyright (C) 1997 Jamie Zawinski <jwz@netscape.com> - -;; Author: Jamie Zawinski <jwz@netscape.com> -;; Created: 16-Apr-1997 -;; Version: 1.2 (17-May-97) -;; Keywords: extensions, c, unix, tools, debugging - -;; 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 synched. - -;;; Commentary: -;; -;; This package makes most objects printed in a *gdb* buffer be -;; mouse-sensitive: as text shows up in the buffer, it is parsed, -;; and objects which are recognized have context-sensitive commands -;; attached to them. Generally, the types that are noticed are: -;; -;; = function and method names; -;; = variable and parameter names; -;; = structure and object slots; -;; = source file names; -;; = type names; -;; = breakpoint numbers; -;; = stack frame numbers. -;; -;; Any time one of those objects is presented in the *gdb* buffer, -;; it will be mousable. Clicking middle mouse button (button2) on -;; it will take some default action -- edit the function, select -;; the stack frame, disable the breakpoint, etc. Clicking the right -;; mouse button (button3) will bring up a menu of commands, including -;; commands specific to the object under the mouse, or other objects -;; on the same line. -;; -;; In addition to these context-sensitive commands are more general -;; gdb commands which were previously inaccessible via the mouse -;; (listing breakpoints, returning values, etc); and the general -;; comint/shell-buffer commands which had been present before. -;; -;; If you notice an object being presented which could (usefully) -;; be made mouse sensitive, but which currently is not, please let -;; me know. - -;;; Installation: -;; -;; To install, add this to your .emacs file: -;; (add-hook 'gdb-mode-hook '(lambda () (require 'gdb-highlight))) - -;;; TODO: -;; -;; = It doesn't really work very well unless you've done `set width 0' -;; in your .gdbinit. It would be nice if this were fixed. -;; (And with `set width 0', `set print pretty on' is the way to go.) -;; -;; = In some contexts, the toggle-breakpoint command doesn't work, -;; because this code doesn't know whether it's enabled. It should -;; remember, or figure it out, or something. -;; -;; = Make it possible to edit the `keep' state of breakpoints. -;; -;; = Is it useful to make addresses clickable? If an address is -;; always acompanied by a variable, then no. -;; -;; = There has got to be a better way to implement `gdb-guess-file-name'. -;; -;; = Make some new toolbar icons and put the most common commands on it. -;; -;; = Maybe make gdb-toolbar-clear work more reliably by consulting a -;; breakpoint-number extent? -;; -;; = I want breakpoint icons in my source files, just like in Energize. -;; -;; = Add a command to quit-and-restart the debugger, with the same -;; breakpoints and program-arguments. (This wouldn't be interesting -;; if gdb didn't leak like a sieve...) -;; -;; = Figure out some way to realize when extents are no longer interesting -;; (stack frames and local variables that are no longer on the stack) -;; and make them no longer be mousable. This is tricky... Nuke them -;; whenever a "run" command is seen? -;; -;; = Make C-x SPC in a source buffer use gdb-menu-command so that it will -;; interrupt-and-continue the debugged program as necessary. -;; -;; = Do stuff for watchpoints (but I never use them, myself.) - -;;; WISHLIST: -;; -;; (extracted from my 13-May-1997 message to comp.emacs and -;; comp.emacs.xemacs, news:33785828.5A524730@netscape.com) -;; -;; 6.1. Make gdbsrc-mode not suck. -;; -;; The idea behind gdbsrc-mode is on the side of the angels: one -;; should be able to focus on the source code and not on the -;; debugger buffer, absolutely. But the implementation is just -;; awful. -;; -;; First and foremost, it should not change "modes" (in the more -;; general sense). Any commands that it defines should be on -;; keys which are exclusively used for that purpose, not keys -;; which are normally self-inserting. I can't be the only person -;; who usually has occasion to actually *edit* the sources which -;; the debugger has chosen to display! Switching into and out of -;; gdbsrc-mode is prohibitive. -;; -;; I want to be looking at my sources at all times, yet I don't -;; want to have to give up my source-editing gestures. I think -;; the right way to accomplish this is to put the gdbsrc commands -;; on the toolbar and on popup menus; or to let the user define -;; their own keys (I could see devoting my kp_enter key to -;; "step", or something common like that.) -;; -;; Also it's extremely frustrating that one can't turn off gdbsrc -;; mode once it has been loaded, without exiting and restarting -;; emacs; that alone means that I'd probably never take the time -;; to learn how to use it, without first having taken the time to -;; repair it... -;; -;; 6.2. Make it easier access to variable values. -;; -;; I want to be able to double-click on a variable name to -;; highlight it, and then drag it to the debugger window to have -;; its value printed. -;; -;; I want gestures that let me write as well as read: for -;; example, to store value A into slot B. -;; -;; 6.3. Make all breakpoints visible. -;; -;; Any time there is a running gdb which has breakpoints, the -;; buffers holding the lines on which those breakpoints are set -;; should have icons in them. These icons should be context- -;; sensitive: I should be able to pop up a menu to enable or -;; disable them, to delete them, to change their commands or -;; conditions. -;; -;; I should also be able to MOVE them. It's annoying when you -;; have a breakpoint with a complex condition or command on it, -;; and then you realize that you really want it to be at a -;; different location. I want to be able to drag-and-drop the -;; icon to its new home. -;; -;; 6.4. Make a debugger status display window. -;; -;; o I want a window off to the side that shows persistent -;; information -- it should have a pane which is a -;; drag-editable, drag-reorderable representation of the -;; elements on gdb's "display" list; they should be displayed -;; here instead of being just dumped in with the rest of the -;; output in the *gdb* buffer. -;; -;; o I want a pane that displays the current call-stack and -;; nothing else. I want a pane that displays the arguments -;; and locals of the currently-selected frame and nothing -;; else. I want these both to update as I move around on the -;; stack. -;; -;; Since the unfortunate reality is that excavating this -;; information from gdb can be slow, it would be a good idea -;; for these panes to have a toggle button on them which meant -;; "stop updating", so that when I want to move fast, I can, -;; but I can easily get the display back when I need it again. -;; -;; The reason for all of this is that I spend entirely too much -;; time scrolling around in the *gdb* buffer; with gdb-highlight, -;; I can just click on a line in the backtrace output to go to -;; that frame, but I find that I spend a lot of time *looking* -;; for that backtrace: since it's mixed in with all the other -;; random output, I waste time looking around for things (and -;; usually just give up and type "bt" again, then thrash around -;; as the buffer scrolls, and I try to find the lower frames that -;; I'm interested in, as they have invariably scrolled off the -;; window already... -;; -;; 6.5. Save and restore breakpoints across emacs/debugger sessions. -;; -;; This would be especially handy given that gdb leaks like a -;; sieve, and with a big program, I only get a few dozen -;; relink-and-rerun attempts before gdb has blown my swap space. -;; -;; 6.6. Keep breakpoints in sync with source lines. -;; -;; When a program is recompiled and then reloaded into gdb, the -;; breakpoints often end up in less-than-useful places. For -;; example, when I edit text which occurs in a file anywhere -;; before a breakpoint, emacs is aware that the line of the bp -;; hasn't changed, but just that it is in a different place -;; relative to the top of the file. Gdb doesn't know this, so -;; your breakpoints end up getting set in the wrong places -;; (usually the maximally inconvenient places, like *after* a -;; loop instead of *inside* it). But emacs knows, so emacs -;; should inform the debugger, and move the breakpoints back to -;; the places they were intended to be. -;; -;; (Possibly the OOBR stuff does some of this, but can't tell, -;; because I've never been able to get it to do anything but beep at -;; me and mumble about environments. I find it pretty funny that the -;; manual keeps explaining to me how intuitive it is, without -;; actually giving me a clue how to launch it...) - - -;;; Code: -;; -;; This code should be considered an example of how over-use of regular -;; expressions leads to code that is an unreadable, unmaintainable mess, -;; and why it's unfortunate that so much of emacs's speed depends on -;; their use, rather than on the use of more traditional parsers. - -(require 'gdb) - -(define-key gdb-mode-map 'button3 'gdb-popup-menu) -(defvar gdb-popup-menu - '("GDB Commands" - ["Up Stack" (gdb-menu-command "up" t) t] - ["Down Stack" (gdb-menu-command "down" t) t] - ["Next Line" (gdb-menu-command "next" t) t] - ["Next Line (Step In)" (gdb-menu-command "step" t) t] - ["Continue" (gdb-menu-command "continue" t) t] - ["Continue Until Return" (gdb-menu-command "finish" t) t] - ("Return..." - ["Return" (gdb-menu-command "return" t) t] - ["Return 0" (gdb-menu-command "return 0" t) t] - ["Return 1" (gdb-menu-command "return 1" t) t] - ["Return -1" (gdb-menu-command "return -1" t) t] - ["Return $" (gdb-menu-command "return $" t) t] - ) - "---" - ["Backtrace" (gdb-menu-command "backtrace" t) t] - ["List Breakpoints" (gdb-menu-command "info breakpoints" t) t] - ["List Local Variables" (gdb-menu-command "info locals" t) t] - ) - "Commands for the popup menu in gdb-mode. -The comint-popup-menu is appended to this, and certain context-sensitive -commands may be prepended to it, depending on the location of the mouse -when the `gdb-popup-menu' command is invoked.") - - -;;; Faces and keymaps used for mousable tokens in the *gdb* buffer. - -(defvar gdb-highlight-face 'gdb-highlight-face) ; the base face -(defvar gdb-breakpoint-number-face 'gdb-breakpoint-number-face) -;(defvar gdb-breakpoint-keep-face 'gdb-breakpoint-keep-face) -(defvar gdb-breakpoint-enabled-face 'gdb-breakpoint-enabled-face) -(defvar gdb-function-name-face 'gdb-function-name-face) -(defvar gdb-function-location-face 'gdb-function-location-face) -(defvar gdb-variable-name-face 'gdb-variable-name-face) -(defvar gdb-type-name-face 'gdb-type-name-face) - -(make-face 'gdb-highlight-face) -(or (face-differs-from-default-p 'gdb-highlight-face) - (make-face-italic 'gdb-highlight-face)) - -(let ((faces '(gdb-breakpoint-number-face - gdb-breakpoint-enabled-face - ;gdb-breakpoint-keep-face - gdb-function-name-face - gdb-function-location-face - gdb-variable-name-face - gdb-type-name-face))) - (while faces - (make-face (car faces)) - (or (face-differs-from-default-p (car faces)) - (if (fboundp 'set-face-parent) - (set-face-parent (car faces) 'gdb-highlight-face) - (copy-face 'gdb-highlight-face (car faces)))) - (setq faces (cdr faces)))) - - -(defvar gdb-token-map ; the base map, inherited by all. - (let ((m (make-sparse-keymap))) - (set-keymap-name m 'gdb-token-map) - (define-key m 'button2 'undefined) - ;;(define-key m 'button3 'gdb-token-popup) - m)) - -(defvar gdb-breakpoint-number-map - (let ((m (make-sparse-keymap))) - (set-keymap-name m 'gdb-breakpoint-number-map) - (set-keymap-parent m gdb-token-map) - ;; not sure if this is the most useful binding... maybe "delete" is better? - (define-key m 'button2 'gdb-mouse-disable-breakpoint) - m)) - -(defvar gdb-info-breakpoint-number-map - (let ((m (make-sparse-keymap))) - (set-keymap-name m 'gdb-breakpoint-number-map) - (set-keymap-parent m gdb-token-map) - ;; not sure if this is the most useful binding... maybe "delete" is better? - (define-key m 'button2 'gdb-mouse-toggle-breakpoint-enabled) - m)) - -;(defvar gdb-breakpoint-keep-map -; (let ((m (make-sparse-keymap))) -; (set-keymap-name m 'gdb-breakpoint-keep-map) -; (set-keymap-parent m gdb-token-map) -; (define-key m 'button2 'gdb-token-mouse-toggle-keep) -; m)) - -(defvar gdb-breakpoint-enabled-map - (let ((m (make-sparse-keymap))) - (set-keymap-name m 'gdb-breakpoint-enabled-map) - (set-keymap-parent m gdb-token-map) - (define-key m 'button2 'gdb-mouse-toggle-breakpoint-enabled) - m)) - -(defvar gdb-function-name-map - (let ((m (make-sparse-keymap))) - (set-keymap-name m 'gdb-function-name-map) - (set-keymap-parent m gdb-token-map) - (define-key m 'button2 'gdb-mouse-edit-function) - m)) - -(defvar gdb-function-location-map - (let ((m (make-sparse-keymap))) - (set-keymap-name m 'gdb-function-location-map) - (set-keymap-parent m gdb-token-map) - (define-key m 'button2 'gdb-mouse-edit-function-location) - m)) - -(defvar gdb-frame-number-map - (let ((m (make-sparse-keymap))) - (set-keymap-name m 'gdb-frame-number-map) - (set-keymap-parent m gdb-token-map) - (define-key m 'button2 'gdb-mouse-goto-frame) - m)) - -(defvar gdb-variable-name-map - (let ((m (make-sparse-keymap))) - (set-keymap-name m 'gdb-variable-name-map) - (set-keymap-parent m gdb-token-map) - (define-key m 'button2 'gdb-mouse-print-variable) - m)) - -(defvar gdb-type-name-map - (let ((m (make-sparse-keymap))) - (set-keymap-name m 'gdb-type-name-map) - (set-keymap-parent m gdb-token-map) - (define-key m 'button2 'gdb-mouse-print-type) - m)) - - -;;; Token definitions. - -;; These properties enumerate the faces and keymaps that will be put over -;; the tokens. - -(put 'gdb-frame-number-token 'gdb-token-face gdb-breakpoint-number-face) -(put 'gdb-frame-number-token 'gdb-token-keymap gdb-frame-number-map) - -;(put 'gdb-breakpoint-keep-token 'gdb-token-face gdb-breakpoint-keep-face) -;(put 'gdb-breakpoint-keep-token 'gdb-token-keymap gdb-breakpoint-keep-map) - -(put 'gdb-enabled-token 'gdb-token-face gdb-breakpoint-enabled-face) -(put 'gdb-enabled-token 'gdb-token-keymap gdb-breakpoint-enabled-map) - -(put 'gdb-function-name-token 'gdb-token-face gdb-function-name-face) -(put 'gdb-function-name-token 'gdb-token-keymap gdb-function-name-map) - -(put 'gdb-function-location-token 'gdb-token-face gdb-function-location-face) -(put 'gdb-function-location-token 'gdb-token-keymap gdb-function-location-map) - -(put 'gdb-breakpoint-number-token 'gdb-token-face gdb-breakpoint-number-face) -(put 'gdb-breakpoint-number-token 'gdb-token-keymap gdb-breakpoint-number-map) -(put 'gdb-info-breakpoint-number-token 'gdb-token-face - gdb-breakpoint-number-face) -(put 'gdb-info-breakpoint-number-token 'gdb-token-keymap - gdb-info-breakpoint-number-map) - -(put 'gdb-frame-number-token 'gdb-token-face gdb-breakpoint-number-face) -(put 'gdb-frame-number-token 'gdb-token-keymap gdb-frame-number-map) - -(put 'gdb-variable-name-token 'gdb-token-face gdb-variable-name-face) -(put 'gdb-variable-name-token 'gdb-token-keymap gdb-variable-name-map) - -(put 'gdb-type-name-token 'gdb-token-face gdb-type-name-face) -(put 'gdb-type-name-token 'gdb-token-keymap gdb-type-name-map) - - -;;; These regular expressions control what text corresponds to which tokens. - -(defconst gdb-highlight-token-patterns - ;; "May god forgive me for what I have unleashed." -- Evil Dead II. - (purecopy - (list - ;; Breakpoints output: - ;; - ;; Breakpoint 5, XCreateWindow () at Window.c:136 - ;; Breakpoint 6, foobar (x=0x7fff3000 "baz") at blorp.c:5382 - ;; - (list (concat "\\(Breakpoint " ; 1 - "\\([0-9]+\\)" ; .2 - "\\), " ; 1 - "\\(0x[0-9a-fA-F]+ in \\)?" ; 3 - "\\(" ; 4 - "\\([a-zA-Z0-9_]+\\):[a-zA-Z0-9_:~]+" ; .5 - "\\|" ; . - "[a-zA-Z0-9_]+" ; . - "\\)" ; 4 - "\\(" ; 6 - " *\\((.*)\\)" ; .7 - " at \\(" ; .8 - "\\([^ \t\n:]+\\):" ; ..9 - "\\([0-9]+\\)" ; ..10 - "\\)" ; .8 - "\\)?" ; 6 - ) - '(gdb-breakpoint-number-token ; 1 - nil ; 2 - nil ; 3 - gdb-function-name-token ; 4 (+5) - gdb-type-name-token ; 5 - nil ; 6 - gdb-arglist-token ; 7 - gdb-function-location-token ; 8 (9+10) - )) - - ;; Output of the "Break" command: - ;; - ;; Breakpoint 1 at 0x4881d4 - ;; Breakpoint 6 at 0xfa50f68: file cuexit.c, line 58. - ;; - (list (concat "\\(Breakpoint " ; 1 - "\\([0-9]+\\)" ; .2 - "\\) at " ; 1 - "\\(0x[0-9A-Fa-f]+\\)" ; 3 - "\\(: file " ; 4 - "\\(" ; .5 - "\\([^ \t\n:]+\\)" ; ..6 - ", line \\([0-9]+\\)" ; ..7 - "\\)" ; .5 - "\\)?" ; 4 - ) - '(gdb-breakpoint-number-token ; 1 - nil ; 2 - nil ;gdb-address-token ; 3 - nil ; 4 - gdb-function-location-token ; 5 (6+7) - )) - - ;; Note: breakpoint 5 (disabled) also set at pc 0x40b420. - ;; Note: breakpoint 5 also set at pc 0x40b420. - ;; - (list (concat "Note: " ; - "\\(breakpoint " ; 1 - "\\([0-9]+\\)" ; .2 - "\\)" ; 1 - ) - '(gdb-breakpoint-number-token ; 1 - nil ; 2 - )) - - ;; Stack Frames: - ;; - ;; 0xe1b8e0 in _OS_SELECT () at os_IRIX.s:50 - ;; XCreateWindow () at Window.c:136 - ;; #0 0x8e0db0 in _OS_SELECT () at os_IRIX.s:50 - ;; #0 XCreateWindow () at Window.c:136 - ;; Run till exit from #0 __ll_mul () at llmul.s:51 - ;; - (list (concat "\\(Run till exit from \\)?" ; 1 - "\\(" ; 2 - "#\\([0-9]+ *\\)" ; .3 - "\\)?" ; 2 - "\\(" ; 4 - "\\(0x[0-9A-Fa-f]+\\)" ; .5 - " in +\\)?" ; 4 - "\\(" ; 6 - "\\([a-zA-Z0-9_]+\\):[a-zA-Z0-9_:~]+" ; .7 - "\\|" ; 6 - "[a-zA-Z0-9_]+" ; - "\\) (" ; 6 - "\\(" ; 8 - "\\(.*\\)" ; .9 - "\\bat \\(" ; .10 - "\\([^ \t\n:]+\\):" ; ..11 - "\\([0-9]+\\)" ; ..12 - "\\)" ; .10 - "\\)?" ; 8 - ) - '(nil ; 1 - gdb-frame-number-token ; 2 - nil ; 3 - nil ; 4 - nil ;gdb-address-token ; 5 - gdb-function-name-token ; 6 (+7) - gdb-type-name-token ; 7 - nil ; 8 - gdb-arglist-token ; 9 - gdb-function-location-token ; 10 (11+12) - )) - - ;; Info Breakpoints output: - ;; - ;; 1 breakpoint keep y 0x0fa50f68 in exit at exit.c:58 - ;; 1 breakpoint keep y 0x000a1b00 <exit+4> - ;; 1 breakpoint keep y 0x0fa429ac <_write> - ;; 6 breakpoint keep y 0x00789490 in foo::bar(bad *) at x.cpp:99 - ;; 7 breakpoint keep y 0x00789490 <foo::bar(bad *)+128> - ;; - (list (concat "\\([0-9]+ *\\) " ; 1 - "\\(breakpoint *\\|watchpoint *\\) " ; 2 - "\\(keep *\\|del *\\|dis *\\) " ; 3 - "\\([yn] *\\) " ; 4 - "\\(0x[0-9A-Fa-f]+\\) *" ; 5 - "\\(in " ; 6 - "\\(" ; .7 - "[a-zA-Z0-9_]+" ; .. - "\\|" ; .7 - "\\([a-zA-Z0-9_]+\\):[a-zA-Z0-9_:~]+" ; ..8 - "\\)" ; .7 - "\\((.*)\\)?" ; 9 - " at " ; . - "\\(" ; .10 - "\\([^ \t\n:]+\\):" ; ..11 - "\\([0-9]+\\)" ; ..12 - "\\)" ; .10 - "\\|" ; 6 - "<" ; . - "\\(" ; .13 - "\\([a-zA-Z0-9_]+\\):[a-zA-Z0-9_:~]+" ; ..14 - "\\|" ; .13 - "[a-zA-Z0-9_]+" ; .. - "\\)" ; .13 - "\\((.*)\\)?" ; .15 - "[^>\n]*>" ; . - "\\)?" ; 6 - ) - '(gdb-info-breakpoint-number-token ; 1 - nil ; 2 - nil ;gdb-breakpoint-keep-token ; 3 - gdb-enabled-token ; 4 - nil ;gdb-address-token ; 5 - nil ; 6 - gdb-function-name-token ; 7 (+8) - gdb-type-name-token ; 8 - gdb-arglist-types-token ; 9 - gdb-function-location-token ; 10 (11+12) - nil ; 11 - nil ; 12 - gdb-function-name-token ; 13 - gdb-type-name-token ; 14 - gdb-arglist-types-token ; 15 - )) - - ;; Whatis and Ptype output: - ;; type = struct _WidgetRec * - ;; type = struct _WidgetRec { - ;; type = int () - ;; type = struct <undefined> *(struct <undefined> *, void *, void (*)()) - ;; type = struct foo *(struct foo *, unsigned char, int) - ;; type = unsigned int [4] - ;; - (list (concat "type = " - "\\(" ; 1 - "\\(signed \\|unsigned \\)?" ; .2 - "\\(struct \\|class \\|union \\|enum \\)?" ; .3 - "\\(<?[a-zA-Z_][a-zA-Z0-9_:]*>?\\)" ; .4 - "\\)" ; 1 - "[ *]*" ; - "\\(" ; 5 - "{?$\\|" ; . - "\\[[0-9]*\\]$\\|" ; . - "\\((.*)\\)" ; .6 - "\\)" ; 5 - ) - '(gdb-type-name-token ; 1 (2+3+4) - nil ; 2 - nil ; 3 - nil ; 4 - nil ; 5 - gdb-arglist-types-token ; 6 - )) - - ;; Ptype output: - ;; CorePart core; - ;; void *constraints; - ;; short x; - ;; unsigned short width; - ;; struct <undefined> *event_table; - ;; XtTMRec tm; - ;; void (*class_initialize)(); - ;; unsigned char (*set_values)(); - ;; unsigned char st_fstype[16]; - ;; type = enum {XtGeometryYes, XtGeometryNo, XtGeometryAlmost} - ;; - (list (concat " *" - "\\(" ; 1 - "\\(signed \\|unsigned \\)?" ; .2 - "\\(struct \\|class \\|union \\|enum \\)?" ; .3 - "\\([a-zA-Z_][a-zA-Z0-9_:]*\\)" ; .4 - "\\)" ; 1 - "[ *]*" - "\\((\\**\\)?" ; 5 - "\\([a-zA-Z_][a-zA-Z0-9_:]*\\)" ; 6 - "\\()()\\)?" ; 7 - "\\( *\\[[0-9]*\\]\\)?" ; 8 - "; *$" - ) - '(gdb-type-name-token ; 1 (2+3+4) - )) - - ;; Ptype output on C++ classes: - ;; - ;; virtual foo (int); - ;; unsigned int foo(void); - ;; static long unsigned int * foo(bar *, baz *, unsigned int); - ;; - ;; not handled: - ;; foo(bar *, _WidgetRec *, char const *, int); - ;; foo (foo &); - ;; foo & operator=(foo const &); - ;; - (list (concat " *" - "\\(static \\)?" ; 1 - "\\(" ; 2 - "\\(signed \\|unsigned " ; .3 - ;; #### not so sure about this: - "\\|long unsigned \\|short unsigned " ; .3 - "\\)?" ; .3 - "\\(struct \\|class \\|union \\|enum \\)?" ; .4 - "\\([a-zA-Z_][a-zA-Z0-9_:]*\\)" ; .5 - "\\)" ; 1 - "[ *&]+" ; - " *\\([a-zA-Z_][a-zA-Z0-9_:]*\\)" ; 6 - " *\\((.*)\\)" ; 7 - "; *$" ; - ) - '(nil ; 1 - gdb-type-name-token ; 2 (3+4+5) - nil ; 3 - nil ; 4 - nil ; 5 - gdb-function-name-token ; 6 - gdb-arglist-types-token ; 7 - )) - - ;; Pointers to functions: - ;; - ;; $1 = {void ()} 0x4a1334 <fe_pulldown_cb> - ;; $2 = (void (*)()) 0x4a1334 <fe_pulldown_cb> - ;; - (list (concat ".* = " - "[({]" - "\\(" ; 1 - "\\(signed \\|unsigned \\)?" ; .2 - "\\(struct \\|class \\|union \\|enum \\)?" ; .3 - "\\([a-zA-Z_][a-zA-Z0-9_:]*\\)" ; .4 - "\\)" ; 1 - " \\((\\*) ?\\)?" ; 5 - "\\((.*)\\)" ; 6 - "[)}] +" ; - "\\(0x[0-9A-Fa-f]+\\) +" ; 7 - "<\\([a-zA-Z_~][a-zA-Z0-9_:]*\\)" ; 8 - "\\+?[0-9]+?>" ; - ) - '(gdb-type-name-token ; 1 (2+3+4) - nil ; 2 - nil ; 3 - nil ; 4 - nil ; 5 - gdb-arglist-types-token ; 6 - nil ;gdb-address-token ; 7 - gdb-function-name-token ; 8 - )) - - ;; Local variables and structures: - ;; - ;; shell = (struct _WidgetRec *) 0x10267350 - ;; delete_response = 270955344 - ;; allow_resize = 200 'È' - ;; is_modal = 47 '/' - ;; class_name = 0xf661d40 "TopLevelShell", - ;; static foo = 0x10791ec0, - ;; initialize = 0xf684770 <TopLevelInitialize>, - ;; av = {{ - ;; name = "foo", - ;; value = 270349836 - ;; }, { - ;; name = 0x12 <Address 0x12 out of bounds>, - ;; value = 0 - ;; }, { - ;; name = 0x0, - ;; value = 0 - ;; }} - ;; - (list (concat " *" - "\\(static \\)?" ; 1 - "\\([$a-zA-Z_][a-zA-Z0-9_:]*\\) = " ; 2 - "\\((" ; 3 - "\\(" ; .4 - "\\(signed \\|unsigned \\)?" ; ..5 - "\\(struct \\|class \\|union \\|enum \\)?"; ..6 - "\\([a-zA-Z_][a-zA-Z0-9_:]*\\)" ; ..7 - "\\)" ; .4 - "[ *]*)" ; - "\\)?" ; 3 - "\\(" ; 8 - ".*" - " <\\([a-zA-Z_~][a-zA-Z0-9_:]*\\)" ; .9 - "\\+?[0-9]+?>" ; . - "\\)?" ; 8 - ) - '(nil ; 1 - gdb-variable-name-token ; 2 - nil ; 3 - gdb-type-name-token ; 4 - nil ; 5 - nil ; 6 - nil ; 7 - nil ; 8 - gdb-function-name-token ; 9 - )) - - ;; Purify output: - ;; UMR: Uninitialized memory read: - ;; * This is occurring while in: - ;; SHA1_Update [algsha.c:137] - ;; * Reading 1 byte from 0xefffdb34 on the stack. - (list (concat "[ \t]+" - "\\([a-zA-Z_~][a-zA-Z0-9_:]*\\)[ \t]*" ; 1 - "\\[\\(" ; 2 - "\\([^ \t\n:]+\\):" ; .3 - "\\([0-9]+\\)" ; .4 - "\\)\\]" ; 2 - ) - '(gdb-function-name-token ; 1 - gdb-function-location-token ; 2 (3+4) - )) - - ;; Purify output: - ;; * Address 0xefffdb34 is 36 bytes past start of local variable \ - ;; "data" in function fe_EventForRNG. - (list (concat ".*\\bAddress " - "\\(0x[0-9A-Fa-f]+\\) +" ; 1 - ".*\\bvariable \"" ; - "\\([a-zA-Z_][a-zA-Z0-9_:]*\\)\"" ; 2 - "\\(" ; 3 - ".*\\bfunction " ; . - "\\([a-zA-Z_~][a-zA-Z0-9_:]*\\)" ; .4 - "\\)?" ; 3 - ) - '(nil ;gdb-address-token ; 1 - gdb-variable-name-token ; 2 - nil ; 3 - gdb-function-name-token ; 4 - )) - )) - "Patterns to highlight in gdb buffers. -Each element of this list takes the form - ( \"regexp\" ( token-1 token-2 ... )) -where token-N is the token to place on the text matched - by sub-pattern N in the match data. - -The patterns should not begin with \"^\".") - - -(defun gdb-highlight-line () - "Highlight any tokens on the line which match gdb-highlight-token-patterns." - (map-extents #'(lambda (e ignore) (delete-extent e)) - nil - (point) (save-excursion (forward-line 1) (point)) - nil nil 'gdb-token) - (while (looking-at comint-prompt-regexp) - (goto-char (match-end 0))) - (if (eobp) - nil - (let ((tokens gdb-highlight-token-patterns) - (do-magic-variable-hack nil)) - (while tokens - (if (not (looking-at (car (car tokens)))) - (setq tokens (cdr tokens)) - (let ((i 1) - (types (nth 1 (car tokens)))) - (if (eq (car types) 'gdb-variable-name-token) - (setq do-magic-variable-hack t)) - (while types - (cond ((not (and (car types) - (match-beginning i))) - nil) - ((memq (car types) '(gdb-arglist-token - gdb-arglist-types-token)) - (gdb-highlight-arglist (car types) - (match-beginning i) - (match-end i))) - ((/= ?$ (char-after (match-beginning i))) - (gdb-highlight-token (car types) - (match-beginning i) - (match-end i)))) - (setq i (1+ i) - types (cdr types))) - - (if (not do-magic-variable-hack) - ;; we're done. - (setq tokens nil) - ;; else, do a grody hack to cope with multiple variables - ;; on the same line. - (save-restriction - (let ((p (point)) - (ok nil)) - (end-of-line) - (narrow-to-region p (point)) - (goto-char (match-end 0)) - (if (= (following-char) ?\{) - (progn - (forward-char 1) - (setq ok t)) - (setq p (scan-sexps (point) 1 nil t)) - (setq ok (if (null p) - nil - (goto-char p) - (if (or (= (following-char) ?\,) - (= (following-char) ?\})) - t - (setq p (scan-sexps (point) 1 nil t)) - (if (null p) - nil - (goto-char p) - t))))) - (if ok - ;; skip over the comma and go around again. - (and (looking-at "}?[ \t]*,[ \t]*") - (goto-char (match-end 0))) - ;; saw something unexpected; give up on this line. - (setq tokens nil))))) - ))))) - nil) - -(defun gdb-highlight-token (type start end) - "Helper for gdb-highlight-line -- makes an extent for one matched token." - (let ((e (make-extent start end))) - (set-extent-property e 'gdb-token type) - (set-extent-property e 'highlight 't) - (set-extent-property e 'help-echo 'gdb-token-help-echo) - (set-extent-property e 'face (get type 'gdb-token-face)) - (set-extent-property e 'keymap (get type 'gdb-token-keymap)) - e)) - -(defun gdb-highlight-arglist (type start end) - "Helper for gdb-highlight-line. -Makes extents for variables or types in an arglist." - (save-match-data - (save-excursion - (goto-char end) - (if (eq (preceding-char) ?\)) - (setq end (1- end))) - (goto-char start) - (if (eq (following-char) ?\() - (forward-char 1)) - (set-extent-property (make-extent start end) 'gdb-token type) - - (cond - ((eq type 'gdb-arglist-token) - (let* ((pat1 "\\([a-zA-Z_][a-zA-Z0-9_:]*\\)=") - (pat2 ", \\([a-zA-Z_][a-zA-Z0-9_:]*\\)=") - (pat pat1)) - (while(re-search-forward pat end t) - (gdb-highlight-token 'gdb-variable-name-token - (match-beginning 1) (match-end 1)) - (cond ((looking-at - "0?x?[0-9A-Fa-f]+ <\\([a-zA-Z_~][a-zA-Z0-9_:]*\\)>") - (goto-char (match-end 0)) - (gdb-highlight-token 'gdb-function-name-token - (match-beginning 1) (match-end 1)))) - (setq pat pat2)))) - - ((eq type 'gdb-arglist-types-token) - (let ((pat (eval-when-compile - (concat - "\\(" ; 1 - "\\(signed \\|unsigned \\)?" ; .2 - "\\(struct \\|class \\|union \\|enum \\)?" ; .3 - "\\(<?[a-zA-Z_~][a-zA-Z0-9_:]*>?\\)" ; .4 - "\\)" ; 1 - "[ *]*" - "\\((\\*) *(.*)\\)?" ; 5 - )))) - (while (< (point) end) - (cond ((looking-at pat) - (goto-char (match-end 0)) - (gdb-highlight-token 'gdb-type-name-token - (match-beginning 1) (match-end 1)) - (if (looking-at " *, *") - (goto-char (match-end 0)))) - (t - ;; error -- try to cope... - (search-forward "," (1+ end) t)))))) - (t - (error "unknown arglist type %s" type))))) - nil) - -(defun gdb-token-help-echo (extent) - "Used as the 'mouse-help property of gdb-token extents, -to describe the binding on button2." - (let* ((map (extent-property extent 'keymap)) - (key 'button2) - (fn (and map (lookup-key map key))) - (doc (and fn (symbolp fn) - (if (fboundp fn) - (format "%s: %s" key (documentation fn)) - (format "Error: %s is undefined" fn))))) - (if doc - (save-match-data - (if (string-match "\n" doc) - (setq doc (substring doc 0 (match-beginning 0)))))) - (or doc - (concat "Error: no doc for " - (symbol-name (extent-property extent 'gdb-token)))))) - -(defun gdb-get-line-token-extents (tokens) - "Given a list of gdb-tokens, returns this line's extents of those types. -The returned value is a list of the same length as the `tokens' list, with -the corresponding extents in the corresponding positions. If an extent -isn't found, nil is placed in the result-list instead." - (setq tokens (append tokens nil)) - (let* ((result (make-list (length tokens) nil))) - (save-excursion - (beginning-of-line) - (map-extents #'(lambda (e ignore) - (let ((type (extent-property e 'gdb-token)) - (r1 tokens) - (r2 result)) - (while r1 - (cond ((and (car r1) (eq type (car r1))) - (setcar r1 nil) - (setcar r2 e) - (setq r1 nil))) - (setq r1 (cdr r1) - r2 (cdr r2)))) - nil) - nil - (point) - (progn (forward-line 1) (point)) - nil nil - 'gdb-token) - result))) - - -;;; Remembering directory names. -;;; gdb and gdb-mode conspire to hide from us the full file names of things -;;; that are presented into the buffer; this is an attempt to circumvent that. - -(defvar gdb-highlight-last-directory nil) -(defvar gdb-highlight-last-directory-table nil) - -(defun gdb-highlight-remember-directory () - ;; When gdb deigns to give us a full pathname, and it's in a different - ;; directory than last time, cache it away on one of the nearby gdb-token - ;; extents. (We intern it to avoid hanging on to a lot of strings.) - (cond ((and (boundp 'gdb-last-frame) - (car gdb-last-frame)) - (cond ((not gdb-highlight-last-directory-table) - (set (make-local-variable 'gdb-highlight-last-directory) nil) - (set (make-local-variable 'gdb-highlight-last-directory-table) - (make-vector 211 0)))) - (let ((dir (file-name-directory (car gdb-last-frame)))) - (setq dir (intern dir gdb-highlight-last-directory-table)) - (cond ((not (eq dir gdb-highlight-last-directory)) - (let ((extent (previous-extent (current-buffer)))) - (setq gdb-highlight-last-directory dir) - (while extent - (cond ((extent-property extent 'gdb-token) - (set-extent-property extent 'gdb-directory dir) - (setq extent nil)) - (t - (setq extent (previous-extent extent)))))))))))) - -(defun gdb-guess-directory () - "Guess what directory gdb was talking about when it wrote the current line." - (let ((extent (or (map-extents #'(lambda (e ignore) e) - (current-buffer) (point) (point-max)) - (previous-extent (current-buffer)) - (error "no extents"))) - (dir nil)) - (while extent - (setq dir (extent-property extent 'gdb-directory)) - (if dir - (setq extent nil) - (setq extent (previous-extent extent)))) - (if dir - (symbol-name dir) - default-directory))) - -(defun gdb-guess-file-name (file) - "Given a directoryless file name printed by gdb, find the file. -First it tries to expand the file relative to `gdb-guess-directory', -and if the resultant file doesn't exist, it tries every other directory -gdb has ever told us about, in no particular order." - (abbreviate-file-name - (if (file-name-absolute-p file) - file - (let ((file2 (expand-file-name file (gdb-guess-directory)))) - (if (file-exists-p file2) - file2 - ;; Oh boy, gdb didn't tell us what directory it's in. - ;; A-hunting we will go. - (if (catch 'done - (mapatoms #'(lambda (dir) - (setq file2 (expand-file-name file - (symbol-name dir))) - (if (file-exists-p file2) - (throw 'done t))) - gdb-highlight-last-directory-table) - nil) - file2 - (expand-file-name file))))))) - - -;;; Commands which are invoked from bindings in the keymaps of the tokens. - -(defun gdb-mouse-toggle-breakpoint-enabled (event &optional what) - "Toggle whether the breakpoint is enabled. -Looks for a gdb-breakpoint extent on the line under the mouse, -and executes an `enable' or `disable' command as appropriate. -Optional arg `what' may be 'enable, 'disable, or 'toggle (default.)" - (interactive "@*e") - (let (number target enabled-p) - (save-excursion - (mouse-set-point event) - (let* ((extents (gdb-get-line-token-extents - '(gdb-breakpoint-number-token - gdb-info-breakpoint-number-token - gdb-enabled-token))) - (be (or (nth 0 extents) (nth 1 extents))) - (ee (nth 2 extents))) - - (or be - (error "no breakpoint-number extent on this line")) - (setq number - (buffer-substring (extent-start-position be) - (extent-end-position be))) - (if (string-match " [0-9]+\\'" number) - (setq number (substring number (1+ (match-beginning 0))))) - (setq number (string-to-int number)) - (or (> number 0) - (error "couldn't find breakpoint number")) - (if (null ee) - (setq enabled-p 'unknown) - (setq target (extent-start-position ee)) - (goto-char target) - (setq enabled-p - (cond ((looking-at "[yY]\\b") t) - ((looking-at "[nN]\\b") nil) - (t (error "enabled is not y or n?"))))) - - (cond ((eq what 'enable) - (setq enabled-p nil)) - ((eq what 'disable) - (setq enabled-p t)) - ((or (eq what 'toggle) (null what)) - (if (eq enabled-p 'unknown) - (error - "can't toggle breakpoint: don't know current state"))) - (t - (error "what must be enable, disable, toggle, or nil."))) - )) - - (gdb-menu-command (format "%s %d" - (if enabled-p "disable" "enable") - number) - nil) - (message "%s breakpoint %d." - (if enabled-p "Disabled" "Enabled") - number) - (cond (target - (save-excursion - (goto-char target) - (insert (if enabled-p "n" "y")) - (delete-char 1) - ;; don't let shell-fonts or font-lock second-guess us. - (remove-text-properties (1- (point)) (point) '(face)))))) - nil) - -(defun gdb-mouse-enable-breakpoint (event) - "Enable the breakpoint. -Looks for a gdb-breakpoint extent on the line under the mouse, -and executes an `enable' command" - (interactive "@*e") - (gdb-mouse-toggle-breakpoint-enabled event 'enable)) - -(defun gdb-mouse-disable-breakpoint (event) - "Disable the breakpoint. -Looks for a gdb-breakpoint extent on the line under the mouse, -and executes a `disable' command" - (interactive "@*e") - (gdb-mouse-toggle-breakpoint-enabled event 'disable)) - - -;; compatibility hack... -(or (fboundp 'extent-object) (fset 'extent-object 'extent-buffer)) - -(defun gdb-mouse-edit-function (event) - "Edit the definition of this function (as with \\[find-tag]) -Looks for a gdb-function-name extent on the line under the mouse, -and runs find-tag on the text under that extent." - (interactive "@*e") - (let (extent) - (save-excursion - (mouse-set-point event) - (setq extent (or (car (gdb-get-line-token-extents - '(gdb-function-name-token))) - (error "no function-name extent on this line")))) - (find-tag - (buffer-substring (extent-start-position extent) - (extent-end-position extent) - (extent-object extent))))) - - -(defun gdb-mouse-edit-function-location (event) - "Edit the source file of this function. -Looks for a gdb-function-location extent on line of the mouse, -and parses the text under it." - (interactive "@*e") - (let (file line) - (save-excursion - (mouse-set-point event) - (let ((extent (or (car (gdb-get-line-token-extents - '(gdb-function-location-token))) - (error "no function-location extent on this line")))) - (goto-char (extent-start-position extent)) - (or (looking-at "\\([^ \t\n:,]+\\):\\([0-9]+\\)") - (looking-at "\\([^ \t\n:,]+\\),? line \\([0-9]+\\)") - (error "no file position on this line")) - (setq file (buffer-substring (match-beginning 1) (match-end 1)) - line (buffer-substring (match-beginning 2) (match-end 2))) - (setq file (gdb-guess-file-name file) - line (string-to-int line)) - )) - (if (file-exists-p file) - (find-file-other-window file) - (signal 'file-error (list "File not found" file))) - (goto-line line))) - - -(defun gdb-mouse-goto-frame (event) - "Select this stack frame. -Looks for a gdb-frame-number extent on the line of the mouse, -and executes a `frame' command to select that frame." - (interactive "@*e") - (let (number) - (save-excursion - (mouse-set-point event) - (let ((extent (or (car (gdb-get-line-token-extents - '(gdb-frame-number-token))) - (error "no frame-number extent on this line")))) - (goto-char (extent-start-position extent)) - (if (eq (following-char) ?#) - (forward-char 1)) - (setq number (string-to-int - (buffer-substring (point) - (extent-end-position extent)))))) - (gdb-menu-command (format "frame %d" number) t)) - nil) - - -(defun gdb-mouse-get-variable-reference (event) - "Returns a string which references the variable under the mouse. -This works even if the variable is deep inside nested arrays or structures. -If the variable seems to hold a pointer, then a \"*\" will be prepended." - (save-excursion - (let* ((extent (if (extentp event) - event - (progn - (mouse-set-point event) - (extent-at (point) nil 'gdb-token)))) - dereference-p - name) - (or (and extent - (eq (extent-property extent 'gdb-token) - 'gdb-variable-name-token)) - (error "not over a variable name")) - (setq name (buffer-substring (extent-start-position extent) - (extent-end-position extent))) - (save-excursion - (goto-char (extent-end-position extent)) - (if (and (looking-at " *= *\\(([^)]+)\\)? *0x[0-9a-fA-F]+") ; pointer - (progn - (goto-char (match-end 0)) - (not (looking-at " +\"")))) ; but not string - (setq dereference-p t)) - - ;; Now, if this variable is buried in a structure, compose a complete - ;; reference-chain to it. - (goto-char (extent-start-position extent)) - - (let ((done nil)) - (while (not done) - (skip-chars-backward " \t") - (if (or (and (/= (preceding-char) ?\n) - (/= (preceding-char) ?\,) - (/= (preceding-char) ?\{)) - (<= (buffer-syntactic-context-depth) 0)) - (setq done t) - (let ((p (scan-lists (point) -1 1))) - (if (null p) - (setq done t) - (goto-char (setq p (- p 3))) - (cond - ((looking-at " = {") - (skip-chars-backward "a-zA-Z0-9_") - (if (= (preceding-char) ?\$) - (forward-char -1)) - (setq name (concat (buffer-substring (point) p) "." name))) - - ((looking-at "}, +{") - (forward-char 1) - (let ((parse-sexp-ignore-comments nil) - (count 0)) - (while (setq p (scan-sexps (point) -1 nil t)) - (goto-char p) - (setq count (1+ count))) - - (setq name (format "[%d].%s" count name)) - - ;; up out of the list - (skip-chars-backward " \t\n") - (if (= (preceding-char) ?\{) - (forward-char -1)) - - ;; we might be tightly nested in slot 0... - (while (= (preceding-char) ?\{) - (forward-char -1) - (setq name (concat "[0]" name))) - - (skip-chars-backward " \t") - (if (= (preceding-char) ?=) (forward-char -1)) - (skip-chars-backward " \t") - (setq p (point)) - (skip-chars-backward "a-zA-Z0-9_") - (if (= (preceding-char) ?\$) - (forward-char -1)) - - (setq name (concat (buffer-substring (point) p) name)) - )) - (t - (setq done t))))))))) - - (if dereference-p - (setq name (concat "*" name))) - name))) - -(defun gdb-mouse-print-variable (event) - "Print the value of this variable. -Finds a variable under the mouse, and figures out whether it is inside of -a structure, and composes and executes a `print' command. If the variable -seems to hold a pointer, prints the object pointed to." - (interactive "@*e") - (gdb-menu-command (concat "print " - (gdb-mouse-get-variable-reference event)) - t)) - -(defun gdb-mouse-print-variable-type (event) - "Describe the type of this variable. -Finds a variable under the mouse, and figures out whether it is inside of -a structure, and composes and executes a `whatis' command. If the variable -seems to hold a pointer, describes the type of the object pointed to." - (interactive "@*e") - (gdb-menu-command (concat "whatis " - (gdb-mouse-get-variable-reference event)) - t)) - -(defun gdb-mouse-print-type (event) - "Describe this type. -Finds a type description under the mouse, and executes a `ptype' command." - (interactive "@*e") - (let* ((extent (save-excursion - (mouse-set-point event) - (extent-at (point) nil 'gdb-token))) - name) - (or (and extent - (eq (extent-property extent 'gdb-token) 'gdb-type-name-token)) - (error "not over a type name")) - (setq name (buffer-substring (extent-start-position extent) - (extent-end-position extent))) - (gdb-menu-command (format "ptype %s" name) - t)) - nil) - - -;;; Popup menus - -(defun gdb-menu-command (command &optional scroll-to-bottom) - "Sends the command to gdb. -If gdb is not sitting at a prompt, interrupts it first -\(as if with \\[gdb-control-c-subjob]), executes the command, and then lets -the debugged program continue. - -If scroll-to-bottom is true, then point will be moved to after the new -output. Otherwise, an effort is made to avoid scrolling the window and -to keep point where it was." - - ;; this is kinda like gdb-call except for the interrupt-first behavior, - ;; but also it leaves the commands in the buffer instead of trying to - ;; hide them. - - (let* ((proc (or (get-buffer-process (current-buffer)) - (error "no process in %s" (buffer-name (current-buffer))))) - (window (selected-window)) - wstart - (opoint (point)) - was-at-bottom - running-p) - - (if (not (eq (current-buffer) (window-buffer window))) - (setq window (get-buffer-window (current-buffer)))) - (setq wstart (window-start window)) - - (let ((pmark (process-mark proc))) - (setq was-at-bottom (>= (point) pmark)) - (goto-char pmark) - (delete-region (point) (point-max))) - - (setq running-p (bolp)) ; maybe not the best way to tell... - - (cond (running-p - (message "Program is running -- interrupting first...") - (gdb-control-c-subjob) - (while (accept-process-output proc 1) - ;; continue accepting output as long as it's arriving - ))) - - (message "%s" command) - (goto-char (process-mark proc)) - (insert command) - (comint-send-input) - - ;; wait for the command to be accepted - (accept-process-output proc) - (goto-char (process-mark proc)) - - ;; continue, if we had interrupted - (cond (running-p - (insert "continue") - (comint-send-input))) - - (if scroll-to-bottom - (goto-char (process-mark proc)) - - (set-window-start window wstart) - (goto-char opoint) - (if was-at-bottom - (if (pos-visible-in-window-p (process-mark proc) window) - (goto-char (process-mark proc)) - (goto-char (window-end window)) - (forward-line -2)))) - ) - nil) - - -(defun gdb-make-context-menu (event) - "Returns a menu-desc corresponding to the stack-frame line under the mouse. -Returns nil if not over a stack-frame." - (save-excursion - (mouse-set-point event) - (let* ((extents (gdb-get-line-token-extents - '(gdb-breakpoint-number-token - gdb-info-breakpoint-number-token - gdb-enabled-token - gdb-frame-number-token - gdb-function-name-token - gdb-function-location-token - gdb-arglist-token - gdb-arglist-types-token - gdb-variable-name-token - gdb-type-name-token - ))) - (bnumber (or (nth 0 extents) - (nth 1 extents))) - (enabled-p (nth 2 extents)) - (fnumber (nth 3 extents)) - (name (nth 4 extents)) - (loc (nth 5 extents)) - (al (nth 6 extents)) - (alt (nth 7 extents)) - (var (nth 8 extents)) - (type (nth 9 extents)) - (var-e var)) - - ;; If this line has an arglist, only document variables and types - ;; if the mouse is directly over them. - (if (or al alt) - (setq var nil - type nil)) - - ;; Always prefer the object under the mouse to one elsewhere on the line. - (let* ((e (extent-at (point) nil 'gdb-token)) - (p (and e (extent-property e 'gdb-token)))) - (cond ((eq p 'gdb-function-name-token) (setq name e)) - ((eq p 'gdb-variable-name-token) (setq var e var-e e)) - ((eq p 'gdb-type-name-token) (setq type e)) - )) - - ;; Extract the frame number (it may begin with "#".) - (cond (fnumber - (goto-char (extent-start-position fnumber)) - (if (eq (following-char) ?#) - (forward-char 1)) - (setq fnumber - (string-to-int - (buffer-substring (point) - (extent-end-position fnumber)))))) - - ;; Extract the breakpoint number (it may begin with "Breakpoint ".) - (cond (bnumber - (setq bnumber - (buffer-substring (extent-start-position bnumber) - (extent-end-position bnumber))) - (if (string-match " [0-9]+\\'" bnumber) - (setq bnumber (substring bnumber (1+ (match-beginning 0))))) - (setq bnumber (string-to-int bnumber)) - (or (> bnumber 0) - (error "couldn't parse breakpoint number")))) - - (cond ((null enabled-p) - (setq enabled-p 'unknown)) - ((memq (char-after (extent-start-position enabled-p)) '(?y ?Y)) - (setq enabled-p 't)) - ((memq (char-after (extent-start-position enabled-p)) '(?n ?N)) - (setq enabled-p 'nil)) - (t - (setq enabled-p 'unknown))) - - ;; Convert the extents to strings. - ;; - (if name - (setq name (buffer-substring (extent-start-position name) - (extent-end-position name)))) - (if loc - (setq loc (buffer-substring (extent-start-position loc) - (extent-end-position loc)))) - (if var - (setq var (buffer-substring (extent-start-position var) - (extent-end-position var)))) - (if type - (setq type (buffer-substring (extent-start-position type) - (extent-end-position type)))) - - ;; Return a menu description list. - ;; - (nconc - (if (and bnumber (not (eq enabled-p 'nil))) - (list (vector (format "Disable Breakpoint %d" - bnumber) - (list 'gdb-mouse-disable-breakpoint event) - t))) - (if (and bnumber (not (eq enabled-p 't))) - (list (vector (format "Enable Breakpoint %d" - bnumber) - (list 'gdb-mouse-enable-breakpoint event) - t))) - (if bnumber - (list (vector (format "Delete Breakpoint %d" bnumber) - (list 'gdb-menu-command (format "delete %d" bnumber) - nil) - t))) - (if var - (list (vector (format "Print Value of `%s'" var) - (list 'gdb-mouse-print-variable var-e) - t) - (vector (format "Print Type of `%s'" var) - (list 'gdb-mouse-print-variable-type var-e) - t))) - (if name - (list (vector (format "Edit Definition of `%s'" name) - (list 'gdb-mouse-edit-function event) - t) - (vector (format "Set Breakpoint on `%s'" name) - (list 'gdb-menu-command (format "break %s" name) nil) - t))) - (if loc - (list (vector (format "Visit Source Line (%s)" loc) - (list 'gdb-mouse-edit-function-location event) - t))) - (if type - (list (vector (format "Describe Type `%s'" type) - (list 'gdb-menu-command (format "ptype %s" type) t) - t))) - (if fnumber - (list (vector (format "Select Stack Frame %d" fnumber) - (list 'gdb-menu-command (format "frame %d" fnumber) t) - t))) - )))) - - -(defun gdb-popup-menu (event) - "Pop up a context-sensitive menu of gdb-mode commands." - (interactive "_@e") - (select-window (event-window event)) - (let (menu) - (save-excursion - (setq menu (append (if (boundp 'gdb-popup-menu) - (append (cdr gdb-popup-menu) - '("---"))) - (if (boundp 'comint-popup-menu) - (cdr comint-popup-menu)))) - (let ((history (if (fboundp 'comint-make-history-menu) - (comint-make-history-menu))) - (context (gdb-make-context-menu event))) - (if history - (setq menu - (append menu (list "---" (cons "Command History" history))))) - (if context - (setq menu (append context (cons "---" menu)))) - ) - (setq menu (cons (if (boundp 'gdb-popup-menu) - (car gdb-popup-menu) - "GDB Commands") - menu))) - (popup-menu menu event))) - - -;;; Patch it in... - -(or (fboundp 'gdb-highlight-orig-filter) - (fset 'gdb-highlight-orig-filter (symbol-function 'gdb-filter))) - -(defun gdb-highlight-filter (proc string) - (let ((p (marker-position (process-mark proc)))) - (prog1 - (gdb-highlight-orig-filter proc string) - - (save-match-data - ;; - ;; If there are no newlines in this string at all, then don't - ;; bother processing it -- we will pick up these characters on - ;; the next time around, when the line's newline gets inserted. - ;; - (cond - ((string-match "\n" string) - (save-excursion - (set-buffer (process-buffer proc)) - (goto-char p) - (let ((p2 (marker-position (process-mark proc))) - p3) - ;; - ;; If gdb has given us a full pathname, remember it. (Do this - ;; before emitting any gdb-token extents, so that we attach it - ;; to the buffer *before* any of the extents to which it is - ;; known to correspond. - ;; - (gdb-highlight-remember-directory) - ;; - ;; Now highlight each line that has been written. If we wrote - ;; the last half of a line, re-highlight that whole line. (We - ;; need to do that so that the regexps will match properly; - ;; the "\n" test above also depends on this behavior.) - ;; - ;; But don't highlight lines longer than 5000 characters -- that - ;; probably means something is spewing, and we'll just get stuck - ;; hard in the regexp matcher. - ;; - (beginning-of-line) - (while (< (point) p2) - (goto-char (prog1 - (point) - (forward-line 1) - (setq p3 (point)))) - (if (< (- p3 (point)) 5000) - (gdb-highlight-line)) - (goto-char p3)))))))))) - -(fset 'gdb-filter 'gdb-highlight-filter) - - -(provide 'gdb-highlight) - -;;; gdb-highlight.el ends here - ---------------4273DDB4BB90CEC3B645B5AC-- - -
--- a/lisp/comint/gdb.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,700 +0,0 @@ -;;; gdb.el --- run gdb under Emacs - -;; Author: W. Schelter, University of Texas -;; wfs@rascal.ics.utexas.edu -;; Rewritten by rms. -;; Keywords: c, unix, tools, debugging - -;; Some ideas are due to Masanobu. - -;; 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: - -;; Description of GDB interface: - -;; A facility is provided for the simultaneous display of the source code -;; in one window, while using gdb to step through a function in the -;; other. A small arrow in the source window, indicates the current -;; line. - -;; Starting up: - -;; In order to use this facility, invoke the command GDB to obtain a -;; shell window with the appropriate command bindings. You will be asked -;; for the name of a file to run. Gdb will be invoked on this file, in a -;; window named *gdb-foo* if the file is foo. - -;; M-s steps by one line, and redisplays the source file and line. - -;; You may easily create additional commands and bindings to interact -;; with the display. For example to put the gdb command next on \M-n -;; (def-gdb next "\M-n") - -;; This causes the emacs command gdb-next to be defined, and runs -;; gdb-display-frame after the command. - -;; gdb-display-frame is the basic display function. It tries to display -;; in the other window, the file and line corresponding to the current -;; position in the gdb window. For example after a gdb-step, it would -;; display the line corresponding to the position for the last step. Or -;; if you have done a backtrace in the gdb buffer, and move the cursor -;; into one of the frames, it would display the position corresponding to -;; that frame. - -;; gdb-display-frame is invoked automatically when a filename-and-line-number -;; appears in the output. - -;;; Code: - -(require 'comint) -(require 'shell) - -(condition-case nil - (if (featurep 'toolbar) - (require 'eos-toolbar "sun-eos-toolbar")) - (error nil)) - -(defvar gdb-last-frame) -(defvar gdb-delete-prompt-marker) -(defvar gdb-filter-accumulator) -(defvar gdb-last-frame-displayed-p) -(defvar gdb-arrow-extent nil) -(or (fboundp 'make-glyph) (fset 'make-glyph 'identity)) ; work w/ pre beta v12 -(defvar gdb-arrow-glyph (make-glyph "=>")) - -(make-face 'gdb-arrow-face) -(or (face-differs-from-default-p 'gdb-arrow-face) - ;; Usually has a better default value than highlight does - (copy-face 'isearch 'gdb-arrow-face)) - -;; Hooks can side-effect extent arg to change extent properties -(defvar gdb-arrow-extent-hooks '()) - -(defvar gdb-prompt-pattern "^>\\|^(.*gdb[+]?) *\\|^---Type <return> to.*--- *" - "A regexp to recognize the prompt for gdb or gdb+.") - -(defvar gdb-mode-map nil - "Keymap for gdb-mode.") - -(defvar gdb-toolbar - '([eos::toolbar-stop-at-icon - gdb-toolbar-break - t - "Stop at selected position"] - [eos::toolbar-stop-in-icon - gdb-toolbar-break - t - "Stop in function whose name is selected"] - [eos::toolbar-clear-at-icon - gdb-toolbar-clear - t - "Clear at selected position"] - [eos::toolbar-evaluate-icon - nil - nil - "Evaluate selected expression; shows in separate XEmacs frame"] - [eos::toolbar-evaluate-star-icon - nil - nil - "Evaluate selected expression as a pointer; shows in separate XEmacs frame"] - [eos::toolbar-run-icon - gdb-run - t - "Run current program"] - [eos::toolbar-cont-icon - gdb-cont - t - "Continue current program"] - [eos::toolbar-step-into-icon - gdb-step - t - "Step into (aka step)"] - [eos::toolbar-step-over-icon - gdb-next - t - "Step over (aka next)"] - [eos::toolbar-up-icon - gdb-up - t - "Stack Up (towards \"cooler\" - less recently visited - frames)"] - [eos::toolbar-down-icon - gdb-down - t - "Stack Down (towards \"warmer\" - more recently visited - frames)"] - [eos::toolbar-fix-icon nil nil "Fix (not available with gdb)"] - [eos::toolbar-build-icon - toolbar-compile - t - "Build (aka make -NYI)"] - )) - -(if gdb-mode-map - nil - (setq gdb-mode-map (make-sparse-keymap)) - (set-keymap-name gdb-mode-map 'gdb-mode-map) - (set-keymap-parents gdb-mode-map (list comint-mode-map)) - (define-key gdb-mode-map "\C-l" 'gdb-refresh) - (define-key gdb-mode-map "\C-c\C-c" 'gdb-control-c-subjob) - (define-key gdb-mode-map "\t" 'comint-dynamic-complete) - (define-key gdb-mode-map "\M-?" 'comint-dynamic-list-completions)) - -(define-key ctl-x-map " " 'gdb-break) -(define-key ctl-x-map "&" 'send-gdb-command) - -;;Of course you may use `def-gdb' with any other gdb command, including -;;user defined ones. - -(defmacro def-gdb (name key &optional doc &rest forms) - (let* ((fun (intern (format "gdb-%s" name))) - (cstr (list 'if '(not (= 1 arg)) - (list 'format "%s %s" name 'arg) - name))) - (list 'progn - (nconc (list 'defun fun '(arg) - (or doc "") - '(interactive "p") - (list 'gdb-call cstr)) - forms) - (and key (list 'define-key 'gdb-mode-map key (list 'quote fun)))))) - -(def-gdb "step" "\M-s" "Step one source line with display" - (gdb-delete-arrow-extent)) -(def-gdb "stepi" "\M-i" "Step one instruction with display" - (gdb-delete-arrow-extent)) -(def-gdb "finish" "\C-c\C-f" "Finish executing current function" - (gdb-delete-arrow-extent)) -(def-gdb "run" nil "Run the current program" - (gdb-delete-arrow-extent)) - -;;"next" and "cont" were bound to M-n and M-c in Emacs 18, but these are -;;poor choices, since M-n is used for history navigation and M-c is -;;capitalize-word. These are defined without key bindings so that users -;;may choose their own bindings. -(def-gdb "next" "\C-c\C-n" "Step one source line (skip functions)" - (gdb-delete-arrow-extent)) -(def-gdb "cont" "\C-c\M-c" "Proceed with the program" - (gdb-delete-arrow-extent)) - -(def-gdb "up" "\C-c<" "Go up N stack frames (numeric arg) with display") -(def-gdb "down" "\C-c>" "Go down N stack frames (numeric arg) with display") - -(defvar gdb-display-mode nil - "Minor mode for gdb frame display") -(or (assq 'gdb-display-mode minor-mode-alist) - (setq minor-mode-alist - (purecopy - (append minor-mode-alist - '((gdb-display-mode " Frame")))))) - -(defun gdb-display-mode (&optional arg) - "Toggle GDB Frame display mode -With arg, turn display mode on if and only if arg is positive. -In the display minor mode, source file are displayed in another -window for repective \\[gdb-display-frame] commands." - (interactive "P") - (setq gdb-display-mode (if (null arg) - (not gdb-display-mode) - (> (prefix-numeric-value arg) 0)))) - -;; Using cc-mode's syntax table is broken. -(defvar gdb-mode-syntax-table nil - "Syntax table for GDB mode.") - -;; This is adapted from CC Mode 5.11. -(unless gdb-mode-syntax-table - (setq gdb-mode-syntax-table (make-syntax-table)) - ;; DO NOT TRY TO SET _ (UNDERSCORE) TO WORD CLASS! - (modify-syntax-entry ?_ "_" gdb-mode-syntax-table) - (modify-syntax-entry ?\\ "\\" gdb-mode-syntax-table) - (modify-syntax-entry ?+ "." gdb-mode-syntax-table) - (modify-syntax-entry ?- "." gdb-mode-syntax-table) - (modify-syntax-entry ?= "." gdb-mode-syntax-table) - (modify-syntax-entry ?% "." gdb-mode-syntax-table) - (modify-syntax-entry ?< "." gdb-mode-syntax-table) - (modify-syntax-entry ?> "." gdb-mode-syntax-table) - (modify-syntax-entry ?& "." gdb-mode-syntax-table) - (modify-syntax-entry ?| "." gdb-mode-syntax-table) - (modify-syntax-entry ?\' "\"" gdb-mode-syntax-table) - ;; add extra comment syntax - (modify-syntax-entry ?/ ". 14" gdb-mode-syntax-table) - (modify-syntax-entry ?* ". 23" gdb-mode-syntax-table)) - - -(defun gdb-mode () - "Major mode for interacting with an inferior Gdb process. -The following commands are available: - -\\{gdb-mode-map} - -\\[gdb-display-frame] displays in the other window -the last line referred to in the gdb buffer. See also -\\[gdb-display-mode]. - -\\[gdb-step],\\[gdb-next], and \\[gdb-nexti] in the gdb window, -call gdb to step,next or nexti and then update the other window -with the current file and position. - -If you are in a source file, you may select a point to break -at, by doing \\[gdb-break]. - -Commands: -Many commands are inherited from comint mode. -Additionally we have: - -\\[gdb-display-frame] display frames file in other window -\\[gdb-step] advance one line in program -\\[send-gdb-command] used for special printing of an arg at the current point. -C-x SPACE sets break point at current line." - (interactive) - (comint-mode) - (use-local-map gdb-mode-map) - (set-syntax-table gdb-mode-syntax-table) - (make-local-variable 'gdb-last-frame-displayed-p) - (make-local-variable 'gdb-last-frame) - (make-local-variable 'gdb-delete-prompt-marker) - (make-local-variable 'gdb-display-mode) - (make-local-variable' gdb-filter-accumulator) - (setq gdb-last-frame nil - gdb-delete-prompt-marker nil - gdb-filter-accumulator nil - gdb-display-mode t - major-mode 'gdb-mode - mode-name "Inferior GDB" - comint-prompt-regexp gdb-prompt-pattern - gdb-last-frame-displayed-p t) - (set (make-local-variable 'shell-dirtrackp) t) - ;;(make-local-variable 'gdb-arrow-extent) - (and (extentp gdb-arrow-extent) - (delete-extent gdb-arrow-extent)) - (setq gdb-arrow-extent nil) - ;; XEmacs change: - (make-local-hook 'kill-buffer-hook) - (add-hook 'kill-buffer-hook 'gdb-delete-arrow-extent nil t) - (add-hook 'comint-input-filter-functions 'shell-directory-tracker nil t) - (run-hooks 'gdb-mode-hook)) - -(defun gdb-delete-arrow-extent () - (let ((inhibit-quit t)) - (if gdb-arrow-extent - (delete-extent gdb-arrow-extent)) - (setq gdb-arrow-extent nil))) - -(defvar current-gdb-buffer nil) - -;;;###autoload -(defvar gdb-command-name "gdb" - "Pathname for executing gdb.") - -;;;###autoload -(defun gdb (path &optional corefile) - "Run gdb on program FILE in buffer *gdb-FILE*. -The directory containing FILE becomes the initial working directory -and source-file directory for GDB. If you wish to change this, use -the GDB commands `cd DIR' and `directory'." - (interactive "FRun gdb on file: ") - (setq path (file-truename (expand-file-name path))) - (let ((file (file-name-nondirectory path))) - (switch-to-buffer (concat "*gdb-" file "*")) - (setq default-directory (file-name-directory path)) - (or (bolp) (newline)) - (insert "Current directory is " default-directory "\n") - (apply 'make-comint - (concat "gdb-" file) - (substitute-in-file-name gdb-command-name) - nil - "-fullname" - "-cd" default-directory - file - (and corefile (list corefile))) - (set-process-filter (get-buffer-process (current-buffer)) 'gdb-filter) - (set-process-sentinel (get-buffer-process (current-buffer)) 'gdb-sentinel) - ;; XEmacs change: turn on gdb mode after setting up the proc filters - ;; for the benefit of shell-font.el - (gdb-mode) - (gdb-set-buffer))) - -;;;###autoload -(defun gdb-with-core (file corefile) - "Debug a program using a corefile." - (interactive "fProgram to debug: \nfCore file to use: ") - (gdb file corefile)) - -(defun gdb-set-buffer () - (cond ((eq major-mode 'gdb-mode) - (setq current-gdb-buffer (current-buffer)) - (if (featurep 'eos-toolbar) - (set-specifier default-toolbar (cons (current-buffer) - gdb-toolbar)))))) - - -;; This function is responsible for inserting output from GDB -;; into the buffer. -;; Aside from inserting the text, it notices and deletes -;; each filename-and-line-number; -;; that GDB prints to identify the selected frame. -;; It records the filename and line number, and maybe displays that file. -(defun gdb-filter (proc string) - (let ((inhibit-quit t)) - (save-current-buffer - (set-buffer (process-buffer proc)) - (if gdb-filter-accumulator - (gdb-filter-accumulate-marker - proc (concat gdb-filter-accumulator string)) - (gdb-filter-scan-input proc string))))) - -(defun gdb-filter-accumulate-marker (proc string) - (setq gdb-filter-accumulator nil) - (if (> (length string) 1) - (if (= (aref string 1) ?\032) - (let ((end (string-match "\n" string))) - (if end - (progn - (let* ((first-colon (string-match ":" string 2)) - (second-colon - (string-match ":" string (1+ first-colon)))) - (setq gdb-last-frame - (cons (substring string 2 first-colon) - (string-to-int - (substring string (1+ first-colon) - second-colon))))) - (setq gdb-last-frame-displayed-p nil) - (gdb-filter-scan-input proc - (substring string (1+ end)))) - (setq gdb-filter-accumulator string))) - (gdb-filter-insert proc "\032") - (gdb-filter-scan-input proc (substring string 1))) - (setq gdb-filter-accumulator string))) - -(defun gdb-filter-scan-input (proc string) - (if (equal string "") - (setq gdb-filter-accumulator nil) - (let ((start (string-match "\032" string))) - (if start - (progn (gdb-filter-insert proc (substring string 0 start)) - (gdb-filter-accumulate-marker proc - (substring string start))) - (gdb-filter-insert proc string))))) - -(defun gdb-filter-insert (proc string) - (let ((moving (= (point) (process-mark proc))) - (output-after-point (< (point) (process-mark proc)))) - (save-excursion - ;; Insert the text, moving the process-marker. - (goto-char (process-mark proc)) - (insert-before-markers string) - (set-marker (process-mark proc) (point)) - (gdb-maybe-delete-prompt) - ;; Check for a filename-and-line number. - (gdb-display-frame - ;; Don't display the specified file - ;; unless (1) point is at or after the position where output appears - ;; and (2) this buffer is on the screen. - (or output-after-point - (not (get-buffer-window (current-buffer)))) - ;; Display a file only when a new filename-and-line-number appears. - t)) - (if moving (goto-char (process-mark proc)))) - - (let (s) - (if (and (should-use-dialog-box-p) - (setq s (or (string-match " (y or n) *\\'" string) - (string-match " (yes or no) *\\'" string)))) - (gdb-mouse-prompt-hack (substring string 0 s) (current-buffer)))) - ) - -(defun gdb-mouse-prompt-hack (prompt buffer) - (popup-dialog-box - (list prompt - (vector "Yes" (list 'gdb-mouse-prompt-hack-answer 't buffer) t) - (vector "No" (list 'gdb-mouse-prompt-hack-answer 'nil buffer) t) - nil - (vector "Cancel" (list 'gdb-mouse-prompt-hack-answer 'nil buffer) t) - ))) - -(defun gdb-mouse-prompt-hack-answer (answer buffer) - (let ((b (current-buffer))) - (unwind-protect - (progn - (set-buffer buffer) - (goto-char (process-mark (get-buffer-process buffer))) - (delete-region (point) (point-max)) - (insert (if answer "yes" "no")) - (comint-send-input)) - (set-buffer b)))) - -(defun gdb-sentinel (proc msg) - (cond ((null (buffer-name (process-buffer proc))) - ;; buffer killed - ;; Stop displaying an arrow in a source file. - ;(setq overlay-arrow-position nil) -- done by kill-buffer-hook - (set-process-buffer proc nil)) - ((memq (process-status proc) '(signal exit)) - ;; Stop displaying an arrow in a source file. - (gdb-delete-arrow-extent) - ;; Fix the mode line. - (setq modeline-process - (concat ": gdb " (symbol-name (process-status proc)))) - (let* ((obuf (current-buffer))) - ;; save-excursion isn't the right thing if - ;; process-buffer is current-buffer - (unwind-protect - (progn - ;; Write something in *compilation* and hack its mode line, - (set-buffer (process-buffer proc)) - ;; Force mode line redisplay soon - (set-buffer-modified-p (buffer-modified-p)) - (if (eobp) - (insert ?\n mode-name " " msg) - (save-excursion - (goto-char (point-max)) - (insert ?\n mode-name " " msg))) - ;; If buffer and mode line will show that the process - ;; is dead, we can delete it now. Otherwise it - ;; will stay around until M-x list-processes. - (delete-process proc)) - ;; Restore old buffer, but don't restore old point - ;; if obuf is the gdb buffer. - (set-buffer obuf)))))) - - -(defun gdb-refresh (&optional arg) - "Fix up a possibly garbled display, and redraw the arrow." - (interactive "P") - (recenter arg) - (gdb-display-frame)) - -(defun gdb-display-frame (&optional nodisplay noauto) - "Find, obey and delete the last filename-and-line marker from GDB. -The marker looks like \\032\\032FILENAME:LINE:CHARPOS\\n. -Obeying it means displaying in another window the specified file and line." - (interactive) - (gdb-set-buffer) - (and gdb-last-frame (not nodisplay) - gdb-display-mode - (or (not gdb-last-frame-displayed-p) (not noauto)) - (progn (gdb-display-line (car gdb-last-frame) (cdr gdb-last-frame)) - (setq gdb-last-frame-displayed-p t)))) - -;; Make sure the file named TRUE-FILE is in a buffer that appears on the screen -;; and that its line LINE is visible. -;; Put the overlay-arrow on the line LINE in that buffer. - -(defun gdb-display-line (true-file line &optional select-method) - ;; FILE to display - ;; LINE number to highlight and make visible - ;; SELECT-METHOD 'source, 'debugger, or 'none. (default is 'debugger) - (and (null select-method) (setq select-method 'debugger)) - (let* ((pre-display-buffer-function nil) ; screw it, put it all in one screen - (pop-up-windows t) - (source-buffer (find-file-noselect true-file)) - (source-window (display-buffer source-buffer)) - (debugger-window (get-buffer-window current-gdb-buffer)) - (extent gdb-arrow-extent) - pos) - ;; XEmacs change: make sure we find a window displaying the source file - ;; even if we are already sitting in it when a breakpoint is hit. - ;; Otherwise the t argument to display-buffer will prevent it from being - ;; displayed. - (save-excursion - (cond ((eq select-method 'debugger) - ;; might not already be displayed - (setq debugger-window (display-buffer current-gdb-buffer)) - (select-window debugger-window)) - ((eq select-method 'source) - (select-window source-window)))) - (and extent - (not (eq (extent-object extent) source-buffer)) - (setq extent (delete-extent extent))) - (or extent - (progn - (setq extent (make-extent 1 1 source-buffer)) - (set-extent-face extent 'gdb-arrow-face) - (set-extent-begin-glyph extent gdb-arrow-glyph) - (set-extent-begin-glyph-layout extent 'whitespace) - (set-extent-priority extent 2000) - (setq gdb-arrow-extent extent))) - (save-current-buffer - (set-buffer source-buffer) - (save-restriction - (widen) - (goto-line line) - (set-window-point source-window (point)) - (setq pos (point)) - (end-of-line) - (set-extent-endpoints extent pos (point)) - (run-hook-with-args 'gdb-arrow-extent-hooks extent)) - (cond ((or (< pos (point-min)) (> pos (point-max))) - (widen) - (goto-char pos)))) - ;; Added by Stig. It caused lots of problems for several users - ;; and since its purpose is unclear it is getting commented out. - ;;(and debugger-window - ;; (set-window-point debugger-window pos)) - )) - -(defun gdb-call (command) - "Invoke gdb COMMAND displaying source in other window." - (interactive) - (goto-char (point-max)) - ;; Record info on the last prompt in the buffer and its position. - ;; This is used in gdb-maybe-delete-prompt - ;; to prevent multiple prompts from accumulating. - (save-excursion - (goto-char (process-mark (get-buffer-process current-gdb-buffer))) - (let ((pt (point))) - (beginning-of-line) - (setq gdb-delete-prompt-marker - (if (= (point) pt) - nil - (list (point-marker) (- pt (point)) - (buffer-substring (point) pt)))))) - (gdb-set-buffer) - (process-send-string (get-buffer-process current-gdb-buffer) - (concat command "\n"))) - -(defun gdb-maybe-delete-prompt () - (if gdb-delete-prompt-marker - ;; Get the string that we used as the prompt before. - (let ((prompt (nth 2 gdb-delete-prompt-marker)) - (length (nth 1 gdb-delete-prompt-marker))) - ;; Position after it. - (goto-char (+ (car gdb-delete-prompt-marker) length)) - ;; Delete any duplicates of it which follow right after. - (while (and (<= (+ (point) length) (point-max)) - (string= prompt - (buffer-substring (point) (+ (point) length)))) - (delete-region (point) (+ (point) length))) - ;; If that didn't take us to where output is arriving, - ;; we have encountered something other than a prompt, - ;; so stop trying to delete any more prompts. - (if (not (= (point) - (process-mark (get-buffer-process current-gdb-buffer)))) - (progn - (set-marker (car gdb-delete-prompt-marker) nil) - (setq gdb-delete-prompt-marker nil)))))) - -(defun gdb-break (temp) - "Set GDB breakpoint at this source line. With ARG set temporary breakpoint." - (interactive "P") - (let* ((file-name (file-name-nondirectory buffer-file-name)) - (line (save-restriction - (widen) - (beginning-of-line) - (1+ (count-lines 1 (point))))) - (cmd (concat (if temp "tbreak " "break ") file-name ":" - (int-to-string line)))) - (set-buffer current-gdb-buffer) - (goto-char (process-mark (get-buffer-process current-gdb-buffer))) - (delete-region (point) (point-max)) - (insert cmd) - (comint-send-input) - ;;(process-send-string (get-buffer-process current-gdb-buffer) cmd) - )) - -(defun gdb-clear () - "Set GDB breakpoint at this source line." - (interactive) - (let* ((file-name (file-name-nondirectory buffer-file-name)) - (line (save-restriction - (widen) - (beginning-of-line) - (1+ (count-lines 1 (point))))) - (cmd (concat "clear " file-name ":" - (int-to-string line)))) - (set-buffer current-gdb-buffer) - (goto-char (process-mark (get-buffer-process current-gdb-buffer))) - (delete-region (point) (point-max)) - (insert cmd) - (comint-send-input) - ;;(process-send-string (get-buffer-process current-gdb-buffer) cmd) - )) - -(defun gdb-read-address() - "Return a string containing the core-address found in the buffer at point." - (save-excursion - (let ((pt (point)) found begin) - (setq found (if (search-backward "0x" (- pt 7) t)(point))) - (cond (found (forward-char 2) - (buffer-substring found - (progn (re-search-forward "[^0-9a-f]") - (forward-char -1) - (point)))) - (t (setq begin (progn (re-search-backward "[^0-9]") (forward-char 1) - (point))) - (forward-char 1) - (re-search-forward "[^0-9]") - (forward-char -1) - (buffer-substring begin (point))))))) - - -(defvar gdb-commands nil - "List of strings or functions used by send-gdb-command. -It is for customization by you.") - -(defun send-gdb-command (arg) - - "This command reads the number where the cursor is positioned. It - then inserts this ADDR at the end of the gdb buffer. A numeric arg - selects the ARG'th member COMMAND of the list gdb-print-command. If - COMMAND is a string, (format COMMAND ADDR) is inserted, otherwise - (funcall COMMAND ADDR) is inserted. eg. \"p (rtx)%s->fld[0].rtint\" - is a possible string to be a member of gdb-commands. " - - - (interactive "P") - (let (comm addr) - (if arg (setq comm (nth arg gdb-commands))) - (setq addr (gdb-read-address)) - (if (eq (current-buffer) current-gdb-buffer) - (set-mark (point))) - (cond (comm - (setq comm - (if (stringp comm) (format comm addr) (funcall comm addr)))) - (t (setq comm addr))) - (switch-to-buffer current-gdb-buffer) - (goto-char (point-max)) - (insert comm))) - -(fset 'gdb-control-c-subjob 'comint-interrupt-subjob) - -;(defun gdb-control-c-subjob () -; "Send a Control-C to the subprocess." -; (interactive) -; (process-send-string (get-buffer-process (current-buffer)) -; "\C-c")) - -(defun gdb-toolbar-break () - (interactive) - (save-excursion - (message (car gdb-last-frame)) - (set-buffer (find-file-noselect (car gdb-last-frame))) - (gdb-break nil))) - -(defun gdb-toolbar-clear () - (interactive) - (save-excursion - (message (car gdb-last-frame)) - (set-buffer (find-file-noselect (car gdb-last-frame))) - (gdb-clear))) - -(provide 'gdb) - -;;; gdb.el ends here
--- a/lisp/comint/gdbsrc.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,896 +0,0 @@ -;;; gdbsrc.el -- Source-based (as opposed to comint-based) debugger -;; interaction mode eventually, this will be unified with GUD -;; (after gud works reliably w/ XEmacs...) -;; Keywords: c, unix, tools, debugging - -;; Copyright (C) 1990 Debby Ayers <ayers@austin.ibm.com>, and -;; Rich Schaefer <schaefer@asc.slb.com> -;; Copyright (C) 1994, 1995 Tinker Systems and INS Engineering Corp. -;; -;; 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 of the License, 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; if not, write to the Free Software -;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -;; Based upon code for version18 by Debra Ayers <ayers@austin.ibm.com> - -;;; GDBSRC:: -;;; Gdbsrc extends the emacs GDB interface to accept gdb commands issued -;;; from the source code buffer. Gdbsrc behaves similar to gdb except -;;; now most debugging may be done from the source code using the *gdb* -;;; buffer to view output. Supports a point and click model under X to -;;; evaluate source code expressions (no more typing long variable names). -;;; -;;; Supports C source at the moment but C++ support will be added if there -;;; is sufficient interest. -;;; - -;; GDBSRC::Gdb Source Mode Interface description. -;; Gdbsrc extends the emacs GDB interface to accept gdb commands issued -;; from the source code buffer. Gdbsrc behaves similar to gdb except now all -;; debugging may be done from the currently focused source buffer using -;; the *gdb* buffer to view output. - -;; When source files are displayed through gdbsrc, buffers are put in -;; gdbsrc-mode minor mode. This mode puts the buffer in read-only state -;; and sets up a special key and mouse map to invoke communication with -;; the current gdb process. The minor mode may be toggled on/off as needed. -;; (ESC-T) - -;; C-expressions may be evaluated by gdbsrc by simply pointing at text in the -;; current source buffer with the mouse or by centering the cursor over text -;; and typing a single key command. ('p' for print, '*' for print *). - -;; As code is debugged and new buffers are displayed, the focus of gdbsrc -;; follows to each new source buffer. Makes debugging fun. (sound like a -;; commercial or what!) -;; - -;; Current Listing :: -;;key binding Comment -;;--- ------- ------- -;; -;; r gdb-return-from-src GDB return command -;; n gdb-next-from-src GDB next command -;; b gdb-back-from-src GDB back command -;; w gdb-where-from-src GDB where command -;; f gdb-finish-from-src GDB finish command -;; u gdb-up-from-src GDB up command -;; d gdb-down-from-src GDB down command -;; c gdb-cont-from-src GDB continue command -;; i gdb-stepi-from-src GDB step instruction command -;; s gdb-step-from-src GDB step command -;; ? gdb-whatis-c-sexp GDB whatis command for data at -;; buffer point -;; x gdbsrc-delete GDB Delete all breakpoints if no arg -;; given or delete arg (C-u arg x) -;; m gdbsrc-frame GDB Display current frame if no arg, -;; given or display frame arg -;; * gdb-*print-c-sexp GDB print * command for data at -;; buffer point -;; ! gdbsrc-goto-gdb Goto the GDB output buffer -;; p gdb-print-c-sexp GDB print * command for data at -;; buffer point -;; g gdbsrc-goto-gdb Goto the GDB output buffer -;; t gdbsrc-mode Toggles Gdbsrc mode (turns it off) -;; -;; C-c C-f gdb-finish-from-src GDB finish command -;; -;; C-x SPC gdb-break Set break for line with point -;; ESC t gdbsrc-mode Toggle Gdbsrc mode -;; -;; Local Bindings for buffer when you exit Gdbsrc minor mode -;; -;; C-x SPC gdb-break Set break for line with point -;; ESC t gdbsrc-mode Toggle Gdbsrc mode -;; - -;;; (eval-when-compile -;;; (or noninteractive -;;; (progn -;;; (message "ONLY compile gdbsrc except with -batch because of advice") -;;; (ding) -;;; ))) - -(require 'gdb "gdb") ; NOT gud! (yet...) - -(defvar gdbsrc-active-p t - "*Set to nil if you do not want source files put in gdbsrc-mode") - -(defvar gdbsrc-call-p nil - "True if gdb command issued from a source buffer") - -(defvar gdbsrc-associated-buffer nil - "Buffer name of attached gdb process") - -(defvar gdbsrc-mode nil - "Indicates whether buffer is in gdbsrc-mode or not") -(make-variable-buffer-local 'gdbsrc-mode) - -(defvar gdbsrc-global-mode nil - "Indicates whether global gdbsrc bindings are in effect or not") - -(defvar gdb-prompt-pattern "^[^)#$%>\n]*[)#$%>] *" - "A regexp for matching the end of the gdb prompt") - -;;; bindings - -(defvar gdbsrc-global-map - (let ((map (make-sparse-keymap))) - (set-keymap-name map 'gdbsrc-global-map) - (define-key map "\C-x " 'gdb-break) - (define-key map "\M-\C-t" 'gdbsrc-mode) - (define-key map "\M-\C-g" 'gdbsrc-goto-gdb) - - ;; middle button to select and print expressions... - (define-key map '(meta button2) 'gdbsrc-print-csexp) - (define-key map '(meta shift button2) 'gdbsrc-*print-csexp) - ;; left button to position breakpoints - (define-key map '(meta button1) 'gdbsrc-set-break) - (define-key map '(meta shift button1) 'gdbsrc-set-tbreak-continue) - map) - "Global minor keymap that is active whenever gdbsrc is running.") - -(add-minor-mode 'gdbsrc-global-mode " GdbGlobal" gdbsrc-global-map) - -(defvar gdbsrc-mode-map - (let ((map (make-sparse-keymap))) - (suppress-keymap map) - (set-keymap-name map 'gdbsrc-mode-map) - ;; inherit keys from global gdbsrc map just in case that somehow gets turned off. - (set-keymap-parents map (list gdbsrc-global-map)) - (define-key map "\C-x\C-q" 'gdbsrc-mode) ; toggle read-only - (define-key map "\C-c\C-c" 'gdbsrc-mode) - (define-key map "b" 'gdb-break) - (define-key map "g" 'gdbsrc-goto-gdb) - (define-key map "!" 'gdbsrc-goto-gdb) - (define-key map "p" 'gdb-print-c-sexp) - (define-key map "*" 'gdb-*print-c-sexp) - (define-key map "?" 'gdb-whatis-c-sexp) - (define-key map "R" 'gdbsrc-reset) - map) - "Minor keymap for buffers in gdbsrc-mode") - -(add-minor-mode 'gdbsrc-mode " GdbSrc" gdbsrc-mode-map) - -(defvar gdbsrc-toolbar - '([eos::toolbar-stop-at-icon - gdb-break - t - "Stop at selected position"] - [eos::toolbar-stop-in-icon - gdb-break - t - "Stop in function whose name is selected"] - [eos::toolbar-clear-at-icon - gdbsrc-delete - t - "Clear at selected position"] - [eos::toolbar-evaluate-icon - gdb-print-c-sexp - t - "Evaluate selected expression; shows in separate XEmacs frame"] - [eos::toolbar-evaluate-star-icon - gdb-*print-c-sexp - t - "Evaluate selected expression as a pointer; shows in separate XEmacs frame"] - [eos::toolbar-run-icon - gdbsrc-run - t - "Run current program"] - [eos::toolbar-cont-icon - gdbsrc-cont - t - "Continue current program"] - [eos::toolbar-step-into-icon - gdbsrc-step - t - "Step into (aka step)"] - [eos::toolbar-step-over-icon - gdbsrc-next - t - "Step over (aka next)"] - [eos::toolbar-up-icon - gdbsrc-up - t - "Stack Up (towards \"cooler\" - less recently visited - frames)"] - [eos::toolbar-down-icon - gdbsrc-down - t - "Stack Down (towards \"warmer\" - more recently visited - frames)"] - [eos::toolbar-fix-icon - nil - nil - "Fix (not available with gdb)"] - [eos::toolbar-build-icon - toolbar-compile - t - "Build (aka make -NYI)"] - )) - -(defmacro def-gdb-from-src (gdb-command key &optional doc &rest forms) - "Create a function that will call GDB-COMMAND with KEY." - (let* ((fname (format "gdbsrc-%s" gdb-command)) - (cstr (list 'if 'arg - (list 'format "%s %s" gdb-command '(prefix-numeric-value arg)) - gdb-command)) - fun) - (while (string-match " " fname) - (aset fname (match-beginning 0) ?-)) - (setq fun (intern fname)) - - (list 'progn - (nconc (list 'defun fun '(arg) - (or doc "") - '(interactive "P") - (list 'gdb-call-from-src cstr)) - forms) - (list 'define-key 'gdbsrc-mode-map key (list 'quote fun))))) - -(def-gdb-from-src "step" "s" "Step one instruction in src" - (gdb-delete-arrow-extent)) -(def-gdb-from-src "stepi" "i" "Step one source line (skip functions)" - (gdb-delete-arrow-extent)) -(def-gdb-from-src "cont" "c" "Continue with display" - (gdb-delete-arrow-extent)) -(def-gdb-from-src "down" "d" "Go down N stack frames (numeric arg) ") -(def-gdb-from-src "up" "u" "Go up N stack frames (numeric arg)") -(def-gdb-from-src "finish" "f" "Finish frame") -(def-gdb-from-src "where" "w" "Display (N frames of) backtrace") -(def-gdb-from-src "next" "n" "Step one line with display" - (gdb-delete-arrow-extent)) -(def-gdb-from-src "run" "r" "Run program from start" - (gdb-delete-arrow-extent)) -(def-gdb-from-src "return" "R" "Return from selected stack frame") -(def-gdb-from-src "disable" "x" "Disable all breakpoints") -(def-gdb-from-src "delete" "X" "Delete all breakpoints") -(def-gdb-from-src "quit" "Q" "Quit gdb." - (gdb-delete-arrow-extent)) -(def-gdb-from-src "info locals" "l" "Show local variables") -(def-gdb-from-src "info break" "B" "Show breakpoints") -(def-gdb-from-src "" "\r" "Repeat last command") -(def-gdb-from-src "frame" "m" "Show frame if no arg, with arg go to frame") - -;;; code - -;;;###autoload -(defun gdbsrc (path &optional core-or-pid) - "Activates a gdb session with gdbsrc-mode turned on. A numeric prefix -argument can be used to specify a running process to attach, and a non-numeric -prefix argument will cause you to be prompted for a core file to debug." - (interactive (let ((file (read-file-name "Program to debug: " nil nil t))) - (cond ((numberp current-prefix-arg) - (list file (int-to-string current-prefix-arg))) - (current-prefix-arg - (list file (read-file-name "Core file: " nil nil t))) - (t (list file))) - )) - ;; FIXME - this is perhaps an uncool thing to do --Stig - (delete-other-windows) - (split-window-vertically) - (other-window 0) - - (gdb path core-or-pid) - (local-set-key 'button2 'gdbsrc-select-or-yank) - (setq mode-motion-hook 'gdbsrc-mode-motion) - ;; XEmacs change: - (make-local-hook 'kill-buffer-hook) - (add-hook 'kill-buffer-hook 'gdbsrc-reset nil t)) - -(defun gdbsrc-global-mode () - ;; this can be used as a hook for gdb-mode.... - (or current-gdb-buffer - (and (eq major-mode 'gdb-mode) ; doesn't work w/ energize yet - (setq current-gdb-buffer (current-buffer)) - ;; XEmacs change: - (progn - (make-local-hook 'kill-buffer-hook) - (add-hook 'kill-buffer-hook 'gdbsrc-reset nil t))) - (error "Cannot determine current-gdb-buffer")) -;;; (set-process-filter -;;; (get-buffer-process current-gdb-buffer) 'gdbsrc-mode-filter) -;;; (set-process-sentinel -;;; (get-buffer-process current-gdb-buffer) 'gdbsrc-mode-sentinel) - ;; gdbsrc-global-mode was set to t here but that tended to piss - ;; people off - (setq gdbsrc-global-mode nil - gdbsrc-active-p t - gdbsrc-call-p nil - gdbsrc-mode nil) - (message "Gbd source mode active")) - -(add-hook 'gdb-mode-hook 'gdbsrc-global-mode) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Gdb Source minor mode. -;;; - -(defvar gdbsrc-associated-buffer nil - "The gdb buffer to send commands to.") -(defvar gdbsrc-initial-readonly 'undefined - "read-only status of buffer when not in gdbsrc-mode") -(defvar gdbsrc-old-toolbar nil - "saved toolbar for buffer") - -(defun gdbsrc-mode (arg &optional quiet) - "Minor mode for interacting with gdb from a c source file. -With arg, turn gdbsrc-mode on iff arg is positive. In gdbsrc-mode, -you may send an associated gdb buffer commands from the current buffer -containing c source code." - (interactive "P") - (setq gdbsrc-mode - (if (null arg) - (not gdbsrc-mode) - (> (prefix-numeric-value arg) 0))) - - (cond (gdbsrc-mode - (cond ((not (local-variable-p 'gdbsrc-initial-readonly (current-buffer))) - (set (make-local-variable 'gdbsrc-initial-readonly) - buffer-read-only) - (set (make-local-variable 'gdbsrc-associated-buffer) - current-gdb-buffer) - (if (featurep 'toolbar) - (set (make-local-variable 'gdbsrc-old-toolbar) - (specifier-specs default-toolbar (current-buffer)))) - ) - ) - (if (featurep 'toolbar) - (set-specifier default-toolbar (cons (current-buffer) - gdbsrc-toolbar))) - (setq buffer-read-only t) - (or quiet (message "Entering gdbsrc-mode..."))) - (t - (and (local-variable-p 'gdbsrc-initial-readonly (current-buffer)) - (progn - (if (featurep 'toolbar) - (if gdbsrc-old-toolbar - (set-specifier default-toolbar - (cons (current-buffer) - gdbsrc-old-toolbar)) - (remove-specifier default-toolbar (current-buffer)))) - (kill-local-variable 'gdbsrc-old-toolbar) - (setq buffer-read-only gdbsrc-initial-readonly) - (kill-local-variable 'gdbsrc-initial-readonly) - (kill-local-variable 'gdbsrc-associated-buffer) - )) - (or quiet (message "Exiting gdbsrc-mode...")))) - (redraw-modeline t)) - -;; -;; Sends commands to gdb process. - -(defun gdb-call-from-src (command) - "Send associated gdb process COMMAND displaying source in this window." - (setq gdbsrc-call-p t) - (let ((src-win (selected-window)) - (buf (or gdbsrc-associated-buffer current-gdb-buffer))) - (or (buffer-name buf) - (error "GDB buffer deleted")) - (pop-to-buffer buf) - (goto-char (point-max)) - (beginning-of-line) - ;; Go past gdb prompt - (re-search-forward - gdb-prompt-pattern (save-excursion (end-of-line) (point)) t) - ;; Delete any not-supposed-to-be-there text - (delete-region (point) (point-max)) - (insert command) - (comint-send-input) - (select-window src-win) - )) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Define Commands for GDB SRC Mode Buffer -;;; - -;;; ;; #### - move elsewhere -(or (fboundp 'event-buffer) - (defun event-buffer (event) - "Return buffer assocaited with EVENT, or nil." - (let ((win (event-window event))) - (and win (window-buffer win))))) - -(defun set-gdbsrc-mode-motion-extent (st en action) - ;; by Stig@hackvan.com - (let ((ex (make-extent st en))) - (set-extent-face ex 'highlight) - (set-extent-property ex 'gdbsrc t) - (set-extent-property ex 'action action) - (setq mode-motion-extent ex))) - -(defun nuke-mode-motion-extent () - ;; by Stig@hackvan.com - (cond (mode-motion-extent - (delete-extent mode-motion-extent) - (setq mode-motion-extent nil)))) - -(defun looking-at-any (regex-list) - ;; by Stig@hackvan.com - (catch 'found - (while regex-list - (and (looking-at (car regex-list)) - (throw 'found t)) - (setq regex-list (cdr regex-list))))) - -(defconst gdb-breakpoint-patterns - '( - ;; when execution stops... - ;;Breakpoint 1, XlwMenuRedisplay (w=0x4d2e00, ev=0xefffe3f8, region=0x580e60) - ;; at /net/stig/src/xemacs/lwlib/xlwmenu.c:2518 - "^[BW][ra][et][ac][kh]point [0-9]+, .*\\(\n\\s .*\\)*" - ;; output of the breakpoint command: - ;;Breakpoint 1 at 0x19f5c8: file /net/stig/src/xemacs/lwlib/xlwmenu.c, line 2715. - "^[BW][ra][et][ac][kh]point [0-9]+ at .*: file \\([^ ,\n]+\\), line \\([0-9]+\\)." - ;;Num Type Disp Enb Address What - ;;1 breakpoint keep y 0x0019ee60 in XlwMenuRedisplay - ;; at /net/stig/src/xemacs/lwlib/xlwmenu.c:2518 - "^[0-9]+\\s +[bw][ra][et][ac][kh]point.* in .*\\(\n\\s +\\)?at [^ :\n]+:[0-9]+\\(\n\\s .*\\)*" - ) - "list of patterns to match gdb's various ways of displaying a breakpoint") - -(defun gdbsrc-make-breakpoint-action (string) - ;; by Stig@hackvan.com - (if (or (string-match "file \\([^ ,\n]+\\), line \\([0-9]+\\)" string) - (string-match "at \\([^ :\n]+\\):\\([0-9]+\\)" string)) - (list 'gdbsrc-display - (match-string 1 string) - (string-to-int (match-string 2 string))))) - -(defconst gdb-stack-frame-pattern - ;;#9 0x62f08 in emacs_Xt_next_event (emacs_event=0x4cf804) - ;; at /net/stig/src/xemacs/src/event-Xt.c:1778 - "^#\\([0-9]+\\)\\s +\\(0x[0-9a-f]+ in .*\\|.*\\sw+.* (.*) at .*\\)\\(\n\\s .*\\)*" - "matches the first line of a gdb stack frame and all continuation lines. -subex 1 is frame number.") - -(defun gdbsrc-mode-motion (ee) - ;; by Stig@hackvan.com - (save-excursion - (set-buffer (event-buffer ee)) - (save-excursion - (if (not (event-point ee)) - (nuke-mode-motion-extent) - (goto-char (event-point ee)) - (beginning-of-line) - (while (and (not (bobp)) (eq ? (char-syntax (following-char)))) - (forward-line -1)) - (if (extent-at (point) (current-buffer) 'gdbsrc) - nil - (nuke-mode-motion-extent) - (cond ((looking-at-any gdb-breakpoint-patterns) - (set-gdbsrc-mode-motion-extent - (match-beginning 0) - (match-end 0) - (gdbsrc-make-breakpoint-action (match-string 0)))) - ((looking-at gdb-stack-frame-pattern) - (set-gdbsrc-mode-motion-extent - (match-beginning 0) - (match-end 0) - (list 'gdbsrc-frame - (string-to-int (match-string 1))))) - ))) - ))) - -(defun gdbsrc-display (file line) - ;; by Stig@hackvan.com - (select-window (display-buffer (find-file-noselect file))) - (goto-line line)) - -(defun click-inside-selection-p (click) - (or (click-inside-extent-p click primary-selection-extent) - (click-inside-extent-p click zmacs-region-extent) - )) - -(defun click-inside-extent-p (click extent) - "Returns non-nil if the button event is within the bounds of the primary -selection-extent, nil otherwise." - ;; stig@hackvan.com - (let ((ewin (event-window click)) - (epnt (event-point click))) - (and ewin - epnt - extent - (eq (window-buffer ewin) - (extent-object extent)) - (extent-start-position extent) - (> epnt (extent-start-position extent)) - (> (extent-end-position extent) epnt)))) - -(defun point-inside-extent-p (extent) - "Returns non-nil if the point is within or just after the bounds of the -primary selection-extent, nil otherwise." - ;; stig@hackvan.com - (and extent ; FIXME - I'm such a sinner... - (eq (current-buffer) - (extent-object extent)) - (> (point) (extent-start-position extent)) - (>= (extent-end-position extent) (point)))) - -(defun gdbsrc-select-or-yank (ee) - ;; by Stig@hackvan.com - (interactive "e") - (let ((action (save-excursion - (set-buffer (event-buffer ee)) - (and mode-motion-extent - (click-inside-extent-p ee mode-motion-extent) - (extent-property mode-motion-extent 'action))) - )) - (if action - (eval action) - (mouse-yank ee)))) - -(defvar gdb-print-format "" - "Set this variable to a valid format string to print c-sexps in a -different way (hex,octal, etc).") - -(defun gdb-print-c-sexp () - "Find the nearest c-mode sexp. Send it to gdb with print command." - (interactive) - (let* ((tag (find-c-sexp)) - (command (concat "print " gdb-print-format tag))) - (gdb-call-from-src command))) - -(defun gdb-*print-c-sexp () - "Find the nearest c-mode sexp. Send it to gdb with the print * command." - (interactive) - (let* ((tag (find-c-sexp)) - (command (concat "print " gdb-print-format "*" tag))) - (gdb-call-from-src command))) - -(defun gdb-whatis-c-sexp () - "Find the nearest c-mode sexp. Send it to gdb with the whatis command. " - (interactive) - (let* ((tag (gdbsrc-selection-or-sexp)) - (command (concat "whatis " tag))) - (gdb-call-from-src command))) - -(defun gdbsrc-goto-gdb () - "Hop back and forth between the gdb interaction buffer and the gdb source -buffer. " - ;; by Stig@hackvan.com - (interactive) - (let ((gbuf (or gdbsrc-associated-buffer current-gdb-buffer))) - (cond ((eq (current-buffer) gbuf) - (and gdb-arrow-extent - (extent-object gdb-arrow-extent) - (progn (pop-to-buffer (extent-object gdb-arrow-extent)) - (goto-char (extent-start-position gdb-arrow-extent))))) - ((buffer-name gbuf) (pop-to-buffer gbuf)) - ((y-or-n-p "No debugger. Start a new one? ") - (call-interactively 'gdbsrc)) - (t (error "No gdb buffer.")) - ))) - -(defvar gdbsrc-last-src-buffer nil) - -(defun gdbsrc-goto-src () - (interactive) - (let* ((valid (and gdbsrc-last-src-buffer - (memq gdbsrc-last-src-buffer (buffer-list)))) - (win (and valid - (get-buffer-window gdbsrc-last-src-buffer)))) - (cond (win (select-window win)) - (valid (pop-to-buffer gdbsrc-last-src-buffer))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; The following functions are used to extract the closest surrounding -;;; c expression from point -;;; -(defun back-sexp () - "Version of backward-sexp that catches errors" - (condition-case nil - (backward-sexp) - (error t))) - -(defun forw-sexp () - "Version of forward-sexp that catches errors" - (condition-case nil - (forward-sexp) - (error t))) - -(defun sexp-compound-sep (span-start span-end) - "Returns '.' for '->' & '.', returns ' ' for white space, -returns '?' for other puctuation" - (let ((result ? ) - (syntax)) - (while (< span-start span-end) - (setq syntax (char-syntax (char-after span-start))) - (cond - ((= syntax ? ) t) - ((= syntax ?.) (setq syntax (char-after span-start)) - (cond - ((= syntax ?.) (setq result ?.)) - ((and (= syntax ?-) (= (char-after (+ span-start 1)) ?>)) - (setq result ?.) - (setq span-start (+ span-start 1))) - (t (setq span-start span-end) - (setq result ??))))) - (setq span-start (+ span-start 1))) - result - ) - ) - -(defun sexp-compound (first second) - "Returns non-nil if the concatenation of two S-EXPs result in a Single C -token. The two S-EXPs are represented as a cons cells, where the car -specifies the point in the current buffer that marks the begging of the -S-EXP and the cdr specifies the character after the end of the S-EXP -Link S-Exps of the form: - Sexp -> SexpC - Sexp . Sexp - Sexp (Sexp) Maybe exclude if first Sexp is: if, while, do, for, switch - Sexp [Sexp] - (Sexp) Sexp - [Sexp] Sexp" - (let ((span-start (cdr first)) - (span-end (car second)) - (syntax)) - (setq syntax (sexp-compound-sep span-start span-end)) - (cond - ((= (car first) (car second)) nil) - ((= (cdr first) (cdr second)) nil) - ((= syntax ?.) t) - ((= syntax ? ) - (setq span-start (char-after (- span-start 1))) - (setq span-end (char-after span-end)) - (cond - ((= span-start ?) ) t ) - ((= span-start ?] ) t ) - ((= span-end ?( ) t ) - ((= span-end ?[ ) t ) - (t nil)) - ) - (t nil)) - ) - ) - -(defun sexp-cur () - "Returns the S-EXP that Point is a member, Point is set to begging of S-EXP. -The S-EXPs is represented as a cons cell, where the car specifies the point in -the current buffer that marks the begging of the S-EXP and the cdr specifies -the character after the end of the S-EXP" - (let ((p (point)) (begin) (end)) - (back-sexp) - (setq begin (point)) - (forw-sexp) - (setq end (point)) - (if (>= p end) - (progn - (setq begin p) - (goto-char p) - (forw-sexp) - (setq end (point)) - ) - ) - (goto-char begin) - (cons begin end) - ) - ) - -(defun sexp-prev () - "Returns the previous S-EXP, Point is set to begging of that S-EXP. -The S-EXPs is represented as a cons cell, where the car specifies the point in -the current buffer that marks the begging of the S-EXP and the cdr specifies -the character after the end of the S-EXP" - (let ((begin) (end)) - (back-sexp) - (setq begin (point)) - (forw-sexp) - (setq end (point)) - (goto-char begin) - (cons begin end)) -) - -(defun sexp-next () - "Returns the following S-EXP, Point is set to begging of that S-EXP. -The S-EXPs is represented as a cons cell, where the car specifies the point in -the current buffer that marks the begging of the S-EXP and the cdr specifies -the character after the end of the S-EXP" - (let ((begin) (end)) - (forw-sexp) - (forw-sexp) - (setq end (point)) - (back-sexp) - (setq begin (point)) - (cons begin end) - ) - ) - -(defun find-c-sexp () - "Returns the Complex S-EXP that surrounds Point" - (interactive) - (save-excursion - (let ((p) (sexp) (test-sexp)) - (setq p (point)) - (setq sexp (sexp-cur)) - (setq test-sexp (sexp-prev)) - (while (sexp-compound test-sexp sexp) - (setq sexp (cons (car test-sexp) (cdr sexp))) - (goto-char (car sexp)) - (setq test-sexp (sexp-prev)) - ) - (goto-char p) - (setq test-sexp (sexp-next)) - (while (sexp-compound sexp test-sexp) - (setq sexp (cons (car sexp) (cdr test-sexp))) - (setq test-sexp (sexp-next)) - ) - (buffer-substring (car sexp) (cdr sexp)) - ) - ) - ) - -(defun gdbsrc-selection-or-sexp (&optional ee) - ;; FIXME - fix this docstring - "If the EVENT is within the primary selection, then return the selected -text, otherwise parse the expression at the point of the mouse click and -return that. If EVENT is nil, then return the C sexp at point." - ;; stig@hackvan.com - (cond ((or (and ee (click-inside-selection-p ee)) - (and (not ee) (point-inside-selection-p))) - (replace-in-string (extent-string primary-selection-extent) "\n\\s *" " ")) - (ee - (gdbsrc-get-csexp-at-click ee)) - (t - (find-c-sexp)) - )) - -(defun gdbsrc-get-csexp-at-click (ee) - "Returns the containing s-expression located at the mouse cursor to point." - ;; " - ;; by Stig@hackvan.com - (let ((ewin (event-window ee)) - (epnt (event-point ee))) - (or (and ewin epnt) - (error "Must click within a window")) - (save-excursion - (set-buffer (window-buffer ewin)) - (save-excursion - (goto-char epnt) - (find-c-sexp))))) - -(defun gdbsrc-print-csexp (&optional ee) - (interactive) - (or ee (setq ee current-mouse-event)) - (gdb-call-from-src - (concat "print " gdb-print-format (gdbsrc-selection-or-sexp ee)))) - -(defun gdbsrc-*print-csexp (&optional ee) - (interactive) - (or ee (setq ee current-mouse-event)) - (gdb-call-from-src - (concat "print *" gdb-print-format (gdbsrc-selection-or-sexp ee)))) - -;; (defun gdbsrc-print-region (arg) -;; (let (( command (concat "print " gdb-print-format (x-get-cut-buffer)))) -;; (gdb-call-from-src command))) -;; -;; (defun gdbsrc-*print-region (arg) -;; (let (( command (concat "print *" gdb-print-format (x-get-cut-buffer)))) -;; (gdb-call-from-src command))) - -(defun gdbsrc-file:lno () - "returns \"file:lno\" specification for location of point. " - ;; by Stig@hackvan.com - (format "%s:%d" - (file-name-nondirectory buffer-file-name) - (save-restriction - (widen) - (1+ (count-lines (point-min) - (save-excursion (beginning-of-line) (point))))) - )) - -(defun gdbsrc-set-break (ee) - "Sets a breakpoint. Click on the selection and it will set a breakpoint -using the selected text. Click anywhere in a source file, and it will set -a breakpoint at that line number of that file." - ;; by Stig@hackvan.com - ;; there is already gdb-break, so this only needs to work with mouse clicks. - (interactive "e") - (gdb-call-from-src - (concat "break " - (if (click-inside-selection-p ee) - (extent-string primary-selection-extent) - (mouse-set-point ee) - (or buffer-file-name (error "No file in window")) - (gdbsrc-file:lno) - )))) - -(defun gdbsrc-set-tbreak-continue (&optional ee) - "Set a temporary breakpoint at the position of the mouse click and then -continues. This can be bound to either a key or a mouse button." - ;; by Stig@hackvan.com - (interactive) - (or ee (setq ee current-mouse-event)) - (and ee (mouse-set-point ee)) - (gdb-call-from-src (concat "tbreak " (gdbsrc-file:lno))) - (gdb-call-from-src "c")) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Functions extended from gdb.el for gdbsrc. -;; -;; gdbsrc-set-buffer - added a check to set buffer to gdbsrc-associated-buffer -;; to handle multiple gdb sessions being driven from src -;; files. - -(require 'advice) - -(defadvice gdb-set-buffer (after gdbsrc activate) ; () - "Advised to work from a source buffer instead of just the gdb buffer." - ;; by Stig@hackvan.com - ;; the operations below have tests which are disjoint from the tests in - ;; the original `gdb-set-buffer'. Current-gdb-buffer cannot be set twice. - (and gdbsrc-call-p - gdbsrc-associated-buffer - (setq current-gdb-buffer gdbsrc-associated-buffer))) - -(defadvice gdb-display-line (around gdbsrc activate) - ;; (true-file line &optional select-method) - "Advised to select the source buffer instead of the gdb-buffer" - ;; by Stig@hackvan.com - (ad-set-arg 2 'source) ; tell it not to select the gdb window - ad-do-it - (save-excursion - (let* ((buf (extent-object gdb-arrow-extent)) - (win (get-buffer-window buf))) - (setq gdbsrc-last-src-buffer buf) - (select-window win) - (set-window-point win (extent-start-position gdb-arrow-extent)) - (set-buffer buf)) - (and gdbsrc-active-p - (not gdbsrc-mode) - (not (eq (current-buffer) current-gdb-buffer)) - (gdbsrc-mode 1)))) - -(defadvice gdb-filter (after gdbsrc activate) ; (proc string) - ;; by Stig@hackvan.com - ;; if we got a gdb prompt and it wasn't a gdbsrc command, then it's gdb - ;; hitting a breakpoint or having a core dump, so bounce back to the gdb - ;; window. - (let* ((selbuf (window-buffer (selected-window))) - win) - ;; if we're at a gdb prompt, then display the buffer - (and (save-match-data (string-match gdb-prompt-pattern (ad-get-arg 1))) - (prog1 - (not gdbsrc-call-p) - (setq gdbsrc-call-p nil)) - (setq win (display-buffer current-gdb-buffer)) - ;; if we're not in either the source buffer or the gdb buffer, - ;; then select the window too... - (not (eq selbuf current-gdb-buffer)) - (not (eq selbuf gdbsrc-last-src-buffer)) - (progn - (ding nil 'warp) - (select-window win))) - )) - -(defun gdbsrc-reset () - ;; tidy house and turn off gdbsrc-mode in all buffers - ;; by Stig@hackvan.com - (gdb-delete-arrow-extent) - (setq gdbsrc-global-mode nil) - (mapcar #'(lambda (buffer) - (set-buffer buffer) - (cond ((eq gdbsrc-associated-buffer current-gdb-buffer) - (gdbsrc-mode -1)))) - (buffer-list))) - -(defadvice gdb-sentinel (after gdbsrc freeze) ; (proc msg) - ;; by Stig@hackvan.com - (gdbsrc-reset) - (message "Gdbsrc finished")) - -(provide 'gdbsrc)
--- a/lisp/comint/gud.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,3230 +0,0 @@ -;;; gud.el --- Grand Unified Debugger mode for gdb, sdb, dbx, or xdb -;;; under Emacs - -;; Author: Eric S. Raymond <esr@snark.thyrsus.com> -;; Maintainer: FSF -;; Version: 1.3 -;; Keywords: c, unix, tools, debugging - -;; Copyright (C) 1992, 1993 Free Software Foundation, Inc. - -;; 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. - -;;; Commentary: - -;; The ancestral gdb.el was by W. Schelter <wfs@rascal.ics.utexas.edu> -;; It was later rewritten by rms. Some ideas were due to Masanobu. -;; Grand Unification (sdb/dbx support) by Eric S. Raymond <esr@thyrsus.com> -;; The overloading code was then rewritten by Barry Warsaw <bwarsaw@cen.com>, -;; who also hacked the mode to use comint.el. Shane Hartman <shane@spr.com> -;; added support for xdb (HPUX debugger). - -;; Cygnus Support added support for gdb's --annotate=2. - -;;; Code: - -(require 'comint) -(require 'etags) - -;; ====================================================================== -;; GUD commands must be visible in C buffers visited by GUD - -(defvar gud-key-prefix "\C-x\C-a" - "Prefix of all GUD commands valid in C buffers.") - -(global-set-key (concat gud-key-prefix "\C-l") 'gud-refresh) -(global-set-key "\C-x " 'gud-break) ;; backward compatibility hack - -;; ====================================================================== -;; the overloading mechanism - -(defun gud-overload-functions (gud-overload-alist) - "Overload functions defined in GUD-OVERLOAD-ALIST. -This association list has elements of the form - (ORIGINAL-FUNCTION-NAME OVERLOAD-FUNCTION)" - (mapcar - (function (lambda (p) (fset (car p) (symbol-function (cdr p))))) - gud-overload-alist)) - -(defun gud-massage-args (file args) - (error "GUD not properly entered.")) - -(defun gud-marker-filter (str) - (error "GUD not properly entered.")) - -(defun gud-find-file (f) - (error "GUD not properly entered.")) - -;; ====================================================================== -;; command definition - -;; This macro is used below to define some basic debugger interface commands. -;; Of course you may use `gud-def' with any other debugger command, including -;; user defined ones. - -;; A macro call like (gud-def FUNC NAME KEY DOC) expands to a form -;; which defines FUNC to send the command NAME to the debugger, gives -;; it the docstring DOC, and binds that function to KEY in the GUD -;; major mode. The function is also bound in the global keymap with the -;; GUD prefix. - -(defmacro gud-def (func cmd key &optional doc) - "Define FUNC to be a command sending STR and bound to KEY, with -optional doc string DOC. Certain %-escapes in the string arguments -are interpreted specially if present. These are: - - %f name (without directory) of current source file. - %d directory of current source file. - %l number of current source line - %e text of the C lvalue or function-call expression surrounding point. - %a text of the hexadecimal address surrounding point - %p prefix argument to the command (if any) as a number - - The `current' source file is the file of the current buffer (if -we're in a C file) or the source file current at the last break or -step (if we're in the GUD buffer). - The `current' line is that of the current buffer (if we're in a -source file) or the source line number at the last break or step (if -we're in the GUD buffer)." - (list 'progn - (list 'defun func '(arg) - (or doc "") - '(interactive "p") - (list 'gud-call cmd 'arg)) - (if key - (list 'define-key - '(current-local-map) - (concat "\C-c" key) - (list 'quote func))) - (if key - (list 'global-set-key - (list 'concat 'gud-key-prefix key) - (list 'quote func))))) - -;; Where gud-display-frame should put the debugging arrow. This is -;; set by the marker-filter, which scans the debugger's output for -;; indications of the current program counter. -(defvar gud-last-frame nil) - -;; Used by gud-refresh, which should cause gud-display-frame to redisplay -;; the last frame, even if it's been called before and gud-last-frame has -;; been set to nil. -(defvar gud-last-last-frame nil) - -;; All debugger-specific information is collected here. -;; Here's how it works, in case you ever need to add a debugger to the mode. -;; -;; Each entry must define the following at startup: -;; -;;<name> -;; comint-prompt-regexp -;; gud-<name>-massage-args -;; gud-<name>-marker-filter -;; gud-<name>-find-file -;; -;; The job of the massage-args method is to modify the given list of -;; debugger arguments before running the debugger. -;; -;; The job of the marker-filter method is to detect file/line markers in -;; strings and set the global gud-last-frame to indicate what display -;; action (if any) should be triggered by the marker. Note that only -;; whatever the method *returns* is displayed in the buffer; thus, you -;; can filter the debugger's output, interpreting some and passing on -;; the rest. -;; -;; The job of the find-file method is to visit and return the buffer indicated -;; by the car of gud-tag-frame. This may be a file name, a tag name, or -;; something else. - -;; ====================================================================== -;; gdb functions - -;;; History of argument lists passed to gdb. -(defvar gud-gdb-history nil) - -(defun gud-gdb-massage-args (file args) - (cons "--annotate=2" (cons file args))) - - -;; -;; In this world, there are gdb instance objects (of unspecified -;; representation) and buffers associated with those objects. -;; - -;; -;; gdb-instance objects -;; - -(defun make-gdb-instance (proc) - "Create a gdb instance object from a gdb process." - (setq last-proc proc) - (let ((instance (cons 'gdb-instance proc))) - (save-excursion - (set-buffer (process-buffer proc)) - (setq gdb-buffer-instance instance) - (progn - (mapcar 'make-variable-buffer-local gdb-instance-variables) - (setq gdb-buffer-type 'gud) - ;; If we're taking over the buffer of another process, - ;; take over it's ancillery buffers as well. - ;; - (let ((dead (or old-gdb-buffer-instance))) - (mapcar - (function - (lambda (b) - (progn - (set-buffer b) - (if (eq dead gdb-buffer-instance) - (setq gdb-buffer-instance instance))))) - (buffer-list))))) - instance)) - -(defun gdb-instance-process (inst) (cdr inst)) - -;;; The list of instance variables is built up by the expansions of -;;; DEF-GDB-VARIABLE -;;; -(defvar gdb-instance-variables '() - "A list of variables that are local to the gud buffer associated -with a gdb instance.") - -(defmacro def-gdb-variable - (name accessor setter &optional default doc) - (` - (progn - (defvar (, name) (, default) (, (or doc "undocumented"))) - (if (not (memq '(, name) gdb-instance-variables)) - (setq gdb-instance-variables - (cons '(, name) gdb-instance-variables))) - (, (and accessor - (` - (defun (, accessor) (instance) - (let - ((buffer (gdb-get-instance-buffer instance 'gud))) - (and buffer - (save-excursion - (set-buffer buffer) - (, name)))))))) - (, (and setter - (` - (defun (, setter) (instance val) - (let - ((buffer (gdb-get-instance-buffer instance 'gud))) - (and buffer - (save-excursion - (set-buffer buffer) - (setq (, name) val))))))))))) - -(defmacro def-gdb-var (root-symbol &optional default doc) - (let* ((root (symbol-name root-symbol)) - (accessor (intern (concat "gdb-instance-" root))) - (setter (intern (concat "set-gdb-instance-" root))) - (var-name (intern (concat "gdb-" root)))) - (` (def-gdb-variable - (, var-name) (, accessor) (, setter) - (, default) (, doc))))) - -(def-gdb-var buffer-instance nil - "In an instance buffer, the buffer's instance.") - -(def-gdb-var buffer-type nil - "One of the symbols bound in gdb-instance-buffer-rules") - -(def-gdb-var burst "" - "A string of characters from gdb that have not yet been processed.") - -(def-gdb-var input-queue () - "A list of high priority gdb command objects.") - -(def-gdb-var idle-input-queue () - "A list of low priority gdb command objects.") - -(def-gdb-var prompting nil - "True when gdb is idle with no pending input.") - -(def-gdb-var output-sink 'user - "The disposition of the output of the current gdb command. -Possible values are these symbols: - - user -- gdb output should be copied to the gud buffer - for the user to see. - - inferior -- gdb output should be copied to the inferior-io buffer - - pre-emacs -- output should be ignored util the post-prompt - annotation is received. Then the output-sink - becomes:... - emacs -- output should be collected in the partial-output-buffer - for subsequent processing by a command. This is the - disposition of output generated by commands that - gud mode sends to gdb on its own behalf. - post-emacs -- ignore input until the prompt annotation is - received, then go to USER disposition. -") - -(def-gdb-var current-item nil - "The most recent command item sent to gdb.") - -(def-gdb-var pending-triggers '() - "A list of trigger functions that have run later than their output -handlers.") - -(defun in-gdb-instance-context (instance form) - "Funcall `form' in the gud buffer of `instance'" - (save-excursion - (set-buffer (gdb-get-instance-buffer instance 'gud)) - (funcall form))) - -;; end of instance vars - -;; -;; finding instances -;; - -(defun gdb-proc->instance (proc) - (save-excursion - (set-buffer (process-buffer proc)) - gdb-buffer-instance)) - -(defun gdb-mru-instance-buffer () - "Return the most recently used (non-auxiliary) gdb gud buffer." - (save-excursion - (gdb-goto-first-gdb-instance (buffer-list)))) - -(defun gdb-goto-first-gdb-instance (blist) - "Use gdb-mru-instance-buffer -- not this." - (and blist - (progn - (set-buffer (car blist)) - (or (and gdb-buffer-instance - (eq gdb-buffer-type 'gud) - (car blist)) - (gdb-goto-first-gdb-instance (cdr blist)))))) - -(defun buffer-gdb-instance (buf) - (save-excursion - (set-buffer buf) - gdb-buffer-instance)) - -(defun gdb-needed-default-instance () - "Return the most recently used gdb instance or signal an error." - (let ((buffer (gdb-mru-instance-buffer))) - (or (and buffer (buffer-gdb-instance buffer)) - (error "No instance of gdb found.")))) - -(defun gdb-instance-target-string (instance) - "The apparent name of the program being debugged by a gdb instance. -For sure this the root string used in smashing together the gud -buffer's name, even if that doesn't happen to be the name of a -program." - (in-gdb-instance-context - instance - (function (lambda () gud-target-name)))) - - - -;; -;; Instance Buffers. -;; - -;; More than one buffer can be associated with a gdb instance. -;; -;; Each buffer has a TYPE -- a symbol that identifies the function -;; of that particular buffer. -;; -;; The usual gud interaction buffer is given the type `gud' and -;; is constructed specially. -;; -;; Others are constructed by gdb-get-create-instance-buffer and -;; named according to the rules set forth in the gdb-instance-buffer-rules-assoc - -(defun gdb-get-instance-buffer (instance key) - "Return the instance buffer for `instance' tagged with type `key'. -The key should be one of the cars in `gdb-instance-buffer-rules-assoc'." - (save-excursion - (gdb-look-for-tagged-buffer instance key (buffer-list)))) - -(defun gdb-get-create-instance-buffer (instance key) - "Create a new gdb instance buffer of the type specified by `key'. -The key should be one of the cars in `gdb-instance-buffer-rules-assoc'." - (or (gdb-get-instance-buffer instance key) - (let* ((rules (assoc key gdb-instance-buffer-rules-assoc)) - (name (funcall (gdb-rules-name-maker rules) instance)) - (new (get-buffer-create name))) - (save-excursion - (set-buffer new) - (make-variable-buffer-local 'gdb-buffer-type) - (setq gdb-buffer-type key) - (make-variable-buffer-local 'gdb-buffer-instance) - (setq gdb-buffer-instance instance) - (if (cdr (cdr rules)) - (funcall (car (cdr (cdr rules))))) - new)))) - -(defun gdb-rules-name-maker (rules) (car (cdr rules))) - -(defun gdb-look-for-tagged-buffer (instance key bufs) - (let ((retval nil)) - (while (and (not retval) bufs) - (set-buffer (car bufs)) - (if (and (eq gdb-buffer-instance instance) - (eq gdb-buffer-type key)) - (setq retval (car bufs))) - (setq bufs (cdr bufs)) - ) - retval)) - -(defun gdb-instance-buffer-p (buf) - (save-excursion - (set-buffer buf) - (and gdb-buffer-type - (not (eq gdb-buffer-type 'gud))))) - -;; -;; This assoc maps buffer type symbols to rules. Each rule is a list of -;; at least one and possible more functions. The functions have these -;; roles in defining a buffer type: -;; -;; NAME - take an instance, return a name for this type buffer for that -;; instance. -;; The remaining function(s) are optional: -;; -;; MODE - called in the new buffer with no arguments, should establish -;; the proper mode for the buffer. -;; - -(defvar gdb-instance-buffer-rules-assoc '()) - -(defun gdb-set-instance-buffer-rules (buffer-type &rest rules) - (let ((binding (assoc buffer-type gdb-instance-buffer-rules-assoc))) - (if binding - (setcdr binding rules) - (setq gdb-instance-buffer-rules-assoc - (cons (cons buffer-type rules) - gdb-instance-buffer-rules-assoc))))) - -(gdb-set-instance-buffer-rules 'gud 'error) ; gud buffers are an exception to the rules - -;; -;; partial-output buffers -;; -;; These accumulate output from a command executed on -;; behalf of emacs (rather than the user). -;; - -(gdb-set-instance-buffer-rules 'gdb-partial-output-buffer - 'gdb-partial-output-name) - -(defun gdb-partial-output-name (instance) - (concat "*partial-output-" - (gdb-instance-target-string instance) - "*")) - - -(gdb-set-instance-buffer-rules 'gdb-inferior-io - 'gdb-inferior-io-name - 'gud-inferior-io-mode) - -(defun gdb-inferior-io-name (instance) - (concat "*input/output of " - (gdb-instance-target-string instance) - "*")) - -(defvar gdb-inferior-io-mode-map (copy-keymap comint-mode-map)) -(define-key gdb-inferior-io-mode-map "\C-c\C-c" 'gdb-inferior-io-interrupt) -(define-key gdb-inferior-io-mode-map "\C-c\C-z" 'gdb-inferior-io-stop) -(define-key gdb-inferior-io-mode-map "\C-c\C-\\" 'gdb-inferior-io-quit) -(define-key gdb-inferior-io-mode-map "\C-c\C-d" 'gdb-inferior-io-eof) - -(defun gud-inferior-io-mode () - "Major mode for gud inferior-io. - -\\{comint-mode-map}" - ;; We want to use comint because it has various nifty and familiar - ;; features. We don't need a process, but comint wants one, so create - ;; a dummy one. - (make-comint (substring (buffer-name) 1 (- (length (buffer-name)) 1)) - "/bin/cat") - (setq major-mode 'gud-inferior-io-mode) - (setq mode-name "Debuggee I/O") - (setq comint-input-sender 'gud-inferior-io-sender) -) - -(defun gud-inferior-io-sender (proc string) - (save-excursion - (set-buffer (process-buffer proc)) - (let ((instance gdb-buffer-instance)) - (set-buffer (gdb-get-instance-buffer instance 'gud)) - (let ((gud-proc (get-buffer-process (current-buffer)))) - (process-send-string gud-proc string) - (process-send-string gud-proc "\n") - )) - )) - -(defun gdb-inferior-io-interrupt (instance) - "Interrupt the program being debugged." - (interactive (list (gdb-needed-default-instance))) - (interrupt-process - (get-buffer-process (gdb-get-instance-buffer instance 'gud)) comint-ptyp)) - -(defun gdb-inferior-io-quit (instance) - "Send quit signal to the program being debugged." - (interactive (list (gdb-needed-default-instance))) - (quit-process - (get-buffer-process (gdb-get-instance-buffer instance 'gud)) comint-ptyp)) - -(defun gdb-inferior-io-stop (instance) - "Stop the program being debugged." - (interactive (list (gdb-needed-default-instance))) - (stop-process - (get-buffer-process (gdb-get-instance-buffer instance 'gud)) comint-ptyp)) - -(defun gdb-inferior-io-eof (instance) - "Send end-of-file to the program being debugged." - (interactive (list (gdb-needed-default-instance))) - (process-send-eof - (get-buffer-process (gdb-get-instance-buffer instance 'gud)))) - - -;; -;; gdb communications -;; - -;; INPUT: things sent to gdb -;; -;; Each instance has a high and low priority -;; input queue. Low priority input is sent only -;; when the high priority queue is idle. -;; -;; The queues are lists. Each element is either -;; a string (indicating user or user-like input) -;; or a list of the form: -;; -;; (INPUT-STRING HANDLER-FN) -;; -;; -;; The handler function will be called from the -;; partial-output buffer when the command completes. -;; This is the way to write commands which -;; invoke gdb commands autonomously. -;; -;; These lists are consumed tail first. -;; - -(defun gdb-send (proc string) - "A comint send filter for gdb. -This filter may simply queue output for a later time." - (let ((instance (gdb-proc->instance proc))) - (gdb-instance-enqueue-input instance (concat string "\n")))) - -;; Note: Stuff enqueued here will be sent to the next prompt, even if it -;; is a query, or other non-top-level prompt. To guarantee stuff will get -;; sent to the top-level prompt, currently it must be put in the idle queue. -;; ^^^^^^^^^ -;; [This should encourage gud extentions that invoke gdb commands to let -;; the user go first; it is not a bug. -t] -;; - -(defun gdb-instance-enqueue-input (instance item) - (if (gdb-instance-prompting instance) - (progn - (gdb-send-item instance item) - (set-gdb-instance-prompting instance nil)) - (set-gdb-instance-input-queue - instance - (cons item (gdb-instance-input-queue instance))))) - -(defun gdb-instance-dequeue-input (instance) - (let ((queue (gdb-instance-input-queue instance))) - (and queue - (if (not (cdr queue)) - (let ((answer (car queue))) - (set-gdb-instance-input-queue instance '()) - answer) - (gdb-take-last-elt queue))))) - -(defun gdb-instance-enqueue-idle-input (instance item) - (if (and (gdb-instance-prompting instance) - (not (gdb-instance-input-queue instance))) - (progn - (gdb-send-item instance item) - (set-gdb-instance-prompting instance nil)) - (set-gdb-instance-idle-input-queue - instance - (cons item (gdb-instance-idle-input-queue instance))))) - -(defun gdb-instance-dequeue-idle-input (instance) - (let ((queue (gdb-instance-idle-input-queue instance))) - (and queue - (if (not (cdr queue)) - (let ((answer (car queue))) - (set-gdb-instance-idle-input-queue instance '()) - answer) - (gdb-take-last-elt queue))))) - -; Don't use this in general. -(defun gdb-take-last-elt (l) - (if (cdr (cdr l)) - (gdb-take-last-elt (cdr l)) - (let ((answer (car (cdr l)))) - (setcdr l '()) - answer))) - - -;; -;; output -- things gdb prints to emacs -;; -;; GDB output is a stream interrupted by annotations. -;; Annotations can be recognized by their beginning -;; with \C-j\C-z\C-z<tag><opt>\C-j -;; -;; The tag is a string obeying symbol syntax. -;; -;; The optional part `<opt>' can be either the empty string -;; or a space followed by more data relating to the annotation. -;; For example, the SOURCE annotation is followed by a filename, -;; line number and various useless goo. This data must not include -;; any newlines. -;; - - -(defun gud-gdb-marker-filter (string) - "A gud marker filter for gdb." - ;; Bogons don't tell us the process except through scoping crud. - (let ((instance (gdb-proc->instance proc))) - (gdb-output-burst instance string))) - -(defvar gdb-annotation-rules - '(("frames-invalid" gdb-invalidate-frames) - ("breakpoints-invalid" gdb-invalidate-breakpoints) - ("pre-prompt" gdb-pre-prompt) - ("prompt" gdb-prompt) - ("commands" gdb-subprompt) - ("overload-choice" gdb-subprompt) - ("query" gdb-subprompt) - ("prompt-for-continue" gdb-subprompt) - ("post-prompt" gdb-post-prompt) - ("source" gdb-source) - ("starting" gdb-starting) - ("exited" gdb-stopping) - ("signalled" gdb-stopping) - ("signal" gdb-stopping) - ("breakpoint" gdb-stopping) - ("watchpoint" gdb-stopping) - ("stopped" gdb-stopped) - ("display-begin" gdb-display-begin) - ("display-end" gdb-display-end) - ("error-begin" gdb-error-begin) - ) - "An assoc mapping annotation tags to functions which process them.") - - -(defun gdb-ignore-annotation (instance args) - nil) - -(defconst gdb-source-spec-regexp - "\\(.*\\):\\([0-9]*\\):[0-9]*:[a-z]*:0x[a-f0-9]*") - -;; Do not use this except as an annotation handler." -(defun gdb-source (instance args) - (string-match gdb-source-spec-regexp args) - ;; Extract the frame position from the marker. - (setq gud-last-frame - (cons - (substring args (match-beginning 1) (match-end 1)) - (string-to-int (substring args - (match-beginning 2) - (match-end 2)))))) - -;; An annotation handler for `prompt'. -;; This sends the next command (if any) to gdb. -(defun gdb-prompt (instance ignored) - (let ((sink (gdb-instance-output-sink instance))) - (cond - ((eq sink 'user) t) - ((eq sink 'post-emacs) - (set-gdb-instance-output-sink instance 'user)) - (t - (set-gdb-instance-output-sink instance 'user) - (error "Phase error in gdb-prompt (got %s)" sink)))) - (let ((highest (gdb-instance-dequeue-input instance))) - (if highest - (gdb-send-item instance highest) - (let ((lowest (gdb-instance-dequeue-idle-input instance))) - (if lowest - (gdb-send-item instance lowest) - (progn - (set-gdb-instance-prompting instance t) - (gud-display-frame))))))) - -;; An annotation handler for non-top-level prompts. -(defun gdb-subprompt (instance ignored) - (let ((highest (gdb-instance-dequeue-input instance))) - (if highest - (gdb-send-item instance highest) - (set-gdb-instance-prompting instance t)))) - -(defun gdb-send-item (instance item) - (set-gdb-instance-current-item instance item) - (if (stringp item) - (progn - (set-gdb-instance-output-sink instance 'user) - (process-send-string (gdb-instance-process instance) - item)) - (progn - (gdb-clear-partial-output instance) - (set-gdb-instance-output-sink instance 'pre-emacs) - (process-send-string (gdb-instance-process instance) - (car item))))) - -;; This terminates the collection of output from a previous -;; command if that happens to be in effect. -(defun gdb-pre-prompt (instance ignored) - (let ((sink (gdb-instance-output-sink instance))) - (cond - ((eq sink 'user) t) - ((eq sink 'emacs) - (set-gdb-instance-output-sink instance 'post-emacs) - (let ((handler - (car (cdr (gdb-instance-current-item instance))))) - (save-excursion - (set-buffer (gdb-get-create-instance-buffer - instance 'gdb-partial-output-buffer)) - (funcall handler)))) - (t - (set-gdb-instance-output-sink instance 'user) - (error "Output sink phase error 1."))))) - -;; An annotation handler for `starting'. This says that I/O for the subprocess -;; is now the program being debugged, not GDB. -(defun gdb-starting (instance ignored) - (let ((sink (gdb-instance-output-sink instance))) - (cond - ((eq sink 'user) - (set-gdb-instance-output-sink instance 'inferior) - ;; FIXME: need to send queued input - ) - (t (error "Unexpected `starting' annotation"))))) - -;; An annotation handler for `exited' and other annotations which say that -;; I/O for the subprocess is now GDB, not the program being debugged. -(defun gdb-stopping (instance ignored) - (let ((sink (gdb-instance-output-sink instance))) - (cond - ((eq sink 'inferior) - (set-gdb-instance-output-sink instance 'user) - ) - (t (error "Unexpected stopping annotation"))))) - -;; An annotation handler for `stopped'. It is just like gdb-stopping, except -;; that if we already set the output sink to 'user in gdb-stopping, that is -;; fine. -(defun gdb-stopped (instance ignored) - (let ((sink (gdb-instance-output-sink instance))) - (cond - ((eq sink 'inferior) - (set-gdb-instance-output-sink instance 'user) - ) - ((eq sink 'user) - t) - (t (error "Unexpected stopping annotation"))))) - -;; An annotation handler for `post-prompt'. -;; This begins the collection of output from the current -;; command if that happens to be appropriate." -(defun gdb-post-prompt (instance ignored) - (if (not (gdb-instance-pending-triggers instance)) - (progn - (gdb-invalidate-registers instance ignored) - (gdb-invalidate-locals instance ignored) - (gdb-invalidate-display instance ignored))) - (let ((sink (gdb-instance-output-sink instance))) - (cond - ((eq sink 'user) t) - ((eq sink 'pre-emacs) - (set-gdb-instance-output-sink instance 'emacs)) - - (t - (set-gdb-instance-output-sink instance 'user) - (error "Output sink phase error 3."))))) - -;; Handle a burst of output from a gdb instance. -;; This function is (indirectly) used as a gud-marker-filter. -;; It must return output (if any) to be insterted in the gud -;; buffer. - -(defun gdb-output-burst (instance string) - "Handle a burst of output from a gdb instance. -This function is (indirectly) used as a gud-marker-filter. -It must return output (if any) to be insterted in the gud -buffer." - - (save-match-data - (let ( - ;; Recall the left over burst from last time - (burst (concat (gdb-instance-burst instance) string)) - ;; Start accumulating output for the gud buffer - (output "")) - - ;; Process all the complete markers in this chunk. - - (while (string-match "\n\032\032\\(.*\\)\n" burst) - (let ((annotation (substring burst - (match-beginning 1) - (match-end 1)))) - - ;; Stuff prior to the match is just ordinary output. - ;; It is either concatenated to OUTPUT or directed - ;; elsewhere. - (setq output - (gdb-concat-output - instance - output - (substring burst 0 (match-beginning 0)))) - - ;; Take that stuff off the burst. - (setq burst (substring burst (match-end 0))) - - ;; Parse the tag from the annotation, and maybe its arguments. - (string-match "\\(\\S-*\\) ?\\(.*\\)" annotation) - (let* ((annotation-type (substring annotation - (match-beginning 1) - (match-end 1))) - (annotation-arguments (substring annotation - (match-beginning 2) - (match-end 2))) - (annotation-rule (assoc annotation-type - gdb-annotation-rules))) - ;; Call the handler for this annotation. - (if annotation-rule - (funcall (car (cdr annotation-rule)) - instance - annotation-arguments) - ;; Else the annotation is not recognized. Ignore it silently, - ;; so that GDB can add new annotations without causing - ;; us to blow up. - )))) - - - ;; Does the remaining text end in a partial line? - ;; If it does, then keep part of the burst until we get more. - (if (string-match "\n\\'\\|\n\032\\'\\|\n\032\032.*\\'" - burst) - (progn - ;; Everything before the potential marker start can be output. - (setq output - (gdb-concat-output - instance - output - (substring burst 0 (match-beginning 0)))) - - ;; Everything after, we save, to combine with later input. - (setq burst (substring burst (match-beginning 0)))) - - ;; In case we know the burst contains no partial annotations: - (progn - (setq output (gdb-concat-output instance output burst)) - (setq burst ""))) - - ;; Save the remaining burst for the next call to this function. - (set-gdb-instance-burst instance burst) - output))) - -(defun gdb-concat-output (instance so-far new) - (let ((sink (gdb-instance-output-sink instance))) - (cond - ((eq sink 'user) (concat so-far new)) - ((or (eq sink 'pre-emacs) (eq sink 'post-emacs)) so-far) - ((eq sink 'emacs) - (gdb-append-to-partial-output instance new) - so-far) - ((eq sink 'inferior) - (gdb-append-to-inferior-io instance new) - so-far) - (t (error "Bogon output sink %S" sink))))) - -(defun gdb-append-to-partial-output (instance string) - (save-excursion - (buffer-disable-undo ; Don't need undo in partial output buffer - (set-buffer - (gdb-get-create-instance-buffer - instance 'gdb-partial-output-buffer))) - (goto-char (point-max)) - (insert string))) - -(defun gdb-clear-partial-output (instance) - (save-excursion - (set-buffer - (gdb-get-create-instance-buffer - instance 'gdb-partial-output-buffer)) - (delete-region (point-min) (point-max)))) - -(defun gdb-append-to-inferior-io (instance string) - (save-excursion - (set-buffer - (gdb-get-create-instance-buffer - instance 'gdb-inferior-io)) - (goto-char (point-max)) - (insert-before-markers string)) - (gud-display-buffer - (gdb-get-create-instance-buffer instance - 'gdb-inferior-io))) - -(defun gdb-clear-inferior-io (instance) - (save-excursion - (set-buffer - (gdb-get-create-instance-buffer - instance 'gdb-inferior-io)) - (delete-region (point-min) (point-max)))) - - - -;; One trick is to have a command who's output is always available in -;; a buffer of it's own, and is always up to date. We build several -;; buffers of this type. -;; -;; There are two aspects to this: gdb has to tell us when the output -;; for that command might have changed, and we have to be able to run -;; the command behind the user's back. -;; -;; The idle input queue and the output phasing associated with -;; the instance variable `(gdb-instance-output-sink instance)' help -;; us to run commands behind the user's back. -;; -;; Below is the code for specificly managing buffers of output from one -;; command. -;; - - -;; The trigger function is suitable for use in the assoc GDB-ANNOTATION-RULES -;; It adds an idle input for the command we are tracking. It should be the -;; annotation rule binding of whatever gdb sends to tell us this command -;; might have changed it's output. -;; -;; NAME is the function name. DEMAND-PREDICATE tests if output is really needed. -;; GDB-COMMAND is a string of such. OUTPUT-HANDLER is the function bound to the -;; input in the input queue (see comment about ``gdb communications'' above). -(defmacro def-gdb-auto-update-trigger (name demand-predicate gdb-command output-handler) - (` - (defun (, name) (instance &optional ignored) - (if (and ((, demand-predicate) instance) - (not (member '(, name) - (gdb-instance-pending-triggers instance)))) - (progn - (gdb-instance-enqueue-idle-input - instance - (list (, gdb-command) '(, output-handler))) - (set-gdb-instance-pending-triggers - instance - (cons '(, name) - (gdb-instance-pending-triggers instance)))) )))) - -(defmacro def-gdb-auto-update-handler (name trigger buf-key) - (` - (defun (, name) () - (set-gdb-instance-pending-triggers - instance - (delq '(, trigger) - (gdb-instance-pending-triggers instance))) - (let ((buf (gdb-get-instance-buffer instance - '(, buf-key)))) - (and buf - (save-excursion - (set-buffer buf) - (buffer-disable-undo buf) ; don't need undo - (let ((p (point)) - (buffer-read-only nil) - (instance-buf (gdb-get-create-instance-buffer - instance - 'gdb-partial-output-buffer))) - (if (gud-buffers-differ buf instance-buf) - (progn - (delete-region (point-min) (point-max)) - (insert-buffer instance-buf) - (if (buffer-dedicated-frame) - (fit-frame-to-buffer (buffer-dedicated-frame) buf)) - )) - (goto-char p)))))))) - -(defmacro def-gdb-auto-updated-buffer - (buffer-key trigger-name gdb-command output-handler-name) - (` - (progn - (def-gdb-auto-update-trigger (, trigger-name) - ;; The demand predicate: - (lambda (instance) - (gdb-get-instance-buffer instance '(, buffer-key))) - (, gdb-command) - (, output-handler-name)) - (def-gdb-auto-update-handler (, output-handler-name) - (, trigger-name) (, buffer-key))))) - - -;; -;; Breakpoint buffers -;; -;; These display the output of `info breakpoints'. -;; - - -(gdb-set-instance-buffer-rules 'gdb-breakpoints-buffer - 'gdb-breakpoints-buffer-name - 'gud-breakpoints-mode) - -(def-gdb-auto-updated-buffer gdb-breakpoints-buffer - ;; This defines the auto update rule for buffers of type - ;; `gdb-breakpoints-buffer'. - ;; - ;; It defines a function to serve as the annotation handler that - ;; handles the `foo-invalidated' message. That function is called: - gdb-invalidate-breakpoints - - ;; To update the buffer, this command is sent to gdb. - "server info breakpoints\n" - - ;; This also defines a function to be the handler for the output - ;; from the command above. That function will copy the output into - ;; the appropriately typed buffer. That function will be called: - gdb-info-breakpoints-handler) - -(defun gdb-breakpoints-buffer-name (instance) - (save-excursion - (set-buffer (process-buffer (gdb-instance-process instance))) - (concat "*breakpoints of " (gdb-instance-target-string instance) "*"))) - -(defun gud-display-breakpoints-buffer (instance) - (interactive (list (gdb-needed-default-instance))) - (gud-display-buffer - (gdb-get-create-instance-buffer instance - 'gdb-breakpoints-buffer))) - -(defun gud-frame-breakpoints-buffer (instance) - (interactive (list (gdb-needed-default-instance))) - (gud-display-buffer-new-frame - (gdb-get-create-instance-buffer instance - 'gdb-breakpoints-buffer))) - -(defvar gud-breakpoints-mode-map nil) -(defvar gud-breakpoints-mode-menu - '("GDB Breakpoint Commands" - "----" - ["Toggle" gud-toggle-bp-this-line t] - ["Delete" gud-delete-bp-this-line t] - ["Condition" gud-bp-condition t] - ["Ignore" gud-bp-ignore t]) - "*menu for gud-breakpoints-mode") - -(setq gud-breakpoints-mode-map (make-keymap)) -(suppress-keymap gud-breakpoints-mode-map) -(define-key gud-breakpoints-mode-map " " 'gud-toggle-bp-this-line) -(define-key gud-breakpoints-mode-map "d" 'gud-delete-bp-this-line) -(define-key gud-breakpoints-mode-map "c" 'gud-bp-condition) -(define-key gud-breakpoints-mode-map "i" 'gud-bp-ignore) -(define-key gud-breakpoints-mode-map 'button3 'gud-breakpoints-popup-menu) -(defun gud-breakpoints-mode () - "Major mode for gud breakpoints. - -\\{gud-breakpoints-mode-map}" - (setq major-mode 'gud-breakpoints-mode) - (setq mode-name "Breakpoints") - (use-local-map gud-breakpoints-mode-map) - (setq buffer-read-only t) - (require 'mode-motion) - (setq mode-motion-hook 'gud-breakpoints-mode-motion-hook) - (gdb-invalidate-breakpoints gdb-buffer-instance)) - -(defun gud-toggle-bp-this-line () - (interactive) - (save-excursion - (set-buffer - (gdb-get-instance-buffer gdb-buffer-instance 'gdb-breakpoints-buffer)) - (if (key-press-event-p last-input-event) - (beginning-of-line 1) - (and mode-motion-extent (extent-buffer mode-motion-extent) - (goto-char (extent-start-position mode-motion-extent)))) - (if (not (looking-at "\\([0-9]*\\)\\s-*\\S-*\\s-*\\S-*\\s-*\\(.\\)")) - (error "Not recognized as breakpoint line (demo foo).") - (gdb-instance-enqueue-idle-input - gdb-buffer-instance - (list - (concat - (if (eq ?y (char-after (match-beginning 2))) - "server disable " - "server enable ") - (buffer-substring (match-beginning 0) - (match-end 1)) - "\n") - '(lambda () nil))) - ))) - -(defun gud-delete-bp-this-line () - (interactive) - (save-excursion - (set-buffer - (gdb-get-instance-buffer gdb-buffer-instance 'gdb-breakpoints-buffer)) - (if (key-press-event-p last-input-event) - (beginning-of-line 1) - (and mode-motion-extent (extent-buffer mode-motion-extent) - (goto-char (extent-start-position mode-motion-extent)))) - (if (not (looking-at "\\([0-9]*\\)\\s-*\\S-*\\s-*\\S-*\\s-*\\(.\\)")) - (error "Not recognized as breakpoint line (demo foo).") - (gdb-instance-enqueue-idle-input - gdb-buffer-instance - (list - (concat - "server delete " - (buffer-substring (match-beginning 0) - (match-end 1)) - "\n") - '(lambda () nil))) - ))) - -(defun gud-bp-condition (condition) - (interactive "sCondition for breakpoint: ") - (save-excursion - (set-buffer - (gdb-get-instance-buffer gdb-buffer-instance 'gdb-breakpoints-buffer)) - (if (key-press-event-p last-input-event) - (beginning-of-line 1) - (and mode-motion-extent (extent-buffer mode-motion-extent) - (goto-char (extent-start-position mode-motion-extent)))) - (if (not (looking-at "\\([0-9]*\\)\\s-*\\S-*\\s-*\\S-*\\s-*\\(.\\)")) - (error "Not recognized as breakpoint line (demo foo).") - (gdb-instance-enqueue-idle-input - gdb-buffer-instance - (list - (concat - "server condition " - (buffer-substring (match-beginning 0) - (match-end 1)) - (if (> (length condition) 0) (concat " " condition) "") - "\n") - '(lambda () nil))) - (gdb-invalidate-breakpoints gdb-buffer-instance) - ))) - -(defun gud-bp-ignore (count) - (interactive "nNumber of times to ignore breakpoint: ") - (save-excursion - (set-buffer - (gdb-get-instance-buffer gdb-buffer-instance 'gdb-breakpoints-buffer)) - (if (key-press-event-p last-input-event) - (beginning-of-line 1) - (and mode-motion-extent (extent-buffer mode-motion-extent) - (goto-char (extent-start-position mode-motion-extent)))) - (if (not (looking-at "\\([0-9]*\\)\\s-*\\S-*\\s-*\\S-*\\s-*\\(.\\)")) - (error "Not recognized as breakpoint line (demo foo).") - (gdb-instance-enqueue-idle-input - gdb-buffer-instance - (list - (concat - "server ignore " - (buffer-substring (match-beginning 0) - (match-end 1)) - " " - (int-to-string count) - "\n") - '(lambda () nil))) - (gdb-invalidate-breakpoints gdb-buffer-instance) - ))) - -(defun gud-breakpoints-mode-motion-hook (event) - (gud-breakpoints-mode-motion-internal event "^[0-9]+[ \t]")) - -(defun gud-breakpoints-mode-motion-internal (event regexp) - ;; - ;; This is mostly ripped off from mode-motion-highlight-internal but - ;; we set the extent's face rather than setting it to highlight. That - ;; way if we're somewhere in the breakpoint's list of commands or other - ;; info we still highlight it. - (if (event-buffer event) - (let* ((buffer (event-buffer event)) - point) - (save-excursion - (set-buffer buffer) - (mouse-set-point event) - (beginning-of-line) - (if (not (looking-at regexp)) - (re-search-backward regexp (point-min) 't)) - (setq point (point)) - (if (looking-at regexp) - (end-of-line)) - (if (and mode-motion-extent (extent-buffer mode-motion-extent)) - (if (eq point (point)) - (delete-extent mode-motion-extent) - (set-extent-endpoints mode-motion-extent point (point))) - (if (eq point (point)) - nil - (setq mode-motion-extent (make-extent point (point))) - (set-extent-property mode-motion-extent 'face - (get-face 'highlight))))) - ))) - -(defun gud-breakpoints-popup-menu (event) - (interactive "@e") - (mouse-set-point event) - (popup-menu gud-breakpoints-mode-menu)) - -;; -;; Display expression buffers -;; -;; These show the current list of expressions which the debugger -;; prints when the inferior stops and their values. Note that there -;; isn't a "display-invalid" annotation so we have to a bit more -;; work than for the other auto-update buffers -;; - -(gdb-set-instance-buffer-rules 'gdb-display-buffer - 'gdb-display-buffer-name - 'gud-display-mode) - - -(def-gdb-auto-updated-buffer gdb-display-buffer - ;; This defines the auto update rule for buffers of type - ;; `gdb-display-buffer'. - ;; - ;; It defines a function to serve as the annotation handler that - ;; handles the `foo-invalidated' message. That function is called: - gdb-invalidate-display - - ;; To update the buffer, this command is sent to gdb. - "server info display\n" - - ;; This also defines a function to be the handler for the output - ;; from the command above. That function will copy the output into - ;; the appropriately typed buffer. That function will be called: - gdb-info-display-handler) - - -;; Since the displayed expressions buffer is not simply a copy of what gdb -;; prints for the "info display" command we need a slightly more complex -;; handler for it than the standard one which def-gdb-auto-updated-buffer -;; defines. - -(defun gdb-info-display-handler () - - (set-gdb-instance-pending-triggers - instance (delq 'gdb-invalidate-display - (gdb-instance-pending-triggers instance))) - - (let ((buf (gdb-get-instance-buffer instance 'gdb-display-buffer))) - (and buf - (save-excursion - (let ((instance-buf (gdb-get-create-instance-buffer - instance 'gdb-partial-output-buffer)) - expr-alist point expr highlight-expr) - (set-buffer instance-buf) - (goto-char (point-min)) - (while - (re-search-forward "^\\([0-9]+\\): \\([ny] .*$\\)" (point-max) t) - (setq expr-alist - (cons - (cons (buffer-substring (match-beginning 1) (match-end 1)) - (buffer-substring (match-beginning 2) (match-end 2))) - expr-alist))) - (set-buffer buf) - (setq buffer-read-only nil) - (if (and mode-motion-extent - (extent-buffer mode-motion-extent) - (extent-start-position mode-motion-extent)) - (progn - (goto-char (extent-start-position mode-motion-extent)) - (if (looking-at "^[0-9]+:") - (setq highlight-expr (buffer-substring (match-beginning 0) (match-end 0)))))) - (goto-char (point-min)) - (delete-region (point-min) - (if (not (re-search-forward "^\\([0-9]+\\): " (point-max) t)) - (point-max) - (beginning-of-line) - (point))) - (if (not expr-alist) - (progn - (insert "There are no auto-display expressions now.\n") - (delete-region (point) (point-max))) - (insert "Auto-display expressions now in effect: -Num Enb Expression = value\n") - (while - (re-search-forward "^\\([0-9]+\\): \\([ny]\\)" (point-max) t) - (if (setq expr (assoc (buffer-substring (match-beginning 1) (match-end 1)) - expr-alist)) - (progn - (if (string-equal (substring (cdr expr) 0 1) "y") - (replace-match "\\1: y") - (replace-match (format "\\1: %s" (cdr expr))) - (setq point (point)) - (if (re-search-forward "^[0-9]+: " (point-max) 'move) - (beginning-of-line)) - (delete-region point (if (eobp) (point) (1- (point))))) - (setq expr-alist (delq expr expr-alist))) - (beginning-of-line) - (setq point (point)) - (if (re-search-forward "^[0-9]+: " (point-max) 'move 2) - (beginning-of-line)) - (delete-region point (point)))) - (goto-char (point-max)) - (while expr-alist - (insert (concat (car (car expr-alist)) ": " - (cdr (car expr-alist)) "\n" )) - (setq expr-alist (cdr expr-alist))) ) - (goto-char (point-min)) - (if (and mode-motion-extent - (extent-buffer mode-motion-extent) - highlight-expr - (re-search-forward (concat "^" highlight-expr ".*$") (point-max) t)) - (set-extent-endpoints mode-motion-extent (match-beginning 0) (match-end 0))) - (setq buffer-read-only t) - (if (buffer-dedicated-frame) - (fit-frame-to-buffer (buffer-dedicated-frame) buf)) - ))))) - -(defvar gud-display-mode-map nil) -(setq gud-display-mode-map (make-keymap)) -(suppress-keymap gud-display-mode-map) - -(defvar gud-display-mode-menu - '("GDB Display Commands" - "----" - ["Toggle enable" gud-toggle-disp-this-line t] - ["Delete" gud-delete-disp-this-line t]) - "*menu for gud-display-mode") - -(define-key gud-display-mode-map " " 'gud-toggle-disp-this-line) -(define-key gud-display-mode-map "d" 'gud-delete-disp-this-line) -(define-key gud-display-mode-map 'button3 'gud-display-popup-menu) - -(defun gud-display-mode () - "Major mode for gud display. - -\\{gud-display-mode-map}" - (setq major-mode 'gud-display-mode) - (setq mode-name "Display") - (setq buffer-read-only t) - (use-local-map gud-display-mode-map) - (require 'mode-motion) - (setq mode-motion-hook 'gud-display-mode-motion-hook) - (gdb-invalidate-display gdb-buffer-instance) - ) - -(defun gdb-display-buffer-name (instance) - (save-excursion - (set-buffer (process-buffer (gdb-instance-process instance))) - (concat "*Displayed expressions of " (gdb-instance-target-string instance) "*"))) - -(defun gud-display-display-buffer (instance) - (interactive (list (gdb-needed-default-instance))) - (let ((buf (gdb-get-create-instance-buffer instance - 'gdb-display-buffer))) - (gdb-invalidate-display instance) - (gud-display-buffer buf))) - - -(defun gud-frame-display-buffer (instance) - (interactive (list (gdb-needed-default-instance))) - (let ((buf (gdb-get-create-instance-buffer instance - 'gdb-display-buffer))) - (gdb-invalidate-display instance) - (gud-display-buffer-new-frame buf))) - -(defun gud-toggle-disp-this-line () - (interactive) - (save-excursion - (set-buffer - (gdb-get-instance-buffer gdb-buffer-instance 'gdb-display-buffer)) - (if (key-press-event-p last-input-event) - (beginning-of-line 1) - (and mode-motion-extent (extent-buffer mode-motion-extent) - (goto-char (extent-start-position mode-motion-extent)))) - (if (not (looking-at "\\([0-9]+\\): \\([ny]\\)")) - (error "No expression on this line.") - (gdb-instance-enqueue-idle-input - gdb-buffer-instance - (list - (concat - (if (eq ?y (char-after (match-beginning 2))) - "server disable display " - "server enable display ") - (buffer-substring (match-beginning 0) - (match-end 1)) - "\n") - '(lambda () nil))) - ))) - -(defun gud-delete-disp-this-line () - (interactive) - (save-excursion - (set-buffer - (gdb-get-instance-buffer gdb-buffer-instance 'gdb-display-buffer)) - (if (key-press-event-p last-input-event) - (beginning-of-line 1) - (and mode-motion-extent (extent-buffer mode-motion-extent) - (goto-char (extent-start-position mode-motion-extent)))) - (if (not (looking-at "\\([0-9]+\\): \\([ny]\\)")) - (error "No expression on this line.") - (gdb-instance-enqueue-idle-input - gdb-buffer-instance - (list - (concat - "server delete display " - (buffer-substring (match-beginning 0) - (match-end 1)) - "\n") - '(lambda () nil))) - ))) - -(defun gud-display-mode-motion-hook (event) - (gud-breakpoints-mode-motion-internal event "^[0-9]+: ")) - -(defun gud-display-popup-menu (event) - (interactive "@e") - (mouse-set-point event) - (popup-menu gud-display-mode-menu)) - -;; If we get an error whilst evaluating one of the expressions -;; we won't get the display-end annotation. Set the sink back to -;; user to make sure that the error message is seen - -(defun gdb-error-begin (instance ignored) - (set-gdb-instance-output-sink instance 'user)) - -(defun gdb-display-begin (instance ignored) - (if (gdb-get-instance-buffer instance 'gdb-display-buffer) - (progn - (set-gdb-instance-output-sink instance 'emacs) - (gdb-clear-partial-output instance)) - (set-gdb-instance-output-sink instance 'user)) - ) - -(defun gdb-display-end (instance ignored) - (save-excursion - (let ((display-output (gdb-get-instance-buffer instance 'gdb-display-buffer)) - display-index - display-value - highlight-expr) - (if display-output - (progn - (set-buffer (gdb-get-instance-buffer - instance 'gdb-partial-output-buffer)) - (goto-char (point-min)) - (looking-at "\\([0-9]+\\): ") - (setq display-index (buffer-substring (match-beginning 1) - (match-end 1))) - (setq display-value (+ 2 (match-end 1))) - (set-buffer display-output) - (if (and mode-motion-extent - (extent-buffer mode-motion-extent) - (extent-start-position mode-motion-extent)) - (progn - (goto-char (extent-start-position mode-motion-extent)) - (if (looking-at "^[0-9]+:") - (setq highlight-expr (buffer-substring (match-beginning 0) (match-end 0)))))) - (setq buffer-read-only nil) - (goto-char (point-min)) - (if (not (re-search-forward (concat "^" display-index ": [ny] ") - (point-max) 'move)) - (insert (format "%s: y " display-index)) - (goto-char (match-end 0)) - (if (save-match-data - (re-search-forward "^[0-9]+: " (point-max) 'move)) - (beginning-of-line)) - (delete-region (match-end 0) (point))) - (insert-buffer-substring (gdb-get-instance-buffer - instance 'gdb-partial-output-buffer) - display-value) - (goto-char (point-min)) - (if (and mode-motion-extent - (extent-buffer mode-motion-extent) - highlight-expr - (re-search-forward (concat "^" highlight-expr ".*$") (point-max) t)) - (set-extent-endpoints mode-motion-extent (match-beginning 0) (match-end 0))) - (setq buffer-read-only t) - ))) - (gdb-clear-partial-output instance) - (set-gdb-instance-output-sink instance 'user) - )) - - -;; -;; Frames buffers. These display a perpetually correct bactracktrace -;; (from the command `where'). -;; -;; Alas, if your stack is deep, they are costly. -;; - -(gdb-set-instance-buffer-rules 'gdb-stack-buffer - 'gdb-stack-buffer-name - 'gud-frames-mode) - -(def-gdb-auto-updated-buffer gdb-stack-buffer - gdb-invalidate-frames - "server where\n" - gdb-info-frames-handler) - -(defun gdb-stack-buffer-name (instance) - (save-excursion - (set-buffer (process-buffer (gdb-instance-process instance))) - (concat "*stack frames of " - (gdb-instance-target-string instance) "*"))) - -(defun gud-display-stack-buffer (instance) - (interactive (list (gdb-needed-default-instance))) - (gud-display-buffer - (gdb-get-create-instance-buffer instance - 'gdb-stack-buffer))) - -(defun gud-frame-stack-buffer (instance) - (interactive (list (gdb-needed-default-instance))) - (gud-display-buffer-new-frame - (gdb-get-create-instance-buffer instance - 'gdb-stack-buffer))) - -(defvar gud-frames-mode-map nil) -(setq gud-frames-mode-map (make-keymap)) -(suppress-keymap gud-frames-mode-map) - -;;; XEmacs change -;(define-key gud-frames-mode-map [mouse-2] -; 'gud-frames-select-by-mouse) - -(define-key gud-frames-mode-map [button2] - 'gud-frames-select-by-mouse) - - -(defun gud-frames-mode () - "Major mode for gud frames. - -\\{gud-frames-mode-map}" - (setq major-mode 'gud-frames-mode) - (setq mode-name "Frames") - (setq buffer-read-only t) - (use-local-map gud-frames-mode-map) - (gdb-invalidate-frames gdb-buffer-instance)) - -(defun gud-get-frame-number () - (save-excursion - (let* ((pos (re-search-backward "^#\\([0-9]*\\)" nil t)) - (n (or (and pos - (string-to-int - (buffer-substring (match-beginning 1) - (match-end 1)))) - 0))) - n))) - -(defun gud-frames-select-by-mouse (e) - (interactive "e") - (let (selection) - (save-excursion - (set-buffer (window-buffer (posn-window (event-end e)))) - (save-excursion - (goto-char (posn-point (event-end e))) - (setq selection (gud-get-frame-number)))) - (select-window (posn-window (event-end e))) - (save-excursion - (set-buffer (gdb-get-instance-buffer (gdb-needed-default-instance) 'gud)) - (gud-call "fr %p" selection) - (gud-display-frame)))) - - -;; -;; Registers buffers -;; - -(def-gdb-auto-updated-buffer gdb-registers-buffer - gdb-invalidate-registers - "server info registers\n" - gdb-info-registers-handler) - -(gdb-set-instance-buffer-rules 'gdb-registers-buffer - 'gdb-registers-buffer-name - 'gud-registers-mode) - -(defvar gud-registers-mode-map nil) -(setq gud-registers-mode-map (make-keymap)) -(suppress-keymap gud-registers-mode-map) - -(defun gud-registers-mode () - "Major mode for gud registers. - -\\{gud-registers-mode-map}" - (setq major-mode 'gud-registers-mode) - (setq mode-name "Registers") - (setq buffer-read-only t) - (use-local-map gud-registers-mode-map) - (gdb-invalidate-registers gdb-buffer-instance)) - -(defun gdb-registers-buffer-name (instance) - (save-excursion - (set-buffer (process-buffer (gdb-instance-process instance))) - (concat "*registers of " (gdb-instance-target-string instance) "*"))) - -(defun gud-display-registers-buffer (instance) - (interactive (list (gdb-needed-default-instance))) - (gud-display-buffer - (gdb-get-create-instance-buffer instance - 'gdb-registers-buffer))) - -(defun gud-frame-registers-buffer (instance) - (interactive (list (gdb-needed-default-instance))) - (gud-display-buffer-new-frame - (gdb-get-create-instance-buffer instance - 'gdb-registers-buffer))) - -;; -;; Locals buffers -;; - -(def-gdb-auto-updated-buffer gdb-locals-buffer - gdb-invalidate-locals - "server info locals\n" - gdb-info-locals-handler) - -(gdb-set-instance-buffer-rules 'gdb-locals-buffer - 'gdb-locals-buffer-name - 'gud-locals-mode) - -(defvar gud-locals-mode-map nil) -(setq gud-locals-mode-map (make-keymap)) -(suppress-keymap gud-locals-mode-map) - -(defun gud-locals-mode () - "Major mode for gud locals. - -\\{gud-locals-mode-map}" - (setq major-mode 'gud-locals-mode) - (setq mode-name "Locals") - (setq buffer-read-only t) - (use-local-map gud-locals-mode-map) - (gdb-invalidate-locals gdb-buffer-instance)) - -(defun gdb-locals-buffer-name (instance) - (save-excursion - (set-buffer (process-buffer (gdb-instance-process instance))) - (concat "*locals of " (gdb-instance-target-string instance) "*"))) - -(defun gud-display-locals-buffer (instance) - (interactive (list (gdb-needed-default-instance))) - (gud-display-buffer - (gdb-get-create-instance-buffer instance - 'gdb-locals-buffer))) - -(defun gud-frame-locals-buffer (instance) - (interactive (list (gdb-needed-default-instance))) - (gud-display-buffer-new-frame - (gdb-get-create-instance-buffer instance - 'gdb-locals-buffer))) - - -;;;; -;;;; Put a friendly face on the GDB on-line help. -;;;; - -;; Keymap for extents in the help buffer -(setq gdb-help-extent-map (make-keymap)) -(suppress-keymap gdb-help-extent-map) -(define-key gdb-help-extent-map 'button2 'gdb-help-xref) -(define-key gdb-help-extent-map 'button3 'gdb-help-popup-menu) - -;; Keymap for elsewhere in the help buffer -(setq gdb-help-map (make-keymap)) -(define-key gdb-help-map 'button3 'gdb-help-popup-menu) - -(defvar gud-help-menu - '("GDB Help Topics" - "----" - ("Classes of GDB Commands" - "----" - ["running" (gdb-help "running") t] - ["stack" (gdb-help "stack") t] - ["data" (gdb-help "data") t] - ["breakpoints" (gdb-help "breakpoints") t] - ["files" (gdb-help "files") t] - ["status" (gdb-help "status") t] - ["support" (gdb-help "support") t] - ["user-defined" (gdb-help "user-defined") t] - ["aliases" (gdb-help "aliases") t] - ["obscure" (gdb-help "obscure") t] - ["internals" (gdb-help "internals") t]) - "----" - ("Prefix Commands" - "----" - ["info" (gdb-help "info") t] - ["delete" (gdb-help "delete") t] - ["disable" (gdb-help "disable") t] - ["enable" (gdb-help "enable") t] - ["maintenance" (gdb-help "maintenance") t] - ["maintenance info" (gdb-help "maintenance info") t] - ["maintenance print" (gdb-help "maintenance print") t] - ["show" (gdb-help "show") t] - ["show check" (gdb-help "show check") t] - ["show history" (gdb-help "show history") t] - ["show print" (gdb-help "show print") t] - ["set" (gdb-help "set") t] - ["set check" (gdb-help "set check") t] - ["set history" (gdb-help "set history") t] - ["set print" (gdb-help "set print") t] - ["thread" (gdb-help "thread") t] - ["thread apply" (gdb-help "thread apply") t] - ["unset" (gdb-help "unset") t]) -; Only if you build this into gdb -; ("Duel" -; ["summary" (gdb-help "duel help") t] -; ["ops" (gdb-help "duel ops") t] -; ["examples" (gdb-help "duel examples") t]) - ) - "*menu for gdb-help") - -(defun gdb-help-popup-menu (event) - (interactive "@e") - (mouse-set-point event) - (popup-menu gud-help-menu)) - -(defun gdb-help-xref (event) - (interactive "e") - (save-excursion - (set-buffer (get-buffer (gettext "*Debugger Help*"))) - (let ((extent (extent-at (event-point event)))) - (gdb-help - (or (extent-property extent 'back-to) - (buffer-substring (extent-start-position extent) - (extent-end-position extent))) - gdb-help-topic) - ))) - -(defun gdb-help-info () - (interactive) - (require 'info) - (Info-goto-node "(gdb)Top")) - -;; Format the help page. We lightly edit the GDB output to add instructions -;; on getting help on listed commands using the mouse rather than typing -;; "help" at gdb. -;; -;; We're not trying to re-produce Info's or w3's navigational and cross -;; referencing here but just to put a simple mouse-driven front end over -;; GDB's help. -;; -;; The help buffer *ought* to be in gdb-help-mode but we only ever create -;; one buffer so just setting a buffer local keymap should be good enough -;; for now. - -(defun gdb-format-help-page nil - (save-excursion - (display-buffer (set-buffer (get-buffer-create - (gettext "*Debugger Help*")))) - (erase-buffer) - (map-extents '(lambda (extent) (delete-extent extent) nil)) - (use-local-map gdb-help-map) - (insert-buffer (gdb-get-instance-buffer - instance 'gdb-partial-output-buffer)) - (goto-char (point-min)) - (forward-line 1) - (while (re-search-forward "\\(^.*\\) -- .*$" (point-max) t) - (let ((extent (make-extent (match-beginning 1) (match-end 1)))) - (set-extent-property extent 'face (find-face 'bold)) - (set-extent-property extent 'highlight t) - (set-extent-property extent 'keymap gdb-help-extent-map) - )) - ;; We use the message at the end of the help to distinguish between - ;; help on a class of commands, help on a prefix command and help - ;; on a command. - (goto-char (point-min)) - (cond - ((looking-at "List of classes of commands:") - ;; It's the list of classes - (end-of-line) - (insert " Click on a highlighted class to see the list of commands -in that class.") - ) - ((and (not (looking-at "List of classes of commands:")) - (re-search-forward "^Type \"help\" followed by command name" (point-max) t)) - ;; It's help on a specific class - (goto-char (point-min)) - (insert "Help on ") - (downcase-word 1) - (end-of-line) - (insert " Click on a highlighted command to see the help -for that command or click ") - (setq point (point)) - (insert "here") - (setq extent (make-extent point (point))) - (set-extent-property extent 'back-to "") - (insert " to see the list of classes of commands.\n") - ) - ((re-search-forward "^Type \"help.*subcommand" (point-max) t) - ;; It's a prefix command - (goto-char (point-min)) - (insert (concat "Help on \"" gdb-help-topic "\" - ")) - (downcase-word 1) - (end-of-line) - (insert " Click on a highlighted topic to see the help -for that topic or click ") - (setq point (point)) - (insert "here") - (setq extent (make-extent point (point))) - (string-match " ?[^ \t]*$" gdb-help-topic) - (if (equal "" - (set-extent-property extent 'back-to - (substring gdb-help-topic - 0 (match-beginning 0)))) - (insert " to see the list of classes of commands.\n") - (insert (concat " to see the help on " (extent-property extent 'back-to )))) - ) - (t - ;; Must be an ordinary command - (goto-char (point-min)) - (insert (concat "Help on \"" gdb-help-topic "\" - ")) - (insert " Click ") - (setq point (point)) - (insert "here") - (setq extent (make-extent point (point))) - (if (equal "" (set-extent-property extent 'back-to gdb-previous-help-topic)) - (insert " to see the list of classes of commands.\n") - (insert (concat " to see the help on " (extent-property extent 'back-to )))) - ) - ) - (and extent - (set-extent-property extent 'face (find-face 'bold)) - (set-extent-property extent 'highlight t) - (set-extent-property extent 'keymap gdb-help-extent-map)) - (setq fill-column 78) - (fill-region (point-min) (point)) - (insert "\n") - )) - -(defun gdb-help (topic &optional previous-topic) - (interactive "sGdb Help Topic: ") - (let ((instance (gdb-needed-default-instance)) - ) - (save-excursion - (set-buffer (get-buffer-create (gettext "*Debugger Help*"))) - (make-variable-buffer-local 'gdb-help-topic) - (make-variable-buffer-local 'gdb-previous-help-topic) - (setq gdb-help-topic topic) - (setq gdb-previous-help-topic (or previous-topic ""))) - (gdb-clear-partial-output instance) - (gdb-instance-enqueue-idle-input - instance - (list - (concat - "server " - (if (string-match "^duel" topic) - "" - "help ") - topic - "\n") - 'gdb-format-help-page)))) - -;;;; Menus and stuff - -(defun gdb-install-menubar () - "Installs the Gdb menu at the menubar." - - ;; We can't define the menu at load-time because many of the functions - ;; that we will call won't be bound then. - (defvar gdb-menu - '("GDB Commands" - "----" - ("Help" - ["info" gdb-help-info t] - "----" - ["running -- Running the program" (gdb-help "running") t] - ["stack -- Examining the stack" (gdb-help "stack") t] - ["data -- Examining data" (gdb-help "data") t] - ["breakpoints -- Making program stop at certain points" (gdb-help "breakpoints") t] - ["files -- Specifying and examining files" (gdb-help "files") t] - ["status -- Status inquiries" (gdb-help "status") t] - ["support -- Support facilities" (gdb-help "support") t] - ["user-defined -- User-defined commands" (gdb-help "user-defined") t] - ["aliases -- Aliases of other commands" (gdb-help "aliases") t] - ["obscure -- Obscure features" (gdb-help "obscure") t] - ["internals -- Maintenance commands" (gdb-help "internals") t] - "---" -; Only if you build this into gdb -; ["Duel summary" (gdb-help "duel help") t] -; ["Duel ops" (gdb-help "duel ops") t] -; ["Duel examples" (gdb-help "duel examples") t] - ) - "---" - ("New window showing" - ["Local variables" gud-display-locals-buffer t] - ["Displayed expressions" gud-display-display-buffer t] - ["Breakpoints" gud-display-breakpoints-buffer t] - ["Stack trace" gud-display-stack-buffer t] - ["Machine registers" gud-display-registers-buffer t] - ) - ("New frame showing" - ["Local variables" gud-frame-locals-buffer t] - ["Displayed expressions" gud-frame-display-buffer t] - ["Breakpoints" gud-frame-breakpoints-buffer t] - ["Stack trace" gud-frame-stack-buffer t] - ["Machine registers" gud-frame-registers-buffer t] - ) - "----" - ["step" gud-step t] - ["next" gud-next t] - ["finish" gud-finish t] - ["continue" gud-cont t] - ["run" gud-run t] - ) - "*The menu for GDB mode.") - (if (and current-menubar (not (assoc "Gdb" current-menubar))) - (progn - (set-buffer-menubar (copy-sequence current-menubar)) - (add-menu nil "Gdb" (cdr gdb-menu)))) - ) -(add-hook 'gdb-mode-hook 'gdb-install-menubar) - - -(gdb-set-instance-buffer-rules 'gdb-command-buffer - 'gdb-command-buffer-name - 'gud-command-mode) - -(defvar gud-command-mode-map nil) -(setq gud-command-mode-map (make-keymap)) -(suppress-keymap gud-command-mode-map) -;;; XEmacs change -;(define-key gud-command-mode-map [mouse-2] 'gud-menu-pick) -(define-key gud-command-mode-map [button2] 'gud-menu-pick) - - -(defun gud-command-mode () - "Major mode for gud menu. - -\\{gud-command-mode-map}" (interactive) (setq major-mode 'gud-command-mode) - (setq mode-name "Menu") (setq buffer-read-only t) (use-local-map - gud-command-mode-map) (make-variable-buffer-local 'gud-menu-position) - (if (not gud-menu-position) (gud-goto-menu gud-running-menu))) - -(defun gdb-command-buffer-name (instance) - (save-excursion - (set-buffer (process-buffer (gdb-instance-process instance))) - (concat "*menu of " (gdb-instance-target-string instance) "*"))) - -(defun gud-display-command-buffer (instance) - (interactive (list (gdb-needed-default-instance))) - (gud-display-buffer - (gdb-get-create-instance-buffer instance - 'gdb-command-buffer) - 6)) - -(defun gud-frame-command-buffer (instance) - (interactive (list (gdb-needed-default-instance))) - (gud-display-buffer-new-frame - (gdb-get-create-instance-buffer instance - 'gdb-command-buffer))) - - - -(defun gdb-call-showing-gud (instance command) - (gud-display-gud-buffer instance) - (comint-input-sender (gdb-instance-process instance) command)) - -(defvar gud-target-history ()) - -(defun gud-temp-buffer-show (buf) - (let ((ow (selected-window))) - (unwind-protect - (progn - (pop-to-buffer buf) - - ;; This insertion works around a bug in emacs. - ;; The bug is that all the empty space after a - ;; highlighted word that terminates a buffer - ;; gets highlighted. That's really ugly, so - ;; make sure a highlighted word can't ever - ;; terminate the buffer. - (goto-char (point-max)) - (insert "\n") - (goto-char (point-min)) - - (if (< (window-height) 10) - (enlarge-window (- 10 (window-height))))) - (select-window ow)))) - -(defun gud-target (instance command) - (interactive - (let* ((instance (gdb-needed-default-instance)) - (temp-buffer-show-function (function gud-temp-buffer-show)) - (target-name (completing-read (format "Target type: ") - '(("remote") - ("core") - ("child") - ("exec")) - nil - t - nil - 'gud-target-history))) - (list instance - (cond - ((equal target-name "child") "run") - - ((equal target-name "core") - (concat "target core " - (read-file-name "core file: " - nil - "core" - t))) - - ((equal target-name "exec") - (concat "target exec " - (read-file-name "exec file: " - nil - "a.out" - t))) - - ((equal target-name "remote") - (concat "target remote " - (read-file-name "serial line for remote: " - "/dev/" - "ttya" - t))) - - (t "echo No such target command!"))))) - - (gud-display-gud-buffer instance) - (apply comint-input-sender - (list (gdb-instance-process instance) command))) - -(defun gud-backtrace () - (interactive) - (let ((instance (gdb-needed-default-instance))) - (gud-display-gud-buffer instance) - (apply comint-input-sender - (list (gdb-instance-process instance) - "backtrace")))) - -(defun gud-frame () - (interactive) - (let ((instance (gdb-needed-default-instance))) - (apply comint-input-sender - (list (gdb-instance-process instance) - "frame")))) - -(defun gud-return (instance command) - (interactive - (let ((temp-buffer-show-function (function gud-temp-buffer-show))) - (list (gdb-needed-default-instance) - (concat "return " (read-string "Expression to return: "))))) - (gud-display-gud-buffer instance) - (apply comint-input-sender - (list (gdb-instance-process instance) command))) - - -(defun gud-file (instance command) - (interactive - (let ((temp-buffer-show-function (function gud-temp-buffer-show))) - (list (gdb-needed-default-instance) - (concat "file " (read-file-name "Executable to debug: " - nil - "a.out" - t))))) - (gud-display-gud-buffer instance) - (apply comint-input-sender - (list (gdb-instance-process instance) command))) - -(defun gud-core-file (instance command) - (interactive - (let ((temp-buffer-show-function (function gud-temp-buffer-show))) - (list (gdb-needed-default-instance) - (concat "core " (read-file-name "Core file to debug: " - nil - "core-file" - t))))) - (gud-display-gud-buffer instance) - (apply comint-input-sender - (list (gdb-instance-process instance) command))) - -(defun gud-cd (dir) - (interactive "FChange GDB's default directory: ") - (let ((instance (gdb-needed-default-instance))) - (save-excursion - (set-buffer (gdb-get-instance-buffer instance 'gud)) - (cd dir)) - (gud-display-gud-buffer instance) - (apply comint-input-sender - (list (gdb-instance-process instance) - (concat "cd " dir))))) - - -(defun gud-exec-file (instance command) - (interactive - (let ((temp-buffer-show-function (function gud-temp-buffer-show))) - (list (gdb-needed-default-instance) - (concat "exec-file " (read-file-name "Init memory from executable: " - nil - "a.out" - t))))) - (gud-display-gud-buffer instance) - (apply comint-input-sender - (list (gdb-instance-process instance) command))) - -(defun gud-load (instance command) - (interactive - (let ((temp-buffer-show-function (function gud-temp-buffer-show))) - (list (gdb-needed-default-instance) - (concat "load " (read-file-name "Dynamicly load from file: " - nil - "a.out" - t))))) - (gud-display-gud-buffer instance) - (apply comint-input-sender - (list (gdb-instance-process instance) command))) - -(defun gud-symbol-file (instance command) - (interactive - (let ((temp-buffer-show-function (function gud-temp-buffer-show))) - (list (gdb-needed-default-instance) - (concat "symbol-file " (read-file-name "Read symbol table from file: " - nil - "a.out" - t))))) - (gud-display-gud-buffer instance) - (apply comint-input-sender - (list (gdb-instance-process instance) command))) - - -(defun gud-add-symbol-file (instance command) - (interactive - (let ((temp-buffer-show-function (function gud-temp-buffer-show))) - (list (gdb-needed-default-instance) - (concat "add-symbol-file " - (read-file-name "Add symbols from file: " - nil - "a.out" - t))))) - (gud-display-gud-buffer instance) - (apply comint-input-sender - (list (gdb-instance-process instance) command))) - - -(defun gud-sharedlibrary (instance command) - (interactive - (let ((temp-buffer-show-function (function gud-temp-buffer-show))) - (list (gdb-needed-default-instance) - (concat "sharedlibrary " - (read-string "Load symbols for files matching regexp: "))))) - (gud-display-gud-buffer instance) - (apply comint-input-sender - (list (gdb-instance-process instance) command))) - - -;;;; Help - - - -;;;; Window management - - -;;; FIXME: This should only return true for buffers in the current instance -(defun gud-protected-buffer-p (buffer) - "Is BUFFER a buffer which we want to leave displayed?" - (save-excursion - (set-buffer buffer) - (or gdb-buffer-type - overlay-arrow-position))) - -;;; The way we abuse the dedicated-p flag is pretty gross, but seems -;;; to do the right thing. Seeing as there is no way for Lisp code to -;;; get at the use_time field of a window, I'm not sure there exists a -;;; more elegant solution without writing C code. - -(defun gud-display-buffer (buf &optional size) - (let ((must-split nil) - (answer nil)) - (save-excursion - (unwind-protect - (progn - (walk-windows - '(lambda (win) - (if (gud-protected-buffer-p (window-buffer win)) - (set-window-buffer-dedicated win (window-buffer win))))) - (setq answer (get-buffer-window buf)) - (if (not answer) - (let ((window (get-lru-window))) - (if (not (window-dedicated-p window)) - (progn - (set-window-buffer window buf) - (setq answer window)) - (setq must-split t))))) - (walk-windows - '(lambda (win) - (if (gud-protected-buffer-p (window-buffer win)) - (set-window-buffer-dedicated win nil))))) - (if must-split - (let* ((largest (get-largest-window)) - (cur-size (window-height largest)) - (new-size (and size (< size cur-size) (- cur-size size)))) - (setq answer (split-window largest new-size)) - (set-window-buffer answer buf))) - answer))) - -(defun existing-source-window (buffer) - (catch 'found - (save-excursion - (walk-windows - (function - (lambda (win) - (if (and overlay-arrow-position - (eq (window-buffer win) - (marker-buffer overlay-arrow-position))) - (progn - (set-window-buffer win buffer) - (throw 'found win)))))) - nil))) - -(defun gud-display-source-buffer (buffer) - (or (existing-source-window buffer) - (gud-display-buffer buffer))) - -(defun gud-display-buffer-new-frame (buf) - (save-excursion - (set-buffer buf) - (let* ((buf-height (+ 4 (count-lines (point-min) (point-max)))) - (frame-params (list (cons 'height buf-height))) - ) - ;; This is a hack so that we can re-size this window to occupy just as - ;; much space is needed. - (setq truncate-lines t) - (set-buffer-dedicated-frame buf (make-frame frame-params))))) - - - -;;; Shared keymap initialization: - -(defun gud-display-gud-buffer (instance) - (interactive (list (gdb-needed-default-instance))) - (gud-display-buffer - (gdb-get-create-instance-buffer instance 'gud))) - -(defun gud-frame-gud-buffer (instance) - (interactive (list (gdb-needed-default-instance))) - (gud-display-buffer-new-frame - (gdb-get-create-instance-buffer instance 'gud))) - - -(defun gud-gdb-find-file (f) - (find-file-noselect f)) - -;;; XEmacs: don't autoload this yet since it's still buggy - use the -;;; one in gdb.el instead -(defun gdb (command-line) - "Run gdb on program FILE in buffer *gud-FILE*. -The directory containing FILE becomes the initial working directory -and source-file directory for your debugger." - (interactive - (list (read-shell-command "Run gdb (like this): " - (if (consp gud-gdb-history) - (car gud-gdb-history) - "gdb ") - '(gud-gdb-history . 1)))) - (gud-overload-functions - '((gud-massage-args . gud-gdb-massage-args) - (gud-marker-filter . gud-gdb-marker-filter) - (gud-find-file . gud-gdb-find-file) - )) - - (let* ((words (gud-chop-words command-line)) - (program (car words)) - (file-word (let ((w (cdr words))) - (while (and w (= ?- (aref (car w) 0))) - (setq w (cdr w))) - (car w))) - (args (delq file-word (cdr words))) - (file (and file-word (expand-file-name file-word))) - (filepart (if file (file-name-nondirectory file) "")) - (buffer-name (concat "*" "gdb" - (and (string< "" filepart) - (concat "-" filepart)) "*"))) - (setq gdb-first-time (not (get-buffer-process buffer-name)))) - - (gud-common-init command-line "gdb") - - (gud-def gud-break "break %f:%l" "\C-b" "Set breakpoint at current line.") - (gud-def gud-tbreak "tbreak %f:%l" "\C-t" "Set breakpoint at current line.") - (gud-def gud-remove "clear %l" "\C-d" "Remove breakpoint at current line") - (gud-def gud-kill "kill" nil "Kill the program.") - (gud-def gud-run "run" nil "Run the program.") - (gud-def gud-stepi "stepi %p" "\C-i" "Step one instruction with display.") - (gud-def gud-step "step %p" "\C-s" "Step one source line with display.") - (gud-def gud-next "next %p" "\C-n" "Step one line (skip functions).") - (gud-def gud-finish "finish" "\C-f" "Finish executing current function.") - (gud-def gud-cont "cont" "\C-r" "Continue with display.") - (gud-def gud-up "up %p" "<" "Up N stack frames (numeric arg).") - (gud-def gud-down "down %p" ">" "Down N stack frames (numeric arg).") - (gud-def gud-print "print %e" "\C-p" "Evaluate C expression at point.") - - (setq comint-prompt-regexp "^(.*gdb[+]?) *") - (setq comint-input-sender 'gdb-send) - (run-hooks 'gdb-mode-hook) - (let ((instance - (make-gdb-instance (get-buffer-process (current-buffer))) - )) - (if gdb-first-time (gdb-clear-inferior-io instance))) - ) - - -;; ====================================================================== -;; sdb functions - -;;; History of argument lists passed to sdb. -(defvar gud-sdb-history nil) - -(defvar gud-sdb-needs-tags (not (file-exists-p "/var")) - "If nil, we're on a System V Release 4 and don't need the tags hack.") - -(defvar gud-sdb-lastfile nil) - -(defun gud-sdb-massage-args (file args) - (cons file args)) - -(defun gud-sdb-marker-filter (string) - (cond - ;; System V Release 3.2 uses this format - ((string-match "\\(^0x\\w* in \\|^\\|\n\\)\\([^:\n]*\\):\\([0-9]*\\):.*\n" - string) - (setq gud-last-frame - (cons - (substring string (match-beginning 2) (match-end 2)) - (string-to-int - (substring string (match-beginning 3) (match-end 3)))))) - ;; System V Release 4.0 - ((string-match "^\\(BREAKPOINT\\|STEPPED\\) process [0-9]+ function [^ ]+ in \\(.+\\)\n" - string) - (setq gud-sdb-lastfile - (substring string (match-beginning 2) (match-end 2)))) - ((and gud-sdb-lastfile (string-match "^\\([0-9]+\\):" string)) - (setq gud-last-frame - (cons - gud-sdb-lastfile - (string-to-int - (substring string (match-beginning 1) (match-end 1)))))) - (t - (setq gud-sdb-lastfile nil))) - string) - -(defun gud-sdb-find-file (f) - (if gud-sdb-needs-tags - (find-tag-noselect f) - (find-file-noselect f))) - -;;;###autoload -(defun sdb (command-line) - "Run sdb on program FILE in buffer *gud-FILE*. -The directory containing FILE becomes the initial working directory -and source-file directory for your debugger." - (interactive - (list (read-from-minibuffer "Run sdb (like this): " - (if (consp gud-sdb-history) - (car gud-sdb-history) - "sdb ") - nil nil - '(gud-sdb-history . 1)))) - (if (and gud-sdb-needs-tags - (not (and (boundp 'tags-file-name) (file-exists-p tags-file-name)))) - (error "The sdb support requires a valid tags table to work.")) - (gud-overload-functions '((gud-massage-args . gud-sdb-massage-args) - (gud-marker-filter . gud-sdb-marker-filter) - (gud-find-file . gud-sdb-find-file) - )) - - (gud-common-init command-line "sdb") - - (gud-def gud-break "%l b" "\C-b" "Set breakpoint at current line.") - (gud-def gud-tbreak "%l c" "\C-t" "Set temporary breakpoint at current line.") - (gud-def gud-remove "%l d" "\C-d" "Remove breakpoint at current line") - (gud-def gud-step "s %p" "\C-s" "Step one source line with display.") - (gud-def gud-stepi "i %p" "\C-i" "Step one instruction with display.") - (gud-def gud-next "S %p" "\C-n" "Step one line (skip functions).") - (gud-def gud-cont "c" "\C-r" "Continue with display.") - (gud-def gud-print "%e/" "\C-p" "Evaluate C expression at point.") - - (setq comint-prompt-regexp "\\(^\\|\n\\)\\*") - (run-hooks 'sdb-mode-hook) - ) - -;; ====================================================================== -;; dbx functions - -;;; History of argument lists passed to dbx. -(defvar gud-dbx-history nil) - -(defun gud-dbx-massage-args (file args) - (cons file args)) - -(defun gud-dbx-marker-filter (string) - (if (or (string-match - "stopped in .* at line \\([0-9]*\\) in file \"\\([^\"]*\\)\"" - string) - (string-match - "signal .* in .* at line \\([0-9]*\\) in file \"\\([^\"]*\\)\"" - string)) - (setq gud-last-frame - (cons - (substring string (match-beginning 2) (match-end 2)) - (string-to-int - (substring string (match-beginning 1) (match-end 1)))))) - string) - -(defun gud-dbx-find-file (f) - (find-file-noselect f)) - -;;;###autoload -(defun dbx (command-line) - "Run dbx on program FILE in buffer *gud-FILE*. -The directory containing FILE becomes the initial working directory -and source-file directory for your debugger." - (interactive - (list (read-from-minibuffer "Run dbx (like this): " - (if (consp gud-dbx-history) - (car gud-dbx-history) - "dbx ") - nil nil - '(gud-dbx-history . 1)))) - (gud-overload-functions '((gud-massage-args . gud-dbx-massage-args) - (gud-marker-filter . gud-dbx-marker-filter) - (gud-find-file . gud-dbx-find-file) - )) - - (gud-common-init command-line "dbx") - - (gud-def gud-break "file \"%d%f\"\nstop at %l" - "\C-b" "Set breakpoint at current line.") -;; (gud-def gud-break "stop at \"%f\":%l" -;; "\C-b" "Set breakpoint at current line.") - (gud-def gud-remove "clear %l" "\C-d" "Remove breakpoint at current line") - (gud-def gud-step "step %p" "\C-s" "Step one line with display.") - (gud-def gud-stepi "stepi %p" "\C-i" "Step one instruction with display.") - (gud-def gud-next "next %p" "\C-n" "Step one line (skip functions).") - (gud-def gud-cont "cont" "\C-r" "Continue with display.") - (gud-def gud-up "up %p" "<" "Up (numeric arg) stack frames.") - (gud-def gud-down "down %p" ">" "Down (numeric arg) stack frames.") - (gud-def gud-print "print %e" "\C-p" "Evaluate C expression at point.") - - (setq comint-prompt-regexp "^[^)]*dbx) *") - (run-hooks 'dbx-mode-hook) - ) - -;; ====================================================================== -;; xdb (HP PARISC debugger) functions - -;;; History of argument lists passed to xdb. -(defvar gud-xdb-history nil) - -(defvar gud-xdb-directories nil - "*A list of directories that xdb should search for source code. -If nil, only source files in the program directory -will be known to xdb. - -The file names should be absolute, or relative to the directory -containing the executable being debugged.") - -(defun gud-xdb-massage-args (file args) - (nconc (let ((directories gud-xdb-directories) - (result nil)) - (while directories - (setq result (cons (car directories) (cons "-d" result))) - (setq directories (cdr directories))) - (nreverse (cons file result))) - args)) - -(defun gud-xdb-file-name (f) - "Transform a relative pathname to a full pathname in xdb mode" - (let ((result nil)) - (if (file-exists-p f) - (setq result (expand-file-name f)) - (let ((directories gud-xdb-directories)) - (while directories - (let ((path (concat (car directories) "/" f))) - (if (file-exists-p path) - (setq result (expand-file-name path) - directories nil))) - (setq directories (cdr directories))))) - result)) - -;; xdb does not print the lines all at once, so we have to accumulate them -(defvar gud-xdb-accumulation "") - -(defun gud-xdb-marker-filter (string) - (let (result) - (if (or (string-match comint-prompt-regexp string) - (string-match ".*\012" string)) - (setq result (concat gud-xdb-accumulation string) - gud-xdb-accumulation "") - (setq gud-xdb-accumulation (concat gud-xdb-accumulation string))) - (if result - (if (or (string-match "\\([^\n \t:]+\\): [^:]+: \\([0-9]+\\):" result) - (string-match "[^: \t]+:[ \t]+\\([^:]+\\): [^:]+: \\([0-9]+\\):" - result)) - (let ((line (string-to-int - (substring result (match-beginning 2) (match-end 2)))) - (file (gud-xdb-file-name - (substring result (match-beginning 1) (match-end 1))))) - (if file - (setq gud-last-frame (cons file line)))))) - (or result ""))) - -(defun gud-xdb-find-file (f) - (let ((realf (gud-xdb-file-name f))) - (if realf (find-file-noselect realf)))) - -;;;###autoload -(defun xdb (command-line) - "Run xdb on program FILE in buffer *gud-FILE*. -The directory containing FILE becomes the initial working directory -and source-file directory for your debugger. - -You can set the variable 'gud-xdb-directories' to a list of program source -directories if your program contains sources from more than one directory." - (interactive - (list (read-from-minibuffer "Run xdb (like this): " - (if (consp gud-xdb-history) - (car gud-xdb-history) - "xdb ") - nil nil - '(gud-xdb-history . 1)))) - (gud-overload-functions '((gud-massage-args . gud-xdb-massage-args) - (gud-marker-filter . gud-xdb-marker-filter) - (gud-find-file . gud-xdb-find-file))) - - (gud-common-init command-line "xdb") - - (gud-def gud-break "b %f:%l" "\C-b" "Set breakpoint at current line.") - (gud-def gud-tbreak "b %f:%l\\t" "\C-t" - "Set temporary breakpoint at current line.") - (gud-def gud-remove "db" "\C-d" "Remove breakpoint at current line") - (gud-def gud-step "s %p" "\C-s" "Step one line with display.") - (gud-def gud-next "S %p" "\C-n" "Step one line (skip functions).") - (gud-def gud-cont "c" "\C-r" "Continue with display.") - (gud-def gud-up "up %p" "<" "Up (numeric arg) stack frames.") - (gud-def gud-down "down %p" ">" "Down (numeric arg) stack frames.") - (gud-def gud-finish "bu\\t" "\C-f" "Finish executing current function.") - (gud-def gud-print "p %e" "\C-p" "Evaluate C expression at point.") - - (setq comint-prompt-regexp "^>") - (make-local-variable 'gud-xdb-accumulation) - (setq gud-xdb-accumulation "") - (run-hooks 'xdb-mode-hook)) - -;; ====================================================================== -;; perldb functions - -;;; History of argument lists passed to perldb. -(defvar gud-perldb-history nil) - -(defun gud-perldb-massage-args (file args) - (cons "-d" (cons file (cons "-emacs" args)))) - -;; There's no guarantee that Emacs will hand the filter the entire -;; marker at once; it could be broken up across several strings. We -;; might even receive a big chunk with several markers in it. If we -;; receive a chunk of text which looks like it might contain the -;; beginning of a marker, we save it here between calls to the -;; filter. -(defvar gud-perldb-marker-acc "") - -(defun gud-perldb-marker-filter (string) - (save-match-data - (setq gud-perldb-marker-acc (concat gud-perldb-marker-acc string)) - (let ((output "")) - - ;; Process all the complete markers in this chunk. - (while (string-match "^\032\032\\([^:\n]*\\):\\([0-9]*\\):.*\n" - gud-perldb-marker-acc) - (setq - - ;; Extract the frame position from the marker. - gud-last-frame - (cons (substring gud-perldb-marker-acc (match-beginning 1) (match-end 1)) - (string-to-int (substring gud-perldb-marker-acc - (match-beginning 2) - (match-end 2)))) - - ;; Append any text before the marker to the output we're going - ;; to return - we don't include the marker in this text. - output (concat output - (substring gud-perldb-marker-acc 0 (match-beginning 0))) - - ;; Set the accumulator to the remaining text. - gud-perldb-marker-acc (substring gud-perldb-marker-acc (match-end 0)))) - - ;; Does the remaining text look like it might end with the - ;; beginning of another marker? If it does, then keep it in - ;; gud-perldb-marker-acc until we receive the rest of it. Since we - ;; know the full marker regexp above failed, it's pretty simple to - ;; test for marker starts. - (if (string-match "^\032.*\\'" gud-perldb-marker-acc) - (progn - ;; Everything before the potential marker start can be output. - (setq output (concat output (substring gud-perldb-marker-acc - 0 (match-beginning 0)))) - - ;; Everything after, we save, to combine with later input. - (setq gud-perldb-marker-acc - (substring gud-perldb-marker-acc (match-beginning 0)))) - - (setq output (concat output gud-perldb-marker-acc) - gud-perldb-marker-acc "")) - - output))) - -(defun gud-perldb-find-file (f) - (find-file-noselect f)) - -;;;###autoload -(defun perldb (command-line) - "Run perldb on program FILE in buffer *gud-FILE*. -The directory containing FILE becomes the initial working directory -and source-file directory for your debugger." - (interactive - (list (read-from-minibuffer "Run perldb (like this): " - (if (consp gud-perldb-history) - (car gud-perldb-history) - "perl ") - nil nil - '(gud-perldb-history . 1)))) - (gud-overload-functions '((gud-massage-args . gud-perldb-massage-args) - (gud-marker-filter . gud-perldb-marker-filter) - (gud-find-file . gud-perldb-find-file) - )) - - (gud-common-init command-line "perldb") - - (gud-def gud-break "b %l" "\C-b" "Set breakpoint at current line.") - (gud-def gud-remove "d %l" "\C-d" "Remove breakpoint at current line") - (gud-def gud-step "s" "\C-s" "Step one source line with display.") - (gud-def gud-next "n" "\C-n" "Step one line (skip functions).") - (gud-def gud-cont "c" "\C-r" "Continue with display.") -; (gud-def gud-finish "finish" "\C-f" "Finish executing current function.") -; (gud-def gud-up "up %p" "<" "Up N stack frames (numeric arg).") -; (gud-def gud-down "down %p" ">" "Down N stack frames (numeric arg).") - (gud-def gud-print "%e" "\C-p" "Evaluate perl expression at point.") - - (setq comint-prompt-regexp "^ DB<[0-9]+> ") - (run-hooks 'perldb-mode-hook) - ) - -;; -;; End of debugger-specific information -;; - - -;;; When we send a command to the debugger via gud-call, it's annoying -;;; to see the command and the new prompt inserted into the debugger's -;;; buffer; we have other ways of knowing the command has completed. -;;; -;;; If the buffer looks like this: -;;; -------------------- -;;; (gdb) set args foo bar -;;; (gdb) -!- -;;; -------------------- -;;; (the -!- marks the location of point), and we type `C-x SPC' in a -;;; source file to set a breakpoint, we want the buffer to end up like -;;; this: -;;; -------------------- -;;; (gdb) set args foo bar -;;; Breakpoint 1 at 0x92: file make-docfile.c, line 49. -;;; (gdb) -!- -;;; -------------------- -;;; Essentially, the old prompt is deleted, and the command's output -;;; and the new prompt take its place. -;;; -;;; Not echoing the command is easy enough; you send it directly using -;;; comint-input-sender, and it never enters the buffer. However, -;;; getting rid of the old prompt is trickier; you don't want to do it -;;; when you send the command, since that will result in an annoying -;;; flicker as the prompt is deleted, redisplay occurs while Emacs -;;; waits for a response from the debugger, and the new prompt is -;;; inserted. Instead, we'll wait until we actually get some output -;;; from the subprocess before we delete the prompt. If the command -;;; produced no output other than a new prompt, that prompt will most -;;; likely be in the first chunk of output received, so we will delete -;;; the prompt and then replace it with an identical one. If the -;;; command produces output, the prompt is moving anyway, so the -;;; flicker won't be annoying. -;;; -;;; So - when we want to delete the prompt upon receipt of the next -;;; chunk of debugger output, we position gud-delete-prompt-marker at -;;; the start of the prompt; the process filter will notice this, and -;;; delete all text between it and the process output marker. If -;;; gud-delete-prompt-marker points nowhere, we leave the current -;;; prompt alone. -(defvar gud-delete-prompt-marker nil) - - -(defvar gdbish-comint-mode-map (copy-keymap comint-mode-map)) -(define-key gdbish-comint-mode-map "\C-c\M-\C-r" 'gud-display-registers-buffer) -(define-key gdbish-comint-mode-map "\C-c\M-\C-f" 'gud-display-stack-buffer) -(define-key gdbish-comint-mode-map "\C-c\M-\C-b" 'gud-display-breakpoints-buffer) - -(defun gud-mode () - "Major mode for interacting with an inferior debugger process. - - You start it up with one of the commands M-x gdb, M-x sdb, M-x dbx, -or M-x xdb. Each entry point finishes by executing a hook; `gdb-mode-hook', -`sdb-mode-hook', `dbx-mode-hook' or `xdb-mode-hook' respectively. - -After startup, the following commands are available in both the GUD -interaction buffer and any source buffer GUD visits due to a breakpoint stop -or step operation: - -\\[gud-break] sets a breakpoint at the current file and line. In the -GUD buffer, the current file and line are those of the last breakpoint or -step. In a source buffer, they are the buffer's file and current line. - -\\[gud-remove] removes breakpoints on the current file and line. - -\\[gud-refresh] displays in the source window the last line referred to -in the gud buffer. - -\\[gud-step], \\[gud-next], and \\[gud-stepi] do a step-one-line, -step-one-line (not entering function calls), and step-one-instruction -and then update the source window with the current file and position. -\\[gud-cont] continues execution. - -\\[gud-print] tries to find the largest C lvalue or function-call expression -around point, and sends it to the debugger for value display. - -The above commands are common to all supported debuggers except xdb which -does not support stepping instructions. - -Under gdb, sdb and xdb, \\[gud-tbreak] behaves exactly like \\[gud-break], -except that the breakpoint is temporary; that is, it is removed when -execution stops on it. - -Under gdb, dbx, and xdb, \\[gud-up] pops up through an enclosing stack -frame. \\[gud-down] drops back down through one. - -If you are using gdb or xdb, \\[gud-finish] runs execution to the return from -the current function and stops. - -All the keystrokes above are accessible in the GUD buffer -with the prefix C-c, and in all buffers through the prefix C-x C-a. - -All pre-defined functions for which the concept make sense repeat -themselves the appropriate number of times if you give a prefix -argument. - -You may use the `gud-def' macro in the initialization hook to define other -commands. - -Other commands for interacting with the debugger process are inherited from -comint mode, which see." - (interactive) - (comint-mode) - (setq major-mode 'gud-mode) - (setq mode-name "Debugger") - (setq mode-line-process '(": %s")) - (use-local-map (copy-keymap gdbish-comint-mode-map)) - (setq gud-last-frame nil) - (make-local-variable 'comint-prompt-regexp) - (make-local-variable 'gud-delete-prompt-marker) - (setq gud-delete-prompt-marker (make-marker)) - (run-hooks 'gud-mode-hook) -) - -(defvar gud-comint-buffer nil) - -;; Chop STRING into words separated by SPC or TAB and return a list of them. -(defun gud-chop-words (string) - (let ((i 0) (beg 0) - (len (length string)) - (words nil)) - (while (< i len) - (if (memq (aref string i) '(?\t ? )) - (progn - (setq words (cons (substring string beg i) words) - beg (1+ i)) - (while (and (< beg len) (memq (aref string beg) '(?\t ? ))) - (setq beg (1+ beg))) - (setq i (1+ beg))) - (setq i (1+ i)))) - (if (< beg len) - (setq words (cons (substring string beg) words))) - (nreverse words))) - -(defvar gud-target-name "--unknown--" - "The apparent name of the program being debugged in a gud buffer. -For sure this the root string used in smashing together the gud -buffer's name, even if that doesn't happen to be the name of a -program.") - -;; Perform initializations common to all debuggers. -(defun gud-common-init (command-line debugger-name) - (let* ((words (gud-chop-words command-line)) - (program (car words)) - (file-word (let ((w (cdr words))) - (while (and w (= ?- (aref (car w) 0))) - (setq w (cdr w))) - (car w))) - (args (delq file-word (cdr words))) - (file (and file-word (expand-file-name file-word))) - (filepart (if file (file-name-nondirectory file) "")) - (buffer-name (concat "*" debugger-name - (and (string< "" filepart) - (concat "-" filepart)) "*"))) - (switch-to-buffer buffer-name) - (if file - (setq default-directory (file-name-directory file))) - (or (bolp) (newline)) - (insert "Current directory is " default-directory "\n") - (let ((old-instance gdb-buffer-instance)) - (apply 'make-comint (concat debugger-name - (and (string< "" filepart) - (concat "-" filepart))) - program nil - ;; There *has* to be an easier way to strip "nil"s from the output - ;; of gud-massage-args - (apply 'append (mapcar '(lambda (arg) (if (stringp arg) (list arg) arg)) - (gud-massage-args file args)))) - (gud-mode) - (make-variable-buffer-local 'old-gdb-buffer-instance) - (setq old-gdb-buffer-instance old-instance)) - (make-variable-buffer-local 'gud-target-name) - (setq gud-target-name filepart)) - (set-process-filter (get-buffer-process (current-buffer)) 'gud-filter) - (set-process-sentinel (get-buffer-process (current-buffer)) 'gud-sentinel) - (gud-set-buffer) - ) - -(defun gud-set-buffer () - (cond ((eq major-mode 'gud-mode) - (setq gud-comint-buffer (current-buffer))))) - -;; These functions are responsible for inserting output from your debugger -;; into the buffer. The hard work is done by the method that is -;; the value of gud-marker-filter. - -(defun gud-filter (proc string) - ;; Here's where the actual buffer insertion is done - (let ((inhibit-quit t)) - (save-excursion - (set-buffer (process-buffer proc)) - (let (moving output-after-point) - (save-excursion - (goto-char (process-mark proc)) - ;; If we have been so requested, delete the debugger prompt. - (if (marker-buffer gud-delete-prompt-marker) - (progn - (delete-region (point) gud-delete-prompt-marker) - (set-marker gud-delete-prompt-marker nil))) - (insert-before-markers (gud-marker-filter string)) - (setq moving (= (point) (process-mark proc))) - (setq output-after-point (< (point) (process-mark proc))) - ;; Check for a filename-and-line number. - ;; Don't display the specified file - ;; unless (1) point is at or after the position where output appears - ;; and (2) this buffer is on the screen. - (if (and gud-last-frame - (not output-after-point) - (get-buffer-window (current-buffer))) - (gud-display-frame))) - (if moving (goto-char (process-mark proc))))))) - -(defun gud-proc-died (proc) - ;; Stop displaying an arrow in a source file. - (setq overlay-arrow-position nil) - - ;; Kill the dummy process, so that C-x C-c won't worry about it. - (save-excursion - (set-buffer (process-buffer proc)) - (let ((buf (gdb-get-instance-buffer gdb-buffer-instance - 'gdb-inferior-io))) - (if buf - (kill-process (get-buffer-process buf))) - ))) - -(defun gud-sentinel (proc msg) - (cond ((null (buffer-name (process-buffer proc))) - ;; buffer killed - (gud-proc-died proc) - (set-process-buffer proc nil)) - ((memq (process-status proc) '(signal exit)) - (gud-proc-died proc) - - ;; Fix the mode line. - (setq mode-line-process - (concat ": " - (symbol-name (process-status proc)))) - (let* ((obuf (current-buffer))) - ;; save-excursion isn't the right thing if - ;; process-buffer is current-buffer - (unwind-protect - (progn - ;; Write something in *compilation* and hack its mode line, - (set-buffer (process-buffer proc)) - ;; Force mode line redisplay soon - (set-buffer-modified-p (buffer-modified-p)) - (if (eobp) - (insert ?\n mode-name " " msg) - (save-excursion - (goto-char (point-max)) - (insert ?\n mode-name " " msg))) - ;; If buffer and mode line will show that the process - ;; is dead, we can delete it now. Otherwise it - ;; will stay around until M-x list-processes. - (delete-process proc)) - ;; Restore old buffer, but don't restore old point - ;; if obuf is the gud buffer. - (set-buffer obuf)))))) - -(defun gud-display-frame () - "Find and obey the last filename-and-line marker from the debugger. -Obeying it means displaying in another window the specified file and line." - (interactive) - (if gud-last-frame - (progn -; (gud-set-buffer) - (gud-display-line (car gud-last-frame) (cdr gud-last-frame)) - (setq gud-last-last-frame gud-last-frame - gud-last-frame nil)))) - -;; Make sure the file named TRUE-FILE is in a buffer that appears on the screen -;; and that its line LINE is visible. -;; Put the overlay-arrow on the line LINE in that buffer. -;; Most of the trickiness in here comes from wanting to preserve the current -;; region-restriction if that's possible. We use an explicit display-buffer -;; to get around the fact that this is called inside a save-excursion. - -(defun gud-display-line (true-file line) - (let* ((buffer (gud-find-file true-file)) - (window (gud-display-source-buffer buffer)) - (pos)) - (if (not window) - (error "foo bar baz")) -;;; (if (equal buffer (current-buffer)) -;;; nil -;;; (setq buffer-read-only nil)) - (save-excursion -;;; (setq buffer-read-only t) - (set-buffer buffer) - (save-restriction - (widen) - (goto-line line) - (setq pos (point)) - (setq overlay-arrow-string "=>") - (or overlay-arrow-position - (setq overlay-arrow-position (make-marker))) - (set-marker overlay-arrow-position (point) (current-buffer))) - (cond ((or (< pos (point-min)) (> pos (point-max))) - (widen) - (goto-char pos)))) - (set-window-point window overlay-arrow-position))) - -;;; The gud-call function must do the right thing whether its invoking -;;; keystroke is from the GUD buffer itself (via major-mode binding) -;;; or a C buffer. In the former case, we want to supply data from -;;; gud-last-frame. Here's how we do it: - -(defun gud-format-command (str arg) - (let ((insource (not (eq (current-buffer) gud-comint-buffer)))) - (if (string-match "\\(.*\\)%f\\(.*\\)" str) - (setq str (concat - (substring str (match-beginning 1) (match-end 1)) - (file-name-nondirectory (if insource - (buffer-file-name) - (car gud-last-frame))) - (substring str (match-beginning 2) (match-end 2))))) - (if (string-match "\\(.*\\)%d\\(.*\\)" str) - (setq str (concat - (substring str (match-beginning 1) (match-end 1)) - (file-name-directory (if insource - (buffer-file-name) - (car gud-last-frame))) - (substring str (match-beginning 2) (match-end 2))))) - (if (string-match "\\(.*\\)%l\\(.*\\)" str) - (setq str (concat - (substring str (match-beginning 1) (match-end 1)) - (if insource - (save-excursion - (beginning-of-line) - (save-restriction (widen) - (1+ (count-lines 1 (point))))) - (cdr gud-last-frame)) - (substring str (match-beginning 2) (match-end 2))))) - (if (string-match "\\(.*\\)%e\\(.*\\)" str) - (setq str (concat - (substring str (match-beginning 1) (match-end 1)) - (find-c-expr) - (substring str (match-beginning 2) (match-end 2))))) - (if (string-match "\\(.*\\)%a\\(.*\\)" str) - (setq str (concat - (substring str (match-beginning 1) (match-end 1)) - (gud-read-address) - (substring str (match-beginning 2) (match-end 2))))) - (if (string-match "\\(.*\\)%p\\(.*\\)" str) - (setq str (concat - (substring str (match-beginning 1) (match-end 1)) - (if arg (int-to-string arg) "") - (substring str (match-beginning 2) (match-end 2))))) - ) - str - ) - -(defun gud-read-address () - "Return a string containing the core-address found in the buffer at point." - (save-excursion - (let ((pt (point)) found begin) - (setq found (if (search-backward "0x" (- pt 7) t) (point))) - (cond - (found (forward-char 2) - (buffer-substring found - (progn (re-search-forward "[^0-9a-f]") - (forward-char -1) - (point)))) - (t (setq begin (progn (re-search-backward "[^0-9]") - (forward-char 1) - (point))) - (forward-char 1) - (re-search-forward "[^0-9]") - (forward-char -1) - (buffer-substring begin (point))))))) - -(defun gud-call (fmt &optional arg) - (let ((msg (gud-format-command fmt arg))) - (message "Command: %s" msg) - (sit-for 0) - (gud-basic-call msg))) - -(defun gud-basic-call (command) - "Invoke the debugger COMMAND displaying source in other window." - (interactive) - (gud-set-buffer) - (let ((proc (get-buffer-process gud-comint-buffer))) - - ;; Arrange for the current prompt to get deleted. - (save-excursion - (set-buffer gud-comint-buffer) - (goto-char (process-mark proc)) - (beginning-of-line) - (if (looking-at comint-prompt-regexp) - (set-marker gud-delete-prompt-marker (point))) - (apply comint-input-sender (list proc command))))) - -(defun gud-refresh (&optional arg) - "Fix up a possibly garbled display, and redraw the arrow." - (interactive "P") - (recenter arg) - (or gud-last-frame (setq gud-last-frame gud-last-last-frame)) - (gud-display-frame)) - -;;; Count windows on a given frame -;; -(defun count-frame-windows (frame &optional minibuf) - "Returns the number of visible windows on FRAME. -Optional arg NO-MINI non-nil means don't count the minibuffer -even if it is active." - (let ((count 0)) - (walk-windows (function (lambda (w) - (if (eq (window-frame w) frame) - (setq count (+ count 1))))) - minibuf t) - count)) - - -;; Attempt to fit a frame so that it is just large enough to display buf -;; Only changes the frame size if it has just one window and we can only -;; make the attempt if the buffer has truncate-lines set (otherwise it's -;; too painful to work out how many lines we need. -;; Doesn't even *attempt* to cope with fontified buffers. - -(defun fit-frame-to-buffer (frame buf) - (let (height-needed) - (if (and frame - truncate-lines - (<= (count-frame-windows frame) 1)) - (progn - (setq height-needed - (+ (count-lines (point-min) (point-max)) 2)) - (cond - ((> (frame-height frame) height-needed) - (set-frame-height frame height-needed)) - ((< height-needed 24) - (set-frame-height frame height-needed)) - (t - (set-frame-height frame 24))))))) - -;;; Code for parsing expressions out of C code. The single entry point is -;;; find-c-expr, which tries to return an lvalue expression from around point. -;;; -;;; The rest of this file is a hacked version of gdbsrc.el by -;;; Debby Ayers <ayers@asc.slb.com>, -;;; Rich Schaefer <schaefer@asc.slb.com> Schlumberger, Austin, Tx. - -(defun find-c-expr () - "Returns the C expr that surrounds point." - (interactive) - (save-excursion - (let ((p) (expr) (test-expr)) - (setq p (point)) - (setq expr (expr-cur)) - (setq test-expr (expr-prev)) - (while (expr-compound test-expr expr) - (setq expr (cons (car test-expr) (cdr expr))) - (goto-char (car expr)) - (setq test-expr (expr-prev))) - (goto-char p) - (setq test-expr (expr-next)) - (while (expr-compound expr test-expr) - (setq expr (cons (car expr) (cdr test-expr))) - (setq test-expr (expr-next)) - ) - (buffer-substring (car expr) (cdr expr))))) - -(defun expr-cur () - "Returns the expr that point is in; point is set to beginning of expr. -The expr is represented as a cons cell, where the car specifies the point in -the current buffer that marks the beginning of the expr and the cdr specifies -the character after the end of the expr." - (let ((p (point)) (begin) (end)) - (expr-backward-sexp) - (setq begin (point)) - (expr-forward-sexp) - (setq end (point)) - (if (>= p end) - (progn - (setq begin p) - (goto-char p) - (expr-forward-sexp) - (setq end (point)) - ) - ) - (goto-char begin) - (cons begin end))) - -(defun expr-backward-sexp () - "Version of `backward-sexp' that catches errors." - (condition-case nil - (backward-sexp) - (error t))) - -(defun expr-forward-sexp () - "Version of `forward-sexp' that catches errors." - (condition-case nil - (forward-sexp) - (error t))) - -(defun expr-prev () - "Returns the previous expr, point is set to beginning of that expr. -The expr is represented as a cons cell, where the car specifies the point in -the current buffer that marks the beginning of the expr and the cdr specifies -the character after the end of the expr" - (let ((begin) (end)) - (expr-backward-sexp) - (setq begin (point)) - (expr-forward-sexp) - (setq end (point)) - (goto-char begin) - (cons begin end))) - -(defun expr-next () - "Returns the following expr, point is set to beginning of that expr. -The expr is represented as a cons cell, where the car specifies the point in -the current buffer that marks the beginning of the expr and the cdr specifies -the character after the end of the expr." - (let ((begin) (end)) - (expr-forward-sexp) - (expr-forward-sexp) - (setq end (point)) - (expr-backward-sexp) - (setq begin (point)) - (cons begin end))) - -(defun expr-compound-sep (span-start span-end) - "Returns '.' for '->' & '.', returns ' ' for white space, -returns '?' for other punctuation." - (let ((result ? ) - (syntax)) - (while (< span-start span-end) - (setq syntax (char-syntax (char-after span-start))) - (cond - ((= syntax ? ) t) - ((= syntax ?.) (setq syntax (char-after span-start)) - (cond - ((= syntax ?.) (setq result ?.)) - ((and (= syntax ?-) (= (char-after (+ span-start 1)) ?>)) - (setq result ?.) - (setq span-start (+ span-start 1))) - (t (setq span-start span-end) - (setq result ??))))) - (setq span-start (+ span-start 1))) - result)) - -(defun expr-compound (first second) - "Non-nil if concatenating FIRST and SECOND makes a single C token. -The two exprs are represented as a cons cells, where the car -specifies the point in the current buffer that marks the beginning of the -expr and the cdr specifies the character after the end of the expr. -Link exprs of the form: - Expr -> Expr - Expr . Expr - Expr (Expr) - Expr [Expr] - (Expr) Expr - [Expr] Expr" - (let ((span-start (cdr first)) - (span-end (car second)) - (syntax)) - (setq syntax (expr-compound-sep span-start span-end)) - (cond - ((= (car first) (car second)) nil) - ((= (cdr first) (cdr second)) nil) - ((= syntax ?.) t) - ((= syntax ? ) - (setq span-start (char-after (- span-start 1))) - (setq span-end (char-after span-end)) - (cond - ((= span-start ?) ) t ) - ((= span-start ?] ) t ) - ((= span-end ?( ) t ) - ((= span-end ?[ ) t ) - (t nil)) - ) - (t nil)))) - - -;;; Compare two buffers. We assume that they're not narrowed. -(defun gud-buffers-differ (buffer1 buffer2) - (save-excursion - (let ((size1 (progn (set-buffer buffer1) (buffer-size))) - (size2 (progn (set-buffer buffer2) (buffer-size)))) - (cond - ((not (= size1 size2)) - t) - ((= (compare-buffer-substrings - buffer1 1 size1 - buffer2 1 size2) 0) - nil) - (t))))) - - -(provide 'gud) - -;; WTF -(defmacro gud (form) - (` (save-excursion (set-buffer "*gud-a.out*") (, form)))) - -(defun dbug (foo &optional fun) - (save-excursion - (set-buffer (get-buffer-create "*trace*")) - (goto-char (point-max)) - (insert "***" (symbol-name foo) "\n") - (if fun - (funcall fun)))) - - - -;;; gud.el ends here
--- a/lisp/comint/history.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,175 +0,0 @@ -;;; history.el --- Generic history stuff - -;; Copyright (C) 1989 Free Software Foundation, Inc. - -;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Synched up with: Not in FSF - -;;; Commentary: - -;; suggested generic history stuff -- tale - -;; This is intended to provided easy access to a list of elements -;; being kept as a history ring. - -;; To use, variables for a list and the index to it need to be kept, and -;; a limit to how large the list can grow. Short wrappers can than be provided -;; to interact with these functions. - -;; For example, a typical application of this is in interactive processes, -;; like shell or gdb. A history can be kept of commands that are sent -;; to the process so that they are easily retrieved for re-inspection or -;; re-use. Using process "foo" to illustrate: - -;; Variable foo-history will be the list. foo-history-index would be the -;; pointer to the current item within the list; it is based with 0 being -;; the most recent element added to the list. foo-history-size can be a -;; user-variable which controls how many items are allowed to exist. - -;; The following functions could interactive with the list; foo-mark -;; in these examples trackes the end of output from foo-process. - -;; (defun foo-history-previous (arg) ;; Suggested binding: C-c C-p -;; "Retrieve the previous command sent to the foo process. -;; ARG means to select that message out of the list (0 is the first)." -;; (interactive "P") -;; (history-fetch 'foo-history 'foo-history-index (or arg 'previous) -;; foo-mark (point-max))) - -;; foo-history-next would look practically the same, but substituting "next" -;; for "previous". Suggested binding: C-c C-n - -;; (defun foo-history-clear () ;; Suggested binding: C-c C-u -;; "Clear the input region for the foo-process and reset history location." -;; (interactive) -;; (delete-region foo-mark (goto-char (point-max)))) - -;; To get the history on the stack, an extremely minimal function would look -;; something like this, probably bound to RET: - -;; (defun foo-send () -;; "Send a command to foo-process." -;; (interactive) -;; (let ((str (buffer-substring foo-mark (goto-char (point-max))))) -;; (insert ?\C-j) -;; (setq foo-history-index -1) ; reset the index -;; (set-marker foo-mark (point)) -;; (send-string foo-process str) -;; (history-add 'foo-history str foo-history-size))) - -;; ToDo: history-isearch - -;;; Code: - -(provide 'history) - -(defvar history-last-search "" - "The last regexp used by history-search which resulted in a match.") - -(defun history-add (list item size) - "At the head of LIST append ITEM. Limit the length of LIST to SIZE elements. -LIST should be the name of the list." - (set list (append (list item) (eval list))) - (let ((elist (eval list))) - (if (> (length elist) size) - (setcdr (nthcdr (1- size) elist) nil)))) - -(defun history-fetch (list index dir &optional beg end) - "Retrieve an entry from LIST, working from INDEX in direction DIR. -LIST should be the name of the list, for message purposes. INDEX should be -the name of the variable used to index the list, so it can be maintained. -DIR non-nil means to use previous entry, unless it is the symbol ``next'' -to get the next entry or a number to get an absolute reference. DIR -nil is equivalent to ``next''. - -If optional numeric argument BEG is preset, it is taken as the point to insert -the entry in the current buffer, leaving point at the start of the entry. -If followed by a numeric END, the region between BEG and END will be deleted -before the entry is inserted." - (let (str (eind (eval index)) (elist (eval list))) - (cond - ((numberp dir) - (setq str (nth dir elist)) - (if str (set index dir) (message "No entry %d in %s." dir list))) - ((or (not dir) (eq dir 'next)) - (if (= eind -1) - (message "No next entry in %s." list) - (set index (1- eind)) - (setq str (if (zerop eind) "" (nth (1- eind) elist))))) - (t - (if (>= (1+ eind) (length elist)) - (message "No previous entry in %s." list) - (set index (1+ eind)) - (setq str (nth (1+ eind) elist))))) - (if (not (and (integer-or-marker-p beg) str)) () - (if (integer-or-marker-p end) (delete-region beg end)) - (insert str) - (goto-char beg)) - str)) - -(defun history-search (list index dir regexp &optional beg end) - "In history LIST, starting at INDEX and working in direction DIR, find REGEXP. -LIST and INDEX should be their respective symbol names. DIR nil or 'forward -means to search from the current index toward the most recent history entry. -DIR non-nil means to search toward the oldest entry. The current entry is -not checked in either case. - -If an entry is found and optional numeric argument BEG exists then the entry -will be inserted there and point left at BEG. If numeric END also exists -then the region will be deleted between BEG and END." - (let* ((forw (or (not dir) (eq dir 'forward))) str found - (eind (eval index)) - (elist (eval list)) - (slist (if forw - (nthcdr (- (length elist) eind) (reverse elist)) - (nthcdr (1+ eind) elist)))) - (while (and (not found) slist) - (if (string-match regexp (car slist)) - (setq found (car slist) - history-last-search regexp)) - (setq eind (+ (if forw -1 1) eind) - slist (cdr slist))) - (if (not found) - (error "\"%s\" not found %s in %s" - regexp (if forw "forward" "backward") list) - (set index eind) - (if (not (integer-or-marker-p beg)) () - (if (integer-or-marker-p end) (delete-region beg end)) - (insert found) - (goto-char beg))) - found)) - -(defun history-menu (list buffer &optional notemp) - "Show the history kept by LIST in BUFFER. -This function will use ``with-output-to-temp-buffer'' unless optional third -argument NOTEMP is non-nil." - (let ((pop-up-windows t) (line 0) - (menu - (mapconcat (function (lambda (item) - (setq line (1+ line)) - (format (format "%%%dd: %%s" - (int-to-string (length list))) - line item))) - list "\n"))) - (if notemp - (save-excursion - (insert menu) - (display-buffer buffer)) - (with-output-to-temp-buffer buffer (princ menu))))) - -;;; history.el ends here
--- a/lisp/comint/inf-lisp.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,636 +0,0 @@ -;;; inf-lisp.el --- an inferior-lisp mode -;;; Copyright (C) 1988, 1993, 1994 Free Software Foundation, Inc. - -;; Author: Olin Shivers <shivers@cs.cmu.edu> -;; Keywords: processes, lisp - -;; 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. - -;;; Commentary: - -;;; Hacked from tea.el by Olin Shivers (shivers@cs.cmu.edu). 8/88 - -;;; This file defines a a lisp-in-a-buffer package (inferior-lisp -;;; mode) built on top of comint mode. This version is more -;;; featureful, robust, and uniform than the Emacs 18 version. The -;;; key bindings are also more compatible with the bindings of Hemlock -;;; and Zwei (the Lisp Machine emacs). - -;;; Since this mode is built on top of the general command-interpreter-in- -;;; a-buffer mode (comint mode), it shares a common base functionality, -;;; and a common set of bindings, with all modes derived from comint mode. -;;; This makes these modes easier to use. - -;;; For documentation on the functionality provided by comint mode, and -;;; the hooks available for customizing it, see the file comint.el. -;;; For further information on inferior-lisp mode, see the comments below. - -;;; Needs fixin: -;;; The load-file/compile-file default mechanism could be smarter -- it -;;; doesn't know about the relationship between filename extensions and -;;; whether the file is source or executable. If you compile foo.lisp -;;; with compile-file, then the next load-file should use foo.bin for -;;; the default, not foo.lisp. This is tricky to do right, particularly -;;; because the extension for executable files varies so much (.o, .bin, -;;; .lbin, .mo, .vo, .ao, ...). -;;; -;;; It would be nice if inferior-lisp (and inferior scheme, T, ...) modes -;;; had a verbose minor mode wherein sending or compiling defuns, etc. -;;; would be reflected in the transcript with suitable comments, e.g. -;;; ";;; redefining fact". Several ways to do this. Which is right? -;;; -;;; When sending text from a source file to a subprocess, the process-mark can -;;; move off the window, so you can lose sight of the process interactions. -;;; Maybe I should ensure the process mark is in the window when I send -;;; text to the process? Switch selectable? - -;;; Code: - -(require 'comint) -(require 'lisp-mode) - - -;;;jwz: ilisp is better, don't ###autoload -(defvar inferior-lisp-filter-regexp "\\`\\s *\\(:\\(\\w\\|\\s_\\)\\)?\\s *\\'" - "*What not to save on inferior Lisp's input history. -Input matching this regexp is not saved on the input history in Inferior Lisp -mode. Default is whitespace followed by 0 or 1 single-letter colon-keyword -\(as in :a, :c, etc.)") - -(defvar inferior-lisp-mode-map nil) -(cond ((not inferior-lisp-mode-map) - (setq inferior-lisp-mode-map (make-sparse-keymap)) - (set-keymap-name inferior-lisp-mode-map 'inferior-lisp-mode-map) - (set-keymap-parents inferior-lisp-mode-map - (list comint-mode-map shared-lisp-mode-map)) - (define-key inferior-lisp-mode-map "\C-x\C-e" 'lisp-eval-last-sexp) - (define-key inferior-lisp-mode-map "\C-c\C-l" 'lisp-load-file) - (define-key inferior-lisp-mode-map "\C-c\C-k" 'lisp-compile-file) - (define-key inferior-lisp-mode-map "\C-c\C-a" 'lisp-show-arglist) - (define-key inferior-lisp-mode-map "\C-c\C-d" 'lisp-describe-sym) - (define-key inferior-lisp-mode-map "\C-c\C-f" - 'lisp-show-function-documentation) - (define-key inferior-lisp-mode-map "\C-c\C-v" - 'lisp-show-variable-documentation))) - -;;; These commands augment Lisp mode, so you can process Lisp code in -;;; the source files. -(define-key lisp-mode-map "\M-\C-x" 'lisp-eval-defun) ; Gnu convention -(define-key lisp-mode-map "\C-x\C-e" 'lisp-eval-last-sexp) ; Gnu convention -(define-key lisp-mode-map "\C-c\C-e" 'lisp-eval-defun) -(define-key lisp-mode-map "\C-c\C-r" 'lisp-eval-region) -(define-key lisp-mode-map "\C-c\C-c" 'lisp-compile-defun) -(define-key lisp-mode-map "\C-c\C-z" 'switch-to-lisp) -(define-key lisp-mode-map "\C-c\C-l" 'lisp-load-file) -(define-key lisp-mode-map "\C-c\C-k" 'lisp-compile-file) ; "kompile" file -(define-key lisp-mode-map "\C-c\C-a" 'lisp-show-arglist) -(define-key lisp-mode-map "\C-c\C-d" 'lisp-describe-sym) -(define-key lisp-mode-map "\C-c\C-f" 'lisp-show-function-documentation) -(define-key lisp-mode-map "\C-c\C-v" 'lisp-show-variable-documentation) - -;;; This function exists for backwards compatibility. -;;; Previous versions of this package bound commands to C-c <letter> -;;; bindings, which is not allowed by the gnumacs standard. - -;;; "This function binds many inferior-lisp commands to C-c <letter> bindings, -;;;where they are more accessible. C-c <letter> bindings are reserved for the -;;;user, so these bindings are non-standard. If you want them, you should -;;;have this function called by the inferior-lisp-load-hook: -;;; (setq inferior-lisp-load-hook '(inferior-lisp-install-letter-bindings)) -;;;You can modify this function to install just the bindings you want." -(defun inferior-lisp-install-letter-bindings () - (define-key lisp-mode-map "\C-ce" 'lisp-eval-defun-and-go) - (define-key lisp-mode-map "\C-cr" 'lisp-eval-region-and-go) - (define-key lisp-mode-map "\C-cc" 'lisp-compile-defun-and-go) - (define-key lisp-mode-map "\C-cz" 'switch-to-lisp) - (define-key lisp-mode-map "\C-cl" 'lisp-load-file) - (define-key lisp-mode-map "\C-ck" 'lisp-compile-file) - (define-key lisp-mode-map "\C-ca" 'lisp-show-arglist) - (define-key lisp-mode-map "\C-cd" 'lisp-describe-sym) - (define-key lisp-mode-map "\C-cf" 'lisp-show-function-documentation) - (define-key lisp-mode-map "\C-cv" 'lisp-show-variable-documentation) - - (define-key inferior-lisp-mode-map "\C-cl" 'lisp-load-file) - (define-key inferior-lisp-mode-map "\C-ck" 'lisp-compile-file) - (define-key inferior-lisp-mode-map "\C-ca" 'lisp-show-arglist) - (define-key inferior-lisp-mode-map "\C-cd" 'lisp-describe-sym) - (define-key inferior-lisp-mode-map "\C-cf" 'lisp-show-function-documentation) - (define-key inferior-lisp-mode-map "\C-cv" - 'lisp-show-variable-documentation)) - - -;;;jwz: ilisp is better, don't ###autoload -(defvar inferior-lisp-program "lisp" - "*Program name for invoking an inferior Lisp with for Inferior Lisp mode.") - -;;;jwz: ilisp is better, don't ###autoload -(defvar inferior-lisp-load-command "(load \"%s\")\n" - "*Format-string for building a Lisp expression to load a file. -This format string should use `%s' to substitute a file name -and should result in a Lisp expression that will command the inferior Lisp -to load that file. The default works acceptably on most Lisps. -The string \"(progn (load \\\"%s\\\" :verbose nil :print t) (values))\\n\" -produces cosmetically superior output for this application, -but it works only in Common Lisp.") - -;;;jwz: ilisp is better, don't ###autoload -(defvar inferior-lisp-prompt "^[^> \n]*>+:? *" - "Regexp to recognise prompts in the Inferior Lisp mode. -Defaults to \"^[^> \\n]*>+:? *\", which works pretty good for Lucid, kcl, -and franz. This variable is used to initialize `comint-prompt-regexp' in the -Inferior Lisp buffer. - -More precise choices: -Lucid Common Lisp: \"^\\\\(>\\\\|\\\\(->\\\\)+\\\\) *\" -franz: \"^\\\\(->\\\\|<[0-9]*>:\\\\) *\" -kcl: \"^>+ *\" - -This is a fine thing to set in your .emacs file.") - -(defvar inferior-lisp-buffer nil "*The current inferior-lisp process buffer. - -MULTIPLE PROCESS SUPPORT -=========================================================================== -To run multiple Lisp processes, you start the first up -with \\[inferior-lisp]. It will be in a buffer named `*inferior-lisp*'. -Rename this buffer with \\[rename-buffer]. You may now start up a new -process with another \\[inferior-lisp]. It will be in a new buffer, -named `*inferior-lisp*'. You can switch between the different process -buffers with \\[switch-to-buffer]. - -Commands that send text from source buffers to Lisp processes -- -like `lisp-eval-defun' or `lisp-show-arglist' -- have to choose a process -to send to, when you have more than one Lisp process around. This -is determined by the global variable `inferior-lisp-buffer'. Suppose you -have three inferior Lisps running: - Buffer Process - foo inferior-lisp - bar inferior-lisp<2> - *inferior-lisp* inferior-lisp<3> -If you do a \\[lisp-eval-defun] command on some Lisp source code, -what process do you send it to? - -- If you're in a process buffer (foo, bar, or *inferior-lisp*), - you send it to that process. -- If you're in some other buffer (e.g., a source file), you - send it to the process attached to buffer `inferior-lisp-buffer'. -This process selection is performed by function `inferior-lisp-proc'. - -Whenever \\[inferior-lisp] fires up a new process, it resets -`inferior-lisp-buffer' to be the new process's buffer. If you only run -one process, this does the right thing. If you run multiple -processes, you can change `inferior-lisp-buffer' to another process -buffer with \\[set-variable].") - -;;;jwz: ilisp is better, don't ###autoload -(defvar inferior-lisp-mode-hook '() - "*Hook for customizing Inferior Lisp mode.") - -(defun inferior-lisp-mode () - "Major mode for interacting with an inferior Lisp process. -Runs a Lisp interpreter as a subprocess of Emacs, with Lisp I/O through an -Emacs buffer. Variable `inferior-lisp-program' controls which Lisp interpreter -is run. Variables `inferior-lisp-prompt', `inferior-lisp-filter-regexp' and -`inferior-lisp-load-command' can customize this mode for different Lisp -interpreters. - -For information on running multiple processes in multiple buffers, see -documentation for variable `inferior-lisp-buffer'. - -\\{inferior-lisp-mode-map} - -Customization: Entry to this mode runs the hooks on `comint-mode-hook' and -`inferior-lisp-mode-hook' (in that order). - -You can send text to the inferior Lisp process from other buffers containing -Lisp source. - switch-to-lisp switches the current buffer to the Lisp process buffer. - lisp-eval-defun sends the current defun to the Lisp process. - lisp-compile-defun compiles the current defun. - lisp-eval-region sends the current region to the Lisp process. - lisp-compile-region compiles the current region. - - Prefixing the lisp-eval/compile-defun/region commands with - a \\[universal-argument] causes a switch to the Lisp process buffer after sending - the text. - -Commands: -Return after the end of the process' output sends the text from the - end of process to point. -Return before the end of the process' output copies the sexp ending at point - to the end of the process' output, and sends it. -Delete converts tabs to spaces as it moves back. -Tab indents for Lisp; with argument, shifts rest - of expression rigidly with the current line. -C-M-q does Tab on each line starting within following expression. -Paragraphs are separated only by blank lines. Semicolons start comments. -If you accidentally suspend your process, use \\[comint-continue-subjob] -to continue it." - (interactive) - (comint-mode) - (setq comint-prompt-regexp inferior-lisp-prompt) - (setq major-mode 'inferior-lisp-mode) - (setq mode-name "Inferior Lisp") - (setq mode-line-process '(":%s")) - (lisp-mode-variables t) - (use-local-map inferior-lisp-mode-map) ;c-c c-k for "kompile" file - (setq comint-get-old-input (function lisp-get-old-input)) - (setq comint-input-filter (function lisp-input-filter)) - (setq comint-input-sentinel 'ignore) - (run-hooks 'inferior-lisp-mode-hook)) - -(defun lisp-get-old-input () - "Return a string containing the sexp ending at point." - (save-excursion - (let ((end (point))) - (backward-sexp) - (buffer-substring (point) end)))) - -(defun lisp-input-filter (str) - "t if STR does not match `inferior-lisp-filter-regexp'." - (not (string-match inferior-lisp-filter-regexp str))) - -;;;jwz: ilisp is better, don't ###autoload -(defun inferior-lisp (cmd) - "Run an inferior Lisp process, input and output via buffer `*inferior-lisp*'. -If there is a process already running in `*inferior-lisp*', just switch -to that buffer. -With argument, allows you to edit the command line (default is value -of `inferior-lisp-program'). Runs the hooks from -`inferior-lisp-mode-hook' (after the `comint-mode-hook' is run). -\(Type \\[describe-mode] in the process buffer for a list of commands.)" - (interactive (list (if current-prefix-arg - (read-string "Run lisp: " inferior-lisp-program) - inferior-lisp-program))) - (if (not (comint-check-proc "*inferior-lisp*")) - (let ((cmdlist (inferior-lisp-args-to-list cmd))) - (set-buffer (apply (function make-comint) - "inferior-lisp" (car cmdlist) nil (cdr cmdlist))) - (inferior-lisp-mode))) - (setq inferior-lisp-buffer "*inferior-lisp*") - (pop-to-buffer "*inferior-lisp*")) -;;;###autoload (add-hook 'same-window-buffer-names "*inferior-lisp*") - -;;;jwz: ilisp is better, don't ###autoload -(define-function 'run-lisp 'inferior-lisp) - -;;; Break a string up into a list of arguments. -;;; This will break if you have an argument with whitespace, as in -;;; string = "-ab +c -x 'you lose'". -(defun inferior-lisp-args-to-list (string) - (let ((where (string-match "[ \t]" string))) - (cond ((null where) (list string)) - ((not (= where 0)) - (cons (substring string 0 where) - (inferior-lisp-args-to-list (substring string (+ 1 where) - (length string))))) - (t (let ((pos (string-match "[^ \t]" string))) - (if (null pos) - nil - (inferior-lisp-args-to-list (substring string pos - (length string))))))))) - -(defun lisp-eval-region (start end &optional and-go) - "Send the current region to the inferior Lisp process. -Prefix argument means switch to the Lisp buffer afterwards." - (interactive "r\nP") - (comint-send-region (inferior-lisp-proc) start end) - (comint-send-string (inferior-lisp-proc) "\n") - (if and-go (switch-to-lisp t))) - -(defun lisp-eval-defun (&optional and-go) - "Send the current defun to the inferior Lisp process. -Prefix argument means switch to the Lisp buffer afterwards." - (interactive "P") - (save-excursion - (end-of-defun) - (skip-chars-backward " \t\n\r\f") ; Makes allegro happy - (let ((end (point))) - (beginning-of-defun) - (lisp-eval-region (point) end))) - (if and-go (switch-to-lisp t))) - -(defun lisp-eval-last-sexp (&optional and-go) - "Send the previous sexp to the inferior Lisp process. -Prefix argument means switch to the Lisp buffer afterwards." - (interactive "P") - (lisp-eval-region (save-excursion (backward-sexp) (point)) (point) and-go)) - -;;; Common Lisp COMPILE sux. -(defun lisp-compile-region (start end &optional and-go) - "Compile the current region in the inferior Lisp process. -Prefix argument means switch to the Lisp buffer afterwards." - (interactive "r\nP") - (comint-send-string - (inferior-lisp-proc) - (format "(funcall (compile nil `(lambda () (progn 'compile %s))))\n" - (buffer-substring start end))) - (if and-go (switch-to-lisp t))) - -(defun lisp-compile-defun (&optional and-go) - "Compile the current defun in the inferior Lisp process. -Prefix argument means switch to the Lisp buffer afterwards." - (interactive "P") - (save-excursion - (end-of-defun) - (skip-chars-backward " \t\n\r\f") ; Makes allegro happy - (let ((e (point))) - (beginning-of-defun) - (lisp-compile-region (point) e))) - (if and-go (switch-to-lisp t))) - -(defun switch-to-lisp (eob-p) - "Switch to the inferior Lisp process buffer. -With argument, positions cursor at end of buffer." - (interactive "P") - (if (get-buffer inferior-lisp-buffer) - (pop-to-buffer inferior-lisp-buffer) - (error "No current inferior Lisp buffer")) - (cond (eob-p - (push-mark) - (goto-char (point-max))))) - - -;;; Now that lisp-compile/eval-defun/region takes an optional prefix arg, -;;; these commands are redundant. But they are kept around for the user -;;; to bind if he wishes, for backwards functionality, and because it's -;;; easier to type C-c e than C-u C-c C-e. - -(defun lisp-eval-region-and-go (start end) - "Send the current region to the inferior Lisp, and switch to its buffer." - (interactive "r") - (lisp-eval-region start end t)) - -(defun lisp-eval-defun-and-go () - "Send the current defun to the inferior Lisp, and switch to its buffer." - (interactive) - (lisp-eval-defun t)) - -(defun lisp-compile-region-and-go (start end) - "Compile the current region in the inferior Lisp, and switch to its buffer." - (interactive "r") - (lisp-compile-region start end t)) - -(defun lisp-compile-defun-and-go () - "Compile the current defun in the inferior Lisp, and switch to its buffer." - (interactive) - (lisp-compile-defun t)) - -;;; A version of the form in H. Shevis' soar-mode.el package. Less robust. -;;; (defun lisp-compile-sexp (start end) -;;; "Compile the s-expression bounded by START and END in the inferior lisp. -;;; If the sexp isn't a DEFUN form, it is evaluated instead." -;;; (cond ((looking-at "(defun\\s +") -;;; (goto-char (match-end 0)) -;;; (let ((name-start (point))) -;;; (forward-sexp 1) -;;; (process-send-string "inferior-lisp" -;;; (format "(compile '%s #'(lambda " -;;; (buffer-substring name-start -;;; (point))))) -;;; (let ((body-start (point))) -;;; (goto-char start) (forward-sexp 1) ; Can't use end-of-defun. -;;; (process-send-region "inferior-lisp" -;;; (buffer-substring body-start (point)))) -;;; (process-send-string "inferior-lisp" ")\n")) -;;; (t (lisp-eval-region start end))))) -;;; -;;; (defun lisp-compile-region (start end) -;;; "Each s-expression in the current region is compiled (if a DEFUN) -;;; or evaluated (if not) in the inferior lisp." -;;; (interactive "r") -;;; (save-excursion -;;; (goto-char start) (end-of-defun) (beginning-of-defun) ; error check -;;; (if (< (point) start) (error "region begins in middle of defun")) -;;; (goto-char start) -;;; (let ((s start)) -;;; (end-of-defun) -;;; (while (<= (point) end) ; Zip through -;;; (lisp-compile-sexp s (point)) ; compiling up defun-sized chunks. -;;; (setq s (point)) -;;; (end-of-defun)) -;;; (if (< s end) (lisp-compile-sexp s end))))) -;;; -;;; End of HS-style code - - -(defvar lisp-prev-l/c-dir/file nil - "Record last directory and file used in loading or compiling. -This holds a cons cell of the form `(DIRECTORY . FILE)' -describing the last `lisp-load-file' or `lisp-compile-file' command.") - -(defvar lisp-source-modes '(lisp-mode) - "*Used to determine if a buffer contains Lisp source code. -If it's loaded into a buffer that is in one of these major modes, it's -considered a Lisp source file by `lisp-load-file' and `lisp-compile-file'. -Used by these commands to determine defaults.") - -(defun lisp-load-file (file-name) - "Load a Lisp file into the inferior Lisp process." - (interactive (comint-get-source "Load Lisp file: " lisp-prev-l/c-dir/file - lisp-source-modes nil)) ; NIL because LOAD - ; doesn't need an exact name - (comint-check-source file-name) ; Check to see if buffer needs saved. - (setq lisp-prev-l/c-dir/file (cons (file-name-directory file-name) - (file-name-nondirectory file-name))) - (comint-send-string (inferior-lisp-proc) - (format inferior-lisp-load-command file-name)) - (switch-to-lisp t)) - -(defun lisp-compile-file (file-name) - "Compile a Lisp file in the inferior Lisp process." - (interactive (comint-get-source "Compile Lisp file: " lisp-prev-l/c-dir/file - lisp-source-modes nil)) ; NIL = don't need - ; suffix .lisp - (comint-check-source file-name) ; Check to see if buffer needs saved. - (setq lisp-prev-l/c-dir/file (cons (file-name-directory file-name) - (file-name-nondirectory file-name))) - (comint-send-string (inferior-lisp-proc) (concat "(compile-file \"" - file-name - "\"\)\n")) - (switch-to-lisp t)) - - - -;;; Documentation functions: function doc, var doc, arglist, and -;;; describe symbol. -;;; =========================================================================== - -;;; Command strings -;;; =============== - -(defvar lisp-function-doc-command - "(let ((fn '%s)) - (format t \"Documentation for ~a:~&~a\" - fn (documentation fn 'function)) - (values))\n" - "Command to query inferior Lisp for a function's documentation.") - -(defvar lisp-var-doc-command - "(let ((v '%s)) - (format t \"Documentation for ~a:~&~a\" - v (documentation v 'variable)) - (values))\n" - "Command to query inferior Lisp for a variable's documentation.") - -(defvar lisp-arglist-command - "(let ((fn '%s)) - (format t \"Arglist for ~a: ~a\" fn (arglist fn)) - (values))\n" - "Command to query inferior Lisp for a function's arglist.") - -(defvar lisp-describe-sym-command - "(describe '%s)\n" - "Command to query inferior Lisp for a variable's documentation.") - - -;;; Ancillary functions -;;; =================== - -;;; Reads a string from the user. -(defun lisp-symprompt (prompt default) - (list (let* ((prompt (if default - (format "%s (default %s): " prompt default) - (concat prompt ": "))) - (ans (read-string prompt))) - (if (zerop (length ans)) default ans)))) - - -;;; Adapted from function-called-at-point in help.el. -(defun lisp-fn-called-at-pt () - "Returns the name of the function called in the current call. -The value is nil if it can't find one." - (condition-case nil - (save-excursion - (save-restriction - (narrow-to-region (max (point-min) (- (point) 1000)) (point-max)) - (backward-up-list 1) - (forward-char 1) - (let ((obj (read (current-buffer)))) - (and (symbolp obj) obj)))) - (error nil))) - - -;;; Adapted from variable-at-point in help.el. -(defun lisp-var-at-pt () - (condition-case () - (save-excursion - (forward-sexp -1) - (skip-chars-forward "'") - (let ((obj (read (current-buffer)))) - (and (symbolp obj) obj))) - (error nil))) - - -;;; Documentation functions: fn and var doc, arglist, and symbol describe. -;;; ====================================================================== - -(defun lisp-show-function-documentation (fn) - "Send a command to the inferior Lisp to give documentation for function FN. -See variable `lisp-function-doc-command'." - (interactive (lisp-symprompt "Function doc" (lisp-fn-called-at-pt))) - (comint-proc-query (inferior-lisp-proc) - (format lisp-function-doc-command fn))) - -(defun lisp-show-variable-documentation (var) - "Send a command to the inferior Lisp to give documentation for function FN. -See variable `lisp-var-doc-command'." - (interactive (lisp-symprompt "Variable doc" (lisp-var-at-pt))) - (comint-proc-query (inferior-lisp-proc) (format lisp-var-doc-command var))) - -(defun lisp-show-arglist (fn) - "Send a query to the inferior Lisp for the arglist for function FN. -See variable `lisp-arglist-command'." - (interactive (lisp-symprompt "Arglist" (lisp-fn-called-at-pt))) - (comint-proc-query (inferior-lisp-proc) (format lisp-arglist-command fn))) - -(defun lisp-describe-sym (sym) - "Send a command to the inferior Lisp to describe symbol SYM. -See variable `lisp-describe-sym-command'." - (interactive (lisp-symprompt "Describe" (lisp-var-at-pt))) - (comint-proc-query (inferior-lisp-proc) - (format lisp-describe-sym-command sym))) - - -;; "Returns the current inferior Lisp process. -;; See variable `inferior-lisp-buffer'." -(defun inferior-lisp-proc () - (let ((proc (get-buffer-process (if (eq major-mode 'inferior-lisp-mode) - (current-buffer) - inferior-lisp-buffer)))) - (or proc - (error "No Lisp subprocess; see variable `inferior-lisp-buffer'")))) - - -;;; Do the user's customization... -;;;=============================== -(defvar inferior-lisp-load-hook nil - "This hook is run when the library `inf-lisp' is loaded. -This is a good place to put keybindings.") - -(run-hooks 'inferior-lisp-load-hook) - -;;; CHANGE LOG -;;; =========================================================================== -;;; 7/21/92 Jim Blandy -;;; - Changed all uses of the cmulisp name or prefix to inferior-lisp; -;;; this is now the official inferior lisp package. Use the global -;;; ChangeLog from now on. -;;; 5/24/90 Olin -;;; - Split cmulisp and cmushell modes into separate files. -;;; Not only is this a good idea, it's apparently the way it'll be rel 19. -;;; - Upgraded process sends to use comint-send-string instead of -;;; process-send-string. -;;; - Explicit references to process "cmulisp" have been replaced with -;;; (cmulisp-proc). This allows better handling of multiple process bufs. -;;; - Added process query and var/function/symbol documentation -;;; commands. Based on code written by Douglas Roberts. -;;; - Added lisp-eval-last-sexp, bound to C-x C-e. -;;; -;;; 9/20/90 Olin -;;; Added a save-restriction to lisp-fn-called-at-pt. This bug and fix -;;; reported by Lennart Staflin. -;;; -;;; 3/12/90 Olin -;;; - lisp-load-file and lisp-compile-file no longer switch-to-lisp. -;;; Tale suggested this. -;;; - Reversed this decision 7/15/91. You need the visual feedback. -;;; -;;; 7/25/91 Olin -;;; Changed all keybindings of the form C-c <letter>. These are -;;; supposed to be reserved for the user to bind. This affected -;;; mainly the compile/eval-defun/region[-and-go] commands. -;;; This was painful, but necessary to adhere to the gnumacs standard. -;;; For some backwards compatibility, see the -;;; cmulisp-install-letter-bindings -;;; function. -;;; -;;; 8/2/91 Olin -;;; - The lisp-compile/eval-defun/region commands now take a prefix arg, -;;; which means switch-to-lisp after sending the text to the Lisp process. -;;; This obsoletes all the -and-go commands. The -and-go commands are -;;; kept around for historical reasons, and because the user can bind -;;; them to key sequences shorter than C-u C-c C-<letter>. -;;; - If M-x cmulisp is invoked with a prefix arg, it allows you to -;;; edit the command line. - -(provide 'inf-lisp) - -;;; inf-lisp.el ends here
--- a/lisp/comint/kermit.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,151 +0,0 @@ -;;; kermit.el --- additions to shell mode for use with kermit, etc. - -;; Copyright (C) 1988 Free Software Foundation, Inc. - -;; Author: Jeff Norden <jeff@colgate.csnet> -;; Created: 15 Feb 1988 -;; Keywords: comm - -;; 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. - -;;; Commentary: - -;; I'm not sure, but I think somebody asked about running kermit under shell -;; mode a while ago. Anyway, here is some code that I find useful. The result -;; is that I can log onto machines with primitive operating systems (VMS and -;; ATT system V :-), and still have the features of shell-mode available for -;; command history, etc. It's also handy to be able to run a file transfer in -;; an emacs window. The transfer is in the "background", but you can also -;; monitor or stop it easily. - -;; The ^\ key is bound to a function for sending escape sequences to kermit, -;; and ^C^Q can be used to send any control characters needed thru to the -;; system you connect to. A more serious problem is that some brain-dead -;; systems will not recognize a ^J as an end-of-line character. So LFD is -;; bound to a new function which acts just like CR usually does in shell-mode, -;; but a ^M is sent as an end-of-line. Functions are also provided to swap the -;; bindings of CR and LFD. I've also included a filter which will clean out -;; any ^M's or ^@'s that get typed at you, but I don't really recommend it. -;; There doesn't seem to be an acceptably fast way to do this via emacs-lisp. -;; Invoking kermit by the command " kermit | tr -d '\015' " seems to work -;; better (on my system anyway). - -;; Here's how I've been using this setup. We have several machines connected -;; thru a fairly stupid terminal switch. If I want to connect to unix system, -;; then I use the LFD key to talk to the switch, and ignore any ^M's in the -;; buffer, and do a " stty -echo nl " after I log in. Then the only real -;; difference from being in local shell-mode is that you need to type -;; ^C^Q^C to send an interrupt, and ^C^Q^Z for a stop signal, etc. (since ^C^C -;; just generates a local stop signal, which kermit ignores). -;; To connect to a VMS system, I use a shell script to invoke kermit thru the -;; tr filter, do "M-X kermit-send-cr", and then tell VMS that I'm on a -;; half-duplex terminal. - -;; Some caveats: -;; 1) Kermit under shell mode is a real pain if you don't have pty's. I -;; recently discovered this on our 3b2/400. When kermit can't find a tty, it -;; assumes it is supposed to be in remote mode. So the simple command "kermit" -;; won't work in shell mode on such a system. You can get around this by using -;; the -c (connect) command line option, which means you also have to specify a -;; line and baud on the command line, as in "kermit -l /dev/tty53 -b 9600 -c". -;; However, this will cause kermit to exit when the connection is closed. So -;; in order to do a file transfer, you have to think ahead and add -r -;; (receive) to the command line. This means that you can't use the server -;; feature. The only fix I can see is to muck around with the source code for -;; kermit, although this probably wouldn't be too hard. What is needed is an -;; option to force kermit to be local, to use stdin and stdout for interactive -;; speech, and to forget about cbreak mode. - -;; Please let me know if any bugs turn up. -;; Feb 1988, Jeff Norden - jeff@colgate.csnet - -;;; Code: - -(require 'shell) - -(defvar kermit-esc-char "\C-\\" "*Kermit's escape char") - -(defun kermit-esc () - "For sending escape sequences to a kermit running in shell mode." - (interactive) - (process-send-string - (get-buffer-process (current-buffer)) - (concat kermit-esc-char (char-to-string (read-char))))) - -(defun kermit-send-char () - "Send an arbitrary character to a program in shell mode." - (interactive) - (process-send-string - (get-buffer-process (current-buffer)) - (char-to-string (read-char)))) - -(define-key shell-mode-map "\C-\\" 'kermit-esc) -(define-key shell-mode-map "\C-c\C-q" 'kermit-send-char) -;; extra bindings for folks suffering form ^S/^Q braindamage: -(define-key shell-mode-map "\C-c\\" 'kermit-esc) - -(defun kermit-send-input-cr () - "Like \\[comint-send-input] but end the line with carriage-return." - (interactive) - (comint-send-input) - (comint-send-string (get-buffer-process (current-buffer)) "\r")) - -;; This is backwards of what makes sense, but ... -(define-key shell-mode-map "\n" 'kermit-send-input-cr) - -(defun kermit-default-cr () - "Make RETURN end the line with carriage-return and LFD end it with a newline. -This is useful for talking to other systems on which carriage-return -is the normal way to end a line." - (interactive) - (define-key shell-mode-map "\r" 'kermit-send-input-cr) - (define-key shell-mode-map "\n" 'comint-send-input)) - -(defun kermit-default-nl () - "Make RETURN end the line with a newline char. This is the default state. -In this state, use LFD to send a line and end it with a carriage-return." - (interactive) - (define-key shell-mode-map "\n" 'kermit-send-input-cr) - (define-key shell-mode-map "\r" 'comint-send-input)) - -(defun kermit-clean-filter (proc str) - "Strip ^M and ^@ characters from process output." - (save-excursion - (let ((beg (process-mark proc))) - (set-buffer (process-buffer proc)) - (goto-char beg) - (insert-before-markers str) - (while (re-search-backward "[\r\C-a]+" beg t) - (replace-match ""))))) - -(defun kermit-clean-on () - "Delete all null characters and ^M's from the kermit output. -Note that another (perhaps better) way to do this is to use the -command `kermit | tr -d '\\015''." - (interactive) - (set-process-filter (get-buffer-process (current-buffer)) - 'kermit-clean-filter)) - -(defun kermit-clean-off () - "Cancel a previous kermit-clean-shell-on command." - (interactive) - (set-process-filter (get-buffer-process (current-buffer)) nil)) - -;;; kermit.el ends here
--- a/lisp/comint/rlogin.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,341 +0,0 @@ -;;; rlogin.el --- remote login interface - -;; Author: Noah Friedman -;; Maintainer: Noah Friedman <friedman@prep.ai.mit.edu> -;; Keywords: unix, comm - -;; Copyright (C) 1992, 1993, 1994, 1995 Free Software Foundation, Inc. -;; -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, write to: The Free Software Foundation, -;; Inc.; 675 Massachusetts Avenue.; Cambridge, MA 02139, USA. - -;; $Id: rlogin.el,v 1.2 1997/04/19 23:20:49 steve Exp $ - -;;; Commentary: - -;; Support for remote logins using `rlogin'. -;; This program is layered on top of shell.el; the code here only accounts -;; for the variations needed to handle a remote process, e.g. directory -;; tracking and the sending of some special characters. - -;; If you wish for rlogin mode to prompt you in the minibuffer for -;; passwords when a password prompt appears, just enter m-x send-invisible -;; and type in your line, or add `comint-watch-for-password-prompt' to -;; `comint-output-filter-functions'. - -;;; Code: - -(require 'comint) -(require 'shell) - -(defgroup rlogin nil - "Remote login interface" - :group 'processes - :group 'unix) - - -(defcustom rlogin-program "rlogin" - "*Name of program to invoke rlogin" - :type 'string - :group 'rlogin) - -(defcustom rlogin-explicit-args nil - "*List of arguments to pass to rlogin on the command line." - :type '(repeat (string :tag "Argument")) - :group 'rlogin) - -(defcustom rlogin-mode-hook nil - "*Hooks to run after setting current buffer to rlogin-mode." - :type 'hook - :group 'rlogin) - -(defcustom rlogin-process-connection-type nil - "*If non-`nil', use a pty for the local rlogin process. -If `nil', use a pipe (if pipes are supported on the local system). - -Generally it is better not to waste ptys on systems which have a static -number of them. On the other hand, some implementations of `rlogin' assume -a pty is being used, and errors will result from using a pipe instead." - :type '(choice (const :tag "ptys" t) - (const :tag "pipes" nil)) - :group 'rlogin) - -(defcustom rlogin-directory-tracking-mode 'local - "*Control whether and how to do directory tracking in an rlogin buffer. - -nil means don't do directory tracking. - -t means do so using an ftp remote file name. - -Any other value means do directory tracking using local file names. -This works only if the remote machine and the local one -share the same directories (through NFS). This is the default. - -This variable becomes local to a buffer when set in any fashion for it. - -It is better to use the function of the same name to change the behavior of -directory tracking in an rlogin session once it has begun, rather than -simply setting this variable, since the function does the necessary -re-synching of directories." - :type '(choice (const :tag "off" nil) - (const :tag "ftp" t) - (const :tag "local" local)) - :group 'rlogin) - -(make-variable-buffer-local 'rlogin-directory-tracking-mode) - -(defcustom rlogin-host nil - "*The name of the remote host. This variable is buffer-local." - :type '(choice (const nil) string) - :group 'rlogin) - -(defcustom rlogin-remote-user nil - "*The username used on the remote host. -This variable is buffer-local and defaults to your local user name. -If rlogin is invoked with the `-l' option to specify the remote username, -this variable is set from that." - :type '(choice (const nil) string) - :group 'rlogin) - -;; Initialize rlogin mode map. -(defvar rlogin-mode-map '()) -(cond - ((null rlogin-mode-map) - (setq rlogin-mode-map (if (consp shell-mode-map) - (cons 'keymap shell-mode-map) - (copy-keymap shell-mode-map))) - (define-key rlogin-mode-map "\C-c\C-c" 'rlogin-send-Ctrl-C) - (define-key rlogin-mode-map "\C-c\C-d" 'rlogin-send-Ctrl-D) - (define-key rlogin-mode-map "\C-c\C-z" 'rlogin-send-Ctrl-Z) - (define-key rlogin-mode-map "\C-c\C-\\" 'rlogin-send-Ctrl-backslash) - (define-key rlogin-mode-map "\C-d" 'rlogin-delchar-or-send-Ctrl-D) - (define-key rlogin-mode-map "\C-i" 'rlogin-tab-or-complete))) - - -;;;###autoload (add-hook 'same-window-regexps "^\\*rlogin-.*\\*\\(\\|<[0-9]+>\\)") - -(defvar rlogin-history nil) - -;;;###autoload -(defun rlogin (input-args &optional buffer) - "Open a network login connection to HOST via the `rlogin' program. -Input is sent line-at-a-time to the remote connection. - -Communication with the remote host is recorded in a buffer `*rlogin-HOST*' -\(or `*rlogin-USER@HOST*' if the remote username differs\). -If a prefix argument is given and the buffer `*rlogin-HOST*' already exists, -a new buffer with a different connection will be made. - -When called from a program, if the optional second argument is a string or -buffer, it names the buffer to use. - -The variable `rlogin-program' contains the name of the actual program to -run. It can be a relative or absolute path. - -The variable `rlogin-explicit-args' is a list of arguments to give to -the rlogin when starting. They are added after any arguments given in -INPUT-ARGS. - -If the default value of `rlogin-directory-tracking-mode' is t, then the -default directory in that buffer is set to a remote (FTP) file name to -access your home directory on the remote machine. Occasionally this causes -an error, if you cannot access the home directory on that machine. This -error is harmless as long as you don't try to use that default directory. - -If `rlogin-directory-tracking-mode' is neither t nor nil, then the default -directory is initially set up to your (local) home directory. -This is useful if the remote machine and your local machine -share the same files via NFS. This is the default. - -If you wish to change directory tracking styles during a session, use the -function `rlogin-directory-tracking-mode' rather than simply setting the -variable." - (interactive (list - (read-from-minibuffer "rlogin arguments (hostname first): " - nil nil nil 'rlogin-history) - current-prefix-arg)) - - (let* ((process-connection-type rlogin-process-connection-type) - (args (if rlogin-explicit-args - (append (rlogin-parse-words input-args) - rlogin-explicit-args) - (rlogin-parse-words input-args))) - (host (car args)) - (user (or (car (cdr (member "-l" args))) - (user-login-name))) - (buffer-name (if (string= user (user-login-name)) - (format "*rlogin-%s*" host) - (format "*rlogin-%s@%s*" user host))) - proc) - - (cond ((null buffer)) - ((or (stringp buffer) (bufferp buffer)) - (setq buffer-name buffer)) - ((numberp buffer) - (setq buffer-name (format "%s<%d>" buffer-name buffer))) - (t - (setq buffer-name (generate-new-buffer-name buffer-name)))) - - (pop-to-buffer buffer-name) - (cond - ((comint-check-proc buffer-name)) - (t - (comint-exec (current-buffer) buffer-name rlogin-program nil args) - (setq proc (get-process buffer-name)) - ;; Set process-mark to point-max in case there is text in the - ;; buffer from a previous exited process. - (set-marker (process-mark proc) (point-max)) - (rlogin-mode) - - ;; comint-output-filter-functions is just like a hook, except that the - ;; functions in that list are passed arguments. add-hook serves well - ;; enough for modifying it. - (add-hook 'comint-output-filter-functions 'rlogin-carriage-filter) - - (make-local-variable 'rlogin-host) - (setq rlogin-host host) - (make-local-variable 'rlogin-remote-user) - (setq rlogin-remote-user user) - - (cond - ((eq rlogin-directory-tracking-mode t) - ;; Do this here, rather than calling the tracking mode function, to - ;; avoid a gratuitous resync check; the default should be the - ;; user's home directory, be it local or remote. - (setq comint-file-name-prefix - (concat "/" rlogin-remote-user "@" rlogin-host ":")) - (cd-absolute comint-file-name-prefix)) - ((null rlogin-directory-tracking-mode)) - (t - (cd-absolute (concat comint-file-name-prefix "~/")))))))) - -(defun rlogin-mode () - "Set major-mode for rlogin sessions. -If `rlogin-mode-hook' is set, run it." - (interactive) - (kill-all-local-variables) - (shell-mode) - (setq major-mode 'rlogin-mode) - (setq mode-name "rlogin") - (use-local-map rlogin-mode-map) - (setq shell-dirtrackp rlogin-directory-tracking-mode) - (make-local-variable 'comint-file-name-prefix) - (run-hooks 'rlogin-mode-hook)) - -(defun rlogin-directory-tracking-mode (&optional prefix) - "Do remote or local directory tracking, or disable entirely. - -If called with no prefix argument or a unspecified prefix argument (just -``\\[universal-argument]'' with no number) do remote directory tracking via -ange-ftp. If called as a function, give it no argument. - -If called with a negative prefix argument, disable directory tracking -entirely. - -If called with a positive, numeric prefix argument, e.g. -``\\[universal-argument] 1 M-x rlogin-directory-tracking-mode\'', -then do directory tracking but assume the remote filesystem is the same as -the local system. This only works in general if the remote machine and the -local one share the same directories (through NFS)." - (interactive "P") - (cond - ((or (null prefix) - (consp prefix)) - (setq rlogin-directory-tracking-mode t) - (setq shell-dirtrackp t) - (setq comint-file-name-prefix - (concat "/" rlogin-remote-user "@" rlogin-host ":"))) - ((< prefix 0) - (setq rlogin-directory-tracking-mode nil) - (setq shell-dirtrackp nil)) - (t - (setq rlogin-directory-tracking-mode 'local) - (setq comint-file-name-prefix "") - (setq shell-dirtrackp t))) - (cond - (shell-dirtrackp - (let* ((proc (get-buffer-process (current-buffer))) - (proc-mark (process-mark proc)) - (current-input (buffer-substring proc-mark (point-max))) - (orig-point (point)) - (offset (and (>= orig-point proc-mark) - (- (point-max) orig-point)))) - (unwind-protect - (progn - (delete-region proc-mark (point-max)) - (goto-char (point-max)) - (shell-resync-dirs)) - (goto-char proc-mark) - (insert current-input) - (if offset - (goto-char (- (point-max) offset)) - (goto-char orig-point))))))) - - -;; Parse a line into its constituent parts (words separated by -;; whitespace). Return a list of the words. -(defun rlogin-parse-words (line) - (let ((list nil) - (posn 0) - (match-data (match-data))) - (while (string-match "[^ \t\n]+" line posn) - (setq list (cons (substring line (match-beginning 0) (match-end 0)) - list)) - (setq posn (match-end 0))) - (store-match-data (match-data)) - (nreverse list))) - -(defun rlogin-carriage-filter (string) - (let* ((point-marker (point-marker)) - (end (process-mark (get-buffer-process (current-buffer)))) - (beg (or (and (boundp 'comint-last-output-start) - comint-last-output-start) - (- end (length string))))) - (goto-char beg) - (while (search-forward "\C-m" end t) - (delete-char -1)) - (goto-char point-marker))) - -(defun rlogin-send-Ctrl-C () - (interactive) - (send-string nil "\C-c")) - -(defun rlogin-send-Ctrl-D () - (interactive) - (send-string nil "\C-d")) - -(defun rlogin-send-Ctrl-Z () - (interactive) - (send-string nil "\C-z")) - -(defun rlogin-send-Ctrl-backslash () - (interactive) - (send-string nil "\C-\\")) - -(defun rlogin-delchar-or-send-Ctrl-D (arg) - "\ -Delete ARG characters forward, or send a C-d to process if at end of buffer." - (interactive "p") - (if (eobp) - (rlogin-send-Ctrl-D) - (delete-char arg))) - -(defun rlogin-tab-or-complete () - "Complete file name if doing directory tracking, or just insert TAB." - (interactive) - (if rlogin-directory-tracking-mode - (comint-dynamic-complete) - (insert "\C-i"))) - -;;; rlogin.el ends here
--- a/lisp/comint/shell.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,971 +0,0 @@ -;;; shell.el --- specialized comint.el for running the shell. - -;; Copyright (C) 1988, 1993, 1994, 1995 Free Software Foundation, Inc. - -;; Author: Olin Shivers <shivers@cs.cmu.edu> -;; Maintainer: Simon Marshall <simon@gnu.ai.mit.edu> -;; Keywords: processes - -;; 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. - -;;; Commentary: - -;;; Please send me bug reports, bug fixes, and extensions, so that I can -;;; merge them into the master source. -;;; - Olin Shivers (shivers@cs.cmu.edu) -;;; - Simon Marshall (simon@gnu.ai.mit.edu) - -;;; This file defines a a shell-in-a-buffer package (shell mode) built -;;; on top of comint mode. This is actually cmushell with things -;;; renamed to replace its counterpart in Emacs 18. cmushell is more -;;; featureful, robust, and uniform than the Emacs 18 version. - -;;; Since this mode is built on top of the general command-interpreter-in- -;;; a-buffer mode (comint mode), it shares a common base functionality, -;;; and a common set of bindings, with all modes derived from comint mode. -;;; This makes these modes easier to use. - -;;; For documentation on the functionality provided by comint mode, and -;;; the hooks available for customising it, see the file comint.el. -;;; For further information on shell mode, see the comments below. - -;;; Needs fixin: -;;; When sending text from a source file to a subprocess, the process-mark can -;;; move off the window, so you can lose sight of the process interactions. -;;; Maybe I should ensure the process mark is in the window when I send -;;; text to the process? Switch selectable? - -;; YOUR .EMACS FILE -;;============================================================================= -;; Some suggestions for your .emacs file. -;; -;; ;; Define M-# to run some strange command: -;; (eval-after-load "shell" -;; '(define-key shell-mode-map "\M-#" 'shells-dynamic-spell)) - -;;; Brief Command Documentation: -;;;============================================================================ -;;; Comint Mode Commands: (common to shell and all comint-derived modes) -;;; -;;; m-p comint-previous-input Cycle backwards in input history -;;; m-n comint-next-input Cycle forwards -;;; m-r comint-previous-matching-input Previous input matching a regexp -;;; m-s comint-next-matching-input Next input that matches -;;; m-c-l comint-show-output Show last batch of process output -;;; return comint-send-input -;;; c-d comint-delchar-or-maybe-eof Delete char unless at end of buff. -;;; c-c c-a comint-bol Beginning of line; skip prompt -;;; c-c c-u comint-kill-input ^u -;;; c-c c-w backward-kill-word ^w -;;; c-c c-c comint-interrupt-subjob ^c -;;; c-c c-z comint-stop-subjob ^z -;;; c-c c-\ comint-quit-subjob ^\ -;;; c-c c-o comint-kill-output Delete last batch of process output -;;; c-c c-r comint-show-output Show last batch of process output -;;; c-c c-h comint-dynamic-list-input-ring List input history -;;; send-invisible Read line w/o echo & send to proc -;;; comint-continue-subjob Useful if you accidentally suspend -;;; top-level job -;;; comint-mode-hook is the comint mode hook. - -;;; Shell Mode Commands: -;;; shell Fires up the shell process -;;; tab comint-dynamic-complete Complete filename/command/history -;;; m-? comint-dynamic-list-filename-completions -;;; List completions in help buffer -;;; m-c-f shell-forward-command Forward a shell command -;;; m-c-b shell-backward-command Backward a shell command -;;; shell-resync-dirs Resync the buffer's dir stack -;;; dirtrack-toggle Turn dir tracking on/off -;;; comint-strip-ctrl-m Remove trailing ^Ms from output -;;; -;;; The shell mode hook is shell-mode-hook -;;; comint-prompt-regexp is initialised to shell-prompt-pattern, for backwards -;;; compatibility. - -;;; Read the rest of this file for more information. - -;;; Customization and Buffer Variables -;;; =========================================================================== -;;; - -;;; Code: - -(require 'comint) - -(defgroup shell nil - "Running shell from within Emacs buffers" - :group 'processes - :group 'unix) - -(defgroup shell-directories nil - "Directory support in shell mode" - :group 'shell) - -(defgroup shell-faces nil - "Faces in shell buffers" - :group 'shell) - -;;;###autoload -(defvar shell-prompt-pattern (purecopy "^[^#$%>\n]*[#$%>] *") - "Regexp to match prompts in the inferior shell. -Defaults to \"^[^#$%>\\n]*[#$%>] *\", which works pretty well. -This variable is used to initialise `comint-prompt-regexp' in the -shell buffer. - -The pattern should probably not match more than one line. If it does, -shell-mode may become confused trying to distinguish prompt from input -on lines which don't start with a prompt. - -This is a fine thing to set in your `.emacs' file.") - -(defcustom shell-completion-fignore nil - "*List of suffixes to be disregarded during file/command completion. -This variable is used to initialize `comint-completion-fignore' in the shell -buffer. The default is nil, for compatibility with most shells. -Some people like (\"~\" \"#\" \"%\"). - -This is a fine thing to set in your `.emacs' file." - :type '(repeat (string :tag "Suffix")) - :group 'shell) - -;jwz: turned this off; it's way too broken. -(defvar shell-delimiter-argument-list nil ;'(?\| ?& ?< ?> ?\( ?\) ?\; - "List of characters to recognise as separate arguments. -This variable is used to initialize `comint-delimiter-argument-list' in the -shell buffer. The default is (?\\| ?& ?< ?> ?\\( ?\\) ?\\;). - -This is a fine thing to set in your `.emacs' file.") - -(defvar shell-file-name-quote-list - (append shell-delimiter-argument-list '(?\ ?\* ?\! ?\" ?\' ?\`)) - "List of characters to quote when in a file name. -This variable is used to initialize `comint-file-name-quote-list' in the -shell buffer. The default is (?\ ?\* ?\! ?\" ?\' ?\`) plus characters -in `shell-delimiter-argument-list'. - -This is a fine thing to set in your `.emacs' file.") - -(defvar shell-dynamic-complete-functions - '(comint-replace-by-expanded-history - shell-dynamic-complete-environment-variable - shell-dynamic-complete-command - shell-replace-by-expanded-directory - comint-dynamic-complete-filename) - "List of functions called to perform completion. -This variable is used to initialise `comint-dynamic-complete-functions' in the -shell buffer. - -This is a fine thing to set in your `.emacs' file.") - -(defcustom shell-command-regexp "[^;&|\n]+" - "*Regexp to match a single command within a pipeline. -This is used for directory tracking and does not do a perfect job." - :type 'regexp - :group 'shell) - -(defcustom shell-completion-execonly t - "*If non-nil, use executable files only for completion candidates. -This mirrors the optional behavior of tcsh. - -Detecting executability of files may slow command completion considerably." - :type 'boolean - :group 'shell) - -(defcustom shell-multiple-shells nil - "*If non-nil, each time shell mode is invoked, a new shell is made" - :type 'boolean - :group 'shell) - -(defcustom shell-popd-regexp "popd" - "*Regexp to match subshell commands equivalent to popd." - :type 'regexp - :group 'shell-directories) - -(defcustom shell-pushd-regexp "pushd" - "*Regexp to match subshell commands equivalent to pushd." - :type 'regexp - :group 'shell-directories) - -(defcustom shell-pushd-tohome nil - "*If non-nil, make pushd with no arg behave as \"pushd ~\" (like cd). -This mirrors the optional behavior of tcsh." - :type 'boolean - :group 'shell-directories) - -(defcustom shell-pushd-dextract nil - "*If non-nil, make \"pushd +n\" pop the nth dir to the stack top. -This mirrors the optional behavior of tcsh." - :type 'boolean - :group 'shell-directories) - -(defcustom shell-pushd-dunique nil - "*If non-nil, make pushd only add unique directories to the stack. -This mirrors the optional behavior of tcsh." - :type 'boolean - :group 'shell-directories) - -(defcustom shell-cd-regexp "cd" - "*Regexp to match subshell commands equivalent to cd." - :type 'regexp - :group 'shell-directories) - -(defcustom explicit-shell-file-name nil - "*If non-nil, is file name to use for explicitly requested inferior shell." - :type '(choice (const :tag "None" nil) file) - :group 'shell) - -(defcustom explicit-csh-args - (if (eq system-type 'hpux) - ;; -T persuades HP's csh not to think it is smarter - ;; than us about what terminal modes to use. - '("-i" "-T") - '("-i")) - "*Args passed to inferior shell by M-x shell, if the shell is csh. -Value is a list of strings, which may be nil." - :type '(repeat (string :tag "Argument")) - :group 'shell) - -(defcustom shell-input-autoexpand 'history - "*If non-nil, expand input command history references on completion. -This mirrors the optional behavior of tcsh (its autoexpand and histlit). - -If the value is `input', then the expansion is seen on input. -If the value is `history', then the expansion is only when inserting -into the buffer's input ring. See also `comint-magic-space' and -`comint-dynamic-complete'. - -This variable supplies a default for `comint-input-autoexpand', -for Shell mode only." - :type '(choice (const nil) (const input) (const history)) - :type 'shell) - -(defvar shell-dirstack nil - "List of directories saved by pushd in this buffer's shell. -Thus, this does not include the shell's current directory.") - -(defvar shell-dirtrackp t - "Non-nil in a shell buffer means directory tracking is enabled.") - -(defvar shell-last-dir nil - "Keep track of last directory for ksh `cd -' command.") - -(defvar shell-dirstack-query nil - "Command used by `shell-resync-dirs' to query the shell.") - -(defvar shell-mode-map nil) -(if (not shell-mode-map) - (let ((map (make-keymap))) - (set-keymap-parents map (list comint-mode-map)) - (set-keymap-name map 'shell-mode-map) - (define-key map "\C-c\C-f" 'shell-forward-command) - (define-key map "\C-c\C-b" 'shell-backward-command) - (define-key map "\t" 'comint-dynamic-complete) - (define-key map "\M-?" 'comint-dynamic-list-filename-completions) - ;; XEmacs: this is a pretty common operation for those of us - ;; who use directory aliases ... someone shoot me if they - ;; don't like this binding. Another possibility is C-c C-s - ;; but that's way awkward. - ;; July-5-1997, Bang! -slb - #-infodock (define-key map "\M-\C-m" 'shell-resync-dirs) - (setq shell-mode-map map))) - -(defcustom shell-mode-hook nil - "*Hook for customising Shell mode." - :type 'hook - :group 'shell) - - -;; font-locking -(defcustom shell-prompt-face 'shell-prompt-face - "Face for shell prompts." - :type 'face - :group 'shell-faces) -(defcustom shell-option-face 'shell-option-face - "Face for command line options." - :type 'face - :group 'shell-faces) -(defcustom shell-output-face 'shell-output-face - "Face for generic shell output." - :type 'face - :group 'shell-faces) -(defcustom shell-output-2-face 'shell-output-2-face - "Face for grep-like output." - :type 'face - :group 'shell-faces) -(defcustom shell-output-3-face 'shell-output-3-face - "Face for [N] output where N is a number." - :type 'face - :group 'shell-faces) - -(make-face shell-prompt-face) -(make-face shell-option-face) -(make-face shell-output-face) -(make-face shell-output-2-face) -(make-face shell-output-3-face) - -(defun shell-font-lock-mode-hook () - (or (face-differs-from-default-p shell-prompt-face) - (copy-face 'font-lock-keyword-face shell-prompt-face)) - (or (face-differs-from-default-p shell-option-face) - (copy-face 'font-lock-comment-face shell-option-face)) - (or (face-differs-from-default-p shell-output-face) - (copy-face 'italic shell-output-face)) - (or (face-differs-from-default-p shell-output-2-face) - (copy-face 'font-lock-string-face shell-output-2-face)) - (or (face-differs-from-default-p shell-output-3-face) - (copy-face 'font-lock-string-face shell-output-3-face)) - ;; we only need to do this once - (remove-hook 'font-lock-mode-hook 'shell-font-lock-mode-hook)) -(add-hook 'font-lock-mode-hook 'shell-font-lock-mode-hook) - -(defvar shell-prompt-pattern-for-font-lock nil - "If non-nil, pattern to use to font-lock the prompt. -When nil, shell-prompt-pattern will be used. Set this to a regular -expression if you want the font-locked pattern to be different then -the shell's prompt pattern.") - -(defvar shell-font-lock-keywords - (list '(eval . (cons (if shell-prompt-pattern-for-font-lock - shell-prompt-pattern-for-font-lock - shell-prompt-pattern) - shell-prompt-face)) - '("[ \t]\\([+-][^ \t\n>]+\\)" 1 shell-option-face) - '("^[^ \t\n]+:.*" . shell-output-2-face) - '("^\\[[1-9][0-9]*\\]" . shell-output-3-face) - '("^[^\n]+.*$" . shell-output-face)) - "Additional expressions to highlight in Shell mode.") -(put 'shell-mode 'font-lock-defaults '(shell-font-lock-keywords t)) - - -;;; Basic Procedures -;;; =========================================================================== -;;; - -(defun shell-mode () - "Major mode for interacting with an inferior shell. -\\<shell-mode-map>\\[comint-send-input] after the end of the process' output sends the text from - the end of process to the end of the current line. -\\[comint-send-input] before end of process output copies the current line minus the - prompt to the end of the buffer and sends it (\\[comint-copy-old-input] just copies - the current line). -\\[send-invisible] reads a line of text without echoing it, and sends it to - the shell. This is useful for entering passwords. Or, add the function - `comint-watch-for-password-prompt' to `comint-output-filter-functions'. - -If you want to make multiple shell buffers, rename the `*shell*' buffer -using \\[rename-buffer] or \\[rename-uniquely] and start a new shell. - -If you want to make shell buffers limited in length, add the function -`comint-truncate-buffer' to `comint-output-filter-functions'. - -If you accidentally suspend your process, use \\[comint-continue-subjob] -to continue it. - -`cd', `pushd' and `popd' commands given to the shell are watched by Emacs to -keep this buffer's default directory the same as the shell's working directory. -While directory tracking is enabled, the shell's working directory is displayed -by \\[list-buffers] or \\[mouse-buffer-menu] in the `File' field. -\\[shell-resync-dirs] queries the shell and resyncs Emacs' idea of what the - current directory stack is. -\\[shell-dirtrack-toggle] turns directory tracking on and off. - -\\{shell-mode-map} -Customization: Entry to this mode runs the hooks on `comint-mode-hook' and -`shell-mode-hook' (in that order). Before each input, the hooks on -`comint-input-filter-functions' are run. After each shell output, the hooks -on `comint-output-filter-functions' are run. - -Variable `shell-multiple-shells' will automatically generate a new shell each -time it is invoked. - -Variables `shell-cd-regexp', `shell-pushd-regexp' and `shell-popd-regexp' -are used to match their respective commands, while `shell-pushd-tohome', -`shell-pushd-dextract' and `shell-pushd-dunique' control the behavior of the -relevant command. - -Variables `comint-completion-autolist', `comint-completion-addsuffix', -`comint-completion-recexact' and `comint-completion-fignore' control the -behavior of file name, command name and variable name completion. Variable -`shell-completion-execonly' controls the behavior of command name completion. -Variable `shell-completion-fignore' is used to initialise the value of -`comint-completion-fignore'. - -Variables `comint-input-ring-file-name' and `comint-input-autoexpand' control -the initialisation of the input ring history, and history expansion. - -Variables `comint-output-filter-functions', a hook, and -`comint-scroll-to-bottom-on-input' and `comint-scroll-to-bottom-on-output' -control whether input and output cause the window to scroll to the end of the -buffer." - (interactive) - (comint-mode) - (setq major-mode 'shell-mode) - (setq mode-name "Shell") - (use-local-map shell-mode-map) - (make-local-variable 'comint-prompt-regexp) - (setq comint-prompt-regexp shell-prompt-pattern) - (setq comint-completion-fignore shell-completion-fignore) - (make-local-variable 'comint-delimiter-argument-list) - (setq comint-delimiter-argument-list shell-delimiter-argument-list) - (make-local-variable 'comint-after-partial-filename-command) - (setq comint-after-partial-filename-command 'shell-after-partial-filename) - (make-local-variable 'comint-get-current-command) - (setq comint-get-current-command 'shell-get-current-command) - (make-local-variable 'comint-dynamic-complete-command-command) - (setq comint-dynamic-complete-command-command 'shell-dynamic-complete-command) - (setq comint-file-name-quote-list shell-file-name-quote-list) - (setq comint-dynamic-complete-functions shell-dynamic-complete-functions) - (make-local-variable 'paragraph-start) - (setq paragraph-start comint-prompt-regexp) - (make-local-variable 'shell-dirstack) - (setq shell-dirstack nil) - (make-local-variable 'shell-last-dir) - (setq shell-last-dir nil) - (make-local-variable 'shell-dirtrackp) - (setq shell-dirtrackp t) - (add-hook 'comint-input-filter-functions 'shell-directory-tracker nil t) - (setq comint-input-autoexpand shell-input-autoexpand) - (make-local-variable 'list-buffers-directory) - (setq list-buffers-directory (expand-file-name default-directory)) - ;; shell-dependent assignments. - (let ((shell (file-name-nondirectory (car - (process-command (get-buffer-process (current-buffer))))))) - (setq comint-input-ring-file-name - (or (getenv "HISTFILE") - (cond ((string-equal shell "bash") "~/.bash_history") - ((string-equal shell "ksh") "~/.sh_history") - (t "~/.history")))) - (if (or (equal comint-input-ring-file-name "") - (equal (file-truename comint-input-ring-file-name) "/dev/null")) - (setq comint-input-ring-file-name nil)) - (setq shell-dirstack-query - (if (string-match "^k?sh$" shell) "pwd" "dirs"))) - (run-hooks 'shell-mode-hook) - (comint-read-input-ring t) - (shell-dirstack-message)) - - -;;;###autoload -(defun shell () - "Run an inferior shell, with I/O through buffer *shell*. -If buffer exists but shell process is not running, make new shell. -If buffer exists and shell process is running, - just switch to buffer `*shell*'. -Program used comes from variable `explicit-shell-file-name', - or (if that is nil) from the ESHELL environment variable, - or else from SHELL if there is no ESHELL. -If a file `~/.emacs_SHELLNAME' exists, it is given as initial input - (Note that this may lose due to a timing error if the shell - discards input when it starts up.) -The buffer is put in Shell mode, giving commands for sending input -and controlling the subjobs of the shell. See `shell-mode'. -See also the variable `shell-prompt-pattern'. - -The shell file name (sans directories) is used to make a symbol name -such as `explicit-csh-args'. If that symbol is a variable, -its value is used as a list of arguments when invoking the shell. -Otherwise, one argument `-i' is passed to the shell. - -\(Type \\[describe-mode] in the shell buffer for a list of commands.)" - (interactive) - (let ((buffer "*shell*") - (buffer-name (if shell-multiple-shells - "*shell*" - "shell"))) - (cond ((or shell-multiple-shells - (not (comint-check-proc buffer))) - (let* ((prog (or explicit-shell-file-name - (getenv "ESHELL") - (getenv "SHELL") - "/bin/sh")) - (name (file-name-nondirectory prog)) - (startfile (concat "~/.emacs_" name)) - (xargs-name (intern-soft (concat "explicit-" name "-args")))) - (setq buffer (set-buffer (apply 'make-comint buffer-name prog - (if (file-exists-p startfile) - startfile) - (if (and xargs-name - (boundp xargs-name)) - (symbol-value xargs-name) - '("-i"))))) - (shell-mode)))) - (pop-to-buffer buffer) - (if shell-multiple-shells - (rename-buffer (generate-new-buffer-name "*shell*"))) - )) - -;;; Don't do this when shell.el is loaded, only while dumping. -;;;###autoload (add-hook 'same-window-buffer-names "*shell*") - -;;; Directory tracking -;;; =========================================================================== -;;; This code provides the shell mode input sentinel -;;; SHELL-DIRECTORY-TRACKER -;;; that tracks cd, pushd, and popd commands issued to the shell, and -;;; changes the current directory of the shell buffer accordingly. -;;; -;;; This is basically a fragile hack, although it's more accurate than -;;; the version in Emacs 18's shell.el. It has the following failings: -;;; 1. It doesn't know about the cdpath shell variable. -;;; 2. It cannot infallibly deal with command sequences, though it does well -;;; with these and with ignoring commands forked in another shell with ()s. -;;; 3. More generally, any complex command is going to throw it. Otherwise, -;;; you'd have to build an entire shell interpreter in emacs lisp. Failing -;;; that, there's no way to catch shell commands where cd's are buried -;;; inside conditional expressions, aliases, and so forth. -;;; -;;; The whole approach is a crock. Shell aliases mess it up. File sourcing -;;; messes it up. You run other processes under the shell; these each have -;;; separate working directories, and some have commands for manipulating -;;; their w.d.'s (e.g., the lcd command in ftp). Some of these programs have -;;; commands that do *not* affect the current w.d. at all, but look like they -;;; do (e.g., the cd command in ftp). In shells that allow you job -;;; control, you can switch between jobs, all having different w.d.'s. So -;;; simply saying %3 can shift your w.d.. -;;; -;;; The solution is to relax, not stress out about it, and settle for -;;; a hack that works pretty well in typical circumstances. Remember -;;; that a half-assed solution is more in keeping with the spirit of Unix, -;;; anyway. Blech. -;;; -;;; One good hack not implemented here for users of programmable shells -;;; is to program up the shell w.d. manipulation commands to output -;;; a coded command sequence to the tty. Something like -;;; ESC | <cwd> | -;;; where <cwd> is the new current working directory. Then trash the -;;; directory tracking machinery currently used in this package, and -;;; replace it with a process filter that watches for and strips out -;;; these messages. - -(defun shell-directory-tracker (str) - "Tracks cd, pushd and popd commands issued to the shell. -This function is called on each input passed to the shell. -It watches for cd, pushd and popd commands and sets the buffer's -default directory to track these commands. - -You may toggle this tracking on and off with \\[shell-dirtrack-toggle]. -If emacs gets confused, you can resync with the shell -with \\[shell-resync-dirs]. - -See variables `shell-cd-regexp', `shell-pushd-regexp', and `shell-popd-regexp', -while `shell-pushd-tohome', `shell-pushd-dextract' and `shell-pushd-dunique' -control the behavior of the relevant command. - -Environment variables are expanded, see function `substitute-in-file-name'." - (if shell-dirtrackp - ;; We fail gracefully if we think the command will fail in the shell. - (condition-case err - (let ((start (progn (string-match "^[; \t]*" str) ; skip whitespace - (match-end 0))) - end cmd arg1) - (while (string-match shell-command-regexp str start) - (setq end (match-end 0) - cmd (comint-arguments (substring str start end) 0 0) - arg1 (comint-arguments (substring str start end) 1 1)) - (cond ((string-match (concat "\\`\\(" shell-popd-regexp - "\\)\\($\\|[ \t]\\)") - cmd) - (shell-process-popd (substitute-in-file-name arg1))) - ((string-match (concat "\\`\\(" shell-pushd-regexp - "\\)\\($\\|[ \t]\\)") - cmd) - (shell-process-pushd (substitute-in-file-name arg1))) - ((string-match (concat "\\`\\(" shell-cd-regexp - "\\)\\($\\|[ \t]\\)") - cmd) - (shell-process-cd (substitute-in-file-name arg1)))) - (setq start (progn (string-match "[; \t]*" str end) ; skip again - (match-end 0))))) - (error - ;; XEmacs change - (message nil) - (display-error err t))))) - -;; Like `cd', but prepends comint-file-name-prefix to absolute names. -(defun shell-cd-1 (dir dirstack) - (if shell-dirtrackp - (setq list-buffers-directory (file-name-as-directory - (expand-file-name dir)))) - (condition-case nil - (progn (if (file-name-absolute-p dir) - (cd-absolute (concat comint-file-name-prefix dir)) - (cd dir)) - (setq shell-dirstack dirstack) - (shell-dirstack-message)) - (file-error (message "Couldn't cd.")))) - -;;; popd [+n] -(defun shell-process-popd (arg) - (let ((num (or (shell-extract-num arg) 0))) - (cond ((and num (= num 0) shell-dirstack) - (shell-cd-1 (car shell-dirstack) (cdr shell-dirstack))) - ((and num (> num 0) (<= num (length shell-dirstack))) - (let* ((ds (cons nil shell-dirstack)) - (cell (nthcdr (1- num) ds))) - (rplacd cell (cdr (cdr cell))) - (setq shell-dirstack (cdr ds)) - (shell-dirstack-message))) - (t - (error "Couldn't popd"))))) - -;; Return DIR prefixed with comint-file-name-prefix as appropriate. -(defun shell-prefixed-directory-name (dir) - (if (= (length comint-file-name-prefix) 0) - dir - (if (file-name-absolute-p dir) - ;; The name is absolute, so prepend the prefix. - (concat comint-file-name-prefix dir) - ;; For relative name we assume default-directory already has the prefix. - (expand-file-name dir)))) - -;;; cd [dir] -(defun shell-process-cd (arg) - (let ((new-dir (cond ((zerop (length arg)) (concat comint-file-name-prefix - "~")) - ((string-equal "-" arg) shell-last-dir) - (t (shell-prefixed-directory-name arg))))) - (setq shell-last-dir default-directory) - (shell-cd-1 new-dir shell-dirstack))) - -;;; pushd [+n | dir] -(defun shell-process-pushd (arg) - (let ((num (shell-extract-num arg))) - (cond ((zerop (length arg)) - ;; no arg -- swap pwd and car of stack unless shell-pushd-tohome - (cond (shell-pushd-tohome - (shell-process-pushd (concat comint-file-name-prefix "~"))) - (shell-dirstack - (let ((old default-directory)) - (shell-cd-1 (car shell-dirstack) - (cons old (cdr shell-dirstack))))) - (t - (message "Directory stack empty.")))) - ((numberp num) - ;; pushd +n - (cond ((> num (length shell-dirstack)) - (message "Directory stack not that deep.")) - ((= num 0) - (error (message "Couldn't cd."))) - (shell-pushd-dextract - (let ((dir (nth (1- num) shell-dirstack))) - (shell-process-popd arg) - (shell-process-pushd default-directory) - (shell-cd-1 dir shell-dirstack))) - (t - (let* ((ds (cons default-directory shell-dirstack)) - (dslen (length ds)) - (front (nthcdr num ds)) - (back (reverse (nthcdr (- dslen num) (reverse ds)))) - (new-ds (append front back))) - (shell-cd-1 (car new-ds) (cdr new-ds)))))) - (t - ;; pushd <dir> - (let ((old-wd default-directory)) - (shell-cd-1 (shell-prefixed-directory-name arg) - (if (or (null shell-pushd-dunique) - (not (member old-wd shell-dirstack))) - (cons old-wd shell-dirstack) - shell-dirstack))))))) - -;; If STR is of the form +n, for n>0, return n. Otherwise, nil. -(defun shell-extract-num (str) - (and (string-match "^\\+[1-9][0-9]*$" str) - (string-to-int str))) - - -(defun shell-dirtrack-toggle () - "Turn directory tracking on and off in a shell buffer." - (interactive) - (if (setq shell-dirtrackp (not shell-dirtrackp)) - (setq list-buffers-directory default-directory) - (setq list-buffers-directory nil)) - (message "Directory tracking %s" (if shell-dirtrackp "ON" "OFF"))) - -;;; For your typing convenience: -;; XEmacs: removed this because then `M-x dir' doesn't complete to `dired' -;;(define-function 'dirtrack-toggle 'shell-dirtrack-toggle) - -(defun shell-cd (dir) - "Do normal `cd' to DIR, and set `list-buffers-directory'." - (if shell-dirtrackp - (setq list-buffers-directory (file-name-as-directory - (expand-file-name dir)))) - (cd dir)) - -(defun shell-resync-dirs () - "Resync the buffer's idea of the current directory stack. -This command queries the shell with the command bound to -`shell-dirstack-query' (default \"dirs\"), reads the next -line output and parses it to form the new directory stack. -DON'T issue this command unless the buffer is at a shell prompt. -Also, note that if some other subprocess decides to do output -immediately after the query, its output will be taken as the -new directory stack -- you lose. If this happens, just do the -command again." - (interactive) - (let* ((proc (get-buffer-process (current-buffer))) - (pmark (process-mark proc))) - (goto-char pmark) - (insert shell-dirstack-query) (insert "\n") - (sit-for 0) ; force redisplay - (comint-send-string proc shell-dirstack-query) - (comint-send-string proc "\n") - (set-marker pmark (point)) - (let ((pt (point))) ; wait for 1 line - ;; This extra newline prevents the user's pending input from spoofing us. - (insert "\n") (backward-char 1) - (while (not (looking-at ".+\n")) - (accept-process-output proc) - (goto-char pt) - ;; kludge to cope with shells that have "stty echo" turned on. - ;; of course this will lose if there is only one dir on the stack - ;; and it is named "dirs"... -jwz - (if (looking-at "^dirs\r?\n") (delete-region (point) (match-end 0))) - )) - (goto-char pmark) (delete-char 1) ; remove the extra newline - ;; That's the dirlist. grab it & parse it. - (let* ((dl (buffer-substring (match-beginning 0) (1- (match-end 0)))) - (dl-len (length dl)) - (ds '()) ; new dir stack - (i 0)) - (while (< i dl-len) - ;; regexp = optional whitespace, (non-whitespace), optional whitespace - (string-match "\\s *\\(\\S +\\)\\s *" dl i) ; pick off next dir - (setq ds (cons (concat comint-file-name-prefix - (substring dl (match-beginning 1) - (match-end 1))) - ds)) - (setq i (match-end 0))) - (let ((ds (reverse ds))) - (shell-cd-1 (car ds) (cdr ds)))))) - -;;; For your typing convenience: -;; XEmacs: removed this because then `M-x dir' doesn't complete to `dired' -;(define-function 'dirs 'shell-resync-dirs) - -;; XEmacs addition -(defvar shell-dirstack-message-hook nil - "Hook to run after a cd, pushd or popd event") - -;;; Show the current dirstack on the message line. -;;; Pretty up dirs a bit by changing "/usr/jqr/foo" to "~/foo". -;;; (This isn't necessary if the dirlisting is generated with a simple "dirs".) -;;; All the commands that mung the buffer's dirstack finish by calling -;;; this guy. -(defun shell-dirstack-message () - (let* ((msg "") - (ds (cons default-directory shell-dirstack)) - (home (format "^%s\\(/\\|$\\)" (regexp-quote (getenv "HOME")))) - (prefix (and comint-file-name-prefix - ;; XEmacs addition: don't turn "/foo" into "foo" !! - (not (= 0 (length comint-file-name-prefix))) - (format "^%s\\(/\\|$\\)" - (regexp-quote comint-file-name-prefix))))) - (while ds - (let ((dir (car ds))) - (if (string-match home dir) - (setq dir (concat "~/" (substring dir (match-end 0))))) - ;; Strip off comint-file-name-prefix if present. - (and prefix (string-match prefix dir) - (setq dir (substring dir (match-end 0))) - (setcar ds dir) - ) - (setq msg (concat msg dir " ")) - (setq ds (cdr ds)))) - ;; XEmacs change - (run-hooks 'shell-dirstack-message-hook) - (message msg))) - - -(defun shell-forward-command (&optional arg) - "Move forward across ARG shell command(s). Does not cross lines. -See `shell-command-regexp'." - (interactive "p") - (let ((limit (save-excursion (end-of-line nil) (point)))) - (if (re-search-forward (concat shell-command-regexp "\\([;&|][\t ]*\\)+") - limit 'move arg) - (skip-syntax-backward " ")))) - - -(defun shell-backward-command (&optional arg) - "Move backward across ARG shell command(s). Does not cross lines. -See `shell-command-regexp'." - (interactive "p") - (let ((limit (save-excursion (comint-bol nil) (point)))) - (if (> limit (point)) - (save-excursion (beginning-of-line) (setq limit (point)))) - (skip-syntax-backward " " limit) - (if (re-search-backward - (format "[;&|]+[\t ]*\\(%s\\)" shell-command-regexp) limit 'move arg) - (progn (goto-char (match-beginning 1)) - (skip-chars-forward ";&|"))))) - - -(defun shell-dynamic-complete-command () - "Dynamically complete the command at point. -This function is similar to `comint-dynamic-complete-filename', except that it -searches `exec-path' (minus the trailing emacs library path) for completion -candidates. Note that this may not be the same as the shell's idea of the -path. - -Completion is dependent on the value of `shell-completion-execonly', plus -those that effect file completion. See `shell-dynamic-complete-as-command'. - -Returns t if successful." - (interactive) - (let ((filename (comint-match-partial-filename))) - (if (and filename - (save-match-data (not (string-match "[~/]" filename))) - (eq (match-beginning 0) - (save-excursion (shell-backward-command 1) (point)))) - (prog2 (message "Completing command name...") - (shell-dynamic-complete-as-command))))) - - -(defun shell-dynamic-complete-as-command () - "Dynamically complete at point as a command. -See `shell-dynamic-complete-filename'. Returns t if successful." - (let* ((filename (or (comint-match-partial-filename) "")) - (pathnondir (file-name-nondirectory filename)) - (paths (cdr (reverse exec-path))) - (cwd (file-name-as-directory (expand-file-name default-directory))) - (ignored-extensions - (and comint-completion-fignore - (mapconcat (function (lambda (x) (concat (regexp-quote x) "$"))) - comint-completion-fignore "\\|"))) - (path "") (comps-in-path ()) (file "") (filepath "") (completions ())) - ;; Go thru each path in the search path, finding completions. - (while paths - (setq path (file-name-as-directory (comint-directory (or (car paths) "."))) - comps-in-path (and (file-accessible-directory-p path) - (file-name-all-completions pathnondir path))) - ;; Go thru each completion found, to see whether it should be used. - (while comps-in-path - (setq file (car comps-in-path) - filepath (concat path file)) - (if (and (not (member file completions)) - (not (and ignored-extensions - (string-match ignored-extensions file))) - (or (string-equal path cwd) - (not (file-directory-p filepath))) - (or (null shell-completion-execonly) - (file-executable-p filepath))) - (setq completions (cons file completions))) - (setq comps-in-path (cdr comps-in-path))) - (setq paths (cdr paths))) - ;; OK, we've got a list of completions. - (let ((success (let ((comint-completion-addsuffix nil)) - (comint-dynamic-simple-complete pathnondir completions)))) - (if (and (memq success '(sole shortest)) comint-completion-addsuffix - (not (file-directory-p (comint-match-partial-filename)))) - (insert " ")) - success))) - - -(defun shell-match-partial-variable () - "Return the variable at point, or nil if non is found." - (save-excursion - (let ((limit (point))) - (if (re-search-backward "[^A-Za-z0-9_{}]" nil 'move) - (or (looking-at "\\$") (forward-char 1))) - ;; Anchor the search forwards. - (if (or (eolp) (looking-at "[^A-Za-z0-9_{}$]")) - nil - (re-search-forward "\\$?{?[A-Za-z0-9_]*}?" limit) - (buffer-substring (match-beginning 0) (match-end 0)))))) - - -(defun shell-dynamic-complete-environment-variable () - "Dynamically complete the environment variable at point. -Completes if after a variable, i.e., if it starts with a \"$\". -See `shell-dynamic-complete-as-environment-variable'. - -This function is similar to `comint-dynamic-complete-filename', except that it -searches `process-environment' for completion candidates. Note that this may -not be the same as the interpreter's idea of variable names. The main problem -with this type of completion is that `process-environment' is the environment -which Emacs started with. Emacs does not track changes to the environment made -by the interpreter. Perhaps it would be more accurate if this function was -called `shell-dynamic-complete-process-environment-variable'. - -Returns non-nil if successful." - (interactive) - (let ((variable (shell-match-partial-variable))) - (if (and variable (string-match "^\\$" variable)) - (prog2 (message "Completing variable name...") - (shell-dynamic-complete-as-environment-variable))))) - - -(defun shell-dynamic-complete-as-environment-variable () - "Dynamically complete at point as an environment variable. -Used by `shell-dynamic-complete-environment-variable'. -Uses `comint-dynamic-simple-complete'." - (let* ((var (or (shell-match-partial-variable) "")) - (variable (substring var (or (string-match "[^$({]\\|$" var) 0))) - (variables (mapcar (function (lambda (x) - (substring x 0 (string-match "=" x)))) - process-environment)) - (addsuffix comint-completion-addsuffix) - (comint-completion-addsuffix nil) - (success (comint-dynamic-simple-complete variable variables))) - (if (memq success '(sole shortest)) - (let* ((var (shell-match-partial-variable)) - (variable (substring var (string-match "[^$({]" var))) - (protection (cond ((string-match "{" var) "}") - ((string-match "(" var) ")") - (t ""))) - (suffix (cond ((null addsuffix) "") - ((file-directory-p - (comint-directory (getenv variable))) "/") - (t " ")))) - (insert protection suffix))) - success)) - - -(defun shell-replace-by-expanded-directory () - "Expand directory stack reference before point. -Directory stack references are of the form \"=digit\" or \"=-\". -See `default-directory' and `shell-dirstack'. - -Returns t if successful." - (interactive) - (if (comint-match-partial-filename) - (save-excursion - (goto-char (match-beginning 0)) - (let ((stack (cons default-directory shell-dirstack)) - (index (cond ((looking-at "=-/?") - (length shell-dirstack)) - ((looking-at "=\\([0-9]+\\)") - (string-to-number - (buffer-substring - (match-beginning 1) (match-end 1))))))) - (cond ((null index) - nil) - ((>= index (length stack)) - (error "Directory stack not that deep.")) - (t - (replace-match (file-name-as-directory (nth index stack)) t t) - (message "Directory item: %d" index) - t)))))) - -(provide 'shell) - -;;; shell.el ends here
--- a/lisp/comint/ssh.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,358 +0,0 @@ -;;; ssh.el --- remote login interface - -;; Copyright (C) 1996, 1997 Noah S. Friedman - -;; Author: Noah Friedman <friedman@prep.ai.mit.edu> -;; Maintainer: friedman@prep.ai.mit.edu -;; Keywords: unix, comm -;; Created: 1996-07-03 - -;; $Id: ssh.el,v 1.1 1997/05/28 16:30:50 steve Exp $ - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, you can either send email to this -;; program's maintainer or write to: The Free Software Foundation, -;; Inc.; 59 Temple Place, Suite 330; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; Support for remote logins using `ssh'. -;; This program is layered on top of shell.el; the code here only accounts -;; for the variations needed to handle a remote process, e.g. directory -;; tracking and the sending of some special characters. - -;; If you wish for ssh mode to prompt you in the minibuffer for -;; passwords when a password prompt appears, just enter m-x send-invisible -;; and type in your line, or add `comint-watch-for-password-prompt' to -;; `comint-output-filter-functions'. - -;;; Code: - -(require 'comint) -(require 'shell) - -(defgroup ssh nil - "Secure remote login interface" - :group 'processes - :group 'unix) - -(defcustom ssh-program "ssh" - "*Name of program to invoke ssh" - :type 'string - :group 'ssh) - -(defcustom ssh-explicit-args '() - "*List of arguments to pass to ssh on the command line." - :type '(repeat (string :tag "Argument")) - :group 'ssh) - -(defcustom ssh-mode-hook nil - "*Hooks to run after setting current buffer to ssh-mode." - :type 'hook - :group 'ssh) - -(defcustom ssh-process-connection-type t - "*If non-`nil', use a pty for the local ssh process. -If `nil', use a pipe (if pipes are supported on the local system). - -Generally it is better not to waste ptys on systems which have a static -number of them. However, ssh won't allocate a pty on the remote host -unless one is used locally as well." - :type '(choice (const :tag "ptys" t) - (const :tag "pipes" nil)) - :group 'ssh) - -(defcustom ssh-directory-tracking-mode 'local - "*Control whether and how to do directory tracking in an ssh buffer. - -nil means don't do directory tracking. - -t means do so using an ftp remote file name. - -Any other value means do directory tracking using local file names. -This works only if the remote machine and the local one -share the same directories (through NFS). This is the default. - -This variable becomes local to a buffer when set in any fashion for it. - -It is better to use the function of the same name to change the behavior of -directory tracking in an ssh session once it has begun, rather than -simply setting this variable, since the function does the necessary -re-synching of directories." - :type '(choice (const :tag "off" nil) - (const :tag "ftp" t) - (const :tag "local" local)) - :group 'ssh) - -(make-variable-buffer-local 'ssh-directory-tracking-mode) - -(defcustom ssh-host nil - "*The name of the remote host. This variable is buffer-local." - :type '(choice (const nil) string) - :group 'ssh) - -(defcustom ssh-remote-user nil - "*The username used on the remote host. -This variable is buffer-local and defaults to your local user name. -If ssh is invoked with the `-l' option to specify the remote username, -this variable is set from that." - :type '(choice (const nil) string) - :group 'ssh) - -;; Initialize ssh mode map. -(defvar ssh-mode-map '()) -(cond - ((null ssh-mode-map) - (setq ssh-mode-map (if (consp shell-mode-map) - (cons 'keymap shell-mode-map) - (copy-keymap shell-mode-map))) - (define-key ssh-mode-map "\C-c\C-c" 'ssh-send-Ctrl-C) - (define-key ssh-mode-map "\C-c\C-d" 'ssh-send-Ctrl-D) - (define-key ssh-mode-map "\C-c\C-z" 'ssh-send-Ctrl-Z) - (define-key ssh-mode-map "\C-c\C-\\" 'ssh-send-Ctrl-backslash) - (define-key ssh-mode-map "\C-d" 'ssh-delchar-or-send-Ctrl-D) - (define-key ssh-mode-map "\C-i" 'ssh-tab-or-complete))) - - -;;;###autoload (add-hook 'same-window-regexps "^\\*ssh-.*\\*\\(\\|<[0-9]+>\\)") - -(defvar ssh-history nil) - -;;;###autoload -(defun ssh (input-args &optional buffer) - "Open a network login connection via `ssh' with args INPUT-ARGS. -INPUT-ARGS should start with a host name; it may also contain -other arguments for `ssh'. - -Input is sent line-at-a-time to the remote connection. - -Communication with the remote host is recorded in a buffer `*ssh-HOST*' -\(or `*ssh-USER@HOST*' if the remote username differs\). -If a prefix argument is given and the buffer `*ssh-HOST*' already exists, -a new buffer with a different connection will be made. - -When called from a program, if the optional second argument BUFFER is -a string or buffer, it specifies the buffer to use. - -The variable `ssh-program' contains the name of the actual program to -run. It can be a relative or absolute path. - -The variable `ssh-explicit-args' is a list of arguments to give to -the ssh when starting. They are prepended to any arguments given in -INPUT-ARGS. - -If the default value of `ssh-directory-tracking-mode' is t, then the -default directory in that buffer is set to a remote (FTP) file name to -access your home directory on the remote machine. Occasionally this causes -an error, if you cannot access the home directory on that machine. This -error is harmless as long as you don't try to use that default directory. - -If `ssh-directory-tracking-mode' is neither t nor nil, then the default -directory is initially set up to your (local) home directory. -This is useful if the remote machine and your local machine -share the same files via NFS. This is the default. - -If you wish to change directory tracking styles during a session, use the -function `ssh-directory-tracking-mode' rather than simply setting the -variable." - (interactive (list - (read-from-minibuffer "ssh arguments (hostname first): " - nil nil nil 'ssh-history) - current-prefix-arg)) - - (let* ((process-connection-type ssh-process-connection-type) - (args (ssh-parse-words input-args)) - (host (car args)) - (user (or (car (cdr (member "-l" args))) - (user-login-name))) - (buffer-name (if (string= user (user-login-name)) - (format "*ssh-%s*" host) - (format "*ssh-%s@%s*" user host))) - proc) - - (and ssh-explicit-args - (setq args (append ssh-explicit-args args))) - - (cond ((null buffer)) - ((stringp buffer) - (setq buffer-name buffer)) - ((bufferp buffer) - (setq buffer-name (buffer-name buffer))) - ((numberp buffer) - (setq buffer-name (format "%s<%d>" buffer-name buffer))) - (t - (setq buffer-name (generate-new-buffer-name buffer-name)))) - - (setq buffer (get-buffer-create buffer-name)) - (pop-to-buffer buffer-name) - - (cond - ((comint-check-proc buffer-name)) - (t - (comint-exec buffer buffer-name ssh-program nil args) - (setq proc (get-buffer-process buffer)) - ;; Set process-mark to point-max in case there is text in the - ;; buffer from a previous exited process. - (set-marker (process-mark proc) (point-max)) - - ;; comint-output-filter-functions is just like a hook, except that the - ;; functions in that list are passed arguments. add-hook serves well - ;; enough for modifying it. - ;; comint-output-filter-functions should already have a - ;; permanent-local property, at least in emacs 19.27 or later. - (if (fboundp 'make-local-hook) - (make-local-hook 'comint-output-filter-functions) - (make-local-variable 'comint-output-filter-functions)) - (add-hook 'comint-output-filter-functions 'ssh-carriage-filter) - - (ssh-mode) - - (make-local-variable 'ssh-host) - (setq ssh-host host) - (make-local-variable 'ssh-remote-user) - (setq ssh-remote-user user) - - (condition-case () - (cond ((eq ssh-directory-tracking-mode t) - ;; Do this here, rather than calling the tracking mode - ;; function, to avoid a gratuitous resync check; the default - ;; should be the user's home directory, be it local or remote. - (setq comint-file-name-prefix - (concat "/" ssh-remote-user "@" ssh-host ":")) - (cd-absolute comint-file-name-prefix)) - ((null ssh-directory-tracking-mode)) - (t - (cd-absolute (concat comint-file-name-prefix "~/")))) - (error nil)))))) - -(put 'ssh-mode 'mode-class 'special) - -(defun ssh-mode () - "Set major-mode for ssh sessions. -If `ssh-mode-hook' is set, run it." - (interactive) - (kill-all-local-variables) - (shell-mode) - (setq major-mode 'ssh-mode) - (setq mode-name "ssh") - (use-local-map ssh-mode-map) - (setq shell-dirtrackp ssh-directory-tracking-mode) - (make-local-variable 'comint-file-name-prefix) - (run-hooks 'ssh-mode-hook)) - -(defun ssh-directory-tracking-mode (&optional prefix) - "Do remote or local directory tracking, or disable entirely. - -If called with no prefix argument or a unspecified prefix argument (just -``\\[universal-argument]'' with no number) do remote directory tracking via -ange-ftp. If called as a function, give it no argument. - -If called with a negative prefix argument, disable directory tracking -entirely. - -If called with a positive, numeric prefix argument, e.g. -``\\[universal-argument] 1 M-x ssh-directory-tracking-mode\'', -then do directory tracking but assume the remote filesystem is the same as -the local system. This only works in general if the remote machine and the -local one share the same directories (through NFS)." - (interactive "P") - (cond - ((or (null prefix) - (consp prefix)) - (setq ssh-directory-tracking-mode t) - (setq shell-dirtrackp t) - (setq comint-file-name-prefix - (concat "/" ssh-remote-user "@" ssh-host ":"))) - ((< prefix 0) - (setq ssh-directory-tracking-mode nil) - (setq shell-dirtrackp nil)) - (t - (setq ssh-directory-tracking-mode 'local) - (setq comint-file-name-prefix "") - (setq shell-dirtrackp t))) - (cond - (shell-dirtrackp - (let* ((proc (get-buffer-process (current-buffer))) - (proc-mark (process-mark proc)) - (current-input (buffer-substring proc-mark (point-max))) - (orig-point (point)) - (offset (and (>= orig-point proc-mark) - (- (point-max) orig-point)))) - (unwind-protect - (progn - (delete-region proc-mark (point-max)) - (goto-char (point-max)) - (shell-resync-dirs)) - (goto-char proc-mark) - (insert current-input) - (if offset - (goto-char (- (point-max) offset)) - (goto-char orig-point))))))) - - -;; Parse a line into its constituent parts (words separated by -;; whitespace). Return a list of the words. -(defun ssh-parse-words (line) - (let ((list nil) - (posn 0) - (match-data (match-data))) - (while (string-match "[^ \t\n]+" line posn) - (setq list (cons (substring line (match-beginning 0) (match-end 0)) - list)) - (setq posn (match-end 0))) - (store-match-data (match-data)) - (nreverse list))) - -(defun ssh-carriage-filter (string) - (let* ((point-marker (point-marker)) - (end (process-mark (get-buffer-process (current-buffer)))) - (beg (or (and (boundp 'comint-last-output-start) - comint-last-output-start) - (- end (length string))))) - (goto-char beg) - (while (search-forward "\C-m" end t) - (delete-char -1)) - (goto-char point-marker))) - -(defun ssh-send-Ctrl-C () - (interactive) - (send-string nil "\C-c")) - -(defun ssh-send-Ctrl-D () - (interactive) - (send-string nil "\C-d")) - -(defun ssh-send-Ctrl-Z () - (interactive) - (send-string nil "\C-z")) - -(defun ssh-send-Ctrl-backslash () - (interactive) - (send-string nil "\C-\\")) - -(defun ssh-delchar-or-send-Ctrl-D (arg) - "\ -Delete ARG characters forward, or send a C-d to process if at end of buffer." - (interactive "p") - (if (eobp) - (ssh-send-Ctrl-D) - (delete-char arg))) - -(defun ssh-tab-or-complete () - "Complete file name if doing directory tracking, or just insert TAB." - (interactive) - (if ssh-directory-tracking-mode - (comint-dynamic-complete) - (insert "\C-i"))) - -;;; ssh.el ends here
--- a/lisp/comint/telnet.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,328 +0,0 @@ -;;; telnet.el --- run a telnet session from within an Emacs buffer - -;;; Copyright (C) 1985, 1988, 1992, 1994 Free Software Foundation, Inc. - -;; Author: William F. Schelter -;; Keywords: comm, unix -;; Maintainer: FSF - -;; 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.34. - -;;; Commentary: - -;; This mode is intended to be used for telnet or rsh to a remode host; -;; `telnet' and `rsh' are the two entry points. Multiple telnet or rsh -;; sessions are supported. -;; -;; Normally, input is sent to the remote telnet/rsh line-by-line, as you -;; type RET or LFD. C-c C-c sends a C-c to the remote immediately; -;; C-c C-z sends C-z immediately. C-c C-q followed by any character -;; sends that character immediately. -;; -;; All RET characters are filtered out of the output coming back from the -;; remote system. The mode tries to do other useful translations based -;; on what it sees coming back from the other system before the password -;; query. It knows about UNIX, ITS, TOPS-20 and Explorer systems. - -;;; Code: - -;; to do fix software types for lispm: -;; to eval current expression. Also to try to send escape keys correctly. -;; essentially we'll want the rubout-handler off. - -;; filter is simplistic but should be okay for typical shell usage. -;; needs hacking if it is going to deal with asynchronous output in a sane -;; manner - -(require 'comint) - -(defgroup telnet nil - "Run a telnet session from within an Emacs buffer." - :group 'comint) - -(defvar telnet-new-line "\r") -(defvar telnet-mode-map nil) -(defvar telnet-default-prompt-pattern "^[^#$%>\n]*[#$%>] *") -(defvar telnet-prompt-pattern telnet-default-prompt-pattern) - -(defvar telnet-replace-c-g nil) -(make-variable-buffer-local - (defvar telnet-remote-echoes t - "True if the telnet process will echo input.")) -(make-variable-buffer-local - (defvar telnet-interrupt-string "\C-c" "String sent by C-c.")) - -(defvar telnet-count 0 - "Number of output strings read from the telnet process -while looking for the initial password.") -;; (make-variable-buffer-local 'telnet-count) - -(defcustom telnet-program "telnet" - "*Program to run to open a telnet connection." - :type 'string - :group 'telnet) - -(defcustom rsh-eat-password-string nil - "Non-nil means rsh will look for a string matching a password prompt." - :type 'boolean - :group 'telnet) - -(defvar telnet-initial-count -75 - "Initial value of `telnet-count'. Should be set to the negative of the -number of terminal writes telnet will make setting up the host connection.") - -(defvar telnet-maximum-count 4 - "Maximum value `telnet-count' can have. -After this many passes, we stop looking for initial setup data. -Should be set to the number of terminal writes telnet will make -rejecting one login and prompting again for a username and password.") - -(defun telnet-interrupt-subjob () - (interactive) - "Interrupt the program running through telnet on the remote host." - (process-send-string nil telnet-interrupt-string)) - -(defun telnet-c-z () - (interactive) - (process-send-string nil "\C-z")) - -;; XEmacs change (Keep telnet- prefix) -(defun telnet-send-process-next-char () - (interactive) - (process-send-string nil - (char-to-string - (let ((inhibit-quit t)) - (prog1 (read-char) - (setq quit-flag nil)))))) - -; initialization on first load. -(if telnet-mode-map - nil - ;; FSF - ;; (setq telnet-mode-map (nconc (make-sparse-keymap) comint-mode-map)) - (setq telnet-mode-map (make-sparse-keymap)) - (set-keymap-parents telnet-mode-map (list comint-mode-map)) - (define-key telnet-mode-map "\C-m" 'telnet-send-input) -; (define-key telnet-mode-map "\C-j" 'telnet-send-input) - (define-key telnet-mode-map "\C-c\C-q" 'telnet-send-process-next-char) - (define-key telnet-mode-map "\C-c\C-c" 'telnet-interrupt-subjob) - (define-key telnet-mode-map "\C-c\C-z" 'telnet-c-z)) - -;;maybe should have a flag for when have found type -(defun telnet-check-software-type-initialize (string) - "Tries to put correct initializations in. Needs work." - (let ((case-fold-search t)) - (cond ((string-match "unix" string) - (setq telnet-prompt-pattern shell-prompt-pattern) - (setq telnet-new-line "\n")) - ((string-match "tops-20" string) ;;maybe add telnet-replace-c-g - (setq telnet-prompt-pattern "[@>] *")) - ((string-match "its" string) - (setq telnet-prompt-pattern "^[^*>\n]*[*>] *")) - ((string-match "explorer" string) ;;explorer telnet needs work - (setq telnet-replace-c-g ?\n)))) - (setq comint-prompt-regexp telnet-prompt-pattern)) - -(defun telnet-initial-filter (proc string) - (let ((case-fold-search t)) - ;For reading up to and including password; also will get machine type. - (cond ((string-match "No such host" string) - (kill-buffer (process-buffer proc)) - (error "No such host.")) - ((string-match "passw" string) - (telnet-filter proc string) - (let ((password (comint-read-noecho "Password: " t))) - (setq telnet-count 0) - (process-send-string proc (concat password telnet-new-line)))) - (t (telnet-check-software-type-initialize string) - (telnet-filter proc string) - (cond ((> telnet-count telnet-maximum-count) - ;; (set-process-filter proc 'telnet-filter) Kludge - ;; for shell-fonts -- this is the only mode that - ;; actually changes what its process filter is at - ;; run time, which confuses shell-font. So we - ;; special-case that here. - ;; #### Danger, knows an internal shell-font variable name. - (let ((old-filter (process-filter proc))) - (if (eq old-filter 'shell-font-process-filter) - (set (make-local-variable 'shell-font-process-filter) - 'telnet-filter) - (set-process-filter proc 'telnet-filter)))) - (t (setq telnet-count (1+ telnet-count)))))))) - -;; Identical to comint-simple-send, except that it sends telnet-new-line -;; instead of "\n". -(defun telnet-simple-send (proc string) - (comint-send-string proc string) - (comint-send-string proc telnet-new-line)) - -(defun telnet-filter (proc string) - (save-excursion - (set-buffer (process-buffer proc)) - (save-match-data - (let* ((last-insertion (marker-position (process-mark proc))) - (delta (- (point) last-insertion)) - (ie (and comint-last-input-end - (marker-position comint-last-input-end))) - (w (get-buffer-window (current-buffer))) - (ws (and w (window-start w)))) - (goto-char last-insertion) - ;; Insert STRING, omitting all C-m characters. - (insert-before-markers string) - (set-marker (process-mark proc) (point)) - ;; the insert-before-markers may have screwed window-start - ;; and likely moved comint-last-input-end. This is why the - ;; insertion-reaction should be a property of markers, not - ;; of the function which does the inserting. - (if ws (set-window-start w ws t)) - (if ie (set-marker comint-last-input-end ie)) - (while (progn (skip-chars-backward "^\C-m" last-insertion) - (> (point) last-insertion)) - (delete-region (1- (point)) (point))) - (goto-char (process-mark proc)) - (and telnet-replace-c-g - (subst-char-in-region last-insertion (point) ?\C-g - telnet-replace-c-g t)) - ;; If point is after the insertion place, move it - ;; along with the text. - (if (> delta 0) - (goto-char (+ (process-mark proc) delta))))))) - -(defun telnet-send-input () - (interactive) - (let ((proc (get-buffer-process (current-buffer))) - p1 p2) - (if (and telnet-remote-echoes - (>= (point) (process-mark proc))) - (save-excursion - (if comint-eol-on-send (end-of-line)) - (setq p1 (marker-position (process-mark proc)) - p2 (point)))) - (prog1 - (comint-send-input) - ;; at this point, comint-send-input has moved the process mark, inserted - ;; a newline, and possibly inserted the (echoed) output. If the host is - ;; in remote-echo mode, then delete our local copy of the command, and - ;; the newline that comint-send-input sent. - (if p1 - (delete-region p1 (1+ p2)))))) - -;;;###autoload (add-hook 'same-window-regexps "\\*telnet-.*\\*\\(\\|<[0-9]+>\\)") - -;;;###autoload -(defun telnet (host &optional port) - "Open a network login connection to host named HOST (a string). -With a prefix argument, prompts for the port name or number as well. -Communication with HOST is recorded in a buffer `*HOST-telnet*'. -Normally input is edited in Emacs and sent a line at a time. -See also `\\[rsh]'." - (interactive (list (read-string "Open telnet connection to host: ") - (if current-prefix-arg - (read-string "Port name or number: ") - nil))) - (let* ((comint-delimiter-argument-list '(?\ ?\t)) - (name (concat "telnet-" (comint-arguments host 0 nil) - (if port (concat "/" port) ""))) - (buffer (get-buffer (concat "*" name "*"))) - process) - (if (and buffer (get-buffer-process buffer)) - (pop-to-buffer buffer) - (pop-to-buffer (make-comint name telnet-program)) - (setq process (get-buffer-process (current-buffer))) - (set-process-filter process 'telnet-initial-filter) - - ;; SunOS and IRIX don't print "unix" in their rsh or telnet - ;; login banners, so let's get a reasonable default here. - ;; #### This patch from jwz mimics what is done in rsh done - ;; below. However, it (along with the one in rsh) mean that - ;; telnet-check-software-type-initialize is effectively a - ;; wastoid function. Reworking it like it claims to need is - ;; probably the better solution but I'm not going to do it. - ;; --cet - (telnet-check-software-type-initialize "unix") - - ;; Don't send the `open' cmd till telnet is ready for it. - (accept-process-output process) - (erase-buffer) - (process-send-string process (concat "open " host - (if port (concat " " port) "") - "\n")) - (setq comint-input-sender 'telnet-simple-send) - ;; run last so that hooks can change things. - (telnet-mode)))) - -(defun telnet-mode () - "This mode is for using telnet (or rsh) from a buffer to another host. -It has most of the same commands as comint-mode. -There is a variable ``telnet-interrupt-string'' which is the character -sent to try to stop execution of a job on the remote host. -Data is sent to the remote host when RET is typed. - -\\{telnet-mode-map} -" - (interactive) - (comint-mode) - (setq major-mode 'telnet-mode - mode-name "Telnet" - comint-prompt-regexp telnet-prompt-pattern) - (use-local-map telnet-mode-map) - (set (make-local-variable 'telnet-count) telnet-initial-count) - (run-hooks 'telnet-mode-hook)) - -;;;###autoload (add-hook 'same-window-regexps "\\*rsh-[^-]*\\*\\(\\|<[0-9]*>\\)") - -;; Berkeley spawn of hell -;;;###autoload -(defun rsh (host) - "Open a network login connection to host named HOST (a string). -Communication with HOST is recorded in a buffer `*rsh-HOST*'. -Normally input is edited in Emacs and sent a line at a time. -See also `\\[telnet]'." - (interactive "sOpen rsh connection to host: ") - (require 'shell) - (let ((name (concat "rsh-" host))) - (pop-to-buffer (make-comint name remote-shell-program nil host)) - (setq telnet-count telnet-initial-count) - ;; - ;; SunOS doesn't print "unix" in its rsh login banner, so let's get a - ;; reasonable default here. There do exist non-Unix machines which - ;; speak the rsh protocol, but let's hope they print their OS name - ;; when one connects. - ;; - (telnet-check-software-type-initialize "unix") - ;; - ;; I think we should use telnet-filter here instead of -initial-filter, - ;; because rsh generally doesn't prompt for a password, and gobbling the - ;; first line that contains "passw" is extremely antisocial. More - ;; antisocial than echoing a password, and more likely than connecting - ;; to a non-Unix rsh host these days... - ;; - ;; I disagree with the above. -sb - ;; - (set-process-filter (get-process name) (if rsh-eat-password-string - 'telnet-initial-filter - 'telnet-filter)) - ;; (set-process-filter (get-process name) 'telnet-filter) - ;; run last so that hooks can change things. - (telnet-mode))) - -(provide 'telnet) - -;;; telnet.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/console.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,49 @@ +;;; console.el --- miscellaneous console functions not written in C + +;; Copyright (C) 1994-5, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1995, 1996 Ben Wing + +;; Maintainer: XEmacs Development Team +;; Keywords: internal, dumped + +;; 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, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: Not in FSF. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;;; Code: + +(defun quit-char (&optional console) + "Return the character that causes a QUIT to happen. +This is normally C-g. Optional arg CONSOLE specifies the console +that the information is returned for; nil means the current console." + (nth 3 (current-input-mode console))) + +(defun resume-pid-console (pid) + "Resume the consoles with a controlling process of PID." + (mapc (lambda (c) + (if (and (eq (console-type c) 'tty) + (eql pid (console-tty-controlling-process c))) + (resume-console c))) + (console-list)) + nil) + +;;; console.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cus-dep.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,182 @@ +;;; cus-dep.el --- Find customization dependencies. +;; +;; Copyright (C) 1997 Free Software Foundation, Inc. +;; +;; Author: Per Abrahamsen <abraham@dina.kvl.dk>, then +;; Richar Stallman <rms@gnu.ai.mit.edu>, then +;; Hrvoje Niksic <hniksic@srce.hr> (rewritten for XEmacs) +;; Maintainer: Hrvoje Niksic <hniksic@srce.hr> +;; Keywords: internal + +;; 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 synched with FSF. + + +;;; Commentary: + +;; This file generates the custom-load files, loaded by cus-load.el. +;; The only entry point is `Custom-make-dependencies'. + +;; It works by scanning all the `.el' files in a directory, and +;; evaluates any `defcustom', `defgroup', or `defface' expression that +;; it finds. The symbol changed by this expression is stored to a +;; hash table as the hash key, file name being the value. + +;; After all the files have been examined, custom-loads.el is +;; generated by mapping all the atoms, and seeing if any of them +;; contains a `custom-group' property. This property is a list whose +;; each element's car is the "child" group symbol. If that property +;; is in the hash-table, the file name will be looked up from the +;; hash-table, and added to cusload-file. Because the hash-table is +;; cleared whenever we process a new directory, we cannot get confused +;; by custom-loads from another directory, or from a previous +;; installation. This is also why it is perfectly safe to have old +;; custom-loads around, and have them loaded by `cus-load.el' (as +;; invoked by `cus-edit.el'). + +;; A trivial, but useful optimization is that if cusload-file exists, +;; and no .el files in the directory are newer than cusload-file, it +;; will not be generated. This means that the directories where +;; nothing has changed will be skipped. + +;; The `custom-put' function, used by files generated by +;; `Custom-make-dependencies', is a specialized function that updates +;; a property (which must be a list of strings) with a new list of +;; strings, eliminating the duplicates. As it also adds an +;; appropriate entry to a custom hash-table, *do not* use it outside +;; of custom. Its inner workings can change anytime, without prior +;; notice. `custom-put' is defined in `cus-load.el'. + +;; Example: + +;; (custom-put 'foo 'custom-loads '("bar" "baz")) +;; (get 'foo 'custom-loads) +;; => ("bar" "baz") +;; +;; (custom-put 'foo 'custom-loads '("hmph" "baz" "quz")) +;; (get 'foo 'custom-loads) +;; => ("bar" "baz" "hmph" "qux") + +;; Obviously, this allows correct incremental loading of custom-load +;; files. This is not necessary under FSF (they use a simple `put'), +;; since they have only *one* file. With the advent of packages, we +;; cannot afford the same luxury. + + +;;; Code: + +(require 'cl) +(require 'widget) +(require 'cus-face) + +;; Don't change this, unless you plan to change the code in +;; cus-start.el, too. +(defconst cusload-base-file "custom-load.el") + +;; Be very careful when changing this function. It looks easy to +;; understand, but is in fact very easy to break. Be sure to read and +;; understand the commentary above! + +;;;###autoload +(defun Custom-make-dependencies (&optional subdirs) + "Extract custom dependencies from .el files in SUBDIRS. +SUBDIRS is a list of directories. If it is nil, the command-line +arguments are used. If it is a string, only that directory is +processed. This function is especially useful in batch mode. + +Batch usage: xemacs -batch -l cus-dep.el -f Custom-make-dependencies DIRS" + (interactive "DDirectory: ") + (and (stringp subdirs) + (setq subdirs (list subdirs))) + (or subdirs + ;; Usurp the command-line-args + (setq subdirs command-line-args-left + command-line-args-left nil)) + (setq subdirs (mapcar #'expand-file-name subdirs)) + (with-temp-buffer + (let ((enable-local-eval nil) + (hash (make-hash-table :test 'eq))) + (dolist (dir subdirs) + (princ (format "Processing %s\n" dir)) + (let ((cusload-file (expand-file-name cusload-base-file dir)) + (files (directory-files dir t "\\`[^=].*\\.el\\'"))) + ;; A trivial optimization: if no file in the directory is + ;; newer than custom-load.el, no need to do anything! + (if (and (file-exists-p cusload-file) + (dolist (file files t) + (when (file-newer-than-file-p file cusload-file) + (return nil)))) + (princ "(No changes need to be written)\n") + ;; Process directory + (dolist (file files) + (when (file-exists-p file) + (erase-buffer) + (insert-file-contents file) + (goto-char (point-min)) + (let ((name (file-name-sans-extension + (file-name-nondirectory file)))) + ;; Search for defcustom/defface/defgroup + ;; expressions, and evaluate them. + (ignore-errors + (while (re-search-forward + "^(defcustom\\|^(defface\\|^(defgroup" + nil t) + (beginning-of-line) + (let ((expr (read (current-buffer)))) + (eval expr) + ;; Hash the file of the affected symbol. + (setf (gethash (nth 1 expr) hash) name))))))) + (cond + ((zerop (hash-table-count hash)) + (princ "(No customization dependencies") + (when (file-exists-p cusload-file) + (princ (format ", deleting %s" cusload-file)) + (delete-file cusload-file)) + (princ ")\n")) + (t + (princ (format "Generating %s...\n" cusload-base-file)) + (with-temp-file cusload-file + (insert ";;; " cusload-base-file + " --- automatically extracted custom dependencies\n" + "\n\n;;; Code:\n\n") + (mapatoms + (lambda (sym) + (let ((members (get sym 'custom-group)) + item where found) + (when members + (while members + (setq item (car (car members)) + members (cdr members) + where (gethash item hash)) + (unless (or (null where) + (member where found)) + (if found + (insert " ") + (insert "(custom-add-loads '" + (symbol-name sym) " '(")) + (prin1 where (current-buffer)) + (push where found))) + (when found + (insert "))\n")))))) + (insert "\n;;; custom-load.el ends here\n")) + (clrhash hash))))))))) + +(provide 'cus-dep) + +;;; cus-dep.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cus-edit.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,3234 @@ +;;; cus-edit.el --- Tools for customizating Emacs and Lisp packages. +;; +;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. +;; +;; Author: Per Abrahamsen <abraham@dina.kvl.dk> +;; Maintainer: Hrvoje Niksic <hniksic@srce.hr> +;; Keywords: help, faces +;; Version: 1.9960-x +;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ + +;; 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. + +;;; Commentary: +;; +;; This file implements the code to create and edit customize buffers. +;; +;; See `custom.el'. + +;; No commands should have names starting with `custom-' because +;; that interferes with completion. Use `customize-' for commands +;; that the user will run with M-x, and `Custom-' for interactive commands. + + +;;; Code: + +(require 'cus-face) +(require 'wid-edit) +(require 'easymenu) + +(require 'cus-load) +(require 'cus-start) + +;; Huh? This looks dirty! +(put 'custom-define-hook 'custom-type 'hook) +(put 'custom-define-hook 'standard-value '(nil)) +(custom-add-to-group 'customize 'custom-define-hook 'custom-variable) + +;;; Customization Groups. + +(defgroup emacs nil + "Customization of the One True Editor." + :link '(custom-manual "(XEmacs)Top")) + +;; Most of these groups are stolen from `finder.el', +(defgroup editing nil + "Basic text editing facilities." + :group 'emacs) + +(defgroup abbrev nil + "Abbreviation handling, typing shortcuts, macros." + :tag "Abbreviations" + :group 'editing) + +(defgroup matching nil + "Various sorts of searching and matching." + :group 'editing) + +(defgroup emulations nil + "Emulations of other editors." + :group 'editing) + +(defgroup mouse nil + "Mouse support." + :group 'editing) + +(defgroup outlines nil + "Support for hierarchical outlining." + :group 'editing) + +(defgroup external nil + "Interfacing to external utilities." + :group 'emacs) + +(defgroup bib nil + "Code related to the `bib' bibliography processor." + :tag "Bibliography" + :group 'external) + +(defgroup processes nil + "Process, subshell, compilation, and job control support." + :group 'external + :group 'development) + +(defgroup programming nil + "Support for programming in other languages." + :group 'emacs) + +(defgroup languages nil + "Specialized modes for editing programming languages." + :group 'programming) + +(defgroup lisp nil + "Lisp support, including Emacs Lisp." + :group 'languages + :group 'development) + +(defgroup c nil + "Support for the C language and related languages." + :group 'languages) + +(defgroup tools nil + "Programming tools." + :group 'programming) + +(defgroup oop nil + "Support for object-oriented programming." + :group 'programming) + +(defgroup applications nil + "Applications written in Emacs." + :group 'emacs) + +(defgroup calendar nil + "Calendar and time management support." + :group 'applications) + +(defgroup mail nil + "Modes for electronic-mail handling." + :group 'applications) + +(defgroup news nil + "Support for netnews reading and posting." + :group 'applications) + +(defgroup games nil + "Games, jokes and amusements." + :group 'applications) + +(defgroup development nil + "Support for further development of Emacs." + :group 'emacs) + +(defgroup docs nil + "Support for Emacs documentation." + :group 'development) + +(defgroup extensions nil + "Emacs Lisp language extensions." + :group 'development) + +(defgroup internal nil + "Code for Emacs internals, build process, defaults." + :group 'development) + +(defgroup maint nil + "Maintenance aids for the Emacs development group." + :tag "Maintenance" + :group 'development) + +(defgroup environment nil + "Fitting Emacs with its environment." + :group 'emacs) + +(defgroup comm nil + "Communications, networking, remote access to files." + :tag "Communication" + :group 'environment) + +(defgroup hardware nil + "Support for interfacing with exotic hardware." + :group 'environment) + +(defgroup terminals nil + "Support for terminal types." + :group 'environment) + +(defgroup unix nil + "Front-ends/assistants for, or emulators of, UNIX features." + :group 'environment) + +(defgroup vms nil + "Support code for vms." + :group 'environment) + +(defgroup i18n nil + "Internationalization and alternate character-set support." + :group 'environment + :group 'editing) + +(defgroup x nil + "The X Window system." + :group 'environment) + +(defgroup frames nil + "Support for Emacs frames and window systems." + :group 'environment) + +(defgroup data nil + "Support editing files of data." + :group 'emacs) + +(defgroup files nil + "Support editing files." + :group 'emacs) + +(defgroup wp nil + "Word processing." + :group 'emacs) + +(defgroup tex nil + "Code related to the TeX formatter." + :group 'wp) + +(defgroup faces nil + "Support for multiple fonts." + :group 'emacs) + +(defgroup hypermedia nil + "Support for links between text or other media types." + :group 'emacs) + +(defgroup help nil + "Support for on-line help systems." + :group 'emacs) + +(defgroup local nil + "Code local to your site." + :group 'emacs) + +(defgroup customize '((widgets custom-group)) + "Customization of the Customization support." + :link '(custom-manual "(custom)Top") + :link '(url-link :tag "Development Page" + "http://www.dina.kvl.dk/~abraham/custom/") + :prefix "custom-" + :group 'help) + +(defgroup custom-faces nil + "Faces used by customize." + :group 'customize + :group 'faces) + +(defgroup custom-browse nil + "Control customize browser." + :prefix "custom-" + :group 'customize) + +(defgroup custom-buffer nil + "Control customize buffers." + :prefix "custom-" + :group 'customize) + +(defgroup custom-menu nil + "Control customize menus." + :prefix "custom-" + :group 'customize) + +(defgroup abbrev-mode nil + "Word abbreviations mode." + :group 'abbrev) + +(defgroup alloc nil + "Storage allocation and gc for GNU Emacs Lisp interpreter." + :tag "Storage Allocation" + :group 'internal) + +(defgroup undo nil + "Undoing changes in buffers." + :group 'editing) + +(defgroup modeline nil + "Content of the modeline." + :group 'environment) + +(defgroup fill nil + "Indenting and filling text." + :group 'editing) + +(defgroup editing-basics nil + "Most basic editing facilities." + :group 'editing) + +(defgroup display nil + "How characters are displayed in buffers." + :group 'environment) + +(defgroup execute nil + "Executing external commands." + :group 'processes) + +(defgroup installation nil + "The Emacs installation." + :group 'environment) + +(defgroup dired nil + "Directory editing." + :group 'environment) + +(defgroup limits nil + "Internal Emacs limits." + :group 'internal) + +(defgroup debug nil + "Debugging Emacs itself." + :group 'development) + +(defgroup minibuffer nil + "Controling the behaviour of the minibuffer." + :group 'environment) + +(defgroup keyboard nil + "Input from the keyboard." + :group 'environment) + +(defgroup mouse nil + "Input from the mouse." + :group 'environment) + +(defgroup menu nil + "Input from the menus." + :group 'environment) + +(defgroup auto-save nil + "Preventing accidential loss of data." + :group 'files) + +(defgroup processes-basics nil + "Basic stuff dealing with processes." + :group 'processes) + +(defgroup mule nil + "MULE Emacs internationalization." + :group 'i18n) + +(defgroup windows nil + "Windows within a frame." + :group 'environment) + + +;;; Utilities. + +(defun custom-quote (sexp) + "Quote SEXP iff it is not self quoting." + (if (or (memq sexp '(t nil)) + (keywordp sexp) + (eq (car-safe sexp) 'lambda) + (stringp sexp) + (numberp sexp) + (characterp sexp)) + sexp + (list 'quote sexp))) + +(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 \"\\|\") + +IF REGEXP is not a string, return it unchanged." + (if (stringp regexp) + (split-string regexp "\\\\|") + regexp)) + +(defun custom-variable-prompt () + ;; Code stolen from `help.el'. + "Prompt for a variable, defaulting to the variable at point. +Return a list suitable for use in `interactive'." + (let ((v (variable-at-point)) + (enable-recursive-minibuffers t) + val) + (setq val (completing-read + (if (symbolp v) + (format "Customize variable: (default %s) " v) + "Customize variable: ") + obarray (lambda (symbol) + (and (boundp symbol) + (or (get symbol 'custom-type) + (user-variable-p symbol)))))) + (list (if (equal val "") + (if (symbolp v) v nil) + (intern val))))) + +;; Here we take not only the actual groups, but the loads, too. +(defun custom-group-prompt (prompt) + "Read group from minibuffer." + (let ((completion-ignore-case t)) + (list (completing-read + prompt obarray + (lambda (symbol) + (or (get symbol 'custom-group) + (get symbol 'custom-loads))) + t)))) + +(defun custom-menu-filter (menu widget) + "Convert MENU to the form used by `widget-choose'. +MENU should be in the same format as `custom-variable-menu'. +WIDGET is the widget to apply the filter entries of MENU on." + (let ((result nil) + current name action filter) + (while menu + (setq current (car menu) + name (nth 0 current) + action (nth 1 current) + filter (nth 2 current) + menu (cdr menu)) + (if (or (null filter) (funcall filter widget)) + (push (cons name action) result) + (push name result))) + (nreverse result))) + + +;;; Unlispify. + +(defvar custom-prefix-list nil + "List of prefixes that should be ignored by `custom-unlispify'") + +(defcustom custom-unlispify-menu-entries t + "Display menu entries as words instead of symbols if non nil." + :group 'custom-menu + :type 'boolean) + +(defcustom custom-unlispify-remove-prefixes t + "Non-nil means remove group prefixes from option names in buffers and menus." + :group 'custom-menu + :type 'boolean) + +(defun custom-unlispify-menu-entry (symbol &optional no-suffix) + "Convert symbol into a menu entry." + (cond ((not custom-unlispify-menu-entries) + (symbol-name symbol)) + ((get symbol 'custom-tag) + (if no-suffix + (get symbol 'custom-tag) + (concat (get symbol 'custom-tag) "..."))) + (t + (with-current-buffer (get-buffer-create " *Custom-Work*") + (erase-buffer) + (princ symbol (current-buffer)) + (goto-char (point-min)) + (when (and (eq (get symbol 'custom-type) 'boolean) + (re-search-forward "-p\\'" nil t)) + (replace-match "" t t) + (goto-char (point-min))) + (when custom-unlispify-remove-prefixes + (let ((prefixes custom-prefix-list) + prefix) + (while prefixes + (setq prefix (car prefixes)) + (if (search-forward prefix (+ (point) (length prefix)) t) + (progn + (setq prefixes nil) + (delete-region (point-min) (point))) + (setq prefixes (cdr prefixes)))))) + (subst-char-in-region (point-min) (point-max) ?- ?\ t) + (capitalize-region (point-min) (point-max)) + (unless no-suffix + (goto-char (point-max)) + (insert "...")) + (buffer-string))))) + +(defcustom custom-unlispify-tag-names t + "Display tag names as words instead of symbols if non nil." + :group 'custom-buffer + :type 'boolean) + +(defun custom-unlispify-tag-name (symbol) + "Convert symbol into a menu entry." + (let ((custom-unlispify-menu-entries custom-unlispify-tag-names)) + (custom-unlispify-menu-entry symbol t))) + +(defun custom-prefix-add (symbol prefixes) + ;; Addd SYMBOL to list of ignored PREFIXES. + (cons (or (get symbol 'custom-prefix) + (concat (symbol-name symbol) "-")) + prefixes)) + + +;;; Guess. + +(defcustom custom-guess-name-alist + '(("-p\\'" boolean) + ("-hooks?\\'" hook) + ("-face\\'" face) + ("-file\\'" file) + ("-function\\'" function) + ("-functions\\'" (repeat function)) + ("-list\\'" (repeat sexp)) + ("-alist\\'" (repeat (cons sexp sexp)))) + "Alist of (MATCH TYPE). + +MATCH should be a regexp matching the name of a symbol, and TYPE should +be a widget suitable for editing the value of that symbol. The TYPE +of the first entry where MATCH matches the name of the symbol will be +used. + +This is used for guessing the type of variables not declared with +customize." + :type '(repeat (group (regexp :tag "Match") (sexp :tag "Type"))) + :group 'customize) + +(defcustom custom-guess-doc-alist + '(("\\`\\*?Non-nil " boolean)) + "Alist of (MATCH TYPE). + +MATCH should be a regexp matching a documentation string, and TYPE +should be a widget suitable for editing the value of a variable with +that documentation string. The TYPE of the first entry where MATCH +matches the name of the symbol will be used. + +This is used for guessing the type of variables not declared with +customize." + :type '(repeat (group (regexp :tag "Match") (sexp :tag "Type"))) + :group 'customize) + +(defun custom-guess-type (symbol) + "Guess a widget suitable for editing the value of SYMBOL. +This is done by matching SYMBOL with `custom-guess-name-alist' and +if that fails, the doc string with `custom-guess-doc-alist'." + (let ((name (symbol-name symbol)) + (names custom-guess-name-alist) + current found) + (while names + (setq current (car names) + names (cdr names)) + (when (string-match (nth 0 current) name) + (setq found (nth 1 current) + names nil))) + (unless found + (let ((doc (documentation-property symbol 'variable-documentation)) + (docs custom-guess-doc-alist)) + (when doc + (while docs + (setq current (car docs) + docs (cdr docs)) + (when (string-match (nth 0 current) doc) + (setq found (nth 1 current) + docs nil)))))) + found)) + + +;;; Sorting. + +(defcustom custom-browse-sort-alphabetically nil + "If non-nil, sort members of each customization group alphabetically." + :type 'boolean + :group 'custom-browse) + +(defcustom custom-browse-order-groups nil + "If non-nil, order group members within each customization group. +If `first', order groups before non-groups. +If `last', order groups after non-groups." + :type '(choice (const first) + (const last) + (const :tag "none" nil)) + :group 'custom-browse) + +(defcustom custom-browse-only-groups nil + "If non-nil, show group members only within each customization group." + :type 'boolean + :group 'custom-browse) + +(defcustom custom-buffer-sort-alphabetically nil + "If non-nil, sort members of each customization group alphabetically." + :type 'boolean + :group 'custom-buffer) + +(defcustom custom-buffer-order-groups 'last + "If non-nil, order group members within each customization group. +If `first', order groups before non-groups. +If `last', order groups after non-groups." + :type '(choice (const first) + (const last) + (const :tag "none" nil)) + :group 'custom-buffer) + +(defcustom custom-menu-sort-alphabetically nil + "If non-nil, sort members of each customization group alphabetically." + :type 'boolean + :group 'custom-menu) + +(defcustom custom-menu-order-groups 'first + "If non-nil, order group members within each customization group. +If `first', order groups before non-groups. +If `last', order groups after non-groups." + :type '(choice (const first) + (const last) + (const :tag "none" nil)) + :group 'custom-menu) + +(defun custom-sort-items (items sort-alphabetically order-groups) + "Return a sorted copy of ITEMS. +ITEMS should be a `custom-group' property. +If SORT-ALPHABETICALLY non-nil, sort alphabetically. +If ORDER-GROUPS is `first' order groups before non-groups, if `last' order +groups after non-groups, if nil do not order groups at all." + (sort (copy-sequence items) + (lambda (a b) + (let ((typea (nth 1 a)) (typeb (nth 1 b)) + (namea (symbol-name (nth 0 a))) (nameb (symbol-name (nth 0 b)))) + (cond ((not order-groups) + ;; Since we don't care about A and B order, maybe sort. + (when sort-alphabetically + (string-lessp namea nameb))) + ((eq typea 'custom-group) + ;; If B is also a group, maybe sort. Otherwise, order A and B. + (if (eq typeb 'custom-group) + (when sort-alphabetically + (string-lessp namea nameb)) + (eq order-groups 'first))) + ((eq typeb 'custom-group) + ;; Since A cannot be a group, order A and B. + (eq order-groups 'last)) + (sort-alphabetically + ;; Since A and B cannot be groups, sort. + (string-lessp namea nameb))))))) + + +;;; Custom Mode Commands. + +(defvar custom-options nil + "Customization widgets in the current buffer.") + +(defun Custom-set () + "Set changes in all modified options." + (interactive) + (let ((children custom-options)) + (mapc (lambda (child) + (when (eq (widget-get child :custom-state) 'modified) + (widget-apply child :custom-set))) + children))) + +(defun Custom-save () + "Set all modified group members and save them." + (interactive) + (let ((children custom-options)) + (mapc (lambda (child) + (when (memq (widget-get child :custom-state) '(modified set)) + (widget-apply child :custom-save))) + children)) + (custom-save-all)) + +(defvar custom-reset-menu + '(("Current" . Custom-reset-current) + ("Saved" . Custom-reset-saved) + ("Standard Settings" . Custom-reset-standard)) + "Alist of actions for the `Reset' button. +The key is a string containing the name of the action, the value is a +lisp function taking the widget as an element which will be called +when the action is chosen.") + +(defun custom-reset (event) + "Select item from reset menu." + (let* ((completion-ignore-case t) + (answer (widget-choose "Reset to" + custom-reset-menu + event))) + (if answer + (funcall answer)))) + +(defun Custom-reset-current (&rest ignore) + "Reset all modified group members to their current value." + (interactive) + (let ((children custom-options)) + (mapc (lambda (child) + (when (eq (widget-get child :custom-state) 'modified) + (widget-apply child :custom-reset-current))) + children))) + +(defun Custom-reset-saved (&rest ignore) + "Reset all modified or set group members to their saved value." + (interactive) + (let ((children custom-options)) + (mapc (lambda (child) + (when (eq (widget-get child :custom-state) 'modified) + (widget-apply child :custom-reset-saved))) + children))) + +(defun Custom-reset-standard (&rest ignore) + "Reset all modified, set, or saved group members to their standard settings." + (interactive) + (let ((children custom-options)) + (mapc (lambda (child) + (when (eq (widget-get child :custom-state) 'modified) + (widget-apply child :custom-reset-standard))) + children))) + + +;;; The Customize Commands + +(defun custom-prompt-variable (prompt-var prompt-val) + "Prompt for a variable and a value and return them as a list. +PROMPT-VAR is the prompt for the variable, and PROMPT-VAL is the +prompt for the value. The %s escape in PROMPT-VAL is replaced with +the name of the variable. + +If the variable has a `variable-interactive' property, that is used as if +it were the arg to `interactive' (which see) to interactively read the value. + +If the variable has a `custom-type' property, it must be a widget and the +`:prompt-value' property of that widget will be used for reading the value." + (let* ((var (read-variable prompt-var)) + (minibuffer-help-form '(describe-variable var))) + (list var + (let ((prop (get var 'variable-interactive)) + (type (get var 'custom-type)) + (prompt (format prompt-val var))) + (unless (listp type) + (setq type (list type))) + (cond (prop + ;; Use VAR's `variable-interactive' property + ;; as an interactive spec for prompting. + (call-interactively (list 'lambda '(arg) + (list 'interactive prop) + 'arg))) + (type + (widget-prompt-value type + prompt + (if (boundp var) + (symbol-value var)) + (not (boundp var)))) + (t + (eval-minibuffer prompt))))))) + +;;;###autoload +(defun customize-set-value (var val) + "Set VARIABLE to VALUE. VALUE is a Lisp object. + +If VARIABLE has a `variable-interactive' property, that is used as if +it were the arg to `interactive' (which see) to interactively read the value. + +If VARIABLE has a `custom-type' property, it must be a widget and the +`:prompt-value' property of that widget will be used for reading the value." + (interactive (custom-prompt-variable "Set variable: " + "Set %s to value: ")) + + (set var val)) + +;;;###autoload +(defun customize-set-variable (var val) + "Set the default for VARIABLE to VALUE. VALUE is a Lisp object. + +If VARIABLE has a `custom-set' property, that is used for setting +VARIABLE, otherwise `set-default' is used. + +The `customized-value' property of the VARIABLE will be set to a list +with a quoted VALUE as its sole list member. + +If VARIABLE has a `variable-interactive' property, that is used as if +it were the arg to `interactive' (which see) to interactively read the value. + +If VARIABLE has a `custom-type' property, it must be a widget and the +`:prompt-value' property of that widget will be used for reading the value. " + (interactive (custom-prompt-variable "Set variable: " + "Set customized value for %s to: ")) + (funcall (or (get var 'custom-set) 'set-default) var val) + (put var 'customized-value (list (custom-quote val)))) + +;;;###autoload +(defun customize-save-variable (var val) + "Set the default for VARIABLE to VALUE, and save it for future sessions. +If VARIABLE has a `custom-set' property, that is used for setting +VARIABLE, otherwise `set-default' is used. + +The `customized-value' property of the VARIABLE will be set to a list +with a quoted VALUE as its sole list member. + +If VARIABLE has a `variable-interactive' property, that is used as if +it were the arg to `interactive' (which see) to interactively read the value. + +If VARIABLE has a `custom-type' property, it must be a widget and the +`:prompt-value' property of that widget will be used for reading the value. " + (interactive (custom-prompt-variable "Set and ave variable: " + "Set and save value for %s as: ")) + (funcall (or (get var 'custom-set) 'set-default) var val) + (put var 'saved-value (list (custom-quote val))) + (custom-save-all)) + +;;;###autoload +(defun customize (group) + "Select a customization buffer which you can use to set user options. +User options are structured into \"groups\". +The default group is `Emacs'." + (interactive (custom-group-prompt + "Customize group: (default emacs) ")) + (when (stringp group) + (if (string-equal "" group) + (setq group 'emacs) + (setq group (intern group)))) + (let ((name (format "*Customize Group: %s*" + (custom-unlispify-tag-name group)))) + (if (get-buffer name) + (switch-to-buffer name) + (custom-buffer-create (list (list group 'custom-group)) + name + (concat " for group " + (custom-unlispify-tag-name group)))))) + +;;;###autoload +(defalias 'customize-group 'customize) + +;;;###autoload +(defun customize-other-window (symbol) + "Customize SYMBOL, which must be a customization group." + (interactive (custom-group-prompt + "Customize group: (default emacs) ")) + (when (stringp symbol) + (if (string-equal "" symbol) + (setq symbol 'emacs) + (setq symbol (intern symbol)))) + (custom-buffer-create-other-window + (list (list symbol 'custom-group)) + (format "*Customize Group: %s*" (custom-unlispify-tag-name symbol)))) + +;;;###autoload +(defalias 'customize-group-other-window 'customize-other-window) + +;;;###autoload +(defalias 'customize-option 'customize-variable) + +;;;###autoload +(defun customize-variable (symbol) + "Customize SYMBOL, which must be a user option variable." + (interactive (custom-variable-prompt)) + (custom-buffer-create (list (list symbol 'custom-variable)) + (format "*Customize Variable: %s*" + (custom-unlispify-tag-name symbol)))) + +;;;###autoload +(defalias 'customize-variable-other-window 'customize-option-other-window) + +;;;###autoload +(defun customize-option-other-window (symbol) + "Customize SYMBOL, which must be a user option variable. +Show the buffer in another window, but don't select it." + (interactive (custom-variable-prompt)) + (custom-buffer-create-other-window + (list (list symbol 'custom-variable)) + (format "*Customize Option: %s*" (custom-unlispify-tag-name symbol)))) + +;;;###autoload +(defun customize-face (&optional symbol) + "Customize SYMBOL, which should be a face name or nil. +If SYMBOL is nil, customize all faces." + (interactive (list (completing-read "Customize face: (default all) " + obarray 'find-face))) + (if (or (null symbol) (and (stringp symbol) (zerop (length symbol)))) + (custom-buffer-create (custom-sort-items + (mapcar (lambda (symbol) + (list symbol 'custom-face)) + (face-list)) + t nil) + "*Customize Faces*") + (when (stringp symbol) + (setq symbol (intern symbol))) + (unless (symbolp symbol) + (error "Should be a symbol %S" symbol)) + (custom-buffer-create (list (list symbol 'custom-face)) + (format "*Customize Face: %s*" + (custom-unlispify-tag-name symbol))))) + +;;;###autoload +(defun customize-face-other-window (&optional symbol) + "Show customization buffer for FACE in other window." + (interactive (list (completing-read "Customize face: " + obarray 'find-face))) + (if (or (null symbol) (and (stringp symbol) (zerop (length symbol)))) + () + (if (stringp symbol) + (setq symbol (intern symbol))) + (unless (symbolp symbol) + (error "Should be a symbol %S" symbol)) + (custom-buffer-create-other-window + (list (list symbol 'custom-face)) + (format "*Customize Face: %s*" (custom-unlispify-tag-name symbol))))) + +;;;###autoload +(defun customize-customized () + "Customize all user options set since the last save in this session." + (interactive) + (let ((found nil)) + (mapatoms (lambda (symbol) + (and (get symbol 'customized-face) + (find-face symbol) + (push (list symbol 'custom-face) found)) + (and (get symbol 'customized-value) + (boundp symbol) + (push (list symbol 'custom-variable) found)))) + (if (not found) + (error "No customized user options") + (custom-buffer-create (custom-sort-items found t nil) + "*Customize Customized*")))) + +;;;###autoload +(defun customize-saved () + "Customize all already saved user options." + (interactive) + (let ((found nil)) + (mapatoms (lambda (symbol) + (and (get symbol 'saved-face) + (find-face symbol) + (push (list symbol 'custom-face) found)) + (and (get symbol 'saved-value) + (boundp symbol) + (push (list symbol 'custom-variable) found)))) + (if (not found ) + (error "No saved user options") + (custom-buffer-create (custom-sort-items found t nil) + "*Customize Saved*")))) + +;;;###autoload +(defun customize-apropos (regexp &optional all) + "Customize all user options matching REGEXP. +If ALL is `options', include only options. +If ALL is `faces', include only faces. +If ALL is `groups', include only groups. +If ALL is t (interactively, with prefix arg), include options which are not +user-settable, as well as faces and groups." + (interactive "sCustomize regexp: \nP") + (let ((found nil)) + (mapatoms (lambda (symbol) + (when (string-match regexp (symbol-name symbol)) + (when (and (not (memq all '(faces options))) + (get symbol 'custom-group)) + (push (list symbol 'custom-group) found)) + (when (and (not (memq all '(options groups))) + (find-face symbol)) + (push (list symbol 'custom-face) found)) + (when (and (not (memq all '(groups faces))) + (boundp symbol) + (or (get symbol 'saved-value) + (get symbol 'standard-value) + (if (memq all '(nil options)) + (user-variable-p symbol) + (get symbol 'variable-documentation)))) + (push (list symbol 'custom-variable) found))))) + (if (not found) + (error "No matches") + (custom-buffer-create (custom-sort-items found t + custom-buffer-order-groups) + "*Customize Apropos*")))) + +;;;###autoload +(defun customize-apropos-options (regexp &optional arg) + "Customize all user options matching REGEXP. +With prefix arg, include options which are not user-settable." + (interactive "sCustomize regexp: \nP") + (customize-apropos regexp (or arg 'options))) + +;;;###autoload +(defun customize-apropos-faces (regexp) + "Customize all user faces matching REGEXP." + (interactive "sCustomize regexp: \n") + (customize-apropos regexp 'faces)) + +;;;###autoload +(defun customize-apropos-groups (regexp) + "Customize all user groups matching REGEXP." + (interactive "sCustomize regexp: \n") + (customize-apropos regexp 'groups)) + + +;;; Buffer. + +(defcustom custom-buffer-style 'links + "Control the presentation style for customization buffers. +The value should be a symbol, one of: + +brackets: groups nest within each other with big horizontal brackets. +links: groups have links to subgroups." + :type '(radio (const :tag "brackets: Groups nest within each others" brackets) + (const :tag "links: Group have links to subgroups" links)) + :group 'custom-buffer) + +(defcustom custom-buffer-indent 3 + "Number of spaces to indent nested groups." + :type 'integer + :group 'custom-buffer) + +;;;###autoload +(defun custom-buffer-create (options &optional name description) + "Create a buffer containing OPTIONS. +Optional NAME is the name of the buffer. +OPTIONS should be an alist of the form ((SYMBOL WIDGET)...), where +SYMBOL is a customization option, and WIDGET is a widget for editing +that option." + (unless name (setq name "*Customization*")) + (kill-buffer (get-buffer-create name)) + (switch-to-buffer (get-buffer-create name)) + (custom-buffer-create-internal options description)) + +;;;###autoload +(defun custom-buffer-create-other-window (options &optional name description) + "Create a buffer containing OPTIONS. +Optional NAME is the name of the buffer. +OPTIONS should be an alist of the form ((SYMBOL WIDGET)...), where +SYMBOL is a customization option, and WIDGET is a widget for editing +that option." + (unless name (setq name "*Customization*")) + (kill-buffer (get-buffer-create name)) + (let ((window (selected-window))) + (switch-to-buffer-other-window (get-buffer-create name)) + (custom-buffer-create-internal options description) + (select-window window))) + +(defcustom custom-reset-button-menu t + "If non-nil, only show a single reset button in customize buffers. +This button will have a menu with all three reset operations." + :type 'boolean + :group 'custom-buffer) + +(defconst custom-skip-messages 5) + +(defun custom-buffer-create-internal (options &optional description) + (message "Creating customization buffer...") + (custom-mode) + (widget-insert "This is a customization buffer") + (if description + (widget-insert description)) + (widget-insert ".\n\ +Type RET or click button2 on an active field to invoke its action. +Invoke ") + (widget-create 'info-link + :tag "Help" + :help-echo "Read the online help" + "(XEmacs)Easy Customization") + (widget-insert " for more information.\n\n") + (message "Creating customization buttons...") + (widget-insert "Operate on everything in this buffer:\n ") + (widget-create 'push-button + :tag "Set" + :tag-glyph '("set-up" "set-down") + :help-echo "\ +Make your editing in this buffer take effect for this session" + :action (lambda (widget &optional event) + (Custom-set))) + (widget-insert " ") + (widget-create 'push-button + :tag "Save" + :tag-glyph '("save-up" "save-down") + :help-echo "\ +Make your editing in this buffer take effect for future Emacs sessions" + :action (lambda (widget &optional event) + (Custom-save))) + (if custom-reset-button-menu + (progn + (widget-insert " ") + (widget-create 'push-button + :tag "Reset" + :tag-glyph '("reset-up" "reset-down") + :help-echo "Show a menu with reset operations" + :mouse-down-action (lambda (&rest junk) t) + :action (lambda (widget &optional event) + (custom-reset event)))) + (widget-insert " ") + (widget-create 'push-button + :tag "Reset" + :help-echo "\ +Reset all edited text in this buffer to reflect current values" + :action 'Custom-reset-current) + (widget-insert " ") + (widget-create 'push-button + :tag "Reset to Saved" + :help-echo "\ +Reset all values in this buffer to their saved settings" + :action 'Custom-reset-saved) + (widget-insert " ") + (widget-create 'push-button + :tag "Reset to Standard" + :help-echo "\ +Reset all values in this buffer to their standard settings" + :action 'Custom-reset-standard)) + (widget-insert " ") + (widget-create 'push-button + :tag "Done" + :tag-glyph '("done-up" "done-down") + :help-echo "Bury the buffer" + :action (lambda (widget &optional event) + (bury-buffer))) + (widget-insert "\n\n") + (message "Creating customization items...") + (setq custom-options + (if (= (length options) 1) + (mapcar (lambda (entry) + (widget-create (nth 1 entry) + :documentation-shown t + :custom-state 'unknown + :tag (custom-unlispify-tag-name + (nth 0 entry)) + :value (nth 0 entry))) + options) + (let ((count 0) + (length (length options))) + (mapcar (lambda (entry) + (prog2 + (display-message + 'progress + (format "Creating customization items %2d%%..." + (/ (* 100.0 count) length))) + (widget-create (nth 1 entry) + :tag (custom-unlispify-tag-name + (nth 0 entry)) + :value (nth 0 entry)) + (incf count) + (unless (eq (preceding-char) ?\n) + (widget-insert "\n")) + (widget-insert "\n"))) + options)))) + (unless (eq (preceding-char) ?\n) + (widget-insert "\n")) + (display-message 'progress + (format + "Creating customization items %2d%%...done" 100)) + (unless (eq custom-buffer-style 'tree) + (mapc 'custom-magic-reset custom-options)) + (message "Creating customization setup...") + (widget-setup) + (goto-char (point-min)) + (message "Creating customization buffer...done")) + + +;;; The Tree Browser. + +;;;###autoload +(defun customize-browse (&optional group) + "Create a tree browser for the customize hierarchy." + (interactive) + (unless group + (setq group 'emacs)) + (let ((name "*Customize Browser*")) + (kill-buffer (get-buffer-create name)) + (switch-to-buffer (get-buffer-create name))) + (custom-mode) + (widget-insert "\ +Square brackets show active fields; type RET or click button2 +on an active field to invoke its action. +Invoke [+] below to expand a group, and [-] to collapse an expanded group.\n") + (if custom-browse-only-groups + (widget-insert "\ +Invoke the [Group] button below to edit that item in another window.\n\n") + (widget-insert "Invoke the ") + (widget-create 'item + :format "%t" + :tag "[Group]" + :tag-glyph "folder") + (widget-insert ", ") + (widget-create 'item + :format "%t" + :tag "[Face]" + :tag-glyph "face") + (widget-insert ", and ") + (widget-create 'item + :format "%t" + :tag "[Option]" + :tag-glyph "option") + (widget-insert " buttons below to edit that +item in another window.\n\n")) + (let ((custom-buffer-style 'tree)) + (widget-create 'custom-group + :custom-last t + :custom-state 'unknown + :tag (custom-unlispify-tag-name group) + :value group)) + (goto-char (point-min))) + +(define-widget 'custom-browse-visibility 'item + "Control visibility of of items in the customize tree browser." + :format "%[[%t]%]" + :action 'custom-browse-visibility-action) + +(defun custom-browse-visibility-action (widget &rest ignore) + (let ((custom-buffer-style 'tree)) + (custom-toggle-parent widget))) + +(define-widget 'custom-browse-group-tag 'push-button + "Show parent in other window when activated." + :tag "Group" + :tag-glyph "folder" + :action 'custom-browse-group-tag-action) + +(defun custom-browse-group-tag-action (widget &rest ignore) + (let ((parent (widget-get widget :parent))) + (customize-group-other-window (widget-value parent)))) + +(define-widget 'custom-browse-variable-tag 'push-button + "Show parent in other window when activated." + :tag "Option" + :tag-glyph "option" + :action 'custom-browse-variable-tag-action) + +(defun custom-browse-variable-tag-action (widget &rest ignore) + (let ((parent (widget-get widget :parent))) + (customize-variable-other-window (widget-value parent)))) + +(define-widget 'custom-browse-face-tag 'push-button + "Show parent in other window when activated." + :tag "Face" + :tag-glyph "face" + :action 'custom-browse-face-tag-action) + +(defun custom-browse-face-tag-action (widget &rest ignore) + (let ((parent (widget-get widget :parent))) + (customize-face-other-window (widget-value parent)))) + +(defconst custom-browse-alist '((" " "space") + (" | " "vertical") + ("-\\ " "top") + (" |-" "middle") + (" `-" "bottom"))) + +(defun custom-browse-insert-prefix (prefix) + "Insert PREFIX. On XEmacs convert it to line graphics." + ;; ### Unfinished. + (if nil ; (string-match "XEmacs" emacs-version) + (progn + (insert "*") + (while (not (string-equal prefix "")) + (let ((entry (substring prefix 0 3))) + (setq prefix (substring prefix 3)) + (let ((overlay (make-overlay (1- (point)) (point) nil t nil)) + (name (nth 1 (assoc entry custom-browse-alist)))) + (overlay-put overlay 'end-glyph (widget-glyph-find name entry)) + (overlay-put overlay 'start-open t) + (overlay-put overlay 'end-open t))))) + (insert prefix))) + + +;;; Modification of Basic Widgets. +;; +;; We add extra properties to the basic widgets needed here. This is +;; fine, as long as we are careful to stay within out own namespace. +;; +;; We want simple widgets to be displayed by default, but complex +;; widgets to be hidden. + +(widget-put (get 'item 'widget-type) :custom-show t) +(widget-put (get 'editable-field 'widget-type) + :custom-show (lambda (widget value) + (let ((pp (pp-to-string value))) + (cond ((string-match "\n" pp) + nil) + ((> (length pp) 40) + nil) + (t t))))) +(widget-put (get 'menu-choice 'widget-type) :custom-show t) + +;;; The `custom-manual' Widget. + +(define-widget 'custom-manual 'info-link + "Link to the manual entry for this customization option." + :tag "Manual") + +;;; The `custom-magic' Widget. + +(defgroup custom-magic-faces nil + "Faces used by the magic button." + :group 'custom-faces + :group 'custom-buffer) + +(defface custom-invalid-face '((((class color)) + (:foreground "yellow" :background "red")) + (t + (:bold t :italic t :underline t))) + "Face used when the customize item is invalid." + :group 'custom-magic-faces) + +(defface custom-rogue-face '((((class color)) + (:foreground "pink" :background "black")) + (t + (:underline t))) + "Face used when the customize item is not defined for customization." + :group 'custom-magic-faces) + +(defface custom-modified-face '((((class color)) + (:foreground "white" :background "blue")) + (t + (:italic t :bold))) + "Face used when the customize item has been modified." + :group 'custom-magic-faces) + +(defface custom-set-face '((((class color)) + (:foreground "blue" :background "white")) + (t + (:italic t))) + "Face used when the customize item has been set." + :group 'custom-magic-faces) + +(defface custom-changed-face '((((class color)) + (:foreground "white" :background "blue")) + (t + (:italic t))) + "Face used when the customize item has been changed." + :group 'custom-magic-faces) + +(defface custom-saved-face '((t (:underline t))) + "Face used when the customize item has been saved." + :group 'custom-magic-faces) + +(defconst custom-magic-alist '((nil "#" underline "\ +uninitialized, you should not see this.") + (unknown "?" italic "\ +unknown, you should not see this.") + (hidden "-" default "\ +hidden, invoke \"Show\" button in the previous line to show." "\ +group now hidden, invoke the above \"Show\" button to show contents.") + (invalid "x" custom-invalid-face "\ +the value displayed for this %c is invalid and cannot be set.") + (modified "*" custom-modified-face "\ +you have edited the value as text, but you have not set the %c." "\ +you have edited something in this group, but not set it.") + (set "+" custom-set-face "\ +you have set this %c, but not saved it for future sessions." "\ +something in this group has been set, but not saved.") + (changed ":" custom-changed-face "\ +this %c has been changed outside the customize buffer." "\ +something in this group has been changed outside customize.") + (saved "!" custom-saved-face "\ +this %c has been set and saved." "\ +something in this group has been set and saved.") + (rogue "@" custom-rogue-face "\ +this %c has not been changed with customize." "\ +something in this group is not prepared for customization.") + (standard " " nil "\ +this %c is unchanged from its standard setting." "\ +visible group members are all at standard settings.")) + "Alist of customize option states. +Each entry is of the form (STATE MAGIC FACE ITEM-DESC [ GROUP-DESC ]), where + +STATE is one of the following symbols: + +`nil' + For internal use, should never occur. +`unknown' + For internal use, should never occur. +`hidden' + This item is not being displayed. +`invalid' + This item is modified, but has an invalid form. +`modified' + This item is modified, and has a valid form. +`set' + This item has been set but not saved. +`changed' + The current value of this item has been changed temporarily. +`saved' + This item is marked for saving. +`rogue' + This item has no customization information. +`standard' + This item is unchanged from the standard setting. + +MAGIC is a string used to present that state. + +FACE is a face used to present the state. + +ITEM-DESC is a string describing the state for options. + +GROUP-DESC is a string describing the state for groups. If this is +left out, ITEM-DESC will be used. + +The string %c in either description will be replaced with the +category of the item. These are `group'. `option', and `face'. + +The list should be sorted most significant first.") + +(defcustom custom-magic-show 'long + "If non-nil, show textual description of the state. +If `long', show a full-line description, not just one word." + :type '(choice (const :tag "no" nil) + (const short) + (const long)) + :group 'custom-buffer) + +(defcustom custom-magic-show-hidden '(option face) + "Control whether the State button is shown for hidden items. +The value should be a list with the custom categories where the State +button should be visible. Possible categories are `group', `option', +and `face'." + :type '(set (const group) (const option) (const face)) + :group 'custom-buffer) + +(defcustom custom-magic-show-button nil + "Show a \"magic\" button indicating the state of each customization option." + :type 'boolean + :group 'custom-buffer) + +(define-widget 'custom-magic 'default + "Show and manipulate state for a customization option." + :format "%v" + :action 'widget-parent-action + :notify 'ignore + :value-get 'ignore + :value-create 'custom-magic-value-create + :value-delete 'widget-children-value-delete) + +(defun widget-magic-mouse-down-action (widget &optional event) + ;; Non-nil unless hidden. + (not (eq (widget-get (widget-get (widget-get widget :parent) :parent) + :custom-state) + 'hidden))) + +(defun custom-magic-value-create (widget) + ;; Create compact status report for WIDGET. + (let* ((parent (widget-get widget :parent)) + (state (widget-get parent :custom-state)) + (hidden (eq state 'hidden)) + (entry (assq state custom-magic-alist)) + (magic (nth 1 entry)) + (face (nth 2 entry)) + (category (widget-get parent :custom-category)) + (text (or (and (eq category 'group) + (nth 4 entry)) + (nth 3 entry))) + (form (widget-get parent :custom-form)) + children) + (while (string-match "\\`\\(.*\\)%c\\(.*\\)\\'" text) + (setq text (concat (match-string 1 text) + (symbol-name category) + (match-string 2 text)))) + (when (and custom-magic-show + (or (not hidden) + (memq category custom-magic-show-hidden))) + (insert " ") + (when (and (eq category 'group) + (not (and (eq custom-buffer-style 'links) + (> (widget-get parent :custom-level) 1)))) + (insert-char ?\ (* custom-buffer-indent + (widget-get parent :custom-level)))) + (push (widget-create-child-and-convert + widget 'choice-item + :help-echo "Change the state of this item" + :format (if hidden "%t" "%[%t%]") + :button-prefix 'widget-push-button-prefix + :button-suffix 'widget-push-button-suffix + :mouse-down-action 'widget-magic-mouse-down-action + :tag "State" + ;;:tag-glyph (or hidden '("state-up" "state-down")) + ) + children) + (insert ": ") + (let ((start (point))) + (if (eq custom-magic-show 'long) + (insert text) + (insert (symbol-name state))) + (cond ((eq form 'lisp) + (insert " (lisp)")) + ((eq form 'mismatch) + (insert " (mismatch)"))) + (put-text-property start (point) 'face 'custom-state-face)) + (insert "\n")) + (when (and (eq category 'group) + (not (and (eq custom-buffer-style 'links) + (> (widget-get parent :custom-level) 1)))) + (insert-char ?\ (* custom-buffer-indent + (widget-get parent :custom-level)))) + (when custom-magic-show-button + (when custom-magic-show + (let ((indent (widget-get parent :indent))) + (when indent + (insert-char ?\ indent)))) + (push (widget-create-child-and-convert + widget 'choice-item + :mouse-down-action 'widget-magic-mouse-down-action + :button-face face + :button-prefix "" + :button-suffix "" + :help-echo "Change the state" + :format (if hidden "%t" "%[%t%]") + :tag (if (memq form '(lisp mismatch)) + (concat "(" magic ")") + (concat "[" magic "]"))) + children) + (insert " ")) + (widget-put widget :children children))) + +(defun custom-magic-reset (widget) + "Redraw the :custom-magic property of WIDGET." + (let ((magic (widget-get widget :custom-magic))) + (widget-value-set magic (widget-value magic)))) + +;;; The `custom' Widget. + +(defface custom-button-face '((t (:bold t))) + "Face used for buttons in customization buffers." + :group 'custom-faces) + +(defface custom-documentation-face nil + "Face used for documentation strings in customization buffers." + :group 'custom-faces) + +(defface custom-state-face '((((class color) + (background dark)) + (:foreground "lime green")) + (((class color) + (background light)) + (:foreground "dark green")) + (t nil)) + "Face used for State descriptions in the customize buffer." + :group 'custom-faces) + +(define-widget 'custom 'default + "Customize a user option." + :format "%v" + :convert-widget 'custom-convert-widget + :notify 'custom-notify + :custom-prefix "" + :custom-level 1 + :custom-state 'hidden + :documentation-property 'widget-subclass-responsibility + :value-create 'widget-subclass-responsibility + :value-delete 'widget-children-value-delete + :value-get 'widget-value-value-get + :validate 'widget-children-validate + :match (lambda (widget value) (symbolp value))) + +(defun custom-convert-widget (widget) + ;; Initialize :value and :tag from :args in WIDGET. + (let ((args (widget-get widget :args))) + (when args + (widget-put widget :value (widget-apply widget + :value-to-internal (car args))) + (widget-put widget :tag (custom-unlispify-tag-name (car args))) + (widget-put widget :args nil))) + widget) + +(defun custom-notify (widget &rest args) + "Keep track of changes." + (let ((state (widget-get widget :custom-state))) + (unless (eq state 'modified) + (unless (memq state '(nil unknown hidden)) + (widget-put widget :custom-state 'modified)) + (custom-magic-reset widget) + (apply 'widget-default-notify widget args)))) + +(defun custom-redraw (widget) + "Redraw WIDGET with current settings." + (let ((line (count-lines (point-min) (point))) + (column (current-column)) + (pos (point)) + (from (marker-position (widget-get widget :from))) + (to (marker-position (widget-get widget :to)))) + (save-excursion + (widget-value-set widget (widget-value widget)) + (custom-redraw-magic widget)) + (when (and (>= pos from) (<= pos to)) + (condition-case nil + (progn + (if (> column 0) + (goto-line line) + (goto-line (1+ line))) + (move-to-column column)) + (error nil))))) + +(defun custom-redraw-magic (widget) + "Redraw WIDGET state with current settings." + (while widget + (let ((magic (widget-get widget :custom-magic))) + (cond (magic + (widget-value-set magic (widget-value magic)) + (when (setq widget (widget-get widget :group)) + (custom-group-state-update widget))) + (t + (setq widget nil))))) + (widget-setup)) + +(defun custom-show (widget value) + "Non-nil if WIDGET should be shown with VALUE by default." + (let ((show (widget-get widget :custom-show))) + (cond ((null show) + nil) + ((eq t show) + t) + (t + (funcall show widget value))))) + +(defvar custom-load-recursion nil + "Hack to avoid recursive dependencies.") + +(defun custom-load-symbol (symbol) + "Load all dependencies for SYMBOL." + (unless custom-load-recursion + (let ((custom-load-recursion t) + (loads (get symbol 'custom-loads)) + load) + (while loads + (setq load (car loads) + loads (cdr loads)) + (cond ((symbolp load) + (condition-case nil + (require load) + (error nil))) + ;; Don't reload a file already loaded. + ((and (boundp 'preloaded-file-list) + (member load preloaded-file-list))) + ((assoc load load-history)) + ((assoc (locate-library load) load-history)) + (t + (condition-case nil + ;; Without this, we would load cus-edit recursively. + ;; We are still loading it when we call this, + ;; and it is not in load-history yet. + (or (equal load "cus-edit") + (load-library load)) + (error nil)))))))) + +(defun custom-load-widget (widget) + "Load all dependencies for WIDGET." + (custom-load-symbol (widget-value widget))) + +(defun custom-unloaded-symbol-p (symbol) + "Return non-nil if the dependencies of SYMBOL has not yet been loaded." + (let ((found nil) + (loads (get symbol 'custom-loads)) + load) + (while loads + (setq load (car loads) + loads (cdr loads)) + (cond ((symbolp load) + (unless (featurep load) + (setq found t))) + ((assoc load load-history)) + ((assoc (locate-library load) load-history) + ;; #### WTF??? + (message nil)) + (t + (setq found t)))) + found)) + +(defun custom-unloaded-widget-p (widget) + "Return non-nil if the dependencies of WIDGET has not yet been loaded." + (custom-unloaded-symbol-p (widget-value widget))) + +(defun custom-toggle-hide (widget) + "Toggle visibility of WIDGET." + (custom-load-widget widget) + (let ((state (widget-get widget :custom-state))) + (cond ((memq state '(invalid modified)) + (error "There are unset changes")) + ((eq state 'hidden) + (widget-put widget :custom-state 'unknown)) + (t + (widget-put widget :documentation-shown nil) + (widget-put widget :custom-state 'hidden))) + (custom-redraw widget) + (widget-setup))) + +(defun custom-toggle-parent (widget &rest ignore) + "Toggle visibility of parent of WIDGET." + (custom-toggle-hide (widget-get widget :parent))) + +(defun custom-add-see-also (widget &optional prefix) + "Add `See also ...' to WIDGET if there are any links. +Insert PREFIX first if non-nil." + (let* ((symbol (widget-get widget :value)) + (links (get symbol 'custom-links)) + (many (> (length links) 2)) + (buttons (widget-get widget :buttons)) + (indent (widget-get widget :indent))) + (when links + (when indent + (insert-char ?\ indent)) + (when prefix + (insert prefix)) + (insert "See also ") + (while links + (push (widget-create-child-and-convert widget (car links)) + buttons) + (setq links (cdr links)) + (cond ((null links) + (insert ".\n")) + ((null (cdr links)) + (if many + (insert ", and ") + (insert " and "))) + (t + (insert ", ")))) + (widget-put widget :buttons buttons)))) + +(defun custom-add-parent-links (widget &optional initial-string) + "Add \"Parent groups: ...\" to WIDGET if the group has parents. +The value if non-nil if any parents were found. +If INITIAL-STRING is non-nil, use that rather than \"Parent groups:\"." + (let ((name (widget-value widget)) + (type (widget-type widget)) + (buttons (widget-get widget :buttons)) + (start (point)) + found) + (insert (or initial-string "Parent groups:")) + (maphash (lambda (group ignore) + (let ((entry (assq name (get group 'custom-group)))) + (when (eq (nth 1 entry) type) + (insert " ") + (push (widget-create-child-and-convert + widget 'custom-group-link + :tag (custom-unlispify-tag-name group) + group) + buttons) + (setq found t)))) + custom-group-hash-table) + (widget-put widget :buttons buttons) + (if found + (insert "\n") + (delete-region start (point))) + found)) + +;;; The `custom-variable' Widget. + +(defface custom-variable-tag-face '((((class color) + (background dark)) + (:foreground "light blue" :underline t)) + (((class color) + (background light)) + (:foreground "blue" :underline t)) + (t (:underline t))) + "Face used for unpushable variable tags." + :group 'custom-faces) + +(defface custom-variable-button-face '((t (:underline t :bold t))) + "Face used for pushable variable tags." + :group 'custom-faces) + +(define-widget 'custom-variable 'custom + "Customize variable." + :format "%v" + :help-echo "Set or reset this variable" + :documentation-property 'variable-documentation + :custom-category 'option + :custom-state nil + :custom-menu 'custom-variable-menu-create + :custom-form 'edit + :value-create 'custom-variable-value-create + :action 'custom-variable-action + :custom-set 'custom-variable-set + :custom-save 'custom-variable-save + :custom-reset-current 'custom-redraw + :custom-reset-saved 'custom-variable-reset-saved + :custom-reset-standard 'custom-variable-reset-standard) + +(defun custom-variable-type (symbol) + "Return a widget suitable for editing the value of SYMBOL. +If SYMBOL has a `custom-type' property, use that. +Otherwise, look up symbol in `custom-guess-type-alist'." + (let* ((type (or (get symbol 'custom-type) + (and (not (get symbol 'standard-value)) + (custom-guess-type symbol)) + 'sexp)) + (options (get symbol 'custom-options)) + (tmp (if (listp type) + (copy-sequence type) + (list type)))) + (when options + (widget-put tmp :options options)) + tmp)) + +(defun custom-variable-value-create (widget) + "Here is where you edit the variables value." + (custom-load-widget widget) + (let* ((buttons (widget-get widget :buttons)) + (children (widget-get widget :children)) + (form (widget-get widget :custom-form)) + (state (widget-get widget :custom-state)) + (symbol (widget-get widget :value)) + (tag (widget-get widget :tag)) + (type (custom-variable-type symbol)) + (conv (widget-convert type)) + (get (or (get symbol 'custom-get) 'default-value)) + (prefix (widget-get widget :custom-prefix)) + (last (widget-get widget :custom-last)) + (value (if (default-boundp symbol) + (funcall get symbol) + (widget-get conv :value)))) + ;; If the widget is new, the child determine whether it is hidden. + (cond (state) + ((custom-show type value) + (setq state 'unknown)) + (t + (setq state 'hidden))) + ;; If we don't know the state, see if we need to edit it in lisp form. + (when (eq state 'unknown) + (unless (widget-apply conv :match value) + ;; (widget-apply (widget-convert type) :match value) + (setq form 'mismatch))) + ;; Now we can create the child widget. + (cond ((eq custom-buffer-style 'tree) + (insert prefix (if last " `--- " " |--- ")) + (push (widget-create-child-and-convert + widget 'custom-browse-variable-tag) + buttons) + (insert " " tag "\n") + (widget-put widget :buttons buttons)) + ((eq state 'hidden) + ;; Indicate hidden value. + (push (widget-create-child-and-convert + widget 'item + :format "%{%t%}: " + :sample-face 'custom-variable-tag-face + :tag tag + :parent widget) + buttons) + (push (widget-create-child-and-convert + widget 'visibility + :help-echo "Show the value of this option" + :action 'custom-toggle-parent + nil) + buttons)) + ((memq form '(lisp mismatch)) + ;; In lisp mode edit the saved value when possible. + (let* ((value (cond ((get symbol 'saved-value) + (car (get symbol 'saved-value))) + ((get symbol 'standard-value) + (car (get symbol 'standard-value))) + ((default-boundp symbol) + (custom-quote (funcall get symbol))) + (t + (custom-quote (widget-get conv :value)))))) + (insert (symbol-name symbol) ": ") + (push (widget-create-child-and-convert + widget 'visibility + :help-echo "Hide the value of this option" + :action 'custom-toggle-parent + t) + buttons) + (insert " ") + (push (widget-create-child-and-convert + widget 'sexp + :button-face 'custom-variable-button-face + :format "%v" + :tag (symbol-name symbol) + :parent widget + :value value) + children))) + (t + ;; Edit mode. + (let* ((format (widget-get type :format)) + tag-format value-format) + (unless (string-match ":" format) + (error "Bad format.")) + (setq tag-format (substring format 0 (match-end 0))) + (setq value-format (substring format (match-end 0))) + (push (widget-create-child-and-convert + widget 'item + :format tag-format + :action 'custom-tag-action + :help-echo "Change value of this option" + :mouse-down-action 'custom-tag-mouse-down-action + :button-face 'custom-variable-button-face + :sample-face 'custom-variable-tag-face + tag) + buttons) + (insert " ") + (push (widget-create-child-and-convert + widget 'visibility + :help-echo "Hide the value of this option" + :action 'custom-toggle-parent + t) + buttons) + (push (widget-create-child-and-convert + widget type + :format value-format + :value value) + children)))) + (unless (eq custom-buffer-style 'tree) + ;; Now update the state. + (unless (eq (preceding-char) ?\n) + (widget-insert "\n")) + (if (eq state 'hidden) + (widget-put widget :custom-state state) + (custom-variable-state-set widget)) + ;; Create the magic button. + (let ((magic (widget-create-child-and-convert + widget 'custom-magic nil))) + (widget-put widget :custom-magic magic) + (push magic buttons)) + ;; Update properties. + (widget-put widget :custom-form form) + (widget-put widget :buttons buttons) + (widget-put widget :children children) + ;; Insert documentation. + (widget-default-format-handler widget ?h) + ;; See also. + (unless (eq state 'hidden) + (when (eq (widget-get widget :custom-level) 1) + (custom-add-parent-links widget)) + (custom-add-see-also widget))))) + +(defun custom-tag-action (widget &rest args) + "Pass :action to first child of WIDGET's parent." + (apply 'widget-apply (car (widget-get (widget-get widget :parent) :children)) + :action args)) + +(defun custom-tag-mouse-down-action (widget &rest args) + "Pass :mouse-down-action to first child of WIDGET's parent." + (apply 'widget-apply (car (widget-get (widget-get widget :parent) :children)) + :mouse-down-action args)) + +(defun custom-variable-state-set (widget) + "Set the state of WIDGET." + (let* ((symbol (widget-value widget)) + (get (or (get symbol 'custom-get) 'default-value)) + (value (if (default-boundp symbol) + (funcall get symbol) + (widget-get widget :value))) + tmp + (state (cond ((setq tmp (get symbol 'customized-value)) + (if (condition-case nil + (equal value (eval (car tmp))) + (error nil)) + 'set + 'changed)) + ((setq tmp (get symbol 'saved-value)) + (if (condition-case nil + (equal value (eval (car tmp))) + (error nil)) + 'saved + 'changed)) + ((setq tmp (get symbol 'standard-value)) + (if (condition-case nil + (equal value (eval (car tmp))) + (error nil)) + 'standard + 'changed)) + (t 'rogue)))) + (widget-put widget :custom-state state))) + +(defvar custom-variable-menu + '(("Set for Current Session" custom-variable-set + (lambda (widget) + (eq (widget-get widget :custom-state) 'modified))) + ("Save for Future Sessions" custom-variable-save + (lambda (widget) + (memq (widget-get widget :custom-state) '(modified set changed rogue)))) + ("Reset to Current" custom-redraw + (lambda (widget) + (and (default-boundp (widget-value widget)) + (memq (widget-get widget :custom-state) '(modified changed))))) + ("Reset to Saved" custom-variable-reset-saved + (lambda (widget) + (and (get (widget-value widget) 'saved-value) + (memq (widget-get widget :custom-state) + '(modified set changed rogue))))) + ("Reset to Standard Settings" custom-variable-reset-standard + (lambda (widget) + (and (get (widget-value widget) 'standard-value) + (memq (widget-get widget :custom-state) + '(modified set changed saved rogue))))) + ("---" ignore ignore) + ("Don't show as Lisp expression" custom-variable-edit + (lambda (widget) + (eq (widget-get widget :custom-form) 'lisp))) + ("Show as Lisp expression" custom-variable-edit-lisp + (lambda (widget) + (eq (widget-get widget :custom-form) 'edit)))) + "Alist of actions for the `custom-variable' widget. +Each entry has the form (NAME ACTION FILTER) where NAME is the name of +the menu entry, ACTION is the function to call on the widget when the +menu is selected, and FILTER is a predicate which takes a `custom-variable' +widget as an argument, and returns non-nil if ACTION is valid on that +widget. If FILTER is nil, ACTION is always valid.") + +(defun custom-variable-action (widget &optional event) + "Show the menu for `custom-variable' WIDGET. +Optional EVENT is the location for the menu." + (if (eq (widget-get widget :custom-state) 'hidden) + (custom-toggle-hide widget) + (unless (eq (widget-get widget :custom-state) 'modified) + (custom-variable-state-set widget)) + ;; Redrawing magic also depresses the state glyph. + ;(custom-redraw-magic widget) + (let* ((completion-ignore-case t) + (answer (widget-choose (concat "Operation on " + (custom-unlispify-tag-name + (widget-get widget :value))) + (custom-menu-filter custom-variable-menu + widget) + event))) + (if answer + (funcall answer widget))))) + +(defun custom-variable-edit (widget) + "Edit value of WIDGET." + (widget-put widget :custom-state 'unknown) + (widget-put widget :custom-form 'edit) + (custom-redraw widget)) + +(defun custom-variable-edit-lisp (widget) + "Edit the lisp representation of the value of WIDGET." + (widget-put widget :custom-state 'unknown) + (widget-put widget :custom-form 'lisp) + (custom-redraw widget)) + +(defun custom-variable-set (widget) + "Set the current value for the variable being edited by WIDGET." + (let* ((form (widget-get widget :custom-form)) + (state (widget-get widget :custom-state)) + (child (car (widget-get widget :children))) + (symbol (widget-value widget)) + (set (or (get symbol 'custom-set) 'set-default)) + val) + (cond ((eq state 'hidden) + (error "Cannot set hidden variable.")) + ((setq val (widget-apply child :validate)) + (goto-char (widget-get val :from)) + (error "%s" (widget-get val :error))) + ((memq form '(lisp mismatch)) + (funcall set symbol (eval (setq val (widget-value child)))) + (put symbol 'customized-value (list val))) + (t + (funcall set symbol (setq val (widget-value child))) + (put symbol 'customized-value (list (custom-quote val))))) + (custom-variable-state-set widget) + (custom-redraw-magic widget))) + +(defun custom-variable-save (widget) + "Set and save the value for the variable being edited by WIDGET." + (let* ((form (widget-get widget :custom-form)) + (state (widget-get widget :custom-state)) + (child (car (widget-get widget :children))) + (symbol (widget-value widget)) + (set (or (get symbol 'custom-set) 'set-default)) + val) + (cond ((eq state 'hidden) + (error "Cannot set hidden variable.")) + ((setq val (widget-apply child :validate)) + (goto-char (widget-get val :from)) + (error "%s" (widget-get val :error))) + ((memq form '(lisp mismatch)) + (put symbol 'saved-value (list (widget-value child))) + (funcall set symbol (eval (widget-value child)))) + (t + (put symbol + 'saved-value (list (custom-quote (widget-value + child)))) + (funcall set symbol (widget-value child)))) + (put symbol 'customized-value nil) + (custom-save-all) + (custom-variable-state-set widget) + (custom-redraw-magic widget))) + +(defun custom-variable-reset-saved (widget) + "Restore the saved value for the variable being edited by WIDGET." + (let* ((symbol (widget-value widget)) + (set (or (get symbol 'custom-set) 'set-default))) + (if (get symbol 'saved-value) + (condition-case nil + (funcall set symbol (eval (car (get symbol 'saved-value)))) + (error nil)) + (error "No saved value for %s" symbol)) + (put symbol 'customized-value nil) + (widget-put widget :custom-state 'unknown) + (custom-redraw widget))) + +(defun custom-variable-reset-standard (widget) + "Restore the standard setting for the variable being edited by WIDGET." + (let* ((symbol (widget-value widget)) + (set (or (get symbol 'custom-set) 'set-default))) + (if (get symbol 'standard-value) + (funcall set symbol (eval (car (get symbol 'standard-value)))) + (error "No standard setting known for %S" symbol)) + (put symbol 'customized-value nil) + (when (get symbol 'saved-value) + (put symbol 'saved-value nil) + (custom-save-all)) + (widget-put widget :custom-state 'unknown) + (custom-redraw widget))) + +;;; The `custom-face-edit' Widget. + +(define-widget 'custom-face-edit 'checklist + "Edit face attributes." + :format "%t: %v" + :tag "Attributes" + :extra-offset 12 + :button-args '(:help-echo "Control whether this attribute have any effect") + :args (mapcar (lambda (att) + (list 'group + :inline t + :sibling-args (widget-get (nth 1 att) :sibling-args) + (list 'const :format "" :value (nth 0 att)) + (nth 1 att))) + custom-face-attributes)) + +;;; The `custom-display' Widget. + +(define-widget 'custom-display 'menu-choice + "Select a display type." + :tag "Display" + :value t + :help-echo "Specify frames where the face attributes should be used" + :args '((const :tag "all" t) + (checklist + :offset 0 + :extra-offset 9 + :args ((group :sibling-args (:help-echo "\ +Only match the specified window systems") + (const :format "Type: " + type) + (checklist :inline t + :offset 0 + (const :format "X " + :sibling-args (:help-echo "\ +The X11 Window System") + x) + (const :format "PM " + :sibling-args (:help-echo "\ +OS/2 Presentation Manager") + pm) + (const :format "Win32 " + :sibling-args (:help-echo "\ +Windows NT/95/97") + win32) + (const :format "DOS " + :sibling-args (:help-echo "\ +Plain MS-DOS") + pc) + (const :format "TTY%n" + :sibling-args (:help-echo "\ +Plain text terminals") + tty))) + (group :sibling-args (:help-echo "\ +Only match the frames with the specified color support") + (const :format "Class: " + class) + (checklist :inline t + :offset 0 + (const :format "Color " + :sibling-args (:help-echo "\ +Match color frames") + color) + (const :format "Grayscale " + :sibling-args (:help-echo "\ +Match grayscale frames") + grayscale) + (const :format "Monochrome%n" + :sibling-args (:help-echo "\ +Match frames with no color support") + mono))) + (group :sibling-args (:help-echo "\ +Only match frames with the specified intensity") + (const :format "\ +Background brightness: " + background) + (checklist :inline t + :offset 0 + (const :format "Light " + :sibling-args (:help-echo "\ +Match frames with light backgrounds") + light) + (const :format "Dark\n" + :sibling-args (:help-echo "\ +Match frames with dark backgrounds") + dark))))))) + +;;; The `custom-face' Widget. + +(defface custom-face-tag-face '((t (:underline t))) + "Face used for face tags." + :group 'custom-faces) + +(define-widget 'custom-face 'custom + "Customize face." + :sample-face 'custom-face-tag-face + :help-echo "Set or reset this face" + :documentation-property '(lambda (face) + (face-doc-string face)) + :value-create 'custom-face-value-create + :action 'custom-face-action + :custom-category 'face + :custom-form 'selected + :custom-set 'custom-face-set + :custom-save 'custom-face-save + :custom-reset-current 'custom-redraw + :custom-reset-saved 'custom-face-reset-saved + :custom-reset-standard 'custom-face-reset-standard + :custom-menu 'custom-face-menu-create) + +(define-widget 'custom-face-all 'editable-list + "An editable list of display specifications and attributes." + :entry-format "%i %d %v" + :insert-button-args '(:help-echo "Insert new display specification here") + :append-button-args '(:help-echo "Append new display specification here") + :delete-button-args '(:help-echo "Delete this display specification") + :args '((group :format "%v" custom-display custom-face-edit))) + +(defconst custom-face-all (widget-convert 'custom-face-all) + "Converted version of the `custom-face-all' widget.") + +(define-widget 'custom-display-unselected 'item + "A display specification that doesn't match the selected display." + :match 'custom-display-unselected-match) + +(defun custom-display-unselected-match (widget value) + "Non-nil if VALUE is an unselected display specification." + (not (face-spec-set-match-display value (selected-frame)))) + +(define-widget 'custom-face-selected 'group + "Edit the attributes of the selected display in a face specification." + :args '((repeat :format "" + :inline t + (group custom-display-unselected sexp)) + (group (sexp :format "") custom-face-edit) + (repeat :format "" + :inline t + sexp))) + +(defconst custom-face-selected (widget-convert 'custom-face-selected) + "Converted version of the `custom-face-selected' widget.") + +(defun custom-face-value-create (widget) + "Create a list of the display specifications for WIDGET." + (let ((buttons (widget-get widget :buttons)) + (symbol (widget-get widget :value)) + (tag (widget-get widget :tag)) + (state (widget-get widget :custom-state)) + (begin (point)) + (is-last (widget-get widget :custom-last)) + (prefix (widget-get widget :custom-prefix))) + (unless tag + (setq tag (prin1-to-string symbol))) + (cond ((eq custom-buffer-style 'tree) + (insert prefix (if is-last " `--- " " |--- ")) + (push (widget-create-child-and-convert + widget 'custom-browse-face-tag) + buttons) + (insert " " tag "\n") + (widget-put widget :buttons buttons)) + (t + ;; Create tag. + (insert tag) + (if (eq custom-buffer-style 'face) + (insert " ") + (widget-specify-sample widget begin (point)) + (insert ": ")) + ;; Sample. + (and (not (find-face symbol)) + ;; XEmacs cannot display uninitialized faces. + (make-face symbol)) + (push (widget-create-child-and-convert widget 'item + :format "(%{%t%})" + :sample-face symbol + :tag "sample") + buttons) + ;; Visibility. + (insert " ") + (push (widget-create-child-and-convert + widget 'visibility + :help-echo "Hide or show this face" + :action 'custom-toggle-parent + (not (eq state 'hidden))) + buttons) + ;; Magic. + (insert "\n") + (let ((magic (widget-create-child-and-convert + widget 'custom-magic nil))) + (widget-put widget :custom-magic magic) + (push magic buttons)) + ;; Update buttons. + (widget-put widget :buttons buttons) + ;; Insert documentation. + (widget-default-format-handler widget ?h) + ;; See also. + (unless (eq state 'hidden) + (when (eq (widget-get widget :custom-level) 1) + (custom-add-parent-links widget)) + (custom-add-see-also widget)) + ;; Editor. + (unless (eq (preceding-char) ?\n) + (insert "\n")) + (unless (eq state 'hidden) + (message "Creating face editor...") + (custom-load-widget widget) + (let* ((symbol (widget-value widget)) + (spec (or (get symbol 'saved-face) + (get symbol 'face-defface-spec) + ;; Attempt to construct it. + (list (list t (face-custom-attributes-get + symbol (selected-frame)))))) + (form (widget-get widget :custom-form)) + (indent (widget-get widget :indent)) + (edit (widget-create-child-and-convert + widget + (cond ((and (eq form 'selected) + (widget-apply custom-face-selected + :match spec)) + (when indent (insert-char ?\ indent)) + 'custom-face-selected) + ((and (not (eq form 'lisp)) + (widget-apply custom-face-all + :match spec)) + 'custom-face-all) + (t + (when indent (insert-char ?\ indent)) + 'sexp)) + :value spec))) + (custom-face-state-set widget) + (widget-put widget :children (list edit))) + (message "Creating face editor...done")))))) + +(defvar custom-face-menu + '(("Set for Current Session" custom-face-set) + ("Save for Future Sessions" custom-face-save) + ("Reset to Saved" custom-face-reset-saved + (lambda (widget) + (get (widget-value widget) 'saved-face))) + ("Reset to Standard Setting" custom-face-reset-standard + (lambda (widget) + (get (widget-value widget) 'face-defface-spec))) + ("---" ignore ignore) + ("Show all display specs" custom-face-edit-all + (lambda (widget) + (not (eq (widget-get widget :custom-form) 'all)))) + ("Just current attributes" custom-face-edit-selected + (lambda (widget) + (not (eq (widget-get widget :custom-form) 'selected)))) + ("Show as Lisp expression" custom-face-edit-lisp + (lambda (widget) + (not (eq (widget-get widget :custom-form) 'lisp))))) + "Alist of actions for the `custom-face' widget. +Each entry has the form (NAME ACTION FILTER) where NAME is the name of +the menu entry, ACTION is the function to call on the widget when the +menu is selected, and FILTER is a predicate which takes a `custom-face' +widget as an argument, and returns non-nil if ACTION is valid on that +widget. If FILTER is nil, ACTION is always valid.") + +(defun custom-face-edit-selected (widget) + "Edit selected attributes of the value of WIDGET." + (widget-put widget :custom-state 'unknown) + (widget-put widget :custom-form 'selected) + (custom-redraw widget)) + +(defun custom-face-edit-all (widget) + "Edit all attributes of the value of WIDGET." + (widget-put widget :custom-state 'unknown) + (widget-put widget :custom-form 'all) + (custom-redraw widget)) + +(defun custom-face-edit-lisp (widget) + "Edit the lisp representation of the value of WIDGET." + (widget-put widget :custom-state 'unknown) + (widget-put widget :custom-form 'lisp) + (custom-redraw widget)) + +(defun custom-face-state-set (widget) + "Set the state of WIDGET." + (let ((symbol (widget-value widget))) + (widget-put widget :custom-state (cond ((get symbol 'customized-face) + 'set) + ((get symbol 'saved-face) + 'saved) + ((get symbol 'face-defface-spec) + 'standard) + (t + 'rogue))))) + +(defun custom-face-action (widget &optional event) + "Show the menu for `custom-face' WIDGET. +Optional EVENT is the location for the menu." + (if (eq (widget-get widget :custom-state) 'hidden) + (custom-toggle-hide widget) + (let* ((completion-ignore-case t) + (symbol (widget-get widget :value)) + (answer (widget-choose (concat "Operation on " + (custom-unlispify-tag-name symbol)) + (custom-menu-filter custom-face-menu + widget) + event))) + (if answer + (funcall answer widget))))) + +(defun custom-face-set (widget) + "Make the face attributes in WIDGET take effect." + (let* ((symbol (widget-value widget)) + (child (car (widget-get widget :children))) + (value (widget-value child))) + (put symbol 'customized-face value) + (face-spec-set symbol value) + (custom-face-state-set widget) + (custom-redraw-magic widget))) + +(defun custom-face-save (widget) + "Make the face attributes in WIDGET default." + (let* ((symbol (widget-value widget)) + (child (car (widget-get widget :children))) + (value (widget-value child))) + (face-spec-set symbol value) + (put symbol 'saved-face value) + (put symbol 'customized-face nil) + (custom-face-state-set widget) + (custom-redraw-magic widget))) + +(defun custom-face-reset-saved (widget) + "Restore WIDGET to the face's default attributes." + (let* ((symbol (widget-value widget)) + (child (car (widget-get widget :children))) + (value (get symbol 'saved-face))) + (unless value + (error "No saved value for this face")) + (put symbol 'customized-face nil) + (face-spec-set symbol value) + (widget-value-set child value) + (custom-face-state-set widget) + (custom-redraw-magic widget))) + +(defun custom-face-reset-standard (widget) + "Restore WIDGET to the face's standard settings." + (let* ((symbol (widget-value widget)) + (child (car (widget-get widget :children))) + (value (get symbol 'face-defface-spec))) + (unless value + (error "No standard setting for this face")) + (put symbol 'customized-face nil) + (when (get symbol 'saved-face) + (put symbol 'saved-face nil) + (custom-save-all)) + (face-spec-set symbol value) + (widget-value-set child value) + (custom-face-state-set widget) + (custom-redraw-magic widget))) + +;;; The `face' Widget. + +(define-widget 'face 'default + "Select and customize a face." + :convert-widget 'widget-value-convert-widget + :button-prefix 'widget-push-button-prefix + :button-suffix 'widget-push-button-suffix + :format "%t: %[select face%] %v" + :tag "Face" + :value 'default + :value-create 'widget-face-value-create + :value-delete 'widget-face-value-delete + :value-get 'widget-value-value-get + :validate 'widget-children-validate + :action 'widget-face-action + :match (lambda (widget value) (symbolp value))) + +(defun widget-face-value-create (widget) + ;; Create a `custom-face' child. + (let* ((symbol (widget-value widget)) + (custom-buffer-style 'face) + (child (widget-create-child-and-convert + widget 'custom-face + :custom-level nil + :value symbol))) + (custom-magic-reset child) + (setq custom-options (cons child custom-options)) + (widget-put widget :children (list child)))) + +(defun widget-face-value-delete (widget) + ;; Remove the child from the options. + (let ((child (car (widget-get widget :children)))) + (setq custom-options (delq child custom-options)) + (widget-children-value-delete widget))) + +(defvar face-history nil + "History of entered face names.") + +(defun widget-face-action (widget &optional event) + "Prompt for a face." + (let ((answer (completing-read "Face: " + (mapcar (lambda (face) + (list (symbol-name face))) + (face-list)) + nil nil nil + 'face-history))) + (unless (zerop (length answer)) + (widget-value-set widget (intern answer)) + (widget-apply widget :notify widget event) + (widget-setup)))) + +;;; The `hook' Widget. + +(define-widget 'hook 'list + "A emacs lisp hook" + :value-to-internal (lambda (widget value) + (if (symbolp value) + (list value) + value)) + :match (lambda (widget value) + (or (symbolp value) + (widget-group-match widget value))) + :convert-widget 'custom-hook-convert-widget + :tag "Hook") + +(defun custom-hook-convert-widget (widget) + ;; Handle `:custom-options'. + (let* ((options (widget-get widget :options)) + (other `(editable-list :inline t + :entry-format "%i %d%v" + (function :format " %v"))) + (args (if options + (list `(checklist :inline t + ,@(mapcar (lambda (entry) + `(function-item ,entry)) + options)) + other) + (list other)))) + (widget-put widget :args args) + widget)) + +;;; The `custom-group-link' Widget. + +(define-widget 'custom-group-link 'link + "Show parent in other window when activated." + :help-echo 'custom-group-link-help-echo + :action 'custom-group-link-action) + +(defun custom-group-link-help-echo (widget) + (concat "Create customization buffer for the `" + (custom-unlispify-tag-name (widget-value widget)) + "' group")) + +(defun custom-group-link-action (widget &rest ignore) + (customize-group (widget-value widget))) + +;;; The `custom-group' Widget. + +(defcustom custom-group-tag-faces nil + ;; In XEmacs, this ought to play games with font size. + "Face used for group tags. +The first member is used for level 1 groups, the second for level 2, +and so forth. The remaining group tags are shown with +`custom-group-tag-face'." + :type '(repeat face) + :group 'custom-faces) + +(defface custom-group-tag-face-1 '((((class color) + (background dark)) + (:foreground "pink" :underline t)) + (((class color) + (background light)) + (:foreground "red" :underline t)) + (t (:underline t))) + "Face used for group tags.") + +(defface custom-group-tag-face '((((class color) + (background dark)) + (:foreground "light blue" :underline t)) + (((class color) + (background light)) + (:foreground "blue" :underline t)) + (t (:underline t))) + "Face used for low level group tags." + :group 'custom-faces) + +(define-widget 'custom-group 'custom + "Customize group." + :format "%v" + :sample-face-get 'custom-group-sample-face-get + :documentation-property 'group-documentation + :help-echo "Set or reset all members of this group" + :value-create 'custom-group-value-create + :action 'custom-group-action + :custom-category 'group + :custom-set 'custom-group-set + :custom-save 'custom-group-save + :custom-reset-current 'custom-group-reset-current + :custom-reset-saved 'custom-group-reset-saved + :custom-reset-standard 'custom-group-reset-standard + :custom-menu 'custom-group-menu-create) + +(defun custom-group-sample-face-get (widget) + ;; Use :sample-face. + (or (nth (1- (widget-get widget :custom-level)) custom-group-tag-faces) + 'custom-group-tag-face)) + +(define-widget 'custom-group-visibility 'visibility + "An indicator and manipulator for hidden group contents." + :create 'custom-group-visibility-create) + +(defun custom-group-visibility-create (widget) + (let ((visible (widget-value widget))) + (if visible + (insert "--------"))) + (widget-default-create widget)) + +(defun custom-group-members (symbol groups-only) + "Return SYMBOL's custom group members. +If GROUPS-ONLY non-nil, return only those members that are groups." + (if (not groups-only) + (get symbol 'custom-group) + (let (members) + (dolist (entry (get symbol 'custom-group) (nreverse members)) + (when (eq (nth 1 entry) 'custom-group) + (push entry members)))))) + +(defun custom-group-value-create (widget) + "Insert a customize group for WIDGET in the current buffer." + (let* ((state (widget-get widget :custom-state)) + (level (widget-get widget :custom-level)) + ;; (indent (widget-get widget :indent)) + (prefix (widget-get widget :custom-prefix)) + (buttons (widget-get widget :buttons)) + (tag (widget-get widget :tag)) + (symbol (widget-value widget)) + (members (custom-group-members symbol + (and (eq custom-buffer-style 'tree) + custom-browse-only-groups)))) + (cond ((and (eq custom-buffer-style 'tree) + (eq state 'hidden) + (or members (custom-unloaded-widget-p widget))) + (custom-browse-insert-prefix prefix) + (push (widget-create-child-and-convert + widget 'custom-browse-visibility + ;; :tag-glyph "plus" + :tag "+") + buttons) + (insert "-- ") + ;; (widget-glyph-insert nil "-- " "horizontal") + (push (widget-create-child-and-convert + widget 'custom-browse-group-tag) + buttons) + (insert " " tag "\n") + (widget-put widget :buttons buttons)) + ((and (eq custom-buffer-style 'tree) + (zerop (length members))) + (custom-browse-insert-prefix prefix) + (insert "[ ]-- ") + ;; (widget-glyph-insert nil "[ ]" "empty") + ;; (widget-glyph-insert nil "-- " "horizontal") + (push (widget-create-child-and-convert + widget 'custom-browse-group-tag) + buttons) + (insert " " tag "\n") + (widget-put widget :buttons buttons)) + ((eq custom-buffer-style 'tree) + (custom-browse-insert-prefix prefix) + (custom-load-widget widget) + (if (zerop (length members)) + (progn + (custom-browse-insert-prefix prefix) + (insert "[ ]-- ") + ;; (widget-glyph-insert nil "[ ]" "empty") + ;; (widget-glyph-insert nil "-- " "horizontal") + (push (widget-create-child-and-convert + widget 'custom-browse-group-tag) + buttons) + (insert " " tag "\n") + (widget-put widget :buttons buttons)) + (push (widget-create-child-and-convert + widget 'custom-browse-visibility + ;; :tag-glyph "minus" + :tag "-") + buttons) + (insert "-\\ ") + ;; (widget-glyph-insert nil "-\\ " "top") + (push (widget-create-child-and-convert + widget 'custom-browse-group-tag) + buttons) + (insert " " tag "\n") + (widget-put widget :buttons buttons) + (message "Creating group...") + (let* ((members (custom-sort-items members + custom-browse-sort-alphabetically + custom-browse-order-groups)) + (prefixes (widget-get widget :custom-prefixes)) + (custom-prefix-list (custom-prefix-add symbol prefixes)) + (extra-prefix (if (widget-get widget :custom-last) + " " + " | ")) + (prefix (concat prefix extra-prefix)) + children entry) + (while members + (setq entry (car members) + members (cdr members)) + (push (widget-create-child-and-convert + widget (nth 1 entry) + :group widget + :tag (custom-unlispify-tag-name (nth 0 entry)) + :custom-prefixes custom-prefix-list + :custom-level (1+ level) + :custom-last (null members) + :value (nth 0 entry) + :custom-prefix prefix) + children)) + (widget-put widget :children (reverse children))) + (message "Creating group...done"))) + ;; Nested style. + ((eq state 'hidden) + ;; Create level indicator. + (unless (eq custom-buffer-style 'links) + (insert-char ?\ (* custom-buffer-indent (1- level))) + (insert "-- ")) + ;; Create link indicator. + (when (eq custom-buffer-style 'links) + (insert " ") + (push (widget-create-child-and-convert + widget 'custom-group-link + :tag "Open" + :tag-glyph '("open-up" "open-down") + symbol) + buttons) + (insert " ")) + ;; Create tag. + (let ((begin (point))) + (insert tag) + (widget-specify-sample widget begin (point))) + (insert " group") + ;; Create visibility indicator. + (unless (eq custom-buffer-style 'links) + (insert ": ") + (push (widget-create-child-and-convert + widget 'custom-group-visibility + :help-echo "Show members of this group" + :action 'custom-toggle-parent + (not (eq state 'hidden))) + buttons)) + (insert " \n") + ;; Create magic button. + (let ((magic (widget-create-child-and-convert + widget 'custom-magic nil))) + (widget-put widget :custom-magic magic) + (push magic buttons)) + ;; Update buttons. + (widget-put widget :buttons buttons) + ;; Insert documentation. + (if (and (eq custom-buffer-style 'links) (> level 1)) + (widget-put widget :documentation-indent 0)) + (widget-default-format-handler widget ?h)) + ;; Nested style. + (t ;Visible. + (custom-load-widget widget) + ;; Update members + (setq members (custom-group-members + symbol (and (eq custom-buffer-style 'tree) + custom-browse-only-groups))) + ;; Add parent groups references above the group. + (if t ;;; This should test that the buffer + ;;; was made to display a group. + (when (eq level 1) + (if (custom-add-parent-links widget + "Go to parent group:") + (insert "\n")))) + ;; Create level indicator. + (insert-char ?\ (* custom-buffer-indent (1- level))) + (insert "/- ") + ;; Create tag. + (let ((start (point))) + (insert tag) + (widget-specify-sample widget start (point))) + (insert " group: ") + ;; Create visibility indicator. + (unless (eq custom-buffer-style 'links) + (insert "--------") + (push (widget-create-child-and-convert + widget 'visibility + :help-echo "Hide members of this group" + :action 'custom-toggle-parent + (not (eq state 'hidden))) + buttons) + (insert " ")) + ;; Create more dashes. + ;; Use 76 instead of 75 to compensate for the temporary "<" + ;; added by `widget-insert'. + (insert-char ?- (- 76 (current-column) + (* custom-buffer-indent level))) + (insert "\\\n") + ;; Create magic button. + (let ((magic (widget-create-child-and-convert + widget 'custom-magic + :indent 0 + nil))) + (widget-put widget :custom-magic magic) + (push magic buttons)) + ;; Update buttons. + (widget-put widget :buttons buttons) + ;; Insert documentation. + (widget-default-format-handler widget ?h) + ;; Parent groups. + (if nil ;;; This should test that the buffer + ;;; was not made to display a group. + (when (eq level 1) + (insert-char ?\ custom-buffer-indent) + (custom-add-parent-links widget))) + (custom-add-see-also widget + (make-string (* custom-buffer-indent level) + ?\ )) + ;; Members. + (message "Creating group...") + (let* ((members (custom-sort-items members + custom-buffer-sort-alphabetically + custom-buffer-order-groups)) + (prefixes (widget-get widget :custom-prefixes)) + (custom-prefix-list (custom-prefix-add symbol prefixes)) + (length (length members)) + (count 0) + (children (mapcar + (lambda (entry) + (widget-insert "\n") + (when (zerop (% count custom-skip-messages)) + (display-message + 'progress + (format "\ +Creating group members... %2d%%" + (/ (* 100.0 count) length)))) + (incf count) + (prog1 + (widget-create-child-and-convert + widget (nth 1 entry) + :group widget + :tag (custom-unlispify-tag-name + (nth 0 entry)) + :custom-prefixes custom-prefix-list + :custom-level (1+ level) + :value (nth 0 entry)) + (unless (eq (preceding-char) ?\n) + (widget-insert "\n")))) + members))) + (message "Creating group magic...") + (mapc 'custom-magic-reset children) + (message "Creating group state...") + (widget-put widget :children children) + (custom-group-state-update widget) + (message "Creating group... done")) + ;; End line + (insert "\n") + (insert-char ?\ (* custom-buffer-indent (1- level))) + (insert "\\- " (widget-get widget :tag) " group end ") + (insert-char ?- (- 75 (current-column) (* custom-buffer-indent level))) + (insert "/\n"))))) + +(defvar custom-group-menu + '(("Set for Current Session" custom-group-set + (lambda (widget) + (eq (widget-get widget :custom-state) 'modified))) + ("Save for Future Sessions" custom-group-save + (lambda (widget) + (memq (widget-get widget :custom-state) '(modified set)))) + ("Reset to Current" custom-group-reset-current + (lambda (widget) + (memq (widget-get widget :custom-state) '(modified)))) + ("Reset to Saved" custom-group-reset-saved + (lambda (widget) + (memq (widget-get widget :custom-state) '(modified set)))) + ("Reset to standard setting" custom-group-reset-standard + (lambda (widget) + (memq (widget-get widget :custom-state) '(modified set saved))))) + "Alist of actions for the `custom-group' widget. +Each entry has the form (NAME ACTION FILTER) where NAME is the name of +the menu entry, ACTION is the function to call on the widget when the +menu is selected, and FILTER is a predicate which takes a `custom-group' +widget as an argument, and returns non-nil if ACTION is valid on that +widget. If FILTER is nil, ACTION is always valid.") + +(defun custom-group-action (widget &optional event) + "Show the menu for `custom-group' WIDGET. +Optional EVENT is the location for the menu." + (if (eq (widget-get widget :custom-state) 'hidden) + (custom-toggle-hide widget) + (let* ((completion-ignore-case t) + (answer (widget-choose (concat "Operation on " + (custom-unlispify-tag-name + (widget-get widget :value))) + (custom-menu-filter custom-group-menu + widget) + event))) + (if answer + (funcall answer widget))))) + +(defun custom-group-set (widget) + "Set changes in all modified group members." + (let ((children (widget-get widget :children))) + (mapc (lambda (child) + (when (eq (widget-get child :custom-state) 'modified) + (widget-apply child :custom-set))) + children))) + +(defun custom-group-save (widget) + "Save all modified group members." + (let ((children (widget-get widget :children))) + (mapc (lambda (child) + (when (memq (widget-get child :custom-state) '(modified set)) + (widget-apply child :custom-save))) + children))) + +(defun custom-group-reset-current (widget) + "Reset all modified group members." + (let ((children (widget-get widget :children))) + (mapc (lambda (child) + (when (eq (widget-get child :custom-state) 'modified) + (widget-apply child :custom-reset-current))) + children))) + +(defun custom-group-reset-saved (widget) + "Reset all modified or set group members." + (let ((children (widget-get widget :children))) + (mapc (lambda (child) + (when (memq (widget-get child :custom-state) '(modified set)) + (widget-apply child :custom-reset-saved))) + children))) + +(defun custom-group-reset-standard (widget) + "Reset all modified, set, or saved group members." + (let ((children (widget-get widget :children))) + (mapc (lambda (child) + (when (memq (widget-get child :custom-state) + '(modified set saved)) + (widget-apply child :custom-reset-standard))) + children))) + +(defun custom-group-state-update (widget) + "Update magic." + (unless (eq (widget-get widget :custom-state) 'hidden) + (let* ((children (widget-get widget :children)) + (states (mapcar (lambda (child) + (widget-get child :custom-state)) + children)) + (magics custom-magic-alist) + (found 'standard)) + (while magics + (let ((magic (car (car magics)))) + (if (and (not (eq magic 'hidden)) + (memq magic states)) + (setq found magic + magics nil) + (setq magics (cdr magics))))) + (widget-put widget :custom-state found))) + (custom-magic-reset widget)) + +;;; The `custom-save-all' Function. +;;;###autoload +(defcustom custom-file (if (boundp 'emacs-user-extension-dir) + (concat "~" + init-file-user + emacs-user-extension-dir + "options.el") + "~/.emacs") + "File used for storing customization information. +If you change this from the default \"~/.emacs\" you need to +explicitly load that file for the settings to take effect." + :type 'file + :group 'customize) + +(defun custom-save-delete (symbol) + "Delete the call to SYMBOL form `custom-file'. +Leave point at the location of the call, or after the last expression." + (let ((find-file-hooks nil) + (auto-mode-alist nil)) + (set-buffer (find-file-noselect custom-file))) + (goto-char (point-min)) + (catch 'found + (while t + (let ((sexp (condition-case nil + (read (current-buffer)) + (end-of-file (throw 'found nil))))) + (when (and (listp sexp) + (eq (car sexp) symbol)) + (delete-region (save-excursion + (backward-sexp) + (point)) + (point)) + (throw 'found nil)))))) + +(defun custom-save-variables () + "Save all customized variables in `custom-file'." + (save-excursion + (custom-save-delete 'custom-set-variables) + (let ((standard-output (current-buffer))) + (unless (bolp) + (princ "\n")) + (princ "(custom-set-variables") + (mapatoms (lambda (symbol) + (let ((value (get symbol 'saved-value)) + (requests (get symbol 'custom-requests)) + (now (not (or (get symbol 'standard-value) + (and (not (boundp symbol)) + (not (get symbol 'force-value))))))) + (when value + (princ "\n '(") + (princ symbol) + (princ " ") + (prin1 (car value)) + (cond (requests + (if now + (princ " t ") + (princ " nil ")) + (prin1 requests) + (princ ")")) + (now + (princ " t)")) + (t + (princ ")"))))))) + (princ ")") + (unless (looking-at "\n") + (princ "\n"))))) + +(defun custom-save-faces () + "Save all customized faces in `custom-file'." + (save-excursion + (custom-save-delete 'custom-set-faces) + (let ((standard-output (current-buffer))) + (unless (bolp) + (princ "\n")) + (princ "(custom-set-faces") + (let ((value (get 'default 'saved-face))) + ;; The default face must be first, since it affects the others. + (when value + (princ "\n '(default ") + (prin1 value) + (if (or (get 'default 'face-defface-spec) + (and (not (find-face 'default)) + (not (get 'default 'force-face)))) + (princ ")") + (princ " t)")))) + (mapatoms (lambda (symbol) + (let ((value (get symbol 'saved-face))) + (when (and (not (eq symbol 'default)) + ;; Don't print default face here. + value) + (princ "\n '(") + (princ symbol) + (princ " ") + (prin1 value) + (if (or (get symbol 'face-defface-spec) + (and (not (find-face symbol)) + (not (get symbol 'force-face)))) + (princ ")") + (princ " t)")))))) + (princ ")") + (unless (looking-at "\n") + (princ "\n"))))) + +;;;###autoload +(defun customize-save-customized () + "Save all user options which have been set in this session." + (interactive) + (mapatoms (lambda (symbol) + (let ((face (get symbol 'customized-face)) + (value (get symbol 'customized-value))) + (when face + (put symbol 'saved-face face) + (put symbol 'customized-face nil)) + (when value + (put symbol 'saved-value value) + (put symbol 'customized-value nil))))) + ;; We really should update all custom buffers here. + (custom-save-all)) + +;;;###autoload +(defun custom-save-all () + "Save all customizations in `custom-file'." + (let ((inhibit-read-only t)) + (custom-save-variables) + (custom-save-faces) + (let ((find-file-hooks nil) + (auto-mode-alist)) + (with-current-buffer (find-file-noselect custom-file) + (save-buffer))))) + + +;;; The Customize Menu. + +;;; Menu support + +(defun custom-face-menu-create (widget symbol) + "Ignoring WIDGET, create a menu entry for customization face SYMBOL." + (vector (custom-unlispify-menu-entry symbol) + `(customize-face ',symbol) + t)) + +(defun custom-variable-menu-create (widget symbol) + "Ignoring WIDGET, create a menu entry for customization variable SYMBOL." + (let ((type (get symbol 'custom-type))) + (unless (listp type) + (setq type (list type))) + (if (and type (widget-get type :custom-menu)) + (widget-apply type :custom-menu symbol) + (vector (custom-unlispify-menu-entry symbol) + `(customize-variable ',symbol) + t)))) + +;; Add checkboxes to boolean variable entries. +(widget-put (get 'boolean 'widget-type) + :custom-menu (lambda (widget symbol) + `[,(custom-unlispify-menu-entry symbol) + (customize-variable ',symbol) + :style toggle + :selected ,symbol])) + +;; XEmacs can create menus dynamically. +(defun custom-group-menu-create (widget symbol) + "Ignoring WIDGET, create a menu entry for customization group SYMBOL." + `( ,(custom-unlispify-menu-entry symbol t) + :filter (lambda (&rest junk) + (let ((item (custom-menu-create ',symbol))) + (if (listp item) + (cdr item) + (list item)))))) + +;;;###autoload +(defun custom-menu-create (symbol) + "Create menu for customization group SYMBOL. +The menu is in a format applicable to `easy-menu-define'." + (let* ((item (vector (custom-unlispify-menu-entry symbol) + `(customize-group ',symbol) + t))) + ;; Item is the entry for creating a menu buffer for SYMBOL. + ;; We may nest, if the menu is not too big. + (custom-load-symbol symbol) + (if (< (length (get symbol 'custom-group)) widget-menu-max-size) + ;; The menu is not too big. + (let ((custom-prefix-list (custom-prefix-add symbol + custom-prefix-list)) + (members (custom-sort-items (get symbol 'custom-group) + custom-menu-sort-alphabetically + custom-menu-order-groups))) + ;; Create the menu. + `(,(custom-unlispify-menu-entry symbol t) + ,item + "--" + ,@(mapcar (lambda (entry) + (widget-apply (if (listp (nth 1 entry)) + (nth 1 entry) + (list (nth 1 entry))) + :custom-menu (nth 0 entry))) + members))) + ;; The menu was too big. + item))) + +;;;###autoload +(defun customize-menu-create (symbol &optional name) + "Return a customize menu for customization group SYMBOL. +If optional NAME is given, use that as the name of the menu. +Otherwise the menu will be named `Customize'. +The format is suitable for use with `easy-menu-define'." + (unless name + (setq name "Customize")) + `(,name + :filter (lambda (&rest junk) + (cdr (custom-menu-create ',symbol))))) + +;;; The Custom Mode. + +(defvar custom-mode-map nil + "Keymap for `custom-mode'.") + +(unless custom-mode-map + (setq custom-mode-map (make-sparse-keymap)) + (set-keymap-parents custom-mode-map widget-keymap) + (suppress-keymap custom-mode-map) + (define-key custom-mode-map " " 'scroll-up) + (define-key custom-mode-map "\177" 'scroll-down) + (define-key custom-mode-map "q" 'bury-buffer) + (define-key custom-mode-map "u" 'Custom-goto-parent) + (define-key custom-mode-map "n" 'widget-forward) + (define-key custom-mode-map "p" 'widget-backward) + ;; (define-key custom-mode-map [mouse-1] 'Custom-move-and-invoke) + ) + +(defun Custom-move-and-invoke (event) + "Move to where you click, and if it is an active field, invoke it." + (interactive "e") + (mouse-set-point event) + (if (widget-event-point event) + (let* ((pos (widget-event-point event)) + (button (get-char-property pos 'button))) + (if button + (widget-button-click event))))) + +(easy-menu-define Custom-mode-menu + custom-mode-map + "Menu used in customization buffers." + `("Custom" + ,(customize-menu-create 'customize) + ["Set" Custom-set t] + ["Save" Custom-save t] + ["Reset to Current" Custom-reset-current t] + ["Reset to Saved" Custom-reset-saved t] + ["Reset to Standard Settings" Custom-reset-standard t] + ["Info" (Info-goto-node "(xemacs)Easy Customization") t])) + +(defun Custom-goto-parent () + "Go to the parent group listed at the top of this buffer. +If several parents are listed, go to the first of them." + (interactive) + (save-excursion + (goto-char (point-min)) + (if (search-forward "\nGo to parent group: " nil t) + (let* ((button (get-char-property (point) 'button)) + (parent (downcase (widget-get button :tag)))) + (customize-group parent))))) + +(defcustom custom-mode-hook nil + "Hook called when entering custom-mode." + :type 'hook + :group 'custom-buffer ) + +(defun custom-state-buffer-message (widget) + (if (eq (widget-get (widget-get widget :parent) :custom-state) 'modified) + (message + "To install your edits, invoke [State] and choose the Set operation"))) + +(defun custom-mode () + "Major mode for editing customization buffers. + +The following commands are available: + +Move to next button or editable field. \\[widget-forward] +Move to previous button or editable field. \\[widget-backward] +\\<widget-field-keymap>\ +Complete content of editable text field. \\[widget-complete] +\\<custom-mode-map>\ +Invoke button under the mouse pointer. \\[Custom-move-and-invoke] +Invoke button under point. \\[widget-button-press] +Set all modifications. \\[Custom-set] +Make all modifications default. \\[Custom-save] +Reset all modified options. \\[Custom-reset-current] +Reset all modified or set options. \\[Custom-reset-saved] +Reset all options. \\[Custom-reset-standard] + +Entry to this mode calls the value of `custom-mode-hook' +if that value is non-nil." + (kill-all-local-variables) + (setq major-mode 'custom-mode + mode-name "Custom") + (use-local-map custom-mode-map) + (easy-menu-add Custom-mode-menu) + (make-local-variable 'custom-options) + (make-local-variable 'widget-documentation-face) + (setq widget-documentation-face 'custom-documentation-face) + (make-local-variable 'widget-button-face) + (setq widget-button-face 'custom-button-face) + (make-local-hook 'widget-edit-functions) + (add-hook 'widget-edit-functions 'custom-state-buffer-message nil t) + (run-hooks 'custom-mode-hook)) + + +;;; The End. + +(provide 'cus-edit) + +;; cus-edit.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cus-face.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,255 @@ +;;; cus-face.el -- Support for Custom faces. +;; +;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. +;; +;; Author: Per Abrahamsen <abraham@dina.kvl.dk> +;; Maintainer: Hrvoje Niksic <hniksic@srce.hr> +;; Keywords: help, faces +;; Version: 1.9960-x +;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ + +;;; Commentary: +;; +;; See `custom.el'. + +;; This file should probably be dissolved, and code moved to faces.el, +;; like Stallman did. + +;;; Code: + +(require 'custom) + +;; To elude the warnings for font functions. +(eval-when-compile + (require 'font)) + +;;; Declaring a face. + +;;;###autoload +(defun custom-declare-face (face spec doc &rest args) + "Like `defface', but FACE is evaluated as a normal argument." + ;; (when (fboundp 'load-gc) + ;; (error "Attempt to declare a face during dump")) + (unless (get face 'face-defface-spec) + (put face 'face-defface-spec spec) + (unless (find-face face) + ;; If the user has already created the face, respect that. + (let ((value (or (get face 'saved-face) spec)) + (frames (relevant-custom-frames)) + frame) + ;; Create global face. + (make-empty-face face) + (face-display-set face value) + ;; Create frame local faces + (while frames + (setq frame (car frames) + frames (cdr frames)) + (face-display-set face value frame)) + (init-face-from-resources face))) + (when (and doc (null (face-doc-string face))) + (set-face-doc-string face doc)) + (custom-handle-all-keywords face args 'custom-face) + (run-hooks 'custom-define-hook)) + face) + +;;; Font Attributes. + +(defconst custom-face-attributes + '((:bold (boolean :tag "Bold" + :help-echo "Control whether a bold font should be used.") + custom-set-face-bold custom-face-bold) + (:italic (boolean :tag "Italic" + :help-echo "\ +Control whether an italic font should be used.") + custom-set-face-italic custom-face-italic) + (:underline (boolean :tag "Underline" + :help-echo "\ +Control whether the text should be underlined.") + set-face-underline-p face-underline-p) + (:foreground (color :tag "Foreground" + :value "" + :help-echo "Set foreground color.") + set-face-foreground face-foreground-name) + (:background (color :tag "Background" + :value "" + :help-echo "Set background color.") + set-face-background face-background-name) + ;; #### Should make it work on X + (:inverse-video (boolean :tag "Inverse" + :help-echo "\ +Control whether the text should be inverted. Works only on TTY-s") + set-face-reverse-p face-reverse-p) + (:stipple (editable-field :format "Stipple: %v" + :help-echo "Name of background bitmap file.") + set-face-background-pixmap custom-face-stipple) + (:family (editable-field :format "Font Family: %v" + :help-echo "\ +Name of font family to use (e.g. times).") + custom-set-face-font-family custom-face-font-family) + (:size (editable-field :format "Size: %v" + :help-echo "\ +Text size (e.g. 9pt or 2mm).") + custom-set-face-font-size custom-face-font-size) + (:strikethru (toggle :format "%[Strikethru%]: %v\n" + :help-echo "\ +Control whether the text should be strikethru.") + set-face-strikethru-p face-strikethru-p)) + "Alist of face attributes. + +The elements are of the form (KEY TYPE SET GET) where KEY is a symbol +identifying the attribute, TYPE is a widget type for editing the +attibute, SET is a function for setting the attribute value, and GET is a function for getiing the attribute value. + +The SET function should take three arguments, the face to modify, the +value of the attribute, and optionally the frame where the face should +be changed. + +The GET function should take two arguments, the face to examine, and +optonally the frame where the face should be examined.") + +(defun face-custom-attributes-set (face frame &rest atts) + "For FACE on FRAME set the attributes [KEYWORD VALUE].... +Each keyword should be listed in `custom-face-attributes'. + +If FRAME is nil, set the default face." + (while atts + (let* ((name (nth 0 atts)) + (value (nth 1 atts)) + (fun (nth 2 (assq name custom-face-attributes)))) + (setq atts (cdr (cdr atts))) + (condition-case nil + (funcall fun face value frame) + (error nil))))) + +(defun face-custom-attributes-get (face frame) + "For FACE on FRAME get the attributes [KEYWORD VALUE].... +Each keyword should be listed in `custom-face-attributes'. + +If FRAME is nil, use the default face." + (condition-case nil + ;; Attempt to get `font.el' from w3. + (require 'font) + (error nil)) + (let ((atts custom-face-attributes) + att result get) + (while atts + (setq att (car atts) + atts (cdr atts) + get (nth 3 att)) + (condition-case nil + ;; This may fail if w3 doesn't exists. + (when get + (let ((answer (funcall get face frame))) + (unless (equal answer (funcall get 'default frame)) + (when (widget-apply (nth 1 att) :match answer) + (setq result (cons (nth 0 att) (cons answer result))))))) + (error nil))) + result)) + +(defun custom-set-face-bold (face value &optional frame) + "Set the bold property of FACE to VALUE." + (if value + (make-face-bold face frame) + (make-face-unbold face frame))) + +;; Really, we should get rid of these font.el dependencies... They +;; are still presenting a problem with dumping the faces (font.el is +;; too bloated for us to dump). I am thinking about hacking up +;; font-like functionality myself for the sake of this file. It will +;; probably be to-the-point and more efficient. + +(defun custom-face-bold (face &rest args) + "Return non-nil if the font of FACE is bold." + (let* ((font (apply 'face-font-name face args)) + ;; Gag + (fontobj (font-create-object font))) + (font-bold-p fontobj))) + +(defun custom-set-face-italic (face value &optional frame) + "Set the italic property of FACE to VALUE." + (if value + (make-face-italic face frame) + (make-face-unitalic face frame))) + +(defun custom-face-italic (face &rest args) + "Return non-nil if the font of FACE is italic." + (let* ((font (apply 'face-font-name face args)) + ;; Gag + (fontobj (font-create-object font))) + (font-italic-p fontobj))) + +(defun custom-face-stipple (face &rest args) + "Return the name of the stipple file used for FACE." + (let ((image (apply 'specifier-instance + (face-background-pixmap face) args))) + (and image + (image-instance-file-name image)))) + +(defun custom-set-face-font-size (face size &rest args) + "Set the font of FACE to SIZE" + (let* ((font (apply 'face-font-name face args)) + ;; Gag + (fontobj (font-create-object font))) + (set-font-size fontobj size) + (apply 'font-set-face-font face fontobj args))) + +(defun custom-face-font-size (face &rest args) + "Return the size of the font of FACE as a string." + (let* ((font (apply 'face-font-name face args)) + ;; Gag + (fontobj (font-create-object font))) + (format "%s" (font-size fontobj)))) + +(defun custom-set-face-font-family (face family &rest args) + "Set the font of FACE to FAMILY." + (let* ((font (apply 'face-font-name face args)) + ;; Gag + (fontobj (font-create-object font))) + (set-font-family fontobj family) + (apply 'font-set-face-font face fontobj args))) + +(defun custom-face-font-family (face &rest args) + "Return the name of the font family of FACE." + (let* ((font (apply 'face-font-name face args)) + ;; Gag + (fontobj (font-create-object font))) + (font-family fontobj))) + +;;; Initializing. + +;;;###autoload +(defun custom-set-faces (&rest args) + "Initialize faces according to user preferences. +The arguments should be a list where each entry has the form: + + (FACE SPEC [NOW]) + +SPEC will be stored as the saved value for FACE. If NOW is present +and non-nil, FACE will also be created according to SPEC. + +See `defface' for the format of SPEC." + (while args + (let ((entry (car args))) + (if (listp entry) + (let ((face (nth 0 entry)) + (spec (nth 1 entry)) + (now (nth 2 entry))) + (put face 'saved-face spec) + (when now + (put face 'force-face t)) + (when (or now (find-face face)) + (unless (find-face face) + (make-empty-face face)) + (face-spec-set face spec)) + (setq args (cdr args))) + ;; Old format, a plist of FACE SPEC pairs. + (let ((face (nth 0 args)) + (spec (nth 1 args))) + (put face 'saved-face spec)) + (setq args (cdr (cdr args))))))) + +;;; The End. + +(provide 'cus-face) + +;; cus-face.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cus-load.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,72 @@ +;;; cus-load.el --- Batch load all available cus-load files + +;; Copyright (C) 1997 by Free Software Foundation, Inc. + +;; Author: Steven L Baur <steve@altair.xemacs.org> +;; Keywords: internal, help, faces + +;; 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: + +;; In FSF all of the custom loads are in a single `cus-load' file. +;; However, we have them distributed across directories, with optional +;; incremental loading. Here we simply collect the whole set. + + +;;; Code: + +(require 'custom) + + +(defun custom-add-loads (symbol list) + "Update the custom-loads list of a symbol. +This works by adding the elements from LIST to the SYMBOL's +`custom-loads' property, avoiding duplicates. Also, SYMBOL is +added to `custom-group-hash-table'." + (let ((loads (get symbol 'custom-loads))) + (dolist (el list) + (unless (member el loads) + (setq loads (nconc loads (list el))))) + (put symbol 'custom-loads loads) + (puthash symbol t custom-group-hash-table))) + +;; custom-add-loads was named custom-put (and accepted different +;; arguments) during the 20.3 beta cycle. Support it for +;; compatibility. +(defun custom-put (symbol ignored list) + (custom-add-loads symbol list)) +(make-obsolete 'custom-put 'custom-add-loads) + + +(message "Loading customization dependencies...") + +;; Garbage-collection seems to be very intensive here, and it slows +;; things down. Nuke it. +(let ((gc-cons-threshold 10000000)) + (mapc (lambda (dir) + (load (expand-file-name "custom-load" dir) t t)) + load-path)) + +(message "Loading customization dependencies...done") + +(provide 'cus-load) + +;;; cus-load.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cus-start.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,205 @@ +;;; cus-start.el --- define customization properties of builtins. + +;; Copyright (C) 1997 Free Software Foundation, Inc. + +;; Author: Per Abrahamsen <abraham@dina.kvl.dk> +;; Maintainer: XEmacs Development Team +;; Keywords: internal, dumped + +;; 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 synched with FSF. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;; The following code is used to define the customization properties +;; for builtin variables, and variables in the packages that are +;; preloaded /very/ early, before custom.el itself (replace.el is such +;; an example). The way it handles custom stuff is dirty, and should +;; be regarded as a last resort. DO NOT add variables here, unless +;; you know what you are doing. + +;; Must be run before the user has changed the value of any options! + + +;;; Code: + +(require 'custom) + +(defun custom-start-quote (sexp) + ;; This is copied from `cus-edit.el'. + "Quote SEXP iff it is not self quoting." + (if (or (memq sexp '(t nil)) + (and (symbolp sexp) + (eq (aref (symbol-name sexp) 0) ?:)) + (and (listp sexp) + (memq (car sexp) '(lambda))) + (stringp sexp) + (numberp sexp) + (and (fboundp 'characterp) + (characterp sexp))) + sexp + (list 'quote sexp))) + +(let ((all '(;; boolean + (abbrev-all-caps abbrev boolean) + (allow-deletion-of-last-visible-frame frames boolean) + (debug-on-quit debug boolean) + (delete-auto-save-files auto-save boolean) + (delete-exited-processes processes-basics boolean) + (indent-tabs-mode editing-basics boolean) + (load-ignore-elc-files maint boolean) + (load-warn-when-source-newer maint boolean) + (load-warn-when-source-only maint boolean) + (modifier-keys-are-sticky keyboard boolean) + (no-redraw-on-reenter display boolean) + (scroll-on-clipped-lines display boolean) + (truncate-partial-width-windows display boolean) + (visible-bell sound boolean) + (x-allow-sendevents x boolean) + (zmacs-regions editing-basics boolean) + ;; integer + (auto-save-interval auto-save integer) + (bell-volume sound integer) + (echo-keystrokes keyboard integer) + (gc-cons-threshold alloc integer) + (next-screen-context-lines display integer) + (scroll-conservatively display integer) + (scroll-step windows integer) + (window-min-height windows integer) + (window-min-width windows integer) + ;; object + (auto-save-file-format auto-save + (choice (const :tag "Normal" t) + (repeat (symbol :tag "Format")))) + (completion-ignored-extensions minibuffer + (repeat + (string :format "%v"))) + (debug-ignored-errors debug (repeat (choice :format "%v" + (symbol :tag "Class") + regexp))) + (debug-on-error debug (choice (const :tag "off" nil) + (const :tag "Always" t) + (repeat :menu-tag "When" + :value (nil) + (symbol + :tag "Condition")))) + (debug-on-signal debug (choice (const :tag "off" nil) + (const :tag "Always" t) + (repeat :menu-tag "When" + :value (nil) + (symbol + :tag "Condition")))) + (exec-path processes-basics (repeat + (choice :tag "Directory" + (const :tag "Default" nil) + (directory :format "%v")))) + (file-name-handler-alist data (repeat + (cons regexp + (function :tag "Handler")))) + (shell-file-name execute file) + (stack-trace-on-error debug (choice (const :tag "off" nil) + (const :tag "Always" t) + (repeat :menu-tag "When" + :value (nil) + (symbol + :tag "Condition")))) + (stack-trace-on-signal debug (choice (const :tag "off" nil) + (const :tag "Always" t) + (repeat :menu-tag "When" + :value (nil) + (symbol + :tag "Condition")))) + ;; buffer-local + (case-fold-search matching boolean) + (ctl-arrow display (choice (integer 160) + (sexp :tag "160 (default)" + :format "%t\n"))) + (fill-column fill integer) + (left-margin fill integer) + (tab-width editing-basics integer) + (truncate-lines display boolean) + ;; not documented as user-options, but should still be + ;; customizable: + (bar-cursor display (choice (const :tag "Block Cursor" nil) + (const :tag "Bar Cursor (1 pixel)" t) + (sexp :tag "Bar Cursor (2 pixels)" + :format "%t\n" 'other))) + (default-frame-plist frames (repeat + (list :inline t + :format "%v" + (symbol :tag "Parameter") + (sexp :tag "Value")))) + (disable-auto-save-when-buffer-shrinks auto-save boolean) + (find-file-use-truenames find-file boolean) + (find-file-compare-truenames find-file boolean) + (focus-follows-mouse x boolean) + (help-char keyboard (choice character + (sexp :tag "Single key specifier"))) + (max-lisp-eval-depth limits integer) + (max-specpdl-size limits integer) + (meta-prefix-char keyboard character) + (parse-sexp-ignore-comments editing-basics boolean) + (selective-display display + (choice (const :tag "off" nil) + (integer :tag "space" + :format "%v" + 1) + (const :tag "on" t))) + (selective-display-ellipses display boolean) + (signal-error-on-buffer-boundary internal boolean) + (temp-buffer-show-function + windows (radio (function-item :tag "Temp Buffers Always in Same Frame" + :format "%t\n" + show-temp-buffer-in-current-frame) + (const :tag "Temp Buffers Like Other Buffers" nil) + (function :tag "Other"))) + (undo-threshold undo integer) + (undo-high-threshold undo integer) + (words-include-escapes editing-basics boolean) + ;; These are from replace.el, which is loaded too early + ;; to be customizable. + (case-replace matching boolean) + (query-replace-highlight matching boolean) + (list-matching-lines-default-context-lines matching integer))) + this symbol group type) + (while all + (setq this (car all) + all (cdr all) + symbol (nth 0 this) + group (nth 1 this) + type (nth 2 this)) + (if (not (boundp symbol)) + ;; This is loaded so early, there is no message + (if (fboundp 'message) + ;; If variables are removed from C code, give an error here! + (message "Intrinsic `%S' not bound" symbol)) + ;; This is called before any user can have changed the value. + (put symbol 'standard-value + (list (custom-start-quote (default-value symbol)))) + ;; Add it to the right group. + (custom-add-to-group group symbol 'custom-variable) + ;; Set the type. + (put symbol 'custom-type type)))) + +;; This is to prevent it from being reloaded by `cus-load.el'. +(provide 'cus-start) + +;;; cus-start.el ends here.
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/custom-load.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,41 @@ +;;; custom-load.el --- automatically extracted custom dependencies + + +;;; Code: + +(custom-add-loads 'extensions '("wid-edit")) +(custom-add-loads 'custom-buffer '("cus-edit")) +(custom-add-loads 'custom-faces '("cus-edit")) +(custom-add-loads 'widgets '("wid-browse" "wid-edit")) +(custom-add-loads 'menu '("x-menubar")) +(custom-add-loads 'environment '("cus-edit" "x-toolbar")) +(custom-add-loads 'custom-menu '("cus-edit")) +(custom-add-loads 'internal '("cus-edit")) +(custom-add-loads 'buffers-menu '("x-menubar")) +(custom-add-loads 'hypermedia '("wid-edit")) +(custom-add-loads 'applications '("cus-edit")) +(custom-add-loads 'help '("cus-edit")) +(custom-add-loads 'widget-browse '("wid-browse")) +(custom-add-loads 'widget-documentation '("wid-edit")) +(custom-add-loads 'customize '("cus-edit" "wid-edit")) +(custom-add-loads 'custom-browse '("cus-edit")) +(custom-add-loads 'abbrev '("cus-edit")) +(custom-add-loads 'programming '("cus-edit")) +(custom-add-loads 'toolbar '("x-toolbar")) +(custom-add-loads 'widget-button '("wid-edit")) +(custom-add-loads 'files '("cus-edit")) +(custom-add-loads 'external '("cus-edit")) +(custom-add-loads 'development '("cus-edit")) +(custom-add-loads 'widget-faces '("wid-edit")) +(custom-add-loads 'languages '("cus-edit")) +(custom-add-loads 'custom-magic-faces '("cus-edit")) +(custom-add-loads 'faces '("cus-edit" "wid-edit")) +(custom-add-loads 'emacs '("cus-edit")) +(custom-add-loads 'processes '("cus-edit")) +(custom-add-loads 'wp '("cus-edit")) +(custom-add-loads 'editing '("cus-edit")) +(custom-add-loads 'i18n '("cus-edit")) +(custom-add-loads 'info '("x-toolbar")) +(custom-add-loads 'x '("x-faces" "x-font-menu")) + +;;; custom-load.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/custom.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,398 @@ +;;; custom.el -- Tools for declaring and initializing options. + +;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. + +;; Author: Per Abrahamsen <abraham@dina.kvl.dk> +;; Maintainer: Hrvoje Niksic <hniksic@srce.hr> +;; Keywords: help, faces, dumped +;; Version: 1.9960-x +;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ + +;; 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. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;; This file only contain the code needed to declare and initialize +;; user options. The code to customize options is autoloaded from +;; `cus-edit.el'. +;; +;; The code implementing face declarations is in `cus-face.el' + +;;; Code: + +(require 'widget) + +(defvar custom-define-hook nil + ;; Customize information for this option is in `cus-edit.el'. + "Hook called after defining each customize option.") + +;;; The `defcustom' Macro. + +(defun custom-initialize-default (symbol value) + "Initialize SYMBOL with VALUE. +This will do nothing if symbol already has a default binding. +Otherwise, if symbol has a `saved-value' property, it will evaluate +the car of that and used as the default binding for symbol. +Otherwise, VALUE will be evaluated and used as the default binding for +symbol." + (unless (default-boundp symbol) + ;; Use the saved value if it exists, otherwise the standard setting. + (set-default symbol (if (get symbol 'saved-value) + (eval (car (get symbol 'saved-value))) + (eval value))))) + +(defun custom-initialize-set (symbol value) + "Initialize SYMBOL with VALUE. +Like `custom-initialize-default', but use the function specified by +`:set' to initialize SYMBOL." + (unless (default-boundp symbol) + (funcall (or (get symbol 'custom-set) 'set-default) + symbol + (if (get symbol 'saved-value) + (eval (car (get symbol 'saved-value))) + (eval value))))) + +(defun custom-initialize-reset (symbol value) + "Initialize SYMBOL with VALUE. +Like `custom-initialize-set', but use the function specified by +`:get' to reinitialize SYMBOL if it is already bound." + (funcall (or (get symbol 'custom-set) 'set-default) + symbol + (cond ((default-boundp symbol) + (funcall (or (get symbol 'custom-get) 'default-value) + symbol)) + ((get symbol 'saved-value) + (eval (car (get symbol 'saved-value)))) + (t + (eval value))))) + +(defun custom-initialize-changed (symbol value) + "Initialize SYMBOL with VALUE. +Like `custom-initialize-reset', but only use the `:set' function if the +not using the standard setting. Otherwise, use the `set-default'." + (cond ((default-boundp symbol) + (funcall (or (get symbol 'custom-set) 'set-default) + symbol + (funcall (or (get symbol 'custom-get) 'default-value) + symbol))) + ((get symbol 'saved-value) + (funcall (or (get symbol 'custom-set) 'set-default) + symbol + (eval (car (get symbol 'saved-value))))) + (t + (set-default symbol (eval value))))) + +(defun custom-declare-variable (symbol value doc &rest args) + "Like `defcustom', but SYMBOL and VALUE are evaluated as normal arguments." + ;; Remember the standard setting. + (put symbol 'standard-value (list value)) + ;; Maybe this option was rogue in an earlier version. It no longer is. + (when (get symbol 'force-value) + ;; It no longer is. + (put symbol 'force-value nil)) + (when doc + (put symbol 'variable-documentation doc)) + (let ((initialize 'custom-initialize-reset) + (requests nil)) + (while args + (let ((arg (car args))) + (setq args (cdr args)) + (unless (symbolp arg) + (error "Junk in args %S" args)) + (let ((keyword arg) + (value (car args))) + (unless args + (error "Keyword %s is missing an argument" keyword)) + (setq args (cdr args)) + (cond ((eq keyword :initialize) + (setq initialize value)) + ((eq keyword :set) + (put symbol 'custom-set value)) + ((eq keyword :get) + (put symbol 'custom-get value)) + ((eq keyword :require) + (setq requests (cons value requests))) + ((eq keyword :type) + (put symbol 'custom-type value)) + ((eq keyword :options) + (if (get symbol 'custom-options) + ;; Slow safe code to avoid duplicates. + (mapc (lambda (option) + (custom-add-option symbol option)) + value) + ;; Fast code for the common case. + (put symbol 'custom-options (copy-sequence value)))) + (t + (custom-handle-keyword symbol keyword value + 'custom-variable)))))) + (put symbol 'custom-requests requests) + ;; Do the actual initialization. + (funcall initialize symbol value)) + (run-hooks 'custom-define-hook) + symbol) + +(defmacro defcustom (symbol value doc &rest args) + "Declare SYMBOL as a customizable variable that defaults to VALUE. +DOC is the variable documentation. + +Neither SYMBOL nor VALUE needs to be quoted. +If SYMBOL is not already bound, initialize it to VALUE. +The remaining arguments should have the form + + [KEYWORD VALUE]... + +The following KEYWORD's are defined: + +:type VALUE should be a widget type for editing the symbols value. + The default is `sexp'. +:options VALUE should be a list of valid members of the widget type. +:group VALUE should be a customization group. + Add SYMBOL to that group. +:initialize VALUE should be a function used to initialize the + variable. It takes two arguments, the symbol and value + given in the `defcustom' call. The default is + `custom-initialize-set' +:set VALUE should be a function to set the value of the symbol. + It takes two arguments, the symbol to set and the value to + give it. The default is `set-default'. +:get VALUE should be a function to extract the value of symbol. + The function takes one argument, a symbol, and should return + the current value for that symbol. The default is + `default-value'. +:require VALUE should be a feature symbol. Each feature will be + required after initialization, of the the user have saved this + option. + +Read the section about customization in the Emacs Lisp manual for more +information." + `(custom-declare-variable (quote ,symbol) (quote ,value) ,doc ,@args)) + +;;; The `defface' Macro. + +(defmacro defface (face spec doc &rest args) + "Declare FACE as a customizable face that defaults to SPEC. +FACE does not need to be quoted. + +Third argument DOC is the face documentation. + +If FACE has been set with `custom-set-face', set the face attributes +as specified by that function, otherwise set the face attributes +according to SPEC. + +The remaining arguments should have the form + + [KEYWORD VALUE]... + +The following KEYWORDs are defined: + +:group VALUE should be a customization group. + Add FACE to that group. + +SPEC should be an alist of the form ((DISPLAY ATTS)...). + +ATTS is a list of face attributes and their values. The possible +attributes are defined in the variable `custom-face-attributes'. + +The ATTS of the first entry in SPEC where the DISPLAY matches the +frame should take effect in that frame. DISPLAY can either be the +symbol t, which will match all frames, or an alist of the form +\((REQ ITEM...)...) + +For the DISPLAY to match a FRAME, the REQ property of the frame must +match one of the ITEM. The following REQ are defined: + +`type' (the value of `window-system') + Should be one of `x' or `tty'. + +`class' (the frame's color support) + Should be one of `color', `grayscale', or `mono'. + +`background' (what color is used for the background text) + Should be one of `light' or `dark'. + +Read the section about customization in the Emacs Lisp manual for more +information." + `(custom-declare-face (quote ,face) ,spec ,doc ,@args)) + +;;; The `defgroup' Macro. + +(defun custom-declare-group (symbol members doc &rest args) + "Like `defgroup', but SYMBOL is evaluated as a normal argument." + (while members + (apply 'custom-add-to-group symbol (car members)) + (pop members)) + (put symbol 'custom-group (nconc members (get symbol 'custom-group))) + (when doc + (put symbol 'group-documentation doc)) + (while args + (let ((arg (car args))) + (setq args (cdr args)) + (unless (symbolp arg) + (error "Junk in args %S" args)) + (let ((keyword arg) + (value (car args))) + (unless args + (error "Keyword %s is missing an argument" keyword)) + (setq args (cdr args)) + (cond ((eq keyword :prefix) + (put symbol 'custom-prefix value)) + (t + (custom-handle-keyword symbol keyword value + 'custom-group)))))) + (run-hooks 'custom-define-hook) + symbol) + +(defmacro defgroup (symbol members doc &rest args) + "Declare SYMBOL as a customization group containing MEMBERS. +SYMBOL does not need to be quoted. + +Third arg DOC is the group documentation. + +MEMBERS should be an alist of the form ((NAME WIDGET)...) where NAME +is a symbol and WIDGET is a widget for editing that symbol. Useful +widgets are `custom-variable' for editing variables, `custom-face' for +edit faces, and `custom-group' for editing groups. + +The remaining arguments should have the form + + [KEYWORD VALUE]... + +The following KEYWORD's are defined: + +:group VALUE should be a customization group. + Add SYMBOL to that group. + +Read the section about customization in the Emacs Lisp manual for more +information." + `(custom-declare-group (quote ,symbol) ,members ,doc ,@args)) + +;; This is preloaded very early, so we avoid using CL features. +(defvar custom-group-hash-table (make-hashtable 300 'eq) + "Hash-table of non-empty groups.") + +(defun custom-add-to-group (group option widget) + "To existing GROUP add a new OPTION of type WIDGET. +If there already is an entry for that option, overwrite it." + (let* ((members (get group 'custom-group)) + (old (assq option members))) + (if old + (setcar (cdr old) widget) + (put group 'custom-group (nconc members (list (list option widget)))))) + (puthash group t custom-group-hash-table)) + +;;; Properties. + +(defun custom-handle-all-keywords (symbol args type) + "For customization option SYMBOL, handle keyword arguments ARGS. +Third argument TYPE is the custom option type." + (while args + (let ((arg (car args))) + (setq args (cdr args)) + (unless (symbolp arg) + (error "Junk in args %S" args)) + (let ((keyword arg) + (value (car args))) + (unless args + (error "Keyword %s is missing an argument" keyword)) + (setq args (cdr args)) + (custom-handle-keyword symbol keyword value type))))) + +(defun custom-handle-keyword (symbol keyword value type) + "For customization option SYMBOL, handle KEYWORD with VALUE. +Fourth argument TYPE is the custom option type." + (cond ((eq keyword :group) + (custom-add-to-group value symbol type)) + ((eq keyword :link) + (custom-add-link symbol value)) + ((eq keyword :load) + (custom-add-load symbol value)) + ((eq keyword :tag) + (put symbol 'custom-tag value)) + (t + (error "Unknown keyword %s" symbol)))) + +(defun custom-add-option (symbol option) + "To the variable SYMBOL add OPTION. + +If SYMBOL is a hook variable, OPTION should be a hook member. +For other types variables, the effect is undefined." + (let ((options (get symbol 'custom-options))) + (unless (member option options) + (put symbol 'custom-options (cons option options))))) + +(defun custom-add-link (symbol widget) + "To the custom option SYMBOL add the link WIDGET." + (let ((links (get symbol 'custom-links))) + (unless (member widget links) + (put symbol 'custom-links (cons widget links))))) + +(defun custom-add-load (symbol load) + "To the custom option SYMBOL add the dependency LOAD. +LOAD should be either a library file name, or a feature name." + (let ((loads (get symbol 'custom-loads))) + (unless (member load loads) + (put symbol 'custom-loads (cons load loads))))) + +;;; Initializing. + +(defun custom-set-variables (&rest args) + "Initialize variables according to user preferences. + +The arguments should be a list where each entry has the form: + + (SYMBOL VALUE [NOW]) + +The unevaluated VALUE is stored as the saved value for SYMBOL. +If NOW is present and non-nil, VALUE is also evaluated and bound as +the default value for the SYMBOL." + (while args + (let ((entry (car args))) + (if (listp entry) + (let* ((symbol (nth 0 entry)) + (value (nth 1 entry)) + (now (nth 2 entry)) + (requests (nth 3 entry)) + (set (or (get symbol 'custom-set) 'set-default))) + (put symbol 'saved-value (list value)) + (cond (now + ;; Rogue variable, set it now. + (put symbol 'force-value t) + (funcall set symbol (eval value))) + ((default-boundp symbol) + ;; Something already set this, overwrite it. + (funcall set symbol (eval value)))) + (when requests + (put symbol 'custom-requests requests) + (mapc 'require requests)) + (setq args (cdr args))) + ;; Old format, a plist of SYMBOL VALUE pairs. + (message "Warning: old format `custom-set-variables'") + (ding) + (sit-for 2) + (let ((symbol (nth 0 args)) + (value (nth 1 args))) + (put symbol 'saved-value (list value))) + (setq args (cdr (cdr args))))))) + +;;; The End. + +(provide 'custom) + +;; custom.el ends here
--- a/lisp/custom/auto-autoloads.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,197 +0,0 @@ -;;; DO NOT MODIFY THIS FILE -(if (featurep 'custom-autoloads) (error "Already loaded")) - -;;;### (autoloads (Custom-make-dependencies) "cus-dep" "custom/cus-dep.el") - -(autoload 'Custom-make-dependencies "cus-dep" "\ -Extract custom dependencies from .el files in SUBDIRS. -SUBDIRS is a list of directories. If it is nil, the command-line -arguments are used. If it is a string, only that directory is -processed. This function is especially useful in batch mode. - -Batch usage: xemacs -batch -l cus-dep.el -f Custom-make-dependencies DIRS" t nil) - -;;;*** - -;;;### (autoloads (customize-menu-create custom-menu-create custom-save-all customize-save-customized customize-browse custom-buffer-create-other-window custom-buffer-create customize-apropos-groups customize-apropos-faces customize-apropos-options customize-apropos customize-saved customize-customized customize-face-other-window customize-face customize-option-other-window customize-variable customize-other-window customize customize-save-variable customize-set-variable customize-set-value) "cus-edit" "custom/cus-edit.el") - -(autoload 'customize-set-value "cus-edit" "\ -Set VARIABLE to VALUE. VALUE is a Lisp object. - -If VARIABLE has a `variable-interactive' property, that is used as if -it were the arg to `interactive' (which see) to interactively read the value. - -If VARIABLE has a `custom-type' property, it must be a widget and the -`:prompt-value' property of that widget will be used for reading the value." t nil) - -(autoload 'customize-set-variable "cus-edit" "\ -Set the default for VARIABLE to VALUE. VALUE is a Lisp object. - -If VARIABLE has a `custom-set' property, that is used for setting -VARIABLE, otherwise `set-default' is used. - -The `customized-value' property of the VARIABLE will be set to a list -with a quoted VALUE as its sole list member. - -If VARIABLE has a `variable-interactive' property, that is used as if -it were the arg to `interactive' (which see) to interactively read the value. - -If VARIABLE has a `custom-type' property, it must be a widget and the -`:prompt-value' property of that widget will be used for reading the value. " t nil) - -(autoload 'customize-save-variable "cus-edit" "\ -Set the default for VARIABLE to VALUE, and save it for future sessions. -If VARIABLE has a `custom-set' property, that is used for setting -VARIABLE, otherwise `set-default' is used. - -The `customized-value' property of the VARIABLE will be set to a list -with a quoted VALUE as its sole list member. - -If VARIABLE has a `variable-interactive' property, that is used as if -it were the arg to `interactive' (which see) to interactively read the value. - -If VARIABLE has a `custom-type' property, it must be a widget and the -`:prompt-value' property of that widget will be used for reading the value. " t nil) - -(autoload 'customize "cus-edit" "\ -Select a customization buffer which you can use to set user options. -User options are structured into \"groups\". -The default group is `Emacs'." t nil) - -(defalias 'customize-group 'customize) - -(autoload 'customize-other-window "cus-edit" "\ -Customize SYMBOL, which must be a customization group." t nil) - -(defalias 'customize-group-other-window 'customize-other-window) - -(defalias 'customize-option 'customize-variable) - -(autoload 'customize-variable "cus-edit" "\ -Customize SYMBOL, which must be a user option variable." t nil) - -(defalias 'customize-variable-other-window 'customize-option-other-window) - -(autoload 'customize-option-other-window "cus-edit" "\ -Customize SYMBOL, which must be a user option variable. -Show the buffer in another window, but don't select it." t nil) - -(autoload 'customize-face "cus-edit" "\ -Customize SYMBOL, which should be a face name or nil. -If SYMBOL is nil, customize all faces." t nil) - -(autoload 'customize-face-other-window "cus-edit" "\ -Show customization buffer for FACE in other window." t nil) - -(autoload 'customize-customized "cus-edit" "\ -Customize all user options set since the last save in this session." t nil) - -(autoload 'customize-saved "cus-edit" "\ -Customize all already saved user options." t nil) - -(autoload 'customize-apropos "cus-edit" "\ -Customize all user options matching REGEXP. -If ALL is `options', include only options. -If ALL is `faces', include only faces. -If ALL is `groups', include only groups. -If ALL is t (interactively, with prefix arg), include options which are not -user-settable, as well as faces and groups." t nil) - -(autoload 'customize-apropos-options "cus-edit" "\ -Customize all user options matching REGEXP. -With prefix arg, include options which are not user-settable." t nil) - -(autoload 'customize-apropos-faces "cus-edit" "\ -Customize all user faces matching REGEXP." t nil) - -(autoload 'customize-apropos-groups "cus-edit" "\ -Customize all user groups matching REGEXP." t nil) - -(autoload 'custom-buffer-create "cus-edit" "\ -Create a buffer containing OPTIONS. -Optional NAME is the name of the buffer. -OPTIONS should be an alist of the form ((SYMBOL WIDGET)...), where -SYMBOL is a customization option, and WIDGET is a widget for editing -that option." nil nil) - -(autoload 'custom-buffer-create-other-window "cus-edit" "\ -Create a buffer containing OPTIONS. -Optional NAME is the name of the buffer. -OPTIONS should be an alist of the form ((SYMBOL WIDGET)...), where -SYMBOL is a customization option, and WIDGET is a widget for editing -that option." nil nil) - -(autoload 'customize-browse "cus-edit" "\ -Create a tree browser for the customize hierarchy." t nil) - -(defcustom custom-file (if (boundp 'emacs-user-extension-dir) (concat "~" init-file-user emacs-user-extension-dir "options.el") "~/.emacs") "File used for storing customization information.\nIf you change this from the default \"~/.emacs\" you need to\nexplicitly load that file for the settings to take effect." :type 'file :group 'customize) - -(autoload 'customize-save-customized "cus-edit" "\ -Save all user options which have been set in this session." t nil) - -(autoload 'custom-save-all "cus-edit" "\ -Save all customizations in `custom-file'." nil nil) - -(autoload 'custom-menu-create "cus-edit" "\ -Create menu for customization group SYMBOL. -The menu is in a format applicable to `easy-menu-define'." nil nil) - -(autoload 'customize-menu-create "cus-edit" "\ -Return a customize menu for customization group SYMBOL. -If optional NAME is given, use that as the name of the menu. -Otherwise the menu will be named `Customize'. -The format is suitable for use with `easy-menu-define'." nil nil) - -;;;*** - -;;;### (autoloads (custom-set-faces custom-declare-face) "cus-face" "custom/cus-face.el") - -(autoload 'custom-declare-face "cus-face" "\ -Like `defface', but FACE is evaluated as a normal argument." nil nil) - -(autoload 'custom-set-faces "cus-face" "\ -Initialize faces according to user preferences. -The arguments should be a list where each entry has the form: - - (FACE SPEC [NOW]) - -SPEC will be stored as the saved value for FACE. If NOW is present -and non-nil, FACE will also be created according to SPEC. - -See `defface' for the format of SPEC." nil nil) - -;;;*** - -;;;### (autoloads (widget-minor-mode widget-browse-other-window widget-browse widget-browse-at) "wid-browse" "custom/wid-browse.el") - -(autoload 'widget-browse-at "wid-browse" "\ -Browse the widget under point." t nil) - -(autoload 'widget-browse "wid-browse" "\ -Create a widget browser for WIDGET." t nil) - -(autoload 'widget-browse-other-window "wid-browse" "\ -Show widget browser for WIDGET in other window." t nil) - -(autoload 'widget-minor-mode "wid-browse" "\ -Togle minor mode for traversing widgets. -With arg, turn widget mode on if and only if arg is positive." t nil) - -;;;*** - -;;;### (autoloads (widget-delete widget-create widget-prompt-value) "wid-edit" "custom/wid-edit.el") - -(autoload 'widget-prompt-value "wid-edit" "\ -Prompt for a value matching WIDGET, using PROMPT. -The current value is assumed to be VALUE, unless UNBOUND is non-nil." nil nil) - -(autoload 'widget-create "wid-edit" "\ -Create widget of TYPE. -The optional ARGS are additional keyword arguments." nil nil) - -(autoload 'widget-delete "wid-edit" "\ -Delete WIDGET." nil nil) - -;;;*** - -(provide 'custom-autoloads)
--- a/lisp/custom/cus-dep.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,182 +0,0 @@ -;;; cus-dep.el --- Find customization dependencies. -;; -;; Copyright (C) 1997 Free Software Foundation, Inc. -;; -;; Author: Per Abrahamsen <abraham@dina.kvl.dk>, then -;; Richar Stallman <rms@gnu.ai.mit.edu>, then -;; Hrvoje Niksic <hniksic@srce.hr> (rewritten for XEmacs) -;; Maintainer: Hrvoje Niksic <hniksic@srce.hr> -;; Keywords: internal - -;; 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 synched with FSF. - - -;;; Commentary: - -;; This file generates the custom-load files, loaded by cus-load.el. -;; The only entry point is `Custom-make-dependencies'. - -;; It works by scanning all the `.el' files in a directory, and -;; evaluates any `defcustom', `defgroup', or `defface' expression that -;; it finds. The symbol changed by this expression is stored to a -;; hash table as the hash key, file name being the value. - -;; After all the files have been examined, custom-loads.el is -;; generated by mapping all the atoms, and seeing if any of them -;; contains a `custom-group' property. This property is a list whose -;; each element's car is the "child" group symbol. If that property -;; is in the hash-table, the file name will be looked up from the -;; hash-table, and added to cusload-file. Because the hash-table is -;; cleared whenever we process a new directory, we cannot get confused -;; by custom-loads from another directory, or from a previous -;; installation. This is also why it is perfectly safe to have old -;; custom-loads around, and have them loaded by `cus-load.el' (as -;; invoked by `cus-edit.el'). - -;; A trivial, but useful optimization is that if cusload-file exists, -;; and no .el files in the directory are newer than cusload-file, it -;; will not be generated. This means that the directories where -;; nothing has changed will be skipped. - -;; The `custom-put' function, used by files generated by -;; `Custom-make-dependencies', is a specialized function that updates -;; a property (which must be a list of strings) with a new list of -;; strings, eliminating the duplicates. As it also adds an -;; appropriate entry to a custom hash-table, *do not* use it outside -;; of custom. Its inner workings can change anytime, without prior -;; notice. `custom-put' is defined in `cus-load.el'. - -;; Example: - -;; (custom-put 'foo 'custom-loads '("bar" "baz")) -;; (get 'foo 'custom-loads) -;; => ("bar" "baz") -;; -;; (custom-put 'foo 'custom-loads '("hmph" "baz" "quz")) -;; (get 'foo 'custom-loads) -;; => ("bar" "baz" "hmph" "qux") - -;; Obviously, this allows correct incremental loading of custom-load -;; files. This is not necessary under FSF (they use a simple `put'), -;; since they have only *one* file. With the advent of packages, we -;; cannot afford the same luxury. - - -;;; Code: - -(require 'cl) -(require 'widget) -(require 'cus-face) - -;; Don't change this, unless you plan to change the code in -;; cus-start.el, too. -(defconst cusload-base-file "custom-load.el") - -;; Be very careful when changing this function. It looks easy to -;; understand, but is in fact very easy to break. Be sure to read and -;; understand the commentary above! - -;;;###autoload -(defun Custom-make-dependencies (&optional subdirs) - "Extract custom dependencies from .el files in SUBDIRS. -SUBDIRS is a list of directories. If it is nil, the command-line -arguments are used. If it is a string, only that directory is -processed. This function is especially useful in batch mode. - -Batch usage: xemacs -batch -l cus-dep.el -f Custom-make-dependencies DIRS" - (interactive "DDirectory: ") - (and (stringp subdirs) - (setq subdirs (list subdirs))) - (or subdirs - ;; Usurp the command-line-args - (setq subdirs command-line-args-left - command-line-args-left nil)) - (setq subdirs (mapcar #'expand-file-name subdirs)) - (with-temp-buffer - (let ((enable-local-eval nil) - (hash (make-hash-table :test 'eq))) - (dolist (dir subdirs) - (princ (format "Processing %s\n" dir)) - (let ((cusload-file (expand-file-name cusload-base-file dir)) - (files (directory-files dir t "\\`[^=].*\\.el\\'"))) - ;; A trivial optimization: if no file in the directory is - ;; newer than custom-load.el, no need to do anything! - (if (and (file-exists-p cusload-file) - (dolist (file files t) - (when (file-newer-than-file-p file cusload-file) - (return nil)))) - (princ "(No changes need to be written)\n") - ;; Process directory - (dolist (file files) - (when (file-exists-p file) - (erase-buffer) - (insert-file-contents file) - (goto-char (point-min)) - (let ((name (file-name-sans-extension - (file-name-nondirectory file)))) - ;; Search for defcustom/defface/defgroup - ;; expressions, and evaluate them. - (ignore-errors - (while (re-search-forward - "^(defcustom\\|^(defface\\|^(defgroup" - nil t) - (beginning-of-line) - (let ((expr (read (current-buffer)))) - (eval expr) - ;; Hash the file of the affected symbol. - (setf (gethash (nth 1 expr) hash) name))))))) - (cond - ((zerop (hash-table-count hash)) - (princ "(No customization dependencies") - (when (file-exists-p cusload-file) - (princ (format ", deleting %s" cusload-file)) - (delete-file cusload-file)) - (princ ")\n")) - (t - (princ (format "Generating %s...\n" cusload-base-file)) - (with-temp-file cusload-file - (insert ";;; " cusload-base-file - " --- automatically extracted custom dependencies\n" - "\n\n;;; Code:\n\n") - (mapatoms - (lambda (sym) - (let ((members (get sym 'custom-group)) - item where found) - (when members - (while members - (setq item (car (car members)) - members (cdr members) - where (gethash item hash)) - (unless (or (null where) - (member where found)) - (if found - (insert " ") - (insert "(custom-add-loads '" - (symbol-name sym) " '(")) - (prin1 where (current-buffer)) - (push where found))) - (when found - (insert "))\n")))))) - (insert "\n;;; custom-load.el ends here\n")) - (clrhash hash))))))))) - -(provide 'cus-dep) - -;;; cus-dep.el ends here
--- a/lisp/custom/cus-edit.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,3234 +0,0 @@ -;;; cus-edit.el --- Tools for customizating Emacs and Lisp packages. -;; -;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. -;; -;; Author: Per Abrahamsen <abraham@dina.kvl.dk> -;; Maintainer: Hrvoje Niksic <hniksic@srce.hr> -;; Keywords: help, faces -;; Version: 1.9960-x -;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ - -;; 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. - -;;; Commentary: -;; -;; This file implements the code to create and edit customize buffers. -;; -;; See `custom.el'. - -;; No commands should have names starting with `custom-' because -;; that interferes with completion. Use `customize-' for commands -;; that the user will run with M-x, and `Custom-' for interactive commands. - - -;;; Code: - -(require 'cus-face) -(require 'wid-edit) -(require 'easymenu) - -(require 'cus-load) -(require 'cus-start) - -;; Huh? This looks dirty! -(put 'custom-define-hook 'custom-type 'hook) -(put 'custom-define-hook 'standard-value '(nil)) -(custom-add-to-group 'customize 'custom-define-hook 'custom-variable) - -;;; Customization Groups. - -(defgroup emacs nil - "Customization of the One True Editor." - :link '(custom-manual "(XEmacs)Top")) - -;; Most of these groups are stolen from `finder.el', -(defgroup editing nil - "Basic text editing facilities." - :group 'emacs) - -(defgroup abbrev nil - "Abbreviation handling, typing shortcuts, macros." - :tag "Abbreviations" - :group 'editing) - -(defgroup matching nil - "Various sorts of searching and matching." - :group 'editing) - -(defgroup emulations nil - "Emulations of other editors." - :group 'editing) - -(defgroup mouse nil - "Mouse support." - :group 'editing) - -(defgroup outlines nil - "Support for hierarchical outlining." - :group 'editing) - -(defgroup external nil - "Interfacing to external utilities." - :group 'emacs) - -(defgroup bib nil - "Code related to the `bib' bibliography processor." - :tag "Bibliography" - :group 'external) - -(defgroup processes nil - "Process, subshell, compilation, and job control support." - :group 'external - :group 'development) - -(defgroup programming nil - "Support for programming in other languages." - :group 'emacs) - -(defgroup languages nil - "Specialized modes for editing programming languages." - :group 'programming) - -(defgroup lisp nil - "Lisp support, including Emacs Lisp." - :group 'languages - :group 'development) - -(defgroup c nil - "Support for the C language and related languages." - :group 'languages) - -(defgroup tools nil - "Programming tools." - :group 'programming) - -(defgroup oop nil - "Support for object-oriented programming." - :group 'programming) - -(defgroup applications nil - "Applications written in Emacs." - :group 'emacs) - -(defgroup calendar nil - "Calendar and time management support." - :group 'applications) - -(defgroup mail nil - "Modes for electronic-mail handling." - :group 'applications) - -(defgroup news nil - "Support for netnews reading and posting." - :group 'applications) - -(defgroup games nil - "Games, jokes and amusements." - :group 'applications) - -(defgroup development nil - "Support for further development of Emacs." - :group 'emacs) - -(defgroup docs nil - "Support for Emacs documentation." - :group 'development) - -(defgroup extensions nil - "Emacs Lisp language extensions." - :group 'development) - -(defgroup internal nil - "Code for Emacs internals, build process, defaults." - :group 'development) - -(defgroup maint nil - "Maintenance aids for the Emacs development group." - :tag "Maintenance" - :group 'development) - -(defgroup environment nil - "Fitting Emacs with its environment." - :group 'emacs) - -(defgroup comm nil - "Communications, networking, remote access to files." - :tag "Communication" - :group 'environment) - -(defgroup hardware nil - "Support for interfacing with exotic hardware." - :group 'environment) - -(defgroup terminals nil - "Support for terminal types." - :group 'environment) - -(defgroup unix nil - "Front-ends/assistants for, or emulators of, UNIX features." - :group 'environment) - -(defgroup vms nil - "Support code for vms." - :group 'environment) - -(defgroup i18n nil - "Internationalization and alternate character-set support." - :group 'environment - :group 'editing) - -(defgroup x nil - "The X Window system." - :group 'environment) - -(defgroup frames nil - "Support for Emacs frames and window systems." - :group 'environment) - -(defgroup data nil - "Support editing files of data." - :group 'emacs) - -(defgroup files nil - "Support editing files." - :group 'emacs) - -(defgroup wp nil - "Word processing." - :group 'emacs) - -(defgroup tex nil - "Code related to the TeX formatter." - :group 'wp) - -(defgroup faces nil - "Support for multiple fonts." - :group 'emacs) - -(defgroup hypermedia nil - "Support for links between text or other media types." - :group 'emacs) - -(defgroup help nil - "Support for on-line help systems." - :group 'emacs) - -(defgroup local nil - "Code local to your site." - :group 'emacs) - -(defgroup customize '((widgets custom-group)) - "Customization of the Customization support." - :link '(custom-manual "(custom)Top") - :link '(url-link :tag "Development Page" - "http://www.dina.kvl.dk/~abraham/custom/") - :prefix "custom-" - :group 'help) - -(defgroup custom-faces nil - "Faces used by customize." - :group 'customize - :group 'faces) - -(defgroup custom-browse nil - "Control customize browser." - :prefix "custom-" - :group 'customize) - -(defgroup custom-buffer nil - "Control customize buffers." - :prefix "custom-" - :group 'customize) - -(defgroup custom-menu nil - "Control customize menus." - :prefix "custom-" - :group 'customize) - -(defgroup abbrev-mode nil - "Word abbreviations mode." - :group 'abbrev) - -(defgroup alloc nil - "Storage allocation and gc for GNU Emacs Lisp interpreter." - :tag "Storage Allocation" - :group 'internal) - -(defgroup undo nil - "Undoing changes in buffers." - :group 'editing) - -(defgroup modeline nil - "Content of the modeline." - :group 'environment) - -(defgroup fill nil - "Indenting and filling text." - :group 'editing) - -(defgroup editing-basics nil - "Most basic editing facilities." - :group 'editing) - -(defgroup display nil - "How characters are displayed in buffers." - :group 'environment) - -(defgroup execute nil - "Executing external commands." - :group 'processes) - -(defgroup installation nil - "The Emacs installation." - :group 'environment) - -(defgroup dired nil - "Directory editing." - :group 'environment) - -(defgroup limits nil - "Internal Emacs limits." - :group 'internal) - -(defgroup debug nil - "Debugging Emacs itself." - :group 'development) - -(defgroup minibuffer nil - "Controling the behaviour of the minibuffer." - :group 'environment) - -(defgroup keyboard nil - "Input from the keyboard." - :group 'environment) - -(defgroup mouse nil - "Input from the mouse." - :group 'environment) - -(defgroup menu nil - "Input from the menus." - :group 'environment) - -(defgroup auto-save nil - "Preventing accidential loss of data." - :group 'files) - -(defgroup processes-basics nil - "Basic stuff dealing with processes." - :group 'processes) - -(defgroup mule nil - "MULE Emacs internationalization." - :group 'i18n) - -(defgroup windows nil - "Windows within a frame." - :group 'environment) - - -;;; Utilities. - -(defun custom-quote (sexp) - "Quote SEXP iff it is not self quoting." - (if (or (memq sexp '(t nil)) - (keywordp sexp) - (eq (car-safe sexp) 'lambda) - (stringp sexp) - (numberp sexp) - (characterp sexp)) - sexp - (list 'quote sexp))) - -(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 \"\\|\") - -IF REGEXP is not a string, return it unchanged." - (if (stringp regexp) - (split-string regexp "\\\\|") - regexp)) - -(defun custom-variable-prompt () - ;; Code stolen from `help.el'. - "Prompt for a variable, defaulting to the variable at point. -Return a list suitable for use in `interactive'." - (let ((v (variable-at-point)) - (enable-recursive-minibuffers t) - val) - (setq val (completing-read - (if (symbolp v) - (format "Customize variable: (default %s) " v) - "Customize variable: ") - obarray (lambda (symbol) - (and (boundp symbol) - (or (get symbol 'custom-type) - (user-variable-p symbol)))))) - (list (if (equal val "") - (if (symbolp v) v nil) - (intern val))))) - -;; Here we take not only the actual groups, but the loads, too. -(defun custom-group-prompt (prompt) - "Read group from minibuffer." - (let ((completion-ignore-case t)) - (list (completing-read - prompt obarray - (lambda (symbol) - (or (get symbol 'custom-group) - (get symbol 'custom-loads))) - t)))) - -(defun custom-menu-filter (menu widget) - "Convert MENU to the form used by `widget-choose'. -MENU should be in the same format as `custom-variable-menu'. -WIDGET is the widget to apply the filter entries of MENU on." - (let ((result nil) - current name action filter) - (while menu - (setq current (car menu) - name (nth 0 current) - action (nth 1 current) - filter (nth 2 current) - menu (cdr menu)) - (if (or (null filter) (funcall filter widget)) - (push (cons name action) result) - (push name result))) - (nreverse result))) - - -;;; Unlispify. - -(defvar custom-prefix-list nil - "List of prefixes that should be ignored by `custom-unlispify'") - -(defcustom custom-unlispify-menu-entries t - "Display menu entries as words instead of symbols if non nil." - :group 'custom-menu - :type 'boolean) - -(defcustom custom-unlispify-remove-prefixes t - "Non-nil means remove group prefixes from option names in buffers and menus." - :group 'custom-menu - :type 'boolean) - -(defun custom-unlispify-menu-entry (symbol &optional no-suffix) - "Convert symbol into a menu entry." - (cond ((not custom-unlispify-menu-entries) - (symbol-name symbol)) - ((get symbol 'custom-tag) - (if no-suffix - (get symbol 'custom-tag) - (concat (get symbol 'custom-tag) "..."))) - (t - (with-current-buffer (get-buffer-create " *Custom-Work*") - (erase-buffer) - (princ symbol (current-buffer)) - (goto-char (point-min)) - (when (and (eq (get symbol 'custom-type) 'boolean) - (re-search-forward "-p\\'" nil t)) - (replace-match "" t t) - (goto-char (point-min))) - (when custom-unlispify-remove-prefixes - (let ((prefixes custom-prefix-list) - prefix) - (while prefixes - (setq prefix (car prefixes)) - (if (search-forward prefix (+ (point) (length prefix)) t) - (progn - (setq prefixes nil) - (delete-region (point-min) (point))) - (setq prefixes (cdr prefixes)))))) - (subst-char-in-region (point-min) (point-max) ?- ?\ t) - (capitalize-region (point-min) (point-max)) - (unless no-suffix - (goto-char (point-max)) - (insert "...")) - (buffer-string))))) - -(defcustom custom-unlispify-tag-names t - "Display tag names as words instead of symbols if non nil." - :group 'custom-buffer - :type 'boolean) - -(defun custom-unlispify-tag-name (symbol) - "Convert symbol into a menu entry." - (let ((custom-unlispify-menu-entries custom-unlispify-tag-names)) - (custom-unlispify-menu-entry symbol t))) - -(defun custom-prefix-add (symbol prefixes) - ;; Addd SYMBOL to list of ignored PREFIXES. - (cons (or (get symbol 'custom-prefix) - (concat (symbol-name symbol) "-")) - prefixes)) - - -;;; Guess. - -(defcustom custom-guess-name-alist - '(("-p\\'" boolean) - ("-hooks?\\'" hook) - ("-face\\'" face) - ("-file\\'" file) - ("-function\\'" function) - ("-functions\\'" (repeat function)) - ("-list\\'" (repeat sexp)) - ("-alist\\'" (repeat (cons sexp sexp)))) - "Alist of (MATCH TYPE). - -MATCH should be a regexp matching the name of a symbol, and TYPE should -be a widget suitable for editing the value of that symbol. The TYPE -of the first entry where MATCH matches the name of the symbol will be -used. - -This is used for guessing the type of variables not declared with -customize." - :type '(repeat (group (regexp :tag "Match") (sexp :tag "Type"))) - :group 'customize) - -(defcustom custom-guess-doc-alist - '(("\\`\\*?Non-nil " boolean)) - "Alist of (MATCH TYPE). - -MATCH should be a regexp matching a documentation string, and TYPE -should be a widget suitable for editing the value of a variable with -that documentation string. The TYPE of the first entry where MATCH -matches the name of the symbol will be used. - -This is used for guessing the type of variables not declared with -customize." - :type '(repeat (group (regexp :tag "Match") (sexp :tag "Type"))) - :group 'customize) - -(defun custom-guess-type (symbol) - "Guess a widget suitable for editing the value of SYMBOL. -This is done by matching SYMBOL with `custom-guess-name-alist' and -if that fails, the doc string with `custom-guess-doc-alist'." - (let ((name (symbol-name symbol)) - (names custom-guess-name-alist) - current found) - (while names - (setq current (car names) - names (cdr names)) - (when (string-match (nth 0 current) name) - (setq found (nth 1 current) - names nil))) - (unless found - (let ((doc (documentation-property symbol 'variable-documentation)) - (docs custom-guess-doc-alist)) - (when doc - (while docs - (setq current (car docs) - docs (cdr docs)) - (when (string-match (nth 0 current) doc) - (setq found (nth 1 current) - docs nil)))))) - found)) - - -;;; Sorting. - -(defcustom custom-browse-sort-alphabetically nil - "If non-nil, sort members of each customization group alphabetically." - :type 'boolean - :group 'custom-browse) - -(defcustom custom-browse-order-groups nil - "If non-nil, order group members within each customization group. -If `first', order groups before non-groups. -If `last', order groups after non-groups." - :type '(choice (const first) - (const last) - (const :tag "none" nil)) - :group 'custom-browse) - -(defcustom custom-browse-only-groups nil - "If non-nil, show group members only within each customization group." - :type 'boolean - :group 'custom-browse) - -(defcustom custom-buffer-sort-alphabetically nil - "If non-nil, sort members of each customization group alphabetically." - :type 'boolean - :group 'custom-buffer) - -(defcustom custom-buffer-order-groups 'last - "If non-nil, order group members within each customization group. -If `first', order groups before non-groups. -If `last', order groups after non-groups." - :type '(choice (const first) - (const last) - (const :tag "none" nil)) - :group 'custom-buffer) - -(defcustom custom-menu-sort-alphabetically nil - "If non-nil, sort members of each customization group alphabetically." - :type 'boolean - :group 'custom-menu) - -(defcustom custom-menu-order-groups 'first - "If non-nil, order group members within each customization group. -If `first', order groups before non-groups. -If `last', order groups after non-groups." - :type '(choice (const first) - (const last) - (const :tag "none" nil)) - :group 'custom-menu) - -(defun custom-sort-items (items sort-alphabetically order-groups) - "Return a sorted copy of ITEMS. -ITEMS should be a `custom-group' property. -If SORT-ALPHABETICALLY non-nil, sort alphabetically. -If ORDER-GROUPS is `first' order groups before non-groups, if `last' order -groups after non-groups, if nil do not order groups at all." - (sort (copy-sequence items) - (lambda (a b) - (let ((typea (nth 1 a)) (typeb (nth 1 b)) - (namea (symbol-name (nth 0 a))) (nameb (symbol-name (nth 0 b)))) - (cond ((not order-groups) - ;; Since we don't care about A and B order, maybe sort. - (when sort-alphabetically - (string-lessp namea nameb))) - ((eq typea 'custom-group) - ;; If B is also a group, maybe sort. Otherwise, order A and B. - (if (eq typeb 'custom-group) - (when sort-alphabetically - (string-lessp namea nameb)) - (eq order-groups 'first))) - ((eq typeb 'custom-group) - ;; Since A cannot be a group, order A and B. - (eq order-groups 'last)) - (sort-alphabetically - ;; Since A and B cannot be groups, sort. - (string-lessp namea nameb))))))) - - -;;; Custom Mode Commands. - -(defvar custom-options nil - "Customization widgets in the current buffer.") - -(defun Custom-set () - "Set changes in all modified options." - (interactive) - (let ((children custom-options)) - (mapc (lambda (child) - (when (eq (widget-get child :custom-state) 'modified) - (widget-apply child :custom-set))) - children))) - -(defun Custom-save () - "Set all modified group members and save them." - (interactive) - (let ((children custom-options)) - (mapc (lambda (child) - (when (memq (widget-get child :custom-state) '(modified set)) - (widget-apply child :custom-save))) - children)) - (custom-save-all)) - -(defvar custom-reset-menu - '(("Current" . Custom-reset-current) - ("Saved" . Custom-reset-saved) - ("Standard Settings" . Custom-reset-standard)) - "Alist of actions for the `Reset' button. -The key is a string containing the name of the action, the value is a -lisp function taking the widget as an element which will be called -when the action is chosen.") - -(defun custom-reset (event) - "Select item from reset menu." - (let* ((completion-ignore-case t) - (answer (widget-choose "Reset to" - custom-reset-menu - event))) - (if answer - (funcall answer)))) - -(defun Custom-reset-current (&rest ignore) - "Reset all modified group members to their current value." - (interactive) - (let ((children custom-options)) - (mapc (lambda (child) - (when (eq (widget-get child :custom-state) 'modified) - (widget-apply child :custom-reset-current))) - children))) - -(defun Custom-reset-saved (&rest ignore) - "Reset all modified or set group members to their saved value." - (interactive) - (let ((children custom-options)) - (mapc (lambda (child) - (when (eq (widget-get child :custom-state) 'modified) - (widget-apply child :custom-reset-saved))) - children))) - -(defun Custom-reset-standard (&rest ignore) - "Reset all modified, set, or saved group members to their standard settings." - (interactive) - (let ((children custom-options)) - (mapc (lambda (child) - (when (eq (widget-get child :custom-state) 'modified) - (widget-apply child :custom-reset-standard))) - children))) - - -;;; The Customize Commands - -(defun custom-prompt-variable (prompt-var prompt-val) - "Prompt for a variable and a value and return them as a list. -PROMPT-VAR is the prompt for the variable, and PROMPT-VAL is the -prompt for the value. The %s escape in PROMPT-VAL is replaced with -the name of the variable. - -If the variable has a `variable-interactive' property, that is used as if -it were the arg to `interactive' (which see) to interactively read the value. - -If the variable has a `custom-type' property, it must be a widget and the -`:prompt-value' property of that widget will be used for reading the value." - (let* ((var (read-variable prompt-var)) - (minibuffer-help-form '(describe-variable var))) - (list var - (let ((prop (get var 'variable-interactive)) - (type (get var 'custom-type)) - (prompt (format prompt-val var))) - (unless (listp type) - (setq type (list type))) - (cond (prop - ;; Use VAR's `variable-interactive' property - ;; as an interactive spec for prompting. - (call-interactively (list 'lambda '(arg) - (list 'interactive prop) - 'arg))) - (type - (widget-prompt-value type - prompt - (if (boundp var) - (symbol-value var)) - (not (boundp var)))) - (t - (eval-minibuffer prompt))))))) - -;;;###autoload -(defun customize-set-value (var val) - "Set VARIABLE to VALUE. VALUE is a Lisp object. - -If VARIABLE has a `variable-interactive' property, that is used as if -it were the arg to `interactive' (which see) to interactively read the value. - -If VARIABLE has a `custom-type' property, it must be a widget and the -`:prompt-value' property of that widget will be used for reading the value." - (interactive (custom-prompt-variable "Set variable: " - "Set %s to value: ")) - - (set var val)) - -;;;###autoload -(defun customize-set-variable (var val) - "Set the default for VARIABLE to VALUE. VALUE is a Lisp object. - -If VARIABLE has a `custom-set' property, that is used for setting -VARIABLE, otherwise `set-default' is used. - -The `customized-value' property of the VARIABLE will be set to a list -with a quoted VALUE as its sole list member. - -If VARIABLE has a `variable-interactive' property, that is used as if -it were the arg to `interactive' (which see) to interactively read the value. - -If VARIABLE has a `custom-type' property, it must be a widget and the -`:prompt-value' property of that widget will be used for reading the value. " - (interactive (custom-prompt-variable "Set variable: " - "Set customized value for %s to: ")) - (funcall (or (get var 'custom-set) 'set-default) var val) - (put var 'customized-value (list (custom-quote val)))) - -;;;###autoload -(defun customize-save-variable (var val) - "Set the default for VARIABLE to VALUE, and save it for future sessions. -If VARIABLE has a `custom-set' property, that is used for setting -VARIABLE, otherwise `set-default' is used. - -The `customized-value' property of the VARIABLE will be set to a list -with a quoted VALUE as its sole list member. - -If VARIABLE has a `variable-interactive' property, that is used as if -it were the arg to `interactive' (which see) to interactively read the value. - -If VARIABLE has a `custom-type' property, it must be a widget and the -`:prompt-value' property of that widget will be used for reading the value. " - (interactive (custom-prompt-variable "Set and ave variable: " - "Set and save value for %s as: ")) - (funcall (or (get var 'custom-set) 'set-default) var val) - (put var 'saved-value (list (custom-quote val))) - (custom-save-all)) - -;;;###autoload -(defun customize (group) - "Select a customization buffer which you can use to set user options. -User options are structured into \"groups\". -The default group is `Emacs'." - (interactive (custom-group-prompt - "Customize group: (default emacs) ")) - (when (stringp group) - (if (string-equal "" group) - (setq group 'emacs) - (setq group (intern group)))) - (let ((name (format "*Customize Group: %s*" - (custom-unlispify-tag-name group)))) - (if (get-buffer name) - (switch-to-buffer name) - (custom-buffer-create (list (list group 'custom-group)) - name - (concat " for group " - (custom-unlispify-tag-name group)))))) - -;;;###autoload -(defalias 'customize-group 'customize) - -;;;###autoload -(defun customize-other-window (symbol) - "Customize SYMBOL, which must be a customization group." - (interactive (custom-group-prompt - "Customize group: (default emacs) ")) - (when (stringp symbol) - (if (string-equal "" symbol) - (setq symbol 'emacs) - (setq symbol (intern symbol)))) - (custom-buffer-create-other-window - (list (list symbol 'custom-group)) - (format "*Customize Group: %s*" (custom-unlispify-tag-name symbol)))) - -;;;###autoload -(defalias 'customize-group-other-window 'customize-other-window) - -;;;###autoload -(defalias 'customize-option 'customize-variable) - -;;;###autoload -(defun customize-variable (symbol) - "Customize SYMBOL, which must be a user option variable." - (interactive (custom-variable-prompt)) - (custom-buffer-create (list (list symbol 'custom-variable)) - (format "*Customize Variable: %s*" - (custom-unlispify-tag-name symbol)))) - -;;;###autoload -(defalias 'customize-variable-other-window 'customize-option-other-window) - -;;;###autoload -(defun customize-option-other-window (symbol) - "Customize SYMBOL, which must be a user option variable. -Show the buffer in another window, but don't select it." - (interactive (custom-variable-prompt)) - (custom-buffer-create-other-window - (list (list symbol 'custom-variable)) - (format "*Customize Option: %s*" (custom-unlispify-tag-name symbol)))) - -;;;###autoload -(defun customize-face (&optional symbol) - "Customize SYMBOL, which should be a face name or nil. -If SYMBOL is nil, customize all faces." - (interactive (list (completing-read "Customize face: (default all) " - obarray 'find-face))) - (if (or (null symbol) (and (stringp symbol) (zerop (length symbol)))) - (custom-buffer-create (custom-sort-items - (mapcar (lambda (symbol) - (list symbol 'custom-face)) - (face-list)) - t nil) - "*Customize Faces*") - (when (stringp symbol) - (setq symbol (intern symbol))) - (unless (symbolp symbol) - (error "Should be a symbol %S" symbol)) - (custom-buffer-create (list (list symbol 'custom-face)) - (format "*Customize Face: %s*" - (custom-unlispify-tag-name symbol))))) - -;;;###autoload -(defun customize-face-other-window (&optional symbol) - "Show customization buffer for FACE in other window." - (interactive (list (completing-read "Customize face: " - obarray 'find-face))) - (if (or (null symbol) (and (stringp symbol) (zerop (length symbol)))) - () - (if (stringp symbol) - (setq symbol (intern symbol))) - (unless (symbolp symbol) - (error "Should be a symbol %S" symbol)) - (custom-buffer-create-other-window - (list (list symbol 'custom-face)) - (format "*Customize Face: %s*" (custom-unlispify-tag-name symbol))))) - -;;;###autoload -(defun customize-customized () - "Customize all user options set since the last save in this session." - (interactive) - (let ((found nil)) - (mapatoms (lambda (symbol) - (and (get symbol 'customized-face) - (find-face symbol) - (push (list symbol 'custom-face) found)) - (and (get symbol 'customized-value) - (boundp symbol) - (push (list symbol 'custom-variable) found)))) - (if (not found) - (error "No customized user options") - (custom-buffer-create (custom-sort-items found t nil) - "*Customize Customized*")))) - -;;;###autoload -(defun customize-saved () - "Customize all already saved user options." - (interactive) - (let ((found nil)) - (mapatoms (lambda (symbol) - (and (get symbol 'saved-face) - (find-face symbol) - (push (list symbol 'custom-face) found)) - (and (get symbol 'saved-value) - (boundp symbol) - (push (list symbol 'custom-variable) found)))) - (if (not found ) - (error "No saved user options") - (custom-buffer-create (custom-sort-items found t nil) - "*Customize Saved*")))) - -;;;###autoload -(defun customize-apropos (regexp &optional all) - "Customize all user options matching REGEXP. -If ALL is `options', include only options. -If ALL is `faces', include only faces. -If ALL is `groups', include only groups. -If ALL is t (interactively, with prefix arg), include options which are not -user-settable, as well as faces and groups." - (interactive "sCustomize regexp: \nP") - (let ((found nil)) - (mapatoms (lambda (symbol) - (when (string-match regexp (symbol-name symbol)) - (when (and (not (memq all '(faces options))) - (get symbol 'custom-group)) - (push (list symbol 'custom-group) found)) - (when (and (not (memq all '(options groups))) - (find-face symbol)) - (push (list symbol 'custom-face) found)) - (when (and (not (memq all '(groups faces))) - (boundp symbol) - (or (get symbol 'saved-value) - (get symbol 'standard-value) - (if (memq all '(nil options)) - (user-variable-p symbol) - (get symbol 'variable-documentation)))) - (push (list symbol 'custom-variable) found))))) - (if (not found) - (error "No matches") - (custom-buffer-create (custom-sort-items found t - custom-buffer-order-groups) - "*Customize Apropos*")))) - -;;;###autoload -(defun customize-apropos-options (regexp &optional arg) - "Customize all user options matching REGEXP. -With prefix arg, include options which are not user-settable." - (interactive "sCustomize regexp: \nP") - (customize-apropos regexp (or arg 'options))) - -;;;###autoload -(defun customize-apropos-faces (regexp) - "Customize all user faces matching REGEXP." - (interactive "sCustomize regexp: \n") - (customize-apropos regexp 'faces)) - -;;;###autoload -(defun customize-apropos-groups (regexp) - "Customize all user groups matching REGEXP." - (interactive "sCustomize regexp: \n") - (customize-apropos regexp 'groups)) - - -;;; Buffer. - -(defcustom custom-buffer-style 'links - "Control the presentation style for customization buffers. -The value should be a symbol, one of: - -brackets: groups nest within each other with big horizontal brackets. -links: groups have links to subgroups." - :type '(radio (const :tag "brackets: Groups nest within each others" brackets) - (const :tag "links: Group have links to subgroups" links)) - :group 'custom-buffer) - -(defcustom custom-buffer-indent 3 - "Number of spaces to indent nested groups." - :type 'integer - :group 'custom-buffer) - -;;;###autoload -(defun custom-buffer-create (options &optional name description) - "Create a buffer containing OPTIONS. -Optional NAME is the name of the buffer. -OPTIONS should be an alist of the form ((SYMBOL WIDGET)...), where -SYMBOL is a customization option, and WIDGET is a widget for editing -that option." - (unless name (setq name "*Customization*")) - (kill-buffer (get-buffer-create name)) - (switch-to-buffer (get-buffer-create name)) - (custom-buffer-create-internal options description)) - -;;;###autoload -(defun custom-buffer-create-other-window (options &optional name description) - "Create a buffer containing OPTIONS. -Optional NAME is the name of the buffer. -OPTIONS should be an alist of the form ((SYMBOL WIDGET)...), where -SYMBOL is a customization option, and WIDGET is a widget for editing -that option." - (unless name (setq name "*Customization*")) - (kill-buffer (get-buffer-create name)) - (let ((window (selected-window))) - (switch-to-buffer-other-window (get-buffer-create name)) - (custom-buffer-create-internal options description) - (select-window window))) - -(defcustom custom-reset-button-menu t - "If non-nil, only show a single reset button in customize buffers. -This button will have a menu with all three reset operations." - :type 'boolean - :group 'custom-buffer) - -(defconst custom-skip-messages 5) - -(defun custom-buffer-create-internal (options &optional description) - (message "Creating customization buffer...") - (custom-mode) - (widget-insert "This is a customization buffer") - (if description - (widget-insert description)) - (widget-insert ".\n\ -Type RET or click button2 on an active field to invoke its action. -Invoke ") - (widget-create 'info-link - :tag "Help" - :help-echo "Read the online help" - "(XEmacs)Easy Customization") - (widget-insert " for more information.\n\n") - (message "Creating customization buttons...") - (widget-insert "Operate on everything in this buffer:\n ") - (widget-create 'push-button - :tag "Set" - :tag-glyph '("set-up" "set-down") - :help-echo "\ -Make your editing in this buffer take effect for this session" - :action (lambda (widget &optional event) - (Custom-set))) - (widget-insert " ") - (widget-create 'push-button - :tag "Save" - :tag-glyph '("save-up" "save-down") - :help-echo "\ -Make your editing in this buffer take effect for future Emacs sessions" - :action (lambda (widget &optional event) - (Custom-save))) - (if custom-reset-button-menu - (progn - (widget-insert " ") - (widget-create 'push-button - :tag "Reset" - :tag-glyph '("reset-up" "reset-down") - :help-echo "Show a menu with reset operations" - :mouse-down-action (lambda (&rest junk) t) - :action (lambda (widget &optional event) - (custom-reset event)))) - (widget-insert " ") - (widget-create 'push-button - :tag "Reset" - :help-echo "\ -Reset all edited text in this buffer to reflect current values" - :action 'Custom-reset-current) - (widget-insert " ") - (widget-create 'push-button - :tag "Reset to Saved" - :help-echo "\ -Reset all values in this buffer to their saved settings" - :action 'Custom-reset-saved) - (widget-insert " ") - (widget-create 'push-button - :tag "Reset to Standard" - :help-echo "\ -Reset all values in this buffer to their standard settings" - :action 'Custom-reset-standard)) - (widget-insert " ") - (widget-create 'push-button - :tag "Done" - :tag-glyph '("done-up" "done-down") - :help-echo "Bury the buffer" - :action (lambda (widget &optional event) - (bury-buffer))) - (widget-insert "\n\n") - (message "Creating customization items...") - (setq custom-options - (if (= (length options) 1) - (mapcar (lambda (entry) - (widget-create (nth 1 entry) - :documentation-shown t - :custom-state 'unknown - :tag (custom-unlispify-tag-name - (nth 0 entry)) - :value (nth 0 entry))) - options) - (let ((count 0) - (length (length options))) - (mapcar (lambda (entry) - (prog2 - (display-message - 'progress - (format "Creating customization items %2d%%..." - (/ (* 100.0 count) length))) - (widget-create (nth 1 entry) - :tag (custom-unlispify-tag-name - (nth 0 entry)) - :value (nth 0 entry)) - (incf count) - (unless (eq (preceding-char) ?\n) - (widget-insert "\n")) - (widget-insert "\n"))) - options)))) - (unless (eq (preceding-char) ?\n) - (widget-insert "\n")) - (display-message 'progress - (format - "Creating customization items %2d%%...done" 100)) - (unless (eq custom-buffer-style 'tree) - (mapc 'custom-magic-reset custom-options)) - (message "Creating customization setup...") - (widget-setup) - (goto-char (point-min)) - (message "Creating customization buffer...done")) - - -;;; The Tree Browser. - -;;;###autoload -(defun customize-browse (&optional group) - "Create a tree browser for the customize hierarchy." - (interactive) - (unless group - (setq group 'emacs)) - (let ((name "*Customize Browser*")) - (kill-buffer (get-buffer-create name)) - (switch-to-buffer (get-buffer-create name))) - (custom-mode) - (widget-insert "\ -Square brackets show active fields; type RET or click button2 -on an active field to invoke its action. -Invoke [+] below to expand a group, and [-] to collapse an expanded group.\n") - (if custom-browse-only-groups - (widget-insert "\ -Invoke the [Group] button below to edit that item in another window.\n\n") - (widget-insert "Invoke the ") - (widget-create 'item - :format "%t" - :tag "[Group]" - :tag-glyph "folder") - (widget-insert ", ") - (widget-create 'item - :format "%t" - :tag "[Face]" - :tag-glyph "face") - (widget-insert ", and ") - (widget-create 'item - :format "%t" - :tag "[Option]" - :tag-glyph "option") - (widget-insert " buttons below to edit that -item in another window.\n\n")) - (let ((custom-buffer-style 'tree)) - (widget-create 'custom-group - :custom-last t - :custom-state 'unknown - :tag (custom-unlispify-tag-name group) - :value group)) - (goto-char (point-min))) - -(define-widget 'custom-browse-visibility 'item - "Control visibility of of items in the customize tree browser." - :format "%[[%t]%]" - :action 'custom-browse-visibility-action) - -(defun custom-browse-visibility-action (widget &rest ignore) - (let ((custom-buffer-style 'tree)) - (custom-toggle-parent widget))) - -(define-widget 'custom-browse-group-tag 'push-button - "Show parent in other window when activated." - :tag "Group" - :tag-glyph "folder" - :action 'custom-browse-group-tag-action) - -(defun custom-browse-group-tag-action (widget &rest ignore) - (let ((parent (widget-get widget :parent))) - (customize-group-other-window (widget-value parent)))) - -(define-widget 'custom-browse-variable-tag 'push-button - "Show parent in other window when activated." - :tag "Option" - :tag-glyph "option" - :action 'custom-browse-variable-tag-action) - -(defun custom-browse-variable-tag-action (widget &rest ignore) - (let ((parent (widget-get widget :parent))) - (customize-variable-other-window (widget-value parent)))) - -(define-widget 'custom-browse-face-tag 'push-button - "Show parent in other window when activated." - :tag "Face" - :tag-glyph "face" - :action 'custom-browse-face-tag-action) - -(defun custom-browse-face-tag-action (widget &rest ignore) - (let ((parent (widget-get widget :parent))) - (customize-face-other-window (widget-value parent)))) - -(defconst custom-browse-alist '((" " "space") - (" | " "vertical") - ("-\\ " "top") - (" |-" "middle") - (" `-" "bottom"))) - -(defun custom-browse-insert-prefix (prefix) - "Insert PREFIX. On XEmacs convert it to line graphics." - ;; ### Unfinished. - (if nil ; (string-match "XEmacs" emacs-version) - (progn - (insert "*") - (while (not (string-equal prefix "")) - (let ((entry (substring prefix 0 3))) - (setq prefix (substring prefix 3)) - (let ((overlay (make-overlay (1- (point)) (point) nil t nil)) - (name (nth 1 (assoc entry custom-browse-alist)))) - (overlay-put overlay 'end-glyph (widget-glyph-find name entry)) - (overlay-put overlay 'start-open t) - (overlay-put overlay 'end-open t))))) - (insert prefix))) - - -;;; Modification of Basic Widgets. -;; -;; We add extra properties to the basic widgets needed here. This is -;; fine, as long as we are careful to stay within out own namespace. -;; -;; We want simple widgets to be displayed by default, but complex -;; widgets to be hidden. - -(widget-put (get 'item 'widget-type) :custom-show t) -(widget-put (get 'editable-field 'widget-type) - :custom-show (lambda (widget value) - (let ((pp (pp-to-string value))) - (cond ((string-match "\n" pp) - nil) - ((> (length pp) 40) - nil) - (t t))))) -(widget-put (get 'menu-choice 'widget-type) :custom-show t) - -;;; The `custom-manual' Widget. - -(define-widget 'custom-manual 'info-link - "Link to the manual entry for this customization option." - :tag "Manual") - -;;; The `custom-magic' Widget. - -(defgroup custom-magic-faces nil - "Faces used by the magic button." - :group 'custom-faces - :group 'custom-buffer) - -(defface custom-invalid-face '((((class color)) - (:foreground "yellow" :background "red")) - (t - (:bold t :italic t :underline t))) - "Face used when the customize item is invalid." - :group 'custom-magic-faces) - -(defface custom-rogue-face '((((class color)) - (:foreground "pink" :background "black")) - (t - (:underline t))) - "Face used when the customize item is not defined for customization." - :group 'custom-magic-faces) - -(defface custom-modified-face '((((class color)) - (:foreground "white" :background "blue")) - (t - (:italic t :bold))) - "Face used when the customize item has been modified." - :group 'custom-magic-faces) - -(defface custom-set-face '((((class color)) - (:foreground "blue" :background "white")) - (t - (:italic t))) - "Face used when the customize item has been set." - :group 'custom-magic-faces) - -(defface custom-changed-face '((((class color)) - (:foreground "white" :background "blue")) - (t - (:italic t))) - "Face used when the customize item has been changed." - :group 'custom-magic-faces) - -(defface custom-saved-face '((t (:underline t))) - "Face used when the customize item has been saved." - :group 'custom-magic-faces) - -(defconst custom-magic-alist '((nil "#" underline "\ -uninitialized, you should not see this.") - (unknown "?" italic "\ -unknown, you should not see this.") - (hidden "-" default "\ -hidden, invoke \"Show\" button in the previous line to show." "\ -group now hidden, invoke the above \"Show\" button to show contents.") - (invalid "x" custom-invalid-face "\ -the value displayed for this %c is invalid and cannot be set.") - (modified "*" custom-modified-face "\ -you have edited the value as text, but you have not set the %c." "\ -you have edited something in this group, but not set it.") - (set "+" custom-set-face "\ -you have set this %c, but not saved it for future sessions." "\ -something in this group has been set, but not saved.") - (changed ":" custom-changed-face "\ -this %c has been changed outside the customize buffer." "\ -something in this group has been changed outside customize.") - (saved "!" custom-saved-face "\ -this %c has been set and saved." "\ -something in this group has been set and saved.") - (rogue "@" custom-rogue-face "\ -this %c has not been changed with customize." "\ -something in this group is not prepared for customization.") - (standard " " nil "\ -this %c is unchanged from its standard setting." "\ -visible group members are all at standard settings.")) - "Alist of customize option states. -Each entry is of the form (STATE MAGIC FACE ITEM-DESC [ GROUP-DESC ]), where - -STATE is one of the following symbols: - -`nil' - For internal use, should never occur. -`unknown' - For internal use, should never occur. -`hidden' - This item is not being displayed. -`invalid' - This item is modified, but has an invalid form. -`modified' - This item is modified, and has a valid form. -`set' - This item has been set but not saved. -`changed' - The current value of this item has been changed temporarily. -`saved' - This item is marked for saving. -`rogue' - This item has no customization information. -`standard' - This item is unchanged from the standard setting. - -MAGIC is a string used to present that state. - -FACE is a face used to present the state. - -ITEM-DESC is a string describing the state for options. - -GROUP-DESC is a string describing the state for groups. If this is -left out, ITEM-DESC will be used. - -The string %c in either description will be replaced with the -category of the item. These are `group'. `option', and `face'. - -The list should be sorted most significant first.") - -(defcustom custom-magic-show 'long - "If non-nil, show textual description of the state. -If `long', show a full-line description, not just one word." - :type '(choice (const :tag "no" nil) - (const short) - (const long)) - :group 'custom-buffer) - -(defcustom custom-magic-show-hidden '(option face) - "Control whether the State button is shown for hidden items. -The value should be a list with the custom categories where the State -button should be visible. Possible categories are `group', `option', -and `face'." - :type '(set (const group) (const option) (const face)) - :group 'custom-buffer) - -(defcustom custom-magic-show-button nil - "Show a \"magic\" button indicating the state of each customization option." - :type 'boolean - :group 'custom-buffer) - -(define-widget 'custom-magic 'default - "Show and manipulate state for a customization option." - :format "%v" - :action 'widget-parent-action - :notify 'ignore - :value-get 'ignore - :value-create 'custom-magic-value-create - :value-delete 'widget-children-value-delete) - -(defun widget-magic-mouse-down-action (widget &optional event) - ;; Non-nil unless hidden. - (not (eq (widget-get (widget-get (widget-get widget :parent) :parent) - :custom-state) - 'hidden))) - -(defun custom-magic-value-create (widget) - ;; Create compact status report for WIDGET. - (let* ((parent (widget-get widget :parent)) - (state (widget-get parent :custom-state)) - (hidden (eq state 'hidden)) - (entry (assq state custom-magic-alist)) - (magic (nth 1 entry)) - (face (nth 2 entry)) - (category (widget-get parent :custom-category)) - (text (or (and (eq category 'group) - (nth 4 entry)) - (nth 3 entry))) - (form (widget-get parent :custom-form)) - children) - (while (string-match "\\`\\(.*\\)%c\\(.*\\)\\'" text) - (setq text (concat (match-string 1 text) - (symbol-name category) - (match-string 2 text)))) - (when (and custom-magic-show - (or (not hidden) - (memq category custom-magic-show-hidden))) - (insert " ") - (when (and (eq category 'group) - (not (and (eq custom-buffer-style 'links) - (> (widget-get parent :custom-level) 1)))) - (insert-char ?\ (* custom-buffer-indent - (widget-get parent :custom-level)))) - (push (widget-create-child-and-convert - widget 'choice-item - :help-echo "Change the state of this item" - :format (if hidden "%t" "%[%t%]") - :button-prefix 'widget-push-button-prefix - :button-suffix 'widget-push-button-suffix - :mouse-down-action 'widget-magic-mouse-down-action - :tag "State" - ;;:tag-glyph (or hidden '("state-up" "state-down")) - ) - children) - (insert ": ") - (let ((start (point))) - (if (eq custom-magic-show 'long) - (insert text) - (insert (symbol-name state))) - (cond ((eq form 'lisp) - (insert " (lisp)")) - ((eq form 'mismatch) - (insert " (mismatch)"))) - (put-text-property start (point) 'face 'custom-state-face)) - (insert "\n")) - (when (and (eq category 'group) - (not (and (eq custom-buffer-style 'links) - (> (widget-get parent :custom-level) 1)))) - (insert-char ?\ (* custom-buffer-indent - (widget-get parent :custom-level)))) - (when custom-magic-show-button - (when custom-magic-show - (let ((indent (widget-get parent :indent))) - (when indent - (insert-char ?\ indent)))) - (push (widget-create-child-and-convert - widget 'choice-item - :mouse-down-action 'widget-magic-mouse-down-action - :button-face face - :button-prefix "" - :button-suffix "" - :help-echo "Change the state" - :format (if hidden "%t" "%[%t%]") - :tag (if (memq form '(lisp mismatch)) - (concat "(" magic ")") - (concat "[" magic "]"))) - children) - (insert " ")) - (widget-put widget :children children))) - -(defun custom-magic-reset (widget) - "Redraw the :custom-magic property of WIDGET." - (let ((magic (widget-get widget :custom-magic))) - (widget-value-set magic (widget-value magic)))) - -;;; The `custom' Widget. - -(defface custom-button-face '((t (:bold t))) - "Face used for buttons in customization buffers." - :group 'custom-faces) - -(defface custom-documentation-face nil - "Face used for documentation strings in customization buffers." - :group 'custom-faces) - -(defface custom-state-face '((((class color) - (background dark)) - (:foreground "lime green")) - (((class color) - (background light)) - (:foreground "dark green")) - (t nil)) - "Face used for State descriptions in the customize buffer." - :group 'custom-faces) - -(define-widget 'custom 'default - "Customize a user option." - :format "%v" - :convert-widget 'custom-convert-widget - :notify 'custom-notify - :custom-prefix "" - :custom-level 1 - :custom-state 'hidden - :documentation-property 'widget-subclass-responsibility - :value-create 'widget-subclass-responsibility - :value-delete 'widget-children-value-delete - :value-get 'widget-value-value-get - :validate 'widget-children-validate - :match (lambda (widget value) (symbolp value))) - -(defun custom-convert-widget (widget) - ;; Initialize :value and :tag from :args in WIDGET. - (let ((args (widget-get widget :args))) - (when args - (widget-put widget :value (widget-apply widget - :value-to-internal (car args))) - (widget-put widget :tag (custom-unlispify-tag-name (car args))) - (widget-put widget :args nil))) - widget) - -(defun custom-notify (widget &rest args) - "Keep track of changes." - (let ((state (widget-get widget :custom-state))) - (unless (eq state 'modified) - (unless (memq state '(nil unknown hidden)) - (widget-put widget :custom-state 'modified)) - (custom-magic-reset widget) - (apply 'widget-default-notify widget args)))) - -(defun custom-redraw (widget) - "Redraw WIDGET with current settings." - (let ((line (count-lines (point-min) (point))) - (column (current-column)) - (pos (point)) - (from (marker-position (widget-get widget :from))) - (to (marker-position (widget-get widget :to)))) - (save-excursion - (widget-value-set widget (widget-value widget)) - (custom-redraw-magic widget)) - (when (and (>= pos from) (<= pos to)) - (condition-case nil - (progn - (if (> column 0) - (goto-line line) - (goto-line (1+ line))) - (move-to-column column)) - (error nil))))) - -(defun custom-redraw-magic (widget) - "Redraw WIDGET state with current settings." - (while widget - (let ((magic (widget-get widget :custom-magic))) - (cond (magic - (widget-value-set magic (widget-value magic)) - (when (setq widget (widget-get widget :group)) - (custom-group-state-update widget))) - (t - (setq widget nil))))) - (widget-setup)) - -(defun custom-show (widget value) - "Non-nil if WIDGET should be shown with VALUE by default." - (let ((show (widget-get widget :custom-show))) - (cond ((null show) - nil) - ((eq t show) - t) - (t - (funcall show widget value))))) - -(defvar custom-load-recursion nil - "Hack to avoid recursive dependencies.") - -(defun custom-load-symbol (symbol) - "Load all dependencies for SYMBOL." - (unless custom-load-recursion - (let ((custom-load-recursion t) - (loads (get symbol 'custom-loads)) - load) - (while loads - (setq load (car loads) - loads (cdr loads)) - (cond ((symbolp load) - (condition-case nil - (require load) - (error nil))) - ;; Don't reload a file already loaded. - ((and (boundp 'preloaded-file-list) - (member load preloaded-file-list))) - ((assoc load load-history)) - ((assoc (locate-library load) load-history)) - (t - (condition-case nil - ;; Without this, we would load cus-edit recursively. - ;; We are still loading it when we call this, - ;; and it is not in load-history yet. - (or (equal load "cus-edit") - (load-library load)) - (error nil)))))))) - -(defun custom-load-widget (widget) - "Load all dependencies for WIDGET." - (custom-load-symbol (widget-value widget))) - -(defun custom-unloaded-symbol-p (symbol) - "Return non-nil if the dependencies of SYMBOL has not yet been loaded." - (let ((found nil) - (loads (get symbol 'custom-loads)) - load) - (while loads - (setq load (car loads) - loads (cdr loads)) - (cond ((symbolp load) - (unless (featurep load) - (setq found t))) - ((assoc load load-history)) - ((assoc (locate-library load) load-history) - ;; #### WTF??? - (message nil)) - (t - (setq found t)))) - found)) - -(defun custom-unloaded-widget-p (widget) - "Return non-nil if the dependencies of WIDGET has not yet been loaded." - (custom-unloaded-symbol-p (widget-value widget))) - -(defun custom-toggle-hide (widget) - "Toggle visibility of WIDGET." - (custom-load-widget widget) - (let ((state (widget-get widget :custom-state))) - (cond ((memq state '(invalid modified)) - (error "There are unset changes")) - ((eq state 'hidden) - (widget-put widget :custom-state 'unknown)) - (t - (widget-put widget :documentation-shown nil) - (widget-put widget :custom-state 'hidden))) - (custom-redraw widget) - (widget-setup))) - -(defun custom-toggle-parent (widget &rest ignore) - "Toggle visibility of parent of WIDGET." - (custom-toggle-hide (widget-get widget :parent))) - -(defun custom-add-see-also (widget &optional prefix) - "Add `See also ...' to WIDGET if there are any links. -Insert PREFIX first if non-nil." - (let* ((symbol (widget-get widget :value)) - (links (get symbol 'custom-links)) - (many (> (length links) 2)) - (buttons (widget-get widget :buttons)) - (indent (widget-get widget :indent))) - (when links - (when indent - (insert-char ?\ indent)) - (when prefix - (insert prefix)) - (insert "See also ") - (while links - (push (widget-create-child-and-convert widget (car links)) - buttons) - (setq links (cdr links)) - (cond ((null links) - (insert ".\n")) - ((null (cdr links)) - (if many - (insert ", and ") - (insert " and "))) - (t - (insert ", ")))) - (widget-put widget :buttons buttons)))) - -(defun custom-add-parent-links (widget &optional initial-string) - "Add \"Parent groups: ...\" to WIDGET if the group has parents. -The value if non-nil if any parents were found. -If INITIAL-STRING is non-nil, use that rather than \"Parent groups:\"." - (let ((name (widget-value widget)) - (type (widget-type widget)) - (buttons (widget-get widget :buttons)) - (start (point)) - found) - (insert (or initial-string "Parent groups:")) - (maphash (lambda (group ignore) - (let ((entry (assq name (get group 'custom-group)))) - (when (eq (nth 1 entry) type) - (insert " ") - (push (widget-create-child-and-convert - widget 'custom-group-link - :tag (custom-unlispify-tag-name group) - group) - buttons) - (setq found t)))) - custom-group-hash-table) - (widget-put widget :buttons buttons) - (if found - (insert "\n") - (delete-region start (point))) - found)) - -;;; The `custom-variable' Widget. - -(defface custom-variable-tag-face '((((class color) - (background dark)) - (:foreground "light blue" :underline t)) - (((class color) - (background light)) - (:foreground "blue" :underline t)) - (t (:underline t))) - "Face used for unpushable variable tags." - :group 'custom-faces) - -(defface custom-variable-button-face '((t (:underline t :bold t))) - "Face used for pushable variable tags." - :group 'custom-faces) - -(define-widget 'custom-variable 'custom - "Customize variable." - :format "%v" - :help-echo "Set or reset this variable" - :documentation-property 'variable-documentation - :custom-category 'option - :custom-state nil - :custom-menu 'custom-variable-menu-create - :custom-form 'edit - :value-create 'custom-variable-value-create - :action 'custom-variable-action - :custom-set 'custom-variable-set - :custom-save 'custom-variable-save - :custom-reset-current 'custom-redraw - :custom-reset-saved 'custom-variable-reset-saved - :custom-reset-standard 'custom-variable-reset-standard) - -(defun custom-variable-type (symbol) - "Return a widget suitable for editing the value of SYMBOL. -If SYMBOL has a `custom-type' property, use that. -Otherwise, look up symbol in `custom-guess-type-alist'." - (let* ((type (or (get symbol 'custom-type) - (and (not (get symbol 'standard-value)) - (custom-guess-type symbol)) - 'sexp)) - (options (get symbol 'custom-options)) - (tmp (if (listp type) - (copy-sequence type) - (list type)))) - (when options - (widget-put tmp :options options)) - tmp)) - -(defun custom-variable-value-create (widget) - "Here is where you edit the variables value." - (custom-load-widget widget) - (let* ((buttons (widget-get widget :buttons)) - (children (widget-get widget :children)) - (form (widget-get widget :custom-form)) - (state (widget-get widget :custom-state)) - (symbol (widget-get widget :value)) - (tag (widget-get widget :tag)) - (type (custom-variable-type symbol)) - (conv (widget-convert type)) - (get (or (get symbol 'custom-get) 'default-value)) - (prefix (widget-get widget :custom-prefix)) - (last (widget-get widget :custom-last)) - (value (if (default-boundp symbol) - (funcall get symbol) - (widget-get conv :value)))) - ;; If the widget is new, the child determine whether it is hidden. - (cond (state) - ((custom-show type value) - (setq state 'unknown)) - (t - (setq state 'hidden))) - ;; If we don't know the state, see if we need to edit it in lisp form. - (when (eq state 'unknown) - (unless (widget-apply conv :match value) - ;; (widget-apply (widget-convert type) :match value) - (setq form 'mismatch))) - ;; Now we can create the child widget. - (cond ((eq custom-buffer-style 'tree) - (insert prefix (if last " `--- " " |--- ")) - (push (widget-create-child-and-convert - widget 'custom-browse-variable-tag) - buttons) - (insert " " tag "\n") - (widget-put widget :buttons buttons)) - ((eq state 'hidden) - ;; Indicate hidden value. - (push (widget-create-child-and-convert - widget 'item - :format "%{%t%}: " - :sample-face 'custom-variable-tag-face - :tag tag - :parent widget) - buttons) - (push (widget-create-child-and-convert - widget 'visibility - :help-echo "Show the value of this option" - :action 'custom-toggle-parent - nil) - buttons)) - ((memq form '(lisp mismatch)) - ;; In lisp mode edit the saved value when possible. - (let* ((value (cond ((get symbol 'saved-value) - (car (get symbol 'saved-value))) - ((get symbol 'standard-value) - (car (get symbol 'standard-value))) - ((default-boundp symbol) - (custom-quote (funcall get symbol))) - (t - (custom-quote (widget-get conv :value)))))) - (insert (symbol-name symbol) ": ") - (push (widget-create-child-and-convert - widget 'visibility - :help-echo "Hide the value of this option" - :action 'custom-toggle-parent - t) - buttons) - (insert " ") - (push (widget-create-child-and-convert - widget 'sexp - :button-face 'custom-variable-button-face - :format "%v" - :tag (symbol-name symbol) - :parent widget - :value value) - children))) - (t - ;; Edit mode. - (let* ((format (widget-get type :format)) - tag-format value-format) - (unless (string-match ":" format) - (error "Bad format.")) - (setq tag-format (substring format 0 (match-end 0))) - (setq value-format (substring format (match-end 0))) - (push (widget-create-child-and-convert - widget 'item - :format tag-format - :action 'custom-tag-action - :help-echo "Change value of this option" - :mouse-down-action 'custom-tag-mouse-down-action - :button-face 'custom-variable-button-face - :sample-face 'custom-variable-tag-face - tag) - buttons) - (insert " ") - (push (widget-create-child-and-convert - widget 'visibility - :help-echo "Hide the value of this option" - :action 'custom-toggle-parent - t) - buttons) - (push (widget-create-child-and-convert - widget type - :format value-format - :value value) - children)))) - (unless (eq custom-buffer-style 'tree) - ;; Now update the state. - (unless (eq (preceding-char) ?\n) - (widget-insert "\n")) - (if (eq state 'hidden) - (widget-put widget :custom-state state) - (custom-variable-state-set widget)) - ;; Create the magic button. - (let ((magic (widget-create-child-and-convert - widget 'custom-magic nil))) - (widget-put widget :custom-magic magic) - (push magic buttons)) - ;; Update properties. - (widget-put widget :custom-form form) - (widget-put widget :buttons buttons) - (widget-put widget :children children) - ;; Insert documentation. - (widget-default-format-handler widget ?h) - ;; See also. - (unless (eq state 'hidden) - (when (eq (widget-get widget :custom-level) 1) - (custom-add-parent-links widget)) - (custom-add-see-also widget))))) - -(defun custom-tag-action (widget &rest args) - "Pass :action to first child of WIDGET's parent." - (apply 'widget-apply (car (widget-get (widget-get widget :parent) :children)) - :action args)) - -(defun custom-tag-mouse-down-action (widget &rest args) - "Pass :mouse-down-action to first child of WIDGET's parent." - (apply 'widget-apply (car (widget-get (widget-get widget :parent) :children)) - :mouse-down-action args)) - -(defun custom-variable-state-set (widget) - "Set the state of WIDGET." - (let* ((symbol (widget-value widget)) - (get (or (get symbol 'custom-get) 'default-value)) - (value (if (default-boundp symbol) - (funcall get symbol) - (widget-get widget :value))) - tmp - (state (cond ((setq tmp (get symbol 'customized-value)) - (if (condition-case nil - (equal value (eval (car tmp))) - (error nil)) - 'set - 'changed)) - ((setq tmp (get symbol 'saved-value)) - (if (condition-case nil - (equal value (eval (car tmp))) - (error nil)) - 'saved - 'changed)) - ((setq tmp (get symbol 'standard-value)) - (if (condition-case nil - (equal value (eval (car tmp))) - (error nil)) - 'standard - 'changed)) - (t 'rogue)))) - (widget-put widget :custom-state state))) - -(defvar custom-variable-menu - '(("Set for Current Session" custom-variable-set - (lambda (widget) - (eq (widget-get widget :custom-state) 'modified))) - ("Save for Future Sessions" custom-variable-save - (lambda (widget) - (memq (widget-get widget :custom-state) '(modified set changed rogue)))) - ("Reset to Current" custom-redraw - (lambda (widget) - (and (default-boundp (widget-value widget)) - (memq (widget-get widget :custom-state) '(modified changed))))) - ("Reset to Saved" custom-variable-reset-saved - (lambda (widget) - (and (get (widget-value widget) 'saved-value) - (memq (widget-get widget :custom-state) - '(modified set changed rogue))))) - ("Reset to Standard Settings" custom-variable-reset-standard - (lambda (widget) - (and (get (widget-value widget) 'standard-value) - (memq (widget-get widget :custom-state) - '(modified set changed saved rogue))))) - ("---" ignore ignore) - ("Don't show as Lisp expression" custom-variable-edit - (lambda (widget) - (eq (widget-get widget :custom-form) 'lisp))) - ("Show as Lisp expression" custom-variable-edit-lisp - (lambda (widget) - (eq (widget-get widget :custom-form) 'edit)))) - "Alist of actions for the `custom-variable' widget. -Each entry has the form (NAME ACTION FILTER) where NAME is the name of -the menu entry, ACTION is the function to call on the widget when the -menu is selected, and FILTER is a predicate which takes a `custom-variable' -widget as an argument, and returns non-nil if ACTION is valid on that -widget. If FILTER is nil, ACTION is always valid.") - -(defun custom-variable-action (widget &optional event) - "Show the menu for `custom-variable' WIDGET. -Optional EVENT is the location for the menu." - (if (eq (widget-get widget :custom-state) 'hidden) - (custom-toggle-hide widget) - (unless (eq (widget-get widget :custom-state) 'modified) - (custom-variable-state-set widget)) - ;; Redrawing magic also depresses the state glyph. - ;(custom-redraw-magic widget) - (let* ((completion-ignore-case t) - (answer (widget-choose (concat "Operation on " - (custom-unlispify-tag-name - (widget-get widget :value))) - (custom-menu-filter custom-variable-menu - widget) - event))) - (if answer - (funcall answer widget))))) - -(defun custom-variable-edit (widget) - "Edit value of WIDGET." - (widget-put widget :custom-state 'unknown) - (widget-put widget :custom-form 'edit) - (custom-redraw widget)) - -(defun custom-variable-edit-lisp (widget) - "Edit the lisp representation of the value of WIDGET." - (widget-put widget :custom-state 'unknown) - (widget-put widget :custom-form 'lisp) - (custom-redraw widget)) - -(defun custom-variable-set (widget) - "Set the current value for the variable being edited by WIDGET." - (let* ((form (widget-get widget :custom-form)) - (state (widget-get widget :custom-state)) - (child (car (widget-get widget :children))) - (symbol (widget-value widget)) - (set (or (get symbol 'custom-set) 'set-default)) - val) - (cond ((eq state 'hidden) - (error "Cannot set hidden variable.")) - ((setq val (widget-apply child :validate)) - (goto-char (widget-get val :from)) - (error "%s" (widget-get val :error))) - ((memq form '(lisp mismatch)) - (funcall set symbol (eval (setq val (widget-value child)))) - (put symbol 'customized-value (list val))) - (t - (funcall set symbol (setq val (widget-value child))) - (put symbol 'customized-value (list (custom-quote val))))) - (custom-variable-state-set widget) - (custom-redraw-magic widget))) - -(defun custom-variable-save (widget) - "Set and save the value for the variable being edited by WIDGET." - (let* ((form (widget-get widget :custom-form)) - (state (widget-get widget :custom-state)) - (child (car (widget-get widget :children))) - (symbol (widget-value widget)) - (set (or (get symbol 'custom-set) 'set-default)) - val) - (cond ((eq state 'hidden) - (error "Cannot set hidden variable.")) - ((setq val (widget-apply child :validate)) - (goto-char (widget-get val :from)) - (error "%s" (widget-get val :error))) - ((memq form '(lisp mismatch)) - (put symbol 'saved-value (list (widget-value child))) - (funcall set symbol (eval (widget-value child)))) - (t - (put symbol - 'saved-value (list (custom-quote (widget-value - child)))) - (funcall set symbol (widget-value child)))) - (put symbol 'customized-value nil) - (custom-save-all) - (custom-variable-state-set widget) - (custom-redraw-magic widget))) - -(defun custom-variable-reset-saved (widget) - "Restore the saved value for the variable being edited by WIDGET." - (let* ((symbol (widget-value widget)) - (set (or (get symbol 'custom-set) 'set-default))) - (if (get symbol 'saved-value) - (condition-case nil - (funcall set symbol (eval (car (get symbol 'saved-value)))) - (error nil)) - (error "No saved value for %s" symbol)) - (put symbol 'customized-value nil) - (widget-put widget :custom-state 'unknown) - (custom-redraw widget))) - -(defun custom-variable-reset-standard (widget) - "Restore the standard setting for the variable being edited by WIDGET." - (let* ((symbol (widget-value widget)) - (set (or (get symbol 'custom-set) 'set-default))) - (if (get symbol 'standard-value) - (funcall set symbol (eval (car (get symbol 'standard-value)))) - (error "No standard setting known for %S" symbol)) - (put symbol 'customized-value nil) - (when (get symbol 'saved-value) - (put symbol 'saved-value nil) - (custom-save-all)) - (widget-put widget :custom-state 'unknown) - (custom-redraw widget))) - -;;; The `custom-face-edit' Widget. - -(define-widget 'custom-face-edit 'checklist - "Edit face attributes." - :format "%t: %v" - :tag "Attributes" - :extra-offset 12 - :button-args '(:help-echo "Control whether this attribute have any effect") - :args (mapcar (lambda (att) - (list 'group - :inline t - :sibling-args (widget-get (nth 1 att) :sibling-args) - (list 'const :format "" :value (nth 0 att)) - (nth 1 att))) - custom-face-attributes)) - -;;; The `custom-display' Widget. - -(define-widget 'custom-display 'menu-choice - "Select a display type." - :tag "Display" - :value t - :help-echo "Specify frames where the face attributes should be used" - :args '((const :tag "all" t) - (checklist - :offset 0 - :extra-offset 9 - :args ((group :sibling-args (:help-echo "\ -Only match the specified window systems") - (const :format "Type: " - type) - (checklist :inline t - :offset 0 - (const :format "X " - :sibling-args (:help-echo "\ -The X11 Window System") - x) - (const :format "PM " - :sibling-args (:help-echo "\ -OS/2 Presentation Manager") - pm) - (const :format "Win32 " - :sibling-args (:help-echo "\ -Windows NT/95/97") - win32) - (const :format "DOS " - :sibling-args (:help-echo "\ -Plain MS-DOS") - pc) - (const :format "TTY%n" - :sibling-args (:help-echo "\ -Plain text terminals") - tty))) - (group :sibling-args (:help-echo "\ -Only match the frames with the specified color support") - (const :format "Class: " - class) - (checklist :inline t - :offset 0 - (const :format "Color " - :sibling-args (:help-echo "\ -Match color frames") - color) - (const :format "Grayscale " - :sibling-args (:help-echo "\ -Match grayscale frames") - grayscale) - (const :format "Monochrome%n" - :sibling-args (:help-echo "\ -Match frames with no color support") - mono))) - (group :sibling-args (:help-echo "\ -Only match frames with the specified intensity") - (const :format "\ -Background brightness: " - background) - (checklist :inline t - :offset 0 - (const :format "Light " - :sibling-args (:help-echo "\ -Match frames with light backgrounds") - light) - (const :format "Dark\n" - :sibling-args (:help-echo "\ -Match frames with dark backgrounds") - dark))))))) - -;;; The `custom-face' Widget. - -(defface custom-face-tag-face '((t (:underline t))) - "Face used for face tags." - :group 'custom-faces) - -(define-widget 'custom-face 'custom - "Customize face." - :sample-face 'custom-face-tag-face - :help-echo "Set or reset this face" - :documentation-property '(lambda (face) - (face-doc-string face)) - :value-create 'custom-face-value-create - :action 'custom-face-action - :custom-category 'face - :custom-form 'selected - :custom-set 'custom-face-set - :custom-save 'custom-face-save - :custom-reset-current 'custom-redraw - :custom-reset-saved 'custom-face-reset-saved - :custom-reset-standard 'custom-face-reset-standard - :custom-menu 'custom-face-menu-create) - -(define-widget 'custom-face-all 'editable-list - "An editable list of display specifications and attributes." - :entry-format "%i %d %v" - :insert-button-args '(:help-echo "Insert new display specification here") - :append-button-args '(:help-echo "Append new display specification here") - :delete-button-args '(:help-echo "Delete this display specification") - :args '((group :format "%v" custom-display custom-face-edit))) - -(defconst custom-face-all (widget-convert 'custom-face-all) - "Converted version of the `custom-face-all' widget.") - -(define-widget 'custom-display-unselected 'item - "A display specification that doesn't match the selected display." - :match 'custom-display-unselected-match) - -(defun custom-display-unselected-match (widget value) - "Non-nil if VALUE is an unselected display specification." - (not (face-spec-set-match-display value (selected-frame)))) - -(define-widget 'custom-face-selected 'group - "Edit the attributes of the selected display in a face specification." - :args '((repeat :format "" - :inline t - (group custom-display-unselected sexp)) - (group (sexp :format "") custom-face-edit) - (repeat :format "" - :inline t - sexp))) - -(defconst custom-face-selected (widget-convert 'custom-face-selected) - "Converted version of the `custom-face-selected' widget.") - -(defun custom-face-value-create (widget) - "Create a list of the display specifications for WIDGET." - (let ((buttons (widget-get widget :buttons)) - (symbol (widget-get widget :value)) - (tag (widget-get widget :tag)) - (state (widget-get widget :custom-state)) - (begin (point)) - (is-last (widget-get widget :custom-last)) - (prefix (widget-get widget :custom-prefix))) - (unless tag - (setq tag (prin1-to-string symbol))) - (cond ((eq custom-buffer-style 'tree) - (insert prefix (if is-last " `--- " " |--- ")) - (push (widget-create-child-and-convert - widget 'custom-browse-face-tag) - buttons) - (insert " " tag "\n") - (widget-put widget :buttons buttons)) - (t - ;; Create tag. - (insert tag) - (if (eq custom-buffer-style 'face) - (insert " ") - (widget-specify-sample widget begin (point)) - (insert ": ")) - ;; Sample. - (and (not (find-face symbol)) - ;; XEmacs cannot display uninitialized faces. - (make-face symbol)) - (push (widget-create-child-and-convert widget 'item - :format "(%{%t%})" - :sample-face symbol - :tag "sample") - buttons) - ;; Visibility. - (insert " ") - (push (widget-create-child-and-convert - widget 'visibility - :help-echo "Hide or show this face" - :action 'custom-toggle-parent - (not (eq state 'hidden))) - buttons) - ;; Magic. - (insert "\n") - (let ((magic (widget-create-child-and-convert - widget 'custom-magic nil))) - (widget-put widget :custom-magic magic) - (push magic buttons)) - ;; Update buttons. - (widget-put widget :buttons buttons) - ;; Insert documentation. - (widget-default-format-handler widget ?h) - ;; See also. - (unless (eq state 'hidden) - (when (eq (widget-get widget :custom-level) 1) - (custom-add-parent-links widget)) - (custom-add-see-also widget)) - ;; Editor. - (unless (eq (preceding-char) ?\n) - (insert "\n")) - (unless (eq state 'hidden) - (message "Creating face editor...") - (custom-load-widget widget) - (let* ((symbol (widget-value widget)) - (spec (or (get symbol 'saved-face) - (get symbol 'face-defface-spec) - ;; Attempt to construct it. - (list (list t (face-custom-attributes-get - symbol (selected-frame)))))) - (form (widget-get widget :custom-form)) - (indent (widget-get widget :indent)) - (edit (widget-create-child-and-convert - widget - (cond ((and (eq form 'selected) - (widget-apply custom-face-selected - :match spec)) - (when indent (insert-char ?\ indent)) - 'custom-face-selected) - ((and (not (eq form 'lisp)) - (widget-apply custom-face-all - :match spec)) - 'custom-face-all) - (t - (when indent (insert-char ?\ indent)) - 'sexp)) - :value spec))) - (custom-face-state-set widget) - (widget-put widget :children (list edit))) - (message "Creating face editor...done")))))) - -(defvar custom-face-menu - '(("Set for Current Session" custom-face-set) - ("Save for Future Sessions" custom-face-save) - ("Reset to Saved" custom-face-reset-saved - (lambda (widget) - (get (widget-value widget) 'saved-face))) - ("Reset to Standard Setting" custom-face-reset-standard - (lambda (widget) - (get (widget-value widget) 'face-defface-spec))) - ("---" ignore ignore) - ("Show all display specs" custom-face-edit-all - (lambda (widget) - (not (eq (widget-get widget :custom-form) 'all)))) - ("Just current attributes" custom-face-edit-selected - (lambda (widget) - (not (eq (widget-get widget :custom-form) 'selected)))) - ("Show as Lisp expression" custom-face-edit-lisp - (lambda (widget) - (not (eq (widget-get widget :custom-form) 'lisp))))) - "Alist of actions for the `custom-face' widget. -Each entry has the form (NAME ACTION FILTER) where NAME is the name of -the menu entry, ACTION is the function to call on the widget when the -menu is selected, and FILTER is a predicate which takes a `custom-face' -widget as an argument, and returns non-nil if ACTION is valid on that -widget. If FILTER is nil, ACTION is always valid.") - -(defun custom-face-edit-selected (widget) - "Edit selected attributes of the value of WIDGET." - (widget-put widget :custom-state 'unknown) - (widget-put widget :custom-form 'selected) - (custom-redraw widget)) - -(defun custom-face-edit-all (widget) - "Edit all attributes of the value of WIDGET." - (widget-put widget :custom-state 'unknown) - (widget-put widget :custom-form 'all) - (custom-redraw widget)) - -(defun custom-face-edit-lisp (widget) - "Edit the lisp representation of the value of WIDGET." - (widget-put widget :custom-state 'unknown) - (widget-put widget :custom-form 'lisp) - (custom-redraw widget)) - -(defun custom-face-state-set (widget) - "Set the state of WIDGET." - (let ((symbol (widget-value widget))) - (widget-put widget :custom-state (cond ((get symbol 'customized-face) - 'set) - ((get symbol 'saved-face) - 'saved) - ((get symbol 'face-defface-spec) - 'standard) - (t - 'rogue))))) - -(defun custom-face-action (widget &optional event) - "Show the menu for `custom-face' WIDGET. -Optional EVENT is the location for the menu." - (if (eq (widget-get widget :custom-state) 'hidden) - (custom-toggle-hide widget) - (let* ((completion-ignore-case t) - (symbol (widget-get widget :value)) - (answer (widget-choose (concat "Operation on " - (custom-unlispify-tag-name symbol)) - (custom-menu-filter custom-face-menu - widget) - event))) - (if answer - (funcall answer widget))))) - -(defun custom-face-set (widget) - "Make the face attributes in WIDGET take effect." - (let* ((symbol (widget-value widget)) - (child (car (widget-get widget :children))) - (value (widget-value child))) - (put symbol 'customized-face value) - (face-spec-set symbol value) - (custom-face-state-set widget) - (custom-redraw-magic widget))) - -(defun custom-face-save (widget) - "Make the face attributes in WIDGET default." - (let* ((symbol (widget-value widget)) - (child (car (widget-get widget :children))) - (value (widget-value child))) - (face-spec-set symbol value) - (put symbol 'saved-face value) - (put symbol 'customized-face nil) - (custom-face-state-set widget) - (custom-redraw-magic widget))) - -(defun custom-face-reset-saved (widget) - "Restore WIDGET to the face's default attributes." - (let* ((symbol (widget-value widget)) - (child (car (widget-get widget :children))) - (value (get symbol 'saved-face))) - (unless value - (error "No saved value for this face")) - (put symbol 'customized-face nil) - (face-spec-set symbol value) - (widget-value-set child value) - (custom-face-state-set widget) - (custom-redraw-magic widget))) - -(defun custom-face-reset-standard (widget) - "Restore WIDGET to the face's standard settings." - (let* ((symbol (widget-value widget)) - (child (car (widget-get widget :children))) - (value (get symbol 'face-defface-spec))) - (unless value - (error "No standard setting for this face")) - (put symbol 'customized-face nil) - (when (get symbol 'saved-face) - (put symbol 'saved-face nil) - (custom-save-all)) - (face-spec-set symbol value) - (widget-value-set child value) - (custom-face-state-set widget) - (custom-redraw-magic widget))) - -;;; The `face' Widget. - -(define-widget 'face 'default - "Select and customize a face." - :convert-widget 'widget-value-convert-widget - :button-prefix 'widget-push-button-prefix - :button-suffix 'widget-push-button-suffix - :format "%t: %[select face%] %v" - :tag "Face" - :value 'default - :value-create 'widget-face-value-create - :value-delete 'widget-face-value-delete - :value-get 'widget-value-value-get - :validate 'widget-children-validate - :action 'widget-face-action - :match (lambda (widget value) (symbolp value))) - -(defun widget-face-value-create (widget) - ;; Create a `custom-face' child. - (let* ((symbol (widget-value widget)) - (custom-buffer-style 'face) - (child (widget-create-child-and-convert - widget 'custom-face - :custom-level nil - :value symbol))) - (custom-magic-reset child) - (setq custom-options (cons child custom-options)) - (widget-put widget :children (list child)))) - -(defun widget-face-value-delete (widget) - ;; Remove the child from the options. - (let ((child (car (widget-get widget :children)))) - (setq custom-options (delq child custom-options)) - (widget-children-value-delete widget))) - -(defvar face-history nil - "History of entered face names.") - -(defun widget-face-action (widget &optional event) - "Prompt for a face." - (let ((answer (completing-read "Face: " - (mapcar (lambda (face) - (list (symbol-name face))) - (face-list)) - nil nil nil - 'face-history))) - (unless (zerop (length answer)) - (widget-value-set widget (intern answer)) - (widget-apply widget :notify widget event) - (widget-setup)))) - -;;; The `hook' Widget. - -(define-widget 'hook 'list - "A emacs lisp hook" - :value-to-internal (lambda (widget value) - (if (symbolp value) - (list value) - value)) - :match (lambda (widget value) - (or (symbolp value) - (widget-group-match widget value))) - :convert-widget 'custom-hook-convert-widget - :tag "Hook") - -(defun custom-hook-convert-widget (widget) - ;; Handle `:custom-options'. - (let* ((options (widget-get widget :options)) - (other `(editable-list :inline t - :entry-format "%i %d%v" - (function :format " %v"))) - (args (if options - (list `(checklist :inline t - ,@(mapcar (lambda (entry) - `(function-item ,entry)) - options)) - other) - (list other)))) - (widget-put widget :args args) - widget)) - -;;; The `custom-group-link' Widget. - -(define-widget 'custom-group-link 'link - "Show parent in other window when activated." - :help-echo 'custom-group-link-help-echo - :action 'custom-group-link-action) - -(defun custom-group-link-help-echo (widget) - (concat "Create customization buffer for the `" - (custom-unlispify-tag-name (widget-value widget)) - "' group")) - -(defun custom-group-link-action (widget &rest ignore) - (customize-group (widget-value widget))) - -;;; The `custom-group' Widget. - -(defcustom custom-group-tag-faces nil - ;; In XEmacs, this ought to play games with font size. - "Face used for group tags. -The first member is used for level 1 groups, the second for level 2, -and so forth. The remaining group tags are shown with -`custom-group-tag-face'." - :type '(repeat face) - :group 'custom-faces) - -(defface custom-group-tag-face-1 '((((class color) - (background dark)) - (:foreground "pink" :underline t)) - (((class color) - (background light)) - (:foreground "red" :underline t)) - (t (:underline t))) - "Face used for group tags.") - -(defface custom-group-tag-face '((((class color) - (background dark)) - (:foreground "light blue" :underline t)) - (((class color) - (background light)) - (:foreground "blue" :underline t)) - (t (:underline t))) - "Face used for low level group tags." - :group 'custom-faces) - -(define-widget 'custom-group 'custom - "Customize group." - :format "%v" - :sample-face-get 'custom-group-sample-face-get - :documentation-property 'group-documentation - :help-echo "Set or reset all members of this group" - :value-create 'custom-group-value-create - :action 'custom-group-action - :custom-category 'group - :custom-set 'custom-group-set - :custom-save 'custom-group-save - :custom-reset-current 'custom-group-reset-current - :custom-reset-saved 'custom-group-reset-saved - :custom-reset-standard 'custom-group-reset-standard - :custom-menu 'custom-group-menu-create) - -(defun custom-group-sample-face-get (widget) - ;; Use :sample-face. - (or (nth (1- (widget-get widget :custom-level)) custom-group-tag-faces) - 'custom-group-tag-face)) - -(define-widget 'custom-group-visibility 'visibility - "An indicator and manipulator for hidden group contents." - :create 'custom-group-visibility-create) - -(defun custom-group-visibility-create (widget) - (let ((visible (widget-value widget))) - (if visible - (insert "--------"))) - (widget-default-create widget)) - -(defun custom-group-members (symbol groups-only) - "Return SYMBOL's custom group members. -If GROUPS-ONLY non-nil, return only those members that are groups." - (if (not groups-only) - (get symbol 'custom-group) - (let (members) - (dolist (entry (get symbol 'custom-group) (nreverse members)) - (when (eq (nth 1 entry) 'custom-group) - (push entry members)))))) - -(defun custom-group-value-create (widget) - "Insert a customize group for WIDGET in the current buffer." - (let* ((state (widget-get widget :custom-state)) - (level (widget-get widget :custom-level)) - ;; (indent (widget-get widget :indent)) - (prefix (widget-get widget :custom-prefix)) - (buttons (widget-get widget :buttons)) - (tag (widget-get widget :tag)) - (symbol (widget-value widget)) - (members (custom-group-members symbol - (and (eq custom-buffer-style 'tree) - custom-browse-only-groups)))) - (cond ((and (eq custom-buffer-style 'tree) - (eq state 'hidden) - (or members (custom-unloaded-widget-p widget))) - (custom-browse-insert-prefix prefix) - (push (widget-create-child-and-convert - widget 'custom-browse-visibility - ;; :tag-glyph "plus" - :tag "+") - buttons) - (insert "-- ") - ;; (widget-glyph-insert nil "-- " "horizontal") - (push (widget-create-child-and-convert - widget 'custom-browse-group-tag) - buttons) - (insert " " tag "\n") - (widget-put widget :buttons buttons)) - ((and (eq custom-buffer-style 'tree) - (zerop (length members))) - (custom-browse-insert-prefix prefix) - (insert "[ ]-- ") - ;; (widget-glyph-insert nil "[ ]" "empty") - ;; (widget-glyph-insert nil "-- " "horizontal") - (push (widget-create-child-and-convert - widget 'custom-browse-group-tag) - buttons) - (insert " " tag "\n") - (widget-put widget :buttons buttons)) - ((eq custom-buffer-style 'tree) - (custom-browse-insert-prefix prefix) - (custom-load-widget widget) - (if (zerop (length members)) - (progn - (custom-browse-insert-prefix prefix) - (insert "[ ]-- ") - ;; (widget-glyph-insert nil "[ ]" "empty") - ;; (widget-glyph-insert nil "-- " "horizontal") - (push (widget-create-child-and-convert - widget 'custom-browse-group-tag) - buttons) - (insert " " tag "\n") - (widget-put widget :buttons buttons)) - (push (widget-create-child-and-convert - widget 'custom-browse-visibility - ;; :tag-glyph "minus" - :tag "-") - buttons) - (insert "-\\ ") - ;; (widget-glyph-insert nil "-\\ " "top") - (push (widget-create-child-and-convert - widget 'custom-browse-group-tag) - buttons) - (insert " " tag "\n") - (widget-put widget :buttons buttons) - (message "Creating group...") - (let* ((members (custom-sort-items members - custom-browse-sort-alphabetically - custom-browse-order-groups)) - (prefixes (widget-get widget :custom-prefixes)) - (custom-prefix-list (custom-prefix-add symbol prefixes)) - (extra-prefix (if (widget-get widget :custom-last) - " " - " | ")) - (prefix (concat prefix extra-prefix)) - children entry) - (while members - (setq entry (car members) - members (cdr members)) - (push (widget-create-child-and-convert - widget (nth 1 entry) - :group widget - :tag (custom-unlispify-tag-name (nth 0 entry)) - :custom-prefixes custom-prefix-list - :custom-level (1+ level) - :custom-last (null members) - :value (nth 0 entry) - :custom-prefix prefix) - children)) - (widget-put widget :children (reverse children))) - (message "Creating group...done"))) - ;; Nested style. - ((eq state 'hidden) - ;; Create level indicator. - (unless (eq custom-buffer-style 'links) - (insert-char ?\ (* custom-buffer-indent (1- level))) - (insert "-- ")) - ;; Create link indicator. - (when (eq custom-buffer-style 'links) - (insert " ") - (push (widget-create-child-and-convert - widget 'custom-group-link - :tag "Open" - :tag-glyph '("open-up" "open-down") - symbol) - buttons) - (insert " ")) - ;; Create tag. - (let ((begin (point))) - (insert tag) - (widget-specify-sample widget begin (point))) - (insert " group") - ;; Create visibility indicator. - (unless (eq custom-buffer-style 'links) - (insert ": ") - (push (widget-create-child-and-convert - widget 'custom-group-visibility - :help-echo "Show members of this group" - :action 'custom-toggle-parent - (not (eq state 'hidden))) - buttons)) - (insert " \n") - ;; Create magic button. - (let ((magic (widget-create-child-and-convert - widget 'custom-magic nil))) - (widget-put widget :custom-magic magic) - (push magic buttons)) - ;; Update buttons. - (widget-put widget :buttons buttons) - ;; Insert documentation. - (if (and (eq custom-buffer-style 'links) (> level 1)) - (widget-put widget :documentation-indent 0)) - (widget-default-format-handler widget ?h)) - ;; Nested style. - (t ;Visible. - (custom-load-widget widget) - ;; Update members - (setq members (custom-group-members - symbol (and (eq custom-buffer-style 'tree) - custom-browse-only-groups))) - ;; Add parent groups references above the group. - (if t ;;; This should test that the buffer - ;;; was made to display a group. - (when (eq level 1) - (if (custom-add-parent-links widget - "Go to parent group:") - (insert "\n")))) - ;; Create level indicator. - (insert-char ?\ (* custom-buffer-indent (1- level))) - (insert "/- ") - ;; Create tag. - (let ((start (point))) - (insert tag) - (widget-specify-sample widget start (point))) - (insert " group: ") - ;; Create visibility indicator. - (unless (eq custom-buffer-style 'links) - (insert "--------") - (push (widget-create-child-and-convert - widget 'visibility - :help-echo "Hide members of this group" - :action 'custom-toggle-parent - (not (eq state 'hidden))) - buttons) - (insert " ")) - ;; Create more dashes. - ;; Use 76 instead of 75 to compensate for the temporary "<" - ;; added by `widget-insert'. - (insert-char ?- (- 76 (current-column) - (* custom-buffer-indent level))) - (insert "\\\n") - ;; Create magic button. - (let ((magic (widget-create-child-and-convert - widget 'custom-magic - :indent 0 - nil))) - (widget-put widget :custom-magic magic) - (push magic buttons)) - ;; Update buttons. - (widget-put widget :buttons buttons) - ;; Insert documentation. - (widget-default-format-handler widget ?h) - ;; Parent groups. - (if nil ;;; This should test that the buffer - ;;; was not made to display a group. - (when (eq level 1) - (insert-char ?\ custom-buffer-indent) - (custom-add-parent-links widget))) - (custom-add-see-also widget - (make-string (* custom-buffer-indent level) - ?\ )) - ;; Members. - (message "Creating group...") - (let* ((members (custom-sort-items members - custom-buffer-sort-alphabetically - custom-buffer-order-groups)) - (prefixes (widget-get widget :custom-prefixes)) - (custom-prefix-list (custom-prefix-add symbol prefixes)) - (length (length members)) - (count 0) - (children (mapcar - (lambda (entry) - (widget-insert "\n") - (when (zerop (% count custom-skip-messages)) - (display-message - 'progress - (format "\ -Creating group members... %2d%%" - (/ (* 100.0 count) length)))) - (incf count) - (prog1 - (widget-create-child-and-convert - widget (nth 1 entry) - :group widget - :tag (custom-unlispify-tag-name - (nth 0 entry)) - :custom-prefixes custom-prefix-list - :custom-level (1+ level) - :value (nth 0 entry)) - (unless (eq (preceding-char) ?\n) - (widget-insert "\n")))) - members))) - (message "Creating group magic...") - (mapc 'custom-magic-reset children) - (message "Creating group state...") - (widget-put widget :children children) - (custom-group-state-update widget) - (message "Creating group... done")) - ;; End line - (insert "\n") - (insert-char ?\ (* custom-buffer-indent (1- level))) - (insert "\\- " (widget-get widget :tag) " group end ") - (insert-char ?- (- 75 (current-column) (* custom-buffer-indent level))) - (insert "/\n"))))) - -(defvar custom-group-menu - '(("Set for Current Session" custom-group-set - (lambda (widget) - (eq (widget-get widget :custom-state) 'modified))) - ("Save for Future Sessions" custom-group-save - (lambda (widget) - (memq (widget-get widget :custom-state) '(modified set)))) - ("Reset to Current" custom-group-reset-current - (lambda (widget) - (memq (widget-get widget :custom-state) '(modified)))) - ("Reset to Saved" custom-group-reset-saved - (lambda (widget) - (memq (widget-get widget :custom-state) '(modified set)))) - ("Reset to standard setting" custom-group-reset-standard - (lambda (widget) - (memq (widget-get widget :custom-state) '(modified set saved))))) - "Alist of actions for the `custom-group' widget. -Each entry has the form (NAME ACTION FILTER) where NAME is the name of -the menu entry, ACTION is the function to call on the widget when the -menu is selected, and FILTER is a predicate which takes a `custom-group' -widget as an argument, and returns non-nil if ACTION is valid on that -widget. If FILTER is nil, ACTION is always valid.") - -(defun custom-group-action (widget &optional event) - "Show the menu for `custom-group' WIDGET. -Optional EVENT is the location for the menu." - (if (eq (widget-get widget :custom-state) 'hidden) - (custom-toggle-hide widget) - (let* ((completion-ignore-case t) - (answer (widget-choose (concat "Operation on " - (custom-unlispify-tag-name - (widget-get widget :value))) - (custom-menu-filter custom-group-menu - widget) - event))) - (if answer - (funcall answer widget))))) - -(defun custom-group-set (widget) - "Set changes in all modified group members." - (let ((children (widget-get widget :children))) - (mapc (lambda (child) - (when (eq (widget-get child :custom-state) 'modified) - (widget-apply child :custom-set))) - children))) - -(defun custom-group-save (widget) - "Save all modified group members." - (let ((children (widget-get widget :children))) - (mapc (lambda (child) - (when (memq (widget-get child :custom-state) '(modified set)) - (widget-apply child :custom-save))) - children))) - -(defun custom-group-reset-current (widget) - "Reset all modified group members." - (let ((children (widget-get widget :children))) - (mapc (lambda (child) - (when (eq (widget-get child :custom-state) 'modified) - (widget-apply child :custom-reset-current))) - children))) - -(defun custom-group-reset-saved (widget) - "Reset all modified or set group members." - (let ((children (widget-get widget :children))) - (mapc (lambda (child) - (when (memq (widget-get child :custom-state) '(modified set)) - (widget-apply child :custom-reset-saved))) - children))) - -(defun custom-group-reset-standard (widget) - "Reset all modified, set, or saved group members." - (let ((children (widget-get widget :children))) - (mapc (lambda (child) - (when (memq (widget-get child :custom-state) - '(modified set saved)) - (widget-apply child :custom-reset-standard))) - children))) - -(defun custom-group-state-update (widget) - "Update magic." - (unless (eq (widget-get widget :custom-state) 'hidden) - (let* ((children (widget-get widget :children)) - (states (mapcar (lambda (child) - (widget-get child :custom-state)) - children)) - (magics custom-magic-alist) - (found 'standard)) - (while magics - (let ((magic (car (car magics)))) - (if (and (not (eq magic 'hidden)) - (memq magic states)) - (setq found magic - magics nil) - (setq magics (cdr magics))))) - (widget-put widget :custom-state found))) - (custom-magic-reset widget)) - -;;; The `custom-save-all' Function. -;;;###autoload -(defcustom custom-file (if (boundp 'emacs-user-extension-dir) - (concat "~" - init-file-user - emacs-user-extension-dir - "options.el") - "~/.emacs") - "File used for storing customization information. -If you change this from the default \"~/.emacs\" you need to -explicitly load that file for the settings to take effect." - :type 'file - :group 'customize) - -(defun custom-save-delete (symbol) - "Delete the call to SYMBOL form `custom-file'. -Leave point at the location of the call, or after the last expression." - (let ((find-file-hooks nil) - (auto-mode-alist nil)) - (set-buffer (find-file-noselect custom-file))) - (goto-char (point-min)) - (catch 'found - (while t - (let ((sexp (condition-case nil - (read (current-buffer)) - (end-of-file (throw 'found nil))))) - (when (and (listp sexp) - (eq (car sexp) symbol)) - (delete-region (save-excursion - (backward-sexp) - (point)) - (point)) - (throw 'found nil)))))) - -(defun custom-save-variables () - "Save all customized variables in `custom-file'." - (save-excursion - (custom-save-delete 'custom-set-variables) - (let ((standard-output (current-buffer))) - (unless (bolp) - (princ "\n")) - (princ "(custom-set-variables") - (mapatoms (lambda (symbol) - (let ((value (get symbol 'saved-value)) - (requests (get symbol 'custom-requests)) - (now (not (or (get symbol 'standard-value) - (and (not (boundp symbol)) - (not (get symbol 'force-value))))))) - (when value - (princ "\n '(") - (princ symbol) - (princ " ") - (prin1 (car value)) - (cond (requests - (if now - (princ " t ") - (princ " nil ")) - (prin1 requests) - (princ ")")) - (now - (princ " t)")) - (t - (princ ")"))))))) - (princ ")") - (unless (looking-at "\n") - (princ "\n"))))) - -(defun custom-save-faces () - "Save all customized faces in `custom-file'." - (save-excursion - (custom-save-delete 'custom-set-faces) - (let ((standard-output (current-buffer))) - (unless (bolp) - (princ "\n")) - (princ "(custom-set-faces") - (let ((value (get 'default 'saved-face))) - ;; The default face must be first, since it affects the others. - (when value - (princ "\n '(default ") - (prin1 value) - (if (or (get 'default 'face-defface-spec) - (and (not (find-face 'default)) - (not (get 'default 'force-face)))) - (princ ")") - (princ " t)")))) - (mapatoms (lambda (symbol) - (let ((value (get symbol 'saved-face))) - (when (and (not (eq symbol 'default)) - ;; Don't print default face here. - value) - (princ "\n '(") - (princ symbol) - (princ " ") - (prin1 value) - (if (or (get symbol 'face-defface-spec) - (and (not (find-face symbol)) - (not (get symbol 'force-face)))) - (princ ")") - (princ " t)")))))) - (princ ")") - (unless (looking-at "\n") - (princ "\n"))))) - -;;;###autoload -(defun customize-save-customized () - "Save all user options which have been set in this session." - (interactive) - (mapatoms (lambda (symbol) - (let ((face (get symbol 'customized-face)) - (value (get symbol 'customized-value))) - (when face - (put symbol 'saved-face face) - (put symbol 'customized-face nil)) - (when value - (put symbol 'saved-value value) - (put symbol 'customized-value nil))))) - ;; We really should update all custom buffers here. - (custom-save-all)) - -;;;###autoload -(defun custom-save-all () - "Save all customizations in `custom-file'." - (let ((inhibit-read-only t)) - (custom-save-variables) - (custom-save-faces) - (let ((find-file-hooks nil) - (auto-mode-alist)) - (with-current-buffer (find-file-noselect custom-file) - (save-buffer))))) - - -;;; The Customize Menu. - -;;; Menu support - -(defun custom-face-menu-create (widget symbol) - "Ignoring WIDGET, create a menu entry for customization face SYMBOL." - (vector (custom-unlispify-menu-entry symbol) - `(customize-face ',symbol) - t)) - -(defun custom-variable-menu-create (widget symbol) - "Ignoring WIDGET, create a menu entry for customization variable SYMBOL." - (let ((type (get symbol 'custom-type))) - (unless (listp type) - (setq type (list type))) - (if (and type (widget-get type :custom-menu)) - (widget-apply type :custom-menu symbol) - (vector (custom-unlispify-menu-entry symbol) - `(customize-variable ',symbol) - t)))) - -;; Add checkboxes to boolean variable entries. -(widget-put (get 'boolean 'widget-type) - :custom-menu (lambda (widget symbol) - `[,(custom-unlispify-menu-entry symbol) - (customize-variable ',symbol) - :style toggle - :selected ,symbol])) - -;; XEmacs can create menus dynamically. -(defun custom-group-menu-create (widget symbol) - "Ignoring WIDGET, create a menu entry for customization group SYMBOL." - `( ,(custom-unlispify-menu-entry symbol t) - :filter (lambda (&rest junk) - (let ((item (custom-menu-create ',symbol))) - (if (listp item) - (cdr item) - (list item)))))) - -;;;###autoload -(defun custom-menu-create (symbol) - "Create menu for customization group SYMBOL. -The menu is in a format applicable to `easy-menu-define'." - (let* ((item (vector (custom-unlispify-menu-entry symbol) - `(customize-group ',symbol) - t))) - ;; Item is the entry for creating a menu buffer for SYMBOL. - ;; We may nest, if the menu is not too big. - (custom-load-symbol symbol) - (if (< (length (get symbol 'custom-group)) widget-menu-max-size) - ;; The menu is not too big. - (let ((custom-prefix-list (custom-prefix-add symbol - custom-prefix-list)) - (members (custom-sort-items (get symbol 'custom-group) - custom-menu-sort-alphabetically - custom-menu-order-groups))) - ;; Create the menu. - `(,(custom-unlispify-menu-entry symbol t) - ,item - "--" - ,@(mapcar (lambda (entry) - (widget-apply (if (listp (nth 1 entry)) - (nth 1 entry) - (list (nth 1 entry))) - :custom-menu (nth 0 entry))) - members))) - ;; The menu was too big. - item))) - -;;;###autoload -(defun customize-menu-create (symbol &optional name) - "Return a customize menu for customization group SYMBOL. -If optional NAME is given, use that as the name of the menu. -Otherwise the menu will be named `Customize'. -The format is suitable for use with `easy-menu-define'." - (unless name - (setq name "Customize")) - `(,name - :filter (lambda (&rest junk) - (cdr (custom-menu-create ',symbol))))) - -;;; The Custom Mode. - -(defvar custom-mode-map nil - "Keymap for `custom-mode'.") - -(unless custom-mode-map - (setq custom-mode-map (make-sparse-keymap)) - (set-keymap-parents custom-mode-map widget-keymap) - (suppress-keymap custom-mode-map) - (define-key custom-mode-map " " 'scroll-up) - (define-key custom-mode-map "\177" 'scroll-down) - (define-key custom-mode-map "q" 'bury-buffer) - (define-key custom-mode-map "u" 'Custom-goto-parent) - (define-key custom-mode-map "n" 'widget-forward) - (define-key custom-mode-map "p" 'widget-backward) - ;; (define-key custom-mode-map [mouse-1] 'Custom-move-and-invoke) - ) - -(defun Custom-move-and-invoke (event) - "Move to where you click, and if it is an active field, invoke it." - (interactive "e") - (mouse-set-point event) - (if (widget-event-point event) - (let* ((pos (widget-event-point event)) - (button (get-char-property pos 'button))) - (if button - (widget-button-click event))))) - -(easy-menu-define Custom-mode-menu - custom-mode-map - "Menu used in customization buffers." - `("Custom" - ,(customize-menu-create 'customize) - ["Set" Custom-set t] - ["Save" Custom-save t] - ["Reset to Current" Custom-reset-current t] - ["Reset to Saved" Custom-reset-saved t] - ["Reset to Standard Settings" Custom-reset-standard t] - ["Info" (Info-goto-node "(xemacs)Easy Customization") t])) - -(defun Custom-goto-parent () - "Go to the parent group listed at the top of this buffer. -If several parents are listed, go to the first of them." - (interactive) - (save-excursion - (goto-char (point-min)) - (if (search-forward "\nGo to parent group: " nil t) - (let* ((button (get-char-property (point) 'button)) - (parent (downcase (widget-get button :tag)))) - (customize-group parent))))) - -(defcustom custom-mode-hook nil - "Hook called when entering custom-mode." - :type 'hook - :group 'custom-buffer ) - -(defun custom-state-buffer-message (widget) - (if (eq (widget-get (widget-get widget :parent) :custom-state) 'modified) - (message - "To install your edits, invoke [State] and choose the Set operation"))) - -(defun custom-mode () - "Major mode for editing customization buffers. - -The following commands are available: - -Move to next button or editable field. \\[widget-forward] -Move to previous button or editable field. \\[widget-backward] -\\<widget-field-keymap>\ -Complete content of editable text field. \\[widget-complete] -\\<custom-mode-map>\ -Invoke button under the mouse pointer. \\[Custom-move-and-invoke] -Invoke button under point. \\[widget-button-press] -Set all modifications. \\[Custom-set] -Make all modifications default. \\[Custom-save] -Reset all modified options. \\[Custom-reset-current] -Reset all modified or set options. \\[Custom-reset-saved] -Reset all options. \\[Custom-reset-standard] - -Entry to this mode calls the value of `custom-mode-hook' -if that value is non-nil." - (kill-all-local-variables) - (setq major-mode 'custom-mode - mode-name "Custom") - (use-local-map custom-mode-map) - (easy-menu-add Custom-mode-menu) - (make-local-variable 'custom-options) - (make-local-variable 'widget-documentation-face) - (setq widget-documentation-face 'custom-documentation-face) - (make-local-variable 'widget-button-face) - (setq widget-button-face 'custom-button-face) - (make-local-hook 'widget-edit-functions) - (add-hook 'widget-edit-functions 'custom-state-buffer-message nil t) - (run-hooks 'custom-mode-hook)) - - -;;; The End. - -(provide 'cus-edit) - -;; cus-edit.el ends here
--- a/lisp/custom/cus-face.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,255 +0,0 @@ -;;; cus-face.el -- Support for Custom faces. -;; -;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. -;; -;; Author: Per Abrahamsen <abraham@dina.kvl.dk> -;; Maintainer: Hrvoje Niksic <hniksic@srce.hr> -;; Keywords: help, faces -;; Version: 1.9960-x -;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ - -;;; Commentary: -;; -;; See `custom.el'. - -;; This file should probably be dissolved, and code moved to faces.el, -;; like Stallman did. - -;;; Code: - -(require 'custom) - -;; To elude the warnings for font functions. -(eval-when-compile - (require 'font)) - -;;; Declaring a face. - -;;;###autoload -(defun custom-declare-face (face spec doc &rest args) - "Like `defface', but FACE is evaluated as a normal argument." - ;; (when (fboundp 'load-gc) - ;; (error "Attempt to declare a face during dump")) - (unless (get face 'face-defface-spec) - (put face 'face-defface-spec spec) - (unless (find-face face) - ;; If the user has already created the face, respect that. - (let ((value (or (get face 'saved-face) spec)) - (frames (relevant-custom-frames)) - frame) - ;; Create global face. - (make-empty-face face) - (face-display-set face value) - ;; Create frame local faces - (while frames - (setq frame (car frames) - frames (cdr frames)) - (face-display-set face value frame)) - (init-face-from-resources face))) - (when (and doc (null (face-doc-string face))) - (set-face-doc-string face doc)) - (custom-handle-all-keywords face args 'custom-face) - (run-hooks 'custom-define-hook)) - face) - -;;; Font Attributes. - -(defconst custom-face-attributes - '((:bold (boolean :tag "Bold" - :help-echo "Control whether a bold font should be used.") - custom-set-face-bold custom-face-bold) - (:italic (boolean :tag "Italic" - :help-echo "\ -Control whether an italic font should be used.") - custom-set-face-italic custom-face-italic) - (:underline (boolean :tag "Underline" - :help-echo "\ -Control whether the text should be underlined.") - set-face-underline-p face-underline-p) - (:foreground (color :tag "Foreground" - :value "" - :help-echo "Set foreground color.") - set-face-foreground face-foreground-name) - (:background (color :tag "Background" - :value "" - :help-echo "Set background color.") - set-face-background face-background-name) - ;; #### Should make it work on X - (:inverse-video (boolean :tag "Inverse" - :help-echo "\ -Control whether the text should be inverted. Works only on TTY-s") - set-face-reverse-p face-reverse-p) - (:stipple (editable-field :format "Stipple: %v" - :help-echo "Name of background bitmap file.") - set-face-background-pixmap custom-face-stipple) - (:family (editable-field :format "Font Family: %v" - :help-echo "\ -Name of font family to use (e.g. times).") - custom-set-face-font-family custom-face-font-family) - (:size (editable-field :format "Size: %v" - :help-echo "\ -Text size (e.g. 9pt or 2mm).") - custom-set-face-font-size custom-face-font-size) - (:strikethru (toggle :format "%[Strikethru%]: %v\n" - :help-echo "\ -Control whether the text should be strikethru.") - set-face-strikethru-p face-strikethru-p)) - "Alist of face attributes. - -The elements are of the form (KEY TYPE SET GET) where KEY is a symbol -identifying the attribute, TYPE is a widget type for editing the -attibute, SET is a function for setting the attribute value, and GET is a function for getiing the attribute value. - -The SET function should take three arguments, the face to modify, the -value of the attribute, and optionally the frame where the face should -be changed. - -The GET function should take two arguments, the face to examine, and -optonally the frame where the face should be examined.") - -(defun face-custom-attributes-set (face frame &rest atts) - "For FACE on FRAME set the attributes [KEYWORD VALUE].... -Each keyword should be listed in `custom-face-attributes'. - -If FRAME is nil, set the default face." - (while atts - (let* ((name (nth 0 atts)) - (value (nth 1 atts)) - (fun (nth 2 (assq name custom-face-attributes)))) - (setq atts (cdr (cdr atts))) - (condition-case nil - (funcall fun face value frame) - (error nil))))) - -(defun face-custom-attributes-get (face frame) - "For FACE on FRAME get the attributes [KEYWORD VALUE].... -Each keyword should be listed in `custom-face-attributes'. - -If FRAME is nil, use the default face." - (condition-case nil - ;; Attempt to get `font.el' from w3. - (require 'font) - (error nil)) - (let ((atts custom-face-attributes) - att result get) - (while atts - (setq att (car atts) - atts (cdr atts) - get (nth 3 att)) - (condition-case nil - ;; This may fail if w3 doesn't exists. - (when get - (let ((answer (funcall get face frame))) - (unless (equal answer (funcall get 'default frame)) - (when (widget-apply (nth 1 att) :match answer) - (setq result (cons (nth 0 att) (cons answer result))))))) - (error nil))) - result)) - -(defun custom-set-face-bold (face value &optional frame) - "Set the bold property of FACE to VALUE." - (if value - (make-face-bold face frame) - (make-face-unbold face frame))) - -;; Really, we should get rid of these font.el dependencies... They -;; are still presenting a problem with dumping the faces (font.el is -;; too bloated for us to dump). I am thinking about hacking up -;; font-like functionality myself for the sake of this file. It will -;; probably be to-the-point and more efficient. - -(defun custom-face-bold (face &rest args) - "Return non-nil if the font of FACE is bold." - (let* ((font (apply 'face-font-name face args)) - ;; Gag - (fontobj (font-create-object font))) - (font-bold-p fontobj))) - -(defun custom-set-face-italic (face value &optional frame) - "Set the italic property of FACE to VALUE." - (if value - (make-face-italic face frame) - (make-face-unitalic face frame))) - -(defun custom-face-italic (face &rest args) - "Return non-nil if the font of FACE is italic." - (let* ((font (apply 'face-font-name face args)) - ;; Gag - (fontobj (font-create-object font))) - (font-italic-p fontobj))) - -(defun custom-face-stipple (face &rest args) - "Return the name of the stipple file used for FACE." - (let ((image (apply 'specifier-instance - (face-background-pixmap face) args))) - (and image - (image-instance-file-name image)))) - -(defun custom-set-face-font-size (face size &rest args) - "Set the font of FACE to SIZE" - (let* ((font (apply 'face-font-name face args)) - ;; Gag - (fontobj (font-create-object font))) - (set-font-size fontobj size) - (apply 'font-set-face-font face fontobj args))) - -(defun custom-face-font-size (face &rest args) - "Return the size of the font of FACE as a string." - (let* ((font (apply 'face-font-name face args)) - ;; Gag - (fontobj (font-create-object font))) - (format "%s" (font-size fontobj)))) - -(defun custom-set-face-font-family (face family &rest args) - "Set the font of FACE to FAMILY." - (let* ((font (apply 'face-font-name face args)) - ;; Gag - (fontobj (font-create-object font))) - (set-font-family fontobj family) - (apply 'font-set-face-font face fontobj args))) - -(defun custom-face-font-family (face &rest args) - "Return the name of the font family of FACE." - (let* ((font (apply 'face-font-name face args)) - ;; Gag - (fontobj (font-create-object font))) - (font-family fontobj))) - -;;; Initializing. - -;;;###autoload -(defun custom-set-faces (&rest args) - "Initialize faces according to user preferences. -The arguments should be a list where each entry has the form: - - (FACE SPEC [NOW]) - -SPEC will be stored as the saved value for FACE. If NOW is present -and non-nil, FACE will also be created according to SPEC. - -See `defface' for the format of SPEC." - (while args - (let ((entry (car args))) - (if (listp entry) - (let ((face (nth 0 entry)) - (spec (nth 1 entry)) - (now (nth 2 entry))) - (put face 'saved-face spec) - (when now - (put face 'force-face t)) - (when (or now (find-face face)) - (unless (find-face face) - (make-empty-face face)) - (face-spec-set face spec)) - (setq args (cdr args))) - ;; Old format, a plist of FACE SPEC pairs. - (let ((face (nth 0 args)) - (spec (nth 1 args))) - (put face 'saved-face spec)) - (setq args (cdr (cdr args))))))) - -;;; The End. - -(provide 'cus-face) - -;; cus-face.el ends here
--- a/lisp/custom/cus-load.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,72 +0,0 @@ -;;; cus-load.el --- Batch load all available cus-load files - -;; Copyright (C) 1997 by Free Software Foundation, Inc. - -;; Author: Steven L Baur <steve@altair.xemacs.org> -;; Keywords: internal, help, faces - -;; 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: - -;; In FSF all of the custom loads are in a single `cus-load' file. -;; However, we have them distributed across directories, with optional -;; incremental loading. Here we simply collect the whole set. - - -;;; Code: - -(require 'custom) - - -(defun custom-add-loads (symbol list) - "Update the custom-loads list of a symbol. -This works by adding the elements from LIST to the SYMBOL's -`custom-loads' property, avoiding duplicates. Also, SYMBOL is -added to `custom-group-hash-table'." - (let ((loads (get symbol 'custom-loads))) - (dolist (el list) - (unless (member el loads) - (setq loads (nconc loads (list el))))) - (put symbol 'custom-loads loads) - (puthash symbol t custom-group-hash-table))) - -;; custom-add-loads was named custom-put (and accepted different -;; arguments) during the 20.3 beta cycle. Support it for -;; compatibility. -(defun custom-put (symbol ignored list) - (custom-add-loads symbol list)) -(make-obsolete 'custom-put 'custom-add-loads) - - -(message "Loading customization dependencies...") - -;; Garbage-collection seems to be very intensive here, and it slows -;; things down. Nuke it. -(let ((gc-cons-threshold 10000000)) - (mapc (lambda (dir) - (load (expand-file-name "custom-load" dir) t t)) - load-path)) - -(message "Loading customization dependencies...done") - -(provide 'cus-load) - -;;; cus-load.el ends here
--- a/lisp/custom/cus-start.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,200 +0,0 @@ -;;; cus-start.el --- define customization properties of builtins. -;; -;; Copyright (C) 1997 Free Software Foundation, Inc. -;; -;; Author: Per Abrahamsen <abraham@dina.kvl.dk> -;; Keywords: internal - -;; 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 synched with FSF. - -;;; Commentary: -;; -;; The following code is used to define the customization properties -;; for builtin variables, and variables in the packages that are -;; preloaded /very/ early, before custom.el itself (replace.el is such -;; an example). The way it handles custom stuff is dirty, and should -;; be regarded as a last resort. DO NOT add variables here, unless -;; you know what you are doing. - -;; Must be run before the user has changed the value of any options! - - -;;; Code: - -(require 'custom) - -(defun custom-start-quote (sexp) - ;; This is copied from `cus-edit.el'. - "Quote SEXP iff it is not self quoting." - (if (or (memq sexp '(t nil)) - (and (symbolp sexp) - (eq (aref (symbol-name sexp) 0) ?:)) - (and (listp sexp) - (memq (car sexp) '(lambda))) - (stringp sexp) - (numberp sexp) - (and (fboundp 'characterp) - (characterp sexp))) - sexp - (list 'quote sexp))) - -(let ((all '(;; boolean - (abbrev-all-caps abbrev boolean) - (allow-deletion-of-last-visible-frame frames boolean) - (debug-on-quit debug boolean) - (delete-auto-save-files auto-save boolean) - (delete-exited-processes processes-basics boolean) - (indent-tabs-mode editing-basics boolean) - (load-ignore-elc-files maint boolean) - (load-warn-when-source-newer maint boolean) - (load-warn-when-source-only maint boolean) - (modifier-keys-are-sticky keyboard boolean) - (no-redraw-on-reenter display boolean) - (scroll-on-clipped-lines display boolean) - (truncate-partial-width-windows display boolean) - (visible-bell sound boolean) - (x-allow-sendevents x boolean) - (zmacs-regions editing-basics boolean) - ;; integer - (auto-save-interval auto-save integer) - (bell-volume sound integer) - (echo-keystrokes keyboard integer) - (gc-cons-threshold alloc integer) - (next-screen-context-lines display integer) - (scroll-step windows integer) - (window-min-height windows integer) - (window-min-width windows integer) - ;; object - (auto-save-file-format auto-save - (choice (const :tag "Normal" t) - (repeat (symbol :tag "Format")))) - (completion-ignored-extensions minibuffer - (repeat - (string :format "%v"))) - (debug-ignored-errors debug (repeat (choice :format "%v" - (symbol :tag "Class") - regexp))) - (debug-on-error debug (choice (const :tag "off" nil) - (const :tag "Always" t) - (repeat :menu-tag "When" - :value (nil) - (symbol - :tag "Condition")))) - (debug-on-signal debug (choice (const :tag "off" nil) - (const :tag "Always" t) - (repeat :menu-tag "When" - :value (nil) - (symbol - :tag "Condition")))) - (exec-path processes-basics (repeat - (choice :tag "Directory" - (const :tag "Default" nil) - (directory :format "%v")))) - (file-name-handler-alist data (repeat - (cons regexp - (function :tag "Handler")))) - (shell-file-name execute file) - (stack-trace-on-error debug (choice (const :tag "off" nil) - (const :tag "Always" t) - (repeat :menu-tag "When" - :value (nil) - (symbol - :tag "Condition")))) - (stack-trace-on-signal debug (choice (const :tag "off" nil) - (const :tag "Always" t) - (repeat :menu-tag "When" - :value (nil) - (symbol - :tag "Condition")))) - ;; buffer-local - (case-fold-search matching boolean) - (ctl-arrow display (choice (integer 160) - (sexp :tag "160 (default)" - :format "%t\n"))) - (fill-column fill integer) - (left-margin fill integer) - (tab-width editing-basics integer) - (truncate-lines display boolean) - ;; not documented as user-options, but should still be - ;; customizable: - (bar-cursor display (choice (const :tag "Block Cursor" nil) - (const :tag "Bar Cursor (1 pixel)" t) - (sexp :tag "Bar Cursor (2 pixels)" - :format "%t\n" 'other))) - (default-frame-plist frames (repeat - (list :inline t - :format "%v" - (symbol :tag "Parameter") - (sexp :tag "Value")))) - (disable-auto-save-when-buffer-shrinks auto-save boolean) - (find-file-use-truenames find-file boolean) - (find-file-compare-truenames find-file boolean) - (focus-follows-mouse x boolean) - (help-char keyboard character) - (max-lisp-eval-depth limits integer) - (max-specpdl-size limits integer) - (meta-prefix-char keyboard character) - (parse-sexp-ignore-comments editing-basics boolean) - (selective-display display - (choice (const :tag "off" nil) - (integer :tag "space" - :format "%v" - 1) - (const :tag "on" t))) - (selective-display-ellipses display boolean) - (signal-error-on-buffer-boundary internal boolean) - (temp-buffer-show-function - windows (radio (function-item :tag "Temp Buffers Always in Same Frame" - :format "%t\n" - show-temp-buffer-in-current-frame) - (const :tag "Temp Buffers Like Other Buffers" nil) - (function :tag "Other"))) - (undo-threshold undo integer) - (undo-high-threshold undo integer) - (words-include-escapes editing-basics boolean) - ;; These are from replace.el, which is loaded too early - ;; to be customizable. - (case-replace matching boolean) - (query-replace-highlight matching boolean) - (list-matching-lines-default-context-lines matching integer))) - this symbol group type) - (while all - (setq this (car all) - all (cdr all) - symbol (nth 0 this) - group (nth 1 this) - type (nth 2 this)) - (if (not (boundp symbol)) - ;; This is loaded so early, there is no message - (if (fboundp 'message) - ;; If variables are removed from C code, give an error here! - (message "Intrinsic `%S' not bound" symbol)) - ;; This is called before any user can have changed the value. - (put symbol 'standard-value - (list (custom-start-quote (default-value symbol)))) - ;; Add it to the right group. - (custom-add-to-group group symbol 'custom-variable) - ;; Set the type. - (put symbol 'custom-type type)))) - -;; This is to prevent it from being reloaded by `cus-load.el'. -(provide 'cus-start) - -;;; cus-start.el ends here.
--- a/lisp/custom/custom-load.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,36 +0,0 @@ -;;; custom-load.el --- automatically extracted custom dependencies - - -;;; Code: - -(custom-add-loads 'extensions '("wid-edit")) -(custom-add-loads 'custom-buffer '("cus-edit")) -(custom-add-loads 'custom-faces '("cus-edit")) -(custom-add-loads 'widgets '("wid-browse" "wid-edit")) -(custom-add-loads 'environment '("cus-edit")) -(custom-add-loads 'custom-menu '("cus-edit")) -(custom-add-loads 'internal '("cus-edit")) -(custom-add-loads 'hypermedia '("wid-edit")) -(custom-add-loads 'applications '("cus-edit")) -(custom-add-loads 'help '("cus-edit")) -(custom-add-loads 'widget-browse '("wid-browse")) -(custom-add-loads 'widget-documentation '("wid-edit")) -(custom-add-loads 'customize '("cus-edit" "wid-edit")) -(custom-add-loads 'custom-browse '("cus-edit")) -(custom-add-loads 'abbrev '("cus-edit")) -(custom-add-loads 'programming '("cus-edit")) -(custom-add-loads 'widget-button '("wid-edit")) -(custom-add-loads 'files '("cus-edit")) -(custom-add-loads 'external '("cus-edit")) -(custom-add-loads 'development '("cus-edit")) -(custom-add-loads 'widget-faces '("wid-edit")) -(custom-add-loads 'languages '("cus-edit")) -(custom-add-loads 'custom-magic-faces '("cus-edit")) -(custom-add-loads 'faces '("cus-edit" "wid-edit")) -(custom-add-loads 'emacs '("cus-edit")) -(custom-add-loads 'processes '("cus-edit")) -(custom-add-loads 'wp '("cus-edit")) -(custom-add-loads 'editing '("cus-edit")) -(custom-add-loads 'i18n '("cus-edit")) - -;;; custom-load.el ends here
--- a/lisp/custom/custom.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,398 +0,0 @@ -;;; custom.el -- Tools for declaring and initializing options. -;; -;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. -;; -;; Author: Per Abrahamsen <abraham@dina.kvl.dk> -;; Maintainer: Hrvoje Niksic <hniksic@srce.hr> -;; Keywords: help, faces -;; Version: 1.9960-x -;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ - -;; 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. - -;;; Commentary: -;; -;; If you want to use this code, please visit the URL above. -;; -;; This file only contain the code needed to declare and initialize -;; user options. The code to customize options is autoloaded from -;; `cus-edit.el'. -;; -;; The code implementing face declarations is in `cus-face.el' - -;;; Code: - -(require 'widget) - -(defvar custom-define-hook nil - ;; Customize information for this option is in `cus-edit.el'. - "Hook called after defining each customize option.") - -;;; The `defcustom' Macro. - -(defun custom-initialize-default (symbol value) - "Initialize SYMBOL with VALUE. -This will do nothing if symbol already has a default binding. -Otherwise, if symbol has a `saved-value' property, it will evaluate -the car of that and used as the default binding for symbol. -Otherwise, VALUE will be evaluated and used as the default binding for -symbol." - (unless (default-boundp symbol) - ;; Use the saved value if it exists, otherwise the standard setting. - (set-default symbol (if (get symbol 'saved-value) - (eval (car (get symbol 'saved-value))) - (eval value))))) - -(defun custom-initialize-set (symbol value) - "Initialize SYMBOL with VALUE. -Like `custom-initialize-default', but use the function specified by -`:set' to initialize SYMBOL." - (unless (default-boundp symbol) - (funcall (or (get symbol 'custom-set) 'set-default) - symbol - (if (get symbol 'saved-value) - (eval (car (get symbol 'saved-value))) - (eval value))))) - -(defun custom-initialize-reset (symbol value) - "Initialize SYMBOL with VALUE. -Like `custom-initialize-set', but use the function specified by -`:get' to reinitialize SYMBOL if it is already bound." - (funcall (or (get symbol 'custom-set) 'set-default) - symbol - (cond ((default-boundp symbol) - (funcall (or (get symbol 'custom-get) 'default-value) - symbol)) - ((get symbol 'saved-value) - (eval (car (get symbol 'saved-value)))) - (t - (eval value))))) - -(defun custom-initialize-changed (symbol value) - "Initialize SYMBOL with VALUE. -Like `custom-initialize-reset', but only use the `:set' function if the -not using the standard setting. Otherwise, use the `set-default'." - (cond ((default-boundp symbol) - (funcall (or (get symbol 'custom-set) 'set-default) - symbol - (funcall (or (get symbol 'custom-get) 'default-value) - symbol))) - ((get symbol 'saved-value) - (funcall (or (get symbol 'custom-set) 'set-default) - symbol - (eval (car (get symbol 'saved-value))))) - (t - (set-default symbol (eval value))))) - -(defun custom-declare-variable (symbol value doc &rest args) - "Like `defcustom', but SYMBOL and VALUE are evaluated as normal arguments." - ;; Remember the standard setting. - (put symbol 'standard-value (list value)) - ;; Maybe this option was rogue in an earlier version. It no longer is. - (when (get symbol 'force-value) - ;; It no longer is. - (put symbol 'force-value nil)) - (when doc - (put symbol 'variable-documentation doc)) - (let ((initialize 'custom-initialize-reset) - (requests nil)) - (while args - (let ((arg (car args))) - (setq args (cdr args)) - (unless (symbolp arg) - (error "Junk in args %S" args)) - (let ((keyword arg) - (value (car args))) - (unless args - (error "Keyword %s is missing an argument" keyword)) - (setq args (cdr args)) - (cond ((eq keyword :initialize) - (setq initialize value)) - ((eq keyword :set) - (put symbol 'custom-set value)) - ((eq keyword :get) - (put symbol 'custom-get value)) - ((eq keyword :require) - (setq requests (cons value requests))) - ((eq keyword :type) - (put symbol 'custom-type value)) - ((eq keyword :options) - (if (get symbol 'custom-options) - ;; Slow safe code to avoid duplicates. - (mapc (lambda (option) - (custom-add-option symbol option)) - value) - ;; Fast code for the common case. - (put symbol 'custom-options (copy-sequence value)))) - (t - (custom-handle-keyword symbol keyword value - 'custom-variable)))))) - (put symbol 'custom-requests requests) - ;; Do the actual initialization. - (funcall initialize symbol value)) - (run-hooks 'custom-define-hook) - symbol) - -(defmacro defcustom (symbol value doc &rest args) - "Declare SYMBOL as a customizable variable that defaults to VALUE. -DOC is the variable documentation. - -Neither SYMBOL nor VALUE needs to be quoted. -If SYMBOL is not already bound, initialize it to VALUE. -The remaining arguments should have the form - - [KEYWORD VALUE]... - -The following KEYWORD's are defined: - -:type VALUE should be a widget type for editing the symbols value. - The default is `sexp'. -:options VALUE should be a list of valid members of the widget type. -:group VALUE should be a customization group. - Add SYMBOL to that group. -:initialize VALUE should be a function used to initialize the - variable. It takes two arguments, the symbol and value - given in the `defcustom' call. The default is - `custom-initialize-set' -:set VALUE should be a function to set the value of the symbol. - It takes two arguments, the symbol to set and the value to - give it. The default is `set-default'. -:get VALUE should be a function to extract the value of symbol. - The function takes one argument, a symbol, and should return - the current value for that symbol. The default is - `default-value'. -:require VALUE should be a feature symbol. Each feature will be - required after initialization, of the the user have saved this - option. - -Read the section about customization in the Emacs Lisp manual for more -information." - `(custom-declare-variable (quote ,symbol) (quote ,value) ,doc ,@args)) - -;;; The `defface' Macro. - -(defmacro defface (face spec doc &rest args) - "Declare FACE as a customizable face that defaults to SPEC. -FACE does not need to be quoted. - -Third argument DOC is the face documentation. - -If FACE has been set with `custom-set-face', set the face attributes -as specified by that function, otherwise set the face attributes -according to SPEC. - -The remaining arguments should have the form - - [KEYWORD VALUE]... - -The following KEYWORDs are defined: - -:group VALUE should be a customization group. - Add FACE to that group. - -SPEC should be an alist of the form ((DISPLAY ATTS)...). - -ATTS is a list of face attributes and their values. The possible -attributes are defined in the variable `custom-face-attributes'. - -The ATTS of the first entry in SPEC where the DISPLAY matches the -frame should take effect in that frame. DISPLAY can either be the -symbol t, which will match all frames, or an alist of the form -\((REQ ITEM...)...) - -For the DISPLAY to match a FRAME, the REQ property of the frame must -match one of the ITEM. The following REQ are defined: - -`type' (the value of `window-system') - Should be one of `x' or `tty'. - -`class' (the frame's color support) - Should be one of `color', `grayscale', or `mono'. - -`background' (what color is used for the background text) - Should be one of `light' or `dark'. - -Read the section about customization in the Emacs Lisp manual for more -information." - `(custom-declare-face (quote ,face) ,spec ,doc ,@args)) - -;;; The `defgroup' Macro. - -(defun custom-declare-group (symbol members doc &rest args) - "Like `defgroup', but SYMBOL is evaluated as a normal argument." - (while members - (apply 'custom-add-to-group symbol (car members)) - (pop members)) - (put symbol 'custom-group (nconc members (get symbol 'custom-group))) - (when doc - (put symbol 'group-documentation doc)) - (while args - (let ((arg (car args))) - (setq args (cdr args)) - (unless (symbolp arg) - (error "Junk in args %S" args)) - (let ((keyword arg) - (value (car args))) - (unless args - (error "Keyword %s is missing an argument" keyword)) - (setq args (cdr args)) - (cond ((eq keyword :prefix) - (put symbol 'custom-prefix value)) - (t - (custom-handle-keyword symbol keyword value - 'custom-group)))))) - (run-hooks 'custom-define-hook) - symbol) - -(defmacro defgroup (symbol members doc &rest args) - "Declare SYMBOL as a customization group containing MEMBERS. -SYMBOL does not need to be quoted. - -Third arg DOC is the group documentation. - -MEMBERS should be an alist of the form ((NAME WIDGET)...) where NAME -is a symbol and WIDGET is a widget for editing that symbol. Useful -widgets are `custom-variable' for editing variables, `custom-face' for -edit faces, and `custom-group' for editing groups. - -The remaining arguments should have the form - - [KEYWORD VALUE]... - -The following KEYWORD's are defined: - -:group VALUE should be a customization group. - Add SYMBOL to that group. - -Read the section about customization in the Emacs Lisp manual for more -information." - `(custom-declare-group (quote ,symbol) ,members ,doc ,@args)) - -;; This is preloaded very early, so we avoid using CL features. -(defvar custom-group-hash-table (make-hashtable 300 'eq) - "Hash-table of non-empty groups.") - -(defun custom-add-to-group (group option widget) - "To existing GROUP add a new OPTION of type WIDGET. -If there already is an entry for that option, overwrite it." - (let* ((members (get group 'custom-group)) - (old (assq option members))) - (if old - (setcar (cdr old) widget) - (put group 'custom-group (nconc members (list (list option widget)))))) - (puthash group t custom-group-hash-table)) - -;;; Properties. - -(defun custom-handle-all-keywords (symbol args type) - "For customization option SYMBOL, handle keyword arguments ARGS. -Third argument TYPE is the custom option type." - (while args - (let ((arg (car args))) - (setq args (cdr args)) - (unless (symbolp arg) - (error "Junk in args %S" args)) - (let ((keyword arg) - (value (car args))) - (unless args - (error "Keyword %s is missing an argument" keyword)) - (setq args (cdr args)) - (custom-handle-keyword symbol keyword value type))))) - -(defun custom-handle-keyword (symbol keyword value type) - "For customization option SYMBOL, handle KEYWORD with VALUE. -Fourth argument TYPE is the custom option type." - (cond ((eq keyword :group) - (custom-add-to-group value symbol type)) - ((eq keyword :link) - (custom-add-link symbol value)) - ((eq keyword :load) - (custom-add-load symbol value)) - ((eq keyword :tag) - (put symbol 'custom-tag value)) - (t - (error "Unknown keyword %s" symbol)))) - -(defun custom-add-option (symbol option) - "To the variable SYMBOL add OPTION. - -If SYMBOL is a hook variable, OPTION should be a hook member. -For other types variables, the effect is undefined." - (let ((options (get symbol 'custom-options))) - (unless (member option options) - (put symbol 'custom-options (cons option options))))) - -(defun custom-add-link (symbol widget) - "To the custom option SYMBOL add the link WIDGET." - (let ((links (get symbol 'custom-links))) - (unless (member widget links) - (put symbol 'custom-links (cons widget links))))) - -(defun custom-add-load (symbol load) - "To the custom option SYMBOL add the dependency LOAD. -LOAD should be either a library file name, or a feature name." - (let ((loads (get symbol 'custom-loads))) - (unless (member load loads) - (put symbol 'custom-loads (cons load loads))))) - -;;; Initializing. - -(defun custom-set-variables (&rest args) - "Initialize variables according to user preferences. - -The arguments should be a list where each entry has the form: - - (SYMBOL VALUE [NOW]) - -The unevaluated VALUE is stored as the saved value for SYMBOL. -If NOW is present and non-nil, VALUE is also evaluated and bound as -the default value for the SYMBOL." - (while args - (let ((entry (car args))) - (if (listp entry) - (let* ((symbol (nth 0 entry)) - (value (nth 1 entry)) - (now (nth 2 entry)) - (requests (nth 3 entry)) - (set (or (get symbol 'custom-set) 'set-default))) - (put symbol 'saved-value (list value)) - (cond (now - ;; Rogue variable, set it now. - (put symbol 'force-value t) - (funcall set symbol (eval value))) - ((default-boundp symbol) - ;; Something already set this, overwrite it. - (funcall set symbol (eval value)))) - (when requests - (put symbol 'custom-requests requests) - (mapc 'require requests)) - (setq args (cdr args))) - ;; Old format, a plist of SYMBOL VALUE pairs. - (message "Warning: old format `custom-set-variables'") - (ding) - (sit-for 2) - (let ((symbol (nth 0 args)) - (value (nth 1 args))) - (put symbol 'saved-value (list value))) - (setq args (cdr (cdr args))))))) - -;;; The End. - -(provide 'custom) - -;; custom.el ends here
--- a/lisp/custom/wid-browse.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,300 +0,0 @@ -;;; wid-browse.el --- Functions for browsing widgets. -;; -;; Copyright (C) 1997 Free Software Foundation, Inc. -;; -;; Author: Per Abrahamsen <abraham@dina.kvl.dk> -;; Keywords: extensions -;; Version: 1.9960 -;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: -;; -;; Widget browser. See `widget.el'. - -;;; Code: - -(require 'easymenu) -(require 'custom) -(require 'wid-edit) -(eval-when-compile (require 'cl)) - -(defgroup widget-browse nil - "Customization support for browsing widgets." - :group 'widgets) - -;;; The Mode. - -(defvar widget-browse-mode-map nil - "Keymap for `widget-browse-mode'.") - -(unless widget-browse-mode-map - (setq widget-browse-mode-map (make-sparse-keymap)) - (set-keymap-parent widget-browse-mode-map widget-keymap) - (define-key widget-browse-mode-map "q" 'bury-buffer)) - -(easy-menu-define widget-browse-mode-customize-menu - widget-browse-mode-map - "Menu used in widget browser buffers." - (customize-menu-create 'widgets)) - -(easy-menu-define widget-browse-mode-menu - widget-browse-mode-map - "Menu used in widget browser buffers." - '("Widget" - ["Browse" widget-browse t] - ["Browse At" widget-browse-at t])) - -(defcustom widget-browse-mode-hook nil - "Hook called when entering widget-browse-mode." - :type 'hook - :group 'widget-browse) - -(defun widget-browse-mode () - "Major mode for widget browser buffers. - -The following commands are available: - -\\[widget-forward] Move to next button or editable field. -\\[widget-backward] Move to previous button or editable field. -\\[widget-button-click] Activate button under the mouse pointer. -\\[widget-button-press] Activate button under point. - -Entry to this mode calls the value of `widget-browse-mode-hook' -if that value is non-nil." - (kill-all-local-variables) - (setq major-mode 'widget-browse-mode - mode-name "Widget") - (use-local-map widget-browse-mode-map) - (easy-menu-add widget-browse-mode-customize-menu) - (easy-menu-add widget-browse-mode-menu) - (run-hooks 'widget-browse-mode-hook)) - -;;; Commands. - -;;;###autoload -(defun widget-browse-at (pos) - "Browse the widget under point." - (interactive "d") - (let* ((field (get-char-property pos 'field)) - (button (get-char-property pos 'button)) - (doc (get-char-property pos 'widget-doc)) - (text (cond (field "This is an editable text area.") - (button "This is an active area.") - (doc "This is documentation text.") - (t "This is unidentified text."))) - (widget (or field button doc))) - (when widget - (widget-browse widget)) - (message text))) - -(defvar widget-browse-history nil) - -;;;###autoload -(defun widget-browse (widget) - "Create a widget browser for WIDGET." - (interactive (list (completing-read "Widget: " - obarray - (lambda (symbol) - (get symbol 'widget-type)) - t nil 'widget-browse-history))) - (if (stringp widget) - (setq widget (intern widget))) - (unless (if (symbolp widget) - (get widget 'widget-type) - (and (consp widget) - (get (widget-type widget) 'widget-type))) - (error "Not a widget.")) - ;; Create the buffer. - (if (symbolp widget) - (let ((buffer (format "*Browse %s Widget*" widget))) - (kill-buffer (get-buffer-create buffer)) - (switch-to-buffer (get-buffer-create buffer))) - (kill-buffer (get-buffer-create "*Browse Widget*")) - (switch-to-buffer (get-buffer-create "*Browse Widget*"))) - (widget-browse-mode) - - ;; Quick way to get out. -;; (widget-create 'push-button -;; :action (lambda (widget &optional event) -;; (bury-buffer)) -;; "Quit") -;; (widget-insert "\n") - - ;; Top text indicating whether it is a class or object browser. - (if (listp widget) - (widget-insert "Widget object browser.\n\nClass: ") - (widget-insert "Widget class browser.\n\n") - (widget-create 'widget-browse - :format "%[%v%]\n%d" - :doc (get widget 'widget-documentation) - widget) - (unless (eq (preceding-char) ?\n) - (widget-insert "\n")) - (widget-insert "\nSuper: ") - (setq widget (get widget 'widget-type))) - - ;; Now show the attributes. - (let ((name (car widget)) - (items (cdr widget)) - key value printer) - (widget-create 'widget-browse - :format "%[%v%]" - name) - (widget-insert "\n") - (while items - (setq key (nth 0 items) - value (nth 1 items) - printer (or (get key 'widget-keyword-printer) - 'widget-browse-sexp) - items (cdr (cdr items))) - (widget-insert "\n" (symbol-name key) "\n\t") - (funcall printer widget key value) - (widget-insert "\n"))) - (widget-setup) - (goto-char (point-min))) - -;;;###autoload -(defun widget-browse-other-window (&optional widget) - "Show widget browser for WIDGET in other window." - (interactive) - (let ((window (selected-window))) - (switch-to-buffer-other-window "*Browse Widget*") - (if widget - (widget-browse widget) - (call-interactively 'widget-browse)) - (select-window window))) - - -;;; The `widget-browse' Widget. - -(define-widget 'widget-browse 'push-button - "Button for creating a widget browser. -The :value of the widget shuld be the widget to be browsed." - :format "%[[%v]%]" - :value-create 'widget-browse-value-create - :action 'widget-browse-action) - -(defun widget-browse-action (widget &optional event) - ;; Create widget browser for WIDGET's :value. - (widget-browse (widget-get widget :value))) - -(defun widget-browse-value-create (widget) - ;; Insert type name. - (let ((value (widget-get widget :value))) - (cond ((symbolp value) - (insert (symbol-name value))) - ((consp value) - (insert (symbol-name (widget-type value)))) - (t - (insert "strange"))))) - -;;; Keyword Printer Functions. - -(defun widget-browse-widget (widget key value) - "Insert description of WIDGET's KEY VALUE. -VALUE is assumed to be a widget." - (widget-create 'widget-browse value)) - -(defun widget-browse-widgets (widget key value) - "Insert description of WIDGET's KEY VALUE. -VALUE is assumed to be a list of widgets." - (while value - (widget-create 'widget-browse - (car value)) - (setq value (cdr value)) - (when value - (widget-insert " ")))) - -(defun widget-browse-sexp (widget key value) - "Insert description of WIDGET's KEY VALUE. -Nothing is assumed about value." - (let ((pp (condition-case signal - (pp-to-string value) - (error (prin1-to-string signal))))) - (when (string-match "\n\\'" pp) - (setq pp (substring pp 0 (1- (length pp))))) - (if (cond ((string-match "\n" pp) - nil) - ((> (length pp) (- (window-width) (current-column))) - nil) - (t t)) - (widget-insert pp) - (widget-create 'push-button - :tag "show" - :action (lambda (widget &optional event) - (with-output-to-temp-buffer - "*Pp Eval Output*" - (princ (widget-get widget :value)))) - pp)))) - -(defun widget-browse-sexps (widget key value) - "Insert description of WIDGET's KEY VALUE. -VALUE is assumed to be a list of widgets." - (let ((target (current-column))) - (while value - (widget-browse-sexp widget key (car value)) - (setq value (cdr value)) - (when value - (widget-insert "\n" (make-string target ?\ )))))) - -;;; Keyword Printers. - -(put :parent 'widget-keyword-printer 'widget-browse-widget) -(put :children 'widget-keyword-printer 'widget-browse-widgets) -(put :buttons 'widget-keyword-printer 'widget-browse-widgets) -(put :button 'widget-keyword-printer 'widget-browse-widget) -(put :args 'widget-keyword-printer 'widget-browse-sexps) - -;;; Widget Minor Mode. - -(defvar widget-minor-mode nil - "I non-nil, we are in Widget Minor Mode.") - (make-variable-buffer-local 'widget-minor-mode) - -(defvar widget-minor-mode-map nil - "Keymap used in Widget Minor Mode.") - -(unless widget-minor-mode-map - (setq widget-minor-mode-map (make-sparse-keymap)) - (set-keymap-parent widget-minor-mode-map widget-keymap)) - -;;;###autoload -(defun widget-minor-mode (&optional arg) - "Togle minor mode for traversing widgets. -With arg, turn widget mode on if and only if arg is positive." - (interactive "P") - (cond ((null arg) - (setq widget-minor-mode (not widget-minor-mode))) - ((<= arg 0) - (setq widget-minor-mode nil)) - (t - (setq widget-minor-mode t))) - (force-mode-line-update)) - -(add-to-list 'minor-mode-alist '(widget-minor-mode " Widget")) - -(add-to-list 'minor-mode-map-alist - (cons 'widget-minor-mode widget-minor-mode-map)) - -;;; The End: - -(provide 'wid-browse) - -;; wid-browse.el ends here
--- a/lisp/custom/wid-edit.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,3640 +0,0 @@ -;;; wid-edit.el --- Functions for creating and using widgets. -;; -;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. -;; -;; Author: Per Abrahamsen <abraham@dina.kvl.dk> -;; Maintainer: Hrvoje Niksic <hniksic@srce.hr> -;; Keywords: extensions -;; Version: 1.9960-x -;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ - -;; 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. - -;;; Commentary: -;; -;; See `widget.el'. - - -;;; Code: - -(require 'widget) - -(autoload 'pp-to-string "pp") -(autoload 'finder-commentary "finder" nil t) - -;;; Customization. - -(defgroup widgets nil - "Customization support for the Widget Library." - :link '(custom-manual "(widget)Top") - :link '(url-link :tag "Development Page" - "http://www.dina.kvl.dk/~abraham/custom/") - :link '(emacs-library-link :tag "Lisp File" "widget.el") - :prefix "widget-" - :group 'extensions - :group 'hypermedia) - -(defgroup widget-documentation nil - "Options controling the display of documentation strings." - :group 'widgets) - -(defgroup widget-faces nil - "Faces used by the widget library." - :group 'widgets - :group 'faces) - -(defvar widget-documentation-face 'widget-documentation-face - "Face used for documentation strings in widges. -This exists as a variable so it can be set locally in certain buffers.") - -(defface widget-documentation-face '((((class color) - (background dark)) - (:foreground "lime green")) - (((class color) - (background light)) - (:foreground "dark green")) - (t nil)) - "Face used for documentation text." - :group 'widget-documentation - :group 'widget-faces) - -(defvar widget-button-face 'widget-button-face - "Face used for buttons in widges. -This exists as a variable so it can be set locally in certain buffers.") - -(defface widget-button-face '((t (:bold t))) - "Face used for widget buttons." - :group 'widget-faces) - -(defcustom widget-mouse-face 'highlight - "Face used for widget buttons when the mouse is above them." - :type 'face - :group 'widget-faces) - -(defface widget-field-face '((((class grayscale color) - (background light)) - (:background "gray85")) - (((class grayscale color) - (background dark)) - (:background "dim gray")) - (t - (:italic t))) - "Face used for editable fields." - :group 'widget-faces) - -;; Currently unused -;(defface widget-single-line-field-face '((((class grayscale color) -; (background light)) -; (:background "gray85")) -; (((class grayscale color) -; (background dark)) -; (:background "dim gray")) -; (t -; (:italic t))) -; "Face used for editable fields spanning only a single line." -; :group 'widget-faces) -; -;(defvar widget-single-line-display-table -; (let ((table (make-display-table))) -; (aset table 9 "^I") -; (aset table 10 "^J") -; table) -; "Display table used for single-line editable fields.") -; -;(set-face-display-table 'widget-single-line-field-face -; widget-single-line-display-table) - - -;; Some functions from this file have been ported to C for speed. -;; Setting this to t (*before* loading wid-edit.el) will make them -;; shadow the subrs. It should be used only for debugging purposes. -(defvar widget-shadow-subrs nil) - - -;;; Utility functions. -;; -;; These are not really widget specific. - -(when (or (not (fboundp 'widget-plist-member)) - widget-shadow-subrs) - ;; Recoded in C, for efficiency. It used to be a defsubst, but old - ;; compiled code won't fail -- it will just be slower. - (defun widget-plist-member (plist prop) - ;; Return non-nil if PLIST has the property PROP. - ;; PLIST is a property list, which is a list of the form - ;; (PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol. - ;; Unlike `plist-get', this allows you to distinguish between a missing - ;; property and a property with the value nil. - ;; The value is actually the tail of PLIST whose car is PROP. - (while (and plist (not (eq (car plist) prop))) - (setq plist (cddr plist))) - plist)) - -(defun widget-princ-to-string (object) - ;; Return string representation of OBJECT, any Lisp object. - ;; No quoting characters are used; no delimiters are printed around - ;; the contents of strings. - (with-current-buffer (get-buffer-create " *widget-tmp*") - (erase-buffer) - (princ object (current-buffer)) - (buffer-string))) - -(defun widget-clear-undo () - "Clear all undo information." - (buffer-disable-undo) - (buffer-enable-undo)) - -(defcustom widget-menu-max-size 40 - "Largest number of items allowed in a popup-menu. -Larger menus are read through the minibuffer." - :group 'widgets - :type 'integer) - -(defcustom widget-menu-minibuffer-flag nil - "*Control how to ask for a choice from the keyboard. -Non-nil means use the minibuffer; -nil means read a single character." - :group 'widgets - :type 'boolean) - -(defun widget-choose (title items &optional event) - "Choose an item from a list. - -First argument TITLE is the name of the list. -Second argument ITEMS is an list whose members are either - (NAME . VALUE), to indicate selectable items, or just strings to - indicate unselectable items. -Optional third argument EVENT is an input event. - -The user is asked to choose between each NAME from the items alist, -and the VALUE of the chosen element will be returned. If EVENT is a -mouse event, and the number of elements in items is less than -`widget-menu-max-size', a popup menu will be used, otherwise the -minibuffer." - (cond ((and (< (length items) widget-menu-max-size) - event - (console-on-window-system-p)) - ;; Pressed by the mouse. - (let ((val (get-popup-menu-response - (cons title - (mapcar (lambda (x) - (if (stringp x) - (vector x nil nil) - (vector (car x) (list (car x)) t))) - items))))) - (setq val (and val - (listp (event-object val)) - (stringp (car-safe (event-object val))) - (car (event-object val)))) - (cdr (assoc val items)))) - ((and (not widget-menu-minibuffer-flag) - ;; Can't handle more than 10 items (as many digits) - (<= (length items) 10)) - ;; Construct a menu of the choices - ;; and then use it for prompting for a single character. - (let* ((overriding-terminal-local-map (make-sparse-keymap)) - (map (make-sparse-keymap title)) - (next-digit ?0) - some-choice-enabled value) - ;; Define SPC as a prefix char to get to this menu. - (define-key overriding-terminal-local-map " " map) - (with-current-buffer (get-buffer-create " widget-choose") - (erase-buffer) - (insert "Available choices:\n\n") - (dolist (choice items) - (when (consp choice) - (let* ((name (car choice)) - (function (cdr choice))) - (insert (format "%c = %s\n" next-digit name)) - (define-key map (vector next-digit) function) - (setq some-choice-enabled t))) - ;; Allocate digits to disabled alternatives - ;; so that the digit of a given alternative never varies. - (incf next-digit)) - (insert "\nC-g = Quit")) - (or some-choice-enabled - (error "None of the choices is currently meaningful")) - (define-key map [?\C-g] 'keyboard-quit) - (define-key map [t] 'keyboard-quit) - ;(setcdr map (nreverse (cdr map))) - ;; Unread a SPC to lead to our new menu. - (push (character-to-event ?\ ) unread-command-events) - ;; Read a char with the menu, and return the result - ;; that corresponds to it. - (save-window-excursion - (display-buffer (get-buffer " widget-choose")) - (let ((cursor-in-echo-area t)) - (setq value - (lookup-key overriding-terminal-local-map - (read-key-sequence (concat title ": ") t))))) - (message "") - (when (or (eq value 'keyboard-quit) - (null value)) - (error "Canceled")) - value)) - (t - ;; Read the choice of name from the minibuffer. - (setq items (remove-if 'stringp items)) - (let ((val (completing-read (concat title ": ") items nil t))) - (if (stringp val) - (let ((try (try-completion val items))) - (when (stringp try) - (setq val try)) - (cdr (assoc val items))) - nil))))) - - -;;; Widget text specifications. -;; -;; These functions are for specifying text properties. - -(defcustom widget-field-add-space t - ;; Setting this to nil might be available, once some problems are resolved. - "Non-nil means add extra space at the end of editable text fields. - -This is needed on all versions of Emacs. If you don't add the space, -it will become impossible to edit a zero size field." - :type 'boolean - :group 'widgets) - -(defcustom widget-field-use-before-change - (and (or (> emacs-minor-version 34) - (> emacs-major-version 19)) - (not (string-match "XEmacs" emacs-version))) - "Non-nil means use `before-change-functions' to track editable fields. -This enables the use of undo, but doesn't work on Emacs 19.34 and earlier. -Using before hooks also means that the :notify function can't know the -new value." - :type 'boolean - :group 'widgets) - -(defun widget-specify-field (widget from to) - "Specify editable button for WIDGET between FROM and TO." - (save-excursion - (goto-char to) - (cond ((null (widget-get widget :size)) - (forward-char 1)) - ;; Terminating space is not part of the field, but necessary in - ;; order for local-map to work. Remove next sexp if local-map works - ;; at the end of the extent. - (widget-field-add-space - (insert-and-inherit " "))) - (setq to (point))) - (let ((map (widget-get widget :keymap)) - (face (or (widget-get widget :value-face) 'widget-field-face)) - (help-echo (widget-get widget :help-echo)) - (extent (make-extent from to))) - (unless (or (stringp help-echo) (null help-echo)) - (setq help-echo 'widget-mouse-help)) - (widget-put widget :field-extent extent) - (and (or (not widget-field-add-space) - (widget-get widget :size)) - (set-extent-property extent 'end-closed t)) - (set-extent-property extent 'detachable nil) - (set-extent-property extent 'field widget) - (set-extent-property extent 'button-or-field t) - (set-extent-property extent 'keymap map) - (set-extent-property extent 'face face) - (set-extent-property extent 'balloon-help help-echo) - (set-extent-property extent 'help-echo help-echo))) - -(defun widget-specify-button (widget from to) - "Specify button for WIDGET between FROM and TO." - (let ((face (widget-apply widget :button-face-get)) - (help-echo (widget-get widget :help-echo)) - (extent (make-extent from to)) - (map (widget-get widget :button-keymap))) - (widget-put widget :button-extent extent) - (unless (or (null help-echo) (stringp help-echo)) - (setq help-echo 'widget-mouse-help)) - (set-extent-property extent 'start-open t) - (set-extent-property extent 'button widget) - (set-extent-property extent 'button-or-field t) - (set-extent-property extent 'mouse-face widget-mouse-face) - (set-extent-property extent 'balloon-help help-echo) - (set-extent-property extent 'help-echo help-echo) - (set-extent-property extent 'face face) - (set-extent-property extent 'keymap map))) - -(defun widget-mouse-help (extent) - "Find mouse help string for button in extent." - (let* ((widget (widget-at (extent-start-position extent))) - (help-echo (and widget (widget-get widget :help-echo)))) - (cond ((stringp help-echo) - help-echo) - ((and (functionp help-echo) - (stringp (setq help-echo (funcall help-echo widget)))) - help-echo) - (t - (format "(widget %S :help-echo %S)" widget help-echo))))) - -(defun widget-specify-sample (widget from to) - ;; Specify sample for WIDGET between FROM and TO. - (let ((face (widget-apply widget :sample-face-get)) - (extent (make-extent from to nil))) - (set-extent-property extent 'start-open t) - (set-extent-property extent 'face face) - (widget-put widget :sample-extent extent))) - -(defun widget-specify-doc (widget from to) - ;; Specify documentation for WIDGET between FROM and TO. - (let ((extent (make-extent from to))) - (set-extent-property extent 'start-open t) - (set-extent-property extent 'widget-doc widget) - (set-extent-property extent 'face widget-documentation-face) - (widget-put widget :doc-extent extent))) - -(defmacro widget-specify-insert (&rest form) - ;; Execute FORM without inheriting any text properties. - `(save-restriction - (let ((inhibit-read-only t) - before-change-functions - after-change-functions) - (insert "<>") - (narrow-to-region (- (point) 2) (point)) - (goto-char (1+ (point-min))) - ;; We use `prog1' instead of a `result' variable, as the latter - ;; confuses the byte-compiler in some cases (a warning). - (prog1 (progn ,@form) - (delete-region (point-min) (1+ (point-min))) - (delete-region (1- (point-max)) (point-max)) - (goto-char (point-max)))))) - -(put 'widget-specify-insert 'edebug-form-spec '(&rest form)) - - -;;; Inactive Widgets. - -(defface widget-inactive-face '((((class grayscale color) - (background dark)) - (:foreground "light gray")) - (((class grayscale color) - (background light)) - (:foreground "dim gray")) - (t - (:italic t))) - "Face used for inactive widgets." - :group 'widget-faces) - -;; For inactiveness to work on complex structures, it is not -;; sufficient to keep track of whether a button/field/glyph is -;; inactive or not -- we must know how many time it was deactivated -;; (inactiveness level). Successive deactivations of the same button -;; increment its inactive-count, and activations decrement it. When -;; inactive-count reaches 0, the button/field/glyph is reactivated. - -(defun widget-activation-widget-mapper (extent action) - "Activate or deactivate EXTENT's widget (button or field). -Suitable for use with `map-extents'." - (ecase action - (:activate - (decf (extent-property extent :inactive-count)) - (when (zerop (extent-property extent :inactive-count)) - (set-extent-properties - extent (extent-property extent :inactive-plist)) - (set-extent-property extent :inactive-plist nil))) - (:deactivate - (incf (extent-property extent :inactive-count 0)) - ;; Store a plist of old properties, which will be fed to - ;; `set-extent-properties'. - (unless (extent-property extent :inactive-plist) - (set-extent-property - extent :inactive-plist - (list 'mouse-face (extent-property extent 'mouse-face) - 'help-echo (extent-property extent 'help-echo) - 'keymap (extent-property extent 'keymap))) - (set-extent-properties - extent '(mouse-face nil help-echo nil keymap nil))))) - nil) - -(defun widget-activation-glyph-mapper (extent action) - (let ((activate-p (if (eq action :activate) t nil))) - (if activate-p - (decf (extent-property extent :inactive-count)) - (incf (extent-property extent :inactive-count 0))) - (when (or (and activate-p - (zerop (extent-property extent :inactive-count))) - (and (not activate-p) - (not (zerop (extent-property extent :inactive-count))))) - (let* ((glyph-widget (extent-property extent 'glyph-widget)) - (up-glyph (widget-get glyph-widget :glyph-up)) - (inactive-glyph (widget-get glyph-widget :glyph-inactive)) - (new-glyph (if activate-p up-glyph inactive-glyph))) - ;; Check that the new glyph exists, and differs from the - ;; default one. - (and up-glyph inactive-glyph (not (eq up-glyph inactive-glyph)) - ;; Check if the glyph is already installed. - (not (eq (extent-end-glyph extent) new-glyph)) - ;; Change it. - (set-extent-end-glyph extent new-glyph))))) - nil) - -(defun widget-specify-inactive (widget from to) - "Make WIDGET inactive for user modifications." - (unless (widget-get widget :inactive) - (let ((extent (make-extent from to))) - ;; It is no longer necessary for the extent to be read-only, as - ;; the inactive editable fields now lose their keymaps. - (set-extent-properties - extent '(start-open t face widget-inactive-face - detachable t priority 2001 widget-inactive t)) - (widget-put widget :inactive extent)) - ;; Deactivate the buttons and fields within the range. In some - ;; cases, the fields are not yet setup at the time this function - ;; is called. Those fields are deactivated explicitly by - ;; `widget-setup'. - (map-extents 'widget-activation-widget-mapper - nil from to :deactivate nil 'button-or-field) - ;; Deactivate glyphs. - (map-extents 'widget-activation-glyph-mapper - nil from to :deactivate nil 'glyph-widget))) - -(defun widget-specify-active (widget) - "Make WIDGET active for user modifications." - (let ((inactive (widget-get widget :inactive))) - (when inactive - ;; Reactivate the buttons and fields covered by the extent. - (map-extents 'widget-activation-widget-mapper - inactive nil nil :activate nil 'button-or-field) - ;; Reactivate the glyphs. - (map-extents 'widget-activation-glyph-mapper - inactive nil nil :activate nil 'end-glyph) - (delete-extent inactive) - (widget-put widget :inactive nil)))) - - -;;; Widget Properties. - -(defsubst widget-type (widget) - "Return the type of WIDGET, a symbol." - (car widget)) - -(when (or (not (fboundp 'widget-put)) - widget-shadow-subrs) - (defun widget-put (widget property value) - "In WIDGET set PROPERTY to VALUE. -The value can later be retrived with `widget-get'." - (setcdr widget (plist-put (cdr widget) property value)))) - -;; Recoded in C, for efficiency: -(when (or (not (fboundp 'widget-get)) - widget-shadow-subrs) - (defun widget-get (widget property) - "In WIDGET, get the value of PROPERTY. -The value could either be specified when the widget was created, or -later with `widget-put'." - (let ((missing t) - value tmp) - (while missing - (cond ((setq tmp (widget-plist-member (cdr widget) property)) - (setq value (car (cdr tmp)) - missing nil)) - ((setq tmp (car widget)) - (setq widget (get tmp 'widget-type))) - (t - (setq missing nil)))) - value))) - -(defun widget-get-indirect (widget property) - "In WIDGET, get the value of PROPERTY. -If the value is a symbol, return its binding. -Otherwise, just return the value." - (let ((value (widget-get widget property))) - (if (symbolp value) - (symbol-value value) - value))) - -(defun widget-member (widget property) - "Non-nil iff there is a definition in WIDGET for PROPERTY." - (cond ((widget-plist-member (cdr widget) property) - t) - ((car widget) - (widget-member (get (car widget) 'widget-type) property)) - (t nil))) - -(when (or (not (fboundp 'widget-apply)) - widget-shadow-subrs) - ;;This is in C, so don't ###utoload - (defun widget-apply (widget property &rest args) - "Apply the value of WIDGET's PROPERTY to the widget itself. -ARGS are passed as extra arguments to the function." - (apply (widget-get widget property) widget args))) - -(defun widget-value (widget) - "Extract the current value of WIDGET." - (widget-apply widget - :value-to-external (widget-apply widget :value-get))) - -(defun widget-value-set (widget value) - "Set the current value of WIDGET to VALUE." - (widget-apply widget - :value-set (widget-apply widget - :value-to-internal value))) - -(defun widget-match-inline (widget vals) - ;; In WIDGET, match the start of VALS. - (cond ((widget-get widget :inline) - (widget-apply widget :match-inline vals)) - ((and vals - (widget-apply widget :match (car vals))) - (cons (list (car vals)) (cdr vals))) - (t nil))) - -(defun widget-apply-action (widget &optional event) - "Apply :action in WIDGET in response to EVENT." - (if (widget-apply widget :active) - (widget-apply widget :action event) - (error "Attempt to perform action on inactive widget"))) - - -;;; Helper functions. -;; -;; These are widget specific. - -;;;###autoload -(defun widget-prompt-value (widget prompt &optional value unbound) - "Prompt for a value matching WIDGET, using PROMPT. -The current value is assumed to be VALUE, unless UNBOUND is non-nil." - (unless (listp widget) - (setq widget (list widget))) - (setq prompt (format "[%s] %s" (widget-type widget) prompt)) - (setq widget (widget-convert widget)) - (let ((answer (widget-apply widget :prompt-value prompt value unbound))) - (unless (widget-apply widget :match answer) - (error "Value does not match %S type." (car widget))) - answer)) - -(defun widget-get-sibling (widget) - "Get the item WIDGET is assumed to toggle. -This is only meaningful for radio buttons or checkboxes in a list." - (let* ((parent (widget-get widget :parent)) - (children (widget-get parent :children)) - child) - (catch 'child - (while children - (setq child (car children) - children (cdr children)) - (when (eq (widget-get child :button) widget) - (throw 'child child))) - nil))) - -(defun widget-map-buttons (function &optional buffer maparg) - "Map FUNCTION over the buttons in BUFFER. -FUNCTION is called with the arguments WIDGET and MAPARG. - -If FUNCTION returns non-nil, the walk is cancelled. - -The arguments MAPARG, and BUFFER default to nil and (current-buffer), -respectively." - (map-extents (lambda (extent ignore) - ;; If FUNCTION returns non-nil, we bail out - (funcall function (extent-property extent 'button) maparg)) - nil nil nil nil nil - 'button)) - - -;;; Glyphs. - -(defcustom widget-glyph-directory (locate-data-directory "custom") - "Where widget glyphs are located. -If this variable is nil, widget will try to locate the directory -automatically." - :group 'widgets - :type 'directory) - -(defcustom widget-glyph-enable t - "If non nil, use glyphs in images when available." - :group 'widgets - :type 'boolean) - -(defcustom widget-image-conversion - '((xpm ".xpm") (gif ".gif") (png ".png") (jpeg ".jpg" ".jpeg") - (xbm ".xbm")) - "Conversion alist from image formats to file name suffixes." - :group 'widgets - :type '(repeat (cons :format "%v" - (symbol :tag "Image Format" unknown) - (repeat :tag "Suffixes" - (string :format "%v"))))) - -(defvar widget-glyph-cache nil - "Cache of glyphs associated with strings (files).") - -(defun widget-glyph-find (image tag) - "Create a glyph corresponding to IMAGE with string TAG as fallback. -IMAGE can already be a glyph, or a file name sans extension (xpm, - xbm, gif, jpg, or png) located in `widget-glyph-directory', or - in one of the data directories. -It can also be a valid image instantiator, in which case it will be - used to make the glyph, with an additional TAG string fallback." - (cond ((not (and image widget-glyph-enable - ;; We don't use glyphs on TTY consoles, although we - ;; could. However, glyph faces aren't yet working - ;; properly, and movement through glyphs is - ;; unintuitive. - (console-on-window-system-p))) - ;; We don't want to use glyphs. - nil) - ((glyphp image) - ;; Already a glyph. Use it. - image) - ((stringp image) - ;; A string. Look it up in the cache first... - (or (lax-plist-get widget-glyph-cache image) - ;; ...and then in the relevant directories - (let* ((dirlist (cons (or widget-glyph-directory - (locate-data-directory "custom")) - data-directory-list)) - (formats widget-image-conversion) - file) - (while (and formats (not file)) - ;; This dance is necessary, because XEmacs signals an - ;; error when it encounters an unrecognized image - ;; format. - (when (valid-image-instantiator-format-p (caar formats)) - (setq file (locate-file image dirlist - (mapconcat 'identity (cdar formats) - ":")))) - (unless file - (pop formats))) - (when file - ;; We create a glyph with the file as the default image - ;; instantiator, and the TAG fallback - (let ((glyph (make-glyph `([,(caar formats) :file ,file] - [string :data ,tag])))) - ;; Cache the glyph - (laxputf widget-glyph-cache image glyph) - ;; ...and return it - glyph))))) - ((valid-instantiator-p image 'image) - ;; A valid image instantiator (e.g. [gif :file "somefile"] etc.) - (make-glyph `(,image [string :data ,tag]))) - (t - ;; Oh well. - nil))) - -(defun widget-glyph-insert (widget tag image &optional down inactive) - "In WIDGET, insert the text TAG or, if supported, IMAGE. -IMAGE should either be a glyph, an image instantiator, an image file -name sans extension (xpm, xbm, gif, jpg, or png) located in -`widget-glyph-directory', or anything else allowed by -`widget-glyph-find'. - -If IMAGE is a list, it will be taken as a list of (UP DOWN INACTIVE) -glyphs. The down and inactive glyphs are shown when glyph is pressed -or inactive, respectively. - -The optional DOWN and INACTIVE arguments are deprecated, and exist -only because of compatibility." - ;; Convert between IMAGE being a list, etc. Must use `psetq', - ;; because otherwise change to `image' screws up the rest. - (psetq image (or (and (consp image) - (car image)) - image) - down (or (and (consp image) - (nth 1 image)) - down) - inactive (or (and (consp image) - (nth 2 image)) - inactive)) - (let ((glyph (widget-glyph-find image tag))) - (if glyph - (widget-glyph-insert-glyph widget glyph - (widget-glyph-find down tag) - (widget-glyph-find inactive tag)) - (insert tag)) - glyph)) - -(defun widget-glyph-insert-glyph (widget glyph &optional down inactive) - "In WIDGET, insert GLYPH. -If optional arguments DOWN and INACTIVE are given, they should be -glyphs used when the widget is pushed and inactive, respectively." - (insert "*") - (let ((extent (make-extent (point) (1- (point)))) - (help-echo (and widget (widget-get widget :help-echo))) - (map (and widget (widget-get widget :button-keymap)))) - (set-extent-property extent 'glyph-widget widget) - ;; It would be fun if we could make this extent atomic, so it - ;; doesn't mess with cursor motion. But atomic-extents library is - ;; currently a mess, so I'd rather not use it. - (set-extent-property extent 'invisible t) - (set-extent-property extent 'start-open t) - (set-extent-property extent 'end-open t) - (set-extent-property extent 'keymap map) - (set-extent-end-glyph extent glyph) - (unless (or (stringp help-echo) (null help-echo)) - (setq help-echo 'widget-mouse-help)) - (when help-echo - (set-extent-property extent 'balloon-help help-echo) - (set-extent-property extent 'help-echo help-echo))) - (when widget - (widget-put widget :glyph-up glyph) - (when down (widget-put widget :glyph-down down)) - (when inactive (widget-put widget :glyph-inactive inactive)))) - - -;;; Buttons. - -(defgroup widget-button nil - "The look of various kinds of buttons." - :group 'widgets) - -(defcustom widget-button-prefix "" - "String used as prefix for buttons." - :type 'string - :group 'widget-button) - -(defcustom widget-button-suffix "" - "String used as suffix for buttons." - :type 'string - :group 'widget-button) - - -;;; Creating Widgets. - -;;;###autoload -(defun widget-create (type &rest args) - "Create widget of TYPE. -The optional ARGS are additional keyword arguments." - (let ((widget (apply 'widget-convert type args))) - (widget-apply widget :create) - widget)) - -(defun widget-create-child-and-convert (parent type &rest args) - "As part of the widget PARENT, create a child widget TYPE. -The child is converted, using the keyword arguments ARGS." - (let ((widget (apply 'widget-convert type args))) - (widget-put widget :parent parent) - (unless (widget-get widget :indent) - (widget-put widget :indent (+ (or (widget-get parent :indent) 0) - (or (widget-get widget :extra-offset) 0) - (widget-get parent :offset)))) - (widget-apply widget :create) - widget)) - -(defun widget-create-child (parent type) - "Create widget of TYPE." - (let ((widget (copy-sequence type))) - (widget-put widget :parent parent) - (unless (widget-get widget :indent) - (widget-put widget :indent (+ (or (widget-get parent :indent) 0) - (or (widget-get widget :extra-offset) 0) - (widget-get parent :offset)))) - (widget-apply widget :create) - widget)) - -(defun widget-create-child-value (parent type value) - "Create widget of TYPE with value VALUE." - (let ((widget (copy-sequence type))) - (widget-put widget :value (widget-apply widget :value-to-internal value)) - (widget-put widget :parent parent) - (unless (widget-get widget :indent) - (widget-put widget :indent (+ (or (widget-get parent :indent) 0) - (or (widget-get widget :extra-offset) 0) - (widget-get parent :offset)))) - (widget-apply widget :create) - widget)) - -;;;###autoload -(defun widget-delete (widget) - "Delete WIDGET." - (widget-apply widget :delete)) - -(defun widget-convert (type &rest args) - "Convert TYPE to a widget without inserting it in the buffer. -The optional ARGS are additional keyword arguments." - ;; Don't touch the type. - (let* ((widget (if (symbolp type) - (list type) - (copy-sequence type))) - (current widget) - (keys args)) - ;; First set the :args keyword. - (while (cdr current) ;Look in the type. - (let ((next (car (cdr current)))) - (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:)) - (setq current (cdr (cdr current))) - (setcdr current (list :args (cdr current))) - (setq current nil)))) - (while args ;Look in the args. - (let ((next (nth 0 args))) - (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:)) - (setq args (nthcdr 2 args)) - (widget-put widget :args args) - (setq args nil)))) - ;; Then Convert the widget. - (setq type widget) - (while type - (let ((convert-widget (plist-get (cdr type) :convert-widget))) - (if convert-widget - (setq widget (funcall convert-widget widget)))) - (setq type (get (car type) 'widget-type))) - ;; Finally set the keyword args. - (while keys - (let ((next (nth 0 keys))) - (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:)) - (progn - (widget-put widget next (nth 1 keys)) - (setq keys (nthcdr 2 keys))) - (setq keys nil)))) - ;; Convert the :value to internal format. - (if (widget-member widget :value) - (let ((value (widget-get widget :value))) - (widget-put widget - :value (widget-apply widget :value-to-internal value)))) - ;; Return the newly created widget. - widget)) - -(defun widget-insert (&rest args) - "Call `insert' with ARGS and make the text read only." - (let ((inhibit-read-only t) - before-change-functions - after-change-functions) - (apply 'insert args))) - -(defun widget-convert-text (type from to - &optional button-from button-to - &rest args) - "Return a widget of type TYPE with endpoint FROM TO. -Optional ARGS are extra keyword arguments for TYPE. -and TO will be used as the widgets end points. If optional arguments -BUTTON-FROM and BUTTON-TO are given, these will be used as the widgets -button end points. -Optional ARGS are extra keyword arguments for TYPE." - (let ((widget (apply 'widget-convert type :delete 'widget-leave-text args)) - (from (copy-marker from)) - (to (copy-marker to))) - (set-marker-insertion-type from t) - (set-marker-insertion-type to nil) - (widget-put widget :from from) - (widget-put widget :to to) - (when button-from - (widget-specify-button widget button-from button-to)) - widget)) - -(defun widget-convert-button (type from to &rest args) - "Return a widget of type TYPE with endpoint FROM TO. -Optional ARGS are extra keyword arguments for TYPE. -No text will be inserted to the buffer, instead the text between FROM -and TO will be used as the widgets end points, as well as the widgets -button end points." - (apply 'widget-convert-text type from to from to args)) - -(defun widget-leave-text (widget) - "Remove markers and extents from WIDGET and its children." - (let ((from (widget-get widget :from)) - (to (widget-get widget :to)) - (button (widget-get widget :button-extent)) - (sample (widget-get widget :sample-extent)) - (doc (widget-get widget :doc-extent)) - (field (widget-get widget :field-extent)) - (children (widget-get widget :children))) - (set-marker from nil) - (set-marker to nil) - ;; Maybe we should delete the extents here? As this code doesn't - ;; remove them from widget structures, maybe it's safer to just - ;; detach them. That's what `delete-overlay' did. - (when button - (detach-extent button)) - (when sample - (detach-extent sample)) - (when doc - (detach-extent doc)) - (when field - (detach-extent field)) - (mapc 'widget-leave-text children))) - - -;;; Keymap and Commands. - -(defvar widget-keymap nil - "Keymap containing useful binding for buffers containing widgets. -Recommended as a parent keymap for modes using widgets.") - -(unless widget-keymap - (setq widget-keymap (make-sparse-keymap)) - (define-key widget-keymap [tab] 'widget-forward) - (define-key widget-keymap [(shift tab)] 'widget-backward) - (define-key widget-keymap [(meta tab)] 'widget-backward) - (define-key widget-keymap [backtab] 'widget-backward)) - -(defvar widget-global-map global-map - "Keymap used for events the widget does not handle themselves.") -(make-variable-buffer-local 'widget-global-map) - -(defvar widget-field-keymap nil - "Keymap used inside an editable field.") - -(unless widget-field-keymap - (setq widget-field-keymap (make-sparse-keymap)) - (set-keymap-parents widget-field-keymap global-map) - (define-key widget-field-keymap "\C-k" 'widget-kill-line) - (define-key widget-field-keymap [(meta tab)] 'widget-complete) - (define-key widget-field-keymap [tab] 'widget-forward) - (define-key widget-field-keymap [(shift tab)] 'widget-backward) - (define-key widget-field-keymap "\C-m" 'widget-field-activate) - (define-key widget-field-keymap "\C-a" 'widget-beginning-of-line) - (define-key widget-field-keymap "\C-e" 'widget-end-of-line) - (define-key widget-field-keymap "\C-t" 'widget-transpose-chars)) - -(defvar widget-text-keymap nil - "Keymap used inside a text field.") - -(unless widget-text-keymap - (setq widget-text-keymap (make-sparse-keymap)) - (set-keymap-parents widget-field-keymap global-map) - (define-key widget-text-keymap "\C-a" 'widget-beginning-of-line) - (define-key widget-text-keymap "\C-e" 'widget-end-of-line) - (define-key widget-text-keymap "\C-t" 'widget-transpose-chars)) - -(defvar widget-button-keymap nil - "Keymap used inside a button.") - -(unless widget-button-keymap - (setq widget-button-keymap (make-sparse-keymap)) - (set-keymap-parents widget-button-keymap widget-keymap) - (define-key widget-button-keymap "\C-m" 'widget-button-press) - (define-key widget-button-keymap [button2] 'widget-button-click) - ;; Ideally, button3 within a button should invoke a button-specific - ;; menu. - (define-key widget-button-keymap [button3] 'widget-button-click) - ;;Glyph support. - (define-key widget-button-keymap [button1] 'widget-button1-click)) - - -(defun widget-field-activate (pos &optional event) - "Invoke the ediable field at point." - (interactive "@d") - (let ((field (widget-field-find pos))) - (if field - (widget-apply-action field event) - (call-interactively - (lookup-key widget-global-map (this-command-keys)))))) - -(defface widget-button-pressed-face - '((((class color)) - (:foreground "red")) - (t - (:bold t :underline t))) - "Face used for pressed buttons." - :group 'widget-faces) - -(defun widget-event-point (event) - "Character position of the mouse event, or nil." - (and (mouse-event-p event) - (event-point event))) - -(defun widget-button-click (event) - "Invoke button below mouse pointer." - (interactive "@e") - (cond ((event-glyph event) - (widget-glyph-click event)) - ((widget-event-point event) - (let* ((pos (widget-event-point event)) - (button (get-char-property pos 'button))) - (if button - (let* ((extent (widget-get button :button-extent)) - (face (extent-property extent 'face)) - (mouse-face (extent-property extent 'mouse-face)) - (help-echo (extent-property extent 'help-echo))) - (unwind-protect - (progn - ;; Merge relevant faces, and make the result mouse-face. - (let ((merge `(widget-button-pressed-face ,mouse-face))) - (nconc merge (if (listp face) - face (list face))) - (setq merge (delete-if-not 'find-face merge)) - (set-extent-property extent 'mouse-face merge)) - (unless (widget-apply button :mouse-down-action event) - ;; Wait for button release. - (while (not (button-release-event-p - (setq event (next-event)))) - (dispatch-event event))) - ;; Disallow mouse-face and help-echo. - (set-extent-property extent 'mouse-face nil) - (set-extent-property extent 'help-echo nil) - (setq pos (widget-event-point event)) - (unless (eq (current-buffer) (extent-object extent)) - ;; Barf if dispatch-event tripped us by - ;; changing buffer. - (error "Buffer changed during mouse motion")) - ;; Do the associated action. - (when (and pos (extent-in-region-p extent pos pos)) - (widget-apply-action button event))) - ;; Unwinding: fully release the button. - (set-extent-property extent 'mouse-face mouse-face) - (set-extent-property extent 'help-echo help-echo))) - ;; This should not happen! - (error "`widget-button-click' called outside button")))) - (t - (message "You clicked somewhere weird")))) - -(defun widget-button1-click (event) - "Invoke glyph below mouse pointer." - (interactive "@e") - (if (event-glyph event) - (widget-glyph-click event) - ;; Should somehow avoid this. - (let ((command (lookup-key widget-global-map (this-command-keys)))) - (and (commandp command) - (call-interactively command))))) - -(defun widget-glyph-click (event) - "Handle click on a glyph." - (let* ((glyph (event-glyph event)) - (extent (event-glyph-extent event)) - (widget (extent-property extent 'glyph-widget)) - (down-glyph (or (and widget (widget-get widget :glyph-down)) glyph)) - (up-glyph (or (and widget (widget-get widget :glyph-up)) glyph)) - (last event)) - (unless (widget-apply widget :active) - (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? - (unwind-protect - (progn - ;; Press the glyph. - (set-extent-end-glyph extent down-glyph) - ;; Redisplay (shouldn't be needed, but...) - (sit-for 0) - (unless (widget-apply widget :mouse-down-action event) - ;; Wait for the release. - (while (not (button-release-event-p last)) - (unless (button-press-event-p last) - (dispatch-event last)) - (when (motion-event-p last) - ;; Update glyphs on mouse motion. - (if (eq extent (event-glyph-extent last)) - (unless (eq current-glyph 'down) - (set-extent-end-glyph extent down-glyph) - (setq current-glyph 'down)) - (unless (eq current-glyph 'up) - (set-extent-end-glyph extent up-glyph) - (setq current-glyph 'up)))) - (setq last (next-event event)))) - (unless (eq (current-buffer) (extent-object extent)) - ;; Barf if dispatch-event tripped us by changing buffer. - (error "Buffer changed during mouse motion")) - ;; Apply widget action. - (when (eq extent (event-glyph-extent last)) - (let ((widget (extent-property (event-glyph-extent event) - 'glyph-widget))) - (cond ((null widget) - (message "You clicked on a glyph")) - ((not (widget-apply widget :active)) - (error "This glyph is inactive")) - (t - (widget-apply-action widget event)))))) - ;; Release the glyph. - (and (eq current-glyph 'down) - ;; The extent might have been detached or deleted - (extent-live-p extent) - (not (extent-detached-p extent)) - (set-extent-end-glyph extent up-glyph)))))) - -(defun widget-button-press (pos &optional event) - "Invoke button at POS." - (interactive "@d") - (let ((button (get-char-property pos 'button))) - (if button - (widget-apply-action button event) - (let ((command (lookup-key widget-global-map (this-command-keys)))) - (when (commandp command) - (call-interactively command)))))) - -(defun widget-tabable-at (&optional pos last-tab backwardp) - "Return the tabable widget at POS, or nil. -POS defaults to the value of (point)." - (unless pos - (setq pos (point))) - (let ((widget (widget-at pos))) - (if widget - (let ((order (widget-get widget :tab-order))) - (if order - (if last-tab (and (= order (if backwardp - (1- last-tab) - (1+ last-tab))) - widget) - (and (> order 0) widget)) - widget)) - nil))) - -;; Return the button or field extent at point. -(defun widget-button-or-field-extent (pos) - (or (and (get-char-property pos 'button) - (widget-get (get-char-property pos 'button) - :button-extent)) - (and (get-char-property pos 'field) - (widget-get (get-char-property pos 'field) - :field-extent)))) - -(defun widget-next-button-or-field (pos) - "Find the next button, or field, and return its start position, or nil. -Internal function, don't use it outside `wid-edit'." - (let* ((at-point (widget-button-or-field-extent pos)) - (extent (map-extents - (lambda (ext ignore) - ext) - nil (if at-point (extent-end-position at-point) pos) - nil nil 'start-open 'button-or-field))) - (and extent - (extent-start-position extent)))) - -;; This is too slow in buffers with many buttons (W3). -(defun widget-previous-button-or-field (pos) - "Find the previous button, or field, and return its start position, or nil. -Internal function, don't use it outside `wid-edit'." - (let* ((at-point (widget-button-or-field-extent pos)) - previous-extent) - (map-extents - (lambda (ext ignore) - (if (eq ext at-point) - ;; We reached the extent we were on originally - (if (= pos (extent-start-position at-point)) - previous-extent - (setq previous-extent at-point)) - (setq previous-extent ext) - nil)) - nil nil pos nil 'start-open 'button-or-field) - (and previous-extent - (extent-start-position previous-extent)))) - -(defun widget-move (arg) - "Move point to the ARG next field or button. -ARG may be negative to move backward." - (let ((opoint (point)) (wrapped 0) - (last-tab (widget-get (widget-at (point)) :tab-order)) - nextpos found) - ;; Movement backward - (while (< arg 0) - (setq nextpos (widget-previous-button-or-field (point))) - (if nextpos - (progn - (goto-char nextpos) - (when (and (not (get-char-property nextpos 'widget-inactive)) - (widget-tabable-at nil last-tab t)) - (incf arg) - (setq found t - last-tab (widget-get (widget-at (point)) - :tab-order)))) - (if (and (not found) (> wrapped 1)) - (setq arg 0 - found nil) - (goto-char (point-max)) - (incf wrapped)))) - ;; Movement forward - (while (> arg 0) - (setq nextpos (widget-next-button-or-field (point))) - (if nextpos - (progn - (goto-char nextpos) - (when (and (not (get-char-property nextpos 'widget-inactive)) - (widget-tabable-at nil last-tab)) - (decf arg) - (setq found t - last-tab (widget-get (widget-at (point)) - :tab-order)))) - (if (and (not found) (> wrapped 1)) - (setq arg 0 - found nil) - (goto-char (point-min)) - (incf wrapped)))) - (if (not found) - (goto-char opoint) - (widget-echo-help (point)) - (run-hooks 'widget-move-hook)))) - -(defun widget-forward (arg) - "Move point to the next field or button. -With optional ARG, move across that many fields." - (interactive "p") - (run-hooks 'widget-forward-hook) - (widget-move arg)) - -(defun widget-backward (arg) - "Move point to the previous field or button. -With optional ARG, move across that many fields." - (interactive "p") - (run-hooks 'widget-backward-hook) - (widget-move (- arg))) - -(defun widget-beginning-of-line () - "Go to beginning of field or beginning of line, whichever is first." - (interactive "_") - (let* ((field (widget-field-find (point))) - (start (and field (widget-field-start field)))) - (if (and start (not (eq start (point)))) - (goto-char start) - (call-interactively 'beginning-of-line)))) - -(defun widget-end-of-line () - "Go to end of field or end of line, whichever is first." - (interactive "_") - (let* ((field (widget-field-find (point))) - (end (and field (widget-field-end field)))) - (if (and end (not (eq end (point)))) - (goto-char end) - (call-interactively 'end-of-line)))) - -(defun widget-kill-line () - "Kill to end of field or end of line, whichever is first." - (interactive) - (let* ((field (widget-field-find (point))) - (newline (save-excursion (forward-line 1) (point))) - (end (and field (widget-field-end field)))) - (if (and field (> newline end)) - (kill-region (point) end) - (call-interactively 'kill-line)))) - -(defun widget-transpose-chars (arg) - "Like `transpose-chars', but works correctly at end of widget." - (interactive "*P") - (let* ((field (widget-field-find (point))) - (start (and field (widget-field-start field))) - (end (and field (widget-field-end field))) - (last-non-space (and start end - (save-excursion - (goto-char end) - (skip-chars-backward " \t\n" start) - (point))))) - (cond ((and last-non-space - (or (= last-non-space start) - (= last-non-space (1+ start)))) - ;; empty or one-character field - nil) - ((= (point) start) - ;; at the beginning of the field -- we would get an error here. - (error "Cannot transpose at beginning of field")) - (t - (when (and (null arg) - (= last-non-space (point))) - (forward-char -1)) - (transpose-chars arg))))) - -(defcustom widget-complete-field (lookup-key global-map "\M-\t") - "Default function to call for completion inside fields." - :options '(ispell-complete-word complete-tag lisp-complete-symbol) - :type 'function - :group 'widgets) - -(defun widget-complete () - "Complete content of editable field from point. -When not inside a field, move to the previous button or field." - (interactive) - (let ((field (widget-field-find (point)))) - (if field - (widget-apply field :complete) - (error "Not in an editable field")))) - - -;;; Setting up the buffer. - -(defvar widget-field-new nil) -;; List of all newly created editable fields in the buffer. -(make-variable-buffer-local 'widget-field-new) - -(defvar widget-field-list nil) -;; List of all editable fields in the buffer. -(make-variable-buffer-local 'widget-field-list) - -(defun widget-setup () - "Setup current buffer so editing string widgets works." - (let ((inhibit-read-only t) - (after-change-functions nil) - before-change-functions - field) - (while widget-field-new - (setq field (car widget-field-new) - widget-field-new (cdr widget-field-new) - widget-field-list (cons field widget-field-list)) - (let ((from (car (widget-get field :field-extent))) - (to (cdr (widget-get field :field-extent)))) - (widget-specify-field field - (marker-position from) (marker-position to)) - (set-marker from nil) - (set-marker to nil)) - ;; If the field is placed within the inactive zone, deactivate it. - (let ((extent (widget-get field :field-extent))) - (when (get-char-property (extent-start-position extent) - 'widget-inactive) - (widget-activation-widget-mapper extent :deactivate))))) - (widget-clear-undo) - (widget-add-change)) - -(defvar widget-field-last nil) -;; Last field containing point. -(make-variable-buffer-local 'widget-field-last) - -(defvar widget-field-was nil) -;; The widget data before the change. -(make-variable-buffer-local 'widget-field-was) - -(defun widget-field-buffer (widget) - "Return the start of WIDGET's editing field." - (let ((extent (widget-get widget :field-extent))) - (and extent (extent-object extent)))) - -(defun widget-field-start (widget) - "Return the start of WIDGET's editing field." - (let ((extent (widget-get widget :field-extent))) - (and extent (extent-start-position extent)))) - -(defun widget-field-end (widget) - "Return the end of WIDGET's editing field." - (let ((extent (widget-get widget :field-extent))) - ;; Don't subtract one if local-map works at the end of the extent. - (and extent (if (or widget-field-add-space - (null (widget-get widget :size))) - (1- (extent-end-position extent)) - (extent-end-position extent))))) - -(defun widget-field-find (pos) - "Return the field at POS. -Unlike (get-char-property POS 'field) this, works with empty fields too." - (let ((field-extent (map-extents (lambda (extent ignore) - extent) - nil pos pos nil nil 'field))) - (and field-extent - (extent-property field-extent 'field)))) - -;; Old version, without `map-extents'. -;(defun widget-field-find (pos) -; (let ((fields widget-field-list) -; field found) -; (while fields -; (setq field (car fields) -; fields (cdr fields)) -; (let ((start (widget-field-start field)) -; (end (widget-field-end field))) -; (when (and (<= start pos) (<= pos end)) -; (when found -; (debug "Overlapping fields")) -; (setq found field)))) -; found)) - -(defun widget-before-change (from to) - ;; Barf if the text changed is outside the editable fields. - (unless inhibit-read-only - (let ((from-field (widget-field-find from)) - (to-field (widget-field-find to))) - (cond ((or (null from-field) - (null to-field)) - ;; Either end of change is not within a field. - (add-hook 'post-command-hook 'widget-add-change nil t) - (error "Attempt to change text outside editable field")) - ((not (eq from-field to-field)) - ;; The change begins in one fields, and ends in another one. - (add-hook 'post-command-hook 'widget-add-change nil t) - (error "Change should be restricted to a single field")) - (widget-field-use-before-change - ;; #### Bletch! This loses because XEmacs get confused - ;; if before-change-functions change the contents of - ;; buffer before from/to. - (condition-case nil - (widget-apply from-field :notify from-field) - (error (debug "Before Change")))))))) - -(defun widget-add-change () - (make-local-hook 'post-command-hook) - (remove-hook 'post-command-hook 'widget-add-change t) - (make-local-hook 'before-change-functions) - (add-hook 'before-change-functions 'widget-before-change nil t) - (make-local-hook 'after-change-functions) - (add-hook 'after-change-functions 'widget-after-change nil t)) - -(defun widget-after-change (from to old) - ;; Adjust field size and text properties. - - ;; Also, notify the widgets (so, for example, a variable changes its - ;; state to `modified'. when it is being edited.) - (condition-case nil - (let ((field (widget-field-find from)) - (other (widget-field-find to))) - (when field - (unless (eq field other) - (debug "Change in different fields")) - (let ((size (widget-get field :size)) - (secret (widget-get field :secret))) - (when size - (let ((begin (widget-field-start field)) - (end (widget-field-end field))) - (cond ((< (- end begin) size) - ;; Field too small. - (save-excursion - (goto-char end) - (insert-char ?\ (- (+ begin size) end)))) - ((> (- end begin) size) - ;; Field too large and - (if (or (< (point) (+ begin size)) - (> (point) end)) - ;; Point is outside extra space. - (setq begin (+ begin size)) - ;; Point is within the extra space. - (setq begin (point))) - (save-excursion - (goto-char end) - (while (and (eq (preceding-char) ?\ ) - (> (point) begin)) - (delete-backward-char 1))))))) - (when secret - (let ((begin (widget-field-start field)) - (end (widget-field-end field))) - (when size - (while (and (> end begin) - (eq (char-after (1- end)) ?\ )) - (setq end (1- end)))) - (while (< begin end) - (let ((old (char-after begin))) - (unless (eq old secret) - (subst-char-in-region begin (1+ begin) old secret) - (put-text-property begin (1+ begin) 'secret old)) - (incf begin)))))) - (widget-apply field :notify field))) - (error (debug "After Change")))) - - -;;; Widget Functions -;; -;; These functions are used in the definition of multiple widgets. - -(defun widget-parent-action (widget &optional event) - "Tell :parent of WIDGET to handle the :action. -Optional EVENT is the event that triggered the action." - (widget-apply (widget-get widget :parent) :action event)) - -(defun widget-children-value-delete (widget) - "Delete all :children and :buttons in WIDGET." - (mapc 'widget-delete (widget-get widget :children)) - (widget-put widget :children nil) - (mapc 'widget-delete (widget-get widget :buttons)) - (widget-put widget :buttons nil)) - -(defun widget-children-validate (widget) - "All the :children must be valid." - (let ((children (widget-get widget :children)) - child found) - (while (and children (not found)) - (setq child (car children) - children (cdr children) - found (widget-apply child :validate))) - found)) - -(defun widget-types-convert-widget (widget) - "Convert :args as widget types in WIDGET." - (widget-put widget :args (mapcar 'widget-convert (widget-get widget :args))) - widget) - -(defun widget-value-convert-widget (widget) - "Initialize :value from :args in WIDGET." - (let ((args (widget-get widget :args))) - (when args - (widget-put widget :value (car args)) - ;; Don't convert :value here, as this is done in `widget-convert'. - ;; (widget-put widget :value (widget-apply widget - ;; :value-to-internal (car args))) - (widget-put widget :args nil))) - widget) - -(defun widget-value-value-get (widget) - "Return the :value property of WIDGET." - (widget-get widget :value)) - -;;; The `default' Widget. - -(define-widget 'default nil - "Basic widget other widgets are derived from." - :value-to-internal (lambda (widget value) value) - :value-to-external (lambda (widget value) value) - :button-prefix 'widget-button-prefix - :button-suffix 'widget-button-suffix - :complete 'widget-default-complete - :create 'widget-default-create - :indent nil - :offset 0 - :format-handler 'widget-default-format-handler - :button-face-get 'widget-default-button-face-get - :sample-face-get 'widget-default-sample-face-get - :button-keymap widget-button-keymap - :delete 'widget-default-delete - :value-set 'widget-default-value-set - :value-inline 'widget-default-value-inline - :menu-tag-get 'widget-default-menu-tag-get - :validate (lambda (widget) nil) - :active 'widget-default-active - :activate 'widget-specify-active - :deactivate 'widget-default-deactivate - :mouse-down-action (lambda (widget event) nil) - :action 'widget-default-action - :notify 'widget-default-notify - :prompt-value 'widget-default-prompt-value) - -(defun widget-default-complete (widget) - "Call the value of the :complete-function property of WIDGET. -If that does not exists, call the value of `widget-complete-field'." - (let ((fun (widget-get widget :complete-function))) - (call-interactively (or fun widget-complete-field)))) - -(defun widget-default-create (widget) - "Create WIDGET at point in the current buffer." - (widget-specify-insert - (let ((from (point)) - button-begin button-end button-glyph - sample-begin sample-end - doc-begin doc-end - value-pos) - (insert (widget-get widget :format)) - (goto-char from) - ;; Parse escapes in format. Coding this in C would speed up - ;; things *a lot*. - (while (re-search-forward "%\\(.\\)" nil t) - (let ((escape (aref (match-string 1) 0))) - (replace-match "" t t) - (cond ((eq escape ?%) - (insert "%")) - ((eq escape ?\[) - (setq button-begin (point-marker)) - (set-marker-insertion-type button-begin nil)) - ((eq escape ?\]) - (setq button-end (point-marker)) - (set-marker-insertion-type button-end nil)) - ((eq escape ?\{) - (setq sample-begin (point))) - ((eq escape ?\}) - (setq sample-end (point))) - ((eq escape ?n) - (when (widget-get widget :indent) - (insert "\n") - (insert-char ?\ (widget-get widget :indent)))) - ((eq escape ?t) - (let* ((tag (widget-get widget :tag)) - (glyph (widget-get widget :tag-glyph))) - (cond (glyph - (setq button-glyph - (widget-glyph-insert - widget (or tag "Image") glyph))) - (tag - (insert tag)) - (t - (let ((standard-output (current-buffer))) - (princ (widget-get widget :value))))))) - ((eq escape ?d) - (let ((doc (widget-get widget :doc))) - (when doc - (setq doc-begin (point)) - (insert doc) - (while (eq (preceding-char) ?\n) - (delete-backward-char 1)) - (insert "\n") - (setq doc-end (point))))) - ((eq escape ?v) - (if (and button-begin (not button-end)) - (widget-apply widget :value-create) - (setq value-pos (point-marker)))) - (t - (widget-apply widget :format-handler escape))))) - ;; Specify button, sample, and doc, and insert value. - (when (and button-begin button-end) - (unless button-glyph - (goto-char button-begin) - (insert (widget-get-indirect widget :button-prefix)) - (goto-char button-end) - (set-marker-insertion-type button-end t) - (insert (widget-get-indirect widget :button-suffix))) - (widget-specify-button widget button-begin button-end) - ;; Is this necessary? - (set-marker button-begin nil) - (set-marker button-end nil)) - (and sample-begin sample-end - (widget-specify-sample widget sample-begin sample-end)) - (and doc-begin doc-end - (widget-specify-doc widget doc-begin doc-end)) - (when value-pos - (goto-char value-pos) - (widget-apply widget :value-create))) - (let ((from (point-min-marker)) - (to (point-max-marker))) - (set-marker-insertion-type from t) - (set-marker-insertion-type to nil) - (widget-put widget :from from) - (widget-put widget :to to))) - (widget-clear-undo)) - -(defun widget-default-format-handler (widget escape) - ;; We recognize the %h escape by default. - (let* ((buttons (widget-get widget :buttons))) - (cond ((eq escape ?h) - (let* ((doc-property (widget-get widget :documentation-property)) - (doc-try (cond ((widget-get widget :doc)) - ((symbolp doc-property) - (documentation-property - (widget-get widget :value) - doc-property)) - (t - (funcall doc-property - (widget-get widget :value))))) - (doc-text (and (stringp doc-try) - (> (length doc-try) 1) - doc-try)) - (doc-indent (widget-get widget :documentation-indent))) - (when doc-text - (and (eq (preceding-char) ?\n) - (widget-get widget :indent) - (insert-char ?\ (widget-get widget :indent))) - ;; The `*' in the beginning is redundant. - (when (eq (aref doc-text 0) ?*) - (setq doc-text (substring doc-text 1))) - ;; Get rid of trailing newlines. - (when (string-match "\n+\\'" doc-text) - (setq doc-text (substring doc-text 0 (match-beginning 0)))) - (push (widget-create-child-and-convert - widget 'documentation-string - :indent (cond ((numberp doc-indent) - doc-indent) - ((null doc-indent) - nil) - (t 0)) - doc-text) - buttons)))) - (t - (error "Unknown escape `%c'" escape))) - (widget-put widget :buttons buttons))) - -(defun widget-default-button-face-get (widget) - ;; Use :button-face or widget-button-face - (or (widget-get widget :button-face) - (let ((parent (widget-get widget :parent))) - (if parent - (widget-apply parent :button-face-get) - widget-button-face)))) - -(defun widget-default-sample-face-get (widget) - ;; Use :sample-face. - (widget-get widget :sample-face)) - -(defun widget-default-delete (widget) - ;; Remove widget from the buffer. - (let ((from (widget-get widget :from)) - (to (widget-get widget :to)) - (inactive-extent (widget-get widget :inactive)) - (button-extent (widget-get widget :button-extent)) - (sample-extent (widget-get widget :sample-extent)) - (doc-extent (widget-get widget :doc-extent)) - before-change-functions - after-change-functions - (inhibit-read-only t)) - (widget-apply widget :value-delete) - (when inactive-extent - (detach-extent inactive-extent)) - (when button-extent - (detach-extent button-extent)) - (when sample-extent - (detach-extent sample-extent)) - (when doc-extent - (detach-extent doc-extent)) - (when (< from to) - ;; Kludge: this doesn't need to be true for empty formats. - (delete-region from to)) - (set-marker from nil) - (set-marker to nil)) - (widget-clear-undo)) - -(defun widget-default-value-set (widget value) - ;; Recreate widget with new value. - (let* ((old-pos (point)) - (from (copy-marker (widget-get widget :from))) - (to (copy-marker (widget-get widget :to))) - (offset (if (and (<= from old-pos) (<= old-pos to)) - (if (>= old-pos (1- to)) - (- old-pos to 1) - (- old-pos from))))) - ;;??? Bug: this ought to insert the new value before deleting the old one, - ;; so that markers on either side of the value automatically - ;; stay on the same side. -- rms. - (save-excursion - (goto-char (widget-get widget :from)) - (widget-apply widget :delete) - (widget-put widget :value value) - (widget-apply widget :create)) - (when offset - (if (< offset 0) - (goto-char (+ (widget-get widget :to) offset 1)) - (goto-char (min (+ from offset) (1- (widget-get widget :to)))))))) - -(defun widget-default-value-inline (widget) - ;; Wrap value in a list unless it is inline. - (if (widget-get widget :inline) - (widget-value widget) - (list (widget-value widget)))) - -(defun widget-default-menu-tag-get (widget) - ;; Use tag or value for menus. - (or (widget-get widget :menu-tag) - (widget-get widget :tag) - (widget-princ-to-string (widget-get widget :value)))) - -(defun widget-default-active (widget) - "Return t iff this widget active (user modifiable)." - (and (not (widget-get widget :inactive)) - (let ((parent (widget-get widget :parent))) - (or (null parent) - (widget-apply parent :active))))) - -(defun widget-default-deactivate (widget) - "Make WIDGET inactive for user modifications." - (widget-specify-inactive widget - (widget-get widget :from) - (widget-get widget :to))) - -(defun widget-default-action (widget &optional event) - ;; Notify the parent when a widget change - (let ((parent (widget-get widget :parent))) - (when parent - (widget-apply parent :notify widget event)))) - -(defun widget-default-notify (widget child &optional event) - ;; Pass notification to parent. - (widget-default-action widget event)) - -(defun widget-default-prompt-value (widget prompt value unbound) - ;; Read an arbitrary value. Stolen from `set-variable'. -;; (let ((initial (if unbound -;; nil -;; ;; It would be nice if we could do a `(cons val 1)' here. -;; (prin1-to-string (custom-quote value)))))) - (eval-minibuffer prompt )) - -;;; The `item' Widget. - -(define-widget 'item 'default - "Constant items for inclusion in other widgets." - :convert-widget 'widget-value-convert-widget - :value-create 'widget-item-value-create - :value-delete 'ignore - :value-get 'widget-value-value-get - :match 'widget-item-match - :match-inline 'widget-item-match-inline - :action 'widget-item-action - :format "%t\n") - -(defun widget-item-value-create (widget) - ;; Insert the printed representation of the value. - (let ((standard-output (current-buffer))) - (princ (widget-get widget :value)))) - -(defun widget-item-match (widget value) - ;; Match if the value is the same. - (equal (widget-get widget :value) value)) - -(defun widget-item-match-inline (widget values) - ;; Match if the value is the same. - (let ((value (widget-get widget :value))) - (and (listp value) - (<= (length value) (length values)) - (let ((head (widget-sublist values 0 (length value)))) - (and (equal head value) - (cons head (widget-sublist values (length value)))))))) - -(defun widget-sublist (list start &optional end) - "Return the sublist of LIST from START to END. -If END is omitted, it defaults to the length of LIST." - (if (> start 0) (setq list (nthcdr start list))) - (if end - (if (<= end start) - nil - (setq list (copy-sequence list)) - (setcdr (nthcdr (- end start 1) list) nil) - list) - (copy-sequence list))) - -(defun widget-item-action (widget &optional event) - ;; Just notify itself. - (widget-apply widget :notify widget event)) - -;;; The `push-button' Widget. - -(defcustom widget-push-button-gui widget-glyph-enable - "If non nil, use GUI push buttons when available." - :group 'widgets - :type 'boolean) - -;; Cache already created GUI objects. -(defvar widget-push-button-cache nil) - -(defcustom widget-push-button-prefix "[" - "String used as prefix for buttons." - :type 'string - :group 'widget-button) - -(defcustom widget-push-button-suffix "]" - "String used as suffix for buttons." - :type 'string - :group 'widget-button) - -(define-widget 'push-button 'item - "A pushable button." - :button-prefix "" - :button-suffix "" - :value-create 'widget-push-button-value-create - :format "%[%v%]") - -(defun widget-push-button-value-create (widget) - ;; Insert text representing the `on' and `off' states. - (let* ((tag (or (widget-get widget :tag) - (widget-get widget :value))) - (tag-glyph (widget-get widget :tag-glyph)) - (text (concat widget-push-button-prefix - tag widget-push-button-suffix)) - (gui-glyphs (lax-plist-get widget-push-button-cache tag))) - (cond (tag-glyph - (widget-glyph-insert widget text tag-glyph)) - ;; We must check for console-on-window-system-p here, - ;; because GUI will not work otherwise (it needs RGB - ;; components for colors, and they are not known on TTYs). - ((and widget-push-button-gui - (console-on-window-system-p)) - (unless gui-glyphs - (let* ((gui-button-shadow-thickness 1) - (gui (make-gui-button tag 'widget-gui-action widget))) - (setq - gui-glyphs - (list - (make-glyph `(,(nth 0 (aref gui 1)) [string :data ,text])) - (make-glyph `(,(nth 1 (aref gui 1)) [string :data ,text])) - (make-glyph `(,(nth 2 (aref gui 1)) [string :data ,text])))) - (laxputf widget-push-button-cache tag gui-glyphs))) - (widget-glyph-insert-glyph - widget (nth 0 gui-glyphs) (nth 1 gui-glyphs) (nth 2 gui-glyphs))) - (t - (insert text))))) - -(defun widget-gui-action (widget) - "Apply :action for WIDGET." - (widget-apply-action widget (this-command-keys))) - -;;; The `link' Widget. - -(defcustom widget-link-prefix "[" - "String used as prefix for links." - :type 'string - :group 'widget-button) - -(defcustom widget-link-suffix "]" - "String used as suffix for links." - :type 'string - :group 'widget-button) - -(define-widget 'link 'item - "An embedded link." - :button-prefix 'widget-link-prefix - :button-suffix 'widget-link-suffix - :help-echo "Follow the link" - :format "%[%t%]") - -;;; The `info-link' Widget. - -(define-widget 'info-link 'link - "A link to an info file." - :help-echo 'widget-info-link-help-echo - :action 'widget-info-link-action) - -(defun widget-info-link-help-echo (widget) - (concat "Read the manual entry `" (widget-value widget) "'")) - -(defun widget-info-link-action (widget &optional event) - "Open the info node specified by WIDGET." - (Info-goto-node (widget-value widget))) - -;;; The `url-link' Widget. - -(define-widget 'url-link 'link - "A link to an www page." - :help-echo 'widget-url-link-help-echo - :action 'widget-url-link-action) - -(defun widget-url-link-help-echo (widget) - (concat "Visit <URL:" (widget-value widget) ">")) - -(defun widget-url-link-action (widget &optional event) - "Open the url specified by WIDGET." - (require 'browse-url) - (funcall browse-url-browser-function (widget-value widget))) - -;;; The `function-link' Widget. - -(define-widget 'function-link 'link - "A link to an Emacs function." - :action 'widget-function-link-action) - -(defun widget-function-link-action (widget &optional event) - "Show the function specified by WIDGET." - (describe-function (widget-value widget))) - -;;; The `variable-link' Widget. - -(define-widget 'variable-link 'link - "A link to an Emacs variable." - :action 'widget-variable-link-action) - -(defun widget-variable-link-action (widget &optional event) - "Show the variable specified by WIDGET." - (describe-variable (widget-value widget))) - -;;; The `file-link' Widget. - -(define-widget 'file-link 'link - "A link to a file." - :action 'widget-file-link-action) - -(defun widget-file-link-action (widget &optional event) - "Find the file specified by WIDGET." - (find-file (widget-value widget))) - -;;; The `emacs-library-link' Widget. - -(define-widget 'emacs-library-link 'link - "A link to an Emacs Lisp library file." - :help-echo 'widget-emacs-library-link-help-echo - :action 'widget-emacs-library-link-action) - -(defun widget-emacs-library-link-help-echo (widget) - (concat "Visit " (widget-value widget))) - -(defun widget-emacs-library-link-action (widget &optional event) - "Find the Emacs Library file specified by WIDGET." - (find-file (locate-library (widget-value widget)))) - -;;; The `emacs-commentary-link' Widget. - -(define-widget 'emacs-commentary-link 'link - "A link to Commentary in an Emacs Lisp library file." - :action 'widget-emacs-commentary-link-action) - -(defun widget-emacs-commentary-link-action (widget &optional event) - "Find the Commentary section of the Emacs file specified by WIDGET." - (finder-commentary (widget-value widget))) - -;;; The `editable-field' Widget. - -(define-widget 'editable-field 'default - "An editable text field." - :convert-widget 'widget-value-convert-widget - :keymap widget-field-keymap - :format "%v" - :value "" - :prompt-internal 'widget-field-prompt-internal - :prompt-history 'widget-field-history - :prompt-value 'widget-field-prompt-value - :action 'widget-field-action - :validate 'widget-field-validate - :valid-regexp "" - :error "No match" - :value-create 'widget-field-value-create - :value-delete 'widget-field-value-delete - :value-get 'widget-field-value-get - :match 'widget-field-match) - -(defvar widget-field-history nil - "History of field minibuffer edits.") - -(defun widget-field-prompt-internal (widget prompt initial history) - ;; Read string for WIDGET prompting with PROMPT. - ;; INITIAL is the initial input and HISTORY is a symbol containing - ;; the earlier input. - (read-string prompt initial history)) - -(defun widget-field-prompt-value (widget prompt value unbound) - ;; Prompt for a string. - (let ((initial (if unbound - nil - (cons (widget-apply widget :value-to-internal - value) 0))) - (history (widget-get widget :prompt-history))) - (let ((answer (widget-apply widget - :prompt-internal prompt initial history))) - (widget-apply widget :value-to-external answer)))) - -(defvar widget-edit-functions nil) - -(defun widget-field-action (widget &optional event) - ;; Edit the value in the minibuffer. - (let* ((invalid (widget-apply widget :validate)) - (prompt (concat (widget-apply widget :menu-tag-get) ": ")) - (value (unless invalid - (widget-value widget))) - (answer (widget-apply widget :prompt-value prompt value invalid))) - (unless (equal value answer) - ;; This is a hack. We can't properly validate the widget - ;; because validation requires the new value to be in the field. - ;; However, widget-field-value-create will not function unless - ;; the new value matches. So, we check whether the thing - ;; matches, and if it does, use either the real or a dummy error - ;; message. - (unless (widget-apply widget :match answer) - (let ((error-message (or (widget-get widget :type-error) - "Invalid field contents"))) - (widget-put widget :error error-message) - (error error-message))) - (widget-value-set widget answer) - (widget-apply widget :notify widget event) - (widget-setup)) - (run-hook-with-args 'widget-edit-functions widget))) - -;(defun widget-field-action (widget &optional event) -; ;; Move to next field. -; (widget-forward 1) -; (run-hook-with-args 'widget-edit-functions widget)) - -(defun widget-field-validate (widget) - ;; Valid if the content matches `:valid-regexp'. - (save-excursion - (let ((value (widget-apply widget :value-get)) - (regexp (widget-get widget :valid-regexp))) - (if (string-match regexp value) - nil - widget)))) - -(defun widget-field-value-create (widget) - ;; Create an editable text field. - (let ((size (widget-get widget :size)) - (value (widget-get widget :value)) - (from (point)) - ;; This is changed to a real extent in `widget-setup'. We - ;; need the end points to behave differently until - ;; `widget-setup' is called. Should probably be replaced with - ;; a genuine extent, but some things break, then. - (extent (cons (make-marker) (make-marker)))) - (widget-put widget :field-extent extent) - (insert value) - (and size - (< (length value) size) - (insert-char ?\ (- size (length value)))) - (unless (memq widget widget-field-list) - (push widget widget-field-new)) - (move-marker (cdr extent) (point)) - (set-marker-insertion-type (cdr extent) nil) - (when (null size) - (insert ?\n)) - (move-marker (car extent) from) - (set-marker-insertion-type (car extent) t))) - -(defun widget-field-value-delete (widget) - ;; Remove the widget from the list of active editing fields. - (setq widget-field-list (delq widget widget-field-list)) - ;; These are nil if the :format string doesn't contain `%v'. - (let ((extent (widget-get widget :field-extent))) - (when extent - (detach-extent extent)))) - -(defun widget-field-value-get (widget) - ;; Return current text in editing field. - (let ((from (widget-field-start widget)) - (to (widget-field-end widget)) - (buffer (widget-field-buffer widget)) - (size (widget-get widget :size)) - (secret (widget-get widget :secret)) - (old (current-buffer))) - (cond - ((and from to) - (set-buffer buffer) - (while (and size - (not (zerop size)) - (> to from) - (eq (char-after (1- to)) ?\ )) - (setq to (1- to))) - (let ((result (buffer-substring-no-properties from to))) - (when secret - (let ((index 0)) - (while (< (+ from index) to) - (aset result index - (get-char-property (+ from index) 'secret)) - (incf index)))) - (set-buffer old) - result)) - (t - (widget-get widget :value))))) - -(defun widget-field-match (widget value) - ;; Match any string. - (stringp value)) - -;;; The `text' Widget. - -(define-widget 'text 'editable-field - :keymap widget-text-keymap - "A multiline text area.") - -;;; The `menu-choice' Widget. - -(define-widget 'menu-choice 'default - "A menu of options." - :convert-widget 'widget-types-convert-widget - :format "%[%t%]: %v" - :case-fold t - :tag "choice" - :void '(item :format "invalid (%t)\n") - :value-create 'widget-choice-value-create - :value-delete 'widget-children-value-delete - :value-get 'widget-choice-value-get - :value-inline 'widget-choice-value-inline - :mouse-down-action 'widget-choice-mouse-down-action - :action 'widget-choice-action - :error "Make a choice" - :validate 'widget-choice-validate - :match 'widget-choice-match - :match-inline 'widget-choice-match-inline) - -(defun widget-choice-value-create (widget) - ;; Insert the first choice that matches the value. - (let ((value (widget-get widget :value)) - (args (widget-get widget :args)) - current) - (while args - (setq current (car args) - args (cdr args)) - (when (widget-apply current :match value) - (widget-put widget :children (list (widget-create-child-value - widget current value))) - (widget-put widget :choice current) - (setq args nil - current nil))) - (when current - (let ((void (widget-get widget :void))) - (widget-put widget :children (list (widget-create-child-and-convert - widget void :value value))) - (widget-put widget :choice void))))) - -(defun widget-choice-value-get (widget) - ;; Get value of the child widget. - (widget-value (car (widget-get widget :children)))) - -(defun widget-choice-value-inline (widget) - ;; Get value of the child widget. - (widget-apply (car (widget-get widget :children)) :value-inline)) - -(defcustom widget-choice-toggle nil - "If non-nil, a binary choice will just toggle between the values. -Otherwise, the user will explicitly have to choose between the values -when he invoked the menu." - :type 'boolean - :group 'widgets) - -(defun widget-choice-mouse-down-action (widget &optional event) - ;; Return non-nil if we need a menu. - (let ((args (widget-get widget :args)) - (old (widget-get widget :choice))) - (cond ((not (console-on-window-system-p)) - ;; No place to pop up a menu. - nil) - ((< (length args) 2) - ;; Empty or singleton list, just return the value. - nil) - ((> (length args) widget-menu-max-size) - ;; Too long, prompt. - nil) - ((> (length args) 2) - ;; Reasonable sized list, use menu. - t) - ((and widget-choice-toggle (memq old args)) - ;; We toggle. - nil) - (t - ;; Ask which of the two. - t)))) - -(defun widget-choice-action (widget &optional event) - ;; Make a choice. - (let ((args (widget-get widget :args)) - (old (widget-get widget :choice)) - (tag (widget-apply widget :menu-tag-get)) - (completion-ignore-case (widget-get widget :case-fold)) - current choices) - ;; Remember old value. - (if (and old (not (widget-apply widget :validate))) - (let* ((external (widget-value widget)) - (internal (widget-apply old :value-to-internal external))) - (widget-put old :value internal))) - ;; Find new choice. - (setq current - (cond ((= (length args) 0) - nil) - ((= (length args) 1) - (nth 0 args)) - ((and widget-choice-toggle - (= (length args) 2) - (memq old args)) - (if (eq old (nth 0 args)) - (nth 1 args) - (nth 0 args))) - (t - (while args - (setq current (car args) - args (cdr args)) - (setq choices - (cons (cons (widget-apply current :menu-tag-get) - current) - choices))) - (widget-choose tag (reverse choices) event)))) - (when current - (widget-value-set widget - (widget-apply current :value-to-external - (widget-get current :value))) - (widget-setup) - (widget-apply widget :notify widget event))) - (run-hook-with-args 'widget-edit-functions widget)) - -(defun widget-choice-validate (widget) - ;; Valid if we have made a valid choice. - (let ((void (widget-get widget :void)) - (choice (widget-get widget :choice)) - (child (car (widget-get widget :children)))) - (if (eq void choice) - widget - (widget-apply child :validate)))) - -(defun widget-choice-match (widget value) - ;; Matches if one of the choices matches. - (let ((args (widget-get widget :args)) - current found) - (while (and args (not found)) - (setq current (car args) - args (cdr args) - found (widget-apply current :match value))) - found)) - -(defun widget-choice-match-inline (widget values) - ;; Matches if one of the choices matches. - (let ((args (widget-get widget :args)) - current found) - (while (and args (null found)) - (setq current (car args) - args (cdr args) - found (widget-match-inline current values))) - found)) - -;;; The `toggle' Widget. - -(define-widget 'toggle 'item - "Toggle between two states." - :format "%[%v%]\n" - :value-create 'widget-toggle-value-create - :action 'widget-toggle-action - :match (lambda (widget value) t) - :on "on" - :off "off") - -(defun widget-toggle-value-create (widget) - ;; Insert text representing the `on' and `off' states. - (if (widget-value widget) - (widget-glyph-insert widget - (widget-get widget :on) - (widget-get widget :on-glyph)) - (widget-glyph-insert widget - (widget-get widget :off) - (widget-get widget :off-glyph)))) - -(defun widget-toggle-action (widget &optional event) - ;; Toggle value. - (widget-value-set widget (not (widget-value widget))) - (widget-apply widget :notify widget event) - (run-hook-with-args 'widget-edit-functions widget)) - -;;; The `checkbox' Widget. - -(define-widget 'checkbox 'toggle - "A checkbox toggle." - :button-suffix "" - :button-prefix "" - :format "%[%v%]" - :on "[X]" - :on-glyph "check1" - :off "[ ]" - :off-glyph "check0" - :action 'widget-checkbox-action) - -(defun widget-checkbox-action (widget &optional event) - "Toggle checkbox, notify parent, and set active state of sibling." - (widget-toggle-action widget event) - (let ((sibling (widget-get-sibling widget))) - (when sibling - (if (widget-value widget) - (widget-apply sibling :activate) - (widget-apply sibling :deactivate))))) - -;;; The `checklist' Widget. - -(define-widget 'checklist 'default - "A multiple choice widget." - :convert-widget 'widget-types-convert-widget - :format "%v" - :offset 4 - :entry-format "%b %v" - :menu-tag "checklist" - :greedy nil - :value-create 'widget-checklist-value-create - :value-delete 'widget-children-value-delete - :value-get 'widget-checklist-value-get - :validate 'widget-checklist-validate - :match 'widget-checklist-match - :match-inline 'widget-checklist-match-inline) - -(defun widget-checklist-value-create (widget) - ;; Insert all values - (let ((alist (widget-checklist-match-find widget (widget-get widget :value))) - (args (widget-get widget :args))) - (while args - (widget-checklist-add-item widget (car args) (assq (car args) alist)) - (setq args (cdr args))) - (widget-put widget :children (nreverse (widget-get widget :children))))) - -(defun widget-checklist-add-item (widget type chosen) - ;; Create checklist item in WIDGET of type TYPE. - ;; If the item is checked, CHOSEN is a cons whose cdr is the value. - (and (eq (preceding-char) ?\n) - (widget-get widget :indent) - (insert-char ?\ (widget-get widget :indent))) - (widget-specify-insert - (let* ((children (widget-get widget :children)) - (buttons (widget-get widget :buttons)) - (button-args (or (widget-get type :sibling-args) - (widget-get widget :button-args))) - (from (point)) - child button) - (insert (widget-get widget :entry-format)) - (goto-char from) - ;; Parse % escapes in format. - (while (re-search-forward "%\\([bv%]\\)" nil t) - (let ((escape (aref (match-string 1) 0))) - (replace-match "" t t) - (cond ((eq escape ?%) - (insert "%")) - ((eq escape ?b) - (setq button (apply 'widget-create-child-and-convert - widget 'checkbox - :value (not (null chosen)) - button-args))) - ((eq escape ?v) - (setq child - (cond ((not chosen) - (let ((child (widget-create-child widget type))) - (widget-apply child :deactivate) - child)) - ((widget-get type :inline) - (widget-create-child-value - widget type (cdr chosen))) - (t - (widget-create-child-value - widget type (car (cdr chosen))))))) - (t - (error "Unknown escape `%c'" escape))))) - ;; Update properties. - (and button child (widget-put child :button button)) - (and button (widget-put widget :buttons (cons button buttons))) - (and child (widget-put widget :children (cons child children)))))) - -(defun widget-checklist-match (widget values) - ;; All values must match a type in the checklist. - (and (listp values) - (null (cdr (widget-checklist-match-inline widget values))))) - -(defun widget-checklist-match-inline (widget values) - ;; Find the values which match a type in the checklist. - (let ((greedy (widget-get widget :greedy)) - (args (copy-sequence (widget-get widget :args))) - found rest) - (while values - (let ((answer (widget-checklist-match-up args values))) - (cond (answer - (let ((vals (widget-match-inline answer values))) - (setq found (append found (car vals)) - values (cdr vals) - args (delq answer args)))) - (greedy - (setq rest (append rest (list (car values))) - values (cdr values))) - (t - (setq rest (append rest values) - values nil))))) - (cons found rest))) - -(defun widget-checklist-match-find (widget vals) - ;; Find the vals which match a type in the checklist. - ;; Return an alist of (TYPE MATCH). - (let ((greedy (widget-get widget :greedy)) - (args (copy-sequence (widget-get widget :args))) - found) - (while vals - (let ((answer (widget-checklist-match-up args vals))) - (cond (answer - (let ((match (widget-match-inline answer vals))) - (setq found (cons (cons answer (car match)) found) - vals (cdr match) - args (delq answer args)))) - (greedy - (setq vals (cdr vals))) - (t - (setq vals nil))))) - found)) - -(defun widget-checklist-match-up (args vals) - ;; Rerturn the first type from ARGS that matches VALS. - (let (current found) - (while (and args (null found)) - (setq current (car args) - args (cdr args) - found (widget-match-inline current vals))) - (if found - current - nil))) - -(defun widget-checklist-value-get (widget) - ;; The values of all selected items. - (let ((children (widget-get widget :children)) - child result) - (while children - (setq child (car children) - children (cdr children)) - (if (widget-value (widget-get child :button)) - (setq result (append result (widget-apply child :value-inline))))) - result)) - -(defun widget-checklist-validate (widget) - ;; Ticked chilren must be valid. - (let ((children (widget-get widget :children)) - child button found) - (while (and children (not found)) - (setq child (car children) - children (cdr children) - button (widget-get child :button) - found (and (widget-value button) - (widget-apply child :validate)))) - found)) - -;;; The `option' Widget - -(define-widget 'option 'checklist - "An widget with an optional item." - :inline t) - -;;; The `choice-item' Widget. - -(define-widget 'choice-item 'item - "Button items that delegate action events to their parents." - :action 'widget-parent-action - :format "%[%t%] \n") - -;;; The `radio-button' Widget. - -(define-widget 'radio-button 'toggle - "A radio button for use in the `radio' widget." - :notify 'widget-radio-button-notify - :format "%[%v%]" - :button-suffix "" - :button-prefix "" - :on "(*)" - :on-glyph '("radio1" nil "radio0") - :off "( )" - :off-glyph "radio0") - -(defun widget-radio-button-notify (widget child &optional event) - ;; Tell daddy. - (widget-apply (widget-get widget :parent) :action widget event)) - -;;; The `radio-button-choice' Widget. - -(define-widget 'radio-button-choice 'default - "Select one of multiple options." - :convert-widget 'widget-types-convert-widget - :offset 4 - :format "%v" - :entry-format "%b %v" - :menu-tag "radio" - :value-create 'widget-radio-value-create - :value-delete 'widget-children-value-delete - :value-get 'widget-radio-value-get - :value-inline 'widget-radio-value-inline - :value-set 'widget-radio-value-set - :error "You must push one of the buttons" - :validate 'widget-radio-validate - :match 'widget-choice-match - :match-inline 'widget-choice-match-inline - :action 'widget-radio-action) - -(defun widget-radio-value-create (widget) - ;; Insert all values - (let ((args (widget-get widget :args)) - arg) - (while args - (setq arg (car args) - args (cdr args)) - (widget-radio-add-item widget arg)))) - -(defun widget-radio-add-item (widget type) - "Add to radio widget WIDGET a new radio button item of type TYPE." - ;; (setq type (widget-convert type)) - (and (eq (preceding-char) ?\n) - (widget-get widget :indent) - (insert-char ?\ (widget-get widget :indent))) - (widget-specify-insert - (let* ((value (widget-get widget :value)) - (children (widget-get widget :children)) - (buttons (widget-get widget :buttons)) - (button-args (or (widget-get type :sibling-args) - (widget-get widget :button-args))) - (from (point)) - (chosen (and (null (widget-get widget :choice)) - (widget-apply type :match value))) - child button) - (insert (widget-get widget :entry-format)) - (goto-char from) - ;; Parse % escapes in format. - (while (re-search-forward "%\\([bv%]\\)" nil t) - (let ((escape (aref (match-string 1) 0))) - (replace-match "" t t) - (cond ((eq escape ?%) - (insert "%")) - ((eq escape ?b) - (setq button (apply 'widget-create-child-and-convert - widget 'radio-button - :value (not (null chosen)) - button-args))) - ((eq escape ?v) - (setq child (if chosen - (widget-create-child-value - widget type value) - (widget-create-child widget type))) - (unless chosen - (widget-apply child :deactivate))) - (t - (error "Unknown escape `%c'" escape))))) - ;; Update properties. - (when chosen - (widget-put widget :choice type)) - (when button - (widget-put child :button button) - (widget-put widget :buttons (nconc buttons (list button)))) - (when child - (widget-put widget :children (nconc children (list child)))) - child))) - -(defun widget-radio-value-get (widget) - ;; Get value of the child widget. - (let ((chosen (widget-radio-chosen widget))) - (and chosen (widget-value chosen)))) - -(defun widget-radio-chosen (widget) - "Return the widget representing the chosen radio button." - (let ((children (widget-get widget :children)) - current found) - (while children - (setq current (car children) - children (cdr children)) - (let* ((button (widget-get current :button)) - (value (widget-apply button :value-get))) - (when value - (setq found current - children nil)))) - found)) - -(defun widget-radio-value-inline (widget) - ;; Get value of the child widget. - (let ((children (widget-get widget :children)) - current found) - (while children - (setq current (car children) - children (cdr children)) - (let* ((button (widget-get current :button)) - (value (widget-apply button :value-get))) - (when value - (setq found (widget-apply current :value-inline) - children nil)))) - found)) - -(defun widget-radio-value-set (widget value) - ;; We can't just delete and recreate a radio widget, since children - ;; can be added after the original creation and won't be recreated - ;; by `:create'. - (let ((children (widget-get widget :children)) - current found) - (while children - (setq current (car children) - children (cdr children)) - (let* ((button (widget-get current :button)) - (match (and (not found) - (widget-apply current :match value)))) - (widget-value-set button match) - (if match - (progn - (widget-value-set current value) - (widget-apply current :activate)) - (widget-apply current :deactivate)) - (setq found (or found match)))))) - -(defun widget-radio-validate (widget) - ;; Valid if we have made a valid choice. - (let ((children (widget-get widget :children)) - current found button) - (while (and children (not found)) - (setq current (car children) - children (cdr children) - button (widget-get current :button) - found (widget-apply button :value-get))) - (if found - (widget-apply current :validate) - widget))) - -(defun widget-radio-action (widget child event) - ;; Check if a radio button was pressed. - (let ((children (widget-get widget :children)) - (buttons (widget-get widget :buttons)) - current) - (when (memq child buttons) - (while children - (setq current (car children) - children (cdr children)) - (let* ((button (widget-get current :button))) - (cond ((eq child button) - (widget-value-set button t) - (widget-apply current :activate)) - ((widget-value button) - (widget-value-set button nil) - (widget-apply current :deactivate))))))) - ;; Pass notification to parent. - (widget-apply widget :notify child event)) - -;;; The `insert-button' Widget. - -(define-widget 'insert-button 'push-button - "An insert button for the `editable-list' widget." - :tag "INS" - :help-echo "Insert a new item into the list at this position" - :action 'widget-insert-button-action) - -(defun widget-insert-button-action (widget &optional event) - ;; Ask the parent to insert a new item. - (widget-apply (widget-get widget :parent) - :insert-before (widget-get widget :widget))) - -;;; The `delete-button' Widget. - -(define-widget 'delete-button 'push-button - "A delete button for the `editable-list' widget." - :tag "DEL" - :help-echo "Delete this item from the list" - :action 'widget-delete-button-action) - -(defun widget-delete-button-action (widget &optional event) - ;; Ask the parent to insert a new item. - (widget-apply (widget-get widget :parent) - :delete-at (widget-get widget :widget))) - -;;; The `editable-list' Widget. - -(defcustom widget-editable-list-gui nil - "If non nil, use GUI push-buttons in editable list when available." - :type 'boolean - :group 'widgets) - -(define-widget 'editable-list 'default - "A variable list of widgets of the same type." - :convert-widget 'widget-types-convert-widget - :offset 12 - :format "%v%i\n" - :format-handler 'widget-editable-list-format-handler - :entry-format "%i %d %v" - :menu-tag "editable-list" - :value-create 'widget-editable-list-value-create - :value-delete 'widget-children-value-delete - :value-get 'widget-editable-list-value-get - :validate 'widget-children-validate - :match 'widget-editable-list-match - :match-inline 'widget-editable-list-match-inline - :insert-before 'widget-editable-list-insert-before - :delete-at 'widget-editable-list-delete-at) - -(defun widget-editable-list-format-handler (widget escape) - ;; We recognize the insert button. - (let ((widget-push-button-gui widget-editable-list-gui)) - (cond ((eq escape ?i) - (and (widget-get widget :indent) - (insert-char ?\ (widget-get widget :indent))) - (apply 'widget-create-child-and-convert - widget 'insert-button - (widget-get widget :append-button-args))) - (t - (widget-default-format-handler widget escape))))) - -(defun widget-editable-list-value-create (widget) - ;; Insert all values - (let* ((value (widget-get widget :value)) - (type (nth 0 (widget-get widget :args))) - (inlinep (widget-get type :inline)) - children) - (widget-put widget :value-pos (copy-marker (point))) - (set-marker-insertion-type (widget-get widget :value-pos) t) - (while value - (let ((answer (widget-match-inline type value))) - (if answer - (setq children (cons (widget-editable-list-entry-create - widget - (if inlinep - (car answer) - (car (car answer))) - t) - children) - value (cdr answer)) - (setq value nil)))) - (widget-put widget :children (nreverse children)))) - -(defun widget-editable-list-value-get (widget) - ;; Get value of the child widget. - (apply 'append (mapcar (lambda (child) (widget-apply child :value-inline)) - (widget-get widget :children)))) - -(defun widget-editable-list-match (widget value) - ;; Value must be a list and all the members must match the type. - (and (listp value) - (null (cdr (widget-editable-list-match-inline widget value))))) - -(defun widget-editable-list-match-inline (widget value) - (let ((type (nth 0 (widget-get widget :args))) - (ok t) - found) - (while (and value ok) - (let ((answer (widget-match-inline type value))) - (if answer - (setq found (append found (car answer)) - value (cdr answer)) - (setq ok nil)))) - (cons found value))) - -(defun widget-editable-list-insert-before (widget before) - ;; Insert a new child in the list of children. - (save-excursion - (let ((children (widget-get widget :children)) - (inhibit-read-only t) - before-change-functions - after-change-functions) - (cond (before - (goto-char (widget-get before :entry-from))) - (t - (goto-char (widget-get widget :value-pos)))) - (let ((child (widget-editable-list-entry-create - widget nil nil))) - (when (< (widget-get child :entry-from) (widget-get widget :from)) - (set-marker (widget-get widget :from) - (widget-get child :entry-from))) - (if (eq (car children) before) - (widget-put widget :children (cons child children)) - (while (not (eq (car (cdr children)) before)) - (setq children (cdr children))) - (setcdr children (cons child (cdr children))))))) - (widget-setup) - (widget-apply widget :notify widget)) - -(defun widget-editable-list-delete-at (widget child) - ;; Delete child from list of children. - (save-excursion - (let ((buttons (copy-sequence (widget-get widget :buttons))) - button - (inhibit-read-only t) - before-change-functions - after-change-functions) - (while buttons - (setq button (car buttons) - buttons (cdr buttons)) - (when (eq (widget-get button :widget) child) - (widget-put widget - :buttons (delq button (widget-get widget :buttons))) - (widget-delete button)))) - (let ((entry-from (widget-get child :entry-from)) - (entry-to (widget-get child :entry-to)) - (inhibit-read-only t) - before-change-functions - after-change-functions) - (widget-delete child) - (delete-region entry-from entry-to) - (set-marker entry-from nil) - (set-marker entry-to nil)) - (widget-put widget :children (delq child (widget-get widget :children)))) - (widget-setup) - (widget-apply widget :notify widget)) - -(defun widget-editable-list-entry-create (widget value conv) - ;; Create a new entry to the list. - (let ((type (nth 0 (widget-get widget :args))) - (widget-push-button-gui widget-editable-list-gui) - child delete insert) - (widget-specify-insert - (save-excursion - (and (widget-get widget :indent) - (insert-char ?\ (widget-get widget :indent))) - (insert (widget-get widget :entry-format))) - ;; Parse % escapes in format. - (while (re-search-forward "%\\(.\\)" nil t) - (let ((escape (aref (match-string 1) 0))) - (replace-match "" t t) - (cond ((eq escape ?%) - (insert "%")) - ((eq escape ?i) - (setq insert (apply 'widget-create-child-and-convert - widget 'insert-button - (widget-get widget :insert-button-args)))) - ((eq escape ?d) - (setq delete (apply 'widget-create-child-and-convert - widget 'delete-button - (widget-get widget :delete-button-args)))) - ((eq escape ?v) - (if conv - (setq child (widget-create-child-value - widget type value)) - (setq child (widget-create-child widget type)))) - (t - (error "Unknown escape `%c'" escape))))) - (widget-put widget - :buttons (cons delete - (cons insert - (widget-get widget :buttons)))) - (let ((entry-from (copy-marker (point-min))) - (entry-to (copy-marker (point-max)))) - (set-marker-insertion-type entry-from t) - (set-marker-insertion-type entry-to nil) - (widget-put child :entry-from entry-from) - (widget-put child :entry-to entry-to))) - (widget-put insert :widget child) - (widget-put delete :widget child) - child)) - -;;; The `group' Widget. - -(define-widget 'group 'default - "A widget which group other widgets inside." - :convert-widget 'widget-types-convert-widget - :format "%v" - :value-create 'widget-group-value-create - :value-delete 'widget-children-value-delete - :value-get 'widget-editable-list-value-get - :validate 'widget-children-validate - :match 'widget-group-match - :match-inline 'widget-group-match-inline) - -(defun widget-group-value-create (widget) - ;; Create each component. - (let ((args (widget-get widget :args)) - (value (widget-get widget :value)) - arg answer children) - (while args - (setq arg (car args) - args (cdr args) - answer (widget-match-inline arg value) - value (cdr answer)) - (and (eq (preceding-char) ?\n) - (widget-get widget :indent) - (insert-char ?\ (widget-get widget :indent))) - (push (cond ((null answer) - (widget-create-child widget arg)) - ((widget-get arg :inline) - (widget-create-child-value widget arg (car answer))) - (t - (widget-create-child-value widget arg (car (car answer))))) - children)) - (widget-put widget :children (nreverse children)))) - -(defun widget-group-match (widget values) - ;; Match if the components match. - (and (listp values) - (let ((match (widget-group-match-inline widget values))) - (and match (null (cdr match)))))) - -(defun widget-group-match-inline (widget vals) - ;; Match if the components match. - (let ((args (widget-get widget :args)) - argument answer found) - (while args - (setq argument (car args) - args (cdr args) - answer (widget-match-inline argument vals)) - (if answer - (setq vals (cdr answer) - found (append found (car answer))) - (setq vals nil - args nil))) - (if answer - (cons found vals) - nil))) - -;;; The `visibility' Widget. - -(define-widget 'visibility 'item - "An indicator and manipulator for hidden items." - :format "%[%v%]" - :button-prefix "" - :button-suffix "" - :on "Hide" - :off "Show" - :value-create 'widget-visibility-value-create - :action 'widget-toggle-action - :match (lambda (widget value) t)) - -(defun widget-visibility-value-create (widget) - ;; Insert text representing the `on' and `off' states. - (let ((on (widget-get widget :on)) - (off (widget-get widget :off))) - (if on - (setq on (concat widget-push-button-prefix - on - widget-push-button-suffix)) - (setq on "")) - (if off - (setq off (concat widget-push-button-prefix - off - widget-push-button-suffix)) - (setq off "")) - (if (widget-value widget) - (widget-glyph-insert widget on '("down" "down-pushed")) - (widget-glyph-insert widget off '("right" "right-pushed"))))) - -;;; The `documentation-link' Widget. -;; -;; This is a helper widget for `documentation-string'. - -(define-widget 'documentation-link 'link - "Link type used in documentation strings." - :tab-order -1 - :help-echo 'widget-documentation-link-echo-help - :action 'widget-documentation-link-action) - -(defun widget-documentation-link-echo-help (widget) - "Tell what this link will describe." - (concat "Describe the `" (widget-get widget :value) "' symbol.")) - -(defun widget-documentation-link-action (widget &optional event) - "Display documentation for WIDGET's value. Ignore optional argument EVENT." - (let* ((string (widget-get widget :value)) - (symbol (intern string))) - (if (and (fboundp symbol) (boundp symbol)) - ;; If there are two doc strings, give the user a way to pick one. - (apropos (concat "\\`" (regexp-quote string) "\\'")) - (if (fboundp symbol) - (describe-function symbol) - (describe-variable symbol))))) - -(defcustom widget-documentation-links t - "Add hyperlinks to documentation strings when non-nil." - :type 'boolean - :group 'widget-documentation) - -(defcustom widget-documentation-link-regexp "`\\([^\n`' ]+\\)'" - "Regexp for matching potential links in documentation strings. -The first group should be the link itself." - :type 'regexp - :group 'widget-documentation) - -(defcustom widget-documentation-link-p 'intern-soft - "Predicate used to test if a string is useful as a link. -The value should be a function. The function will be called one -argument, a string, and should return non-nil if there should be a -link for that string." - :type 'function - :options '(widget-documentation-link-p) - :group 'widget-documentation) - -(defcustom widget-documentation-link-type 'documentation-link - "Widget type used for links in documentation strings." - :type 'symbol - :group 'widget-documentation) - -(defun widget-documentation-link-add (widget from to) - (widget-specify-doc widget from to) - (when widget-documentation-links - (let ((regexp widget-documentation-link-regexp) - (predicate widget-documentation-link-p) - (type widget-documentation-link-type) - (buttons (widget-get widget :buttons))) - (save-excursion - (goto-char from) - (while (re-search-forward regexp to t) - (let ((name (match-string 1)) - (begin (match-beginning 1)) - (end (match-end 1))) - (when (funcall predicate name) - (push (widget-convert-button type begin end :value name) - buttons))))) - (widget-put widget :buttons buttons))) - (let ((indent (widget-get widget :indent))) - (when (and indent (not (zerop indent))) - (save-excursion - (save-restriction - (narrow-to-region from to) - (goto-char (point-min)) - (while (search-forward "\n" nil t) - (insert-char ?\ indent))))))) - -;;; The `documentation-string' Widget. - -(define-widget 'documentation-string 'item - "A documentation string." - :format "%v" - :action 'widget-documentation-string-action - :value-delete 'widget-children-value-delete - :value-create 'widget-documentation-string-value-create) - -(defun widget-documentation-string-value-create (widget) - ;; Insert documentation string. - (let ((doc (widget-value widget)) - (indent (widget-get widget :indent)) - (shown (widget-get (widget-get widget :parent) :documentation-shown)) - (start (point))) - (if (string-match "\n" doc) - (let ((before (substring doc 0 (match-beginning 0))) - (after (substring doc (match-beginning 0))) - buttons) - (insert before " ") - (widget-documentation-link-add widget start (point)) - (push (widget-create-child-and-convert - widget 'visibility - :help-echo (lambda (widget) - (concat - (if (widget-value widget) - "Hide" "Show") - " the rest of the documentation")) - :off "More" - :action 'widget-parent-action - shown) - buttons) - (when shown - (setq start (point)) - (when indent - (insert-char ?\ indent)) - (insert after) - (widget-documentation-link-add widget start (point))) - (widget-put widget :buttons buttons)) - (insert doc) - (widget-documentation-link-add widget start (point)))) - (insert "\n")) - -(defun widget-documentation-string-action (widget &rest ignore) - ;; Toggle documentation. - (let ((parent (widget-get widget :parent))) - (widget-put parent :documentation-shown - (not (widget-get parent :documentation-shown)))) - ;; Redraw. - (widget-value-set widget (widget-value widget))) - -;;; The Sexp Widgets. - -(define-widget 'const 'item - "An immutable sexp." - :prompt-value 'widget-const-prompt-value - :format "%t\n%d") - -(defun widget-const-prompt-value (widget prompt value unbound) - ;; Return the value of the const. - (widget-value widget)) - -(define-widget 'function-item 'const - "An immutable function name." - :format "%v\n%h" - :documentation-property (lambda (symbol) - (condition-case nil - (documentation symbol t) - (error nil)))) - -(define-widget 'variable-item 'const - "An immutable variable name." - :format "%v\n%h" - :documentation-property 'variable-documentation) - -(defvar widget-string-prompt-value-history nil - "History of input to `widget-string-prompt-value'.") - -(define-widget 'string 'editable-field - "A string" - :tag "String" - :format "%{%t%}: %v" - :complete-function 'ispell-complete-word - :prompt-history 'widget-string-prompt-value-history) - -(define-widget 'regexp 'string - "A regular expression." - :match 'widget-regexp-match - :validate 'widget-regexp-validate - ;; Doesn't work well with terminating newline. - ;; :value-face 'widget-single-line-field-face - :tag "Regexp") - -(defun widget-regexp-match (widget value) - ;; Match valid regexps. - (and (stringp value) - (condition-case nil - (prog1 t - (string-match value "")) - (error nil)))) - -(defun widget-regexp-validate (widget) - "Check that the value of WIDGET is a valid regexp." - (let ((value (widget-value widget))) - (condition-case data - (prog1 nil - (string-match value "")) - (error (widget-put widget :error (error-message-string data)) - widget)))) - -(define-widget 'file 'string - "A file widget. -It will read a file name from the minibuffer when invoked." - :complete-function 'widget-file-complete - :prompt-value 'widget-file-prompt-value - :format "%{%t%}: %v" - ;; Doesn't work well with terminating newline. - ;; :value-face 'widget-single-line-field-face - :tag "File") - -(defun widget-file-complete () - "Perform completion on file name preceding point." - (interactive) - (let* ((end (point)) - (beg (save-excursion - (skip-chars-backward "^ ") - (point))) - (pattern (buffer-substring beg end)) - (name-part (file-name-nondirectory pattern)) - (directory (file-name-directory pattern)) - (completion (file-name-completion name-part directory))) - (cond ((eq completion t)) - ((null completion) - (message "Can't find completion for \"%s\"" pattern) - (ding)) - ((not (string= name-part completion)) - (delete-region beg end) - (insert (expand-file-name completion directory))) - (t - (message "Making completion list...") - (let ((list (file-name-all-completions name-part directory))) - (setq list (sort list 'string<)) - (with-output-to-temp-buffer "*Completions*" - (display-completion-list list))) - (message "Making completion list...%s" "done"))))) - -(defun widget-file-prompt-value (widget prompt value unbound) - ;; Read file from minibuffer. - (abbreviate-file-name - (if unbound - (read-file-name prompt) - (let ((prompt2 (format "%s (default %s) " prompt value)) - (dir (file-name-directory value)) - (file (file-name-nondirectory value)) - (must-match (widget-get widget :must-match))) - (read-file-name prompt2 dir nil must-match file))))) - -;;;(defun widget-file-action (widget &optional event) -;;; ;; Read a file name from the minibuffer. -;;; (let* ((value (widget-value widget)) -;;; (dir (file-name-directory value)) -;;; (file (file-name-nondirectory value)) -;;; (menu-tag (widget-apply widget :menu-tag-get)) -;;; (must-match (widget-get widget :must-match)) -;;; (answer (read-file-name (concat menu-tag ": (default `" value "') ") -;;; dir nil must-match file))) -;;; (widget-value-set widget (abbreviate-file-name answer)) -;;; (widget-setup) -;;; (widget-apply widget :notify widget event))) - -(define-widget 'directory 'file - "A directory widget. -It will read a directory name from the minibuffer when invoked." - :tag "Directory") - -(defvar widget-symbol-prompt-value-history nil - "History of input to `widget-symbol-prompt-value'.") - -(define-widget 'symbol 'editable-field - "A lisp symbol." - :value nil - :tag "Symbol" - :format "%{%t%}: %v" - :match (lambda (widget value) (symbolp value)) - :complete-function 'lisp-complete-symbol - :prompt-internal 'widget-symbol-prompt-internal - :prompt-match 'symbolp - :prompt-history 'widget-symbol-prompt-value-history - :value-to-internal (lambda (widget value) - (if (symbolp value) - (symbol-name value) - value)) - :value-to-external (lambda (widget value) - (if (stringp value) - (intern value) - value))) - -(defun widget-symbol-prompt-internal (widget prompt initial history) - ;; Read file from minibuffer. - (let ((answer (completing-read prompt obarray - (widget-get widget :prompt-match) - nil initial history))) - (if (and (stringp answer) - (not (zerop (length answer)))) - answer - (error "No value")))) - -(defvar widget-function-prompt-value-history nil - "History of input to `widget-function-prompt-value'.") - -(define-widget 'function 'sexp - "A lisp function." - :complete-function 'lisp-complete-symbol - :prompt-value 'widget-field-prompt-value - :prompt-internal 'widget-symbol-prompt-internal - :prompt-match 'fboundp - :prompt-history 'widget-function-prompt-value-history - :action 'widget-field-action - :tag "Function") - -(defvar widget-variable-prompt-value-history nil - "History of input to `widget-variable-prompt-value'.") - -(define-widget 'variable 'symbol - ;; Should complete on variables. - "A lisp variable." - :prompt-match 'boundp - :prompt-history 'widget-variable-prompt-value-history - :tag "Variable") - -;; This part issues a warning when compiling without Mule. Is there a -;; way of shutting it up? -;; -;; OK, I'll simply comment the whole thing out, until someone decides -;; to do something with it. -;(defvar widget-coding-system-prompt-value-history nil -; "History of input to `widget-coding-system-prompt-value'.") - -;(define-widget 'coding-system 'symbol -; "A MULE coding-system." -; :format "%{%t%}: %v" -; :tag "Coding system" -; :prompt-history 'widget-coding-system-prompt-value-history -; :prompt-value 'widget-coding-system-prompt-value -; :action 'widget-coding-system-action) - -;(defun widget-coding-system-prompt-value (widget prompt value unbound) -; ;; Read coding-system from minibuffer. -; (intern -; (completing-read (format "%s (default %s) " prompt value) -; (mapcar (lambda (sym) -; (list (symbol-name sym))) -; (coding-system-list))))) - -;(defun widget-coding-system-action (widget &optional event) -; ;; Read a file name from the minibuffer. -; (let ((answer -; (widget-coding-system-prompt-value -; widget -; (widget-apply widget :menu-tag-get) -; (widget-value widget) -; t))) -; (widget-value-set widget answer) -; (widget-apply widget :notify widget event) -; (widget-setup))) - -(define-widget 'sexp 'editable-field - "An arbitrary lisp expression." - :tag "Lisp expression" - :format "%{%t%}: %v" - :value nil - :validate 'widget-sexp-validate - :match (lambda (widget value) t) - :value-to-internal 'widget-sexp-value-to-internal - :value-to-external (lambda (widget value) (read value)) - :prompt-history 'widget-sexp-prompt-value-history - :prompt-value 'widget-sexp-prompt-value) - -(defun widget-sexp-value-to-internal (widget value) - ;; Use pp for printer representation. - (let ((pp (if (symbolp value) - (prin1-to-string value) - (pp-to-string value)))) - (while (string-match "\n\\'" pp) - (setq pp (substring pp 0 -1))) - (if (or (string-match "\n\\'" pp) - (> (length pp) 40)) - (concat "\n" pp) - pp))) - -(defun widget-sexp-validate (widget) - ;; Valid if we can read the string and there is no junk left after it. - (save-excursion - (let ((buffer (set-buffer (get-buffer-create " *Widget Scratch*")))) - (erase-buffer) - (insert (widget-apply widget :value-get)) - (goto-char (point-min)) - (condition-case data - (let ((value (read buffer))) - (if (eobp) - (if (widget-apply widget :match value) - nil - (widget-put widget :error (widget-get widget :type-error)) - widget) - (widget-put widget - :error (format "Junk at end of expression: %s" - (buffer-substring (point) - (point-max)))) - widget)) - (error (widget-put widget :error (error-message-string data)) - widget))))) - -(defvar widget-sexp-prompt-value-history nil - "History of input to `widget-sexp-prompt-value'.") - -(defun widget-sexp-prompt-value (widget prompt value unbound) - ;; Read an arbitrary sexp. - (let ((found (read-string prompt - (if unbound nil (cons (prin1-to-string value) 0)) - (widget-get widget :prompt-history)))) - (save-excursion - (let ((buffer (set-buffer (get-buffer-create " *Widget Scratch*")))) - (erase-buffer) - (insert found) - (goto-char (point-min)) - (let ((answer (read buffer))) - (unless (eobp) - (error "Junk at end of expression: %s" - (buffer-substring (point) (point-max)))) - answer))))) - -(define-widget 'restricted-sexp 'sexp - "A Lisp expression restricted to values that match. -To use this type, you must define :match or :match-alternatives." - :type-error "The specified value is not valid" - :match 'widget-restricted-sexp-match - :value-to-internal (lambda (widget value) - (if (widget-apply widget :match value) - (prin1-to-string value) - value))) - -(defun widget-restricted-sexp-match (widget value) - (let ((alternatives (widget-get widget :match-alternatives)) - matched) - (while (and alternatives (not matched)) - (if (cond ((functionp (car alternatives)) - (funcall (car alternatives) value)) - ((and (consp (car alternatives)) - (eq (car (car alternatives)) 'quote)) - (eq value (nth 1 (car alternatives))))) - (setq matched t)) - (setq alternatives (cdr alternatives))) - matched)) - -(define-widget 'integer 'restricted-sexp - "An integer." - :tag "Integer" - :value 0 - :type-error "This field should contain an integer" - :match-alternatives '(integerp)) - -(define-widget 'number 'restricted-sexp - "A floating point number." - :tag "Number" - :value 0.0 - :type-error "This field should contain a number" - :match-alternatives '(numberp)) - -(define-widget 'character 'editable-field - "A character." - :tag "Character" - :value 0 - :size 1 - :format "%{%t%}: %v\n" - :valid-regexp "\\`[\0-\377]\\'" - :error "This field should contain a single character" - :value-to-internal (lambda (widget value) - (if (stringp value) - value - (char-to-string value))) - :value-to-external (lambda (widget value) - (if (stringp value) - (aref value 0) - value)) - :match (lambda (widget value) - (characterp value))) - -(define-widget 'list 'group - "A lisp list." - :tag "List" - :format "%{%t%}:\n%v") - -(define-widget 'vector 'group - "A lisp vector." - :tag "Vector" - :format "%{%t%}:\n%v" - :match 'widget-vector-match - :value-to-internal (lambda (widget value) (append value nil)) - :value-to-external (lambda (widget value) (vconcat value))) - -(defun widget-vector-match (widget value) - (and (vectorp value) - (widget-group-match widget - (widget-apply widget :value-to-internal value)))) - -(define-widget 'cons 'group - "A cons-cell." - :tag "Cons-cell" - :format "%{%t%}:\n%v" - :match 'widget-cons-match - :value-to-internal (lambda (widget value) - (list (car value) (cdr value))) - :value-to-external (lambda (widget value) - (cons (car value) (cadr value)))) - -(defun widget-cons-match (widget value) - (and (consp value) - (widget-group-match widget - (widget-apply widget :value-to-internal value)))) - -(define-widget 'choice 'menu-choice - "A union of several sexp types." - :tag "Choice" - :format "%{%t%}: %[Value Menu%] %v" - :button-prefix 'widget-push-button-prefix - :button-suffix 'widget-push-button-suffix - :prompt-value 'widget-choice-prompt-value) - -(defun widget-choice-prompt-value (widget prompt value unbound) - "Make a choice." - (let ((args (widget-get widget :args)) - (completion-ignore-case (widget-get widget :case-fold)) - current choices old) - ;; Find the first arg that match VALUE. - (let ((look args)) - (while look - (if (widget-apply (car look) :match value) - (setq old (car look) - look nil) - (setq look (cdr look))))) - ;; Find new choice. - (setq current - (cond ((= (length args) 0) - nil) - ((= (length args) 1) - (nth 0 args)) - ((and (= (length args) 2) - (memq old args)) - (if (eq old (nth 0 args)) - (nth 1 args) - (nth 0 args))) - (t - (while args - (setq current (car args) - args (cdr args)) - (setq choices - (cons (cons (widget-apply current :menu-tag-get) - current) - choices))) - (let ((val (completing-read prompt choices nil t))) - (if (stringp val) - (let ((try (try-completion val choices))) - (when (stringp try) - (setq val try)) - (cdr (assoc val choices))) - nil))))) - (if current - (widget-prompt-value current prompt nil t) - value))) - -(define-widget 'radio 'radio-button-choice - "A union of several sexp types." - :tag "Choice" - :format "%{%t%}:\n%v" - :prompt-value 'widget-choice-prompt-value) - -(define-widget 'repeat 'editable-list - "A variable length homogeneous list." - :tag "Repeat" - :format "%{%t%}:\n%v%i\n") - -(define-widget 'set 'checklist - "A list of members from a fixed set." - :tag "Set" - :format "%{%t%}:\n%v") - -(define-widget 'boolean 'toggle - "To be nil or non-nil, that is the question." - :tag "Boolean" - :prompt-value 'widget-boolean-prompt-value - :button-prefix 'widget-push-button-prefix - :button-suffix 'widget-push-button-suffix - :format "%{%t%}: %[Toggle%] %v\n" - :on "on (non-nil)" - :off "off (nil)") - -(defun widget-boolean-prompt-value (widget prompt value unbound) - ;; Toggle a boolean. - (y-or-n-p prompt)) - -;;; The `color' Widget. - -(define-widget 'color 'editable-field - "Choose a color name (with sample)." - :format "%[%t%]: %v (%{sample%})\n" - :size 10 - :tag "Color" - :value "black" - :complete 'widget-color-complete - :sample-face-get 'widget-color-sample-face-get - :notify 'widget-color-notify - :action 'widget-color-action) - -(defun widget-color-complete (widget) - "Complete the color in WIDGET." - (let* ((prefix (buffer-substring-no-properties (widget-field-start widget) - (point))) - (list (widget-color-choice-list)) - (completion (try-completion prefix list))) - (cond ((eq completion t) - (message "Exact match")) - ((null completion) - (error "Can't find completion for \"%s\"" prefix)) - ((not (string-equal prefix completion)) - (insert (substring completion (length prefix)))) - (t - (message "Making completion list...") - (let ((list (all-completions prefix list nil))) - (with-output-to-temp-buffer "*Completions*" - (display-completion-list list))) - (message "Making completion list...done"))))) - -(defun widget-color-sample-face-get (widget) - (or (widget-get widget :sample-face) - (let ((color (widget-value widget)) - (face (make-face (gensym "sample-face-") nil t))) - ;; Use the face object, not its name, to prevent lossage if gc - ;; happens before applying the face. - (widget-put widget :sample-face face) - (and color - (not (equal color "")) - (valid-color-name-p color) - (set-face-foreground face color)) - face))) - -(defvar widget-color-choice-list nil) -;; Variable holding the possible colors. - -(defun widget-color-choice-list () - (or widget-color-choice-list - (setq widget-color-choice-list (read-color-completion-table)))) - -(defvar widget-color-history nil - "History of entered colors") - -(defun widget-color-action (widget &optional event) - ;; Prompt for a color. - (let* ((tag (widget-apply widget :menu-tag-get)) - (answer (read-color (concat tag ": ")))) - (unless (zerop (length answer)) - (widget-value-set widget answer) - (widget-setup) - (widget-apply widget :notify widget event)))) - -(defun widget-color-notify (widget child &optional event) - "Update the sample, and notify the parent." - (let* ((face (widget-apply widget :sample-face-get)) - (color (widget-value widget))) - (if (valid-color-name-p color) - (set-face-foreground face color) - (remove-face-property face 'foreground))) - (widget-default-notify widget child event)) - -;; Is this a misnomer? -(defun widget-at (pos) - "The button or field at POS." - (or (get-char-property pos 'button) - (get-char-property pos 'field))) - -(defun widget-echo-help (pos) - "Display the help echo for widget at POS." - (let* ((widget (widget-at pos)) - (help-echo (and widget (widget-get widget :help-echo)))) - (and (functionp help-echo) - (setq help-echo (funcall help-echo widget))) - (when (stringp help-echo) - (display-message 'no-log help-echo)))) - -;;; The End: - -(provide 'wid-edit) - -;; wid-edit.el ends here
--- a/lisp/custom/widget.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,73 +0,0 @@ -;;; widget.el --- a library of user interface components. -;; -;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. -;; -;; Author: Per Abrahamsen <abraham@dina.kvl.dk> -;; Maintainer: Hrvoje Niksic <hniksic@srce.hr> -;; Keywords: help, extensions, faces, hypermedia -;; Version: 1.9960-x -;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ - -;; 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. - -;;; Commentary: -;; -;; If you want to use this code, please visit the URL above. -;; -;; This file only contain the code needed to define new widget types. -;; Everything else is autoloaded from `wid-edit.el'. - -;;; Code: - -;; Neither XEmacs, nor latest GNU Emacs need this -- provided for -;; compatibility. -;; (defalias 'define-widget-keywords 'ignore) - -(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))))))) - -(defun define-widget (name class doc &rest args) - "Define a new widget type named NAME from CLASS. - -NAME and CLASS should both be symbols, CLASS should be one of the -existing widget types, or nil to create the widget from scratch. - -After the new widget has been defined, the following two calls will -create identical widgets: - -* (widget-create NAME) - -* (apply 'widget-create CLASS ARGS) - -The third argument DOC is a documentation string for the widget." - (put name 'widget-type (cons class args)) - (put name 'widget-documentation doc) - name) - -;;; The End. - -(provide 'widget) - -;; widget.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/derived.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,363 @@ +;;; derived.el --- allow inheritance of major modes. + +;; Copyright (C) 1993, 1994, 1997 Free Software Foundation, Inc. + +;; Author: David Megginson (dmeggins@aix1.uottawa.ca) +;; Maintainer: XEmacs Development Team +;; Keywords: extensions, dumped + +;; 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.34. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;; GNU Emacs is already, in a sense, object oriented -- each object +;; (buffer) belongs to a class (major mode), and that class defines +;; the relationship between messages (input events) and methods +;; (commands) by means of a keymap. +;; +;; The only thing missing is a good scheme of inheritance. It is +;; possible to simulate a single level of inheritance with generous +;; use of hooks and a bit of work -- sgml-mode, for example, also runs +;; the hooks for text-mode, and keymaps can inherit from other keymaps +;; -- but generally, each major mode ends up reinventing the wheel. +;; Ideally, someone should redesign all of Emacs's major modes to +;; follow a more conventional object-oriented system: when defining a +;; new major mode, the user should need only to name the existing mode +;; it is most similar to, then list the (few) differences. +;; +;; In the mean time, this package offers most of the advantages of +;; full inheritance with the existing major modes. The macro +;; `define-derived-mode' allows the user to make a variant of an existing +;; major mode, with its own keymap. The new mode will inherit the key +;; bindings of its parent, and will, in fact, run its parent first +;; every time it is called. For example, the commands +;; +;; (define-derived-mode hypertext-mode text-mode "Hypertext" +;; "Major mode for hypertext.\n\n\\{hypertext-mode-map}" +;; (setq case-fold-search nil)) +;; +;; (define-key hypertext-mode-map [down-mouse-3] 'do-hyper-link) +;; +;; will create a function `hypertext-mode' with its own (sparse) +;; keymap `hypertext-mode-map.' The command M-x hypertext-mode will +;; perform the following actions: +;; +;; - run the command (text-mode) to get its default setup +;; - replace the current keymap with 'hypertext-mode-map,' which will +;; inherit from 'text-mode-map'. +;; - replace the current syntax table with +;; 'hypertext-mode-syntax-table', which will borrow its defaults +;; from the current text-mode-syntax-table. +;; - replace the current abbrev table with +;; 'hypertext-mode-abbrev-table', which will borrow its defaults +;; from the current text-mode-abbrev table +;; - change the mode line to read "Hypertext" +;; - assign the value 'hypertext-mode' to the 'major-mode' variable +;; - run the body of commands provided in the macro -- in this case, +;; set the local variable `case-fold-search' to nil. +;; - **run the command (hypertext-mode-setup), which is empty by +;; default, but may be redefined by the user to contain special +;; commands (ie. setting local variables like 'outline-regexp') +;; **NOTE: do not use this option -- it will soon be obsolete. +;; - run anything assigned to 'hypertext-mode-hooks' (obsolete, but +;; supported for the sake of compatibility). +;; +;; The advantages of this system are threefold. First, text mode is +;; untouched -- if you had added the new keystroke to `text-mode-map,' +;; possibly using hooks, you would have added it to all text buffers +;; -- here, it appears only in hypertext buffers, where it makes +;; sense. Second, it is possible to build even further, and make +;; a derived mode from a derived mode. The commands +;; +;; (define-derived-mode html-mode hypertext-mode "HTML") +;; [various key definitions] +;; +;; will add a new major mode for HTML with very little fuss. +;; +;; Note also the function `derived-mode-class,' which returns the non-derived +;; major mode which a derived mode is based on (ie. NOT necessarily the +;; immediate parent). +;; +;; (derived-mode-class 'text-mode) ==> text-mode +;; (derived-mode-class 'hypertext-mode) ==> text-mode +;; (derived-mode-class 'html-mode) ==> text-mode + +;;; Code: + +;; PUBLIC: define a new major mode which inherits from an existing one. + +;; XEmacs -- no autoload +(defmacro define-derived-mode (child parent name &optional docstring &rest body) + "Create a new mode as a variant of an existing mode. + +The arguments to this command are as follow: + +CHILD: the name of the command for the derived mode. +PARENT: the name of the command for the parent mode (ie. text-mode). +NAME: a string which will appear in the status line (ie. \"Hypertext\") +DOCSTRING: an optional documentation string--if you do not supply one, + the function will attempt to invent something useful. +BODY: forms to execute just before running the + hooks for the new mode. + +Here is how you could define LaTeX-Thesis mode as a variant of LaTeX mode: + + (define-derived-mode LaTeX-thesis-mode LaTeX-mode \"LaTeX-Thesis\") + +You could then make new key bindings for `LaTeX-thesis-mode-map' +without changing regular LaTeX mode. In this example, BODY is empty, +and DOCSTRING is generated by default. + +On a more complicated level, the following command uses sgml-mode as +the parent, and then sets the variable `case-fold-search' to nil: + + (define-derived-mode article-mode sgml-mode \"Article\" + \"Major mode for editing technical articles.\" + (setq case-fold-search nil)) + +Note that if the documentation string had been left out, it would have +been generated automatically, with a reference to the keymap." + + ; Some trickiness, since what + ; appears to be the docstring + ; may really be the first + ; element of the body. + (if (and docstring (not (stringp docstring))) + (progn (setq body (cons docstring body)) + (setq docstring nil))) + (setq docstring (or docstring (derived-mode-make-docstring parent child))) + + (` (progn + (derived-mode-init-mode-variables (quote (, child))) + (defun (, child) () + (, docstring) + (interactive) + ; Run the parent. + ((, parent)) + ; Identify special modes. + (if (get (quote (, parent)) 'special) + (put (quote (, child)) 'special t)) + ;; XEmacs addition + (let ((mode-class (get (quote (, parent)) 'mode-class))) + (if mode-class + (put (quote (, child)) 'mode-class mode-class))) + ; Identify the child mode. + (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))) + ; Splice in the body (if any). + (,@ body) +;;; ; Run the setup function, if +;;; ; any -- this will soon be +;;; ; obsolete. +;;; (derived-mode-run-setup-function (quote (, child))) + ; Run the hooks, if any. + (derived-mode-run-hooks (quote (, child))))))) + + +;; PUBLIC: find the ultimate class of a derived mode. + +(defun derived-mode-class (mode) + "Find the class of a major mode. +A mode's class is the first ancestor which is NOT a derived mode. +Use the `derived-mode-parent' property of the symbol to trace backwards." + (while (get mode 'derived-mode-parent) + (setq mode (get mode 'derived-mode-parent))) + mode) + + +;; Inline functions to construct various names from a mode name. + +(defsubst derived-mode-setup-function-name (mode) + "Construct a setup-function name based on a mode name." + (intern (concat (symbol-name mode) "-setup"))) + +(defsubst derived-mode-hooks-name (mode) + "Construct a hooks name based on a mode name." + ;; XEmacs change from -hooks + (intern (concat (symbol-name mode) "-hook"))) + +(defsubst derived-mode-map-name (mode) + "Construct a map name based on a mode name." + (intern (concat (symbol-name mode) "-map"))) + +(defsubst derived-mode-syntax-table-name (mode) + "Construct a syntax-table name based on a mode name." + (intern (concat (symbol-name mode) "-syntax-table"))) + +(defsubst derived-mode-abbrev-table-name (mode) + "Construct an abbrev-table name based on a mode name." + (intern (concat (symbol-name mode) "-abbrev-table"))) + + +;; Utility functions for defining a derived mode. + +;; XEmacs -- don't autoload +(defun derived-mode-init-mode-variables (mode) + "Initialise variables for a new mode. +Right now, if they don't already exist, set up a blank keymap, an +empty syntax table, and an empty abbrev table -- these will be merged +the first time the mode is used." + + (if (boundp (derived-mode-map-name mode)) + t + (eval (` (defvar (, (derived-mode-map-name mode)) + ;; XEmacs change + (make-sparse-keymap (derived-mode-map-name mode)) + (, (format "Keymap for %s." mode))))) + (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))))) + (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))))))) + +(defun derived-mode-make-docstring (parent child) + "Construct a docstring for a new mode if none is provided." + + (format "This major mode is a variant of `%s', created by `define-derived-mode'. +It inherits all of the parent's attributes, but has its own keymap, +abbrev table and syntax table: + + `%s-map' and `%s-syntax-table' + +which more-or-less shadow + + `%s-map' and `%s-syntax-table' + +\\{%s-map}" parent child child parent parent child)) + + +;; Utility functions for running a derived mode. + +(defun derived-mode-set-keymap (mode) + "Set the keymap of the new mode, maybe merging with the parent." + (let* ((map-name (derived-mode-map-name mode)) + (new-map (eval map-name)) + (old-map (current-local-map))) + (and old-map + (get map-name 'derived-mode-unmerged) + (derived-mode-merge-keymaps old-map new-map)) + (put map-name 'derived-mode-unmerged nil) + (use-local-map new-map))) + +(defun derived-mode-set-syntax-table (mode) + "Set the syntax table of the new mode, maybe merging with the parent." + (let* ((table-name (derived-mode-syntax-table-name mode)) + (old-table (syntax-table)) + (new-table (eval table-name))) + (if (get table-name 'derived-mode-unmerged) + (derived-mode-merge-syntax-tables old-table new-table)) + (put table-name 'derived-mode-unmerged nil) + (set-syntax-table new-table))) + +(defun derived-mode-set-abbrev-table (mode) + "Set the abbrev table if it exists. +Always merge its parent into it, since the merge is non-destructive." + (let* ((table-name (derived-mode-abbrev-table-name mode)) + (old-table local-abbrev-table) + (new-table (eval table-name))) + (derived-mode-merge-abbrev-tables old-table new-table) + (setq local-abbrev-table new-table))) + +;;;(defun derived-mode-run-setup-function (mode) +;;; "Run the setup function if it exists." + +;;; (let ((fname (derived-mode-setup-function-name mode))) +;;; (if (fboundp fname) +;;; (funcall fname)))) + +(defun derived-mode-run-hooks (mode) + "Run the hooks if they exist." + + (let ((hooks-name (derived-mode-hooks-name mode))) + (if (boundp hooks-name) + (run-hooks hooks-name)))) + +;; Functions to merge maps and tables. + +(defun derived-mode-merge-keymaps (old new) + "Merge an old keymap into a new one. +The old keymap is set to be the parent of the new one, so that there will +be automatic inheritance." + ;; XEmacs change. FSF 19.30 & 19.34 has a whole bunch of weird crap here + ;; for merging prefix keys and such. Hopefully none of this is + ;; necessary in XEmacs. + (set-keymap-parents new (list old))) + +(defun derived-mode-merge-syntax-tables (old new) + "Merge an old syntax table into a new one. +Where the new table already has an entry, nothing is copied from the old one." + ;; 20.x + (if (fboundp 'map-char-table) + ;; we use map-char-table not map-syntax-table so we can explicitly + ;; check for inheritance. + (map-char-table + #'(lambda (key value) + (if (eq ?@ (char-syntax-from-code value)) + (map-char-table #'(lambda (key1 value1) + (put-char-table key1 value1 new)) + old + key))) + new) + ;; pre-20.0 + (let ((idx 0) + (end (min (length new) (length old)))) + (while (< idx end) + (if (not (aref new idx)) + (aset new idx (aref old idx))) + (setq idx (1+ idx)))))) + +;; Merge an old abbrev table into a new one. +;; This function requires internal knowledge of how abbrev tables work, +;; presuming that they are obarrays with the abbrev as the symbol, the expansion +;; as the value of the symbol, and the hook as the function definition. +(defun derived-mode-merge-abbrev-tables (old new) + (if old + (mapatoms + (function + (lambda (symbol) + (or (intern-soft (symbol-name symbol) new) + (define-abbrev new (symbol-name symbol) + (symbol-value symbol) (symbol-function symbol))))) + old))) + +(provide 'derived) + +;;; derived.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/device.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,85 @@ +;;; device.el --- miscellaneous device functions not written in C + +;; Copyright (C) 1994-5, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1995, 1996 Ben Wing + +;; Maintainer: XEmacs Development Team +;; Keywords: internal, dumped + +;; 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, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: Not in FSF. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;;; Code: + +(defun device-list () + "Return a list of all devices." + (apply 'nconc (mapcar 'console-device-list (console-list)))) + +(defun device-type (&optional device) + "Return the type of the specified device (e.g. `x' or `tty'). +This is equivalent to the type of the device's console. +Value is `tty' for a tty device (a character-only terminal), +`x' for a device that is a screen on an X display, +`ns' for a device that is a NeXTstep connection (not yet implemented), +`w32' for a device that is a Windows or Windows NT connection, +`pc' for a device that is a direct-write MS-DOS screen (not yet implemented), +`stream' for a stream device (which acts like a stdio stream), and +`dead' for a deleted device." + (or device (setq device (selected-device))) + (if (not (device-live-p device)) 'dead + (console-type (device-console device)))) + +(defun make-tty-device (&optional tty terminal-type controlling-process) + "Create a new device on TTY. + TTY should be the name of a tty device file (e.g. \"/dev/ttyp3\" under +SunOS et al.), as returned by the `tty' command. A value of nil means +use the stdin and stdout as passed to XEmacs from the shell. + If TERMINAL-TYPE is non-nil, it should be a string specifying the +type of the terminal attached to the specified tty. If it is nil, +the terminal type will be inferred from the TERM environment variable. + If CONTROLLING-PROCESS is non-nil, it should be an integer +specifying the process id of the process in control of the specified tty. If +it is nil, it is assumes to be the value returned by emacs-pid." + (make-device 'tty tty (list 'terminal-type terminal-type + 'controlling-process controlling-process))) + +(defun make-x-device (&optional display) + "Create a new device connected to DISPLAY." + (make-device 'x display)) + +(defun make-w32-device () + "Create a new win32 device." + (make-device 'w32 nil)) + +(defun device-on-window-system-p (&optional device) + "Return non-nil if DEVICE is on a window system. +This generally means that there is support for the mouse, the menubar, +the toolbar, glyphs, etc." + (or device (setq device (selected-device))) + (console-on-window-system-p (device-console device))) + +(defalias 'valid-device-type-p 'valid-console-type-p) +(defalias 'device-type-list 'console-type-list) +(defalias 'device-pixel-depth 'device-bitplanes) + +;;; device.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/dialog.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,157 @@ +;;; dialog.el --- Dialog-box support for XEmacs + +;; Copyright (C) 1991-4, 1997 Free Software Foundation, Inc. + +;; Maintainer: XEmacs Development Team +;; Keywords: extensions, internal, dumped + +;; 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, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: Not in FSF. + +;;; Commentary: + +;; This file is dumped with XEmacs (when dialog boxes are compiled in). + +;;; Code: +(defun yes-or-no-p-dialog-box (prompt) + "Ask user a \"y or n\" question with a popup dialog box. +Returns t if answer is \"yes\". +Takes one argument, which is the string to display to ask the question." + (let ((echo-keystrokes 0) + event) + (popup-dialog-box + ;; "Non-violent language please!" says Robin. + (cons prompt '(["Yes" yes t] ["No" no t] nil ["Cancel" abort t]))) +; (cons prompt '(["Yes" yes t] ["No" no t] nil ["Abort" abort t]))) + (catch 'ynp-done + (while t + (setq event (next-command-event event)) + (cond ((and (misc-user-event-p event) (eq (event-object event) 'yes)) + (throw 'ynp-done t)) + ((and (misc-user-event-p event) (eq (event-object event) 'no)) + (throw 'ynp-done nil)) + ((and (misc-user-event-p event) + (or (eq (event-object event) 'abort) + (eq (event-object event) 'menu-no-selection-hook))) + (signal 'quit nil)) + ((button-release-event-p event) ;; don't beep twice + nil) + (t + (beep) + (message "please answer the dialog box"))))))) + +(defun yes-or-no-p-maybe-dialog-box (prompt) + "Ask user a yes-or-no question. Return t if answer is yes. +The question is asked with a dialog box or the minibuffer, as appropriate. +Takes one argument, which is the string to display to ask the question. +It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it. +The user must confirm the answer with RET, +and can edit it until it as been confirmed." + (if (should-use-dialog-box-p) + (yes-or-no-p-dialog-box prompt) + (yes-or-no-p-minibuf prompt))) + +(defun y-or-n-p-maybe-dialog-box (prompt) + "Ask user a \"y or n\" question. Return t if answer is \"y\". +Takes one argument, which is the string to display to ask the question. +The question is asked with a dialog box or the minibuffer, as appropriate. +It should end in a space; `y-or-n-p' adds `(y or n) ' to it. +No confirmation of the answer is requested; a single character is enough. +Also accepts Space to mean yes, or Delete to mean no." + (if (should-use-dialog-box-p) + (yes-or-no-p-dialog-box prompt) + (y-or-n-p-minibuf prompt))) + +(if (fboundp 'popup-dialog-box) + (progn + (fset 'yes-or-no-p 'yes-or-no-p-maybe-dialog-box) + (fset 'y-or-n-p 'y-or-n-p-maybe-dialog-box))) + +;; this is call-compatible with the horribly-named FSF Emacs function +;; `x-popup-dialog'. I refuse to use that name. +(defun get-dialog-box-response (position contents) + ;; by Stig@hackvan.com + ;; modified by pez@atlantic2.sbi.com + "Pop up a dialog box and return user's selection. +POSITION specifies which frame to use. +This is normally an event or a window or frame. +If POSITION is t or nil, it means to use the frame the mouse is on. +The dialog box appears in the middle of the specified frame. + +CONTENTS specifies the alternatives to display in the dialog box. +It is a list of the form (TITLE ITEM1 ITEM2...). +Each ITEM is a cons cell (STRING . VALUE). +The return value is VALUE from the chosen item. + +An ITEM may also be just a string--that makes a nonselectable item. +An ITEM may also be nil--that means to put all preceding items +on the left of the dialog box and all following items on the right." + (cond + ((eventp position) + (select-frame (event-frame position))) + ((framep position) + (select-frame position)) + ((windowp position) + (select-window position))) + (let ((dbox (cons (car contents) + (mapcar #'(lambda (x) + (cond + ((null x) + nil) + ((stringp x) + `[,x 'ignore nil]) ;this will never get + ;selected + (t + `[,(car x) (throw 'result ',(cdr x)) t]))) + (cdr contents)) + ))) + (catch 'result + (popup-dialog-box dbox) + (dispatch-event (next-command-event))))) + +(defun message-box (fmt &rest args) + "Display a message, in a dialog box if possible. +If the selected device has no dialog-box support, use the echo area. +The arguments are the same as to `format'. + +If the only argument is nil, clear any existing message; let the +minibuffer contents show." + (if (and (null fmt) (null args)) + (progn + (clear-message nil) + nil) + (let ((str (apply 'format fmt args))) + (if (device-on-window-system-p) + (get-dialog-box-response nil (list str (cons "OK" t))) + (display-message 'message str)) + str))) + +(defun message-or-box (fmt &rest args) + "Display a message in a dialog box or in the echo area.\n\ +If this command was invoked with the mouse, use a dialog box.\n\ +Otherwise, use the echo area. +The arguments are the same as to `format'. + +If the only argument is nil, clear any existing message; let the +minibuffer contents show." + (if (should-use-dialog-box-p) + (apply 'message-box fmt args) + (apply 'message fmt args))) + +;;; dialog.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/disass.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,272 @@ +;;; disass.el --- disassembler for compiled Emacs Lisp code + +;;; Copyright (C) 1986, 1991-1994 Free Software Foundation, Inc. + +;; Author: Doug Cutting <doug@csli.stanford.edu> +;; Jamie Zawinski <jwz@netscape.com> +;; Maintainer: Jamie Zawinski <jwz@netscape.com> +;; Keywords: internal + +;; 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.28. + +;;; Commentary: + +;; The single entry point, `disassemble', disassembles a code object generated +;; by the Emacs Lisp byte-compiler. This doesn't invert the compilation +;; operation, not by a long shot, but it's useful for debugging. + +;; +;; Original version by Doug Cutting (doug@csli.stanford.edu) +;; Substantially modified by Jamie Zawinski for +;; the new lapcode-based byte compiler. + +;;; 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. +OBJECT can be a symbol defined as a function, or a function itself +\(a lambda expression or a compiled-function object). +If OBJECT is not already compiled, we compile it, but do not +redefine OBJECT if it is a symbol." + (interactive (list (intern (completing-read "Disassemble function: " + obarray 'fboundp t)) + nil 0 t)) + (if (eq (car-safe object) 'byte-code) + (setq object (list 'lambda () object))) + (or indent (setq indent 0)) ;Default indent to zero + (save-excursion + (if (or interactive-p (null buffer)) + (with-output-to-temp-buffer "*Disassemble*" + (set-buffer "*Disassemble*") + (disassemble-internal object indent (not interactive-p))) + (set-buffer buffer) + (disassemble-internal object indent nil))) + nil) + + +(defun disassemble-internal (obj indent interactive-p) + (let ((macro 'nil) + (name 'nil) + args) + (while (symbolp obj) + (setq name obj + obj (symbol-function obj))) + (if (subrp obj) + (error "Can't disassemble #<subr %s>" name)) + (if (eq (car-safe obj) 'autoload) + (progn + (load (elt obj 1)) + (setq obj (symbol-function name)))) + (if (eq (car-safe obj) 'macro) ;handle macros + (setq macro t + obj (cdr obj))) + (if (and (listp obj) (eq (car obj) 'byte-code)) + (setq obj (list 'lambda nil obj))) + (if (and (listp obj) (not (eq (car obj) 'lambda))) + (error "not a function")) + (if (consp obj) + (if (assq 'byte-code obj) + nil + (if interactive-p (message (if name + "Compiling %s's definition..." + "Compiling definition...") + name)) + (setq obj (byte-compile obj)) + (if interactive-p (message "Done compiling. Disassembling...")))) + (cond ((consp obj) + (setq obj (cdr obj)) ;throw lambda away + (setq args (car obj)) ;save arg list + (setq obj (cdr obj))) + (t + (setq args (compiled-function-arglist obj)))) + (if (zerop indent) ; not a nested function + (progn + (indent-to indent) + (insert (format "byte code%s%s%s:\n" + (if (or macro name) " for" "") + (if macro " macro" "") + (if name (format " %s" name) ""))))) + (let ((doc (if (consp obj) + (and (stringp (car obj)) (car obj)) + (condition-case error + (documentation obj) + (error (format "%S" error)))))) + (if (and doc (stringp doc)) + (progn (and (consp obj) (setq obj (cdr obj))) + (indent-to indent) + (princ " doc: " (current-buffer)) + (let ((frobbed nil)) + (if (string-match "\n" doc) + (setq doc (substring doc 0 (match-beginning 0)) + frobbed t)) + (if (> (length doc) 70) + (setq doc (substring doc 0 65) frobbed t)) + (if frobbed (setq doc (concat doc " ...")))) + (insert doc "\n")))) + (indent-to indent) + (insert " args: ") + (prin1 args (current-buffer)) + (insert "\n") + (if (condition-case () + (commandp obj) ; ie interactivep + (error nil)) + (let ((interactive (if (consp obj) + (elt (assq 'interactive obj) 1) + (elt (compiled-function-interactive obj) 1)))) + (if (eq (car-safe (car-safe obj)) 'interactive) + (setq obj (cdr obj))) + (indent-to indent) + (insert " interactive: ") + (if (eq (car-safe interactive) 'byte-code) + (progn + (insert "\n") + (disassemble-1 interactive + (+ indent disassemble-recursive-indent))) + (let ((print-escape-newlines t)) + (prin1 interactive (current-buffer)))) + (insert "\n"))) + (cond ((and (consp obj) (assq 'byte-code obj)) + (disassemble-1 (assq 'byte-code obj) indent)) + ((compiled-function-p obj) + (disassemble-1 obj indent)) + (t + (insert "Uncompiled body: ") + (let ((print-escape-newlines t)) + (prin1 (if (cdr obj) (cons 'progn obj) (car obj)) + (current-buffer)))))) + (if interactive-p + (message nil))) + + +(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." + (let (bytes constvec) + (if (consp obj) + (setq bytes (car (cdr obj)) ; the byte code + constvec (car (cdr (cdr obj)))) ; constant vector + (setq bytes (compiled-function-instructions obj) + constvec (compiled-function-constants obj))) + (let ((lap (byte-decompile-bytecode bytes constvec)) + op arg opname pc-value) + (let ((tagno 0) + tmp + (lap lap)) + (while (setq tmp (assq 'TAG lap)) + (setcar (cdr tmp) (setq tagno (1+ tagno))) + (setq lap (cdr (memq tmp lap))))) + (while lap + ;; Take off the pc value of the next thing + ;; and put it in pc-value. + (setq pc-value nil) + (if (numberp (car lap)) + (setq pc-value (car lap) + lap (cdr lap))) + ;; Fetch the next op and its arg. + (setq op (car (car lap)) + arg (cdr (car lap))) + (setq lap (cdr lap)) + (indent-to indent) + (if (eq 'TAG op) + (progn + ;; We have a label. Display it, but first its pc value. + (if pc-value + (insert (format "%d:" pc-value))) + (insert (int-to-string (car arg)))) + ;; We have an instruction. Display its pc value first. + (if pc-value + (insert (format "%d" pc-value))) + (indent-to (+ indent disassemble-column-1-indent)) + (if (and op + (string-match "^byte-" (setq opname (symbol-name op)))) + (setq opname (substring opname 5)) + (setq opname "<not-an-opcode>")) + (if (eq op 'byte-constant2) + (insert " #### shouldn't have seen constant2 here!\n ")) + (insert opname) + (indent-to (+ indent disassemble-column-1-indent + disassemble-column-2-indent + -1)) + (insert " ") + (cond ((memq op byte-goto-ops) + (insert (int-to-string (nth 1 arg)))) + ((memq op '(byte-call byte-unbind + byte-listN byte-concatN byte-insertN)) + (insert (int-to-string arg))) + ((memq op '(byte-varref byte-varset byte-varbind)) + (prin1 (car arg) (current-buffer))) + ((memq op '(byte-constant byte-constant2)) + ;; it's a constant + (setq arg (car arg)) + ;; but if the value of the constant is compiled code, then + ;; recursively disassemble it. + (cond ((or (compiled-function-p arg) + (and (eq (car-safe arg) 'lambda) + (assq 'byte-code arg)) + (and (eq (car-safe arg) 'macro) + (or (compiled-function-p (cdr arg)) + (and (eq (car-safe (cdr arg)) 'lambda) + (assq 'byte-code (cdr arg)))))) + (cond ((compiled-function-p arg) + (insert "<compiled-function>\n")) + ((eq (car-safe arg) 'lambda) + (insert "<compiled lambda>")) + (t (insert "<compiled macro>\n"))) + (disassemble-internal + arg + (+ indent disassemble-recursive-indent 1) + nil)) + ((eq (car-safe arg) 'byte-code) + (insert "<byte code>\n") + (disassemble-1 ;recurse on byte-code object + arg + (+ indent disassemble-recursive-indent))) + ((eq (car-safe (car-safe arg)) 'byte-code) + (insert "(<byte code>...)\n") + (mapcar ;recurse on list of byte-code objects + '(lambda (obj) + (disassemble-1 + obj + (+ indent disassemble-recursive-indent))) + arg)) + (t + ;; really just a constant + (let ((print-escape-newlines t)) + (prin1 arg (current-buffer)))))) + ) + (insert "\n"))))) + nil) + +(provide 'disass) + +;;; disass.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/easymenu.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,217 @@ +;;; easymenu.el - Easy menu support for Emacs 19 and XEmacs. + +;; Copyright (C) 1992, 1993, 1994, 1995 Free Software Foundation, Inc. + +;; Author: Per Abrahamsen <abraham@dina.kvl.dk> +;; Maintainer: XEmacs Development Team +;; Keywords: internal, extensions, dumped + +;; 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; if not, write to the Free Software +;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: Not synched with FSF. + +;; Commentary: + +;; This file is dumped with XEmacs. + +;; Easymenu allows you to define menus for both Emacs 19 and XEmacs. + +;; This file +;; The advantages of using easymenu are: + +;; - Easier to use than either the Emacs 19 and XEmacs menu syntax. + +;; - Common interface for Emacs 18, Emacs 19, and XEmacs. +;; (The code does nothing when run under Emacs 18). + +;; The public functions are: + +;; - Function: easy-menu-define SYMBOL MAPS DOC MENU +;; SYMBOL is both the name of the variable that holds the menu and +;; the name of a function that will present a the menu. +;; MAPS is a list of keymaps where the menu should appear in the menubar. +;; DOC is the documentation string for the variable. +;; MENU is an XEmacs style menu description. + +;; See the documentation for easy-menu-define for details. + +;; - Function: easy-menu-change PATH NAME ITEMS +;; Change an existing menu. +;; The menu must already exist and be visible on the menu bar. +;; PATH is a list of strings used for locating the menu on the menu bar. +;; NAME is the name of the menu. +;; ITEMS is a list of menu items, as defined in `easy-menu-define'. + +;; - Function: easy-menu-add MENU [ MAP ] +;; Add MENU to the current menubar in MAP. + +;; - Function: easy-menu-remove MENU +;; Remove MENU from the current menubar. + +;; Emacs 19 never uses `easy-menu-add' or `easy-menu-remove', menus +;; automatically appear and disappear when the keymaps specified by +;; the MAPS argument to `easy-menu-define' are activated. + +;; XEmacs will bind the map to button3 in each MAPS, but you must +;; explicitly call `easy-menu-add' and `easy-menu-remove' to add and +;; remove menus from the menu bar. + +;;; Code: + +;; ;;;###autoload +(defmacro easy-menu-define (symbol maps doc menu) + "Define a menu bar submenu in maps MAPS, according to MENU. +The arguments SYMBOL and DOC are ignored; they are present for +compatibility only. SYMBOL is not evaluated. In other Emacs versions +these arguments may be used as a variable to hold the menu data, and a +doc string for that variable. + +The first element of MENU must be a string. It is the menu bar item name. +The rest of the elements are menu items. + +A menu item is usually a vector of three elements: [NAME CALLBACK ENABLE] + +NAME is a string--the menu item name. + +CALLBACK is a command to run when the item is chosen, +or a list to evaluate when the item is chosen. + +ENABLE is an expression; the item is enabled for selection +whenever this expression's value is non-nil. + +Alternatively, a menu item may have the form: + + [ NAME CALLBACK [ KEYWORD ARG ] ... ] + +Where KEYWORD is one of the symbol defined below. + + :keys KEYS + +KEYS is a string; a complex keyboard equivalent to this menu item. + + :active ENABLE + +ENABLE is an expression; the item is enabled for selection +whenever this expression's value is non-nil. + + :suffix NAME + +NAME is a string; the name of an argument to CALLBACK. + + :style STYLE + +STYLE is a symbol describing the type of menu item. The following are +defined: + +toggle: A checkbox. + Currently just prepend the name with the string \"Toggle \". +radio: A radio button. +nil: An ordinary menu item. + + :selected SELECTED + +SELECTED is an expression; the checkbox or radio button is selected +whenever this expression's value is non-nil. +Currently just disable radio buttons, no effect on checkboxes. + +A menu item can be a string. Then that string appears in the menu as +unselectable text. A string consisting solely of hyphens is displayed +as a solid horizontal line. + +A menu item can be a list. It is treated as a submenu. +The first element should be the submenu name. That's used as the +menu item in the top-level menu. The cdr of the submenu list +is a list of menu items, as above." + (` (progn + (defvar (, symbol) nil (, doc)) + (easy-menu-do-define (quote (, symbol)) (, maps) (, doc) (, menu))))) + +(defun easy-menu-do-define (symbol maps doc menu) + (if (featurep 'menubar) + (progn + (set symbol menu) + (fset symbol (list 'lambda '(e) + doc + '(interactive "@e") + '(run-hooks 'activate-menubar-hook) + '(setq zmacs-region-stays 't) + (list 'popup-menu symbol)))))) + +(defun easy-menu-change (&rest args) + (when (featurep 'menubar) + (apply 'add-menu args))) + +;; This variable hold the easy-menu mode menus of all major and +;; minor modes currently in effect in the current buffer. +(defvar easy-menu-all-popups nil) +(make-variable-buffer-local 'easy-menu-all-popups) + +(defun easy-menu-add (menu &optional map) + "Add MENU to the current menu bar." + (if (featurep 'menubar) + (progn + (unless (member menu easy-menu-all-popups) + (push menu easy-menu-all-popups)) + (setq mode-popup-menu (if (> (length easy-menu-all-popups) 1) + (cons (easy-menu-title) + (reverse easy-menu-all-popups)) + (car easy-menu-all-popups))) + + (cond ((null current-menubar) + ;; Don't add it to a non-existing menubar. + nil) + ((assoc (car menu) current-menubar) + ;; Already present. + nil) + ((equal current-menubar '(nil)) + ;; Set at left if only contains right marker. + (set-buffer-menubar (list menu nil))) + (t + ;; Add at right. + (set-buffer-menubar (copy-sequence current-menubar)) + (add-menu nil (car menu) (cdr menu))))))) + +(defun easy-menu-remove (menu) + "Remove MENU from the current menu bar." + (if (featurep 'menubar) + (progn + (setq easy-menu-all-popups (delq menu easy-menu-all-popups) + mode-popup-menu (if (< (length easy-menu-all-popups) 1) + (cons (easy-menu-title) + (reverse easy-menu-all-popups)) + (car easy-menu-all-popups))) + + (and current-menubar + (assoc (car menu) current-menubar) + (delete-menu-item (list (car menu))))))) + +;; Think up a good title for the menu. Take the major-mode of the +;; buffer, strip the -mode part, convert hyphens to spaces, and +;; capitalize it. +;; +;; If you can think of something smarter, feel free to replace it. +;; Don't forget to mail the change to xemacs@xemacs.org where everyone +;; can flame, er, praise your changes. +(defun easy-menu-title () + (capitalize (replace-in-string (replace-in-string + (symbol-name major-mode) "-mode$" "") + "-" " "))) + +(provide 'easymenu) + +;;; easymenu.el ends here
--- a/lisp/edebug/Makefile Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,75 +0,0 @@ -# Makefile for the edebug manual, and distribution packaging. -# -# March 1994 - -# The version of edebug. -VERSION = 3.4 - -# Redefine `TEX' if `tex' does not invoke plain TeX. For example: -# TEX=platex -TEX=tex - -# Redefine `DVIPS' if it is not `dvips'. The command line may need -# to be changed anyway. -DVIPS=dvips - -FILES = README Makefile edebug.el cust-print.el edebug-history \ - eval-region.el \ - edebug-test.el \ - cl-specs.el cl-read.el edebug-cl-read.el \ - edebug.tex edebug.texi - -# I include the cl package for now. -CLFILES = cl.el cl-extra.el cl-macs.el cl-seq.el cl-compat.el cl.texinfo - -SUBDIR = edebug-${VERSION} - -all: edebug.dvi - -# First shot to define xrefs and produce permuted index. -edebug.cp: edebug.tex edebug.texi - $(TEX) edebug.tex - -edebug.cps: edebug.cp - ./permute-index edebug cp - mv permuted.cps edebug.cps - -# Produce the final dvi. -edebug.dvi: edebug.cps - $(TEX) edebug.tex # This modifies edebug.cp again. - touch edebug.cps # This one is OK. - -# Produce a postscript file -edebug.ps: edebug.dvi - $(DVIPS) edebug.dvi -o edebug.ps - -# Produce edebug.info -edebug.info: edebug.tex edebug.texi - makeinfo edebug.tex - -dist edebug.tar.Z: ${FILES} - rm -rf edebug.tar edebug.tar.Z ${SUBDIR} - mkdir ${SUBDIR} - mv ${FILES} ${SUBDIR} - tar chf edebug.tar ${SUBDIR} - mv ${SUBDIR}/* . - compress edebug.tar - rm -r ${SUBDIR} - -cl-dist: ${CLFILES} - rm -rf cl.tar cl.tar.Z - tar cf cl.tar ${CLFILES} - compress cl.tar - -unpack: - uncompress edebug.tar.Z - tar xf edebug.tar - -mostlyclean clean: - rm -f edebug.dvi edebug.log edebug.toc - rm -f edebug.cp edebug.fn edebug.ky edebug.pg edebug.tp edebug.vr - rm -rf edebug.tar edebug.tar.Z ${SUBDIR} - -distclean realclean: clean - rm -f edebug.??s edebug.aux # tex files - rm -f *.elc
--- a/lisp/edebug/README Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,49 +0,0 @@ -Files included in this distribution: - -README This file. -Makefile Just enough to make the manual and distribution. -edebug.el The reason for all this. -cust-print.el The custom print package. -edebug-history A history of older modifications. -eval-reg.el Elisp version of eval-region. -cl-specs.el Specifications for Common Lisp macros. -cl-read.el Customizable, CL-like reader from bosch@crpht.lu. -edebug-cl-read.el Edebug reader macros for use with cl-read. -edebug.tex The manual source. -edebug.texi The core of the manual for Lisp Reference Manual. -edebug-test.el Some tests, not organized. - --------------------------- -Installation - -To install, put the .el files in some directory in your load-path and -byte-compile them. Put the following forms in your .emacs file. - -(define-key emacs-lisp-mode-map "\C-xx" 'edebug-eval-top-level-form) -(autoload 'edebug-eval-top-level-form "edebug") - -If you wish to change the default edebug global command prefix, change this: -(setq edebug-global-prefix "\C-xX") - -Other options, are described in the manual. -Also see cl-specs.el, and edebug-cl-read.el if they apply to you. - -In previous versions of edebug, users were directed to set -`debugger' to `edebug-debug'. This is no longer necessary -since Edebug automatically sets it whenever Edebug is active. - ---------------------------- - -Send me your enhancements, ideas, bugs, or fixes. -There is an edebug mailing list if you want to keep up -with the latest developments: edebug@cs.uiuc.edu -(requests to: edebug-request@cs.uiuc.edu) - -You can use edebug-submit-bug-report to simplify bug reporting. - -Daniel LaLiberte 217-398-4114 -University of Illinois, Urbana-Champaign -Department of Computer Science - -704 W Green -Champaign IL, 61820
--- a/lisp/edebug/advise-eval-region.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,46 +0,0 @@ -;;; advise-eval-region.el --- Wrap advice around eval-region -;; Copyright (C) 1996 Miranova Systems, Inc. - -;; Original-Author: Unknown -;; Adapted-By: Steven L Baur <steve@miranova.com> -;; Keywords: extensions lisp - -;; 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: - -;; This file splits out advice to eval-region formerly done in cl-read.el. -;; Due to the way cl-read.el reads itself in twice during bytecompilation, -;; and the fact that functions shouldn't be advised twice, I split this out -;; into its own file. - -;;; Code: - -(require 'advice) - -;; Advise the redefined eval-region -(defadvice eval-region (around cl-read activate) - "Use the reader::read instead of the original read if cl-read-active." - (with-elisp-eval-region (not cl-read-active) - ad-do-it)) - -(provide 'advise-eval-region) - -;;; advise-eval-region.el ends here
--- a/lisp/edebug/auto-autoloads.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,21 +0,0 @@ -;;; DO NOT MODIFY THIS FILE -(if (featurep 'edebug-autoloads) (error "Already loaded")) - -;;;### (autoloads (edebug-eval-top-level-form def-edebug-spec) "edebug" "edebug/edebug.el") - -(autoload 'def-edebug-spec "edebug" "\ -Set the edebug-form-spec property of SYMBOL according to SPEC. -Both SYMBOL and SPEC are unevaluated. The SPEC can be 0, t, a symbol -\(naming a function), or a list." nil 'macro) - -(defalias 'edebug-defun 'edebug-eval-top-level-form) - -(autoload 'edebug-eval-top-level-form "edebug" "\ -Evaluate a top level form, such as a defun or defmacro. -This is like `eval-defun', but the code is always instrumented for Edebug. -Print its name in the minibuffer and leave point where it is, -or if an error occurs, leave point after it with mark at the original point." t nil) - -;;;*** - -(provide 'edebug-autoloads)
--- a/lisp/edebug/cl-read.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1401 +0,0 @@ -;; Customizable, Common Lisp like reader for Emacs Lisp. -;; -;; Copyright (C) 1993 by Guido Bosch <Guido.Bosch@loria.fr> - -;; 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: - -;; Please send bugs and comments to the author. -;; -;; <DISCLAIMER> -;; This program is still under development. Neither the author nor -;; his employer accepts responsibility to anyone for the consequences of -;; using it or for whether it serves any particular purpose or works -;; at all. - - -;; Introduction -;; ------------ -;; -;; This package replaces the standard Emacs Lisp reader (implemented -;; as a set of built-in Lisp function in C) by a flexible and -;; customizable Common Lisp like one (implemented entirely in Emacs -;; Lisp). During reading of Emacs Lisp source files, it is about 40% -;; slower than the built-in reader, but there is no difference in -;; loading byte compiled files - they dont contain any syntactic sugar -;; and are loaded with the built in subroutine `load'. -;; -;; The user level functions for defining read tables, character and -;; dispatch macros are implemented according to the Commom Lisp -;; specification by Steel's (2nd edition), but the read macro functions -;; themselves are implemented in a slightly different way, because the -;; basic character reading is done in an Emacs buffer, and not by -;; using the primitive functions `read-char' and `unread-char', as real -;; CL does. To get 100% compatibility with CL, the above functions -;; (or their equivalents) must be implemented as subroutines. -;; -;; Another difference with real CL reading is that basic tokens (symbols -;; numbers, strings, and a few more) are still read by the original -;; built-in reader. This is necessary to get reasonable performance. -;; As a consquence, the read syntax of basic tokens can't be -;; customized. - -;; Most of the built-in reader syntax has been replaced by lisp -;; character macros: parentheses and brackets, simple and double -;; quotes, semicolon comments and the dot. In addition to that, the -;; following new syntax features are provided: - -;; Backquote-Comma-Atsign Macro: `(,el ,@list) -;; -;; (the clumsy Emacs Lisp syntax (` ((, el) (,@ list))) is also -;; supported, but with one restriction: the blank behind the quote -;; characters is mandatory when using the old syntax. The cl reader -;; needs it as a landmark to distinguish between old and new syntax. -;; An example: -;; -;; With blanks, both readers read the same: -;; (` (, (head)) (,@ (tail))) -std-read-> (` (, (head)) (,@ (tail))) -;; (` (, (head)) (,@ (tail))) -cl-read-> (` (, (head)) (,@ (tail))) -;; -;; Without blanks, the form is interpreted differently by the two readers: -;; (`(,(head)) (,@(tail))) -std-read-> (` (, (head)) (,@ (tail))) -;; (`(,(head)) (,@(tail))) -cl-read-> ((` ((, ((head)))) ((,@ ((tail))))) -;; -;; -;; Dispatch Character Macro" `#' -;; -;; #'<function> function quoting -;; #\<character> character syntax -;; #.<form> read time evaluation -;; #p<path>, #P<path> paths -;; #+<feature>, #-<feature> conditional reading -;; #<n>=, #<n># tags for shared structure reading -;; -;; Other read macros can be added easily (see the definition of the -;; above ones in this file, using the functions `set-macro-character' -;; and `set-dispatch-macro-character') -;; -;; The Cl reader is mostly downward compatile, (exception: backquote -;; comma macro, see above). E.g., this file, which is written entirely -;; in the standard Emacs Lisp syntax, can be read and compiled with the -;; cl-reader activated (see Examples below). - -;; This also works with package.el for Common Lisp packages. - - -;; Requirements -;; ------------ -;; The package runs on Emacs 18 and Emacs 19 (FSF and Lucid) It is -;; built on top of Dave Gillespie's cl.el package (version 2.02 or -;; later). The old one (from Ceazar Quiroz, still shiped with some -;; Emacs 19 disributions) will not do. - -;; Usage -;; ----- -;; The package is implemented as a kind of minor mode to the -;; emacs-lisp-mode. As most of the Emacs Lisp files are still written -;; in the standard Emacs Lisp syntax, the cl reader is only activated -;; on elisp files whose property lines contain the following entry: -;; -;; -*- Read-Syntax: Common-Lisp -*- -;; -;; Note that both property name ("Read-Syntax") and value -;; ("Common-Lisp") are not case sensitive. There can also be other -;; properties in this line: -;; -;; -*- Mode: Emacs-Lisp; Read-Syntax: Common-Lisp -*- - -;; Installation -;; ------------ -;; Save this file in a directory where Emacs will find it, then -;; byte compile it (M-x byte-compile-file). -;; -;; A permanent installation of the package can be done in two ways: -;; -;; 1.) If you want to have the package always loaded, put this in your -;; .emacs, or in just the files that require it: -;; -;; (require 'cl-read) -;; -;; 2.) To load the cl-read package automatically when visiting an elisp -;; file that needs it, it has to be installed using the -;; emacs-lisp-mode-hook. In this case, put the following function -;; definition and add-hook form in your .emacs: -;; -;; (defun cl-reader-autoinstall-function () -;; "Activates the Common Lisp style reader for emacs-lisp-mode buffers, -;; if the property line has a local variable setting like this: -;; \;\; -*- Read-Syntax: Common-Lisp -*-" -;; -;; (or (boundp 'local-variable-hack-done) -;; (let (local-variable-hack-done -;; (case-fold-search t)) -;; (hack-local-variables-prop-line 't) -;; (cond -;; ((and (boundp 'read-syntax) -;; read-syntax -;; (string-match "^common-lisp$" (symbol-name read-syntax))) -;; (require 'cl-read) -;; (make-local-variable 'cl-read-active) -;; (setq cl-read-active 't)))))) -;; -;; (add-hook 'emacs-lisp-mode-hook 'cl-reader-autoinstall-function) -;; -;; The `cl-reader-autoinstall-function' function tests for the -;; presence of the correct Read-Syntax property in the first line of -;; the file and loads the cl-read package if necessary. cl-read -;; replaces the following standard elisp functions: -;; -;; - read -;; - read-from-string -;; - eval-current-buffer -;; - eval-buffer -;; - eval-region -;; - eval-expression (to call reader explicitly) -;; -;; There may be other built-in functions that need to be replaced -;; (e.g. load). The behavior of the new reader function depends on -;; the value of the buffer local variable `cl-read-active': if it is -;; nil, they just call the original functions, otherwise they call the -;; cl reader. If the cl reader is active in a buffer, this is -;; indicated in the modeline by the string "CL" (minor mode like). -;; - -;; Examples: -;; --------- -;; After having installed the package as described above, the -;; following forms can be evaluated (M-C-x) with the cl reader being -;; active. (make sure that the mode line displays "(Emacs-Lisp CL)") -;; -;; (setq whitespaces '(#\space #\newline #\tab)) -;; (setq more-whitespaces `(#\page ,@whitespaces #\linefeed)) -;; (setq whitespace-strings (mapcar #'char-to-string more-whitespaces)) -;; -;; (setq shared-struct '(#1=[hello world] #1# #1#)) -;; (progn (setq cirlist '#1=(a b . #1#)) 't) -;; -;; This file, though written in standard Emacs Lisp syntax, can also be -;; compiled with the cl reader active: Type M-x byte-compile-file - -;; TO DO List: -;; ----------- -;; - Provide a replacement for load so that uncompiled cl syntax -;; source file can be loaded, too. For now prohibit loading un-bytecompiled. -;; - Do we really need the (require 'cl) dependency? Yes. -;; - More read macros: #S for structs, #A for array, #X for hex, #nR for radix -;; - Refine the error signaling mechanism. -;; - invalid-cl-read-syntax is now defined. what else? - - -; Change History -; -; $Log: cl-read.el,v $ -; Revision 1.2 1997/03/08 23:25:50 steve -; Patches to Beta6 -; -; Revision 1.19 94/03/21 19:59:24 liberte -; Add invalid-cl-read-syntax error symbol. -; Add reader::read-sexp and reader::read-sexp-func to allow customization -; based on the results of reading. -; Remove more dependencies on cl-package. -; Remove reader::eval-current-buffer, eval-buffer, and eval-region, -; and use elisp-eval-region package instead. -; -; Revision 1.18 94/03/04 23:42:24 liberte -; Fix typos in comments. -; -; Revision 1.17 93/11/24 12:04:09 bosch -; cl-packages dependency removed. `reader::read-constituent' and -; corresponding variables moved to cl-packages.el. -; Multi-line comment #| ... |# dispatch character read macro added. -; -; Revision 1.16 1993/11/23 10:21:02 bosch -; Patches from Daniel LaLiberte integrated. -; -; Revision 1.15 1993/11/18 21:21:10 bosch -; `reader::symbol-regexp1' modified. -; -; Revision 1.14 1993/11/17 19:06:32 bosch -; More characters added to `reader::symbol-characters'. -; `reader::read-constituent' modified. -; defpackage form added. -; -; Revision 1.13 1993/11/16 13:06:41 bosch -; - Symbol reading for CL package convention implemented. -; Variables `reader::symbol-characters', `reader::symbol-regexp1' and -; `reader::symbol-regexp2' and functions `reader::lookup-symbol' and -; `reader::read-constituent' added. -; - Prefix for internal symbols is now "reader::" (Common Lisp -; compatible). -; - Dispatch character macro #: for reading uninterned symbols added. -; -; Revision 1.12 1993/11/07 19:29:07 bosch -; Minor bug fix. -; -; Revision 1.11 1993/11/07 19:23:59 bosch -; Comment added. Character read macro #\<char> rewritten. Now reads -; e.g. #\meta-control-x. Needs to be checked. -; fix in `reader::restore-shared-structure'. `cl-reader-autoinstall-function' improved. -; -; Revision 1.10 1993/11/06 18:35:35 bosch -; Included Daniel LaLiberte's Patches. -; Efficiency of `reader::restore-shared-structure' improved. -; Implementation notes for shared structure reading added. -; -; Revision 1.9 1993/09/08 07:44:54 bosch -; Comment modified. -; -; Revision 1.8 1993/08/10 13:43:34 bosch -; Hook function `cl-reader-autoinstall-function' for automatic installation added. -; Buffer local variable `cl-read-active' added: together with the above -; hook it allows the file specific activation of the cl reader. -; -; Revision 1.7 1993/08/10 10:35:21 bosch -; Functions `read*' and `read-from-string*' renamed into `reader::read' -; and `reader::read-from-string'. Whitespace character skipping after -; recursive reader calls removed (Emacs 19 should not need this). -; Functions `cl-reader-install' and `cl-reader-uninstall' updated. -; Introduction text and function comments added. -; -; Revision 1.6 1993/08/09 15:36:05 bosch Function `read*' now nearly -; elisp compatible (no functions as streams, yet -- I don't think I -; will ever implement this, it would be far too slow). Elisp -; compatible function `read-from-string*' added. Replacements for -; `eval-current-buffer', `eval-buffer' and `eval-region' added. -; Renamed feature `cl-dg' in `cl', as Dave Gillespie's cl.el package -; is rather stable now. Function `cl-reader-install' and -; `cl-reader-uninstall' modified. -; -; Revision 1.5 1993/08/09 10:23:35 bosch -; Functions `copy-readtable' and `set-syntax-from-character' added. -; Variable `reader::internal-standard-readtable' added. Standard -; readtable initialization modified. Whitespace skipping placed back -; inside the read loop. -; -; Revision 1.4 1993/05/14 13:00:48 bosch -; Included patches from Daniel LaLiberte. -; -; Revision 1.3 1993/05/11 09:57:39 bosch -; `read*' renamed in `reader::read-from-buffer'. `read*' now can read -; from strings. -; -; Revision 1.2 1993/05/09 16:30:50 bosch -; (require 'cl-read) added. -; Calling of `{before,after}-read-hook' modified. -; -; Revision 1.1 1993/03/29 19:37:21 bosch -; Initial revision -; -; - -;;; Code: - -(require 'cl) -;; Thou shalt evaluate a defadvice only once, or thou shalt surely lose. -sb -(require 'advise-eval-region) - -;; load before compiling -;; This is ugly, but apparently the only way to do it :-( -sb -(provide 'cl-read) -(require 'cl-read) - -;; bootstrapping with cl-packages -;; defpackage and in-package are ignored until cl-read is installed. -'(defpackage reader - (:nicknames "rd") - (:use el) - (:export - cl-read-active - copy-readtable - set-macro-character - get-macro-character - set-syntax-from-character - make-dispatch-macro-character - set-dispatch-macro-character - get-dispatch-macro-character - before-read-hook - after-read-hook - cl-reader-install - cl-reader-uninstall - read-syntax - cl-reader-autoinstall-function)) - -'(in-package reader) - - -(autoload 'compiled-function-p "bytecomp") - -;; This makes cl-read behave as a kind of minor mode: - -(make-variable-buffer-local 'cl-read-active) -(defvar cl-read-active nil - "Buffer local variable that enables Common Lisp style syntax reading.") -(setq-default cl-read-active nil) - -(or (assq 'cl-read-active minor-mode-alist) - (setq minor-mode-alist - (cons '(cl-read-active " CL") minor-mode-alist))) - -;; Define a new error symbol: invalid-cl-read-syntax -;; XEmacs change -(define-error 'invalid-cl-read-syntax "Invalid CL read syntax" - 'invalid-read-syntax) - -(defun reader::error (msg &rest args) - (signal 'invalid-cl-read-syntax (list (apply 'format msg args)))) - - -;; The readtable - -(defvar reader::readtable-size 256 - "The size of a readtable." - ;; Actually, the readtable is a vector of size (1+ - ;; reader::readtable-size), because the last element contains the - ;; symbol `readtable', used for defining `readtablep. - ) - -;; An entry of the readtable must have one of the following forms: -;; -;; 1. A symbol, one of {illegal, constituent, whitespace}. It means -;; the character's reader class. -;; -;; 2. A function (i.e., a symbol with a function definition, a byte -;; compiled function or an uncompiled lambda expression). It means the -;; character is a macro character. -;; -;; 3. A vector of length `reader::readtable-size'. Elements of this vector -;; may be `nil' or a function (see 2.). It means the character is a -;; dispatch character, and the vector its dispatch function table. - -(defvar *readtable*) -(defvar reader::internal-standard-readtable) - -(defun* copy-readtable - (&optional (from-readtable *readtable*) - (to-readtable - (make-vector (1+ reader::readtable-size) 'illegal))) - "Return a copy of FROM-READTABLE \(default: *readtable*\). If the -FROM-READTABLE argument is provided as `nil', make a copy of a -standard \(CL-like\) readtable. If TO-READTABLE is provided, modify and -return it, otherwise create a new readtable object." - - (if (null from-readtable) - (setq from-readtable reader::internal-standard-readtable)) - - (loop for i to reader::readtable-size - as from-syntax = (aref from-readtable i) - do (setf (aref to-readtable i) - (if (vectorp from-syntax) - (copy-sequence from-syntax) - from-syntax)) - finally return to-readtable)) - - -(defmacro reader::get-readtable-entry (char readtable) - (` (aref (, readtable) (, char)))) - -(defun set-macro-character - (char function &optional readtable) - "Makes CHAR to be a macro character with FUNCTION as handler. -When CHAR is seen by reader::read-from-buffer, it calls FUNCTION. -Returns always t. Optional argument READTABLE is the readtable to set -the macro character in (default: *readtable*)." - (or readtable (setq readtable *readtable*)) - (or (reader::functionp function) - (reader::error "Not valid character macro function: %s" function)) - (setf (reader::get-readtable-entry char readtable) function) - t) - - -(put 'set-macro-character 'edebug-form-spec - '(&define sexp function-form &optional sexp)) -(put 'set-macro-character 'lisp-indent-function 1) - -(defun get-macro-character (char &optional readtable) - "Return the function associated with the character CHAR. -Optional READTABLE defaults to *readtable*. If char isn't a macro -character in READTABLE, return nil." - (or readtable (setq readtable *readtable*)) - (let ((entry (reader::get-readtable-entry char readtable))) - (if (reader::functionp entry) - entry))) - -(defun set-syntax-from-character - (to-char from-char &optional to-readtable from-readtable) - "Make the syntax of TO-CHAR be the same as the syntax of FROM-CHAR. -Optional TO-READTABLE and FROM-READTABLE are the corresponding tables -to use. TO-READTABLE defaults to the current readtable -\(*readtable*\), and FROM-READTABLE to nil, meaning to use the -syntaxes from the standard Lisp Readtable." - (or to-readtable (setq to-readtable *readtable*)) - (or from-readtable - (setq from-readtable reader::internal-standard-readtable)) - (let ((from-syntax - (reader::get-readtable-entry from-char from-readtable))) - (if (vectorp from-syntax) - ;; dispatch macro character table - (setq from-syntax (copy-sequence from-syntax))) - (setf (reader::get-readtable-entry to-char to-readtable) - from-syntax)) - t) - - -;; Dispatch macro character -(defun make-dispatch-macro-character (char &optional readtable) - "Let CHAR be a dispatch macro character in READTABLE (default: *readtable*)." - (or readtable (setq readtable *readtable*)) - (setf (reader::get-readtable-entry char readtable) - ;; create a dispatch character table - (make-vector reader::readtable-size nil))) - - -(defun set-dispatch-macro-character - (disp-char sub-char function &optional readtable) - "Make reading CHAR1 followed by CHAR2 be handled by FUNCTION. -Optional argument READTABLE (default: *readtable*). CHAR1 must first be -made a dispatch char with `make-dispatch-macro-character'." - (or readtable (setq readtable *readtable*)) - (let ((disp-table (reader::get-readtable-entry disp-char readtable))) - ;; check whether disp-char is a valid dispatch character - (or (vectorp disp-table) - (reader::error "`%c' not a dispatch macro character." disp-char)) - ;; check whether function is a valid function - (or (reader::functionp function) - (reader::error "Not valid dispatch character macro function: %s" - function)) - (setf (aref disp-table sub-char) function))) - -(put 'set-dispatch-macro-character 'edebug-form-spec - '(&define sexp sexp function-form &optional sexp)) -(put 'set-dispatch-macro-character 'lisp-indent-function 2) - - -(defun get-dispatch-macro-character - (disp-char sub-char &optional readtable) - "Return the macro character function for SUB-CHAR unser DISP-CHAR. -Optional READTABLE defaults to *readtable*. -Returns nil if there is no such function." - (or readtable (setq readtable *readtable*)) - (let ((disp-table (reader::get-readtable-entry disp-char readtable))) - (and (vectorp disp-table) - (reader::functionp (aref disp-table sub-char)) - (aref disp-table sub-char)))) - - -(defun reader::functionp (function) - ;; Check whether FUNCTION is a valid function object to be used - ;; as (dispatch) macro character function. - (or (and (symbolp function) (fboundp function)) - (compiled-function-p function) - (and (consp function) (eq (first function) 'lambda)))) - - -;; The basic reader loop - -;; shared and circular structure reading -(defvar reader::shared-structure-references nil) -(defvar reader::shared-structure-labels nil) - -(defun reader::read-sexp-func (point func) - ;; This function is called to read a sexp at POINT by calling FUNC. - ;; reader::read-sexp-func is here to be advised, e.g. by Edebug, - ;; to do something before or after reading. - (funcall func)) - -(defmacro reader::read-sexp (point &rest body) - ;; Called to return a sexp starting at POINT. BODY creates the sexp result - ;; and should leave point after the sexp. The body is wrapped in - ;; a lambda expression and passed to reader::read-sexp-func. - (` (reader::read-sexp-func (, point) (function (lambda () (,@ body)))))) - -(put 'reader::read-sexp 'edebug-form-spec '(form body)) -(put 'reader::read-sexp 'lisp-indent-function 2) -(put 'reader::read-sexp 'lisp-indent-hook 1) ;; Emacs 18 - - -(defconst before-read-hook nil) -(defconst after-read-hook nil) - -;; Set the hooks to `read-char' in order to step through the reader. e.g. -;; (add-hook 'before-read-hook '(lambda () (message "before") (read-char))) -;; (add-hook 'after-read-hook '(lambda () (message "after") (read-char))) - -(defmacro reader::encapsulate-recursive-call (reader-call) - ;; Encapsulate READER-CALL, a form that contains a recursive call to - ;; the reader, for usage inside the main reader loop. The macro - ;; wraps two hooks around READER-CALL: `before-read-hook' and - ;; `after-read-hook'. - ;; - ;; If READER-CALL returns normally, the macro exits immediately from - ;; the surrounding loop with the value of READER-CALL as result. If - ;; it exits non-locally (with tag `reader-ignore'), it just returns - ;; the value of READER-CALL, in which case the surrounding reader - ;; loop continues its execution. - ;; - ;; In both cases, `before-read-hook' and `after-read-hook' are - ;; called before and after executing READER-CALL. - ;; Are there any other uses for these hooks? Edebug doesn't need them. - (` (prog2 - (run-hooks 'before-read-hook) - ;; this catch allows to ignore the return, in the case that - ;; reader::read-from-buffer should continue looping (e.g. - ;; skipping over comments) - (catch 'reader-ignore - ;; this only works inside a block (e.g., in a loop): - ;; go outside - (return - (prog1 - (, reader-call) - ;; this occurrence of the after hook fires if the - ;; reader-call returns normally ... - (run-hooks 'after-read-hook)))) - ;; ... and that one if it was thrown to the tag 'reader-ignore - (run-hooks 'after-read-hook)))) - -(put 'reader::encapsulate-recursive-call 'edebug-form-spec '(form)) -(put 'reader::encapsulate-recursive-call 'lisp-indent-function 0) - -(defun reader::read-from-buffer (&optional stream reader::recursive-p) - (or (bufferp stream) - (reader::error "Sorry, can only read on buffers")) - (if (not reader::recursive-p) - ;; set up environment for shared structure reading - (let (reader::shared-structure-references - reader::shared-structure-labels - tmp-sexp) - ;; the reader returns an unshared sexpr, possibly containing - ;; symbolic references - (setq tmp-sexp (reader::read-from-buffer stream 't)) - (if ;; sexpr actually contained shared structures - reader::shared-structure-references - (reader::restore-shared-structure tmp-sexp) - ;; it did not, so don't bother about restoring - tmp-sexp)) - - (loop for char = (following-char) - for entry = (reader::get-readtable-entry char *readtable*) - if (eobp) do (reader::error "End of file during reading") - do - (cond - - ((eq entry 'illegal) - (reader::error "`%c' has illegal character syntax" char)) - - ;; skipping whitespace characters must be done inside this - ;; loop as character macro subroutines may return without - ;; leaving the loop using (throw 'reader-ignore ...) - ((eq entry 'whitespace) - (forward-char 1) - ;; skip all whitespace - (while (eq 'whitespace - (reader::get-readtable-entry - (following-char) *readtable*)) - (forward-char 1))) - - ;; for every token starting with a constituent character - ;; call the built-in reader (symbols, numbers, strings, - ;; characters with ?<char> syntax) - ((eq entry 'constituent) - (reader::encapsulate-recursive-call - (reader::read-constituent stream))) - - ((vectorp entry) - ;; Dispatch macro character. The dispatch macro character - ;; function is contained in the vector `entry', at the - ;; place indicated by <sub-char>, the first non-digit - ;; character following the <disp-char>: - ;; <disp-char><digit>*<sub-char> - (reader::encapsulate-recursive-call - (loop initially do (forward-char 1) - for sub-char = (prog1 (following-char) - (forward-char 1)) - while (memq sub-char - '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9)) - collect sub-char into digit-args - finally - (return - (funcall - ;; no test is done here whether a non-nil - ;; contents is a correct dispatch character - ;; function to apply. - (or (aref entry sub-char) - (reader::error - "Undefined subsequent dispatch character `%c'" - sub-char)) - stream - sub-char - (string-to-int - (apply 'concat - (mapcar - 'char-to-string digit-args)))))))) - - (t - ;; must be a macro character. In this case, `entry' is - ;; the function to be called - (reader::encapsulate-recursive-call - (progn - (forward-char 1) - (funcall entry stream char)))))))) - - -;; Constituent reader fix for Emacs 18 -(if (string-match "^19" emacs-version) - (defun reader::read-constituent (stream) - (reader::read-sexp (point) - (reader::original-read stream))) - - (defun reader::read-constituent (stream) - (reader::read-sexp (point) - (prog1 (reader::original-read stream) - ;; For Emacs 18, backing up is necessary because the `read' function - ;; reads one character too far after reading a symbol or number. - ;; This doesnt apply to reading chars (e.g. ?n). - ;; This still loses for escaped chars. - (if (not (eq (reader::get-readtable-entry - (preceding-char) *readtable*) 'constituent)) - (forward-char -1)))))) - - -;; Make the default current CL readtable - -(defconst *readtable* - (loop with raw-readtable = - (make-vector (1+ reader::readtable-size) 'illegal) - initially do (setf (aref raw-readtable reader::readtable-size) - 'readtable) - for entry in - '((constituent ?! ?@ ?$ ?% ?& ?* ?_ ?- ?+ ?= ?/ ?\\ ?0 ?1 ?2 - ?3 ?4 ?5 ?6 ?7 ?8 ?9 ?: ?~ ?> ?< ?a ?b - ?c ?d ?e ?f ?g ?h ?i ?j ?k ?l ?m ?n ?o ?p - ?q ?r ?s ?t ?u ?v ?w ?x ?y ?z ?A ?B ?C ?D - ?E ?F ?G ?H ?I ?J ?K ?L ?M ?N ?O ?P ?Q ?R - ?S ?T ?U ?V ?W ?X ?Y ?Z) - (whitespace ? ?\t ?\n ?\r ?\f) - - ;; The following CL character classes are only useful for - ;; token parsing. We don't need them, as token parsing is - ;; left to the built-in reader. - ;; (single-escape ?\\) - ;; (multiple-escape ?|) - ) - do - (loop for char in (rest entry) - do (setf (reader::get-readtable-entry char raw-readtable) - (first entry))) - finally return raw-readtable) - "The current readtable.") - - -;; Variables used non-locally in the standard readmacros -(defvar reader::context) -(defvar reader::stack) -(defvar reader::recursive-p) - - -;;;; Read macro character definitions - -;;; Hint for modifying, testing and debugging new read macros: All the -;;; read macros and dispatch character macros below are defined in -;;; the `*readtable*'. Modifications or -;;; instrumenting with edebug are effective immediately without having to -;;; copy the internal readtable to the standard *readtable*. However, -;;; if you wish to modify reader::internal-standard-readtable, then -;;; you must recopy *readtable*. - -;; Chars and strings - -;; This is defined to distinguish chars from constituents -;; since chars are read by the standard reader without reading too far. -(set-macro-character ?\? - (function - (lambda (stream char) - (forward-char -1) - (reader::read-sexp (point) - (reader::original-read stream))))) - -;; ?\M-\C-a - -;; This is defined to distinguish strings from constituents -;; since backing up after reading a string is simpler. -(set-macro-character ?\" - (function - (lambda (stream char) - (forward-char -1) - (reader::read-sexp (point) - (prog1 (reader::original-read stream) - ;; This is not needed with Emacs 19, but it is OK. See above. - (if (/= (preceding-char) ?\") - (forward-char -1))))))) - -;; Lists and dotted pairs -(set-macro-character ?\( - (function - (lambda (stream char) - (reader::read-sexp (1- (point)) - (catch 'read-list - (let ((reader::context 'list) reader::stack ) - ;; read list elements up to a `.' - (catch 'dotted-pair - (while t - (setq reader::stack (cons (reader::read-from-buffer stream 't) - reader::stack)))) - ;; In dotted pair. Read one more element - (setq reader::stack (cons (reader::read-from-buffer stream 't) - reader::stack) - ;; signal it to the closing paren - reader::context 'dotted-pair) - ;; Next char *must* be the closing paren that throws read-list - (reader::read-from-buffer stream 't) - ;; otherwise an error is signalled - (reader::error "Illegal dotted pair read syntax"))))))) - -(set-macro-character ?\) - (function - (lambda (stream char) - (cond ((eq reader::context 'list) - (throw 'read-list (nreverse reader::stack))) - ((eq reader::context 'dotted-pair) - (throw 'read-list (nconc (nreverse (cdr reader::stack)) - (car reader::stack)))) - (t - (reader::error "`)' doesn't end a list")))))) - -(set-macro-character ?\. - (function - (lambda (stream char) - (and (eq reader::context 'dotted-pair) - (reader::error "No more than one `.' allowed in list")) - (throw 'dotted-pair nil)))) - -;; '(#\a . #\b) -;; '(a . (b . c)) - -;; Vectors: [a b] -(set-macro-character ?\[ - (function - (lambda (stream char) - (reader::read-sexp (1- (point)) - (let ((reader::context 'vector)) - (catch 'read-vector - (let ((reader::context 'vector) - reader::stack) - (while t (push (reader::read-from-buffer stream 't) - reader::stack))))))))) - -(set-macro-character ?\] - (function - (lambda (stream char) - (if (eq reader::context 'vector) - (throw 'read-vector (apply 'vector (nreverse reader::stack))) - (reader::error "`]' doesn't end a vector"))))) - -;; Quote and backquote/comma macro -(set-macro-character ?\' - (function - (lambda (stream char) - (reader::read-sexp (1- (point)) - (list (reader::read-sexp (point) 'quote) - (reader::read-from-buffer stream 't)))))) - -(set-macro-character ?\` - (function - (lambda (stream char) - (if (= (following-char) ?\ ) - ;; old backquote syntax. This is ambigous, because - ;; (`(sexp)) is a valid form in both syntaxes, but - ;; unfortunately not the same. - ;; old syntax: read -> (` (sexp)) - ;; new syntax: read -> ((` (sexp))) - (reader::read-sexp (1- (point)) '\`) - (reader::read-sexp (1- (point)) - (list (reader::read-sexp (point) '\`) - (reader::read-from-buffer stream 't))))))) - -(set-macro-character ?\, - (function - (lambda (stream char) - (cond ((eq (following-char) ?\ ) - ;; old syntax - (reader::read-sexp (point) '\,)) - ((eq (following-char) ?\@) - (forward-char 1) - (cond ((eq (following-char) ?\ ) - (reader::read-sexp (point) '\,\@)) - (t - (reader::read-sexp (- (point) 2) - (list - (reader::read-sexp (point) '\,\@) - (reader::read-from-buffer stream 't)))))) - (t - (reader::read-sexp (1- (point)) - (list - (reader::read-sexp (1- (point)) '\,) - (reader::read-from-buffer stream 't)))))))) - -;; 'a -;; '(a b c) -;; (let ((a 10) (b '(20 30))) `(,a ,@b c)) -;; the old syntax is also supported: -;; (let ((a 10) (b '(20 30))) (` ((, a) (,@ b) c))) - -;; Single line character comment: ; -(set-macro-character ?\; - (function - (lambda (stream char) - (skip-chars-forward "^\n\r") - (throw 'reader-ignore nil)))) - - - -;; Dispatch character character # -(make-dispatch-macro-character ?\#) - -(defsubst reader::check-0-infix (n) - (or (= n 0) - (reader::error "Numeric infix argument not allowed: %d" n))) - - -(defalias 'search-forward-regexp 're-search-forward) - -;; nested multi-line comments #| ... |# -(set-dispatch-macro-character ?\# ?\| - (function - (lambda (stream char n) - (reader::check-0-infix n) - (let ((counter 0)) - (while (search-forward-regexp "#|\\||#" nil t) - (if (string-equal - (buffer-substring - (match-beginning 0) (match-end 0)) - "|#") - (cond ((> counter 0) - (decf counter)) - ((= counter 0) - ;; stop here - (goto-char (match-end 0)) - (throw 'reader-ignore nil)) - ('t - (reader::error "Unmatching closing multicomment"))) - (incf counter))) - (reader::error "Unmatching opening multicomment"))))) - -;; From cl-packages.el -(defconst reader::symbol-characters "[A-Za-z0-9-_!@$%^&*+=|~{}<>/]") -(defconst reader::symbol-regexp2 - (format "\\(%s+\\)" reader::symbol-characters)) - -(set-dispatch-macro-character ?\# ?\: - (function - (lambda (stream char n) - (reader::check-0-infix n) - (or (looking-at reader::symbol-regexp2) - (reader::error "Invalid symbol read syntax")) - (goto-char (match-end 0)) - (make-symbol - (buffer-substring (match-beginning 0) (match-end 0)))))) - -;; Function quoting: #'<function> -(set-dispatch-macro-character ?\# ?\' - (function - (lambda (stream char n) - (reader::check-0-infix n) - ;; Probably should test if cl is required by current buffer. - ;; Currently, cl will always be a feature because cl-read requires it. - (reader::read-sexp (- (point) 2) - (list - (reader::read-sexp (point) (if (featurep 'cl) 'function* 'function)) - (reader::read-from-buffer stream 't)))))) - -;; Character syntax: #\<char> -;; Not yet implemented: #\Control-a #\M-C-a etc. -;; This definition is not used - the next one is more general. -'(set-dispatch-macro-character ?# ?\\ - (function - (lambda (stream char n) - (reader::check-0-infix n) - (let ((next (following-char)) - name) - (if (not (and (<= ?a next) (<= next ?z))) - (progn (forward-char 1) next) - (setq next (reader::read-from-buffer stream t)) - (cond ((symbolp next) (setq name (symbol-name next))) - ((integerp next) (setq name (int-to-string next)))) - (if (= 1 (length name)) - (string-to-char name) - (case next - (linefeed ?\n) - (newline ?\r) - (space ?\ ) - (rubout ?\b) - (page ?\f) - (tab ?\t) - (return ?\C-m) - (t - (reader::error "Unknown character specification `%s'" - next)))))))) - ) - -(defvar reader::special-character-name-table - '(("linefeed" . ?\n) - ("newline" . ?\r) - ("space" . ?\ ) - ("rubout" . ?\b) - ("page" . ?\f) - ("tab" . ?\t) - ("return" . ?\C-m))) - -(set-dispatch-macro-character ?# ?\\ - (function - (lambda (stream char n) - (reader::check-0-infix n) - (forward-char -1) - ;; We should read in a special package to avoid creating symbols. - (let ((symbol (reader::read-from-buffer stream t)) - (case-fold-search t) - name modifier character char-base) - (setq name (symbol-name symbol)) - (if (string-match "^\\(meta-\\|m-\\|control-\\|c-\\)+" name) - (setq modifier (substring name - (match-beginning 1) - (match-end 1)) - character (substring name (match-end 1))) - (setq character name)) - (setq char-base - (cond ((= (length character) 1) - (string-to-char character)) - ('t - (cdr (assoc character - reader::special-character-name-table))))) - (or char-base - (reader::error - "Unknown character specification `%s'" character)) - - (and modifier - (progn - (and (string-match "control-\\|c-" modifier) - (decf char-base 32)) - (and (string-match "meta-\\|m-" modifier) - (incf char-base 128)))) - char-base)))) - -;; '(#\meta-space #\tab #\# #\> #\< #\a #\A #\return #\space) -;; (eq #\m-tab ?\M-\t) -;; (eq #\c-m-x #\m-c-x) -;; (eq #\Meta-Control-return #\M-C-return) -;; (eq #\m-m-c-c-x #\m-c-x) -;; #\C-space #\C-@ ?\C-@ - - - -;; Read and load time evaluation: #.<form> -;; Not yet implemented: #,<form> -(set-dispatch-macro-character ?\# ?\. - (function - (lambda (reader::stream reader::char reader::n) - (reader::check-0-infix reader::n) - ;; This eval will see all internal vars of reader, - ;; e.g. stream, reader::recursive-p. Anything that might be bound. - ;; We must use `read' here rather than read-from-buffer with 'recursive-p - ;; because the expression must not have unresolved #n#s in it anyway. - ;; Otherwise the top-level expression must be completely read before - ;; any embedded evaluation(s) occur(s). CLtL2 does not specify this. - ;; Also, call `read' so that it may be customized, by e.g. Edebug - (eval (read reader::stream))))) -;; '(#.(current-buffer) #.(get-buffer "*scratch*")) - -;; Path names (kind of): #p<string>, #P<string>, -(set-dispatch-macro-character ?\# ?\P - (function - (lambda (stream char n) - (reader::check-0-infix n) - (let ((string (reader::read-from-buffer stream 't))) - (or (stringp string) - (reader::error "Pathname must be a string: %s" string)) - (expand-file-name string))))) - -(set-dispatch-macro-character ?\# ?\p - (get-dispatch-macro-character ?\# ?\P)) - -;; #P"~/.emacs" -;; #p"~root/home" - -;; Feature reading: #+<feature>, #-<feature> -;; Not yet implemented: #+<boolean expression>, #-<boolean expression> - - -(defsubst reader::read-feature (stream char n flag) - (reader::check-0-infix n) - (let (;; Use the original reader to only read the feature. - ;; This is not exactly correct without *read-suppress*. - ;; Also Emacs 18 read goes one too far, - ;; so we assume there is a space after the feature. - (feature (reader::original-read stream)) - (object (reader::read-from-buffer stream 't))) - (if (eq (featurep feature) flag) - object - ;; Ignore it. - (throw 'reader-ignore nil)))) - -(set-dispatch-macro-character ?\# ?\+ - (function - (lambda (stream char n) - (reader::read-feature stream char n t)))) - -(set-dispatch-macro-character ?\# ?\- - (function - (lambda (stream char n) - (reader::read-feature stream char n nil)))) - -;; (#+cl loop #+cl do #-cl while #-cl t (body)) - - - - -;; Shared structure reading: #<n>=, #<n># - -;; Reading of sexpression with shared and circular structure read -;; syntax is done in two steps: -;; -;; 1. Create an sexpr with unshared structures, just as the ordinary -;; read macros do, with two exceptions: -;; - each label (#<n>=) creates, as a side effect, a symbolic -;; reference for the sexpr that follows it -;; - each reference (#<n>#) is replaced by the corresponding -;; symbolic reference. -;; -;; 2. This non-cyclic and unshared lisp structure is given to the -;; function `reader::restore-shared-structure' (see -;; `reader::read-from-buffer'), which simply replaces -;; destructively all symbolic references by the lisp structures the -;; references point at. -;; -;; A symbolic reference is an uninterned symbol whose name is obtained -;; from the label/reference number using the function `int-to-string': -;; -;; There are two non-locally used variables (bound in -;; `reader::read-from-buffer') which control shared structure reading: -;; `reader::shared-structure-labels': -;; A list of integers that correspond to the label numbers <n> in -;; the string currently read. This is used to avoid multiple -;; definitions of the same label. -;; `reader::shared-structure-references': -;; The list of symbolic references that will be used as temporary -;; placeholders for the shared objects introduced by a reference -;; with the same number identification. - -(set-dispatch-macro-character ?\# ?\= - (function - (lambda (stream char n) - (and (= n 0) (reader::error "0 not allowed as label")) - ;; check for multiple definition of the same label - (if (memq n reader::shared-structure-labels) - (reader::error "Label defined twice") - (push n reader::shared-structure-labels)) - ;; create an uninterned symbol as symbolic reference for the label - (let* ((string (int-to-string n)) - (ref (or (find string reader::shared-structure-references - :test 'string=) - (first - (push (make-symbol string) - reader::shared-structure-references))))) - ;; the link between the symbolic reference and the lisp - ;; structure it points at is done using the symbol value cell - ;; of the reference symbol. - (setf (symbol-value ref) - ;; this is also the return value - (reader::read-from-buffer stream 't)))))) - - -(set-dispatch-macro-character ?\# ?\# - (function - (lambda (stream char n) - (and (= n 0) (reader::error "0 not allowed as label")) - ;; use the non-local variable `reader::recursive-p' (from the reader - ;; main loop) to detect labels at the top level of an sexpr. - (if (not reader::recursive-p) - (reader::error "References at top level not allowed")) - (let* ((string (int-to-string n)) - (ref (or (find string reader::shared-structure-references - :test 'string=) - (first - (push (make-symbol string) - reader::shared-structure-references))))) - ;; the value of reading a #n# form is a reference symbol - ;; whose symbol value is or will be the shared structure. - ;; `reader::restore-shared-structure' then replaces the symbol by - ;; its value. - ref)))) - -(defun reader::restore-shared-structure (obj) - ;; traverses recursively OBJ and replaces all symbolic references by - ;; the objects they point at. Remember that a symbolic reference is - ;; an uninterned symbol whose value is the object it points at. - (cond - ((consp obj) - (loop for rest on obj - as lastcdr = rest - do - (if;; substructure is a symbolic reference - (memq (car rest) reader::shared-structure-references) - ;; replace it by its symbol value, i.e. the associated object - (setf (car rest) (symbol-value (car rest))) - (reader::restore-shared-structure (car rest))) - finally - (if (memq (cdr lastcdr) reader::shared-structure-references) - (setf (cdr lastcdr) (symbol-value (cdr lastcdr))) - (reader::restore-shared-structure (cdr lastcdr))))) - ((vectorp obj) - (loop for i below (length obj) - do - (if;; substructure is a symbolic reference - (memq (aref obj i) reader::shared-structure-references) - ;; replace it by its symbol value, i.e. the associated object - (setf (aref obj i) (symbol-value (aref obj i))) - (reader::restore-shared-structure (aref obj i)))))) - obj) - - -;; #1=(a b #3=[#2=c]) -;; (#1=[#\return #\a] #1# #1#) -;; (#1=[a b c] #1# #1#) -;; #1=(a b . #1#) - -;; Creation and initialization of an internal standard readtable. -;; Do this after all the macros and dispatch chars above have been defined. - -(defconst reader::internal-standard-readtable (copy-readtable) - "The original (CL-like) standard readtable. If you ever modify this -readtable, you won't be able to recover a standard readtable using -\(copy-readtable nil\)") - - -;; Replace built-in functions that call the built-in reader -;; -;; The following functions are replaced here: -;; -;; read by reader::read -;; read-from-string by reader::read-from-string -;; -;; eval-expression by reader::eval-expression -;; Why replace eval-expression? Not needed for Lucid Emacs since the -;; reader for arguments is also written in Lisp, and so may be overridden. -;; -;; eval-current-buffer by reader::eval-current-buffer -;; eval-buffer by reader::eval-buffer -;; original-eval-region by reader::original-eval-region - - -;; Temporary read buffer used for reading from strings -(defconst reader::tmp-buffer - (get-buffer-create " *CL Read*")) - -;; Save a pointer to the original read function -(or (fboundp 'reader::original-read) - (fset 'reader::original-read (symbol-function 'read))) - -(defun reader::read (&optional stream reader::recursive-p) - "Read one Lisp expression as text from STREAM, return as Lisp object. -If STREAM is nil, use the value of `standard-input' \(which see\). -STREAM or the value of `standard-input' may be: - a buffer \(read from point and advance it\) - a marker \(read from where it points and advance it\) - a string \(takes text from string, starting at the beginning\) - t \(read text line using minibuffer and use it\). - -This is the cl-read replacement of the standard elisp function -`read'. The only incompatibility is that functions as stream arguments -are not supported." - (if (not cl-read-active) - (reader::original-read stream) - (if (null stream) ; read from standard-input - (setq stream standard-input)) - - (if (eq stream 't) ; read from minibuffer - (setq stream (read-from-minibuffer "Common Lisp Expression: "))) - - (cond - - ((bufferp stream) ; read from buffer - (reader::read-from-buffer stream reader::recursive-p)) - - ((markerp stream) ; read from marker - (save-excursion - (set-buffer (marker-buffer stream)) - (goto-char (marker-position stream)) - (reader::read-from-buffer (current-buffer) reader::recursive-p))) - - ((stringp stream) ; read from string - (save-excursion - (set-buffer reader::tmp-buffer) - (auto-save-mode -1) - (erase-buffer) - (insert stream) - (goto-char (point-min)) - (reader::read-from-buffer reader::tmp-buffer reader::recursive-p))) - (t - (reader::error "Not a valid stream: %s" stream))))) - -;; read-from-string -;; save a pointer to the original `read-from-string' function -(or (fboundp 'reader::original-read-from-string) - (fset 'reader::original-read-from-string - (symbol-function 'read-from-string))) - -(defun reader::read-from-string (string &optional start end) - "Read one Lisp expression which is represented as text by STRING. -Returns a cons: (OBJECT-READ . FINAL-STRING-INDEX). -START and END optionally delimit a substring of STRING from which to read; -they default to 0 and (length STRING) respectively. - -This is the cl-read replacement of the standard elisp function -`read-from-string'. It uses the reader macros in *readtable* if -`cl-read-active' is non-nil in the current buffer." - - ;; Does it really make sense to have read-from-string depend on - ;; what the current buffer happens to be? Yes, so code that - ;; has nothing to do with cl-read uses original reader. - (if (not cl-read-active) - (reader::original-read-from-string string start end) - (or start (setq start 0)) - (or end (setq end (length string))) - (save-excursion - (set-buffer reader::tmp-buffer) - (auto-save-mode -1) - (erase-buffer) - (insert (substring string 0 end)) - (goto-char (1+ start)) - (cons - (reader::read-from-buffer reader::tmp-buffer nil) - (1- (point)))))) - -;; (read-from-string "abc (car 'a) bc" 4) -;; (reader::read-from-string "abc (car 'a) bc" 4) -;; (read-from-string "abc (car 'a) bc" 2 11) -;; (reader::read-from-string "abc (car 'a) bc" 2 11) -;; (reader::read-from-string "`(car ,first ,@rest)") -;; (read-from-string ";`(car ,first ,@rest)") -;; (reader::read-from-string ";`(car ,first ,@rest)") - -;; We should replace eval-expression, too, so that it reads (and -;; evals) in the current buffer. Alternatively, this could be fixed -;; in C. In Lemacs 19.6 and later, this function is already written -;; in lisp, and based on more primitive read functions we already -;; replaced. The reading happens during the interactive parameter -;; retrieval, which is written in lisp, too. So this replacement of -;; eval-expression is only required for (FSF) Emacs 18 (and 19?). - -(or (fboundp 'reader::original-eval-expression) - (fset 'reader::original-eval-expression - (symbol-function 'eval-expression))) - -(defun reader::eval-expression (reader::expression) - "Evaluate EXPRESSION and print value in minibuffer. -Value is also consed on to front of variable `values'." - (interactive - (list - (car (read-from-string - (read-from-minibuffer - "Eval: " nil - ;;read-expression-map ;; not for emacs 18 - nil ;; use default map - nil ;; don't do read with minibuffer current. - ;; 'edebug-expression-history ;; not for emacs 18 - ))))) - (setq values (cons (eval reader::expression) values)) - (prin1 (car values) t)) - -(require 'eval-reg "eval-reg") -; (require 'advice) - - -;; installing/uninstalling the cl reader -;; These two should always be used in pairs, or just install once and -;; never uninstall. -(defun cl-reader-install () - (interactive) - (fset 'read 'reader::read) - (fset 'read-from-string 'reader::read-from-string) - (fset 'eval-expression 'reader::eval-expression) - (elisp-eval-region-install)) - -(defun cl-reader-uninstall () - (interactive) - (fset 'read - (symbol-function 'reader::original-read)) - (fset 'read-from-string - (symbol-function 'reader::original-read-from-string)) - (fset 'eval-expression - (symbol-function 'reader::original-eval-expression)) - (elisp-eval-region-uninstall)) - -;; Globally installing the cl-read replacement functions is safe, even -;; for buffers without cl read syntax. The buffer local variable -;; `cl-read-active' controls whether the replacement funtions of this -;; package or the original ones are actually called. -(cl-reader-install) -(cl-reader-uninstall) - -(add-hook 'emacs-lisp-mode-hook 'cl-reader-autoinstall-function) - -'(defvar read-syntax) - -'(defun cl-reader-autoinstall-function () - "Activates the Common Lisp style reader for emacs-lisp-mode buffers, -if the property line has a local variable setting like this: -\;\; -*- Read-Syntax: Common-Lisp -*-" - ;; this is a hack to avoid recursion in the case that the prop line - ;; containes "Mode: emacs-lisp" entry - (or (boundp 'local-variable-hack-done) - (let (local-variable-hack-done - (case-fold-search t)) - ;; Usually `hack-local-variables-prop-line' is called only after - ;; installation of the major mode. But we need to know about the - ;; local variables before that, so we call the local variable hack - ;; explicitly here: - (hack-local-variables-prop-line 't) - ;; But hack-local-variables-prop-line not defined in emacs 18. - (cond - ((and (boundp 'read-syntax) - read-syntax - (string-match "^common-lisp$" (symbol-name read-syntax))) - (require 'cl-read) - (make-local-variable 'cl-read-active) - (setq cl-read-active 't)))))) - -;; Emacs 18 doesnt have hack-local-variables-prop-line. So use this instead. -(defun cl-reader-autoinstall-function () - (save-excursion - (goto-char (point-min)) - (let ((case-fold-search t)) - (cond ((re-search-forward - "read-syntax: *common-lisp" - (save-excursion - (end-of-line) - (point)) - t) - (require 'cl-read) - (make-local-variable 'cl-read-active) - (setq cl-read-active t)))))) - - -(run-hooks 'cl-read-load-hooks) - -;; cl-read.el ends here
--- a/lisp/edebug/cl-specs.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,477 +0,0 @@ -;; cl-specs.el - Edebug specs for cl.el - -;; Copyright (C) 1993 Free Software Foundation, Inc. -;; Author: Daniel LaLiberte <liberte@cs.uiuc.edu> -;; Keywords: lisp, tools, maint - -;; 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: - -;; LCD Archive Entry: -;; cl-specs.el|Daniel LaLiberte|liberte@cs.uiuc.edu -;; |Edebug specs for cl.el -;; |$Date: 1996/12/18 22:51:45 $|$Revision: 1.1.1.2 $|~/modes/cl-specs.el| - -;; These specs are to be used with edebug.el version 3.3 or later and -;; cl.el version 2.03 or later, by Dave Gillespie <daveg@synaptics.com>. - -;; This file need not be byte-compiled, but it shouldn't hurt. - -;;; Code: - -(provide 'cl-specs) -;; Do the above provide before the following require. -;; Otherwise if you load this before edebug if cl is already loaded -;; an infinite loading loop would occur. -(require 'edebug) - -;; Blocks - -(def-edebug-spec block (symbolp body)) -(def-edebug-spec return (&optional form)) -(def-edebug-spec return-from (symbolp &optional form)) - -;; Loops - -(def-edebug-spec when t) -(def-edebug-spec unless t) -(def-edebug-spec case (form &rest (sexp body))) -(def-edebug-spec ecase case) -(def-edebug-spec do - ((&rest &or symbolp (symbolp &optional form form)) - (form body) - cl-declarations body)) -(def-edebug-spec do* do) -(def-edebug-spec dolist - ((symbolp form &optional form) cl-declarations body)) -(def-edebug-spec dotimes dolist) -(def-edebug-spec do-symbols - ((symbolp &optional form form) cl-declarations body)) -(def-edebug-spec do-all-symbols - ((symbolp &optional form) cl-declarations body)) - -;; Multiple values - -(def-edebug-spec multiple-value-list (form)) -(def-edebug-spec multiple-value-call (function-form body)) -(def-edebug-spec multiple-value-bind - ((&rest symbolp) form cl-declarations body)) -(def-edebug-spec multiple-value-setq ((&rest symbolp) form)) -(def-edebug-spec multiple-value-prog1 (form body)) - -;; Bindings - -(def-edebug-spec lexical-let let) -(def-edebug-spec lexical-let* let) - -(def-edebug-spec psetq setq) -(def-edebug-spec progv (form form body)) - -(def-edebug-spec flet ((&rest (defun*)) cl-declarations body)) -(def-edebug-spec labels flet) - -(def-edebug-spec macrolet - ((&rest (&define name (&rest arg) cl-declarations-or-string def-body)) - cl-declarations body)) - -(def-edebug-spec symbol-macrolet - ((&rest (symbol sexp)) cl-declarations body)) - -(def-edebug-spec destructuring-bind - (&define cl-macro-list form cl-declarations def-body)) - -;; Setf - -(def-edebug-spec setf (&rest [place form])) ;; sexp is not specific enough -(def-edebug-spec psetf setf) - -(def-edebug-spec letf ;; *not* available in Common Lisp - ((&rest (gate place &optional form)) - body)) -(def-edebug-spec letf* letf) - - -(def-edebug-spec defsetf - (&define name - [&or [symbolp &optional stringp] - [cl-lambda-list (symbolp)]] - cl-declarations-or-string def-body)) - -(def-edebug-spec define-setf-method - (&define name cl-lambda-list cl-declarations-or-string def-body)) - -(def-edebug-spec define-modify-macro - (&define name cl-lambda-list ;; should exclude &key - symbolp &optional stringp)) - -(def-edebug-spec callf (function* place &rest form)) -(def-edebug-spec callf2 (function* form place &rest form)) - -;; Other operations on places - -(def-edebug-spec remf (place form)) - -(def-edebug-spec incf (place &optional form)) -(def-edebug-spec decf incf) -(def-edebug-spec push (form place)) -(def-edebug-spec pushnew - (form place &rest - &or [[&or ":test" ":test-not" ":key"] function-form] - [keywordp form])) -(def-edebug-spec pop (place)) - -(def-edebug-spec shiftf (&rest place)) ;; really [&rest place] form -(def-edebug-spec rotatef (&rest place)) - - -;; Functions with function args. These are only useful if the -;; function arg is quoted with ' instead of function. - -(def-edebug-spec some (function-form form &rest form)) -(def-edebug-spec every some) -(def-edebug-spec notany some) -(def-edebug-spec notevery some) - -;; Mapping - -(def-edebug-spec map (form function-form form &rest form)) -(def-edebug-spec maplist (function-form form &rest form)) -(def-edebug-spec mapc maplist) -(def-edebug-spec mapl maplist) -(def-edebug-spec mapcan maplist) -(def-edebug-spec mapcon maplist) - -;; Sequences - -(def-edebug-spec reduce (function-form form &rest form)) - -;; Types and assertions - -(def-edebug-spec cl-type-spec (sexp)) ;; not worth the trouble to specify, yet. - -(def-edebug-spec deftype defmacro*) -(def-edebug-spec check-type (place cl-type-spec &optional stringp)) -;; (def-edebug-spec assert (form &optional form stringp &rest form)) -(def-edebug-spec assert (form &rest form)) -(def-edebug-spec typecase (form &rest ([&or cl-type-spec "otherwise"] body))) -(def-edebug-spec etypecase typecase) - -(def-edebug-spec ignore-errors t) - -;; Time of Evaluation - -(def-edebug-spec eval-when - ((&rest &or "compile" "load" "eval") body)) -(def-edebug-spec load-time-value (form &optional &or "t" "nil")) - -;; Declarations - -(def-edebug-spec cl-decl-spec - ((symbolp &rest sexp))) - -(def-edebug-spec cl-declarations - (&rest ("declare" &rest cl-decl-spec))) - -(def-edebug-spec cl-declarations-or-string - (&or stringp cl-declarations)) - -(def-edebug-spec declaim (&rest cl-decl-spec)) -(def-edebug-spec declare (&rest cl-decl-spec)) ;; probably not needed. -(def-edebug-spec locally (cl-declarations &rest form)) -(def-edebug-spec the (cl-type-spec form)) - -;;====================================================== -;; Lambda things - -(def-edebug-spec cl-lambda-list - (([&rest arg] - [&optional ["&optional" cl-&optional-arg &rest cl-&optional-arg]] - [&optional ["&rest" arg]] - [&optional ["&key" [cl-&key-arg &rest cl-&key-arg] - &optional "&allow-other-keywords"]] - [&optional ["&aux" &rest - &or (symbolp &optional def-form) symbolp]] - ))) - -(def-edebug-spec cl-&optional-arg - (&or (arg &optional def-form arg) arg)) - -(def-edebug-spec cl-&key-arg - (&or ([&or (symbolp arg) arg] &optional def-form arg) arg)) - -;; The lambda list for macros is different from that of normal lambdas. -;; Note that &environment is only allowed as first or last items in the -;; top level list. - -(def-edebug-spec cl-macro-list - (([&optional "&environment" arg] - [&rest cl-macro-arg] - [&optional ["&optional" &rest - &or (cl-macro-arg &optional def-form cl-macro-arg) arg]] - [&optional [[&or "&rest" "&body"] cl-macro-arg]] - [&optional ["&key" [&rest - [&or ([&or (symbolp cl-macro-arg) arg] - &optional def-form cl-macro-arg) - arg]] - &optional "&allow-other-keywords"]] - [&optional ["&aux" &rest - &or (symbolp &optional def-form) symbolp]] - [&optional "&environment" arg] - ))) - -(def-edebug-spec cl-macro-arg - (&or arg cl-macro-list1)) - -(def-edebug-spec cl-macro-list1 - (([&optional "&whole" arg] ;; only allowed at lower levels - [&rest cl-macro-arg] - [&optional ["&optional" &rest - &or (cl-macro-arg &optional def-form cl-macro-arg) arg]] - [&optional [[&or "&rest" "&body"] cl-macro-arg]] - [&optional ["&key" [&rest - [&or ([&or (symbolp cl-macro-arg) arg] - &optional def-form cl-macro-arg) - arg]] - &optional "&allow-other-keywords"]] - [&optional ["&aux" &rest - &or (symbolp &optional def-form) symbolp]] - . [&or arg nil]))) - - -(def-edebug-spec defun* - ;; Same as defun but use cl-lambda-list. - (&define [&or name - ("setf" :name setf name)] - cl-lambda-list - cl-declarations-or-string - [&optional ("interactive" interactive)] - def-body)) -(def-edebug-spec defsubst* defun*) - -(def-edebug-spec defmacro* - (&define name cl-macro-list cl-declarations-or-string def-body)) -(def-edebug-spec define-compiler-macro defmacro*) - - -(def-edebug-spec function* - (&or symbolp cl-lambda-expr)) - -(def-edebug-spec cl-lambda-expr - (&define ("lambda" cl-lambda-list - ;;cl-declarations-or-string - ;;[&optional ("interactive" interactive)] - def-body))) - -;; Redefine function-form to also match function* -(def-edebug-spec function-form - ;; form at the end could also handle "function", - ;; but recognize it specially to avoid wrapping function forms. - (&or ([&or "quote" "function"] &or symbolp lambda-expr) - ("function*" cl-lambda-expr) - form)) - -;;====================================================== -;; Structures -;; (def-edebug-spec defstruct (&rest sexp)) would be sufficient, but... - -;; defstruct may contain forms that are evaluated when a structure is created. -(def-edebug-spec defstruct - (&define ; makes top-level form not be wrapped - [&or symbolp - (gate - symbolp &rest - (&or [":conc-name" &or stringp "nil"] - [":constructor" symbolp &optional cl-lambda-list] - [":copier" symbolp] - [":predicate" symbolp] - [":include" symbolp &rest sexp];; not finished - ;; The following are not supported. - ;; [":print-function" ...] - ;; [":type" ...] - ;; [":initial-offset" ...] - ))] - [&optional stringp] - ;; All the above is for the following def-form. - &rest &or symbolp (symbolp def-form &optional ":read-only" sexp))) - -;;====================================================== -;; Loop - -;; The loop macro is very complex, and a full spec is found below. -;; The following spec only minimally specifies that -;; parenthesized forms are executable, but single variables used as -;; expressions will be missed. You may want to use this if the full -;; spec causes problems for you. - -(def-edebug-spec loop - (&rest &or symbolp form)) - -;; Below is a complete spec for loop, in several parts that correspond -;; to the syntax given in CLtL2. The specs do more than specify where -;; the forms are; it also specifies, as much as Edebug allows, all the -;; syntactically legal loop clauses. The disadvantage of this -;; completeness is rigidity, but the "for ... being" clause allows -;; arbitrary extensions of the form: [symbolp &rest &or symbolp form]. - -(def-edebug-spec loop - ([&optional ["named" symbolp]] - [&rest - &or - ["repeat" form] - loop-for-as - loop-with - loop-initial-final] - [&rest loop-clause] - )) - -(def-edebug-spec loop-with - ("with" loop-var - loop-type-spec - [&optional ["=" form]] - &rest ["and" loop-var - loop-type-spec - [&optional ["=" form]]])) - -(def-edebug-spec loop-for-as - ([&or "for" "as"] loop-for-as-subclause - &rest ["and" loop-for-as-subclause])) - -(def-edebug-spec loop-for-as-subclause - (loop-var - loop-type-spec - &or - [[&or "in" "on" "in-ref" "across-ref"] - form &optional ["by" function-form]] - - ["=" form &optional ["then" form]] - ["across" form] - ["being" - [&or "the" "each"] - &or - [[&or "element" "elements"] - [&or "of" "in" "of-ref"] form - &optional "using" ["index" symbolp]];; is this right? - [[&or "hash-key" "hash-keys" - "hash-value" "hash-values"] - [&or "of" "in"] - hash-table-p &optional ["using" ([&or "hash-value" "hash-values" - "hash-key" "hash-keys"] sexp)]] - - [[&or "symbol" "present-symbol" "external-symbol" - "symbols" "present-symbols" "external-symbols"] - [&or "in" "of"] package-p] - - ;; Extensions for Emacs Lisp, including Lucid Emacs. - [[&or "frame" "frames" - "screen" "screens" - "buffer" "buffers"]] - - [[&or "window" "windows"] - [&or "of" "in"] form] - - [[&or "overlay" "overlays" - "extent" "extents"] - [&or "of" "in"] form - &optional [[&or "from" "to"] form]] - - [[&or "interval" "intervals"] - [&or "in" "of"] form - &optional [[&or "from" "to"] form] - ["property" form]] - - [[&or "key-code" "key-codes" - "key-seq" "key-seqs" - "key-binding" "key-bindings"] - [&or "in" "of"] form - &optional ["using" ([&or "key-code" "key-codes" - "key-seq" "key-seqs" - "key-binding" "key-bindings"] - sexp)]] - ;; For arbitrary extensions, recognize anything else. - [symbolp &rest &or symbolp form] - ] - - ;; arithmetic - must be last since all parts are optional. - [[&optional [[&or "from" "downfrom" "upfrom"] form]] - [&optional [[&or "to" "downto" "upto" "below" "above"] form]] - [&optional ["by" form]] - ])) - -(def-edebug-spec loop-initial-final - (&or ["initially" - ;; [&optional &or "do" "doing"] ;; CLtL2 doesnt allow this. - &rest loop-non-atomic-expr] - ["finally" &or - [[&optional &or "do" "doing"] &rest loop-non-atomic-expr] - ["return" form]])) - -(def-edebug-spec loop-and-clause - (loop-clause &rest ["and" loop-clause])) - -(def-edebug-spec loop-clause - (&or - [[&or "while" "until" "always" "never" "thereis"] form] - - [[&or "collect" "collecting" - "append" "appending" - "nconc" "nconcing" - "concat" "vconcat"] form - [&optional ["into" loop-var]]] - - [[&or "count" "counting" - "sum" "summing" - "maximize" "maximizing" - "minimize" "minimizing"] form - [&optional ["into" loop-var]] - loop-type-spec] - - [[&or "if" "when" "unless"] - form loop-and-clause - [&optional ["else" loop-and-clause]] - [&optional "end"]] - - [[&or "do" "doing"] &rest loop-non-atomic-expr] - - ["return" form] - loop-initial-final - )) - -(def-edebug-spec loop-non-atomic-expr - ([¬ atom] form)) - -(def-edebug-spec loop-var - ;; The symbolp must be last alternative to recognize e.g. (a b . c) - ;; loop-var => - ;; (loop-var . [&or nil loop-var]) - ;; (symbolp . [&or nil loop-var]) - ;; (symbolp . loop-var) - ;; (symbolp . (symbolp . [&or nil loop-var])) - ;; (symbolp . (symbolp . loop-var)) - ;; (symbolp . (symbolp . symbolp)) == (symbolp symbolp . symbolp) - (&or (loop-var . [&or nil loop-var]) [gate symbolp])) - -(def-edebug-spec loop-type-spec - (&optional ["of-type" loop-d-type-spec])) - -(def-edebug-spec loop-d-type-spec - (&or (loop-d-type-spec . [&or nil loop-d-type-spec]) cl-type-spec)) - -;; cl-specs.el ends here
--- a/lisp/edebug/cust-print.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,726 +0,0 @@ -;;; cust-print.el --- handles print-level and print-circle. - -;; Copyright (C) 1992 Free Software Foundation, Inc. - -;; Author: Daniel LaLiberte <liberte@cs.uiuc.edu> -;; Adapted-By: ESR -;; Keywords: extensions - -;; 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 - -;; LCD Archive Entry: -;; cust-print|Daniel LaLiberte|liberte@cs.uiuc.edu -;; |Handle print-level, print-circle and more. -;; |$Date: 1996/12/18 22:51:45 $|$Revision: 1.1.1.2 $| - -;; =============================== -;; $Header: /afs/informatik.uni-tuebingen.de/local/web/xemacs/xemacs-cvs/XEmacs/xemacs/lisp/edebug/Attic/cust-print.el,v 1.1.1.2 1996/12/18 22:51:45 steve Exp $ -;; $Log: cust-print.el,v $ -;; Revision 1.1.1.2 1996/12/18 22:51:45 steve -;; XEmacs 20.0 -- Beta 31 -;; -;; Revision 1.4 1994/03/23 20:34:29 liberte -;; * Change "emacs" to "original" - I just can't decide. -;; -;; Revision 1.3 1994/02/21 21:25:36 liberte -;; * Make custom-prin1-to-string more robust when errors occur. -;; * Change "internal" to "emacs". -;; -;; Revision 1.2 1993/11/22 22:36:36 liberte -;; * Simplified and generalized printer customization. -;; custom-printers is an alist of (PREDICATE . PRINTER) pairs -;; for any data types. The PRINTER function should print to -;; `standard-output' add-custom-printer and delete-custom-printer -;; change custom-printers. -;; -;; * Installation function now called install-custom-print. The -;; old name is still around for now. -;; -;; * New macro with-custom-print (added earlier) - executes like -;; progn but with custom-print activated temporarily. -;; -;; * Cleaned up comments for replacements of standardard printers. -;; -;; * Changed custom-prin1-to-string to use a temporary buffer. -;; -;; * Internal symbols are prefixed with CP::. -;; -;; * Option custom-print-vectors (added earlier) - controls whether -;; vectors should be printed according to print-length and -;; print-length. Emacs doesnt do this, but cust-print would -;; otherwise do it only if custom printing is required. -;; -;; * Uninterned symbols are treated as non-read-equivalent. -;; - - -;;; Commentary: - -;; This package provides a general print handler for prin1 and princ -;; that supports print-level and print-circle, and by the way, -;; print-length since the standard routines are being replaced. Also, -;; to print custom types constructed from lists and vectors, use -;; custom-print-list and custom-print-vector. See the documentation -;; strings of these variables for more details. - -;; If the results of your expressions contain circular references to -;; other parts of the same structure, the standard Emacs print -;; subroutines may fail to print with an untrappable error, -;; "Apparently circular structure being printed". If you only use cdr -;; circular lists (where cdrs of lists point back; what is the right -;; term here?), you can limit the length of printing with -;; print-length. But car circular lists and circular vectors generate -;; the above mentioned error in Emacs version 18. Version -;; 19 supports print-level, but it is often useful to get a better -;; print representation of circular and shared structures; the print-circle -;; option may be used to print more concise representations. - -;; There are three main ways to use this package. First, you may -;; replace prin1, princ, and some subroutines that use them by calling -;; install-custom-print so that any use of these functions in -;; Lisp code will be affected; you can later reset with -;; uninstall-custom-print. Second, you may temporarily install -;; these functions with the macro with-custom-print. Third, you -;; could call the custom routines directly, thus only affecting the -;; printing that requires them. - -;; Note that subroutines which call print subroutines directly will -;; not use the custom print functions. In particular, the evaluation -;; functions like eval-region call the print subroutines directly. -;; Therefore, if you evaluate (aref circ-list 0), where circ-list is a -;; circular list rather than an array, aref calls error directly which -;; will jump to the top level instead of printing the circular list. - -;; Uninterned symbols are recognized when print-circle is non-nil, -;; but they are not printed specially here. Use the cl-packages package -;; to print according to print-gensym. - -;; Obviously the right way to implement this custom-print facility is -;; in C or with hooks into the standard printer. Please volunteer -;; since I don't have the time or need. More CL-like printing -;; capabilities could be added in the future. - -;; Implementation design: we want to use the same list and vector -;; processing algorithm for all versions of prin1 and princ, since how -;; the processing is done depends on print-length, print-level, and -;; print-circle. For circle printing, a preprocessing step is -;; required before the final printing. Thanks to Jamie Zawinski -;; for motivation and algorithms. - - -;;; Code: -;;========================================================= - -;; If using cl-packages: - -'(defpackage "cust-print" - (:nicknames "CP" "custom-print") - (:use "el") - (:export - print-level - print-circle - - install-custom-print - uninstall-custom-print - custom-print-installed-p - with-custom-print - - custom-prin1 - custom-princ - custom-prin1-to-string - custom-print - custom-format - custom-message - custom-error - - custom-printers - add-custom-printer - )) - -'(in-package cust-print) - -(require 'backquote) - -;; Emacs 18 doesnt have defalias. -;; Provide def for byte compiler. -(defun defalias (symbol func) (fset symbol func)) -;; Better def when loaded. -(or (fboundp 'defalias) (fset 'defalias 'fset)) - - -;; Variables: -;;========================================================= - -;;(defvar print-length nil -;; "*Controls how many elements of a list, at each level, are printed. -;;This is defined by emacs.") - -(defvar print-level nil - "*Controls how many levels deep a nested data object will print. - -If nil, printing proceeds recursively and may lead to -max-lisp-eval-depth being exceeded or an error may occur: -`Apparently circular structure being printed.' -Also see `print-length' and `print-circle'. - -If non-nil, components at levels equal to or greater than `print-level' -are printed simply as `#'. The object to be printed is at level 0, -and if the object is a list or vector, its top-level components are at -level 1.") - - -(defvar print-circle nil - "*Controls the printing of recursive structures. - -If nil, printing proceeds recursively and may lead to -`max-lisp-eval-depth' being exceeded or an error may occur: -\"Apparently circular structure being printed.\" Also see -`print-length' and `print-level'. - -If non-nil, shared substructures anywhere in the structure are printed -with `#N=' before the first occurrence (in the order of the print -representation) and `#N#' in place of each subsequent occurrence, -where N is a positive decimal integer. - -There is no way to read this representation in standard Emacs, -but if you need to do so, try the cl-read.el package.") - - -(defvar custom-print-vectors nil - "*Non-nil if printing of vectors should obey print-level and print-length. - -For Emacs 18, setting print-level, or adding custom print list or -vector handling will make this happen anyway. Emacs 19 obeys -print-level, but not for vectors.") - - -;; Custom printers -;;========================================================== - -(defconst custom-printers nil - ;; e.g. '((symbolp . pkg::print-symbol)) - "An alist for custom printing of any type. -Pairs are of the form (PREDICATE . PRINTER). If PREDICATE is true -for an object, then PRINTER is called with the object. -PRINTER should print to `standard-output' using CP::original-princ -if the standard printer is sufficient, or CP::prin for complex things. -The PRINTER should return the object being printed. - -Don't modify this variable directly. Use `add-custom-printer' and -`delete-custom-printer'") -;; Should CP::original-princ and CP::prin be exported symbols? -;; Or should the standard printers functions be replaced by -;; CP ones in elisp so that CP internal functions need not be called? - -(defun add-custom-printer (pred printer) - "Add a pair of PREDICATE and PRINTER to `custom-printers'. -Any pair that has the same PREDICATE is first removed." - (setq custom-printers (cons (cons pred printer) - (delq (assq pred custom-printers) - custom-printers))) - ;; Rather than updating here, we could wait until CP::top-level is called. - (CP::update-custom-printers)) - -(defun delete-custom-printer (pred) - "Delete the custom printer associated with PREDICATE." - (setq custom-printers (delq (assq pred custom-printers) - custom-printers)) - (CP::update-custom-printers)) - - -(defun CP::use-custom-printer (object) - ;; Default function returns nil. - nil) - -(defun CP::update-custom-printers () - ;; Modify the definition of CP::use-custom-printer - (defalias 'CP::use-custom-printer - ;; We dont really want to require the byte-compiler. - ;; (byte-compile - (` (lambda (object) - (cond - (,@ (mapcar (function - (lambda (pair) - (` (((, (car pair)) object) - ((, (cdr pair)) object))))) - custom-printers)) - ;; Otherwise return nil. - (t nil) - ))) - ;; ) - )) - - -;; Saving and restoring emacs printing routines. -;;==================================================== - -(defun CP::set-function-cell (symbol-pair) - (defalias (car symbol-pair) - (symbol-function (car (cdr symbol-pair))))) - -(defun CP::original-princ (object &optional stream)) ; dummy def - -;; Save emacs routines. -(if (not (fboundp 'CP::original-prin1)) - (mapcar 'CP::set-function-cell - '((CP::original-prin1 prin1) - (CP::original-princ princ) - (CP::original-print print) - (CP::original-prin1-to-string prin1-to-string) - (CP::original-format format) - (CP::original-message message) - (CP::original-error error)))) - - -(defalias 'install-custom-print-funcs 'install-custom-print) -(defun install-custom-print () - "Replace print functions with general, customizable, Lisp versions. -The emacs subroutines are saved away, and you can reinstall them -by running `uninstall-custom-print'." - (interactive) - (mapcar 'CP::set-function-cell - '((prin1 custom-prin1) - (princ custom-princ) - (print custom-print) - (prin1-to-string custom-prin1-to-string) - (format custom-format) - (message custom-message) - (error custom-error) - )) - t) - -(defalias 'uninstall-custom-print-funcs 'uninstall-custom-print) -(defun uninstall-custom-print () - "Reset print functions to their emacs subroutines." - (interactive) - (mapcar 'CP::set-function-cell - '((prin1 CP::original-prin1) - (princ CP::original-princ) - (print CP::original-print) - (prin1-to-string CP::original-prin1-to-string) - (format CP::original-format) - (message CP::original-message) - (error CP::original-error) - )) - t) - -(defalias 'custom-print-funcs-installed-p 'custom-print-installed-p) -(defun custom-print-installed-p () - "Return t if custom-print is currently installed, nil otherwise." - (eq (symbol-function 'custom-prin1) (symbol-function 'prin1))) - -(put 'with-custom-print-funcs 'edebug-form-spec '(body)) -(put 'with-custom-print 'edebug-form-spec '(body)) - -(defalias 'with-custom-print-funcs 'with-custom-print) -(defmacro with-custom-print (&rest body) - "Temporarily install the custom print package while executing BODY." - (` (unwind-protect - (progn - (install-custom-print) - (,@ body)) - (uninstall-custom-print)))) - - -;; Lisp replacements for prin1 and princ, and for some subrs that use them -;;=============================================================== -;; - so far only the printing and formatting subrs. - -(defun custom-prin1 (object &optional stream) - "Output the printed representation of OBJECT, any Lisp object. -Quoting characters are printed when needed to make output that `read' -can handle, whenever this is possible. -Output stream is STREAM, or value of `standard-output' (which see). - -This is the custom-print replacement for the standard `prin1'. It -uses the appropriate printer depending on the values of `print-level' -and `print-circle' (which see)." - (CP::top-level object stream 'CP::original-prin1)) - - -(defun custom-princ (object &optional stream) - "Output the printed representation of OBJECT, any Lisp object. -No quoting characters are used; no delimiters are printed around -the contents of strings. -Output stream is STREAM, or value of `standard-output' (which see). - -This is the custom-print replacement for the standard `princ'." - (CP::top-level object stream 'CP::original-princ)) - - -(defun custom-prin1-to-string (object) - "Return a string containing the printed representation of OBJECT, -any Lisp object. Quoting characters are used when needed to make output -that `read' can handle, whenever this is possible. - -This is the custom-print replacement for the standard `prin1-to-string'." - (let ((buf (get-buffer-create " *custom-print-temp*"))) - ;; We must erase the buffer before printing in case an error - ;; occured during the last prin1-to-string and we are in debugger. - (save-excursion - (set-buffer buf) - (erase-buffer)) - ;; We must be in the current-buffer when the print occurs. - (custom-prin1 object buf) - (save-excursion - (set-buffer buf) - (buffer-string) - ;; We could erase the buffer again, but why bother? - ))) - - -(defun custom-print (object &optional stream) - "Output the printed representation of OBJECT, with newlines around it. -Quoting characters are printed when needed to make output that `read' -can handle, whenever this is possible. -Output stream is STREAM, or value of `standard-output' (which see). - -This is the custom-print replacement for the standard `print'." - (CP::original-princ "\n" stream) - (custom-prin1 object stream) - (CP::original-princ "\n" stream)) - - -(defun custom-format (fmt &rest args) - "Format a string out of a control-string and arguments. -The first argument is a control string. It, and subsequent arguments -substituted into it, become the value, which is a string. -It may contain %s or %d or %c to substitute successive following arguments. -%s means print an argument as a string, %d means print as number in decimal, -%c means print a number as a single character. -The argument used by %s must be a string or a symbol; -the argument used by %d, %b, %o, %x or %c must be a number. - -This is the custom-print replacement for the standard `format'. It -calls the emacs `format' after first making strings for list, -vector, or symbol args. The format specification for such args should -be `%s' in any case, so a string argument will also work. The string -is generated with `custom-prin1-to-string', which quotes quotable -characters." - (apply 'CP::original-format fmt - (mapcar (function (lambda (arg) - (if (or (listp arg) (vectorp arg) (symbolp arg)) - (custom-prin1-to-string arg) - arg))) - args))) - - -(defun custom-message (fmt &rest args) - "Print a one-line message at the bottom of the screen. -The first argument is a control string. -It may contain %s or %d or %c to print successive following arguments. -%s means print an argument as a string, %d means print as number in decimal, -%c means print a number as a single character. -The argument used by %s must be a string or a symbol; -the argument used by %d or %c must be a number. - -This is the custom-print replacement for the standard `message'. -See `custom-format' for the details." - ;; It doesn't work to princ the result of custom-format as in: - ;; (CP::original-princ (apply 'custom-format fmt args)) - ;; because the echo area requires special handling - ;; to avoid duplicating the output. - ;; CP::original-message does it right. - (apply 'CP::original-message fmt - (mapcar (function (lambda (arg) - (if (or (listp arg) (vectorp arg) (symbolp arg)) - (custom-prin1-to-string arg) - arg))) - args))) - - -(defun custom-error (fmt &rest args) - "Signal an error, making error message by passing all args to `format'. - -This is the custom-print replacement for the standard `error'. -See `custom-format' for the details." - (signal 'error (list (apply 'custom-format fmt args)))) - - - -;; Support for custom prin1 and princ -;;========================================= - -;; Defs to quiet byte-compiler. -(defvar circle-table) -(defvar CP::current-level) - -(defun CP::original-printer (object)) ; One of the standard printers. -(defun CP::low-level-prin (object)) ; Used internally. -(defun CP::prin (object)) ; Call this to print recursively. - -(defun CP::top-level (object stream emacs-printer) - ;; Set up for printing. - (let ((standard-output (or stream standard-output)) - ;; circle-table will be non-nil if anything is circular. - (circle-table (and print-circle - (CP::preprocess-circle-tree object))) - (CP::current-level (or print-level -1))) - - (defalias 'CP::original-printer emacs-printer) - (defalias 'CP::low-level-prin - (cond - ((or custom-printers - circle-table - print-level ; comment out for version 19 - ;; Emacs doesn't use print-level or print-length - ;; for vectors, but custom-print can. - (if custom-print-vectors - (or print-level print-length))) - 'CP::print-object) - (t 'CP::original-printer))) - (defalias 'CP::prin - (if circle-table 'CP::print-circular 'CP::low-level-prin)) - - (CP::prin object) - object)) - - -(defun CP::print-object (object) - ;; Test object type and print accordingly. - ;; Could be called as either CP::low-level-prin or CP::prin. - (cond - ((null object) (CP::original-printer object)) - ((CP::use-custom-printer object) object) - ((consp object) (CP::list object)) - ((vectorp object) (CP::vector object)) - ;; All other types, just print. - (t (CP::original-printer object)))) - - -(defun CP::print-circular (object) - ;; Printer for `prin1' and `princ' that handles circular structures. - ;; If OBJECT appears multiply, and has not yet been printed, - ;; prefix with label; if it has been printed, use `#N#' instead. - ;; Otherwise, print normally. - (let ((tag (assq object circle-table))) - (if tag - (let ((id (cdr tag))) - (if (> id 0) - (progn - ;; Already printed, so just print id. - (CP::original-princ "#") - (CP::original-princ id) - (CP::original-princ "#")) - ;; Not printed yet, so label with id and print object. - (setcdr tag (- id)) ; mark it as printed - (CP::original-princ "#") - (CP::original-princ (- id)) - (CP::original-princ "=") - (CP::low-level-prin object) - )) - ;; Not repeated in structure. - (CP::low-level-prin object)))) - - -;;================================================ -;; List and vector processing for print functions. - -(defun CP::list (list) - ;; Print a list using print-length, print-level, and print-circle. - (if (= CP::current-level 0) - (CP::original-princ "#") - (let ((CP::current-level (1- CP::current-level))) - (CP::original-princ "(") - (let ((length (or print-length 0))) - - ;; Print the first element always (even if length = 0). - (CP::prin (car list)) - (setq list (cdr list)) - (if list (CP::original-princ " ")) - (setq length (1- length)) - - ;; Print the rest of the elements. - (while (and list (/= 0 length)) - (if (and (listp list) - (not (assq list circle-table))) - (progn - (CP::prin (car list)) - (setq list (cdr list))) - - ;; cdr is not a list, or it is in circle-table. - (CP::original-princ ". ") - (CP::prin list) - (setq list nil)) - - (setq length (1- length)) - (if list (CP::original-princ " "))) - - (if (and list (= length 0)) (CP::original-princ "...")) - (CP::original-princ ")")))) - list) - - -(defun CP::vector (vector) - ;; Print a vector according to print-length, print-level, and print-circle. - (if (= CP::current-level 0) - (CP::original-princ "#") - (let ((CP::current-level (1- CP::current-level)) - (i 0) - (len (length vector))) - (CP::original-princ "[") - - (if print-length - (setq len (min print-length len))) - ;; Print the elements - (while (< i len) - (CP::prin (aref vector i)) - (setq i (1+ i)) - (if (< i (length vector)) (CP::original-princ " "))) - - (if (< i (length vector)) (CP::original-princ "...")) - (CP::original-princ "]") - )) - vector) - - - -;; Circular structure preprocessing -;;================================== - -(defun CP::preprocess-circle-tree (object) - ;; Fill up the table. - (let (;; Table of tags for each object in an object to be printed. - ;; A tag is of the form: - ;; ( <object> <nil-t-or-id-number> ) - ;; The id-number is generated after the entire table has been computed. - ;; During walk through, the real circle-table lives in the cdr so we - ;; can use setcdr to add new elements instead of having to setq the - ;; variable sometimes (poor man's locf). - (circle-table (list nil))) - (CP::walk-circle-tree object) - - ;; Reverse table so it is in the order that the objects will be printed. - ;; This pass could be avoided if we always added to the end of the - ;; table with setcdr in walk-circle-tree. - (setcdr circle-table (nreverse (cdr circle-table))) - - ;; Walk through the table, assigning id-numbers to those - ;; objects which will be printed using #N= syntax. Delete those - ;; objects which will be printed only once (to speed up assq later). - (let ((rest circle-table) - (id -1)) - (while (cdr rest) - (let ((tag (car (cdr rest)))) - (cond ((cdr tag) - (setcdr tag id) - (setq id (1- id)) - (setq rest (cdr rest))) - ;; Else delete this object. - (t (setcdr rest (cdr (cdr rest)))))) - )) - ;; Drop the car. - (cdr circle-table) - )) - - - -(defun CP::walk-circle-tree (object) - (let (read-equivalent-p tag) - (while object - (setq read-equivalent-p - (or (numberp object) - (and (symbolp object) - ;; Check if it is uninterned. - (eq object (intern-soft (symbol-name object))))) - tag (and (not read-equivalent-p) - (assq object (cdr circle-table)))) - (cond (tag - ;; Seen this object already, so note that. - (setcdr tag t)) - - ((not read-equivalent-p) - ;; Add a tag for this object. - (setcdr circle-table - (cons (list object) - (cdr circle-table))))) - (setq object - (cond - (tag ;; No need to descend since we have already. - nil) - - ((consp object) - ;; Walk the car of the list recursively. - (CP::walk-circle-tree (car object)) - ;; But walk the cdr with the above while loop - ;; to avoid problems with max-lisp-eval-depth. - ;; And it should be faster than recursion. - (cdr object)) - - ((vectorp object) - ;; Walk the vector. - (let ((i (length object)) - (j 0)) - (while (< j i) - (CP::walk-circle-tree (aref object j)) - (setq j (1+ j)))))))))) - - -;; Example. -;;======================================= - -'(progn - (progn - ;; Create some circular structures. - (setq circ-sym (let ((x (make-symbol "FOO"))) (list x x))) - (setq circ-list (list 'a 'b (vector 1 2 3 4) 'd 'e 'f)) - (setcar (nthcdr 3 circ-list) circ-list) - (aset (nth 2 circ-list) 2 circ-list) - (setq dotted-circ-list (list 'a 'b 'c)) - (setcdr (cdr (cdr dotted-circ-list)) dotted-circ-list) - (setq circ-vector (vector 1 2 3 4 (list 'a 'b 'c 'd) 6 7)) - (aset circ-vector 5 (make-symbol "-gensym-")) - (setcar (cdr (aref circ-vector 4)) (aref circ-vector 5)) - nil) - - (install-custom-print) - ;; (setq print-circle t) - - (let ((print-circle t)) - (or (equal (prin1-to-string circ-list) "#1=(a b [1 2 #1# 4] #1# e f)") - (error "circular object with array printing"))) - - (let ((print-circle t)) - (or (equal (prin1-to-string dotted-circ-list) "#1=(a b c . #1#)") - (error "circular object with array printing"))) - - (let* ((print-circle t) - (x (list 'p 'q)) - (y (list (list 'a 'b) x 'foo x))) - (setcdr (cdr (cdr (cdr y))) (cdr y)) - (or (equal (prin1-to-string y) "((a b) . #1=(#2=(p q) foo #2# . #1#))" - ) - (error "circular list example from CL manual"))) - - (let ((print-circle nil)) - ;; cl-packages.el is required to print uninterned symbols like #:FOO. - ;; (require 'cl-packages) - (or (equal (prin1-to-string circ-sym) "(#:FOO #:FOO)") - (error "uninterned symbols in list"))) - (let ((print-circle t)) - (or (equal (prin1-to-string circ-sym) "(#1=FOO #1#)") - (error "circular uninterned symbols in list"))) - - (uninstall-custom-print) - ) - -(provide 'cust-print) - -;;; cust-print.el ends here
--- a/lisp/edebug/custom-load.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,9 +0,0 @@ -;;; custom-load.el --- automatically extracted custom dependencies - - -;;; Code: - -(custom-add-loads 'lisp '("edebug")) -(custom-add-loads 'edebug '("edebug")) - -;;; custom-load.el ends here
--- a/lisp/edebug/edebug-cl-read.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,118 +0,0 @@ -;;; edebug-cl-read.el --- Edebug reader macros for use with cl-read. - -;; Copyright (C) 1993 Daniel LaLiberte -;; Author: Daniel LaLiberte <liberte@cs.uiuc.edu> -;; Keywords: lisp, tools, maint - -;; 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: - -;; LCD Archive Entry: -;; edebug-cl-read.el|Daniel LaLiberte|liberte@cs.uiuc.edu -;; |Edebug reader macros for cl-read.el -;; |$Date: 1996/12/18 22:51:45 $|$Revision: 1.1.1.2 $|~/modes/edebug-cl-read.el| - -;; If you use cl-read.el and want to use edebug with any code -;; in a file written with CL read syntax, then you need to use this -;; package. - -;; To Do: -;; Handle shared structures, but this is not normally used in executable code. - -;; Read-time evaluation shouldn't be used in a form argument since -;; there is no way to instrument the result of the evaluation, and -;; no way to tell Edebug not to try. - -;; Need to mangle all local variable names that might be visible to -;; eval, e.g. stream, char. Alternatively, packages could hide them. - -;;; Code: - -(require 'cl) -;; For byte compiling cl-read is needed. -;; But edebug-cl-read should not even be loaded unless cl-read already is. -(require 'cl-read) - -(provide 'edebug-cl-read) -;; Do the above provide before the following require to avoid load loop. -(require 'edebug) - -(defvar reader::stack) - -;; The following modifications of reader functions -;; could be done via advice. But we need to switch between -;; edebug versions and originals frequently. Also advice.el -;; doesn't support advising anonymous functions. - -(defun edebug-reader::read-sexp-func (point func) - ;; dummy def - ) - -(defvar edebug-read-dotted-list) - -(defun edebug-read-sexp-func (point func) - "Edebug offset storing is happening." - (edebug-storing-offsets point - (let (edebug-read-dotted-list) - (edebug-reader::read-sexp-func point func)))) - -(defun edebug-end-list-handler (stream char) - ;; If the dotted form is a list, signal to offset routines. - (setq edebug-read-dotted-list (listp (car reader::stack))) - (edebug-reader::end-list-handler stream char)) - - -;;========================================================================= -;; Redefine the edebug reader to check whether CL syntax is active. -;; This might be a little cleaner using advice. - -(defvar edebug-reading-with-cl-read nil) - -(or (fboundp 'edebug-original-read-storing-offsets) - (defalias 'edebug-original-read-storing-offsets - (symbol-function 'edebug-read-storing-offsets))) - -(defun edebug-read-storing-offsets (stream) - ;; Read a sexp from STREAM. - ;; STREAM is limited to the current buffer. - ;; Create a parallel offset structure as described in doc for edebug-offsets. - ;; This version, from edebug-cl-read, uses cl-read. - (if (not cl-read-active) - ;; Use the reader for standard Emacs Lisp. - (edebug-original-read-storing-offsets stream) - - ;; Use cl-read with edebug hooks. - (if edebug-reading-with-cl-read nil - ;; Only do this if it's not already been done, else it loops. - (fset 'edebug-reader::read-sexp-func - (symbol-function 'reader::read-sexp-func)) - (fset 'reader::read-sexp-func 'edebug-read-sexp-func) - (fset 'edebug-reader::end-list-handler (get-macro-character ?\))) - (set-macro-character ?\) 'edebug-end-list-handler))) - (unwind-protect - (let ((edebug-reading-with-cl-read t)) - (reader::read stream)) - (if edebug-reading-with-cl-read nil - (set-macro-character - ?\) (symbol-function 'edebug-reader::end-list-handler)) - (fset 'reader::read-sexp-func - (symbol-function 'edebug-reader::read-sexp-func))))) -
--- a/lisp/edebug/edebug-history Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,333 +0,0 @@ -@c =================================================================== -@node Revision History, Index, Todo List, Top -@section Revision History - -Here is a summary of changes to edebug recorded in the RCS log, in -reverse chronological order. - -Revision 2.9 1993/02/04 22:40:58 liberte -Fix handling of 0 and t edebug-form-specs. - -Remove loop for consecutive special specs to simplify code. - -Fix [&optional specs] again. - -Bug: [&rest specs] still broken. - -Bug: nested definitions may have problems still - let me know. - -New variable edebug-debugger holds name of debugger for errors or quit. - -Unrestore edebug-buffer's window-point after edebug display. -Needed in addition to setting the buffer point -because otherwise quitting doesnt leave point as is. -But doing it causes point not to be restored other times. -Let me know if there are problems. - -Fix zmacs-regions typo for lemacs. - -Revision 2.8 1993/01/13 18:34:19 liberte -Support edebugging top-level forms and generalize handling -of defining forms. - -Rename edebug-defun to edebug-eval-top-level-form. -edebug-defun still points to the latter. - -Rename edebug-all-defuns to edebug-all-defs. - -Add edebug-all-forms option and command. - -Add edebug-continue-kbd-macro option. - -Stop defining epoch::version. - -Rename def-edebug-form-spec to def-edebug-spec. Arguments are unevaluated. - -edebug-form-spec supports indirection. List specs may now -contain body, &define, name, arglist, def-body, def-form, and strings. - -While parsing, commit to alternative after matching a symbol. - -Fix nested &optional handling. - -Improve syntax error reporting. - -Use edebug-form-specs for many Emacs special-forms: defun, defmacro, -interactive, condition-case, cond, as well as lambda forms and -functions that take function arguments. Define specs for all cl.el -macros. - -Fix printing of window objects so they show the correct buffer. - -Numerous display fixes that are too complex to explain. - -Display frequency counts along with coverage data by inserting comment -lines. - -Add global break condition. - -Add "next" mode to stop only after expression evaluation. -Add top-level-nonstop to stop no more. - -Add time argument to edebug-bounce-point. - -Allow editing of previous breakpoint condition. - -Fix edebug-step-in. - -Clean up the backtrace display better. - -Support Lucid Emacs command events. - - -Revision 2.7 92/03/23 - -Fix edebug-get-displayed-buffer-points to actually change buffers. - -Restore current buffer in edebug-set-buffer-points - -Use epoch::version instead of edebug-epoch-running. - -Apparently we need to set-buffer in edebug-pop-to-buffer, -even after select-window. - -Define dynamically bound variables to quite byte-compiler, -but leave them unbound to cause runtime error if used improperly. - -Fix other problems with window-start, current-buffer, and -edebug-outside-excursion. - -Revision 2.6 92/03/19 -Disable edebug-save-point. Now point of source code buffers is always -saved, mark is never saved, and window-start is always saved. - -Change name of edebug-save-buffer-points to -edebug-save-displayed-buffer-points. Also, if non-nil, only displayed -buffer points are saved. - -Restructure definition of epoch specific functions so there is no -overhead for non-epoch use. - -Add support for custom-print functions to handle print-level and -print-circle. Use edebug-prin* functions instead of standard -print functions. - -Yet another change of the instrumenting scheme: -edebug-enter gets a lambda form which can be byte-compiled; -edebug-after gets the after expression index from edebug-before which -is given the before expression index. (Perhaps it is false economy to -avoid the after expression index.) edebug-after also gets the -evaluated expression result, so no explicit evals need be done. - -Most of edebug-defun was moved to edebug-func-form which also -handles embedded defuns. - -Add functions edebug-forms and edebug-sexps. - -Rename edebug-list to edebug-list-form. - -Use edebug-form-specs for all special forms. The spec may now be -a function which is called to process args. Added -form to -the names of special form parser functions. - -Rename edebug-form-parser to edebug-interpret-form-spec. Add handling -of [...], function spec, and backtracking. &optional now only applies -to one following spec. Fixed some other bugs. - -Added macro def-edebug-form-spec for convenience, and to convert -0 and t values to edebug-forms and edebug-sexps. - -Add edebug-form-specs for mapcar, mapconcat, mapatoms, apply, and funcall -that all use the new function spec. - -Rebuilt edebug-read-sexp to be simpler, faster, and more complete. - -Accummulate frequencies of expression evaluation, displayable -with edebug-display-freq-count. - -No longer do save-restriction since edebug's eval-region doesnt narrow. - -Numerous other display changes related to source code buffer's -point and window-start. - -Add -mode to the names of mode changing functions. - -Set debugger to edebug-debug while inside edebug - it's almost -always useful inside, and not useful outside of edebug. - -Add edebug-trace function to output FMT with ARGS to *edebug-trace* buffer. - -Other changes I've forgotten. - -Revision 2.5 91/07/25 - -Doc string cleanup. - -If edebug-form-spec is t, evaluate all arguments. - -If edebug-form-spec is 0, evaluate no arguments. - -If edebug-form-spec is nil, evaluate macro args according - to edebug-eval-macro-args. - -Save the outside value of executing macro. - -Save and restore the outside restriction. - -Dont force update for go and Go-nonstop. - -Save and restore last-command-char, last-command, - this-command, last-input-char. - -For epoch, do epoch::dispatch-events before sit-for - and input-pending-p since X events could interfere. - -Warn about unsetting non-existent breakpoint. - -Fix edebug-forward-sexp with prefix arg. - -Add edebug-step-out to exit from current sexp. - -Revision 2.4 91/03/18 -Force update after go or Go-nonstop modes, so overlay arrow is correct. - -Support debug-on-quit. Remove edebug-on-error. - -Fix edebug-anonymous. Bug found by jackr@wpd.sgi.com (Jack Repenning). - -Don't discard-input anymore. Easier to change modes this way. - -Fix max-lisp-eval-depth and max-specpdl-size incrementing. - -Save and restore points in all buffers, if - edebug-save-buffer-points is non-nil. Expensive! - Bug caught by wolfgang@wsrcc.com (Wolfgang S. Rupprecht) - -Save standard-output and standard-input in edebug-recursive-edit - so that edebug-outside-excursion can restore them. - -Call set-buffer in edebug-pop-to-buffer since - select-window does not do that. - -Fix edebug's eval-defun to remember current buffer inside evaluations - and to evaluate top-level forms. Found by Jamie Zawinski. - -Add edebug-interactive-entry to support interactive forms with - non-string arg. Bug found by Jack Repenning. - -Simplify edebug-restore-match-data to just store-match-data. - Motivated by linus@lysator.liu.se. - -Move the match-data call to before the outside - buffer is changed, since it assumes that. - -Revision 2.3 91/01/17 - -Fix bug found by hollen@megatek.uucp. - Current buffer was not being restored. - -Call edebug with (edebug begin end 'exp) - and add additional wrapper around body of functions: - (edebug-enter function body). - -Make &optional only apply to immediate next arg - in edebug-interpret-form-spec (was edebug-macro-parser). - -Catch debug errors with edebug. Yeah! - -Reset edebug-mode on first function entry. Yeah! - Motivated by Dion Hollenbeck. - -Add the missing bindings to the global-edebug-map. - -eval-current-buffer now uses eval-region. - -eval-region now does not narrow region. - Narrowing was the cause of the window-start being set wrong. - -Reset edebug-mode only on - first entry of any function at each recursive-edit level. - -Add edebug-backtrace, to generate cleaned up - backtrace. It doesnt "work" like the debug backtrace, however. - -Require reselecting outside window even if - quit occurs, otherwise save-excursions may restore - buffer to the wrong window. - -Revision 2.2 90/11/26 - -Shadow eval-defun and eval-region. Toggle - edebugging with edebug-all-defuns. - -Call edebug with (edebug 'function begin end 'exp) - Suggested by Jamie Zawinski <jwz@lucid.com>. - -Add edebug-interpret-form-spec to process macro args. - Motivated by Darryl Okahata darrylo@hpnmxx.hp.com. - -Fix by Roland McGrath <roland@ai.mit.edu> - to wrap body of edebug-save-restriction in progn. - -Fix by Darryl Okahata <darrylo%hpnmd@hpcea.hp.com> - to add (set-window-hscroll (selected-window) 0) to - edebug-pop-to-buffer. - -Revision 2.1 90/11/16 - -Clean up. - -Add edebug-form-spec to edebug macro calls. Thanks to Joe Wells. - -edebug-forward-sexp uses step mode if no forward-sexp. - -Revision 2.0 90/11/14 22:30:54 liberte - -Handle lambda forms, function, interactive evals, defmacro. - -Clean up display for Epoch - save and restore screen configurations. - Note: epoch 3.2 broke set-window-configuration. - Also, sit-for pauses do not always work in epoch. - -Display evaluations window. - -Display result after expression evaluation. - Thanks to discussions with Shinichirou Sugou. - -Conditional and temporary breakpoints. - -Change "continue" to "go" mode and add different "continue" mode. - -Option to stop before symbols. - -Fix by: Glen Ditchfield gjditchfield@violet.uwaterloo.ca -to handle ?# type chars. - - -Revision 1.5 89/05/10 -Fix condition-case expression lists. - -Reorganize edebug. - -Revision 1.4 89/02/14 -Fix broken breakpointing. - -Temporarily widen elisp buffer during edebug. - -Revision 1.3 89/01/30 -More bug fixes for cond and let. - -Another parsing fix backquote. - -Fix for lambda forms inside defuns. - -Leave point at syntax error, mark at starting position. - -Revision 1.2 88/11/28 -Bug fixes: cond construct didnt execute. - () in sexp list didnt parse - () as variable in condition-case didnt parse. - -Revision 1.1 88/11/28 -Initial revision -
--- a/lisp/edebug/edebug-test.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1189 +0,0 @@ -;; Some tests for edebug. - -;;======================= -;; Reading tests. - -(testing (one two) three) - -(progn '(testing)) - -(a . (b . c)) - -(a . "test") - -(a . (b . nil)) - -(a . [one two three]) - -;;=========================== -;; Backquote test - -(defun test () - (macroexpand '(` ((, (a)) . (, test)))) -) -(test) - -(progn (` ((, (point)) . (, (point))))) -(` (, (point))) - -(defun test () -(message "%d" 999999) - -(defun test1 () - - (progn - (defun test () - (message "%d" 99999)) - (test) - ) - - ) -(test1) -(test) - -(eval (edebug-` (append [(, (point)) (, (point))] nil))) -(eval (edebug-` (append (, (point)) (, (point)) nil))) - -(eval (progn (edebug-` (edebug-` (, '(, (point))))))) - -(eval (edebug-` (let (((, 'a) 'b)) - (message "%s" a)))) - -(defun test () - -(let ((r '(union x y))) - (` (` (foo (, '(, r)))))) -) - -(defun test () - (let ((a '(one two))) a)) - -(def-edebug-spec test-func (sexp &rest def-form)) - -(setq edebug-unwrap-results t) -(setq edebug-unwrap-results nil) - -(defmacro test-func (func &rest args) - (edebug-` ((, func) (,@ args)))) - -(test-func message (concat "hi%s" "there") (+ 1 2)) - -(defmacro test-progn (&rest body) - (edebug-` (progn (,@ body)))) - -(def-edebug-spec test-progn (&rest def-form)) - -(test-progn - (message "testing")) - - -;;================= -;; Testing read syntax. - -(format "testing %s %s %s" 1 2 (+ 1 2)) - -(defun test-syntax () - (setq mode-line-stuff'("draft(%b) ^C^S(end) ^C^Q(uit) ^C^K(ill)")) -;; (re-search-forward "[.?!][])""']*$" nil t) -;; (let (test) - ) -) - -(test-syntax) - -(let ()) -;;==================== -;; Testing function - -(defun foo (x) - (mapconcat (function identity) x ", ")) - -(defun foo (x) - (mapconcat 'identity x ", ")) - -(defun foo (x) - (mapconcat (function (lambda (x) x)) x ", ")) - -(require 'cl) - -(defun foo (x) - (mapconcat (function* (lambda (x &optional (y (1+ x)) &key xyz) x)) x ", ")) - -(defun foo (x) - (mapconcat '(lambda (x) x) x ", ")) - -(foo '(1 2 3)) - -(apply 'identity one two) - -(defun test1 (arg) - arg) - -(def-edebug-spec test1 - (form)) -(setq x 5) -(test1 (+ x 2)) - - (("test1" test1))) - -(def-edebug-spec test1 - (&define sexp form)) - -(test (test1 xyz (message "jfdjfd"))) - -;;==================== -;; Anonymous function test -(defun hej (arg) - "docstring" - (interactive (list 2)) - ((lambda (luttr &rest params) - (apply luttr luttr params)) - (function (lambda (self n) - (edebug-trace "n: %s" n) - (if (= n 5) (edebug nil "n is 5")) - (edebug-tracing "cond" - (cond - ((= 0 n) 1) - (t (* n (funcall self self (1- n)))))))) - 11)) - -(defun hej-test () - (interactive) - (message - "testing") - (hej edebug-execution-mode) - ) -(hej-test) - -(defun lambda-test () - ((lambda (arg) arg) 'xyz)) -(lambda-test) - -(defun test () - "doc string - (with left paren on start of line)" - - 1) - - -(progn - (save-window-excursion - (split-window) - (split-window) - (setq w (next-window))) - (edebug-window-live-p w)) - - -;;==================== -;; Test edebugging top-level-forms - -(def-edebug-spec test nil) -(let ((arg (list 'a 'b 'c))) - (defun test (arg) - arg) - (test arg)) - - -(fset 'emacs-setq (symbol-function 'setq)) - -(defmacro my-setq (&rest args) - (while args - (set (car args) (eval (car (cdr args)))) - (setq args (cdr (cdr args))))) - -(defmacro test-macro (&rest args) - (cons 'list args)) -(def-edebug-spec test-macro 0) - -(defun test () - (test-macro (message "testing"))) -(test) - -(defun test () - (message "someting") - (function (lambda () - (message "something else"))) - ) - -(funcall (test)) - -;;==================== -;; Test for and inc -(def-edebug-spec for - (symbolp ["from" def-form ["to" def-form] ["do" &rest def-form]])) - - ;; (symbolp ['from form ['to form] ['do &rest form]]) - -(inc x) -(defmacro inc (var) - (list 'setq var (list '1+ var))) - -(defmacro for (var from init to final do &rest body) - (let ((tempvar (make-symbol "max"))) - (edebug-` (let (((, var) (, init)) - ((, tempvar) (, final))) - (while (<= (, var) (, tempvar)) - (,@ body) - (inc (, var))))))) - -(defun test-for (one two) - (for i from one to two do - (message "%s" i)) - ) - -(let ((n 5)) - (for i from n to (* n (+ n 1)) do - (message "%s" i))) - -(test-for 3 10) - -;;==================== -;; Test condition-case -(def-edebug-spec condition-case - (symbolp - form - &rest (symbolp &optional form))) - -(setq edebug-on-signal '(error)) - -(defun test-condition-case () - (condition-case err - (signal 'error '(oh)) - (error (message "error: %s" err)) - )) -(test-condition-case) - -(require 'cl) - -;;============= -;; lexical let - -(defun test-lexical () - (funcall (lexical-let ((xyz 123)) - (function (lambda (arg) (+ arg xyz)))) - 456)) -(test-lexical) - -;;==================== -;; case test. -(defun test-case (one) - (case one - ((one) (message "(one)")) - ("one" (message "one")) - ('one (message "'one")) - )) - -(test-case 'one) - -;;==================== -;; Test of do from cl.el - -(defun list-reverse (list) - (do ((x list (cdr x)) - (y nil (cons (car x) y))) - ((endp x) y) - (message "x: %s y: %s" x y) - )) - - -(list-reverse '(testing one two three)) - -(defmacro test-backquote (arg list) - (edebug-` - (progn - (message "%s %s" (, arg) (, list)) - (mapcar (function (lambda (arg1) - (message "%s %s" arg1 (, arg)))) (, list))))) - -(def-edebug-spec test-backquote (def-form def-form)) -(test-backquote (symbol-name 'something) (list 1 2 3)) - - -(defmacro dired-map-over-marks (body arg &optional show-progress) - (edebug-` (prog1 - (let (buffer-read-only case-fold-search found results) - (if (, arg) - (if (integerp (, arg)) - (progn;; no save-excursion, want to move point. - (dired-repeat-over-lines - (, arg) - (function (lambda () - (if (, show-progress) (sit-for 0)) - (setq results (cons (, body) results))))) - (if (< (, arg) 0) - (nreverse results) - results)) - ;; non-nil, non-integer ARG means use current file: - (list (, body))) - (let ((regexp (dired-marker-regexp)) next-position) - (save-excursion - (goto-char (point-min)) - ;; remember position of next marked file before BODY - ;; can insert lines before the just found file, - ;; confusing us by finding the same marked file again - ;; and again and... - (setq next-position (and (re-search-forward regexp nil t) - (point-marker)) - found (not (null next-position))) - (while next-position - (goto-char next-position) - (if (, show-progress) (sit-for 0)) - (setq results (cons (, body) results)) - ;; move after last match - (goto-char next-position) - (forward-line 1) - (set-marker next-position nil) - (setq next-position (and (re-search-forward regexp nil t) - (point-marker))))) - (if found - results - (list (, body)))))) - ;; save-excursion loses, again - (dired-move-to-filename)))) - - -(def-edebug-spec dired-map-over-marks (&rest def-form)) - -(dired-map-over-marks - (message "here") (+ 1 2) t) - -;;==================== -;; circular structure test - -(edebug-install-custom-print) -(edebug-uninstall-custom-print) - -(setq a '(1 2)) -(progn - (edebug-install-custom-print) - (setq a '(1 2)) - (setcar a a)) - -(defun test () - (with-custom-print - (format "%s" (setcar a a))))) -(test) -(setcdr a a) -(let ((b a)) b) - -(with-custom-print - (let ((print-circle t) - (circ-list (list 'a 'b (vector 1 2 3 4) 'd 'e 'f))) - (setcar (nthcdr 3 circ-list) circ-list) - (aset (nth 2 circ-list) 2 circ-list) - (prin1-to-string circ-list))) - -;;==================== -;; interactive-p test -(defun test-interactive () - (interactive) - (interactive-p)) - -(test-interactive) -(call-interactively 'test-interactive) - - -;;==================== -;; test several things: -;; - nested defun. -;; - display scrolling. - - -(defmacro testmacro () - '(interactive-p)) - -(call-interactively 'testing1) -(testing1 9) - -(defun testing1 (arg) - (interactive (list 3)) - (message "%s" (interactive-p)) (sit-for 2) - (edebug-trace "interactive: %s" (testmacro)) - (defun testing1-1 () - (testing1 2)) -;; (custom-message "%s" arg "extra") - (current-buffer) - (selected-window) - (while (< 0 (setq arg (1- arg))) - arg - arg - arg - arg - arg - arg - arg - arg - arg ; middle - arg - arg - arg - arg - arg - arg - arg - arg - arg - arg ; jump - arg - arg - arg - arg - arg - arg - arg - arg - arg - arg - arg - arg - arg -)) -(edebug-trace-display "*testing*" "one") -(edebug-tracer "one\n") - -(testing1 a) -(call-interactively 'testing1) -(testing1 2) - -(testing1-1) - - -(defmacro testmacro () - (interactive) - '(one)) - -(defun testing2 () - (let* ((buf (get-buffer-create "testing")) - (win (get-buffer-window buf))) - (testing1 1) - (window-point win) - (window-point win) - -;; (read-stream-char buf) - )) - -(testing2) - - -(defun testing3 () - (save-excursion - (set-buffer (get-buffer-create "*testing*")) - (current-buffer) - (point) - (forward-char 1) - )) -(testing3) - - -;;==================== -;; anonymous function test -(defun testanon (arg) - (mapcar '(lambda (x) x) arg) - (mapcar (function (lambda (x) x)) arg) - (mapcar (function testing3 ) arg) - ) - -(testanon '(1 2 3)) - -;;==================== -;; upward funarg test - -(defmacro lambda (&rest args) - "Return the quoted lambda expression." - (cons 'function (list (cons 'lambda args)))) - -(lambda (testing) one two) - -(defun testanon2 () - "return an anoymous function." - (function (lambda (x) x)) - ) -;; Emacs 19 has a lambda macro -(defun testanon2 () - "return an anoymous function." - (lambda (x) x)) -(testanon2) - -(setq func - (testanon2)) -(funcall func 2) - -(defun foo () - (mapcar #'(lambda (x) - (message "%S" x)) - (append '(0) '(a b c d e f)))) -(foo) - -;;==================== -;; downward funarg test - -(defun xxx (func) - (funcall func)) - -(defun yyy () - (xxx (function (lambda () (message "hello"))))) - -(yyy) - -;; eval this: -(def-edebug-spec test nil) -(defun test (func list) - (dolist (el list) - (funcall func el))) - -;; edebug this: -(defun testcall (l) - (test (function (lambda (x) (print x))) ;; set breakpoints in anon. - l)) - -;; test call: -(testcall '(a b c)) - -;; flet test. - -(defun alep-write-history (&rest args) - (message "alep-write-history( %s )\n" - args) - ;; write out header - '(write-region (format ";;Saved on %s\n" (current-time-string)) - nil buffer-file-name nil 'shut-up) - ;; dump all not deleted actions - (flet ((write-solution (sol) - t) - (write-action (action) - (if (a-h-action-deleted action) - ;; nothing to be done - t - (write-region - (format "(alep-new-history-action %S %S %S)\n" - (a-h-action-name action) - (alep-tnowv-string (a-h-action-in-tnowv - action)) - (a-h-action-timestamp action)) - nil buffer-file-name t 'shut-up) - (mapc 'write-solution - (a-h-action-solutions action))))) - (mapc 'write-action - history-list)) - t) -(setq history-list '(1 2 3)) -(alep-write-history) - -;;========================= - - (edebug-trace "my stuff") - -(defun fac (n) - (if (= n 0) (edebug)) -;#6 1 0 =5 - (if (< 0 n) -;#5 = - (* n (fac (1- n))) -;# 5 0 - 1)) -;# 0 - -(fac 5) - - -;;==================== -;; Timing test - how bad is edebug? - -(defun looptest (n) - (let ((i 0)) - (while (< i n) (setq i (1+ i))))) - -(looptest 10000) - -;;==================== -;; eval-depth testing. - -(defun test-depth (i) - (test-depth (1+ i))) - -;; Without edebug i reaches 193, failing on eval depth -;; With edebug, i reaches about 57. Better safe than sorry. -(setq max-lisp-eval-depth 200) -(test-depth 0) - -;;==================== -;; specpdl-size testing. -(defun test-depth2 (i max) - (let ((test max-specpdl-size) - (max-lisp-eval-depth (+ 2 max-lisp-eval-depth)) - ) - (test-depth2 (1+ i) max-specpdl-size))) - -(let ((max-lisp-eval-depth 300) - (max-specpdl-size 3)) - (test-depth2 0 max-specpdl-size)) - -;;==================== -;; Buffer testing. - -(defun zprint-region-1 (start end switches) - (let ((name (concat (buffer-name) "")) - (width tab-width)) - (save-excursion - (message "Spooling...") - (let ((oldbuf (current-buffer))) - (set-buffer (get-buffer-create " *spool temp*")) - (widen) - (erase-buffer) - (insert-buffer-substring oldbuf start end) - (setq tab-width width) - (if (/= tab-width 8) - (untabify (point-min) (point-max))) - (setq start (point-min) end (point-max))) - (apply 'call-process-region - (nconc (list start end zpr-command nil nil nil - "-h" name switches))) - (message "Spooling...done") - ) - ) - ) - - - -(defun quick-hanoi (nrings) - (with-output-to-temp-buffer "*hanio*" - (set-buffer "*hanio*") - (princ (format "Solution to %s ring hanoi problem\n\n" nrings)) - (hanoi0 nrings 'pole-1 'pole-2 'pole-3))) - -(defun hanoi0 (n from to work) -;; (edebug-set-window-configuration (edebug-current-window-configuration)) - (if (> n 0) - (progn -;; (save-excursion -;; (set-buffer "*hanio*") -;; (message "Point=%s window-point=%s" (point) -;; (window-point (get-buffer-window "*hanio*"))) -;; (set-window-point (get-buffer-window "*hanio*") (point)) -;; ) - - (hanoi0 (1- n) from work to) - (princ (format "ring %s from %s to %s\n" n from to)) - (hanoi0 (1- n) work to from)))) - -(quick-hanoi 5) - - -;;==================== -;; Error test - -(defun error-generating-function () - (message "try again?") (sit-for 1) - (prog1 - (signal 'bogus '("some error" xyz abc)) - (error "debug-on-error: %s edebug-entered: %s edebug-recursion-depth: %s" - debug-on-error edebug-entered edebug-recursion-depth))) - -;; --><-- point will be left between the two arrows -(setq debug-on-error nil) -(setq edebug-on-signal '(bogus)) - -(testing-function) -(defun testing-function () - (interactive) - (message "YYY") - (error-generating-function) - (message "ZZZ")) - - -(let ((debug-on-error t)) - xyzzyz) - -;;==================== -;; Quitting with unwind-protect - -(defun unwind-test () - (prog1 - (unwind-protect - (unwind-protect - (message "testing") - (message "unwinding1")) - (message "unwinding2") - (sit-for 1) - ) - )) -(unwind-test) - -(defmacro save-buffer-points (&rest body) - (` (let ((buffer-points - (mapcar (function (lambda (buf) - (set-buffer buf) - (cons buf (point)))) - (buffer-list)))) - (unwind-protect - (progn - (,@ body)) - (mapcar (function (lambda (buf-point) - (if (buffer-name (car buf-point)) - (progn - (set-buffer (car buf-point)) - (goto-char (cdr buf-point)))))) - buffer-points))))) - -(defun testing4 () - (with-output-to-temp-buffer "*testing*" - (princ "Line 1\n") - (save-buffer-points - (recursive-edit) - ) - (princ "Line 2\n") - )) - -(testing4) -test! - - -;;==================== -;; edebug-form-specs for Guido Bosch's flavors - -(def-edebug-spec defmethod defun) ; same as defun -(def-edebug-spec defwhopper defun) ; same as defun - -;;====================== -;; Check syntax errors. - -(defun test-too-many-arguments () - (mapcar 'test one two)) - -(mapcar 'not-enough) - -(defun test-not-enough-arguments () - (mapcar 'test)) - -(defun test-bad-function () - (function)) - -(defun test-bad-function () - (function - (bad () ))) - -(defun test-bad-lambda-arguments () - (function (lambda "bad" ))) - -(defun test-bad-defun-arguments "bad" - (function (lambda "bad" ))) - -(defun test-bad-defun-arguments (arg "bad") ;; wrong error - (function (lambda "bad" ))) - -(defun test-bad-defun-arguments (&optional) - (function (lambda "bad" ))) - -(defun test-bad-let-in-lambda () - (function (lambda () - (let ((something one bad)))))) ;; wrong error - -(defun test-bad-interactive () - (interactive one bad)) - -(defun test-bad-defvar () - (defvar test-defvar nil [bad])) - -(defun test-bad-let1 () - (let bad)) - -(defun test-bad-let2 () - (let ((something one bad)))) - -(defun test-good-let () - (let ((a b)))) - -(defun test-bad-let3 () - (let (((bad))))) - -(defun test-bad-let4 () - (let ("bad"))) - -(let ((good (list 'one))) good) - -(defun test-bad-setq () - (setq "bad" )) - -(setq good ok - "bad") - -(defun test-bad-cond () - (cond "bad")) - -(cond ()) - -(defun test-bad-cond () - (cond () [] "bad")) - -(defun test-bad-condition-case1 () - (condition-case "bad")) - -(defun test-bad-condition-case2 () - (condition-case err - nil - "bad")) - -(defun test-bad-condition-case3 () - (condition-case err - (error "messages") -;; () - ((error quit) (message "%s" err)))) - - -(def-edebug-spec do - ((&rest &or symbolp - (fence symbolp &optional form form)) - (form body) body)) - -(defun bad-do (list) - -(do ( x - (x list (cdr x)) - (y nil (cons (car x) y)) - (x list (cdr x) bad) - "bad" - ) - ((endp x) y) - )) - -(defun ok () - test - ) - -(defun "bad" () ) -(defun) - -;;========================= - -;; Test printing. - -(defun test-window-buffer-change (arg) - "testing" - (interactive arg) - (save-window-excursion - (set-window-buffer (selected-window) (get-buffer "*scratch*")) - (get-buffer-window (current-buffer)))) -(test-window-buffer-change 'test) - - -(defun test-window-buffer-change () - (selected-window)) - -(test-window-buffer-change 1) - -arg - - -(def-edebug-spec edebug-forms - (&rest edebug-form)) - -(def-edebug-spec edebug-form - (&or (edebug-function-symbolp edebug-forms) - (anonymous-function edebug-forms) - (edebug-macro-symbolp - sexp))) - - -(defun test-mapatoms () ) - -(mapatoms (function (lambda (arg) - (princ - arg) - ))) - - -(test-mapatoms) - -;; Test embedded &rest -(def-edebug-spec symbol-list - ([&rest "a" symbolp] form)) - -(defun test () - (symbol-list a b a (+ c d))) -(test) - -(def-edebug-spec group-alternates-test - (&or ["foo" "bar"] "baz")) - -(group-alternates-test foo bar) -(group-alternates-test baz ) - -;;--------------------- - -(defun test () - (dolist (f (list 1 2)) - (message f))) - -(defun test () - (dolist (el (list 'a 'b 'c)) - (print el))) - - -;; (of-type (type (more type))) - -(def-edebug-spec test-nil - (&or symbolp "nil")) -(test-nil () ) - -(defun test () - ((lambda (arg) arg) two) -) - - -;; Dot notation testing - -(def-edebug-spec test-dot - (symbolp . [&or symbolp (stringp)])) -(test-dot xyz . jk) -(test-dot xyz "jk") - -(def-edebug-spec test-dot - (&or symbolp (test-dot1))) - -(def-edebug-spec test-dot1 - (test-dot2 . test-dot2)) - -(def-edebug-spec test-dot2 - (symbolp)) - -(def-edebug-spec test-dot2 - ([&or test-dot1 nil])) - -(def-edebug-spec test-dot1 - (symbolp)) - - (&or symbolp (test-dot))) - - -(defun test () - (test-dot (a . b))) - -(def-edebug-spec edebug-specs - (symbolp . symbolp)) - -(def-edebug-spec edebug-specs1 - (&or symbolp)) - -(def-edebug-spec edebug-spec - (&or - symbolp)) - - -(def-edebug-spec test-not - (symbolp . [¬ symbolp form])) -(test-not "string") - -;;-------------------------- -;; Loop macro testing - -(defun test () - (loop-var (((var1 (var2 var4) . (var3 var5)) . var1)) - )) - -(loop-var (var1 var2 . var3)) -(loop-var (var1 ["bad"] . "bad")) - - ' (var2 var3 . var4)) - -(loop for ((a . b) (c . d)) - of-type ((float . float) (integer. integer)) - ) - -(defun test () - (loop if some-test - collect a-form into var - else minimize x ;; of-type some-type - and append x - end)) - -(defun test () - (loop for x from 1 to 9 - and y = nil then x - collect (list x y))) - -(defun test () - (loop for i from 10 downto 1 by 3 - do (print i))) - - -(defun test () - (loop for item = 1 then (+ item 10) - repeat 5 - collect item)) - -(defun test () - (loop for z upfrom 2 - thereis - (loop for n upfrom 3 below (+ z 2) ;; + was log - thereis - (loop for x below z - thereis - (loop for y below z - thereis (= (+ (* x n) ;; * was expt - (* y n)) - (* z n))))))) - -(defun test () - (loop for name in '(fred sue alice joe june) - as age in '(22 26 19 20 10) - append (list name age) into name-and-age-list - count name into name-count - sum age into total-age - finally - (return (values (round* total-age name-count) - name-and-age-list)))) - -(defun test () - (loop for x from 0 to 3 - do (print x) - if (zerop (mod x 2)) - do (princ " a") - and if (zerop (floor* x 2)) - do (princ " b") - end - and do (princ " c"))) - - -(defun test () - (loop initially do (message x) - do (dispatch-event event))) - -(defun test () - (loop initially do (popup-menu menu) ;; do is an error here. - with event = (allocate-event) - do (dispatch-event event))) - -(defun popup-menu-synchronously (menu) - (loop initially (popup-menu menu) - with event = (allocate-event) - until (button-release-event-p (next-event event)) - do (dispatch-event event) - finally do (deallocate-event event))) - -(defun test () - (loop with list = '(1 2 3 4) - for item in list - sum item into summation - collect (list item))) - -;;---------- - -(defun test-catch (n) - (if (> n 0) - (let* ((test - (catch 'test - (test-catch (1- n))))) - (if test - (do-throw))) - (do-throw))) - -(defun do-throw () - (funcall 'throw 'test 'here)) - -(test-catch 3) - - -;;------------ - -(defun* foo (a &optional b &key c d (e 17))) - -(def-edebug-spec test-vector - ((vector form))) - -(defun test () - - (test-vector [one])) - -[testing one two three] -(testing one two three) - -(def-edebug-spec test - (&optional &or ["something" keywordp] symbolp)) - -(test something :somekey) - -;;---------- - - - -(defun find-faq (filename) - "Hmtar en faq." - (interactive - - (list - (all-faq-a-valid-ftp - (intern-soft - (let ((minibuffer-help-form - (function - (let* ((partial (buffer-string)) - (soft (intern-soft partial all-faq-known-files))) - (if soft - (set soft (append (cdr (symbol-value soft)) - (list (car (symbol-value soft)))))) - (if (and soft (all-faq-a-valid-ftp soft)) - (mapconcat - (function - (lambda (apair) - (car apair))) - (symbol-value soft) - "\n")))))) - (completing-read "What faq? " - all-faq-known-files - (function all-faq-a-valid-ftp) - t "")) - all-faq-known-files))) -) - (find-file filename)) - - -;;=============== - -;; Keyword testing - -(def-edebug-spec test - (&key (bad "one") (good "thing"))) -(defun test-key () - (test :bad one) - (test1 :bad one)) - -(def-edebug-spec test - (("one"))) - - (&rest ["one" "two"])) - -(test (one)) - -(progn (message "one" ) ) -(testet xxx) -(progn (message "one" ) ) - -(let ((a (+ 1 1))) - (1+ a)) - -(mapcar 'test (list 1 2 3)) -(defun test (testing) testing) - -;;================== -;; Test defstruct. - -(defun test () - (defstruct - (test (:constructor construct (args))) - a - (b (+ a c)) - c)) - -;;================ -;; advice - -(defun foo (x) - "Add 1 to x." - (1+ x)) - -(require 'advice) - -(defadvice foo (before add2 first activate) - " Add 2 to x" - (setq x (1+ x))) - -(foo 3)
--- a/lisp/edebug/edebug.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,4604 +0,0 @@ -;;; edebug.el --- a source-level debugger for Emacs Lisp - -;; Copyright (C) 1988,'89,'90,'91,'92,'93,'94,'95 Free Software Foundation, Inc - -;; Author: Daniel LaLiberte <liberte@cs.uiuc.edu> -;; Keywords: lisp, tools, maint - -;; 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.34. - -;;; Commentary: - -;; LCD Archive Entry: -;; edebug|Daniel LaLiberte|liberte@cs.uiuc.edu -;; |A source level debugger for Emacs Lisp. -;; |$Date: 1997/06/14 20:30:57 $|$Revision: 1.6 $|~/modes/edebug.el| - -;; This minor mode allows programmers to step through Emacs Lisp -;; source code while executing functions. You can also set -;; breakpoints, trace (stopping at each expression), evaluate -;; expressions as if outside Edebug, reevaluate and display a list of -;; expressions, trap errors normally caught by debug, and display a -;; debug style backtrace. - -;;; Installation -;; ============= - -;; Put edebug.el in some directory in your load-path and -;; byte-compile it. Also read the beginning of edebug-epoch.el, -;; cl-specs.el, and edebug-cl-read.el if they apply to you. - -;; Unless you are using Emacs 19 which is already set up to use Edebug, -;; put the following forms in your .emacs file. -;; (define-key emacs-lisp-mode-map "\C-xx" 'edebug-eval-top-level-form) -;; (autoload 'edebug-eval-top-level-form "edebug") - -;; If you wish to change the default edebug global command prefix, change: -;; (setq edebug-global-prefix "\C-xX") - -;; Other options, are described in the manual. - -;; In previous versions of Edebug, users were directed to set -;; `debugger' to `edebug-debug'. This is no longer necessary -;; since Edebug automatically sets it whenever Edebug is active. - -;;; Minimal Instructions -;; ===================== - -;; First evaluate a defun with C-xx, then run the function. Step -;; through the code with SPC, mark breakpoints with b, go until a -;; breakpoint is reached with g, and quit execution with q. Use the -;; "?" command in edebug to describe other commands. See edebug.tex -;; or the Emacs 19 Lisp Reference Manual for more instructions. - -;; Send me your enhancements, ideas, bugs, or fixes. -;; For bugs, you can call edebug-submit-bug-report if you have reporter.el. -;; There is an edebug mailing list if you want to keep up -;; with the latest developments. Requests to: edebug-request@cs.uiuc.edu - -;; Daniel LaLiberte 217-398-4114 -;; University of Illinois, Urbana-Champaign -;; Department of Computer Science -;; 1304 W Springfield -;; Urbana, IL 61801 - -;; uiucdcs!liberte -;; liberte@cs.uiuc.edu - -;; For the early revision history, see edebug-history. - -;;; Code: - -(defconst edebug-version - (let ((raw-version "$Revision: 1.6 $")) - (substring raw-version (string-match "[0-9.]*" raw-version) - (match-end 0)))) - -(require 'backquote) - -;; Emacs 18 doesn't have defalias. -(eval-and-compile - (or (fboundp 'defalias) (fset 'defalias 'fset))) - - -;;; Bug reporting - -(defconst edebug-maintainer-address "liberte@cs.uiuc.edu") - -(defun edebug-submit-bug-report () - "Submit, via mail, a bug report on edebug." - (interactive) - (require 'reporter) - (and (y-or-n-p "Do you really want to submit a report on edebug? ") - (reporter-submit-bug-report - edebug-maintainer-address - (concat "edebug.el " edebug-version) - (list 'edebug-setup-hook - 'edebug-all-defs - 'edebug-all-forms - 'edebug-eval-macro-args - 'edebug-stop-before-symbols - 'edebug-save-windows - 'edebug-save-displayed-buffer-points - 'edebug-initial-mode - 'edebug-trace - 'edebug-test-coverage - 'edebug-continue-kbd-macro - 'edebug-print-length - 'edebug-print-level - 'edebug-print-circle - )))) - -;;; Options - -(defgroup edebug nil - "A source-level debugger for Emacs Lisp" - :group 'lisp) - - -(defvar edebug-setup-hook nil - "*Functions to call before edebug is used. -Each time it is set to a new value, Edebug will call those functions -once and then `edebug-setup-hook' is reset to nil. You could use this -to load up Edebug specifications associated with a package you are -using but only when you also use Edebug.") - -(defcustom edebug-all-defs nil - "*If non-nil, evaluation of any defining forms will instrument for Edebug. -This applies to `eval-defun', `eval-region', `eval-buffer', and -`eval-current-buffer'. `eval-region' is also called by -`eval-last-sexp', and `eval-print-last-sexp'. - -You can use the command `edebug-all-defs' to toggle the value of this -variable. You may wish to make it local to each buffer with -\(make-local-variable 'edebug-all-defs) in your -`emacs-lisp-mode-hook'." - :type 'boolean - :group 'edebug) - -(defcustom edebug-all-forms nil - "*Non-nil evaluation of all forms will instrument for Edebug. -This doesn't apply to loading or evaluations in the minibuffer. -Use the command `edebug-all-forms' to toggle the value of this option." - :type 'boolean - :group 'edebug) - -(defcustom edebug-eval-macro-args nil - "*Non-nil means all macro call arguments may be evaluated. -If this variable is nil, the default, Edebug will *not* wrap -macro call arguments as if they will be evaluated. -For each macro, a `edebug-form-spec' overrides this option. -So to specify exceptions for macros that have some arguments evaluated -and some not, you should specify an `edebug-form-spec'. - -This option is going away soon." - :type 'boolean - :group 'edebug) - -(defcustom edebug-stop-before-symbols nil - "*Non-nil causes Edebug to stop before symbols as well as after. -In any case, a breakpoint or interrupt may stop before a symbol. - -This option is going away soon." - :type 'boolean - :group 'edebug) - -(defcustom edebug-save-windows t - "*If non-nil, Edebug saves and restores the window configuration. -That takes some time, so if your program does not care what happens to -the window configurations, it is better to set this variable to nil. - -If the value is a list, only the listed windows are saved and -restored. - -`edebug-toggle-save-windows' may be used to change this variable." - :type '(choice boolean (repeat string)) - :group 'edebug) - -(defcustom edebug-save-displayed-buffer-points nil - "*If non-nil, save and restore point in all displayed buffers. - -Saving and restoring point in other buffers is necessary if you are -debugging code that changes the point of a buffer which is displayed -in a non-selected window. If Edebug or the user then selects the -window, the buffer's point will be changed to the window's point. - -Saving and restoring point in all buffers is expensive, since it -requires selecting each window twice, so enable this only if you need -it." - :type 'boolean - :group 'edebug) - -(defcustom edebug-initial-mode 'step - "*Initial execution mode for Edebug, if non-nil. If this variable -is non-@code{nil}, it specifies the initial execution mode for Edebug -when it is first activated. Possible values are step, next, go, -Go-nonstop, trace, Trace-fast, continue, and Continue-fast." - :type '(choice (const step) (const next) (const go) - (const Go-nonstop) (const trace) - (const Trace-fast) (const continue) - (const continue-fast)) - :group 'edebug) - -(defcustom edebug-trace nil - "*Non-nil means display a trace of function entry and exit. -Tracing output is displayed in a buffer named `*edebug-trace*', one -function entry or exit per line, indented by the recursion level. - -You can customize by replacing functions `edebug-print-trace-before' -and `edebug-print-trace-after'." - :type 'boolean - :group 'edebug) - -(defcustom edebug-test-coverage nil - "*If non-nil, Edebug tests coverage of all expressions debugged. -This is done by comparing the result of each expression -with the previous result. Coverage is considered OK if two different -results are found. - -Use `edebug-display-freq-count' to display the frequency count and -coverage information for a definition." - :type 'boolean - :group 'edebug) - -(defcustom edebug-continue-kbd-macro nil - "*If non-nil, continue defining or executing any keyboard macro. -Use this with caution since it is not debugged." - :type 'boolean - :group 'edebug) - - -(defcustom edebug-print-length 50 - "*Default value of `print-length' to use while printing results in Edebug." - :type 'integer - :group 'edebug) -(defcustom edebug-print-level 50 - "*Default value of `print-level' to use while printing results in Edebug." - :type 'integer - :group 'edebug) -(defcustom edebug-print-circle t - "*Default value of `print-circle' to use while printing results in Edebug." - :type 'boolean - :group 'edebug) - -(defcustom edebug-unwrap-results nil - "*Non-nil if Edebug should unwrap results of expressions. -This is useful when debugging macros where the results of expressions -are instrumented expressions. But don't do this when results might be -circular or an infinite loop will result." - :type 'boolean - :group 'edebug) - -(defcustom edebug-on-error t - "*Value bound to `debug-on-error' while Edebug is active. - -If `debug-on-error' is non-nil, that value is still used. - -If the value is a list of signal names, Edebug will stop when any of -these errors are signaled from Lisp code whether or not the signal is -handled by a `condition-case'. This option is useful for debugging -signals that *are* handled since they would otherwise be missed. -After execution is resumed, the error is signaled again." - :type '(choice boolean (repeat string)) - :group 'edebug) - -(defcustom edebug-on-quit t - "*Value bound to `debug-on-quit' while Edebug is active." - :type 'boolean - :group 'edebug) - -(defcustom edebug-global-break-condition nil - "*If non-nil, an expression to test for at every stop point. -If the result is non-nil, then break. Errors are ignored." - :type 'sexp - :group 'edebug) - -;;; Form spec utilities. - -;;;###autoload -(defmacro def-edebug-spec (symbol spec) - "Set the edebug-form-spec property of SYMBOL according to SPEC. -Both SYMBOL and SPEC are unevaluated. The SPEC can be 0, t, a symbol -\(naming a function), or a list." - (` (put (quote (, symbol)) 'edebug-form-spec (quote (, spec))))) - -(defmacro def-edebug-form-spec (symbol spec-form) - "For compatibility with old version. Use `def-edebug-spec' instead." - (message "Obsolete: use def-edebug-spec instead.") - (def-edebug-spec symbol (eval spec-form))) - -(defun get-edebug-spec (symbol) - ;; Get the spec of symbol resolving all indirection. - (let ((edebug-form-spec (get symbol 'edebug-form-spec)) - indirect) - (while (and (symbolp edebug-form-spec) - (setq indirect (get edebug-form-spec 'edebug-form-spec))) - ;; (edebug-trace "indirection: %s" edebug-form-spec) - (setq edebug-form-spec indirect)) - edebug-form-spec - )) - -;;; Utilities - -;; Define edebug-gensym - from old cl.el -(defvar edebug-gensym-index 0 - "Integer used by `edebug-gensym' to produce new names.") - -(defun edebug-gensym (&optional prefix) - "Generate a fresh uninterned symbol. -There is an optional argument, PREFIX. PREFIX is the -string that begins the new name. Most people take just the default, -except when debugging needs suggest otherwise." - (if (null prefix) - (setq prefix "G")) - (let ((newsymbol nil) - (newname "")) - (while (not newsymbol) - (setq newname (concat prefix (int-to-string edebug-gensym-index))) - (setq edebug-gensym-index (+ edebug-gensym-index 1)) - (if (not (intern-soft newname)) - (setq newsymbol (make-symbol newname)))) - newsymbol)) - -;; Only used by CL-like code. -(defun edebug-keywordp (object) - "Return t if OBJECT is a keyword. -A keyword is a symbol that starts with `:'." - (and (symbolp object) - (= ?: (aref (symbol-name object) 0)))) - -(defun edebug-lambda-list-keywordp (object) - "Return t if OBJECT is a lambda list keyword. -A lambda list keyword is a symbol that starts with `&'." - (and (symbolp object) - (= ?& (aref (symbol-name object) 0)))) - - -(defun edebug-last-sexp () - ;; Return the last sexp before point in current buffer. - ;; Assumes Emacs Lisp syntax is active. - (car - (read-from-string - (buffer-substring - (save-excursion - (forward-sexp -1) - (point)) - (point))))) - -(defun edebug-window-list () - "Return a list of windows, in order of `next-window'." - ;; This doesn't work for epoch. - (let* ((first-window (selected-window)) - (window-list (list first-window)) - (next (next-window first-window))) - (while (not (eq next first-window)) - (setq window-list (cons next window-list)) - (setq next (next-window next))) - (nreverse window-list))) - -(defun edebug-window-live-p (window) - "Return non-nil if WINDOW is visible." - (let* ((first-window (selected-window)) - (next (next-window first-window t))) - (while (not (or (eq next window) - (eq next first-window))) - (setq next (next-window next t))) - (eq next window))) - -;; Not used. -'(defun edebug-two-window-p () - "Return t if there are two windows." - (and (not (one-window-p)) - (eq (selected-window) - (next-window (next-window (selected-window)))))) - -(defsubst edebug-lookup-function (object) - (while (and (symbolp object) (fboundp object)) - (setq object (symbol-function object))) - object) - -(defun edebug-macrop (object) - "Return the macro named by OBJECT, or nil if it is not a macro." - (setq object (edebug-lookup-function object)) - (if (and (listp object) - (eq 'macro (car object)) - (edebug-functionp (cdr object))) - object)) - -(defun edebug-functionp (object) - "Returns the function named by OBJECT, or nil if it is not a function." - (setq object (edebug-lookup-function object)) - (if (or (subrp object) - (compiled-function-p object) ; XEmacs - (and (listp object) - (eq (car object) 'lambda) - (listp (car (cdr object))))) - object)) - -(defun edebug-sort-alist (alist function) - ;; Return the ALIST sorted with comparison function FUNCTION. - ;; This uses 'sort so the sorting is destructive. - (sort alist (function - (lambda (e1 e2) - (funcall function (car e1) (car e2)))))) - -;;(def-edebug-spec edebug-save-restriction t) - -;; Not used. If it is used, def-edebug-spec must be defined before use. -'(defmacro edebug-save-restriction (&rest body) - "Evaluate BODY while saving the current buffers restriction. -BODY may change buffer outside of current restriction, unlike -save-restriction. BODY may change the current buffer, -and the restriction will be restored to the original buffer, -and the current buffer remains current. -Return the result of the last expression in BODY." - (` (let ((edebug:s-r-beg (point-min-marker)) - (edebug:s-r-end (point-max-marker))) - (unwind-protect - (progn (,@ body)) - (save-excursion - (set-buffer (marker-buffer edebug:s-r-beg)) - (narrow-to-region edebug:s-r-beg edebug:s-r-end)))))) - -;;; Display - -(defconst edebug-trace-buffer "*edebug-trace*" - "Name of the buffer to put trace info in.") - -(defun edebug-pop-to-buffer (buffer &optional window) - ;; Like pop-to-buffer, but select window where BUFFER was last shown. - ;; Select WINDOW if it provided and it still exists. Otherwise, - ;; if buffer is currently shown in several windows, choose one. - ;; Otherwise, find a new window, possibly splitting one. - (setq window (if (and (windowp window) (edebug-window-live-p window) - (eq (window-buffer window) buffer)) - window - (if (eq (window-buffer (selected-window)) buffer) - (selected-window) - (edebug-get-buffer-window buffer)))) - (if window - (select-window window) - (if (one-window-p) - (split-window)) - ;; (message "next window: %s" (next-window)) (sit-for 1) - (if (eq (get-buffer-window edebug-trace-buffer) (next-window)) - ;; Don't select trace window - nil - (select-window (next-window)))) - (set-window-buffer (selected-window) buffer) - (set-window-hscroll (selected-window) 0);; should this be?? - ;; Selecting the window does not set the buffer until command loop. - ;;(set-buffer buffer) - ) - - -(defun edebug-get-displayed-buffer-points () - ;; Return a list of buffer point pairs, for all displayed buffers. - (save-excursion - (let* ((first-window (selected-window)) - (next (next-window first-window)) - (buffer-point-list nil) - buffer) - (while (not (eq next first-window)) - (set-buffer (setq buffer (window-buffer next))) - (setq buffer-point-list - (cons (cons buffer (point)) buffer-point-list)) - (setq next (next-window next))) - buffer-point-list))) - - -(defun edebug-set-buffer-points (buffer-points) - ;; Restore the buffer-points created by edebug-get-displayed-buffer-points. - (let ((current-buffer (current-buffer))) - (mapcar (function (lambda (buf-point) - (if (buffer-name (car buf-point)) ; still exists - (progn - (set-buffer (car buf-point)) - (goto-char (cdr buf-point)))))) - buffer-points) - (set-buffer current-buffer))) - -(defun edebug-current-windows (which-windows) - ;; Get either a full window configuration or some window information. - (if (listp which-windows) - (mapcar (function (lambda (window) - (if (edebug-window-live-p window) - (list window - (window-buffer window) - (window-point window) - (window-start window) - (window-hscroll window))))) - which-windows) - (current-window-configuration))) - -(defun edebug-set-windows (window-info) - ;; Set either a full window configuration or some window information. - (if (listp window-info) - (mapcar (function - (lambda (one-window-info) - (if one-window-info - (apply (function - (lambda (window buffer point start hscroll) - (if (edebug-window-live-p window) - (progn - (set-window-buffer window buffer) - (set-window-point window point) - (set-window-start window start) - (set-window-hscroll window hscroll))))) - one-window-info)))) - window-info) - (set-window-configuration window-info))) - -(defalias 'edebug-get-buffer-window 'get-buffer-window) -(defalias 'edebug-sit-for 'sit-for) -(defalias 'edebug-input-pending-p 'input-pending-p) - - -;;; Redefine read and eval functions -;; read is redefined to maybe instrument forms. -;; eval-defun is redefined to check edebug-all-forms and edebug-all-defs. - -;; Use the Lisp version of eval-region. -(require 'eval-reg "eval-reg") - -;; Save the original read function -(or (fboundp 'edebug-original-read) - (defalias 'edebug-original-read (symbol-function 'read))) - -(defun edebug-read (&optional stream) - "Read one Lisp expression as text from STREAM, return as Lisp object. -If STREAM is nil, use the value of `standard-input' (which see). -STREAM or the value of `standard-input' may be: - a buffer (read from point and advance it) - a marker (read from where it points and advance it) - a function (call it with no arguments for each character, - call it with a char as argument to push a char back) - a string (takes text from string, starting at the beginning) - t (read text line using minibuffer and use it). - -This version, from Edebug, maybe instruments the expression. But the -STREAM must be the current buffer to do so. Whether it instruments is -also dependent on the values of `edebug-all-defs' and -`edebug-all-forms'." - (or stream (setq stream standard-input)) - (if (eq stream (current-buffer)) - (edebug-read-and-maybe-wrap-form) - (edebug-original-read stream))) - -(or (fboundp 'edebug-original-eval-defun) - (defalias 'edebug-original-eval-defun (symbol-function 'eval-defun))) - -;; We should somehow arrange to be able to do this -;; without actually replacing the eval-defun command. -(defun edebug-eval-defun (edebug-it) - "Evaluate the top-level form containing point, or after point. - -This version, from Edebug, has the following differences: With a -prefix argument instrument the code for Edebug. If `edebug-all-defs' is -non-nil, then the code is instrumented *unless* there is a prefix -argument. If instrumenting, it prints: `Edebug: FUNCTIONNAME'. -Otherwise, it prints in the minibuffer." - (interactive "P") - (let* ((edebugging (not (eq (not edebug-it) (not edebug-all-defs)))) - (edebug-result) - (form - (let ((edebug-all-forms edebugging) - (edebug-all-defs (eq edebug-all-defs (not edebug-it)))) - (edebug-read-top-level-form)))) - (if (and (eq (car form) 'defvar) - (cdr-safe (cdr-safe form))) - (setq form (cons 'defconst (cdr form)))) - (setq edebug-result (eval form)) - (if (not edebugging) - (princ edebug-result) - edebug-result))) - - -;;;###autoload -(defalias 'edebug-defun 'edebug-eval-top-level-form) - -;;;###autoload -(defun edebug-eval-top-level-form () - "Evaluate a top level form, such as a defun or defmacro. -This is like `eval-defun', but the code is always instrumented for Edebug. -Print its name in the minibuffer and leave point where it is, -or if an error occurs, leave point after it with mark at the original point." - (interactive) - (eval - ;; Bind edebug-all-forms only while reading, not while evalling - ;; but this causes problems while edebugging edebug. - (let ((edebug-all-forms t) - (edebug-all-defs t)) - (edebug-read-top-level-form)))) - - -(defun edebug-read-top-level-form () - (let ((starting-point (point))) - (end-of-defun) - (beginning-of-defun) - (prog1 - (edebug-read-and-maybe-wrap-form) - ;; Recover point, but only if no error occurred. - (goto-char starting-point)))) - - -;; Compatibility with old versions. -(defalias 'edebug-all-defuns 'edebug-all-defs) - -(defun edebug-all-defs () - "Toggle edebugging of all definitions." - (interactive) - (setq edebug-all-defs (not edebug-all-defs)) - (message "Edebugging all definitions is %s." - (if edebug-all-defs "on" "off"))) - - -(defun edebug-all-forms () - "Toggle edebugging of all forms." - (interactive) - (setq edebug-all-forms (not edebug-all-forms)) - (message "Edebugging all forms is %s." - (if edebug-all-forms "on" "off"))) - - -(defun edebug-install-read-eval-functions () - (interactive) - ;; Don't install if already installed. - (if (eq (symbol-function 'read) 'edebug-read) nil - (elisp-eval-region-install) - (defalias 'read 'edebug-read) - (defalias 'eval-defun 'edebug-eval-defun))) - -(defun edebug-uninstall-read-eval-functions () - (interactive) - (elisp-eval-region-uninstall) - (defalias 'read (symbol-function 'edebug-original-read)) - (defalias 'eval-defun (symbol-function 'edebug-original-eval-defun))) - - -;;; Edebug internal data - -;; The internal data that is needed for edebugging is kept in the -;; buffer-local variable `edebug-form-data'. - -;; XEmacs change? -(defconst edebug-form-data nil) -(make-variable-buffer-local 'edebug-form-data) - -;; A list of entries associating symbols with buffer regions. -;; This is an automatic buffer local variable. Each entry looks like: -;; @code{(@var{symbol} @var{begin-marker} @var{end-marker}). The markers -;; are at the beginning and end of an entry level form and @var{symbol} is -;; a symbol that holds all edebug related information for the form on its -;; property list. - -;; In the future, the symbol will be irrelevant and edebug data will -;; be stored in the definitions themselves rather than in the property -;; list of a symbol. - -(defun edebug-make-form-data-entry (symbol begin end) - (list symbol begin end)) - -(defsubst edebug-form-data-name (entry) - (car entry)) - -(defsubst edebug-form-data-begin (entry) - (nth 1 entry)) - -(defsubst edebug-form-data-end (entry) - (nth 2 entry)) - -(defsubst edebug-set-form-data-entry (entry name begin end) - (setcar entry name);; in case name is changed - (set-marker (nth 1 entry) begin) - (set-marker (nth 2 entry) end)) - -(defun edebug-get-form-data-entry (pnt &optional end-point) - ;; Find the edebug form data entry which is closest to PNT. - ;; If END-POINT is supplied, match must be exact. - ;; Return `nil' if none found. - (let ((rest edebug-form-data) - closest-entry - (closest-dist 999999)) ;; need maxint here - (while (and rest (< 0 closest-dist)) - (let* ((entry (car rest)) - (begin (edebug-form-data-begin entry)) - (dist (- pnt begin))) - (setq rest (cdr rest)) - (if (and (<= 0 dist) - (< dist closest-dist) - (or (not end-point) - (= end-point (edebug-form-data-end entry))) - (<= pnt (edebug-form-data-end entry))) - (setq closest-dist dist - closest-entry entry)))) - closest-entry)) - -;; Also need to find all contained entries, -;; and find an entry given a symbol, which should be just assq. - -(defun edebug-form-data-symbol () -;; Return the edebug data symbol of the form where point is in. -;; If point is not inside a edebuggable form, cause error. - (or (edebug-form-data-name (edebug-get-form-data-entry (point))) - (error "Not inside instrumented form"))) - -(defun edebug-make-top-form-data-entry (new-entry) - ;; Make NEW-ENTRY the first element in the `edebug-form-data' list. - (edebug-clear-form-data-entry new-entry) - (setq edebug-form-data (cons new-entry edebug-form-data))) - -(defun edebug-clear-form-data-entry (entry) -;; If non-nil, clear ENTRY out of the form data. -;; Maybe clear the markers and delete the symbol's edebug property? - (if entry - (progn - ;; Instead of this, we could just find all contained forms. - ;; (put (car entry) 'edebug nil) ; - ;; (mapcar 'edebug-clear-form-data-entry ; dangerous - ;; (get (car entry) 'edebug-dependents)) - ;; (set-marker (nth 1 entry) nil) - ;; (set-marker (nth 2 entry) nil) - (setq edebug-form-data (delq entry edebug-form-data))))) - -;;; Parser utilities - -(defun edebug-syntax-error (&rest args) - ;; Signal an invalid-read-syntax with ARGS. - (signal 'invalid-read-syntax args)) - - -(defconst edebug-read-syntax-table - ;; Lookup table for significant characters indicating the class of the - ;; token that follows. This is not a \"real\" syntax table. - (let ((table (make-vector 256 'symbol)) - (i 0)) - (while (< i ?!) - (aset table i 'space) - (setq i (1+ i))) - (aset table ?\( 'lparen) - (aset table ?\) 'rparen) - (aset table ?\' 'quote) - (aset table ?\` 'backquote) - (aset table ?\, 'comma) - (aset table ?\" 'string) - (aset table ?\? 'char) - (aset table ?\[ 'lbracket) - (aset table ?\] 'rbracket) - (aset table ?\. 'dot) - (aset table ?\# 'hash) - ;; We treat numbers as symbols, because of confusion with -, -1, and 1-. - ;; We don't care about any other chars since they won't be seen. - table)) - -(defun edebug-next-token-class () - ;; Move to the next token and return its class. We only care about - ;; lparen, rparen, dot, quote, backquote, comma, string, char, vector, - ;; or symbol. - (edebug-skip-whitespace) - (aref edebug-read-syntax-table (following-char))) - - -(defun edebug-skip-whitespace () - ;; Leave point before the next token, skipping white space and comments. - (skip-chars-forward " \t\r\n\f") - (while (= (following-char) ?\;) - ;; \r is counted as a comment terminator to support selective display. - (skip-chars-forward "^\n\r") ; skip the comment - (skip-chars-forward " \t\r\n\f"))) - - -;; Mostly obsolete reader; still used in one case. - -(defun edebug-read-sexp () - ;; Read one sexp from the current buffer starting at point. - ;; Leave point immediately after it. A sexp can be a list or atom. - ;; An atom is a symbol (or number), character, string, or vector. - ;; This works for reading anything legitimate, but it - ;; is gummed up by parser inconsistencies (bugs?) - (let ((class (edebug-next-token-class))) - (cond - ;; read goes one too far if a (possibly quoted) string or symbol - ;; is immediately followed by non-whitespace. - ((eq class 'symbol) (prog1 - (edebug-original-read (current-buffer)) - (if (not (eq (aref edebug-read-syntax-table - (preceding-char)) 'symbol)) - (forward-char -1)))) - ((eq class 'string) (prog1 - (edebug-original-read (current-buffer)) - (if (/= (preceding-char) ?\") - (forward-char -1)))) - ((eq class 'quote) (forward-char 1) - (list 'quote (edebug-read-sexp))) - ((eq class 'backquote) - (list '\` (edebug-read-sexp))) - ((eq class 'comma) - (list '\, (edebug-read-sexp))) - (t ; anything else, just read it. - (edebug-original-read (current-buffer)))))) - -;;; Offsets for reader - -;; Define a structure to represent offset positions of expressions. -;; Each offset structure looks like: (before . after) for constituents, -;; or for structures that have elements: (before <subexpressions> . after) -;; where the <subexpressions> are the offset structures for subexpressions -;; including the head of a list. -(defconst edebug-offsets nil) - -;; Stack of offset structures in reverse order of the nesting. -;; This is used to get back to previous levels. -(defconst edebug-offsets-stack nil) -(defconst edebug-current-offset nil) ; Top of the stack, for convenience. - -;; We must store whether we just read a list with a dotted form that -;; is itself a list. This structure will be condensed, so the offsets -;; must also be condensed. -(defconst edebug-read-dotted-list nil) - -(defsubst edebug-initialize-offsets () - ;; Reinitialize offset recording. - (setq edebug-current-offset nil)) - -(defun edebug-store-before-offset (point) - ;; Add a new offset pair with POINT as the before offset. - (let ((new-offset (list point))) - (if edebug-current-offset - (setcdr edebug-current-offset - (cons new-offset (cdr edebug-current-offset))) - ;; Otherwise, we are at the top level, so initialize. - (setq edebug-offsets new-offset - edebug-offsets-stack nil - edebug-read-dotted-list nil)) - ;; Cons the new offset to the front of the stack. - (setq edebug-offsets-stack (cons new-offset edebug-offsets-stack) - edebug-current-offset new-offset) - )) - -(defun edebug-store-after-offset (point) - ;; Finalize the current offset struct by reversing it and - ;; store POINT as the after offset. - (if (not edebug-read-dotted-list) - ;; Just reverse the offsets of all subexpressions. - (setcdr edebug-current-offset (nreverse (cdr edebug-current-offset))) - - ;; We just read a list after a dot, which will be abbreviated out. - (setq edebug-read-dotted-list nil) - ;; Drop the corresponding offset pair. - ;; That is, nconc the reverse of the rest of the offsets - ;; with the cdr of last offset. - (setcdr edebug-current-offset - (nconc (nreverse (cdr (cdr edebug-current-offset))) - (cdr (car (cdr edebug-current-offset)))))) - - ;; Now append the point using nconc. - (setq edebug-current-offset (nconc edebug-current-offset point)) - ;; Pop the stack. - (setq edebug-offsets-stack (cdr edebug-offsets-stack) - edebug-current-offset (car edebug-offsets-stack))) - -(defun edebug-ignore-offset () - ;; Ignore the last created offset pair. - (setcdr edebug-current-offset (cdr (cdr edebug-current-offset)))) - -(def-edebug-spec edebug-storing-offsets (form body)) -(put 'edebug-storing-offsets 'lisp-indent-hook 1) - -(defmacro edebug-storing-offsets (point &rest body) - (` (unwind-protect - (progn - (edebug-store-before-offset (, point)) - (,@ body)) - (edebug-store-after-offset (point))))) - - -;;; Reader for Emacs Lisp. - -;; Uses edebug-next-token-class (and edebug-skip-whitespace) above. - -(defconst edebug-read-alist - '((symbol . edebug-read-symbol) - (lparen . edebug-read-list) - (string . edebug-read-string) - (quote . edebug-read-quote) - (backquote . edebug-read-backquote) - (comma . edebug-read-comma) - (lbracket . edebug-read-vector) - (hash . edebug-read-function) - )) - -(defun edebug-read-storing-offsets (stream) - (let ((class (edebug-next-token-class)) - func - edebug-read-dotted-list) ; see edebug-store-after-offset - (edebug-storing-offsets (point) - (if (setq func (assq class edebug-read-alist)) - (funcall (cdr func) stream) - ;; anything else, just read it. - (edebug-original-read stream)) - ))) - -(defun edebug-read-symbol (stream) - (prog1 - (edebug-original-read stream) - ;; loses for escaped chars - (if (not (eq (aref edebug-read-syntax-table - (preceding-char)) 'symbol)) - (forward-char -1)))) - -(defun edebug-read-string (stream) - (prog1 - (edebug-original-read stream) - (if (/= (preceding-char) ?\") - (forward-char -1)))) - -(defun edebug-read-quote (stream) - ;; Turn 'thing into (quote thing) - (forward-char 1) - (list - (edebug-storing-offsets (point) 'quote) - (edebug-read-storing-offsets stream))) - -(defun edebug-read-backquote (stream) - ;; Turn `thing into (\` thing) - (let ((opoint (point))) - (forward-char 1) - ;; Generate the same structure of offsets we would have - ;; if the resulting list appeared verbatim in the input text. - (edebug-storing-offsets opoint - (list - (edebug-storing-offsets opoint '\`) - (edebug-read-storing-offsets stream))))) - -(defvar edebug-read-backquote-new nil - "Non-nil if reading the inside of a new-style backquote with no parens around it. -Value of nil means reading the inside of an old-style backquote construct -which is surrounded by an extra set of parentheses. -This controls how we read comma constructs.") - -(defun edebug-read-comma (stream) - ;; Turn ,thing into (\, thing). Handle ,@ and ,. also. - (let ((opoint (point))) - (forward-char 1) - (let ((symbol '\,)) - (cond ((eq (following-char) ?\.) - (setq symbol '\,\.) - (forward-char 1)) - ((eq (following-char) ?\@) - (setq symbol '\,@) - (forward-char 1))) - ;; Generate the same structure of offsets we would have - ;; if the resulting list appeared verbatim in the input text. - (if edebug-read-backquote-new - (list - (edebug-storing-offsets opoint symbol) - (edebug-read-storing-offsets stream)) - (edebug-storing-offsets opoint symbol))))) - -(defun edebug-read-function (stream) - ;; Turn #'thing into (function thing) - (forward-char 1) - (if (/= ?\' (following-char)) (edebug-syntax-error "Bad char")) - (forward-char 1) - (list - (edebug-storing-offsets (point) - (if (featurep 'cl) 'function* 'function)) - (edebug-read-storing-offsets stream))) - -(defun edebug-read-list (stream) - (forward-char 1) ; skip \( - (prog1 - (let ((elements)) - (while (not (memq (edebug-next-token-class) '(rparen dot))) - (if (eq (edebug-next-token-class) 'backquote) - (let ((edebug-read-backquote-new (not (null elements))) - (opoint (point))) - (if edebug-read-backquote-new - (setq elements (cons (edebug-read-backquote stream) elements)) - (forward-char 1) ; Skip backquote. - ;; Call edebug-storing-offsets here so that we - ;; produce the same offsets we would have had - ;; if the backquote were an ordinary symbol. - (setq elements (cons (edebug-storing-offsets opoint '\`) - elements)))) - (setq elements (cons (edebug-read-storing-offsets stream) elements)))) - (setq elements (nreverse elements)) - (if (eq 'dot (edebug-next-token-class)) - (let (dotted-form) - (forward-char 1) ; skip \. - (setq dotted-form (edebug-read-storing-offsets stream)) - elements (nconc elements dotted-form) - (if (not (eq (edebug-next-token-class) 'rparen)) - (edebug-syntax-error "Expected `)'")) - (setq edebug-read-dotted-list (listp dotted-form)) - )) - elements) - (forward-char 1) ; skip \) - )) - -(defun edebug-read-vector (stream) - (forward-char 1) ; skip \[ - (prog1 - (let ((elements)) - (while (not (eq 'rbracket (edebug-next-token-class))) - (setq elements (cons (edebug-read-storing-offsets stream) elements))) - (apply 'vector (nreverse elements))) - (forward-char 1) ; skip \] - )) - -;;; Cursors for traversal of list and vector elements with offsets. - -(defvar edebug-dotted-spec nil) - -(defun edebug-new-cursor (expressions offsets) - ;; Return a new cursor for EXPRESSIONS with OFFSETS. - (if (vectorp expressions) - (setq expressions (append expressions nil))) - (cons expressions offsets)) - -(defsubst edebug-set-cursor (cursor expressions offsets) - ;; Set the CURSOR's EXPRESSIONS and OFFSETS to the given. - ;; Return the cursor. - (setcar cursor expressions) - (setcdr cursor offsets) - cursor) - -'(defun edebug-copy-cursor (cursor) - ;; Copy the cursor using the same object and offsets. - (cons (car cursor) (cdr cursor))) - -(defsubst edebug-cursor-expressions (cursor) - (car cursor)) -(defsubst edebug-cursor-offsets (cursor) - (cdr cursor)) - -(defsubst edebug-empty-cursor (cursor) - ;; Return non-nil if CURSOR is empty - meaning no more elements. - (null (car cursor))) - -(defsubst edebug-top-element (cursor) - ;; Return the top element at the cursor. - ;; Assumes not empty. - (car (car cursor))) - -(defun edebug-top-element-required (cursor &rest error) - ;; Check if a dotted form is required. - (if edebug-dotted-spec (edebug-no-match cursor "Dot expected.")) - ;; Check if there is at least one more argument. - (if (edebug-empty-cursor cursor) (apply 'edebug-no-match cursor error)) - ;; Return that top element. - (edebug-top-element cursor)) - -(defsubst edebug-top-offset (cursor) - ;; Return the top offset pair corresponding to the top element. - (car (cdr cursor))) - -(defun edebug-move-cursor (cursor) - ;; Advance and return the cursor to the next element and offset. - ;; throw no-match if empty before moving. - ;; This is a violation of the cursor encapsulation, but - ;; there is plenty of that going on while matching. - ;; The following test should always fail. - (if (edebug-empty-cursor cursor) - (edebug-no-match cursor "Not enough arguments.")) - (setcar cursor (cdr (car cursor))) - (setcdr cursor (cdr (cdr cursor))) - cursor) - - -(defun edebug-before-offset (cursor) - ;; Return the before offset of the cursor. - ;; If there is nothing left in the offsets, - ;; return one less than the offset itself, - ;; which is the after offset for a list. - (let ((offset (edebug-cursor-offsets cursor))) - (if (consp offset) - (car (car offset)) - (1- offset)))) - -(defun edebug-after-offset (cursor) - ;; Return the after offset of the cursor object. - (let ((offset (edebug-top-offset cursor))) - (while (consp offset) - (setq offset (cdr offset))) - offset)) - -;;; The Parser - -;; The top level function for parsing forms is -;; edebug-read-and-maybe-wrap-form; it calls all the rest. It checks the -;; syntax a bit and leaves point at any error it finds, but otherwise -;; should appear to work like eval-defun. - -;; The basic plan is to surround each expression with a call to -;; the edebug debugger together with indexes into a table of positions of -;; all expressions. Thus an expression "exp" becomes: - -;; (edebug-after (edebug-before 1) 2 exp) - -;; When this is evaluated, first point is moved to the beginning of -;; exp at offset 1 of the current function. The expression is -;; evaluated, which may cause more edebug calls, and then point is -;; moved to offset 2 after the end of exp. - -;; The highest level expressions of the function are wrapped in a call to -;; edebug-enter, which supplies the function name and the actual -;; arguments to the function. See functions edebug-enter, edebug-before, -;; and edebug-after for more details. - -;; Dynamically bound vars, left unbound, but globally declared. -;; This is to quiet the byte compiler. - -;; Window data of the highest definition being wrapped. -;; This data is shared by all embedded definitions. -(defvar edebug-top-window-data) - -(defvar edebug-&optional) -(defvar edebug-&rest) -(defvar edebug-gate nil) ;; whether no-match forces an error. - -(defconst edebug-def-name nil) ; name of definition, used by interactive-form -(defconst edebug-old-def-name nil) ; previous name of containing definition. - -(defconst edebug-error-point nil) -(defconst edebug-best-error nil) - - -(defun edebug-read-and-maybe-wrap-form () - ;; Read a form and wrap it with edebug calls, if the conditions are right. - ;; Here we just catch any no-match not caught below and signal an error. - - ;; Run the setup hook. - (let ((temp-hook edebug-setup-hook)) - (setq edebug-setup-hook nil) - (run-hooks 'temp-hook)) - - (let (result - edebug-top-window-data - edebug-def-name;; make sure it is locally nil - ;; I don't like these here!! - edebug-&optional - edebug-&rest - edebug-gate - edebug-best-error - edebug-error-point - no-match - ;; Do this once here instead of several times. - (max-lisp-eval-depth (+ 800 max-lisp-eval-depth)) - (max-specpdl-size (+ 2000 max-specpdl-size))) - (setq no-match - (catch 'no-match - (setq result (edebug-read-and-maybe-wrap-form1)) - nil)) - (if no-match - (apply 'edebug-syntax-error no-match)) - result)) - - -(defun edebug-read-and-maybe-wrap-form1 () - (let (spec - def-kind - defining-form-p - def-name - ;; These offset things don't belong here, but to support recursive - ;; calls to edebug-read, they need to be here. - edebug-offsets - edebug-offsets-stack - edebug-current-offset ; reset to nil - ) - (save-excursion - (if (and (eq 'lparen (edebug-next-token-class)) - (eq 'symbol (progn (forward-char 1) (edebug-next-token-class)))) - ;; Find out if this is a defining form from first symbol - (setq def-kind (edebug-original-read (current-buffer)) - spec (and (symbolp def-kind) (get-edebug-spec def-kind)) - defining-form-p (and (listp spec) - (eq '&define (car spec))) - ;; This is incorrect in general!! But OK most of the time. - def-name (if (and defining-form-p - (eq 'name (car (cdr spec))) - (eq 'symbol (edebug-next-token-class))) - (edebug-original-read (current-buffer)))))) -;;;(message "all defs: %s all forms: %s" edebug-all-defs edebug-all-forms) - (cond - (defining-form-p - (if (or edebug-all-defs edebug-all-forms) - ;; If it is a defining form and we are edebugging defs, - ;; then let edebug-list-form start it. - (let ((cursor (edebug-new-cursor - (list (edebug-read-storing-offsets (current-buffer))) - (list edebug-offsets)))) - (car - (edebug-make-form-wrapper - cursor - (edebug-before-offset cursor) - (1- (edebug-after-offset cursor)) - (list (cons (symbol-name def-kind) (cdr spec)))))) - - ;; Not edebugging this form, so reset the symbol's edebug - ;; property to be just a marker at the definition's source code. - ;; This only works for defs with simple names. - (put def-name 'edebug (point-marker)) - ;; Also nil out dependent defs. - '(mapcar (function - (lambda (def) - (put def-name 'edebug nil))) - (get def-name 'edebug-dependents)) - (edebug-read-sexp))) - - ;; If all forms are being edebugged, explicitly wrap it. - (edebug-all-forms - (let ((cursor (edebug-new-cursor - (list (edebug-read-storing-offsets (current-buffer))) - (list edebug-offsets)))) - (edebug-make-form-wrapper - cursor - (edebug-before-offset cursor) - (edebug-after-offset cursor) - nil))) - - ;; Not a defining form, and not edebugging. - (t (edebug-read-sexp))) - )) - - -(defvar edebug-def-args) ; args of defining form. -(defvar edebug-def-interactive) ; is it an emacs interactive function? -(defvar edebug-inside-func) ;; whether code is inside function context. -;; Currently def-form sets this to nil; def-body sets it to t. - -(defun edebug-interactive-p-name () - ;; Return a unique symbol for the variable used to store the - ;; status of interactive-p for this function. - (intern (format "edebug-%s-interactive-p" edebug-def-name))) - - -(defun edebug-wrap-def-body (forms) - "Wrap the FORMS of a definition body." - (if edebug-def-interactive - (` (let (((, (edebug-interactive-p-name)) - (interactive-p))) - (, (edebug-make-enter-wrapper forms)))) - (edebug-make-enter-wrapper forms))) - - -(defun edebug-make-enter-wrapper (forms) - ;; Generate the enter wrapper for some forms of a definition. - ;; This is not to be used for the body of other forms, e.g. `while', - ;; since it wraps the list of forms with a call to `edebug-enter'. - ;; Uses the dynamically bound vars edebug-def-name and edebug-def-args. - ;; Do this after parsing since that may find a name. - (setq edebug-def-name - (or edebug-def-name edebug-old-def-name (edebug-gensym "edebug-anon"))) - (` (edebug-enter - (quote (, edebug-def-name)) - (, (if edebug-inside-func - (` (list (,@ - ;; Doesn't work with more than one def-body!! - ;; But the list will just be reversed. - (nreverse edebug-def-args)))) - 'nil)) - (function (lambda () (,@ forms))) - ))) - - -(defvar edebug-form-begin-marker) ; the mark for def being instrumented - -(defvar edebug-offset-index) ; the next available offset index. -(defvar edebug-offset-list) ; the list of offset positions. - -(defun edebug-inc-offset (offset) - ;; modifies edebug-offset-index and edebug-offset-list - ;; accesses edebug-func-marc and buffer point - (prog1 - edebug-offset-index - (setq edebug-offset-list (cons (- offset edebug-form-begin-marker) - edebug-offset-list) - edebug-offset-index (1+ edebug-offset-index)))) - - -(defun edebug-make-before-and-after-form (before-index form after-index) - ;; Return the edebug form for the current function at offset BEFORE-INDEX - ;; given FORM. Looks like: - ;; (edebug-after (edebug-before BEFORE-INDEX) AFTER-INDEX FORM) - ;; Also increment the offset index for subsequent use. - ;; if (not edebug-stop-before-symbols) and form is a symbol, - ;; then don't call edebug-before. - (list 'edebug-after - (list 'edebug-before before-index) - after-index form)) - -(defun edebug-make-after-form (form after-index) - ;; Like edebug-make-before-and-after-form, but only after. - (list 'edebug-after 0 after-index form)) - - -(defun edebug-unwrap (sexp) - "Return the unwrapped SEXP or return it as is if it is not wrapped. -The SEXP might be the result of wrapping a body, which is a list of -expressions; a `progn' form will be returned enclosing these forms." - (if (consp sexp) - (cond - ((eq 'edebug-after (car sexp)) - (nth 3 sexp)) - ((eq 'edebug-enter (car sexp)) - (let ((forms (nthcdr 2 (nth 1 (nth 3 sexp))))) - (if (> (length forms) 1) - (cons 'progn forms) ;; could return (values forms) instead. - (car forms)))) - (t sexp);; otherwise it is not wrapped, so just return it. - ) - sexp)) - -(defun edebug-unwrap* (sexp) - "Return the sexp recursively unwrapped." - (let ((new-sexp (edebug-unwrap sexp))) - (while (not (eq sexp new-sexp)) - (setq sexp new-sexp - new-sexp (edebug-unwrap sexp))) - (if (consp new-sexp) - (mapcar 'edebug-unwrap* new-sexp) - new-sexp))) - - -(defun edebug-defining-form (cursor form-begin form-end speclist) - ;; Process the defining form, starting outside the form. - ;; The speclist is a generated list spec that looks like: - ;; (("def-symbol" defining-form-spec-sans-&define)) - ;; Skip the first offset. - (edebug-set-cursor cursor (edebug-cursor-expressions cursor) - (cdr (edebug-cursor-offsets cursor))) - (edebug-make-form-wrapper - cursor - form-begin (1- form-end) - speclist)) - -(defun edebug-make-form-wrapper (cursor form-begin form-end - &optional speclist) - ;; Wrap a form, usually a defining form, but any evaluated one. - ;; If speclist is non-nil, this is being called by edebug-defining-form. - ;; Otherwise it is being called from edebug-read-and-maybe-wrap-form1. - ;; This is a hack, but I havent figured out a simpler way yet. - (let* ((form-data-entry (edebug-get-form-data-entry form-begin form-end)) - ;; Set this marker before parsing. - (edebug-form-begin-marker - (if form-data-entry - (edebug-form-data-begin form-data-entry) - ;; Buffer must be current-buffer for this to work: - (set-marker (make-marker) form-begin)))) - - (let (edebug-offset-list - (edebug-offset-index 0) - result - ;; For definitions. - ;; (edebug-containing-def-name edebug-def-name) - ;; Get name from form-data, if any. - (edebug-old-def-name (edebug-form-data-name form-data-entry)) - edebug-def-name - edebug-def-args - edebug-def-interactive - edebug-inside-func;; whether wrapped code executes inside a function. - ) - - (setq result - (if speclist - (edebug-match cursor speclist) - - ;; else wrap as an enter-form. - (edebug-make-enter-wrapper (list (edebug-form cursor))))) - - ;; Set the name here if it was not set by edebug-make-enter-wrapper. - (setq edebug-def-name - (or edebug-def-name edebug-old-def-name (edebug-gensym "edebug-anon"))) - - ;; Add this def as a dependent of containing def. Buggy. - '(if (and edebug-containing-def-name - (not (get edebug-containing-def-name 'edebug-dependents))) - (put edebug-containing-def-name 'edebug-dependents - (cons edebug-def-name - (get edebug-containing-def-name - 'edebug-dependents)))) - - ;; Create a form-data-entry or modify existing entry's markers. - ;; In the latter case, pointers to the entry remain eq. - (if (not form-data-entry) - (setq form-data-entry - (edebug-make-form-data-entry - edebug-def-name - edebug-form-begin-marker - ;; Buffer must be current-buffer. - (set-marker (make-marker) form-end) - )) - (edebug-set-form-data-entry - form-data-entry edebug-def-name ;; in case name is changed - form-begin form-end)) - - ;; (message "defining: %s" edebug-def-name) (sit-for 2) - (edebug-make-top-form-data-entry form-data-entry) - (message "Edebug: %s" edebug-def-name) - ;;(debug edebug-def-name) - - ;; Destructively reverse edebug-offset-list and make vector from it. - (setq edebug-offset-list (vconcat (nreverse edebug-offset-list))) - - ;; Side effects on the property list of edebug-def-name. - (edebug-clear-frequency-count edebug-def-name) - (edebug-clear-coverage edebug-def-name) - - ;; Set up the initial window data. - (if (not edebug-top-window-data) ;; if not already set, do it now. - (let ((window ;; Find the best window for this buffer. - (or (get-buffer-window (current-buffer)) - (selected-window)))) - (setq edebug-top-window-data - (cons window (window-start window))))) - - ;; Store the edebug data in symbol's property list. - (put edebug-def-name 'edebug - ;; A struct or vector would be better here!! - (list edebug-form-begin-marker - nil ; clear breakpoints - edebug-offset-list - edebug-top-window-data - )) - result - ))) - - -(defun edebug-clear-frequency-count (name) - ;; Create initial frequency count vector. - ;; For each stop point, the counter is incremented each time it is visited. - (put name 'edebug-freq-count - (make-vector (length edebug-offset-list) 0))) - - -(defun edebug-clear-coverage (name) - ;; Create initial coverage vector. - ;; Only need one per expression, but it is simpler to use stop points. - (put name 'edebug-coverage - (make-vector (length edebug-offset-list) 'unknown))) - - -(defun edebug-form (cursor) - ;; Return the instrumented form for the following form. - ;; Add the point offsets to the edebug-offset-list for the form. - (let* ((form (edebug-top-element-required cursor "Expected form")) - (offset (edebug-top-offset cursor))) - (prog1 - (cond - ((consp form) - ;; The first offset for a list form is for the list form itself. - (if (eq 'quote (car form)) - form - (let* ((head (car form)) - (spec (and (symbolp head) (get-edebug-spec head))) - (new-cursor (edebug-new-cursor form offset))) - ;; Find out if this is a defining form from first symbol. - ;; An indirect spec would not work here, yet. - (if (and (consp spec) (eq '&define (car spec))) - (edebug-defining-form - new-cursor - (car offset);; before the form - (edebug-after-offset cursor) - (cons (symbol-name head) (cdr spec))) - ;; Wrap a regular form. - (edebug-make-before-and-after-form - (edebug-inc-offset (car offset)) - (edebug-list-form new-cursor) - ;; After processing the list form, the new-cursor is left - ;; with the offset after the form. - (edebug-inc-offset (edebug-cursor-offsets new-cursor)))) - ))) - - ((symbolp form) - (cond - ;; Check for constant symbols that don't get wrapped. - ((or (memq form '(t nil)) - (and (fboundp 'edebug-keywordp) (edebug-keywordp form))) - form) - - ;; This option may go away. - (edebug-stop-before-symbols - (edebug-make-before-and-after-form - (edebug-inc-offset (car offset)) - form - (edebug-inc-offset (cdr offset)) - )) - - (t ;; just a variable - (edebug-make-after-form form (edebug-inc-offset (cdr offset)))))) - - ;; Anything else is self-evaluating. - (t form)) - (edebug-move-cursor cursor)))) - - -(defsubst edebug-forms (cursor) (edebug-match cursor '(&rest form))) -(defsubst edebug-sexps (cursor) (edebug-match cursor '(&rest sexp))) - -(defsubst edebug-list-form-args (head cursor) - ;; Process the arguments of a list form given that head of form is a symbol. - ;; Helper for edebug-list-form - (let ((spec (get-edebug-spec head))) - (cond - (spec - (cond - ((consp spec) - ;; It is a speclist. - (let (edebug-best-error - edebug-error-point);; This may not be needed. - (edebug-match-sublist cursor spec))) - ((eq t spec) (edebug-forms cursor)) - ((eq 0 spec) (edebug-sexps cursor)) - ((symbolp spec) (funcall spec cursor));; Not used by edebug, - ; but leave it in for compatibility. - )) - ;; No edebug-form-spec provided. - ((edebug-macrop head) - (if edebug-eval-macro-args - (edebug-forms cursor) - (edebug-sexps cursor))) - (t ;; Otherwise it is a function call. - (edebug-forms cursor))))) - - -(defun edebug-list-form (cursor) - ;; Return an instrumented form built from the list form. - ;; The after offset will be left in the cursor after processing the form. - (let ((head (edebug-top-element-required cursor "Expected elements")) - ;; Prevent backtracking whenever instrumenting. - (edebug-gate t) - ;; A list form is never optional because it matches anything. - (edebug-&optional nil) - (edebug-&rest nil)) - ;; Skip the first offset. - (edebug-set-cursor cursor (edebug-cursor-expressions cursor) - (cdr (edebug-cursor-offsets cursor))) - (cond - ((null head) nil) ; () is legal. - - ((symbolp head) - (cond - ((null head) - (edebug-syntax-error "nil head")) - ((eq head 'interactive-p) - ;; Special case: replace (interactive-p) with variable - (setq edebug-def-interactive 'check-it) - (edebug-move-cursor cursor) - (edebug-interactive-p-name)) - (t - (cons head (edebug-list-form-args - head (edebug-move-cursor cursor)))))) - - ((consp head) - (if (and (listp head) (eq (car head) ',)) - (edebug-match cursor '(("," def-form) body)) - ;; Process anonymous function and args. - ;; This assumes no anonymous macros. - (edebug-match-specs cursor '(lambda-expr body) 'edebug-match-specs))) - - (t (edebug-syntax-error - "Head of list form must be a symbol or lambda expression."))) - )) - -;;; Matching of specs. - -(defvar edebug-after-dotted-spec nil) - -(defvar edebug-matching-depth 0) ;; initial value -(defconst edebug-max-depth 150) ;; maximum number of matching recursions. - - -;;; Failure to match - -;; This throws to no-match, if there are higher alternatives. -;; Otherwise it signals an error. The place of the error is found -;; with the two before- and after-offset functions. - -(defun edebug-no-match (cursor &rest edebug-args) - ;; Throw a no-match, or signal an error immediately if gate is active. - ;; Remember this point in case we need to report this error. - (setq edebug-error-point (or edebug-error-point - (edebug-before-offset cursor)) - edebug-best-error (or edebug-best-error edebug-args)) - (if (and edebug-gate (not edebug-&optional)) - (progn - (if edebug-error-point - (goto-char edebug-error-point)) - (apply 'edebug-syntax-error edebug-args)) - (funcall 'throw 'no-match edebug-args))) - - -(defun edebug-match (cursor specs) - ;; Top level spec matching function. - ;; Used also at each lower level of specs. - (let (edebug-&optional - edebug-&rest - edebug-best-error - edebug-error-point - (edebug-gate edebug-gate) ;; locally bound to limit effect - ) - (edebug-match-specs cursor specs 'edebug-match-specs))) - - -(defun edebug-match-one-spec (cursor spec) - ;; Match one spec, which is not a keyword &-spec. - (cond - ((symbolp spec) (edebug-match-symbol cursor spec)) - ((vectorp spec) (edebug-match cursor (append spec nil))) - ((stringp spec) (edebug-match-string cursor spec)) - ((listp spec) (edebug-match-list cursor spec)) - )) - - -(defun edebug-match-specs (cursor specs remainder-handler) - ;; Append results of matching the list of specs. - ;; The first spec is handled and the remainder-handler handles the rest. - (let ((edebug-matching-depth - (if (> edebug-matching-depth edebug-max-depth) - (error "too deep - perhaps infinite loop in spec?") - (1+ edebug-matching-depth)))) - (cond - ((null specs) nil) - - ;; Is the spec dotted? - ((atom specs) - (let ((edebug-dotted-spec t));; Containing spec list was dotted. - (edebug-match-specs cursor (list specs) remainder-handler))) - - ;; Is the form dotted? - ((not (listp (edebug-cursor-expressions cursor)));; allow nil - (if (not edebug-dotted-spec) - (edebug-no-match cursor "Dotted spec required.")) - ;; Cancel dotted spec and dotted form. - (let ((edebug-dotted-spec) - (this-form (edebug-cursor-expressions cursor)) - (this-offset (edebug-cursor-offsets cursor))) - ;; Wrap the form in a list, (by changing the cursor??)... - (edebug-set-cursor cursor (list this-form) this-offset) - ;; and process normally, then unwrap the result. - (car (edebug-match-specs cursor specs remainder-handler)))) - - (t;; Process normally. - (let* ((spec (car specs)) - (rest) - (first-char (and (symbolp spec) (aref (symbol-name spec) 0)))) - ;;(message "spec = %s first char = %s" spec first-char) (sit-for 1) - (nconc - (cond - ((eq ?& first-char);; "&" symbols take all following specs. - (funcall (get-edebug-spec spec) cursor (cdr specs))) - ((eq ?: first-char);; ":" symbols take one following spec. - (setq rest (cdr (cdr specs))) - (funcall (get-edebug-spec spec) cursor (car (cdr specs)))) - (t;; Any other normal spec. - (setq rest (cdr specs)) - (edebug-match-one-spec cursor spec))) - (funcall remainder-handler cursor rest remainder-handler))))))) - - -;; Define specs for all the symbol specs with functions used to process them. -;; Perhaps we shouldn't be doing this with edebug-form-specs since the -;; user may want to define macros or functions with the same names. -;; We could use an internal obarray for these primitive specs. - -(mapcar - (function (lambda (pair) - (put (car pair) 'edebug-form-spec (cdr pair)))) - '((&optional . edebug-match-&optional) - (&rest . edebug-match-&rest) - (&or . edebug-match-&or) - (form . edebug-match-form) - (sexp . edebug-match-sexp) - (body . edebug-match-body) - (&define . edebug-match-&define) - (name . edebug-match-name) - (:name . edebug-match-colon-name) - (arg . edebug-match-arg) - (def-body . edebug-match-def-body) - (def-form . edebug-match-def-form) - ;; Less frequently used: - ;; (function . edebug-match-function) - (lambda-expr . edebug-match-lambda-expr) - (¬ . edebug-match-¬) - (&key . edebug-match-&key) - (place . edebug-match-place) - (gate . edebug-match-gate) - ;; (nil . edebug-match-nil) not this one - special case it. - )) - -(defun edebug-match-symbol (cursor symbol) - ;; Match a symbol spec. - (let* ((spec (get-edebug-spec symbol))) - (cond - (spec - (if (consp spec) - ;; It is an indirect spec. - (edebug-match cursor spec) - ;; Otherwise it should be the symbol name of a function. - ;; There could be a bug here - maybe need to do edebug-match bindings. - (funcall spec cursor))) - - ((null symbol) ;; special case this. - (edebug-match-nil cursor)) - - ((fboundp symbol) ; is it a predicate? - (let ((sexp (edebug-top-element-required cursor "Expected" symbol))) - ;; Special case for edebug-`. - (if (and (listp sexp) (eq (car sexp) ',)) - (edebug-match cursor '(("," def-form))) - (if (not (funcall symbol sexp)) - (edebug-no-match cursor symbol "failed")) - (edebug-move-cursor cursor) - (list sexp)))) - (t (error "%s is not a form-spec or function" symbol)) - ))) - - -(defun edebug-match-sexp (cursor) - (list (prog1 (edebug-top-element-required cursor "Expected sexp") - (edebug-move-cursor cursor)))) - -(defun edebug-match-form (cursor) - (list (edebug-form cursor))) - -(defalias 'edebug-match-place 'edebug-match-form) - ;; Currently identical to edebug-match-form. - ;; This is for common lisp setf-style place arguments. - -(defsubst edebug-match-body (cursor) (edebug-forms cursor)) - -(defun edebug-match-&optional (cursor specs) - ;; Keep matching until one spec fails. - (edebug-&optional-wrapper cursor specs 'edebug-&optional-wrapper)) - -(defun edebug-&optional-wrapper (cursor specs remainder-handler) - (let (result - (edebug-&optional specs) - (edebug-gate nil) - (this-form (edebug-cursor-expressions cursor)) - (this-offset (edebug-cursor-offsets cursor))) - (if (null (catch 'no-match - (setq result - (edebug-match-specs cursor specs remainder-handler)) - ;; Returning nil means no no-match was thrown. - nil)) - result - ;; no-match, but don't fail; just reset cursor and return nil. - (edebug-set-cursor cursor this-form this-offset) - nil))) - - -(defun edebug-&rest-wrapper (cursor specs remainder-handler) - (if (null specs) (setq specs edebug-&rest)) - ;; Reuse the &optional handler with this as the remainder handler. - (edebug-&optional-wrapper cursor specs remainder-handler)) - -(defun edebug-match-&rest (cursor specs) - ;; Repeatedly use specs until failure. - (let ((edebug-&rest specs) ;; remember these - edebug-best-error - edebug-error-point) - (edebug-&rest-wrapper cursor specs 'edebug-&rest-wrapper))) - - -(defun edebug-match-&or (cursor specs) - ;; Keep matching until one spec succeeds, and return its results. - ;; If none match, fail. - ;; This needs to be optimized since most specs spend time here. - (let ((original-specs specs) - (this-form (edebug-cursor-expressions cursor)) - (this-offset (edebug-cursor-offsets cursor))) - (catch 'matched - (while specs - (catch 'no-match - (throw 'matched - (let (edebug-gate ;; only while matching each spec - edebug-best-error - edebug-error-point) - ;; Doesn't support e.g. &or symbolp &rest form - (edebug-match-one-spec cursor (car specs))))) - ;; Match failed, so reset and try again. - (setq specs (cdr specs)) - ;; Reset the cursor for the next match. - (edebug-set-cursor cursor this-form this-offset)) - ;; All failed. - (apply 'edebug-no-match cursor "Expected one of" original-specs)) - )) - - -(defun edebug-match-¬ (cursor specs) - ;; If any specs match, then fail - (if (null (catch 'no-match - (let ((edebug-gate nil)) - (save-excursion - (edebug-match-&or cursor specs))) - nil)) - ;; This means something matched, so it is a no match. - (edebug-no-match cursor "Unexpected")) - ;; This means nothing matched, so it is OK. - nil) ;; So, return nothing - - -(def-edebug-spec &key edebug-match-&key) - -(defun edebug-match-&key (cursor specs) - ;; Following specs must look like (<name> <spec>) ... - ;; where <name> is the name of a keyword, and spec is its spec. - ;; This really doesn't save much over the expanded form and takes time. - (edebug-match-&rest - cursor - (cons '&or - (mapcar (function (lambda (pair) - (vector (format ":%s" (car pair)) - (car (cdr pair))))) - specs)))) - - -(defun edebug-match-gate (cursor) - ;; Simply set the gate to prevent backtracking at this level. - (setq edebug-gate t) - nil) - - -(defun edebug-match-list (cursor specs) - ;; The spec is a list, but what kind of list, and what context? - (if edebug-dotted-spec - ;; After dotted spec but form did not contain dot, - ;; so match list spec elements as if spliced in. - (prog1 - (let ((edebug-dotted-spec)) - (edebug-match-specs cursor specs 'edebug-match-specs)) - ;; If it matched, really clear the dotted-spec flag. - (setq edebug-dotted-spec nil)) - (let ((spec (car specs)) - (form (edebug-top-element-required cursor "Expected" specs))) - (cond - ((eq 'quote spec) - (let ((spec (car (cdr specs)))) - (cond - ((symbolp spec) - ;; Special case: spec quotes a symbol to match. - ;; Change in future. Use "..." instead. - (if (not (eq spec form)) - (edebug-no-match cursor "Expected" spec)) - (edebug-move-cursor cursor) - (setq edebug-gate t) - form) - (t - (error "Bad spec: %s" specs))))) - - ((listp form) - (prog1 - (list (edebug-match-sublist - ;; First offset is for the list form itself. - ;; Treat nil as empty list. - (edebug-new-cursor form (cdr (edebug-top-offset cursor))) - specs)) - (edebug-move-cursor cursor))) - - ((and (eq 'vector spec) (vectorp form)) - ;; Special case: match a vector with the specs. - (let ((result (edebug-match-sublist - (edebug-new-cursor - form (cdr (edebug-top-offset cursor))) - (cdr specs)))) - (edebug-move-cursor cursor) - (list (apply 'vector result)))) - - (t (edebug-no-match cursor "Expected" specs))) - ))) - - -(defun edebug-match-sublist (cursor specs) - ;; Match a sublist of specs. - (let (edebug-&optional - ;;edebug-best-error - ;;edebug-error-point - ) - (prog1 - ;; match with edebug-match-specs so edebug-best-error is not bound. - (edebug-match-specs cursor specs 'edebug-match-specs) - (if (not (edebug-empty-cursor cursor)) - (if edebug-best-error - (apply 'edebug-no-match cursor edebug-best-error) - ;; A failed &rest or &optional spec may leave some args. - (edebug-no-match cursor "Failed matching" specs) - ))))) - - -(defun edebug-match-string (cursor spec) - (let ((sexp (edebug-top-element-required cursor "Expected" spec))) - (if (not (eq (intern spec) sexp)) - (edebug-no-match cursor "Expected" spec) - ;; Since it matched, failure means immediate error, unless &optional. - (setq edebug-gate t) - (edebug-move-cursor cursor) - (list sexp) - ))) - -(defun edebug-match-nil (cursor) - ;; There must be nothing left to match a nil. - (if (not (edebug-empty-cursor cursor)) - (edebug-no-match cursor "Unmatched argument(s)") - nil)) - - -(defun edebug-match-function (cursor) - (error "Use function-form instead of function in edebug spec")) - -(defun edebug-match-&define (cursor specs) - ;; Match a defining form. - ;; Normally, &define is interpreted specially other places. - ;; This should only be called inside of a spec list to match the remainder - ;; of the current list. e.g. ("lambda" &define args def-body) - (edebug-make-form-wrapper - cursor - (edebug-before-offset cursor) - ;; Find the last offset in the list. - (let ((offsets (edebug-cursor-offsets cursor))) - (while (consp offsets) (setq offsets (cdr offsets))) - offsets) - specs)) - -(defun edebug-match-lambda-expr (cursor) - ;; The expression must be a function. - ;; This will match any list form that begins with a symbol - ;; that has an edebug-form-spec beginning with &define. In - ;; practice, only lambda expressions should be used. - ;; I could add a &lambda specification to avoid confusion. - (let* ((sexp (edebug-top-element-required - cursor "Expected lambda expression")) - (offset (edebug-top-offset cursor)) - (head (and (consp sexp) (car sexp))) - (spec (and (symbolp head) (get-edebug-spec head))) - (edebug-inside-func nil)) - ;; Find out if this is a defining form from first symbol. - (if (and (consp spec) (eq '&define (car spec))) - (prog1 - (list - (edebug-defining-form - (edebug-new-cursor sexp offset) - (car offset);; before the sexp - (edebug-after-offset cursor) - (cons (symbol-name head) (cdr spec)))) - (edebug-move-cursor cursor)) - (edebug-no-match cursor "Expected lambda expression") - ))) - - -(defun edebug-match-name (cursor) - ;; Set the edebug-def-name bound in edebug-defining-form. - (let ((name (edebug-top-element-required cursor "Expected name"))) - ;; Maybe strings and numbers could be used. - (if (not (symbolp name)) - (edebug-no-match cursor "Symbol expected for name of definition")) - (setq edebug-def-name - (if edebug-def-name - ;; Construct a new name by appending to previous name. - (intern (format "%s@%s" edebug-def-name name)) - name)) - (edebug-move-cursor cursor) - (list name))) - -(defun edebug-match-colon-name (cursor spec) - ;; Set the edebug-def-name to the spec. - (setq edebug-def-name - (if edebug-def-name - ;; Construct a new name by appending to previous name. - (intern (format "%s@%s" edebug-def-name spec)) - spec)) - nil) - -(defun edebug-match-arg (cursor) - ;; set the def-args bound in edebug-defining-form - (let ((edebug-arg (edebug-top-element-required cursor "Expected arg"))) - (if (or (not (symbolp edebug-arg)) - (edebug-lambda-list-keywordp edebug-arg)) - (edebug-no-match cursor "Bad argument:" edebug-arg)) - (edebug-move-cursor cursor) - (setq edebug-def-args (cons edebug-arg edebug-def-args)) - (list edebug-arg))) - -(defun edebug-match-def-form (cursor) - ;; Like form but the form is wrapped in edebug-enter form. - ;; The form is assumed to be executing outside of the function context. - ;; This is a hack for now, since a def-form might execute inside as well. - ;; Not to be used otherwise. - (let ((edebug-inside-func nil)) - (list (edebug-make-enter-wrapper (list (edebug-form cursor)))))) - -(defun edebug-match-def-body (cursor) - ;; Like body but body is wrapped in edebug-enter form. - ;; The body is assumed to be executing inside of the function context. - ;; Not to be used otherwise. - (let ((edebug-inside-func t)) - (list (edebug-wrap-def-body (edebug-forms cursor))))) - - -;;;; Edebug Form Specs -;;; ========================================================== -;;; See cl-specs.el for common lisp specs. - -;;;;* Spec for def-edebug-spec -;;; Out of date. - -(defun edebug-spec-p (object) - "Return non-nil if OBJECT is a symbol with an edebug-form-spec property." - (and (symbolp object) - (get object 'edebug-form-spec))) - -(def-edebug-spec def-edebug-spec - ;; Top level is different from lower levels. - (&define :name edebug-spec name - &or "nil" edebug-spec-p "t" "0" (&rest edebug-spec))) - -(def-edebug-spec edebug-spec-list - ;; A list must have something in it, or it is nil, a symbolp - ((edebug-spec . [&or nil edebug-spec]))) - -(def-edebug-spec edebug-spec - (&or - (vector &rest edebug-spec) ; matches a vector - ("vector" &rest edebug-spec) ; matches a vector spec - ("quote" symbolp) - edebug-spec-list - stringp - [edebug-lambda-list-keywordp &rest edebug-spec] - ;; [edebug-keywordp gate edebug-spec] ;; need edebug-keywordp for this. - edebug-spec-p ;; Including all the special ones e.g. form. - symbolp;; a predicate - )) - - -;;;* Emacs special forms and some functions. - -;; quote expects only one argument, although it allows any number. -(def-edebug-spec quote sexp) - -;; The standard defining forms. -(def-edebug-spec defconst defvar) -(def-edebug-spec defvar (symbolp &optional form stringp)) - -(def-edebug-spec defun - (&define name lambda-list - [&optional stringp] - [&optional ("interactive" interactive)] - def-body)) -(def-edebug-spec defmacro - (&define name lambda-list def-body)) - -(def-edebug-spec arglist lambda-list) ;; deprecated - use lambda-list. - -(def-edebug-spec lambda-list - (([&rest arg] - [&optional ["&optional" arg &rest arg]] - &optional ["&rest" arg] - ))) - -(def-edebug-spec interactive - (&optional &or stringp def-form)) - -;; A function-form is for an argument that may be a function or a form. -;; This specially recognizes anonymous functions quoted with quote. -(def-edebug-spec function-form - ;; form at the end could also handle "function", - ;; but recognize it specially to avoid wrapping function forms. - (&or ([&or "quote" "function"] &or symbolp lambda-expr) form)) - -;; function expects a symbol or a lambda or macro expression -;; A macro is allowed by Emacs. -(def-edebug-spec function (&or symbolp lambda-expr)) - -;; lambda is a macro in emacs 19. -(def-edebug-spec lambda (&define lambda-list - [&optional stringp] - [&optional ("interactive" interactive)] - def-body)) - -;; A macro expression is a lambda expression with "macro" prepended. -(def-edebug-spec macro (&define "lambda" lambda-list def-body)) - -;; (def-edebug-spec anonymous-form ((&or ["lambda" lambda] ["macro" macro]))) - -;; Standard functions that take function-forms arguments. -(def-edebug-spec mapcar (function-form form)) -(def-edebug-spec mapconcat (function-form form form)) -(def-edebug-spec mapatoms (function-form &optional form)) -(def-edebug-spec apply (function-form &rest form)) -(def-edebug-spec funcall (function-form &rest form)) - -(def-edebug-spec let - ((&rest &or (symbolp &optional form) symbolp) - body)) - -(def-edebug-spec let* let) - -(def-edebug-spec setq (&rest symbolp form)) -(def-edebug-spec setq-default setq) - -(def-edebug-spec cond (&rest (&rest form))) - -(def-edebug-spec condition-case - (symbolp - form - &rest (symbolp body))) - - -(def-edebug-spec \` (backquote-form)) - -;; Supports quotes inside backquotes, -;; but only at the top level inside unquotes. -(def-edebug-spec backquote-form - (&or - ([&or "," ",@"] &or ("quote" backquote-form) form) - (backquote-form &rest backquote-form) - ;; If you use dotted forms in backquotes, replace the previous line - ;; with the following. This takes quite a bit more stack space, however. - ;; (backquote-form . [&or nil backquote-form]) - (vector &rest backquote-form) - sexp)) - -;; Special version of backquote that instruments backquoted forms -;; destined to be evaluated, usually as the result of a -;; macroexpansion. Backquoted code can only have unquotes (, and ,@) -;; in places where list forms are allowed, and predicates. If the -;; backquote is used in a macro, unquoted code that come from -;; arguments must be instrumented, if at all, with def-form not def-body. - -;; We could assume that all forms (not nested in other forms) -;; in arguments of macros should be def-forms, whether or not the macros -;; are defined with edebug-` but this would be expensive. - -;; ,@ might have some problems. - -(defalias 'edebug-\` '\`) ;; same macro as regular backquote. -(def-edebug-spec edebug-\` (def-form)) - -;; Assume immediate quote in unquotes mean backquote at next higher level. -(def-edebug-spec , (&or ("quote" edebug-`) def-form)) -(def-edebug-spec ,@ (&define ;; so (,@ form) is never wrapped. - &or ("quote" edebug-`) def-form)) - -;; New byte compiler. -(def-edebug-spec defsubst defun) -(def-edebug-spec dont-compile t) -(def-edebug-spec eval-when-compile t) -(def-edebug-spec eval-and-compile t) - -(def-edebug-spec save-selected-window t) -(def-edebug-spec save-current-buffer t) -(def-edebug-spec save-match-data t) -(def-edebug-spec with-output-to-string t) -(def-edebug-spec with-current-buffer t) -(def-edebug-spec with-temp-file t) -(def-edebug-spec with-temp-buffer t) - -;; Anything else? - - -;; Some miscellaneous specs for macros in public packages. -;; Send me yours. - -;; advice.el by Hans Chalupsky (hans@cs.buffalo.edu) - -(def-edebug-spec ad-dolist ((symbolp form &optional form) body)) -(def-edebug-spec defadvice - (&define name ;; thing being advised. - (name ;; class is [&or "before" "around" "after" - ;; "activation" "deactivation"] - name ;; name of advice - &rest sexp ;; optional position and flags - ) - [&optional stringp] - [&optional ("interactive" interactive)] - def-body)) - -;;; The debugger itself - -(defvar edebug-active nil) ;; Non-nil when edebug is active - -;;; add minor-mode-alist entry -(or (assq 'edebug-active minor-mode-alist) - (setq minor-mode-alist (cons (list 'edebug-active " *Debugging*") - minor-mode-alist))) - -(defvar edebug-stack nil) -;; Stack of active functions evaluated via edebug. -;; Should be nil at the top level. - -(defvar edebug-stack-depth -1) -;; Index of last edebug-stack item. - -(defvar edebug-offset-indices nil) -;; Stack of offset indices of visited edebug sexps. -;; Should be nil at the top level. -;; Each function adds one cons. Top is modified with setcar. - - -(defvar edebug-entered nil - ;; Non-nil if edebug has already been entered at this recursive edit level. - ;; This should stay nil at the top level. - ) - -;; Should these be options? -(defconst edebug-debugger 'edebug - ;; Name of function to use for debugging when error or quit occurs. - ;; Set this to 'debug if you want to debug edebug. - ) - - -;; Dynamically bound variables, declared globally but left unbound. -(defvar edebug-function) ; the function being executed. change name!! -(defvar edebug-args) ; the arguments of the function -(defvar edebug-data) ; the edebug data for the function -(defvar edebug-value) ; the result of the expression -(defvar edebug-after-index) -(defvar edebug-def-mark) ; the mark for the definition -(defvar edebug-freq-count) ; the count of expression visits. -(defvar edebug-coverage) ; the coverage results of each expression of function. - -(defvar edebug-buffer) ; which buffer the function is in. -(defvar edebug-result) ; the result of the function call returned by body -(defvar edebug-outside-executing-macro) -(defvar edebug-outside-defining-kbd-macro) - -(defvar edebug-execution-mode 'step) ; Current edebug mode set by user. -(defvar edebug-next-execution-mode nil) ; Use once instead of initial mode. - -(defvar edebug-outside-debug-on-error) ; the value of debug-on-error outside -(defvar edebug-outside-debug-on-quit) ; the value of debug-on-quit outside - -(defvar edebug-outside-pre-command-hook) -(defvar edebug-outside-post-command-hook) -(defvar edebug-outside-post-command-idle-hook) - -;; Emacs 19 -(defvar pre-command-hook nil) -(defvar post-command-hook nil) -(defvar post-command-idle-hook nil) - -(defvar cl-lexical-debug) ;; Defined in cl.el - -;;; Handling signals - -(if (not (fboundp 'edebug-original-signal)) - (defalias 'edebug-original-signal (symbol-function 'signal))) -;; We should use advise for this!! - -(defun edebug-signal (edebug-signal-name edebug-signal-data) - "Signal an error. Args are SIGNAL-NAME, and associated DATA. -A signal name is a symbol with an `error-conditions' property -that is a list of condition names. -A handler for any of those names will get to handle this signal. -The symbol `error' should always be one of them. - -DATA should be a list. Its elements are printed as part of the error message. -If the signal is handled, DATA is made available to the handler. -See `condition-case'. - -This is the Edebug replacement for the standard `signal'. It should -only be active while Edebug is. It checks `debug-on-error' to see -whether it should call the debugger. When execution is resumed, the -error is signaled again." - (if (and (listp debug-on-error) (memq edebug-signal-name debug-on-error)) - (edebug 'error (cons edebug-signal-name edebug-signal-data))) - ;; If we reach here without another non-local exit, then send signal again. - ;; i.e. the signal is not continuable, yet. - (edebug-original-signal edebug-signal-name edebug-signal-data)) - - -;;; Entering Edebug - -(defun edebug-enter (edebug-function edebug-args edebug-body) - ;; Entering FUNC. The arguments are ARGS, and the body is BODY. - ;; Setup edebug variables and evaluate BODY. This function is called - ;; when a function evaluated with edebug-eval-top-level-form is entered. - ;; Return the result of BODY. - - ;; Is this the first time we are entering edebug since - ;; lower-level recursive-edit command? - ;; More precisely, this tests whether Edebug is currently active. - (if (not edebug-entered) - (let ((edebug-entered t) - ;; Binding max-lisp-eval-depth here is OK, - ;; but not inside an unwind-protect. - ;; Doing it here also keeps it from growing too large. - (max-lisp-eval-depth (+ 100 max-lisp-eval-depth)) ; too much?? - (max-specpdl-size (+ 200 max-specpdl-size)) - - (debugger edebug-debugger) ; only while edebug is active. - (edebug-outside-debug-on-error debug-on-error) - (edebug-outside-debug-on-quit debug-on-quit) - ;; Binding these may not be the right thing to do. - ;; We want to allow the global values to be changed. - (debug-on-error (or debug-on-error edebug-on-error)) - (debug-on-quit edebug-on-quit) - - ;; Lexical bindings must be uncompiled for this to work. - (cl-lexical-debug t) - - ;; Save the outside value of executing macro. (here??) - (edebug-outside-executing-macro executing-kbd-macro) - (edebug-outside-pre-command-hook pre-command-hook) - (edebug-outside-post-command-hook post-command-hook) - (edebug-outside-post-command-idle-hook post-command-idle-hook)) - (unwind-protect - (let (;; Don't keep reading from an executing kbd macro - ;; within edebug unless edebug-continue-kbd-macro is - ;; non-nil. Again, local binding may not be best. - (executing-kbd-macro - (if edebug-continue-kbd-macro executing-kbd-macro)) - - ;; Disable command hooks. This is essential when - ;; a hook function is instrumented - to avoid infinite loop. - ;; This may be more than we need, however. - (pre-command-hook nil) - (post-command-hook nil) - (post-command-idle-hook nil)) - (setq edebug-execution-mode (or edebug-next-execution-mode - edebug-initial-mode - edebug-execution-mode) - edebug-next-execution-mode nil) - ;; Bind signal to edebug-signal only while Edebug is active. - (fset 'signal 'edebug-signal) - (unwind-protect - (edebug-enter edebug-function edebug-args edebug-body) - (fset 'signal (symbol-function 'edebug-original-signal)))) - ;; Reset global variables in case outside value was changed. - (setq executing-kbd-macro edebug-outside-executing-macro - pre-command-hook edebug-outside-pre-command-hook - post-command-hook edebug-outside-post-command-hook - post-command-idle-hook edebug-outside-post-command-idle-hook - ))) - - (let* ((edebug-data (get edebug-function 'edebug)) - (edebug-def-mark (car edebug-data)) ; mark at def start - (edebug-freq-count (get edebug-function 'edebug-freq-count)) - (edebug-coverage (get edebug-function 'edebug-coverage)) - (edebug-buffer (marker-buffer edebug-def-mark)) - - (edebug-stack (cons edebug-function edebug-stack)) - (edebug-offset-indices (cons 0 edebug-offset-indices)) - ) - (if (get edebug-function 'edebug-on-entry) - (progn - (setq edebug-execution-mode 'step) - (if (eq (get edebug-function 'edebug-on-entry) 'temp) - (put edebug-function 'edebug-on-entry nil)))) - (if edebug-trace - (edebug-enter-trace edebug-body) - (funcall edebug-body)) - ))) - - -(defun edebug-enter-trace (edebug-body) - (let ((edebug-stack-depth (1+ edebug-stack-depth)) - edebug-result) - (edebug-print-trace-before - (format "%s args: %s" edebug-function edebug-args)) - (prog1 (setq edebug-result (funcall edebug-body)) - (edebug-print-trace-after - (format "%s result: %s" edebug-function edebug-result))))) - -(def-edebug-spec edebug-tracing (form body)) - -(defmacro edebug-tracing (msg &rest body) - "Print MSG in *edebug-trace* before and after evaluating BODY. -The result of BODY is also printed." - (` (let ((edebug-stack-depth (1+ edebug-stack-depth)) - edebug-result) - (edebug-print-trace-before (, msg)) - (prog1 (setq edebug-result (progn (,@ body))) - (edebug-print-trace-after - (format "%s result: %s" (, msg) edebug-result)))))) - -(defun edebug-print-trace-before (msg) - "Function called to print trace info before expression evaluation. -MSG is printed after `::::{ '." - (edebug-trace-display - edebug-trace-buffer "%s{ %s" (make-string edebug-stack-depth ?\:) msg)) - -(defun edebug-print-trace-after (msg) - "Function called to print trace info after expression evaluation. -MSG is printed after `::::} '." - (edebug-trace-display - edebug-trace-buffer "%s} %s" (make-string edebug-stack-depth ?\:) msg)) - - - -(defun edebug-slow-before (edebug-before-index) - ;; Debug current function given BEFORE position. - ;; Called from functions compiled with edebug-eval-top-level-form. - ;; Return the before index. - (setcar edebug-offset-indices edebug-before-index) - - ;; Increment frequency count - (aset edebug-freq-count edebug-before-index - (1+ (aref edebug-freq-count edebug-before-index))) - - (if (or (not (memq edebug-execution-mode '(Go-nonstop next))) - (edebug-input-pending-p)) - (edebug-debugger edebug-before-index 'before nil)) - edebug-before-index) - -(defun edebug-fast-before (edebug-before-index) - ;; Do nothing. - ) - -(defun edebug-slow-after (edebug-before-index edebug-after-index edebug-value) - ;; Debug current function given AFTER position and VALUE. - ;; Called from functions compiled with edebug-eval-top-level-form. - ;; Return VALUE. - (setcar edebug-offset-indices edebug-after-index) - - ;; Increment frequency count - (aset edebug-freq-count edebug-after-index - (1+ (aref edebug-freq-count edebug-after-index))) - (if edebug-test-coverage (edebug-update-coverage)) - - (if (and (eq edebug-execution-mode 'Go-nonstop) - (not (edebug-input-pending-p))) - ;; Just return result. - edebug-value - (edebug-debugger edebug-after-index 'after edebug-value) - )) - -(defun edebug-fast-after (edebug-before-index edebug-after-index edebug-value) - ;; Do nothing but return the value. - edebug-value) - -(defun edebug-run-slow () - (defalias 'edebug-before 'edebug-slow-before) - (defalias 'edebug-after 'edebug-slow-after)) - -;; This is not used, yet. -(defun edebug-run-fast () - (defalias 'edebug-before 'edebug-fast-before) - (defalias 'edebug-after 'edebug-fast-after)) - -(edebug-run-slow) - - -(defun edebug-update-coverage () - (let ((old-result (aref edebug-coverage edebug-after-index))) - (cond - ((eq 'ok-coverage old-result)) - ((eq 'unknown old-result) - (aset edebug-coverage edebug-after-index edebug-value)) - ;; Test if a different result. - ((not (eq edebug-value old-result)) - (aset edebug-coverage edebug-after-index 'ok-coverage))))) - - -;; Dynamically declared unbound variables. -(defvar edebug-arg-mode) ; the mode, either before, after, or error -(defvar edebug-breakpoints) -(defvar edebug-break-data) ; break data for current function. -(defvar edebug-break) ; whether a break occurred. -(defvar edebug-global-break) ; whether a global break occurred. -(defvar edebug-break-condition) ; whether the breakpoint is conditional. - -(defvar edebug-break-result nil) -(defvar edebug-global-break-result nil) - - -(defun edebug-debugger (edebug-offset-index edebug-arg-mode edebug-value) - ;; Check breakpoints and pending input. - ;; If edebug display should be updated, call edebug-display. - ;; Return edebug-value. - (let* (;; This needs to be here since breakpoints may be changed. - (edebug-breakpoints (car (cdr edebug-data))) ; list of breakpoints - (edebug-break-data (assq edebug-offset-index edebug-breakpoints)) - (edebug-break-condition (car (cdr edebug-break-data))) - (edebug-global-break - (if edebug-global-break-condition - (condition-case nil - (setq edebug-global-break-result - (eval edebug-global-break-condition)) - (error nil)))) - (edebug-break)) - -;;; (edebug-trace "exp: %s" edebug-value) - ;; Test whether we should break. - (setq edebug-break - (or edebug-global-break - (and edebug-break-data - (or (not edebug-break-condition) - (setq edebug-break-result - (eval edebug-break-condition)))))) - (if (and edebug-break - (nth 2 edebug-break-data)) ; is it temporary? - ;; Delete the breakpoint. - (setcdr edebug-data - (cons (delq edebug-break-data edebug-breakpoints) - (cdr (cdr edebug-data))))) - - ;; Display if mode is not go, continue, or Continue-fast - ;; or break, or input is pending, - (if (or (not (memq edebug-execution-mode '(go continue Continue-fast))) - edebug-break - (edebug-input-pending-p)) - (edebug-display)) ; <--------------- display - - edebug-value - )) - - -;; window-start now stored with each function. -;;(defvar edebug-window-start nil) -;; Remember where each buffers' window starts between edebug calls. -;; This is to avoid spurious recentering. -;; Does this still need to be buffer-local?? -;;(setq-default edebug-window-start nil) -;;(make-variable-buffer-local 'edebug-window-start) - - -;; Dynamically declared unbound vars -(defvar edebug-point) ; the point in edebug buffer -(defvar edebug-outside-buffer) ; the current-buffer outside of edebug -(defvar edebug-outside-point) ; the point outside of edebug -(defvar edebug-outside-mark) ; the mark outside of edebug -(defvar edebug-window-data) ; window and window-start for current function -(defvar edebug-outside-windows) ; outside window configuration -(defvar edebug-eval-buffer) ; for the evaluation list. -(defvar edebug-outside-o-a-p) ; outside overlay-arrow-position -(defvar edebug-outside-o-a-s) ; outside overlay-arrow-string -(defvar edebug-outside-c-i-e-a) ; outside cursor-in-echo-area - -(defvar edebug-eval-list nil) ;; List of expressions to evaluate. - -(defvar edebug-previous-result nil) ;; Last result returned. - -;; Emacs 19 adds an arg to mark and mark-marker. -(defalias 'edebug-mark 'mark) -(defalias 'edebug-mark-marker 'mark-marker) - - -(defun edebug-display () - ;; Setup windows for edebug, determine mode, maybe enter recursive-edit. - ;; Uses local variables of edebug-enter, edebug-before, edebug-after - ;; and edebug-debugger. - (let ((edebug-active t) ; for minor mode alist - edebug-stop ; should we enter recursive-edit - (edebug-point (+ edebug-def-mark - (aref (nth 2 edebug-data) edebug-offset-index))) - edebug-buffer-outside-point ; current point in edebug-buffer - ;; window displaying edebug-buffer - (edebug-window-data (nth 3 edebug-data)) - (edebug-outside-window (selected-window)) - (edebug-outside-buffer (current-buffer)) - (edebug-outside-point (point)) - (edebug-outside-mark (edebug-mark)) - edebug-outside-windows ; window or screen configuration - edebug-buffer-points - - edebug-eval-buffer ; declared here so we can kill it below - (edebug-eval-result-list (and edebug-eval-list - (edebug-eval-result-list))) - edebug-trace-window - edebug-trace-window-start - - (edebug-outside-o-a-p overlay-arrow-position) - (edebug-outside-o-a-s overlay-arrow-string) - (edebug-outside-c-i-e-a cursor-in-echo-area)) - (unwind-protect - (let ((overlay-arrow-position overlay-arrow-position) - (overlay-arrow-string overlay-arrow-string) - (cursor-in-echo-area nil) - ;; any others?? - ) - (if (not (buffer-name edebug-buffer)) - (let ((debug-on-error nil)) - (error "Buffer defining %s not found" edebug-function))) - - (if (eq 'after edebug-arg-mode) - ;; Compute result string now before windows are modified. - (edebug-compute-previous-result edebug-value)) - - (if edebug-save-windows - ;; Save windows now before we modify them. - (setq edebug-outside-windows - (edebug-current-windows edebug-save-windows))) - - (if edebug-save-displayed-buffer-points - (setq edebug-buffer-points (edebug-get-displayed-buffer-points))) - - ;; First move the edebug buffer point to edebug-point - ;; so that window start doesn't get changed when we display it. - ;; I don't know if this is going to help. - ;;(set-buffer edebug-buffer) - ;;(goto-char edebug-point) - - ;; If edebug-buffer is not currently displayed, - ;; first find a window for it. - (edebug-pop-to-buffer edebug-buffer (car edebug-window-data)) - (setcar edebug-window-data (selected-window)) - - ;; Now display eval list, if any. - ;; This is done after the pop to edebug-buffer - ;; so that buffer-window correspondence is correct after quitting. - (edebug-eval-display edebug-eval-result-list) - ;; The evaluation list better not have deleted edebug-window-data. - (select-window (car edebug-window-data)) - (set-buffer edebug-buffer) - - (setq edebug-buffer-outside-point (point)) - (goto-char edebug-point) - - (if (eq 'before edebug-arg-mode) - ;; Check whether positions are up-to-date. - ;; This assumes point is never before symbol. - (if (not (memq (following-char) '(?\( ?\# ?\` ))) - (let ((debug-on-error nil)) - (error "Source has changed - reevaluate definition of %s" - edebug-function) - ))) - - (setcdr edebug-window-data - (edebug-adjust-window (cdr edebug-window-data))) - - ;; Test if there is input, not including keyboard macros. - (if (edebug-input-pending-p) - (progn - (setq edebug-execution-mode 'step - edebug-stop t) - (edebug-stop) - ;; (discard-input) ; is this unfriendly?? - )) - ;; Now display arrow based on mode. - (edebug-overlay-arrow) - - (cond - ((eq 'error edebug-arg-mode) - ;; Display error message - (setq edebug-execution-mode 'step) - (edebug-overlay-arrow) - (beep) - (if (eq 'quit (car edebug-value)) - (message "Quit") - (edebug-report-error edebug-value))) - (edebug-break - (cond - (edebug-global-break - (message "Global Break: %s => %s" - edebug-global-break-condition - edebug-global-break-result)) - (edebug-break-condition - (message "Break: %s => %s" - edebug-break-condition - edebug-break-result)) - ((not (eq edebug-execution-mode 'Continue-fast)) - (message "Break")) - (t))) - - (t (message ""))) - - (if (eq 'after edebug-arg-mode) - (progn - ;; Display result of previous evaluation. - (if (and edebug-break - (not (eq edebug-execution-mode 'Continue-fast))) - (sit-for 1)) ; Show break message. - (edebug-previous-result))) - - (cond - (edebug-break - (cond - ((eq edebug-execution-mode 'continue) (edebug-sit-for 1)) - ((eq edebug-execution-mode 'Continue-fast) (edebug-sit-for 0)) - (t (setq edebug-stop t)))) - ;; not edebug-break - ((eq edebug-execution-mode 'trace) - (edebug-sit-for 1)) ; Force update and pause. - ((eq edebug-execution-mode 'Trace-fast) - (edebug-sit-for 0)) ; Force update and continue. - ) - - (unwind-protect - (if (or edebug-stop - (memq edebug-execution-mode '(step next)) - (eq edebug-arg-mode 'error)) - (progn - ;; (setq edebug-execution-mode 'step) - ;; (edebug-overlay-arrow) ; this doesn't always show up. - (edebug-recursive-edit))) ; <---------- Recursive edit - - ;; Reset the edebug-window-data to whatever it is now. - (let ((window (if (eq (window-buffer) edebug-buffer) - (selected-window) - (edebug-get-buffer-window edebug-buffer)))) - ;; Remember window-start for edebug-buffer, if still displayed. - (if window - (progn - (setcar edebug-window-data window) - (setcdr edebug-window-data (window-start window))))) - - ;; Save trace window point before restoring outside windows. - ;; Could generalize this for other buffers. - (setq edebug-trace-window (get-buffer-window edebug-trace-buffer)) - (if edebug-trace-window - (setq edebug-trace-window-start - (and edebug-trace-window - (window-start edebug-trace-window)))) - - ;; Restore windows before continuing. - (if edebug-save-windows - (progn - (edebug-set-windows edebug-outside-windows) - - ;; Restore displayed buffer points. - ;; Needed even if restoring windows because - ;; window-points are not restored. (should they be??) - (if edebug-save-displayed-buffer-points - (edebug-set-buffer-points edebug-buffer-points)) - - ;; Unrestore trace window's window-point. - (if edebug-trace-window - (set-window-start edebug-trace-window - edebug-trace-window-start)) - - ;; Unrestore edebug-buffer's window-start, if displayed. - (let ((window (car edebug-window-data))) - (if (and window (edebug-window-live-p window) - (eq (window-buffer) edebug-buffer)) - (progn - (set-window-start window (cdr edebug-window-data) - 'no-force) - ;; Unrestore edebug-buffer's window-point. - ;; Needed in addition to setting the buffer point - ;; - otherwise quitting doesn't leave point as is. - ;; But this causes point to not be restored at times. - ;; Also, it may not be a visible window. - ;; (set-window-point window edebug-point) - ))) - - ;; Unrestore edebug-buffer's point. Rerestored below. - ;; (goto-char edebug-point) ;; in edebug-buffer - ) - ;; Since we may be in a save-excursion, in case of quit, - ;; reselect the outside window only. - ;; Only needed if we are not recovering windows?? - (if (edebug-window-live-p edebug-outside-window) - (select-window edebug-outside-window)) - ) ; if edebug-save-windows - - ;; Restore current buffer always, in case application needs it. - (set-buffer edebug-outside-buffer) - ;; Restore point, and mark. - ;; Needed even if restoring windows because - ;; that doesn't restore point and mark in the current buffer. - ;; But don't restore point if edebug-buffer is current buffer. - (if (not (eq edebug-buffer edebug-outside-buffer)) - (goto-char edebug-outside-point)) - (if (marker-buffer (edebug-mark-marker)) - ;; Does zmacs-regions need to be nil while doing set-marker? - (set-marker (edebug-mark-marker) edebug-outside-mark)) - ) ; unwind-protect - ;; None of the following is done if quit or signal occurs. - - ;; Restore edebug-buffer's outside point. - ;; (edebug-trace "restore edebug-buffer point: %s" - ;; edebug-buffer-outside-point) - (let ((current-buffer (current-buffer))) - (set-buffer edebug-buffer) - (goto-char edebug-buffer-outside-point) - (set-buffer current-buffer)) - ;; ... nothing more. - ) - ;; Reset global variables to outside values in case they were changed. - (setq - overlay-arrow-position edebug-outside-o-a-p - overlay-arrow-string edebug-outside-o-a-s - cursor-in-echo-area edebug-outside-c-i-e-a) - ))) - - -(defvar edebug-number-of-recursions 0) -;; Number of recursive edits started by edebug. -;; Should be 0 at the top level. - -(defvar edebug-recursion-depth 0) -;; Value of recursion-depth when edebug was called. - -;; Dynamically declared unbound vars -(defvar edebug-outside-match-data) ; match data outside of edebug -(defvar edebug-backtrace-buffer) ; each recursive edit gets its own -(defvar edebug-inside-windows) -(defvar edebug-interactive-p) - -(defvar edebug-outside-map) -(defvar edebug-outside-standard-output) -(defvar edebug-outside-standard-input) -(defvar edebug-outside-last-command-char) -(defvar edebug-outside-last-command) -(defvar edebug-outside-this-command) -(defvar edebug-outside-last-input-char) - -;; Note: here we have defvars for variables that are -;; built-in in certain versions. -;; Each defvar makes a difference -;; in versions where the variable is *not* built-in. - -;; Emacs 18 -(defvar edebug-outside-unread-command-char) - -;; XEmacs -(defvar edebug-outside-unread-command-event) ;; like unread-command-events -(defvar unread-command-event nil) - -;; Emacs 19. -(defvar edebug-outside-last-command-event) -(defvar edebug-outside-unread-command-events) -(defvar edebug-outside-last-input-event) -(defvar edebug-outside-last-event-frame) -(defvar edebug-outside-last-nonmenu-event) -(defvar edebug-outside-track-mouse) - -;; Disable byte compiler warnings about unread-command-char and -event -;; (maybe works with byte-compile-version 2.22 at least) -(defvar edebug-unread-command-char-warning) -(defvar edebug-unread-command-event-warning) -(eval-when-compile - (setq edebug-unread-command-char-warning - (get 'unread-command-char 'byte-obsolete-variable)) - (put 'unread-command-char 'byte-obsolete-variable nil) - (setq edebug-unread-command-event-warning - (get 'unread-command-event 'byte-obsolete-variable)) - (put 'unread-command-event 'byte-obsolete-variable nil)) - -(defun edebug-recursive-edit () - ;; Start up a recursive edit inside of edebug. - ;; The current buffer is the edebug-buffer, which is put into edebug-mode. - ;; Assume that none of the variables below are buffer-local. - (let ((edebug-buffer-read-only buffer-read-only) - ;; match-data must be done in the outside buffer - (edebug-outside-match-data - (save-excursion ; might be unnecessary now?? - (set-buffer edebug-outside-buffer) ; in case match buffer different - (match-data))) - - ;;(edebug-number-of-recursions (1+ edebug-number-of-recursions)) - (edebug-recursion-depth (recursion-depth)) - edebug-entered ; bind locally to nil - (edebug-interactive-p nil) ; again non-interactive - edebug-backtrace-buffer ; each recursive edit gets its own - ;; The window configuration may be saved and restored - ;; during a recursive-edit - edebug-inside-windows - - (edebug-outside-map (current-local-map)) - - (edebug-outside-standard-output standard-output) - (edebug-outside-standard-input standard-input) - (edebug-outside-defining-kbd-macro defining-kbd-macro) - - (edebug-outside-last-command-char last-command-char) - (edebug-outside-last-command last-command) - (edebug-outside-this-command this-command) - (edebug-outside-last-input-char last-input-char) - - ;; XEmacs: added the boundp checks - (edebug-outside-unread-command-char - (and (boundp 'unread-command-char) unread-command-char)) - - (edebug-outside-last-input-event - (and (boundp 'last-input-event) last-input-event)) - (edebug-outside-last-command-event - (and (boundp 'last-command-event) last-command-event)) - (edebug-outside-unread-command-event - (and (boundp 'unread-command-event) unread-command-event)) - (edebug-outside-unread-command-events - (and (boundp 'unread-command-events) unread-command-events)) - (edebug-outside-last-event-frame - (and (boundp 'last-event-frame) last-event-frame)) - (edebug-outside-last-nonmenu-event - (and (boundp 'last-nonmenu-event) last-nonmenu-event)) - (edebug-outside-track-mouse - (and (boundp 'track-mouse) track-mouse)) - ) - - (unwind-protect - (let ( - ;; Declare global values local but using the same global value. - ;; We could set these to the values for previous edebug call. - (last-command-char last-command-char) - (last-command last-command) - (this-command this-command) - (last-input-char last-input-char) - - ;; Assume no edebug command sets unread-command-char. - (unread-command-char -1) - - ;; More for Emacs 19 - (last-input-event nil) - (last-command-event nil) - (unread-command-event nil);; XEmacs - (unread-command-events nil) - (last-event-frame nil) - (last-nonmenu-event nil) - (track-mouse nil) - - ;; Bind again to outside values. - (debug-on-error edebug-outside-debug-on-error) - (debug-on-quit edebug-outside-debug-on-quit) - - ;; Don't keep defining a kbd macro. - (defining-kbd-macro - (if edebug-continue-kbd-macro defining-kbd-macro)) - - ;; others?? - ) - - (if (fboundp 'zmacs-deactivate-region);; for XEmacs - (zmacs-deactivate-region)) - (if (and (eq edebug-execution-mode 'go) - (not (memq edebug-arg-mode '(after error)))) - (message "Break")) - - (setq buffer-read-only t) - (fset 'signal (symbol-function 'edebug-original-signal)) - - (edebug-mode) - (unwind-protect - (recursive-edit) ; <<<<<<<<<< Recursive edit - - ;; Do the following, even if quit occurs. - (fset 'signal 'edebug-signal) - (if edebug-backtrace-buffer - (kill-buffer edebug-backtrace-buffer)) - ;; Could be an option to keep eval display up. - (if edebug-eval-buffer (kill-buffer edebug-eval-buffer)) - - ;; Remember selected-window after recursive-edit. - ;; (setq edebug-inside-window (selected-window)) - - (store-match-data edebug-outside-match-data) - - ;; Recursive edit may have changed buffers, - ;; so set it back before exiting let. - (if (buffer-name edebug-buffer) ; if it still exists - (progn - (set-buffer edebug-buffer) - (if (memq edebug-execution-mode '(go Go-nonstop)) - (edebug-overlay-arrow)) - (setq buffer-read-only edebug-buffer-read-only) - (use-local-map edebug-outside-map) - ) - ;; gotta have a buffer to let its buffer local variables be set - (get-buffer-create " bogus edebug buffer")) - ));; inner let - - ;; Reset global vars to outside values, in case they have been changed. - (setq - last-command-char edebug-outside-last-command-char - last-command-event edebug-outside-last-command-event - last-command edebug-outside-last-command - this-command edebug-outside-this-command - unread-command-char edebug-outside-unread-command-char - unread-command-event edebug-outside-unread-command-event - unread-command-events edebug-outside-unread-command-events - last-input-char edebug-outside-last-input-char - last-input-event edebug-outside-last-input-event - last-event-frame edebug-outside-last-event-frame - last-nonmenu-event edebug-outside-last-nonmenu-event - track-mouse edebug-outside-track-mouse - - standard-output edebug-outside-standard-output - standard-input edebug-outside-standard-input - defining-kbd-macro edebug-outside-defining-kbd-macro - )) - )) - - -;;; Display related functions - -(defun edebug-adjust-window (old-start) - ;; If pos is not visible, adjust current window to fit following context. -;;; (message "window: %s old-start: %s window-start: %s pos: %s" -;;; (selected-window) old-start (window-start) (point)) (sit-for 5) - (if (not (pos-visible-in-window-p)) - (progn - ;; First try old-start - (if old-start - (set-window-start (selected-window) old-start)) - (if (not (pos-visible-in-window-p)) - (progn -;; (message "resetting window start") (sit-for 2) - (set-window-start - (selected-window) - (save-excursion - (forward-line - (if (< (point) (window-start)) -1 ; one line before if in back - (- (/ (window-height) 2)) ; center the line moving forward - )) - (beginning-of-line) - (point))))))) - (window-start)) - - - -(defconst edebug-arrow-alist - '((Continue-fast . "=") - (Trace-fast . "-") - (continue . ">") - (trace . "->") - (step . "=>") - (next . "=>") - (go . "<>") - (Go-nonstop . "..") ; not used - ) - "Association list of arrows for each edebug mode.") - -(defun edebug-overlay-arrow () - ;; Set up the overlay arrow at beginning-of-line in current buffer. - ;; The arrow string is derived from edebug-arrow-alist and - ;; edebug-execution-mode. - (let ((pos (save-excursion (beginning-of-line) (point)))) - (setq overlay-arrow-string - (cdr (assq edebug-execution-mode edebug-arrow-alist))) - (setq overlay-arrow-position (make-marker)) - (set-marker overlay-arrow-position pos (current-buffer)))) - - -(defun edebug-toggle-save-all-windows () - "Toggle the saving and restoring of all windows. -Also, each time you toggle it on, the inside and outside window -configurations become the same as the current configuration." - (interactive) - (setq edebug-save-windows (not edebug-save-windows)) - (if edebug-save-windows - (setq edebug-inside-windows - (setq edebug-outside-windows - (edebug-current-windows - edebug-save-windows)))) - (message "Window saving is %s for all windows." - (if edebug-save-windows "on" "off"))) - -(defmacro edebug-changing-windows (&rest body) - (` (let ((window (selected-window))) - (setq edebug-inside-windows (edebug-current-windows t)) - (edebug-set-windows edebug-outside-windows) - (,@ body) ;; Code to change edebug-save-windows - (setq edebug-outside-windows (edebug-current-windows - edebug-save-windows)) - ;; Problem: what about outside windows that are deleted inside? - (edebug-set-windows edebug-inside-windows)))) - -(defun edebug-toggle-save-selected-window () - "Toggle the saving and restoring of the selected window. -Also, each time you toggle it on, the inside and outside window -configurations become the same as the current configuration." - (interactive) - (cond - ((eq t edebug-save-windows) - ;; Save all outside windows except the selected one. - ;; Remove (selected-window) from outside-windows. - (edebug-changing-windows - (setq edebug-save-windows (delq window (edebug-window-list))))) - - ((memq (selected-window) edebug-save-windows) - (setq edebug-outside-windows - (delq (assq (selected-window) edebug-outside-windows) - edebug-outside-windows)) - (setq edebug-save-windows - (delq (selected-window) edebug-save-windows))) - (t ; Save a new window. - (edebug-changing-windows - (setq edebug-save-windows (cons window edebug-save-windows))))) - - (message "Window saving is %s for %s." - (if (memq (selected-window) edebug-save-windows) - "on" "off") - (selected-window))) - -(defun edebug-toggle-save-windows (arg) - "Toggle the saving and restoring of windows. -With prefix, toggle for just the selected window. -Otherwise, toggle for all windows." - (interactive "P") - (if arg - (edebug-toggle-save-selected-window) - (edebug-toggle-save-all-windows))) - - -(defun edebug-where () - "Show the debug windows and where we stopped in the program." - (interactive) - (if (not edebug-active) - (error "Edebug is not active")) - ;; Restore the window configuration to what it last was inside. - ;; But it is not always set. - experiment - ;;(if edebug-inside-windows - ;; (edebug-set-windows edebug-inside-windows)) - (edebug-pop-to-buffer edebug-buffer) - (goto-char edebug-point)) - -(defun edebug-view-outside () - "Change to the outside window configuration." - (interactive) - (if (not edebug-active) - (error "Edebug is not active")) - (setq edebug-inside-windows - (edebug-current-windows edebug-save-windows)) - (edebug-set-windows edebug-outside-windows) - (goto-char edebug-outside-point) - (message "Window configuration outside of Edebug. Return with %s" - (substitute-command-keys "\\<global-map>\\[edebug-where]"))) - - -(defun edebug-bounce-point (arg) - "Bounce the point in the outside current buffer. -If prefix arg is supplied, sit for that many seconds before returning. -The default is one second." - (interactive "p") - (if (not edebug-active) - (error "Edebug is not active")) - (save-excursion - ;; If the buffer's currently displayed, avoid set-window-configuration. - (save-window-excursion - (edebug-pop-to-buffer edebug-outside-buffer) - (goto-char edebug-outside-point) - (message "Current buffer: %s Point: %s Mark: %s" - (current-buffer) (point) - (if (marker-buffer (edebug-mark-marker)) - (marker-position (edebug-mark-marker)) "<not set>")) - (edebug-sit-for arg) - (edebug-pop-to-buffer edebug-buffer (car edebug-window-data))))) - - -;; Joe Wells, here is a start at your idea of adding a buffer to the internal -;; display list. Still need to use this list in edebug-display. - -'(defvar edebug-display-buffer-list nil - "List of buffers that edebug will display when it is active.") - -'(defun edebug-display-buffer (buffer) - "Toggle display of a buffer inside of edebug." - (interactive "bBuffer: ") - (let ((already-displaying (memq buffer edebug-display-buffer-list))) - (setq edebug-display-buffer-list - (if already-displaying - (delq buffer edebug-display-buffer-list) - (cons buffer edebug-display-buffer-list))) - (message "Displaying %s %s" buffer - (if already-displaying "off" "on")))) - -;;; Breakpoint related functions - -(defun edebug-find-stop-point () - ;; Return (function . index) of the nearest edebug stop point. - (let* ((edebug-def-name (edebug-form-data-symbol)) - (edebug-data - (let ((data (get edebug-def-name 'edebug))) - (if (or (null data) (markerp data)) - (error "%s is not instrumented for Edebug" edebug-def-name)) - data)) ; we could do it automatically, if data is a marker. - ;; pull out parts of edebug-data. - (edebug-def-mark (car edebug-data)) - ;; (edebug-breakpoints (car (cdr edebug-data))) - - (offset-vector (nth 2 edebug-data)) - (offset (- (save-excursion - (if (looking-at "[ \t]") - ;; skip backwards until non-whitespace, or bol - (skip-chars-backward " \t")) - (point)) - edebug-def-mark)) - len i) - ;; the offsets are in order so we can do a linear search - (setq len (length offset-vector)) - (setq i 0) - (while (and (< i len) (> offset (aref offset-vector i))) - (setq i (1+ i))) - (if (and (< i len) - (<= offset (aref offset-vector i))) - ;; return the relevant info - (cons edebug-def-name i) - (message "Point is not on an expression in %s." - edebug-def-name) - ))) - - -(defun edebug-next-breakpoint () - "Move point to the next breakpoint, or first if none past point." - (interactive) - (let ((edebug-stop-point (edebug-find-stop-point))) - (if edebug-stop-point - (let* ((edebug-def-name (car edebug-stop-point)) - (index (cdr edebug-stop-point)) - (edebug-data (get edebug-def-name 'edebug)) - - ;; pull out parts of edebug-data - (edebug-def-mark (car edebug-data)) - (edebug-breakpoints (car (cdr edebug-data))) - (offset-vector (nth 2 edebug-data)) - breakpoint) - (if (not edebug-breakpoints) - (message "No breakpoints in this function.") - (let ((breaks edebug-breakpoints)) - (while (and breaks - (<= (car (car breaks)) index)) - (setq breaks (cdr breaks))) - (setq breakpoint - (if breaks - (car breaks) - ;; goto the first breakpoint - (car edebug-breakpoints))) - (goto-char (+ edebug-def-mark - (aref offset-vector (car breakpoint)))) - - (message "%s" - (concat (if (nth 2 breakpoint) - "Temporary " "") - (if (car (cdr breakpoint)) - (format "Condition: %s" - (edebug-safe-prin1-to-string - (car (cdr breakpoint)))) - ""))) - )))))) - - -(defun edebug-modify-breakpoint (flag &optional condition temporary) - "Modify the breakpoint for the form at point or after it according -to FLAG: set if t, clear if nil. Then move to that point. -If CONDITION or TEMPORARY are non-nil, add those attributes to -the breakpoint. " - (let ((edebug-stop-point (edebug-find-stop-point))) - (if edebug-stop-point - (let* ((edebug-def-name (car edebug-stop-point)) - (index (cdr edebug-stop-point)) - (edebug-data (get edebug-def-name 'edebug)) - - ;; pull out parts of edebug-data - (edebug-def-mark (car edebug-data)) - (edebug-breakpoints (car (cdr edebug-data))) - (offset-vector (nth 2 edebug-data)) - present) - ;; delete it either way - (setq present (assq index edebug-breakpoints)) - (setq edebug-breakpoints (delq present edebug-breakpoints)) - (if flag - (progn - ;; add it to the list and resort - (setq edebug-breakpoints - (edebug-sort-alist - (cons - (list index condition temporary) - edebug-breakpoints) '<)) - (if condition - (message "Breakpoint set in %s with condition: %s" - edebug-def-name condition) - (message "Breakpoint set in %s" edebug-def-name))) - (if present - (message "Breakpoint unset in %s" edebug-def-name) - (message "No breakpoint here"))) - - (setcar (cdr edebug-data) edebug-breakpoints) - (goto-char (+ edebug-def-mark (aref offset-vector index))) - )))) - -(defun edebug-set-breakpoint (arg) - "Set the breakpoint of nearest sexp. -With prefix argument, make it a temporary breakpoint." - (interactive "P") - (edebug-modify-breakpoint t nil arg)) - -(defun edebug-unset-breakpoint () - "Clear the breakpoint of nearest sexp." - (interactive) - (edebug-modify-breakpoint nil)) - - -;; For emacs 18, no read-expression-history -(defun edebug-set-conditional-breakpoint (arg condition) - "Set a conditional breakpoint at nearest sexp. -The condition is evaluated in the outside context. -With prefix argument, make it a temporary breakpoint." - ;; (interactive "P\nxCondition: ") - (interactive - (list - current-prefix-arg - ;; Edit previous condition as follows, but it is cumbersome: - (let ((edebug-stop-point (edebug-find-stop-point))) - (if edebug-stop-point - (let* ((edebug-def-name (car edebug-stop-point)) - (index (cdr edebug-stop-point)) - (edebug-data (get edebug-def-name 'edebug)) - (edebug-breakpoints (car (cdr edebug-data))) - (edebug-break-data (assq index edebug-breakpoints)) - (edebug-break-condition (car (cdr edebug-break-data)))) - (read-minibuffer - (format "Condition in %s: " edebug-def-name) - (if edebug-break-condition - (format "%s" edebug-break-condition) - (format "")))))))) - (edebug-modify-breakpoint t condition arg)) - - -(defun edebug-set-global-break-condition (expression) - (interactive (list (read-minibuffer - "Global Condition: " - (format "%s" edebug-global-break-condition)))) - (setq edebug-global-break-condition expression)) - - -;;; Mode switching functions - -(defun edebug-set-mode (mode shortmsg msg) - ;; Set the edebug mode to MODE. - ;; Display SHORTMSG, or MSG if not within edebug. - (if (eq (1+ edebug-recursion-depth) (recursion-depth)) - (progn - (setq edebug-execution-mode mode) - (message shortmsg) - ;; Continue execution - (exit-recursive-edit)) - ;; This is not terribly useful!! - (setq edebug-next-execution-mode mode) - (message msg))) - - -(defalias 'edebug-step-through-mode 'edebug-step-mode) - -(defun edebug-step-mode () - "Proceed to next stop point." - (interactive) - (edebug-set-mode 'step "" "Edebug will stop at next stop point.")) - -(defun edebug-next-mode () - "Proceed to next `after' stop point." - (interactive) - (edebug-set-mode 'next "" "Edebug will stop after next eval.")) - -(defun edebug-go-mode (arg) - "Go, evaluating until break. -With prefix ARG, set temporary break at current point and go." - (interactive "P") - (if arg - (edebug-set-breakpoint t)) - (edebug-set-mode 'go "Go..." "Edebug will go until break.")) - -(defun edebug-Go-nonstop-mode () - "Go, evaluating without debugging." - (interactive) - (edebug-set-mode 'Go-nonstop "Go-Nonstop..." - "Edebug will not stop at breaks.")) - - -(defun edebug-trace-mode () - "Begin trace mode." - (interactive) - (edebug-set-mode 'trace "Tracing..." "Edebug will trace with pause.")) - -(defun edebug-Trace-fast-mode () - "Trace with no wait at each step." - (interactive) - (edebug-set-mode 'Trace-fast - "Trace fast..." "Edebug will trace without pause.")) - -(defun edebug-continue-mode () - "Begin continue mode." - (interactive) - (edebug-set-mode 'continue "Continue..." - "Edebug will pause at breakpoints.")) - -(defun edebug-Continue-fast-mode () - "Trace with no wait at each step." - (interactive) - (edebug-set-mode 'Continue-fast "Continue fast..." - "Edebug will stop and go at breakpoints.")) - -;; ------------------------------------------------------------ -;; The following use the mode changing commands and breakpoints. - - -(defun edebug-goto-here () - "Proceed to this stop point." - (interactive) - (edebug-go-mode t)) - - -(defun edebug-stop () - "Stop execution and do not continue. -Useful for exiting from trace or continue loop." - (interactive) - (message "Stop")) - - -'(defun edebug-forward () - "Proceed to the exit of the next expression to be evaluated." - (interactive) - (edebug-set-mode - 'forward "Forward" - "Edebug will stop after exiting the next expression.")) - - -(defun edebug-forward-sexp (arg) - "Proceed from the current point to the end of the ARGth sexp ahead. -If there are not ARG sexps ahead, then do edebug-step-out." - (interactive "p") - (condition-case nil - (let ((parse-sexp-ignore-comments t)) - ;; Call forward-sexp repeatedly until done or failure. - (forward-sexp arg) - (edebug-go-mode t)) - (error - (edebug-step-out) - ))) - -(defun edebug-step-out () - "Proceed from the current point to the end of the containing sexp. -If there is no containing sexp that is not the top level defun, -go to the end of the last sexp, or if that is the same point, then step." - (interactive) - (condition-case nil - (let ((parse-sexp-ignore-comments t)) - (up-list 1) - (save-excursion - ;; Is there still a containing expression? - (up-list 1)) - (edebug-go-mode t)) - (error - ;; At top level - 1, so first check if there are more sexps at this level. - (let ((start-point (point))) -;; (up-list 1) - (down-list -1) - (if (= (point) start-point) - (edebug-step-mode) ; No more at this level, so step. - (edebug-go-mode t) - ))))) - -(defun edebug-instrument-function (func) - ;; Func should be a function symbol. - ;; Return the function symbol, or nil if not instrumented. - (let ((func-marker)) - (setq func-marker (get func 'edebug)) - (cond - ((markerp func-marker) - ;; It is uninstrumented, so instrument it. - (save-excursion - (set-buffer (marker-buffer func-marker)) - (goto-char func-marker) - (edebug-eval-top-level-form) - func)) - ((consp func-marker) - (message "%s is already instrumented." func) - func) - (t - ;; We could try harder, e.g. do a tags search. - (error "Don't know where %s is defined" func) - nil)))) - -(defun edebug-instrument-callee () - "Instrument the definition of the function or macro about to be called. -Do this when stopped before the form or it will be too late. -One side effect of using this command is that the next time the -function or macro is called, Edebug will be called there as well." - (interactive) - (if (not (looking-at "\(")) - (error "You must be before a list form") - (let ((func - (save-excursion - (down-list 1) - (if (looking-at "\(") - (edebug-form-data-name - (edebug-get-form-data-entry (point))) - (edebug-original-read (current-buffer)))))) - (edebug-instrument-function func)))) - - -(defun edebug-step-in () - "Step into the definition of the function or macro about to be called. -This first does `edebug-instrument-callee' to ensure that it is -instrumented. Then it does `edebug-on-entry' and switches to `go' mode." - (interactive) - (let ((func (edebug-instrument-callee))) - (if func - (progn - (edebug-on-entry func 'temp) - (edebug-go-mode nil))))) - -(defun edebug-on-entry (function &optional flag) - "Cause Edebug to stop when FUNCTION is called. -With prefix argument, make this temporary so it is automatically -cancelled the first time the function is entered." - (interactive "aEdebug on entry to: \nP") - ;; Could store this in the edebug data instead. - (put function 'edebug-on-entry (if flag 'temp t))) - -(defun cancel-edebug-on-entry (function) - (interactive "aEdebug on entry to: ") - (put function 'edebug-on-entry nil)) - - -(if (not (fboundp 'edebug-original-debug-on-entry)) - (fset 'edebug-original-debug-on-entry (symbol-function 'debug-on-entry))) -'(fset 'debug-on-entry 'edebug-debug-on-entry) ;; Should we do this? -;; Also need edebug-cancel-debug-on-entry - -'(defun edebug-debug-on-entry (function) - "Request FUNCTION to invoke debugger each time it is called. -If the user continues, FUNCTION's execution proceeds. -Works by modifying the definition of FUNCTION, -which must be written in Lisp, not predefined. -Use `cancel-debug-on-entry' to cancel the effect of this command. -Redefining FUNCTION also does that. - -This version is from Edebug. If the function is instrumented for -Edebug, it calls `edebug-on-entry'" - (interactive "aDebug on entry (to function): ") - (let ((func-data (get function 'edebug))) - (if (or (null func-data) (markerp func-data)) - (edebug-original-debug-on-entry function) - (edebug-on-entry function)))) - - -(defun edebug-top-level-nonstop () - "Set mode to Go-nonstop, and exit to top-level. -This is useful for exiting even if unwind-protect code may be executed." - (interactive) - (setq edebug-execution-mode 'Go-nonstop) - (top-level)) - - -;;(defun edebug-exit-out () -;; "Go until the current function exits." -;; (interactive) -;; (edebug-set-mode 'exiting "Exit...")) - - -;;; The following initial mode setting definitions are not used yet. - -'(defconst edebug-initial-mode-alist - '((edebug-Continue-fast . Continue-fast) - (edebug-Trace-fast . Trace-fast) - (edebug-continue . continue) - (edebug-trace . trace) - (edebug-go . go) - (edebug-step-through . step) - (edebug-Go-nonstop . Go-nonstop) - ) - "Association list between commands and the modes they set.") - - -'(defun edebug-set-initial-mode () - "Ask for the initial mode of the enclosing function. -The mode is requested via the key that would be used to set the mode in -edebug-mode." - (interactive) - (let* ((this-function (edebug-which-function)) - (keymap (if (eq edebug-mode-map (current-local-map)) - edebug-mode-map)) - (old-mode (or (get this-function 'edebug-initial-mode) - edebug-initial-mode)) - (key (read-key-sequence - (format - "Change initial edebug mode for %s from %s (%s) to (enter key): " - this-function - old-mode - (where-is-internal - (car (rassq old-mode edebug-initial-mode-alist)) - keymap 'firstonly - )))) - (mode (cdr (assq (key-binding key) edebug-initial-mode-alist))) - ) - (if (and mode - (or (get this-function 'edebug-initial-mode) - (not (eq mode edebug-initial-mode)))) - (progn - (put this-function 'edebug-initial-mode mode) - (message "Initial mode for %s is now: %s" - this-function mode)) - (error "Key must map to one of the mode changing commands") - ))) - -;;; Evaluation of expressions - -(def-edebug-spec edebug-outside-excursion t) - -(defmacro edebug-outside-excursion (&rest body) - "Evaluate an expression list in the outside context. -Return the result of the last expression." - (` (save-excursion ; of current-buffer - (if edebug-save-windows - (progn - ;; After excursion, we will - ;; restore to current window configuration. - (setq edebug-inside-windows - (edebug-current-windows edebug-save-windows)) - ;; Restore outside windows. - (edebug-set-windows edebug-outside-windows))) - - (set-buffer edebug-buffer) ; why? - ;; (use-local-map edebug-outside-map) - (store-match-data edebug-outside-match-data) - ;; Restore outside context. - (let (;; (edebug-inside-map (current-local-map)) ;; restore map?? - (last-command-char edebug-outside-last-command-char) - (last-command-event edebug-outside-last-command-event) - (last-command edebug-outside-last-command) - (this-command edebug-outside-this-command) - (unread-command-char edebug-outside-unread-command-char) - (unread-command-event edebug-outside-unread-command-event) - (unread-command-events edebug-outside-unread-command-events) - (last-input-char edebug-outside-last-input-char) - (last-input-event edebug-outside-last-input-event) - (last-event-frame edebug-outside-last-event-frame) - (last-nonmenu-event edebug-outside-last-nonmenu-event) - (track-mouse edebug-outside-track-mouse) - (standard-output edebug-outside-standard-output) - (standard-input edebug-outside-standard-input) - - (executing-kbd-macro edebug-outside-executing-macro) - (defining-kbd-macro edebug-outside-defining-kbd-macro) - (pre-command-hook edebug-outside-pre-command-hook) - (post-command-hook edebug-outside-post-command-hook) - (post-command-idle-hook edebug-outside-post-command-idle-hook) - - ;; See edebug-display - (overlay-arrow-position edebug-outside-o-a-p) - (overlay-arrow-string edebug-outside-o-a-s) - (cursor-in-echo-area edebug-outside-c-i-e-a) - ) - (unwind-protect - (save-excursion ; of edebug-buffer - (set-buffer edebug-outside-buffer) - (goto-char edebug-outside-point) - (if (marker-buffer (edebug-mark-marker)) - (set-marker (edebug-mark-marker) edebug-outside-mark)) - (,@ body)) - - ;; Back to edebug-buffer. Restore rest of inside context. - ;; (use-local-map edebug-inside-map) - (if edebug-save-windows - ;; Restore inside windows. - (edebug-set-windows edebug-inside-windows)) - - ;; Save values that may have been changed. - (setq - edebug-outside-last-command-char last-command-char - edebug-outside-last-command-event last-command-event - edebug-outside-last-command last-command - edebug-outside-this-command this-command - edebug-outside-unread-command-char unread-command-char - edebug-outside-unread-command-event unread-command-event - edebug-outside-unread-command-events unread-command-events - edebug-outside-last-input-char last-input-char - edebug-outside-last-input-event last-input-event - edebug-outside-last-event-frame last-event-frame - edebug-outside-last-nonmenu-event last-nonmenu-event - edebug-outside-track-mouse track-mouse - edebug-outside-standard-output standard-output - edebug-outside-standard-input standard-input - - edebug-outside-executing-macro executing-kbd-macro - edebug-outside-defining-kbd-macro defining-kbd-macro - edebug-outside-pre-command-hook pre-command-hook - edebug-outside-post-command-hook post-command-hook - edebug-outside-post-command-idle-hook post-command-idle-hook - - edebug-outside-o-a-p overlay-arrow-position - edebug-outside-o-a-s overlay-arrow-string - edebug-outside-c-i-e-a cursor-in-echo-area - ))) ; let - ))) - -(defvar cl-debug-env nil) ;; defined in cl; non-nil when lexical env used. - -(defun edebug-eval (edebug-expr) - ;; Are there cl lexical variables active? - (if cl-debug-env - (eval (cl-macroexpand-all edebug-expr cl-debug-env)) - (eval edebug-expr))) - -(defun edebug-safe-eval (edebug-expr) - ;; Evaluate EXPR safely. - ;; If there is an error, a string is returned describing the error. - (condition-case edebug-err - (edebug-eval edebug-expr) - (error (edebug-format "%s: %s" ;; could - (get (car edebug-err) 'error-message) - (car (cdr edebug-err)))))) - -;;; Printing - -;; Replace printing functions. - -;; obsolete names -(defalias 'edebug-install-custom-print-funcs 'edebug-install-custom-print) -(defalias 'edebug-reset-print-funcs 'edebug-uninstall-custom-print) -(defalias 'edebug-uninstall-custom-print-funcs 'edebug-uninstall-custom-print) - -(defun edebug-install-custom-print () - "Replace print functions used by Edebug with custom versions." - ;; Modifying the custom print functions, or changing print-length, - ;; print-level, print-circle, custom-print-list or custom-print-vector - ;; have immediate effect. - (interactive) - (require 'cust-print) - (defalias 'edebug-prin1 'custom-prin1) - (defalias 'edebug-print 'custom-print) - (defalias 'edebug-prin1-to-string 'custom-prin1-to-string) - (defalias 'edebug-format 'custom-format) - (defalias 'edebug-message 'custom-message) - "Installed") - -(eval-and-compile - (defun edebug-uninstall-custom-print () - "Replace edebug custom print functions with internal versions." - (interactive) - (defalias 'edebug-prin1 'prin1) - (defalias 'edebug-print 'print) - (defalias 'edebug-prin1-to-string 'prin1-to-string) - (defalias 'edebug-format 'format) - (defalias 'edebug-message 'message) - "Uninstalled") - - ;; Default print functions are the same as Emacs'. - (edebug-uninstall-custom-print)) - - -(defun edebug-report-error (edebug-value) - ;; Print an error message like command level does. - ;; This also prints the error name if it has no error-message. - (message "%s: %s" - (or (get (car edebug-value) 'error-message) - (format "peculiar error (%s)" (car edebug-value))) - (mapconcat (function (lambda (edebug-arg) - ;; continuing after an error may - ;; complain about edebug-arg. why?? - (prin1-to-string edebug-arg))) - (cdr edebug-value) ", "))) - -;; Define here in case they are not already defined. -(defvar print-level nil) -(defvar print-circle nil) -(defvar print-readably) ;; defined by XEmacs -;; Alternatively, we could change the definition of -;; edebug-safe-prin1-to-string to only use these if defined. - -(defun edebug-safe-prin1-to-string (value) - (let ((print-escape-newlines t) - (print-length (or edebug-print-length print-length)) - (print-level (or edebug-print-level print-level)) - (print-circle (or edebug-print-circle print-circle)) - (print-readably nil)) ;; XEmacs uses this. - (edebug-prin1-to-string value))) - -(defun edebug-compute-previous-result (edebug-previous-value) - (setq edebug-previous-result - (if (numberp edebug-previous-value) - (format "Result: %s" edebug-previous-value) - (if edebug-unwrap-results - (setq edebug-previous-value - (edebug-unwrap* edebug-previous-value))) - (concat "Result: " - (edebug-safe-prin1-to-string edebug-previous-value))))) - -(defun edebug-previous-result () - "Print the previous result." - (interactive) - (message "%s" edebug-previous-result)) - -;;; Read, Eval and Print - -(defun edebug-eval-expression (edebug-expr) - "Evaluate an expression in the outside environment. -If interactive, prompt for the expression. -Print result in minibuffer." - (interactive "xEval: ") - (princ - (edebug-outside-excursion - (setq values (cons (edebug-eval edebug-expr) values)) - (edebug-safe-prin1-to-string (car values))))) - -(defun edebug-eval-last-sexp () - "Evaluate sexp before point in the outside environment; -print value in minibuffer." - (interactive) - (edebug-eval-expression (edebug-last-sexp))) - -(defun edebug-eval-print-last-sexp () - "Evaluate sexp before point in the outside environment; -print value into current buffer." - (interactive) - (let* ((edebug-form (edebug-last-sexp)) - (edebug-result-string - (edebug-outside-excursion - (edebug-safe-prin1-to-string (edebug-safe-eval edebug-form)))) - (standard-output (current-buffer))) - (princ "\n") - ;; princ the string to get rid of quotes. - (princ edebug-result-string) - (princ "\n") - )) - -;;; Edebug Minor Mode - -;; Global GUD bindings for all emacs-lisp-mode buffers. -(define-key emacs-lisp-mode-map "\C-x\C-a\C-s" 'edebug-step-mode) -(define-key emacs-lisp-mode-map "\C-x\C-a\C-n" 'edebug-next-mode) -(define-key emacs-lisp-mode-map "\C-x\C-a\C-c" 'edebug-go-mode) -(define-key emacs-lisp-mode-map "\C-x\C-a\C-l" 'edebug-where) - - -(defvar edebug-mode-map nil) -(if edebug-mode-map - nil - (progn - (setq edebug-mode-map (copy-keymap emacs-lisp-mode-map)) - ;; control - (define-key edebug-mode-map " " 'edebug-step-mode) - (define-key edebug-mode-map "n" 'edebug-next-mode) - (define-key edebug-mode-map "g" 'edebug-go-mode) - (define-key edebug-mode-map "G" 'edebug-Go-nonstop-mode) - (define-key edebug-mode-map "t" 'edebug-trace-mode) - (define-key edebug-mode-map "T" 'edebug-Trace-fast-mode) - (define-key edebug-mode-map "c" 'edebug-continue-mode) - (define-key edebug-mode-map "C" 'edebug-Continue-fast-mode) - - ;;(define-key edebug-mode-map "f" 'edebug-forward) not implemented - (define-key edebug-mode-map "f" 'edebug-forward-sexp) - (define-key edebug-mode-map "h" 'edebug-goto-here) - - (define-key edebug-mode-map "I" 'edebug-instrument-callee) - (define-key edebug-mode-map "i" 'edebug-step-in) - (define-key edebug-mode-map "o" 'edebug-step-out) - - ;; quitting and stopping - (define-key edebug-mode-map "q" 'top-level) - (define-key edebug-mode-map "Q" 'edebug-top-level-nonstop) - (define-key edebug-mode-map "a" 'abort-recursive-edit) - (define-key edebug-mode-map "S" 'edebug-stop) - - ;; breakpoints - (define-key edebug-mode-map "b" 'edebug-set-breakpoint) - (define-key edebug-mode-map "u" 'edebug-unset-breakpoint) - (define-key edebug-mode-map "B" 'edebug-next-breakpoint) - (define-key edebug-mode-map "x" 'edebug-set-conditional-breakpoint) - (define-key edebug-mode-map "X" 'edebug-set-global-break-condition) - - ;; evaluation - (define-key edebug-mode-map "r" 'edebug-previous-result) - (define-key edebug-mode-map "e" 'edebug-eval-expression) - (define-key edebug-mode-map "\C-x\C-e" 'edebug-eval-last-sexp) - (define-key edebug-mode-map "E" 'edebug-visit-eval-list) - - ;; views - (define-key edebug-mode-map "w" 'edebug-where) - (define-key edebug-mode-map "v" 'edebug-view-outside) ;; maybe obsolete?? - (define-key edebug-mode-map "p" 'edebug-bounce-point) - (define-key edebug-mode-map "P" 'edebug-view-outside) ;; same as v - (define-key edebug-mode-map "W" 'edebug-toggle-save-windows) - - ;; misc - (define-key edebug-mode-map "?" 'edebug-help) - (define-key edebug-mode-map "d" 'edebug-backtrace) - - (define-key edebug-mode-map "-" 'negative-argument) - - ;; statistics - (define-key edebug-mode-map "=" 'edebug-temp-display-freq-count) - - ;; GUD bindings - (define-key edebug-mode-map "\C-c\C-s" 'edebug-step-mode) - (define-key edebug-mode-map "\C-c\C-n" 'edebug-next-mode) - (define-key edebug-mode-map "\C-c\C-c" 'edebug-go-mode) - - (define-key edebug-mode-map "\C-x " 'edebug-set-breakpoint) - (define-key edebug-mode-map "\C-c\C-d" 'edebug-unset-breakpoint) - (define-key edebug-mode-map "\C-c\C-t" - (function (lambda () (edebug-set-breakpoint t)))) - (define-key edebug-mode-map "\C-c\C-l" 'edebug-where) - )) - -;; Autoloading these global bindings doesn't make sense because -;; they cannot be used anyway unless Edebug is already loaded and active. - -(defvar global-edebug-prefix "\^XX" - "Prefix key for global edebug commands, available from any buffer.") - -(defvar global-edebug-map nil - "Global map of edebug commands, available from any buffer.") - -(if global-edebug-map - nil - (setq global-edebug-map (make-sparse-keymap)) - - (global-unset-key global-edebug-prefix) - (global-set-key global-edebug-prefix global-edebug-map) - - (define-key global-edebug-map " " 'edebug-step-mode) - (define-key global-edebug-map "g" 'edebug-go-mode) - (define-key global-edebug-map "G" 'edebug-Go-nonstop-mode) - (define-key global-edebug-map "t" 'edebug-trace-mode) - (define-key global-edebug-map "T" 'edebug-Trace-fast-mode) - (define-key global-edebug-map "c" 'edebug-continue-mode) - (define-key global-edebug-map "C" 'edebug-Continue-fast-mode) - - ;; breakpoints - (define-key global-edebug-map "b" 'edebug-set-breakpoint) - (define-key global-edebug-map "u" 'edebug-unset-breakpoint) - (define-key global-edebug-map "x" 'edebug-set-conditional-breakpoint) - (define-key global-edebug-map "X" 'edebug-set-global-break-condition) - - ;; views - (define-key global-edebug-map "w" 'edebug-where) - (define-key global-edebug-map "W" 'edebug-toggle-save-windows) - - ;; quitting - (define-key global-edebug-map "q" 'top-level) - (define-key global-edebug-map "Q" 'edebug-top-level-nonstop) - (define-key global-edebug-map "a" 'abort-recursive-edit) - - ;; statistics - (define-key global-edebug-map "=" 'edebug-display-freq-count) - ) - -(defun edebug-help () - (interactive) - (describe-function 'edebug-mode)) - -(defun edebug-mode () - "Mode for Emacs Lisp buffers while in Edebug. - -In addition to all Emacs Lisp commands (except those that modify the -buffer) there are local and global key bindings to several Edebug -specific commands. E.g. `edebug-step-mode' is bound to \\[edebug-step-mode] -in the Edebug buffer and \\<global-map>\\[edebug-step-mode] in any buffer. - -Also see bindings for the eval list buffer, *edebug*. - -The edebug buffer commands: -\\{edebug-mode-map} - -Global commands prefixed by `global-edebug-prefix': -\\{global-edebug-map} - -Options: -edebug-setup-hook -edebug-all-defs -edebug-all-forms -edebug-save-windows -edebug-save-displayed-buffer-points -edebug-initial-mode -edebug-trace -edebug-test-coverage -edebug-continue-kbd-macro -edebug-print-length -edebug-print-level -edebug-print-circle -edebug-on-error -edebug-on-quit -edebug-on-signal -edebug-unwrap-results -edebug-global-break-condition -" - (use-local-map edebug-mode-map)) - -;;; edebug eval list mode - -;; A list of expressions and their evaluations is displayed in *edebug*. - -(defun edebug-eval-result-list () - "Return a list of evaluations of edebug-eval-list" - ;; Assumes in outside environment. - ;; Don't do any edebug things now. - (let ((edebug-execution-mode 'Go-nonstop) - (edebug-trace nil)) - (mapcar 'edebug-safe-eval edebug-eval-list))) - -(defun edebug-eval-display-list (edebug-eval-result-list) - ;; Assumes edebug-eval-buffer exists. - (let ((edebug-eval-list-temp edebug-eval-list) - (standard-output edebug-eval-buffer) - (edebug-comment-line - (format ";%s\n" (make-string (- (window-width) 2) ?-)))) - (set-buffer edebug-eval-buffer) - (erase-buffer) - (while edebug-eval-list-temp - (prin1 (car edebug-eval-list-temp)) (terpri) - (prin1 (car edebug-eval-result-list)) (terpri) - (princ edebug-comment-line) - (setq edebug-eval-list-temp (cdr edebug-eval-list-temp)) - (setq edebug-eval-result-list (cdr edebug-eval-result-list))) - (edebug-pop-to-buffer edebug-eval-buffer) - )) - -(defun edebug-create-eval-buffer () - (if (not (and edebug-eval-buffer (buffer-name edebug-eval-buffer))) - (progn - (set-buffer (setq edebug-eval-buffer (get-buffer-create "*edebug*"))) - (edebug-eval-mode)))) - -;; Should generalize this to be callable outside of edebug -;; with calls in user functions, e.g. (edebug-eval-display) - -(defun edebug-eval-display (edebug-eval-result-list) - "Display expressions and evaluations in EVAL-LIST. -It modifies the context by popping up the eval display." - (if edebug-eval-result-list - (progn - (edebug-create-eval-buffer) - (edebug-eval-display-list edebug-eval-result-list) - ))) - -(defun edebug-eval-redisplay () - "Redisplay eval list in outside environment. -May only be called from within edebug-recursive-edit." - (edebug-create-eval-buffer) - (edebug-outside-excursion - (edebug-eval-display-list (edebug-eval-result-list)) - )) - -(defun edebug-visit-eval-list () - (interactive) - (edebug-eval-redisplay) - (edebug-pop-to-buffer edebug-eval-buffer)) - - -(defun edebug-update-eval-list () - "Replace the evaluation list with the sexps now in the eval buffer." - (interactive) - (let ((starting-point (point)) - new-list) - (goto-char (point-min)) - ;; get the first expression - (edebug-skip-whitespace) - (if (not (eobp)) - (progn - (forward-sexp 1) - (setq new-list (cons (edebug-last-sexp) new-list)))) - - (while (re-search-forward "^;" nil t) - (forward-line 1) - (skip-chars-forward " \t\n\r") - (if (and (/= ?\; (following-char)) - (not (eobp))) - (progn - (forward-sexp 1) - (setq new-list (cons (edebug-last-sexp) new-list))))) - - (setq edebug-eval-list (nreverse new-list)) - (edebug-eval-redisplay) - (goto-char starting-point))) - - -(defun edebug-delete-eval-item () - "Delete the item under point and redisplay." - ;; could add arg to do repeatedly - (interactive) - (if (re-search-backward "^;" nil 'nofail) - (forward-line 1)) - (delete-region - (point) (progn (re-search-forward "^;" nil 'nofail) - (beginning-of-line) - (point))) - (edebug-update-eval-list)) - - - -(defvar edebug-eval-mode-map nil - "Keymap for edebug-eval-mode. Superset of lisp-interaction-mode.") - -(if edebug-eval-mode-map - nil - (setq edebug-eval-mode-map (copy-keymap lisp-interaction-mode-map)) - - (define-key edebug-eval-mode-map "\C-c\C-w" 'edebug-where) - (define-key edebug-eval-mode-map "\C-c\C-d" 'edebug-delete-eval-item) - (define-key edebug-eval-mode-map "\C-c\C-u" 'edebug-update-eval-list) - (define-key edebug-eval-mode-map "\C-x\C-e" 'edebug-eval-last-sexp) - (define-key edebug-eval-mode-map "\C-j" 'edebug-eval-print-last-sexp) - ) - - -(defun edebug-eval-mode () - "Mode for evaluation list buffer while in Edebug. - -In addition to all Interactive Emacs Lisp commands there are local and -global key bindings to several Edebug specific commands. E.g. -`edebug-step-mode' is bound to \\[edebug-step-mode] in the Edebug -buffer and \\<global-map>\\[edebug-step-mode] in any buffer. - -Eval list buffer commands: -\\{edebug-eval-mode-map} - -Global commands prefixed by global-edebug-prefix: -\\{global-edebug-map} -" - (lisp-interaction-mode) - (setq major-mode 'edebug-eval-mode) - (setq mode-name "Edebug-Eval") - (use-local-map edebug-eval-mode-map)) - -;;; Interface with standard debugger. - -;; (setq debugger 'edebug) ; to use the edebug debugger -;; (setq debugger 'debug) ; use the standard debugger - -;; Note that debug and its utilities must be byte-compiled to work, -;; since they depend on the backtrace looking a certain way. But -;; edebug is not dependent on this, yet. - -(defun edebug (&optional edebug-arg-mode &rest debugger-args) - "Replacement for debug. -If we are running an edebugged function, -show where we last were. Otherwise call debug normally." -;; (message "entered: %s depth: %s edebug-recursion-depth: %s" -;; edebug-entered (recursion-depth) edebug-recursion-depth) (sit-for 1) - (if (and edebug-entered ; anything active? - (eq (recursion-depth) edebug-recursion-depth)) - (let (;; Where were we before the error occurred? - (edebug-offset-index (car edebug-offset-indices)) - ;; Bind variables required by edebug-display - (edebug-value (car debugger-args)) - edebug-breakpoints - edebug-break-data - edebug-break-condition - edebug-global-break - (edebug-break (null edebug-arg-mode)) ;; if called explicitly - ) - (edebug-display) - (if (eq edebug-arg-mode 'error) - nil - edebug-value)) - - ;; Otherwise call debug normally. - ;; Still need to remove extraneous edebug calls from stack. - (apply 'debug edebug-arg-mode debugger-args) - )) - - -(defun edebug-backtrace () - "Display a non-working backtrace. Better than nothing..." - (interactive) - (if (or (not edebug-backtrace-buffer) - (null (buffer-name edebug-backtrace-buffer))) - (setq edebug-backtrace-buffer - (generate-new-buffer "*Backtrace*")) - ;; else, could just display edebug-backtrace-buffer - ) - (with-output-to-temp-buffer (buffer-name edebug-backtrace-buffer) - (setq edebug-backtrace-buffer standard-output) - (let ((print-escape-newlines t) - (print-length 50) - last-ok-point) - (backtrace) - - ;; Clean up the backtrace. - ;; Not quite right for current edebug scheme. - (set-buffer edebug-backtrace-buffer) - (setq truncate-lines t) - (goto-char (point-min)) - (setq last-ok-point (point)) - (if t (progn - - ;; Delete interspersed edebug internals. - (while (re-search-forward "^ \(?edebug" nil t) - (beginning-of-line) - (cond - ((looking-at "^ \(edebug-after") - ;; Previous lines may contain code, so just delete this line - (setq last-ok-point (point)) - (forward-line 1) - (delete-region last-ok-point (point))) - - ((looking-at "^ edebug") - (forward-line 1) - (delete-region last-ok-point (point)) - ))) - ))))) - - -;;; Trace display - -(defun edebug-trace-display (buf-name fmt &rest args) - "In buffer BUF-NAME, display FMT and ARGS at the end and make it visible. -The buffer is created if it does not exist. -You must include newlines in FMT to break lines, but one newline is appended." -;; e.g. -;; (edebug-trace-display "*trace-point*" -;; "saving: point = %s window-start = %s" -;; (point) (window-start)) - (let* ((oldbuf (current-buffer)) - (selected-window (selected-window)) - (buffer (get-buffer-create buf-name)) - buf-window) -;; (message "before pop-to-buffer") (sit-for 1) - (edebug-pop-to-buffer buffer) - (setq truncate-lines t) - (setq buf-window (selected-window)) - (goto-char (point-max)) - (insert (apply 'edebug-format fmt args) "\n") - ;; Make it visible. - (vertical-motion (- 1 (window-height))) - (set-window-start buf-window (point)) - (goto-char (point-max)) -;; (set-window-point buf-window (point)) -;; (edebug-sit-for 0) - (bury-buffer buffer) - (select-window selected-window) - (set-buffer oldbuf)) - buf-name) - - -(defun edebug-trace (fmt &rest args) - "Convenience call to edebug-trace-display using edebug-trace-buffer" - (apply 'edebug-trace-display edebug-trace-buffer fmt args)) - - -;;; Frequency count and coverage - -(defun edebug-display-freq-count () - "Display the frequency count data for each line of the current -definition. The frequency counts are inserted as comment lines after -each line, and you can undo all insertions with one `undo' command. - -The counts are inserted starting under the `(' before an expression -or the `)' after an expression, or on the last char of a symbol. -The counts are only displayed when they differ from previous counts on -the same line. - -If coverage is being tested, whenever all known results of an expression -are `eq', the char `=' will be appended after the count -for that expression. Note that this is always the case for an -expression only evaluated once. - -To clear the frequency count and coverage data for a definition, -reinstrument it." - (interactive) - (let* ((function (edebug-form-data-symbol)) - (counts (get function 'edebug-freq-count)) - (coverages (get function 'edebug-coverage)) - (data (get function 'edebug)) - (def-mark (car data)) ; mark at def start - (edebug-points (nth 2 data)) - (i (1- (length edebug-points))) - (last-index) - (first-index) - (start-of-line) - (start-of-count-line) - (last-count) - ) - (save-excursion - ;; Traverse in reverse order so offsets are correct. - (while (<= 0 i) - ;; Start at last expression in line. - (goto-char (+ def-mark (aref edebug-points i))) - (beginning-of-line) - (setq start-of-line (- (point) def-mark) - last-index i) - - ;; Find all indexes on same line. - (while (and (<= 0 (setq i (1- i))) - (<= start-of-line (aref edebug-points i)))) - ;; Insert all the indices for this line. - (forward-line 1) - (setq start-of-count-line (point) - first-index i ; really last index for line above this one. - last-count -1) ; cause first count to always appear. - (insert ";#") - ;; i == first-index still - (while (<= (setq i (1+ i)) last-index) - (let ((count (aref counts i)) - (coverage (aref coverages i)) - (col (save-excursion - (goto-char (+ (aref edebug-points i) def-mark)) - (- (current-column) - (if (= ?\( (following-char)) 0 1))))) - (insert (make-string - (max 0 (- col (- (point) start-of-count-line))) ?\ ) - (if (and (< 0 count) - (not (memq coverage - '(unknown ok-coverage)))) - "=" "") - (if (= count last-count) "" (int-to-string count)) - " ") - (setq last-count count))) - (insert "\n") - (setq i first-index))))) - -(defun edebug-temp-display-freq-count () - "Temporarily display the frequency count data for the current definition. -It is removed when you hit any char." - ;; This seems not to work with Emacs 18.59. It undoes too far. - (interactive) - (let ((buffer-read-only nil)) - (undo-boundary) - (edebug-display-freq-count) - (setq unread-command-char (read-char)) - (undo))) - - -;;; Menus - -(defun edebug-toggle (variable) - (set variable (not (eval variable))) - (message "%s: %s" variable (eval variable))) - -;; We have to require easymenu (even for Emacs 18) just so -;; the easy-menu-define macro call is compiled correctly. -(require 'easymenu) - -(defconst edebug-mode-menus - '("Edebug" - "----" - ["Stop" edebug-stop t] - ["Step" edebug-step-mode t] - ["Next" edebug-next-mode t] - ["Trace" edebug-trace-mode t] - ["Trace Fast" edebug-Trace-fast-mode t] - ["Continue" edebug-continue-mode t] - ["Continue Fast" edebug-Continue-fast-mode t] - ["Go" edebug-go-mode t] - ["Go Nonstop" edebug-Go-nonstop-mode t] - "----" - ["Help" edebug-help t] - ["Abort" abort-recursive-edit t] - ["Quit to Top Level" top-level t] - ["Quit Nonstop" edebug-top-level-nonstop t] - "----" - ("Jumps" - ["Forward Sexp" edebug-forward-sexp t] - ["Step In" edebug-step-in t] - ["Step Out" edebug-step-out t] - ["Goto Here" edebug-goto-here t]) - - ("Breaks" - ["Set Breakpoint" edebug-set-breakpoint t] - ["Unset Breakpoint" edebug-unset-breakpoint t] - ["Set Conditional Breakpoint" edebug-set-conditional-breakpoint t] - ["Set Global Break Condition" edebug-set-global-break-condition t] - ["Show Next Breakpoint" edebug-next-breakpoint t]) - - ("Views" - ["Where am I?" edebug-where t] - ["Bounce to Current Point" edebug-bounce-point t] - ["View Outside Windows" edebug-view-outside t] - ["Previous Result" edebug-previous-result t] - ["Show Backtrace" edebug-backtrace t] - ["Display Freq Count" edebug-display-freq-count t]) - - ("Eval" - ["Expression" edebug-eval-expression t] - ["Last Sexp" edebug-eval-last-sexp t] - ["Visit Eval List" edebug-visit-eval-list t]) - - ("Options" - ["Edebug All Defs" edebug-all-defs t] - ["Edebug All Forms" edebug-all-forms t] - "----" - ["Toggle Tracing" (edebug-toggle 'edebug-trace) t] - ["Toggle Coverage Testing" (edebug-toggle 'edebug-test-coverage) t] - ["Toggle Window Saving" edebug-toggle-save-windows t] - ["Toggle Point Saving" - (edebug-toggle 'edebug-save-displayed-buffer-points) t] - )) - "XEmacs style menus for Edebug.") - - -;;; Emacs version specific code - -;;; The default for all above is Emacs 18, because it is easier to compile -;;; Emacs 18 code in Emacs 19 than vice versa. This default will -;;; change once most people are using Emacs 19 or derivatives. - -;; Epoch specific code is in a separate file: edebug-epoch.el. - -;; The byte-compiler will complain about changes in number of arguments -;; to functions like mark and read-from-minibuffer. These warnings -;; may be ignored because the right call should always be made. - -(defun edebug-emacs-19-specific () - - (defalias 'edebug-window-live-p 'window-live-p) - - ;; Mark takes an argument in Emacs 19. - (defun edebug-mark () - (mark t));; Does this work for XEmacs too? - - ;; Use minibuffer-history when reading expressions. - (defvar read-expression-history) ;; hush bytecomp - (defvar read-expression-map) - - (defun edebug-set-conditional-breakpoint (arg condition) - "Set a conditional breakpoint at nearest sexp. -The condition is evaluated in the outside context. -With prefix argument, make it a temporary breakpoint." - ;; (interactive "P\nxCondition: ") - (interactive - (list - current-prefix-arg - ;; Read condition as follows; getting previous condition is cumbersome: - (let ((edebug-stop-point (edebug-find-stop-point))) - (if edebug-stop-point - (let* ((edebug-def-name (car edebug-stop-point)) - (index (cdr edebug-stop-point)) - (edebug-data (get edebug-def-name 'edebug)) - (edebug-breakpoints (car (cdr edebug-data))) - (edebug-break-data (assq index edebug-breakpoints)) - (edebug-break-condition (car (cdr edebug-break-data))) - (edebug-expression-history - ;; Prepend the current condition, if any. - (if edebug-break-condition - (cons edebug-break-condition read-expression-history) - read-expression-history))) - (prog1 - (read-from-minibuffer - "Condition: " nil read-expression-map t - 'edebug-expression-history) - (setq read-expression-history edebug-expression-history) - )))))) - (edebug-modify-breakpoint t condition arg)) - - (defun edebug-eval-expression (edebug-expr) - "Evaluate an expression in the outside environment. -If interactive, prompt for the expression. -Print result in minibuffer." - (interactive (list (read-from-minibuffer - "Eval: " nil read-expression-map t - 'read-expression-history))) - (princ - (edebug-outside-excursion - (setq values (cons (edebug-eval edebug-expr) values)) - (edebug-safe-prin1-to-string (car values))))) - - (easy-menu-define edebug-menu edebug-mode-map "Edebug menus" edebug-mode-menus) - (if (eq (console-type) 'x) ; XEmacs - (x-popup-menu nil (lookup-key edebug-mode-map [menu-bar Edebug]))) - ) - - -(defun edebug-xemacs-specific () - - ;; We need to bind zmacs-regions to nil around all calls to `mark' and - ;; `mark-marker' but don't bind it to nil before entering a recursive edit, - ;; that is, don't interfere with the binding the user might see while - ;; executing a command. - - (defvar zmacs-regions) - - (defun edebug-mark () - (let ((zmacs-regions nil)) - (mark))) - - (defun edebug-mark-marker () - (let ((zmacs-regions nil));; for XEmacs - (mark-marker))) - - - (defun edebug-mode-menu (event) - (interactive "@event") - (popup-menu edebug-mode-menus)) - - (define-key edebug-mode-map 'button3 'edebug-mode-menu) - ) - -(defun edebug-emacs-version-specific () - (cond - ((string-match "XEmacs" emacs-version);; XEmacs - (edebug-xemacs-specific)) - - ((and (boundp 'epoch::version) epoch::version) - (require 'edebug-epoch)) - - ((not (string-match "^18" emacs-version)) - (edebug-emacs-19-specific)))) - -(edebug-emacs-version-specific) - - -;;; Byte-compiler - -;; Extension for bytecomp to resolve undefined function references. -;; Requires new byte compiler. - -;; Reenable byte compiler warnings about unread-command-char and -event. -;; Disabled before edebug-recursive-edit. -(eval-when-compile - (if edebug-unread-command-char-warning - (put 'unread-command-char 'byte-obsolete-variable - edebug-unread-command-char-warning)) - (if edebug-unread-command-event-warning - (put 'unread-command-event 'byte-obsolete-variable - edebug-unread-command-event-warning))) - -(eval-when-compile - ;; The body of eval-when-compile seems to get evaluated with eval-defun. - ;; We only want to evaluate when actually byte compiling. - ;; But it is OK to evaluate as long as byte-compiler has been loaded. - (if (featurep 'byte-compile) (progn - - (defun byte-compile-resolve-functions (funcs) - "Say it is OK for the named functions to be unresolved." - (mapcar - (function - (lambda (func) - (setq byte-compile-unresolved-functions - (delq (assq func byte-compile-unresolved-functions) - byte-compile-unresolved-functions)))) - funcs) - nil) - - '(defun byte-compile-resolve-free-references (vars) - "Say it is OK for the named variables to be referenced." - (mapcar - (function - (lambda (var) - (setq byte-compile-free-references - (delq var byte-compile-free-references)))) - vars) - nil) - - '(defun byte-compile-resolve-free-assignments (vars) - "Say it is OK for the named variables to be assigned." - (mapcar - (function - (lambda (var) - (setq byte-compile-free-assignments - (delq var byte-compile-free-assignments)))) - vars) - nil) - - (byte-compile-resolve-functions - '(reporter-submit-bug-report - edebug-gensym ;; also in cl.el - ;; Interfaces to standard functions. - edebug-original-eval-defun - edebug-original-read - edebug-get-buffer-window - edebug-mark - edebug-mark-marker - edebug-input-pending-p - edebug-sit-for - edebug-prin1-to-string - edebug-format - edebug-original-signal - ;; XEmacs - zmacs-deactivate-region - popup-menu - ;; CL - cl-macroexpand-all - ;; And believe it or not, the byte compiler doesn't know about: - byte-compile-resolve-functions - )) - - '(byte-compile-resolve-free-references - '(read-expression-history - read-expression-map)) - - '(byte-compile-resolve-free-assignments - '(read-expression-history)) - - ))) - - -;;; Autoloading of Edebug accessories - -(if (featurep 'cl) - (add-hook 'edebug-setup-hook - (function (lambda () (require 'cl-specs)))) - ;; The following causes cl-specs to be loaded if you load cl.el. - (add-hook 'cl-load-hook - (function (lambda () (require 'cl-specs))))) - -;;; edebug-cl-read and cl-read are available from liberte@cs.uiuc.edu -(if (featurep 'cl-read) - (add-hook 'edebug-setup-hook - (function (lambda () (require 'edebug-cl-read)))) - ;; The following causes edebug-cl-read to be loaded when you load cl-read.el. - (add-hook 'cl-read-load-hooks - (function (lambda () (require 'edebug-cl-read))))) - - -;;; Finalize Loading - -;;; Finally, hook edebug into the rest of Emacs. -;;; There are probably some other things that could go here. - -;; Install edebug read and eval functions. -(edebug-install-read-eval-functions) - -(provide 'edebug) - -;;; edebug.el ends here
--- a/lisp/edebug/eval-reg.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,220 +0,0 @@ -;;; eval-reg.el --- Redefine eval-region, and subrs that use it, in Lisp - -;; Copyright (C) 1994 Daniel LaLiberte - -;; Author: Daniel LaLiberte <liberte@cs.uiuc.edu> -;; Keywords: lisp - -;; 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: - -;; eval-region, eval-buffer, and eval-current-buffer are redefined in -;; Lisp to allow customizations by Lisp code. eval-region calls -;; `read', `eval', and `prin1', so Lisp replacements of these -;; functions will affect eval-region and anything else that calls it. -;; eval-buffer and eval-current-buffer are redefined in Lisp to call -;; eval-region on the buffer. - -;; Because of dynamic binding, all local variables are protected from -;; being seen by eval by giving them funky names. But variables in -;; routines that call eval-region are similarly exposed. - -;; Perhaps this should be one of several files in an `elisp' package -;; that replaces Emacs Lisp subroutines with Lisp versions of the -;; same. - -;; Eval-region may be installed, after loading, by calling: -;; (elisp-eval-region-install). Installation can be undone with: -;; (elisp-eval-region-uninstall). - -;;; Code: - -'(defpackage "elisp-eval-region" - (:nicknames "elisp") - (:use "elisp") - (:export - elisp-eval-region-install - elisp-eval-region-uninstall - elisp-eval-region-level - with-elisp-eval-region - eval-region - eval-buffer - eval-current-buffer - )) -'(in-package elisp-eval-region) - -;; Save standard versions. -(if (not (fboundp 'original-eval-region)) - (defalias 'original-eval-region (symbol-function 'eval-region))) -(if (not (fboundp 'original-eval-buffer)) - (defalias 'original-eval-buffer - (if (fboundp 'eval-buffer) ;; only in Emacs 19 - (symbol-function 'eval-buffer) - 'undefined))) -(if (not (fboundp 'original-eval-current-buffer)) - (defalias 'original-eval-current-buffer - (symbol-function 'eval-current-buffer))) - -(defvar elisp-eval-region-level 0 - "If the value is 0, use the original version of `elisp-eval-region'. -Callers of `elisp-eval-region' should increment `elisp-eval-region-level' -while the Lisp version should be used. Installing `elisp-eval-region' -increments it once, and uninstalling decrements it.") - -;; Installing and uninstalling should always be used in pairs, -;; or just install once and never uninstall. -(defun elisp-eval-region-install () - (interactive) - (defalias 'eval-region 'elisp-eval-region) - (defalias 'eval-buffer 'elisp-eval-buffer) - (defalias 'eval-current-buffer 'elisp-eval-current-buffer) - (setq elisp-eval-region-level (1+ elisp-eval-region-level))) - -(defun elisp-eval-region-uninstall () - (interactive) - (if (> 1 elisp-eval-region-level) - (setq elisp-eval-region-level (1- elisp-eval-region-level)) - (setq elisp-eval-region-level 0) - (defalias 'eval-region (symbol-function 'original-eval-region)) - (defalias 'eval-buffer (symbol-function 'original-eval-buffer)) - (defalias 'eval-current-buffer - (symbol-function 'original-eval-current-buffer)) - )) - -(put 'with-elisp-eval-region 'lisp-indent-function 1) -(put 'with-elisp-eval-region 'lisp-indent-hook 1) -(put 'with-elisp-eval-region 'edebug-form-spec t) - -(defmacro with-elisp-eval-region (flag &rest body) - "If FLAG is nil, decrement `eval-region-level' while executing BODY. -The effect of decrementing all the way to zero is that `eval-region' -will use the original `eval-region', which may be the Emacs subr or some -previous redefinition. Before calling this macro, this package should -already have been installed, using `elisp-eval-region-install', which -increments the count once. So if another package still requires the -Lisp version of the code, the count will still be non-zero. - -The count is not bound locally by this macro, so changes by BODY to -its value will not be lost." - (` (let ((elisp-code (function (lambda () (,@ body))))) - (if (not (, flag)) - (unwind-protect - (progn - (setq elisp-eval-region-level (1- elisp-eval-region-level)) - (funcall elisp-code)) - (setq elisp-eval-region-level (1+ elisp-eval-region-level))) - (funcall elisp-code))))) - - -(defun elisp-eval-region (elisp-start elisp-end &optional elisp-output) - "Execute the region as Lisp code. -When called from programs, expects two arguments, -giving starting and ending indices in the current buffer -of the text to be executed. -Programs can pass third argument PRINTFLAG which controls printing of output: -nil means discard it; anything else is stream for print. - -This version, from `eval-reg.el', allows Lisp customization of read, -eval, and the printer." - - ;; Because this doesnt narrow to the region, one other difference - ;; concerns inserting whitespace after the expression being evaluated. - - (interactive "r") - (if (= 0 elisp-eval-region-level) - (original-eval-region elisp-start elisp-end elisp-output) - (let ((elisp-pnt (point)) - (elisp-buf (current-buffer));; Outside buffer - (elisp-inside-buf (current-buffer));; Buffer current while evaling - ;; Mark the end because it may move. - (elisp-end-marker (set-marker (make-marker) elisp-end)) - elisp-form - elisp-val) - (goto-char elisp-start) - (elisp-skip-whitespace) - (while (< (point) elisp-end-marker) - (setq elisp-form (read elisp-buf)) - - (let ((elisp-current-buffer (current-buffer))) - ;; Restore the inside current-buffer. - (set-buffer elisp-inside-buf) - (setq elisp-val (eval elisp-form)) - ;; Remember current buffer for next time. - (setq elisp-inside-buf (current-buffer)) - ;; Should this be protected? - (set-buffer elisp-current-buffer)) - - (if elisp-output - (let ((standard-output (or elisp-output t))) - (setq values (cons elisp-val values)) - (if (eq standard-output t) - (prin1 elisp-val) - (princ "\n") - (prin1 elisp-val) - (princ "\n") - ))) - (goto-char (min (max elisp-end-marker (point)) - (progn (elisp-skip-whitespace) (point)))) - ) ; while - (if elisp-output nil - ;; like save-excursion recovery, but done only if no error occurs - ;; but mark is not restored - (set-buffer elisp-buf) - (goto-char elisp-pnt)) - nil))) - - -(defun elisp-skip-whitespace () - ;; Leave point before the next token, skipping white space and comments. - (skip-chars-forward " \t\r\n\f") - (while (= (following-char) ?\;) - (skip-chars-forward "^\n\r") ; skip the comment - (skip-chars-forward " \t\r\n\f"))) - - -(defun elisp-eval-current-buffer (&optional elisp-output) - "Execute the current buffer as Lisp code. -Programs can pass argument PRINTFLAG which controls printing of output: -nil means discard it; anything else is stream for print. - -This version calls `eval-region' on the whole buffer." - ;; The standard eval-current-buffer doesn't use eval-region. - (interactive) - (eval-region (point-min) (point-max) elisp-output)) - - -(defun elisp-eval-buffer (&optional elisp-bufname elisp-printflag) - "Execute BUFFER as Lisp code. Use current buffer if BUFFER is nil. -Programs can pass argument PRINTFLAG which controls printing of -output: nil means discard it; anything else is stream for print. - -This version calls `eval-region' on the whole buffer." - (interactive) - (if (null elisp-bufname) - (setq elisp-bufname (current-buffer))) - (save-excursion - (set-buffer (or (get-buffer elisp-bufname) - (error "No such buffer: %s" elisp-bufname))) - (eval-region (point-min) (point-max) elisp-printflag))) - -(provide 'eval-reg) - -;;; eval-reg.el ends here
--- a/lisp/electric/auto-autoloads.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,96 +0,0 @@ -;;; DO NOT MODIFY THIS FILE -(if (featurep 'electric-autoloads) (error "Already loaded")) - -;;;### (autoloads (electric-buffer-list) "ebuff-menu" "electric/ebuff-menu.el") - -(autoload 'electric-buffer-list "ebuff-menu" "\ -Pops up a buffer describing the set of Emacs buffers. -Vaguely like ITS lunar select buffer; combining typeoutoid buffer -listing with menuoid buffer selection. - -If the very next character typed is a space then the buffer list -window disappears. Otherwise, one may move around in the buffer list -window, marking buffers to be selected, saved or deleted. - -To exit and select a new buffer, type a space when the cursor is on -the appropriate line of the buffer-list window. Other commands are -much like those of buffer-menu-mode. - -Calls value of `electric-buffer-menu-mode-hook' on entry if non-nil. - -Non-null optional arg FILES-ONLY means mention only file buffers. -When called from Lisp code, FILES-ONLY may be a regular expression, -in which case only buffers whose names match that expression are listed, -or an arbitrary predicate function. - -\\{electric-buffer-menu-mode-map}" t nil) - -;;;*** - -;;;### (autoloads (electric-command-history Electric-command-history-redo-expression) "echistory" "electric/echistory.el") - -(autoload 'Electric-command-history-redo-expression "echistory" "\ -Edit current history line in minibuffer and execute result. -With prefix arg NOCONFIRM, execute current line as-is without editing." t nil) - -(autoload 'electric-command-history "echistory" "\ -\\<electric-history-map>Major mode for examining and redoing commands from `command-history'. -This pops up a window with the Command History listing. -The number of command listed is controlled by `list-command-history-max'. -The command history is filtered by `list-command-history-filter' if non-nil. -Combines typeout Command History list window with menu like selection -of an expression from the history for re-evaluation in the *original* buffer. - -The history displayed is filtered by `list-command-history-filter' if non-nil. - -Like Emacs-Lisp mode except that characters do not insert themselves and -Tab and Linefeed do not indent. Instead these commands are provided: -\\{electric-history-map} - -Calls the value of `electric-command-history-hook' if that is non-nil. -The Command History listing is recomputed each time this mode is invoked." t nil) - -;;;*** - -;;;### (autoloads (electric-helpify with-electric-help) "ehelp" "electric/ehelp.el") - -(autoload 'with-electric-help "ehelp" "\ -Pop up an \"electric\" help buffer. -The arguments are THUNK &optional BUFFER NOERASE MINHEIGHT. -THUNK is a function of no arguments which is called to initialize the -contents of BUFFER. BUFFER defaults to `*Help*'. BUFFER will be -erased before THUNK is called unless NOERASE is non-nil. THUNK will -be called while BUFFER is current and with `standard-output' bound to -the buffer specified by BUFFER. - -If THUNK returns nil, we display BUFFER starting at the top, and -shrink the window to fit. If THUNK returns non-nil, we don't do those things. - -After THUNK has been called, this function \"electrically\" pops up a window -in which BUFFER is displayed and allows the user to scroll through that buffer -in electric-help-mode. The window's height will be at least MINHEIGHT if -this value is non-nil. - -If THUNK returns nil, we display BUFFER starting at the top, and -shrink the window to fit. If THUNK returns non-nil, we don't do those -things. - -When the user exits (with `electric-help-exit', or otherwise) the help -buffer's window disappears (i.e., we use `save-window-excursion') -BUFFER is put into `default-major-mode' (or `fundamental-mode') when we exit." nil nil) - -(autoload 'electric-helpify "ehelp" nil nil nil) - -;;;*** - -;;;### (autoloads (Helper-help Helper-describe-bindings) "helper" "electric/helper.el") - -(autoload 'Helper-describe-bindings "helper" "\ -Describe local key bindings of current mode." t nil) - -(autoload 'Helper-help "helper" "\ -Provide help for current mode." t nil) - -;;;*** - -(provide 'electric-autoloads)
--- a/lisp/electric/ebuff-menu.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,302 +0,0 @@ -;;; ebuff-menu.el --- electric-buffer-list mode - -;; Copyright (C) 1985, 1986, 1994 Free Software Foundation, Inc. - -;; Author: Richard Mlynarik <mly@ai.mit.edu> -;; Keywords: frames - -;; 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.34. - -;;; Commentary: - -;; Who says one can't have typeout windows in GNU Emacs? The entry -;; point, `electric-buffer-list' works like ^r select buffer from the -;; ITS Emacs lunar or tmacs libraries. - -;;; Code: - -(require 'electric) -;; XEmacs change -(require 'buff-menu) - -;; this depends on the format of list-buffers (from src/buffer.c) and -;; on stuff in lisp/buff-menu.el - -(defvar electric-buffer-menu-mode-map nil) - -;;;###autoload -(defun electric-buffer-list (&optional files-only) - "Pops up a buffer describing the set of Emacs buffers. -Vaguely like ITS lunar select buffer; combining typeoutoid buffer -listing with menuoid buffer selection. - -If the very next character typed is a space then the buffer list -window disappears. Otherwise, one may move around in the buffer list -window, marking buffers to be selected, saved or deleted. - -To exit and select a new buffer, type a space when the cursor is on -the appropriate line of the buffer-list window. Other commands are -much like those of buffer-menu-mode. - -Calls value of `electric-buffer-menu-mode-hook' on entry if non-nil. - -Non-null optional arg FILES-ONLY means mention only file buffers. -When called from Lisp code, FILES-ONLY may be a regular expression, -in which case only buffers whose names match that expression are listed, -or an arbitrary predicate function. - -\\{electric-buffer-menu-mode-map}" - (interactive (list (if current-prefix-arg t nil))) - (let (select buffer) - (save-window-excursion - (save-window-excursion (list-buffers files-only)) - (setq buffer (window-buffer (Electric-pop-up-window "*Buffer List*"))) - (unwind-protect - (progn - (set-buffer buffer) - (Electric-buffer-menu-mode) - (setq select - (catch 'electric-buffer-menu-select - (message "<<< Press Return to bury the buffer list >>>") - ;; XEmacs change - (if (eq (setq unread-command-events - (list (next-command-event))) - ?\ ) - (progn (setq unread-command-events nil) - (throw 'electric-buffer-menu-select nil))) - (let ((start-point (point)) - (first (progn (goto-char (point-min)) - (forward-line 2) - (point))) - (last (progn (goto-char (point-max)) - (forward-line -1) - (point))) - (goal-column 0)) - ;; Use start-point if it is meaningful. - (goto-char (if (or (< start-point first) - (> start-point last)) - first - start-point)) - (Electric-command-loop 'electric-buffer-menu-select - nil - t - 'electric-buffer-menu-looper - (cons first last)))))) - (set-buffer buffer) - (Buffer-menu-mode) - (bury-buffer buffer) - (message ""))) - (if select - (progn (set-buffer buffer) - (let ((opoint (point-marker))) - (Buffer-menu-execute) - (goto-char (point-min)) - (if (prog1 (search-forward "\n>" nil t) - (goto-char opoint) (set-marker opoint nil)) - (Buffer-menu-select) - (switch-to-buffer (Buffer-menu-buffer t)))))))) - -(defun electric-buffer-menu-looper (state condition) - (cond ((and condition - (not (memq (car condition) '(buffer-read-only - end-of-buffer - beginning-of-buffer)))) - (signal (car condition) (cdr condition))) - ((< (point) (car state)) - (goto-char (point-min)) - (forward-line 2)) - ((> (point) (cdr state)) - (goto-char (point-max)) - (forward-line -1) - (if (pos-visible-in-window-p (point-max)) - (recenter -1))))) - -(put 'Electric-buffer-menu-mode 'mode-class 'special) -(defun Electric-buffer-menu-mode () - "Major mode for editing a list of buffers. -Each line describes one of the buffers in Emacs. -Letters do not insert themselves; instead, they are commands. -\\<electric-buffer-menu-mode-map> -\\[keyboard-quit] or \\[Electric-buffer-menu-quit] -- exit buffer menu, returning to previous window and buffer - configuration. If the very first character typed is a space, it - also has this effect. -\\[Electric-buffer-menu-select] -- select buffer of line point is on. - Also show buffers marked with m in other windows, - deletes buffers marked with \"D\", and saves those marked with \"S\". -\\[Buffer-menu-mark] -- mark buffer to be displayed. -\\[Buffer-menu-not-modified] -- clear modified-flag on that buffer. -\\[Buffer-menu-save] -- mark that buffer to be saved. -\\[Buffer-menu-delete] or \\[Buffer-menu-delete-backwards] -- mark that buffer to be deleted. -\\[Buffer-menu-unmark] -- remove all kinds of marks from current line. -\\[Electric-buffer-menu-mode-view-buffer] -- view buffer, returning when done. -\\[Buffer-menu-backup-unmark] -- back up a line and remove marks. - -\\{electric-buffer-menu-mode-map} - -Entry to this mode via command `electric-buffer-list' calls the value of -`electric-buffer-menu-mode-hook' if it is non-nil." - (kill-all-local-variables) - (use-local-map electric-buffer-menu-mode-map) - (setq mode-name "Electric Buffer Menu") - (setq mode-line-buffer-identification "Electric Buffer List") - ;; XEmacs - (if (memq 'mode-name mode-line-format) - (progn (setq mode-line-format (copy-sequence mode-line-format)) - (setcar (memq 'mode-name mode-line-format) "Buffers"))) - (make-local-variable 'Helper-return-blurb) - (setq Helper-return-blurb "return to buffer editing") - (setq truncate-lines t) - ;; XEmacs - (setq buffer-scrollbar-height 0) - (setq buffer-read-only t) - (setq major-mode 'Electric-buffer-menu-mode) - ;; XEmacs - (setq mode-motion-hook 'mode-motion-highlight-line) - (goto-char (point-min)) - (if (search-forward "\n." nil t) (forward-char -1)) - (run-hooks 'electric-buffer-menu-mode-hook)) - -;; generally the same as Buffer-menu-mode-map -;; (except we don't indirect to global-map) -(put 'Electric-buffer-menu-undefined 'suppress-keymap t) -(if electric-buffer-menu-mode-map - nil - (let ((map (make-keymap)) (submap (make-keymap))) - ;(fillarray (car (cdr map)) 'Electric-buffer-menu-undefined) ; FSF - (let ((i 0)) - (while (< i 128) - (define-key map (make-string 1 i) 'Electric-buffer-menu-undefined) - (setq i (1+ i)))) - (define-key map "\e" submap) - ;(fillarray (car (cdr submap)) 'Electric-buffer-menu-undefined) ; FSF - (let ((map2 (lookup-key map "\e")) - (i 0)) - (while (< i 128) - (define-key map2 (make-string 1 i) 'Electric-buffer-menu-undefined) - (setq i (1+ i)))) - (define-key map "\C-z" 'suspend-emacs) - (define-key map "v" 'Electric-buffer-menu-mode-view-buffer) - (define-key map (vector help-char) 'Helper-help) - (define-key map "?" 'Helper-describe-bindings) - (define-key map "\C-c" nil) - (define-key map "\C-c\C-c" 'Electric-buffer-menu-quit) - (define-key map "\C-]" 'Electric-buffer-menu-quit) - (define-key map "q" 'Electric-buffer-menu-quit) - (define-key map " " 'Electric-buffer-menu-select) - (define-key map "\C-m" 'Electric-buffer-menu-select) - (define-key map "\C-l" 'recenter) - (define-key map "s" 'Buffer-menu-save) - (define-key map "d" 'Buffer-menu-delete) - (define-key map "k" 'Buffer-menu-delete) - (define-key map "\C-d" 'Buffer-menu-delete-backwards) - ;(define-key map "\C-k" 'Buffer-menu-delete) - (define-key map "\177" 'Buffer-menu-backup-unmark) - ;; XEmacs - (define-key map 'backspace 'Buffer-menu-backup-unmark) - (define-key map "~" 'Buffer-menu-not-modified) - (define-key map "u" 'Buffer-menu-unmark) - (let ((i ?0)) - (while (<= i ?9) - (define-key map (char-to-string i) 'digit-argument) - ;;#### Urk! - (define-key map (concat "\e" (char-to-string i)) 'digit-argument) - (setq i (1+ i)))) - (define-key map "-" 'negative-argument) - (define-key map "\e-" 'negative-argument) - (define-key map "m" 'Buffer-menu-mark) - (define-key map "\C-u" 'universal-argument) - (define-key map "\C-p" 'previous-line) - (define-key map "\C-n" 'next-line) - (define-key map "p" 'previous-line) - (define-key map "n" 'next-line) - (define-key map "\C-v" 'scroll-up) - (define-key map "\ev" 'scroll-down) - (define-key map ">" 'scroll-right) - (define-key map "<" 'scroll-left) - (define-key map "\e\C-v" 'scroll-other-window) - (define-key map "\e>" 'end-of-buffer) - (define-key map "\e<" 'beginning-of-buffer) - (define-key map "\e\e" nil) - (define-key map "\e\e\e" 'Electric-buffer-menu-quit) - ;; XEmacs - (define-key map [home] 'beginning-of-buffer) - (define-key map [down] 'next-line) - (define-key map [up] 'previous-line) - (define-key map [prior] 'scroll-down) - (define-key map [next] 'scroll-up) - (define-key map 'button2 'Electric-buffer-menu-mouse-select) - (define-key map 'button3 'Buffer-menu-popup-menu) - (setq electric-buffer-menu-mode-map map))) - -(defun Electric-buffer-menu-exit () - (interactive) - ;; XEmacs - (setq unread-command-event last-input-event) - ;; for robustness - (condition-case () - (throw 'electric-buffer-menu-select nil) - (error (Buffer-menu-mode) - (other-buffer)))) - -(defun Electric-buffer-menu-select () - "Leave Electric Buffer Menu, selecting buffers and executing changes. -Saves buffers marked \"S\". Deletes buffers marked \"K\". -Selects buffer at point and displays buffers marked \">\" in other windows." - (interactive) - (throw 'electric-buffer-menu-select (point))) - -(defun Electric-buffer-menu-mouse-select (event) - (interactive "e") - ;; XEmacs is simpler - (mouse-set-point event) - (Electric-buffer-menu-select)) - -(defun Electric-buffer-menu-quit () - "Leave Electric Buffer Menu, restoring previous window configuration. -Does not execute select, save, or delete commands." - (interactive) - (throw 'electric-buffer-menu-select nil)) - -(defun Electric-buffer-menu-undefined () - (interactive) - (ding) - (message "%s" - (if (and (eq (key-binding "\C-c\C-c") 'Electric-buffer-menu-quit) - (eq (key-binding " ") 'Electric-buffer-menu-select) - (eq (key-binding (vector help-char)) 'Helper-help) - (eq (key-binding "?") 'Helper-describe-bindings)) - (substitute-command-keys "Type C-c C-c to exit, Space to select, -Type \\[Electric-buffer-menu-quit] to exit, \ -\\[Electric-buffer-menu-select] to select, \ -\\[Helper-help] for help, \\[Helper-describe-bindings] for commands."))) - (sit-for 4)) - -(defun Electric-buffer-menu-mode-view-buffer () - "View buffer on current line in Electric Buffer Menu. -Returns to Electric Buffer Menu when done." - (interactive) - (let ((bufnam (Buffer-menu-buffer nil))) - (if bufnam - (view-buffer bufnam) - (ding) - (message "Buffer %s does not exist!" bufnam) - (sit-for 4)))) - -;;; ebuff-menu.el ends here
--- a/lisp/electric/echistory.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,156 +0,0 @@ -;;; echistory.el --- Electric Command History Mode - -;; Copyright (C) 1985 Free Software Foundation, Inc. - -;; Author: K. Shane Hartman -;; Maintainer: FSF -;; Keywords: extensions - -;; 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.34. - -;;; Code: - -(require 'electric) ; command loop -(require 'chistory) ; history lister - -;;;###autoload -(defun Electric-command-history-redo-expression (&optional noconfirm) - "Edit current history line in minibuffer and execute result. -With prefix arg NOCONFIRM, execute current line as-is without editing." - (interactive "P") - (let (todo) - (save-excursion - (set-buffer "*Command History*") - (beginning-of-line) - (setq todo (read (current-buffer))) - (if (boundp 'electric-history-in-progress) - (if todo (throw 'electric-history-quit (list noconfirm todo))))))) - -(defvar electric-history-map ()) -(if electric-history-map - () - ;; XEmacs - (setq electric-history-map (make-keymap)) - (set-keymap-name electric-history-map 'electric-history-map) - (set-keymap-default-binding electric-history-map 'Electric-history-undefined) - (define-key electric-history-map "\C-u" 'universal-argument) - (define-key electric-history-map " " 'Electric-command-history-redo-expression) - (define-key electric-history-map "!" 'Electric-command-history-redo-expression) - (define-key electric-history-map "\e\C-x" 'eval-sexp) - (define-key electric-history-map "\e\C-d" 'down-list) - (define-key electric-history-map "\e\C-u" 'backward-up-list) - (define-key electric-history-map "\e\C-b" 'backward-sexp) - (define-key electric-history-map "\e\C-f" 'forward-sexp) - (define-key electric-history-map "\e\C-a" 'beginning-of-defun) - (define-key electric-history-map "\e\C-e" 'end-of-defun) - (define-key electric-history-map "\e\C-n" 'forward-list) - (define-key electric-history-map "\e\C-p" 'backward-list) - (define-key electric-history-map "q" 'Electric-history-quit) - (define-key electric-history-map "\C-c" nil) - (define-key electric-history-map "\C-c\C-c" 'Electric-history-quit) - (define-key electric-history-map "\C-]" 'Electric-history-quit) - (define-key electric-history-map "\C-z" 'suspend-emacs) - (define-key electric-history-map (vector help-char) 'Helper-help) - ;; XEmacs - (define-key electric-history-map 'backspace 'previous-line) - (define-key electric-history-map "?" 'Helper-describe-bindings) - (define-key electric-history-map "\e>" 'end-of-buffer) - (define-key electric-history-map "\e<" 'beginning-of-buffer) - (define-key electric-history-map "\n" 'next-line) - (define-key electric-history-map "\r" 'next-line) - (define-key electric-history-map "\177" 'previous-line) - (define-key electric-history-map "\C-n" 'next-line) - (define-key electric-history-map "\C-p" 'previous-line) - (define-key electric-history-map "\ev" 'scroll-down) - (define-key electric-history-map "\C-v" 'scroll-up) - (define-key electric-history-map [home] 'beginning-of-buffer) - (define-key electric-history-map [down] 'next-line) - (define-key electric-history-map [up] 'previous-line) - (define-key electric-history-map [prior] 'scroll-down) - (define-key electric-history-map [next] 'scroll-up) - (define-key electric-history-map "\C-l" 'recenter) - (define-key electric-history-map "\e\C-v" 'scroll-other-window)) - -(defvar electric-command-history-hook nil - "If non-nil, its value is called by `electric-command-history'.") - -;;;###autoload -(defun electric-command-history () - "\\<electric-history-map>Major mode for examining and redoing commands from `command-history'. -This pops up a window with the Command History listing. -The number of command listed is controlled by `list-command-history-max'. -The command history is filtered by `list-command-history-filter' if non-nil. -Combines typeout Command History list window with menu like selection -of an expression from the history for re-evaluation in the *original* buffer. - -The history displayed is filtered by `list-command-history-filter' if non-nil. - -Like Emacs-Lisp mode except that characters do not insert themselves and -Tab and Linefeed do not indent. Instead these commands are provided: -\\{electric-history-map} - -Calls the value of `electric-command-history-hook' if that is non-nil. -The Command History listing is recomputed each time this mode is invoked." - (interactive) - (let ((electric-history-in-progress t) - (old-buffer (current-buffer)) - (todo)) - (unwind-protect - (setq todo - (catch 'electric-history-quit - (save-window-excursion - (save-window-excursion - (list-command-history) - (set-buffer "*Command History*") - (Command-history-setup 'electric-command-history - "Electric History" - electric-history-map)) - (Electric-pop-up-window "*Command History*") - (run-hooks 'electric-command-history-hook) - (if (eobp) - (progn (ding) - (message "No command history.") - (throw 'electric-history-quit nil)) - (let ((Helper-return-blurb "return to History")) - (Electric-command-loop 'electric-history-quit - "->" t)))))) - (set-buffer "*Command History*") - (Command-history-setup) - (bury-buffer (current-buffer))) - (if (consp todo) - (progn (set-buffer old-buffer) - (if (car todo) - (apply (car (car (cdr todo))) (cdr (car (cdr todo)))) - (edit-and-eval-command "Redo: " (car (cdr todo)))))))) - -(defun Electric-history-undefined () - (interactive) - (ding) - (message (substitute-command-keys "Type \\[Helper-help] for help, ? for commands, C-c C-c to quit, Space to execute")) - (sit-for 4)) - -(defun Electric-history-quit () - "Quit Electric Command History, restoring previous window configuration." - (interactive) - (if (boundp 'electric-history-in-progress) - (progn (message "") - (throw 'electric-history-quit nil)))) - -;;; echistory.el ends here
--- a/lisp/electric/ehelp.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,418 +0,0 @@ -;;; ehelp.el --- bindings for electric-help mode - -;; Copyright (C) 1986, 1995 Free Software Foundation, Inc. - -;; Author: Richard Mlynarik <mly@ai.mit.edu> -;; Maintainer: FSF -;; Keywords: help, extensions - -;; 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.34. - -;;; Commentary: - -;; This package provides a pre-packaged `Electric Help Mode' for -;; browsing on-line help screens. There is one entry point, -;; `with-electric-help'; all you have to give it is a no-argument -;; function that generates the actual text of the help into the current -;; buffer. - -;; To make this the default, you must do -;; (require 'ehelp) -;; (define-key global-map "\C-h" 'ehelp-command) -;; (define-key global-map [help] 'ehelp-command) -;; (define-key global-map [f1] 'ehelp-command) - -;;; Code: - -(require 'electric) -(defvar electric-help-map () - "Keymap defining commands available in `electric-help-mode'.") - -(defvar electric-help-form-to-execute nil) - -(put 'electric-help-undefined 'suppress-keymap t) -(if electric-help-map - () - (let ((map (make-keymap))) - ;; allow all non-self-inserting keys - search, scroll, etc, but - ;; let M-x and C-x exit ehelp mode and retain buffer: - (suppress-keymap map) - (define-key map "\C-u" 'electric-help-undefined) - (define-key map [(control ?0)] 'electric-help-undefined) - (define-key map [(control ?1)] 'electric-help-undefined) - (define-key map [(control ?2)] 'electric-help-undefined) - (define-key map [(control ?3)] 'electric-help-undefined) - (define-key map [(control ?4)] 'electric-help-undefined) - (define-key map [(control ?5)] 'electric-help-undefined) - (define-key map [(control ?6)] 'electric-help-undefined) - (define-key map [(control ?7)] 'electric-help-undefined) - (define-key map [(control ?8)] 'electric-help-undefined) - (define-key map [(control ?9)] 'electric-help-undefined) - (define-key map (vector help-char) 'electric-help-help) - (define-key map "?" 'electric-help-help) - ;; XEmacs addition - (define-key map 'help 'electric-help-help) - (define-key map " " 'scroll-up) - (define-key map "\^?" 'scroll-down) - (define-key map "." 'beginning-of-buffer) - (define-key map "<" 'beginning-of-buffer) - (define-key map ">" 'end-of-buffer) - ;(define-key map "\C-g" 'electric-help-exit) - (define-key map "q" 'electric-help-exit) - (define-key map "Q" 'electric-help-exit) - ;;a better key than this? - (define-key map "r" 'electric-help-retain) - (define-key map "R" 'electric-help-retain) - (define-key map "\ex" 'electric-help-execute-extended) - (define-key map "\C-x" 'electric-help-ctrl-x-prefix) - - (setq electric-help-map map))) - -(defun electric-help-mode () - "`with-electric-help' temporarily places its buffer in this mode. -\(On exit from `with-electric-help', the buffer is put in `default-major-mode'.)" - (setq buffer-read-only t) - (setq mode-name "Help") - (setq major-mode 'help) - (setq modeline-buffer-identification '(" Help: %b")) - (use-local-map electric-help-map) - (add-hook 'mouse-leave-buffer-hook 'electric-help-retain) - (view-mode -1) - ;; this is done below in with-electric-help - ;(run-hooks 'electric-help-mode-hook) - ) - -;;;###autoload -(defun with-electric-help (thunk &optional buffer noerase minheight) - "Pop up an \"electric\" help buffer. -The arguments are THUNK &optional BUFFER NOERASE MINHEIGHT. -THUNK is a function of no arguments which is called to initialize the -contents of BUFFER. BUFFER defaults to `*Help*'. BUFFER will be -erased before THUNK is called unless NOERASE is non-nil. THUNK will -be called while BUFFER is current and with `standard-output' bound to -the buffer specified by BUFFER. - -If THUNK returns nil, we display BUFFER starting at the top, and -shrink the window to fit. If THUNK returns non-nil, we don't do those things. - -After THUNK has been called, this function \"electrically\" pops up a window -in which BUFFER is displayed and allows the user to scroll through that buffer -in electric-help-mode. The window's height will be at least MINHEIGHT if -this value is non-nil. - -If THUNK returns nil, we display BUFFER starting at the top, and -shrink the window to fit. If THUNK returns non-nil, we don't do those -things. - -When the user exits (with `electric-help-exit', or otherwise) the help -buffer's window disappears (i.e., we use `save-window-excursion') -BUFFER is put into `default-major-mode' (or `fundamental-mode') when we exit." - (setq buffer (get-buffer-create (or buffer "*Help*"))) - (let ((one (one-window-p t)) - (config (current-window-configuration)) - (bury nil) - (electric-help-form-to-execute nil)) - (unwind-protect - (save-excursion - (if one (goto-char (window-start (selected-window)))) - (let ((pop-up-windows t)) - (pop-to-buffer buffer)) - (save-excursion - (set-buffer buffer) - (if (and minheight (< (window-height) minheight)) - (enlarge-window (- minheight (window-height)))) - (electric-help-mode) - (setq buffer-read-only nil) - (or noerase - (erase-buffer))) - (let ((standard-output buffer)) - (if (not (funcall thunk)) - (progn - (set-buffer buffer) - (set-buffer-modified-p nil) - (goto-char (point-min)) - (if one (shrink-window-if-larger-than-buffer (selected-window)))))) - (set-buffer buffer) - (run-hooks 'electric-help-mode-hook) - (setq buffer-read-only t) - (if (eq (car-safe - ;; XEmacs: Don't be screwed by minor-modes (view-minor-mode) - (let ((overriding-local-map electric-help-map)) - (electric-help-command-loop))) - 'retain) - (setq config (current-window-configuration)) - (setq bury t))) - (message "") - (set-buffer buffer) - (setq buffer-read-only nil) - (condition-case () - (funcall (or default-major-mode 'fundamental-mode)) - (error nil)) - (set-window-configuration config) - (if bury - (progn - ;;>> Perhaps this shouldn't be done. - ;; so that when we say "Press space to bury" we mean it - (replace-buffer-in-windows buffer) - ;; must do this outside of save-window-excursion - (bury-buffer buffer))) - (eval electric-help-form-to-execute)))) - -(defun electric-help-command-loop () - (catch 'exit - (if (pos-visible-in-window-p (point-max)) - (progn (message "%s" (substitute-command-keys "<<< Press Space to bury the help buffer, Press \\[electric-help-retain] to retain it >>>")) - ;; XEmacs change - (if (equal (setq unread-command-events - (list (next-command-event))) - '(?\ )) - (progn (setq unread-command-events nil) - (throw 'exit t))))) - (let (up down both neither - (standard (and (eq (key-binding " ") - 'scroll-up) - (eq (key-binding "\^?") - 'scroll-down) - (eq (key-binding "q") - 'electric-help-exit) - (eq (key-binding "r") - 'electric-help-retain)))) - (Electric-command-loop - 'exit - (function (lambda () - (sit-for 0) ;necessary if last command was end-of-buffer or - ;beginning-of-buffer - otherwise pos-visible-in-window-p - ;will yield a wrong result. - (let ((min (pos-visible-in-window-p (point-min))) - (max (pos-visible-in-window-p (point-max)))) - (cond (isearch-mode 'noprompt) - ((and min max) - (cond (standard "Press q to exit, r to retain ") - (neither) - (t (setq neither (substitute-command-keys "Press \\[electric-help-exit] to exit, \\[electric-help-retain] to retain "))))) - (min - (cond (standard "Press SPC to scroll, q to exit, r to retain ") - (up) - (t (setq up (substitute-command-keys "Press \\[scroll-up] to scroll, \\[electric-help-exit] to exit, \\[electric-help-retain] to retain "))))) - (max - (cond (standard "Press DEL to scroll back, q to exit, r to retain ") - (down) - (t (setq down (substitute-command-keys "Press \\[scroll-down] to scroll back, \\[electric-help-exit] to exit, \\[electric-help-retain] to retain "))))) - (t - (cond (standard "Press SPC to scroll, DEL to scroll back, q to exit, r to retain ") - (both) - (t (setq both (substitute-command-keys "Press \\[scroll-up] to scroll, \\[scroll-down] to scroll back, \\[electric-help-exit] to exit, \\[electric-help-retain] to retain "))))))))) - t)))) - - - -;(defun electric-help-scroll-up (arg) -; ">>>Doc" -; (interactive "P") -; (if (and (null arg) (pos-visible-in-window-p (point-max))) -; (electric-help-exit) -; (scroll-up arg))) - -(defun electric-help-exit () - ">>>Doc" - (interactive) - (throw 'exit t)) - -(defun electric-help-retain () - "Exit `electric-help', retaining the current window/buffer configuration. -\(The *Help* buffer will not be selected, but \\[switch-to-buffer-other-window] RET -will select it.)" - (interactive) - ;; Make sure that we don't throw twice, even if two events cause - ;; calling this function: - (if (memq 'electric-help-retain mouse-leave-buffer-hook) - (progn - (remove-hook 'mouse-leave-buffer-hook 'electric-help-retain) - (throw 'exit '(retain))))) - - -(defun electric-help-undefined () - (interactive) - (error "%s is undefined -- Press %s to exit" - (mapconcat 'single-key-description (this-command-keys) " ") - (if (eq (key-binding "q") 'electric-help-exit) - "q" - (substitute-command-keys "\\[electric-help-exit]")))) - - -;>>> this needs to be hairified (recursive help, anybody?) -(defun electric-help-help () - (interactive) - (if (and (eq (key-binding "q") 'electric-help-exit) - (eq (key-binding " ") 'scroll-up) - (eq (key-binding "\^?") 'scroll-down) - (eq (key-binding "r") 'electric-help-retain)) - (message "SPC scrolls up, DEL scrolls down, q exits burying help buffer, r exits") - (message "%s" (substitute-command-keys "\\[scroll-up] scrolls up, \\[scroll-down] scrolls down, \\[electric-help-exit] exits burying help buffer, \\[electric-help-retain] exits"))) - (sit-for 2)) - - -;;;###autoload -(defun electric-helpify (fun &optional name) - (let ((name (or name "*Help*"))) - (if (save-window-excursion - ;; kludge-o-rama - (let* ((p (symbol-function 'print-help-return-message)) - (b (get-buffer name)) - (m (buffer-modified-p b))) - (and b (not (get-buffer-window b)) - (setq b nil)) - (unwind-protect - (progn - (message "%s..." (capitalize (symbol-name fun))) - ;; with-output-to-temp-buffer marks the buffer as unmodified. - ;; kludging excessively and relying on that as some sort - ;; of indication leads to the following abomination... - ;;>> This would be doable without such icky kludges if either - ;;>> (a) there were a function to read the interactive - ;;>> args for a command and return a list of those args. - ;;>> (To which one would then just apply the command) - ;;>> (The only problem with this is that interactive-p - ;;>> would break, but that is such a misfeature in - ;;>> any case that I don't care) - ;;>> It is easy to do this for emacs-lisp functions; - ;;>> the only problem is getting the interactive spec - ;;>> for subrs - ;;>> (b) there were a function which returned a - ;;>> modification-tick for a buffer. One could tell - ;;>> whether a buffer had changed by whether the - ;;>> modification-tick were different. - ;;>> (Presumably there would have to be a way to either - ;;>> restore the tick to some previous value, or to - ;;>> suspend updating of the tick in order to allow - ;;>> things like momentary-string-display) - (and b - (save-excursion - (set-buffer b) - (set-buffer-modified-p t))) - (fset 'print-help-return-message 'ignore) - (call-interactively fun) - (and (get-buffer name) - (get-buffer-window (get-buffer name)) - (or (not b) - (not (eq b (get-buffer name))) - (not (buffer-modified-p b))))) - (fset 'print-help-return-message p) - (and b (buffer-name b) - (save-excursion - (set-buffer b) - (set-buffer-modified-p m)))))) - (with-electric-help 'ignore name t)))) - - - -;; This is to be bound to M-x in ehelp mode. Retains ehelp buffer and then -;; continues with execute-extended-command. -(defun electric-help-execute-extended (prefixarg) - (interactive "p") - (setq electric-help-form-to-execute '(execute-extended-command nil)) - (electric-help-retain)) - -;; This is to be buond to C-x in ehelp mode. Retains ehelp buffer and then -;; continues with ctrl-x prefix. -(defun electric-help-ctrl-x-prefix (prefixarg) - (interactive "p") - (setq electric-help-form-to-execute '(progn (message nil) (setq unread-command-char ?\C-x))) - (electric-help-retain)) - - -(defun electric-describe-key () - (interactive) - (electric-helpify 'describe-key)) - -(defun electric-describe-mode () - (interactive) - (electric-helpify 'describe-mode)) - -(defun electric-view-lossage () - (interactive) - (electric-helpify 'view-lossage)) - -;(defun electric-help-for-help () -; "See help-for-help" -; (interactive) -; ) - -(defun electric-describe-function () - (interactive) - (electric-helpify 'describe-function)) - -(defun electric-describe-variable () - (interactive) - (electric-helpify 'describe-variable)) - -(defun electric-describe-bindings () - (interactive) - (electric-helpify 'describe-bindings)) - -(defun electric-describe-syntax () - (interactive) - (electric-helpify 'describe-syntax)) - -(defun electric-command-apropos () - (interactive) - (electric-helpify 'command-apropos "*Apropos*")) - -;(define-key help-map "a" 'electric-command-apropos) - -(defun electric-apropos () - (interactive) - (electric-helpify 'apropos)) - - -;;;; ehelp-map - -(defvar ehelp-map ()) -(if ehelp-map - nil - ;; #### WTF? Why don't we just use substitute-key-definition - ;; like FSF does? - (let ((shadow '((apropos . electric-apropos) - (command-apropos . electric-command-apropos) - (describe-key . electric-describe-key) - (describe-mode . electric-describe-mode) - (view-lossage . electric-view-lossage) - (describe-function . electric-describe-function) - (describe-variable . electric-describe-variable) - (describe-bindings . electric-describe-bindings) - (describe-syntax . electric-describe-syntax))) - (map (make-sparse-keymap))) - (set-keymap-name map 'ehelp-map) - (set-keymap-parents map (list help-map)) - ;; Shadow bindings which would be inherited from help-map - ;;#### This doesn't descend into sub-keymaps - (map-keymap (function (lambda (key binding) - (let ((tem (assq binding shadow))) - (if tem - (define-key map key (cdr tem)))))) - help-map) - (setq ehelp-map map) - (fset 'ehelp-command map))) - -;; Do (define-key global-map "\C-h" 'ehelp-command) if you want to win - -(provide 'ehelp) - -;;; ehelp.el ends here
--- a/lisp/electric/electric.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,210 +0,0 @@ -;;; electric.el --- window maker and Command loop for `electric' modes. - -;; Copyright (C) 1985, 1986, 1995 Free Software Foundation, Inc. - -;; Author: K. Shane Hartman -;; Maintainer: FSF -;; Keywords: extensions - -;; 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.34. - -;;; Commentary: - -; zaaaaaaap - -;;; Code: - -;; This loop is the guts for non-standard modes which retain control -;; until some event occurs. It is a `do-forever', the only way out is -;; to throw. It assumes that you have set up the keymap, window, and -;; everything else: all it does is read commands and execute them - -;; providing error messages should one occur (if there is no loop -;; function - which see). The required argument is a tag which should -;; expect a value of nil if the user decides to punt. The second -;; argument is the prompt to be used: if nil, use "->", if 'noprompt, -;; don't use a prompt, if a string, use that string as prompt, and if -;; a function of no variable, it will be evaluated in every iteration -;; of the loop and its return value, which can be nil, 'noprompt or a -;; string, will be used as prompt. Given third argument non-nil, it -;; INHIBITS quitting unless the user types C-g at toplevel. This is -;; so user can do things like C-u C-g and not get thrown out. Fourth -;; argument, if non-nil, should be a function of two arguments which -;; is called after every command is executed. The fifth argument, if -;; provided, is the state variable for the function. If the -;; loop-function gets an error, the loop will abort WITHOUT throwing -;; (moral: use unwind-protect around call to this function for any -;; critical stuff). The second argument for the loop function is the -;; conditions for any error that occurred or nil if none. - -(defun Electric-command-loop (return-tag - &optional prompt inhibit-quit - loop-function loop-state) - - (let (cmd - (err nil) - (electrified-buffer (current-buffer)) ; XEmacs - - (prompt-string prompt)) - (while t - (if (not (or (stringp prompt) (eq prompt nil) (eq prompt 'noprompt))) - (setq prompt-string (funcall prompt))) - (if (not (stringp prompt-string)) - (if (eq prompt-string 'noprompt) - (setq prompt-string nil) - (setq prompt-string "->"))) - (setq cmd (read-key-sequence prompt-string)) - ;; XEmacs - (or prefix-arg (setq last-command this-command)) - (setq last-command-event (aref cmd (1- (length cmd))) - current-mouse-event - (and (or (button-press-event-p last-command-event) - (button-release-event-p last-command-event) - (misc-user-event-p last-command-event)) - last-command-event) - this-command (if (misc-user-event-p last-command-event) - last-command-event - (key-binding cmd t)) - cmd this-command) - ;; This makes universal-argument-other-key work. - (setq universal-argument-num-events 0) - (if (or (prog1 quit-flag (setq quit-flag nil)) - ;; XEmacs - (eq (event-to-character last-input-event) (quit-char))) - (progn (setq unread-command-events nil - prefix-arg nil) - ;; If it wasn't cancelling a prefix character, then quit. - (if (or (= (length (this-command-keys)) 1) - (not inhibit-quit)) ; safety - (progn (ding nil 'quit) ; XEmacs - - (message "Quit") - (throw return-tag nil)) - (setq cmd nil)))) - (setq current-prefix-arg prefix-arg) - (if cmd - (condition-case conditions - ;; XEmacs - (progn (if (eventp cmd) - (progn - (let ((b (current-buffer))) - (dispatch-event cmd) - (if (not (eq b (current-buffer))) - (throw return-tag (current-buffer))))) - (command-execute cmd)) - (setq last-command this-command) - (if (or (prog1 quit-flag (setq quit-flag nil)) - ;; XEmacs - (eq (event-to-character last-input-event) - (quit-char))) - (progn (setq unread-command-events nil) - (if (not inhibit-quit) - ;; XEmacs - (progn (ding nil 'quit) - (message "Quit") - (throw return-tag nil)) - (message "Quit inhibited") - (ding))))) - (buffer-read-only (if loop-function - (setq err conditions) - (ding) - (message "Buffer is read-only") - (sit-for 2))) - (beginning-of-buffer (if loop-function - (setq err conditions) - (ding) - (message "Beginning of Buffer") - (sit-for 2))) - (end-of-buffer (if loop-function - (setq err conditions) - (ding) - (message "End of Buffer") - (sit-for 2))) - (error (if loop-function - (setq err conditions) - (ding) - (message "Error: %s" - (if (eq (car conditions) 'error) - (car (cdr conditions)) - (prin1-to-string conditions))) - (sit-for 2)))) - (ding)) - (and (not (eq (current-buffer) electrified-buffer)) ; XEmacs - - (not (eq (selected-window) (minibuffer-window))) - (progn (ding nil 'quit) - (message "Leaving electric command loop %s." - "because buffer has changed") - (sit-for 2) - (throw return-tag nil))) - (if loop-function (funcall loop-function loop-state err)))) - ;; XEmacs - huh? It should be impossible to ever get here... - (ding nil 'alarm) - (throw return-tag nil)) - -;; This function is like pop-to-buffer, sort of. -;; The algorithm is -;; If there is a window displaying buffer -;; Select it -;; Else if there is only one window -;; Split it, selecting the window on the bottom with height being -;; the lesser of max-height (if non-nil) and the number of lines in -;; the buffer to be displayed subject to window-min-height constraint. -;; Else -;; Switch to buffer in the current window. -;; -;; Then if max-height is nil, and not all of the lines in the buffer -;; are displayed, grab the whole frame. -;; -;; Returns selected window on buffer positioned at point-min. - -(defun Electric-pop-up-window (buffer &optional max-height) - (let* ((win (or (get-buffer-window buffer) (selected-window))) - (buf (get-buffer buffer)) - (one-window (one-window-p t)) - (pop-up-windows t) - (target-height) - (lines)) - (if (not buf) - (error "Buffer %s does not exist" buffer) - (save-excursion - (set-buffer buf) - (setq lines (count-lines (point-min) (point-max))) - (setq target-height - (min (max (if max-height (min max-height (1+ lines)) (1+ lines)) - window-min-height) - (save-window-excursion - (delete-other-windows) - (1- (window-height (selected-window))))))) - (cond ((and (eq (window-buffer win) buf)) - (select-window win)) - (one-window - (goto-char (window-start win)) - (pop-to-buffer buffer) - (setq win (selected-window)) - (enlarge-window (- target-height (window-height win)))) - (t - (switch-to-buffer buf))) - (if (and (not max-height) - (> target-height (window-height (selected-window)))) - (progn (goto-char (window-start win)) - (enlarge-window (- target-height (window-height win))))) - (goto-char (point-min)) - win))) - -(provide 'electric) - -;;; electric.el ends here
--- a/lisp/electric/helper.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,159 +0,0 @@ -;;; helper.el --- utility help package supporting help in electric modes - -;; Copyright (C) 1985 Free Software Foundation, Inc. - -;; Author: K. Shane Hartman -;; Maintainer: FSF -;; Keywords: help - -;; 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.34. - -;;; Code: - -;; hey, here's a helping hand. - -;; Bind this to a string for <blank> in "... Other keys <blank>". -;; Helper-help uses this to construct help string when scrolling. -;; Defaults to "return" -(defvar Helper-return-blurb nil) - -;; Keymap implementation doesn't work too well for non-standard loops. -;; But define it anyway for those who can use it. Non-standard loops -;; will probably have to use Helper-help. You can't autoload the -;; keymap either. - - -(defvar Helper-help-map nil) -(if Helper-help-map - nil - (setq Helper-help-map (make-keymap)) - ;(fillarray Helper-help-map 'undefined) - (define-key Helper-help-map "m" 'Helper-describe-mode) - (define-key Helper-help-map "b" 'Helper-describe-bindings) - (define-key Helper-help-map "c" 'Helper-describe-key-briefly) - (define-key Helper-help-map "k" 'Helper-describe-key) - ;(define-key Helper-help-map "f" 'Helper-describe-function) - ;(define-key Helper-help-map "v" 'Helper-describe-variable) - (define-key Helper-help-map "?" 'Helper-help-options) - (define-key Helper-help-map (vector help-char) 'Helper-help-options) - (fset 'Helper-help-map Helper-help-map)) - -(defun Helper-help-scroller () - (let ((blurb (or (and (boundp 'Helper-return-blurb) - Helper-return-blurb) - "return"))) - (save-window-excursion - (goto-char (window-start (selected-window))) - (if (get-buffer-window "*Help*") - (pop-to-buffer "*Help*") - (switch-to-buffer "*Help*")) - (goto-char (point-min)) - (let ((continue t) state) - (while continue - (setq state (+ (* 2 (if (pos-visible-in-window-p (point-max)) 1 0)) - (if (pos-visible-in-window-p (point-min)) 1 0))) - (message - (nth state - '("Space forward, Delete back. Other keys %s" - "Space scrolls forward. Other keys %s" - "Delete scrolls back. Other keys %s" - "Type anything to %s")) - blurb) - (setq continue (read-char)) - (cond ((and (memq continue '(?\ ?\C-v)) (< state 2)) - (scroll-up)) - ((= continue ?\C-l) - (recenter)) - ((and (= continue ?\177) (zerop (% state 2))) - (scroll-down)) - (t (setq continue nil)))))))) - -(defun Helper-help-options () - "Describe help options." - (interactive) - (message "c (key briefly), m (mode), k (key), b (bindings)") - ;(message "c (key briefly), m (mode), k (key), v (variable), f (function)") - (sit-for 4)) - -(defun Helper-describe-key-briefly (key) - "Briefly describe binding of KEY." - (interactive "kDescribe key briefly: ") - (describe-key-briefly key) - (sit-for 4)) - -(defun Helper-describe-key (key) - "Describe binding of KEY." - (interactive "kDescribe key: ") - (save-window-excursion (describe-key key)) - (Helper-help-scroller)) - -(defun Helper-describe-function () - "Describe a function. Name read interactively." - (interactive) - (save-window-excursion (call-interactively 'describe-function)) - (Helper-help-scroller)) - -(defun Helper-describe-variable () - "Describe a variable. Name read interactively." - (interactive) - (save-window-excursion (call-interactively 'describe-variable)) - (Helper-help-scroller)) - -(defun Helper-describe-mode () - "Describe the current mode." - (interactive) - (let ((name mode-name) - (documentation (documentation major-mode))) - (save-excursion - (set-buffer (get-buffer-create "*Help*")) - (erase-buffer) - (insert name " Mode\n" documentation) - (help-mode))) - (Helper-help-scroller)) - -;;;###autoload -(defun Helper-describe-bindings () - "Describe local key bindings of current mode." - (interactive) - (message "Making binding list...") - (save-window-excursion (describe-bindings)) - (Helper-help-scroller)) - -;;;###autoload -(defun Helper-help () - "Provide help for current mode." - (interactive) - (let ((continue t) c) - (while continue - (message "Help (Type ? for further options)") - (setq c (read-key-sequence nil)) - (setq c (lookup-key Helper-help-map c)) - (cond ((eq c 'Helper-help-options) - (Helper-help-options)) - ((commandp c) - (call-interactively c) - (setq continue nil)) - (t - (ding) - (setq continue nil)))))) - -(provide 'helper) - -;;; helper.el ends here
--- a/lisp/eos/sun-eos-toolbar.el Mon Aug 13 10:03:54 2007 +0200 +++ b/lisp/eos/sun-eos-toolbar.el Mon Aug 13 10:04:58 2007 +0200 @@ -14,7 +14,7 @@ ;;; Code: (defvar eos::toolbar-icon-directory - (file-name-as-directory (expand-file-name "eos" data-directory))) + (file-name-as-directory (locate-data-directory "eos"))) (defvar eos::toolbar-run-icon (if (featurep 'xpm)
--- a/lisp/eterm/ChangeLog Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,149 +0,0 @@ -1997-09-30 SL Baur <steve@altair.xemacs.org> - - * term.el (term-mode): Use window-displayed-height instead of - window-height. - (term-check-size): Ditto. - From Glynn Clements <glynn@sensei.co.uk> - -1997-06-04 Steven L Baur <steve@altair.xemacs.org> - - * term.el (make-term): Fix docstring. - -Sun Dec 22 00:38:46 1996 Sudish Joseph <sudish@mindspring.com> - - * tgud.el (tgud-gdb-complete-filter): Match carriage returns as - well as line feeds. - -Tue Jun 13 16:38:40 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * term.el: Various optimizations. The main one is to optimize for - simple output at the end of the buffer, with no paging, and in that - case to defer scrolling while we can. - (term-emulate-terminal): Don't call term-handle-scroll in - simple cases unless we are either paging or term-scroll-with-delete. - (term-down): Likewise. - (term-handle-scroll): Modify accordingly. - (term-emulate-terminal): Avoid deleting old text in common case. - Optimize the simple case of CRLF when we're at buffer end. - Handle deferred scroll when done processing output. - (term-handle-deferred-scroll): New function. - (term-down): Simplify - no longer take RIGHT argument. Tune. - (term-goto): Use term-move-columns to compensate for the above. - -Sat Jun 10 23:10:52 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * term.el (term-escape-char, term-set-escape-char): Add doc-string. - (term-mouse-paste): Add xemacs support. - - * term.el: Various speed enhencements: - (term-handle-scroll): Don't clear term-current-row; maybe adjust it. - (term-down): Don't call term-adjust-current-row-cache if we've - done term-handle-scroll. - (term-emulate-terminal): Don't call term-adjust-current-row-cache. - (term-emulate-terminal): For TAB, don't nil term-start-line-column. - (term-goto): Possible optimization. - -Wed Mar 15 17:20:26 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * term.el (term-mouse-paste): Make work for xemacs-19.11. - For GNU emacs, don't mouse-set-point, but do - run-hooks on mouse-leave-buffer-hook, - - * term.el (term-char-mode): Fix paren error that caused - the arrow keys to not be recognized under xemacs. - Also, simplify/fix [(button2)] to [button2] for paste under xemacs. - -Tue Mar 7 16:43:51 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * term.el (term-eol-on-send): New variable. - (term-send-input): Move point to eol before sending only if - term-eol-on-send is true. - - * term.el (term-send-input): Don't move process-mark until - after possible 'history processing. - -Tue Feb 7 02:59:59 1995 Richard Stallman <rms@pogo.gnu.ai.mit.edu> - - * term.el (term-protocol-version): Renamed from term-version. - -Sat Feb 4 16:23:18 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * term.el (term-version): Increased to 0.95. - (term-pager-enabled): New macro. Use it a bunch of places. - (term-terminal-menu): Clean up initialization so we don't get - complaints when re-loading term.el. - (term-send-raw-meta): Redo to handle meta-symbols (e.g. meta-delete). - More robust checking of parameter to make-string. - (term-update-mode-line): New function. Call it whenever we change - char/line/paging mode. Now includes "page" in mode-line-process - if paging is abled. - - * term.el: Remove causes for byte-compilation to complain: - (term-terminal-pos): Declare x and y in let-binding. - (term-send-invisible): Remove bogus second "iteractive" call. - (term-*): Provide defvars for lots of buffer-local variables. - (term-mode): Make comments and initial value setting from - here to the corresponding defvar. - (term-line-start-column): Remove unused variable. - (term-erase-in-line): Fix syntax (incorrect parenthesis) error. - (term-erase-in-display): Fix typo "\?n" -> "?\n". - - * term.el: Make Unix "resize" command work: - (term-handle-ansi-escape): On "\e[row;colH", limit row - and col to size of window. (Resize sends "999;999".) - (term-handle-ansi-escape): Implement "\e[6n" "Report cursor - position". This requires that we pass proc as an extra parameter. - (term-scroll-region): An empty region means extend to window bottom. - -Fri Jan 20 14:07:31 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * term.el (term-version): Increased to 0.94. - (term-if-emacs19, term-if-xemacs, term-ifnot-xemacs): New macros - to conditionalize at compile-time for different emacs versions. - (various places): Use them (instead of term-is-XXXX). - (term-is-emacs19): Removed, no longer needed. - - * term.el: Change keybindings to not use C-c LETTER, for - term-char-mode, term-line-mode. Keybindings for term-pager-enable - and term-pager-disable replaced by one for term-pager-toggle. - (term-pager-toggle): New function. - - * term.el (term-fake-pager-enable, term-fake-pager-disable): - Define as aliases, so that menubar code will find proper keybindings. - (term-char-mode): Make no-op if already in char mode. - (term-line-mode): Make no-op if already in line mode. - (term-mode-map): Add keybinding for no-op term-line-mode, so - code to display menubar keybindings doesn't lose it. (Needed - as long as char-mode and line-mode share term-terminal-menu.) - (term-raw-escape-map): Likewise for term-char-mode. - (term-char-mode, term-line-mode): Better documentation strings. - - * term.el: Added menubar for pager sub-mode. - -Wed Jan 11 17:06:37 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * term.el (term-command-hook): Disabled the feature that allowed - inferior to send a lisp command to emacs - too big a security hole. - -Mon Nov 21 12:38:05 1994 Per Bothner <bothner@kalessin.cygnus.com> - - * term.el (term-termcap-format): Add cd capability. Fix ei. - (term-exec-1): Pass $TERMINFO instead of $TERMCAP if appropriate. - (term-exec-1): Pass emacs-version and term-version in $TERM. - (term-exec-1): Re-write to set process-environment. - -Sun Jun 26 20:31:52 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * term.el: Set version number to 0.92. - * term.el (term): New top-level function. - -Tue May 17 11:45:21 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * term.el (term-emulate-terminal): Move most of the scrolling - and other final actions inside the body of the unwind-protect. - But make sure to select the original selected window in the - cleanup actions. Bug reported by David Hampton <hampton@cisco.com>. - - * term.el (term-emulate-terminal): Ignore ?\016 (Shift Out) - and ?\017 (Shift In). (These are produced by the Lynx WWW-viewer.) -
--- a/lisp/eterm/QUESTIONS Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,29 +0,0 @@ -- What should be the default escape key for char mode? - Currently; I'm using ^C. - -- What other keybindings should we have for char mode? - -- What terminal type should we use? - The old shell.el defined TERM=emacs. - To avoid confusion, we should use something different. (E.g. if TERM - is "emacs", bash turns off editing, which is not what we want.) - I'm currently using TERM=emacs-terminal. - This is somewhat verbose. - Other ideas: TERM=eterm TERM=emacsterm TERM=emacst. - -- How should buffer-local variables be defined and documented? - -; Features in comint.el not supported: -; comint-scroll-to-bottom-on-input -; comint-process-echoes (would be always true) -; comint-password-prompt-regexp (not useful) -; comint-watch-for-password-prompt (not useful) -; comint-eol-on-send -; comint-run -; comint-preinput-scroll-to-bottom -; comint-postoutput-scroll-to-bottom (inlined into term-emulate-terminal). - -; Should set EMACS env var to emacs-version? -; Should set TERM to vt100 if using terminfo? -; Should we set COLUMNS if using terminfo? -; New C-c kodes?
--- a/lisp/eterm/README.term Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,84 +0,0 @@ -This new term-mode is a merge of the comint shell mode with a -ANSI-compatible terminal-emulator. - -If you're using emacs-19.23 (or newer) or xemacs-19.11 (or newer), -and only want the terminal-emulator itself, just load the file -term.el. (You probably want to byte-compile it first, especially -if you have a slow machine.) - -To start term do M-x term RETURN. - -Compared to terminal.el: -* Uses standard ANSI (vt102) escape sequences. -* High-lighting (inverse video, underline, bold) are supported. -* Fully integrated into shell mode. -* Can switch back and forth between character mode (acts like xterm) - and line mode (acts like old shell mode). -* Tab and line breaks are stored in buffer (so cut and paste will get - the correct tabs and line breaks), but terminal motion uses the - "visible" layout of the screen (and display programs can assume - tab, cr and lf work as on plain terminal). - -In character ("raw") sub-mode: -Each character type is sent to the inferior process, except for C-c. -C-c C-c Send a C-c to the inferior. -C-c C-j Enter line sub-mode -C-c OTHER Same as cooked C-x map -Can use bash line editing, filename completion, and history. -Can run emacs in an emacs window! (bash users first do: export -n DISPLAY) - -In line ("cooked") mode: -Like traditional shell mode -C-c C-k Enter character sub-mode - -Either character or line sub-mode: -C-c C-q Toggle pager sub-mode (enable or disable) -The "pager" provides functionality similar to the "more" program: -Whenever a screenful has been received, emacs stops reading from -the process until you type the appropriate key. (The key 'h' provides help.) -The pager is smart enough that you can leave it on, even while -running full-screen interactive programs inside a shell window. -(The pager does not work under xemacs 19.11.) - -The file tshell.el is a preliminary replacement for shell mode. -After loading it, you invoke it with M-x tshell RET. -This needs a little work, and is not recommended. It differs from -term-mode in that it starts in line mode, and it performs directory -tracking. Such directory tracking cannot be made reliable. -It you're running bash, it is better to just use term-mode and have -bash tell term the current directory. You can do that by adding -the following to your ~/.bashrc: - - if [ "$TERM" = "eterm" ]; then - PROMPT_COMMAND='echo "/${PWD}"' - fi - -The file tgud.el is a preliminary replacement for gud.el, including -gdb-mode. After loading it, invoke "tgdb-mode" with M-x tgdb RET. - -An alternative is to run gdb from term (or tshell) mode. -Just start gdb with the --fullname flag. This will cause gdb to -ask emacs to display proper source frame on break-points - -even over a telnet/rlogin link! You would not be able to use the -gud-specific commands, but you can use gdb/readline line editing. - -If you're using terminfo, copy the e directory (itself, not just -the files in it) into the emacs 'etc' directory (as given by -ESC ESC data-directory RET), so you have ..../etc/e/eterm. -(Your system uses terminfo if ESC ESC (boundp 'system-uses-terminfo) RET -return t.) If you can't do that, replace the word "data-directory" -in term.el by a string naming this directory. - -The file TODO.term notes ideas for improvements. - -The file term.texi contain some notes that one day may become part -of a manual. - -Term.el will be in the next emacs release from the FSF. -It will also probably be in the next xemacs release. -The comint-based shell.el and gud.el will be replaced later. -Telnet.el can then be junked. -Long-term, term.el will replace comint.el, but can co-exist with it. - -Comments and bug fixes should be sent to Per Bothner (bothner@cygnus.com). -Note that I'm new to emacs hacking, so improvements are very welcome.
--- a/lisp/eterm/TODO.term Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,48 +0,0 @@ -* Define a sentinel function, so that the display doesn't get -screwed up the default sentinel when the process finishes. - -* Performance improvements? (It is zippy enough on reasonably -fast machines, though.) - -* Should more terminal escape sequences be supported? -Yes: At least the ANSI color escapes (as in colour_xterm). - -* The caching variables (e.g. term-current-row) assume that there -is be no random editing of the buffer that we don't know about. In that -respect, they are somewhat fragile. - -* Document the internals better, and make it easier to write -emulators for other kinds of terminals. - -* The scrolling behavior is still not quite right. - -* Stallman has expressed dislike for the xterm style of switching to the -alternate buffer on the "ti" capability. An alternative would be to -defer this until the screen is cleared. That assumes there are programs -that emit ti without following that by a command to erase the window. -I'm not sure there are any such programs (that we care about) ... - -*** CHANGES THAT REQUIRE NEW EMACS PRIMITIVES *** - -* If ioctl is made accessible to elisp, it may be possible -to support some kind of automatic switching between char mode -and line mode. It also becomes possible to privide term -primitives to turn off echoing in the inferior. - -*** CHANGES TO DO IN OTHER PROGRAMS *** - -* In gdb-mode, a keysequence like \C-c\C-s works by sending the command -"step" in gdb-mode. Emacs goes to a fair bit of trouble to delete the -prompt preceding the command, as well as the echo from the inferior. -In addition to being hairy, it is somewhat fragile (because of possible -type-ahead, and because the inferior might be mixing other output with -the echo). -More robust would be for emacs to send the command "noecho step" (or -"step #noecho") where the "noecho" is an instruction to gdb (readline) -to erase the prompt for this command, and suppress its echo. - -* Bash (and perhaps other shells) should be modified so that before -the prompt (and PROMPT_COMMAND) are printed, they emit: - printf("\032/%s\n", PWD); -This will tell the shell window which directory it should assume, -and obviates the need for all that hairy directory tracking.
--- a/lisp/eterm/auto-autoloads.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,87 +0,0 @@ -;;; DO NOT MODIFY THIS FILE -(if (featurep 'eterm-autoloads) (error "Already loaded")) - -;;;### (autoloads (term make-term) "term" "eterm/term.el") - -(autoload 'make-term "term" "\ -Make a term process NAME in a buffer, running PROGRAM. -The name of the buffer is made by surrounding NAME with `*'s. -If there is already a running process in that buffer, it is not restarted. -Optional third arg STARTFILE is the name of a file to send the contents of to -the process. Any more args are arguments to PROGRAM." nil nil) - -(autoload 'term "term" "\ -Start a terminal-emulator in a new buffer." t nil) - -;;;*** - -;;;### (autoloads (tperldb txdb tdbx tsdb tgdb) "tgud" "eterm/tgud.el") - -(autoload 'tgdb "tgud" "\ -Run gdb on program FILE in buffer *tgud-FILE*. -The directory containing FILE becomes the initial working directory -and source-file directory for your debugger." t nil) - -(autoload 'tsdb "tgud" "\ -Run sdb on program FILE in buffer *tgud-FILE*. -The directory containing FILE becomes the initial working directory -and source-file directory for your debugger." t nil) - -(autoload 'tdbx "tgud" "\ -Run dbx on program FILE in buffer *tgud-FILE*. -The directory containing FILE becomes the initial working directory -and source-file directory for your debugger." t nil) - -(autoload 'txdb "tgud" "\ -Run xdb on program FILE in buffer *tgud-FILE*. -The directory containing FILE becomes the initial working directory -and source-file directory for your debugger. - -You can set the variable 'tgud-xdb-directories' to a list of program source -directories if your program contains sources from more than one directory." t nil) - -(autoload 'tperldb "tgud" "\ -Run perldb on program FILE in buffer *tgud-FILE*. -The directory containing FILE becomes the initial working directory -and source-file directory for your debugger." t nil) - -;;;*** - -;;;### (autoloads (tshell) "tshell" "eterm/tshell.el") - -(defvar tshell-prompt-pattern "^[^#$%>\n]*[#$%>] *" "\ -Regexp to match prompts in the inferior shell. -Defaults to \"^[^#$%>\\n]*[#$%>] *\", which works pretty well. -This variable is used to initialise `term-prompt-regexp' in the -shell buffer. - -The pattern should probably not match more than one line. If it does, -tshell-mode may become confused trying to distinguish prompt from input -on lines which don't start with a prompt. - -This is a fine thing to set in your `.emacs' file.") - -(autoload 'tshell "tshell" "\ -Run an inferior shell, with I/O through buffer *shell*. -If buffer exists but shell process is not running, make new shell. -If buffer exists and shell process is running, just switch to buffer `*shell*'. -Program used comes from variable `explicit-shell-file-name', - or (if that is nil) from the ESHELL environment variable, - or else from SHELL if there is no ESHELL. -If a file `~/.emacs_SHELLNAME' exists, it is given as initial input - (Note that this may lose due to a timing error if the shell - discards input when it starts up.) -The buffer is put in Tshell mode, giving commands for sending input -and controlling the subjobs of the shell. See `tshell-mode'. -See also the variable `tshell-prompt-pattern'. - -The shell file name (sans directories) is used to make a symbol name -such as `explicit-csh-args'. If that symbol is a variable, -its value is used as a list of arguments when invoking the shell. -Otherwise, one argument `-i' is passed to the shell. - -\(Type \\[describe-mode] in the shell buffer for a list of commands.)" t nil) - -;;;*** - -(provide 'eterm-autoloads)
--- a/lisp/eterm/custom-load.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,11 +0,0 @@ -;;; custom-load.el --- automatically extracted custom dependencies - - -;;; Code: - -(custom-add-loads 'shell '("term")) -(custom-add-loads 'term '("term")) -(custom-add-loads 'processes '("term")) -(custom-add-loads 'unix '("term")) - -;;; custom-load.el ends here
--- a/lisp/eterm/term.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,3334 +0,0 @@ -;;; term.el --- general command interpreter in a window stuff - -;; Copyright (C) 1988-1995, 1997 Free Software Foundation, Inc. - -;; Author: Per Bothner <bothner@cygnus.com> -;; Based on comint mode written by: Olin Shivers <shivers@cs.cmu.edu> -;; Keyword: processes - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; The changelog is at the end of this file. - -;; Please send me bug reports, bug fixes, and extensions, so that I can -;; merge them into the master source. -;; - Per Bothner (bothner@cygnus.com) - -;; This file defines a general command-interpreter-in-a-buffer package -;; (term mode). The idea is that you can build specific process-in-a-buffer -;; modes on top of term mode -- e.g., lisp, shell, scheme, T, soar, .... -;; This way, all these specific packages share a common base functionality, -;; and a common set of bindings, which makes them easier to use (and -;; saves code, implementation time, etc., etc.). - -;; For hints on converting existing process modes (e.g., tex-mode, -;; background, dbx, gdb, kermit, prolog, telnet) to use term-mode -;; instead of shell-mode, see the notes at the end of this file. - - -;; Brief Command Documentation: -;;============================================================================ -;; Term Mode Commands: (common to all derived modes, like cmushell & cmulisp -;; mode) -;; -;; m-p term-previous-input Cycle backwards in input history -;; m-n term-next-input Cycle forwards -;; m-r term-previous-matching-input Previous input matching a regexp -;; m-s comint-next-matching-input Next input that matches -;; return term-send-input -;; c-c c-a term-bol Beginning of line; skip prompt. -;; c-d term-delchar-or-maybe-eof Delete char unless at end of buff. -;; c-c c-u term-kill-input ^u -;; c-c c-w backward-kill-word ^w -;; c-c c-c term-interrupt-subjob ^c -;; c-c c-z term-stop-subjob ^z -;; c-c c-\ term-quit-subjob ^\ -;; c-c c-o term-kill-output Delete last batch of process output -;; c-c c-r term-show-output Show last batch of process output -;; c-c c-h term-dynamic-list-input-ring List input history -;; -;; Not bound by default in term-mode -;; term-send-invisible Read a line w/o echo, and send to proc -;; (These are bound in shell-mode) -;; term-dynamic-complete Complete filename at point. -;; term-dynamic-list-completions List completions in help buffer. -;; term-replace-by-expanded-filename Expand and complete filename at point; -;; replace with expanded/completed name. -;; term-kill-subjob No mercy. -;; term-show-maximum-output Show as much output as possible. -;; term-continue-subjob Send CONT signal to buffer's process -;; group. Useful if you accidentally -;; suspend your process (with C-c C-z). - -;; term-mode-hook is the term mode hook. Basically for your keybindings. -;; term-load-hook is run after loading in this package. - -;; Code: - -;; This is passed to the inferior in the EMACS environment variable, -;; so it is important to increase it if there are protocol-relevant changes. -(defconst term-protocol-version "0.95") - -(require 'ring) -(require 'ehelp) - -(if (fboundp 'defgroup) nil - (defmacro defgroup (&rest forms) nil) - (defmacro defcustom (name init doc &rest forms) - (list 'defvar name init doc))) - -(defgroup term nil - "General command interpreter in a window" - :group 'processes - :group 'unix) - - -;;; Buffer Local Variables: -;;;============================================================================ -;;; Term mode buffer local variables: -;;; term-prompt-regexp - string term-bol uses to match prompt. -;;; term-delimiter-argument-list - list For delimiters and arguments -;;; term-last-input-start - marker Handy if inferior always echoes -;;; term-last-input-end - marker For term-kill-output command -;; For the input history mechanism: -(defvar term-input-ring-size 32 "Size of input history ring.") -;;; term-input-ring-size - integer -;;; term-input-ring - ring -;;; term-input-ring-index - number ... -;;; term-input-autoexpand - symbol ... -;;; term-input-ignoredups - boolean ... -;;; term-last-input-match - string ... -;;; term-dynamic-complete-functions - hook For the completion mechanism -;;; term-completion-fignore - list ... -;;; term-get-old-input - function Hooks for specific -;;; term-input-filter-functions - hook process-in-a-buffer -;;; term-input-filter - function modes. -;;; term-input-send - function -;;; term-scroll-to-bottom-on-output - symbol ... -;;; term-scroll-show-maximum-output - boolean... -(defvar term-height) ;; Number of lines in window. -(defvar term-width) ;; Number of columns in window. -(defvar term-home-marker) ;; Marks the "home" position for cursor addressing. -(defvar term-saved-home-marker nil) ;; When using alternate sub-buffer, -;; contains saved term-home-marker from original sub-buffer . -(defvar term-start-line-column 0) ;; (current-column) at start of screen line, -;; or nil if unknown. -(defvar term-current-column 0) ;; If non-nil, is cache for (current-column). -(defvar term-current-row 0) ;; Current vertical row (relative to home-marker) -;; or nil if unknown. -(defvar term-insert-mode nil) -(defvar term-vertical-motion) -(defvar term-terminal-state 0) ;; State of the terminal emulator: -;; state 0: Normal state -;; state 1: Last character was a graphic in the last column. -;; If next char is graphic, first move one column right -;; (and line warp) before displaying it. -;; This emulates (more or less) the behavior of xterm. -;; state 2: seen ESC -;; state 3: seen ESC [ (or ESC [ ?) -;; state 4: term-terminal-parameter contains pending output. -(defvar term-kill-echo-list nil) ;; A queue of strings whose echo -;; we want suppressed. -(defvar term-terminal-parameter) -(defvar term-terminal-previous-parameter) -(defvar term-current-face 'default) -(defvar term-scroll-start 0) ;; Top-most line (inclusive) of scrolling region. -(defvar term-scroll-end) ;; Number of line (zero-based) after scrolling region. -(defvar term-pager-count nil) ;; If nil, paging is disabled. -;; Otherwise, number of lines before we need to page. -(defvar term-saved-cursor nil) -(defvar term-command-hook) -(defvar term-log-buffer nil) -(defvar term-scroll-with-delete nil) ;; term-scroll-with-delete is t if -;; forward scrolling should be implemented by delete to -;; top-most line(s); and nil if scrolling should be implemented -;; by moving term-home-marker. It is set to t iff there is a -;; (non-default) scroll-region OR the alternate buffer is used. -(defvar term-pending-delete-marker) ;; New user input in line mode needs to -;; be deleted, because it gets echoed by the inferior. -;; To reduce flicker, we defer the delete until the next output. -(defvar term-old-mode-map nil) ;; Saves the old keymap when in char mode. -(defvar term-old-mode-line-format) ;; Saves old mode-line-format while paging. -(defvar term-pager-old-local-map nil) ;; Saves old keymap while paging. -(defvar term-pager-old-filter) ;; Saved process-filter while paging. - -(defcustom explicit-shell-file-name nil - "*If non-nil, is file name to use for explicitly requested inferior shell." - :type '(choice (const nil) file) - :group 'term) - -(defvar term-prompt-regexp "^" - "Regexp to recognise prompts in the inferior process. -Defaults to \"^\", the null string at BOL. - -Good choices: - Canonical Lisp: \"^[^> \\n]*>+:? *\" (Lucid, franz, kcl, T, cscheme, oaklisp) - Lucid Common Lisp: \"^\\\\(>\\\\|\\\\(->\\\\)+\\\\) *\" - franz: \"^\\\\(->\\\\|<[0-9]*>:\\\\) *\" - kcl: \"^>+ *\" - shell: \"^[^#$%>\\n]*[#$%>] *\" - T: \"^>+ *\" - -This is a good thing to set in mode hooks.") - -(defvar term-delimiter-argument-list () - "List of characters to recognise as separate arguments in input. -Strings comprising a character in this list will separate the arguments -surrounding them, and also be regarded as arguments in their own right (unlike -whitespace). See `term-arguments'. -Defaults to the empty list. - -For shells, a good value is (?\\| ?& ?< ?> ?\\( ?\\) ?;). - -This is a good thing to set in mode hooks.") - -(defcustom term-input-autoexpand nil - "*If non-nil, expand input command history references on completion. -This mirrors the optional behavior of tcsh (its autoexpand and histlit). - -If the value is `input', then the expansion is seen on input. -If the value is `history', then the expansion is only when inserting -into the buffer's input ring. See also `term-magic-space' and -`term-dynamic-complete'. - -This variable is buffer-local." - :type '(choice (const nil) (const t) (const input) (const history)) - :group 'term) - -(defcustom term-input-ignoredups nil - "*If non-nil, don't add input matching the last on the input ring. -This mirrors the optional behavior of bash. - -This variable is buffer-local." - :type 'boolean - :group 'term) - -(defcustom term-input-ring-file-name nil - "*If non-nil, name of the file to read/write input history. -See also `term-read-input-ring' and `term-write-input-ring'. - -This variable is buffer-local, and is a good thing to set in mode hooks." - :type 'boolean - :group 'term) - -(defcustom term-scroll-to-bottom-on-output nil - "*Controls whether interpreter output causes window to scroll. -If nil, then do not scroll. If t or `all', scroll all windows showing buffer. -If `this', scroll only the selected window. -If `others', scroll only those that are not the selected window. - -The default is nil. - -See variable `term-scroll-show-maximum-output'. This variable is buffer-local." - :type '(choice (const :tag "off" nil) - (const t) - (const all) - (const this) - (const others)) - :group 'term) - -(defcustom term-scroll-show-maximum-output nil - "*Controls how interpreter output causes window to scroll. -If non-nil, then show the maximum output when the window is scrolled. - -See variable `term-scroll-to-bottom-on-output'. -This variable is buffer-local." - :type 'boolean - :group 'term) - -;; Where gud-display-frame should put the debugging arrow. This is -;; set by the marker-filter, which scans the debugger's output for -;; indications of the current pc. -(defvar term-pending-frame nil) - -;;; Here are the per-interpreter hooks. -(defvar term-get-old-input (function term-get-old-input-default) - "Function that submits old text in term mode. -This function is called when return is typed while the point is in old text. -It returns the text to be submitted as process input. The default is -term-get-old-input-default, which grabs the current line, and strips off -leading text matching term-prompt-regexp") - -(defvar term-dynamic-complete-functions - '(term-replace-by-expanded-history term-dynamic-complete-filename) - "List of functions called to perform completion. -Functions should return non-nil if completion was performed. -See also `term-dynamic-complete'. - -This is a good thing to set in mode hooks.") - -(defvar term-input-filter - (function (lambda (str) (not (string-match "\\`\\s *\\'" str)))) - "Predicate for filtering additions to input history. -Only inputs answering true to this function are saved on the input -history list. Default is to save anything that isn't all whitespace") - -(defvar term-input-filter-functions '() - "Functions to call before input is sent to the process. -These functions get one argument, a string containing the text to send. - -This variable is buffer-local.") - -(defvar term-input-sender (function term-simple-send) - "Function to actually send to PROCESS the STRING submitted by user. -Usually this is just 'term-simple-send, but if your mode needs to -massage the input string, this is your hook. This is called from -the user command term-send-input. term-simple-send just sends -the string plus a newline.") - -(defcustom term-eol-on-send t - "*Non-nil means go to the end of the line before sending input. -See `term-send-input'." - :type 'boolean - :group 'term) - -(defcustom term-mode-hook '() - "Called upon entry into term-mode -This is run before the process is cranked up." - :type 'hook - :group 'term) - -(defcustom term-exec-hook '() - "Called each time a process is exec'd by term-exec. -This is called after the process is cranked up. It is useful for things that -must be done each time a process is executed in a term-mode buffer (e.g., -\(process-kill-without-query)). In contrast, the term-mode-hook is only -executed once when the buffer is created." - :type 'hook - :group 'term) - -(defvar term-mode-map nil) -(defvar term-raw-map nil - "Keyboard map for sending characters directly to the inferior process.") -(defvar term-escape-char nil - "Escape character for char-sub-mode of term mode. -Do not change it directly; use term-set-escape-char instead.") -(defvar term-raw-escape-map nil) - -(defvar term-pager-break-map nil) - -(defvar term-ptyp t - "True if communications via pty; false if by pipe. Buffer local. -This is to work around a bug in emacs process signaling.") - -(defvar term-last-input-match "" - "Last string searched for by term input history search, for defaulting. -Buffer local variable.") - -(defvar term-input-ring nil) -(defvar term-last-input-start) -(defvar term-last-input-end) -(defvar term-input-ring-index nil - "Index of last matched history element.") -(defvar term-matching-input-from-input-string "" - "Input previously used to match input history.") -; This argument to set-process-filter disables reading from the process, -; assuming this is emacs-19.20 or newer. -(defvar term-pager-filter t) - -(put 'term-replace-by-expanded-history 'menu-enable 'term-input-autoexpand) -(put 'term-input-ring 'permanent-local t) -(put 'term-input-ring-index 'permanent-local t) -(put 'term-input-autoexpand 'permanent-local t) -(put 'term-input-filter-functions 'permanent-local t) -(put 'term-scroll-to-bottom-on-output 'permanent-local t) -(put 'term-scroll-show-maximum-output 'permanent-local t) -(put 'term-ptyp 'permanent-local t) - -;; Do FORMS if running under Emacs-19. -(defmacro term-if-emacs19 (&rest forms) - (if (string-match "^19" emacs-version) (cons 'progn forms))) -;; True if running under XEmacs (previously Lucid emacs). -(defmacro term-is-xemacs () '(string-match "Lucid" emacs-version)) -;; Do FORM if running under XEmacs (previously Lucid emacs). -(defmacro term-if-xemacs (&rest forms) - (if (term-is-xemacs) (cons 'progn forms))) -;; Do FORM if NOT running under XEmacs (previously Lucid emacs). -(defmacro term-ifnot-xemacs (&rest forms) - (if (not (term-is-xemacs)) (cons 'progn forms))) - -(defmacro term-in-char-mode () '(eq (current-local-map) term-raw-map)) -(defmacro term-in-line-mode () '(not (term-in-char-mode))) -;; True if currently doing PAGER handling. -(defmacro term-pager-enabled () 'term-pager-count) -(defmacro term-handling-pager () 'term-pager-old-local-map) -(defmacro term-using-alternate-sub-buffer () 'term-saved-home-marker) - -(defvar term-signals-menu) -(defvar term-terminal-menu) - -(term-if-xemacs - (defvar term-terminal-menu - '("Terminal" - [ "Character mode" term-char-mode (term-in-line-mode)] - [ "Line mode" term-line-mode (term-in-char-mode)] - [ "Enable paging" term-pager-toggle (not term-pager-count)] - [ "Disable paging" term-pager-toggle term-pager-count]))) - -(defun term-mode () - "Major mode for interacting with an inferior interpreter. -Interpreter name is same as buffer name, sans the asterisks. -In line sub-mode, return at end of buffer sends line as input, -while return not at end copies rest of line to end and sends it. -In char sub-mode, each character (except `term-escape-char`) is -set immediately. - -This mode is typically customised to create inferior-lisp-mode, -shell-mode, etc.. This can be done by setting the hooks -term-input-filter-functions, term-input-filter, term-input-sender and -term-get-old-input to appropriate functions, and the variable -term-prompt-regexp to the appropriate regular expression. - -An input history is maintained of size `term-input-ring-size', and -can be accessed with the commands \\[term-next-input], \\[term-previous-input], and \\[term-dynamic-list-input-ring]. -Input ring history expansion can be achieved with the commands -\\[term-replace-by-expanded-history] or \\[term-magic-space]. -Input ring expansion is controlled by the variable `term-input-autoexpand', -and addition is controlled by the variable `term-input-ignoredups'. - -Input to, and output from, the subprocess can cause the window to scroll to -the end of the buffer. See variables `term-scroll-to-bottom-on-input', -and `term-scroll-to-bottom-on-output'. - -If you accidentally suspend your process, use \\[term-continue-subjob] -to continue it. - -\\{term-mode-map} - -Entry to this mode runs the hooks on term-mode-hook" - (interactive) - ;; Do not remove this. All major modes must do this. - (kill-all-local-variables) - (setq major-mode 'term-mode) - (setq mode-name "Term") - (use-local-map term-mode-map) - (make-local-variable 'term-home-marker) - (setq term-home-marker (copy-marker 0)) - (make-local-variable 'term-saved-home-marker) - (make-local-variable 'term-height) - (make-local-variable 'term-width) - (setq term-width (1- (window-width))) - (setq term-height (1- (window-displayed-height))) - (make-local-variable 'term-terminal-parameter) - (make-local-variable 'term-saved-cursor) - (make-local-variable 'term-last-input-start) - (setq term-last-input-start (make-marker)) - (make-local-variable 'term-last-input-end) - (setq term-last-input-end (make-marker)) - (make-local-variable 'term-last-input-match) - (setq term-last-input-match "") - (make-local-variable 'term-prompt-regexp) ; Don't set; default - (make-local-variable 'term-input-ring-size) ; ...to global val. - (make-local-variable 'term-input-ring) - (make-local-variable 'term-input-ring-file-name) - (or (and (boundp 'term-input-ring) term-input-ring) - (setq term-input-ring (make-ring term-input-ring-size))) - (make-local-variable 'term-input-ring-index) - (or (and (boundp 'term-input-ring-index) term-input-ring-index) - (setq term-input-ring-index nil)) - - (make-local-variable 'term-command-hook) - (setq term-command-hook (symbol-function 'term-command-hook)) - - (make-local-variable 'term-terminal-state) - (make-local-variable 'term-kill-echo-list) - (make-local-variable 'term-start-line-column) - (make-local-variable 'term-current-column) - (make-local-variable 'term-current-row) - (make-local-variable 'term-log-buffer) - (make-local-variable 'term-scroll-start) - (make-local-variable 'term-scroll-end) - (setq term-scroll-end term-height) - (make-local-variable 'term-scroll-with-delete) - (make-local-variable 'term-pager-count) - (make-local-variable 'term-pager-old-local-map) - (make-local-variable 'term-old-mode-map) - (make-local-variable 'term-insert-mode) - (make-local-variable 'term-dynamic-complete-functions) - (make-local-variable 'term-completion-fignore) - (make-local-variable 'term-get-old-input) - (make-local-variable 'term-matching-input-from-input-string) - (make-local-variable 'term-input-autoexpand) - (make-local-variable 'term-input-ignoredups) - (make-local-variable 'term-delimiter-argument-list) - (make-local-variable 'term-input-filter-functions) - (make-local-variable 'term-input-filter) - (make-local-variable 'term-input-sender) - (make-local-variable 'term-eol-on-send) - (make-local-variable 'term-scroll-to-bottom-on-output) - (make-local-variable 'term-scroll-show-maximum-output) - (make-local-variable 'term-ptyp) - (make-local-variable 'term-exec-hook) - (make-local-variable 'term-vertical-motion) - (make-local-variable 'term-pending-delete-marker) - (setq term-pending-delete-marker (make-marker)) - (make-local-variable 'term-current-face) - (make-local-variable 'term-pending-frame) - (setq term-pending-frame nil) - (run-hooks 'term-mode-hook) - (term-if-xemacs - (if (fboundp 'add-submenu) - (progn - (set (make-local-variable 'current-menubar) - (copy-sequence current-menubar)) - (add-submenu nil term-terminal-menu)))) - (or term-input-ring - (setq term-input-ring (make-ring term-input-ring-size))) - (term-update-mode-line)) - -(if term-mode-map - nil - (setq term-mode-map (make-sparse-keymap)) - (define-key term-mode-map "\ep" 'term-previous-input) - (define-key term-mode-map "\en" 'term-next-input) - (define-key term-mode-map "\er" 'term-previous-matching-input) - (define-key term-mode-map "\es" 'term-next-matching-input) - (term-ifnot-xemacs - (define-key term-mode-map [?\A-\M-r] 'term-previous-matching-input-from-input) - (define-key term-mode-map [?\A-\M-s] 'term-next-matching-input-from-input)) - (define-key term-mode-map "\e\C-l" 'term-show-output) - (define-key term-mode-map "\C-m" 'term-send-input) - (define-key term-mode-map "\C-d" 'term-delchar-or-maybe-eof) - (define-key term-mode-map "\C-c\C-a" 'term-bol) - (define-key term-mode-map "\C-c\C-u" 'term-kill-input) - (define-key term-mode-map "\C-c\C-w" 'backward-kill-word) - (define-key term-mode-map "\C-c\C-c" 'term-interrupt-subjob) - (define-key term-mode-map "\C-c\C-z" 'term-stop-subjob) - (define-key term-mode-map "\C-c\C-\\" 'term-quit-subjob) - (define-key term-mode-map "\C-c\C-m" 'term-copy-old-input) - (define-key term-mode-map "\C-c\C-o" 'term-kill-output) - (define-key term-mode-map "\C-c\C-r" 'term-show-output) - (define-key term-mode-map "\C-c\C-e" 'term-show-maximum-output) - (define-key term-mode-map "\C-c\C-l" 'term-dynamic-list-input-ring) - (define-key term-mode-map "\C-c\C-n" 'term-next-prompt) - (define-key term-mode-map "\C-c\C-p" 'term-previous-prompt) - (define-key term-mode-map "\C-c\C-d" 'term-send-eof) - (define-key term-mode-map "\C-c\C-k" 'term-char-mode) - (define-key term-mode-map "\C-c\C-j" 'term-line-mode) - (define-key term-mode-map "\C-c\C-q" 'term-pager-toggle) - - (copy-face 'default 'term-underline-face) - (set-face-underline-p 'term-underline-face t) - -; ;; completion: -; (define-key term-mode-map [menu-bar completion] -; (cons "Complete" (make-sparse-keymap "Complete"))) -; (define-key term-mode-map [menu-bar completion complete-expand] -; '("Expand File Name" . term-replace-by-expanded-filename)) -; (define-key term-mode-map [menu-bar completion complete-listing] -; '("File Completion Listing" . term-dynamic-list-filename-completions)) -; (define-key term-mode-map [menu-bar completion complete-file] -; '("Complete File Name" . term-dynamic-complete-filename)) -; (define-key term-mode-map [menu-bar completion complete] -; '("Complete Before Point" . term-dynamic-complete)) -; ;; Put them in the menu bar: -; (setq menu-bar-final-items (append '(terminal completion inout signals) -; menu-bar-final-items)) - ) - -;; Menu bars: -(term-ifnot-xemacs - (term-if-emacs19 - - ;; terminal: - (let (newmap) - (setq newmap (make-sparse-keymap "Terminal")) - (define-key newmap [terminal-pager-enable] - '("Enable paging" . term-fake-pager-enable)) - (define-key newmap [terminal-pager-disable] - '("Disable paging" . term-fake-pager-disable)) - (define-key newmap [terminal-char-mode] - '("Character mode" . term-char-mode)) - (define-key newmap [terminal-line-mode] - '("Line mode" . term-line-mode)) - (define-key newmap [menu-bar terminal] - (setq term-terminal-menu (cons "Terminal" newmap))) - - ;; completion: (line mode only) - (defvar term-completion-menu (make-sparse-keymap "Complete")) - (define-key term-mode-map [menu-bar completion] - (cons "Complete" term-completion-menu)) - (define-key term-completion-menu [complete-expand] - '("Expand File Name" . term-replace-by-expanded-filename)) - (define-key term-completion-menu [complete-listing] - '("File Completion Listing" . term-dynamic-list-filename-completions)) - (define-key term-completion-menu [menu-bar completion complete-file] - '("Complete File Name" . term-dynamic-complete-filename)) - (define-key term-completion-menu [menu-bar completion complete] - '("Complete Before Point" . term-dynamic-complete)) - - ;; Input history: (line mode only) - (defvar term-inout-menu (make-sparse-keymap "In/Out")) - (define-key term-mode-map [menu-bar inout] - (cons "In/Out" term-inout-menu)) - (define-key term-inout-menu [kill-output] - '("Kill Current Output Group" . term-kill-output)) - (define-key term-inout-menu [next-prompt] - '("Forward Output Group" . term-next-prompt)) - (define-key term-inout-menu [previous-prompt] - '("Backward Output Group" . term-previous-prompt)) - (define-key term-inout-menu [show-maximum-output] - '("Show Maximum Output" . term-show-maximum-output)) - (define-key term-inout-menu [show-output] - '("Show Current Output Group" . term-show-output)) - (define-key term-inout-menu [kill-input] - '("Kill Current Input" . term-kill-input)) - (define-key term-inout-menu [copy-input] - '("Copy Old Input" . term-copy-old-input)) - (define-key term-inout-menu [forward-matching-history] - '("Forward Matching Input..." . term-forward-matching-input)) - (define-key term-inout-menu [backward-matching-history] - '("Backward Matching Input..." . term-backward-matching-input)) - (define-key term-inout-menu [next-matching-history] - '("Next Matching Input..." . term-next-matching-input)) - (define-key term-inout-menu [previous-matching-history] - '("Previous Matching Input..." . term-previous-matching-input)) - (define-key term-inout-menu [next-matching-history-from-input] - '("Next Matching Current Input" . term-next-matching-input-from-input)) - (define-key term-inout-menu [previous-matching-history-from-input] - '("Previous Matching Current Input" . term-previous-matching-input-from-input)) - (define-key term-inout-menu [next-history] - '("Next Input" . term-next-input)) - (define-key term-inout-menu [previous-history] - '("Previous Input" . term-previous-input)) - (define-key term-inout-menu [list-history] - '("List Input History" . term-dynamic-list-input-ring)) - (define-key term-inout-menu [expand-history] - '("Expand History Before Point" . term-replace-by-expanded-history)) - - ;; Signals - (setq newmap (make-sparse-keymap "Signals")) - (define-key newmap [eof] '("EOF" . term-send-eof)) - (define-key newmap [kill] '("KILL" . term-kill-subjob)) - (define-key newmap [quit] '("QUIT" . term-quit-subjob)) - (define-key newmap [cont] '("CONT" . term-continue-subjob)) - (define-key newmap [stop] '("STOP" . term-stop-subjob)) - (define-key newmap [] '("BREAK" . term-interrupt-subjob)) - (define-key term-mode-map [menu-bar signals] - (setq term-signals-menu (cons "Signals" newmap))) - ))) - -(defun term-reset-size (height width) - (setq term-height height) - (setq term-width width) - (setq term-start-line-column nil) - (setq term-current-row nil) - (setq term-current-column nil) - (term-scroll-region 0 height)) - -;; Recursive routine used to check if any string in term-kill-echo-list -;; matches part of the buffer before point. -;; If so, delete that matched part of the buffer - this suppresses echo. -;; Also, remove that string from the term-kill-echo-list. -;; We *also* remove any older string on the list, as a sanity measure, -;; in case something gets out of sync. (Except for type-ahead, there -;; should only be one element in the list.) - -(defun term-check-kill-echo-list () - (let ((cur term-kill-echo-list) (found nil) (save-point (point))) - (unwind-protect - (progn - (end-of-line) - (while cur - (let* ((str (car cur)) (len (length str)) (start (- (point) len))) - (if (and (>= start (point-min)) - (string= str (buffer-substring start (point)))) - (progn (delete-backward-char len) - (setq term-kill-echo-list (cdr cur)) - (setq term-current-column nil) - (setq term-current-row nil) - (setq term-start-line-column nil) - (setq cur nil found t)) - (setq cur (cdr cur)))))) - (if (not found) - (goto-char save-point))) - found)) - -(defun term-check-size (process) - (if (or (/= term-height (1- (window-displayed-height))) - (/= term-width (1- (window-width)))) - (progn - (term-reset-size (1- (window-displayed-height)) (1- (window-width))) - (set-process-window-size process term-height term-width)))) - -(defun term-send-raw-string (chars) - (let ((proc (get-buffer-process (current-buffer)))) - (if (not proc) - (error "Current buffer has no process") - ;; Note that (term-current-row) must be called *after* - ;; (point) has been updated to (process-mark proc). - (goto-char (process-mark proc)) - (if (term-pager-enabled) - (setq term-pager-count (term-current-row))) - (process-send-string proc chars)))) - -(defun term-send-raw () - "Send the last character typed through the terminal-emulator -without any interpretation." - (interactive) - - (term-if-xemacs - (if (key-press-event-p last-input-event) - (let ((mods (event-modifiers last-input-event)) - (key (event-key last-input-event)) - meta) - (if (memq 'meta mods) - (progn - (setq meta t) - (setq mods (delq 'meta mods)))) - (let ((ascii (event-to-character (character-to-event - (append mods (list key))) - t ;; lenient - nil ;; no meta mucking - t ;; allow non-ASCII - ))) - (cond (ascii - (if meta - (term-send-raw-string (format "\e%c" ascii)) - (term-send-raw-string (make-string 1 ascii)))) - (t (command-execute (key-binding last-input-event)))))) - (let ((cmd (lookup-key (current-global-map) (this-command-keys)))) - (and cmd (call-interactively cmd))))) - - (term-ifnot-xemacs - ;; Convert `return' to C-m, etc. - (if (and (symbolp last-input-char) - (get last-input-char 'ascii-character)) - (setq last-input-char (get last-input-char 'ascii-character))) - (term-send-raw-string (make-string 1 last-input-char)))) - -(defun term-mouse-paste (click arg) - "Insert the last stretch of killed text at the position clicked on." - (interactive "e\nP") - (term-if-xemacs - (term-send-raw-string (or (condition-case () (x-get-selection) (error ())) - (x-get-cutbuffer) - (error "No selection or cut buffer available")))) - (term-ifnot-xemacs - ;; Give temporary modes such as isearch a chance to turn off. - (run-hooks 'mouse-leave-buffer-hook) - (setq this-command 'yank) - (term-send-raw-string (current-kill (cond - ((listp arg) 0) - ((eq arg '-) -1) - (t (1- arg))))))) - -;; Which would be better: "\e[A" or "\eOA"? readline accepts either. -;; Both xterm and dtterm (CDE) send "\e[A", which argues for that choice. -;; The xterm termcap claims ku=\EOA; the dtterm terminfo entry says ku=\E[A. -(defun term-send-up () (interactive) (term-send-raw-string "\e[A")) -(defun term-send-down () (interactive) (term-send-raw-string "\e[B")) -(defun term-send-right () (interactive) (term-send-raw-string "\e[C")) -(defun term-send-left () (interactive) (term-send-raw-string "\e[D")) -(defun term-send-home () (interactive) (term-send-raw-string "\e[H")) -(defun term-send-end () (interactive) (term-send-raw-string "\eOw")) -(defun term-send-prior () (interactive) (term-send-raw-string "\e[5~")) -(defun term-send-next () (interactive) (term-send-raw-string "\e[6~")) -(defun term-send-del () (interactive) (term-send-raw-string "\C-?")) -(defun term-send-backspace () (interactive) (term-send-raw-string "\C-H")) - -(defun term-set-escape-char (c) - "Change term-escape-char and keymaps that depend on it." - (if term-escape-char - (define-key term-raw-map term-escape-char 'term-send-raw)) - (setq c (make-string 1 c)) - (define-key term-raw-map c term-raw-escape-map) - ;; Define standard bindings in term-raw-escape-map - (define-key term-raw-escape-map "\C-x" - (lookup-key (current-global-map) "\C-x")) - (define-key term-raw-escape-map "\C-v" - (lookup-key (current-global-map) "\C-v")) - (define-key term-raw-escape-map "\C-u" - (lookup-key (current-global-map) "\C-u")) - (define-key term-raw-escape-map c 'term-send-raw) - (define-key term-raw-escape-map "\C-q" 'term-pager-toggle) - ;; The keybinding for term-char-mode is needed by the menubar code. - (define-key term-raw-escape-map "\C-k" 'term-char-mode) - (define-key term-raw-escape-map "\C-j" 'term-line-mode)) - -(defun term-char-mode () - "Switch to char (\"raw\") sub-mode of term mode. -Each character you type is sent directly to the inferior without -intervention from emacs, except for the escape character (usually C-c)." - (interactive) - (if (not term-raw-map) - ;; Initialize term-raw-map. - (let* ((map (make-keymap)) - (save-meta-prefix-char meta-prefix-char) - (i 0)) - ;; Temporarily disable meta-prefix-char while building keymaps. - (setq meta-prefix-char -1) - (term-if-xemacs - (set-keymap-default-binding map 'term-send-raw)) - (term-ifnot-xemacs - (while (< i 128) - (define-key map (make-string 1 i) 'term-send-raw) - (setq i (1+ i)))) - (setq term-raw-map map) - (setq term-raw-escape-map - (copy-keymap (lookup-key (current-global-map) "\C-x"))) - (define-key term-raw-map [up] 'term-send-up) - (define-key term-raw-map [down] 'term-send-down) - (define-key term-raw-map [right] 'term-send-right) - (define-key term-raw-map [left] 'term-send-left) - (define-key term-raw-map [home] 'term-send-home) - (define-key term-raw-map [end] 'term-send-end) - (define-key term-raw-map [prior] 'term-send-prior) - (define-key term-raw-map [next] 'term-send-next) - (term-if-xemacs - (define-key term-raw-map [button2] 'term-mouse-paste)) - (term-ifnot-xemacs - (define-key term-raw-map [mouse-2] 'term-mouse-paste) - (define-key term-raw-map [menu-bar terminal] term-terminal-menu) - (define-key term-raw-map [menu-bar signals] term-signals-menu) - (define-key term-raw-map [delete] 'term-send-del) - (define-key term-raw-map [backspace] 'term-send-backspace)) - (setq meta-prefix-char save-meta-prefix-char) - (term-set-escape-char ?\C-c))) - ;; FIXME: Emit message? Cfr ilisp-raw-message - (if (term-in-line-mode) - (progn - (setq term-old-mode-map (current-local-map)) - (use-local-map term-raw-map) - - ;; Send existing partial line to inferior (without newline). - (let ((pmark (process-mark (get-buffer-process (current-buffer)))) - (save-input-sender term-input-sender)) - (if (> (point) pmark) - (unwind-protect - (progn - (setq term-input-sender - (symbol-function 'term-send-string)) - (end-of-line) - (term-send-input)) - (setq term-input-sender save-input-sender)))) - (term-update-mode-line)))) - -(defun term-line-mode () - "Switch to line (\"cooked\") sub-mode of term mode. -This means that emacs editing commands work as normally, until -you type \\[term-send-input] which sends the current line to the inferior." - (interactive) - (if (term-in-char-mode) - (progn - (use-local-map term-old-mode-map) - (term-update-mode-line)))) - -(defun term-update-mode-line () - (setq mode-line-process - (if (term-in-char-mode) - (if (term-pager-enabled) '(": char page %s") '(": char %s")) - (if (term-pager-enabled) '(": line page %s") '(": line %s")))) - (force-mode-line-update)) - -(defun term-check-proc (buffer) - "True if there is a process associated w/buffer BUFFER, and -it is alive (status RUN or STOP). BUFFER can be either a buffer or the -name of one" - (let ((proc (get-buffer-process buffer))) - (and proc (memq (process-status proc) '(run stop))))) - -;;; Note that this guy, unlike shell.el's make-shell, barfs if you pass it () -;;; for the second argument (program). -;;;###autoload -(defun make-term (name program &optional startfile &rest switches) - "Make a term process NAME in a buffer, running PROGRAM. -The name of the buffer is made by surrounding NAME with `*'s. -If there is already a running process in that buffer, it is not restarted. -Optional third arg STARTFILE is the name of a file to send the contents of to -the process. Any more args are arguments to PROGRAM." - (let ((buffer (get-buffer-create (concat "*" name "*")))) - ;; If no process, or nuked process, crank up a new one and put buffer in - ;; term mode. Otherwise, leave buffer and existing process alone. - (cond ((not (term-check-proc buffer)) - (save-excursion - (set-buffer buffer) - (term-mode)) ; Install local vars, mode, keymap, ... - (term-exec buffer name program startfile switches))) - buffer)) - -;;;###autoload -(defun term (program) - "Start a terminal-emulator in a new buffer." - (interactive (list (read-from-minibuffer "Run program: " - (or explicit-shell-file-name - (getenv "ESHELL") - (getenv "SHELL") - "/bin/sh")))) - (set-buffer (make-term "terminal" program)) - (term-mode) - (term-char-mode) - (switch-to-buffer "*terminal*")) - -(defun term-exec (buffer name command startfile switches) - "Start up a process in buffer for term modes. -Blasts any old process running in the buffer. Doesn't set the buffer mode. -You can use this to cheaply run a series of processes in the same term -buffer. The hook term-exec-hook is run after each exec." - (save-excursion - (set-buffer buffer) - (let ((proc (get-buffer-process buffer))) ; Blast any old process. - (if proc (delete-process proc))) - ;; Crank up a new process - (let ((proc (term-exec-1 name buffer command switches))) - (make-local-variable 'term-ptyp) - (setq term-ptyp process-connection-type) ; T if pty, NIL if pipe. - ;; Jump to the end, and set the process mark. - (goto-char (point-max)) - (set-marker (process-mark proc) (point)) - (set-process-filter proc 'term-emulate-terminal) - ;; Feed it the startfile. - (cond (startfile - ;;This is guaranteed to wait long enough - ;;but has bad results if the term does not prompt at all - ;; (while (= size (buffer-size)) - ;; (sleep-for 1)) - ;;I hope 1 second is enough! - (sleep-for 1) - (goto-char (point-max)) - (insert-file-contents startfile) - (setq startfile (buffer-substring (point) (point-max))) - (delete-region (point) (point-max)) - (term-send-string proc startfile))) - (run-hooks 'term-exec-hook) - buffer))) - -;;; Name to use for TERM. -;;; Using "emacs" loses, because bash disables editing if TERM == emacs. -(defvar term-term-name "eterm") -; Format string, usage: (format term-termcap-string emacs-term-name "TERMCAP=" 24 80) -(defvar term-termcap-format - "%s%s:li#%d:co#%d:cl=\\E[H\\E[J:cd=\\E[J:bs:am:xn:cm=\\E[%%i%%d;%%dH\ -:nd=\\E[C:up=\\E[A:ce=\\E[K:ho=\\E[H:pt\ -:al=\\E[L:dl=\\E[M:DL=\\E[%%dM:AL=\\E[%%dL:cs=\\E[%%i%%d;%%dr:sf=\\n\ -:te=\\E[2J\\E[?47l\\E8:ti=\\E7\\E[?47h\ -:dc=\\E[P:DC=\\E[%%dP:IC=\\E[%%d@:im=\\E[4h:ei=\\E[4l:mi\ -:kd=\\E[B:kl=\\E[D:kr=\\E[C:ku=\\E[A\ -:so=\\E[7m:se=\\E[m:us=\\E[4m:ue=\\E[m:md=\\E[1m:mr=\\E[7m:me=\\E[m\ -:UP=\\E[%%dA:DO=\\E[%%dB:LE=\\E[%%dD:RI=\\E[%%dC" -;;; : -undefine ic - "termcap capabilities supported") - -;;; This auxiliary function cranks up the process for term-exec in -;;; the appropriate environment. - -(defun term-exec-1 (name buffer command switches) - ;; We need to do an extra (fork-less) exec to run stty. - ;; (This would not be needed if we had suitable emacs primitives.) - ;; The 'if ...; then shift; fi' hack is because Bourne shell - ;; loses one arg when called with -c, and newer shells (bash, ksh) don't. - ;; Thus we add an extra dummy argument "..", and then remove it. - (let ((process-environment - (nconc - (list - (format "TERM=%s" term-term-name) - (if (and (boundp 'system-uses-terminfo) system-uses-terminfo) - (format "TERMINFO=%s" data-directory) - (format term-termcap-format "TERMCAP=" - term-term-name term-height term-width)) - (format "EMACS=%s (term:%s)" emacs-version term-protocol-version) - (format "LINES=%d" term-height) - (format "COLUMNS=%d" term-width)) - process-environment))) - (apply 'start-process name buffer - "/bin/sh" "-c" - (format "stty -nl echo rows %d columns %d sane 2>/dev/null;\ -if [ $1 = .. ]; then shift; fi; exec \"$@\"" - term-height term-width) - ".." - command switches))) - -;;; This should be in emacs, but it isn't. -(defun term-mem (item list &optional elt=) - "Test to see if ITEM is equal to an item in LIST. -Option comparison function ELT= defaults to equal." - (let ((elt= (or elt= (function equal))) - (done nil)) - (while (and list (not done)) - (if (funcall elt= item (car list)) - (setq done list) - (setq list (cdr list)))) - done)) - - -;;; Input history processing in a buffer -;;; =========================================================================== -;;; Useful input history functions, courtesy of the Ergo group. - -;;; Eleven commands: -;;; term-dynamic-list-input-ring List history in help buffer. -;;; term-previous-input Previous input... -;;; term-previous-matching-input ...matching a string. -;;; term-previous-matching-input-from-input ... matching the current input. -;;; term-next-input Next input... -;;; term-next-matching-input ...matching a string. -;;; term-next-matching-input-from-input ... matching the current input. -;;; term-backward-matching-input Backwards input... -;;; term-forward-matching-input ...matching a string. -;;; term-replace-by-expanded-history Expand history at point; -;;; replace with expanded history. -;;; term-magic-space Expand history and insert space. -;;; -;;; Three functions: -;;; term-read-input-ring Read into term-input-ring... -;;; term-write-input-ring Write to term-input-ring-file-name. -;;; term-replace-by-expanded-history-before-point Workhorse function. - -(defun term-read-input-ring (&optional silent) - "Sets the buffer's `term-input-ring' from a history file. -The name of the file is given by the variable `term-input-ring-file-name'. -The history ring is of size `term-input-ring-size', regardless of file size. -If `term-input-ring-file-name' is nil this function does nothing. - -If the optional argument SILENT is non-nil, we say nothing about a -failure to read the history file. - -This function is useful for major mode commands and mode hooks. - -The structure of the history file should be one input command per line, -with the most recent command last. -See also `term-input-ignoredups' and `term-write-input-ring'." - (cond ((or (null term-input-ring-file-name) - (equal term-input-ring-file-name "")) - nil) - ((not (file-readable-p term-input-ring-file-name)) - (or silent - (message "Cannot read history file %s" - term-input-ring-file-name))) - (t - (let ((history-buf (get-buffer-create " *temp*")) - (file term-input-ring-file-name) - (count 0) - (ring (make-ring term-input-ring-size))) - (unwind-protect - (save-excursion - (set-buffer history-buf) - (widen) - (erase-buffer) - (insert-file-contents file) - ;; Save restriction in case file is already visited... - ;; Watch for those date stamps in history files! - (goto-char (point-max)) - (while (and (< count term-input-ring-size) - (re-search-backward "^[ \t]*\\([^#\n].*\\)[ \t]*$" - nil t)) - (let ((history (buffer-substring (match-beginning 1) - (match-end 1)))) - (if (or (null term-input-ignoredups) - (ring-empty-p ring) - (not (string-equal (ring-ref ring 0) history))) - (ring-insert-at-beginning ring history))) - (setq count (1+ count)))) - (kill-buffer history-buf)) - (setq term-input-ring ring - term-input-ring-index nil))))) - -(defun term-write-input-ring () - "Writes the buffer's `term-input-ring' to a history file. -The name of the file is given by the variable `term-input-ring-file-name'. -The original contents of the file are lost if `term-input-ring' is not empty. -If `term-input-ring-file-name' is nil this function does nothing. - -Useful within process sentinels. - -See also `term-read-input-ring'." - (cond ((or (null term-input-ring-file-name) - (equal term-input-ring-file-name "") - (null term-input-ring) (ring-empty-p term-input-ring)) - nil) - ((not (file-writable-p term-input-ring-file-name)) - (message "Cannot write history file %s" term-input-ring-file-name)) - (t - (let* ((history-buf (get-buffer-create " *Temp Input History*")) - (ring term-input-ring) - (file term-input-ring-file-name) - (index (ring-length ring))) - ;; Write it all out into a buffer first. Much faster, but messier, - ;; than writing it one line at a time. - (save-excursion - (set-buffer history-buf) - (erase-buffer) - (while (> index 0) - (setq index (1- index)) - (insert (ring-ref ring index) ?\n)) - (write-region (buffer-string) nil file nil 'no-message) - (kill-buffer nil)))))) - - -(defun term-dynamic-list-input-ring () - "List in help buffer the buffer's input history." - (interactive) - (if (or (not (ring-p term-input-ring)) - (ring-empty-p term-input-ring)) - (message "No history") - (let ((history nil) - (history-buffer " *Input History*") - (index (1- (ring-length term-input-ring))) - (conf (current-window-configuration))) - ;; We have to build up a list ourselves from the ring vector. - (while (>= index 0) - (setq history (cons (ring-ref term-input-ring index) history) - index (1- index))) - ;; Change "completion" to "history reference" - ;; to make the display accurate. - (with-output-to-temp-buffer history-buffer - (display-completion-list history) - (set-buffer history-buffer) - (forward-line 3) - (while (search-backward "completion" nil 'move) - (replace-match "history reference"))) - (sit-for 0) - (message "Hit space to flush") - (let ((ch (read-event))) - (if (eq ch ?\ ) - (set-window-configuration conf) - (setq unread-command-events (list ch))))))) - - -(defun term-regexp-arg (prompt) - ;; Return list of regexp and prefix arg using PROMPT. - (let* ((minibuffer-history-sexp-flag nil) - ;; Don't clobber this. - (last-command last-command) - (regexp (read-from-minibuffer prompt nil nil nil - 'minibuffer-history-search-history))) - (list (if (string-equal regexp "") - (setcar minibuffer-history-search-history - (nth 1 minibuffer-history-search-history)) - regexp) - (prefix-numeric-value current-prefix-arg)))) - -(defun term-search-arg (arg) - ;; First make sure there is a ring and that we are after the process mark - (cond ((not (term-after-pmark-p)) - (error "Not at command line")) - ((or (null term-input-ring) - (ring-empty-p term-input-ring)) - (error "Empty input ring")) - ((zerop arg) - ;; arg of zero resets search from beginning, and uses arg of 1 - (setq term-input-ring-index nil) - 1) - (t - arg))) - -(defun term-search-start (arg) - ;; Index to start a directional search, starting at term-input-ring-index - (if term-input-ring-index - ;; If a search is running, offset by 1 in direction of arg - (mod (+ term-input-ring-index (if (> arg 0) 1 -1)) - (ring-length term-input-ring)) - ;; For a new search, start from beginning or end, as appropriate - (if (>= arg 0) - 0 ; First elt for forward search - (1- (ring-length term-input-ring))))) ; Last elt for backward search - -(defun term-previous-input-string (arg) - "Return the string ARG places along the input ring. -Moves relative to `term-input-ring-index'." - (ring-ref term-input-ring (if term-input-ring-index - (mod (+ arg term-input-ring-index) - (ring-length term-input-ring)) - arg))) - -(defun term-previous-input (arg) - "Cycle backwards through input history." - (interactive "*p") - (term-previous-matching-input "." arg)) - -(defun term-next-input (arg) - "Cycle forwards through input history." - (interactive "*p") - (term-previous-input (- arg))) - -(defun term-previous-matching-input-string (regexp arg) - "Return the string matching REGEXP ARG places along the input ring. -Moves relative to `term-input-ring-index'." - (let* ((pos (term-previous-matching-input-string-position regexp arg))) - (if pos (ring-ref term-input-ring pos)))) - -(defun term-previous-matching-input-string-position (regexp arg &optional start) - "Return the index matching REGEXP ARG places along the input ring. -Moves relative to START, or `term-input-ring-index'." - (if (or (not (ring-p term-input-ring)) - (ring-empty-p term-input-ring)) - (error "No history")) - (let* ((len (ring-length term-input-ring)) - (motion (if (> arg 0) 1 -1)) - (n (mod (- (or start (term-search-start arg)) motion) len)) - (tried-each-ring-item nil) - (prev nil)) - ;; Do the whole search as many times as the argument says. - (while (and (/= arg 0) (not tried-each-ring-item)) - ;; Step once. - (setq prev n - n (mod (+ n motion) len)) - ;; If we haven't reached a match, step some more. - (while (and (< n len) (not tried-each-ring-item) - (not (string-match regexp (ring-ref term-input-ring n)))) - (setq n (mod (+ n motion) len) - ;; If we have gone all the way around in this search. - tried-each-ring-item (= n prev))) - (setq arg (if (> arg 0) (1- arg) (1+ arg)))) - ;; Now that we know which ring element to use, if we found it, return that. - (if (string-match regexp (ring-ref term-input-ring n)) - n))) - -(defun term-previous-matching-input (regexp arg) - "Search backwards through input history for match for REGEXP. -\(Previous history elements are earlier commands.) -With prefix argument N, search for Nth previous match. -If N is negative, find the next or Nth next match." - (interactive (term-regexp-arg "Previous input matching (regexp): ")) - (setq arg (term-search-arg arg)) - (let ((pos (term-previous-matching-input-string-position regexp arg))) - ;; Has a match been found? - (if (null pos) - (error "Not found") - (setq term-input-ring-index pos) - (message "History item: %d" (1+ pos)) - (delete-region - ;; Can't use kill-region as it sets this-command - (process-mark (get-buffer-process (current-buffer))) (point)) - (insert (ring-ref term-input-ring pos))))) - -(defun term-next-matching-input (regexp arg) - "Search forwards through input history for match for REGEXP. -\(Later history elements are more recent commands.) -With prefix argument N, search for Nth following match. -If N is negative, find the previous or Nth previous match." - (interactive (term-regexp-arg "Next input matching (regexp): ")) - (term-previous-matching-input regexp (- arg))) - -(defun term-previous-matching-input-from-input (arg) - "Search backwards through input history for match for current input. -\(Previous history elements are earlier commands.) -With prefix argument N, search for Nth previous match. -If N is negative, search forwards for the -Nth following match." - (interactive "p") - (if (not (memq last-command '(term-previous-matching-input-from-input - term-next-matching-input-from-input))) - ;; Starting a new search - (setq term-matching-input-from-input-string - (buffer-substring - (process-mark (get-buffer-process (current-buffer))) - (point)) - term-input-ring-index nil)) - (term-previous-matching-input - (concat "^" (regexp-quote term-matching-input-from-input-string)) - arg)) - -(defun term-next-matching-input-from-input (arg) - "Search forwards through input history for match for current input. -\(Following history elements are more recent commands.) -With prefix argument N, search for Nth following match. -If N is negative, search backwards for the -Nth previous match." - (interactive "p") - (term-previous-matching-input-from-input (- arg))) - - -(defun term-replace-by-expanded-history (&optional silent) - "Expand input command history references before point. -Expansion is dependent on the value of `term-input-autoexpand'. - -This function depends on the buffer's idea of the input history, which may not -match the command interpreter's idea, assuming it has one. - -Assumes history syntax is like typical Un*x shells'. However, since emacs -cannot know the interpreter's idea of input line numbers, assuming it has one, -it cannot expand absolute input line number references. - -If the optional argument SILENT is non-nil, never complain -even if history reference seems erroneous. - -See `term-magic-space' and `term-replace-by-expanded-history-before-point'. - -Returns t if successful." - (interactive) - (if (and term-input-autoexpand - (string-match "[!^]" (funcall term-get-old-input)) - (save-excursion (beginning-of-line) - (looking-at term-prompt-regexp))) - ;; Looks like there might be history references in the command. - (let ((previous-modified-tick (buffer-modified-tick))) - (message "Expanding history references...") - (term-replace-by-expanded-history-before-point silent) - (/= previous-modified-tick (buffer-modified-tick))))) - - -(defun term-replace-by-expanded-history-before-point (silent) - "Expand directory stack reference before point. -See `term-replace-by-expanded-history'. Returns t if successful." - (save-excursion - (let ((toend (- (save-excursion (end-of-line nil) (point)) (point))) - (start (progn (term-bol nil) (point)))) - (while (progn - (skip-chars-forward "^!^" - (save-excursion - (end-of-line nil) (- (point) toend))) - (< (point) - (save-excursion - (end-of-line nil) (- (point) toend)))) - ;; This seems a bit complex. We look for references such as !!, !-num, - ;; !foo, !?foo, !{bar}, !?{bar}, ^oh, ^my^, ^god^it, ^never^ends^. - ;; If that wasn't enough, the plings can be suffixed with argument - ;; range specifiers. - ;; Argument ranges are complex too, so we hive off the input line, - ;; referenced with plings, with the range string to `term-args'. - (setq term-input-ring-index nil) - (cond ((or (= (preceding-char) ?\\) - (term-within-quotes start (point))) - ;; The history is quoted, or we're in quotes. - (goto-char (1+ (point)))) - ((looking-at "![0-9]+\\($\\|[^-]\\)") - ;; We cannot know the interpreter's idea of input line numbers. - (goto-char (match-end 0)) - (message "Absolute reference cannot be expanded")) - ((looking-at "!-\\([0-9]+\\)\\(:?[0-9^$*-]+\\)?") - ;; Just a number of args from `number' lines backward. - (let ((number (1- (string-to-number - (buffer-substring (match-beginning 1) - (match-end 1)))))) - (if (<= number (ring-length term-input-ring)) - (progn - (replace-match - (term-args (term-previous-input-string number) - (match-beginning 2) (match-end 2)) - t t) - (setq term-input-ring-index number) - (message "History item: %d" (1+ number))) - (goto-char (match-end 0)) - (message "Relative reference exceeds input history size")))) - ((or (looking-at "!!?:?\\([0-9^$*-]+\\)") (looking-at "!!")) - ;; Just a number of args from the previous input line. - (replace-match - (term-args (term-previous-input-string 0) - (match-beginning 1) (match-end 1)) - t t) - (message "History item: previous")) - ((looking-at - "!\\??\\({\\(.+\\)}\\|\\(\\sw+\\)\\)\\(:?[0-9^$*-]+\\)?") - ;; Most recent input starting with or containing (possibly - ;; protected) string, maybe just a number of args. Phew. - (let* ((mb1 (match-beginning 1)) (me1 (match-end 1)) - (mb2 (match-beginning 2)) (me2 (match-end 2)) - (exp (buffer-substring (or mb2 mb1) (or me2 me1))) - (pref (if (save-match-data (looking-at "!\\?")) "" "^")) - (pos (save-match-data - (term-previous-matching-input-string-position - (concat pref (regexp-quote exp)) 1)))) - (if (null pos) - (progn - (goto-char (match-end 0)) - (or silent - (progn (message "Not found") - (ding)))) - (setq term-input-ring-index pos) - (replace-match - (term-args (ring-ref term-input-ring pos) - (match-beginning 4) (match-end 4)) - t t) - (message "History item: %d" (1+ pos))))) - ((looking-at "\\^\\([^^]+\\)\\^?\\([^^]*\\)\\^?") - ;; Quick substitution on the previous input line. - (let ((old (buffer-substring (match-beginning 1) (match-end 1))) - (new (buffer-substring (match-beginning 2) (match-end 2))) - (pos nil)) - (replace-match (term-previous-input-string 0) t t) - (setq pos (point)) - (goto-char (match-beginning 0)) - (if (not (search-forward old pos t)) - (or silent - (error "Not found")) - (replace-match new t t) - (message "History item: substituted")))) - (t - (goto-char (match-end 0)))))))) - - -(defun term-magic-space (arg) - "Expand input history references before point and insert ARG spaces. -A useful command to bind to SPC. See `term-replace-by-expanded-history'." - (interactive "p") - (term-replace-by-expanded-history) - (self-insert-command arg)) - -(defun term-within-quotes (beg end) - "Return t if the number of quotes between BEG and END is odd. -Quotes are single and double." - (let ((countsq (term-how-many-region "\\(^\\|[^\\\\]\\)\'" beg end)) - (countdq (term-how-many-region "\\(^\\|[^\\\\]\\)\"" beg end))) - (or (= (mod countsq 2) 1) (= (mod countdq 2) 1)))) - -(defun term-how-many-region (regexp beg end) - "Return number of matches for REGEXP from BEG to END." - (let ((count 0)) - (save-excursion - (save-match-data - (goto-char beg) - (while (re-search-forward regexp end t) - (setq count (1+ count))))) - count)) - -(defun term-args (string begin end) - ;; From STRING, return the args depending on the range specified in the text - ;; from BEGIN to END. If BEGIN is nil, assume all args. Ignore leading `:'. - ;; Range can be x-y, x-, -y, where x/y can be [0-9], *, ^, $. - (save-match-data - (if (null begin) - (term-arguments string 0 nil) - (let* ((range (buffer-substring - (if (eq (char-after begin) ?:) (1+ begin) begin) end)) - (nth (cond ((string-match "^[*^]" range) 1) - ((string-match "^-" range) 0) - ((string-equal range "$") nil) - (t (string-to-number range)))) - (mth (cond ((string-match "[-*$]$" range) nil) - ((string-match "-" range) - (string-to-number (substring range (match-end 0)))) - (t nth)))) - (term-arguments string nth mth))))) - -;; Return a list of arguments from ARG. Break it up at the -;; delimiters in term-delimiter-argument-list. Returned list is backwards. -(defun term-delim-arg (arg) - (if (null term-delimiter-argument-list) - (list arg) - (let ((args nil) - (pos 0) - (len (length arg))) - (while (< pos len) - (let ((char (aref arg pos)) - (start pos)) - (if (memq char term-delimiter-argument-list) - (while (and (< pos len) (eq (aref arg pos) char)) - (setq pos (1+ pos))) - (while (and (< pos len) - (not (memq (aref arg pos) - term-delimiter-argument-list))) - (setq pos (1+ pos)))) - (setq args (cons (substring arg start pos) args)))) - args))) - -(defun term-arguments (string nth mth) - "Return from STRING the NTH to MTH arguments. -NTH and/or MTH can be nil, which means the last argument. -Returned arguments are separated by single spaces. -We assume whitespace separates arguments, except within quotes. -Also, a run of one or more of a single character -in `term-delimiter-argument-list' is a separate argument. -Argument 0 is the command name." - (let ((argpart "[^ \n\t\"'`]+\\|\\(\"[^\"]*\"\\|'[^']*'\\|`[^`]*`\\)") - (args ()) (pos 0) - (count 0) - beg str quotes) - ;; Build a list of all the args until we have as many as we want. - (while (and (or (null mth) (<= count mth)) - (string-match argpart string pos)) - (if (and beg (= pos (match-beginning 0))) - ;; It's contiguous, part of the same arg. - (setq pos (match-end 0) - quotes (or quotes (match-beginning 1))) - ;; It's a new separate arg. - (if beg - ;; Put the previous arg, if there was one, onto ARGS. - (setq str (substring string beg pos) - args (if quotes (cons str args) - (nconc (term-delim-arg str) args)) - count (1+ count))) - (setq quotes (match-beginning 1)) - (setq beg (match-beginning 0)) - (setq pos (match-end 0)))) - (if beg - (setq str (substring string beg pos) - args (if quotes (cons str args) - (nconc (term-delim-arg str) args)) - count (1+ count))) - (let ((n (or nth (1- count))) - (m (if mth (1- (- count mth)) 0))) - (mapconcat - (function (lambda (a) a)) (nthcdr n (nreverse (nthcdr m args))) " ")))) - -;;; -;;; Input processing stuff [line mode] -;;; - -(defun term-send-input () - "Send input to process. -After the process output mark, sends all text from the process mark to -point as input to the process. Before the process output mark, calls value -of variable term-get-old-input to retrieve old input, copies it to the -process mark, and sends it. A terminal newline is also inserted into the -buffer and sent to the process. The list of function names contained in the -value of `term-input-filter-functions' is called on the input before sending -it. The input is entered into the input history ring, if the value of variable -term-input-filter returns non-nil when called on the input. - -Any history reference may be expanded depending on the value of the variable -`term-input-autoexpand'. The list of function names contained in the value -of `term-input-filter-functions' is called on the input before sending it. -The input is entered into the input history ring, if the value of variable -`term-input-filter' returns non-nil when called on the input. - -If variable `term-eol-on-send' is non-nil, then point is moved to the -end of line before sending the input. - -The values of `term-get-old-input', `term-input-filter-functions', and -`term-input-filter' are chosen according to the command interpreter running -in the buffer. E.g., - -If the interpreter is the csh, - term-get-old-input is the default: take the current line, discard any - initial string matching regexp term-prompt-regexp. - term-input-filter-functions monitors input for \"cd\", \"pushd\", and - \"popd\" commands. When it sees one, it cd's the buffer. - term-input-filter is the default: returns T if the input isn't all white - space. - -If the term is Lucid Common Lisp, - term-get-old-input snarfs the sexp ending at point. - term-input-filter-functions does nothing. - term-input-filter returns NIL if the input matches input-filter-regexp, - which matches (1) all whitespace (2) :a, :c, etc. - -Similarly for Soar, Scheme, etc." - (interactive) - ;; Note that the input string does not include its terminal newline. - (let ((proc (get-buffer-process (current-buffer)))) - (if (not proc) (error "Current buffer has no process") - (let* ((pmark (process-mark proc)) - (pmark-val (marker-position pmark)) - (input-is-new (>= (point) pmark-val)) - (intxt (if input-is-new - (progn (if term-eol-on-send (end-of-line)) - (buffer-substring pmark (point))) - (funcall term-get-old-input))) - (input (if (not (eq term-input-autoexpand 'input)) - ;; Just whatever's already there - intxt - ;; Expand and leave it visible in buffer - (term-replace-by-expanded-history t) - (buffer-substring pmark (point)))) - (history (if (not (eq term-input-autoexpand 'history)) - input - ;; This is messy 'cos ultimately the original - ;; functions used do insertion, rather than return - ;; strings. We have to expand, then insert back. - (term-replace-by-expanded-history t) - (let ((copy (buffer-substring pmark (point)))) - (delete-region pmark (point)) - (insert input) - copy)))) - (if (term-pager-enabled) - (save-excursion - (goto-char (process-mark proc)) - (setq term-pager-count (term-current-row)))) - (if (and (funcall term-input-filter history) - (or (null term-input-ignoredups) - (not (ring-p term-input-ring)) - (ring-empty-p term-input-ring) - (not (string-equal (ring-ref term-input-ring 0) - history)))) - (ring-insert term-input-ring history)) - (let ((functions term-input-filter-functions)) - (while functions - (funcall (car functions) (concat input "\n")) - (setq functions (cdr functions)))) - (setq term-input-ring-index nil) - - ;; Update the markers before we send the input - ;; in case we get output amidst sending the input. - (set-marker term-last-input-start pmark) - (set-marker term-last-input-end (point)) - (if input-is-new - (progn - ;; Set up to delete, because inferior should echo. - (if (marker-buffer term-pending-delete-marker) - (delete-region term-pending-delete-marker pmark)) - (set-marker term-pending-delete-marker pmark-val) - (set-marker (process-mark proc) (point)))) - (goto-char pmark) - (funcall term-input-sender proc input))))) - -(defun term-get-old-input-default () - "Default for term-get-old-input. -Take the current line, and discard any initial text matching -term-prompt-regexp." - (save-excursion - (beginning-of-line) - (term-skip-prompt) - (let ((beg (point))) - (end-of-line) - (buffer-substring beg (point))))) - -(defun term-copy-old-input () - "Insert after prompt old input at point as new input to be edited. -Calls `term-get-old-input' to get old input." - (interactive) - (let ((input (funcall term-get-old-input)) - (process (get-buffer-process (current-buffer)))) - (if (not process) - (error "Current buffer has no process") - (goto-char (process-mark process)) - (insert input)))) - -(defun term-skip-prompt () - "Skip past the text matching regexp term-prompt-regexp. -If this takes us past the end of the current line, don't skip at all." - (let ((eol (save-excursion (end-of-line) (point)))) - (if (and (looking-at term-prompt-regexp) - (<= (match-end 0) eol)) - (goto-char (match-end 0))))) - - -(defun term-after-pmark-p () - "Is point after the process output marker?" - ;; Since output could come into the buffer after we looked at the point - ;; but before we looked at the process marker's value, we explicitly - ;; serialise. This is just because I don't know whether or not emacs - ;; services input during execution of lisp commands. - (let ((proc-pos (marker-position - (process-mark (get-buffer-process (current-buffer)))))) - (<= proc-pos (point)))) - -(defun term-simple-send (proc string) - "Default function for sending to PROC input STRING. -This just sends STRING plus a newline. To override this, -set the hook TERM-INPUT-SENDER." - (term-send-string proc string) - (term-send-string proc "\n")) - -(defun term-bol (arg) - "Goes to the beginning of line, then skips past the prompt, if any. -If a prefix argument is given (\\[universal-argument]), then no prompt skip --- go straight to column 0. - -The prompt skip is done by skipping text matching the regular expression -term-prompt-regexp, a buffer local variable." - (interactive "P") - (beginning-of-line) - (if (null arg) (term-skip-prompt))) - -;;; These two functions are for entering text you don't want echoed or -;;; saved -- typically passwords to ftp, telnet, or somesuch. -;;; Just enter m-x term-send-invisible and type in your line. - -(defun term-read-noecho (prompt &optional stars) - "Read a single line of text from user without echoing, and return it. -Prompt with argument PROMPT, a string. Optional argument STARS causes -input to be echoed with '*' characters on the prompt line. Input ends with -RET, LFD, or ESC. DEL or C-h rubs out. C-u kills line. C-g aborts (if -`inhibit-quit' is set because e.g. this function was called from a process -filter and C-g is pressed, this function returns nil rather than a string). - -Note that the keystrokes comprising the text can still be recovered -\(temporarily) with \\[view-lossage]. This may be a security bug for some -applications." - (let ((ans "") - (c 0) - (echo-keystrokes 0) - (cursor-in-echo-area t) - (done nil)) - (while (not done) - (if stars - (message "%s%s" prompt (make-string (length ans) ?*)) - (message "%s" prompt)) - (setq c (read-char)) - (cond ((= c ?\C-g) - ;; This function may get called from a process filter, where - ;; inhibit-quit is set. In later versions of emacs read-char - ;; may clear quit-flag itself and return C-g. That would make - ;; it impossible to quit this loop in a simple way, so - ;; re-enable it here (for backward-compatibility the check for - ;; quit-flag below would still be necessary, so this seems - ;; like the simplest way to do things). - (setq quit-flag t - done t)) - ((or (= c ?\r) (= c ?\n) (= c ?\e)) - (setq done t)) - ((= c ?\C-u) - (setq ans "")) - ((and (/= c ?\b) (/= c ?\177)) - (setq ans (concat ans (char-to-string c)))) - ((> (length ans) 0) - (setq ans (substring ans 0 -1))))) - (if quit-flag - ;; Emulate a true quit, except that we have to return a value. - (prog1 - (setq quit-flag nil) - (message "Quit") - (beep t)) - (message "") - ans))) - -(defun term-send-invisible (str &optional proc) - "Read a string without echoing. -Then send it to the process running in the current buffer. A new-line -is additionally sent. String is not saved on term input history list. -Security bug: your string can still be temporarily recovered with -\\[view-lossage]." - (interactive "P") ; Defeat snooping via C-x esc - (if (not (stringp str)) - (setq str (term-read-noecho "Non-echoed text: " t))) - (if (not proc) - (setq proc (get-buffer-process (current-buffer)))) - (if (not proc) (error "Current buffer has no process") - (setq term-kill-echo-list (nconc term-kill-echo-list - (cons str nil))) - (term-send-string proc str) - (term-send-string proc "\n"))) - - -;;; Low-level process communication - -(defvar term-input-chunk-size 512 - "*Long inputs send to term processes are broken up into chunks of this size. -If your process is choking on big inputs, try lowering the value.") - -(defun term-send-string (proc str) - "Send PROCESS the contents of STRING as input. -This is equivalent to process-send-string, except that long input strings -are broken up into chunks of size term-input-chunk-size. Processes -are given a chance to output between chunks. This can help prevent processes -from hanging when you send them long inputs on some OS's." - (let* ((len (length str)) - (i (min len term-input-chunk-size))) - (process-send-string proc (substring str 0 i)) - (while (< i len) - (let ((next-i (+ i term-input-chunk-size))) - (accept-process-output) - (process-send-string proc (substring str i (min len next-i))) - (setq i next-i))))) - -(defun term-send-region (proc start end) - "Sends to PROC the region delimited by START and END. -This is a replacement for process-send-region that tries to keep -your process from hanging on long inputs. See term-send-string." - (term-send-string proc (buffer-substring start end))) - - -;;; Random input hackage - -(defun term-kill-output () - "Kill all output from interpreter since last input." - (interactive) - (let ((pmark (process-mark (get-buffer-process (current-buffer))))) - (kill-region term-last-input-end pmark) - (goto-char pmark) - (insert "*** output flushed ***\n") - (set-marker pmark (point)))) - -(defun term-show-output () - "Display start of this batch of interpreter output at top of window. -Sets mark to the value of point when this command is run." - (interactive) - (goto-char term-last-input-end) - (backward-char) - (beginning-of-line) - (set-window-start (selected-window) (point)) - (end-of-line)) - -(defun term-interrupt-subjob () - "Interrupt the current subjob." - (interactive) - (interrupt-process nil term-ptyp)) - -(defun term-kill-subjob () - "Send kill signal to the current subjob." - (interactive) - (kill-process nil term-ptyp)) - -(defun term-quit-subjob () - "Send quit signal to the current subjob." - (interactive) - (quit-process nil term-ptyp)) - -(defun term-stop-subjob () - "Stop the current subjob. -WARNING: if there is no current subjob, you can end up suspending -the top-level process running in the buffer. If you accidentally do -this, use \\[term-continue-subjob] to resume the process. (This -is not a problem with most shells, since they ignore this signal.)" - (interactive) - (stop-process nil term-ptyp)) - -(defun term-continue-subjob () - "Send CONT signal to process buffer's process group. -Useful if you accidentally suspend the top-level process." - (interactive) - (continue-process nil term-ptyp)) - -(defun term-kill-input () - "Kill all text from last stuff output by interpreter to point." - (interactive) - (let* ((pmark (process-mark (get-buffer-process (current-buffer)))) - (p-pos (marker-position pmark))) - (if (> (point) p-pos) - (kill-region pmark (point))))) - -(defun term-delchar-or-maybe-eof (arg) - "Delete ARG characters forward, or send an EOF to process if at end of buffer." - (interactive "p") - (if (eobp) - (process-send-eof) - (delete-char arg))) - -(defun term-send-eof () - "Send an EOF to the current buffer's process." - (interactive) - (process-send-eof)) - -(defun term-backward-matching-input (regexp arg) - "Search backward through buffer for match for REGEXP. -Matches are searched for on lines that match `term-prompt-regexp'. -With prefix argument N, search for Nth previous match. -If N is negative, find the next or Nth next match." - (interactive (term-regexp-arg "Backward input matching (regexp): ")) - (let* ((re (concat term-prompt-regexp ".*" regexp)) - (pos (save-excursion (end-of-line (if (> arg 0) 0 1)) - (if (re-search-backward re nil t arg) - (point))))) - (if (null pos) - (progn (message "Not found") - (ding)) - (goto-char pos) - (term-bol nil)))) - -(defun term-forward-matching-input (regexp arg) - "Search forward through buffer for match for REGEXP. -Matches are searched for on lines that match `term-prompt-regexp'. -With prefix argument N, search for Nth following match. -If N is negative, find the previous or Nth previous match." - (interactive (term-regexp-arg "Forward input matching (regexp): ")) - (term-backward-matching-input regexp (- arg))) - - -(defun term-next-prompt (n) - "Move to end of Nth next prompt in the buffer. -See `term-prompt-regexp'." - (interactive "p") - (let ((paragraph-start term-prompt-regexp)) - (end-of-line (if (> n 0) 1 0)) - (forward-paragraph n) - (term-skip-prompt))) - -(defun term-previous-prompt (n) - "Move to end of Nth previous prompt in the buffer. -See `term-prompt-regexp'." - (interactive "p") - (term-next-prompt (- n))) - -;;; Support for source-file processing commands. -;;;============================================================================ -;;; Many command-interpreters (e.g., Lisp, Scheme, Soar) have -;;; commands that process files of source text (e.g. loading or compiling -;;; files). So the corresponding process-in-a-buffer modes have commands -;;; for doing this (e.g., lisp-load-file). The functions below are useful -;;; for defining these commands. -;;; -;;; Alas, these guys don't do exactly the right thing for Lisp, Scheme -;;; and Soar, in that they don't know anything about file extensions. -;;; So the compile/load interface gets the wrong default occasionally. -;;; The load-file/compile-file default mechanism could be smarter -- it -;;; doesn't know about the relationship between filename extensions and -;;; whether the file is source or executable. If you compile foo.lisp -;;; with compile-file, then the next load-file should use foo.bin for -;;; the default, not foo.lisp. This is tricky to do right, particularly -;;; because the extension for executable files varies so much (.o, .bin, -;;; .lbin, .mo, .vo, .ao, ...). - - -;;; TERM-SOURCE-DEFAULT -- determines defaults for source-file processing -;;; commands. -;;; -;;; TERM-CHECK-SOURCE -- if FNAME is in a modified buffer, asks you if you -;;; want to save the buffer before issuing any process requests to the command -;;; interpreter. -;;; -;;; TERM-GET-SOURCE -- used by the source-file processing commands to prompt -;;; for the file to process. - -;;; (TERM-SOURCE-DEFAULT previous-dir/file source-modes) -;;;============================================================================ -;;; This function computes the defaults for the load-file and compile-file -;;; commands for tea, soar, cmulisp, and cmuscheme modes. -;;; -;;; - PREVIOUS-DIR/FILE is a pair (directory . filename) from the last -;;; source-file processing command. NIL if there hasn't been one yet. -;;; - SOURCE-MODES is a list used to determine what buffers contain source -;;; files: if the major mode of the buffer is in SOURCE-MODES, it's source. -;;; Typically, (lisp-mode) or (scheme-mode). -;;; -;;; If the command is given while the cursor is inside a string, *and* -;;; the string is an existing filename, *and* the filename is not a directory, -;;; then the string is taken as default. This allows you to just position -;;; your cursor over a string that's a filename and have it taken as default. -;;; -;;; If the command is given in a file buffer whose major mode is in -;;; SOURCE-MODES, then the filename is the default file, and the -;;; file's directory is the default directory. -;;; -;;; If the buffer isn't a source file buffer (e.g., it's the process buffer), -;;; then the default directory & file are what was used in the last source-file -;;; processing command (i.e., PREVIOUS-DIR/FILE). If this is the first time -;;; the command has been run (PREVIOUS-DIR/FILE is nil), the default directory -;;; is the cwd, with no default file. (\"no default file\" = nil) -;;; -;;; SOURCE-REGEXP is typically going to be something like (tea-mode) -;;; for T programs, (lisp-mode) for Lisp programs, (soar-mode lisp-mode) -;;; for Soar programs, etc. -;;; -;;; The function returns a pair: (default-directory . default-file). - -(defun term-source-default (previous-dir/file source-modes) - (cond ((and buffer-file-name (memq major-mode source-modes)) - (cons (file-name-directory buffer-file-name) - (file-name-nondirectory buffer-file-name))) - (previous-dir/file) - (t - (cons default-directory nil)))) - - -;;; (TERM-CHECK-SOURCE fname) -;;;============================================================================ -;;; Prior to loading or compiling (or otherwise processing) a file (in the CMU -;;; process-in-a-buffer modes), this function can be called on the filename. -;;; If the file is loaded into a buffer, and the buffer is modified, the user -;;; is queried to see if he wants to save the buffer before proceeding with -;;; the load or compile. - -(defun term-check-source (fname) - (let ((buff (get-file-buffer fname))) - (if (and buff - (buffer-modified-p buff) - (y-or-n-p (format "Save buffer %s first? " - (buffer-name buff)))) - ;; save BUFF. - (let ((old-buffer (current-buffer))) - (set-buffer buff) - (save-buffer) - (set-buffer old-buffer))))) - - -;;; (TERM-GET-SOURCE prompt prev-dir/file source-modes mustmatch-p) -;;;============================================================================ -;;; TERM-GET-SOURCE is used to prompt for filenames in command-interpreter -;;; commands that process source files (like loading or compiling a file). -;;; It prompts for the filename, provides a default, if there is one, -;;; and returns the result filename. -;;; -;;; See TERM-SOURCE-DEFAULT for more on determining defaults. -;;; -;;; PROMPT is the prompt string. PREV-DIR/FILE is the (directory . file) pair -;;; from the last source processing command. SOURCE-MODES is a list of major -;;; modes used to determine what file buffers contain source files. (These -;;; two arguments are used for determining defaults). If MUSTMATCH-P is true, -;;; then the filename reader will only accept a file that exists. -;;; -;;; A typical use: -;;; (interactive (term-get-source "Compile file: " prev-lisp-dir/file -;;; '(lisp-mode) t)) - -;;; This is pretty stupid about strings. It decides we're in a string -;;; if there's a quote on both sides of point on the current line. -(defun term-extract-string () - "Returns string around POINT that starts the current line or nil." - (save-excursion - (let* ((point (point)) - (bol (progn (beginning-of-line) (point))) - (eol (progn (end-of-line) (point))) - (start (progn (goto-char point) - (and (search-backward "\"" bol t) - (1+ (point))))) - (end (progn (goto-char point) - (and (search-forward "\"" eol t) - (1- (point)))))) - (and start end - (buffer-substring start end))))) - -(defun term-get-source (prompt prev-dir/file source-modes mustmatch-p) - (let* ((def (term-source-default prev-dir/file source-modes)) - (stringfile (term-extract-string)) - (sfile-p (and stringfile - (condition-case () - (file-exists-p stringfile) - (error nil)) - (not (file-directory-p stringfile)))) - (defdir (if sfile-p (file-name-directory stringfile) - (car def))) - (deffile (if sfile-p (file-name-nondirectory stringfile) - (cdr def))) - (ans (read-file-name (if deffile (format "%s(default %s) " - prompt deffile) - prompt) - defdir - (concat defdir deffile) - mustmatch-p))) - (list (expand-file-name (substitute-in-file-name ans))))) - -;;; I am somewhat divided on this string-default feature. It seems -;;; to violate the principle-of-least-astonishment, in that it makes -;;; the default harder to predict, so you actually have to look and see -;;; what the default really is before choosing it. This can trip you up. -;;; On the other hand, it can be useful, I guess. I would appreciate feedback -;;; on this. -;;; -Olin - - -;;; Simple process query facility. -;;; =========================================================================== -;;; This function is for commands that want to send a query to the process -;;; and show the response to the user. For example, a command to get the -;;; arglist for a Common Lisp function might send a "(arglist 'foo)" query -;;; to an inferior Common Lisp process. -;;; -;;; This simple facility just sends strings to the inferior process and pops -;;; up a window for the process buffer so you can see what the process -;;; responds with. We don't do anything fancy like try to intercept what the -;;; process responds with and put it in a pop-up window or on the message -;;; line. We just display the buffer. Low tech. Simple. Works good. - -;;; Send to the inferior process PROC the string STR. Pop-up but do not select -;;; a window for the inferior process so that its response can be seen. -(defun term-proc-query (proc str) - (let* ((proc-buf (process-buffer proc)) - (proc-mark (process-mark proc))) - (display-buffer proc-buf) - (set-buffer proc-buf) ; but it's not the selected *window* - (let ((proc-win (get-buffer-window proc-buf)) - (proc-pt (marker-position proc-mark))) - (term-send-string proc str) ; send the query - (accept-process-output proc) ; wait for some output - ;; Try to position the proc window so you can see the answer. - ;; This is bogus code. If you delete the (sit-for 0), it breaks. - ;; I don't know why. Wizards invited to improve it. - (if (not (pos-visible-in-window-p proc-pt proc-win)) - (let ((opoint (window-point proc-win))) - (set-window-point proc-win proc-mark) (sit-for 0) - (if (not (pos-visible-in-window-p opoint proc-win)) - (push-mark opoint) - (set-window-point proc-win opoint))))))) - -;;; Returns the current column in the current screen line. -;;; Note: (current-column) yields column in buffer line. - -(defun term-horizontal-column () - (- (term-current-column) (term-start-line-column))) - -;; Calls either vertical-motion or buffer-vertical-motion -(defmacro term-vertical-motion (count) - (list 'funcall 'term-vertical-motion count)) - -;; An emulation of vertical-motion that is independent of having a window. -;; Instead, it uses the term-width variable as the logical window width. - -(defun buffer-vertical-motion (count) - (cond ((= count 0) - (move-to-column (* term-width (/ (current-column) term-width))) - 0) - ((> count 0) - (let ((H) - (todo (+ count (/ (current-column) term-width)))) - (end-of-line) - ;; The loop iterates over buffer lines; - ;; H is the number of screen lines in the current line, i.e. - ;; the ceiling of dividing the buffer line width by term-width. - (while (and (<= (setq H (max (/ (+ (current-column) term-width -1) - term-width) - 1)) - todo) - (not (eobp))) - (setq todo (- todo H)) - (forward-char) ;; Move past the ?\n - (end-of-line)) ;; and on to the end of the next line. - (if (and (>= todo H) (> todo 0)) - (+ (- count todo) H -1) ;; Hit end of buffer. - (move-to-column (* todo term-width)) - count))) - (t ;; (< count 0) ;; Similar algorithm, but for upward motion. - (let ((H) - (todo (- count))) - (while (and (<= (setq H (max (/ (+ (current-column) term-width -1) - term-width) - 1)) - todo) - (progn (beginning-of-line) - (not (bobp)))) - (setq todo (- todo H)) - (backward-char)) ;; Move to end of previous line. - (if (and (>= todo H) (> todo 0)) - (+ count todo (- 1 H)) ;; Hit beginning of buffer. - (move-to-column (* (- H todo 1) term-width)) - count))))) - -;;; The term-start-line-column variable is used as a cache. -(defun term-start-line-column () - (cond (term-start-line-column) - ((let ((save-pos (point))) - (term-vertical-motion 0) - (setq term-start-line-column (current-column)) - (goto-char save-pos) - term-start-line-column)))) - -;;; Same as (current-column), but uses term-current-column as a cache. -(defun term-current-column () - (cond (term-current-column) - ((setq term-current-column (current-column))))) - -;;; Move DELTA column right (or left if delta < 0). - -(defun term-move-columns (delta) - (setq term-current-column (+ (term-current-column) delta)) - (move-to-column term-current-column t)) - -;; Insert COUNT copies of CHAR in the default face. -(defun term-insert-char (char count) - (let ((old-point (point))) - (insert-char char count) - (put-text-property old-point (point) 'face 'default))) - -(defun term-current-row () - (cond (term-current-row) - ((setq term-current-row - (save-restriction - (save-excursion - (narrow-to-region term-home-marker (point-max)) - (- (term-vertical-motion -9999)))))))) - -(defun term-adjust-current-row-cache (delta) - (if term-current-row - (setq term-current-row (+ term-current-row delta)))) - -(defun term-terminal-pos () - (save-excursion ; save-restriction - (let ((save-col (term-current-column)) - x y) - (term-vertical-motion 0) - (setq x (- save-col (current-column))) - (setq y (term-vertical-motion term-height)) - (cons x y)))) - -;;; Terminal emulation -;;; This is the standard process filter for term buffers. -;;; It emulates (most of the features of) a VT100/ANSI-style terminal. - -(defun term-emulate-terminal (proc str) - (let* ((previous-buffer (current-buffer)) - (i 0) char funny count save-point save-marker old-point temp win - (selected (selected-window)) - (str-length (length str))) - (unwind-protect - (progn - (set-buffer (process-buffer proc)) - - (if (marker-buffer term-pending-delete-marker) - (progn - ;; Delete text following term-pending-delete-marker. - (delete-region term-pending-delete-marker (process-mark proc)) - (set-marker term-pending-delete-marker nil))) - - (if (eq (window-buffer) (current-buffer)) - (progn - (setq term-vertical-motion (symbol-function 'vertical-motion)) - (term-check-size proc)) - (setq term-vertical-motion - (symbol-function 'buffer-vertical-motion))) - - (setq save-marker (copy-marker (process-mark proc))) - - (if (/= (point) (process-mark proc)) - (progn (setq save-point (point-marker)) - (goto-char (process-mark proc)))) - - (save-restriction - ;; If the buffer is in line mode, and there is a partial - ;; input line, save the line (by narrowing to leave it - ;; outside the restriction ) until we're done with output. - (if (and (> (point-max) (process-mark proc)) - (term-in-line-mode)) - (narrow-to-region (point-min) (process-mark proc))) - - (if term-log-buffer - (princ str term-log-buffer)) - (cond ((eq term-terminal-state 4) ;; Have saved pending output. - (setq str (concat term-terminal-parameter str)) - (setq term-terminal-parameter nil) - (setq str-length (length str)) - (setq term-terminal-state 0))) - - (while (< i str-length) - (setq char (aref str i)) - (cond ((< term-terminal-state 2) - ;; Look for prefix of regular chars - (setq funny - (string-match "[\r\n\000\007\033\t\b\032\016\017]" - str i)) - (if (not funny) (setq funny str-length)) - (cond ((> funny i) - (cond ((eq term-terminal-state 1) - (term-move-columns 1) - (setq term-terminal-state 0))) - (setq count (- funny i)) - (setq temp (- (+ (term-horizontal-column) count) - term-width)) - (cond ((<= temp 0)) ;; All count chars fit in line. - ((> count temp) ;; Some chars fit. - ;; This iteration, handle only what fits. - (setq count (- count temp)) - (setq funny (+ count i))) - ((or (not (or term-pager-count - term-scroll-with-delete)) - (> (term-handle-scroll 1) 0)) - (term-adjust-current-row-cache 1) - (setq count (min count term-width)) - (setq funny (+ count i)) - (setq term-start-line-column - term-current-column)) - (t ;; Doing PAGER processing. - (setq count 0 funny i) - (setq term-current-column nil) - (setq term-start-line-column nil))) - (setq old-point (point)) - ;; In the common case that we're at the end of - ;; the buffer, we can save a little work. - (cond ((/= (point) (point-max)) - (if term-insert-mode - ;; Inserting spaces, then deleting them, - ;; then inserting the actual text is - ;; inefficient, but it is simple, and - ;; the actual overhead is miniscule. - (term-insert-spaces count)) - (term-move-columns count) - (delete-region old-point (point))) - (t (setq term-current-column (+ (term-current-column) count)))) - (insert (substring str i funny)) - (put-text-property old-point (point) - 'face term-current-face) - ;; If the last char was written in last column, - ;; back up one column, but remember we did so. - ;; Thus we emulate xterm/vt100-style line-wrapping. - (cond ((eq temp 0) - (term-move-columns -1) - (setq term-terminal-state 1))) - (setq i (1- funny))) - ((and (setq term-terminal-state 0) - (eq char ?\^I)) ; TAB - ;; FIXME: Does not handle line wrap! - (setq count (term-current-column)) - (setq count (+ count 8 (- (mod count 8)))) - (if (< (move-to-column count nil) count) - (term-insert-char char 1)) - (setq term-current-column count)) - ((eq char ?\r) - ;; Optimize CRLF at end of buffer: - (cond ((and (< (setq temp (1+ i)) str-length) - (eq (aref str temp) ?\n) - (= (point) (point-max)) - (not (or term-pager-count - term-kill-echo-list - term-scroll-with-delete))) - (insert ?\n) - (term-adjust-current-row-cache 1) - (setq term-start-line-column 0) - (setq term-current-column 0) - (setq i temp)) - (t ;; Not followed by LF or can't optimize: - (term-vertical-motion 0) - (setq term-current-column term-start-line-column)))) - ((eq char ?\n) - (if (not (and term-kill-echo-list - (term-check-kill-echo-list))) - (term-down 1 t))) - ((eq char ?\b) - (term-move-columns -1)) - ((eq char ?\033) ; Escape - (setq term-terminal-state 2)) - ((eq char ?\0)) ; NUL: Do nothing - ((eq char ?\016)) ; Shift Out - ignored - ((eq char ?\017)) ; Shift In - ignored - ((eq char ?\^G) - (beep t)) ; Bell - ((eq char ?\032) - (let ((end (string-match "\n" str i))) - (if end - (progn (funcall term-command-hook - (substring str (1+ i) (1- end))) - (setq i end)) - (setq term-terminal-parameter - (substring str i)) - (setq term-terminal-state 4) - (setq i str-length)))) - (t ; insert char FIXME: Should never happen - (term-move-columns 1) - (backward-delete-char 1) - (insert char)))) - ((eq term-terminal-state 2) ; Seen Esc - (cond ((eq char ?\133) ;; ?\133 = ?[ - (make-local-variable 'term-terminal-parameter) - (make-local-variable 'term-terminal-previous-parameter) - (setq term-terminal-parameter 0) - (setq term-terminal-previous-parameter 0) - (setq term-terminal-state 3)) - ((eq char ?D) ;; scroll forward - (term-handle-deferred-scroll) - (term-down 1 t) - (setq term-terminal-state 0)) - ((eq char ?M) ;; scroll reversed - (term-insert-lines 1) - (setq term-terminal-state 0)) - ((eq char ?7) ;; Save cursor - (term-handle-deferred-scroll) - (setq term-saved-cursor - (cons (term-current-row) - (term-horizontal-column))) - (setq term-terminal-state 0)) - ((eq char ?8) ;; Restore cursor - (if term-saved-cursor - (term-goto (car term-saved-cursor) - (cdr term-saved-cursor))) - (setq term-terminal-state 0)) - ((setq term-terminal-state 0)))) - ((eq term-terminal-state 3) ; Seen Esc [ - (cond ((and (>= char ?0) (<= char ?9)) - (setq term-terminal-parameter - (+ (* 10 term-terminal-parameter) (- char ?0)))) - ((eq char ?\073 ) ; ?; - (setq term-terminal-previous-parameter - term-terminal-parameter) - (setq term-terminal-parameter 0)) - ((eq char ??)) ; Ignore ? - (t - (term-handle-ansi-escape proc char) - (setq term-terminal-state 0))))) - (if (term-handling-pager) - ;; Finish stuff to get ready to handle PAGER. - (progn - (if (> (% (current-column) term-width) 0) - (setq term-terminal-parameter - (substring str i)) - ;; We're at column 0. Goto end of buffer; to compensate, - ;; prepend a ?\r for later. This looks more consistent. - (if (zerop i) - (setq term-terminal-parameter - (concat "\r" (substring str i))) - (setq term-terminal-parameter (substring str (1- i))) - (aset term-terminal-parameter 0 ?\r)) - (goto-char (point-max))) - (setq term-terminal-state 4) - (make-local-variable 'term-pager-old-filter) - (setq term-pager-old-filter (process-filter proc)) - (set-process-filter proc term-pager-filter) - (setq i str-length))) - (setq i (1+ i)))) - - (if (>= (term-current-row) term-height) - (term-handle-deferred-scroll)) - - (set-marker (process-mark proc) (point)) - (if save-point - (progn (goto-char save-point) - (set-marker save-point nil))) - - ;; Check for a pending filename-and-line number to display. - ;; We do this before scrolling, because we might create a new window. - (if (and term-pending-frame - (eq (window-buffer selected) (current-buffer))) - (progn (term-display-line (car term-pending-frame) - (cdr term-pending-frame)) - (setq term-pending-frame nil) - ;; We have created a new window, so check the window size. - (term-check-size proc))) - - ;; Scroll each window displaying the buffer but (by default) - ;; only if the point matches the process-mark we started with. - (setq win selected) - (while (progn - (setq win (next-window win nil t)) - (if (eq (window-buffer win) (process-buffer proc)) - (let ((scroll term-scroll-to-bottom-on-output)) - (select-window win) - (if (or (= (point) save-marker) - (eq scroll t) (eq scroll 'all) - ;; Maybe user wants point to jump to the end. - (and (eq selected win) - (or (eq scroll 'this) (not save-point))) - (and (eq scroll 'others) - (not (eq selected win)))) - (progn - (goto-char term-home-marker) - (recenter 0) - (goto-char (process-mark proc)) - (if (not (pos-visible-in-window-p (point) win)) - (recenter -1)))) - ;; Optionally scroll so that the text - ;; ends at the bottom of the window. - (if (and term-scroll-show-maximum-output - (>= (point) (process-mark proc))) - (save-excursion - (goto-char (point-max)) - (recenter -1))))) - (not (eq win selected)))) - - (set-marker save-marker nil)) - ;; unwind-protect cleanup-forms follow: - (set-buffer previous-buffer) - (select-window selected)))) - -(defun term-handle-deferred-scroll () - (let ((count (- (term-current-row) term-height))) - (if (>= count 0) - (save-excursion - (goto-char term-home-marker) - (term-vertical-motion (1+ count)) - (set-marker term-home-marker (point)) - (setq term-current-row (1- term-height)))))) - -;;; Handle a character assuming (eq terminal-state 2) - -;;; i.e. we have previously seen Escape followed by ?[. - -(defun term-handle-ansi-escape (proc char) - (cond - ((eq char ?H) ; cursor motion - (if (<= term-terminal-parameter 0) - (setq term-terminal-parameter 1)) - (if (<= term-terminal-previous-parameter 0) - (setq term-terminal-previous-parameter 1)) - (if (> term-terminal-previous-parameter term-height) - (setq term-terminal-previous-parameter term-height)) - (if (> term-terminal-parameter term-width) - (setq term-terminal-parameter term-width)) - (term-goto - (1- term-terminal-previous-parameter) - (1- term-terminal-parameter))) - ;; \E[A - cursor up - ((eq char ?A) - (term-handle-deferred-scroll) - (term-down (- (max 1 term-terminal-parameter)) t)) - ;; \E[B - cursor down - ((eq char ?B) - (term-down (max 1 term-terminal-parameter) t)) - ;; \E[C - cursor right - ((eq char ?C) - (term-move-columns (max 1 term-terminal-parameter))) - ;; \E[D - cursor left - ((eq char ?D) - (term-move-columns (- (max 1 term-terminal-parameter)))) - ;; \E[J - clear to end of screen - ((eq char ?J) - (term-erase-in-display term-terminal-parameter)) - ;; \E[K - clear to end of line - ((eq char ?K) - (term-erase-in-line term-terminal-parameter)) - ;; \E[L - insert lines - ((eq char ?L) - (term-insert-lines (max 1 term-terminal-parameter))) - ;; \E[M - delete lines - ((eq char ?M) - (term-delete-lines (max 1 term-terminal-parameter))) - ;; \E[P - delete chars - ((eq char ?P) - (term-delete-chars (max 1 term-terminal-parameter))) - ;; \E[@ - insert spaces - ((eq char ?@) - (term-insert-spaces (max 1 term-terminal-parameter))) - ;; \E[?h - DEC Private Mode Set - ((eq char ?h) - (cond ((eq term-terminal-parameter 4) - (setq term-insert-mode t)) - ((eq term-terminal-parameter 47) - (term-switch-to-alternate-sub-buffer t)))) - ;; \E[?l - DEC Private Mode Reset - ((eq char ?l) - (cond ((eq term-terminal-parameter 4) - (setq term-insert-mode nil)) - ((eq term-terminal-parameter 47) - (term-switch-to-alternate-sub-buffer nil)))) - ;; \E[m - Set/reset standard mode - ((eq char ?m) - (cond ((eq term-terminal-parameter 7) - (setq term-current-face 'highlight)) - ((eq term-terminal-parameter 4) - (setq term-current-face 'term-underline-face)) - ((eq term-terminal-parameter 1) - (setq term-current-face 'bold)) - (t (setq term-current-face 'default)))) - ;; \E[6n - Report cursor position - ((eq char ?n) - (term-handle-deferred-scroll) - (process-send-string proc - (format "\e[%s;%sR" - (1+ (term-current-row)) - (1+ (term-horizontal-column))))) - ;; \E[r - Set scrolling region - ((eq char ?r) - (term-scroll-region - (1- term-terminal-previous-parameter) - term-terminal-parameter)) - (t))) - -(defun term-scroll-region (top bottom) - "Set scrolling region. -TOP is the top-most line (inclusive) of the new scrolling region, -while BOTTOM is the line following the new scrolling region (e.g. exclusive). -The top-most line is line 0." - (setq term-scroll-start - (if (or (< top 0) (>= top term-height)) - 0 - top)) - (setq term-scroll-end - (if (or (<= bottom term-scroll-start) (> bottom term-height)) - term-height - bottom)) - (setq term-scroll-with-delete - (or (term-using-alternate-sub-buffer) - (not (and (= term-scroll-start 0) - (= term-scroll-end term-height)))))) - -(defun term-switch-to-alternate-sub-buffer (set) - ;; If asked to switch to (from) the alternate sub-buffer, and already (not) - ;; using it, do nothing. This test is needed for some programs (including - ;; emacs) that emit the ti termcap string twice, for unknown reason. - (term-handle-deferred-scroll) - (if (eq set (not (term-using-alternate-sub-buffer))) - (let ((row (term-current-row)) - (col (term-horizontal-column))) - (cond (set - (goto-char (point-max)) - (if (not (eq (preceding-char) ?\n)) - (term-insert-char ?\n 1)) - (setq term-scroll-with-delete t) - (setq term-saved-home-marker (copy-marker term-home-marker)) - (set-marker term-home-marker (point))) - (t - (setq term-scroll-with-delete - (not (and (= term-scroll-start 0) - (= term-scroll-end term-height)))) - (set-marker term-home-marker term-saved-home-marker) - (set-marker term-saved-home-marker nil) - (setq term-saved-home-marker nil) - (goto-char term-home-marker))) - (setq term-current-column nil) - (setq term-current-row 0) - (term-goto row col)))) - -;; Default value for the symbol term-command-hook. - -(defun term-command-hook (string) - (cond ((= (aref string 0) ?\032) - ;; gdb (when invoked with -fullname) prints: - ;; \032\032FULLFILENAME:LINENUMBER:CHARPOS:BEG_OR_MIDDLE:PC\n - (let* ((first-colon (string-match ":" string 1)) - (second-colon - (string-match ":" string (1+ first-colon))) - (filename (substring string 1 first-colon)) - (fileline (string-to-int - (substring string (1+ first-colon) second-colon)))) - (setq term-pending-frame (cons filename fileline)))) - ((= (aref string 0) ?/) - ;; FIXME: If cd fails, should ignore, and not raise error. - (cd (substring string 1))) - ;; Allowing the inferior to call functions in emacs is - ;; probably too big a security hole. - ;; ((= (aref string 0) ?!) - ;; (eval (car (read-from-string string 1)))) - (t)));; Otherwise ignore it - -;; Make sure the file named TRUE-FILE is in a buffer that appears on the screen -;; and that its line LINE is visible. -;; Put the overlay-arrow on the line LINE in that buffer. -;; This is mainly used by gdb. - -(defun term-display-line (true-file line) - (term-display-buffer-line (find-file-noselect true-file) line)) - -(defun term-display-buffer-line (buffer line) - (let* ((window (display-buffer buffer t)) - (pos)) - (save-excursion - (set-buffer buffer) - (save-restriction - (widen) - (goto-line line) - (setq pos (point)) - (setq overlay-arrow-string "=>") - (or overlay-arrow-position - (setq overlay-arrow-position (make-marker))) - (set-marker overlay-arrow-position (point) (current-buffer))) - (cond ((or (< pos (point-min)) (> pos (point-max))) - (widen) - (goto-char pos)))) - (set-window-point window overlay-arrow-position))) - -;;; The buffer-local marker term-home-marker defines the "home position" -;;; (in terms of cursor motion). However, we move the term-home-marker -;;; "down" as needed so that is no more that a window-full above (point-max). - -(defun term-goto-home () - (term-handle-deferred-scroll) - (goto-char term-home-marker) - (setq term-current-row 0) - (setq term-current-column (current-column)) - (setq term-start-line-column term-current-column)) - -(defun term-goto (row col) - (term-handle-deferred-scroll) - (cond ((and term-current-row (>= row term-current-row)) - ;; I assume this is a worthwhile optimization. - (term-vertical-motion 0) - (setq term-current-column term-start-line-column) - (setq row (- row term-current-row))) - (t - (term-goto-home))) - (term-down row) - (term-move-columns col)) - -; The page is full, so enter "pager" mode, and wait for input. - -(defun term-process-pager () - (if (not term-pager-break-map) - (let* ((map (make-keymap)) - (i 0) tmp) -; (while (< i 128) -; (define-key map (make-string 1 i) 'term-send-raw) -; (setq i (1+ i))) - (define-key map "\e" - (lookup-key (current-global-map) "\e")) - (define-key map "\C-x" - (lookup-key (current-global-map) "\C-x")) - (define-key map "\C-u" - (lookup-key (current-global-map) "\C-u")) - (define-key map " " 'term-pager-page) - (define-key map "\r" 'term-pager-line) - (define-key map "?" 'term-pager-help) - (define-key map "h" 'term-pager-help) - (define-key map "b" 'term-pager-back-page) - (define-key map "\177" 'term-pager-back-line) - (define-key map "q" 'term-pager-discard) - (define-key map "D" 'term-pager-disable) - (define-key map "<" 'term-pager-bob) - (define-key map ">" 'term-pager-eob) - - ;; Add menu bar. - (term-if-emacs19 - (term-ifnot-xemacs - (define-key map [menu-bar terminal] term-terminal-menu) - (define-key map [menu-bar signals] term-signals-menu) - (setq tmp (make-sparse-keymap "More pages?")) - (define-key tmp [help] '("Help" . term-pager-help)) - (define-key tmp [disable] - '("Disable paging" . term-fake-pager-disable)) - (define-key tmp [discard] - '("Discard remaining output" . term-pager-discard)) - (define-key tmp [eob] '("Goto to end" . term-pager-eob)) - (define-key tmp [bob] '("Goto to beginning" . term-pager-bob)) - (define-key tmp [line] '("1 line forwards" . term-pager-line)) - (define-key tmp [bline] '("1 line backwards" . term-pager-back-line)) - (define-key tmp [back] '("1 page backwards" . term-pager-back-page)) - (define-key tmp [page] '("1 page forwards" . term-pager-page)) - (define-key map [menu-bar page] (cons "More pages?" tmp)) - )) - - (setq term-pager-break-map map))) -; (let ((process (get-buffer-process (current-buffer)))) -; (stop-process process)) - (setq term-pager-old-local-map (current-local-map)) - (use-local-map term-pager-break-map) - (make-local-variable 'term-old-mode-line-format) - (setq term-old-mode-line-format mode-line-format) - (setq mode-line-format - (list "-- **MORE** " - mode-line-buffer-identification - " [Type ? for help] " - "%-")) - (force-mode-line-update)) - -(defun term-pager-line (lines) - (interactive "p") - (let* ((moved (vertical-motion (1+ lines))) - (deficit (- lines moved))) - (if (> moved lines) - (backward-char)) - (cond ((<= deficit 0) ;; OK, had enough in the buffer for request. - (recenter (1- term-height))) - ((term-pager-continue deficit))))) - -(defun term-pager-page (arg) - "Proceed past the **MORE** break, allowing the next page of output to appear" - (interactive "p") - (term-pager-line (* arg term-height))) - -; Pager mode command to go to beginning of buffer -(defun term-pager-bob () - (interactive) - (goto-char (point-min)) - (if (= (vertical-motion term-height) term-height) - (backward-char)) - (recenter (1- term-height))) - -; pager mode command to go to end of buffer -(defun term-pager-eob () - (interactive) - (goto-char term-home-marker) - (recenter 0) - (goto-char (process-mark (get-buffer-process (current-buffer))))) - -(defun term-pager-back-line (lines) - (interactive "p") - (vertical-motion (- 1 lines)) - (if (not (bobp)) - (backward-char) - (beep) - ;; Move cursor to end of window. - (vertical-motion term-height) - (backward-char)) - (recenter (1- term-height))) - -(defun term-pager-back-page (arg) - (interactive "p") - (term-pager-back-line (* arg term-height))) - -(defun term-pager-discard () - (interactive) - (setq term-terminal-parameter "") - (interrupt-process nil t) - (term-pager-continue term-height)) - -; Disable pager processing. -; Only callable while in pager mode. (Contrast term-disable-pager.) -(defun term-pager-disable () - (interactive) - (if (term-handling-pager) - (term-pager-continue nil) - (setq term-pager-count nil)) - (term-update-mode-line)) - -; Enable pager processing. -(defun term-pager-enable () - (interactive) - (or (term-pager-enabled) - (setq term-pager-count 0)) ;; Or maybe set to (term-current-row) ?? - (term-update-mode-line)) - -(defun term-pager-toggle () - (interactive) - (if (term-pager-enabled) (term-pager-disable) (term-pager-enable))) - -(term-ifnot-xemacs - (defalias 'term-fake-pager-enable 'term-pager-toggle) - (defalias 'term-fake-pager-disable 'term-pager-toggle) - (put 'term-char-mode 'menu-enable '(term-in-line-mode)) - (put 'term-line-mode 'menu-enable '(term-in-char-mode)) - (put 'term-fake-pager-enable 'menu-enable '(not term-pager-count)) - (put 'term-fake-pager-disable 'menu-enable 'term-pager-count)) - -(defun term-pager-help () - "Provide help on commands available in a terminal-emulator **MORE** break" - (interactive) - (message "Terminal-emulator pager break help...") - (sit-for 0) - (with-electric-help - (function (lambda () - (princ (substitute-command-keys -"\\<term-pager-break-map>\ -Terminal-emulator MORE break.\n\ -Type one of the following keys:\n\n\ -\\[term-pager-page]\t\tMove forward one page.\n\ -\\[term-pager-line]\t\tMove forward one line.\n\ -\\[universal-argument] N \\[term-pager-page]\tMove N pages forward.\n\ -\\[universal-argument] N \\[term-pager-line]\tMove N lines forward.\n\ -\\[universal-argument] N \\[term-pager-back-line]\tMove N lines back.\n\ -\\[universal-argument] N \\[term-pager-back-page]\t\tMove N pages back.\n\ -\\[term-pager-bob]\t\tMove to the beginning of the buffer.\n\ -\\[term-pager-eob]\t\tMove to the end of the buffer.\n\ -\\[term-pager-discard]\t\tKill pending output and kill process.\n\ -\\[term-pager-disable]\t\tDisable PAGER handling.\n\n\ -\\{term-pager-break-map}\n\ -Any other key is passed through to the program -running under the terminal emulator and disables pager processing until -all pending output has been dealt with.")) - nil)))) - -(defun term-pager-continue (new-count) - (let ((process (get-buffer-process (current-buffer)))) - (use-local-map term-pager-old-local-map) - (setq term-pager-old-local-map nil) - (setq mode-line-format term-old-mode-line-format) - (force-mode-line-update) - (setq term-pager-count new-count) - (set-process-filter process term-pager-old-filter) - (funcall term-pager-old-filter process "") - (continue-process process))) - -;; Make sure there are DOWN blank lines below the current one. -;; Return 0 if we're unable (because of PAGER handling), else return DOWN. - -(defun term-handle-scroll (down) - (let ((scroll-needed - (- (+ (term-current-row) down 1) term-scroll-end))) - (if (> scroll-needed 0) - (let ((save-point (copy-marker (point))) (save-top)) - (goto-char term-home-marker) - (cond (term-scroll-with-delete - ;; delete scroll-needed lines at term-scroll-start - (term-vertical-motion term-scroll-start) - (setq save-top (point)) - (term-vertical-motion scroll-needed) - (delete-region save-top (point)) - (goto-char save-point) - (term-vertical-motion down) - (term-adjust-current-row-cache (- scroll-needed)) - (setq term-current-column nil) - (term-insert-char ?\n scroll-needed)) - ((and (numberp term-pager-count) - (< (setq term-pager-count (- term-pager-count down)) - 0)) - (setq down 0) - (term-process-pager)) - (t - (term-adjust-current-row-cache (- scroll-needed)) - (term-vertical-motion scroll-needed) - (set-marker term-home-marker (point)))) - (goto-char save-point) - (set-marker save-point nil)))) - down) - -(defun term-down (down &optional check-for-scroll) - "Move down DOWN screen lines vertically." - (let ((start-column (term-horizontal-column))) - (if (and check-for-scroll (or term-scroll-with-delete term-pager-count)) - (setq down (term-handle-scroll down))) - (term-adjust-current-row-cache down) - (if (/= (point) (point-max)) - (setq down (- down (term-vertical-motion down)))) - ;; Extend buffer with extra blank lines if needed. - (cond ((> down 0) - (term-insert-char ?\n down) - (setq term-current-column 0) - (setq term-start-line-column 0)) - (t - (setq term-current-column nil) - (setq term-start-line-column (current-column)))) - (if start-column - (term-move-columns start-column)))) - -;; Assuming point is at the beginning of a screen line, -;; if the line above point wraps around, add a ?\n to undo the wrapping. -;; FIXME: Probably should be called more than it is. -(defun term-unwrap-line () - (if (not (bolp)) (insert-before-markers ?\n))) - -(defun term-erase-in-line (kind) - (if (> kind 1) ;; erase left of point - (let ((cols (term-horizontal-column)) (saved-point (point))) - (term-vertical-motion 0) - (delete-region (point) saved-point) - (term-insert-char ?\n cols))) - (if (not (eq kind 1)) ;; erase right of point - (let ((saved-point (point)) - (wrapped (and (zerop (term-horizontal-column)) - (not (zerop (term-current-column)))))) - (term-vertical-motion 1) - (delete-region saved-point (point)) - ;; wrapped is true if we're at the beginning of screen line, - ;; but not a buffer line. If we delete the current screen line - ;; that will make the previous line no longer wrap, and (because - ;; of the way emacs display works) point will be at the end of - ;; the previous screen line rather then the beginning of the - ;; current one. To avoid that, we make sure that current line - ;; contain a space, to force the previous line to continue to wrap. - ;; We could do this always, but it seems preferable to not add the - ;; extra space when wrapped is false. - (if wrapped - (insert ? )) - (insert ?\n) - (put-text-property saved-point (point) 'face 'default) - (goto-char saved-point)))) - -(defun term-erase-in-display (kind) - "Erases (that is blanks out) part of the window. -If KIND is 0, erase from (point) to (point-max); -if KIND is 1, erase from home to point; else erase from home to point-max. -Should only be called when point is at the start of a screen line." - (term-handle-deferred-scroll) - (cond ((eq term-terminal-parameter 0) - (delete-region (point) (point-max)) - (term-unwrap-line)) - ((let ((row (term-current-row)) - (col (term-horizontal-column)) - (start-region term-home-marker) - (end-region (if (eq kind 1) (point) (point-max)))) - (delete-region start-region end-region) - (term-unwrap-line) - (if (eq kind 1) - (term-insert-char ?\n row)) - (setq term-current-column nil) - (setq term-current-row nil) - (term-goto row col))))) - -(defun term-delete-chars (count) - (let ((save-point (point))) - (term-vertical-motion 1) - (term-unwrap-line) - (goto-char save-point) - (move-to-column (+ (term-current-column) count) t) - (delete-region save-point (point)))) - -;;; Insert COUNT spaces after point, but do not change any of -;;; following screen lines. Hence we may have to delete characters -;;; at teh end of this screen line to make room. - -(defun term-insert-spaces (count) - (let ((save-point (point)) (save-eol)) - (term-vertical-motion 1) - (if (bolp) - (backward-char)) - (setq save-eol (point)) - (move-to-column (+ (term-start-line-column) (- term-width count)) t) - (if (> save-eol (point)) - (delete-region (point) save-eol)) - (goto-char save-point) - (term-insert-char ? count) - (goto-char save-point))) - -(defun term-delete-lines (lines) - (let ((start (point)) - (save-current-column term-current-column) - (save-start-line-column term-start-line-column) - (save-current-row (term-current-row))) - (term-down lines) - (delete-region start (point)) - (term-down (- term-scroll-end save-current-row lines)) - (term-insert-char ?\n lines) - (setq term-current-column save-current-column) - (setq term-start-line-column save-start-line-column) - (setq term-current-row save-current-row) - (goto-char start))) - -(defun term-insert-lines (lines) - (let ((start (point)) - (start-deleted) - (save-current-column term-current-column) - (save-start-line-column term-start-line-column) - (save-current-row (term-current-row))) - (term-down (- term-scroll-end save-current-row lines)) - (setq start-deleted (point)) - (term-down lines) - (delete-region start-deleted (point)) - (goto-char start) - (setq term-current-column save-current-column) - (setq term-start-line-column save-start-line-column) - (setq term-current-row save-current-row) - (term-insert-char ?\n lines) - (goto-char start))) - -(defun term-set-output-log (name) - "Record raw inferior process output in a buffer." - (interactive (list (if term-log-buffer - nil - (read-buffer "Record output in buffer: " - (format "%s output-log" - (buffer-name (current-buffer))) - nil)))) - (if (or (null name) (equal name "")) - (progn (setq term-log-buffer nil) - (message "Output logging off.")) - (if (get-buffer name) - nil - (save-excursion - (set-buffer (get-buffer-create name)) - (fundamental-mode) - (buffer-disable-undo (current-buffer)) - (erase-buffer))) - (setq term-log-buffer (get-buffer name)) - (message "Recording terminal emulator output into buffer \"%s\"" - (buffer-name term-log-buffer)))) - -(defun term-stop-photo () - "Discontinue raw inferior process logging." - (interactive) - (term-set-output-log nil)) - -(defun term-show-maximum-output () - "Put the end of the buffer at the bottom of the window." - (interactive) - (goto-char (point-max)) - (recenter -1)) - -;;; Do the user's customisation... - -(defvar term-load-hook nil - "This hook is run when term is loaded in. -This is a good place to put keybindings.") - -(run-hooks 'term-load-hook) - - -;;; Filename/command/history completion in a buffer -;;; =========================================================================== -;;; Useful completion functions, courtesy of the Ergo group. - -;;; Six commands: -;;; term-dynamic-complete Complete or expand command, filename, -;;; history at point. -;;; term-dynamic-complete-filename Complete filename at point. -;;; term-dynamic-list-filename-completions List completions in help buffer. -;;; term-replace-by-expanded-filename Expand and complete filename at point; -;;; replace with expanded/completed name. -;;; term-dynamic-simple-complete Complete stub given candidates. - -;;; These are not installed in the term-mode keymap. But they are -;;; available for people who want them. Shell-mode installs them: -;;; (define-key shell-mode-map "\t" 'term-dynamic-complete) -;;; (define-key shell-mode-map "\M-?" -;;; 'term-dynamic-list-filename-completions))) -;;; -;;; Commands like this are fine things to put in load hooks if you -;;; want them present in specific modes. - -(defvar term-completion-autolist nil - "*If non-nil, automatically list possibilities on partial completion. -This mirrors the optional behavior of tcsh.") - -(defvar term-completion-addsuffix t - "*If non-nil, add a `/' to completed directories, ` ' to file names. -If a cons pair, it should be of the form (DIRSUFFIX . FILESUFFIX) where -DIRSUFFIX and FILESUFFIX are strings added on unambiguous or exact -completion. This mirrors the optional behavior of tcsh.") - -(defvar term-completion-recexact nil - "*If non-nil, use shortest completion if characters cannot be added. -This mirrors the optional behavior of tcsh. - -A non-nil value is useful if `term-completion-autolist' is non-nil too.") - -(defvar term-completion-fignore nil - "*List of suffixes to be disregarded during file completion. -This mirrors the optional behavior of bash and tcsh. - -Note that this applies to `term-dynamic-complete-filename' only.") - -(defvar term-file-name-prefix "" - "Prefix prepended to absolute file names taken from process input. -This is used by term's and shell's completion functions, and by shell's -directory tracking functions.") - - -(defun term-directory (directory) - ;; Return expanded DIRECTORY, with `term-file-name-prefix' if absolute. - (expand-file-name (if (file-name-absolute-p directory) - (concat term-file-name-prefix directory) - directory))) - - -(defun term-word (word-chars) - "Return the word of WORD-CHARS at point, or nil if non is found. -Word constituents are considered to be those in WORD-CHARS, which is like the -inside of a \"[...]\" (see `skip-chars-forward')." - (save-excursion - (let ((limit (point)) - (word (concat "[" word-chars "]")) - (non-word (concat "[^" word-chars "]"))) - (if (re-search-backward non-word nil 'move) - (forward-char 1)) - ;; Anchor the search forwards. - (if (or (eolp) (looking-at non-word)) - nil - (re-search-forward (concat word "+") limit) - (buffer-substring (match-beginning 0) (match-end 0)))))) - - -(defun term-match-partial-filename () - "Return the filename at point, or nil if non is found. -Environment variables are substituted. See `term-word'." - (let ((filename (term-word "~/A-Za-z0-9+@:_.$#,={}-"))) - (and filename (substitute-in-file-name filename)))) - - -(defun term-dynamic-complete () - "Dynamically perform completion at point. -Calls the functions in `term-dynamic-complete-functions' to perform -completion until a function returns non-nil, at which point completion is -assumed to have occurred." - (interactive) - (let ((functions term-dynamic-complete-functions)) - (while (and functions (null (funcall (car functions)))) - (setq functions (cdr functions))))) - - -(defun term-dynamic-complete-filename () - "Dynamically complete the filename at point. -Completes if after a filename. See `term-match-partial-filename' and -`term-dynamic-complete-as-filename'. -This function is similar to `term-replace-by-expanded-filename', except that -it won't change parts of the filename already entered in the buffer; it just -adds completion characters to the end of the filename. A completions listing -may be shown in a help buffer if completion is ambiguous. - -Completion is dependent on the value of `term-completion-addsuffix', -`term-completion-recexact' and `term-completion-fignore', and the timing of -completions listing is dependent on the value of `term-completion-autolist'. - -Returns t if successful." - (interactive) - (if (term-match-partial-filename) - (prog2 (or (eq (selected-window) (minibuffer-window)) - (message "Completing file name...")) - (term-dynamic-complete-as-filename)))) - -(defun term-dynamic-complete-as-filename () - "Dynamically complete at point as a filename. -See `term-dynamic-complete-filename'. Returns t if successful." - (let* ((completion-ignore-case nil) - (completion-ignored-extensions term-completion-fignore) - (success t) - (dirsuffix (cond ((not term-completion-addsuffix) "") - ((not (consp term-completion-addsuffix)) "/") - (t (car term-completion-addsuffix)))) - (filesuffix (cond ((not term-completion-addsuffix) "") - ((not (consp term-completion-addsuffix)) " ") - (t (cdr term-completion-addsuffix)))) - (filename (or (term-match-partial-filename) "")) - (pathdir (file-name-directory filename)) - (pathnondir (file-name-nondirectory filename)) - (directory (if pathdir (term-directory pathdir) default-directory)) - (completion (file-name-completion pathnondir directory)) - (mini-flag (eq (selected-window) (minibuffer-window)))) - (cond ((null completion) - (message "No completions of %s" filename) - (setq success nil)) - ((eq completion t) ; Means already completed "file". - (if term-completion-addsuffix (insert " ")) - (or mini-flag (message "Sole completion"))) - ((string-equal completion "") ; Means completion on "directory/". - (term-dynamic-list-filename-completions)) - (t ; Completion string returned. - (let ((file (concat (file-name-as-directory directory) completion))) - (insert (substring (directory-file-name completion) - (length pathnondir))) - (cond ((symbolp (file-name-completion completion directory)) - ;; We inserted a unique completion. - (insert (if (file-directory-p file) dirsuffix filesuffix)) - (or mini-flag (message "Completed"))) - ((and term-completion-recexact term-completion-addsuffix - (string-equal pathnondir completion) - (file-exists-p file)) - ;; It's not unique, but user wants shortest match. - (insert (if (file-directory-p file) dirsuffix filesuffix)) - (or mini-flag (message "Completed shortest"))) - ((or term-completion-autolist - (string-equal pathnondir completion)) - ;; It's not unique, list possible completions. - (term-dynamic-list-filename-completions)) - (t - (or mini-flag (message "Partially completed"))))))) - success)) - - -(defun term-replace-by-expanded-filename () - "Dynamically expand and complete the filename at point. -Replace the filename with an expanded, canonicalised and completed replacement. -\"Expanded\" means environment variables (e.g., $HOME) and `~'s are replaced -with the corresponding directories. \"Canonicalised\" means `..' and `.' are -removed, and the filename is made absolute instead of relative. For expansion -see `expand-file-name' and `substitute-in-file-name'. For completion see -`term-dynamic-complete-filename'." - (interactive) - (replace-match (expand-file-name (term-match-partial-filename)) t t) - (term-dynamic-complete-filename)) - - -(defun term-dynamic-simple-complete (stub candidates) - "Dynamically complete STUB from CANDIDATES list. -This function inserts completion characters at point by completing STUB from -the strings in CANDIDATES. A completions listing may be shown in a help buffer -if completion is ambiguous. - -Returns nil if no completion was inserted. -Returns `sole' if completed with the only completion match. -Returns `shortest' if completed with the shortest of the completion matches. -Returns `partial' if completed as far as possible with the completion matches. -Returns `listed' if a completion listing was shown. - -See also `term-dynamic-complete-filename'." - (let* ((completion-ignore-case nil) - (candidates (mapcar (function (lambda (x) (list x))) candidates)) - (completions (all-completions stub candidates))) - (cond ((null completions) - (message "No completions of %s" stub) - nil) - ((= 1 (length completions)) ; Gotcha! - (let ((completion (car completions))) - (if (string-equal completion stub) - (message "Sole completion") - (insert (substring completion (length stub))) - (message "Completed")) - (if term-completion-addsuffix (insert " ")) - 'sole)) - (t ; There's no unique completion. - (let ((completion (try-completion stub candidates))) - ;; Insert the longest substring. - (insert (substring completion (length stub))) - (cond ((and term-completion-recexact term-completion-addsuffix - (string-equal stub completion) - (member completion completions)) - ;; It's not unique, but user wants shortest match. - (insert " ") - (message "Completed shortest") - 'shortest) - ((or term-completion-autolist - (string-equal stub completion)) - ;; It's not unique, list possible completions. - (term-dynamic-list-completions completions) - 'listed) - (t - (message "Partially completed") - 'partial))))))) - - -(defun term-dynamic-list-filename-completions () - "List in help buffer possible completions of the filename at point." - (interactive) - (let* ((completion-ignore-case nil) - (filename (or (term-match-partial-filename) "")) - (pathdir (file-name-directory filename)) - (pathnondir (file-name-nondirectory filename)) - (directory (if pathdir (term-directory pathdir) default-directory)) - (completions (file-name-all-completions pathnondir directory))) - (if completions - (term-dynamic-list-completions completions) - (message "No completions of %s" filename)))) - - -(defun term-dynamic-list-completions (completions) - "List in help buffer sorted COMPLETIONS. -Typing SPC flushes the help buffer." - (let ((conf (current-window-configuration))) - (with-output-to-temp-buffer "*Completions*" - (display-completion-list (sort completions 'string-lessp))) - (message "Hit space to flush") - (let (key first) - (if (save-excursion - (set-buffer (get-buffer "*Completions*")) - (setq key (read-key-sequence nil) - first (aref key 0)) - (and (consp first) - (eq (window-buffer (posn-window (event-start first))) - (get-buffer "*Completions*")) - (eq (key-binding key) 'mouse-choose-completion))) - ;; If the user does mouse-choose-completion with the mouse, - ;; execute the command, then delete the completion window. - (progn - (mouse-choose-completion first) - (set-window-configuration conf)) - (if (eq first ?\ ) - (set-window-configuration conf) - (term-ifnot-xemacs - (setq unread-command-events (listify-key-sequence key))) - (term-if-xemacs - (setq unread-command-events (append key nil)))))))) - -;;; Converting process modes to use term mode -;;; =========================================================================== -;;; Renaming variables -;;; Most of the work is renaming variables and functions. These are the common -;;; ones: -;;; Local variables: -;;; last-input-start term-last-input-start -;;; last-input-end term-last-input-end -;;; shell-prompt-pattern term-prompt-regexp -;;; shell-set-directory-error-hook <no equivalent> -;;; Miscellaneous: -;;; shell-set-directory <unnecessary> -;;; shell-mode-map term-mode-map -;;; Commands: -;;; shell-send-input term-send-input -;;; shell-send-eof term-delchar-or-maybe-eof -;;; kill-shell-input term-kill-input -;;; interrupt-shell-subjob term-interrupt-subjob -;;; stop-shell-subjob term-stop-subjob -;;; quit-shell-subjob term-quit-subjob -;;; kill-shell-subjob term-kill-subjob -;;; kill-output-from-shell term-kill-output -;;; show-output-from-shell term-show-output -;;; copy-last-shell-input Use term-previous-input/term-next-input -;;; -;;; SHELL-SET-DIRECTORY is gone, its functionality taken over by -;;; SHELL-DIRECTORY-TRACKER, the shell mode's term-input-filter-functions. -;;; Term mode does not provide functionality equivalent to -;;; shell-set-directory-error-hook; it is gone. -;;; -;;; term-last-input-start is provided for modes which want to munge -;;; the buffer after input is sent, perhaps because the inferior -;;; insists on echoing the input. The LAST-INPUT-START variable in -;;; the old shell package was used to implement a history mechanism, -;;; but you should think twice before using term-last-input-start -;;; for this; the input history ring often does the job better. -;;; -;;; If you are implementing some process-in-a-buffer mode, called foo-mode, do -;;; *not* create the term-mode local variables in your foo-mode function. -;;; This is not modular. Instead, call term-mode, and let *it* create the -;;; necessary term-specific local variables. Then create the -;;; foo-mode-specific local variables in foo-mode. Set the buffer's keymap to -;;; be foo-mode-map, and its mode to be foo-mode. Set the term-mode hooks -;;; (term-{prompt-regexp, input-filter, input-filter-functions, -;;; get-old-input) that need to be different from the defaults. Call -;;; foo-mode-hook, and you're done. Don't run the term-mode hook yourself; -;;; term-mode will take care of it. The following example, from shell.el, -;;; is typical: -;;; -;;; (defvar shell-mode-map '()) -;;; (cond ((not shell-mode-map) -;;; (setq shell-mode-map (copy-keymap term-mode-map)) -;;; (define-key shell-mode-map "\C-c\C-f" 'shell-forward-command) -;;; (define-key shell-mode-map "\C-c\C-b" 'shell-backward-command) -;;; (define-key shell-mode-map "\t" 'term-dynamic-complete) -;;; (define-key shell-mode-map "\M-?" -;;; 'term-dynamic-list-filename-completions))) -;;; -;;; (defun shell-mode () -;;; (interactive) -;;; (term-mode) -;;; (setq term-prompt-regexp shell-prompt-pattern) -;;; (setq major-mode 'shell-mode) -;;; (setq mode-name "Shell") -;;; (use-local-map shell-mode-map) -;;; (make-local-variable 'shell-directory-stack) -;;; (setq shell-directory-stack nil) -;;; (add-hook 'term-input-filter-functions 'shell-directory-tracker) -;;; (run-hooks 'shell-mode-hook)) -;;; -;;; -;;; Note that make-term is different from make-shell in that it -;;; doesn't have a default program argument. If you give make-shell -;;; a program name of NIL, it cleverly chooses one of explicit-shell-name, -;;; $ESHELL, $SHELL, or /bin/sh. If you give make-term a program argument -;;; of NIL, it barfs. Adjust your code accordingly... -;;; -;;; Completion for term-mode users -;;; -;;; For modes that use term-mode, term-dynamic-complete-functions is the -;;; hook to add completion functions to. Functions on this list should return -;;; non-nil if completion occurs (i.e., further completion should not occur). -;;; You could use term-dynamic-simple-complete to do the bulk of the -;;; completion job. - -(provide 'term) - -;;; term.el ends here
--- a/lisp/eterm/tgud.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1264 +0,0 @@ -;; Things to look at: -; (gud-call "") in gud-send-input -; (defvar gud-last-last-frame nil) -; term-prompt-regexp - -;;; tgud.el --- Grand Unified Debugger mode for gdb, sdb, dbx, or xdb -;;; under Emacs - -;; Author: Eric S. Raymond <esr@snark.thyrsus.com> -;; Maintainer: FSF -;; Version: 1.3 -;; Keywords: unix, tools - -;; Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc. - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: - -;; The ancestral gdb.el was by W. Schelter <wfs@rascal.ics.utexas.edu> -;; It was later rewritten by rms. Some ideas were due to Masanobu. -;; Grand Unification (sdb/dbx support) by Eric S. Raymond <esr@thyrsus.com> -;; The overloading code was then rewritten by Barry Warsaw <bwarsaw@cen.com>, -;; who also hacked the mode to use comint.el. Shane Hartman <shane@spr.com> -;; added support for xdb (HPUX debugger). Rick Sladkey <jrs@world.std.com> -;; wrote the GDB command completion code. Dave Love <d.love@dl.ac.uk> -;; added the IRIX kluge and re-implemented the Mips-ish variant. -;; Then hacked by Per Bothner <bothner@cygnus.com> to use term.el. - -;;; Code: - -(require 'term) -(require 'etags) - -;; ====================================================================== -;; TGUD commands must be visible in C buffers visited by TGUD - -(defvar tgud-key-prefix "\C-x\C-a" - "Prefix of all TGUD commands valid in C buffers.") - -(global-set-key (concat tgud-key-prefix "\C-l") 'tgud-refresh) -(define-key ctl-x-map " " 'tgud-break) ;; backward compatibility hack - -;; ====================================================================== -;; the overloading mechanism - -(defun tgud-overload-functions (tgud-overload-alist) - "Overload functions defined in TGUD-OVERLOAD-ALIST. -This association list has elements of the form - (ORIGINAL-FUNCTION-NAME OVERLOAD-FUNCTION)" - (mapcar - (function (lambda (p) (fset (car p) (symbol-function (cdr p))))) - tgud-overload-alist)) - -(defun tgud-massage-args (file args) - (error "TGUD not properly entered")) - -(defun tgud-marker-filter (str) - (error "TGUD not properly entered")) - -(defun tgud-find-file (f) - (error "TGUD not properly entered")) - -;; ====================================================================== -;; command definition - -;; This macro is used below to define some basic debugger interface commands. -;; Of course you may use `tgud-def' with any other debugger command, including -;; user defined ones. - -;; A macro call like (tgud-def FUNC NAME KEY DOC) expands to a form -;; which defines FUNC to send the command NAME to the debugger, gives -;; it the docstring DOC, and binds that function to KEY in the TGUD -;; major mode. The function is also bound in the global keymap with the -;; TGUD prefix. - -(defmacro tgud-def (func cmd key &optional doc) - "Define FUNC to be a command sending STR and bound to KEY, with -optional doc string DOC. Certain %-escapes in the string arguments -are interpreted specially if present. These are: - - %f name (without directory) of current source file. - %d directory of current source file. - %l number of current source line - %e text of the C lvalue or function-call expression surrounding point. - %a text of the hexadecimal address surrounding point - %p prefix argument to the command (if any) as a number - - The `current' source file is the file of the current buffer (if -we're in a C file) or the source file current at the last break or -step (if we're in the TGUD buffer). - The `current' line is that of the current buffer (if we're in a -source file) or the source line number at the last break or step (if -we're in the TGUD buffer)." - (list 'progn - (list 'defun func '(arg) - (or doc "") - '(interactive "p") - (list 'tgud-call cmd 'arg)) - (if key - (list 'define-key - '(current-local-map) - (concat "\C-c" key) - (list 'quote func))) - (if key - (list 'global-set-key - (list 'concat 'tgud-key-prefix key) - (list 'quote func))))) - -;; Used by tgud-refresh, which should cause tgud-display-frame to redisplay -;; the last frame, even if it's been called before and term-pending-frame has -;; been set to nil. -(defvar tgud-last-last-frame nil) - -;; All debugger-specific information is collected here. -;; Here's how it works, in case you ever need to add a debugger to the mode. -;; -;; Each entry must define the following at startup: -;; -;;<name> -;; term-prompt-regexp -;; tgud-<name>-massage-args -;; tgud-<name>-marker-filter -;; tgud-<name>-find-file -;; -;; The job of the massage-args method is to modify the given list of -;; debugger arguments before running the debugger. -;; -;; The job of the marker-filter method is to detect file/line markers in -;; strings and set the global term-pending-frame to indicate what display -;; action (if any) should be triggered by the marker. Note that only -;; whatever the method *returns* is displayed in the buffer; thus, you -;; can filter the debugger's output, interpreting some and passing on -;; the rest. -;; -;; The job of the find-file method is to visit and return the buffer indicated -;; by the car of tgud-tag-frame. This may be a file name, a tag name, or -;; something else. - -;; ====================================================================== -;; gdb functions - -;;; History of argument lists passed to gdb. -(defvar tgud-gdb-history nil) - -(defun tgud-gdb-massage-args (file args) - (cons "-fullname" (cons file args))) - -;; Don't need to do anything, since term-mode does it for us. -;; (This is so that you can run 'gdb -fullname' from a shell buffer.) -(defun tgud-gdb-marker-filter (string) - string) - -(defun tgud-gdb-find-file (f) - (find-file-noselect f)) - -(defvar gdb-minibuffer-local-map nil - "Keymap for minibuffer prompting of gdb startup command.") -(if gdb-minibuffer-local-map - () - (setq gdb-minibuffer-local-map (copy-keymap minibuffer-local-map)) - (define-key - gdb-minibuffer-local-map "\C-i" 'term-dynamic-complete-filename)) - -;;;###autoload -(defun tgdb (command-line) - "Run gdb on program FILE in buffer *tgud-FILE*. -The directory containing FILE becomes the initial working directory -and source-file directory for your debugger." - (interactive - (list (read-from-minibuffer "Run gdb (like this): " - (if (consp tgud-gdb-history) - (car tgud-gdb-history) - "gdb ") - gdb-minibuffer-local-map nil - '(tgud-gdb-history . 1)))) - (tgud-overload-functions '((tgud-massage-args . tgud-gdb-massage-args) - (tgud-marker-filter . tgud-gdb-marker-filter) - (tgud-find-file . tgud-gdb-find-file) - )) - - (tgud-common-init command-line) - - (tgud-def tgud-break "break %f:%l" "\C-b" "Set breakpoint at current line.") - (tgud-def tgud-tbreak "tbreak %f:%l" "\C-t" "Set breakpoint at current line.") - (tgud-def tgud-remove "clear %l" "\C-d" "Remove breakpoint at current line") - (tgud-def tgud-step "step %p" "\C-s" "Step one source line with display.") - (tgud-def tgud-stepi "stepi %p" "\C-i" "Step one instruction with display.") - (tgud-def tgud-next "next %p" "\C-n" "Step one line (skip functions).") - (tgud-def tgud-cont "cont" "\C-r" "Continue with display.") - (tgud-def tgud-finish "finish" "\C-f" "Finish executing current function.") - (tgud-def tgud-up "up %p" "<" "Up N stack frames (numeric arg).") - (tgud-def tgud-down "down %p" ">" "Down N stack frames (numeric arg).") - (tgud-def tgud-print "print %e" "\C-p" "Evaluate C expression at point.") - - (local-set-key "\C-i" 'tgud-gdb-complete-command) - (setq term-prompt-regexp "^(.*gdb[+]?) *") - (setq paragraph-start term-prompt-regexp) - (run-hooks 'gdb-mode-hook) - ) - -;; One of the nice features of GDB is its impressive support for -;; context-sensitive command completion. We preserve that feature -;; in the TGUD buffer by using a GDB command designed just for Emacs. - -;; The completion process filter indicates when it is finished. -(defvar tgud-gdb-complete-in-progress) - -;; Since output may arrive in fragments we accumulate partials strings here. -(defvar tgud-gdb-complete-string) - -;; We need to know how much of the completion to chop off. -(defvar tgud-gdb-complete-break) - -;; The completion list is constructed by the process filter. -(defvar tgud-gdb-complete-list) - -(defvar tgud-term-buffer nil) - -(defun tgud-gdb-complete-command () - "Perform completion on the GDB command preceding point. -This is implemented using the GDB `complete' command which isn't -available with older versions of GDB." - (interactive) - (let* ((end (point)) - (command (save-excursion - (beginning-of-line) - (and (looking-at term-prompt-regexp) - (goto-char (match-end 0))) - (buffer-substring (point) end))) - command-word) - ;; Find the word break. This match will always succeed. - (string-match "\\(\\`\\| \\)\\([^ ]*\\)\\'" command) - (setq tgud-gdb-complete-break (match-beginning 2) - command-word (substring command tgud-gdb-complete-break)) - (unwind-protect - (progn - ;; Temporarily install our filter function. - (tgud-overload-functions - '((tgud-marker-filter . tgud-gdb-complete-filter))) - ;; Issue the command to GDB. - (tgud-basic-call (concat "complete " command)) - (setq tgud-gdb-complete-in-progress t - tgud-gdb-complete-string nil - tgud-gdb-complete-list nil) - ;; Slurp the output. - (while tgud-gdb-complete-in-progress - (accept-process-output (get-buffer-process tgud-term-buffer)))) - ;; Restore the old filter function. - (tgud-overload-functions '((tgud-marker-filter . tgud-gdb-marker-filter)))) - ;; Protect against old versions of GDB. - (and tgud-gdb-complete-list - (string-match "^Undefined command: \"complete\"" - (car tgud-gdb-complete-list)) - (error "This version of GDB doesn't support the `complete' command.")) - ;; Sort the list like readline. - (setq tgud-gdb-complete-list - (sort tgud-gdb-complete-list (function string-lessp))) - ;; Remove duplicates. - (let ((first tgud-gdb-complete-list) - (second (cdr tgud-gdb-complete-list))) - (while second - (if (string-equal (car first) (car second)) - (setcdr first (setq second (cdr second))) - (setq first second - second (cdr second))))) - ;; Let term handle the rest. - (term-dynamic-simple-complete command-word tgud-gdb-complete-list))) - -;; The completion process filter is installed temporarily to slurp the -;; output of GDB up to the next prompt and build the completion list. -(defun tgud-gdb-complete-filter (string) - (setq string (concat tgud-gdb-complete-string string)) - (while (string-match "\r?\n" string) - (setq tgud-gdb-complete-list - (cons (substring string tgud-gdb-complete-break (match-beginning 0)) - tgud-gdb-complete-list)) - (setq string (substring string (match-end 0)))) - (if (string-match term-prompt-regexp string) - (progn - (setq tgud-gdb-complete-in-progress nil) - string) - (progn - (setq tgud-gdb-complete-string string) - ""))) - - -;; ====================================================================== -;; sdb functions - -;;; History of argument lists passed to sdb. -(defvar tgud-sdb-history nil) - -(defvar tgud-sdb-needs-tags (not (file-exists-p "/var")) - "If nil, we're on a System V Release 4 and don't need the tags hack.") - -(defvar tgud-sdb-lastfile nil) - -(defun tgud-sdb-massage-args (file args) - (cons file args)) - -(defun tgud-sdb-marker-filter (string) - (cond - ;; System V Release 3.2 uses this format - ((string-match "\\(^0x\\w* in \\|^\\|\n\\)\\([^:\n]*\\):\\([0-9]*\\):.*\n" - string) - (setq term-pending-frame - (cons - (substring string (match-beginning 2) (match-end 2)) - (string-to-int - (substring string (match-beginning 3) (match-end 3)))))) - ;; System V Release 4.0 - ((string-match "^\\(BREAKPOINT\\|STEPPED\\) process [0-9]+ function [^ ]+ in \\(.+\\)\n" - string) - (setq tgud-sdb-lastfile - (substring string (match-beginning 2) (match-end 2)))) - ((and tgud-sdb-lastfile (string-match "^\\([0-9]+\\):" string)) - (setq term-pending-frame - (cons - tgud-sdb-lastfile - (string-to-int - (substring string (match-beginning 1) (match-end 1)))))) - (t - (setq tgud-sdb-lastfile nil))) - string) - -(defun tgud-sdb-find-file (f) - (if tgud-sdb-needs-tags - (find-tag-noselect f) - (find-file-noselect f))) - -;;;###autoload -(defun tsdb (command-line) - "Run sdb on program FILE in buffer *tgud-FILE*. -The directory containing FILE becomes the initial working directory -and source-file directory for your debugger." - (interactive - (list (read-from-minibuffer "Run sdb (like this): " - (if (consp tgud-sdb-history) - (car tgud-sdb-history) - "sdb ") - nil nil - '(tgud-sdb-history . 1)))) - (if (and tgud-sdb-needs-tags - (not (and (boundp 'tags-file-name) - (stringp tags-file-name) - (file-exists-p tags-file-name)))) - (error "The sdb support requires a valid tags table to work.")) - (tgud-overload-functions '((tgud-massage-args . tgud-sdb-massage-args) - (tgud-marker-filter . tgud-sdb-marker-filter) - (tgud-find-file . tgud-sdb-find-file) - )) - - (tgud-common-init command-line) - - (tgud-def tgud-break "%l b" "\C-b" "Set breakpoint at current line.") - (tgud-def tgud-tbreak "%l c" "\C-t" "Set temporary breakpoint at current line.") - (tgud-def tgud-remove "%l d" "\C-d" "Remove breakpoint at current line") - (tgud-def tgud-step "s %p" "\C-s" "Step one source line with display.") - (tgud-def tgud-stepi "i %p" "\C-i" "Step one instruction with display.") - (tgud-def tgud-next "S %p" "\C-n" "Step one line (skip functions).") - (tgud-def tgud-cont "c" "\C-r" "Continue with display.") - (tgud-def tgud-print "%e/" "\C-p" "Evaluate C expression at point.") - - (setq term-prompt-regexp "\\(^\\|\n\\)\\*") - (setq paragraph-start term-prompt-regexp) - (run-hooks 'sdb-mode-hook) - ) - -;; ====================================================================== -;; dbx functions - -;;; History of argument lists passed to dbx. -(defvar tgud-dbx-history nil) - -(defun tgud-dbx-massage-args (file args) - (cons file args)) - -(defun tgud-dbx-marker-filter (string) - (if (or (string-match - "stopped in .* at line \\([0-9]*\\) in file \"\\([^\"]*\\)\"" - string) - (string-match - "signal .* in .* at line \\([0-9]*\\) in file \"\\([^\"]*\\)\"" - string)) - (setq term-pending-frame - (cons - (substring string (match-beginning 2) (match-end 2)) - (string-to-int - (substring string (match-beginning 1) (match-end 1)))))) - string) - -;; Functions for Mips-style dbx. Given the option `-emacs', documented in -;; OSF1, not necessarily elsewhere, it produces markers similar to gdb's. -(defvar tgud-mips-p - (or (string-match "^mips-[^-]*-ultrix" system-configuration) - ;; We haven't tested tgud on this system: - (string-match "^mips-[^-]*-riscos" system-configuration) - ;; It's documented on OSF/1.3 - (string-match "^mips-[^-]*-osf1" system-configuration) - (string-match "^alpha-[^-]*-osf" system-configuration)) - "Non-nil to assume the MIPS/OSF dbx conventions (argument `-emacs').") - -(defun tgud-mipsdbx-massage-args (file args) - (cons "-emacs" (cons file args))) - -;; This is just like the gdb one except for the regexps since we need to cope -;; with an optional breakpoint number in [] before the ^Z^Z -(defun tgud-mipsdbx-marker-filter (string) - (save-match-data - (setq tgud-marker-acc (concat tgud-marker-acc string)) - (let ((output "")) - - ;; Process all the complete markers in this chunk. - (while (string-match - ;; This is like th gdb marker but with an optional - ;; leading break point number like `[1] ' - "[][ 0-9]*\032\032\\([^:\n]*\\):\\([0-9]*\\):.*\n" - tgud-marker-acc) - (setq - - ;; Extract the frame position from the marker. - term-pending-frame - (cons (substring tgud-marker-acc (match-beginning 1) (match-end 1)) - (string-to-int (substring tgud-marker-acc - (match-beginning 2) - (match-end 2)))) - - ;; Append any text before the marker to the output we're going - ;; to return - we don't include the marker in this text. - output (concat output - (substring tgud-marker-acc 0 (match-beginning 0))) - - ;; Set the accumulator to the remaining text. - tgud-marker-acc (substring tgud-marker-acc (match-end 0)))) - - ;; Does the remaining text look like it might end with the - ;; beginning of another marker? If it does, then keep it in - ;; tgud-marker-acc until we receive the rest of it. Since we - ;; know the full marker regexp above failed, it's pretty simple to - ;; test for marker starts. - (if (string-match "[][ 0-9]*\032.*\\'" tgud-marker-acc) - (progn - ;; Everything before the potential marker start can be output. - (setq output (concat output (substring tgud-marker-acc - 0 (match-beginning 0)))) - - ;; Everything after, we save, to combine with later input. - (setq tgud-marker-acc - (substring tgud-marker-acc (match-beginning 0)))) - - (setq output (concat output tgud-marker-acc) - tgud-marker-acc "")) - - output))) - -;; The dbx in IRIX is a pain. It doesn't print the file name when -;; stopping at a breakpoint (but you do get it from the `up' and -;; `down' commands...). The only way to extract the information seems -;; to be with a `file' command, although the current line number is -;; available in $curline. Thus we have to look for output which -;; appears to indicate a breakpoint. Then we prod the dbx sub-process -;; to output the information we want with a combination of the -;; `printf' and `file' commands as a pseudo marker which we can -;; recognise next time through the marker-filter. This would be like -;; the gdb marker but you can't get the file name without a newline... -;; Note that tgud-remove won't work since Irix dbx expects a breakpoint -;; number rather than a line number etc. Maybe this could be made to -;; work by listing all the breakpoints and picking the one(s) with the -;; correct line number, but life's too short. -;; d.love@dl.ac.uk (Dave Love) can be blamed for this - -(defvar tgud-irix-p (string-match "^mips-[^-]*-irix" system-configuration) - "Non-nil to assume the interface appropriate for IRIX dbx. -This works in IRIX 4 and probably IRIX 5.") -;; (It's been tested in IRIX 4 and the output from dbx on IRIX 5 looks -;; the same.) - -;; this filter is influenced by the xdb one rather than the gdb one - -(defun tgud-irixdbx-marker-filter (string) - (save-match-data - (let (result (case-fold-search nil)) - (if (or (string-match term-prompt-regexp string) - (string-match ".*\012" string)) - (setq result (concat tgud-marker-acc string) - tgud-marker-acc "") - (setq tgud-marker-acc (concat tgud-marker-acc string))) - (if result - (cond - ;; look for breakpoint or signal indication e.g.: - ;; [2] Process 1267 (pplot) stopped at [params:338 ,0x400ec0] - ;; Process 1281 (pplot) stopped at [params:339 ,0x400ec8] - ;; Process 1270 (pplot) Floating point exception [._read._read:16 ,0x452188] - ((string-match - "^\\(\\[[0-9]+] \\)?Process +[0-9]+ ([^)]*) [^[]+\\[[^]\n]*]\n" - result) - ;; prod dbx into printing out the line number and file - ;; name in a form we can grok as below - (process-send-string (get-buffer-process tgud-term-buffer) - "printf \"\032\032%1d:\",$curline;file\n")) - ;; look for result of, say, "up" e.g.: - ;; .pplot.pplot(0x800) ["src/pplot.f":261, 0x400c7c] - ;; (this will also catch one of the lines printed by "where") - ((string-match - "^[^ ][^[]*\\[\"\\([^\"]+\\)\":\\([0-9]+\\), [^]]+]\n" - result) - (let ((file (substring result (match-beginning 1) - (match-end 1)))) - (if (file-exists-p file) - (setq term-pending-frame - (cons - (substring - result (match-beginning 1) (match-end 1)) - (string-to-int - (substring - result (match-beginning 2) (match-end 2))))))) - result) - ((string-match ; kluged-up marker as above - "\032\032\\([0-9]*\\):\\(.*\\)\n" result) - (let ((file (substring result (match-beginning 2) (match-end 2)))) - (if (file-exists-p file) - (setq term-pending-frame - (cons - file - (string-to-int - (substring - result (match-beginning 1) (match-end 1))))))) - (setq result (substring result 0 (match-beginning 0)))))) - (or result "")))) - -(defun tgud-dbx-find-file (f) - (find-file-noselect f)) - -;;;###autoload -(defun tdbx (command-line) - "Run dbx on program FILE in buffer *tgud-FILE*. -The directory containing FILE becomes the initial working directory -and source-file directory for your debugger." - (interactive - (list (read-from-minibuffer "Run dbx (like this): " - (if (consp tgud-dbx-history) - (car tgud-dbx-history) - "dbx ") - nil nil - '(tgud-dbx-history . 1)))) - - (tgud-overload-functions - (cond - (tgud-mips-p - '((tgud-massage-args . tgud-mipsdbx-massage-args) - (tgud-marker-filter . tgud-mipsdbx-marker-filter) - (tgud-find-file . tgud-dbx-find-file))) - (tgud-irix-p - '((tgud-massage-args . tgud-dbx-massage-args) - (tgud-marker-filter . tgud-irixdbx-marker-filter) - (tgud-find-file . tgud-dbx-find-file))) - (t - '((tgud-massage-args . tgud-dbx-massage-args) - (tgud-marker-filter . tgud-dbx-marker-filter) - (tgud-find-file . tgud-dbx-find-file))))) - - (tgud-common-init command-line) - - (cond - (tgud-mips-p - (tgud-def tgud-break "stop at \"%f\":%l" - "\C-b" "Set breakpoint at current line.") - (tgud-def tgud-finish "return" "\C-f" "Finish executing current function.")) - (tgud-irix-p - (tgud-def tgud-break "stop at \"%d%f\":%l" - "\C-b" "Set breakpoint at current line.") - (tgud-def tgud-finish "return" "\C-f" "Finish executing current function.") - ;; Make dbx give out the source location info that we need. - (process-send-string (get-buffer-process tgud-term-buffer) - "printf \"\032\032%1d:\",$curline;file\n")) - (t - (tgud-def tgud-break "file \"%d%f\"\nstop at %l" - "\C-b" "Set breakpoint at current line."))) - - (tgud-def tgud-remove "clear %l" "\C-d" "Remove breakpoint at current line") - (tgud-def tgud-step "step %p" "\C-s" "Step one line with display.") - (tgud-def tgud-stepi "stepi %p" "\C-i" "Step one instruction with display.") - (tgud-def tgud-next "next %p" "\C-n" "Step one line (skip functions).") - (tgud-def tgud-cont "cont" "\C-r" "Continue with display.") - (tgud-def tgud-up "up %p" "<" "Up (numeric arg) stack frames.") - (tgud-def tgud-down "down %p" ">" "Down (numeric arg) stack frames.") - (tgud-def tgud-print "print %e" "\C-p" "Evaluate C expression at point.") - - (setq term-prompt-regexp "^[^)\n]*dbx) *") - (setq paragraph-start term-prompt-regexp) - (run-hooks 'dbx-mode-hook) - ) - -;;---ok -;; ====================================================================== -;; xdb (HP PARISC debugger) functions - -;;; History of argument lists passed to xdb. -(defvar tgud-xdb-history nil) - -(defvar tgud-xdb-directories nil - "*A list of directories that xdb should search for source code. -If nil, only source files in the program directory -will be known to xdb. - -The file names should be absolute, or relative to the directory -containing the executable being debugged.") - -(defun tgud-xdb-massage-args (file args) - (nconc (let ((directories tgud-xdb-directories) - (result nil)) - (while directories - (setq result (cons (car directories) (cons "-d" result))) - (setq directories (cdr directories))) - (nreverse (cons file result))) - args)) - -(defun tgud-xdb-file-name (f) - "Transform a relative pathname to a full pathname in xdb mode" - (let ((result nil)) - (if (file-exists-p f) - (setq result (expand-file-name f)) - (let ((directories tgud-xdb-directories)) - (while directories - (let ((path (concat (car directories) "/" f))) - (if (file-exists-p path) - (setq result (expand-file-name path) - directories nil))) - (setq directories (cdr directories))))) - result)) - -;; xdb does not print the lines all at once, so we have to accumulate them -(defun tgud-xdb-marker-filter (string) - (let (result) - (if (or (string-match term-prompt-regexp string) - (string-match ".*\012" string)) - (setq result (concat tgud-marker-acc string) - tgud-marker-acc "") - (setq tgud-marker-acc (concat tgud-marker-acc string))) - (if result - (if (or (string-match "\\([^\n \t:]+\\): [^:]+: \\([0-9]+\\):" result) - (string-match "[^: \t]+:[ \t]+\\([^:]+\\): [^:]+: \\([0-9]+\\):" - result)) - (let ((line (string-to-int - (substring result (match-beginning 2) (match-end 2)))) - (file (tgud-xdb-file-name - (substring result (match-beginning 1) (match-end 1))))) - (if file - (setq term-pending-frame (cons file line)))))) - (or result ""))) - -(defun tgud-xdb-find-file (f) - (let ((realf (tgud-xdb-file-name f))) - (if realf (find-file-noselect realf)))) - -;;;###autoload -(defun txdb (command-line) - "Run xdb on program FILE in buffer *tgud-FILE*. -The directory containing FILE becomes the initial working directory -and source-file directory for your debugger. - -You can set the variable 'tgud-xdb-directories' to a list of program source -directories if your program contains sources from more than one directory." - (interactive - (list (read-from-minibuffer "Run xdb (like this): " - (if (consp tgud-xdb-history) - (car tgud-xdb-history) - "xdb ") - nil nil - '(tgud-xdb-history . 1)))) - (tgud-overload-functions '((tgud-massage-args . tgud-xdb-massage-args) - (tgud-marker-filter . tgud-xdb-marker-filter) - (tgud-find-file . tgud-xdb-find-file))) - - (tgud-common-init command-line) - - (tgud-def tgud-break "b %f:%l" "\C-b" "Set breakpoint at current line.") - (tgud-def tgud-tbreak "b %f:%l\\t" "\C-t" - "Set temporary breakpoint at current line.") - (tgud-def tgud-remove "db" "\C-d" "Remove breakpoint at current line") - (tgud-def tgud-step "s %p" "\C-s" "Step one line with display.") - (tgud-def tgud-next "S %p" "\C-n" "Step one line (skip functions).") - (tgud-def tgud-cont "c" "\C-r" "Continue with display.") - (tgud-def tgud-up "up %p" "<" "Up (numeric arg) stack frames.") - (tgud-def tgud-down "down %p" ">" "Down (numeric arg) stack frames.") - (tgud-def tgud-finish "bu\\t" "\C-f" "Finish executing current function.") - (tgud-def tgud-print "p %e" "\C-p" "Evaluate C expression at point.") - - (setq term-prompt-regexp "^>") - (setq paragraph-start term-prompt-regexp) - (run-hooks 'xdb-mode-hook)) - -;; ====================================================================== -;; perldb functions - -;;; History of argument lists passed to perldb. -(defvar tgud-perldb-history nil) - -(defun tgud-perldb-massage-args (file args) - (cons "-d" (cons file (cons "-emacs" args)))) - -;; There's no guarantee that Emacs will hand the filter the entire -;; marker at once; it could be broken up across several strings. We -;; might even receive a big chunk with several markers in it. If we -;; receive a chunk of text which looks like it might contain the -;; beginning of a marker, we save it here between calls to the -;; filter. -(defvar tgud-perldb-marker-acc "") - -(defun tgud-perldb-marker-filter (string) - (save-match-data - (setq tgud-marker-acc (concat tgud-marker-acc string)) - (let ((output "")) - - ;; Process all the complete markers in this chunk. - (while (string-match "\032\032\\([^:\n]*\\):\\([0-9]*\\):.*\n" - tgud-marker-acc) - (setq - - ;; Extract the frame position from the marker. - term-pending-frame - (cons (substring tgud-marker-acc (match-beginning 1) (match-end 1)) - (string-to-int (substring tgud-marker-acc - (match-beginning 2) - (match-end 2)))) - - ;; Append any text before the marker to the output we're going - ;; to return - we don't include the marker in this text. - output (concat output - (substring tgud-marker-acc 0 (match-beginning 0))) - - ;; Set the accumulator to the remaining text. - tgud-marker-acc (substring tgud-marker-acc (match-end 0)))) - - ;; Does the remaining text look like it might end with the - ;; beginning of another marker? If it does, then keep it in - ;; tgud-marker-acc until we receive the rest of it. Since we - ;; know the full marker regexp above failed, it's pretty simple to - ;; test for marker starts. - (if (string-match "\032.*\\'" tgud-marker-acc) - (progn - ;; Everything before the potential marker start can be output. - (setq output (concat output (substring tgud-marker-acc - 0 (match-beginning 0)))) - - ;; Everything after, we save, to combine with later input. - (setq tgud-marker-acc - (substring tgud-marker-acc (match-beginning 0)))) - - (setq output (concat output tgud-marker-acc) - tgud-marker-acc "")) - - output))) - -(defun tgud-perldb-find-file (f) - (find-file-noselect f)) - -;;;###autoload -(defun tperldb (command-line) - "Run perldb on program FILE in buffer *tgud-FILE*. -The directory containing FILE becomes the initial working directory -and source-file directory for your debugger." - (interactive - (list (read-from-minibuffer "Run perldb (like this): " - (if (consp tgud-perldb-history) - (car tgud-perldb-history) - "perl ") - nil nil - '(tgud-perldb-history . 1)))) - (tgud-overload-functions '((tgud-massage-args . tgud-perldb-massage-args) - (tgud-marker-filter . tgud-perldb-marker-filter) - (tgud-find-file . tgud-perldb-find-file) - )) - - (tgud-common-init command-line) - - (tgud-def tgud-break "b %l" "\C-b" "Set breakpoint at current line.") - (tgud-def tgud-remove "d %l" "\C-d" "Remove breakpoint at current line") - (tgud-def tgud-step "s" "\C-s" "Step one source line with display.") - (tgud-def tgud-next "n" "\C-n" "Step one line (skip functions).") - (tgud-def tgud-cont "c" "\C-r" "Continue with display.") -; (tgud-def tgud-finish "finish" "\C-f" "Finish executing current function.") -; (tgud-def tgud-up "up %p" "<" "Up N stack frames (numeric arg).") -; (tgud-def tgud-down "down %p" ">" "Down N stack frames (numeric arg).") - (tgud-def tgud-print "%e" "\C-p" "Evaluate perl expression at point.") - - (setq term-prompt-regexp "^ DB<[0-9]+> ") - (setq paragraph-start term-prompt-regexp) - (run-hooks 'perldb-mode-hook) - ) - -;; -;; End of debugger-specific information -;; - - -;;; When we send a command to the debugger via tgud-call, it's annoying -;;; to see the command and the new prompt inserted into the debugger's -;;; buffer; we have other ways of knowing the command has completed. -;;; -;;; If the buffer looks like this: -;;; -------------------- -;;; (gdb) set args foo bar -;;; (gdb) -!- -;;; -------------------- -;;; (the -!- marks the location of point), and we type `C-x SPC' in a -;;; source file to set a breakpoint, we want the buffer to end up like -;;; this: -;;; -------------------- -;;; (gdb) set args foo bar -;;; Breakpoint 1 at 0x92: file make-docfile.c, line 49. -;;; (gdb) -!- -;;; -------------------- -;;; Essentially, the old prompt is deleted, and the command's output -;;; and the new prompt take its place. -;;; -;;; Not echoing the command is easy enough; you send it directly using -;;; process-send-string, and it never enters the buffer. However, -;;; getting rid of the old prompt is trickier; you don't want to do it -;;; when you send the command, since that will result in an annoying -;;; flicker as the prompt is deleted, redisplay occurs while Emacs -;;; waits for a response from the debugger, and the new prompt is -;;; inserted. Instead, we'll wait until we actually get some output -;;; from the subprocess before we delete the prompt. If the command -;;; produced no output other than a new prompt, that prompt will most -;;; likely be in the first chunk of output received, so we will delete -;;; the prompt and then replace it with an identical one. If the -;;; command produces output, the prompt is moving anyway, so the -;;; flicker won't be annoying. -;;; -;;; So - when we want to delete the prompt upon receipt of the next -;;; chunk of debugger output, we position term-pending-delete-marker at -;;; the start of the prompt; the process filter will notice this, and -;;; delete all text between it and the process output marker. If -;;; term-pending-delete-marker points nowhere, we leave the current -;;; prompt alone. -(defvar term-pending-delete-marker nil) - - -(defun tgud-mode () - "Major mode for interacting with an inferior debugger process. - - You start it up with one of the commands M-x gdb, M-x sdb, M-x dbx, -or M-x xdb. Each entry point finishes by executing a hook; `gdb-mode-hook', -`sdb-mode-hook', `dbx-mode-hook' or `xdb-mode-hook' respectively. - -After startup, the following commands are available in both the TGUD -interaction buffer and any source buffer TGUD visits due to a breakpoint stop -or step operation: - -\\[tgud-break] sets a breakpoint at the current file and line. In the -TGUD buffer, the current file and line are those of the last breakpoint or -step. In a source buffer, they are the buffer's file and current line. - -\\[tgud-remove] removes breakpoints on the current file and line. - -\\[tgud-refresh] displays in the source window the last line referred to -in the tgud buffer. - -\\[tgud-step], \\[tgud-next], and \\[tgud-stepi] do a step-one-line, -step-one-line (not entering function calls), and step-one-instruction -and then update the source window with the current file and position. -\\[tgud-cont] continues execution. - -\\[tgud-print] tries to find the largest C lvalue or function-call expression -around point, and sends it to the debugger for value display. - -The above commands are common to all supported debuggers except xdb which -does not support stepping instructions. - -Under gdb, sdb and xdb, \\[tgud-tbreak] behaves exactly like \\[tgud-break], -except that the breakpoint is temporary; that is, it is removed when -execution stops on it. - -Under gdb, dbx, and xdb, \\[tgud-up] pops up through an enclosing stack -frame. \\[tgud-down] drops back down through one. - -If you are using gdb or xdb, \\[tgud-finish] runs execution to the return from -the current function and stops. - -All the keystrokes above are accessible in the TGUD buffer -with the prefix C-c, and in all buffers through the prefix C-x C-a. - -All pre-defined functions for which the concept make sense repeat -themselves the appropriate number of times if you give a prefix -argument. - -You may use the `tgud-def' macro in the initialization hook to define other -commands. - -Other commands for interacting with the debugger process are inherited from -term mode, which see." - (interactive) - (term-mode) - (setq major-mode 'tgud-mode) - (setq mode-name "Debugger") - (setq mode-line-process '(":%s")) - (use-local-map (copy-keymap term-mode-map)) - (define-key (current-local-map) "\C-m" 'tgud-send-input) - (define-key (current-local-map) "\C-c\C-l" 'tgud-refresh) - (make-local-variable 'term-prompt-regexp) - (make-local-variable 'paragraph-start) - (run-hooks 'tgud-mode-hook) -) - -(defun tgud-send-input () - (interactive) - (let ((proc (get-buffer-process (current-buffer)))) - (if (not proc) (error "Current buffer has no process") - ;; If input line is empty, use tgud-call to get prompt deleted. - (if (and (= (point) (process-mark proc)) (= (point) (point-max))) - (tgud-call "") - (term-send-input))))) - -;; Chop STRING into words separated by SPC or TAB and return a list of them. -(defun tgud-chop-words (string) - (let ((i 0) (beg 0) - (len (length string)) - (words nil)) - (while (< i len) - (if (memq (aref string i) '(?\t ? )) - (progn - (setq words (cons (substring string beg i) words) - beg (1+ i)) - (while (and (< beg len) (memq (aref string beg) '(?\t ? ))) - (setq beg (1+ beg))) - (setq i (1+ beg))) - (setq i (1+ i)))) - (if (< beg len) - (setq words (cons (substring string beg) words))) - (nreverse words))) - -;; Perform initializations common to all debuggers. -(defun tgud-common-init (command-line) - (let* ((words (tgud-chop-words command-line)) - (program (car words)) - (file-word (let ((w (cdr words))) - (while (and w (= ?- (aref (car w) 0))) - (setq w (cdr w))) - (car w))) - (args (delq file-word (cdr words))) - (file (and file-word - (expand-file-name (substitute-in-file-name file-word)))) - (filepart (and file-word (file-name-nondirectory file)))) - (switch-to-buffer (concat "*tgud-" filepart "*")) - (and file-word (setq default-directory (file-name-directory file))) - (or (bolp) (newline)) - (insert "Current directory is " default-directory "\n") - (apply 'make-term (concat "tgud-" filepart) program nil - (if file-word (tgud-massage-args file args)))) - (tgud-mode) - ;; Note the insertion about of the line giving the "Current directory" - ;; is not known about by the terminal emulator, so clear the - ;; current-row cache to avoid confusion. - (setq term-current-row nil) - (set-process-filter (get-buffer-process (current-buffer)) 'tgud-filter) - (set-process-sentinel (get-buffer-process (current-buffer)) 'tgud-sentinel) - (tgud-set-buffer) - ) - -(defun tgud-set-buffer () - (cond ((eq major-mode 'tgud-mode) - (setq tgud-term-buffer (current-buffer))))) - -;; These functions are responsible for inserting output from your debugger -;; into the buffer. The hard work is done by the method that is -;; the value of tgud-marker-filter. - -(defun tgud-filter (proc string) - ;; Here's where the actual buffer insertion is done - (set-buffer (process-buffer proc)) - (let ((inhibit-quit t)) ;; ??? - (term-emulate-terminal proc (tgud-marker-filter string)))) - -(defun tgud-sentinel (proc msg) - (cond ((null (buffer-name (process-buffer proc))) - ;; buffer killed - ;; Stop displaying an arrow in a source file. - (setq overlay-arrow-position nil) - (set-process-buffer proc nil)) - ((memq (process-status proc) '(signal exit)) - ;; Stop displaying an arrow in a source file. - (setq overlay-arrow-position nil) - ;; Fix the mode line. - (setq mode-line-process - (concat ":" - (symbol-name (process-status proc)))) - (let* ((obuf (current-buffer))) - ;; save-excursion isn't the right thing if - ;; process-buffer is current-buffer - (unwind-protect - (progn - ;; Write something in *compilation* and hack its mode line, - (set-buffer (process-buffer proc)) - ;; Force mode line redisplay soon - (set-buffer-modified-p (buffer-modified-p)) - (if (eobp) - (insert ?\n mode-name " " msg) - (save-excursion - (goto-char (point-max)) - (insert ?\n mode-name " " msg))) - ;; If buffer and mode line will show that the process - ;; is dead, we can delete it now. Otherwise it - ;; will stay around until M-x list-processes. - (delete-process proc)) - ;; Restore old buffer, but don't restore old point - ;; if obuf is the tgud buffer. - (set-buffer obuf)))))) - -(defun tgud-display-frame () - "Find and obey the last filename-and-line marker from the debugger. -Obeying it means displaying in another window the specified file and line." - (interactive) - (if term-pending-frame - (progn - (tgud-set-buffer) - (term-display-buffer-line (tgud-visit-file (car term-pending-frame)) - (cdr term-pending-frame)) - (setq term-pending-frame nil)))) - -;;; The tgud-call function must do the right thing whether its invoking -;;; keystroke is from the TGUD buffer itself (via major-mode binding) -;;; or a C buffer. In the former case, we want to supply data from -;;; term-pending-frame. Here's how we do it: - -(defun tgud-format-command (str arg) - (let ((insource (not (eq (current-buffer) tgud-term-buffer))) - (frame (or term-pending-frame tgud-last-last-frame)) - result) - (while (and str (string-match "\\([^%]*\\)%\\([adeflp]\\)" str)) - (let ((key (string-to-char (substring str (match-beginning 2)))) - subst) - (cond - ((eq key ?f) - (setq subst (file-name-nondirectory (if insource - (buffer-file-name) - (car frame))))) - ((eq key ?d) - (setq subst (file-name-directory (if insource - (buffer-file-name) - (car frame))))) - ((eq key ?l) - (setq subst (if insource - (save-excursion - (beginning-of-line) - (save-restriction (widen) - (1+ (count-lines 1 (point))))) - (cdr frame)))) - ((eq key ?e) - (setq subst (find-c-expr))) - ((eq key ?a) - (setq subst (tgud-read-address))) - ((eq key ?p) - (setq subst (if arg (int-to-string arg) "")))) - (setq result (concat result - (substring str (match-beginning 1) (match-end 1)) - subst))) - (setq str (substring str (match-end 2)))) - ;; There might be text left in STR when the loop ends. - (concat result str))) - -(defun tgud-read-address () - "Return a string containing the core-address found in the buffer at point." - (save-excursion - (let ((pt (point)) found begin) - (setq found (if (search-backward "0x" (- pt 7) t) (point))) - (cond - (found (forward-char 2) - (buffer-substring found - (progn (re-search-forward "[^0-9a-f]") - (forward-char -1) - (point)))) - (t (setq begin (progn (re-search-backward "[^0-9]") - (forward-char 1) - (point))) - (forward-char 1) - (re-search-forward "[^0-9]") - (forward-char -1) - (buffer-substring begin (point))))))) - -(defun tgud-call (fmt &optional arg) - (let ((msg (tgud-format-command fmt arg))) - (message "Command: %s" msg) - (sit-for 0) - (tgud-basic-call msg))) - -(defun tgud-basic-call (command) - "Invoke the debugger COMMAND displaying source in other window." - (interactive) - (tgud-set-buffer) - (let ((proc (get-buffer-process tgud-term-buffer))) - - ;; Arrange for the current prompt to get deleted. - (save-excursion - (set-buffer tgud-term-buffer) - (goto-char (process-mark proc)) - (beginning-of-line) - (if (looking-at term-prompt-regexp) - (set-marker term-pending-delete-marker (point))) - (term-send-invisible command proc)))) - -(defun tgud-refresh (&optional arg) - "Fix up a possibly garbled display, and redraw the arrow." - (interactive "P") - (recenter arg) - (or term-pending-frame (setq term-pending-frame tgud-last-last-frame)) - (tgud-display-frame)) - -;;; Code for parsing expressions out of C code. The single entry point is -;;; find-c-expr, which tries to return an lvalue expression from around point. -;;; -;;; The rest of this file is a hacked version of gdbsrc.el by -;;; Debby Ayers <ayers@asc.slb.com>, -;;; Rich Schaefer <schaefer@asc.slb.com> Schlumberger, Austin, Tx. - -(defun find-c-expr () - "Returns the C expr that surrounds point." - (interactive) - (save-excursion - (let ((p) (expr) (test-expr)) - (setq p (point)) - (setq expr (expr-cur)) - (setq test-expr (expr-prev)) - (while (expr-compound test-expr expr) - (setq expr (cons (car test-expr) (cdr expr))) - (goto-char (car expr)) - (setq test-expr (expr-prev))) - (goto-char p) - (setq test-expr (expr-next)) - (while (expr-compound expr test-expr) - (setq expr (cons (car expr) (cdr test-expr))) - (setq test-expr (expr-next)) - ) - (buffer-substring (car expr) (cdr expr))))) - -(defun expr-cur () - "Returns the expr that point is in; point is set to beginning of expr. -The expr is represented as a cons cell, where the car specifies the point in -the current buffer that marks the beginning of the expr and the cdr specifies -the character after the end of the expr." - (let ((p (point)) (begin) (end)) - (expr-backward-sexp) - (setq begin (point)) - (expr-forward-sexp) - (setq end (point)) - (if (>= p end) - (progn - (setq begin p) - (goto-char p) - (expr-forward-sexp) - (setq end (point)) - ) - ) - (goto-char begin) - (cons begin end))) - -(defun expr-backward-sexp () - "Version of `backward-sexp' that catches errors." - (condition-case nil - (backward-sexp) - (error t))) - -(defun expr-forward-sexp () - "Version of `forward-sexp' that catches errors." - (condition-case nil - (forward-sexp) - (error t))) - -(defun expr-prev () - "Returns the previous expr, point is set to beginning of that expr. -The expr is represented as a cons cell, where the car specifies the point in -the current buffer that marks the beginning of the expr and the cdr specifies -the character after the end of the expr" - (let ((begin) (end)) - (expr-backward-sexp) - (setq begin (point)) - (expr-forward-sexp) - (setq end (point)) - (goto-char begin) - (cons begin end))) - -(defun expr-next () - "Returns the following expr, point is set to beginning of that expr. -The expr is represented as a cons cell, where the car specifies the point in -the current buffer that marks the beginning of the expr and the cdr specifies -the character after the end of the expr." - (let ((begin) (end)) - (expr-forward-sexp) - (expr-forward-sexp) - (setq end (point)) - (expr-backward-sexp) - (setq begin (point)) - (cons begin end))) - -(defun expr-compound-sep (span-start span-end) - "Returns '.' for '->' & '.', returns ' ' for white space, -returns '?' for other punctuation." - (let ((result ? ) - (syntax)) - (while (< span-start span-end) - (setq syntax (char-syntax (char-after span-start))) - (cond - ((= syntax ? ) t) - ((= syntax ?.) (setq syntax (char-after span-start)) - (cond - ((= syntax ?.) (setq result ?.)) - ((and (= syntax ?-) (= (char-after (+ span-start 1)) ?>)) - (setq result ?.) - (setq span-start (+ span-start 1))) - (t (setq span-start span-end) - (setq result ??))))) - (setq span-start (+ span-start 1))) - result)) - -(defun expr-compound (first second) - "Non-nil if concatenating FIRST and SECOND makes a single C token. -The two exprs are represented as a cons cells, where the car -specifies the point in the current buffer that marks the beginning of the -expr and the cdr specifies the character after the end of the expr. -Link exprs of the form: - Expr -> Expr - Expr . Expr - Expr (Expr) - Expr [Expr] - (Expr) Expr - [Expr] Expr" - (let ((span-start (cdr first)) - (span-end (car second)) - (syntax)) - (setq syntax (expr-compound-sep span-start span-end)) - (cond - ((= (car first) (car second)) nil) - ((= (cdr first) (cdr second)) nil) - ((= syntax ?.) t) - ((= syntax ? ) - (setq span-start (char-after (- span-start 1))) - (setq span-end (char-after span-end)) - (cond - ((= span-start ?) ) t ) - ((= span-start ?] ) t ) - ((= span-end ?( ) t ) - ((= span-end ?[ ) t ) - (t nil)) - ) - (t nil)))) - -(provide 'tgud) - -;;; tgud.el ends here
--- a/lisp/eterm/tshell.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,817 +0,0 @@ -;;; tshell.el --- specialized term.el for running the shell. - -;; Copyright (C) 1988, 1993, 1994 Free Software Foundation, Inc. - -;; Author: Per Bothner <bothner@cygnus.com> -;; Original comint version author: Olin Shivers <shivers@cs.cmu.edu> -;; Comint version maintainer: Simon Marshall <s.marshall@dcs.hull.ac.uk> -;; Keywords: processes - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: - -;;; Please send me bug reports, bug fixes, and extensions, so that I can -;;; merge them into the master source. -;;; - Olin Shivers (shivers@cs.cmu.edu) -;;; - Simon Marshall (s.marshall@dcs.hull.ac.uk) - -;;; This file defines a a shell-in-a-buffer package (shell mode) built -;;; on top of term mode. This is actually cmushell with things -;;; renamed to replace its counterpart in Emacs 18. cmushell is more -;;; featureful, robust, and uniform than the Emacs 18 version. - -;;; Since this mode is built on top of the general command-interpreter-in- -;;; a-buffer mode (term mode), it shares a common base functionality, -;;; and a common set of bindings, with all modes derived from term mode. -;;; This makes these modes easier to use. - -;;; For documentation on the functionality provided by term mode, and -;;; the hooks available for customising it, see the file term.el. -;;; For further information on shell mode, see the comments below. - -;;; Needs fixin: -;;; When sending text from a source file to a subprocess, the process-mark can -;;; move off the window, so you can lose sight of the process interactions. -;;; Maybe I should ensure the process mark is in the window when I send -;;; text to the process? Switch selectable? - -;; YOUR .EMACS FILE -;;============================================================================= -;; Some suggestions for your .emacs file. -;; -;; ;; Define C-c t to run my favorite command in shell mode: -;; (setq tshell-mode-hook -;; '((lambda () -;; (define-key tshell-mode-map "\C-ct" 'favorite-cmd)))) - - -;;; Brief Command Documentation: -;;;============================================================================ -;;; Term Mode Commands: (common to tshell and all term-derived modes) -;;; -;;; m-p term-previous-input Cycle backwards in input history -;;; m-n term-next-input Cycle forwards -;;; m-r term-previous-matching-input Previous input matching a regexp -;;; m-R term-previous-matching-input-from-input -"- matching input -;;; m-s term-next-matching-input Next input that matches -;;; m-S term-next-matching-input-from-input -"- matching input -;;; m-c-l term-show-output Show last batch of process output -;;; return term-send-input -;;; c-c c-a term-bol Beginning of line; skip prompt -;;; c-d term-delchar-or-maybe-eof Delete char unless at end of buff. -;;; c-c c-u term-kill-input ^u -;;; c-c c-w backward-kill-word ^w -;;; c-c c-c term-interrupt-subjob ^c -;;; c-c c-z term-stop-subjob ^z -;;; c-c c-\ term-quit-subjob ^\ -;;; c-c c-o term-kill-output Delete last batch of process output -;;; c-c c-r term-show-output Show last batch of process output -;;; c-c c-h term-dynamic-list-input-ring List input history -;;; term-send-invisible Read line w/o echo & send to proc -;;; term-continue-subjob Useful if you accidentally suspend -;;; top-level job -;;; term-mode-hook is the term mode hook. - -;;; Tshell Mode Commands: -;;; tshell Fires up the shell process -;;; tab term-dynamic-complete Complete filename/command/history -;;; m-? term-dynamic-list-filename-completions List completions in help buffer -;;; m-c-f tshell-forward-command Forward a shell command -;;; m-c-b tshell-backward-command Backward a shell command -;;; dirs Resync the buffer's dir stack -;;; dirtrack-toggle Turn dir tracking on/off -;;; tshell-strip-ctrl-m Remove trailing ^Ms from output -;;; -;;; The tshell mode hook is tshell-mode-hook -;;; term-prompt-regexp is initialised to tshell-prompt-pattern, for backwards -;;; compatibility. - -;;; Read the rest of this file for more information. - -;;; SHELL.EL COMPATIBILITY -;;; Notes from when this was called cmushell, and was not the standard emacs -;;; shell package. -;;;============================================================================ -;;; In brief: this package should have no trouble coexisting with shell.el. -;;; -;;; Most customising variables -- e.g., explicit-shell-file-name -- are the -;;; same, so the users shouldn't have much trouble. Hooks have different -;;; names, however, so you can customise tshell mode differently from cmushell -;;; mode. You basically just have to remember to type M-x cmushell instead of -;;; M-x shell. -;;; -;;; It would be nice if this file was completely plug-compatible with the old -;;; shell package -- if you could just name this file shell.el, and have it -;;; transparently replace the old one. But you can't. Several other packages -;;; (tex-mode, background, dbx, gdb, kermit, monkey, prolog, telnet) are also -;;; clients of shell mode. These packages assume detailed knowledge of shell -;;; mode internals in ways that are incompatible with cmushell mode (mostly -;;; because of cmushell mode's greater functionality). So, unless we are -;;; willing to port all of these packages, we can't have this file be a -;;; complete replacement for shell.el -- that is, we can't name this file -;;; shell.el, and its main entry point (shell), because dbx.el will break -;;; when it loads it in and tries to use it. -;;; -;;; There are two ways to fix this. One: rewrite these other modes to use the -;;; new package. This is a win, but can't be assumed. The other, backwards -;;; compatible route, is to make this package non-conflict with shell.el, so -;;; both files can be loaded in at the same time. And *that* is why some -;;; functions and variables have different names: (cmushell), -;;; cmushell-mode-map, that sort of thing. All the names have been carefully -;;; chosen so that shell.el and cmushell.el won't tromp on each other. - -;;; Customization and Buffer Variables -;;; =========================================================================== -;;; - -;;; Code: - -(require 'term) - -;;;###autoload -(defvar tshell-prompt-pattern "^[^#$%>\n]*[#$%>] *" - "Regexp to match prompts in the inferior shell. -Defaults to \"^[^#$%>\\n]*[#$%>] *\", which works pretty well. -This variable is used to initialise `term-prompt-regexp' in the -shell buffer. - -The pattern should probably not match more than one line. If it does, -tshell-mode may become confused trying to distinguish prompt from input -on lines which don't start with a prompt. - -This is a fine thing to set in your `.emacs' file.") - -(defvar tshell-completion-fignore nil - "*List of suffixes to be disregarded during file/command completion. -This variable is used to initialize `term-completion-fignore' in the shell -buffer. The default is nil, for compatibility with most shells. -Some people like (\"~\" \"#\" \"%\"). - -This is a fine thing to set in your `.emacs' file.") - -(defvar tshell-delimiter-argument-list '(?\| ?& ?< ?> ?\( ?\) ?\;) - "List of characters to recognise as separate arguments. -This variable is used to initialize `term-delimiter-argument-list' in the -shell buffer. The default is (?\\| ?& ?< ?> ?\\( ?\\) ?\\;). - -This is a fine thing to set in your `.emacs' file.") - -(defvar tshell-dynamic-complete-functions - '(term-replace-by-expanded-history - tshell-dynamic-complete-environment-variable - tshell-dynamic-complete-command - tshell-replace-by-expanded-directory - term-dynamic-complete-filename) - "List of functions called to perform completion. -This variable is used to initialise `term-dynamic-complete-functions' in the -shell buffer. - -This is a fine thing to set in your `.emacs' file.") - -(defvar shell-command-regexp "[^;&|\n]+" - "*Regexp to match a single command within a pipeline. -This is used for directory tracking and does not do a perfect job.") - -(defvar shell-completion-execonly t - "*If non-nil, use executable files only for completion candidates. -This mirrors the optional behavior of tcsh. - -Detecting executability of files may slow command completion considerably.") - -(defvar shell-popd-regexp "popd" - "*Regexp to match subshell commands equivalent to popd.") - -(defvar shell-pushd-regexp "pushd" - "*Regexp to match subshell commands equivalent to pushd.") - -(defvar shell-pushd-tohome nil - "*If non-nil, make pushd with no arg behave as \"pushd ~\" (like cd). -This mirrors the optional behavior of tcsh.") - -(defvar shell-pushd-dextract nil - "*If non-nil, make \"pushd +n\" pop the nth dir to the stack top. -This mirrors the optional behavior of tcsh.") - -(defvar shell-pushd-dunique nil - "*If non-nil, make pushd only add unique directories to the stack. -This mirrors the optional behavior of tcsh.") - -(defvar shell-cd-regexp "cd" - "*Regexp to match subshell commands equivalent to cd.") - -;; explicit-shell-file-name nil is in term.el. - -(defvar explicit-csh-args - (if (eq system-type 'hpux) - ;; -T persuades HP's csh not to think it is smarter - ;; than us about what terminal modes to use. - '("-i" "-T") - '("-i")) - "*Args passed to inferior shell by M-x tshell, if the shell is csh. -Value is a list of strings, which may be nil.") - -(defvar tshell-input-autoexpand 'history - "*If non-nil, expand input command history references on completion. -This mirrors the optional behavior of tcsh (its autoexpand and histlit). - -If the value is `input', then the expansion is seen on input. -If the value is `history', then the expansion is only when inserting -into the buffer's input ring. See also `term-magic-space' and -`term-dynamic-complete'. - -This variable supplies a default for `term-input-autoexpand', -for Tshell mode only.") - -(defvar tshell-dirstack nil - "List of directories saved by pushd in this buffer's shell. -Thus, this does not include the shell's current directory.") - -(defvar tshell-dirtrackp t - "Non-nil in a shell buffer means directory tracking is enabled.") - -(defvar tshell-last-dir nil - "Keep track of last directory for ksh `cd -' command.") - -(defvar tshell-dirstack-query nil - "Command used by `tshell-resync-dir' to query the shell.") - -(defvar tshell-mode-map nil) -(cond ((not tshell-mode-map) - (setq tshell-mode-map (copy-keymap term-mode-map)) - (define-key tshell-mode-map "\C-c\C-f" 'tshell-forward-command) - (define-key tshell-mode-map "\C-c\C-b" 'tshell-backward-command) - (define-key tshell-mode-map "\t" 'term-dynamic-complete) - (define-key tshell-mode-map "\M-?" - 'term-dynamic-list-filename-completions) -;;; XEmacs change [JTL]: We don't have define-key-after -;;; (and we don't need it ...) -;;; (define-key-after (lookup-key tshell-mode-map [menu-bar completion]) -;;; [complete-env-variable] '("Complete Env. Variable Name" . -;;; tshell-dynamic-complete-environment-variable) -;;; 'complete-file) -;;; (define-key-after (lookup-key tshell-mode-map [menu-bar completion]) -;;; [expand-directory] '("Expand Directory Reference" . -;;; tshell-replace-by-expanded-directory) -;;; 'complete-expand) - )) - -(defvar tshell-mode-hook '() - "*Hook for customising Tshell mode.") - - -;;; Basic Procedures -;;; =========================================================================== -;;; - -(defun tshell-mode () - "Major mode for interacting with an inferior shell. -Return after the end of the process' output sends the text from the - end of process to the end of the current line. -Return before end of process output copies the current line (except - for the prompt) to the end of the buffer and sends it. -M-x term-send-invisible reads a line of text without echoing it, - and sends it to the shell. This is useful for entering passwords. - -If you accidentally suspend your process, use \\[term-continue-subjob] -to continue it. - -cd, pushd and popd commands given to the shell are watched by Emacs to keep -this buffer's default directory the same as the shell's working directory. -M-x dirs queries the shell and resyncs Emacs' idea of what the current - directory stack is. -M-x dirtrack-toggle turns directory tracking on and off. - -\\{tshell-mode-map} -Customization: Entry to this mode runs the hooks on `term-mode-hook' and -`tshell-mode-hook' (in that order). Before each input, the hooks on -`term-input-filter-functions' are run. - -Variables `shell-cd-regexp', `shell-pushd-regexp' and `shell-popd-regexp' -are used to match their respective commands, while `shell-pushd-tohome', -`shell-pushd-dextract' and `shell-pushd-dunique' control the behavior of the -relevant command. - -Variables `term-completion-autolist', `term-completion-addsuffix', -`term-completion-recexact' and `term-completion-fignore' control the -behavior of file name, command name and variable name completion. Variable -`shell-completion-execonly' controls the behavior of command name completion. -Variable `tshell-completion-fignore' is used to initialise the value of -`term-completion-fignore'. - -Variables `term-input-ring-file-name' and `term-input-autoexpand' control -the initialisation of the input ring history, and history expansion. - -Variables `term-output-filter-functions', a hook, and -`term-scroll-to-bottom-on-input' and `term-scroll-to-bottom-on-output' -control whether input and output cause the window to scroll to the end of the -buffer." - (interactive) - (term-mode) - (setq major-mode 'tshell-mode) - (setq mode-name "Shell") - (use-local-map tshell-mode-map) - (setq term-prompt-regexp tshell-prompt-pattern) - (setq term-completion-fignore tshell-completion-fignore) - (setq term-delimiter-argument-list tshell-delimiter-argument-list) - (setq term-dynamic-complete-functions tshell-dynamic-complete-functions) - (make-local-variable 'paragraph-start) - (setq paragraph-start term-prompt-regexp) - (make-local-variable 'tshell-dirstack) - (setq tshell-dirstack nil) - (setq tshell-last-dir nil) - (make-local-variable 'tshell-dirtrackp) - (setq tshell-dirtrackp t) - (add-hook 'term-input-filter-functions 'tshell-directory-tracker) - (setq term-input-autoexpand tshell-input-autoexpand) - ;; shell-dependent assignments. - (let ((shell (file-name-nondirectory (car - (process-command (get-buffer-process (current-buffer))))))) - (setq term-input-ring-file-name - (or (getenv "HISTFILE") - (cond ((string-equal shell "bash") "~/.bash_history") - ((string-equal shell "ksh") "~/.sh_history") - (t "~/.history")))) - (if (equal term-input-ring-file-name "/dev/null") - (setq term-input-ring-file-name nil)) - (setq tshell-dirstack-query - (if (string-match "^k?sh$" shell) "pwd" "dirs"))) - (run-hooks 'tshell-mode-hook) - (term-read-input-ring t)) - -;;;###autoload -(defun tshell () - "Run an inferior shell, with I/O through buffer *shell*. -If buffer exists but shell process is not running, make new shell. -If buffer exists and shell process is running, just switch to buffer `*shell*'. -Program used comes from variable `explicit-shell-file-name', - or (if that is nil) from the ESHELL environment variable, - or else from SHELL if there is no ESHELL. -If a file `~/.emacs_SHELLNAME' exists, it is given as initial input - (Note that this may lose due to a timing error if the shell - discards input when it starts up.) -The buffer is put in Tshell mode, giving commands for sending input -and controlling the subjobs of the shell. See `tshell-mode'. -See also the variable `tshell-prompt-pattern'. - -The shell file name (sans directories) is used to make a symbol name -such as `explicit-csh-args'. If that symbol is a variable, -its value is used as a list of arguments when invoking the shell. -Otherwise, one argument `-i' is passed to the shell. - -\(Type \\[describe-mode] in the shell buffer for a list of commands.)" - (interactive) - (if (not (term-check-proc "*shell*")) - (let* ((prog (or explicit-shell-file-name - (getenv "ESHELL") - (getenv "SHELL") - "/bin/sh")) - (name (file-name-nondirectory prog)) - (startfile (concat "~/.emacs_" name)) - (xargs-name (intern-soft (concat "explicit-" name "-args")))) - (set-buffer (apply 'make-term "shell" prog - (if (file-exists-p startfile) startfile) - (if (and xargs-name (boundp xargs-name)) - (symbol-value xargs-name) - '("-i")))) - (tshell-mode))) - (switch-to-buffer "*shell*")) - -;;; Directory tracking -;;; =========================================================================== -;;; This code provides the tshell mode input sentinel -;;; TSHELL-DIRECTORY-TRACKER -;;; that tracks cd, pushd, and popd commands issued to the tshell, and -;;; changes the current directory of the tshell buffer accordingly. -;;; -;;; A better mechanism is now available: -;;; The standard term process filter supports a special escape command -;;; \032 / <cwd> \n -;;; that the inferior can use to tell emacs what the current working -;;; directory is. -;;; All the inferior has to do is something like: -;;; printf("\032/%s\n", PWD); -;;; Most modern shells can be programmed to emit this string easily. -;;; Hopefully, bash (at least) will be modified to do this automatically. -;;; -;;; So all this horrible directory-tracking machinary is now obsolete, -;;; but is kept at least until the standard GNU shells are modified -;;; -;;; This is basically a fragile hack, although it's more accurate than -;;; the version in Emacs 18's shell.el. It has the following failings: -;;; 1. It doesn't know about the cdpath shell variable. -;;; 2. It cannot infallibly deal with command sequences, though it does well -;;; with these and with ignoring commands forked in another shell with ()s. -;;; 3. More generally, any complex command is going to throw it. Otherwise, -;;; you'd have to build an entire shell interpreter in emacs lisp. Failing -;;; that, there's no way to catch shell commands where cd's are buried -;;; inside conditional expressions, aliases, and so forth. -;;; -;;; The whole approach is a crock. Shell aliases mess it up. File sourcing -;;; messes it up. You run other processes under the shell; these each have -;;; separate working directories, and some have commands for manipulating -;;; their w.d.'s (e.g., the lcd command in ftp). Some of these programs have -;;; commands that do *not* affect the current w.d. at all, but look like they -;;; do (e.g., the cd command in ftp). In shells that allow you job -;;; control, you can switch between jobs, all having different w.d.'s. So -;;; simply saying %3 can shift your w.d.. -;;; -;;; The solution is to relax, not stress out about it, and settle for -;;; a hack that works pretty well in typical circumstances. Remember -;;; that a half-assed solution is more in keeping with the spirit of Unix, -;;; anyway. Blech. - -(defun tshell-directory-tracker (str) - "Tracks cd, pushd and popd commands issued to the shell. -This function is called on each input passed to the shell. -It watches for cd, pushd and popd commands and sets the buffer's -default directory to track these commands. - -You may toggle this tracking on and off with M-x dirtrack-toggle. -If emacs gets confused, you can resync with the shell with M-x dirs. - -See variables `shell-cd-regexp', `shell-pushd-regexp', and `shell-popd-regexp', -while `shell-pushd-tohome', `shell-pushd-dextract' and `shell-pushd-dunique' -control the behavior of the relevant command. - -Environment variables are expanded, see function `substitute-in-file-name'." - (if tshell-dirtrackp - ;; We fail gracefully if we think the command will fail in the shell. - (condition-case chdir-failure - (let ((start (progn (string-match "^[;\\s ]*" str) ; skip whitespace - (match-end 0))) - end cmd arg1) - (while (string-match shell-command-regexp str start) - (setq end (match-end 0) - cmd (term-arguments (substring str start end) 0 0) - arg1 (term-arguments (substring str start end) 1 1)) - (cond ((eq (string-match shell-popd-regexp cmd) 0) - (tshell-process-popd (substitute-in-file-name arg1))) - ((eq (string-match shell-pushd-regexp cmd) 0) - (tshell-process-pushd (substitute-in-file-name arg1))) - ((eq (string-match shell-cd-regexp cmd) 0) - (tshell-process-cd (substitute-in-file-name arg1)))) - (setq start (progn (string-match "[;\\s ]*" str end) ; skip again - (match-end 0))))) - (error "Couldn't cd")))) - -;;; popd [+n] -(defun tshell-process-popd (arg) - (let ((num (or (tshell-extract-num arg) 0))) - (cond ((and num (= num 0) tshell-dirstack) - (cd (car tshell-dirstack)) - (setq tshell-dirstack (cdr tshell-dirstack)) - (tshell-dirstack-message)) - ((and num (> num 0) (<= num (length tshell-dirstack))) - (let* ((ds (cons nil tshell-dirstack)) - (cell (nthcdr (1- num) ds))) - (rplacd cell (cdr (cdr cell))) - (setq tshell-dirstack (cdr ds)) - (tshell-dirstack-message))) - (t - (error "Couldn't popd"))))) - -;; Return DIR prefixed with term-file-name-prefix as appropriate. -(defun tshell-prefixed-directory-name (dir) - (if (= (length term-file-name-prefix) 0) - dir - (if (file-name-absolute-p dir) - ;; The name is absolute, so prepend the prefix. - (concat term-file-name-prefix dir) - ;; For a relative name we assume default-directory already has the prefix. - (expand-file-name dir)))) - -;;; cd [dir] -(defun tshell-process-cd (arg) - (let ((new-dir (cond ((zerop (length arg)) (concat term-file-name-prefix - "~")) - ((string-equal "-" arg) tshell-last-dir) - (t (tshell-prefixed-directory-name arg))))) - (setq tshell-last-dir default-directory) - (cd new-dir) - (tshell-dirstack-message))) - -;;; pushd [+n | dir] -(defun tshell-process-pushd (arg) - (let ((num (tshell-extract-num arg))) - (cond ((zerop (length arg)) - ;; no arg -- swap pwd and car of stack unless shell-pushd-tohome - (cond (shell-pushd-tohome - (shell-process-pushd (concat term-file-name-prefix "~"))) - (tshell-dirstack - (let ((old default-directory)) - (cd (car tshell-dirstack)) - (setq tshell-dirstack - (cons old (cdr tshell-dirstack))) - (tshell-dirstack-message))) - (t - (message "Directory stack empty.")))) - ((numberp num) - ;; pushd +n - (cond ((> num (length tshell-dirstack)) - (message "Directory stack not that deep.")) - ((= num 0) - (error (message "Couldn't cd."))) - (shell-pushd-dextract - (let ((dir (nth (1- num) tshell-dirstack))) - (tshell-process-popd arg) - (tshell-process-pushd default-directory) - (cd dir) - (tshell-dirstack-message))) - (t - (let* ((ds (cons default-directory tshell-dirstack)) - (dslen (length ds)) - (front (nthcdr num ds)) - (back (reverse (nthcdr (- dslen num) (reverse ds)))) - (new-ds (append front back))) - (cd (car new-ds)) - (setq tshell-dirstack (cdr new-ds)) - (tshell-dirstack-message))))) - (t - ;; pushd <dir> - (let ((old-wd default-directory)) - (cd (tshell-prefixed-directory-name arg)) - (if (or (null shell-pushd-dunique) - (not (member old-wd tshell-dirstack))) - (setq tshell-dirstack (cons old-wd tshell-dirstack))) - (tshell-dirstack-message)))))) - -;; If STR is of the form +n, for n>0, return n. Otherwise, nil. -(defun tshell-extract-num (str) - (and (string-match "^\\+[1-9][0-9]*$" str) - (string-to-int str))) - - -(defun tshell-dirtrack-toggle () - "Turn directory tracking on and off in a shell buffer." - (interactive) - (setq tshell-dirtrackp (not tshell-dirtrackp)) - (message "Directory tracking %s" (if tshell-dirtrackp "ON" "OFF"))) - -;;; For your typing convenience: -(defalias 'dirtrack-toggle 'tshell-dirtrack-toggle) - - -(defun tshell-resync-dirs () - "Resync the buffer's idea of the current directory stack. -This command queries the shell with the command bound to -`tshell-dirstack-query' (default \"dirs\"), reads the next -line output and parses it to form the new directory stack. -DON'T issue this command unless the buffer is at a shell prompt. -Also, note that if some other subprocess decides to do output -immediately after the query, its output will be taken as the -new directory stack -- you lose. If this happens, just do the -command again." - (interactive) - (let* ((proc (get-buffer-process (current-buffer))) - (pmark (process-mark proc))) - (goto-char pmark) - (insert tshell-dirstack-query) (insert "\n") - (sit-for 0) ; force redisplay - (term-send-string proc tshell-dirstack-query) - (term-send-string proc "\n") - (set-marker pmark (point)) - (let ((pt (point))) ; wait for 1 line - ;; This extra newline prevents the user's pending input from spoofing us. - (insert "\n") (backward-char 1) - (while (not (looking-at ".+\n")) - (accept-process-output proc) - (goto-char pt))) - (goto-char pmark) (delete-char 1) ; remove the extra newline - ;; That's the dirlist. grab it & parse it. - (let* ((dl (buffer-substring (match-beginning 0) (1- (match-end 0)))) - (dl-len (length dl)) - (ds '()) ; new dir stack - (i 0)) - (while (< i dl-len) - ;; regexp = optional whitespace, (non-whitespace), optional whitespace - (string-match "\\s *\\(\\S +\\)\\s *" dl i) ; pick off next dir - (setq ds (cons (concat term-file-name-prefix - (substring dl (match-beginning 1) - (match-end 1))) - ds)) - (setq i (match-end 0))) - (let ((ds (nreverse ds))) - (condition-case nil - (progn (cd (car ds)) - (setq tshell-dirstack (cdr ds)) - (tshell-dirstack-message)) - (error (message "Couldn't cd."))))))) - -;;; For your typing convenience: -(defalias 'dirs 'tshell-resync-dirs) - - -;;; Show the current dirstack on the message line. -;;; Pretty up dirs a bit by changing "/usr/jqr/foo" to "~/foo". -;;; (This isn't necessary if the dirlisting is generated with a simple "dirs".) -;;; All the commands that mung the buffer's dirstack finish by calling -;;; this guy. -(defun tshell-dirstack-message () - (let* ((msg "") - (ds (cons default-directory tshell-dirstack)) - (home (expand-file-name (concat term-file-name-prefix "~/"))) - (homelen (length home))) - (while ds - (let ((dir (car ds))) - (and (>= (length dir) homelen) (string= home (substring dir 0 homelen)) - (setq dir (concat "~/" (substring dir homelen)))) - ;; Strip off term-file-name-prefix if present. - (and term-file-name-prefix - (>= (length dir) (length term-file-name-prefix)) - (string= term-file-name-prefix - (substring dir 0 (length term-file-name-prefix))) - (setq dir (substring dir (length term-file-name-prefix))) - (setcar ds dir)) - (setq msg (concat msg (directory-file-name dir) " ")) - (setq ds (cdr ds)))) - (message msg))) - -(defun tshell-forward-command (&optional arg) - "Move forward across ARG shell command(s). Does not cross lines. -See `shell-command-regexp'." - (interactive "p") - (let ((limit (save-excursion (end-of-line nil) (point)))) - (if (re-search-forward (concat shell-command-regexp "\\([;&|][\t ]*\\)+") - limit 'move arg) - (skip-syntax-backward " ")))) - - -(defun tshell-backward-command (&optional arg) - "Move backward across ARG shell command(s). Does not cross lines. -See `shell-command-regexp'." - (interactive "p") - (let ((limit (save-excursion (term-bol nil) (point)))) - (if (> limit (point)) - (save-excursion (beginning-of-line) (setq limit (point)))) - (skip-syntax-backward " " limit) - (if (re-search-backward - (format "[;&|]+[\t ]*\\(%s\\)" shell-command-regexp) limit 'move arg) - (progn (goto-char (match-beginning 1)) - (skip-chars-forward ";&|"))))) - - -(defun tshell-dynamic-complete-command () - "Dynamically complete the command at point. -This function is similar to `term-dynamic-complete-filename', except that it -searches `exec-path' (minus the trailing emacs library path) for completion -candidates. Note that this may not be the same as the shell's idea of the -path. - -Completion is dependent on the value of `shell-completion-execonly', plus -those that effect file completion. See `tshell-dynamic-complete-as-command'. - -Returns t if successful." - (interactive) - (let ((filename (term-match-partial-filename))) - (if (and filename - (save-match-data (not (string-match "[~/]" filename))) - (eq (match-beginning 0) - (save-excursion (tshell-backward-command 1) (point)))) - (prog2 (message "Completing command name...") - (tshell-dynamic-complete-as-command))))) - - -(defun tshell-dynamic-complete-as-command () - "Dynamically complete at point as a command. -See `tshell-dynamic-complete-filename'. Returns t if successful." - (let* ((filename (or (term-match-partial-filename) "")) - (pathnondir (file-name-nondirectory filename)) - (paths (cdr (reverse exec-path))) - (cwd (file-name-as-directory (expand-file-name default-directory))) - (ignored-extensions - (and term-completion-fignore - (mapconcat (function (lambda (x) (concat (regexp-quote x) "$"))) - term-completion-fignore "\\|"))) - (path "") (comps-in-path ()) (file "") (filepath "") (completions ())) - ;; Go thru each path in the search path, finding completions. - (while paths - (setq path (file-name-as-directory (term-directory (or (car paths) "."))) - comps-in-path (and (file-accessible-directory-p path) - (file-name-all-completions pathnondir path))) - ;; Go thru each completion found, to see whether it should be used. - (while comps-in-path - (setq file (car comps-in-path) - filepath (concat path file)) - (if (and (not (member file completions)) - (not (and ignored-extensions - (string-match ignored-extensions file))) - (or (string-equal path cwd) - (not (file-directory-p filepath))) - (or (null shell-completion-execonly) - (file-executable-p filepath))) - (setq completions (cons file completions))) - (setq comps-in-path (cdr comps-in-path))) - (setq paths (cdr paths))) - ;; OK, we've got a list of completions. - (let ((success (let ((term-completion-addsuffix nil)) - (term-dynamic-simple-complete pathnondir completions)))) - (if (and (memq success '(sole shortest)) term-completion-addsuffix - (not (file-directory-p (term-match-partial-filename)))) - (insert " ")) - success))) - - -(defun tshell-match-partial-variable () - "Return the variable at point, or nil if non is found." - (save-excursion - (let ((limit (point))) - (if (re-search-backward "[^A-Za-z0-9_{}]" nil 'move) - (or (looking-at "\\$") (forward-char 1))) - ;; Anchor the search forwards. - (if (or (eolp) (looking-at "[^A-Za-z0-9_{}$]")) - nil - (re-search-forward "\\$?{?[A-Za-z0-9_]*}?" limit) - (buffer-substring (match-beginning 0) (match-end 0)))))) - - -(defun tshell-dynamic-complete-environment-variable () - "Dynamically complete the environment variable at point. -Completes if after a variable, i.e., if it starts with a \"$\". -See `tshell-dynamic-complete-as-environment-variable'. - -This function is similar to `term-dynamic-complete-filename', except that it -searches `process-environment' for completion candidates. Note that this may -not be the same as the interpreter's idea of variable names. The main problem -with this type of completion is that `process-environment' is the environment -which Emacs started with. Emacs does not track changes to the environment made -by the interpreter. Perhaps it would be more accurate if this function was -called `tshell-dynamic-complete-process-environment-variable'. - -Returns non-nil if successful." - (interactive) - (let ((variable (tshell-match-partial-variable))) - (if (and variable (string-match "^\\$" variable)) - (prog2 (message "Completing variable name...") - (tshell-dynamic-complete-as-environment-variable))))) - - -(defun tshell-dynamic-complete-as-environment-variable () - "Dynamically complete at point as an environment variable. -Used by `tshell-dynamic-complete-environment-variable'. -Uses `term-dynamic-simple-complete'." - (let* ((var (or (tshell-match-partial-variable) "")) - (variable (substring var (or (string-match "[^$({]\\|$" var) 0))) - (variables (mapcar (function (lambda (x) - (substring x 0 (string-match "=" x)))) - process-environment)) - (addsuffix term-completion-addsuffix) - (term-completion-addsuffix nil) - (success (term-dynamic-simple-complete variable variables))) - (if (memq success '(sole shortest)) - (let* ((var (tshell-match-partial-variable)) - (variable (substring var (string-match "[^$({]" var))) - (protection (cond ((string-match "{" var) "}") - ((string-match "(" var) ")") - (t ""))) - (suffix (cond ((null addsuffix) "") - ((file-directory-p - (term-directory (getenv variable))) "/") - (t " ")))) - (insert protection suffix))) - success)) - - -(defun tshell-replace-by-expanded-directory () - "Expand directory stack reference before point. -Directory stack references are of the form \"=digit\" or \"=-\". -See `default-directory' and `tshell-dirstack'. - -Returns t if successful." - (interactive) - (if (term-match-partial-filename) - (save-excursion - (goto-char (match-beginning 0)) - (let ((stack (cons default-directory tshell-dirstack)) - (index (cond ((looking-at "=-/?") - (length tshell-dirstack)) - ((looking-at "=\\([0-9]+\\)") - (string-to-number - (buffer-substring - (match-beginning 1) (match-end 1))))))) - (cond ((null index) - nil) - ((>= index (length stack)) - (error "Directory stack not that deep.")) - (t - (replace-match (file-name-as-directory (nth index stack)) t t) - (message "Directory item: %d" index) - t)))))) - -(provide 'tshell) - -;;; tshell.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/events.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,160 @@ +;;; events.el --- event functions for XEmacs. + +;; Copyright (C) 1997 Free Software Foundation, Inc. +;; Copyright (C) 1996-7 Sun Microsystems, Inc. +;; Copyright (C) 1996 Ben Wing. + +;; Maintainer: Martin Buchholz +;; Keywords: internal, event, dumped + +;; 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, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: Not in FSF. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;;; Code: + + +(defun event-console (event) + "Return the console that EVENT occurred on. +This will be nil for some types of events (e.g. eval events)." + (cdfw-console (event-channel event))) + +(defun event-device (event) + "Return the device that EVENT occurred on. +This will be nil for some types of events (e.g. keyboard and eval events)." + (dfw-device (event-channel event))) + +(defun event-frame (event) + "Return the frame that EVENT occurred on. +This will be nil for some types of events (e.g. keyboard and eval events)." + (fw-frame (event-channel event))) + +(defun event-buffer (event) + "Return the buffer of the window over which mouse event EVENT occurred. +Return nil unless both (mouse-event-p EVENT) and +(event-over-text-area-p EVENT) are non-nil." + (let ((window (event-window event))) + (and (windowp window) (window-buffer window)))) + +(defalias 'allocate-event 'make-event) + + +(defun key-press-event-p (object) + "Return t if OBJECT is a key-press event." + (and (event-live-p object) (eq 'key-press (event-type object)))) + +(defun button-press-event-p (object) + "Return t if OBJECT is a mouse button-press event." + (and (event-live-p object) (eq 'button-press (event-type object)))) + +(defun button-release-event-p (object) + "Return t if OBJECT is a mouse button-release event." + (and (event-live-p object) (eq 'button-release (event-type object)))) + +(defun button-event-p (object) + "Return t if OBJECT is a mouse button-press or button-release event." + (and (event-live-p object) + (memq (event-type object) '(button-press button-release)) + t)) + +(defun motion-event-p (object) + "Return t if OBJECT is a mouse motion event." + (and (event-live-p object) (eq 'motion (event-type object)))) + +(defun mouse-event-p (object) + "Return t if OBJECT is a mouse button-press, button-release or motion event." + (and (event-live-p object) + (memq (event-type object) '(button-press button-release motion)) + t)) + +(defun process-event-p (object) + "Return t if OBJECT is a process-output event." + (and (event-live-p object) (eq 'process (event-type object)))) + +(defun timeout-event-p (object) + "Return t if OBJECT is a timeout event." + (and (event-live-p object) (eq 'timeout (event-type object)))) + +(defun eval-event-p (object) + "Return t if OBJECT is an eval event." + (and (event-live-p object) (eq 'eval (event-type object)))) + +(defun misc-user-event-p (object) + "Return t if OBJECT is a misc-user event. +A misc-user event is a user event that is not a keypress or mouse click; +normally this means a menu selection or scrollbar action." + (and (event-live-p object) (eq 'misc-user (event-type object)))) + +;; You could just as easily use event-glyph but we include this for +;; consistency. + +(defun event-over-glyph-p (object) + "Return t if OBJECT is a mouse event occurring over a glyph. +Mouse events are events of type button-press, button-release or motion." + (and (event-live-p object) (event-glyph object) t)) + +(defun keyboard-translate (&rest pairs) + "Translate character or keysym FROM to TO at a low level. +Multiple FROM-TO pairs may be specified. + +See `keyboard-translate-table' for more information." + (while pairs + (puthash (pop pairs) (pop pairs) keyboard-translate-table))) + +(put 'backspace 'ascii-character ?\b) +(put 'delete 'ascii-character ?\177) +(put 'tab 'ascii-character ?\t) +(put 'linefeed 'ascii-character ?\n) +(put 'clear 'ascii-character 12) +(put 'return 'ascii-character ?\r) +(put 'escape 'ascii-character ?\e) +(put 'space 'ascii-character ? ) + + ;; Do the same voodoo for the keypad keys. I used to bind these to keyboard + ;; macros (for instance, kp-0 was bound to "0") so that they would track the + ;; bindings of the corresponding keys by default, but that made the display + ;; of M-x describe-bindings much harder to read, so now we'll just bind them + ;; to self-insert by default. Not a big difference... + +(put 'kp-0 'ascii-character ?0) +(put 'kp-1 'ascii-character ?1) +(put 'kp-2 'ascii-character ?2) +(put 'kp-3 'ascii-character ?3) +(put 'kp-4 'ascii-character ?4) +(put 'kp-5 'ascii-character ?5) +(put 'kp-6 'ascii-character ?6) +(put 'kp-7 'ascii-character ?7) +(put 'kp-8 'ascii-character ?8) +(put 'kp-9 'ascii-character ?9) + +(put 'kp-space 'ascii-character ? ) +(put 'kp-tab 'ascii-character ?\t) +(put 'kp-enter 'ascii-character ?\r) +(put 'kp-equal 'ascii-character ?=) +(put 'kp-multiply 'ascii-character ?*) +(put 'kp-add 'ascii-character ?+) +(put 'kp-separator 'ascii-character ?,) +(put 'kp-subtract 'ascii-character ?-) +(put 'kp-decimal 'ascii-character ?.) +(put 'kp-divide 'ascii-character ?/) + +;;; events.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/extents.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,98 @@ +;;; extents.el --- miscellaneous extent functions not written in C + +;; Copyright (C) 1993-4, 1997 Free Software Foundation, Inc. + +;; Keywords: internal, dumped + +;; 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, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: Not in FSF. + +;;; Commentary: + +;; some help from stig@hackvan.com here. + +;;; Code: + +;; an alternative to map-extents. +(defun mapcar-extents (function &optional predicate buffer-or-string from to + flags property value) + "Applies FUNCTION to all extents which overlap a region in BUFFER-OR-STRING. +The region is delimited by FROM and TO. FUNCTION is called with +one argument, the extent. A list of the values returned by FUNCTION +is returned. An optional PREDICATE may be used to further limit the +extents over which FUNCTION is mapped. The optional arguments FLAGS, +PROPERTY, and VALUE may also be used to control the extents passed to +PREDICATE or FUNCTION. See also `map-extents'." + (let (*result*) + (map-extents (if predicate + #'(lambda (ex junk) + (and (funcall predicate ex) + (setq *result* (cons (funcall function ex) + *result*))) + nil) + #'(lambda (ex junk) + (setq *result* (cons (funcall function ex) + *result*)) + nil)) + buffer-or-string from to nil flags property value) + (nreverse *result*))) + +(defun extent-list (&optional buffer-or-string from to flags) + "Return a list of the extents in BUFFER-OR-STRING. +BUFFER-OR-STRING defaults to the current buffer if omitted. +FROM and TO can be used to limit the range over which extents are +returned; if omitted, all extents in the buffer or string are returned. + +More specifically, if a range is specified using FROM and TO, only +extents that overlap the range (i.e. begin or end inside of the range) +are included in the list. FROM and TO default to the beginning and +end of BUFFER-OR-STRING, respectively. + +FLAGS controls how end cases are treated. For a discussion of this, +and exactly what ``overlap'' means, see `map-extents'. + +If you want to map a function over the extents in a buffer or string, +consider using `map-extents' or `mapcar-extents' instead." + (mapcar-extents 'identity nil buffer-or-string from to flags)) + +(defun extent-string (extent) + "Return the string delimited by the bounds of EXTENT." + (let ((object (extent-object extent))) + (if (bufferp object) + (buffer-substring (extent-start-position extent) + (extent-end-position extent) + object) + (substring object + (extent-start-position extent) + (extent-end-position extent))))) + +(defun extent-descendants (extent) + "Return a list of all descendants of EXTENT, including EXTENT. +This recursively applies `extent-children' to any children of +EXTENT, until no more children can be found." + (let ((children (extent-children extent))) + (if children + (apply 'nconc (mapcar 'extent-descendants children)) + (list extent)))) + +(defun set-extent-keymap (extent keymap) + "Set EXTENT's `keymap' property to KEYMAP." + (set-extent-property extent 'keymap keymap)) + +;;; extents.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/faces.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,1692 @@ +;;; faces.el --- Lisp interface to the C "face" structure + +;; Copyright (C) 1992-4, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1995 Board of Trustees, University of Illinois +;; Copyright (C) 1995, 1996 Ben Wing + +;; Author: Ben Wing <wing@666.com> +;; Keywords: faces, internal, dumped + +;; 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 synched with FSF. Almost completely divergent. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;; face implementation #1 (used Lisp vectors and parallel C vectors; +;; FSFmacs still uses this) authored by Jamie Zawinski <jwz@netscape.com> +;; pre Lucid-Emacs 19.0. + +;; face implementation #2 (used one face object per frame per face) +;; authored by Jamie Zawinski for 19.9. + +;; face implementation #3 (use one face object per face) originally +;; authored for 19.12 by Chuck Thompson <cthomp@cs.uiuc.edu>, +;; rewritten by Ben Wing with the advent of specifiers. + + +;;; Some stuff in FSF's faces.el is in our x-faces.el. + +;;; Code: + +(defun read-face-name (prompt) + (let (face) + (while (= (length face) 0) ; nil or "" + (setq face (completing-read prompt + (mapcar (lambda (x) (list (symbol-name x))) + (face-list)) + nil t))) + (intern face))) + +(defun face-interactive (what &optional bool) + (let* ((fn (intern (concat "face-" what "-instance"))) + (face (read-face-name (format "Set %s of face: " what))) + (default (if (fboundp fn) + ;; #### we should distinguish here between + ;; explicitly setting the value to be the + ;; same as the default face's value, and + ;; not setting a value at all. + (funcall fn face))) + (value (if bool + (y-or-n-p (format "Should face %s be %s? " + (symbol-name face) bool)) + (read-string (format "Set %s of face %s to: " + what (symbol-name face)) + (cond ((font-instance-p default) + (font-instance-name default)) + ((color-instance-p default) + (color-instance-name default)) + ((image-instance-p default) + (image-instance-file-name default)) + (t default)))))) + (list face (if (equal value "") nil value)))) + +(defconst built-in-face-specifiers + (built-in-face-specifiers) + "A list of the built-in face properties that are specifiers.") + +(defun face-property (face property &optional locale tag-set exact-p) + "Return FACE's value of the given PROPERTY. + +If LOCALE is omitted, the FACE's actual value for PROPERTY will be + returned. For built-in properties, this will be a specifier object + of a type appropriate to the property (e.g. a font or color + specifier). For other properties, this could be anything. + +If LOCALE is supplied, then instead of returning the actual value, + the specification(s) for the given locale or locale type will + be returned. This will only work if the actual value of + PROPERTY is a specifier (this will always be the case for built-in + properties, but not or not may apply to user-defined properties). + If the actual value of PROPERTY is not a specifier, this value + will simply be returned regardless of LOCALE. + +The return value will be a list of instantiators (e.g. strings + specifying a font or color name), or a list of specifications, each + of which is a cons of a locale and a list of instantiators. + Specifically, if LOCALE is a particular locale (a buffer, window, + frame, device, or 'global), a list of instantiators for that locale + will be returned. Otherwise, if LOCALE is a locale type (one of + the symbols 'buffer, 'window, 'frame, or 'device), the specifications + for all locales of that type will be returned. Finally, if LOCALE is + 'all, the specifications for all locales of all types will be returned. + +The specifications in a specifier determine what the value of + PROPERTY will be in a particular \"domain\" or set of circumstances, + which is typically a particular Emacs window along with the buffer + it contains and the frame and device it lies within. The value + is derived from the instantiator associated with the most specific + locale (in the order buffer, window, frame, device, and 'global) + that matches the domain in question. In other words, given a domain + (i.e. an Emacs window, usually), the specifier for PROPERTY will first + be searched for a specification whose locale is the buffer contained + within that window; then for a specification whose locale is the window + itself; then for a specification whose locale is the frame that the + window is contained within; etc. The first instantiator that is + valid for the domain (usually this means that the instantiator is + recognized by the device [i.e. the X server or TTY device] that the + domain is on. The function `face-property-instance' actually does + all this, and is used to determine how to display the face. + +See `set-face-property' for the built-in property-names." + + (setq face (get-face face)) + (let ((value (get face property))) + (if (and locale + (or (memq property built-in-face-specifiers) + (specifierp value))) + (setq value (specifier-specs value locale tag-set exact-p))) + value)) + +(defun convert-face-property-into-specifier (face property) + "Convert PROPERTY on FACE into a specifier, if it's not already." + (setq face (get-face face)) + (let ((specifier (get face property))) + ;; if a user-property does not have a specifier but a + ;; locale was specified, put a specifier there. + ;; If there was already a value there, convert it to a + ;; specifier with the value as its 'global instantiator. + (unless (specifierp specifier) + (let ((new-specifier (make-specifier 'generic))) + (if (or (not (null specifier)) + ;; make sure the nil returned from `get' wasn't + ;; actually the value of the property + (null (get face property t))) + (add-spec-to-specifier new-specifier specifier)) + (setq specifier new-specifier) + (put face property specifier))))) + +(defun face-property-instance (face property + &optional domain default no-fallback) + "Return the instance of FACE's PROPERTY in the specified DOMAIN. + +Under most circumstances, DOMAIN will be a particular window, + and the returned instance describes how the specified property + actually is displayed for that window and the particular buffer + in it. Note that this may not be the same as how the property + appears when the buffer is displayed in a different window or + frame, or how the property appears in the same window if you + switch to another buffer in that window; and in those cases, + the returned instance would be different. + +The returned instance will typically be a color-instance, + font-instance, or pixmap-instance object, and you can query + it using the appropriate object-specific functions. For example, + you could use `color-instance-rgb-components' to find out the + RGB (red, green, and blue) components of how the 'background + property of the 'highlight face is displayed in a particular + window. The results might be different from the results + you would get for another window (perhaps the user + specified a different color for the frame that window is on; + or perhaps the same color was specified but the window is + on a different X server, and that X server has different RGB + values for the color from this one). + +DOMAIN defaults to the selected window if omitted. + +DOMAIN can be a frame or device, instead of a window. The value + returned for a such a domain is used in special circumstances + when a more specific domain does not apply; for example, a frame + value might be used for coloring a toolbar, which is conceptually + attached to a frame rather than a particular window. The value + is also useful in determining what the value would be for a + particular window within the frame or device, if it is not + overridden by a more specific specification. + +If PROPERTY does not name a built-in property, its value will + simply be returned unless it is a specifier object, in which case + it will be instanced using `specifier-instance'. + +Optional arguments DEFAULT and NO-FALLBACK are the same as in + `specifier-instance'." + + (setq face (get-face face)) + (let ((value (get face property))) + (if (specifierp value) + (setq value (specifier-instance value domain default no-fallback))) + value)) + +(defun face-property-matching-instance (face property matchspec + &optional domain default + no-fallback) + "Return the instance of FACE's PROPERTY matching MATCHSPEC in DOMAIN. +Currently the only useful value for MATCHSPEC is a charset, when used +in conjunction with the face's font; this allows you to retrieve a +font that can be used to display a particular charset, rather than just +any font. + +Other than MATCHSPEC, this function is identical to `face-property-instance'. +See also `specifier-matching-instance' for a fuller description of the +matching process." + + (setq face (get-face face)) + (let ((value (get face property))) + (if (specifierp value) + (setq value (specifier-matching-instance value matchspec domain + default no-fallback))) + value)) + +(defun set-face-property (face property value &optional locale tag-set + how-to-add) + "Change a property of a FACE. + +NOTE: If you want to remove a property from a face, use `remove-face-property' + rather than attempting to set a value of nil for the property. + +For built-in properties, the actual value of the property is a + specifier and you cannot change this; but you can change the + specifications within the specifier, and that is what this function + will do. For user-defined properties, you can use this function + to either change the actual value of the property or, if this value + is a specifier, change the specifications within it. + +If PROPERTY is a built-in property, the specifications to be added to + this property can be supplied in many different ways: + + -- If VALUE is a simple instantiator (e.g. a string naming a font or + color) or a list of instantiators, then the instantiator(s) will + be added as a specification of the property for the given LOCALE + (which defaults to 'global if omitted). + -- If VALUE is a list of specifications (each of which is a cons of + a locale and a list of instantiators), then LOCALE must be nil + (it does not make sense to explicitly specify a locale in this + case), and specifications will be added as given. + -- If VALUE is a specifier (as would be returned by `face-property' + if no LOCALE argument is given), then some or all of the + specifications in the specifier will be added to the property. + In this case, the function is really equivalent to + `copy-specifier' and LOCALE has the same semantics (if it is + a particular locale, the specification for the locale will be + copied; if a locale type, specifications for all locales of + that type will be copied; if nil or 'all, then all + specifications will be copied). + +HOW-TO-ADD should be either nil or one of the symbols 'prepend, + 'append, 'remove-tag-set-prepend, 'remove-tag-set-append, 'remove-locale, + 'remove-locale-type, or 'remove-all. See `copy-specifier' and + `add-spec-to-specifier' for a description of what each of + these means. Most of the time, you do not need to worry about + this argument; the default behavior usually is fine. + +In general, it is OK to pass an instance object (e.g. as returned + by `face-property-instance') as an instantiator in place of + an actual instantiator. In such a case, the instantiator used + to create that instance object will be used (for example, if + you set a font-instance object as the value of the 'font + property, then the font name used to create that object will + be used instead). If some cases, however, doing this + conversion does not make sense, and this will be noted in + the documentation for particular types of instance objects. + +If PROPERTY is not a built-in property, then this function will + simply set its value if LOCALE is nil. However, if LOCALE is + given, then this function will attempt to add VALUE as the + instantiator for the given LOCALE, using `add-spec-to-specifier'. + If the value of the property is not a specifier, it will + automatically be converted into a 'generic specifier. + + +The following symbols have predefined meanings: + + foreground The foreground color of the face. + For valid instantiators, see `color-specifier-p'. + + background The background color of the face. + For valid instantiators, see `color-specifier-p'. + + font The font used to display text covered by this face. + For valid instantiators, see `font-specifier-p'. + + display-table The display table of the face. + This should be a vector of 256 elements. + + background-pixmap The pixmap displayed in the background of the face. + Only used by faces on X devices. + For valid instantiators, see `image-specifier-p'. + + underline Underline all text covered by this face. + For valid instantiators, see `face-boolean-specifier-p'. + + strikethru Draw a line through all text covered by this face. + For valid instantiators, see `face-boolean-specifier-p'. + + highlight Highlight all text covered by this face. + Only used by faces on TTY devices. + For valid instantiators, see `face-boolean-specifier-p'. + + dim Dim all text covered by this face. + Only used by faces on TTY devices. + For valid instantiators, see `face-boolean-specifier-p'. + + blinking Blink all text covered by this face. + Only used by faces on TTY devices. + For valid instantiators, see `face-boolean-specifier-p'. + + reverse Reverse the foreground and background colors. + Only used by faces on TTY devices. + For valid instantiators, see `face-boolean-specifier-p'. + + doc-string Description of what the face's normal use is. + NOTE: This is not a specifier, unlike all + the other built-in properties, and cannot + contain locale-specific values." + + (setq face (get-face face)) + (if (memq property built-in-face-specifiers) + (set-specifier (get face property) value locale tag-set how-to-add) + + ;; This section adds user defined properties. + (if (not locale) + (put face property value) + (convert-face-property-into-specifier face property) + (add-spec-to-specifier (get face property) value locale tag-set + how-to-add))) + value) + +(defun remove-face-property (face property &optional locale tag-set exact-p) + "Remove a property from a face. +For built-in properties, this is analogous to `remove-specifier'. +See `remove-specifier' for the meaning of the LOCALE, TAG-SET, and EXACT-P +arguments." + (or locale (setq locale 'all)) + (if (memq property built-in-face-specifiers) + (remove-specifier (face-property face property) locale tag-set exact-p) + (if (eq locale 'all) + (remprop (get-face face) property) + (convert-face-property-into-specifier face property) + (remove-specifier (face-property face property) locale tag-set + exact-p)))) + +(defun reset-face (face &optional locale tag-set exact-p) + "Clear all existing built-in specifications from FACE. +This makes FACE inherit all its display properties from 'default. +WARNING: Be absolutely sure you want to do this!!! It is a dangerous +operation and is not undoable. + +The arguments LOCALE, TAG-SET and EXACT-P are the same as for +`remove-specifier'." + (mapc (lambda (x) + (remove-specifier (face-property face x) locale tag-set exact-p)) + built-in-face-specifiers) + nil) + +(defun set-face-parent (face parent &optional locale tag-set how-to-add) + "Set the parent of FACE to PARENT, for all properties. +This makes all properties of FACE inherit from PARENT." + (setq parent (get-face parent)) + (mapcar (lambda (x) + (set-face-property face x (vector parent) locale tag-set + how-to-add)) + (delq 'display-table + (delq 'background-pixmap + (copy-sequence built-in-face-specifiers)))) + (set-face-background-pixmap face (vector 'inherit ':face parent) + locale tag-set how-to-add) + nil) + +(defun face-doc-string (face) + "Return the documentation string for FACE." + (face-property face 'doc-string)) + +(defun set-face-doc-string (face doc-string) + "Change the documentation string of FACE to DOC-STRING." + (interactive (face-interactive "doc-string")) + (set-face-property face 'doc-string doc-string)) + +(defun face-font-name (face &optional domain charset) + "Return the font name of the given face, or nil if it is unspecified. +DOMAIN is as in `face-font-instance'." + (let ((f (face-font-instance face domain charset))) + (and f (font-instance-name f)))) + +(defun face-font (face &optional locale tag-set exact-p) + "Return the font of the given face, or nil if it is unspecified. + +FACE may be either a face object or a symbol representing a face. + +LOCALE may be a locale (the instantiators for that particular locale + will be returned), a locale type (the specifications for all locales + of that type will be returned), 'all (all specifications will be + returned), or nil (the actual specifier object will be returned). + +See `face-property' for more information." + (face-property face 'font locale tag-set exact-p)) + +(defun face-font-instance (face &optional domain charset) + "Return the instance of the given face's font in the given domain. + +FACE may be either a face object or a symbol representing a face. + +Normally DOMAIN will be a window or nil (meaning the selected window), + and an instance object describing how the font appears in that + particular window and buffer will be returned. + +See `face-property-instance' for more information." + (if charset + (face-property-matching-instance face 'font charset domain) + (face-property-instance face 'font domain))) + +(defun set-face-font (face font &optional locale tag-set how-to-add) + "Change the font of the given face. + +FACE may be either a face object or a symbol representing a face. + +FONT should be an instantiator (see `font-specifier-p'), a list of + instantiators, an alist of specifications (each mapping a + locale to an instantiator list), or a font specifier object. + +If FONT is an alist, LOCALE must be omitted. If FONT is a + specifier object, LOCALE can be a locale, a locale type, 'all, + or nil; see `copy-specifier' for its semantics. Otherwise LOCALE + specifies the locale under which the specified instantiator(s) + will be added, and defaults to 'global. + +See `set-face-property' for more information." + (interactive (face-interactive "font")) + (set-face-property face 'font font locale tag-set how-to-add)) + +(defun face-foreground (face &optional locale tag-set exact-p) + "Return the foreground of the given face, or nil if it is unspecified. + +FACE may be either a face object or a symbol representing a face. + +LOCALE may be a locale (the instantiators for that particular locale + will be returned), a locale type (the specifications for all locales + of that type will be returned), 'all (all specifications will be + returned), or nil (the actual specifier object will be returned). + +See `face-property' for more information." + (face-property face 'foreground locale tag-set exact-p)) + +(defun face-foreground-instance (face &optional domain default no-fallback) + "Return the instance of the given face's foreground in the given domain. + +FACE may be either a face object or a symbol representing a face. + +Normally DOMAIN will be a window or nil (meaning the selected window), + and an instance object describing how the foreground appears in that + particular window and buffer will be returned. + +See `face-property-instance' for more information." + (face-property-instance face 'foreground domain default no-fallback)) + +(defun face-foreground-name (face &optional domain default no-fallback) + "Return the name of the given face's foreground color in the given domain. + +FACE may be either a face object or a symbol representing a face. + +Normally DOMAIN will be a window or nil (meaning the selected window), + and an instance object describing how the background appears in that + particular window and buffer will be returned. + +See `face-property-instance' for more information." + (color-instance-name (face-foreground-instance + face domain default no-fallback))) + +(defun set-face-foreground (face color &optional locale tag-set how-to-add) + "Change the foreground of the given face. + +FACE may be either a face object or a symbol representing a face. + +COLOR should be an instantiator (see `color-specifier-p'), a list of + instantiators, an alist of specifications (each mapping a locale to + an instantiator list), or a color specifier object. + +If COLOR is an alist, LOCALE must be omitted. If COLOR is a + specifier object, LOCALE can be a locale, a locale type, 'all, + or nil; see `copy-specifier' for its semantics. Otherwise LOCALE + specifies the locale under which the specified instantiator(s) + will be added, and defaults to 'global. + +See `set-face-property' for more information." + (interactive (face-interactive "foreground")) + (set-face-property face 'foreground color locale tag-set how-to-add)) + +(defun face-background (face &optional locale tag-set exact-p) + "Return the background of the given face, or nil if it is unspecified. + +FACE may be either a face object or a symbol representing a face. + +LOCALE may be a locale (the instantiators for that particular locale + will be returned), a locale type (the specifications for all locales + of that type will be returned), 'all (all specifications will be + returned), or nil (the actual specifier object will be returned). + +See `face-property' for more information." + (face-property face 'background locale tag-set exact-p)) + +(defun face-background-instance (face &optional domain default no-fallback) + "Return the instance of the given face's background in the given domain. + +FACE may be either a face object or a symbol representing a face. + +Normally DOMAIN will be a window or nil (meaning the selected window), + and an instance object describing how the background appears in that + particular window and buffer will be returned. + +See `face-property-instance' for more information." + (face-property-instance face 'background domain default no-fallback)) + +(defun face-background-name (face &optional domain default no-fallback) + "Return the name of the given face's background color in the given domain. + +FACE may be either a face object or a symbol representing a face. + +Normally DOMAIN will be a window or nil (meaning the selected window), + and an instance object describing how the background appears in that + particular window and buffer will be returned. + +See `face-property-instance' for more information." + (color-instance-name (face-background-instance + face domain default no-fallback))) + +(defun set-face-background (face color &optional locale tag-set how-to-add) + "Change the background of the given face. + +FACE may be either a face object or a symbol representing a face. + +COLOR should be an instantiator (see `color-specifier-p'), a list of + instantiators, an alist of specifications (each mapping a locale to + an instantiator list), or a color specifier object. + +If COLOR is an alist, LOCALE must be omitted. If COLOR is a + specifier object, LOCALE can be a locale, a locale type, 'all, + or nil; see `copy-specifier' for its semantics. Otherwise LOCALE + specifies the locale under which the specified instantiator(s) + will be added, and defaults to 'global. + +See `set-face-property' for more information." + (interactive (face-interactive "background")) + (set-face-property face 'background color locale tag-set how-to-add)) + +(defun face-background-pixmap (face &optional locale tag-set exact-p) + "Return the background pixmap of the given face, or nil if it is unspecified. +This property is only used on X devices. + +FACE may be either a face object or a symbol representing a face. + +LOCALE may be a locale (the instantiators for that particular locale + will be returned), a locale type (the specifications for all locales + of that type will be returned), 'all (all specifications will be + returned), or nil (the actual specifier object will be returned). + +See `face-property' for more information." + (face-property face 'background-pixmap locale tag-set exact-p)) + +(defun face-background-pixmap-instance (face &optional domain default + no-fallback) + "Return the instance of the given face's background pixmap in the given domain. + +FACE may be either a face object or a symbol representing a face. + +Normally DOMAIN will be a window or nil (meaning the selected window), + and an instance object describing how the background appears in that + particular window and buffer will be returned. + +See `face-property-instance' for more information." + (face-property-instance face 'background-pixmap domain default no-fallback)) + +(defun set-face-background-pixmap (face pixmap &optional locale tag-set + how-to-add) + "Change the background pixmap of the given face. +This property is only used on X devices. + +FACE may be either a face object or a symbol representing a face. + +PIXMAP should be an instantiator (see `image-specifier-p'), a list + of instantiators, an alist of specifications (each mapping a locale + to an instantiator list), or an image specifier object. + +If PIXMAP is an alist, LOCALE must be omitted. If PIXMAP is a + specifier object, LOCALE can be a locale, a locale type, 'all, + or nil; see `copy-specifier' for its semantics. Otherwise LOCALE + specifies the locale under which the specified instantiator(s) + will be added, and defaults to 'global. + +See `set-face-property' for more information." + (interactive (face-interactive "background-pixmap")) + (set-face-property face 'background-pixmap pixmap locale tag-set how-to-add)) + +(defun face-display-table (face &optional locale tag-set exact-p) + "Return the display table of the given face. + +A vector (as returned by `make-display-table') will be returned. + +LOCALE may be a locale (the instantiators for that particular locale + will be returned), a locale type (the specifications for all locales + of that type will be returned), 'all (all specifications will be + returned), or nil (the actual specifier object will be returned). + +See `face-property' for more information." + (face-property face 'display-table locale tag-set exact-p)) + +(defun face-display-table-instance (face &optional domain default no-fallback) + "Return the instance of FACE's display table in DOMAIN. +A vector (as returned by `make-display-table') will be returned. + +See `face-property-instance' for the semantics of the DOMAIN argument." + (face-property-instance face 'display-table domain default no-fallback)) + +(defun set-face-display-table (face display-table &optional locale tag-set + how-to-add) + "Change the display table of the given face. +DISPLAY-TABLE should be a vector as returned by `make-display-table'. + +See `set-face-property' for the semantics of the LOCALE, TAG-SET, and + HOW-TO-ADD arguments." + (interactive (face-interactive "display-table")) + (set-face-property face 'display-table display-table locale tag-set + how-to-add)) + +;; The following accessors and mutators are, IMHO, good +;; implementation. Cf. with `make-face-bold'. + +(defun face-underline-p (face &optional domain default no-fallback) + "Return whether the given face is underlined. +See `face-property-instance' for the semantics of the DOMAIN argument." + (face-property-instance face 'underline domain default no-fallback)) + +(defun set-face-underline-p (face underline-p &optional locale tag-set + how-to-add) + "Change whether the given face is underlined. +UNDERLINE-P is normally a face-boolean instantiator; see + `face-boolean-specifier-p'. +See `set-face-property' for the semantics of the LOCALE, TAG-SET, and + HOW-TO-ADD arguments." + (interactive (face-interactive "underline-p" "underlined")) + (set-face-property face 'underline underline-p locale tag-set how-to-add)) + +(defun face-strikethru-p (face &optional domain default no-fallback) + "Return whether the given face is strikethru-d (i.e. struck through). +See `face-property-instance' for the semantics of the DOMAIN argument." + (face-property-instance face 'strikethru domain default no-fallback)) + +(defun set-face-strikethru-p (face strikethru-p &optional locale tag-set + how-to-add) + "Change whether the given face is strikethru-d (i.e. struck through). +STRIKETHRU-P is normally a face-boolean instantiator; see + `face-boolean-specifier-p'. +See `set-face-property' for the semantics of the LOCALE, TAG-SET, and + HOW-TO-ADD arguments." + (interactive (face-interactive "strikethru-p" "strikethru-d")) + (set-face-property face 'strikethru strikethru-p locale tag-set how-to-add)) + +(defun face-highlight-p (face &optional domain default no-fallback) + "Return whether the given face is highlighted (TTY domains only). +See `face-property-instance' for the semantics of the DOMAIN argument." + (face-property-instance face 'highlight domain default no-fallback)) + +(defun set-face-highlight-p (face highlight-p &optional locale tag-set + how-to-add) + "Change whether the given face is highlighted (TTY locales only). +HIGHLIGHT-P is normally a face-boolean instantiator; see + `face-boolean-specifier-p'. +See `set-face-property' for the semantics of the LOCALE, TAG-SET, and + HOW-TO-ADD arguments." + (interactive (face-interactive "highlight-p" "highlighted")) + (set-face-property face 'highlight highlight-p locale tag-set how-to-add)) + +(defun face-dim-p (face &optional domain default no-fallback) + "Return whether the given face is dimmed (TTY domains only). +See `face-property-instance' for the semantics of the DOMAIN argument." + (face-property-instance face 'dim domain default no-fallback)) + +(defun set-face-dim-p (face dim-p &optional locale tag-set how-to-add) + "Change whether the given face is dimmed (TTY locales only). +DIM-P is normally a face-boolean instantiator; see + `face-boolean-specifier-p'. +See `set-face-property' for the semantics of the LOCALE, TAG-SET, and + HOW-TO-ADD arguments." + (interactive (face-interactive "dim-p" "dimmed")) + (set-face-property face 'dim dim-p locale tag-set how-to-add)) + +(defun face-blinking-p (face &optional domain default no-fallback) + "Return whether the given face is blinking (TTY domains only). +See `face-property-instance' for the semantics of the DOMAIN argument." + (face-property-instance face 'blinking domain default no-fallback)) + +(defun set-face-blinking-p (face blinking-p &optional locale tag-set + how-to-add) + "Change whether the given face is blinking (TTY locales only). +BLINKING-P is normally a face-boolean instantiator; see + `face-boolean-specifier-p'. +See `set-face-property' for the semantics of the LOCALE, TAG-SET, and + HOW-TO-ADD arguments." + (interactive (face-interactive "blinking-p" "blinking")) + (set-face-property face 'blinking blinking-p locale tag-set how-to-add)) + +(defun face-reverse-p (face &optional domain default no-fallback) + "Return whether the given face is reversed (TTY domains only). +See `face-property-instance' for the semantics of the DOMAIN argument." + (face-property-instance face 'reverse domain default no-fallback)) + +(defun set-face-reverse-p (face reverse-p &optional locale tag-set how-to-add) + "Change whether the given face is reversed (TTY locales only). +REVERSE-P is normally a face-boolean instantiator; see + `face-boolean-specifier-p'. +See `set-face-property' for the semantics of the LOCALE, TAG-SET, and + HOW-TO-ADD arguments." + (interactive (face-interactive "reverse-p" "reversed")) + (set-face-property face 'reverse reverse-p locale tag-set how-to-add)) + + +(defun face-property-equal (face1 face2 prop domain) + (equal (face-property-instance face1 prop domain) + (face-property-instance face2 prop domain))) + +(defun face-equal-loop (props face1 face2 domain) + (while (and props + (face-property-equal face1 face2 (car props) domain)) + (setq props (cdr props))) + (null props)) + +(defun face-equal (face1 face2 &optional domain) + "True if the given faces will display in the same way. +See `face-property-instance' for the semantics of the DOMAIN argument." + (if (null domain) (setq domain (selected-window))) + (if (not (valid-specifier-domain-p domain)) + (error "Invalid specifier domain")) + (let ((device (dfw-device domain)) + (common-props '(foreground background font display-table underline)) + (x-props '(background-pixmap strikethru)) + (tty-props '(highlight dim blinking reverse))) + + ;; First check the properties which are used in common between the + ;; x and tty devices. Then, check those properties specific to + ;; the particular device type. + (and (face-equal-loop common-props face1 face2 domain) + (cond ((eq 'tty (device-type device)) + (face-equal-loop tty-props face1 face2 domain)) + ((eq 'x (device-type device)) + (face-equal-loop x-props face1 face2 domain)) + (t t))))) + +(defun face-differs-from-default-p (face &optional domain) + "True if the given face will display differently from the default face. +See `face-property-instance' for the semantics of the DOMAIN argument." + (not (face-equal face 'default domain))) + + +;; This function is a terrible, disgusting hack!!!! Need to +;; separate out the font elements as separate face properties! + +;; WE DEMAND LEXICAL SCOPING!!! +;; WE DEMAND LEXICAL SCOPING!!! +;; WE DEMAND LEXICAL SCOPING!!! +;; WE DEMAND LEXICAL SCOPING!!! +;; WE DEMAND LEXICAL SCOPING!!! +;; WE DEMAND LEXICAL SCOPING!!! +;; WE DEMAND LEXICAL SCOPING!!! +;; WE DEMAND LEXICAL SCOPING!!! +;; WE DEMAND LEXICAL SCOPING!!! +;; WE DEMAND LEXICAL SCOPING!!! +;; WE DEMAND LEXICAL SCOPING!!! +;; WE DEMAND LEXICAL SCOPING!!! +;; WE DEMAND LEXICAL SCOPING!!! +;; WE DEMAND LEXICAL SCOPING!!! +;; WE DEMAND LEXICAL SCOPING!!! +(defun frob-face-property (face property func &optional locale) + "Change the specifier for FACE's PROPERTY according to FUNC, in LOCALE. +This function is ugly and messy and is primarily used as an internal +helper function for `make-face-bold' et al., so you probably don't +want to use it or read the rest of the documentation. But if you do ... + +FUNC should be a function of two arguments (an instance and a device) +that returns a modified name that is valid for the given device. +If LOCALE specifies a valid domain (i.e. a window, frame, or device), +this function instantiates the specifier over that domain, applies FUNC +to the resulting instance, and adds the result back as an instantiator +for that locale. Otherwise, LOCALE should be a locale, locale type, or +'all (defaults to 'all if omitted). For each specification thusly +included: if the locale given is a valid domain, FUNC will be +iterated over all valid instantiators for the device of the domain +until a non-nil result is found (if there is no such result, the +first valid instantiator is used), and that result substituted for +the specification; otherwise, the process just outlined is +iterated over each existing device and the concatenated results +substituted for the specification." + (let ((sp (face-property face property))) + (if (valid-specifier-domain-p locale) + ;; this is easy. + (let* ((inst (face-property-instance face property locale)) + (name (and inst (funcall func inst (dfw-device locale))))) + (when name + (add-spec-to-specifier sp name locale))) + ;; otherwise, map over all specifications ... + ;; but first, some further kludging: + ;; (1) if we're frobbing the global property, make sure + ;; that something is there (copy from the default face, + ;; if necessary). Otherwise, something like + ;; (make-face-larger 'modeline) + ;; won't do anything at all if the modeline simply + ;; inherits its font from 'default. + ;; (2) if we're frobbing a particular locale, nothing would + ;; happen if that locale has no instantiators. So signal + ;; an error to indicate this. + (if (and (or (eq locale 'global) (eq locale 'all) (not locale)) + (not (face-property face property 'global))) + (copy-specifier (face-property 'default property) + (face-property face property) + 'global)) + (if (and (valid-specifier-locale-p locale) + (not (face-property face property locale))) + (error "Property must have a specification in locale %S" locale)) + (map-specifier + sp + (lambda (sp locale inst-list func) + (let* ((device (dfw-device locale)) + ;; if a device can be derived from the locale, + ;; call frob-face-property-1 for that device. + ;; Otherwise map frob-face-property-1 over each device. + (result + (if device + (list (frob-face-property-1 sp device inst-list func)) + (mapcar (lambda (device) + (frob-face-property-1 sp device + inst-list func)) + (device-list)))) + new-result) + ;; remove duplicates and nils from the obtained list of + ;; instantiators. + (mapcar (lambda (arg) + (when (and arg (not (member arg new-result))) + (setq new-result (cons arg new-result)))) + result) + ;; add back in. + (add-spec-list-to-specifier sp (list (cons locale new-result))) + ;; tell map-specifier to keep going. + nil)) + locale + func)))) + +(defun frob-face-property-1 (sp device inst-list func) + (let + (first-valid result) + (while (and inst-list (not result)) + (let* ((inst-pair (car inst-list)) + (tag-set (car inst-pair)) + (sp-inst (specifier-instance-from-inst-list + sp device (list inst-pair)))) + (if sp-inst + (progn + (if (not first-valid) + (setq first-valid inst-pair)) + (setq result (funcall func sp-inst device)) + (if result + (setq result (cons tag-set result)))))) + (setq inst-list (cdr inst-list))) + (or result first-valid))) + +(defun frob-face-font-2 (face locale unfrobbed-face frobbed-face + tty-thunk x-thunk standard-face-mapping) + ;; another kludge to make things more intuitive. If we're + ;; inheriting from a standard face in this locale, frob the + ;; inheritance as appropriate. Else, if, after the first X frobbing + ;; pass, the face hasn't changed and still looks like the standard + ;; unfrobbed face (e.g. 'default), make it inherit from the standard + ;; frobbed face (e.g. 'bold). Regardless of things, do the TTY + ;; frobbing. + + ;; yuck -- The LOCALE argument to make-face-bold is not actually a locale, + ;; but is a "locale, locale-type, or nil for all". So ... do our extra + ;; frobbing only if it's actually a locale; or for nil, do the frobbing + ;; on 'global. This specifier stuff needs some rethinking. + (let* ((the-locale (cond ((null locale) 'global) + ((valid-specifier-locale-p locale) locale) + (t nil))) + (specs (and the-locale (face-font face the-locale nil t))) + (change-it (and specs (cdr (assoc specs standard-face-mapping))))) + (if (and change-it + (not (memq (face-name (find-face face)) + '(default bold italic bold-italic)))) + (progn + (or (equal change-it t) + (set-face-property face 'font change-it the-locale)) + (funcall tty-thunk)) + (let* ((domain (cond ((null the-locale) nil) + ((valid-specifier-domain-p the-locale) the-locale) + ;; OK, this next one is truly a kludge, but + ;; it results in more intuitive behavior most + ;; of the time. (really!) + ((or (eq the-locale 'global) (eq the-locale 'all)) + (selected-device)) + (t nil))) + (inst (and domain (face-property-instance face 'font domain)))) + (funcall tty-thunk) + (funcall x-thunk) + ;; If it's reasonable to do the inherit-from-standard-face trick, + ;; and it's called for, then do it now. + (or (null domain) + (not (equal inst (face-property-instance face 'font domain))) + ;; don't do it for standard faces, or you'll get inheritance loops. + ;; #### This makes XEmacs seg fault! fix this bug. + (memq (face-name (find-face face)) + '(default bold italic bold-italic)) + (not (equal (face-property-instance face 'font domain) + (face-property-instance unfrobbed-face 'font domain))) + (set-face-property face 'font (vector frobbed-face) + the-locale)))))) + +(defun make-face-bold (face &optional locale) + "Make the face bold, if possible. +This will attempt to make the font bold for X locales and will set the +highlight flag for TTY locales. + +If LOCALE is nil, omitted, or `all', this will attempt to frob all +font specifications for FACE to make them appear bold. Similarly, if +LOCALE is a locale type, this frobs all font specifications for locales +of that type. If LOCALE is a particular locale, what happens depends on +what sort of locale is given. If you gave a device, frame, or window, +then it's always possible to determine what the font actually will be, +so this is determined and the resulting font is frobbed and added back as a +specification for this locale. If LOCALE is a buffer, however, you can't +determine what the font will actually be unless there's actually a +specification given for that particular buffer (otherwise, it depends +on what window and frame the buffer appears in, and might not even be +well-defined if the buffer appears multiple times in different places); +therefore you will get an error unless there's a specification for the +buffer. + +Finally, in some cases (specifically, when LOCALE is not a locale type), +if the frobbing didn't actually make the font look any different +\(this happens, for example, if your font specification is already bold +or has no bold equivalent), and currently looks like the font of the +'default face, it is set to inherit from the 'bold face. This is kludgy +but it makes `make-face-bold' have more intuitive behavior in many +circumstances." + (interactive (list (read-face-name "Make which face bold: "))) + (frob-face-font-2 + face locale 'default 'bold + (lambda () + ;; handle TTY specific entries + (when (featurep 'tty) + (set-face-highlight-p face t locale 'tty))) + (lambda () + ;; handle X specific entries + (cond ((featurep 'x) + (frob-face-property face 'font 'x-make-font-bold locale)) + ((featurep 'w32) + (frob-face-property face 'font 'w32-make-font-bold locale)) + )) + '(([default] . [bold]) + ([bold] . t) + ([italic] . [bold-italic]) + ([bold-italic] . t)))) + +(defun make-face-italic (face &optional locale) + "Make the face italic, if possible. +This will attempt to make the font italic for X locales and will set +the underline flag for TTY locales. +See `make-face-bold' for the semantics of the LOCALE argument and +for more specifics on exactly how this function works." + (interactive (list (read-face-name "Make which face italic: "))) + (frob-face-font-2 + face locale 'default 'italic + (lambda () + ;; handle TTY specific entries + (when (featurep 'tty) + (set-face-underline-p face t locale 'tty))) + (lambda () + ;; handle X specific entries + (cond ((featurep 'x) + (frob-face-property face 'font 'x-make-font-italic locale)) + ((featurep 'w32) + (frob-face-property face 'font 'w32-make-font-italic locale)) + )) + '(([default] . [italic]) + ([bold] . [bold-italic]) + ([italic] . t) + ([bold-italic] . t)))) + +(defun make-face-bold-italic (face &optional locale) + "Make the face bold and italic, if possible. +This will attempt to make the font bold-italic for X locales and will +set the highlight and underline flags for TTY locales. +See `make-face-bold' for the semantics of the LOCALE argument and +for more specifics on exactly how this function works." + (interactive (list (read-face-name "Make which face bold-italic: "))) + (frob-face-font-2 + face locale 'default 'bold-italic + (lambda () + ;; handle TTY specific entries + (when (featurep 'tty) + (set-face-highlight-p face t locale 'tty) + (set-face-underline-p face t locale 'tty))) + (lambda () + ;; handle X specific entries + (cond ((featurep 'x) + (frob-face-property face 'font 'x-make-font-bold-italic locale)) + ((featurep 'w32) + (frob-face-property face 'font 'w32-make-font-bold-italic locale)) + )) + '(([default] . [italic]) + ([bold] . [bold-italic]) + ([italic] . [bold-italic]) + ([bold-italic] . t)))) + +(defun make-face-unbold (face &optional locale) + "Make the face non-bold, if possible. +This will attempt to make the font non-bold for X locales and will +unset the highlight flag for TTY locales. +See `make-face-bold' for the semantics of the LOCALE argument and +for more specifics on exactly how this function works." + (interactive (list (read-face-name "Make which face non-bold: "))) + (frob-face-font-2 + face locale 'bold 'default + (lambda () + ;; handle TTY specific entries + (when (featurep 'tty) + (set-face-highlight-p face nil locale 'tty))) + (lambda () + ;; handle X specific entries + (cond ((featurep 'x) + (frob-face-property face 'font 'x-make-font-unbold locale)) + ((featurep 'w32) + (frob-face-property face 'font 'w32-make-font-unbold locale)) + )) + '(([default] . t) + ([bold] . [default]) + ([italic] . t) + ([bold-italic] . [italic])))) + +(defun make-face-unitalic (face &optional locale) + "Make the face non-italic, if possible. +This will attempt to make the font non-italic for X locales and will +unset the underline flag for TTY locales. +See `make-face-bold' for the semantics of the LOCALE argument and +for more specifics on exactly how this function works." + (interactive (list (read-face-name "Make which face non-italic: "))) + (frob-face-font-2 + face locale 'italic 'default + (lambda () + ;; handle TTY specific entries + (when (featurep 'tty) + (set-face-underline-p face nil locale 'tty))) + (lambda () + ;; handle X specific entries + (cond ((featurep 'x) + (frob-face-property face 'font 'x-make-font-unitalic locale)) + ((featurep 'w32) + (frob-face-property face 'font 'w32-make-font-unitalic locale)) + )) + '(([default] . t) + ([bold] . t) + ([italic] . [default]) + ([bold-italic] . [bold])))) + + +;; Why do the following two functions lose so badly in so many +;; circumstances? + +(defun make-face-smaller (face &optional locale) + "Make the font of the given face be smaller, if possible. +LOCALE works as in `make-face-bold' et al., but the ``inheriting- +from-the-bold-face'' operations described there are not done +because they don't make sense in this context." + (interactive (list (read-face-name "Shrink which face: "))) + ;; handle X specific entries + (cond ((featurep 'x) + (frob-face-property face 'font 'x-find-smaller-font locale)) + ((featurep 'w32) + (frob-face-property face 'font 'w32-find-smaller-font locale)))) + +(defun make-face-larger (face &optional locale) + "Make the font of the given face be larger, if possible. +See `make-face-smaller' for the semantics of the LOCALE argument." + (interactive (list (read-face-name "Enlarge which face: "))) + ;; handle X specific entries + (cond ((featurep 'x) + (frob-face-property face 'font 'x-find-larger-font locale)) + ((featurep 'w32) + (frob-face-property face 'font 'w32-find-larger-font locale)))) + +(defun invert-face (face &optional locale) + "Swap the foreground and background colors of the face." + (interactive (list (read-face-name "Invert face: "))) + (if (valid-specifier-domain-p locale) + (let ((foreface (face-foreground-instance face locale))) + (set-face-foreground face (face-background-instance face locale) + locale) + (set-face-background face foreface locale)) + (let ((forespec (copy-specifier (face-foreground face) nil locale))) + (copy-specifier (face-background face) (face-foreground face) locale) + (copy-specifier forespec (face-background face) locale)))) + + +;;; Convenience functions + +(defun face-ascent (face &optional domain charset) + "Return the ascent of a face. +See `face-property-instance' for the semantics of the DOMAIN argument." + (font-ascent (face-font face) domain charset)) + +(defun face-descent (face &optional domain charset) + "Return the descent of a face. +See `face-property-instance' for the semantics of the DOMAIN argument." + (font-descent (face-font face) domain charset)) + +(defun face-width (face &optional domain charset) + "Return the width of a face. +See `face-property-instance' for the semantics of the DOMAIN argument." + (font-width (face-font face) domain charset)) + +(defun face-height (face &optional domain charset) + "Return the height of a face. +See `face-property-instance' for the semantics of the DOMAIN argument." + (+ (face-ascent face domain charset) (face-descent face domain charset))) + +(defun face-proportional-p (face &optional domain charset) + "Return whether FACE is proportional. +See `face-property-instance' for the semantics of the DOMAIN argument." + (font-proportional-p (face-font face) domain charset)) + + +;; Functions that used to be in cus-face.el, but logically go here. + +(defcustom frame-background-mode nil + "*The brightness of the background. +Set this to the symbol dark if your background color is dark, light if +your background is light, or nil (default) if you want Emacs to +examine the brightness for you." + :group 'faces + :type '(choice (choice-item dark) + (choice-item light) + (choice-item :tag "Auto" nil))) + +;; The old variable that many people still have in .emacs files. +(define-obsolete-variable-alias 'custom-background-mode + 'frame-background-mode) + +(defun get-frame-background-mode (frame) + "Detect background mode for FRAME." + (let* ((color-instance (face-background-instance 'default frame)) + (mode (condition-case nil + (if (< (apply '+ (color-instance-rgb-components + color-instance)) 65536) + 'dark 'light) + ;; Here, we get an error on a TTY. As we don't have + ;; a good way of detecting whether a TTY is light or + ;; dark, we'll guess it's dark. + (error 'dark)))) + (set-frame-property frame 'background-mode mode) + mode)) + +(defun extract-custom-frame-properties (frame) + "Return a plist with the frame properties of FRAME used by custom." + (list 'type (or (frame-property frame 'display-type) + (device-type (frame-device frame))) + 'class (device-class (frame-device frame)) + 'background (or frame-background-mode + (frame-property frame 'background-mode) + (get-frame-background-mode frame)))) + +(defcustom init-face-from-resources t + "If non nil, attempt to initialize faces from the resource database." + :group 'faces + :type 'boolean) + +;; Old name, used by custom. Also, FSFmacs name. +(defvaralias 'initialize-face-resources 'init-face-from-resources) + +(defun face-spec-set (face spec &optional frame) + "Set FACE's face attributes according to the first matching entry in SPEC. +If optional FRAME is non-nil, set it for that frame only. +If it is nil, then apply SPEC to each frame individually. +See `defface' for information about SPEC." + (if frame + (progn + (reset-face face frame) + (face-display-set face spec frame) + (init-face-from-resources face frame)) + (let ((frames (relevant-custom-frames))) + (reset-face face) + (face-display-set face spec) + (while frames + (face-display-set face spec (car frames)) + (pop frames)) + (init-face-from-resources face)))) + +(defun face-display-set (face spec &optional frame) + "Set FACE to the attributes to the first matching entry in SPEC. +Iff optional FRAME is non-nil, set it for that frame only. +See `defface' for information about SPEC." + (while spec + (let ((display (caar spec)) + (atts (cadar spec))) + (pop spec) + (when (face-spec-set-match-display display frame) + ;; Avoid creating frame local duplicates of the global face. + (unless (and frame (eq display (get face 'custom-face-display))) + (apply 'face-custom-attributes-set face frame atts)) + (unless frame + (put face 'custom-face-display display)) + (setq spec nil))))) + +(defvar default-custom-frame-properties nil + "The frame properties used for the global faces. +Frames not matching these propertiess should have frame local faces. +The value should be nil, if uninitialized, or a plist otherwise. +See `defface' for a list of valid keys and values for the plist.") + +(defun get-custom-frame-properties (&optional frame) + "Return a plist with the frame properties of FRAME used by custom. +If FRAME is nil, return the default frame properties." + (cond (frame + ;; Try to get from cache. + (let ((cache (frame-property frame 'custom-properties))) + (unless cache + ;; Oh well, get it then. + (setq cache (extract-custom-frame-properties frame)) + ;; and cache it... + (set-frame-property frame 'custom-properties cache)) + cache)) + (default-custom-frame-properties) + (t + (setq default-custom-frame-properties + (extract-custom-frame-properties (selected-frame)))))) + +(defun face-spec-set-match-display (display frame) + "Non-nil iff DISPLAY matches FRAME. +DISPLAY is part of a spec such as can be used in `defface'. +If FRAME is nil, the current FRAME is used." + (if (eq display t) + t + (let* ((props (get-custom-frame-properties frame)) + (type (plist-get props 'type)) + (class (plist-get props 'class)) + (background (plist-get props 'background)) + (match t) + (entries display) + entry req options) + (while (and entries match) + (setq entry (car entries) + entries (cdr entries) + req (car entry) + options (cdr entry) + match (case req + (type (memq type options)) + (class (memq class options)) + (background (memq background options)) + (t (warn "Unknown req `%S' with options `%S'" + req options) + nil)))) + match))) + +(defun relevant-custom-frames () + "List of frames whose custom properties differ from the default." + (let ((relevant nil) + (default (get-custom-frame-properties)) + (frames (frame-list)) + frame) + (while frames + (setq frame (car frames) + frames (cdr frames)) + (unless (equal default (get-custom-frame-properties frame)) + (push frame relevant))) + relevant)) + +(defun initialize-custom-faces (&optional frame) + "Initialize all custom faces for FRAME. +If FRAME is nil or omitted, initialize them for all frames." + (mapc (lambda (symbol) + (let ((spec (or (get symbol 'saved-face) + (get symbol 'face-defface-spec)))) + (when spec + ;; No need to init-face-from-resources -- code in + ;; `init-frame-faces' does it already. + (face-display-set symbol spec frame)))) + (face-list))) + +(defun custom-initialize-frame (frame) + "Initialize frame-local custom faces for FRAME if necessary." + (unless (equal (get-custom-frame-properties) + (get-custom-frame-properties frame)) + (initialize-custom-faces frame))) + + +(defun make-empty-face (name &optional doc-string temporary) + "Like `make-face', but doesn't query the resource database." + (let ((init-face-from-resources nil)) + (make-face name doc-string temporary))) + +(defun init-face-from-resources (face &optional locale) + "Initialize FACE from the resource database. +If LOCALE is specified, it should be a frame, device, or 'global, and +the face will be resourced over that locale. Otherwise, the face will +be resourced over all possible locales (i.e. all frames, all devices, +and 'global)." + (cond ((null init-face-from-resources) + ;; Do nothing. + ) + ((not locale) + ;; Global, set for all frames. + (progn + (init-face-from-resources face 'global) + (let ((devices (device-list))) + (while devices + (init-face-from-resources face (car devices)) + (setq devices (cdr devices)))) + (let ((frames (frame-list))) + (while frames + (init-face-from-resources face (car frames)) + (setq frames (cdr frames)))))) + (t + ;; Specific. + (let ((devtype (cond ((devicep locale) (device-type locale)) + ((framep locale) (frame-type locale)) + (t nil)))) + (cond ((or (and (not devtype) (featurep 'x)) (eq 'x devtype)) + (x-init-face-from-resources face locale)) + ((or (not devtype) (eq 'tty devtype)) + ;; Nothing to do for TTYs? + )))))) + +(defun init-device-faces (device) + ;; First, add any device-local face resources. + (when init-face-from-resources + (loop for face in (face-list) do + (init-face-from-resources face device)) + ;; Then do any device-specific initialization. + (cond ((eq 'x (device-type device)) + (x-init-device-faces device)) + ((eq 'w32 (device-type device)) + (w32-init-device-faces device)) + ;; Nothing to do for TTYs? + ) + (init-other-random-faces device))) + +(defun init-frame-faces (frame) + (when init-face-from-resources + ;; First, add any frame-local face resources. + (loop for face in (face-list) do + (init-face-from-resources face frame)) + ;; Then do any frame-specific initialization. + (cond ((eq 'x (frame-type frame)) + (x-init-frame-faces frame)) + ((eq 'w32 (frame-type frame)) + (w32-init-frame-faces frame)) + ;; Is there anything which should be done for TTY's? + ))) + +;; #### This is somewhat X-specific, and is called when the first +;; X device is created (even if there were TTY devices created +;; beforehand). The concept of resources has not been generalized +;; outside of X-specificness, so we have to live with this +;; breach of device-independence. + +(defun init-global-faces () + ;; Look for global face resources. + (loop for face in (face-list) do + (init-face-from-resources face 'global)) + ;; Further X frobbing. + (x-init-global-faces) + ;; for bold and the like, make the global specification be bold etc. + ;; if the user didn't already specify a value. These will also be + ;; frobbed further in init-other-random-faces. + (unless (face-font 'bold 'global) + (make-face-bold 'bold 'global)) + ;; + (unless (face-font 'italic 'global) + (make-face-italic 'italic 'global)) + ;; + (unless (face-font 'bold-italic 'global) + (make-face-bold-italic 'bold-italic 'global) + (unless (face-font 'bold-italic 'global) + (copy-face 'bold 'bold-italic) + (make-face-italic 'bold-italic))) + + (when (face-equal 'bold 'bold-italic) + (copy-face 'italic 'bold-italic) + (make-face-bold 'bold-italic)) + ;; + ;; Nothing more to be done for X or TTY's? + ) + + +;; These warnings are there for a reason. Just specify your fonts +;; correctly. Deal with it. Additionally, one can use +;; `log-warning-minimum-level' instead of this. +;(defvar inhibit-font-complaints nil +; "Whether to suppress complaints about incomplete sets of fonts.") + +(defun face-complain-about-font (face device) + (if (symbolp face) (setq face (symbol-name face))) +;; (if (not inhibit-font-complaints) + (display-warning + 'font + (let ((default-name (face-font-name 'default device))) + (format "%s: couldn't deduce %s %s version of the font +%S. + +Please specify X resources to make the %s face +visually distinguishable from the default face. +For example, you could add one of the following to $HOME/Emacs: + +Emacs.%s.attributeFont: -dt-*-medium-i-* +or +Emacs.%s.attributeForeground: hotpink\n" + invocation-name + (if (string-match "\\`[aeiouAEIOU]" face) "an" "a") + face + default-name + face + face + face + )))) + + +;; #### This is quite a mess. We should use the custom mechanism for +;; most of this stuff. Currently we don't do it, because Custom +;; doesn't use specifiers (yet.) FSF does it the Right Way. + +;; For instance, the definition of `bold' should be something like +;; (defface bold ((t (:bold t))) "Bold text.") -- and `:bold t' should +;; make sure that everything works properly. + +(defun init-other-random-faces (device) + "Initializes the colors and fonts of the bold, italic, bold-italic, +zmacs-region, list-mode-item-selected, highlight, primary-selection, +secondary-selection, and isearch faces when each device is created. If +you want to add code to do stuff like this, use the create-device-hook." + + ;; try to make 'bold look different from the default on this device. + ;; If that doesn't work at all, then issue a warning. + (unless (face-differs-from-default-p 'bold device) + (make-face-bold 'bold device) + (unless (face-differs-from-default-p 'bold device) + (make-face-unbold 'bold device) + (unless (face-differs-from-default-p 'bold device) + ;; the luser specified one of the bogus font names + (face-complain-about-font 'bold device)))) + + ;; Similar for italic. + ;; It's unreasonable to expect to be able to make a font italic all + ;; the time. For many languages, italic is an alien concept. + ;; Basically, because italic is not a globally meaningful concept, + ;; the use of the italic face should really be oboleted. + + ;; I disagree with above. In many languages, the concept of capital + ;; letters is just as alien, and yet we use them. Italic is here to + ;; stay. -hniksic + + ;; In a Solaris Japanese environment, there just aren't any italic + ;; fonts - period. CDE recognizes this reality, and fonts + ;; -dt-interface user-medium-r-normal-*-*-*-*-*-*-*-*-* don't come + ;; in italic versions. So we first try to make the font bold before + ;; complaining. + (unless (face-differs-from-default-p 'italic device) + (make-face-italic 'italic device) + (unless (face-differs-from-default-p 'italic device) + (make-face-bold 'italic device) + (unless (face-differs-from-default-p 'italic device) + (face-complain-about-font 'italic device)))) + + ;; similar for bold-italic. + (unless (face-differs-from-default-p 'bold-italic device) + (make-face-bold-italic 'bold-italic device) + ;; if we couldn't get a bold-italic version, try just bold. + (unless (face-differs-from-default-p 'bold-italic device) + (make-face-bold 'bold-italic device) + ;; if we couldn't get bold or bold-italic, then that's probably because + ;; the default font is bold, so make the `bold-italic' face be unbold. + (unless (face-differs-from-default-p 'bold-italic device) + (make-face-unbold 'bold-italic device) + (make-face-italic 'bold-italic device) + (unless (face-differs-from-default-p 'bold-italic device) + ;; if that didn't work, try plain italic + ;; (can this ever happen? what the hell.) + (make-face-italic 'bold-italic device) + (unless (face-differs-from-default-p 'bold-italic device) + ;; then bitch and moan. + (face-complain-about-font 'bold-italic device)))))) + + ;; Set the text-cursor colors unless already specified. + (when (and (not (eq 'tty (device-type device))) + (not (face-background 'text-cursor 'global)) + (face-property-equal 'text-cursor 'default 'background device)) + (set-face-background 'text-cursor [default foreground] 'global + nil 'append)) + (when (and (not (eq 'tty (device-type device))) + (not (face-foreground 'text-cursor 'global)) + (face-property-equal 'text-cursor 'default 'foreground device)) + (set-face-foreground 'text-cursor [default background] 'global + nil 'append)) + + ;; Set the secondary-selection color unless already specified. + (unless (or (face-differs-from-default-p 'highlight device) + (face-background 'highlight 'global)) + ;; some older servers don't recognize "darkseagreen2" + (set-face-background 'highlight + '((color . "darkseagreen2") + (color . "green")) + 'global nil 'append) + (set-face-background 'highlight "gray53" 'global 'grayscale 'append)) + (unless (or (face-differs-from-default-p 'highlight device) + (face-background-pixmap 'highlight 'global)) + (set-face-background-pixmap 'highlight [nothing] 'global 'color 'append) + (set-face-background-pixmap 'highlight [nothing] 'global 'grayscale 'append) + (set-face-background-pixmap 'highlight "gray1" 'global 'mono 'append)) + ;; if the highlight face isn't distinguished on this device, + ;; at least try inverting it. + (unless (face-differs-from-default-p 'highlight device) + (invert-face 'highlight device)) + + ;; first time through, set the zmacs-region color if it's not already + ;; specified. + (unless (or (face-differs-from-default-p 'zmacs-region device) + (face-background 'zmacs-region 'global)) + (set-face-background 'zmacs-region "gray65" 'global 'color) + (set-face-background 'zmacs-region "gray65" 'global 'grayscale)) + (unless (or (face-differs-from-default-p 'zmacs-region device) + (face-background-pixmap 'zmacs-region 'global)) + (set-face-background-pixmap 'zmacs-region [nothing] 'global 'color) + (set-face-background-pixmap 'zmacs-region [nothing] 'global 'grayscale) + (set-face-background-pixmap 'zmacs-region "gray3" 'global 'mono)) + ;; if the zmacs-region face isn't distinguished on this device, + ;; at least try inverting it. + (unless (face-differs-from-default-p 'zmacs-region device) + (invert-face 'zmacs-region device)) + + ;; first time through, set the list-mode-item-selected color if it's + ;; not already specified. + (unless (or (face-differs-from-default-p 'list-mode-item-selected device) + (face-background 'list-mode-item-selected 'global)) + (set-face-background 'list-mode-item-selected "gray68" 'global 'color) + (set-face-background 'list-mode-item-selected "gray68" 'global 'grayscale) + (if (featurep 'x) + (unless (face-foreground 'list-mode-item-selected 'global) + (set-face-background 'list-mode-item-selected + [default foreground] 'global '(mono x)) + (set-face-foreground 'list-mode-item-selected + [default background] 'global '(mono x))))) + + ;; if the list-mode-item-selected face isn't distinguished on this device, + ;; at least try inverting it. + (unless (face-differs-from-default-p 'list-mode-item-selected device) + (invert-face 'list-mode-item-selected device)) + + ;; Set the primary-selection color unless already specified. + (unless (or (face-differs-from-default-p 'primary-selection device) + (face-background 'primary-selection 'global)) + (set-face-background 'primary-selection "gray65" 'global 'color) + (set-face-background 'primary-selection "gray65" 'global 'grayscale)) + (unless (or (face-differs-from-default-p 'secondary-selection device) + (face-background-pixmap 'primary-selection 'global)) + (set-face-background-pixmap 'primary-selection "gray3" 'global 'mono)) + ;; If the primary-selection face isn't distinguished on this device, + ;; at least try inverting it. + (unless (face-differs-from-default-p 'primary-selection device) + (invert-face 'primary-selection device)) + + ;; Set the secondary-selection color unless already specified. + (unless (or (face-differs-from-default-p 'secondary-selection device) + (face-background 'secondary-selection 'global)) + (set-face-background 'secondary-selection + '((color . "paleturquoise") + (color . "green")) + 'global) + (set-face-background 'secondary-selection "gray53" 'global + 'grayscale)) + (unless (or (face-differs-from-default-p 'secondary-selection device) + (face-background-pixmap 'secondary-selection 'global)) + (set-face-background-pixmap 'secondary-selection "gray1" 'global 'mono)) + ;; If the secondary-selection face isn't distinguished on this device, + ;; at least try inverting it. + (unless (face-differs-from-default-p 'secondary-selection device) + (invert-face 'secondary-selection device)) + + ;; Set the isearch color if unless already specified. + (unless (or (face-differs-from-default-p 'isearch device) + (face-background 'isearch 'global)) + ;; TTY's and some older X servers don't recognize "paleturquoise" + (set-face-background 'isearch + '((color . "paleturquoise") + (color . "green")) + 'global)) + ;; if the isearch face isn't distinguished (e.g. we're not on a color + ;; display), at least try making it bold. + (unless (face-differs-from-default-p 'isearch device) + (set-face-font 'isearch [bold])) + ) + +;; New function with 20.1, suggested by Per Abrahamsen, coded by Kyle Jones. +(defun set-face-stipple (face pixmap &optional frame) + "Change the stipple pixmap of face FACE to PIXMAP. +This is an Emacs compatibility function; consider using +set-face-background-pixmap instead. + +PIXMAP should be a string, the name of a file of pixmap data. +The directories listed in the `x-bitmap-file-path' variable are searched. +Any kind of image file for which XEmacs has builtin support can be used. + +Alternatively, PIXMAP may be a list of the form (WIDTH HEIGHT +DATA) where WIDTH and HEIGHT are the size in pixels, and DATA is +a string, containing the raw bits of the bitmap. XBM data is +expected in this case, other types of image data will not work. + +If the optional FRAME argument is provided, change only +in that frame; otherwise change each frame." + (while (not (find-face face)) + (setq face (signal 'wrong-type-argument (list 'facep face)))) + (while (cond ((stringp pixmap) + (unless (file-readable-p pixmap) + (setq pixmap `[xbm :file ,pixmap])) + nil) + ((and (consp pixmap) (= (length pixmap) 3)) + (setq pixmap `[xbm :data ,pixmap]) + nil) + (t t)) + (setq pixmap (signal 'wrong-type-argument + (list 'stipple-pixmap-p pixmap)))) + (while (and frame (not (framep frame))) + (setq frame (signal 'wrong-type-argument (list 'framep frame)))) + (set-face-background-pixmap face pixmap frame)) + + +;; Create the remaining standard faces now. This way, packages that we dump +;; can reference these faces as parents. +;; +;; The default, modeline, left-margin, right-margin, text-cursor, +;; and pointer faces are created in C. + +(make-face 'bold "Bold text.") +(make-face 'italic "Italic text.") +(make-face 'bold-italic "Bold-italic text.") +(make-face 'underline "Underlined text.") +(or (face-differs-from-default-p 'underline) + (set-face-underline-p 'underline t 'global)) +(make-face 'zmacs-region "Used on highlightes region between point and mark.") +(make-face 'isearch "Used on region matched by isearch.") +(make-face 'list-mode-item-selected + "Face for the selected list item in list-mode.") +(make-face 'highlight "Highlight face.") +(make-face 'primary-selection "Primary selection face.") +(make-face 'secondary-selection "Secondary selection face.") + +;; Several useful color faces. +(eval-when-compile (load "cl-macs")) +(dolist (color '(red green blue yellow)) + (make-face color (concat (symbol-name color) " text.")) + (set-face-foreground color (symbol-name color) nil 'color)) + +;; Make some useful faces. This happens very early, before creating +;; the first non-stream device. We initialize the tty global values here. +;; We cannot initialize the X global values here because they depend +;; on having already resourced the global face specs, which happens +;; when the first X device is created. + +(set-face-background-pixmap 'modeline [nothing]) + +(when (featurep 'tty) + (set-face-highlight-p 'bold t 'global 'tty) + (set-face-underline-p 'italic t 'global 'tty) + (set-face-highlight-p 'bold-italic t 'global 'tty) + (set-face-underline-p 'bold-italic t 'global 'tty) + (set-face-highlight-p 'highlight t 'global 'tty) + (set-face-reverse-p 'text-cursor t 'global 'tty) + (set-face-reverse-p 'modeline t 'global 'tty) + (set-face-reverse-p 'zmacs-region t 'global 'tty) + (set-face-reverse-p 'primary-selection t 'global 'tty) + (set-face-underline-p 'secondary-selection t 'global 'tty) + (set-face-reverse-p 'list-mode-item-selected t 'global 'tty) + (set-face-reverse-p 'isearch t 'global 'tty) + ) + +;;; faces.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/files-nomule.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,96 @@ +;;; files-nomule.el --- file I/O stubs when not under Mule. + +;; Copyright (C) 1985-1987, 1992-1994, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1995 Sun Microsystems. + +;; Maintainer: XEmacs Development Team +;; Keywords: extensions, dumped + +;; 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, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: FSF 19.34 (files.el). (Is it? Please check) + +;;; Commentary: + +;; This file is dumped with XEmacs (when Mule is not compiled in). + +;; These stubs were moved from the bottom of files.el. + +;;; Code: + +(defun insert-file-contents (filename &optional visit beg end replace) + "Insert contents of file FILENAME after point. +Returns list of absolute file name and length of data inserted. +If second argument VISIT is non-nil, the buffer's visited filename +and last save file modtime are set, and it is marked unmodified. +If visiting and the file does not exist, visiting is completed +before the error is signaled. + +The optional third and fourth arguments BEG and END +specify what portion of the file to insert. +If VISIT is non-nil, BEG and END must be nil. +If optional fifth argument REPLACE is non-nil, +it means replace the current buffer contents (in the accessible portion) +with the file contents. This is better than simply deleting and inserting +the whole thing because (1) it preserves some marker positions +and (2) it puts less data in the undo list." + (insert-file-contents-internal filename visit beg end replace nil nil)) + +(defun write-region (start end filename &optional append visit lockname coding-system) + "Write current region into specified file. +By default, the file's existing contents are replaced by the specified region. +When called from a program, takes three arguments: +START, END and FILENAME. START and END are buffer positions. +Optional fourth argument APPEND if non-nil means + append to existing file contents (if any). +Optional fifth argument VISIT if t means + set the last-save-file-modtime of buffer to this file's modtime + and mark buffer not modified. +If VISIT is a string, it is a second file name; + the output goes to FILENAME, but the buffer is marked as visiting VISIT. + VISIT is also the file name to lock and unlock for clash detection. +If VISIT is neither t nor nil nor a string, + that means do not print the \"Wrote file\" message. +The optional sixth arg LOCKNAME, if non-nil, specifies the name to + use for locking and unlocking, overriding FILENAME and VISIT. +Kludgy feature: if START is a string, then that string is written +to the file, instead of any buffer contents, and END is ignored. +Optional seventh argument CODING-SYSTEM is meaningful only if support + for Mule is present in XEmacs and specifies the coding system + used to encode the text when it is written out, and defaults to + the value of `buffer-file-coding-system' in the current buffer. + When Mule support is not present, the CODING-SYSTEM argument is + ignored." + (interactive "r\nFWrite region to file: ") + (write-region-internal start end filename append visit lockname nil)) + +(defun load (file &optional noerror nomessage nosuffix) + "Execute a file of Lisp code named FILE. +First try FILE with `.elc' appended, then try with `.el', + then try FILE unmodified. +This function searches the directories in `load-path'. +If optional second arg NOERROR is non-nil, + report no error if FILE doesn't exist. +Print messages at start and end of loading unless + optional third arg NOMESSAGE is non-nil (ignored in -batch mode). +If optional fourth arg NOSUFFIX is non-nil, don't try adding + suffixes `.elc' or `.el' to the specified name FILE. +Return t if file exists." + (load-internal file noerror nomessage nosuffix nil nil)) + +;;; files-nomule.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/files.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,3101 @@ +;;; files.el --- file input and output commands for XEmacs. + +;; Copyright (C) 1985-1987, 1992-1995, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1995 Sun Microsystems. + +;; Maintainer: XEmacs Development Team +;; Keywords: extensions, dumped + +;; 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.34 [Partial]. +;;; Warning: Merging this file is tough. Beware. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;; Defines most of XEmacs's file- and directory-handling functions, +;; including basic file visiting, backup generation, link handling, +;; ITS-id version control, load- and write-hook handling, and the like. + +;;; Code: + +;; XEmacs: Avoid compilation warnings. +(defvar coding-system-for-read) +(defvar buffer-file-coding-system) + +(defgroup backup nil + "Backups of edited data files." + :group 'files) + +(defgroup find-file nil + "Finding and editing files." + :group 'files) + + +;; XEmacs: In buffer.c +;(defconst delete-auto-save-files t +; "*Non-nil means delete auto-save file when a buffer is saved or killed.") + +;; FSF has automount-dir-prefix. Our directory-abbrev-alist is more general. +;; note: tmp_mnt bogosity conversion is established in paths.el. +(defcustom directory-abbrev-alist nil + "*Alist of abbreviations for file directories. +A list of elements of the form (FROM . TO), each meaning to replace +FROM with TO when it appears in a directory name. +This replacement is done when setting up the default directory of a +newly visited file. *Every* FROM string should start with \\\\` or ^. + +Use this feature when you have directories which you normally refer to +via absolute symbolic links or to eliminate automounter mount points +from the beginning of your filenames. Make TO the name of the link, +and FROM the name it is linked to." + :type '(repeat (cons :format "%v" + :value ("\\`" . "") + (regexp :tag "From") + (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)) + "*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. + +Renaming means that XEmacs renames the existing file so that it is a +backup file, then writes the buffer into a new file. Any other names +that the old file had will now refer to the backup file. The new file +is owned by you and its group is defaulted. + +Copying means that XEmacs copies the existing file into the backup +file, then writes the buffer on top of the existing file. Any other +names that the old file had will now refer to the new (edited) file. +The file's owner and group are unchanged. + +The choice of renaming or copying is controlled by the variables +`backup-by-copying', `backup-by-copying-when-linked' and +`backup-by-copying-when-mismatch'. See also `backup-inhibited'." + :type 'boolean + :group 'backup) + +;; Do this so that local variables based on the file name +;; are not overridden by the major mode. +(defvar backup-inhibited nil + "Non-nil means don't make a backup, regardless of the other parameters. +This variable is intended for use by making it local to a buffer. +But it is local only if you make it local.") +(put 'backup-inhibited 'permanent-local t) + +(defcustom backup-by-copying nil + "*Non-nil means always use copying to create backup files. +See documentation of variable `make-backup-files'." + :type 'boolean + :group 'backup) + +(defcustom backup-by-copying-when-linked nil + "*Non-nil means use copying to create backups for files with multiple names. +This causes the alternate names to refer to the latest version as edited. +This variable is relevant only if `backup-by-copying' is nil." + :type 'boolean + :group 'backup) + +(defcustom backup-by-copying-when-mismatch nil + "*Non-nil means create backups by copying if this preserves owner or group. +Renaming may still be used (subject to control of other variables) +when it would not result in changing the owner or group of the file; +that is, for files which are owned by you and whose group matches +the default for a new file created there by you. +This variable is relevant only if `backup-by-copying' is nil." + :type 'boolean + :group 'backup) + +(defvar backup-enable-predicate + '(lambda (name) + (or (< (length name) 5) + (not (string-equal "/tmp/" (substring name 0 5))))) + "Predicate that looks at a file name and decides whether to make backups. +Called with an absolute file name as argument, it returns t to enable backup.") + +(defcustom buffer-offer-save nil + "*Non-nil in a buffer means offer to save the buffer on exit +even if the buffer is not visiting a file. +Automatically local in all buffers." + :type 'boolean + :group 'find-file) +(make-variable-buffer-local 'buffer-offer-save) + +;; FSF uses normal defconst +(defvaralias 'find-file-visit-truename 'find-file-use-truenames) +(defvaralias 'find-file-existing-other-name 'find-file-compare-truenames) + +(defcustom revert-without-query nil + "*Specify which files should be reverted without query. +The value is a list of regular expressions. +If the file name matches one of these regular expressions, +then `revert-buffer' reverts the file without querying +if the file has changed on disk and you have not edited the buffer." + :type '(repeat (regexp "")) + :group 'find-file) + +(defvar buffer-file-number nil + "The device number and file number of the file visited in the current buffer. +The value is a list of the form (FILENUM DEVNUM). +This pair of numbers uniquely identifies the file. +If the buffer is visiting a new file, the value is nil.") +(make-variable-buffer-local 'buffer-file-number) +(put 'buffer-file-number 'permanent-local t) + +(defvar buffer-file-numbers-unique (not (memq system-type '(windows-nt))) + "Non-nil means that buffer-file-number uniquely identifies files.") + +(defcustom file-precious-flag nil + "*Non-nil means protect against I/O errors while saving files. +Some modes set this non-nil in particular buffers. + +This feature works by writing the new contents into a temporary file +and then renaming the temporary file to replace the original. +In this way, any I/O error in writing leaves the original untouched, +and there is never any instant where the file is nonexistent. + +Note that this feature forces backups to be made by copying. +Yet, at the same time, saving a precious file +breaks any hard links between it and other files." + :type 'boolean + :group 'backup) + +(defcustom version-control nil + "*Control use of version numbers for backup files. +t means make numeric backup versions unconditionally. +nil means make them for files that have some already. +`never' means do not make them." + :type 'boolean + :group 'backup + :group 'vc) + +;; This is now defined in efs. +;(defvar dired-kept-versions 2 +; "*When cleaning directory, number of versions to keep.") + +(defcustom delete-old-versions nil + "*If t, delete excess backup versions silently. +If nil, ask confirmation. Any other value prevents any trimming." + :type '(choice (const :tag "Delete" t) + (const :tag "Ask" nil) + (sexp :tag "Leave" :format "%t\n" other)) + :group 'backup) + +(defcustom kept-old-versions 2 + "*Number of oldest versions to keep when a new numbered backup is made." + :type 'integer + :group 'backup) + +(defcustom kept-new-versions 2 + "*Number of newest versions to keep when a new numbered backup is made. +Includes the new backup. Must be > 0" + :type 'integer + :group 'backup) + +(defcustom require-final-newline nil + "*Value of t says silently ensure a file ends in a newline when it is saved. +Non-nil but not t says ask user whether to add a newline when there isn't one. +nil means don't add newlines." + :type '(choice (const :tag "Off" nil) + (const :tag "Add" t) + (sexp :tag "Ask" :format "%t\n" ask)) + :group 'editing-basics) + +(defcustom auto-save-default t + "*Non-nil says by default do auto-saving of every file-visiting buffer." + :type 'boolean + :group 'auto-save) + +(defcustom auto-save-visited-file-name nil + "*Non-nil says auto-save a buffer in the file it is visiting, when practical. +Normally auto-save files are written under other names." + :type 'boolean + :group 'auto-save) + +(defcustom save-abbrevs nil + "*Non-nil means save word abbrevs too when files are saved. +Loading an abbrev file sets this to t." + :type 'boolean + :group 'abbrev) + +(defcustom find-file-run-dired t + "*Non-nil says run dired if `find-file' is given the name of a directory." + :type 'boolean + :group 'find-file) + +;;;It is not useful to make this a local variable. +;;;(put 'find-file-not-found-hooks 'permanent-local t) +(defvar find-file-not-found-hooks nil + "List of functions to be called for `find-file' on nonexistent file. +These functions are called as soon as the error is detected. +`buffer-file-name' is already set up. +The functions are called in the order given until one of them returns non-nil.") + +;;;It is not useful to make this a local variable. +;;;(put 'find-file-hooks 'permanent-local t) +(defvar find-file-hooks nil + "List of functions to be called after a buffer is loaded from a file. +The buffer's local variables (if any) will have been processed before the +functions are called.") + +(defvar write-file-hooks nil + "List of functions to be called before writing out a buffer to a file. +If one of them returns non-nil, the file is considered already written +and the rest are not called. +These hooks are considered to pertain to the visited file. +So this list is cleared if you change the visited file name. +See also `write-contents-hooks' and `continue-save-buffer'.") +;;; However, in case someone does make it local... +(put 'write-file-hooks 'permanent-local t) + +(defvar local-write-file-hooks nil + "Just like `write-file-hooks', except intended for per-buffer use. +The functions in this list are called before the ones in +`write-file-hooks'. + +This variable is meant to be used for hooks that have to do with a +particular visited file. Therefore, it is a permanent local, so that +changing the major mode does not clear it. However, calling +`set-visited-file-name' does clear it.") +(make-variable-buffer-local 'local-write-file-hooks) +(put 'local-write-file-hooks 'permanent-local t) + + +;; #### think about this (added by Sun). +(put 'after-set-visited-file-name-hooks 'permanent-local t) +(defvar after-set-visited-file-name-hooks nil + "List of functions to be called after \\[set-visited-file-name] +or during \\[write-file]. +You can use this hook to restore local values of write-file-hooks, +after-save-hook, and revert-buffer-function, which pertain +to a specific file and therefore are normally killed by a rename. +Put hooks pertaining to the buffer contents on write-contents-hooks +and revert-buffer-insert-file-contents-function.") + +(defvar write-contents-hooks nil + "List of functions to be called before writing out a buffer to a file. +If one of them returns non-nil, the file is considered already written +and the rest are not called. +These hooks are considered to pertain to the buffer's contents, +not to the particular visited file; thus, `set-visited-file-name' does +not clear this variable, but changing the major mode does clear it. +See also `write-file-hooks' and `continue-save-buffer'.") + +;; XEmacs addition +;; Energize needed this to hook into save-buffer at a lower level; we need +;; to provide a new output method, but don't want to have to duplicate all +;; of the backup file and file modes logic.that does not occur if one uses +;; a write-file-hook which returns non-nil. +(put 'write-file-data-hooks 'permanent-local t) +(defvar write-file-data-hooks nil + "List of functions to be called to put the bytes on disk. +These functions receive the name of the file to write to as argument. +The default behavior is to call + (write-region (point-min) (point-max) filename nil t) +If one of them returns non-nil, the file is considered already written +and the rest are not called. +These hooks are considered to pertain to the visited file. +So this list is cleared if you change the visited file name. +See also `write-file-hooks'.") + +(defcustom enable-local-variables t + "*Control use of local-variables lists in files you visit. +The value can be t, nil or something else. +A value of t means local-variables lists are obeyed; +nil means they are ignored; anything else means query. + +The command \\[normal-mode] always obeys local-variables lists +and ignores this variable." + :type '(choice (const :tag "Obey" t) + (const :tag "Ignore" nil) + (sexp :tag "Query" :format "%t\n" other)) + :group 'find-file) + +(defcustom enable-local-eval 'maybe + "*Control processing of the \"variable\" `eval' in a file's local variables. +The value can be t, nil or something else. +A value of t means obey `eval' variables; +nil means ignore them; anything else means query. + +The command \\[normal-mode] always obeys local-variables lists +and ignores this variable." + :type '(choice (const :tag "Obey" t) + (const :tag "Ignore" nil) + (sexp :tag "Query" :format "%t\n" other)) + :group 'find-file) + +;; Avoid losing in versions where CLASH_DETECTION is disabled. +(or (fboundp 'lock-buffer) + (defalias 'lock-buffer 'ignore)) +(or (fboundp 'unlock-buffer) + (defalias 'unlock-buffer 'ignore)) + +;;FSFmacs bastardized ange-ftp cruft +;; This hook function provides support for ange-ftp host name +;; completion. It runs the usual ange-ftp hook, but only for +;; completion operations. Having this here avoids the need +;; to load ange-ftp when it's not really in use. +;(defun ange-ftp-completion-hook-function (op &rest args) +; (if (memq op '(file-name-completion file-name-all-completions)) +; (apply 'ange-ftp-hook-function op args) +; (let ((inhibit-file-name-handlers +; (cons 'ange-ftp-completion-hook-function +; (and (eq inhibit-file-name-operation op) +; inhibit-file-name-handlers))) +; (inhibit-file-name-operation op)) +; (apply op args)) + +(defun convert-standard-filename (filename) + "Convert a standard file's name to something suitable for the current OS. +This function's standard definition is trivial; it just returns the argument. +However, on some systems, the function is redefined +with a definition that really does change some file names." + filename) + +(defun pwd () + "Show the current default directory." + (interactive nil) + (message "Directory %s" default-directory)) + +(defvar cd-path nil + "Value of the CDPATH environment variable, as a list. +Not actually set up until the first time you use it.") + +(defvar path-separator ":" + "Character used to separate concatenated paths.") + +(defun parse-colon-path (cd-path) + "Explode a colon-separated list of paths into a string list." + (and cd-path + (let (cd-list (cd-start 0) cd-colon) + (setq cd-path (concat cd-path path-separator)) + (while (setq cd-colon (string-match path-separator cd-path cd-start)) + (setq cd-list + (nconc cd-list + (list (if (= cd-start cd-colon) + nil + (substitute-in-file-name + (file-name-as-directory + (substring cd-path cd-start cd-colon))))))) + (setq cd-start (+ cd-colon 1))) + cd-list))) + +(defun cd-absolute (dir) + "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))) + ;; XEmacs change: stig@hackvan.com + (if find-file-use-truenames + (setq dir (file-truename dir))) + (setq dir (abbreviate-file-name (expand-file-name dir))) + (cond ((not (file-directory-p dir)) + (error "%s is not a directory" dir)) + ;; this breaks ange-ftp, which doesn't (can't?) overload `file-executable-p'. + ;;((not (file-executable-p dir)) + ;; (error "Cannot cd to %s: Permission denied" dir)) + (t + (setq default-directory dir)))) + +(defun cd (dir) + "Make DIR become the current buffer's default directory. +If your environment includes a `CDPATH' variable, try each one of that +colon-separated list of directories when resolving a relative directory name." + (interactive + ;; XEmacs change? (read-file-name => read-directory-name) + (list (read-directory-name "Change default directory: " + default-directory default-directory + (and (member cd-path '(nil ("./"))) + (null (getenv "CDPATH")))))) + (if (file-name-absolute-p dir) + (cd-absolute (expand-file-name dir)) + ;; XEmacs + (if (null cd-path) + ;;#### Unix-specific + (let ((trypath (parse-colon-path (getenv "CDPATH")))) + (setq cd-path (or trypath (list "./"))))) + (or (catch 'found + (mapcar #'(lambda (x) + (let ((f (expand-file-name (concat x dir)))) + (if (file-directory-p f) + (progn + (cd-absolute f) + (throw 'found t))))) + cd-path) + nil) + ;; jwz: give a better error message to those of us with the + ;; good taste not to use a kludge like $CDPATH. + (if (equal cd-path '("./")) + (error "No such directory: %s" (expand-file-name dir)) + (error "Directory not found in $CDPATH: %s" dir))))) + +(defun load-file (file) + "Load the Lisp file named FILE." + (interactive "fLoad file: ") + (load (expand-file-name file) nil nil t)) + +; We now dump utils/lib-complete.el which has improved versions of this. +;(defun load-library (library) +; "Load the library named LIBRARY. +;This is an interface to the function `load'." +; (interactive "sLoad library: ") +; (load library)) +; +;(defun find-library (library) +; "Find the library of Lisp code named LIBRARY. +;This searches `load-path' for a file named either \"LIBRARY\" or \"LIBRARY.el\"." +; (interactive "sFind library file: ") +; (let ((f (locate-file library load-path ":.el:"))) +; (if f +; (find-file f) +; (error "Couldn't locate library %s" library)))) + +(defun file-local-copy (file &optional buffer) + "Copy the file FILE into a temporary file on this machine. +Returns the name of the local copy, or nil, if FILE is directly +accessible." + (let ((handler (find-file-name-handler file 'file-local-copy))) + (if handler + (funcall handler 'file-local-copy file) + nil))) + +;; XEmacs change block +; We have this in C and use the realpath() system call. + +;(defun file-truename (filename &optional counter prev-dirs) +; "Return the truename of FILENAME, which should be absolute. +;The truename of a file name is found by chasing symbolic links +;both at the level of the file and at the level of the directories +;containing it, until no links are left at any level. +; +;The arguments COUNTER and PREV-DIRS are used only in recursive calls. +;Do not specify them in other calls." +; ;; COUNTER can be a cons cell whose car is the count of how many more links +; ;; to chase before getting an error. +; ;; PREV-DIRS can be a cons cell whose car is an alist +; ;; of truenames we've just recently computed. +; ;; The last test looks dubious, maybe `+' is meant here? --simon. +; (if (or (string= filename "") (string= filename "~") +; (and (string= (substring filename 0 1) "~") +; (string-match "~[^/]*" filename))) +; (progn +; (setq filename (expand-file-name filename)) +; (if (string= filename "") +; (setq filename "/")))) +; (or counter (setq counter (list 100))) +; (let (done +; ;; For speed, remove the ange-ftp completion handler from the list. +; ;; We know it's not needed here. +; ;; For even more speed, do this only on the outermost call. +; (file-name-handler-alist +; (if prev-dirs file-name-handler-alist +; (let ((tem (copy-sequence file-name-handler-alist))) +; (delq (rassq 'ange-ftp-completion-hook-function tem) tem))))) +; (or prev-dirs (setq prev-dirs (list nil))) +; ;; If this file directly leads to a link, process that iteratively +; ;; so that we don't use lots of stack. +; (while (not done) +; (setcar counter (1- (car counter))) +; (if (< (car counter) 0) +; (error "Apparent cycle of symbolic links for %s" filename)) +; (let ((handler (find-file-name-handler filename 'file-truename))) +; ;; For file name that has a special handler, call handler. +; ;; This is so that ange-ftp can save time by doing a no-op. +; (if handler +; (setq filename (funcall handler 'file-truename filename) +; done t) +; (let ((dir (or (file-name-directory filename) default-directory)) +; target dirfile) +; ;; Get the truename of the directory. +; (setq dirfile (directory-file-name dir)) +; ;; If these are equal, we have the (or a) root directory. +; (or (string= dir dirfile) +; ;; If this is the same dir we last got the truename for, +; ;; save time--don't recalculate. +; (if (assoc dir (car prev-dirs)) +; (setq dir (cdr (assoc dir (car prev-dirs)))) +; (let ((old dir) +; (new (file-name-as-directory (file-truename dirfile counter prev-dirs)))) +; (setcar prev-dirs (cons (cons old new) (car prev-dirs))) +; (setq dir new)))) +; (if (equal ".." (file-name-nondirectory filename)) +; (setq filename +; (directory-file-name (file-name-directory (directory-file-name dir))) +; done t) +; (if (equal "." (file-name-nondirectory filename)) +; (setq filename (directory-file-name dir) +; done t) +; ;; Put it back on the file name. +; (setq filename (concat dir (file-name-nondirectory filename))) +; ;; Is the file name the name of a link? +; (setq target (file-symlink-p filename)) +; (if target +; ;; Yes => chase that link, then start all over +; ;; since the link may point to a directory name that uses links. +; ;; We can't safely use expand-file-name here +; ;; since target might look like foo/../bar where foo +; ;; is itself a link. Instead, we handle . and .. above. +; (setq filename +; (if (file-name-absolute-p target) +; target +; (concat dir target)) +; done nil) +; ;; No, we are done! +; (setq done t)))))))) +; filename)) + +;; XEmacs addition. Called from `insert-file-contents-internal' +;; at the appropriate time. +(defun compute-buffer-file-truename (&optional buffer) + "Recomputes BUFFER's value of `buffer-file-truename' +based on the current value of `buffer-file-name'. +BUFFER defaults to the current buffer if unspecified." + (save-excursion + (set-buffer (or buffer (current-buffer))) + (cond ((null buffer-file-name) + (setq buffer-file-truename nil)) + ((setq buffer-file-truename (file-truename buffer-file-name)) + ;; it exists, we're done. + nil) + (t + ;; the file doesn't exist, but maybe the directory does. + (let* ((dir (file-name-directory buffer-file-name)) + (truedir (file-truename dir))) + (if truedir (setq dir truedir)) + (setq buffer-file-truename + (expand-file-name (file-name-nondirectory buffer-file-name) + dir))))) + (if (and find-file-use-truenames buffer-file-truename) + (setq buffer-file-name (abbreviate-file-name buffer-file-truename) + default-directory (file-name-directory buffer-file-name))) + buffer-file-truename)) +;; End XEmacs change block + +(defun file-chase-links (filename) + "Chase links in FILENAME until a name that is not a link. +Does not examine containing directories for links, +unlike `file-truename'." + (let (tem (count 100) (newname filename)) + (while (setq tem (file-symlink-p newname)) + (if (= count 0) + (error "Apparent cycle of symbolic links for %s" filename)) + ;; In the context of a link, `//' doesn't mean what XEmacs thinks. + (while (string-match "//+" tem) + (setq tem (concat (substring tem 0 (1+ (match-beginning 0))) + (substring tem (match-end 0))))) + ;; Handle `..' by hand, since it needs to work in the + ;; target of any directory symlink. + ;; This code is not quite complete; it does not handle + ;; embedded .. in some cases such as ./../foo and foo/bar/../../../lose. + (while (string-match "\\`\\.\\./" tem) ;#### Unix specific + (setq tem (substring tem 3)) + (setq newname (file-name-as-directory + ;; Do the .. by hand. + (directory-file-name + (file-name-directory + ;; Chase links in the default dir of the symlink. + (file-chase-links + (directory-file-name + (file-name-directory newname)))))))) + (setq newname (expand-file-name tem (file-name-directory newname))) + (setq count (1- count))) + newname)) + +(defun switch-to-other-buffer (arg) + "Switch to the previous buffer. With a numeric arg, n, switch to the nth +most recent buffer. With an arg of 0, buries the current buffer at the +bottom of the buffer stack." + (interactive "p") + (if (eq arg 0) + (bury-buffer (current-buffer))) + (switch-to-buffer + (if (<= arg 1) (other-buffer (current-buffer)) + (nth (1+ arg) (buffer-list))))) + +(defun switch-to-buffer-other-window (buffer) + "Select buffer BUFFER in another window." + (interactive "BSwitch to buffer in other window: ") + (let ((pop-up-windows t)) + ;; XEmacs: this used to have (selected-frame) as the third argument, + ;; but this is obnoxious. If the user wants the buffer in a + ;; different frame, then it should be this way. + + ;; Change documented above undone --mrb + (pop-to-buffer buffer t (selected-frame)))) + +(defun switch-to-buffer-other-frame (buffer) + "Switch to buffer BUFFER in a newly-created frame." + (interactive "BSwitch to buffer in other frame: ") + (let* ((name (get-frame-name-for-buffer buffer)) + (frame (make-frame (if name + (list (cons 'name (symbol-name name))))))) + (pop-to-buffer buffer t frame) + (make-frame-visible frame) + buffer)) + +(defun find-file (filename &optional codesys) + "Edit file FILENAME. +Switch to a buffer visiting file FILENAME, +creating one if none already exists. +Under XEmacs/Mule, optional second argument specifies the +coding system to use when decoding the file. Interactively, +with a prefix argument, you will be prompted for the coding system." + (interactive "FFind file: \nZCoding system: ") + (if codesys + (let ((coding-system-for-read + (get-coding-system codesys))) + (switch-to-buffer (find-file-noselect filename))) + (switch-to-buffer (find-file-noselect filename)))) + +(defun find-file-other-window (filename &optional codesys) + "Edit file FILENAME, in another window. +May create a new window, or reuse an existing one. +See the function `display-buffer'. +Under XEmacs/Mule, optional second argument specifies the +coding system to use when decoding the file. Interactively, +with a prefix argument, you will be prompted for the coding system." + (interactive "FFind file in other window: \nZCoding system: ") + (if codesys + (let ((coding-system-for-read + (get-coding-system codesys))) + (switch-to-buffer-other-window (find-file-noselect filename))) + (switch-to-buffer-other-window (find-file-noselect filename)))) + +(defun find-file-other-frame (filename &optional codesys) + "Edit file FILENAME, in a newly-created frame. +Under XEmacs/Mule, optional second argument specifies the +coding system to use when decoding the file. Interactively, +with a prefix argument, you will be prompted for the coding system." + (interactive "FFind file in other frame: \nZCoding system: ") + (if codesys + (let ((coding-system-for-read + (get-coding-system codesys))) + (switch-to-buffer-other-frame (find-file-noselect filename))) + (switch-to-buffer-other-frame (find-file-noselect filename)))) + +(defun find-file-read-only (filename &optional codesys) + "Edit file FILENAME but don't allow changes. +Like \\[find-file] but marks buffer as read-only. +Use \\[toggle-read-only] to permit editing. +Under XEmacs/Mule, optional second argument specifies the +coding system to use when decoding the file. Interactively, +with a prefix argument, you will be prompted for the coding system." + (interactive "fFind file read-only: \nZCoding system: ") + (if codesys + (let ((coding-system-for-read + (get-coding-system codesys))) + (find-file filename)) + (find-file filename)) + (setq buffer-read-only t) + (current-buffer)) + +(defun find-file-read-only-other-window (filename &optional codesys) + "Edit file FILENAME in another window but don't allow changes. +Like \\[find-file-other-window] but marks buffer as read-only. +Use \\[toggle-read-only] to permit editing. +Under XEmacs/Mule, optional second argument specifies the +coding system to use when decoding the file. Interactively, +with a prefix argument, you will be prompted for the coding system." + (interactive "fFind file read-only other window: \nZCoding system: ") + (if codesys + (let ((coding-system-for-read + (get-coding-system codesys))) + (find-file-other-window filename)) + (find-file-other-window filename)) + (setq buffer-read-only t) + (current-buffer)) + +(defun find-file-read-only-other-frame (filename &optional codesys) + "Edit file FILENAME in another frame but don't allow changes. +Like \\[find-file-other-frame] but marks buffer as read-only. +Use \\[toggle-read-only] to permit editing. +Under XEmacs/Mule, optional second argument specifies the +coding system to use when decoding the file. Interactively, +with a prefix argument, you will be prompted for the coding system." + (interactive "fFind file read-only other frame: \nZCoding system: ") + (if codesys + (let ((coding-system-for-read + (get-coding-system codesys))) + (find-file-other-frame filename)) + (find-file-other-frame filename)) + (setq buffer-read-only t) + (current-buffer)) + +(defun find-alternate-file-other-window (filename &optional codesys) + "Find file FILENAME as a replacement for the file in the next window. +This command does not select that window. +Under XEmacs/Mule, optional second argument specifies the +coding system to use when decoding the file. Interactively, +with a prefix argument, you will be prompted for the coding system." + (interactive + (save-selected-window + (other-window 1) + (let ((file buffer-file-name) + (file-name nil) + (file-dir nil)) + (and file + (setq file-name (file-name-nondirectory file) + file-dir (file-name-directory file))) + (list (read-file-name + "Find alternate file: " file-dir nil nil file-name) + (if (and current-prefix-arg (featurep 'mule)) + (read-coding-system "Coding-system: ")))))) + (if (one-window-p) + (find-file-other-window filename) + (save-selected-window + (other-window 1) + (find-alternate-file filename codesys)))) + +(defun find-alternate-file (filename &optional codesys) + "Find file FILENAME, select its buffer, kill previous buffer. +If the current buffer now contains an empty file that you just visited +\(presumably by mistake), use this command to visit the file you really want. +Under XEmacs/Mule, optional second argument specifies the +coding system to use when decoding the file. Interactively, +with a prefix argument, you will be prompted for the coding system." + (interactive + (let ((file buffer-file-name) + (file-name nil) + (file-dir nil)) + (and file + (setq file-name (file-name-nondirectory file) + file-dir (file-name-directory file))) + (list (read-file-name + "Find alternate file: " file-dir nil nil file-name) + (if (and current-prefix-arg (featurep 'mule)) + (read-coding-system "Coding-system: "))))) + (and (buffer-modified-p) (buffer-file-name) + ;; (not buffer-read-only) + (not (yes-or-no-p (format + "Buffer %s is modified; kill anyway? " + (buffer-name)))) + (error "Aborted")) + (let ((obuf (current-buffer)) + (ofile buffer-file-name) + (onum buffer-file-number) + (otrue buffer-file-truename) + (oname (buffer-name))) + (if (get-buffer " **lose**") + (kill-buffer " **lose**")) + (rename-buffer " **lose**") + (setq buffer-file-name nil) + (setq buffer-file-number nil) + (setq buffer-file-truename nil) + (unwind-protect + (progn + (unlock-buffer) + (if codesys + (let ((coding-system-for-read + (get-coding-system codesys))) + (find-file filename)) + (find-file filename))) + (cond ((eq obuf (current-buffer)) + (setq buffer-file-name ofile) + (setq buffer-file-number onum) + (setq buffer-file-truename otrue) + (lock-buffer) + (rename-buffer oname)))) + (or (eq (current-buffer) obuf) + (kill-buffer obuf)))) + +(defun create-file-buffer (filename) + "Create a suitably named buffer for visiting FILENAME, and return it. +FILENAME (sans directory) is used unchanged if that name is free; +otherwise a string <2> or <3> or ... is appended to get an unused name." + (let ((handler (find-file-name-handler filename 'create-file-buffer))) + (if handler + (funcall handler 'create-file-buffer filename) + (let ((lastname (file-name-nondirectory filename))) + (if (string= lastname "") + (setq lastname filename)) + (generate-new-buffer lastname))))) + +(defun generate-new-buffer (name) + "Create and return a buffer with a name based on NAME. +Choose the buffer's name using `generate-new-buffer-name'." + (get-buffer-create (generate-new-buffer-name name))) + +(defvar abbreviated-home-dir nil + "The user's homedir abbreviated according to `directory-abbrev-alist'.") + +(defun abbreviate-file-name (filename &optional hack-homedir) + "Return a version of FILENAME shortened using `directory-abbrev-alist'. +See documentation of variable `directory-abbrev-alist' for more information. +If optional argument HACK-HOMEDIR is non-nil, then this also substitutes +\"~\" for the user's home directory." + (let ((handler (find-file-name-handler filename 'abbreviate-file-name))) + (if handler + (funcall handler 'abbreviate-file-name filename hack-homedir) + ;; Get rid of the prefixes added by the automounter. + ;;(if (and (string-match automount-dir-prefix filename) + ;; (file-exists-p (file-name-directory + ;; (substring filename (1- (match-end 0)))))) + ;; (setq filename (substring filename (1- (match-end 0))))) + (let ((tail directory-abbrev-alist)) + ;; If any elt of directory-abbrev-alist matches this name, + ;; abbreviate accordingly. + (while tail + (if (string-match (car (car tail)) filename) + (setq filename + (concat (cdr (car tail)) (substring filename (match-end 0))))) + (setq tail (cdr tail)))) + (if hack-homedir + (progn + ;; Compute and save the abbreviated homedir name. + ;; We defer computing this until the first time it's needed, to + ;; give time for directory-abbrev-alist to be set properly. + ;; We include a slash at the end, to avoid spurious matches + ;; such as `/usr/foobar' when the home dir is `/usr/foo'. + (or abbreviated-home-dir + (setq abbreviated-home-dir + (let ((abbreviated-home-dir "$foo")) + (concat "\\`" (regexp-quote (abbreviate-file-name + (expand-file-name "~"))) + "\\(/\\|\\'\\)")))) + ;; If FILENAME starts with the abbreviated homedir, + ;; make it start with `~' instead. + (if (and (string-match abbreviated-home-dir filename) + ;; 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)) + (save-match-data + (string-match "^[a-zA-Z]:/$" filename))))) + (setq filename + (concat "~" + (substring filename + (match-beginning 1) (match-end 1)) + (substring filename (match-end 0))))))) + 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." + :type '(repeat (string :tag "Name")) + :group 'find-file) + +;; This function is needed by FSF vc.el. I hope somebody can make it +;; work for XEmacs. -sb. +(defun find-buffer-visiting (filename) + "Return the buffer visiting file FILENAME (a string). +This is like `get-file-buffer', except that it checks for any buffer +visiting the same file, possibly under a different name. +If there is no such live buffer, return nil." + (let ((buf (get-file-buffer filename)) + (truename (abbreviate-file-name (file-truename filename)))) + (or buf + (let ((list (buffer-list)) found) + (while (and (not found) list) + (save-excursion + (set-buffer (car list)) + (if (and buffer-file-name + (string= buffer-file-truename truename)) + (setq found (car list)))) + (setq list (cdr list))) + found) + (let ((number (nthcdr 10 (file-attributes truename))) + (list (buffer-list)) found) + (and buffer-file-numbers-unique + number + (while (and (not found) list) + (save-excursion + (set-buffer (car list)) + (if (and buffer-file-number + (equal buffer-file-number number) + ;; Verify this buffer's file number + ;; still belongs to its file. + (file-exists-p buffer-file-name) + (equal (nthcdr 10 (file-attributes buffer-file-name)) + number)) + (setq found (car list)))) + (setq list (cdr list)))) + found)))) + +(defun insert-file-contents-literally (filename &optional visit beg end replace) + "Like `insert-file-contents', q.v., but only reads in the file. +A buffer may be modified in several ways after reading into the buffer due +to advanced Emacs features, such as file-name-handlers, format decoding, +find-file-hooks, etc. + This function ensures that none of these modifications will take place." + (let ((file-name-handler-alist nil) + (format-alist nil) + (after-insert-file-functions nil) + (find-buffer-file-type-function + (if (fboundp 'find-buffer-file-type) + (symbol-function 'find-buffer-file-type) + nil))) + (unwind-protect + (progn + (fset 'find-buffer-file-type (lambda (filename) t)) + (insert-file-contents filename visit beg end replace)) + (if find-buffer-file-type-function + (fset 'find-buffer-file-type find-buffer-file-type-function) + (fmakunbound 'find-buffer-file-type))))) + +(defun find-file-noselect (filename &optional nowarn rawfile) + "Read file FILENAME into a buffer and return the buffer. +If a buffer exists visiting FILENAME, return that one, but +verify that the file has not changed since visited or saved. +The buffer is not selected, just returned to the caller. +If NOWARN is non-nil, warning messages about several potential +problems will be suppressed." + (setq filename (abbreviate-file-name (expand-file-name filename))) + (if (file-directory-p filename) + (if find-file-run-dired + (dired-noselect (if find-file-use-truenames + (abbreviate-file-name (file-truename filename)) + filename)) + (error "%s is a directory." filename)) + (let* ((buf (get-file-buffer filename)) +; (truename (abbreviate-file-name (file-truename filename))) + (number (nthcdr 10 (file-attributes (file-truename filename)))) +; (number (and buffer-file-truename +; (nthcdr 10 (file-attributes buffer-file-truename)))) +; ;; Find any buffer for a file which has same truename. +; (other (and (not buf) (find-buffer-visiting filename))) + (error nil)) + +; ;; Let user know if there is a buffer with the same truename. +; (if (and (not buf) same-truename (not nowarn)) +; (message "%s and %s are the same file (%s)" +; filename (buffer-file-name same-truename) +; truename) +; (if (and (not buf) same-number (not nowarn)) +; (message "%s and %s are the same file" +; filename (buffer-file-name same-number)))) +; ;; Optionally also find that buffer. +; (if (or find-file-existing-other-name find-file-visit-truename) +; (setq buf (or same-truename same-number))) + + (when (and buf + (or find-file-compare-truenames find-file-use-truenames) + (not nowarn)) + (save-excursion + (set-buffer buf) + (if (not (string-equal buffer-file-name filename)) + (message "%s and %s are the same file (%s)" + filename buffer-file-name + buffer-file-truename)))) + + (if buf + (or nowarn + (verify-visited-file-modtime buf) + (cond ((not (file-exists-p filename)) + (error "File %s no longer exists!" filename)) + ;; Certain files should be reverted automatically + ;; if they have changed on disk and not in the buffer. + ((and (not (buffer-modified-p buf)) + (let (found) + (dolist (rx revert-without-query found) + (when (string-match rx filename) + (setq found t))))) + (with-current-buffer buf + (message "Reverting file %s..." filename) + (revert-buffer t t) + (message "Reverting file %s... done" filename))) + ((yes-or-no-p + (if (string= (file-name-nondirectory filename) + (buffer-name buf)) + (format + (if (buffer-modified-p buf) + (gettext "File %s changed on disk. Discard your edits? ") + (gettext "File %s changed on disk. Reread from disk? ")) + (file-name-nondirectory filename)) + (format + (if (buffer-modified-p buf) + (gettext "File %s changed on disk. Discard your edits in %s? ") + (gettext "File %s changed on disk. Reread from disk into %s? ")) + (file-name-nondirectory filename) + (buffer-name buf)))) + (save-excursion + (set-buffer buf) + (revert-buffer t t))))) + ;; Else: we must create a new buffer for filename + (save-excursion +;;; The truename stuff makes this obsolete. +;;; (let* ((link-name (car (file-attributes filename))) +;;; (linked-buf (and (stringp link-name) +;;; (get-file-buffer link-name)))) +;;; (if (bufferp linked-buf) +;;; (message "Symbolic link to file in buffer %s" +;;; (buffer-name linked-buf)))) + (setq buf (create-file-buffer filename)) + (set-buffer-major-mode buf) + (set-buffer buf) + (erase-buffer) + (if rawfile + (condition-case () + (insert-file-contents-literally filename t) + (file-error + ;; Unconditionally set error + (setq error t))) + (condition-case e + (insert-file-contents filename t) + (file-error + ;; Run find-file-not-found-hooks until one returns non-nil. + (or (run-hook-with-args-until-success 'find-file-not-found-hooks) + ;; If they fail too, set error. + (setq error e))))) + ;; Find the file's truename, and maybe use that as visited name. + ;; automatically computed in XEmacs. +; (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)) +; (if find-file-visit-truename +; (setq buffer-file-name +; (setq filename +; (expand-file-name buffer-file-truename)))) + (and find-file-use-truenames + ;; This should be in C. Put pathname abbreviations that have + ;; been explicitly requested back into the pathname. Most + ;; importantly, strip out automounter /tmp_mnt directories so + ;; that auto-save will work + (setq buffer-file-name (abbreviate-file-name buffer-file-name))) + ;; Set buffer's default directory to that of the file. + (setq default-directory (file-name-directory buffer-file-name)) + ;; Turn off backup files for certain file names. Since + ;; this is a permanent local, the major mode won't eliminate it. + (and (not (funcall backup-enable-predicate buffer-file-name)) + (progn + (make-local-variable 'backup-inhibited) + (setq backup-inhibited t))) + (if rawfile + nil + (after-find-file error (not nowarn)) + (setq buf (current-buffer))))) + buf))) + +(defvar after-find-file-from-revert-buffer nil) + +(defun after-find-file (&optional error warn noauto + after-find-file-from-revert-buffer + nomodes) + "Called after finding a file and by the default revert function. +Sets buffer mode, parses local variables. +Optional args ERROR, WARN, and NOAUTO: ERROR non-nil means there was an +error in reading the file. WARN non-nil means warn if there +exists an auto-save file more recent than the visited file. +NOAUTO means don't mess with auto-save mode. +Fourth arg AFTER-FIND-FILE-FROM-REVERT-BUFFER non-nil + means this call was from `revert-buffer'. +Fifth arg NOMODES non-nil means don't alter the file's modes. +Finishes by calling the functions in `find-file-hooks'." + (setq buffer-read-only (not (file-writable-p buffer-file-name))) + (if noninteractive + nil + (let* (not-serious + (msg + (cond ((and error (file-attributes buffer-file-name)) + (setq buffer-read-only t) + (gettext "File exists, but cannot be read.")) + ((not buffer-read-only) + (if (and warn + (file-newer-than-file-p (make-auto-save-file-name) + buffer-file-name)) + (format "%s has auto save data; consider M-x recover-file" + (setq not-serious t) + (if error (gettext "(New file)") nil)))) + ((not error) + (setq not-serious t) + (gettext "Note: file is write protected")) + ((file-attributes (directory-file-name default-directory)) + (gettext "File not found and directory write-protected")) + ((file-exists-p (file-name-directory buffer-file-name)) + (setq buffer-read-only nil)) + (t + ;; If the directory the buffer is in doesn't exist, + ;; offer to create it. It's better to do this now + ;; than when we save the buffer, because we want + ;; autosaving to work. + (setq buffer-read-only nil) + ;; XEmacs + (or (file-exists-p (file-name-directory buffer-file-name)) + (if (yes-or-no-p + (format + "The directory containing %s does not exist. Create? " + (abbreviate-file-name buffer-file-name))) + (make-directory (file-name-directory + buffer-file-name) + t))) + nil)))) + (if msg + (progn + (message msg) + (or not-serious (sit-for 1 t))))) + (if (and auto-save-default (not noauto)) + (auto-save-mode t))) + (unless nomodes + (normal-mode t) + (run-hooks 'find-file-hooks))) + +(defun normal-mode (&optional find-file) + "Choose the major mode for this buffer automatically. +Also sets up any specified local variables of the file. +Uses the visited file name, the -*- line, and the local variables spec. + +This function is called automatically from `find-file'. In that case, +we may set up specified local variables depending on the value of +`enable-local-variables': if it is t, we do; if it is nil, we don't; +otherwise, we query. `enable-local-variables' is ignored if you +run `normal-mode' explicitly." + (interactive) + (or find-file (funcall (or default-major-mode 'fundamental-mode))) + (and (condition-case err + (progn (set-auto-mode) + t) + (error (message "File mode specification error: %s" + (prin1-to-string err)) + nil)) + (condition-case err + (hack-local-variables (not find-file)) + (error (message "File local-variables error: %s" + (prin1-to-string err)))))) + +(defvar auto-mode-alist + '(("\\.te?xt\\'" . text-mode) + ("\\.[ch]\\'" . c-mode) + ("\\.el\\'" . emacs-lisp-mode) + ("\\.\\([CH]\\|cc\\|hh\\)\\'" . c++-mode) + ("\\.[ch]\\(pp\\|xx\\|\\+\\+\\)\\'" . c++-mode) + ("\\.java\\'" . java-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. + ("\\.p[lm]\\'" . perl-mode) + ("\\.py\\'" . python-mode) + ("\\.texi\\(nfo\\)?\\'" . texinfo-mode) + ("\\.ad[abs]\\'" . ada-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) + ("\\$CHANGE_LOG\\$\\.TXT" . change-log-mode) + ("\\.scm\\(\\.[0-9]*\\)?\\'" . scheme-mode) + ("\\.e\\'" . eiffel-mode) + ("\\.mss\\'" . scribe-mode) + ("\\.m\\([mes]\\|an\\)\\'" . nroff-mode) + ("\\.icn\\'" . icon-mode) + ("\\.\\([ckz]?sh\\|shar\\)\\'" . 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 should 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) + ("\\.bib\\'" . bibtex-mode) + ("\\.article\\'" . text-mode) + ("\\.letter\\'" . text-mode) + ("\\.\\(tcl\\|exp\\)\\'" . tcl-mode) + ("\\.wrl\\'" . vrml-mode) + ("\\.awk\\'" . awk-mode) + ("\\.prolog\\'" . prolog-mode) + ("\\.tar\\'" . tar-mode) + ("\\.\\(arc\\|zip\\|lzh\\|zoo\\)\\'" . archive-mode) + ;; Mailer puts message to be edited in + ;; /tmp/Re.... or Message + ("^/tmp/Re" . text-mode) + ("/Message[0-9]*\\'" . text-mode) + ("/drafts/[0-9]+\\'" . mh-letter-mode) + ;; some news reader is reported to use this + ("^/tmp/fol/" . text-mode) + ("\\.y\\'" . c-mode) + ("\\.lex\\'" . c-mode) + ("\\.m\\'" . objc-mode) + ("\\.oak\\'" . scheme-mode) + ("\\.s?html?\\'" . html-mode) + ("\\.htm?l?3\\'" . html3-mode) + ("\\.\\(sgml?\\|dtd\\)\\'" . sgml-mode) + ("\\.c?ps\\'" . postscript-mode) + ;; .emacs following a directory delimiter + ;; in either Unix or VMS syntax. + ("[]>:/]\\..*emacs\\'" . emacs-lisp-mode) + ;; _emacs following a directory delimiter + ;; in MsDos syntax + ("[:/]_emacs\\'" . emacs-lisp-mode) + ("\\.m4\\'" . autoconf-mode) + ("configure\\.in\\'" . autoconf-mode) + ("\\.ml\\'" . lisp-mode) + ("\\.ma?k\\'" . makefile-mode) + ("[Mm]akefile\\(\\.\\|\\'\\)" . makefile-mode) + ("\\.X\\(defaults\\|environment\\|resources\\|modmap\\)\\'" . xrdb-mode) + ("/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) + ) +"Alist of filename patterns vs. corresponding major mode functions. +Each element looks like (REGEXP . FUNCTION) or (REGEXP FUNCTION NON-NIL). +\(NON-NIL stands for anything that is not nil; the value does not matter.) +Visiting a file whose name matches REGEXP specifies FUNCTION as the +mode function to use. FUNCTION will be called, unless it is nil. + +If the element has the form (REGEXP FUNCTION NON-NIL), then after +calling FUNCTION (if it's not nil), we delete the suffix that matched +REGEXP and search the list again for another match.") + +(defconst interpreter-mode-alist + '(("^#!.*csh" . sh-mode) + ("^#!.*sh\\b" . sh-mode) + ("^#!.*\\b\\(scope\\|wish\\|tcl\\|expect\\)" . tcl-mode) + ("perl" . perl-mode) + ("python" . python-mode) + ("awk\\b" . awk-mode) + ("rexx" . rexx-mode) + ("scm" . scheme-mode) + ("^:" . sh-mode)) + "Alist mapping interpreter names to major modes. +This alist is used to guess the major mode of a file based on the +contents of the first line. This line often contains something like: +#!/bin/sh +but may contain something more imaginative like +#! /bin/env python +or +eval 'exec perl -w -S $0 ${1+\"$@\"}'. + +Each alist element looks like (INTERPRETER . MODE). +The car of each element is a regular expression which is compared +with the name of the interpreter specified in the first line. +If it matches, mode MODE is selected.") + +(defconst inhibit-first-line-modes-regexps (purecopy '("\\.tar\\'")) + "List of regexps; if one matches a file name, don't look for `-*-'.") + +(defconst inhibit-first-line-modes-suffixes nil + "List of regexps for what to ignore, for `inhibit-first-line-modes-regexps'. +When checking `inhibit-first-line-modes-regexps', we first discard +from the end of the file name anything that matches one of these regexps.") + +(defvar user-init-file + "" ; set by command-line + "File name including directory of user's initialization file.") + +(defun set-auto-mode () + "Select major mode appropriate for current buffer. +This checks for a -*- mode tag in the buffer's text, +compares the filename against the entries in `auto-mode-alist', +or checks the interpreter that runs this file against +`interpreter-mode-alist'. + +It does not check for the `mode:' local variable in the +Local Variables section of the file; for that, use `hack-local-variables'. + +If `enable-local-variables' is nil, this function does not check for a +-*- mode tag." + (save-excursion + ;; Look for -*-MODENAME-*- or -*- ... mode: MODENAME; ... -*- + ;; Do this by calling the hack-local-variables helper to avoid redundancy. + ;; We bind enable-local-variables to nil this time because we're going to + ;; call hack-local-variables-prop-line again later, "for real." + (or (let ((enable-local-variables nil)) + (hack-local-variables-prop-line nil)) + ;; It's not in the -*- line, so check the auto-mode-alist, unless + ;; this buffer isn't associated with a file. + (null buffer-file-name) + (let ((name (file-name-sans-versions buffer-file-name)) + (keep-going t)) + (while keep-going + (setq keep-going nil) + (let ((alist auto-mode-alist) + (mode nil)) + ;; Find first matching alist entry. + (let ((case-fold-search + (memq system-type '(vax-vms windows-nt)))) + (while (and (not mode) alist) + (if (string-match (car (car alist)) name) + (if (and (consp (cdr (car alist))) + (nth 2 (car alist))) + (progn + (setq mode (car (cdr (car alist))) + name (substring name 0 (match-beginning 0)) + keep-going t)) + (setq mode (cdr (car alist)) + keep-going nil))) + (setq alist (cdr alist)))) + ;; If we can't deduce a mode from the file name, + ;; look for an interpreter specified in the first line. + (if (and (null mode) + (save-excursion ; XEmacs + (goto-char (point-min)) + (looking-at "#!"))) + (let ((firstline + (buffer-substring + (point-min) + (save-excursion + (goto-char (point-min)) (end-of-line) (point))))) + (setq alist interpreter-mode-alist) + (while alist + (if (string-match (car (car alist)) firstline) + (progn + (setq mode (cdr (car alist))) + (setq alist nil)) + (setq alist (cdr alist)))))) + (if mode + (funcall mode)) + )))))) + +(defvar hack-local-variables-hook nil + "Normal hook run after processing a file's local variables specs. +Major modes can use this to examine user-specified local variables +in order to initialize other data structure based on them. + +This hook runs even if there were no local variables or if their +evaluation was suppressed. See also `enable-local-variables' and +`enable-local-eval'.") + +(defun hack-local-variables (&optional force) + "Parse, and bind or evaluate as appropriate, any local variables +for current buffer." + ;; Don't look for -*- if this file name matches any + ;; of the regexps in inhibit-first-line-modes-regexps. + (if (or (null buffer-file-name) ; don't lose if buffer has no file! + (not (let ((temp inhibit-first-line-modes-regexps) + (name (if buffer-file-name + (file-name-sans-versions buffer-file-name) + (buffer-name)))) + (while (let ((sufs inhibit-first-line-modes-suffixes)) + (while (and sufs (not + (string-match (car sufs) name))) + (setq sufs (cdr sufs))) + sufs) + (setq name (substring name 0 (match-beginning 0)))) + (while (and temp + (not (string-match (car temp) name))) + (setq temp (cdr temp)) + temp)))) + (progn + ;; Look for variables in the -*- line. + (hack-local-variables-prop-line force) + ;; Look for "Local variables:" block in last page. + (hack-local-variables-last-page force))) + (run-hooks 'hack-local-variables-hook)) + +;;; Local variables may be specified in the last page of the file (within 3k +;;; from the end of the file and after the last ^L) in the form +;;; +;;; Local variables: +;;; variable-name: variable-value +;;; end: +;;; +;;; The lines may begin with a common prefix, like ";;; " in the above +;;; example. They may also have a common suffix (" */" for example). In +;;; this form, the local variable "mode" can be used to change the major +;;; mode, and the local variable "eval" can be used to evaluate an arbitrary +;;; form. +;;; +;;; Local variables may also be specified in the first line of the file. +;;; Embedded in this line are a pair of "-*-" sequences. What lies between +;;; them are variable-name/variable-value pairs, like: +;;; +;;; -*- mode: emacs-lisp -*- +;;; or -*- mode: postscript; version-control: never -*- +;;; or -*- tags-file-name: "/foo/bar/TAGS" -*- +;;; +;;; The local variable "eval" is not used with this form. For hysterical +;;; reasons, the syntax "-*- modename -*-" is allowed as well. +;;; + +(defun hack-local-variables-p (modeline) + (or (eq enable-local-variables t) + (and enable-local-variables + (save-window-excursion + (condition-case nil + (switch-to-buffer (current-buffer)) + (error + ;; If we fail to switch in the selected window, + ;; it is probably a minibuffer. + ;; So try another window. + (condition-case nil + (switch-to-buffer-other-window (current-buffer)) + (error + (switch-to-buffer-other-frame (current-buffer)))))) + (or modeline (save-excursion + (beginning-of-line) + (set-window-start (selected-window) (point)))) + (y-or-n-p (format + "Set local variables as specified %s of %s? " + (if modeline "in -*- line" "at end") + (if buffer-file-name + (file-name-nondirectory buffer-file-name) + (concat "buffer " (buffer-name))))))))) + +(defun hack-local-variables-last-page (&optional force) + ;; Set local variables set in the "Local Variables:" block of the last page. + (save-excursion + (goto-char (point-max)) + (search-backward "\n\^L" (max (- (point-max) 3000) (point-min)) 'move) + (if (let ((case-fold-search t)) + (and (search-forward "Local Variables:" nil t) + (or force + (hack-local-variables-p nil)))) + (let ((continue t) + prefix prefixlen suffix beg + (enable-local-eval enable-local-eval)) + ;; The prefix is what comes before "local variables:" in its line. + ;; The suffix is what comes after "local variables:" in its line. + (skip-chars-forward " \t") + (or (eolp) + (setq suffix (buffer-substring (point) + (progn (end-of-line) (point))))) + (goto-char (match-beginning 0)) + (or (bolp) + (setq prefix + (buffer-substring (point) + (progn (beginning-of-line) (point))))) + (if prefix (setq prefixlen (length prefix) + prefix (regexp-quote prefix))) + (if suffix (setq suffix (concat (regexp-quote suffix) "$"))) + (while continue + ;; Look at next local variable spec. + (if selective-display (re-search-forward "[\n\C-m]") + (forward-line 1)) + ;; Skip the prefix, if any. + (if prefix + (if (looking-at prefix) + (forward-char prefixlen) + (error "Local variables entry is missing the prefix"))) + ;; Find the variable name; strip whitespace. + (skip-chars-forward " \t") + (setq beg (point)) + (skip-chars-forward "^:\n") + (if (eolp) (error "Missing colon in local variables entry")) + (skip-chars-backward " \t") + (let* ((str (buffer-substring beg (point))) + (var (read str)) + val) + ;; Setting variable named "end" means end of list. + (if (string-equal (downcase str) "end") + (setq continue nil) + ;; Otherwise read the variable value. + (skip-chars-forward "^:") + (forward-char 1) + (setq val (read (current-buffer))) + (skip-chars-backward "\n") + (skip-chars-forward " \t") + (or (if suffix (looking-at suffix) (eolp)) + (error "Local variables entry is terminated incorrectly")) + ;; Set the variable. "Variables" mode and eval are funny. + (hack-one-local-variable var val)))))))) + +;; jwz - New Version 20.1/19.15 +(defun hack-local-variables-prop-line (&optional force) + ;; Set local variables specified in the -*- line. + ;; Returns t if mode was set. + (let ((result nil)) + (save-excursion + (goto-char (point-min)) + (skip-chars-forward " \t\n\r") + (let ((end (save-excursion + ;; If the file begins with "#!" + ;; (un*x exec interpreter magic), look + ;; for mode frobs in the first two + ;; lines. You cannot necessarily + ;; put them in the first line of + ;; such a file without screwing up + ;; the interpreter invocation. + (end-of-line (and (looking-at "^#!") 2)) + (point)))) + ;; Parse the -*- line into the `result' alist. + (cond ((not (search-forward "-*-" end t)) + ;; doesn't have one. + (setq force t)) + ((looking-at "[ \t]*\\([^ \t\n\r:;]+\\)\\([ \t]*-\\*-\\)") + ;; Antiquated form: "-*- ModeName -*-". + (setq result + (list (cons 'mode + (intern (buffer-substring + (match-beginning 1) + (match-end 1))))) + )) + (t + ;; Usual form: '-*-' [ <variable> ':' <value> ';' ]* '-*-' + ;; (last ";" is optional). + (save-excursion + (if (search-forward "-*-" end t) + (setq end (- (point) 3)) + (error "-*- not terminated before end of line"))) + (while (< (point) end) + (or (looking-at "[ \t]*\\([^ \t\n:]+\\)[ \t]*:[ \t]*") + (error "malformed -*- line")) + (goto-char (match-end 0)) + ;; There used to be a downcase here, + ;; but the manual didn't say so, + ;; and people want to set var names that aren't all lc. + (let ((key (intern (buffer-substring + (match-beginning 1) + (match-end 1)))) + (val (save-restriction + (narrow-to-region (point) end) + (read (current-buffer))))) + ;; Case sensitivity! Icepicks in my forehead! + (if (equal (downcase (symbol-name key)) "mode") + (setq key 'mode)) + (setq result (cons (cons key val) result)) + (skip-chars-forward " \t;"))) + (setq result (nreverse result)))))) + + (let ((set-any-p (or force (hack-local-variables-p t))) + (mode-p nil)) + (while result + (let ((key (car (car result))) + (val (cdr (car result)))) + (cond ((eq key 'mode) + (and enable-local-variables + (setq mode-p t) + (funcall (intern (concat (downcase (symbol-name val)) + "-mode"))))) + (set-any-p + (hack-one-local-variable key val)) + (t + nil))) + (setq result (cdr result))) + mode-p))) + +(defconst ignored-local-variables + (list 'enable-local-eval) + "Variables to be ignored in a file's local variable spec.") + +;; Get confirmation before setting these variables as locals in a file. +(put 'debugger 'risky-local-variable t) +(put 'enable-local-eval 'risky-local-variable t) +(put 'ignored-local-variables 'risky-local-variable t) +(put 'eval 'risky-local-variable t) +(put 'file-name-handler-alist 'risky-local-variable t) +(put 'minor-mode-map-alist 'risky-local-variable t) +(put 'after-load-alist 'risky-local-variable t) +(put 'buffer-file-name 'risky-local-variable t) +(put 'buffer-auto-save-file-name 'risky-local-variable t) +(put 'buffer-file-truename 'risky-local-variable t) +(put 'exec-path 'risky-local-variable t) +(put 'load-path 'risky-local-variable t) +(put 'exec-directory 'risky-local-variable t) +(put 'process-environment 'risky-local-variable t) +;; Don't wait for outline.el to be loaded, for the sake of outline-minor-mode. +(put 'outline-level 'risky-local-variable t) +(put 'rmail-output-file-alist 'risky-local-variable t) + +;; This one is safe because the user gets to check it before it is used. +(put 'compile-command 'safe-local-variable t) + +;(defun hack-one-local-variable-quotep (exp) +; (and (consp exp) (eq (car exp) 'quote) (consp (cdr exp)))) + +;; "Set" one variable in a local variables spec. +;; A few variable names are treated specially. +(defun hack-one-local-variable (var val) + (cond ((eq var 'mode) + (funcall (intern (concat (downcase (symbol-name val)) + "-mode")))) + ((memq var ignored-local-variables) + nil) + ;; "Setting" eval means either eval it or do nothing. + ;; Likewise for setting hook variables. + ((or (get var 'risky-local-variable) + (and + (string-match "-hooks?$\\|-functions?$\\|-forms?$\\|-program$\\|-command$" + (symbol-name var)) + (not (get var 'safe-local-variable)))) +; ;; Permit evaling a put of a harmless property +; ;; if the args do nothing tricky. +; (if (or (and (eq var 'eval) +; (consp val) +; (eq (car val) 'put) +; (hack-one-local-variable-quotep (nth 1 val)) +; (hack-one-local-variable-quotep (nth 2 val)) +; ;; Only allow safe values of lisp-indent-hook; +; ;; not functions. +; (or (numberp (nth 3 val)) +; (equal (nth 3 val) ''defun)) +; (memq (nth 1 (nth 2 val)) +; '(lisp-indent-hook))) + (if (and (not (zerop (user-uid))) + (or (eq enable-local-eval t) + (and enable-local-eval + (save-window-excursion + (switch-to-buffer (current-buffer)) + (save-excursion + (beginning-of-line) + (set-window-start (selected-window) (point))) + (setq enable-local-eval + (y-or-n-p (format "Process `eval' or hook local variables in file %s? " + (file-name-nondirectory buffer-file-name)))))))) + (if (eq var 'eval) + (save-excursion (eval val)) + (make-local-variable var) + (set var val)) + (message "Ignoring `eval:' in file's local variables"))) + ;; Ordinary variable, really set it. + (t (make-local-variable var) + (set var val)))) + +(defun set-visited-file-name (filename) + "Change name of file visited in current buffer to FILENAME. +The next time the buffer is saved it will go in the newly specified file. +nil or empty string as argument means make buffer not be visiting any file. +Remember to delete the initial contents of the minibuffer +if you wish to pass an empty string as the argument." + (interactive "FSet visited file name: ") + (if (buffer-base-buffer) + (error "An indirect buffer cannot visit a file")) + (let (truename) + (if filename + (setq filename + (if (string-equal filename "") + nil + (expand-file-name filename)))) + (if filename + (progn + (setq truename (file-truename filename)) + ;; #### Do we need to check if truename is non-nil? + (if find-file-use-truenames + (setq filename truename)))) + (or (equal filename buffer-file-name) + (progn + (and filename (lock-buffer filename)) + (unlock-buffer))) + (setq buffer-file-name filename) + (if filename ; make buffer name reflect filename. + (let ((new-name (file-name-nondirectory buffer-file-name))) + (if (string= new-name "") + (error "Empty file name")) + (if (eq system-type 'vax-vms) + (setq new-name (downcase new-name))) + (setq default-directory (file-name-directory buffer-file-name)) + (or (string= new-name (buffer-name)) + (rename-buffer new-name t)))) + (setq buffer-backed-up nil) + (clear-visited-file-modtime) + (compute-buffer-file-truename) ; insert-file-contents does this too. +; ;; Abbreviate the file names of the buffer. +; (if truename +; (progn +; (setq buffer-file-truename (abbreviate-file-name truename)) +; (if find-file-visit-truename +; (setq buffer-file-name buffer-file-truename)))) + (setq buffer-file-number + (if filename + (nthcdr 10 (file-attributes buffer-file-name)) + nil))) + ;; write-file-hooks is normally used for things like ftp-find-file + ;; that visit things that are not local files as if they were files. + ;; Changing to visit an ordinary local file instead should flush the hook. + (kill-local-variable 'write-file-hooks) + (kill-local-variable 'after-save-hook) + (kill-local-variable 'local-write-file-hooks) + (kill-local-variable 'write-file-data-hooks) + (kill-local-variable 'revert-buffer-function) + (kill-local-variable 'backup-inhibited) + ;; If buffer was read-only because of version control, + ;; that reason is gone now, so make it writable. + (if (and (boundp 'vc-mode) vc-mode) + (setq buffer-read-only nil)) + (kill-local-variable 'vc-mode) + ;; Turn off backup files for certain file names. + ;; Since this is a permanent local, the major mode won't eliminate it. + (and (not (funcall backup-enable-predicate buffer-file-name)) + (progn + (make-local-variable 'backup-inhibited) + (setq backup-inhibited t))) + (let ((oauto buffer-auto-save-file-name)) + ;; If auto-save was not already on, turn it on if appropriate. + (if (not buffer-auto-save-file-name) + (and buffer-file-name auto-save-default + (auto-save-mode t)) + ;; If auto save is on, start using a new name. + ;; We deliberately don't rename or delete the old auto save + ;; for the old visited file name. This is because perhaps + ;; the user wants to save the new state and then compare with the + ;; previous state from the auto save file. + (setq buffer-auto-save-file-name + (make-auto-save-file-name))) + ;; Rename the old auto save file if any. + (and oauto buffer-auto-save-file-name + (file-exists-p oauto) + (rename-file oauto buffer-auto-save-file-name t))) + (if buffer-file-name + (set-buffer-modified-p t)) + ;; #### ?? + (run-hooks 'after-set-visited-file-name-hooks)) + +(defun write-file (filename &optional confirm codesys) + "Write current buffer into file FILENAME. +Makes buffer visit that file, and marks it not modified. +If the buffer is already visiting a file, you can specify +a directory name as FILENAME, to write a file of the same +old name in that directory. +If optional second arg CONFIRM is non-nil, +ask for confirmation for overwriting an existing file. +Under XEmacs/Mule, optional third argument specifies the +coding system to use when encoding the file. Interactively, +with a prefix argument, you will be prompted for the coding system." +;; (interactive "FWrite file: ") + (interactive + (list (if buffer-file-name + (read-file-name "Write file: " + nil nil nil nil) + (read-file-name "Write file: " + (cdr (assq 'default-directory + (buffer-local-variables))) + nil nil (buffer-name))) + t + (if (and current-prefix-arg (featurep 'mule)) + (read-coding-system "Coding system: ")))) + (and (eq (current-buffer) mouse-grabbed-buffer) + (error "Can't write minibuffer window")) + (or (null filename) (string-equal filename "") + (progn + ;; If arg is just a directory, + ;; use same file name, but in that directory. + (if (and (file-directory-p filename) buffer-file-name) + (setq filename (concat (file-name-as-directory filename) + (file-name-nondirectory buffer-file-name)))) + (and confirm + (file-exists-p filename) + (or (y-or-n-p (format "File `%s' exists; overwrite? " filename)) + (error "Canceled"))) + (set-visited-file-name filename))) + (set-buffer-modified-p t) + (setq buffer-read-only nil) + (if codesys + (let ((buffer-file-coding-system (get-coding-system codesys))) + (save-buffer)) + (save-buffer))) + +(defun backup-buffer () + "Make a backup of the disk file visited by the current buffer, if appropriate. +This is normally done before saving the buffer the first time. +If the value is non-nil, it is the result of `file-modes' on the original file; +this means that the caller, after saving the buffer, should change the modes +of the new file to agree with the old modes." + (if buffer-file-name + (let ((handler (find-file-name-handler buffer-file-name 'backup-buffer))) + (if handler + (funcall handler 'backup-buffer) + (if (and make-backup-files + (not backup-inhibited) + (not buffer-backed-up) + (file-exists-p buffer-file-name) + (memq (aref (elt (file-attributes buffer-file-name) 8) 0) + '(?- ?l))) + (let ((real-file-name buffer-file-name) + backup-info backupname targets setmodes) + ;; If specified name is a symbolic link, chase it to the target. + ;; Thus we make the backups in the directory where the real file is. + (setq real-file-name (file-chase-links real-file-name)) + (setq backup-info (find-backup-file-name real-file-name) + backupname (car backup-info) + targets (cdr backup-info)) +;;; (if (file-directory-p buffer-file-name) +;;; (error "Cannot save buffer in directory %s" buffer-file-name)) + (if backup-info + (condition-case () + (let ((delete-old-versions + ;; If have old versions to maybe delete, + ;; ask the user to confirm now, before doing anything. + ;; But don't actually delete til later. + (and targets + (or (eq delete-old-versions t) + (eq delete-old-versions nil)) + (or delete-old-versions + (y-or-n-p (format "Delete excess backup versions of %s? " + real-file-name)))))) + ;; Actually write the back up file. + (condition-case () + (if (or file-precious-flag + ; (file-symlink-p buffer-file-name) + backup-by-copying + (and backup-by-copying-when-linked + (> (file-nlinks real-file-name) 1)) + (and backup-by-copying-when-mismatch + (let ((attr (file-attributes real-file-name))) + (or (nth 9 attr) + (not (file-ownership-preserved-p real-file-name)))))) + (condition-case () + (copy-file real-file-name backupname t t) + (file-error + ;; If copying fails because file BACKUPNAME + ;; is not writable, delete that file and try again. + (if (and (file-exists-p backupname) + (not (file-writable-p backupname))) + (delete-file backupname)) + (copy-file real-file-name backupname t t))) + ;; rename-file should delete old backup. + (rename-file real-file-name backupname t) + (setq setmodes (file-modes backupname))) + (file-error + ;; If trouble writing the backup, write it in ~. + (setq backupname (expand-file-name "~/%backup%~")) + (message "Cannot write backup file; backing up in ~/%%backup%%~") + (sleep-for 1) + (condition-case () + (copy-file real-file-name backupname t t) + (file-error + ;; If copying fails because file BACKUPNAME + ;; is not writable, delete that file and try again. + (if (and (file-exists-p backupname) + (not (file-writable-p backupname))) + (delete-file backupname)) + (copy-file real-file-name backupname t t))))) + (setq buffer-backed-up t) + ;; Now delete the old versions, if desired. + (if delete-old-versions + (while targets + (condition-case () + (delete-file (car targets)) + (file-error nil)) + (setq targets (cdr targets)))) + setmodes) + (file-error nil))))))))) + +(defun file-name-sans-versions (name &optional keep-backup-version) + "Return FILENAME sans backup versions or strings. +This is a separate procedure so your site-init or startup file can +redefine it. +If the optional argument KEEP-BACKUP-VERSION is non-nil, +we do not remove backup version numbers, only true file version numbers." + (let ((handler (find-file-name-handler name 'file-name-sans-versions))) + (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)))))))) + +(defun file-ownership-preserved-p (file) + "Returns t if deleting FILE and rewriting it would preserve the owner." + (let ((handler (find-file-name-handler file 'file-ownership-preserved-p))) + (if handler + (funcall handler 'file-ownership-preserved-p file) + (let ((attributes (file-attributes file))) + ;; Return t if the file doesn't exist, since it's true that no + ;; information would be lost by an (attempted) delete and create. + (or (null attributes) + (= (nth 2 attributes) (user-uid))))))) + +(defun file-name-sans-extension (filename) + "Return FILENAME sans final \"extension\". +The extension, in a file name, is the part that follows the last `.'." + (save-match-data + (let ((file (file-name-sans-versions (file-name-nondirectory filename))) + directory) + (if (string-match "\\.[^.]*\\'" file) + (if (setq directory (file-name-directory filename)) + (expand-file-name (substring file 0 (match-beginning 0)) + directory) + (substring file 0 (match-beginning 0))) + filename)))) + +(defun make-backup-file-name (file) + "Create the non-numeric backup file name for FILE. +This is a separate function so you can redefine it for customization." + (if (eq system-type 'ms-dos) + (let ((fn (file-name-nondirectory file))) + (concat (file-name-directory file) + (if (string-match "\\([^.]*\\)\\(\\..*\\)?" fn) + (substring fn 0 (match-end 1))) + ".bak")) + (concat file "~"))) + +(defun backup-file-name-p (file) + "Return non-nil if FILE is a backup file name (numeric or not). +This is a separate function so you can redefine it for customization. +You may need to redefine `file-name-sans-versions' as well." + (if (eq system-type 'ms-dos) + (string-match "\\.bak\\'" file) + (string-match "~\\'" file))) + +;; This is used in various files. +;; The usage of bv-length is not very clean, +;; but I can't see a good alternative, +;; so as of now I am leaving it alone. +(defun backup-extract-version (fn) + "Given the name of a numeric backup file, return the backup number. +Uses the free variable `bv-length', whose value should be +the index in the name where the version number begins." + (declare (special bv-length)) + (if (and (string-match "[0-9]+~\\'" fn bv-length) + (= (match-beginning 0) bv-length)) + (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 + and whose cdr is a list of old versions to consider deleting now. +If the value is nil, don't make a backup." + (let ((handler (find-file-name-handler fn 'find-backup-file-name))) + ;; Run a handler for this function so that ange-ftp can refuse to do it. + (if handler + (funcall handler 'find-backup-file-name fn) + (if (eq version-control 'never) + (list (make-backup-file-name fn)) + (let* ((base-versions (concat (file-name-nondirectory fn) ".~")) + ;; used by backup-extract-version: + (bv-length (length base-versions)) + possibilities + (versions nil) + (high-water-mark 0) + (deserve-versions-p nil) + (number-to-delete 0)) + (condition-case () + (setq possibilities (file-name-all-completions + base-versions + (file-name-directory fn)) + versions (sort (mapcar + #'backup-extract-version + possibilities) + '<) + high-water-mark (apply #'max 0 versions) + deserve-versions-p (or version-control + (> high-water-mark 0)) + number-to-delete (- (length versions) + kept-old-versions kept-new-versions -1)) + (file-error + (setq possibilities nil))) + (if (not deserve-versions-p) + (list (make-backup-file-name fn)) + (cons (concat fn ".~" (int-to-string (1+ high-water-mark)) "~") + (if (and (> number-to-delete 0) + ;; Delete nothing if there is overflow + ;; in the number of versions to keep. + (>= (+ kept-new-versions kept-old-versions -1) 0)) + (mapcar #'(lambda (n) + (concat fn ".~" (int-to-string n) "~")) + (let ((v (nthcdr kept-old-versions versions))) + (rplacd (nthcdr (1- number-to-delete) v) ()) + v)))))))))) + +(defun file-nlinks (filename) + "Return number of names file FILENAME has." + (car (cdr (file-attributes filename)))) + +(defun file-relative-name (filename &optional directory) + "Convert FILENAME to be relative to DIRECTORY (default: default-directory)." + (setq filename (expand-file-name filename) + directory (file-name-as-directory (expand-file-name + (or directory default-directory)))) + (let ((ancestor "")) + (while (not (string-match (concat "^" (regexp-quote directory)) filename)) + (setq directory (file-name-directory (substring directory 0 -1)) + ancestor (concat "../" ancestor))) + (concat ancestor (substring filename (match-end 0))))) + +(defun save-buffer (&optional args) + "Save current buffer in visited file if modified. Versions described below. + +By default, makes the previous version into a backup file + if previously requested or if this is the first save. +With 1 or 3 \\[universal-argument]'s, marks this version + to become a backup when the next save is done. +With 2 or 3 \\[universal-argument]'s, + unconditionally makes the previous version into a backup file. +With argument of 0, never makes the previous version into a backup file. + +If a file's name is FOO, the names of its numbered backup versions are + FOO.~i~ for various integers i. A non-numbered backup file is called FOO~. +Numeric backups (rather than FOO~) will be made if value of + `version-control' is not the atom `never' and either there are already + numeric versions of the file being backed up, or `version-control' is + non-nil. +We don't want excessive versions piling up, so there are variables + `kept-old-versions', which tells XEmacs how many oldest versions to keep, + and `kept-new-versions', which tells how many newest versions to keep. + Defaults are 2 old versions and 2 new. +`dired-kept-versions' controls dired's clean-directory (.) command. +If `delete-old-versions' is nil, system will query user + before trimming versions. Otherwise it does it silently." + (interactive "_p") + (let ((modp (buffer-modified-p)) + (large (> (buffer-size) 50000)) + (make-backup-files (or (and make-backup-files (not (eq args 0))) + (memq args '(16 64))))) + (and modp (memq args '(16 64)) (setq buffer-backed-up nil)) + (if (and modp large) (display-message + 'progress (format "Saving file %s..." + (buffer-file-name)))) + (basic-save-buffer) + (and modp (memq args '(4 64)) (setq buffer-backed-up nil)))) + +(defun delete-auto-save-file-if-necessary (&optional force) + "Delete auto-save file for current buffer if `delete-auto-save-files' is t. +Normally delete only if the file was written by this XEmacs +since the last real save, but optional arg FORCE non-nil means delete anyway." + (and buffer-auto-save-file-name delete-auto-save-files + (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)) + (set-buffer-auto-saved)))) + +;; XEmacs change (from Sun) +;; used to communicate with continue-save-buffer: +(defvar continue-save-buffer-hooks-tail nil) + +;; Not in FSFmacs +(defun basic-write-file-data (realname truename) + ;; call the hooks until the bytes are put + ;; call write-region as a last resort + (let ((region-written nil) + (hooks write-file-data-hooks)) + (while (and hooks (not region-written)) + (setq region-written (funcall (car hooks) realname) + hooks (cdr hooks))) + (if (not region-written) + (write-region (point-min) (point-max) realname nil t truename)))) + +(put 'after-save-hook 'permanent-local t) +(defvar after-save-hook nil + "Normal hook that is run after a buffer is saved to its file. +These hooks are considered to pertain to the visited file. +So this list is cleared if you change the visited file name.") + +(defun files-fetch-hook-value (hook) + (let ((localval (symbol-value hook)) + (globalval (default-value hook))) + (if (memq t localval) + (setq localval (append (delq t localval) (delq t globalval)))) + localval)) + +(defun basic-save-buffer () + "Save the current buffer in its visited file, if it has been modified. +After saving the buffer, run `after-save-hook'." + (interactive) + (save-excursion + ;; In an indirect buffer, save its base buffer instead. + (if (buffer-base-buffer) + (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 + (expand-file-name + (read-file-name "File to save in: ") nil))) + (and (file-exists-p filename) + (or (y-or-n-p (format "File `%s' exists; overwrite? " + filename)) + (error "Canceled"))) + (set-visited-file-name filename))) + (or (verify-visited-file-modtime (current-buffer)) + (not (file-exists-p buffer-file-name)) + (yes-or-no-p + (format "%s has changed since visited or saved. Save anyway? " + (file-name-nondirectory buffer-file-name))) + (error "Save not confirmed")) + (save-restriction + (widen) + (and (> (point-max) 1) + (/= (char-after (1- (point-max))) ?\n) + (not (and (eq selective-display t) + (= (char-after (1- (point-max))) ?\r))) + (or (eq require-final-newline t) + (and require-final-newline + (y-or-n-p + (format "Buffer %s does not end in newline. Add one? " + (buffer-name))))) + (save-excursion + (goto-char (point-max)) + (insert ?\n))) + ;; + ;; Run the write-file-hooks until one returns non-null. + ;; Bind after-save-hook to nil while running the + ;; write-file-hooks so that if this function is called + ;; recursively (from inside a write-file-hook) the + ;; after-hooks will only get run once (from the + ;; outermost call). + ;; + ;; Ugh, have to duplicate logic of run-hook-with-args-until-success + (let ((hooks (append (files-fetch-hook-value 'write-contents-hooks) + (files-fetch-hook-value + 'local-write-file-hooks) + (files-fetch-hook-value 'write-file-hooks))) + (after-save-hook nil) + (local-write-file-hooks nil) + (write-contents-hooks nil) + (write-file-hooks nil) + done) + (while (and hooks + (let ((continue-save-buffer-hooks-tail hooks)) + (not (setq done (funcall (car hooks)))))) + (setq hooks (cdr hooks))) + ;; If a hook returned t, file is already "written". + ;; Otherwise, write it the usual way now. + (if (not done) + (basic-save-buffer-1))) + ;; XEmacs: next two clauses (buffer-file-number setting and + ;; set-file-modes) moved into basic-save-buffer-1. + ) + ;; If the auto-save file was recent before this command, + ;; delete it now. + (delete-auto-save-file-if-necessary recent-save) + ;; Support VC `implicit' locking. + (when (fboundp 'vc-after-save) + (vc-after-save)) + (run-hooks 'after-save-hook)) + (display-message 'no-log "(No changes need to be saved)")))) + +;; This does the "real job" of writing a buffer into its visited file +;; and making a backup file. This is what is normally done +;; but inhibited if one of write-file-hooks returns non-nil. +;; It returns a value to store in setmodes. +(defun basic-save-buffer-1 () + (let (setmodes tempsetmodes) + (if (not (file-writable-p buffer-file-name)) + (let ((dir (file-name-directory buffer-file-name))) + (if (not (file-directory-p dir)) + (error "%s is not a directory" dir) + (if (not (file-exists-p buffer-file-name)) + (error "Directory %s write-protected" dir) + (if (yes-or-no-p + (format "File %s is write-protected; try to save anyway? " + (file-name-nondirectory + buffer-file-name))) + (setq tempsetmodes t) + (error + "Attempt to save to a file which you aren't allowed to write")))))) + (or buffer-backed-up + (setq setmodes (backup-buffer))) + (let ((dir (file-name-directory buffer-file-name))) + (if (and file-precious-flag + (file-writable-p dir)) + ;; If file is precious, write temp name, then rename it. + ;; This requires write access to the containing dir, + ;; which is why we don't try it if we don't have that access. + (let ((realname buffer-file-name) + tempname nogood i succeed + (old-modtime (visited-file-modtime))) + (setq i 0) + (setq nogood t) + ;; Find the temporary name to write under. + (while nogood + (setq tempname (format "%s#tmp#%d" dir i)) + (setq nogood (file-exists-p tempname)) + (setq i (1+ i))) + (unwind-protect + (progn (clear-visited-file-modtime) + (write-region (point-min) (point-max) + tempname nil realname + buffer-file-truename) + (setq succeed t)) + ;; If writing the temp file fails, + ;; delete the temp file. + (or succeed + (progn + (delete-file tempname) + (set-visited-file-modtime old-modtime)))) + ;; Since we have created an entirely new file + ;; and renamed it, make sure it gets the + ;; right permission bits set. + (setq setmodes (file-modes buffer-file-name)) + ;; We succeeded in writing the temp file, + ;; so rename it. + (rename-file tempname buffer-file-name t)) + ;; If file not writable, see if we can make it writable + ;; temporarily while we write it. + ;; But no need to do so if we have just backed it up + ;; (setmodes is set) because that says we're superseding. + (cond ((and tempsetmodes (not setmodes)) + ;; Change the mode back, after writing. + (setq setmodes (file-modes buffer-file-name)) + (set-file-modes buffer-file-name 511))) + (basic-write-file-data buffer-file-name buffer-file-truename))) + (setq buffer-file-number + (if buffer-file-name + (nth 10 (file-attributes buffer-file-name)) + nil)) + (if setmodes + (condition-case () + (set-file-modes buffer-file-name setmodes) + (error nil))))) + +;; XEmacs change, from Sun +(defun continue-save-buffer () + "Provide a clean way for a write-file-hook to wrap AROUND +the execution of the remaining hooks and writing to disk. +Do not call this function except from a functions +on the write-file-hooks or write-contents-hooks list. +A hook that calls this function must return non-nil, +to signal completion to its caller. continue-save-buffer +always returns non-nil." + (let ((hooks (cdr (or continue-save-buffer-hooks-tail + (error + "continue-save-buffer called outside a write-file-hook!")))) + (done nil)) + ;; Do something like this: + ;; (let ((write-file-hooks hooks)) (basic-save-buffer)) + ;; First run the rest of the hooks. + (while (and hooks + (let ((continue-save-buffer-hooks-tail hooks)) + (not (setq done (funcall (car hooks)))))) + (setq hooks (cdr hooks))) + ;; + ;; If a hook returned t, file is already "written". + (if (not done) + (basic-save-buffer-1)) + 'continue-save-buffer)) + +(defcustom save-some-buffers-query-display-buffer xemacs-betaname + "*Non-nil makes `\\[save-some-buffers]' switch to the buffer offered for saving." + :type 'boolean + :group 'editing-basics) + +(defun save-some-buffers (&optional arg exiting) + "Save some modified file-visiting buffers. Asks user about each one. +Optional argument (the prefix) non-nil means save all with no questions. +Optional second argument EXITING means ask about certain non-file buffers + as well as about file buffers." + (interactive "P") + (save-excursion + (save-window-excursion + ;; This can bomb during autoloads generation + (when (and (not noninteractive) + save-some-buffers-query-display-buffer) + (delete-other-windows)) + ;; XEmacs - do not use queried flag + (let ((files-done + (map-y-or-n-p + (function + (lambda (buffer) + (and (buffer-modified-p buffer) + (not (buffer-base-buffer buffer)) + ;; XEmacs addition: + (not (symbol-value-in-buffer 'save-buffers-skip buffer)) + (or + (buffer-file-name buffer) + (and exiting + (progn + (set-buffer buffer) + (and buffer-offer-save (> (buffer-size) 0))))) + (if arg + t + (when save-some-buffers-query-display-buffer + (condition-case nil + (switch-to-buffer buffer t) + (error nil))) + (if (buffer-file-name buffer) + (format "Save file %s? " + (buffer-file-name buffer)) + (format "Save buffer %s? " + (buffer-name buffer))))))) + (function + (lambda (buffer) + (set-buffer buffer) + (condition-case () + (save-buffer) + (error nil)))) + (buffer-list) + '("buffer" "buffers" "save") + ;;instead of this we just say "yes all", "no all", etc. + ;;"save all the rest" + ;;"save only this buffer" "save no more buffers") + ;; this is rather bogus. --ben + ;; (it makes the dialog box too big, and you get an error + ;; "wrong type argument: framep, nil" when you hit q after + ;; choosing the option from the dialog box) +; (list (list ?\C-r (lambda (buf) +; (view-buffer buf) +; (setq view-exit-action +; '(lambda (ignore) +; (exit-recursive-edit))) +; (recursive-edit) +; ;; Return nil to ask about BUF again. +; nil) +; "display the current buffer")) + )) + (abbrevs-done + (and save-abbrevs abbrevs-changed + (progn + (if (or arg + (y-or-n-p (format "Save abbrevs in %s? " abbrev-file-name))) + (write-abbrev-file nil)) + ;; Don't keep bothering user if he says no. + (setq abbrevs-changed nil) + t)))) + (or (> files-done 0) abbrevs-done + (display-message 'no-log "(No files need saving)")))))) + + +(defun not-modified (&optional arg) + "Mark current buffer as unmodified, not needing to be saved. +With prefix arg, mark buffer as modified, so \\[save-buffer] will save. + +It is not a good idea to use this function in Lisp programs, because it +prints a message in the minibuffer. Instead, use `set-buffer-modified-p'." + (interactive "_P") + (if arg ;; rewritten for I18N3 snarfing + (display-message 'command "Modification-flag set") + (display-message 'command "Modification-flag cleared")) + (set-buffer-modified-p arg)) + +(defun toggle-read-only (&optional arg) + "Change whether this buffer is visiting its file read-only. +With arg, set read-only iff arg is positive." + (interactive "_P") + (setq buffer-read-only + (if (null arg) + (not buffer-read-only) + (> (prefix-numeric-value arg) 0))) + ;; Force modeline redisplay + (redraw-modeline)) + +(defun insert-file (filename &optional codesys) + "Insert contents of file FILENAME into buffer after point. +Set mark after the inserted text. + +Under XEmacs/Mule, optional second argument specifies the +coding system to use when decoding the file. Interactively, +with a prefix argument, you will be prompted for the coding system. + +This function is meant for the user to run interactively. +Don't call it from programs! Use `insert-file-contents' instead. +\(Its calling sequence is different; see its documentation)." + (interactive "*fInsert file: \nZCoding system: ") + (if (file-directory-p filename) + (signal 'file-error (list "Opening input file" "file is a directory" + filename))) + (let ((tem + (if codesys + (let ((coding-system-for-read + (get-coding-system codesys))) + (insert-file-contents filename)) + (insert-file-contents filename)))) + (push-mark (+ (point) (car (cdr tem)))))) + +(defun append-to-file (start end filename &optional codesys) + "Append the contents of the region to the end of file FILENAME. +When called from a function, expects three arguments, +START, END and FILENAME. START and END are buffer positions +saying what text to write. +Under XEmacs/Mule, optional fourth argument specifies the +coding system to use when encoding the file. Interactively, +with a prefix argument, you will be prompted for the coding system." + (interactive "r\nFAppend to file: \nZCoding system: ") + (if codesys + (let ((buffer-file-coding-system (get-coding-system codesys))) + (write-region start end filename t)) + (write-region start end filename t))) + +(defun file-newest-backup (filename) + "Return most recent backup file for FILENAME or nil if no backups exist." + (let* ((filename (expand-file-name filename)) + (file (file-name-nondirectory filename)) + (dir (file-name-directory filename)) + (comp (file-name-all-completions file dir)) + newest) + (while comp + (setq file (concat dir (car comp)) + comp (cdr comp)) + (if (and (backup-file-name-p file) + (or (null newest) (file-newer-than-file-p file newest))) + (setq newest file))) + newest)) + +(defun rename-uniquely () + "Rename current buffer to a similar name not already taken. +This function is useful for creating multiple shell process buffers +or multiple mail buffers, etc." + (interactive) + (save-match-data + (let* ((base-name (if (and (string-match "<[0-9]+>\\'" (buffer-name)) + (not (and buffer-file-name + (string= (buffer-name) + (file-name-nondirectory + buffer-file-name))))) + ;; If the existing buffer name has a <NNN>, + ;; which isn't part of the file name (if any), + ;; then get rid of that. + (substring (buffer-name) 0 (match-beginning 0)) + (buffer-name))) + (new-buf (generate-new-buffer base-name)) + (name (buffer-name new-buf))) + (kill-buffer new-buf) + (rename-buffer name) + (redraw-modeline)))) + +(defun make-directory-path (path) + "Create all the directories along path that don't exist yet." + (interactive "Fdirectory path to create: ") + (make-directory path t)) + +(defun make-directory (dir &optional parents) + "Create the directory DIR and any nonexistent parent dirs. +Interactively, the default choice of directory to create +is the current default directory for file names. +That is useful when you have visited a file in a nonexistent directory. + +Noninteractively, the second (optional) argument PARENTS says whether +to create parent directories if they don't exist." + (interactive (list (let ((current-prefix-arg current-prefix-arg)) + (read-directory-name "Create directory: ")) + current-prefix-arg)) + (let ((handler (find-file-name-handler dir 'make-directory))) + (if handler + (funcall handler 'make-directory dir parents) + (if (not parents) + (make-directory-internal dir) + (let ((dir (directory-file-name (expand-file-name dir))) + create-list) + (while (not (file-exists-p dir)) + (setq create-list (cons dir create-list) + dir (directory-file-name (file-name-directory dir)))) + (while create-list + (make-directory-internal (car create-list)) + (setq create-list (cdr create-list)))))))) + +(put 'revert-buffer-function 'permanent-local t) +(defvar revert-buffer-function nil + "Function to use to revert this buffer, or nil to do the default. +The function receives two arguments IGNORE-AUTO and NOCONFIRM, +which are the arguments that `revert-buffer' received.") + +(put 'revert-buffer-insert-file-contents-function 'permanent-local t) +(defvar revert-buffer-insert-file-contents-function nil + "Function to use to insert contents when reverting this buffer. +Gets two args, first the nominal file name to use, +and second, t if reading the auto-save file.") + +(defvar before-revert-hook nil + "Normal hook for `revert-buffer' to run before reverting. +If `revert-buffer-function' is used to override the normal revert +mechanism, this hook is not used.") + +(defvar after-revert-hook nil + "Normal hook for `revert-buffer' to run after reverting. +Note that the hook value that it runs is the value that was in effect +before reverting; that makes a difference if you have buffer-local +hook functions. + +If `revert-buffer-function' is used to override the normal revert +mechanism, this hook is not used.") + +(defvar revert-buffer-internal-hook nil + "Don't use this.") + +(defun revert-buffer (&optional ignore-auto noconfirm preserve-modes) + "Replace the buffer text with the text of the visited file on disk. +This undoes all changes since the file was visited or saved. +With a prefix argument, offer to revert from latest auto-save file, if +that is more recent than the visited file. + +This command also works for special buffers that contain text which +doesn't come from a file, but reflects some other data base instead: +for example, Dired buffers and buffer-list buffers. In these cases, +it reconstructs the buffer contents from the appropriate data base. + +When called from Lisp, the first argument is IGNORE-AUTO; only offer +to revert from the auto-save file when this is nil. Note that the +sense of this argument is the reverse of the prefix argument, for the +sake of backward compatibility. IGNORE-AUTO is optional, defaulting +to nil. + +Optional second argument NOCONFIRM means don't ask for confirmation at +all. + +Optional third argument PRESERVE-MODES non-nil means don't alter +the files modes. Normally we reinitialize them using `normal-mode'. + +If the value of `revert-buffer-function' is non-nil, it is called to +do the work. + +The default revert function runs the hook `before-revert-hook' at the +beginning and `after-revert-hook' at the end." + ;; I admit it's odd to reverse the sense of the prefix argument, but + ;; there is a lot of code out there which assumes that the first + ;; argument should be t to avoid consulting the auto-save file, and + ;; there's no straightforward way to encourage authors to notice a + ;; reversal of the argument sense. So I'm just changing the user + ;; interface, but leaving the programmatic interface the same. + (interactive (list (not current-prefix-arg))) + (if revert-buffer-function + (funcall revert-buffer-function ignore-auto noconfirm) + (let* ((opoint (point)) + (auto-save-p (and (not ignore-auto) + (recent-auto-save-p) + buffer-auto-save-file-name + (file-readable-p buffer-auto-save-file-name) + (y-or-n-p + "Buffer has been auto-saved recently. Revert from auto-save file? "))) + (file-name (if auto-save-p + buffer-auto-save-file-name + buffer-file-name))) + (cond ((null file-name) + (error "Buffer does not seem to be associated with any file")) + ((or noconfirm + (and (not (buffer-modified-p)) + (let (found) + (dolist (rx revert-without-query found) + (when (string-match rx file-name) + (setq found t))))) + (yes-or-no-p (format "Revert buffer from file %s? " + file-name))) + (run-hooks 'before-revert-hook) + ;; If file was backed up but has changed since, + ;; we shd make another backup. + (and (not auto-save-p) + (not (verify-visited-file-modtime (current-buffer))) + (setq buffer-backed-up nil)) + ;; Get rid of all undo records for this buffer. + (or (eq buffer-undo-list t) + (setq buffer-undo-list nil)) + ;; Effectively copy the after-revert-hook status, + ;; since after-find-file will clobber it. + (let ((global-hook (default-value 'after-revert-hook)) + (local-hook-p (local-variable-p 'after-revert-hook + (current-buffer))) + (local-hook (and (local-variable-p 'after-revert-hook + (current-buffer)) + after-revert-hook))) + (let (buffer-read-only + ;; Don't make undo records for the reversion. + (buffer-undo-list t)) + (if revert-buffer-insert-file-contents-function + (funcall revert-buffer-insert-file-contents-function + file-name auto-save-p) + (if (not (file-exists-p file-name)) + (error "File %s no longer exists!" file-name)) + ;; Bind buffer-file-name to nil + ;; so that we don't try to lock the file. + (let ((buffer-file-name nil)) + (or auto-save-p + (unlock-buffer))) + (widen) + (insert-file-contents file-name (not auto-save-p) + nil nil t))) + (goto-char (min opoint (point-max))) + ;; Recompute the truename in case changes in symlinks + ;; have changed the truename. + ;XEmacs: already done by insert-file-contents + ;;(setq buffer-file-truename + ;;(abbreviate-file-name (file-truename buffer-file-name))) + (after-find-file nil nil t t preserve-modes) + ;; Run after-revert-hook as it was before we reverted. + (setq-default revert-buffer-internal-hook global-hook) + (if local-hook-p + (progn + (make-local-variable 'revert-buffer-internal-hook) + (setq revert-buffer-internal-hook local-hook)) + (kill-local-variable 'revert-buffer-internal-hook)) + (run-hooks 'revert-buffer-internal-hook)) + t))))) + +(defun recover-file (file) + "Visit file FILE, but get contents from its last auto-save file." + ;; Actually putting the file name in the minibuffer should be used + ;; only rarely. + ;; Not just because users often use the default. + (interactive "FRecover file: ") + (setq file (expand-file-name file)) + (let ((handler (or (find-file-name-handler file 'recover-file) + (find-file-name-handler + (let ((buffer-file-name file)) + (make-auto-save-file-name)) + 'recover-file)))) + (if handler + (funcall handler 'recover-file file) + (if (auto-save-file-name-p file) + (error "%s is an auto-save file" file)) + (let ((file-name (let ((buffer-file-name file)) + (make-auto-save-file-name)))) + (cond ((if (file-exists-p file) + (not (file-newer-than-file-p file-name file)) + (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))) + (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)) + (erase-buffer) + (insert-file-contents file-name nil)) + (after-find-file nil nil t)) + (t (error "Recover-file cancelled."))))))) + +(defun recover-session () + "Recover auto save files from a previous Emacs session. +This command first displays a Dired buffer showing you the +previous sessions that you could recover from. +To choose one, move point to the proper line and then type C-c C-c. +Then you'll be asked about a number of files to recover." + (interactive) + (dired (concat auto-save-list-file-prefix "*")) + (goto-char (point-min)) + (or (looking-at "Move to the session you want to recover,") + (let ((inhibit-read-only t)) + (insert "Move to the session you want to recover,\n" + "then type C-c C-c to select it.\n\n" + "You can also delete some of these files;\n" + "type d on a line to mark that file for deletion.\n\n"))) + (use-local-map (let ((map (make-sparse-keymap))) + (set-keymap-parents map (list (current-local-map))) + map)) + (define-key (current-local-map) "\C-c\C-c" 'recover-session-finish)) + +(defun recover-session-finish () + "Choose one saved session to recover auto-save files from. +This command is used in the special Dired buffer created by +\\[recover-session]." + (interactive) + ;; Get the name of the session file to recover from. + (let ((file (dired-get-filename)) + files + (buffer (get-buffer-create " *recover*"))) + ;; #### dired-do-flagged-delete in FSF. + ;; This version is for ange-ftp + ;;(dired-do-deletions t) + ;; This version is for efs + (dired-expunge-deletions) + (unwind-protect + (save-excursion + ;; Read in the auto-save-list file. + (set-buffer buffer) + (erase-buffer) + (insert-file-contents file) + ;; Loop thru the text of that file + ;; and get out the names of the files to recover. + (while (not (eobp)) + (let (thisfile autofile) + (if (eolp) + ;; This is a pair of lines for a non-file-visiting buffer. + ;; Get the auto-save file name and manufacture + ;; a "visited file name" from that. + (progn + (forward-line 1) + (setq autofile + (buffer-substring-no-properties + (point) + (save-excursion + (end-of-line) + (point)))) + (setq thisfile + (expand-file-name + (substring + (file-name-nondirectory autofile) + 1 -1) + (file-name-directory autofile))) + (forward-line 1)) + ;; This pair of lines is a file-visiting + ;; buffer. Use the visited file name. + (progn + (setq thisfile + (buffer-substring-no-properties + (point) (progn (end-of-line) (point)))) + (forward-line 1) + (setq autofile + (buffer-substring-no-properties + (point) (progn (end-of-line) (point)))) + (forward-line 1))) + ;; Ignore a file if its auto-save file does not exist now. + (if (file-exists-p autofile) + (setq files (cons thisfile files))))) + (setq files (nreverse files)) + ;; The file contains a pair of line for each auto-saved buffer. + ;; The first line of the pair contains the visited file name + ;; or is empty if the buffer was not visiting a file. + ;; The second line is the auto-save file name. + (if files + (map-y-or-n-p "Recover %s? " + (lambda (file) + (condition-case nil + (save-excursion (recover-file file)) + (error + "Failed to recover `%s'" file))) + files + '("file" "files" "recover")) + (message "No files can be recovered from this session now"))) + (kill-buffer buffer)))) + +(defun kill-some-buffers () + "For each buffer, ask whether to kill it." + (interactive) + (let ((list (buffer-list))) + (while list + (let* ((buffer (car list)) + (name (buffer-name buffer))) + (and (not (string-equal name "")) + (/= (aref name 0) ? ) + (yes-or-no-p + (format + (if (buffer-modified-p buffer) + (gettext "Buffer %s HAS BEEN EDITED. Kill? ") + (gettext "Buffer %s is unmodified. Kill? ")) + name)) + (kill-buffer buffer))) + (setq list (cdr list))))) + +(defun auto-save-mode (arg) + "Toggle auto-saving of contents of current buffer. +With prefix argument ARG, turn auto-saving on if positive, else off." + (interactive "P") + (setq buffer-auto-save-file-name + (and (if (null arg) + (or (not buffer-auto-save-file-name) + ;; If autosave is off because buffer has shrunk, + ;; then toggling should turn it on. + (< buffer-saved-size 0)) + (or (eq arg t) (listp arg) (and (integerp arg) (> arg 0)))) + (if (and buffer-file-name auto-save-visited-file-name + (not buffer-read-only)) + buffer-file-name + (make-auto-save-file-name)))) + ;; If -1 was stored here, to temporarily turn off saving, + ;; turn it back on. + (and (< buffer-saved-size 0) + (setq buffer-saved-size 0)) + (if (interactive-p) + (if buffer-auto-save-file-name ;; rewritten for I18N3 snarfing + (display-message 'command "Auto-save on (in this buffer)") + (display-message 'command "Auto-save off (in this buffer)"))) + buffer-auto-save-file-name) + +(defun rename-auto-save-file () + "Adjust current buffer's auto save file name for current conditions. +Also rename any existing auto save file, if it was made in this session." + (let ((osave buffer-auto-save-file-name)) + (setq buffer-auto-save-file-name + (make-auto-save-file-name)) + (if (and osave buffer-auto-save-file-name + (not (string= buffer-auto-save-file-name buffer-file-name)) + (not (string= buffer-auto-save-file-name osave)) + (file-exists-p osave) + (recent-auto-save-p)) + (rename-file osave buffer-auto-save-file-name t)))) + +;; see also ../packages/auto-save.el +(defun make-auto-save-file-name (&optional filename) + "Return file name to use for auto-saves of current buffer. +Does not consider `auto-save-visited-file-name' as that variable is checked +before calling this function. You can redefine this for customization. +See also `auto-save-file-name-p'." + (let ((fname (or filename buffer-file-name)) + name) + (setq name + (if fname + (concat (file-name-directory fname) + "#" + (file-name-nondirectory fname) + "#") + + ;; Deal with buffers that don't have any associated files. (Mail + ;; mode tends to create a good number of these.) + + (let ((buffer-name (buffer-name)) + (limit 0)) + ;; Use technique from Sebastian Kremer's auto-save + ;; package to turn slashes into \\!. This ensures that + ;; the auto-save buffer name is unique. + + ;; #### - yuck! yuck! yuck! move this functionality + ;; somewhere else and make the name translation customizable. + ;; Using "\!" as part of a filename on a UNIX filesystem is nearly + ;; IMPOSSIBLE to get past a shell parser. -stig + + (while (string-match "[/\\]" buffer-name limit) + (setq buffer-name + (concat (substring buffer-name 0 (match-beginning 0)) + (if (string= (substring buffer-name + (match-beginning 0) + (match-end 0)) + "/") + "\\!" + "\\\\") + (substring buffer-name (match-end 0)))) + (setq limit (1+ (match-end 0)))) + + ;; (expand-file-name (format "#%s#%s#" (buffer-name) (make-temp-name ""))) + + ;; jwz: putting the emacs PID in the auto-save file name + ;; is bad news, because that defeats auto-save-recovery of + ;; *mail* buffers -- the (sensible) code in sendmail.el + ;; calls (make-auto-save-file-name) to determine whether + ;; there is unsent, auto-saved mail to recover. If that + ;; mail came from a previous emacs process (far and away + ;; the most likely case) then this can never succeed as + ;; the pid differs. + + (expand-file-name (format "#%s#" buffer-name))) + )) + ;; don't try to write auto-save files in unwritable places. Unless + ;; there's already an autosave file here, put ours somewhere safe. --Stig + (if (or (file-writable-p name) + (file-exists-p name)) + name + (expand-file-name (concat "~/" (file-name-nondirectory name)))))) + +(defun auto-save-file-name-p (filename) + "Return non-nil if FILENAME can be yielded by `make-auto-save-file-name'. +FILENAME should lack slashes. +You can redefine this for customization." + (string-match "\\`#.*#\\'" filename)) + +(defcustom list-directory-brief-switches + (if (eq system-type 'vax-vms) "" "-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") + "*Switches for list-directory to pass to `ls' for verbose listing," + :type 'string + :group 'dired) + +(defun list-directory (dirname &optional verbose) + "Display a list of files in or matching DIRNAME, a la `ls'. +DIRNAME is globbed by the shell if necessary. +Prefix arg (second arg if noninteractive) means supply -l switch to `ls'. +Actions controlled by variables `list-directory-brief-switches' +and `list-directory-verbose-switches'." + (interactive (let ((pfx current-prefix-arg)) + (list (read-file-name (if pfx (gettext "List directory (verbose): ") + (gettext "List directory (brief): ")) + nil default-directory nil) + pfx))) + (let ((switches (if verbose list-directory-verbose-switches + list-directory-brief-switches))) + (or dirname (setq dirname default-directory)) + (setq dirname (expand-file-name dirname)) + (with-output-to-temp-buffer "*Directory*" + (buffer-disable-undo standard-output) + (princ "Directory ") + (princ dirname) + (terpri) + (save-excursion + (set-buffer "*Directory*") + (setq default-directory (file-name-directory dirname)) + (let ((wildcard (not (file-directory-p dirname)))) + (insert-directory dirname switches wildcard (not wildcard))))))) + +(defvar insert-directory-program "ls" + "Absolute or relative name of the `ls' program used by `insert-directory'.") + +;; insert-directory +;; - must insert _exactly_one_line_ describing FILE if WILDCARD and +;; FULL-DIRECTORY-P is nil. +;; The single line of output must display FILE's name as it was +;; given, namely, an absolute path name. +;; - must insert exactly one line for each file if WILDCARD or +;; FULL-DIRECTORY-P is t, plus one optional "total" line +;; before the file lines, plus optional text after the file lines. +;; Lines are delimited by "\n", so filenames containing "\n" are not +;; allowed. +;; File lines should display the basename. +;; - must be consistent with +;; - functions dired-move-to-filename, (these two define what a file line is) +;; dired-move-to-end-of-filename, +;; dired-between-files, (shortcut for (not (dired-move-to-filename))) +;; dired-insert-headerline +;; dired-after-subdir-garbage (defines what a "total" line is) +;; - variable dired-subdir-regexp +(defun insert-directory (file switches &optional wildcard full-directory-p) + "Insert directory listing for FILE, formatted according to SWITCHES. +Leaves point after the inserted text. +SWITCHES may be a string of options, or a list of strings. +Optional third arg WILDCARD means treat FILE as shell wildcard. +Optional fourth arg FULL-DIRECTORY-P means file is a directory and +switches do not contain `d', so that a full listing is expected. + +This works by running a directory listing program +whose name is in the variable `insert-directory-program'. +If WILDCARD, it also runs the shell specified by `shell-file-name'." + ;; We need the directory in order to find the right handler. + (let ((handler (find-file-name-handler (expand-file-name file) + 'insert-directory))) + (if handler + (funcall handler 'insert-directory file switches + wildcard full-directory-p) + (if (eq system-type 'vax-vms) + (vms-read-directory file switches (current-buffer)) + (if wildcard + ;; Run ls in the directory of the file pattern we asked for. + (let ((default-directory + (if (file-name-absolute-p file) + (file-name-directory file) + (file-name-directory (expand-file-name file)))) + (pattern (file-name-nondirectory file)) + (beg 0)) + ;; Quote some characters that have special meanings in shells; + ;; but don't quote the wildcards--we want them to be special. + ;; We also currently don't quote the quoting characters + ;; in case people want to use them explicitly to quote + ;; wildcard characters. + ;;#### Unix-specific + (while (string-match "[ \t\n;<>&|()#$]" pattern beg) + (setq pattern + (concat (substring pattern 0 (match-beginning 0)) + "\\" + (substring pattern (match-beginning 0))) + beg (1+ (match-end 0)))) + (call-process shell-file-name nil t nil + "-c" (concat "\\" ;; Disregard shell aliases! + insert-directory-program + " -d " + (if (stringp switches) + switches + (mapconcat 'identity switches " ")) + " " + pattern))) + ;; SunOS 4.1.3, SVr4 and others need the "." to list the + ;; directory if FILE is a symbolic link. + (apply 'call-process + insert-directory-program nil t nil + (let (list) + (if (listp switches) + (setq list switches) + (if (not (equal switches "")) + (progn + ;; Split the switches at any spaces + ;; so we can pass separate options as separate args. + (while (string-match " " switches) + (setq list (cons (substring switches 0 (match-beginning 0)) + list) + switches (substring switches (match-end 0)))) + (setq list (cons switches list))))) + (append list + (list + (if full-directory-p + (concat (file-name-as-directory file) + ;;#### Unix-specific + ".") + file)))))))))) + +(defvar kill-emacs-query-functions nil + "Functions to call with no arguments to query about killing XEmacs. +If any of these functions returns nil, killing Emacs is cancelled. +`save-buffers-kill-emacs' (\\[save-buffers-kill-emacs]) calls these functions, +but `kill-emacs', the low level primitive, does not. +See also `kill-emacs-hook'.") + +(defun save-buffers-kill-emacs (&optional arg) + "Offer to save each buffer, then kill this XEmacs process. +With prefix arg, silently save all file-visiting buffers, then kill." + (interactive "P") + (save-some-buffers arg t) + (and (or (not (memq t (mapcar #'(lambda (buf) (and (buffer-file-name buf) + (buffer-modified-p buf))) + (buffer-list)))) + (yes-or-no-p "Modified buffers exist; exit anyway? ")) + (or (not (fboundp 'process-list)) + ;; process-list is not defined on VMS. + (let ((processes (process-list)) + active) + (while processes + (and (memq (process-status (car processes)) '(run stop open)) + (let ((val (process-kill-without-query (car processes)))) + (process-kill-without-query (car processes) val) + val) + (setq active t)) + (setq processes (cdr processes))) + (or + (not active) + (save-excursion + (save-window-excursion + (delete-other-windows) + (list-processes) + (yes-or-no-p + "Active processes exist; kill them and exit anyway? ")))))) + ;; Query the user for other things, perhaps. + (run-hook-with-args-until-failure 'kill-emacs-query-functions) + (kill-emacs))) + +(defun symlink-expand-file-name (filename) + "If FILENAME is a symlink, return its non-symlink equivalent. +Unlike `file-truename', this doesn't chase symlinks in directory +components of the file or expand a relative pathname into an +absolute one." + (let ((count 20)) + (while (and (> count 0) (file-symlink-p filename)) + (setq filename (file-symlink-p filename) + count (1- count))) + (if (> count 0) + filename + (error "Apparently circular symlink path")))) + +;; Suggested by Michael Kifer <kifer@CS.SunySB.EDU> +(defun file-remote-p (file-name) + "Test whether FILE-NAME is looked for on a remote system." + (cond ((not allow-remote-paths) nil) + ((featurep 'ange-ftp) (ange-ftp-ftp-path file-name)) + (t (efs-ftp-path file-name)))) + +;;; files.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/fill.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,1061 @@ +;;; fill.el --- fill commands for XEmacs. + +;; Copyright (C) 1985, 86, 92, 94, 95, 1997 Free Software Foundation, Inc. + +;; Maintainer: XEmacs Development Team +;; Keywords: wp, dumped + +;; 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.34. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;; All the commands for filling text. These are documented in the XEmacs +;; Reference Manual. + +;; 97/3/14 Jareth Hein (jhod@po.iijnet.or.jp) added functions for kinsoku (asian text +;; line break processing) +;; 97/06/11 Steve Baur (steve@altair.xemacs.org) converted broken +;; following-char/preceding-char calls to char-after/char-before. + +;;; Code: + +(defconst fill-individual-varying-indent nil + "*Controls criterion for a new paragraph in `fill-individual-paragraphs'. +Non-nil means changing indent doesn't end a paragraph. +That mode can handle paragraphs with extra indentation on the first line, +but it requires separator lines between paragraphs. +A value of nil means that any change in indentation starts a new paragraph.") + +(defconst sentence-end-double-space t + "*Non-nil means a single space does not end a sentence. +This variable applies only to filling, not motion commands. To +change the behavior of motion commands, see `sentence-end'.") + +(defconst colon-double-space nil + "*Non-nil means put two spaces after a colon when filling.") + +(defvar fill-paragraph-function nil + "Mode-specific function to fill a paragraph, or nil if there is none. +If the function returns nil, then `fill-paragraph' does its normal work.") + +(defun set-fill-prefix () + "Set the fill prefix to the current line up to point. +Filling expects lines to start with the fill prefix and +reinserts the fill prefix in each resulting line." + (interactive) + (setq fill-prefix (buffer-substring + (save-excursion (move-to-left-margin) (point)) + (point))) + (if (equal fill-prefix "") + (setq fill-prefix nil)) + (if fill-prefix + (message "fill-prefix: \"%s\"" fill-prefix) + (message "fill-prefix cancelled"))) + +(defconst adaptive-fill-mode t + "*Non-nil means determine a paragraph's fill prefix from its text.") + +;; #### - this is still weak. Yeah, there's filladapt, but this should +;; still be better... --Stig +(defconst adaptive-fill-regexp (purecopy "[ \t]*\\([#;>*]+ +\\)?") + "*Regexp to match text at start of line that constitutes indentation. +If Adaptive Fill mode is enabled, whatever text matches this pattern +on the second line of a paragraph is used as the standard indentation +for the paragraph. If the paragraph has just one line, the indentation +is taken from that line.") + +(defvar adaptive-fill-function nil + "*Function to call to choose a fill prefix for a paragraph. +This function is used when `adaptive-fill-regexp' does not match.") + +;; Added for kinsoku processing. Use this instead of +;; (skip-chars-backward "^ \t\n") +;; (skip-chars-backward "^ \n" linebeg) +(defun fill-move-backward-to-break-point (regexp &optional lim) + (let ((opoint (point))) + ;; 93.8.23 by kawamoto@ics.es.osaka-u.ac.jp + ;; case of first 'word' being longer than fill-column + (if (not (re-search-backward regexp lim 'move)) + nil + ;; we have skipped backward SPC or WAN (word-across-newline). So move point forward again. + (forward-char) + (if (< opoint (point)) + (forward-char -1))))) + +;; Added for kinsoku processing. Use instead of +;; (re-search-forward "[ \t]" opoint t) +;; (skip-chars-forward "^ \n") +;; (skip-chars-forward "^ \n") +(defun fill-move-forward-to-break-point (regexp &optional lim) + (let ((opoint (point))) + (if (not (re-search-forward regexp lim 'move)) + nil + (forward-char -1) + (if (< (point) opoint) + (forward-char)))) + (if (featurep 'mule) (kinsoku-process-extend))) + +(defun fill-end-of-sentence-p () + (save-excursion + (skip-chars-backward " ]})\"'") + (memq (char-before (point)) '(?. ?? ?!)))) + +(defun current-fill-column () + "Return the fill-column to use for this line. +The fill-column to use for a buffer is stored in the variable `fill-column', +but can be locally modified by the `right-margin' text property, which is +subtracted from `fill-column'. + +The fill column to use for a line is the first column at which the column +number equals or exceeds the local fill-column - right-margin difference." + (save-excursion + (if fill-column + (let* ((here (progn (beginning-of-line) (point))) + (here-col 0) + (eol (progn (end-of-line) (point))) + margin fill-col change col) + ;; Look separately at each region of line with a different right-margin. + (while (and (setq margin (get-text-property here 'right-margin) + fill-col (- fill-column (or margin 0)) + change (text-property-not-all + here eol 'right-margin margin)) + (progn (goto-char (1- change)) + (setq col (current-column)) + (< col fill-col))) + (setq here change + here-col col)) + (max here-col fill-col))))) + +(defun canonically-space-region (beg end) + "Remove extra spaces between words in region. +Leave one space between words, two at end of sentences or after colons +\(depending on values of `sentence-end-double-space' and `colon-double-space'). +Remove indentation from each line." + (interactive "r") + ;;;### 97/3/14 jhod: Do I have to add anything here for kinsoku? + (save-excursion + (goto-char beg) + ;; XEmacs - (ENE/stig from fa-extras.el): Skip the start of a comment. + (and comment-start-skip + (looking-at comment-start-skip) + (goto-char (match-end 0))) + ;; Nuke tabs; they get screwed up in a fill. + ;; This is quick, but loses when a tab follows the end of a sentence. + ;; Actually, it is difficult to tell that from "Mr.\tSmith". + ;; Blame the typist. + (subst-char-in-region beg end ?\t ?\ ) + (while (and (< (point) end) + (re-search-forward " *" end t)) + (delete-region + (+ (match-beginning 0) + ;; Determine number of spaces to leave: + (save-excursion + (skip-chars-backward " ]})\"'") + (cond ((and sentence-end-double-space + (memq (char-before (point)) '(?. ?? ?!))) 2) + ((and colon-double-space + (eq (char-before (point)) ?:)) 2) + ((char-equal (char-before (point)) ?\n) 0) + (t 1)))) + (match-end 0))) + ;; Make sure sentences ending at end of line get an extra space. + ;; loses on split abbrevs ("Mr.\nSmith") + (goto-char beg) + (while (and (< (point) end) + (re-search-forward "[.?!][])}\"']*$" end t)) + ;; We insert before markers in case a caller such as + ;; do-auto-fill has done a save-excursion with point at the end + ;; of the line and wants it to stay at the end of the line. + (insert ? )))) +;; XEmacs: we don't have this function. +;; (insert-before-markers-and-inherit ? )))) + +;; XEmacs -- added DONT-SKIP-FIRST. Port of older code changes by Stig. +;; #### probably this junk is broken -- do-auto-fill doesn't actually use +;; it. If so, it should be removed. + +(defun fill-context-prefix (from to &optional first-line-regexp + dont-skip-first) + "Compute a fill prefix from the text between FROM and TO. +This uses the variables `adaptive-fill-prefix' and `adaptive-fill-function'. +If FIRST-LINE-REGEXP is non-nil, then when taking a prefix from the +first line, insist it must match FIRST-LINE-REGEXP." + (save-excursion + (goto-char from) + (if (eolp) (forward-line 1)) + ;; Move to the second line unless there is just one. + (let ((firstline (point)) + ;; Non-nil if we are on the second line. + at-second + result) + ;; XEmacs change + (if (not dont-skip-first) + (forward-line 1)) + (if (>= (point) to) + (goto-char firstline) + (setq at-second t)) + (move-to-left-margin) + ;; XEmacs change + (let ((start (point)) + ; jhod: no longer used? + ;(eol (save-excursion (end-of-line) (point))) + ) + (setq result + (if (not (looking-at paragraph-start)) + (cond ((and adaptive-fill-regexp (looking-at adaptive-fill-regexp)) + (buffer-substring-no-properties start (match-end 0))) + (adaptive-fill-function (funcall adaptive-fill-function))))) + (and result + (or at-second + (null first-line-regexp) + (string-match first-line-regexp result)) + result))))) + +;; XEmacs (stig) - this is pulled out of fill-region-as-paragraph so that it +;; can also be called from do-auto-fill +;; #### But it's not used there. Chuck pulled it out because it broke things. +(defun maybe-adapt-fill-prefix (&optional from to dont-skip-first) + (if (and adaptive-fill-mode + (or (null fill-prefix) (string= fill-prefix ""))) + (setq fill-prefix (fill-context-prefix from to nil dont-skip-first)))) + +(defun fill-region-as-paragraph (from to &optional justify + nosqueeze squeeze-after) + "Fill the region as one paragraph. +It removes any paragraph breaks in the region and extra newlines at the end, +indents and fills lines between the margins given by the +`current-left-margin' and `current-fill-column' functions. +It leaves point at the beginning of the line following the paragraph. + +Normally performs justification according to the `current-justification' +function, but with a prefix arg, does full justification instead. + +From a program, optional third arg JUSTIFY can specify any type of +justification. Fourth arg NOSQUEEZE non-nil means not to make spaces +between words canonical before filling. Fifth arg SQUEEZE-AFTER, if non-nil, +means don't canonicalize spaces before that position. + +If `sentence-end-double-space' is non-nil, then period followed by one +space does not end a sentence, so don't break a line there." + (interactive + (progn + ;; XEmacs addition: + (barf-if-buffer-read-only nil (region-beginning) (region-end)) + (list (region-beginning) (region-end) + (if current-prefix-arg 'full)))) + ;; Arrange for undoing the fill to restore point. + (if (and buffer-undo-list (not (eq buffer-undo-list t))) + (setq buffer-undo-list (cons (point) buffer-undo-list))) + + ;; Make sure "to" is the endpoint. + (goto-char (min from to)) + (setq to (max from to)) + ;; Ignore blank lines at beginning of region. + (skip-chars-forward " \t\n") + + (let ((from-plus-indent (point)) + (oneleft nil)) + + (beginning-of-line) + (setq from (point)) + + ;; Delete all but one soft newline at end of region. + ;; And leave TO before that one. + (goto-char to) + (while (and (> (point) from) (eq ?\n (char-after (1- (point))))) + (if (and oneleft + (not (and use-hard-newlines + (get-text-property (1- (point)) 'hard)))) + (delete-backward-char 1) + (backward-char 1) + (setq oneleft t))) + (setq to (point)) + + ;; If there was no newline, and there is text in the paragraph, then + ;; create a newline. + (if (and (not oneleft) (> to from-plus-indent)) + (newline)) + (goto-char from-plus-indent)) + + (if (not (> to (point))) + nil ; There is no paragraph, only whitespace: exit now. + + (or justify (setq justify (current-justification))) + + ;; Don't let Adaptive Fill mode alter the fill prefix permanently. + (let ((fill-prefix fill-prefix)) + ;; Figure out how this paragraph is indented, if desired. + ;; XEmacs: move some code here to a separate function. + (maybe-adapt-fill-prefix from to t) + + (save-restriction + (goto-char from) + (beginning-of-line) + (narrow-to-region (point) to) + + (if (not justify) ; filling disabled: just check indentation + (progn + (goto-char from) + (while (not (eobp)) + (if (and (not (eolp)) + (< (current-indentation) (current-left-margin))) + (indent-to-left-margin)) + (forward-line 1))) + + (if use-hard-newlines + (remove-text-properties from (point-max) '(hard nil))) + ;; Make sure first line is indented (at least) to left margin... + (if (or (memq justify '(right center)) + (< (current-indentation) (current-left-margin))) + (indent-to-left-margin)) + ;; Delete the fill prefix from every line except the first. + ;; The first line may not even have a fill prefix. + (goto-char from) + (let ((fpre (and fill-prefix (not (equal fill-prefix "")) + (concat "[ \t]*" + (regexp-quote fill-prefix) + "[ \t]*")))) + (and fpre + (progn + (if (>= (+ (current-left-margin) (length fill-prefix)) + (current-fill-column)) + (error "fill-prefix too long for specified width")) + (goto-char from) + (forward-line 1) + (while (not (eobp)) + (if (looking-at fpre) + (delete-region (point) (match-end 0))) + (forward-line 1)) + (goto-char from) + (if (looking-at fpre) + (goto-char (match-end 0))) + (setq from (point))))) + ;; Remove indentation from lines other than the first. + (beginning-of-line 2) + (indent-region (point) (point-max) 0) + (goto-char from) + + ;; FROM, and point, are now before the text to fill, + ;; but after any fill prefix on the first line. + + ;; Make sure sentences ending at end of line get an extra space. + ;; loses on split abbrevs ("Mr.\nSmith") + (while (re-search-forward "[.?!][])}\"']*$" nil t) + ;; XEmacs change (no insert-and-inherit) + (or (eobp) (insert ?\ ?\ ))) + (goto-char from) + (skip-chars-forward " \t") + ;; Then change all newlines to spaces. + ;;; 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. + (if (not (and (featurep 'mule) + (stringp word-across-newline))) + (subst-char-in-region from (point-max) ?\n ?\ ) + ;; + ;; WAN +NL+WAN --> WAN + WAN + ;; not(WAN)+NL+WAN --> not(WAN) + WAN + ;; WAN +NL+not(WAN) --> WAN + not(WAN) + ;; SPC +NL+not(WAN) --> SPC + not(WAN) + ;; not(WAN)+NL+not(WAN) --> not(WAN) + SPC + not(WAN) + ;; + (goto-char from) + (end-of-line) + (while (not (eobp)) + ;; Insert SPC only when point is between nonWAN. Insert + ;; before deleting to preserve marker if possible. + (if (or (prog2 ; check following char. + (forward-char) ; skip newline + (or (eobp) + (looking-at word-across-newline)) + (forward-char -1)) + (prog2 ; check previous char. + (forward-char -1) + (or (eq (char-after (point)) ?\ ) + (looking-at word-across-newline)) + (forward-char))) + nil + (insert ?\ )) + (delete-char 1) ; delete newline + (end-of-line))) + ;; end patch + (goto-char from) + (skip-chars-forward " \t") + (if (and nosqueeze (not (eq justify 'full))) + nil + (canonically-space-region (or squeeze-after (point)) (point-max)) + (goto-char (point-max)) + (delete-horizontal-space) + ;; XEmacs change (no insert-and-inherit) + (insert " ")) + (goto-char (point-min)) + + ;; This is the actual filling loop. + (let ((prefixcol 0) linebeg + (re-break-point (if (featurep 'mule) + (concat "[ \n\t]\\|" word-across-newline) + "[ \n\t]"))) + (while (not (eobp)) + (setq linebeg (point)) + (move-to-column (1+ (current-fill-column))) + (if (eobp) + (or nosqueeze (delete-horizontal-space)) + ;; Move back to start of word. + ;; 97/3/14 jhod: Kinsoku + ;(skip-chars-backward "^ \n" linebeg) + (fill-move-backward-to-break-point re-break-point linebeg) + ;; end patch + ;; Don't break after a period followed by just one space. + ;; Move back to the previous place to break. + ;; The reason is that if a period ends up at the end of a line, + ;; further fills will assume it ends a sentence. + ;; If we now know it does not end a sentence, + ;; avoid putting it at the end of the line. + (if sentence-end-double-space + (while (and (> (point) (+ linebeg 2)) + (eq (char-before (point)) ?\ ) + (not (eq (char-after (point)) ?\ )) + (eq (char-after (- (point) 2)) ?\.)) + (forward-char -2) + ;; 97/3/14 jhod: Kinsoku + ;(skip-chars-backward "^ \n" linebeg))) + (fill-move-backward-to-break-point re-break-point linebeg))) + (if (featurep 'mule) (kinsoku-process)) + ;end patch + + ;; If the left margin and fill prefix by themselves + ;; pass the fill-column. or if they are zero + ;; but we have no room for even one word, + ;; keep at least one word anyway. + ;; This handles ALL BUT the first line of the paragraph. + (if (if (zerop prefixcol) + (save-excursion + (skip-chars-backward " \t" linebeg) + (bolp)) + (>= prefixcol (current-column))) + ;; Ok, skip at least one word. + ;; Meanwhile, don't stop at a period followed by one space. + (let ((first t)) + (move-to-column prefixcol) + (while (and (not (eobp)) + (or first + (and (not (bobp)) + sentence-end-double-space + (save-excursion (forward-char -1) + (and (looking-at "\\. ") + (not (looking-at "\\. "))))))) + (skip-chars-forward " \t") + ;; 94/3/14 jhod: Kinsoku + ;(skip-chars-forward "^ \n\t") + (fill-move-forward-to-break-point re-break-point) + ;; end patch + (setq first nil))) + ;; Normally, move back over the single space between the words. + (if (eq (char-before (point)) ?\ ) + (forward-char -1))) + ;; If the left margin and fill prefix by themselves + ;; pass the fill-column, keep at least one word. + ;; This handles the first line of the paragraph. + (if (and (zerop prefixcol) + (let ((fill-point (point)) nchars) + (save-excursion + (move-to-left-margin) + (setq nchars (- fill-point (point))) + (or (< nchars 0) + (and fill-prefix + (< nchars (length fill-prefix)) + (string= (buffer-substring (point) fill-point) + (substring fill-prefix 0 nchars))))))) + ;; Ok, skip at least one word. But + ;; don't stop at a period followed by just one space. + (let ((first t)) + (while (and (not (eobp)) + (or first + (and (not (bobp)) + sentence-end-double-space + (save-excursion (forward-char -1) + (and (looking-at "\\. ") + (not (looking-at "\\. "))))))) + (skip-chars-forward " \t") + ;; 97/3/14 jhod: Kinsoku + ;(skip-chars-forward "^ \t\n") + (fill-move-forward-to-break-point re-break-point) + ;; end patch + (setq first nil)))) + ;; Check again to see if we got to the end of the paragraph. + (if (save-excursion (skip-chars-forward " \t") (eobp)) + (or nosqueeze (delete-horizontal-space)) + ;; Replace whitespace here with one newline, then indent to left + ;; margin. + (skip-chars-backward " \t") + ;; 97/3/14 jhod: More kinsoku stuff + (if (featurep 'mule) + ;; WAN means chars which match word-across-newline. + ;; (0) | SPC + SPC* <EOB> --> NL + ;; (1) WAN | SPC + SPC* --> WAN + SPC + NL + ;; (2) | SPC + SPC* + WAN --> SPC + NL + WAN + ;; (3) '.' | SPC + nonSPC --> '.' + SPC + NL + nonSPC + ;; (4) '.' | SPC + SPC --> '.' + NL + ;; (5) | SPC* --> NL + (let ((start (point)) ; 92.6.30 by K.Handa + (ch (char-after (point)))) + (if (and (= ch ? ) + (progn ; not case (0) -- 92.6.30 by K.Handa + (skip-chars-forward " \t") + (not (eobp))) + (or + (progn ; case (1) + (goto-char start) + (forward-char -1) + (looking-at word-across-newline)) + (progn ; case (2) + (goto-char start) + (skip-chars-forward " \t") + (and (not (eobp)) + (looking-at word-across-newline) + ;; never leave space after the end of sentence + (not (fill-end-of-sentence-p)))) + (progn ; case (3) + (goto-char (1+ start)) + (and (not (eobp)) + (not (eq (char-after (point)) ? )) + (fill-end-of-sentence-p))))) + ;; We should keep one SPACE before NEWLINE. (1),(2),(3) + (goto-char (1+ start)) + ;; We should delete all SPACES around break point. (4),(5) + (goto-char start)))) + ;; end of patch + (insert ?\n) + ;; Give newline the properties of the space(s) it replaces + (set-text-properties (1- (point)) (point) + (text-properties-at (point))) + (indent-to-left-margin) + ;; Insert the fill prefix after indentation. + ;; Set prefixcol so whitespace in the prefix won't get lost. + (and fill-prefix (not (equal fill-prefix "")) + (progn + (insert fill-prefix) + (setq prefixcol (current-column)))))) + ;; Justify the line just ended, if desired. + (if justify + (if (save-excursion (skip-chars-forward " \t") (eobp)) + (progn + (delete-horizontal-space) + (justify-current-line justify t t)) + (forward-line -1) + (justify-current-line justify nil t) + (forward-line 1)))))) + ;; Leave point after final newline. + (goto-char (point-max))) + (forward-char 1)))) + +(defun fill-paragraph (arg) + "Fill paragraph at or after point. Prefix arg means justify as well. +If `sentence-end-double-space' is non-nil, then period followed by one +space does not end a sentence, so don't break a line there. + +If `fill-paragraph-function' is non-nil, we call it (passing our +argument to it), and if it returns non-nil, we simply return its value." + (interactive (list (if current-prefix-arg 'full))) + (or (and fill-paragraph-function + (let ((function fill-paragraph-function) + fill-paragraph-function) + (funcall function arg))) + (let ((before (point))) + (save-excursion + (forward-paragraph) + (or (bolp) (newline 1)) + (let ((end (point)) + (beg (progn (backward-paragraph) (point)))) + (goto-char before) + (if use-hard-newlines + ;; Can't use fill-region-as-paragraph, since this paragraph may + ;; still contain hard newlines. See fill-region. + (fill-region beg end arg) + (fill-region-as-paragraph beg end arg))))))) + +(defun fill-region (from to &optional justify nosqueeze to-eop) + "Fill each of the paragraphs in the region. +Prefix arg (non-nil third arg, if called from program) means justify as well. + +Noninteractively, fourth arg NOSQUEEZE non-nil means to leave +whitespace other than line breaks untouched, and fifth arg TO-EOP +non-nil means to keep filling to the end of the paragraph (or next +hard newline, if `use-hard-newlines' is on). + +If `sentence-end-double-space' is non-nil, then period followed by one +space does not end a sentence, so don't break a line there." + (interactive + (progn + ;; XEmacs addition: + (barf-if-buffer-read-only nil (region-beginning) (region-end)) + (list (region-beginning) (region-end) + (if current-prefix-arg 'full)))) + (let (end beg) + (save-restriction + (goto-char (max from to)) + (if to-eop + (progn (skip-chars-backward "\n") + (forward-paragraph))) + (setq end (point)) + (goto-char (setq beg (min from to))) + (beginning-of-line) + (narrow-to-region (point) end) + (while (not (eobp)) + (let ((initial (point)) + end) + ;; If using hard newlines, break at every one for filling + ;; purposes rather than using paragraph breaks. + (if use-hard-newlines + (progn + (while (and (setq end (text-property-any (point) (point-max) + 'hard t)) + (not (eq ?\n (char-after end))) + (not (= end (point-max)))) + (goto-char (1+ end))) + (setq end (if end (min (point-max) (1+ end)) (point-max))) + (goto-char initial)) + (forward-paragraph 1) + (setq end (point)) + (forward-paragraph -1)) + (if (< (point) beg) + (goto-char beg)) + (if (>= (point) initial) + (fill-region-as-paragraph (point) end justify nosqueeze) + (goto-char end))))))) + +;; XEmacs addition: from Tim Bradshaw <tfb@edinburgh.ac.uk> +(defun fill-paragraph-or-region (arg) + "Fill the current region, if it's active; otherwise, fill the paragraph. +See `fill-paragraph' and `fill-region' for more information." + (interactive "*P") + (if (region-active-p) + (fill-region (point) (mark) arg) + (fill-paragraph arg))) + + +(defconst default-justification 'left + "*Method of justifying text not otherwise specified. +Possible values are `left', `right', `full', `center', or `none'. +The requested kind of justification is done whenever lines are filled. +The `justification' text-property can locally override this variable. +This variable automatically becomes buffer-local when set in any fashion.") +(make-variable-buffer-local 'default-justification) + +(defun current-justification () + "How should we justify this line? +This returns the value of the text-property `justification', +or the variable `default-justification' if there is no text-property. +However, it returns nil rather than `none' to mean \"don't justify\"." + (let ((j (or (get-text-property + ;; Make sure we're looking at paragraph body. + (save-excursion (skip-chars-forward " \t") + (if (and (eobp) (not (bobp))) + (1- (point)) (point))) + 'justification) + default-justification))) + (if (eq 'none j) + nil + j))) + +(defun set-justification (begin end value &optional whole-par) + "Set the region's justification style. +The kind of justification to use is prompted for. +If the mark is not active, this command operates on the current paragraph. +If the mark is active, the region is used. However, if the beginning and end +of the region are not at paragraph breaks, they are moved to the beginning and +end of the paragraphs they are in. +If `use-hard-newlines' is true, all hard newlines are taken to be paragraph +breaks. + +When calling from a program, operates just on region between BEGIN and END, +unless optional fourth arg WHOLE-PAR is non-nil. In that case bounds are +extended to include entire paragraphs as in the interactive command." + ;; XEmacs change (was mark-active) + (interactive (list (if (region-active-p) (region-beginning) (point)) + (if (region-active-p) (region-end) (point)) + (let ((s (completing-read + "Set justification to: " + '(("left") ("right") ("full") + ("center") ("none")) + nil t))) + (if (equal s "") (error "")) + (intern s)) + t)) + (save-excursion + (save-restriction + (if whole-par + (let ((paragraph-start (if use-hard-newlines "." paragraph-start)) + (paragraph-ignore-fill-prefix (if use-hard-newlines t + paragraph-ignore-fill-prefix))) + (goto-char begin) + (while (and (bolp) (not (eobp))) (forward-char 1)) + (backward-paragraph) + (setq begin (point)) + (goto-char end) + (skip-chars-backward " \t\n" begin) + (forward-paragraph) + (setq end (point)))) + + (narrow-to-region (point-min) end) + (unjustify-region begin (point-max)) + (put-text-property begin (point-max) 'justification value) + (fill-region begin (point-max) nil t)))) + +(defun set-justification-none (b e) + "Disable automatic filling for paragraphs in the region. +If the mark is not active, this applies to the current paragraph." + ;; XEmacs change (was mark-active) + (interactive (list (if (region-active-p) (region-beginning) (point)) + (if (region-active-p) (region-end) (point)))) + (set-justification b e 'none t)) + +(defun set-justification-left (b e) + "Make paragraphs in the region left-justified. +This is usually the default, but see the variable `default-justification'. +If the mark is not active, this applies to the current paragraph." + ;; XEmacs change (was mark-active) + (interactive (list (if (region-active-p) (region-beginning) (point)) + (if (region-active-p) (region-end) (point)))) + (set-justification b e 'left t)) + +(defun set-justification-right (b e) + "Make paragraphs in the region right-justified: +Flush at the right margin and ragged on the left. +If the mark is not active, this applies to the current paragraph." + ;; XEmacs change (was mark-active) + (interactive (list (if (region-active-p) (region-beginning) (point)) + (if (region-active-p) (region-end) (point)))) + (set-justification b e 'right t)) + +(defun set-justification-full (b e) + "Make paragraphs in the region fully justified: +This makes lines flush on both margins by inserting spaces between words. +If the mark is not active, this applies to the current paragraph." + ;; XEmacs change (was mark-active) + (interactive (list (if (region-active-p) (region-beginning) (point)) + (if (region-active-p) (region-end) (point)))) + (set-justification b e 'full t)) + +(defun set-justification-center (b e) + "Make paragraphs in the region centered. +If the mark is not active, this applies to the current paragraph." + ;; XEmacs change (was mark-active) + (interactive (list (if (region-active-p) (region-beginning) (point)) + (if (region-active-p) (region-end) (point)))) + (set-justification b e 'center t)) + +;; 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" + (if (boundp 'space-insertable) + (if (re-search-backward space-insertable nil t) + (progn (forward-char 1) + t) + nil) + (search-backward " " nil t))) + +;; A line has up to six parts: +;; +;; >>> hello. +;; [Indent-1][FP][ Indent-2 ][text][trailing whitespace][newline] +;; +;; "Indent-1" is the left-margin indentation; normally it ends at column +;; given by the `current-left-margin' function. +;; "FP" is the fill-prefix. It can be any string, including whitespace. +;; "Indent-2" is added to justify a line if the `current-justification' is +;; `center' or `right'. In `left' and `full' justification regions, any +;; whitespace there is part of the line's text, and should not be changed. +;; Trailing whitespace is not counted as part of the line length when +;; center- or right-justifying. +;; +;; All parts of the line are optional, although the final newline can +;; only be missing on the last line of the buffer. + +(defun justify-current-line (&optional how eop nosqueeze) + "Do some kind of justification on this line. +Normally does full justification: adds spaces to the line to make it end at +the column given by `current-fill-column'. +Optional first argument HOW specifies alternate type of justification: +it can be `left', `right', `full', `center', or `none'. +If HOW is t, will justify however the `current-justification' function says to. +If HOW is nil or missing, full justification is done by default. +Second arg EOP non-nil means that this is the last line of the paragraph, so +it will not be stretched by full justification. +Third arg NOSQUEEZE non-nil means to leave interior whitespace unchanged, +otherwise it is made canonical." + (interactive) + (if (eq t how) (setq how (or (current-justification) 'none)) + (if (null how) (setq how 'full) + (or (memq how '(none left right center)) + (setq how 'full)))) + (or (memq how '(none left)) ; No action required for these. + (let ((fc (current-fill-column)) + (pos (point-marker)) + fp-end ; point at end of fill prefix + beg ; point at beginning of line's text + end ; point at end of line's text + indent ; column of `beg' + endcol ; column of `end' + ncols) ; new indent point or offset + (end-of-line) + ;; Check if this is the last line of the paragraph. + (if (and use-hard-newlines (null eop) + (get-text-property (point) 'hard)) + (setq eop t)) + (skip-chars-backward " \t") + ;; Quick exit if it appears to be properly justified already + ;; or there is no text. + (if (or (bolp) + (and (memq how '(full right)) + (= (current-column) fc))) + nil + (setq end (point)) + (beginning-of-line) + (skip-chars-forward " \t") + ;; Skip over fill-prefix. + (if (and fill-prefix + (not (string-equal fill-prefix "")) + (equal fill-prefix + (buffer-substring + (point) (min (point-max) (+ (length fill-prefix) + (point)))))) + (forward-char (length fill-prefix)) + (if (and adaptive-fill-mode + (looking-at adaptive-fill-regexp)) + (goto-char (match-end 0)))) + (setq fp-end (point)) + (skip-chars-forward " \t") + ;; This is beginning of the line's text. + (setq indent (current-column)) + (setq beg (point)) + (goto-char end) + (setq endcol (current-column)) + + ;; HOW can't be null or left--we would have exited already + (cond ((eq 'right how) + (setq ncols (- fc endcol)) + (if (< ncols 0) + ;; Need to remove some indentation + (delete-region + (progn (goto-char fp-end) + (if (< (current-column) (+ indent ncols)) + (move-to-column (+ indent ncols) t)) + (point)) + (progn (move-to-column indent) (point))) + ;; Need to add some + (goto-char beg) + (indent-to (+ indent ncols)) + ;; If point was at beginning of text, keep it there. + (if (= beg pos) + (move-marker pos (point))))) + + ((eq 'center how) + ;; Figure out how much indentation is needed + (setq ncols (+ (current-left-margin) + (/ (- fc (current-left-margin) ;avail. space + (- endcol indent)) ;text width + 2))) + (if (< ncols indent) + ;; Have too much indentation - remove some + (delete-region + (progn (goto-char fp-end) + (if (< (current-column) ncols) + (move-to-column ncols t)) + (point)) + (progn (move-to-column indent) (point))) + ;; Have too little - add some + (goto-char beg) + (indent-to ncols) + ;; If point was at beginning of text, keep it there. + (if (= beg pos) + (move-marker pos (point))))) + + ((eq 'full how) + ;; Insert extra spaces between words to justify line + (save-restriction + (narrow-to-region beg end) + (or nosqueeze + (canonically-space-region beg end)) + (goto-char (point-max)) + (setq ncols (- fc endcol)) + ;; Ncols is number of additional spaces needed + (if (> ncols 0) + (if (and (not eop) + ;; 97/3/14 jhod: Kinsoku + (find-space-insertable-point)) ;(search-backward " " nil t)) + (while (> ncols 0) + (let ((nmove (+ 3 (random 3)))) + (while (> nmove 0) + (or (find-space-insertable-point) ;(search-backward " " nil t) + (progn + (goto-char (point-max)) + (find-space-insertable-point))) ;(search-backward " "))) + (skip-chars-backward " ") + (setq nmove (1- nmove)))) + ;; XEmacs change + (insert " ") + (skip-chars-backward " ") + (setq ncols (1- ncols))))))) + (t (error "Unknown justification value")))) + (goto-char pos) + (move-marker pos nil))) + nil) + +(defun unjustify-current-line () + "Remove justification whitespace from current line. +If the line is centered or right-justified, this function removes any +indentation past the left margin. If the line is full-justified, it removes +extra spaces between words. It does nothing in other justification modes." + (let ((justify (current-justification))) + (cond ((eq 'left justify) nil) + ((eq nil justify) nil) + ((eq 'full justify) ; full justify: remove extra spaces + (beginning-of-line-text) + (canonically-space-region + (point) (save-excursion (end-of-line) (point)))) + ((memq justify '(center right)) + (save-excursion + (move-to-left-margin nil t) + ;; Position ourselves after any fill-prefix. + (if (and fill-prefix + (not (string-equal fill-prefix "")) + (equal fill-prefix + (buffer-substring + (point) (min (point-max) (+ (length fill-prefix) + (point)))))) + (forward-char (length fill-prefix))) + (delete-region (point) (progn (skip-chars-forward " \t") + (point)))))))) + +(defun unjustify-region (&optional begin end) + "Remove justification whitespace from region. +For centered or right-justified regions, this function removes any indentation +past the left margin from each line. For full-justified lines, it removes +extra spaces between words. It does nothing in other justification modes. +Arguments BEGIN and END are optional; default is the whole buffer." + (save-excursion + (save-restriction + (if end (narrow-to-region (point-min) end)) + (goto-char (or begin (point-min))) + (while (not (eobp)) + (unjustify-current-line) + (forward-line 1))))) + + +(defun fill-nonuniform-paragraphs (min max &optional justifyp mailp) + "Fill paragraphs within the region, allowing varying indentation within each. +This command divides the region into \"paragraphs\", +only at paragraph-separator lines, then fills each paragraph +using as the fill prefix the smallest indentation of any line +in the paragraph. + +When calling from a program, pass range to fill as first two arguments. + +Optional third and fourth arguments JUSTIFY and MAIL-FLAG: +JUSTIFY to justify paragraphs (prefix arg), +MAIL-FLAG for a mail message, i. e. don't fill header lines." + (interactive (list (region-beginning) (region-end) + (if current-prefix-arg 'full))) + (let ((fill-individual-varying-indent t)) + (fill-individual-paragraphs min max justifyp mailp))) + +(defun fill-individual-paragraphs (min max &optional justify mailp) + "Fill paragraphs of uniform indentation within the region. +This command divides the region into \"paragraphs\", +treating every change in indentation level as a paragraph boundary, +then fills each paragraph using its indentation level as the fill prefix. + +When calling from a program, pass range to fill as first two arguments. + +Optional third and fourth arguments JUSTIFY and MAIL-FLAG: +JUSTIFY to justify paragraphs (prefix arg), +MAIL-FLAG for a mail message, i. e. don't fill header lines." + (interactive (list (region-beginning) (region-end) + (if current-prefix-arg 'full))) + (save-restriction + (save-excursion + (goto-char min) + (beginning-of-line) + (narrow-to-region (point) max) + (if mailp + (while (and (not (eobp)) + (or (looking-at "[ \t]*[^ \t\n]+:") + (looking-at "[ \t]*$"))) + (if (looking-at "[ \t]*[^ \t\n]+:") + (search-forward "\n\n" nil 'move) + (forward-line 1)))) + (narrow-to-region (point) max) + ;; Loop over paragraphs. + (while (progn (skip-chars-forward " \t\n") (not (eobp))) + (move-to-left-margin) + (let ((start (point)) + fill-prefix fill-prefix-regexp) + ;; Find end of paragraph, and compute the smallest fill-prefix + ;; that fits all the lines in this paragraph. + (while (progn + ;; Update the fill-prefix on the first line + ;; and whenever the prefix good so far is too long. + (if (not (and fill-prefix + (looking-at fill-prefix-regexp))) + (setq fill-prefix + (if (and adaptive-fill-mode adaptive-fill-regexp + (looking-at adaptive-fill-regexp)) + (match-string 0) + (buffer-substring + (point) + (save-excursion (skip-chars-forward " \t") + (point)))) + fill-prefix-regexp (regexp-quote fill-prefix))) + (forward-line 1) + (if (bolp) + ;; If forward-line went past a newline + ;; move further to the left margin. + (move-to-left-margin)) + ;; Now stop the loop if end of paragraph. + (and (not (eobp)) + (if fill-individual-varying-indent + ;; If this line is a separator line, with or + ;; without prefix, end the paragraph. + (and + (not (looking-at paragraph-separate)) + (save-excursion + (not (and (looking-at fill-prefix-regexp) + ;; XEmacs change + (progn + (forward-char (length fill-prefix)) + (looking-at paragraph-separate)))))) + ;; If this line has more or less indent + ;; than the fill prefix wants, end the paragraph. + (and (looking-at fill-prefix-regexp) + (save-excursion + (not + (progn + (forward-char (length fill-prefix)) + (or (looking-at paragraph-separate) + (looking-at paragraph-start)))))))))) + ;; Fill this paragraph, but don't add a newline at the end. + (let ((had-newline (bolp))) + (fill-region-as-paragraph start (point) justify) + (or had-newline (delete-char -1)))))))) + +;;; fill.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/float-sup.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,67 @@ +;;; float-sup.el --- detect absence of floating-point support in XEmacs runtime + +;; Copyright (C) 1985-7, 1997 Free Software Foundation, Inc. + +;; Maintainer: FSF +;; Keywords: internal, dumped + +;; 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.34. + +;;; Code: + +;; This file is dumped with XEmacs. + +;; Provide a meaningful error message if we are running on +;; bare (non-float) emacs. +;; Can't test for 'floatp since that may be defined by float-imitation +;; packages like float.el in this very directory. + +;; XEmacs change +(or (featurep 'lisp-float-type) + (error "Floating point was disabled at compile time")) + +;; define pi and e via math-lib calls. (much less prone to killer typos.) +;; XEmacs change (purecopy) +(defconst pi (purecopy (* 4 (atan 1))) "The value of Pi (3.1415926...)") +(defconst e (purecopy (exp 1)) "The value of e (2.7182818...)") + +;; Careful when editing this file ... typos here will be hard to spot. +;; (defconst pi 3.14159265358979323846264338327 +;; "The value of Pi (3.14159265358979323846264338327...)") + +;; XEmacs change (purecopy) +(defconst degrees-to-radians (purecopy (/ pi 180.0)) + "Degrees to radian conversion constant") +(defconst radians-to-degrees (purecopy (/ 180.0 pi)) + "Radian to degree conversion constant") + +;; these expand to a single multiply by a float when byte compiled + +(defmacro degrees-to-radians (x) + "Convert ARG from degrees to radians." + (list '* (/ pi 180.0) x)) +(defmacro radians-to-degrees (x) + "Convert ARG from radians to degrees." + (list '* (/ 180.0 pi) x)) + +;; Provided in C code in XEmacs +;; (provide 'lisp-float-type) + +;;; float-sup.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/format.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,833 @@ +;;; format.el --- read and save files in multiple formats + +;; Copyright (c) 1994, 1995, 1997 Free Software Foundation + +;; Author: Boris Goldowsky <boris@gnu.ai.mit.edu> +;; Keywords: extensions, dumped + +;; 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: Emacs/Mule zeta. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;; This file defines a unified mechanism for saving & loading files stored +;; in different formats. `format-alist' contains information that directs +;; Emacs to call an encoding or decoding function when reading or writing +;; files that match certain conditions. +;; +;; When a file is visited, its format is determined by matching the +;; beginning of the file against regular expressions stored in +;; `format-alist'. If this fails, you can manually translate the buffer +;; using `format-decode-buffer'. In either case, the formats used are +;; listed in the variable `buffer-file-format', and become the default +;; format for saving the buffer. To save a buffer in a different format, +;; change this variable, or use `format-write-file'. +;; +;; Auto-save files are normally created in the same format as the visited +;; file, but the variable `auto-save-file-format' can be set to a +;; particularly fast or otherwise preferred format to be used for +;; auto-saving (or nil to do no encoding on auto-save files, but then you +;; risk losing any text-properties in the buffer). +;; +;; You can manually translate a buffer into or out of a particular format +;; with the functions `format-encode-buffer' and `format-decode-buffer'. +;; To translate just the region use the functions `format-encode-region' +;; and `format-decode-region'. +;; +;; You can define a new format by writing the encoding and decoding +;; functions, and adding an entry to `format-alist'. See enriched.el for +;; an example of how to implement a file format. There are various +;; functions defined in this file that may be useful for writing the +;; encoding and decoding functions: +;; * `format-annotate-region' and `format-deannotate-region' allow a +;; single alist of information to be used for encoding and decoding. +;; The alist defines a correspondence between strings in the file +;; ("annotations") and text-properties in the buffer. +;; * `format-replace-strings' is similarly useful for doing simple +;; string->string translations in a reversible manner. + +;;; Code: + +(put 'buffer-file-format 'permanent-local t) + +(defvar format-alist + '((image/jpeg "JPEG image" "\377\330\377\340\000\020JFIF" + image-decode-jpeg nil t image-mode) + (image/gif "GIF image" "GIF8[79]" + image-decode-gif nil t image-mode) + (image/png "Portable Network Graphics" "\211PNG" + image-decode-png nil t image-mode) + (image/x-xpm "XPM image" "/\\* XPM \\*/" + image-decode-xpm nil t image-mode) + (text/enriched "Extended MIME text/enriched format." + "Content-[Tt]ype:[ \t]*text/enriched" + enriched-decode enriched-encode t enriched-mode) + (text/richtext "Extended MIME obsolete text/richtext format." + "Content-[Tt]ype:[ \t]*text/richtext" + richtext-decode richtext-encode t enriched-mode) + (plain "Standard ASCII format, no text properties." + ;; Plain only exists so that there is an obvious neutral choice in + ;; the completion list. + nil nil nil nil nil)) + "List of information about understood file formats. +Elements are of the form \(NAME DOC-STR REGEXP FROM-FN TO-FN MODIFY MODE-FN). +NAME is a symbol, which is stored in `buffer-file-format'. +DOC-STR should be a single line providing more information about the + format. It is currently unused, but in the future will be shown to + the user if they ask for more information. +REGEXP is a regular expression to match against the beginning of the file; + it should match only files in that format. +FROM-FN is called to decode files in that format; it gets two args, BEGIN + and END, and can make any modifications it likes, returning the new + end. It must make sure that the beginning of the file no longer + matches REGEXP, or else it will get called again. +TO-FN is called to encode a region into that format; it is passed three + arguments: BEGIN, END, and BUFFER. BUFFER is the original buffer that + the data being written came from, which the function could use, for + example, to find the values of local variables. TO-FN should either + return a list of annotations like `write-region-annotate-functions', + or modify the region and return the new end. +MODIFY, if non-nil, means the TO-FN wants to modify the region. If nil, + TO-FN will not make any changes but will instead return a list of + annotations. +MODE-FN, if specified, is called when visiting a file with that format.") + +;;; Basic Functions (called from Lisp) + +(defun format-annotate-function (format from to) + "Returns annotations for writing region as FORMAT. +FORMAT is a symbol naming one of the formats defined in `format-alist', +it must be a single symbol, not a list like `buffer-file-format'. +FROM and TO delimit the region to be operated on in the current buffer. +This function works like a function on `write-region-annotate-functions': +it either returns a list of annotations, or returns with a different buffer +current, which contains the modified text to write. + +For most purposes, consider using `format-encode-region' instead." + ;; This function is called by write-region (actually build-annotations) + ;; for each element of buffer-file-format. + (let* ((info (assq format format-alist)) + (to-fn (nth 4 info)) + (modify (nth 5 info))) + (if to-fn + (if modify + ;; To-function wants to modify region. Copy to safe place. + (let ((copy-buf (get-buffer-create " *Format Temp*"))) + (copy-to-buffer copy-buf from to) + (set-buffer copy-buf) + (format-insert-annotations write-region-annotations-so-far from) + (funcall to-fn (point-min) (point-max)) + nil) + ;; Otherwise just call function, it will return annotations. + (funcall to-fn from to))))) + +(defun format-decode (format length &optional visit-flag) + ;; This function is called by insert-file-contents whenever a file is read. + "Decode text from any known FORMAT. +FORMAT is a symbol appearing in `format-alist' or a list of such symbols, +or nil, in which case this function tries to guess the format of the data by +matching against the regular expressions in `format-alist'. After a match is +found and the region decoded, the alist is searched again from the beginning +for another match. + +Second arg LENGTH is the number of characters following point to operate on. +If optional third arg VISIT-FLAG is true, set `buffer-file-format' +to the list of formats used, and call any mode functions defined for those +formats. + +Returns the new length of the decoded region. + +For most purposes, consider using `format-decode-region' instead." + (let ((mod (buffer-modified-p)) + (begin (point)) + (end (+ (point) length))) + (if (null format) + ;; Figure out which format it is in, remember list in `format'. + (let ((try format-alist)) + (while try + (let* ((f (car try)) + (regexp (nth 2 f)) + (p (point))) + (if (and regexp (looking-at regexp) + (< (match-end 0) (+ begin length))) + (progn + (setq format (cons (car f) format)) + ;; Decode it + (if (nth 3 f) (setq end (funcall (nth 3 f) begin end))) + ;; Call visit function if required + (if (and visit-flag (nth 6 f)) (funcall (nth 6 f) 1)) + ;; Safeguard against either of the functions changing pt. + (goto-char p) + ;; Rewind list to look for another format + (setq try format-alist)) + (setq try (cdr try)))))) + ;; Deal with given format(s) + (or (listp format) (setq format (list format))) + (let ((do format) f) + (while do + (or (setq f (assq (car do) format-alist)) + (error "Unknown format" (car do))) + ;; Decode: + (if (nth 3 f) (setq end (funcall (nth 3 f) begin end))) + ;; Call visit function if required + (if (and visit-flag (nth 6 f)) (funcall (nth 6 f) 1)) + (setq do (cdr do))))) + (if visit-flag + (setq buffer-file-format format)) + (set-buffer-modified-p mod) + ;; Return new length of region + (- end begin))) + +;;; +;;; Interactive functions & entry points +;;; + +(defun format-decode-buffer (&optional format) + "Translate the buffer from some FORMAT. +If the format is not specified, this function attempts to guess. +`buffer-file-format' is set to the format used, and any mode-functions +for the format are called." + (interactive + (list (format-read "Translate buffer from format (default: guess): "))) + (save-excursion + (goto-char (point-min)) + (format-decode format (buffer-size) t))) + +(defun format-decode-region (from to &optional format) + "Decode the region from some format. +Arg FORMAT is optional; if omitted the format will be determined by looking +for identifying regular expressions at the beginning of the region." + (interactive + (list (region-beginning) (region-end) + (format-read "Translate region from format (default: guess): "))) + (save-excursion + (goto-char from) + (format-decode format (- to from) nil))) + +(defun format-encode-buffer (&optional format) + "Translate the buffer into FORMAT. +FORMAT defaults to `buffer-file-format'. It is a symbol naming one of the +formats defined in `format-alist', or a list of such symbols." + (interactive + (list (format-read (format "Translate buffer to format (default %s): " + buffer-file-format)))) + (format-encode-region (point-min) (point-max) format)) + +(defun format-encode-region (beg end &optional format) + "Translate the region into some FORMAT. +FORMAT defaults to `buffer-file-format', it is a symbol naming +one of the formats defined in `format-alist', or a list of such symbols." + (interactive + (list (region-beginning) (region-end) + (format-read (format "Translate region to format (default %s): " + buffer-file-format)))) + (if (null format) (setq format buffer-file-format)) + (if (symbolp format) (setq format (list format))) + (save-excursion + (goto-char end) + (let ( ; (cur-buf (current-buffer)) + (end (point-marker))) + (while format + (let* ((info (assq (car format) format-alist)) + (to-fn (nth 4 info)) + (modify (nth 5 info)) + ;; result + ) + (if to-fn + (if modify + (setq end (funcall to-fn beg end (current-buffer))) + (format-insert-annotations + (funcall to-fn beg end (current-buffer))))) + (setq format (cdr format))))))) + +(defun format-write-file (filename format) + "Write current buffer into a FILE using some FORMAT. +Makes buffer visit that file and sets the format as the default for future +saves. If the buffer is already visiting a file, you can specify a directory +name as FILE, to write a file of the same old name in that directory." + (interactive + ;; Same interactive spec as write-file, plus format question. + (let* ((file (if buffer-file-name + (read-file-name "Write file: " + nil nil nil nil) + (read-file-name "Write file: " + (cdr (assq 'default-directory + (buffer-local-variables))) + nil nil (buffer-name)))) + (fmt (format-read (format "Write file `%s' in format: " + (file-name-nondirectory file))))) + (list file fmt))) + (setq buffer-file-format format) + (write-file filename)) + +(defun format-find-file (filename format) + "Find the file FILE using data format FORMAT. +If FORMAT is nil then do not do any format conversion." + (interactive + ;; Same interactive spec as write-file, plus format question. + (let* ((file (read-file-name "Find file: ")) + (fmt (format-read (format "Read file `%s' in format: " + (file-name-nondirectory file))))) + (list file fmt))) + (let ((format-alist nil)) + (find-file filename)) + (if format + (format-decode-buffer format))) + +(defun format-insert-file (filename format &optional beg end) + "Insert the contents of file FILE using data format FORMAT. +If FORMAT is nil then do not do any format conversion. +The optional third and fourth arguments BEG and END specify +the part of the file to read. + +The return value is like the value of `insert-file-contents': +a list (ABSOLUTE-FILE-NAME . SIZE)." + (interactive + ;; Same interactive spec as write-file, plus format question. + (let* ((file (read-file-name "Find file: ")) + (fmt (format-read (format "Read file `%s' in format: " + (file-name-nondirectory file))))) + (list file fmt))) + (let (value size) + (let ((format-alist nil)) + (setq value (insert-file-contents filename nil beg end)) + (setq size (nth 1 value))) + (if format + (setq size (format-decode format size) + value (cons (car value) size))) + value)) + +(defun format-read (&optional prompt) + "Read and return the name of a format. +Return value is a list, like `buffer-file-format'; it may be nil. +Formats are defined in `format-alist'. Optional arg is the PROMPT to use." + (let* ((table (mapcar (lambda (x) (list (symbol-name (car x)))) + format-alist)) + (ans (completing-read (or prompt "Format: ") table nil t))) + (if (not (equal "" ans)) (list (intern ans))))) + + +;;; +;;; Below are some functions that may be useful in writing encoding and +;;; decoding functions for use in format-alist. +;;; + +(defun format-replace-strings (alist &optional reverse beg end) + "Do multiple replacements on the buffer. +ALIST is a list of (from . to) pairs, which should be proper arguments to +`search-forward' and `replace-match' respectively. +Optional 2nd arg REVERSE, if non-nil, means the pairs are (to . from), so that +you can use the same list in both directions if it contains only literal +strings. +Optional args BEGIN and END specify a region of the buffer to operate on." + (save-excursion + (save-restriction + (or beg (setq beg (point-min))) + (if end (narrow-to-region (point-min) end)) + (while alist + (let ((from (if reverse (cdr (car alist)) (car (car alist)))) + (to (if reverse (car (cdr alist)) (cdr (car alist))))) + (goto-char beg) + (while (search-forward from nil t) + (goto-char (match-beginning 0)) + (insert to) + (set-text-properties (- (point) (length to)) (point) + (text-properties-at (point))) + (delete-region (point) (+ (point) (- (match-end 0) + (match-beginning 0))))) + (setq alist (cdr alist))))))) + +;;; Some list-manipulation functions that we need. + +(defun format-delq-cons (cons list) + "Remove the given CONS from LIST by side effect, +and return the new LIST. Since CONS could be the first element +of LIST, write `\(setq foo \(format-delq-cons element foo))' to be sure of +changing the value of `foo'." + (if (eq cons list) + (cdr list) + (let ((p list)) + (while (not (eq (cdr p) cons)) + (if (null p) (error "format-delq-cons: not an element.")) + (setq p (cdr p))) + ;; Now (cdr p) is the cons to delete + (setcdr p (cdr cons)) + list))) + +(defun format-make-relatively-unique (a b) + "Delete common elements of lists A and B, return as pair. +Compares using `equal'." + (let* ((acopy (copy-sequence a)) + (bcopy (copy-sequence b)) + (tail acopy)) + (while tail + (let ((dup (member (car tail) bcopy)) + (next (cdr tail))) + (if dup (setq acopy (format-delq-cons tail acopy) + bcopy (format-delq-cons dup bcopy))) + (setq tail next))) + (cons acopy bcopy))) + +(defun format-common-tail (a b) + "Given two lists that have a common tail, return it. +Compares with `equal', and returns the part of A that is equal to the +equivalent part of B. If even the last items of the two are not equal, +returns nil." + (let ((la (length a)) + (lb (length b))) + ;; Make sure they are the same length + (if (> la lb) + (setq a (nthcdr (- la lb) a)) + (setq b (nthcdr (- lb la) b)))) + (while (not (equal a b)) + (setq a (cdr a) + b (cdr b))) + a) + +(defun format-reorder (items order) + "Arrange ITEMS to following partial ORDER. +Elements of ITEMS equal to elements of ORDER will be rearranged to follow the +ORDER. Unmatched items will go last." + (if order + (let ((item (member (car order) items))) + (if item + (cons (car item) + (format-reorder (format-delq-cons item items) + (cdr order))) + (format-reorder items (cdr order)))) + items)) + +(put 'face 'format-list-valued t) ; These text-properties take values +(put 'unknown 'format-list-valued t) ; that are lists, the elements of which + ; should be considered separately. + ; See format-deannotate-region and + ; format-annotate-region. + +;;; +;;; Decoding +;;; + +(defun format-deannotate-region (from to translations next-fn) + "Translate annotations in the region into text properties. +This sets text properties between FROM to TO as directed by the +TRANSLATIONS and NEXT-FN arguments. + +NEXT-FN is a function that searches forward from point for an annotation. +It should return a list of 4 elements: \(BEGIN END NAME POSITIVE). BEGIN and +END are buffer positions bounding the annotation, NAME is the name searched +for in TRANSLATIONS, and POSITIVE should be non-nil if this annotation marks +the beginning of a region with some property, or nil if it ends the region. +NEXT-FN should return nil if there are no annotations after point. + +The basic format of the TRANSLATIONS argument is described in the +documentation for the `format-annotate-region' function. There are some +additional things to keep in mind for decoding, though: + +When an annotation is found, the TRANSLATIONS list is searched for a +text-property name and value that corresponds to that annotation. If the +text-property has several annotations associated with it, it will be used only +if the other annotations are also in effect at that point. The first match +found whose annotations are all present is used. + +The text property thus determined is set to the value over the region between +the opening and closing annotations. However, if the text-property name has a +non-nil `format-list-valued' property, then the value will be consed onto the +surrounding value of the property, rather than replacing that value. + +There are some special symbols that can be used in the \"property\" slot of +the TRANSLATIONS list: PARAMETER and FUNCTION \(spelled in uppercase). +Annotations listed under the pseudo-property PARAMETER are considered to be +arguments of the immediately surrounding annotation; the text between the +opening and closing parameter annotations is deleted from the buffer but saved +as a string. The surrounding annotation should be listed under the +pseudo-property FUNCTION. Instead of inserting a text-property for this +annotation, the function listed in the VALUE slot is called to make whatever +changes are appropriate. The function's first two arguments are the START and +END locations, and the rest of the arguments are any PARAMETERs found in that +region. + +Any annotations that are found by NEXT-FN but not defined by TRANSLATIONS +are saved as values of the `unknown' text-property \(which is list-valued). +The TRANSLATIONS list should usually contain an entry of the form + \(unknown \(nil format-annotate-value)) +to write these unknown annotations back into the file." + (save-excursion + (save-restriction + (narrow-to-region (point-min) to) + (goto-char from) + (let (next open-ans todo + ;; loc + unknown-ans) + (while (setq next (funcall next-fn)) + (let* ((loc (nth 0 next)) + (end (nth 1 next)) + (name (nth 2 next)) + (positive (nth 3 next)) + (found nil)) + + ;; Delete the annotation + (delete-region loc end) + (if positive + ;; Positive annotations are stacked, remembering location + (setq open-ans (cons (list name loc) open-ans)) + ;; It is a negative annotation: + ;; Close the top annotation & add its text property. + ;; If the file's nesting is messed up, the close might not match + ;; the top thing on the open-annotations stack. + ;; If no matching annotation is open, just ignore the close. + (if (not (assoc name open-ans)) + (message "Extra closing annotation (%s) in file" name) + ;; If one is open, but not on the top of the stack, close + ;; the things in between as well. Set `found' when the real + ;; one is closed. + (while (not found) + (let* ((top (car open-ans)) ; first on stack: should match. + (top-name (car top)) + (start (car (cdr top))) ; location of start + (params (cdr (cdr top))) ; parameters + (aalist translations) + (matched nil)) + (if (equal name top-name) + (setq found t) + (message "Improper nesting in file.")) + ;; Look through property names in TRANSLATIONS + (while aalist + (let ((prop (car (car aalist))) + (alist (cdr (car aalist)))) + ;; And look through values for each property + (while alist + (let ((value (car (car alist))) + (ans (cdr (car alist)))) + (if (member top-name ans) + ;; This annotation is listed, but still have to + ;; check if multiple annotations are satisfied + (if (member 'nil (mapcar + (lambda (r) + (assoc r open-ans)) + ans)) + nil ; multiple ans not satisfied + ;; Yes, all set. + ;; If there are multiple annotations going + ;; into one text property, adjust the + ;; begin points of the other annotations + ;; so that we don't get double marking. + (let ((to-reset ans) + this-one) + (while to-reset + (setq this-one + (assoc (car to-reset) + (cdr open-ans))) + (if this-one + (setcar (cdr this-one) loc)) + (setq to-reset (cdr to-reset)))) + ;; Set loop variables to nil so loop + ;; will exit. + (setq alist nil aalist nil matched t + ;; pop annotation off stack. + open-ans (cdr open-ans)) + (cond + ;; Check for pseudo-properties + ((eq prop 'PARAMETER) + ;; This is a parameter of the top open ann: + ;; delete text and use as arg. + (if open-ans + ;; (If nothing open, discard). + (setq open-ans + (cons (append (car open-ans) + (list + (buffer-substring + start loc))) + (cdr open-ans)))) + (delete-region start loc)) + ((eq prop 'FUNCTION) + ;; Not a property, but a function to call. + (let ((rtn (apply value start loc params))) + (if rtn (setq todo (cons rtn todo))))) + (t + ;; Normal property/value pair + (setq todo + (cons (list start loc prop value) + todo))))))) + (setq alist (cdr alist)))) + (setq aalist (cdr aalist))) + (if matched + nil + ;; Didn't find any match for the annotation: + ;; Store as value of text-property `unknown'. + (setq open-ans (cdr open-ans)) + (setq todo (cons (list start loc 'unknown top-name) + todo)) + (setq unknown-ans (cons name unknown-ans))))))))) + + ;; Once entire file has been scanned, add the properties. + (while todo + (let* ((item (car todo)) + (from (nth 0 item)) + (to (nth 1 item)) + (prop (nth 2 item)) + (val (nth 3 item))) + + (put-text-property + from to prop + (cond ((numberp val) ; add to ambient value if numeric + (+ val (or (get-text-property from prop) 0))) + ((get prop 'format-list-valued) ; value gets consed onto + ; list-valued properties + (let ((prev (get-text-property from prop))) + (cons val (if (listp prev) prev (list prev))))) + (t val)))) ; normally, just set to val. + (setq todo (cdr todo))) + + (if unknown-ans + (message "Unknown annotations: %s" unknown-ans)))))) + +;;; +;;; Encoding +;;; + +(defun format-insert-annotations (list &optional offset) + "Apply list of annotations to buffer as `write-region' would. +Inserts each element of the given LIST of buffer annotations at its +appropriate place. Use second arg OFFSET if the annotations' locations are +not relative to the beginning of the buffer: annotations will be inserted +at their location-OFFSET+1 \(ie, the offset is treated as the character number +of the first character in the buffer)." + (if (not offset) + (setq offset 0) + (setq offset (1- offset))) + (let ((l (reverse list))) + (while l + (goto-char (- (car (car l)) offset)) + (insert (cdr (car l))) + (setq l (cdr l))))) + +(defun format-annotate-value (old new) + "Return OLD and NEW as a \(close . open) annotation pair. +Useful as a default function for TRANSLATIONS alist when the value of the text +property is the name of the annotation that you want to use, as it is for the +`unknown' text property." + (cons (if old (list old)) + (if new (list new)))) + +(defun format-annotate-region (from to trans format-fn ignore) + "Generate annotations for text properties in the region. +Searches for changes between FROM and TO, and describes them with a list of +annotations as defined by alist TRANSLATIONS and FORMAT-FN. IGNORE lists text +properties not to consider; any text properties that are neither ignored nor +listed in TRANSLATIONS are warned about. +If you actually want to modify the region, give the return value of this +function to `format-insert-annotations'. + +Format of the TRANSLATIONS argument: + +Each element is a list whose car is a PROPERTY, and the following +elements are VALUES of that property followed by the names of zero or more +ANNOTATIONS. Whenever the property takes on that value, the annotations +\(as formatted by FORMAT-FN) are inserted into the file. +When the property stops having that value, the matching negated annotation +will be inserted \(it may actually be closed earlier and reopened, if +necessary, to keep proper nesting). + +If the property's value is a list, then each element of the list is dealt with +separately. + +If a VALUE is numeric, then it is assumed that there is a single annotation +and each occurrence of it increments the value of the property by that number. +Thus, given the entry \(left-margin \(4 \"indent\")), if the left margin +changes from 4 to 12, two <indent> annotations will be generated. + +If the VALUE is nil, then instead of annotations, a function should be +specified. This function is used as a default: it is called for all +transitions not explicitly listed in the table. The function is called with +two arguments, the OLD and NEW values of the property. It should return +lists of annotations like `format-annotate-location' does. + + The same structure can be used in reverse for reading files." + (let ((all-ans nil) ; All annotations - becomes return value + (open-ans nil) ; Annotations not yet closed + (loc nil) ; Current location + (not-found nil)) ; Properties that couldn't be saved + (while (or (null loc) + (and (setq loc (next-property-change loc nil to)) + (< loc to))) + (or loc (setq loc from)) + (let* ((ans (format-annotate-location loc (= loc from) ignore trans)) + (neg-ans (format-reorder (aref ans 0) open-ans)) + (pos-ans (aref ans 1)) + (ignored (aref ans 2))) + (setq not-found (append ignored not-found) + ignore (append ignored ignore)) + ;; First do the negative (closing) annotations + (while neg-ans + ;; Check if it's missing. This can happen (eg, a numeric property + ;; going negative can generate closing annotations before there are + ;; any open). Warn user & ignore. + (if (not (member (car neg-ans) open-ans)) + (message "Can't close %s: not open." (car neg-ans)) + (while (not (equal (car neg-ans) (car open-ans))) + ;; To close anno. N, need to first close ans 1 to N-1, + ;; remembering to re-open them later. + (setq pos-ans (cons (car open-ans) pos-ans)) + (setq all-ans + (cons (cons loc (funcall format-fn (car open-ans) nil)) + all-ans)) + (setq open-ans (cdr open-ans))) + ;; Now remove the one we're really interested in from open list. + (setq open-ans (cdr open-ans)) + ;; And put the closing annotation here. + (setq all-ans + (cons (cons loc (funcall format-fn (car neg-ans) nil)) + all-ans))) + (setq neg-ans (cdr neg-ans))) + ;; Now deal with positive (opening) annotations + (let ( ; (p pos-ans) + ) + (while pos-ans + (setq open-ans (cons (car pos-ans) open-ans)) + (setq all-ans + (cons (cons loc (funcall format-fn (car pos-ans) t)) + all-ans)) + (setq pos-ans (cdr pos-ans)))))) + + ;; Close any annotations still open + (while open-ans + (setq all-ans + (cons (cons to (funcall format-fn (car open-ans) nil)) + all-ans)) + (setq open-ans (cdr open-ans))) + (if not-found + (message "These text properties could not be saved:\n %s" + not-found)) + (nreverse all-ans))) + +;;; Internal functions for format-annotate-region. + +(defun format-annotate-location (loc all ignore trans) + "Return annotation(s) needed at LOCATION. +This includes any properties that change between LOC-1 and LOC. +If ALL is true, don't look at previous location, but generate annotations for +all non-nil properties. +Third argument IGNORE is a list of text-properties not to consider. + +Return value is a vector of 3 elements: +1. List of names of the annotations to close +2. List of the names of annotations to open. +3. List of properties that were ignored or couldn't be annotated." + (let* ((prev-loc (1- loc)) + (before-plist (if all nil (text-properties-at prev-loc))) + (after-plist (text-properties-at loc)) + p negatives positives prop props not-found) + ;; make list of all property names involved + (setq p before-plist) + (while p + (if (not (memq (car p) props)) + (setq props (cons (car p) props))) + (setq p (cdr (cdr p)))) + (setq p after-plist) + (while p + (if (not (memq (car p) props)) + (setq props (cons (car p) props))) + (setq p (cdr (cdr p)))) + + (while props + (setq prop (car props) + props (cdr props)) + (if (memq prop ignore) + nil ; If it's been ignored before, ignore it now. + (let ((before (if all nil (car (cdr (memq prop before-plist))))) + (after (car (cdr (memq prop after-plist))))) + (if (equal before after) + nil ; no change; ignore + (let ((result (format-annotate-single-property-change + prop before after trans))) + (if (not result) + (setq not-found (cons prop not-found)) + (setq negatives (nconc negatives (car result)) + positives (nconc positives (cdr result))))))))) + (vector negatives positives not-found))) + +(defun format-annotate-single-property-change (prop old new trans) + "Return annotations for PROPERTY changing from OLD to NEW. +These are searched for in the TRANSLATIONS alist. +If NEW does not appear in the list, but there is a default function, then that +function is called. +Annotations to open and to close are returned as a dotted pair." + (let ((prop-alist (cdr (assoc prop trans))) + ;; default + ) + (if (not prop-alist) + nil + ;; If property is numeric, nil means 0 + (cond ((and (numberp old) (null new)) + (setq new 0)) + ((and (numberp new) (null old)) + (setq old 0))) + ;; If either old or new is a list, have to treat both that way. + (if (or (consp old) (consp new)) + (let* ((old (if (listp old) old (list old))) + (new (if (listp new) new (list new))) + ;; (tail (format-common-tail old new)) + close open) + (while old + (setq close + (append (car (format-annotate-atomic-property-change + prop-alist (car old) nil)) + close) + old (cdr old))) + (while new + (setq open + (append (cdr (format-annotate-atomic-property-change + prop-alist nil (car new))) + open) + new (cdr new))) + (format-make-relatively-unique close open)) + (format-annotate-atomic-property-change prop-alist old new))))) + +(defun format-annotate-atomic-property-change (prop-alist old new) + "Internal function annotate a single property change. +PROP-ALIST is the relevant segment of a TRANSLATIONS list. +OLD and NEW are the values." + (cond + ;; Numerical annotation - use difference + ((and (numberp old) (numberp new)) + (let* ((entry (progn + (while (and (car (car prop-alist)) + (not (numberp (car (car prop-alist))))) + (setq prop-alist (cdr prop-alist))) + (car prop-alist))) + (increment (car (car prop-alist))) + (n (ceiling (/ (float (- new old)) (float increment)))) + (anno (car (cdr (car prop-alist))))) + (if (> n 0) + (cons nil (make-list n anno)) + (cons (make-list (- n) anno) nil)))) + + ;; Standard annotation + (t (let ((close (and old (cdr (assoc old prop-alist)))) + (open (and new (cdr (assoc new prop-alist))))) + (if (or close open) + (format-make-relatively-unique close open) + ;; Call "Default" function, if any + (let ((default (assq nil prop-alist))) + (if default + (funcall (car (cdr default)) old new)))))))) + +;;; format.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/frame.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,1300 @@ +;;; frame.el --- multi-frame management independent of window systems. + +;; Copyright (C) 1993-4, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1995, 1996 Ben Wing. + +;; Maintainer: XEmacs Development Team +;; Keywords: internal, dumped + +;; 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, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: FSF 19.30. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;;; Code: + +(defgroup frames nil + "Support for Emacs frames and window systems." + :group 'environment) + +; No need for `frame-creation-function'. + +;;; The initial value given here for this must ask for a minibuffer. +;;; There must always exist a frame with a minibuffer, and after we +;;; delete the terminal frame, this will be the only frame. +(defcustom initial-frame-plist '(minibuffer t) + "Plist of frame properties for creating the initial X window frame. +You can set this in your `.emacs' file; for example, + (setq initial-frame-plist '(top 1 left 1 width 80 height 55)) +Properties specified here supersede the values given in `default-frame-plist'. +The format of this can also be an alist for backward compatibility. + +If the value calls for a frame without a minibuffer, and you have not created +a minibuffer frame on your own, one is created according to +`minibuffer-frame-plist'. + +You can specify geometry-related options for just the initial frame +by setting this variable in your `.emacs' file; however, they won't +take effect until Emacs reads `.emacs', which happens after first creating +the frame. If you want the frame to have the proper geometry as soon +as it appears, you need to use this three-step process: +* Specify X resources to give the geometry you want. +* Set `default-frame-plist' to override these options so that they + don't affect subsequent frames. +* Set `initial-frame-plist' in a way that matches the X resources, + to override what you put in `default-frame-plist'." + :type '(repeat (group :inline t + (symbol :tag "Property") + (sexp :tag "Value"))) + :group 'frames) + +(defcustom minibuffer-frame-plist '(width 80 height 2 menubar-visible-p nil + default-toolbar-visible-p nil) + "Plist of frame properties for initially creating a minibuffer frame. +You can set this in your `.emacs' file; for example, + (setq minibuffer-frame-plist '(top 1 left 1 width 80 height 2)) +Properties specified here supersede the values given in +`default-frame-plist'. +The format of this can also be an alist for backward compatibility." + :type '(repeat (group :inline t + (symbol :tag "Property") + (sexp :tag "Value"))) + :group 'frames) + +(defcustom pop-up-frame-plist nil + "Plist of frame properties used when creating pop-up frames. +Pop-up frames are used for completions, help, and the like. +This variable can be set in your init file, like this: + (setq pop-up-frame-plist '(width 80 height 20)) +These supersede the values given in `default-frame-plist'. +The format of this can also be an alist for backward compatibility." + :type '(repeat (group :inline t + (symbol :tag "Property") + (sexp :tag "Value"))) + :group 'frames) + +(setq pop-up-frame-function + (function (lambda () + (make-frame pop-up-frame-plist)))) + +(defcustom special-display-frame-plist '(height 14 width 80 unsplittable t) + "*Plist of frame properties used when creating special frames. +Special frames are used for buffers whose names are in +`special-display-buffer-names' and for buffers whose names match +one of the regular expressions in `special-display-regexps'. +This variable can be set in your init file, like this: + (setq special-display-frame-plist '(width 80 height 20)) +These supersede the values given in `default-frame-plist'. +The format of this can also be an alist for backward compatibility." + :type '(repeat (group :inline t + (symbol :tag "Property") + (sexp :tag "Value"))) + :group 'frames) + +(defun safe-alist-to-plist (cruftiness) + (if (consp (car cruftiness)) + (alist-to-plist cruftiness) + cruftiness)) + +;; Display BUFFER in its own frame, reusing an existing window if any. +;; Return the window chosen. +;; Currently we do not insist on selecting the window within its frame. +;; If ARGS is a plist, use it as a list of frame property specs. +;; #### Change, not compatible with FSF: This stuff is all so incredibly +;; junky anyway that I doubt it makes any difference. +;; If ARGS is a list whose car is t, +;; use (cadr ARGS) as a function to do the work. +;; Pass it BUFFER as first arg, and (cddr ARGS) gives the rest of the args. +(defun special-display-popup-frame (buffer &optional args) + ;; if we can't display simultaneous multiple frames, just return + ;; nil and let the normal behavior take over. + (and (device-on-window-system-p) + (if (and args (eq t (car args))) + (apply (cadr args) buffer (cddr args)) + (let ((window (get-buffer-window buffer t))) + (if window + ;; If we have a window already, make it visible. + (let ((frame (window-frame window))) + (make-frame-visible frame) + (raise-frame frame) + window) + ;; If no window yet, make one in a new frame. + (let ((frame + (make-frame (append (safe-alist-to-plist args) + (safe-alist-to-plist + special-display-frame-plist))))) + (set-window-buffer (frame-selected-window frame) buffer) + (set-window-dedicated-p (frame-selected-window frame) t) + (frame-selected-window frame))))))) + +(setq special-display-function 'special-display-popup-frame) + +;;; Handle delete-frame events from the X server. +;(defun handle-delete-frame (event) +; (interactive "e") +; (let ((frame (posn-window (event-start event))) +; (i 0) +; (tail (frame-list))) +; (while tail +; (and (frame-visible-p (car tail)) +; (not (eq (car tail) frame)) +; (setq i (1+ i))) +; (setq tail (cdr tail))) +; (if (> i 0) +; (delete-frame frame t) +; (kill-emacs)))) + + +;;;; Arrangement of frames at startup + +;;; 1) Load the window system startup file from the lisp library and read the +;;; high-priority arguments (-q and the like). The window system startup +;;; file should create any frames specified in the window system defaults. +;;; +;;; 2) If no frames have been opened, we open an initial text frame. +;;; +;;; 3) Once the init file is done, we apply any newly set properties +;;; in initial-frame-plist to the frame. + +;; These are now called explicitly at the proper times, +;; since that is easier to understand. +;; Actually using hooks within Emacs is bad for future maintenance. --rms. +;; (add-hook 'before-init-hook 'frame-initialize) +;; (add-hook 'window-setup-hook 'frame-notice-user-settings) + +;;; If we create the initial frame, this is it. +(defvar frame-initial-frame nil) + +;; Record the properties used in frame-initialize to make the initial frame. +(defvar frame-initial-frame-plist) + +(defvar frame-initial-geometry-arguments nil) + +(defun canonicalize-frame-plists () + (setq initial-frame-plist (safe-alist-to-plist initial-frame-plist)) + (setq default-frame-plist (safe-alist-to-plist default-frame-plist))) + +;;; startup.el calls this function before loading the user's init +;;; file - if there is no frame with a minibuffer open now, create +;;; one to display messages while loading the init file. +(defun frame-initialize () + ;; In batch mode, we actually use the initial terminal device for output. + (canonicalize-frame-plists) + (if (not (noninteractive)) + (progn + ;; Don't call select-frame here - focus is a matter of WM policy. + + ;; If there is no frame with a minibuffer besides the terminal + ;; frame, then we need to create the opening frame. Make sure + ;; it has a minibuffer, but let initial-frame-plist omit the + ;; minibuffer spec. + (or (delq terminal-frame (minibuffer-frame-list)) + (progn + (setq frame-initial-frame-plist + (append initial-frame-plist default-frame-plist)) + ;; FSFmacs has scroll-bar junk here that we don't need. + (setq default-minibuffer-frame + (setq frame-initial-frame + (make-frame initial-frame-plist + (car (delq terminal-device + (device-list)))))) + ;; Delete any specifications for window geometry properties + ;; so that we won't reapply them in frame-notice-user-settings. + ;; It would be wrong to reapply them then, + ;; because that would override explicit user resizing. + (setq initial-frame-plist + (frame-remove-geometry-props initial-frame-plist)))) + ;; At this point, we know that we have a frame open, so we + ;; can delete the terminal device. + (delete-device terminal-device) + (setq terminal-frame nil) + + ;; FSFmacs sets frame-creation-function here, but no need. + ))) + +;;; startup.el calls this function after loading the user's init +;;; file. Now default-frame-plist and initial-frame-plist contain +;;; information to which we must react; do what needs to be done. +(defun frame-notice-user-settings () + + ;; FSFmacs has menu-bar junk here that we don't need. + + (canonicalize-frame-plists) + + ;; Creating and deleting frames may shift the selected frame around, + ;; and thus the current buffer. Protect against that. We don't + ;; want to use save-excursion here, because that may also try to set + ;; the buffer of the selected window, which fails when the selected + ;; window is the minibuffer. + (let ((old-buffer (current-buffer))) + + ;; If the initial frame is still around, apply initial-frame-plist + ;; and default-frame-plist to it. + (if (frame-live-p frame-initial-frame) + + ;; The initial frame we create above always has a minibuffer. + ;; If the user wants to remove it, or make it a minibuffer-only + ;; frame, then we'll have to delete the current frame and make a + ;; new one; you can't remove or add a root window to/from an + ;; existing frame. + ;; + ;; NOTE: default-frame-plist was nil when we created the + ;; existing frame. We need to explicitly include + ;; default-frame-plist in the properties of the screen we + ;; create here, so that its new value, gleaned from the user's + ;; .emacs file, will be applied to the existing screen. + (if (not (eq (car + (or (and (lax-plist-member + initial-frame-plist 'minibuffer) + (list (lax-plist-get initial-frame-plist + 'minibuffer))) + (and (lax-plist-member default-frame-plist + 'minibuffer) + (list (lax-plist-get default-frame-plist + 'minibuffer))) + '(t))) + t)) + ;; Create the new frame. + (let (props + ) + ;; If the frame isn't visible yet, wait till it is. + ;; If the user has to position the window, + ;; Emacs doesn't know its real position until + ;; the frame is seen to be visible. + + (if (frame-property frame-initial-frame 'initially-unmapped) + nil + (while (not (frame-visible-p frame-initial-frame)) + (sleep-for 1))) + (setq props (frame-properties frame-initial-frame)) + ;; Get rid of `name' unless it was specified explicitly before. + (or (lax-plist-member frame-initial-frame-plist 'name) + (setq props (lax-plist-remprop props 'name))) + (setq props (append initial-frame-plist default-frame-plist + props + nil)) + ;; Get rid of `reverse', because that was handled + ;; when we first made the frame. + (laxputf props 'reverse nil) + ;; Get rid of `window-id', otherwise make-frame will + ;; think we're trying to setup an external widget. + (laxremf props 'window-id) + (if (lax-plist-member frame-initial-geometry-arguments 'height) + (laxremf props 'height)) + (if (lax-plist-member frame-initial-geometry-arguments 'width) + (laxremf props 'width)) + (if (lax-plist-member frame-initial-geometry-arguments 'left) + (laxremf props 'left)) + (if (lax-plist-member frame-initial-geometry-arguments 'top) + (laxremf props 'top)) + + ;; Now create the replacement initial frame. + (make-frame + ;; Use the geometry args that created the existing + ;; frame, rather than the props we get for it. + (append '(user-size t user-position t) + frame-initial-geometry-arguments + props)) + ;; The initial frame, which we are about to delete, may be + ;; the only frame with a minibuffer. If it is, create a + ;; new one. + (or (delq frame-initial-frame (minibuffer-frame-list)) + (make-initial-minibuffer-frame nil)) + + ;; If the initial frame is serving as a surrogate + ;; minibuffer frame for any frames, we need to wean them + ;; onto a new frame. The default-minibuffer-frame + ;; variable must be handled similarly. + (let ((users-of-initial + (filtered-frame-list + #'(lambda (frame) + (and (not (eq frame frame-initial-frame)) + (eq (window-frame + (minibuffer-window frame)) + frame-initial-frame)))))) + (if (or users-of-initial + (eq default-minibuffer-frame frame-initial-frame)) + + ;; Choose an appropriate frame. Prefer frames which + ;; are only minibuffers. + (let* ((new-surrogate + (car + (or (filtered-frame-list + #'(lambda (frame) + (eq 'only + (frame-property frame 'minibuffer)))) + (minibuffer-frame-list)))) + (new-minibuffer (minibuffer-window new-surrogate))) + + (if (eq default-minibuffer-frame frame-initial-frame) + (setq default-minibuffer-frame new-surrogate)) + + ;; Wean the frames using frame-initial-frame as + ;; their minibuffer frame. + (mapcar + #' + (lambda (frame) + (set-frame-property frame 'minibuffer + new-minibuffer)) + users-of-initial)))) + + ;; Redirect events enqueued at this frame to the new frame. + ;; Is this a good idea? + ;; Probably not, since this whole redirect-frame-focus + ;; stuff is a load of trash, and so is this function we're in. + ;; --ben + ;(redirect-frame-focus frame-initial-frame new) + + ;; Finally, get rid of the old frame. + (delete-frame frame-initial-frame t)) + + ;; Otherwise, we don't need all that rigamarole; just apply + ;; the new properties. + (let (newprops allprops tail) + (setq allprops (append initial-frame-plist + default-frame-plist)) + (if (lax-plist-member frame-initial-geometry-arguments 'height) + (laxremf allprops 'height)) + (if (lax-plist-member frame-initial-geometry-arguments 'width) + (remf allprops 'width)) + (if (lax-plist-member frame-initial-geometry-arguments 'left) + (laxremf allprops 'left)) + (if (lax-plist-member frame-initial-geometry-arguments 'top) + (laxremf allprops 'top)) + (setq tail allprops) + ;; Find just the props that have changed since we first + ;; made this frame. Those are the ones actually set by + ;; the init file. For those props whose values we already knew + ;; (such as those spec'd by command line options) + ;; it is undesirable to specify the parm again + ;; once the user has seen the frame and been able to alter it + ;; manually. + (while tail + (let (newval oldval) + (setq oldval (lax-plist-get frame-initial-frame-plist + (car tail))) + (setq newval (lax-plist-get allprops (car tail))) + (or (eq oldval newval) + (laxputf newprops (car tail) newval))) + (setq tail (cddr tail))) + (set-frame-properties frame-initial-frame newprops) + ;silly FSFmacs junk + ;if (lax-plist-member newprops 'font) + ; (frame-update-faces frame-initial-frame)) + + ))) + + ;; Restore the original buffer. + (set-buffer old-buffer) + + ;; Make sure the initial frame can be GC'd if it is ever deleted. + ;; Make sure frame-notice-user-settings does nothing if called twice. + (setq frame-initial-frame nil))) + +(defun make-initial-minibuffer-frame (device) + (let ((props (append '(minibuffer only) + (safe-alist-to-plist minibuffer-frame-plist)))) + (make-frame props device))) + + +;;;; Creation of additional frames, and other frame miscellanea + +(defun get-other-frame () + "Return some frame other than the current frame, creating one if necessary." + (let* ((this (selected-frame)) + ;; search visible frames first + (next (next-frame this 'visible-nomini))) + ;; then search iconified frames + (if (eq this next) + (setq next (next-frame 'visible-iconic-nomini))) + (if (eq this next) + ;; otherwise, make a new frame + (make-frame) + next))) + +(defun next-multiframe-window () + "Select the next window, regardless of which frame it is on." + (interactive) + (select-window (next-window (selected-window) + (> (minibuffer-depth) 0) + t))) + +(defun previous-multiframe-window () + "Select the previous window, regardless of which frame it is on." + (interactive) + (select-window (previous-window (selected-window) + (> (minibuffer-depth) 0) + t))) + +(defun make-frame-on-device (type connection &optional props) + "Create a frame of type TYPE on CONNECTION. +TYPE should be a symbol naming the device type, i.e. one of + +x An X display. CONNECTION should be a standard display string + such as \"unix:0\", or nil for the display specified on the + command line or in the DISPLAY environment variable. Only if + support for X was compiled into XEmacs. +tty A standard TTY connection or terminal. CONNECTION should be + a TTY device name such as \"/dev/ttyp2\" (as determined by + the Unix command `tty') or nil for XEmacs' standard input + and output (usually the TTY in which XEmacs started). Only + if support for TTY's was compiled into XEmacs. +ns A connection to a machine running the NeXTstep windowing + system. Not currently implemented. +w32 A connection to a machine running Microsoft Windows NT or + Windows 95. +pc A direct-write MS-DOS frame. Not currently implemented. + +PROPS should be a plist of properties, as in the call to `make-frame'. + +If a connection to CONNECTION already exists, it is reused; otherwise, +a new connection is opened." + (make-frame props (make-device type connection props))) + +;; Alias, kept temporarily. +(defalias 'new-frame 'make-frame) + +; FSFmacs has make-frame here. We have it in C, so no need for +; frame-creation-function. + +(defun filtered-frame-list (predicate &optional device) + "Return a list of all live frames which satisfy PREDICATE. +If optional second arg DEVICE is non-nil, restrict the frames + returned to that device." + (let ((frames (if device (device-frame-list device) + (frame-list))) + good-frames) + (while (consp frames) + (if (funcall predicate (car frames)) + (setq good-frames (cons (car frames) good-frames))) + (setq frames (cdr frames))) + good-frames)) + +(defun minibuffer-frame-list (&optional device) + "Return a list of all frames with their own minibuffers. +If optional second arg DEVICE is non-nil, restrict the frames + returned to that device." + (filtered-frame-list + #'(lambda (frame) + (eq frame (window-frame (minibuffer-window frame)))) + device)) + +(defun frame-minibuffer-only-p (frame) + "Return non-nil if FRAME is a minibuffer-only frame." + (eq (frame-root-window frame) (minibuffer-window frame))) + +(defun frame-remove-geometry-props (plist) + "Return the property list PLIST, but with geometry specs removed. +This deletes all bindings in PLIST for `top', `left', `width', +`height', `user-size' and `user-position' properties. +Emacs uses this to avoid overriding explicit moves and resizings from +the user during startup." + (setq plist (canonicalize-lax-plist (copy-sequence plist))) + (mapcar #'(lambda (propname) + (if (lax-plist-member plist propname) + (progn + (setq frame-initial-geometry-arguments + (cons propname + (cons (lax-plist-get plist propname) + frame-initial-geometry-arguments))) + (setq plist (lax-plist-remprop plist propname))))) + '(height width top left user-size user-position)) + plist) + +(defun other-frame (arg) + "Select the ARG'th different visible frame, and raise it. +All frames are arranged in a cyclic order. +This command selects the frame ARG steps away in that order. +A negative ARG moves in the opposite order." + (interactive "p") + (let ((frame (selected-frame))) + (while (> arg 0) + (setq frame (next-frame frame 'visible-nomini)) + (setq arg (1- arg))) + (while (< arg 0) + (setq frame (previous-frame frame 'visible-nomini)) + (setq arg (1+ arg))) + (raise-frame frame) + (select-frame frame) + ;this is a bad idea; you should in general never warp the + ;pointer unless the user asks for this. Furthermore, + ;our version of `set-mouse-position' takes a window, + ;not a frame. + ;(set-mouse-position (selected-frame) (1- (frame-width)) 0) + ;some weird FSFmacs randomness + ;(if (fboundp 'unfocus-frame) + ; (unfocus-frame)))) + )) + +;; XEmacs-added utility functions + +; this is in C in FSFmacs +(defun frame-list () + "Return a list of all frames on all devices/consoles." + ;; Lists are copies, so nconc is safe here. + (apply 'nconc (mapcar 'device-frame-list (device-list)))) + +(defun frame-type (&optional frame) + "Return the type of the specified frame (e.g. `x' or `tty'). +This is equivalent to the type of the frame's device. +Value is `tty' for a tty frame (a character-only terminal), +`x' for a frame that is an X window, +`ns' for a frame that is a NeXTstep window (not yet implemented), +`win32' for a frame that is a Windows or Windows NT window (not yet + implemented), +`pc' for a frame that is a direct-write MS-DOS frame (not yet implemented), +`stream' for a stream frame (which acts like a stdio stream), and +`dead' for a deleted frame." + (or frame (setq frame (selected-frame))) + (if (not (frame-live-p frame)) 'dead + (device-type (frame-device frame)))) + +(defun device-or-frame-p (object) + "Return non-nil if OBJECT is a device or frame." + (or (devicep object) + (framep object))) + +(defun device-or-frame-type (device-or-frame) + "Return the type (e.g. `x' or `tty') of DEVICE-OR-FRAME. +DEVICE-OR-FRAME should be a device or a frame object. See `device-type' +for a description of the possible types." + (if (devicep device-or-frame) + (device-type device-or-frame) + (frame-type device-or-frame))) + +(defun fw-frame (obj) + "Given a frame or window, return the associated frame. +Return nil otherwise." + (cond ((windowp obj) (window-frame obj)) + ((framep obj) obj) + (t nil))) + + +;;;; Frame configurations + +(defun current-frame-configuration () + "Return a list describing the positions and states of all frames. +Its car is `frame-configuration'. +Each element of the cdr is a list of the form (FRAME PLIST WINDOW-CONFIG), +where + FRAME is a frame object, + PLIST is a property list specifying some of FRAME's properties, and + WINDOW-CONFIG is a window configuration object for FRAME." + (cons 'frame-configuration + (mapcar (function + (lambda (frame) + (list frame + (frame-properties frame) + (current-window-configuration frame)))) + (frame-list)))) + +(defun set-frame-configuration (configuration &optional nodelete) + "Restore the frames to the state described by CONFIGURATION. +Each frame listed in CONFIGURATION has its position, size, window +configuration, and other properties set as specified in CONFIGURATION. +Ordinarily, this function deletes all existing frames not +listed in CONFIGURATION. But if optional second argument NODELETE +is given and non-nil, the unwanted frames are iconified instead." + (or (frame-configuration-p configuration) + (signal 'wrong-type-argument + (list 'frame-configuration-p configuration))) + (let ((config-plist (cdr configuration)) + frames-to-delete) + (mapc (lambda (frame) + (let ((properties (assq frame config-plist))) + (if properties + (progn + (set-frame-properties + frame + ;; Since we can't set a frame's minibuffer status, + ;; we might as well omit the parameter altogether. + (lax-plist-remprop (nth 1 properties) 'minibuffer)) + (set-window-configuration (nth 2 properties))) + (setq frames-to-delete (cons frame frames-to-delete))))) + (frame-list)) + (if nodelete + ;; Note: making frames invisible here was tried + ;; but led to some strange behavior--each time the frame + ;; was made visible again, the window manager asked afresh + ;; for where to put it. + (mapc 'iconify-frame frames-to-delete) + (mapc 'delete-frame frames-to-delete)))) + +; this function is in subr.el in FSFmacs. +; that's because they don't always include frame.el, while we do. + +(defun frame-configuration-p (object) + "Return non-nil if OBJECT seems to be a frame configuration. +Any list whose car is `frame-configuration' is assumed to be a frame +configuration." + (and (consp object) + (eq (car object) 'frame-configuration))) + + +;; FSFmacs has functions `frame-width', `frame-height' here. +;; We have them in C. + +;; FSFmacs has weird functions `set-default-font', `set-background-color', +;; `set-foreground-color' here. They don't do sensible things like +;; set faces; instead they set frame properties (??!!) and call +;; useless functions such as `frame-update-faces' and +;; `frame-update-face-colors'. + +;; FSFmacs has functions `set-cursor-color', `set-mouse-color', and +;; `set-border-color', which refer to frame properties. +;; #### We need to use specifiers here. + +;(defun auto-raise-mode (arg) +; "Toggle whether or not the selected frame should auto-raise. +;With arg, turn auto-raise mode on if and only if arg is positive. +;Note that this controls Emacs's own auto-raise feature. +;Some window managers allow you to enable auto-raise for certain windows. +;You can use that for Emacs windows if you wish, but if you do, +;that is beyond the control of Emacs and this command has no effect on it." +; (interactive "P") +; (if (null arg) +; (setq arg +; (if (frame-property (selected-frame) 'auto-raise) +; -1 1))) +; (set-frame-property (selected-frame) 'auto-raise (> arg 0))) + +;(defun auto-lower-mode (arg) +; "Toggle whether or not the selected frame should auto-lower. +;With arg, turn auto-lower mode on if and only if arg is positive. +;Note that this controls Emacs's own auto-lower feature. +;Some window managers allow you to enable auto-lower for certain windows. +;You can use that for Emacs windows if you wish, but if you do, +;that is beyond the control of Emacs and this command has no effect on it." +; (interactive "P") +; (if (null arg) +; (setq arg +; (if (frame-property (selected-frame) 'auto-lower) +; -1 1))) +; (set-frame-property (selected-frame) 'auto-lower (> arg 0))) + +;; FSFmacs has silly functions `toggle-scroll-bar', +;; `toggle-horizontal-scrollbar' + +;;; Iconifying emacs. +;;; +;;; The function iconify-emacs replaces every non-iconified emacs window +;;; with a *single* icon. Iconified emacs windows are left alone. When +;;; emacs is in this globally-iconified state, de-iconifying any emacs icon +;;; will uniconify all frames that were visible, and iconify all frames +;;; that were not. This is done by temporarily changing the value of +;;; `map-frame-hook' to `deiconify-emacs' (which should never be called +;;; except from the map-frame-hook while emacs is iconified). +;;; +;;; The title of the icon representing all emacs frames is controlled by +;;; the variable `icon-name'. This is done by temporarily changing the +;;; value of `frame-icon-title-format'. Unfortunately, this changes the +;;; titles of all emacs icons, not just the "big" icon. +;;; +;;; It would be nice if existing icons were removed and restored by +;;; iconifying the emacs process, but I couldn't make that work yet. + +(defvar icon-name nil) ; set this at run time, not load time. + +(defvar iconification-data nil) + +(defun iconify-emacs () + "Replace every non-iconified FRAME with a *single* icon. +Iconified frames are left alone. When XEmacs is in this +globally-iconified state, de-iconifying any emacs icon will uniconify +all frames that were visible, and iconify all frames that were not." + (interactive) + (if iconification-data (error "already iconified?")) + (let* ((frames (frame-list)) + (rest frames) + (me (selected-frame)) + frame) + (while rest + (setq frame (car rest)) + (setcar rest (cons frame (frame-visible-p frame))) +; (if (memq (cdr (car rest)) '(icon nil)) +; (progn +; (make-frame-visible frame) ; deiconify, and process the X event +; (sleep-for 500 t) ; process X events; I really want to XSync() here +; )) + (or (eq frame me) (make-frame-invisible frame)) + (setq rest (cdr rest))) + (or (boundp 'map-frame-hook) (setq map-frame-hook nil)) + (or icon-name + (setq icon-name (concat invocation-name " @ " (system-name)))) + (setq iconification-data + (list frame-icon-title-format map-frame-hook frames) + frame-icon-title-format icon-name + map-frame-hook 'deiconify-emacs) + (iconify-frame me))) + + +(defun deiconify-emacs (&optional ignore) + (or iconification-data (error "not iconified?")) + (setq frame-icon-title-format (car iconification-data) + map-frame-hook (car (cdr iconification-data)) + iconification-data (car (cdr (cdr iconification-data)))) + (while iconification-data + (let ((visibility (cdr (car iconification-data)))) + (cond (visibility ;; JV (Note non-nil means visible in XEmacs) + (make-frame-visible (car (car iconification-data)))) +; (t ;; (eq visibility 'icon) ;; JV Not in XEmacs!!! +; (make-frame-visible (car (car iconification-data))) +; (sleep-for 500 t) ; process X events; I really want to XSync() here +; (iconify-frame (car (car iconification-data)))) + ;; (t nil) + )) + (setq iconification-data (cdr iconification-data)))) + +(defun suspend-or-iconify-emacs () + "Calls iconify-emacs if frame is an X frame, otherwise calls suspend-emacs" + (interactive) + (cond + ((eq (frame-type) 'x) + (iconify-emacs)) + ((and (eq (frame-type) 'tty) + (console-tty-controlling-process (selected-console))) + (suspend-console (selected-console))) + (t + (suspend-emacs)))) + +;; This is quite a mouthful, but it should be descriptive, as it's +;; bound to C-z +(defun suspend-emacs-or-iconify-frame () + "Iconify current frame if it is an X frame, otherwise suspend Emacs." + (interactive) + (cond ((eq (frame-type) 'x) + (iconify-frame)) + ((and (eq (frame-type) 'tty) + (console-tty-controlling-process (selected-console))) + (suspend-console (selected-console))) + (t + (suspend-emacs)))) + + +;;; auto-raise and auto-lower + +(defcustom auto-raise-frame nil + "*If true, frames will be raised to the top when selected. +Under X, most ICCCM-compliant window managers will have an option to do this +for you, but this variable is provided in case you're using a broken WM." + :type 'boolean + :group 'frames) + +(defcustom auto-lower-frame nil + "*If true, frames will be lowered to the bottom when no longer selected. +Under X, most ICCCM-compliant window managers will have an option to do this +for you, but this variable is provided in case you're using a broken WM." + :type 'boolean + :group 'frames) + +(defun default-select-frame-hook () + "Implements the `auto-raise-frame' variable. +For use as the value of `select-frame-hook'." + (if auto-raise-frame (raise-frame (selected-frame)))) + +(defun default-deselect-frame-hook () + "Implements the `auto-lower-frame' variable. +For use as the value of `deselect-frame-hook'." + (if auto-lower-frame (lower-frame (selected-frame)))) + +(or select-frame-hook + (add-hook 'select-frame-hook 'default-select-frame-hook)) + +(or deselect-frame-hook + (add-hook 'deselect-frame-hook 'default-deselect-frame-hook)) + +(defun default-drag-and-drop-functions (frame filepath &optional data) + "Implements the `drag-and-drop-functions' variable. +For use as the value of `drag-and-drop-functions'. +A file is popped up in a new buffer, some data without +is inserted at point." + ;; changed this back -- hope it works for CDE ;-) Oliver Graf <ograf@fga.de> + ;; the OffiX drop stuff has moved to mouse.el (mouse-offix-drop) + (if data + (insert data) + (let ((x pop-up-windows)) + (setq pop-up-windows nil) + (pop-to-buffer (find-file-noselect filepath) nil frame) + (make-frame-visible frame) + (setq pop-up-windows x)))) + +(and (boundp 'drag-and-drop-functions) + (or drag-and-drop-functions + (add-hook 'drag-and-drop-functions 'default-drag-and-drop-functions))) + +(defun cde-start-drag (begin end) + "Implements the CDE drag operation. +Calls the internal function cde-start-drag-internal to do the actual work." + (interactive "_r") + (if (featurep 'cde) + ;; Avoid build-time doc string warning by calling the function + ;; in the following roundabout way: + (funcall (intern "cde-start-drag-internal") + (buffer-substring-no-properties begin end)) + (error "CDE functionality not compiled in."))) + +;; the OffiX drag stuff will soon move also (perhaps mouse.el) +;; if the drag event is done +(defun offix-start-drag (event data &optional type) + "Implements the OffiX drag operation. +Calls the internal function offix-start-drag-internal to do the actual work. +If type is not given, DndText is assumed." + ;; Oliver Graf <ograf@fga.de> + (interactive "esi") + (if (featurep 'offix) + (funcall (intern "offix-start-drag-internal") event data type) + (error "OffiX functionality not compiled in."))) + +(defun offix-start-drag-region (event begin end) + "Implements the OffiX drag operation for a region. +Calls the internal function offix-start-drag-internal to do the actual work. +This always assumes DndText as type." + ;; Oliver Graf <ograf@fga.de> + (interactive "_er") + (if (featurep 'offix) + (funcall (intern "offix-start-drag-internal") + event (buffer-substring-no-properties begin end)) + (error "OffiX functionality not compiled in."))) + + + +;;; Application-specific frame-management + +(defvar get-frame-for-buffer-default-frame-name nil + "The default frame to select; see doc of `get-frame-for-buffer'.") + +(defvar get-frame-for-buffer-default-instance-limit nil) + +(defun get-frame-name-for-buffer (buffer) + (let ((mode (and (get-buffer buffer) + (save-excursion (set-buffer buffer) + major-mode)))) + (or (get mode 'frame-name) + get-frame-for-buffer-default-frame-name))) + +(defun get-frame-for-buffer-make-new-frame (buffer &optional frame-name plist) + (let* ((fr (make-frame plist)) + (w (frame-root-window fr))) + ;; + ;; Make the one buffer being displayed in this newly created + ;; frame be the buffer of interest, instead of something + ;; random, so that it won't be shown in two-window mode. + ;; Avoid calling switch-to-buffer here, since that's something + ;; people might want to call this routine from. + ;; + ;; (If the root window doesn't have a buffer, then that means + ;; there is more than one window on the frame, which can only + ;; happen if the user has done something funny on the frame- + ;; creation-hook. If that's the case, leave it alone.) + ;; + (if (window-buffer w) + (set-window-buffer w buffer)) + fr)) + +(defun get-frame-for-buffer-noselect (buffer + &optional not-this-window-p on-frame) + "Return a frame in which to display BUFFER. +This is a subroutine of `get-frame-for-buffer' (which see)." + (let (name limit) + (cond + ((or on-frame (eq (selected-window) (minibuffer-window))) + ;; don't switch frames if a frame was specified, or to list + ;; completions from the minibuffer, etc. + nil) + + ((setq name (get-frame-name-for-buffer buffer)) + ;; + ;; This buffer's mode expressed a preference for a frame of a particular + ;; name. That always takes priority. + ;; + (let ((limit (get name 'instance-limit)) + (defaults (get name 'frame-defaults)) + (matching-frames '()) + frames frame already-visible) + ;; Sort the list so that iconic frames will be found last. They + ;; will be used too, but mapped frames take precedence. And + ;; fully visible frames come before occluded frames. + ;; Hidden frames come after really visible ones + (setq frames + (sort (frame-list) + #'(lambda (s1 s2) + (cond ((frame-totally-visible-p s2) + nil) + ((not (frame-visible-p s2)) + (frame-visible-p s1)) + ((eq (frame-visible-p s2) 'hidden) + (eq (frame-visible-p s1) t )) + ((not (frame-totally-visible-p s2)) + (and (frame-visible-p s1) + (frame-totally-visible-p s1))))))) + ;; but the selected frame should come first, even if it's occluded, + ;; to minimize thrashing. + (setq frames (cons (selected-frame) + (delq (selected-frame) frames))) + + (setq name (symbol-name name)) + (while frames + (setq frame (car frames)) + (if (equal name (frame-name frame)) + (if (get-buffer-window buffer frame) + (setq already-visible frame + frames nil) + (setq matching-frames (cons frame matching-frames)))) + (setq frames (cdr frames))) + (cond (already-visible + already-visible) + ((or (null matching-frames) + (eq limit 0) ; means create with reckless abandon + (and limit (< (length matching-frames) limit))) + (get-frame-for-buffer-make-new-frame + buffer + name + (alist-to-plist (acons 'name name + (plist-to-alist defaults))))) + (t + ;; do not switch any of the window/buffer associations in an + ;; existing frame; this function only picks a frame; the + ;; determination of which windows on it get reused is up to + ;; display-buffer itself. +;; (or (window-dedicated-p (selected-window)) +;; (switch-to-buffer buffer)) + (car matching-frames))))) + + ((setq limit get-frame-for-buffer-default-instance-limit) + ;; + ;; This buffer's mode did not express a preference for a frame of a + ;; particular name, but the user wants a new frame rather than + ;; reusing the existing one. + (let* ((defname + (or (plist-get default-frame-plist 'name) + default-frame-name)) + (frames + (sort (filtered-frame-list #'(lambda (x) + (or (frame-visible-p x) + (frame-iconified-p x)))) + #'(lambda (s1 s2) + (cond ((and (frame-visible-p s1) + (not (frame-visible-p s2)))) + ((and (eq (frame-visible-p s1) t) + (eq (frame-visible-p s2) 'hidden))) + ((and (frame-visible-p s2) + (not (frame-visible-p s1))) + nil) + ((and (equal (frame-name s1) defname) + (not (equal (frame-name s2) defname)))) + ((and (equal (frame-name s2) defname) + (not (equal (frame-name s1) defname))) + nil) + ((frame-totally-visible-p s2) + nil) + (t)))))) + ;; put the selected frame last. The user wants a new frame, + ;; so don't reuse the existing one unless forced to. + (setq frames (append (delq (selected-frame) frames) (list frames))) + (if (or (eq limit 0) ; means create with reckless abandon + (< (length frames) limit)) + (get-frame-for-buffer-make-new-frame buffer) + (car frames)))) + + (t + ;; + ;; This buffer's mode did not express a preference for a frame of a + ;; particular name. So try to find a frame already displaying this + ;; buffer. + ;; + (let ((w (or (get-buffer-window buffer 'visible) ; check visible first + (get-buffer-window buffer 0)))) ; then iconic + (cond ((null w) + ;; It's not in any window - return nil, meaning no frame has + ;; preference. + nil) + ((and not-this-window-p + (eq (selected-frame) (window-frame w))) + ;; It's in a window, but on this frame, and we have been + ;; asked to pick another window. Return nil, meaning no + ;; frame has preference. + nil) + (t + ;; Otherwise, return the frame of the buffer's window. + (window-frame w)))))))) + + +;; The pre-display-buffer-function is called for effect, so this needs to +;; actually select the frame it wants. Fdisplay_buffer() takes notice of +;; changes to the selected frame. +(defun get-frame-for-buffer (buffer &optional not-this-window-p on-frame) + "Select and return a frame in which to display BUFFER. +Normally, the buffer will simply be displayed in the current frame. +But if the symbol naming the major-mode of the buffer has a 'frame-name +property (which should be a symbol), then the buffer will be displayed in +a frame of that name. If there is no frame of that name, then one is +created. + +If the major-mode doesn't have a 'frame-name property, then the frame +named by `get-frame-for-buffer-default-frame-name' will be used. If +that is nil (the default) then the currently selected frame will used. + +If the frame-name symbol has an 'instance-limit property (an integer) +then each time a buffer of the mode in question is displayed, a new frame +with that name will be created, until there are `instance-limit' of them. +If instance-limit is 0, then a new frame will be created each time. + +If a buffer is already displayed in a frame, then `instance-limit' is +ignored, and that frame is used. + +If the frame-name symbol has a 'frame-defaults property, then that is +prepended to the `default-frame-plist' when creating a frame for the +first time. + +This function may be used as the value of `pre-display-buffer-function', +to cause the display-buffer function and its callers to exhibit the above +behavior." + (let ((frame (get-frame-for-buffer-noselect + buffer not-this-window-p on-frame))) + (if (not (eq frame (selected-frame))) + frame + (select-frame frame) + (or (frame-visible-p frame) + ;; If the frame was already visible, just focus on it. + ;; If it wasn't visible (it was just created, or it used + ;; to be iconified) then uniconify, raise, etc. + (make-frame-visible frame)) + frame))) + +(defun frames-of-buffer (&optional buffer visible-only) + "Return list of frames that BUFFER is currently being displayed on. +If the buffer is being displayed on the currently selected frame, that frame +is first in the list. VISIBLE-ONLY will only list non-iconified frames." + (let ((list (windows-of-buffer buffer)) + (cur-frame (selected-frame)) + next-frame frames save-frame) + + (while list + (if (memq (setq next-frame (window-frame (car list))) + frames) + nil + (if (eq cur-frame next-frame) + (setq save-frame next-frame) + (and + (or (not visible-only) + (frame-visible-p next-frame)) + (setq frames (append frames (list next-frame)))))) + (setq list (cdr list))) + + (if save-frame + (append (list save-frame) frames) + frames))) + +(defcustom temp-buffer-shrink-to-fit nil + "*When non-nil resize temporary output buffers to minimize blank lines." + :type 'boolean + :group 'frames) + +(defcustom temp-buffer-max-height .5 + "*Proportion of frame to use for temp windows." + :type 'number + :group 'frames) + +(defun show-temp-buffer-in-current-frame (buffer) + "For use as the value of temp-buffer-show-function: +always displays the buffer in the current frame, regardless of the behavior +that would otherwise be introduced by the `pre-display-buffer-function', which +is normally set to `get-frame-for-buffer' (which see)." + (let ((pre-display-buffer-function nil)) ; turn it off, whatever it is + (let ((window (display-buffer buffer))) + (if (not (eq (last-nonminibuf-frame) (window-frame window))) + ;; only the pre-display-buffer-function should ever do this. + (error "display-buffer switched frames on its own!!")) + (setq minibuffer-scroll-window window) + (set-window-start window 1) ; obeys narrowing + (set-window-point window 1) + (when temp-buffer-shrink-to-fit + (let* ((temp-window-size (round (* temp-buffer-max-height + (frame-height (window-frame window))))) + (size (window-displayed-height window))) + (when (< size temp-window-size) + (enlarge-window (- temp-window-size size) nil window))) + (shrink-window-if-larger-than-buffer window)) + nil))) + +(setq pre-display-buffer-function 'get-frame-for-buffer) +(setq temp-buffer-show-function 'show-temp-buffer-in-current-frame) + + +;; from Bob Weiner <bweiner@pts.mot.com>, modified by Ben Wing +(defun delete-other-frames (&optional frame) + "Delete all but FRAME (or the selected frame)." + (interactive) + (mapc 'delete-frame (delq (or frame (selected-frame)) (frame-list)))) + +;; By adding primitives to directly access the window hierarchy, +;; we can move many functions into Lisp. We do it this way +;; because the implementations are simpler in Lisp, and because +;; new functions like this can be added without requiring C +;; additions. + +(defun frame-utmost-window-2 (window position left-right-p major-end-p + minor-end-p) + ;; LEFT-RIGHT-P means we're looking for the leftmost or rightmost + ;; window, instead of the highest or lowest. In this case, we + ;; say that the "major axis" goes left-to-right instead of top-to- + ;; bottom. The "minor axis" always goes perpendicularly. + ;; + ;; If MAJOR-END-P is t, we're looking for a windows that abut the + ;; end (i.e. right or bottom) of the major axis, instead of the + ;; start. + ;; + ;; If MINOR-END-P is t, then we want to start counting from the + ;; end of the minor axis instead of the beginning. + ;; + ;; Here's the general idea: Imagine we're trying to count the number + ;; of windows that abut the top; call this function foo(). So, we + ;; start with the root window. If this is a vertical combination + ;; window, then foo() applied to the root window is the same as + ;; foo() applied to the first child. If the root is a horizontal + ;; combination window, then foo() applied to the root is the + ;; same as the sum of foo() applied to each of the children. + ;; Otherwise, the root window is a leaf window, and foo() is 1. + ;; Now it's clear that, each time foo() encounters a leaf window, + ;; it's encountering a different window that abuts the top. + ;; With a little examining, you can see that foo encounters the + ;; top-abutting windows in order from left to right. We can + ;; modify foo() to return the nth top-abutting window by simply + ;; keeping a global variable that is decremented each time + ;; foo() encounters a leaf window and would return 1. If the + ;; global counter gets to zero, we've encountered the window + ;; we were looking for, so we exit right away using a `throw'. + ;; Otherwise, we make sure that all normal paths return nil. + + (let (child) + (cond ((setq child (if left-right-p + (window-first-hchild window) + (window-first-vchild window))) + (if major-end-p + (while (window-next-child child) + (setq child (window-next-child child)))) + (frame-utmost-window-2 child position left-right-p major-end-p + minor-end-p)) + ((setq child (if left-right-p + (window-first-vchild window) + (window-first-hchild window))) + (if minor-end-p + (while (window-next-child child) + (setq child (window-next-child child)))) + (while child + (frame-utmost-window-2 child position left-right-p major-end-p + minor-end-p) + (setq child (if minor-end-p + (window-previous-child child) + (window-next-child child)))) + nil) + (t + (setcar position (1- (car position))) + (if (= (car position) 0) + (throw 'fhw-exit window) + nil))))) + +(defun frame-utmost-window-1 (frame position left-right-p major-end-p) + (let (minor-end-p) + (or frame (setq frame (selected-frame))) + (or position (setq position 0)) + (if (>= position 0) + (setq position (1+ position)) + (setq minor-end-p t) + (setq position (- position))) + (catch 'fhw-exit + ;; we use a cons here as a simple form of call-by-reference. + ;; scheme has "boxes" for the same purpose. + (frame-utmost-window-2 (frame-root-window frame) (list position) + left-right-p major-end-p minor-end-p)))) + + +(defun frame-highest-window (&optional frame position) + "Return the highest window on FRAME which is at POSITION. +If omitted, FRAME defaults to the currently selected frame. +POSITION is used to distinguish between multiple windows that abut + the top of the frame: 0 means the leftmost window abutting the + top of the frame, 1 the next-leftmost, etc. POSITION can also + be less than zero: -1 means the rightmost window abutting the + top of the frame, -2 the next-rightmost, etc. +If omitted, POSITION defaults to 0, i.e. the leftmost highest window. +If there is no window at the given POSITION, return nil." + (frame-utmost-window-1 frame position nil nil)) + +(defun frame-lowest-window (&optional frame position) + "Return the lowest window on FRAME which is at POSITION. +If omitted, FRAME defaults to the currently selected frame. +POSITION is used to distinguish between multiple windows that abut + the bottom of the frame: 0 means the leftmost window abutting the + bottom of the frame, 1 the next-leftmost, etc. POSITION can also + be less than zero: -1 means the rightmost window abutting the + bottom of the frame, -2 the next-rightmost, etc. +If omitted, POSITION defaults to 0, i.e. the leftmost lowest window. +If there is no window at the given POSITION, return nil." + (frame-utmost-window-1 frame position nil t)) + +(defun frame-leftmost-window (&optional frame position) + "Return the leftmost window on FRAME which is at POSITION. +If omitted, FRAME defaults to the currently selected frame. +POSITION is used to distinguish between multiple windows that abut + the left edge of the frame: 0 means the highest window abutting the + left edge of the frame, 1 the next-highest, etc. POSITION can also + be less than zero: -1 means the lowest window abutting the + left edge of the frame, -2 the next-lowest, etc. +If omitted, POSITION defaults to 0, i.e. the highest leftmost window. +If there is no window at the given POSITION, return nil." + (frame-utmost-window-1 frame position t nil)) + +(defun frame-rightmost-window (&optional frame position) + "Return the rightmost window on FRAME which is at POSITION. +If omitted, FRAME defaults to the currently selected frame. +POSITION is used to distinguish between multiple windows that abut + the right edge of the frame: 0 means the highest window abutting the + right edge of the frame, 1 the next-highest, etc. POSITION can also + be less than zero: -1 means the lowest window abutting the + right edge of the frame, -2 the next-lowest, etc. +If omitted, POSITION defaults to 0, i.e. the highest rightmost window. +If there is no window at the given POSITION, return nil." + (frame-utmost-window-1 frame position t t)) + + + +;; frame properties. + +(defun set-frame-property (frame prop val) + "Set property PROP of FRAME to VAL. See `set-frame-properties'." + (set-frame-properties frame (list prop val))) + +(defun frame-height (&optional frame) + "Return number of lines available for display on FRAME." + (frame-property frame 'height)) + +(defun frame-width (&optional frame) + "Return number of columns available for display on FRAME." + (frame-property frame 'width)) + +(put 'cursor-color 'frame-property-alias [text-cursor background]) +(put 'modeline 'frame-property-alias 'has-modeline-p) + + +(provide 'frame) + +;;; frame.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/glyphs.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,684 @@ +;;; glyphs.el --- Lisp interface to C glyphs + +;; Copyright (C) 1994, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1995, 1996 Ben Wing. + +;; Author: Chuck Thompson <cthomp@cs.uiuc.edu>, Ben Wing <wing@666.com> +;; Maintainer: XEmacs Development Team +;; Keywords: extensions, internal, dumped + +;; 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, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: Not in FSF. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;;; Code: + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; font specifiers + +(defun make-image-specifier (spec-list) + "Create a new `image' specifier object with the given specification list. +SPEC-LIST can be a list of specifications (each of which is a cons of a +locale and a list of instantiators), a single instantiator, or a list +of instantiators. See `make-specifier' for more information about +specifiers." + (make-specifier-and-init 'image spec-list)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; glyphs + +(defconst built-in-glyph-specifiers + '(image contrib-p baseline) + "A list of the built-in face properties that are specifiers.") + +(defun glyph-property (glyph property &optional locale) + "Return GLYPH's value of the given PROPERTY. + +If LOCALE is omitted, the GLYPH's actual value for PROPERTY will be + returned. For built-in properties, this will be a specifier object + of a type appropriate to the property (e.g. a font or color + specifier). For other properties, this could be anything. + +If LOCALE is supplied, then instead of returning the actual value, + the specification(s) for the given locale or locale type will + be returned. This will only work if the actual value of + PROPERTY is a specifier (this will always be the case for built-in + properties, but not or not may apply to user-defined properties). + If the actual value of PROPERTY is not a specifier, this value + will simply be returned regardless of LOCALE. + +The return value will be a list of instantiators (e.g. strings + specifying a font or color name), or a list of specifications, each + of which is a cons of a locale and a list of instantiators. + Specifically, if LOCALE is a particular locale (a buffer, window, + frame, device, or 'global), a list of instantiators for that locale + will be returned. Otherwise, if LOCALE is a locale type (one of + the symbols 'buffer, 'window, 'frame, 'device, 'device-class, or + 'device-type), the specifications for all locales of that type will + be returned. Finally, if LOCALE is 'all, the specifications for all + locales of all types will be returned. + +The specifications in a specifier determine what the value of + PROPERTY will be in a particular \"domain\" or set of circumstances, + which is typically a particular Emacs window along with the buffer + it contains and the frame and device it lies within. The value + is derived from the instantiator associated with the most specific + locale (in the order buffer, window, frame, device, and 'global) + that matches the domain in question. In other words, given a domain + (i.e. an Emacs window, usually), the specifier for PROPERTY will first + be searched for a specification whose locale is the buffer contained + within that window; then for a specification whose locale is the window + itself; then for a specification whose locale is the frame that the + window is contained within; etc. The first instantiator that is + valid for the domain (usually this means that the instantiator is + recognized by the device [i.e. the X server or TTY device] that the + domain is on. The function `glyph-property-instance' actually does + all this, and is used to determine how to display the glyph. + +See `set-glyph-property' for the built-in property-names." + (check-argument-type 'glyphp glyph) + (let ((value (get glyph property))) + (if (and locale + (or (memq property built-in-glyph-specifiers) + (specifierp value))) + (setq value (specifier-specs value locale))) + value)) + +(defun convert-glyph-property-into-specifier (glyph property) + "Convert PROPERTY on GLYPH into a specifier, if it's not already." + (check-argument-type 'glyphp glyph) + (let ((specifier (get glyph property))) + ;; if a user-property does not have a specifier but a + ;; locale was specified, put a specifier there. + ;; If there was already a value there, convert it to a + ;; specifier with the value as its 'global instantiator. + (if (not (specifierp specifier)) + (let ((new-specifier (make-specifier 'generic))) + (if (or (not (null specifier)) + ;; make sure the nil returned from `get' wasn't + ;; actually the value of the property + (null (get glyph property t))) + (add-spec-to-specifier new-specifier specifier)) + (setq specifier new-specifier) + (put glyph property specifier))))) + +(defun glyph-property-instance (glyph property + &optional domain default no-fallback) + "Return the instance of GLYPH's PROPERTY in the specified DOMAIN. + +Under most circumstances, DOMAIN will be a particular window, + and the returned instance describes how the specified property + actually is displayed for that window and the particular buffer + in it. Note that this may not be the same as how the property + appears when the buffer is displayed in a different window or + frame, or how the property appears in the same window if you + switch to another buffer in that window; and in those cases, + the returned instance would be different. + +DOMAIN defaults to the selected window if omitted. + +DOMAIN can be a frame or device, instead of a window. The value + returned for a such a domain is used in special circumstances + when a more specific domain does not apply; for example, a frame + value might be used for coloring a toolbar, which is conceptually + attached to a frame rather than a particular window. The value + is also useful in determining what the value would be for a + particular window within the frame or device, if it is not + overridden by a more specific specification. + +If PROPERTY does not name a built-in property, its value will + simply be returned unless it is a specifier object, in which case + it will be instanced using `specifier-instance'. + +Optional arguments DEFAULT and NO-FALLBACK are the same as in + `specifier-instance'." + (check-argument-type 'glyphp glyph) + (let ((value (get glyph property))) + (if (specifierp value) + (setq value (specifier-instance value domain default no-fallback))) + value)) + +(defun set-glyph-property (glyph property value &optional locale tag-set + how-to-add) + "Change a property of a GLYPH. + +NOTE: If you want to remove a property from a glyph, use + `remove-glyph-property' rather than attempting to set a value of nil + for the property. + +For built-in properties, the actual value of the property is a + specifier and you cannot change this; but you can change the + specifications within the specifier, and that is what this function + will do. For user-defined properties, you can use this function + to either change the actual value of the property or, if this value + is a specifier, change the specifications within it. + +If PROPERTY is a built-in property, the specifications to be added to + this property can be supplied in many different ways: + + -- If VALUE is a simple instantiator (e.g. a string naming a font or + color) or a list of instantiators, then the instantiator(s) will + be added as a specification of the property for the given LOCALE + (which defaults to 'global if omitted). + -- If VALUE is a list of specifications (each of which is a cons of + a locale and a list of instantiators), then LOCALE must be nil + (it does not make sense to explicitly specify a locale in this + case), and specifications will be added as given. + -- If VALUE is a specifier (as would be returned by `glyph-property' + if no LOCALE argument is given), then some or all of the + specifications in the specifier will be added to the property. + In this case, the function is really equivalent to + `copy-specifier' and LOCALE has the same semantics (if it is + a particular locale, the specification for the locale will be + copied; if a locale type, specifications for all locales of + that type will be copied; if nil or 'all, then all + specifications will be copied). + +HOW-TO-ADD should be either nil or one of the symbols 'prepend, + 'append, 'remove-tag-set-prepend, 'remove-tag-set-append, 'remove-locale, + 'remove-locale-type, or 'remove-all. See `copy-specifier' and + `add-spec-to-specifier' for a description of what each of + these means. Most of the time, you do not need to worry about + this argument; the default behavior usually is fine. + +In general, it is OK to pass an instance object (e.g. as returned + by `glyph-property-instance') as an instantiator in place of + an actual instantiator. In such a case, the instantiator used + to create that instance object will be used (for example, if + you set a font-instance object as the value of the 'font + property, then the font name used to create that object will + be used instead). If some cases, however, doing this + conversion does not make sense, and this will be noted in + the documentation for particular types of instance objects. + +If PROPERTY is not a built-in property, then this function will + simply set its value if LOCALE is nil. However, if LOCALE is + given, then this function will attempt to add VALUE as the + instantiator for the given LOCALE, using `add-spec-to-specifier'. + If the value of the property is not a specifier, it will + automatically be converted into a 'generic specifier. + + +The following symbols have predefined meanings: + + image The image used to display the glyph. + + baseline Percent above baseline that glyph is to be + displayed. + + contrib-p Whether the glyph contributes to the + height of the line it's on. + + face Face of this glyph (*not* a specifier)." + (check-argument-type 'glyphp glyph) + (if (memq property built-in-glyph-specifiers) + (set-specifier (get glyph property) value locale tag-set how-to-add) + + ;; This section adds user defined properties. + (if (not locale) + (put glyph property value) + (convert-glyph-property-into-specifier glyph property) + (add-spec-to-specifier (get glyph property) value locale tag-set + how-to-add))) + value) + +(defun remove-glyph-property (glyph property &optional locale tag-set exact-p) + "Remove a property from a glyph. +For built-in properties, this is analogous to `remove-specifier'. +See `remove-specifier' for the meaning of the LOCALE, TAG-SET, and EXACT-P + arguments." + (or locale (setq locale 'all)) + (if (memq property built-in-glyph-specifiers) + (remove-specifier (glyph-property glyph property) locale tag-set exact-p) + (if (eq locale 'all) + (remprop glyph property) + (convert-glyph-property-into-specifier glyph property) + (remove-specifier (glyph-property glyph property) locale tag-set + exact-p)))) + +(defun glyph-face (glyph) + "Return the face of GLYPH." + (glyph-property glyph 'face)) + +(defun set-glyph-face (glyph face) + "Change the face of GLYPH to FACE." +; (interactive (glyph-interactive "face")) + (set-glyph-property glyph 'face face)) + +(defun glyph-image (glyph &optional locale) + "Return the image of the given glyph, or nil if it is unspecified. + +LOCALE may be a locale (the instantiators for that particular locale + will be returned), a locale type (the specifications for all locales + of that type will be returned), 'all (all specifications will be + returned), or nil (the actual specifier object will be returned). + +See `glyph-property' for more information." + (glyph-property glyph 'image locale)) + +(defun glyph-image-instance (glyph &optional domain default no-fallback) + "Return the instance of the given glyph's image in the given domain. + +Normally DOMAIN will be a window or nil (meaning the selected window), + and an instance object describing how the image appears in that + particular window and buffer will be returned. + +See `glyph-property-instance' for more information." + (glyph-property-instance glyph 'image domain default no-fallback)) + +(defun set-glyph-image (glyph spec &optional locale tag-set how-to-add) + "Change the image of the given glyph. + +SPEC should be an instantiator (a string or vector; see + `image-specifier-p' for a description of possible values here), + a list of (possibly tagged) instantiators, an alist of specifications + (each mapping a locale to an instantiator list), or an image specifier + object. + +If SPEC is an alist, LOCALE must be omitted. If SPEC is a + specifier object, LOCALE can be a locale, a locale type, 'all, + or nil; see `copy-specifier' for its semantics. Otherwise LOCALE + specifies the locale under which the specified instantiator(s) + will be added, and defaults to 'global. + +See `set-glyph-property' for more information." + ; (interactive (glyph-interactive "image")) + (set-glyph-property glyph 'image spec locale tag-set how-to-add)) + +(defun glyph-contrib-p (glyph &optional locale) + "Return whether GLYPH contributes to its line height. + +LOCALE may be a locale (the instantiators for that particular locale + will be returned), a locale type (the specifications for all locales + of that type will be returned), 'all (all specifications will be + returned), or nil (the actual specifier object will be returned). + +See `glyph-property' for more information." + (glyph-property glyph 'contrib-p locale)) + +(defun glyph-contrib-p-instance (glyph &optional domain default no-fallback) + "Return the instance of the GLYPH's 'contrib-p property in the given domain. + +Normally DOMAIN will be a window or nil (meaning the selected window), + and an instance object describing what the 'contrib-p property is in + that particular window and buffer will be returned. + +See `glyph-property-instance' for more information." + (glyph-property-instance glyph 'contrib-p domain default no-fallback)) + +(defun set-glyph-contrib-p (glyph spec &optional locale tag-set how-to-add) + "Change the contrib-p of the given glyph. + +SPEC should be an instantiator (t or nil), a list of (possibly + tagged) instantiators, an alist of specifications (each mapping a + locale to an instantiator list), or a boolean specifier object. + +If SPEC is an alist, LOCALE must be omitted. If SPEC is a + specifier object, LOCALE can be a locale, a locale type, 'all, + or nil; see `copy-specifier' for its semantics. Otherwise LOCALE + specifies the locale under which the specified instantiator(s) + will be added, and defaults to 'global. + +See `set-glyph-property' for more information." + ; (interactive (glyph-interactive "contrib-p")) + (set-glyph-property glyph 'contrib-p spec locale tag-set how-to-add)) + +(defun glyph-baseline (glyph &optional locale) + "Return the baseline of the given glyph, or nil if it is unspecified. + +LOCALE may be a locale (the instantiators for that particular locale + will be returned), a locale type (the specifications for all locales + of that type will be returned), 'all (all specifications will be + returned), or nil (the actual specifier object will be returned). + +See `glyph-property' for more information." + (glyph-property glyph 'baseline locale)) + +(defun glyph-baseline-instance (glyph &optional domain default no-fallback) + "Return the instance of the given glyph's baseline in the given domain. + +Normally DOMAIN will be a window or nil (meaning the selected window), + and an integer or nil (specifying the baseline in that particular + window and buffer) will be returned. + +See `glyph-property-instance' for more information." + (glyph-property-instance glyph 'baseline domain default no-fallback)) + +(defun set-glyph-baseline (glyph spec &optional locale tag-set how-to-add) + "Change the baseline of the given glyph. + +SPEC should be an instantiator (an integer [a percentage above the + baseline of the line the glyph is on] or nil), a list of (possibly + tagged) instantiators, an alist of specifications (each mapping a + locale to an instantiator list), or a generic specifier object. + +If SPEC is an alist, LOCALE must be omitted. If SPEC is a + specifier object, LOCALE can be a locale, a locale type, 'all, + or nil; see `copy-specifier' for its semantics. Otherwise LOCALE + specifies the locale under which the specified instantiator(s) + will be added, and defaults to 'global. + +See `set-glyph-property' for more information." + ; (interactive (glyph-interactive "baseline")) + (set-glyph-property glyph 'baseline spec locale tag-set how-to-add)) + +(defun make-glyph (&optional spec-list type) + "Create a new `glyph' object of type TYPE. + +TYPE should be one of `buffer' (used for glyphs in an extent, the modeline, +the toolbar, or elsewhere in a buffer), `pointer' (used for the mouse-pointer), +or `icon' (used for a frame's icon), and defaults to `buffer'. + +SPEC-LIST is used to initialize the glyph's image. It is typically an +image instantiator (a string or a vector; see `image-specifier-p' for +a detailed description of the valid image instantiators), but can also +be a list of such instantiators (each one in turn is tried until an +image is successfully produced), a cons of a locale (frame, buffer, etc.) +and an instantiator, a list of such conses, or any other form accepted +by `canonicalize-spec-list'. See `make-specifier' for more information +about specifiers." + (let ((glyph (make-glyph-internal type))) + (and spec-list (set-glyph-image glyph spec-list)) + glyph)) + +(defun buffer-glyph-p (object) + "t if OBJECT is a glyph of type `buffer'." + (and (glyphp object) (eq 'buffer (glyph-type object)))) + +(defun pointer-glyph-p (object) + "t if OBJECT is a glyph of type `pointer'." + (and (glyphp object) (eq 'pointer (glyph-type object)))) + +(defun icon-glyph-p (object) + "t if OBJECT is a glyph of type `icon'." + (and (glyphp object) (eq 'icon (glyph-type object)))) + +(defun make-pointer-glyph (&optional spec-list) + "Create a new `pointer-glyph' object with the given specification list. + +This is equivalent to calling `make-glyph' and specifying a type of +`pointer'. + +SPEC-LIST is used to initialize the glyph's image. It is typically an +image instantiator (a string or a vector; see `image-specifier-p' for +a detailed description of the valid image instantiators), but can also +be a list of such instantiators (each one in turn is tried until an +image is successfully produced), a cons of a locale (frame, buffer, etc.) +and an instantiator, a list of such conses, or any other form accepted +by `canonicalize-spec-list'. See `make-specifier' for more information +about specifiers. + +You can also create a glyph with an empty SPEC-LIST and add image +instantiators afterwards using `set-glyph-image'." + (make-glyph spec-list 'pointer)) + +(defun make-icon-glyph (&optional spec-list) + "Create a new `icon-glyph' object with the given specification list. + +This is equivalent to calling `make-glyph' and specifying a type of +`icon'. + +SPEC-LIST is used to initialize the glyph's image. It is typically an +image instantiator (a string or a vector; see `image-specifier-p' for +a detailed description of the valid image instantiators), but can also +be a list of such instantiators (each one in turn is tried until an +image is successfully produced), a cons of a locale (frame, buffer, etc.) +and an instantiator, a list of such conses, or any other form accepted +by `canonicalize-spec-list'. See `make-specifier' for more information +about specifiers. + +You can also create a glyph with an empty SPEC-LIST and add image +instantiators afterwards using `set-glyph-image'." + (make-glyph spec-list 'icon)) + +(defun nothing-image-instance-p (object) + "t if OBJECT is an image instance of type `nothing'." + (and (image-instance-p object) (eq 'nothing (image-instance-type object)))) + +(defun text-image-instance-p (object) + "t if OBJECT is an image instance of type `text'." + (and (image-instance-p object) (eq 'text (image-instance-type object)))) + +(defun mono-pixmap-image-instance-p (object) + "t if OBJECT is an image instance of type `mono-pixmap'." + (and (image-instance-p object) (eq 'mono-pixmap + (image-instance-type object)))) + +(defun color-pixmap-image-instance-p (object) + "t if OBJECT is an image instance of type `color-pixmap'." + (and (image-instance-p object) (eq 'color-pixmap + (image-instance-type object)))) + +(defun pointer-image-instance-p (object) + "t if OBJECT is an image instance of type `pointer'." + (and (image-instance-p object) (eq 'pointer (image-instance-type object)))) + +(defun subwindow-image-instance-p (object) + "t if OBJECT is an image instance of type `subwindow'. +Subwindows are not implemented in this version of XEmacs." + (and (image-instance-p object) (eq 'subwindow (image-instance-type object)))) + +;;;;;;;;;; the built-in glyphs + +(defvar text-pointer-glyph (make-pointer-glyph) + "*The shape of the mouse-pointer when over text. +This is a glyph; use `set-glyph-image' to change it.") +(set-glyph-face text-pointer-glyph 'pointer) + +(defvar nontext-pointer-glyph (make-pointer-glyph) + "*The shape of the mouse-pointer when over a buffer, but not over text. +This is a glyph; use `set-glyph-image' to change it. +If unspecified in a particular domain, `text-pointer-glyph' is used.") +(set-glyph-face nontext-pointer-glyph 'pointer) + +(defvar modeline-pointer-glyph (make-pointer-glyph) + "*The shape of the mouse-pointer when over the modeline. +This is a glyph; use `set-glyph-image' to change it. +If unspecified in a particular domain, `nontext-pointer-glyph' is used.") +(set-glyph-face modeline-pointer-glyph 'pointer) + +(defvar selection-pointer-glyph (make-pointer-glyph) + "*The shape of the mouse-pointer when over a selectable text region. +This is a glyph; use `set-glyph-image' to change it. +If unspecified in a particular domain, `text-pointer-glyph' is used.") +(set-glyph-face selection-pointer-glyph 'pointer) + +(defvar busy-pointer-glyph (make-pointer-glyph) + "*The shape of the mouse-pointer when XEmacs is busy. +This is a glyph; use `set-glyph-image' to change it. +If unspecified in a particular domain, the pointer is not changed +when XEmacs is busy.") +(set-glyph-face busy-pointer-glyph 'pointer) + +(defvar toolbar-pointer-glyph (make-pointer-glyph) + "*The shape of the mouse-pointer when over a toolbar. +This is a glyph; use `set-glyph-image' to change it. +If unspecified in a particular domain, `nontext-pointer-glyph' is used.") +(set-glyph-face toolbar-pointer-glyph 'pointer) + +;; The following three are in C. +(if (featurep 'menubar) + (set-glyph-face menubar-pointer-glyph 'pointer)) +(if (featurep 'scrollbar) + (set-glyph-face scrollbar-pointer-glyph 'pointer)) +(set-glyph-face gc-pointer-glyph 'pointer) + +;; Now add the magic access/set behavior. + +(defun dontusethis-set-value-glyph-handler (sym args fun harg handler) + (error "Use `set-glyph-image' to set `%s'" sym)) +(defun dontusethis-make-unbound-glyph-handler (sym args fun harg handler) + (error "Can't `makunbound' `%s'" sym)) +(defun dontusethis-make-local-glyph-handler (sym args fun harg handler) + (error "Use `set-glyph-image' to make local values for `%s'" sym)) + +(defun define-constant-glyph (sym) + (dontusethis-set-symbol-value-handler + sym 'set-value + 'dontusethis-set-value-glyph-handler) + (dontusethis-set-symbol-value-handler + sym 'make-unbound + 'dontusethis-make-unbound-glyph-handler) + (dontusethis-set-symbol-value-handler + sym 'make-local + 'dontusethis-make-local-glyph-handler) + ;; Make frame properties magically work with glyph variables. + (put sym 'const-glyph-variable t)) + +(define-constant-glyph 'text-pointer-glyph) +(define-constant-glyph 'nontext-pointer-glyph) +(define-constant-glyph 'modeline-pointer-glyph) +(define-constant-glyph 'selection-pointer-glyph) +(define-constant-glyph 'busy-pointer-glyph) +(define-constant-glyph 'gc-pointer-glyph) +(define-constant-glyph 'toolbar-pointer-glyph) +(define-constant-glyph 'menubar-pointer-glyph) +(define-constant-glyph 'scrollbar-pointer-glyph) + +(define-constant-glyph 'octal-escape-glyph) +(define-constant-glyph 'control-arrow-glyph) +(define-constant-glyph 'invisible-text-glyph) +(define-constant-glyph 'hscroll-glyph) +(define-constant-glyph 'truncation-glyph) +(define-constant-glyph 'continuation-glyph) + +(define-constant-glyph 'frame-icon-glyph) + +;; backwards compatibility garbage + +(defun dontusethis-old-pointer-shape-handler (sym args fun harg handler) + (let ((value (car args))) + (if (null value) + (remove-specifier harg 'global) + (set-glyph-image (symbol-value harg) value)))) + +;; It might or might not be garbage, but it's rude. Make these +;; 'compatible instead of 'obsolete. -slb +(defun define-obsolete-pointer-glyph (old new) + (define-compatible-variable-alias old new) + (dontusethis-set-symbol-value-handler + old 'set-value 'dontusethis-old-pointer-shape-handler new)) + +;;; (defvar x-pointer-shape nil) +(define-obsolete-pointer-glyph 'x-pointer-shape 'text-pointer-glyph) + +;;; (defvar x-nontext-pointer-shape nil) +(define-obsolete-pointer-glyph 'x-nontext-pointer-shape 'nontext-pointer-glyph) + +;;; (defvar x-mode-pointer-shape nil) +(define-obsolete-pointer-glyph 'x-mode-pointer-shape 'modeline-pointer-glyph) + +;;; (defvar x-selection-pointer-shape nil) +(define-obsolete-pointer-glyph 'x-selection-pointer-shape + 'selection-pointer-glyph) + +;;; (defvar x-busy-pointer-shape nil) +(define-obsolete-pointer-glyph 'x-busy-pointer-shape 'busy-pointer-glyph) + +;;; (defvar x-gc-pointer-shape nil) +(define-obsolete-pointer-glyph 'x-gc-pointer-shape 'gc-pointer-glyph) + +;;; (defvar x-toolbar-pointer-shape nil) +(define-obsolete-pointer-glyph 'x-toolbar-pointer-shape 'toolbar-pointer-glyph) + +;;;;;;;;;; initialization + +(defun init-glyphs () + ;; initialize default image types + (if (featurep 'x) + (set-console-type-image-conversion-list 'x + `(,@(if (featurep 'xpm) '(("\\.xpm\\'" [xpm :file nil] 2))) + ("\\.xbm\\'" [xbm :file nil] 2) + ,@(if (featurep 'xpm) '(("\\`/\\* XPM \\*/" [xpm :data nil] 2))) + ,@(if (featurep 'xface) '(("\\`X-Face:" [xface :data nil] 2))) + ,@(if (featurep 'gif) '(("\\.gif\\'" [gif :file nil] 2) + ("\\`GIF8[79]" [gif :data nil] 2))) + ,@(if (featurep 'jpeg) '(("\\.jpe?g\\'" [jpeg :file nil] 2))) + ;; all of the JFIF-format JPEG's that I've seen begin with + ;; the following. I have no idea if this is standard. + ,@(if (featurep 'jpeg) '(("\\`\377\330\377\340\000\020JFIF" + [jpeg :data nil] 2))) + ,@(if (featurep 'png) '(("\\.png\\'" [png :file nil] 2))) + ,@(if (featurep 'png) '(("\\`\211PNG" [png :data nil] 2))) + ("" [autodetect :data nil] 2)))) + ;; #### this should really be formatted-string, not string but we + ;; don't have it implemented yet + ;; + ;; #define could also mean a bitmap as well as a version 1 XPM. Who + ;; cares. We don't want the file contents getting converted to a + ;; string in either case which is why the entry is there. + (if (featurep 'tty) + (progn + (set-console-type-image-conversion-list + 'tty + '(("^#define" [string :data "[xpm]"]) + ("\\`X-Face:" [string :data "[xface]"]) + ("\\`/\\* XPM \\*/" [string :data "[xpm]"]) + ("\\`GIF87" [string :data "[gif]"]) + ("\\`\377\330\340\000\020JFIF" [string :data "[jpeg]"]) + ("" [string :data nil] 2) + ;; this last one is here for pointers and icons and such -- + ;; strings are not allowed so they will be ignored. + ("" [nothing]))) + + ;; finish initializing truncation glyph -- created internally + ;; because it has a built-in bitmap + (set-glyph-image truncation-glyph "$" 'global 'tty) + + ;; finish initializing continuation glyph -- created internally + ;; because it has a built-in bitmap + (set-glyph-image continuation-glyph "\\" 'global 'tty) + + ;; finish initializing hscroll glyph -- created internally + ;; because it has a built-in bitmap + (set-glyph-image hscroll-glyph "$" 'global 'tty))) + + (set-glyph-image octal-escape-glyph "\\") + (set-glyph-image control-arrow-glyph "^") + (set-glyph-image invisible-text-glyph " ...") + ;; (set-glyph-image hscroll-glyph "$") + + ;; finish initializing xemacs logo -- created internally because it + ;; has a built-in bitmap + (if (featurep 'xpm) + (set-glyph-image xemacs-logo + (concat "../etc/" + (if emacs-beta-version + "xemacs-beta.xpm" + "xemacs.xpm")) + 'global 'x)) + (cond ((featurep 'xpm) + (set-glyph-image frame-icon-glyph + (concat "../etc/" "xemacs-icon.xpm") + 'global 'x)) + ((featurep 'x) + (set-glyph-image frame-icon-glyph + (concat "../etc/" "xemacs-icon2.xbm") + 'global 'x))) + + (if (featurep 'tty) + (set-glyph-image xemacs-logo + "XEmacs <insert spiffy graphic logo here>" + 'global 'tty)) +) + +(init-glyphs) + +;;; glyphs.el ends here.
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gui.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,121 @@ +;;; gui.el --- Basic GUI functions for XEmacs. + +;; Copyright (C) 1997 Free Software Foundation, Inc. +;; Copyright (C) 1996 Ben Wing + +;; Maintainer: XEmacs Development Team +;; Keywords: internal, dumped + +;; 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, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: Not in FSF + +;;; Commentary: + +;; This file is dumped with XEmacs (when window system support is compiled in). + +;;; Code: + +(defcustom dialog-frame-plist '(width 60 height 20) + "Plist of frame properties for initially creating a dialog frame. +Properties specified here supersede the values given in +`default-frame-plist'." + :type '(repeat (group :inline t + (symbol :tag "Property") + (sexp :tag "Value"))) + :group 'frames) + +(defun make-dialog-frame (&optional props parent) + "Create a frame suitable for use as a dialog box. +The frame is made a child of PARENT (defaults to the selected frame), +and has additional properties PROPS, as well as `dialog-frame-plist'. +Normally it also has no modelines, menubars, or toolbars." + (or parent (setq parent (selected-frame))) + (let* ((ftop (frame-property parent 'top)) + (fleft (frame-property parent 'left)) + (fwidth (frame-pixel-width parent)) + (fheight (frame-pixel-height parent)) + (fonth (font-height (face-font 'default))) + (fontw (font-width (face-font 'default))) + (props (append props dialog-frame-plist)) + (dfheight (plist-get props 'height)) + (dfwidth (plist-get props 'width)) + ;; under FVWM at least, if I don't specify the initial position, + ;; it ends up always at (0, 0). xwininfo doesn't tell me + ;; that there are any program-specified position hints, so + ;; it must be an FVWM bug. So just be smashing and position + ;; in the center of the selected frame. + (frame (make-frame + (append props + `(popup ,parent initially-unmapped t + menubar-visible-p nil + has-modeline-p nil + default-toolbar-visible-p nil + modeline-shadow-thickness 0 + left ,(+ fleft (- (/ fwidth 2) + (/ (* dfwidth fontw) + 2))) + top ,(+ ftop (- (/ fheight 2) + (/ (* dfheight fonth) + 2)))))))) + (set-face-foreground 'modeline [default foreground] frame) + (set-face-background 'modeline [default background] frame) + (make-frame-visible frame) + frame)) + +(defvar gui-button-shadow-thickness 2) + +(defun gui-button-p (object) + "True if OBJECT is a GUI button." + (and (vectorp object) + (> (length object) 0) + (eq 'gui-button (aref object 0)))) + +(make-face 'gui-button-face "Face used for gui buttons") +(if (not (face-differs-from-default-p 'gui-button-face)) + (progn + (set-face-background 'gui-button-face "grey75") + (set-face-foreground 'gui-button-face "black"))) + +(defun make-gui-button (string &optional action user-data) + "Make a GUI button whose label is STRING and whose action is ACTION. +If the button is inserted in a buffer and then clicked on, and ACTION +is non-nil, ACTION will be called with one argument, USER-DATA." + (vector 'gui-button + (if (featurep 'xpm) + (xpm-button-create + string gui-button-shadow-thickness + (color-instance-name (face-foreground-instance 'gui-button-face)) + (color-instance-name (face-background-instance 'gui-button-face))) + (xbm-button-create string gui-button-shadow-thickness)) + action user-data)) + +(defun insert-gui-button (button &optional pos buffer) + "Insert GUI button BUTTON at POS in BUFFER." + (check-argument-type 'gui-button-p button) + (let ((annotation + (make-annotation (make-glyph (car (aref button 1))) + pos 'text buffer nil + (make-glyph (cadr (aref button 1))))) + (action (aref button 2))) + (and action + (progn + (set-annotation-action annotation action) + (set-annotation-data annotation (aref button 3)))))) + +;;; gui.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/help-nomule.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,105 @@ +;;; help-nomule.el --- Help functions when not in Mule + +;; Copyright (C) 1997 by Free Software Foundation, Inc. + +;; Maintainer: XEmacs Development Team +;; Keywords: help, internal, dumped + +;; 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: + +;; This file is dumped with XEmacs. + +;;; Code: + +(defconst tutorial-supported-languages + '(("French" fr iso-8859-1) + ("German" de iso-8859-1) + ("Norwegian" no iso-8859-1) + ("Croatian" hr iso-8859-2)) + "Alist of supported languages in TUTORIAL files. +Add languages here, as more are translated.") + +;; TUTORIAL arg is XEmacs addition +(defun help-with-tutorial (&optional tutorial language) + "Select the XEmacs learn-by-doing tutorial. +Optional arg TUTORIAL specifies the tutorial file; default is \"TUTORIAL\". +With a prefix argument, choose the language." + (interactive "i\nP") + (or tutorial + (setq tutorial "TUTORIAL")) + (when (and language (consp language)) + (let ((completion-ignore-case t)) + (setq language (assoc (completing-read "Language: " + tutorial-supported-languages + nil t) + tutorial-supported-languages)))) + (when language + (setq tutorial (format "%s.%s" tutorial (cadr language)))) + (let ((file (expand-file-name tutorial "~"))) + (delete-other-windows) + (let ((buffer (or (get-file-buffer file) + (create-file-buffer file))) + (window-configuration (current-window-configuration))) + (condition-case error-data + (progn + (switch-to-buffer buffer) + (setq buffer-file-name file) + (setq default-directory (expand-file-name "~/")) + (setq buffer-auto-save-file-name nil) + ;; Because of non-Mule users, TUTORIALs are not coded + ;; independently, so we must guess the coding according to + ;; the language. + (let ((coding-system-for-read (nth 2 language))) + (insert-file-contents (expand-file-name tutorial + data-directory))) + (goto-char (point-min)) + ;; The 'didactic' blank lines: possibly insert blank lines + ;; around <<nya nya nya>> and replace << >> with [ ]. + (if (re-search-forward "^<<.+>>") + (let ((n (- (window-height (selected-window)) + (count-lines (point-min) (point-at-bol)) + 6))) + (if (< n 12) + (progn (beginning-of-line) (kill-line)) + ;; Some people get confused by the large gap + (delete-backward-char 2) + (insert "]") + (beginning-of-line) + (save-excursion + (delete-char 2) + (insert "[")) + (newline (/ n 2)) + (next-line 1) + (newline (- n (/ n 2)))))) + (goto-char (point-min)) + (set-buffer-modified-p nil)) + ;; TUTORIAL was not found: kill the buffer and restore the + ;; window configuration. + (file-error (kill-buffer buffer) + (set-window-configuration window-configuration) + ;; Now, signal the error + (signal (car error-data) (cdr error-data))))))) + + +(provide 'help-nomule) + +;;; help-nomule.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/help.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,1316 @@ +;;; help.el --- help commands for XEmacs. + +;; Copyright (C) 1985, 1986, 1992-4, 1997 Free Software Foundation, Inc. + +;; Maintainer: FSF +;; Keywords: help, internal, dumped + +;; 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, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: FSF 19.30. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;; This code implements XEmacs's on-line help system, the one invoked by +;;`M-x help-for-help'. + +;; 06/11/1997 -- Converted to use char-after instead of broken +;; following-char. -slb + +;;; Code: + +;#### FSFmacs +;; Get the macro make-help-screen when this is compiled, +;; or run interpreted, but not when the compiled code is loaded. +;(eval-when-compile (require 'help-macro)) + +(defgroup help-appearance nil + "Appearance of help buffers" + :group 'help) + +(defvar help-map (let ((map (make-sparse-keymap))) + (set-keymap-name map 'help-map) + (set-keymap-prompt + map (purecopy (gettext "(Type ? for further options)"))) + map) + "Keymap for characters following the Help key.") + +;; global-map definitions moved to keydefs.el +(fset 'help-command help-map) + +(define-key help-map (vector help-char) 'help-for-help) +(define-key help-map "?" 'help-for-help) +(define-key help-map 'help 'help-for-help) + +(define-key help-map "\C-l" 'describe-copying) ; on \C-c in FSFmacs +(define-key help-map "\C-d" 'describe-distribution) +(define-key help-map "\C-w" 'describe-no-warranty) +(define-key help-map "a" 'hyper-apropos) ; 'command-apropos in FSFmacs +(define-key help-map "A" 'command-apropos) + +(define-key help-map "b" 'describe-bindings) +(define-key help-map "B" 'describe-beta) +(define-key help-map "\C-p" 'describe-pointer) + +(define-key help-map "C" 'customize) +(define-key help-map "c" 'describe-key-briefly) +(define-key help-map "k" 'describe-key) + +(define-key help-map "d" 'describe-function) +(define-key help-map "e" 'describe-last-error) +(define-key help-map "f" 'describe-function) + +(define-key help-map "F" 'xemacs-local-faq) + +;;; Setup so Hyperbole can be autoloaded from a key. +;;; Choose a key on which to place the Hyperbole menus. +;;; For most people this key binding will work and will be equivalent +;;; to {C-h h}. +;;; +(or (where-is-internal 'hyperbole) + (where-is-internal 'hui:menu) + (define-key help-map "h" 'hyperbole)) +(autoload 'hyperbole "hsite" "Hyperbole info manager menus." t) + +(define-key help-map "i" 'info) +(define-key help-map '(control i) 'Info-query) +;; FSFmacs has Info-goto-emacs-command-node on C-f, no binding +;; for Info-elisp-ref +(define-key help-map '(control c) 'Info-goto-emacs-command-node) +(define-key help-map '(control k) 'Info-goto-emacs-key-command-node) +(define-key help-map '(control f) 'Info-elisp-ref) + +(define-key help-map "l" 'view-lossage) + +(define-key help-map "m" 'describe-mode) + +(define-key help-map "\C-n" 'view-emacs-news) +(define-key help-map "n" 'view-emacs-news) + +(define-key help-map "p" 'finder-by-keyword) +(autoload 'finder-by-keyword "finder" + "Find packages matching a given keyword." t) + +(define-key help-map "s" 'describe-syntax) + +(define-key help-map "t" 'help-with-tutorial) + +(define-key help-map "w" 'where-is) + +(define-key help-map "v" 'describe-variable) + +(if (fboundp 'view-last-error) + (define-key help-map "e" 'view-last-error)) + + +(define-key help-map "q" 'help-quit) + +;#### This stuff was an attempt to have font locking and hyperlinks in the +;help buffer, but it doesn't really work. Some of this stuff comes from +;FSF Emacs; but the FSF Emacs implementation is rather broken, as usual. +;What needs to happen is this: +; +; -- we probably need a "hyperlink mode" from which help-mode is derived. +; -- this means we probably need multiple inheritance of modes! +; Thankfully this is not hard to implement; we already have the +; ability for a keymap to have multiple parents. However, we'd +; have to define any multiply-inherited-from modes using a standard +; `define-mode' construction instead of manually doing it, because +; we don't want each guy calling `kill-all-local-variables' and +; messing up the previous one. +; -- we need to scan the buffer ourselves (not from font-lock, because +; the user might not have font-lock enabled) and highlight only +; those words that are *documented* functions and variables (and +; probably excluding words without dashes in them unless enclosed +; in quotes, so that common words like "list" and "point" don't +; become hyperlinks. +; -- we should *not* use font-lock keywords like below. Instead we +; should add the font-lock stuff ourselves during the scanning phase, +; if font-lock is enabled in this buffer. + +;(defun help-follow-reference (event extent user-data) +; (let ((symbol (intern-soft (extent-string extent)))) +; (cond ((and symbol (fboundp symbol)) +; (describe-function symbol)) +; ((and symbol (boundp symbol)) +; (describe-variable symbol)) +; (t nil)))) + +;(defvar help-font-lock-keywords +; (let ((name-char "[-+a-zA-Z0-9_*]") (sym-char "[-+a-zA-Z0-9_:*]")) +; (list +; ;; +; ;; The symbol itself. +; (list (concat "\\`\\(" name-char "+\\)\\(:\\)?") +; '(1 (if (match-beginning 2) +; 'font-lock-function-name-face +; 'font-lock-variable-name-face) +; nil t)) +; ;; +; ;; Words inside `' which tend to be symbol names. +; (list (concat "`\\(" sym-char sym-char "+\\)'") +; 1 '(prog1 +; 'font-lock-reference-face +; (add-list-mode-item (match-beginning 1) +; (match-end 1) +; nil +; 'help-follow-reference)) +; t) +; ;; +; ;; CLisp `:' keywords as references. +; (list (concat "\\<:" sym-char "+\\>") 0 'font-lock-reference-face t))) +; "Default expressions to highlight in Help mode.") + +;(put 'help-mode 'font-lock-defaults '(help-font-lock-keywords)) + +(define-derived-mode help-mode view-major-mode "Help" + "Major mode for viewing help text. +Entry to this mode runs the normal hook `help-mode-hook'. +Commands: +\\{help-mode-map}" + ) + +(define-key help-mode-map "q" 'help-mode-quit) +(define-key help-mode-map "f" 'find-function-at-point) + +(defun describe-function-at-point () + "Describe directly the function at point in the other window." + (interactive) + (let ((symb (function-at-point))) + (when symb + (describe-function symb)))) +(defun describe-variable-at-point () + "Describe directly the variable at point in the other window." + (interactive) + (let ((symb (variable-at-point))) + (when symb + (describe-variable symb)))) +(defun help-next-symbol () + "Move point to the next quoted symbol." + (interactive) + (search-forward "`" nil t)) +(defun help-prev-symbol () + "Move point to the previous quoted symbol." + (interactive) + (search-backward "'" nil t)) +(define-key help-mode-map "d" 'describe-function-at-point) +(define-key help-mode-map "v" 'describe-variable-at-point) +(define-key help-mode-map [tab] 'help-next-symbol) +(define-key help-mode-map [(shift tab)] 'help-prev-symbol) + + +(defun help-mode-quit () + "Exits from help mode, possibly restoring the previous window configuration. +Bury the help buffer to the end of the buffer list." + (interactive) + (let ((buf (current-buffer))) + (cond ((frame-property (selected-frame) 'help-window-config) + (set-window-configuration + (frame-property (selected-frame) 'help-window-config)) + (set-frame-property (selected-frame) 'help-window-config nil)) + ((not (one-window-p)) + (delete-window))) + (bury-buffer buf))) + +(defun help-quit () + (interactive) + nil) + +;; This is a grody hack of the same genotype as `advertised-undo'; if the +;; bindings of Backspace and C-h are the same, we want the menubar to claim +;; that `info' in invoked with `C-h i', not `BS i'. + +(defun deprecated-help-command () + (interactive) + (if (eq 'help-command (key-binding "\C-h")) + (setq unread-command-event (character-to-event ?\C-h)) + (help-for-help))) + +;;(define-key global-map 'backspace 'deprecated-help-command) + +;; This function has been moved to help-nomule.el and mule-help.el. +;; TUTORIAL arg is XEmacs addition +;(defun help-with-tutorial (&optional tutorial) +; "Select the XEmacs learn-by-doing tutorial. +;Optional arg TUTORIAL specifies the tutorial file; default is \"TUTORIAL\"." +; (interactive) +; (if (null tutorial) +; (setq tutorial "TUTORIAL")) +; (let ((file (expand-file-name (concat "~/" tutorial)))) +; (delete-other-windows) +; (if (get-file-buffer file) +; (switch-to-buffer (get-file-buffer file)) +; (switch-to-buffer (create-file-buffer file)) +; (setq buffer-file-name file) +; (setq default-directory (expand-file-name "~/")) +; (setq buffer-auto-save-file-name nil) +; (insert-file-contents (expand-file-name tutorial data-directory)) +; (goto-char (point-min)) +; (search-forward "\n<<") +; (delete-region (point-at-bol) (point-at-eol)) +; (let ((n (- (window-height (selected-window)) +; (count-lines (point-min) (point)) +; 6))) +; (if (< n 12) +; (newline n) +; ;; Some people get confused by the large gap. +; (newline (/ n 2)) +; (insert "[Middle of page left blank for didactic purposes. " +; "Text continues below]") +; (newline (- n (/ n 2))))) +; (goto-char (point-min)) +; (set-buffer-modified-p nil)))) + +;; used by describe-key, describe-key-briefly, insert-key-binding, etc. + +(defun key-or-menu-binding (key &optional menu-flag) + "Return the command invoked by KEY. +Like `key-binding', but handles menu events and toolbar presses correctly. +KEY is any value returned by `next-command-event'. +MENU-FLAG is a symbol that should be set to T if KEY is a menu event, + or NIL otherwise" + (let (defn) + (and menu-flag (set menu-flag nil)) + ;; If the key typed was really a menu selection, grab the form out + ;; of the event object and intuit the function that would be called, + ;; and describe that instead. + (if (and (vectorp key) (= 1 (length key)) + (or (misc-user-event-p (aref key 0)) + (eq (car-safe (aref key 0)) 'menu-selection))) + (let ((event (aref key 0))) + (setq defn (if (eventp event) + (list (event-function event) (event-object event)) + (cdr event))) + (and menu-flag (set menu-flag t)) + (when (eq (car defn) 'eval) + (setq defn (car (cdr defn)))) + (when (eq (car-safe defn) 'call-interactively) + (setq defn (car (cdr defn)))) + (when (and (consp defn) (null (cdr defn))) + (setq defn (car defn)))) + ;; else + (setq defn (key-binding key))) + ;; kludge: if a toolbar button was pressed on, try to find the + ;; binding of the toolbar button. + (if (and (eq defn 'press-toolbar-button) + (vectorp key) + (button-press-event-p (aref key (1- (length key))))) + ;; wait for the button release. We're on shaky ground here ... + (let ((event (next-command-event)) + button) + (if (and (button-release-event-p event) + (event-over-toolbar-p event) + (eq 'release-and-activate-toolbar-button + (key-binding (vector event))) + (setq button (event-toolbar-button event))) + (toolbar-button-callback button) + ;; if anything went wrong, try returning the binding of + ;; the button-up event, of the original binding + (or (key-or-menu-binding (vector event)) + defn))) + ;; no toolbar kludge + defn) + )) + +(defun describe-key-briefly (key) + "Print the name of the function KEY invokes. KEY is a string." + (interactive "kDescribe key briefly: ") + (let (defn menup) + (setq defn (key-or-menu-binding key 'menup)) + (if (or (null defn) (integerp defn)) + (message "%s is undefined" (key-description key)) + ;; If it's a keyboard macro which trivially invokes another command, + ;; document that instead. + (if (or (stringp defn) (vectorp defn)) + (setq defn (or (key-binding defn) + defn))) + (let ((last-event (and (vectorp key) + (aref key (1- (length key)))))) + (message (if (or (button-press-event-p last-event) + (button-release-event-p last-event)) + (gettext "%s at that spot runs the command %s") + (gettext "%s runs the command %s")) + ;; This used to say 'This menu item' but it could also + ;; be a scrollbar event. We can't distinguish at the + ;; moment. + (if menup "This item" (key-description key)) + (if (symbolp defn) defn (prin1-to-string defn))))))) + +;; #### this is a horrible piece of shit function that should +;; not exist. In FSF 19.30 this function has gotten three times +;; as long and has tons and tons of dumb shit checking +;; special-display-buffer-names and such crap. I absolutely +;; refuse to insert that Ebolification here. I wanted to delete +;; this function entirely but Mly bitched. +;; +;; If your user-land code calls this function, rewrite it to +;; call with-displaying-help-buffer. + +(defun print-help-return-message (&optional function) + "Display or return message saying how to restore windows after help command. +Computes a message and applies the optional argument FUNCTION to it. +If FUNCTION is nil, applies `message' to it, thus printing it." + (and (not (get-buffer-window standard-output)) + (funcall + (or function 'message) + (concat + (substitute-command-keys + (if (one-window-p t) + (if pop-up-windows + (gettext "Type \\[delete-other-windows] to remove help window.") + (gettext "Type \\[switch-to-buffer] RET to remove help window.")) + (gettext "Type \\[switch-to-buffer-other-window] RET to restore the other window."))) + (substitute-command-keys + (gettext " \\[scroll-other-window] to scroll the help.")))))) + +(defcustom help-selects-help-window t + "*If nil, use the \"old Emacs\" behavior for Help buffers. +This just displays the buffer in another window, rather than selecting +the window." + :type 'boolean + :group 'help-appearance) + +;; Use this function for displaying help when C-h something is pressed +;; or in similar situations. Do *not* use it when you are displaying +;; a help message and then prompting for input in the minibuffer -- +;; this macro usually selects the help buffer, which is not what you +;; want in those situations. + +;;; ### Should really be a macro (as suggested above) to eliminate the +;;; requirement of caller to code a lambda form in THUNK -- mrb +(defun with-displaying-help-buffer (thunk) + (let ((winconfig (current-window-configuration)) + (was-one-window (one-window-p)) + (help-not-visible + (not (and (windows-of-buffer "*Help*") ;shortcut + (member (selected-frame) + (mapcar 'window-frame + (windows-of-buffer "*Help*"))))))) + (prog1 (with-output-to-temp-buffer "*Help*" + (prog1 (funcall thunk) + (save-excursion + (set-buffer standard-output) + (help-mode)))) + (let ((helpwin (get-buffer-window "*Help*"))) + (when helpwin + (with-current-buffer (window-buffer helpwin) + ;; If the *Help* buffer is already displayed on this + ;; frame, don't override the previous configuration + (when help-not-visible + (set-frame-property (selected-frame) + 'help-window-config winconfig))) + (when help-selects-help-window + (select-window helpwin)) + (cond ((eq helpwin (selected-window)) + (display-message 'command + (substitute-command-keys "Type \\[help-mode-quit] to remove help window, \\[scroll-up] to scroll the help."))) + (was-one-window + (display-message 'command + (substitute-command-keys "Type \\[delete-other-windows] to remove help window, \\[scroll-other-window] to scroll the help."))) + (t + (display-message 'command + (substitute-command-keys "Type \\[switch-to-buffer-other-window] to restore the other window, \\[scroll-other-window] to scroll the help."))))))))) + +(defun describe-key (key) + "Display documentation of the function invoked by KEY. +KEY is a string, or vector of events. +When called interactively, KEY may also be a menu selection." + (interactive "kDescribe key: ") + (let ((defn (key-or-menu-binding key))) + (if (or (null defn) (integerp defn)) + (message "%s is undefined" (key-description key)) + (with-displaying-help-buffer + (lambda () + (princ (key-description key)) + (princ " runs ") + (if (symbolp defn) (princ (format "`%S'" defn)) + (prin1 defn)) + (princ "\n\n") + (cond ((or (stringp defn) (vectorp defn)) + (let ((cmd (key-binding defn))) + (if (not cmd) + (princ "a keyboard macro") + (progn + (princ "a keyboard macro which runs the command ") + (prin1 cmd) + (princ ":\n\n") + (if (documentation cmd) (princ (documentation cmd))))))) + ((and (consp defn) (not (eq 'lambda (car-safe defn)))) + (let ((describe-function-show-arglist nil)) + (describe-function-1 (car defn) standard-output))) + ((symbolp defn) + (describe-function-1 defn standard-output)) + ((documentation defn) + (princ (documentation defn))) + (t + (princ "not documented")))))))) + +(defun describe-mode () + "Display documentation of current major mode and minor modes. +For this to work correctly for a minor mode, the mode's indicator variable +\(listed in `minor-mode-alist') must also be a function whose documentation +describes the minor mode." + (interactive) + (with-displaying-help-buffer + (lambda () + ;; XEmacs change: print the major-mode documentation before + ;; the minor modes. + (princ mode-name) + (princ " mode:\n") + (princ (documentation major-mode)) + (princ "\n\n----\n\n") + (let ((minor-modes minor-mode-alist)) + (while minor-modes + (let* ((minor-mode (car (car minor-modes))) + (indicator (car (cdr (car minor-modes))))) + ;; Document a minor mode if it is listed in minor-mode-alist, + ;; bound locally in this buffer, non-nil, and has a function + ;; definition. + (if (and (boundp minor-mode) + (symbol-value minor-mode) + (fboundp minor-mode)) + (let ((pretty-minor-mode minor-mode)) + (if (string-match "-mode\\'" (symbol-name minor-mode)) + (setq pretty-minor-mode + (capitalize + (substring (symbol-name minor-mode) + 0 (match-beginning 0))))) + (while (and (consp indicator) (extentp (car indicator))) + (setq indicator (cdr indicator))) + (while (and indicator (symbolp indicator)) + (setq indicator (symbol-value indicator))) + (princ (format "%s minor mode (indicator%s):\n" + pretty-minor-mode indicator)) + (princ (documentation minor-mode)) + (princ "\n\n----\n\n")))) + (setq minor-modes (cdr minor-modes))))))) + +;; So keyboard macro definitions are documented correctly +(fset 'defining-kbd-macro (symbol-function 'start-kbd-macro)) + +(defun describe-distribution () + "Display info on how to obtain the latest version of XEmacs." + (interactive) + (find-file-read-only + (expand-file-name "DISTRIB" data-directory))) + +(defun describe-beta () + "Display info on how to deal with Beta versions of XEmacs." + (interactive) + (find-file-read-only + (expand-file-name "BETA" data-directory)) + (goto-char (point-min))) + +(defun describe-copying () + "Display info on how you may redistribute copies of XEmacs." + (interactive) + (find-file-read-only + (expand-file-name "COPYING" data-directory)) + (goto-char (point-min))) + +(defun describe-pointer () + "Show a list of all defined mouse buttons, and their definitions." + (interactive) + (describe-bindings nil t)) + +(defun describe-project () + "Display info on the GNU project." + (interactive) + (find-file-read-only + (expand-file-name "GNU" data-directory)) + (goto-char (point-min))) + +(defun describe-no-warranty () + "Display info on all the kinds of warranty XEmacs does NOT have." + (interactive) + (describe-copying) + (let (case-fold-search) + (search-forward "NO WARRANTY") + (recenter 0))) + +(defun describe-bindings (&optional prefix mouse-only-p) + "Show a list of all defined keys, and their definitions. +The list is put in a buffer, which is displayed. +If the optional argument PREFIX is supplied, only commands which +start with that sequence of keys are described. +If the second argument (prefix arg, interactively) is non-null +then only the mouse bindings are displayed." + (interactive (list nil current-prefix-arg)) + (with-displaying-help-buffer + (lambda () + (describe-bindings-1 prefix mouse-only-p)))) + +(defun describe-bindings-1 (&optional prefix mouse-only-p) + (let ((heading (if mouse-only-p + (gettext "button binding\n------ -------\n") + (gettext "key binding\n--- -------\n"))) + (buffer (current-buffer)) + (minor minor-mode-map-alist) + (local (current-local-map)) + (shadow '())) + (set-buffer standard-output) + (while minor + (let ((sym (car (car minor))) + (map (cdr (car minor)))) + (if (symbol-value-in-buffer sym buffer nil) + (progn + (insert (format "Minor Mode Bindings for `%s':\n" + sym) + heading) + (describe-bindings-internal map nil shadow prefix mouse-only-p) + (insert "\n") + (setq shadow (cons map shadow)))) + (setq minor (cdr minor)))) + (if local + (progn + (insert "Local Bindings:\n" heading) + (describe-bindings-internal local nil shadow prefix mouse-only-p) + (insert "\n") + (setq shadow (cons local shadow)))) + (insert "Global Bindings:\n" heading) + (describe-bindings-internal (current-global-map) + nil shadow prefix mouse-only-p) + (when (and prefix function-key-map (not mouse-only-p)) + (insert "\nFunction key map translations:\n" heading) + (describe-bindings-internal function-key-map nil nil prefix mouse-only-p)) + (set-buffer buffer))) + +(defun describe-prefix-bindings () + "Describe the bindings of the prefix used to reach this command. +The prefix described consists of all but the last event +of the key sequence that ran this command." + (interactive) + (let* ((key (this-command-keys)) + (prefix (make-vector (1- (length key)) nil)) + i) + (setq i 0) + (while (< i (length prefix)) + (aset prefix i (aref key i)) + (setq i (1+ i))) + (with-displaying-help-buffer + (lambda () + (princ "Key bindings starting with ") + (princ (key-description prefix)) + (princ ":\n\n") + (describe-bindings-1 prefix nil))))) + +;; Make C-h after a prefix, when not specifically bound, +;; run describe-prefix-bindings. +(setq prefix-help-command 'describe-prefix-bindings) + +(defun view-emacs-news () + "Display info on recent changes to XEmacs." + (interactive) + #-infodock (require 'outl-mouse) + (find-file (expand-file-name "NEWS" data-directory))) + +(defun xemacs-www-page () + "Go to the XEmacs World Wide Web page." + (interactive) + (funcall browse-url-browser-function "http://www.xemacs.org/")) + +(defun xemacs-www-faq () + "View the latest and greatest XEmacs FAQ using the World Wide Web." + (interactive) + (funcall browse-url-browser-function "http://www.xemacs.org/faq/index.html")) + +(defun xemacs-local-faq () + "View the local copy of the XEmacs FAQ. +If you have access to the World Wide Web, you should use `xemacs-www-faq' +instead, to ensure that you get the most up-to-date information." + (interactive) + (save-window-excursion + (info) + (Info-find-node "xemacs-faq" "Top")) + (switch-to-buffer "*info*")) + +(defcustom view-lossage-key-count 100 + "*Number of keys `view-lossage' shows. +The maximum number of available keys is governed by `recent-keys-ring-size'." + :type 'integer + :group 'help) + +(defcustom view-lossage-message-count 100 + "*Number of minibuffer messages `view-lossage' shows." + :type 'integer + :group 'help) + +(defun view-lossage () + "Display recent input keystrokes and recent minibuffer messages. +The number of keys shown is controlled by `view-lossage-key-count'. +The number of messages shown is controlled by `view-lossage-message-count'." + (interactive) + (with-displaying-help-buffer + (lambda () + (princ (key-description (recent-keys view-lossage-key-count))) + (save-excursion + (set-buffer standard-output) + (goto-char (point-min)) + (insert "Recent keystrokes:\n\n") + (while (progn (move-to-column 50) (not (eobp))) + (search-forward " " nil t) + (insert "\n"))) + ;; XEmacs addition + (princ "\n\n\nRecent minibuffer messages (most recent first):\n\n") + (save-excursion + (let ((buffer (get-buffer " *Message-Log*")) + (count 0) + oldpoint) + (set-buffer buffer) + (goto-char (point-max)) + (set-buffer standard-output) + (while (and (> (point buffer) (point-min buffer)) + (< count view-lossage-message-count)) + (setq oldpoint (point buffer)) + (forward-line -1 buffer) + (insert-buffer-substring buffer (point buffer) oldpoint) + (setq count (1+ count)))))))) + +(define-function 'help 'help-for-help) +;; #### FSF calls `make-help-screen' here. We need to port `help-macro.el'. +(defun help-for-help () + "You have typed \\[help-for-help], the help character. Type a Help option: +\(Use SPC or DEL to scroll through this text. Type \\<help-map>\\[help-quit] to exit the Help command.) + +\\[hyper-apropos] Type a substring; it shows a hypertext list of + functions and variables that contain that substring. + See also the `apropos' command. +\\[command-apropos] Type a substring; it shows a list of commands + (interactively callable functions) that contain that substring. +\\[describe-bindings] Table of all key bindings. +\\[describe-key-briefly] Type a command key sequence; + it displays the function name that sequence runs. +\\[Info-goto-emacs-command-node] Type a function name; it displays the Info node for that command. +\\[describe-function] Type a function name; it shows its documentation. +\\[Info-elisp-ref] Type a function name; it jumps to the full documentation + in the XEmacs Lisp Programmer's Manual. +\\[xemacs-local-faq] Local copy of the XEmacs FAQ. +\\[info] Info documentation reader. +\\[Info-query] Type an Info file name; it displays it in Info reader. +\\[describe-key] Type a command key sequence; + it displays the documentation for the command bound to that key. +\\[Info-goto-emacs-key-command-node] Type a command key sequence; + it displays the Info node for the command bound to that key. +\\[view-lossage] Recent input keystrokes and minibuffer messages. +\\[describe-mode] Documentation of current major and minor modes. +\\[view-emacs-news] News of recent XEmacs changes. +\\[finder-by-keyword] Type a topic keyword; it finds matching packages. +\\[describe-pointer] Table of all mouse-button bindings. +\\[describe-syntax] Contents of syntax table with explanations. +\\[help-with-tutorial] XEmacs learn-by-doing tutorial. +\\[describe-variable] Type a variable name; it displays its documentation and value. +\\[where-is] Type a command name; it displays which keystrokes invoke that command. +\\[describe-distribution] XEmacs ordering information. +\\[describe-no-warranty] Information on absence of warranty for XEmacs. +\\[describe-copying] XEmacs copying permission (General Public License)." + (interactive) + (let ((help-key (copy-event last-command-event)) + event char) + (message (gettext "A B C F I K L M N P S T V W C-c C-d C-n C-w. Type %s again for more help: ") + ;; arrgh, no room for "C-i C-k C-f" !! + (single-key-description help-key)) + (setq event (next-command-event) + char (event-to-character event)) + (if (or (equal event help-key) + (eq char ??) + (eq 'help-command (key-binding event))) + (save-window-excursion + (switch-to-buffer "*Help*") + ;; #### I18N3 should mark buffer as output-translating + (delete-other-windows) + (let ((buffer-read-only nil)) + (erase-buffer) + (insert (documentation 'help-for-help))) + (goto-char (point-min)) + (while (or (equal event help-key) + (eq char ??) + (eq 'help-command (key-binding event)) + (eq char ?\ ) + (eq 'scroll-up (key-binding event)) + (eq char ?\177) + (and (not (eq char ?b)) + (eq 'scroll-down (key-binding event)))) + (if (or (eq char ?\ ) + (eq 'scroll-up (key-binding event))) + (scroll-up)) + (if (or (eq char ?\177) + (and (not (eq char ?b)) + (eq 'scroll-down (key-binding event)))) + (scroll-down)) + ;; write this way for I18N3 snarfing + (if (pos-visible-in-window-p (point-max)) + (message "A B C F I K L M N P S T V W C-c C-d C-n C-w C-i C-k C-f: ") + (message "A B C F I K L M N P S T V W C-c C-d C-n C-w C-i C-k C-f or Space to scroll: ")) + (let ((cursor-in-echo-area t)) + (setq event (next-command-event event) + char (or (event-to-character event) event)))))) + (let ((defn (or (lookup-key help-map (vector event)) + (and (numberp char) + (lookup-key help-map (make-string 1 (downcase char))))))) + (message nil) + (if defn + (call-interactively defn) + (ding))))) + +(defun function-called-at-point () + "Return the function which is called by the list containing point. +If that gives no function, return the function whose name is around point. +If that doesn't give a function, return nil." + (or (condition-case () + (save-excursion + (save-restriction + (narrow-to-region (max (point-min) (- (point) 1000)) (point-max)) + (backward-up-list 1) + (forward-char 1) + (let (obj) + (setq obj (read (current-buffer))) + (and (symbolp obj) (fboundp obj) obj)))) + (error nil)) + (condition-case () + (let ((stab (syntax-table))) + (unwind-protect + (save-excursion + (set-syntax-table emacs-lisp-mode-syntax-table) + (or (not (zerop (skip-syntax-backward "_w"))) + (eq (char-syntax (char-after (point))) ?w) + (eq (char-syntax (char-after (point))) ?_) + (forward-sexp -1)) + (skip-chars-forward "`'") + (let ((obj (read (current-buffer)))) + (and (symbolp obj) (fboundp obj) obj))) + (set-syntax-table stab))) + (error nil)))) + +(defun function-at-point () + "Return the function whose name is around point. +If that gives no function, return the function which is called by the +list containing point. If that doesn't give a function, return nil." + (or (condition-case () + (let ((stab (syntax-table))) + (unwind-protect + (save-excursion + (set-syntax-table emacs-lisp-mode-syntax-table) + (or (not (zerop (skip-syntax-backward "_w"))) + (eq (char-syntax (char-after (point))) ?w) + (eq (char-syntax (char-after (point))) ?_) + (forward-sexp -1)) + (skip-chars-forward "`'") + (let ((obj (read (current-buffer)))) + (and (symbolp obj) (fboundp obj) obj))) + (set-syntax-table stab))) + (error nil)) + (condition-case () + (save-excursion + (save-restriction + (narrow-to-region (max (point-min) (- (point) 1000)) + (point-max)) + (backward-up-list 1) + (forward-char 1) + (let (obj) + (setq obj (read (current-buffer))) + (and (symbolp obj) (fboundp obj) obj)))) + (error nil)))) + +;; Default to nil for the non-hackers? Not until we find a way to +;; distinguish hackers from non-hackers automatically! +(defcustom describe-function-show-arglist t + "*If non-nil, describe-function will show its arglist, +unless the function is autoloaded." + :type 'boolean + :group 'help-appearance) + +(defun describe-function-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-function (function) + "Display the full documentation of FUNCTION (a symbol). +When run interactively, it defaults to any function found by +`function-at-point'." + (interactive + (let* ((fn (function-at-point)) + (val (let ((enable-recursive-minibuffers t)) + (completing-read + (if fn + (format (gettext "Describe function (default %s): ") + fn) + (gettext "Describe function: ")) + obarray 'fboundp t nil 'function-history)))) + (list (if (equal val "") fn (intern val))))) + (with-displaying-help-buffer + (lambda () + (describe-function-1 function standard-output) + ;; Return the text we displayed. + (buffer-string nil nil standard-output)))) + +(defun function-obsolete-p (function) + "Return non-nil if FUNCTION is obsolete." + (not (null (get function 'byte-obsolete-info)))) + +(defun function-obsoleteness-doc (function) + "If FUNCTION is obsolete, return a string describing this." + (let ((obsolete (get function 'byte-obsolete-info))) + (if obsolete + (format "Obsolete; %s" + (if (stringp (car obsolete)) + (car obsolete) + (format "use `%s' instead." (car obsolete))))))) + +(defun function-compatible-p (function) + "Return non-nil if FUNCTION is present for Emacs compatibility." + (not (null (get function 'byte-compatible-info)))) + +(defun function-compatibility-doc (function) + "If FUNCTION is Emacs compatible, return a string describing this." + (let ((compatible (get function 'byte-compatible-info))) + (if compatible + (format "Emacs Compatible; %s" + (if (stringp (car compatible)) + (car compatible) + (format "use `%s' instead." (car compatible))))))) + +;Here are all the possibilities below spelled out, for the benefit +;of the I18N3 snarfer. +; +;(gettext "a built-in function") +;(gettext "an interactive built-in function") +;(gettext "a built-in macro") +;(gettext "an interactive built-in macro") +;(gettext "a compiled Lisp function") +;(gettext "an interactive compiled Lisp function") +;(gettext "a compiled Lisp macro") +;(gettext "an interactive compiled Lisp macro") +;(gettext "a Lisp function") +;(gettext "an interactive Lisp function") +;(gettext "a Lisp macro") +;(gettext "an interactive Lisp macro") +;(gettext "a mocklisp function") +;(gettext "an interactive mocklisp function") +;(gettext "a mocklisp macro") +;(gettext "an interactive mocklisp macro") +;(gettext "an autoloaded Lisp function") +;(gettext "an interactive autoloaded Lisp function") +;(gettext "an autoloaded Lisp macro") +;(gettext "an interactive autoloaded Lisp macro") + +(defun describe-function-1 (function stream &optional nodoc) + (princ (format "`%S' is " function) stream) + (let* ((def function) + (doc (condition-case nil + (or (documentation function) + (gettext "not documented")) + (void-function ""))) + aliases file-name autoload-file kbd-macro-p fndef macrop) + (while (and (symbolp def) (fboundp def)) + (when (not (eq def function)) + (setq aliases + (if aliases + ;; I18N3 Need gettext due to concat + (concat aliases + (format + "\n which is an alias for `%s', " + (symbol-name def))) + (format "an alias for `%s', " (symbol-name def))))) + (setq def (symbol-function def))) + (if (compiled-function-p def) + (setq file-name (compiled-function-annotation def))) + (if (eq 'macro (car-safe def)) + (setq fndef (cdr def) + file-name (and (compiled-function-p (cdr def)) + (compiled-function-annotation (cdr def))) + macrop t) + (setq fndef def)) + (if aliases (princ aliases stream)) + (let ((int #'(lambda (string an-p macro-p) + (princ (format + (gettext (concat + (cond ((commandp def) + "an interactive ") + (an-p "an ") + (t "a ")) + "%s" + (if macro-p " macro" " function"))) + string) + stream)))) + (cond ((or (stringp def) (vectorp def)) + (princ "a keyboard macro." stream) + (setq kbd-macro-p t)) + ((subrp fndef) + (funcall int "built-in" nil macrop)) + ((compiled-function-p fndef) + (funcall int "compiled Lisp" nil macrop)) +; XEmacs -- we handle aliases above. +; ((symbolp fndef) +; (princ (format "alias for `%s'" +; (prin1-to-string def)) stream)) + ((eq (car-safe fndef) 'lambda) + (funcall int "Lisp" nil macrop)) + ((eq (car-safe fndef) 'mocklisp) + (funcall int "mocklisp" nil macrop)) + ((eq (car-safe def) 'autoload) + (setq autoload-file (elt def 1)) + (funcall int "autoloaded Lisp" t (elt def 4))) + ((and (symbolp def) (not (fboundp def))) + (princ "a symbol with a void (unbound) function definition." stream)) + (t + nil))) + (princ "\n") + (if autoload-file + (princ (format " -- autoloads from \"%s\"\n" autoload-file) stream)) + (or file-name + (setq file-name (describe-function-find-file function))) + (if file-name + (princ (format " -- loaded from \"%s\"\n" file-name)) stream) +;; (terpri stream) + (if describe-function-show-arglist + (let ((arglist + (cond ((compiled-function-p fndef) + (compiled-function-arglist fndef)) + ((eq (car-safe fndef) 'lambda) + (nth 1 fndef)) + ((and (subrp fndef) + (string-match + "[\n\t ]*\narguments: ?(\\(.*\\))\n?\\'" + doc)) + (prog1 + (substring doc (match-beginning 1) (match-end 1)) + (setq doc (substring doc 0 (match-beginning 0))))) + (t t)))) + (if (listp arglist) + (progn +;; (princ " ") + (princ (cons function + (mapcar (lambda (arg) + (if (memq arg '(&optional &rest)) + arg + (intern (upcase (symbol-name arg))))) + arglist)) stream) + (terpri stream))) + (if (stringp arglist) + (princ (format "(%s %s)\n" function arglist) stream)))) + (terpri stream) + (cond (kbd-macro-p + (princ "These characters are executed:\n\n\t" stream) + (princ (key-description def) stream) + (cond ((setq def (key-binding def)) + (princ (format "\n\nwhich executes the command %S.\n\n" def) stream) + (describe-function-1 def stream)))) + (nodoc nil) + (t + ;; tell the user about obsoleteness. + ;; If the function is obsolete and is aliased, don't + ;; even bother to report the documentation, as a further + ;; encouragement to use the new function. + (let ((obsolete (function-obsoleteness-doc function)) + (compatible (function-compatibility-doc function))) + (when obsolete + (princ obsolete stream) + (terpri stream) + (terpri stream)) + (when compatible + (princ compatible stream) + (terpri stream) + (terpri stream)) + (unless (and obsolete aliases) + (princ doc stream) + (unless (or (equal doc "") + (eq ?\n (aref doc (1- (length doc))))) + (terpri stream)))))))) + + +;;; ## this doesn't seem to be used for anything +;; (defun describe-function-arglist (function) +;; (interactive (list (or (function-at-point) +;; (error "no function call at point")))) +;; (let ((b nil)) +;; (unwind-protect +;; (save-excursion +;; (set-buffer (setq b (get-buffer-create " *arglist*"))) +;; (buffer-disable-undo b) +;; (erase-buffer) +;; (describe-function-1 function b t) +;; (goto-char (point-min)) +;; (end-of-line) +;; (or (eobp) (delete-char 1)) +;; (just-one-space) +;; (end-of-line) +;; (message (buffer-substring (point-min) (point)))) +;; (and b (kill-buffer b))))) + + +(defun variable-at-point () + (ignore-errors + (let ((stab (syntax-table))) + (unwind-protect + (save-excursion + (set-syntax-table emacs-lisp-mode-syntax-table) + (or (not (zerop (skip-syntax-backward "_w"))) + (eq (char-syntax (char-after (point))) ?w) + (eq (char-syntax (char-after (point))) ?_) + (forward-sexp -1)) + (skip-chars-forward "'") + (let ((obj (read (current-buffer)))) + (and (symbolp obj) (boundp obj) obj))) + (set-syntax-table stab))))) + +(defun variable-obsolete-p (variable) + "Return non-nil if VARIABLE is obsolete." + (not (null (get variable 'byte-obsolete-variable)))) + +(defun variable-obsoleteness-doc (variable) + "If VARIABLE is obsolete, return a string describing this." + (let ((obsolete (get variable 'byte-obsolete-variable))) + (if obsolete + (format "Obsolete; %s" + (if (stringp obsolete) + obsolete + (format "use `%s' instead." obsolete)))))) + +(defun variable-compatible-p (variable) + "Return non-nil if VARIABLE is Emacs compatible." + (not (null (get variable 'byte-compatible-variable)))) + +(defun variable-compatibility-doc (variable) + "If VARIABLE is Emacs compatible, return a string describing this." + (let ((compatible (get variable 'byte-compatible-variable))) + (if compatible + (format "Emacs Compatible; %s" + (if (stringp compatible) + compatible + (format "use `%s' instead." compatible)))))) + +(defun built-in-variable-doc (variable) + "Return a string describing whether VARIABLE is built-in." + (let ((type (built-in-variable-type variable))) + (case type + (integer "a built-in integer variable") + (const-integer "a built-in constant integer variable") + (boolean "a built-in boolean variable") + (const-boolean "a built-in constant boolean variable") + (object "a simple built-in variable") + (const-object "a simple built-in constant variable") + (const-specifier "a built-in constant specifier variable") + (current-buffer "a built-in buffer-local variable") + (const-current-buffer "a built-in constant buffer-local variable") + (default-buffer "a built-in default buffer-local variable") + (selected-console "a built-in console-local variable") + (const-selected-console "a built-in constant console-local variable") + (default-console "a built-in default console-local variable") + (t + (if type "an unknown type of built-in variable?" + "a variable declared in Lisp"))))) + +(defun describe-variable (variable) + "Display the full documentation of VARIABLE (a symbol)." + (interactive + (let* ((v (variable-at-point)) + (val (let ((enable-recursive-minibuffers t)) + (completing-read + (if v + (format "Describe variable (default %s): " v) + (gettext "Describe variable: ")) + obarray 'boundp t nil 'variable-history)))) + (list (if (equal val "") v (intern val))))) + (with-displaying-help-buffer + (lambda () + (let ((origvar variable) + aliases) + (let ((print-escape-newlines t)) + (princ (format "`%s' is " (symbol-name variable))) + (while (variable-alias variable) + (let ((newvar (variable-alias variable))) + (if aliases + ;; I18N3 Need gettext due to concat + (setq aliases + (concat aliases + (format "\n which is an alias for `%s'," + (symbol-name newvar)))) + (setq aliases + (format "an alias for `%s'," + (symbol-name newvar)))) + (setq variable newvar))) + (if aliases + (princ (format "%s" aliases))) + (princ (built-in-variable-doc variable)) + (princ ".\n\n") + (princ "Value: ") + (if (not (boundp variable)) + (princ "void") + (prin1 (symbol-value variable))) + (terpri) + (cond ((local-variable-p variable (current-buffer)) + (let* ((void (cons nil nil)) + (def (condition-case nil + (default-value variable) + (error void)))) + (princ "This value is specific to the current buffer.") + (terpri) + (if (local-variable-p variable nil) + (progn + (princ "(Its value is local to each buffer.)") + (terpri))) + (if (if (eq def void) + (boundp variable) + (not (eq (symbol-value variable) def))) + ;; #### I18N3 doesn't localize properly! + (progn (princ "Its default-value is ") + (if (eq def void) + (princ "void.") + (prin1 def)) + (terpri))))) + ((local-variable-p variable (current-buffer) t) + (princ "Setting it would make its value buffer-local.\n")))) + (terpri) + (princ "Documentation:") + (terpri) + (let ((doc (documentation-property variable 'variable-documentation)) + (obsolete (variable-obsoleteness-doc origvar)) + (compatible (variable-compatibility-doc origvar))) + (when obsolete + (princ obsolete) + (terpri) + (terpri)) + (when compatible + (princ compatible) + (terpri) + (terpri)) + ;; don't bother to print anything if variable is obsolete and aliased. + (when (or (not obsolete) (not aliases)) + (if doc + ;; note: documentation-property calls substitute-command-keys. + (princ doc) + (princ "not documented as a variable.")) + (terpri))) + ;; Return the text we displayed. + (buffer-string nil nil standard-output))))) + +(defun sorted-key-descriptions (keys &optional separator) + "Sort and separate the key descriptions for KEYS. +The sorting is done by length (shortest bindings first), and the bindings +are separated with SEPARATOR (\", \" by default)." + (mapconcat 'key-description + (sort keys #'(lambda (x y) + (< (length x) (length y)))) + (or separator ", "))) + +(defun where-is (definition) + "Print message listing key sequences that invoke specified command. +Argument is a command definition, usually a symbol with a function definition. +When run interactively, it defaults to any function found by +`function-at-point'." + (interactive + (let ((fn (function-at-point)) + (enable-recursive-minibuffers t) + val) + (setq val (read-command + (if fn (format "Where is command (default %s): " fn) + "Where is command: "))) + (list (if (equal (symbol-name val) "") + fn val)))) + (let ((keys (where-is-internal definition))) + (if keys + (message "%s is on %s" definition (sorted-key-descriptions keys)) + (message "%s is not on any keys" definition))) + nil) + +;; `locate-library' moved to "packages.el" + + +;; Functions ported from C into Lisp in XEmacs + +(defun describe-syntax () + "Describe the syntax specifications in the syntax table. +The descriptions are inserted in a buffer, which is then displayed." + (interactive) + (with-displaying-help-buffer + (lambda () + ;; defined in syntax.el + (describe-syntax-table (syntax-table) standard-output)))) + +(defun list-processes () + "Display a list of all processes. +\(Any processes listed as Exited or Signaled are actually eliminated +after the listing is made.)" + (interactive) + (with-output-to-temp-buffer "*Process List*" + (set-buffer standard-output) + (buffer-disable-undo standard-output) + (make-local-variable 'truncate-lines) + (setq truncate-lines t) + (let ((stream standard-output)) + ;; 00000000001111111111222222222233333333334444444444 + ;; 01234567890123456789012345678901234567890123456789 + ;; rewritten for I18N3. This one should stay rewritten + ;; so that the dashes will line up properly. + (princ "Proc Status Buffer Tty Command\n---- ------ ------ --- -------\n" stream) + (let ((tail (process-list))) + (while tail + (let* ((p (car tail)) + (pid (process-id p)) + (s (process-status p))) + (setq tail (cdr tail)) + (princ (format "%-13s" (process-name p)) stream) + ;(if (and (eq system-type 'vax-vms) + ; (eq s 'signal) + ; (< (process-exit-status p) NSIG)) + ; (princ (aref sys_errlist (process-exit-status p)) stream)) + (princ s stream) + (if (and (eq s 'exit) (/= (process-exit-status p) 0)) + (princ (format " %d" (process-exit-status p)) stream)) + (if (memq s '(signal exit closed)) + ;; Do delete-exited-processes' work + (delete-process p)) + (indent-to 22 1) ;#### + (let ((b (process-buffer p))) + (cond ((not b) + (princ "(none)" stream)) + ((not (buffer-name b)) + (princ "(killed)" stream)) + (t + (princ (buffer-name b) stream)))) + (indent-to 37 1) ;#### + (let ((tn (process-tty-name p))) + (cond ((not tn) + (princ "(none)" stream)) + (t + (princ (format "%s" tn) stream)))) + (indent-to 49 1) ;#### + (if (not (integerp pid)) + (progn + (princ "network stream connection " stream) + (princ (car pid) stream) + (princ "@" stream) + (princ (cdr pid) stream)) + (let ((cmd (process-command p))) + (while cmd + (princ (car cmd) stream) + (setq cmd (cdr cmd)) + (if cmd (princ " " stream))))) + (terpri stream))))))) + +;; `find-function' et al moved to "find-func.el" + +;;; help.el ends here
--- a/lisp/hyperbole/ChangeLog Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,694 +0,0 @@ -1997-09-17 SL Baur <steve@altair.xemacs.org> - - * Makefile (autoloads): Fixup dependency. - -1997-07-08 Steven L Baur <steve@altair.xemacs.org> - - * hact.el (action:commandp): Don't reference bytecode objects as - vectors. - (action:params): Ditto. - -1997-07-07 Steven L Baur <steve@altair.xemacs.org> - - * hypb.el (hypb:function-copy): Don't reference bytecode objects - as vectors. - (hypb:function-symbol-replace): Document as broken. The - substition cannot be done without some thinking I'm not in the - mood for. - -1997-07-03 Steven L Baur <steve@altair.xemacs.org> - - * Makefile: Add autoloads dependencies. - -1997-06-27 Steven L Baur <steve@altair.xemacs.org> - - * wrolo-menu.el (TopLevel): Fix tests so that W3's id-menubar - simulation doesn't bollux up feature tests. - -Thu Mar 13 22:01:52 1997 Bob Weiner <weiner@infodock.com> - -* wrolo.el (rolo-toggle-datestamps): Added. -* hui-mini.el (hui:menus): Added Cust/Toggle-Rolodex-Dates entry. -* hui-menu.el (hui-menu-options): Added Customization/Toggle-Rolodex-Dates - item. -* wrolo.el (rolo-add): Added wrolo-add-hook, executed after the record - is added. - (rolo-edit): Added wrolo-edit-hook, executed after point is - successfully moved to the record to edit. These can be used, for - example, to add and update date entries in address records. - (rolo-current-date): Added. - (rolo-set-date): Added and used as default wrolo-add-hook and - wrolo-edit-hook settings. - -Mon Mar 10 12:17:15 1997 Bob Weiner <weiner@infodock.com> - -* hsys-w3.el (www-url): Eliminated call of external Web browser if not - running under a window system. - -Sun Mar 9 01:32:03 1997 Bob Weiner <weiner@infodock.com> - -* hpath.el (hpath:url-at-p): - (hpath:www-at-p): Fixed bug that referred to an optional match - component without checking if it was matched. - (hpath:url-p): Changed doc to reflect that pathname can be optional. - -* hsite-ex.el: Added (require 'hyperbole) to ensure that this file - is loaded if hsite.el is autoloaded, e.g. under XEmacs. - -Thu Mar 6 14:14:05 1997 Bob Weiner <weiner@infodock.com> - -* hui-mini.el (hyperbole): Added autoload special comment. - -Wed Mar 5 01:14:47 1997 Bob Weiner <weiner@infodock.com> - -* kotl/kotl-mode.el (kotl-mode:center-line): -* kotl/kview.el (kcell-view:line): Changed calls to - kotl-mode:beginning-of-line to kotl-mode:start-of-line to avoid an - XEmacs byte compiler bug in some versions. The bug shows up when - kotl-mode:center-line is called on the first line of a cell and the - cell label is centered along with the line (the label should not - move). - -Tue Mar 4 20:45:52 1997 Bob Weiner <weiner@infodock.com> - -* hsite-ex.el (hpath:find-alist): Modified to use `xv' to display xpm - files; it is more robust than `sxpm' in the face of limited colors. - -Mon Mar 3 12:06:49 1997 Bob Weiner <weiner@infodock.com> - -* hui-menu.el (infodock-hyperbole-menu): Added :config 'Hyperbole - configurator to the menu so users can hide the Hyperbole - menu from the menubar if they don't use it, via menubar-configuration, - under XEmacs and InfoDock. - -Sun Mar 2 22:35:26 1997 Bob Weiner <weiner@infodock.com> - -* kotl/kotl-mode.el (kotl-mode:set-cell-attribute): Changed - read-expression to read-minibuffer since GNU Emacs doesn't - have the former. - -Fri Feb 28 23:31:57 1997 Bob Weiner <weiner@infodock.com> - -* kotl/kprop-xe.el (kproperty:put): Fixed problem with internal handling - of text property protocols within newer versions of XEmacs. The - `text-prop' symbol can no longer be set to `t'. It must be set to - a symbol from the property list of the extent that carries - text-properties. - -============================================================================== -V4.023 changes ^^^^: -============================================================================== - -Sat Feb 22 14:30:14 1997 Bob Weiner <weiner@infodock.com> - -* hypb.el (hypb:ida-logo-keymap): Added conditional for Emacs keybinding. - -============================================================================== -V4.022 changes ^^^^: -============================================================================== - -Fri Feb 21 17:49:01 1997 Bob Weiner <weiner@infodock.com> - -* hmouse-reg.el (hmouse-get-bindings): - (hmouse-setup): -* hmouse-sh.el (hmouse-get-bindings): - (hmouse-setup): -* hmouse-key.el (hmouse-set-bindings): -Modified to do nothing when running in batch mode (noninteractively). - - -============================================================================== -V4.021 changes ^^^^: -============================================================================== - -Tue Feb 18 18:57:27 1997 Bob Weiner <weiner@infodock.com> - -* hui-mini.el (hui:menus): Added "Doc/About" menu item -* hui-menu.el (infodock-hyperbole-menu): Added "About" menu item. -* hypb.el (hypb:ida-logo-keymap): - (hypb:ida-home-page): - (hypb:display-file-with-logo): Added to support About Hyperbole command. - -Mon Feb 17 15:27:21 1997 Bob Weiner <weiner@infodock.com> - -* hversion.el (hyperb:microcruft-os-p): Added. - -Sat Feb 15 16:03:42 1997 Bob Weiner <weiner@infodock.com> - -* hpath.el (hpath:find): Fixed bug that returned nil (now is 't) if file - was displayed using a specialized function. - (hpath:find-line): Added to handle displaying of all files at - specific lines (hpath:find does not work for this use since it - may call external display functions). -* hactypes.el (link-to-file-line): Rewrote to call hpath:find-line. - -Fri Feb 14 11:39:09 1997 Bob Weiner <weiner@infodock.com> - -* hrmail.el (rmail-forward): Updated to V19 compatibility. - -Sun Jan 26 14:32:28 1997 Bob Weiner <weiner@infodock.com> - -* hmouse-sh.el (hmouse-get-bindings): -* hmouse-reg.el (hmouse-get-bindings): Rearranged order of initial - conditional so that lemacs or emacs19 always takes precedence over - hyperb:window-system setting, which may be "xterm". - -* hmouse-key.el (or hyperb:xemacs-p hyperb:emacs19-p): Prevent any attempt - to load pre-dumped mouse libraries when running under X terms on these - versions of emacs. - -* hyperbole.el (hbut:key-src): Added this autoload to avert error if the - rolodex is loaded before the Hyperbole system and then a rolo-edit, {e}, - request is made within the match buffer. - -* hgnus.el: Updated to support new Gnus gnus-msg.el replacement for gnuspost.el. - -* hversion.el (sm-window-sys-term): -* hbmap.el (hbmap:dir-user): Patched to support GNU Emacs running - natively under Windows NT. - -Tue Jan 14 15:45:14 1997 Bob Weiner <weiner@infodock.com> - -* ../../etc/hypb-mouse.txt (Special Modes): Added Objective-C, Java and - Fortran support documentation. - -Mon Jan 6 18:59:13 1997 Bob Weiner <weiner@infodock.com> - -* kotl/klink.el (klink:at-p): Eliminated matches to URLs for now. - -Wed Dec 25 22:01:05 1996 Bob Weiner <weiner@infodock.com> - -* hmouse-tag.el: Changed all opening quotes in comments from ' to `. - -Tue Dec 10 16:40:09 1996 Bob Weiner <weiner@infodock.com> - -* wrolo.el (wrolo-mode-syntax-table): Added to support syntactic selection - of delimited e-mail addresses. - -Fri Dec 6 12:34:31 1996 Bob Weiner <weiner@infodock.com> - -* hmail.el (hmail:region): Fixed bug that extracted region from the wrong - buffer. - -Thu Dec 5 15:34:55 1996 Bob Weiner <weiner@infodock.com> - -* hibtypes.el (annot-bib): Eliminated conflict with PPG-sw-process-id - ibtype. - -* hpath.el (hpath:is-p): Fixed error triggered when tried to format a path - with more than one %s. - -Wed Dec 4 13:39:09 1996 Bob Weiner <weiner@infodock.com> - -* kotl/kmenu.el (id-menubar-kotl): Fixed so this mode menu is properly - installed under InfoDock. - -Tue Nov 26 21:21:50 1996 Bob Weiner <weiner@infodock.com> - -* hui-menu.el (infodock-hyperbole-menu): Added Customization option that - sets the program used to display URLs. - -Thu Nov 14 18:11:36 1996 Bob Weiner <weiner@infodock.com> - -* hmouse-tag.el (smart-*-at-tag-p): Modified to flash tag as a hyperbutton - when pressed, if Hyperbole has been loaded and flashing is supported - on the current device. - -* hbut.el (ibut:label-set): Made this return its LABEL argument. Useful - when label has not yet been saved in a variable. - -* kotl/klink.el (klink:at-p): Ignore HTML and SGML tags when looking for Klinks. - -Sun Nov 10 01:47:01 1996 Bob Weiner <weiner@infodock.com> - -* wrolo.el (rolo-sort-level): Made case-insensitive. - (rolo-add): Fixed bug caused by a call to widen that sometimes - failed to leave point at the newly added entry if the rolodex - buffer was already displayed when the rolo-add call was made. - -* hmouse-tag.el (smart-lisp): Display message and beep when tag is not found. - -* hibtypes.el (function-in-buffer): -* hactypes.el (function-in-buffer): Added to follow function references - that are defined in the same buffer as the reference. - (annot-bib): - (exec-shell-cmd): - (man-show): - (rfc-toc): Updated all of these to use hpath:display-where - output display setting. - (link-to-elisp-doc): Also modified to move point to the - documentation buffer. - -* hui.el (hui:hbut-current-act): Added. - -Fri Nov 8 21:37:34 1996 Bob Weiner <weiner@infodock.com> - -* hbut.el (ebut:act): Added for use when activating an explicit button - from a menu. - (ebut:list): Fixed bug that returned (nil) when no explicit - buttons were found. -* hui-menu.el (hui-menu-explicit-buttons): Added to display a list of - explicit buttons for activation via the Explicit-Button menu. -* hui-menu.el (hyperbole-gbut-menu): Added to display a list of existing - global buttons for activation via the Global-Button menu. - -Tue Nov 5 19:26:17 1996 Bob Weiner <weiner@infodock.com> - -* hibtypes.el (pathname): Modified to display Emacs Lisp libraries when - given as delimited filenames, without any path. - -Fri Nov 1 00:26:13 1996 Bob Weiner <weiner@infodock.com> - -* hui-mouse.el (hkey-alist): Moved OO-Browser handler to near bottom so - that it does not override mode-specific handlers. - -Thu Oct 31 20:01:34 1996 Bob Weiner <weiner@infodock.com> - -* hui-mouse.el (hkey-alist): Added Action and Assist key support for Java - identifiers. -* hyperbole.el: Added Java autoloads. -* hmouse-tag.el (smart-java-package-dirs): Added this variable as the - setting of where Java package source code can be found when the - OO-Browser is not in use. Defaults to a single item list of - "${JAVA_HOME}/src/" if JAVA_HOME is set. - (smart-java-*): Added point and click identifier jumping for Java. - (smart-tags-file): Added optional argument NAME-OF-TAGS-FILE - so can search for OO-Browser lookup tables. - (smart-java-cross-reference): Added to follow @see cross-references. - -Sat Oct 26 01:05:29 1996 Bob Weiner <weiner@infodock.com> - -* hui-menu.el (infodock-hyperbole-menu): Added Customization submenu. -* hui-mini.el (hui:menus): Added Cust/ submenu. - -* hbut.el (hbut:source): Fixed bug that neglected to account for double - quotes around the name within the printed representation of - a buffer object. - -Fri Oct 25 13:52:51 1996 Bob Weiner <weiner@infodock.com> - -* hmouse-tag.el: Updated function to use with new buffer display protocol. -* hactypes.el: Updated many definitions here to use hpath:find and - hpath:display-buffer. -* hui-mouse.el (smart-dired): Changed call of hpath:find-other-window to - hpath:find to use new user-definable display location protocol. -* hpath.el (hpath:find): Expanded optional values of 2nd arg and made - default location of an internally displayed file be given by the - value of the hpath:display-where variable. -* hpath.el (hpath:display-buffer): - (hpath:display-buffer-other-frame): Added for linked to buffers. - (hpath:find-other-frame): Added for use in hpath:display-where-alist. -* hsite-ex.el (hpath:display-where): - (hpath:display-where-alist): - (hpath:display-buffer-alist): - Added these new variables to control where Hyperbole displays link referents. - The first one documents the possibilities and the second two specify - the function to call for each possibility. - -Tue Oct 22 01:21:53 1996 Bob Weiner <weiner@infodock.com> - -* kotl/kvspec.el (kvspec:update-modeline): Fixed to accomodate specialized - extents in the modeline introduced by XEmacs 19.14. - -* hui-mouse.el (hkey-alist): Added support for new id-edit-mode which - can be setup to activate whenever a region is highlighted with the - mouse. When id-edit-mode is active the Action Key (or the Assist Key) - will paste the region that was highlighted at point. The key {y} also - happens to do the same thing in this mode, but has the additional - property that it will cycle through previous entries in the kill-ring. - -Fri Sep 20 22:19:33 1996 Bob Weiner <weiner@infodock.com> - -* Changed `cs.uiuc.edu' to `xemacs.org', the new Hyperbole distribution site. - -============================================================================== -V4.02 changes ^^^^: -============================================================================== - -Fri Nov 3 22:40:34 1995 Bob Weiner <weiner@infodock.com> - -* hsys-w3.el: Renamed entries in this file and added - action-key-url-function definition in "hyperbole.el", which can be - used to change the display function used when a URL is activated with - the Action Key. Also, loaded this library by default instead of - requiring that it be set up in "hsite.el". - -Fri Nov 3 19:25:24 1995 Bob Weiner <weiner@infodock.com> - -* kotl/kotl-mode.el (kotl-mode): Fixed so re-narrows a formatted koutline - to just its cells when invoked. - -Fri Nov 3 19:29:58 1995 Bob Weiner <weiner@infodock.com> - -* kotl/kvspec.el (kvspec:blank-lines): Modified to allow toggling blank - lines in a read-only outline and to not change the modification status - of the buffer when kvspec:toggle-blank-lines is used. - -Fri Nov 3 01:28:44 1995 Bob Weiner <weiner@infodock.com> - -* man/hypb-mouse.txt: Updated to reflect new smart-scroll-proportional - default setting. - -* hsite-ex.el (hpath:display-alist): Fixed bug that tried to kill *info* - buffer when it didn't exist. Also fixed bug in call to Info-find-node - which gave too many args under Emacs 19. - -============================================================================== -V4.01 changes ^^^^: -============================================================================== - -Thu Nov 2 00:52:26 1995 Bob Weiner <weiner@infodock.com> - -* kotl/kotl-mode.el (kotl-mode:cell-help): Fixed this, the {C-c h} command - to properly deal with a cell-ref = 0. In this case, always display - the 0 cell's attributes before any other attribute data. - -* kotl/kview.el (kcell-view:previous): Fixed bug that moved to a hidden - cell when visible-p flag was given. - -Wed Nov 1 02:05:36 1995 Bob Weiner <weiner@infodock.com> - -* kotl/klink.el (klink:parse): Changed to require a common following any - pathname in a link to prevent parsing, <3g |en>, as a pathname followed - by a viewspec. - -* kotl/kview.el (kcell-view:child): - (kcell-view:child-p) - (kcell-view:sibling-p): Added optional visible-p parameter to - find only visible matches. - -* kotl/kotl-mode.el: Fixed improper modification of global - minor-mode-alist and mode-line-format values. - -Tue Oct 31 00:45:44 1995 Bob Weiner <weiner@infodock.com> - -* wrolo.el (rolo-mail-to): Added to compose mail to current or next e-mail - address when in a rolodex or mail buffer. Bound to {m} in rolodex - match buffer and added as Rolo/Mail menu item. - -* hsite-ex.el (smart-scroll-proportional): Changed default to t, so can do - proportional scrolling by default. Scrollbars are often available - when non-proportional scrolling is desired. - -* kotl/kotl-mode.el (kotl-mode:to-valid-position): Optimized a bit further. - -Mon Oct 30 01:37:31 1995 Bob Weiner <weiner@infodock.com> - -* kotl/kotl-mode.el (kotl-mode:copy-to-buffer): Made the default buffer to - copy to the buffer in the other window of this frame, if any. Also - fixed bug that caused more than one tree to be copied if there was no - successor for the tree but there was a following higher level cell. - -* hsys-www.el: Removed this library that encapsulated the old CERN - command-line WWW browser. No one would want to use that today. Use - hsys-w3.el instead. - -* hypb.el (hypb:insert-region): Added to deal with region copying used by - hmail:region and kotl-mode:copy-to-buffer. - -* kotl/kview.el (kcell-view:child-p): Added. - -* wrolo.el (rolo-isearch): Added to search for next occurrence of current - match regexp and then allow user to add characters to narrow the - search, bound to {M-s}. -* man/hyperbole.texi (Rolo Keys): Documented {M-s} binding. - -* kotl/kview.el (kcell-view:contents): Added optional POS argument. - -* kotl/kimport.el (kimport:file): Added to import different file types - based upon buffer name suffixes. Default is to import as text. - -* kotl/kimport.el: Rewrote all of these functions to handle importation - at an arbitrary level in an existing koutline. - -Sun Oct 29 01:26:25 1995 Bob Weiner <weiner@infodock.com> - -* kotl/kotl-mode.el (kotl-mode:demote-tree): - (kotl-mode:promote-tree): Fixed bug that could leave - point in a non-editable portion of a koutline. - -* hibtypes.el (grep-msg): Added support for IBM AIX xlc C compiler errors. - Also made this higher priority that `pathname' implicit button type so - that if activate within a doubly quoted pathname followed by a line - number, the line number is used. - -* kotl/kotl-mode.el (kotl-mode:fill-paragraph): Fixed bugs that kept it - from filling paragraphs where point was not on the first paragraph - line but the first line did not need filling. - -* hui-mini.el (Win/PopRing): - (Win/YankRing): Changed so they redisplay the Win menu. - This lets you repeatedly yank or pop window configurations until you reach - the one you want. - -* kotl/kview.el (kcell-view:create): Fixed so if no-fill is in the kcell's - attribute list, rather than passed in as the `no-fill' argument, its - value is still used. - -* kotl/kotl-mode.el (kotl-mode:add-cell): Added extra argument so can pass - in a list of attributes for the cell, as a property list. - (kotl-mode:split-cell): Fixed so original cell - attributes are propagated to the newly created cell. - -* kotl/kfile.el (kfile:create): Modified to handle importation of a - foreign text buffer when kotl-mode calls this function within a - foreign format buffer. - -Sat Oct 28 02:32:12 1995 Bob Weiner <weiner@infodock.com> - -* kotl/klink.el (klink:create): - (link-to-kotl): - (klink:parse): - (klink:cell-ref-regexp): -* kotl/kvspec.el (kvspec:string-format): -* hactypes.el (link-to-kcell): -* kotl/kotl.el (kcell:ref-to-id): -* kotl/kotl-mode.el (kotl-mode:goto-cell): Changed viewspec preface - character from : to |. Augment viewspec characters preceded by a - colon are ignored, for now. - -Fri Oct 27 15:16:11 1995 Bob Weiner <weiner@infodock.com> - -* kotl/kview.el (kview:set-label-separator): Rewrote so properly changes - the separator in the current view. Made it interactive and removed - input argument, kview. Use local buffer value of kview instead. - Added key binding for it, {C-c M-l}. -* kotl/kprop-em.el: - kotl/kprop-xe.el (kproperty:replace-separator): Added, called by above - function. - -* kotl/kprop-xe.el (kproperty:properties): Changed definition since - text-properties-at did not return the list of kproperties. - -Thu Oct 26 00:06:49 1995 Bob Weiner <weiner@infodock.com> - -* hui-mini.el (hui:menus): Simplified a number of documentation display - entries. - -* kotl/kotl.el (kcell:read-only-attributes): Added, lists cell attributes - that may not be modified by a user. - -* kotl/kotl-mode.el (kotl-mode:insert-file-contents): Renamed from - kotl-mode:insert-file. Now use that name to import a file as a - sequence of sibling cells, rather than one monolithic cell, bound to - {C-x i}, overloading the standard insert-file. - (kotl-mode:get-cell-attribute): Added. - (kotl-mode:set-cell-attribute): Added, bound to {C-c C-i}. - (kotl-mode:cell-help): Renamed from :kcell-help. - (kotl-mode:print-attributes): Renamed from :print-properties. - -* kotl/klabel.el (klabel:level): Added to compute the level of a given label. - (klabel:level-alpha): Renamed from kimport:aug-label-level. - (klabel:level-legal): Added. - -* kotl/kimport.el (kimport:kcells): Added to insert kcell contents from - one koutline to another. - (kimport:text): Generalized greatly so can import into - an existing or non-existing koutline and can take buffer, buffer-name or - file arguments. - (kimport:aug-post-outline): - (kimport:star-outline): Fixed and speeded up. Code had - somehow broken over time. - (kimport:text): - (kimport:text-cells): Added to import text paragraph as - cells all at the same level. - -Wed Oct 25 02:24:35 1995 Bob Weiner <weiner@infodock.com> - -* kotl/kfile.el (kfile:update): Added kotl-mode setting to the first line - of koutline files so they are read in with the right mode even if they - do not have a file suffix of .kotl. - (kfile:read-name): Relaxed to allow files without .kotl suffix. - -* kotl/kotl-mode.el (kfile:write): Fixed bug that failed to restore local - hook settings after renaming buffer. This would cause invalid - koutlines to be written after a rename. -* (kotl-mode): Fixed bug that treated a koutline that - has been read in and formatted for editing as an unformatted koutline. - -* hibtypes.el (text-toc): - hactypes.el (text-toc): Added to use README table of contents as - implicit buttons. - -* hbut.el (ibut:label-set): Expanded doc string. - -* README: Rewrote installation instructions. -* man/hyperbole.texi: Reorganized manual for clarity. Added obtaining - Hyperbole, installing it and filled out the whole Hyperbole Outliner - chapter. - -Tue Oct 24 03:52:40 1995 Bob Weiner <weiner@infodock.com> - -* man/hyperbole.texi (Configuration): Renamed from Initializing. - -Mon Oct 23 01:00:54 1995 Bob Weiner <weiner@infodock.com> - -* kotl/kotl-mode.el (kotl-mode:top-cells): Simplified and fixed to utilize - blank lines setting. - -* kotl/kmenu.el (id-popup-kotl-menu): - (id-menubar-kotl): Added View Menu and moved view-related - tree operations from Tree menu to here. Also added Find and - Find-Read-Only menu entries so can edit/view other koutlines. - Added Append-Cell and Set-Cell-Attributes menu items. -* hui-mini.el (hui:menus): Renamed Otl/Below to Otl/Downto so could add - Otl/Blanks to toggle blanks on and off. Changed name and function of - Otl/View to Otl/Vspec. Now prompts for and activates a view spec. - User can use {C-x C-r} to view a koutline instead. - -* README: Updated What's New section to V4.00. - -* man/hyperbole.texi (Hyperbole Views): Rewrote and expanded to explain - new view specs. - -* man/hyperbole.texi (Hook Variables): - wrolo.el (rolo-yank): - (wrolo-yank-reformat-function): Added this variable to - allow user to reformat yanked entries. - -* kotl/kvspec.el (kvspec:toggle-blank-lines): Added, bound to {C-c b}. - -* kotl/kfile.el (kfile:read-v4): Added for V4 format which initializes - view spec local variables read from the file. - (kfile:update): Save current viewspec to file. - (kfile:version): Updated file format to V4.0. - -* kotl/kotl.el (kcell:ref-to-id): - kotl/kotl-mode.el (kotl-mode:goto-cell): Fixed to ignore relative specs - and to utilize view specs. - -* kotl/EXAMPLE.kotl: Updated to explain view spec handling. - -Sun Oct 22 00:38:45 1995 Bob Weiner <weiner@infodock.com> - -* hbut.el (ebut:key-src): Fixed bug that prevented match to - hbut:source-prefix line when in a collapsed outline line. - rolo-edit-entry would not work when rolodex match entries were - collapsed. - -* kotl/kotl-mode.el (kotl-mode:append-cell): Added to append the contents - of one cell to another, bound to {C-c +}. - -* kotl/kvspec.el: Added this file to control Koutliner view specification. - (kvspec:activate): Added to interactively set view specs - and bound to {C-c C-v}. - (kvspec:no-blank-lines): Renamed from kotl-mode:shorten-all. - (kvspec:blank-lines): Renamed from kotl-mode:extend-all. - -* kotl/kmenu.el (kotl-menubar-menu): - hui-menu.el (hyperbole-menubar-menu): - wrolo-menu.el (wrolo-menubar-menu): Fixed bug when current-menubar was - nil, would not display menubar entry under Emacs 19 even though it should. - -Sat Oct 21 01:07:32 1995 Bob Weiner <weiner@infodock.com> - -* kotl/kview.el (kview:default-blank-lines): - (kview:default-levels-to-show): - (kview:default-lines-to-show): Added these variables. - (kview:create): Use their values. - (kcell-view:create): Use kview's blank-lines setting. - -* kotl/kprop-xe.el (kproperty:remove): Fixed bug that ignored open-ended - properties. - kotl/kprop-em.el (kproperty:remove): Rewrote to remove only those - properties with matching values. - -* kotl/kotl-mode.el (kotl-mode:extend-all): - (kotl-mode:shorten-all): Rewrote to use invisible - properties. -* kotl/kfile.el (kfile:shorten-after-saving): - (kfile:extend-before-save): Removed. No longer needed - since blank lines are removed using invisible characters. - -* kotl/kprop-em.el (kproperty:put): -* kotl/kprop-xe.el (kproperty:put): Changed calling interface to take a - list of properties. - -* kotl/kfill.el (kfill:prefix-table): Generalized supercite citation prefix. - -Tue Oct 17 01:21:37 1995 Bob Weiner <weiner@infodock.com> - -* hinit.el (hyperb:check-dir-user): Call make-directory function if - available. - -Mon Oct 16 01:02:19 1995 Bob Weiner <weiner@infodock.com> - -* wrolo.el (rolo-file-list): Set to c:/_rolodex.otl under MS-DOS and Windows. -* hbmap.el (hbmap:dir-user): Set to c:/_hyperb/ under MS-DOS and Windows. -* hbut.el (hattr:filename): Set to _hypb under MS-DOS and Windows. - -Sun Oct 15 17:32:46 1995 Bob Weiner <weiner@infodock.com> - -* kotl/kotl-mode.el (kotl-mode:copy-region-as-kill): Don't trigger error - when called in a read-only buffer. - -Fri Oct 6 12:56:57 1995 Bob Weiner <weiner@infodock.com> - -* hui-mouse.el (hkey-alist): Moved Smart Menu display code closer to - highest priority so that hkey-always-display-menu works as advertised. - -* hui-window.el (hmouse-modeline-depress): Fixed so does not false under - Emacs 19 when depress in a minibuffer window. This fixes the problem - of the Action Key not properly selecting Hyperbole minibuffer menu items. - -Thu Oct 5 14:31:56 1995 Bob Weiner <weiner@infodock.com> - -* hui-menu.el (hyperbole-menubar-menu): Added omitted (require 'lmenu) for - Emacs 19 that prevented Hyperbole menubar from appearing under Emacs 19. - -Wed Oct 4 12:41:24 1995 Bob Weiner <weiner@infodock.com> - -* hsite-ex.el (hkey-always-display-menu): Added this definition to prevent - it from being unbound if smart-menu is invoked and the Smart Menu system - is loaded under InfoDock. - -Wed Sep 27 01:56:53 1995 Bob Weiner <weiner@infodock.com> - -* wrolo.el (rolo-edit): Modified to treat an empty string argument for - NAME as a null argument, so one can just hit RET interactively. Also, - modified to automatically select rolodex file when called - interactively if rolo-file-list has only one element. - -* wrolo.el (wrolo-mode-map): Added {e} binding to edit the entry at point - within the rolodex match buffer. -* man/hyperbole.texi (Rolo Keys): Documented {e} key. - -Mon Sep 25 11:15:49 1995 Bob Weiner <weiner@infodock.com> - -* kotl/kotl-mode.el (kotl-mode:indent-line): - (kotl-mode:indent-region): Added. Each signals an - error to force user to hit SPC to indent lines. - (kotl-mode): Set indent-line-function and - indent-region-function. - -* hyperbole.el (hmail:msg-narrow): Added autoload. - -Fri Sep 22 17:14:05 1995 Bob Weiner <weiner@infodock.com> - -* hsite-ex.el (hpath:display-alist): Fixed bug in handling info-suffix - variable scoping that prevented Action Key from browsing info files in - dired. - -============================================================================== -V4.00 changes ^^^^: -==============================================================================
--- a/lisp/hyperbole/ChangeLog.1 Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,4077 +0,0 @@ -Thu Sep 21 11:44:51 1995 Bob Weiner <weiner@infodock.com> - -* wrolo.el (rolo-name-and-email): Fixed bug that could cause current - buffer to scroll. - -Wed Sep 20 11:46:09 1995 Bob Weiner <weiner@infodock.com> - -* hypb.el (hypb:supercite-p): Fixed bug that returned nil when should have - returned t. - (hypb:configuration): Added so this could be used in OO-Browser. -* hactypes.el (hyp-config): Simplified to just call hypb:configuration. - -============================================================================== -V3.19.09 changes ^^^^: -============================================================================== - -Fri Sep 15 12:59:40 1995 Bob Weiner <weiner@infodock.com> - -* wrolo.el (rolo-name-and-email): Modified to work if point is in a mail - or news summary listing buffer. - -* hui-window.el (assist-key-modeline): Simplified unburying of buffer. - -Thu Sep 14 14:03:17 1995 Bob Weiner <weiner@infodock.com> - -* hmail.el (hmail:buffer): Modified to use logic in hmail:region. - (hmail:region): - kotl/kotl-mode.el (kotl-mode:mail-tree): - (kotl-mode:copy-to-buffer): Modified to prompt for - whether to erase hidden text when copying or to copy and expand it. - -* hmouse-key.el (hmouse-set-bindings): - hmouse-sh.el - hmouse-reg.el (hmouse-setup): - (hmouse-get-bindings): Execute these even if on a tty when - under Emacs 19, XEmacs or InfoDock. - -* hmouse-key.el (hmouse-shift-buttons): Added this function to allow - switching the location of the Action and Assist Keys between shifted - and unshifted mouse buttons. -* man/hyperbole.texi (Smart Keys): Documented this new function. - -* hactypes.el (link-to-Info-node): Removed hpath:validate call since that - will cause some valid node references to not be accepted. - -Wed Sep 13 13:23:24 1995 Bob Weiner <weiner@infodock.com> - -* kotl/kfill.el: Renamed most functions from filladapt- to kfill:, to - avoid conflicts with the new minor mode filladapt. -* kotl/kotl-mode.el (kotl-mode): Turn filladapt minor mode off since - "kfill.el" handles filling in koutlines and reload kfill if some other - package has defined fill-paragraph. - -* hpath.el (hpath:find): -* hactypes.el (exec-shell-cmd): Execute in selected window if in the - OO-Browser, even when other-window is requested. - -* hmous-info.el (Info-handle-in-node-hdr): - (Info-handle-in-menu): Fixed invalid call to - Info-goto-node under GNU Emacs. - -* DEMO (Implicit Path Links): Expanded explanation of pathname handling. -* hibtypes.el (pathname): Added doc pointers to variables that control the - way files are displayed. - -* hpath.el (hpath:exists-p): - (hpath:suffixes): Added. - (hpath:find): - (hpath:validate): -* hactypes.el (link-to-Info-node): - (link-to-ebut): Modified to handle files that have been - compressed/uncompressed after a link was made to their - filenames. - -* hsite-ex.el: (hpath:display-alist): Modified to handle compressed info - files. - -Mon Sep 11 14:00:29 1995 Bob Weiner <weiner@infodock.com> - -* hmouse-tag.el (smart-c-include-file): - (smart-asm-include-file): Fixed to display include file in - viewer window if current in the OO-Browser. - -* kotl/klink.el (klink:create): Fixed to read and parse link references - properly. -* hargs.el (hargs:at-p): Return klink as a list, not a string. - (hargs:read): Convert klink to a string after reading it. - -Wed Aug 30 16:34:34 1995 Bob Weiner <weiner@infodock.com> - -* man/hyperbole.texi (Smart Keyboard Keys): Updated to describe URL and - gomoku support. - -* hui-mouse.el (hkey-alist): When playing {M-x gomoku}, Action key makes - human move at point and Assist Key takes back a move at point. - -============================================================================== -V3.19.08 changes ^^^^: -============================================================================== - -Sun Aug 27 04:55:17 1995 Bob Weiner <weiner@infodock.com> - -* hibtypes.el (patch-msg): Jumps to source associated with patch output - lines that begin with "Hunk" or "Patching". - -Sat Aug 26 21:30:45 1995 Bob Weiner <weiner@infodock.com> - -* hibtypes.el (grep-msg): Added support for Perl5 error message parsing. - -Fri Aug 25 00:30:08 1995 Bob Weiner <weiner@infodock.com> - -* kotl/kmenu.el (id-menubar-kotl): - (id-popup-kotl-menu): Added Hide-Levels, Hide-Subtree, - Show-Subtree menu items. Also enabled Copy-Before/After-Cell menu - items. - hui-menus.el (hui:menus): Added `Below' (same as {C-x $}) and `Kill' - (same as {C-c C-k}) menu items to Outliner menu. - -============================================================================== -V3.19.07 changes ^^^^: -============================================================================== - -* hui.el (hui:ebut-buf): Support mail buffers of the form *VM-mail* or - *mail*<2>. - -* kotl/kotl-mode.el (kotl-mode:hide-sublevels): Added to hide all outline - levels deeper than a given level argument. Bound to {C-x $}, since is - similar to set-selective-display. - -* kotl/kview.el (kcell-view:next): Fixed bug that failed to advance to - next visible cell when visible-p flag was true and current cell had a - collapsed subtree but was not itself collapsed and point was not on the - final line of the cell. - -Thu Aug 24 23:32:28 1995 Bob Weiner <weiner@infodock.com> - -* kotl/kotl-mode.el (kotl-mode:hide-subtree): Added to hide the subtree, - excluding root of a cell. Bound to {C-M-h}. - (kotl-mode:show-subtree): Added to show the subtree, - excluding root of a cell. - -Wed Aug 23 12:34:48 1995 Bob Weiner <weiner@infodock.com> - -* hpath.el (hpath:url-at-p): - (hpath:url-p): Fixed to handle more URL specifications and to - delete trailing periods and other characters properly. - -Tue Aug 22 12:08:53 1995 Bob Weiner <weiner@infodock.com> - -* hui-menu.el (hyperbole-menubar-menu): - wrolo-menu.el (wrolo-menubar-menu): - kotl/kmenu.el (kotl-menubar-menu): Fixed bug that would add menu if - menubar was nil. - -============================================================================== -V3.19.06 changes ^^^^: -============================================================================== - -Wed Aug 16 12:41:09 1995 Bob Weiner <weiner@infodock.com> - -* hibtypes.el (mail-address-regexp): Corrected omission of underscores in - addresses. - -Thu Aug 10 17:36:23 1995 Bob Weiner <weiner@infodock.com> - -* hpath.el (hpath:at-p): Modified to handle local file URLs like - file://localhost/ just as other local file references. - -* hargs.el (hargs:delimited): Modified to accomodate long string - delimiters where point might be in the middle of the opening delimiter. - -Wed Aug 9 18:37:54 1995 Bob Weiner <weiner@infodock.com> - -* hactypes.el (hyp-config): Reversed order of listing of Editor: and - Hyperbole: lines. - -============================================================================== -V3.19.05 changes ^^^^: -============================================================================== - -Tue Aug 8 10:53:38 1995 Bob Weiner <weiner@infodock.com> - -* hgnus.el - hsmail.el (smail:comment-add): Add to front of hook if add-hook exists - so that if the mail/news buffer headers are highlighted, so is this - comment header. - -Mon Jul 31 15:33:29 1995 Bob Weiner <weiner@infodock.com> - -* kotl/kview.el (kview:insert-contents): - (kcell-view:create): Moved call to kfile:narrow-to-kcells - so it is after insertion of newlines terminating the new cell. - Otherwise, this call would leave kotl data exposed when a cell was - inserted at the end of an outline. - -Tue Jul 25 16:26:16 1995 Bob Weiner <weiner@infodock.com> - -* hibtypes.el (mail-address): Prevented from triggering in a mail or news - summary buffer. - -* hui-mouse.el: Rewrote some functions for improved clarity. - -============================================================================== -V3.19.04 changes ^^^^: -============================================================================== - -Fri Jul 14 17:03:27 1995 Bob Weiner <weiner@infodock.com> - -* kotl/kotl-mode.el (kotl-mode): Changed hook used to save koutline data - from write-contents-hooks to local-write-file-hooks. - -Thu Jul 13 16:37:30 1995 Bob Weiner <weiner@infodock.com> - -* hui-em19-b.el (hproperty:but-add): Under Emacs 19, modified to highlight - explicit buttons when mouse passes over them if - hproperty:but-emphasize-p has been set non-nil (nil = default) in - hsite.el. - -* hsmail.el (smail:comment-add): Modified to only add - "Hyperbole mail buttons accepted" comment to outgoing mail messages if - the full Hyperbole system has been loaded since this function can be - called when only hyperbole.el has been loaded by a site initialization - but the individual user never uses Hyperbole. - -Mon Jul 10 11:49:52 1995 Bob Weiner <weiner@infodock.com> - -* hui-mouse.el (hkey-alist): -* hmouse-tag.el (smart-fortran): - (smart-fortran-at-tag-p): Added Fortran tags browsing support. - -Fri Jul 7 14:02:28 1995 Bob Weiner <weiner@infodock.com> - -* hsite-ex.el (hpath:display-alist): Modified to display files below an - /info/ directory but with a non-info suffix, in whatever their normal - mode is. Files under /info/ without a suffix are displayed as info - files. - -* kotl/kotl-mode.el (kotl-mode:center-line): Added and bound to {M-s}. - (kotl-mode:center-paragraph): Added and bound to {M-S}. - (kotl-mode:fill-paragraph): Modified to save point as a marker. - -============================================================================== -V3.19.03 changes ^^^^: -============================================================================== - -* htz.el (htz:date-unix): Clarified default values in doc string - and fixed bug that ignored LOCAL timezone argument, leading to - improper display of outliner cell time attributes. - -* kotl/kotl.el (kotl-data:to-kcell-v2): - (kotl-data:to-kcell-v3): Rewrote to repair cells on the fly - where the cell data saved in the outline is nil. This would only - happen if there is a bug in the kproperty code, but we still want - people to be able to read in outlines without error in such a case. - -* kotl/kprop-em.el (kproperty:put): Rewrote to prevent inheritance of - the added property by characters inserted following the region to which - the property is added. This inheritance caused bugs in the cell - separator search routines. Inheritance was already off by default for - characters preceding this region. - -Thu Jul 6 14:24:40 1995 Bob Weiner <weiner@infodock.com> - -* hmouse-drv.el (hkey-help-show): Fixed a bug that failed to properly - check whether a help buffer was already displayed. - -Sun Jun 25 17:16:21 1995 Bob Weiner <weiner@infodock.com> - -* kotl/kimport.el (kimport:star-outline): Modified to handle start - outlines whose stars are preceded by whitespace. - -* kotl/klabel.el (klabel-type:set-star): Fixed infinite loop problem when - converting to start labels. - -* kotl/kotl-mode.el (kotl-mode:add-cell): Modified to only fill a new cell - This is called by kotl-mode:split-cell. - (kotl-mode:add-cell): Added no-fill parameter. - (kotl-mode:split-cell): Modified to not fill new cell - if the original cell had a no-fill property. - -* kotl/kview.el (kview:add-cell): Added optional parameter no-fill to skip - filling of any initial cell contents. - -Fri Jun 23 11:58:24 1995 Bob Weiner <weiner@infodock.com> - -* hyperbole.el (Info-goto-node): Added autoload of this for Hyperbole menus. - -* kotl/klabel.el (klabel-type:set-partial-alpha): Speeded up partial-alpha - renumbering. - (klabel-type:update-tree-labels): Added, to update labels - in a single tree. - -* hvm.el (Vm-msg-to-p): Fixed problem that link-to-mail displayed the - wrong message when a folder was sorted into some order other than the - physcial order of messages. - -* kotl/kfile.el (kfile:print-to-string): Locally set emacs-lisp-mode-hook - to nil so no fontification is done when pretty printing koutline data - structures. - -============================================================================== -V3.19.02 changes ^^^^: -============================================================================== - -Wed Jun 21 00:42:12 1995 Bob Weiner <weiner@infodock.com> - -* kotl/kotl-mode.el (kotl-mode:fill-tree): Modified to support filling 0 - rooted tree, i.e. all cells in outline, when given a prefix argument. - -* kotl/klabel.el (klabel-type:set-labels): Fixed bug that incremented - labels by 1 too many because point started at an invalid outline - position. - -* kotl/kotl-mode.el (kotl-mode:exchange-cells): Modified to only refill - cells when kotl-mode:refill-flag is non-nil. - -* kotl/kproperty.el: Separated into two separate implementation files. - kprop-em.el for Emacs 19 - kprop-xe.el for XEmacs -* MANIFEST: -* Makefile (EL_KOTL, ELC_KOTL): Added references to new kprop-* files. - -Tue Jun 20 10:54:18 1995 Bob Weiner <weiner@infodock.com> - -* kotl/kproperty.el (kproperty:put): Fixed XEmacs version of this function - by using raw extents instead of text properties. - -* kotl/kmenu.el (id-popup-kotl-menu): Fixed Show-Top-Level-Only to run - proper command. - -* hui-menus.el (Msg): Shortened Msg menu to fit in 80 columns. - -* kotl/kproperty.el (kproperty:map): Added to map over a matching property - in a buffer and to return the result. - -Mon Jun 19 18:50:34 1995 Bob Weiner <weiner@infodock.com> - -* kotl/kotl-mode.el (kotl-mode:demote-tree): - (kotl-mode:promote-tree): - (kotl-mode:move-after): - (kotl-mode:move-before): -* kotl/kview.el (kview:move): Reversed meaning of last argument, fill-p. - -* hui-menus.el (hui:menus): Removed any leading 0 from Hyperbole version - number in the keyboard menu. - -============================================================================== -V3.19.01 changes ^^^^: -============================================================================== - -Thu Jun 15 00:24:34 1995 Bob Weiner <weiner@infodock.com> - -* kotl/kview.el (kcell-view:previous): Expanded cases that will find - previous cell. - -* kotl/kotl-mode.el (kotl-mode:move-after): - (kotl-mode:move-before): Fixed bug where original - sibling cell could be renumbered twice, the 2nd time with the wrong label. - -* hui-menus.el (hui:menu-enter): Rewrote to properly handle XEmacs and - Emacs 19 keyboard events. - -* kotl/kview.el (kcell-view:previous): - (kcell-view:next): Optimized. - -Wed Jun 14 01:49:45 1995 Bob Weiner <weiner@infodock.com> - -* kotl/kview.el (kview:goto-cell-id): Speeded up by up to 10x with - optimized implementations for each Emacs variant. - -* kotl/kotl-mode.el (kotl-mode:fill-cell): Notify user if can't fill since - cell has a no-fill attribute. - -* kotl/EXAMPLE.kotl (2b5): Explained cell and tree filling. - -* hversion.el (id-browse-file): Added definition needed by pull-down menu. - -* kotl/kotl-mode.el (kotl-mode:fill-tree): Added and bound to {C-M-j} and - {C-M-q}. - -* kotl/kview.el (kcell-view:remove-attr): - kotl/kotl.el (kcell:remove-attr): - kotl/knode.el (knode:remove-attr): Added. - -* kotl/kview.el (kcell-view:set-attr): Added this back in; somehow it was - accidentally deleted. Also made it and kcell-view:get-attr - interactive, so users can set and get attributes. - -* kotl/kotl-mode.el (kotl-mode:demote-tree): - (kotl-mode:promote-tree): With prefix ARG = 0, cells - are moved up to one level but are not refilled. This is much faster - than when each cell must be refilled. - -* kotl/kview.el (kview:move): Optimized to skip mapping over a tree to - re-collapse cells if none were collapsed. - -Tue Jun 13 16:35:42 1995 Bob Weiner <weiner@infodock.com> - -* hmous-info.el (Info-handle-in-note): Added support for `See' - cross-references used by XEmacs. - -============================================================================== -V3.19 changes ^^^^: -============================================================================== - -Tue Jun 13 16:35:42 1995 Bob Weiner <weiner@infodock.com> - -* hinit.el (hyperb:init-menubar): -* hui-menu.el (hyperbole-menubar-menu): Modified to re-install Hyperbole - menu in InfoDock menubar after using the menu's Quit item. - -Mon Jun 12 19:31:28 1995 Bob Weiner <weiner@infodock.com> - -* kotl/klabel.el (klabel-type:set-alpha): Optimized alpha and legal - renumbering. Cut time by about 50% for multi-level outlines. - -Tue Jun 6 12:34:47 1995 Bob Weiner <weiner@infodock.com> - -* kotl/klabel.el - kview.el - kotl-mode.el: Optimized many functions to not compute - label-sep-len repeatedly. This speeds up many operations. - -* kotl/kotl-mode.el (kotl-mode-map): Fixed to handle {M-q} bound to - fill-paragraph-or-region in XEmacs. - -Mon Jun 5 16:56:58 1995 Bob Weiner <weiner@infodock.com> - -* hui-menu.el (infodock-hyperbole-menu): Made "Quit" menu item remove - Hyperbole comment from future outgoing mail and remove Hyperbole menu - from every menubar which has it. - -============================================================================== -V3.18.13 changes ^^^^: -============================================================================== - -Fri Jun 2 11:29:11 1995 Bob Weiner <weiner@infodock.com> - -* kotl/kotl-mode.el (kotl-mode:beginning-of-tree): Added and bound to {C-c ^}. - (kotl-mode:end-of-tree): Addded and bound to {C-c $}. - -* kotl/kview.el (kcell-view:parent): Added optional parameter visible-p, - when non-nil, only visible parents are considered. - -* kotl/kotl-mode.el (kotl-mode:first-sibling): Added and bound to {C-c <}. - (kotl-mode:last-sibling): Added and bound to {C-c >}. - -* man/hyperbole.texi (Outliner Keys): - kotl/kotl-mode.el (kotl-mode:copy-to-buffer): Added and bound to {C-c M-c}. - -Thu Jun 1 11:10:03 1995 Bob Weiner <weiner@infodock.com> - -* hui-window.el (smart-window-of-coords): - (smart-coords-in-window-p): - (hmouse-modeline-resize-window): Fixed bug under XEmacs 19.11. - -============================================================================== -V3.18.12 changes ^^^^: -============================================================================== - -Fri May 19 15:32:37 1995 Bob Weiner <weiner@infodock.com> - -* hui-menus.el (hyperbole): Added call to hyperb:init-menubar. -* hinit.el (hyperb:init-menubar): Added to add Hyperbole menu to menubar. -* hui-menu.el (infodock-hyperbole-menu): Added Quit menu item to delete - the Hyperbole menu from the menubar. {C-h h} will bring it back again. - -Thu May 18 12:23:01 1995 Bob Weiner <weiner@infodock.com> - -* Changed all cs.brown references to hub.ucsb.edu (for mail lists) - and cs.uiuc.edu (for Hyperbole source). - -* hui-xe-but.el (hproperty:set-item-highlight): Fixed this function - for use with XEmacs 19.12. - -* wrolo.el (rolo-to): - (rolo-edit): Fixed longstanding bug that failed to move point - to the matched entry if the rolodex file buffer was already displayed - before the edit request was made. - -============================================================================== -V3.18.11 changes ^^^^: -============================================================================== - -Mon May 15 11:20:38 1995 Bob Weiner <weiner@infodock.com> - -* hmous-info.el (Info-handle-in-node-hdr): - (Info-handle-in-menu): Fixed to handle Info references - whose filenames require a suffix in Info-suffix-list. - -* hpath.el (hpath:find-program): Return nil if given a directory name, so - that no special cases trigger on directories. - -* hsite-ex.el (hpath:display-alist): Changed to display files which do not - end in .info but which are in directories /info/ or /info-local/ as - Info files. - -============================================================================== -V3.18.10 changes ^^^^: -============================================================================== - -Fri May 12 12:54:19 1995 Bob Weiner <weiner@infodock.com> - -* Makefile (dist): Updated to execute entire distribution build process. - -* hsite-ex.el (hyperb:lemacs-p): -* hui-xe-but.el (hproperty:highlight-face): Fixed to highlight explicit - buttons and rolodex matches with the `italic' face when used under - XEmacs on a tty. - -============================================================================== -V3.18.9 changes ^^^^: -============================================================================== - -Tue May 9 12:45:21 1995 Bob Weiner <weiner@infodock.com> - -* Makefile (install): Changed to install documentation. - -* man/hyperbole.texi (Smart Keys): Renamed hmouse-doc.txt to - hypb-mouse.txt for easier association with Hyperbole when moved to - data-directory during install. -* hypb.el (hypb:mouse-help-file): Added to centralize resolution of - the hypb-mouse.txt path. -* hmouse-drv.el (hkey-summarize): -* hui-menu.el (infodock-hyperbole-menu): -* hui-menus.el (hui:menus): Called (hypb:mouse-help-file). - -* hui-window.el (smart-coords-in-window-p): - (smart-window-of-coords): Updated to support XEmacs 19.12 - mouse-position protocol which returns window of event as the car of a - list. - -* hibtypes.el (debugger-source): Added jump to source of an XEmacs - assertion failure which looks like: - assert_failed (file=0xf3c78 "eval.c", line=1412, - -Mon May 8 14:30:56 1995 Bob Weiner <weiner@infodock.com> - -* man/hyperbole.texi (Operating Menus): -* hui-menu.el (hyperbole-menubar-menu): -* kotl/kfile.el: -* kotl/kmenu.el (kotl-menubar-menu): -* wrolo.el (wrolo-mode): -* wrolo-menu.el (wrolo-menubar-menu): Added support for pulldown and popup - menus under Emacs19. - -* kotl/kotl-mode.el (kotl-mode:print-properties): Made kview argument - required to avoid a bug where kview is somehow set to nil within - callers. - -* kotl/kview.el (kcell-view:to-label-end): Clarified error when kview is nil. - -============================================================================== -V3.18.8 changes ^^^^: -============================================================================== - -Fri May 5 14:33:51 1995 Bob Weiner <weiner@infodock.com> - -* Makefile: Removed building of Info and Postscript versions of the - Hyperbole manual from default `make'. Use `make info' and `make ps', - respectively. - -* hui-xe-but.el: -* wrolo.el (rolo-highlight-face): Adapted for new XEmacs make-face return - value of a face object, rather than the old behavior of a face name. - -* kotl/kfile.el (kfile:update): Added (let ((debug-on-error nil)) so one - can easily save koutlines while debugging Emacs Lisp code. - -Tue May 2 11:08:53 1995 Bob Weiner <weiner@infodock.com> - -* Makefile (tags): Replaced all - with underscore in variable names to - satisfy the AIX sh. - -Mon May 1 15:50:33 1995 Bob Weiner <weiner@infodock.com> - -* hsite-ex.el (hpath:display-alist): Added display of top node when Action - Key is pressed over an Info file name. - -Fri Apr 28 19:18:13 1995 Bob Weiner <weiner@infodock.com> - -* hui-xe-but.el (hproperty:set-item-highlight): Fixed failure to set - rolo-highlight-face when it is the same as the default font. - -============================================================================== -V3.18.7 changes ^^^^: -============================================================================== - -Mon Apr 24 10:49:30 1995 Bob Weiner <weiner@infodock.com> - -* hui-mouse.el (hkey-alist): Simplified support for view major and minor - modes. - -Sun Apr 23 13:21:20 1995 Bob Weiner <weiner@infodock.com> - -* hibtypes.el (debugger-source): Renamed from gdb-source and added dbx and - xdb debugger support for jumping to source from a stack backtrace line. - -Wed Apr 19 19:37:20 1995 Bob Weiner <weiner@infodock.com> - -* hmouse-tag.el (smart-tags-file-path): Added this function, used by - ibtype gdb-source and actype link-to-file-line to find non-local, - relative files. -* hyperbole.el (smart-tags-file-path): Added autoload. - -Tue Apr 18 11:49:27 1995 Bob Weiner <weiner@infodock.com> - -* hversion.el (id-tool-invoke): Fixed to handle interactive command calls. - -Sun Apr 16 22:35:33 1995 Bob Weiner <weiner@infodock.com> - -* hversion.el (sm-window-sys-term): Support Emacs under OS/2 which uses - the Presentation Manger window manager. -* htz.el (htz:local): OS/2 doesn't have a date function, so use TZ or - TIMEZONE environment variable if set as local timezone instead. -* hpath.el (hpath:url-p): - (hpath:url-at-p): Avoid [a-z]:/path patterns since these may be - disk paths on OS/2, DOS or Windows. - -============================================================================== -V3.18.6 changes ^^^^: -============================================================================== - -Fri Apr 14 15:31:17 1995 Bob Weiner <weiner@infodock.com> - -* man/hyperbole.ps: Removed from the distribution. Too large; users who - need it can build it themselves. - -* man/hyperbole.texi (Action Types): Documented extension command - characters' use of `+' prefix. - -* hargs.el (hargs:iforms): Added basic support for new Emacs 19 `K' - command character. - -* *.el: Added KEYWORDS: header. - -Wed Apr 12 11:26:03 1995 Bob Weiner <weiner@infodock.com> - -* hui-window.el (smart-coords-in-window-p): - (smart-window-of-coords): Fixed to work with XEmacs 19.11 - which can return nil for (event-window) if event is over a - modeline. - -Tue Apr 11 12:48:18 1995 Bob Weiner <weiner@infodock.com> - -* hargs.el (hargs:get): Added support for user extension interactive - command characters that are being added to Emacs 19. Each such - character is preceded by a `+' character. - -* hui-mouse.el (hkey-alist): Added Action/Assist key press support for - OO-Browser listing buffers used when the full OO-Browser user interface - is not displayed. - -Mon Apr 10 17:41:54 1995 Bob Weiner <weiner@infodock.com> - -* Makefile (ELC-COMPILE): Added hsys-* files so they will be built. - -============================================================================== -V3.18.5 changes ^^^^: -============================================================================== - -Sat Apr 8 13:53:27 1995 Bob Weiner <weiner@infodock.com> - -* man/hyperbole.texi (Top): Added credits. - -Fri Apr 7 17:21:04 1995 Bob Weiner <weiner@infodock.com> - -* kotl/kfile.el (kfile:update): - kotl/kotl.el (kotl-data:create): Modified to repair invalid cells when - trying to save them. - (kotl-data:to-kcell-v3): Modified to repair invalid cells when - trying to load them from a file. - -Thu Apr 6 10:22:07 1995 Bob Weiner <weiner@infodock.com> - -* Makefile (PRELOADS): Added ref to $(SITE-PRELOADS) for customization of - the Lisp libraries loaded before byte-compiling any files. - (BATCHFLAGS): Removed -no-site-file so addition of the - OO-Browser directory to load-path may be done in site-start.el. - -* kotl/kmenu.el: Added this file of menus for the Koutliner from InfoDock - and adapted for use under standard XEmacs. - -Wed Apr 5 18:48:15 1995 Bob Weiner <weiner@infodock.com> - -* hinit.el (hyperb:init): Added setup of XEmacs pulldown menu for Hyperbole. -* hui-menu.el: Added this file to provide a global pulldown menu of InfoDock - comands under XEmacs. -* wrolo-menu.el: Added this file of menus for the Rolodex from InfoDock - and adapted for use under standard XEmacs. Also defines a rolodex - menu which may be used independently of the Hyperbole menu. - -Mon Apr 3 10:03:09 1995 Bob Weiner <weiner@infodock.com> - -* hyperbole.el (rolo-word): Autoloaded this command. - -============================================================================== -V3.18.4 changes ^^^^: -============================================================================== - -Tue Mar 28 12:22:27 1995 Bob Weiner <weiner@infodock.com> - -* hui-window.el (hmouse-release-left-edge): - (hmouse-release-right-edge): Fixed bug which improperly - called `window-event' when `event-window' was intended. - -Sun Mar 26 00:39:18 1995 Bob Weiner <weiner@meltdown.valhalla (Bob Weiner)> - -* man/hyperbole.texi: Renamed from hypb.texi. - -Sat Mar 25 23:20:02 1995 Bob Weiner <weiner@infodock.com> - -* Makefile (elc): Cleaned up user output produced by this target. - -============================================================================== -V3.18.3 changes ^^^^: -============================================================================== - -Fri Mar 24 10:41:17 1995 Bob Weiner <weiner@infodock.com> - -* hibtypes.el (rfc): Updated to support efs too. -* hpath.el (hpath:ange-ftp-p): - (hpath:ange-ftp-at-p): Added support for `efs' package, the - successor to ange-ftp. - Also changed so can jump to remote pathnames if ange-ftp will - be autoloaded via file-name-handler-alist under Emacs V19. - -* Makefile (elc): Rewrote in a portable manner so that one emacs - invocation builds all elc files. - -Thu Mar 23 03:23:51 1995 Bob Weiner <weiner@infodock.com> - -* kotl/klink.el (klink:at-p): Fixed so won't trigger in OO-Browser listing - buffers, e.g. on a C++ <template> class. - -* hversion.el (hyperb:stack-frame): Fixed stack frame indirection problem - with autoloaded commands called by name. Also added optional - debug-flag parameter to simplify debugging of this function. - -* kotl/kotl-mode.el (kotl-mode:delete-char): Fixed bug that deleted - non-whitespace characters if they fell in the indent area, e.g. when - yank text that starts with a newline and then some characters. - -* hactypes.el (link-to-file-line): - (link-to-regexp-match): Added a (widen) so matches are found - when buffer happens to be narrowed to a particular part. - -Wed Mar 22 03:18:39 1995 Bob Weiner <weiner@infodock.com> - -* hib-kbd.el (kbd-key:act): Fixed infinite recursion if used the Action - Key on a {key sequence} that invokes the Action Key. - -* Makefile (EMACS): Changed default setting of this variable to XEMACS. - -* Renamed a bunch of Hyperbole functions and variables. - -Tue Mar 21 17:11:23 1995 Bob Weiner <weiner@infodock.com> - -* Makefile: Fixed problems in a number of areas with different versions - of make. - -* hmouse-key.el (hyperb:window-system): Eliminated require of Emacs 19 and - XEmacs mouse libraries since they both pre-load these. - -============================================================================== -V3.18.2 changes ^^^^: -============================================================================== - -Mon Mar 20 11:49:42 1995 Bob Weiner <weiner@infodock.com> - -* hui-window.el: Rewrote to support XEmacs 19.12 new window-local mouse - coordinate API. Mainly eliminated use of window-edges under XEmacs. - -* hui-menus.el (hui:bottom-window): Added with function to avoid use of - (window-edges) when (window-lowest-p) is defined. - -* hypb.el (hypb:frame-line): Deleted this function as it is no longer used - and would not work in new XEmacs versions. -* hmouse-drv.el (scroll-down-eol): - (scroll-up-eol): Rewrote to not require knowledge of - current frame line, only current window line. - -Fri Mar 17 12:46:39 1995 Bob Weiner <weiner@infodock.com> - -* Makefile (elc): Rewrote to compile all out of date .elc files with one - invocation of Emacs. - -Thu Mar 16 13:07:48 1995 Bob Weiner <weiner@infodock.com> - -* hactypes.el (hyp-config): Added OO-Browser version number when it has - been loaded. - -Wed Mar 15 14:50:57 1995 Bob Weiner <weiner@infodock.com> - -* Changed all functions and variables named *-meta* to *-assist*. Meta - was an old remnant of the Assist Key being bound to a meta-mouse key. - -* hui-xe-but.el (hproperty:item-button): Added defvar of this to satisfy - XEmacs 19.12beta which does not set a default value for a variable - when a make-variable-buffer-local is done without a preceding defvar. - -Wed Mar 15 11:11:49 1995 Bob Weiner <weiner@infodock.com> - -* hmouse-reg.el (sm-mouse-setup): Fixed problem with trying to add a key - to a null valued Info-mode-map. - -Tue Mar 14 01:30:54 1995 Bob Weiner <weiner@infodock.com> - -* README: Changed ftp site to cs.uiuc.edu. - hypb.texi (Initializing): Documented that one must now load - "hversion.el" before Hyperbole. -* hversion.el: Added functions used to computer Hyperbole directory in - here so that they may easily be used with other packages, like the - OO-Browser. - -* hyperbole.el (hyperb:dir): Rewrote to always be dynamically set, rather - than having Makefile hard-code the Hyperbole path. This will only - work under versions of Emacs 19, however. Emacs 18 users should set - this variable manually before loading hyperbole.el. - -============================================================================== -V3.18.1 changes ^^^^: -============================================================================== - -Mon Mar 6 23:14:34 1995 Bob Weiner <weiner@infodock.com> - - * V3.18 is released. - -Sun Mar 5 18:23:12 1995 Bob Weiner <weiner@infodock.com> - -* hmouse-tag.el: Changed so that identifier tags within comments are no - longer ignored. - -* hui-mouse.el (smart-key-alist): -* hmouse-tag.el: (smart-objc): - (smart-objc-oobr): - (smart-objc-at-tag-p): Added these 3 functions and Action - Key support under Objective-C. -* man/hypb.texi (Smart Keyboard Keys): Documented these additions. - -Fri Mar 3 14:50:31 1995 Bob Weiner <weiner@infodock.com> - -* kotl/kotl-mode.el (kotl-mode:delete-blank-lines): If nothing but - whitespace follows point until the end of a cell, delete all - whitespace at the end of the cell. - -Thu Mar 2 23:35:11 1995 Bob Weiner <weiner@infodock.com> - -* hmouse-drv.el (smart-key-help): Fixed so selected window does not change - if in the OO-Browser when this command is called. - -Wed Mar 1 12:59:25 1995 Bob Weiner <weiner@infodock.com> - -* hibtypes.el (grep-msg): Fixed bug in file name expansion when grep - output is in a buffer with an attached file. - -Tue Feb 28 16:11:46 1995 Bob Weiner <weiner@infodock.com> - -* hibtypes.el (elisp-compiler-msg): Modified to handle makefiles which - send byte-compiler messages to a shell or any other buffer. - -Mon Feb 27 00:27:45 1995 Bob Weiner <weiner@infodock.com> - -* Updated all copyrights to reflect transfer to the FSF. - -Sat Feb 25 12:11:19 1995 Bob Weiner <weiner@infodock.com> - -* hpath.el (hpath:is-p): - (hpath:at-p): Fixed so handles URL ftp:// paths as ange-ftp paths. - -* Makefile: Changed so that elc target just rebuilds out of date elc - files, not all elc files. all-elc now does that. - -Thu Feb 16 13:32:03 1995 Bob Weiner <weiner@infodock.com> - -* man/hypb.texi (Implicit Buttons and Types): Added many new index entries - and added new mail-address type. -* hibtypes.el (mail-address): Added new implicit button type to compose mail, - in another window, when point is on an Internet e-mail address. - (mail-address-at-p): Added to test if point is within an - e-mail address. - (mail-address-regexp): Regexp matching an e-mail address. - -* hui-mouse.el (smart-wrolo): Fixed doc to agree with function behavior. - Also added support for sending e-mail to a specific address when - called with point inside an e-mail address. - -Wed Feb 15 14:41:33 1995 Bob Weiner <weiner@infodock.com> - -* kotl/kotl-mode.el (kotl-mode:head-cell): Added to move point to first - cell at same level as current cell. - (kotl-mode:tail-cell): Added to move point to last - cell at same level as current cell. - - (kotl-mode:mark-paragraph): Renamed from somehow - mistakenly named, hypb:mark-paragraph. - -* kotl/kview.el (kview:map-tree): Renamed from kview:map and set-buffer - to KVIEW parameter's buffer. - (kview:map-branch): Added to map across a set of trees - starting at the same level. - (kview:map-siblings): Added to map across a set of sibling - cells. - - (kcell-view:backward): - (kcell-view:forward): Changed parameter from INVISIBLE-P - to VISIBLE-P to match kcell-view:next/previous functions. - -* kotl/kotl-mode.el (kotl-mode-map): Made kotl-mode commands which - override standard editing commands also inherit the property lists from - their respective standard command symbols. So, for example, commands - which use the pending-delete property under XEmacs will be compatible. - - (kotl-mode:split-cell): Changed to delete any - whitespace preceding point before splitting cell, so do not end up - with excess whitespace at the end of the preceding cell. - -Tue Feb 14 12:13:37 1995 Bob Weiner <weiner@infodock.com> - -* kotl/kfill.el (filladapt-prefix-table): Tightened hanging indent pattern - so does not match to lines whose first word happens to end with a paren - and then a space, unless the word is 2 chars or less, then assume it is - a label, e.g. A2) . - -Mon Feb 13 10:26:20 1995 Bob Weiner <weiner@infodock.com> - -* wrolo.el (rolo-next-match): - (rolo-previous-match): Added (let ((case-fold-search t))) since - this is used in rolo-grep and `looking-at' call may fail if not set. - -* wrolo.el (wrolo-mode): Don't load menus-rolo under tty InfoDock. -* kotl/kfile.el (featurep 'menus-kotl): Don't load menus-kotl under tty InfoDock. -* hversion.el (sm-window-sys-term): Added (eq window-system 'tty) clause - and set return value to nil, since there is no mouse support in this - case. -* hsite-ex.el (and hyperb:lemacs-p window-system): XEmacs 19.12 and above - sets window-system = 'tty if running on a dumb terminal so that it can - still display faces. But testing for a color display will fail since - this requires an X display right now, so added a (not (eq - window-system 'tty) in this case. - -Mon Jan 30 18:50:22 1995 Bob Weiner <weiner@infodock.com> - -* hactypes.el (hyp-config): Updated to use system-configuration variable - when available. - -Wed Jan 25 17:33:26 1995 Bob Weiner <weiner@infodock.com> - -* hibtypes.el (cscope): Tightened predicate to only match if in a Cscope - output buffer, to avoid false regexp matches. - -Fri Jan 20 15:19:08 1995 Bob Weiner <weiner@infodock.com> - -* hpath.el (hpath:is-p): Modified to not allow whitespace within - (pathname) component of Info node paths. - -Mon Jan 9 13:59:28 1995 Bob Weiner <weiner@infodock.com> - -* kotl/kotl-mode.el (kotl-mode:overview): - hui-menus.el (hui:menus): - man/hypb.texi (Outliner Keys): Renamed kotl-mode:hide-body to - kotl-mode:overview, changed binding to {C-c C-o} and changed its - function to show first line of all cells. Also added to Otl> menu as - `Overview' command. - Also added kotl-mode:top-cells bound to {C-c C-t} which does what - kotl-mode:hide-body used to, show only top cells. - -Fri Dec 30 14:12:02 1994 Bob Weiner <weiner@infodock.com> - -* kotl/kotl-mode.el (kotl-mode:first-cell-p): - (kotl-mode:last-cell-p): Fixed bug that invoked wrong - subroutine. - -Thu Dec 29 14:04:52 1994 Bob Weiner <weiner@infodock.com> - -* kotl/kotl-mode.el (kotl-mode:shorten-all): - (kotl-mode:extend-all): Added to remove and then add - back in blank lines separating outline nodes, for compact viewing use - only. - -* kotl/kfile.el (kfile:shorten-after-save): - (kfile:extend-before-save): Added to add blank lines for - saving outlines and then to restore original view after save. - -* kotl/kproperty.el (kproperty:put): Added error message if XEmacs extent - is not created. Also get extent from (1+ start) to avoid bounds error. - -* kotl/kotl-mode.el (kotl-mode:transpose-paragraphs): - (kotl-mode:mark-paragraph): - (kotl-mode:mark-whole-buffer): Added to overload - standard command. - (kotl-mode:backward-para): - (kotl-mode:backward-paragraph): - (kotl-mode:forward-para): - (kotl-mode:forward-paragraph): Redefined to only move - a paragraph within a cell, not a cell at a time. - (kotl-mode:collapse-tree): - (kotl-mode:expand-tree): - (kotl-mode:toggle-tree-expansion): Added to expand and - collapse each cell within a tree. - -* hypb.el (hypb:push-mark): Added for push-mark compatibility between - Emacs 18 and 19. Used in kotl-mode.el. - -Wed Dec 21 13:10:24 1994 Bob Weiner <bweiner@sun29> - -* hui-mouse.el (first-line-p): - (last-line-p): Moved from hinit.el to reduce inter-file - dependencies. - -* hyperbole.el: Removed old bindings of smart key help, {C-h S} and {C-h - H}. Use {C-h A} instead. - -* hsite-ex.el (hpath:display-alist): Defined this new variable. -* man/hypb.texi (Internal Viewers): Added this section to describe the new - hpath:display-alist variable. -* hpath.el (hpath:find-program): Added use of `hpath:display-alist' - variable for file types which should be displayed a special way within - Emacs, e.g. by running a Lisp program on the file. This differs form - `hapth:find-alist' in that its entries are window-system independent. - -Fri Dec 16 20:04:45 1994 Bob Weiner <bweiner@sun29> - -* hpath.el (hpath:find): Modified to support Lisp expression return values - from hpath:find-program. - -* kotl/kfile.el (menus-kotl): Changed so menus are only loaded under - XEmacs-based InfoDock. - -Thu Dec 15 12:51:34 1994 Bob Weiner (bweiner@sun29) - -* hact.el (actype:doc): Fixed so that ibtypes doc is used when the current - button is an implicit button. (Previously only the action type doc - was displayed.) - -* hibtypes.el (elisp-compiler-msg): Modified to handle makefiles which run - the byte-compile and send output to *compilation* buffer. - -* hlvar.el (hack-local-variables): Added (run-hooks - 'hack-local-variables-hook)) for future Emacs version compatibility. - -Wed Dec 7 17:25:33 1994 Bob Weiner (bweiner@sun29) - -* wrolo.el (rolo-highlight-face): Rewrote so is always initialized properly. -* hui-xe-but.el (hproperty:set-item-highlight): Changed (facep - rolo-highlight-face) to (find-face rolo-highlight-face) so that - conditional works properly. - -* hmous-info.el (Info-handle-in-note): Updated to use Info-footnote-tag - variable if defined. - -Tue Dec 6 13:29:57 1994 Bob Weiner (bweiner@sun29) - -* hibtypes.el (rfc): Rewrote so that ange-ftp is required only if - hpath:rfc is a remote pathname. - -* hui-mouse.el (smart-man-c-routine-ref): Fixed so only prompts for - tags-file-name when truly needed. - (smart-key-alist): Added handler for view-less mode used - with XEmacs and re-arranged clauses so that view mode can be used to - display man pages. - -Thu Dec 1 13:25:15 1994 Bob Weiner (bweiner@sun468) - -* hui-mouse.el: Added autoload of var:append. - -============================================================================== -V3.18 changes ^^^^: -============================================================================== - -Fri Nov 11 17:34:05 1994 Bob Weiner (bweiner@sun285) - -* hbmap.el (hbmap:dir-list): Removed skip of first line in dir-list file. - This had been reserved in earlier Hyperbole versions but now contains the - first directory entry. - -* hmouse-tag.el (smart-c-include-file): Modified to deal with cc-mode as a - replacement for c-mode. - -* wrolo.el (rolo-display-matches): Triggered error if buffer of previous - matches does not exist. - -* hui-menus.el (hui-menu): Corrected Rolo/Info node pointer. - -Sat Nov 5 13:49:19 1994 Bob Weiner (bweiner@sun285) - -* hui-xe-but.el - hui-em19-b.el - hui-ep19-b.el (hproperty:set-item-highlight): Updated to alter - rolo-highlight-face if it matches hproperty:highlight-face. -* wrolo.el (rolo-grep-file): Removed call to - hproperty:set-item-highlight. Instead done once when wrolo.el is loaded. - (rolo-highlight-face): Updated initial setting expression. - -============================================================================== -V3.17 changes ^^^^: -============================================================================== - -Fri Nov 4 12:37:45 1994 Bob Weiner (bweiner@sun285) - -* wrolo.el (rolo-highlight-face): Fixed to work with Emacs 19 (V19.25). - -Fri Oct 28 14:49:59 1994 Bob Weiner (bweiner@sun285) - -* hibtypes.el (grep-msg): Modified to expand filename against implicit - button source location, if a pathname. This makes constructs - like the following work when the 2nd line is activated: - @loc> "/usr/local/infodock" - lisp-local/hypb/hactypes.el:145: (require 'comint)) - -* hmail.el (hmail:compose): Fixed to allow empty string subject lines. - -Wed Oct 26 13:33:26 1994 Bob Weiner (bweiner@sun285) - -* man/hypb.texi (Rolo Keys): Added this section to document wrolo-mode - keymap bindings. - -* wrolo.el (rolo-edit-entry): Added this command to edit entry at point. - -* hui-epV4-b.el - hui-em19-b.el - hui-xe-but.el (hproperty:set-item-highlight): Fixed to always set - BACKGROUND if given. - -* wrolo.el (wrolo-mode): Added a real mode for rolodex match buffer. - (wrolo-mode-map): Added keymap which allows easy scrolling, - outline movement and match location within the rolodex match buffer. - (rolo-match-regexp): Added to store last search expression. - (rolo-next-match): Added and bound to {TAB} in rolodex - match buffer. Moves point to next match. - (rolo-previous-match): Added and bound to {r} and {M-TAB} in - rolodex match buffer. Moves point to previous match. - (rolo-display-matches): Added (run-hooks 'wrolo-display-hook) - to affect match buffer after a search has been done and matches have - been inserted. Also, now that the match buffer has a real mode, - changed so that point is left in the match buffer after a search. {q} - will quit. - (rolo-quit): Added to quit from rolodex match buffer and to - restore frame display. Bound to {q}. - -Tue Oct 25 11:10:05 1994 Bob Weiner (bweiner@sun285) - -* wrolo.el (rolo-word): Added to search rolodex for string matches only on - word boundaries. - -* man/hypb.texi (Rolo Settings): Documented new rolo-highlight-face variable. - -* wrolo.el rolo-highlight-face - (rolo-add-match): - (rolo-highlight-matches): Added to highlight regions which - match to any rolodex search argument. - README - Added a note about this feature. - -* hsite-ex.el: Changed all `le:' and `ep:' to `hproperty:' throughout - Hyperbole. This changed a number of variable names, so be sure to - recreate your hsite.el file from hsite-ex.el. - Renamed `ep/le:style_highlight' to `hproperty:highlight-style'. - Renamed `ep/le:item-style' to `hproperty:item-style'. - -Mon Oct 24 17:52:59 1994 Bob Weiner (bweiner@sun285) - -* man: Created this subdirectory and moved all Hyperbole user - documentation there. - -Thu Oct 20 14:37:32 1994 Bob Weiner (bweiner@sun285) - -* hui-mouse.el (smart-man-entry-ref): Removed conditional referencing - Interviews C++ library. No longer needed. - -* hmouse-drv.el (smart-key-help-show): Removed lines which set Help - buffers into Emacs Lisp mode so that Smart Keys would follow symbol - references. - hmouse-tag.el (smart-emacs-lisp-mode-p): Updated to recognize Help buffers. - -* hsite-ex.el (hpath:find-alist): Added `mif' suffix, FrameMaker - Interchange Format. - -Wed Oct 19 14:17:54 1994 Bob Weiner (bweiner@sun285) - -* hmous-info.el (Info-handle-in-note): Modified to handle clicks on cross-reference - labels whose `*Ref' header is on the prior line. - -Tue Oct 18 23:25:16 1994 Bob Weiner (bweiner@sun285) - -* hversion.el (hyperb:kotl-p): Moved from hyperbole.el. - -Mon Oct 17 19:56:26 1994 Bob Weiner (bweiner@sun285) - -* hui-window.el (sm-mouse-modeline-action-hook): - (sm-mouse-modeline-assist-hook): Added definitions of - these hooks run when Action or Assist key is clicked in the middle of - a modeline. - -* wrolo.el (rolo-to-buffer): Changed so uses selected frame by default. - -Fri Oct 14 18:46:47 1994 Bob Weiner (bweiner@sun285) - -* hinit.el (hyperb:action-v1): - hact.el (action:act): Removed these two functions which were for - Hyperbole V1 compatibility. Nobody uses V1 anymore. - -Wed Oct 12 16:38:01 1994 Bob Weiner (bweiner@sun285) - -* hui-xe-but.el (le:but-add): Change 'set-extent-attribute to - 'set-extent-property, its replacement function. - -Sat Oct 8 16:40:43 1994 Bob Weiner (bweiner@sun285) - -* (hmouse-drv.el) - (hib-doc-id.el): Renamed `*smart-key-screen-config*' to - `*smart-key-wconfig*'. - -* (wrolo.el) rolo-display-matches: Added hyperb:xemacs-p conditional. -* (hversion.el) hyperb:xemacs-p: Added to match "XEmacs", the new name for - Lucid Emacs. - hyperb:lemacs-p: Also match to XEmacs in places where the API - is the same as that of XEmacs. - hyperb:version: Bumped to 3.16 for release. - -Wed Oct 5 13:32:33 1994 Bob Weiner (bweiner@sun285) - -* (MANIFEST): - (Makefile): - (TAGS): - (hsite-ex.el): - (hui-le-but.el): Renamed to hui-xe-but.el since Lemacs was renamed to XEmacs. - -Fri Sep 30 12:12:58 1994 Bob Weiner (bweiner@sun285) - -* hactypes.el: (require 'comint): Conditionalized so not invoked under - InfoDock, a modified version of XEmacs which uses shell rather than - comint mode. - -Thu Sep 22 11:53:04 1994 Bob Weiner (bweiner@sun29) - -* htz.el (htz:date-parse): Modified to parse dates from an `ls -l' command. - (htz:span-in-days): Added to compute time spans between dates. - -Wed Sep 21 18:46:30 1994 Bob Weiner (bweiner@sun29) - -* hui-mouse.el (smart-key-alist): Added handler for tar-mode. - (smart-tar): - (smart-tar-meta): Added these Smart Key handlers, similar - to Smart Key handling in dired-mode. -* hypb.texi (Smart Keyboard Keys): Added tar-mode entry. - -Wed Sep 21 17:10:30 1994 Bob Weiner (bweiner@sun1) - -* hibtypes.el (elisp-compiler-msg): Fixed so that label is regexp-quoted - before being included in a regexp; otherwise, labels such as `c++' will - fail. - -Mon Sep 19 13:08:23 1994 Bob Weiner (bweiner@sun285) - -* hsite-ex.el (hpath:find-alist): Added .xpm suffix which invokes sxpm view. - -Wed Sep 14 18:52:33 1994 Bob Weiner (bweiner@sun285) - -* hypb.el (hypb:domain-name): Rewrote to not fork a grep process. - -Thu Sep 8 19:26:14 1994 Bob Weiner (bweiner@sun285) - -* hmouse-drv.el (smart-key-help-show): Nullified emacs-lisp-mode-hook when - help buffer is put into emacs-lisp-mode since if this hook turned on - font-locking in XEmacs 19.11, it could cause the editor to hang. - -Wed Aug 31 12:54:00 1994 Bob Weiner (bweiner@sun285) - -* hypb.el (require 'hact): Added for action: functions which are used in there. - This fixed a bug where Hyperbole was autoloaded, hvm.el was loaded and - then called hypb:function-overload which invoked action:params without - doing a (require 'hact). - -* README: - hypb.texi: - DEMO: Changed references to `Lucid Emacs' to `XEmacs', the new name. - -* hpath.el (hpath:is-p): A kotl link may be passed to this function. It - may contain multiple components following a comma after the pathname, so - strip this before checking pathname validity. - Otherwise, action:path-args-abs could trigger an error when trying to - expand a link pathname with an environment variable in it. - -Tue Aug 30 19:28:58 1994 Bob Weiner (bweiner@sun285) - -* hsite-ex.el (hpath:find-alist): Added support for .eps encapsulated - postscript files under X. - -============================================================================== -V3.16 changes ^^^^: -============================================================================== - -Mon Aug 29 00:04:11 1994 Bob Weiner (weiner@sun314) - -* README: Updated for V3.15 release. - -* DEMO: Explained that hsys-w3 is required to browse URLs. - Added paragraph on Cscope C/C++ analyzer output implicit buttons. - -* hpath.el (hpath:url-at-p): - (hpath:url-p): Added to test WWW URLs. - (hpath:ange-ftp-at-p): - (hpath:ange-ftp-p): - (hpath:www-at-p): - (hpath:www-p): Modified to invoke hpath:url functions and thereby - fixed to accept ftp URLs of the forms: - ftp:/anonymous@ftp.cs.uiuc.edu//pub/hyperbole. - http://www.fake.com:80/HomePage.html. - -Sun Aug 28 16:13:26 1994 Bob Weiner (weiner@sun314) - -* kotl/kotl-mode.el (kotl-mode:hide-body): - (kotl-mode:hide-tree): - (kotl-mode:show-all): - (kotl-mode:show-tree): Modified to work when buffer is - read-only so can change view but not edit buffer. - kotl/EXAMPLE.kotl: Explained use of view commands on read-only outlines. - -* kotl/kview.el (kview:delete-region): Modified to call delete-region. - -* kotl/kfile.el (kfile:read): Removed disable of auto-saving since V3 - outline buffer format can be auto-saved properly. - -* hui-menus.el (hui:menu-line): Added to build menu lines so that they - best fit within the width of the current frame. - (hui:menu-select): Modified to call hui:menu-line. - -* hpath.el (hpath:rfc): Added both a variable and a function under this name - to specify the location of Internet Request For Comments (RFCs). - Variable permits site-specific settings. - hactypes.el (link-to-rfc): Modified to call hpath:rfc. - hsite-ex.el: Added a comment describing site-specific hpath:rfc setting. - -* hvm.el: Rewrote to support newer versions of VM. Specifically modified to - match VM version "5.72 (beta)". (Isn't every VM version a beta?) - Upgrade your version of VM if earlier than this. - hyperbole.el: Re-enabled Hyperbole VM support. - -Fri Aug 27 17:41:28 1994 Bob Weiner (bweiner@sun285) - -* wconfig.el (wconfig-add-by-name): - (wconfig-delete-by-name): - (wconfig-restore-by-name): Added to handle window - configurations by name. - hui-menus.el (hui:menus): Added Win/ submenu for both name and ring wconfig - commands. - hyperbole.el: Added autoloads for new wconfig functions. Commented out key - bindings for wconfig commands since a larger set of commands is now - available through the Win/ menu. - hypb.texi: Documented new wconfig functions. - -Thu Aug 25 17:27:48 1994 Bob Weiner (bweiner@sun285) - -* set.el (set:replace): Added to replace elements in sets whose elements - look like (key . value). - (set:get): Added to return value associated with a key from a set. - -* hmouse-reg.el - hmouse-sh.el (sm-mouse-setup): - (sm-mouse-get-bindings): Modified to support 2-button mice - properly when GNU Emacs 19 with native NEXTSTEP support is run. - -============================================================================== -V3.15 changes ^^^^: -============================================================================== - -Tue Aug 16 13:28:01 1994 Bob Weiner (bweiner@sun285) - -* hactypes.el (link-to-file): Changed to allow non-existing paths so that - ange-ftp pathnames are not checked. - -Fri Jul 22 13:57:35 1994 Bob Weiner (bweiner@sun285) - -* hyperbole.el: Moved (require 'hversion) from hsite-ex.el to here so can - use hyperb:window-system value in here. - -* hibtypes.el (cscope): Added this new type to jump to source lines - associated with output from the USL cscope C/C++ flow analysis tool. - -Wed Jul 20 13:48:09 1994 Bob Weiner (bweiner@sun285) - -* hyperbole.el (hypb:read-only-smart-keys): - Changed oversight bug: - (define-key dired-mode-map smart-key-read-only 'smart-dired) - to: - (define-key dired-mode-map smart-key-read-only 'smart-key) - -Sat Jun 25 21:29:32 1994 Bob Weiner (weiner@sun314) - -* hmouse-drv.el (smart-key-operate): Added error message triggered if no - mouse support available, then drag actions cannot be performed, even from - the keyboard. - -Tue Jun 21 12:11:07 1994 Bob Weiner (weiner@sun285) - -* kotl/kotl-mode.el (kotl-mode:move-before): Fixed bug that caused failure - to renumber at location copied to. - -* kotl/kview.el (kview:set-label-type): Disabled partial-alpha label - selection since these don't work yet. - -* hui.el (hui:link-possible-types): Eliminated possibility of error if - user has (setq outline-regexp nil). - -Sun Jun 19 16:06:28 1994 Bob Weiner (weiner@sun285) - -* Makefile: Rewrote to use /bin/sh syntax instead of /bin/csh syntax. - -* hactypes.el (link-to-rfc): Updated to new standard RFC ftp site. - -* hargs.el (hargs:completion): Removed leading space from *Completion* - buffer name for Emacs V19. - -Thu Jun 16 01:04:49 1994 Bob Weiner (weiner@sun285) - -* hmouse-drv.el: Added (require 'hsite) to commands which may be - autoloaded to ensure that smart-key-alist from "hui-mouse.el" gets - defined and the rest of the Hyperbole system can be used. - -* hyperbole.el (hypb:read-only-smart-keys): Replaced old GNUS symbol names - with GNUS V4 ones. This was an oversight. - (defact): - (defib): Added autoloads for these so users can define own types. - -* hpath.el (hpath:www-at-p): Fixed regexp bug that could lead to extra - long invalid button labels. - README: Fixed format of WWW ftp: path so it would work properly. - -* hyperbole.el (load-path): Added an nreverse call after set:create to - keep it from reversing order of load-path entries. - -============================================================================== -V3.14 changes ^^^^: -============================================================================== - -* hversion.el (hyperb:version): Updated to V3.13. - -* Makefile: Added for automated install and rebuilding of Hyperbole. - MANIFEST: Added Makefile entry. - README: Updated installation instructions to use make. - hsite-ex.el: - hyperbole.el: Pointed readers to "README" for installation instructions. - -Wed Jun 15 00:48:51 1994 Bob Weiner (weiner@sun285) - -* hactypes.el (exec-shell-cmd): - (exec-window-cmd): If default-directory is a remote ange-ftp - pathname, don't try to cd to it before executing the shell command. - -* hpath.el (hpath:find): Fixed bug in handling pathnames that begin with - special character `&', which means execute the filename as a - window-based program. - (hpath:find-program): Added copy of remote ange-ftp pathnames - to local storage so that external viewer programs get a pathname that - they can reach. - -* kotl/kotl-mode.el (kotl-mode:fill-cell): - (kotl-mode:fill-paragraph): Added - (kotl-mode:to-valid-position) calls at end since point may otherwise - end up in a non-editable region of the outline. - -* hyperbole.el (vm-mode-hooks): Commented out Hyperbole support for Vm - since it doesn't work with current versions. - -Tue Jun 14 11:58:55 1994 Bob Weiner (weiner@sun285) - -* hactypes.el (exec-kbd-macro): Rewrote to translate Lucid Emacs events - into printable key sequence strings for storage as a macro definition. - But since Lemacs insert-kbd-macro function is broken as of V19.10, - this only works for certain macros under Lemacs. - -* hyperbole.el: Added (require 'hvar) so that var:append is defined. - -* hmouse-key.el: Moved common functions from "hmouse-sh.el" and - "hmouse-reg.el" back in here. No need to duplicate them. - -* hmouse-sh.el - hmouse-reg.el (sm-mouse-get-bindings): Fixed lemacs key names which - needed [] around them. - (sm-mouse-setup): Changed to only set - sm-mouse-previous-bindings (mouse key bindings prior to Hyperbole use) - if not already set. - -Mon Jun 13 12:44:18 1994 Bob Weiner (weiner@sun285) - -* README: - DEMO: Changed Hyperbole ftp location from `wilma' to `cs.uiuc.edu'. - -============================================================================== -V3.13 changes ^^^^: -============================================================================== - -Fri Jun 10 00:13:31 1994 Bob Weiner (weiner@sun285) - -* kotl/kotl-mode.el (kotl-mode:move-before/after): Added error check if - try to move a tree to within itself. - -* kotl/kotl-mode.el: Fixed bug in many next/prev type commands that did - not change a negative arg sent to the next command to a positive arg - when sent to the prev command for handling. - -* kotl/kview.el (kview:default-label-min-width): Raised from 3 to 4 so - that idstamps up to 0999 display correctly in level 1 cells. - (kcell-view:operate): Changed first arg from an - sexpression to a function so can byte-compile the function passed in. - -Wed Jun 8 18:44:01 1994 Bob Weiner (weiner@sun285) - -* kotl/kotl-mode.el (kotl-mode:kill-tree): Added an optional arg, the - number of trees to kill forward from point. - (kotl-mode:first-cell-p): Added. - (kotl-mode:last-cell-p): Added. - -Tue Jun 7 18:39:39 1994 Bob Weiner (weiner@sun285) - -* hyperbole.el: Moved message system hook settings here from hsite-ex.el - so that they are activated if Hyperbole is autoloaded. - -Sat Jun 4 17:12:15 1994 Bob Weiner <weiner@infodock.com> - -* kotl/kotl-mode.el (kotl-mode:exchange-cells) - (kotl-mode:transpose-cells): Added. - (kotl-mode-map): Added {C-c e} and {C-c t} key - bindings for these new commands. - -* kotl/kview.el (kcell-view:contents): Rewrote to handle collapsed cells. - (kcell-view:expand): Added to expand cell contents. - -* kotl/kotl-mode.el (kotl-mode:insert-buffer): - (kotl-mode:insert-file): - Added to overload standard functions. - -Thu Jun 2 19:40:56 1994 Bob Weiner (weiner@sun285) - -* hargs.el (hargs:iform-read): Added support for `@' and `_' initial - interactive specification characters. - -* kotl/kotl-mode.el (kotl-mode:copy-to-register): - (kotl-mode:insert-register): - Added to overload standard functions. - - Also added (setq zmacs-region-stays t) to movement commands so they - do not deselect the region under Lemacs. - -Wed Jun 1 21:47:33 1994 Bob Weiner (weiner@sun285) - -* hbdata.el (hbdata:apply-entry): Rewrote this function and its calls to - pass in a function rather than an sexpr, so the function body can be - byte-compiled. - - Also fixed so that mail conditionals are only tested - if key-src is a buffer, which implies source buffer is a mail or news - buffer. This prevents these conditionals from triggering when a - global button is invoked from a mail/news buffer, since its key-src - will be a buffer name, not a buffer. - -* hui.el (hui:link-directly): Removed item-array internal variable which - was being used improperly as an obarray into which symbols were - interned. This caused the function to fail whenever there were two or - more link type possibilities. - -* hib-doc-id.el (link-to-doc): Added error message for user feedback if an - online document path is found but the path is invalid. - -Mon May 30 00:36:56 1994 Bob Weiner (weiner@sun285) - -* kotl/kotl-mode.el (kotl-mode:transpose-chars): - (kotl-mode:transpose-words): - Added to overload standard functions. - -* hmouse-drv.el (smart-key-mouse): - (smart-key-mouse-meta): Make this a no-op if some local mouse - key binding overrode its associated global depress binding so that the - Smart Keys do not interfere with local bindings. - -* hmouse-sh.el - Added to bind Smart Keys to shift-middle and shift-right. - hmouse-reg.el - Renamed from hmouse-key.el; can be used instead of - hmouse-sh.el to bind Smart Keys to middle and right mouse buttons. - hmouse-key.el - Wrapper file which loads hmouse-sh.el by default. - hypb.texi - Updated to reflect shift Smart Key bindings. - -* DEMO - Rewrote to use Action and Assist Key terminology. - -Wed May 18 19:35:23 1994 Bob Weiner (weiner@sun285) - -* hsite-ex.el (hpath:find-alist): Added display support for the following image - file formats using the `xv' program: gif, tiff, xbm, pm, pbm, and jpeg. - Added a blurb about this in "DEMO". - -Tue May 17 19:05:43 1994 Bob Weiner (weiner@sun285) - -* hui-window.el (sm-mouse-x/y-coord): Modified emacs19 section to use - posn-col-row since event reporting changed from character positions to - pixels in V19.23. - -Mon May 9 12:22:16 1994 Bob Weiner (weiner@sun285) - -* hmouse-drv.el: Added (require 'hypb) since hypb:window-list is called in here. - -Sun May 8 14:16:34 1994 Bob Weiner <weiner@infodock.com> - -* hversion.el (sm-window-sys-term): - (hyperb:window-system): Moved from "hmouse-key.el" so would - not have to load that library to determine the window system or term - type under which Hyperbole is run. - -* hyperbole.el: Centralized all Hyperbole system autoloads here. - Moved message system and window configuration autoloads from - "hinit.el" to here. Moved Smart Key autoloads from "hui-mouse.el" to - here. Moved key bindings from "hsite-ex.el" here so only need to load - "hsite.el" if a Hyperbole command is invoked, either from the mouse or - the keyboard. - -* kotl/: Replaced V2 koutliner with V3, largely rewritten internally for - reliability and speed. - -Mon May 2 18:44:35 1994 Bob Weiner (weiner@sun285) - -* hpath.el (hpath:ange-ftp-at-p): - (hpath:ange-ftp-p): Fixed bug that allowed whitespace and - other characters in user name to match. This came out when W3 link - names matched as ange-ftp paths. - -Tue Apr 19 18:30:14 1994 Bob Weiner (weiner@sun285) - -* hui-window.el (sm-mouse-x/y-drag-sensitivity): Upped to 5 and 3 - respectively since novice users would inadvertently split windows via - drags when they were trying to click and then would have no idea what - they did. All they knew was that they didn't like the result. This - makes it harder for such problems to occur. - -Wed Apr 13 17:07:10 1994 Bob Weiner (weiner@sun285) - -* hmouse-doc.txt: - hmouse-tag.el: - hypb.texi: Updated doc for smart-asm, smart-c and smart-c++ to - reference include-dir variables so that users will have some way to know - to set them. - -Thu Apr 7 17:20:06 1994 Bob Weiner (weiner@sun285) - -* hmouse-drv.el (smart-key-meta-help): Fixed bug in its interactive spec. - -* MANIFEST: - hsys-w3.el: Added to support following of URLs (WWW links) from any buffer. -* hpath.el (hpath:www-at-p): Added optional include-start-and-end-p flag - for use in hsys-w3.el. - -Mon Apr 4 00:33:53 1994 Bob Weiner (weiner@sun285) - -* hui-mouse.el (smart-key-alist): Added clause to handle tag lookup in - assembly language, asm-mode. - hmouse-tag.el: Added functions to support assembly-language tag lookup. - -Thu Mar 31 11:28:59 1994 Bob Weiner (weiner@sun285) - -* hyperbole.el: Since the kotl/ subdirectory is added to the load-path, - there is no need to include it within autoload definitions, so it was - removed. - -Wed Mar 30 11:02:42 1994 Bob Weiner (weiner@sun285) - -* hsys-wais.el: Changed load of wais library to an autoload. - -* hypb.texi (Smart Keys): Added description of `smart-key-other-mode-cmd' - and `smart-key-meta-other-mode-cmd' variables. - -* hib-doc-id.el: - hui-window.el: - hui-mouse.el: - hui-menus.el: - hsys-hbase.el: - hsite-ex.el: - hmouse-mode.el: - hmouse-key.el: - hmouse-drv.el: -* hmouse-doc.txt: Renamed primary Smart Key to Action Key and secondary - Smart Key to Assist Key. -* hypb.texi (Smart Keys): - hsite-ex.el: Moved key binding showing Action and Assist Key - context-sensitive behavior from {C-h S} to {C-h A} for mnemonic - reasons. Left old binding for now for backward compatibility. - - -Mon Mar 28 01:03:56 1994 Bob Weiner (weiner@sun285) - -* hui.el (hui:gbut-modify): Added to modify global buttons. - (hui:ebut-modify): Fixed bug when called interactively button - label was not converted to a lbl-key. - -* kotl/kview.el (kview:update-label): Fixed to remove `*' labels when - 'bullet label type has been selected. - -* kotl/kotl-mode.el (kotl-mode): Added keymap description to documentation. - (kotl-mode:kcell-help): Made `cell-ref' arg optional. - -* hmouse-key.el (sm-mouse-setup): Fixed typo in Emacs19 binding. Changed - 2nd occurrence of double-mouse-2 to triple-mouse-2. - -* kotl/kotl-mode.el (kotl-mode:mail-tree): Added to mail an outline tree, - which can be the whole outline. Bound to {C-c @}. - -Sun Mar 27 21:11:27 1994 Bob Weiner (weiner@sun285) - -* hmail.el (hnews:composer): - (hnews:lister): - (hnews:reader): - (hmail:composer): Set these to standard defaults. Invocation - of a different tool will override them. - (hmail:buffer): Added. Inserts a buffer into the mail composer. - (hmail:invoke): Added. Invokes user-specific mail composer. - -* kotl/kview.el (kcell-view:get-attr): - (kcell-view:set-attr): Added these to get and set cell - attributes within a view. - -* kotl/kotl-mode.el (kotl-mode): Added a `widen' call to ensure that - narrowed but unformatted kotl file is recognized, e.g. when switch a - kotl buffer to another mode and then re-invoke kotl-mode. - -* kotl/kview.el (kview:insert-contents): - (kview:fill-region): Fixed to fill multi-paragraph - cells properly. - -Sat Mar 26 15:22:50 1994 Bob Weiner (weiner@sun285) - -* kotl-mode.el (fill-paragraph): Added this to list of functions overloaded - in kotl-mode. - -Mon Mar 21 18:42:07 1994 Bob Weiner (weiner@sun285) - -* hsite-ex.el (hpath:find-alist): Added viewer programs under X for - X window dumps (.xwd), Sun rasterfiles (.rs), Frame documents (.fm, - .frame), and Interleaf documents (.doc, .boo). - -Fri Mar 18 15:32:39 1994 Bob Weiner (weiner@sun285) - -* hargs.el (hargs:delimited): Modified to take an optional third flag - parameter which if non-nil says to treat first 2 args as regexps. - -Thu Mar 10 03:42:09 1994 Bob Weiner (weiner@sun285) - -* kotl/kfile.el (kfile:find): - (kfile:view): Modified to validate suffix on filename - argument when called interactively. - -* DEMO: Changed HTML ftp pathname to proper format. - -============================================================================== -V3.12 changes ^^^^: -============================================================================== - -Wed Mar 9 02:13:32 1994 Bob Weiner (weiner@sun285) - -* hibtypes.el (grep-msg): Added support for BSO/Tasking 68HC08 C - cross-compiler error messages. - -Tue Mar 8 12:12:18 1994 Bob Weiner (weiner@sun285) - -* wrolo.el (rolo-display-matches): Improved code and fixed bug under Lucid - Emacs which permitted display of rolodex buffer in some screen other - than the selected one. Had to conditionalized for Lucid Emacs since - it requires an optional parameter to pop-to-buffer to limit it to the - selected screen. - (rolo-kill): Rewrote to remove compiler warnings. - -* hyperbole.el: Added autoloads for all commands called from Hyperbole - Otl/ menu. Also added signalling of error if outline-specific - commands are invoked from the menu when not within an outline buffer. - -* hibtypes.el (elisp-compiler-msg): Added support for byte-compile-buffer - command available with Lucid Emacs byte-compiler. -* hactypes.el (link-to-regexp-match): - (link-to-string-match): Added optional buffer-p argument - which allows passing a buffer or buffer-name argument, rather than a - filename. - -* hbut.el (hbut:label): Added to return the label of a Hyperbole button. - Helpful in implicit button help functions. - -Mon Mar 7 17:12:14 1994 Bob Weiner (weiner@sun285) - -* hibtypes.el (elisp-compiler-msg): Added to jump to the source of an - Emacs Lisp V19 byte-compiler error message. - -Mon Mar 7 00:14:07 1994 Bob Weiner <weiner@infodock.com> - -* hactypes.el (exec-shell-cmd): Modified to ensure that when a new shell - is started, it is displayed in a window other than the current one. - -Sun Mar 6 13:56:20 1994 Bob Weiner <weiner@infodock.com> - -* kotl/kotl-mode.el (kotl-mode:delete-line): - (kotl-mode:first-line-p): - (kotl-mode:last-line-p): - (kotl-mode:transpose-lines-internal): - (kotl-mode:transpose-lines): - Added for use in kotl-mode:transpose-lines command. - - (kotl-mode:forward-char): Fixed bug that allowed - movement of point one character beyond the end of the last cell. - -* kotl/kview.el (kview:valid-position-p): Renamed from - kotl-mode:valid-position-p since is view-specific, not mode-specific. - (kcell-view:line): Added, returns contents of a kcell line. - -* kotl/kotl-mode.el (kotl-mode:valid-position-p): Added optional POS - argument so can test validity of positions other than point, e.g. - mark. - -* kotl/kview.el (kcell-view:forward): Fixed bug that moved point to last - cell of subtree when a following cell at same level was not found. - -* kotl/kotl-mode.el (kotl-mode:delete-horizontal-space): - (kotl-mode:delete-blank-lines): - (kotl-mode:just-one-space): - (kotl-mode:zap-to-char): - Added to overload standard functions. These functions apply only to - the current cell. - (kotl-mode:to-valid-position): Fixed bug which skipped - past valid positions containing space characters. - -Thu Mar 3 19:15:36 1994 Bob Weiner (weiner@sun285) - -* hbut.el (ebut:label-p): Fixed a bug that could cause forward search to - occur after point had past the search bound already, triggering an - error. - -Wed Mar 2 15:32:16 1994 Bob Weiner (weiner@sun285) - -* hactypes.el (exec-window-cmd): Fixed so display does not change when - shell is started and sit-for is reached. Also, ensured that message - describing the command executed stays around through the end of the - action. - -* hypb.el (hypb:window-list): Fixed bug under Emacs 19 that caused some - window side drags to fail since windows in all frames were considered. - Now considers only those in current frame. Use new function - `hypb:window-list-all-frames' when you want all existing windows. - -Sun Feb 27 18:02:24 1994 Bob Weiner (weiner@sun285) - -* hui.el (hui:buf-writable-err): Added conditional to deal with - vc-toggle-read-only key binding in Emacs V19. - Also, removed check for unwritable file, since since some people want - to be able to create buttons within files which they have purposely - marked read-only. - -* hmail.el (hmail:compose): Slight mod to send arguments to mail functions - when possible, rather than inserting them into the mail buffer. - (hmail:init-function): Added this variable. Setting it tells - hactypes::link-to-mail which mail reader to use, if user has not - already invoked one. See its documentation for valid values. - -Thu Feb 24 16:37:09 1994 Bob Weiner (weiner@sun285) - -* hui-mouse.el (smart-key-alist): Added support for w3-mode, - world-wide-web browsing. - -* hibtypes.el (annot-bib): Updated to only match buttons within buffers - with attached files. - -* hmouse-key.el: - hui-mouse.el: - hui-window.el: Removed all references to hyperb:lemacs-early-p since - no one should have such an early version of Lemacs anymore. If they - do, they should upgrade. - -* hsite-ex.el: (hyperb:lemacs-p) - (hyperb:emacs19-p) - (hyperb:epoch-p): Moved definitions to hversion.el so - can use these settings without loading all of Hyperbole. Also - eliminated need to duplicate them in "hmouse-key.el". - hypb.el: Added (require 'hversion) since it uses the variables set there. -* hyperbole.el: Added autoloads for all wrolo commands. This allows - removal of (require 'wrolo) in hui-menus.el. - -Wed Feb 23 00:41:39 1994 Bob Weiner (weiner@sun285) - -* hyperbole.el (hyperb:kotl-p): Fixed test for Lemacs 19.9 or above. - -Tue Feb 22 19:24:11 1994 Bob Weiner (weiner@sun285) - -* kotl/kotl-mode.el (kotl-mode:update-buffer): Added explicit setting of - window-start to fix bug that sometimes causes window-start to change - when a save of an outline is done. - -Mon Feb 21 12:06:16 1994 Bob Weiner (weiner@sun285) - -* hui-le-but.el - hui-em19-b.el (le:cycle-but-color): - (le:but-flash): - (ep:select-line): - (le:select-item): Changed sit-for to wait for 0 seconds - to avoid any floating point issues. - -* kotl/klink.el (klink:at-p): Added a check to prevent matches to e-mail - addresses like <user@domain>. - -Tue Feb 15 11:08:10 1994 Bob Weiner (weiner@sun285) - -* hui-em19-b.el (le:background): - (le:foreground): Modified to deal with bug in GNU Emacs - 19.22 which returns nil for default font background and foreground - colors. - -* hsmail.el (mail-yank-original): Updated to work pretty much as Emacs 19 - does with yank and citation hooks. - -Mon Feb 14 16:04:54 1994 Bob Weiner (weiner@sun285) - -* hsite-ex.el (hpath:find-alist): Added sample Postscript file viewer under X. - -* hpath.el (hpath:find-program): Modified to permit filename use within - the middle of the program command if program includes %s in its string. - (hpath:find): Modified to accept hpath:find-program result - which now includes entire program invocation line. - -Tue Feb 8 09:57:51 1994 Bob Weiner (weiner@sun285) - -* hui.el (hui:hbut-help): Made ibtypes with their own :help functions - automatically flash their buttons when selected, if their type - definitions indicate a button label. -* hbut.el (htype:names): Fixed bug in which arg `sym' was handled - improperly when it contained a type category prefix. This showed up - when doc-id ibtypes did not show their card catalog entries as part of - their doc-id:help command. - (hbut:report): Attributes are now stored in reverse order, so must - print them all in report, rather than trying to hide internal - attributes as before. - -Mon Feb 7 18:01:43 1994 Bob Weiner (weiner@sun285) - -* kotl/kfile.el (kfile:narrow-to-kcells): Conditionalized so is a no-op if - called in a non-outline buffer. This allows it to be used in - `after-save-hook'. -* kotl/kotl-mode.el (kotl-mode:add-cell): Added 2nd optional argument, - contents, so can fill in contents at create time. - (kotl-mode:split-cell): Rewrote to not use kill ring. - (after-save-hook): Set to call kfile:narrow-to-kcells - to ensure that view is always narrowed properly after a save. - (Without this, if a save is done right after a cell is added at the - end of a kotl, the view is not narrowed properly, due to some problem - with save-restriction in basic-save-buffer. - -Thu Feb 3 14:13:00 1994 Bob Weiner (weiner@sun285) - -* kotl/kfile.el (kfile:update): Added visible-only-p option and turned - narrowing of view off by default since this interfered with saving an - outline. - (kfile:narrow-to-kcells): Made this interactive so could be bound to a - key in case view is ever widened so that structure data is showing. - This will narrow the view properly. - (kfile:narrow-to-kcells): Stopped this from moving point. - -Wed Feb 2 00:43:33 1994 Bob Weiner <weiner@infodock.com> - -* kotl/kimport.el: Added to import other tree-structured file formats into - outlines. Initial support for Emacs `*' outlines and Augment files - with cell numbering after each cell (post-cell numbering). - kotl/MANIFEST: Added kimport.el entry. - hyperbole.el: Added autoloads for kimport public functions. - -* hmouse-tag.el (smart-tags-file): Added call to smart-emacs-lisp-mode-p - for generality. - -* kotl/kfile.el (kfile:write): Added interactive spec. and setting of view - buffer name. - (kfile:save): Deleted. Use save-buffer instead. - (kotl-mode:write): Deleted. Use kfile:write instead. - kotl/kview.el (kview:set-buffer-name): Removed call to rename-buffer, - this is done elsewhere. This fixes bug that gives you a buf<2> buffer - name after doing a kfile:write. - -* kotl/kotl-mode.el (write-contents-hooks): Set this hook to update - outline structure whenever a save-buffer is done. - (kotl-mode:update-buffer): Added this function and - used in write-contents-hooks. - (kotl-mode:save-buffer): Deleted this function. Use - normal save buffer now. - -* kotl/kfile.el: (kfile:update): Added to update file structure in - preparation for file save but does not do a save. Appropriate for - use in write-contents-hooks. - -* kotl/kotl-mode.el (kotl-mode:split-cell): Added to split a cell in two - and to move to new cell and bound to {C-c s}. - (kotl-mode-map): Moved `kview:set-label-type' off {C-c - s} to {C-c C-l}. - kotl/EXAMPLE.kotl: Changed references of {C-c s} and {C-c C-l}. - hypb.texi: Changed same key bindings and added doc for - kotl-mode:split-cell. - -* kotl/kotl-mode.el (kotl-mode:save-buffer): Renamed to this from - kotl-mode:save and overloaded standard Emacs function. - -* hpath.el (hpath:ange-ftp-p): - (hpath:ange-ftp-at-p): - (hpath:at-p): - (hpath:is-p): Modified to ignore non-ftp (other - protocol) WWW link refs. - (hpath:www-at-p): - (hpath:www-p): Added these two functions to detect WWW - link refs. - (hpath:absolute-to): - (hpath:substitute-var): - (hpath:relative-to): Modified to only change paths for which - `hpath:is-p' is true. - (hpath:validate): Modified to reject WWW link refs. - -* kotl/klink.el (klink:create): Fixed bug which removed directory before - creating a klink to a referent in a directory different than the klink - source. -* hargs.el (hargs:at-p): Added use of default-dir when reading a klink arg. - -Tue Feb 1 21:32:51 1994 Bob Weiner <weiner@infodock.com> - -* kotl/kview.el (kview:idstamp-to-label): Added to convert idstamp to its - relative label within current view. - -* kotl/kotl.el (kcell:ref-to-id): Fixed minor doc errors. - -* kotl/klink.el (klink:at-p): Added to test if point is within a klink. - Used within klink implicit button type. - (klink:act): - (klink:replace-label): - (klink:update-label): Added these functions to allow - automatic updating of cell labels (relative ids) within - klinks whenever a klink is activated. - -Mon Jan 31 13:59:24 1994 Bob Weiner (weiner@sun285) - -* hpath.el (hpath:symlink-referent): Simplified and fixed bug that led to - a/b/b/c pathname in a button link when a/b/c was the target. Changed - interface to *not* expand pathnames that are not links. - -* hypb.texi (Outliner Keys): Deleted descriptions of overloads of standard - emacs editing keys. These are transparent to the user. - -* hypb.el (hypb:copy-sublists): Added to make deep copies of lists for use in - the outliner. - -* kotl/kotl.el (kcell:copy): Added this function to copy a kcell. -* kotl/ktree.el (knode:copy): Added this function to copy a knode. - -============================================================================== -V3.12-pre-release changes ^^^^: -============================================================================== - -Sat Jan 29 12:04:15 1994 Bob Weiner (weiner@sun285) - -* hypb.texi - Updated with references and documentation on the outliner. -* README - Updated Hyperbole description to conform to hypb.texi. - -Thu Jan 27 20:52:28 1994 Bob Weiner (weiner@sun285) - -* hbut.el (ibut:label-set): Fixed bug that prevented setting of lbl-start - and lbl-end when all args are sent as a single list, as the doc explains. - (ibut:at-p): Fixed bug that prevented display of implicit button - help. (hattr:clear) was called when `key-only' argument was t, in - which case new button attributes were not generated, leaving the - button without any attributes. - -* README: Updated What's New section for V3.11 release. - -* DEMO (Outliner): Added new section pointing to outliner documentation. - -Wed Jan 26 12:08:40 1994 Bob Weiner (weiner@sun285) - -* hmouse-key.el (sm-mouse-get-bindings): - (sm-mouse-setup): Added Smart Key bindings of - {double,triple}-mouse-{2,3} for double and triple clicks. - (sm-release-args-emacs19): Added support for double and - triple clicks. - -* hpath.el (hpath:relative-to): Modified to handle "../path" and - "../../path" cases. - -* hargs.el (find-tag-default): Replaced with a new version from V19 etags.el. - -Tue Jan 25 18:36:52 1994 Bob Weiner (weiner@sun285) - -* hsite-ex.el - Added (require 'hyperbole). - -* hargs.el (hargs:iforms): Added ?L entry - Get a kcell or path - reference for use in an implicit <link>. - (hargs:at-p): Added klink direct selection type. - -* hyperbole.el (hyperb:kotl-p): Added this variable. Non-nil value means - koutline support is available. - -Sun Jan 23 12:50:24 1994 Bob Weiner (weiner@sun285) - -* hypb.texi - Added descriptions of ibtypes::klink, - actypes::link-to-kotl and actypes::link-to-kcell. - -* hui-le-but.el - le:but-add - Rewrote to ignore set-extent-face return - value since what it returns is not documented. - -* hmouse-tag.el - smart-tags-file - Fixed so will work even if given a nil - or directory argument. - -* hui-mouse.el - smart-key-alist - Fixed bug that prevented invocation of - c++-mode clause when on a #include line in a C++ buffer. - -* hactypes.el - exec-window-cmd - Added a (sit-for 1) when shell is - started so that commands will not be sent before it starts up, as has - been reported by a user. - -* hbdata.el - hbdata:apply-entry - Removed save-restriction which worked - improperly when button data buffer was modified because of a button - deletion. Instead added an (hmail:editor-p) conditional which hides - button data in mail and news composition buffers. - -* hypb.el - hypb:domain-name - Added (getenv "DOMAINNAME") to allow manual - setting of Internet domainname for systems which do not have proper - configurations, such as my own. cs.uiuc.edu would be a valid setting - for this variable, for example. - -Wed Jan 19 15:50:16 1994 Bob Weiner (weiner@sun285) - -* hactypes.el - exec-window-cmd - Changed `save-excursion' to - `save-window-excursion' so that shell buffer is not displayed. - -* hpath.el - hpath:prefix-regexp - Added so can add command prefix - characters to pathnames. - - hpath:is-p - Fixed to deal with command prefix chars. - -Thu Jan 13 17:11:39 1994 Bob Weiner (weiner@sun285) - -* hactypes.el - exec-window-cmd - Made command run in background. - -Tue Jan 4 11:30:49 1994 Bob Weiner (weiner@sun285) - -* MANIFEST - Added pointers to kotl/MANIFEST and kotl/SAMPLE.kotl. -* kotl/ - Added this subdirectory with outliner support code and its own MANIFEST. - -* hibtypes.el - klink - Added conditional require of "kotl/klink.el" to provide - implicit links to kotl cells. - -* hactypes.el - link-to-Info-node - Fixed so never displays Info in more than - one window. - -Mon Jan 3 15:20:22 1994 Bob Weiner (weiner@sun285) - -* hui-menus.el - hui:menus - Moved Types/ menu from top-level to below - Doc/ menu. Moved Types/DeleteIButType to Ibut/DeleteIButType. - - Added Otl/ menu. - - Added Info entries to menus for rapid access to - appropriate Hyperbole manual section. - -* DEMO - Added sections on: Grep, Occurrence, GDB and Compiler Error Buttons. - Completion Buttons. - -* hyperbole.el - auto-mode-alist - Added .kotl setting. - - kfile:find, kfile:view, kotl-mode - Added autoloads. - -* hsite-ex.el - hpath:find-alist - Fixed so Emacs19 under NEXTSTEP is - configured with NEXTSTEP file suffix alist. - - Added section labels for each section of this file. - - Added "kotl/", koutline subdirectory, to load-path. - -Fri Dec 31 15:59:41 1993 Bob Weiner (weiner@sun285) - -* hpath.el - hpath:substitute-var-name - Changed so only does variable - replacement when given an absolute path to test against, since relative - paths can cause too many undesirable results. - -* hpath.el - hpath:substitute-dir - Added conditional that prevents error if - VAR-NAME value is a list which contains nil entries as sometimes happens - with variables such as exec-path. - -Wed Dec 29 11:40:46 1993 Bob Weiner (weiner@sun285) - -* hpath.el - hpath:ange-ftp-at-p - hpath:ange-ftp-p - Added support for WWW ftp path format: - ftp://[<user>@]<domain><path> - -* hmouse-tag.el - Fixed bug in require of etags for Emacs V19. - -* hbut.el - htype:body - Fixed bug that triggered error when nil argument was - sent. This prevented the use of regular Emacs Lisp functions in - Hyperbole actions (calls to `hact'). - - ibut:at-p - Fixed bug that assumed all actype args were Hyperbole - action types. - -* hypb.texi - Action Types - Added description of Hyperbole interactive - command extension `K', which takes a kcell identifier. - -============================================================================== -V3.11 changes ^^^^: -============================================================================== - -Sun Nov 21 16:03:54 1993 Bob Weiner <weiner@infodock.com> - -* hpath.el - hpath:find - hpath:find-other-window - Extended to support `-', `!', `&' - special prefix characters in front of pathnames. - -* hui.el - hui:link-directly - hui:htype-help - Changed use of `variable-documentation' to - `documentation' since Hyperbole types are now defined as functions. - This was visible as a bug when trying to display the doc for any type, - no output would appear. - -* hypb.texi - Smart Keyboard Keys - Added Smart Key reference description - for kotl-mode. - -Sat Nov 20 16:54:21 1993 Bob Weiner <weiner@infodock.com> - -* hargs.el - hargs:get - Fixed to allow interactive command characters to - return nil without signalling an error, e.g. when reading the prefix - argument. - -Sun Nov 14 16:38:26 1993 Bob Weiner <weiner@infodock.com> - -* hui.el - hui:link-possible-types - Added link-to-kcell context for use - with kotl-mode. - hactypes.el - link-to-kcell - Added. - -Fri Nov 12 14:33:31 1993 Bob Weiner (weiner@sun285) - -* hmouse-key.el - sm-window-sys-term - Added support for Emacs variants - running with mouse support under the Display Postscript (DPS) window - system, notably NEXTSTEP. - -* hvm.el - Vm-Summ-goto - Changed from a `defun' to an `fset' which is - what it should have been. This was visible as a bug when a primary - Smart Key click in a VM summary buffer did nothing. - - Vm-Summ-delete - Added call to (vm-follow-summary-cursor) so - that message summary line clicked upon is the one that is deleted. - -Thu Nov 11 12:33:04 1993 Bob Weiner (weiner@sun285) - -* hvm.el - Vm-msg-start-regexp - Renamed from Vm-msg-start-string. Made - it a regexp and added support for MMDF folders. - -* Replaced all remaining '(lambda) expressions with (function (lambda)) - so that they can be byte-compiled. - -Wed Nov 10 18:17:38 1993 Bob Weiner (weiner@sun285) - -* hmouse-tag.el - smart-lisp-at-tag-p - Made more descrinating in its - matching of `def' constructs. Prevented falses on terms like - `define-key'. - -* hui-menus.el - hui:menu - Rewrote once again in a simpler fashion. - Should solve problems of error messages sometimes showing up only as - "error". - - hui:menu-mode-map - Added key binding for left mouse - button under Lemacs since default binding is broken under V19.8. - -* htz.el - htz:zone-to-hour - Fixed to deal with V19 current-time-zone - function which returns a list. Also added error message if called with a - null argument (used to return 0 in this case which would just cover up - timezone problems). - -* hargs.el - hargs:iforms - Modified `I' component to utilize - V19 Info-directory-list if bound. - -Tue Nov 9 19:08:05 1993 Bob Weiner (weiner@sun285) - -* hui-em19-b.el - Added color support for GNU Emacs 19 under NEXTSTEP (the - Display Postscript window system). - -* hmouse-tag.el - smart-c - smart-c++ - Fixed bug that caused immediate return if - non-nil `identifier' was sent in when function was called. - - smart-c - smart-c++ - smart-lisp - Changed so that `tags-file-name' is set - globally so that next `find-tag' command uses the same tags file. - -Wed Oct 20 10:47:25 1993 Bob Weiner (weiner@sun285) - -* hibtypes.el - grep-msg - Added condition-case and call of - compilation-parse-errors with 2 args for GNU Emacs 19 compatibility. - -Thu Oct 14 16:01:07 1993 Bob Weiner (weiner@sun285) - -* hui-le-but.el - le:but-face - le:flash-face - Changed internal face name of these - variables to match variable name. - -* hsite-ex.el - hinit.el - hyperb:init - Removed find-file-hooks setup of button - highlighting and moved it to hsite-ex.el so that it may be customized - for a site. - -Thu Oct 7 11:10:15 1993 Bob Weiner (weiner@sun285) - -* hact.el - action:commandp - action:params - Rewrote to handle autoload functions. - -* hypb.el - hypb:indirect-function - Added and replaced all calls to - `symbol-function' in Hyperbole with this instead, so if symbol has - more than one level of indirection, things will work. - -* hypb.el - hypb:debug - Updated to deal with V19 byte codes. - -Wed Oct 6 11:41:23 1993 Bob Weiner <weiner@infodock.com> - -* hactypes.el - hyp-config - Fixed bug that had wrong major mode for MH mail - reader. - -Sat Oct 3 18:03:11 1987 Bob Weiner <weiner@infodock.com> - -* hargs.el - hargs:action-get - hact.el - action:commandp - Fixed bug that prevented these from working - with Emacs V19 byte compiled code. Users saw this bug when they were - not prompted for necessary arguments during explicit button creation. - -* hbut.el - htype:names - htype:create - Modified to use obarray. - - htype:category - Added to return all type symbols within a - category. - - htype:symbol - Added to encapsulate htype symbol creation. - - htype:body - Added to return action part of an htype. - - hbut:action - ibut:at-p - Modified to use new implicit button type defs. - - defib - Modified to use new version of htype:create. - - symset:get - Added to return a symbol set. - hact.el - defact - Modified to use new version of htype:create. - -Thu Sep 30 11:01:10 1993 Bob Weiner <weiner@infodock.com> - -* hibtypes.el - grep-msg - Added support for Introl 68HC11 compiler and - assembler errors. - -Fri Sep 24 12:58:26 1993 Bob Weiner <weiner@infodock.com> - -* hui-epV4-b.el - ep:but-flash - Changed `extent-at' to `button-at' which is - the right function for epoch. - -Wed Sep 22 08:56:28 1993 Bob Weiner <weiner@infodock.com> - -* hypb.el - hypb:mark-marker - Fixed definition for Emacs V19. - -Tue Sep 21 12:23:36 1993 Bob Weiner <weiner@infodock.com> - -* hui-em19-b.el - Added to support Hyperbole button highlighting and - flashing under GNU Emacs V19. - MANIFEST - hui-em19-b.el - Added summary. - hinit.el - hyperb:init - Updated to add ep:but-create to - find-file-hooks for Emacs V19. - hsite-ex.el - hyperb:emacs19-p - Added conditional clauses to set up - button highlighting and flashing options. - -============================================================================== -V3.10 changes ^^^^: -============================================================================== - -Tue Sep 21 12:23:36 1993 Bob Weiner <weiner@infodock.com> - -* hinit.el - Added require of 'hui since had removed this from - hui-menus.el so that it could be loaded independently of hui.el. - -* hbut.el - htype:create - Updated to support byte-compiling of values - within property-list which are functions. - - ibtype:create - Changed to support modified htype:create. - - ibut:at-p - Changed `eval' of at-p to `funcall' to support - modified htype:create. - hact.el - action:create - Quoted lambda expression with a 'function wrapper - so that V19 byte compiler will compile action code. - - actype:act - Added hypb:v19-byte-code-p call to handle V19 - byte-compiled actions. - - hact - Modified to handle V19 byte-compiled actions. - - actype:create - Eliminated local variables and changed to - support modified htype:create. - -* hactypes.el - hib*.el - hsys-*.el - Byte-compiled to use new hact, defact, and defib macros. - -============================================================================== -V3.09 changes ^^^^: -============================================================================== - -Thu Sep 16 13:15:18 1993 Bob Weiner <weiner@infodock.com> - -* hlvar.el - hack-local-variables - Fixed bug I had introduced which used - improper (match-beginning 0) expression. Needed to save this value - in a (let) instead. - -Wed Sep 15 14:43:04 1993 Bob Weiner <weiner@infodock.com> - -* hactypes.el - link-to-mail - Handled error where mail reader has not been - invoked so link-to-mail does not know which mail reader to use to display - the linked message. - -* hpath.el - hpath:is-p - Fixed bug manifested in hui:link-possible-types - which allowed a string such as "this is a string" to match as a pathname. - This was due to the fact that in general, we want to allow spaces in - pathnames. - -* hui.el - hui:ebut-unmark - Modified so that if explicit button delete - command is called with a prefix argument, then the button label is also - deleted from the text. (Normally only the button delimiters are removed.) - -* hui-menus.el - hui:menu-lemacs - Added this function to convert from - Hyperbole menu format to Lucid Emacs menus format. Thanks to Guido - Bosch for the idea. - -* hui-epV4-b.el - ep:but-flash - Rewrote so works for explicit buttons - (worked only for implicit buttons before). - hui-le-but.el - le:but-flash - Rewrote so works for explicit buttons - (worked only for implicit buttons before). - hsite-ex.el - le:but-emphasize-p - Added under Lemacs conditional to - emphasize explicit buttons when the mouse pointer moves over them, if set - to non-nil. - -Tue Sep 14 12:10:35 1993 Bob Weiner <weiner@infodock.com> - -* hypb.texinfo - Renamed to hypb.texi. - -* hibtypes.el - completion - Added to recognize entries from " *Completions*" buffer. - hactypes.el - completion - Added to insert entries from " *Completions*" buffer. - -* hargs.el - hargs:at-p - Added missing setq in " *Completions*" conditional - so that if a pathname exists in the minibuffer, completion is simply - appended to it. - Also fixed bug in directory reading section where default-directory was - referred to as a function rather than a variable. - hargs:completion - Added to return and optionally insert - argument completion at point. Used in hargs:at-p for completion handling. - -* hactypes.el - hyp-source - Fixed to accomodate new Lemacs buffer object - print form, which includes double quotes around the buffer name. - -Thu Aug 19 21:52:42 1993 Bob Weiner <weiner@infodock.com> - -* h-skip-bytec.lsp - smart-key-mouse-set-point - Fixed to handle newer - versions of Lemacs which return 0 for X and Y modeline event positions. - -* hui-window.el - Replaced all references to `screen' with `frame'. - - sm-mouse-modeline - Changed so Smart Menus would only - display if the package is available and not running under a version of - Emacs19 or Lemacs which supports popup menus. If Smart Menu is not - displayed then a buffer menu is displayed or hidden (toggles). (The - Smart Menu package has not yet been released.) - -* hui-window.el - sm-mouse-side-sensitivity - Increased to 2 to handle window - side-by-side window resizing when scroll bars are active by depressing - just to the left of the scroll bar and then dragging, under GNU Emacs 19. -* hmouse-key.el - sm-mouse-setup - Added vertical-line bindings for GNU Emacs V19 - to handle side-by-side window resizes properly when vertical scroll bars - are turned off. - Also unbound local [mouse-2] (Emacs 19) - and button2 and button3 (Lemacs) in Info-mode so Hyperbole would handle - following Info nodes. - Unbound button3 in mode-line-map (Lemacs) - so Hyperbole can use this key. - -Thu Aug 12 12:48:27 1993 Bob Weiner (weiner@sun285) - -* hmail.el - hmail:compose - Added to compose messages to Hyperbole mail lists. - hui-menus.el - hui:menus - Changed Msg> menu code to use hmail:compose. - -Tue Aug 10 15:59:42 1993 Bob Weiner <weiner@infodock.com> - -* hargs.el - hargs:iform-read - Updated to use hargs:defaults as default - arg list if bound to a list and if no `modifying' argument is given. - -* hypb.el - hypb:v19-byte-code-p - Added to test for V19 bytecodes. - hypb:function-copy - Updated to deal better with V19 bytecodes - hargs.el - action:params - Updated to deal better with V19 bytecodes. - -Mon Aug 9 11:52:39 1993 Bob Weiner <weiner@infodock.com> - -* hypb.el - hypb:mark - Added to support common calling protocol to retrieve - mark value under Emacs V18 and V19. -* hsmail.el - hypb:mark - Replaced calls of `mark' with this. - - mail-citation-hook - Added and used in mail-yank-original for - V19 compatibility. - - smail:comment-add - Updated to handle mh-e header separator. - Also added (smail:comment-add) to mh-letter-mode-hook. -* hypb.el - hypb:supercite-p - Updated to account for V19 mail-citation-hook. - -Thu Aug 5 11:36:33 1993 Bob Weiner <weiner@infodock.com> - -* hargs.el - Updated to handle new "K" interactive command parameter in hargs:read. - This reads a kcell location for use within koutlines, which are tree structured - documents. (Koutlines will be part of Hyperbole V4.0.) - -* hui-mouse.el - smart-gnus-summary* - Updated doc to reflect actual function - behavior. - -Wed Jul 28 15:28:31 1993 Bob Weiner (weiner@sun285) - -* hmouse-key.el - sm-window-sys-term - Modified so when run from an X term - returns non-nil only if (eq window-system 'x). This prevents attempts to - enable mouse features when using an xterm as a dumb terminal that has - no mouse handling support. - -Tue Jul 27 17:11:38 1993 Bob Weiner (weiner@sun285) - -* hui-mouse.el - Updated to support GNUS V3.15 symbol names. -* hbut.el - ebut:map - Updated so that ep:but-create does not highlight - "<(" ")>" as a button. If the open paren is followed by a double quote, - it is ignored. - -Fri Jul 23 17:47:48 1993 Bob Weiner (weiner@sun285) - -* hmouse-key.el - Added hyperb:lemacs-early-p variable, set to non-nil if - running a version of Lucid Emacs without outlining and side-by-side window - support. -* hui-window.el - sm-split-window-horizontally - Signal error if - hyperb:lemacs-early-p since it can't do side-by-side windows. -* hui-mouse.el - smart-key-alist - Altered selective-display predicate to - ignore outline-minor-mode when hyperb:lemacs-early-p is non-nil. - -Tue Jul 20 13:25:26 1993 Bob Weiner <weiner@infodock.com> - -* hgnus.el - Updated to support GNUS V3.15 symbol names. - -Fri Jul 9 14:47:59 1993 Bob Weiner <weiner@infodock.com> - -* hypb.el - hypb:function-overload - Added to allow simple prepending or - appending to existing functions. - hmh.el - hrmail.el - hvm.el - Replaced manual overloads with calls to hypb:function-overload. - -Thu Jul 8 16:11:23 1993 Bob Weiner <weiner@infodock.com> - -* hui.el - hui:gbut-create - Added save-excursion to prevent movement of - point from what may be a user-specified position when adding a global - button. - -* hactypes.el - exec-shell-cmd - exec-window-cmd - Modified to set comint marker variables for - use with CMU comint shell package. - -Wed Jul 7 20:06:40 1993 Bob Weiner <weiner@infodock.com> - -* hpath.el - hpath:is-p - Fixed to recognize Info paths which display whole files, - e.g. "(emacs-ftrs)*". - -Tue Jul 6 14:20:44 1993 Bob Weiner <weiner@infodock.com> - -* hbut.el - ebut:operate - hui.el - hui:ebut-create - hui:ebut-edit - hsmail.el - mail-yank-original - hargs.el - hargs:iforms - Changed (mark) to (marker-position (mark-marker)) - for use in predicates since (mark) can signal an error under Emacs19 - instead of returning an int or nil as we want. - -* hui-window.el - smart-window-of-coords - smart-coords-in-window-p - Changed hyperb:emacs19-p conditionals - so works if Emacs19 is run under a non-X window system, e.g. NeXTSTEP. - -Wed Jun 30 13:36:18 1993 Bob Weiner <weiner@infodock.com> - -* set.el - set:union - Fixed missing setq bug in set:union. - -* hvar.el - Added so var:append function could be loaded independently of - the whole Hyperbole system. Moved var:append from hinit.el. - -* hlvar.el - hack-local-variables - Adapted for use with Emacs V19. - -Tue Jun 22 19:15:36 1993 Bob Weiner <weiner@infodock.com> - -* hibtypes.el - gdb-source - Added to jump to source lines associated with - gdb stack frame and breakpoint lines. - -Mon Jun 7 11:03:24 1993 Bob Weiner <weiner@infodock.com> - -* hpath.el - hpath:ange-ftp-p - Renamed to hpath:ange-ftp-at-p and changed - use in "hargs.el". - hpath:ange-ftp-p - Added, tests if argument is an ange-ftp path. - -Sun Jun 6 16:24:02 1993 Bob Weiner <weiner@infodock.com> - -* hpath.el - hpath:validate - Fixed so does not check readability of Info - and ange-ftp pathnames. - - hpath:ange-ftp-p - hpath:is-p - Fixed remote-path regexp comparison to match - to paths of form /host:relative-path permitted by ange-ftp. - -* hpath.el - hpath:substitute-var-name - Fixed bug so that nil var-dir-val is - replaced by default-directory. See doc for exec-path and load-path for - reason why. - -Fri Jun 4 13:32:30 1993 Bob Weiner <weiner@infodock.com> - -* hsite-ex.el - hmouse-key.el - Redefined hyperb:emacs19-p so is not true when running - Lucid Emacs. This was a bug. - -Fri May 21 10:50:58 1993 Bob Weiner <weiner@infodock.com> - -* hsite-ex.el - hpath:find-alist - Added "rtf" to "next". - -============================================================================== -V3.08 changes ^^^^: -============================================================================== - -* hactypes.el - Replaced all `error' calls with `hypb:error'. - -* hui-menus.el - In Msg> menu, use vm-mail if defined. - -* hui.el - hypb.el - hui:error - Renamed to hypb:error and moved from hui.el to hypb.el. - -Thu May 20 12:03:48 1993 Bob Weiner <weiner@infodock.com> - -* hrmail.el - Fixed bug in overlay of rmail-new-summary function related to - &rest which caused rmail-summary-by-recipients to fail. - -Tue May 18 11:33:48 1993 Bob Weiner <weiner@infodock.com> - -* hui.el - hui:ebut-delimit - Renamed to ebut:delimit so is part of ebut class. - hui:ebut-operate - Renamed to ebut:operate so is part of ebut class - and can be used to programmatically create buttons without use of "hui.el". - hbut.el - Added ebut:delimit and ebut:operate. - -Mon May 17 17:36:35 1993 Bob Weiner <weiner@infodock.com> - -* hpath.el - hpath:substitute-dir - hpath:substitute-in-file-name - hpath:substitute-var - hpath:substitute-var-name - Added to do expansion and - replacement of directory Emacs lisp variables in link paths. - hsite-ex.el - hpath:variables - Added to support var substitution in link paths. - hbdata.el - hbdata:build - Added call to hpath:substitute-var to support - var substitution in link paths. - - hypb.texinfo - Added doc explaining how to create/modify links via drags. - -Sun May 9 12:01:47 1993 Bob Weiner (weiner at localhost) - -* hmouse-key.el - hui-window.el - h-skip-bytec.lsp - Added mouse handling support for GNU Emacs V19. - -* hpath.el - hpath:find/-other-window - Added these 2 functions - to permit links which use external programs to display files. - hsite-ex.el - hpath:find-alist - Added to support hpath:find funcs. - hactypes.el - hypb-source - link-to-file - link-to-file-line - Added use of hpath:find functions. - hui-mouse.el - smart-dired - Made selection of entry display it for editing - rather than viewing and added use of hpath:find-other-window function. - -Sat May 8 16:03:51 1993 Bob Weiner (weiner at localhost) - -* hmouse-drv.el - smart-key-operate - Added so can emulate mouse drags - from the keyboard and thereby rapidly create link buttons from the - keyboard. - hsite-ex.el - Added {M-o} key binding for smart-key-operate. - -Mon May 3 15:07:30 1993 Bob Weiner <weiner@infodock.com> - -* hypb.el - hypb:function-copy - Fixed bug in error call, missing arg. - Fixed to work with V19 byte-compiler. - hypb:function-symbol-replace - Fixed to work with V19 byte-compiler. - hypb:map-vector - Added. - -Fri Mar 26 17:40:16 1993 Bob Weiner <weiner@infodock.com> - -* hib-doc-id.el, hmouse-drv.el, hsite-ex.el, hui.el - Mirrored value of temp-buffer-show-hook - in temp-buffer-show-function which is used instead under Lucid Emacs. - -Wed Mar 24 20:21:25 1993 Bob Weiner <weiner@infodock.com> - -* hlvar.el - hack-local-variables - Added support for V19 - enable-local-variables flag. - -Mon Mar 8 16:04:14 1993 Bob Weiner <weiner@infodock.com> - -* hmouse-key.el - sm-mouse-get-bindings - Fixed bug in NeXTSTEP portion. - -Sat Feb 27 16:56:25 1993 Bob Weiner <weiner@infodock.com> - -* DEMO - hmouse-doc.txt - hypb.texinfo - hui.el - Added hui:link-* functions to support dragging between windows to - create or modify links. - -* README - Updated What's New section for this release. - -Fri Feb 12 17:56:08 1993 Bob Weiner <weiner@infodock.com> - -* hactypes.el - exec-shell-command - exec-window-cmd - Added support for `comint' package when - it is loaded and Emacs V18 shell.el is not. - -Wed Feb 3 15:32:32 1993 Bob Weiner <weiner@infodock.com> - -* hmouse-info.el - Fixed bug in Info-handle-in-node-hdr/meta which had false - matches on node names which contained key words. - -Thu Jan 28 11:03:54 1993 Bob Weiner <weiner@infodock.com> - -* hui-mouse.el - Added autoload of "hmous-info" when Info-handle-in-note is - called since it may be called outside of the smart-info function. - -Mon Jan 11 13:46:42 1993 Bob Weiner <weiner@infodock.com> - -* hvm.el - Vm-Summ-goto - Redefined so would work properly. - -* hsys-www.el - Removed (require 'hinit). - -Fri Jan 8 16:11:59 1993 Bob Weiner <weiner@infodock.com> - -* hmous-info.el - Info-handle-in-node-hdr - Removed period as node reference - termination character since it is not one. - -Thu Dec 31 10:52:22 1992 Bob Weiner <weiner@infodock.com> - -* hui-menus.el - hui:menu - Fixed error message display handling. - -Wed Dec 30 11:23:28 1992 Bob Weiner <weiner@infodock.com> - -* hmouse-drv.el - smart-key-help-show - Added optional second arg - `current-window' so that help can be displayed within current window. - smart-key-summarize - Added optional arg `current-window'. - hui-window.el - sm-mouse-modeline-meta - Changed call of - `smart-key-summarize' to use current window. - -* hui-menus.el - hui:menus - Modified Doc/ menu to bring up all files - in read-only mode. - -* hmouse-tag.el - smart-tags-file - Fixed so works with UNIX ange-ftp - pathnames. - -Tue Dec 15 14:21:06 1992 Bob Weiner <weiner@infodock.com> - -* hui.el - hui:hbut-label-default - hui:hbut-label - Created these funcs from parts of - hui:ebut-create and called them from there. - - Also changed '(lambda ...) to (function (lambda ...)) throughout - file. - -Mon Dec 14 16:55:41 1992 Bob Weiner <weiner@infodock.com> - -* hpath.el - hpath:is-p - Narrowed regexp match of Info paths, so will false - infrequently. -* hargs.el - hargs:at-p - Added optional argument NO-DEFAULT and fixed doc. - -Wed Dec 9 11:38:08 1992 Bob Weiner <weiner@infodock.com> - -* hib-doc-id.el - link-to-doc - Fixed so retrieved documents properly. - wrolo.el - rolo-fgrep - rolo-grep - Added optional parameter `no-display' which - retrieves rolo records but suppresses display of the matches. - Used in "hib-doc-id.el". - -Sun Dec 6 17:35:22 1992 Bob Weiner <weiner@infodock.com> - -* hib-doc-id.el - link-to-doc action - Fixed bug where rolo-display-buffer - pointed to wrong buffer causing document retrievals to fail. - -Tue Dec 1 10:52:33 1992 Bob Weiner <weiner@infodock.com> - -* hsite-ex.el - hypb:read-only-smart-keys - hui-mouse.el - Removed smart-key read-only mode map key bindings since are - now set in hsite-ex.el for read-only modes which have been loaded when - Hyperbole is initialized. Modes loaded after Hyperbole will no longer - have read-only smart key bindings but can use the global smart key - bindings. - -Mon Nov 23 19:51:21 1992 Bob Weiner <weiner@infodock.com> - -* DEMO - hypb.texinfo - h-skip-bytec.lsp - hmouse-key.el - hactypes.el - hui-mouse.el - hui-window.el - Made NeXTSTEP and SunView mouse support work. On NeXT, - Left = Smart Key, Right = secondary Smart Key, Shift-Left sets point. - -* hsys-wais.el - Changed so doesn't trigger error if this library is loaded - by hsite but wais.el does not exist. - -* hvm.el - vm-show-current-message - Ensured that buttons are highlighted - when one moves between messages. - -============================================================================== -V3.07 changes ^^^^: -============================================================================== - -Mon Nov 16 09:01:34 1992 Bob Weiner <weiner@infodock.com> - -* hsmail.el - mail-yank-original - Added more support for various yank-hook - configurations. - -* hui-mouse.el - hmouse-key.el - hmouse-drv.el - Updated Apollo mouse key handling to work with V18.58 - patches from lnz@lucid.com. - -Fri Nov 13 11:48:51 1992 Bob Weiner <weiner@infodock.com> - -* hsite-ex.el - hypb:read-only-smart-keys - Only define keys if object - actually is a keymap. - -* hargs.el - hargs:iforms - Modified `M' command entry to return a single arg - to fix problem of improper arg display when editing mail links. - hactypes.el - link-to-mail - Modified to accept either 1 (new style) or 2 - (old style) args for mail links. - -Thu Nov 12 10:52:06 1992 Bob Weiner <weiner@infodock.com> - -* sm-mouse-drag-window-side - Changed `abs' to `max' since abs is only - defined in some Emacs versions if cl.el has been loaded. - -* hactypes.el - link-to-file - hargs.el - hargs:iforms - Fixed typo. Was 'vms, now is 'vax-vms. - -* hsmail.el - smail:comment-add - Fixed so works if `mail' is given args. - -Wed Nov 11 17:22:17 1992 Bob Weiner <weiner@infodock.com> - -* hui-epV4-b.el - ep:but-clear - Added to clear just Hyperbole button zones. - hui-le-but.el - le:but-clear - Made clear only Hyperbole button extents - under Lemacs V19.3 or greater. - -* hui-epV3-b.el - Deleted. - hsite-ex.el - Removed Hyperbole support for Epoch V3. Only V4 is now - supported. - -* hmouse-drv.el - smart-key-mouse - smart-key-mouse-meta - hmouse-key.el - sm-depress - sm-depress-meta - Fixed bug in Smart Key context-sensitive - help which made help shown vary depending on which Smart Key was released - first rather than depressed first. - -* Made mouse handling work under Epoch. - hmouse-key.el - sm-mouse-get-bindings - sm-mouse-setup - Added in modeline bindings for Epoch. - h-skip-bytec.lsp - smart-key-mouse-set-point - Under Epoch, modified - to return X,Y coords of mouse rather than press/release event. - hui-window.el - sm-mouse-x/y-coord - Changed Epoch X,Y args. - -Mon Nov 9 10:16:51 1992 Bob Weiner <weiner@infodock.com> - -* hui-window - smart-key-alist - Fixed precedence bug which could register a - drag between windows when in actuality a drag from a modeline was done. - sm-mouse-x/y-coord - Modified to get x/y coords from modeline - presses under Lucid Emacs even though they are not reported with depress - event. - h-skip-bytec.lsp - smart-key-mouse-set-point - Under Lucid Emacs, modified - to return X,Y coords of mouse rather than press/release event whenever - the event contains no coord info, e.g. when over a modeline. - DEMO - hypb.texinfo - Removed notes saying that modeline presses don't work under - Lucid Emacs. - -* README - Installation - Fixed description of how to install Hyperbole Info - manual. - -* hui-window.el - abs - Added conditional function def if not already defined. - -Fri Nov 6 17:14:57 1992 Bob Weiner <weiner@infodock.com> - -* hmh.el - mh-send-letter - Had been byte-compiled without access to - "mh-e.el" macros loaded. Fixed. - -Wed Nov 4 13:48:24 1992 Bob Weiner <weiner@infodock.com> - -* hbmap.el - hbmap:dir-filename - Transposed args to expand-file-name - which were backwards. - -Tue Nov 3 15:56:08 1992 Bob Weiner <weiner@infodock.com> - -* hui-mouse.el - smart-key-alist - Updated to support etags use under C++. -* hmouse-tag.el - smart-c++ - Renamed to `smart-c++-oobr' and made a new - `smart-c++' function like `smart-c'. - smart-c - Modified this and smart-c++ to take an argument - of a tag to find, rather than just searching for the tag at point. - -* hvm.el - Vm-msg-num - Vm-msg-to-p - Vm-msg-end - Made search for msg delimiter case-sensitive so - wouldn't false as often. - -* smart-clib-sym - file-newer - Added for use by "hmouse-tag.el" smart-c function. - MANIFEST - Updated. - hmouse-tag.el - smart-c - Changed `sm-directory' to `hypb:dir'. - -* hui-le-but.el - ep:set-item-highlight - Changed `get-face' to `find-face'. - -* DEMO - Clarified lack of modeline support for Lucid Emacs and fixed typo. - -* hmouse-tag.el - Added (load "etags") for Emacs V19. - -* hsite-ex.el - Swapped order of definition of hyperb:lemacs-p and - hyperb:epoch-p so that when under Epoch, hyperb:lemacs-p is defined - when used in the "hypb.el" file which is loaded by the Epoch conditional - code in "hsite-ex.el". - -============================================================================== -V3.06 changes ^^^^: -============================================================================== - -Mon Nov 2 15:15:42 1992 Bob Weiner (ex594bw at msn25) - -* hui-le-but.el - ep:set-item-highlight - Added optional 2nd arg FOREGROUND. - -* hypb.el - hypb:window-list - Added Lemacs support to return list of all - windows on all screens. - -Fri Oct 30 16:58:43 1992 Bob Weiner <weiner@infodock.com> - -* DEMO - Added Smart Mouse Keys section demoing drag and modeline click - capabilities. - -Thu Oct 29 13:41:43 1992 Bob Weiner <weiner@infodock.com> - -* hmous-info.el - smart-info - smart-info-meta - Modified to utilize Gillespie's Info tree - traversal routines if loaded so can walk through a whole manual with - mouse keys easily. - -* hmouse-drv.el - smart-key - smart-key-meta - Fixed doc strings so don't mention - smart-menu. - -* hsmail.el - mail-yank-original - Fixed bug that could cause whole Rmail - buffer to be yanked in if Hyperbole mail support was not fully loaded. - -Wed Oct 28 11:18:13 1992 Bob Weiner <weiner@infodock.com> - -* hui-window - sm-mouse-modeline - Made Smart Key click on right edge of - modeline bury Info buffer if displayed already, so it acts as a display/ - hide toggle. - sm-mouse-modeline-meta - Did the same for the secondary - Smart Key with the Smart Key summary display. - -Thu Oct 22 17:05:35 1992 Bob Weiner <weiner@infodock.com> - -* hypb.texinfo - Added Smart Key Reference appendix. - -Wed Oct 21 14:33:21 1992 Bob Weiner <weiner@infodock.com> - -* hmouse-drv.el - smart-key-help-show - Changed so help buffers come up - in Emacs Lisp mode so symbols in help may be further browsed with - smart key presses. - -* hui-mouse.el - smart-key-alist - Changed smart-man-entry-ref entry so works - properly with Smart Key help commands. - -* MANIFEST - Reorganized. - -Fri Oct 16 10:29:58 1992 Bob Weiner <weiner@infodock.com> - -* hui-mouse.el - smart-key-mouse-alist - Added def to handle smart key - and smart key mouse actions. - smart-key-mouse - smart-key-mouse-meta - Updated to use smar-tkey-mouse-alist. - -* hsite-ex.el - Swapped smart-key to {M-RET} and smart-key-meta to {C-u - M-RET} since this is more intuitive overall and jives with the {C-h S} - binding. - hypb.texinfo - DEMO - Updated with change. - -* hui.el - hui:ebut-delete-confirm-p - Added. - hui:ebut-delete - Changed to prompt user before deleting button - when hui:ebut-delete-confirm-p is non-nil and delete command is called - interactively. - hui:ebut-delete-op - Added. - hui:error - Added and changed hui error calls to use. - hui:menu - Updated to handle errors properly. - hypb.texinfo - Explained changed. - -Thu Oct 15 12:18:42 1992 Bob Weiner <weiner@infodock.com> - -* smart-key-help - Made arg optional. - smart-key-meta-help - Added so can call without sending an arg. -* hmouse-mod.el - Added to support use of Smart Mouse Keys as keyboard - modifier keys, Control and Meta. - MANIFEST - Updated. - hmouse-drv.el - smart-key-mouse-help - Added to handle help for context - sensitive help for drags. - -Wed Oct 14 11:55:15 1992 Bob Weiner <weiner@infodock.com> - -* hbut.el - ebut:label-p - Made it handle labels with embedded open and close - delimiters properly, e.g. {C-x @key{RET}}. - hib-kbd.el - kbd-key:normalize - Accounted for @key{SPC} type notation - in Texinfo. - -* hui-menus - hui:menu - Provide user feedback on {C-g} quit signals - when within a Hyperbole menu just like when not. - -* hbut.el - ebut:list - Remove duplicate labels by default. - -* hypb.texinfo - Updated list of ibtypes and actypes. - -* hbmap.el - hbmap:dir-filename - Replaced concat with expand-file-name. - hbdata.el - hbdata:to-hbdata-buffer - hbut.el - ebut:search - gbut:file - hattr:save - hbut:source - hmouse-drv.el - smart-key-summarize - hmouse-tag.el - smart-c - smart-c-include-file - smart-tags-file - hpath.el - hpath:symlink-expand - hsite-ex.el - set load - hui.el - ebut:unmark - -* hmouse-doc - Renamed to hmouse-doc.txt for easy inclusion - in Texinfo Manual. - MANIFEST - Updated. - hmouse-drv.el - smart-key-summarize - Updated. - hui-menus.el - hui:menus - Updated. - -Mon Oct 12 18:54:03 1992 Bob Weiner <weiner@infodock.com> - -* hui-menus.el - hui:menus - Capitalized all top-level entries. - hypb.texinfo - Reflected this change in menu. - -Sun Oct 11 16:37:10 1992 Bob Weiner <weiner@infodock.com> - -* hibtypes.el - hibtypes:begin-load-hook - hibtypes:end-load-hook - Added to improve customizability - of ibtype loading. - hypb.texinfo - Documented these new hooks. - hsite-ex.el - Used new hooks in loads of some ibtypes. - README - Mentioned new hooks. - -Thu Oct 8 17:22:33 1992 Bob Weiner <weiner@infodock.com> - -* hmouse-key.el - sm-depress - sm-depress-meta - Stopped from moving point, release action - can do that when needed. - hmouse-drv.el - smart-key-mouse - smart-key-mouse-meta - Moved `smart-key-help' function - to Smart Key release event rather than depress, so that depress can - be used more generally. - -* hmouse-tag.el - smart-lisp-at-tag-p - Added `*' as valid symbol char. - -* h-skip-bytec.lsp - Added for functions not to byte compile. - hmouse-drv.el - smart-key-mouse-set-point - Moved to "h-skip-bytec.lsp" - so would remain non-byte-compiled because byte-compiled version - fails under X, at least. - MANIFEST - Updated. - -Tue Oct 6 12:24:48 1992 Bob Weiner <weiner@infodock.com> - -* hyperbole.el - Added to autoload Hyperbole; provides main entry point. - MANIFEST - Updated. - -Mon Oct 5 19:13:07 1992 Bob Weiner <weiner@infodock.com> - -* hui-mouse.el - smart-gnus-Subject - Fixed last-line-p condition which - did not work because of GNUS code does not properly determine the - current article regardless of point position within the subject buffer. - -Sun Oct 4 14:36:13 1992 Bob Weiner <weiner@infodock.com> - -* hmouse-key.el - apollo-mouse-move-point - Added definition which - returns screen coordinates of point. - smart-key-mouse-set-point - Called. - hmouse-drv.el - smart-key-mouse-set-point - Added. - -Thu Oct 1 18:14:29 1992 Bob Weiner <weiner@infodock.com> - -* wrolo.el - rolo-grep-file - Added a save-excursion so that - point does not change after a rolo search of a buffer - already in use. - -Wed Sep 30 17:41:58 1992 Bob Weiner <weiner@infodock.com> - -* hib-doc-id.el - Added to display site-specific documents based on ID. - You must load it explicitly or it is not used. See the DESCRIPTION - in its header. - MANIFEST - Added hib-doc-id.el entry. - -* wconfig.el - Added. - MANIFEST - Added wconfig.el entry. - hsite-ex.el - Added wconfig key bindings. - hinit.el - Added wconfig autoloads. - -Sat Sep 26 17:40:41 1992 Bob Weiner <weiner@infodock.com> - -* wrolo.el - rolo-grep - Fixed bug in handling of negative max-matches - argument which kept rolo-yank from working. - -* hmouse-drv.el - smart-key-depress/release-window - smart-key-meta-depress/release-window - Added to - track window of presses and releases. - smart-key-mouse-func - Set above variables. - hmouse-key.el - sm-depress - sm-depress-meta - Set above variables. - -Fri Sep 25 13:35:26 1992 Bob Weiner <weiner@infodock.com> - -* hypb.el - hypb:screen-line - Added to determine screen - line from point or marker. - -* hui-window.el - Added module to handle Smart Mouse Key - depress and release actions in windows and mode lines. - MANIFEST - Added "hui-window.el" entry. - hui-mouse.el - Added require of hui-window if running - under a window system. - -* hmouse-drv.el - smart-key-point-prev - Removed its def. - smart-key-depress-prev-point - smart-key-meta-depress-prev-point - smart-key-release-prev-point - smart-key-meta-release-prev-point - Added defs for these - vars for use in mouse drag determinations and point restorations. - hui.el - hui:ebut-edit - Removed use of smart-key-point-prev. - -Wed Sep 23 19:17:07 1992 Bob Weiner <weiner@infodock.com> - -* hmouse-drv.el - *smart-key-release-args* - *smart-key-meta-release-args* - Added to provide other - functions with args last given to Smart Mouse Keys. - smart-key-mouse - smart-key-mouse-meta - Modified to set these arg vars. - -* hmouse-key.el - *smart-key-depress-args* - *smart-key-meta-depress-args* - Added as globals to hold - args sent to smart key depress events for use by other functions. - -Tue Sep 22 22:38:02 1992 Bob Weiner <weiner@infodock.com> - -* hui-mouse.el - smart-key-alist - Fixed bug that kept end of - line scrolling from working properly when selective-display - is in use since mouse can set point to precede a ^M character - in addition to a newline. This is really a bug in the way - "x-mouse.el" sets point, but we compensate here. - -* hmouse-drv.el - scroll-down/up-eol - Modified to do - proportional scrolling when `smart-scroll-proportional' - is non-nil. - hsite-ex.el - Added `smart-scroll-proportional' defvar. - Updated and clarified installation instructions. - hypb.texinfo - Added prop scrolling to Smart Key summary table. - DEMO - Added demo of Smart Key end of line scrolling. - -Sun Sep 20 01:43:32 1992 Bob Weiner <weiner@infodock.com> - -* hmouse-tag.el - smart-c-include-regexp - Redefined to also handle #import - used by Objective-C classes. - -Sat Sep 19 17:56:14 1992 Bob Weiner <weiner@infodock.com> - -* hinit.el - hyperb:version - Moved out of here to "hversion.el" - file. Updated version number to 3.05. - MANIFEST - Updated. - -* hui-menus.el - hui:menu - Added two optional parameters to permit - invocation of alternative menus from other packages. - hui:menu-act - Added an optional menu-list parameter so that - other packages can more simply used Hyperbole menus for their menu - UIs. - -============================================================================== -V3.05 changes ^^^^: -============================================================================== - -Sun Sep 6 02:52:32 1992 Bob Weiner <weiner@infodock.com> - -* hypb.texinfo - hsite-ex.el - smart-key-help - Added {C-h S} key binding to - make accessible whether or not one has a mouse. - -Wed Sep 2 18:02:02 1992 Bob Weiner <weiner@infodock.com> - -* hact.el - actype:act - Tried another fix for getting relative - paths resolved properly without improperly setting default-directory. - -Tue Sep 1 14:21:47 1992 Bob Weiner <weiner@infodock.com> - -* hmouse-key.el - sm-depress - sm-depress-meta - Fixed bug which kept depressed flag - from being set if mouse handler function sends no args. - -* hsite-ex.el - Uncommented key bindings for `hui:ebut-rename' - and `sm-mouse-toggle-bindings' and protected all key bindings - so are not done if function is already bound to key or if key - is already in use. - hypb:rebind-smart-keys - Added to permit special - smart key bindings in read-only modes. - -Fri Aug 28 09:39:55 1992 Bob Weiner <weiner@infodock.com> - -* hui-le-but.el - le:but-delete - Added missing - (fset 'le:but-delete 'ep:but-delete). -* hbut.el - hattr:clear - Fixed bug which could leave wrong attributes, - e.g. args, attached to button. -* hui-le-but.el - ep:but-flash - Fixed bug which left some implicit - buttons highlighted after flash. - le:cycle-but-color - Made flash-style foreground & - background contrast as good as button highlighted style. - hui-epV4-b.el - ep:but-flash - Fixed bug which left some implicit - buttons highlighted after flash. - ep:cycle-but-color - Made flash-style foreground & - background contrast as good as button highlighted style. - -Tue Aug 25 15:21:14 1992 Bob Weiner <weiner@infodock.com> - -* hui-le-but.el - Added. - hmouse-key.el - hui-menus.el - hsite-ex.el - MANIFEST - hinit.el - Added button highlighting, mouse key support, - and event-based keypress input for Lucid Emacs. - Released this set of files as patch to add Lucid Emacs support. - -============================================================================== -V3.05P changes ^^^^: -============================================================================== - -Thu May 7 15:48:00 1992 Bob Weiner <weiner@infodock.com> - -* hbdata.el - hbdata:apply-entry - Fixed bug that matched to C-l within - a button data entry rather than at its end. - -Mon Apr 27 02:15:53 1992 Bob Weiner <weiner@infodock.com> - -* hbut.el - htype:create - Fixed improper use of macro form which - caused emission of no code for ibtypes when compiled with the new, - optimizing byte compiler. -* hact.el - hact - Simplified. - action:create - Wrapped `function' around action body - so is byte-compiled. - -Fri Apr 24 14:17:58 1992 Bob Weiner <weiner@infodock.com> - -* hibtypes.el - rfc - Added to retrieve and display rfcs from references. - hactypes.el - link-to-rfc - Added. - -Tue Apr 21 22:11:06 1992 Bob Weiner <weiner@infodock.com> - -* hui-menus.el - hui:menus - Added Ebut/Edit for consistency with other menus. - -Thu Apr 16 17:06:32 1992 Bob Weiner <weiner@infodock.com> - -* hbut.el - ebut:next-occurrence - Added. - ebut:get - Modified to use ebut:next-occurrence to correct bug - that caused failure when called with point not at desired button and - button source is pointed to indirectly with @loc>, e.g. in search - result (moccur) buffer. - -Wed Apr 15 03:20:10 1992 Bob Weiner <weiner@infodock.com> - -* hpath.el - hpath:symlink-referent - Added to recursively resolve symlinks. - hpath:symlink-expand - hui.el - hui:key-dir - hui:key-src - Modified to use hpath:symlink-referent. - hbut.el - hbut:key-src - Modified to use hpath:symlink-referent. - hact.el - actype:act - Made default-directory relative to but src - location, which may be complicated by symbolic links. - -Tue Apr 14 08:53:11 1992 Bob Weiner <weiner@infodock.com> - -* hui-mouse.el - smart-dired - Added call to dired-to-flagged-delete for - Tree Dired compatibility. - -Fri Apr 10 18:53:24 1992 Bob Weiner <weiner@infodock.com> - -* DEMO - Started reworking to illustrate newer features. - -Thu Apr 9 04:10:48 1992 Bob Weiner <weiner@infodock.com> - -* hmous-info.el - Info-handle-in-node-hdr - Fixed bug when (dir) entry - appears in node header. -* hui-mouse.el - smart-outline-to-entry-end - Added this omitted function. - -* hmouse-doc - Reorganized for readability. - -Tue Mar 31 20:34:21 1992 Bob Weiner <weiner@infodock.com> - -* hui-mouse.el - hsite-ex.el - Made local smart key read-only mode bindings site - configurable. - -Mon Mar 30 01:11:28 1992 Bob Weiner <weiner@infodock.com> - -* hui-epV4-b.el - Added code to support item and line highlighting for - Smart Menus and PIEmail, for example. - -Sun Mar 29 21:04:39 1992 Bob Weiner <weiner@infodock.com> - -* hactypes.el - link-to-elisp-doc - Added. - -Fri Mar 27 13:20:43 1992 Bob Weiner <weiner@infodock.com> - -* hmouse-drv.el - hsite-ex.el - Moved Smart Key global bindings here so are site - customizable. - -Thu Mar 26 14:40:57 1992 Bob Weiner <weiner@infodock.com> - -* hpath.el - hpath:ange-ftp-p - Tweaked to recognize path with user names - properly so all forms shown in DEMO work. - -Tue Mar 24 17:07:35 1992 Bob Weiner <weiner@infodock.com> - -* hmouse-key.el - Required sun-fns under SunView. - -Sat Mar 21 19:04:58 1992 Bob Weiner <weiner@infodock.com> - -* hui.el - hui:ebut-operate - Fixed bug caused by returning 't. - -* hargs.el - hargs:iforms - Fixed bug in `N' and `n' cmd chars where - arg value was not set. - -* hactypes.el - hyp-config - Added PIEmail descriptor and suppressed - mailer entry if nil valued. - -Thu Mar 19 02:10:11 1992 Bob Weiner <weiner@infodock.com> - -* hmouse-key.el - Added NeXTStep auto-configured mouse support. - -Wed Mar 18 21:32:32 1992 Bob Weiner <weiner@infodock.com> - -* hmouse-key.el - sm-mouse-setup - Ensured Gillespie's new Info mouse support - code is turned off since Hyperbole handles that and errors result if not. - -* hui-mouse.el - smart-calendar - Changed scroll op from eol to eob since - no longer provide local function control of eol. - -* hui-menus.el - hui:menu - Removed improper use of unwind-protect which - allowed recursive Hyperbole menu invocation. - -============================================================================== -V3.04 changes ^^^^: -============================================================================== - -Tue Mar 17 18:39:21 1992 Bob Weiner <weiner@infodock.com> - -* hui-mouse.el - smart-key-alist - Added View mode scrolling support. - -Mon Mar 16 13:59:07 1992 Bob Weiner <weiner@infodock.com> - -* hypb.el - hypb:debug - Added to support more informative tracebacks. - -* htz.el - htz:date-parse - Fixed incorrect month regexp for format 4 - and added error clause to catch invalid date formats. - -* hvm.el - Conditionalized load of "vm-edit", so for vm versions where - all code is in vm.elc, works correctly. - -Wed Mar 11 12:51:55 1992 Bob Weiner <weiner@infodock.com> - -* hrmail.el - hmv.el - hmh.el - hmail.el - Added msg-next, msg-prev, Summ-delete, Summ-expunge, - Summ-goto, and Summ-undelete-all for use in smart-hmail/meta funcs. -* hui-mouse.el - smart-rmail - Added press on first line of msg - smart-rmail-meta - that goes to next/prev msg. - Also renamed to smart-hmail since now use abstract functions. - Eliminated local smart key binding of {RTN} in mail reader modes - since would have to set in every mode map and may be used in some. - -Mon Mar 9 05:43:06 1992 Bob Weiner <weiner@infodock.com> - -* hpath.el - hpath:at-p - Added missing call to `hpath:ange-ftp-p' - so that `pathname' ibtype works as documented and so that remote pathnames - are not checked for existence. - -* hvm.el - Vm-msg-num - Fixed miscounting bug. - hmh.el - Mh-msg-num - Fixed invalid function call. - -* hui-mouse.el - smart-gnus-Article - smart-gnus-Article-meta - Added smart key support for - GNUS article mode browsing. - -* hinit.el - hsite-ex.el - Added autoload of Hyperbole support for PIEmail reader. - PIEmail is not yet released, so don't ask about it. - -============================================================================== -V3.04P changes ^^^^: -============================================================================== - -Mon Mar 9 01:51:54 1992 Bob Weiner <weiner@infodock.com> - -* hact.el - action:path-args-rel - hui.el - hui:ebut-create - hui:ebut-modify - hui:gbut-create - Added use of 'dir attribute in 'hbut:current - so that always know which directory button path args should be made - relative to. - -Sat Mar 7 03:23:26 1992 Bob Weiner <weiner@infodock.com> - -* hmouse-tag.el - smart-c - Fixed so selecting #include files works by - calling smart-c-include-file. - smart-c-include-dirs - smart-c-cpp-include-dirs - smart-c-include-regexp - smart-c-include-file - Added to support include selection. - - -Fri Mar 6 01:48:28 1992 Bob Weiner <weiner@infodock.com> - -* hui-mouse.el - smart-man-c-routine-ref - Made it use `man-path' variable - from smart-man.el (not distributed because not needed) if available. - -* hactypes.el - exec-window-cmd - Added exec of window-based shell cmds. - Does not display shell input or output, just applications window. - -============================================================================== -V3.03P changes ^^^^: -============================================================================== - -Wed Mar 4 02:00:28 1992 Bob Weiner <weiner@infodock.com> - -* hactypes.el - hyp-config - Added system-type inclusion and removed tabs. - hui-menus.el - Msg/ - Made Subject line for hyp-config more definitive. - -Tue Mar 3 00:23:47 1992 Bob Weiner <weiner@infodock.com> - -* hui-mouse.el - unix-apropos-map - Fixed bug where badly written unix apropos - mode does not define key map properly and we try to set keys in it. - -* hmouse-drv.el - smart-key-help - Made display action doc specific to any - Hyperbole button clicked on. - -* hbut.el - hattr:report - Fixed bug in field filling when attr name was too long. - -* hmouse-key.el - sm-depress - sm-depress-meta - Removed save-excursion to ensure that point - is always put where smart keys are depressed. - -* hmouse-drv.el - smart-key-set-point - Made `smart-key-point-prev' save - point-marker rather than point. - hui.el - hui:ebut-edit - Made use of `smart-key-point-prev' as marker. - -* hui-mouse.el - smart-buffer-menu - smart-buffer-menu-meta - Added, were accidentally omitted. - -Mon Mar 2 19:41:55 1992 Bob Weiner <weiner@infodock.com> - -* hypb.el - hypb:function-copy - Removed code that deleted &rest keyword - since this could cause a wrong number of arguments error. - -============================================================================== -V3.02P changes ^^^^: -============================================================================== - -Wed Feb 26 02:00:07 1992 Bob Weiner <weiner@infodock.com> - -* hypb.el - hypb:supercite-p - Added to test if supercite is in use. - hsmail.el - mail-yank-original - Prevented removal of headers when - supercite package is used. Also fixed bug where point and mark - exchange was being done in wrong scope. - hgnus.el - Added supercite compatible `news-reply-yank-original'. - hypb.texinfo - Updated to mention that mail/news inits, like - supercite init, must come before Hyperbole init. - -* hrmail.el - Fixed bug where function overloads that contained &rest - would end up creating a list of a list. - hypb.el - hypb:function-copy - Added to solve this bug. - hinit.el - Updated version number. - -============================================================================== -V3.01P changes ^^^^: -============================================================================== - -Tue Feb 25 00:42:24 1992 Bob Weiner <weiner@infodock.com> - -* hypb.texinfo - hactypes.el - link-to-regexp-match - link-to-string-match - Added. - -* hinit.el - var:append - Modified to deal with reality that people may - set their hook variables to function symbols rather than lists. - -* hui-mouse.el - Added smart key support for: C and Lisp jump to tag def, - calendar scrolling and appt viewing, man apropos and - man page ref following, outline expanding and collapsing, - Rmail and GNUS browsing, dired and buffer menu - selections and deletions, wrolo entry source editing - and entry narrowing to focus. -* hui.el - hui:htype-help - hui-menus.el - hui:menus - Made ibtypes listing print in decreasing - priority order, so user can see the priorities. - -Mon Feb 24 20:10:46 1992 Bob Weiner <weiner@infodock.com> - -* hmouse-tag.el - Added, jumps to identifier definition locations. - -Sun Feb 23 03:29:17 1992 Bob Weiner <weiner@infodock.com> - -* hargs.el - hargs:at-p - Fixed bug where if reading an `ebut' argument - could not select from completions buffer. Global buttons now need - this behavior. - -Sat Feb 22 03:57:24 1992 Bob Weiner <weiner@infodock.com> - -* hibtypes.el - hyp-address - hactypes.el - hyp-config - Added to insert Hyperbole configuration info - in outgoing mail messages and news articles. - hyp-request - Added to provide help when making hyperbole - mail list requests. - hui-menus.el - Added Msg/ menu providing quick access to hyp-config and - hyp-request actions. - -Wed Feb 19 00:37:37 1992 Bob Weiner <weiner@infodock.com> - -* hbut - gbut:act - gbut:help - gbut:key-list - gbut:lbl-list -hui.el - hui:gbut-create - Added basic global button support. - -* hbdata.el - hbdata:build - Fixed bug during button creation where - instance number never went over 2. - -* hui.el - hui:ebut-create - hui:ebut-modify - Modified to permit button creation in mail - reader buffers properly. - hui:key-src - Added to support this change. - -Tue Feb 18 02:27:05 1992 Bob Weiner <weiner@infodock.com> - -* hypb.texinfo - hui-menus.el - Added Doc/ top-level menu. - -* hinit.el - hsite-ex.el - Made all mail and news reader support autoconfigure. - -* hvm.el - Made whole VM support work. - -Mon Feb 17 21:50:23 1992 Bob Weiner <weiner@infodock.com> - -* hmail.el - hmail:hbdata-to-p - hsmail.el - mail-yank-original - Fixed placement of author ref line. - hgnus.el - rnews:summ-msg-to - Added. - gnus-Article-prepare-hook - Changed from improper `mode-hook'. - gnus-Subject-prepare-hook - Added. - hbdata.el - hbdata:apply-entry - Made whole GNUS support work. - -Mon Feb 3 03:06:15 1992 Bob Weiner <weiner@infodock.com> - -* README - Rearranged sections. - -* hmouse-key.el - sm-depress - sm-depress-meta - Changed to take any number of - arguments to support 3 arg calling convention under Sunview. - -Sun Feb 2 16:52:05 1992 Bob Weiner <weiner@infodock.com> - -* hui.el - hui:ebut-operate - Fixed bug that had crept in that - did not use marked text during button create. - -Fri Jan 24 10:36:19 1992 Bob Weiner <weiner@infodock.com> - -* set.el - set:add - Changed to always return current set, like - set:remove. Use set:member to check if elt is in set. - -Thu Jan 16 14:41:50 1992 Bob Weiner <weiner@infodock.com> - -* hui-mouse.el - Changed `defconst' to `defvar' throughout file so if - Smart Key package is loaded separately, defaults are not overwritten. - -============================================================================== -V3.0P changes ^^^^: -============================================================================== - -Sat Jan 11 14:28:51 1992 Bob Weiner <weiner@infodock.com> - -* hypb.el - hypb:call-process-p - Made `predicate' param optional to - conform to doc string. - -Thu Jan 9 02:15:14 1992 Bob Weiner <weiner@infodock.com> - -* hmouse-key.el - sm-mouse-set-bindings - Fixed conditional bug, missing paren. - -* hib* - hsys* - Updated all ibtypes to new format. -* hbut.el - defib - Removed `actype' param since ibtypes can perform any number - of actions now. -* hact.el - actype:act - Added and aliased to `hact'. This is the function - new ibtypes call to perform actions. - actype:action - Added support so any function can be called - as an action. - hrule:action - Added this var to allow disabling of actions. -* hbut.el - hattr:report - Removed display of internal "actypes::" prefix. - ibut:at-p - Set hrule:action to disable action when eval ibtype. - -* hsys-www.el - ib hwww:link-follow - Permitted [<num>] references without any - leading text since some WWW documents use this. This may lead to false - button recognition in other documents. When clicked on, it will become clear - that such are not valid buttons. - -Wed Jan 8 22:53:41 1992 Bob Weiner <weiner@infodock.com> - -* hui-ep-but.el - ep:but-color - Changed "black" dflt to (epoch::foreground). - -============================================================================== -V2.02.4 changes ^^^^: -============================================================================== - -Sat Jan 4 17:48:12 1992 Bob Weiner <weiner@infodock.com> - -* hbut.el - ebut:create - Removed `save-excursion' call which conflicted with - function doc. - hui.el - hui:ebut-create - hui:ebut-modify - hui:ebut-rename - Added `save-excursion' so buttons are always - created in the proper buffer. - hargs.el - hargs:read - hargs:read-match - Added `save-excursion' so user buffer or window - switching during arg reading does not change current buffer. - -============================================================================== -V2.02.3 changes ^^^^: -============================================================================== - -Fri Jan 3 17:51:42 1992 Bob Weiner <weiner@infodock.com> - -* hui-menus.el - hui:menu-select - Fixed bug in menus where if hit invalid - key, could not enter a valid one any more. - -Thu Jan 2 02:27:12 1992 Bob Weiner <weiner@infodock.com> - -* hpath.el - hpath:at-p - hpath:is-p - Added recognition of ange-ftp pathnames, - automatically used by ibtype, pathname. - -* wrolo.el - wrolo-logic.el - Added rolodex system to distribution. - -Wed Jan 1 01:52:41 1992 Bob Weiner <weiner@infodock.com> - -* hui-menus.el - hui:menus - Renamed Report/ menu to Help/ and placed - under Ebut/ menu rather than top level, so could fit new Rolo/ menu. - Removed duplicative `List' entry from Ebut/. -* hactypes.el - hibtypes.el - hypb.texinfo - rfc-toc - Added ibtype-actype pair to display summary of - Internet RFC contents for random access browsing. - -Sun Dec 29 00:50:18 1991 Bob Weiner <weiner@infodock.com> - -* hmous-info.el - Info-handle-in-note - Updated to handle *Ref cross refs as - used in Elisp manual. Maybe these are part of Texinfo V2? - -* hpath.el - hpath:is-p - Updated to allow Info node paths. - hibtypes.el - Info-node - Added new type to recognized double quoted - Info node refs. - DEMO - hypb.texinfo - Updated with new type. - -Sat Dec 28 05:01:45 1991 Bob Weiner <weiner@infodock.com> - -* hargs.el - hargs:at-p - Fixed completion handling so does not - eliminate prefix portion already in minibuffer when selecting a - path completion entry, e.g. with "~/h/ha" in minibuffer and - "hact.el" chosen, result is "~/h/hact.el". - hargs:read-match - Made always ignore case in matches. - -Thu Dec 26 00:57:39 1991 Bob Weiner <weiner@infodock.com> - -* hact.el - action:act - Added execution of action:act-hook before action. - hypb.texinfo - action:act-hook - Documented. -* hbut.el - hbut:fill-prefix-remove - hbut:fill-prefix-regexps - Added. - hbut:label-to-key - Added removal of fill prefixes within - button labels. - -Wed Dec 25 01:48:24 1991 Bob Weiner <weiner@infodock.com> - -* hbdata.el - hbdata:apply-entry - Added support for explicit buttons in - newsreader summaries. - hmail.el - Added basic newsreader abstract interface, hnews. - hgnus.el - Added to distribution. Hyperbole button support within - GNUS newsreader/poster. - hypb.el - hypb:map-sublists - hypb:function-symbol-replace - Added. - MANIFEST - hsite-ex.el - hypb.texinfo - Updated for addition. - Also changed improper reference of `hyperbole-admin' - mailing address to `hyperbole-request' which is where changes to the - Hyperbole code should be sent. - -Mon Dec 23 02:10:41 1991 Bob Weiner <weiner@infodock.com> - -* hui-menus.el - hui:menu - Fixed problem common with mouse systems - under which one could get multiple activations of Hyperbole menus. - Although, there are some uses for this behavior, it has been - eliminated to remove the aggravation of having to exit from each - menu activation level in turn. - hui:menus - Added Mail> support menu. - hui:menu-act - Fixed bug where func calls with no arg - were interpreted as menu activations. - hui:menu-p - Added flag for testing of menu activation. -* hibtypes.el - grep-msg - Added, jumps to source of grep and error msg lines. - hactypes.el - link-to-file-line - Added. - hypb.texinfo - Documented additions. - -* hypb.texinfo - hui-menus.el - Shortened menu notation and added GBut access menu entry. - -* hact.el - action:path-args-abs - Added. - hmail.el - hmail:composing-dir - Added. - hbdata.el - hbdata:build - Modified arg handling to make paths - absolute when in outgoing mail messages, otherwise, relative paths - would be mailed and misinterpreted. - -Sun Dec 22 00:35:39 1991 Bob Weiner <weiner@infodock.com> - -* MANIFEST - Added "hvm.el" and "hmh.el" to distribution. - hsite-ex.el - Added conditional configuration for Rmail, Mh or Vm setup. - hmail.el - rmail:edit-quit - smail:send - smail:yank - Unused, removed from mail interface. - hsmail.el - Simplified and generalized to support use of - `send-mail-function' variable from "sendmail.el" and to allow use - of the Emacs Lisp archive "mail-plus.el" package which allows multiple - message composure within *mail* buffer. - smail:comment-add - Added to `mail-setup-hook' to automatically - add a comment indicating Hyperbole mail button acceptance on - outgoing mail. - smail:comment - Form to eval to get mail comment. - - hrmail.el - Moved mail reader specific settings of abstract mail - interface variables and functions here from "hmail.el". - hmh.el - Added to support MH mail reader. -* hinit.el - hyperb:init - Moved invocation of `hyperb:init-hook' to - front of init instead of end so hook can influence init sequence - such as the selection of a mail reader to load Hyperbole support for. - var:append - Rewrote to not append if all elements of list - are already a part of variables value. -* hmail.el - rmail:msg-hdrs-full - Added to abstract interface. - rmail:msg-id-get - Changed to call above func. - -Sat Dec 21 21:11:30 1991 Bob Weiner <weiner@infodock.com> - -* hypb.texinfo - hsite-ex.el - Changed sample `hui:ebut-rename' binding from {C-c r} to - {C-c C-r}. - -Fri Dec 20 14:28:14 1991 Bob Weiner <weiner@infodock.com> - -* hbut.el - ibut:at-p - Moved clear of hbut:current to start of function - so `defib' bodies can set button `args' attribute or others. - Also sets `args' from any list elts after first 3 returned by `defib' if - args is not already set. This permits the same argument flexibility as - enjoyed by explicit buttons. - ebut:label-to-key - Rewrote to simplify, remove leading and - trailing space, and to use `hypb:replace-match-string'. - hypb.texinfo - Updated manual to explain this change. - -Thu Dec 19 00:00:11 1991 Bob Weiner <weiner@infodock.com> - -* hmail.el - Conditionalized require of `hrmail' and `hsmail' so they - are only loaded if `hmail:reader' and `hmail:composer' values - indicate that they are needed. -* hmouse-key.el - Rewrote module so that mouse binding conditionals - depend on window system values rather than terminal types so that - when run within a terminal window without mouse support on a window - system, mouse keys are not enabled. - -Wed Dec 18 23:15:17 1991 Bob Weiner <weiner@infodock.com> - -* hbut.el - ibut:at-p - Put key into `lbl-key' attribute rather than label. - hibtypes.el - annot-bib - Changed in file doc and code so ibtypes - always return label rather than key, as documented previously in the - Hyperbole manual. -* hib-kbd.el - kbd-key:normalize - Added removal of "\n" and "C-m" chars. -* hui-menus.el - hui:menu-select - Added "no help" message to prevent - menu items without help strings from quitting menu. - -Sat Dec 14 02:02:36 1991 Bob Weiner <weiner@infodock.com> - -* hsite-ex.el - If hyperb:dir already set when loaded, then don't define it. - - Changed `hui:menu' key binding to use whatever user's - help-map prefix key is. -* hmouse-key.el - Fixed improper placement of ELisp require clauses which - caused load failure of code. - -============================================================================== -V2.02.2 changes ^^^^: -============================================================================== - -Fri Dec 13 01:11:59 1991 Bob Weiner <weiner@infodock.com> - -* All - Added final copyright. -* hargs.el - hargs:iform-read - Bound free variable defaults for - modification when interactive form is an sexpression. -* hactypes.el - exec-shell-cmd - Rewrote to operate asyncronously. - Changed calling protocol somewhat incompatibly since prior second - argument was useless. - link-to-file - Added optional point parameter to allow - jumping to a position in a file. -* hui.el - hui:ebut-rename - Wholly rewrote to allow both in buffer renaming - of buttons and prompted renaming (when called outside of a button). -* hbut.el - ebut:get - Modified to always clear hbut:current attrib list - at beginning, so can later test whether or not button was found. - hui-mouse.el - smart-key-alist - Changed clause that recognizes - explicit buttons to trigger on what looks like a button but is not. - Actions then signal appropriate error. - hbdata.el - hbdata:get-entry - Stopped it from signalling an error. - hui.el - hui:ebut-delete - Added error when no button is found. - hui:hbut-act - Added invalid button error. - hui:hbut-help - Added invalid button error. -* hsite-ex.el - Added note about binding `sm-mouse-toggle-bindings' to a key. -* hmouse-key.el - sm-mouse-get-bindings - sm-mouse-set-bindings - sm-mouse-toggle-bindings - apollo-mouse-key-and-binding - Added these functions. - sm-mouse-bindings - sm-mouse-bindings-p - sm-mouse-previous-bindings - Added these variables. - -Thu Dec 12 19:42:15 1991 Bob Weiner <weiner@infodock.com> - -* hinit.el - Removed def of scroll-{up,down}-eol. - hui-mouse.el - Removed def of scroll-{up,down}-eol. - hmouse-drv.el - Moved def of scroll-{up,down}-eol here. -* hui-mouse.el - smart-key-alist - Moved default context ops to - variables designed to handle them. -* hinit.el - Conditionally required `hmouse-drv' so that - `smart-key-help-show' is always loaded. - -Wed Dec 11 08:24:17 1991 Bob Weiner <weiner@infodock.com> - -* hui.el - hui:ebut-buf - Added exceptional handling of *post-news* buffer. -* hui-mouse.el - smart-key-alist - Added general help buffer screen restore. -* hmouse-drv.el - smart-key-help-show - Added for use with - `temp-buffer-show-hook'. - smart-key-help - Modified to not handle special Smart Key - Help buffer since no longer needed. - *smart-key-help-buf* - Deleted. - *smart-key-screen-config* - Added. - smart-key-summarize - Removed screen config save code. -* hsite-ex.el - temp-buffer-show-hook - Added setting so can restore screen - after any help buffer display by pressing either Smart Key at end of help - buffer. - -Tue Dec 10 18:22:47 1991 Bob Weiner <weiner@infodock.com> - -* hpath.el - hpath:at-p - hpath:is-p - Added `non-exist' flag to allow non-existent paths. -* hargs.el - hargs:at-p - Added recognition of delimited pathnames. - -Mon Dec 9 03:09:09 1991 Bob Weiner <weiner@infodock.com> - -* hib-kbd.el - kbd-key:normalize - Added RET or RTN key code translation. -* hypb - hypb:functionp - Added for use by hypb:replace-match-string. -* hsite-ex.el - Added call to ep:cycle-but-color. -* hibtypes.el - annot-bib - Removed limitation of use only in files named - refs-* or *.bib. -* MANIFEST - README - refs-DEMO - Renamed to DEMO. - -Sun Dec 8 02:22:08 1991 Bob Weiner <weiner@infodock.com> - -* hui-mouse.el - smart-key-alist - Added call to (smart-key-summarize). -* MANIFEST - hmouse-doc - Added. -* hmouse-doc - Added for smart-key-summarize and Hyperbole manual use. -* hmouse-drv.el - smart-key-summarize - Added. -* hsite-ex.el - hyperb:dir - Added var for Hyperbole source dir. -* README - Added section describing mailing lists. -* hact.el - actype:delete - Added. -* hbut.el - ibtype:delete - Added. - -Sat Dec 7 21:23:47 1991 Bob Weiner <weiner@infodock.com> - -* hui-epV4-b.el - ep:cycle-but-color - Reset flash color also. -* hui.el - hui:but-flash - Moved init of button flashing to hsite-ex.el - so button highlight and flash attributes can be customized more - easily. -* hinit.el - hyperb:epoch-p - Moved to hsite-ex.el. - -Thu Dec 5 00:19:35 1991 Bob Weiner <weiner@infodock.com> - -* hargs.el - hargs:at-p - Expanded filename recognition using hpath:at-p. -* hibtypes - pathname - Modified to use hpath:at-p. -* hpath.el - hpath:at-p - Added to recognize double quoted, open and close - single quoted or Texinfo file name references at point. - hpath:is-p - Eliminated bug where default local path case - was not checked for existence. - -Wed Dec 4 19:16:02 1991 Bob Weiner <weiner@infodock.com> - -* hui-ep-but.el - Removed Epoch version-specific code. - hui-epV3-b.el - Added to support Epoch V3 Hyperbole button highlighting. - hui-epV4-b.el - Added to support Epoch V4 Hyperbole button highlighting. - Version-specific code selection is now automatic. -* hinit.el - hyperb:epoch-p - Added variable, enables Epoch support. - Used in hinit.el, hui.el, and hsite-ex.el. - -Tue Dec 3 20:03:42 1991 Bob Weiner <weiner@infodock.com> - -* hui-mouse.el - smart-key-alist - Adapted to support Hyperbole menu help. -* hargs.el - hargs:select-p - hargs:at-p - Adapted to support Hyperbole menu help. -* hypb.el - hypb:help-buf-suffix - Added. -* hmouse-drv.el - smart-key-help - Changed so windows are stored - only if help buffer is not on screen. - -Mon Dec 2 17:08:50 1991 Bob Weiner <weiner@infodock.com> - -* hbut.el - ebut:map - Added missing local binding of var `quoted'. - -Sun Dec 1 19:06:09 1991 Bob Weiner <weiner@infodock.com> - -* hinit.el - hyperb:check-dir-user - Fixed error on some machines where - `hbmap:dir-user' was not created because of trailing slash - in directory name. - -Sat Nov 30 03:00:09 1991 Bob Weiner <weiner@infodock.com> - -* hui-menus.el - hui:menu-help - Added this function to show menu help - messages. - hui:menus - Added help messages. Changed items that invoke - menus to return a cons cell whose car is the symbol `menu' - so no longer makes recursive calls while walking through - menus. - hui:menu-act - Added support for help display and added - simple loop to display each selected menu. - hui:menu-select - Added support for help display via - secondary Smart Key. - hui:menu-top - Changed binding from ESC to C-t so ESC - could be used to enter meta movement keys. - -Fri Nov 29 00:01:40 1991 Bob Weiner <weiner@infodock.com> - -* hargs.el - hargs:at-p - Added support for: - symbol, buffer, character, key, and sexpression, - thus supporting direct selection of all - interactive arg types. - hargs:sexpression-p - Added this private function to - return sexpression at point or nil. -* hui.el - hui:file-find - Documented. - hui:hbut-help - Made error message more appropriate. -* hbmap.el - hbmap:filename - Added this variable. -* hui-menus.el - hui:menus - Renamed `LocalFileShow' to `DirFile' and - show even if does not exist. - Renamed `GlobalPersonalFileShow' to - `PersonalFile' thus changing keys used - to select. - Removed literal `HYPB' from this menu and - made into a user settable variable, - `hbmap:filename'. -* hinit.el - hsite-ex.el - Moved Hyperbole initialization messages here from - hinit.el so that they actually occur at the beginning and end of - init sequence and can be more easily tailored locally. - -Wed Nov 27 01:42:17 1991 Bob Weiner <weiner@infodock.com> - -* hbut.el - hattr:memq - Added, so can test for membership of nil-valued - attributes. - hattr:attributes - Added, so can cache list of attributes. - hattr:list - Changed arg name to `obj-symbol' to generalize. - -Tue Nov 26 05:03:42 1991 Bob Weiner <weiner@infodock.com> - -* hbut.el - ibtype:create - Changed to allow associated action type to - be defined after ibtype. This permits the existence of - ibtypes with invalid actypes but avoids the hard to - understand error of having a loaded ibtype end up undefined. - ebut:map - Added support for ignoring quoted but delimiters. - ebut:label-p - Added `{' and `\' as characters that quote explicit - button delimiters, so they do not register as buttons, used - with texinfo or other formatting. -* hib-kbd.el - kbd-key:normalize - Eliminated use of tmp buffer, made more - efficient, made handle most prefix arg syntax and {ESC ESC} - key sequence. -* hypb.el - hypb:replace-match-string - Added this function. Like - `replace-match' but for strings rather than buffers. -* hinit.el - hyperb:version - Updated to 2.02B. - -============================================================================== -V2.02 changes ^^^^: -============================================================================== - -Tue Nov 26 00:54:17 1991 Bob Weiner <weiner@infodock.com> - -* README-BETA - Reworked for V2.01B. -* hibtypes.el - dir-summary - Added this implicit button type - which displays files from a list in a MANIFEST or DIR - file. - hyp-source - Fixed so lbl-key returned is always a - string and changed so uses `hyp-source' actype. - -* hactypes.el - hyp-source - Added. - -Mon Nov 25 01:13:52 1991 Bob Weiner <weiner@infodock.com> - -* hargs.el - hargs:iform-read - Fixed handling of null default values - so are not converted to strings. This showed up as a - nil default value instead of default-directory's value - when prompting for a file or directory name. -* MANIFEST - Updated with hib-kbd.el, refs-DEMO, hypb.texinfo. -* hactypes.el - link-to-ebut - Fixed missing paren bug in interactive - calling spec. - link-to-Info-node - Added support for Info-directory-list - used in newer versions of Info. -* hpath.el - hpath:absolute-to - Modified to allow a list of directories - to look for file in. -* hbut.el - ibut:at-p - Added setting of `loc' attribute for display - when reporting on implicit buttons. - hbut:source - Corrected to handle quotes around file names. - hbut:label-p - Added optional `pos-flag' parameter which - when non-nil returns a list including button start and end - positions rather than just the label or lbl-key. -* hibtypes.el - annot-bib - Corrected so returns proper key. - pathname - Added new ibtype that recognizes pathnames. -* README - Reworked for public relase. -* hbut.el - ibtype:create - Removed ibtype:create-hook. - htype:create - Added more general htype:create-hook. - htype:delete - Added htype:delete-hook. -* hbut.el - ebut:label-regexp - Added ^M as whitespace character. - -Fri Nov 22 00:40:06 1991 Bob Weiner <weiner@infodock.com> - -* hsmail.el - sendmail-send-it - Removed code to delete sender from - mail list and added conditional which calls - `sendmail-delete-sender' to do this only if that - function has been defined. Thus, users of the standard - sendmail.el package see no behavior change. -* hui.el - hui:ebut-buf - Modified to not drop `*mail*' mail composition - buffer from list of potential button buffers. -* hib-kbd.el - Added this file; makes brace delimited key sequences function - as implicit buttons. -* hibtypes.el - Required hib-kbd. -* hbut.el - Added hbut:{key-src,key-to-label,label-p,label-to-key} aliases - for ebut: functions of same name since these are now used - for more than explicit buttons. - - ebut:label-p - modified doc to account for this change. -* hbut.el - ebut:label-p - Modified to allow `\' quoting of button delim - chars for use in labels. - Also fixed bug where if multiple open delimiters preceded an end - delimiter, first open delimiter was chosen rather than innermost. - Nesting of buttons is not allowed. - -Thu Nov 21 17:03:17 1991 Bob Weiner <weiner@infodock.com> - -* hbut.el - hattr:summarize - Renamed to `hattr:report'. - - hbut:summarize - Renamed to `hbut:report' - to conform to menu-level naming. - Left original names intact for backward compatibility. - Affected: hbut.el, hui-menus.el, and hui.el -* hrmail.el - rmail-get-new-mail - Added missing interactive declaration to - overlay. - -Wed Nov 20 05:04:09 1991 Bob Weiner <weiner@infodock.com> - -* hargs.el - hargs:at-p - Fixed missing paren bug affecting dired and - monkey-mode branches. -* hui-mouse.el - smart-key-alist - Added smart relational DB handling. - -Mon Nov 18 19:18:09 1991 Bob Weiner <weiner@infodock.com> - -* set.el - Modified `set:create' to allow a list of elements as input. -* hui-mouse.el - Added missing `scroll-down-eol' and `scroll-up-eol' functions. - -Sun Nov 17 07:45:21 1991 Bob Weiner <weiner@infodock.com> - -* hui-mouse.el - smart-key-alist - hargs.el - hargs:at-p - Added selection of completion item at point. - -Mon Nov 11 19:06:09 1991 Bob Weiner <weiner@infodock.com> - -* htz.el - Added needed (require 'hypb) to prevent Hyperbole init failure. - hinit.el - Moved (require 'hypb) earlier in list of requires. - -============================================================================== -V2.01B changes ^^^^: -==============================================================================
--- a/lisp/hyperbole/DEMO Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,576 +0,0 @@ -* Overview - -InfoDock Associates, the developer of Hyperbole and InfoDock (an industrial -quality turn-key version of XEmacs), sells high quality commercial support, -training, books and custom package development for InfoDock, XEmacs or GNU -Emacs on a variety of platforms. Contact us at <info@infodock.com> or visit -our web site at http://www.infodock.com. - - ------------------ - -This file demonstrates simple usage of the basic Hyperbole button-action -types and shows how Hyperbole can support a style of self-documenting, -interactive files. See the glossary in the Hyperbole Manual, -"(hyperbole.info)Glossary", if terms used here are unfamiliar to you. - -* Smart Keys - -Hyperbole provides two context-sensitive keys, the Action Key and the Assist -Key, jointly referred to as Smart Keys. The Action Key is the shift-middle -mouse button on a 3-button mouse or shift-left button on a two button mouse -or {M-RET} on your keyboard. The Assist Key is the shift-right mouse button -or {C-u M-RET}. (InfoDock users may also use the middle mouse button as the -Action Key.) - -See also the later section, <(Smart Mouse Keys)>. - - -** Button Activation and Help - -This button prints the <(factorial)> of 5 in the minibuffer when activated -with the Action Key. (Once you have Hyperbole installed, just press the -Action Key on the word, <(factorial)>.) If you instead press the Assist Key, -you get help for the preceding button. The help provides a summary report of -the button. You will see that it utilizes the `eval-elisp' action type. You -can also see who created it. Try it. - -Note that the create-time and mod-time are displayed using your own -timezone but they are stored as universal times. So if you work with -people at other sites, you can mix their buttons with your own within -the same document and see one unified view of the modification times on -each button. These times will also be useful for sorting buttons by -time when such features are provided in future Hyperbole releases. - -** Smart Scrolling - -By default, the variable smart-scroll-proportional is set to t (TRUE). This -makes a press of the Action Key at the end of a line scroll forward, so that -the current line is placed at the top of the window; the Assist Key does the -reverse when pressed at the end of line; it places the current line at the -bottom of the window. This is called proportional scrolling because the -amount of scrolling is relative to the point's position in the window. Try -it and then come back here. - -Alternatively, if this variable is set to nil (FALSE), the Smart Keys scroll -forward or backward a windowful when at the end of a line, regardless of -which line point is on, just as {C-v} and {M-v} do. - -Let's try windowful scrolling a bit. Click this button and then practice -scrolling: <(toggle-scroll-proportional)>. If you prefer the default -proportional scrolling, click on the previous button again to restore it. - -If you always want windowful scrolling, you'll have to add a setting of -smart-scroll-proportional to your "~/.emacs" file after the point at which -you load Hyperbole or else set it as part of hyperb:init-hook, which executes -whenever Hyperbole is loaded, e.g.: - - (setq hyperb:init-hook - (list (function (lambda () (setq smart-scroll-proportional nil))))) - - -** Hyperbole Menus - -To display the top-level Hyperbole menu, click the Action Key anywhere -within this paragraph or alternatively, use {C-h h}. Clicking within the -paragraph, applies the default operation, given by action-key-default-function, -since the Action Key finds no more specialized context. The default -operation happens to bring up the Hyperbole menu. - -{q} or {C-g} will quit from the menu without invoking any commands if you -just want to take a look. A menu item is selected by pressing the Action Key -over it or by typing its first letter in upper or lower case. - -A click of the Assist Key on a menu item gives help on it. - - -** Help Buffers - -Context-sensitive Action Key help typically is bound to {C-h A}. {C-u C-h A} -displays the same kind of help for the Assist Key. Try it. - -Any buffer whose name ends in `Help*' is presumed to be a temporary buffer -that one wants to inspect and then remove from view. If you click either the -Action or Assist Key at the end of a help buffer, the buffer is buried from -view and your window configuration is restored to its state prior to -displaying the help. If you have removed the Smart Key help buffer, bring it -back. Then press one of the Smart Keys at its end to remove it. Note how -your window configuration is restored. - -Remember that this works for any help buffer, whether or not Hyperbole -generated it. - -* Explicit Button Samples - -Hyperbole is pretty forgiving about the format of explicit buttons. For -example, all of the following represent the same button, as long as one -clicks on the *first* line of the button, within the button delimiters: - - <(factorial button)> - - <( factorial button)> - - Pam> <(factorial - Pam> button)> - - ;; <(factorial - ;; button)> - - /* <( factorial */ - /* button )> */ - - -If your <(Info-directory-list)> or <(Info-directory)> variables include the -directory that contains the online GNU Emacs manual, activation of the -next button will tell you about <(keyboard macros)>. Can't remember a -Hyperbole term? Check out the Hyperbole Manual <(glossary)>. - -Here is a <(keyboard macro)> button. It displays documentation for the first -Emacs Lisp function that follows it, e.g. (hbut:report). You can see that a -button label can consist of a number of words, up to a set <(maximum -length)>. - -A <(shell command)> button can do many things, such as display the length of -this file. While such commands are executing, you can perform other -operations. If you create a button that runs a shell command which -displays its own window system window, i.e. a window outside of Emacs, use -`exec-window-cmd' rather than `exec-shell-cmd' as its action type. - -You can link to files such as your <(.login)> file. Or directories, -like the <(tmp directory)>. When creating file links, if the file you -are linking to is loaded in a buffer, you are prompted as to whether you -want the link to jump to the present point in that buffer. If so, the -link will always jump there, so position point within the referent file -to take advantage of this feature. Note how a separate window is used -when you activate file link buttons. Most basic Hyperbole action types -display their results in this manner. - -You can make a button an alias for another by using the `link-to-ebut' -action type. This <(factorial alias)> button does whatever the earlier -<(factorial)> button does. - -The `link-to-mail' action type allows you to reference mail messages -that you have stored away. We can't demonstrate it here since we don't -have the mail messages that you do. - -Hyperbole buttons may also be embedded within mail messages. Even -buttons copied into mail replies can work: - - Emile said: - > - > Hyperbole is better than home baked bread but not as filling. - > The following sample button displays a message, <(as long as - > you click within its first line)>. - - -* Implicit Button Samples - -** Key Sequence Buttons - -Any Emacs key sequence delimited with braces may be executed by -activating it as a button, for example {C-u C-p} should leave point four -lines above the button line. A help request upon the key sequence -displays the documentation for its command binding, i.e. what it does. -If it does not represent a bound key sequence, it will not be -treated as a key sequence button. - -** Implicit Path Links - -Any doubly quoted pathname acts as an implicit button that either displays the -referenced path within a buffer, passes it to an external viewer program, or -runs a function that operates upon the path. These are `pathname' implicit -buttons. For example, activate "README". - -Most pathnames simply link to the files that they name and so are simply -displayed for editing. The variable `hpath:suffixes' is a list of filename -suffix strings that are added to or removed from pathnames when searching for -a match. "So if "README.gz" existed, the pathname button "README" would -display it. If you use the Emacs "crypt.el" package, then compressed files -will be uncompressed before they are displayed. Activate "README.gz" and -you'll see that the README file is displayed as desired. - -The variable `hpath:display-alist' contains pairs of pathname expressions and -edit functions. When a pathname matches an expression, the associated edit -function is invoked upon the pathname. - -The variable `hpath:find-alist' determines the file suffixes which should be -viewed with external programs. It also specifies the associated viewer -program for each different window system under which Hyperbole may be run. -See its documentation for more details. Under the X window system, for -example, if you have the `xv' program, all of the following file formats may -be displayed as images: gif, tiff, xbm, pm, pbm, and jpeg. - -Several prefix characters may be attached to pathnames to indicate that -a different action should be taken when the button is activated. -An exclamation point prefix indicates that the full pathname should be run -as a non-windowed shell program. For example, try "!/bin/date". -An ampersand prefix means run the full pathname as a windowed program, e.g. -"&/usr/bin/X11/xeyes". Finally, a hyphen indicates that the filename should -be evaluated as an Emacs Lisp program, e.g. "-hibtypes.elc", rather than -displayed. - -If you use the ange-ftp or efs add-on to GNU Emacs, such remote pathnames -will work as well. (The latest version of ange-ftp may always be obtained -via anonymous ftp to: - "/anonymous@alpha.gnu.ai.mit.edu:ange-ftp/ange-ftp.tar.gz"). - -Once you have *loaded* the ange-ftp or the efs package (or you use a version -of Emacs 19 which autoloads ange-ftp), if you are on the Internet, you can -click on any of the following to browse the contents of the Hyperbole -distribution at the University of Illinois at Urbana (limit the amount -you do this so as not to deny others access to the archive): - - "/anonymous@ftp.xemacs.org:pub/infodock/" - /anonymous@128.174.252.16:/pub/infodock/ - /ftp.xemacs.org:pub/infodock/ - -You can see that for ange-ftp/efs pathnames, Hyperbole recognizes them with -or without the double quote delimiters. These same pathnames can be used -within explicit buttons which link to files or directories. The HTML -(HyperText Markup Language) ftp pathname format used by World-Wide-Web -browsers is also recognized: - - "ftp://ftp.xemacs.org/pub/infodock/ - - -GNU Info (filename)node references such as "(hyperbole.info)Glossary" or -"(emacs)Glossary", work similarly, thanks to the `Info-node' button type. -Try one of the Glossary buttons above. - -If you want to quickly learn how to create explicit buttons, see -"(hyperbole.info)Drags" and "(hyperbole.info)Menus". - -So now when browsing the many documents that refer to filenames or Info -nodes in this way, you can just click on the name to see the contents. -(If a doubly quoted string references a local pathname that does not -exist within the file system, it will not be considered a pathname -button by Hyperbole.) Pathname implicit buttons provide one example of -how Hyperbole can improve your working environment without you having to -do any work at all. - - -Hyperbole provides a history command which returns you to previous button -locations in the reverse order of the way you traverse them. You access it -by selecting the Hist command from the top-level Hyperbole menu, {C-h h h}. -Remember this because you will want to use that command to return to this -DEMO later. - -Now suppose you want to browse through a number of files within the -Hyperbole distribution. You could use the Emacs dired subsystem, -"(emacs)Dired", but a faster way is to note that files named MANIFEST -and DIR are used to summarize the files in a directory, so we can use -each of their entries as an implicit button (of `dir-summary' type) to -take us to the file. - -Let's look at "MANIFEST". Now click anywhere within a line in the MANIFEST -file and you see that it is displayed as expected. (Remember to use the -Hyperbole history command to return here.) You can get help on these buttons -just like any others. - -Table of contents entries in "README" files act similarly. Click on "README" -to view that file and then click on a table of contents entry to jump to the -associated section in the "README" file. - -** World-Wide-Web URL Buttons - -If you use the w3 World-Wide-Web browser add-on to GNU Emacs, you can browse -URLs (universal resource locators) from within any buffer just as you would -any other implicit button, once you do some initial setup. - -First you must ensure that you load the Hyperbole library that supports URL -viewing. Either your "hsite.el" file should require hsys-w3 as part of -`hibtypes:begin-load-hook' or you should move point after the following line -and hit {C-x C-e} to evaluate it. - - (progn (require 'w3) (require 'hsys-w3)) - -Now try using the Action Key on: - - "http://www.infodock.com" - -** Grep, Occurrence, Debugger and Compiler Error Buttons, and Cscope Analyzer - Lines - -The output of `grep -n', the UNIX line pattern matcher, can be -activated as buttons that jump to each matched line within its source -file; use {M-x grep RET}. - -Compiler error messages also serve as implicit buttons that jump to -associated source lines; use {M-x compile RET}. GDB, DBX or XDB stack frames -along with GDB breakpoint listing lines also link to source lines. - -{M-x occur RET} (find matches in a single buffer) and {M-x moccur RET} -(find matches across multiple buffers and files) also produce implicit -button output that displays associated source lines. - -If you have the Cscope C/C++ code analyzer from the AT&T Toolchest and have -loaded the cscope.el library add-on for GNU Emacs, then the output lines from -a cscope query serve as implicit buttons which jump to associated source -lines. Cscope goes beyond the basic Emacs tags facility to allow you to see -the callers of a function and the functions called by a specific routine. - -** Annotated Bibliography Buttons - -Here's a use of an annotated bibliography reference implicit button -which allows you to see a bibliography entry such as [Stallman 87] when -you activate the button between brackets. - -** Completion Buttons - -Often when Emacs or Hyperbole prompts for an argument in the -minibuffer, a list of possible argument completions is available by -pressing {?}. A single Action Key press on any of these completions -inserts it into the minibuffer for your inspection. A second press on -the same completion causes it to be used as the argument value and any -succeeding argument prompt is then displayed. Test this technique -with a {C-x C-f} (find-file) and then a {?}. - -** Hyperbole Source Buttons - -If you ask for help on the [Stallman 87] button, the first line of the -help buffer will look like this: - -@loc> "DEMO" - -except it will contain the full pathname of the file. If the button -were embedded within a buffer without an attached file, the first line -of the help buffer might look like: - -@loc> #<buffer *scratch*> - -If you click on the buffer name, the buffer will be displayed just as a -file buffer would. This type of implicit button is called a -`hyp-source' button. - -You can also activate any explicit buttons shown in a help buffer. - -** UNIX Man Apropos Buttons - -Below are some lines output by the UNIX `apropos' command (with a little -touchup for display purposes). A button activation anywhere within such -a line recognizes the line as an apropos entry and tries to display the -man page for the entry. Try it. (If you happen to use the `superman' -package which fetches man pages in the background, you'll have to wait -for the next version of superman which removes incompatibilities with -the standard man page fetch command before you can use these -`man-apropos' implicit buttons.) - -grep, egrep, fgrep (1V) - search a file for a string or regular expression -rm, rmdir (1) - remove (unlink) files or directories -touch (1V) - update the access and modification times of a file -cat (1V) - concatenate and display - -** Internet Request For Comments (RFC) Document Browsing - -If you are on the Internet and you have the ange-ftp or efs remote file -handling package for GNU Emacs, you can retrieve and browse RFC documents -used in Internet standard-making. Simply use the Action Key on an RFC -document identifier, like RFC-822. Rfc822 and rfc 822 work as well. The -`rfc' implicit button type provides this service. The `hpath:rfc' variable -specifies the location from which to retrieve RFCs. - -Once you have retrieved an RFC, an Action Key press most anywhere within a -line typically will produce a table of contents summary of the RFC (via the -`rfc-toc' implicit button type). An Action Key press on any of the table of -contents lines then displays that section, for easy random access browsing. - -** Site-specific Online Library Document IDs - -Hyperbole offers a powerful, yet easy to use facility for building online -libraries through the use of the `doc-id' implicit button type. A document id -is used just like a reference citation in traditional publications but -it actually links to the document that it references and the card catalog -(index) entry for the document. One can easily pass around doc ids to point -people to appropriate documents. For example, a mail message in response to -a question might say, "See [Emacs-001] for examples of what Emacs can do." - -Since the format and handling of document identifiers and their index entries -is site-specific, document id handling is not completely configured in a -default Hyperbole configuration. If you wish to setup this facility for -site or personal use, see the DESCRIPTION section in "hib-doc-id.el" for -installation and use information. - - -* Smart Mouse Keys - -If you use Emacs with mouse support under the X window system, NeXTstep, -OpenWindows, SunView, or Apollo's DM window system, Hyperbole automatically -configures your mouse keys for use as Smart Keys and provides additional -display-oriented operations as demonstrated here. - -See the Hyperbole menu item, Doc/SmartKy, for a summary of all Smart Key -operations. For extensive details on Smart Key operation, see the Hyperbole -manual section, "(hyperbole.info)Smart Key Reference". - -When Hyperbole is installed, a key may be bound which allows you to -switch between the Smart Key mouse bindings and your prior ones. `C-h w -hmouse-toggle-bindings RTN' should show you any key which performs this -command. If no key binding has been established or if you prefer one of -your own, simply select a key and bind it within your "~/.emacs" file. -For example, (global-set-key "\C-ct" 'hmouse-toggle-bindings). - - -** Context-sensitive Help - -Since the Smart Keys perform different operations in different contexts, it -is important to have context-sensitive help available. The earlier section -on Help Buffers explained how to display such help from the keyboard. The -same help can be displayed using the mouse by depressing the Smart Key for -which you want help, performing any action necessary to register a context, -such as a drag motion, and then pressing the other Smart Key. - -Here is an example. Depress the Action Key somewhere within this paragraph -and while holding it down, depress the Assist Key. Then release the keys in -any order and the help display will pop up. It explains that there was no -particular matching Smart Key context, so a default operation is performed -(the value of the variable `action-key-default-function' determines the -operation performed). - -** Scrolling to the Beginning and End of Buffers - -A left to right horizontal drag of the Action Key of 5 or more characters -scrolls the current buffer to its end (what {M->} does by default). A right -to left drag of the Action Key does the opposite; it scrolls to the buffer's -beginning (what {M-<} does by default). Try out these operations and then -use the Smart Key end of line scrolling capability to return here. - -** Creating and Deleting Windows - -Horizontal and vertical drags of the Assist Key within a single window can be -used to create and delete Emacs windows. - -A horizontal drag of five or more characters from left to right creates a new -window by splitting the current window into two windows, one on top of the -other. A horizontal drag from right to left deletes the current window. A -vertical drag in either direction splits the current window into two -side-by-side windows. - -Let's try these. Remember to use your Assist Key. You need only move your -mouse pointer a few characters to register a drag. First, split this window -with a left to right drag, then delete either one of the windows with a right -to left drag. - -Now try a side-by-side window split. Drag vertically in the up or down -direction three or more lines to split the window and then use a right to -left drag to delete either one of the side-by-side windows. - -** Resizing Windows - -You can easily resize Emacs windows by dragging their window separators -(modelines or vertical side lines) within a frame. Simply depress either -Smart Key on a modeline or near a window side, hold it down while you drag to -a new location and then release. The window separator will then jump to the -location of release. Basically, just drag the window separator to where you -want it. If you want a single window to fill an entire frame, drag its -modeline, and if necessary its side, to the edge of the frame. - -Did you follow all that? Let's try it to be sure. First, you need at least -two windows, so create a new one with the drag techniques you just learned. -Now drag with either Smart Key from the shared window edge to a new location. -See how both windows change size? - -Try to drag the bottom modeline. You see that you can't. - -** Swapping Buffers - -Swapping buffer locations is quick and easy with Hyperbole. Simply drag -from one window to another with the Assist Key. - -Split the current window into two, one above the other. Drag the upper -modeline so that one window is clearly bigger than the other. Now try -dragging from inside one window to another with the Assist Key. - -** Modeline Clicks - -Window modelines are treated specially be Hyperbole. They are broken up into -three regions, each with their own Smart Key operations. The regions are: -the left edge, the right edge, and the middle portion (the non-edge part of -the modeline). The edge regions are the left or rightmost three characters -of the modeline, by default. - -*** Switching to Another Buffer - -An Action Key click in the left edge of a modeline buries the current buffer, -i.e. puts it on the bottom of the buffer list and removes it from view, if it -is not the only available buffer. An Assist Key click in the left edge of a -modeline unburies the bottom buffer. Repeated clicks of either key allow you -to cycle through buffers to get to the one you want. Try this out. - -*** Displaying Documentation - -An Action Key click in the right edge of a modeline displays the Info manual -browsing system, see "(info)". Once in Info, you can click with your Action -Key to follow menu items, cross references, or to jump to Info nodes -referenced within the top header line of a node. Try browsing a bit and -while in Info display context-sensitive help for both the Action and Assist -Keys to see all that they can do. - -If you click again with the Action Key on the right edge of the window -displaying Info, it will hide the Info buffer. Thus, it works as a toggle to -display or to hide the Info buffer. Try it. - -A click of the Assist Key at the right edge of a modeline toggles between -display and removal of a Smart Key operation summary. To remove the summary, -you must click on the modeline of the window displaying the summary. - - -*** Buffer Menu Display - -An Action Key click in the center portion of a modeline displays a buffer -menu, a summary of available buffers. An Action Key click on any buffer menu -line then displays that buffer. - -This behavior is subject to change in the future if a more useful Action Key -operation is found for the middle of modelines. - - -** Saving and Restoring Window Configurations - -A window configuration consists of the set of windows within a single Emacs -frame. This includes their locations, buffers, and scrolled positions of -their buffers. - -Hyperbole allows you to save and restore window configurations with simple -diagonal mouse drags within a single window. A diagonal drag in any -direction of the Action Key saves the current window configuration to a ring -of window configurations, just like the Emacs text kill ring. (See -"(Emacs)Kill Ring".) Each diagonal drag in any direction of the Assist Key -restores a prior saved window configuration from the ring. Window -configurations are restored in reverse order of the way they were saved. -Since a ring is circular, after the oldest element is restored, the newest -element will again be restored and so on. - -If these operations are unclear to you, just forget about them and move on. -They are not necessary to enjoy the rest of Hyperbole. Otherwise, give them -a try by creating various window configurations and then saving and restoring -them. - -* Outliner - -The Hyperbole outliner only works under GNU Emacs version 19 or higher and -XEmacs version 19.9 or higher. You can tell whether you are running a -version of Emacs which supports the outliner by hitting -@{@kbd{C-h h}@} to display the Hyperbole menu. If you see an -@code{Otl/} entry in the menu, then the outliner is available. -Otherwise, the outliner does not work with your version of Emacs, so -this section of the DEMO will not be of interest to you. - -The Hyperbole outliner produces structured, autonumbered documents -composed of hierarchies of cells. Each cell has two identifiers, a -relative autonumber indicating its present position within the outline -and a permanent identifier suitable for use within hyperlink references -to the cell. - -If the outliner works in your Emacs, see "kotl/EXAMPLE.kotl", an outline file -that explains how to operate the outliner. Use the @code{Otl/Example} menu -entry to display this file. Additional documentation can be found in -"(hyperbole.info)Outliner". "(hyperbole.info)Outliner Keys" -summarizes in alphabetical order the outliner commands which are bound -to keys. - - -* References - -[Stallman 87] Stallman, Richard. GNU Emacs Manual. Free Software -Foundation, Cambridge: MA, March 1987. - -* THE END
--- a/lisp/hyperbole/Makefile Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,269 +0,0 @@ -# -# SUMMARY: Build Hyperbole directories and distributions. -# -# AUTHOR: Bob Weiner -# -# ORIG-DATE: 15-Jun-94 at 03:42:38 -# LAST-MOD: 18-Mar-97 at 00:45:58 by Bob Weiner -# -# This file is part of Hyperbole. -# Available for use and distribution under the same terms as GNU Emacs. -# -# Copyright (C) 1994-1995, Free Software Foundation, Inc. -# Developed with support from Motorola Inc. -# -# DESCRIPTION: -# -# USAGE: Emacs V19, configure Hyperbole for use in current directory: -# make -# Rebuild out of date Emacs V19 Lisp .elc files: -# make -# If you really want to rebuild all .elc files under Emacs 19: -# make all-elc -# Emacs V18 and Epoch, rebuild Hyperbole in current directory: -# make all-elc-v18 -# Build out of date Emacs V18 Lisp .elc files: -# make elc-v18 -# -# DESCRIP-END. - -########################################################################## -# CONFIGURABLE SECTION # -########################################################################## - -# Executables for various versions of Emacs. Ensure that the name following -# the equals sign is correct for the version of emacs to which you set the -# EMACS variable. -EMACS19 = emacs19 -EMACS18 = emacs -EPOCH = epoch -INFODOCK = infodock.bin -XEMACS = xemacs - -# Emacs version used to byte-compile .el files into .elc's. -EMACS = $(XEMACS) - -# Where to install the Hyperbole mouse key help file. -datadir = ../../etc -# Where to install the Info version of the Hyperbole manual. -infodir = ../../info -# Where to find the .texi source for the Hyperbole manual. -mandir = ../../man -# Where to install the Texinfo version of the Hyperbole manual. -texidir = ../../man - -# Site-specific Emacs Lisp libraries to load before byte-compiling any files -# from this package. Typically the only reason to set this is to get Emacs -# to include the directory of this package into its load-path variable, which -# determines where it will find Lisp library files to load. -# -# InfoDock and XEmacs 19.12 or higher include this package and automatically -# add its directory to load-path. Under Emacs 19, if you add this directory -# to load-path in your site-lisp/site-start.el file, then you need not change -# this setting since site-start is automatically loaded whenever Emacs starts -# up. If, however, you set load-path in your personal ~/.emacs file, you -# must add that to this setting. -# -# You must include the .el or .elc file suffix on each library name and each -# must be preceded by the `-l ' command-line flag. If the directory in which -# the library is stored will not be in your Emacs load-path when Emacs -# attempts to load the library, you must include the full pathname to the -# library. Here is an example setting. -# -# SITE_PRELOADS = -l ~/.emacs -l set-load-path.el -# -SITE_PRELOADS = - -# Temp file to use to build .elc files. -ELISP_TO_COMPILE = /tmp/elc-${USER} - -# Shell used to process this Makefile. Bourne shell syntax is required. -SHELL = /bin/sh - -# UNIX commands you may want to change for your particular system. -CP = \cp -p -DVIPS = \dvips -ETAGS = etags -INSTALL = install -c -MAKE = make -MAKEINFO = \makeinfo --fill-column 74 -MV = \mv -f -RM = \rm -f -TAR = tar - -# Directory in which to create new distributions of Hyperbole. -DIST_DIR = /tmp - -########################################################################## -# NO CHANGES REQUIRED BELOW HERE. # -########################################################################## - -HYPB_VERSION = 4.023 - -# Libraries that must be pre-loaded before trying to byte-compile anything. -PRELOADS = $(SITE_PRELOADS) -l ./hversion.el -l ./hyperbole.el -l ./hsite.el - -# Compile in batch mode. Under Emacs 19 and XEmacs, load -# site-lisp/site-start.el, which may set load-path. -BATCHFLAGS = -batch - -# Directories other than the current directory in which to find files. -# This doesn't seem to work in all versions of make, so we also add kotl/ -# explicitly to those files which need it. -VPATH = kotl - -EL_SRC = hsite.el hui-em19-b.el hui-ep-but.el hui-epV4-b.el hui-xe-but.el - -EL_COMPILE = hact.el hactypes.el hargs.el hbdata.el hbmap.el hbut.el \ - hgnus.el hhist.el hib-doc-id.el hib-kbd.el hibtypes.el \ - hinit.el hlvar.el hmail.el hmh.el hmoccur.el hmous-info.el \ - hmouse-drv.el hmouse-key.el hmouse-mod.el hmouse-reg.el \ - hmouse-sh.el hmouse-tag.el hpath.el hrmail.el hsmail.el \ - hsys-hbase.el hsys-w3.el hsys-wais.el \ - htz.el hui-menu.el hui-mini.el hui-mouse.el hui-window.el \ - hui.el hvar.el hversion.el hvm.el hypb.el hyperbole.el \ - set.el wconfig.el wrolo-logic.el wrolo-menu.el wrolo.el - -EL_KOTL = kotl/kfile.el kotl/kfill.el kotl/kimport.el kotl/klabel.el \ - kotl/klink.el kotl/kmenu.el kotl/knode.el kotl/kotl-mode.el \ - kotl/kotl.el kotl/kproperty.el kotl/kprop-em.el \ - kotl/kprop-xe.el kotl/kview.el kotl/kvspec.el - -ELC_COMPILE = hactypes.elc hibtypes.elc hib-kbd.elc hib-doc-id.elc hact.elc \ - hargs.elc hbdata.elc hbmap.elc hbut.elc hgnus.elc hhist.elc \ - hinit.elc hlvar.elc hmail.elc hmh.elc hmoccur.elc hmous-info.elc \ - hmouse-drv.elc hmouse-key.elc hmouse-mod.elc hmouse-reg.elc \ - hmouse-sh.elc hmouse-tag.elc hpath.elc hrmail.elc hsmail.elc \ - hsys-hbase.elc hsys-w3.elc hsys-wais.elc \ - htz.elc hui-menu.elc hui-mini.elc hui-mouse.elc hui-window.elc \ - hui.elc hvar.elc hversion.elc hvm.elc hypb.elc hyperbole.elc \ - set.elc wconfig.elc wrolo-logic.elc wrolo-menu.elc wrolo.elc - -ELC_KOTL = kotl/kfile.elc kotl/kfill.elc kotl/kimport.elc kotl/klabel.elc \ - kotl/klink.elc kotl/kmenu.elc kotl/knode.elc kotl/kotl-mode.elc \ - kotl/kotl.elc kotl/kproperty.elc \ - kotl/kprop-xe.elc kotl/kview.el kotl/kvspec.elc - -EL_TAGS = $(EL_SRC) $(EL_COMPILE) $(EL_KOTL) - -.SUFFIXES: # Delete the default suffixes -.SUFFIXES: .el .elc # Define the list of file suffixes to match to rules - -# Install Hyperbole for use in current directory under Emacs 19. -all: elc - -doc: info ps - -install: elc doc - cd $(mandir); $(INSTALL) hypb-mouse.txt $(datadir); \ - $(INSTALL) hyperbole.info* $(infodir); \ - $(INSTALL) hyperbole.texi $(texidir) - -install-v18: - $(MAKE) EMACS="$(EMACS18)" VPATH="" EL_KOTL="" ELC_KOTL="" install - -# Record any .el files that need to be compiled. -.el.elc: - @ echo $< >> $(ELISP_TO_COMPILE) - -# Compile all recorded .el files. -elc: elc-init hsite.el $(ELC_KOTL) $(ELC_COMPILE) $(XEMACS_COMPILE) - @- \test ! -f $(ELISP_TO_COMPILE) \ - || (echo "These files will be compiled: " \ - && echo "`cat $(ELISP_TO_COMPILE)`" \ - && $(EMACS) $(BATCHFLAGS) $(PRELOADS) \ - -f batch-byte-compile `cat $(ELISP_TO_COMPILE)`) - @ $(RM) $(ELISP_TO_COMPILE) - -elc-init: - @ $(RM) $(ELISP_TO_COMPILE) - -elc-v18: - $(MAKE) EMACS="$(EMACS18)" VPATH="" EL_KOTL="" ELC_KOTL="" elc - -all-v19: all-elc install - -all-v18: all-elc-v18 install-v18 - -# Remove and then rebuild all byte-compiled .elc files for V19 Emacs, even -# those .elc files which do not yet exist. -all-elc: hsite.el - $(RM) *.elc kotl/*.elc - $(EMACS) $(BATCHFLAGS) $(PRELOADS) -f batch-byte-compile $(EL_KOTL) $(EL_COMPILE) - -# Remove and then rebuild all byte-compiled .elc files for V18 Emacs. -# The kotl/ files are not used under V18 so they are not rebuilt. -all-elc-v18: - $(MAKE) EMACS="$(EMACS18)" VPATH="" EL_KOTL="" ELC_KOTL="" all-elc - -# This creates the site-specific hsite.el file from hsite-ex.el if necessary. -hsite.el: hsite-ex.el - \test -f hsite.el || $(CP) hsite-ex.el hsite.el - -dvi: $(mandir)/hyperbole.dvi - -info: $(infodir)/hyperbole.info - -ps: $(mandir)/hyperbole.ps - -$(mandir)/hyperbole.dvi: info - cd $(mandir); tex hyperbole.texi; \ - texindex hyperbole.??; tex hyperbole.texi - -$(infodir)/hyperbole.info: $(mandir)/hyperbole.texi - cd $(mandir); $(MAKEINFO) hyperbole.texi - -$(mandir)/hyperbole.ps: $(mandir)/hyperbole.texi - make $(mandir)/hyperbole.dvi - -$(RM) $(mandir)/hyperbole.ps - cd $(mandir); $(DVIPS) -o hyperbole.ps hyperbole.dvi - -tags: $(EL_TAGS) - $(ETAGS) $(EL_TAGS) h-skip-bytec.lsp - -clean: - -$(RM) core .place* .*~ *~ *\# *.orig *.rej .nfs* - -cd kotl; $(RM) core .*~ *~ *\# *.orig *.rej .place* .nfs* - -cd $(mandir); $(RM) core .*~ *~ *\# *.orig *.rej .place* .nfs* - -version: - fgrep $(HYPB_VERSION) Makefile README hversion.el \ - $(mandir)/hyperbole.texi; echo "" - -# Don't use this target. -bw-install: - cd /home/infodock/lisp/; \ - tar zxvf /tmp/hyperbole-$(HYPB_VERSION).tar.gz; \ - cd hyperbole/; \ - mv man/hyperbole.info* ../../info/; mv man/hyperbole.texi ../../man/; \ - mv man/hypb-mouse.txt ../../etc/; rm -rf man - -dist: version elc info - echo "Ensure version # in README, hversion.el, Makefile and man/hyperbole.texi is up to date." - cd ..; $(TAR) clf $(DIST_DIR)/h.tar hyperbole; \ - $(CP) ../etc/ida-logo.xpm $(DIST_DIR); \ - $(RM) -r $(DIST_DIR)/hman; mkdir $(DIST_DIR)/hman; \ - $(CP) ../man/hyperbole.texi ../info/hyperbole.info* \ - ../etc/hypb-mouse.txt $(DIST_DIR)/hman - $(RM) -r $(DIST_DIR)/hyperbole - cd $(DIST_DIR); $(TAR) xf h.tar; \ - $(MV) hman hyperbole/man; $(MV) ida-logo.xpm hyperbole - cd $(DIST_DIR)/hyperbole; make distclean -# This ver setup won't work under SunOS for some reason. -# ver="`head -3 hyperbole/hversion.el | tail -1 | sed -e 's/.*|//'`" - cd $(DIST_DIR); $(RM) h.tar ver; \ - $(TAR) --gzip -clf hyperbole-$(HYPB_VERSION).tar.gz hyperbole - -# Don't run this target manually. Use 'make dist' instead. -distclean: clean - -$(RM) TAGS hsite.el* kotl/TO-DO* $(mandir)/hyperbole.dvi \ - $(mandir)/hyperbole.?? - -autoloads: auto-autoloads.el - -auto-autoloads.el: $(EL_SRC) $(EL_COMPILE) $(EL_KOTL) - $(EMACS) -batch -q -no-site-file \ - -eval '(setq autoload-target-directory "'`pwd`'/")' \ - -eval '(setq autoload-package-name "hyperbole")' \ - -l autoload \ - -f batch-update-autoloads $?
--- a/lisp/hyperbole/README Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,714 +0,0 @@ -# See "hversion.el" for the Hyperbole lisp code directory entry. -# -# FILE: README -# SUMMARY: Information Hyperbole users and maintainers should read. -# -# AUTHOR: Bob Weiner -# -# ORG: InfoDock Associates. We sell corporate support and development -# contracts for InfoDock, Emacs and XEmacs. -# E-mail: <info@infodock.com> Web: http://www.infodock.com -# Tel: +1 408-243-3300 -# -# ORIG-DATE: 19-Oct-91 at 03:27:47 -# LAST-MOD: 17-Mar-97 at 21:14:10 by Bob Weiner -# -# See the Copyright section below for license information. - -We thank Motorola Inc. for sponsoring our initial development work on -Hyperbole. - -We hope you enjoy using and developing with Hyperbole. Suggestions -and bug reports are welcome, as described later in this document. -Feel free to mail or post news containing this file wherever it may be -of use. - - -=========================================================================== -* Table of Contents -=========================================================================== - * Hyperbole Overview - * What's New - * How to Obtain - * Installation / Configuration - * Quick Reference - * Mail Lists - * User Quotes - * Why was Hyperbole developed? - * Copyright - - -=========================================================================== -* Hyperbole Overview -=========================================================================== - -Hyperbole is an open, efficient, programmable information management and -hypertext system. It is intended for everyday work on any UNIX platform -supported by GNU Emacs. It works well with the versions of Emacs that -support MS-Windows, X or NEXTSTEP windows: XEmacs and GNU Emacs. - -Hyperbole allows hypertext buttons to be embedded within unstructured and -structured files, mail messages and news articles. It offers intuitive -mouse-based control of information display within multiple windows. It also -provides point-and-click access to Info manuals, ftp archives, Wide-Area -Information Servers (WAIS), and the World-Wide Web (WWW) hypertext system -through encapsulations of software that support these protocols. - -Hyperbole consists of four parts: - - 1. Info Management: an interactive information management interface, - including a powerful rolodex, which anyone can use. It is easy - to pick up and use since it introduces only a few new mechanisms - and provides user-level facilities through a menu interface, - which you control from the keyboard or the mouse; - - 2. Hypertext Outliner: an outliner with multi-level autonumbering - and permanent ids attached to each outline node for use as - hypertext link anchors, plus flexible view specifications that - can be embedded within links or used interactively; - - 3. Button Types: A set of hyper-button types that provides - core hypertext and other behaviors. Users can make simple - changes to button types and those familiar with Emacs Lisp can - quickly prototype and deliver new types; - - 4. Programming Library: a set of programming library classes for - system developers who want to integrate Hyperbole with another - user interface or as a back-end to a distinct system. (All of - Hyperbole is written in Emacs Lisp for ease of modification. - Although Hyperbole was initially designed as a prototype, it has - been engineered for real-world usage and is well structured.) - -A Hyperbole user works with buttons; he may create, modify, -move or delete buttons. Each button performs a specific action, such as -linking to a file or executing a shell command. - -There are three categories of Hyperbole buttons: - - 1. Explicit Buttons - created by Hyperbole, accessible from within a single document; - - 2. Global Buttons - created by Hyperbole, accessible anywhere within a user's - network of documents; - - 3. Implicit Buttons - buttons created and managed by other programs or embedded - within the structure of a document, accessible from within a - single document. Hyperbole recognizes implicit buttons by - contextual patterns given in their type specifications. - -Hyperbole buttons may be clicked upon with a mouse to activate them or -to describe their actions. Thus, a user can always check how a button -will act before activating it. Buttons may also be activated from a -keyboard. (In fact, virtually all Hyperbole operations, including menu -usage, may be performed from any standard character terminal interface, so -one need not be anchored to a workstation all day). - -Hyperbole does not enforce any particular hypertext or information management -model, but instead allows you to organize your information in large or small -chunks as you see fit. The Hyperbole outliner organizes information -hierarchies which may also contain links to external information sources. - -Some of Hyperbole's most important features include: - - Buttons may link to information or may execute procedures, such as - starting or communicating with external programs; - - One simply drags between a button source location and a link destination - to create or to modify a link button. The same result can be achieved - from the keyboard. - - Buttons may be embedded within electronic mail messages; - - Outlines allow rapid browsing, editing and movement of chunks of - information organized into trees (hierarchies); - - Other hypertext and information retrieval systems may be - encapsulated under a Hyperbole user interface (a number of samples - are provided). - -Typical Hyperbole applications include: - - Personal Information Management - Overlapping link paths provide a variety of views into an - information space. - - A search facility locates buttons in context and permits quick - selection. - - Documentation Browsing - Embed cross-references in your favorite documentation format. - - Add a point-and-click interface to existing documentation. - - Link code and design documents. Jump to the definition of an - identifier from its use within code or its reference within - documentation. - - Brainstorming - Capture ideas and then quickly reorganize them with the Hyperbole - outliner. Link to related ideas, eliminating the need to copy - and paste information into a single place. - - Help/Training Systems - Create tutorials with embedded buttons that show students how - things work while explaining the concepts, e.g. an introduction - to UNIX commands. This technique can be much more effective than - descriptions alone. - - Archive Managers - Supplement programs that manage archives from incoming - information streams by having them add topic-based buttons that - link to the archive holdings. Users can then search and create - their own links to archive entries. - - -=========================================================================== -* What's New in V4.02-V4.023 -=========================================================================== - - (See "ChangeLog" for more complete details of changes.) - - ACTION AND ASSIST KEYS - - - Action Key clicks on HTTP URLs use the Emacs internal web browser - if not running under a window system. - - - Support for new ID-edit mode (a part of InfoDock) that allows rapid, - cutting, copying and yanking of regions plus fast display management. - In this mode, the Action and Assist keys yank the previously selected - region at point. - - - An Action Key press on a Java identifier jumps to its definition - (if an associated TAGS file or OO-Browser environment exists). The - same is true for an `@see' cross-reference within a Java comment. The - variable, `smart-java-package-dirs,' determines where Java package - source can be found when the OO-Browser is not in use. - - - An Action Key press on a double or single quoted Emacs Lisp filename - (without any path) displays the file by looking for it among the - directories in the variable, `load-path'. - - - If the Action Key is pressed on a function identifier that is defined - in the same buffer as the reference clicked upon, it will now be - displayed faster, since the func-menu package will be used. The - reference identifier will also flash when pressed, if the display - device supports this. - - EMACS VERSIONS - - - Further support for MS-DOS, Windows NT Emacs 19, and Win-Emacs. - - - Fixed configuration setup problem when running Emacs 19 on a dumb - terminal. - - KOUTLINER - - - XEmacs 19.14 and above: Fixed display of current viewspec in the - modeline to accomodate modeline extents (specialized modeline regions). - This eliminated an error that occurred when reading in an Koutline file. - - - Fixed bug that prevented installation of Koutliner mode-specific - menubar when running InfoDock. - - MENUS - - - New Hyperbole/About menu item added. In minibuffer menus, this item is - found under the Doc/ menu. - - - New window system menu, Hyperbole/Customization (and minibuffer menu, - Cust/) added to set Hyperbole options, including where Hyperbole link - referents are displayed, where URLs are displayed and whether to use - proportional or windowful scrolling when a Smart Key is pressed at the - end of a line. - - - The default setting of where Hyperbole link references are displayed - may be set in "hsite.el" via the variable, `hpath:display-where' - (after Hyperbole has been installed using `make install'). - See its documentation for detail. - - - The Hyperbole/Global-Button menu now includes a menu item that will - activate each existing global button. The Hyperbole/Explicit-Button - menu does the same thing for explicit buttons in the current buffer. - - ROLODEX - - - Date stamps are added to each rolodex entry when created and updated - when edited. This feature can be toggled on and off with: - M-x rolo-toggle-datestamps RET, or via the Toggle-Rolodex-Dates menu - item on the Customization menu. - - - wrolo-add-hook is called after a new entry is added. - wrolo-edit-hook is called after an entry is displayed for editing. - - - Rolo-edit, bound to {e} in the rolodex match buffer, now works properly - if the rolodex is loaded before the rest of the Hyperbole system. - - -=========================================================================== -* How to Obtain -=========================================================================== - -InfoDock Associates, the developer of Hyperbole and InfoDock (an industrial -quality turn-key version of XEmacs), is a firm dedicated to radical -productivity improvement in technical environments, whether in software -development or other knowledge intensive disciplines. Our initial offerings -include high quality commercial support, training, books and custom package -development for InfoDock, XEmacs or GNU Emacs on a variety of platforms. -InfoDock provides a modern user interface on top of Emacs, information -management, and powerful software development tools, all in one package. - -Contact us at <info@infodock.com> or visit our web site at -http://www.infodock.com. - -Hyperbole is available as part of InfoDock or XEmacs and also as a standalone -package via anonymous ftp across the Internet. Do not send requests to have -it mailed to you since it won't be. Instead have another party who has -Internet access obtain it for the both of you. - -Here is how to obtain Hyperbole as a standalone package on the Internet: - -Move to a directory below which you want the 'hyperbole' directory to -be created. Unpacking the Hyperbole archive will create this -directory and place all of the files below it. - - cd <LOCAL-LISP-DIR> - -Ftp to ftp.xemacs.org (Internet Host ID = 128.174.252.16): - - prompt> ftp ftp.xemacs.org (If this doesn't work, try `ftp xemacs.org'.) - -Login as 'anonymous' with your own <user-id>@<site-name> as a password. - - Name (ftp.xemacs.org): anonymous - 331 Guest login ok, send EMAIL address (e.g. user@host.domain) as password. - Password: - 230 Guest login ok, access restrictions apply. - -Move to the Hyperbole directory: - - ftp> cd /pub/infodock - -Set your transfer mode to binary: - - ftp> bin - 200 Type set to I. - -Turn off prompting: - - ftp> prompt - Interactive mode off. - -Retrieve just the Hyperbole archive and any diff-based patches (there may not -be any patches): - - ftp> mget hyperbole* - -Close the ftp connection: - - ftp> quit - 221 Goodbye. - -Unpack the tar archive using the GNU version of the 'zcat' program: - - zcat h*tar.gz | tar xvf - -or - gunzip h*tar.gz; tar xvf h*tar - -Apply any patches you retrieved, also: - - cd hyperbole; patch < <patch-file> - - -=========================================================================== -* Installation / Configuration -=========================================================================== - -The following explains how to Use the Hyperbole "Makefile" to compile any -needed code, to generate the "hsite.el" file used for site-specific Hyperbole -customization, and to produce printable documentation. - -Edit the line near the top of "Makefile" that represents the emacs version -that you use, so that it corresponds to the emacs executable name used on -your system. Then immediatly below there, set the EMACS variable to the -variable name for the emacs that you will use to compile the Hyperbole Lisp -files. - -You may also have to set the SITE-PRELOADS variable defined further down -in the file; follow the instructions that precede the `SITE-PRELOADS =' -line. Make these changes now and save the Makefile. - -To install Hyperbole for use with InfoDock, XEmacs, GNU Emacs or Epoch, from -a shell: - - cd <HYPERBOLE-DIR>; make - -All of the .elc compiled Lisp files are already built for XEmacs and V19, so -this build will finish very quickly. If you really want to rebuild all of -the .elc files, use: - - cd <HYPERBOLE-DIR>; make all-elc - -To produce the Postscript version of the Hyperbole manual: - - cd <HYPERBOLE-DIR>; make ps - -To install Hyperbole for use with GNU Emacs V18 or Epoch: - - cd <HYPERBOLE-DIR>; make all-elc-v18 - -This will produce a complete set of Emacs V18 .elc files. - ----- - -The Hyperbole Manual is included in two forms: - - "man/hyperbole.info" - online version - "man/hyperbole.texi" - source form - -To add pointers to the Info version of the Hyperbole manual within your Info -directory, follow these instructions. If `Info-directory-list' is bound as a -variable within your Emacs, you can simply set it so that <HYPERBOLE-DIR> is -an element in the list. Otherwise, from a shell, cd to the directory given -by your 'Info-directory' variable and execute the following command: - - (rm hyperbole.info*; cp <HYPERBOLE-DIR>/man/hyperbole.info* .) - -Then add an Info menu entry for the Hyperbole manual in your Info "dir" file: -(the `*' should be placed in the first column of the file): - - * Hyperbole:: GNU Emacs-based everyday information management system. - Use {C-h h d d} for a demonstration. Includes context-sensitive - mouse and keyboard support, a powerful rolodex, an autonumbered - outliner with hyperlink anchors for each outline cell, and extensible - hypertext facilities including hyper-links in mail and news messages. - ----- - -To set up so that all Emacs users have Hyperbole loaded for them, add the -following lines to a site initialization file such as "site-start.el". -Otherwise, each user will have to add these lines to his own "~/.emacs" -initialization file. The following instructions use the term -<HYPERBOLE-DIR>/ to refer to your hyperbole/ directory, so substitute your -own value. - -To autoload Hyperbole so that it loads only when needed: - - (defvar hyperb:dir "<HYPERBOLE-DIR>/") - "Directory where the Hyperbole executable code is kept. -It must end with a directory separator character.") - - (load (expand-file-name "hversion" hyperb:dir)) - (load (expand-file-name "hyperbole" hyperb:dir)) - -To fully load Hyperbole upon startup, add the additional line: - - (require 'hsite) - -That's all there is to the installation. - ----- - -Once Hyperbole has been installed for use at your site, you can invoke it -with {C-h h} or {M-x hyperbole RET} to bring up the Hyperbole main menu in -the minibuffer window. - - -=========================================================================== -* Quick Reference -=========================================================================== - -"MANIFEST" summarizes most of the files in the distribution. - -See "DEMO" for a demonstration of standard Hyperbole button -capabilities. - -Naming conventions: - - - All Hyperbole-specific code files begin with an 'h', aside from the - Koutliner files which are in the kotl/ subdirectory and begin with a 'k'. - - - Hyperbole user-interface files begin with 'hui-' or 'hmous'. - - - Files that define implicit button types begin with 'hib'. - - - Encapsulations of foreign systems begin with 'hsys-'. - -Most of the standard Emacs user interface for Hyperbole is located in -"hui.el". Most of the Hyperbole application programming interface can be -found in "hbut.el". "hbdata.el" encapsulates the button attribute storage -handling presently implemented by Hyperbole. "hmail.el" provides a basic -abstract interface for folding mail readers other than Rmail into Hyperbole. - -See the "(hyperbole.info)Questions and Answers" appendix in the -Hyperbole manual for information on how to alter the default -context-sensitive Hyperbole key bindings. - - -=========================================================================== -* Mail Lists -=========================================================================== - -There are several Hyperbole-related mail addresses. Learn what each is -for before you mail to any of them. - -<hyperbole-request@infodock.com> -<hyperbole-announce-request@infodock.com> - - ALL mail concerning administration of the Hyperbole mailing lists should - be sent to the appropriate one of these addresses. That includes - addition, change, or deletion requests. Don't consider sending such a - request to a Hyperbole mail list or people will wonder why you don't know - that all Internet mail lists have a -request address for administrative - requests. - - Use the following formats in the *body* of your message to execute requests, - where you substitute your own values for the <> delimited items and items - enclosed in [] are optional. - - subscribe <mail-list-name> [<your-email-address>] - or - unsubscribe <mail-list-name> [<your-email-address>] - - For example: - - To: hyperbole-request@infodock.com - Subject: Used if a human happens to read your mail. - - subscribe hyperbole joe@nowhere.gov - - To change your address, you must unsubscribe your old address with - once command and subscribe your new address with another command, though - you can embed multiple commands on separate lines within a single message. - - -There are two Hyperbole-related mail lists. Subscribe to one or the other, -not to both. - -<hyperbole@infodock.com> - - Mail list for discussion of all Hyperbole issues. Bug reports and - suggestions may also be sent here. - - Always use your Subject and/or Summary: lines to state the position - that your message takes on the topic that it addresses, e.g. send - "Subject: Basic bug in top-level minibuffer menu." rather than - "Subject: Hyperbole bug". Statements end with periods, questions - with question marks (typically), and high energy, high impact - declarations with exclamation points. This simple rule makes all - e-mail communication much easier for recipients to handle - appropriately. - - If you ask a question, your subject line should end with a '?', - e.g. "Subject: How can man page SEE ALSOs be made implicit buttons?" A - "Subject: Re: How can ..." then indicates an answer to the question. - Question messages should normally include your Hyperbole and Emacs version - numbers and clearly explain your problem and surrounding issues. - Otherwise, you will simply waste the time of those who may want to help - you. (Your top-level Hyperbole menu shows its version number and {M-x - emacs-version RET} gives the other.) - - If you ask questions, you should consider adding to the discussion by - telling people the kinds of work you are doing or contemplating doing - with Hyperbole. In this way, the list will not be overwhelmed by - messages that ask for, but provide no information. - -<hyperbole-announce@infodock.com> - - Those who don't want to participate in the discussion but want to - hear about bug fixes and new releases of Hyperbole should subscribe - to this list. Anyone on the `hyperbole' list is automatically on - this one too, so there is no need to subscribe to this one in that - case. This list is for official fixes and announcements so don't send - your own fixes here. Send them to `hyperbole' instead. - - -=========================================================================== -* User Quotes -=========================================================================== - - - *** MAN I love Hyperbole!!! Wow! *** - - -- Ken Olstad - Cheyenne Software, Inc. - -------- - - I *love* koutlines. - - -- Bob Glickstein - Z-Code Software Corporation -------- - - I've found Hyperbole (in conjunction with XEmacs) to be very useful - for signal processing algorithm development. - - For me, it has almost completely obsoleted the engineering notebook: - I keep a set of files with ideas, algorithms, and results, linked - together and to the implementation in C++ files. Using XEmacs' - support for embedding graphics, I've written a mode that accepts - image tags (formatted like HTML), and reads in GIF files to display - plots. I have another program that converts the file to HTML (not - perfect, but adequate), so I can put any aspect of development on - our internal web for others to see. - - -- Farzin Guilak - Protocol Systems, Inc., Engineer - -------- - - I am blind and have been using Hyperbole since 1992. I used to use a PC as - a talking terminal attached to a UNIX system, but then I developed - Emacspeak which lets me use Emacs and Hyperbole from standard UNIX - workstations with an attached voice synthesizer. - - My main uses are: - 1) Global and implicit buttons for jumping to ftp sites. - 2) The rolodex with Emacspeak support. - 3) Explicit buttons as part of comments made about a structured document. - Each button jumps to the document section referred to by the comment. - This is very, very useful. - 4) The Hyperbole outliner, which I find a very useful tool. I've - implemented Emacspeak extensions to support it. - - -- TV Raman - Digital Cambridge Research Lab - -------- - - I've been a grateful Hyperbole user for a few years now. Hyperbole's - flexibility and ease of use is a marvel. - - Mainly, I write easy little implicit button types (and corresponding action - types) to make my life easier. For example, I have an implicit button type - to bury certain buffers when I click at their bottoms, one that recognizes - a bug report record in various contexts and edits it, one that links pieces - of test output in a log file to the corresponding test case source code - (EXTREMELY helpful in interpreting test output), others that support our - homegrown test framework, one that handles tree dired mode the way I'd - like, one that completely handles wico menus (I've also overloaded the - wconfig actions triggered by diagonal mouse drags with wicos actions), and - a couple that support interaction with BBDB. - - Other than that, I keep a global button file with 30 or so explicit buttons - that do various little things, and I index saved mail messages by putting - explicit link-to-mail buttons in an outline file. - - -- Ken Olstad - Cheyenne Software, Inc. - -------- - - In general, Hyperbole is an embeddable, highly extensible hypertext - tool. As such, I find it very useful. As it stands now, Hyperbole is - particularly helpful for organizing ill-structured or loosely coupled - information, in part because there are few tools geared for this purpose. - Hyperbole also possesses a lot of potentials in supporting a wider - spectrum of structuredness, ranging from unstructured to highly - structured environments, as well as structural changes over time. - - Major Uses: - - * Menu interface to our own Epoch-based collaborative support environment - called CoReView: This interface brings together all top-level user - commands into a single partitioned screen, and allows the end user to - interact with the system using simple mouse-clicking instead of the - meta-x key. - - * Gateway to internet resources: this includes links to major Internet - archive sites of various types of information. Links are made at both - directory and file levels. - - * Alternative directory organizer: The hierarchical nature of the Unix - file system sometimes makes it difficult to find things quickly and - easily using directory navigational tools such as dired. Hyperbole - enables me to create various "profile" views of my directory tree, with - entries in these views referring to files anywhere in the hierarchy. - - * Organizing and viewing online documentation: using Hyperbole along with - Hyper-man and Info makes it truly easy to look up online documentation. - - * Other desktop organization tasks: including links to various mail - folders, saved newsgroup conversation threads, online note-taker, - emacs-command invocations, etc. - - -- Dadong Wan - -------- - - Hyperbole is the first hyper-link system I've run across that is - actually part of the environment I use regularly, namely Emacs. The - complete flexibility of the links is both impressive and expected -- the - idea of making the link itself programmable is clever, and given that one - assumes the full power of Emacs. Being able to send email with buttons - in it is a very powerful capability. Using ange-ftp mode, one can make - file references "across the world" as easily as normal file references. - - -- Mark Eichin - Cygnus Support -------- - - I just wanted to say how much I enjoy using the Hyperbole outliner. - It is a great way to quickly construct very readable technical documents - that I can pass around to others. Thanks for the great work. - - -- Jeff Fried - Informix - -------- - - The Hyperbole system provides a nice interface to exploring corners of - Unix that I didn't know existed before. - - -- Craig Smith - -------- - - -=========================================================================== -* Why was Hyperbole developed? -=========================================================================== - -Hyperbole has been designed to aid in research aimed at Personalized -Information production/retrieval Environments (PIEs). Hyperbole is a -PIE Manager that provides services to PIE Tools. PIEmail, a mail reader is -the only PIE Tool developed to date. - -An examination of many hypertext environments as background research did -not turn up any that seemed suitable for the research envisioned, mainly -due to the lack of rich, portable programmer and user environments. We also -tired of trying to manage our own distributed information pools with standard -UNIX tools. And so Hyperbole was conceived and raved about until it -got its name. - - -=========================================================================== -* Copyright -=========================================================================== - -The following copyright applies to the Hyperbole system as a whole. - -Copyright (C) 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996 Free Software Foundation, Inc. - -Available for use and distribution under the terms of the GNU Public License, -version 2 or higher. - -Hyperbole is free software; you can use it, redistribute it and/or modify it -without fee 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. - -Hyperbole 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. - -InfoDock Associates sells support and development services for this package -and most other aspects of Emacs or InfoDock. Contact information is at the -top of this file. - -You should have received a copy of the GNU General Public License -along with GNU Emacs, XEmacs or InfoDock; see the file COPYING. If -not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, -MA 02139, USA.
--- a/lisp/hyperbole/auto-autoloads.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,346 +0,0 @@ -;;; DO NOT MODIFY THIS FILE -(if (featurep 'hyperbole-autoloads) (error "Already loaded")) - -;;;### (autoloads (hmail:compose) "hmail" "hyperbole/hmail.el") - -(autoload 'hmail:compose "hmail" "\ -Compose mail with ADDRESS and evaluation of EXPR. -Optional SUBJECT and HELP message may also be given." t nil) - -;;;*** - -;;;### (autoloads (Info-handle-in-note smart-info-assist smart-info) "hmous-info" "hyperbole/hmous-info.el") - -(autoload 'smart-info "hmous-info" "\ -Walks through Info documentation networks using one key or mouse key. - -If key is pressed within: - (1) the first line of an Info Menu Entry or Cross Reference, the desired node - is found; - (2) the Up, Next, or Previous entries of a Node Header (first line), - the desired node is found; - (3) the File entry of a Node Header (first line), - the 'Top' node within that file is found; - (4) at the end of the current node, the Next node is found (this will - descend subtrees if the function 'Info-global-next' is bound); - (5) anywhere else (e.g. at the end of a line), the current node entry is - scrolled up one windowful. - -Returns t if key is pressed within an Info Node Header, Cross Reference, -or a Menu; otherwise returns nil." t nil) - -(autoload 'smart-info-assist "hmous-info" "\ -Walks through Info documentation networks using one assist-key or mouse assist-key. - -If assist-key is pressed within: - (1) the first line of an Info Menu Entry or Cross Reference, the desired node - is found; - (2) the Up, Next, or Previous entries of a Node Header (first line), - the last node in the history list is found; - (3) the File entry of a Node Header (first line), - the 'DIR' root-level node is found; - (4) at the end of the current node, the Previous node is found (this will - return from subtrees if the function 'Info-global-prev is bound); - (5) anywhere else (e.g. at the end of a line), the current node entry is - scrolled down one windowful. - -Returns t if assist-key is pressed within an Info Node Header, Cross Reference, -or a Menu; otherwise returns nil." t nil) - -(autoload 'Info-handle-in-note "hmous-info" "\ -Follows an Info cross-reference. -If point is within the first line of an Info note (cross-reference), follows -cross-reference and returns t; otherwise returns nil." nil nil) - -;;;*** - -;;;### (autoloads (hkey-help-show) "hmouse-drv" "hyperbole/hmouse-drv.el") - -(autoload 'hkey-help-show "hmouse-drv" "\ -Saves prior frame configuration if BUFFER displays help. Displays BUFFER. - -Optional second arg CURRENT-WINDOW non-nil forces display of buffer within -the current window. By default, it is displayed in another window." nil nil) - -;;;*** - -;;;### (autoloads (smart-tags-file smart-tags-file-path smart-objc smart-lisp-mode-p smart-java-at-tag-p smart-java smart-fortran-at-tag-p smart-c++ smart-c-at-tag-p smart-asm-at-tag-p) "hmouse-tag" "hyperbole/hmouse-tag.el") - -(autoload 'smart-asm-at-tag-p "hmouse-tag" "\ -Return assembly tag name that point is within, else nil." nil nil) - -(autoload 'smart-c-at-tag-p "hmouse-tag" "\ -Return C tag name that point is within, else nil." nil nil) - -(autoload 'smart-c++ "hmouse-tag" "\ -Jumps to the definition of optional C++ IDENTIFIER or the one at point. -Optional second arg NEXT means jump to next matching C++ tag. - -It assumes that its caller has already checked that the key was pressed in an -appropriate buffer and has moved the cursor to the selected buffer. - -If: - (1) on a `#include' statement, the include file is displayed; - Look for include file in directory lists `smart-c-cpp-include-dirs' - and `smart-c-include-dirs'. - (2) on a C++ identifier, the identifier definition is displayed, - assuming the identifier is found within an `etags' generated tag file - in the current directory or any of its ancestor directories. - (3) if `smart-c-use-lib-man' is non-nil, the C++ identifier is - recognized as a library symbol, and a man page is found for the - identifier, then the man page is displayed." t nil) - -(autoload 'smart-fortran-at-tag-p "hmouse-tag" "\ -Return Fortran tag name that point is within, else nil." nil nil) - -(autoload 'smart-java "hmouse-tag" "\ -Jumps to the definition of optional Java IDENTIFIER or the one at point. -Optional second arg NEXT means jump to next matching Java tag. - -It assumes that its caller has already checked that the key was pressed in an -appropriate buffer and has moved the cursor to the selected buffer. - -If: - (1) within a commented @see cross-reference, the referent is displayed; - (2) on a `package' or `import' statement, the referent is displayed; - Look for referent files in the directory list `smart-java-package-dirs'. - (3) on an Java identifier, the identifier definition is displayed, - assuming the identifier is found within an `etags' generated tag file - in the current directory or any of its ancestor directories." t nil) - -(autoload 'smart-java-at-tag-p "hmouse-tag" "\ -Return Java tag name that point is within, else nil." nil nil) - -(autoload 'smart-lisp-mode-p "hmouse-tag" "\ -Return t if in a mode which uses Lisp symbols." nil nil) - -(autoload 'smart-objc "hmouse-tag" "\ -Jumps to the definition of optional Objective-C IDENTIFIER or the one at point. -Optional second arg NEXT means jump to next matching Objective-C tag. - -It assumes that its caller has already checked that the key was pressed in an -appropriate buffer and has moved the cursor to the selected buffer. - -If: - (1) on a `#include' statement, the include file is displayed; - Look for include file in directory lists `smart-c-cpp-include-dirs' - and `smart-c-include-dirs'. - (2) on an Objective-C identifier, the identifier definition is displayed, - assuming the identifier is found within an `etags' generated tag file - in the current directory or any of its ancestor directories. - (3) if `smart-c-use-lib-man' is non-nil, the Objective-C identifier is - recognized as a library symbol, and a man page is found for the - identifier, then the man page is displayed." t nil) - -(autoload 'smart-tags-file-path "hmouse-tag" "\ -Expand relative FILE name by looking it up in the nearest tags file. -Return FILE unchanged if it exists relative to the current directory or -cannot be expanded via a tags file." nil nil) - -(autoload 'smart-tags-file "hmouse-tag" "\ -Return appropriate tags file name for CURR-FILENAME or `tags-file-name'. -Optional NAME-OF-TAGS-FILE is the literal filename for which to look." nil nil) - -;;;*** - -;;;### (autoloads (hyperbole) "hui-mini" "hyperbole/hui-mini.el") - -(autoload 'hyperbole "hui-mini" "\ -Invokes default Hyperbole menu user interface when not already active. -Suitable for binding to a key, e.g. {C-h h}. -Non-interactively, returns t if menu is actually invoked by call, else nil. - -Two optional arguments may be given to invoke alternative menus. -MENU (a symbol) specifies the menu to invoke from MENU-LIST, (a -Hyperbole menu list structure). MENU defaults to 'hyperbole and MENU-LIST -to `hui:menus'. See `hui:menus' definition for the format of the menu list -structure." t nil) - -;;;*** - -;;;### (autoloads (var:append) "hvar" "hyperbole/hvar.el") - -(autoload 'var:append "hvar" "\ -Appends to value held by VAR-SYMBOL-NAME, LIST-TO-ADD. Returns new value. -If VAR-SYMBOL-NAME is unbound, it is set to LIST-TO-ADD. -Often used to append to 'hook' variables." nil nil) - -;;;*** - -;;;### (autoloads (hypb:display-file-with-logo hypb:configuration) "hypb" "hyperbole/hypb.el") - -(autoload 'hypb:configuration "hypb" "\ -Insert Emacs configuration information at the end of optional OUT-BUF or the current buffer." nil nil) - -(autoload 'hypb:display-file-with-logo "hypb" "\ -Display an optional text FILE with the InfoDock Associates logo prepended. -Without file, logo is prepended to the current buffer." nil nil) - -;;;*** - -;;;### (autoloads nil "hyperbole" "hyperbole/hyperbole.el") - -(defvar action-key-url-function 'w3-fetch "\ -Value is a function of one argument, a url, which displays the url referent. -Possible values are: - w3-fetch - display using the W3 Emacs web browser; - highlight-headers-follow-url-netscape - display in Netscape; - highlight-headers-follow-url-mosaic - display in Mosaic.") - -(defvar kimport:mode-alist '((t . kimport:text) (outline-mode . kimport:star-outline)) "\ -Alist of (major-mode . importation-function) elements. -This determines the type of importation done on a file when `kimport:file' is -called if the major mode of the import file matches the car of an element in -this list. If there is no match, then `kimport:suffix-alist' is checked. If -that yields no match, the element in this list whose car is 't is used. It -normally does an import of a koutline or text file. - -Each importation-function must take two arguments, a buffer/file to import -and a buffer/file into which to insert the imported elements and a third -optional argument, CHILDREN-P, which when non-nil means insert imported cells -as the initial set of children of the current cell, if any. - - outline-mode - imported as an Emacs outline whose entries begin with - asterisks; - .kot - .kotl - imported as a structured koutline - - all others - imported as text.") - -(defvar kimport:suffix-alist '(("\\.otl$" . kimport:star-outline) ("\\.aug$" . kimport:aug-post-outline)) "\ -Alist of (buffer-name-suffix-regexp . importation-function) elements. -This determines the type of importation done on a file when `kimport:file' is -called. Each importation-function must take two arguments, a buffer/file to -import and a buffer/file into which to insert the imported elements and a -third optional argument, CHILDREN-P, which when non-nil means insert imported -cells as the initial set of children of the current cell, if any. - - .otl - imported as an Emacs outline whose entries begin with asterisks; - .kot - .kotl - imported as a structured koutline - .aug - imported as an Augment post-numbered outline.") - -;;;*** - -;;;### (autoloads (wconfig-yank-pop wconfig-ring-save wconfig-delete-pop wconfig-restore-by-name wconfig-delete-by-name wconfig-add-by-name) "wconfig" "hyperbole/wconfig.el") - -(autoload 'wconfig-add-by-name "wconfig" "\ -Saves the current window configuration under the string NAME. -When called interactively and a window configuration already exists under -NAME, confirms whether or not to replace it." t nil) - -(autoload 'wconfig-delete-by-name "wconfig" "\ -Deletes window configuration saved under NAME." t nil) - -(autoload 'wconfig-restore-by-name "wconfig" "\ -Restores window configuration saved under NAME." t nil) - -(autoload 'wconfig-delete-pop "wconfig" "\ -Replaces current window config with most recently saved config in ring. -Then deletes this new configuration from the ring." t nil) - -(autoload 'wconfig-ring-save "wconfig" "\ -Saves the current window configuration onto the save ring. -Use {\\[wconfig-yank-pop]} to restore it at a later time." t nil) - -(autoload 'wconfig-yank-pop "wconfig" "\ -Replaces current window config with prefix arg Nth prior one in save ring. -Interactively, default value of N = 1, meaning the last saved window -configuration is displayed. - -The sequence of window configurations wraps around, so that after the oldest -one comes the newest one." t nil) - -;;;*** - -;;;### (autoloads (rolo-logic) "wrolo-logic" "hyperbole/wrolo-logic.el") - -(autoload 'rolo-logic "wrolo-logic" "\ -Apply FUNC to all entries in optional IN-BUFS, display entries where FUNC is non-nil. -If IN-BUFS is nil, 'rolo-file-list' is used. If optional COUNT-ONLY is -non-nil, don't display entries, return count of matching entries only. If -optional INCLUDE-SUB-ENTRIES flag is non-nil, FUNC will be applied across all -sub-entries at once. Default is to apply FUNC to each entry and sub-entry -separately. Entries are displayed with all of their sub-entries unless -INCLUDE-SUB-ENTRIES is nil and optional NO-SUB-ENTRIES-OUT flag is non-nil. -FUNC should use the free variables 'start' and 'end' which contain the limits -of the region on which it should operate. Returns number of applications of -FUNC that return non-nil." t nil) - -;;;*** - -;;;### (autoloads (rolo-yank rolo-toggle-datestamps rolo-sort rolo-kill rolo-grep rolo-fgrep rolo-edit rolo-display-matches rolo-add) "wrolo" "hyperbole/wrolo.el") - -(autoload 'rolo-add "wrolo" "\ -Adds a new entry in personal rolodex for NAME. -Last name first is best, e.g. \"Smith, John\". -With prefix argument, prompts for optional FILE to add entry within. -NAME may be of the form: parent/child to insert child below a parent -entry which begins with the parent string." t nil) - -(autoload 'rolo-display-matches "wrolo" "\ -Display optional DISPLAY-BUF buffer of previously found rolodex matches. -If DISPLAY-BUF is nil, use the value in `rolo-display-buffer'. -Second arg RETURN-TO-BUFFER is the buffer to leave point within after the display." t nil) - -(autoload 'rolo-edit "wrolo" "\ -Edits a rolodex entry given by optional NAME within `rolo-file-list'. -With prefix argument, prompts for optional FILE to locate entry within. -With no NAME arg, simply displays FILE or first entry in `rolo-file-list' in an -editable mode. NAME may be of the form: parent/child to edit child below a -parent entry which begins with the parent string." t nil) - -(autoload 'rolo-fgrep "wrolo" "\ -Display rolodex entries matching STRING. -To a maximum of optional prefix arg MAX-MATCHES, in file(s) from optional -ROLO-FILE or rolo-file-list. Default is to find all matching entries. Each -entry is displayed with all of its sub-entries. Optional COUNT-ONLY non-nil -means don't retrieve and don't display matching entries. Optional NO-DISPLAY -non-nil means retrieve entries but don't display. - -Nil value of MAX-MATCHES means find all matches, t value means find all matches -but omit file headers, negative values mean find up to the inverse of that -number of entries and omit file headers. - -Returns number of entries matched. See also documentation for the variable -rolo-file-list." t nil) - -(autoload 'rolo-grep "wrolo" "\ -Display rolodex entries matching REGEXP. -To a maximum of prefix arg MAX-MATCHES, in buffer(s) from optional ROLO-BUFS or -rolo-file-list. Default is to find all matching entries. Each entry is -displayed with all of its sub-entries. Optional COUNT-ONLY non-nil means don't -retrieve and don't display matching entries. Optional NO-DISPLAY non-nil -means retrieve entries but don't display. - -Nil value of MAX-MATCHES means find all matches, t value means find all matches -but omit file headers, negative values mean find up to the inverse of that -number of entries and omit file headers. - -Returns number of entries matched. See also documentation for the variable -rolo-file-list." t nil) - -(autoload 'rolo-kill "wrolo" "\ -Kills a rolodex entry given by NAME within `rolo-file-list'. -With prefix argument, prompts for optional FILE to locate entry within. -NAME may be of the form: parent/child to kill child below a parent entry -which begins with the parent string. -Returns t if entry is killed, nil otherwise." t nil) - -(autoload 'rolo-sort "wrolo" "\ -Sorts up to 14 levels of entries in ROLO-FILE (default is personal rolo). -Assumes entries are delimited by one or more `*'characters. -Returns list of number of groupings at each entry level." t nil) - -(autoload 'rolo-toggle-datestamps "wrolo" "\ -Toggle whether datestamps are updated when rolodex entries are modified. -With optional ARG, turn them on iff ARG is positive." t nil) - -(autoload 'rolo-yank "wrolo" "\ -Inserts at point the first rolodex entry matching NAME. -With optional prefix arg, REGEXP-P, treats NAME as a regular expression instead -of a string." t nil) - -;;;*** - -(provide 'hyperbole-autoloads)
--- a/lisp/hyperbole/file-newer Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,9 +0,0 @@ -#!/usr/local/bin/perl -#file-newer: Return 1 if file 1 is newer than file 2, else 0 - -$cmp = (stat($ARGV[0]))[9] - (stat($ARGV[1]))[9]; -if ($cmp > 0) - { print "1"; } -else - { print "0"; } -
--- a/lisp/hyperbole/h-skip-bytec.lsp Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,84 +0,0 @@ -;;!emacs -;; -;; FILE: h-skip-bytec.lsp -;; SUMMARY: Functions that should not be byte-compiled. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: mouse, hypermedia -;; -;; AUTHOR: Bob Weiner -;; ORG: Motorola, Inc., PPG -;; -;; ORIG-DATE: 8-Oct-92 at 17:17:10 -;; LAST-MOD: 9-May-95 at 16:18:42 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1992-1995, Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; -;; DON'T byte-compile this file or its functions may not work. -;; If we knew why they won't work, they wouldn't be in here. -;; -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -;;; For some reason, using this in byte-compiled form causes first character -;;; after mouse key depress to be dropped from input queue when running -;;; Emacs under X. The non-byte-compiled form works fine. - -(defun hmouse-set-point (args) - "Sets point to Smart Key press/release location given by ARGS. -Returns argument list including x and y frame coordinates in characters and -lines." - (and (car args) (listp (car args)) (setq args (car args))) - (if (not hyperb:window-system) - (point-marker) - (let ((point-args (hmouse-set-point-at args))) - (cond (hyperb:xemacs-p - (if (eventp current-mouse-event) - (copy-event current-mouse-event))) - (hyperb:lemacs-p - (cond ((and (fboundp 'mouse-position) - ;; mouse-position returns nil coords when not over - ;; existing text within a window, so we can only use - ;; its coordinates when non-nil. It returns a cons - ;; of (device X . Y) in chars. We drop the device - ;; and assume the selected frame. - (car (cdr (setq point-args (mouse-position))))) - (cdr point-args)) - ((and (fboundp 'read-mouse-position) - ;; read-mouse-position returns nil coords when not - ;; over existing text within a window, so we can - ;; only use its coordinates when non-nil. It - ;; returns a cons of (X . Y) in chars. - (car (setq point-args (read-mouse-position - (selected-frame))))) - point-args) - (t - ;; We just compute X and Y from event's location. - (cons (event-x current-mouse-event) - (event-y current-mouse-event))))) - (hyperb:epoch-p - ;; Modeline clicks return nil for point position so we - ;; must compute it instead of using the arguments given. - (let ((x-char (/ (* mouse::x (window-width)) - (window-pixwidth))) - (y-char (/ (* mouse::y (window-height)) - (window-pixheight)))) - (apply 'list x-char y-char args))) - ((or (equal hyperb:window-system "next") - (equal hyperb:window-system "sun")) - (let ((win (car args))) - (list win - (+ (nth 1 args) (nth 0 (window-edges win))) - (+ (nth 2 args) (nth 1 (window-edges win)))))) - ((equal hyperb:window-system "apollo") point-args) - (t args))))) - -(provide 'h-skip-bytec)
--- a/lisp/hyperbole/hact.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,222 +0,0 @@ -;;!emacs -;; -;; FILE: hact.el -;; SUMMARY: Hyperbole button action handling. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: hypermedia -;; -;; AUTHOR: Bob Weiner -;; ORG: Brown U. -;; -;; ORIG-DATE: 18-Sep-91 at 02:57:09 -;; LAST-MOD: 14-Apr-95 at 15:57:11 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1991-1995, Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Other required Elisp libraries -;;; ************************************************************************ - -(require 'hhist) - -;;; ************************************************************************ -;;; Public variables -;;; ************************************************************************ - -(defvar hrule:action 'actype:act - "Value is a function of any number of arguments that executes actions. -Variable is used to vary actual effect of evaluating a Hyperbole action, -e.g. to inhibit actions.") - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -;;; ======================================================================== -;;; action class -;;; ======================================================================== - -(defun action:commandp (function) - "Return interactive calling form if FUNCTION has one, else nil." - (let ((action - (cond ((null function) nil) - ((symbolp function) - (and (fboundp function) - (hypb:indirect-function function))) - ((and (listp function) - (eq (car function) 'autoload)) - (error "(action:commandp): Autoload not supported: %s" function)) - (t function)))) - (if (hypb:v19-byte-code-p action) - (cond ((fboundp 'compiled-function-interactive) - (compiled-function-interactive action)) - ((commandp action) - (list 'interactive (aref action 5)))) - (commandp action)))) - -(defun action:create (param-list body) - "Create an action defined by PARAM-LIST and BODY, a list of Lisp forms." - (if (symbolp body) - body - (list 'function (cons 'lambda (cons param-list body))))) - -(defun action:kbd-macro (macro &optional repeat-count) - "Returns Hyperbole action that executes a keyboard MACRO REPEAT-COUNT times." - (list 'execute-kbd-macro macro repeat-count)) - -(defun action:params (action) - "Returns unmodified ACTION parameter list." - (cond ((null action) nil) - ((symbolp action) - (car (cdr - (and (fboundp action) (hypb:indirect-function action))))) - ((listp action) - (if (eq (car action) 'autoload) - (error "(action:params): Autoload not supported: %s" action) - (car (cdr action)))) - ((hypb:v19-byte-code-p action) - (if (fboundp 'compiled-function-arglist) - (compiled-function-arglist action) - ;; Turn into a list for extraction - (car (cdr (cons nil (append action nil)))))))) - -(defun action:param-list (action) - "Returns list of actual ACTION parameters (removes '&' special forms)." - (delq nil (mapcar - (function - (lambda (param) - (if (= (aref (symbol-name param) - 0) ?&) - nil param))) - (action:params action)))) - -(defun action:path-args-abs (args-list &optional default-dirs) - "Return any paths in ARGS-LIST made absolute. -Uses optional DEFAULT-DIRS or 'default-directory'. -Other arguments are returned unchanged." - (mapcar (function (lambda (arg) (hpath:absolute-to arg default-dirs))) - args-list)) - -(defun action:path-args-rel (args-list) - "Return any paths in ARGS-LIST below current directory made relative. -Other paths are simply expanded. Non-path arguments are returned unchanged." - (let ((dir (hattr:get 'hbut:current 'dir))) - (mapcar (function (lambda (arg) (hpath:relative-to arg dir))) - args-list))) - - -;;; ======================================================================== -;;; actype class -;;; ======================================================================== - -(defmacro hact (&rest args) - "Performs action formed from rest of ARGS. -First arg may be a symbol or symbol name for either an action type or a -function. Runs 'action:act-hook' before performing action." - (eval (` (cons 'funcall (cons 'hrule:action (quote (, args))))))) - -(defun actype:act (actype &rest args) - "Performs action formed from ACTYPE and rest of ARGS and returns value. -If value is nil, however, t is returned instead, to ensure that implicit button -types register the performance of the action. ACTYPE may be a symbol or symbol -name for either an action type or a function. Runs 'action:act-hook' before -performing ACTION." - ;; Needed so relative paths are expanded properly. - (setq args (action:path-args-abs args)) - (let ((prefix-arg current-prefix-arg) - (action (actype:action actype)) - (act '(apply action args))) - (if (null action) - (error "(actype:act): Null action for: '%s'" actype) - (let ((hist-elt (hhist:element))) - (run-hooks 'action:act-hook) - (prog1 (or (cond ((or (symbolp action) (listp action) - (hypb:v19-byte-code-p action)) - (eval act)) - ((and (stringp action) - (let ((func (key-binding action))) - (if (not (integerp action)) - (setq action func)))) - (eval act)) - (t (eval action))) - t) - (hhist:add hist-elt)) - )))) - -(defun actype:action (actype) - "Returns action part of ACTYPE (a symbol or symbol name). -ACTYPE may be a Hyperbole actype or Emacs Lisp function." - (let (actname) - (if (stringp actype) - (setq actname actype - actype (intern actype)) - (setq actname (symbol-name actype))) - (cond ((htype:body (if (string-match "^actypes::" actname) - actype - (intern-soft (concat "actypes::" actname))))) - ((fboundp actype) actype) - ))) - -(defmacro actype:create (type params doc &rest default-action) - "Creates an action TYPE (an unquoted symbol) with PARAMS, described by DOC. -The type uses PARAMS to perform DEFAULT-ACTION (list of the rest of the -arguments). A call to this function is syntactically the same as for -'defun', but a doc string is required. -Returns symbol created when successful, else nil." - (list 'htype:create type 'actypes doc params default-action nil)) - -(fset 'defact 'actype:create) -(put 'actype:create 'lisp-indent-function 'defun) - -(defun actype:delete (type) - "Deletes an action TYPE (a symbol). Returns TYPE's symbol if it existed." - (htype:delete type 'actypes)) - -(defun actype:doc (hbut &optional full) - "Returns first line of act doc for HBUT (a Hyperbole button symbol). -With optional FULL, returns full documentation string. -Returns nil when no documentation." - (let* ((act (and (hbut:is-p hbut) (or (hattr:get hbut 'action) - (hattr:get hbut 'actype)))) - (but-type (hattr:get hbut 'categ)) - (sym-p (and act (symbolp act))) - (end-line) (doc)) - (cond ((and but-type (fboundp but-type) - (setq doc (htype:doc but-type))) - ;; Is an implicit button, so use its doc string if any. - ) - (sym-p - (setq doc (htype:doc act)))) - (if (null doc) - nil - (setq doc (substitute-command-keys doc)) - (or full (setq end-line (string-match "[\n]" doc) - doc (substring doc 0 end-line)))) - doc)) - -(defun actype:identity (&rest args) - "Returns list of ARGS unchanged or if no ARGS, returns t. -Used as the setting of 'hrule:action' to inhibit action evaluation." - (or args t)) - -(defun actype:interact (actype) - "Interactively calls default action for ACTYPE. -ACTYPE is a symbol that was previously defined with 'defact'. -Returns nil only when no action is found or the action has no interactive -calling form." - (let ((action (htype:body - (intern-soft (concat "actypes::" (symbol-name actype)))))) - (and action (action:commandp action) (or (call-interactively action) t)))) - -(defun actype:params (actype) - "Returns list of ACTYPE's parameters." - (action:params (actype:action actype))) - -(provide 'hact)
--- a/lisp/hyperbole/hactypes.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,503 +0,0 @@ -;;!emacs -;; -;; FILE: hactypes.el -;; SUMMARY: Default action types for Hyperbole. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: extensions, hypermedia -;; -;; AUTHOR: Bob Weiner -;; ORG: InfoDock Associates -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1991-1997 Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; ORIG-DATE: 23-Sep-91 at 20:34:36 -;; LAST-MOD: 20-Feb-97 at 11:16:36 by Bob Weiner - -;;; ************************************************************************ -;;; Other required Elisp libraries -;;; ************************************************************************ - -(mapcar 'require '(hbut hpath hargs hact hmail)) - -;;; ************************************************************************ -;;; Standard Hyperbole action types -;;; ************************************************************************ - -(defact annot-bib (key) - "Follows internal ref KEY within an annotated bibliography, delimiters=[]." - (interactive "sReference key (no []): ") - (let ((opoint (point)) - (key-regexp (concat "^[*]*[ \t]*\\\[" (ebut:key-to-label key) "\\\]"))) - (goto-char (point-min)) - (if (re-search-forward key-regexp nil t) - (progn (hpath:display-buffer (current-buffer)) - (beginning-of-line)) - (goto-char opoint) - (beep)))) - -(defact completion () - "Inserts completion at point into the minibuffer or a buffer. -Unless point is at the end of the buffer or if completion has already been -inserted, the completions window is deleted." - (interactive) - (if (eobp) - (progn (bury-buffer nil) - (delete-window)) - (hargs:completion))) - -(defact eval-elisp (lisp-expr) - "Evaluates a Lisp expression LISP-EXPR." - (interactive "xLisp to eval: ") - (eval lisp-expr)) - -(defact exec-kbd-macro (kbd-macro &optional repeat-count) - "Executes KBD-MACRO REPEAT-COUNT times. -KBD-MACRO may be a string of editor command characters, a function symbol or -nil to use the last defined keyboard macro. -Optional REPEAT-COUNT nil means execute once, zero means repeat until -error." - (interactive - (let (macro repeat) - (setq macro (intern-soft - (hargs:read-match - "Unquoted macro name or nil for last one defined: " - obarray (function - (lambda (sym) - (and (fboundp sym) - (stringp (hypb:indirect-function sym))))) - nil "nil" 'symbol))) - (cond ((fboundp macro)) - ((null last-kbd-macro) - (hypb:error - "(exec-kbd-macro): Define a keyboard macro first.")) - (t (fset 'zzk last-kbd-macro) - (setq macro 'zzk))) - (save-excursion - (let ((standard-output (get-buffer-create "*macro-def*"))) - (unwind-protect - (progn (set-buffer standard-output) - (setq buffer-read-only nil) - (erase-buffer) - (insert-kbd-macro macro) - (goto-char (point-min)) - (setq macro (car (cdr (cdr (read (current-buffer))))))) - (kill-buffer standard-output)))) - (fmakunbound 'zzk) - (setq repeat (hargs:read "Repeat count: " - (function - (lambda (repeat) - (or (null repeat) - (and (integerp repeat) (>= repeat 0))))) - 1)) - (list macro repeat))) - (if (interactive-p) - nil - (or (and kbd-macro (or (stringp kbd-macro) - (and (symbolp kbd-macro) (fboundp kbd-macro)))) - (hypb:error "(exec-kbd-macro): Bad macro: %s" kbd-macro)) - (or (null repeat-count) (and (integerp repeat-count) (<= 0 repeat-count)) - (hypb:error "(exec-kbd-macro): Bad repeat count: %s" repeat-count))) - (execute-kbd-macro kbd-macro repeat-count)) - -;;; Support next two actypes on systems which use the `comint' shell package -;;; rather than Emacs V18 shell.el. -;;; -(if (or hyperb:lemacs-p hyperb:emacs19-p) - (require 'comint)) -(and (fboundp 'comint-send-input) (not (fboundp 'shell-send-input)) - (fset 'shell-send-input 'comint-send-input)) -(and (fboundp 'comint-kill-output) (not (fboundp 'kill-output-from-shell)) - (fset 'kill-output-from-shell 'comint-kill-output)) -(and (fboundp 'comint-show-output) (not (fboundp 'show-output-from-shell)) - (fset 'show-output-from-shell 'comint-show-output)) - -(defact exec-shell-cmd (shell-cmd &optional internal-cmd kill-prev) - "Executes a SHELL-CMD string asynchronously. -Optional non-nil second argument INTERNAL-CMD means do not display the shell -command line executed. Optional non-nil third argument KILL-PREV means -kill the last output to the shell buffer before executing SHELL-CMD." - (interactive - (let ((default (car defaults)) - (default1 (nth 1 defaults)) - (default2 (nth 2 defaults))) - (list (hargs:read "Shell cmd: " - (function - (lambda (cmd) (not (string-equal cmd "")))) - default "Enter a shell command." 'string) - (y-or-n-p (format "Omit cmd from output (default = %s): " - default1)) - (y-or-n-p (format "Kill prior cmd's output (default = %s): " - default2))))) - (let ((buf-name "*Hypb Shell*") - (owind (selected-window))) - (unwind-protect - (progn - (if (not (hpath:ange-ftp-p default-directory)) - (setq shell-cmd - (concat "cd " default-directory "; " shell-cmd))) - (if (not (get-buffer buf-name)) - (save-excursion - (hpath:display-buffer (current-buffer)) - (if (eq (minibuffer-window) (selected-window)) - (other-window 1)) - (shell) (rename-buffer buf-name) - (setq last-input-start (point-marker) - last-input-end (point-marker)) - (if (fboundp 'comint-kill-output) - (setq comint-last-input-start last-input-start - comint-last-input-end last-input-end) - ))) - (hpath:display-buffer buf-name) - (goto-char (point-max)) - (and kill-prev last-input-end - (not (equal last-input-start last-input-end)) - (kill-output-from-shell)) - (insert shell-cmd) - (shell-send-input) - (show-output-from-shell) - (or internal-cmd (scroll-down 1))) - (select-window owind)))) - -(defact exec-window-cmd (shell-cmd) - "Asynchronously executes an external window-based SHELL-CMD string." - (interactive - (let ((default (car defaults))) - (list (hargs:read "Shell cmd: " - (function - (lambda (cmd) (not (string-equal cmd "")))) - default "Enter a shell command." 'string)))) - (let ((buf-name "*Hypb Shell*") - (cmd (if (hpath:ange-ftp-p default-directory) - (concat "(" shell-cmd ") &") - (concat "(cd " default-directory "; " shell-cmd ") &"))) - (msg (format "Executing: %s" shell-cmd)) - (shell-buf)) - (message msg) - (save-excursion - (save-window-excursion - (if (not (get-buffer buf-name)) - (progn (save-excursion - (save-window-excursion - (shell) - (setq shell-buf (current-buffer)))) - (message msg) - ;; Wait for shell to startup before sending it input. - (sit-for 1) - (set-buffer shell-buf) - (rename-buffer buf-name) - (setq last-input-start (point-marker) - last-input-end (point-marker)) - (if (fboundp 'comint-kill-output) - (setq comint-last-input-start last-input-start - comint-last-input-end last-input-end) - ))) - (or (equal (buffer-name (current-buffer)) buf-name) - (set-buffer buf-name)) - (goto-char (point-max)) - (insert cmd) - (shell-send-input))) - (message msg))) - -(defact function-in-buffer (name pos) - "Displays the definition of function NAME found at POS in the current buffer." - (save-excursion - (goto-char pos) - (if (looking-at (regexp-quote name)) - nil - (let ((fume-scanning-message nil)) - (fume-rescan-buffer) - (setq pos (cdr-safe (assoc name fume-funclist)))))) - (if pos - (progn (hpath:display-buffer (current-buffer)) - (goto-char pos) - ;; Move to beginning of the line for compatibility with find-tag. - (beginning-of-line)))) - -(defact hyp-config (&optional out-buf) - "Inserts Hyperbole configuration info at end of current buffer or optional OUT-BUF." - (hypb:configuration out-buf)) - -(defact hyp-request (&optional out-buf) - "Inserts Hyperbole mail list request help into current buffer or optional OUT-BUF." - (save-excursion - (and out-buf (set-buffer out-buf)) - (goto-char (point-max)) - (delete-blank-lines) (delete-blank-lines) - (insert "Use one of the following formats in the *body* of your message:\n -subscribe <mail-list-name> [<your-email-address>] - or -unsubscribe <mail-list-name> [<your-email-address>] - -where possible <mail-list-names> are: - hyperbole - discussion of Hyperbole - hyperbole-announce - Hyperbole announcements only - -For example: subscribe hyperbole joe@nowhere.gov\n"))) - -(defact hyp-source (buf-str-or-file) - "Displays a buffer or file from a line beginning with `hbut:source-prefix'." - (interactive - (list (prin1-to-string (get-buffer-create - (read-buffer "Buffer to link to: "))))) - (if (stringp buf-str-or-file) - (cond ((string-match "\\`#<buffer \"?\\([^ \n\"]+\\)\"?>" buf-str-or-file) - (hpath:display-buffer - (substring buf-str-or-file (match-beginning 1) (match-end 1)))) - (t (hpath:find buf-str-or-file))) - (hypb:error "(hyp-source): Non-string argument: %s" buf-str-or-file))) - -(defact link-to-buffer-tmp (buffer) - "Displays a BUFFER. -Link is generally only good for current Emacs session. -Use `link-to-file' instead for a permanent link." - (interactive "bBuffer to link to: ") - (if (or (stringp buffer) (bufferp buffer)) - (hpath:display-buffer buffer) - (hypb:error "(link-to-buffer-tmp): Not a current buffer: %s" buffer))) - -(defact link-to-directory (directory) - "Displays a DIRECTORY in Dired mode." - (interactive "DDirectory to link to: ") - (hpath:find directory)) - -(defact link-to-ebut (key-file key) - "Performs action given by another button, specified by KEY-FILE and KEY." - (interactive - (let (but-file but-lbl) - (while (cond ((setq but-file - (read-file-name - "File of button to link to: " nil nil t)) - (if (string-equal but-file "") - (progn (beep) t))) - ((not (file-readable-p but-file)) - (message "(link-to-ebut): You cannot read `%s'." - but-file) - (beep) (sit-for 3)))) - (list but-file - (progn - (find-file-noselect but-file) - (while (string-equal "" (setq but-lbl - (hargs:read-match - "Button to link to: " - (ebut:alist but-file) - nil nil nil 'ebut))) - (beep)) - (ebut:label-to-key but-lbl))))) - (or (interactive-p) - (setq key-file (hpath:validate (hpath:substitute-value key-file)))) - (let ((but (ebut:get key (find-file-noselect key-file)))) - (if but (hbut:act but) - (hypb:error "(link-to-ebut): No button `%s' in `%s'." (ebut:key-to-label key) - key-file)))) - -(defact link-to-elisp-doc (func-symbol) - "Displays documentation for FUNC-SYMBOL." - (interactive "aFunction to display doc for: ") - (cond ((not (symbolp func-symbol)) - (hypb:error "(link-to-elisp-doc): `%s' not a symbol." - func-symbol)) - ((not (fboundp func-symbol)) - (hypb:error "(link-to-elisp-doc): `%s' not defined as a function." - func-symbol)) - ((not (documentation func-symbol)) - (hypb:error "(link-to-elisp-doc): `%s' has no documentation." - func-symbol)) - (t (let ((temp-buffer-show-function 'switch-to-buffer)) - (hpath:display-buffer (current-buffer)) - (describe-function func-symbol))))) - -(defact link-to-file (path &optional point) - "Displays file given by PATH scrolled to optional POINT. -With POINT, buffer is displayed with POINT at window top." - (interactive - (let ((prev-reading-p hargs:reading-p)) - (unwind-protect - (let* ((default (car defaults)) - (hargs:reading-p 'file) - (path (read-file-name "Path to link to: " default default)) - (path-buf (get-file-buffer path))) - (if path-buf - (save-excursion - (set-buffer path-buf) - (setq hargs:reading-p 'character) - (if (y-or-n-p - (format "y = Display at present position (line %d); n = no position: " - (count-lines 1 (point)))) - (list path (point)) - (list path))) - (list path))) - (setq hargs:reading-p prev-reading-p)))) - (and (hpath:find path) - (integerp point) - (progn (goto-char (min (point-max) point)) - (recenter 0)))) - -(defact link-to-file-line (path line-num) - "Displays a file given by PATH scrolled to LINE-NUM." - (interactive "fPath to link to: \nnDisplay at line number: ") - (if (setq path (smart-tags-file-path path)) - (hpath:find-line path line-num))) - -(defact link-to-Info-node (node) - "Displays an Info NODE. -NODE must be a string of the form `(file)nodename'." - (interactive "+IInfo (file)nodename to link to: ") - (require 'info) - (if (and (stringp node) (string-match "^(\\([^\)]+\\))\\(.*\\)" node)) - (let ((nodename (substring node (match-beginning 2) (match-end 2))) - (file (hpath:absolute-to - (substring node (match-beginning 1) (match-end 1)) - (if (boundp 'Info-directory-list) - Info-directory-list - Info-directory)))) - (if (and file (setq file (hpath:substitute-value file))) - (let ((wind (get-buffer-window "*info*"))) - (if wind (select-window wind) - (hpath:display-buffer (other-buffer))) - (info) (Info-goto-node (concat "(" file ")" nodename))) - (hypb:error "(link-to-Info-node): Bad node spec: `%s'" node))))) - -(defact link-to-kcell (file cell-ref) - "Displays FILE with kcell given by CELL-REF at window top. -See documentation for `kcell:ref-to-id' for valid cell-ref formats. - -If FILE is nil, the current buffer is used. -If CELL-REF is nil, the first cell in the view is shown." - (interactive "fKotl file to link to: \n+KKcell to link to: ") - (require 'kfile) - (cond ((and (stringp cell-ref) (> (length cell-ref) 0) - (= ?| (aref cell-ref 0))) - ;; Activate view spec in current window. - (kotl-mode:goto-cell cell-ref)) - ((if file - (hpath:find file) - (hpath:display-buffer (current-buffer))) - (if cell-ref - (kotl-mode:goto-cell cell-ref) - (kotl-mode:beginning-of-buffer)) - (recenter 0)))) - -(defact link-to-mail (mail-msg-id &optional mail-file) - "Displays mail msg with MAIL-MSG-ID from optional MAIL-FILE. -See documentation for the variable `hmail:init-function' for information on -how to specify a mail reader to use." - (interactive "+MMail Msg: ") - (if (not (fboundp 'rmail:msg-to-p)) - (hypb:error "(link-to-mail): Invoke mail reader before trying to follow a mail link.") - (if (and (listp mail-msg-id) (null mail-file)) - (setq mail-file (car (cdr mail-msg-id)) - mail-msg-id (car mail-msg-id))) - (let ((wconfig (current-window-configuration))) - (hpath:display-buffer (current-buffer)) - ;; Initialize user-specified mail reader if need be. - (if (and (symbolp hmail:init-function) - (fboundp hmail:init-function) - (listp (symbol-function hmail:init-function)) - (eq 'autoload (car (symbol-function hmail:init-function)))) - (funcall hmail:init-function)) - (if (rmail:msg-to-p mail-msg-id mail-file) - nil - ;; Couldn't find message, restore old window config, report error - (set-window-configuration wconfig) - (hypb:error "(link-to-mail): No msg `%s' in file \"%s\"." - mail-msg-id mail-file))))) - -(defact link-to-regexp-match (regexp n source &optional buffer-p) - "Finds REGEXP's Nth occurrence in SOURCE and displays location at window top. -SOURCE is a pathname unless optional BUFFER-P is non-nil, then SOURCE must be -a buffer name or buffer. -Returns t if found, signals an error if not." - (interactive "sRegexp to match: \nnOccurrence number: \nfFile to search: ") - (let ((orig-src source)) - (if buffer-p - (if (stringp source) - (setq source (get-buffer source))) - ;; Source is a pathname. - (if (not (stringp source)) - (hypb:error - "(link-to-regexp-match): Source parameter is not a filename: `%s'" - orig-src) - (setq source (find-file-noselect (hpath:substitute-value source))))) - (if (not (bufferp source)) - (hypb:error - "(link-to-regexp-match): Invalid source parameter: `%s'" orig-src) - (hpath:display-buffer source) - (widen) - (goto-char (point-min)) - (if (re-search-forward regexp nil t n) - (progn (beginning-of-line) (recenter 0) t) - (hypb:error - "(link-to-regexp-match): Pattern not found: `%s'" regexp))))) - -(defact link-to-rfc (rfc-num) - "Retrieves and displays an Internet rfc given by RFC-NUM. -RFC-NUM may be a string or an integer. Requires ange-ftp or efs for -remote retrievals." - (interactive "nRFC number to retrieve: ") - (if (or (stringp rfc-num) (integerp rfc-num)) - (hpath:find (hpath:rfc rfc-num)))) - -(defact link-to-string-match (string n source &optional buffer-p) - "Finds STRING's Nth occurrence in SOURCE and displays location at window top. -SOURCE is a pathname unless optional BUFFER-P is non-nil, then SOURCE must be -a buffer name or buffer. -Returns t if found, nil if not." - (interactive "sString to match: \nnOccurrence number: \nfFile to search: ") - (funcall (actype:action 'link-to-regexp-match) - (regexp-quote string) n source buffer-p)) - -(defact man-show (topic) - "Displays man page on TOPIC, which may be of the form <command>(<section>). -If using the Superman manual entry package, see the documentation for -`sm-notify' to control where the man page is displayed." - (interactive "sManual topic: ") - (let ((display-buffer-function - (function (lambda (buffer &rest unused) (hpath:display-buffer buffer))))) - (manual-entry topic))) - -(defact rfc-toc (&optional buf-name opoint) - "Computes and displays summary of an Internet rfc in BUF-NAME. -Assumes point has already been moved to start of region to summarize. -Optional OPOINT is point to return to in BUF-NAME after displaying summary." - (interactive) - (if buf-name - (cond ((get-buffer buf-name) - (switch-to-buffer buf-name)) - ((let ((buf (get-file-buffer buf-name))) - (if buf - (progn (switch-to-buffer (setq buf-name buf)) - t)))) - (t (if opoint (goto-char opoint)) - (hypb:error "(rfc-toc): Invalid buffer name: %s" buf-name)))) - (let ((sect-regexp "^[ \t]*[1-9][0-9]*\\.[0-9.]*[ \t]+[^ \t\n]") - (temp-buffer-show-function 'switch-to-buffer)) - (hpath:display-buffer (current-buffer)) - (occur sect-regexp) - (set-buffer "*Occur*") - (rename-buffer (format "*%s toc*" buf-name)) - (re-search-forward "^[ ]*[0-9]+:" nil t) - (beginning-of-line) - (delete-region (point-min) (point)) - (insert "Contents of " (buffer-name occur-buffer) ":\n") - (set-buffer-modified-p nil) - (set-buffer buf-name) - (if opoint (goto-char opoint)))) - -(defact text-toc (section) - "Jumps to the text file SECTION referenced by a table of contents entry at point." - (interactive "sGo to section named: ") - (if (stringp section) - (progn - (actypes::link-to-regexp-match - (concat "^\\*+[ \t]*" (regexp-quote section)) - 1 (current-buffer) t) - (while (and (= (forward-line -1) 0) - (looking-at "[ \t]*[-=][-=]"))) - (forward-line 1) - (recenter 0)))) - -(provide 'hactypes)
--- a/lisp/hyperbole/hargs.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,738 +0,0 @@ -;;!emacs -;; -;; FILE: hargs.el -;; SUMMARY: Obtains user input through Emacs for Hyperbole -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: extensions, hypermedia -;; -;; AUTHOR: Bob Weiner -;; ORG: Brown U. -;; -;; ORIG-DATE: 31-Oct-91 at 23:17:35 -;; LAST-MOD: 11-Sep-95 at 16:34:32 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1991-1995, Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; -;; This module should be used for any interactive prompting and -;; argument reading that Hyperbole does through Emacs. -;; -;; 'hargs:iform-read' provides a complete Lisp-based replacement for -;; interactive argument reading (most of what 'call-interactively' does). -;; It also supports prompting for new argument values with defaults drawn -;; from current button arguments. A few extensions to interactive argument -;; types are also provided, see 'hargs:iforms-extensions' for details. -;; -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Other required Elisp libraries -;;; ************************************************************************ - -(require 'hpath) -(require 'set) - -;;; ************************************************************************ -;;; Public variables -;;; ************************************************************************ - -(defvar hargs:reading-p nil - "t only when Hyperbole is prompting user for input, else nil.") - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -(defun hargs:actype-get (actype &optional modifying) - "Interactively gets and returns list of arguments for ACTYPE's parameters. -Current button is being modified when MODIFYING is non-nil." - (hargs:action-get (actype:action actype) modifying)) - -(defun hargs:at-p (&optional no-default) - "Returns thing at point, if of hargs:reading-p type, or default. -If optional argument NO-DEFAULT is non-nil, nil is returned instead of any -default values. - -Caller should have checked whether an argument is presently being read -and set 'hargs:reading-p' to an appropriate argument type. -Handles all of the interactive argument types that 'hargs:iform-read' does." - (cond ((and (eq hargs:reading-p 'kcell) - (eq major-mode 'kotl-mode) - (not (looking-at "^$"))) - (kcell-view:label)) - ((and (eq hargs:reading-p 'klink) - (not (looking-at "^$"))) - (if (eq major-mode 'kotl-mode) - (kcell-view:reference - nil (and (boundp 'default-dir) default-dir)) - (let ((hargs:reading-p 'file)) - (list (hargs:at-p))))) - ((eolp) nil) - ((and (eq hargs:reading-p 'hmenu) - (eq (selected-window) (minibuffer-window))) - (save-excursion - (char-to-string - (if (search-backward " " nil t) - (progn (skip-chars-forward " ") - (following-char)) - 0)))) - ((hargs:completion t)) - ((eq hargs:reading-p 'ebut) (ebut:label-p 'as-label)) - ((ebut:label-p) nil) - ((eq hargs:reading-p 'file) - (cond ((hpath:at-p nil 'non-exist)) - ((eq major-mode 'dired-mode) - (let ((file (dired-get-filename nil t))) - (and file (hpath:absolute-to file)))) - ((eq major-mode 'monkey-mode) - (let ((file (monkey-filename t))) - (and file (hpath:absolute-to file)))) - ;; Delimited file name. - ((hpath:at-p 'file)) - ;; Unquoted remote file name. - ((hpath:is-p (hpath:ange-ftp-at-p) 'file)) - (no-default nil) - ((buffer-file-name)) - )) - ((eq hargs:reading-p 'directory) - (cond ((hpath:at-p 'directory 'non-exist)) - ((eq major-mode 'dired-mode) - (let ((dir (dired-get-filename nil t))) - (and dir (setq dir (hpath:absolute-to dir)) - (file-directory-p dir) dir))) - ((eq major-mode 'monkey-mode) - (let ((dir (monkey-filename t))) - (and dir (setq dir (hpath:absolute-to dir)) - (file-directory-p dir) dir))) - ;; Delimited directory name. - ((hpath:at-p 'directory)) - ;; Unquoted remote directory name. - ((hpath:is-p (hpath:ange-ftp-at-p) 'directory)) - (no-default nil) - (default-directory) - )) - ((eq hargs:reading-p 'string) - (or (hargs:delimited "\"" "\"") (hargs:delimited "'" "'") - (hargs:delimited "`" "'") - )) - ((or (eq hargs:reading-p 'actype) - (eq hargs:reading-p 'actypes)) - (let ((name (find-tag-default))) - (car (set:member name (htype:names 'actypes))))) - ((or (eq hargs:reading-p 'ibtype) - (eq hargs:reading-p 'ibtypes)) - (let ((name (find-tag-default))) - (car (set:member name (htype:names 'ibtypes))))) - ((eq hargs:reading-p 'sexpression) (hargs:sexpression-p)) - ((eq hargs:reading-p 'Info-node) - (and (eq major-mode 'Info-mode) - (let ((file (hpath:relative-to Info-current-file - Info-directory))) - (and (stringp file) (string-match "^\\./" file) - (setq file (substring file (match-end 0)))) - (concat "(" file ")" Info-current-node)))) - ((eq hargs:reading-p 'mail) - (and (hmail:reader-p) buffer-file-name - (prin1-to-string (list (rmail:msg-id-get) buffer-file-name)))) - ((eq hargs:reading-p 'symbol) - (let ((sym (find-tag-default))) - (if (or (fboundp sym) (boundp sym)) sym))) - ((eq hargs:reading-p 'buffer) - (find-tag-default)) - ((eq hargs:reading-p 'character) - (following-char)) - ((eq hargs:reading-p 'key) - (require 'hib-kbd) - (let ((key-seq (hbut:label-p 'as-label "{" "}"))) - (and key-seq (kbd-key:normalize key-seq)))) - ((eq hargs:reading-p 'integer) - (save-excursion (skip-chars-backward "-0-9") - (if (looking-at "-?[0-9]+") - (read (current-buffer))))) - )) - -(defun hargs:completion (&optional no-insert) - "If in the completions buffer, return completion at point. Also insert unless optional NO-INSERT is non-nil. -Insert in minibuffer if active or in other window if minibuffer is inactive." - (interactive '(nil)) - (if (or (equal (buffer-name) "*Completions*") ;; V19 - (equal (buffer-name) " *Completions*")) ;; V18 - (let ((opoint (point)) - (owind (selected-window))) - (if (re-search-backward "^\\|[ \t][ \t]" nil t) - (let ((insert-window - (cond ((> (minibuffer-depth) 0) - (minibuffer-window)) - ((not (eq (selected-window) (next-window nil))) - (next-window nil)))) - (bury-completions) - (entry)) - (skip-chars-forward " \t") - (if (and insert-window (looking-at "[^\t\n]+")) - (progn (setq entry (buffer-substring (match-beginning 0) - (match-end 0))) - (select-window insert-window) - (let ((str (buffer-substring - (point) - (save-excursion (beginning-of-line) - (point))))) - (if (and (eq (selected-window) (minibuffer-window))) - ;; If entry matches tail of minibuffer prefix - ;; already, then return minibuffer contents - ;; as entry. - (progn - (setq entry - (if (string-match - (concat - (regexp-quote entry) "\\'") - str) - str - (concat - (if (string-match - "/[^/]+\\'" str) - (substring - str 0 (1+ (match-beginning 0))) - str) - entry))) - (or no-insert (if entry (insert entry))) - ) - ;; In buffer, non-minibuffer completion. - ;; Only insert entry if last buffer line does - ;; not end in entry. - (cond (no-insert) - ((or (string-match - (concat - (regexp-quote entry) "\\'") str) - (null entry)) - (setq bury-completions t)) - (t (insert entry))) - )))) - (select-window owind) (goto-char opoint) - (if bury-completions - (progn (bury-buffer nil) (delete-window))) - entry))))) - -(defun hargs:iform-read (iform &optional modifying) - "Reads action arguments according to IFORM, a list with car = 'interactive. -Optional MODIFYING non-nil indicates current button is being modified, so -button's current values should be presented as defaults. Otherwise, uses -hargs:defaults as list of defaults, if any. -See also documentation for 'interactive'." - ;; This is mostly a translation of 'call-interactively' to Lisp. - ;; - ;; Save this now, since use of minibuffer will clobber it. - (setq prefix-arg current-prefix-arg) - (if (not (and (listp iform) (eq (car iform) 'interactive))) - (error - "(hargs:iform-read): arg must be a list whose car = 'interactive.") - (setq iform (car (cdr iform))) - (if (or (null iform) (and (stringp iform) (equal iform ""))) - nil - (let ((prev-reading-p hargs:reading-p)) - (unwind-protect - (progn - (setq hargs:reading-p t) - (if (not (stringp iform)) - (let ((defaults (if modifying - (hattr:get 'hbut:current 'args) - (and (boundp 'hargs:defaults) - (listp hargs:defaults) - hargs:defaults) - ))) - (eval iform)) - (let ((i 0) (start 0) (end (length iform)) - (ientry) (results) (val) (default) - (defaults (if modifying - (hattr:get 'hbut:current 'args) - (and (boundp 'hargs:defaults) - (listp hargs:defaults) - hargs:defaults) - ))) - ;; - ;; Handle special initial interactive string chars. - ;; - ;; '*' means error if buffer is read-only. - ;; Notion of when action cannot be performed due to - ;; read-only buffer is view-specific, so here, we just - ;; ignore a read-only specification since it is checked for - ;; earlier by any ebut edit code. - ;; - ;; '@' means select window of last mouse event. - ;; - ;; '_' means keep region in same state (active or inactive) - ;; after this command. (XEmacs only.) - ;; - (while (cond - ((eq (aref iform i) ?*)) - ((eq (aref iform i) ?@) - (hargs:select-event-window) - t) - ((eq (aref iform i) ?_) - (setq zmacs-region-stays t))) - (setq i (1+ i) start i)) - ;; - (while (and (< start end) - (string-match "\n\\|\\'" iform start)) - (setq start (match-end 0) - ientry (substring iform i (match-beginning 0)) - i start - default (car defaults) - default (if (or (null default) (stringp default)) - default - (prin1-to-string default)) - val (hargs:get ientry default (car results)) - defaults (cdr defaults) - results (cond ((or (null val) (not (listp val))) - (cons val results)) - ;; Is a list of args? - ((eq (car val) 'args) - (append (nreverse (cdr val)) results)) - (t;; regular list value - (cons val results))))) - (nreverse results)))) - (setq hargs:reading-p prev-reading-p)))))) - -(defun hargs:read (prompt &optional predicate default err val-type) - "PROMPTs without completion for a value matching PREDICATE and returns it. -PREDICATE is an optional boolean function of one argument. Optional DEFAULT -is a string to insert after PROMPT as the default return value. Optional -ERR is a string to display temporarily when an invalid value is given. -Optional VAL-TYPE is a symbol indicating type of value to be read. If -VAL-TYPE is not equal to 'sexpression' or 'klink' and is non-nil, value is -returned as a string." - (let ((bad-val) (val) (stringify) - (prev-reading-p hargs:reading-p) (read-func) - (owind (selected-window)) - (obuf (current-buffer))) - (unwind-protect - (progn - (cond ((or (null val-type) (eq val-type 'sexpression)) - (setq read-func 'read-minibuffer - hargs:reading-p 'sexpression)) - (t (setq read-func 'read-string hargs:reading-p val-type - stringify t))) - (while (progn (and default (not (stringp default)) - (setq default (prin1-to-string default))) - (condition-case () - (or bad-val - (setq val (funcall read-func prompt default))) - (error (setq bad-val t))) - (if bad-val t - (and stringify - ;; Remove any double quoting of strings. - (string-match - "\\`\"\\([^\"]*\\)\"\\'" val) - (setq val (substring val (match-beginning 1) - (match-end 1)))) - (and predicate (not (funcall predicate val))))) - (if bad-val (setq bad-val nil) (setq default val)) - (beep) - (if err (progn (message err) (sit-for 3)))) - val) - (setq hargs:reading-p prev-reading-p) - (select-window owind) - (switch-to-buffer obuf) - ))) - -(defun hargs:read-match (prompt table &optional - predicate must-match default val-type) - "PROMPTs with completion for a value in TABLE and returns it. -TABLE is an alist where each element's car is a string, or it may be an -obarray for symbol-name completion. -Optional PREDICATE limits table entries to match against. -Optional MUST-MATCH means value returned must be from TABLE. -Optional DEFAULT is a string inserted after PROMPT as default value. -Optional VAL-TYPE is a symbol indicating type of value to be read." - (if (and must-match (null table)) - nil - (let ((prev-reading-p hargs:reading-p) - (completion-ignore-case t) - (owind (selected-window)) - (obuf (current-buffer))) - (unwind-protect - (progn - (setq hargs:reading-p (or val-type t)) - (completing-read prompt table predicate must-match default)) - (setq hargs:reading-p prev-reading-p) - (select-window owind) - (switch-to-buffer obuf) - )))) - -(defun hargs:select-p (&optional value assist-flag) - "Returns optional VALUE or value selected at point if any, else nil. -If value is the same as the contents of the minibuffer, it is used as -the current minibuffer argument, otherwise, the minibuffer is erased -and value is inserted there. -Optional ASSIST-FLAG non-nil triggers display of Hyperbole menu item help when -appropriate." - (if (and (> (minibuffer-depth) 0) (or value (setq value (hargs:at-p)))) - (let ((owind (selected-window)) (back-to) - (str-value (and value (format "%s" value)))) - (unwind-protect - (progn - (select-window (minibuffer-window)) - (set-buffer (window-buffer (minibuffer-window))) - (cond - ;; Selecting a menu item - ((eq hargs:reading-p 'hmenu) - (if assist-flag (setq hargs:reading-p 'hmenu-help)) - (hui:menu-enter str-value)) - ;; Use value for parameter. - ((string= str-value (buffer-string)) - (exit-minibuffer)) - ;; Clear minibuffer and insert value. - (t (setq buffer-read-only nil) - (erase-buffer) (insert str-value) - (setq back-to t))) - value) - (if back-to (select-window owind)))))) - -;;; ************************************************************************ -;;; Private functions -;;; ************************************************************************ - -;;; From etags.el, so don't have to load the whole thing. -(or (fboundp 'find-tag-default) - (defun find-tag-default () - (or (and (boundp 'find-tag-default-hook) - (not (memq find-tag-default-hook '(nil find-tag-default))) - (condition-case data - (funcall find-tag-default-hook) - (error - (message "value of find-tag-default-hook signalled error: %s" - data) - (sit-for 1) - nil))) - (save-excursion - (if (not (memq (char-syntax (preceding-char)) '(?w ?_))) - (while (not (looking-at "\\sw\\|\\s_\\|\\'")) - (forward-char 1))) - (while (looking-at "\\sw\\|\\s_") - (forward-char 1)) - (if (re-search-backward "\\sw\\|\\s_" nil t) - (regexp-quote - (progn (forward-char 1) - (buffer-substring (point) - (progn (forward-sexp -1) - (while (looking-at "\\s'") - (forward-char 1)) - (point))))) - nil))))) - -(defun hargs:action-get (action modifying) - "Interactively gets list of arguments for ACTION's parameters. -Current button is being modified when MODIFYING is non-nil. -Returns nil if ACTION is not a list or byte-code object, has no interactive -form or takes no arguments." - (and (or (hypb:v19-byte-code-p action) (listp action)) - (let ((interactive-form (action:commandp action))) - (if interactive-form - (action:path-args-rel - (hargs:iform-read interactive-form modifying)))))) - -(defun hargs:delimited (start-delim end-delim - &optional start-regexp-flag end-regexp-flag) - "Returns a single line, delimited argument that point is within, or nil. -START-DELIM and END-DELIM are strings that specify the argument delimiters. -With optional START-REGEXP-FLAG non-nil, START-DELIM is treated as a regular -expression. END-REGEXP-FLAG is similar." - (let* ((opoint (point)) - (limit (if start-regexp-flag opoint - (+ opoint (1- (length start-delim))))) - (start-search-func (if start-regexp-flag 're-search-forward - 'search-forward)) - (end-search-func (if end-regexp-flag 're-search-forward - 'search-forward)) - start end) - (save-excursion - (beginning-of-line) - (while (and (setq start (funcall start-search-func start-delim limit t)) - (< (point) opoint) - ;; This is not to find the real end delimiter but to find - ;; end delimiters that precede the current argument and are - ;; therefore false matches, hence the search is limited to - ;; prior to the original point. - (funcall end-search-func end-delim opoint t)) - (setq start nil)) - (if start - (progn - (end-of-line) (setq limit (1+ (point))) - (goto-char opoint) - (and (funcall end-search-func end-delim limit t) - (setq end (match-beginning 0)) - (buffer-substring start end))))))) - -(defun hargs:get (interactive-entry &optional default prior-arg) - "Prompts for an argument, if need be, from INTERACTIVE-ENTRY, a string. -Optional DEFAULT is inserted after prompt. -First character of INTERACTIVE-ENTRY must be a command character from -the list in the documentation for 'interactive' or a `+' which indicates that -the following character is a Hyperbole interactive extension command -character. - -May return a single value or a list of values, in which case the first -element of the list is always the symbol 'args." - (let (func cmd prompt) - (cond ((or (null interactive-entry) (equal interactive-entry "")) - (error "(hargs:get): Empty interactive-entry arg.")) - ((= (aref interactive-entry 0) ?+) - ;; Hyperbole / user extension command character. The next - ;; character is the actual command character. - (setq cmd (aref interactive-entry 1) - prompt (format (substring interactive-entry 2) prior-arg) - func (if (< cmd (length hargs:iform-extensions-vector)) - (aref hargs:iform-extensions-vector cmd))) - (if func - (funcall func prompt default) - (error - "(hargs:get): Bad interactive-entry extension character: '%c'." - cmd))) - (t (setq cmd (aref interactive-entry 0) - prompt - (format (substring interactive-entry 1) prior-arg) - func (if (< cmd (length hargs:iform-vector)) - (aref hargs:iform-vector cmd))) - (if func - (funcall func prompt default) - (error - "(hargs:get): Bad interactive-entry command character: '%c'." - cmd)))))) - -(defun hargs:make-iform-vector (iform-alist) - "Return a vector built from IFORM-ALIST used for looking up interactive command code characters." - ;; Vector needs to have 1 more elts than the highest char code for - ;; interactive commands. - (let* ((size (1+ (car (sort (mapcar 'car iform-alist) '>)))) - (vec (make-vector size nil))) - (mapcar (function - (lambda (elt) - (aset vec (car elt) - (` (lambda (prompt default) - (setq hargs:reading-p '(, (car (cdr elt)))) - (, (cdr (cdr elt)))))))) - iform-alist) - vec)) - -(defun hargs:prompt (prompt default &optional default-prompt) - "Returns string of PROMPT including DEFAULT. -Optional DEFAULT-PROMPT is used to describe default value." - (if default - (format "%s(%s%s%s) " prompt (or default-prompt "default") - (if (equal default "") "" " ") - default) - prompt)) - -(defun hargs:select-event-window () - "Select window, if any, that mouse was over during last event." - (if hyperb:lemacs-p - (if current-mouse-event - (select-window - (or (event-window current-mouse-event) - (selected-window)))) - (let* ((event last-command-event) - (window (posn-window (event-start event)))) - (if (and (eq window (minibuffer-window)) - (not (minibuffer-window-active-p - (minibuffer-window)))) - (error "Attempt to select inactive minibuffer window") - (select-window - (or window (selected-window))))))) - -(defun hargs:sexpression-p (&optional no-recurse) - "Returns an sexpression at point as a string. -If point follows an sexpression end character, the preceding sexpression -is returned. If point precedes an sexpression start character, the -following sexpression is returned. Otherwise, the innermost sexpression -that point is within is returned or nil if none." - (save-excursion - (condition-case () - (let ((not-quoted - '(not (and (= (char-syntax (char-after (- (point) 2))) ?\\) - (/= (char-syntax (char-after (- (point) 3))) ?\\))))) - (cond ((and (= (char-syntax (preceding-char)) ?\)) - ;; Ignore quoted end chars. - (eval not-quoted)) - (buffer-substring (point) - (progn (forward-sexp -1) (point)))) - ((and (= (char-syntax (following-char)) ?\() - ;; Ignore quoted begin chars. - (eval not-quoted)) - (buffer-substring (point) - (progn (forward-sexp) (point)))) - (no-recurse nil) - (t (save-excursion (up-list 1) (hargs:sexpression-p t))))) - (error nil)))) - -;;; ************************************************************************ -;;; Private variables -;;; ************************************************************************ - -(defvar hargs:iforms nil - "Alist of (interactive-cmd-chr . (argument-type . get-argument-form)) elts.") -(setq hargs:iforms - '( - ;; Get function symbol. - (?a . (symbol . - (intern (completing-read prompt obarray 'fboundp t default)))) - ;; Get name of existing buffer. - (?b . (buffer . - (progn - (or default (setq default (other-buffer (current-buffer)))) - (read-buffer prompt default t)))) - ;; Get name of possibly nonexistent buffer. - (?B . (buffer . - (progn - (or default (setq default (other-buffer (current-buffer)))) - (read-buffer prompt default nil)))) - ;; Get character. - (?c . (character . - (progn (message - (if default - (hargs:prompt prompt - (if (integerp default) - (char-to-string default) - default) - "Curr:") - prompt)) - (char-to-string (read-char))))) - ;; Get symbol for interactive function, a command. - (?C . (symbol . - (intern - (completing-read prompt obarray 'commandp t default)))) - ;; Get value of point; does not do I/O. - (?d . (integer . (point))) - ;; Get directory name. - (?D . (directory . - (progn - (or default (setq default default-directory)) - (read-file-name prompt default default 'existing)))) - ;; Get existing file name. - (?f . (file . - (read-file-name prompt default default - (if (eq system-type 'vax-vms) - nil 'existing)))) - ;; Get possibly nonexistent file name. - (?F . (file . (read-file-name prompt default default nil))) - ;; Get key sequence. - (?k . (key . - (key-description (read-key-sequence - (if default - (hargs:prompt prompt default "Curr:") - prompt))))) - ;; Get key sequence without converting uppercase or shifted - ;; function keys to their unshifted equivalents. - (?K . (key . - (key-description (read-key-sequence - (if default - (hargs:prompt prompt default "Curr:") - prompt) - nil t)))) - ;; Get value of mark. Does not do I/O. - (?m . (integer . (marker-position (hypb:mark-marker t)))) - ;; Get numeric prefix argument or a number from the minibuffer. - (?N . (integer . - (if prefix-arg - (prefix-numeric-value prefix-arg) - (let ((arg)) - (while (not (integerp - (setq arg (read-minibuffer prompt default)))) - (beep)) - arg)))) - ;; Get number from minibuffer. - (?n . (integer . - (let ((arg)) - (while (not (integerp - (setq arg (read-minibuffer prompt default)))) - (beep)) - arg))) - ;; Get numeric prefix argument. No I/O. - (?p . (prefix-arg . - (prefix-numeric-value prefix-arg))) - ;; Get prefix argument in raw form. No I/O. - (?P . (prefix-arg . prefix-arg)) - ;; Get region, point and mark as 2 args. No I/O - (?r . (region . - (if (marker-position (hypb:mark-marker t)) - (list 'args (min (point) (hypb:mark t)) - (max (point) (hypb:mark t))) - (list 'args nil nil)))) - ;; Get string. - (?s . (string . (read-string prompt default))) - ;; Get symbol. - (?S . (symbol . - (read-from-minibuffer - prompt default minibuffer-local-ns-map 'sym))) - ;; Get variable name: symbol that is user-variable-p. - (?v . (symbol . (read-variable - (if default - (hargs:prompt prompt default "Curr:") - prompt)))) - ;; Get Lisp expression but don't evaluate. - (?x . (sexpression . (read-minibuffer prompt default))) - ;; Get Lisp expression and evaluate. - (?X . (sexpression . (eval-minibuffer prompt default))) - )) - -(defvar hargs:iform-vector nil - "Vector of forms for each interactive command character code.") -(setq hargs:iform-vector (hargs:make-iform-vector hargs:iforms)) - -(defvar hargs:iforms-extensions nil - "Hyperbole extension alist of (interactive-cmd-chr . (argument-type . get-argument-form)) elts.") -(setq hargs:iforms-extensions - '( - ;; Get existing Info node name and file. - (?I . (Info-node . - (let (file) - (require 'info) - (hargs:read - prompt - (function - (lambda (node) - (and (string-match "^(\\([^\)]+\\))" node) - (setq file (substring node (match-beginning 1) - (match-end 1))) - (memq t (mapcar - (function - (lambda (dir) - (file-readable-p - (hpath:absolute-to file dir)))) - (if (boundp 'Info-directory-list) - Info-directory-list - (list Info-directory)) - ))))) - default - "(hargs:read): Use (readable-filename)nodename." - 'Info-node)))) - ;; Get kcell from koutline. - (?K . (kcell . (hargs:read prompt nil default nil 'kcell))) - ;; Get kcell or path reference for use in a link. - (?L . (klink . (hargs:read prompt nil default nil 'klink))) - ;; Get existing mail msg date and file. - (?M . (mail . (progn - (while - (or (not (listp - (setq default - (read-minibuffer - (hargs:prompt - prompt "" - "list of (date mail-file)") - default)))) - (/= (length default) 2) - (not (and (stringp (car (cdr default))) - (file-exists-p - (car (cdr default)))))) - (beep)) - default))))) - -(defvar hargs:iform-extensions-vector nil - "Vector of forms for each interactive command character code.") -(setq hargs:iform-extensions-vector - (hargs:make-iform-vector hargs:iforms-extensions)) - -(provide 'hargs)
--- a/lisp/hyperbole/hbdata.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,459 +0,0 @@ -;;!emacs -;; -;; FILE: hbdata.el -;; SUMMARY: Hyperbole button attribute accessor methods. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: hypermedia -;; -;; AUTHOR: Bob Weiner -;; ORG: Brown U. -;; -;; ORIG-DATE: 2-Apr-91 -;; LAST-MOD: 14-Apr-95 at 15:59:49 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1991-1995, Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; -;; This module handles Hyperbole button data/attribute storage. In -;; general, it should not be extended by anyone other than Hyperbole -;; maintainers. If you alter the formats or accessors herein, you are -;; likely to make your buttons incompatible with future releases. -;; System developers should instead work with and extend the "hbut.el" -;; module which provides much of the Hyperbole application programming -;; interface and which hides the low level details handled by this -;; module. -;; -;; -;; Button data is typically stored within a file that holds the button -;; data for all files within that directory. The name of this file is -;; given by the variable 'hattr:filename,' usually it is ".hypb". -;; -;; Here is a sample from a Hyperbole V2 button data file. Each button -;; data entry is a list of fields: -;; -;; -;; "TO-DO" -;; (Key Placeholders LinkType <arg-list> creator and modifier with times) -;; ("alt.mouse.el" nil nil link-to-file ("./ell/alt-mouse.el") "zzz@cs.brown.edu" "19911027:09:19:26" "zzz" "19911027:09:31:36") -;; -;; which means: button \<(alt.mouse.el)> found in file "TO-DO" in the current -;; directory provides a link to the local file "./ell/alt-mouse.el". It was -;; created and last modified by zzz@cs.brown.edu. -;; -;; All link entries that originate from the same source file are stored -;; contiguously, one per line, in reverse order of creation. -;; Preceding all such entries is the source name (in the case of a file -;; used as a source, no directory information is included, since only -;; sources within the same directory as the button data file are used as -;; source files within it. -;; -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Other required Elisp libraries -;;; ************************************************************************ - -(require 'hbmap) - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -;;; ------------------------------------------------------------------------ -;;; Button data accessor functions -;;; ------------------------------------------------------------------------ -(defun hbdata:action (hbdata) - "[Hyp V2] Returns action overriding button's action type or nil." - (nth 1 hbdata)) - -(defun hbdata:actype (hbdata) - "Returns the action type in HBDATA as a string." - (let ((nm (symbol-name (nth 3 hbdata)))) - (and nm (if (or (= (length nm) 2) (string-match "::" nm)) - nm (concat "actypes::" nm))))) - -(defun hbdata:args (hbdata) - "Returns the list of any arguments given in HBDATA." - (nth 4 hbdata)) - -(defun hbdata:categ (hbdata) - "Returns the category of HBDATA's button." - 'explicit) - -(defun hbdata:creator (hbdata) - "Returns the user-id of the original creator of HBDATA's button." - (nth 5 hbdata)) - -(defun hbdata:create-time (hbdata) - "Returns the original creation time given for HBDATA's button." - (nth 6 hbdata)) - -(defun hbdata:key (hbdata) - "Returns the indexing key in HBDATA as a string." - (car hbdata)) - -(defun hbdata:loc-p (hbdata) - "[Hyp V1] Returns 'L iff HBDATA referent is within a local file system. -Returns 'R if remote and nil if irrelevant for button action type." - (nth 1 hbdata)) - -(defun hbdata:modifier (hbdata) - "Returns the user-id of the most recent modifier of HBDATA's button. -Nil is returned when button has not been modified." - (nth 7 hbdata)) - -(defun hbdata:mod-time (hbdata) - "Returns the time of the most recent change to HBDATA's button. -Nil is returned when button has not beened modified." - (nth 8 hbdata)) - -(defun hbdata:referent (hbdata) - "Returns the referent name in HBDATA." - (nth 2 hbdata)) - -(defun hbdata:search (buf label partial) - "Go to Hyperbole hbdata BUF and find LABEL whole or PARTIAL matches. - Search is case-insensitive. Returns list with elements: - (<button-src> <label-key1> ... <label-keyN>)." - (set-buffer buf) - (let ((case-fold-search t) (src-matches) (src) (matches) (end)) - (goto-char (point-min)) - (while (re-search-forward "^\^L\n\"\\([^\"]+\\)\"" nil t) - (setq src (buffer-substring (match-beginning 1) - (match-end 1)) - matches nil) - (save-excursion - (setq end (if (re-search-forward "^\^L" nil t) - (1- (point)) (point-max)))) - (while (re-search-forward - (concat "^(\"\\(" (if partial "[^\"]*") - (regexp-quote (ebut:label-to-key label)) - (if partial "[^\"]*") "\\)\"") nil t) - (setq matches (cons - (buffer-substring (match-beginning 1) - (match-end 1)) - matches))) - (if matches - (setq src-matches (cons (cons src matches) src-matches))) - (goto-char end)) - src-matches)) - -;;; ------------------------------------------------------------------------ -;;; Button data operators -;;; ------------------------------------------------------------------------ - -(defun hbdata:build (&optional mod-lbl-key but-sym) - "Tries to construct button data from optional MOD-LBL-KEY and BUT-SYM. -MOD-LBL-KEY nil means create a new entry, otherwise modify existing one. -BUT-SYM nil means use 'hbut:current'. If successful, returns a cons of - (button-data . button-instance-str), else nil." - (let* ((but) - (b (hattr:copy (or but-sym 'hbut:current) 'but)) - (l (hattr:get b 'loc)) - (key (or mod-lbl-key (hattr:get b 'lbl-key))) - (new-key (if mod-lbl-key (hattr:get b 'lbl-key) key)) - (lbl-instance) (creator) (create-time) (modifier) (mod-time) - (entry) loc dir) - (if (null l) - nil - (setq loc (if (bufferp l) l (file-name-nondirectory l)) - dir (if (bufferp l) nil (file-name-directory l))) - (if (setq entry (hbdata:to-entry key loc dir (not mod-lbl-key))) - (if mod-lbl-key - (progn - (setq creator (hbdata:creator entry) - create-time (hbdata:create-time entry) - modifier (let* ((user (user-login-name)) - (addr (concat user - hyperb:host-domain))) - (if (equal creator addr) - user addr)) - mod-time (htz:date-sortable-gmt) - entry (cons new-key (cdr entry))) - (hbdata:delete-entry-at-point) - (if (setq lbl-instance (hbdata:instance-last new-key loc dir)) - (progn - (setq lbl-instance (concat ebut:instance-sep - (1+ lbl-instance))) - ;; This line is needed to ensure that the highest - ;; numbered instance of a label appears before - ;; other instances, so 'hbdata:instance-last' will work. - (if (hbdata:to-entry-buf loc dir) (forward-line 1)))) - ) - (let ((inst-num (hbdata:instance-last new-key loc dir))) - (setq lbl-instance (if inst-num - (hbdata:instance-next - (concat new-key ebut:instance-sep - (int-to-string inst-num)))))) - )) - (if (or entry (not mod-lbl-key)) - (cons - (list (concat new-key lbl-instance) - (hattr:get b 'action) - ;; Hyperbole V1 referent compatibility, always nil in V2 - (hattr:get b 'referent) - ;; Save actype without class prefix - (let ((actype (hattr:get b 'actype))) - (and actype (symbolp actype) - (setq actype (symbol-name actype)) - (intern - (substring actype (if (string-match "::" actype) - (match-end 0) 0))))) - (let ((mail-dir (and (fboundp 'hmail:composing-dir) - (hmail:composing-dir l))) - (args (hattr:get b 'args))) - ;; Replace matches for Emacs Lisp directory variable - ;; values with their variable names in any pathname args. - (mapcar 'hpath:substitute-var - (if mail-dir - ;; Make pathname args absolute for outgoing mail and - ;; news messages. - (action:path-args-abs args mail-dir) - args))) - (or creator (concat (user-login-name) hyperb:host-domain)) - (or create-time (htz:date-sortable-gmt)) - modifier - mod-time) - lbl-instance) - )))) - -(defun hbdata:get-entry (lbl-key key-src &optional directory) - "Returns button data entry given by LBL-KEY, KEY-SRC and optional DIRECTORY. -Returns nil if no matching entry is found. -A button data entry is a list of attribute values. Use methods from -class 'hbdata' to operate on the entry." - (hbdata:apply-entry - (function (lambda () (read (current-buffer)))) - lbl-key key-src directory)) - -(defun hbdata:instance-next (lbl-key) - "Returns string for button instance number following LBL-KEY's. -nil if LBL-KEY is nil." - (and lbl-key - (if (string-match - (concat (regexp-quote ebut:instance-sep) "[0-9]+$") lbl-key) - (concat ebut:instance-sep - (int-to-string - (1+ (string-to-int - (substring lbl-key (1+ (match-beginning 0))))))) - ":2"))) - -(defun hbdata:instance-last (lbl-key key-src &optional directory) - "Returns highest instance number for repeated button label. -1 if not repeated, nil if no instance. -Takes arguments LBL-KEY, KEY-SRC and optional DIRECTORY." - (hbdata:apply-entry - (function (lambda () - (if (looking-at "[0-9]+") - (string-to-int (buffer-substring (match-beginning 0) - (match-end 0))) - 1))) - lbl-key key-src directory nil 'instance)) - -(defun hbdata:delete-entry (lbl-key key-src &optional directory) - "Deletes button data entry given by LBL-KEY, KEY-SRC and optional DIRECTORY. -Returns entry deleted (a list of attribute values) or nil. -Use methods from class 'hbdata' to operate on the entry." - (hbdata:apply-entry - (function - (lambda () - (prog1 (read (current-buffer)) - (let ((empty-file-entry "[ \t\n]*\\(\^L\\|\\'\\)") - (kill)) - (beginning-of-line) - (hbdata:delete-entry-at-point) - (if (looking-at empty-file-entry) - (let ((end (point)) - (empty-hbdata-file "[ \t\n]*\\'")) - (forward-line -1) - (if (= (following-char) ?\") - ;; Last button entry for filename, so del filename. - (progn (forward-line -1) (delete-region (point) end))) - (save-excursion - (goto-char (point-min)) - (if (looking-at empty-hbdata-file) - (setq kill t))) - (if kill - (let ((fname buffer-file-name)) - (erase-buffer) (save-buffer) (kill-buffer nil) - (hbmap:dir-remove (file-name-directory fname)) - (call-process "rm" nil 0 nil "-f" fname))))))))) - lbl-key key-src directory)) - -(defun hbdata:delete-entry-at-point () - (delete-region (point) (progn (forward-line 1) (point)))) - -(defun hbdata:to-entry (but-key key-src &optional directory instance) - "Returns button data entry indexed by BUT-KEY, KEY-SRC, optional DIRECTORY. -Returns nil if entry is not found. Leaves point at start of entry when -successful or where entry should be inserted if unsuccessful. -A button entry is a list. Use methods from class 'hbdata' to operate on the -entry. Optional INSTANCE non-nil means search for any button instance matching -but-key." - (let ((pos-entry-cons - (hbdata:apply-entry - (function - (lambda () - (beginning-of-line) - (cons (point) (read (current-buffer))))) - but-key key-src directory 'create instance))) - (hbdata:to-entry-buf key-src directory) - (forward-line 1) - (if pos-entry-cons - (progn - (goto-char (car pos-entry-cons)) - (cdr pos-entry-cons))))) - -;;; ************************************************************************ -;;; Private functions -;;; ************************************************************************ - -(defun hbdata:apply-entry (function lbl-key key-src &optional directory - create instance) - "Invokes FUNCTION with point at hbdata entry given by LBL-KEY, KEY-SRC, optional DIRECTORY. -With optional CREATE, if no such line exists, inserts a new file entry at the -beginning of the hbdata file (which is created if necessary). -INSTANCE non-nil means search for any button instance matching LBL-KEY and -call FUNCTION with point right after any 'ebut:instance-sep' in match. -Returns value of evaluation when a matching entry is found or nil." - (let ((found) - (rtn) - (opoint) - (end-func)) - (save-excursion - (unwind-protect - (progn - (if (not (bufferp key-src)) - nil - (set-buffer key-src) - (cond ((hmail:editor-p) - (setq end-func (function (lambda () - (hmail:msg-narrow))))) - ((and (hmail:lister-p) - (progn (rmail:summ-msg-to) (rmail:to))) - (setq opoint (point) - key-src (current-buffer) - end-func (function (lambda () - (hmail:msg-narrow) - (goto-char opoint) - (lmail:to))))) - ((and (hnews:lister-p) - (progn (rnews:summ-msg-to) (rnews:to))) - (setq opoint (point) - key-src (current-buffer) - end-func (function (lambda () - (hmail:msg-narrow) - (goto-char opoint) - (lnews:to))))))) - (setq found (hbdata:to-entry-buf key-src directory create))) - (if found - (let ((case-fold-search t) - (qkey (regexp-quote lbl-key)) - (end (save-excursion (if (search-forward "\n\^L" nil t) - (point) (point-max))))) - (if (if instance - (re-search-forward - (concat "\n(\"" qkey "[" - ebut:instance-sep "\"]") end t) - (search-forward (concat "\n(\"" lbl-key "\"") end t)) - (progn - (or instance (beginning-of-line)) - (let (buffer-read-only) - (setq rtn (funcall function))))))) - (if end-func (funcall end-func)))) - rtn)) - -(defun hbdata:to-hbdata-buffer (dir &optional create) - "Reads in the file containing DIR's button data, if any, and returns buffer. -If it does not exist and optional CREATE is non-nil, creates a new -one and returns buffer, otherwise returns nil." - (let* ((file (expand-file-name hattr:filename (or dir default-directory))) - (existing-file (or (file-exists-p file) (get-file-buffer file))) - (buf (or (get-file-buffer file) - (and (or create existing-file) - (find-file-noselect file))))) - (if buf - (progn (set-buffer buf) - (or (verify-visited-file-modtime (get-file-buffer file)) - (cond ((yes-or-no-p - "Hyperbole button data file has changed, read new contents? ") - (revert-buffer t t) - ))) - (or (= (point-max) 1) (eq (char-after 1) ?\^L) - (error "File %s is not a valid Hyperbole button data table." file)) - (or (equal (buffer-name) file) (rename-buffer file)) - (setq buffer-read-only nil) - (or existing-file (hbmap:dir-add (file-name-directory file))) - buf)))) - - -(defun hbdata:to-entry-buf (key-src &optional directory create) - "Moves point to end of line in but data buffer matching KEY-SRC. -Uses hbdata file in KEY-SRC's directory, or optional DIRECTORY or if nil, uses -default-directory. -With optional CREATE, if no such line exists, inserts a new file entry at the -beginning of the hbdata file (which is created if necessary). -Returns non-nil if KEY-SRC is found or created, else nil." - (let ((rtn) (ln-dir)) - (if (bufferp key-src) - ;; Button buffer has no file attached - (progn (setq rtn (set-buffer key-src) - buffer-read-only nil) - (if (not (hmail:hbdata-to-p)) - (insert "\n" hmail:hbdata-sep "\n")) - (backward-char 1) - ) - (setq directory (or (file-name-directory key-src) directory)) - (let ((ln-file) (link-p key-src)) - (while (setq link-p (file-symlink-p link-p)) - (setq ln-file link-p)) - (if ln-file - (setq ln-dir (file-name-directory ln-file) - key-src (file-name-nondirectory ln-file)) - (setq key-src (file-name-nondirectory key-src)))) - (if (or (hbdata:to-hbdata-buffer directory create) - (and ln-dir (hbdata:to-hbdata-buffer ln-dir nil) - (setq create nil - directory ln-dir))) - (progn - (goto-char 1) - (cond ((search-forward (concat "\^L\n\"" key-src "\"") - nil t) - (setq rtn t)) - (create - (setq rtn t) - (insert "\^L\n\"" key-src "\"\n") - (backward-char 1)) - )))) - rtn - )) - -(defun hbdata:write (&optional orig-lbl-key but-sym) - "Tries to write Hyperbole button data from optional ORIG-LBL-KEY and BUT-SYM. -ORIG-LBL-KEY nil means create a new entry, otherwise modify existing one. -BUT-SYM nil means use 'hbut:current'. If successful, returns -a button instance string to append to button label or t when first instance. -On failure, returns nil." - (let ((cns (hbdata:build orig-lbl-key but-sym)) - entry lbl-instance) - (if (or (and buffer-file-name - (not (file-writable-p buffer-file-name))) - (null cns)) - nil - (setq entry (car cns) lbl-instance (cdr cns)) - (prin1 entry (current-buffer)) - (terpri (current-buffer)) - (or lbl-instance t) - ))) - - -;;; ************************************************************************ -;;; Private variables -;;; ************************************************************************ - -(provide 'hbdata)
--- a/lisp/hyperbole/hbmap.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,132 +0,0 @@ -;;!emacs -;; -;; FILE: hbmap.el -;; SUMMARY: Hyperbole button map maintenance for queries and lookups. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: hypermedia, matching -;; -;; AUTHOR: Bob Weiner -;; ORG: Brown U. -;; -;; ORIG-DATE: 6-Oct-91 at 06:34:05 -;; LAST-MOD: 17-Feb-97 at 15:30:16 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1991-1995, Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Public variables -;;; ************************************************************************ - -(defvar hbmap:filename "HYPB" - "*Filename used for quick access button files.") - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -(defun hbmap:dir-add (dir-name &optional no-save) - "Adds DIR-NAME to map of all directories in which user has written buttons. -Returns t iff DIR-NAME is not already in map, nil if it is, and some -other value when cannot read or write map. -Optional NO-SAVE disables saving of the map after an add." - (hbmap:dir-operate (function (lambda (dir) (not (hbmap:dir-member dir)))) - dir-name - '(progn (prin1 (list dir-name) buf) (terpri buf)) - no-save)) - -(defun hbmap:dir-list () - "Returns list of all directories in which user has written buttons." - (save-excursion - (let ((buf (if (and (file-exists-p hbmap:dir-filename) - (not (file-readable-p hbmap:dir-filename))) - nil - (find-file-noselect hbmap:dir-filename))) - (dirs)) - (if buf - (progn (set-buffer buf) - (goto-char (point-min)) - (condition-case () - (while (setq dirs (cons (car (read (current-buffer))) - dirs))) - (error t)) - dirs))))) - -(defun hbmap:dir-remove (dir-name &optional no-save) - "Removes DIR-NAME from map of all dirs in which user has written buttons. -Returns t iff DIR-NAME is in the map and is successfully removed, nil if it -is not, and some other value when the map is not readable or writable. -Optional NO-SAVE disables saving of the map after a removal." -(hbmap:dir-operate 'hbmap:dir-member dir-name - '(delete-region (point) (progn (forward-line 1) (point))) - no-save)) - -(defun hbmap:dir-member (dir-name) - "Returns t iff DIR-NAME is a member of user's Hyperbole map, else nil. -If t, point is left at the start of the matching map entry. If nil, -point is left in a position appropriate for insertion of a new entry." - (let ((obuf (current-buffer)) - (buf (and (file-exists-p hbmap:dir-filename) - (find-file-noselect hbmap:dir-filename))) - (rtn)) - (if buf - (progn (set-buffer buf) (widen) (goto-char 1) - (if (search-forward (concat "\n(\"" dir-name "\"") nil t) - (progn (beginning-of-line) (setq rtn t)) - (goto-char 1) (or (= (forward-line 1) 0) (insert "\n"))) - (set-buffer obuf))) - rtn)) - -;;; ************************************************************************ -;;; Private functions -;;; ************************************************************************ - -(defun hbmap:dir-operate (pred dir-name form &optional no-save) - "If PRED called on DIR-NAME is non-nil, evaluates FORM. -Returns t if PRED evaluation is successful and nil when not, except when -hbmap is not readable or writable, in which case returns a symbol indicating -the error. Optional NO-SAVE disables saving of the map after operation." - (save-excursion - (let ((buf (if (and (file-exists-p hbmap:dir-filename) - (not (file-readable-p hbmap:dir-filename))) - nil - (find-file-noselect hbmap:dir-filename)))) - (if buf - (progn (set-buffer buf) - (if (funcall pred dir-name) - (progn - (setq buffer-read-only nil) - (eval form) - (if no-save t - (if (file-writable-p buffer-file-name) - (progn (save-buffer) t) - 'hbmap-not-writable))))) - 'hbmap-not-readable)))) - -;;; ************************************************************************ -;;; Private variables -;;; ************************************************************************ - -(defvar hbmap:dir-user - (if (and hyperb:microcruft-os-p - (or (not (fboundp 'getenv)) - (not (getenv "HOME")))) - "c:/_hyperb/" "~/.hyperb/") - "Per user directory in which to store top level Hyperbole map data. -Must end with a directory separator. -Hyperbole will try to create it whenever 'hyperb:init' is called.") - -(defvar hbmap:dir-filename - (expand-file-name "HBMAP" hbmap:dir-user) - "Name of a file that lists all dirs to which a user has written buttons. -See also 'hbmap:dir-user'. -If you change its value, you will be unable to search for buttons created by -others who use a different value!") - -(provide 'hbmap)
--- a/lisp/hyperbole/hbut.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1201 +0,0 @@ -;;!emacs -;; -;; FILE: hbut.el -;; SUMMARY: Hyperbole button constructs. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: extensions, hypermedia -;; -;; AUTHOR: Bob Weiner -;; ORG: InfoDock Associates -;; -;; ORIG-DATE: 18-Sep-91 at 02:57:09 -;; LAST-MOD: 17-Feb-97 at 15:31:03 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1991-1996, Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Other required Elisp libraries -;;; ************************************************************************ - -(require 'hmoccur) -(require 'hbmap) -(require 'htz) -(require 'hbdata) -(require 'hact) - -;;; ************************************************************************ -;;; Public definitions -;;; ************************************************************************ - -;;; ======================================================================== -;;; ebut class - Explicit Hyperbole buttons -;;; ======================================================================== - -(defvar ebut:hattr-save t - "*Non-nil value saves button data when button source is saved. -Nil disables saving.") - -(defconst ebut:max-len 100 - "Maximum length of a hyper-button label.") - - -(defun ebut:act (label) - "Activates Hyperbole explicit button with LABEL from the current buffer." - (interactive (list (hargs:read-match "Activate explicit button labeled: " - (ebut:alist) - nil t nil 'ebut))) - (let* ((lbl-key (hbut:label-to-key label)) - (but (ebut:get lbl-key))) - (if but - (hbut:act but) - (error "(ebut:act): No explicit button labeled: %s" label)))) - -(defun ebut:alist (&optional file) - "Returns alist with each element a list containing a button label. -For use as a completion table. Gets labels from optional FILE or current -buffer." - (mapcar 'list (ebut:list file))) - -(defun ebut:at-p (&optional start-delim end-delim) - "Returns explicit Hyperbole button at point or nil. -Assumes point is within first line of button label, if at all. -Optional START-DELIM and END-DELIM are strings that override default -button delimiters." - (let ((key (ebut:label-p nil start-delim end-delim))) - (and key (ebut:get key)))) - -(defun ebut:create (&optional but-sym) - "Creates Hyperbole explicit button based on optional BUT-SYM. -Default is 'hbut:current'. -Button should hold the following attributes (see 'hattr:set'): - lbl-key (normalized button label string), - loc (filename or buffer where button is located), - dir (directory name where button is located), - actype (action type that provides a default action for the button), - action (optional action that overrides the default), - args (list of arguments for action, if action takes a single - argument of the button lbl-key, args may be nil). - -If successful returns any instance number to append to button label -except when instance number would be 1, then returns t. On failure, -returns nil. - -If successful, leaves point in button data buffer, so caller should use -'save-excursion'. Does not save button data buffer." - (let ((lbl-instance (hbdata:write nil but-sym))) - (run-hooks 'ebut:create-hook) - lbl-instance)) - -(defun ebut:delete (&optional but-sym) - "Deletes Hyperbole explicit button based on optional BUT-SYM. -Default is 'hbut:current'. -Returns entry deleted (a list of attribute values) or nil." - (if (null but-sym) (setq but-sym 'hbut:current)) - (if (ebut:is-p but-sym) - (let* ((but-key (hattr:get but-sym 'lbl-key)) - (loc (hattr:get but-sym 'loc)) - (entry (hbdata:delete-entry but-key loc))) - (run-hooks 'ebut:delete-hook) - entry))) - -(defun ebut:get (&optional lbl-key buffer key-src) - "Returns explicit Hyperbole button symbol given by LBL-KEY and BUFFER. -KEY-SRC is given when retrieving global buttons and is full source pathname. -Retrieves button data, converts into a button object and returns a symbol -which references the button. - -All arguments are optional. When none are given, returns symbol for -button that point is within or nil. BUFFER defaults to the current -buffer." - (hattr:clear 'hbut:current) - (save-excursion - (let ((key-file) (key-dir) (but-data) (actype)) - (or lbl-key (setq lbl-key (ebut:label-p))) - (if buffer - (if (bufferp buffer) (set-buffer buffer) - (error "(ebut:get): Invalid buffer argument: %s" buffer))) - (if key-src - nil - (if (equal lbl-key (ebut:label-p)) - nil - (goto-char (point-min)) - (ebut:next-occurrence lbl-key)) - (if (setq key-src (ebut:key-src 'full)) - ;; 'ebut:key-src' sets current buffer to key-src buffer. - (setq buffer (current-buffer))) - ) - (if (and (stringp lbl-key) key-src) - (progn - (if (stringp key-src) - (setq key-dir (file-name-directory key-src) - key-file (file-name-nondirectory key-src))) - (setq but-data (and key-src - (hbdata:get-entry lbl-key (or key-file key-src) - key-dir))) - (if (null but-data) - nil - (hattr:set 'hbut:current 'lbl-key lbl-key) - (hattr:set 'hbut:current 'loc key-src) - (hattr:set 'hbut:current 'categ 'explicit) - (hattr:set 'hbut:current 'action nil) - (hattr:set 'hbut:current 'actype - (intern (setq actype (hbdata:actype but-data)))) - ;; Hyperbole V1 referent compatibility - (if (= (length actype) 2) - (hattr:set 'hbut:current 'referent - (hbdata:referent but-data))) - (hattr:set 'hbut:current 'args (hbdata:args but-data)) - (hattr:set 'hbut:current 'creator (hbdata:creator but-data)) - (hattr:set 'hbut:current - 'create-time (hbdata:create-time but-data)) - (hattr:set 'hbut:current - 'modifier (hbdata:modifier but-data)) - (hattr:set 'hbut:current - 'mod-time (hbdata:mod-time but-data)) - 'hbut:current) - ))))) - -(defun ebut:is-p (object) - "Returns non-nil if OBJECT denotes an explicit Hyperbole button." - (and (symbolp object) - (eq (hattr:get object 'categ) 'explicit))) - -(defun ebut:key-of-label-p (key label) - "Returns t iff KEY matches to LABEL in a case insensitive manner." - (and (stringp key) (stringp label) - (equal key (downcase (ebut:label-to-key label))))) - -(defun ebut:key-src (&optional full) - "Return key source (usually unqualified) for current Hyperbole button. -Also sets current buffer to key source. -With optional FULL when source is a pathname, the full pathname is returned." - (let ((src (cond ((hmail:mode-is-p) (current-buffer)) - ((ebut:key-src-fmt)) - ((save-excursion - (save-restriction - (widen) - (if (and (search-backward hbut:source-prefix nil t) - (or (memq (preceding-char) '(?\n ?\^M)) - (= (point) (point-min)))) - (hbut:source full))))) - (buffer-file-name - (if full buffer-file-name - (file-name-nondirectory buffer-file-name))) - (t (current-buffer)) - ))) - (cond ((null src) nil) - ((bufferp src) - (set-buffer src) - src) - ((file-readable-p src) - (set-buffer (find-file-noselect src)) - src) - ((file-readable-p (setq src (hpath:symlink-referent src))) - (set-buffer (find-file-noselect src)) - src)))) - -(defun ebut:key-src-fmt () - "Returns unformatted filename associated with formatted current buffer. -This is used to obtain the source of explicit buttons for buffers that -represent the output of particular document formatters." - (cond ((or (eq major-mode 'Info-mode) - (string-match "\\.info\\(-[0-9]+\\)?$" (buffer-name))) - (let ((src (and buffer-file-name - (substring - buffer-file-name - 0 (string-match "\\.[^.]+$" buffer-file-name))))) - (cond ((file-exists-p (concat src ".texi")) - (concat src ".texi")) - ((file-exists-p (concat src ".texinfo")) - (concat src ".texinfo")) - ((current-buffer))))) - )) - -(defun ebut:key-to-label (lbl-key) - "Unnormalizes LBL-KEY and returns a label string approximating actual label." - (if lbl-key - (let* ((pos 0) (len (length lbl-key)) (lbl) c) - (while (< pos len) - (setq c (aref lbl-key pos) - lbl (concat lbl - (if (= c ?_) - (if (or (= (1+ pos) len) - (/= (aref lbl-key (1+ pos)) ?_)) - " " - (setq pos (1+ pos)) - "_") - (char-to-string c))) - pos (1+ pos))) - lbl))) - -(defun ebut:label-p (&optional as-label start-delim end-delim pos-flag) - "Returns key for Hyperbole button label that point is within. -Returns nil if not within a label. -Assumes point is within first line of button label, if at all. -If optional AS-LABEL is non-nil, label is returned rather than the key -derived from the label. Optional START-DELIM and END-DELIM are strings -that override default button delimiters. With optional POS-FLAG non-nil, -returns list of label-or-key, but-start-position, but-end-position. -Positions include delimiters." - (let ((opoint (point)) - (npoint (1+ (point))) - (quoted "\\(^\\|[^\\{]\\)") - (start) - lbl-key end but-start but-end) - (or start-delim (setq start-delim ebut:start)) - (or end-delim (setq end-delim ebut:end)) - (save-excursion - (beginning-of-line) - (while (and (progn - (while (re-search-forward - (concat quoted (regexp-quote start-delim)) - npoint t) - (setq start t)) - start) - (re-search-forward (concat "[^\\{]" (regexp-quote end-delim)) - npoint t)) - (setq start nil)) - (if start - (progn - (setq start (point) - but-start (match-end 1)) - (if (= ?\( (char-syntax (preceding-char))) - (condition-case () - (progn - (forward-char -1) - (forward-list) - (forward-char -2)) - (error (goto-char (1- opoint)))) - (goto-char (1- opoint))) - (and (< (point) (+ start ebut:max-len)) - (re-search-forward (concat quoted (regexp-quote end-delim)) - (+ start ebut:max-len) t) - (setq but-end (point) - end (- (point) (length end-delim)) - lbl-key (ebut:label-to-key (buffer-substring start end))) - (cond (pos-flag - (if as-label - (list (ebut:key-to-label lbl-key) but-start but-end) - (list lbl-key but-start but-end))) - (t (if as-label (ebut:key-to-label lbl-key) lbl-key))))))))) - -(defun ebut:label-regexp (lbl-key &optional no-delim) - "Unnormalizes LBL-KEY. Returns regular expr matching delimited but label. -Optional NO-DELIM leaves off delimiters and leading and trailing space." - (if lbl-key - (let* ((pos 0) - (len (length lbl-key)) - (c) - (sep0 "[ \t\n\^M]*") - (sep "[ \t\n\^M]+") - (regexp (if no-delim "" (concat (regexp-quote ebut:start) sep0))) - (case-fold-search)) - (while (< pos len) - (setq c (aref lbl-key pos) - regexp (concat regexp - (if (= c ?_) - (if (or (= (1+ pos) len) - (/= (aref lbl-key (1+ pos)) ?_)) - sep - (setq pos (1+ pos)) - "_") - (regexp-quote (char-to-string c)))) - pos (1+ pos))) - (if no-delim regexp - (setq regexp (concat regexp sep0 (regexp-quote ebut:end))))))) - -(defun ebut:label-to-key (label) - "Normalizes LABEL for use as a Hyperbole button key and returns key. -Eliminates any fill prefix in the middle of the label, replaces '_' with -'__', removes leading and trailing whitespace and replaces each other -whitespace sequence with '_'." - (if (null label) - nil - (setq label (hbut:fill-prefix-remove label) - ;; Remove leading and trailing space. - label (hypb:replace-match-string "\\`[ \t\n\^M]+\\|[ \t\n\^M]+\\'" - label "" t) - label (hypb:replace-match-string "_" label "__" t)) - (hypb:replace-match-string "[ \t\n\^M]+" label "_" t))) - -(defun ebut:list (&optional file loc-p) - "Returns list of button labels from given FILE or current buffer. -Removes duplicate labels if optional LOC-P is omitted. With LOC-P, returns -list of elements (label start end) where start and end are the buffer -positions at which the starting button delimiter begins and ends." - (interactive) - (setq file (if file (and (file-exists-p file) (find-file-noselect file)) - (current-buffer))) - (if file - (progn - (set-buffer file) - (let ((buts (ebut:map (if loc-p - (function - (lambda (lbl start end) - ;; Normalize label spacing - (list (ebut:key-to-label - (ebut:label-to-key lbl)) - start end))) - (function - (lambda (lbl start end) - ;; Normalize label spacing - (ebut:key-to-label - (ebut:label-to-key lbl)))))))) - (if loc-p buts (if buts (nreverse (set:create buts)))))))) - -(fset 'map-ebut 'ebut:map) -(defun ebut:map (but-func &optional start-delim end-delim - regexp-match include-delims) - "Applies BUT-FUNC to buttons delimited by optional START-DELIM and END-DELIM. -If REGEXP-MATCH is non-nil, only buttons which match this argument are -considered. -Maps over portion of buffer visible under any current restriction. -BUT-FUNC must take precisely three arguments: the button label, the -start position of the delimited button label and its end position (positions -include delimiters when INCLUDE-DELIMS is non-nil). -If END-DELIM is a symbol, e.g. t, then START-DELIM is taken as a regular -expression which matches an entire button string." - (or start-delim (setq start-delim ebut:start)) - (or end-delim (setq end-delim ebut:end)) - (let* ((regexp (symbolp end-delim)) - (end-sym (or regexp (substring end-delim -1))) - (rtn) - (quoted) - start end but lbl) - (save-excursion - (goto-char (point-min)) - (setq include-delims (if include-delims 0 1)) - (while (re-search-forward - (if regexp start-delim - (concat (regexp-quote start-delim) - "\\([^" end-sym "\"][^" end-sym "]*\\)" - (regexp-quote end-delim))) - nil t) - (setq start (match-beginning include-delims) - end (match-end include-delims) - but (buffer-substring (match-beginning 0) (match-end 0)) - lbl (buffer-substring (match-beginning 1) (match-end 1))) - (save-excursion - (goto-char start) - (if (or (= (preceding-char) ?\\) (= (preceding-char) ?\{)) - ;; Ignore matches with quoted delimiters. - (setq quoted t))) - (cond (quoted (setq quoted nil)) - ((or (not regexp-match) - (string-match regexp-match but)) - (setq rtn (cons (funcall but-func lbl start end) rtn)))))) - (nreverse rtn))) - -(defun ebut:modify (&optional lbl-key but-sym) - "Modifies existing Hyperbole button from optional LBL-KEY and BUT-SYM. -Defaults are the key for any button label at point and 'hbut:current'. -If successful, returns button's instance number except when instance -number is 1, then returns t. On failure, as when button does not exist, -returns nil. - -If successful, leaves point in button data buffer, so caller should use -'save-excursion'. Does not save button data buffer." - (save-excursion - (let ((lbl-instance (hbdata:write lbl-key but-sym))) - (run-hooks 'ebut:modify-hook) - lbl-instance))) - -(defun ebut:next-occurrence (lbl-key &optional buffer) - "Moves point to next occurrence of button with LBL-KEY in optional BUFFER. -BUFFER defaults to current buffer. It may be a buffer name. -Returns non-nil iff occurrence is found. - -Remember to use (goto-char (point-min)) before calling this in order to -move to the first occurrence of the button." - (if buffer - (if (not (or (bufferp buffer) - (and (stringp buffer) (get-buffer buffer)))) - (error "(ebut:next-occurrence): Invalid buffer arg: %s" buffer) - (switch-to-buffer buffer))) - (if (re-search-forward (ebut:label-regexp lbl-key) nil t) - (goto-char (+ (match-beginning 0) (length ebut:start))))) - -(defun ebut:operate (curr-label new-label) - "Operates on a new or existing Hyperbole button given by CURR-LABEL. -When NEW-LABEL is non-nil, this is substituted for CURR-LABEL and the -associated button is modified. Otherwise, a new button is created. -Returns instance string appended to label to form unique label, nil if -label is already unique. Signals an error when no such button is found -in the current buffer." - (let* ((lbl-key (ebut:label-to-key curr-label)) - (lbl-regexp (ebut:label-regexp lbl-key)) - (modify new-label) - (instance-flag)) - (or new-label (setq new-label curr-label)) - (hattr:set 'hbut:current 'lbl-key (ebut:label-to-key new-label)) - (save-excursion - (if (setq instance-flag - (if modify (ebut:modify lbl-key) (ebut:create))) - (if (hmail:editor-p) (hmail:msg-narrow)))) - (if instance-flag - (progn - ;; Rename all occurrences of button - those with same label. - (if modify - (let* ((but-key-and-pos (ebut:label-p nil nil nil 'pos)) - (at-but (equal (car but-key-and-pos) - (ebut:label-to-key new-label)))) - (if at-but - (ebut:delimit (nth 1 but-key-and-pos) - (nth 2 but-key-and-pos) - instance-flag)) - (cond ((ebut:map - (function - (lambda (lbl start end) - (delete-region start end) - (ebut:delimit - (point) - (progn (insert new-label) (point)) - instance-flag))) - nil nil lbl-regexp 'include-delims)) - (at-but) - ((hypb:error "(ebut:operate): No button matching: %s" curr-label)))) - ;; Add a new button. - (let (start end buf-lbl) - (cond ((and (marker-position (hypb:mark-marker t)) - (setq start (region-beginning) - end (region-end) - buf-lbl (buffer-substring start end)) - (equal buf-lbl curr-label)) - nil) - ((looking-at (regexp-quote curr-label)) - (setq start (point) - end (match-end 0))) - (t (setq start (point)) - (insert curr-label) - (setq end (point)))) - (ebut:delimit start end instance-flag)) - ) - ;; Position point - (let ((new-key (ebut:label-to-key new-label))) - (cond ((equal (ebut:label-p) new-key) - (forward-char 1) (search-backward ebut:start nil t) - (goto-char (match-end 0))) - ((let ((regexp (ebut:label-regexp new-key))) - (or (re-search-forward regexp nil t) - (re-search-backward regexp nil t))) - (goto-char (+ (match-beginning 0) (length ebut:start)))))) - ;; instance-flag might be 't which we don't want to return. - (if (stringp instance-flag) instance-flag)) - (hypb:error - "(ebut:operate): Operation failed. Check button attribute permissions: %s" - hattr:filename)))) - -(defun ebut:search (string out-buf &optional match-part) - "Writes explicit button lines matching STRING to OUT-BUF. -Uses Hyperbole space into which user has written buttons for the search. -By default, only matches for whole button labels are found, optional MATCH-PART -enables partial matches." - (let* ((buffers (mapcar (function - (lambda (dir) - (expand-file-name hattr:filename dir))) - (hbmap:dir-list))) - (total 0) - (firstmatch)) - (save-excursion - (set-buffer out-buf) - (setq buffer-read-only nil) - (widen) - (erase-buffer) - (let (currbuf currfile kill-buf src-matches dir) - (while buffers - (setq currbuf (car buffers) - currfile (if (stringp currbuf) currbuf) - kill-buf (and currfile (not (get-file-buffer currfile))) - buffers (cdr buffers)) - (if currfile - (setq currbuf (and (file-readable-p currfile) - (find-file-noselect currfile)) - dir (file-name-directory currfile)) - (setq currfile (buffer-file-name currbuf))) - (and currfile currbuf - (unwind-protect - (setq src-matches - (hbdata:search currbuf string match-part)) - (if kill-buf (kill-buffer currbuf)))) - (if src-matches - (let (elt matches) - (while src-matches - (setq elt (car src-matches)) - (if (null elt) nil - (setq src-matches (cdr src-matches) - currfile (expand-file-name (car elt) dir) - matches (cdr elt) - currbuf (get-file-buffer currfile) - kill-buf (not currbuf) - currbuf (or currbuf - (and (file-readable-p currfile) - (find-file-noselect currfile)))) - (if (null currbuf) - (progn (set-buffer out-buf) - (insert "ERROR: (ebut:search): \"" currfile - "\" is not readable.\n\n")) - (set-buffer currbuf) - (unwind-protect - (save-excursion - (widen) (goto-char 1) - (let ((case-fold-search t) - (regexp - (ebut:match-regexp matches match-part))) - (setq firstmatch t) - (while (re-search-forward regexp nil t) - (setq total (1+ total)) - (let* ((linenum (count-lines (point-min) - (point))) - (tag (format "\n%4d:" linenum)) - lns start end) - (setq end (progn (end-of-line) (point)) - start (progn - (goto-char (match-beginning 0)) - (beginning-of-line) (point)) - lns (buffer-substring start end)) - (goto-char end) - (save-excursion - (set-buffer out-buf) - (if firstmatch - (progn - (insert hbut:source-prefix "\"" - currfile "\"\n") - (setq firstmatch nil))) - (insert tag lns)))) - (set-buffer out-buf) - (if (not firstmatch) (insert "\n\n")))) - (if kill-buf (kill-buffer currbuf))))))))))) - total)) - -;;; ------------------------------------------------------------------------ -(defun ebut:delimit (start end instance-str) - "Delimits button label spanning region START to END in current buffer. -If button is already delimited or delimit fails, returns nil, else t. -Inserts INSTANCE-STR after END, before ending delimiter." - (goto-char start) - (if (looking-at (regexp-quote ebut:start)) - (forward-char (length ebut:start))) - (if (ebut:label-p) - nil - (if (not (stringp instance-str)) (setq instance-str "")) - (insert ebut:start) - (goto-char (setq end (+ end (length ebut:start)))) - (insert instance-str ebut:end) - (setq end (+ end (length instance-str) (length ebut:end))) - (and (fboundp 'hproperty:but-add) (hproperty:but-add start end hproperty:but)) - (hbut:comment start end) - (goto-char end) - t)) - -(defun ebut:match-regexp (match-keys match-part) - "Returns regexp to match to all explicit button keys from MATCH-KEYS." - (setq match-part (if match-part - (concat "[^" (substring ebut:end -1) "]*") - "[ \t\n]*")) - (concat - (regexp-quote ebut:start) match-part - "\\(" (mapconcat (function - (lambda (key) (ebut:label-regexp key 'no-delim))) - match-keys "\\|") - "\\)" match-part (regexp-quote ebut:end))) - -(defconst ebut:start "<(" - "String matching the start of a hyper-button.") -(defconst ebut:end ")>" - "String matching the end of a hyper-button.") -(defconst ebut:instance-sep ":" - "String of one character, separates an ebut label from its instance num.") - -;;; ======================================================================== -;;; gbut class - Global Hyperbole buttons - activated by typing label name -;;; ======================================================================== - -(defvar gbut:file (expand-file-name hbmap:filename hbmap:dir-user) - "File that stores Hyperbole buttons accessible by name, global buttons.") - -(defun gbut:act (label) - "Activates Hyperbole global button with LABEL." - (interactive (list (hargs:read-match "Activate global button labeled: " - (mapcar 'list (gbut:label-list)) - nil t nil 'ebut))) - (let* ((lbl-key (hbut:label-to-key label)) - (but (ebut:get lbl-key nil gbut:file))) - (if but - (hbut:act but) - (error "(gbut:act): No global button labeled: %s" label)))) - -(defun gbut:help (label) - "Displays help for Hyperbole global button with LABEL." - (interactive (list (hargs:read-match "Report on global button labeled: " - (mapcar 'list (gbut:label-list)) - nil t nil 'ebut))) - (let* ((lbl-key (hbut:label-to-key label)) - (but (ebut:get lbl-key nil gbut:file))) - (if but - (hbut:report but) - (error "(gbut:help): No global button labeled: %s" label)))) - -(defun gbut:label-list () - "Returns list of global button labels." - (mapcar 'hbut:key-to-label (gbut:key-list))) - -;;; ------------------------------------------------------------------------ -(defun gbut:key-list () - "Returns list of global button label keys." - (save-excursion - (if (hbdata:to-entry-buf gbut:file) - (let ((gbuts)) - (save-restriction - (narrow-to-region (point) (if (search-forward "\^L" nil t) - (point) (point-max))) - (goto-char (point-min)) - (condition-case () - (while (setq gbuts (cons (car (read (current-buffer))) gbuts))) - (error nil)) - gbuts))))) - -;;; ======================================================================== -;;; hattr class -;;; ======================================================================== - -(defun hattr:attributes (obj-symbol) - "Returns a list of OBJ-SYMBOL's attributes as symbols." - (if (symbolp obj-symbol) - (let* ((attr-val-list (symbol-plist obj-symbol)) - (i -1)) - (delq nil (mapcar (function - (lambda (elt) - (setq i (1+ i)) - (and (= (% i 2) 0) elt))) - attr-val-list))))) - -(defun hattr:clear (hbut) - "Removes all of HBUT's attributes except `variable-documentation'." - (let (sublist) - (or (symbolp hbut) - (error "(hattr:clear): Argument not a Hyperbole button: %s" hbut)) - (if (setq sublist (memq 'variable-documentation (symbol-plist hbut))) - (progn - (setcdr (cdr sublist) nil) - (setplist hbut sublist)) - (setplist hbut nil) - ))) - -(defun hattr:copy (from-hbut to-hbut) - "Copies attributes FROM-HBUT TO-HBUT, eliminating attributes TO-HBUT had. -Returns TO-HBUT." - (mapcar - (function - (lambda (hbut) - (or (and hbut (symbolp hbut)) - (error "(hattr:clear): Argument not a Hyperbole button: %s" hbut)))) - (list from-hbut to-hbut)) - (unwind-protect - nil - (hattr:clear to-hbut) - (setplist to-hbut (copy-sequence (symbol-plist from-hbut)))) - to-hbut) - -(defun hattr:get (obj-symbol attr-symbol) - "Returns value of OBJ-SYMBOL's attribute ATTR-SYMBOL." - (get obj-symbol attr-symbol)) - -(defun hattr:list (obj-symbol) - "Returns a property list of OBJ-SYMBOL's attributes. -Each pair of elements is: <attrib-name> <attrib-value>." - (if (symbolp obj-symbol) - (symbol-plist obj-symbol) - (error "(hattr:list): Argument not a symbol: %s" obj-symbol))) - -(defun hattr:memq (attr-symbol obj-symbol) - "Returns t if ATTR-SYMBOL is in OBJ-SYMBOL's attribute list, else nil." - (and (symbolp obj-symbol) (symbolp attr-symbol) - (let* ((attr-val-list (symbol-plist obj-symbol)) - (attr-list (let ((i -1)) - (delq nil (mapcar - (function - (lambda (elt) - (setq i (1+ i)) - (and (= (% i 2) 0) elt))) - attr-val-list))))) - (if (memq attr-symbol attr-list) t)))) - -(defun hattr:report (attrib-list) - "Pretty prints to standard-output attribute-value pairs from ATTRIB-LIST. -Ignores nil valued attributes. Returns t unless no attributes are printed." - (let ((has-attr) attr val len) - (if (or (null attrib-list) (not (listp attrib-list)) - ;; odd number of elements? - (= (% (length attrib-list) 2) 1)) - nil - (while (setq attr (car attrib-list)) - (setq val (car (setq attrib-list (cdr attrib-list))) - attrib-list (cdr attrib-list)) - (if val - (progn - (setq has-attr t - attr (symbol-name attr) - len (max (- 16 (length attr)) 1)) - (princ " ") (princ attr) (princ ":") - (princ (make-string len ? )) - (let (str) - (prin1 (cond ((string-match "time" attr) - (htz:date-unix val - (and (>= (aref val 0) ?0) - (<= (aref val 0) ?9) - "GMT") htz:local)) - ((and (setq str (if (stringp val) val - (prin1-to-string val))) - (string-match "\\`actypes::" str)) - (intern (substring str (match-end 0)))) - (t val)))) - (terpri)))) - has-attr))) - -(defun hattr:save () - "Saves button attribute file for current directory, if modified. -Suitable for use as part of 'write-file-hooks'." - (let* ((bd-file (expand-file-name hattr:filename default-directory)) - (buf (and (stringp default-directory) - (get-file-buffer bd-file)))) - (if (and ebut:hattr-save buf (not (eq buf (current-buffer)))) - (let ((ebut:hattr-save));; Prevents 'write-file-hooks' looping. - (and (buffer-modified-p buf) - (save-excursion - (set-buffer buf) (save-buffer) - ;; Unlock button attribute file; kill buffer so user is - ;; never holding a buffer which is out of sync with file, - ;; due to some other user's edits. - ;; Maybe this should be user or site configurable. - (or (buffer-modified-p buf) (kill-buffer buf)) - ))))) - ;; Must return nil, so can be used as part of write-file-hooks. - nil) - -(defun hattr:set (obj-symbol attr-symbol attr-value) - "Sets OBJ-SYMBOL's attribute ATTR-SYMBOL to ATTR-VALUE." - (put obj-symbol attr-symbol attr-value)) - -(fset 'hattr:summarize 'hattr:report) - -(defvar hattr:filename - (if hyperb:microcruft-os-p "_hypb" ".hypb") - "Per directory file name in which explicit button attributes are stored. -If you change its value, you will be unable to use buttons created by -others who use a different value!") - -;;; ======================================================================== -;;; hbut class - abstract -;;; ======================================================================== - -(defun hbut:act (hbut) - "Performs action for explicit or implicit Hyperbole button symbol HBUT." - (if hbut (apply 'actype:act (hattr:get hbut 'actype) - (hattr:get hbut 'args)))) - -(defun hbut:action (hbut) - "Returns appropriate action for Hyperbole button symbol HBUT." - (let ((categ (hattr:get hbut 'categ)) (atype) (action)) - (if (eq categ 'explicit) - (progn (setq action (hattr:get hbut 'action) - atype (hattr:get hbut 'actype)) - (if (= (length (symbol-name atype)) 2) - atype - (or action (actype:action atype)))) - ;; Must be an implicit button. - (if (fboundp atype) atype)))) - -(defun hbut:at-p () - "Returns symbol for explicit or implicit Hyperbole button at point or nil." - (or (ebut:at-p) (ibut:at-p))) - - -(defun hbut:comment (start end) - "Comment button label spanning region START to END in current buffer. -Use buffer commenting grammar, if any, otherwise don't comment." - (save-excursion - (if comment-start - (if (or (equal comment-end "") - (null comment-end)) - (progn - (beginning-of-line) - (if (search-forward comment-start start t) - nil - (goto-char start) - (insert comment-start) - (if (/= (preceding-char) ? ) - (insert ? )))) - ;; Comments have both start and end delimiters - (if (and (re-search-backward - (concat (regexp-quote comment-start) "\\|" - (regexp-quote comment-end)) - nil t) - (looking-at (regexp-quote comment-start))) - nil - (goto-char start) - (insert comment-start) - (if (/= (preceding-char) ? ) - (insert ? )) - (goto-char (+ (point) (- end start))) - (if (/= (following-char) ? ) - (insert ? )) - (insert comment-end) - ))))) - -;;; Regexps derived in part from "filladapt.el" under the GPL, Copyright -;;; 1989 Kyle E. Jones. -(defvar hbut:fill-prefix-regexps - '( - ;; Included text in news or mail messages - "\n[ \t]*\\([:|<>]+ *\\)+" - ;; Included text generated by SUPERCITE. We can't hope to match all - ;; the possible variations. - "\n[ \t]*[^'`\"< \t]*> *" - ;; Lisp comments - "\n[ \t]*\\(;+[ \t]*\\)+" - ;; UNIX shell comments - "\n[ \t]*\\(#+[ \t]*\\)+" - ;; C++ comments - "\n[ \t]*//[/ \t]+" - ;; C or Pascal comments, one open and close per line, so match close - ;; then open. - "\\*+[/\)][ \t]*\n+[ \t]*[/\(]\\*+" - "}[ \t]*\n+[ \t]*{" - ;; Eiffel or Sather comments - "\n[ \t]*--[ \t]+" - ;; Fortran comments - "\n[Cc][ \t]+" - ;; Postscript comments - "\n[ \t]*\\(%+[ \t]*\\)+" - ) - "List of regexps of fill prefixes to remove from the middle of buttons.") - -(defun hbut:fill-prefix-remove (label) - "Removes any recognized fill prefix from within LABEL. -'hbut:fill-prefix-regexps' is a list of fill prefixes to recognize." - (if (string-match "\n" label) - (mapcar - (function - (lambda (fill-prefix) - (and (string-match "\n" label) - (setq label - (hypb:replace-match-string fill-prefix label " " t))))) - hbut:fill-prefix-regexps)) - label) - -(defun hbut:is-p (object) - "Returns non-nil if object denotes a Hyperbole button." - (and (symbolp object) (hattr:get object 'categ))) - -(fset 'hbut:key-src 'ebut:key-src) -(fset 'hbut:key-to-label 'ebut:key-to-label) - -(defun hbut:label (hbut) - "Returns the label for Hyperbole button symbol HBUT." - (if (hbut:is-p hbut) - (hbut:key-to-label (hattr:get hbut 'lbl-key)) - (error "(hbut:label): Argument is not a Hyperbole button symbol, '%s'" - hbut))) - -(fset 'hbut:label-p 'ebut:label-p) -(fset 'hbut:label-to-key 'ebut:label-to-key) - -(defun hbut:report (&optional arg) - "Pretty prints the attributes of a button or buttons. - -Takes an optional ARG interpreted as follows: - a button symbol - report on that button; - nil - report on button at point, if any; - integer > 0 - report on all explicit buttons in buffer, alphabetize; - integer < 1 - report on all explicit buttons in occurrence order; - -Returns number of buttons reported on or nil if none." - (setq arg (cond ((or (integerp arg) (symbolp arg)) arg) - ((listp arg) - (if (integerp (setq arg (car arg))) arg 1)) - (t 1))) - (let* ((but (if (and arg (symbolp arg)) arg (hbut:at-p))) - (curr-key (and but (hattr:get but 'lbl-key))) - (key-src (or (and but (hattr:get but 'loc)) (hbut:key-src))) - (lbl-lst (cond ((not arg) - (if curr-key (list (ebut:key-to-label curr-key)))) - ((symbolp arg) (if curr-key - (list (hbut:key-to-label - (hattr:get arg 'lbl-key))))) - ((< arg 1) (ebut:list)) - (t (sort (ebut:list) - (function - (lambda (s1 s2) - (string< (downcase s1) (downcase s2)))))))) - (key-buf (current-buffer)) - (buf-name (hypb:help-buf-name)) - (attribs)) - (if lbl-lst - (progn - (with-output-to-temp-buffer buf-name - (princ hbut:source-prefix) - (prin1 key-src) - (terpri) - (terpri) - (mapcar - (function - (lambda (lbl) - (if (setq but - (cond ((or (null arg) (symbolp arg)) but) - (t (ebut:get (ebut:label-to-key lbl) key-buf))) - attribs (hattr:list but)) - (progn - (princ (if (ibut:is-p but) - lbl - (concat ebut:start lbl ebut:end))) - (terpri) - (let ((doc (actype:doc but (= 1 (length lbl-lst))))) - (if doc - (progn - (princ " ") - (princ doc) - (terpri)))) - (hattr:report -;; (if (eq (car (cdr (memq 'categ attribs))) 'explicit) -;; (memq 'action attribs) -;; (memq 'categ attribs)) - attribs) - (terpri)) - ))) - lbl-lst)) - (length lbl-lst))))) - -(defun hbut:source (&optional full) - "Returns Hyperbole source buffer or file given at point. -If a file, always returns a full path if optional FULL is non-nil." - (goto-char (match-end 0)) - (cond ((looking-at "#<buffer \"?\\([^ \n\"]+\\)\"?>") - (get-buffer (buffer-substring (match-beginning 1) - (match-end 1)))) - ((looking-at "\".+\"") - (let* ((file (buffer-substring (1+ (match-beginning 0)) - (1- (match-end 0)))) - (absolute (file-name-absolute-p file))) - (if (and full (not absolute)) - (expand-file-name file default-directory) - file))))) - -(fset 'hbut:summarize 'hbut:report) - -(defvar hbut:current nil - "Currently selected Hyperbole button. -Available to action routines.") - -(defconst hbut:source-prefix moccur-source-prefix - "String found at start of a buffer containing only a hyper-button menu. - This expression should be followed immediately by a file-name indicating the -source file for the buttons in the menu, if any.") - -;;; ======================================================================== -;;; htype class - Hyperbole Types, e.g. action and implicit button types -;;; ======================================================================== - -(require 'set) - -(defun htype:body (htype-sym) - "Return body for HTYPE-SYM. If HTYPE-SYM is nil, return nil." - (and htype-sym (hypb:indirect-function htype-sym))) - -(defun htype:category (type-category) - "Return list of symbols in Hyperbole TYPE-CATEGORY in priority order. -Symbols contain category component. -TYPE-CATEGORY should be 'actypes, 'ibtypes or nil for all." - (let ((types (symset:get type-category 'symbols)) - (categ-name (symbol-name type-category))) - (mapcar (function - (lambda (type) - (intern (concat categ-name "::" (symbol-name type))))) - types))) - -;; Thanks to JWZ for help on this. -(defmacro htype:create (type type-category doc params body property-list) - "Create a new Hyperbole TYPE within TYPE-CATEGORY (both unquoted symbols). -Third arg DOC is a string describing the type. -Fourth arg PARAMS is a list of parameters to send to the fifth arg BODY, -which is a list of forms executed when the type is evaluated. -Sixth arg PROPERTY-LIST is attached to the new type's symbol. - -This symbol is returned." - (let* ((sym (htype:symbol type type-category)) - (action (nconc (list 'defun sym params doc) body))) - (` (progn - (, action) - (setplist '(, sym) (, property-list)) - (symset:add '(, type) '(, type-category) 'symbols) - (run-hooks 'htype:create-hook) - '(, sym))))) - -(defun htype:delete (type type-category) - "Delete a Hyperbole TYPE derived from TYPE-CATEGORY (both symbols). -Return the Hyperbole symbol for the TYPE if it existed, else nil." - (let* ((sym (htype:symbol type type-category)) - (exists (fboundp 'sym))) - (setplist sym nil) - (symset:delete type type-category 'symbols) - (fmakunbound sym) - (run-hooks 'htype:delete-hook) - (and exists sym))) - -(defun htype:doc (type) - "Return documentation for Hyperbole TYPE, a symbol." - (documentation type)) - -(defun htype:names (type-category &optional sym) - "Return list of current names for Hyperbole TYPE-CATEGORY in priority order. -Names do not contain category component. -TYPE-CATEGORY should be 'actypes, 'ibtypes or nil for all. -When optional SYM is given, return the name for that symbol only, if any." - (let ((types (symset:get type-category 'symbols)) - (sym-name (and sym (symbol-name sym)))) - (if sym-name - ;; Strip category from sym-name before looking for a match. - (progn (if (string-match "::" sym-name) - (setq sym (intern (substring sym-name (match-end 0))))) - (if (memq sym types) (symbol-name sym))) - (mapcar 'symbol-name types)))) - -;;; ------------------------------------------------------------------------ - -(defun htype:symbol (type type-category) - "Return Hyperbole type symbol composed from TYPE and TYPE-CATEGORY (both symbols)." - (intern (concat (symbol-name type-category) "::" - (symbol-name type)))) - -;;; ======================================================================== -;;; ibut class - Implicit Hyperbole Buttons -;;; ======================================================================== - -(defun ibut:at-p (&optional key-only) - "Returns symbol for implicit button at point, else nil. -With optional KEY-ONLY, returns only the label key for button." - (let ((types (htype:category 'ibtypes)) - ;; Global var used in (hact) function, don't delete. - (hrule:action 'actype:identity) - (itype) - (args) - (is-type)) - (or key-only (hattr:clear 'hbut:current)) - (while (and (not is-type) types) - (setq itype (car types)) - (if (setq args (funcall itype)) - (setq is-type itype) - (setq types (cdr types)))) - (if is-type - (if key-only - (hattr:get 'hbut:current 'lbl-key) - (hattr:set 'hbut:current 'loc (save-excursion - (hbut:key-src 'full))) - (hattr:set 'hbut:current 'categ is-type) - (or (hattr:get 'hbut:current 'args) - (not (listp args)) - (progn - (hattr:set 'hbut:current 'actype - (or - ;; Hyperbole action type - (intern-soft (concat "actypes::" - (symbol-name (car args)))) - ;; Regular Emacs Lisp function symbol - (car args) - )) - (hattr:set 'hbut:current 'args (cdr args)))) - 'hbut:current)))) - -(defun ibut:is-p (object) - "Returns non-nil if object denotes an implicit Hyperbole button." - (if (symbolp object) - (let ((categ (hattr:get object 'categ))) - (and categ (string-match "^ibtypes::" (symbol-name categ)))))) - -(defun ibut:label-p () - "Returns key for Hyperbole implicit button label that point is on or nil." - (ibut:at-p 'key-only)) - -(defun ibut:label-set (label &optional start end) - "Sets current implicit button attributes from LABEL and START, END position. -Returns label. START and END are optional. When given, they specify the -region in the buffer to flash when this implicit button is activated or -queried for its attributes. If LABEL is a list, it is assumed to contain all -arguments." - (cond ((stringp label) - (hattr:set 'hbut:current 'lbl-key (hbut:label-to-key label)) - (and start (hattr:set 'hbut:current 'lbl-start start)) - (and end (hattr:set 'hbut:current 'lbl-end end))) - ((and label (listp label)) - (hattr:set 'hbut:current 'lbl-key (hbut:label-to-key (car label))) - (hattr:set 'hbut:current 'lbl-start (nth 1 label)) - (hattr:set 'hbut:current 'lbl-end (nth 2 label))) - (t (error "(ibut:label-set): Invalid label arg: '%s'" label))) - label) - -;;; ======================================================================== -;;; ibtype class - Implicit button types -;;; ======================================================================== - -(fset 'defib 'ibtype:create) -(put 'ibtype:create 'lisp-indent-function 'defun) -(defmacro ibtype:create (type params doc at-p &optional to-p style) - "Creates implicit button TYPE (unquoted sym) with PARAMS, described by DOC. -PARAMS are presently ignored. - - AT-P is a boolean form of no arguments which determines whether or not point -is within a button of this type. - Optional TO-P is a boolean form which moves point immediately after the next -button of this type within the current buffer and returns a list of (button- -label start-pos end-pos), or nil when none is found. - Optional STYLE is a display style specification to use when highlighting -buttons of this type; most useful when TO-P is also given. - -Returns symbol created when successful, else nil. Nil indicates that action -type for ibtype is presently undefined." - (if type - (let ((to-func (if to-p (action:create nil (list to-p)))) - (at-func (list at-p))) - (` (htype:create (, type) ibtypes (, doc) nil (, at-func) - (list 'to-p (, to-func) 'style (, style))))))) - -(defun ibtype:delete (type) - "Deletes an implicit button TYPE (a symbol). -Returns TYPE's symbol if it existed, else nil." - (htype:delete type 'ibtypes)) - -;;; ======================================================================== -;;; symset class - Hyperbole internal symbol set maintenance -;;; ======================================================================== - -(require 'set) - -(defun symset:add (elt symbol prop) - "Adds ELT to SYMBOL's PROP set. -Returns nil iff ELT is already in SET. Uses 'eq' for comparison." - (let* ((set (get symbol prop)) - (set:equal-op 'eq) - (new-set (set:add elt set))) - (and new-set (put symbol prop new-set)))) - -(fset 'symset:delete 'symset:remove) - -(defun symset:get (symbol prop) - "Returns SYMBOL's PROP set." - (get symbol prop)) - -(defun symset:remove (elt symbol prop) - "Removes ELT from SYMBOL's PROP set and returns the new set. -Assumes PROP is a valid set. Uses 'eq' for comparison." - (let ((set (get symbol prop)) - (set:equal-op 'eq)) - (put symbol prop (set:remove elt set)))) - - -(provide 'hbut)
--- a/lisp/hyperbole/hgnus.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,139 +0,0 @@ -;;!emacs -;; -;; FILE: hgnus.el -;; SUMMARY: Support Hyperbole buttons in news reader/poster: GNUS. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: hypermedia, news -;; -;; AUTHOR: Bob Weiner -;; ORG: InfoDock Associates -;; -;; ORIG-DATE: 24-Dec-91 at 22:29:28 by Bob Weiner -;; LAST-MOD: 26-Jan-97 at 14:43:54 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1991-1996, Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; -;; This only works with GNUS 3.15 or above, so be sure to check your -;; newsreader version {M-ESC gnus-version RET} before reporting any -;; problems. -;; -;; Automatically configured for use in "hyperbole.el". -;; If hsite loading fails prior to initializing Hyperbole Gnus support, -;; -;; {M-x Gnus-init RET} -;; -;; will do it. -;; -;; -;; Have not yet overloaded 'news-reply-yank-original' -;; to yank and hide button data from news article buffer. -;; -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Other required Elisp libraries -;;; ************************************************************************ - -(require 'hmail) -(require 'hsmail) -(cond ((or (featurep 'gnus-msg) - (featurep 'gnuspost))) - ((load "gnus-msg" t)) - (t (load "gnuspost" t))) - -;;; ************************************************************************ -;;; Public variables -;;; ************************************************************************ - -(setq hnews:composer 'news-reply-mode - hnews:lister 'gnus-summary-mode - hnews:reader 'gnus-article-mode) - - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -(defun Gnus-init () - "Initializes Hyperbole support for Gnus Usenet news reading." - (interactive) - nil) - -(defun lnews:to () - "Sets current buffer to the Usenet news article summary listing buffer." - (and (eq major-mode hnews:reader) (set-buffer gnus-summary-buffer))) - -(defun rnews:to () - "Sets current buffer to the Usenet news article reader buffer." - (and (eq major-mode hnews:lister) (set-buffer gnus-article-buffer))) - -(defun rnews:summ-msg-to () - "Displays news message associated with current summary header." - (let ((article (gnus-summary-article-number))) - (if (or (null gnus-current-article) - (/= article gnus-current-article)) - ;; Selected subject is different from current article's. - (gnus-summary-display-article article)))) - - -;;; Overlay 'gnus-inews-article' from "gnuspost.el" to make it include -;;; any signature before Hyperbole button data. Does this by having -;;; signature inserted within narrowed buffer and then applies a hook to -;;; have the buffer widened before sending. -(hypb:function-symbol-replace - 'gnus-inews-article 'widen 'hmail:msg-narrow) - -;;; Overload this function from "rnewspost.el" for supercite compatibility -;;; only when supercite is in use. -(if (hypb:supercite-p) - (defun news-reply-yank-original (arg) - "Supercite version of news-reply-yank-original. -Insert the message being replied to in the reply buffer. Puts point -before the mail headers and mark after body of the text. Calls -mail-yank-original to actually yank the message into the buffer and -cite text. - -If mail-yank-original is not overloaded by supercite, each nonblank -line is indented ARG spaces (default 3). Just \\[universal-argument] -as ARG means don't indent and don't delete any header fields." - (interactive "P") - (mail-yank-original arg) - (exchange-point-and-mark) - (run-hooks 'news-reply-header-hook)) - ) - -;;; ************************************************************************ -;;; Private variables -;;; ************************************************************************ -;;; -(var:append 'gnus-Inews-article-hook '(widen)) -;;; -;;; Hide any Hyperbole button data and highlight buttons if possible -;;; in news article being read. -(var:append 'gnus-article-prepare-hook - (if (fboundp 'hproperty:but-create) - '(hmail:msg-narrow hproperty:but-create) - '(hmail:msg-narrow))) - -(if (fboundp 'hproperty:but-create) - (var:append 'gnus-summary-prepare-hook '(hproperty:but-create))) - -;;; Try to setup comment addition as the first element of these hooks. -(if (fboundp 'add-hook) - ;; Called from 'news-post-news' if prev unsent article exists and user - ;; says erase it. Add a comment on Hyperbole button support. - (progn - (add-hook 'news-setup-hook 'smail:comment-add) - ;; Called from 'news-post-news' if no prev unsent article exists. - ;; Add a comment on Hyperbole button support. - (add-hook 'news-reply-mode-hook 'smail:comment-add)) - (var:append 'news-setup-hook '(smail:comment-add)) - (var:append 'news-reply-mode-hook '(smail:comment-add))) - -(provide 'hgnus)
--- a/lisp/hyperbole/hhist.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,90 +0,0 @@ -;;!emacs -;; -;; FILE: hhist.el -;; SUMMARY: Maintains history of Hyperbole buttons selected. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: hypermedia -;; -;; AUTHOR: Bob Weiner -;; ORG: Brown U. -;; -;; ORIG-DATE: 24-Apr-91 at 03:36:23 -;; LAST-MOD: 14-Apr-95 at 16:02:05 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1991-1995, Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; -;; This is minimal right now and will be extended. -;; Currently, it implements a push-pop stack of traversed locations. -;; -;; It will be extended to allow random access to previous locations -;; and to store traversal histories for later recall. -;; -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -(defun hhist:add (elt) - "Adds ELT to hyper-history list if not the same as current or previous loc. -ELT must have been created via a call to 'hhist:element'." - ;; Even though this next line looks useless, it cures a problem with - ;; window buffer correspondences on startup, so don't remove it. - (set-buffer (window-buffer (selected-window))) - (let ((prev-buf (car elt))) - (if (or (equal prev-buf (buffer-name)) - (equal prev-buf (car (car *hhist*)))) - nil - (setq *hhist* (cons elt *hhist*))))) - -(defun hhist:element () - "Returns a history element for current point location." - (list (current-buffer) (point))) - -(defun hhist:remove (&optional arg) - "Removes optional prefix ARG entries from history, returns to ARGth location. -The command is ignored with ARG < 1." - (interactive "p") - (setq arg (or arg 1)) - (let ((prev-buf-line)) - (if (null *hhist*) - (and (> arg 0) - (message "(hhist:remove): No previous source to which to return.") - (beep)) - (while (and (> arg 0) *hhist*) - (setq prev-buf-line (car *hhist*) - *hhist* (cdr *hhist*) - arg (1- arg))) - (switch-to-buffer (car prev-buf-line)) - (goto-char (car (cdr prev-buf-line))) - ))) - -(defun hhist:init () - "Resets history list." - (interactive) - (setq *hhist* nil)) - -;;; ************************************************************************ -;;; Private functions -;;; ************************************************************************ - -(defun hhist:wind-line () - "Returns window relative line number that point is on." - (max 0 (1- (- (count-lines 1 (1+ (point))) - (count-lines 1 (window-start)))))) - -;;; ************************************************************************ -;;; Private variables -;;; ************************************************************************ - -(defconst *hhist* nil - "List of previously visited Hyperbole button source locations. -Car of list is most recent.") - -(provide 'hhist)
--- a/lisp/hyperbole/hib-doc-id.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,229 +0,0 @@ -;;!emacs -;; -;; FILE: hib-doc-id.el -;; SUMMARY: Implicit button type for document id index entries. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: docs, extensions, hypermedia -;; -;; AUTHOR: Bob Weiner -;; ORG: InfoDock Associates -;; -;; ORIG-DATE: 30-Sep-92 at 19:39:59 -;; LAST-MOD: 12-Dec-96 at 15:15:28 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1992-1996, InfoDock Associates -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; -;; TO USE: -;; -;; Pressing the Action Key on a doc id such as, [Emacs-001], -;; displays the online version of the document, if any. Pressing the -;; Assist Key on it displays its document index entry. -;; -;; TO INSTALL: -;; -;; Set the value of 'doc-id-indices' before using the 'doc-id' -;; implicit button type defined herein or you will get an error telling you -;; to do so. See the documentation for 'doc-id-indices'. -;; -;; You must explicitly load this package in order to use it, since -;; Hyperbole does not load it by default. -;; -;; Motorola PPG uses doc ids of the form, [Emacs-001], delimited by -;; brackets, starting with a subject name, followed by a - and a -;; multi-digit numeric identifier. -;; -;; Typically an index entry should have links to all available forms of its -;; document, e.g. online, printed, source. Below is the index entry form -;; we use. The default variable settings herein work with PPG's formats. If -;; you prefer different ones, you must change all of the variable values. -;; -;; -------------------------------------------------------------------------- -;; Title: ID: [] -;; Email-To: -;; Distribution: -;; -;; Abstract: -;; -;; -;; References: -;; -;; Author: -;; Copyright: -;; Keywords: -;; -;; Online-Format: -;; Online-Loc: "" -;; Printed-Format: -;; Printed-Loc: Local Library -;; Printable-Loc: "" -;; Source-Format: -;; Source-Loc: "" -;; -;; Date: -;; Version: -;; Version-Changes: -;; -------------------------------------------------------------------------- -;; -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Public implicit button types -;;; ************************************************************************ - -;;; ======================================================================== -;;; Displays a documentation index entry given an ID. -;;; ======================================================================== - -(defact link-to-doc (doc-id) - "Displays online version of a document given by DOC-ID (no delimiters), in other window. -If online version of document is not found in `doc-id-indices', an error is -signalled." - (interactive "sID for document to link to (omit delimiters): ") - (let ((rolo-display-buffer (hypb:help-buf-name "Doc ID")) - (delim-doc-id (concat doc-id-start doc-id doc-id-end))) - (cond ((null doc-id-indices) - (error "(doc-id-index-entry): You must set the `doc-id-indices' variable first.")) - ((let ((rolo-entry-regexp doc-id-index-entry-regexp)) - (= 0 (rolo-grep (funcall doc-id-match doc-id) - 1 doc-id-indices nil 'no-display))) - (error "(doc-id-index-entry): %s not found in document index." - delim-doc-id)) - ;; Matching index entry has been put into 'rolo-display-buffer'. - (t (save-excursion - (set-buffer rolo-display-buffer) - (goto-char (point-min)) - (message "Searching for document %s..." delim-doc-id) - (if (re-search-forward doc-id-online-regexp nil t) - (progn - (goto-char (match-beginning 1)) - (let ((doc-path (buffer-substring - (match-beginning 1) (match-end 1))) - (ibut (ibut:at-p))) - (if ibut - (progn (hbut:act ibut) - (message "Displaying %s." delim-doc-id)) - (error - "(link-to-doc): %s online location is invalid: \"%s\"" - delim-doc-id doc-path)))) - (error "(link-to-doc): %s is unavailable in online form." - delim-doc-id))))))) - -(defib doc-id () - "Displays an index entry for a site-specific document given its id. -Ids must be delimited by `doc-id-start' and `doc-id-end' and must -match the function given by `doc-id-p'." - (and (not (bolp)) - (let* ((id-and-pos (hbut:label-p t doc-id-start doc-id-end t)) - (id (car id-and-pos))) - (if (funcall doc-id-p id) - (progn (ibut:label-set id-and-pos) - (hact 'link-to-doc id)))))) - - -;;; ======================================================================== -;;; Displays a doc from SW Process Tree (Motorola Paging Products Specific) -;;; ======================================================================== - -(if (and (boundp 'ppg-sw-process-directory) ppg-sw-process-directory - (file-exists-p ppg-sw-process-directory)) - (defib ppg-sw-process () - "Display a Paging Products software process document whose location is at point." - (let ((path (hpath:at-p nil t))) - (if (and path (string-match "/.+%s.+%s" path)) - (progn (require 'sw-process) - (ibut:label-set path) - (setq path (format path ppg-sw-process-file-format - ppg-sw-process-file-suffix)) - (if (file-exists-p path) - (hact 'link-to-file path) - (if (re-search-forward - "^Source-Loc:[ \t]*\"\\([^\"]+\\)\"" nil t) - (progn - (goto-char (match-beginning 1)) - (let ((path-but (ibut:at-p))) - (if path-but - (hbut:act path-but) - (error - "(ppg-sw-process): \"%s\" does not exist." path) - )))))))))) - -;;; ************************************************************************ -;;; Public variables -;;; ************************************************************************ - -(defvar doc-id-indices '() - "List of pathnames in which to search for site-specific document index entries. -Each file must utilize a wrolo record format, with each record start -delimited by `doc-id-index-entry-regexp'.") - -;;; ************************************************************************ -;;; Private functions -;;; ************************************************************************ - -(defun doc-id:help (but) - "Displays site-specific document index entry given by doc-id BUT, in other window. -Also displays standard Hyperbole help for implicit button BUT." - (let ((rolo-entry-regexp doc-id-index-entry-regexp) - (rolo-display-buffer (hypb:help-buf-name "Doc ID")) - (doc-id (hbut:key-to-label (hattr:get but 'lbl-key)))) - (cond ((null doc-id-indices) - (error "(doc-id-index-entry): You must set the 'doc-id-indices' variable first.")) - ((= 0 (rolo-grep (funcall doc-id-match doc-id) 1 doc-id-indices)) - (error - "(doc-id-index-entry): No document index entry found for %s%s%s." - doc-id-start doc-id doc-id-end))) - (let* ((report-buf (hypb:help-buf-name)) - (temp-buffer-show-hook - (function - (lambda (buffer) - (setq *hkey-wconfig* (current-window-configuration))) - (let ((wind (get-buffer-create buffer))) - (setq minibuffer-scroll-window wind)))) - (temp-buffer-show-function temp-buffer-show-hook)) - (hbut:report but) - (save-excursion - (set-buffer rolo-display-buffer) - (setq buffer-read-only nil) - (goto-char (point-max)) - (insert-buffer report-buf) - (set-buffer-modified-p nil) - (setq buffer-read-only nil) - (goto-char (point-min))) - (kill-buffer report-buf) - ))) - -;;; ************************************************************************ -;;; Private variables -;;; ************************************************************************ - -(defvar doc-id-start "[" - "String which delimits start of a site-specific document id.") -(defvar doc-id-end "]" - "String which delimits end of a site-specific document id.") - -(defvar doc-id-index-entry-regexp "^------+[ \t\n]+Title:" - "Regexp which matches start of a site-specific document index entry.") - -(defvar doc-id-match - (function (lambda (doc-id) - (concat "ID:[ \t]*\\[" (regexp-quote doc-id) "\\]"))) - "Function which returns regexp which matches only in DOC-ID's index entry.") - -(defvar doc-id-p (function - (lambda (str) - (and (stringp str) - (> (length str) 0) - (= ?w (char-syntax (aref str 0))) - (string-match "\\`\\w+-[0-9][0-9][0-9]+\\'" str)))) - "Function with a boolean result which tests whether or not arg `str' is a doc id.") - -(defvar doc-id-online-regexp "^Online-Loc:[ \t]*\"\\([^\"]+\\)\"" - "Regexp whose 1st grouping matches an implicit button which displays an online document within an index entry.") - -(provide 'hib-doc-id)
--- a/lisp/hyperbole/hib-kbd.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,154 +0,0 @@ -;;!emacs -;; -;; FILE: hib-kbd.el -;; SUMMARY: Implicit button type for key sequences delimited with {}. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: extensions, hypermedia -;; -;; AUTHOR: Bob Weiner -;; ORG: Brown U. -;; -;; ORIG-DATE: 22-Nov-91 at 01:37:57 -;; LAST-MOD: 23-Oct-95 at 05:02:49 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1991-1995, Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; -;; A click of the Hyperbole execution key on a key sequence executes its -;; command binding. -;; -;; A click of the Hyperbole help key on a key sequence displays the -;; documentation for its command binding. -;; -;; Key sequences should be in human readable form, e.g. {C-b}. -;; Forms such as {\C-b}, {\^b}, and {^b} will not be recognized. -;; -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Public implicit button types -;;; ************************************************************************ - -(defact kbd-key (key-sequence) - "Executes the function binding for KEY-SEQUENCE, delimited by {}. -Returns t if a KEY-SEQUENCE has a binding, else nil." - (interactive "kKeyboard key to execute (no {}): ") - (kbd-key:act key-sequence)) - -(defib kbd-key () - "Executes a key sequence delimited by curly braces. -Key sequences should be in human readable form, e.g. {C-b}. -Forms such as {\C-b}, {\^b}, and {^b} will not be recognized." - (if (br-in-browser) - nil - (let* ((seq-and-pos (or (hbut:label-p t "{`" "'}" t) - (hbut:label-p t "{" "}" t))) - (key-sequence (car seq-and-pos)) - (binding (and (stringp key-sequence) - (key-binding (kbd-key:normalize key-sequence))))) - (and binding (not (integerp binding)) - (ibut:label-set seq-and-pos) - (hact 'kbd-key key-sequence))))) - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -(defun kbd-key:act (key-sequence) - "Executes the command binding for KEY-SEQUENCE. -Returns t if KEY-SEQUENCE has a binding, else nil." - (interactive "kKeyboard key to execute (no {}): ") - (setq current-prefix-arg nil) ;; kbd-key:normalize below sets it. - (let ((binding (key-binding (kbd-key:normalize key-sequence)))) - (cond ((null binding) nil) - ((memq binding '(action-key action-mouse-key hkey-either)) - (beep) - (message "(kbd-key:act): This key does what the Action Key does.") - t) - (t (call-interactively binding) t)))) - -(defun kbd-key:doc (key &optional full) - "Shows first line of doc for binding of keyboard KEY in minibuffer. -With optional FULL, displays full documentation for command." - (interactive "kKey sequence: \nP") - (let* ((cmd (let ((cmd (key-binding (kbd-key:normalize key)))) - (if (not (integerp cmd)) cmd))) - (doc (and cmd (documentation cmd))) - (end-line)) - (if doc - (or full - (setq end-line (string-match "[\n]" doc) - doc (substitute-command-keys (substring doc 0 end-line)))) - (setq doc (format "No documentation for {%s} %s" key (or cmd "")))) - (if (and cmd doc) - (if full - (describe-function cmd) - (message doc))))) - -(defun kbd-key:help (but) - "Display documentation for binding of keyboard key given by BUT's label." - (let ((kbd-key (hbut:key-to-label (hattr:get but 'lbl-key)))) - (and kbd-key (kbd-key:doc kbd-key 'full)))) - -(defun kbd-key:normalize (key-sequence) - "Returns KEY-SEQUENCE normalized into a form that can be parsed by commands." - (interactive "kKeyboard key sequence to normalize (no {}): ") - (let ((norm-key-seq (copy-sequence key-sequence)) - (case-fold-search nil) (case-replace t)) - ;; Quote Control and Meta key names - (setq norm-key-seq (hypb:replace-match-string - "[ \t\n\^M]+" norm-key-seq "" t) - norm-key-seq (hypb:replace-match-string - "@key{SPC}\\|SPC" norm-key-seq "\040" t) - norm-key-seq (hypb:replace-match-string - "@key{DEL}\\|DEL" norm-key-seq "\177" t) - norm-key-seq (hypb:replace-match-string - "@key{RET}\\|@key{RTN}\\|RET\\|RTN" - norm-key-seq "\015" t) - norm-key-seq (hypb:replace-match-string - "ESCESC" norm-key-seq "\233" t) - norm-key-seq (hypb:replace-match-string - "@key{ESC}\\|ESC" norm-key-seq "M-" t) - ;; Unqote special {} chars. - norm-key-seq (hypb:replace-match-string "\\\\\\([{}]\\)" - norm-key-seq "\\1") - ) - (while (string-match "\\`\\(C-u\\|M-\\)\\(-?[0-9]+\\)" norm-key-seq) - (setq current-prefix-arg - (string-to-int (substring norm-key-seq (match-beginning 2) - (match-end 2))) - norm-key-seq (substring norm-key-seq (match-end 0)))) - (let (arg-val) - (while (string-match "\\`C-u" norm-key-seq) - (if (or (not (listp current-prefix-arg)) - (not (integerp (setq arg-val (car current-prefix-arg))))) - (setq current-prefix-arg '(1) - arg-val 1)) - (setq arg-val (* arg-val 4) - current-prefix-arg (cons arg-val nil) - norm-key-seq (substring norm-key-seq (match-end 0))))) - (setq norm-key-seq (hypb:replace-match-string - "C-\\(.\\)" norm-key-seq - (function - (lambda (str) - (char-to-string - (1+ (- (downcase - (string-to-char - (substring str (match-beginning 1) - (1+ (match-beginning 1))))) - ?a))))))) - (hypb:replace-match-string - "M-\\(.\\)" norm-key-seq - (function - (lambda (str) - (char-to-string (+ (downcase (string-to-char - (substring str (match-beginning 1) - (1+ (match-beginning 1))))) - 128))))))) - -(provide 'hib-kbd)
--- a/lisp/hyperbole/hibtypes.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,556 +0,0 @@ -;;!emacs -;; -;; FILE: hibtypes.el -;; SUMMARY: Hyperbole System Implicit Button Types. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: extensions, hypermedia -;; -;; AUTHOR: Bob Weiner -;; ORG: InfoDock Associates -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1991-1997 Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; ORIG-DATE: 19-Sep-91 at 20:45:31 -;; LAST-MOD: 20-Feb-97 at 11:17:04 by Bob Weiner - -;;; ************************************************************************ -;;; Other required Elisp libraries -;;; ************************************************************************ - -(require 'hactypes) - -;;; ************************************************************************ -;;; Public implicit button types -;;; ************************************************************************ - -(run-hooks 'hibtypes:begin-load-hook) - -;;; ======================================================================== -;;; Use func-menu.el to jump to a function referred to in the same file in -;;; which it is defined. Function references across files are handled -;;; separately be clauses within the `hkey-alist' variable. -;;; ======================================================================== - -(defib function-in-buffer () - "Return function name defined within this buffer that point is within or after, else nil. -This triggers only when the func-menu.el package has been loaded and the -current major mode is one handled by func-menu." - (if (and (boundp 'fume-function-name-regexp-alist) - (assq major-mode fume-function-name-regexp-alist) - (not (eq major-mode 'dired-mode)) - ;; Not sure if this is defined in early versions of Emacs. - (fboundp 'skip-syntax-backward)) - (save-excursion - (skip-syntax-backward "w_") - (if (looking-at "\\(\\sw\\|\\s_\\)+") - (let ((function-name (buffer-substring (point) (match-end 0))) - (start (point)) - (end (match-end 0)) - function-pos) - (if fume-funclist - nil - (fume-set-defaults) - (let ((fume-scanning-message nil)) - (fume-rescan-buffer))) - (setq function-pos (cdr-safe (assoc function-name fume-funclist))) - (if function-pos - (progn (ibut:label-set function-name start end) - (hact 'function-in-buffer function-name - function-pos)))))))) - -;;; ======================================================================== -;;; Follows URLs by invoking a browser. -;;; ======================================================================== - -(require 'hsys-w3) - -;;; ======================================================================== -;;; Handles internal references within an annotated bibliography, delimiters=[] -;;; ======================================================================== - -(defib annot-bib () - "Displays annotated bibliography entries referenced internally. -References must be delimited by square brackets, must begin with a word -constituent character, and must not be in buffers whose names begin with a -' ' or '*' character or which do not have an attached file." - (and (not (bolp)) - buffer-file-name - (let ((chr (aref (buffer-name) 0))) - (not (or (= chr ? ) (= chr ?*)))) - ;; Force [PPG-sw-process-id], if defined, to take precedence. - (not (htype:names 'ibtypes 'ppg-sw-process)) - (let* ((ref-and-pos (hbut:label-p t "[" "]" t)) - (ref (car ref-and-pos))) - (and ref (= ?w (char-syntax (aref ref 0))) - (progn (ibut:label-set ref-and-pos) - (hact 'annot-bib ref)))))) - -;;; ======================================================================== -;;; Summarizes an Internet rfc for random access browsing by section. -;;; ======================================================================== - -(defib rfc-toc () - "Summarizes contents of an Internet rfc from anywhere within rfc buffer. -Each line in summary may be selected to jump to section." - (let ((case-fold-search t) - (toc) - (opoint (point))) - (if (and (string-match "rfc" (buffer-name)) - (goto-char (point-min)) - (progn (setq toc (search-forward "Table of Contents" nil t)) - (re-search-forward "^[ \t]*1.0?[ \t]+[^ \t\n]" nil t - (and toc 2)))) - (progn (beginning-of-line) - (ibut:label-set (buffer-name)) - (hact 'rfc-toc (buffer-name) opoint)) - (goto-char opoint) - nil))) - -;;; ======================================================================== -;;; Jumps to C/C++ source line associated with Cscope C analyzer output line. -;;; ======================================================================== - -(defib cscope () - "Jumps to C/C++ source line associated with Cscope C analyzer output line. -Requires pre-loading of the cscope.el Lisp library available from the Emacs -Lisp archives and the commercial cscope program available from UNIX System -Laboratories. Otherwise, does nothing." - (and (boundp 'cscope:bname-prefix) ;; (featurep 'cscope) - (stringp cscope:bname-prefix) - (string-match (regexp-quote cscope:bname-prefix) - (buffer-name)) - (= (match-beginning 0) 0) - (save-excursion - (beginning-of-line) - (looking-at cscope-output-line-regexp)) - (let (start end) - (skip-chars-backward "^\n\^M") - (setq start (point)) - (skip-chars-forward "^\n\^M") - (setq end (point)) - (ibut:label-set (buffer-substring start end) - start end) - (hact 'cscope-interpret-output-line)))) - -;;; ======================================================================== -;;; Makes README table of contents entries jump to associated sections. -;;; ======================================================================== - -(defib text-toc () - "Jumps to the text file section referenced by a table of contents entry at point. -File name must contain README and there must be a `Table of Contents' or -`Contents' label on a line by itself (it may begin with an asterisk), -preceding the table of contents. Each toc entry must begin with some -whitespace followed by one or more asterisk characters. Each file section -name line must start with one or more asterisk characters at the very -beginning of the line." - (let (section) - (if (and (string-match "README" (buffer-name)) - (save-excursion - (beginning-of-line) - (if (looking-at - "[ \t]+\\*+[ \t]+\\(.*[^ \t]\\)[ \t]*$") - (setq section (buffer-substring (match-beginning 1) - (match-end 1))))) - (progn (ibut:label-set section (match-beginning 1) (match-end 1)) - t) - (save-excursion (re-search-backward - "^\\**[ \t]*\\(Table of \\)Contents[ \t]*$" - nil t))) - (hact 'text-toc section)))) - -;;; ======================================================================== -;;; Makes directory summaries into file list menus. -;;; ======================================================================== - -(defib dir-summary () - "Detects filename buttons in files named \"MANIFEST\" or \"DIR\". -Displays selected files. Each file name must be at the beginning of the line -or may be preceded by some semicolons and must be followed by one or more -spaces and then another non-space, non-parenthesis, non-brace character." - (if buffer-file-name - (let ((file (file-name-nondirectory buffer-file-name)) - entry start end) - (if (or (string= file "DIR") (string= file "MANIFEST")) - (save-excursion - (beginning-of-line) - (if (looking-at - "\\(;+[ \t]*\\)?\\([^(){}* \t\n]+\\)[ \t]+[^(){}* \t\n]") - (progn - (setq entry (buffer-substring - (match-beginning 2) (match-end 2)) - start (match-beginning 2) - end (match-end 2)) - (if (file-exists-p entry) - (progn (ibut:label-set entry start end) - (hact 'link-to-file entry)))))))))) - -;;; ======================================================================== -;;; Executes or documents command bindings of brace delimited key sequences. -;;; ======================================================================== - -(require 'hib-kbd) - -;;; ======================================================================== -;;; Makes Internet RFC references retrieve the RFC. -;;; ======================================================================== - -(defib rfc () - "Retrieves and displays an Internet rfc referenced at point. -Requires ange-ftp or efs when needed for remote retrievals. The following -formats are recognized: RFC822, rfc-822, and RFC 822. The 'hpath:rfc' -variable specifies the location from which to retrieve RFCs." - (let ((case-fold-search t) - (rfc-num nil)) - (and (not (memq major-mode '(dired-mode monkey-mode))) - (boundp 'hpath:rfc) - (stringp hpath:rfc) - (save-excursion - (skip-chars-backward "-rRfFcC0-9") - (if (looking-at "rfc[- ]?\\([0-9]+\\)") - (progn - (setq rfc-num - (buffer-substring - (match-beginning 1) (match-end 1))) - (ibut:label-set - (buffer-substring (match-beginning 0) (match-end 0))) - t))) - ;; Ensure ange-ftp is available for retrieving a remote - ;; RFC, if need be. - (if (string-match "^/.+:" hpath:rfc) - ;; This is a remote path. - (hpath:ange-ftp-available-p) - ;; local path - t) - (hact 'link-to-rfc rfc-num)))) - -;;; ======================================================================== -;;; Makes Hyperbole mail addresses output Hyperbole envir info. -;;; ======================================================================== - -(defib hyp-address () - "Turns a Hyperbole e-mail list address into an implicit button which inserts Hyperbole environment information. -Useful when sending mail to a Hyperbole mail list. -See also the documentation for `actypes::hyp-config'." - (if (memq major-mode (list hmail:composer hnews:composer)) - (let ((addr (find-tag-default))) - (cond ((set:member addr (list "hyperbole" "hyperbole@infodock.com")) - (hact 'hyp-config)) - ((set:member addr - (list "hyperbole-request" - "hyperbole-request@infodock.com")) - (hact 'hyp-request)) - )))) - -;;; ======================================================================== -;;; Makes source entries in Hyperbole reports selectable. -;;; ======================================================================== - -(defib hyp-source () - "Turns source location entries in Hyperbole reports into buttons that jump to the associated location." - (save-excursion - (beginning-of-line) - (if (looking-at hbut:source-prefix) - (let ((src (hbut:source))) - (if src - (progn (if (not (stringp src)) (setq src (prin1-to-string src))) - (ibut:label-set src (point) (progn (end-of-line) (point))) - (hact 'hyp-source src))))))) - -;;; ======================================================================== -;;; Shows man page associated with a man apropos entry. -;;; ======================================================================== - -(defib man-apropos () - "Makes man apropos entries display associated man pages when selected." - (save-excursion - (beginning-of-line) - (let ((nm "[^ \t\n!@,][^ \t\n,]*") - topic) - (and (looking-at - (concat - "^\\(\\*[ \t]+[!@]\\)?\\(" nm "[ \t]*,[ \t]*\\)*\\(" nm "\\)[ \t]*" - "\\(([-0-9a-zA-z]+)\\)\\(::\\)?[ \t]+-[ \t]+[^ \t\n]")) - (setq topic - (concat (buffer-substring (match-beginning 3) (match-end 3)) - (buffer-substring (match-beginning 4) (match-end 4)))) - (ibut:label-set topic (match-beginning 3) (match-end 4)) - (hact 'man-show topic))))) - -;;; ======================================================================== -;;; Follows links to Hyperbole outliner cells. -;;; ======================================================================== - -(if hyperb:kotl-p (require 'klink)) - -;;; ======================================================================== -;;; Displays files and directories when double quoted pathname is activated. -;;; ======================================================================== - -(defib pathname () - "Makes a delimited, valid pathname display the path entry. -Also works for delimited and non-delimited ange-ftp and efs pathnames. -Emacs Lisp library files (filenames that end in .el and .elc) are looked up -using the load-path directory list. - -See `hpath:at-p' function documentation for possible delimiters. -See `hpath:suffixes' variable documentation for suffixes that are added to or -removed from pathname when searching for a valid match. -See `hpath:find' function documentation for special file display options." - (let ((path (hpath:at-p))) - (cond (path - (ibut:label-set path) - (hact 'link-to-file path)) - ((and (fboundp 'locate-file) - (setq path (or (hargs:delimited "\"" "\"") - ;; Filenames in Info docs - (hargs:delimited "\`" "\'") - ;; Filenames in TexInfo docs - (hargs:delimited "@file{" "}"))) - (string-match ".\\.el?c\\'" path)) - (ibut:label-set path) - (setq path (locate-file path load-path)) - (if path (hact 'link-to-file path)))))) - - -;;; ======================================================================== -;;; Jumps to source line associated with debugger stack frame or breakpoint -;;; lines. Supports gdb, dbx, and xdb. -;;; ======================================================================== - -(defib debugger-source () - "Jumps to source line associated with debugger stack frame or breakpoint lines. -This works with gdb, dbx, and xdb. Such lines are recognized in any buffer." - (save-excursion - (beginning-of-line) - (cond ((looking-at ".+ \\(at\\|file\\) \\([^ :]+\\):\\([0-9]+\\)\\.?$") - ;; GDB - (let* ((file (buffer-substring (match-beginning 2) - (match-end 2))) - (line-num (buffer-substring (match-beginning 3) - (match-end 3))) - (but-label (concat file ":" line-num))) - (setq line-num (string-to-int line-num)) - (ibut:label-set but-label) - (hact 'link-to-file-line file line-num))) - ((looking-at ".+ (file=[^\"\n]+\"\\([^\"\n]+\\)\", line=\\([0-9]+\\),") - ;; XEmacs assertion failure - (let* ((file (buffer-substring (match-beginning 1) - (match-end 1))) - (line-num (buffer-substring (match-beginning 2) - (match-end 2))) - (but-label (concat file ":" line-num))) - (setq line-num (string-to-int line-num)) - (ibut:label-set but-label) - (hact 'link-to-file-line file line-num))) - ((looking-at ".+ line \\([0-9]+\\) in \"\\([^\"]+\\)\"$") - ;; New DBX - (let* ((file (buffer-substring (match-beginning 2) - (match-end 2))) - (line-num (buffer-substring (match-beginning 1) - (match-end 1))) - (but-label (concat file ":" line-num))) - (setq line-num (string-to-int line-num)) - (ibut:label-set but-label) - (hact 'link-to-file-line file line-num))) - ((or (looking-at ".+ \\[\"\\([^\"]+\\)\":\\([0-9]+\\),") ;; Old DBX - (looking-at ".+ \\[\\([^: ]+\\): \\([0-9]+\\)\\]")) ;; HP-UX xdb - (let* ((file (buffer-substring (match-beginning 1) - (match-end 1))) - (line-num (buffer-substring (match-beginning 2) - (match-end 2))) - (but-label (concat file ":" line-num))) - (setq line-num (string-to-int line-num)) - (ibut:label-set but-label) - (hact 'link-to-file-line file line-num)))))) - -;;; ======================================================================== -;;; Jumps to source line associated with grep or compilation error messages. -;;; With credit to Michael Lipp and Mike Williams for the idea. -;;; ======================================================================== - -(defib grep-msg () - "Jumps to line associated with grep or compilation error msgs. -Messages are recognized in any buffer." - (progn - (if (equal (buffer-name) "*compilation*") - (progn - (require 'compile) - ;; Make sure we have a parsed error-list - (if (eq compilation-error-list t) - (progn (compilation-forget-errors) - (setq compilation-parsing-end 1))) - (if (not compilation-error-list) - (save-excursion - (set-buffer-modified-p nil) - (condition-case () - ;; Emacs V19 incompatibly adds two non-optional arguments - ;; over V18. - (compilation-parse-errors nil nil) - (error (compilation-parse-errors))))))) - ;; Locate and parse grep messages found in any buffer. - (save-excursion - (beginning-of-line) - (if (or - ;; UNIX C compiler and Introl 68HC11 C compiler errors - (looking-at "\\([^ \t\n\^M:]+\\): ?\\([0-9]+\\)[ :]") - ;; BSO/Tasking 68HC08 C compiler errors - (looking-at - "[a-zA-Z 0-9]+: \\([^ \t\n\^M]+\\) line \\([0-9]+\\)[ \t]*:") - ;; UNIX Lint errors - (looking-at "[^:]+: \\([^ \t\n\^M:]+\\): line \\([0-9]+\\):") - ;; SparcWorks C compiler errors (ends with :) - ;; IBM AIX xlc C compiler errors (ends with .) - (looking-at "\"\\([^\"]+\\)\", line \\([0-9]+\\)[:.]") - ;; Introl as11 assembler errors - (looking-at " \\*+ \\([^ \t\n\^M]+\\) - \\([0-9]+\\) ") - ;; perl5: ... at file.c line 10 - (looking-at ".+ at \\([^ \t\n]+\\) line +\\([0-9]+\\)") - ) - (let* ((file (buffer-substring (match-beginning 1) - (match-end 1))) - (line-num (buffer-substring (match-beginning 2) - (match-end 2))) - (but-label (concat file ":" line-num)) - (source-loc (hbut:key-src t))) - (if (stringp source-loc) - (setq file (expand-file-name - file (file-name-directory source-loc)))) - (setq line-num (string-to-int line-num)) - (ibut:label-set but-label) - (hact 'link-to-file-line file line-num)))))) - -;;; ======================================================================== -;;; Jumps to source of Emacs Lisp V19 byte-compiler error messages. -;;; ======================================================================== - -(defib elisp-compiler-msg () - "Jumps to source code for definition associated with byte-compiler error message. -Works when activated anywhere within an error line." - (if (or (equal (buffer-name) "*Compile-Log*") - (equal (buffer-name) "*compilation*") - (save-excursion - (and (re-search-backward "^[^ \t\n\r]" nil t) - (looking-at "While compiling")))) - (let (src buffer-p label) - (and (save-excursion - (re-search-backward - "^While compiling [^\t\n]+ in \\(file\\|buffer\\) \\([^ \n]+\\):$" - nil t)) - (setq buffer-p - (equal (buffer-substring (match-beginning 1) (match-end 1)) - "buffer") - src (buffer-substring (match-beginning 2) (match-end 2))) - (save-excursion - (end-of-line) - (re-search-backward "^While compiling \\([^ \n]+\\)\\(:$\\| \\)" - nil t)) - (progn - (setq label (buffer-substring - (match-beginning 1) (match-end 1))) - (ibut:label-set label (match-beginning 1) (match-end 1)) - ;; Remove prefix generated by actype and ibtype definitions. - (setq label (hypb:replace-match-string "[^:]+::" label "" t)) - (hact 'link-to-regexp-match - (concat "^\(def[a-z \t]+" (regexp-quote label) - "[ \t\n\(]") - 1 src buffer-p)))))) - -;;; ======================================================================== -;;; Jumps to source associated with a line of output from 'patch'. -;;; ======================================================================== - -(defib patch-msg () - "Jumps to source code associated with output from the 'patch' program. -Patch applies diffs to source code." - (if (save-excursion - (beginning-of-line) - (looking-at "Patching \\|Hunk ")) - (let ((opoint (point)) - (file) line) - (beginning-of-line) - (cond ((looking-at "Hunk .+ at \\([0-9]+\\)") - (setq line (buffer-substring (match-beginning 1) - (match-end 1))) - (ibut:label-set line (match-beginning 1) (match-end 1)) - (if (re-search-backward "^Patching file \\(\\S +\\)" nil t) - (setq file (buffer-substring (match-beginning 1) - (match-end 1))))) - ((looking-at "Patching file \\(\\S +\\)") - (setq file (buffer-substring (match-beginning 1) - (match-end 1)) - line "1") - (ibut:label-set file (match-beginning 1) (match-end 1)))) - (goto-char opoint) - (if (null file) - nil - (setq line (string-to-int line)) - (hact 'link-to-file-line file line))))) - -;;; ======================================================================== -;;; Composes mail, in another window, to the e-mail address at point. -;;; ======================================================================== - -(defib mail-address () - "If on an e-mail address in a specific buffer type, mail to that address in another window. -Applies to the rolodex match buffer, any buffer attached to a file in -'rolo-file-list', or any buffer with \"mail\" or \"rolo\" (case-insensitive) -within its name." - (if (or (and (let ((case-fold-search t)) - (string-match "mail\\|rolo" (buffer-name))) - ;; Don't want this to trigger in a mail/news summary buffer. - (not (or (hmail:lister-p) (hnews:lister-p)))) - (if (boundp 'rolo-display-buffer) - (equal (buffer-name) rolo-display-buffer)) - (and buffer-file-name - (boundp 'rolo-file-list) - (set:member (current-buffer) - (mapcar 'get-file-buffer rolo-file-list)))) - (let ((address (mail-address-at-p))) - (if address - (progn - (ibut:label-set address (match-beginning 1) (match-end 1)) - (hact 'mail-other-window nil address)))))) - -(defconst mail-address-regexp - "\\([_a-zA-Z][-_a-zA-Z0-9.!@+%]*@[-_a-zA-Z0-9.!@+%]+\\.[a-zA-Z][-_a-zA-Z][-_a-zA-Z]?\\|[a-zA-Z][-_a-zA-Z0-9.!+%]+@[-_a-zA-Z0-9@]+\\)\\($\\|[^a-zA-Z0-9.!@%]\\)" - "Regexp with group 1 matching an Internet email address.") - -(defun mail-address-at-p () - "Return e-mail address, a string, that point is within or nil." - (save-excursion - (skip-chars-backward "^ \t\n\^M\"\'(){}[];<>|") - (if (looking-at mail-address-regexp) - (buffer-substring (match-beginning 1) (match-end 1))))) - -;;; ======================================================================== -;;; Displays Info nodes when double quoted "(file)node" button is activated. -;;; ======================================================================== - -(defib Info-node () - "Makes \"(file)node\" buttons display the associated Info node." - (let* ((node-ref-and-pos (hbut:label-p t "\"" "\"" t)) - (node-ref (hpath:is-p (car node-ref-and-pos) nil t))) - (and node-ref (string-match "([^\)]+)" node-ref) - (ibut:label-set node-ref-and-pos) - (hact 'link-to-Info-node node-ref)))) - -;;; ======================================================================== -;;; Inserts completion into minibuffer or other window. -;;; ======================================================================== - -(defib completion () - "Inserts completion at point into minibuffer or other window." - (let ((completion (hargs:completion t))) - (and completion - (ibut:label-set completion) - (hact 'completion)))) - - -(run-hooks 'hibtypes:end-load-hook) -(provide 'hibtypes) -
--- a/lisp/hyperbole/hinit.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,122 +0,0 @@ -;;!emacs -;; -;; FILE: hinit.el -;; SUMMARY: Standard initializations for Hyperbole hypertext system. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: hypermedia -;; -;; AUTHOR: Bob Weiner -;; ORG: InfoDock Associates -;; -;; ORIG-DATE: 1-Oct-91 at 02:32:51 -;; LAST-MOD: 17-Feb-97 at 16:03:46 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1991-1997, Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Public variables -;;; ************************************************************************ - -(defvar hyperb:host-domain nil - "<@domain-name> for current host. Set automatically by `hyperb:init'.") - -;;; ************************************************************************ -;;; Other required Elisp libraries -;;; ************************************************************************ - -(require 'hvar) - -(mapcar 'require '(hui-mouse hypb hui hui-mini hbmap hibtypes)) - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -(if (not (fboundp 'br-in-browser)) - ;; Then the OO-Browser is not loaded, so we can never be within the - ;; browser. Define this as a dummy function that always returns nil - ;; until the OO-Browser is ever loaded. - (defun br-in-browser () - "Always returns nil since the OO-Browser is not loaded." - nil)) - -(defun hyperb:init () - "Standard configuration routine for Hyperbole." - (interactive) - (run-hooks 'hyperb:init-hook) - (hyperb:check-dir-user) - (or hyperb:host-domain (setq hyperb:host-domain (hypb:domain-name))) - (hyperb:act-set) - ;; - ;; Save button attribute file whenever same dir file is saved and - ;; `ebut:hattr-save' is non-nil. - ;; - (var:append 'write-file-hooks '(hattr:save)) - ;; - (hyperb:init-menubar)) - -(defun hyperb:init-menubar () - "Add a pulldown menu for Hyperbole, if appropriate." - (and hyperb:window-system - (or hyperb:lemacs-p - (if hyperb:emacs19-p - (require 'lmenu))) - (require 'hui-menu) - ;; XEmacs or Emacs19 under a window system; add Hyperbole menu to - ;; menubar. - (hyperbole-menubar-menu))) - -(defun hyperb:act-set () - "COORDINATION IS NOT YET OPERATIONAL. hui-coord.el IS NOT INCLUDED. -Sets Hyperbole action command to uncoordinated or coordinated operation. -Coordinated is used when `hcoord:hosts' is a non-nil list. -See \"hui-coord.el\"." - (interactive) - (fset 'hyperb:act (if (and (boundp 'hcoord:hosts) hcoord:hosts) - 'hcoord:act 'hbut:act))) - - -;;; ************************************************************************ -;;; Private functions -;;; ************************************************************************ - -(defun hyperb:check-dir-user () - "Ensures `hbmap:dir-user' exists and is writable or signals an error." - (if (or (null hbmap:dir-user) (not (stringp hbmap:dir-user)) - (and (setq hbmap:dir-user (file-name-as-directory - (expand-file-name hbmap:dir-user))) - (file-directory-p hbmap:dir-user) - (not (file-writable-p (directory-file-name hbmap:dir-user))))) - (error - "(hyperb:init): `hbmap:dir-user' must be a writable directory name.")) - (let ((hbmap:dir-user (directory-file-name hbmap:dir-user))) - (or (file-directory-p hbmap:dir-user) ;; Exists and is writable. - (let* ((parent-dir (file-name-directory - (directory-file-name hbmap:dir-user)))) - (cond - ((not (file-directory-p parent-dir)) - (error - "(hyperb:init): `hbmap:dir-user' parent dir does not exist.")) - ((not (file-writable-p parent-dir)) - (error - "(hyperb:init): `hbmap:dir-user' parent directory not writable.")) - ((or (if (fboundp 'make-directory) - (progn (make-directory hbmap:dir-user) t)) - (hypb:call-process-p "mkdir" nil nil hbmap:dir-user)) - (or (file-writable-p hbmap:dir-user) - (or (progn (hypb:chmod '+ 700 hbmap:dir-user) - (file-writable-p hbmap:dir-user)) - (error "(hyperb:init): Can't write to 'hbmap:dir-user'.") - ))) - (t (error "(hyperb:init): `hbmap:dir-user' create failed.")))))) - t) - -(provide 'hinit) -
--- a/lisp/hyperbole/hlvar.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,144 +0,0 @@ -;;!emacs -;; -;; FILE: hlvar.el -;; SUMMARY: Permits use of Hyperbole variables in local variable lists. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: extensions, hypermedia -;; -;; AUTHOR: Bob Weiner -;; ORG: Brown U. -;; -;; ORIG-DATE: 4-Nov-91 at 00:26:06 -;; LAST-MOD: 21-Jun-95 at 00:50:14 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1985-1995, Free Software Foundation, Inc. -;; -;; This file is not part of GNU Emacs but the code here is a slight -;; variant of that found in "files.el" from GNU Emacs. -;; -;; DESCRIPTION: -;; -;; Hyperbole uses the colon character extensively in its variable names. -;; The standard GNU Emacs syntax for local variable setting does not allow -;; the use of this character, even though it is a valid symbol name -;; character. The code here is slightly modified to support local setting of -;; variables with colons in their names. -;; -;; Where the standard code allows: var:val -; This code requires one use: var: val (where var may include colons) -;; -;; So functionality is gained and none is lost, but a slight incompatibility -;; in protocol is introduced. -;; -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -(defun hack-local-variables (&optional force) - "Parse, and bind or evaluate as appropriate, any local variables -for current buffer." - (if (fboundp 'hack-local-variables-prop-line) - (hack-local-variables-prop-line)) - ;; Look for "Local variables:" line in last page. - (save-excursion - (goto-char (point-max)) - (search-backward "\n\^L" (max (- (point-max) 3000) (point-min)) 'move) - (let (local-start) - (if (let ((case-fold-search t) - (ignore nil)) - (and (search-forward "Local Variables:" nil t) - (setq local-start (match-beginning 0)) - (or (and (not (string-match "^19\\." emacs-version)) - (not inhibit-local-variables)) - force - (if (string-match "^19\\." emacs-version) - (cond ((eq enable-local-variables t) t) - ((eq enable-local-variables nil) - (setq ignore t)))) - (if ignore - nil - (save-window-excursion - (switch-to-buffer (current-buffer)) - (save-excursion - (beginning-of-line) - (set-window-start (selected-window) (point))) - (y-or-n-p - (format "Set local variables as specified at end of %s? " - (file-name-nondirectory - buffer-file-name)))))))) - (let ((continue t) - prefix prefixlen suffix beg - (enable-local-eval - (if (boundp 'enable-local-eval) enable-local-eval))) - ;; The prefix is what comes before "local variables:" in its line. - ;; The suffix is what comes after "local variables:" in its line. - (skip-chars-forward " \t") - (or (eolp) - (setq suffix (buffer-substring (point) - (progn (end-of-line) (point))))) - (goto-char local-start) - (or (bolp) - (setq prefix - (buffer-substring (point) - (progn (beginning-of-line) (point))))) - - (if prefix (setq prefixlen (length prefix) - prefix (regexp-quote prefix))) - (if suffix (setq suffix (concat (regexp-quote suffix) "$"))) - (while continue - ;; Look at next local variable spec. - (if selective-display (re-search-forward "[\n\C-m]") - (forward-line 1)) - ;; Skip the prefix, if any. - (if prefix - (if (looking-at prefix) - (forward-char prefixlen) - (error "Local variables entry is missing the prefix"))) - ;; Find the variable name; strip whitespace. - (skip-chars-forward " \t") - (setq beg (point)) - ;; - ;; Bob Weiner - changed here to allow colons in var names. - ;; - (skip-chars-forward "^ \t\n") - (skip-chars-backward ":") - (or (looking-at "[ \t]*:") - (error "(hack-local-variables): Missing colon in local variables entry")) - ;; - ;; Bob Weiner - end changes. - ;; - (let* ((str (buffer-substring beg (point))) - (var (read str)) - val) - ;; Setting variable named "end" means end of list. - (if (string-equal (downcase str) "end") - (setq continue nil) - ;; Otherwise read the variable value. - (skip-chars-forward "^:") - (forward-char 1) - (setq val (read (current-buffer))) - (skip-chars-backward "\n") - (skip-chars-forward " \t") - (or (if suffix (looking-at suffix) (eolp)) - (error "Local variables entry is terminated incorrectly")) - ;; Set the variable. "Variables" mode and eval are funny. - (if (fboundp 'hack-one-local-variable) - (hack-one-local-variable var val) - (cond ((eq var 'mode) - (funcall (intern (concat (downcase (symbol-name val)) - "-mode")))) - ((eq var 'eval) - (if (string= (user-login-name) "root") - (message - "Ignoring `eval:' in file's local variables") - (eval val))) - (t (make-local-variable var) - (set var val)))))))))) - (run-hooks 'hack-local-variables-hook))) - -(provide 'hlvar)
--- a/lisp/hyperbole/hmail.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,289 +0,0 @@ -;;!emacs -;; -;; FILE: hmail.el -;; SUMMARY: Support for Hyperbole buttons embedded in e-mail messages. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: hypermedia, mail -;; -;; AUTHOR: Bob Weiner -;; ORG: Brown U. -;; -;; ORIG-DATE: 9-Oct-91 at 18:38:05 -;; LAST-MOD: 6-Dec-96 at 12:35:29 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1991-1995, Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; -;; The 'hmail' class provides an abstract interface for connecting -;; GNU Emacs-based mail readers and composers to Hyperbole. Its -;; public variables together with supporting classes determine the -;; mail tools that Hyperbole will support. -;; -;; The 'rmail' and 'lmail' classes provide a set of feature names -;; that Hyperbole packages can call to interface to a user's selected -;; mail reader. Eventually, a full abstract calling interface may be -;; developed. The public features (the ones above the line of dashes) -;; must be redefined for any mail reader. The private features are -;; used only by a particular mail reader. -;; -;; The 'smail' class is similar; it connects a mail composer for use -;; with Hyperbole. -;; -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Public variables -;;; ************************************************************************ - -(defvar hnews:composer 'news-reply-mode - "Major mode for composing USENET news to be sent with Hyperbole buttons.") -(defvar hnews:lister 'gnus-summary-mode - "Major mode for listing USENET news header summaries with Hyperbole buttons.") -(defvar hnews:reader 'gnus-article-mode - "Major mode for reading USENET news with Hyperbole buttons.") - -(defvar hmail:init-function nil - "*Function (a symbol) to run to initialize Hyperbole support for a mail reader/composer. -Valid values are: nil, Rmail-init, Vm-init, Mh-init, or Pm-init.") - -(defvar hmail:composer 'mail-mode - "Major mode for composing mail to be sent with Hyperbole buttons.") -(defvar hmail:lister nil - "Major mode for listing mail header summaries with Hyperbole buttons.") -(defvar hmail:modifier nil - "Major mode for editing received mail with Hyperbole buttons.") -(defvar hmail:reader nil - "Major mode for reading mail with Hyperbole buttons.") - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -;;; ======================================================================== -;;; hmail class - abstract -;;; ======================================================================== - -(defun hmail:hbdata-start (&optional msg-start msg-end) - "Returns point immediately before any Hyperbole button data in current msg. -Returns message end point when no button data is found. -Has side-effect of widening buffer. -Message's displayable part begins at optional MSG-START and ends at or before -MSG-END." - (widen) - (or msg-end (setq msg-end (point-max))) - (save-excursion - (goto-char msg-end) - (if (search-backward hmail:hbdata-sep msg-start t) (1- (point)) msg-end))) - -(defun hmail:hbdata-to-p () - "Moves point to Hyperbole but data start in an e-mail msg. -Returns t if button data is found." - (and (cond ((memq major-mode (list hmail:reader hmail:modifier)) - (rmail:msg-narrow) t) - ((or (hmail:lister-p) (hnews:lister-p)) t) - ((memq major-mode (list hmail:composer hnews:reader - hnews:composer)) - (widen) t)) - (progn - (goto-char (point-max)) - (if (search-backward hmail:hbdata-sep nil t) - (progn (forward-line 1) t))))) - -(defun hmail:browser-p () - "Returns t iff current major mode helps browse received e-mail messages." - (memq major-mode (list hmail:reader hmail:lister))) - -(defun hmail:buffer (&optional buf invisible-flag) - "Start composing mail with the contents of optional BUF as the message body. -Invisible text is expanded and included in the mail only if INVISIBLE-FLAG is -non-nil. BUF defaults to the current buffer and may be a buffer or buffer -name." - (interactive (list (current-buffer) (y-or-n-p "Include invisible text? "))) - (or buf (setq buf (current-buffer))) - (if (stringp buf) (setq buf (get-buffer buf))) - (set-buffer buf) - (hmail:region (point-min) (point-max) buf invisible-flag)) - -;;;###autoload -(defun hmail:compose (address expr &optional subject help) - "Compose mail with ADDRESS and evaluation of EXPR. -Optional SUBJECT and HELP message may also be given." - (interactive "sDeliver e-mail to: \nSubject: ") - (require 'hactypes) ;; Needed in case EXPR calls 'hact. - (if (or (stringp help) (stringp subject)) - nil - (setq subject "Be explicit here. Make a statement or ask a question.")) - (hmail:invoke address nil subject) - (eval expr) - (if (re-search-backward "^Subject: " nil t) - (goto-char (match-end 0))) - (message (if (stringp help) - help - "Replace subject, compose message, and then mail."))) - -(defun hmail:composing-dir (key-src) - "If button KEY-SRC is a mail/news composure buffer, returns composure directory, else nil." - (save-excursion - (and (bufferp key-src) - (progn (set-buffer key-src) - (or (eq major-mode hmail:composer) - (eq major-mode hnews:composer))) - default-directory))) - -(defun hmail:editor-p () - "Returns t iff current major mode edits Hyperbole e-mail/news messages." - (memq major-mode (list hmail:composer hnews:composer hmail:modifier))) - -(defun hmail:init (class-prefix func-suffix-list) - "Sets up CLASS-PREFIX functions with aliases for FUNC-SUFFIX-LIST. -'hmail:reader' should be set appropriately before this is called." - (if (null hmail:reader) - nil - (let* ((reader-name (symbol-name hmail:reader)) - (reader-prefix (capitalize - (substring reader-name - 0 (string-match "-" reader-name)))) - hmail-func) - (mapcar (function - (lambda (func-suffix) - (setq hmail-func (hypb:replace-match-string - "Summ-" func-suffix "" t)) - (fset (intern (concat class-prefix hmail-func)) - (intern (concat reader-prefix "-" func-suffix))))) - func-suffix-list)))) - -(defun hmail:invoke (&optional address cc subject) - "Invoke user preferred mail composer: vm-mail, mh-send or mail. -Optional arguments are ADDRESS, CC list and SUBJECT of mail." - (or address (setq address "")) - (or cc (setq cc "")) - (or subject (setq subject "")) - (cond ((and (featurep 'vm) (fboundp 'vm-mail)) - (vm-mail) - (insert address) - (cond ((re-search-forward "^CC: " nil t) - (end-of-line) - (insert cc)) - ((not (equal cc "")) - (forward-line 1) - (insert "CC: " cc))) - (if (re-search-forward "^Subject: " nil t) - (progn (end-of-line) - (save-excursion - (insert subject))))) - ((and (featurep 'mh-e) (fboundp 'mh-send)) - (mh-send address cc subject)) - (t - ;; Next 3 lines prevent blank lines between fields due to - ;; fill-region-as-paragraph within mail-setup. - (if (equal address "") (setq address nil)) - (if (equal cc "") (setq cc nil)) - (if (equal subject "") (setq subject nil)) - (mail nil address subject nil cc)))) - -(defun hmail:lister-p () - "Returns t iff current major mode is a Hyperbole e-mail lister mode." - (eq major-mode hmail:lister)) - -(defun hnews:lister-p () - "Returns t iff current major mode is a Hyperbole news summary lister mode." - (eq major-mode hnews:lister)) - -(defun hmail:mode-is-p () - "Returns current major mode if a Hyperbole e-mail or news mode, else nil." - (car (memq major-mode - (list hmail:reader hmail:composer hmail:lister hmail:modifier - hnews:reader hnews:composer hnews:lister) - ))) - -(defun hmail:msg-narrow (&optional msg-start msg-end) - "Narrows buffer to displayable part of current message. -Its displayable part begins at optional MSG-START and ends at or before -MSG-END." - (if (hmail:reader-p) (rmail:msg-widen)) - (setq msg-start (or msg-start (point-min)) - msg-end (or msg-end (point-max))) - (narrow-to-region msg-start (hmail:hbdata-start msg-start msg-end))) - -(defun hmail:reader-p () - "Returns t iff current major mode shows received Hyperbole e-mail messages." - (memq major-mode (list hmail:reader hmail:modifier))) - -(defun hmail:region (start end &optional buf invisible-flag) - "Start composing mail with region between START and END included in message. -Invisible text is expanded and included in the mail only if INVISIBLE-FLAG is -non-nil. Optional BUF contains the region and defaults to the current -buffer. It may be a buffer or buffer name." - (interactive (list (region-beginning) (region-end) (current-buffer) - (y-or-n-p "Include invisible text? "))) - (or buf (setq buf (current-buffer))) - (if (stringp buf) (setq buf (get-buffer buf))) - (let (mail-buf) - (hmail:invoke) - (setq mail-buf (current-buffer)) - (save-excursion - (if (search-forward mail-header-separator nil t) - ;; Within header, so move to body - (goto-char (point-max))) - (set-buffer buf) - (hypb:insert-region mail-buf start end invisible-flag)))) - -;;; ======================================================================== -;;; rmail class - mail reader interface - abstract -;;; ======================================================================== - -(defun rmail:init () - "Initializes Hyperbole abstract mail interface for a particular mail reader. -'hmail:reader' should be set appropriately before this is called." - (hmail:init "rmail:" '("msg-hdrs-full" "msg-narrow" "msg-num" - "msg-prev" "msg-next" - "msg-to-p" ;; 2 args: (mail-msg-id mail-file) - "msg-widen" "to")) - (hmail:init "lmail:" '("Summ-delete" "Summ-expunge" "Summ-goto" "Summ-to" - "Summ-undelete-all"))) - -(defvar rmail:msg-hdr-prefix "\\(^Date: \\|\n\nFrom [^ \n]+ \\)" - "String header preceding an e-mail received message-id.") - -(defun rmail:msg-id-get () - "Returns current msg id for an 'hmail:reader' buffer as a string, else nil. -Signals error when current mail reader is not supported." - (let* ((reader (symbol-name hmail:reader)) - ;; (toggled) - ) - (or (fboundp 'rmail:msg-hdrs-full) - (error "(rmail:msg-id-get): Invalid mail reader: %s" reader)) - (save-excursion - (unwind-protect - (progn - ;; (setq toggled (rmail:msg-hdrs-full nil)) - (goto-char (point-min)) - (if (re-search-forward (concat rmail:msg-hdr-prefix - "\\(.+\\)")) - ;; Found matching msg - (buffer-substring (match-beginning 2) (match-end 2)))) - ;; (rmail:msg-hdrs-full toggled) - () - )))) - -;;; ------------------------------------------------------------------------ -;;; Each mail reader-specific Hyperbole support module must also define -;;; the following functions, commonly aliased to existing mail reader -;;; functions within the "-init" function of the Hyperbole module. -;;; See "hrmail.el" for examples. -;;; -;;; rmail:get-new, rmail:msg-forward, rmail:summ-msg-to, rmail:summ-new - -;;; ************************************************************************ -;;; Private variables -;;; ************************************************************************ - -(defvar hmail:hbdata-sep "\^Lbd" - "Text separating e-mail msg from any trailing Hyperbole button data.") - -(provide 'hmail)
--- a/lisp/hyperbole/hmh.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,177 +0,0 @@ -;;!emacs -;; -;; FILE: hmh.el -;; SUMMARY: Support for Hyperbole buttons in mail reader: Mh. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: hypermedia, mail -;; -;; AUTHOR: Bob Weiner -;; ORG: InfoDock Associates -;; -;; ORIG-DATE: 21-May-91 at 17:06:36 -;; LAST-MOD: 31-Oct-96 at 22:34:01 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1991-1996, Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; -;; Automatically configured for use in "hsite.el". -;; If hsite loading fails prior to initializing Hyperbole Mh support, -;; -;; {M-x Mh-init RET} -;; -;; will do it. -;; -;; -;; Have not yet overloaded 'mh-yank-cur-msg' to yank and hide -;; button data from mail reader buffer. -;; Have not yet overloaded 'mh-insert-letter' to highlight buttons -;; and to merge its button data. -;; -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Other required Elisp libraries -;;; ************************************************************************ -(require 'hmail) -(load "hsmail") -(require 'mh-e) - -;;; ************************************************************************ -;;; Public variables -;;; ************************************************************************ - - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -(defun Mh-init () - "Initializes Hyperbole support for Mh mail reading." - (interactive) - (setq hmail:composer 'mh-letter-mode - hmail:lister 'mh-folder-mode - hmail:modifier 'mh-letter-mode - hmail:reader 'mh-show-mode) - (var:append 'mh-show-hook '(hmail:msg-narrow Mh-hbut-highlight)) - ;; - ;; - ;; Setup public abstract interface to Hyperbole defined mail - ;; reader-specific functions used in "hmail.el". - ;; - (rmail:init) - ;; - ;; Setup private abstract interface to mail reader-specific functions - ;; used in "hmail.el". - ;; - (fset 'rmail:get-new 'mh-inc-folder) - (fset 'rmail:msg-forward 'mh-redistribute) - (fset 'rmail:summ-msg-to 'mh-goto-msg) - (fset 'rmail:summ-new 'mh-rescan-folder) - (if (interactive-p) - (message "Hyperbole MH mail reader support initialized.")) - ) - -(defun Mh-hbut-highlight () - "Highlight any Hyperbole buttons in buffer for which display support exists." - (if (fboundp 'hproperty:but-create) (hproperty:but-create))) - -(defun Mh-msg-hdrs-full (toggled) - "If TOGGLED is non-nil, toggle full/hidden headers, else show full headers. -For now, a no-op." - ) - -(defun Mh-msg-narrow () - "Narrows mail reader buffer to current message. -This includes Hyperbole button data." - (Mh-msg-widen)) - -(defun Mh-msg-next () (mh-next-undeleted-msg 1)) - -(defun Mh-msg-num () - "Returns number of mail message that point is within." - (interactive) - (mh-get-msg-num nil)) - -(defun Mh-msg-prev () (mh-previous-undeleted-msg 1)) - -(defun Mh-msg-to-p (mail-msg-id mail-file) - "Sets current buffer to start of msg with MAIL-MSG-ID in MAIL-FILE. -Returns t if successful, else nil." - (if (not (file-readable-p mail-file)) - nil - (find-file mail-file) - (hmail:msg-narrow) - (goto-char 1) - t)) - -(defun Mh-msg-widen () - "Widens buffer to full current message including Hyperbole button data." - (Mh-to) (widen)) - -(defun Mh-to () - "Sets current buffer to a mail reader buffer." - (and (eq major-mode 'Mh-folder-mode) - (set-buffer (Mh-get-buffer Mh-show-buffer)))) - -(defun Mh-Summ-delete () (mh-delete-msg (mh-get-msg-num t))) - -(fset 'Mh-Summ-expunge 'mh-execute-commands) - -(defun Mh-Summ-goto () - (let ((msg-num (mh-get-msg-num nil))) - (mh-goto-msg msg-num nil t) - (mh-show msg-num))) - -(defun Mh-Summ-to () - "Sets current buffer to a mail listing buffer." - (let ((summ-buf)) - (save-excursion - (mapcar (function - (lambda (window) - (if summ-buf - nil - (set-buffer (window-buffer window)) - (if (eq major-mode 'Mh-folder-mode) - (setq summ-buf (current-buffer)))))) - (hypb:window-list 'no-mini))) - (if summ-buf (set-buffer summ-buf)))) - -(defun Mh-Summ-undelete-all () - (message - "(Mh-Summ-undelete-all: I don't think mh-e has an undelete operator.")) - -;;; ************************************************************************ -;;; Private functions -;;; ************************************************************************ -;;; -;;; Overlay version of this function from mh-e.el to run mh-show-hook at end. -;;; This hook may already be run, depending on the version of mh-e you are -;;; running, but running it twice shouldn't do any harm. Comment this out if -;;; you know that your mh-e.el already runs the hook. -(hypb:function-overload 'mh-display-msg nil - '(run-hooks 'mh-show-hook)) - -;;; -;;; Overlay version of 'mh-regenerate-headers' to highlight Hyperbole -;;; buttons when possible. -;;; -(hypb:function-overload 'mh-regenerate-headers nil - '(if (fboundp 'hproperty:but-create) - (hproperty:but-create))) - -;;; -;;; Set 'mh-send-letter' hook to widen to include button data before sending. -;;; -(var:append 'mh-before-send-letter-hook '(widen)) - -;;; ************************************************************************ -;;; Private variables -;;; ************************************************************************ - -(provide 'hmh) -
--- a/lisp/hyperbole/hmoccur.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,211 +0,0 @@ -;;!emacs -;; -;; FILE: hmoccur.el -;; SUMMARY: Multi-buffer or multi-file regexp occurrence location. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: hypermedia, matching -;; -;; AUTHOR: Markus Freericks <mfx@cs.tu-berlin.de> / Bob Weiner -;; ORG: Technical University of Berlin / InfoDock Associates -;; -;; ORIG-DATE: 1-Aug-91 -;; LAST-MOD: 31-Oct-96 at 22:35:01 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1991, Markus Freericks -;; Copyright (C) 1991-1996, Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; -;; Modified by Bob Weiner to allow selection of a set of files within a -;; single directory to search. By default, {M-x moccur RET} searches -;; current buffers with files attached. -;; -;; Date: 1 Aug 91 15:47:27 GMT -;; From: mfx@cs.tu-berlin.de (Markus Freericks) -;; Subject: moccur - multibuffer occurences -;; -;; While editing some dozen or so files, i had the dire need for -;; something like 'occur' that can cope with multiple buffers. This has -;; probably been done before; but still, here is my try at it. It seems -;; to be very useful. -;; -;; How to use it: simple say -;; M-x moccur <regexp> -;; moccur then searches through *all buffers* currently existing that are -;; bound to files and displays the occurences in a buffer that runs in -;; Moccur-mode. Change to that buffer, scroll around, and say C-c C-c -;; to jump to the occurrence. Quite simple. -;; -;; Incompatibilites to Occur mode: -;; a) it browses through *all* buffers that have a file name -;; associated with them; those may or may not include the current -;; buffer. Especially, while standard occur works -;; on 'all lines following point', Moccur does not. -;; b) there is no support for the 'NLINE' argument. -;; -;; Usage: -;; moccur <regexp> shows all occurences of <regexp> in all buffers -;; currently existing that refer to files. -;; the occurences are displayed in a buffer running in Moccur mode; -;; C-c C-c gets you to the occurence -;; -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Public variables -;;; ************************************************************************ - -(defconst moccur-source-prefix "@loc> " - "Prefix for lines indicating source of matches.") - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -(defun moccur (regexp &optional file-regexp no-fold-search) - "Show all lines of all buffers containing a match for REGEXP. -With optional FILE-REGEXP, a pattern matching to files in a single -directory, search matching files rather than current buffers. -The lines are shown in a buffer named *Moccur* which serves as a menu to -find any of the occurrences in this buffer. -\\[describe-mode] in that buffer explains how." - (interactive "sRegexp to find occurrences of: \nsFiles to search (default current file buffers): ") - (if (equal file-regexp "") (setq file-regexp nil)) - (let* ((buffers (if file-regexp (directory-files - (expand-file-name - (or (file-name-directory - file-regexp) ".")) - 'full (file-name-nondirectory file-regexp)) - (buffer-list))) - (occbuf (get-buffer-create "*Moccur*")) - (matches 0) - (firstmatch t)) - (set-buffer occbuf) - (setq buffer-read-only nil) - (widen) - (erase-buffer) - (insert "Lines matching '" regexp "':\n\n") - (let ((currbuf) (currfile) (kill-buf)) - (while buffers - (setq currbuf (car buffers) - currfile (if (stringp currbuf) currbuf) - kill-buf (and currfile (not (get-file-buffer currfile))) - buffers (cdr buffers)) - (if currfile - (setq currbuf (find-file-noselect currfile)) - (setq currfile (buffer-file-name currbuf))) - (if (or (not currfile) (not currbuf)) - nil - (set-buffer currbuf) - (let ((case-fold-search (not no-fold-search))) - (save-excursion - (goto-char (point-min)) - (setq firstmatch t) - (while (re-search-forward regexp nil t) - (setq matches (+ matches 1)) - (let* ((linenum (count-lines (point-min)(point))) - (tag (format "\n%4d:" linenum))) - (set-buffer occbuf) - (if firstmatch - (progn - (insert moccur-source-prefix currfile "\n") - (setq firstmatch nil))) - (insert tag) - (set-buffer currbuf) - (forward-word -1) ;; needed if match goes to eoline - (beginning-of-line) - (let ((beg (point))) - (end-of-line) - (append-to-buffer occbuf beg (point))) - (forward-line 1))))) - (save-excursion - (set-buffer occbuf) - (if (not firstmatch) (insert "\n\n")) - (if kill-buf (kill-buffer currbuf)))))) - (if (> matches 0) - (progn - (set-buffer occbuf) - (moccur-mode) - (if (fboundp 'outline-minor-mode) - (and (progn (goto-char 1) - (search-forward "\C-m" nil t)) - (outline-minor-mode 1))) - (goto-char (point-min)) - (pop-to-buffer occbuf) - (message "%d matches." matches) - t) - (message "No matches.") - nil))) - -(defun moccur-to () - "Go to the line where this occurrence was found." - (interactive) - (if (not (eq major-mode 'moccur-mode)) - (error "'moccur-to' must be called within a moccur buffer.") - (let ((beg nil) - (line nil) - (lineno nil) - (dstbuf nil)) - (save-excursion - (beginning-of-line) - (setq beg (point)) - (end-of-line) - (setq line (buffer-substring beg (point))) - (if (string-match "^[ ]*[0-9]+:" line) - (progn - (setq lineno (string-to-int (substring - line 0 (match-end 0)))) - (if (re-search-backward - (concat "^" moccur-source-prefix - "\"?\\([^\" \n]+\\)\"?") nil t) - (progn - (setq line (buffer-substring - (match-beginning 1) (match-end 1)) - dstbuf (find-file-noselect line)) - (if (not dstbuf) - (message - "moccur-to: file '%s' is not readable" line))) - (error "No moccur header line for file."))) - (error "Not an moccur occurrence line."))) - (if (and lineno dstbuf) - (progn - (message "Selection <%s> line %d." line lineno) - (pop-to-buffer dstbuf) - (goto-line lineno)))))) - -(fset 'moccur-mode-goto-occurrence 'moccur-to) - - -;;; ************************************************************************ -;;; Private functions -;;; ************************************************************************ - -(defun moccur-mode () - "Major mode for output from \\[moccur]. -Move point to one of the occurrences in this buffer, -then use \\[moccur-to] to go to the same occurrence -in the buffer that the occurrenc was found in. -\\{occur-mode-map}" - (kill-all-local-variables) - (use-local-map moccur-mode-map) - (setq major-mode 'moccur-mode) - (setq mode-name "Moccur")) - -;;; ************************************************************************ -;;; Private variables -;;; ************************************************************************ - -(defvar moccur-mode-map ()) -(if moccur-mode-map - () - (setq moccur-mode-map (make-sparse-keymap)) - (define-key moccur-mode-map "\C-c\C-c" 'moccur-to) - (define-key moccur-mode-map " " 'moccur-to) - (define-key moccur-mode-map "\C-m" 'moccur-to) -) - -(provide 'hmoccur)
--- a/lisp/hyperbole/hmous-info.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,216 +0,0 @@ -;;!emacs -;; -;; FILE: hmous-info.el -;; SUMMARY: Walks through Info networks using one key. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: docs, help, hypermedia, mouse -;; -;; AUTHOR: Bob Weiner -;; ORIG-DATE: 04-Apr-89 -;; LAST-MOD: 1-Nov-95 at 20:33:46 by Bob Weiner -;; -;; This file is for use with Hyperbole. -;; -;; Copyright (C) 1989, 1990, 1991 Free Software Foundation, Inc. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; -;; DESCRIPTION: -;; -;; This code is machine independent. -;; -;; To install: See hui-mouse.el -;; -;; DESCRIP-END. - -;;;###autoload -(defun smart-info () - "Walks through Info documentation networks using one key or mouse key. - -If key is pressed within: - (1) the first line of an Info Menu Entry or Cross Reference, the desired node - is found; - (2) the Up, Next, or Previous entries of a Node Header (first line), - the desired node is found; - (3) the File entry of a Node Header (first line), - the 'Top' node within that file is found; - (4) at the end of the current node, the Next node is found (this will - descend subtrees if the function 'Info-global-next' is bound); - (5) anywhere else (e.g. at the end of a line), the current node entry is - scrolled up one windowful. - -Returns t if key is pressed within an Info Node Header, Cross Reference, -or a Menu; otherwise returns nil." - - (interactive) - (cond - ;; - ;; If at end of node, go to next node - ;; - ((last-line-p) - (if (fboundp 'Info-global-next) (Info-global-next) - (Info-next))) - ((Info-handle-in-node-hdr)) - ((Info-handle-in-note)) - ((Info-handle-in-menu)) - ((pos-visible-in-window-p (point-max)) - (if (fboundp 'Info-global-next) (Info-global-next) - (Info-next))) - ;; - ;; If nothing else scroll forward a windowful. - ;; - ((smart-scroll-up)))) - -;;;###autoload -(defun smart-info-assist () - "Walks through Info documentation networks using one assist-key or mouse assist-key. - -If assist-key is pressed within: - (1) the first line of an Info Menu Entry or Cross Reference, the desired node - is found; - (2) the Up, Next, or Previous entries of a Node Header (first line), - the last node in the history list is found; - (3) the File entry of a Node Header (first line), - the 'DIR' root-level node is found; - (4) at the end of the current node, the Previous node is found (this will - return from subtrees if the function 'Info-global-prev is bound); - (5) anywhere else (e.g. at the end of a line), the current node entry is - scrolled down one windowful. - -Returns t if assist-key is pressed within an Info Node Header, Cross Reference, -or a Menu; otherwise returns nil." - - (interactive) - (cond - ;; - ;; If at end or beginning of node, go to previous node - ;; - ((last-line-p) - (if (fboundp 'Info-global-prev) (Info-global-prev) - (Info-prev))) - ((Info-handle-in-node-hdr-assist)) - ((Info-handle-in-note)) - ((Info-handle-in-menu)) - ((pos-visible-in-window-p (point-min)) - (if (fboundp 'Info-global-prev) (Info-global-prev) - (Info-prev))) - ;; - ;; If anywhere else, scroll backward a windowful. - ;; - ((smart-scroll-down)))) - -(defun Info-handle-in-node-hdr () - "If within an Info node header, move to <FILE>Top, <Up>, <Previous>, or -<Next> node, depending on which label point is on, and return t. -Otherwise, return nil." - ;; - ;; Test if on 1st line of node, i.e. node header - ;; - (if (not (first-line-p)) - nil - (let ((nodename "Top") (filep nil)) - (save-excursion - (if (and - (re-search-forward "[:, \t\n]" nil t) - (re-search-backward - "\\(File\\|Node\\|Up\\|Prev\\|Previous\\|Next\\):[ \t]" nil t)) - (progn (setq filep (string-equal - "file" - (downcase (buffer-substring - (match-beginning 1) - (match-end 1))))) - (if (re-search-forward (concat ":[ \n]\\([^,\t\n" - (if filep " ") - "]*\\)") nil t) - (setq nodename (buffer-substring - (match-beginning 1) - (match-end 1))))) - (error "Node header not found."))) - (setq nodename - (cond ((= (aref nodename 0) ?\() nodename) - (filep (concat "(" nodename ")" "Top")) - (buffer-file-name (concat "(" buffer-file-name ")" nodename)) - (t nodename))) - (if hyperb:lemacs-p - (Info-goto-node nodename nil t) - (Info-goto-node nodename)) - t))) - -(defun Info-handle-in-node-hdr-assist () - "If within an Info node header when the 'smart-info-assist' command is -executed, when within the <FILE> header go to the DIR top-level node. When -within any other header (<Up>, <Previous>, or <Next>) go to last node from -history list. Return t if in Info node header. Otherwise return nil." - ;; - ;; Test if on 1st line of node, i.e. node header - ;; - (if (not (first-line-p)) - nil - (save-excursion - (if (and - (re-search-forward "[:, \t\n]" nil t) - (re-search-backward - "\\(File\\|Node\\|Up\\|Prev\\|Previous\\|Next\\):[ \t]" nil t) ) - ;; If in <FILE> hdr - (progn (if (string-equal - "file" - (downcase (buffer-substring - (match-beginning 1) - (match-end 1)))) - (Info-directory) - (Info-last)) - t) - (error "Node header not found.") - nil)))) - -;;;###autoload -(defun Info-handle-in-note () - "Follows an Info cross-reference. -If point is within the first line of an Info note (cross-reference), follows -cross-reference and returns t; otherwise returns nil." - (let ((note-name) (opoint (point))) - (save-excursion - (skip-chars-forward "^:") - (if (and (re-search-backward - "\*\\(Ref\\|Note\\|See\\)\\([ \t\n]+\\|$\\)" nil t) - (looking-at "\*\\(Ref\\|Note\\|See\\)[ \t\n]+\\([^:]*\\):") - (<= (match-beginning 0) opoint) - (> (match-end 0) opoint)) - ;; Remove newline and extra spaces from 'note-name' - (setq note-name (hypb:replace-match-string - "[ \n\t]+" - (buffer-substring - (match-beginning 2) (match-end 2)) - " " t)))) - (if note-name - (progn (Info-follow-reference note-name) t)))) - -(defun Info-handle-in-menu () - "Displays node referred to by an Info Menu Entry. -If point is within an Info menu entry, goes to node referenced by -entry and returns t; otherwise returns nil." - ;; - ;; Test if there is a menu in this node - ;; - (let ((in-menu nil) (curr-point (point))) - (save-excursion - (goto-char (point-min)) - (setq in-menu - (and (search-forward "\n* menu:" nil t) - (< (point) curr-point)))) - (if (not in-menu) - nil - (let ((node)) - (save-excursion - (forward-char) ; Pass '*' char if point is in front of - (if (search-backward "\n*" nil t) - (progn (forward-char 2) - (setq node (Info-extract-menu-node-name))))) - (if (null node) - nil - (if hyperb:lemacs-p - (Info-goto-node node nil t) - (Info-goto-node node)) - t))))) - -(provide 'hmous-info)
--- a/lisp/hyperbole/hmouse-drv.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,439 +0,0 @@ -;;!emacs -;; -;; FILE: hmouse-drv.el -;; SUMMARY: Smart Key/Mouse driver functions. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: hypermedia, mouse -;; -;; AUTHOR: Bob Weiner -;; ORIG-DATE: 04-Feb-90 -;; LAST-MOD: 22-Feb-97 at 14:16:55 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1989-1995, Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Other required Elisp libraries -;;; ************************************************************************ - -(require 'hypb) - -;;; ************************************************************************ -;;; Public variables -;;; ************************************************************************ - -(defvar action-key-depress-window nil - "The last window in which the Action Key was depressed or nil.") -(defvar assist-key-depress-window nil - "The last window in which the Assist Key was depressed or nil.") -(defvar action-key-release-window nil - "The last window in which the Action Key was released or nil.") -(defvar assist-key-release-window nil - "The last window in which the Assist Key was released or nil.") - -(defvar action-key-depress-prev-point nil - "Marker at point prior to last Action Key depress. -Note that this may be a buffer different than where the depress occurs.") -(defvar assist-key-depress-prev-point nil - "Marker at point prior to last Assist Key depress. -Note that this may be a buffer different than where the depress occurs.") -(defvar action-key-release-prev-point nil - "Marker at point prior to last Action Key release. -Note that this may be a buffer different than where the release occurs.") -(defvar assist-key-release-prev-point nil - "Marker at point prior to last Assist Key release. -Note that this may be a buffer different than where the release occurs.") - -(defvar action-key-cancelled nil - "When non-nil, cancels last Action Key depress.") -(defvar assist-key-cancelled nil - "When non-nil, cancels last Assist Key depress.") - -(defvar action-key-help-flag nil - "When non-nil, forces display of help for next Action Key release.") -(defvar assist-key-help-flag nil - "When non-nil, forces display of help for next Assist Key release.") - -;;; ************************************************************************ -;;; Hyperbole context-sensitive key driver functions -;;; ************************************************************************ - -(defun action-mouse-key (&rest args) - "Set point to the current mouse cursor position and execute 'action-key'. -Any ARGS will be passed to 'hmouse-function'." - (interactive) - (require 'hsite) - ;; Make this a no-op if some local mouse key binding overrode the global - ;; action-key-depress command invocation. - (if action-key-depressed-flag - (let ((hkey-alist hmouse-alist)) - (setq action-key-depressed-flag nil) - (cond (action-key-cancelled - (setq action-key-cancelled nil - assist-key-depressed-flag nil)) - (assist-key-depressed-flag - (hmouse-function nil nil args)) - ((action-mouse-key-help nil args)) - (t (hmouse-function 'action-key nil args)))))) - -(defun assist-mouse-key (&rest args) - "Set point to the current mouse cursor position and execute 'assist-key'. -Any ARGS will be passed to 'hmouse-function'." - (interactive) - (require 'hsite) - ;; Make this a no-op if some local mouse key binding overrode the global - ;; assist-key-depress command invocation. - (if assist-key-depressed-flag - (let ((hkey-alist hmouse-alist)) - (setq assist-key-depressed-flag nil) - (cond (assist-key-cancelled - (setq assist-key-cancelled nil - action-key-depressed-flag nil)) - (action-key-depressed-flag - (hmouse-function nil t args)) - ((action-mouse-key-help t args)) - (t (hmouse-function 'assist-key t args)))))) - -(defun hmouse-function (func assist-flag set-point-arg-list) - "Executes FUNC for Action Key (Assist Key with ASSIST-FLAG non-nil) and sets point from SET-POINT-ARG-LIST. -FUNC may be nil in which case no function is called. -SET-POINT-ARG-LIST is passed to the call of the command bound to -'hmouse-set-point-command'. Returns nil if 'hmouse-set-point-command' variable -is not bound to a valid function." - (if (fboundp hmouse-set-point-command) - (let ((release-args (hmouse-set-point set-point-arg-list))) - (if assist-flag - (setq assist-key-release-window (selected-window) - assist-key-release-args release-args - assist-key-release-prev-point (point-marker)) - (setq action-key-release-window (selected-window) - action-key-release-args release-args - action-key-release-prev-point (point-marker))) - (and (eq major-mode 'br-mode) - (setq action-mouse-key-prev-window - (if (br-in-view-window-p) - (save-window-excursion - (br-next-listing-window) - (selected-window)) - (selected-window)))) - (setq action-mouse-key-prefix-arg current-prefix-arg) - (if (null func) - nil - (funcall func) - (setq action-mouse-key-prev-window nil - action-mouse-key-prefix-arg nil)) - t))) - -(defun action-mouse-key-help (assist-flag args) - "If a Smart Key help flag is set and the other Smart Key is not down, shows help. -Takes two args: ASSIST-FLAG should be non-nil iff command applies to the Assist Key. -ARGS is a list of arguments passed to 'hmouse-function'. -Returns t if help is displayed, nil otherwise." - (let ((help-shown) - (other-key-released (not (if assist-flag - action-key-depressed-flag - assist-key-depressed-flag)))) - (unwind-protect - (setq help-shown - (cond ((and action-key-help-flag other-key-released) - (setq action-key-help-flag nil) - (hmouse-function 'hkey-help assist-flag args) - t) - ((and assist-key-help-flag other-key-released) - (setq assist-key-help-flag nil) - (hmouse-function 'assist-key-help assist-flag args) - t))) - (if help-shown - ;; Then both Smart Keys have been released. - (progn (setq action-key-cancelled nil - assist-key-cancelled nil) - t))))) - -(defun action-key () - "Use one key to perform functions that vary by buffer. -Default function is given by 'action-key-default-function' variable. -Returns t unless 'action-key-default-function' variable is not bound to a valid -function." - (interactive) - (require 'hsite) - (or (hkey-execute nil) - (if (fboundp action-key-default-function) - (progn (funcall action-key-default-function) - t)))) - -(defun assist-key () - "Use one assist-key to perform functions that vary by buffer. -Default function is given by 'assist-key-default-function' variable. -Returns non-nil unless 'assist-key-default-function' variable is not bound -to a valid function." - (interactive) - (require 'hsite) - (or (hkey-execute t) - (if (fboundp assist-key-default-function) - (progn (funcall assist-key-default-function) - t)))) - -(defun hkey-execute (assist-flag) - "Evaluate Action Key form (or Assist Key form with ASSIST-FLAG non-nil) for first non-nil predicate from 'hkey-alist'. -Non-nil ASSIST-FLAG means evaluate second form, otherwise evaluate first form. -Returns non-nil iff a non-nil predicate is found." - (let ((pred-forms hkey-alist) - (pred-form) (pred-t)) - (while (and (null pred-t) (setq pred-form (car pred-forms))) - (if (setq pred-t (eval (car pred-form))) - (eval (if assist-flag (cdr (cdr pred-form)) (car (cdr pred-form)))) - (setq pred-forms (cdr pred-forms)))) - pred-t)) - -(defun hkey-help (&optional assist-flag) - "Display help for the Action Key command in current context. -With optional ASSIST-FLAG non-nil, display help for the Assist Key command. -Returns non-nil iff associated help documentation is found." - (interactive "P") - (require 'hsite) - (let ((pred-forms hkey-alist) - (pred-form) (pred-t) (call) (cmd-sym) (doc)) - (while (and (null pred-t) (setq pred-form (car pred-forms))) - (or (setq pred-t (eval (car pred-form))) - (setq pred-forms (cdr pred-forms)))) - (if pred-t - (setq call (if assist-flag (cdr (cdr pred-form)) - (car (cdr pred-form))) - cmd-sym (car call)) - (setq cmd-sym - (if assist-flag assist-key-default-function action-key-default-function) - call cmd-sym)) - (setq hkey-help-msg - (if (and cmd-sym (symbolp cmd-sym)) - (progn - (setq doc (documentation cmd-sym)) - (let* ((condition (car pred-form)) - (temp-buffer-show-hook - (function - (lambda (buf) - (set-buffer buf) - (setq buffer-read-only t) - (if (br-in-browser) - (save-excursion - (let ((owind (selected-window))) - (br-to-view-window) - (select-window (previous-window)) - (display-buffer buf 'other-win) - (select-window owind))) - (display-buffer buf 'other-win))))) - (temp-buffer-show-function temp-buffer-show-hook)) - (with-output-to-temp-buffer (hypb:help-buf-name "Smart") - (princ (format "A click of the %s Key" - (if assist-flag "Assist" "Action"))) - (terpri) - (princ "WHEN ") - (princ - (or condition - "there is no matching context")) - (terpri) - (princ "CALLS ") (princ call) - (if doc (progn (princ " WHICH:") (terpri) (terpri) - (princ doc))) - (if (memq cmd-sym '(hui:hbut-act hui:hbut-help)) - (progn - (princ (format "\n\nBUTTON SPECIFICS:\n\n%s\n" - (actype:doc 'hbut:current t))) - (hattr:report - (nthcdr 2 (hattr:list 'hbut:current))))) - (terpri) - )) - "") - (message "No %s Key command for current context." - (if assist-flag "Assist" "Action")))) - doc)) - -(defun assist-key-help () - "Display doc associated with Assist Key command in current context. -Returns non-nil iff associated documentation is found." - (interactive) - (hkey-help 'assist)) - -(defun hkey-help-hide () - "Restores frame to configuration prior to help buffer display. -Point must be in the help buffer." - (let ((buf (current-buffer))) - (if *hkey-wconfig* - (set-window-configuration *hkey-wconfig*) - (switch-to-buffer (other-buffer))) - (bury-buffer buf) - (setq *hkey-wconfig* nil))) - -;;;###autoload -(defun hkey-help-show (buffer &optional current-window) - "Saves prior frame configuration if BUFFER displays help. Displays BUFFER. - -Optional second arg CURRENT-WINDOW non-nil forces display of buffer within -the current window. By default, it is displayed in another window." - (if (bufferp buffer) (setq buffer (buffer-name buffer))) - (and (stringp buffer) - (string-match "Help\\*$" buffer) - (not (memq t (mapcar (function - (lambda (wind) - (string-match - "Help\\*$" - (buffer-name (window-buffer wind))))) - (hypb:window-list 'no-mini)))) - (setq *hkey-wconfig* (current-window-configuration))) - (let* ((buf (get-buffer-create buffer)) - (wind (if current-window - (progn (switch-to-buffer buf) - (selected-window)) - (display-buffer buf)))) - (setq minibuffer-scroll-window wind))) - -(defun hkey-operate (arg) - "Uses the keyboard to emulate Smart Mouse Key drag actions. -Each invocation alternates between starting a drag and ending it. -Prefix ARG non-nil means emulate Assist Key rather than the Action Key. - -Only works when running under a window system, not from a dumb terminal." - (interactive "P") - (or hyperb:window-system - (hypb:error "(hkey-operate): Drag actions require mouse support")) - (if arg - (if assist-key-depressed-flag - (progn (assist-mouse-key) - (message "Assist Key released.")) - (assist-key-depress) - (message - "Assist Key depressed; go to release point and hit {%s %s}." - (substitute-command-keys "\\[universal-argument]") - (substitute-command-keys "\\[hkey-operate]") - )) - (if action-key-depressed-flag - (progn (action-mouse-key) - (message "Action Key released.")) - (action-key-depress) - (message "Action Key depressed; go to release point and hit {%s}." - (substitute-command-keys "\\[hkey-operate]")) - ))) - -(defun hkey-summarize (&optional current-window) - "Displays smart key operation summary in help buffer. -Optional arg CURRENT-WINDOW non-nil forces display of buffer within -the current window. By default, it is displayed in another window." - (let* ((doc-file (hypb:mouse-help-file)) - (buf-name (hypb:help-buf-name "Smart")) - (wind (get-buffer-window buf-name)) - owind) - (if (file-readable-p doc-file) - (progn - (if (br-in-browser) - (br-to-view-window)) - (setq owind (selected-window)) - (unwind-protect - (progn - (if wind - (select-window wind) - (hkey-help-show buf-name current-window) - (select-window (get-buffer-window buf-name))) - (setq buffer-read-only nil) (erase-buffer) - (insert-file-contents doc-file) - (goto-char (point-min)) - (set-buffer-modified-p nil)) - (select-window owind)))))) - -;; ************************************************************************ -;; Private variables -;; ************************************************************************ - -(defvar action-key-depress-args nil - "List of mouse event args from most recent depress of the Action Key.") -(defvar assist-key-depress-args nil - "List of mouse event args from most recent depress of the Assist Key.") - -(defvar action-key-release-args nil - "List of mouse event args from most recent release of the Action Key.") -(defvar assist-key-release-args nil - "List of mouse event args from most recent release of the Assist Key.") - -(defvar action-mouse-key-prev-window nil - "Window point was in prior to current invocation of 'action/assist-mouse-key'.") - -(defvar action-mouse-key-prefix-arg nil - "Prefix argument to pass to 'smart-br-cmd-select'.") - -(defvar action-key-depressed-flag nil "t while Action Key is depressed.") -(defvar assist-key-depressed-flag nil "t while Assist Key is depressed.") -(defvar hkey-help-msg "" "Holds last Smart Key help message.") -(defvar *hkey-wconfig* nil - "Screen configuration prior to display of a help buffer.") - -;;; ************************************************************************ -;;; public support functions -;;; ************************************************************************ - -;; "hsite.el" contains documentation for this variable. -(or (boundp 'smart-scroll-proportional) (setq smart-scroll-proportional nil)) - -;; The smart keys scroll buffers when pressed at the ends of lines. -;; These next two functions do the scrolling and keep point at the end -;; of line to simplify repeated scrolls when using keyboard smart keys. -;; -;; These functions may also be used to test whether the scroll action would -;; be successful, no action is taken if it would fail (because the beginning -;; or end of a buffer is already showing) and nil is returned. -;; t is returned whenever scrolling is performed. - -(defun smart-scroll-down () - "Scrolls down according to value of smart-scroll-proportional. -If smart-scroll-proportional is nil or if point is on the bottom window line, -scrolls down (backward) a windowful. Otherwise, tries to bring current line -to bottom of window. Leaves point at end of line and returns t if scrolled, -nil if not." - (interactive) - (let ((rtn t)) - (if smart-scroll-proportional - ;; If selected line is already last in window, then scroll backward - ;; a windowful, otherwise make it last in window. - (if (>= (point) (save-excursion - (goto-char (1- (window-end))) - (beginning-of-line) (point))) - (if (pos-visible-in-window-p (point-min)) - (setq rtn nil) - (scroll-down)) - (recenter -1)) - (if (pos-visible-in-window-p (point-min)) - (setq rtn nil) - (scroll-down))) - (end-of-line) - (or rtn (progn (beep) (message "Beginning of buffer"))) - rtn)) - -(defun smart-scroll-up () - "Scrolls up according to value of smart-scroll-proportional. -If smart-scroll-proportional is nil or if point is on the top window line, -scrolls up (forward) a windowful. Otherwise, tries to bring current line to -top of window. Leaves point at end of line and returns t if scrolled, nil if -not." - (interactive) - (let ((rtn t)) - (if smart-scroll-proportional - ;; If selected line is already first in window, then scroll forward a - ;; windowful, otherwise make it first in window. - (if (<= (point) (save-excursion - (goto-char (window-start)) - (end-of-line) (point))) - (if (pos-visible-in-window-p (point-max)) - (setq rtn nil) - (scroll-up)) - (recenter 0)) - (if (pos-visible-in-window-p (point-max)) - (setq rtn nil) - (scroll-up))) - (end-of-line) - (or rtn (progn (beep) (message "End of buffer"))) - rtn)) - -(provide 'hmouse-drv)
--- a/lisp/hyperbole/hmouse-key.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,350 +0,0 @@ -;;!emacs -;; -;; FILE: hmouse-key.el -;; SUMMARY: Load "hmouse-sh.el" or "hmouse-reg.el" for Smart Key bindings. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: hypermedia, mouse -;; -;; AUTHOR: Bob Weiner -;; ORG: InfoDock Associates -;; -;; ORIG-DATE: 30-May-94 at 00:11:57 -;; LAST-MOD: 21-Feb-97 at 18:03:12 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1994-1995, 1997 Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; -;; Supports Epoch, Lucid Emacs, X, Sunview, NEXTSTEP, and Apollo DM -;; window systems. -;; -;; `hmouse-shift-buttons' globally binds the Action and Assist Mouse Keys -;; to either shifted or unshifted mouse buttons. -;; -;; `hmouse-toggle-bindings' may be bound to a key. It switches between -;; the Hyperbole mouse bindings and previous mouse key bindings any time -;; after `hmouse-shift-buttons' has been called. -;; -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Other required Elisp libraries -;;; ************************************************************************ - -(require 'hversion) -(require 'hmouse-drv) -(require 'h-skip-bytec "h-skip-bytec.lsp") - -;;; ************************************************************************ -;;; Public variables -;;; ************************************************************************ - -(if (or hyperb:xemacs-p hyperb:emacs19-p) - ;; XEmacs and Emacs 19 pre-load their mouse libraries, so - ;; we shouldn't have to require them here. - nil - (eval (cdr (assoc hyperb:window-system - '( - ("xterm" . (require 'x-mouse)) ; X - ("epoch" . (require 'mouse)) ; UofI Epoch - ("next" . (load "eterm-fns" t)) ; NeXTstep - ("sun" . (require 'sun-fns)) ; SunView - ("apollo" . (require 'apollo)) ; Display Manager - ))))) - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -(defun hmouse-set-bindings (key-binding-list) - "Sets mouse keys used as Smart Keys to bindings in KEY-BINDING-LIST. -KEY-BINDING-LIST is the value returned by 'hmouse-get-bindings' prior to -Smart Key setup." - (cond - ;; Do nothing when running in batch mode. - (noninteractive) - ;; - ;; GNU Emacs 19, Lucid Emacs, XEmacs or InfoDock - ((or hyperb:xemacs-p hyperb:emacs19-p (equal hyperb:window-system "lemacs")) - (mapcar - (function - (lambda (key-and-binding) - (global-set-key (car key-and-binding) (cdr key-and-binding)))) - key-binding-list)) - ;; - ;; X - ((equal hyperb:window-system "xterm") - (mapcar - (function - (lambda (key-and-binding) - (define-key mouse-map (car key-and-binding) (cdr key-and-binding)))) - key-binding-list)) - ;; - ;; Epoch - ((equal hyperb:window-system "epoch") - (mapcar - (function - (lambda (key-and-binding) - (aset mouse::global-map (car key-and-binding) - (cdr key-and-binding)))) - key-binding-list)) - ;; - ;; SunView or NeXT - ((or (equal hyperb:window-system "next") - (equal hyperb:window-system "sun")) - (mapcar - (function - (lambda (key-and-binding) - (global-set-mouse (car key-and-binding) (cdr key-and-binding)))) - key-binding-list)) - ;; - ;; Apollo Display Manager - ((equal hyperb:window-system "apollo") - (if (string< emacs-version "18.58") - (mapcar - (function - (lambda (key-and-binding) - (global-set-key (car key-and-binding) (cdr key-and-binding)))) - key-binding-list) - (mapcar - (function - (lambda (key-and-binding) - (define-key 'apollo-prefix (car key-and-binding) - (cdr key-and-binding)))) - key-binding-list))))) - -(defun hmouse-shift-buttons (&optional arg) - "Selects between shifted and unshifted Action and Assist mouse buttons. -With optional prefix ARG, use shifted buttons if ARG is positive or use -unshifted buttons otherwise. If ARG is nil, shifted buttons are used and -under InfoDock the middle button also acts as an Action Key." - (interactive "P") - (setq hmouse-shift-flag (if arg - (> (prefix-numeric-value arg) 0) - (not (and (boundp 'infodock-version) - infodock-version)))) - (if hmouse-shift-flag - ;; Action Key = shift-middle mouse key. Assist Key = shift-right mouse - ;; key. Standard Hyperbole configuration. - (load "hmouse-sh") - ;; Action Key = middle mouse key; Assist Key = right mouse key - ;; InfoDock actually moves the Assist Key to the shift-right mouse key so - ;; that the right key can be used for popup menus. - (load "hmouse-reg")) - ;; Replace any original mouse bindings before moving Hyperbole bindings and - ;; then force reinitialization of hmouse-previous-bindings. - (if (and hmouse-bindings-flag hmouse-previous-bindings) - (hmouse-set-bindings hmouse-previous-bindings)) - (setq hmouse-bindings-flag nil - hmouse-previous-bindings nil) - ;; Initialize Hyperbole mouse bindings. - (hmouse-setup) - (if (interactive-p) - (message "%s Action and Assist mouse buttons in use." - (if hmouse-shift-flag "Shifted" "Unshifted")))) - -(defun hmouse-toggle-bindings () - "Toggles between Smart Key mouse settings and their prior bindings." - (interactive) - (let ((key-binding-list (if hmouse-bindings-flag - hmouse-previous-bindings - hmouse-bindings)) - (other-list-var (if hmouse-bindings-flag - 'hmouse-bindings - 'hmouse-previous-bindings))) - (if key-binding-list - (progn - (set other-list-var (hmouse-get-bindings)) - (hmouse-set-bindings key-binding-list) - (message "%s mouse bindings in use." - (if (setq hmouse-bindings-flag (not hmouse-bindings-flag)) - "Smart Key" "Personal"))) - (error "(hmouse-toggle-bindings): Null %s." other-list-var)))) - -(defun hmouse-set-point-at (set-point-arg-list) - "Sets point to cursor position using SET-POINT-ARG-LIST and returns t. -If 'hmouse-set-point-command' is not bound to a function, this does nothing -and returns nil." - (if (fboundp hmouse-set-point-command) - (progn - (if (and (boundp 'drag-zone) drag-zone) - (progn (delete-zone drag-zone) - (setq drag-zone nil)) - (and (boundp 'drag-button) drag-button - (progn (delete-button drag-button) - (setq drag-button nil)))) - (or (if set-point-arg-list - (funcall hmouse-set-point-command set-point-arg-list) - (funcall hmouse-set-point-command)) - t)))) - -;;; ************************************************************************ -;;; Private functions -;;; ************************************************************************ - -(if (fboundp 'bind-apollo-mouse-button) - (progn - (if (string< emacs-version "18.58") - (defun apollo-mouse-key-and-binding (mouse-button) - "Returns binding for an Apollo MOUSE-BUTTON (a string) or nil if none." - (interactive "sMouse Button: ") - (let ((numeric-code (cdr (assoc mouse-button *apollo-mouse-buttons*)))) - (if (null numeric-code) - (error "(hmouse-key): %s is not a valid Apollo mouse key name." - mouse-button)) - (if (stringp numeric-code) - (setq numeric-code - (cdr (assoc numeric-code *apollo-mouse-buttons*)))) - (let ((key-sequence (concat "\M-*" (char-to-string numeric-code)))) - (cons key-sequence (global-key-binding key-sequence))))) - (defun apollo-mouse-key-and-binding (mouse-button) - "Returns binding for an Apollo MOUSE-BUTTON (a string) or nil if none." - (interactive "sMouse Button: ") - (let ((numeric-code (cdr (assoc mouse-button *apollo-mouse-buttons*)))) - (if (null numeric-code) - (error "(hmouse-key): %s is not a valid Apollo mouse key name." - mouse-button)) - (if (stringp numeric-code) - (setq numeric-code - (cdr (assoc numeric-code *apollo-mouse-buttons*)))) - (let ((key-sequence (char-to-string numeric-code))) - (cons key-sequence (lookup-key 'apollo-prefix key-sequence))))) - ) - (defun apollo-mouse-move-point (&optional no-mark) - "Used so that pressing the left mouse button, moving the cursor, and -releasing the left mouse button leaves the mark set to the initial position -and the point set to the final position. Useful for easily marking regions -of text. If the left mouse button is pressed and released at the same place, -the mark is left at the original position of the character cursor. - -Returns (x y) frame coordinates of point in columns and lines." - (interactive) - (let* ((opoint (point)) - (owindow (selected-window)) - (x (- (read-char) 8)) - (y (- (read-char) 8)) - (edges (window-edges)) - (window nil)) - (while (and (not (eq window (selected-window))) - (or (< y (nth 1 edges)) - (>= y (nth 3 edges)) - (< x (nth 0 edges)) - (>= x (nth 2 edges)))) - (setq window (next-window window)) - (setq edges (window-edges window))) - (if (and window (not (eq window (selected-window)))) - (progn - (if (and (not *apollo-mouse-move-point-allow-minibuffer-exit*) - (eq (selected-window) (minibuffer-window))) - (error "Cannot use mouse to leave minibuffer!")) - (if (eq window (minibuffer-window)) - (error "Cannot use mouse to enter minibuffer!")))) - (if window (select-window window)) - (move-to-window-line (- y (nth 1 edges))) - (let* ((width-1 (1- (window-width window))) - (wraps (/ (current-column) width-1)) - (prompt-length (if (eq (selected-window) (minibuffer-window)) - (minibuffer-prompt-length) - 0))) - (move-to-column (+ (- x (nth 0 edges) prompt-length) - (* wraps width-1)))) - (if no-mark - (progn (setq window (selected-window)) - (if (eq owindow window) - (if (equal opoint (point)) - (pop-mark)) - (select-window owindow) - (pop-mark) - (select-window window))) - (set-mark-command nil)) - ;; Return (x y) coords of point in column and frame line numbers. - (list x y))) - )) - -(defun action-key-depress (&rest args) - (interactive) - (require 'hsite) - (setq action-key-depress-prev-point (point-marker) - action-key-depressed-flag t - action-key-depress-args (hmouse-set-point args) - action-key-depress-window (selected-window) - action-key-release-args nil - action-key-release-window nil - action-key-release-prev-point nil) - (if assist-key-depressed-flag - (or action-key-help-flag - (setq assist-key-help-flag t)))) - -(defun assist-key-depress (&rest args) - (interactive) - (require 'hsite) - (setq assist-key-depress-prev-point (point-marker) - assist-key-depressed-flag t - assist-key-depress-args (hmouse-set-point args) - assist-key-depress-window (selected-window) - assist-key-release-args nil - assist-key-release-window nil - assist-key-release-prev-point nil) - (if action-key-depressed-flag - (or assist-key-help-flag - (setq action-key-help-flag t))) - ) - -(defun action-key-depress-emacs19 (event) - (interactive "e") - (require 'hsite) - (action-key-depress event)) - -(defun assist-key-depress-emacs19 (event) - (interactive "e") - (require 'hsite) - (assist-key-depress event)) - -(defun action-mouse-key-emacs19 (event) - "Set point to the current mouse cursor position and execute 'action-key'. -EVENT will be passed to 'hmouse-function'." - (interactive "e") - (action-mouse-key (hmouse-key-release-args-emacs19 event))) - -(defun assist-mouse-key-emacs19 (event) - "Set point to the current mouse cursor position and execute 'action-key'. -EVENT will be passed to 'hmouse-function'." - (interactive "e") - (assist-mouse-key (hmouse-key-release-args-emacs19 event))) - -(defun hmouse-key-release-args-emacs19 (event) - (let ((ev-type-str (and (listp event) (symbol-name (car event))))) - (if (or (and ev-type-str - (string-match "\\(double\\|triple\\)-mouse" ev-type-str)) - (not (= (length event) 3))) - event - ;; Remove depress coordinates and send only release coordinates. - (list (car event) (nth 2 event))))) - -(defun hmouse-move-point-xemacs () - (condition-case () - (mouse-set-point current-mouse-event) - ;; Catch "not in a window" errors, e.g. on modeline - (error nil))) - -(defun hmouse-move-point-eterm (arg-list) - (apply 'mouse-move-point arg-list)) - -;;; ************************************************************************ -;;; Private variables -;;; ************************************************************************ - -(defvar hmouse-bindings nil - "List of (key . binding) pairs for Smart Mouse Keys.") - -(defvar hmouse-bindings-flag nil - "True if Smart Key mouse bindings are in use, else nil.") - -(defvar hmouse-previous-bindings nil - "List of previous (key . binding) pairs for mouse keys used as Smart Keys.") - -(provide 'hmouse-key)
--- a/lisp/hyperbole/hmouse-mod.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,148 +0,0 @@ -;;!emacs -;; -;; FILE: hmouse-mod.el -;; SUMMARY: Action Key acts as CONTROL modifier and Assist Key as META modifier. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: hypermedia, mouse -;; -;; AUTHOR: Bob Weiner -;; ORG: Motorola, Inc., PPG -;; -;; ORIG-DATE: 8-Oct-92 at 19:08:31 -;; LAST-MOD: 14-Apr-95 at 16:06:26 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1992-1995, Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; -;; This module is meant to be used with a chord keyboard in one hand for -;; typing and a mouse in the other. It requires that Hyperbole be loaded -;; in order to work. Hyperbole defines two Smart Keys, the Action Key and -;; the Assist Key, on the middle and right buttons by default. -;; -;; If the Action Key is held down while alpha characters are typed, -;; they are translated into Control keys instead. The Assist -;; Key translates them into Meta keys. When both Smart Keys -;; are depressed, Control-Meta keys are produced. The commands bound -;; to the characters produced are then run. -;; -;; So the Smart Keys modify the keys typed, e.g. Action Key + {a} -;; runs the function for {C-a}. -;; -;; If no keys are typed while the Smart Keys are down, they operate as -;; normally under Hyperbole. -;; -;; TO INVOKE: -;; -;; (hmouse-mod-set-global-map) -;; -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Other required Elisp libraries -;;; ************************************************************************ - -(require 'hyperbole) - -;;; ************************************************************************ -;;; Public variables -;;; ************************************************************************ - -(defvar hmouse-mod-global-map nil - "Global key map installed by hmouse-mod-set-global-map function. -Translates self-insert-command characters into control and meta characters if -the Action or Assist Keys are depressed at the time of key press.") - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -(defun hmouse-mod-insert-command (count) - "Surrogate function for self-insert-command. Accounts for modifier Smart Keys." - (interactive "p") - (if (and (boundp 'action-key-depressed-flag) - (boundp 'assist-key-depressed-flag)) - (cond ((and action-key-depressed-flag assist-key-depressed-flag) - (setq action-key-cancelled t - assist-key-cancelled t) - (let* ((c (downcase last-command-char)) - (key (char-to-string (+ 128 (% (- c ?\`) 128))))) - (if (and (or (= c ?\C-@) - (>= c ?a) (<= c ?z))) - (hmouse-mod-execute-command key) - (beep))) - ) - ;; Control keys - (action-key-depressed-flag - (setq action-key-cancelled t) - (let ((c (downcase last-command-char))) - (if (and (or (= c ?\C-@) - (>= c ?a) (<= c ?z))) - (hmouse-mod-execute-command - (char-to-string (- c ?\`))) - (beep))) - ) - ;; Meta keys - (assist-key-depressed-flag - (setq assist-key-cancelled t) - (hmouse-mod-execute-command - (char-to-string (+ 128 (% last-command-char 128)))) - ) - (t (call-interactively 'self-insert-command))) - (call-interactively 'self-insert-command)) - ) - -(defun hmouse-mod-keyboard-quit () - "Surrogate function for keyboard-quit. Cancels any hmouse-mod-prefix." - (interactive) - (setq hmouse-mod-prefix nil) - (keyboard-quit)) - -(defun hmouse-mod-set-global-map () - "Creates 'hmouse-mod-global-map' and installs as current global map. -It accounts for modifier Smart Keys." - (interactive) - (setq hmouse-mod-global-map (copy-keymap global-map)) - (substitute-key-definition - 'self-insert-command 'hmouse-mod-insert-command hmouse-mod-global-map) - (substitute-key-definition - 'keyboard-quit 'hmouse-mod-keyboard-quit hmouse-mod-global-map) - (use-global-map hmouse-mod-global-map)) - -;;; ************************************************************************ -;;; Private functions -;;; ************************************************************************ - -(defun hmouse-mod-execute-command (key) - "Executes command associated with keyboard KEY or if KEY prefix, records it." - (setq key (concat hmouse-mod-prefix key)) - (let ((binding (key-binding key))) - (cond ((and (not (or (vectorp binding) (stringp binding))) - (commandp binding)) - (if (> (length key) 1) - (or noninteractive (message (key-description key)))) - (setq hmouse-mod-prefix nil) - (call-interactively binding)) - ((symbolp binding) - (setq hmouse-mod-prefix nil) - (error "(hmouse-mod-execute-command): {%s} not bound to a command." - (key-description key))) - ((integerp binding) - (setq hmouse-mod-prefix nil) - (error "(hmouse-mod-execute-command): {%s} invalid key sequence." - (key-description key))) - (t (or noninteractive (message (key-description key))) - (setq hmouse-mod-prefix key))))) - -;;; ************************************************************************ -;;; Private variables -;;; ************************************************************************ - -(defvar hmouse-mod-prefix nil - "Prefix key part of current key sequence.") - -(provide 'hmouse-mod)
--- a/lisp/hyperbole/hmouse-reg.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,298 +0,0 @@ -;;!emacs -;; -;; FILE: hmouse-reg.el -;; SUMMARY: System-dependent Smart Mouse Key bindings (no shift key). -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: hypermedia, mouse -;; -;; AUTHOR: Bob Weiner -;; ORG: InfoDock Associates -;; -;; ORIG-DATE: 3-Sep-91 at 21:40:58 -;; LAST-MOD: 21-Feb-97 at 18:02:33 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1991-1997, Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -(defun hmouse-get-bindings () - "Returns list of bindings for mouse keys prior to their use as Smart Keys." - ;; Do nothing when running in batch mode. - (if noninteractive - nil - (eval - (cdr (assoc - ;; Get mouse bindings under Emacs 19 or XEmacs, even if not under a - ;; window system since it can have frames on ttys and windowed - ;; displays at the same time. - (or (and hyperb:xemacs-p "lemacs") - (and hyperb:emacs19-p "emacs19") - hyperb:window-system) - '(("emacs19" . - (mapcar (function - (lambda (key) (cons key (lookup-key global-map key)))) - (if (memq window-system '(ns dps)) - ;; NEXTSTEP offers only 2 mouse buttons which we use - ;; as the Smart Keys. We move the mouse-set-point - ;; command to shift-left. - '([down-mouse-1] [mouse-1] [down-mouse-2] [mouse-2] - [double-mouse-1] [triple-mouse-1] - [double-mouse-2] [triple-mouse-2] - [vertical-line down-mouse-1] [vertical-line mouse-1] - [vertical-line down-mouse-2] [vertical-line mouse-2] - [mode-line down-mouse-1] [mode-line mouse-1] - [mode-line down-mouse-2] [mode-line mouse-2] - [S-mouse-1] - ) - ;; X - '([down-mouse-2] [mouse-2] [down-mouse-3] [mouse-3] - [double-mouse-2] [triple-mouse-2] - [double-mouse-3] [triple-mouse-3] - [vertical-line down-mouse-2] [vertical-line mouse-2] - [vertical-line down-mouse-3] [vertical-line mouse-3] - [mode-line down-mouse-2] [mode-line mouse-2] - [mode-line down-mouse-3] [mode-line mouse-3] - )))) - ("lemacs" . - (nconc - (mapcar (function - (lambda (key) - (cons key (lookup-key global-map key)))) - '([button2] [button2up] [button3] [button3up])) - (if (boundp 'mode-line-map) - (mapcar (function - (lambda (key) - (cons key (lookup-key mode-line-map key)))) - '([button3] [button3up]))))) - ("xterm" . - (mapcar (function - (lambda (key) (cons key (lookup-key mouse-map key)))) - (list x-button-middle x-button-middle-up - x-button-right x-button-right-up))) - ("epoch" . - (mapcar (function - (lambda (key) (cons key (aref mouse::global-map key)))) - (list (mouse::index mouse-middle mouse-down) - (mouse::index mouse-middle mouse-up) - (mouse::index mouse-right mouse-down) - (mouse::index mouse-right mouse-up) - ;; Modeline mouse map - (mouse::index mouse-mode-middle mouse-down) - (mouse::index mouse-mode-middle mouse-up) - (mouse::index mouse-mode-right mouse-down) - (mouse::index mouse-mode-right mouse-up) - ))) - ("next" . - (mapcar (function - (lambda (key) - (cons key (mousemap-get - (mouse-list-to-mouse-code key) - current-global-mousemap)))) - (apply 'nconc - (mapcar (function - (lambda (region) - (mapcar (function - (lambda (key) - (cons region key))) - '((left) (up left) (shift left) - (right) (up right) - )))) - '(text scrollbar modeline minibuffer))) - )) - ;; SunView - ("sun" . - (mapcar (function - (lambda (key) - (setq key (mouse-list-to-mouse-code key)) - (cons key (mousemap-get - key current-global-mousemap)))) - (apply 'nconc - (mapcar (function - (lambda (region) - (mapcar (function - (lambda (key) - (cons region key))) - '((middle) (up middle) - (right) (up right) - )))) - '(text scrollbar modeline minibuffer))) - )) - ("apollo" . - (mapcar (function - (lambda (key-str) (apollo-mouse-key-and-binding - key-str))) - '("M2D" "M2U" "M3D" "M3U"))) - )))))) - -(defun hmouse-setup () - "Binds mouse keys for use as Smart Keys." - (interactive) - ;; Do nothing when running in batch mode. - (if noninteractive - nil - (or hmouse-bindings-flag hmouse-previous-bindings - (setq hmouse-previous-bindings (hmouse-get-bindings))) - ;; Ensure Gillespie's Info mouse support is off since - ;; Hyperbole handles that. - (setq Info-mouse-support nil) - ;; - (cond;; GNU Emacs 19 - (hyperb:emacs19-p - (setq hmouse-set-point-command 'mouse-set-point) - ;; Get rid of Info-mode [mouse-2] binding since Hyperbole performs - ;; a superset of what it does. - (add-hook 'Info-mode-hook - (function (lambda () (define-key Info-mode-map [mouse-2] nil)))) - ;; - (if (memq window-system '(ns dps)) - ;; NEXTSTEP offers only 2 mouse buttons which we use - ;; as the Smart Keys. We move the mouse-set-point - ;; command to shift-left. - (progn - (global-set-key [S-down-mouse-1] 'mouse-drag-region) - (global-set-key [S-mouse-1] 'mouse-set-point) - (global-set-key [down-mouse-1] 'action-key-depress-emacs19) - (global-set-key [mouse-1] 'action-mouse-key-emacs19) - (global-set-key [double-mouse-1] 'action-mouse-key-emacs19) - (global-set-key [triple-mouse-1] 'action-mouse-key-emacs19) - (global-set-key [down-mouse-2] 'assist-key-depress-emacs19) - (global-set-key [mouse-2] 'assist-mouse-key-emacs19) - (global-set-key [double-mouse-2] 'assist-mouse-key-emacs19) - (global-set-key [triple-mouse-2] 'assist-mouse-key-emacs19) - (global-set-key [vertical-line down-mouse-1] 'action-key-depress-emacs19) - (global-set-key [vertical-line mouse-1] 'action-mouse-key-emacs19) - (global-set-key [vertical-line down-mouse-2] 'assist-key-depress-emacs19) - (global-set-key [vertical-line mouse-2] 'assist-mouse-key-emacs19) - (global-set-key [mode-line down-mouse-2] 'action-key-depress-emacs19) - (global-set-key [mode-line mouse-2] 'action-mouse-key-emacs19) - (global-set-key [mode-line down-mouse-3] 'assist-key-depress-emacs19) - (global-set-key [mode-line mouse-3] 'assist-mouse-key-emacs19)) - ;; X - (global-set-key [down-mouse-2] 'action-key-depress-emacs19) - (global-set-key [mouse-2] 'action-mouse-key-emacs19) - (global-set-key [double-mouse-2] 'action-mouse-key-emacs19) - (global-set-key [triple-mouse-2] 'action-mouse-key-emacs19) - (global-set-key [down-mouse-3] 'assist-key-depress-emacs19) - (global-set-key [mouse-3] 'assist-mouse-key-emacs19) - (global-set-key [double-mouse-3] 'assist-mouse-key-emacs19) - (global-set-key [triple-mouse-3] 'assist-mouse-key-emacs19) - (global-set-key [vertical-line down-mouse-2] 'action-key-depress-emacs19) - (global-set-key [vertical-line mouse-2] 'action-mouse-key-emacs19) - (global-set-key [vertical-line down-mouse-3] 'assist-key-depress-emacs19) - (global-set-key [vertical-line mouse-3] 'assist-mouse-key-emacs19) - (global-set-key [mode-line down-mouse-2] 'action-key-depress-emacs19) - (global-set-key [mode-line mouse-2] 'action-mouse-key-emacs19) - (global-set-key [mode-line down-mouse-3] 'assist-key-depress-emacs19) - (global-set-key [mode-line mouse-3] 'assist-mouse-key-emacs19))) - ;; - ;; XEmacs - (hyperb:xemacs-p - ;; Set mouse bindings under XEmacs, even if not under a window - ;; system since it can have frames on ttys and windowed displays at - ;; the same time. - (setq hmouse-set-point-command 'hmouse-move-point-xemacs) - ;; Get rid of Info-mode buttons 2 and 3 bindings since Hyperbole - ;; handles things in Info. - (add-hook 'Info-mode-hook - (function (lambda () - (define-key Info-mode-map 'button2 nil)))) - ;; - (global-set-key 'button2 'action-key-depress) - (global-set-key 'button2up 'action-mouse-key) - (if (fboundp 'infodock-set-mouse-bindings) - (infodock-set-mouse-bindings) - (let ((unbind-but3 - (function (lambda () - (define-key Info-mode-map 'button3 nil))))) - (if (and (boundp 'Info-mode-map) (keymapp Info-mode-map)) - (funcall unbind-but3) - (add-hook 'Info-mode-hook unbind-but3))) - (if (boundp 'mode-line-map) - (progn (define-key mode-line-map 'button3 'assist-key-depress) - (define-key mode-line-map 'button3up 'assist-mouse-key))) - (global-set-key 'button3 'assist-key-depress) - (global-set-key 'button3up 'assist-mouse-key))) - ;; - ;; X - ((equal hyperb:window-system "xterm") - (setq hmouse-set-point-command 'x-mouse-set-point) - (define-key mouse-map x-button-middle 'action-key-depress) - (define-key mouse-map x-button-middle-up 'action-mouse-key) - (define-key mouse-map x-button-right 'assist-key-depress) - (define-key mouse-map x-button-right-up 'assist-mouse-key) - ;; Use these instead of the above for a true META-BUTTON binding. - ;; (define-key mouse-map x-button-m-middle 'assist-key-depress) - ;; (define-key mouse-map x-button-m-middle-up 'assist-mouse-key) - ) - ;; - ;; Epoch - ((equal hyperb:window-system "epoch") - (setq hmouse-set-point-command 'mouse::set-point) - (global-set-mouse mouse-middle mouse-down 'action-key-depress) - (global-set-mouse mouse-middle mouse-up 'action-mouse-key) - (global-set-mouse mouse-right mouse-down 'assist-key-depress) - (global-set-mouse mouse-right mouse-up 'assist-mouse-key) - ;; Modeline mouse map - (global-set-mouse mouse-mode-middle mouse-down 'action-key-depress) - (global-set-mouse mouse-mode-middle mouse-up 'action-mouse-key) - (global-set-mouse mouse-mode-right mouse-down 'assist-key-depress) - (global-set-mouse mouse-mode-right mouse-up 'assist-mouse-key) - ) - ;; - ;; NeXT - ((equal hyperb:window-system "next") - (setq hmouse-set-point-command 'hmouse-move-point-eterm) - ;; Use shift-left button to set point. - ;; Use left button instead of non-existent middle as Smart Key. - (mapcar - (function - (lambda (region) - (global-set-mouse (cons region '(shift left)) 'mouse-move-point) - (global-set-mouse (cons region '(left)) 'action-key-depress) - (global-set-mouse (cons region '(up left)) 'action-mouse-key) - (global-set-mouse (cons region '(right)) 'assist-key-depress) - (global-set-mouse (cons region '(up right)) 'assist-mouse-key) - ;; Use these instead of the above for a true META-BUTTON binding. - ;; (global-set-mouse (cons region '(meta right)) 'assist-key-depress) - ;; (global-set-mouse (cons region '(meta up right)) 'assist-mouse-key) - )) - '(text scrollbar modeline minibuffer)) - ) - ;; - ;; SunView - ((equal hyperb:window-system "sun") - (setq hmouse-set-point-command 'hmouse-move-point-eterm) - (mapcar - (function - (lambda (region) - (global-set-mouse (cons region '(middle)) 'action-key-depress) - (global-set-mouse (cons region '(up middle)) 'action-mouse-key) - (global-set-mouse (cons region '(right)) 'assist-key-depress) - (global-set-mouse (cons region '(up right)) 'assist-mouse-key) - ;; Use these instead of the above for a true META-BUTTON binding. - ;; (global-set-mouse (cons region '(meta middle)) 'assist-key-depress) - ;; (global-set-mouse (cons region '(meta up middle)) 'assist-mouse-key) - )) - '(text scrollbar modeline minibuffer)) - ) - ;; - ;; Apollo DM - ((equal hyperb:window-system "apollo") - (setq hmouse-set-point-command 'apollo-mouse-move-point) - (bind-apollo-mouse-button "M2D" 'action-key-depress) - (bind-apollo-mouse-button "M2U" 'action-mouse-key) - (bind-apollo-mouse-button "M3D" 'assist-key-depress) - (bind-apollo-mouse-button "M3U" 'assist-mouse-key) - ;; Use these instead of the above for a true META-BUTTON binding. - ;; (bind-apollo-mouse-button "M2U" 'action-mouse-key - ;; 'assist-mouse-key) - ;; (bind-apollo-mouse-button "M2D" 'action-key-depress 'assist-key-depress) - )) - (setq hmouse-bindings (hmouse-get-bindings) - hmouse-bindings-flag t)))
--- a/lisp/hyperbole/hmouse-sh.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,296 +0,0 @@ -;;!emacs -;; -;; FILE: hmouse-sh.el -;; SUMMARY: System-dependent Smart Mouse Key bindings (using shift key). -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: hypermedia, mouse -;; -;; AUTHOR: Bob Weiner -;; ORG: InfoDock Associates -;; -;; ORIG-DATE: 3-Sep-91 at 21:40:58 -;; LAST-MOD: 21-Feb-97 at 18:02:48 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1991-1997, Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; -;; See description in "hmouse-key.el". -;; -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -(defun hmouse-get-bindings () - "Returns list of bindings for mouse keys prior to their use as Smart Keys." - ;; Do nothing when running in batch mode. - (if noninteractive - nil - (eval - (cdr (assoc - ;; Get mouse bindings under Emacs 19 or XEmacs, even if not under a - ;; window system since it can have frames on ttys and windowed - ;; displays at the same time. - (or (and hyperb:xemacs-p "lemacs") - (and hyperb:emacs19-p "emacs19") - hyperb:window-system) - '(("emacs19" . - (mapcar (function - (lambda (key) (cons key (lookup-key global-map key)))) - (if (memq window-system '(ns dps)) - ;; NEXTSTEP offers only 2 shift-mouse buttons which we use - ;; as the Smart Keys. - '([S-down-mouse-1] [S-mouse-1] [S-down-mouse-2] - [S-mouse-2] [S-double-mouse-1] [S-triple-mouse-1] - [S-double-mouse-2] [S-triple-mouse-2] - [vertical-line S-down-mouse-1] - [vertical-line S-mouse-1] - [vertical-line S-down-mouse-2] - [vertical-line S-mouse-2] - [mode-line S-down-mouse-1] [mode-line S-mouse-1] - [mode-line S-down-mouse-2] [mode-line S-mouse-2] - ) - ;; X - '([S-down-mouse-2] [S-mouse-2] [S-down-mouse-3] - [S-mouse-3] [S-double-mouse-2] [S-triple-mouse-2] - [S-double-mouse-3] [S-triple-mouse-3] - [vertical-line S-down-mouse-2] - [vertical-line S-mouse-2] - [vertical-line S-down-mouse-3] - [vertical-line S-mouse-3] - [mode-line S-down-mouse-2] [mode-line S-mouse-2] - [mode-line S-down-mouse-3] [mode-line S-mouse-3] - )))) - ("lemacs" . - (nconc - (mapcar (function - (lambda (key) - (cons key (lookup-key global-map key)))) - '([(shift button2)] [(shift button2up)] - [(shift button3)] [(shift button3up)])) - (if (boundp 'mode-line-map) - (mapcar (function - (lambda (key) - (cons key (lookup-key mode-line-map key)))) - '([(shift button3)] [(shift button3up)]))))) - ("xterm" . - (mapcar (function - (lambda (key) (cons key (lookup-key mouse-map key)))) - (list x-button-s-middle x-button-s-middle-up - x-button-s-right x-button-s-right-up))) - ("epoch" . - (mapcar (function - (lambda (key) (cons key (aref mouse::global-map key)))) - (list (mouse::index mouse-middle mouse-shift) - (mouse::index mouse-middle mouse-shift-up) - (mouse::index mouse-right mouse-shift) - (mouse::index mouse-right mouse-shift-up) - ;; Modeline mouse map - (mouse::index mouse-mode-middle mouse-shift) - (mouse::index mouse-mode-middle mouse-shift-up) - (mouse::index mouse-mode-right mouse-shift) - (mouse::index mouse-mode-right mouse-shift-up) - ))) - ("next" . - (mapcar (function - (lambda (key) - (cons key (mousemap-get - (mouse-list-to-mouse-code key) - current-global-mousemap)))) - (apply 'nconc - (mapcar (function - (lambda (region) - (mapcar (function - (lambda (key) - (cons region key))) - '((shift left) (shift up left) - (shift right) - (shift up right) - )))) - '(text scrollbar modeline minibuffer))) - )) - ;; SunView - ("sun" . - (mapcar (function - (lambda (key) - (setq key (mouse-list-to-mouse-code key)) - (cons key (mousemap-get - key current-global-mousemap)))) - (apply 'nconc - (mapcar (function - (lambda (region) - (mapcar (function - (lambda (key) - (cons region key))) - '((shift middle) - (shift up middle) - (shift right) - (shift up right) - )))) - '(text scrollbar modeline minibuffer))) - )) - ("apollo" . - (mapcar (function - (lambda (key-str) (apollo-mouse-key-and-binding - key-str))) - '("M2S" "M2U" "M3S" "M3U"))) - )))))) - -(defun hmouse-setup () - "Binds mouse keys for use as Smart Keys." - (interactive) - ;; Do nothing when running in batch mode. - (if noninteractive - nil - (or hmouse-bindings-flag hmouse-previous-bindings - (setq hmouse-previous-bindings (hmouse-get-bindings))) - ;; Ensure Gillespie's Info mouse support is off since - ;; Hyperbole handles that. - (setq Info-mouse-support nil) - ;; - (cond;; GNU Emacs 19 - (hyperb:emacs19-p - (setq hmouse-set-point-command 'mouse-set-point) - (if (memq window-system '(ns dps)) - ;; NEXTSTEP offers only 2 shift-mouse buttons which we use - ;; as the Smart Keys. - (progn - (global-set-key [S-down-mouse-1] 'action-key-depress-emacs19) - (global-set-key [S-mouse-1] 'action-mouse-key-emacs19) - (global-set-key [S-double-mouse-1] 'action-mouse-key-emacs19) - (global-set-key [S-triple-mouse-1] 'action-mouse-key-emacs19) - (global-set-key [S-down-mouse-2] 'assist-key-depress-emacs19) - (global-set-key [S-mouse-2] 'assist-mouse-key-emacs19) - (global-set-key [S-double-mouse-2] 'assist-mouse-key-emacs19) - (global-set-key [S-triple-mouse-2] 'assist-mouse-key-emacs19) - (global-set-key [vertical-line S-down-mouse-1] 'action-key-depress-emacs19) - (global-set-key [vertical-line S-mouse-1] 'action-mouse-key-emacs19) - (global-set-key [vertical-line S-down-mouse-2] - 'assist-key-depress-emacs19) - (global-set-key [vertical-line S-mouse-2] - 'assist-mouse-key-emacs19) - (global-set-key [mode-line S-down-mouse-1] 'action-key-depress-emacs19) - (global-set-key [mode-line S-mouse-1] 'action-mouse-key-emacs19) - (global-set-key [mode-line S-down-mouse-2] 'assist-key-depress-emacs19) - (global-set-key [mode-line S-mouse-2] 'assist-mouse-key-emacs19)) - ;; X - (global-set-key [S-down-mouse-2] 'action-key-depress-emacs19) - (global-set-key [S-mouse-2] 'action-mouse-key-emacs19) - (global-set-key [S-double-mouse-2] 'action-mouse-key-emacs19) - (global-set-key [S-triple-mouse-2] 'action-mouse-key-emacs19) - (global-set-key [S-down-mouse-3] 'assist-key-depress-emacs19) - (global-set-key [S-mouse-3] 'assist-mouse-key-emacs19) - (global-set-key [S-double-mouse-3] 'assist-mouse-key-emacs19) - (global-set-key [S-triple-mouse-3] 'assist-mouse-key-emacs19) - (global-set-key [vertical-line S-down-mouse-2] 'action-key-depress-emacs19) - (global-set-key [vertical-line S-mouse-2] 'action-mouse-key-emacs19) - (global-set-key [vertical-line S-down-mouse-3] - 'assist-key-depress-emacs19) - (global-set-key [vertical-line S-mouse-3] - 'assist-mouse-key-emacs19) - (global-set-key [mode-line S-down-mouse-2] 'action-key-depress-emacs19) - (global-set-key [mode-line S-mouse-2] 'action-mouse-key-emacs19) - (global-set-key [mode-line S-down-mouse-3] 'assist-key-depress-emacs19) - (global-set-key [mode-line S-mouse-3] 'assist-mouse-key-emacs19))) - ;; - ;; XEmacs - (hyperb:xemacs-p - ;; Set mouse bindings under XEmacs, even if not under a window - ;; system since it can have frames on ttys and windowed displays at - ;; the same time. - (setq hmouse-set-point-command 'hmouse-move-point-xemacs) - (global-set-key '(shift button2) 'action-key-depress) - (global-set-key '(shift button2up) 'action-mouse-key) - (if (fboundp 'infodock-set-mouse-bindings) - (infodock-set-mouse-bindings) - (if (boundp 'mode-line-map) - (progn (define-key mode-line-map '(shift button3) - 'assist-key-depress) - (define-key mode-line-map '(shift button3up) - 'assist-mouse-key) - )) - (global-set-key '(shift button3) 'assist-key-depress) - (global-set-key '(shift button3up) 'assist-mouse-key))) - ;; - ;; X - ((equal hyperb:window-system "xterm") - (setq hmouse-set-point-command 'x-mouse-set-point) - (define-key mouse-map x-button-s-middle 'action-key-depress) - (define-key mouse-map x-button-s-middle-up 'action-mouse-key) - (define-key mouse-map x-button-s-right 'assist-key-depress) - (define-key mouse-map x-button-s-right-up 'assist-mouse-key) - ;; Use these instead of the above for a true META-BUTTON binding. - ;; (define-key mouse-map x-button-m-middle 'assist-key-depress) - ;; (define-key mouse-map x-button-m-middle-up 'assist-mouse-key) - ) - ;; - ;; Epoch - ((equal hyperb:window-system "epoch") - (setq hmouse-set-point-command 'mouse::set-point) - (global-set-mouse mouse-middle mouse-shift 'action-key-depress) - (global-set-mouse mouse-middle mouse-shift-up 'action-mouse-key) - (global-set-mouse mouse-right mouse-shift 'assist-key-depress) - (global-set-mouse mouse-right mouse-shift-up 'assist-mouse-key) - ;; Modeline mouse map - (global-set-mouse mouse-mode-middle mouse-shift 'action-key-depress) - (global-set-mouse mouse-mode-middle mouse-shift-up 'action-mouse-key) - (global-set-mouse mouse-mode-right mouse-shift 'assist-key-depress) - (global-set-mouse mouse-mode-right mouse-shift-up - 'assist-mouse-key) - ) - ;; - ;; NeXT - ((equal hyperb:window-system "next") - (setq hmouse-set-point-command 'hmouse-move-point-eterm) - ;; Use left button to set point. - ;; Use shift-left button instead of non-existent middle as Action Key. - (mapcar - (function - (lambda (region) - (global-set-mouse (cons region '(shift left)) 'action-key-depress) - (global-set-mouse (cons region '(shift up left)) 'action-mouse-key) - (global-set-mouse (cons region '(shift right)) 'assist-key-depress) - (global-set-mouse (cons region '(shift up right)) - 'assist-mouse-key) - ;; Use these instead of the above for a true META-BUTTON binding. - ;; (global-set-mouse (cons region '(meta right)) 'assist-key-depress) - ;; (global-set-mouse (cons region '(meta up right)) 'assist-mouse-key) - )) - '(text scrollbar modeline minibuffer)) - ) - ;; - ;; SunView - ((equal hyperb:window-system "sun") - (setq hmouse-set-point-command 'hmouse-move-point-eterm) - (mapcar - (function - (lambda (region) - (global-set-mouse (cons region '(shift middle)) 'action-key-depress) - (global-set-mouse (cons region '(shift up middle)) - 'action-mouse-key) - (global-set-mouse (cons region '(shift right)) 'assist-key-depress) - (global-set-mouse (cons region '(shift up right)) - 'assist-mouse-key) - ;; Use these instead of the above for a true META-BUTTON binding. - ;; (global-set-mouse (cons region '(meta middle)) 'assist-key-depress) - ;; (global-set-mouse (cons region '(meta up middle)) 'assist-mouse-key) - )) - '(text scrollbar modeline minibuffer)) - ) - ;; - ;; Apollo DM - ((equal hyperb:window-system "apollo") - (setq hmouse-set-point-command 'apollo-mouse-move-point) - (bind-apollo-mouse-button "M2S" 'action-key-depress) - (bind-apollo-mouse-button "M2U" 'action-mouse-key) - (bind-apollo-mouse-button "M3S" 'assist-key-depress) - (bind-apollo-mouse-button "M3U" 'assist-mouse-key) - )) - (setq hmouse-bindings (hmouse-get-bindings) - hmouse-bindings-flag t)))
--- a/lisp/hyperbole/hmouse-tag.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,929 +0,0 @@ -;;!emacs -;; -;; FILE: hmouse-tag.el -;; SUMMARY: Smart Key support of programming language tags location. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: c, hypermedia, mouse, oop, tools -;; -;; AUTHOR: Bob Weiner -;; ORG: InfoDock Associates -;; -;; ORIG-DATE: 24-Aug-91 -;; LAST-MOD: 17-Feb-97 at 15:31:50 by Bob Weiner -;;; ************************************************************************ -;;; Other required Elisp libraries -;;; ************************************************************************ - -(require 'hpath) -(require 'hbut) - -(if (cond ((or (featurep 'etags) (featurep 'tags)) - nil) - ((or hyperb:lemacs-p hyperb:emacs19-p) - ;; Force use of .elc file here since otherwise the bin/etags - ;; executable might be found in a user's load-path by the load - ;; command. - (or (load "etags.elc" t nil t) - (load "tags-fix" t))) - ((load "tags" t))) - (provide 'tags)) - -;;; ************************************************************************ -;;; Public variables -;;; ************************************************************************ - -(defvar smart-asm-include-dirs nil - "*Ordered list of directories to search for assembly language include files. -Each directory must end with a directory separator.") - -(defconst smart-asm-include-regexp - "[ \t*#|;]*\\(include\\|lib\\)[ \t]+\\([^ \t\n\^M]+\\)" - "Regexp to match to assembly language include file lines. -Include keyword matched is grouping 1. File name is grouping 2 but may be -missing its suffix, so add \".ins\" or \".inc\" if need be. -Examples include: - INCLUDE GLOBALS - should jump to file \"globals.ins\" - lib conditionals_equ.inc - should include \"conditionals_equ.inc\"") - -(defvar smart-c-cpp-include-dirs '("/usr/include/") - "*Ordered list of include directories by default searched by C/C++ preprocessor. -Each directory must end with a directory separator. See also -'smart-c-include-dirs'.") - -(defvar smart-c-include-dirs nil - "*Ordered list of directories to search for C/C++ include files. -Each directory must end with a directory separator. Directories normally -searched by the C/C++ pre-processor should be set instead in -`smart-c-cpp-include-dirs'.") - -(defvar smart-c-use-lib-man nil - "When non-nil makes `smart-c' and `smart-c++' display man pages for recognized lib symbols. -When nil, `smart-c' and `smart-c++' look up only symbols defined in an etags -TAGS file. - -Create the file ~/.CLIBS-LIST and populate it with the full pathnames (one per -line) of all of the C/C++ libraries whose symbols you want to match against. -Your MANPATH environment variable must include paths for the man pages of -these libraries also. - -Your smart-clib-sym executable script must output a 1 if a symbol is from a -C/C++ library listed in ~/.CLIBS-LIST or 0 if not! Otherwise, don't set this -variable to t.") - -(defconst smart-c-include-regexp - "[ \t/*]*#[ \t]*\\(include\\|import\\)[ \t]+\\([\"<]\\)\\([^\">]+\\)[\">]" - "Regexp to match to C, C++, or Objective-C include file lines. -Include keyword matched is grouping 1. Type of include, user-specified via -double quote, or system-related starting with `<' is given by grouping 2. -File name is grouping 3.") - -(defvar smart-java-package-dirs - (and (fboundp 'getenv) (getenv "JAVA_HOME") - (list (expand-file-name "src/" (file-name-as-directory (getenv "JAVA_HOME"))))) - "*Ordered list of directories to search for imported Java packages. -Each directory must end with a directory separator.") - -(defconst smart-java-package-regexp - "[ \t/*]*\\(package\\|import\\)[ \t]+\\([^; \t\n\r\f]+\\)" - "Regexp to match to Java `package' and `import' lines. -Keyword matched is grouping 1. Referent is grouping 2.") - -(defvar smart-emacs-tags-file nil - "*Full path name of etags file for GNU Emacs source.") - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -(defun smart-asm (&optional identifier next) - "Jumps to the definition of optional assembly IDENTIFIER or the one at point. -Optional second arg NEXT means jump to next matching assembly tag. - -It assumes that its caller has already checked that the key was pressed in an -appropriate buffer and has moved the cursor to the selected buffer. - -If: - (1) on an include statement, the include file is displayed; - Look for include file in directory list `smart-asm-include-dirs'. - (2) on an identifier, the identifier definition is displayed, - assuming the identifier is found within an `etags' generated tag file - in the current directory or any of its ancestor directories." - - (interactive) - (or - (if identifier nil (smart-asm-include-file)) - (let ((tag (or identifier (smart-asm-at-tag-p)))) - ;; Set free variable tags-file-name so that next `find-tag' command uses - ;; whatever tags file is set here. - (setq tags-file-name (smart-tags-file buffer-file-name)) - (message "Looking for `%s' in `%s'..." tag tags-file-name) - (condition-case () - (progn - (smart-tags-display tag next) - (message "Found definition for `%s'." tag)) - (error (message "`%s' not found in `%s'." tag tags-file-name) - (beep)))))) - -;;;###autoload -(defun smart-asm-at-tag-p () - "Return assembly tag name that point is within, else nil." - (let* ((identifier-chars "_.$a-zA-Z0-9") - (identifier (concat "[_.$a-zA-Z][" identifier-chars "]*"))) - (save-excursion - (skip-chars-backward identifier-chars) - (if (looking-at identifier) - (smart-flash-tag - (buffer-substring (point) (match-end 0)) - (point) (match-end 0)))))) - -(defun smart-c (&optional identifier next) - "Jumps to the definition of optional C IDENTIFIER or the one at point. -Optional second arg NEXT means jump to next matching C tag. - -It assumes that its caller has already checked that the key was pressed in an -appropriate buffer and has moved the cursor to the selected buffer. - -If: - (1) on a `#include' statement, the include file is displayed; - Look for include file in directory lists `smart-c-cpp-include-dirs' - and `smart-c-include-dirs'. - (2) on a C identifier, the identifier definition is displayed, - assuming the identifier is found within an `etags' generated tag file - in the current directory or any of its ancestor directories. - (3) if `smart-c-use-lib-man' is non-nil, the C identifier is - recognized as a library symbol, and a man page is found for the - identifier, then the man page is displayed." - - (interactive) - (or - (if identifier nil (smart-c-include-file)) - (let ((tag (or identifier (smart-c-at-tag-p)))) - ;; Set free variable tags-file-name so that next `find-tag' command uses - ;; whatever tags file is set here. - (setq tags-file-name (smart-tags-file buffer-file-name)) - (message "Looking for `%s' in `%s'..." tag tags-file-name) - (condition-case () - (progn - (smart-tags-display tag next) - (message "Found definition for `%s'." tag)) - (error - (if (not smart-c-use-lib-man) - (progn (message "`%s' not found in `%s'." tag tags-file-name) - (beep)) - (message "Checking if `%s' is a C library function..." tag) - (if (smart-library-symbol tag) - (progn (message "Displaying C library man page for `%s'." tag) - (manual-entry tag)) - (message "`%s' not found in `%s' or C libraries." - tag tags-file-name) - (beep)))))))) - -;;;###autoload -(defun smart-c-at-tag-p () - "Return C tag name that point is within, else nil." - (let* ((identifier-chars "_a-zA-Z0-9") - (identifier (concat "[_a-zA-Z][" identifier-chars "]*"))) - (save-excursion - (skip-chars-backward identifier-chars) - (if (looking-at identifier) - (smart-flash-tag - (buffer-substring (point) (match-end 0)) - (point) (match-end 0)))))) - -;;;###autoload -(defun smart-c++ (&optional identifier next) - "Jumps to the definition of optional C++ IDENTIFIER or the one at point. -Optional second arg NEXT means jump to next matching C++ tag. - -It assumes that its caller has already checked that the key was pressed in an -appropriate buffer and has moved the cursor to the selected buffer. - -If: - (1) on a `#include' statement, the include file is displayed; - Look for include file in directory lists `smart-c-cpp-include-dirs' - and `smart-c-include-dirs'. - (2) on a C++ identifier, the identifier definition is displayed, - assuming the identifier is found within an `etags' generated tag file - in the current directory or any of its ancestor directories. - (3) if `smart-c-use-lib-man' is non-nil, the C++ identifier is - recognized as a library symbol, and a man page is found for the - identifier, then the man page is displayed." - - (interactive) - (if (fboundp 'c++-to-definition) - ;; Only fboundp if OO-Browser has been loaded. - (smart-c++-oo-browser) - (or - (if identifier nil (smart-c-include-file)) - (let ((tag (or identifier (smart-c++-at-tag-p)))) - ;; Set free variable tags-file-name so that next `find-tag' command uses - ;; whatever tags file is set here. - (setq tags-file-name (smart-tags-file buffer-file-name)) - (message "Looking for `%s' in `%s'..." tag tags-file-name) - (condition-case () - (progn - (smart-tags-display tag next) - (message "Found definition for `%s'." tag)) - (error - (if (not smart-c-use-lib-man) - (progn (message "`%s' not found in `%s'." tag tags-file-name) - (beep)) - (message "Checking if `%s' is a C++ library function..." tag) - (if (smart-library-symbol tag) - (progn (message "Displaying C++ library man page for `%s'." tag) - (manual-entry tag)) - (message "`%s' not found in `%s' or C++ libraries." - tag tags-file-name) - (beep))))))))) - -;;; The following should be called only if the OO-Browser is available. -(defun smart-c++-oo-browser (&optional junk) - "Jumps to the definition of selected C++ construct via OO-Browser support. -Optional JUNK is ignored. Does nothing if the OO-Browser is not available. - -It assumes that its caller has already checked that the key was pressed in an -appropriate buffer and has moved the cursor to the selected buffer. - -If key is pressed: - (1) on a `#include' statement, the include file is displayed; - Look for include file in directory lists `smart-c-cpp-include-dirs' - and `smart-c-include-dirs'. - (2) within a method declaration, its definition is displayed; - (3) on a class name, the class definition is shown. - - (2) and (3) require that an OO-Browser Environment has been loaded with - the {M-x br-env-load RET} command." - - (interactive) - (c++-to-definition t)) - -(defun smart-c++-at-tag-p () - "Return C++ tag name that point is within, else nil." - (let* ((identifier-chars "_:~<>a-zA-Z0-9") - (identifier (concat "\\([_~:<a-zA-Z][" identifier-chars "]*" - "[ \t]*[^]) \t:;.,?~{}][^[( \t:;.,~^!|?{}]?[=*]?\\)[ \t\n]*("))) - (save-excursion - (skip-chars-backward identifier-chars) - (if (looking-at identifier) - (smart-flash-tag - (buffer-substring (match-beginning 1) (match-end 1)) - (match-beginning 1) (match-end 1)))))) - -(defun smart-emacs-lisp-mode-p () - "Return t if in a mode which uses Emacs Lisp symbols." - (or (memq major-mode '(emacs-lisp-mode lisp-interaction-mode debugger-mode)) - ;; Emacs Lisp symbols appear in Help buffers frequently. - (string-match "Help\\*$" (buffer-name)))) - -(defun smart-fortran (&optional identifier next) - "Jumps to the definition of optional Fortran IDENTIFIER or the one at point. -Optional second arg NEXT means jump to next matching Fortran tag. - -It assumes that its caller has already checked that the key was pressed in an -appropriate buffer and has moved the cursor to the selected buffer. - -If on a Fortran identifier, the identifier definition is displayed, -assuming the identifier is found within an `etags' generated tag file -in the current directory or any of its ancestor directories." - (interactive) - (let ((tag (or identifier (smart-fortran-at-tag-p)))) - ;; Set free variable tags-file-name so that next `find-tag' command uses - ;; whatever tags file is set here. - (setq tags-file-name (smart-tags-file buffer-file-name)) - (message "Looking for `%s' in `%s'..." tag tags-file-name) - (condition-case () - (progn - (smart-tags-display tag next) - (message "Found definition for `%s'." tag)) - (error - (message "`%s' not found in `%s'." tag tags-file-name) - (beep))))) - -;;;###autoload -(defun smart-fortran-at-tag-p () - "Return Fortran tag name that point is within, else nil." - (let* ((identifier-chars "_a-zA-Z0-9") - (identifier (concat "[_a-zA-Z][" identifier-chars "]*"))) - (save-excursion - (skip-chars-backward identifier-chars) - (if (looking-at identifier) - (smart-flash-tag - (buffer-substring (point) (match-end 0)) - (point) (match-end 0)))))) - -;;;###autoload -(defun smart-java (&optional identifier next) - "Jumps to the definition of optional Java IDENTIFIER or the one at point. -Optional second arg NEXT means jump to next matching Java tag. - -It assumes that its caller has already checked that the key was pressed in an -appropriate buffer and has moved the cursor to the selected buffer. - -If: - (1) within a commented @see cross-reference, the referent is displayed; - (2) on a `package' or `import' statement, the referent is displayed; - Look for referent files in the directory list `smart-java-package-dirs'. - (3) on an Java identifier, the identifier definition is displayed, - assuming the identifier is found within an `etags' generated tag file - in the current directory or any of its ancestor directories." - - (interactive) - (if (fboundp 'java-to-definition) - ;; Only fboundp if OO-Browser has been loaded. - (smart-java-oo-browser) - (or - (if identifier nil (or (smart-java-cross-reference) (smart-java-packages))) - (let ((tag (or identifier (smart-java-at-tag-p)))) - ;; Set free variable tags-file-name so that next `find-tag' command uses - ;; whatever tags file is set here. - (setq tags-file-name (smart-tags-file buffer-file-name)) - (message "Looking for `%s' in `%s'..." tag tags-file-name) - (condition-case () - (progn - (smart-tags-display tag next) - (message "Found definition for `%s'." tag)) - (error (progn (message "`%s' not found in `%s'." tag tags-file-name) - (beep)))))))) - -;;; The following should be called only if the OO-Browser is available. -(defun smart-java-oo-browser (&optional junk) - "Jumps to the definition of selected Java construct via OO-Browser support. -Optional JUNK is ignored. Does nothing if the OO-Browser is not available. - -It assumes that its caller has already checked that the key was pressed in an -appropriate buffer and has moved the cursor to the selected buffer. - -If key is pressed: - (1) within a commented @see cross-reference, the referent is displayed; - (2) on a `package' or `import' statement, the referent is displayed; - Look for referent files in the directory list `smart-java-package-dirs'. - (3) within a method declaration, its definition is displayed; - (4) on a class name, the class definition is shown." - - (interactive) - (or (smart-java-cross-reference) - (smart-java-packages) - (java-to-definition t))) - -;;;###autoload -(defun smart-java-at-tag-p () - "Return Java tag name that point is within, else nil." - (let* ((identifier-chars "_$.a-zA-Z0-9") - (identifier - (concat "[_$a-zA-Z][" identifier-chars "]*"))) - (save-excursion - (skip-chars-backward identifier-chars) - (if (looking-at identifier) - (smart-flash-tag - (buffer-substring (point) (match-end 0)) - (point) (match-end 0)))))) - -(defun smart-lisp (&optional next) - "Jumps to the definition of any selected Lisp construct. -If on an Emacs Lisp require, load, or autoload clause and `find-library' -from load-library package by Hallvard Furuseth (hallvard@ifi.uio.no) has -been loaded, jumps to library source, if possible. - -Otherwise, the construct must be found within an `etags' generated tag file -in the current directory or any of its ancestor directories in order for its -definition to be located. - -Optional NEXT means jump to next matching Lisp tag. When matching to an Emacs -Lisp tag using `wtags' (Bob Weiner's personal modifications to `etags'), -there is no next tag, so display documentation for current tag instead. - -This command assumes that its caller has already checked that the key was -pressed in an appropriate buffer and has moved the cursor to the selected -buffer." - - (interactive) - ;; Handle `require', `load', and `autoload' clauses in Emacs Lisp. - (or (and (fboundp 'find-library) - (smart-emacs-lisp-mode-p) - (let ((req) - (opoint (point))) - (setq req (and (search-backward "\(" nil t) - (looking-at (concat - "(\\(require\\|load\\|autoload\\)" - "[ \t]+.*['\"]" - "\\([^][() \t\n\^M`'\"]+\\)")))) - (goto-char opoint) - (if req (progn - (setq req (buffer-substring (match-beginning 2) - (match-end 2))) - (hpath:display-buffer (current-buffer)) - (find-library req) - t)))) - (let ((tag (smart-lisp-at-tag-p))) - ;; Set free variable tags-file-name so that next `find-tag' command - ;; uses whatever tags file is set here. - (setq tags-file-name (smart-tags-file default-directory)) - ;; This part only works properly for Emacs Lisp, so is conditionalized. - (if (and next (smart-emacs-lisp-mode-p) (featurep 'wtags)) - (progn (setq tag (intern tag)) - (cond ((fboundp tag) (describe-function tag)) - ((boundp tag) (describe-variable tag)) - (t (error "(smart-lisp): Unbound symbol: %s" tag)))) - (condition-case () - (smart-tags-display tag next) - (error (if (equal tags-file-name smart-emacs-tags-file) - (progn (message "`%s' not found in `%s'." - tag tags-file-name) - (beep)) - (setq tags-file-name smart-emacs-tags-file) - (smart-tags-display tag next)))))))) - -(defun smart-lisp-at-tag-p () - "Returns Lisp tag name that point is within, else nil. -Returns nil when point is within a Lisp `def' keyword." - (let* ((identifier-chars "-_*:+%$#!<>a-zA-Z0-9") - (identifier (concat "[-<*a-zA-Z][" identifier-chars "]*")) - (opoint (point))) - (save-excursion - (beginning-of-line) - (if (and (looking-at "\\(;*[ \t]*\\)?(def[^- \n\t]+") - (< opoint (match-end 0))) - nil - (goto-char opoint) - (skip-chars-backward identifier-chars) - (if (looking-at identifier) - (smart-flash-tag - (buffer-substring (point) (match-end 0)) - (point) (match-end 0))))))) - -;;;###autoload -(defun smart-lisp-mode-p () - "Return t if in a mode which uses Lisp symbols." - (or (smart-emacs-lisp-mode-p) - (memq major-mode '(lisp-mode scheme-mode)))) - -;;;###autoload -(defun smart-objc (&optional identifier next) - "Jumps to the definition of optional Objective-C IDENTIFIER or the one at point. -Optional second arg NEXT means jump to next matching Objective-C tag. - -It assumes that its caller has already checked that the key was pressed in an -appropriate buffer and has moved the cursor to the selected buffer. - -If: - (1) on a `#include' statement, the include file is displayed; - Look for include file in directory lists `smart-c-cpp-include-dirs' - and `smart-c-include-dirs'. - (2) on an Objective-C identifier, the identifier definition is displayed, - assuming the identifier is found within an `etags' generated tag file - in the current directory or any of its ancestor directories. - (3) if `smart-c-use-lib-man' is non-nil, the Objective-C identifier is - recognized as a library symbol, and a man page is found for the - identifier, then the man page is displayed." - - (interactive) - - (if (fboundp 'objc-to-definition) - ;; Only fboundp if OO-Browser has been loaded. - (smart-objc-oo-browser) - (or - (if identifier nil (smart-c-include-file)) - (let ((tag (or identifier (smart-objc-at-tag-p)))) - ;; Set free variable tags-file-name so that next `find-tag' command uses - ;; whatever tags file is set here. - (setq tags-file-name (smart-tags-file buffer-file-name)) - (message "Looking for `%s' in `%s'..." tag tags-file-name) - (condition-case () - (progn - (smart-tags-display tag next) - (message "Found definition for `%s'." tag)) - (error - (if (not smart-c-use-lib-man) - (progn (message "`%s' not found in `%s'." tag tags-file-name) - (beep)) - (message - "Checking if `%s' is an Objective-C library function..." tag) - (if (smart-library-symbol tag) - (progn - (message - "Displaying Objective-C library man page for `%s'." tag) - (manual-entry tag)) - (message "`%s' not found in `%s' or Objective-C libraries." - tag tags-file-name) - (beep))))))))) - -;;; The following should be called only if the OO-Browser is available. -(defun smart-objc-oo-browser (&optional junk) - "Jumps to the definition of selected Objective-C construct via OO-Browser support. -Optional JUNK is ignored. Does nothing if the OO-Browser is not available. - -It assumes that its caller has already checked that the key was pressed in an -appropriate buffer and has moved the cursor to the selected buffer. - -If key is pressed: - (1) on a `#include' statement, the include file is displayed; - Look for include file in directory lists `smart-c-cpp-include-dirs' - and `smart-c-include-dirs'. - (2) within a method declaration, its definition is displayed; - (3) on a class name, the class definition is shown. - - (2) and (3) require that an OO-Browser Environment has been loaded with - the {M-x br-env-load RET} command." - - (interactive) - (objc-to-definition t)) - -(defun smart-objc-at-tag-p () - "Return Objective-C tag name that point is within, else nil." - (let* ((identifier-chars "_a-zA-Z0-9") - (identifier - (concat "\\([-+][ \t]*\\)?\\([_a-zA-Z][" identifier-chars "]*\\)"))) - (save-excursion - (skip-chars-backward identifier-chars) - (if (looking-at identifier) - (smart-flash-tag - (buffer-substring (match-beginning 2) (match-end 2)) - (match-beginning 2) (match-end 2)))))) - -;;; ************************************************************************ -;;; Private functions -;;; ************************************************************************ - -(defun smart-asm-include-file () - "If point is on an include file line, tries to display file. -Returns non-nil iff on an include file line, even if file is not found. -Look for include file in `smart-asm-include-dirs' and add suffix \".ins\" or -\".inc\" to filename if it lacks a suffix." - (let ((opoint (point))) - ;; Some assemblers utilize the C preprocessor, so try that first. - (cond ((smart-c-include-file)) - ((progn (beginning-of-line) - (looking-at smart-asm-include-regexp)) - (let ((file (buffer-substring (match-beginning 2) (match-end 2))) - (path) - (dir-list smart-asm-include-dirs)) - (goto-char opoint) - (setq dir-list (cons (file-name-directory buffer-file-name) - dir-list)) - (if (string-match "\\." file) - (setq file (regexp-quote file)) - (setq file (concat (regexp-quote file) "\\.in[sc]$"))) - (while dir-list - (setq dir-list - (if (setq path (car (directory-files - (car dir-list) t file))) - nil - (cdr dir-list)))) - ;; - ;; If path exists, display file - ;; - (if path - (if (and (file-readable-p path) - (progn - (hpath:find path) - (cond ((featurep 'asm-mode) t) - ((load "asm-mode" nil 'nomessage) - (provide 'asm-mode)) - (t - (beep) - (message - "(smart-asm-include-file): asm-mode undefined.") - nil - )))) - nil - (beep) - (message "(smart-asm-include-file): `%s' unreadable." path)) - (beep) - (message "(smart-asm-include-file): `%s' not found." file)) - path)) - ;; not on an include file line - (t (goto-char opoint) - nil)))) - - -(defun smart-c-include-file () - "If point is on an include file line, tries to display file. -Returns non-nil iff on an include file line, even if file is not found. -Look for include file in `smart-c-cpp-include-dirs' and in directory list -`smart-c-include-dirs'." - (let ((opoint (point))) - (beginning-of-line) - (if (looking-at smart-c-include-regexp) - (let ((incl-type (string-to-char - (buffer-substring (match-beginning 2) - (1+ (match-beginning 2))))) - (file (buffer-substring (match-beginning 3) (match-end 3))) - (path) - (dir-list smart-c-include-dirs) - (found)) - (goto-char opoint) - (setq dir-list (if (= incl-type ?<) - (append dir-list smart-c-cpp-include-dirs) - (cons (file-name-directory buffer-file-name) - dir-list))) - (while dir-list - (setq path (expand-file-name file (car dir-list)) - dir-list (if (setq found (file-exists-p path)) - nil - (cdr dir-list)))) - ;; - ;; If found, display file - ;; - (if found - (if (and (file-readable-p path) - (progn - (hpath:find path) - (cond ((or (featurep 'cc-mode) - (featurep 'c-mode)) - t) - ((or (load "cc-mode" 'missing-ok 'nomessage) - (load "c-mode" 'missing-ok 'nomessage)) - (provide 'c-mode)) - (t - (beep) - (message - "(smart-c-include-file): c-mode undefined.") - nil - )))) - nil - (beep) - (message "(smart-c-include-file): `%s' unreadable." path)) - (beep) - (message "(smart-c-include-file): `%s' not found." file)) - path) - (goto-char opoint) - nil))) - -(defun smart-flash-tag (tag start end) - "Tries to flash TAG at START to END in buffer, to indicate that it is serving as a hyperlink button. -Returns TAG." - ;; Button flashing code might not yet have been loaded if the whole - ;; Hyperbole system has not been started. - (if (fboundp 'hui:but-flash) - (progn - (ibut:label-set tag start end) - (hui:but-flash))) - tag) - -(defun smart-java-cross-reference () - "If within a Java @see comment, displays the associated definition for editing and returns non-nil, else nil. -Non-nil is returned even if the @see referent cannot be found. - -Does nothing if the `oo-browser' command is undefined, since it requires that -package for class and feature lookups." - ;; - ;; Valid forms of @see cross-references are: - ;; * @see #getComponent - current class attribute - ;; * @see #waitForAll() - current class method, no arguments - ;; * @see #checkID(int, boolean) - current class method, with arguments - ;; * @see java.awt.ColorModel#getRGBdefault - library class method - ;; * @see Component#paintAll - class method - ;; * @see java.awt.GridBagLayout - library class - ;; * @see Container - class - ;; - ;; For simplicity sake, this code ignores the library path given with any - ;; class in favor of the OO-Browser's lookup tables. It also ignores any - ;; parameters associated with a method, and thus cannot distinguish between - ;; methods with the same name within a single class, which we believe to be - ;; fairly bad form anyway. - ;; - (let ((opoint (point))) - (if (and (eq major-mode 'java-mode) buffer-file-name - (fboundp 'br-env-load) - (or (looking-at "@see[ \t]+") - (and (re-search-backward "[@\n\r\f]" nil t) - (looking-at "@see[ \t]+")))) - (let ((class) (feature)) - ;; Ignore any library path preceding a classname (grouping 1) - (cond - ((looking-at - "@see[ \t]+\\(#\\)?\\([^][(){} \t\n\r\f#]+[.]\\)?\\([^][(){} \t\n\r\f#.]+\\)[][(){} \t\n\r\f]") - (if (match-beginning 1) - (setq class nil - feature (buffer-substring (match-beginning 3) - (match-end 3))) - (setq class (buffer-substring (match-beginning 3) (match-end 3)) - feature nil))) - ((looking-at - "@see[ \t]+\\([^][(){} \t\n\r\f#]+[.]\\)?\\([^][(){} \t\n\r\f#.]+\\)#\\([^][(){} \t\n\r\f#.]+\\)") - (setq class (buffer-substring (match-beginning 2) - (match-end 2)) - feature (buffer-substring (match-beginning 3) - (match-end 3))))) - ;; Return to original point. - (goto-char opoint) - ;; Lookup class / feature. - (cond - ((and (null class) (null feature)) - ;; Invalid or unrecognized @see format, so ignore. - (message "(smart-java-cross-reference): Invalid @see cross-reference format.") - (beep) - t) - ;; Ensure that a Java OO-Browser environment has been loaded. - (t (if (or (and (boundp 'br-lang-prefix) - (equal br-lang-prefix "java-") - (boundp 'br-env-file) (stringp br-env-file) - (null br-env-spec)) - ;; Load an existing Environment based on current - ;; buffer or prompt to build one. This also - ;; loads the "br-java.el" library in which the - ;; `java-class-def-regexp' variable used below - ;; is defined. - (and (br-env-load - (smart-tags-file - buffer-file-name - (if (boundp 'br-env-default-file) - br-env-default-file "OOBR"))) - (equal br-lang-prefix "java-"))) - (cond ((null feature) - (br-edit nil class)) - (t - (if (null class) - (if (save-excursion - (or (re-search-backward java-class-def-regexp nil t) - (re-search-forward java-class-def-regexp nil t))) - (setq class (buffer-substring - (match-beginning java-class-def-name-grpn) - (match-end java-class-def-name-grpn))) - (error "(smart-java-cross-reference): This @see must be in a class definition."))) - (br-edit-feature class feature t))) - (error "(smart-java-cross-reference): The OO-Browser failed to load a Java environment."))))) - ;; Return to original point. - (goto-char opoint) - nil))) - -(defun smart-java-library-path (library-name) - "Search up directory tree from current directory for a match to LIBRARY-NAME." - (let ((path default-directory) - (library-path) - (library-regexp (if (string-match "\\.\\|'//" library-name) - (regexp-quote - (concat (file-name-as-directory "") - (substring library-name 0 (match-beginning 0)) - (file-name-as-directory ""))))) - (start 0)) - ;; Return rightmost match to first part of library-name. - (if library-regexp - (while (string-match library-regexp path start) - (setq start (1+ (match-beginning 0)) - library-path (substring path 0 (match-beginning 0))))) - library-path)) - -(defun smart-java-packages () - "If point is on a `package' or `import' line, this tries to display the associated referent. -Returns non-nil iff on such a line, even if the referent is not found. -Look for packages in `smart-java-package-dirs'." - (let ((opoint (point))) - (beginning-of-line) - (if (looking-at smart-java-package-regexp) - (let ((keyword-type (buffer-substring - (match-beginning 1) (match-end 1))) - (referent (buffer-substring (match-beginning 2) (match-end 2))) - (found) - (subpath) - dir-list path subfile) - (goto-char opoint) - (if (string-equal keyword-type "package") - (let ((library-path (smart-java-library-path referent))) - (if library-path - (hpath:find (expand-file-name - (hypb:replace-match-string - "\\." referent (file-name-as-directory "") t) - library-path)) - ;; Show the current directory, which should contain this package. - (hpath:find default-directory))) - ;; This is an `import' statement. If it includes a *, show the - ;; associated library directory, otherwise, show the specific - ;; package. - (if (string-match "\\.\\*" referent) - (setq subfile (substring referent 0 (match-beginning 0)) - subfile (hypb:replace-match-string - "\\." subfile (file-name-as-directory "") t)) - (setq subpath (hypb:replace-match-string - "\\." referent (file-name-as-directory "") t) - subfile (concat subpath ".java"))) - ;; - ;; Try to find the path containing referent. - ;; - ;; Search up the current directory tree for a possible matching - ;; directory below which the referent library might live and add - ;; this to smart-java-package-dirs for searching. - (let ((library-path (smart-java-library-path referent))) - (if library-path - (setq dir-list (cons library-path smart-java-package-dirs)))) - - (while dir-list - (setq path (expand-file-name subfile (car dir-list)) - dir-list (if (setq found (file-exists-p path)) - nil - (cdr dir-list)))) - (if (and (not found) subpath hyperb:microcruft-os-p) - ;; Try .jav suffix. - (progn (setq subfile (concat subpath ".jav") - dir-list smart-java-package-dirs) - (while dir-list - (setq path (expand-file-name subfile (car dir-list)) - dir-list (if (setq found (file-exists-p path)) - nil - (cdr dir-list)))))) - ;; - ;; If found, display file - ;; - (if found - (if (file-readable-p path) - (hpath:find path) - (beep) - (message "(smart-java-packages): `%s' unreadable." path)) - (beep) - (message "(smart-java-packages): `%s' not found." referent)) - path)) - (goto-char opoint) - nil))) - -(defun smart-library-symbol (tag) - "Return non-nil if TAG is a library symbol listed in cache of such symbols. -See the \"${hyperb:dir}/smart-clib-sym\" script for more information." - (let ((buf (get-buffer-create "*junk*")) - (found)) - (save-excursion - (set-buffer buf) - (setq buffer-read-only nil) - (erase-buffer) - (call-process (expand-file-name "smart-clib-sym" hyperb:dir) - nil buf nil tag) - (setq found (string-equal (buffer-substring 1 2) "1")) - (set-buffer-modified-p nil) - (kill-buffer buf) - found))) - -(defun smart-tags-display (tag next) - (if next (setq tag nil)) - (let ((func (or (if (fboundp 'find-tag-internal) 'find-tag-internal) - (if (fboundp 'find-tag-noselect) 'find-tag-noselect))) - ;; For XEmacs - (tags-always-exact t) - ;; For Emacs 19 - (find-tag-tag-order (if (boundp 'find-tag-tag-order) - find-tag-tag-order))) - (if find-tag-tag-order - (if next nil (setq find-tag-tag-order '(tag-exact-match-p))) - ;; For InfoDock (XEmacs may also take this branch), force exact match. - (if (stringp tag) (setq tag (list tag)))) - (if (and func (funcall func tag)) - (hpath:display-buffer (current-buffer))) - ;; Signals an error if tag is not found which is caught by many callers - ;; of this function. - (find-tag tag))) - -;;;###autoload -(defun smart-tags-file-path (file) - "Expand relative FILE name by looking it up in the nearest tags file. -Return FILE unchanged if it exists relative to the current directory or -cannot be expanded via a tags file." - (or (cond ((or (file-exists-p file) (file-name-absolute-p file)) file) - (t (let ((tags-file (smart-tags-file default-directory)) - (file-regexp - (concat "\^L\n\\(.*/\\)?" (regexp-quote file) ","))) - (if tags-file - (progn - (set-buffer (find-file-noselect tags-file)) - (goto-char (point-min)) - (if (re-search-forward file-regexp nil t) - (expand-file-name - (buffer-substring (1- (match-end 0)) - (progn (beginning-of-line) - (point)))))))))) - file)) - -;;;###autoload -(defun smart-tags-file (curr-filename &optional name-of-tags-file) - "Return appropriate tags file name for CURR-FILENAME or `tags-file-name'. -Optional NAME-OF-TAGS-FILE is the literal filename for which to look." - (let ((path curr-filename) - (tags-file)) - (while (and - (stringp path) - (setq path (file-name-directory path)) - (setq path (directory-file-name path)) - ;; Not at root directory - (not (string-match ":?/\\'" path)) - ;; No tags file - (not (file-exists-p - (setq tags-file (expand-file-name (or name-of-tags-file "TAGS") path))))) - (setq tags-file nil)) - (if (and (not tags-file) - (stringp curr-filename) - (smart-emacs-lisp-mode-p) - (let ((path (file-name-directory curr-filename))) - (delq nil (mapcar - (function - (lambda (p) - (and p (equal (file-name-as-directory p) - path)))) - load-path)))) - (setq tags-file smart-emacs-tags-file)) - (or tags-file tags-file-name - (call-interactively 'visit-tags-table)))) - -;;; ************************************************************************ -;;; Private variables -;;; ************************************************************************ - -(provide 'hmouse-tag)
--- a/lisp/hyperbole/hpath.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,761 +0,0 @@ -;;!emacs -;; -;; FILE: hpath.el -;; SUMMARY: Hyperbole support routines for handling UNIX paths. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: comm, hypermedia, unix -;; -;; AUTHOR: Bob Weiner -;; ORG: InfoDock Associates -;; -;; ORIG-DATE: 1-Nov-91 at 00:44:23 -;; LAST-MOD: 20-Mar-97 at 11:52:51 by Bob Weiner - -;;; ************************************************************************ -;;; Public variables -;;; ************************************************************************ - -(defvar hpath:rfc "/anonymous@ds.internic.net:rfc/rfc%s.txt" - "*String to be used in the call: (hpath:rfc rfc-num) -to create an path to the RFC document for `rfc-num'.") - -(defvar hpath:suffixes '(".gz" ".Z") - "*List of filename suffixes to add or remove within (hpath:exists-p) calls.") - -(defvar hpath:tmp-prefix "/tmp/remote-" - "*Pathname prefix to attach to remote files copied locally for use with external viewers.") - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -(defun hpath:absolute-to (path &optional default-dirs) - "Returns PATH as an absolute path relative to one directory from optional DEFAULT-DIRS or `default-directory'. -Returns PATH unchanged when it is not a valid path or when DEFAULT-DIRS -is invalid. DEFAULT-DIRS when non-nil may be a single directory or a list of -directories. The first one in which PATH is found is used." - (if (not (and (stringp path) (hpath:is-p path nil t))) - path - (if (not (cond ((null default-dirs) - (setq default-dirs (cons default-directory nil))) - ((stringp default-dirs) - (setq default-dirs (cons default-dirs nil))) - ((listp default-dirs)) - (t nil))) - path - (let ((rtn) dir) - (while (and default-dirs (null rtn)) - (setq dir (expand-file-name - (file-name-as-directory (car default-dirs))) - rtn (expand-file-name path dir) - default-dirs (cdr default-dirs)) - (or (file-exists-p rtn) (setq rtn nil))) - (or rtn path))))) - -(defun hpath:ange-ftp-at-p () - "Returns an ange-ftp pathname that point is within or nil. -See the `ange-ftp' or `efs' Elisp packages for pathname format details. -Always returns nil if (hpath:ange-ftp-available-p) returns nil." - (if (hpath:ange-ftp-available-p) - (let ((user (hpath:ange-ftp-default-user)) - path) - (setq path - (save-excursion - (skip-chars-backward "^[ \t\n\"`'\(\{<") - (cond - ((hpath:url-at-p) - (if (string-equal - (buffer-substring (match-beginning 2) (match-end 2)) - "ftp") - (concat - "/" - ;; user - (if (match-beginning 3) - (buffer-substring - (match-beginning 3) (match-end 3)) - (concat user "@")) - ;; domain - (hpath:delete-trailer - (buffer-substring (match-beginning 4) (match-end 4))) - ":" - ;; path - (if (match-beginning 6) - (buffer-substring (match-beginning 6) - (match-end 6)))) - ;; else ignore this other type of WWW path - )) - ;; user, domain and path - ((looking-at "/?[^/:@ \t\n\^M\"`']+@[^/:@ \t\n\^M\"`']+:[^]@ \t\n\^M\"`'\)\}]*") - (buffer-substring (match-beginning 0) (match-end 0))) - ;; @domain and path - ((looking-at "@[^/:@ \t\n\^M\"`']+:[^]@ \t\n\^M\"`'\)\}]*") - (concat "/" user (buffer-substring - (match-beginning 0) (match-end 0)))) - ;; domain and path - ((and (looking-at - "/?\\(\\([^/:@ \t\n\^M\"`']+\\):[^]@:, \t\n\^M\"`'\)\}]*\\)[] \t\n\^M,.\"`'\)\}]") - (setq path (buffer-substring - (match-beginning 1) (match-end 1))) - (string-match "[^.]\\.[^.]" - (buffer-substring (match-beginning 2) - (match-end 2)))) - (concat "/" user "@" path)) - ;; host and path - ((and (looking-at - "/\\([^/:@ \t\n\^M\"`']+:[^]@:, \t\n\^M\"`'\)\}]*\\)") - (setq path (buffer-substring - (match-beginning 1) (match-end 1)))) - (concat "/" user "@" path)) - ))) - (hpath:delete-trailer path)))) - -(defun hpath:ange-ftp-p (path) - "Returns non-nil iff PATH is an ange-ftp pathname. -See the `ange-ftp' or `efs' Elisp package for pathname format details. -Always returns nil if (hpath:ange-ftp-available-p) returns nil." - (and (stringp path) - (or (featurep 'ange-ftp) (featurep 'efs)) - (let ((user (hpath:ange-ftp-default-user)) - result) - (setq result - (cond - ((hpath:url-p path) - (if (string-equal - (substring path (match-beginning 2) (match-end 2)) - "ftp") - (concat - "/" - ;; user - (if (match-beginning 3) - (substring path (match-beginning 3) (match-end 3)) - (concat user "@")) - ;; domain - (hpath:delete-trailer - (substring path (match-beginning 4) (match-end 4))) - ":" - ;; path - (if (match-beginning 6) - (substring path (match-beginning 6) - (match-end 6)))) - ;; else ignore this other type of WWW path - )) - ;; user, domain and path - ((string-match "/?[^/:@ \t\n\^M\"`']+@[^/:@ \t\n\^M\"`']+:[^]@ \t\n\^M\"`'\)\}]*" - path) - (substring path (match-beginning 0) (match-end 0))) - ;; @domain and path - ((string-match "@[^/:@ \t\n\^M\"`']+:[^]@ \t\n\^M\"`'\)\}]*" - path) - (concat "/" user - (substring path (match-beginning 0) (match-end 0)))) - ;; domain and path - ((and (string-match - "/?\\(\\([^/:@ \t\n\^M\"`']+\\):[^]@:, \t\n\^M\"`'\)\}]*\\)" - path) - (setq result (substring path - (match-beginning 1) (match-end 1))) - (string-match "[^.]\\.[^.]" - (substring path (match-beginning 2) - (match-end 2)))) - (concat "/" user "@" result)) - ;; host and path - ((and (string-match - "/\\([^/:@ \t\n\^M\"`']+:[^]@:, \t\n\^M\"`'\)\}]*\\)" - path) - (setq result (substring - path - (match-beginning 1) (match-end 1)))) - (concat "/" user "@" result)) - )) - (hpath:delete-trailer result)))) - -(defun hpath:at-p (&optional type non-exist) - "Returns delimited path or non-delimited ange-ftp path at point, if any. -World wide web urls are treated as non-paths so they are handled elsewhere. -Delimiters may be: double quotes, open and close single quote, or -Texinfo file references. -If optional TYPE is the symbol 'file or 'directory, then only that path type is -accepted as a match. Only locally reachable paths are checked for existence. -With optional NON-EXIST, nonexistent local paths are allowed. -Absolute pathnames must begin with a `/' or `~'. Relative pathnames -must begin with a `./' or `../' to be recognized." - (cond (;; Local file URLs - (hpath:is-p (hargs:delimited - "file://localhost" "[ \t\n\^M\"\'\}]" nil t))) - ((hpath:ange-ftp-at-p)) - ((hpath:www-at-p) nil) - ((hpath:is-p (or (hargs:delimited "\"" "\"") - ;; Filenames in Info docs - (hargs:delimited "\`" "\'") - ;; Filenames in TexInfo docs - (hargs:delimited "@file{" "}")) - type non-exist)))) - -(defun hpath:display-buffer (buffer &optional display-where) - "Displays BUFFER at optional DISPLAY-WHERE location or at hpath:display-where. -BUFFER may be a buffer or a buffer name. - -See documentation of `hpath:display-buffer-alist' for valid values of DISPLAY-WHERE. -Returns non-nil iff buffer is actually displayed." - (interactive "bDisplay buffer: ") - (if (stringp buffer) (setq buffer (get-buffer buffer))) - (if (null buffer) - nil - (if (null display-where) - (setq display-where hpath:display-where)) - (funcall (car (cdr (or (assq display-where - hpath:display-buffer-alist) - (assq 'other-window - hpath:display-buffer-alist)))) - buffer) - t)) - -(defun hpath:display-buffer-other-frame (buffer) - "Displays BUFFER, in another frame. -May create a new frame, or reuse an existing one. -See documentation of `hpath:display-buffer' for details. -Returns the dispalyed buffer." - (interactive "bDisplay buffer in other frame: ") - (if (= (length (frame-list)) 1) - (select-frame (make-frame)) - (other-frame 1)) - (if (br-in-browser) - (br-to-view-window)) - (switch-to-buffer buffer)) - -(defun hpath:find (filename &optional display-where) - "Edits file FILENAME using user customizable settings of display program and location. - -FILENAME may start with a special prefix character which is -handled as follows: - !filename - execute as a non-windowed program within a shell; - &filename - execute as a windowed program; - -filename - load as an Emacs Lisp program. - -Otherwise, if FILENAME matches a regular expression in the variable -`hpath:find-alist,' the associated external display program is invoked. -If not, `hpath:display-alist' is consulted for a specialized internal -display function to use. If no matches are found there, -`hpath:display-where-alist' is consulted using the optional argument, -DISPLAY-WHERE (a symbol) or if that is nil, the value of -`hpath:display-where', and the matching display function is used. -Returns non-nil iff file is displayed within a buffer (not with an external -program)." - (interactive "FFind file: ") - (let (modifier) - (if (string-match hpath:prefix-regexp filename) - (setq modifier (aref filename 0) - filename (substring filename (match-end 0)))) - (setq filename (hpath:substitute-value filename)) - (cond (modifier (cond ((eq modifier ?!) - (hact 'exec-shell-cmd filename)) - ((eq modifier ?&) - (hact 'exec-window-cmd filename)) - ((eq modifier ?-) - (load filename))) - nil) - (t (let ((find-program (hpath:find-program filename))) - (cond ((stringp find-program) - (hact 'exec-window-cmd find-program) - nil) - ((hypb:functionp find-program) - (funcall find-program filename) - t) - (t (setq filename (hpath:validate filename)) - (if (null display-where) - (setq display-where hpath:display-where)) - (funcall (car (cdr (or (assq display-where - hpath:display-where-alist) - (assq 'other-window - hpath:display-where-alist)))) - filename) - t))))))) - -(defun hpath:find-line (filename line-num &optional display-where) - "Edits file FILENAME with point placed at LINE-NUM. - -`hpath:display-where-alist' is consulted using the optional argument, -DISPLAY-WHERE (a symbol) or if that is nil, the value of -`hpath:display-where', and the matching display function is used to determine -where to display the file, e.g. in another frame. -Always returns t." - (interactive "FFind file: ") - ;; Just delete any special characters preceding the filename, ignoring them. - (if (string-match hpath:prefix-regexp filename) - (setq filename (substring filename (match-end 0)))) - (setq filename (hpath:substitute-value filename) - filename (hpath:validate filename)) - (if (null display-where) - (setq display-where hpath:display-where)) - (funcall (car (cdr (or (assq display-where - hpath:display-where-alist) - (assq 'other-window - hpath:display-where-alist)))) - filename) - (if (integerp line-num) - (progn (widen) (goto-line line-num))) - t) - -(defun hpath:find-other-frame (filename) - "Edits file FILENAME, in another frame. -May create a new frame, or reuse an existing one. -See documentation of `hpath:find' for details. -Returns the buffer of displayed file." - (interactive "FFind file in other frame: ") - (if (= (length (frame-list)) 1) - (select-frame (make-frame)) - (other-frame 1)) - (if (br-in-browser) - (br-to-view-window)) - (find-file filename)) - -(defun hpath:find-other-window (filename) - "Edits file FILENAME, in another window or using an external program. -May create a new window, or reuse an existing one; see the function display-buffer. -See documentation of `hpath:find' for details. -Returns non-nil iff file is displayed within a buffer." - (interactive "FFind file in other window: ") - (hpath:find filename 'other-window)) - -(defun hpath:is-p (path &optional type non-exist) - "Returns PATH if PATH is a Unix path, else nil. -If optional TYPE is the symbol 'file or 'directory, then only that path type -is accepted as a match. The existence of the path is checked only for -locally reachable paths (Info paths are not checked). Single spaces are -permitted in middle of existing pathnames, but not at the start or end. Tabs -and newlines are converted to space before the pathname is checked, this -normalized path form is what is returned for PATH. With optional NON-EXIST, -nonexistent local paths are allowed." - (let ((rtn-path path) - (suffix)) - (and (stringp path) - ;; Path may be a link reference with other components other than a - ;; pathname. These components always follow a comma, so strip them, - ;; if any, before checking path. - (if (string-match "[ \t\n\^M]*," path) - (setq rtn-path (concat (substring path 0 (match-beginning 0)) - "%s" (substring path (match-beginning 0))) - path (substring path 0 (match-beginning 0))) - (setq rtn-path (concat rtn-path "%s"))) - (if (string-match hpath:prefix-regexp path) - (setq path (substring path (match-end 0))) - t) - (not (or (string-equal path "") - (string-match "\\`\\s \\|\\s \\'" path))) - ;; Convert tabs and newlines to space. - (setq path (hbut:key-to-label (hbut:label-to-key path))) - (or (not (string-match "[()]" path)) - (string-match "\\`([^ \t\n\^M\)]+)[ *A-Za-z0-9]" path)) - (if (string-match "\\${[^}]+}" path) - (setq path (hpath:substitute-value path)) - t) - (not (string-match "[\t\n\^M\"`'{}|\\]" path)) - (or (not (hpath:www-p path)) - (string-match "^ftp:" path)) - (let ((remote-path (string-match "@.+:\\|^/.+:\\|.+:/" path))) - (if (cond (remote-path - (cond ((eq type 'file) - (not (string-equal "/" (substring path -1)))) - ((eq type 'directory) - (string-equal "/" (substring path -1))) - (t))) - ((or (and non-exist - (or - ;; Info or ange-ftp path, so don't check for. - (string-match "[()]" path) - (hpath:ange-ftp-p path) - (setq suffix (hpath:exists-p path t)) - ;; Don't allow spaces in non-existent - ;; pathnames. - (not (string-match " " path)))) - (setq suffix (hpath:exists-p path t))) - (cond ((eq type 'file) - (not (file-directory-p path))) - ((eq type 'directory) - (file-directory-p path)) - (t))) - ) - (progn - ;; Quote any but last %s within rtn-path. - (setq rtn-path (hypb:replace-match-string "%s" rtn-path "%%s") - rtn-path (hypb:replace-match-string "%%s\\'" rtn-path "%s")) - ;; Return path if non-nil return value. - (if (stringp suffix);; suffix could = t, which we ignore - (if (string-match - (concat (regexp-quote suffix) "%s") rtn-path) - ;; remove suffix - (concat (substring rtn-path 0 (match-beginning 0)) - (substring rtn-path (match-end 0))) - ;; add suffix - (format rtn-path suffix)) - (format rtn-path "")))))))) - -(defun hpath:relative-to (path &optional default-dir) - "Returns PATH relative to optional DEFAULT-DIR or `default-directory'. -Returns PATH unchanged when it is not a valid path." - (if (not (and (stringp path) (hpath:is-p path))) - path - (setq default-dir - (expand-file-name - (file-name-as-directory (or default-dir default-directory))) - path (expand-file-name path)) - (and path default-dir - (if (string-equal "/" default-dir) - path - (let ((end-dir (min (length path) (length default-dir)))) - (cond - ((string-equal (substring path 0 end-dir) default-dir) - (concat "./" (substring path end-dir))) - ((progn (setq default-dir (file-name-directory (directory-file-name default-dir)) - end-dir (min (length path) (length default-dir))) - (string-equal (substring path 0 end-dir) default-dir)) - (concat "../" (substring path end-dir))) - ((progn (setq default-dir (file-name-directory (directory-file-name default-dir)) - end-dir (min (length path) (length default-dir))) - (string-equal (substring path 0 end-dir) default-dir)) - (concat "../../" (substring path end-dir))) - (t path))))))) - -(defun hpath:rfc (rfc-num) - "Return pathname to textual rfc document indexed by RFC-NUM. -See the documentation of the `hpath:rfc' variable." - (format hpath:rfc rfc-num)) - -(defun hpath:substitute-value (path) - "Substitutes matching value for Emacs Lisp variables and environment variables in PATH. -Returns path with variable values substituted." - (substitute-in-file-name - (hypb:replace-match-string - "\\${[^}]+}" - path - (function - (lambda (str) - (let* ((var-group (substring path match start)) - (var-name (substring path (+ match 2) (1- start))) - (rest-of-path (substring path start)) - (sym (intern-soft var-name))) - (if (file-name-absolute-p rest-of-path) - (setq rest-of-path (substring rest-of-path 1))) - (if (and sym (boundp sym)) - (directory-file-name - (hpath:substitute-dir var-name rest-of-path)) - var-group)))) - t))) - -(defun hpath:substitute-var (path) - "Replaces up to one match in PATH with first matching variable from `hpath:variables'." - (if (not (and (stringp path) (string-match "/" path) (hpath:is-p path))) - path - (setq path (hpath:symlink-referent path)) - (let ((new-path) - (vars hpath:variables) - result var val) - (while (and vars (null new-path)) - (setq var (car vars) vars (cdr vars)) - (if (boundp var) - (progn (setq val (symbol-value var)) - (cond ((stringp val) - (if (setq result - (hpath:substitute-var-name var val path)) - (setq new-path result))) - ((null val)) - ((listp val) - (while (and val (null new-path)) - (if (setq result - (hpath:substitute-var-name var (car val) path)) - (setq new-path result)) - (setq val (cdr val)))) - (t (error "(hpath:substitute-var): `%s' has invalid value for hpath:variables" var)))))) - (or new-path path) - ))) - -;; -;; The following function recursively resolves all UNIX links to their -;; final referents. -;; Works with Apollo's variant and other strange links like: -;; /usr/local -> $(SERVER_LOCAL)/usr/local, /usr/bin -> -;; ../$(SYSTYPE)/usr/bin and /tmp -> `node_data/tmp. It also handles -;; relative links properly as in /usr/local/emacs -> gnu/emacs which must -;; be resolved relative to the `/usr/local' directory. -;; It will fail on Apollos if the `../' notation is used to move just -;; above the `/' directory level. This is fairly uncommon and so the -;; problem has not been fixed. -;; -(defun hpath:symlink-referent (linkname) - "Returns expanded file or directory referent of LINKNAME. -LINKNAME should not end with a directory delimiter. -Returns nil if LINKNAME is not a string. -Returns LINKNAME unchanged if it is not a symbolic link but is a pathname." - (if (stringp linkname) - (or (file-symlink-p linkname) linkname))) - -(defun hpath:symlink-expand (referent dirname) - "Returns expanded file or directory REFERENT relative to DIRNAME." - (let ((var-link) - (dir dirname)) - (while (string-match "\\$(\\([^\)]*\\))" referent) - (setq var-link (getenv (substring referent (match-beginning 1) - (match-end 1))) - referent (concat (substring referent 0 (match-beginning 0)) - var-link - (substring referent (match-end 0))))) - ;; If referent is not an absolute path - (let ((nd-abbrev (string-match "`node_data" referent))) - (if (and nd-abbrev (= nd-abbrev 0)) - (setq referent (concat - ;; Prepend node name given in dirname, if any - (and (string-match "^//[^/]+" dirname) - (substring dirname 0 (match-end 0))) - "/sys/" (substring referent 1))))) - (while (string-match "\\(^\\|/\\)\\.\\.\\(/\\|$\\)" referent) - ;; Match to "//.." or "/.." at the start of link referent - (while (string-match "^\\(//\\.\\.\\|/\\.\\.\\)\\(/\\|$\\)" referent) - (setq referent (substring referent (match-end 1)))) - ;; Match to "../" or ".." at the start of link referent - (while (string-match "^\\.\\.\\(/\\|$\\)" referent) - (setq dir (file-name-directory (directory-file-name dir)) - referent (concat dir (substring referent (match-end 0))))) - ;; Match to rest of "../" in link referent - (while (string-match "[^/]+/\\.\\./" referent) - (setq referent (concat (substring referent 0 (match-beginning 0)) - (substring referent (match-end 0)))))) - (and (/= (aref referent 0) ?~) - (/= (aref referent 0) ?/) - (setq referent (expand-file-name referent dirname)))) - referent) - -(defun hpath:validate (path) - "Returns PATH if PATH is a valid, readable path, else signals error. -Info and ange-ftp remote pathnames are considered readable without any -validation checks. -Default-directory should be equal to current Hyperbole button source -directory when called, so that PATH is expanded relative to it." - (cond ((not (stringp path)) - (error "(hpath:validate): \"%s\" is not a pathname." path)) - ((or (string-match "[()]" path) (hpath:ange-ftp-p path)) - ;; info or ange-ftp path, so don't validate - path) - ((if (not (hpath:www-p path)) - ;; Otherwise, must not be a WWW link ref and must be a readable - ;; path. - (let ((return-path (hpath:exists-p path))) - (and return-path (file-readable-p return-path) - return-path)))) - (t (error "(hpath:validate): \"%s\" is not readable." path)))) - -(defun hpath:url-at-p () - "Return world-wide-web universal resource locator (url) that point immediately precedes or nil. -Use buffer-substring with match-beginning and match-end on the following -groupings: - 1 = optional `URL:' literal - 2 = access protocol - 4 = optional username - 4 = host and domain to connect to - 5 = optional port number to use - 6 = optional pathname to access." - ;; WWW URL format: [URL:]<protocol>:/[<user>@]<domain>[:<port>][/<path>] - ;; or [URL:]<protocol>://[<user>@]<domain>[:<port>][<path>] - ;; Avoid [a-z]:/path patterns since these may be disk paths on OS/2, DOS or - ;; Windows. - (if (looking-at "\\(URL:\\)?\\([a-zA-Z][a-zA-Z]+\\)://?\\([^@/: \t\n\^M]+@\\)?\\([^/:@ \t\n\^M\"`']+\\)\\(:[0-9]+\\)?\\([/~][^]@ \t\n\^M\"`'\)\}>]*\\)?") - (save-excursion - (goto-char (match-end 0)) - (skip-chars-backward ".,?#!*()") - (buffer-substring (match-beginning 2) (point))))) - -(defun hpath:url-p (obj) - "Return t if OBJ is a world-wide-web universal resource locator (url) string, else nil. -Use string-match with match-beginning and match-end on the following groupings: - 1 = optional `URL:' literal - 2 = access protocol - 3 = optional username - 4 = host and domain to connect to - 5 = optional port number to use - 6 = optional pathname to access." - ;; WWW URL format: [URL:]<protocol>:/[<user>@]<domain>[:<port>][/<path>] - ;; or [URL:]<protocol>://[<user>@]<domain>[:<port>][<path>] - ;; Avoid [a-z]:/path patterns since these may be disk paths on OS/2, DOS or - ;; Windows. - (and (stringp obj) - (string-match "\\`<?\\(URL:\\)?\\([a-zA-Z][a-zA-Z]+\\)://?\\([^@/: \t\n\^M]+@\\)?\\([^/:@ \t\n\^M\"`']+\\)\\(:[0-9]+\\)?\\([/~][^]@ \t\n\^M\"`'\)\}>]*\\)?>?\\'" - obj) - t)) - -(defun hpath:www-at-p (&optional include-start-and-end-p) - "Returns a world-wide-web link reference that point is within or nil. -With optional INCLUDE-START-AND-END-P non-nil, returns list of: - (link-string begin-position end-position)." - (save-excursion - (skip-chars-backward "^[ \t\n\"`'\(\{<") - (cond ((not include-start-and-end-p) - (hpath:url-at-p)) - ((hpath:url-at-p) - (list (buffer-substring (match-beginning 2) (match-end 0)) - (match-beginning 2) - (match-end 0)))))) - -(defun hpath:www-p (path) - "Returns non-nil iff PATH is a world-wide-web link reference." - (and (stringp path) (hpath:url-p path) path)) - -;;; ************************************************************************ -;;; Private functions -;;; ************************************************************************ - -(defun hpath:ange-ftp-available-p () - "Return t if the ange-ftp or efs package is available, nil otherwise. -Either the package must have been loaded already or under versions of Emacs -19, it must be set for autoloading via `file-name-handler-alist'." - (or (featurep 'ange-ftp) (featurep 'efs) - (and (boundp 'file-name-handler-alist) ; v19 - (or (rassq 'ange-ftp-hook-function file-name-handler-alist) - (rassq 'efs-file-handler-function file-name-handler-alist)) - t))) - - - -(defun hpath:ange-ftp-default-user () - "Return default user account for remote file access with ange-ftp or efs. -Returns \"anonymous\" if neither ange-ftp-default-user nor efs-default-user -is set." - (cond ((and (boundp 'ange-ftp-default-user) - (stringp ange-ftp-default-user)) - ange-ftp-default-user) - ((and (boundp 'efs-default-user) - (stringp efs-default-user)) - efs-default-user) - (t "anonymous"))) - -(defun hpath:delete-trailer (string) - "Return string minus any trailing .?#!*() characters." - (save-match-data - (if (and (stringp string) (> (length string) 0) - (string-match "[.?#!*()]+\\'" string)) - (substring string 0 (match-beginning 0)) - string))) - -(defun hpath:exists-p (path &optional suffix-flag) - "Return PATH if it exists. (This does not mean you can read it.) -If PATH exists with or without a suffix from hpath:suffixes, then that -pathname is returned. - -With optional SUFFIX-FLAG and PATH exists, return suffix added or removed -from path or t." - (let ((return-path) - (suffix) suffixes) - (if (file-exists-p path) - (setq return-path path) - (setq suffixes hpath:suffixes) - (while suffixes - (setq suffix (car suffixes)) - (if (string-match (concat (regexp-quote suffix) "\\'") path) - ;; Remove suffix - (setq return-path (substring path 0 (match-beginning 0))) - ;; Add suffix - (setq return-path (concat path suffix))) - (if (file-exists-p return-path) - (setq suffixes nil);; found a match - (setq suffix nil - suffixes (cdr suffixes) - return-path nil)))) - (if return-path - (if suffix-flag - (or suffix t) - return-path)))) - -(defun hpath:find-program (filename) - "Return shell or Lisp command to execute to display FILENAME or nil. -Return nil if FILENAME is a directory name. -See also documentation for `hpath:find-alist' and `hpath:display-alist'." - (let ((cmd)) - (cond ((and (stringp filename) (file-directory-p filename)) - nil) - ((stringp (setq cmd (hpath:match filename hpath:find-alist))) - (let ((orig-path filename)) - ;; If filename is a remote path, we have to copy it to a - ;; temporary local file and then display that. - (if (hpath:ange-ftp-p filename) - (copy-file orig-path - (setq filename - (concat hpath:tmp-prefix - (file-name-nondirectory orig-path))) - t t)) - ;; - ;; Permit %s substitution of filename within program. - (if (string-match "[^%]%s" cmd) - (format cmd filename) - (concat cmd " " filename)))) - ((null cmd) - (hpath:match filename hpath:display-alist)) - (t cmd)))) - -(defun hpath:match (filename regexp-alist) - "If FILENAME matches the car of any element in REGEXP-ALIST, return its cdr. -REGEXP-ALIST elements must be of the form (<filename-regexp> -. <command-to-display-file>). <command-to-display-file> may be a string -representing an external window-system command to run or it may be a Lisp -function to call with FILENAME as its single argument." - (let ((cmd) - elt) - (while (and (not cmd) regexp-alist) - (if (string-match (car (setq elt (car regexp-alist))) filename) - (setq cmd (cdr elt))) - (setq regexp-alist (cdr regexp-alist))) - cmd)) - -(defun hpath:substitute-dir (var-name rest-of-path) - "Returns a dir for VAR-NAME using REST-OF-PATH to find match or triggers an error when no match. -VAR-NAME's value may be a directory or a list of directories. If it is a -list, the first directory prepended to REST-OF-PATH which produces a valid -local pathname is returned." - (let (sym val) - (cond ((not (stringp var-name)) - (error "(hpath:substitute-dir): VAR-NAME arg, `%s', must be a string" var-name)) - ((not (and (setq sym (intern-soft var-name)) - (boundp sym))) - (error "(hpath:substitute-dir): VAR-NAME arg, \"%s\", is not a bound variable" - var-name)) - ((stringp (setq val (symbol-value sym))) - (if (hpath:validate (expand-file-name rest-of-path val)) - val)) - ((listp val) - (let ((dir)) - (while (and val (not dir)) - (setq dir (car val) val (cdr val)) - (or (and (stringp dir) - (file-name-absolute-p dir) - (file-readable-p (expand-file-name rest-of-path dir))) - (setq dir nil))) - (if dir (hpath:validate (directory-file-name dir)) - (error "(hpath:substitute-dir): Can't find match for \"%s\"" - (concat "${" var-name "}/" rest-of-path)) - ))) - (t (error "(hpath:substitute-dir): Value of VAR-NAME, \"%s\", must be a string or list" var-name)) - ))) - -(defun hpath:substitute-var-name (var-symbol var-dir-val path) - "Replaces with VAR-SYMBOL any occurrences of VAR-DIR-VAL in PATH. -Replacement is done iff VAR-DIR-VAL is an absolute path. -If PATH is modified, returns PATH, otherwise returns nil." - (if (and (stringp var-dir-val) (file-name-absolute-p var-dir-val)) - (let ((new-path (hypb:replace-match-string - (regexp-quote (file-name-as-directory - (or var-dir-val default-directory))) - path (concat "${" (symbol-name var-symbol) "}/") - t))) - (if (equal new-path path) nil new-path)))) - - -;;; ************************************************************************ -;;; Private variables -;;; ************************************************************************ - - -(defvar hpath:prefix-regexp "\\`[-!&][ ]*" - "Regexp matching command characters which may precede a pathname. -These are used to indicate how to display or execute the pathname. - - means evaluate it as Emacs Lisp; - ! means execute it as a shell script - & means run it under the current window system.") - -(provide 'hpath)
--- a/lisp/hyperbole/hrmail.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,281 +0,0 @@ -;;!emacs -;; -;; FILE: hrmail.el -;; SUMMARY: Support for Hyperbole buttons in mail reader: Rmail. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: hypermedia, mail -;; -;; AUTHOR: Bob Weiner -;; ORG: Brown U. -;; -;; ORIG-DATE: 9-May-91 at 04:22:02 -;; LAST-MOD: 14-Feb-97 at 11:38:57 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1991-1995, Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; -;; Automatically configured for use in "hyperbole.el". -;; If hsite loading fails prior to initializing Hyperbole Rmail support, -;; -;; {M-x Rmail-init RET} -;; -;; will do it. -;; -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Other required Elisp libraries -;;; ************************************************************************ - -(require 'hmail) -(require 'hact) -(load "hsmail") -(require 'rmail) -(load "rmailedit") -(provide 'rmailedit) - -;;; ************************************************************************ -;;; Public variables -;;; ************************************************************************ - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -(defun Rmail-init () - "Initializes Hyperbole support for Rmail mail reading." - (interactive) - (setq hmail:composer 'mail-mode - hmail:lister 'rmail-summary-mode - hmail:modifier 'rmail-edit-mode - hmail:reader 'rmail-mode) - (var:append 'rmail-show-message-hook '(hmail:msg-narrow)) - ;; - ;; - ;; Setup public abstract interface to Hyperbole defined mail - ;; reader-specific functions used in "hmail.el". - ;; - (rmail:init) - ;; - ;; Setup private abstract interface to mail reader-specific functions - ;; used in "hmail.el". - ;; - (fset 'rmail:get-new 'rmail-get-new-mail) - (fset 'rmail:msg-forward 'rmail-forward) - (fset 'rmail:summ-msg-to 'rmail-summary-goto-msg) - (fset 'rmail:summ-new 'rmail-new-summary) - (if (interactive-p) - (message "Hyperbole RMAIL mail reader support initialized.")) - ) - -(defun Rmail-msg-hdrs-full (toggled) - "If TOGGLED is non-nil, toggle full/hidden headers, else show full headers." - (save-excursion - (if (or toggled - (let ((tog nil)) - (save-excursion - (save-restriction - (rmail-maybe-set-message-counters) - (narrow-to-region (rmail-msgbeg rmail-current-message) - (point-max)) - (let ((buffer-read-only nil)) - (goto-char (point-min)) - (forward-line 1) - ;; Need to show full header - (if (= (following-char) ?1) - (setq tog t))))) - tog)) - (progn (rmail-toggle-header) - (setq toggled t))) - toggled)) - -(defun Rmail-msg-narrow () - "Narrows mail reader buffer to current message. -This includes Hyperbole button data." - (let ((beg (rmail-msgbeg rmail-current-message)) - (end (rmail-msgend rmail-current-message))) - (narrow-to-region beg end))) - -(defun Rmail-msg-next () (rmail-next-undeleted-message 1)) - -(defun Rmail-msg-num () - "Returns number of Rmail message that point is within." - (interactive) - (let ((count 0) opoint) - (save-excursion - (while (and (not (eobp)) - (progn (setq opoint (point)) - (re-search-backward "^\^_" nil t))) - (if (= opoint (point)) - (backward-char 1) - (setq count (1+ count))))) - count)) - -(defun Rmail-msg-prev () (rmail-previous-undeleted-message 1)) - -(defun Rmail-msg-to-p (mail-msg-id mail-file) - "Sets current buffer to start of msg with MAIL-MSG-ID in MAIL-FILE. -Returns t if successful, else nil." - (if (not (file-readable-p mail-file)) - nil - (let ((buf (get-file-buffer mail-file))) - (cond (buf - (switch-to-buffer buf) - (or (eq major-mode 'rmail-mode) - (rmail mail-file))) - (t (rmail mail-file)))) - (widen) - (goto-char 1) - (if (re-search-forward (concat rmail:msg-hdr-prefix - (regexp-quote mail-msg-id)) nil t) - ;; Found matching msg - (progn - (setq buffer-read-only t) - (rmail-show-message (Rmail-msg-num)) - t)))) - - -(defun Rmail-msg-widen () - "Widens buffer to full current message including Hyperbole button data." - (let ((start (point-min)) - (end (point-max))) - (unwind-protect - (save-excursion - (widen) - (if (re-search-forward "^\^_" nil t) - (progn (forward-char -1) - (setq end (point))))) - (narrow-to-region start end)))) - -(defun Rmail-to () - "Sets current buffer to a mail reader buffer." - (and (eq major-mode 'rmail-summary-mode) (set-buffer rmail-buffer))) - -(fset 'Rmail-Summ-delete 'rmail-summary-delete-forward) - -(fset 'Rmail-Summ-expunge 'rmail-summary-expunge) - -(fset 'Rmail-Summ-goto 'rmail-summary-goto-msg) - -(defun Rmail-Summ-to () - "Sets current buffer to a mail listing buffer." - (and (eq major-mode 'rmail-mode) (set-buffer rmail-summary-buffer))) - -(fset 'Rmail-Summ-undelete-all 'rmail-summary-undelete-many) - -;;; ************************************************************************ -;;; Private functions -;;; ************************************************************************ - -;;; -;;; Overlay version of this function from "rmailedit.el" to include any -;;; hidden Hyperbole button data when computing message length. -(defun rmail-cease-edit () - "Finish editing message; switch back to Rmail proper." - (interactive) - ;; Make sure buffer ends with a newline. - (save-excursion - (Rmail-msg-widen) - (goto-char (point-max)) - (if (/= (preceding-char) ?\n) - (insert "\n")) - ;; Adjust the marker that points to the end of this message. - (set-marker (aref rmail-message-vector (1+ rmail-current-message)) - (point)) - (hmail:msg-narrow) - ) - (let ((old rmail-old-text)) - ;; Update the mode line. - (set-buffer-modified-p (buffer-modified-p)) - (rmail-mode-1) - (if (and (= (length old) (- (point-max) (point-min))) - (string= old (buffer-substring (point-min) (point-max)))) - () - (setq old nil) - (rmail-set-attribute "edited" t) - (if (boundp 'rmail-summary-vector) - (progn - (aset rmail-summary-vector (1- rmail-current-message) nil) - (save-excursion - (rmail-widen-to-current-msgbeg - (function (lambda () - (forward-line 2) - (if (looking-at "Summary-line: ") - (let ((buffer-read-only nil)) - (delete-region (point) - (progn (forward-line 1) - (point)))))))) - (rmail-show-message)))))) - (setq buffer-read-only t)) - - -;;; Overlay version of this function from "rmail.el" to include any -;;; Hyperbole button data. -(defun rmail-forward (resend) - "Forward the current message to another user. -With prefix argument, \"resend\" the message instead of forwarding it; -see the documentation of `rmail-resend'." - (interactive "P") - (if resend - (call-interactively 'rmail-resend) - (let ((forward-buffer (current-buffer)) - (subject (concat "[" - (let ((from (or (mail-fetch-field "From") - (mail-fetch-field ">From")))) - (if from - (concat (mail-strip-quoted-names from) ": ") - "")) - (or (mail-fetch-field "Subject") "") - "]"))) - (save-restriction - (Rmail-msg-widen) - ;; Turn off the usual actions for initializing the message body - ;; because we want to get only the text from the failure message. - (let (mail-signature mail-setup-hook) - ;; If only one window, use it for the mail buffer. - ;; Otherwise, use another window for the mail buffer - ;; so that the Rmail buffer remains visible - ;; and sending the mail will get back to it. - (if (funcall (if (one-window-p t) - (function mail) - (function mail-other-window)) - nil nil subject nil nil nil - (list (list (function (lambda (buf msgnum) - (save-excursion - (set-buffer buf) - (rmail-set-attribute - "forwarded" t msgnum)))) - (current-buffer) - rmail-current-message))) - (save-excursion - (goto-char (point-max)) - (forward-line 1) - (insert-buffer forward-buffer) - (hmail:msg-narrow)))))))) - -;;; Overlay version of 'rmail-get-new-mail' from "rmail.el" to highlight -;;; Hyperbole buttons when possible. -;;; -(hypb:function-overload 'rmail-get-new-mail nil - '(if (fboundp 'hproperty:but-create) - (progn (widen) (hproperty:but-create) - (rmail-show-message)))) - -;;; Overlay version of 'rmail-new-summary' from "rmailsum.el" to -;;; highlight Hyperbole buttons when possible. -;;; -(or (fboundp 'rmail-new-summary) (load "rmailsum")) -(hypb:function-overload 'rmail-new-summary nil - '(if (fboundp 'hproperty:but-create) - (hproperty:but-create))) - -;;; ************************************************************************ -;;; Private variables -;;; ************************************************************************ - -(provide 'hrmail)
--- a/lisp/hyperbole/hsite-ex.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,387 +0,0 @@ -;;!emacs -;; -;; FILE: hsite.el -;; SUMMARY: Site-specific setup for Hyperbole -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: hypermedia, local -;; -;; AUTHOR: Bob Weiner -;; ORG: InfoDock Associates -;; -;; ORIG-DATE: 15-Apr-91 at 00:48:49 -;; LAST-MOD: 24-Apr-97 at 22:41:33 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1991-1997, Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; -;; See the "README" file for installation instructions. -;; -;; "hsite.el" may be byte-compiled if you like but normally it is not. -;; -;; Be sure to have users load any personal mail/news initializations -;; before they load this file if any of Hyperbole's mail or news -;; support features are enabled either herein or within their personal -;; Hyperbole initializations. Otherwise, the mail/news support may -;; not be configured properly. -;; -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Read the comments and modify as desired. -;;; ************************************************************************ - -(message "Initializing Hyperbole, please wait...") - -;; The following line must not be deleted. -(require 'hyperbole) - -;;; ************************************************************************ -;;; TIMEZONE SETTING -;;; ************************************************************************ - -;; The following section applies only to MS-DOS and MS-Windows OSs. -;; For such OSs, you must configure this section or you will receive -;; an error when starting Hyperbole. Users of other OSs may simply -;; ignore this section. - - -;; Microcruft OSs don't provide an automatically set timezone environment -;; variable. Nor do they include a UNIX-style date program. So follow -;; the commented instructions in the code below here. - -;; If you happened to have installed a UNIX-style date program (when you type -;; `date' at a shell, it simply spits out the date and time and then quits), -;; you may comment out the logic. -;; -(if (and hyperb:microcruft-os-p - (not (or (getenv "TZ") (getenv "TIMEZONE")))) - (progn - ;; Comment out the following `error' line... - (error "(hsite.el): Configure the TIMEZONE SETTING section in this file.") - ;; ... and uncomment the following line, substituting an appropriate - ;; timezone from the list in the variable, `htz:world-timezones' - ;; in the file, "htz.el". - ;; (setenv "TZ" "your-3char-timezone") - )) - -;;; ************************************************************************ -;;; SMART SETTINGS -;;; ************************************************************************ - -(defvar hkey-always-display-menu nil - "*Non-nil means always display the Smart Menu window when the Action or Assist Key is pressed and the Smart Menu system has been loaded. -If a Smart Menu is already displayed, perform another Action or Assist Key -function.") - -(defvar smart-scroll-proportional t - "*Non-nil means Smart Keys should scroll relative to current line when pressed at the end of a line. -Action Key moves current line to top of window. Assist Key moves current -line to bottom of window. Repeated presses then scroll up or down a -windowful. Nil value instead ignores current line and always scrolls up or -down a windowful.") - -;;; ************************************************************************ -;;; HYPERBOLE DIRECTORY SETTING -;;; ************************************************************************ - -(require 'hyperbole) - -;;; ************************************************************************ -;;; INTERNET SETTINGS -;;; ************************************************************************ - -;; String to be used in the call: (hpath:rfc rfc-num) to create a remote -;; path to the RFC document for `rfc-num'. Uncomment and alter this setting -;; if another site is closer for you. -;; (setq hpath:rfc "/anonymous@ds.internic.net:rfc/rfc%s.txt") - -;; When a user creates an explicit button, Hyperbole tries to store her -;; Internet e-mail address with the button by using the formula, email-id = -;; <user-id>@<domainname>. Not every system has its domainname set -;; up properly, however. If you do a {M-x load-file hypb.elc RET} and then -;; hit {C-x C-e} after the closing paren of the following function, -;; (hypb:domain-name), you will see whether or not yours is configured -;; properly. If it is not, uncomment the following line and set it to the -;; proper value. - -;; (setenv "DOMAINNAME" "yourdomain.com") - -;;; ************************************************************************ -;;; XEMACS, GNU EMACS 19, AND EPOCH CONFIGURATION -;;; ************************************************************************ - -;; No-op unless set by one of the conditionals below. -(defun hui:but-flash ()) - -(if (and hyperb:emacs19-p window-system) - (progn - (require 'hui-em19-b) - ;; Highlight explicit buttons whenever a file is read in. - (var:append 'find-file-hooks '(hproperty:but-create)) - (fset 'hui:but-flash 'hproperty:but-flash) - ;; - ;; Substitute for the nil argument below a valid X color name with - ;; which to highlight buttons if the default highlighting does not - ;; appeal to you. See "hui-em19-b.el" for how this works. - (hproperty:cycle-but-color nil) - ;; - ;; Non-nil means visually emphasize that button under mouse cursor is - ;; selectable. - (setq hproperty:but-emphasize-p nil) - ;; - ;; If you find that the Hyperbole button flash time is too slow - ;; or too fast, adjust it here. - (setq hproperty:but-flash-time 1000) - )) - -(if (and hyperb:lemacs-p (not noninteractive)) - (progn - (require 'hui-xe-but) - ;; - ;; If running XEmacs 19.8 or below, don't highlight explicit buttons - ;; whenever a file is read in since this can cause a sporadic crash - ;; when find-files are done. - (if hyperb:kotl-p (var:append 'find-file-hooks '(hproperty:but-create))) - (fset 'hui:but-flash 'hproperty:but-flash) - ;; - ;; Substitute for the nil argument below a valid X color name with - ;; which to highlight buttons if the default highlighting does not - ;; appeal to you. See "hui-xe-but.el" for how this works. - (hproperty:cycle-but-color nil) - ;; - ;; Non-nil means visually emphasize that button under mouse cursor is - ;; selectable. - (setq hproperty:but-emphasize-p nil) - ;; - ;; If you find that the Hyperbole button flash time is too slow - ;; or too fast, adjust it here. - (setq hproperty:but-flash-time 1000) - )) - -(if (and hyperb:epoch-p (string= hyperb:epoch-p "V4")) - (progn - (require 'hui-epV4-b) - ;; Highlight explicit buttons whenever a file is read in. - (var:append 'find-file-hooks '(hproperty:but-create)) - (fset 'hui:but-flash 'hproperty:but-flash) - ;; Substitute for the nil argument below a valid X color name with - ;; which to highlight buttons if the default highlighting does not - ;; appeal to you. See "hui-epV4-b.el" for how this works. - (hproperty:cycle-but-color nil) - ;; If you use Epoch and find that the Hyperbole button flash time is - ;; too slow or too fast, adjust it here. - (defvar hproperty:but-flash-time 1000 - "Machine specific value for empty loop counter, Epoch but flash delay.") - )) - -;;; ************************************************************************ -;;; EXTERNAL SYSTEM ENCAPSULATIONS -;;; ************************************************************************ - -;;; Support for encapsulations of any of these external systems may be -;;; enabled here. You should be familiar with the external system before -;;; you try to use the Hyperbole support for it. -;;; Possible system encapsulations to include within the innermost set of -;;; parentheses are: -;;; hsys-wais hsys-hbase -;;; See files with the same name, e.g. "hsys-wais.el" for details on each -;;; system. -;;; -;;; Note: hsys-w3 is automatically loaded by default by Hyperbole. -(setq hibtypes:begin-load-hook - (list (function (lambda () (mapcar 'require '()))))) - -;;; ************************************************************************ -;;; ONLINE LIBRARY CONFIGURATION -;;; ************************************************************************ - -;;; Support for online library document id references is loaded here but -;;; requires some additional configuration before use. See the DESCRIPTION -;;; section in "hib-doc-id.el" for complete installation and use information. -;;; -(setq hibtypes:end-load-hook - (list (function (lambda () (mapcar 'require '(hib-doc-id)))))) - -;;; ************************************************************************ -;;; FILE VIEWER COMMAND SETTINGS -;;; ************************************************************************ - -(defvar hpath:display-alist - (let ((info-suffix "\\.info\\(-[0-9]+\\)?\\(\\.gz\\|\\.Z\\|-z\\)?$")) - (list - ;; Run the OO-Browser on OOBR or OOBR-FTR Environment files. - '("OOBR\\(-FTR\\)?$" . br-env-browse) - ;; Display the top node from Info online manuals. - (cons - (concat (` (, info-suffix)) "\\|/info/[^.]+$\\|/info-local/[^.]+$") - (` (lambda (file) - (if (and (string-match (, info-suffix) file) - (match-beginning 1)) - ;; Removed numbered trailer to get basic filename. - (setq file (concat (substring file 0 (match-beginning 1)) - (substring file (match-end 1))))) - (require 'info) - (condition-case () - (Info-find-node file "Top") - (error (if (and file (file-exists-p file)) - (progn - (if (get-buffer "*info*") - (kill-buffer "*info*")) - (Info-find-node file "*" nil t)) - (error "Invalid file"))))))) - )) - "*Alist of (FILENAME-REGEXP . EDIT-FUNCTION) elements for calling special -functions to display particular file types within Emacs. See also -`hpath:file-alist' for external display program settings.") - -(defvar hpath:display-buffer-alist - (list - (list 'this-window 'switch-to-buffer) - (list 'other-window (function (lambda (b) - (if (br-in-browser) - (progn (br-to-view-window) - (switch-to-buffer b)) - (switch-to-buffer-other-window b))))) - (list 'one-window (function (lambda (b) - (if (br-in-browser) (br-quit)) - (delete-other-windows) - (switch-to-buffer b)))) - (list 'new-frame (function (lambda (b) - (select-frame (make-frame)) - (switch-to-buffer b)))) - (list 'other-frame 'hpath:display-buffer-other-frame) - (list 'other-frame-one-window - (function (lambda (b) - (hpath:display-buffer-other-frame b) - (delete-other-windows))))) - "*Alist of (DISPLAY-WHERE-SYMBOL DISPLAY-BUFFER-FUNCTION) elements. -This permits fine-grained control of where Hyperbole displays linked to buffers. -The default value of DISPLAY-WHERE-SYMBOL is given by `hpath:display-where'. -Valid DISPLAY-WHERE-SYMBOLs are: - this-window - display in the current window - other-window - display in another window in the current frame - one-window - display in the current window, deleting other windows - new-frame - display in a new frame - other-frame - display in another, possibly existing, frame - other-frame-one-window - display in another frame, deleting other windows.") - -(defvar hpath:display-where 'other-window - "Symbol specifying the default method to use to display Hyperbole link referents. -See documentation of `hpath:display-where-alist' for valid values.") - -(defvar hpath:display-where-alist - (list - (list 'this-window 'find-file) - (list 'other-window (function (lambda (f) - (if (br-in-browser) - (progn (br-to-view-window) - (find-file f)) - (find-file-other-window f))))) - (list 'one-window (function (lambda (f) - (if (br-in-browser) (br-quit)) - (delete-other-windows) (find-file f)))) - (list 'new-frame (function (lambda (f) - (if (fboundp 'find-file-new-frame) - (find-file-new-frame f) - (find-file-other-frame f))))) - (list 'other-frame 'hpath:find-other-frame) - (list 'other-frame-one-window - (function (lambda (f) (hpath:find-other-frame f) (delete-other-windows))))) - "*Alist of (DISPLAY-WHERE-SYMBOL DISPLAY-FILE-FUNCTION) elements. -This permits fine-grained control of where Hyperbole displays linked to files. -The default value of DISPLAY-WHERE-SYMBOL is given by `hpath:display-where'. -Valid DISPLAY-WHERE-SYMBOLs are: - this-window - display in the current window - other-window - display in another window in the current frame - one-window - display in the current window, deleting other windows - new-frame - display in a new frame - other-frame - display in another, possibly existing, frame - other-frame-one-window - display in another frame, deleting other windows.") - -;;; `hyperb:window-system' variable from "hversion.el" must be defined -;;; prior to this variable definition. -;;; -(defvar hpath:find-alist - (let ((nextstep-suffixes '(("\\.\\(adaptor\\|app\\|bshlf\\|clr\\|concur\\|create\\|diagram\\|dp\\|e?ps\\|frame\\|gif\\|locus\\|Mesa\\|nib\\|project\\|rtf\\|sense\\|tiff\\|tree\\)$" . "open"))) - (x-suffixes '(("\\.e?ps$" . "ghostview") - ("\\.ps\\.g?[zZ]$" . "zcat %s | ghostview -") - ("\\.\\(gif\\|tiff?\\|xpm\\|xbm\\|pm\\|pbm\\|jpe?g\\)" . "xv") - ("\\.xwd$" . "xwud -noclick -in") - ("\\.ra?s$" . "snapshot -l") - ("\\.\\(fm\\|frame\\|mif\\)$" . - "frame.pl -vn -preader -c -f%s") ;; was "msgfm_driver" - ("\\.\\(doc\\|boo\\)$" . "ileaf") - ))) - (if (memq window-system '(dps ns)) - nextstep-suffixes - (cdr (assoc hyperb:window-system - (list (cons "emacs19" x-suffixes) ; GNU Emacs V19 under X - (cons "lemacs" x-suffixes) ; XEmacs under X - (cons "xterm" x-suffixes) ; GNU Emacs V18 under X - (cons "epoch" x-suffixes) ; UofI Epoch under X - '("sun" . nil) ; SunView - (cons "next" nextstep-suffixes) - '("apollo" . nil) ; Display Manager - ))))) - "*Alist of (FILENAME-REGEXP . EDIT-PROGRAM) elements for using window system -dependent external programs to edit/display particular file types. See also -`hpath:display-alist' for internal, window-system independent display -settings.") - -;;; ************************************************************************ -;;; LINK PATH VARIABLE SUBSTITUTION SETTINGS -;;; ************************************************************************ - -;;; The following variable permits sharing of links over wide areas, where -;;; links may contain variable references whose values may differ between -;;; link creator and link activator. -;;; -;;; When a link is created, if its path contains a match for any of the -;;; variable values in hpath:variables, then the variable's symbol is -;;; substituted for the literal value. Hyperbole then replaces the variable -;;; with a matching value when the link is resolved. -;;; -(defvar hpath:variables - '(hyperb:dir Info-directory Info-directory-list sm-directory load-path exec-path) - "*List of Emacs Lisp variable symbols to substitute within matching link paths. -Each variable value, if bound, must be either a pathname or a list of pathnames.") - -;;; ************************************************************************ -;;; HYPERBOLE INITIALIZATION -;;; ************************************************************************ - -;;; This call loads the whole Hyperbole system. -;;; You may want to look at this file just to see what it does. -;;; -(require 'hinit) -;;; -;;; This call initializes the Hyperbole system for use. -;;; -(hyperb:init) - -;;; ************************************************************************ -;;; HYPERBOLE LOCAL VARIABLE SUPPORT -;;; ************************************************************************ - -;;; Uncomment this if you really need to be able to use Hyperbole variables -;;; (and others with colons in their names) within file local variable lists. -;;; See the source file for more details. -;;; -;; (require 'hlvar) - -;;; ************************************************************************ -;;; SITE-SPECIFIC ADDITIONS - Add your Hyperbole configuration additions here. -;;; ************************************************************************ - -;;; ************************************************************************ -;;; END OF HYPERBOLE CONFIGURATION -;;; ************************************************************************ - -(provide 'hsite) - -(message "Hyperbole is ready for action.")
--- a/lisp/hyperbole/hsmail.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,204 +0,0 @@ -;;!emacs -;; -;; FILE: hsmail.el -;; SUMMARY: Support for Hyperbole buttons in mail composer: mail and mh-letter. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: hypermedia, mail -;; -;; AUTHOR: Bob Weiner -;; ORG: Brown U. -;; -;; ORIG-DATE: 9-May-91 at 04:50:20 -;; LAST-MOD: 8-Aug-95 at 10:55:17 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1991-1995, Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Other required Elisp libraries -;;; ************************************************************************ - -(require 'sendmail) - -;;; ************************************************************************ -;;; Public variables -;;; ************************************************************************ - - -(defvar smail:comment '(format - "Comments: Hyperbole mail buttons accepted, v%s.\n" - hyperb:version) - "Default comment form to evaluate and add to outgoing mail. -Set to the empty string, \"\", for no comment.") - -;;; Used by 'mail-send' in Emacs "sendmail.el". -(if (boundp 'send-mail-function) - (or (if (listp send-mail-function) - (if (equal (nth 2 send-mail-function) '(smail:widen)) - nil - (error - "(hsmail): Set 'send-mail-function' to a symbol-name, not a list, before load."))) - (setq send-mail-function - (list 'lambda nil '(smail:widen) (list send-mail-function)))) - (error "(hsmail): Install an Emacs \"sendmail.el\" which includes 'send-mail-function'.")) - -(if (fboundp 'mail-prefix-region) - ;; - ;; For compatibility with rsw-modified sendmail.el. - (defvar mail-yank-hook - (function - (lambda () - ;; Set off original message. - (mail-prefix-region (hypb:mark t) (point)))) - "*Hook to run mail yank preface function. -Expects point and mark to be set to the region to preface.") - ;; - ;; Else for compatibility with Supercite and Emacs V19. - ;; If you create your own yank hook, set this variable rather than - ;; 'mail-yank-hook' from above. - (defvar mail-citation-hook nil - "*Hook for modifying a citation just inserted in the mail buffer. -Each hook function can find the citation between (point) and (mark t). -And each hook function should leave point and mark around the citation -text as modified. - -If this hook is entirely empty (nil), a default action is taken -instead of no action.") - (defvar mail-yank-hooks '(mail-indent-citation) - "*Obsolete hook to run mail yank citation function. Use mail-citation-hook instead. -Expects point and mark to be set to the region to cite.")) - -;; For compatibility with Supercite and Emacs V19. -(defvar mail-yank-prefix nil - "*Prefix insert on lines of yanked message being replied to. -nil means use indentation.") -(defvar mail-indentation-spaces 3 - "*Number of spaces to insert at the beginning of each cited line.") - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -(defun smail:comment-add (&optional comment-form) - "Adds a comment to the current outgoing message if Hyperbole has been loaded. -Optional COMMENT-FORM is evaluated to obtain the string to add to the -message. If not given, 'smail:comment' is evaluated by default." - (let ((comment (eval (or comment-form smail:comment)))) - (if (and comment (featurep 'hsite)) - (save-excursion - (goto-char (point-min)) - (and (or (search-forward mail-header-separator nil t) - (if (eq major-mode 'mh-letter-mode) - (search-forward "\n--------" nil t))) - (not (search-backward comment nil t)) - (progn (beginning-of-line) (insert comment))))))) - -(defun smail:widen () - "Widens outgoing mail buffer to include Hyperbole button data." - (if (fboundp 'mail+narrow) (mail+narrow) (widen))) - -;; Overlay this function from V19 "sendmail.el" to work with V18. -(defun mail-indent-citation () - "Modify text just inserted from a message to be cited. -The inserted text should be the region. -When this function returns, the region is again around the modified text. - -Normally, indent each nonblank line `mail-indentation-spaces' spaces. -However, if `mail-yank-prefix' is non-nil, insert that prefix on each line." - (let ((start (point))) - ;; Don't ever remove headers if user uses Supercite package, - ;; since he can set an option in that package to do - ;; the removal. - (or (hypb:supercite-p) - (mail-yank-clear-headers start (hypb:mark t))) - (if (null mail-yank-prefix) - (indent-rigidly start (hypb:mark t) mail-indentation-spaces) - (save-excursion - (goto-char start) - (while (< (point) (hypb:mark t)) - (insert mail-yank-prefix) - (forward-line 1)))))) - -;; Overlay this function from "sendmail.el" to include Hyperbole button -;; data when yanking in a message and to highlight buttons if possible. -(defun mail-yank-original (arg) - "Insert the message being replied to, if any. -Puts point before the text and mark after. -Applies 'mail-citation-hook', 'mail-yank-hook' or 'mail-yank-hooks' -to text (in decreasing order of precedence). -Just \\[universal-argument] as argument means don't apply hooks -and don't delete any header fields. - -If supercite is in use, header fields are never deleted. -Use (setq sc-nuke-mail-headers-p t) to have them removed." - (interactive "P") - (if mail-reply-buffer - (let ((start (point)) opoint) - (delete-windows-on mail-reply-buffer) - (unwind-protect - (progn - (save-excursion - (set-buffer mail-reply-buffer) - ;; Might be called from newsreader before any - ;; Hyperbole mail reader support has been autoloaded. - (cond ((fboundp 'rmail:msg-widen) (rmail:msg-widen)) - ((eq major-mode 'news-reply-mode) (widen)))) - (setq opoint (point)) - (insert-buffer mail-reply-buffer) - (hmail:msg-narrow) - (if (fboundp 'hproperty:but-create) (hproperty:but-create)) - (if (consp arg) - nil - ;; Don't ever remove headers if user uses Supercite package, - ;; since he can set an option in that package to do - ;; the removal. - (or (hypb:supercite-p) - (mail-yank-clear-headers - start (marker-position (hypb:mark-marker t)))) - (let ((mail-indentation-spaces (if arg (prefix-numeric-value arg) - mail-indentation-spaces))) - (cond ((and (boundp 'mail-citation-hook) mail-citation-hook) - (run-hooks 'mail-citation-hook)) - ((and (boundp 'mail-yank-hook) mail-yank-hook) - (run-hooks 'mail-yank-hook)) - ((and (boundp 'mail-yank-hooks) mail-yank-hooks) - (run-hooks 'mail-yank-hooks)) - (t (mail-indent-citation)))) - (goto-char (min (point-max) (hypb:mark t))) - (set-mark opoint) - (delete-region (point) ; Remove trailing blank lines. - (progn (re-search-backward "[^ \^I\^L\n]") - (end-of-line) - (point)))) - (or (eq major-mode 'news-reply-mode) - ;; This is like exchange-point-and-mark, but doesn't activate the mark. - ;; It is cleaner to avoid activation, even though the command - ;; loop would deactivate the mark because we inserted text. - (goto-char (prog1 (hypb:mark t) - (set-marker (hypb:mark-marker t) - (point) (current-buffer))))) - (if (not (eolp)) (insert ?\n)) - ) - (save-excursion - (set-buffer mail-reply-buffer) - (hmail:msg-narrow)))))) - -;;; ************************************************************************ -;;; Private variables -;;; ************************************************************************ - -;;; Try to setup comment addition as the first element of these hooks. -(if (fboundp 'add-hook) - (progn - (add-hook 'mail-setup-hook 'smail:comment-add) - (add-hook 'mh-letter-mode-hook 'smail:comment-add)) - (var:append 'mail-setup-hook '(smail:comment-add)) - (var:append 'mh-letter-mode-hook '(smail:comment-add))) - -(provide 'hsmail)
--- a/lisp/hyperbole/hsys-hbase.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,177 +0,0 @@ -;;!emacs -;; -;; FILE: hsys-hbase.el -;; SUMMARY: Hyperbole support for the Hyperbase system. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: comm, hypermedia -;; -;; AUTHOR: Bob Weiner -;; ORG: Brown U. -;; -;; ORIG-DATE: 16-Oct-91 at 04:35:09 -;; LAST-MOD: 30-Oct-95 at 22:31:23 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1991, 1995, Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; -;; For information and the source to HyperBase and follow-on hypermedia -;; work, see: ftp://ftp.iesd.auc.dk/pub/packages/hypertext/ -;; -;; In order to use this package, you must have the HyperBase system -;; and must start up a HyperBase server and then load the HyperBase -;; Epoch support software that comes with the HyperBase system. -;; -;; Then load this package and Hyperbole will do the following when -;; in a Hyperbase buffer: -;; -;; Action Key press on a button follows the link, within any other -;; text, closes current Epoch screen and kills node buffer. -;; -;; Assist Key press shows attributes for the current button or -;; for the current node buffer, if no current button. -;; -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Other required Elisp libraries -;;; ************************************************************************ - -(require 'hbut) - -;;; ************************************************************************ -;;; Public variables -;;; ************************************************************************ - -(defib hyperbase () - "Detects link buttons in buffers that communicate with the Hyperbase system. -Hyperbase is a hypertext database system that interfaces to Emacs." - (and (boundp 'ehts-mode) ehts-mode - (let ((lbl (or (ebut:label-p 'as-label "[-> " "]") - "no-but"))) - (ibut:label-set lbl) - (hact 'hyperbase lbl)))) - -(defact hyperbase (linkname) - "Follows LINKNAME in a buffer that communicates with the Hyperbase system. -If LINKNAME equals t, closes the current Epoch screen and kill the -buffer of the current Hyperbase node. -Hyperbase is a hypertext database system that interfaces to Emacs." - ;; From hb-EHTS.el by: - ;; Uffe Kock Wiil (kock@iesd.auc.dk) - ;; Claus Bo Nielsen (cbn@cci.dk) - ;; - (if (equal linkname "no-but") - (progn (ehts-mouse-kill-screen-and-buffer t) - (and (fboundp 'epoch::select-screen) - (epoch::select-screen))) - (let ((linknum (cdr (assoc linkname ehts-node-link-alist))) tonode) - (ehts-command t) - (if (< (ehts-hb-sys-call "read" linknum "to data node no" nil t) 0) - (progn - (ehts-command nil) - (error "Can't read \"to data node no\" in link, panic !!!"))) - (ehts-read-4bytes) - (setq tonode (ehts-read-4bytes)) - (if (< (ehts-hb-sys-call "read" tonode "n name" nil t) 0) - (progn - (ehts-command nil) - (error "Can't read \"name\" in data node, panic !!!"))) - (ehts-get-node (ehts-read-null-string)) - (and (fboundp 'hproperty:but-create-all) - (hproperty:but-create-all "[-> " "]")) - (ehts-command nil)))) - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -(defun hyperbase:init () - "Show initial set of Hyperbase buttons." - (if (assoc (user-full-name) ehts-node-name-alist) - (progn - (ehts-get-node (user-full-name)) - (let (buffer screen) - (setq buffer "*Ehts Welcome*") - (setq screen (ehts-find-buffer-screen buffer)) - (kill-buffer buffer) - (switch-to-buffer (user-full-name)) - (remove-screen screen))) - (if (assoc "dir ehts help" ehts-node-name-alist) - (progn - (ehts-get-node "dir ehts help") - (let (buffer screen) - (setq buffer "*Ehts Welcome*") - (setq screen (ehts-find-buffer-screen buffer)) - (kill-buffer buffer) - (switch-to-buffer "dir ehts help") - (remove-screen screen) - (hproperty:but-create "[-> " "]")))))) - -(defun hyperbase:help (&optional but) - "Displays attributes of a link button BUT if on one or of the current node. -Hyperbase is a hypertext database system that interfaces to Emacs." - (interactive (list (ibut:at-p))) - (or (and (boundp 'ehts-mode) ehts-mode) - (error "(hyperbase:help): Not in a Hyperbase mode buffer.")) - (hyperbase:attr-help - (or (and (symbolp but) - (let ((lbl (ebut:key-to-label (hattr:get but 'lbl-key)))) - (if (not (equal lbl "no-but")) lbl))) - (current-buffer)))) - -;;; ************************************************************************ -;;; Private functions -;;; ************************************************************************ - -(defun hyperbase:already-displayed-p (name) - "Test if a buffer allready is displayed." - (let (screenid) - (setq screenid (ehts-find-buffer-screen name)) - (if screenid - (progn - (switch-screen screenid) - t) - nil))) - -(defun hyperbase:attr-help (node-link-spec) - "Show the attributes of a node or a button link from NODE-LINK-SPEC. -A string value of NODE-LINK-SPEC means show attributes for that button link. -A buffer value means show attributes for the node in that buffer." - (interactive) - (or (stringp node-link-spec) (bufferp node-link-spec) - (error "(hyperbase-show-attributes): Non-string or buffer argument.")) - (let (entity name string number buffer screenid) - (setq buffer (if (bufferp node-link-spec) (buffer-name node-link-spec)) - entity (cdr (assoc (if buffer "node" "link") node-link-list)) - buffer (or buffer (buffer-name))) - (if (eq (string-match "Attributes - " buffer) 0) - nil - (if (= entity 0) - (progn - (setq name (concat "Attributes - " buffer)) - (if (not (hyperbase:already-displayed-p name)) - (progn - (setq number (cdr (assoc buffer ehts-node-name-alist)) - string (ehts-create-node-attribute-string number)) - (ehts-setup-attribute-screen name string entity buffer)))) - (if (eq ehts-node-link-alist '()) - (error "No links in this node.")) - (setq name (concat "Attributes - " - (car (assoc node-link-spec ehts-node-link-alist)))) - (if (not (hyperbase:already-displayed-p name)) - (progn - (setq number (cdr (assoc (substring name 13) - ehts-node-link-alist)) - string (ehts-create-link-attribute-string number)) - (ehts-setup-attribute-screen name string entity buffer))))))) - -;;; ************************************************************************ -;;; Private variables -;;; ************************************************************************ - -(provide 'hsys-hbase)
--- a/lisp/hyperbole/hsys-w3.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,80 +0,0 @@ -;;!emacs -;; -;; FILE: hsys-w3.el -;; SUMMARY: Hyperbole support for Emacs W3 World-Wide Web (WWW) browsing. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: comm, help, hypermedia -;; -;; AUTHOR: Bob Weiner -;; ORG: Motorola Inc. -;; -;; ORIG-DATE: 7-Apr-94 at 17:17:39 by Bob Weiner -;; LAST-MOD: 10-Mar-97 at 12:17:08 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1994, 1995 Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; -;; This module defines an implicit button type and associated action and -;; help types. A press of the Action Key on a unified resource locator -;; (URL) displays the referent for the URL. A press of the Help Key on a -;; URL displays a history list of previously browsed WWW documents. Press -;; the Action Key on any item from the history list to display it. -;; -;; This requires the Emacs W3 World-Wide-Web browser available from: -;; ftp://cs.indiana.edu/pub/elisp/w3/. -;; -;; It assumes that you have set up to have w3 auto-loaded according to the -;; setup instructions included with W3. Specifically, `w3-fetch' should be -;; autoloaded. -;; -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Other required Elisp libraries -;;; ************************************************************************ - -;;; Requires that 'w3' or other web browser code that is called be available. - -;;; ************************************************************************ -;;; Public functions and types -;;; ************************************************************************ - -(defib www-url () - "When not in a w3 buffer, follow any non-ftp url (link) at point. -The variable, `action-key-url-function,' can be used to customize the url -browser that is used." - (if (not (eq major-mode 'w3-mode)) - (let ((link-and-pos (hpath:www-at-p t))) - (if link-and-pos - (progn (ibut:label-set link-and-pos) - (hact 'www-url (car link-and-pos))))))) - -(defact www-url (url) - "Follows a link given by URL. -The variable, `action-key-url-function,' can be used to customize the url -browser that is used." - (interactive "sURL to follow: ") - (or (stringp url) - (error "(www-url): Link label must be given as a string.")) - (and (symbolp action-key-url-function) - (memq action-key-url-function - '(highlight-headers-follow-url-netscape - highlight-headers-follow-url-mosaic)) - (require 'highlight-headers)) - (if window-system - (funcall action-key-url-function url) - (w3-fetch url))) - -(defun www-url:help (&optional but) - "Displays history list of www nodes previously visited with the W3 browser." - (interactive) - (if (fboundp 'w3-show-history-list) - (hact 'w3-show-history-list) - (hact 'error "(www-url:help): W3 must be loaded to display WWW history"))) - -(provide 'hsys-w3)
--- a/lisp/hyperbole/hsys-wais.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,77 +0,0 @@ -;;!emacs -;; -;; FILE: hsys-wais.el -;; SUMMARY: Hyperbole support for WAIS browsing. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: comm, help, hypermedia -;; -;; AUTHOR: Bob Weiner -;; ORG: Brown U. -;; -;; ORIG-DATE: 5-Nov-91 at 20:53:26 -;; LAST-MOD: 30-Oct-95 at 22:48:21 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1991, 1995, Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; -;; For information on WAIS, see ftp://ftp.wais.com:/pub/. -;; The freeware/ subdirectory there contains free source code to support -;; WAIS on most standard architectures. -;; -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Other required Elisp libraries -;;; ************************************************************************ - -;; Autoload wais. -(autoload 'wais "wais" "Client-server full-text retrieval" t) -(autoload 'waisd-mode "wais" "Wide Area Information Services" t) -(autoload 'wais-select-question "wais" "Select a new WAIS question." t) -(autoload 'wais-create-question "wais" "Create a new WAIS question." t) - -;;; ************************************************************************ -;;; Public implicit button types -;;; ************************************************************************ - -(defib wais-smart () - "Handles context-sensitive Smart Key in WAIS buffers." - (if (featurep 'wais) - (let ((b (buffer-name))) - (cond ((string-match ": Find Documents On\\|: Similar To" b) - (hact 'wais-smart 'wais-query)) - ((equal "*Source List*" b) - (hact 'wais-smart 'source-menu-view)) - ((string-match ": On Sources" b) - (hact 'wais-smart - (if (eobp) 'wais-view-source 'source-menu-view))) - ((string-match ": Results" b) - (hact 'wais-smart 'wais-edit)) - )))) - -;;; ************************************************************************ -;;; Public button action types -;;; ************************************************************************ - -(defact wais-ques (question-name) - "Loads a Wais Question QUESTION-NAME, displays it with WAIS Emacs interface." - (interactive "sWAIS Question name: ") - (if (or (featurep 'wais) (load "wais")) - (progn - (display-question question-name) - (wais) - (display-question question-name) - ) - (error "(wais-ques): WAIS interface not available so can't load question.") - )) - -(defact wais-smart (interactive-func) - "Performs INTERACTIVE-FUNC in a Wais buffer." - (call-interactively interactive-func)) - -(provide 'hsys-wais)
--- a/lisp/hyperbole/hsys-www.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,201 +0,0 @@ -;;!emacs -;; -;; FILE: hsys-www.el -;; SUMMARY: Hyperbole support for old CERN command line WWW browsing. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: comm, help, hypermedia -;; -;; AUTHOR: Bob Weiner -;; ORG: Brown U. -;; -;; ORIG-DATE: 12-Oct-91 at 03:48:23 -;; LAST-MOD: 14-Apr-95 at 16:09:23 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1991-1995, Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; -;; You must first build the www line mode browser executable before you can -;; use this system encapsulation. The browser MUST be configured so that -;; the final part of its prompt is a line beginning with "==> " without a -;; trailing newline, like so: -;; -;; <ref.number>, Back, Quit, or Help. -;; ==> -;; -;; -;; Then, a Hyperbole button should be created that has 'hwww:start' as its -;; action type. It may optionally contain a file name argument as -;; the initial file to display. When selected, it starts a 'www' -;; process and displays the initial file. -;; -;; The 'hwww:link-follow' implicit button type is then used when the -;; user clicks inside the buffer containing the 'www' output. It -;; passes commands to the 'hwww:link-follow' action type. -;; -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Other required Elisp libraries -;;; ************************************************************************ - -;;; Requires external 'www' executable available via anonymous ftp -;;; from info.cern.ch. - -;;; ************************************************************************ -;;; Public variables -;;; ************************************************************************ - -(defib hwww:link-follow () - "When in a www buffer, returns a link follow or history recall command." - (let* ((www (get-buffer-process (current-buffer))) - (www-proc-nm (and www (process-name www))) - (selection) - (act (function - (lambda (&optional prefix) - (setq selection - (buffer-substring (match-beginning 1) - (match-end 1))) - (ibut:label-set selection (match-beginning 1) - (match-end 1)) - (hact 'hwww:link-follow (concat prefix selection)))))) - (if (and www-proc-nm (equal (string-match "www" www-proc-nm) 0)) - (cond (;; Hyper ref - (save-excursion - (skip-chars-backward "^ \t\n") - (looking-at "[^][ \t\n]*\\[\\([0-9]+\\)\\]")) - (funcall act)) - (;; History list entry - (save-excursion - (beginning-of-line) - (looking-at "[ \t]*\\([0-9]+\\)\)[ \t]+[^ \t\n]")) - (funcall act "recall ")) - (;; Hyper ref list - (save-excursion - (beginning-of-line) - (looking-at "[ \t]*\\[\\([0-9]+\\)\\][ \t]+[^ \t\n]")) - (funcall act )))))) - -(defact hwww:link-follow (link-num-str) - "Follows a link given by LINK-NUM-STR or displays a www history list." - (interactive "sNumber of WWW link to follow: ") - (or (stringp link-num-str) - (error "(hwww:link-follow): Link number must be given as a string.")) - (let ((www (get-buffer-process (current-buffer)))) - (if www - (progn - (setq buffer-read-only nil) - (erase-buffer) - (process-send-string www (concat link-num-str "\n")) - ) - (error "(hwww:link-follow): No current WWW process. Use 'hwww:start'.")))) - -(defun hwww:link-follow:help (&optional but) - "Displays history list of www nodes previously visited." - (interactive) - (hact 'hwww:link-follow "recall")) - -(defact hwww:start (&optional file) - "Starts a www process and displays optional FILE. -Without FILE (an empty string), displays default initial www file." - (interactive "FWWW file to start with: ") - (or (stringp file) - (error "(hwww:start): FILE argument is not a string.")) - (let ((www-buf (get-buffer-create "WWW")) - (www-proc (get-process "www"))) - (save-excursion - (set-buffer www-buf) - (setq buffer-read-only nil) - (erase-buffer) - ) - (if www-proc - (pop-to-buffer www-buf) - (if (setq www-proc - (if (or (equal file "") (equal file "\"\"")) - (start-process "www" www-buf "www" "-p") - (start-process "www" www-buf "www" "-p" file))) - (progn (set-process-sentinel www-proc 'hwww:sentinel) - (set-process-filter www-proc 'hwww:filter) - (process-kill-without-query www-proc) - (pop-to-buffer www-buf) - (shell-mode) - (make-local-variable 'explicit-shell-file-name) - (setq explicit-shell-file-name "www") - (use-local-map hwww:mode-map) - (if hwww:mode-map - nil - (setq hwww:mode-map (copy-keymap shell-mode-map)) - (define-key hwww:mode-map "\C-m" 'hwww:send-input) - (define-key hwww:mode-map " " 'hwww:scroll-up) - (define-key hwww:mode-map "\177" 'hwww:scroll-down) - ) - (goto-char (point-min)) - ))))) - -;;; ************************************************************************ -;;; Private functions -;;; ************************************************************************ - -(defun hwww:filter (process str) - (if (and (> (length str) 3) - (equal "==> " (substring str -4))) - (progn - (insert str) - (goto-char (point-min)) - (hproperty:but-create (concat "\\([^ \t\n]*\\[[0-9]+\\]\\|" - "^[ \t]*\\[\\([0-9]+\\)\\][ \t]+[^ \t\n]+\\|" - "^[ ]+[0-9]+\).*\\)") - 'regexp)) - (insert str))) - -(defun hwww:scroll-up (&optional arg) - "If on last line of buffer, insert space, else scroll up a page." - (interactive "P") - (if (last-line-p) (insert " ") (scroll-up arg))) - -(defun hwww:scroll-down (&optional arg) - "If on last line of buffer, delete char backwards, else scroll down a page." - (interactive "P") - (if (last-line-p) (backward-delete-char-untabify (or arg 1)) - (scroll-down arg))) - -(defun hwww:send-input () - (interactive) - (cond ((eobp) - (let ((www (get-buffer-process (current-buffer)))) - (if www - (progn - (beginning-of-line) - ;; Exclude the shell prompt, if any. - (re-search-forward shell-prompt-pattern - (save-excursion (end-of-line) (point)) - t) - (let ((cmd (concat (buffer-substring (point) - (progn (forward-line 1) - (point))) - "\n"))) - (erase-buffer) - (process-send-string www cmd) - )) - (error "(hwww:link-follow): No current WWW process. Use 'hwww:start'.")))) - ((ibut:at-p) (hui:hbut-act)) - (t (end-of-buffer)) - )) - -(defun hwww:sentinel (process signal) - (princ - (format "Process: %s received the msg: %s" process signal)) - (or (string-match "killed" signal) - (pop-to-buffer (process-buffer process)))) - -;;; ************************************************************************ -;;; Private variables -;;; ************************************************************************ - -(defvar hwww:mode-map nil) - -(provide 'hsys-www)
--- a/lisp/hyperbole/htz.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,393 +0,0 @@ -;;!emacs -;; -;; FILE: htz.el -;; SUMMARY: Timezone-based time and date support for Hyperbole. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: calendar, hypermedia -;; -;; AUTHOR: Masanobu UMEDA / Bob Weiner -;; ORG: Fujitsu Laboratories LTD. / InfoDock Associates -;; -;; ORIG-DATE: 14-Oct-91 at 07:22:08 -;; LAST-MOD: 20-Feb-97 at 12:21:10 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1991-1995, 1997 Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; Adapted from Timezone package for GNU Emacs -;; Copyright(C) 1990 Masanobu UMEDA (umerin@mse.kyutech.ac.jp) -;; $Header: /afs/informatik.uni-tuebingen.de/local/web/xemacs/xemacs-cvs/XEmacs/xemacs/lisp/hyperbole/Attic/htz.el,v 1.2 1997/02/24 01:13:35 steve Exp $ -;; -;; DESCRIPTION: -;; -;; All date parsing functions accept the output of any other parsing -;; function as input, so one can convert to a sortable date format, do a -;; compare and the display the result in a user selected format. -;; All date formats use a 4-digit year, so there are no problems around the -;; turn of the century. -;; -;; Hyperbole uses this package to normalize all worldwide date times to -;; Greenwich Mean Time, so that Hyperbole buttons created by users in -;; different timezones will sort by time properly. -;; -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Other required Elisp libraries -;;; ************************************************************************ - -(require 'hypb) - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -(defun htz:date-arpa (&optional date local timezone) - "Convert optional DATE or current date to an arpanet standard date. -Optional 1st argument LOCAL specifies the default local timezone of the DATE. -Optional 2nd argument TIMEZONE specifies a timezone to be represented in." - (or (vectorp date) - (setq date (htz:date-parse (or date (current-time-string))))) - (let* ((year (string-to-int (aref date 0))) - (month (string-to-int (aref date 1))) - (day (string-to-int (aref date 2))) - (time (htz:time-parse (aref date 3))) - (hour (string-to-int (aref time 0))) - (minute (string-to-int (aref time 1))) - (second (string-to-int (aref time 2))) - (local (or (aref date 4) local htz:local)) ;Use original if defined - (timezone (or timezone local)) - (diff (- (htz:zone-to-hour timezone) - (htz:zone-to-hour local))) - (new (htz:time-fix year month day - (+ hour diff) minute second))) - (htz:date-make-arpa (aref new 0) (aref new 1) (aref new 2) - (htz:time-make-string - (aref new 3) (aref new 4) (aref new 5)) - timezone))) - -(defun htz:date-parse (date &optional parsed-current-date) - "Parse DATE string and return a vector [year month day time timezone]. -19 is prepended to year if necessary. Timezone in DATE is optional, it -defaults to the value of `htz:local'. - -Recognizes the following styles: - (1) 14 Apr 89 03:20[:12] [GMT] - (2) Fri, 17 Mar [19]89 4:01[:33] [GMT] - (3) Mon Jan 16 16:12[:37] [GMT] 1989 - (4) 19911014:07:51:08 or 1991101407:51:08 'sortable date' - (5) Mar 29 14:00 'ls -l date' requires 'parsed-current-date' arg - (6) Mar 7 1994 'ls -l date' requires 'parsed-current-date' arg" - (let ((date (or date "")) - (year nil) - (month nil) - (day nil) - (time nil) - (zone nil)) ; This may be nil. - (cond ((string-match -"\\([0-9][0-9][0-9][0-9]\\)\\([0-1][0-9]\\)\\([0-3][0-9]\\):?\\([0-2][0-9]:[0-5][0-9:]+\\)[ ]*\\'" date) - ;; Style (4) - (setq year 1 month 2 day 3 time 4 zone nil)) - ((string-match -"\\([0-9]+\\) \\([^ ,]+\\) \\([0-9]+\\) \\([0-9]+:[0-9:]+\\)[ ]*\\'" date) - ;; Styles: (1) and (2) without timezone - (setq year 3 month 2 day 1 time 4 zone nil)) - ((string-match -"\\([0-9]+\\) \\([^ ,]+\\) \\([0-9]+\\) \\([0-9]+:[0-9:]+\\)[ ]*\\([-+a-zA-Z0-9]+\\)" date) - ;; Styles: (1) and (2) with timezone and buggy timezone - (setq year 3 month 2 day 1 time 4 zone 5)) - ((string-match -"\\([^ ,]+\\) +\\([0-9]+\\) \\([0-9]+:[0-9:]+\\) \\([0-9]+\\)" date) - ;; Styles: (3) without timezone - (setq year 4 month 1 day 2 time 3 zone nil)) - ((string-match -"\\([^ ,]+\\) +\\([0-9]+\\) \\([0-9]+:[0-9:]+\\) \\([-+a-zA-Z0-9]+\\) \\([0-9]+\\)" date) - ;; Styles: (3) with timezone - (setq year 5 month 1 day 2 time 3 zone 4)) - ((string-match "^\\([^ ,]+\\) +\\([0-9]+\\) +\\([0-9]+:[0-9:]+\\)$" date) - ;; Style: (5) - (setq year nil month 1 day 2 time 3 zone nil)) - ((string-match - "^\\([^ ,]+\\) +\\([0-9]+\\) +\\([0-9][0-9][0-9][0-9]\\)$" date) - ;; Style: (6) - (setq year 3 month 1 day 2 time nil zone nil)) - (t (error "(htz:date-parse): Invalid date format: '%s'" date))) - (if year - (setq year - (substring date (match-beginning year) (match-end year)) - year (if (/= (length year) 2) year - (let* ((yr (substring (current-time-string) -4)) - (curr-yr (substring yr 2)) - (century (substring yr 0 2))) - (concat (if (string< curr-yr yr) - (format "%02d" - (1- (string-to-int century))) - century) - year)))) - (setq year (if (vectorp parsed-current-date) - (aref parsed-current-date 0) - "0"))) - (if month - (setq month (substring date - (match-beginning month) (match-end month)) - month (if (/= (string-to-int month) 0) month - (int-to-string - (cdr (assoc (upcase month) htz:months-assoc))))) - (setq month (if (vectorp parsed-current-date) - (aref parsed-current-date 1) - "0"))) - (if day - (setq day (substring date (match-beginning day) (match-end day))) - (setq day (if (vectorp parsed-current-date) - (aref parsed-current-date 2) - "0"))) - (if time - (setq time (substring date (match-beginning time) (match-end time))) - (setq time (if (vectorp parsed-current-date) - (aref parsed-current-date 3)))) - (if zone - (setq zone (substring date (match-beginning zone) (match-end zone))) - (setq zone (if (vectorp parsed-current-date) - (aref parsed-current-date 4) - htz:local))) - ;; Return a vector. - (vector year month day time zone))) - -(defun htz:date-sortable (&optional date local timezone) - "Convert optional DATE or current date to a sortable date string. -Optional 1st argument LOCAL specifies the local timezone of the DATE. -Optional 2nd argument TIMEZONE specifies an output timezone to use." - (or (vectorp date) - (setq date (htz:date-parse (or date (current-time-string))))) - (let* ((year (string-to-int (aref date 0))) - (month (string-to-int (aref date 1))) - (day (string-to-int (aref date 2))) - (time (htz:time-parse (aref date 3))) - (hour (string-to-int (aref time 0))) - (minute (string-to-int (aref time 1))) - (second (string-to-int (aref time 2))) - (local (or (aref date 4) local htz:local)) ;Use original if defined - (timezone (or timezone local)) - (diff (- (htz:zone-to-hour timezone) - (htz:zone-to-hour local))) - (new (htz:time-fix year month day - (+ hour diff) minute second))) - (htz:date-make-sortable (aref new 0) (aref new 1) (aref new 2) - (htz:time-make-string - (aref new 3) (aref new 4) (aref new 5))))) - -;;; -;;; Parsers and Constructors of Date and Time -;;; - -(defun htz:date-sortable-gmt (&optional date local) - "Convert optional DATE or current date to a sortable date string in Greenwich Mean Time. -Optional argument LOCAL specifies the local timezone of the DATE." - (htz:date-sortable date local "GMT")) - -(defun htz:date-unix (&optional date local timezone) - "Convert DATE or current date to a unix standard date. -Optional 1st argument LOCAL specifies the local timezone of the DATE (default -is the timezone embedded in the date or if there is none, then the value of -`htz:local'). Optional 2nd argument TIMEZONE specifies the timezone in which -the date is returned; it defaults to the value of `htz:local'." - (or (vectorp date) - (setq date (htz:date-parse (or date (current-time-string))))) - (or local (setq local (or (aref date 4) htz:local))) - (let* ((year (string-to-int (aref date 0))) - (month (string-to-int (aref date 1))) - (day (string-to-int (aref date 2))) - (time (htz:time-parse (aref date 3))) - (hour (string-to-int (aref time 0))) - (minute (string-to-int (aref time 1))) - (second (string-to-int (aref time 2))) - (timezone (or timezone local)) - (diff (- (htz:zone-to-hour timezone) - (htz:zone-to-hour local))) - (fixed (htz:time-fix year month day - (+ hour diff) minute second))) - (htz:date-make-unix - (aref fixed 0) (aref fixed 1) (aref fixed 2) - (htz:time-make-string (aref fixed 3) (aref fixed 4) (aref fixed 5)) - timezone))) - -(defun htz:span-in-days (start-date end-date) - "Return span in days between START-DATE and END-DATE strings. -See 'htz:date-parse' for a list of acceptable date formats." - (require 'calendar) - (let* ((parsed-current-date (htz:date-parse (current-time-string))) - (htz-start-date (htz:date-parse start-date parsed-current-date)) - (htz-end-date (htz:date-parse end-date parsed-current-date)) - (cal-start-date - (list (string-to-int (aref htz-start-date 1)) ;; month - (string-to-int (aref htz-start-date 2)) ;; day - (string-to-int (aref htz-start-date 0)))) ;; year - (cal-end-date - (list (string-to-int (aref htz-end-date 1)) ;; month - (string-to-int (aref htz-end-date 2)) ;; day - (string-to-int (aref htz-end-date 0)))) ;; year - ) - (- (calendar-absolute-from-julian cal-end-date) - (calendar-absolute-from-julian cal-start-date)))) - -(defun htz:time-parse (time) - "Parse TIME (HH:MM:SS) and return a vector [hour minute second]." - (let ((time (or time "")) - (hour nil) - (minute nil) - (second nil)) - (cond ((string-match "\\`\\([0-9]+\\):\\([0-9]+\\):\\([0-9]+\\)\\'" time) - ;; HH:MM:SS - (setq hour 1 minute 2 second 3)) - ((string-match "\\`\\([0-9]+\\):\\([0-9]+\\)\\'" time) - ;; HH:MM - (setq hour 1 minute 2 second nil))) - ;; Return [hour minute second] - (vector - (if hour - (substring time (match-beginning hour) (match-end hour)) "0") - (if minute - (substring time (match-beginning minute) (match-end minute)) "0") - (if second - (substring time (match-beginning second) (match-end second)) "0")))) - -;;; ************************************************************************ -;;; Private functions -;;; ************************************************************************ - -(defun htz:date-make-arpa (year month day time &optional timezone) - "Make arpanet standard date string from YEAR, MONTH, DAY, and TIME. -Optional argument TIMEZONE specifies a time zone." - (format "%02d %s %02d %s%s" - day - (capitalize (car (rassq month htz:months-assoc))) - (- year (* (/ year 100) 100)) ;1990 -> 90 - time - (if timezone (concat " " timezone) "") - )) - -(defun htz:date-make-unix (year month day time &optional timezone) - "Approximate Unix date format from YEAR, MONTH, DAY, and TIME. -Optional argument TIMEZONE specifies a time zone." - (format "%s %02d %s%s %04d" - (capitalize (car (rassq month htz:months-assoc))) - day time (if timezone (concat " " timezone) "") year)) - -(defun htz:date-make-sortable (year month day time) - "Make sortable date string from YEAR, MONTH, DAY, and TIME." - (format "%04d%02d%02d:%s" year month day time)) - -(defun htz:last-day-of-month (month year) - "The last day in MONTH during YEAR." - (if (and (= month 2) (htz:leap-year-p year)) - 29 - (aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month)))) - -(defun htz:leap-year-p (year) - "Returns t if YEAR is a Gregorian leap year." - (or (and (zerop (% year 4)) - (not (zerop (% year 100)))) - (zerop (% year 400)))) - -(defun htz:time-fix (year month day hour minute second) - "Fix date and time." - (cond ((<= 24 hour) ; 24 -> 00 - (setq hour (- hour 24)) - (setq day (1+ day)) - (if (< (htz:last-day-of-month month year) day) - (progn - (setq month (1+ month)) - (setq day 1) - (if (< 12 month) - (progn - (setq month 1) - (setq year (1+ year))))))) - ((> 0 hour) - (setq hour (+ hour 24)) - (setq day (1- day)) - (if (> 1 day) - (progn - (setq month (1- month)) - (if (> 1 month) - (progn - (setq month 12) - (setq year (1- year)))) - (setq day (htz:last-day-of-month month year)))))) - (vector year month day hour minute second)) - -;; Partly copied from Calendar program by Edward M. Reingold. -(defun htz:time-make-string (hour minute second) - "Make time string from HOUR, MINUTE, and SECOND." - (format "%02d:%02d:%02d" hour minute second)) - -(defun htz:zone-to-hour (timezone) - "Translate TIMEZONE (in zone name or integer) to integer hour." - (if timezone - (progn - (setq timezone - (or (cdr (assoc (upcase timezone) - htz:world-timezones)) - (and (fboundp 'current-time-zone) - (if (listp (current-time-zone)) - (car (cdr (current-time-zone))) - (current-time-zone))) - timezone)) - (if (stringp timezone) - (setq timezone (string-to-int timezone))) - (/ timezone 100)) - (error "(htz:zone-to-hour): Nil timezone sent as argument"))) - - -;;; ************************************************************************ -;;; Private variables -;;; ************************************************************************ - -(defvar htz:local - (or (getenv "TZ") (getenv "TIMEZONE") - (hypb:call-process-p - "date" nil '(if (re-search-backward - " \\([-+a-zA-Z0-9]+\\) [0-9]+$" nil t) - (buffer-substring (match-beginning 1) (match-end 1))))) - "Holds string giving the timezone for the local machine.") - -(defvar htz:world-timezones - '(("PST" . -800) - ("PDT" . -700) - ("MST" . -700) - ("MDT" . -600) - ("CST" . -600) - ("CDT" . -500) - ("EST" . -500) - ("EDT" . -400) - ("AST" . -400) ;by <clamen@CS.CMU.EDU> - ("NST" . -330) ;by <clamen@CS.CMU.EDU> - ("GMT" . +000) - ("BST" . +100) - ("MET" . +100) - ("EET" . +200) - ("JST" . +900) - ("GMT+1" . +100) ("GMT+2" . +200) ("GMT+3" . +300) - ("GMT+4" . +400) ("GMT+5" . +500) ("GMT+6" . +600) - ("GMT+7" . +700) ("GMT+8" . +800) ("GMT+9" . +900) - ("GMT+10" . +1000) ("GMT+11" . +1100) ("GMT+12" . +1200) ("GMT+13" . +1300) - ("GMT-1" . -100) ("GMT-2" . -200) ("GMT-3" . -300) - ("GMT-4" . -400) ("GMT-5" . -500) ("GMT-6" . -600) - ("GMT-7" . -700) ("GMT-8" . -800) ("GMT-9" . -900) - ("GMT-10" . -1000) ("GMT-11" . -1100) ("GMT-12" . -1200)) - "*Time differentials of timezone from GMT in +-HHMM form. -This list is obsolescent, and is present only for backwards compatibility, -because time zone names are ambiguous in practice. -Use `current-time-zone' instead.") - -(defvar htz:months-assoc - '(("JAN" . 1)("FEB" . 2)("MAR" . 3) - ("APR" . 4)("MAY" . 5)("JUN" . 6) - ("JUL" . 7)("AUG" . 8)("SEP" . 9) - ("OCT" . 10)("NOV" . 11)("DEC" . 12)) - "Alist of first three letters of a month and its numerical representation.") - - -(provide 'htz)
--- a/lisp/hyperbole/hui-em19-b.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,428 +0,0 @@ -;;!emacs -;; -;; FILE: hui-em19-b.el -;; SUMMARY: GNU Emacs V19 button highlighting and flashing support. -;; USAGE: GNU Emacs V19 Lisp Library -;; KEYWORDS: faces, hypermedia -;; -;; AUTHOR: Bob Weiner -;; ORG: InfoDock Associates -;; -;; ORIG-DATE: 21-Aug-92 -;; LAST-MOD: 26-Feb-97 at 01:58:45 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; It is for use with GNU Emacs V19. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1992-1995, Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; -;; This is truly prototype code. -;; -;; Can't use read-only buttons here because then outline-mode -;; becomes unusable. -;; -;; DESCRIP-END. - -(if (and hyperb:emacs19-p (or noninteractive hyperb:window-system)) - nil - (error "(hui-em19-b.el): Load only when running GNU Emacs V19 under a window system.")) - -;;; ************************************************************************ -;;; Other required Elisp libraries -;;; ************************************************************************ - -(require 'hvar) -(require 'hbut) - -(defun hproperty:background () - "Returns default background color for current frame." - (or (face-background (make-face 'default)) - (cdr (assq 'background-color (frame-parameters))) - "White")) - -(defun hproperty:foreground () - "Returns default foreground color for current frame." - (or (face-foreground (make-face 'default)) - (cdr (assq 'foreground-color (frame-parameters))) - "Black")) - -;;; ************************************************************************ -;;; Public variables -;;; ************************************************************************ - -(defvar hproperty:but-emphasize-p nil - "*Non-nil means visually emphasize that button under mouse cursor is selectable.") - -(defvar hproperty:but-flash-time 1000 - "*Machine specific value for empty loop counter, Emacs 19 button flash delay.") - -(defvar hproperty:item-highlight-color (hproperty:foreground) - "Color with which to highlight list/menu selections. -Call (hproperty:set-item-highlight <color>) to change value.") - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -;; Support NEXTSTEP and X window systems. -(and (not (fboundp 'display-color-p)) - (fboundp 'x-display-color-p) - (fset 'display-color-p 'x-display-color-p)) - -(defun hproperty:but-add (start end face) - "Add between START and END a button using FACE in current buffer. -If `hproperty:but-emphasize-p' is non-nil when this is called, emphasize that -button is selectable whenever the mouse cursor moves over it." - (let ((but (make-overlay start end))) - (overlay-put but 'face face) - (if hproperty:but-emphasize-p (overlay-put but 'mouse-face 'highlight)))) - -(defun hproperty:but-color () - "Return current color of buffer's buttons." - (if hproperty:color-ptr - (car hproperty:color-ptr) - (hproperty:foreground))) - -(defun hproperty:but-clear () - "Delete all Hyperbole buttons from current buffer." - (interactive) - (let ((start (point-min))) - (while (< start (point-max)) - (mapcar (function (lambda (props) - (if (eq (overlay-get props 'face) hproperty:but-face) - (delete-overlay props)))) - (overlays-at start)) - (setq start (next-overlay-change start))))) - -(defun hproperty:but-create (&optional start-delim end-delim regexp-match) - "Highlight all hyper-buttons in buffer. -Will use optional strings START-DELIM and END-DELIM instead of default values. -If END-DELIM is a symbol, e.g. t, then START-DELIM is taken as a regular -expression which matches an entire button string. -If REGEXP-MATCH is non-nil, only buttons matching this argument are -highlighted. - -If `hproperty:but-emphasize-p' is non-nil when this is called, emphasize that -button is selectable whenever the mouse cursor moves over it." - (interactive) - (hproperty:but-clear) - (hproperty:but-create-all start-delim end-delim regexp-match)) - -(defun hproperty:but-create-all (&optional start-delim end-delim regexp-match) - "Mark all hyper-buttons in buffer for later highlighting. -Will use optional strings START-DELIM and END-DELIM instead of default values. -If END-DELIM is a symbol, e.g. t, then START-DELIM is taken as a regular -expression which matches an entire button string. -If REGEXP-MATCH is non-nil, only buttons matching this argument are -highlighted." - (ebut:map (function (lambda (lbl start end) - (hproperty:but-add start end hproperty:but-face))) - start-delim end-delim regexp-match 'include-delims)) - -(defun hproperty:but-delete (&optional pos) - (let ((but (hproperty:but-get pos))) - (if but (delete-overlay but)))) - -;;; ************************************************************************ -;;; Private functions -;;; ************************************************************************ - -(defun hproperty:but-get (&optional pos) - (car (delq nil - (mapcar (function (lambda (props) - (if (memq (overlay-get props 'face) - (list hproperty:but-face - hproperty:flash-face)) - props))) - (overlays-at (or pos (point))))))) - -(defmacro hproperty:list-cycle (list-ptr list) - "Move LIST-PTR to next element in LIST or when at end to first element." - (` (or (and (, list-ptr) - (setq (, list-ptr) (cdr (, list-ptr)))) - (setq (, list-ptr) (, list))))) - -;;; ************************************************************************ -;;; Private variables -;;; ************************************************************************ - -(defconst hproperty:color-list - (if (eq window-system 'x) - '( "red" "blue" "paleturquoise4" "mediumpurple2" -"lightskyblue3" "springgreen2" "salmon" "yellowgreen" "darkorchid2" -"aquamarine4" "slateblue4" "slateblue1" "olivedrab1" "goldenrod4" -"goldenrod3" "cadetblue2" "burlywood1" "slategrey" "mistyrose" -"limegreen" "lightcyan" "goldenrod" "gainsboro" "skyblue1" "honeydew" -"yellow2" "tomato3" "skyblue" "purple4" "orange3" "bisque3" "bisque2" -"grey34" "gray99" "gray63" "gray44" "gray37" "gray33" "gray26" "azure1" -"snow4" "peru" "red" "lightgoldenrod4" "mediumseagreen" "blush" -"mediumorchid2" "lightskyblue1" "darkslateblue" "midnightblue" -"lightsalmon1" "lemonchiffon" "yellow" "lightsalmon" "coral" -"dodgerblue3" "darkorange4" "blue" "royalblue4" "red" "green" "cyan" -"darkviolet" "darksalmon" "darkorange" "blue" "pink" "magenta2" -"sienna4" "khaki2" "grey75" "grey74" "grey73" "grey69" "grey68" "grey35" -"grey13" "gray90" "gray81" "gray55" "gray51" "gray31" "snow2" "pink3" -"grey7" "gray1" "red4" "red3" "tan" "red" "yellow" "mediumvioletred" -"lightslategrey" "lavenderblush4" "turquoise" "darkturquoise" -"darkslategrey" "lightskyblue" "lightsalmon4" "lightsalmon3" -"forestgreen" "dodgerblue4" "orchid" "rosybrown4" "brown" "peachpuff3" -"palegreen3" "orangered2" "rose" "lightcyan4" "indianred4" "indianred3" -"seagreen2" "indianred" "deeppink1" "navyblue" "lavender" "grey" -"deeppink" "salmon4" "salmon3" "oldlace" "grey78" "grey77" "grey54" -"grey45" "grey21" "gray97" "gray96" "gray95" "gray88" "gray87" "gray86" -"gray70" "gray57" "gray38" "gray12" "gray11" "plum3" "linen" "gray9" -"gray8" "blue4" "beige" "turquoise" "blue" "lemonchiffon4" -"darkseagreen1" "antiquewhite3" "mediumorchid" "springgreen" -"turquoise4" "steelblue3" "mistyrose2" "lightcyan2" "red" "firebrick2" -"royalblue" "cadetblue" "skyblue3" "yellow3" "salmon1" "orange4" -"hotpink" "grey90" "gray56" "gray39" "gray18" "gray14" "plum4" "grey6" -"gray6" "gold3" "gold1" "blue2" "tan2" "cyan" "mediumspringgreen" -"darkolivegreen2" "goldenrod" "lightsteelblue" "brown" "whip" -"chartreuse3" "violetred4" "royalblue2" "royalblue1" "papayawhip" -"mistyrose3" "lightcyan1" "aquamarine" "skyblue4" "hotpink4" "hotpink3" -"hotpink2" "dimgray" "tomato" "grey66" "grey65" "grey64" "grey33" -"grey27" "gray76" "gray69" "gray68" "grey0" "azure" "green" -"darkgoldenrod4" "darkgoldenrod3" "darkgoldenrod2" "darkgoldenrod" -"brown" "lightsalmon2" "deepskyblue4" "deepskyblue3" "deepskyblue2" -"deepskyblue" "darkorange1" "violetred3" "violetred2" "violetred1" -"slateblue3" "slateblue2" "drab" "indianred1" "firebrick1" "cadetblue4" -"violetred" "rosybrown" "blue" "firebrick" "grey100" "wheat4" "grey79" -"grey76" "grey61" "gray93" "gray84" "gray65" "gray36" "gray32" "gray13" -"gray10" "azure3" "snow1" "tan1" "gray" "darkolivegreen1" "blue" -"almond" "lavenderblush3" "lavenderblush2" "lavenderblush1" -"darkolivegreen" "lavenderblush" "aquamarine2" "red" "olivedrab2" -"mistyrose4" "mistyrose1" "lightcyan3" "lightcoral" "chartreuse" -"peachpuff" "palegreen" "mintcream" "skyblue2" "moccasin" "tomato1" -"orchid3" "maroon3" "salmon" "grey81" "grey62" "grey39" "grey38" -"grey37" "gray92" "gray83" "gray66" "gray54" "gray50" "gray30" "gray19" -"gray15" "azure4" "grey3" "tan3" "pink" "gray" "blue" "lightsteelblue2" -"lightsteelblue1" "green" "lightslategray" "lemonchiffon2" -"springgreen1" "greenyellow" "chartreuse2" "grey" "royalblue3" -"powderblue" "peachpuff2" "palegreen2" "cream" "slateblue" "seashell2" -"deeppink2" "darkkhaki" "maroon4" "sienna" "grey71" "grey67" "grey18" -"gray59" "gray43" "gray25" "bisque" "red1" "mediumslateblue" -"lightgoldenrod1" "goldenrod" "paleturquoise3" "lightskyblue4" "green" -"yellow" "smoke" "blue" "white" "steelblue4" "rosybrown3" "peachpuff1" -"palegreen1" "blueviolet" "seashell4" "sienna3" "grey40" "gray91" -"gray82" "gray5" "cyan2" "cyan1" "blue1" "snow" "lightgoldenrod2" -"lightslateblue" "mediumorchid3" "darkseagreen4" "springgreen3" "green" -"slategray4" "slategray3" "slategray2" "blue" "peachpuff4" "palegreen4" -"green" "orangered3" "goldenrod1" "ghostwhite" "firebrick4" "firebrick3" -"cadetblue3" "slategray" "seashell3" "honeydew3" "cornsilk4" "cornsilk2" -"purple1" "dimgrey" "khaki1" "ivory3" "grey70" "grey60" "grey32" -"grey22" "grey12" "gray98" "gray89" "gray71" "gray64" "gray60" "gray49" -"azure2" "gray3" "paleturquoise1" "mediumpurple1" "purple" -"lemonchiffon1" "blue" "navajowhite3" "darkorchid1" "orange" -"goldenrod2" "khaki" "chocolate2" "burlywood2" "honeydew1" "darkgreen" -"thistle3" "thistle2" "thistle1" "thistle" "maroon2" "maroon1" "grey53" -"grey44" "grey25" "gray74" "gray45" "gray41" "gray35" "gray27" "gray23" -"gray16" "brown4" "wheat" "coral" "tan4" "lightgoldenrodyellow" "blue" -"green" "gray" "palevioletred3" "mediumpurple4" "mediumpurple3" -"saddlebrown" "blue" "darkorchid4" "darkorchid3" "puff" "olivedrab4" -"lightblue4" "lightpink" "lightgray" "honeydew2" "cornsilk1" "lace" -"sienna1" "bisque4" "orchid" "khaki3" "grey84" "grey83" "grey82" -"grey72" "grey52" "grey43" "grey26" "grey14" "grey10" "gray75" "gray53" -"gray21" "gray20" "brown3" "grey8" "red2" "navy" "grey" "gold" -"mediumaquamarine" "lightgoldenrod" "darkslategray4" "darkseagreen3" -"darkseagreen2" "antiquewhite4" "white" "springgreen4" "lightyellow4" -"white" "aquamarine1" "turquoise3" "steelblue2" "rosybrown2" "pink" -"gray" "indianred2" "dodgerblue" "green" "seagreen1" "deeppink4" -"aliceblue" "magenta1" "pink" "sienna2" "orchid1" "gray100" "grey97" -"grey94" "grey87" "grey86" "grey51" "grey42" "grey19" "gray94" "gray85" -"gray61" "brown2" "khaki" "grey1" "gold4" "blue" "green" "grey" -"turquoise" "paleturquoise" "mediumorchid4" "antiquewhite2" -"lightyellow2" "violet" "salmon" "chartreuse1" "turquoise1" "sandybrown" -"orangered1" "lightpink1" "lightblue2" "lightblue1" "grey" "seagreen4" -"seagreen3" "lightblue" "deeppink3" "burlywood" "seashell" "hotpink1" -"gray" "yellow4" "yellow" "purple" "orange" "ivory4" "grey99" "grey89" -"grey63" "grey58" "grey49" "grey31" "grey24" "grey20" "green4" "green1" -"gray73" "gray67" "coral3" "coral2" "plum2" "pink4" "ivory" "gray4" -"gray2" "gold2" "aquamarine" "grey" "lightgoldenrod3" "darkolivegreen3" -"darkgoldenrod1" "goldenrod" "orchid" "chiffon" "navajowhite4" -"deepskyblue1" "lightyellow" "floralwhite" "blue" "mediumblue" -"chocolate4" "chocolate3" "burlywood4" "turquoise" "steelblue" "green" -"lawngreen" "honeydew4" "seagreen" "orchid4" "wheat1" "violet" "ivory1" -"grey88" "grey85" "grey57" "grey56" "grey55" "grey48" "grey47" "grey46" -"grey30" "grey17" "gray47" "gray29" "pink2" "grey5" "grey4" "green" -"gray0" "brown" "lightsteelblue4" "darkolivegreen4" "palevioletred4" -"blue" "darkslategray3" "darkslategray2" "darkslategray1" -"blanchedalmond" "palegoldenrod" "blue" "lightseagreen" "lemonchiffon3" -"darkslategray" "green" "darkseagreen" "antiquewhite" "darkorange2" -"chartreuse4" "blue" "rosybrown1" "olivedrab3" "lightpink2" "orangered" -"thistle4" "blue" "cornsilk" "salmon2" "orchid2" "ivory2" "grey93" -"grey92" "grey91" "grey36" "grey29" "grey28" "grey16" "gray79" "gray78" -"gray77" "gray48" "gray17" "coral4" "coral1" "plum1" "pink1" "grey9" -"grey2" "gray7" "cyan4" "blue3" "plum" "cornflowerblue" "lightskyblue2" -"antiquewhite1" "navajowhite2" "navajowhite1" "lightyellow3" -"navajowhite" "darkorange3" "whitesmoke" "turquoise2" "steelblue1" -"lightpink4" "lightblue3" "green" "chocolate1" "blue" "olivedrab" -"lightgrey" "chocolate" "magenta4" "magenta3" "yellow1" "purple3" -"purple2" "orange2" "orange1" "magenta" "bisque1" "wheat2" "maroon" -"khaki4" "grey96" "grey95" "grey80" "grey50" "grey41" "grey15" "grey11" -"gray80" "gray58" "gray40" "gray34" "gray22" "brown1" "snow3" -"mediumturquoise" "lightsteelblue3" "palevioletred2" "palevioletred1" -"paleturquoise2" "green" "palevioletred" "mediumorchid1" "white" -"mediumpurple" "lightyellow1" "dodgerblue2" "dodgerblue1" "violet" -"aquamarine3" "slategray1" "gray" "orangered4" "lightpink3" "blue" -"darkorchid" "cadetblue1" "burlywood3" "seashell1" "cornsilk3" "tomato4" -"tomato2" "wheat3" "grey98" "grey59" "grey23" "green3" "green2" "gray72" -"gray62" "gray52" "gray46" "gray42" "gray28" "gray24" "white" "cyan3" -"black" ) - '("Red" "Blue" "Purple" "Magenta" "Orange" "Yellow" "Green" "Brown" - "Dark Gray" "Light Gray" "Black" "Cyan") - )) - - -(defvar hproperty:color-ptr nil - "Pointer to current color name table to use for Hyperbole buttons.") - -(defconst hproperty:good-colors - (if (eq window-system 'x) - '( - "medium violet red" "indianred4" "firebrick1" "DarkGoldenrod" - "NavyBlue" "darkorchid" "tomato3" "mediumseagreen" "deeppink" - "forestgreen" "mistyrose4" "slategrey" "purple4" "dodgerblue3" - "mediumvioletred" "lightsalmon3" "orangered2" "turquoise4" "Gray55" - ) - hproperty:color-list) - "Good colors for contrast against wheat background and black foreground.") - - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -(defun hproperty:cycle-but-color (&optional color) - "Switches button color to optional COLOR name or next item referenced by hproperty:color-ptr." - (interactive "sHyperbole button color: ") - (if (not (display-color-p)) - nil - (if color (setq hproperty:color-ptr nil)) - (set-face-foreground - hproperty:but-face (or color (car (hproperty:list-cycle hproperty:color-ptr hproperty:good-colors)))) - (hproperty:set-flash-color) - (sit-for 0) ;; Force display update - t)) - -(defun hproperty:set-flash-color () - "Set button flashing colors based upon current color set." - (if (not (display-color-p)) - nil - (set-face-background hproperty:flash-face (hproperty:but-color)) - (set-face-foreground hproperty:flash-face (hproperty:background)))) - -(defun hproperty:but-p (&optional pos) - "Return non-nil at point or optional POS iff face is eq to hproperty:but-face." - (memq t (mapcar (function (lambda (props) - (eq (overlay-get props 'face) hproperty:but-face))) - (overlays-at (or pos (point)))))) - -(defun hproperty:set-but-face (pos face) - (let ((but (hproperty:but-get pos))) - (if but (overlay-put but 'face face)))) - -(defun hproperty:but-flash () - "Flash a Hyperbole button at or near point to indicate selection." - (interactive) - (let ((ibut) (prev) - (start (hattr:get 'hbut:current 'lbl-start)) - (end (hattr:get 'hbut:current 'lbl-end)) - (b) (a)) - (if (and start end (setq prev (hproperty:but-p start) - ibut t)) - (if (not prev) (hproperty:but-add start end hproperty:but-face)) - (setq start (point))) - (setq b (and (hproperty:but-p start) hproperty:but-face)) - (if (setq a b) - (progn - (hproperty:set-but-face start hproperty:flash-face) - (sit-for 0) ;; Force display update - ;; Delay before redraw button - (let ((i 0)) (while (< i hproperty:but-flash-time) (setq i (1+ i)))) - (hproperty:set-but-face start a) - (sit-for 0);; Force display update - )) - (if (and ibut (not prev)) (hproperty:but-delete start)) - )) - -(defun hproperty:set-item-highlight (&optional background foreground) - "Setup or reset item highlight face using optional BACKGROUND and FOREGROUND." - (make-local-variable 'hproperty:item-face) - (if (stringp background) (setq hproperty:item-highlight-color background)) - (if (not hproperty:highlight-face) - (progn - (setq hproperty:highlight-face (make-face 'hproperty:highlight-face)) - (set-face-foreground hproperty:highlight-face (or foreground - (hproperty:background))) - (set-face-underline-p hproperty:highlight-face nil))) - - (let ((update-rolo-highlight-flag - (and (boundp 'rolo-highlight-face) - (internal-facep rolo-highlight-face) - (or (null (face-foreground rolo-highlight-face)) - (face-equal hproperty:highlight-face rolo-highlight-face))))) - (if (not (equal (face-background hproperty:highlight-face) - hproperty:item-highlight-color)) - (set-face-background hproperty:highlight-face - hproperty:item-highlight-color)) - (and background (not (equal (face-background - hproperty:highlight-face) background)) - (set-face-background hproperty:highlight-face background)) - (and foreground (not (equal (face-foreground - hproperty:highlight-face) foreground)) - (set-face-foreground hproperty:highlight-face foreground)) - (setq hproperty:item-face hproperty:highlight-face) - (if update-rolo-highlight-flag - (copy-face hproperty:highlight-face rolo-highlight-face)))) - -(defun hproperty:select-item (&optional pnt) - "Select item in current buffer at optional position PNT using hproperty:item-face." - (if pnt (goto-char pnt)) - (skip-chars-forward " \t") - (skip-chars-backward "^ \t\n") - (let ((start (point))) - (save-excursion - (skip-chars-forward "^ \t\n") - (hproperty:but-add start (point) hproperty:item-face) - )) - (sit-for 0) ;; Force display update - ) - -(defun hproperty:select-line (&optional pnt) - "Select line in current buffer at optional position PNT using hproperty:item-face." - (if pnt (goto-char pnt)) - (save-excursion - (beginning-of-line) - (hproperty:but-add (point) (progn (end-of-line) (point)) hproperty:item-face)) - (sit-for 0) ;; Force display update - ) - -;;; ************************************************************************ -;;; Private variables -;;; ************************************************************************ - -(defvar hproperty:but-face (progn (make-face 'hbut) 'hbut) "Face for hyper-buttons.") -(setq hproperty:but hproperty:but-face) -(set-face-foreground hproperty:but-face (hproperty:but-color)) -(set-face-background hproperty:but-face (hproperty:background)) - -(defvar hproperty:flash-face (progn (make-face 'hbut-flash) 'hbut-flash) - "Face for flashing hyper-buttons.") -(hproperty:set-flash-color) - -(defvar hproperty:item-button nil - "Button used to highlight an item in a listing buffer.") -(make-variable-buffer-local 'hproperty:item-button) -(defvar hproperty:item-face nil "Item marking face.") -(defvar hproperty:highlight-face nil - "Item highlighting face. Use (hproperty:set-item-highlight) to set.") -(if hproperty:highlight-face - nil - ;; Reverse foreground and background colors for default block-style highlighting. - (hproperty:set-item-highlight (hproperty:foreground) (hproperty:background))) - -(provide 'hui-em19-b)
--- a/lisp/hyperbole/hui-ep-but.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,220 +0,0 @@ -;;!emacs -;; -;; FILE: hui-ep-but.el -;; SUMMARY: Support for highlighting/flashing buttons under Epoch. -;; USAGE: Epoch V4 Lisp Library -;; KEYWORDS: faces, hypermedia -;; -;; AUTHOR: Bob Weiner -;; ORG: Brown U. -;; -;; ORIG-DATE: 27-Apr-91 at 05:37:10 -;; LAST-MOD: 14-Apr-95 at 16:10:47 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; It is for use with Epoch, a modified version of GNU Emacs. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1990-1995, Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; -;; This is truly prototype code. -;; -;; Can't use epoch read-only buttons here because then outline-mode -;; becomes unusable; when it tries to do a 'subst-char-in-region' -;; epoch triggers a read-only error. -;; -;; DESCRIP-END. - -(if (and (boundp 'epoch::version) (stringp epoch::version) - (or noninteractive (string-lessp epoch::version "Epoch 4"))) - nil - (error "(hui-ep-but.el): Load only under Epoch version 3 or lower.")) - -;;; ************************************************************************ -;;; Other required Elisp libraries -;;; ************************************************************************ - -(require 'hbut) - -;;; ************************************************************************ -;;; Public variables -;;; ************************************************************************ - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -(fset 'hproperty:but-add 'epoch::add-button) - -(defun hproperty:but-color () - "Return current color of buffer's buttons." - (if hproperty:color-ptr - (car hproperty:color-ptr) - (epoch::foreground))) - -(defun hproperty:but-create-all (&optional start-delim end-delim regexp-match) - "Mark all hyper-buttons in buffer as Epoch buttons, for later highlighting. -Will use optional strings START-DELIM and END-DELIM instead of default values. -If END-DELIM is a symbol, e.g. t, then START-DELIM is taken as a regular -expression which matches an entire button string. -If REGEXP-MATCH is non-nil, only buttons matching this argument are -highlighted." - (ebut:map (function (lambda (lbl start end) - (hproperty:but-add start end hproperty:but))) - start-delim end-delim regexp-match 'include-delims)) - -(defun hproperty:but-delete (&optional pos) - (epoch::delete-button-at (or pos (point)))) - -;;; ************************************************************************ -;;; Private functions -;;; ************************************************************************ - -(defmacro hproperty:list-cycle (list-ptr list) - "Move LIST-PTR to next element in LIST or when at end to first element." - (` (or (and (, list-ptr) - (setq (, list-ptr) (cdr (, list-ptr)))) - (setq (, list-ptr) (, list))))) - -;;; ************************************************************************ -;;; Private variables -;;; ************************************************************************ - -(defconst hproperty:color-list '( "red" "blue" "paleturquoise4" "mediumpurple2" -"lightskyblue3" "springgreen2" "salmon" "yellowgreen" "darkorchid2" -"aquamarine4" "slateblue4" "slateblue1" "olivedrab1" "goldenrod4" -"goldenrod3" "cadetblue2" "burlywood1" "slategrey" "mistyrose" -"limegreen" "lightcyan" "goldenrod" "gainsboro" "skyblue1" "honeydew" -"yellow2" "tomato3" "skyblue" "purple4" "orange3" "bisque3" "bisque2" -"grey34" "gray99" "gray63" "gray44" "gray37" "gray33" "gray26" "azure1" -"snow4" "peru" "red" "lightgoldenrod4" "mediumseagreen" "blush" -"mediumorchid2" "lightskyblue1" "darkslateblue" "midnightblue" -"lightsalmon1" "lemonchiffon" "yellow" "lightsalmon" "coral" -"dodgerblue3" "darkorange4" "blue" "royalblue4" "red" "green" "cyan" -"darkviolet" "darksalmon" "darkorange" "blue" "pink" "magenta2" -"sienna4" "khaki2" "grey75" "grey74" "grey73" "grey69" "grey68" "grey35" -"grey13" "gray90" "gray81" "gray55" "gray51" "gray31" "snow2" "pink3" -"grey7" "gray1" "red4" "red3" "tan" "red" "yellow" "mediumvioletred" -"lightslategrey" "lavenderblush4" "turquoise" "darkturquoise" -"darkslategrey" "lightskyblue" "lightsalmon4" "lightsalmon3" -"forestgreen" "dodgerblue4" "orchid" "rosybrown4" "brown" "peachpuff3" -"palegreen3" "orangered2" "rose" "lightcyan4" "indianred4" "indianred3" -"seagreen2" "indianred" "deeppink1" "navyblue" "lavender" "grey" -"deeppink" "salmon4" "salmon3" "oldlace" "grey78" "grey77" "grey54" -"grey45" "grey21" "gray97" "gray96" "gray95" "gray88" "gray87" "gray86" -"gray70" "gray57" "gray38" "gray12" "gray11" "plum3" "linen" "gray9" -"gray8" "blue4" "beige" "turquoise" "blue" "lemonchiffon4" -"darkseagreen1" "antiquewhite3" "mediumorchid" "springgreen" -"turquoise4" "steelblue3" "mistyrose2" "lightcyan2" "red" "firebrick2" -"royalblue" "cadetblue" "skyblue3" "yellow3" "salmon1" "orange4" -"hotpink" "grey90" "gray56" "gray39" "gray18" "gray14" "plum4" "grey6" -"gray6" "gold3" "gold1" "blue2" "tan2" "cyan" "mediumspringgreen" -"darkolivegreen2" "goldenrod" "lightsteelblue" "brown" "whip" -"chartreuse3" "violetred4" "royalblue2" "royalblue1" "papayawhip" -"mistyrose3" "lightcyan1" "aquamarine" "skyblue4" "hotpink4" "hotpink3" -"hotpink2" "dimgray" "tomato" "grey66" "grey65" "grey64" "grey33" -"grey27" "gray76" "gray69" "gray68" "grey0" "azure" "green" -"darkgoldenrod4" "darkgoldenrod3" "darkgoldenrod2" "darkgoldenrod" -"brown" "lightsalmon2" "deepskyblue4" "deepskyblue3" "deepskyblue2" -"deepskyblue" "darkorange1" "violetred3" "violetred2" "violetred1" -"slateblue3" "slateblue2" "drab" "indianred1" "firebrick1" "cadetblue4" -"violetred" "rosybrown" "blue" "firebrick" "grey100" "wheat4" "grey79" -"grey76" "grey61" "gray93" "gray84" "gray65" "gray36" "gray32" "gray13" -"gray10" "azure3" "snow1" "tan1" "gray" "darkolivegreen1" "blue" -"almond" "lavenderblush3" "lavenderblush2" "lavenderblush1" -"darkolivegreen" "lavenderblush" "aquamarine2" "red" "olivedrab2" -"mistyrose4" "mistyrose1" "lightcyan3" "lightcoral" "chartreuse" -"peachpuff" "palegreen" "mintcream" "skyblue2" "moccasin" "tomato1" -"orchid3" "maroon3" "salmon" "grey81" "grey62" "grey39" "grey38" -"grey37" "gray92" "gray83" "gray66" "gray54" "gray50" "gray30" "gray19" -"gray15" "azure4" "grey3" "tan3" "pink" "gray" "blue" "lightsteelblue2" -"lightsteelblue1" "green" "lightslategray" "lemonchiffon2" -"springgreen1" "greenyellow" "chartreuse2" "grey" "royalblue3" -"powderblue" "peachpuff2" "palegreen2" "cream" "slateblue" "seashell2" -"deeppink2" "darkkhaki" "maroon4" "sienna" "grey71" "grey67" "grey18" -"gray59" "gray43" "gray25" "bisque" "red1" "mediumslateblue" -"lightgoldenrod1" "goldenrod" "paleturquoise3" "lightskyblue4" "green" -"yellow" "smoke" "blue" "white" "steelblue4" "rosybrown3" "peachpuff1" -"palegreen1" "blueviolet" "seashell4" "sienna3" "grey40" "gray91" -"gray82" "gray5" "cyan2" "cyan1" "blue1" "snow" "lightgoldenrod2" -"lightslateblue" "mediumorchid3" "darkseagreen4" "springgreen3" "green" -"slategray4" "slategray3" "slategray2" "blue" "peachpuff4" "palegreen4" -"green" "orangered3" "goldenrod1" "ghostwhite" "firebrick4" "firebrick3" -"cadetblue3" "slategray" "seashell3" "honeydew3" "cornsilk4" "cornsilk2" -"purple1" "dimgrey" "khaki1" "ivory3" "grey70" "grey60" "grey32" -"grey22" "grey12" "gray98" "gray89" "gray71" "gray64" "gray60" "gray49" -"azure2" "gray3" "paleturquoise1" "mediumpurple1" "purple" -"lemonchiffon1" "blue" "navajowhite3" "darkorchid1" "orange" -"goldenrod2" "khaki" "chocolate2" "burlywood2" "honeydew1" "darkgreen" -"thistle3" "thistle2" "thistle1" "thistle" "maroon2" "maroon1" "grey53" -"grey44" "grey25" "gray74" "gray45" "gray41" "gray35" "gray27" "gray23" -"gray16" "brown4" "wheat" "coral" "tan4" "lightgoldenrodyellow" "blue" -"green" "gray" "palevioletred3" "mediumpurple4" "mediumpurple3" -"saddlebrown" "blue" "darkorchid4" "darkorchid3" "puff" "olivedrab4" -"lightblue4" "lightpink" "lightgray" "honeydew2" "cornsilk1" "lace" -"sienna1" "bisque4" "orchid" "khaki3" "grey84" "grey83" "grey82" -"grey72" "grey52" "grey43" "grey26" "grey14" "grey10" "gray75" "gray53" -"gray21" "gray20" "brown3" "grey8" "red2" "navy" "grey" "gold" -"mediumaquamarine" "lightgoldenrod" "darkslategray4" "darkseagreen3" -"darkseagreen2" "antiquewhite4" "white" "springgreen4" "lightyellow4" -"white" "aquamarine1" "turquoise3" "steelblue2" "rosybrown2" "pink" -"gray" "indianred2" "dodgerblue" "green" "seagreen1" "deeppink4" -"aliceblue" "magenta1" "pink" "sienna2" "orchid1" "gray100" "grey97" -"grey94" "grey87" "grey86" "grey51" "grey42" "grey19" "gray94" "gray85" -"gray61" "brown2" "khaki" "grey1" "gold4" "blue" "green" "grey" -"turquoise" "paleturquoise" "mediumorchid4" "antiquewhite2" -"lightyellow2" "violet" "salmon" "chartreuse1" "turquoise1" "sandybrown" -"orangered1" "lightpink1" "lightblue2" "lightblue1" "grey" "seagreen4" -"seagreen3" "lightblue" "deeppink3" "burlywood" "seashell" "hotpink1" -"gray" "yellow4" "yellow" "purple" "orange" "ivory4" "grey99" "grey89" -"grey63" "grey58" "grey49" "grey31" "grey24" "grey20" "green4" "green1" -"gray73" "gray67" "coral3" "coral2" "plum2" "pink4" "ivory" "gray4" -"gray2" "gold2" "aquamarine" "grey" "lightgoldenrod3" "darkolivegreen3" -"darkgoldenrod1" "goldenrod" "orchid" "chiffon" "navajowhite4" -"deepskyblue1" "lightyellow" "floralwhite" "blue" "mediumblue" -"chocolate4" "chocolate3" "burlywood4" "turquoise" "steelblue" "green" -"lawngreen" "honeydew4" "seagreen" "orchid4" "wheat1" "violet" "ivory1" -"grey88" "grey85" "grey57" "grey56" "grey55" "grey48" "grey47" "grey46" -"grey30" "grey17" "gray47" "gray29" "pink2" "grey5" "grey4" "green" -"gray0" "brown" "lightsteelblue4" "darkolivegreen4" "palevioletred4" -"blue" "darkslategray3" "darkslategray2" "darkslategray1" -"blanchedalmond" "palegoldenrod" "blue" "lightseagreen" "lemonchiffon3" -"darkslategray" "green" "darkseagreen" "antiquewhite" "darkorange2" -"chartreuse4" "blue" "rosybrown1" "olivedrab3" "lightpink2" "orangered" -"thistle4" "blue" "cornsilk" "salmon2" "orchid2" "ivory2" "grey93" -"grey92" "grey91" "grey36" "grey29" "grey28" "grey16" "gray79" "gray78" -"gray77" "gray48" "gray17" "coral4" "coral1" "plum1" "pink1" "grey9" -"grey2" "gray7" "cyan4" "blue3" "plum" "cornflowerblue" "lightskyblue2" -"antiquewhite1" "navajowhite2" "navajowhite1" "lightyellow3" -"navajowhite" "darkorange3" "whitesmoke" "turquoise2" "steelblue1" -"lightpink4" "lightblue3" "green" "chocolate1" "blue" "olivedrab" -"lightgrey" "chocolate" "magenta4" "magenta3" "yellow1" "purple3" -"purple2" "orange2" "orange1" "magenta" "bisque1" "wheat2" "maroon" -"khaki4" "grey96" "grey95" "grey80" "grey50" "grey41" "grey15" "grey11" -"gray80" "gray58" "gray40" "gray34" "gray22" "brown1" "snow3" -"mediumturquoise" "lightsteelblue3" "palevioletred2" "palevioletred1" -"paleturquoise2" "green" "palevioletred" "mediumorchid1" "white" -"mediumpurple" "lightyellow1" "dodgerblue2" "dodgerblue1" "violet" -"aquamarine3" "slategray1" "gray" "orangered4" "lightpink3" "blue" -"darkorchid" "cadetblue1" "burlywood3" "seashell1" "cornsilk3" "tomato4" -"tomato2" "wheat3" "grey98" "grey59" "grey23" "green3" "green2" "gray72" -"gray62" "gray52" "gray46" "gray42" "gray28" "gray24" "white" "cyan3" -"black" )) - -(defvar hproperty:color-ptr nil - "Pointer to current color name table to use for Hyperbole buttons in Epoch.") - -(defconst hproperty:good-colors - '( - "medium violet red" "indianred4" "firebrick1" "DarkGoldenrod" "NavyBlue" - "darkorchid" "tomato3" "mediumseagreen" "deeppink" "forestgreen" - "mistyrose4" "slategrey" "purple4" "dodgerblue3" "mediumvioletred" - "lightsalmon3" "orangered2" "turquoise4" "Gray55" - ) - "Good colors for contrast against wheat background and black foreground.") - -(provide 'hui-ep-but) -
--- a/lisp/hyperbole/hui-epV4-b.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,214 +0,0 @@ -;;!emacs -;; -;; FILE: hui-epV4-b.el -;; SUMMARY: Support color and flashing of hyper-buttons under Epoch V4 -;; USAGE: Epoch Lisp Library -;; KEYWORDS: faces, hypermedia -;; -;; AUTHOR: Bob Weiner -;; ORG: Brown U. -;; -;; ORIG-DATE: 27-Apr-91 at 05:37:10 -;; LAST-MOD: 14-Apr-95 at 16:10:55 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; It is for use with Epoch, a modified version of GNU Emacs. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1991-1995, Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; -;; Requires Epoch 4.0a or greater. -;; -;; This is truly prototype code. -;; -;; DESCRIP-END. - -(if (and (boundp 'epoch::version) (stringp epoch::version) - (or noninteractive (not (string-lessp epoch::version "Epoch 4")))) - nil - (error "(hui-epV4-b.el): Load only under Epoch V4 or higher.")) - -(load "button") -(require 'hui-ep-but) - -(defun hproperty:background () - "Returns default background color for selected frame." - (epoch::background)) - -(defun hproperty:foreground () - "Returns default foreground color for selected frame." - (epoch::foreground)) - -;;; ************************************************************************ -;;; Public variables -;;; ************************************************************************ - -(defvar hproperty:item-highlight-color (foreground) - "Color with which to highlight list/menu selections. -Call (hproperty:set-item-highlight <color>) to change value.") - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -(defun hproperty:but-create (&optional start-delim end-delim regexp-match) - "Mark all hyper-buttons in buffer as Epoch buttons, for later highlighting. -Will use optional strings START-DELIM and END-DELIM instead of default values. -If END-DELIM is a symbol, e.g. t, then START-DELIM is taken as a regular -expression which matches an entire button string. -If REGEXP-MATCH is non-nil, only buttons matching this argument are -highlighted." - ;; Clear out Hyperbole button zones. - (hproperty:but-clear) - ;; Then recreate them. - (hproperty:but-create-all start-delim end-delim regexp-match)) - -(defun hproperty:but-clear () - "Delete all Hyperbole button zones from current buffer." - (interactive) - (mapcar (function (lambda (zone) - (if (eq (epoch::zone-style zone) hproperty:but) - (epoch::delete-zone zone)))) - (epoch::zone-list))) - -(defun hproperty:cycle-but-color (&optional color) - "Switches button color to optional COLOR name or next item referenced by hproperty:color-ptr." - (interactive "sHyperbole button color: ") - (if (<= (epoch::number-of-colors) 2) - nil - (if color (setq hproperty:color-ptr nil)) - (epoch::set-style-foreground - hproperty:but - (or color (car (hproperty:list-cycle - hproperty:color-ptr hproperty:good-colors)))) - (hproperty:set-flash-color) - (redraw-display) - t)) - -(defun hproperty:but-flash () - "Flash a Hyperbole button at point to indicate selection, when using Epoch." - (interactive) - (let ((ibut) (prev) - (start (hattr:get 'hbut:current 'lbl-start)) - (end (hattr:get 'hbut:current 'lbl-end)) - (b) (a)) - (if (and start end (setq prev (epoch::button-at start) - ibut t)) - (progn (if (not prev) (hproperty:but-add start end hproperty:but)) - (setq b (and start (epoch::button-at start)))) - (setq b (button-at (point)))) - (if (setq a (and (epoch::buttonp b) (epoch::button-style b))) - (progn - (epoch::set-button-style b hproperty:flash-face) - (epoch::redisplay-screen) - ;; Delay before redraw button - (let ((i 0)) (while (< i hproperty:but-flash-time) (setq i (1+ i)))) - (epoch::set-button-style b a) - (epoch::redisplay-screen) - )) - (if (and ibut (not prev)) (hproperty:but-delete start)) - )) - -(defun hproperty:set-item-highlight (&optional background foreground) - "Setup or reset item highlight style using optional BACKGROUND and FOREGROUND." - (make-local-variable 'hproperty:item-face) - (if (stringp background) (setq hproperty:item-highlight-color background)) - (if (not hproperty:highlight-face) - (progn - (setq hproperty:highlight-face (make-style)) - (set-style-foreground hproperty:highlight-face (background)) - (set-style-underline hproperty:highlight-face nil))) - - (let ((update-rolo-highlight-flag - (and (boundp 'rolo-highlight-face) (stylep rolo-highlight-face) - (or (null (style-foreground rolo-highlight-face)) - (equal (style-foreground hproperty:highlight-face) - (style-foreground rolo-highlight-face)))))) - (if (not (equal (style-background hproperty:highlight-face) - (get-color hproperty:item-highlight-color))) - (set-style-background hproperty:highlight-face - hproperty:item-highlight-color)) - (and background (not (equal (style-background hproperty:highlight-face) - (get-color background))) - (set-style-background hproperty:highlight-face background)) - (and foreground (not (equal (style-foreground hproperty:highlight-face) - (get-color foreground))) - (set-style-foreground hproperty:highlight-face foreground)) - (setq hproperty:item-face hproperty:highlight-face) - (if update-rolo-highlight-flag - (progn - (set-style-background rolo-highlight-face - (style-background hproperty:highlight-face)) - (set-style-foreground rolo-highlight-face - (style-foreground hproperty:highlight-face)) - (set-style-font rolo-highlight-face - (style-font hproperty:highlight-face)) - (set-style-underline rolo-highlight-face - (style-underline hproperty:highlight-face)))))) - -(defun hproperty:select-item (&optional pnt) - "Select item in current buffer at optional position PNT using hproperty:item-face." - (or hproperty:item-button - (setq hproperty:item-button (add-button (point) (point) hproperty:item-face))) - (if pnt (goto-char pnt)) - (skip-chars-forward " \t") - (skip-chars-backward "^ \t\n") - (let ((start (point))) - (save-excursion - (skip-chars-forward "^ \t\n") - (move-button hproperty:item-button start (point)) - )) - (epoch::redisplay-screen) - ) - -(defun hproperty:select-line (&optional pnt) - "Select line in current buffer at optional position PNT using hproperty:item-face." - (or hproperty:item-button - (setq hproperty:item-button (add-button (point) (point) hproperty:item-face))) - (if pnt (goto-char pnt)) - (save-excursion - (beginning-of-line) - (move-button hproperty:item-button (point) (progn (end-of-line) (point))) - ) - (epoch::redisplay-screen) - ) - -;;; ************************************************************************ -;;; Private functions -;;; ************************************************************************ - -(defun hproperty:set-flash-color () - "Set button flashing colors based upon current color set." - (if (<= (epoch::number-of-colors) 2) - nil - (epoch::set-style-background hproperty:flash-face (hproperty:but-color)) - (epoch::set-style-foreground hproperty:flash-face (hproperty:background)) - )) - -;;; ************************************************************************ -;;; Private variables -;;; ************************************************************************ - -(defvar hproperty:but (epoch::make-style) "Style for hyper-buttons.") -(epoch::set-style-foreground hproperty:but (hproperty:but-color)) -(epoch::set-style-background hproperty:but (hproperty:background)) - -(defvar hproperty:flash-face (epoch::make-style) - "Style for flashing hyper-buttons.") -(hproperty:set-flash-color) - -(defvar hproperty:item-button nil - "Button used to highlight an item in a listing buffer.") -(make-variable-buffer-local 'hproperty:item-button) -(defvar hproperty:item-face nil "Style for item marking.") -(defvar hproperty:highlight-face nil - "Item highlighting face. Use (hproperty:set-item-highlight) to set.") -(if hproperty:highlight-face - nil - ;; Reverse foreground and background colors for default block-style highlighting. - (hproperty:set-item-highlight (hproperty:foreground) (hproperty:background))) - -(provide 'hui-epV4-b)
--- a/lisp/hyperbole/hui-menu.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,342 +0,0 @@ -;;!emacs -;; -;; FILE: hui-menu.el -;; SUMMARY: InfoDock/Emacs menubar menu of Hyperbole commands. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: hypermedia, mouse -;; -;; AUTHOR: Bob Weiner -;; ORG: InfoDock Associates -;; -;; ORIG-DATE: 28-Oct-94 at 10:59:44 -;; LAST-MOD: 14-Mar-97 at 01:35:02 by Bob Weiner -;; -;; Copyright (C) 1994, 1995, 1996, 1997 Free Software Foundation, Inc. -;; -;; This file is part of Hyperbole. -;; -;; DESCRIPTION: -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Other required Elisp libraries -;;; ************************************************************************ - -(require 'wrolo-menu) - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -;; Add Hyperbole menu to menubar. -(defun hyperbole-menubar-menu () - "Add the Hyperbole menu to the global menubar." - (if hyperb:emacs19-p (require 'lmenu)) - (if (and (boundp 'current-menubar) - (or hyperb:emacs19-p current-menubar) - (not (car (find-menu-item current-menubar '("Hyperbole"))))) - (let ((add-before (if (and (boundp 'infodock-menubar-type) - (eq infodock-menubar-type 'menubar-infodock)) - "Key" nil))) - (if (fboundp 'add-submenu) - (add-submenu nil infodock-hyperbole-menu add-before) - (add-menu nil (car infodock-hyperbole-menu) - (cdr infodock-hyperbole-menu) add-before))))) - -;;; ************************************************************************ -;;; Public variables -;;; ************************************************************************ - -;; Ensure that this variable is defined to avert any error within -;; the Customization menu. -(defvar highlight-headers-follow-url-netscape-new-window nil - "*Whether to make Netscape create a new window when a URL is sent to it.") - -(defconst hui-menu-options - (append '("Display-Referents-in" - "----" - "----") - (mapcar (function (lambda (sym) - (vector - (capitalize (symbol-name sym)) - (` (setq hpath:display-where '(, sym))) - :style 'radio - :selected (` (eq hpath:display-where - '(, sym)))))) - (mapcar 'car hpath:display-where-alist)) - '("----" - "Display-URLs-in" - "----" - "----" - ["Here" - (setq action-key-url-function 'w3-fetch - highlight-headers-follow-url-function - action-key-url-function) - :style radio - :selected (eq action-key-url-function 'w3-fetch)] - ["Current-Netscape-Window" - (setq action-key-url-function - 'highlight-headers-follow-url-netscape - highlight-headers-follow-url-function - action-key-url-function - highlight-headers-follow-url-netscape-new-window - nil) - :style radio - :selected - (and (eq action-key-url-function - 'highlight-headers-follow-url-netscape) - (not highlight-headers-follow-url-netscape-new-window))] - ["New-Netscape-Window" - (setq action-key-url-function - 'highlight-headers-follow-url-netscape - highlight-headers-follow-url-function - action-key-url-function - highlight-headers-follow-url-netscape-new-window - t) - :style radio - :selected - (and (eq action-key-url-function - 'highlight-headers-follow-url-netscape) - highlight-headers-follow-url-netscape-new-window)] - ["Mosaic" - (setq action-key-url-function - 'highlight-headers-follow-url-mosaic - highlight-headers-follow-url-function - action-key-url-function) - :style radio - :selected (eq action-key-url-function - 'highlight-headers-follow-url-mosaic)] - ) - '("----" - "Smart-Key-Press-at-Eol" - "----" - "----" - ["Scrolls-a-Windowful" - (setq smart-scroll-proportional nil) - :style radio :selected (null smart-scroll-proportional)] - ["Scrolls-Proportionally" - (setq smart-scroll-proportional t) - :style radio :selected smart-scroll-proportional] - ) - '("----" - ["Toggle-Rolodex-Dates" rolo-toggle-datestamps - :style toggle :selected (and (boundp 'wrolo-add-hook) - (listp wrolo-add-hook) - (memq 'rolo-set-date wrolo-add-hook))] - )) - "Untitled menu of Hyperbole options.") - -;;; Don't change this name; doing so will break the way InfoDock -;;; initializes the Hyperbole menu. -(defconst infodock-hyperbole-menu - (delq nil - (list - "Hyperbole" - :config 'Hyperbole - '["About" (hypb:display-file-with-logo - (expand-file-name "ABOUT" hyperb:dir)) t] - '["Manual" (id-info "(hyperbole.info)Top") t] - "----" - '["Activate-Button-at-Point" hui:hbut-current-act t] - '["Back-to-Prior-Location" (hhist:remove current-prefix-arg) t] - '("Button-File" - ["Manual" (id-info "(hyperbole.info)Button Files") t] - "----" - ["Edit-Per-Directory-File" (find-file hbmap:filename) t] - ["Edit-Personal-File" (find-file - (expand-file-name - hbmap:filename hbmap:dir-user)) t] - ) - (cons "Customization" hui-menu-options) - '("Documentation" - ["Manual" (id-info "(hyperbole.info)Top") t] - "----" - ["Copyright" (id-info "(hyperbole.info)Top") t] - ["Demonstration" (find-file-read-only - (expand-file-name "DEMO" hyperb:dir)) t] - ["Manifest" (find-file-read-only - (expand-file-name "MANIFEST" hyperb:dir)) t] - ["Glossary" (id-info "(hyperbole.info)Glossary") t] - ["Mail-Lists" (id-info "(hyperbole.info)Mail Lists") t] - ["New-Features" (progn - (hact 'link-to-regexp-match - "\\*[ \t]+What's New" 2 - (expand-file-name "README" hyperb:dir)) - (setq buffer-read-only nil) - (toggle-read-only)) t] - ["Smart-Key-Summary" (id-browse-file (hypb:mouse-help-file)) t] - ) - '("Explicit-Button" - :filter hui-menu-explicit-buttons - ["Activate" hui:hbut-act t] - ["Create" hui:ebut-create t] - ["Delete" hui:ebut-delete t] - ["Edit" hui:ebut-modify t] - ("Help" - ["Manual" (id-info "(hyperbole.info)Location") t] - "----" - ["Buffer-Buttons" (hui:hbut-report -1) t] - ["Current-Button" (hui:hbut-report) t] - ["Ordered-Buttons" (hui:hbut-report 1) t] - ) - ["Modify" hui:ebut-modify t] - ["Rename" hui:ebut-rename t] - ["Search" hui:ebut-search t] - ) - '("Global-Button" - :filter hui-menu-global-buttons - ["Create" hui:gbut-create t] - ["Edit" hui:gbut-modify t] - ["Help" gbut:help t] - ["Modify" hui:gbut-modify t] - ) - '("Implicit-Button" - ["Manual" (id-info "(hyperbole.info)Implicit Buttons") t] - "----" - ["Activate-at-Point" hui:hbut-current-act t] - ["Delete-Type" (hui:htype-delete 'ibtypes) t] - ["Help" hui:hbut-help t] - ["Types" (hui:htype-help 'ibtypes 'no-sort) t] - ) - '("Mail-Lists" - ["Manual" (id-info "(hyperbole.info)Suggestion or Bug Reporting") - t] - "----" - ["Change-Hyperbole-Address" - (hmail:compose "hyperbole-request@infodock.com" - '(hact 'hyp-request)) t] - ["Change-Hyperbole-Announce-Address" - (hmail:compose "hyperbole-request@infodock.com" - '(hact 'hyp-request)) t] - ["Mail-to-Hyperbole-List" - (hmail:compose "hyperbole@infodock.com" '(hact 'hyp-config)) t] - ) - (if hyperb:kotl-p - '("Outline" - ["Manual" (id-info "(hyperbole.info)Outliner") t] - ["Example" (find-file-read-only - (expand-file-name - "EXAMPLE.kotl" (concat hyperb:dir "kotl/"))) - t] - "----" - ["Create-File" kfile:find t] - ["View-File" kfile:view t] - "----" - ["Collapse-Tree" (progn (kotl-mode:is-p) - (kotl-mode:hide-tree - (kcell-view:label))) t] - ["Create-Link" klink:create t] - ["Expand-All-Trees" kotl-mode:show-all t] - ["Expand-Tree" (progn (kotl-mode:is-p) - (kotl-mode:show-tree - (kcell-view:label))) t] - ["Show-Top-Level-Only" kotl-mode:hide-body t] - )) - infodock-wrolo-menu - '("Types" - ["Action-Types-Manual" - (id-info "(hyperbole.info)Action Types") t] - ["Implicit-Button-Types-Manual" - (id-info "(hyperbole.info)Implicit Buttons") t] - "----" - ["Action-Types" (hui:htype-help 'actypes) t] - ["Implicit-Button-Types" (hui:htype-help 'ibtypes 'no-sort) t] - ) - '("Window-Configuration" - ["Manual" (id-info "(hyperbole.info)Window Configurations") t] - "----" - ["Name-Configuration" wconfig-add-by-name t] - ["Delete-Name" wconfig-delete-by-name t] - ["Restore-Name" wconfig-restore-by-name t] - "----" - ["Pop-from-Ring" wconfig-delete-pop t] - ["Save-to-Ring" wconfig-ring-save t] - ["Yank-from-Ring" wconfig-yank-pop t] - ) - '["Quit" (progn - ;; Delete Hyperbole menu item from all menubars. - (mapcar - (function - (lambda (buf) - (set-buffer buf) - (if (assoc "Hyperbole" current-menubar) - (delete-menu-item '("Hyperbole"))))) - (buffer-list)) - ;; - ;; Remove Hyperbole button comment from future - ;; outgoing mail. - (if (boundp 'smail:comment) - (setq smail:comment ""))) - t] - ))) - -;;; ************************************************************************ -;;; Private functions -;;; ************************************************************************ - -(defvar hui-menu-max-list-length 24 - "Positive integer that caps the length of a dynamic menu list.") - -(defvar hui-menu-order-explicit-buttons t - "When non-nil (default), explicit button menu list is lexicographically ordered. -Otherwise, explicit buttons are listed in their order of appearance within -the current buffer.") - -;; List explicit buttons in the current buffer for menu activation. -(defun hui-menu-explicit-buttons (rest-of-menu) - (delq nil - (append - '(["Manual" (id-info "(hyperbole.info)Explicit Buttons") t] - "----") - (let ((labels (ebut:list)) - (cutoff)) - (if labels - (progn - ;; Cutoff list if too long. - (if (setq cutoff (nthcdr (1- hui-menu-max-list-length) labels)) - (setcdr cutoff nil)) - (delq nil - (append - '("----" - ["Alphabetize-List" - (setq hui-menu-order-explicit-buttons - (not hui-menu-order-explicit-buttons)) - :style toggle :selected hui-menu-order-explicit-buttons] - "Activate:") - (mapcar (function (lambda (label) - (vector label `(ebut:act ,label) t))) - (if hui-menu-order-explicit-buttons - (sort labels 'string-lessp) - labels)) - (if cutoff '(". . .")) - '("----" "----")))))) - rest-of-menu))) - -;; List existing global buttons for menu activation. -(defun hui-menu-global-buttons (rest-of-menu) - (delq nil - (append - '(["Manual" (id-info "(hyperbole.info)Global Buttons") t] - "----") - (let ((labels (gbut:label-list)) - (cutoff)) - (if labels - (progn - ;; Cutoff list if too long. - (if (setq cutoff (nthcdr (1- hui-menu-max-list-length) labels)) - (setcdr cutoff nil)) - (delq nil - (append - '("----" "Activate:") - (mapcar (function (lambda (label) - (vector label `(gbut:act ,label) t))) - (sort labels 'string-lessp)) - (if cutoff '(". . .")) - '("----" "----")))))) - rest-of-menu))) - -;;; ************************************************************************ -;;; Private variables -;;; ************************************************************************ - -(provide 'hui-menu)
--- a/lisp/hyperbole/hui-mini.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,561 +0,0 @@ -;;!emacs -;; -;; FILE: hui-mini.el -;; SUMMARY: One line command menus for Hyperbole -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: hypermedia, mouse -;; -;; AUTHOR: Bob Weiner -;; ORG: InfoDock Associates -;; -;; ORIG-DATE: 15-Oct-91 at 20:13:17 -;; LAST-MOD: 17-Mar-97 at 21:28:26 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1991-1997, Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Other required Elisp libraries -;;; ************************************************************************ - -(require 'hypb) - -;;; ************************************************************************ -;;; Public variables -;;; ************************************************************************ - -(defvar hui:menu-select "\C-m" - "*Upper case char-string which selects the Hyperbole menu item at point.") -(defvar hui:menu-quit "Q" - "*Upper case char-string which quits selecting from a Hyperbole menu item.") -(defvar hui:menu-abort "\C-g" - "*Same function as 'hui:menu-quit'.") -(defvar hui:menu-top "\C-t" - "*Character which returns to top Hyperbole menu.") - -(defvar hui:menu-p nil - "Non-nil iff a current Hyperbole menu activation exists.") - -(defvar hui:menus nil - "Command menus for use with the default Hyperbole user interface.") -(setq - hui:menus - (delq nil - (list (cons - 'hyperbole - (append - (let ((version (if (= (aref hyperb:version 0) ?0) - (substring hyperb:version 1) - hyperb:version))) - (list (list (concat "Hy" version ">")))) - (delq nil - (list - '("Act" hui:hbut-act - "Activates button at point or prompts for explicit button.") - '("Butfile/" (menu . butfile) - "Quick access button files menus.") - '("Cust/" (menu . cust) - "Customizes Hyperbole by setting major options.") - '("Doc/" (menu . doc) - "Quick access to Hyperbole documentation.") - '("Ebut/" (menu . ebut) - "Explicit button commands.") - '("Gbut/" (menu . gbut) - "Global button commands.") - '("Hist" (hhist:remove current-prefix-arg) - "Jumps back to location prior to last Hyperbole button follow.") - '("Ibut/" (menu . ibut) - "Implicit button and button type commands.") - '("Msg/" (menu . msg) - "Mail and News messaging facilities.") - (if hyperb:kotl-p - '("Otl/" (menu . otl) - "Autonumbered outlining and hyper-node facilities.")) - '("Rolo/" (menu . rolo) - "Hierarchical, multi-file rolodex lookup and edit commands.") - '("Win/" (menu . win) - "Window configuration management command.") - )))) - '(butfile . - (("Butfile>") - ("DirFile" (find-file hbmap:filename) - "Edits directory-specific button file.") - ("Info" - (id-info "(hyperbole.info)Button Files") - "Displays manual section on button files.") - ("PersonalFile" (find-file - (expand-file-name hbmap:filename hbmap:dir-user)) - "Edits user-specific button file.") - )) - '(cust . - (("Customize>") - ("Referent-Display/" (menu . cust-referents) - "Sets where referents are displayed.") - ("Smart-Key-at-Eol/" (menu . cust-eol) - "Sets how scrolling via end of line presses works.") - ("Toggle-Rolo-Dates" - (if (and (boundp 'wrolo-add-hook) (listp wrolo-add-hook) - (memq 'rolo-set-date wrolo-add-hook)) - (progn (remove-hook 'wrolo-add-hook 'rolo-set-date) - (remove-hook 'wrolo-edit-hook 'rolo-set-date) - (message "Rolodex date stamps are now turned off.")) - (add-hook 'wrolo-add-hook 'rolo-set-date) - (add-hook 'wrolo-edit-hook 'rolo-set-date) - (message "Rolodex date stamps are now turned on.")) - "Toggle whether date stamps are update when rolodex entries are edited.") - ("URL-Display/" (menu . cust-urls) "Sets where URLs are displayed."))) - '(cust-eol . - (("Smart Key press at eol scrolls>") - ("Proportionally" (setq smart-scroll-proportional t)) - ("Windowful" (setq smart-scroll-proportional nil)))) - '(cust-referents . - (("Ref display>") - ("Any-Frame" (setq hpath:display-where 'other-frame)) - ("Current-Win" (setq hpath:display-where 'this-window)) - ("Diff-Frame-One-Win" - (setq hpath:display-where 'other-frame-one-window)) - ("New-Frame" (setq hpath:display-where 'new-frame)) - ("Other-Win" (setq hpath:display-where 'other-window)) - ("Single-Win" (setq hpath:display-where 'one-window)))) - '(cust-urls . - (("URL display>") - ("Any-Netscape-Window" - (setq action-key-url-function 'highlight-headers-follow-url-netscape - highlight-headers-follow-url-function action-key-url-function - highlight-headers-follow-url-netscape-new-window nil)) - ("New-Netscape-Window" - (setq action-key-url-function 'highlight-headers-follow-url-netscape - highlight-headers-follow-url-function action-key-url-function - highlight-headers-follow-url-netscape-new-window t)) - ("Mosaic" (setq action-key-url-function - 'highlight-headers-follow-url-mosaic - highlight-headers-follow-url-function - action-key-url-function)) - ("W3-Browser" - (setq action-key-url-function 'w3-fetch - highlight-headers-follow-url-function - action-key-url-function)))) - '(doc . - (("Doc>") - ("About" (hypb:display-file-with-logo - (expand-file-name "ABOUT" hyperb:dir)) - "Overview of Hyperbole and InfoDock Associates.") - ("Demo" (find-file-read-only - (expand-file-name "DEMO" hyperb:dir)) - "Demonstrates Hyperbole features.") - ("Files" (find-file-read-only - (expand-file-name "MANIFEST" hyperb:dir)) - "Summarizes Hyperbole system files. Click on an entry to view it.") - ("Glossary" - (id-info "(hyperbole.info)Glossary") - "Glossary of Hyperbole terms.") - ("HypbCopy" (id-info "(hyperbole.info)Top") - "Displays general Hyperbole copyright and license details.") - ("Info" (id-info "(hyperbole.info)Top") - "Online Info version of Hyperbole manual.") - ("MailLists" (id-info "(hyperbole.info)Mail Lists") - "Details on Hyperbole mail list subscriptions.") - ("New" (progn - (hact 'link-to-regexp-match - "\\*[ \t]+What's New" 2 - (expand-file-name "README" hyperb:dir)) - (setq buffer-read-only nil) - (toggle-read-only)) - "Recent changes to Hyperbole.") - ("SmartKy" (find-file-read-only (hypb:mouse-help-file)) - "Summarizes Smart Key mouse or keyboard handling.") - ("Types/" (menu . types) - "Provides documentation on Hyperbole types.") - )) - '(ebut . - (("EButton>") - ("Act" hui:hbut-act - "Activates button at point or prompts for explicit button.") - ("Create" hui:ebut-create) - ("Delete" hui:ebut-delete) - ("Edit" hui:ebut-modify "Modifies any desired button attributes.") - ("Help/" (menu . ebut-help) "Summarizes button attributes.") - ("Info" - (id-info "(hyperbole.info)Explicit Buttons") - "Displays manual section on explicit buttons.") - ("Modify" hui:ebut-modify "Modifies any desired button attributes.") - ("Rename" hui:ebut-rename "Relabels an explicit button.") - ("Search" hui:ebut-search - "Locates and displays personally created buttons in context.") - )) - '(ebut-help . - (("Help on>") - ("BufferButs" (hui:hbut-report -1) - "Summarizes all explicit buttons in buffer.") - ("CurrentBut" (hui:hbut-report) - "Summarizes only current button in buffer.") - ("OrderedButs" (hui:hbut-report 1) - "Summarizes explicit buttons in lexicographically order.") - )) - '(gbut . - (("GButton>") - ("Act" gbut:act "Activates global button by name.") - ("Create" hui:gbut-create "Adds a global button to gbut:file.") - ("Edit" hui:gbut-modify "Modifies global button attributes.") - ("Help" gbut:help "Reports on a global button by name.") - ("Info" (id-info "(hyperbole.info)Global Buttons") - "Displays manual section on global buttons.") - ("Modify" hui:gbut-modify "Modifies global button attributes.") - )) - '(ibut . - (("IButton>") - ("Act" hui:hbut-current-act "Activates implicit button at point.") - ("DeleteIButType" (hui:htype-delete 'ibtypes) - "Deletes specified button type.") - ("Help" hui:hbut-help "Reports on button's attributes.") - ("Info" (id-info "(hyperbole.info)Implicit Buttons") - "Displays manual section on implicit buttons.") - ("Types" (hui:htype-help 'ibtypes 'no-sort) - "Displays documentation for one or all implicit button types.") - )) - '(msg . - (("Msg>") - ("Compose-Hypb-Mail" - (hmail:compose "hyperbole@infodock.com" '(hact 'hyp-config)) - "Send a message to the Hyperbole discussion list.") - ("Edit-Hypb-List-Entry" - (hmail:compose "hyperbole-request@infodock.com" - '(hact 'hyp-request)) - "Add, remove or change your entry on a the Hyperbole mail list.") - ("Modify-Hypb-Announce-Entry" - (hmail:compose "hyperbole-announce-request@infodock.com" - '(hact 'hyp-request)) - "Add, remove or change your entry on the Hyperbole Announce mail list.") - )) - (if hyperb:kotl-p - '(otl - . (("Otl>") - ("All" kotl-mode:show-all "Expand all collapsed cells.") - ("Blanks" kvspec:toggle-blank-lines - "Toggle blank lines between cells on or off.") - ("Create" kfile:find "Create or edit an outline file.") - ("Downto" kotl-mode:hide-sublevels - "Hide all cells in outline deeper than a particular level.") - ("Examp" (find-file-read-only - (expand-file-name - "EXAMPLE.kotl" (concat hyperb:dir "kotl/"))) - "Display a self-descriptive example outline file.") - ("Hide" (progn (kotl-mode:is-p) - (kotl-mode:hide-tree (kcell-view:label))) - "Collapse tree rooted at point.") - ("Info" - (id-info "(hyperbole.info)Outliner") - "Display manual section on Hyperbole outliner.") - ("Kill" kotl-mode:kill-tree - "Kill ARG following trees starting from point.") - ("Link" klink:create - "Create and insert an implicit link at point.") - ("Overvw" kotl-mode:overview - "Show first line of each cell.") - ("Show" (progn (kotl-mode:is-p) - (kotl-mode:show-tree (kcell-view:label))) - "Expand tree rooted at point.") - ("Top" kotl-mode:top-cells - "Hide all but top-level cells.") - ("Vspec" kvspec:activate - "Prompt for and activate a view specifiction.") - ))) - '(rolo . - (("Rolo>") - ("Add" rolo-add "Add a new rolo entry.") - ("Display" rolo-display-matches - "Display last found rolodex matches again.") - ("Edit" rolo-edit "Edit an existing rolo entry.") - ("Info" (id-info "(hyperbole.info)Rolodex") - "Displays manual section on Hyperbole rolodex.") - ("Kill" rolo-kill "Kill an existing rolo entry.") - ("Mail" rolo-mail-to "Mail to address following point.") - ("Order" rolo-sort "Order rolo entries in a file.") - ("RegexFind" rolo-grep "Find entries containing a regexp.") - ("StringFind" rolo-fgrep "Find entries containing a string.") - ("WordFind" rolo-word "Find entries containing words.") - ("Yank" rolo-yank - "Find an entry containing a string and insert it at point.") - )) - '(types . - (("Types>") - ("ActionTypes" (hui:htype-help 'actypes) - "Displays documentation for one or all action types.") - ("IButTypes" (hui:htype-help 'ibtypes 'no-sort) - "Displays documentation for one or all implicit button types.") - )) - '(win . - (("WinConfig>") - ("AddName" wconfig-add-by-name - "Name current window configuration.") - ("DeleteName" wconfig-delete-by-name - "Delete named window configuration.") - ("RestoreName" wconfig-restore-by-name - "Restore frame to window configuration given by name.") - ("PopRing" (progn (wconfig-delete-pop) - (hyperbole 'win)) - "Restores window configuration from ring and removes it from ring.") - ("SaveRing" (wconfig-ring-save) - "Saves current window configuration to ring.") - ("YankRing" (progn (call-interactively 'wconfig-yank-pop) - (hyperbole 'win)) - "Restores next window configuration from ring.") - )) - ))) - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -;;; Old name -(fset 'hui:menu 'hyperbole) - -;;; Used as autoloaded main entry point to Hyperbole (but hsite.el) is the -;;; file that is autoloaded when this is invoked. -;;; It brings up a menu of commands. -;;;###autoload -(defun hyperbole (&optional menu menu-list) - "Invokes default Hyperbole menu user interface when not already active. -Suitable for binding to a key, e.g. {C-h h}. -Non-interactively, returns t if menu is actually invoked by call, else nil. - -Two optional arguments may be given to invoke alternative menus. -MENU (a symbol) specifies the menu to invoke from MENU-LIST, (a -Hyperbole menu list structure). MENU defaults to 'hyperbole and MENU-LIST -to `hui:menus'. See `hui:menus' definition for the format of the menu list -structure." - - (interactive) - (if (and hui:menu-p (> (minibuffer-depth) 0)) - (progn (beep) nil) - (unwind-protect - (progn - (require 'hsite) ;; Since "hui-mini" may be loaded without loading - ;; all of Hyperbole. - (hyperb:init-menubar) - (setq hui:menu-p t) - (hui:menu-act (or menu 'hyperbole) menu-list) - t) - (setq hui:menu-p nil)))) - -(defun hui:menu-act (menu &optional menu-list) - "Prompts user with Hyperbole MENU (a symbol) and performs selected item. -Optional second argument MENU-LIST is a Hyperbole menu list structure from -which to extract MENU. It defaults to `hui:menus'. See its definition for -the menu list structure." - (let ((set-menu '(or (and menu (symbolp menu) - (setq menu-alist - (cdr (assq menu (or menu-list hui:menus))))) - (hypb:error "(menu-act): Invalid menu symbol arg: %s" - menu))) - (show-menu t) - (rtn) - menu-alist act-form) - (while (and show-menu (eval set-menu)) - (cond ((and (consp (setq act-form (hui:menu-select menu-alist))) - (cdr act-form) - (symbolp (cdr act-form))) - ;; Display another menu - (setq menu (cdr act-form))) - (act-form - (let ((prefix-arg current-prefix-arg)) - (cond ((symbolp act-form) - (if (eq act-form t) - nil - (setq show-menu nil - rtn (call-interactively act-form)))) - ((stringp act-form) - (hui:menu-help act-form) - ;; Loop and show menu again. - ) - (t (setq show-menu nil - rtn (eval act-form)))))) - (t (setq show-menu nil)))) - rtn)) - -(defun hui:menu-enter (&optional char-str) - "Uses CHAR-STR or last input character as minibuffer argument." - (interactive) - (let ((input (or char-str (aref (recent-keys) (1- (length (recent-keys))))))) - (cond (hyperb:emacs19-p - (and (not (integerp input)) - (eventp input) - (setq input (event-basic-type input)))) - (hyperb:lemacs-p - (if (eventp input) - (setq input (event-to-character input))))) - (if (or (symbolp input) - (and (integerp input) - (= input ?\r))) - (setq input (hargs:at-p))) - (erase-buffer) - (or (symbolp input) (insert input))) - (exit-minibuffer)) - -(defun hui:menu-help (help-str) - "Displays HELP-STR in a small window. HELP-STR must be a string." - (let* ((window-min-height 2) - (owind (selected-window)) - (buf-name (hypb:help-buf-name "Menu"))) - (unwind-protect - (progn - (save-window-excursion - (hkey-help-show buf-name)) ;; Needed to save wconfig. - (if (eq (selected-window) (minibuffer-window)) - (other-window 1)) - (if (= (length (hypb:window-list 'no-mini)) 1) - (split-window-vertically nil)) - (select-window (hui:bottom-window)) - (switch-to-buffer (get-buffer-create buf-name)) - (setq buffer-read-only nil) - (erase-buffer) - (insert "\n" help-str) - (set-buffer-modified-p nil) - (shrink-window - (- (window-height) - (+ 3 (length - (delq nil - (mapcar (function - (lambda (chr) (= chr ?\n))) - help-str))))))) - (select-window owind)))) - -(defun hui:menu-xemacs (&optional menu menu-list) - "Returns an XEmacs menu built from Hyperbole type menus. -Optional MENU (a symbol) specifies a specific submenu of optional MENU-LIST. -a Hyperbole menu list structure. Otherwise, all menus are used. -MENU defaults to 'hyperbole and MENU-LIST to `hui:menus'. See `hui:menus' -definition for the format of the menu list structure." - (mapcar - (function - (lambda (entry) - (or (consp entry) - (error "(hui:menu-xemacs): Invalid menu entry: %s" entry)) - (let ((label (car entry)) - (content (car (cdr entry)))) - (cond ((null content) (hypb:replace-match-string ">$" label "" t)) - ((and (consp content) (eq (car content) 'menu)) - (hui:menu-xemacs (cdr content))) - (t (vector label content 't)))))) - (cdr (assq (or menu 'hyperbole) (or menu-list hui:menus))))) - -(defun hui:menu-select (menu-alist) - "Prompts user to choose the first character of any item from MENU-ALIST. -Case is not significant. If chosen by direct selection with the Assist Key, -returns any help string for item, else returns the action form for the item." - (let* ((menu-line (hui:menu-line menu-alist)) - (set:equal-op 'eq) - (select-char (string-to-char hui:menu-select)) - (quit-char (string-to-char hui:menu-quit)) - (abort-char (string-to-char hui:menu-abort)) - (top-char (string-to-char hui:menu-top)) - (item-keys (mapcar (function - (lambda (item) (aref item 0))) - (mapcar 'car (cdr menu-alist)))) - (keys (apply 'list select-char quit-char abort-char - top-char item-keys)) - (key 0) - (hargs:reading-p 'hmenu) - sublist) - (while (not (memq (setq key (upcase - (string-to-char - (read-from-minibuffer - "" menu-line hui:menu-mode-map)))) - keys)) - (beep) - (setq hargs:reading-p 'hmenu) - (discard-input)) - (cond ((eq key quit-char) nil) - ((eq key abort-char) (beep) nil) - ((eq key top-char) '(menu . hyperbole)) - ((and (eq key select-char) - (save-excursion - (if (search-backward " " nil t) - (progn (skip-chars-forward " ") - (setq key (following-char)) - nil) ;; Drop through. - t)))) - (t (if (setq sublist (memq key item-keys)) - (let* ((label-act-help-list - (nth (- (1+ (length item-keys)) (length sublist)) - menu-alist)) - (act-form (car (cdr label-act-help-list)))) - (if (eq hargs:reading-p 'hmenu-help) - (let ((help-str - (or (car (cdr (cdr label-act-help-list))) - "No help documentation for this item."))) - (concat (car label-act-help-list) "\n " - help-str "\n Action: " - (prin1-to-string act-form))) - act-form))))))) - -;;; ************************************************************************ -;;; Private functions -;;; ************************************************************************ - -(if (fboundp 'window-lowest-p) - (defun hui:bottom-window () - "Return a window that is at the bottom of the selected frame." - (let ((winds (hypb:window-list 'no-mini)) - (window)) - (while (and (not window) winds) - (if (window-lowest-p (car winds)) - (setq window (car winds)) - (setq winds (cdr winds)))) - window)) - (defun hui:bottom-window () - "Return a window that is at the bottom of the selected frame." - (let* ((winds (hypb:window-list 'no-mini)) - (bot-list (mapcar - (function - (lambda (wind) - (nth 3 (window-edges wind)))) - winds)) - (bot (apply 'max bot-list))) - (nth (- (length winds) (length (memq bot bot-list))) winds)))) - -(defun hui:menu-line (menu-alist) - "Returns a menu line string built from MENU-ALIST." - (let ((menu-prompt (concat (car (car menu-alist)) " ")) - (menu-items (mapconcat 'car (cdr menu-alist) " ")) - menu-line) - (setq menu-line (concat menu-prompt menu-items)) - ;; Narrow menu by changing 2 spaces to 1 if too wide for current frame. - (if (>= (length menu-line) (1- (frame-width))) - (concat menu-prompt (mapconcat 'car (cdr menu-alist) " ")) - menu-line))) - -;;; ************************************************************************ -;;; Private variables -;;; ************************************************************************ - -;; Hyperbole menu mode is suitable only for specially formatted data. -(put 'hui:menu-mode 'mode-class 'special) - -(defvar hui:menu-mode-map nil - "Keymap containing hui:menu commands.") -(if hui:menu-mode-map - nil - (setq hui:menu-mode-map (make-keymap)) - (suppress-keymap hui:menu-mode-map) - (define-key hui:menu-mode-map hui:menu-quit 'hui:menu-enter) - (define-key hui:menu-mode-map hui:menu-abort 'hui:menu-enter) - (define-key hui:menu-mode-map hui:menu-top 'hui:menu-enter) - (define-key hui:menu-mode-map hui:menu-select 'hui:menu-enter) - ;; - ;; This next binding is necessary since the default button1 binding under - ;; XEmacs, mouse-track, is broken under XEmacs V19.8. - (and hyperb:lemacs-p window-system - (define-key hui:menu-mode-map 'button1 'mouse-set-point)) - (let ((i 32)) - (while (<= i 126) - (define-key hui:menu-mode-map (char-to-string i) 'hui:menu-enter) - (setq i (1+ i))))) - -(provide 'hui-mini)
--- a/lisp/hyperbole/hui-mouse.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1008 +0,0 @@ -;;!emacs -;; -;; FILE: hui-mouse.el -;; SUMMARY: Use key or mouse key for many functions, e.g. Hypb menus. -;; See the "${data-directory}/hypb-mouse.txt" file and the -;; documentation strings for functions herein. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: hypermedia, mouse -;; -;; AUTHOR: Bob Weiner -;; ORG: InfoDock Associates -;; -;; ORIG-DATE: 04-Feb-89 -;; LAST-MOD: 24-Apr-97 at 22:37:14 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1989-1995, Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; -;; This code is machine independent. It works best with a pointing device but -;; may also be used from a keyboard. When used with a pointing device it -;; requires an Emacs command that sets point to the location of the pointing -;; device's cursor. -;; -;; If you want to use your shift-middle mouse button to select Hyperbole menu -;; items and Hyperbole buttons, follow these instructions. -;; -;; If you plan to use a mouse only with X windows (Lucid Emacs, GNU Emacs -;; 19, or Epoch), NEXTSTEP, SunView, Apollo's DM, and you want to use the -;; shift-middle and shift-right buttons, you need not do any mouse -;; configuration. Your Emacs executable must have been built so as to -;; include the mouse support files for your window system, however. These -;; are in the Emacs "src" directory: for X "x*.c", for SunView "sunfns.c", -;; and for Apollo DM "apollo.c" and "apollo.el". -;; -;; To use a different mouse key or a different window system, modify the -;; mouse key bindings in "hmouse-key.el". -;; -;; Using the Action Mouse Key to browse through and delete files from -;; Dired listings is exceptionally nice, just as it is when reading mail. -;; -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Public variables -;;; ************************************************************************ - -(defvar hmouse-set-point-command nil - "*Command that sets point to mouse cursor position.") - -(defvar action-key-default-function 'hui:menu - "*Symbol name of function run by the Action Key in an unspecified context.") - -(defvar assist-key-default-function 'hkey-summarize - "*Symbol name of function run by the Assist Key in an unspecified context.") - -;;; ************************************************************************ -;;; Hyperbole context-sensitive keys dispatch table -;;; ************************************************************************ - -(defvar hkey-value nil - "Communicates a value between a Smart Key predicate and its actions.") - -(defvar hkey-alist - '( - ;; - ;; If click in the minibuffer and reading an argument, - ;; accept argument or give completion help. - ((and (> (minibuffer-depth) 0) - (eq (selected-window) (minibuffer-window)) - (not (eq hargs:reading-p 'hmenu))) . - ((exit-minibuffer) . (smart-completion-help))) - ;; - ;; If reading a Hyperbole menu item or a Hyperbole completion-based - ;; argument, allow selection of an item at point. - ((if (> (minibuffer-depth) 0) (setq hkey-value (hargs:at-p))) . - ((hargs:select-p hkey-value) . - (hargs:select-p hkey-value 'assist))) - ;; - ;; The ID-edit package supports rapid killing, copying, yanking and - ;; display management. It is available only as a part of InfoDock. - ;; It is not included with Hyperbole. - ((and (boundp 'id-edit-mode) id-edit-mode - (not buffer-read-only)) . - ((id-edit-yank) . (id-edit-yank))) - ;; - ((if (not (eobp)) - (or (eolp) (if selective-display - (= (following-char) ?\^M)))) . - ((smart-scroll-up) . (smart-scroll-down))) - ;; - ((eq major-mode 'smart-menu-mode) . - ((smart-menu-select) . (smart-menu-help))) - ;; - ;; If on a Hyperbole button, perform action or give help. - ((if (fboundp 'hbut:at-p) (or (hbut:at-p) (hbut:label-p))) . - ((hui:hbut-act 'hbut:current) . (hui:hbut-help 'hbut:current))) - ;; - ;; The Smart Menu system provides menus within Emacs on a dumb terminal. - ;; It is a part of InfoDock, but may also be obtained as a separate - ;; package. It is not included with Hyperbole. - ((and (fboundp 'smart-menu-choose-menu) - (setq hkey-value (and hkey-always-display-menu - (smart-menu-choose-menu))) - (not (and (get-buffer-window *smart-menu-buffer*) - (eq hkey-value *smart-menu-curr*)))) . - ((smart-menu hkey-value) . - (smart-menu hkey-value))) - ;; - ;; - ;; View minor mode - ((if (boundp 'view-minor-mode) view-minor-mode) . - ((cond ((last-line-p) - (view-quit)) - ((pos-visible-in-window-p (point-max)) - (goto-char (point-max))) - (t (scroll-up))) . - (scroll-down))) - ;; - ;; View major mode - ((eq major-mode 'view-mode) . - ((View-scroll-lines-forward) . (View-scroll-lines-backward))) - ;; - ((eq major-mode 'kotl-mode) . - ((kotl-mode:action-key) . (kotl-mode:help-key))) - ;; - ;; Rdb-mode Supports direct selection and viewing on in-memory relational - ;; databases. Rdb-mode is available only as a part of InfoDock. - ;; It is not included with Hyperbole. - ((eq major-mode 'rdb-mode) . ((smart-rdb) . (smart-rdb-assist))) - ;; - ;; Restore window config and hide help buffer when click at buffer end. - ((if (= (point) (point-max)) (string-match "Help\\*$" (buffer-name))) . - ((hkey-help-hide) . (hkey-help-hide))) - ;; - ((and (memq major-mode '(c-mode c++-c-mode)) - buffer-file-name (smart-c-at-tag-p)) . - ((smart-c) . (smart-c nil 'next-tag))) - ;; - ((and (eq major-mode 'asm-mode) - buffer-file-name (smart-asm-at-tag-p)) . - ((smart-asm) . (smart-asm nil 'next-tag))) - ;; - ((if (smart-lisp-mode-p) (smart-lisp-at-tag-p)) . - ((smart-lisp) . (smart-lisp 'next-tag))) - ;; - ((and (eq major-mode 'java-mode) buffer-file-name - (or (smart-java-at-tag-p) - ;; Also handle Java @see cross-references. - (looking-at "@see[ \t]+") - (save-excursion - (and (re-search-backward "[@\n\r\f]" nil t) - (looking-at "@see[ \t]+"))))) . - ((smart-java) . (smart-java nil 'next-tag))) - ;; - ((and (eq major-mode 'c++-mode) buffer-file-name - ;; Don't use smart-c++-at-tag-p here since it will prevent #include - ;; lines from matching. - (smart-c-at-tag-p)) . - ((smart-c++) . (smart-c++ nil 'next-tag))) - ;; - ((and (eq major-mode 'objc-mode) buffer-file-name - (smart-objc-at-tag-p)) . - ((smart-objc) . (smart-objc nil 'next-tag))) - ;; - ((and (eq major-mode 'fortran-mode) - buffer-file-name (smart-fortran-at-tag-p)) . - ((smart-fortran) . (smart-fortran nil 'next-tag))) - ;; - ((eq major-mode 'occur-mode) . - ((occur-mode-goto-occurrence) . (occur-mode-goto-occurrence))) - ;; - ((eq major-mode 'moccur-mode) . - ((moccur-mode-goto-occurrence) . (moccur-mode-goto-occurrence))) - ;; - ((eq major-mode 'calendar-mode) . - ((smart-calendar) . (smart-calendar-assist))) - ;; - ((eq major-mode 'unix-apropos-mode) . - ((smart-apropos) . (smart-apropos-assist))) - ;; - ((eq major-mode 'outline-mode) . - ((smart-outline) . (smart-outline-assist))) - ;; - ((eq major-mode 'Info-mode) . - ((smart-info) . (smart-info-assist))) - ;; - ((if (boundp 'hmail:reader) - (or (eq major-mode hmail:reader) - (eq major-mode hmail:lister))) . - ((smart-hmail) . (smart-hmail-assist))) - ;; - ((eq major-mode 'gnus-group-mode) - (smart-gnus-group) . (smart-gnus-group-assist)) - ;; - ((eq major-mode 'gnus-summary-mode) - (smart-gnus-summary) . (smart-gnus-summary-assist)) - ;; - ((eq major-mode 'gnus-article-mode) - (smart-gnus-article) . (smart-gnus-article-assist)) - ;; - ((eq major-mode 'Buffer-menu-mode) . - ((smart-buffer-menu) . (smart-buffer-menu-assist))) - ;; - ((eq major-mode 'dired-mode) . - ((smart-dired) . (smart-dired-assist))) - ;; - ((eq major-mode 'tar-mode) . - ((smart-tar) . (smart-tar-assist))) - ;; - ;; Follow references in man pages. - ((setq hkey-value (smart-man-entry-ref)) . - ((smart-man-display hkey-value) . - (smart-man-display hkey-value))) - ;; - ((eq major-mode 'w3-mode) . - ((w3-follow-link) . (w3-goto-last-buffer))) - ;; - ((if (boundp 'rolo-display-buffer) - (equal (buffer-name) rolo-display-buffer)) . - ((smart-wrolo) . (smart-wrolo-assist))) - ;; - ;; Gomoku game - ((eq major-mode 'gomoku-mode) . - ((gomoku-human-plays) . (gomoku-human-takes-back))) - ;; - ;; Support the OO-Browser, a part of InfoDock and XEmacs, and an add on - ;; to Emacs. It is not included with Hyperbole. - ((or (br-in-browser) (eq major-mode 'br-mode)) . - ((smart-br-dispatch) . (smart-br-assist-dispatch))) - ;; - ;; Outline minor mode is on and usable. - (selective-display . - ((smart-outline) . (smart-outline-assist))) - ) - "Alist of predicates and form-conses for Action and Assist Keys. -When the Action or Assist Key is pressed, the first or second form, -respectively, associated with the first non-nil predicate is evaluated.") - -;;; ************************************************************************ -;;; driver code -;;; ************************************************************************ - -;; The following autoload is needed if another subsystem besides -;; Hyperbole uses this mouse handling code. -(autoload 'var:append "hvar" "Append to a list variable." nil) - -(require 'hargs) -(require 'hmouse-key) -(if hyperb:window-system - (progn - (defvar hmouse-alist hkey-alist - "Alist of predicates and form-conses for context-sensitive smart key mouse actions. -When the action-key or the assist-key is pressed, the first or -second form, respectively, associated with the first non-nil predicate is -evaluated.") - (load "hui-window"))) - -;;; ************************************************************************ -;;; support code -;;; ************************************************************************ - -;; The 'load' line below loads any local Smart Key function definitions. -;; The public distribution contains none. You may leave it commented out if -;; you prefer. -;; (load "smart-local" t) - -;;; ************************************************************************ -;;; Required Init functions -;;; ************************************************************************ - -(defun first-line-p () - "Returns true if point is on the first line of the buffer." - (save-excursion (beginning-of-line) (bobp))) - -(defun last-line-p () - "Returns true if point is on the last line of the buffer." - (save-excursion (end-of-line) (eobp))) - -(defun smart-completion-help () - "Offer completion help for current minibuffer argument, if any." - (if (where-is-internal 'minibuffer-completion-help (current-local-map)) - (minibuffer-completion-help))) - -(defun smart-symlink-expand (path) - "Returns referent for possible symbolic link, PATH." - (if (not (fboundp 'symlink-referent)) - path - (let ((start 0) (len (length path)) (ref) (part)) - (while (and (< start len) (setq part (string-match "/[^/]*" path start))) - (setq part (concat ref - (substring path start (setq start (match-end 0)))) - ref (symlink-referent part))) - ref))) - -;;; ************************************************************************ -;;; smart-buffer-menu functions -;;; ************************************************************************ - -(defun smart-buffer-menu (&optional in-browser) - "Uses a single key or mouse key to manipulate buffer-menu entries. - -Invoked via a key press when in Buffer-menu-mode. It assumes that its -caller has already checked that the key was pressed in an appropriate buffer -and has moved the cursor there. - -Optional non-nil IN-BROWSER indicates use within the OO-Browser. - -If key is pressed: - (1) on the first column of an entry, the selected buffer is marked for - display; - (2) on the second column of an entry, the selected buffer is marked to be - saved; - (3) anywhere else within an entry line, all saves and deletes are done, and - selected buffers are displayed, including the one just clicked on (if - IN-BROWSER, only the selected buffer is displayed); - (4) on or after the last line in the buffer, all saves and deletes are done." - - (interactive) - (cond ((last-line-p) (Buffer-menu-execute)) - ((bolp) (Buffer-menu-mark)) - ((save-excursion - (goto-char (1- (point))) - (bolp)) - (Buffer-menu-save)) - (in-browser (br-buffer-menu-select)) - (t (Buffer-menu-select)))) - -(defun smart-buffer-menu-assist () - "Uses a single assist-key or mouse assist-key to manipulate buffer-menu entries. - -Invoked via an assist-key press when in Buffer-menu-mode. It assumes that its -caller has already checked that the assist-key was pressed in an appropriate -buffer and has moved the cursor there. - -If assist-key is pressed: - (1) on the first or second column of an entry, the selected buffer is unmarked - for display and for saving or deletion; - (2) anywhere else within an entry line, the selected buffer is marked for - deletion; - (3) on or after the last line in the buffer, all display, save, and delete - marks on all entries are undone." - - (interactive) - (cond ((last-line-p) (progn (list-buffers) (forward-line 3))) - ((bolp) (Buffer-menu-unmark)) - ((save-excursion - (goto-char (1- (point))) - (bolp)) - (Buffer-menu-unmark)) - (t (Buffer-menu-delete)))) - -;;; ************************************************************************ -;;; smart-calendar functions -;;; ************************************************************************ - -(defun smart-calendar () - "Uses a single key or mouse key to manipulate the scrolling calendar. - -Invoked via a key press when in calendar-mode. It assumes that its -caller has already checked that the key was pressed in an appropriate buffer -and has moved the cursor there. - -If key is pressed: - (1) at the end of the buffer, the calendar is scrolled forward 3 months; - (2) to the left of any dates on a calendar line, the calendar is scrolled - backward 3 months; - (3) on a date, the diary entries for the date, if any, are displayed." - - (interactive) - (cond ((eobp) (calendar-cursor-to-nearest-date) - (scroll-calendar-left-three-months 1)) - ((< (current-column) 5) (calendar-cursor-to-nearest-date) - (scroll-calendar-right-three-months 1)) - (t (calendar-cursor-to-nearest-date) - (view-diary-entries 1)))) - -(defun smart-calendar-assist () - "Uses a single assist-key or mouse assist-key to manipulate the scrolling calendar. - -Invoked via an assist-key press when in calendar-mode. It assumes that its -caller has already checked that the assist-key was pressed in an appropriate -buffer and has moved the cursor there. - -If assist-key is pressed: - (1) at the end of the buffer, the calendar is scrolled backward 3 months; - (2) to the left of any dates on a calendar line, the calendar is scrolled - forward 3 months; - (3) anywhere else, all dates with marking diary entries are marked in the - calendar window." - - (interactive) - (cond ((eobp) (calendar-cursor-to-nearest-date) - (scroll-calendar-right-three-months 1)) - ((< (current-column) 5) (calendar-cursor-to-nearest-date) - (scroll-calendar-left-three-months 1)) - (t (mark-diary-entries)))) - - -;;; ************************************************************************ -;;; smart-dired functions -;;; ************************************************************************ - -(defun smart-dired () - "Uses a single key or mouse key to manipulate directory entries. - -Invoked via a key press when in dired-mode. It assumes that its -caller has already checked that the key was pressed in an appropriate buffer -and has moved the cursor there. - -If key is pressed: - (1) within an entry line, the selected file/directory is displayed for - editing in the other window; - (2) on or after the last line in the buffer, if any deletes are to be - performed, they are executed after user verification, otherwise, this - dired invocation is quit." - - (interactive) - (cond ((last-line-p) - (let (flagged) - (save-excursion - (goto-char 1) - (setq flagged (re-search-forward "^D" nil t))) - (if flagged - (cond ((fboundp 'dired-do-deletions) - (dired-do-deletions)) - ;; For Tree-dired compatibility - ((fboundp 'dired-do-flagged-delete) - (dired-do-flagged-delete)) - (t (error "(smart-dired): No Dired expunge function."))) - (dired-quit)))) - (t (hpath:find (dired-get-filename))))) - -(defun smart-dired-assist () - "Uses a single assist-key or mouse assist-key to manipulate directory entries. - -Invoked via an assist-key press when in dired-mode. It assumes that its -caller has already checked that the assist-key was pressed in an appropriate -buffer and has moved the cursor there. - -If assist-key is pressed: - (1) on a '~' character, all backup files in the directory are marked for - deletion; - (2) on a '#' character, all auto-save files in the directory are marked for - deletion; - (3) anywhere else within an entry line, the current entry is marked for - deletion; - (4) on or after the last line in the buffer, all delete marks on all entries - are undone." - - (interactive) - (cond ((last-line-p) - (dired-unflag (- (count-lines (point-min) (point-max)))) - (goto-char (point-max))) - ((looking-at "~") (dired-flag-backup-files)) - ((looking-at "#") (dired-flag-auto-save-files)) - (t (if (fboundp 'dired-flag-file-deletion) - (dired-flag-file-deletion 1) - (dired-flag-file-deleted 1))))) - -;;; ************************************************************************ -;;; smart-gnus functions -;;; ************************************************************************ - -(defun smart-gnus-group () - "Uses a key or mouse key to move through Gnus Newsgroup listings. -Invoked via a key press when in gnus-group-mode. It assumes that its caller -has already checked that the key was pressed in an appropriate buffer and has -moved the cursor to the selected buffer. - -If key is pressed within: - (1) a GNUS-GROUP line, that newsgroup is read; - (2) to the left of any GNUS-GROUP line, on any of the whitespace, the current - group is unsubscribed or resubscribed; - (3) at the end of the GNUS-GROUP buffer, after all lines, checks for new - news." - - (interactive) - (cond ((last-line-p) (gnus-group-get-new-news)) - ((progn (skip-chars-backward " U") (bolp)) - (gnus-group-unsubscribe-current-group)) - (t (gnus-group-read-group nil)))) - -(defun smart-gnus-group-assist () - "Uses an assist-key or assist-mouse key to move through Gnus Newsgroup listings. -Invoked via an assist-key press when in gnus-group-mode. It assumes that its -caller has already checked that the key was pressed in an appropriate buffer -and has moved the cursor to the selected buffer. - -If key is pressed within: - (1) a GNUS-GROUP line, that newsgroup is read; - (2) to the left of any GNUS-GROUP line, on any of the whitespace, the user is - prompted for a group name to subscribe or unsubscribe to; - (3) at the end of the GNUS-GROUP buffer, after all lines, quits from the - newsreader." - - (interactive) - (cond ((last-line-p) (gnus-group-exit)) - ((progn (skip-chars-backward " U") (bolp)) - (call-interactively 'gnus-group-unsubscribe-group)) - (t (gnus-group-read-group nil)))) - -(defun smart-gnus-summary () - "Uses a key or mouse key to move through Gnus News article listings. -Invoked via a key press when in gnus-summary-mode. It assumes that its caller -has already checked that the key was pressed in an appropriate buffer and has -moved the cursor to the selected buffer. - -If key is pressed within: - (1) to the left of an article number, that article is marked as unread; - (2) a GNUS-SUMMARY line, that article is read, marked deleted, and scrolled - forward; - (3) at the end of the GNUS-SUMMARY buffer, the next undeleted article - is read or the next group is entered." - - (interactive) - (cond ((last-line-p) - (if gnus-current-article - (progn (goto-char (point-min)) - (re-search-forward - (format "^.[ ]+%d:" gnus-current-article) nil t) - (setq this-command 'gnus-summary-next-page) - (call-interactively 'gnus-summary-next-page)) - (goto-char (point-min)) - (setq this-command 'gnus-summary-first-unread-article) - (call-interactively 'gnus-summary-first-unread-article))) - ((save-excursion (skip-chars-backward " D") (bolp)) - (gnus-summary-mark-as-unread-forward 1)) - (t (setq this-command 'gnus-summary-next-page) - (call-interactively 'gnus-summary-next-page)))) - -(defun smart-gnus-summary-assist () - "Uses an assist-key or assist-mouse key to move through Gnus News articles. -Invoked via an assist-key press when in gnus-summary-mode. It assumes that its -caller has already checked that the key was pressed in an appropriate buffer -and has moved the cursor to the selected buffer. - -If key is pressed within: - (1) to the left of an article number, that article is marked as unread; - (2) a GNUS-SUMMARY line, that article is read and scrolled backward; - (3) at the end of the GNUS-SUMMARY buffer, the summary is exited, the user - is returned to group mode." - - (interactive) - (cond ((last-line-p) - (setq this-command 'gnus-summary-prev-page) - (call-interactively 'gnus-summary-exit)) - ((save-excursion (skip-chars-backward " D") (bolp)) - (gnus-summary-mark-as-unread-backward 1)) - (t (setq this-command 'gnus-summary-prev-page) - (call-interactively 'gnus-summary-prev-page)))) - -(defun smart-gnus-article () - "Uses a key or mouse key to move through Gnus netnews articles. - -Invoked via a key press when in gnus-article-mode. -It assumes that its caller has already checked that the key was pressed in an -appropriate buffer and has moved the cursor to the selected buffer. - -If key is pressed within: - (1) the first line or end of an article, the next unread message is displayed; - (2) the first line of an Info cross reference, the reference is followed; - (3) anywhere else, the window is scrolled up a windowful." - (interactive) - (cond ((or (last-line-p) (and (not (eolp)) (first-line-p))) - (unwind-protect - (progn (set-buffer gnus-summary-buffer) - (setq this-command 'gnus-summary-next-unread-article) - (gnus-summary-next-unread-article) - (gnus-summary-goto-subject gnus-current-article) - ) - (let ((artic (get-buffer-window gnus-article-buffer))) - (if artic (select-window artic))))) - ((and (not (eolp)) (Info-handle-in-note))) - (t (smart-scroll-up)))) - -(defun smart-gnus-article-assist () - "Uses an assist-key or mouse assist-key to move through Gnus netnews articles. - -Invoked via an assist-key press when in gnus-article-mode. -It assumes that its caller has already checked that the assist-key was pressed in -an appropriate buffer and has moved the cursor to the selected buffer. - -If assist-key is pressed within: - (1) the first line or end of an article, the previous message is displayed; - (2) the first line of an Info cross reference, the reference is followed; - (3) anywhere else, the window is scrolled down a windowful." - (interactive) - (cond ((or (last-line-p) (and (not (eolp)) (first-line-p))) - (unwind-protect - (progn (set-buffer gnus-summary-buffer) - (setq this-command 'gnus-summary-prev-article) - (gnus-summary-prev-article nil) - (gnus-summary-goto-subject gnus-current-article) - ) - (let ((artic (get-buffer-window gnus-summary-buffer))) - (if artic (select-window artic))))) - ((and (not (eolp)) (Info-handle-in-note))) - (t (smart-scroll-down)))) - -;;; ************************************************************************ -;;; smart-hmail functions -;;; ************************************************************************ - -(defun smart-hmail () - "Uses a key or mouse key to move through e-mail messages and summaries. - -Invoked via a key press when in hmail:reader or hmail:lister mode. -It assumes that its caller has already checked that the key was pressed in an -appropriate buffer and has moved the cursor to the selected buffer. - -If key is pressed within: - (1) a msg buffer, within the first line or at the end of a message, - the next undeleted message is displayed; - (2) a msg buffer within the first line of an Info cross reference, the - reference is followed; - (3) anywhere else in a msg buffer, the window is scrolled up a windowful; - (4) a msg summary buffer on a header entry, the message corresponding to - the header is displayed in the msg window; - (5) a msg summary buffer, on or after the last line, the messages marked - for deletion are expunged." - - (interactive) - ;; - ;; Branch on buffer type - ;; - (cond ((eq major-mode hmail:reader) - (cond ((or (last-line-p) (and (not (eolp)) (first-line-p))) - (rmail:msg-next)) - ((and (not (eolp)) (Info-handle-in-note))) - ((smart-scroll-up)))) - ;; - ;; Assume are in msg summary buffer - ;; - ((last-line-p) (lmail:expunge)) - (t (lmail:goto)))) - -(defun smart-hmail-assist () - "Uses an assist key or mouse key to move through e-mail messages and summaries. - -Invoked via an assist key press when in hmail:reader or hmail:lister mode. -It assumes that its caller has already checked that the assist-key was pressed in -an appropriate buffer and has moved the cursor to the selected buffer. - -If assist-key is pressed within: - (1) a msg buffer, within the first line or at the end of a message, - the previous undeleted message is displayed; - (2) a msg buffer within the first line of an Info cross reference, the - reference is followed; - (3) anywhere else in a msg buffer, the window is scrolled down a windowful; - (4) a msg summary buffer on a header entry, the message corresponding to - the header is marked as deleted; - (5) a msg summary buffer, on or after the last line, all messages are - marked undeleted." - - (interactive) - ;; - ;; Branch on buffer type - ;; - (cond ((eq major-mode hmail:reader) - (cond ((or (last-line-p) (and (not (eolp)) (first-line-p))) - (rmail:msg-prev)) - ((and (not (eolp)) (Info-handle-in-note))) - ((smart-scroll-down)))) - ;; - ;; Assume are in msg summary buffer - ;; - ((last-line-p) (lmail:undelete-all)) - (t (lmail:delete)))) - - -;;; ************************************************************************ -;;; smart-info functions -;;; ************************************************************************ -;;; Autoloaded in "hyperbole.el". - -;;; ************************************************************************ -;;; smart-man functions -;;; ************************************************************************ - -;; "unix-apropos.el" is a publicly available Emacs Lisp package that -;; allows man page browsing from apropos listings. "superman.el" is a -;; newer, much more complete package that you would probably prefer at -;; this point, but there is no Smart Key apropos support for it. There -;; is smart key support within the man page buffers it produces, however. -;; - -(defun smart-apropos () - "Moves through UNIX man apropos listings by using one key or mouse key. - -Invoked via a key press when in unix-apropos-mode. It assumes that -its caller has already checked that the key was pressed in an appropriate -buffer and has moved the cursor to the selected buffer. - -If key is pressed: - (1) on a UNIX man apropos entry, the man page for that entry is displayed in - another window; - (2) on or after the last line, the buffer in the other window is scrolled up - a windowful." - - (interactive) - (if (last-line-p) - (scroll-other-window) - (unix-apropos-get-man))) - -(defun smart-apropos-assist () - "Moves through UNIX man apropos listings by using one assist-key or mouse assist-key. - -Invoked via an assist-key press when in unix-apropos-mode. It assumes that -its caller has already checked that the assist-key was pressed in an appropriate -buffer and has moved the cursor to the selected buffer. - -If assist-key is pressed: - (1) on a UNIX man apropos entry, the man page for that entry is displayed in - another window; - (2) on or after the last line, the buffer in the other window is scrolled down - a windowful." - - (interactive) - (if (last-line-p) - (scroll-other-window (- 3 (window-height))) - (unix-apropos-get-man))) - -(defun smart-man-display (lisp-form) - "Evaluates LISP-FORM returned from 'smart-man-entry-ref' to display a man page." - (eval lisp-form)) - -(defun smart-man-entry-ref () - "Returns form which displays referenced manual entry that point is on or nil. -Handles references in sections: NAME, SEE ALSO, or PACKAGES USED. Also can -display C routine definitions selected in a man page, see -'smart-man-c-routine-ref'. - -Man page buffer must either have an attached file or else a `man-path' -local variable containing its pathname." - (interactive) - (let ((ref "")) - (if (not (or (if (string-match "Manual Entry\\|\\*man " - (buffer-name (current-buffer))) - (progn (and (boundp 'man-path) man-path - (setq ref (smart-symlink-expand man-path))) - t)) - (if buffer-file-name - (string-match "/man/" (setq ref (smart-symlink-expand - buffer-file-name)))))) - (setq ref nil) - (or (setq ref (or (smart-man-file-ref) - (smart-man-c-routine-ref))) - (save-excursion - (let ((opoint (point)) - (case-fold-search)) - (and - (re-search-backward "^[.A-Z]" nil t) - (looking-at - "\\(\\.SH[ \t]+\\)?\\(SEE ALSO\\|NAME\\|PACKAGES USED\\)") - (progn (goto-char opoint) - (skip-chars-backward "-_a-zA-Z0-9?.(") - (let ((start (point))) - (skip-chars-forward "-_a-zA-Z0-9?.()") - (setq ref (buffer-substring start (point))) - ;; Leave only one char within ref parens - (if ref - (if (string-match "(\\(.\\)\\(.+\\))" ref) - (setq ref (concat (substring ref 0 (match-end 1)) - "\)")))) - ))))))) - (cond ((equal ref "") nil) - ((stringp ref) (list 'manual-entry ref)) - (t ref)))) - -(defun smart-man-c-routine-ref () - "Returns form to jump to def of C function whose name is at point, if any. -Valid sections within the man page are: ROUTINES, MACROS or FUNCTIONS. -Uses (smart-tags-file) function to determine etags file from which to -locate the definition. - -Returns etags file name if point is on an identifier in the appropriate -section and the jump is done, otherwise, returns nil." - (let ((ref) - (opoint (point)) - (case-fold-search)) - (save-excursion - (and (re-search-backward "^[.A-Z]" nil t) - (looking-at "^\\(FUNCTIONS\\|ROUTINES\\|MACROS\\)[ \t\n]") - (progn (goto-char opoint) - (skip-chars-backward "_~<>:a-zA-Z0-9(") - (if (or (looking-at "\\([_~<>:a-zA-Z0-9]+\\)[ \t\n]*(") - (looking-at "\\([_~<:A-Z][_<>:A-Z0-9]+\\)")) - (setq ref (buffer-substring - (match-beginning 1) (match-end 1)) - ))))) - (if ref - (let ((tags-file-name - (smart-tags-file (if (and (boundp 'man-path) man-path) - man-path - default-directory)))) - (and (file-exists-p tags-file-name) - (file-readable-p tags-file-name) - (list 'let (list (list 'tags-file-name tags-file-name)) - (list (if (br-in-browser) - 'find-tag 'find-tag-other-window) - ref))))))) - -(defun smart-man-file-ref () - "Returns form to eval to display file whose name point is on, within a FILES man page section. -If not on a file name, returns nil." - (let ((ref) - (opoint (point)) - (case-fold-search)) - (save-excursion - (and (re-search-backward "^[.A-Z]" nil t) - (looking-at "^FILES[ \t\n]") - (progn (goto-char opoint) - (skip-chars-backward "^ \t") - (if (looking-at "/[^ \t\n]+") - (setq ref (buffer-substring - (match-beginning 0) (match-end 0)) - ))))) - (if ref - (list (if (br-in-browser) - 'find-file 'find-file-other-window) - ref)))) - -;;; ************************************************************************ -;;; smart-outline functions -;;; ************************************************************************ - -;; The functions in this section require InfoDock's version of outline.el -;; in order to work properly. - -(defvar smart-outline-cut nil - "Non-nil means outline region was cut and is ready to be pasted at point.") - -(let ((proc - '((lambda () - (make-local-variable 'smart-outline-cut) - ;; Non-nil means outline region was cut and is available to be - ;; pasted at point. - (setq smart-outline-cut nil) - )))) - (if (boundp 'outline-mode-map) - (eval proc) - (var:append 'outline-mode-hook proc))) - -(defun smart-outline () - "Collapses, expands, and moves outline entries. -Invoked via a key press when in outline-mode. It assumes that -its caller has already checked that the key was pressed in an appropriate -buffer and has moved the cursor to the selected buffer. - -If key is pressed: - (1) after an outline heading has been cut via the Action Key, then paste the - cut heading at point; - (2) at the end of buffer, show all buffer text - (3) at the beginning of a heading line, cut the headings subtree from the - buffer; - (4) on a header line but not at the beginning or end, if headings subtree is - hidden then show it, otherwise hide it; - (5) anywhere else, scroll up a windowful." - - (interactive) - (cond (smart-outline-cut - (setq smart-outline-cut nil) (yank)) - ((eobp) (show-all)) - ((and (bolp) (looking-at outline-regexp)) - (setq smart-outline-cut t) - (kill-region - (point) - (or (outline-get-next-sibling) - ;; Skip past start of current entry - (progn (re-search-forward outline-regexp nil t) - (smart-outline-to-entry-end t (outline-level)))))) - - ((or (eolp) (zerop (save-excursion (beginning-of-line) - (outline-level)))) - (smart-scroll-up)) - ;; On an outline header line but not at the start/end of line. - ((smart-outline-subtree-hidden-p) - (show-subtree)) - (t (hide-subtree)))) - - -(defun smart-outline-assist () - "Collapses, expands, and moves outline entries. -Invoked via an assist-key press when in outline-mode. It assumes that -its caller has already checked that the assist-key was pressed in an appropriate -buffer and has moved the cursor to the selected buffer. - -If assist-key is pressed: - (1) after an outline heading has been cut via the action-key, allow multiple - pastes throughout the buffer (last paste should be done with the Action Key, - not the Assist Key); - (2) at the end of buffer, hide all bodies in buffer; - (3) at the beginning of a heading line, cut the current heading (sans - subtree) from the buffer; - (4) on a header line but not at the beginning or end, if heading body is - hidden then show it, otherwise hide it; - (5) anywhere else, scroll down a windowful." - - (interactive) - (cond (smart-outline-cut (yank)) - ((eobp) (hide-body )) - ((and (bolp) (looking-at outline-regexp)) - (setq smart-outline-cut t) - (kill-region (point) - ;; Skip past start of current entry - (progn (re-search-forward outline-regexp nil t) - (smart-outline-to-entry-end - nil (outline-level))))) - ((or (eolp) (zerop (save-excursion (beginning-of-line) - (outline-level)))) - (smart-scroll-down)) - ;; On an outline header line but not at the start/end of line. - ((smart-outline-subtree-hidden-p) - (show-entry)) - (t (hide-entry)))) - -(defun smart-outline-to-entry-end - (&optional include-sub-entries curr-entry-level) - "Goes to end of whole entry if optional INCLUDE-SUB-ENTRIES is non-nil. -CURR-ENTRY-LEVEL is an integer representing the length of the current level -string which matched to 'outline-regexp'. If INCLUDE-SUB-ENTRIES is nil, -CURR-ENTRY-LEVEL is not needed." - (let (next-entry-exists) - (while (and (setq next-entry-exists - (re-search-forward outline-regexp nil t)) - include-sub-entries - (save-excursion - (beginning-of-line) - (> (outline-level) - curr-entry-level)))) - (if next-entry-exists - (progn (beginning-of-line) (point)) - (goto-char (point-max))))) - -(defun smart-outline-subtree-hidden-p () - "Returns t if at least initial subtree of heading is hidden, else nil." - (save-excursion - (if (re-search-forward "[\n\^M]" nil t) (= (preceding-char) ?\^M)))) - -;;; ************************************************************************ -;;; smart-tar functions -;;; ************************************************************************ - -(defun smart-tar () - "Uses a single key or mouse key to manipulate tar file entries. - -Invoked via a key press when in tar-mode. It assumes that its -caller has already checked that the key was pressed in an appropriate buffer -and has moved the cursor there. - -If key is pressed: - (1) within an entry line, the selected file/directory is displayed for - editing in the other window; - (2) on or after the last line in the buffer, if any deletes are to be - performed, they are executed after user verification, otherwise, this - tar file browser is quit." - - (interactive) - (cond ((last-line-p) - (let (flagged) - (save-excursion - (goto-char 1) - (setq flagged (re-search-forward "^D" nil t))) - (if flagged - (tar-expunge) - (kill-buffer nil)))) - (t (tar-extract-other-window)))) - -(defun smart-tar-assist () - "Uses a single assist-key or mouse assist-key to manipulate tar file entries. - -Invoked via an assist-key press when in dired-mode. It assumes that its -caller has already checked that the assist-key was pressed in an appropriate -buffer and has moved the cursor there. - -If assist-key is pressed: - (1) on an entry line, the current entry is marked for deletion; - (2) on or after the last line in the buffer, all delete marks on all entries - are undone." - - (interactive) - (cond ((last-line-p) - (tar-unflag (- (count-lines (point-min) (point-max)))) - (goto-char (point-max))) - (t (tar-flag-deleted 1)))) - -;;; ************************************************************************ -;;; smart-wrolo functions -;;; ************************************************************************ - -(defun smart-wrolo () - "In wrolo match buffer, edits current entry. -Uses one key or mouse key. - -Invoked via a key press when in the 'rolo-display-buffer'. It assumes that -its caller has already checked that the key was pressed in an appropriate -buffer and has moved the cursor to the selected buffer." - (interactive) - (rolo-edit-entry)) - -(fset 'smart-wrolo-assist 'smart-wrolo) - -(provide 'hui-mouse)
--- a/lisp/hyperbole/hui-window.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,651 +0,0 @@ -;;!emacs -;; -;; FILE: hui-window.el -;; SUMMARY: Smart Mouse Key window and modeline depress/release actions. -;; USAGE: GNU Emacs Lisp Library, Load only when mouse is available. -;; KEYWORDS: hypermedia, mouse -;; -;; AUTHOR: Bob Weiner -;; ORG: Motorola, Inc., PWDG -;; -;; ORIG-DATE: 21-Sep-92 -;; LAST-MOD: 6-Oct-95 at 12:56:48 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1992-1995, Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; -;; Must be loaded AFTER hmouse-alist has been defined in -;; "hui-mouse.el". -;; -;; Handles drags in same window or across windows and modeline depresses. -;; -;; What drags and modeline presses do. -;; ============================================================================== -;; Smart Keys -;; Context Action Key Assist Key -;; ============================================================================== -;; Drag horizontally within window -;; Left to right Scroll to buffer end Split window across -;; Right to left Scroll to buffer begin Delete window -;; Click in modeline -;; Left window edge Bury buffer Unbury bottom buffer -;; Right window edge Info Smart Key Summary -;; Otherwise Action Key Hook Assist Key Hook -;; Modeline depress & wind release Resize window height <- same -;; Drag from shared window side Resize window's width <- same -;; Drag from one window to another Create/modify a link but Swap buffers -;; Drag vertically within window Split window sideways <- same -;; Drag diagonally within window Save ring frame-config Restore ring config -;; -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Public variables -;;; ************************************************************************ - -(defvar action-key-modeline-hook 'hmouse-context-menu - "A list of functions to call when the Action Mouse Key is clicked in the center portion of a modeline.") - -(defvar assist-key-modeline-hook nil - "A list of functions to call when the Assist Mouse Key is clicked in the center portion of a modeline.") - -(defvar hmouse-edge-sensitivity 3 - "*Number of characters from window edges within which a click is considered at an edge.") - -(defvar hmouse-side-sensitivity (if hyperb:emacs19-p 2 1) - "*Characters in either direction from window side within which a click is considered on the side.") - -(defvar hmouse-x-drag-sensitivity 5 - "*Number of chars mouse must move horizontally between depress/release to register a horizontal drag.") - -(defvar hmouse-y-drag-sensitivity 3 - "*Number of lines mouse must move vertically between depress/release to register a vertical drag.") - -(defvar hmouse-x-diagonal-sensitivity 4 - "*Number of chars mouse must move horizontally between depress/release to register a diagonal drag.") -(defvar hmouse-y-diagonal-sensitivity 3 - "*Number of lines mouse must move vertically between depress/release to register a diagonal drag.") - -;;; -;;; Add mode line handling to hmouse-alist dispatch table. -;;; -(if (not (boundp 'hmouse-alist)) - (error - "\"hui-modeln.el\": hmouse-alist must be defined before loading this.") - (or (memq 'hmouse-drag-window-side - (mapcar (function (lambda (elt) (let ((pred (car elt))) - (if (listp pred) (car pred))))) - hmouse-alist)) - (setq hmouse-alist - (append - '( - ((hmouse-drag-window-side) . - ((hmouse-resize-window-side) . - (hmouse-resize-window-side 'assist))) - ((setq hkey-value - (and (not (hmouse-drag-between-windows)) - (hmouse-drag-horizontally))) . - ((hmouse-horizontal) . (hmouse-horizontal-assist))) - ((hmouse-modeline-depress) . - ((action-key-modeline) . (assist-key-modeline))) - ((hmouse-drag-between-windows) . - ((hui:link-directly) . (hmouse-swap-buffers 'assist))) - ((hmouse-drag-vertically) . - ((sm-split-window-horizontally) . - (sm-split-window-horizontally))) - ((setq hkey-value (hmouse-drag-diagonally)) . - ((wconfig-ring-save) . - (wconfig-yank-pop - (prefix-numeric-value current-prefix-arg)))) - ) - hmouse-alist)))) - - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -(defun hmouse-drag-between-windows () - "Returns non-nil if last Action Key depress and release were in different windows. -If free variable 'assist-flag' is non-nil, uses Assist Key." - (if assist-flag - (and assist-key-depress-window assist-key-release-window - (not (eq assist-key-depress-window - assist-key-release-window))) - (and action-key-depress-window action-key-release-window - (not (eq action-key-depress-window action-key-release-window))))) - -(defun hmouse-drag-diagonally () - "Returns non-nil iff last Action Key use was a diagonal drag within a single window. -If free variable 'assist-flag' is non-nil, uses Assist Key. -Value returned is nil if not a diagonal drag, or one of the following symbols -depending on the direction of the drag: southeast, southwest, northwest, northeast." - (let ((last-depress-x) (last-release-x) - (last-depress-y) (last-release-y)) - (if assist-flag - (setq last-depress-x (hmouse-x-coord assist-key-depress-args) - last-release-x (hmouse-x-coord assist-key-release-args) - last-depress-y (hmouse-y-coord assist-key-depress-args) - last-release-y (hmouse-y-coord assist-key-release-args)) - (setq last-depress-x (hmouse-x-coord action-key-depress-args) - last-release-x (hmouse-x-coord action-key-release-args) - last-depress-y (hmouse-y-coord action-key-depress-args) - last-release-y (hmouse-y-coord action-key-release-args))) - (and last-depress-x last-release-x last-depress-y last-release-y - (>= (- (max last-depress-x last-release-x) - (min last-depress-x last-release-x)) - hmouse-x-diagonal-sensitivity) - (>= (- (max last-depress-y last-release-y) - (min last-depress-y last-release-y)) - hmouse-y-diagonal-sensitivity) - (cond - ((< last-depress-x last-release-x) - (if (< last-depress-y last-release-y) - 'southeast 'northeast)) - (t (if (< last-depress-y last-release-y) - 'southwest 'northwest)))))) - -(defun hmouse-drag-horizontally () - "Returns non-nil iff last Action Key use was a horizontal drag within a single window. -If free variable 'assist-flag' is non-nil, uses Assist Key. -Value returned is nil if not a horizontal drag, 'left if drag moved left or -'right otherwise." - (let ((last-depress-x) (last-release-x) - (last-depress-y) (last-release-y)) - (if assist-flag - (setq last-depress-x (hmouse-x-coord assist-key-depress-args) - last-release-x (hmouse-x-coord assist-key-release-args) - last-depress-y (hmouse-y-coord assist-key-depress-args) - last-release-y (hmouse-y-coord assist-key-release-args)) - (setq last-depress-x (hmouse-x-coord action-key-depress-args) - last-release-x (hmouse-x-coord action-key-release-args) - last-depress-y (hmouse-y-coord action-key-depress-args) - last-release-y (hmouse-y-coord action-key-release-args))) - (and last-depress-x last-release-x last-depress-y last-release-y - (>= (- (max last-depress-x last-release-x) - (min last-depress-x last-release-x)) - hmouse-x-drag-sensitivity) - ;; Don't want to register vertical drags here, so ensure any - ;; vertical movement was less than the vertical drag sensitivity. - (< (- (max last-depress-y last-release-y) - (min last-depress-y last-release-y)) - hmouse-y-drag-sensitivity) - (if (< last-depress-x last-release-x) 'right 'left)))) - -(defun hmouse-drag-vertically () - "Returns non-nil iff last Action Key use was a vertical drag within a single window. -If free variable 'assist-flag' is non-nil, uses Assist Key. -Value returned is nil if not a vertical line drag, 'up if drag moved up or -'down otherwise." - (let ((last-depress-x) (last-release-x) - (last-depress-y) (last-release-y)) - (if assist-flag - (setq last-depress-x (hmouse-x-coord assist-key-depress-args) - last-release-x (hmouse-x-coord assist-key-release-args) - last-depress-y (hmouse-y-coord assist-key-depress-args) - last-release-y (hmouse-y-coord assist-key-release-args)) - (setq last-depress-x (hmouse-x-coord action-key-depress-args) - last-release-x (hmouse-x-coord action-key-release-args) - last-depress-y (hmouse-y-coord action-key-depress-args) - last-release-y (hmouse-y-coord action-key-release-args))) - (and last-depress-x last-release-x last-depress-y last-release-y - (>= (- (max last-depress-y last-release-y) - (min last-depress-y last-release-y)) - hmouse-y-drag-sensitivity) - ;; Don't want to register horizontal drags here, so ensure any - ;; horizontal movement was less than or equal to the horizontal drag - ;; sensitivity. - (<= (- (max last-depress-x last-release-x) - (min last-depress-x last-release-x)) - hmouse-x-drag-sensitivity) - (if (< last-depress-y last-release-y) 'down 'up)))) - -(or (fboundp 'abs) - (defun abs (number) - "Return the absolute value of NUMBER." - (cond - ((< number 0) - (- 0 number)) - (t number)))) - -(defun hmouse-drag-window-side () - "Returns non-nil if Action Key was dragged from a window side divider. -If free variable 'assist-flag' is non-nil, uses Assist Key." - (cond (hyperb:xemacs-p - ;; Depress events in scrollbars or in non-text area of buffer are - ;; not visible or identifiable at the Lisp-level, so always return - ;; nil. - nil) - (hyperb:window-system - (let* ((depress-args (if assist-flag assist-key-depress-args - action-key-depress-args)) - (release-args (if assist-flag assist-key-release-args - action-key-release-args)) - (w (smart-window-of-coords depress-args)) - (side-ln (and w (1- (nth 2 (window-edges w))))) - (last-press-x (hmouse-x-coord depress-args)) - (last-release-x (hmouse-x-coord release-args))) - (and last-press-x last-release-x side-ln - (/= last-press-x last-release-x) - (/= (1+ side-ln) (frame-width)) - (<= (max (- last-press-x side-ln) (- side-ln last-press-x)) - hmouse-side-sensitivity)))))) - -(defun sm-split-window-horizontally () - "Splits current window in two evenly, side by side. -Beeps and prints message if can't split window further." - (interactive) - (let ((window-min-width 5)) - (condition-case () - (split-window-horizontally nil) - (error (progn (beep) - (message - "(sm-split-window-horizontally): Can't split window further.")))))) - -(defun sm-split-window-vertically () - "Splits current window in two evenly, one above the other. -Beeps and prints message if can't split window further." - (interactive) - (let ((window-min-height 2)) - (condition-case () - (if (fboundp 'split-window-quietly) - (split-window-quietly nil) - (split-window-vertically nil)) - (error - (progn - (beep) - (message - "(sm-split-window-vertically): Can't split window further.")))))) - -(defun smart-coords-in-window-p (coords window) - "Tests if COORDS are in WINDOW. Returns WINDOW if they are, nil otherwise." - (cond ((and hyperb:emacs19-p (eventp coords)) - (eq (posn-window (event-start coords)) window)) - ((if hyperb:xemacs-p - (if (eventp coords) - (eq (event-window coords) window) - (eq (car coords) window)))) - ((fboundp 'window-edges) - (let* ((edges (window-edges window)) - (w-xmin (nth 0 edges)) - (w-ymin (nth 1 edges)) - (w-xmax (nth 2 edges)) - (w-ymax (nth 3 edges)) - (x (hmouse-x-coord coords)) - (y (hmouse-y-coord coords))) - (and (<= w-xmin x) (<= x w-xmax) - (<= w-ymin y) (<= y w-ymax) - window))))) - -(defun smart-window-of-coords (coords) - "Returns window in which COORDS fall or nil if none. -Ignores minibuffer window." - (cond ((and hyperb:emacs19-p (eventp coords)) - (posn-window (event-start coords))) - ((if hyperb:xemacs-p - (if (eventp coords) - (event-window coords) - (car coords)))) - (t (let ((window-list (hypb:window-list 'no-minibuf)) - (window) - (w)) - (while (and (not window) window-list) - (setq w (car window-list) - window-list (cdr window-list) - window (smart-coords-in-window-p coords w))) - window)))) - -;;; ************************************************************************ -;;; Private functions -;;; ************************************************************************ - -(defun hmouse-context-menu () - "If running under a window system, display or hide the buffer menu. -If not running under a window system and Smart Menus are loaded, display the -appropriate Smart Menu for the context at point." - (if (and (fboundp 'smart-menu) - (or (null window-system) - (not (or hyperb:lemacs-p hyperb:emacs19-p)))) - (smart-menu) - (let ((wind (get-buffer-window "*Buffer List*")) - owind) - (if wind - (unwind-protect - (progn (setq owind (selected-window)) - (select-window wind) - (bury-buffer nil)) - (select-window owind)) - (buffer-menu nil))))) - -(defun hmouse-horizontal () - "Goes to buffer end if drag was to the right, otherwise goes to beginning." - (if (eq hkey-value 'right) - (end-of-buffer) - (beginning-of-buffer))) - -(defun hmouse-horizontal-assist () - "Splits window vertically if drag was to the right, otherwise deletes window." - (if (eq hkey-value 'right) - (sm-split-window-vertically) - (delete-window))) - -(defun action-key-modeline () - "Handles Action Key depresses on a window mode line. -If key is: - (1) clicked on left edge of a window's modeline, - window's buffer is buried (placed at bottom of buffer list); - (2) clicked on right edge of a window's modeline, - the Info buffer is displayed, or if already displayed and the - modeline clicked belongs to a window displaying Info, the Info - buffer is hidden; - (3) clicked anywhere in the middle of a window's modeline, - the functions listed in 'action-key-modeline-hook' are called; - (4) dragged vertically from modeline to within a window, - the modeline is moved to point of key release, thereby resizing - its window and potentially its vertical neighbors." - (let ((w (smart-window-of-coords action-key-depress-args))) - (if w (select-window w)) - (cond ((hmouse-modeline-click) - (cond ((hmouse-release-left-edge) (bury-buffer)) - ((hmouse-release-right-edge) - (if (eq major-mode 'Info-mode) - (Info-exit) - (info))) - (t (run-hooks 'action-key-modeline-hook)))) - (t (hmouse-modeline-resize-window))))) - -(defun assist-key-modeline () - "Handles Assist Key depresses on a window mode line. -If secondary key is: - (1) clicked on left edge of a window's modeline, - bottom buffer in buffer list is unburied and placed in window; - (2) clicked on right edge of a window's modeline, - the summary of Smart Key behavior is displayed, or if already - displayed and the modeline clicked belongs to a window displaying - the summary, the summary buffer is hidden; - (3) clicked anywhere in the middle of a window's modeline, - the functions listed in 'assist-key-modeline-hook' are called; - (4) dragged vertically from modeline to within a window, - the modeline is moved to point of key release, thereby resizing - its window and potentially its vertical neighbors." - (let ((buffers) - (w (smart-window-of-coords assist-key-depress-args))) - (if w (select-window w)) - (cond ((hmouse-modeline-click 'assist) - (cond ((hmouse-release-left-edge 'assist) - (if (fboundp 'last) - (switch-to-buffer (car (last (buffer-list)))) - (setq buffers (buffer-list)) - (switch-to-buffer (nth (1- (length buffers)) buffers)))) - ((hmouse-release-right-edge 'assist) - (if (equal (buffer-name) (hypb:help-buf-name "Smart")) - (hkey-help-hide) - (hkey-summarize 'current-window))) - (t (run-hooks 'assist-key-modeline-hook)))) - (t (hmouse-modeline-resize-window 'assist))))) - -(defun hmouse-modeline-click (&optional assist-flag) - "Returns non-nil if last Action Key depress and release was at same point in a modeline. -Optional ASSIST-FLAG non-nil means test for Assist Key click instead." - ;; Assume depress was in modeline and that any drag has already been handled. - ;; So just check that release was in modeline. - (hmouse-modeline-release assist-flag)) - -(defun hmouse-modeline-depress () - "Returns non-nil if Action Key was depressed on a window mode line. -If free variable 'assist-flag' is non-nil, uses Assist Key." - (let ((args (if assist-flag assist-key-depress-args - action-key-depress-args))) - (if (and hyperb:window-system args) - (if (fboundp 'event-over-modeline-p) - (event-over-modeline-p args) - (let* ((w (smart-window-of-coords args)) - (mode-ln (if w (nth 3 (window-edges w)))) - (last-press-y (hmouse-y-coord args))) - ;; Mode-line is always 1 less than the bottom of the window, unless it - ;; is a minibuffer window which does not have a modeline. - (if (not (eq w (minibuffer-window))) (setq mode-ln (1- mode-ln))) - (and last-press-y mode-ln (= last-press-y mode-ln))))))) - -(defun hmouse-modeline-release (&optional assist-flag) - "Returns non-nil if Action Key was released on a window mode line. -Optional non-nil ASSIST-FLAG means test release of Assist Key instead." - (let ((args (if assist-flag assist-key-release-args - action-key-release-args))) - (if (and hyperb:window-system args) - (if (fboundp 'event-over-modeline-p) - (event-over-modeline-p args) - (let* ((w (smart-window-of-coords args)) - (mode-ln (and w (1- (nth 3 (window-edges w))))) - (last-press-y (hmouse-y-coord args))) - (and last-press-y mode-ln (= last-press-y mode-ln))))))) - -(defun hmouse-modeline-resize-window (&optional assist-flag) - "Resizes window whose mode line was depressed upon by the Action Key. -Resize amount depends upon the vertical difference between press and release -of the Action Key. Optional arg ASSIST-FLAG non-nil means use values from -Assist Key instead." - (cond ((not hyperb:window-system) nil) - ((and hyperb:xemacs-p (not (fboundp 'window-edges))) - (error "Drag from a mode-line with button1 to resize windows.")) - (t (let* ((owind (selected-window)) - (window (smart-window-of-coords - (if assist-flag assist-key-depress-args - action-key-depress-args))) - (mode-ln (and window (1- (nth 3 (window-edges window))))) - (last-release-y - (hmouse-y-coord - (if assist-flag assist-key-release-args - action-key-release-args))) - (shrink-amount (- mode-ln last-release-y))) - ;; Restore position of point prior to Action Key release. - (if action-key-release-prev-point - (let ((obuf (current-buffer))) - (unwind-protect - (progn - (set-buffer - (marker-buffer action-key-release-prev-point)) - (goto-char - (marker-position action-key-release-prev-point))) - (set-buffer obuf)))) - (cond - ((>= (+ mode-ln 2) (frame-height)) - (error - "(hmouse-modeline-resize-window): Can't move bottom window in frame.")) - ((< (length (hypb:window-list 'no-minibuf)) 2) - (error - "(hmouse-modeline-resize-window): Can't resize sole window in frame.")) - (t (unwind-protect - (progn - (select-window window) - (shrink-window shrink-amount) - ;; Keep redisplay from scrolling other window. - (select-window (next-window nil 'no-mini)) - (condition-case () - (scroll-down shrink-amount) - (error nil))) - (select-window owind)))))))) - -(defun hmouse-release-left-edge (&optional assist-flag) - "Returns non-nil if last Action Key release was at left window edge. -'hmouse-edge-sensitivity' value determines how near to actual edge the -release must be." - (let ((args (if assist-flag assist-key-release-args - action-key-release-args)) - window-left last-release-x) - (if (fboundp 'window-lowest-p) ;; XEmacs >= 19.12 - (setq last-release-x (and args (eq (event-window args) - (selected-window)) - (hmouse-x-coord args)) - window-left 0) - (setq window-left (car (window-edges)) - last-release-x (and args (hmouse-x-coord args)))) - (and last-release-x (< (- last-release-x window-left) - hmouse-edge-sensitivity) - (>= (- last-release-x window-left) 0)))) - -(defun hmouse-release-right-edge (&optional assist-flag) - "Returns non-nil if last Action Key release was at right window edge. -'hmouse-edge-sensitivity' value determines how near to actual edge the -release must be." - (let ((args (if assist-flag assist-key-release-args - action-key-release-args)) - window-right last-release-x) - (if (fboundp 'window-lowest-p) ;; XEmacs >= 19.12 - (setq last-release-x (and args (eq (event-window args) - (selected-window)) - (hmouse-x-coord args)) - window-right (window-width)) - (setq window-right (nth 2 (window-edges)) - last-release-x (and args (hmouse-x-coord args)))) - (and last-release-x (>= (+ last-release-x hmouse-edge-sensitivity) - window-right) - (>= (- window-right last-release-x) 0)))) - -(defun hmouse-resize-window-side (&optional assist-flag) - "Resizes window whose side was depressed upon by the Action Key. -Resize amount depends upon the horizontal difference between press and release -of the Action Key. Optional arg ASSIST-FLAG non-nil means use values from -Assist Key instead." - (cond (hyperb:xemacs-p - ;; Depress events in scrollbars or in non-text area of buffer are - ;; not visible or identifiable at the Lisp-level, so always return - ;; nil. - nil) - (hyperb:window-system - (let* ((owind (selected-window)) - (window (smart-window-of-coords - (if assist-flag assist-key-depress-args - action-key-depress-args))) - (side-ln (and window (1- (nth 2 (window-edges window))))) - (last-release-x - (hmouse-x-coord - (if assist-flag assist-key-release-args - action-key-release-args))) - (shrink-amount (- side-ln last-release-x)) - ) - ;; Restore position of point prior to Action Key release. - (if action-key-release-prev-point - (let ((obuf (current-buffer))) - (unwind-protect - (progn - (set-buffer (marker-buffer action-key-release-prev-point)) - (goto-char (marker-position action-key-release-prev-point))) - (set-buffer obuf)))) - (cond - ((>= (+ side-ln 2) (frame-width)) - (error - "(hmouse-resize-window-side): Can't change width of full frame width window.")) - ((< (length (hypb:window-list 'no-minibuf)) 2) - (error - "(hmouse-resize-window-side): Can't resize sole window in frame.")) - (t (unwind-protect - (progn - (select-window window) - (shrink-window-horizontally shrink-amount)) - (select-window owind)))))))) - -(defun hmouse-swap-buffers (&optional assist-flag) - "Swaps buffers in windows selected with last Action Key depress and release. -If optional arg ASSIST-FLAG is non-nil, uses Assist Key." - (let* ((w1 (if assist-flag assist-key-depress-window - action-key-depress-window)) - (w2 (if assist-flag assist-key-release-window - action-key-release-window)) - (w1-buf (and w1 (window-buffer w1))) - (w2-buf (and w2 (window-buffer w2))) - ) - (or (and w1 w2) - (error "(hmouse-swap-buffers): Last depress or release not within a window.")) - ;; Swap window buffers. - (set-window-buffer w1 w2-buf) - (set-window-buffer w2 w1-buf))) - -(defun hmouse-swap-windows (&optional assist-flag) - "Swaps windows selected with last Action Key depress and release. -If optional arg ASSIST-FLAG is non-nil, uses Assist Key." - (let* ((w1 (if assist-flag assist-key-depress-window - action-key-depress-window)) - (w2 (if assist-flag assist-key-release-window - action-key-release-window)) - (w1-width (and w1 (window-width w1))) - (w1-height (and w1 (window-height w1))) - (w2-width (and w2 (window-width w2))) - (w2-height (and w2 (window-height w2))) - ) - (or (and w1 w2) - (error "(hmouse-swap-windows): Last depress or release not within a window.")) - (unwind-protect - (progn - (select-window w1) - (if (not (= w1-height (frame-height))) - (shrink-window (- w1-height w2-height))) - (if (not (= w1-width (frame-width))) - (shrink-window-horizontally (- w1-width w2-width))) - (select-window w2) - (setq w2-width (window-width w2) - w2-height (window-height w2)) - (if (not (= w2-height (frame-height))) - (shrink-window (- w2-height w1-height))) - (if (not (= w2-width (frame-width))) - (shrink-window-horizontally (- w2-width w1-width))) - ) - (select-window w2) - ))) - -(defun hmouse-x-coord (args) - "Returns x coordinate in chars from window system dependent ARGS." - (let ((x (eval (cdr (assoc hyperb:window-system - '(("emacs19" . (if (eventp args) - (+ (car (posn-col-row - (event-start args))) - (nth 0 (window-edges - (car - (car (cdr args)) - )))) - (car args))) - ("lemacs" . (if (eventp args) - (event-x args) - (car args))) - ("xterm" . (car args)) - ("epoch" . (nth 0 args)) ;; Epoch V4 - ("sun" . (nth 1 args)) - ("next" . (nth 1 args)) - ("apollo" . (car args)) - )))))) - (if (integerp x) x (error "(hmouse-x-coord): invalid X coord: %s" x)))) - -(defun hmouse-y-coord (args) - "Returns y coordinate in frame lines from window system dependent ARGS." - (let ((y (eval (cdr (assoc hyperb:window-system - '(("emacs19" . (if (eventp args) - (+ (cdr (posn-col-row - (event-start args))) - (nth 1 (window-edges - (car - (car (cdr args)) - )))) - (cdr args))) - ("lemacs" . (if (eventp args) - (event-y args) - (cdr args))) - ("xterm" . (nth 1 args)) - ("epoch" . (nth 1 args)) ;; Epoch V4 - ("sun" . (nth 2 args)) - ("next" . (nth 2 args)) - ("apollo" . (nth 1 args)) - )))))) - (if (integerp y) y (error "(hmouse-y-coord): invalid Y coord: %s" y)))) - - -;;; ************************************************************************ -;;; Private variables -;;; ************************************************************************ - - -(provide 'hui-window)
--- a/lisp/hyperbole/hui-xe-but.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,427 +0,0 @@ -;;!emacs -;; -;; FILE: hui-xe-but.el -;; SUMMARY: XEmacs button highlighting and flashing support. -;; USAGE: XEmacs Lisp Library -;; KEYWORDS: faces, hypermedia -;; -;; AUTHOR: Bob Weiner -;; ORG: InfoDock Associates -;; -;; ORIG-DATE: 21-Aug-92 -;; LAST-MOD: 26-Feb-97 at 01:58:01 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; It is for use with XEmacs, a modified version of GNU Emacs V19. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1992-1995, Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; -;; This is truly prototype code. -;; -;; Can't use read-only buttons here because then outline-mode -;; becomes unusable. -;; -;; DESCRIP-END. - -(or hyperb:lemacs-p - (error "(hui-xe-but.el): Load only when running XEmacs.")) - -;;; ************************************************************************ -;;; Other required Elisp libraries -;;; ************************************************************************ - -(require 'hbut) - -;;; XEmacs 19.12 renamed x-color-display-p to x-display-color-p. -(if (and (fboundp 'x-color-display-p) - (not (fboundp 'x-display-color-p))) - (fset 'x-display-color-p 'x-color-display-p)) - -(defun hproperty:background () - "Returns default background color for selected frame." - (face-background (get-face 'default))) - -(defun hproperty:foreground () - "Returns default foreground color for selected frame." - (face-foreground (get-face 'default))) - -;;; ************************************************************************ -;;; Public variables -;;; ************************************************************************ - -(defvar hproperty:but-emphasize-p nil - "*Non-nil means visually emphasize that button under mouse cursor is selectable.") - -(defvar hproperty:but-flash-time 1000 - "*Machine specific value for empty loop counter, XEmacs button flash delay.") - -(defvar hproperty:item-highlight-color (hproperty:foreground) - "Color with which to highlight list/menu selections. -Call (hproperty:set-item-highlight <color>) to change value.") - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -(defun hproperty:but-add (start end face) - "Add between START and END a button using FACE in current buffer. -If `hproperty:but-emphasize-p' is non-nil when this is called, emphasize that -button is selectable whenever the mouse cursor moves over it." - (let ((but (make-extent start end))) - (set-extent-face but face) - (set-extent-property but 'highlight hproperty:but-emphasize-p))) - -(defun hproperty:but-color () - "Return current color of buffer's buttons." - (if hproperty:color-ptr - (car hproperty:color-ptr) - (hproperty:foreground))) - -(defun hproperty:but-clear () - "Delete all Hyperbole buttons from current buffer." - (interactive) - (map-extents (function (lambda (extent unused-arg) - (if (eq (extent-face extent) 'hbut) - (delete-extent extent)))))) - -(defun hproperty:but-create (&optional start-delim end-delim regexp-match) - "Highlight all hyper-buttons in buffer using XEmacs extents. -Will use optional strings START-DELIM and END-DELIM instead of default values. -If END-DELIM is a symbol, e.g. t, then START-DELIM is taken as a regular -expression which matches an entire button string. -If REGEXP-MATCH is non-nil, only buttons matching this argument are -highlighted. - -If `hproperty:but-emphasize-p' is non-nil when this is called, emphasize that -button is selectable whenever the mouse cursor moves over it." - (interactive) - (hproperty:but-clear) - (hproperty:but-create-all start-delim end-delim regexp-match)) - -(defun hproperty:but-create-all (&optional start-delim end-delim regexp-match) - "Mark all hyper-buttons in buffer as XEmacs buttons, for later highlighting. -Will use optional strings START-DELIM and END-DELIM instead of default values. -If END-DELIM is a symbol, e.g. t, then START-DELIM is taken as a regular -expression which matches an entire button string. -If REGEXP-MATCH is non-nil, only buttons matching this argument are -highlighted." - (ebut:map (function (lambda (lbl start end) - (hproperty:but-add start end hproperty:but-face))) - start-delim end-delim regexp-match 'include-delims)) - -(defun hproperty:but-delete (&optional pos) - (let ((extent (extent-at (or pos (point))))) - (if extent (delete-extent extent)))) - -;;; ************************************************************************ -;;; Private functions -;;; ************************************************************************ - -(defmacro hproperty:list-cycle (list-ptr list) - "Move LIST-PTR to next element in LIST or when at end to first element." - (` (or (and (, list-ptr) - (setq (, list-ptr) (cdr (, list-ptr)))) - (setq (, list-ptr) (, list))))) - -;;; ************************************************************************ -;;; Private variables -;;; ************************************************************************ - -(defconst hproperty:color-list '( "red" "blue" "paleturquoise4" "mediumpurple2" -"lightskyblue3" "springgreen2" "salmon" "yellowgreen" "darkorchid2" -"aquamarine4" "slateblue4" "slateblue1" "olivedrab1" "goldenrod4" -"goldenrod3" "cadetblue2" "burlywood1" "slategrey" "mistyrose" -"limegreen" "lightcyan" "goldenrod" "gainsboro" "skyblue1" "honeydew" -"yellow2" "tomato3" "skyblue" "purple4" "orange3" "bisque3" "bisque2" -"grey34" "gray99" "gray63" "gray44" "gray37" "gray33" "gray26" "azure1" -"snow4" "peru" "red" "lightgoldenrod4" "mediumseagreen" "blush" -"mediumorchid2" "lightskyblue1" "darkslateblue" "midnightblue" -"lightsalmon1" "lemonchiffon" "yellow" "lightsalmon" "coral" -"dodgerblue3" "darkorange4" "blue" "royalblue4" "red" "green" "cyan" -"darkviolet" "darksalmon" "darkorange" "blue" "pink" "magenta2" -"sienna4" "khaki2" "grey75" "grey74" "grey73" "grey69" "grey68" "grey35" -"grey13" "gray90" "gray81" "gray55" "gray51" "gray31" "snow2" "pink3" -"grey7" "gray1" "red4" "red3" "tan" "red" "yellow" "mediumvioletred" -"lightslategrey" "lavenderblush4" "turquoise" "darkturquoise" -"darkslategrey" "lightskyblue" "lightsalmon4" "lightsalmon3" -"forestgreen" "dodgerblue4" "orchid" "rosybrown4" "brown" "peachpuff3" -"palegreen3" "orangered2" "rose" "lightcyan4" "indianred4" "indianred3" -"seagreen2" "indianred" "deeppink1" "navyblue" "lavender" "grey" -"deeppink" "salmon4" "salmon3" "oldlace" "grey78" "grey77" "grey54" -"grey45" "grey21" "gray97" "gray96" "gray95" "gray88" "gray87" "gray86" -"gray70" "gray57" "gray38" "gray12" "gray11" "plum3" "linen" "gray9" -"gray8" "blue4" "beige" "turquoise" "blue" "lemonchiffon4" -"darkseagreen1" "antiquewhite3" "mediumorchid" "springgreen" -"turquoise4" "steelblue3" "mistyrose2" "lightcyan2" "red" "firebrick2" -"royalblue" "cadetblue" "skyblue3" "yellow3" "salmon1" "orange4" -"hotpink" "grey90" "gray56" "gray39" "gray18" "gray14" "plum4" "grey6" -"gray6" "gold3" "gold1" "blue2" "tan2" "cyan" "mediumspringgreen" -"darkolivegreen2" "goldenrod" "lightsteelblue" "brown" "whip" -"chartreuse3" "violetred4" "royalblue2" "royalblue1" "papayawhip" -"mistyrose3" "lightcyan1" "aquamarine" "skyblue4" "hotpink4" "hotpink3" -"hotpink2" "dimgray" "tomato" "grey66" "grey65" "grey64" "grey33" -"grey27" "gray76" "gray69" "gray68" "grey0" "azure" "green" -"darkgoldenrod4" "darkgoldenrod3" "darkgoldenrod2" "darkgoldenrod" -"brown" "lightsalmon2" "deepskyblue4" "deepskyblue3" "deepskyblue2" -"deepskyblue" "darkorange1" "violetred3" "violetred2" "violetred1" -"slateblue3" "slateblue2" "drab" "indianred1" "firebrick1" "cadetblue4" -"violetred" "rosybrown" "blue" "firebrick" "grey100" "wheat4" "grey79" -"grey76" "grey61" "gray93" "gray84" "gray65" "gray36" "gray32" "gray13" -"gray10" "azure3" "snow1" "tan1" "gray" "darkolivegreen1" "blue" -"almond" "lavenderblush3" "lavenderblush2" "lavenderblush1" -"darkolivegreen" "lavenderblush" "aquamarine2" "red" "olivedrab2" -"mistyrose4" "mistyrose1" "lightcyan3" "lightcoral" "chartreuse" -"peachpuff" "palegreen" "mintcream" "skyblue2" "moccasin" "tomato1" -"orchid3" "maroon3" "salmon" "grey81" "grey62" "grey39" "grey38" -"grey37" "gray92" "gray83" "gray66" "gray54" "gray50" "gray30" "gray19" -"gray15" "azure4" "grey3" "tan3" "pink" "gray" "blue" "lightsteelblue2" -"lightsteelblue1" "green" "lightslategray" "lemonchiffon2" -"springgreen1" "greenyellow" "chartreuse2" "grey" "royalblue3" -"powderblue" "peachpuff2" "palegreen2" "cream" "slateblue" "seashell2" -"deeppink2" "darkkhaki" "maroon4" "sienna" "grey71" "grey67" "grey18" -"gray59" "gray43" "gray25" "bisque" "red1" "mediumslateblue" -"lightgoldenrod1" "goldenrod" "paleturquoise3" "lightskyblue4" "green" -"yellow" "smoke" "blue" "white" "steelblue4" "rosybrown3" "peachpuff1" -"palegreen1" "blueviolet" "seashell4" "sienna3" "grey40" "gray91" -"gray82" "gray5" "cyan2" "cyan1" "blue1" "snow" "lightgoldenrod2" -"lightslateblue" "mediumorchid3" "darkseagreen4" "springgreen3" "green" -"slategray4" "slategray3" "slategray2" "blue" "peachpuff4" "palegreen4" -"green" "orangered3" "goldenrod1" "ghostwhite" "firebrick4" "firebrick3" -"cadetblue3" "slategray" "seashell3" "honeydew3" "cornsilk4" "cornsilk2" -"purple1" "dimgrey" "khaki1" "ivory3" "grey70" "grey60" "grey32" -"grey22" "grey12" "gray98" "gray89" "gray71" "gray64" "gray60" "gray49" -"azure2" "gray3" "paleturquoise1" "mediumpurple1" "purple" -"lemonchiffon1" "blue" "navajowhite3" "darkorchid1" "orange" -"goldenrod2" "khaki" "chocolate2" "burlywood2" "honeydew1" "darkgreen" -"thistle3" "thistle2" "thistle1" "thistle" "maroon2" "maroon1" "grey53" -"grey44" "grey25" "gray74" "gray45" "gray41" "gray35" "gray27" "gray23" -"gray16" "brown4" "wheat" "coral" "tan4" "lightgoldenrodyellow" "blue" -"green" "gray" "palevioletred3" "mediumpurple4" "mediumpurple3" -"saddlebrown" "blue" "darkorchid4" "darkorchid3" "puff" "olivedrab4" -"lightblue4" "lightpink" "lightgray" "honeydew2" "cornsilk1" "lace" -"sienna1" "bisque4" "orchid" "khaki3" "grey84" "grey83" "grey82" -"grey72" "grey52" "grey43" "grey26" "grey14" "grey10" "gray75" "gray53" -"gray21" "gray20" "brown3" "grey8" "red2" "navy" "grey" "gold" -"mediumaquamarine" "lightgoldenrod" "darkslategray4" "darkseagreen3" -"darkseagreen2" "antiquewhite4" "white" "springgreen4" "lightyellow4" -"white" "aquamarine1" "turquoise3" "steelblue2" "rosybrown2" "pink" -"gray" "indianred2" "dodgerblue" "green" "seagreen1" "deeppink4" -"aliceblue" "magenta1" "pink" "sienna2" "orchid1" "gray100" "grey97" -"grey94" "grey87" "grey86" "grey51" "grey42" "grey19" "gray94" "gray85" -"gray61" "brown2" "khaki" "grey1" "gold4" "blue" "green" "grey" -"turquoise" "paleturquoise" "mediumorchid4" "antiquewhite2" -"lightyellow2" "violet" "salmon" "chartreuse1" "turquoise1" "sandybrown" -"orangered1" "lightpink1" "lightblue2" "lightblue1" "grey" "seagreen4" -"seagreen3" "lightblue" "deeppink3" "burlywood" "seashell" "hotpink1" -"gray" "yellow4" "yellow" "purple" "orange" "ivory4" "grey99" "grey89" -"grey63" "grey58" "grey49" "grey31" "grey24" "grey20" "green4" "green1" -"gray73" "gray67" "coral3" "coral2" "plum2" "pink4" "ivory" "gray4" -"gray2" "gold2" "aquamarine" "grey" "lightgoldenrod3" "darkolivegreen3" -"darkgoldenrod1" "goldenrod" "orchid" "chiffon" "navajowhite4" -"deepskyblue1" "lightyellow" "floralwhite" "blue" "mediumblue" -"chocolate4" "chocolate3" "burlywood4" "turquoise" "steelblue" "green" -"lawngreen" "honeydew4" "seagreen" "orchid4" "wheat1" "violet" "ivory1" -"grey88" "grey85" "grey57" "grey56" "grey55" "grey48" "grey47" "grey46" -"grey30" "grey17" "gray47" "gray29" "pink2" "grey5" "grey4" "green" -"gray0" "brown" "lightsteelblue4" "darkolivegreen4" "palevioletred4" -"blue" "darkslategray3" "darkslategray2" "darkslategray1" -"blanchedalmond" "palegoldenrod" "blue" "lightseagreen" "lemonchiffon3" -"darkslategray" "green" "darkseagreen" "antiquewhite" "darkorange2" -"chartreuse4" "blue" "rosybrown1" "olivedrab3" "lightpink2" "orangered" -"thistle4" "blue" "cornsilk" "salmon2" "orchid2" "ivory2" "grey93" -"grey92" "grey91" "grey36" "grey29" "grey28" "grey16" "gray79" "gray78" -"gray77" "gray48" "gray17" "coral4" "coral1" "plum1" "pink1" "grey9" -"grey2" "gray7" "cyan4" "blue3" "plum" "cornflowerblue" "lightskyblue2" -"antiquewhite1" "navajowhite2" "navajowhite1" "lightyellow3" -"navajowhite" "darkorange3" "whitesmoke" "turquoise2" "steelblue1" -"lightpink4" "lightblue3" "green" "chocolate1" "blue" "olivedrab" -"lightgrey" "chocolate" "magenta4" "magenta3" "yellow1" "purple3" -"purple2" "orange2" "orange1" "magenta" "bisque1" "wheat2" "maroon" -"khaki4" "grey96" "grey95" "grey80" "grey50" "grey41" "grey15" "grey11" -"gray80" "gray58" "gray40" "gray34" "gray22" "brown1" "snow3" -"mediumturquoise" "lightsteelblue3" "palevioletred2" "palevioletred1" -"paleturquoise2" "green" "palevioletred" "mediumorchid1" "white" -"mediumpurple" "lightyellow1" "dodgerblue2" "dodgerblue1" "violet" -"aquamarine3" "slategray1" "gray" "orangered4" "lightpink3" "blue" -"darkorchid" "cadetblue1" "burlywood3" "seashell1" "cornsilk3" "tomato4" -"tomato2" "wheat3" "grey98" "grey59" "grey23" "green3" "green2" "gray72" -"gray62" "gray52" "gray46" "gray42" "gray28" "gray24" "white" "cyan3" -"black" )) - -(defvar hproperty:color-ptr nil - "Pointer to current color name table to use for Hyperbole buttons in XEmacs.") - -(defconst hproperty:good-colors - '( - "medium violet red" "indianred4" "firebrick1" "DarkGoldenrod" "NavyBlue" - "darkorchid" "tomato3" "mediumseagreen" "deeppink" "forestgreen" - "mistyrose4" "slategrey" "purple4" "dodgerblue3" "mediumvioletred" - "lightsalmon3" "orangered2" "turquoise4" "Gray55" - ) - "Good colors for contrast against wheat background and black foreground.") - - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -(defun hproperty:cycle-but-color (&optional color) - "Switches button color to optional COLOR name or next item referenced by hproperty:color-ptr." - (interactive "sHyperbole button color: ") - (if (not (x-display-color-p)) - nil - (if color (setq hproperty:color-ptr nil)) - (set-face-foreground - hproperty:but-face - (or color (car (hproperty:list-cycle - hproperty:color-ptr hproperty:good-colors)))) - (hproperty:set-flash-color) - (sit-for 0) ;; Force display update - t)) - -(defun hproperty:set-flash-color () - "Set button flashing colors based upon current color set." - (if (not (x-display-color-p)) - nil - (set-face-background hproperty:flash-face (hproperty:but-color)) - (set-face-foreground hproperty:flash-face (hproperty:background)))) - -(defun hproperty:but-flash () - "Flash a XEmacs Hyperbole button at or near point to indicate selection." - (interactive) - (let ((ibut) (prev) - (start (hattr:get 'hbut:current 'lbl-start)) - (end (hattr:get 'hbut:current 'lbl-end)) - (b) (a)) - (if (and start end (setq prev (extent-at start) - ibut t)) - (progn (if (not prev) (hproperty:but-add start end hproperty:but-face)) - (setq b (and start (extent-at start)))) - (setq b (extent-at (point)))) - (if (setq a (and (extentp b) (extent-face b))) - (progn - (set-extent-face b hproperty:flash-face) - (sit-for 0);; Force display update - ;; Delay before redraw button - (let ((i 0)) (while (< i hproperty:but-flash-time) (setq i (1+ i)))) - (set-extent-face b a) - (sit-for 0);; Force display update - )) - (if (and ibut (not prev)) (hproperty:but-delete start)) - )) - -(defun hproperty:set-item-highlight (&optional background foreground) - "Setup or reset item highlight face using optional BACKGROUND and FOREGROUND." - (make-local-variable 'hproperty:item-face) - (if background (setq hproperty:item-highlight-color background)) - (if (not hproperty:highlight-face) - (progn - (setq hproperty:highlight-face - (or (find-face 'hproperty:highlight-face) - (face-name (make-face 'hproperty:highlight-face)))) - (set-face-foreground hproperty:highlight-face - (or foreground (hproperty:background))) - (set-face-underline-p hproperty:highlight-face nil))) - - (let* ((tty (and (fboundp 'device-type) - (eq 'tty (device-type (selected-device))))) - (specifiers-function - (if (fboundp 'specifier-specs) 'specifier-specs 'identity)) - (color-function - (if (fboundp 'color-name) 'color-name 'identity)) - (update-rolo-highlight-flag - (and (boundp 'rolo-highlight-face) (find-face rolo-highlight-face) - (or (null - (funcall specifiers-function - (face-foreground rolo-highlight-face))) - (equal - (funcall color-function - (face-foreground rolo-highlight-face)) - (funcall color-function (face-foreground 'default))) - (face-equal hproperty:highlight-face rolo-highlight-face))))) - (if tty - (copy-face 'italic 'hproperty:highlight-face) - (if (and (funcall specifiers-function - (face-background hproperty:highlight-face)) - (equal (funcall color-function - (face-background hproperty:highlight-face)) - hproperty:item-highlight-color)) - nil - (set-face-background hproperty:highlight-face - hproperty:item-highlight-color)) - (and background (not (equal (face-background - hproperty:highlight-face) background)) - (set-face-background hproperty:highlight-face background)) - (and foreground (not (equal (face-foreground - hproperty:highlight-face) foreground)) - (set-face-foreground hproperty:highlight-face foreground))) - (setq hproperty:item-face hproperty:highlight-face) - (if update-rolo-highlight-flag - (if tty - (copy-face 'italic 'rolo-highlight-face) - (copy-face hproperty:highlight-face rolo-highlight-face))))) - -(defun hproperty:select-item (&optional pnt) - "Select item in current buffer at optional position PNT using hproperty:item-face." - (if hproperty:item-button - nil - (set-extent-face (setq hproperty:item-button (make-extent (point) (point))) - hproperty:item-face)) - (if pnt (goto-char pnt)) - (skip-chars-forward " \t") - (skip-chars-backward "^ \t\n") - (let ((start (point))) - (save-excursion - (skip-chars-forward "^ \t\n") - (set-extent-endpoints hproperty:item-button start (point)) - )) - (sit-for 0) ;; Force display update - ) - -(defun hproperty:select-line (&optional pnt) - "Select line in current buffer at optional position PNT using hproperty:item-face." - (if hproperty:item-button - nil - (set-extent-face (setq hproperty:item-button (make-extent (point) (point))) - hproperty:item-face)) - (if pnt (goto-char pnt)) - (save-excursion - (beginning-of-line) - (set-extent-endpoints hproperty:item-button (point) (progn (end-of-line) (point))) - ) - (sit-for 0) ;; Force display update - ) - -;;; ************************************************************************ -;;; Private variables -;;; ************************************************************************ - -(defvar hproperty:but-face (face-name (make-face 'hproperty:but-face)) - "Face for hyper-buttons.") -(setq hproperty:but hproperty:but-face) -(if (and (fboundp 'device-type) - (eq 'tty (device-type (selected-device)))) - (copy-face 'italic 'hproperty:but-face) - (set-face-foreground hproperty:but-face (hproperty:but-color)) - (set-face-background hproperty:but-face (hproperty:background))) - -(defvar hproperty:flash-face (face-name (make-face 'hproperty:flash-face)) - "Face for flashing hyper-buttons.") -(hproperty:set-flash-color) - -(defvar hproperty:item-button nil - "Button used to highlight an item in a listing buffer.") -(make-variable-buffer-local 'hproperty:item-button) -(defvar hproperty:item-face nil "Item marking face.") -(defvar hproperty:highlight-face nil - "Item highlighting face. Use (hproperty:set-item-highlight) to set.") -(if hproperty:highlight-face - nil - ;; Reverse foreground and background colors for default block-style highlighting. - (hproperty:set-item-highlight (hproperty:foreground) (hproperty:background))) - -(provide 'hui-xe-but)
--- a/lisp/hyperbole/hui.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,927 +0,0 @@ -;;!emacs -;; -;; FILE: hui.el -;; SUMMARY: GNU Emacs User Interface to Hyperbole -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: hypermedia -;; -;; AUTHOR: Bob Weiner -;; ORG: InfoDock Associates -;; -;; ORIG-DATE: 19-Sep-91 at 21:42:03 -;; LAST-MOD: 10-Nov-96 at 01:51:13 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1991-1996, Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Other required Elisp libraries -;;; ************************************************************************ - -(require 'hargs) (require 'set) (require 'hmail) - -;;; ************************************************************************ -;;; Public variables -;;; ************************************************************************ - -(defvar hui:ebut-delete-confirm-p t - "*Non-nil means prompt before interactively deleting explicit buttons.") - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -(defun hui:ebut-create (&optional start end) - "Creates an explicit but starting from label between optional START and END. -Indicates by delimiting and adding any necessary instance number of the button -label." - (interactive (list (and (marker-position (hypb:mark-marker t)) - (region-beginning)) - (and (marker-position (hypb:mark-marker t)) - (region-end)))) - (let ((default-lbl) lbl but-buf actype) - (save-excursion - (setq default-lbl - (hui:hbut-label-default start end (not (interactive-p))) - lbl (hui:hbut-label default-lbl "ebut-create")) - (if (not (equal lbl default-lbl)) (setq default-lbl nil)) - - (setq but-buf (if default-lbl (current-buffer) (hui:ebut-buf))) - (hui:buf-writable-err but-buf "ebut-create") - - (hattr:set 'hbut:current 'loc (hui:key-src but-buf)) - (hattr:set 'hbut:current 'dir (hui:key-dir but-buf)) - (setq actype (hui:actype)) - (hattr:set 'hbut:current 'actype actype) - (hattr:set 'hbut:current 'args (hargs:actype-get actype)) - (hattr:set 'hbut:current 'action - (and (boundp 'hui:ebut-prompt-for-action) - hui:ebut-prompt-for-action (hui:action actype))) - ) - (ebut:operate lbl nil))) - -(defun hui:ebut-delete (but-key &optional key-src) - "Deletes explicit Hyperbole button given by BUT-KEY in optional KEY-SRC. -KEY-SRC may be a buffer or a pathname, when nil the current buffer is used. -Returns t if button is deleted, nil if user chooses not to delete or signals -an error otherwise. If called interactively, prompts user whether to delete -and derives BUT-KEY from the button that point is within. -Signals an error if point is not within a button." - (interactive (list (if (ebut:at-p) - (hattr:get 'hbut:current 'lbl-key) - nil))) - (cond ((null but-key) - (hypb:error - "(ebut-delete): Point is not over the label of an existing button.")) - ((not (stringp but-key)) - (hypb:error - "(ebut-delete): Invalid label key argument: '%s'." but-key))) - (let ((interactive (interactive-p))) - (if (and hui:ebut-delete-confirm-p interactive) - (if (y-or-n-p (format "Delete button %s%s%s? " - ebut:start - (hbut:key-to-label but-key) ebut:end)) - (hui:ebut-delete-op interactive but-key key-src) - (message "")) - (hui:ebut-delete-op interactive but-key key-src)))) - -(defun hui:ebut-edit () - "Creates or modifies an explicit Hyperbole button when conditions are met. -A region must have been delimited with the action-key and point must now be -within it before this function is called or it will do nothing. The region -must be no larger than the size given by 'ebut:max-len'. It must be entirely -within or entirely outside of an existing explicit button. When region is -within the button, the button is interactively modified. Otherwise, a new -button is created interactively with the region as the default label." - (interactive) - (let ((m (marker-position (hypb:mark-marker t))) - (op action-key-depress-prev-point) (p (point)) (lbl-key)) - (if (and m (eq (marker-buffer m) (marker-buffer op)) - (< op m) (<= (- m op) ebut:max-len) - (<= p m) (<= op p)) - (progn - (if (setq lbl-key (ebut:label-p)) - (hui:ebut-modify lbl-key) - (hui:ebut-create op m)) - t)))) - -(defun hui:ebut-modify (lbl-key) - "Modifies an explicit Hyperbole button given by LBL-KEY. -Signals an error when no such button is found in the current buffer." - (interactive (list (save-excursion - (hui:buf-writable-err (current-buffer) "ebut-modify") - (or (ebut:label-p) - (ebut:label-to-key - (hargs:read-match "Button to modify: " - (ebut:alist) nil t - nil 'ebut)))))) - (let ((lbl (ebut:key-to-label lbl-key)) - (but-buf (current-buffer)) - actype but new-lbl) - (save-excursion - (or (interactive-p) - (hui:buf-writable-err but-buf "ebut-modify")) - - (or (setq but (ebut:get lbl-key but-buf)) - (progn (pop-to-buffer but-buf) - (hypb:error "(ebut-modify): Invalid button, no data for '%s'." lbl))) - - (setq new-lbl - (hargs:read - "Change button label to: " - (function - (lambda (lbl) - (and (not (string= lbl "")) (<= (length lbl) ebut:max-len)))) - lbl - (format "(ebut-modify): Enter a string of at most %s chars." - ebut:max-len) - 'string)) - - (hattr:set 'hbut:current 'loc (hui:key-src but-buf)) - (hattr:set 'hbut:current 'dir (hui:key-dir but-buf)) - (setq actype (hui:actype (hattr:get but 'actype))) - (hattr:set 'hbut:current 'actype actype) - (hattr:set 'hbut:current 'args (hargs:actype-get actype 'modifying)) - (hattr:set 'hbut:current 'action - (and (boundp 'hui:ebut-prompt-for-action) - hui:ebut-prompt-for-action (hui:action actype))) - ) - (ebut:operate lbl new-lbl))) - -(defun hui:ebut-rename (curr-label new-label) - "Renames explicit Hyperbole button given by CURR-LABEL to NEW-LABEL. -If called interactively when point is not within an explicit button: - prompts for old and new button label values and performs rename. -If called interactively when point is within an explicit button: - saves button label and tells user to edit label, then call again. - second call changes the button's name from the stored value to the - edited value. -Signals an error if any problem occurs." - (interactive - (save-excursion - (let (curr-label new-label) - (hui:buf-writable-err (current-buffer) "ebut-rename") - (if hui:ebut-label-prev - (setq curr-label hui:ebut-label-prev - new-label (ebut:label-p 'as-label)) - (setq new-label nil - curr-label - (or (ebut:label-p 'as-label) - (let ((buts (ebut:alist))) - (if (null buts) - (hypb:error "(ebut-rename): No explicit buttons in buffer.") - (prog1 (hargs:read-match - "Button label to rename: " - buts nil t nil 'ebut) - (setq new-label - (hargs:read - "Rename button label to: " - (function - (lambda (lbl) - (and (not (string= lbl "")) - (<= (length lbl) ebut:max-len)))) - curr-label - (format - "(ebut-rename): Use a quoted string of at most %s chars." - ebut:max-len) - 'string)))))))) - (list curr-label new-label)))) - - (save-excursion - (if (interactive-p) - nil - (hui:buf-writable-err (current-buffer) "ebut-rename") - (if (or (not (stringp curr-label)) (string= curr-label "")) - (hypb:error "(ebut-rename): 'curr-label' must be a non-empty string: %s" - curr-label)) - (and (stringp new-label) (string= new-label "") - (hypb:error "(ebut-rename): 'new-label' must be a non-empty string: %s" - new-label))) - (or (ebut:get (ebut:label-to-key curr-label)) - (hypb:error "(ebut-rename): Can't rename %s since no button data." - curr-label)) - ) - (cond (new-label - (ebut:operate curr-label new-label) - (setq hui:ebut-label-prev nil) - (message "Renamed from '%s' to '%s'." curr-label new-label)) - (curr-label - (setq hui:ebut-label-prev curr-label) - (message "Edit button label and use same command to finish rename.")) - (t (hypb:error "(ebut-rename): Move point to within a button label.")))) - -(defun hui:ebut-search (string &optional match-part) - "Shows lines of files/buffers containing an explicit but match for STRING. -Returns number of buttons matched and displayed. -By default, only matches for whole button labels are found, optional MATCH-PART -enables partial matches. The match lines are shown in a buffer which serves as -a menu to find any of the occurrences." - (interactive (list (read-string "Search for button string: ") - (y-or-n-p "Enable partial matches? "))) - (if (not (stringp string)) - (hypb:error "(ebut-search): String to search for is required.")) - (let* ((prefix (if (> (length string) 14) - (substring string 0 13) string)) - (out-buf (get-buffer-create (concat "*" prefix " Hypb Search*"))) - (total (ebut:search string out-buf match-part))) - (if (> total 0) - (progn - (set-buffer out-buf) - (moccur-mode) - (if (fboundp 'outline-minor-mode) - (and (progn (goto-char 1) - (search-forward "\C-m" nil t)) - (outline-minor-mode 1))) - (if (fboundp 'hproperty:but-create) - (hproperty:but-create nil nil (regexp-quote - (if match-part string - (concat ebut:start string ebut:end))))) - (goto-char (point-min)) - (pop-to-buffer out-buf) - (if (interactive-p) (message "%d match%s." total - (if (> total 1) "es" "")) - total)) - (if (interactive-p) (message "No matches.") - total)))) - -(defun hui:error (&rest args) - (hypb:error "(hui:error): Obsolete, use hypb:error instead.")) - -(defun hui:gbut-create (lbl) - "Creates Hyperbole global button with LBL." - (interactive "sCreate global button labeled: ") - (let (but-buf actype) - (save-excursion - (setq actype (hui:actype)) - (setq but-buf (set-buffer (find-file-noselect gbut:file))) - (hui:buf-writable-err but-buf "ebut-create") - ;; This prevents movement of point which might be useful to user. - (save-excursion - (goto-char (point-max)) - (hattr:set 'hbut:current 'loc (hui:key-src but-buf)) - (hattr:set 'hbut:current 'dir (hui:key-dir but-buf)) - (hattr:set 'hbut:current 'actype actype) - (hattr:set 'hbut:current 'args (hargs:actype-get actype)) - (hattr:set 'hbut:current 'action - (and (boundp 'hui:ebut-prompt-for-action) - hui:ebut-prompt-for-action (hui:action actype))) - (setq lbl (concat lbl (ebut:operate lbl nil))) - (goto-char (point-max)) - (insert "\n") - (save-buffer) - ) - (message "%s created." lbl) - ))) - -(defun hui:gbut-modify (lbl-key) - "Modifies a global Hyperbole button given by LBL-KEY. -Signals an error when no such button is found." - (interactive (list (save-excursion - (hui:buf-writable-err - (find-file-noselect gbut:file) "gbut-modify") - (hbut:label-to-key - (hargs:read-match "Global button to modify: " - (mapcar 'list (gbut:label-list)) - nil t nil 'ebut))))) - (let ((lbl (hbut:key-to-label lbl-key)) - (but-buf (find-file-noselect gbut:file)) - actype but new-lbl) - (save-excursion - (or (interactive-p) - (hui:buf-writable-err but-buf "gbut-modify")) - - (or (setq but (ebut:get lbl-key but-buf)) - (progn (pop-to-buffer but-buf) - (hypb:error - "(gbut-modify): Invalid button, no data for '%s'." lbl))) - - (setq new-lbl - (hargs:read - "Change global button label to: " - (function - (lambda (lbl) - (and (not (string= lbl "")) (<= (length lbl) ebut:max-len)))) - lbl - (format "(gbut-modify): Enter a string of at most %s chars." - ebut:max-len) - 'string)) - - (hattr:set 'hbut:current 'loc (hui:key-src but-buf)) - (hattr:set 'hbut:current 'dir (hui:key-dir but-buf)) - (setq actype (hui:actype (hattr:get but 'actype))) - (hattr:set 'hbut:current 'actype actype) - (hattr:set 'hbut:current 'args (hargs:actype-get actype 'modifying)) - (hattr:set 'hbut:current 'action - (and (boundp 'hui:ebut-prompt-for-action) - hui:ebut-prompt-for-action (hui:action actype))) - (set-buffer but-buf) - (ebut:operate lbl new-lbl)))) - -(defun hui:hbut-act (&optional but) - "Executes action for optional Hyperbole button symbol BUT in current buffer. -Default is the current button." - (interactive - (let ((but (hbut:at-p)) (lst)) - (list - (cond (but) - ((setq lst (ebut:alist)) - (ebut:get (ebut:label-to-key - (hargs:read-match "Button to execute: " lst nil t - (ebut:label-p 'as-label) 'ebut)))) - (t (hypb:error "(hbut-act): No explicit buttons in buffer.")))))) - (cond ((and (interactive-p) (null but)) - (hypb:error "(hbut-act): No current button to activate.")) - ((not (hbut:is-p but)) - (hypb:error "(hbut-act): Button is invalid; it has no attributes.")) - (t (or but (setq but 'hbut:current)) - (hui:but-flash) (hyperb:act but)))) - -(defun hui:hbut-current-act () - "Activate Hyperbole button at point or signal an error if there is no such button." - (interactive) - (let ((but (hbut:at-p))) - (cond ((null but) - (hypb:error "(hbut-act): No current button to activate.")) - ((not (hbut:is-p but)) - (hypb:error "(hbut-act): Button is invalid; it has no attributes.")) - (t (hui:but-flash) (hyperb:act but))))) - -(defun hui:hbut-help (&optional but) - "Checks for and explains an optional button given by symbol, BUT. -BUT defaults to the button whose label point is within." - (interactive) - (setq but (or but (hbut:at-p) - (ebut:get (ebut:label-to-key - (hargs:read-match "Help for button: " - (ebut:alist) nil t nil 'ebut))))) - (or but - (hypb:error "(hbut-help): Move point to a valid Hyperbole button.")) - (if (not (hbut:is-p but)) - (cond (but (hypb:error "(hbut-help): Invalid button.")) - (t (hypb:error - "(hbut-help): Not on an implicit button and no buffer explicit buttons.")))) - (let ((type-help-func (intern-soft - (concat - (htype:names 'ibtypes (hattr:get but 'categ)) - ":help")))) - (or (equal (hypb:indirect-function 'hui:but-flash) - (function (lambda nil))) - ;; Only flash button if point is on it. - (let ((lbl-key (hattr:get but 'lbl-key))) - (and lbl-key - (or (equal lbl-key (ebut:label-p)) - (equal lbl-key (ibut:label-p))) - (hui:but-flash)))) - (if type-help-func - (funcall type-help-func but) - (let ((total (hbut:report but))) - (if total (hui:help-ebut-highlight)))))) - -(defun hui:hbut-label (default-label func-name) - "Reads button label from user using DEFAULT-LABEL and caller's FUNC-NAME." - (hargs:read "Button label: " - (function - (lambda (lbl) - (and (not (string= lbl "")) (<= (length lbl) ebut:max-len)))) - default-label - (format "(%s): Enter a string of at most %s chars." - func-name ebut:max-len) - 'string)) - -(defun hui:hbut-label-default (start end &optional skip-len-test) - "Returns default label based on START and END region markers or points. -Optional SKIP-LEN-TEST means don't limit label to 'ebut:max-len' length. -Returns nil if START or END are invalid or if region fails length test. - -Also has side effect of moving point to start of default label, if any." - (if (markerp start) (setq start (marker-position start))) - (if (markerp end) (setq end (marker-position end))) - ;; Test whether to use region as default button label. - (if (and (integerp start) (integerp end) - (or skip-len-test - (<= (max (- end start) (- start end)) ebut:max-len))) - (progn (goto-char start) - (buffer-substring start end)))) - -(defun hui:hbut-report (&optional arg) - "Pretty prints attributes of current button, using optional prefix ARG. -See 'hbut:report'." - (interactive "P") - (if (and arg (symbolp arg)) - (hui:hbut-help arg) - (let ((total (hbut:report arg))) - (if total - (progn (hui:help-ebut-highlight) - (message "%d button%s." total (if (/= total 1) "s" ""))))))) - -(fset 'hui:hbut-summarize 'hui:hbut-report) - -(defun hui:link-directly () - "Creates a Hyperbole link button at depress point, linked to release point. -See also documentation for 'hui:link-possible-types'." - (let* ((link-types (hui:link-possible-types)) - (but-window action-key-depress-window) - (num-types (length link-types)) - (release-window (selected-window)) - (but-modify nil) - type-and-args lbl-key but-loc but-dir) - (select-window action-key-depress-window) - (hui:buf-writable-err (current-buffer) "link-directly") - (if (ebut:at-p) - (progn - (setq but-modify t - but-loc (hattr:get 'hbut:current 'loc) - but-dir (hattr:get 'hbut:current 'dir) - lbl-key (hattr:get 'hbut:current 'lbl-key))) - (setq but-loc (hui:key-src (current-buffer)) - but-dir (hui:key-dir (current-buffer)) - lbl-key (hbut:label-to-key - (hui:hbut-label - (if (marker-position (hypb:mark-marker t)) - (hui:hbut-label-default - (region-beginning) (region-end))) - "link-directly")))) - (select-window release-window) - - (cond ((= num-types 0) - (error "(link-directly): No possible link type to create.")) - ((= num-types 1) - (hui:link-create but-modify - but-window lbl-key but-loc but-dir - (setq type-and-args (car link-types)))) - (t;; more than 1 - (let ((item) - type) - (hui:link-create - but-modify but-window - lbl-key but-loc but-dir - (setq type-and-args - (hui:menu-select - (cons '("Link to>") - (mapcar - (function - (lambda (type-and-args) - (setq type (car type-and-args)) - (list - (capitalize - (if (string-match - "^\\(link-to\\|eval\\)-" - (setq item (symbol-name type))) - (setq item (substring - item (match-end 0))) - item)) - type-and-args - (documentation - (intern (concat "actypes::" - (symbol-name type))))))) - link-types)))))))) - (message "`%s' button %s type `%s'." - (hbut:key-to-label lbl-key) - (if but-modify "set to" "created with") - (car type-and-args)))) - -;;; ************************************************************************ -;;; Private functions -;;; ************************************************************************ - -(defun hui:action (actype &optional prompt) - "Prompts for and returns an action to override action from ACTYPE." - (and actype - (let* ((act) (act-str) - (params (actype:params actype)) - (params-str (and params (concat " " (prin1-to-string params)))) - ) - (while (progn - (while (and (setq act-str - (hargs:read - (or prompt (concat "Action" params-str - ": ")) nil nil - nil 'string)) - (not (string= act-str "")) - (condition-case () - (progn (setq act (read act-str)) nil) - (error - (beep) (message "Invalid action syntax.") - (sit-for 3) t)))) - (and (not (symbolp act)) - params - ;; Use the weak condition that action must - ;; involve at least one of actype's parameters - ;; or else we assume the action is invalid, tell - ;; the user and provide another chance for entry. - (not (memq t - (mapcar - (function - (lambda (param) - (setq param (symbol-name param)) - (and (string-match - (concat "[\( \t\n,']" - (regexp-quote param) - "[\(\) \t\n\"]") - act-str) - t))) - params))) - )) - (beep) (message "Action must use at least one parameter.") - (sit-for 3)) - (let (head) - (while (cond ((listp act) - (and act (setq head (car act)) - (not (or (eq head 'lambda) - (eq head 'defun) - (eq head 'defmacro))) - (setq act (list 'lambda params act)) - nil ;; terminate loop - )) - ((symbolp act) - (setq act (cons act params))) - ((stringp act) - (setq act (action:kbd-macro act 1))) - ;; Unrecognized form - (t (setq act nil)) - ))) - act))) - -(defun hui:actype (&optional default-actype prompt) - "Using optional DEFAULT-ACTYPE, PROMPTs for a button action type. -DEFAULT-ACTYPE may be a valid symbol or symbol-name." - (and default-actype (symbolp default-actype) - (progn - (setq default-actype (symbol-name default-actype)) - (if (string-match "actypes::" default-actype) - (setq default-actype (substring default-actype (match-end 0)))))) - (if (or (null default-actype) (stringp default-actype)) - (intern-soft - (concat "actypes::" - (hargs:read-match (or prompt "Button's action type: ") - (mapcar 'list (htype:names 'actypes)) - nil t default-actype 'actype))) - (hypb:error "(actype): Invalid default action type received.") - )) - -(defun hui:buf-writable-err (but-buf func-name) - "If BUT-BUF is read-only or is unwritable, signal an error from FUNC-NAME." - (let ((obuf (prog1 (current-buffer) (set-buffer but-buf))) - ;; (unwritable (and buffer-file-name - ;; (not (file-writable-p buffer-file-name)))) - (err)) - ;; (if unwritable - ;; Commented error out since some people want to be able to create - ;; buttons within files which they have purposely marked read-only. - ;; (setq err - ;; (format "(ebut-modify): You are not allowed to modify '%s'." - ;; (file-name-nondirectory buffer-file-name)))) - (if buffer-read-only - (setq err - (format - "Button buffer '%s' is read-only. Use %s to change it." - (buffer-name but-buf) - (hypb:cmd-key-string - (if (where-is-internal 'vc-toggle-read-only) - 'vc-toggle-read-only 'toggle-read-only)) - ))) - (set-buffer obuf) - (if err (progn (pop-to-buffer but-buf) (hypb:error err))))) - -(defun hui:ebut-buf (&optional prompt) - "Prompt for and return a buffer in which to place a button." - (let ((buf-name)) - (while - (progn - (setq buf-name - (hargs:read-match - (or prompt "Button's buffer: ") - (delq nil - (mapcar - (function - (lambda (buf) - (let ((b (buffer-name buf))) - (if (and (not (string-match "mail\\*" b)) - (not (string-match "\\*post-news\\*" b)) - (string-match "\\`[* ]" b)) - nil - (cons b nil))))) - (buffer-list))) - nil t (buffer-name) 'buffer)) - (or (null buf-name) (equal buf-name ""))) - (beep)) - (get-buffer buf-name))) - -(defun hui:ebut-delete-op (interactive but-key key-src) - "INTERACTIVEly or not deletes explicit Hyperbole button given by BUT-KEY in KEY-SRC. -KEY-SRC may be a buffer or a pathname, when nil the current buffer is used. -Returns t if button is deleted, signals error otherwise. If called -with INTERACTIVE non-nil, derives BUT-KEY from the button that point is -within." - (let ((buf (current-buffer)) (ebut)) - (if (if interactive - (ebut:delete) - (cond ((or (null key-src) (and (bufferp key-src) (setq buf key-src))) - (setq ebut (ebut:get but-key key-src))) - ((and (stringp key-src) - (setq buf (find-file-noselect key-src))) - (setq ebut (ebut:get but-key buf))) - (t (hypb:error "(ebut-delete): Invalid key-src: '%s'." key-src))) - (if ebut - (ebut:delete ebut) - (hypb:error "(ebut-delete): No valid %s button in %s." - (ebut:key-to-label but-key) buf)) - ) - (progn (set-buffer buf) - (if interactive - (progn - (call-interactively 'hui:ebut-unmark) - (message "Button deleted.")) - (hui:ebut-unmark but-key key-src)) - (if (hmail:reader-p) (hmail:msg-narrow)) - ) - (hypb:error "(ebut-delete): You may not delete buttons from this buffer.")))) - -(defun hui:ebut-delimit (start end instance-str) - (hypb:error "(hui:ebut-delimit): Obsolete, use ebut:delimit instead.")) - -(defun hui:ebut-operate (curr-label new-label) - (hypb:error "(hui:ebut-operate): Obsolete, use ebut:operate instead.")) - -(defun hui:ebut-unmark (&optional but-key key-src directory) - "Remove delimiters from button given by BUT-KEY in KEY-SRC of DIRECTORY. -All args are optional, the current button and buffer file are the defaults." - (interactive) - (let ((form (function - (lambda () - (let ((buffer-read-only) start end) - (setq start (match-beginning 0) - end (match-end 0)) - (and (fboundp 'hproperty:but-delete) - (hproperty:but-delete start)) - (skip-chars-backward " \t\n") - (skip-chars-backward "0-9") - (if (= (preceding-char) (string-to-char ebut:instance-sep)) - (setq start (1- (point)))) - (if (search-backward ebut:start (- (point) ebut:max-len) t) - (if current-prefix-arg - ;; Remove button label, delimiters and preceding - ;; space, if any. - (delete-region (max (point-min) - (1- (match-beginning 0))) - end) - ;; - ;; Remove button delimiters only. - ;; - ;; Remove button ending delimiter - (delete-region start end) - ;; Remove button starting delimiter - (delete-region (match-beginning 0) - (match-end 0))))))))) - (if (interactive-p) - (save-excursion - (if (search-forward ebut:end nil t) (funcall form))) - ;; Non-interactive invocation. - (let ((cur-p)) - (if (and (or (null key-src) (eq key-src buffer-file-name)) - (or (null directory) (eq directory default-directory))) - (setq cur-p t) - (set-buffer (find-file-noselect - (expand-file-name key-src directory)))) - (save-excursion - (goto-char (point-min)) - (if (re-search-forward (ebut:label-regexp but-key) nil t) - (progn (funcall form) - ;; If modified a buffer other than the current one, - ;; save it. - (or cur-p (save-buffer))))))))) - -(defun hui:file-find (file-name) - "If FILE-NAME is readable, finds it, else signals an error." - (if (and (stringp file-name) (file-readable-p file-name)) - (find-file file-name) - (hypb:error "(file-find): \"%s\" does not exist or is not readable." - file-name))) - -(defun hui:hbut-term-highlight (start end) - "For terminals only: Emphasize a button spanning from START to END." - (save-restriction - (save-excursion - (goto-char start) - (narrow-to-region (point-min) start) - (sit-for 0) - (setq inverse-video t) - (goto-char (point-min)) - (widen) - (narrow-to-region (point) end) - (sit-for 0) - (setq inverse-video nil) - ))) - -(defun hui:hbut-term-unhighlight (start end) - "For terminals only: Remove any emphasis from hyper-button at START to END." - (save-restriction - (save-excursion - (goto-char start) - (narrow-to-region (point-min) start) - (sit-for 0) - (setq inverse-video nil)))) - -(defun hui:help-ebut-highlight () - "Highlight any explicit buttons in help buffer associated with current buffer." - (if (fboundp 'hproperty:but-create) - (save-excursion - (set-buffer - (get-buffer (hypb:help-buf-name))) - (hproperty:but-create)))) - -(defun hui:htype-delete (htype-sym) - "Deletes HTYPE-SYM from use in current Hyperbole session. -HTYPE-SYM must be redefined for use again." - (and htype-sym (symbolp htype-sym) - (let ((type - (intern (hargs:read-match - (concat "Delete from " (symbol-name htype-sym) ": ") - (mapcar 'list (htype:names htype-sym)) - nil t nil htype-sym)))) - (htype:delete type htype-sym)))) - -(defun hui:htype-help (htype-sym &optional no-sort) - "Displays documentation for types from HTYPE-SYM which match to a regexp. -Optional NO-SORT means display in decreasing priority order (natural order)." - (and htype-sym (symbolp htype-sym) - (let* ((tstr (symbol-name htype-sym)) - (tprefix (concat tstr "::")) - (buf-name (hypb:help-buf-name (capitalize tstr))) - (temp-buffer-show-hook - (function - (lambda (buf) - (set-buffer buf) (goto-char (point-min)) - (replace-regexp "^" " ") (goto-char (point-min)) - (replace-string (concat " " tprefix) "") - (goto-char (point-min)) (set-buffer-modified-p nil) - (display-buffer buf nil)))) - (temp-buffer-show-function temp-buffer-show-hook) - (names (htype:names htype-sym)) - (term (hargs:read-match - (concat (capitalize tstr) - " to describe (RET for all): ") - (mapcar 'list (cons "" names)) - nil t nil htype-sym)) - nm-list - doc-list) - (setq nm-list - (if (string= term "") - (let ((type-names - (mapcar (function (lambda (nm) (concat tprefix nm))) - names))) - (if no-sort type-names - (sort type-names 'string<))) - (cons (concat tprefix term) nil)) - doc-list (delq nil (mapcar - (function - (lambda (name) - (let ((doc (documentation - (intern-soft name)))) - (if doc (cons name doc))))) - nm-list))) - (with-output-to-temp-buffer buf-name - (mapcar (function (lambda (nm-doc-cons) - (princ (car nm-doc-cons)) (terpri) - (princ (cdr nm-doc-cons)) (terpri))) - doc-list))))) - -(defun hui:key-dir (but-buf) - "Returns button key src directory based on BUT-BUF, a buffer." - (if (bufferp but-buf) - (let ((file (buffer-file-name but-buf))) - (if file - (file-name-directory (hpath:symlink-referent file)) - (cdr (assq 'default-directory (buffer-local-variables but-buf))))) - (hypb:error "(hui:key-dir): '%s' is not a valid buffer."))) - -(defun hui:key-src (but-buf) - "Returns button key src location based on BUT-BUF, a buffer. -This is BUT-BUF when button data is stored in the buffer and the -button's source file name when the button data is stored externally." - (save-excursion - (set-buffer but-buf) - (cond ((hmail:mode-is-p) but-buf) - ((hpath:symlink-referent (buffer-file-name but-buf))) - (t but-buf)))) - -(defun hui:link-create (modify but-window lbl-key but-loc but-dir type-and-args) - "Creates or modifies a new Hyperbole button. -If MODIFY is non-nil, modifies button at point in BUT-WINDOW, -otherwise, prompts for button label and creates a button. -LBL-KEY is internal form of button label. BUT-LOC is file or buffer -in which to create button. BUT-DIR is directory of BUT-LOC. -TYPE-AND-ARGS is the action type for the button followed by any arguments it requires." - (hattr:set 'hbut:current 'loc but-loc) - (hattr:set 'hbut:current 'dir but-dir) - (hattr:set 'hbut:current 'actype (intern-soft - (concat "actypes::" - (symbol-name - (car type-and-args))))) - (hattr:set 'hbut:current 'args (cdr type-and-args)) - - (select-window but-window) - (let ((label (ebut:key-to-label lbl-key))) - (ebut:operate label (if modify label))) - ) - -(defun hui:link-possible-types () - "Returns list of possible link types for a Hyperbole button link to point. -Each list element is a list of the link type and any arguments it requires. - -The link types considered are fixed. Defining new link types will not alter -the possible types. The code must be changed to do that. - -Referent Context Possible Link Type Returned ----------------------------------------------------- -Explicit Button link-to-ebut - or -Info Node link-to-Info-node - or -Mail Reader Msg link-to-mail - -Outline Regexp Prefix link-to-string-match - or -Directory Name link-to-directory - or -File Name link-to-file - or -Koutline Cell link-to-kcell - or -Buffer attached to File link-to-file - or -Buffer without File link-to-buffer-tmp - -Elisp Buffer at Start -or End of Sexpression eval-elisp -" - (let (val) - (delq nil - (list (if (ebut:at-p) - (list 'link-to-ebut buffer-file-name (ebut:label-p))) - (cond ((eq major-mode 'Info-mode) - (let ((hargs:reading-p 'Info-node)) - (list 'link-to-Info-node (hargs:at-p)))) - ((hmail:reader-p) - (list 'link-to-mail - (list (rmail:msg-id-get) buffer-file-name))) - ) - (cond - ;; If link is within an outline-regexp prefix, use - ;; a link-to-string-match. - ((and (boundp 'outline-regexp) - (stringp outline-regexp) - (save-excursion - (<= (point) - (progn - (beginning-of-line) - (if (looking-at outline-regexp) - (match-end 0) - 0))))) - (save-excursion - (end-of-line) - (let ((heading (buffer-substring - (point) - (progn (beginning-of-line) (point)))) - (occur 1)) - (while (search-backward heading nil t) - (setq occur (1+ occur))) - (list 'link-to-string-match - heading occur buffer-file-name)))) - ((let ((hargs:reading-p 'directory)) - (setq val (hargs:at-p t))) - (list 'link-to-directory val)) - ((let ((hargs:reading-p 'file)) - (setq val (hargs:at-p t))) - (list 'link-to-file val (point))) - ((eq major-mode 'kotl-mode) - (list 'link-to-kcell buffer-file-name (kcell-view:idstamp))) - (buffer-file-name - (list 'link-to-file buffer-file-name (point))) - (t (list 'link-to-buffer-tmp (buffer-name))) - ) - (and (fboundp 'smart-emacs-lisp-mode-p) - (smart-emacs-lisp-mode-p) - (or (= (char-syntax (following-char)) ?\() - (= (char-syntax (preceding-char)) ?\))) - (setq val (hargs:sexpression-p)) - (list 'eval-elisp val)) - )))) - - -;;; ************************************************************************ -;;; Private variables -;;; ************************************************************************ - - -(defvar hui:ebut-label-prev nil - "String value of previous button name during an explicit button rename. -At other times, values must be nil.") - -(provide 'hui)
--- a/lisp/hyperbole/hvar.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,55 +0,0 @@ -;;!emacs -;; -;; FILE: hvar.el -;; SUMMARY: Variable manipulation routines for Hyperbole. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: extensions, hypermedia -;; -;; AUTHOR: Bob Weiner -;; ORG: Brown U. -;; -;; ORIG-DATE: 1-Oct-91 at 14:00:24 -;; LAST-MOD: 14-Apr-95 at 16:13:46 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1991-1995, Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Other required Elisp libraries -;;; ************************************************************************ - -(require 'set) - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -;;;###autoload -(defun var:append (var-symbol-name list-to-add) - "Appends to value held by VAR-SYMBOL-NAME, LIST-TO-ADD. Returns new value. -If VAR-SYMBOL-NAME is unbound, it is set to LIST-TO-ADD. -Often used to append to 'hook' variables." - (let ((val)) - (if (and (boundp var-symbol-name) - (setq val (symbol-value var-symbol-name)) - (or (if (symbolp val) (setq val (cons val nil))) - (listp val))) - ;; Don't add if list elts are already there. - (if (memq nil (mapcar (function - (lambda (elt) (set:member elt val))) - list-to-add)) - (set-variable var-symbol-name - (if (eq (car val) 'lambda) - (apply 'list val list-to-add) - (append val list-to-add))) - val) - (set-variable var-symbol-name list-to-add)))) - -(provide 'hvar) -
--- a/lisp/hyperbole/hversion.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,240 +0,0 @@ -;;!emacs -;; -;; LCD-ENTRY: hyperbole|Bob Weiner|hyperbole@infodock.com|Everyday Info Manager|17-Mar-97|4.023|ftp://ftp.xemacs.org/pub/infodock -;; -;; FILE: hversion.el -;; SUMMARY: Hyperbole version, system and load path information. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: hypermedia -;; -;; AUTHOR: Bob Weiner -;; ORG: InfoDock Associates -;; -;; ORIG-DATE: 1-Jan-94 -;; LAST-MOD: 17-Mar-97 at 21:08:15 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1994, 1995, 1996, 1997 Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Public variables -;;; ************************************************************************ - -(defconst hyperb:version "04.023" "Hyperbole revision number.") - -;;; Support button highlighting and flashing under XEmacs. -;;; -(defvar hyperb:xemacs-p - (let ((case-fold-search t)) - (if (string-match "XEmacs" emacs-version) - emacs-version)) - "Version string under XEmacs (not Lucid Emacs) or nil") - -;;; Support button highlighting and flashing under obsolete Lucid Emacs. -;;; -(defvar hyperb:lemacs-p - (let ((case-fold-search t)) - (if (string-match "XEmacs\\|Lucid" emacs-version) - emacs-version)) - "Version string under XEmacs or Lucid Emacs or nil") - -;;; Support mouse handling under GNU Emacs V19. -;;; -(defvar hyperb:emacs19-p - (and (not hyperb:lemacs-p) - (string-match "^19\\." emacs-version) - emacs-version) - "Version string under GNU Emacs 19 or nil") - -;;; Support button highlighting and flashing under obsolete Epoch. -;;; -(defvar hyperb:epoch-p - (if (and (boundp 'epoch::version) - (stringp epoch::version)) - (if (string< epoch::version "Epoch 4") "V3" "V4")) - "Simplified version string under Epoch, e.g. \"V4\", or nil") - -;;; Koutlines work only with specific versions of Emacs 19 and XEmacs. -(defconst hyperb:kotl-p - (if hyperb:lemacs-p - ;; Only works for XEmacs 19.9 and above. - (or (string-match "^19\\.9 \\|^19\\.[1-9][0-9]" emacs-version) - ;; Version 20 and above. - (string-lessp "20" emacs-version)) - hyperb:emacs19-p) - "Non-nil iff this Emacs version supports the Hyperbole outliner.") - -;;; Account for what rain all year round and working for two ex-Harvard guys -;;; will do to programmers. -(defvar hyperb:microcruft-os-p - (memq system-type '(ms-windows windows-nt ms-dos)) - "T iff Hyperbole is running under a Microcruft OS.") - -(defun sm-window-sys-term () - "Returns the first part of the term-type if running under a window system, else nil. -Where a part in the term-type is delimited by a '-' or an '_'." - (let* ((display-type (if (fboundp 'device-type) (device-type) window-system)) - (term (cond ((memq display-type '(x ns dps pm win32)) - ;; X11, NEXTSTEP (DPS), or OS/2 Presentation Manager (PM) - (cond (hyperb:emacs19-p "emacs19") - (hyperb:lemacs-p "lemacs") - (hyperb:epoch-p "epoch") - (t "xterm"))) - ((or (featurep 'eterm-fns) - (equal (getenv "TERM") "NeXT") - (equal (getenv "TERM") "eterm")) - ;; NEXTSTEP add-on support to Emacs - "next") - ((or display-type - (featurep 'sun-mouse) (featurep 'apollo)) - (getenv "TERM"))))) - (and term - (substring term 0 (string-match "[-_]" term))))) - -(defconst hyperb:window-system (sm-window-sys-term) - "String name for window system or term type under which Emacs was run. -If nil, no window system or mouse support is available.") - -;;; ************************************************************************ -;;; Public functions to dynamically compute Hyperbole directory. -;;; ************************************************************************ - -(defvar hyperb:automount-prefixes - (if (and (boundp 'automount-dir-prefix) (stringp automount-dir-prefix)) - automount-dir-prefix - "^/tmp_mnt/" - "*Regexp to match any automounter prefix in a pathname.")) - -(defun hyperb:stack-frame (function-list &optional debug-flag) - "Return the nearest Emacs Lisp stack frame which called any function symbol from FUNCTION-LIST or nil if no match. -If FUNCTION-LIST contains 'load, 'autoload or 'require, detect -autoloads not visible within the Lisp level stack frames. - -With optional DEBUG-FLAG non-nil, if no matching frame is found, return list -of stack frames (from innermost to outermost)." - (let ((count 0) - (frame-list) - (load-flag (or (memq 'load function-list) - (memq 'autoload function-list) - (memq 'require function-list))) - fsymbol - fbody - frame) - (or (catch 'hyperb:stack-frame - (while (setq frame (backtrace-frame count)) - (if debug-flag (setq frame-list (cons frame frame-list))) - (setq count (1+ count) - fsymbol (nth 1 frame)) - (and (eq fsymbol 'command-execute) - (not (memq 'command-execute function-list)) - ;; Use command being executed instead because it might not - ;; show up in the stack anywhere else, e.g. if it is an - ;; autoload under Emacs 19. - (setq fsymbol (nth 2 frame))) - (cond ((and load-flag (symbolp fsymbol) - (fboundp fsymbol) - (listp (setq fbody (symbol-function fsymbol))) - (eq (car fbody) 'autoload)) - (setq frame (list (car frame) 'load - (car (cdr fbody)) - nil noninteractive nil)) - (throw 'hyperb:stack-frame frame)) - ((memq fsymbol function-list) - (throw 'hyperb:stack-frame frame)))) - nil) - (if debug-flag (nreverse frame-list))))) - -(defun hyperb:path-being-loaded () - "Return the full pathname used by the innermost `load' or 'require' call. -Removes any matches for `hyperb:automount-prefixes' before returning -the pathname." - (let* ((frame (hyperb:stack-frame '(load require))) - (function (nth 1 frame)) - file nosuffix) - (cond ((eq function 'load) - (setq file (nth 2 frame) - nosuffix (nth 5 frame))) - ((eq function 'require) - (setq file (or (nth 3 frame) (symbol-name (nth 2 frame)))))) - (if (stringp file) - (setq nosuffix (or nosuffix - (string-match - "\\.\\(elc?\\|elc?\\.gz\\|elc?\\.Z\\)$" - file)) - file (substitute-in-file-name file) - file (locate-file file load-path - (if nosuffix "" ".elc:.el:.el.gz:.el.Z:") - ;; accept any existing file - 0) - file (if (and (stringp file) - (string-match hyperb:automount-prefixes file)) - (substring file (1- (match-end 0))) - file))))) - -(if (fboundp 'locate-file) - nil - (defun locate-file (file dir-list &optional suffix-string unused) - "Search for FILE in DIR-LIST. -If optional SUFFIX-STRING is provided, allow file to be followed by one of the -colon separated suffixes." - (let ((suffix-list)) - (cond ((null suffix-string) (setq suffix-list '(""))) - ((stringp suffix-string) - (let ((start 0) - (len (length suffix-string))) - (while (and (< start len) - (string-match "[^:]+" suffix-string start)) - (setq suffix-list - (cons (substring suffix-string - (match-beginning 0) - (match-end 0)) - suffix-list) - start (1+ (match-end 0)))) - (setq suffix-list (nconc (nreverse suffix-list) '(""))))) - (t (error "(locate-file): Invalid third arg, '%s', use a colon separated string of file suffixes" - suffix-string))) - (if (and (file-name-absolute-p file) (file-readable-p file)) - file;; file exists without suffix addition, so return it - (if (file-name-absolute-p file) (setq dir-list '(nil))) - (if (equal file "") (error "(locate-file): Empty file argument")) - (let (suffixes pathname) - ;; Search dir-list for a matching, readable file. - (catch 'found - (while dir-list - (setq suffixes suffix-list) - (while suffixes - (setq pathname (expand-file-name - (concat file (car suffixes)) - (car dir-list))) - (if (file-readable-p pathname) - (throw 'found pathname)) - (setq suffixes (cdr suffixes))) - (setq dir-list (cdr dir-list))))))))) - -;;; ************************************************************************ -;;; Public functions used by pulldown and popup menus -;;; ************************************************************************ - -(if (not (fboundp 'id-browse-file)) - (fset 'id-browse-file 'find-file-read-only)) - -(if (not (fboundp 'id-info)) - (defun id-info (node) - (if (br-in-browser) (br-to-view-window)) - (Info-goto-node node))) - -(if (not (fboundp 'id-tool-quit)) (fset 'id-tool-quit 'eval)) - -(if (not (fboundp 'id-tool-invoke)) - (defun id-tool-invoke (sexp) - (if (commandp sexp) - (call-interactively sexp) - (funcall sexp)))) - -(provide 'hversion)
--- a/lisp/hyperbole/hvm.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,502 +0,0 @@ -;;!emacs -;; -;; FILE: hvm.el -;; SUMMARY: Support Hyperbole buttons in mail reader: Vm. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: hypermedia, mail -;; -;; AUTHOR: Bob Weiner -;; ORG: InfoDock Associates -;; -;; ORIG-DATE: 10-Oct-91 at 01:51:12 -;; LAST-MOD: 20-Mar-97 at 14:52:54 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1991-1995, Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; -;; Automatically configured for use in "hyperbole.el". -;; If hsite loading fails prior to initializing Hyperbole Vm support, -;; -;; {M-x Vm-init RET} -;; -;; will do it. -;; -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Other required Elisp libraries -;;; ************************************************************************ - -(require 'hmail) -(load "hsmail") -(require 'vm) -(or (and (fboundp 'vm-edit-message) (fboundp 'vm-edit-message-end)) - (load "vm-edit")) -(vm-session-initialization) - -;;; ************************************************************************ -;;; Public variables -;;; ************************************************************************ - -;;; Current versions of VM define this next variable in "vm-vars.el". We -;;; define it here for earlier VM versions. -(defvar vm-edit-message-mode nil - "*Major mode to use when editing messages in VM.") - -;;; "hmail.el" procedures will branch improperly if a regular mode, like VM's -;;; default 'text-mode', is used for editing. -(setq vm-edit-message-mode 'vm-edit-mode) - -(defun vm-edit-mode () - "Major mode for editing vm mail messages. - Special commands:\\{vm-edit-message-map} -Turning on vm-edit-mode calls the value of the variable vm-edit-message-hook, -if that value is non-nil." - (interactive) - (kill-all-local-variables) - (use-local-map vm-edit-message-map) - (setq mode-name "VM Edit") - (setq major-mode 'vm-edit-mode) - (setq local-abbrev-table text-mode-abbrev-table) - (set-syntax-table text-mode-syntax-table) - (run-hooks 'vm-edit-message-hook)) - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -(defun Vm-init () - "Initializes Hyperbole support for Vm mail reading." - (interactive) - (setq hmail:composer 'mail-mode - hmail:lister 'vm-summary-mode - hmail:modifier 'vm-edit-mode - hmail:reader 'vm-mode) - ;; - ;; Setup public abstract interface to Hyperbole defined mail - ;; reader-specific functions used in "hmail.el". - ;; - (rmail:init) - ;; - ;; Setup private abstract interface to mail reader-specific functions - ;; used in "hmail.el". - ;; - (fset 'rmail:get-new 'vm-get-new-mail) - (fset 'rmail:msg-forward 'vm-forward-message) - (fset 'rmail:summ-msg-to 'vm-follow-summary-cursor) - (fset 'rmail:summ-new 'vm-summarize) - (if (interactive-p) - (message "Hyperbole VM mail reader support initialized.")) - ) - -(defun Vm-msg-hdrs-full (toggled) - "If TOGGLED is non-nil, toggle full/hidden headers, else show full headers." - (save-excursion - (if (or toggled - (let ((exposed (= (point-min) - (vm-start-of (car vm-message-pointer))))) - (not exposed))) - (progn (vm-expose-hidden-headers) - (setq toggled t))) - toggled)) - -(defun Vm-msg-narrow () - "Narrows mail reader buffer to current message. -This includes Hyperbole button data." - (save-excursion - (vm-select-folder-buffer) - (narrow-to-region (point-min) (Vm-msg-end)))) - -(defun Vm-msg-next () (vm-next-message 1)) - -(defun Vm-msg-num () - "Returns number of vm mail message that point is within, in physical message order." - (interactive) - (let ((count 1) - (case-fold-search)) - (save-excursion - (save-restriction - (widen) - (while (re-search-backward Vm-msg-start-regexp nil t) - (setq count (1+ count))))) - count)) - -(defun Vm-msg-prev () (vm-previous-message 1)) - -(defun Vm-msg-to-p (mail-msg-id mail-file) - "Sets current buffer to start of msg with MAIL-MSG-ID in MAIL-FILE. -Returns t if successful, else nil or signals error." - (if (not (file-readable-p mail-file)) - nil - (vm-visit-folder mail-file) - (widen) - (goto-char 1) - (if (let ((case-fold-search)) - (re-search-forward (concat rmail:msg-hdr-prefix - (regexp-quote mail-msg-id)) nil t)) - ;; Found matching msg - (progn - (setq buffer-read-only t) - (vm-goto-message-at-point) - t)))) - -(defun Vm-msg-widen () - "Widens buffer to full current message including Hyperbole button data." - (save-excursion - (vm-select-folder-buffer) - (narrow-to-region (point-min) (Vm-msg-end)))) - -(defun Vm-to () - "Sets current buffer to a mail reader buffer." - (and (eq major-mode 'vm-summary-mode) (set-buffer vm-mail-buffer))) - -(defun Vm-Summ-delete () - (vm-follow-summary-cursor) - (vm-delete-message 1)) - -(fset 'Vm-Summ-expunge 'vm-expunge-folder) - -(fset 'Vm-Summ-goto 'vm-follow-summary-cursor) - -(defun Vm-Summ-to () - "Sets current buffer to a mail listing buffer." - (and (eq major-mode 'vm-mode) (set-buffer vm-summary-buffer))) - -(defun Vm-Summ-undelete-all () - (message - "(Vm-Summ-undelete-all: Vm doesn't have an undelete all msgs function.")) - -;;; ************************************************************************ -;;; Private functions -;;; ************************************************************************ - -(defun Vm-msg-end () - "Returns end point for current Vm message, including Hyperbole button data. -Has side-effect of widening buffer." - (save-excursion - (goto-char (point-min)) - (widen) - (if (let ((case-fold-search)) - (re-search-forward Vm-msg-start-regexp nil t)) - (match-beginning 0) - (point-max)))) - -;;; Overlay version of this function from "vm-page.el" to hide any -;;; Hyperbole button data whenever a message is displayed in its entirety. -(defun vm-show-current-message () - (save-excursion - (save-excursion - (goto-char (point-min)) - (hmail:msg-narrow (point-min) (Vm-msg-end))) - (and vm-honor-page-delimiters - (save-excursion - (if (search-forward page-delimiter nil t) - (progn - (goto-char (match-beginning 0)) - (not (looking-at (regexp-quote hmail:hbdata-sep)))))) - (progn - (if (looking-at page-delimiter) - (forward-page 1)) - (vm-narrow-to-page)))) - ;; don't mark the message as read if the user can't see it! - (if (vm-get-buffer-window (current-buffer)) - (progn - (setq vm-system-state 'showing) - (cond ((vm-new-flag (car vm-message-pointer)) - (vm-set-new-flag (car vm-message-pointer) nil))) - (cond ((vm-unread-flag (car vm-message-pointer)) - (vm-set-unread-flag (car vm-message-pointer) nil))) - (vm-update-summary-and-mode-line) - (vm-howl-if-eom)) - (if (fboundp 'hproperty:but-create) (hproperty:but-create)) - (vm-update-summary-and-mode-line))) - -;;; Overlay version of this function from "vm-page.el" to treat end of -;;; text (excluding Hyperbole button data) as end of message. -(defun vm-scroll-forward-internal (arg) - (let ((direction (prefix-numeric-value arg)) - (w (selected-window))) - (condition-case error-data - (progn (scroll-up arg) nil) - (error - (if (or (and (< direction 0) - (> (point-min) (vm-text-of (car vm-message-pointer)))) - (and (>= direction 0) - (/= (point-max) - (save-restriction - (hmail:hbdata-start - (point-min) - (vm-text-end-of - (car vm-message-pointer))))))) - (progn - (vm-widen-page) - (if (>= direction 0) - (progn - (forward-page 1) - (set-window-start w (point)) - nil ) - (if (or (bolp) - (not (save-excursion - (beginning-of-line) - (looking-at page-delimiter)))) - (forward-page -1)) - (beginning-of-line) - (set-window-start w (point)) - 'tryagain)) - (if (eq (car error-data) 'end-of-buffer) - (if vm-auto-next-message - 'next-message - (set-window-point w (point)) - 'end-of-message))))))) - -;;; Overlay version of this function from "vm-page.el" (called by -;;; vm-scroll-* functions). Make it keep Hyperbole button data hidden. -(defun vm-widen-page () - (if (or (> (point-min) (vm-text-of (car vm-message-pointer))) - (/= (point-max) (vm-text-end-of (car vm-message-pointer)))) - (hmail:msg-narrow (vm-vheaders-of (car vm-message-pointer)) - (if (or (vm-new-flag (car vm-message-pointer)) - (vm-unread-flag (car vm-message-pointer))) - (vm-text-of (car vm-message-pointer)) - (vm-text-end-of (car vm-message-pointer)))))) - -;;; Overlay version of this function from "vm-edit.el" to hide -;;; Hyperbole button data when insert edited message from temporary buffer. -(hypb:function-overload 'vm-edit-message nil '(hmail:msg-narrow)) - -;;; Overlay version of this function from "vm-edit.el" to hide -;;; Hyperbole button data when insert edited message from temporary buffer. -(defun vm-edit-message-end () - "End the edit of a message and copy the result to its folder." - (interactive) - (if (null vm-message-pointer) - (error "This is not a VM message edit buffer.")) - (if (null (buffer-name (vm-buffer-of (car vm-message-pointer)))) - (error "The folder buffer for this message has been killed.")) - ;; make sure the message ends with a newline - (goto-char (point-max)) - (and (/= (preceding-char) ?\n) (insert ?\n)) - ;; munge message separators found in the edited message to - ;; prevent message from being split into several messages. - (vm-munge-message-separators (vm-message-type-of (car vm-message-pointer)) - (point-min) (point-max)) - ;; for From_-with-Content-Length recompute the Content-Length header - (if (eq (vm-message-type-of (car vm-message-pointer)) - 'From_-with-Content-Length) - (let ((buffer-read-only nil) - length) - (goto-char (point-min)) - ;; first delete all copies of Content-Length - (while (and (re-search-forward vm-content-length-search-regexp nil t) - (null (match-beginning 1)) - (progn (goto-char (match-beginning 0)) - (vm-match-header vm-content-length-header))) - (delete-region (vm-matched-header-start) (vm-matched-header-end))) - ;; now compute the message body length - (goto-char (point-min)) - (search-forward "\n\n" nil 0) - (setq length (- (point-max) (point))) - ;; insert the header - (goto-char (point-min)) - (insert vm-content-length-header " " (int-to-string length) "\n"))) - (let ((edit-buf (current-buffer)) - (mp vm-message-pointer)) - (if (buffer-modified-p) - (progn - (widen) - (save-excursion - (set-buffer (vm-buffer-of (vm-real-message-of (car mp)))) - (if (not (memq (vm-real-message-of (car mp)) vm-message-list)) - (error "The original copy of this message has been expunged.")) - (vm-save-restriction - (widen) - (goto-char (vm-headers-of (vm-real-message-of (car mp)))) - (let ((vm-message-pointer mp) - (buffer-read-only nil)) - (insert-buffer-substring edit-buf) - (delete-region - (point) (vm-text-end-of (vm-real-message-of (car mp)))) - (vm-discard-cached-data) - (hmail:msg-narrow)) - (vm-set-edited-flag-of (car mp) t) - (vm-mark-for-summary-update (car mp)) - (if (eq vm-flush-interval t) - (vm-stuff-virtual-attributes (car mp)) - (vm-set-modflag-of (car mp) t)) - (vm-set-buffer-modified-p t) - (vm-clear-modification-flag-undos) - (vm-set-edit-buffer-of (car mp) nil)) - (set-buffer (vm-buffer-of (car mp))) - (if (eq (vm-real-message-of (car mp)) - (vm-real-message-of (car vm-message-pointer))) - (vm-preview-current-message) - (vm-update-summary-and-mode-line)))) - (message "No change.")) - (vm-display edit-buf nil '(vm-edit-message-end) - '(vm-edit-message-end reading-message startup)) - (set-buffer-modified-p nil) - (kill-buffer edit-buf))) - -;;; Define this function if VM version in use doesn't have it. -(or (fboundp 'vm-goto-message-at-point) -(defun vm-goto-message-at-point () - "In a VM folder buffer, select the message that contains point." - (cond ((fboundp 'vm-update-search-position) - (vm-update-search-position t) - ;; vm-show-current-message only adjusts (point-max), - ;; it doesn't change (point-min). - (narrow-to-region - (vm-vheaders-of (car vm-message-pointer)) - (point-max)) - (vm-show-current-message) - (setq vm-system-state 'reading)) - ((fboundp 'vm-isearch-update) - (vm-isearch-update) - (narrow-to-region - (vm-vheaders-of (car vm-message-pointer)) - (point-max)) - (vm-show-current-message) - (setq vm-system-state 'reading)) - (t (error "vm search code is missing, can't continue")))) -) - -;;; Hide any Hyperbole button data when reply to or forward a message. -;;; See "vm-reply.el". -(var:append 'vm-mail-mode-hook '(hmail:msg-narrow)) - -;;; Overlay this function from "vm-folder.el" called whenever new mail is -;;; incorporated so that it will highlight Hyperbole buttons when possible. -;; Returns non-nil if there were any new messages. -(defun vm-assimilate-new-messages (&optional - dont-read-attributes - gobble-order - labels) - (let ((tail-cons (vm-last vm-message-list)) - b-list new-messages) - (save-excursion - (vm-save-restriction - (widen) - (if (fboundp 'hproperty:but-create) - (hproperty:but-create)) - (vm-build-message-list) - (if (or (null tail-cons) (cdr tail-cons)) - (progn - (setq vm-ml-sort-keys nil) - (if dont-read-attributes - (vm-set-default-attributes (cdr tail-cons)) - (vm-read-attributes (cdr tail-cons))) - ;; Yuck. This has to be done here instead of in the - ;; vm function because this needs to be done before - ;; any initial thread sort (so that if the thread - ;; sort matches the saved order the folder won't be - ;; modified) but after the message list is created. - ;; Since thread sorting is done here this has to be - ;; done here too. - (if gobble-order - (vm-gobble-message-order)) - (if vm-thread-obarray - (vm-build-threads (cdr tail-cons)))))) - (setq new-messages (if tail-cons (cdr tail-cons) vm-message-list)) - (vm-set-numbering-redo-start-point new-messages) - (vm-set-summary-redo-start-point new-messages)) - ;; copy the new-messages list because sorting might scramble - ;; it. Also something the user does when - ;; vm-arrived-message-hook is run might affect it. - ;; vm-assimilate-new-messages returns this value so it must - ;; not be mangled. - (setq new-messages (copy-sequence new-messages)) - ;; add the labels - (if (and labels (boundp 'vm-burst-digest-messages-inherit-labels) - vm-burst-digest-messages-inherit-labels) - (let ((mp new-messages)) - (while mp - (vm-set-labels-of (car mp) (copy-sequence labels)) - (setq mp (cdr mp))))) - (if vm-summary-show-threads - (progn - ;; get numbering and summary of new messages done now - ;; so that the sort code only has to worry about the - ;; changes it needs to make. - (vm-update-summary-and-mode-line) - (vm-sort-messages "thread"))) - (if (and vm-arrived-message-hook - new-messages - ;; tail-cons == nil means vm-message-list was empty. - ;; Thus new-messages == vm-message-list. In this - ;; case, run the hooks only if this is not the first - ;; time vm-assimilate-new-messages has been called - ;; in this folder. gobble-order non-nil is a good - ;; indicator that this is the first time because the - ;; order is gobbled only once per visit and always - ;; the first time vm-assimilate-new-messages is - ;; called. - (or tail-cons (null gobble-order))) - (let ((new-messages new-messages)) - ;; seems wise to do this so that if the user runs VM - ;; command here they start with as much of a clean - ;; slate as we can provide, given we're currently deep - ;; in the guts of VM. - (vm-update-summary-and-mode-line) - (while new-messages - (vm-run-message-hook (car new-messages) 'vm-arrived-message-hook) - (setq new-messages (cdr new-messages))))) - (vm-update-summary-and-mode-line) - (run-hooks 'vm-arrived-messages-hook) - (if (and new-messages vm-virtual-buffers) - (save-excursion - (setq b-list vm-virtual-buffers) - (while b-list - ;; buffer might be dead - (if (buffer-name (car b-list)) - (let (tail-cons) - (set-buffer (car b-list)) - (setq tail-cons (vm-last vm-message-list)) - (vm-build-virtual-message-list new-messages) - (if (or (null tail-cons) (cdr tail-cons)) - (progn - (setq vm-ml-sort-keys nil) - (if vm-thread-obarray - (vm-build-threads (cdr tail-cons))) - (vm-set-summary-redo-start-point - (or (cdr tail-cons) vm-message-list)) - (vm-set-numbering-redo-start-point - (or (cdr tail-cons) vm-message-list)) - (if (null vm-message-pointer) - (progn (setq vm-message-pointer vm-message-list - vm-need-summary-pointer-update t) - (if vm-message-pointer - (vm-preview-current-message)))) - (if vm-summary-show-threads - (progn - (vm-update-summary-and-mode-line) - (vm-sort-messages "thread"))))))) - (setq b-list (cdr b-list))))) - new-messages )) - -;;; Overlay version of 'vm-force-mode-line-update' from "vm-folder.el" -;;; to highlight Hyperbole buttons in summary buffers. -(defun vm-force-mode-line-update () - "Force a mode line update in all frames." - (if vm-summary-buffer - (save-excursion - (set-buffer vm-summary-buffer) - (if (fboundp 'hproperty:but-create) (hproperty:but-create)))) - (if (fboundp 'force-mode-line-update) - (force-mode-line-update t) - (save-excursion - (set-buffer (other-buffer)) - (set-buffer-modified-p (buffer-modified-p))))) - -;;; ************************************************************************ -;;; Private variables -;;; ************************************************************************ - -(defvar Vm-msg-start-regexp "\n\nFrom \\|\n\001\001\001\001" - "Regular expression that begins a Vm mail message.") - -(provide 'hvm)
--- a/lisp/hyperbole/hypb.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,628 +0,0 @@ -;;!emacs -;; -;; FILE: hypb.el -;; SUMMARY: Miscellaneous Hyperbole support features. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: extensions, hypermedia -;; -;; AUTHOR: Bob Weiner -;; ORG: InfoDock Associates -;; -;; ORIG-DATE: 6-Oct-91 at 03:42:38 -;; LAST-MOD: 22-Feb-97 at 14:30:10 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1991-1995, 1997 Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Other required Elisp libraries -;;; ************************************************************************ - -(mapcar 'require '(hversion hact)) - -;;; ************************************************************************ -;;; Public variables -;;; ************************************************************************ - -(defconst hypb:help-buf-suffix " Hypb Help*" - "Suffix attached to all native Hyperbole help buffer names.") - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -(defun hypb:call-process-p (program infile &optional predicate &rest args) - "Calls an external PROGRAM with INFILE for input. -If PREDICATE is given, it is evaluated in a buffer with the PROGRAM's -output and the result returned. If PREDICATE is nil, returns t iff -program has no output or just a 0-valued output. -Rest of ARGS are passed as arguments to PROGRAM." - (let ((buf (get-buffer-create "*test-output*")) - (found)) - (save-excursion - (set-buffer buf) (setq buffer-read-only nil) (erase-buffer) - (apply 'call-process program infile buf nil args) - (setq found - (if predicate - (eval predicate) - (or (= (point-max) 1) ;; No output, consider cmd a success. - (and (< (point-max) 4) - (string= (buffer-substring 1 2) "0"))))) - (set-buffer-modified-p nil) - (kill-buffer buf)) - found)) - - -(defun hypb:chmod (op octal-permissions file) - "Uses OP and OCTAL-PERMISSIONS integer to set FILE permissions. -OP may be +, -, xor, or default =." - (let ((func (cond ((eq op '+) (function logior)) - ((eq op '-) (function - (lambda (p1 p2) (logand (lognot p1) p2)))) - ((eq op 'xor) (function logxor)) - (t (function (lambda (p1 p2) p1)))))) - (set-file-modes file (funcall func (hypb:oct-to-int octal-permissions) - (file-modes file))))) - -(defun hypb:cmd-key-string (cmd-sym &optional keymap) - "Returns a single pretty printed key sequence string bound to CMD-SYM. -Global keymap is used unless optional KEYMAP is given." - (if (and cmd-sym (symbolp cmd-sym) (fboundp cmd-sym)) - (let* ((get-keys (function - (lambda (cmd-sym keymap) - (key-description (where-is-internal - cmd-sym keymap 'first))))) - (keys (funcall get-keys cmd-sym keymap))) - (concat "{" - (if (string= keys "") - (concat (funcall get-keys 'execute-extended-command nil) - " " (symbol-name cmd-sym) " RET") - keys) - "}")) - (error "(hypb:cmd-key-string): Invalid cmd-sym arg: %s." cmd-sym))) - -;;;###autoload -(defun hypb:configuration (&optional out-buf) - "Insert Emacs configuration information at the end of optional OUT-BUF or the current buffer." - (save-excursion - (and out-buf (set-buffer out-buf)) - (goto-char (point-max)) - (delete-blank-lines) (delete-blank-lines) - (let ((start (point))) - (insert (format "I use:\tEditor: %s\n\tHyperbole: %s\n" - (if (boundp 'epoch::version) - epoch::version - (hypb:replace-match-string - " of .+" (emacs-version) "" t)) - hyperb:version)) - (if (and (boundp 'system-configuration) (stringp system-configuration)) - (insert (format "\tSys Type: %s\n" system-configuration))) - (insert (format "\tOS Type: %s\n\tWindow Sys: %s\n" - system-type (or window-system hyperb:window-system - "None"))) - (if (and (boundp 'hmail:reader) hmail:reader) - (insert (format "\tMailer: %s\n" - (cond ((eq hmail:reader 'rmail-mode) "RMAIL") - ((eq hmail:reader 'vm-mode) - (concat "VM " vm-version)) - ((and (eq hmail:reader 'mh-show-mode) - (string-match "v ?\\([0-9]+.[0-9]+\\)" - mh-e-RCS-id)) - (concat "MH-e " - (substring mh-e-RCS-id - (match-beginning 1) - (match-end 1)))) - ((eq hmail:reader 'pm-fdr-mode) - (concat "PIEmail " pm-version)) - )))) - (if (and (boundp 'hnews:reader) (boundp 'gnus-version) hnews:reader) - (insert (format "\tNews Rdr: %s\n" gnus-version))) - (if (and (boundp 'br-version) (stringp br-version)) - (insert (format "\tOO-Browser: %s\n" br-version))) - (untabify start (point))))) - -(if (fboundp 'copy-tree) - (fset 'hypb:copy-sublists 'copy-tree) - ;; - ;; This function is derived from a copylefted function. - ;; Define hypb:copy-sublists if not a builtin. This version - ;; is a Lisp translation of the C version in Lemacs 19.8. - ;; Copyright (C) 1985, 1986, 1987, 1992, 1993 Free Software Foundation, Inc. - ;; Available for use and distribution under the GPL. - ;; - (defun hypb:copy-sublists (obj &optional vector-p) - "Return a copy of a list and substructures. -The argument is copied, and any lists contained within it are copied -recursively. Circularities and shared substructures are not preserved. -Second arg VECP causes vectors to be copied, too. Strings are not copied." - (cond ((consp obj) - (let (rest) - (setq obj (copy-sequence obj) - rest obj) - (while (consp rest) - (let ((elt (car rest))) - (if quit-flag (top-level)) - (if (or (consp elt) (vectorp elt)) - (setcar rest (hypb:copy-sublists elt vector-p))) - (if (vectorp (cdr rest)) - (setcdr rest (hypb:copy-sublists (cdr rest) vector-p))) - (setq rest (cdr rest)))))) - ((and (vectorp obj) obj) - (let ((i (length obj)) - (j 0) - elt) - (setq obj (copy-sequence obj)) - (while (< j i) - (setq elt (aref obj j)) - (if quit-flag (top-level)) - (if (or (consp elt) (vectorp elt)) - (aset obj j (hypb:copy-sublists elt vector-p))) - (setq j (1+ j)))))) - obj)) - -(defun hypb:debug () - "Loads Hyperbole hbut.el source file and sets debugging traceback flag." - (interactive) - (or (featurep 'hinit) (load "hsite")) - (or (and (featurep 'hbut) - (let ((func (hypb:indirect-function 'ebut:create))) - (not (or (hypb:v19-byte-code-p func) - (eq 'byte-code - (car (car (nthcdr 3 (hypb:indirect-function - 'ebut:create))))))))) - (load "hbut.el")) - (setq debug-on-error t)) - -(defun hypb:domain-name () - "Returns current Internet domain name with '@' prepended or nil if none." - (let* ((dname-cmd (or (file-exists-p "/usr/bin/domainname") - (file-exists-p "/bin/domainname"))) - (dname (or (getenv "DOMAINNAME") - (if dname-cmd - (hypb:call-process-p - "domainname" nil - '(substring (buffer-string) 0 -1)))))) - (if (or (and dname (string-match "\\." dname)) - (let* ((src "/etc/resolv.conf") - (src-buf-exists-p (get-file-buffer src))) - (and (file-exists-p src) (file-readable-p src) - (save-excursion - (set-buffer (find-file-noselect src)) - (goto-char (point-min)) - (if (re-search-forward "^domain[ \t]+\\([^ \t\n]+\\)" - nil t) - (setq dname (buffer-substring (match-beginning 1) - (match-end 1)))) - (or src-buf-exists-p (kill-buffer nil)) - dname)))) - (concat "@" dname)))) - -(defun hypb:error (&rest args) - "Signals an error typically to be caught by 'hui:menu'." - (let ((msg (apply 'format args))) - (put 'error 'error-message msg) - (error msg))) - -(defun hypb:functionp (obj) -"Returns t if OBJ is a function, nil otherwise." - (cond - ((symbolp obj) (fboundp obj)) - ((subrp obj)) - ((hypb:v19-byte-code-p obj)) - ((consp obj) - (if (eq (car obj) 'lambda) (listp (car (cdr obj))))) - (t nil))) - -(defun hypb:function-copy (func-symbol) - "Copies FUNC-SYMBOL's body for overloading. Returns copy of body." - (if (fboundp func-symbol) - (let ((func (hypb:indirect-function func-symbol))) - (cond ((listp func) (copy-sequence func)) - ((subrp func) (error "(hypb:function-copy): `%s' is a primitive; can't copy body." - func-symbol)) - ((and (hypb:v19-byte-code-p func) (fboundp 'make-byte-code)) - (if (not (fboundp 'compiled-function-arglist)) - ;; This is evil -slb - (let ((new-code (append func nil))) ; turn it into a list - (apply 'make-byte-code new-code)) - ;; Can't reference bytecode objects as vectors in modern - ;; XEmacs. - (let ((new-code (nconc - (list (compiled-function-arglist func) - (compiled-function-instructions func) - (compiled-function-constants func) - (compiled-function-stack-depth func) - (compiled-function-doc-string func)))) - spec) - (if (setq spec (compiled-function-interactive func)) - (setq new-code (nconc new-code (list (nth 1 spec))))) - (apply 'make-byte-code new-code)))) - (t (error "(hypb:function-copy): Can't copy function body: %s" func)) - )) - (error "(hypb:function-copy): `%s' symbol is not bound to a function." - func-symbol))) - -(defun hypb:function-overload (func-sym prepend &rest new-forms) - "Redefine function named FUNC-SYM by either PREPENDing (or appending if nil) rest of quoted NEW-FORMS." - (let ((old-func-sym (intern - (concat "*hypb-old-" - (symbol-name func-sym) - "*")))) - (or (fboundp old-func-sym) - (fset old-func-sym (hypb:function-copy func-sym))) - (let* ((old-func (hypb:indirect-function old-func-sym)) - (old-param-list (action:params old-func)) - (param-list (action:param-list old-func)) - (old-func-call - (list (if (memq '&rest old-param-list) - ;; Have to account for extra list wrapper from &rest. - (cons 'apply - (cons (list 'quote old-func-sym) param-list)) - (cons old-func-sym param-list))))) - (eval (append - (list 'defun func-sym old-param-list) - (delq nil - (list - (documentation old-func-sym) - (action:commandp old-func-sym))) - (if prepend - (append new-forms old-func-call) - (append old-func-call new-forms))))))) - -;; #### FIXME -- This code is highly broken in XEmacs 20.3 -(defun hypb:function-symbol-replace (func-sym sym-to-replace replace-with-sym) - "Replaces in body of FUNC-SYM SYM-TO-REPLACE with REPLACE-WITH-SYM. -All occurrences within lists are replaced. Returns body of modified FUNC-SYM." - (let ((body (hypb:indirect-function func-sym)) - (arg-vector) (arg)) - (if (listp body) - ;; assume V18 byte compiler - (setq arg-vector - (car (delq nil (mapcar - (function - (lambda (elt) - (and (listp elt) - (vectorp (setq arg-vector (nth 2 elt))) - arg-vector))) - body)))) - ;; assume V19 byte compiler (eq (compiled-function-p body) t) - (setq arg (if (fboundp 'compiled-function-arglist) - (compiled-function-arglist body) - (aref body 2)) - arg-vector (if (vectorp arg) arg)) - ) - (if arg-vector - ;; Code is byte-compiled. - (let ((i (1- (length arg-vector)))) - (setq arg nil) - (while (and (not arg) (>= i 0)) - (if (eq (setq arg (aref arg-vector i)) sym-to-replace) - (aset arg-vector i replace-with-sym) - (setq arg nil i (1- i))))) - ;; Code is not byte-compiled. - ;; Only replaces occurrence of symbol as an element of a list. - (hypb:map-sublists - (function - (lambda (atom list) (if (eq atom sym-to-replace) - (let ((again t)) - (while (and again list) - (if (eq (car list) atom) - (progn (setcar list replace-with-sym) - (setq again nil)) - (setq list (cdr list)))))))) - body) - ) - body)) - -(defun hypb:help-buf-name (&optional prefix) - "Returns a Hyperbole help buffer name for current buffer. -With optional PREFIX string, uses it rather than buffer name." - (let ((bn (or prefix (buffer-name)))) - (if (string-match " Hypb " bn) - (buffer-name (generate-new-buffer bn)) - (concat "*" bn hypb:help-buf-suffix)))) - -(defun hypb:indirect-function (obj) - "Return the function at the end of OBJ's function chain. -Resolves autoloadable function symbols properly." - (let ((func - (if (fboundp 'indirect-function) - (indirect-function obj) - (while (symbolp obj) - (setq obj (symbol-function obj))) - obj))) - ;; Handle functions with autoload bodies. - (if (and (symbolp obj) (listp func) (eq (car func) 'autoload)) - (let ((load-file (car (cdr func)))) - (load load-file) - ;; Prevent infinite recursion - (if (equal func (symbol-function obj)) - (error "(hypb:indirect-function): Autoload of '%s' failed" obj) - (hypb:indirect-function obj))) - func))) - -(defun hypb:insert-region (buffer start end invisible-flag) - "Insert into BUFFER the contents of a region from START to END in the current buffer. -INVISIBLE-FLAG, if non-nil, means invisible text in an outline region is -copied, otherwise, it is omitted." - (let ((from-koutline (eq major-mode 'kotl-mode))) - (append-to-buffer buffer start end) - (save-excursion - (set-buffer buffer) - (let ((first (- (point) (- end start))) - (last (point))) - ;; Remove from buffer any copied text that was hidden if invisible-flag - ;; is nil. - (if invisible-flag - ;; Show all hidden text within the copy. - (subst-char-in-region first last ?\r ?\n t) - ;; Remove hidden text. - (goto-char first) - (while (search-forward "\r" last t) - (delete-region (1- (point)) (progn (end-of-line) (point))))) - ;; - ;; If region came from a koutline, remove any characters with an - ;; invisible property which separate cells. - (if from-koutline - (kproperty:map - (function (lambda (prop) (delete-char 1))) 'invisible t)))))) - -(if (or hyperb:lemacs-p hyperb:emacs19-p) - (fset 'hypb:mark 'mark) - (defun hypb:mark (inactive-p) - "Return this buffer's mark value as integer, or nil if no mark. -INACTIVE-P non-nil means return value of mark even if region is not active -under Emacs version 19. -If you are using this in an editing command, you are most likely making -a mistake; see the documentation of `set-mark'." - (mark)) - ) -(if hyperb:lemacs-p - (fset 'hypb:mark-marker 'mark-marker) - (defun hypb:mark-marker (inactive-p) - "Return this buffer's mark as a marker object, or nil if no mark. -INACTIVE-P is unused, it is for compatibility with Lucid Emacs' -version of mark-marker." - (mark-marker)) - ) - -(defun hypb:map-sublists (func list) - "Applies FUNC to every atom found at any level of LIST. -FUNC must take two arguments, an atom and a list in which the atom is found. -Returns values from applications of FUNC as a list with the same -structure as LIST. FUNC is therefore normally used just for its side-effects." - (mapcar (function - (lambda (elt) (if (atom elt) - (funcall func elt list) - (hypb:map-sublists func elt))) - list))) - -(defun hypb:map-vector (func object) - "Returns list of results of application of FUNC to each element of OBJECT. -OBJECT should be a vector or byte-code object." - (if (not (or (vectorp object) (hypb:v19-byte-code-p object))) - (error "(hypb:map-vector): Second argument must be a vector or byte-code object.")) - (let ((end (length object)) - (i 0) - (result)) - (while (< i end) - (setq result (cons (funcall func (aref object i)) result) - i (1+ i))) - (nreverse result))) - -(defun hypb:mouse-help-file () - "Return the full path to the Hyperbole mouse key help file." - (let* ((hypb-man (expand-file-name "man/" hyperb:dir)) - (help-file (expand-file-name "hypb-mouse.txt" hypb-man))) - (if (or (file-exists-p help-file) - (file-exists-p - (setq help-file (expand-file-name - "hypb-mouse.txt" data-directory)))) - help-file - (error "(hypb:mouse-help-file): Non-existent file: \"%s\"" help-file)))) - -(if (or hyperb:lemacs-p hyperb:emacs19-p) - (fset 'hypb:push-mark 'push-mark) - (defun hypb:push-mark (&optional location nomsg activate-region) - "Set mark at LOCATION (point, by default) and push old mark on mark ring. -If the last global mark pushed was not in the current buffer, -also push LOCATION on the global mark ring. -Display `Mark set' unless the optional second arg NOMSG is non-nil. -Optional third arg ACTIVATE-REGION is ignored. - -Novice Emacs Lisp programmers often try to use the mark for the wrong -purposes. See the documentation of `set-mark' for more information." - (push-mark location nomsg)) - ) - -(defun hypb:replace-match-string (regexp str newtext &optional literal) - "Replaces all matches for REGEXP in STR with NEWTEXT string and returns the result. -Optional LITERAL non-nil means do a literal replacement. -Otherwise treat \\ in NEWTEXT string as special: - \\& means substitute original matched text, - \\N means substitute match for \(...\) number N, - \\\\ means insert one \\. -NEWTEXT may instead be a function of one argument, the string to replace in, -that returns a replacement string." - (if (not (stringp str)) - (error "(hypb:replace-match-string): 2nd arg must be a string: %s" str)) - (if (or (stringp newtext) (hypb:functionp newtext)) - nil - (error "(hypb:replace-match-string): 3rd arg must be a string or function: %s" - newtext)) - (let ((rtn-str "") - (start 0) - (special) - match prev-start) - (while (setq match (string-match regexp str start)) - (setq prev-start start - start (match-end 0) - rtn-str - (concat - rtn-str - (substring str prev-start match) - (cond ((hypb:functionp newtext) (funcall newtext str)) - (literal newtext) - (t (mapconcat - (function - (lambda (c) - (if special - (progn - (setq special nil) - (cond ((eq c ?\\) "\\") - ((eq c ?&) - (substring str - (match-beginning 0) - (match-end 0))) - ((and (>= c ?0) (<= c ?9)) - (if (> c (+ ?0 (length - (match-data)))) - ;; Invalid match num - (error "(hypb:replace-match-string) Invalid match num: %c" c) - (setq c (- c ?0)) - (substring str - (match-beginning c) - (match-end c)))) - (t (char-to-string c)))) - (if (eq c ?\\) (progn (setq special t) nil) - (char-to-string c))))) - newtext "")))))) - (concat rtn-str (substring str start)))) - -(defun hypb:supercite-p () - "Returns non-nil iff the Emacs add-on supercite package is in use." - (let (hook-val) - (if (memq t (mapcar - (function - (lambda (hook-var) - (and (boundp hook-var) - (progn (setq hook-val (symbol-value hook-var)) - (cond ((listp hook-val) - (if (memq 'sc-cite-original hook-val) - t)) - ((eq hook-val 'sc-cite-original))))))) - '(mail-citation-hook mail-yank-hooks))) - t))) - -;;; Next function is copied from a copylefted function: -;;; Copyright (C) 1987, 1988 Kyle E. Jones -(if (or hyperb:lemacs-p hyperb:emacs19-p) - (defun hypb:window-list-all-frames (&optional mini) - "Returns a list of Lisp window objects for all Emacs windows in all frames. -Optional first arg MINI t means include the minibuffer window -in the list, even if it is not active. If MINI is neither t -nor nil it means to not count the minibuffer window even if it is active." - (let* ((first-window (next-window - (previous-window (selected-window) nil t t) - mini t t)) - (windows (cons first-window nil)) - (current-cons windows) - (w (next-window first-window mini t t))) - (while (not (eq w first-window)) - (setq current-cons (setcdr current-cons (cons w nil))) - (setq w (next-window w mini t t))) - windows))) - -;;; Next function is copied from a copylefted function: -;;; Copyright (C) 1987, 1988 Kyle E. Jones -(defun hypb:window-list (&optional mini) - "Returns a list of Lisp window objects for all Emacs windows in selected frame. -Optional first arg MINI t means include the minibuffer window -in the list, even if it is not active. If MINI is neither t -nor nil it means to not count the minibuffer window even if it is active." - (let* ((first-window (next-window - (previous-window (selected-window)) mini)) - (windows (cons first-window nil)) - (current-cons windows) - (w (next-window first-window mini))) - (while (not (eq w first-window)) - (setq current-cons (setcdr current-cons (cons w nil))) - (setq w (next-window w mini))) - windows)) - -(defun hypb:v19-byte-code-p (obj) - "Return non-nil iff OBJ is an Emacs V19 byte compiled object." - (or (and (fboundp 'compiled-function-p) (compiled-function-p obj)) - (and (fboundp 'byte-code-function-p) (byte-code-function-p obj)))) - -;;; ************************************************************************ -;;; About Hyperbole Setup -;;; ************************************************************************ - -;;;###autoload -(defun hypb:display-file-with-logo (&optional file) - "Display an optional text FILE with the InfoDock Associates logo prepended. -Without file, logo is prepended to the current buffer." - ;; - (if file - ;; This function is defined in hversion.el when needed. - (id-browse-file file)) - (if (next-extent (current-buffer)) - ;; Images have already been inserted, don't do it again. - nil - (let* ((ida-logo (make-glyph (expand-file-name "ida-logo.xpm" data-directory))) - (buffer-read-only) - extent) - (goto-char (point-min)) - (indent-to (startup-center-spaces ida-logo)) - (insert "\n\n") - (setq extent (make-extent (- (point) 3) (- (point) 2))) - (set-extent-end-glyph extent ida-logo) - (set-extent-property extent 'help-echo "Visit InfoDock Associates") - (set-extent-property extent 'keymap hypb:ida-logo-keymap)) - (goto-char (point-min)) - (skip-syntax-forward "-") - (set-window-start (selected-window) 1) - (set-buffer-modified-p nil))) - -(defvar hypb:ida-logo-keymap - (let ((map (make-sparse-keymap))) - (cond (hyperb:emacs19-p - (define-key map [button-1] 'hypb:ida-home-page) - (define-key map [button-2] 'hypb:ida-home-page) - (define-key map "\C-m" 'hypb:ida-home-page)) - (hyperb:lemacs-p - (define-key map 'button1 'hypb:ida-home-page) - (define-key map 'button2 'hypb:ida-home-page) - (define-key map '(return) 'hypb:ida-home-page))) - map) - "Keymap used when on the InfoDock Associates logo glyph.") - -(defun hypb:ida-home-page () - "Visit InfoDock Associates home web page." - (interactive) - (funcall - (if (boundp 'highlight-headers-follow-url-function) - highlight-headers-follow-url-function - 'w3-fetch) - "http://www.infodock.com/")) - -;;; ************************************************************************ -;;; Private functions -;;; ************************************************************************ - -(defun hypb:oct-to-int (oct-num) - "Returns octal integer OCTAL-NUM converted to a decimal integer." - (let ((oct-str (int-to-string oct-num)) - (dec-num 0)) - (and (string-match "[^0-7]" oct-str) - (error (format "(hypb:oct-to-int): Bad octal number: %s" oct-str))) - (mapconcat (function - (lambda (o) - (setq dec-num (+ (* dec-num 8) - (if (and (>= o ?0) (<= o ?7)) - (- o ?0)))))) - oct-str "") - dec-num)) - -;;; ************************************************************************ -;;; Private variables -;;; ************************************************************************ - -(provide 'hypb)
--- a/lisp/hyperbole/hyperbole.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,512 +0,0 @@ -;;!emacs -;; -;; LCD-ENTRY: See "hversion.el". -;; -;; FILE: hyperbole.el -;; SUMMARY: Sets up Hyperbole for autoloading and use. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: hypermedia -;; -;; AUTHOR: Bob Weiner -;; ORG: InfoDock Associates -;; -;; ORIG-DATE: 6-Oct-92 at 11:52:51 -;; LAST-MOD: 15-Mar-97 at 17:09:40 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1992-1996, Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; -;; See the "README" file for installation instructions. -;; -;; There is no need to manually edit this file unless there are specific -;; customizations you would like to make, such as whether the Hyperbole -;; mouse buttons are placed on shifted or unshifted mouse buttons. -;; (See the call of the function, hmouse-shift-buttons, below.) -;; -;; Other site-specific customizations belong in "hsite.el" which is created -;; from "hsite-ex.el" by the person who installs Hyperbole at your site. -;; -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Hyperbole directory setting -;;; ************************************************************************ - -;; Defines hyperb:window-system, hyperb:kotl-p and -;; (hyperb:path-being-loaded), which are used below. -;; The Hyperbole distribution directory must either already be in -;; load-path or an explicit load of "hversion" must have been -;; done already or else the following line will fail to load hversion. -;; This is all documented in the Hyperbole installation instructions. -(require 'hversion) - -;; Reinitialize hyperb:dir on reload if initialization failed for any reason. -(and (boundp 'hyperb:dir) (null hyperb:dir) (makunbound 'hyperb:dir)) - -(defvar hyperb:dir (if (fboundp 'backtrace-frame) (hyperb:path-being-loaded)) - "Directory where the Hyperbole executable code is kept. -It must end with a directory separator character.") -(if (stringp hyperb:dir) - (setq hyperb:dir (file-name-directory hyperb:dir)) - (error - "(hyperbole.el): Failed to set hyperb:dir. Try setting it manually.")) - -;;; ************************************************************************ -;;; Other required Elisp libraries -;;; ************************************************************************ - -(require 'set (expand-file-name "set" hyperb:dir)) - -;; Add hyperb:dir and kotl subdirectory to load-path so other -;; Hyperbole libraries can be found. -(setq load-path (set:add hyperb:dir load-path)) -(if hyperb:kotl-p - (setq load-path (set:add (expand-file-name "kotl/" hyperb:dir) load-path))) - -(require 'hvar) ;; Defines var:append function. - -;;; ************************************************************************ -;;; Public key bindings -;;; ************************************************************************ - -;;; Setup so Hyperbole can be autoloaded from a key. -;;; Choose a key on which to place the Hyperbole menus. -;;; For most people this key binding will work and will be equivalent -;;; to {C-h h}. -;;; -(or (where-is-internal 'hyperbole) - (where-is-internal 'hui:menu) - (define-key help-map "h" 'hyperbole)) - -;;; Provides a site standard way of emulating most Hyperbole mouse drag -;;; commands from the keyboard. This is most useful for rapidly creating -;;; Hyperbole link buttons from the keyboard without invoking the Hyperbole -;;; menu. Only works if Emacs is run under a window system. -;;; -(or (not hyperb:window-system) - (global-key-binding "\M-o") - (where-is-internal 'hkey-operate) - (global-set-key "\M-o" 'hkey-operate)) - -;;; Provides a site standard way of performing explicit button -;;; renames without invoking the Hyperbole menu. -;;; -(or (global-key-binding "\C-c\C-r") - (where-is-internal 'hui:ebut-rename) - (global-set-key "\C-c\C-r" 'hui:ebut-rename)) - -;;; The following operations are now available through the Hyperbole Win/ -;;; menu. In earlier versions of Hyperbole, each of these operations had its -;;; own keybindings. Uncomment the following code lines if you still want -;;; to use those key bindings. -;;; Key bindings for window configuration save/restore ring, like kill-ring -;;; except holds the configuration of windows within a frame. -;;; {C-x 4 w} to save config; {C-x 4 y} to restore successive -;;; saves; {C-x 4 DEL} to delete successive saves. -;;; -;; (or (global-key-binding "\C-x4w") -;; (global-set-key "\C-x4w" 'wconfig-ring-save)) -;; (or (global-key-binding "\C-x4y") -;; (global-set-key "\C-x4y" 'wconfig-yank-pop)) -;; (or (global-key-binding "\C-x4\177") -;; (global-set-key "\C-x4\177" 'wconfig-delete-pop)) - -;;; Provides a site standard way to easily switch between the Hyperbole mouse -;;; bindings and a set of personal mouse bindings. You may instead show -;;; users how to bind this to a key via `hyperb:init-hook' (see -;;; Hyperbole Manual). -;;; -(or (global-key-binding "\C-ct") - (where-is-internal 'hmouse-toggle-bindings) - (global-set-key "\C-ct" 'hmouse-toggle-bindings)) - -(defun hkey-either (arg) - "Executes `action-key' or with non-nil ARG executes `assist-key'." - (interactive "P") - (if arg (assist-key) (action-key))) - -;;; A value of t for `hkey-init' below will cause the Hyperbole -;;; context-sensitive keys to be bound to keyboard keys, in addition to any -;;; mouse key bindings. Comment it out or set it to nil if you don't want -;;; these bindings. Or change the bindings in the succeeding lines. -;;; -(or (boundp 'hkey-init) (setq hkey-init t)) -(and hkey-init - (not (global-key-binding "\M-\C-m")) - (global-set-key "\M-\C-m" 'hkey-either)) -;; -;; Bind a key, {C-h A}, for Action Key help and {C-u C-h A} for Assist key -;; help. -(and hkey-init - (not (where-is-internal 'hkey-help)) - (define-key help-map "A" 'hkey-help)) - -;;; -;;; Hyperbole key bindings for many non-edit modes. -;;; Set both to nil if unwanted. -;;; -(defvar action-key-read-only "\C-m" - "Local Action Key binding for special read-only modes.") -(defvar assist-key-read-only "\M-\C-m" - "Local Assist Key binding for special read-only modes.") - -;;; ************************************************************************ -;;; URL Browsing -;;; ************************************************************************ - -;;;###autoload -(defvar action-key-url-function 'w3-fetch - "Value is a function of one argument, a url, which displays the url referent. -Possible values are: - w3-fetch - display using the W3 Emacs web browser; - highlight-headers-follow-url-netscape - display in Netscape; - highlight-headers-follow-url-mosaic - display in Mosaic.") - -;;; ************************************************************************ -;;; Koutliner mode and file suffix importation settings. -;;; ************************************************************************ - -;;;###autoload -(defvar kimport:mode-alist - '((t . kimport:text) - (outline-mode . kimport:star-outline)) - "Alist of (major-mode . importation-function) elements. -This determines the type of importation done on a file when `kimport:file' is -called if the major mode of the import file matches the car of an element in -this list. If there is no match, then `kimport:suffix-alist' is checked. If -that yields no match, the element in this list whose car is 't is used. It -normally does an import of a koutline or text file. - -Each importation-function must take two arguments, a buffer/file to import -and a buffer/file into which to insert the imported elements and a third -optional argument, CHILDREN-P, which when non-nil means insert imported cells -as the initial set of children of the current cell, if any. - - outline-mode - imported as an Emacs outline whose entries begin with - asterisks; - .kot - .kotl - imported as a structured koutline - - all others - imported as text.") - -;;;###autoload -(defvar kimport:suffix-alist - '(("\\.otl$". kimport:star-outline) - ("\\.aug$" . kimport:aug-post-outline)) - "Alist of (buffer-name-suffix-regexp . importation-function) elements. -This determines the type of importation done on a file when `kimport:file' is -called. Each importation-function must take two arguments, a buffer/file to -import and a buffer/file into which to insert the imported elements and a -third optional argument, CHILDREN-P, which when non-nil means insert imported -cells as the initial set of children of the current cell, if any. - - .otl - imported as an Emacs outline whose entries begin with asterisks; - .kot - .kotl - imported as a structured koutline - .aug - imported as an Augment post-numbered outline.") - -;;; ************************************************************************ -;;; You shouldn't need to modify anything below here. -;;; ************************************************************************ - -(defun hkey-read-only-bindings () - "Binds Action and Assist Keys in many read-only modes. -Uses values of `action-key-read-only' and `assist-key-read-only'. Does -nothing if either variable is nil." - (if (not (and action-key-read-only assist-key-read-only)) - nil - (if (and (boundp 'Buffer-menu-mode-map) - (keymapp Buffer-menu-mode-map)) - (progn - (define-key Buffer-menu-mode-map action-key-read-only 'action-key) - (define-key Buffer-menu-mode-map assist-key-read-only - 'hkey-either))) - (if (and (boundp 'calendar-mode-map) - (keymapp calendar-mode-map)) - (progn - (define-key calendar-mode-map action-key-read-only 'action-key) - (define-key calendar-mode-map assist-key-read-only - 'hkey-either))) - (if (and (boundp 'dired-mode-map) - (keymapp dired-mode-map)) - (progn - (define-key dired-mode-map action-key-read-only 'action-key) - (define-key dired-mode-map assist-key-read-only - 'hkey-either))) - (if (and (boundp 'gnus-group-mode-map) - (keymapp gnus-group-mode-map)) - (progn - (define-key gnus-group-mode-map action-key-read-only 'action-key) - (define-key gnus-group-mode-map assist-key-read-only - 'hkey-either))) - (if (and (boundp 'gnus-summary-mode-map) - (keymapp gnus-summary-mode-map)) - (progn - (define-key gnus-summary-mode-map action-key-read-only 'action-key) - (define-key gnus-summary-mode-map assist-key-read-only - 'hkey-either))) - (if (and (boundp 'Info-mode-map) - (keymapp Info-mode-map)) - (progn - (define-key Info-mode-map action-key-read-only 'action-key) - (define-key Info-mode-map assist-key-read-only - 'hkey-either))) - (if (and (boundp 'oo-browse-mode-map) - (keymapp oo-browse-mode-map)) - (progn - (define-key oo-browse-mode-map action-key-read-only 'action-key) - (define-key oo-browse-mode-map assist-key-read-only - 'hkey-either))) - (if (and (boundp 'rmail-mode-map) - (keymapp rmail-mode-map)) - (progn - (define-key rmail-mode-map action-key-read-only 'action-key) - (define-key rmail-mode-map assist-key-read-only - 'hkey-either))) - (if (and (boundp 'rmail-summary-mode-map) - (keymapp rmail-summary-mode-map)) - (progn - (define-key rmail-summary-mode-map action-key-read-only 'action-key) - (define-key rmail-summary-mode-map assist-key-read-only - 'hkey-either))) - (if (and (boundp 'unix-apropos-map) - (keymapp unix-apropos-map)) - (progn - (define-key unix-apropos-map action-key-read-only 'action-key) - (define-key unix-apropos-map assist-key-read-only - 'hkey-either))) - )) - -(hkey-read-only-bindings) - -;;; ************************************************************************ -;;; Setup Hyperbole mouse bindings -;;; ************************************************************************ - -(require 'hmouse-key) -;;; The following function call selects between shifted and unshifted Action -;;; and Assist mouse buttons. With no argument or an argument of nil, -;;; shifted buttons are used, and under InfoDock, the middle button also acts -;;; as an Action Key. With a positive number as an argument, use shifted -;;; buttons. With any other integer, use unshifted buttons. -(hmouse-shift-buttons) - -;;; Permits restore of the prior window configuration after any help buffer -;;; is shown by pressing either the Action or Assist Key at the end of the -;;; help buffer. (Help buffer names end with "Help*".) -;;; -(setq temp-buffer-show-hook 'hkey-help-show - temp-buffer-show-function temp-buffer-show-hook) - -;;; ************************************************************************ -;;; Autoloads -;;; ************************************************************************ - -;;; Menu items could call this function before Info is loaded. -(autoload 'Info-goto-node "info" "Jump to specific Info node." t) - -;;; Hyperbole user interface entry points that trigger loading of the full -;;; Hyperbole system. - -;; Action type definitions. -(autoload 'defact "hsite" - "Creates an action TYPE (an unquoted symbol) with PARAMS, described by DOC." - nil 'macro) -;; Implicit button type definitions. -(autoload 'defib "hsite" - "Creates implicit button TYPE (unquoted sym) with PARAMS, described by DOC." - nil 'macro) - -(autoload 'ebut:map "hsite" "Map over Hyperbole buffer buttons." nil) -(autoload 'hbut:key-src "hsite" "Called by {e} command in rolo match buffer.") -(autoload 'hui:ebut-rename "hsite" "Rename a Hyperbole button." t) -(autoload 'hyperbole "hsite" "Hyperbole info manager menus." t) - -(autoload 'action-key "hsite" - "Context-sensitive Action Key command." t) -(autoload 'hkey-help "hsite" - "Display help for the Action Key command in current context. -With optional ASSIST-FLAG non-nil, display help for the Assist Key command. -Returns non-nil iff associated help documentation is found." t) -(autoload 'assist-key-help "hsite" - "Display help for the Assist Key command in current context." t) -(autoload 'hkey-help-hide "hsite" - "Restores frame to configuration prior to help buffer display." nil) -(autoload 'hkey-help-show "hsite" - "Saves prior frame configuration if BUFFER displays help." nil) -(autoload 'assist-key "hsite" - "Context-sensitive Assist Key command." t) -(autoload 'action-mouse-key "hsite" - "Context-sensitive Action Mouse Key command." t) -(autoload 'assist-mouse-key "hsite" - "Context-sensitive Assist Mouse Key command." t) -(autoload 'hkey-operate "hsite" "Emulate Hyperbole mouse key drags." t) -(autoload 'symset:add "hsite" "Adds ELT to SYMBOL's PROP set." nil) -(autoload 'hact "hsite" "Performs action formed from rest of ARGS." - nil) -(autoload 'actypes::exec-window-cmd "hsite" - "Executes an external window-based SHELL-CMD string asynchronously." nil) -(autoload 'hpath:absolute-to "hsite" - "Make PATH absolute from optional DEFAULT-DIRS." nil) -(autoload 'hpath:find "hsite" - "Edit file FILENAME, possibly using a special command." t) -(autoload 'hpath:find-other-frame "hsite" - "Edit file FILENAME in other frame, possibly using a special command." t) -(autoload 'hpath:find-other-window "hsite" - "Edit file FILENAME in other window, possibly using a special command." t) - -;;; Hyperbole entry points that trigger loading part of the system. - -(autoload 'hypb:functionp "hypb" "Return t iff OBJ is a function." nil) -(autoload 'hypb:display-file-with-logo "hypb" "Display FILE with IDA logo." nil) - -;;; Hyperbole msg reader autoloads. -(autoload 'Rmail-init "hrmail" "Initializes Hyperbole Rmail support." t) -(autoload 'Mh-init "hmh" "Initializes Hyperbole Mh support." t) -(autoload 'Vm-init "hvm" "Initializes Hyperbole Vm support." t) -(autoload 'Pm-init "hpm" "Initializes Hyperbole PIEmail support." t) -(autoload 'Gnus-init "hgnus" "Initializes Hyperbole Gnus support." t) - -;;; Hyperbole msg composer autoloads. -(autoload 'hmail:compose "hmail" - "Compose mail with ADDRESS and evaluation of EXPR." t) -(autoload 'hmail:msg-narrow "hmail" - "Narrows buffer to displayable part of current message. -Its displayable part begins at optional MSG-START and ends at or before MSG-END.") - -;;; Hyperbole outliner main entry points. -(if (not hyperb:kotl-p) - nil - (autoload 'kfile:find "kfile" "Edit an autonumbered outline." t) - (autoload 'kfile:is-p "kfile" "Is an unformatted outline?" nil) - (autoload 'kfile:view "kfile" - "View an autonumbered outline in read-only mode." t) - (autoload 'kotl-mode "kfile" "Autonumbered outlining mode." t) - ;; - ;; Entry points from Hyperbole Otl/ menu. - (autoload 'klink:create "klink" "Insert an implicit link at point." t) - (autoload 'kotl-mode:is-p "kfile" "Test if within a Hyperbole outline.") - (autoload 'kotl-mode:hide-tree "kfile" "Hide sublevels of current tree." t) - (autoload 'kotl-mode:overview "kfile" "Show first line of each cell." t) - (autoload 'kotl-mode:show-all "kfile" "Expand all outline cells." t) - (autoload 'kotl-mode:show-tree "kfile" "Expand current tree cells." t) - (autoload 'kotl-mode:top-cells "kfile" "Hide all but top-level cells." t) - ;; - ;; Functions required from outline.el library. - (autoload 'show-all "outline" "Show all of the text in the buffer." t) - ;; - (autoload 'kimport:file "kfile" "Import different file types." t) - (autoload 'kimport:aug-post-outline "kfile" "Import Augment files." t) - (autoload 'kimport:star-outline "kfile" "Import * outline files." t) - (autoload 'kimport:text "kfile" "Import text or koutline files." t) - ) - -;;; Hyperbole rolodex main entry points. -(autoload 'rolo-add "wrolo" "Add an entry to rolodex" t) -(autoload 'rolo-display-matches "wrolo" "Redisplay previous rolodex matches" t) -(autoload 'rolo-edit "wrolo" "Edit an existing rolodex entry" t) -(autoload 'rolo-fgrep "wrolo" "Rolodex string search" t) -(autoload 'rolo-grep "wrolo" "Rolodex regexp search" t) -(autoload 'rolo-kill "wrolo" "Delete an existing rolodex entry" t) -(autoload 'rolo-logic "wrolo-logic" "Logical rolodex search filters." t) -(autoload 'rolo-sort "wrolo" "Sort rolodex entries" t) -(autoload 'rolo-toggle-datestamps "wrolo" "Toggle datestamp insertion." t) -(autoload 'rolo-word "wrolo" "Rolodex string search for a word" t) -(autoload 'rolo-yank "wrolo" "Insert a rolodex entry into current buffer" t) - -;;; Hyperbole Key autoloads. -(autoload 'Info-handle-in-note "hmous-info" - "Follows Info documentation references.") -(autoload 'smart-info "hmous-info" "Follows Info documentation references." t) -(autoload 'smart-info-assist "hmous-info" - "Follows Info documentation references." t) -(autoload 'smart-asm-at-tag-p "hmouse-tag" - "Jumps to assembly identifier definitions.") -(autoload 'smart-c-at-tag-p "hmouse-tag" "Jumps to C identifier definitions.") -(autoload 'smart-lisp-mode-p "hmouse-tag" - "Jumps to Lisp identifier definitions.") -(autoload 'smart-c++ "hmouse-tag" "Jumps to C++ identifier definitions.") -(autoload 'smart-fortran-at-tag-p "hmouse-tag" "Jumps to Fortran identifier definitions.") -(autoload 'smart-java "hmouse-tag" "Jumps to Java identifier definitions.") -(autoload 'smart-java-at-tag-p "hmouse-tag" "Jumps to Java identifier definitions.") -(autoload 'smart-objc "hmouse-tag" "Jumps to Objective-C identifier definitions.") -(autoload 'smart-tags-file "hmouse-tag" "Determines nearest etags file.") -(autoload 'smart-tags-file-path "hmouse-tag" "Expands a filename from TAGS file.") - -;;; Window configuration save and restore autoloads. -(autoload 'wconfig-add-by-name "wconfig" "Save win config under name." t) -(autoload 'wconfig-delete-by-name "wconfig" "Delete win config under name." t) -(autoload 'wconfig-restore-by-name "wconfig" "Restore win config under name." t) -(autoload 'wconfig-ring-save "wconfig" "Save window-config to ring." t) -(autoload 'wconfig-yank-pop "wconfig" "Pop window-config from ring." t) -(autoload 'wconfig-delete-pop "wconfig" "Delete window-config from ring." t) - -;;; ************************************************************************ -;;; Auto mode file suffixes -;;; ************************************************************************ - -;;; Invoke kotl-mode for files ending in ".kotl". Also allow ".kot" for DOS -;;; and Windows users. -(if hyperb:kotl-p - (setq auto-mode-alist (cons '("\\.kotl$\\|\\.kot$" . kotl-mode) - auto-mode-alist))) - -;;; ************************************************************************ -;;; MESSAGE SYSTEM SUPPORT CONFIGURATION -;;; ************************************************************************ - -;;; Even if you don't need some of the following hook settings, you might -;;; as well leave them in so that if they ever become useful to you, you -;;; need not reconfigure Hyperbole. These settings do nothing if the -;;; corresponding subsystems are never invoked. -;;; -;;; GNUS USENET news reader/poster support. -;;; -(var:append 'gnus-Startup-hook '(Gnus-init)) -;;; -;;; Hyperbole mail reader support configuration. -;;; -;; Rmail -(var:append 'rmail-mode-hook '(Rmail-init)) -;; Mh-e -(var:append 'mh-inc-folder-hook '(Mh-init)) -;; -;; VM support is based on V5.72 beta of VM. If you have a version of VM -;; earlier than 5.70 beta, you should either upgrade or comment out the -;; following line so that Hyperbole support for VM is not enabled. -(var:append 'vm-mode-hooks '(Vm-init)) -;; -;; PIEmail -(var:append 'pm-hook '(Pm-init)) -;;; -;;; Hyperbole mail composer support configuration. -;;; -(var:append 'mail-mode-hook (list (function (lambda () (require 'hsmail))))) -(var:append 'mh-letter-mode-hook (list (function (lambda () (require 'hsmail))))) -(var:append 'vm-mail-mode-hook (list (function (lambda () (require 'hsmail))))) - -;;; ************************************************************************ -;;; Frame function aliases. -;;; ************************************************************************ -;; Create all needed `frame-' aliases for all `screen-' functions, e.g. -;; screen-width. -(if (fboundp 'selected-frame) - nil - (fset 'selected-frame 'selected-screen) - (mapcar - (function (lambda (func-name) - (or (fboundp (intern-soft (concat "frame" func-name))) - (fset (intern (concat "frame" func-name)) - (intern-soft (concat "screen" func-name)))))) - '("-width" "-height"))) - -;;; ************************************************************************ -;;; Register Hyperbole Package -;;; ************************************************************************ - -(provide 'hyperbole)
--- a/lisp/hyperbole/kotl/EXAMPLE.kotl Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,487 +0,0 @@ -;; -*- Mode: kotl -*- -"Kotl-4.0" ;; file-format - - 1 The Koutliner is a part of the Hyperbole information management system. - InfoDock Associates, the developer of Hyperbole and InfoDock (an - industrial quality turn-key version of XEmacs), sells high quality - commercial support, training, books and custom package development for - InfoDock, XEmacs or GNU Emacs on a variety of platforms. Contact us at - <info@infodock.com> or visit our web site at http://www.infodock.com. - - 2 The Koutliner produces hierarchically structured files consisting of - trees of cells. - - 2a A cell is an element of the outline which has its own display label - and unique, permanent identifier (idstamp). - - 2b Idstamps support the creation of hyperlinks to cells which are - maintained as the structure of an outline changes. - - 3 Features implemented include: - - 3a Full on screen editing (just like a Macintosh). Click to type in a - node (we call them cells) and just enter text. Structure is - automatically maintained for you. All of the standard Emacs editor - command set is supported both through keyboard and mouse interaction. - - 3b Advanced outline processing - - 3b1 Autonumbering: Full auto-numbering in Augment (1a2) or legal - (1.1.2) formats. Augment style is the default. Single level - autonumbering (only the last part of the level number is shown), - as commonly seen in outliner products, is also available, though - it has not been tested very much and so is not recommended. Use - {C-c C-l ?} to see the full set of label types and to select a - different label type. - - 3b2 Label Separators: By default, the outliner separates labels from - cell contents by two spaces. If you want to change the separator - for the current outline, use {C-c M-l}. {C-u C-c M-l} will - additionally change the default separator value used when new - outlines are created. For example, use the value ". " to get a - trailing period after each cell label. The separator must be at - least two characters long. - - 3b3 Cell Creation: {C-j} adds a new cell as a sibling following the - current cell. A non-negative prefix argument, {C-u C-j} or {C-c - a} adds the cell as a child of the current cell. {C-c p} adds the - cell as the sibling of the current cell's parent. - - 3b4 Cell and Tree Deletion: {C-c C-k} kills the current cell and its - entire subtree. {C-c k} kills the contents of a cell from point - through the end of the cell. {C-u C-c k} kills the entire - contents of the cell regardless of the location of point. You may - then yank the contents into another cell with {C-y}. - - 3b5 Tree Demotion and Promotion: Trees may be demoted or promoted by - hitting {TAB} or {M-TAB} respectively, as in most outliners today - (their sub-levels move with them). {M-0 TAB} and {M-0 M-TAB} will - demote and promote trees and will additionally refill each cell - which has not been specially marked to prevent refilling. - - You can also use a command line interface and either enter cell - ids or select the cells to operate upon by using your mouse. - - 3b6 Cell and Tree Filling: {M-q} or {M-j} refills a paragraph within a - cell so that its lines wrap within the current margin settings. - {C-c M-q} or {C-c M-j} refills all paragraphs within a cell. - {C-M-q} or {C-M-j} refills all cells within a tree. - - Set the variable, kotl-mode:refill-flag, to t if you want moving, - promoting, demoting, exchanging, splitting and appending cells to - also automatically refill each cell. - - 3b7 Cursor Movement: In addition to normal Emacs movement commands, - you can move within a cell or from one cell or tree to another. - - {C-c ,} - Move to the beginning of the current cell. - {C-c .} - Move to the end of the current cell. - - {C-c C-n} - Move to the next visible cell, regardless of level. - {C-c C-p} - Move to the prev visible cell, regardless of level. - - {C-c C-f} - Move forward to this cell's successor, if any. - {C-c C-b} - Move backward to this cell's predecessor, if any. - - {C-c C-d} - Move to first child of current cell, if any. - - {C-c C-u} - Move to parent cell of current cell, if any. - - {C-c <} - Move to the first sibling at the current level. - {C-c >} - Move to the last sibling at the current level. - - {C-c ^} - Move to the level 1 root of the current tree. - {C-c $} - Move to the last cell in the tree rooted at point. - - 3b8 Tree Movement and Copying: Entire outline trees can be moved or - copied with single commands. Simply invoke the desired command - and then double click with the Action Key on the desired root cell - for each argument for which you are prompted. - - Copying and moving only work within a single outline right now, so - don't use them to move trees across different outline files. You - can, however, copy an outline tree to a non-outline buffer with: - {C-c M-c} - Copy a koutline tree to a non-koutline buffer. - {C-c @} - Copy a koutline tree to an outgoing mail message. - - {C-c c} - Copy <tree> to follow as sibling of <cell>. - {C-u C-c c} - Copy <tree> to follow as first child of <cell>. - - {C-c C-c} - Copy <tree> to precede <cell>. - {C-u C-c C-c} - Copy <tree> as first child of the parent of <cell>. - - {C-c m} - Move <tree> to follow as sibling of <cell>. - {C-u C-c m} - Move <tree> to follow as first child of <cell>. - - {C-c C-m} - Move <tree> to precede <cell>. - {C-u C-c C-m} - Move <tree> as first child of the parent of <cell>. - - If you have mouse support under Hyperbole, you can move entire - trees with mouse clicks. Simply click the Assist Key within the - indentation to the left of a cell text and you will be prompted - for a tree to move. Double click the Action Key within the body - of the root cell of the tree to move and then double click within - the body of the root cell of the tree you want it to follow. - - 3b9 Cell Transposition: The move and copy commands rearrange entire - trees. The following two commands exchange the locations of two - cells. - - 3b9a {C-c e} prompts for two cell addresses and exchanges the cells. - - 3b9b {C-c t} does not prompt. It exchanges the current and - preceding cells. If there is no preceding cell it exchanges - the current and next cell. - - {C-c t} with a prefix argument of zero exchanges the cells in - which point and mark fall. - - {C-c t} with a non-zero numeric prefix argument, N, moves - the current tree past maximally the next N visible cells. If - there are fewer visible, it makes the current cell the last - cell in the outline. - - 3b10 Cell Splitting: You can split one cell into two adjacent cells - with {C-c s}. This leaves the cell contents preceding point in - the current cell, minus any trailing whitespace, and moves the - contents following point to a new sibling cell which is inserted - into the outline. {C-u C-c s} adds the new cell as the first - child of the original cell, rather than as its sibling. - - All cell attributes in the original cell are propagated to the new - one. - - 3b11 Cell Appending: {C-c +} appends the contents of a specified cell - to the end of another cell. - - 3b12 Hiding and Showing: Individual cells, branches, or particular - levels in the outline may be hidden or shown. These commands work - even when an outline buffer is read-only, e.g. when its file is - not checked out of a version control system yet. - - 3b12a {C-c C-h} - Hide (collapse) tree rooted at point. - {C-c C-s} - Show (expand) tree rooted at point. - - {C-c C-a} - Show (expand) all cells in the outline. - {C-x $} - Show all cells down to a particular level. The - user is prompted for the level or a prefix - argument may be given. - - {C-M-h} - Hide subtree at point, excluding root. - {M-x kotl-mode:show-subtree} - Show subtree at point. - - {C-c C-o} - Overview, show only first line of outline cells. - {C-c C-t} - Top-level, hide all cells below level 1 and show - only the first line of each level 1 cell. - - 3b12b A click or press of the Action Key within a cell's body, but - not on a button, toggles between hiding and showing the tree - rooted at point. - - 3b13 Cell Identifiers: Permanent ids are associated with each cell and - can be used in hyperlinks that are maintained as cells are - reordered in a file. (These ids may also be displayed in place of - the outline level relative ids. Use {C-c C-l id RET}.) Permanent - ids are numbered from 0, where 0 is the root node of the entire - outline. This node is never visible within the outline. - Permanent ids always begin with a 0, as in 012, to distinguish - them from relative ids. - - 3b14 Cell Attributes: Each cell has its own attribute list. The - attribute lists for the cells in the tree rooted at point can be - displayed by pressing the Assist Key. {C-c h} prompts for a kcell - id and displays its attributes. {C-u C-c h} prompts for a kcell - id and displays the attributes for it and its subtree; use 0 as - the kcell id to see attributes for all visible cells in the - outline. - - Use {C-c C-i} to add an attribute or to modify an existing - attribute to the cell at point. - - 3b15 File Insertion: The elements of another buffer or file may be - inserted into a koutline as a set of cells by using the {C-x i} - command. When prompted, you may use a buffer name or file name - from which to insert. - - 3b15a The cells will be inserted as the successors of the current - cell unless {C-u C-x i} is used and then they are inserted as - the initial children of the current cell. - - 3b15b See the documentation for the variables, kimport:mode-alist and - kimport:suffix-alist, for information on mode and - suffix-specific conversions performed on files before they are - inserted. This same conversion process applies if you invoke - {M-x kotl-mode RET} in a non-koutline buffer or if you perform - a generic file import as described in <@ 2b16>. - - 3b15c Use {M-x kotl-mode:insert-file-contents RET} to insert the - entire contents of a file into the current cell at the location - of point. - - 3b16 File Importation: The outliner presently supports conversion of - three types of files into koutline files. You can choose to - import a file into an existing koutline, following the tree at - point, or to create a new koutline of the imported file contents. - {M-x kimport:file RET} will select the importation type based on - the buffer or file name suffix of the file to import. Use one of - the following commands if you want to control the type of - importation explicitly. - - 3b16a Text Files - - 3b16a1 In a text buffer, use {M-x kotl-mode RET} to convert - the buffer into a koutline in-place. You will lose the old - format of the buffer when you do this. - - 3b16a2 Use {M-x kimport:text RET} and you will be prompted for a - text buffer or file to import and the new koutline buffer or - file to create from its text. It will also import the - contents, attributes and level structure of cells from a - koutline. - - With this command, your original file remains intact. - - 3b16b Star Outline Files: Star outlines are standard Emacs outlines - where each entry begins with one or more asterisk characters. - Use {M-x kimport:star-outline RET} and you will be prompted - for the star outline buffer or file to import and the new - koutline buffer or file to create. - - 3b16c Augment Files Numbered on the Right-Side: (Skip this if you are - unfamiliar with this sort of file.) Files exported from the - Augment system as text often have alphanumeric statement - identifiers on the right side. - - Use {M-x kimport:aug-post-outline RET} and you will be prompted - for the augment buffer or file to import and the koutline to - create. - - 3b17 View Specification: Flexible views of outlines may be specified - with succinct single character codes. - - 3b17a The current view spec is shown in the modeline after the buffer - name, delimited by <|>. - - 3b17b The current view spec is saved whenever the outline is saved. - The next time the outline is read in, this will be the initial - view. The standard initial viewspec is <|ben>. - - 3b17c {C-c C-v} prompts for a view spec string in which the following - codes are valid. Any invalid characters in a view spec are - ignored. - - 3b17c1 a: Show all cell levels and all lines in cells. - - 3b17c2 b: Turn on blank lines between cells. Without this code, - blank lines will be turned off. You can also use the - {C-c b} key binding to toggle line numbers on and off - independent of any other view settings. - - 3b17c3 cN: Hide any lines greater than N in each cell. 0 means - don't cutoff any lines. - - 3b17c4 e: Show ellipses when some content is hidden. - - 3b17c5 lN: Hide cells at levels deeper than N. 0 means don't hide - any cells. - - 3b17c6 n: Turn on the default label type. - n0: Display idstamps. - n1: Display alpha labels. - n2: Display partial alpha labels (don't use this). - n.: Display legal labels. - n*: Display star labels. - n~: Turn off labels. (n viewspec is removed from modeline). - - 3b17d Try a view spec of `c2l1' to turn off blank lines, to clip each - cell after its second line, and to hide all cells below level - one. - - 3c Hyperlinks may be embedded in cells and may refer to other cells. - Explicit Hyperbole buttons may be created as usual via mouse drags, - see "(hyperbole.info)By Dragging". A klink is a special implicit - link button that jumps to a specific outline cell. - - 3c1 Here are three klink examples: - - 3c1a <@ 3b=06> jumps to the cell within this outline which has - permanent id `06' and relative id `2b', namely the preceding - sibling of this cell's parent. <@ 06> does the same thing, as - does <@ 2b>, though this latter form will not maintain the link - properly if the cell is moved elsewhere within the outline. - - 3c1b <EXAMPLE.kotl, 4=012 |c1e> displays the named file, starting at - the unimplemented features section whose permanent identifer is - 012, with the view specification of: blank lines turned off, - cutoff after one line per cell, and show ellipses for cells or - trees which are clipped. - - 3c1c <|ben> is a klink consisting of just a view specification. - When activated, it sets the view in the current outline to - display blank lines, ellipses following collapsed lines and - standard alphanumeric numbering. - - 3c2 There are a number of easy ways to insert klinks into koutlines. - If you have mouse support under Hyperbole, simply click the Action - Key within the indentation to the left of a cell text. If you - then double click on some cell, a link to that cell will be - inserted where you started. From a keyboard, use {C-c l} when in - a koutline or {C-h h o l} when not in a koutline to insert a - klink. - - 3d The outliner code runs on virtually any UNIX system. It supports dumb - terminal, X window, and NEXTSTEP (Display Postscript) displays. - - 4 Features remaining to be implemented: - - 4a Branch handling commands (all cells at same level). - - 4b Copying a single cell without its subtree. - - 4c Replacing one cell or one tree with another. - - 4d Transposing two trees, rather than two cells. - - 4e A small amount of work remains to enable setting different per level - fonts and colors, so that outline levels are visually easy to - distinguish. - - 4f Flexible view handling has been only partially implemented. - - 4g The code to export from koutlines to other formats has not yet been - written. Exporting to HTML, for example would be very useful. - - -"ben" ;; kvspec:current -75 ;; id-counter -alpha ;; label-type -3 ;; label-min-width -" " ;; label-separator -3 ;; level-indent - -;; depth-first kcell attributes -[[0 - (creator "weiner@infodock.com" create-time "19970219:03:24:19" id-counter 75 file "/home/infodock/lisp/hyperbole/kotl/EXAMPLE.kotl")] - [20 - (creator "weiner@infodock.com" create-time "19940104:17:38:28" no-fill t)] - [75 - (idstamp 20 creator "weiner@infodock.com" create-time "19940104:17:38:28" no-fill t)] - [34 - (creator "weiner@infodock.com" create-time "19940610:16:43:55")] - [35 - (creator "weiner@infodock.com" create-time "19940610:16:44:03")] - [4 - (creator "weiner@infodock.com" create-time "19940104:17:38:29")] - [5 - (creator "weiner@infodock.com" create-time "19940104:17:38:29")] - [6 - (creator "weiner@infodock.com" create-time "19940104:17:38:29")] - [14 - (creator "weiner@infodock.com" create-time "19940104:17:38:29")] - [67 - (creator "weiner@infodock.com" create-time "19951028:04:29:13" no-fill t)] - [15 - (creator "weiner@infodock.com" create-time "19940104:17:38:29")] - [31 - (creator "weiner@infodock.com" create-time "19940306:18:11:43")] - [7 - (creator "weiner@infodock.com" create-time "19940104:17:38:29")] - [46 - (creator "weiner@infodock.com" create-time "19950614:21:35:17")] - [43 - (creator "weiner@infodock.com" create-time "19940610:22:00:46")] - [22 - (creator "weiner@infodock.com" create-time "19940127:22:41:42")] - [32 - (creator "weiner@infodock.com" create-time "19940610:16:31:28")] - [41 - (creator "weiner@infodock.com" create-time "19940610:18:55:09")] - [42 - (creator "weiner@infodock.com" create-time "19940610:18:55:57")] - [33 - (creator "weiner@infodock.com" create-time "19940610:16:31:29")] - [47 - (creator "weiner@infodock.com" create-time "19951022:22:59:26" no-fill t)] - [8 - (creator "weiner@infodock.com" create-time "19940104:17:38:29")] - [28 - (creator "weiner@infodock.com" create-time "19940128:22:50:44")] - [29 - (creator "weiner@infodock.com" create-time "19940128:22:50:54")] - [10 - (creator "weiner@infodock.com" create-time "19940104:17:38:29")] - [30 - (creator "weiner@infodock.com" create-time "19940129:00:27:59")] - [62 - (creator "weiner@infodock.com" create-time "19951026:08:32:57" no-fill t)] - [70 - (creator "weiner@infodock.com" create-time "19951030:19:18:49" no-fill t)] - [71 - (creator "weiner@infodock.com" create-time "19951030:19:19:40" no-fill t)] - [73 - (creator "weiner@infodock.com" create-time "19951030:19:23:09" no-fill t)] - [63 - (creator "weiner@infodock.com" create-time "19951026:19:31:34" no-fill t)] - [64 - (creator "weiner@infodock.com" create-time "19951026:19:33:01" no-fill t)] - [69 - (creator "weiner@infodock.com" create-time "19951029:06:24:35" no-fill t)] - [68 - (creator "weiner@infodock.com" create-time "19951029:06:24:27" no-fill t)] - [65 - (creator "weiner@infodock.com" create-time "19951026:19:33:08" no-fill t)] - [66 - (creator "weiner@infodock.com" create-time "19951026:19:33:15" no-fill t)] - [48 - (creator "weiner@infodock.com" create-time "19951023:05:55:19" no-fill t)] - [57 - (creator "weiner@infodock.com" create-time "19951023:10:07:06" no-fill t)] - [58 - (creator "weiner@infodock.com" create-time "19951023:10:07:26" no-fill t)] - [49 - (creator "weiner@infodock.com" create-time "19951023:05:55:55" no-fill t)] - [55 - (creator "weiner@infodock.com" create-time "19951023:08:56:41" no-fill t)] - [50 - (creator "weiner@infodock.com" create-time "19951023:05:57:26" no-fill t)] - [51 - (creator "weiner@infodock.com" create-time "19951023:05:58:31" no-fill t)] - [56 - (creator "weiner@infodock.com" create-time "19951023:08:57:09" no-fill t)] - [52 - (creator "weiner@infodock.com" create-time "19951023:05:59:59" no-fill t)] - [53 - (creator "weiner@infodock.com" create-time "19951023:06:00:48" no-fill t)] - [54 - (creator "weiner@infodock.com" create-time "19951023:06:05:50" no-fill t)] - [26 - (creator "weiner@infodock.com" create-time "19940128:03:56:23")] - [27 - (creator "weiner@infodock.com" create-time "19940128:22:36:54")] - [59 - (creator "weiner@infodock.com" create-time "19951024:03:40:05" no-fill t)] - [60 - (creator "weiner@infodock.com" create-time "19951024:03:40:13" no-fill t)] - [61 - (creator "weiner@infodock.com" create-time "19951024:03:40:42" no-fill t)] - [1 - (creator "weiner@infodock.com" create-time "19940104:17:38:29")] - [11 - (creator "weiner@infodock.com" create-time "19940104:17:38:29")] - [12 - (creator "weiner@infodock.com" create-time "19940104:17:38:29")] - [44 - (creator "weiner@infodock.com" create-time "19940728:21:56:49")] - [36 - (creator "weiner@infodock.com" create-time "19940610:16:49:34")] - [37 - (creator "weiner@infodock.com" create-time "19940610:16:50:02")] - [38 - (creator "weiner@infodock.com" create-time "19940610:16:50:13")] - [13 - (creator "weiner@infodock.com" create-time "19940104:17:38:29")] - [16 - (creator "weiner@infodock.com" create-time "19940104:17:38:29")] - [74 - (creator "weiner@infodock.com" create-time "19951101:21:56:21" no-fill t)] - nil nil nil nil nil nil nil nil nil nil nil nil nil nil]
--- a/lisp/hyperbole/kotl/kfile.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,535 +0,0 @@ -;;!emacs -;; -;; FILE: kfile.el -;; SUMMARY: Save and restore kotls from files. -;; USAGE: GNU Emacs V19 Lisp Library -;; KEYWORDS: outlines, wp -;; -;; AUTHOR: Bob Weiner & Kellie Clark -;; -;; ORIG-DATE: 10/31/93 -;; LAST-MOD: 6-Mar-97 at 01:17:51 by Bob Weiner - -;;; ************************************************************************ -;;; Other required Elisp libraries -;;; ************************************************************************ - -(mapcar 'require '(kproperty kotl-mode)) - -;; Loads menus under non-tty InfoDock, XEmacs or Emacs19; does nothing -;; otherwise. -(and (not (featurep 'kmenu)) hyperb:window-system - (or hyperb:lemacs-p hyperb:emacs19-p) (require 'kmenu)) - -;;; ************************************************************************ -;;; Public variables -;;; ************************************************************************ - -(defconst kfile:version "Kotl-4.0" - "Version number of persistent data format used for saving koutlines.") - -;;; ************************************************************************ -;;; Entry Points -;;; ************************************************************************ - -;;;###autoload -(defun kfile:find (file-name) - "Find a file FILE-NAME containing a kotl or create one if none exists. -Return the new kview." - (interactive - (list (kfile:read-name - "Find koutline file: " nil))) - (let ((existing-file (file-exists-p file-name)) - buffer) - (and existing-file - (not (file-readable-p file-name)) - (error - "(kfile:find): \"%s\" is not readable. Check permissions." - file-name)) - (setq buffer (find-file file-name)) - ;; Finding the file may have already done a kfile:read as invoked through - ;; kotl-mode via a file local variable setting. If so, don't read it - ;; again. - (if (kview:is-p kview) - nil - (kfile:read buffer existing-file)) - (or (eq major-mode 'kotl-mode) (kotl-mode)) - kview)) - -;;;###autoload -(defun kfile:view (file-name) - "View an existing kotl version-2 file FILE-NAME in a read-only mode." - (interactive - (list (kfile:read-name - "View koutline file: " t))) - (let ((existing-file (file-exists-p file-name))) - (if existing-file - (if (not (file-readable-p file-name)) - (error - "(kfile:view): \"%s\" is not readable. Check permissions." - file-name)) - (error "(kfile:view): \"%s\" does not exist.")) - (view-file file-name)) - (kfile:narrow-to-kcells) - (goto-char (point-min))) - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -(defun kfile:create (buffer) - "Create a new koutline file attached to BUFFER, with a single empty level 1 kotl cell. -Return file's kview." - (or buffer (setq buffer (current-buffer))) - (if (not (bufferp buffer)) - (error "(kfile:create): Invalid buffer argument, %s" buffer)) - (set-buffer buffer) - (if buffer-read-only - (error "(kfile:create): %s is read-only" buffer)) - (widen) - - (let ((empty-p (zerop (buffer-size))) - import-from view standard-output) - - (if (not empty-p) - ;; This is a foreign file whose elements must be converted into - ;; koutline cells. - (progn (setq import-from (kimport:copy-and-set-buffer buffer)) - (set-buffer buffer) - (erase-buffer))) ;; We copied the contents to `import-from'. - - (setq view (kview:create (buffer-name buffer)) - standard-output (current-buffer)) - (goto-char (point-min)) - (princ ";; -*- Mode: kotl -*- \n") - (prin1 kfile:version) - (princ " ;; file-format\n\^_\n") - ;; Ensure that last cell has two newlines after it so that - ;; kfile:insert-attributes finds it. - (goto-char (point-max)) - (princ "\n\n\^_\n") - (princ "\^_\n;; depth-first kcell attributes\n") - ;; Ensure that display is narrowed to cell region only. - (kfile:narrow-to-kcells) - (goto-char (point-min)) - (if empty-p - ;; This is a new koutline file. Always need at least one visible - ;; cell within a view. Insert initial empty cell. - (progn (kview:add-cell "1" 1) - ;; Mark view unmodified, so if kill right away, there is no - ;; prompt. - (set-buffer-modified-p nil) - ;; Move to first cell. - (goto-char (point-min)) - (goto-char (kcell-view:start))) - ;; Import buffer. Next line is necessary or the importation will fail. - (delete-region (point-min) (point-max)) - ;; Import foreign buffer as koutline cells. - (kimport:file import-from (current-buffer)) - ;; If import buffer name starts with a space, kill it, as it is no - ;; longer needed. - (if (= ?\ (aref (buffer-name import-from) 0)) - (kill-buffer import-from))) - - view)) - -;;;###autoload -(defun kfile:is-p () - "Iff current buffer contains an unformatted or formatted koutline, return file format version string, else nil." - (let (ver-string) - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (condition-case () - (progn - (setq ver-string (read (current-buffer))) - (and (stringp ver-string) (string-match "^Kotl-" ver-string) - ver-string)) - (error nil)))))) - -(defun kfile:read (buffer existing-file-p) - "Create a new kotl view by reading BUFFER or create an empty view when EXISTING-FILE-P is nil. -Return the new view." - (let (ver-string) - (cond ((not (bufferp buffer)) - (error "(kfile:read): Argument must be a buffer, `%s'." buffer)) - ((not existing-file-p) - (kfile:create buffer)) - ((progn - (set-buffer buffer) - (not (setq ver-string (kfile:is-p)))) - (error "(kfile:read): `%s' is not a koutline file." buffer)) - ((equal ver-string "Kotl-4.0") - (kfile:read-v4-or-v3 buffer nil)) - ((equal ver-string "Kotl-3.0") - (kfile:read-v4-or-v3 buffer t)) - ((equal ver-string "Kotl-2.0") - (kfile:read-v2 buffer)) - ((equal ver-string "Kotl-1.0") - (error "(kfile:read): V1 koutlines are no longer supported")) - (t (error "(kfile:read): `%s' has unknown kotl version, %s." - buffer ver-string))))) - -(defun kfile:read-v2 (buffer) - "Create a kotl view by reading kotl version-2 BUFFER. Return the new view." - (let ((standard-input buffer) - cell-count label-type label-min-width label-separator - level-indent cell-data kotl-structure view kcell-list) - (widen) - (goto-char (point-min)) - ;; Skip past cell contents here. - (search-forward "\n\^_" nil t 2) - ;; Read rest of file data. - (setq cell-count (read) - label-type (read) - label-min-width (read) - label-separator (read) - level-indent (read) - cell-data (read) - kotl-structure (read)) - ;; - ;; kcell-list is a depth-first list of kcells to be attached to the cell - ;; contents within the kview down below. - (setq kcell-list (kfile:build-structure-v2 kotl-structure cell-data) - view (kview:create (buffer-name buffer) cell-count label-type - level-indent label-separator label-min-width)) - ;; - (kfile:narrow-to-kcells) - (goto-char (point-min)) - ;; - ;; Add attributes to cells. - (kfile:insert-attributes-v2 view kcell-list) - ;; - ;; Mark view unmodified and move to first cell. - (set-buffer-modified-p nil) - (goto-char (point-min)) - (goto-char (kcell-view:start)) - view)) - -(defun kfile:read-v4-or-v3 (buffer v3-flag) - "Create a koutline view by reading version-4 BUFFER. Return the new view. -If V3-FLAG is true, read as a version-3 buffer." - (let ((standard-input buffer) - cell-count label-type label-min-width label-separator - level-indent cell-data view) - (widen) - (goto-char (point-min)) - ;; Skip past cell contents here. - (search-forward "\n\^_" nil t 2) - ;; Read rest of file data. - (if v3-flag - nil ;; V3 files did not store viewspecs. - (kvspec:initialize) - (setq kvspec:current (read))) - (setq cell-count (read) - label-type (read) - label-min-width (read) - label-separator (read) - level-indent (read) - cell-data (read)) - ;; - (setq view (kview:create (buffer-name buffer) cell-count label-type - level-indent label-separator label-min-width)) - ;; - (kfile:narrow-to-kcells) - (goto-char (point-min)) - ;; - ;; Add attributes to cells. - (kfile:insert-attributes-v3 view cell-data) - ;; - ;; Mark view unmodified and move to first cell. - (set-buffer-modified-p nil) - (goto-char (point-min)) - (goto-char (kcell-view:start)) - view)) - -(defun kfile:update (&optional visible-only-p) - "Update kfile internal structure so that view is ready for saving to a file. -Leave outline file expanded with structure data showing unless optional -VISIBLE-ONLY-P is non-nil. Signal an error if kotl is not attached to a file." - (let* ((top (kview:top-cell kview)) - (file (kcell:get-attr top 'file)) - (label-type (kview:label-type kview)) - (label-min-width (kview:label-min-width kview)) - (label-separator (kview:label-separator kview)) - (level-indent (kview:level-indent kview)) - ;; If this happens to be non-nil, it is virtually impossible to save - ;; a file, so ensure it is nil. - (debug-on-error)) - (cond ((null file) - (error "(kfile:update): Current outline is not attached to a file.")) - ((not (file-writable-p file)) - (error "(kfile:update): File \"%s\" is not writable." file))) - (let* ((buffer-read-only) - (id-counter (kcell:get-attr top 'id-counter)) - (kotl-data (make-vector (1+ id-counter) nil)) - (standard-output (current-buffer)) - (opoint (set-marker (make-marker) (point))) - (kcell-num 1) - cell) - ;; - ;; Prepare cell data for saving. - (kfile:narrow-to-kcells) - (kview:map-tree - (function - (lambda (view) - (setq cell (kcell-view:cell)) - (aset kotl-data - kcell-num - (kotl-data:create cell)) - (setq kcell-num (1+ kcell-num)))) - kview t) - ;; Save top cell, 0, last since above loop may increment the total - ;; number of cells counter stored in it, if any invalid cells are - ;; encountered. - (aset kotl-data 0 (kotl-data:create top)) - (setq id-counter (kcell:get-attr top 'id-counter)) - ;; - (widen) - (goto-char (point-min)) - (if (search-forward "\n\^_\n" nil t) - (delete-region (point-min) (match-end 0))) - (princ ";; -*- Mode: kotl -*- \n") - (prin1 kfile:version) - (princ " ;; file-format\n\^_\n") - ;; Skip past cells. - (if (search-forward "\n\^_\n" nil t) - ;; Get rid of excess blank lines after last cell. - (progn (goto-char (match-beginning 0)) - (skip-chars-backward "\n") - (delete-region (point) (point-max))) - (goto-char (point-max))) - ;; Ensure that last cell has two newlines after it so that - ;; kfile:insert-attributes finds it. - (princ "\n\n\^_\n") - (princ (format (concat - "%S ;; kvspec:current\n%d ;; id-counter\n" - "%S ;; label-type\n%d ;; label-min-width\n" - "%S ;; label-separator\n%d ;; level-indent\n") - kvspec:current id-counter label-type label-min-width - label-separator level-indent)) - (princ "\^_\n;; depth-first kcell attributes\n") - (kfile:pretty-print kotl-data) - ;; - ;; Don't re-narrow buffer by default since this is used in - ;; write-contents-hooks after save-buffer has widened buffer. If - ;; buffer is narrowed here, only the narrowed portion will be saved to - ;; the file. Narrow as an option since saving only the portion of the - ;; file visible in a view may be useful in some situations. - (if visible-only-p (kfile:narrow-to-kcells)) - ;; - ;; Return point to its original position as given by the opoint marker. - (goto-char opoint) - (set-marker opoint nil) - nil))) - -;;; Next function is adapted from `file-write' of GNU Emacs 19, copyright FSF, -;;; under the GPL. -(defun kfile:write (file) - "Write current outline to FILE." - (interactive "FWrite outline file: ") - (if (or (null file) (string-equal file "")) - (error "(kfile:write): Invalid file name, \"%s\"" file)) - ;; If arg is just a directory, use same file name, but in that directory. - (if (and (file-directory-p file) buffer-file-name) - (setq file (concat (file-name-as-directory file) - (file-name-nondirectory buffer-file-name)))) - (kcell:set-attr (kview:top-cell kview) 'file file) - (set-visited-file-name file) - ;; Set-visited-file-name clears local-write-file-hooks that we use to save - ;; koutlines properly, so reinitialize local variables. - (kotl-mode) - (set-buffer-modified-p t) - ;; This next line must come before the save-buffer since write-file-hooks - ;; can make use of it. - (kview:set-buffer-name kview (buffer-name)) - (save-buffer)) - -;;; ************************************************************************ -;;; Private functions -;;; ************************************************************************ - -(defun kfile:build-structure-v2 (kotl-structure cell-data) - "Build cell list from the KOTL-STRUCTURE and its CELL-DATA. -Assumes all arguments are valid. CELL-DATA is a vector of cell fields read -from a koutline file. - -Return list of outline cells in depth first order. Invisible top cell is not -included in the list." - (let ((stack) (sibling-p) (cell-list) func cell) - (mapcar - (function - (lambda (item) - (setq func (cdr (assoc item - (list - (cons "\(" - (function - (lambda () - (setq stack (cons sibling-p stack) - sibling-p nil)))) - (cons "\)" - (function - (lambda () - (setq sibling-p (car stack) - stack (cdr stack))))))))) - (cond (func (funcall func)) - ;; 0th cell was created with kview:create. - ((equal item 0) nil) - (t (setq cell (kotl-data:to-kcell-v2 (aref cell-data item)) - cell-list (cons cell cell-list) - sibling-p t) - )))) - kotl-structure) - (nreverse cell-list))) - -(defun kfile:insert-attributes-v2 (kview kcell-list) - "Set cell attributes within kview for each element in KCELL-LIST. -Assumes all cell contents are already in kview and that no cells are -hidden." - (let (buffer-read-only) - (while - (progn - (skip-chars-forward "\n") - ;; !!! Won't work if label-type is 'no. - ;; Here we search past the cell identifier - ;; for the location at which to place cell properties. - ;; Be sure not to skip past a period which may terminate the label. - (if (re-search-forward "[A-Za-z0-9]\\(\\.?[A-Za-z0-9]\\)*" nil t) - (progn - (kproperty:set 'kcell (car kcell-list)) - (setq kcell-list (cdr kcell-list)))) - (search-forward "\n\n" nil t))))) - -(defun kfile:insert-attributes-v3 (kview kcell-vector) - "Set cell attributes within kview for each element in KCELL-VECTOR. -Assumes all cell contents are already in kview and that no cells are -hidden." - (let ((kcell-num 1) - (buffer-read-only)) - (while - (progn - (skip-chars-forward "\n") - ;; !!! Won't work if label-type is 'no. - ;; Here we search past the cell identifier - ;; for the location at which to place cell properties. - ;; Be sure not to skip past a period which may terminate the label. - (if (re-search-forward "[A-Za-z0-9]\\(\\.?[A-Za-z0-9]\\)*" nil t) - (progn - (kproperty:set 'kcell - (kotl-data:to-kcell-v3 - (aref kcell-vector kcell-num))) - (setq kcell-num (1+ kcell-num)))) - (search-forward "\n\n" nil t))))) - -(defun kfile:narrow-to-kcells () - "Narrow kotl file to kcell section only." - (interactive) - (if (kview:is-p kview) - (let ((start-text) (end-text)) - (save-excursion - (widen) - (goto-char (point-min)) - ;; Skip to start of kcells. - (if (search-forward "\n\^_" nil t) - (setq start-text (1+ (match-end 0)))) - ;; Skip past end of kcells. - (if (and start-text (search-forward "\n\^_" nil t)) - (setq end-text (1+ (match-beginning 0)))) - (if (and start-text end-text) - (progn (narrow-to-region start-text end-text) - (goto-char (point-min))) - (error - "(kfile:narrow-to-kcells): Cannot find start or end of kcells")) - )))) - -(defun kfile:print-to-string (object) - "Return a string containing OBJECT, any Lisp object, in pretty-printed form. -Quoting characters are used when needed to make output that `read' can -handle, whenever this is possible." - (save-excursion - (set-buffer (get-buffer-create " kfile:print-to-string")) - (let ((emacs-lisp-mode-hook) - (buffer-read-only)) - (erase-buffer) - (unwind-protect - (progn - (emacs-lisp-mode) - (let ((print-escape-newlines kfile:escape-newlines)) - (prin1 object (current-buffer))) - (goto-char (point-min)) - (while (not (eobp)) - ;; (message "%06d" (- (point-max) (point))) - (cond - ((looking-at "\\s\(") - (while (looking-at "\\s(") - (forward-char 1))) - ((and (looking-at "\\(quote[ \t]+\\)\\([^.)]\\)") - (> (match-beginning 1) 1) - (= ?\( (char-after (1- (match-beginning 1)))) - ;; Make sure this is a two-element list. - (save-excursion - (goto-char (match-beginning 2)) - (forward-sexp) - ;; (looking-at "[ \t]*\)") - ;; Avoid mucking with match-data; does this test work? - (char-equal ?\) (char-after (point))))) - ;; -1 gets the paren preceding the quote as well. - (delete-region (1- (match-beginning 1)) (match-end 1)) - (insert "'") - (forward-sexp 1) - (if (looking-at "[ \t]*\)") - (delete-region (match-beginning 0) (match-end 0)) - (error "Malformed quote")) - (backward-sexp 1)) - ((condition-case () - (prog1 t (down-list 1)) - (error nil)) - (backward-char 1) - (skip-chars-backward " \t") - (delete-region - (point) - (progn (skip-chars-forward " \t") (point))) - (if (not (char-equal ?' (char-after (1- (point))))) - (insert ?\n))) - ((condition-case () - (prog1 t (up-list 1)) - (error nil)) - (while (looking-at "\\s)") - (forward-char 1)) - (skip-chars-backward " \t") - (delete-region - (point) - (progn (skip-chars-forward " \t") (point))) - (if (not (char-equal ?' (char-after (1- (point))))) - (insert ?\n))) - (t (goto-char (point-max))))) - (goto-char (point-min)) - (indent-sexp) - (buffer-string)) - (kill-buffer (current-buffer)))))) - -(defun kfile:pretty-print (object &optional stream) - "Output the pretty-printed representation of OBJECT, any Lisp object. -Quoting characters are printed when needed to make output that `read' -can handle, whenever this is possible. -Output stream is STREAM, or value of `standard-output' (which see)." - (princ (kfile:print-to-string object) (or stream standard-output))) - -(defun kfile:read-name (prompt existing-p) - "PROMPT for and read a koutline file name. EXISTING-P means must exist." - (let ((filename)) - (while (not filename) - (setq filename (read-file-name prompt nil nil existing-p)) - (if (or (null filename) (equal filename "")) - (progn (ding) (setq filename nil)))) - filename)) - -;;; ************************************************************************ -;;; Private variables -;;; ************************************************************************ - -(defvar kfile:escape-newlines t - "Value of print-escape-newlines used by `kfile:print-to-string' function.") - -(provide 'kfile)
--- a/lisp/hyperbole/kotl/kfill.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,330 +0,0 @@ -;;!emacs -;; -;; FILE: kfill.el -;; SUMMARY: Fill and justify koutline cells (adapted from Kyle Jones' filladapt). -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: outlines, wp -;; -;; AUTHOR: Bob Weiner -;; ORIG-DATE: 23-Jan-94 -;; LAST-MOD: 6-Mar-97 at 01:18:10 by Bob Weiner - -;;; ************************************************************************ -;;; Public variables -;;; ************************************************************************ - -(defvar kfill:function-table - (progn - (if (featurep 'filladapt) - (progn (load "fill") ;; Save basic fill-paragraph function. - (load "simple"))) ;; Save basic do-auto-fill function. - (list (cons 'fill-paragraph (symbol-function 'fill-paragraph)) - (cons 'do-auto-fill (symbol-function 'do-auto-fill)))) - "Table containing the old function definitions that kfill overrides.") - -(defvar kfill:prefix-table - '( - ;; Lists with hanging indents, e.g. - ;; 1. xxxxx or 1) xxxxx etc. - ;; xxxxx xxx - ;; - ;; Be sure pattern does not match to: (last word in parens starts - ;; newline) - (" *(?\\([0-9][0-9a-z.]*\\|[a-z][0-9a-z.]\\)) +" . kfill:hanging-list) - (" *\\([0-9]+[a-z.]+[0-9a-z.]*\\|[0-9]+\\|[a-z]\\)\\([.>] +\\| +\\)" - . kfill:hanging-list) - ;; Included text in news or mail replies - ("[ \t]*\\(>+ *\\)+" . kfill:normal-included-text) - ;; Included text generated by SUPERCITE. We can't hope to match all - ;; the possible variations, your mileage may vary. - ("[ \t]*[A-Za-z0-9][^'`\"< \t\n]*>[ \t]*" . kfill:supercite-included-text) - ;; Lisp comments - ("[ \t]*\\(;+[ \t]*\\)+" . kfill:lisp-comment) - ;; UNIX shell comments - ("[ \t]*\\(#+[ \t]*\\)+" . kfill:sh-comment) - ;; Postscript comments - ("[ \t]*\\(%+[ \t]*\\)+" . kfill:postscript-comment) - ;; C++ comments - ("[ \t]*//[/ \t]*" . kfill:c++-comment) - ("[?!~*+ -]+ " . kfill:hanging-list) - ;; This keeps normal paragraphs from interacting unpleasantly with - ;; the types given above. - ("[^ \t/#%?!~*+-]" . kfill:normal) - ) -"Value is an alist of the form - - ((REGXP . FUNCTION) ...) - -When fill-paragraph or do-auto-fill is called, the REGEXP of each alist -element is compared with the beginning of the current line. If a match -is found the corresponding FUNCTION is called. FUNCTION is called with -one argument, which is non-nil when invoked on the behalf of -fill-paragraph, nil for do-auto-fill. It is the job of FUNCTION to set -the values of the paragraph-* variables (or set a clipping region, if -paragraph-start and paragraph-separate cannot be made discerning enough) -so that fill-paragraph and do-auto-fill work correctly in various -contexts.") - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -(defun do-auto-fill () - (save-restriction - (if (null fill-prefix) - (let ((paragraph-ignore-fill-prefix nil) - ;; Need this or Emacs 19 ignores fill-prefix when - ;; inside a comment. - (comment-multi-line t) - fill-prefix) - (kfill:adapt nil) - (kfill:funcall 'do-auto-fill)) - (kfill:funcall 'do-auto-fill)))) - -(defun fill-paragraph (arg &optional skip-prefix-remove) - "Fill paragraph at or after point. Prefix ARG means justify as well." - (interactive "*P") - ;; Emacs 19 expects a specific symbol here. - (if (and arg (not (symbolp arg))) (setq arg 'full)) - (or skip-prefix-remove (kfill:remove-paragraph-prefix)) - (save-restriction - (catch 'done - (if (null fill-prefix) - (let ((paragraph-ignore-fill-prefix nil) - ;; Need this or Emacs 19 ignores fill-prefix when - ;; inside a comment. - (comment-multi-line t) - (paragraph-start paragraph-start) - (paragraph-separate paragraph-separate) - fill-prefix) - (if (kfill:adapt t) - (throw 'done (kfill:funcall 'fill-paragraph arg))))) - ;; Kfill:adapt failed or fill-prefix is set, so do a basic - ;; paragraph fill as adapted from par-align.el. - (kfill:fill-paragraph arg skip-prefix-remove)))) - -;;; -;;; Redefine this function so that it sets `fill-prefix-prev' also. -;;; -(defun set-fill-prefix (&optional turn-off) - "Set the fill-prefix to the current line up to point. -Also sets fill-prefix-prev to previous value of fill-prefix. -Filling expects lines to start with the fill prefix and reinserts the fill -prefix in each resulting line." - (interactive) - (setq fill-prefix-prev fill-prefix - fill-prefix (if turn-off - nil - (buffer-substring - (save-excursion (beginning-of-line) (point)) - (point)))) - (if (equal fill-prefix-prev "") - (setq fill-prefix-prev nil)) - (if (equal fill-prefix "") - (setq fill-prefix nil)) - (if fill-prefix - (message "fill-prefix: \"%s\"" fill-prefix) - (message "fill-prefix cancelled"))) - -;;; ************************************************************************ -;;; Private functions -;;; ************************************************************************ - -(defun kfill:adapt (paragraph) - (let ((table kfill:prefix-table) - case-fold-search - success ) - (save-excursion - (beginning-of-line) - (while table - (if (not (looking-at (car (car table)))) - (setq table (cdr table)) - (funcall (cdr (car table)) paragraph) - (setq success t table nil)))) - success )) - -(defun kfill:c++-comment (paragraph) - (setq fill-prefix (buffer-substring (match-beginning 0) (match-end 0))) - (if paragraph - (setq paragraph-separate "^[^ \t/]"))) - -(defun kfill:fill-paragraph (justify-flag &optional leave-prefix) - (save-excursion - (end-of-line) - ;; Backward to para begin - (re-search-backward (concat "\\`\\|" paragraph-separate)) - (forward-line 1) - (let ((region-start (point))) - (forward-line -1) - (let ((from (point))) - (forward-paragraph) - ;; Forward to real paragraph end - (re-search-forward (concat "\\'\\|" paragraph-separate)) - (or (= (point) (point-max)) (beginning-of-line)) - (or leave-prefix - (kfill:replace-string - (or fill-prefix fill-prefix-prev) - "" nil region-start (point))) - (fill-region-as-paragraph from (point) justify-flag))))) - -(defun kfill:funcall (function &rest args) - (apply (cdr (assq function kfill:function-table)) args)) - -(defun kfill:hanging-list (paragraph) - (let (prefix match beg end) - (setq prefix (make-string (- (match-end 0) (match-beginning 0)) ?\ )) - (if paragraph - (progn - (setq match (buffer-substring (match-beginning 0) (match-end 0))) - (if (string-match "^ +$" match) - (save-excursion - (while (and (not (bobp)) (looking-at prefix)) - (forward-line -1)) - - (cond ((kfill:hanging-p) - (setq beg (point))) - (t (setq beg (progn (forward-line 1) (point)))))) - (setq beg (point))) - (save-excursion - (forward-line) - (while (and (looking-at prefix) - (not (equal (char-after (match-end 0)) ?\ ))) - (forward-line)) - (setq end (point))) - (narrow-to-region beg end))) - (setq fill-prefix prefix))) - -(defun kfill:hanging-p () - "Return non-nil iff point is in front of a hanging list." - (eval kfill:hanging-expression)) - -(defun kfill:lisp-comment (paragraph) - (setq fill-prefix (buffer-substring (match-beginning 0) (match-end 0))) - (if paragraph - (setq paragraph-separate - (concat "^" fill-prefix " *;\\|^" - (kfill:negate-string fill-prefix))))) - -(defun kfill:negate-string (string) - (let ((len (length string)) - (i 0) string-list) - (setq string-list (cons "\\(" nil)) - (while (< i len) - (setq string-list - (cons (if (= i (1- len)) "" "\\|") - (cons "]" - (cons (substring string i (1+ i)) - (cons "[^" - (cons (regexp-quote (substring string 0 i)) - string-list))))) - i (1+ i))) - (setq string-list (cons "\\)" string-list)) - (apply 'concat (nreverse string-list)))) - -(defun kfill:normal (paragraph) - (if paragraph - (setq paragraph-separate - (concat paragraph-separate "\\|^[ \t/#%?!~*+-]")))) - -(defun kfill:normal-included-text (paragraph) - (setq fill-prefix (buffer-substring (match-beginning 0) (match-end 0))) - (if paragraph - (setq paragraph-separate - (concat "^" fill-prefix " *>\\|^" - (kfill:negate-string fill-prefix))))) - -(defun kfill:postscript-comment (paragraph) - (setq fill-prefix (buffer-substring (match-beginning 0) (match-end 0))) - (if paragraph - (setq paragraph-separate - (concat "^" fill-prefix " *%\\|^" - (kfill:negate-string fill-prefix))))) - -(defun kfill:remove-paragraph-prefix (&optional indent-str) - "Remove fill prefix from current paragraph." - (save-excursion - (end-of-line) - ;; Backward to para begin - (re-search-backward (concat "\\`\\|" paragraph-separate)) - (forward-line 1) - (let ((region-start (point))) - (forward-line -1) - (forward-paragraph) - ;; Forward to real paragraph end - (re-search-forward (concat "\\'\\|" paragraph-separate)) - (or (= (point) (point-max)) (beginning-of-line)) - (kfill:replace-string (or fill-prefix fill-prefix-prev) - (if (eq major-mode 'kotl-mode) - (or indent-str - (make-string (kcell-view:indent) ? )) - "") - nil region-start (point))))) - -(defun kfill:replace-string (fill-str-prev fill-str &optional suffix start end) - "Replace whitespace separated FILL-STR-PREV with FILL-STR. -Optional SUFFIX non-nil means replace at ends of lines, default is beginnings. -Optional arguments START and END specify the replace region, default is the -current region." - (if fill-str-prev - (progn (if start - (let ((s (min start end))) - (setq end (max start end) - start s)) - (setq start (region-beginning) - end (region-end))) - (if (not fill-str) (setq fill-str "")) - (save-excursion - (save-restriction - (narrow-to-region start end) - (goto-char (point-min)) - (let ((prefix - (concat - (if suffix nil "^") - "[ \t]*" - (regexp-quote - ;; Get non-whitespace separated fill-str-prev - (substring - fill-str-prev - (or (string-match "[^ \t]" fill-str-prev) 0) - (if (string-match - "[ \t]*\\(.*[^ \t]\\)[ \t]*$" - fill-str-prev) - (match-end 1)))) - "[ \t]*" - (if suffix "$")))) - (while (re-search-forward prefix nil t) - (replace-match fill-str nil t)))))))) - -(defun kfill:sh-comment (paragraph) - (setq fill-prefix (buffer-substring (match-beginning 0) (match-end 0))) - (if paragraph - (setq paragraph-separate - (concat "^" fill-prefix " *#\\|^" - (kfill:negate-string fill-prefix))))) - -(defun kfill:supercite-included-text (paragraph) - (setq fill-prefix (buffer-substring (match-beginning 0) (match-end 0))) - (if paragraph - (setq paragraph-separate - (concat "^" (kfill:negate-string fill-prefix))))) - -;;; ************************************************************************ -;;; Private variables -;;; ************************************************************************ - -(defconst kfill:hanging-expression - (cons 'or - (delq nil (mapcar (function - (lambda (pattern-type) - (if (eq (cdr pattern-type) 'kfill:hanging-list) - (list 'looking-at (car pattern-type))))) - kfill:prefix-table))) - "Conditional expression used to test for hanging indented lists.") - -(defvar fill-prefix-prev nil - "Prior string inserted at front of new line during filling, or nil for none. -Setting this variable automatically makes it local to the current buffer.") -(make-variable-buffer-local 'fill-prefix-prev) - - -(provide 'kfill)
--- a/lisp/hyperbole/kotl/kimport.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,589 +0,0 @@ -;;!emacs -;; -;; FILE: kimport.el -;; SUMMARY: Convert and insert other outline file formats into koutlines. -;; USAGE: GNU Emacs V19 Lisp Library -;; KEYWORDS: data, outlines, wp -;; -;; AUTHOR: Bob Weiner & Kellie Clark -;; -;; ORIG-DATE: 15-Nov-93 at 11:57:05 -;; LAST-MOD: 6-Mar-97 at 01:18:33 by Bob Weiner - -;;; ************************************************************************ -;;; Other required Elisp libraries -;;; ************************************************************************ - -;; kfile.el requires kotl-mode.el which requires kimport.el. -(require 'wrolo) - -;;; ************************************************************************ -;;; Public variables -;;; ************************************************************************ - -;; kimport:mode-alist and kimport:suffix-alist are defined in -;; "../hyperbole.el". - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -;;;###autoload -(defun kimport:file (import-from output-to &optional children-p) - "Import a buffer or file IMPORT-FROM into the koutline in buffer or file OUTPUT-TO. - -Any suffix in IMPORT-FROM's buffer name is used to determine the type of -importation. All others are imported as text, one paragraph per cell. - -See the documentation for the variable, `kimport:suffix-alist' for -information on specific importation formats." - (interactive "FImport from buffer/file: \nFInsert into koutline buffer/file: \nP") - (let ((import-buf-name - (cond ((or (bufferp import-from) - (get-buffer import-from)) - (buffer-name (get-buffer import-from))) - ((get-file-buffer import-from) - (buffer-name (get-file-buffer import-from))) - ((stringp import-from) - (file-name-nondirectory import-from)) - (t (error "(kimport:buffer): `%s' is an invalid `import-from' argument")))) - (function)) - - (set-buffer import-buf-name) - (if (setq function (cdr (assq major-mode kimport:mode-alist))) - nil - (let ((import-suffix (if (string-match "\\..+\\'" import-buf-name) - (match-string 0 import-buf-name))) - (suffix-alist kimport:suffix-alist) - suffix-regexp) - (while (and import-suffix suffix-alist) - (setq suffix-regexp (car (car suffix-alist)) - function (cdr (car suffix-alist)) - suffix-alist (cdr suffix-alist)) - (if (string-match suffix-regexp import-suffix) - nil - (setq function nil))) - (if function nil (setq function (cdr (assq t kimport:mode-alist)))))) - (funcall function import-from output-to children-p))) - -;;; Augment right-side numbered files, blank line between cells -;;; - -;;;###autoload -(defun kimport:aug-post-outline (import-from output-to &optional children-p) - "Insert Augment outline statements from IMPORT-FROM into koutline OUTPUT-TO. -Displays and leaves point in OUTPUT-TO. See documentation for -`kimport:initialize' for valid values of IMPORT-FROM and OUTPUT-TO and for -an explanation of where imported cells are placed. - -If OUTPUT-TO is a new koutline, the first statement inserted will be the -first cell. Otherwise, it will be the successor of the current cell. - -Each statement to be imported is delimited by an Augment relative id at the -end of the statement. \"1\" = level 1, \"1a\" = level 2 in outline and so -on." - (interactive "FImport from Augment post-numbered buffer/file: \nFBuffer/file to insert cells into: \nP") - (let ((output-level 1) (klabel "1") - initially-empty-output no-renumber orig-point count total) - ;; Don't change the order of import-from and output-to inits here. - (setq import-from (kimport:copy-and-set-buffer import-from) - output-to (kimport:initialize output-to) - orig-point (point) - initially-empty-output (zerop (- (point-max) (point-min))) - no-renumber (or initially-empty-output - (not (if children-p - (kcell-view:child-p) - (kcell-view:sibling-p))))) - - (if (eq import-from output-to) - (error "(kimport:aug-post-outline): Import and output buffers may not be the same.")) - - (set-buffer import-from) - (show-all) - (save-excursion - (goto-char (point-min)) - ;; Total number of Augement statements. - (setq total (read (count-matches - " +\\([0-9][0-9a-z]*\\)\n\\(\n\\|\\'\\)"))) - (if initially-empty-output - nil - ;; Insert first cell as sibling of current cell. - (set-buffer output-to) - (if children-p - ;; Insert as children. - (progn (setq klabel (klabel:child (kcell-view:label)) - output-level (klabel:level klabel)) - ;; Move to end of this cell since cell insertion will - ;; occur at point. - (goto-char (kcell-view:end))) - ;; Insert as successors. - (setq klabel (klabel:increment (kcell-view:label)) - output-level (klabel:level klabel)) - ;; Move to start of line of next tree since cell insertion will occur - ;; at point. - (goto-char (kotl-mode:tree-end)))) - (setq count (kimport:aug-post-statements - import-from output-to klabel output-level 1 0 total))) - (pop-to-buffer output-to) - (kfile:narrow-to-kcells) - (if no-renumber nil (klabel-type:update-labels klabel)) - (goto-char orig-point) - (if (kotl-mode:buffer-empty-p) - nil - (kotl-mode:to-valid-position)) - (message "Imported %d of %d Augment statements." count total))) - -;;; -;;; Emacs outliner style files, leading `*' cell delimiters -;;; - -;;;###autoload -(defun kimport:star-outline (import-from output-to &optional children-p) - "Insert star outline nodes from IMPORT-FROM into koutline OUTPUT-TO. -Displays and leaves point in OUTPUT-TO. See documentation for -`kimport:initialize' for valid values of IMPORT-FROM and OUTPUT-TO and for -an explanation of where imported cells are placed. - -\"* \" = level 1, \"** \" = level 2 in outline and so on." - (interactive "FImport from star delimited cells buffer/file: \nFBuffer/file to insert cells into: \nP") - (let ((output-level 1) (klabel "1") - initially-empty-output no-renumber orig-point count total) - ;; Don't change the order of import-from and output-to inits here. - (setq import-from (kimport:copy-and-set-buffer import-from) - output-to (kimport:initialize output-to) - orig-point (point) - initially-empty-output (zerop (- (point-max) (point-min))) - no-renumber (or initially-empty-output - (not (if children-p - (kcell-view:child-p) - (kcell-view:sibling-p))))) - - (if (eq import-from output-to) - (error "(kimport:star-outline): Import and output buffers may not be the same.")) - - (set-buffer import-from) - (show-all) - (save-excursion - (goto-char (point-min)) - ;; If initial text in buffer is not an star outline node, add a star to - ;; make it one, so it is not deleted from the import. - (if (not (looking-at "[ \t]*\\*")) - (insert "* ")) - (goto-char (point-min)) - ;; Total number of top-level cells. - (setq total (read (count-matches "^[ \t]*\\*[ \t\n]"))) - (if initially-empty-output - nil - ;; Insert first cell as sibling of current cell. - (set-buffer output-to) - (if children-p - ;; Insert as children. - (progn (setq klabel (klabel:child (kcell-view:label)) - output-level (klabel:level klabel)) - ;; Move to end of this cell since cell insertion will - ;; occur at point. - (goto-char (kcell-view:end))) - ;; Insert as successors. - (setq klabel (klabel:increment (kcell-view:label)) - output-level (klabel:level klabel)) - ;; Move to start of line of next tree since cell insertion will occur - ;; at point. - (goto-char (kotl-mode:tree-end)))) - (setq count (kimport:star-entries - import-from output-to klabel output-level 1 0 total))) - (pop-to-buffer output-to) - (kfile:narrow-to-kcells) - (if no-renumber nil (klabel-type:update-labels klabel)) - (goto-char orig-point) - (if (kotl-mode:buffer-empty-p) - nil - (kotl-mode:to-valid-position)) - (message "Imported %d of %d star outline trees." count total))) - -;;; -;;; Generic text file import or koutline insertion. -;;; - -;;;###autoload -(defun kimport:text (import-from output-to &optional children-p) - "Insert text paragraphs from IMPORT-FROM into koutline OUTPUT-TO. -Displays and leaves point in OUTPUT-TO. See documentation for -`kimport:initialize' for valid values of IMPORT-FROM and OUTPUT-TO and for -an explanation of where imported cells are placed. - -Text paragraphs are imported as a sequence of same level cells. Koutlines -are imported with their structure intact. - -The variable, `paragraph-start,' is used to determine paragraphs." - (interactive "FImport from text/koutline buffer/file: \nFInsert cells into koutline buffer/file: \nP") - (let ((klabel "1") (output-level 1) (count 0) initially-empty-output - no-renumber orig-point total) - ;; Don't change the order of import-from and output-to inits here. - (setq import-from (kimport:copy-and-set-buffer import-from) - output-to (kimport:initialize output-to) - orig-point (point) - initially-empty-output (zerop (- (point-max) (point-min))) - no-renumber (or initially-empty-output - (not (if children-p - (kcell-view:child-p) - (kcell-view:sibling-p))))) - - (if (eq import-from output-to) - (error "(kimport:text): Import and output buffers may not be the same.")) - - (set-buffer import-from) - (let ((kotl-import (eq major-mode 'kotl-mode)) - visible-cells) - (save-excursion - (if initially-empty-output - nil - ;; Insert first cell as sibling of current cell. - (set-buffer output-to) - (if children-p - ;; Insert as children. - (progn (setq klabel (klabel:child (kcell-view:label)) - output-level (klabel:level klabel)) - ;; Move to end of this cell since cell insertion will - ;; occur at point. - (goto-char (kcell-view:end))) - ;; Insert as successors. - (setq klabel (klabel:increment (kcell-view:label)) - output-level (klabel:level klabel)) - ;; Move to start of line of next tree since cell insertion will occur - ;; at point. - (goto-char (kotl-mode:tree-end))) - (set-buffer import-from)) - - (if kotl-import - ;; Importing from a koutline, so handle specially. - (progn (kotl-mode:beginning-of-buffer) - ;; Total number of cells. - (setq total (read (count-matches "[\n\r][\n\r]")) - visible-cells (read (count-matches "\n\n")) - count (save-excursion - ;; Incredible non-local exit to ensure that - ;; recursion ends at the right time. - (catch 'end - (kimport:kcells import-from output-to klabel - output-level 1 - count total))))) - - (show-all) - (goto-char (point-min)) - ;; Total number of paragraphs. - (setq total (read (count-matches paragraph-start)) - count (kimport:text-paragraphs import-from output-to klabel - output-level count total)))) - (pop-to-buffer output-to) - (kfile:narrow-to-kcells) - (if no-renumber nil (klabel-type:update-labels klabel)) - (goto-char orig-point) - (if (kotl-mode:buffer-empty-p) - nil - (kotl-mode:to-valid-position)) - (if kotl-import - (message "Imported %d of %d visible cells from a %d cell outline." - count visible-cells total) - (message "Imported %d of %d paragraphs." count total))))) - -;;; ************************************************************************ -;;; Private functions - Don't call these functions from outside of this -;;; module or you may misuse them and cause data corruption. -;;; ************************************************************************ - -(defun kimport:aug-label-lessp (label1 label2) - "Return non-nil iff Augment-style LABEL1 is less than LABEL2." - (let ((lev1 (klabel:level-alpha label1)) - (lev2 (klabel:level-alpha label2))) - (cond ((< lev1 lev2)) - ((= lev1 lev2) (string-lessp label1 label2)) - (t nil)))) - -(defun kimport:aug-post-statements (import-from output-to klabel output-level - import-level count total) - "Insert post-numbered Augment statements (contents only) from IMPORT-FROM into existing OUTPUT-TO. - -KLABEL is the label to use for the first imported statement. -OUTPUT-LEVEL is the level at which to insert the first statement. -IMPORT-LEVEL is the depth of the current statement in the import file, -\(initially 1). - -COUNT of inserted cells starts at 0. TOTAL is the total number of statements -in IMPORT-FROM, used to show a running tally of the imported statements." - (set-buffer import-from) - (let ((cell-end-regexp " +\\([0-9][0-9a-z]*\\)\n\\(\n+\\|\\'\\)") - contents start subtree-p end end-contents statement-level - child-label) - ;; While find cells at import-level or deeper ... - (while (and (setq start (point)) - (re-search-forward cell-end-regexp nil t) - (<= import-level - (setq statement-level - (klabel:level-alpha - (buffer-substring - (match-beginning 1) (match-end 1)))))) - (setq end-contents (match-beginning 0) - end (match-end 0)) - (goto-char start) - (skip-chars-forward " ") - (setq contents (kimport:unindent-region (point) end-contents)) - (goto-char end) - (setq subtree-p (save-excursion - (if (re-search-forward cell-end-regexp nil t) - (< statement-level - (klabel:level-alpha - (buffer-substring - (match-beginning 1) (match-end 1))))))) - (save-excursion - (set-buffer output-to) - ;; Add the cell starting at point. - (kview:add-cell klabel output-level contents nil t) - (if subtree-p (setq child-label (klabel:child klabel))) - (message "%d of %d statements converted..." - (setq count (1+ count)) total) - (setq klabel (klabel:increment klabel))) - ;; - ;; Current buffer returns to `import-from' here. - ;; Handle each sub-level through recursion. - (if subtree-p - ;; Subtree exists so insert its cells. - (setq count - (kimport:aug-post-statements - import-from output-to child-label (1+ output-level) - (1+ import-level) count total)))) - (goto-char start)) - count) - -(defun kimport:copy-and-set-buffer (source) - "Copy and untabify SOURCE, set copy buffer as current buffer for this command and return the copy buffer. -SOURCE may be a buffer name, a buffer or a file name. -If SOURCE buffer name begins with a space, it is not copied under the -assumption that it already has been. If SOURCE is a koutline, it is not -copied since there is no need to copy it to import it." - ;; This buffer name format is used so that we can easily - ;; extract any file name suffix from the buffer name. - (setq source (set-buffer (or (get-buffer source) - (find-file-noselect source)))) - (let ((mode (or (if (boundp 'kotl-previous-mode) kotl-previous-mode) - major-mode)) - copy) - (if (or (eq mode 'kotl-mode) - (= ?\ (aref (buffer-name source) 0))) - source - (setq copy (get-buffer-create - (concat " " (if (string-match ".+[|<]" (buffer-name)) - (substring (buffer-name) - 0 (1- (match-end 0))) - (buffer-name))))) - (set-buffer copy) - (setq buffer-read-only nil - major-mode mode) - (erase-buffer) - (insert-buffer source) - (untabify (point-min) (point-max)) - ;; Ensure buffer ends with a newline so that we don't miss the last - ;; element during the import. - (goto-char (point-max)) - (if (/= (preceding-char) ?\n) (insert "\n")) - (set-buffer-modified-p nil) - copy))) - -(defun kimport:initialize (output-to) - "Setup to import elements into koutline OUTPUT-TO. -Return OUTPUT-TO buffer and set current buffer for the current command -to OUTPUT-TO. - -OUTPUT-TO may be a buffer, buffer-name or file name. If OUTPUT-TO exists -already, it must be a koutline or an error will be signaled. For an existing -OUTPUT-TO, the text cells are inserted after the cell at point or after the -first cell for a newly loaded koutline. If OUTPUT-TO is nil, the current -buffer is used. - -If OUTPUT-TO is an existing koutline, the first cell imported will be added -as the successor of the current cell. If an existing file is read in as -OUTPUT-TO within this function, point is left at the end of this buffer so -that imported cells will be appended to the buffer. For a new file, this -means the first cell imported will become the first outline cell. - -If a non-nil third argument, CHILDREN-P, is given to the caller of this -function and OUTPUT-TO contains at least one cell, then the imported cells -will be added as children of the cell where this function leaves point -\(either the current cell or for a newly read in outline, the last cell)." - (let* ((output-existing-buffer-p - (if output-to - (or (get-buffer output-to) (get-file-buffer output-to)))) - (output-exists-p - (if output-to - (or output-existing-buffer-p (file-exists-p output-to)) - ;; current buffer will be used for output and it exists. - t))) - (setq output-to (if output-to - (or (get-buffer output-to) - (find-file-noselect output-to)) - (current-buffer))) - (set-buffer output-to) - (if output-exists-p - (if (eq major-mode 'kotl-mode) - (if (kotl-mode:buffer-empty-p) - nil - ;; Make imported cells be appended if the output buffer was - ;; just read in. - (if output-existing-buffer-p nil (goto-char (point-max))) - (kotl-mode:to-valid-position)) - (error - "(kimport:initialize): Second arg, %s, must be a koutline file." - (buffer-name output-to))) - (if (eq major-mode 'kotl-mode) - nil - (setq kview nil) - (kotl-mode)) - (delete-region (point-min) (point-max)))) - output-to) - -(defun kimport:kcells (import-from output-to klabel output-level - import-level count total) - "Insert visible koutline cells (contents and attributes) from IMPORT-FROM into existing OUTPUT-TO. - -KLABEL is the label to use for the first imported cell. -OUTPUT-LEVEL is the level at which to insert the first cell. -IMPORT-LEVEL is the depth of the current cell in the import file, -\(initially 1). - -COUNT of inserted cells starts at 0. TOTAL is the total number of cells -in IMPORT-FROM, used to show a running tally of the imported cells." - (set-buffer import-from) - (goto-char (kcell-view:start)) - (let ((again t) contents subtree-p child-label) - ;; While find cells at import-level or deeper ... - (while (<= import-level (kcell-view:level)) - (setq subtree-p (kcell-view:child-p nil t) - contents (kcell-view:contents)) - (goto-char (kcell-view:end-contents)) - (save-excursion - (set-buffer output-to) - ;; Add the cell starting at point. - (kview:add-cell klabel output-level contents nil t) - (if subtree-p (setq child-label (klabel:child klabel))) - (message "%d of %d cells inserted..." - (setq count (1+ count)) total) - (setq klabel (klabel:increment klabel))) - ;; - ;; Current buffer returns to `import-from' here. - ;; Handle each sub-level through recursion. - (if (and (setq again (kcell-view:next t)) subtree-p) - ;; Subtree exists so insert its cells. - (setq count - (kimport:kcells - import-from output-to child-label (1+ output-level) - (1+ import-level) count total))) - (if again nil (throw 'end count)))) - count) - -(defun kimport:star-entries (import-from output-to klabel output-level - import-level count total) - "Insert visible star outline entries from IMPORT-FROM into existing OUTPUT-TO. - -KLABEL is the label to use for the first imported entry. -OUTPUT-LEVEL is the level at which to insert the first entry. -IMPORT-LEVEL is the depth of the current entry in the import file, -\(initially 1). - -COUNT of inserted entries starts at 0. TOTAL is the total number of entries -in IMPORT-FROM, used to show a running tally of the imported entries." - (set-buffer import-from) - (let ((start (point)) - (rolo-entry-regexp "^[ \t]*\\(\\*+\\)") - subtree-p end contents node-level child-label) - ;; While find cells at import-level or deeper ... - (while (and (re-search-forward rolo-entry-regexp nil t) - (<= import-level - (setq node-level - (length - (buffer-substring - (match-beginning 1) (match-end 1)))))) - (skip-chars-forward " \t") - (setq start (point) - end (rolo-to-entry-end) - subtree-p (if (looking-at rolo-entry-regexp) - (< node-level - (length (buffer-substring - (match-beginning 1) (match-end 1)))))) - (skip-chars-backward "\n\r") - (setq contents (kimport:unindent-region start (point))) - (save-excursion - (set-buffer output-to) - ;; Add the cell starting at point. - (kview:add-cell klabel output-level contents nil t) - (if subtree-p (setq child-label (klabel:child klabel))) - (message "%d of %d trees converted..." - (if (= node-level 1) (setq count (1+ count)) count) - total) - (setq klabel (klabel:increment klabel))) - ;; - ;; Current buffer returns to `import-from' here. - (goto-char end) - ;; - ;; Handle each sub-level through recursion. - (if subtree-p - ;; Subtree exists so insert its cells. - (setq count - (kimport:star-entries import-from output-to child-label - (1+ output-level) (1+ import-level) - count total)))) - (goto-char start)) - count) - -(defun kimport:text-paragraphs (import-from output-to klabel - output-level count total) - "Insert text paragraphs from IMPORT-FROM into existing OUTPUT-TO. -First cell is inserted with KLABEL at OUTPUT-LEVEL, as the sibling of the -previous cell, with the COUNT of inserted paragraphs starting at 0. TOTAL is -the total number of paragraphs in IMPORT-FROM, used to show a running tally -of the imported paragraphs. - -The variable, `paragraph-start' is used to determine paragraphs." - (set-buffer import-from) - (let* ((count 0) start end contents) - ;; Next line is needed when importing into an existing kview. - (goto-char (point-min)) - ;; Move past blank lines at point. - (skip-chars-forward " \t\n\r") - (beginning-of-line) - (while (and (setq start (point) - end (re-search-forward paragraph-start nil t)) - (/= start end)) - (setq contents (kimport:unindent-region start end)) - (set-buffer output-to) - ;; Add the cell starting at point. - (kview:add-cell klabel output-level contents nil t) - (setq count (1+ count)) - (message "%d of %d paragraphs converted..." - count total) - (setq klabel (klabel:increment klabel)) - (set-buffer import-from) - (goto-char end) - ;; Move past blank lines separating paragraphs. - (skip-chars-forward " \t\n\r") - (beginning-of-line)) - (message "%d of %d paragraphs converted" count total) - count)) - -(defun kimport:unindent-region (start end) - "Calculate indent based upon the second line within the region START to END. -Remove the indent and return the remaining region as a string." - (save-excursion - (let (indent-regexp) - (goto-char start) - ;; Remove leading indent from lines in paragraph. Base paragraph - ;; indent on the 2nd paragraph line since the first line might be - ;; further indented or outdented. - (setq indent-regexp - (if (re-search-forward "[\n\r][ \t]+" end t) - (concat "^" (make-string (current-column) ?\ )))) - (if indent-regexp - (hypb:replace-match-string - indent-regexp (buffer-substring start end) "" t) - (buffer-substring start end))))) - -(provide 'kimport) -
--- a/lisp/hyperbole/kotl/klabel.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,715 +0,0 @@ -;;!emacs -;; -;; FILE: klabel.el -;; SUMMARY: Display label handling for koutlines. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: outlines, wp -;; -;; AUTHOR: Bob Weiner & Kellie Clark -;; -;; ORIG-DATE: 17-Apr-94 -;; LAST-MOD: 6-Mar-97 at 01:19:02 by Bob Weiner - -;;; ************************************************************************ -;;; Public variables -;;; ************************************************************************ - -(defvar klabel-type:changing-flag nil - "Non-nil only while the label type in the current view is being changed.") - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -;;; -;;; klabel - koutline display labels -;;; - -(defun klabel:child (label) - "Return LABEL's child cell label." - (funcall (kview:get-attr kview 'label-child) label)) - -(defun klabel:increment (label) - "Return LABEL's sibling label." - (funcall (kview:get-attr kview 'label-increment) label)) - -(defun klabel:level (label) - "Return outline level of LABEL using current kview label type." - (let ((label-type (kview:label-type kview))) - (cond ((memq label-type '(alpha legal)) - (funcall (intern-soft (concat "klabel:level-" - (symbol-name label-type))) - label)) - ((eq label-type 'no) 1) - ((eq label-type 'star) (length label)) - ((eq label-type 'id) - (error - "(klabel:level): Can't compute the level of an idstamp label")) - ((eq label-type 'partial-alpha) - (error - "(klabel:level): Can't compute the level of a partial-alpha label")) - (t (error "(klabel:level): Invalid label type setting: `%s'" - label-type))))) - -(defun klabel:parent (label) - "Return LABEL's parent label." - (funcall (kview:get-attr kview 'label-parent) label)) - -(defun klabel-type:child (label-type) - "Return function which computes child cell label of LABEL-TYPE." - (cond ((memq label-type '(alpha legal partial-alpha)) - (intern-soft (concat "klabel:child-" - (symbol-name label-type)))) - ((eq label-type 'no) - (function (lambda (label) ""))) - ((eq label-type 'star) - (function (lambda (label) (concat label "*")))) - ((eq label-type 'id) - (function - (lambda (label) - (error - "(klabel:child-id): Can't compute child of idstamp label")))) - (t (error - "(klabel-type:child): Invalid label type setting: `%s'" - label-type)))) - -(defun klabel-type:increment (label-type) - "Return function which computes sibling cell label of LABEL-TYPE." - (cond ((memq label-type '(alpha legal partial-alpha)) - (intern-soft (concat "klabel:increment-" - (symbol-name label-type)))) - ((eq label-type 'no) - (function - (lambda (label) - (if (equal label "0") - (error "(klabel:increment-no): 0 cell cannot have a sibling") - "")))) - ((eq label-type 'star) - (function - (lambda (label) - (if (string-equal label "0") - (error "(klabel:increment-star): 0 cell cannot have a sibling") - label)))) - ((eq label-type 'id) - (function - (lambda (label) - (if (string-equal label "0") - (error "(klabel:increment-no): 0 cell cannot have a sibling") - (error "(klabel:increment-id): Can't compute sibling of idstamp label"))))) - (t (error - "(klabel:increment): Invalid label type setting: `%s'" - label-type)))) - -(defun klabel-type:parent (label-type) - "Return function which computes parent cell label of LABEL-TYPE." - (cond ((memq label-type '(alpha legal partial-alpha)) - (intern-soft (concat "klabel:parent-" - (symbol-name label-type)))) - ((eq label-type 'no) - (function - (lambda (label) - (if (equal label "0") - (error "(klabel:parent-no): 0 cell cannot have a parent") - "")))) - ((eq label-type 'star) - (function - (lambda (label) - (if (string-equal label "0") - (error "(klabel:parent-star): 0 cell cannot have a parent") - (substring label 0 (1- (length label))))))) - ((eq label-type 'partial-alpha) - (function - (lambda (label) - (error - "(klabel:parent-partial-alpha): Can't compute parent of partial alpha label")))) - ((eq label-type 'id) - (function - (lambda (label) - (error - "(klabel:parent-id): Can't compute parent of idstamp label")))) - (t (error - "(klabel-type:parent): Invalid label type setting: `%s'" - label-type)))) - -;;; -;;; alpha klabels -;;; - -(defun klabel:child-alpha (label) - "Return label for first child of alpha LABEL." - (if (or (string-equal label "0") - (string-equal label "")) - "1" - (concat label (if (< (aref label (1- (length label))) ?a) - "a" "1")))) - -(defun klabel:increment-alpha (alpha-label) - "Increment full ALPHA-LABEL by one and return." - (if (string-equal alpha-label "0") - (error "(klabel:increment-alpha): 0 cell cannot have a sibling") - (let ((kotl-label (klabel:to-kotl-label alpha-label))) - (concat (substring alpha-label 0 (- (length kotl-label))) - (kotl-label:increment kotl-label 1))))) - -(defun klabel:level-alpha (label) - "Return outline level as an integer of alpha-style (Augment-style) LABEL. -First visible outline cell is level 1." - (if (string-equal label "0") - 0 - (let ((i 0) - (level 0) - (len (length label)) - (digit-p nil) - chr) - (while (< i len) - (if (and (>= (setq chr (aref label i)) ?0) - (<= chr ?9)) - (or digit-p (setq level (1+ level) - digit-p t)) - ;; assume chr is alpha - (if digit-p (setq level (1+ level) - digit-p nil))) - (setq i (1+ i))) - level))) - -(defun klabel:parent-alpha (label) - "Return parent label of full alpha LABEL." - (cond ((or (string-equal label "0") - (string-equal label "")) - (error "(klabel:parent-alpha): 0 cell cannot have a parent")) - ((kotl-label:integer-p label) ;; level 1 label - "0") - (t (substring label 0 (- (length (klabel:to-kotl-label label))))))) - -;;; -;;; partial-alpha klabels -;;; - -(fset 'klabel:child-partial-alpha 'kotl-label:child) - -(defun klabel:increment-partial-alpha (label) - "Increment partial alpha LABEL by one and return." - (if (string-equal label "0") - (error "(klabel:increment-partial-alpha): 0 cell cannot have a sibling") - (kotl-label:increment label 1))) - -;;; -;;; legal klabels -;;; - -(defun klabel:child-legal (label) - "Return label for first child of legal LABEL." - (if (or (string-equal label "0") - (string-equal label "")) - "1" - (concat label ".1"))) - -(defun klabel:increment-legal (label) - "Increment full legal LABEL by one and return." - (cond ((string-equal label "0") - (error "(klabel:increment-legal): 0 cell cannot have a sibling")) - ((string-match "[0-9]+$" label) - (concat (substring label 0 (match-beginning 0)) - (int-to-string - (1+ (string-to-int (substring label (match-beginning 0))))))) - (t (error "(klabel:increment-legal): Invalid label, `%s'" label)))) - -(defun klabel:level-legal (label) - "Return outline level as an integer of legal-style LABEL. -First visible outline cell is level 1." - (if (string-equal label "0") - 0 - (let ((i 0) - (level 1) - (len (length label))) - (while (< i len) - (if (= (aref label i) ?.) - (setq level (1+ level))) - (setq i (1+ i))) - level))) - -(defun klabel:parent-legal (label) - "Return parent label of full legal LABEL." - (cond ((or (string-equal label "0") - (string-equal label "")) - (error "(klabel:parent-legal): 0 cell cannot have a parent")) - ((kotl-label:integer-p label) ;; level 1 label - "0") - (t (substring label 0 (string-match "\\.[0-9]+$" label))))) - -;;; -;;; klabel-type - Sets display label format and converts among formats -;;; -;; Default label-type to use for new views. -;; It must be one of the following symbols: -;; no for no labels, -;; id for permanent idstamp labels, e.g. 001, 002, etc. -;; alpha for `1a2' full alphanumeric labels -;; legal for `1.1.2' labels -;; partial-alpha for partial alphanumeric labels, e.g. `2' for node `1a2' -;; star for multi-star labeling, e.g. `***'. - -;; -;; Functions to compute sibling and child labels for particular label types. -;; -(defun klabel-type:function (&optional label-type) - "Return function which will return display label for current cell. -Label format is optional LABEL-TYPE or the default label type for the current view. - -Function signature is: (func prev-label &optional child-p), where prev-label -is the display label of the cell preceding the current one and child-p is -non-nil if cell is to be the child of the preceding cell." - (or label-type (setq label-type (kview:label-type kview))) - (cond ((eq label-type 'no) - (function (lambda (prev-label &optional child-p) - ""))) - ((eq label-type 'partial-alpha) - (function (lambda (prev-label &optional child-p) - (if child-p - (if (kotl-label:integer-p prev-label) - "a" "1") - (kotl-label:increment prev-label 1))))) - ((eq label-type 'id) - (function (lambda (prev-label &optional child-p) - (format "0%d" (kcell-view:idstamp))))) - (t (intern-soft (concat "klabel-type:" - (symbol-name label-type) "-label"))))) - -(defun klabel-type:alpha-label (prev-label &optional child-p) - "Return full alphanumeric label, e.g. 1a2, for cell following PREV-LABEL's cell. -With optional CHILD-P, return label for first child cell of PREV-LABEL cell." - (if child-p - (klabel:child prev-label) - (klabel:increment prev-label))) - -(defun klabel-type:legal-label (prev-label &optional child-p) - "Return full legal label, e.g. 1.1.2, for cell following PREV-LABEL's cell. -With optional CHILD-P, return label for first child cell of PREV-LABEL cell." - (if child-p - (if (string-equal prev-label "0") - "1" - (concat prev-label ".1")) - (let* ((last-part (string-match "[0-9]+$" prev-label)) - (partial-legal (substring prev-label last-part)) - (next (kotl-label:create (1+ (string-to-int partial-legal))))) - (if (equal last-part prev-label) - next - (concat (substring prev-label 0 last-part) next))))) - -(defun klabel-type:to-label-end (&optional label-type) - "Return function which will search backward to a the end of a cell's label. -Label format is optional LABEL-TYPE or the default label type for the current view. - -Function signature is: (). It takes no arguments and begins the search from point." - (or label-type (setq label-type (kview:label-type kview))) - (or (cdr (assq label-type - (list - (cons - 'alpha - (function - (lambda () - (if (re-search-backward - "\\(\\`\\|[\n\r][\n\r]\\)[ \t]*[1-9][0-9a-zA-Z]*" - nil t) - (goto-char (match-end 0)))))) - (cons - 'legal - (function - (lambda () - (if (re-search-backward - "\\(\\`\\|[\n\r][\n\r]\\)[ \t]*[0-9]+\\(\\.[0-9]+\\)*" - nil t) - (goto-char (match-end 0)))))) - (cons - 'star - (function - (lambda () - (if (re-search-backward - "\\(\\`\\|[\n\r][\n\r]\\)[ \t]*\\*+" nil t) - (goto-char (match-end 0)))))) - (cons - 'no - (function - (lambda () - (goto-char - (if (and (not hyperb:lemacs-p) - (string-lessp emacs-version "19.22")) - (kproperty:previous-single-change (point) 'kcell) - ;; (GNU Emacs V19.22 / Lucid Emacs V19.9) or greater - (- (kproperty:previous-single-change - (point) 'kcell) 1)))))) - (cons - 'partial-alpha - (function - (lambda () - (if (re-search-backward - "\\(\\`\\|[\n\r][\n\r]\\)[ \t]*[0-9]+\\|[a-zA-Z]+" - nil t) - (goto-char (match-end 0)))))) - (cons - 'id - (function - (lambda () - (if (re-search-backward - "\\(\\`\\|[\n\r][\n\r]\\)[ \t]*0[0-9]+" nil t) - (goto-char (match-end 0))))))))) - (error "(kview:to-label-end): Invalid label type: `%s'" label-type))) - -(defun klabel-type:star-label (prev-label &optional child-p) - "Return full star label, e.g. ***, for cell following PREV-LABEL's cell. -With optional CHILD-P, return label for first child cell of PREV-LABEL cell." - (if child-p - (concat prev-label "*") - prev-label)) - -;; -;; Functions to compute labels for cells following point and for all cells in -;; a view. -;; - -(defun klabel-type:set-labels (label-type) - "Replace labels of all cells in current view with those of LABEL-TYPE (a symbol)." - (let (first-label) - (save-excursion - (goto-char (point-min)) - (goto-char (kcell-view:start)) - (setq first-label - (cond ((memq label-type '(alpha legal partial-alpha)) - "1") - ((eq label-type 'id) (kcell-view:idstamp)) - ((eq label-type 'no) "") - ((eq label-type 'star) "*") - (t (error - "(klabel-type:set-labels): Invalid label type: `%s'" - label-type)))) - (let ((klabel-type:changing-flag t)) - (klabel-type:update-labels-from-point label-type first-label))))) - -(defun klabel-type:set-alpha (current-cell-label label-sep-len current-indent - per-level-indent &optional current-tree-only) - "Set the labels of current cell, its following siblings and their subtrees. -CURRENT-CELL-LABEL is the label to display for the current cell. -LABEL-SEP-LEN is the length of the separation between a cell's label -and the start of its contents." - (let (label-prefix label-suffix suffix-val suffix-function opoint) - (if current-cell-label - (setq label-suffix (klabel:to-kotl-label current-cell-label) - label-prefix (substring current-cell-label - 0 (- (length label-suffix))) - suffix-function (if (kotl-label:integer-p label-suffix) - (progn (setq suffix-val - (string-to-int label-suffix)) - 'int-to-string) - (setq suffix-val - (kotl-label:alpha-to-int label-suffix)) - 'kotl-label:int-to-alpha))) - (while current-cell-label - ;; Set current cell's label. - (klabel:set current-cell-label label-sep-len) - ;; Process any subtrees of current cell. - (if (kcell-view:child nil label-sep-len) - ;; Recurse over subtree. - (klabel-type:set-alpha - (klabel:child-alpha current-cell-label) - label-sep-len - (+ current-indent per-level-indent) - per-level-indent)) - ;; Process next sibling of current cell if any. - (setq opoint (point)) - (if (and (not current-tree-only) - (kcell-view:next nil label-sep-len) - (= current-indent (kcell-view:indent nil label-sep-len))) - (setq suffix-val (1+ suffix-val) - label-suffix (funcall suffix-function suffix-val) - current-cell-label (concat label-prefix label-suffix)) - (goto-char opoint) - (setq current-cell-label nil))))) - -(defun klabel-type:set-id (current-cell-label label-sep-len &rest ignore) - "Set the labels of current cell, its following siblings and their subtrees. -CURRENT-CELL-LABEL is the label to display for the current cell." - ;; Only need to do this when switching from one label type to another, - ;; i.e. when every cell label will be updated. So if not starting with the - ;; first cell, do nothing. - (if (kotl-mode:first-cell-p) - (while (and (klabel:set (kcell-view:idstamp) label-sep-len) - (kcell-view:next nil label-sep-len))))) - -(defun klabel-type:set-legal (current-cell-label label-sep-len current-indent - per-level-indent &optional current-tree-only) - "Set the labels of current cell, its following siblings and their subtrees. -CURRENT-CELL-LABEL is the label to display for the current cell. -LABEL-SEP-LEN is the length of the separation between a cell's label -and the start of its contents." - (let (label-prefix label-suffix suffix-val opoint) - (if current-cell-label - (setq label-suffix (klabel:to-kotl-label current-cell-label) - label-prefix (substring current-cell-label - 0 (- (length label-suffix))) - suffix-val (string-to-int label-suffix))) - (while current-cell-label - ;; Set current cell's label. - (klabel:set current-cell-label label-sep-len) - ;; Process any subtrees of current cell. - (if (kcell-view:child nil label-sep-len) - ;; Recurse over subtree. - (klabel-type:set-legal - (klabel:child-legal current-cell-label) - label-sep-len - (+ current-indent per-level-indent) - per-level-indent)) - ;; Process next sibling of current cell if any. - (setq opoint (point)) - (if (and (not current-tree-only) - (kcell-view:next nil label-sep-len) - (= current-indent (kcell-view:indent nil label-sep-len))) - (setq suffix-val (1+ suffix-val) - label-suffix (int-to-string suffix-val) - current-cell-label (concat label-prefix label-suffix)) - (goto-char opoint) - (setq current-cell-label nil))))) - -(defun klabel-type:set-no (current-cell-label label-sep-len &rest ignore) - "Set the labels of current cell, its following siblings and their subtrees. -CURRENT-CELL-LABEL is the label to display for the current cell." - ;; Only need to do this when switching from one label type to another, - ;; i.e. when every cell label will be updated. So if not starting with the - ;; first cell, do nothing. - (if (kotl-mode:first-cell-p) - (while (and (klabel:set "" label-sep-len) - (kcell-view:next nil label-sep-len))))) - -(defun klabel-type:set-partial-alpha (current-cell-label label-sep-len - current-indent per-level-indent - &optional current-tree-only) - "Set the labels of current cell, its following siblings and their subtrees. -CURRENT-CELL-LABEL is the label to display for the current cell. -LABEL-SEP-LEN is the length of the separation between a cell's label -and the start of its contents." - (let (label-suffix suffix-val suffix-function opoint) - (if current-cell-label - (setq label-suffix current-cell-label - suffix-function (if (kotl-label:integer-p label-suffix) - (progn (setq suffix-val - (string-to-int label-suffix)) - 'int-to-string) - (setq suffix-val - (kotl-label:alpha-to-int label-suffix)) - 'kotl-label:int-to-alpha))) - (while current-cell-label - ;; Set current cell's label. - (klabel:set current-cell-label label-sep-len) - ;; Process any subtrees of current cell. - (if (kcell-view:child nil label-sep-len) - ;; Recurse over subtree. - (klabel-type:set-partial-alpha - (klabel:child-partial-alpha current-cell-label) - label-sep-len - (+ current-indent per-level-indent) - per-level-indent)) - ;; Process next sibling of current cell if any. - (setq opoint (point)) - (if (and (not current-tree-only) - (kcell-view:next nil label-sep-len) - (= current-indent (kcell-view:indent nil label-sep-len))) - (setq suffix-val (1+ suffix-val) - label-suffix (funcall suffix-function suffix-val) - current-cell-label label-suffix) - (goto-char opoint) - (setq current-cell-label nil))))) - -(defun klabel-type:set-star (current-cell-label label-sep-len &rest ignore) - "Set the labels of current cell, its following siblings and their subtrees. -CURRENT-CELL-LABEL is the label to display for the current cell. -LABEL-SEP-LEN is the length of the separation between a cell's label -and the start of its contents." - ;; Only need to do this when switching from one label type to another, - ;; i.e. when every cell label will be updated. So if not starting with the - ;; first cell, do nothing. - (if (kotl-mode:first-cell-p) - (while (and (klabel:set (make-string - (kcell-view:level nil label-sep-len) ?*) - label-sep-len) - (kcell-view:next nil label-sep-len))))) - -(defun klabel-type:update-labels (current-cell-label) - "Update the labels of current cell, its following siblings and their subtrees. -CURRENT-CELL-LABEL is the label to display for the current cell. -If, however, it is \"0\", then all cell labels are updated." - (let ((label-type (kview:label-type kview))) - (if (string-equal current-cell-label "0") - ;; Update all cells in view. - (klabel-type:set-labels label-type) - ;; Update current tree and its siblings only. - (klabel-type:update-labels-from-point - label-type current-cell-label)))) - -(defun klabel-type:update-tree-labels (current-cell-label) - "Update the labels of current cell and its subtree. -CURRENT-CELL-LABEL is the label to display for the current cell. -Use '(klabel-type:update-labels "0")' to update all cells in an outline." - (let ((label-type (kview:label-type kview)) - (label-sep-len (kview:label-separator-length kview))) - (save-excursion - (funcall (intern-soft (concat "klabel-type:set-" - (symbol-name label-type))) - first-label label-sep-len - (kcell-view:indent nil label-sep-len) - (kview:level-indent kview) - ;; Update current tree only. - t)))) - -;;; -;;; kotl-label--the part of a full label which represents a -;;; kcell's relative position in the koutline hierarchy, -;;; e.g. the full label "1a2" has kotl-label "2". -;;; -(defun kotl-label:alpha-to-int (alpha-label) - "Return integer value of ALPHA-LABEL, e.g. `b' returns 2. -Assumes ALPHA-LABEL is alphabetic." - (let ((power (length alpha-label)) - (digit 0) - (min (1- ?a))) - (apply '+ (mapcar - (function (lambda (chr) - (setq digit (- chr min) - power (1- power)) - (* (apply '* (make-list power 26)) digit) - )) - alpha-label)))) - -(defun kotl-label:alpha-p (label) - "Return LABEL if LABEL is composed of all alphabetic characters, else return nil." - (if (string-match "\\`[a-zA-Z]+\\'" label) label)) - -(defun kotl-label:child (label) - "Return child label of partial alpha LABEL." - (cond ((or (string-equal label "0") - (string-equal label "")) - "1") - ((kotl-label:integer-p label) "a") - (t "1"))) - -(defun kotl-label:create (int-or-string) - "Return new kcell label from INT-OR-STRING." - (cond ((integerp int-or-string) (int-to-string int-or-string)) - ((equal int-or-string "") "0") - (t int-or-string))) - -(defun kotl-label:increment (label n) - "Return LABEL incremented by N. -For example, if N were 1, 2 would become 3, z would become aa, and aa would -become bb. If N were -2, 4 would become 2, etc. -LABEL must be >= 1 or >= a. If LABEL is decremented below 1 or a, an error -is signaled." - (if (not (kotl-label:is-p label)) - (error - "(kotl-label:increment): First arg, `%s', must be a kotl-label." - label)) - (let ((int-p) (val 0)) - (if (or (setq int-p (kotl-label:integer-p label)) - (kotl-label:alpha-p label)) - ;; Test if trying to decrement below 1 or a. - (if int-p - (progn (setq int-p (string-to-int label)) - (if (> (setq val (+ int-p n)) 0) - (kotl-label:create val) - (error "(kotl-label:increment): Decrement of `%s' by `%d' is less than 1." label n))) - ;; alpha-p - (if (<= 0 (setq val (+ n (kotl-label:alpha-to-int label)))) - (kotl-label:create - (kotl-label:int-to-alpha val)) - (error "(kotl-label:increment): Decrement of `%s' by `%d' is illegal." label n))) - (error "(kotl-label:increment): label, `%s', must be all digits or alpha characters" label)))) - -(defun kotl-label:increment-alpha (label) - "Return alphabetic LABEL incremented by 1. -For example, z would become aa, and aa would become bb. LABEL must be >= a." - (kotl-label:int-to-alpha - (1+ (kotl-label:alpha-to-int label)))) - -(defun kotl-label:increment-int (int-string) - "Return INT-STRING label incremented by 1. -For example, \"14\" would become \"15\"." - (int-to-string (1+ (string-to-int int-string)))) - -(defun kotl-label:integer-p (label) - "Return LABEL iff LABEL is composed of all digits, else return nil." - (if (string-match "\\`[0-9]+\\'" label) label)) - -;; This handles partial alphabetic labels with a maximum single level -;; sequence of 17575 items, which = (1- (expt 26 3)), after which it gives -;; invalid results. This should be large enough for any practical cases. - -(defun kotl-label:int-to-alpha (n) - "Return alphabetic representation of N as a string. -N may be an integer or a string containing an integer." - (if (stringp n) (setq n (string-to-int n))) - (let ((lbl "") pow26 exp26 quotient remainder) - (if (= n 0) - "" - (setq pow26 (floor (kotl-label:log26 - (if (= (mod (1- n) 26) 0) n (1- n))))) - (while (>= pow26 0) - (setq exp26 (expt 26 pow26) - quotient (floor (/ n exp26)) - remainder (mod n exp26)) - (if (= remainder 0) - (setq quotient (- quotient (1+ pow26)) - n 26) - (setq n remainder - quotient (max 0 (1- quotient)))) - (setq lbl (concat lbl (char-to-string (+ quotient ?a))) - pow26 (1- pow26))) - lbl))) - -(defun kotl-label:is-p (object) - "Return non-nil if OBJECT is a KOTL-LABEL." - (stringp object)) - - - -;;; ************************************************************************ -;;; Private functions -;;; ************************************************************************ - -(defun klabel:set (new-label &optional label-sep-len) - "Replace label displayed in cell at point with NEW-LABEL, which may be a different label type. -Return NEW-LABEL string." - (let ((modified (buffer-modified-p)) - (buffer-read-only) - (thru-label (- (kcell-view:indent nil label-sep-len) - (or label-sep-len - (kview:label-separator-length kview))))) - (save-excursion - (kcell-view:to-label-end) - ;; delete backwards thru label - (delete-backward-char thru-label) - ;; replace with new label, right justified - (insert (format (format "%%%ds" thru-label) new-label))) - (set-buffer-modified-p modified) - new-label)) - -(defun klabel:to-kotl-label (label) - "Given full alpha or legal LABEL, return rightmost part, called a kotl-label. -For example, the full label \"1a2\" has kotl-label \"2\", as does \"1.1.2\"." - (if (string-match "[0-9]+$\\|[a-zA-Z]+$" label) - (substring label (match-beginning 0)) - (error "(klabel:to-kotl-label): Invalid label, `%s'" label))) - -(defun klabel-type:update-labels-from-point (label-type first-label) - (let ((label-sep-len (kview:label-separator-length kview))) - (save-excursion - (funcall (intern-soft (concat "klabel-type:set-" - (symbol-name label-type))) - first-label label-sep-len - (kcell-view:indent nil label-sep-len) - (kview:level-indent kview))))) - -(defun kotl-label:log26 (n) - "Return log base 26 of integer N." - (/ (log10 n) - ;; Next line = (log10 26.514147167125703) - 1.423477662509912)) - -(provide 'klabel)
--- a/lisp/hyperbole/kotl/klink.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,277 +0,0 @@ -;;!emacs -;; -;; FILE: klink.el -;; SUMMARY: Implicit reference to a kcell action type, for use in koutlines. -;; USAGE: GNU Emacs V19 Lisp Library -;; KEYWORDS: extensions, hypermedia, outlines, wp -;; -;; AUTHOR: Bob Weiner & Kellie Clark -;; -;; ORIG-DATE: 15-Nov-93 at 12:15:16 -;; LAST-MOD: 6-Mar-97 at 01:19:19 by Bob Weiner -;; -;; DESCRIPTION: -;; -;;; link = -;; < pathname [, cell-ref] [, position] > -;; < @ cell-ref > ;; In same buffer -;; < journal-name, journal-item-number [, cell-ref] [, position] > -;; -;;; pathname = -;; path ;; display path in Emacs buffer -;; !path ;; execute pathname within a shell -;; &path ;; execute path as a windowed program -;; -path ;; Load as an Emacs Lisp program -;; -;;; cell-ref = -;; cell - 1a, 012, 1.2, 1a=012 (both relative and absolute ids separated -;; by an equal sign) -;; range - 1a-5c, 1a-+3 (include 3 cells past 1a) (not yet implemented) -;; tree - 1a+ (not yet implemented) -;; -;; optionally followed by a period and 1 or more relative position specs -;; (not yet implemented): -;; -;; previous-cell - .b -;; down-a-level - .d -;; end-of-branch - .e -;; follow-next-link - .l -;; return-to-prev-location - .r -;; return-to-prev-buffer - .rf -;; sibling - .s, .2s for 2 siblings forward -;; tail-of-tree - .t -;; up-a-level - .u -;; last char of cell - .f -;; -;; and then optionally followed by any amount of whitespace, a pipe `|' -;; character and then one or more view specification characters. (Augment -;; viewspec characters may be given instead, preceded by a colon. They are -;; ignored for now.) -;; -;;; position (relative to cell start) = (not yet implemented) -;; char-pos, e.g. 28 or C28 -;; word-num, e.g. W5 -;; line-num, e.g. L2 -;; paragraph-num, e.g. P3 -;; regexp-match, e.g. "regexp" -;; -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -;;;###autoload -(defun klink:create (reference) - "Insert at point an implicit link to REFERENCE. -REFERENCE should be a cell-ref or a string containing \"filename, cell-ref\". -See documentation for `kcell:ref-to-id' for valid cell-ref formats." - (interactive - ;; Don't change the name or delete default-dir used here. It is referenced - ;; in "hargs.el" for argument getting. - (let ((default-dir default-directory)) - (barf-if-buffer-read-only) - (hargs:iform-read - (list 'interactive "*+LInsert link to <[file,] cell-id [|vspecs]>: ")))) - (barf-if-buffer-read-only) - ;; Reference generally is a string. It may be a list as a string, e.g. - ;; "(\"file\" \"cell\")", in which case, we remove the unneeded internal - ;; double quotes and then parse it with pattern matching. - (and (stringp reference) (> (length reference) 0) - (= (aref reference 0) ?\() - (setq reference (hypb:replace-match-string "\\\"" reference "" t))) - (let ((default-dir default-directory) - file-ref cell-ref) - (setq reference (klink:parse reference) - file-ref (car reference) - cell-ref (car (cdr reference))) - ;; Don't need filename if link is to a cell in current buffer. - (if (and file-ref (equal buffer-file-name - (expand-file-name file-ref default-directory))) - (setq file-ref nil)) - (cond (file-ref - (setq file-ref (hpath:relative-to file-ref)) - ;; "./" prefix, if any. - (if (string-match "^\\./" file-ref) - (setq file-ref (substring file-ref (match-end 0)))) - (insert "<" file-ref) - (if cell-ref (insert ", " cell-ref)) - (insert ">")) - (cell-ref (insert "<@ " cell-ref ">")) - (t (error "(klink:create) Invalid reference, `%s'" reference))))) - -(defun klink:at-p () - "Return non-nil iff point is within a klink. -See documentation for the `actypes::link-to-kotl' function for valid klink -formats. Value returned is a list of: link-label, link-start-position, and -link-end-position, (including delimiters)." - (let (bol klink referent) - (if (and - ;; If this is an OO-Browser listing buffer, ignore anything that - ;; looks like a klink, e.g. a C++ <template> class. - (if (fboundp 'br-browser-buffer-p) - (not (br-browser-buffer-p)) - t) - ;; Don't match to C/C++ lines like: #include < path > - (save-excursion - (beginning-of-line) - (setq bol (point)) - (require 'hmouse-tag) - (not (looking-at smart-c-include-regexp))) - (save-excursion - ;; Don't match Elisp print objects such as #<buffer> - (and (search-backward "<" bol t) - (/= (preceding-char) ?#) - ;; Don't match to \<(explicit)> Hyperbole buttons - (/= (char-after (1+ (point))) ?\())) - (setq klink (hbut:label-p t "<" ">" t)) - (stringp (setq referent (car klink))) - ;; Eliminate matches to e-mail address like, <user@domain>. - (not (string-match "[^<> \t\n][!&@]" referent)) - ;; Eliminate matches to URLs - (not (string-match "\\`[a-zA-Z]+:" referent)) - ;; Don't match to <HTML> and </SGML> tags. - (not (and (memq major-mode - (if (boundp 'id-select-markup-modes) - id-select-markup-modes - '(html-mode sgml-mode))) - ;; Assume , followed by a number is a klink. - (not (string-match ",\\s *[0-9]" referent)) - (string-match "\\`[a-zA-Z!/]" referent)))) - klink))) - -;;; ************************************************************************ -;;; Hyperbole type definitions -;;; ************************************************************************ - -(defib klink () - "Follows a link delimited by <> to a koutline cell. -See documentation for the `link-to-kotl' function for valid klink formats." - (let* ((link-and-pos (klink:at-p)) - (link (car link-and-pos)) - (start-pos (car (cdr link-and-pos)))) - (if link - (progn (ibut:label-set link-and-pos) - (hact 'klink:act link start-pos))))) - -(defact link-to-kotl (link) - "Displays at the top of another window the referent pointed to by LINK. -LINK may be of any of the following forms, with or without delimiters: - < pathname [, cell-ref] > - < [-!&] pathname > - < @ cell-ref > - -See documentation for `kcell:ref-to-id' for valid cell-ref formats." - - (interactive "sKotl link specifier: ") - (or (stringp link) (error "(link-to-kotl): Non-string link argument, %s" - link)) - (cond - ((or (string-match (format "\\`<?\\s *@\\s *\\(%s\\)\\s *>?\\'" - klink:cell-ref-regexp) link) - (string-match (format "\\`<?\\s *\\([|:]%s\\)\\s *>?\\'" - klink:cell-ref-regexp) link)) - ;; < @ cell-ref > or < |viewspec > or < :augment-viewspec > - (hact 'link-to-kcell - nil - (kcell:ref-to-id - (substring link (match-beginning 1) (match-end 1))))) - ((string-match - (format "\\`<?\\s *\\([^ \t\n,<>]+\\)\\s *\\(,\\s *\\(%s\\)\\)?\\s *>?\\'" - klink:cell-ref-regexp) - link) - ;; < pathname [, cell-ref] > - (hact 'link-to-kcell - (substring link (match-beginning 1) (match-end 1)) - (if (match-end 3) - (kcell:ref-to-id - (substring link (match-beginning 3) (match-end 3)))))) - ((string-match - "\\`<?\\s *\\(\\([-!&]\\)?\\s *[^ \t\n,<>]+\\)\\s *>?\\'" link) - ;; < [-!&] pathname > - (hpath:find-other-window - (substring link (match-beginning 1) (match-end 1)))) - (t (error "(link-to-kotl): Invalid link specifier, %s" link)))) - -;;; ************************************************************************ -;;; Private functions -;;; ************************************************************************ - -(defun klink:act (link start-pos) - (let ((obuf (current-buffer))) - ;; Perform klink's action which is to jump to link referent. - (hact 'link-to-kotl link) - ;; Update klink label if need be, which might be in a different buffer - ;; than the current one. - (klink:update-label link start-pos obuf))) - -(defun klink:parse (reference) - "Returns (file-ref cell-ref) list parsed from REFERENCE string. -Either element of the list may be nil if REFERENCE does not contain that -element. REFERENCE should be one of the following forms (and may include an -optional pair of <> delimiters: - (pathname, cell-ref) - pathname, cell-ref - cell-ref - |viewspec - :augment-viewspec (ignored for now) - -See documentation for `kcell:ref-to-id' for valid cell-ref formats." - - (or (stringp reference) - (error "(klink:parse): Non-string reference argument, %s" - reference)) - (cond - ((string-match - (format - "\\`\\s *[<\(]?\\s *\\([^|: \t\n\r,<>][^ \t\n\r,<>]*\\)\\s *,\\s *\\(%s\\)\\s *[\)>]?\\s *\\'" - klink:cell-ref-regexp) - reference) - ;; pathname cell-ref - (list (substring reference (match-beginning 1) (match-end 1)) - (substring reference (match-beginning 2) (match-end 2)))) - ((string-match (format "\\`\\s *<?\\s *\\(%s\\)\\s *>?\\s *\\'" - klink:cell-ref-regexp) - reference) - ;; cell-ref - (list nil (substring reference (match-beginning 1) (match-end 1)))) - (t (error "(klink:parse): Invalid reference specifier, %s" reference)))) - -(defun klink:replace-label (klink link-buf start new-label) - "Replace out of date relative id in a link reference of the form, relid=idstamp." - (save-excursion - (set-buffer link-buf) - (if buffer-read-only - (message "Relative label should be `%s' in klink <%s>." - new-label klink) - (goto-char start) - (cond ((or (looking-at "<\\s *@\\s *") - (looking-at "[^,]+,\\s *")) - (goto-char (match-end 0)) - (zap-to-char 1 ?=) - (insert new-label ?=)) - (t nil))))) - -(defun klink:update-label (klink start link-buf) - "Update label of KLINK if its relative cell id has changed. -Assume point is in klink referent buffer, where the klink points." - (if (and (stringp klink) - (string-match - "[@,]\\s *\\([*0-9][*.0-9a-zA-Z]*\\)\\s *=\\s *0[0-9]*" - klink)) - ;; Then klink has both relative and permanent ids. - (let* ((label (substring klink (match-beginning 1) (match-end 1))) - (new-label (kcell-view:label))) - (if (and new-label (not (equal label new-label))) - (klink:replace-label klink link-buf start new-label))))) - -;;; ************************************************************************ -;;; Private variables. -;;; ************************************************************************ - -(defvar klink:cell-ref-regexp - "[|:0-9a-zA-Z][|:.*~=0-9a-zA-Z \t\n\r]*" - "Regexp matching a cell reference including relative and view specs. -Contains no groupings.") - -(provide 'klink)
--- a/lisp/hyperbole/kotl/kmenu.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,282 +0,0 @@ -;;!emacs -;; -;; FILE: kmenu.el -;; SUMMARY: Pulldown and popup menus for kotl-mode, the Hyperbole Outliner. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: mouse, outlines, wp -;; -;; AUTHOR: Bob Weiner -;; -;; ORIG-DATE: 28-Mar-94 at 11:22:09 -;; LAST-MOD: 6-Mar-97 at 01:20:03 by Bob Weiner -;; -;; Copyright (C) 1994, 1995, 1997 Free Software Foundation, Inc. -;; -;; This file is part of Hyperbole. -;; -;; DESCRIPTION: -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Public variables -;;; ************************************************************************ - -;;; This definition is used by InfoDock only. -(defconst id-menubar-kotl - '( - ("Koutline" - ["All-Cells-Attributes" (kotl-mode:cell-help nil -1) t] - ["Help" describe-mode t] - ["Manual" (id-info "(hyperbole.info)Outliner") t] - "----" - ["Find (Open)" find-file t] - ["Find-Read-Only" find-file-read-only t] - ["Save" save-buffer t] - ["Toggle-Read-Only" toggle-read-only t] - ["Write (Save as)" kfile:write t] - "----" - ["Quit" (id-tool-quit '(kill-buffer nil)) t] - ) - ("Edit" - ["Set-Cell-Attribute" kotl-mode:set-cell-attribute t] - "----" - ["Add-Child" kotl-mode:add-child t] - ["Add-Cell" kotl-mode:add-cell t] - ["Add-Parent" kotl-mode:add-parent t] - ["Append-Cell" kotl-mode:append-cell t] - ["Split-Cell" kotl-mode:split-cell t] - "----" - ["Kill-to-Cell-End" kotl-mode:kill-contents t] - ["Kill-Tree" kotl-mode:kill-tree t] - ["Yank" kotl-mode:yank t] - "----" - ["Copy-After-Cell" kotl-mode:copy-after t] - ["Copy-Before-Cell" kotl-mode:copy-before t] - ["Move-After-Cell" kotl-mode:move-after t] - ["Move-Before-Cell" kotl-mode:move-before t] - "----" - ["Fill" kotl-mode:fill-cell t] - ["Fill-Paragraph" kotl-mode:fill-paragraph t] - ["Set-Fill-Prefix" kotl-mode:set-fill-prefix t] - ) - ("Jump-to" - ["Cell" kotl-mode:goto-cell t] - "----" - ["Cell-Beginning" kotl-mode:beginning-of-cell t] - ["Cell-End" kotl-mode:end-of-cell t] - "----" - ["Child" kotl-mode:down-level t] - ["Parent" kotl-mode:up-level t] - "----" - ["Next-Cell" kotl-mode:next-cell t] - ["Prev-Cell" kotl-mode:previous-cell t] - "----" - ["Next-Same-Level" kotl-mode:forward-cell t] - ["Prev-Same-Level" kotl-mode:backward-cell t] - "----" - ["First-Sibling" kotl-mode:first-sibling t] - ["Last-Sibling" kotl-mode:last-sibling t] - "----" - ["Beginning-of-Tree" kotl-mode:beginning-of-tree t] - ["End-of-Tree" kotl-mode:end-of-tree t] - "----" - ["First-Cell" kotl-mode:beginning-of-buffer t] - ["Last-Cell" kotl-mode:end-of-buffer t] - ) - ("Label-Type" - ["Alphanumeric (Default)" (kview:set-label-type kview 'alpha) t] - ["Legal" (kview:set-label-type kview 'legal) t] - ["None" (kview:set-label-type kview 'no) t] - ["Partial-Alpha" (kview:set-label-type kview 'partial-alpha) t] - ["Permanent-Idstamp" (kview:set-label-type kview 'id) t] - ["Stars" (kview:set-label-type kview 'star) t] - ) - ("Link" - ["Add-at-Point" klink:create t] - ) - ("Tree" - ["Copy-to-Buffer" kotl-mode:copy-to-buffer t] - ["Demote" kotl-mode:demote-tree t] - ["Kill" kotl-mode:kill-tree t] - ["Mail" kotl-mode:mail-tree t] - ["Promote" kotl-mode:promote-tree t] - ["Show-Attributes" (kotl-mode:cell-help nil 2) t] - "----" - ["Copy-After-Cell" kotl-mode:copy-after t] - ["Copy-Before-Cell" kotl-mode:copy-before t] - ["Move-After-Cell" kotl-mode:move-after t] - ["Move-Before-Cell" kotl-mode:move-before t] - ) - ("View" - ["Set-View-Spec" kvspec:activate t] - ["Toggle-Blank-Lines" kvspec:toggle-blank-lines t] - "----" - ["Set-Cell-Attribute" kotl-mode:set-cell-attribute t] - ["Show-Cell-Attributes" (kotl-mode:cell-help) t] - ["All-Cells-Attributes" (kotl-mode:cell-help nil -1) t] - ["Show-Tree-Attributes" (kotl-mode:cell-help nil 2) t] - "----" - ["Hide (Collapse)" kotl-mode:hide-tree t] - ["Hide-Levels" kotl-mode:hide-sublevels t] - ["Hide-Subtree" kotl-mode:hide-subtree t] - ["Overview" kotl-mode:overview t] - "----" - ["Show (Expand)" kotl-mode:show-tree t] - ["Show-All" kotl-mode:show-all t] - ["Show-Subtree" kotl-mode:show-subtree t] - ["Show-Top-Level-Only" kotl-mode:top-cells t] - ) - )) - -;;; This definition is used by InfoDock and XEmacs. -(defconst id-popup-kotl-menu - '("Koutline" - ["All-Cells-Attributes" (kotl-mode:cell-help nil -1) t] - ["Help" describe-mode t] - ["Manual" (id-info "(hyperbole.info)Outliner") t] - "----" - ("Edit" - ["Set-Cell-Attribute" kotl-mode:set-cell-attribute t] - "----" - ["Add-Child" kotl-mode:add-child t] - ["Add-Cell" kotl-mode:add-cell t] - ["Add-Parent" kotl-mode:add-parent t] - ["Append-Cell" kotl-mode:append-cell t] - ["Split-Cell" kotl-mode:split-cell t] - "----" - ["Kill-to-Cell-End" kotl-mode:kill-contents t] - ["Kill-Tree" kotl-mode:kill-tree t] - ["Yank" kotl-mode:yank t] - "----" - ["Copy-After-Cell" kotl-mode:copy-after t] - ["Copy-Before-Cell" kotl-mode:copy-before t] - ["Move-After-Cell" kotl-mode:move-after t] - ["Move-Before-Cell" kotl-mode:move-before t] - "----" - ["Fill" kotl-mode:fill-cell t] - ["Fill-Paragraph" kotl-mode:fill-paragraph t] - ["Set-Fill-Prefix" kotl-mode:set-fill-prefix t] - ) - ("Jump-to" - ["Cell" kotl-mode:goto-cell t] - "----" - ["Cell-Beginning" kotl-mode:beginning-of-cell t] - ["Cell-End" kotl-mode:end-of-cell t] - "----" - ["Child" kotl-mode:down-level t] - ["Parent" kotl-mode:up-level t] - "----" - ["Next-Cell" kotl-mode:next-cell t] - ["Prev-Cell" kotl-mode:previous-cell t] - "----" - ["Next-Same-Level" kotl-mode:forward-cell t] - ["Prev-Same-Level" kotl-mode:backward-cell t] - "----" - ["First-Sibling" kotl-mode:first-sibling t] - ["Last-Sibling" kotl-mode:last-sibling t] - "----" - ["Beginning-of-Tree" kotl-mode:beginning-of-tree t] - ["End-of-Tree" kotl-mode:end-of-tree t] - "----" - ["First-Cell" kotl-mode:beginning-of-buffer t] - ["Last-Cell" kotl-mode:end-of-buffer t] - ) - ("Label-Type" - ["Alphanumeric (Default)" (kview:set-label-type kview 'alpha) t] - ["Legal" (kview:set-label-type kview 'legal) t] - ["None" (kview:set-label-type kview 'no) t] - ["Partial-Alpha" (kview:set-label-type kview 'partial-alpha) t] - ["Permanent-Idstamp" (kview:set-label-type kview 'id) t] - ["Stars" (kview:set-label-type kview 'star) t] - ) - ("Link" - ["Add-at-Point" klink:create t] - ) - ("Tree" - ["Copy-to-Buffer" kotl-mode:copy-to-buffer t] - ["Demote" kotl-mode:demote-tree t] - ["Kill" kotl-mode:kill-tree t] - ["Mail" kotl-mode:mail-tree t] - ["Promote" kotl-mode:promote-tree t] - ["Show-Attributes" (kotl-mode:cell-help nil 2) t] - "----" - ["Copy-After-Cell" kotl-mode:copy-after t] - ["Copy-Before-Cell" kotl-mode:copy-before t] - ["Move-After-Cell" kotl-mode:move-after t] - ["Move-Before-Cell" kotl-mode:move-before t] - ) - ("View" - ["Set-View-Spec" kvspec:activate t] - ["Toggle-Blank-Lines" kvspec:toggle-blank-lines t] - "----" - ["Set-Cell-Attribute" kotl-mode:set-cell-attribute t] - ["Show-Cell-Attributes" (kotl-mode:cell-help) t] - ["All-Cells-Attributes" (kotl-mode:cell-help nil -1) t] - ["Show-Tree-Attributes" (kotl-mode:cell-help nil 2) t] - "----" - ["Hide (Collapse)" kotl-mode:hide-tree t] - ["Hide-Levels" kotl-mode:hide-sublevels t] - ["Hide-Subtree" kotl-mode:hide-subtree t] - ["Overview" kotl-mode:overview t] - "----" - ["Show (Expand)" kotl-mode:show-tree t] - ["Show-All" kotl-mode:show-all t] - ["Show-Subtree" kotl-mode:show-subtree t] - ["Show-Top-Level-Only" kotl-mode:top-cells t] - ) - "----" - ["Find (Open)" find-file t] - ["Find-Read-Only" find-file-read-only t] - ["Save" save-buffer t] - ["Toggle-Read-Only" toggle-read-only t] - ["Write (Save as)" kfile:write t] - "----" - ["Quit" (id-tool-quit '(kill-buffer nil)) t] - )) - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -;;; This definition is used only by XEmacs and Emacs19. -(defun kotl-menubar-menu () - "Add a Koutline menu to the menubar for each koutline buffer." - (cond ((fboundp 'popup-mode-menu) - (setq mode-popup-menu id-popup-kotl-menu)) - (hyperb:lemacs-p - (define-key kotl-mode-map 'button3 'kotl-popup-menu)) - (t ;; hyperb:emacs19-p - (define-key kotl-mode-map [down-mouse-3] 'kotl-popup-menu) - (define-key kotl-mode-map [mouse-3] nil))) - (if (and (boundp 'current-menubar) - (or hyperb:emacs19-p current-menubar) - (not (car (find-menu-item current-menubar '("Koutline"))))) - (progn - (set-buffer-menubar (copy-sequence current-menubar)) - (if (fboundp 'add-submenu) - (add-submenu nil id-popup-kotl-menu) - (add-menu nil (car id-popup-kotl-menu) (cdr id-popup-kotl-menu)))))) - -;;; This definition is used only by XEmacs and Emacs19. -(defun kotl-popup-menu (event) - "Popup the Koutline buffer menu." - (interactive "@e") - (mouse-set-point event) - (if (fboundp 'popup-mode-menu) - (popup-mode-menu) - (popup-menu id-popup-kotl-menu))) - -(cond ((null hyperb:window-system)) - ((fboundp 'id-menubar-set) - ;; InfoDock under a window system - (require 'id-menubars) - (id-menubar-set 'kotl-mode 'id-menubar-kotl)) - (hyperb:lemacs-p - ;; XEmacs under a window system - (add-hook 'kotl-mode-hook 'kotl-menubar-menu)) - (hyperb:emacs19-p - ;; Emacs 19 under a window system - (require 'lmenu) - (add-hook 'kotl-mode-hook 'kotl-menubar-menu))) - -(provide 'kmenu)
--- a/lisp/hyperbole/kotl/knode.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,98 +0,0 @@ -;;!emacs -;; -;; FILE: knode.el -;; SUMMARY: Generic nodes for use as elements in data structures. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: extensions, hypermedia, outlines -;; -;; AUTHOR: Kellie Clark & Bob Weiner -;; -;; ORIG-DATE: 5/1/93 -;; LAST-MOD: 14-Jun-95 at 12:45:49 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1993-1995, Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -;;; -;;; Knodes -;;; - -(defun knode:create (contents &optional prop-list) - "Return a new knode which stores CONTENTS and optional PROP-LIST." - (list 'knode - 'contents contents - 'plist prop-list)) - -(defun knode:contents (knode) - "Return KNODE's contents." - (if (knode:is-p knode) - (car (cdr (memq 'contents knode))) - (error "(knode:contents): Argument must be a knode."))) - -(fset 'knode:copy 'copy-tree) - -(defun knode:is-p (object) - "Is OBJECT a knode?" - (and (listp object) (eq (car object) 'knode))) - -(defun knode:set-contents (knode contents) - "Set KNODE's CONTENTS." - (if (knode:is-p knode) - (setcar (cdr (memq 'contents knode)) contents) - (error "(knode:set-contents): First arg must be a knode."))) - -;;; ************************************************************************ -;;; Private functions -;;; ************************************************************************ - -(defun knode:get-attr (obj attribute) - "Return the value of OBJECT's ATTRIBUTE." - (car (cdr (memq attribute obj)))) - -(defun knode:remove-attr (obj attribute) - "Remove OBJECT's ATTRIBUTE, if any, and return modified OBJECT. -Use (setq object (knode:remove-attr object attribute)) to ensure that OBJECT -is updated." - (let ((tail obj) - sym - prev) - (setq sym (car tail)) - (while (and sym (eq sym attribute)) - (setq tail (cdr (cdr tail)) - sym (car tail))) - (setq obj tail - prev tail - tail (cdr (cdr tail))) - (while tail - (setq sym (car tail)) - (if (eq sym attribute) - (setcdr (cdr prev) (cdr (cdr tail)))) - (setq prev tail - tail (cdr (cdr tail)))) - obj)) - -(defun knode:set-attr (obj attribute value) - "Set OBJECT's ATTRIBUTE to VALUE and return OBJECT." - (let ((attr (memq attribute obj))) - (if attr - (setcar (cdr attr) value) - (setq obj (nconc obj (list attribute value))))) - obj) - -;;; ************************************************************************ -;;; Private variables -;;; ************************************************************************ - -(provide 'knode) -
--- a/lisp/hyperbole/kotl/kotl-mode.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2873 +0,0 @@ -;;!emacs -;; -;; FILE: kotl-mode.el -;; SUMMARY: Major mode for editing koutlines and associated commands. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: data, hypermedia, outlines, wp -;; -;; AUTHOR: Bob Weiner & Kellie Clark -;; -;; ORIG-DATE: 6/30/93 -;; LAST-MOD: 6-Mar-97 at 01:15:42 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1993, 1994, 1995 Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Other required Lisp Libraries -;;; ************************************************************************ - -(mapcar 'require '(hsite hmail kview kimport kvspec kotl)) - -;;; ************************************************************************ -;;; Public variables -;;; ************************************************************************ - -(defvar kotl-mode:refill-flag nil - "*Automatically refill cells during move, copy, promotion and demotion operations when non-nil. -Default value is nil. Cells with a `no-fill' attribute are never refilled -during such operations, regardless of the value of this flag.") - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -;;;###autoload -(defun kotl-mode () - "The major mode used to edit and view koutlines. -It provides the following keys: -\\{kotl-mode-map}" - (interactive) - (use-local-map kotl-mode-map) - (set-syntax-table text-mode-syntax-table) - ;; Turn off filladapt minor mode if on, so that it does not interfere with - ;; the filling code in "kfill.el". - (and (boundp 'filladapt-mode) filladapt-mode (filladapt-mode -1)) - (if (/= 3 (length (action:params (symbol-function 'fill-paragraph)))) - ;; Some package such as filladapt has overwritten the primitives - ;; defined in kfill.el, so reload it. - (load "kfill")) - ;; Ensure that outline structure data is saved when save-buffer is called - ;; from save-some-buffers, {C-x s}. - (add-hook 'local-write-file-hooks 'kotl-mode:update-buffer) - (mapcar 'make-local-variable - '(kotl-previous-mode indent-line-function indent-region-function - minor-mode-alist selective-display-ellipses)) - ;; Used by kimport.el functions. - (if (and (boundp 'kotl-previous-mode) kotl-previous-mode) - nil - (setq kotl-previous-mode major-mode - ;; Remove outline indication due to selective-display. - minor-mode-alist (copy-sequence minor-mode-alist) - minor-mode-alist (set:remove '(selective-display " Outline") - minor-mode-alist) - minor-mode-alist (set:remove '(selective-display " Otl") - minor-mode-alist) - ;; Remove indication that buffer is narrowed. - mode-line-format (copy-sequence mode-line-format) - mode-line-format (set:remove "%n" mode-line-format))) - ;; - (setq indent-line-function 'kotl-mode:indent-line - indent-region-function 'kotl-mode:indent-region - local-abbrev-table text-mode-abbrev-table - selective-display t - selective-display-ellipses t - paragraph-start "^[ \t]*$\\|^\^L" - paragraph-separate "^[ \t]*$\\|^\^L") - ;; - ;; This major-mode setting must come after the local variable settings but - ;; before the koutline is formatted. - (setq major-mode 'kotl-mode - mode-name "Kotl" - indent-tabs-mode nil) - ;; If buffer has not yet been formatted for editing, format it. - (cond - ;; Koutline file that has been loaded and formatted for editing. - ((kview:is-p kview) - ;; The buffer might have been widened for inspection, so narrow to cells - ;; only. - (kfile:narrow-to-kcells)) - ;; Koutline file that has been loaded but not yet formatted for editing. - ((kfile:is-p) - (kfile:read - (current-buffer) - (and buffer-file-name (file-exists-p buffer-file-name))) - (kvspec:activate)) - ;; New koutline buffer or a foreign text buffer that must be converted to - ;; koutline format. - (t - (kfile:create (current-buffer)) - (kvspec:activate))) - ;; We have been converting a buffer from a foreign format to a koutline. - ;; Now that it is converted, ensure that kotl-previous-mode is set to - ;; koutline now. - (setq kotl-previous-mode 'kotl-mode) - (run-hooks 'kotl-mode-hook)) - -(defun kotl-mode:find-file-hook () - (if (kview:is-p kview) - (kotl-mode:to-valid-position)) - nil) - -;;; Ensure that point ends up at a valid position whenever a find-file -;;; is done on a kotl-file. -(add-hook 'find-file-hooks 'kotl-mode:find-file-hook) - -;;; Ensure that outline structure data is hidden from view after a file save. -(add-hook 'after-save-hook 'kfile:narrow-to-kcells) - -;;; ------------------------------------------------------------------------ -;;; Editing within a single kotl -;;; ------------------------------------------------------------------------ - -(fset 'kotl-mode:backward-delete-char-untabify - 'kotl-mode:delete-backward-char) -(fset 'kotl-mode:backward-delete-char - 'kotl-mode:delete-backward-char) - -(defun kotl-mode:backward-kill-word (arg) - "Kill up to prefix ARG words preceding point within a single cell." - (interactive "*p") - (or arg (setq arg 1)) - (cond ((< arg 0) - (if (kotl-mode:eocp) - (error "(kotl-mode:backward-kill-word): End of cell"))) - ((> arg 0) - (if (kotl-mode:bocp) - (error "(kotl-mode:backward-kill-word): Beginning of cell")))) - (if (= arg 0) - nil - (save-restriction - (narrow-to-region (kcell-view:start) (kcell-view:end-contents)) - (backward-kill-word arg)))) - -(defun kotl-mode:center-line () - "Center the line point is on, within the width specified by `fill-column'. -This means adjusting the indentation so that it equals the distance between -the end of the text and `fill-column'." - (interactive "*") - (setq zmacs-region-stays t) ;; Maintain region highlight for XEmacs. - (let ((indent (kcell-view:indent)) - (opoint (point-marker)) - (bocp) - start) - (setq start (kotl-mode:start-of-line)) - (if (setq bocp (kotl-mode:bocp)) - (progn - ;; Add a temporary fill-prefix since this is the 1st line of the cell - ;; where label could interfere with centering. - (insert "\n\n") (insert-char ?\ indent))) - (center-line) - (if bocp - ;; Delete temporary fill prefix. - (delete-region start (+ start indent 2))) - (goto-char opoint) - ;; Move to editable point if need be. - (kotl-mode:to-valid-position))) - -(defun kotl-mode:center-paragraph () - "Center each nonblank line in the paragraph at or after point. -See `center-line' for more info." - (interactive "*") - (setq zmacs-region-stays t) ;; Maintain region highlight for XEmacs. - (let ((indent (kcell-view:indent)) - (opoint (point-marker)) - start) - (backward-paragraph) - (kotl-mode:to-valid-position) - (setq start (point)) - ;; Add a temporary fill-prefix for 1st line in cell which contains a - ;; label, so is centered properly. - (insert "\n\n") (insert-char ?\ indent) - (kcell-view:operate 'center-paragraph) - ;; Delete temporary fill prefix. - (delete-region start (+ start indent 2)) - ;; Return to original point. - (goto-char (min opoint (kcell-view:end-contents))) - ;; Move to editable point if need be. - (kotl-mode:to-valid-position))) - -(defun kotl-mode:copy-region-as-kill (start end) - "Copy region between START and END within a single kcell to kill ring." - (interactive "r") - (kotl-mode:kill-region start end t)) - -(defun kotl-mode:copy-to-register (register start end &optional delete-flag) - "Copy into REGISTER the region START to END. -With optional prefix arg DELETE-FLAG, delete region." - (interactive "cCopy to register: \nr\nP") - (let ((indent (kcell-view:indent))) - (set-register register - (hypb:replace-match-string - (concat "^" (make-string indent ?\ )) - (buffer-substring start end) - "" t))) - (if delete-flag (delete-region start end))) - -(defun kotl-mode:delete-backward-char (arg &optional kill-flag) - "Delete up to the preceding prefix ARG characters. -Return number of characters deleted. -Optional KILL-FLAG non-nil means save in kill ring instead of deleting. -Does not delete across cell boundaries." - (interactive "*P") - (if (interactive-p) - (if current-prefix-arg - (setq kill-flag t - arg (prefix-numeric-value current-prefix-arg)))) - (or arg (setq arg 1)) - (kotl-mode:delete-char (- arg) kill-flag)) - -(defun kotl-mode:delete-blank-lines () - "On blank line within a cell, delete all surrounding blank lines, leaving just one. -On isolated blank line, delete that one. -On nonblank line, delete all blank lines that follow it. - -If nothing but whitespace follows point until the end of a cell, delete all -whitespace at the end of the cell." - (interactive "*") - ;; If nothing but whitespace from point until the end of cell, remove all - ;; cell trailing whitespace. - (let ((end (kcell-view:end-contents)) - start) - (if (save-excursion - (skip-chars-forward " \t\n\r" end) - (not (kotl-mode:eocp))) - (kcell-view:operate (function (lambda () (delete-blank-lines)))) - (setq start (kcell-view:start)) - (goto-char end) - ;; delete any preceding whitespace - (skip-chars-backward " \t\n\r" start) - (delete-region (max start (point)) end))) - (kotl-mode:to-valid-position)) - -(defun kotl-mode:delete-char (arg &optional kill-flag) - "Delete up to prefix ARG characters following point. -Return number of characters deleted. -Optional KILL-FLAG non-nil means save in kill ring instead of deleting. -Does not delete across cell boundaries." - (interactive "*P") - (if (interactive-p) - (if current-prefix-arg - (setq kill-flag t - arg (prefix-numeric-value current-prefix-arg)))) - (or arg (setq arg 1)) - (let ((del-count 0) - (indent (kcell-view:indent)) - count start end) - (cond ((> arg 0) - (if (kotl-mode:eocp) - (error "(kotl-mode:delete-char): End of cell") - (setq end (kcell-view:end) - arg (min arg (- end (point)))) - (while (> arg 0) - (if (kotl-mode:eolp) - (if (/= ?\ (char-syntax (following-char))) - (setq arg 0 - del-count (1- del-count)) - (delete-char 1 kill-flag) - ;; There may be non-whitespace characters in the - ;; indent area. Don't delete them. - (setq count indent) - (while (and (> count 0) - (= ?\ (char-syntax (following-char)))) - (delete-char 1) - (setq count (1- count)))) - (delete-char 1 kill-flag)) - (setq arg (1- arg) - del-count (1+ del-count))) - )) - ((< arg 0) - (if (kotl-mode:bocp) - (error "(kotl-mode:delete-char): Beginning of cell") - (setq start (kcell-view:start) - arg (max arg (- start (point)))) - (while (< arg 0) - (if (kotl-mode:bolp) - (if (/= ?\ (char-syntax (preceding-char))) - (setq arg 0 - del-count (1- del-count)) - ;; There may be non-whitespace characters in the - ;; indent area. Don't delete them. - (setq count indent) - (while (and (> count 0) - (= ?\ (char-syntax (preceding-char)))) - (delete-char -1) - (setq count (1- count))) - (if (zerop count) - (delete-char -1 kill-flag))) - (delete-char -1 kill-flag)) - (setq arg (1+ arg) - del-count (1+ del-count)))))) - del-count)) - -(defun kotl-mode:delete-horizontal-space () - "Delete all spaces and tabs around point." - (interactive "*") - (save-restriction - (narrow-to-region - (save-excursion - (kotl-mode:start-of-line)) - (save-excursion - (kotl-mode:finish-of-line))) - (delete-horizontal-space))) - -(defun kotl-mode:delete-indentation (&optional arg) - "Join this line to previous and fix up whitespace at join. -If there is a fill prefix, delete it from the beginning of this line. -With argument, join this line to following line." - (interactive "*P") - (kcell-view:operate - (function - (lambda () - (let ((opoint (point))) - (beginning-of-line) - (if arg (forward-line 1)) - (if (eq (preceding-char) ?\n) - (progn - (delete-region (point) (1- (point))) - ;; If the second line started with the fill prefix, - ;; delete the prefix. - (if (and fill-prefix - (<= (+ (point) (length fill-prefix)) (point-max)) - (string= fill-prefix - (buffer-substring - (point) (+ (point) (length fill-prefix))))) - (delete-region (point) (+ (point) (length fill-prefix)))) - (fixup-whitespace)) - (goto-char opoint))))))) - -(defun kotl-mode:fill-cell (&optional justify ignore-collapsed-p) - "Fill current cell within current view if it does not have a non-nil `no-fill' attribute. -With optional JUSTIFY, justify cell as well. -IGNORE-COLLAPSED-P is used when caller has already expanded cell, indicating -it is not collapsed." - (interactive "*P") - (cond ((kcell-view:get-attr 'no-fill) - (if (interactive-p) - (progn (beep) - (message "Current cell has a `do not fill' attribute.") - nil))) - ((string-match "\\`[ \t\n\r]*\\'" (kcell-view:contents)) - ;; Cell content is all whitespace. - nil) - (t (let* ((indent (kcell-view:indent)) - (opoint (set-marker (make-marker) (point))) - (start (kcell-view:start)) - (collapsed-p) - (end (kcell-view:end-contents)) - temp-prefix prev-point) - (goto-char start) - ;; Expand cell if collapsed so that filling is done properly. - (if (and (not ignore-collapsed-p) - (setq collapsed-p (search-forward "\r" end t))) - (subst-char-in-region start end ?\r ?\n t)) - (goto-char start) - ;; Add a temporary fill-prefix for first labeled line, so is - ;; filled properly. - (insert (setq temp-prefix - (concat "\n\n" (make-string indent ?\ )))) - (while (progn (fill-paragraph justify) - (setq prev-point (point)) - (forward-paragraph) - (and (/= (point) prev-point) - (< (point) (kcell-view:end-contents)) - (if (memq (preceding-char) '(?\n ?\r)) - (not (looking-at "[\n\r]")) - t)))) - ;; Delete temporary fill prefix. - (goto-char start) - (if (looking-at temp-prefix) - (replace-match "" t t)) - ;; Return to original point. - (setq end (kcell-view:end-contents)) - (goto-char (min opoint end)) - ;; - ;; If cell was collapsed before filling, collapse it again. - (if collapsed-p - (subst-char-in-region start end ?\n ?\r t)) - ;; - ;; Remove markers - (set-marker opoint nil)) - ;; Move to editable point if need be. - (kotl-mode:to-valid-position)))) - -(defun kotl-mode:fill-paragraph (&optional justify) - "Fill the current paragraph within the cell. -With optional JUSTIFY, justify the paragraph as well. -Ignore any non-nil no-fill attribute attached to the cell." - (interactive "*P") - (let ((indent (kcell-view:indent)) - (opoint (point-marker)) - start end) - (backward-paragraph) - (kotl-mode:to-valid-position) - (setq start (point-marker)) - ;; Add a temporary fill-prefix for 1st line in cell which contains a - ;; label, so is filled properly. - (insert "\n\n") (insert-char ?\ indent) - (setq end (point-marker)) - ;; Return to original paragraph point. This is the correct formula, - ;; considering the fill prefix that was just added. - (goto-char (min (max opoint (point)) (kcell-view:end-contents))) - (fill-paragraph justify) - ;; Delete temporary fill prefix. - (delete-region start end) - ;; Return to original point. - (goto-char (min opoint (kcell-view:end-contents))) - ;; Move to editable point if need be. - (kotl-mode:to-valid-position) - ;; Remove markers - (set-marker opoint nil) - (set-marker start nil) - (set-marker end nil))) - -;; XEmacs binds this to {M-q}. -(fset 'kotl-mode:fill-paragraph-or-region 'kotl-mode:fill-paragraph) - -(defun kotl-mode:fill-tree (&optional top-p) - "Refill each cell within the tree whose root is at point. -Skip cells with a non-nil no-fill attribute. -With optional prefix argument TOP-P non-nil, refill all cells in the outline." - (interactive "P") - ;; Store list of which cells are presently collapsed. - (let ((collapsed-cells - (kview:map-tree - (function (lambda (view) - ;; Use free variable label-sep-len bound in - ;; kview:map-tree for speed. - (kcell-view:collapsed-p nil label-sep-len))) - kview top-p))) - ;; - ;; Expand all cells in tree. - (if top-p - (subst-char-in-region (point-min) (point-max) ?\r ?\n t) - (save-excursion - (kotl-mode:end-of-tree) - (subst-char-in-region - (point) (kcell-view:end-contents) ?\r ?\n t))) - ;; - ;; Refill cells without no-fill property. - (kview:map-tree (function (lambda (view) (kotl-mode:fill-cell))) - kview top-p) - ;; - ;; Collapse temporarily expanded cells. - (if (delq nil collapsed-cells) - (kview:map-tree - (function - (lambda (view) - (if (car collapsed-cells) - ;; Use free variable label-sep-len bound in - ;; kview:map-tree for speed. - (kcell-view:collapse nil label-sep-len)) - (setq collapsed-cells (cdr collapsed-cells)))) - kview top-p)))) - -(defun kotl-mode:insert-buffer (buffer) - "Insert after point the contents of BUFFER. -Puts mark after the inserted text. -BUFFER may be a buffer or a buffer name." - (interactive "*bInsert buffer: ") - (insert-buffer buffer) - (kotl-mode:add-indent-to-region)) - -(defun kotl-mode:insert-file (import-from children-p) - "Insert each element in IMPORT-FROM as a separate cell in the current view. -Insert as sibling cells following the current cell unless prefix arg, -CHILDREN-P is non-nil, then insert as the initial children of the current -cell. - -IMPORT-FROM may be a buffer name or file name (file name completion is -provided). - -See documentation for `kimport:file' for information on how the type of -importation is determined." - (interactive - (list (read-file-name - (if current-prefix-arg - "Buffer or file to insert as children of current cell: " - "Buffer or file to insert as siblings of current cell: ")) - current-prefix-arg)) - (kimport:file import-from (current-buffer) children-p)) - -(defun kotl-mode:insert-file-contents (filename) - "Insert contents of file FILENAME into current cell after point. -Set mark after the inserted text." - (interactive "*fInsert file: ") - (let ((tem (insert-file-contents filename))) - (push-mark (+ (point) (car (cdr tem))))) - (kotl-mode:add-indent-to-region)) - -(defun kotl-mode:insert-register (register &optional arg) - "Insert contents of register REGISTER at point in current cell. -REGISTER is a character naming the register to insert. -Normally puts point before and mark after the inserted text. -If optional second arg is non-nil, puts mark before and point after. -Interactively, second arg is non-nil if prefix arg is supplied." - (interactive "*cInsert register: \nP") - (push-mark) - (let ((val (get-register register))) - (cond ((consp val) - (insert-rectangle val)) - ((stringp val) - (insert val) - (kotl-mode:add-indent-to-region)) - ((integerp val) - (princ val (current-buffer))) - ((and (markerp val) (marker-position val)) - (princ (marker-position val) (current-buffer))) - (t - (error "Register `%c' does not contain text" register)))) - (if (not arg) (exchange-point-and-mark))) - -(defun kotl-mode:just-one-space () - "Delete all spaces and tabs around point and leave one space." - (interactive "*") - (save-restriction - (narrow-to-region - (save-excursion - (kotl-mode:start-of-line)) - (save-excursion - (kotl-mode:finish-of-line))) - (just-one-space))) - -(defun kotl-mode:kill-line (&optional arg) - "Kill ARG lines from point." - (interactive "*P") - (if (and (null arg) - (kotl-mode:bolp) - (boundp 'kill-whole-line) kill-whole-line) - (let ((indent (kcell-view:indent))) - ;; Kill whole line including newline, if any. - (kcell-view:operate - (function - (lambda () - (let ((no-newline)) - (kill-region (point) - (progn (setq no-newline - (not (search-forward "\n" nil 'stay))) - (point))) - (or no-newline (delete-char indent))))))) - ;; Kill part of a line or multiple lines. - (let ((num-arg (prefix-numeric-value arg))) - (cond - ((and (null arg) (not (kotl-mode:eolp))) - ;; kill to eol but not newline - (kill-region (point) (setq arg (kotl-mode:finish-of-line)))) - ((= num-arg 0) - ;; kill to bol - (kill-region (point) (setq arg (kotl-mode:start-of-line)))) - (t;; (/= num-arg 0) - ;; Find start and end of region to kill - (let ((start (point)) - (end (min (kcell-view:end-contents) - (save-excursion (forward-line num-arg) (point))))) - (kotl-mode:kill-region start end)))))) - (setq last-command 'kill-region)) - -(defun kotl-mode:kill-region (start end &optional copy-p) - "Kill region between START and END within a single kcell. -With optional COPY-P equal to 't, copy region to kill ring but does not -kill it. With COPY-P any other non-nil value, return region as a -string without affecting kill ring. - -If the buffer is read-only and COPY-P is nil, the region will not be deleted -but it will be copied to the kill ring and then an error will be signaled." - (interactive "*r") - (let ((read-only (and (not copy-p) buffer-read-only))) - (if read-only (setq copy-p t)) - (if (and (number-or-marker-p start) - (number-or-marker-p end) - (eq (kcell-view:cell start) - (kcell-view:cell end))) - (save-excursion - (goto-char start) - (let ((indent (kcell-view:indent)) - killed subst-str) - ;; Convert region to string - ;; Convert all occurrences of newline + indent - ;; to just newline, eliminating indent. - ;; Then save to kill ring. - (setq subst-str (concat "\\([\n\r]\\)" (make-string indent ?\ )) - killed - (hypb:replace-match-string - subst-str (buffer-substring start end) "\\1")) - (if copy-p - nil - ;; If last char of region is a newline, then delete indent in - ;; following line. - (delete-region - start (+ end (if (memq (char-after (1- (max start end))) - '(?\n ?\r)) - indent - 0)))) - (if (and copy-p (not (eq copy-p t))) - ;; Return killed region as a string. - killed - (if (eq last-command 'kill-region) - (kill-append killed (< end start)) - (kill-new killed)) - (setq this-command 'kill-region) - (if read-only (barf-if-buffer-read-only)) - ))) - (error - "(kotl-mode:kill-region): Bad region or not within a single kcell.")))) - -(fset 'kotl-mode:kill-ring-save 'kotl-mode:copy-region-as-kill) - -(defun kotl-mode:kill-sentence (&optional arg) - "Kill up to prefix ARG (or 1) sentences following point within a single cell." - (interactive "*p") - (or arg (setq arg 1)) - (cond ((> arg 0) - (if (kotl-mode:eocp) - (error "(kotl-mode:kill-sentence): End of cell"))) - ((< arg 0) - (if (kotl-mode:bocp) - (error "(kotl-mode:kill-sentence): Beginning of cell")))) - (if (= arg 0) - nil - (kotl-mode:kill-region (point) - (save-excursion - (kotl-mode:forward-sentence arg))))) - -(defun kotl-mode:kill-word (arg) - "Kill up to prefix ARG words following point within a single cell." - (interactive "*p") - (or arg (setq arg 1)) - (cond ((> arg 0) - (if (kotl-mode:eocp) - (error "(kotl-mode:kill-word): End of cell"))) - ((< arg 0) - (if (kotl-mode:bocp) - (error "(kotl-mode:kill-word): Beginning of cell")))) - (if (= arg 0) - nil - (save-restriction - (narrow-to-region (kcell-view:start) (kcell-view:end-contents)) - (kill-word arg)))) - -(defun kotl-mode:newline (arg) - "Insert a newline. With ARG, insert ARG newlines. -In Auto Fill mode, if no numeric arg, break the preceding line if it is -too long." - (interactive "*p") - (let ((indent (kcell-view:indent))) - (if (equal arg 1) - (progn - (save-excursion - (insert ?\n) - (insert-char ?\ indent)) - (do-auto-fill) - (forward-line 1) - (kotl-mode:start-of-line) - ) - (while (> arg 0) - (insert ?\n) - (insert-char ?\ indent) - (setq arg (1- arg)))))) - -(fset 'kotl-mode:newline-and-indent 'kotl-mode:newline) - -(defun kotl-mode:open-line (arg) - "Insert a newline and leave point before it. -With arg N, insert N newlines." - (interactive "*p") - (let* ((bolp (and (kotl-mode:bolp) (not (kotl-mode:bocp)))) - (indent (kcell-view:indent))) - (while (> arg 0) - (save-excursion - (insert ?\n) - (if (and (not bolp) fill-prefix) - (insert fill-prefix) - (insert-char ?\ indent))) - (setq arg (1- arg))) - (if (and bolp fill-prefix) - (progn (delete-horizontal-space) - (insert fill-prefix))) - )) - -(defun kotl-mode:set-fill-prefix (turn-off) - "Sets fill prefix to line up to point. -With prefix arg TURN-OFF or at begin of line, turns fill prefix off." - (interactive "P") - (set-fill-prefix (or turn-off (kotl-mode:bolp)))) - -(defun kotl-mode:transpose-chars (arg) - "Interchange characters around point, moving forward one character. -With prefix ARG, take character before point and drag it forward past ARG -other characters (backward if ARG negative). -If no prefix ARG and at end of line, the previous two characters are -exchanged." - (interactive "*P") - (and (null arg) (kotl-mode:eolp) (kotl-mode:forward-char -1)) - (transpose-subr 'kotl-mode:forward-char (prefix-numeric-value arg))) - -(defun kotl-mode:transpose-lines (arg) - "Exchange current line and previous line, leaving point after both. -If no previous line, exchange current with next line. -With prefix ARG, take previous line and move it past ARG lines. -With prefix ARG = 0, interchange the line that contains point with the line -that contains mark." - (interactive "*p") - (cond - ((and (kotl-mode:first-line-p) (kotl-mode:last-line-p)) - (error "(kotl-mode:transpose-lines): Only one line in outline")) - ;; - ;; Transpose current and previous lines or current and next lines, if no - ;; previous line. Leave point after both exchanged lines. - ((= arg 1) - (let* ((point (point-marker)) - (mark (set-marker (make-marker) - (if (kotl-mode:first-line-p) - (kotl-mode:next-line 1) - (kotl-mode:previous-line 1))))) - (kotl-mode:transpose-lines-internal point mark) - (goto-char (max point mark)) - (kotl-mode:next-line 1) - (set-marker mark nil))) - ;; - ;; Transpose point and mark lines, leaving point on the line of text that - ;; originally contained point. - ((= arg 0) - (kotl-mode:transpose-lines-internal (point-marker) (hypb:mark-marker t)) - ;; This is like exchange-point-and-mark, but doesn't activate the - ;; mark. - (goto-char (prog1 (hypb:mark t) - (set-marker (hypb:mark-marker t) (point))))) - ;; - ;; Move previous line past ARG next lines and leave point after previous - ;; line text. - (t - (if (kotl-mode:first-line-p) - (error "(kotl-mode:transpose-lines): No previous line to transpose")) - (kotl-mode:previous-line 1) - (let* ((mark (set-marker (make-marker) - (save-excursion (kotl-mode:next-line arg)))) - (line-to-move (kotl-mode:delete-line))) - (condition-case () - ;; Delete trailing newline if any, ignoring error. - (kotl-mode:delete-char 1) - (error nil)) - (goto-char mark) - (set-marker mark nil) - (kotl-mode:finish-of-line) - (insert "\n") - (insert-char ?\ (kcell-view:indent)) - (insert line-to-move) - (kotl-mode:start-of-line))))) - -(defun kotl-mode:transpose-paragraphs (arg) - "Interchange this (or next) paragraph with previous one." - (interactive "*p") - (transpose-subr 'kotl-mode:forward-paragraph (prefix-numeric-value arg))) - -(defun kotl-mode:transpose-sentences (arg) - "Interchange this (next) and previous sentence." - (interactive "*p") - (transpose-subr 'kotl-mode:forward-sentence (prefix-numeric-value arg))) - -(defun kotl-mode:transpose-words (arg) - "Interchange words around point, leaving point after both words. -With prefix ARG, take word before or around point and drag it forward past -ARG other words (backward if ARG negative). If ARG is zero, the words around -or after point and around or after mark are interchanged." - (interactive "*p") - (transpose-subr 'kotl-mode:forward-word (prefix-numeric-value arg))) - -(defun kotl-mode:zap-to-char (arg char) - "Kill up to and including prefix ARG'th occurrence of CHAR. -Goes backward if ARG is negative; error if CHAR not found." - (interactive "*p\ncZap to char within current cell: ") - (kcell-view:operate - (function (lambda () (zap-to-char arg char))))) - -;;; ------------------------------------------------------------------------ -;;; Editing across kotls -;;; ------------------------------------------------------------------------ - -(defun kotl-mode:append-cell (contents-cell append-to-cell) - "Append CONTENTS-CELL to APPEND-TO-CELL. -APPEND-TO-CELL is refilled if neither cell has a no-fill property and -kotl-mode:refill-flag is enabled." - (interactive - (let* ((label (kcell-view:label)) - (hargs:defaults (list label label))) - (hargs:iform-read - '(interactive - "*+KAppend contents of cell: \n+KAppend contents of cell <%s> to cell: ")))) - (save-excursion - (kotl-mode:goto-cell contents-cell) - (let ((contents (kcell-view:contents)) - (no-fill (kcell-view:get-attr 'no-fill))) - (kotl-mode:goto-cell append-to-cell) - (if no-fill nil (setq no-fill (kcell-view:get-attr 'no-fill))) - (goto-char (kcell-view:end-contents)) - (let ((fill-prefix (make-string (kcell-view:indent) ?\ ))) - (if (kotl-mode:bolp) - nil - ;; Append contents of cell beginning on its own line. - (insert "\n" fill-prefix)) - (kview:insert-contents (kcell-view:cell) contents - (or no-fill (null kotl-mode:refill-flag)) - fill-prefix))))) - -(defun kotl-mode:copy-after (from-cell-ref to-cell-ref child-p) - "Copy tree rooted at FROM-CELL-REF to follow tree rooted at TO-CELL-REF. -If prefix arg CHILD-P is non-nil, make FROM-CELL-REF the first child of -TO-CELL-REF, otherwise make it the sibling following TO-CELL-REF. - -Leave point at the start of the root cell of the new tree." - (interactive - (let* ((label (kcell-view:label)) - (hargs:defaults (list label label))) - (append - (hargs:iform-read - (list - 'interactive - (format "*+KCopy tree: \n+KCopy tree <%%s> to follow as %s of cell: " - (if current-prefix-arg "child" "sibling")))) - (list current-prefix-arg)))) - ;; - ;; Copy tree in current view and leave point at the start of the copy. - (goto-char (kotl-mode:move-after from-cell-ref to-cell-ref child-p t)) - ;; Alter the copied tree so each cell appears to be newly created. - (kview:map-tree - (function - (lambda (view) - (kcell-view:set-cell - (kcell:create nil (kview:id-increment view))))) - kview)) - -(defun kotl-mode:copy-before (from-cell-ref to-cell-ref parent-p) - "Copy tree rooted at FROM-CELL-REF to precede tree rooted at TO-CELL-REF. -If prefix arg PARENT-P is non-nil, make FROM-CELL-REF the first child of -TO-CELL-REF's parent, otherwise make it the preceding sibling of TO-CELL-REF. - -Leave point at the start of the root cell of the new tree." - (interactive - (let* ((label (kcell-view:label)) - (hargs:defaults (list label label))) - (append - (hargs:iform-read - (list 'interactive - (format "*+KCopy tree: \n+KCopy tree <%%s> to be %s of cell: " - (if current-prefix-arg "first child of parent" - "preceding sibling")))) - (list current-prefix-arg)))) - ;; - ;; Copy tree in current view and leave point at the start of the copy. - (goto-char (kotl-mode:move-before from-cell-ref to-cell-ref parent-p t)) - ;; Alter the copied tree so each cell appears to be newly created. - (kview:map-tree - (function - (lambda (view) - (kcell-view:set-cell - (kcell:create nil (kview:id-increment view))))) - kview)) - -(defun kotl-mode:copy-to-buffer (cell-ref buffer invisible-flag) - "Copy outline tree rooted at CELL-REF to a non-koutline BUFFER. -Invisible text is expanded and included in the copy only if INVISIBLE-FLAG is -non-nil. The tree is inserted before point in BUFFER. Use \"0\" to copy the -whole outline buffer." - (interactive - (let ((label-default (kcell-view:label))) - (hargs:iform-read - '(interactive - (list - (hargs:read "Copy tree without attributes: (0 for whole outline) " - nil label-default nil 'kcell) - (read-buffer "To buffer: " - (save-window-excursion - (if (one-window-p) - (select-frame (next-frame)) - (other-window 1)) - (buffer-name)) - t) - (y-or-n-p "Copy invisible text? ")))))) - (message "") ;; Erase last interactive prompt, if any. - (setq buffer (get-buffer-create buffer)) - (if (equal cell-ref "0") - (hypb:insert-region buffer (point-min) (point-max) invisible-flag) - (let (start end) - (save-excursion - (kotl-mode:goto-cell cell-ref t) - (save-excursion (beginning-of-line) (setq start (point))) - (setq end (kotl-mode:tree-end))) - (hypb:insert-region buffer start end invisible-flag)))) - -(defun kotl-mode:move-after (from-cell-ref to-cell-ref child-p - &optional copy-p fill-p) - "Move tree rooted at FROM-CELL-REF to follow tree rooted at TO-CELL-REF. -If prefix arg CHILD-P is non-nil, make FROM-CELL-REF the first child of -TO-CELL-REF, otherwise make it the sibling following TO-CELL-REF. -With optional COPY-P, copies tree rather than moving it. - -Leave point at original location but return the tree's new start point." - (interactive - (let* ((label (kcell-view:label)) - (hargs:defaults (list label label))) - (append - (hargs:iform-read - (list - 'interactive - (format "*+KMove tree: \n+KMove tree <%%s> to follow as %s of cell: " - (if current-prefix-arg "child" "sibling")))) - (list current-prefix-arg)))) - (if (and (not copy-p) (equal from-cell-ref to-cell-ref)) - (error "(kotl-mode:move-after): Can't move tree after itself")) - (let* ((orig (set-marker (make-marker) (point))) - (label-sep-len (kview:label-separator-length kview)) - (move-to-point (set-marker - (make-marker) - (kotl-mode:goto-cell to-cell-ref t))) - (to-label (kcell-view:label)) - (to-indent (kcell-view:indent nil label-sep-len)) - (from-label (progn (kotl-mode:goto-cell from-cell-ref t) - (kcell-view:label))) - (from-indent (kcell-view:indent nil label-sep-len)) - (start (kotl-mode:tree-start)) - (end (kotl-mode:tree-end)) - (sib-id (if (= 0 (kotl-mode:forward-cell 1)) - (kcell-view:idstamp))) - new-tree-start) - ;; - ;; We can't move a tree to a point within itself, so if that is the case - ;; and this is not a copy operation, signal an error. - (if (and (not copy-p) (>= move-to-point start) (<= move-to-point end)) - (error "(kotl-mode:move-after): Can't move tree <%s> to within itself" - from-label)) - ;; - ;; If tree to move has a sibling, point is now at the start of the - ;; sibling cell. Mark its label with a property which will be deleted - ;; whenever the cell label is renumbered. This tells us whether or not - ;; to renumber the sibling separately from the tree to move. - (if sib-id - ;; Move to middle of label and insert klabel-original temp property. - (progn (goto-char (- (point) label-sep-len 3)) - (kproperty:set 'klabel-original t))) - ;; - ;; Position for insertion before deletion of tree-to-move from old - ;; position, in case old position precedes new one. - ;; Skip past either cell or tree at move-to-point. - (goto-char move-to-point) - (if child-p - ;; Move to insert position for first child of to-cell-ref. - (progn (goto-char (kcell-view:end)) - (setq to-label (klabel:child to-label) - to-indent (+ to-indent (kview:level-indent kview)))) - ;; Move to after to-cell-ref's tree for insertion as following sibling. - (goto-char (kotl-mode:tree-end)) - (setq to-label (klabel:increment to-label))) - ;; - ;; Insert tree-to-move at new location - ;; - (kview:move start end (point) from-indent to-indent copy-p - (or fill-p kotl-mode:refill-flag)) - ;; - ;; Ensure that point is within editable region of cell with to-label. - (kotl-mode:to-valid-position) - (setq new-tree-start (point)) - ;; - ;; Update current cell and new siblings' labels within view. - (klabel-type:update-labels to-label) - ;; - (if copy-p - nil - ;; - ;; Move to sibling of tree-to-move within view and update labels within - ;; view of tree-to-move's original siblings. - (if sib-id - (progn (kotl-mode:goto-cell sib-id t) - ;; Sibling labels may have already been updated if tree was - ;; moved somewhere preceding its siblings. - (let ((label-middle (- (point) label-sep-len 2))) - (if (kproperty:get label-middle 'klabel-original) - (klabel-type:update-labels from-label)))))) - ;; - (goto-char orig) - ;; - ;; Ensure that point is within editable region of a cell. - (kotl-mode:to-valid-position) - ;; - (set-marker orig nil) - (set-marker move-to-point nil) - new-tree-start)) - -(defun kotl-mode:move-before (from-cell-ref to-cell-ref parent-p - &optional copy-p fill-p) - "Move tree rooted at FROM-CELL-REF to precede tree rooted at TO-CELL-REF. -If prefix arg PARENT-P is non-nil, make FROM-CELL-REF the first child of -TO-CELL-REF's parent, otherwise make it the preceding sibling of TO-CELL-REF. -With optional COPY-P, copies tree rather than moving it. - -Leave point at original location but return the tree's new start point." - (interactive - (let* ((label (kcell-view:label)) - (hargs:defaults (list label label))) - (append - (hargs:iform-read - (list 'interactive - (format "*+KMove tree: \n+KMove tree <%%s> to be %s of cell: " - (if current-prefix-arg "first child of parent" - "preceding sibling")))) - (list current-prefix-arg)))) - (if (and (not copy-p) (equal from-cell-ref to-cell-ref)) - (error "(kotl-mode:move-before): Can't move tree before itself")) - (let* ((orig (set-marker (make-marker) (point))) - (label-sep-len (kview:label-separator-length kview)) - (move-to-point (set-marker - (make-marker) - (kotl-mode:goto-cell to-cell-ref t))) - (to-label (kcell-view:label)) - (to-indent (kcell-view:indent nil label-sep-len)) - (from-label (progn (kotl-mode:goto-cell from-cell-ref t) - (kcell-view:label))) - (from-indent (kcell-view:indent nil label-sep-len)) - (start (kotl-mode:tree-start)) - (end (kotl-mode:tree-end)) - (sib-id (if (= 0 (kotl-mode:forward-cell 1)) - (kcell-view:idstamp))) - new-tree-start) - ;; - ;; We can't move a tree to a point within itself, so if that is the case - ;; and this is not a copy operation, signal an error. - (if (and (not copy-p) (>= move-to-point start) (<= move-to-point end)) - (error "(kotl-mode:move-before): Can't move tree <%s> to within itself" - from-label)) - ;; - ;; If tree to move has a sibling, point is now at the start of the - ;; sibling cell. Mark its label with a property which will be deleted - ;; whenever the cell label is renumbered. This tells us whether or not - ;; to renumber the sibling separately from the tree to move. - (if sib-id - ;; Move to middle of label and insert klabel-original temp property. - (progn (goto-char (- (point) label-sep-len 3)) - (kproperty:set 'klabel-original t))) - ;; - ;; Position for insertion at succeeding-tree, before deletion of - ;; tree-to-move from old position, in case old position precedes new one. - (goto-char move-to-point) - (if parent-p - ;; Move to insert position for first child of to-cell-ref's parent. - (if (kcell-view:parent nil label-sep-len) - (progn (setq to-label (klabel:child (kcell-view:label))) - (goto-char (kcell-view:end))) - (error "(kotl-mode:move-before): to-cell-ref's parent not in current view")) - ;; Move to before to-cell-ref for insertion as preceding sibling. - (goto-char (kotl-mode:tree-start))) - ;; - ;; Insert tree-to-move at new location - ;; - (kview:move start end (point) from-indent to-indent copy-p - (or fill-p kotl-mode:refill-flag)) - ;; - ;; Ensure that point is within editable region of root of tree just moved. - (kotl-mode:to-valid-position) - (setq new-tree-start (point)) - ;; - ;; Update current cell and new siblings' labels within view. - (klabel-type:update-labels to-label) - ;; - (if copy-p - nil - ;; - ;; Move to sibling of tree-to-move within view and update labels within - ;; view of tree-to-move's original siblings. - (if sib-id - (progn - (kotl-mode:goto-cell sib-id t) - ;; Sibling labels may have already been updated if tree was - ;; moved somewhere preceding its siblings. - (let ((label-middle (- (point) label-sep-len 2))) - (if (kproperty:get label-middle 'klabel-original) - (klabel-type:update-labels from-label)))))) - ;; - (goto-char orig) - ;; - ;; Ensure that point is within editable region of a cell. - (kotl-mode:to-valid-position) - ;; - (set-marker orig nil) - (set-marker move-to-point nil) - new-tree-start)) - -(defun kotl-mode:yank (&optional arg) - "Reinsert the last stretch of killed text. -More precisely, reinsert the stretch of killed text most recently -killed OR yanked. Put point at end, and set mark at beginning. -With just C-u as argument, same but put point at beginning (and mark at end). -With argument N, reinsert the Nth most recently killed stretch of killed -text. -See also the command \\[kotl-mode:yank-pop]." - (interactive "*P") - (push-mark (point)) - (let* ((yank-text (current-kill (cond - ((listp arg) 0) - ((eq arg '-) -1) - (t (1- arg))))) - (indent (kcell-view:indent)) - (indent-str (make-string indent ?\ ))) - ;; Convert all occurrences of newline to newline + cell indent. - ;; Then insert into buffer. - (insert (hypb:replace-match-string - "[\n\r]" yank-text (concat "\\0" indent-str)))) - (if (consp arg) - ;; This is like exchange-point-and-mark, but doesn't activate the mark. - ;; It is cleaner to avoid activation, even though the command - ;; loop would deactivate the mark because we inserted text. - (goto-char (prog1 (mark t) - (set-marker (hypb:mark-marker t) (point))))) - nil) - -(defun kotl-mode:yank-pop (arg) - "Replace just-yanked stretch of killed text with a different stretch. -This command is allowed only immediately after a `yank' or a `yank-pop'. -At such a time, the region contains a stretch of reinserted -previously-killed text. `yank-pop' deletes that text and inserts in its -place a different stretch of killed text. - -With no argument, the previous kill is inserted. -With argument N, insert the Nth previous kill. -If N is negative, this is a more recent kill. - -The sequence of kills wraps around, so that after the oldest one -comes the newest one." - (interactive "*p") - (if (not (eq last-command 'kotl-mode:yank)) - (error "Previous command was not a yank")) - (setq this-command 'kotl-mode:yank) - (let ((before (< (point) (mark t)))) - (delete-region (point) (mark t)) - (set-marker (hypb:mark-marker t) (point) (current-buffer)) - (let* ((yank-text (current-kill arg)) - (indent (kcell-view:indent)) - (indent-str (make-string indent ?\ ))) - ;; Convert all occurrences of newline to newline + cell indent. - ;; Then insert into buffer. - (insert (hypb:replace-match-string - "[\n\r]" yank-text (concat "\\0" indent-str)))) - (if before - ;; This is like exchange-point-and-mark, but doesn't activate the mark. - ;; It is cleaner to avoid activation, even though the command - ;; loop would deactivate the mark because we inserted text. - (goto-char (prog1 (mark t) - (set-marker (hypb:mark-marker t) (point) (current-buffer)))))) - nil) - -;;; ------------------------------------------------------------------------ -;;; Movement -;;; ------------------------------------------------------------------------ - -;;; Cursor and keypad key functions aliases for XEmacs. -(if (not (string-match "XEmacs\\|Lucid" emacs-version)) - nil - (fset 'kotl-mode:fkey-backward-char 'kotl-mode:backward-char) - (fset 'kotl-mode:fkey-forward-char 'kotl-mode:forward-char) - (fset 'kotl-mode:fkey-next-line 'kotl-mode:next-line) - (fset 'kotl-mode:fkey-previous-line 'kotl-mode:previous-line) - (fset 'kotl-mode:deprecated-scroll-down 'kotl-mode:scroll-down) - (fset 'kotl-mode:deprecated-scroll-up 'kotl-mode:scroll-up) - (fset 'kotl-mode:deprecated-bob 'kotl-mode:beginning-of-buffer) - (fset 'kotl-mode:deprecated-eob 'kotl-mode:end-of-buffer)) - -(defun kotl-mode:back-to-indentation () - "Move point to the first non-read-only non-whitespace character on this line." - (interactive) - (setq zmacs-region-stays t) ;; Maintain region highlight for XEmacs. - (back-to-indentation) - (kotl-mode:to-valid-position)) - -(defun kotl-mode:backward-cell (arg) - "Move to prefix ARGth prior visible cell (same level) within current view. -Return number of cells left to move." - (interactive "p") - (setq zmacs-region-stays t) ;; Maintain region highlight for XEmacs. - (if (< arg 0) - (kotl-mode:forward-cell (- arg)) - (let ((prior (= arg 0)) - (label-sep-len (kview:label-separator-length kview))) - (while (and (> arg 0) (setq prior (kcell-view:backward t label-sep-len))) - (setq arg (1- arg))) - (if (or prior (not (interactive-p))) - arg - (error "(kotl-mode:backward-cell): No prior cell at same level"))))) - -(defun kotl-mode:backward-char (&optional arg) - "Move point backward ARG (or 1) characters and return point." - (interactive "p") - (setq zmacs-region-stays t) ;; Maintain region highlight for XEmacs. - (or arg (setq arg 1)) - (if (>= arg 0) - (while (> arg 0) - (cond ((kotl-mode:bobp) - (error "(kotl-mode:backward-char): Beginning of buffer")) - ((kotl-mode:bocp) - (if (kcell-view:previous) - (kotl-mode:end-of-cell))) - ((kotl-mode:bolp) - (if (re-search-backward "[\n\r]" nil t) - (kotl-mode:to-valid-position t))) - (t (backward-char))) - (setq arg (1- arg))) - (kotl-mode:forward-char (- arg))) - (point)) - -(defun kotl-mode:backward-paragraph (&optional arg) - "Move backward to start of paragraph. -With arg N, do it N times; negative arg -N means move forward N paragraphs. -Return point. - -A paragraph start is the beginning of a line which is a -`first-line-of-paragraph' or which is ordinary text and follows a -paragraph-separating line. - -See `forward-paragraph' for more information." - (interactive "p") - (setq arg (prefix-numeric-value arg) - zmacs-region-stays t);; Maintain region highlight for XEmacs. - (kotl-mode:forward-paragraph (- arg))) - -(fset 'kotl-mode:backward-para 'kotl-mode:backward-paragraph) - -(defun kotl-mode:backward-sentence (&optional arg) - "Move point backward ARG (or 1) sentences and return point." - (interactive "p") - (setq zmacs-region-stays t) ;; Maintain region highlight for XEmacs. - (let* ((label-sep-len (kview:label-separator-length kview)) - ;; Setting fill prefix makes sentence commands properly recognize - ;; indented paragraphs. - (fill-prefix (make-string (kcell-view:indent nil label-sep-len) ?\ ))) - (if (kotl-mode:bobp) - (error "(kotl-mode:backward-sentence): First sentence") - (if (and (kotl-mode:bocp) (kcell-view:previous nil label-sep-len)) - (goto-char (kcell-view:end-contents))) - (or arg (setq arg 1)) - (save-restriction - (if (= arg 1) - (narrow-to-region - (- (kcell-view:start nil label-sep-len) - (kcell-view:indent nil label-sep-len)) - (kcell-view:end-contents))) - (unwind-protect - (let ((opoint (point))) - (backward-sentence arg) - (if (= opoint (point)) - (progn (kcell-view:previous nil label-sep-len) - (backward-sentence arg)))) - (kotl-mode:to-valid-position t))))) - (point)) - -(defun kotl-mode:backward-word (&optional arg) - "Move point backward ARG (or 1) words and return point." - (interactive "p") - (setq zmacs-region-stays t) ;; Maintain region highlight for XEmacs. - (or arg (setq arg 1)) - (if (>= arg 0) - (while (> arg 0) - (cond ((kotl-mode:bobp) (setq arg 0)) - ((kotl-mode:bocp) - (beginning-of-line) - (kotl-mode:to-valid-position t))) - (unwind-protect - (backward-word 1) - (kotl-mode:to-valid-position t)) - (setq arg (1- arg))) - (kotl-mode:forward-word (- arg))) - (point)) - -(defun kotl-mode:beginning-of-buffer () - "Move point to beginning of buffer and return point." - (interactive) - (setq zmacs-region-stays t) ;; Maintain region highlight for XEmacs. - (goto-char (point-min)) - ;; To move to cell start. - (goto-char (kcell-view:start))) - -(defun kotl-mode:beginning-of-cell (&optional arg) - "Move point to beginning of current or ARGth - 1 prior cell and return point." - (interactive "p") - (setq zmacs-region-stays t) ;; Maintain region highlight for XEmacs. - (or arg (setq arg 1)) - (or (integer-or-marker-p arg) - (error "(kotl-mode:beginning-of-cell): Wrong type arg, integer-or-marker, `%s'" arg)) - (if (= arg 1) - (goto-char (kcell-view:start)) - (kotl-mode:backward-cell (1- arg))) - (point)) - -;;; Avoid XEmacs byte-compiler bug which inserts nil for calls to this -;;; function if named kotl-mode:beginning-of-line. -;;; -(defun kotl-mode:start-of-line (&optional arg) - "Move point to beginning of current or ARGth - 1 line and return point." - (interactive "p") - (setq zmacs-region-stays t) ;; Maintain region highlight for XEmacs. - (or arg (setq arg 1)) - (or (integer-or-marker-p arg) - (error "(kotl-mode:start-of-line): Wrong type arg, integer-or-marker, `%s'" arg)) - (forward-line (1- arg)) - (if (eolp) - nil - (forward-char (prog1 (kcell-view:indent) - (beginning-of-line)))) - (point)) - -;;; This ensures that the key bound to `beginning-of-line' is replaced in -;;; kotl-mode. -(fset 'kotl-mode:beginning-of-line 'kotl-mode:start-of-line) - -(defun kotl-mode:beginning-of-tree () - "Move point to the level 1 root of the current cell's tree. -Leave point at the start of the cell." - (interactive) - (setq zmacs-region-stays t) ;; Maintain region highlight for XEmacs. - (let ((label-sep-len (kview:label-separator-length kview))) - (if (/= (kcell-view:level nil label-sep-len) 1) - ;; Enable user to return to this previous position if desired. - (push-mark nil 'no-msg)) - (while (and (/= (kcell-view:level nil label-sep-len) 1) - (kcell-view:parent nil label-sep-len))) - (kotl-mode:beginning-of-cell))) - -(defun kotl-mode:down-level (arg) - "Move down prefix ARG levels lower within current tree." - (interactive "p") - (setq zmacs-region-stays t) ;; Maintain region highlight for XEmacs. - (if (< arg 0) - (kotl-mode:up-level (- arg)) - ;; Enable user to return to this previous position if desired. - (push-mark nil 'no-msg) - (let ((child)) - (while (and (> arg 0) (kcell-view:child)) - (or child (setq child t)) - (setq arg (1- arg))) - ;; Signal an error if couldn't move down at least 1 child level. - (or child - (progn - (goto-char (hypb:mark t)) - (pop-mark) - (error "(kotl-mode:down-level): No child level to which to move") - ))))) - -(defun kotl-mode:end-of-buffer () - "Move point to end of buffer and return point." - (interactive) - (setq zmacs-region-stays t) ;; Maintain region highlight for XEmacs. - (goto-char (point-max)) - ;; To move to cell end. - (kotl-mode:to-valid-position t) - (point)) - -(defun kotl-mode:end-of-cell (&optional arg) - "Move point to end of current or ARGth - 1 succeeding cell and return point." - (interactive "p") - (setq zmacs-region-stays t) ;; Maintain region highlight for XEmacs. - (or arg (setq arg 1)) - (or (integer-or-marker-p arg) - (error "(kotl-mode:end-of-cell): Wrong type arg, integer-or-marker, `%s'" arg)) - (if (= arg 1) - (goto-char (kcell-view:end-contents)) - (kotl-mode:forward-cell (1- arg))) - (point)) - -;;; Avoid XEmacs byte-compiler bug which inserts nil for calls to this -;;; function if named kotl-mode:end-of-line. -;;; -(defun kotl-mode:finish-of-line (&optional arg) - "Move point to end of current or ARGth - 1 line and return point." - (interactive "p") - (setq zmacs-region-stays t) ;; Maintain region highlight for XEmacs. - (or arg (setq arg 1)) - (or (integer-or-marker-p arg) - (error "(kotl-mode:finish-of-line): Wrong type arg, integer-or-marker, `%s'" arg)) - (forward-line (1- arg)) - (end-of-line) - ;; May have to move backwards to before label if support labels - ;; at end of cells. - (point)) - -(defalias 'kotl-mode:end-of-line 'kotl-mode:finish-of-line) - -(defun kotl-mode:end-of-tree () - "Move point to the last cell in tree rooted at the current cell. -Leave point at the start of the cell." - (interactive) - (setq zmacs-region-stays t) ;; Maintain region highlight for XEmacs. - ;; Enable user to return to this previous position if desired. - (push-mark nil 'no-msg) - (let ((label-sep-len (kview:label-separator-length kview))) - (if (kcell-view:forward nil label-sep-len) - ;; Move to cell preceding start of next tree. - (kcell-view:previous nil label-sep-len) - ;; Otherwise, no next tree, so move until find last cell in tree. - (let ((cell-indent (kcell-view:indent nil label-sep-len)) - (end-point (point))) - ;; Terminate when no further cells or when reach a cell at an equal - ;; or higher level in the outline than the first cell that we - ;; processed. - (while (and (kcell-view:next nil label-sep-len) - (> (kcell-view:indent nil label-sep-len) cell-indent)) - (setq end-point (point))) - (goto-char end-point))) - (kotl-mode:beginning-of-cell))) - -(defun kotl-mode:first-sibling () - "Move point to the first sibling of the present cell. -Leave point at the start of the cell or at its present position if it is -already within the first sibling cell." - (interactive) - (setq zmacs-region-stays t) ;; Maintain region highlight for XEmacs. - (let ((label-sep-len (kview:label-separator-length kview))) - (if (save-excursion (kcell-view:backward nil label-sep-len)) - ;; Enable user to return to this previous position if desired. - (push-mark nil 'no-msg)) - (while (kcell-view:backward nil label-sep-len)))) - -(defun kotl-mode:forward-cell (arg) - "Move to prefix ARGth following cell (same level) within current view. -Return number of cells left to move." - (interactive "p") - (setq zmacs-region-stays t) ;; Maintain region highlight for XEmacs. - (if (< arg 0) - (kotl-mode:backward-cell (- arg)) - (let ((next (= arg 0)) - (label-sep-len (kview:label-separator-length kview))) - (while (and (> arg 0) (setq next (kcell-view:forward t label-sep-len))) - (setq arg (1- arg))) - (if (or next (not (interactive-p))) - arg - (error "(kotl-mode:forward-cell): No following cell at same level"))))) - -(defun kotl-mode:forward-char (&optional arg) - "Move point forward ARG (or 1) characters and return point." - (interactive "p") - (setq zmacs-region-stays t) ;; Maintain region highlight for XEmacs. - (or arg (setq arg 1)) - (if (>= arg 0) - (while (> arg 0) - (cond ((and (kotl-mode:eolp) (kotl-mode:last-line-p)) - (error "(kotl-mode:forward-char): End of buffer")) - ((kotl-mode:eocp) - (skip-chars-forward "\n\r") - (kotl-mode:start-of-line)) - ((kotl-mode:eolp) - (forward-char) - (kotl-mode:start-of-line)) - (t (forward-char))) - (setq arg (1- arg))) - (kotl-mode:backward-char (- arg))) - (point)) - -(defun kotl-mode:forward-paragraph (&optional arg) - "Move point forward until after the last character of the current paragraph. -With arg N, do it N times; negative arg -N means move backward N paragraphs. -Return point. - -A line which `paragraph-start' matches either separates paragraphs -\(if `paragraph-separate' matches it also) or is the first line of a paragraph. -A paragraph end is one character before the beginning of a line which is not -part of the paragraph, or the end of the buffer." - (interactive "p") - (setq arg (prefix-numeric-value arg) - zmacs-region-stays t);; Maintain region highlight for XEmacs. - (if (< arg 0) - (progn - (if (kotl-mode:bocp) (setq arg (1- arg))) - (while (< arg 0) - (start-of-paragraph-text) - (setq arg (1+ arg)))) - (while (> arg 0) - (end-of-paragraph-text) - (setq arg (1- arg)))) - (kotl-mode:to-valid-position) - (point)) - -(fset 'kotl-mode:forward-para 'kotl-mode:forward-paragraph) - -(defun kotl-mode:forward-sentence (&optional arg) - "Move point forward ARG (or 1) sentences and return point." - (interactive "P") - (setq zmacs-region-stays t) ;; Maintain region highlight for XEmacs. - (let* ((label-sep-len (kview:label-separator-length kview)) - ;; Setting fill prefix makes sentence commands properly recognize - ;; indented paragraphs. - (fill-prefix (make-string (kcell-view:indent nil label-sep-len) ?\ ))) - (if (kotl-mode:eobp) - (error "(kotl-mode:forward-sentence): Last sentence") - (if (kotl-mode:eocp) (kcell-view:next nil label-sep-len)) - (or arg (setq arg 1)) - (save-restriction - (if (= arg 1) - (narrow-to-region - (- (kcell-view:start nil label-sep-len) - (kcell-view:indent nil label-sep-len)) - (kcell-view:end-contents))) - (unwind-protect - (let ((opoint (point))) - (forward-sentence arg) - (if (= opoint (point)) - (progn (kcell-view:next nil label-sep-len) - (forward-sentence arg)))) - (kotl-mode:to-valid-position))))) - (point)) - -(defun kotl-mode:forward-word (&optional arg) - "Move point forward ARG (or 1) words and return point." - (interactive "p") - (setq zmacs-region-stays t) ;; Maintain region highlight for XEmacs. - (or arg (setq arg 1)) - (if (>= arg 0) - (while (> arg 0) - (cond ((kotl-mode:eobp) (setq arg 0)) - ((kotl-mode:eocp) - (skip-chars-forward "\n\r") - (kotl-mode:start-of-line))) - (unwind-protect - (forward-word 1) - (kotl-mode:to-valid-position)) - ;; If point is at beginning of a cell after moving forward a word, - ;; then we moved over something other than a word (some - ;; punctuation or an outline autonumber); therefore, leave counter as - ;; is in order to move forward over next word. - (or (kotl-mode:bocp) - (setq arg (1- arg)))) - (kotl-mode:backward-word (- arg))) - (point)) - -(defun kotl-mode:goto-cell (cell-ref &optional error-p) - "Move point to start of cell given by CELL-REF. (See `kcell:ref-to-id'.) -Return point iff CELL-REF is found within current view. -With a prefix argument, CELL-REF is assigned the argument value for use -as an idstamp. - -Optional second arg, ERROR-P, non-nil means signal an error if CELL-REF is -not found within current view. Will signal same error if called -interactively when CELL-REF is not found." - (interactive - (list (if current-prefix-arg - (format "0%d" (prefix-numeric-value current-prefix-arg)) - (read-string "Goto cell label or id: ")))) - (setq cell-ref - (or (kcell:ref-to-id cell-ref) - (error "(kotl-mode:goto-cell): Invalid cell reference, `%s'" cell-ref))) - (let* ((opoint (point)) - (found) - cell-id kvspec) - (if (= ?| (aref cell-ref 0)) - ;; This is a standalone view spec, not a cell reference. - (progn (kvspec:activate cell-ref) (setq found (point))) - - ;; !! Remove any relative specs and view specs from - ;; cell-ref to form cell-id. Really should account for relative - ;; specs here, but we don't yet support them. - (if (string-match "\\(\\.[a-zA-Z]+\\)?\\([|:].*\\)\\|\\.[a-zA-Z]+" - cell-ref) - (setq cell-id (substring cell-ref 0 (match-beginning 0)) - kvspec (if (match-beginning 2) - (substring - cell-ref (match-beginning 2) (match-end 2)))) - (setq cell-id cell-ref kvspec nil)) - - (goto-char (point-min)) - (cond ((= ?0 (aref cell-id 0)) - ;; is an idstamp - (if (kview:goto-cell-id cell-id) - (setq found (point)))) - ;; is a label - ((re-search-forward - (format "\\([\n\r][\n\r]\\|\\`\\)[ ]*%s%s" - (regexp-quote cell-id) - (regexp-quote (kview:label-separator kview))) - nil t) - (setq found (point))) - ;; no match - (t (goto-char opoint) - nil)) - (if (and (not found) (or error-p (interactive-p))) - (error "(kotl-mode:goto-cell): No `%s' cell in this view" cell-ref) - ;; Activate any viewspec associated with cell-ref. - (if kvspec (kvspec:activate kvspec)))) - found)) - -(defun kotl-mode:head-cell () - "Move point to the start of the first visible cell at the same level as current cell. -If at head cell already, do nothing and return nil." - (interactive "p") - (setq zmacs-region-stays t) ;; Maintain region highlight for XEmacs. - (let ((moved) - (label-sep-len (kview:label-separator-length kview))) - (while (kcell-view:backward t label-sep-len) - (setq moved t)) - moved)) - -(defun kotl-mode:last-sibling () - "Move point to the last sibling of the present cell. -Leave point at the start of the cell or at its present position if it is -already within the last sibling cell." - (interactive) - (setq zmacs-region-stays t) ;; Maintain region highlight for XEmacs. - (let ((label-sep-len (kview:label-separator-length kview))) - (if (save-excursion (kcell-view:forward nil label-sep-len)) - ;; Enable user to return to this previous position if desired. - (push-mark nil 'no-msg)) - (while (kcell-view:forward nil label-sep-len)))) - -(defun kotl-mode:mark-paragraph () - "Put point at beginning of this paragraph, mark at end. -The paragraph marked is the one that contains point or follows point." - (interactive) - (forward-paragraph 1) - (kotl-mode:to-valid-position t) - (hypb:push-mark nil t t) - (backward-paragraph 1) - (kotl-mode:to-valid-position)) - -(defun kotl-mode:mark-whole-buffer () - "Put point at first editable character in buffer and mark at the last such character." - (interactive) - (hypb:push-mark (point)) - (kotl-mode:end-of-buffer) - (hypb:push-mark (point) nil t) - (kotl-mode:beginning-of-buffer)) - -(defun kotl-mode:next-cell (arg) - "Move to prefix ARGth next cell (any level) within current view." - (interactive "p") - (setq zmacs-region-stays t) ;; Maintain region highlight for XEmacs. - (if (< arg 0) - (kotl-mode:previous-cell (- arg)) - (let ((next (= arg 0)) - (label-sep-len (kview:label-separator-length kview))) - (while (and (> arg 0) (setq next (kcell-view:next t label-sep-len))) - (setq arg (1- arg))) - (if next - arg - (error "(kotl-mode:next-cell): Last cell"))))) - -(defun kotl-mode:next-line (arg) - "Move point to ARGth next line and return point." - (interactive "p") - (setq zmacs-region-stays t) ;; Maintain region highlight for XEmacs. - (kotl-mode:set-temp-goal-column) - (let ((orig-arg arg)) - (cond ((> arg 0) - (while (and (> arg 0) (= 0 (forward-line 1))) - (cond ((kotl-mode:eobp) - (forward-line -1) - (goto-char (kcell-view:end-contents)) - (and (interactive-p) (= orig-arg arg) - (message "(kotl-mode:next-line): Last line") (beep)) - (setq arg 0) - ) - ((looking-at "^$");; blank line between cells - nil);; Don't count this line. - (t (setq arg (1- arg))))) - (kotl-mode:line-move 0) - (kotl-mode:to-valid-position) - ) - ((< arg 0) - (kotl-mode:previous-line (- arg))) - (t))) - (setq this-command 'next-line) - (point)) - -(defun kotl-mode:next-tree () - "Move past current tree to next tree, or to last cell in tree if no next tree. -Return non-nil iff there is a next tree within this koutline." - (let ((start-indent (kcell-view:indent)) - (label-sep-len (kview:label-separator-length kview)) - (same-tree t)) - (while (and (kcell-view:next nil label-sep-len) - (setq same-tree (< start-indent - (kcell-view:indent nil label-sep-len))))) - (not same-tree))) - -(defun kotl-mode:previous-line (arg) - "Move point to ARGth previous line and return point." - (interactive "p") - (setq zmacs-region-stays t) ;; Maintain region highlight for XEmacs. - (kotl-mode:set-temp-goal-column) - (cond ((> arg 0) - (while (and (> arg 0) (= 0 (forward-line -1))) - (cond ((kotl-mode:bobp) - (kotl-mode:beginning-of-cell) - (setq arg 0)) - ((looking-at "^$") ;; blank line between cells - nil) ;; Don't count this line. - (t (setq arg (1- arg))))) - (kotl-mode:line-move 0) - (kotl-mode:to-valid-position) - ) - ((< arg 0) - (kotl-mode:next-line (- arg))) - (t)) - (setq this-command 'previous-line) - (point)) - -(defun kotl-mode:previous-cell (arg) - "Move to prefix ARGth previous cell (any level) within current view." - (interactive "p") - (setq zmacs-region-stays t) ;; Maintain region highlight for XEmacs. - (if (< arg 0) - (kotl-mode:next-cell (- arg)) - (let ((previous (= arg 0)) - (label-sep-len (kview:label-separator-length kview))) - (while (and (> arg 0) (setq previous - (kcell-view:previous t label-sep-len))) - (setq arg (1- arg))) - (if previous - arg - (error "(kotl-mode:previous-cell): First cell"))))) - -(defun kotl-mode:scroll-down (arg) - "Scroll text of current window downward ARG lines; or a windowful if no ARG." - (interactive "P") - (setq zmacs-region-stays t) ;; Maintain region highlight for XEmacs. - (scroll-down arg) - (kotl-mode:to-valid-position t)) - -(defun kotl-mode:scroll-up (arg) - "Scroll text of current window upward ARG lines; or a windowful if no ARG." - (interactive "P") - (setq zmacs-region-stays t) ;; Maintain region highlight for XEmacs. - (scroll-up arg) - (kotl-mode:to-valid-position)) - -(defun kotl-mode:tail-cell () - "Move point to the start of the last visible cell at the same level as current cell and return t. -If at tail cell already, do nothing and return nil." - (interactive "p") - (setq zmacs-region-stays t) ;; Maintain region highlight for XEmacs. - (let ((moved) - (label-sep-len (kview:label-separator-length kview))) - (while (kcell-view:forward t label-sep-len) - (setq moved t)) - moved)) - -(defun kotl-mode:up-level (arg) - "Move up prefix ARG levels higher in current outline view." - (interactive "p") - (setq zmacs-region-stays t) ;; Maintain region highlight for XEmacs. - (if (< arg 0) - (kotl-mode:down-level (- arg)) - ;; Enable user to return to this previous position if desired. - (push-mark nil 'no-msg) - (let ((parent) - (label-sep-len (kview:label-separator-length kview)) - result) - (while (and (> arg 0) (setq result (kcell-view:parent t label-sep-len))) - (or parent (setq parent result)) - (setq arg (if (eq result 0) 0 (1- arg)))) - ;; Signal an error if couldn't move up at least 1 parent level. - (or (and parent (not (eq parent 0))) - (progn - (goto-char (hypb:mark t)) - (pop-mark) - (error "(kotl-mode:up-level): No parent level to which to move") - ))))) - -;;; ------------------------------------------------------------------------ -;;; Predicates -;;; ------------------------------------------------------------------------ - -(defun kotl-mode:bobp () - "Return point if at the start of the first cell in kview, else nil." - (interactive) - (or (bobp) - (and (not (save-excursion (re-search-backward "[\n\r]" nil t))) - (kotl-mode:bolp)))) - -(defun kotl-mode:bocp () - "Return point if at beginning of a kcell, else nil." - (and (kotl-mode:bolp) - (let ((begin-point (kcell-view:plist-point)) - (bol)) - (and begin-point - (save-excursion - ;; If first line-begin is less than cell begin point, - ;; then we know we are on the first line of the cell. - (if (setq bol (re-search-backward "^" nil t)) - (<= bol begin-point))))) - (point))) - -(defun kotl-mode:bolp () - "Return point if at beginning of a kview line, else nil." - (if (= (current-column) (kcell-view:indent)) - (point))) - -(defun kotl-mode:buffer-empty-p () - "Return non-nil iff there are no outline cells within current buffer." - (save-excursion - (goto-char (point-min)) - (looking-at "[\n\r]*\\'"))) - -(defun kotl-mode:eobp () - "Return point if after the end of the last cell in kview, else nil." - (interactive) - (if (looking-at "^[\n\r]*\\'") (point))) - -(defun kotl-mode:eocp () - "Return point if at the end of a kview cell, else nil." - (or (eobp) - (looking-at "[\n\r]+\\'") - (and (eolp) - (save-excursion - (skip-chars-forward "\n\r") - (kotl-mode:start-of-line) - (kotl-mode:bocp))))) - -(fset 'kotl-mode:eolp 'eolp) - -(defun kotl-mode:first-cell-p () - "Return t iff point is on the first cell of the outline." - (save-excursion (not (kcell-view:previous)))) - -(fset 'kotl-mode:first-line-p 'first-line-p) - -(defun kotl-mode:last-cell-p () - "Return t iff point is on the last cell of the outline." - (save-excursion (not (kcell-view:next)))) - -(defun kotl-mode:last-line-p () - "Return t iff point is on the last line of the outline." - (save-excursion - (kotl-mode:finish-of-line) - (looking-at "\n*\\'"))) - -;;; ------------------------------------------------------------------------ -;;; Smart Key Support -;;; ------------------------------------------------------------------------ - - -(defun kotl-mode:action-key () - "Collapses, expands, links to, and scrolls through koutline cells. -Invoked via a key press when in kotl-mode. It assumes that its caller has -already checked that the key was pressed in an appropriate buffer and has -moved the cursor to the selected buffer. - -If key is pressed: - (1) at the end of buffer, uncollapse and unhide all cells in view; - (2) within a cell, if its subtree is hidden then show it, - otherwise hide it; - (3) between cells or within the read-only indentation region to the left of - a cell, then move point to prior location and begin creation of a - klink to some other outline cell; hit the Action Key twice to select the - link referent cell; - (4) anywhere else, scroll up a windowful." - (interactive) - (cond ((kotl-mode:eobp) (kotl-mode:show-all)) - ((kotl-mode:eolp) (smart-scroll-up)) - ((not (kview:valid-position-p)) - (if (markerp action-key-depress-prev-point) - (progn (select-window - (get-buffer-window - (marker-buffer action-key-depress-prev-point))) - (goto-char (marker-position action-key-depress-prev-point)) - (call-interactively 'klink:create)) - (kotl-mode:to-valid-position) - (error "(kotl-mode:action-key): Action Key released at invalid position"))) - (t ;; On a cell line (not at the end of line). - (if (smart-outline-subtree-hidden-p) - (kotl-mode:show-tree (kcell-view:label)) - (kotl-mode:hide-tree (kcell-view:label))))) - (kotl-mode:to-valid-position)) - -(defun kotl-mode:help-key () - "Displays properties of koutline cells, collapses all cells, and scrolls back. -Invoked via an assist-key press when in kotl-mode. It assumes that its caller -has already checked that the assist-key was pressed in an appropriate buffer -and has moved the cursor to the selected buffer. - -If assist-key is pressed: - (1) at the end of buffer, collapse all cells and hide all non-level-one - cells; - (2) on a header line but not at the beginning or end, display properties of - each cell in tree beginning at point; - (3) between cells or within the read-only indentation region to the left of - a cell, then move point to prior location and prompt to move one tree to - a new location in the outline; hit the Action Key twice to select the - tree to move and where to move it; - (4) anywhere else, scroll down a windowful." - (interactive) - (cond ((kotl-mode:eobp) (kotl-mode:overview)) - ((kotl-mode:eolp) (smart-scroll-down)) - ((not (kview:valid-position-p)) - (if (markerp assist-key-depress-prev-point) - (progn (select-window - (get-buffer-window - (marker-buffer assist-key-depress-prev-point))) - (goto-char (marker-position - assist-key-depress-prev-point)) - (call-interactively 'kotl-mode:move-after)) - (kotl-mode:to-valid-position) - (error "(kotl-mode:help-key): Help Key released at invalid position"))) - ((not (bolp)) - ;; On an outline header line but not at the start/end of line, - ;; show attributes for tree at point. - (kotl-mode:cell-help (kcell-view:label) (or current-prefix-arg 2))) - ((smart-scroll-down))) - (kotl-mode:to-valid-position)) - -;;; ------------------------------------------------------------------------ -;;; Structure Editing -;;; ------------------------------------------------------------------------ - -(defun kotl-mode:add-child () - "Add a new cell to current kview as first child of current cell." - (interactive "*") - (kotl-mode:add-cell '(4))) - -(defun kotl-mode:add-parent () - "Add a new cell to current kview as sibling of current cell's parent." - (interactive "*") - (kotl-mode:add-cell -1)) - -(defun kotl-mode:add-cell (&optional relative-level contents plist no-fill) - "Add a cell following current cell at optional RELATIVE-LEVEL with CONTENTS string, attributes in PLIST, a property list, and NO-FILL flag to prevent any filling of CONTENTS. - -Optional prefix arg RELATIVE-LEVEL means add as sibling if nil or >= 0, as -child if equal to universal argument, {C-u}, and as sibling of current cell's -parent, otherwise. If added as sibling of current level, RELATIVE-LEVEL is -used as a repeat count for the number of cells to add. - -Return last newly added cell." - (interactive "*P") - (or (stringp contents) (setq contents nil)) - (let ((klabel (kcell-view:label)) - (label-sep-len (kview:label-separator-length kview)) - cell-level new-cell sibling-p child-p start parent - cells-to-add) - (setq cell-level (kcell-view:level nil label-sep-len) - child-p (equal relative-level '(4)) - sibling-p (and (not child-p) - (cond ((not relative-level) 1) - ((>= (prefix-numeric-value relative-level) 0) - (prefix-numeric-value relative-level)))) - cells-to-add (or sibling-p 1)) - (if child-p - (setq cell-level (1+ cell-level)) - (if sibling-p - nil - ;; Add as following sibling of current cell's parent. - ;; Move to parent. - (setq cell-level (1- cell-level) - start (point) - parent (kcell-view:parent nil label-sep-len)) - (if (not (eq parent t)) - (progn - (goto-char start) - (error - "(kotl-mode:add-cell): No higher level at which to add cell.") - ))) - ;; Skip from point past any children to next cell. - (if (kotl-mode:next-tree) - ;; If found a new tree, then move back to prior cell so can add - ;; new cell after it. - (kcell-view:previous nil label-sep-len))) - (goto-char (kcell-view:end)) - ;; - ;; Insert new cells into view. - (if (= cells-to-add 1) - (setq klabel - (cond (sibling-p - (klabel:increment klabel)) - (child-p (klabel:child klabel)) - ;; add as sibling of parent of current cell - (t (klabel:increment (klabel:parent klabel)))) - new-cell (kview:add-cell klabel cell-level contents plist - (or no-fill sibling-p - (not kotl-mode:refill-flag)))) - ;; - ;; sibling-p must be true if we are looping here so there is no need to - ;; conditionalize how to increment the labels. - (while (>= (setq cells-to-add (1- cells-to-add)) 0) - (setq klabel (klabel:increment klabel) - ;; Since new cells are at the same level as old one, don't fill - ;; any of their intial contents. - new-cell (kview:add-cell klabel cell-level contents plist t)))) - ;; - ;; Move back to last inserted cell and then move to its following - ;; sibling if any. - (kotl-mode:to-valid-position t) - (save-excursion - (if (kcell-view:forward t label-sep-len) - ;; Update the labels of these siblings and their subtrees. - (klabel-type:update-labels (klabel:increment klabel)))) - ;; - ;; Leave point within last newly added cell and return this cell. - (kotl-mode:beginning-of-cell) - new-cell)) - -(defun kotl-mode:demote-tree (arg) - "Move current tree a maximum of prefix ARG levels lower in current view. -Each cell is refilled iff its `no-fill' attribute is nil and -kotl-mode:refill-flag is non-nil. With prefix ARG = 0, cells are demoted up -to one level and kotl-mode:refill-flag is treated as true." - (interactive "*p") - (if (< arg 0) - (kotl-mode:promote-tree (- arg)) - (let* ((label-sep-len (kview:label-separator-length kview)) - (orig-level (kcell-view:level nil label-sep-len)) - (orig-point (point)) - (orig-id (kcell-view:idstamp)) - (fill-p (= arg 0)) - (orig-pos-in-cell - (- (point) (kcell-view:start nil label-sep-len))) - prev prev-level) - (if fill-p (setq arg 1)) - (unwind-protect - (progn - (backward-char 1) - (while (and (> arg 0) - (setq prev - (kcell-view:previous nil label-sep-len))) - (if prev - (progn (setq prev-level - (kcell-view:level nil label-sep-len)) - (cond ((> prev-level (+ orig-level arg)) - ;; Don't want to demote this far - ;; so keep looking at prior nodes. - nil) - ((= arg (- prev-level orig-level)) - ;; Demote to be sibling of this kcell. - (setq arg -1)) - ((< prev-level orig-level) - ;; prev is at higher level then - ;; orig, so can't demote - (setq prev nil - arg 0)) - (t - ;; Demote below this kcell. This is - ;; as far we can demote, though it may - ;; not be the full amount of arg. - (setq arg 0)))))) - (if prev - (kotl-mode:move-after - (kcell-view:label orig-point) - (kcell-view:label) (= arg 0) - nil fill-p))) - ;; Move to start of original cell - (kotl-mode:goto-cell orig-id) - ;; Move to original pos within cell - (forward-char orig-pos-in-cell) - (kotl-mode:to-valid-position)) - (if (not prev) - (error "(kotl-mode:demote-tree): Cannot demote any further"))))) - -(defun kotl-mode:exchange-cells (cell-ref-1 cell-ref-2) - "Exchange CELL-REF-1 with CELL-REF-2 in current view. Don't move point." - (interactive - (let ((hargs:defaults - (save-excursion - (list (kcell-view:label) - (cond - ((kcell-view:previous t) - (kcell-view:label)) - ((kcell-view:next t) - (kcell-view:label)) - (t (error - "(kotl-mode:exchange-cells): No 2 visible cells"))))))) - (hargs:iform-read - '(interactive "*+KExchange cell: \n+KExchange cell <%s> with cell: ")))) - (save-excursion - (let (kcell-1 contents-1 - kcell-2 contents-2) - ;; - ;; Save cell-1 attributes - (kotl-mode:goto-cell cell-ref-1 t) - (setq kcell-1 (kcell-view:cell) - contents-1 (kcell-view:contents)) - ;; - ;; Save cell-2 attributes - (kotl-mode:goto-cell cell-ref-2 t) - (setq kcell-2 (kcell-view:cell) - contents-2 (kcell-view:contents)) - ;; - ;; Substitute cell-1 attributes into cell-2 location. - ;; - ;; Set kcell properties. - (kcell-view:set-cell kcell-1) - ;; If idstamp labels are on, then must exchange labels in view. - (if (eq (kview:label-type kview) 'id) - (klabel:set (kcell-view:idstamp))) - ;; Exchange cell contents. - (delete-region (kcell-view:start) (kcell-view:end-contents)) - (insert - (hypb:replace-match-string - "\\([\n\r]\\)" - contents-1 (concat "\\1" (make-string (kcell-view:indent) ?\ )))) - (if kotl-mode:refill-flag (kotl-mode:fill-cell)) - ;; - ;; Substitute cell-2 attributes into cell-1 location. - ;; - ;; Set kcell properties. - (kotl-mode:goto-cell cell-ref-1 t) - (kcell-view:set-cell kcell-2) - ;; If idstamp labels are on, then must exchange labels in view. - (if (eq (kview:label-type kview) 'id) - (klabel:set (kcell-view:idstamp))) - ;; Exchange cell contents. - (delete-region (kcell-view:start) (kcell-view:end-contents)) - ;; Add indentation to all but first line. - (insert - (hypb:replace-match-string - "\\([\n\r]\\)" - contents-2 (concat "\\1" (make-string (kcell-view:indent) ?\ )))) - (if kotl-mode:refill-flag (kotl-mode:fill-cell))))) - -(defun kotl-mode:kill-contents (arg) - "Kill contents of cell from point to cell end. -With prefix ARG, kill entire cell contents." - (interactive "*P") - (kotl-mode:kill-region - (if arg (kcell-view:start) (point)) - (kcell-view:end-contents))) - -(defun kotl-mode:kill-tree (&optional arg) - "Kill ARG following trees starting with tree rooted at point. -If ARG is not a non-positive number, nothing is done." - (interactive "*p") - (or (integerp arg) (setq arg 1)) - (let ((killed) (label (kcell-view:label)) - (label-sep-len (kview:label-separator-length kview)) - start end sib) - (while (> arg 0) - (setq start (kotl-mode:tree-start) - end (kotl-mode:tree-end) - sib (kcell-view:sibling-p nil nil label-sep-len) - arg (1- arg) - killed t) - ;; Don't want to delete any prior cells, so if on last cell, ensure - ;; this is the last one killed. - (if (kotl-mode:last-cell-p) - (progn (setq arg 0) - (kview:delete-region start end)) - (kview:delete-region start end) - (kotl-mode:to-valid-position))) - (if killed - (progn - (cond (sib (klabel-type:update-labels label)) - ((kotl-mode:buffer-empty-p) - ;; Always leave at least 1 visible cell within a view. - (kview:add-cell "1" 1))) - (kotl-mode:to-valid-position))))) - -(defun kotl-mode:mail-tree (cell-ref invisible-flag) - "Mail outline tree rooted at CELL-REF. Use \"0\" for whole outline buffer. -Invisible text is expanded and included in the mail only if INVISIBLE-FLAG is -non-nil." - (interactive - (let ((label-default (kcell-view:label))) - (hargs:iform-read - '(interactive - (list - (hargs:read "Mail tree: (0 for whole outline) " - nil label-default nil 'kcell) - (y-or-n-p "Include invisible text? ")))))) - (if (equal cell-ref "0") - (hmail:buffer nil invisible-flag) - (let (start end) - (save-excursion - (kotl-mode:goto-cell cell-ref t) - (beginning-of-line) - (setq start (point)) - (or (= (kotl-mode:forward-cell 1) 0) (goto-char (point-max))) - (forward-line -1) - (setq end (point))) - (hmail:region start end nil invisible-flag)))) - -(defun kotl-mode:promote-tree (arg) - "Move current tree a maximum of prefix ARG levels higher in current view. -Each cell is refilled iff its `no-fill' attribute is nil and -kotl-mode:refill-flag is non-nil. With prefix ARG = 0, cells are promoted up -to one level and kotl-mode:refill-flag is treated as true." - (interactive "*p") - (if (< arg 0) - (kotl-mode:demote-tree (- arg)) - (let* ((parent) (result) - (label-sep-len (kview:label-separator-length kview)) - (orig-point (point)) - (orig-id (kcell-view:idstamp)) - (fill-p (= arg 0)) - (orig-pos-in-cell - (- (point) (kcell-view:start nil label-sep-len)))) - (if fill-p (setq arg 1)) - (unwind-protect - (progn - (backward-char 1) - (while (and (> arg 0) - (setq result (kcell-view:parent - nil label-sep-len)) - (not (eq result 0))) - (setq parent result - arg (1- arg))) - (if parent - (kotl-mode:move-after - (kcell-view:label orig-point) - (kcell-view:label) nil - nil fill-p))) - ;; Move to start of original cell - (kotl-mode:goto-cell orig-id) - ;; Move to original pos within cell - (forward-char orig-pos-in-cell) - (kotl-mode:to-valid-position)) - (if (not parent) - (error "(kotl-mode:promote-tree): Cannot promote any further"))))) - -(defun kotl-mode:set-cell-attribute (attribute value &optional pos) - "Include ATTRIBUTE VALUE with the current cell or the cell at optional POS. -Replaces any existing value that ATTRIBUTE has. -When called interactively, it displays the setting in the minibuffer as -confirmation." - (interactive - (let* ((plist (copy-sequence (kcell-view:plist))) - (existing-attributes plist) - attribute value) - (barf-if-buffer-read-only) - ;; Remove attribute values - (while plist - (setcdr plist (cdr (cdr plist))) - (setq plist (cdr plist))) - ;; Remove read-only attributes - (setq existing-attributes (set:create existing-attributes) - existing-attributes (set:difference - existing-attributes - kcell:read-only-attributes)) - - (while (zerop (length (setq attribute - (completing-read - "Current cell attribute to set: " - (mapcar 'list - (mapcar 'symbol-name - existing-attributes)))))) - (beep)) - (setq attribute (intern attribute) - value (kcell-view:get-attr attribute)) - (if value - (setq value (read-minibuffer - (format "Change value of \"%s\" to: " attribute) - (prin1-to-string value))) - (setq value (read-minibuffer - (format "Set value of \"%s\" to: " attribute)))) - (list attribute value nil))) - (kcell-view:set-attr attribute value pos) - ;; Note that buffer needs to be saved to store new attribute value. - (set-buffer-modified-p t) - (if (interactive-p) - (message "Attribute \"%s\" set to `%s' in cell <%s>." - attribute value (kcell-view:label pos)))) - -(defun kotl-mode:split-cell (&optional arg) - "Split the current cell into two cells and move to the new cell. -The cell contents after point become part of the newly created cell. -The default is to create the new cell as a sibling of the current cell. -With optional universal ARG, {C-u}, the new cell is added as the child of -the current cell." - (interactive "*P") - (let ((new-cell-contents (kotl-mode:kill-region - (point) (kcell-view:end-contents) 'string)) - (start (kcell-view:start))) - ;; delete any preceding whitespace - (skip-chars-backward " \t\n\r" start) - (delete-region (max start (point)) (kcell-view:end-contents)) - (kotl-mode:add-cell arg new-cell-contents (kcell-view:plist)))) - -(defun kotl-mode:transpose-cells (arg) - "Exchange current and previous visible cells, leaving point after both. -If no previous cell, exchange current with next cell. -With prefix ARG, take current tree and move it past ARG visible cells. -With prefix ARG = 0, interchange the cell that contains point with the cell -that contains mark." - (interactive "*p") - (let ((label-sep-len (kview:label-separator-length kview))) - (cond - ((save-excursion (not (or (kcell-view:next t label-sep-len) - (kcell-view:previous t label-sep-len)))) - (error "(kotl-mode:transpose-cells): Only one visible cell in outline")) - ;; - ;; Transpose current and previous cells or current and next cells, if no - ;; previous cell. Leave point after both exchanged cells or within last - ;; visible cell. - ((= arg 1) - (let ((label-1 (kcell-view:label)) - (prev (kcell-view:previous t label-sep-len)) - label-2) - (or prev (kcell-view:next t label-sep-len)) - (setq label-2 (kcell-view:label)) - (kotl-mode:exchange-cells label-1 label-2) - (kcell-view:next t label-sep-len) - (if prev (kcell-view:next t label-sep-len)))) - ;; - ;; Transpose point and mark cells, moving point to the new location of the - ;; cell which originally contained point. - ((= arg 0) - (let ((label-1 (kcell-view:label)) - label-2) - ;; This is like exchange-point-and-mark, but doesn't activate the - ;; mark. - (goto-char (prog1 (hypb:mark t) - (set-marker (hypb:mark-marker t) (point)))) - (setq label-2 (kcell-view:label)) - (kotl-mode:exchange-cells label-1 label-2))) - ;; - ;; Move current tree past ARG next visible cells and leave point after - ;; original cell text. - (t - (let ((mark (set-marker (make-marker) - (save-excursion (kotl-mode:next-line arg))))) - (kotl-mode:move-after - (kcell-view:label) - (progn (while (and (> arg 0) (kcell-view:next t label-sep-len)) - (setq arg (1- arg))) - (kcell-view:label)) - nil) - (goto-char mark) - (set-marker mark nil)))))) - -;;; ------------------------------------------------------------------------ -;;; Structure Viewing -;;; ------------------------------------------------------------------------ - -(defun kotl-mode:collapse-tree (&optional all-flag) - "Collapse to one line each visible cell of tree rooted at point. -With optional ALL-FLAG non-nil, collapse all cells visible within the current -view." - (interactive "P") - (kotl-mode:is-p) - (let (buffer-read-only) - (if all-flag - (progn (kvspec:show-lines-per-cell 1) - (kvspec:update t)) - (kview:map-tree - (function - (lambda (kview) - ;; Use free variable label-sep-len bound in kview:map-tree for speed. - (goto-char (kcell-view:start nil label-sep-len)) - (subst-char-in-region (point) (kcell-view:end-contents) ?\n ?\r t))) - kview nil t)))) - -(defun kotl-mode:expand-tree (&optional all-flag) - "Expand each visible cell of tree rooted at point. -With optional ALL-FLAG non-nil, expand all cells visible within the current -view." - (interactive "P") - (kotl-mode:is-p) - (let (buffer-read-only) - (if all-flag - (progn (kvspec:show-lines-per-cell 0) - (kvspec:update t)) - (kview:map-tree - (function - (lambda (kview) - ;; Use free variable label-sep-len bound in kview:map-tree for speed. - (goto-char (kcell-view:start nil label-sep-len)) - (subst-char-in-region (point) (kcell-view:end-contents) ?\r ?\n t))) - kview nil t)))) - -(defun kotl-mode:toggle-tree-expansion (&optional all-flag) - "Collapse or expand each cell of tree rooted at point or all visible cells if optional prefix arg ALL-FLAG is given. -If current cell is collapsed, cells will be expanded, otherwise they will be -collapsed." - (interactive "P") - (if (kcell-view:collapsed-p) - ;; expand cells - (kotl-mode:expand-tree all-flag) - (kotl-mode:collapse-tree all-flag))) - -;;; -(defun kotl-mode:overview () - "Show the first line of each cell without blank line separators." - (interactive) - (kotl-mode:show-all) - (if (string-match "b" kvspec:current) - (kvspec:toggle-blank-lines)) - (kotl-mode:collapse-tree t)) - -(defun kotl-mode:show-all () - "Show (expand) all cells in current view." - (interactive) - (if (kotl-mode:is-p) - (progn (kview:set-attr kview 'levels-to-show 0) - (kview:set-attr kview 'lines-to-show 0) - (show-all) - (kvspec:update t)))) - -(defun kotl-mode:top-cells () - "Collapse all level 1 cells in view and hide any deeper sublevels." - (interactive) - (kotl-mode:is-p) - (let ((modified-p (buffer-modified-p)) - (buffer-read-only)) - (kvspec:levels-to-show 1) - (kvspec:show-lines-per-cell 1) - (kvspec:update t) - ;; Restore buffer modification status - (set-buffer-modified-p modified-p))) - -;;; -(defun kotl-mode:hide-sublevels (levels-to-keep) - "Hide all cells in outline at levels deeper than LEVELS-TO-KEEP (a number). -Shows any hidden cells within LEVELS-TO-KEEP. 1 is the first level. 0 means -display all levels of cells." - (interactive "P") - (kvspec:levels-to-show levels-to-keep) - ;; The prior call might have shown more lines per cell than the current - ;; viewspec supports, so reset lines per cell. - (kvspec:lines-to-show) - (kvspec:update t)) - -(defun kotl-mode:hide-subtree (&optional cell-ref show-flag) - "Hide subtree, ignoring root, at optional CELL-REF (defaults to cell at point)." - (interactive) - (kotl-mode:is-p) - (save-excursion - (if cell-ref - (kotl-mode:goto-cell cell-ref t) - (kotl-mode:beginning-of-cell)) - (let ((start (kcell-view:end-contents)) - (end (kotl-mode:tree-end t)) - (buffer-read-only)) - (if show-flag - (subst-char-in-region start end ?\r ?\n t) - (subst-char-in-region start end ?\n ?\r t))))) - -(defun kotl-mode:show-subtree (&optional cell-ref) - "Show subtree, ignoring root, at optional CELL-REF (defaults to cell at point)." - (interactive) - (kotl-mode:hide-subtree cell-ref t)) - -(defun kotl-mode:hide-tree (&optional cell-ref show-flag) - "Collapse tree rooted at optional CELL-REF (defaults to cell at point)." - (interactive) - (kotl-mode:is-p) - (save-excursion - (let ((start (if cell-ref - (kotl-mode:goto-cell cell-ref t) - (kotl-mode:beginning-of-cell))) - (end (kotl-mode:tree-end t)) - (buffer-read-only)) - (if show-flag - (subst-char-in-region start end ?\r ?\n t) - (subst-char-in-region start end ?\n ?\r t))))) - -(defun kotl-mode:show-tree (&optional cell-ref) - "Display fully expanded tree rooted at CELL-REF." - (interactive) - (kotl-mode:hide-tree cell-ref t)) - -;;; -(defun kotl-mode:cell-attributes (all-flag) - "Display a temporary buffer with the attributes of the current kcell. -With prefix arg ALL-FLAG non-nil, display the attributes of all visible -kcells in the current buffer. - -See also the documentation for `kotl-mode:cell-help'." - (interactive "P") - (with-output-to-temp-buffer - (hypb:help-buf-name "Kotl") - (save-excursion - (if (not all-flag) - (kotl-mode:print-attributes kview) - (let ((label-sep-len (kview:label-separator-length kview))) - (kotl-mode:beginning-of-buffer) - (while (progn (kotl-mode:print-attributes kview) - (kcell-view:next t label-sep-len)))))))) - -(defun kotl-mode:cell-help (&optional cell-ref cells-flag) - "Display a temporary buffer with CELL-REF's attributes. -CELL-REF defaults to current cell. -Optional prefix arg CELLS-FLAG selects the cells to print: - If = 1, print CELL-REF's cell only; - If > 1, print CELL-REF's visible tree (the tree rooted at CELL-REF); - If < 1, print all visible cells in current view (CELL-REF is not used). - -See also the documentation for `kotl-mode:cell-attributes'." - (interactive - (let* ((label (kcell-view:label)) - (hargs:defaults (list label label))) - (append - (let ((arg (prefix-numeric-value current-prefix-arg))) - (if (< arg 1) - 0 - (hargs:iform-read - (list 'interactive - (format "+KDisplay properties of koutline %s: " - (if (= arg 1) "cell" "tree")))))) - (list current-prefix-arg)))) - (or (integerp cells-flag) - (setq cells-flag (prefix-numeric-value cells-flag))) - (or (stringp cell-ref) (setq cell-ref (kcell-view:label))) - (with-output-to-temp-buffer - (hypb:help-buf-name "Koutline") - (save-excursion - (if (equal cell-ref "0") - (progn - (hattr:report (kcell:plist (kview:top-cell kview))) - (terpri) - (cond ((= cells-flag 1) nil) - ((> cells-flag 1) - (kview:map-tree 'kotl-mode:print-attributes kview t t)) - ;; (< cells-flag 1) - (t (kotl-mode:cell-attributes t)))) - (cond ((= cells-flag 1) - (kotl-mode:goto-cell cell-ref) - (kotl-mode:print-attributes kview)) - ((> cells-flag 1) - (kotl-mode:goto-cell cell-ref) - (kview:map-tree 'kotl-mode:print-attributes kview nil t)) - ;; (< cells-flag 1) - (t (kotl-mode:cell-attributes t))))))) - -(defun kotl-mode:get-cell-attribute (attribute &optional pos) - "Return ATTRIBUTE's value for the current cell or the cell at optional POS. -When called interactively, it displays the value in the minibuffer." - (interactive "SCurrent cell attribute to get: ") - (let ((value (kcell-view:get-attr attribute pos))) - (if (interactive-p) - (message "Attribute \"%s\" = `%s' in cell <%s>." - attribute value (kcell-view:label pos))) - value)) - -;;; ************************************************************************ -;;; Private functions -;;; ************************************************************************ - -(defun kotl-mode:add-indent-to-region (&optional indent start end) - "Add current cell's indent to current region. -Optionally, INDENT and region START and END may be given." - (or (integerp indent) (setq indent (kcell-view:indent))) - (save-excursion - (save-restriction - (narrow-to-region (or start (point)) (or end (hypb:mark t))) - (goto-char (point-min)) - (replace-regexp "\n" (concat "\n" (make-string indent ?\ )))))) - -(defun kotl-mode:delete-line (&optional pos) - "Delete and return contents of cell line at point or optional POS as a string. -Does not delete newline at end of line." - (save-excursion - (if pos (goto-char pos)) - (if (kview:valid-position-p) - (let ((bol (kotl-mode:start-of-line)) - (eol (kotl-mode:finish-of-line))) - (prog1 - (buffer-substring bol eol) - (delete-region bol eol))) - (error "(kotl-mode:delete-line): Invalid position, `%d'" (point))))) - -(defun kotl-mode:indent-line (arg) - ;; Disallow the indent-line command. - (error "(kotl-mode:indent-line): Insert spaces to indent each line.")) - -(defun kotl-mode:indent-region (start end) - ;; User might try to indent across cells. This would be bad, so disallow - ;; the indent-region command. - (error "(kotl-mode:indent-region): Insert spaces to indent each line.")) - -(defun kotl-mode:is-p () - "Signal an error if current buffer is not a Hyperbole outline, else return t." - (if (kview:is-p kview) - t - (hypb:error - "(kotl-mode:is-p): Command requires a current Hyperbole outline."))) - -(defun kotl-mode:tree-end (&optional omit-end-newlines) - "Return end point of current cell's tree within this view. -If optional OMIT-END-NEWLINES is non-nil, point returned precedes any -newlines at end of tree." - (let* ((label-sep-len (kview:label-separator-length kview)) - (start-indent (kcell-view:indent nil label-sep-len)) - (next)) - (save-excursion - (while (and (setq next (kcell-view:next nil label-sep-len)) - (< start-indent (kcell-view:indent nil label-sep-len)))) - (cond (next - (goto-char (progn (kcell-view:previous nil label-sep-len) - (kcell-view:end)))) - ;; Avoid skipping too far at end of file. - ((re-search-forward "[\n\r][\n\r]" nil t)) - (t (goto-char (point-max)))) - (if omit-end-newlines (skip-chars-backward "\n\r")) - (point)))) - -(defun kotl-mode:tree-start () - "Return beginning of line position preceding current cell's start point." - (save-excursion (goto-char (kcell-view:start)) (beginning-of-line) - (point))) - -(defun kotl-mode:line-move (arg) - "Move point ARG visible lines forward within an outline." - (if (not (integerp selective-display)) - (forward-line arg) - ;; Move by arg lines, but ignore invisible ones. - (while (> arg 0) - (vertical-motion 1) - (forward-char -1) - (forward-line 1) - (setq arg (1- arg))) - (while (< arg 0) - (vertical-motion -1) - (beginning-of-line) - (setq arg (1+ arg)))) - (move-to-column (or goal-column temporary-goal-column)) - nil) - -(defun kotl-mode:print-attributes (kview) - "Print to the `standard-output' stream the attributes of the current visible kcell. -Takes argument KVIEW (so it can be used with `kview:map-tree' and so that -KVIEW is bound correctly) but always operates upon the current view." - ;; Move to start of visible cell to avoid printing attributes for an - ;; invisible kcell which point may be over. - ;; Print first line of cell for reference. - (save-excursion - (princ - (buffer-substring (progn (beginning-of-line) (point)) - (progn (kview:end-of-actual-line) - (point))))) - (terpri) - (hattr:report (kcell:plist (kcell-view:cell))) - (terpri)) - -(defun kotl-mode:set-temp-goal-column () - (if (not (or (eq last-command 'next-line) - (eq last-command 'previous-line))) - (setq temporary-goal-column - (if (and track-eol (eolp) - ;; Don't count beg of empty line as end of line - ;; unless we just did explicit end-of-line. - (or (not (bolp)) (eq last-command 'end-of-line))) - 9999 - (current-column))))) - -(defun kotl-mode:to-valid-position (&optional backward-p) - "Move point to the nearest non-read-only position within current koutline view. -With optional BACKWARD-P, move backward if possible to get to valid position." - (if (kview:valid-position-p) - nil - (let ((label-sep-len (kview:label-separator-length kview))) - (cond ((kotl-mode:bobp) - (goto-char (kcell-view:start nil label-sep-len))) - ((kotl-mode:eobp) - (skip-chars-backward "\n\r")) - (t (let ((indent (kcell-view:indent nil label-sep-len))) - (if (bolp) - (if backward-p - (skip-chars-backward "\n\r") - (skip-chars-forward "\n\r"))) - (setq indent (kcell-view:indent nil label-sep-len)) - (if (< (current-column) indent) - (move-to-column indent)))))))) - -(defun kotl-mode:transpose-lines-internal (start end) - "Transpose lines at START and END markers within an outline. -Leave point at end of line now residing at START." - (if (and start end - (kview:valid-position-p start) - (kview:valid-position-p end)) - (let* ((pline (kotl-mode:delete-line start)) - mline) - (goto-char end) - (setq mline (kotl-mode:delete-line)) - (insert pline) - (goto-char start) - (insert mline)) - ;; Set non-point and non-mark markers to point nowhere before signalling - ;; an error. - (or (eq start (point-marker)) - (eq start (hypb:mark-marker t)) - (set-marker start nil)) - (or (eq end (point-marker)) - (eq end (hypb:mark-marker t)) - (set-marker start nil)) - (error "(kotl-mode:transpose-lines): Point or mark is at an invalid position"))) - -(defun kotl-mode:update-buffer () - "Update current view buffer in preparation for saving." - (if (kview:is-p kview) - (let ((mod-p (buffer-modified-p)) - (start (window-start))) - (save-excursion - (kfile:update) - (set-buffer-modified-p mod-p)) - (set-window-start nil (max (point-min) start) t) - nil))) - -;;; ------------------------------------------------------------------------ - -(defvar kotl-mode-map nil - "Keymap containing koutliner editing and viewing commands.") -(if kotl-mode-map - nil - (setq kotl-mode-map - (if (string-match "XEmacs\\|Lucid" emacs-version) - (make-keymap) - (copy-keymap indented-text-mode-map))) - ;; Overload edit keys to deal with structure and labels. - (let (local-cmd) - (mapcar - (if (string-match "XEmacs\\|Lucid" emacs-version) - ;; XEmacs - (function - (lambda (cmd) - (setq local-cmd (intern-soft - (concat "kotl-mode:" (symbol-name cmd)))) - ;; Only bind key locally if kotl-mode local-cmd has already - ;; been defined and cmd is a valid function. - (if (and local-cmd (fboundp cmd)) - (progn - ;; Make local-cmd have the same property list as cmd, - ;; e.g. so pending-delete property is the same. - (setplist local-cmd (symbol-plist cmd)) - (mapcar - (function - (lambda (key) (define-key kotl-mode-map key local-cmd))) - (where-is-internal cmd)))))) - ;; GNU Emacs 19 - (function - (lambda (cmd) - (setq local-cmd (intern-soft - (concat "kotl-mode:" (symbol-name cmd)))) - ;; Only bind key locally if kotl-mode local-cmd has already - ;; been defined and cmd is a valid function. - (if (and local-cmd (fboundp cmd)) - (progn - ;; Make local-cmd have the same property list as cmd, - ;; e.g. so pending-delete property is the same. - (setplist local-cmd (symbol-plist cmd)) - (substitute-key-definition - cmd local-cmd kotl-mode-map global-map)))))) - '( - back-to-indentation - backward-char - backward-delete-char - backward-delete-char-untabify - backward-kill-word - backward-para - backward-paragraph - backward-sentence - backward-word - beginning-of-buffer - beginning-of-line - copy-region-as-kill - copy-to-register - delete-blank-lines - delete-backward-char - delete-char - delete-horizontal-space - delete-indentation - end-of-buffer - end-of-line - fill-paragraph - fill-paragraph-or-region - ;; cursor keys - fkey-backward-char - fkey-forward-char - fkey-next-line - fkey-previous-line - ;; - forward-char - forward-word - forward-para - forward-paragraph - forward-sentence - insert-buffer - insert-file - insert-register - just-one-space - kill-word - kill-line - kill-region - kill-ring-save - kill-sentence - mark-paragraph - mark-whole-buffer - newline - newline-and-indent - next-line - open-line - previous-line - scroll-down - scroll-up - set-fill-prefix - transpose-chars - transpose-lines - transpose-paragraphs - transpose-sentences - transpose-words - yank - yank-pop - zap-to-char - ))) - - - ;; kotl-mode keys - (define-key kotl-mode-map "\C-c@" 'kotl-mode:mail-tree) - (define-key kotl-mode-map "\C-c+" 'kotl-mode:append-cell) - (define-key kotl-mode-map "\C-c," 'kotl-mode:beginning-of-cell) - (define-key kotl-mode-map "\C-c." 'kotl-mode:end-of-cell) - (define-key kotl-mode-map "\C-c<" 'kotl-mode:first-sibling) - (define-key kotl-mode-map "\C-c>" 'kotl-mode:last-sibling) - (define-key kotl-mode-map "\C-c^" 'kotl-mode:beginning-of-tree) - (define-key kotl-mode-map "\C-c$" 'kotl-mode:end-of-tree) - (define-key kotl-mode-map "\C-ca" 'kotl-mode:add-child) - (define-key kotl-mode-map "\C-c\C-a" 'kotl-mode:show-all) - (define-key kotl-mode-map "\C-cb" 'kvspec:toggle-blank-lines) - (define-key kotl-mode-map "\C-c\C-b" 'kotl-mode:backward-cell) - (define-key kotl-mode-map "\C-cc" 'kotl-mode:copy-after) - (define-key kotl-mode-map "\C-c\C-c" 'kotl-mode:copy-before) - (define-key kotl-mode-map "\C-c\M-c" 'kotl-mode:copy-to-buffer) - (define-key kotl-mode-map "\C-cd" 'kotl-mode:down-level) - (define-key kotl-mode-map "\C-c\C-d" 'kotl-mode:down-level) - (define-key kotl-mode-map "\C-ce" 'kotl-mode:exchange-cells) - (define-key kotl-mode-map "\C-c\C-f" 'kotl-mode:forward-cell) - (define-key kotl-mode-map "\C-cg" 'kotl-mode:goto-cell) - (define-key kotl-mode-map "\C-ch" 'kotl-mode:cell-help) - (define-key kotl-mode-map "\C-c\C-h" 'kotl-mode:hide-tree) - (define-key kotl-mode-map "\M-\C-h" 'kotl-mode:hide-subtree) - ;; Override this global binding for set-selective-display with a similar - ;; function appropriate for kotl-mode. - (define-key kotl-mode-map "\C-x$" 'kotl-mode:hide-sublevels) - (define-key kotl-mode-map "\C-i" 'kotl-mode:demote-tree) - (define-key kotl-mode-map "\M-\C-i" 'kotl-mode:promote-tree) - (define-key kotl-mode-map "\C-j" 'kotl-mode:add-cell) - (define-key kotl-mode-map "\M-j" 'kotl-mode:fill-paragraph) - (define-key kotl-mode-map "\C-c\M-j" 'kotl-mode:fill-cell) - (define-key kotl-mode-map "\M-\C-j" 'kotl-mode:fill-tree) - (define-key kotl-mode-map "\C-c\C-k" 'kotl-mode:kill-tree) - (define-key kotl-mode-map "\C-ck" 'kotl-mode:kill-contents) - (define-key kotl-mode-map "\C-c\C-i" 'kotl-mode:set-cell-attribute) - (define-key kotl-mode-map "\C-cl" 'klink:create) - (define-key kotl-mode-map "\C-c\C-l" 'kview:set-label-type) - (define-key kotl-mode-map "\C-c\M-l" 'kview:set-label-separator) - (define-key kotl-mode-map "\C-m" 'kotl-mode:newline) - (define-key kotl-mode-map "\C-cm" 'kotl-mode:move-after) - (define-key kotl-mode-map "\C-c\C-m" 'kotl-mode:move-before) - (define-key kotl-mode-map "\C-c\C-n" 'kotl-mode:next-cell) - (define-key kotl-mode-map "\C-c\C-o" 'kotl-mode:overview) - (define-key kotl-mode-map "\C-c\C-p" 'kotl-mode:previous-cell) - (define-key kotl-mode-map "\C-cp" 'kotl-mode:add-parent) - (if (memq (global-key-binding "\M-q") '(fill-paragraph - fill-paragraph-or-region)) - (progn - (define-key kotl-mode-map "\C-c\M-q" 'kotl-mode:fill-cell) - (define-key kotl-mode-map "\M-\C-q" 'kotl-mode:fill-tree))) - (define-key kotl-mode-map "\C-cs" 'kotl-mode:split-cell) - (define-key kotl-mode-map "\C-c\C-s" 'kotl-mode:show-tree) - (define-key kotl-mode-map "\C-c\C-\\" 'kotl-mode:show-tree) - (define-key kotl-mode-map "\M-s" 'kotl-mode:center-line) - (define-key kotl-mode-map "\M-S" 'kotl-mode:center-paragraph) - (define-key kotl-mode-map "\C-ct" 'kotl-mode:transpose-cells) - (define-key kotl-mode-map "\C-c\C-t" 'kotl-mode:top-cells) - (define-key kotl-mode-map "\C-cu" 'kotl-mode:up-level) - (define-key kotl-mode-map "\C-c\C-u" 'kotl-mode:up-level) - (define-key kotl-mode-map "\C-c\C-v" 'kvspec:activate) - (define-key kotl-mode-map "\C-x\C-w" 'kfile:write)) - -(provide 'kotl-mode)
--- a/lisp/hyperbole/kotl/kotl.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,210 +0,0 @@ -;;!emacs -;; -;; FILE: kotl.el -;; SUMMARY: Internal representation of outline kcells used by kviews. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: outlines, wp -;; -;; AUTHOR: Kellie Clark & Bob Weiner -;; -;; ORIG-DATE: 5/1/93 -;; LAST-MOD: 29-Oct-95 at 11:13:47 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1993, 1994, 1995 Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Other required Elisp libraries -;;; ************************************************************************ - -(mapcar 'require '(klabel knode hinit htz)) - -;;; ************************************************************************ -;;; Public variables -;;; ************************************************************************ - -(defvar kcell:read-only-attributes - '(idstamp creator create-time modifier mod-time) - "List of kcell attributes which may not be modified by a user. -Add to this list but don't remove any of the default elements.") - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -;;; -;;; kcell -;;; - -(fset 'kcell:contents 'knode:contents) - -(defun kcell:copy (kcell) - "Return a copy of KCELL." - (knode:copy kcell)) - -(defun kcell:create (contents idstamp &optional plist) - "Return a new kcell which stores CONTENTS (a string or nil), has permanent IDSTAMP (an integer), and optional additional property list, PLIST. -User id of `creator' of cell and `create-time' are added to cell's PLIST if -not already there." - (and contents (not (stringp contents)) - (error "(kcell:create): Invalid `contents' argument: %s" contents)) - (if (or (not (integerp idstamp)) (< idstamp 0)) - (error "(kcell:create): Invalid `idstamp' argument: %s" idstamp)) - (knode:create - contents (nconc (list 'idstamp idstamp) - (if (memq 'creator plist) - nil - (list 'creator (concat (user-login-name) - hyperb:host-domain) - 'create-time (htz:date-sortable-gmt))) - plist))) - -(defun kcell:create-top (&optional file counter) - "Return a new koutline top cell optionally attached to FILE with current idstamp COUNTER." - (kcell:create nil 0 - ;; id-counter = max idstamp value given out in this kotl - (list 'id-counter (or counter 0) 'file file))) - -(defun kcell:get-attr (kcell attribute) - "Return the value of KCELL's ATTRIBUTE." - (knode:get-attr (kcell:plist kcell) attribute)) - -(defun kcell:idstamp (kcell) - "Return permanent idstamp of KCELL as an integer." - (kcell:get-attr kcell 'idstamp)) - -(fset 'kcell:is-p 'knode:is-p) - -(defun kcell:plist (kcell) - (knode:get-attr kcell 'plist)) - -(defun kcell:ref-to-id (cell-ref) - "Returns a CELL-REF string converted to a cell identifier string. -If CELL-REF contains both a relative and a permanent id, the permanent id is -returned. If CELL-REF is invalid, nil is returned. - -CELL-REF may be of any of the following forms: - 1b - relative id, augment style - 1.2 - relative id, legal style - 012 - permanent idstamp - 1a=012 - both relative and permanent ids (in that order) separated by = - |viewspec - a viewspec setting, rather than a cell reference - :viewspec - an augment viewspec, ignored for now. - -Optionally, any of the above id forms may be followed by a period and some -alpha characters indicating a location relative to the id. - -Optionally, any of these id forms (or the relative form) may be followed by -zero or more whitespace characters, a | and some view specification -characters. Augment viewspec characters preceded by a colon are ignored, for -now." - - (if (not (stringp cell-ref)) - nil - (setq cell-ref (hypb:replace-match-string "\\s +" cell-ref "" t)) - (let ((specs) result) - ;; Ignore Augment :viewspecs. - (if (string-match ":" cell-ref) - (setq cell-ref (substring cell-ref 0 (match-beginning 0)))) - ;; Separate koutline |viewspecs from cell id. - (if (string-match "\\(\\.[a-zA-Z]\\||\\)" cell-ref) - (setq specs (substring cell-ref (match-beginning 1)) - cell-ref (substring cell-ref 0 (match-beginning 0)))) - (setq result - (cond - ((string-match "[^.= \t\n0-9a-zA-Z]" cell-ref) nil) - ((string-match "^\\([.0-9a-zA-Z]+\\)=\\(0[0-9]*\\)$" - cell-ref) - (substring cell-ref (match-beginning 2) (match-end 2))) - ((string-match "^\\([.0-9a-zA-Z]+\\)$" cell-ref) - (substring cell-ref (match-beginning 1) (match-end 1))))) - (cond (result - (if specs (concat result specs) result)) - (specs - (if (= ?| (aref specs 0)) specs)))))) - -(defun kcell:remove-attr (kcell attribute) - "Remove KCELL's ATTRIBUTE, if any, return modified KCELL." - (knode:set-attr - kcell 'plist (knode:remove-attr (kcell:plist kcell) attribute))) - -(defun kcell:set-attr (kcell attribute value) - "Set KCELL's ATTRIBUTE to VALUE and return modified KCELL." - (knode:set-attr - kcell 'plist (knode:set-attr (kcell:plist kcell) - attribute value))) - -(defun kcell:set-create-time (kcell) - "Store the time of creation of KCELL." - (kcell:set-attr kcell 'create-time (htz:date-sortable-gmt))) - -(defun kcell:set-creator (kcell) - "Store the current user's id as the creator of KCELL." - (kcell:set-attr - kcell 'creator (concat (user-login-name) hyperb:host-domain))) - -(defun kcell:set-idstamp (kcell idstamp) - "Set KCELL's permanent IDSTAMP (an integer) and return IDSTAMP." - (kcell:set-attr kcell 'idstamp idstamp) - (kcell:idstamp kcell)) - -;;; -;;; kotl-data - Persistent representation of kotl cells (written to files). -;;; - -(defun kotl-data:create (cell) - "Given a kotl CELL, return a kotl-data structure to write to a file. -If CELL, its idstamp, or its property list are nil, this repairs the cell by -assuming it is the cell at point and filling in the missing information." - (let ((idstamp (kcell:idstamp cell)) - (plist (nthcdr 2 (kcell:plist cell)))) - (if (and cell idstamp plist) - (vector idstamp plist) - (kotl-data:create - (kcell:create nil - (or idstamp (kview:id-increment kview)) - plist))))) - -(defun kotl-data:idstamp (kotl-data) - (aref kotl-data 0)) - -(defun kotl-data:plist-v2 (kotl-data) - (aref kotl-data 2)) - -(defun kotl-data:plist-v3 (kotl-data) - (aref kotl-data 1)) - -(defun kotl-data:to-kcell-v2 (kotl-data) - (if (vectorp kotl-data) - (kcell:create - ;; Cell contents are no longer put into cells themselves by default - ;; when a file is read. The contents are stored within the kview - ;; buffer, so use nil as a place-holder. - nil - ;; Repair invalid idstamps on the fly. - (or (kotl-data:idstamp kotl-data) (kview:id-increment kview)) - (kotl-data:plist-v2 kotl-data)) - ;; Repair invalid cells on the fly. - (kcell:create nil (kview:id-increment kview)))) - -(defun kotl-data:to-kcell-v3 (kotl-data) - (if (vectorp kotl-data) - (kcell:create - ;; Cell contents are no longer put into cells themselves by default - ;; when a file is read. The contents are stored within the kview - ;; buffer, so use nil as a place-holder. - nil - ;; Repair invalid idstamps on the fly. - (or (kotl-data:idstamp kotl-data) (kview:id-increment kview)) - (kotl-data:plist-v3 kotl-data)) - ;; Repair invalid cells on the fly. - (kcell:create nil (kview:id-increment kview)))) - -(provide 'kotl)
--- a/lisp/hyperbole/kotl/kprop-em.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,96 +0,0 @@ -;;!emacs -;; -;; FILE: kprop-em.el -;; SUMMARY: Koutline text property handling under Emacs 19. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: outlines, wp -;; -;; AUTHOR: Bob Weiner -;; -;; ORIG-DATE: 7/27/93 -;; LAST-MOD: 30-Oct-95 at 20:59:54 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1993, 1994, 1995 Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Other required Elisp libraries -;;; ************************************************************************ - -(require 'hversion) - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -(fset 'kproperty:get 'get-text-property) - -(defun kproperty:map (function property value) - "Apply FUNCTION to each PROPERTY `eq' to VALUE in the current buffer. -FUNCTION is called with point preceding PROPERTY and receives the list of -properties at point as an argument. FUNCTION may not modify this list of -properties." - (let ((result) - (start (point-min))) - (save-excursion - (while (setq start - (text-property-any start (point-max) property value)) - (goto-char start) - (setq result (cons (funcall function (text-properties-at start)) - result)))) - (nreverse result))) - -(fset 'kproperty:next-single-change 'next-single-property-change) - -(fset 'kproperty:previous-single-change 'previous-single-property-change) - -(fset 'kproperty:properties 'text-properties-at) - -(defun kproperty:put (start end property-list &optional object) - "From START to END, add PROPERTY-LIST properties to the text. -The optional fourth argument, OBJECT, is the string or buffer containing the -text. Text inserted before or after this region does not inherit the added -properties." - (add-text-properties - start end (append property-list '(rear-nonsticky t)) object)) - -(defun kproperty:remove (start end property-list &optional object) - "From START to END, remove the text properties in PROPERTY-LIST. -The optional fourth argument, OBJECT, is the string or buffer containing the -text. PROPERTY-LIST should be a plist; if the value of a property is -non-nil, then only a property with a matching value will be removed. -Returns t if any property was changed, nil otherwise." - (let ((changed) plist property value next) - (while property-list - (setq property (car property-list) - value (car (cdr property-list)) - plist (list property value) - property-list (nthcdr 2 property-list) - next start) - (while (setq next (text-property-any next end property value object)) - (remove-text-properties next (1+ next) plist object) - (setq changed t next (1+ next)))) - changed)) - -(defun kproperty:replace-separator (pos label-separator old-sep-len) - "Replace at POS the cell label separator with LABEL-SEPARATOR. -OLD-SEP-LEN is the length of the separator being replaced." - (let (properties) - (while (setq pos (kproperty:next-single-change (point) 'kcell)) - (goto-char pos) - (setq properties (text-properties-at pos)) - ;; Replace label-separator while maintaining cell properties. - (insert label-separator) - (add-text-properties pos (+ pos 2) properties) - (delete-region (point) (+ (point) old-sep-len))))) - -(defun kproperty:set (property value) - "Set PROPERTY of character at point to VALUE." - (kproperty:put (point) (min (+ 2 (point)) (point-max)) - (list property value)))
--- a/lisp/hyperbole/kotl/kprop-xe.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,152 +0,0 @@ -;;!emacs -;; -;; FILE: kprop-xe.el -;; SUMMARY: Koutline text property handling under XEmacs. -;; USAGE: XEmacs Lisp Library -;; KEYWORDS: outlines, wp -;; -;; AUTHOR: Bob Weiner -;; ORG: InfoDock Associates -;; -;; ORIG-DATE: 7/27/93 -;; LAST-MOD: 28-Feb-97 at 23:41:02 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1993, 1994, 1995, 1997 Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Other required Elisp libraries -;;; ************************************************************************ - -(require 'hversion) - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -;; (get-text-property (pos prop &optional object)) -;; Return the value of position POS's property PROP, in OBJECT. -;; OBJECT is optional and defaults to the current buffer. -;; If POSITION is at the end of OBJECT, the value is nil. -(fset 'kproperty:get 'get-text-property) - -(if (and hyperb:xemacs-p (or (>= emacs-minor-version 12) - (> emacs-major-version 19))) - (defun kproperty:map (function property &optional value) - "Apply FUNCTION to each PROPERTY `eq' to VALUE in the current buffer. -FUNCTION is called with point preceding PROPERTY and receives PROPERTY as an -argument." - (let ((result)) - (save-excursion - (map-extents - (function (lambda (extent unused) - (goto-char (or (extent-start-position extent) (point))) - (setq result (cons (funcall function extent) result)) - nil)) - nil nil nil nil nil property value)) - (nreverse result))) - (defun kproperty:map (function property &optional value) - "Apply FUNCTION to each PROPERTY `eq' to VALUE in the current buffer. -FUNCTION is called with point preceding PROPERTY and receives PROPERTY as an -argument." - (let ((result)) - (save-excursion - (map-extents - (function (lambda (extent unused) - (if (eq (extent-property extent property) value) - (progn (goto-char (or (extent-start-position extent) - (point))) - (setq result (cons (funcall function extent) - result)))) - nil)))) - (nreverse result)))) - -;; (next-single-property-change (pos prop &optional object)) -;; Return the position of next property change for a specific property. -;; Scans characters forward from POS till it finds -;; a change in the PROP property, then returns the position of the change. -;; The optional third argument OBJECT is the string or buffer to scan. -;; Return nil if the property is constant all the way to the end of OBJECT. -;; If the value is non-nil, it is a position greater than POS, never equal. -(fset 'kproperty:next-single-change 'next-single-property-change) - -;; (previous-single-property-change (pos prop &optional object)) -;; Return the position of previous property change for a specific property. -;; Scans characters backward from POS till it finds -;; a change in the PROP property, then returns the position of the change. -;; The optional third argument OBJECT is the string or buffer to scan. -;; Return nil if the property is constant all the way to the start of OBJECT. -;; If the value is non-nil, it is a position less than POS, never equal. -(fset 'kproperty:previous-single-change 'previous-single-property-change) - -(fset 'kproperty:properties 'extent-properties-at) - -(defun kproperty:put (start end property-list &optional object) - "From START to END, add PROPERTY-LIST properties to the text. -The optional fourth argument, OBJECT, is the string or buffer containing the -text. Text inserted before or after this region does not inherit the added -properties." - ;; Don't use text properties internally because they don't work as desired - ;; when copied to a string and then reinserted, at least in some versions - ;; of XEmacs. - (let ((extent (make-extent start end object))) - (if (null extent) - (error "(kproperty:put): No extent at %d-%d to add properties %s" - start end property-list)) - (if (/= (mod (length property-list) 2) 0) - (error "(kproperty:put): Property-list has odd number of elements, %s" - property-list)) - (set-extent-property extent 'text-prop (car property-list)) - (set-extent-property extent 'duplicable t) - (set-extent-property extent 'start-open t) - (set-extent-property extent 'end-open t) - (while property-list - (set-extent-property - extent (car property-list) (car (cdr property-list))) - (setq property-list (nthcdr 2 property-list))) - extent)) - -(defun kproperty:remove (start end property-list &optional object) - "From START to END, remove the text properties in PROPERTY-LIST. -The optional fourth argument, OBJECT, is the string or buffer containing the -text. PROPERTY-LIST should be a plist; if the value of a property is -non-nil, then only a property with a matching value will be removed. -Returns t if any property was changed, nil otherwise." - ;; Don't use text property functions internally because they only look for - ;; closed extents, which kproperty does not use. - (let ((changed) property value) - (while property-list - (setq property (car property-list) - value (car (cdr property-list)) - property-list (nthcdr 2 property-list)) - (map-extents - (function (lambda (extent maparg) - (if (extent-live-p extent) - (progn (setq changed t) - (delete-extent extent))) - nil)) - object start end nil nil property value)) - changed)) - -(defun kproperty:replace-separator (pos label-separator old-sep-len) - "Replace at POS the cell label separator with LABEL-SEPARATOR. -OLD-SEP-LEN is the length of the separator being replaced." - (let (extent) - (while (setq pos (kproperty:next-single-change (point) 'kcell)) - (goto-char pos) - (setq extent (extent-at pos)) - ;; Replace label-separator while maintaining cell properties. - (insert label-separator) - (set-extent-endpoints extent pos (+ pos 2)) - (delete-region (point) (+ (point) old-sep-len))))) - -(defun kproperty:set (property value) - "Set PROPERTY of character at point to VALUE." - (kproperty:put (point) (min (+ 2 (point)) (point-max)) - (list property value)))
--- a/lisp/hyperbole/kotl/kproperty.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,29 +0,0 @@ -;;!emacs -;; -;; FILE: kproperty.el -;; SUMMARY: Wrapper for koutline text property implementations. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: outlines, wp -;; -;; AUTHOR: Bob Weiner -;; -;; ORIG-DATE: 7/27/93 -;; LAST-MOD: 27-Oct-95 at 22:45:55 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1993, 1994, 1995 Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Other required Elisp libraries -;;; ************************************************************************ - -(load (if hyperb:emacs19-p "kprop-em" "kprop-xe")) - -(provide 'kproperty)
--- a/lisp/hyperbole/kotl/kview.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1049 +0,0 @@ -;;!emacs -;; -;; FILE: kview.el -;; SUMMARY: Display handling of koutlines. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: outlines, wp -;; -;; AUTHOR: Bob Weiner & Kellie Clark -;; -;; ORIG-DATE: 6/30/93 -;; LAST-MOD: 6-Mar-97 at 01:16:42 by Bob Weiner - -;;; ************************************************************************ -;;; Other required Lisp Libraries -;;; ************************************************************************ -(mapcar 'require '(klabel kfill hypb)) - -;;; ************************************************************************ -;;; Public variables -;;; ************************************************************************ - -(set-default 'kview nil) - -(defvar kview:default-blank-lines t - "*Default setting of whether to show blank lines between koutline cells. -T means show them, nil means don't show them.") - -(defvar kview:default-levels-to-show 0 - "*Default number of cell levels to show. 0 means all levels.") - -(defvar kview:default-lines-to-show 0 - "*Default number of lines per cell to show. 0 means all lines.") - - -(defvar kview:default-label-min-width 4 - "*Minimum width to which to pad labels in a kotl view. -Labels are padded with spaces on the left.") - -(defvar kview:default-label-separator " " - "*Default string of characters to insert between label and contents of a koutline cell.") - -(defvar kview:default-label-type 'alpha - "*Default label-type to use for new koutlines. -It must be one of the following symbols: - no for no labels - id for permanent idstamp labels, e.g. 001, 002, etc. - alpha for `1a2' full alphanumeric labels - legal for `1.1.2' labels - partial-alpha for partial alphanumeric labels, e.g. `2' for node `1a2' - star for multi-star labeling, e.g. `***'.") - -(defvar kview:default-level-indent 3 - "*Default number of spaces to indent each succeeding level in koutlines.") - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -;;; -;;; kcell-view -;;; - -(defun kcell-view:backward (&optional visible-p label-sep-len) - "Move to start of the prior cell at the same level as the current cell. -With optional VISIBLE-P, consider only visible cells. -Return t unless no such cell." - (or label-sep-len (setq label-sep-len - (kview:label-separator-length kview))) - (let ((opoint (point)) - (found) (done) - (curr-indent 0) - (start-indent (kcell-view:indent nil label-sep-len))) - (while (and (not (or found done)) - (kcell-view:previous visible-p label-sep-len)) - (if (bobp) - (progn (setq done t) - (goto-char opoint)) - (setq curr-indent (kcell-view:indent nil label-sep-len)) - (cond ((= curr-indent start-indent) - (goto-char (kcell-view:start nil label-sep-len)) - (setq found t)) - ((< curr-indent start-indent) - ;; Went past start of this tree without a match. - (setq done t) - (goto-char opoint)) - ;; else go to prior node - ))) - found)) - -(defun kview:beginning-of-actual-line () - "Go to the beginning of the current line whether collapsed or not." - (if (re-search-backward "[\n\r]" nil 'move) - (forward-char 1))) - -(defun kcell-view:cell (&optional pos) - "Return kcell at optional POS or point." - (kproperty:get (kcell-view:plist-point pos) 'kcell)) - -(defun kcell-view:child (&optional visible-p label-sep-len) - "Move to start of current cell's child. -With optional VISIBLE-P, consider only visible children. -Return t unless cell has no matching child. -Optional LABEL-SEP-LEN is the length of the separation between -a cell's label and the start of its contents." - (let* ((opoint (point)) - (prev-indent (kcell-view:indent nil label-sep-len)) - (next (kcell-view:next visible-p label-sep-len))) - (or label-sep-len (setq label-sep-len - (kview:label-separator-length kview))) - ;; Since kcell-view:next leaves point at the start of a cell, the cell's - ;; indent is just the current-column of point. - (if (and next (> (current-column) prev-indent)) - t - ;; Move back to previous point and return nil. - (goto-char opoint) - nil))) - -(defun kcell-view:child-p (&optional pos visible-p label-sep-len) - "Return t if cell at optional POS or point has a child. -With optional VISIBLE-P, consider only visible children. -Optional LABEL-SEP-LEN is the length of the separation between -a cell's label and the start of its contents." - (save-excursion - (if pos (goto-char pos)) - (kcell-view:child visible-p label-sep-len))) - -(defun kcell-view:collapse (&optional pos label-sep-len) - "Collapse cell at optional POS or point within the current view." - (save-excursion - (goto-char (kcell-view:start pos label-sep-len)) - (subst-char-in-region (point) (kcell-view:end-contents) ?\n ?\r t))) - -(defun kcell-view:collapsed-p (&optional pos label-sep-len) - "Return t if cell at optional POS or point is collapsed within the current view." - (save-excursion - (goto-char (kcell-view:start pos label-sep-len)) - (if (search-forward "\r" (kcell-view:end-contents) t) - t))) - -(defun kcell-view:contents (&optional pos) - "Return contents of cell at optional POS or point." - (save-excursion - (if pos (goto-char pos)) - (let ((indent (kcell-view:indent)) - (start (kcell-view:start)) - (end (kcell-view:end-contents))) - ;; Remove indentation from all but first line. - (hypb:replace-match-string - (concat "\\([\n\r]\\)" (make-string indent ?\ )) - (buffer-substring start end) "\\1")))) - -(defun kcell-view:create (kview cell level klabel &optional no-fill) - "Insert into KVIEW at point, CELL at LEVEL (1 = first level) with KLABEL. -Optional NO-FILL non-nil suppresses filling of cell's contents upon insertion -or movement." - (if (= (kcell:idstamp cell) 0) - nil - (or no-fill (setq no-fill (kcell:get-attr cell 'no-fill))) - (let* ((label-min-width (kview:label-min-width kview)) - (label-fmt (format "%%%ds" label-min-width)) - (label (if (string= klabel "") "" (format label-fmt klabel))) - (label-separator (if (string= klabel "") " " - (kview:label-separator kview))) - (mult-line-indent (* (1- level) (kview:level-indent kview))) - (thru-label (+ mult-line-indent label-min-width - (length label-separator))) - (old-point (point)) - (fill-prefix (make-string thru-label ?\ )) - contents - new-point) - (if no-fill (kcell:set-attr cell 'no-fill t)) - (insert fill-prefix) - (setq contents (kview:insert-contents cell nil no-fill fill-prefix)) - ;; Insert lines to separate cell from next. - (insert (if (or no-fill (equal contents "")) - "\n\n" "\n")) - (if (kview:get-attr kview 'blank-lines) - nil - ;; Make blank lines invisible. - (kproperty:put (1- (point)) (min (point) (point-max)) - '(invisible t))) - (kfile:narrow-to-kcells) - (setq new-point (point)) - (goto-char old-point) - ;; Delete leading spaces used to get fill right in first cell - ;; line. Replace it with label. - (delete-char thru-label) - (insert (format - (format "%%%ds" (- thru-label (length label-separator))) - label)) - (setq old-point (point)) - (insert label-separator) - (goto-char old-point) - ;; Add cell's attributes to the text property list at point. - (kproperty:set 'kcell cell) - (goto-char new-point)))) - -(defun kcell-view:end (&optional pos) - "Return end position of cell from optional POS or point. -Includes blank lines following cell contents." - (or pos (setq pos (point))) - (save-excursion - (or (re-search-forward "[\n\r][\n\r]" nil t) - (point-max)))) - -(defun kcell-view:end-contents (&optional pos) - "Return end position of cell contents from optional POS or point. -Excludes blank lines following cell contents." - (save-excursion - (if pos (goto-char pos)) - (goto-char (kcell-view:end)) - (skip-chars-backward "\n\r") - (point))) - -(defun kcell-view:expand (&optional pos label-sep-len) - "Expand cell at optional POS or point within the current view." - (save-excursion - (goto-char (kcell-view:start pos label-sep-len)) - (subst-char-in-region (point) (kcell-view:end-contents) ?\r ?\n t))) - -(defun kcell-view:forward (&optional visible-p label-sep-len) - "Move to start of the following cell at the same level as the current cell. -With optional VISIBLE-P, consider only visible cells. -Return t unless no such cell." - (or label-sep-len (setq label-sep-len - (kview:label-separator-length kview))) - (let ((opoint (point)) - (found) (done) - (curr-indent 0) - (start-indent (kcell-view:indent nil label-sep-len))) - (while (and (not (or found done)) - (kcell-view:next visible-p label-sep-len)) - (setq curr-indent (kcell-view:indent nil label-sep-len)) - (cond ((= curr-indent start-indent) - (goto-char (kcell-view:start nil label-sep-len)) - (setq found t)) - ((< curr-indent start-indent) - ;; Went past end of this tree without a match. - (setq done t) - (goto-char opoint)) - ;; else go to following node - )) - ;; If didn't find a match, return to original point. - (or found (goto-char opoint)) - found)) - -(defun kcell-view:get-attr (attribute &optional pos) - "Return ATTRIBUTE's value for current cell or cell at optional POS." - (save-excursion - (if pos (goto-char pos)) - (kcell:get-attr (kcell-view:cell) attribute))) - -(defun kcell-view:idstamp (&optional pos) - "Return idstamp string of cell at optional POS or point." - (save-excursion - (if pos (goto-char pos)) - (format "0%d" (kcell:idstamp (kcell-view:cell))))) - -(defun kcell-view:indent (&optional pos label-sep-len) - "Return indentation of cell at optional POS or point. -Optional LABEL-SEP-LEN is the view-specific length of the separator between a -cell's label and the start of its contents." - (+ (save-excursion - (kcell-view:to-label-end pos) - (current-column)) - (or label-sep-len (kview:label-separator-length kview)))) - -(defun kcell-view:label (&optional pos) - "Return displayed label string of cell at optional POS or point. -If labels are off, return cell's idstamp as a string." - (save-excursion - (if pos (goto-char pos)) - (let ((label-type (kview:label-type kview))) - (if (eq label-type 'no) - (kcell-view:idstamp) - (kcell-view:to-label-end) - (buffer-substring (point) (progn (skip-chars-backward "^ \t\n\r") - (point))))))) - -(defun kcell-view:level (&optional pos label-sep-len indent) - "Return cell level relative to top cell of the outline for current cell or one at optional POS. -0 = top cell level, 1 = 1st level in outline. -Optional LABEL-SEP-LEN is length of spaces between a cell label and its the -start of its body in the current view. Optional INDENT is the indentation in -characters of the cell whose level is desired." - (or label-sep-len (setq label-sep-len (kview:label-separator-length kview))) - (save-excursion - (if pos (goto-char pos)) - (/ (- (or indent (kcell-view:indent nil label-sep-len)) label-sep-len) - (kview:level-indent kview)))) - -(defun kcell-view:line (&optional pos) - "Return contents of cell line at point or optional POS as a string." - (save-excursion - (if pos (goto-char pos)) - (if (kview:valid-position-p) - (buffer-substring - (kotl-mode:start-of-line) - (kotl-mode:end-of-line)) - (error "(kcell-view:line): Invalid position, `%d'" (point))))) - -(defun kcell-view:next (&optional visible-p label-sep-len) - "Move to start of next cell within current view. -With optional VISIBLE-P, consider only visible cells. -Return t unless no next cell." - (let ((opoint (point)) - pos) - ;; - ;; If a subtree is collapsed, be sure we end up at the start of a visible - ;; cell rather than within an invisible one. - (if visible-p - (progn (goto-char (kcell-view:end-contents)) (end-of-line))) - (setq pos (kproperty:next-single-change (point) 'kcell)) - (if (or (null pos) - (if (goto-char pos) (kotl-mode:eobp))) - (progn (goto-char opoint) - nil) - (goto-char (kcell-view:start nil label-sep-len)) - (not (eq opoint (point)))))) - -(defun kcell-view:operate (function &optional start end) - "Invoke FUNCTION with view restricted to current cell contents. -Optional START and END are start and endpoints of cell to use." - (save-restriction - (narrow-to-region (or start (kcell-view:start)) - (or end (kcell-view:end-contents))) - (funcall function))) - -(defun kcell-view:parent (&optional visible-p label-sep-len) - "Move to start of current cell's parent within current view. -If parent is top cell, move to first cell within view and return 0. -Otherwise, return t unless optional VISIBLE-P is non-nil and the parent cell -is not part of the current view." - (or label-sep-len (setq label-sep-len (kview:label-separator-length kview))) - (let ((opoint (point)) - (parent-level (1- (kcell-view:level nil label-sep-len)))) - (if (= parent-level 0) ;; top cell - (progn (goto-char (point-min)) - (goto-char (kcell-view:start nil label-sep-len)) - 0) - ;; Skip from point back past any siblings - (while (kcell-view:backward visible-p label-sep-len)) - ;; Move back to parent. - (if (kcell-view:previous visible-p label-sep-len) - t - ;; Move back to previous point and return nil. - (goto-char opoint) - nil)))) - -(defun kcell-view:previous (&optional visible-p label-sep-len) - "Move to start of previous cell within current view. -With optional VISIBLE-P, consider only visible cells. -Return t unless no previous cell." - (let ((opoint (point)) - (pos (point))) - (goto-char (kcell-view:start nil label-sep-len)) - ;; - ;; If a subtree is collapsed, be sure we end up at the start of a visible - ;; cell rather than within an invisible one. - (if visible-p - (beginning-of-line) - (if (setq pos (kproperty:previous-single-change (point) 'kcell)) - (goto-char pos))) - (if (and pos (not (kotl-mode:bobp)) - (setq pos (kproperty:previous-single-change (point) 'kcell))) - (progn (goto-char pos) - (skip-chars-backward "\n\r") - (if visible-p (beginning-of-line)) - (goto-char (kcell-view:start nil label-sep-len)) - (not (eq opoint (point)))) - ;; No previous cell exists - (goto-char opoint) - nil))) - -(defun kcell-view:plist (&optional pos) - "Return attributes associated with cell at optional POS or point." - (kcell:plist (kcell-view:cell pos))) - -(defun kcell-view:plist-point (&optional pos) - "Return buffer position of attributes associated with cell at optional POS or point." - (save-excursion (1+ (kcell-view:to-label-end pos)))) - -(defun kcell-view:to-label-end (&optional pos) - "Move point after end of current cell's label and return point." - (if pos (goto-char pos)) - (kview:end-of-actual-line) - (cond ((null kview) - (error "(kcell-view:to-label-end): Invalid kview; try {M-x kotl-mode RET} to fix it.")) - (klabel-type:changing-flag - ;; When changing from one label type to another, e.g. alpha to - ;; legal, we can't depend on the label being of the type given by - ;; the kview, so use kcell properties to find label end. - (if (kproperty:get (1- (point)) 'kcell) - nil - ;; If not at beginning of cell contents, move there. - (goto-char (kproperty:previous-single-change (point) 'kcell))) - ;; Then move to end of label via embedded kcell property. - (goto-char (kproperty:previous-single-change (point) 'kcell))) - ((funcall (kview:get-attr kview 'to-label-end)) - (point)) - (t (error "(kcell-view:to-label-end): Can't find end of current cell's label")))) - -(defun kcell-view:reference (&optional pos relative-dir) - "Return a reference to the kcell at optional POS or point for use in a link. -The reference is a string of the form, \"<kcell-file, cell-ref>\" where -cell-ref is as described in the documentation for `kcell:ref-to-id'. -Kcell-file is made relative to optional RELATIVE-DIR before it is returned." - (format "<%s, %s=%s>" (hpath:relative-to buffer-file-name relative-dir) - (kcell-view:label pos) (kcell-view:idstamp pos))) - -(defun kcell-view:remove-attr (attribute &optional pos) - "Remove ATTRIBUTE, if any, for current cell or cell at optional POS." - (interactive "*SAttribute to remove: ") - (save-excursion - (if pos (goto-char pos)) - (let ((kcell (kcell:remove-attr (kcell-view:cell) attribute))) - (if (interactive-p) - (message "Cell <%s> now has no %s attribute." - (kcell-view:label) attribute)) - kcell))) - -(defun kcell-view:set-attr (attribute value &optional pos) - "Set ATTRIBUTE's VALUE for current cell or cell at optional POS and return the cell." - (save-excursion - (if pos (goto-char pos)) - ;; Returns kcell. - (kcell:set-attr (kcell-view:cell) attribute value))) - -(defun kcell-view:set-cell (kcell) - "Attach KCELL property to cell at point." - (save-excursion - (kcell-view:to-label-end) - (kproperty:set 'kcell kcell))) - -(defun kcell-view:sibling-p (&optional pos visible-p label-sep-len) - "Return t if cell at optional POS or point has a successor. -With optional VISIBLE-P, consider only visible siblings." - (save-excursion - (if pos (goto-char pos)) - (kcell-view:forward visible-p label-sep-len))) - -(defun kcell-view:start (&optional pos label-sep-len) - "Return start position of cell contents from optional POS or point." - (save-excursion - (+ (kcell-view:to-label-end pos) - (or label-sep-len (kview:label-separator-length kview))))) - -;;; -;;; kview - one view per buffer, multiple views per kotl -;;; - -(defun kview:add-cell (klabel level &optional contents prop-list no-fill) - "Create a new cell with full KLABEL and add it at point at LEVEL within outline. -1 = first level. Optional cell CONTENTS and PROP-LIST may also be given, as -well as NO-FILL which skips filling of any CONTENTS. -Return new cell. This function does not renumber any other cells." - (let ((new-cell (kcell:create contents (kview:id-increment kview) - prop-list))) - (kcell-view:create kview new-cell level klabel no-fill) - new-cell)) - -(defun kview:buffer (kview) - "Return kview's buffer or nil if argument is not a kview." - (if (kview:is-p kview) - (get-buffer (kview:get-attr kview 'view-buffer-name)))) - -(defun kview:create (buffer-name - &optional id-counter label-type level-indent - label-separator label-min-width blank-lines - levels-to-show lines-to-show) - "Return a new kview for BUFFER-NAME. -Optional ID-COUNTER is the maximum permanent id previously given out in this -outline. Optional LABEL-TYPE, LEVEL-INDENT, LABEL-SEPARATOR, LABEL-MIN-WIDTH, -BLANK-LINES, LEVELS-TO-SHOW, and LINES-TO-SHOW may also be given, otherwise default values are used. - - See documentation of: - `kview:default-label-type' for LABEL-TYPE, - `kview:default-level-indent' for LEVEL-INDENT, - `kview:default-label-separator' for LABEL-SEPARATOR, - `kview:default-label-min-width' for LABEL-MIN-WIDTH, - `kview:default-blank-lines' for BLANK-LINES, - `kview:default-levels-to-show' for LEVELS-TO-SHOW, - `kview:default-lines-to-show' for LINES-TO-SHOW." - - (let ((buf (get-buffer buffer-name))) - (cond ((null buf) - (error "(kview:create): No such buffer, `%s'." buffer-name)) - ((or (null id-counter) (= id-counter 0)) - (setq id-counter 0)) - ((not (integerp id-counter)) - (error "(kview:create): 2nd arg, `%s', must be an integer." id-counter))) - (set-buffer buf) - (if (and (boundp 'kview) (eq (kview:buffer kview) buf)) - ;; Don't recreate view if it exists. - nil - (make-local-variable 'kview) - (setq kview - (list 'kview 'plist - (list 'view-buffer-name buffer-name - 'top-cell - (kcell:create-top buffer-file-name id-counter) - 'label-type (or label-type kview:default-label-type) - 'label-min-width (or label-min-width - kview:default-label-min-width) - 'label-separator (or label-separator - kview:default-label-separator) - 'label-separator-length - (length (or label-separator - kview:default-label-separator)) - 'level-indent (or level-indent - kview:default-level-indent) - 'blank-lines - (or blank-lines kview:default-blank-lines) - 'levels-to-show - (or levels-to-show kview:default-levels-to-show) - 'lines-to-show - (or lines-to-show kview:default-lines-to-show) -))) - (kview:set-functions (or label-type kview:default-label-type))) - kview)) - -;;; Using this stimulates an GNU Emacs V19.19 bug in text-property handling, -;; visible when one deletes a sibling cell and then deletes the prior cell, -;; the following cell is left with a different idstamp and its label -;; displays as "0". Using delete-char here would solve the problem but we -;; suggest you upgrade to a newer version of GNU Emacs in which the bug is -;; fixed. -(defun kview:delete-region (start end) - "Delete cells between START and END points from current view." - (delete-region start end)) - -(defun kview:end-of-actual-line () - "Go to the end of the current line whether collapsed or not." - (if (re-search-forward "[\n\r]" nil 'move) - (backward-char 1))) - -(defun kview:fill-region (start end &optional kcell justify) - "Fill region between START and END within current view. -With optional KCELL, assume START and END delimit that cell's contents. -With optional JUSTIFY, justify region as well. -Fill-prefix must be a string of spaces the length of this cell's indent, when -this function is called." - (let ((opoint (set-marker (make-marker) (point))) - (label-sep-len (kview:label-separator-length kview)) - (continue t) - prev-point) - (goto-char start) - (while continue - (if (kcell:get-attr (or kcell (kcell-view:cell)) 'no-fill) - (setq continue (kcell-view:next nil label-sep-len)) - (fill-paragraph justify t) - (setq prev-point (point)) - (forward-paragraph) - (re-search-forward "[^ \t\n\r]" nil t)) - (setq continue (and continue - (/= (point) prev-point) - (< (point) (min end (point-max)))))) - ;; Return to original point. - (goto-char opoint) - (set-marker opoint nil))) - -(cond ((and hyperb:xemacs-p (or (>= emacs-minor-version 12) - (> emacs-major-version 19))) - (defun kview:goto-cell-id (id-string) - "Move point to start of cell with idstamp ID-STRING and return t, else nil." - (let ((cell-id (string-to-int id-string)) - label-end kcell) - (setq label-end - (map-extents - (function (lambda (extent unused) - (setq kcell (extent-property extent 'kcell)) - (if (= (kcell:idstamp kcell) cell-id) - (extent-end-position extent)))) - nil nil nil nil nil 'kcell)) - (if (null label-end) - nil - (goto-char label-end) - t)))) - (hyperb:lemacs-p - (defun kview:goto-cell-id (id-string) - "Move point to start of cell with idstamp ID-STRING and return t, else nil." - (let ((cell-id (string-to-int id-string)) - label-end kcell) - (setq label-end - (map-extents - (function (lambda (extent unused) - (setq kcell (extent-property extent 'kcell)) - (and kcell (= (kcell:idstamp kcell) cell-id) - (extent-end-position extent)))))) - (if (null label-end) - nil - (goto-char label-end) - t)))) - ;; Emacs 19 - (t (defun kview:goto-cell-id (id-string) - "Move point to start of cell with idstamp ID-STRING and return t, else nil." - (let ((cell-id (string-to-int id-string)) - (opoint (point)) - pos kcell) - (goto-char (point-min)) - (while (and (setq pos - (kproperty:next-single-change (point) 'kcell)) - (goto-char pos) - (or (null (setq kcell (kproperty:get pos 'kcell))) - (/= (kcell:idstamp kcell) cell-id)))) - (if pos - (progn - (forward-char (kview:label-separator-length kview)) - t) - (goto-char opoint) - nil)))) -) - -(defun kview:id-increment (kview) - "Return next idstamp (an integer) for KVIEW." - (let* ((top-cell (kview:get-attr kview 'top-cell)) - (counter (1+ (kcell:get-attr top-cell 'id-counter)))) - (kcell:set-attr top-cell 'id-counter counter) - counter)) - -(defun kview:idstamp-to-label (permanent-id) - "Return relative label for cell with PERMANENT-ID within current kview." - (save-excursion - (if (kotl-mode:goto-cell permanent-id) - (kcell-view:label)))) - -(defun kview:insert-contents (kcell contents no-fill fill-prefix) - "Insert KCELL's CONTENTS into view at point and fill resulting paragraphs, unless NO-FILL is non-nil. -FILL-PREFIX is the indentation string for the current cell. -If CONTENTS is nil, get contents from KCELL. Return contents inserted (this -value may differ from the value passed in.)" - (let ((start (point)) - end) - (setq contents (or contents (kcell:contents kcell) "")) - (insert contents) - ;; - ;; Delete any extra newlines at end of cell contents. - (setq end (point)) - (skip-chars-backward "\n\r") - (delete-region (point) end) - (setq end (point)) - ;; - (save-restriction - (if no-fill - ;; Insert proper indent in all but the first line which has - ;; already been indented. - (progn - (narrow-to-region start end) - (goto-char (point-min)) - (while (re-search-forward "[\n\r]" nil t) - (insert fill-prefix)) - (goto-char (point-max))) - ;; - ;; Filling cell will insert proper indent on all lines. - (if (equal contents "") - nil - (goto-char start) - (beginning-of-line) - (narrow-to-region (point) end) - ;; Add fill-prefix to all but paragraph separator lines, so - ;; filling is done properly. - (while (re-search-forward "[\n\r][^\n\r]" nil t) - (forward-char -1) (insert fill-prefix)) - (kview:fill-region start end kcell) - (goto-char (point-min)) - ;; Now add fill-prefix to paragraph separator lines. - (while (re-search-forward "[\n\r][\n\r]" nil t) - (forward-char -1) (insert fill-prefix)) - ;; - (goto-char (point-max)))))) - contents) - -(defun kview:is-p (object) - "Is OBJECT a kview?" - (if (listp object) (eq (car object) 'kview))) - -(defun kview:kotl (kview) - "Return kview's kotl object or nil if argument is not a kview." - (if (kview:is-p kview) - (kview:get-attr kview 'kotl))) - -(defun kview:label (klabel-function prev-label child-p) - "Return label string to display for current cell computed from KLABEL-FUNCTION, PREV-LABEL and CHILD-P." - (funcall klabel-function prev-label child-p)) - -(defun kview:label-function (kview) - "Return function which will return display label for current cell in KVIEW. -Function signature is: (func prev-label &optional child-p), where prev-label -is the display label of the cell preceding the current one and child-p is -non-nil if cell is to be the child of the preceding cell." - (kview:get-attr kview 'label-function)) - -(defun kview:label-min-width (kview) - "Return kview's label-min-width setting or nil if argument is not a kview. -See documentation for kview:default-label-min-width." - (if (kview:is-p kview) - (kview:get-attr kview 'label-min-width))) - -(defun kview:label-separator (kview) - "Return kview's label-separator setting or nil if argument is not a kview. -See documentation for kview:default-label-separator." - (if (kview:is-p kview) - (kview:get-attr kview 'label-separator))) - -(defun kview:label-separator-length (kview) - "Return kview's label-separator length or nil if argument is not a kview. -See documentation for kview:default-label-separator." - (kview:get-attr kview 'label-separator-length)) - -(defun kview:label-type (kview) - "Return kview's label-type setting or nil if argument is not a kview. -See documentation for kview:default-label-type." - (if (kview:is-p kview) - (kview:get-attr kview 'label-type))) - -(defun kview:level-indent (kview) - "Return kview's level-indent setting or nil if argument is not a kview. -See documentation for kview:default-level-indent." - (if (kview:is-p kview) - (kview:get-attr kview 'level-indent))) - -(defun kview:map-branch (func kview &optional first-p visible-p) - "Applies FUNC to the sibling trees from point forward within KVIEW and returns results as a list. -With optional FIRST-P non-nil, begins with first sibling in current branch. -With optional VISIBLE-P, considers only those sibling cells that are visible -in the view. - -FUNC should take one argument, the kview local variable of the current -buffer or some other kview, and should operate upon the cell at point. - -`Cell-indent' contains the indentation value of the first cell mapped when -FUNC is called so that it may test against this value. `Label-sep-len' -contains the label separator length. - -See also `kview:map-siblings' and `kview:map-tree'." - (save-excursion - (set-buffer (kview:buffer kview)) - (let ((results) - (label-sep-len (kview:label-separator-length kview))) - (if first-p - ;; Move back to first predecessor at same level. - (while (kcell-view:backward t label-sep-len))) - (let ((cell-indent (kcell-view:indent nil label-sep-len))) - ;; Terminate when no further cells or when reach a cell at an equal - ;; or higher level in the kotl than the first cell that we processed. - (while (and (progn (setq results (cons (funcall func kview) results)) - (kcell-view:next visible-p label-sep-len)) - (> (kcell-view:indent nil label-sep-len) cell-indent)))) - (nreverse results)))) - -(defun kview:map-siblings (func kview &optional first-p visible-p) - "Applies FUNC to the sibling cells from point forward within KVIEW and returns results as a list. -With optional FIRST-P non-nil, begins with first sibling in current branch. -With optional VISIBLE-P, considers only those sibling cells that are visible -in the view. - -FUNC should take one argument, the kview local variable of the current -buffer or some other kview, and should operate upon the cell at point. - -`Cell-indent' contains the indentation value of the first cell mapped when -FUNC is called so that it may test against this value. `Label-sep-len' -contains the label separator length. - -See also `kview:map-branch' and `kview:map-tree'." - (save-excursion - (set-buffer (kview:buffer kview)) - (let ((results) - (label-sep-len (kview:label-separator-length kview))) - (if first-p - ;; Move back to first predecessor at same level. - (while (kcell-view:backward t label-sep-len))) - (let ((cell-indent (kcell-view:indent nil label-sep-len))) - ;; Terminate when no further cells at same level. - (while (progn (setq results (cons (funcall func kview) results)) - (kcell-view:forward visible-p label-sep-len)))) - (nreverse results)))) - -(defun kview:map-tree (func kview &optional top-p visible-p) - "Applies FUNC to the tree starting at point within KVIEW and returns results as a list. -With optional TOP-P non-nil, maps over all of kview's cells. -With optional VISIBLE-P, considers only those cells that are visible in the -view. - -FUNC should take one argument, the kview local variable of the current -buffer or some other kview, and should operate upon the cell at point. - -`Cell-indent' contains the indentation value of the first cell mapped when -FUNC is called so that it may test against this value. `Label-sep-len' -contains the label separator length. - -See also `kview:map-branch' and `kview:map-siblings'." - (let ((results) - (label-sep-len (kview:label-separator-length kview))) - (save-excursion - (set-buffer (kview:buffer kview)) - (if top-p - (progn (goto-char (point-min)) - (kview:end-of-actual-line) - ;; Terminate when no further cells to process. - (while (progn - (setq results (cons (funcall func kview) results)) - (kcell-view:next visible-p label-sep-len)))) - (let ((cell-indent (kcell-view:indent nil label-sep-len))) - ;; Terminate when no further cells or when reach a cell at an equal - ;; or higher level in the kotl than the first cell that we processed. - (while (and (progn (setq results (cons (funcall func kview) results)) - (kcell-view:next visible-p label-sep-len)) - (> (kcell-view:indent nil label-sep-len) - cell-indent)))))) - (nreverse results))) - -(defun kview:move (from-start from-end to-start from-indent to-indent - &optional copy-p fill-p) - "Move tree between FROM-START and FROM-END to TO-START, changing FROM-INDENT to TO-INDENT. -Copy tree if optional COPY-P is non-nil. Refill cells if optional -FILL-P is non-nil. Leave point at TO-START." - (let ((region (buffer-substring from-start from-end)) - (new-start (set-marker (make-marker) to-start)) - collapsed-cells expr new-end space) - ;; - ;; Move or copy tree region to new location. - (or copy-p (delete-region from-start from-end)) - (goto-char new-start) - (insert region) - (setq new-end (point)) - ;; - ;; Change indentation of tree cells. - (if (/= from-indent to-indent) - (save-restriction - (narrow-to-region new-start new-end) - ;; Store list of which cells are presently collapsed. - (setq collapsed-cells - (kview:map-tree - (function (lambda (view) - ;; Use free variable label-sep-len bound in - ;; kview:map-tree for speed. - (kcell-view:collapsed-p nil label-sep-len))) - kview t)) - ;; Expand all cells. - (subst-char-in-region new-start new-end ?\r ?\n t) - ;; - (goto-char (point-min)) - (if (< from-indent to-indent) - ;; Add indent - (progn - (setq expr (make-string (1+ (- to-indent from-indent)) ?\ )) - (while (re-search-forward "^ " nil t) - (replace-match expr t t) - (forward-line 1))) - ;; Reduce indent in all but first cell lines. - (setq expr (concat "^" (make-string - (- from-indent to-indent) ?\ ))) - (while (re-search-forward expr nil t) - (replace-match "" t t) - (forward-line 1)) - ;; Reduce indent in first cell lines which may have an - ;; autonumber or other cell delimiter. - (setq space (- from-indent to-indent - (kview:label-separator-length kview) - 1)) - (if (zerop space) - nil - (setq expr (concat "^" (make-string - (- from-indent to-indent - (kview:label-separator-length kview) - 1) - ?\ ))) - (kview:map-tree - (function (lambda (view) - (save-excursion - (beginning-of-line) - (if (looking-at expr) - (replace-match "" t t))))) - kview t))) - ;; - (if fill-p - ;; Refill cells without no-fill attribute. - (kview:map-tree (function (lambda (view) - (kotl-mode:fill-cell nil t))) - kview t)) - ;; - ;; Collapse temporarily expanded cells. - (if (delq nil collapsed-cells) - (kview:map-tree - (function - (lambda (view) - (if (car collapsed-cells) - ;; Use free variable label-sep-len bound in - ;; kview:map-tree for speed. - (kcell-view:collapse nil label-sep-len)) - (setq collapsed-cells (cdr collapsed-cells)))) - kview t)))) - ;; - (goto-char new-start) - ;; - ;; Delete temporary markers. - (set-marker new-start nil))) - -(defun kview:set-buffer-name (kview new-name) - "Set kview's buffer name to NEW-NAME." - (if (kview:is-p kview) - (save-excursion - (let ((buf (kview:buffer kview))) - (if buf (set-buffer buf))) - (kview:set-attr kview 'view-buffer-name new-name)) - (error "(kview:set-buffer-name): Invalid kview argument"))) - -(defun kview:set-label-type (kview new-type) - "Change kview's label display type to NEW-TYPE, updating all displayed labels. -See documentation for variable, kview:default-label-type, for -valid values of NEW-TYPE." - (interactive (list kview - (let ((completion-ignore-case) - (label-type (kview:label-type kview)) - new-type-str) - (if (string= - "" - (setq new-type-str - (completing-read - (format "View label type (current = %s): " - label-type) - '(("alpha") ("legal") ("id") ("no") - ("partial-alpha") ("star")) - nil t))) - label-type - (intern new-type-str))))) - (if (not (memq new-type '(alpha legal id no partial-alpha star))) - (error "(kview:set-label-type): Invalid label type, `%s'." new-type)) - ;; Disable use of partial-alpha for now since it is broken. - (if (eq new-type 'partial-alpha) - (error "(kview:set-label-type): Partial-alpha labels don't work, choose another type")) - (let ((old-label-type (kview:label-type kview))) - (if (eq old-label-type new-type) - nil - (klabel-type:set-labels new-type) - (kview:set-attr kview 'label-type new-type) - (kview:set-functions new-type) - (kvspec:update t)))) - -(defun kview:top-cell (kview) - "Return kview's invisible top cell with idstamp 0 or nil if argument is not a kview." - (if (kview:is-p kview) - (kview:get-attr kview 'top-cell))) - -(defun kview:valid-position-p (&optional pos) - "Return non-nil iff point or optional POS is at a position where editing may occur. -The read-only positions between cells and within cell indentations are invalid." - (cond ((null pos) - (>= (current-column) (kcell-view:indent))) - ((not (integer-or-marker-p pos)) - (error "(kview:valid-position-p): Argument POS not an integer -or marker, `%s'" pos)) - ((or (< pos (point-min)) (> pos (point-max))) - (error "(kview:valid-position-p): Invalid POS argument, `%d'" - pos)) - (t (save-excursion - (goto-char pos) - (>= (current-column) (kcell-view:indent)))))) - -;;; ************************************************************************ -;;; Private functions -;;; ************************************************************************ - -(defun kview:get-attr (obj attribute) - "Return the value of OBJECT's ATTRIBUTE." - (car (cdr (memq attribute (car (cdr (memq 'plist obj))))))) - -(defun kview:set-attr (obj attribute value) - "Set OBJECT's ATTRIBUTE to VALUE and return VALUE." - (let* ((plist-ptr (cdr (memq 'plist obj))) - (plist (car plist-ptr)) - (attr (memq attribute plist))) - (if attr - (setcar (cdr attr) value) - (setcar plist-ptr - (nconc (list attribute value) plist))) - value)) - -(defun kview:set-functions (label-type) - "Setup functions which handle labels of LABEL-TYPE for current view." - (kview:set-attr kview 'label-function (klabel-type:function label-type)) - (kview:set-attr kview 'label-child (klabel-type:child label-type)) - (kview:set-attr kview 'label-increment (klabel-type:increment label-type)) - (kview:set-attr kview 'label-parent (klabel-type:parent label-type)) - (kview:set-attr kview 'to-label-end (klabel-type:to-label-end label-type))) - -(defun kview:set-label-separator (label-separator &optional set-default-p) - "Set the LABEL-SEPARATOR (a string) between labels and cell contents for the current kview. -With optional prefix arg SET-DEFAULT-P, the default separator value used for -new outlines is also set to this new value." - (interactive - (progn (barf-if-buffer-read-only) - (list (if (kview:is-p kview) - (read-string - (format - "Change current%s label separator from \"%s\" to: " - (if current-prefix-arg " and default" "") - (kview:label-separator kview)))) - current-prefix-arg))) - - (barf-if-buffer-read-only) - (cond ((not (kview:is-p kview)) - (error "(kview:set-label-separator): This is not a koutline")) - ((not (stringp label-separator)) - (error "(kview:set-label-separator): Invalid separator, \"%s\"" - label-separator)) - ((< (length label-separator) 2) - (error "(kview:set-label-separator): Separator must be two or more characters, \"%s\"" - label-separator))) - - (let* ((old-sep-len (kview:label-separator-length kview)) - (sep-len (length label-separator)) - (sep-len-increase (- sep-len old-sep-len)) - (indent) - (reindent-function - (cond ((zerop sep-len-increase) - (function (lambda ()))) - ((> sep-len-increase 0) - ;; Increase indent in each cell line. - (function (lambda () - (goto-char (point-min)) - (setq indent (make-string - sep-len-increase ?\ )) - (while (re-search-forward "[^\n\r][\n\r] " nil t) - (insert indent))))) - (t - ;; Decrease indent in each cell line. - (function (lambda () - (goto-char (point-min)) - (setq indent - (concat "[^\n\r][\n\r]" - (make-string - (- sep-len-increase) ?\ ))) - (while (re-search-forward indent nil t) - (delete-region - (+ (match-beginning 0) 2) (match-end 0)))))))) - pos) - (save-excursion - (goto-char (point-min)) - (kproperty:replace-separator pos label-separator old-sep-len) - ;; Reindent all lines in cells except the first line which has already - ;; been done. - (funcall reindent-function)) - (kview:set-attr kview 'label-separator label-separator) - (kview:set-attr kview 'label-separator-length sep-len) - (if set-default-p - (setq kview:default-label-separator label-separator)))) - -(provide 'kview)
--- a/lisp/hyperbole/kotl/kvspec.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,380 +0,0 @@ -;;!emacs -;; -;; FILE: kvspec.el -;; SUMMARY: Koutline view specification. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: outlines, wp -;; -;; AUTHOR: Bob Weiner -;; -;; ORIG-DATE: 21-Oct-95 at 15:17:07 -;; LAST-MOD: 6-Mar-97 at 01:17:04 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1995, Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; -;;; Koutliner view specs -;; + means support code has been written already. -;; -;; + all: Show all lines of cells and all cells in the outline. -;; + blank: Blank lines are on. -;; b - on -;; + cutoff: Show only NUM lines per cell, 0 = all -;; c - set default cutoff lines -;; cNUM - set cutoff lines to NUM -;; descend: Only entries below this entry -;; + elide: Ellipses are on. -;; e - ellipses on -;; filter: Regexp or filter program to select entries for view, -;; off=select non-matching entries -;; glue: Freeze any group of entries selected to stay at top of -;; window, off=freeze those not-in-group. -;; include: Include an entry referenced by a link. -;; + level: Some levels are hidden. -;; l - set default level clipping -;; lNUM - set level clipping to NUM -;; name: Display leading names within cells. -;; m - show names -;; + number: Cell numbers are on -;; n - set default labels -;; n0 - display idstamp labels -;; n1 - display alpha labels -;; n2 - display partial alpha labels -;; n. - display legal labels -;; n* - display star labels -;; n~ - turn off labels -;; rest: Only following cells. -;; synthesize: Use a named generator function to generate entries for -;; view. -;; view: Turn koutliner view mode on. Standard insertion keys then -;; can be used for browsing and view setting. -;; -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Other required Elisp libraries -;;; ************************************************************************ - -(require 'kview) - -;;; ************************************************************************ -;;; Public variables -;;; ************************************************************************ - -(defvar kvspec:current nil - "String that represents the current view spec. -It is local to each koutline. Nil value means it has not been set yet.") - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -(defun kvspec:activate (&optional view-spec) - "Activate optional VIEW-SPEC or existing view spec in the current koutline. -VIEW-SPEC is a string or t, which means recompute the current view spec. See -<${hyperb:dir}/kotl/EXAMPLE.kotl, 2b17=048> for details on valid view specs." - (interactive (list (read-string "Set view spec: " kvspec:current))) - (kotl-mode:is-p) - (if (or (equal view-spec "") (equal view-spec kvspec:current)) - (setq view-spec nil)) - (kvspec:initialize) - (kvspec:update view-spec) - (kvspec:update-view)) - -(defun kvspec:initialize () - "Ensure that view spec settings will be local to the current buffer." - (if (and (fboundp 'local-variable-p) - (local-variable-p 'kvspec:current (current-buffer))) - nil - (make-local-variable 'kvspec:current) - (make-local-variable 'kvspec:string))) - -(defun kvspec:levels-to-show (levels-to-keep) - "Hide all cells in outline at levels deeper than LEVELS-TO-KEEP (a number). -Shows any hidden cells within LEVELS-TO-KEEP. 1 is the first level. 0 means -display all levels of cells." - (if (null levels-to-keep) - (setq levels-to-keep - (read-from-minibuffer "Show cells down to level (0 = show all levels): " - nil nil t))) - (setq levels-to-keep (prefix-numeric-value levels-to-keep)) - (if (< levels-to-keep 0) - (error "(kvspec:levels-to-show): Must display at least one level.")) - (kview:map-tree - (function (lambda (kview) - (if (/= (kcell-view:level) levels-to-keep) - (kotl-mode:show-tree) - (kotl-mode:hide-subtree) - ;; Move to last cell in hidden subtree, to skip further - ;; processing of these cells. - (if (kcell-view:next t) - (kcell-view:previous) - (goto-char (point-max)))))) - kview t) - (kview:set-attr kview 'levels-to-show levels-to-keep)) - -(defun kvspec:show-lines-per-cell (num) - "Show NUM lines per cell." - (if (and (integerp num) (>= num 0)) - nil - (error "(kvspec:show-lines-per-cell): Invalid lines per cell, `%d'" num)) - (kview:set-attr kview 'lines-to-show num) - (let (start end count) - (if (zerop num) - ;; Show all lines in cells. - (kview:map-tree - (function - (lambda (kview) - ;; Use free variable label-sep-len bound in kview:map-tree for - ;; speed. - (setq start (goto-char (kcell-view:start nil label-sep-len)) - end (kcell-view:end-contents)) - ;; Show all lines in cell. - (subst-char-in-region start end ?\r ?\n t))) - kview t t) - ;; Show NUM lines in cells. - (kview:map-tree - (function - (lambda (kview) - ;; Use free variable label-sep-len bound in kview:map-tree for speed. - (setq start (goto-char (kcell-view:start nil label-sep-len)) - end (kcell-view:end-contents) - count (1- num)) - ;; Hide all lines in cell. - (subst-char-in-region start end ?\n ?\r t) - ;; Expand num - 1 newlines to show num lines. - (while (and (> count 0) (search-forward "\r" end t)) - (replace-match "\n") (setq count (1- count))))) - kview t t)))) - -(defun kvspec:toggle-blank-lines () - "Toggle blank lines between cells on or off." - (interactive) - (setq kvspec:current - (if (string-match "b" kvspec:current) - (hypb:replace-match-string "b" kvspec:current "" t) - (concat "b" kvspec:current))) - (kvspec:blank-lines) - (kvspec:update-modeline)) - -(defun kvspec:update (view-spec) - "Update current view spec according to VIEW-SPEC but don't change the view. -VIEW-SPEC is a string or t, which means recompute the current view spec. See -<${hyperb:dir}/kotl/EXAMPLE.kotl, 2b17=048> for details on valid view specs." - (cond ((stringp view-spec) - ;; Use given view-spec after removing extraneous characters. - (setq kvspec:current - (hypb:replace-match-string - "[^.*~0-9abcdefgilnrsv]+" view-spec "" t))) - ((or (eq view-spec t) (null kvspec:current)) - (setq kvspec:current (kvspec:compute)))) - ;; Update display using current specs. - (kvspec:update-modeline)) - -;;; ************************************************************************ -;;; Private functions -;;; ************************************************************************ - -(defun kvspec:blank-lines () - "Turn blank lines on or off according to `kvspec:current'." - (let ((modified-p (buffer-modified-p)) - (buffer-read-only)) - (if (string-match "b" kvspec:current) - ;; On - (progn (kview:set-attr kview 'blank-lines t) - (kproperty:remove (point-min) (point-max) '(invisible t))) - ;; Off - (kview:set-attr kview 'blank-lines nil) - (save-excursion - (goto-char (point-max)) - (while (re-search-backward "[\n\r][\n\r]" nil t) - ;; Make blank lines invisible. - (kproperty:put (1+ (point)) (min (+ (point) 2) (point-max)) - '(invisible t))))) - (set-buffer-modified-p modified-p))) - -(defun kvspec:compute () - "Compute and return current view spec string." - (concat - - ;; a - Show all cells and cell lines. - ;; Never compute this setting (use it only within links) since it will - ;; expose all carefully hidden outline items if the user forgets to turn - ;; it off when he resets the view specs. - - ;; b - blank separator lines - (if (kview:get-attr kview 'blank-lines) "b") - - ;; c - cutoff lines per cell - (let ((lines (kview:get-attr kview 'lines-to-show))) - (if (zerop lines) - nil - (concat "c" (int-to-string lines)))) - - ;; e - ellipses on - (if selective-display-ellipses "e") - - ;; l - hide some levels - (let ((levels (kview:get-attr kview 'levels-to-show))) - (if (zerop levels) - nil - (concat "l" (int-to-string levels)))) - - ;; n - numbering type - (let ((type (kview:label-type kview))) - (cond ((eq type 'no) nil) - ((eq type kview:default-label-type) "n") - (t (concat "n" (char-to-string - (car (rassq (kview:label-type kview) - kvspec:label-type-alist))))))))) - -(defun kvspec:elide () - "Turn ellipses display following clipped cells on or off according to `kvspec:current'." - (setq selective-display-ellipses - (if (string-match "e" kvspec:current) t))) - -(defun kvspec:hide-levels () - "Show a set number of cell levels according to `kvspec:current'." - ;; "l" means use value of kview:default-levels-to-show. - ;; "l0" means show all levels. - (let (levels) - (if (not (string-match "l\\([0-9]+\\)?" kvspec:current)) - ;; Don't change the view if no view spec is given but note that - ;; all levels should be shown in the future. - (kview:set-attr kview 'levels-to-show 0) - (if (match-beginning 1) - (setq levels (string-to-int - (substring kvspec:current (match-beginning 1) - (match-end 1)))) - (setq levels kview:default-levels-to-show)) - (kview:set-attr kview 'levels-to-show levels) - (kvspec:levels-to-show levels)))) - -(defun kvspec:lines-to-show () - "Show a set number of lines per cell according to `kvspec:current'." - ;; "c" means use value of kview:default-lines-to-show. - ;; "c0" means show all lines. - (cond ((not (string-match "c\\([0-9]+\\)?" kvspec:current)) - ;; Don't change the view if no view spec is given but note that all - ;; lines should be shown in the future. - (kview:set-attr kview 'lines-to-show 0)) - ((match-beginning 1) - (kvspec:show-lines-per-cell - (string-to-int (substring kvspec:current (match-beginning 1) - (match-end 1))))) - (t (kvspec:show-lines-per-cell kview:default-lines-to-show)))) - -(defun kvspec:numbering () - "Set the type of numbering (label) display according to `kvspec:current'." - (if (not (string-match "n\\([.*~0-2]\\)?" kvspec:current)) - nil - ;; "n" means use value of kview:default-label-type. - ;; "n0" means display idstamps. - ;; "n1" means display alpha labels. - ;; "n2" means display partial alpha labels. - ;; "n." means display legal labels. - ;; "n*" means star labels. - ;; "n~" means no labels. - (let (spec type) - (if (match-beginning 1) - (setq spec (string-to-char - (substring kvspec:current - (match-beginning 1) (match-end 1))) - type (cdr (assq spec kvspec:label-type-alist))) - (setq type kview:default-label-type)) - (kview:set-label-type kview type)))) - -(defun kvspec:update-modeline () - "Setup or update display of the current kview spec in the modeline." - (if (stringp kvspec:current) - (setq kvspec:string (format kvspec:string-format kvspec:current))) - (if (memq 'kvspec:string mode-line-format) - nil - (setq mode-line-format (copy-sequence mode-line-format)) - (let ((elt (or (memq 'mode-line-buffer-identification mode-line-format) - (memq 'modeline-buffer-identification - mode-line-format)))) - (if elt - (setcdr elt (cons 'kvspec:string (cdr elt))) - ;; - ;; XEmacs 19.14 introduced extents into the modeline that we - ;; must work around. - (if (and hyperb:xemacs-p (string-lessp "19.14" hyperb:xemacs-p)) - (let ((mf modeline-format) - elt) - (while mf - (setq elt (car mf)) - (if (and (consp elt) (eq (cdr elt) 'modeline-buffer-identification)) - (progn (setcdr mf (cons 'kvspec:string (cdr mf))) - (setq mf nil))) - (setq mf (cdr mf))))))))) - -(defun kvspec:update-view () - "Update view according to current setting of local `kvspec:current' variable." - (let ((modified-p (buffer-modified-p)) - (buffer-read-only)) - (save-excursion - - (if (string-match "a" kvspec:current) - (kotl-mode:show-all)) - - (kvspec:blank-lines) ;; b - - ;; This must come before kvspec:lines-to-show or else it could show - ;; lines that should be hidden. - (kvspec:hide-levels) ;; l - - (kvspec:lines-to-show) ;; c - - (if (string-match "d" kvspec:current) - nil) - - (kvspec:elide) ;; e - - (if (string-match "f" kvspec:current) - nil) - - (if (string-match "g" kvspec:current) - nil) - - (if (string-match "i" kvspec:current) - nil) - - (if (string-match "r" kvspec:current) - nil) - - (if (string-match "s" kvspec:current) - nil) - - ;; Do this last since it can trigger an error if partial alpha is - ;; selected. - (kvspec:numbering) ;; n - - ) - (set-buffer-modified-p modified-p))) - -;;; ************************************************************************ -;;; Private variables -;;; ************************************************************************ - -(defvar kvspec:label-type-alist - '((?0 . idstamp) (?1 . alpha) (?2 . partial-alpha) - (?. . legal) (?* . star) (?~ . no)) - "Alist of (view-spec-character . label-type) pairs.") - -(defvar kvspec:string "" - "String displayed in koutline modelines to reflect the current view spec. -It is local to each koutline. Set this to nil to disable modeline display of -the view spec settings.") - -(defvar kvspec:string-format " <|%s>" - "Format of the kview spec modeline display. -It must contain a `%s' which is replaced with the current set of view spec -characters at run-time.") - -(provide 'kvspec)
--- a/lisp/hyperbole/set.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,220 +0,0 @@ -;;!emacs -;; -;; FILE: set.el -;; SUMMARY: Provide general mathematical operators on unordered sets. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: extensions, tools -;; -;; AUTHOR: Bob Weiner -;; ORG: Brown U. -;; -;; ORIG-DATE: 26-Sep-91 at 19:24:19 -;; LAST-MOD: 14-Apr-95 at 16:17:03 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1991-1995, Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; -;; All set operations herein work with sets of arbitrary Lisp objects, -;; including strings. By default, they use 'equal' for comparisons -;; but this may be overidden by changing the function bound to -;; the 'set:equal-op' variable. -;; -;; DESCRIP-END. - -;; ************************************************************************ -;; Other required Elisp libraries -;; ************************************************************************ - -;; ************************************************************************ -;; Public variables -;; ************************************************************************ - -(defvar set:equal-op 'equal - "Comparison function used by set operators. -It must be a function of two arguments which returns non-nil only when -the arguments are equivalent.") - -;; ************************************************************************ -;; Public functions -;; ************************************************************************ - -(defmacro set:add (elt set) - "Adds element ELT to SET and then returns SET. -Uses 'set:equal-op' for comparison. -Use (setq set (set:add elt set)) to assure set is always properly modified." - (` (cond ((set:member (, elt) (, set)) (, set)) - ((, set) (setq (, set) (cons (, elt) (, set)))) - (t (list (, elt)))))) - -(defun set:combinations (set &optional arity) - "Returns all possible combinations (subsets) of SET. -Assumes SET is a valid set. With optional ARITY, returns only subsets with -ARITY members." - (cond ((null arity) - (setq arity 0) - (cons nil (apply 'nconc (mapcar (function - (lambda (elt) - (setq arity (1+ arity)) - (set:combinations set arity))) - set)))) - ((= arity 1) set) - ((<= arity 0) '(nil)) - (t (let ((rest) (ctr 1)) - (apply - 'nconc - (mapcar (function - (lambda (first) - (setq rest (nthcdr ctr set) - ctr (1+ ctr)) - (mapcar (function - (lambda (elt) - (if (listp elt) (cons first elt) - (list first elt)))) - (set:combinations rest (1- arity))))) - set)))))) - -(defun set:create (&rest elements) - "Returns a new set created from any number of ELEMENTS or a list of ELEMENTS. -Uses 'set:equal-op' for comparison." - (let ((set)) - (mapcar (function - (lambda (elt) (or (set:member elt set) - (setq set (cons elt set))))) - (if (or (null (car elements)) (not (listp (car elements)))) - elements - (car elements))) - set)) - -(fset 'set:delete 'set:remove) -(defun set:difference (&rest sets) - "Returns difference of any number of SETS. -Difference is the set of elements in the first set that are not in any of the -other sets. Uses 'set:equal-op' for comparison." - (let ((rtn-set (set:members (car sets)))) - (mapcar - (function - (lambda (set) - (mapcar (function - (lambda (elt) (set:remove elt rtn-set))) - set))) - (cdr sets)) - rtn-set)) - -(defun set:equal (set1 set2) - "Returns t iff SET1 contains the same members as SET2. Both must be sets. -Uses 'set:equal-op' for comparison." - (and (listp set1) (listp set2) - (= (set:size set1) (set:size set2)) - (set:subset set1 set2))) - -(defun set:get (key set) - "Returns the value associated with KEY in SET or nil. -Elements of SET should be of the form (key . value)." - (cdr (car (let ((set:equal-op - (function (lambda (key elt) - (equal key (car elt)))))) - (set:member key set))))) - -(defun set:intersection (&rest sets) - "Returns intersection of all SETS given as arguments. -Uses 'set:equal-op' for comparison." - (let ((rtn-set)) - (mapcar - (function - (lambda (elt) - (or (memq nil (mapcar (function - (lambda (set) (set:member elt set))) - (cdr sets))) - (setq rtn-set (cons elt rtn-set))))) - (car sets)) - rtn-set)) - -(defun set:is (obj) - "Returns t if OBJ is a set (a list with no repeated elements). -Uses 'set:equal-op' for comparison." - (and (listp obj) - (let ((lst obj)) - (while (and (not (set:member (car lst) (cdr lst))) - (setq lst (cdr lst)))) - (null lst)))) - -(fset 'set:map 'mapcar) - -(defun set:member (elt set) - "Returns non-nil if ELT is an element of SET. -The value is actually the tail of SET whose car is ELT. -Uses 'set:equal-op' for comparison." - (while (and set (not (funcall set:equal-op elt (car set)))) - (setq set (cdr set))) - set) - -(defun set:members (list) - "Returns set of unique elements of LIST. -Uses 'set:equal-op' for comparison. See also 'set:create'." - (let ((set)) - (mapcar (function - (lambda (elt) (or (set:member elt set) (setq set (cons elt set))))) - list) - set)) - -(defmacro set:remove (elt set) - "Removes element ELT from SET and returns new set. -Assumes SET is a valid set. Uses 'set:equal-op' for comparison. -Use (setq set (set:remove elt set)) to assure set is always properly modified." - (` (let ((rest (set:member (, elt) (, set))) - (rtn (, set))) - (if rest - (cond ((= (length rtn) 1) (setq rtn nil)) - ((= (length rest) 1) - (setcdr (nthcdr (- (length rtn) 2) rtn) nil)) - (t (setcar rest (car (cdr rest))) - (setcdr rest (cdr (cdr rest)))))) - rtn))) - -(defun set:replace (key value set) - "Replaces or adds element whose car matches KEY with element (KEY . VALUE) in SET. -Returns set if modified, else nil. -Use (setq set (set:replace elt set)) to assure set is always properly modified. - -Uses 'set:equal-op' to match against KEY. Assumes each element in the set -has a car and a cdr." - (let ((elt-set (set:member key set))) - (if elt-set - ;; replace element - (progn (setcar elt-set (cons key value)) - set) - ;; add new element - (cons (cons key value) set)))) - -(fset 'set:size 'length) - -(defun set:subset (sub set) - "Returns t iff set SUB is a subset of SET. -Uses 'set:equal-op' for comparison." - (let ((is t)) - (mapcar (function (lambda (elt) (if is (setq is (set:member elt set))))) sub) - (and is t))) - -(defun set:union (&rest sets) - "Returns union of all SETS given as arguments. -Uses 'set:equal-op' for comparison." - (let ((rtn-set)) - (mapcar - (function - (lambda (set) (mapcar (function - (lambda (elt) - (setq rtn-set (set:add elt rtn-set)))) - set))) - sets) - rtn-set)) - -;; ************************************************************************ -;; Private variables -;; ************************************************************************ - -(provide 'set)
--- a/lisp/hyperbole/smart-clib-sym Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,63 +0,0 @@ -#!/bin/csh -f -# -# SUMMARY: Test whether symbol appears within a set of C libraries. -# USAGE: <script-name> <symbol-string> -# -# AUTHOR: Bob Weiner -# ORG: Brown U. -# -# ORIG-DATE: 5-Oct-91 at 03:29:05 -# LAST-MOD: 25-Aug-95 at 02:23:17 by Bob Weiner -# -# This file is part of Hyperbole. -# Available for use and distribution under the same terms as GNU Emacs. -# -# Copyright (C) 1991-1995, Free Software Foundation, Inc. -# Developed with support from Motorola Inc. -# -# DESCRIPTION: -# -# Create the file given by the variable 'clib_list' below, and place in that -# file the full path for each C, C++ or Objective-C library that you want -# scanned for symbol names. One filename per line. Do not quote the -# filenames. -# -# Handles exact name matches only. Echos and exits with same output value. -# Either 1 if symbol is found or 0 if not. -# -# DESCRIP-END. - -# Perl script used to tell whether one file is newer than another. -# -set fn = "file-newer" - -# Create this file and place in the file the full path for each C, C++ or -# Objective-C library that you want scanned for symbol names. One filename -# per line. Do not quote the filenames. -# -set clib_list = "~/.CLIBS-LIST" - - -# This file will automatically be created to cache the symbol names. -# Remove it if you ever want to rebuild the symbol table. -# -set clib_symbols = "~/.clibs-symbols" - -# Try to locate 'perl' and 'file-newer' script for use. - -which perl >& /dev/null -if ($status) unset fn - -set st = 0 rebuild = 0 -if (-e $clib_list) then - if (! -e $clib_symbols || -z $clib_symbols) set rebuild = 1 - if (! $rebuild && $?fn) @ rebuild = `perl $fn $clib_list $clib_symbols` - if ($rebuild) then - nm -g `cat $clib_list` | grep '^[0-9 ].* _[A-Za-z]' | sed -e 's/^[^_][^_]*_//g' | sort | uniq > $clib_symbols - endif - fgrep -sx $1 $clib_symbols >& /dev/null - @ st = ! $status -endif - -echo $st -exit $st
--- a/lisp/hyperbole/wconfig.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,182 +0,0 @@ -;;!emacs -;; -;; FILE: wconfig.el -;; SUMMARY: Saves and yanks from save ring of window configurations. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: frames, hypermedia -;; -;; AUTHOR: Bob Weiner -;; ORG: InfoDock Associates -;; -;; ORIG-DATE: 15-Mar-89 -;; LAST-MOD: 9-Dec-96 at 18:39:50 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1989-1995, Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; -;; This library provides two unrelated means of managing window -;; configurations, (the set of windows and associated buffers within a -;; frame). The first means associates a name with each stored window -;; configuration. The name can then be used to retrieve the window -;; configuration later. The following functions provide this behavior: -;; -;; wconfig-add-by-name -;; wconfig-delete-by-name -;; wconfig-restore-by-name -;; -;; The second means of window configuration management is through the use -;; of a ring structure, just like the Emacs kill ring except the elements -;; stored are window configurations instead of textual regions. The -;; following functions support storage and sequential retrieval of window -;; configurations: -;; -;; wconfig-ring-save -;; wconfig-yank-pop -;; wconfig-delete-pop -;; -;; None of this information is stored between Emacs sessions, so your -;; window configurations will last only through a single session of use. -;; -;; Based in part on kill-ring code from simple.el. -;; -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Recommended key bindings -;;; ************************************************************************ - -;;; Set up in local "hyperbole.el". - -;;; ************************************************************************ -;;; Other required Elisp libraries -;;; ************************************************************************ -(require 'hargs) -(require 'set) - -;;; ************************************************************************ -;;; Public variables -;;; ************************************************************************ - -(defconst wconfig-ring-max 10 - "*Maximum length of window configuration ring before oldest elements are deleted.") - -(defvar wconfig-names (set:create) - "Set of (name . window-configuration) elements.") - -(defvar wconfig-ring nil - "List of window configurations saved in a ring.") - -(defvar wconfig-ring-yank-pointer nil - "The tail of the window configuration ring whose car is the last thing yanked.") - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -;;; Handling of name associations with each stored window configuration. -;;;###autoload -(defun wconfig-add-by-name (name) - "Saves the current window configuration under the string NAME. -When called interactively and a window configuration already exists under -NAME, confirms whether or not to replace it." - (interactive "sName for current window configuration: ") - (or (stringp name) - (error "(wconfig-add-by-name): NAME argument is not a string: %s" name)) - (let ((set:equal-op (function (lambda (key elt) - (equal key (car elt)))))) - (if (or (not (interactive-p)) - (not (set:member name wconfig-names)) - (y-or-n-p - (format "Replace existing '%s' window configuration: " name))) - (progn (setq wconfig-names - (set:replace name (current-window-configuration) - wconfig-names)) - (if (interactive-p) - (message "Window configuration '%s' saved. Use 'wconfig-restore-by-name' to restore." name)))))) - -;;;###autoload -(defun wconfig-delete-by-name (name) - "Deletes window configuration saved under NAME." - (interactive (list (hargs:read-match "Delete window configuration named: " - wconfig-names nil t))) - (or (stringp name) - (error "(wconfig-delete-by-name): NAME argument is not a string: %s" name)) - (let ((set:equal-op (function (lambda (key elt) - (equal key (car elt)))))) - (setq wconfig-names (set:remove name wconfig-names)))) - -;;;###autoload -(defun wconfig-restore-by-name (name) - "Restores window configuration saved under NAME." - (interactive (list (hargs:read-match "Restore window configuration named: " - wconfig-names nil t))) - (or (stringp name) - (error "(wconfig-restore-by-name): NAME argument is not a string: %s" name)) - (let ((wconfig (set:get name wconfig-names))) - (if wconfig - (set-window-configuration wconfig) - (error "(wconfig-restore-by-name): No window configuration named '%s'" name)))) - -;;; Window configuration ring management (like text kill ring). -;;;###autoload -(defun wconfig-delete-pop () - "Replaces current window config with most recently saved config in ring. -Then deletes this new configuration from the ring." - (interactive) - (if (not wconfig-ring) - (error "(wconfig-delete-pop): Window configuration save ring is empty") - (set-window-configuration (car wconfig-ring)) - (and (eq wconfig-ring wconfig-ring-yank-pointer) - (setq wconfig-ring-yank-pointer (cdr wconfig-ring))) - (setq wconfig-ring (cdr wconfig-ring)))) - -;;;###autoload -(defun wconfig-ring-save () - "Saves the current window configuration onto the save ring. -Use {\\[wconfig-yank-pop]} to restore it at a later time." - (interactive) - (setq wconfig-ring (cons (current-window-configuration) wconfig-ring)) - (if (> (length wconfig-ring) wconfig-ring-max) - (setcdr (nthcdr (1- wconfig-ring-max) wconfig-ring) nil)) - (setq wconfig-ring-yank-pointer wconfig-ring) - (wconfig-rotate-yank-pointer (1- (length wconfig-ring-yank-pointer))) - (if (interactive-p) - (message - "Window configuration saved. Use 'wconfig-yank-pop' to restore."))) - -(defun wconfig-rotate-yank-pointer (arg) - "Rotates the yanking point prefix ARG elements in the window configuration save ring. -Interactively, default value of ARG = 1." - (interactive "p") - (let ((length (length wconfig-ring))) - (if (zerop length) - (error "(wconfig-rotate-yank-pointer): Window configuration save ring is empty") - (setq wconfig-ring-yank-pointer - (nthcdr (% (+ arg (- length (length wconfig-ring-yank-pointer))) - length) - wconfig-ring))))) - -;;;###autoload -(defun wconfig-yank-pop (n) - "Replaces current window config with prefix arg Nth prior one in save ring. -Interactively, default value of N = 1, meaning the last saved window -configuration is displayed. - -The sequence of window configurations wraps around, so that after the oldest -one comes the newest one." - (interactive "p") - (wconfig-rotate-yank-pointer n) - (set-window-configuration (car wconfig-ring-yank-pointer))) - -;;; ************************************************************************ -;;; Private variables -;;; ************************************************************************ - -(run-hooks 'wconfig-load-hook) - -(provide 'wconfig)
--- a/lisp/hyperbole/wrolo-logic.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,277 +0,0 @@ -;;!emacs -;; -;; FILE: wrolo-logic.el -;; SUMMARY: Performs logical retrievals on rolodex files -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: hypermedia, matching -;; -;; AUTHOR: Bob Weiner -;; ORG: Motorola Inc. -;; -;; ORIG-DATE: 13-Jun-89 at 22:57:33 -;; LAST-MOD: 14-Apr-95 at 16:27:43 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1989-1995, Free Software Foundation, Inc. -;; Developed with support from Motorola Inc. -;; -;; DESCRIPTION: -;; -;; INSTALLATION: -;; -;; See also wrolo.el. These functions are separated from wrolo.el since many -;; users may never want or need them. They can be automatically loaded when -;; desired by adding the following to one of your Emacs init files: -;; -;; (autoload 'rolo-logic "wrolo-logic" "Logical rolodex search filters." t) -;; -;; FEATURES: -;; -;; 1. One command, 'rolo-logic' which takes a logical search expression as -;; an argument and displays any matching entries. -;; -;; 2. Logical 'and', 'or', 'not', and 'xor' rolodex entry retrieval filter -;; functions. They take any number of string or boolean arguments and -;; may be nested. NOTE THAT THESE FUNCTIONS SHOULD NEVER BE CALLED -;; DIRECTLY UNLESS THE FREE VARIABLES 'start' and 'end' ARE BOUND -;; BEFOREHAND. -;; -;; EXAMPLE: -;; -;; (rolo-logic (function -;; (lambda () -;; (rolo-and -;; (rolo-not "Tool-And-Die") -;; "secretary")))) -;; -;; would find all non-Tool-And-Die Corp. secretaries in your rolodex. -;; -;; The logical matching routines are not at all optimal, but then most -;; rolodex files are not terribly lengthy either. -;; -;; DESCRIP-END. - -(require 'wrolo) - -;;;###autoload -(defun rolo-logic (func &optional in-bufs count-only include-sub-entries - no-sub-entries-out) - "Apply FUNC to all entries in optional IN-BUFS, display entries where FUNC is non-nil. -If IN-BUFS is nil, 'rolo-file-list' is used. If optional COUNT-ONLY is -non-nil, don't display entries, return count of matching entries only. If -optional INCLUDE-SUB-ENTRIES flag is non-nil, FUNC will be applied across all -sub-entries at once. Default is to apply FUNC to each entry and sub-entry -separately. Entries are displayed with all of their sub-entries unless -INCLUDE-SUB-ENTRIES is nil and optional NO-SUB-ENTRIES-OUT flag is non-nil. -FUNC should use the free variables 'start' and 'end' which contain the limits -of the region on which it should operate. Returns number of applications of -FUNC that return non-nil." - (interactive "xLogic function of no arguments, (lambda () (<function calls>): ") - (let ((obuf (current-buffer)) - (display-buf (if count-only - nil - (prog1 (set-buffer (get-buffer-create rolo-display-buffer)) - (setq buffer-read-only nil) - (erase-buffer))))) - (let ((result - (mapcar - (function - (lambda (in-bufs) - (rolo-map-logic func in-bufs count-only include-sub-entries - no-sub-entries-out))) - (cond ((null in-bufs) rolo-file-list) - ((listp in-bufs) in-bufs) - ((list in-bufs)))))) - (let ((total-matches (apply '+ result))) - (if (or count-only (= total-matches 0)) - nil - (pop-to-buffer display-buf) - (goto-char (point-min)) - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (let ((buf (get-buffer-window obuf))) - (if buf (select-window buf) (switch-to-buffer buf)))) - (if (interactive-p) - (message (concat (if (= total-matches 0) "No" total-matches) - " matching entr" - (if (= total-matches 1) "y" "ies") - " found in rolodex."))) - total-matches)))) - -(defun rolo-map-logic (func rolo-buf &optional count-only - include-sub-entries no-sub-entries-out) - "Apply FUNC to all entries in ROLO-BUF, write to buffer entries where FUNC is non-nil. -If optional COUNT-ONLY is non-nil, don't display entries, return count of -matching entries only. If optional INCLUDE-SUB-ENTRIES flag is non-nil, FUNC -will be applied across all sub-entries at once. Default is to apply FUNC to -each entry and sub-entry separately. Entries are displayed with all of their -sub-entries unless INCLUDE-SUB-ENTRIES is nil and optional NO-SUB-ENTRIES-OUT -flag is non-nil. FUNC should use the free variables 'start' and 'end' which -contain the limits of the region on which it should operate. Returns number -of applications of FUNC that return non-nil." - (if (or (bufferp rolo-buf) - (if (file-exists-p rolo-buf) - (setq rolo-buf (find-file-noselect rolo-buf t)))) - (let* ((display-buf (set-buffer (get-buffer-create rolo-display-buffer))) - (buffer-read-only)) - (let ((hdr-pos) (num-found 0)) - (set-buffer rolo-buf) - (goto-char (point-min)) - (if (re-search-forward rolo-hdr-regexp nil t 2) - (progn (forward-line) - (setq hdr-pos (cons (point-min) (point))))) - (let* ((start) - (end) - (end-entry-hdr) - (curr-entry-level)) - (while (re-search-forward rolo-entry-regexp nil t) - (setq start (save-excursion (beginning-of-line) (point)) - next-entry-exists nil - end-entry-hdr (point) - curr-entry-level (buffer-substring start end-entry-hdr) - end (rolo-to-entry-end include-sub-entries curr-entry-level)) - (let ((fun (funcall func))) - (or count-only - (and fun (= num-found 0) hdr-pos - (append-to-buffer display-buf - (car hdr-pos) (cdr hdr-pos)))) - (if fun - (progn (goto-char end) - (setq num-found (1+ num-found) - end (if (or include-sub-entries - no-sub-entries-out) - end - (goto-char (rolo-to-entry-end - t curr-entry-level)))) - (or count-only - (append-to-buffer display-buf start end))) - (goto-char end-entry-hdr))))) - (rolo-kill-buffer rolo-buf) - num-found)) - 0)) - - -;; -;; INTERNAL FUNCTIONS. -;; - -;; Do NOT call the following functions directly. -;; Send them as parts of a lambda expression to 'rolo-logic'. - -(defun rolo-not (&rest pat-list) - "Logical <not> rolodex entry filter. PAT-LIST is a list of pattern elements. -Each element may be t, nil, or a string." - (let ((pat)) - (while (and pat-list - (or (not (setq pat (car pat-list))) - (and (not (eq pat t)) - (goto-char start) - (not (search-forward pat end t))))) - (setq pat-list (cdr pat-list))) - (if pat-list nil t))) - -(defun rolo-or (&rest pat-list) - "Logical <or> rolodex entry filter. PAT-LIST is a list of pattern elements. -Each element may be t, nil, or a string." - (if (memq t pat-list) - t - (let ((pat)) - (while (and pat-list - (or (not (setq pat (car pat-list))) - (and (not (eq pat t)) - (goto-char start) - (not (search-forward pat end t))))) - (setq pat-list (cdr pat-list))) - (if pat-list t nil)))) - -(defun rolo-xor (&rest pat-list) - "Logical <xor> rolodex entry filter. PAT-LIST is a list of pattern elements. -Each element may be t, nil, or a string." - (let ((pat) - (matches 0)) - (while (and pat-list - (or (not (setq pat (car pat-list))) - (and (or (eq pat t) - (not (goto-char start)) - (search-forward pat end t)) - (setq matches (1+ matches))) - t) - (< matches 2)) - (setq pat-list (cdr pat-list))) - (= matches 1))) - -(defun rolo-and (&rest pat-list) - "Logical <and> rolodex entry filter. PAT-LIST is a list of pattern elements. -Each element may be t, nil, or a string." - (if (memq nil pat-list) - nil - (let ((pat)) - (while (and pat-list - (setq pat (car pat-list)) - (or (eq pat t) - (not (goto-char start)) - (search-forward pat end t))) - (setq pat-list (cdr pat-list))) - (if pat-list nil t)))) - -;; Work with regular expression patterns rather than strings - -(defun rolo-r-not (&rest pat-list) - "Logical <not> rolodex entry filter. PAT-LIST is a list of pattern elements. -Each element may be t, nil, or a string." - (let ((pat)) - (while (and pat-list - (or (not (setq pat (car pat-list))) - (and (not (eq pat t)) - (goto-char start) - (not (re-search-forward pat end t))))) - (setq pat-list (cdr pat-list))) - (if pat-list nil t))) - -(defun rolo-r-or (&rest pat-list) - "Logical <or> rolodex entry filter. PAT-LIST is a list of pattern elements. -Each element may be t, nil, or a string." - (if (memq t pat-list) - t - (let ((pat)) - (while (and pat-list - (or (not (setq pat (car pat-list))) - (and (not (eq pat t)) - (goto-char start) - (not (re-search-forward pat end t))))) - (setq pat-list (cdr pat-list))) - (if pat-list t nil)))) - -(defun rolo-r-xor (&rest pat-list) - "Logical <xor> rolodex entry filter. PAT-LIST is a list of pattern elements. -Each element may be t, nil, or a string." - (let ((pat) - (matches 0)) - (while (and pat-list - (or (not (setq pat (car pat-list))) - (and (or (eq pat t) - (not (goto-char start)) - (re-search-forward pat end t)) - (setq matches (1+ matches))) - t) - (< matches 2)) - (setq pat-list (cdr pat-list))) - (= matches 1))) - -(defun rolo-r-and (&rest pat-list) - "Logical <and> rolodex entry filter. PAT-LIST is a list of pattern elements. -Each element may be t, nil, or a string." - (if (memq nil pat-list) - nil - (let ((pat)) - (while (and pat-list - (setq pat (car pat-list)) - (or (eq pat t) - (not (goto-char start)) - (re-search-forward pat end t))) - (setq pat-list (cdr pat-list))) - (if pat-list nil t)))) - -(provide 'wrolo-logic)
--- a/lisp/hyperbole/wrolo-menu.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,165 +0,0 @@ -;;!emacs -;; -;; FILE: wrolo-menu.el -;; SUMMARY: Pulldown and popup menus of Hyperbole rolodex commands. -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: hypermedia, matching, mouse -;; -;; AUTHOR: Bob Weiner -;; ORG: Motorola, Inc., PPG -;; -;; ORIG-DATE: 28-Oct-94 at 10:59:44 -;; LAST-MOD: 31-Oct-95 at 18:45:24 by Bob Weiner -;; -;; Copyright (C) 1994-1995 Free Software Foundation, Inc. -;; -;; This file is part of Hyperbole. -;; -;; DESCRIPTION: -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Public variables -;;; ************************************************************************ - -;;; This definition is used by InfoDock and XEmacs. -(defconst infodock-wrolo-menu - '("Rolodex" - ["Manual" (id-tool-invoke id-man-rolodex) t] - "----" - ["Add-Entry" (id-tool-invoke 'rolo-add) t] - ["Delete-Entry" (id-tool-invoke 'rolo-kill) t] - ["Display-Prior-Matches" (id-tool-invoke 'rolo-display-matches) t] - ["Edit-Entry" (id-tool-invoke 'rolo-edit) t] - ["Edit-Rolodex" (id-tool-invoke - '(progn (require 'wrolo) - (find-file (car rolo-file-list)) - (setq buffer-read-only nil))) - t] - ["Insert-Entry-at-Point" (id-tool-invoke 'rolo-yank) t] - ["Mail-to-Address" (id-tool-invoke 'rolo-mail-to) t] - ["Search-for-Regexp" (id-tool-invoke 'rolo-grep) t] - ["Search-for-String" (id-tool-invoke 'rolo-fgrep) t] - ["Search-for-Word" (id-tool-invoke 'rolo-word) t] - ["Sort-Entries" (id-tool-invoke 'rolo-sort) t] - )) - -;;; This definition is used by InfoDock only. -(defconst id-menubar-wrolo - (list - '("Wrolo" - ["Help" describe-mode t] - ["Manual" (id-info "(hyperbole.info)Rolo Keys") t] - "----" - ["Toggle-Read-Only" toggle-read-only t] - ["Write (Save as)" write-file t] - "----" - ["Quit" (id-tool-quit '(kill-buffer nil)) t] - ) - '["Edit-Entry-at-Point" rolo-edit-entry t] - ["Mail-to-Address" (id-tool-invoke 'rolo-mail-to) t] - '("Move" - ["Scroll-Backward" scroll-down t] - ["Scroll-Forward" scroll-up t] - ["To-Beginning" beginning-of-buffer t] - ["To-End" end-of-buffer t] - "----" - ["To-Next-Entry" outline-next-visible-heading t] - ["To-Next-Same-Level" outline-forward-same-level t] - ["To-Previous-Entry" outline-previous-visible-heading t] - ["To-Previous-Same-Level" outline-backward-same-level t] - ["Up-a-Level" outline-up-heading t] - ) - '("Outline" - ["Hide (Collapse)" hide-subtree t] - ["Show (Expand)" show-subtree t] - ["Show-All" show-all t] - ["Show-Only-First-Line" hide-body t] - ) - '["Next-Match" rolo-next-match t] - '["Previous-Match" rolo-previous-match t] - infodock-wrolo-menu - )) - -;;; This definition is used by InfoDock and XEmacs. -(defconst id-popup-wrolo-menu - (list - "Wrolo" - '["Help" describe-mode t] - '["Manual" (id-info "(hyperbole.info)Rolo Keys") t] - "----" - '["Edit-Entry-at-Point" rolo-edit-entry t] - "----" - '["Next-Match" rolo-next-match t] - '["Previous-Match" rolo-previous-match t] - "----" - '("Move" - ["Scroll-Backward" scroll-down t] - ["Scroll-Forward" scroll-up t] - ["To-Beginning" beginning-of-buffer t] - ["To-End" end-of-buffer t] - "----" - ["To-Next-Entry" outline-next-visible-heading t] - ["To-Next-Same-Level" outline-forward-same-level t] - ["To-Previous-Entry" outline-previous-visible-heading t] - ["To-Previous-Same-Level" outline-backward-same-level t] - ["Up-a-Level" outline-up-heading t] - ) - '("Outline" - ["Hide (Collapse)" hide-subtree t] - ["Show (Expand)" show-subtree t] - ["Show-All" show-all t] - ["Show-Only-First-Line" hide-body t] - ) - infodock-wrolo-menu - "----" - '["Quit" (id-tool-quit 'rolo-quit) t] - )) - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -;;; This definition is used only by XEmacs and Emacs19. -(defun wrolo-menubar-menu () - "Add a Hyperbole Rolodex menu to the rolodex match buffer menubar." - (cond ((fboundp 'popup-mode-menu) - (setq mode-popup-menu id-popup-wrolo-menu)) - (hyperb:lemacs-p - (define-key wrolo-mode-map 'button3 'wrolo-popup-menu)) - (t ;; hyperb:emacs19-p - (define-key wrolo-mode-map [down-mouse-3] 'wrolo-popup-menu) - (define-key wrolo-mode-map [mouse-3] nil))) - (if (and (boundp 'current-menubar) - (or hyperb:emacs19-p current-menubar) - (not (car (find-menu-item current-menubar '("Wrolo"))))) - (progn - (set-buffer-menubar (copy-sequence current-menubar)) - (if (fboundp 'add-submenu) - (add-submenu nil id-popup-wrolo-menu) - (add-menu nil (car id-popup-wrolo-menu) - (cdr id-popup-wrolo-menu)))))) - -;;; This definition is used only by XEmacs and Emacs19. -(defun wrolo-popup-menu (event) - "Popup the Hyperbole Rolodex match buffer menu." - (interactive "@e") - (mouse-set-point event) - (if (fboundp 'popup-mode-menu) - (popup-mode-menu) - (popup-menu id-popup-wrolo-menu))) - -(cond ((null hyperb:window-system)) - ((and (featurep 'infodock) (fboundp 'id-menubar-set)) - ;; InfoDock under a window system - (require 'id-menubars) - (id-menubar-set 'wrolo-mode 'id-menubar-wrolo)) - (hyperb:lemacs-p - ;; XEmacs under a window system - (add-hook 'wrolo-mode-hook 'wrolo-menubar-menu)) - (hyperb:emacs19-p - ;; Emacs 19 under a window system - (require 'lmenu) - (add-hook 'wrolo-mode-hook 'wrolo-menubar-menu))) - -(provide 'wrolo-menu)
--- a/lisp/hyperbole/wrolo.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1259 +0,0 @@ -;;!emacs -;; -;; FILE: wrolo.el V2 (Renamed from rolo.el in earlier versions to avoid -;; load path conflicts with the rolo.el written by -;; another author.) -;; SUMMARY: Hierarchical, multi-file, easy to use rolodex system -;; USAGE: GNU Emacs Lisp Library -;; KEYWORDS: hypermedia, matching -;; -;; AUTHOR: Bob Weiner -;; -;; ORG: InfoDock Associates. We sell corporate support and development -;; contracts for InfoDock, Emacs and XEmacs. -;; E-mail: <info@infodock.com> Web: http://www.infodock.com -;; Tel: +1 408-243-3300 -;; -;; ORIG-DATE: 7-Jun-89 at 22:08:29 -;; LAST-MOD: 14-Mar-97 at 01:32:23 by Bob Weiner -;; -;; This file is part of Hyperbole. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; Copyright (C) 1989, '90, '91, '92, '95, '96, '97 Free Software Foundation, Inc. -;; -;; DESCRIPTION: -;; -;; The `put whatever you feel like into it' rolodex. -;; -;; FEATURES: -;; -;; 1. Multiple rolodex files with free text lookup. No structured -;; fields are used. -;; -;; 2. Hierarchical rolodex entries as in: -;; * Company -;; ** Manager -;; *** Underlings -;; -;; Searching for Manager turns up all Underlings. Searching for -;; Company retrieves all listed employees. -;; -;; This hierarchical system has proved very effective for retrieving -;; computer system administration problem reports by vendor name, -;; problem number or by subject area, without having to resort to a -;; database system, and also for extraction of relevant text -;; sections from reports. -;; -;; 3. String and regular expression searching capabilities. Matches are -;; found anywhere within entries, so entries may be of any format you -;; like without the bother of fixed field restrictions. -;; Ability to restrict number of matches or to report number of matches -;; without displaying entries. -;; -;; 4. Smart addition, editing and sorting of entries by hierarchy level. -;; -;; 5. Support for Hyperbole buttons within rolodex entries. -;; -;; See "wrolo-logic.el" for logical search functions (and, or, not, xor). -;; See "wrolo-menu.el" for menu handling functions. (If you received -;; wrolo as part of Hyperbole, this file in unneeded and so not included.) -;; -;; -;; SETUP: -;; -;; The variable `rolo-file-list' is a list of files to search for -;; matching rolodex entries. To add personal files to rolo-file-list, -;; when you find these functions are useful for any sort of list lookup, -;; add the following to your ~/.emacs file (substituting where you see -;; <fileN>): -;; -;; (setq rolo-file-list (append rolo-file-list '("<file1>" "<file2>"))) -;; -;; We recommend that entries in `rolo-file-list' have ".otl" suffixes -;; so that they do not conflict with file names that other rolodex -;; programs might use and so that they are edited in `outline-mode' by -;; default. If you want the latter behavior, uncomment and add something -;; like the following to one of your GNU Emacs initialization files: -;; -;; ;; Add to the list of suffixes that causes automatic mode invocation -;; (setq auto-mode-alist -;; (append '(("\\.otl$" . outline-mode)) auto-mode-alist)) -;; -;; The buffers containing the rolodex files are not killed after a search -;; on the assumption that another search is likely to follow within this -;; Emacs session. You may wish to change this behavior with the following -;; setting: -;; -;; (setq rolo-kill-buffers-after-use t) -;; -;; After an entry is killed, the modified rolodex file is automatically -;; saved. If you would rather always save files yourself, use this -;; setting: -;; -;; (setq rolo-save-buffers-after-use nil) -;; -;; When adding an entry from within a buffer containing a mail -;; message, the rolodex add function will extract the sender's name -;; and e-mail address and prompt you with the name as a default. If -;; you accept it, it will enter the name and the email address using -;; the format given by the `rolo-email-format' variable. See its -;; documentation if you want to change its value. -;; -;; -;; If you use Hyperbole V2.3 or greater, then no other rolodex setup -;; is necessary, simply select the "Rolo/" menu item from the top -;; level Hyperbole menu. Otherwise, add the following to your -;; "~/.emacs" file: -;; -;; (autoload 'rolo-menu "rolo-menu" "Load wrolo system." t) -;; (global-set-key "\C-x4r" 'rolo-menu) -;; -;; And then simply invoke the rolodex menu with {C-x 4 r} after Emacs -;; has read those lines in your init file. -;; -;; -;; SUMMARY OF USE: -;; -;; The rolo menu provides access to the following commands: -;; -;; Menu Item Function Description -;; ==================================================================== -;; Add rolo-add Adds a rolodex entry -;; Display rolo-display-matches Displays last matches again -;; Edit rolo-edit Edits an existing rolodex entry -;; Info Displays Rolodex manual entry -;; Kill rolo-kill Removes an entry from the rolodex -;; Order rolo-sort Sorts all levels in rolodex -;; RegexFind rolo-grep Finds all entries containing -;; a regular expression -;; StringFind rolo-fgrep Finds all entries containing -;; a string -;; WordFind rolo-word Finds all entries containing -;; a string of whole words -;; Yank rolo-yank Inserts first matching rolodex -;; entry at point -;; -;; For any of these commands that prompt you for a name, you may use the form -;; parent/child to locate a child entry below a parent entry, e.g. -;; from the example near the top, we could give Company/Manager/Underlings. -;; -;; Here is a snippet from our group rolodex file. The `;'s should be -;; removed of course and the `*'s should begin at the start of the -;; line. If a rolodex file begins with two separator lines whose -;; first three characters are "===", then these lines and any text -;; between them are prepended to the output buffer whenever any -;; entries are retrieved from that file. -;; -;;============================================================================= -;; GROUP ROLODEX -;; <Last Name>, <First Name> <Co/Categ> W<Work #> H<Home #> P<Pager #> -;; F<Fax #> M<Modem #> C<Cellular #> -;; <Address> <Miscellaneous Info, Key Words> -;;============================================================================= -;;* EX594, Digital-Systems-Research -;;** Weiner, Bob Motorola W2087 P7-7489 -;; FL19, L-1035 -;; -;; -;; FOR PROGRAMMERS: -;; -;; Entries in rolodex files are separated by patterns matching -;; `rolo-entry-regexp'. Each entry may have any number of sub-entries -;; which represent the next level down in the entry hierarchy. -;; Sub-entries' separator patterns are always longer than their parents'. -;; For example, if an entry began with `*' then its sub-entries would begin -;; with `**' and so on. Blank lines in rolodex files will not end up where -;; you want them if you use the rolo-sort commands; therefore, blank lines -;; are not recommended. If you change the value of -;; `rolo-entry-regexp', you will have to modify `rolo-sort'. -;; -;; The following additional functions are provided: -;; -;; `rolo-sort-level' sorts a specific level of entries in a rolodex file; -;; `rolo-map-level' runs a user specified function on a specific level of -;; entries in a rolodex file; -;; `rolo-fgrep-file', same as `rolo-fgrep' but operates on a single file; -;; `rolo-grep-file', same as `rolo-grep' but operates on a single file; -;; `rolo-display-matches', display last set of rolodex matches, if any; -;; `rolo-toggle-narrow-to-entry' toggles between display of current entry -;; and display of all matching entries. -;; -;; -;; MOD HISTORY: -;; -;; 12/17/89 -;; Added internal `rolo-shrink-window' function for use in -;; compressing/uncompressing the rolo view window to/from a size just -;; large enough for the selected entry. This is useful when a search -;; turns up more entries than desired. -;; -;; 02/21/90 -;; Modified `rolo-grep-file' and `rolo-map-level' so they only set buffers -;; read-only the first time they are read in. This way, if someone edits a -;; rolodex file and then does a rolo-fgrep or other function, the buffer -;; will not be back in read-only mode. -;; -;; 04/18/91 -;; Modified `rolo-grep-file' to expand any hidden entries in rolo file -;; before doing a search. -;; -;; 12/24/91 -;; Added Hyperbole button support. -;; -;; 12/30/91 -;; Added convenient support for entry add, edit, kill and yank. -;; -;; 01/10/91 -;; Fixed bug in rolo-to that ended search too early. -;; -;; DESCRIP-END. - -;;; ************************************************************************ -;;; Other required Elisp libraries -;;; ************************************************************************ - -(require 'hversion) -(require 'hmail) - -;;; ************************************************************************ -;;; Public variables -;;; ************************************************************************ - -(defvar rolo-email-format "%s\t\t<%s>" - "Format string to use when adding an entry with e-mail addr from a mail msg. -It must contain a %s indicating where to put the entry name and a second -%s indicating where to put the e-mail address.") - -(defvar rolo-file-list - (if hyperb:microcruft-os-p - '("c:/_rolodex.otl") '("~/.rolodex.otl")) - "*List of files containing rolodex entries. -The first file should be a user-specific rolodex file, typically in the home -directory. The second file is often a shared, group-specific rolodex file. - -A rolo-file consists of: - (1) an optional header beginning with and ending with a line which matches - rolo-hdr-regexp; - (2) one or more rolodex entries which each begin with - rolo-entry-regexp and may be nested.") - -(defvar rolo-highlight-face nil - "*Face used to highlight rolodex search matches.") -(if rolo-highlight-face - nil - (setq rolo-highlight-face - (cond (hyperb:emacs19-p - (if (fboundp 'make-face) - (progn (make-face 'rolo-highlight-face) - 'rolo-highlight-face))) - (hyperb:epoch-p (make-style)) - (t (if (fboundp 'make-face) - (face-name (make-face 'rolo-highlight-face)))))) - (if (fboundp 'hproperty:set-item-highlight) - (hproperty:set-item-highlight))) - -(defvar rolo-kill-buffers-after-use nil - "*Non-nil means kill rolodex file buffers after searching them for entries. -Only unmodified buffers are killed.") - -(defvar rolo-save-buffers-after-use t - "*Non-nil means save rolodex file after an entry is killed.") - -;; Insert or update the entry date each time an entry is added or edited. -(add-hook 'wrolo-add-hook 'rolo-set-date) -(add-hook 'wrolo-edit-hook 'rolo-set-date) - -(defvar wrolo-yank-reformat-function nil - "*Value is a function of two arguments, START and END, invoked after a rolo-yank. -It should reformat the region given by the arguments to some preferred style. -Default value is nil, meaning no reformmating is done.") - -;;; ************************************************************************ -;;; Commands -;;; ************************************************************************ - -;;;###autoload -(defun rolo-add (name &optional file) - "Adds a new entry in personal rolodex for NAME. -Last name first is best, e.g. \"Smith, John\". -With prefix argument, prompts for optional FILE to add entry within. -NAME may be of the form: parent/child to insert child below a parent -entry which begins with the parent string." - (interactive - (progn - (or (fboundp 'mail-fetch-field) (require 'mail-utils)) - (let* ((lst (rolo-name-and-email)) - (name (car lst)) - (email (car (cdr lst))) - (entry (read-string "Name to add to rolo: " - (or name email)))) - (list (if (and email name - (string-match (concat "\\`" (regexp-quote entry)) name)) - (format rolo-email-format entry email) entry) - current-prefix-arg)))) - (if (or (not (stringp name)) (string= name "")) - (error "(rolo-add): Invalid name: `%s'" name)) - (if (and (interactive-p) file) - (setq file (completing-read "File to add to: " - (mapcar 'list rolo-file-list)))) - (if (null file) (setq file (car rolo-file-list))) - (cond ((and file (or (not (stringp file)) (string= file ""))) - (error "(rolo-add): Invalid file: `%s'" file)) - ((and (file-exists-p file) (not (file-readable-p file))) - (error "(rolo-add): File not readable: `%s'" file)) - ((not (file-writable-p file)) - (error "(rolo-add): File not writable: `%s'" file))) - (set-buffer (or (get-file-buffer file) (find-file-noselect file))) - (if (interactive-p) (message "Locating insertion point for `%s'..." name)) - (let ((parent "") (level "") end) - (widen) (goto-char 1) - (while (setq end (string-match "/" name)) - (setq parent (substring name 0 end) - name (substring name (min (1+ end) (length name)))) - (if (re-search-forward - (concat "\\(" rolo-entry-regexp "\\)[ \t]*" - (regexp-quote parent)) nil t) - (setq level (buffer-substring (match-beginning 1) - (match-end 1))) - (error "(rolo-add): `%s' category not found in \"%s\"." - parent file))) - (narrow-to-region (point) - (progn (rolo-to-entry-end t level) (point))) - (goto-char (point-min)) - (let* ((len (length name)) - (name-level (concat level "*")) - (level-len (length name-level)) - (entry "") - (entry-spc "") - (entry-level) - (match) - (again t)) - (while (and again - (re-search-forward - (concat "\\(" rolo-entry-regexp "\\)\\([ \t]*\\)") - nil 'end)) - (setq entry-level (buffer-substring (match-beginning 1) - (match-end 1))) - (if (/= (length entry-level) level-len) - (rolo-to-entry-end t entry-level) - (setq entry (buffer-substring (point) (+ (point) len)) - entry-spc (buffer-substring (match-beginning 2) - (match-end 2))) - (cond ((string< entry name) - (rolo-to-entry-end t entry-level)) - ((string< name entry) - (setq again nil) (beginning-of-line)) - (t ;; found existing entry matching name - (setq again nil match t))))) - (setq buffer-read-only nil) - (if match - nil - (insert (or entry-level (concat level "*")) - (if (string= entry-spc "") " " entry-spc) - name "\n") - (backward-char 1)) - ;; Rolo-to-buffer may move point from its desired location, so - ;; restore it. - (let ((opoint (point))) - (widen) - (rolo-to-buffer (current-buffer)) - (goto-char opoint)) - (run-hooks 'wrolo-add-hook) - (if (interactive-p) - (message "Edit entry at point."))))) - -;;;###autoload -(defun rolo-display-matches (&optional display-buf return-to-buffer) - "Display optional DISPLAY-BUF buffer of previously found rolodex matches. -If DISPLAY-BUF is nil, use the value in `rolo-display-buffer'. -Second arg RETURN-TO-BUFFER is the buffer to leave point within after the display." - (interactive) - (or display-buf (setq display-buf (get-buffer rolo-display-buffer))) - (if display-buf nil - (error "(rolo-display-matches): Search the rolodex first.")) - ;; Save current window configuration if rolodex match buffer is not - ;; displayed in one of the windows already. - (or - ;; Handle both Emacs V18 and V19 versions of get-buffer-window. - (condition-case () - (get-buffer-window display-buf (selected-frame)) - (error (get-buffer-window display-buf))) - (setq *rolo-wconfig* (current-window-configuration))) - (rolo-to-buffer display-buf t) - (if (eq major-mode 'wrolo-mode) nil (wrolo-mode)) - (setq buffer-read-only nil) - (if (fboundp 'hproperty:but-create) (hproperty:but-create)) - (rolo-shrink-window) - (goto-char (point-min)) - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (run-hooks 'wrolo-display-hook) - ;; Leave point in match buffer unless a specific RETURN-TO-BUFFER has - ;; been specified. Use {q} to quit and restore display. - (if return-to-buffer (rolo-to-buffer return-to-buffer t))) - -;;;###autoload -(defun rolo-edit (&optional name file) - "Edits a rolodex entry given by optional NAME within `rolo-file-list'. -With prefix argument, prompts for optional FILE to locate entry within. -With no NAME arg, simply displays FILE or first entry in `rolo-file-list' in an -editable mode. NAME may be of the form: parent/child to edit child below a -parent entry which begins with the parent string." - (interactive "sName to edit in rolo: \nP") - (if (string-equal name "") (setq name nil)) - (and name (not (stringp name)) - (error "(rolo-edit): Invalid name: `%s'" name)) - (if (and (interactive-p) current-prefix-arg) - (if (= (length rolo-file-list) 1) - (setq file (car rolo-file-list)) - (setq file (completing-read "Entry's File: " - (mapcar 'list rolo-file-list))))) - (let ((found-point) (file-list (if file (list file) rolo-file-list))) - (or file (setq file (car file-list))) - (if (null name) - (progn (if (not (file-writable-p file)) - (error "(rolo-edit): File not writable: `%s'" file)) - (find-file-other-window file) (setq buffer-read-only nil)) - (if (setq found-point (rolo-to name file-list)) - (progn - (setq file buffer-file-name) - (if (file-writable-p file) - (setq buffer-read-only nil) - (message - "(rolo-edit): Entry found but file not writable: `%s'" file) - (beep)) - (rolo-to-buffer (current-buffer))) - (message "(rolo-edit): `%s' not found." name) - (beep) - (rolo-to-buffer (or (get-file-buffer (car file-list)) - (find-file-noselect (car file-list)))) - (setq buffer-read-only nil)) - (widen) - ;; Rolo-to-buffer may have moved point from its desired location, so - ;; restore it. - (if found-point (goto-char found-point)) - (run-hooks 'wrolo-edit-hook)))) - -(defun rolo-edit-entry () - "Edit the source entry of the rolodex match buffer entry at point. -Returns entry name if found, else nil." - (interactive) - (let ((name (rolo-name-at))) - (if name (progn (rolo-edit name (hbut:key-src)) - name)))) - -;;;###autoload -(defun rolo-fgrep (string - &optional max-matches rolo-file count-only no-display) - "Display rolodex entries matching STRING. -To a maximum of optional prefix arg MAX-MATCHES, in file(s) from optional -ROLO-FILE or rolo-file-list. Default is to find all matching entries. Each -entry is displayed with all of its sub-entries. Optional COUNT-ONLY non-nil -means don't retrieve and don't display matching entries. Optional NO-DISPLAY -non-nil means retrieve entries but don't display. - -Nil value of MAX-MATCHES means find all matches, t value means find all matches -but omit file headers, negative values mean find up to the inverse of that -number of entries and omit file headers. - -Returns number of entries matched. See also documentation for the variable -rolo-file-list." - (interactive "sRolodex string to match: \nP") - (let ((total-matches (rolo-grep (regexp-quote string) max-matches - rolo-file count-only no-display))) - (if (interactive-p) - (message "%s matching entr%s found in rolodex." - (if (= total-matches 0) "No" total-matches) - (if (= total-matches 1) "y" "ies"))) - total-matches)) - -;;;###autoload -(defun rolo-grep (regexp &optional max-matches rolo-bufs count-only no-display) - "Display rolodex entries matching REGEXP. -To a maximum of prefix arg MAX-MATCHES, in buffer(s) from optional ROLO-BUFS or -rolo-file-list. Default is to find all matching entries. Each entry is -displayed with all of its sub-entries. Optional COUNT-ONLY non-nil means don't -retrieve and don't display matching entries. Optional NO-DISPLAY non-nil -means retrieve entries but don't display. - -Nil value of MAX-MATCHES means find all matches, t value means find all matches -but omit file headers, negative values mean find up to the inverse of that -number of entries and omit file headers. - -Returns number of entries matched. See also documentation for the variable -rolo-file-list." - (interactive "sRolodex regular expression to match: \nP") - (let ((rolo-file-list - (cond ((null rolo-bufs) rolo-file-list) - ((listp rolo-bufs) rolo-bufs) - ((list rolo-bufs)))) - (display-buf (if count-only - nil - (set-buffer (get-buffer-create rolo-display-buffer)))) - (total-matches 0) - (num-matched 0) - (inserting (or (eq max-matches t) - (and (integerp max-matches) (< max-matches 0)))) - (file)) - (if count-only nil - (setq buffer-read-only nil) - (or inserting (erase-buffer))) - (while (and (setq file (car rolo-file-list)) - (or (not (integerp max-matches)) - (< total-matches (max max-matches (- max-matches))))) - (setq rolo-file-list (cdr rolo-file-list) - num-matched (rolo-grep-file file regexp max-matches count-only) - total-matches (+ total-matches num-matched)) - (if (integerp max-matches) - (setq max-matches - (if (>= max-matches 0) - (- max-matches num-matched) - (+ max-matches num-matched))))) - (if (or count-only no-display inserting (= total-matches 0)) - nil - (rolo-display-matches display-buf)) - (if (interactive-p) - (message "%s matching entr%s found in rolodex." - (if (= total-matches 0) "No" total-matches) - (if (= total-matches 1) "y" "ies") - )) - total-matches)) - -(defun rolo-isearch () - "Interactively search forward for next occurrence of current match regexp. -Use this to add characters to further narrow the search." - (interactive) - (if (equal (buffer-name) rolo-display-buffer) - (execute-kbd-macro (concat "\e\C-s" rolo-match-regexp)) - (error "(rolo-isearch): Use this command in the %s match buffer" - rolo-display-buffer))) - -;;;###autoload -(defun rolo-kill (name &optional file) - "Kills a rolodex entry given by NAME within `rolo-file-list'. -With prefix argument, prompts for optional FILE to locate entry within. -NAME may be of the form: parent/child to kill child below a parent entry -which begins with the parent string. -Returns t if entry is killed, nil otherwise." - (interactive "sName to kill in rolo: \nP") - (if (or (not (stringp name)) (string= name "")) - (error "(rolo-kill): Invalid name: `%s'" name)) - (if (and (interactive-p) current-prefix-arg) - (setq file (completing-read "Entry's File: " - (mapcar 'list rolo-file-list)))) - (let ((file-list (if file (list file) rolo-file-list)) - (killed)) - (or file (setq file (car file-list))) - (if (rolo-to name file-list) - (progn - (setq file buffer-file-name) - (if (file-writable-p file) - (let ((kill-op - (function (lambda (start level) - (kill-region - start (rolo-to-entry-end t level)) - (setq killed t) - (rolo-save-buffer) - (rolo-kill-buffer)))) - start end level) - (setq buffer-read-only nil) - (re-search-backward rolo-entry-regexp nil t) - (setq end (match-end 0)) - (beginning-of-line) - (setq start (point) - level (buffer-substring start end)) - (goto-char end) - (skip-chars-forward " \t") - (if (interactive-p) - (let ((entry-line (buffer-substring - (point) - (min (+ (point) 60) - (progn (end-of-line) (point)))))) - (if (y-or-n-p (format "Kill `%s...' " entry-line)) - (progn - (funcall kill-op start level) - (message "Killed")) - (message "Aborted"))) - (funcall kill-op start level))) - (message - "(rolo-kill): Entry found but file not writable: `%s'" file) - (beep))) - (message "(rolo-kill): `%s' not found." name) - (beep)) - killed)) - -(defun rolo-mail-to () - "Start composing mail addressed to the first e-mail address at or after point." - (interactive) - (let ((opoint (point)) button) - (skip-chars-backward "^ \t\n\r<>") - (if (and (re-search-forward mail-address-regexp nil t) - (goto-char (match-beginning 1)) - (setq button (ibut:at-p))) - (hui:hbut-act button) - (goto-char opoint) - (beep) - (message "(rolo-mail-to): Invalid buffer or no e-mail address found")))) - -(defun rolo-next-match () - "Move point forward to the start of the next rolodex search match." - (interactive) - (if (not (stringp rolo-match-regexp)) - (error "(rolo-next-match): Invoke a rolodex search expression first")) - (let ((start (point)) - (case-fold-search t)) - (if (looking-at rolo-match-regexp) - (goto-char (match-end 0))) - (if (re-search-forward rolo-match-regexp nil t) - (goto-char (match-beginning 0)) - (goto-char start) - (error - "(rolo-next-match): No following matches for \"%s\"" rolo-match-regexp)))) - -(defun rolo-previous-match () - "Move point back to the start of the previous rolodex search match." - (interactive) - (if (not (stringp rolo-match-regexp)) - (error "(rolo-previous-match): Invoke a rolodex search expression first")) - (let ((case-fold-search t)) - (if (re-search-backward rolo-match-regexp nil t) - nil - (error - "(rolo-previous-match): No prior matches for \"%s\"" rolo-match-regexp)))) - -(defun rolo-quit () - "Quit from the rolodex match buffer and restore the prior frame display." - (interactive) - (bury-buffer) - (if (and *rolo-wconfig* - (if (fboundp 'window-configuration-p) - (window-configuration-p *rolo-wconfig*) - t)) - (set-window-configuration *rolo-wconfig*))) - -;;;###autoload -(defun rolo-sort (&optional rolo-file) - "Sorts up to 14 levels of entries in ROLO-FILE (default is personal rolo). -Assumes entries are delimited by one or more `*'characters. -Returns list of number of groupings at each entry level." - (interactive - (list (let ((default "") - (file)) - (setq file - (completing-read - (format "Sort rolo file (default %s): " - (file-name-nondirectory - (setq default - (if (and buffer-file-name - (memq - t (mapcar - (function - (lambda (file) - (equal buffer-file-name - (expand-file-name file)))) - rolo-file-list))) - buffer-file-name - (car rolo-file-list))))) - (mapcar 'list rolo-file-list))) - (if (string= file "") default file)))) - (if (or (not rolo-file) (equal rolo-file "")) - (setq rolo-file (car rolo-file-list))) - (if (not (and (stringp rolo-file) (file-readable-p rolo-file))) - (error "(rolo-sort): Invalid or unreadable file: %s" rolo-file)) - (let ((level-regexp (regexp-quote "**************")) - (entries-per-level-list) - (n)) - (while (not (equal level-regexp "")) - (setq n (rolo-sort-level rolo-file level-regexp)) - (if (or (/= n 0) entries-per-level-list) - (setq entries-per-level-list - (append (list n) entries-per-level-list))) - (setq level-regexp (substring level-regexp 0 (- (length level-regexp) 2)))) - entries-per-level-list)) - -(defun rolo-sort-level (rolo-file level-regexp &optional max-groupings) - "Sorts groupings of entries in ROLO-FILE at hierarchy level LEVEL-REGEXP. -To a maximum of optional MAX-GROUPINGS. Nil value of MAX-GROUPINGS means all -groupings at the given level. LEVEL-REGEXP should simply match the text of -any rolodex entry of the given level, not the beginning of a line (^); an -example, might be (regexp-quote \"**\") to match level two. Returns number -of groupings sorted." - (interactive "sRolodex file to sort: \nRegexp for level's entries: \nP") - (let ((sort-fold-case t)) - (rolo-map-level - (function (lambda (start end) (sort-lines nil start end))) - rolo-file - level-regexp - max-groupings))) - -;;;###autoload -(defun rolo-toggle-datestamps (&optional arg) - "Toggle whether datestamps are updated when rolodex entries are modified. -With optional ARG, turn them on iff ARG is positive." - (interactive "P") - (if (or (and arg (<= (prefix-numeric-value arg) 0)) - (and (not (and arg (> (prefix-numeric-value arg) 0))) - (boundp 'wrolo-add-hook) (listp wrolo-add-hook) - (memq 'rolo-set-date wrolo-add-hook))) - (progn (remove-hook 'wrolo-add-hook 'rolo-set-date) - (remove-hook 'wrolo-edit-hook 'rolo-set-date) - (message "Rolodex date stamps are now turned off.")) - (add-hook 'wrolo-add-hook 'rolo-set-date) - (add-hook 'wrolo-edit-hook 'rolo-set-date) - (message "Rolodex date stamps are now turned on."))) - -(defun rolo-toggle-narrow-to-entry () - "Toggle between display of current entry and display of all matched entries. -Useful when bound to a mouse key." - (interactive) - (if (rolo-narrowed-p) - (widen) - (if (or (looking-at rolo-entry-regexp) - (re-search-backward rolo-entry-regexp nil t)) - (progn (forward-char) - (narrow-to-region (1- (point)) (rolo-display-to-entry-end))))) - (rolo-shrink-window) - (goto-char (point-min))) - -(defun rolo-word (string - &optional max-matches rolo-file count-only no-display) - "Display rolodex entries with whole word matches for STRING. -To a maximum of optional prefix arg MAX-MATCHES, in file(s) from optional -ROLO-FILE or rolo-file-list. Default is to find all matching entries. Each -entry is displayed with all of its sub-entries. Optional COUNT-ONLY non-nil -means don't retrieve and don't display matching entries. Optional NO-DISPLAY -non-nil means retrieve entries but don't display. - -Nil value of MAX-MATCHES means find all matches, t value means find all matches -but omit file headers, negative values mean find up to the inverse of that -number of entries and omit file headers. - -Returns number of entries matched. See also documentation for the variable -rolo-file-list." - (interactive "sRolodex whole words to match: \nP") - (let ((total-matches (rolo-grep (format "\\b%s\\b" (regexp-quote string)) - max-matches - rolo-file count-only no-display))) - (if (interactive-p) - (message "%s matching entr%s found in rolodex." - (if (= total-matches 0) "No" total-matches) - (if (= total-matches 1) "y" "ies"))) - total-matches)) - -;;;###autoload -(defun rolo-yank (name &optional regexp-p) - "Inserts at point the first rolodex entry matching NAME. -With optional prefix arg, REGEXP-P, treats NAME as a regular expression instead -of a string." - (interactive "sName to insert record for: \nP") - (let ((rolo-display-buffer (current-buffer)) - (start (point)) - found) - (save-excursion - (setq found (if regexp-p - (rolo-grep name -1) - (rolo-grep (regexp-quote name) -1)))) - ;; Let user reformat the region just yanked. - (if (and (= found 1) (fboundp wrolo-yank-reformat-function)) - (funcall wrolo-yank-reformat-function start (point))) - found)) - -;;; ************************************************************************ -;;; Public functions -;;; ************************************************************************ - -(defun rolo-fgrep-file (rolo-buf string &optional max-matches count-only) - "Retrieve entries in ROLO-BUF matching STRING to a maximum of optional MAX-MATCHES. -Nil value of MAX-MATCHES means find all matches, t value means find all matches -but omit file headers, negative values mean find up to the inverse of that -number of entries and omit file headers. Optional COUNT-ONLY non-nil -means don't retrieve matching entries. -Returns number of matching entries found." - (rolo-grep-file rolo-buf (regexp-quote string) max-matches count-only)) - -(defun rolo-grep-file (rolo-buf regexp &optional max-matches count-only) - "Retrieve entries in ROLO-BUF matching REGEXP to a maximum of optional MAX-MATCHES. -Nil value of MAX-MATCHES means find all matches, t value means find all matches -but omit file headers, negative values mean find up to the inverse of that -number of entries and omit file headers. Optional COUNT-ONLY non-nil -means don't retrieve matching entries. -Returns number of matching entries found." - ;; - ;; Save regexp as last rolodex search expression. - (setq rolo-match-regexp regexp) - ;; - (let ((new-buf-p) (actual-buf)) - (if (and (or (null max-matches) (eq max-matches t) (integerp max-matches)) - (or (setq actual-buf (rolo-buffer-exists-p rolo-buf)) - (if (file-exists-p rolo-buf) - (setq actual-buf (find-file-noselect rolo-buf t) - new-buf-p t)))) - (let ((hdr-pos) (num-found 0) (curr-entry-level) - (incl-hdr t)) - (if max-matches - (cond ((eq max-matches t) - (setq incl-hdr nil max-matches nil)) - ((< max-matches 0) - (setq incl-hdr nil - max-matches (- max-matches))))) - (set-buffer actual-buf) - (if new-buf-p (setq buffer-read-only t)) - (save-excursion - (save-restriction - (widen) - (goto-char 1) - ;; Ensure no entries in outline mode are hidden. - ;; Uses `show-all' function from outline.el. - (and (search-forward "\C-m" nil t) - (show-all)) - (if (re-search-forward rolo-hdr-regexp nil t 2) - (progn (forward-line) - (setq hdr-pos (cons (point-min) (point))))) - (re-search-forward rolo-entry-regexp nil t) - (while (and (or (null max-matches) (< num-found max-matches)) - (re-search-forward regexp nil t)) - (re-search-backward rolo-entry-regexp nil t) - (let ((start (point)) - (next-entry-exists)) - (re-search-forward rolo-entry-regexp nil t) - (setq curr-entry-level (buffer-substring start (point))) - (rolo-to-entry-end t curr-entry-level) - (or count-only - (if (and (= num-found 0) incl-hdr) - (let* ((src (or (buffer-file-name actual-buf) - actual-buf)) - (src-line - (format - (concat (if (boundp 'hbut:source-prefix) - hbut:source-prefix - "@loc> ") - "%s") - (prin1-to-string src)))) - (set-buffer rolo-display-buffer) - (goto-char (point-max)) - (if hdr-pos - (progn - (insert-buffer-substring - actual-buf (car hdr-pos) (cdr hdr-pos)) - (insert src-line "\n\n")) - (insert (format rolo-hdr-format src-line))) - (set-buffer actual-buf)))) - (setq num-found (1+ num-found)) - (or count-only - (rolo-add-match rolo-display-buffer regexp start (point))))))) - (rolo-kill-buffer actual-buf) - num-found) - 0))) - -(defun rolo-map-level (func rolo-buf level-regexp &optional max-groupings) - "Perform FUNC on groupings of ROLO-BUF entries at level LEVEL-REGEXP, -to a maximum of optional argument MAX-GROUPINGS. Nil value of MAX-GROUPINGS -means all groupings at the given level. FUNC should take two arguments, the -start and the end of the region that it should manipulate. LEVEL-REGEXP -should simply match the text of any rolodex entry of the given level, not the -beginning of a line (^); an example, might be (regexp-quote \"**\") to match -level two. Returns number of groupings matched." - (let ((actual-buf)) - (if (and (or (null max-groupings) (< 0 max-groupings)) - (or (setq actual-buf (rolo-buffer-exists-p rolo-buf)) - (if (file-exists-p rolo-buf) - (progn (setq actual-buf (find-file-noselect rolo-buf t)) - t)))) - (progn - (set-buffer actual-buf) - (let ((num-found 0) - (exact-level-regexp (concat "^\\(" level-regexp "\\)[ \t\n]")) - (outline-regexp rolo-entry-regexp) - (buffer-read-only) - (level-len)) - ;; Load `outline' library since its functions are used here. - (if (not (boundp 'outline-mode-map)) - (load-library "outline")) - (goto-char (point-min)) - ;; Pass buffer header if it exists - (if (re-search-forward rolo-hdr-regexp nil t 2) - (forward-line)) - (while (and (or (null max-groupings) (< num-found max-groupings)) - (re-search-forward exact-level-regexp nil t)) - (setq num-found (1+ num-found)) - (let* ((opoint (prog1 (point) (beginning-of-line))) - (grouping-start (point)) - (start grouping-start) - (level-len (or level-len (- (1- opoint) start))) - (next-level-len) - (next-entry-exists) - (grouping-end) - (no-subtree)) - (while (and (progn - (if (setq next-entry-exists - (re-search-forward - rolo-entry-regexp nil t 2)) - (setq next-level-len - (- (point) - (progn (beginning-of-line) - (point))) - grouping-end - (< next-level-len level-len) - no-subtree - (<= next-level-len level-len)) - (setq grouping-end t no-subtree t) - (goto-char (point-max))) - (let ((end (point))) - (goto-char start) - (hide-subtree) ; And hide multiple entry lines - ;; Move to start of next entry at equal - ;; or higher level. - (setq start - (if no-subtree - end - (if (re-search-forward - rolo-entry-regexp nil t) - (progn (beginning-of-line) (point)) - (point-max)))) - ;; Remember last expression in `progn' - ;; must always return non-nil. - (goto-char start))) - (not grouping-end))) - (let ((end (point))) - (goto-char grouping-start) - (funcall func grouping-start end) - (goto-char end)))) - (show-all) - (rolo-kill-buffer actual-buf) - num-found)) - 0))) - -;;; ************************************************************************ -;;; Private functions -;;; ************************************************************************ - -(defun rolo-add-match (rolo-matches-buffer regexp start end) - "Insert before point in ROLO-MATCHES-BUFFER an entry matching REGEXP from the current region between START to END." - (let ((rolo-buf (current-buffer)) - opoint) - (set-buffer (get-buffer-create rolo-matches-buffer)) - (setq opoint (point)) - (insert-buffer-substring rolo-buf start end) - (rolo-highlight-matches regexp opoint (point)) - (set-buffer rolo-buf))) - -(defun rolo-buffer-exists-p (rolo-buf) - "Returns buffer given by ROLO-BUF or nil. -ROLO-BUF may be a file-name, buffer-name, or buffer." - (car (memq (get-buffer (or (and (stringp rolo-buf) - (get-file-buffer rolo-buf)) - rolo-buf)) - (buffer-list)))) - -(defun rolo-current-date () - "Return the current date (a string) in a form used for rolodex entry insertion." - (let ((year-month-day (htz:date-parse (current-time-string)))) - (format "\t%02s/%02s/%s" - (aref year-month-day 1) - (aref year-month-day 2) - (aref year-month-day 0)))) - -(defun rolo-display-to-entry-end () - "Go to end of current entry, ignoring sub-entries." - (if (re-search-forward (concat rolo-hdr-regexp "\\|" - rolo-entry-regexp) nil t) - (progn (beginning-of-line) (point)) - (goto-char (point-max)))) - - -(defun rolo-format-name (name-str first last) - "Reverse order of NAME-STR field given my regexp match field FIRST and LAST." - (if (match-beginning last) - (concat (substring name-str (match-beginning last) (match-end last)) - ", " - (substring name-str (match-beginning first) (match-end first))))) - -(defun rolo-highlight-matches (regexp start end) - "Highlight matches for REGEXP in region from START to END." - (if (fboundp 'hproperty:but-add) - (let ((hproperty:but-emphasize-p)) - (save-excursion - (goto-char start) - (while (re-search-forward regexp nil t) - (hproperty:but-add (match-beginning 0) (match-end 0) - (or rolo-highlight-face - hproperty:highlight-face))))))) - -(defun rolo-kill-buffer (&optional rolo-buf) - "Kills optional ROLO-BUF if unchanged and `rolo-kill-buffers-after-use' is t. -Default is current buffer." - (or rolo-buf (setq rolo-buf (current-buffer))) - (and rolo-kill-buffers-after-use (not (buffer-modified-p rolo-buf)) - (kill-buffer rolo-buf))) - -(defun rolo-name-and-email () - "If point is in a mail message, returns list of (name email-addr) of sender. -Name is returned as `last, first-and-middle'." - (let ((email) (name) (from)) - (save-window-excursion - (if (or (hmail:lister-p) (hnews:lister-p)) - (other-window 1)) - (save-excursion - (save-restriction - (goto-char (point-min)) - (if (search-forward "\n\n" nil t) - (narrow-to-region (point-min) (point))) - (setq email (mail-fetch-field "reply-to") - from (mail-fetch-field "from"))))) - (if from - (cond - ;; Match: email, email (name), email "name" - ((string-match - (concat "^\\([^\"<>() \t\n]+\\)" - "\\([ \t]*[(\"][ \t]*\\([^\"()]+\\)[ \t]+" - "\\([^\" \t()]+\\)[ \t]*[)\"]\\)?[ \t]*$") - from) - (setq name (rolo-format-name from 3 4)) - (or email (setq email (substring from (match-beginning 1) - (match-end 1))))) - ;; Match: <email>, name <email>, "name" <email> - ((string-match - (concat "^\\(\"?\\([^\"<>()\n]+\\)[ \t]+" - "\\([^\" \t()<>]+\\)\"?[ \t]+\\)?" - "<\\([^\"<>() \t\n]+\\)>[ \t]*$") - from) - (setq name (rolo-format-name from 2 3)) - (or email (setq email (substring from (match-beginning 4) - (match-end 4))))))) - (if (or name email) - (list name email)))) - -(defun rolo-name-at () - "If point is within an entry in `rolo-display-buffer', returns entry, else nil." - (if (string-equal (buffer-name) rolo-display-buffer) - (save-excursion - (if (or (looking-at rolo-entry-regexp) - (progn (end-of-line) - (re-search-backward rolo-entry-regexp nil t))) - (progn (goto-char (match-end 0)) - (skip-chars-forward " \t") - (if (or (looking-at "[^ \t\n\^M]+ ?, ?[^ \t\n\^M]+") - (looking-at "\\( ?[^ \t\n\^M]+\\)+")) - (buffer-substring (match-beginning 0) - (match-end 0)))))))) - -(defun rolo-narrowed-p () - (or (/= (point-min) 1) (/= (1+ (buffer-size)) (point-max)))) - -(defun rolo-save-buffer (&optional rolo-buf) - "Saves optional ROLO-BUF if changed and `rolo-save-buffers-after-use' is t. -Default is current buffer. Used, for example, after a rolo entry is killed." - (or rolo-buf (setq rolo-buf (current-buffer))) - (and rolo-save-buffers-after-use (buffer-modified-p rolo-buf) - (set-buffer rolo-buf) (save-buffer))) - -(defun rolo-set-date () - "Add a line with the current date at the end of the current rolodex entry. -Suitable for use as an entry in `wrolo-add-hook' and `wrolo-edit-hook'. -The default date format is MM/DD/YYYY. Rewrite `rolo-current-date' to -return a different format, if you prefer." - (save-excursion - (skip-chars-forward "*") - (rolo-to-entry-end) - (skip-chars-backward " \t\n\r\f") - (skip-chars-backward "^\n\r\f") - (if (looking-at "\\s-+[-0-9./]+\\s-*$") ;; a date - (progn (delete-region (point) (match-end 0)) - (insert (rolo-current-date))) - (end-of-line) - (insert "\n" (rolo-current-date))))) - -(defun rolo-shrink-window () - (let* ((lines (count-lines (point-min) (point-max))) - (height (window-height)) - (window-min-height 2) - (desired-shrinkage (1- (min (- height lines))))) - (and (>= lines 0) - (/= desired-shrinkage 0) - (> (frame-height) (1+ height)) - (shrink-window - (if (< desired-shrinkage 0) - (max desired-shrinkage (- height (/ (frame-height) 2))) - (min desired-shrinkage (- height window-min-height))))))) - -(defun rolo-to (name &optional file-list) - "Moves point to entry for NAME within optional FILE-LIST. -`rolo-file-list' is used as default when FILE-LIST is nil. -Leaves point immediately after match for NAME within entry. -Switches internal current buffer but does not alter the frame. -Returns point where matching entry begins or nil if not found." - (or file-list (setq file-list rolo-file-list)) - (let ((found) file) - (while (and (not found) file-list) - (setq file (car file-list) - file-list (cdr file-list)) - (cond ((and file (or (not (stringp file)) (string= file ""))) - (error "(rolo-to): Invalid file: `%s'" file)) - ((and (file-exists-p file) (not (file-readable-p file))) - (error "(rolo-to): File not readable: `%s'" file))) - (set-buffer (or (get-file-buffer file) (find-file-noselect file))) - (let ((case-fold-search t) (real-name name) (parent "") (level) end) - (widen) (goto-char 1) - (while (setq end (string-match "/" name)) - (setq level nil - parent (substring name 0 end) - name (substring name (min (1+ end) (length name)))) - (cond ((progn - (while (and (not level) (search-forward parent nil t)) - (save-excursion - (beginning-of-line) - (if (looking-at - (concat "\\(" rolo-entry-regexp "\\)[ \t]*" - (regexp-quote parent))) - (setq level (buffer-substring (match-beginning 1) - (match-end 1)))))) - level)) - ((equal name real-name));; Try next file. - (t;; Found parent but not child - (setq buffer-read-only nil) - (rolo-to-buffer (current-buffer)) - (error "(rolo-to): `%s' part of name not found in \"%s\"." - parent file))) - (if level - (narrow-to-region (point) - (save-excursion - (rolo-to-entry-end t level) (point))))) - (goto-char (point-min)) - (while (and (search-forward name nil t) - (not (save-excursion - (beginning-of-line) - (setq found - (if (looking-at - (concat "\\(" rolo-entry-regexp - "\\)[ \t]*" - (regexp-quote name))) - (point)))))))) - (or found (rolo-kill-buffer))) ;; conditionally kill - (widen) - found)) - -(defun rolo-to-buffer (buffer &optional other-window-flag frame) - "Pop to BUFFER." - (cond (hyperb:lemacs-p - (pop-to-buffer buffer other-window-flag - ;; default is to use selected frame - (or frame (selected-frame)))) - (t (pop-to-buffer buffer other-window-flag)))) - -(defun rolo-to-entry-end (&optional include-sub-entries curr-entry-level) -"Goes to end of whole entry if optional INCLUDE-SUB-ENTRIES is non-nil. -CURR-ENTRY-LEVEL is a string whose length is the same as the last found entry -header. If INCLUDE-SUB-ENTRIES is nil, CURR-ENTRY-LEVEL is not needed. -Returns current point." - (while (and (setq next-entry-exists - (re-search-forward rolo-entry-regexp nil t)) - include-sub-entries - (> (- (point) (save-excursion - (beginning-of-line) - (point))) - (length curr-entry-level)))) - (if next-entry-exists - (progn (beginning-of-line) (point)) - (goto-char (point-max)))) - -(defun wrolo-mode () - "Major mode for the rolodex match buffer. -Calls the functions given by `wrolo-mode-hook'. -\\{wrolo-mode-map}" - (interactive) - (setq major-mode 'wrolo-mode - mode-name "Rolodex") - (use-local-map wrolo-mode-map) - ;; - (set-syntax-table wrolo-mode-syntax-table) - ;; - ;; Loads menus under non-tty InfoDock, XEmacs or Emacs19; does nothing - ;; otherwise. - (and (not (featurep 'wrolo-menu)) hyperb:window-system - (or hyperb:lemacs-p hyperb:emacs19-p) (require 'wrolo-menu)) - ;; - (if (not (fboundp 'outline-minor-mode)) - nil - (outline-minor-mode 1)) - (run-hooks 'wrolo-mode-hook)) - -;;; ************************************************************************ -;;; Private variables -;;; ************************************************************************ - -(defvar rolo-display-buffer "*Rolodex*" - "Buffer used to display set of last matching rolodex entries.") - -(defvar rolo-entry-regexp "^\\*+" - "Regular expression to match the beginning of a rolodex entry. -This pattern must match the beginning of the line. Entries may be nested -through the use of increasingly longer beginning patterns.") - -(defconst rolo-hdr-format - (concat - "======================================================================\n" - "%s\n" - "======================================================================\n") - "Header to insert preceding a file's first rolodex entry match when -file has none of its own. Used with one argument, the file name." -) - -(defconst rolo-hdr-regexp "^===" - "Regular expression to match the first and last lines of rolodex file headers. -This header is inserted into rolo-display-buffer before any entries from the -file are added.") - -(defconst rolo-match-regexp nil - "Last regular expression used to search the rolodex. -Nil before a search is done. -String search expressions are converted to regular expressions.") - -(defvar *rolo-wconfig* nil - "Saves frame's window configuration prior to a rolodex search.") - -(defvar wrolo-mode-syntax-table nil - "Syntax table used while in wrolo match mode.") - -(if wrolo-mode-syntax-table - () - (setq wrolo-mode-syntax-table (make-syntax-table text-mode-syntax-table)) - ;; Support syntactic selection of delimited e-mail addresses. - (modify-syntax-entry ?< "(>" wrolo-mode-syntax-table) - (modify-syntax-entry ?> ")<" wrolo-mode-syntax-table)) - -(defvar wrolo-mode-map nil - "Keymap for the rolodex match buffer.") - -(if wrolo-mode-map - nil - (setq wrolo-mode-map (make-keymap)) - (if (fboundp 'set-keymap-name) - (set-keymap-name wrolo-mode-map 'wrolo-mode-map)) - (suppress-keymap wrolo-mode-map) - (define-key wrolo-mode-map "<" 'beginning-of-buffer) - (define-key wrolo-mode-map ">" 'end-of-buffer) - (define-key wrolo-mode-map "." 'beginning-of-buffer) - (define-key wrolo-mode-map "," 'end-of-buffer) - (define-key wrolo-mode-map "?" 'describe-mode) - (define-key wrolo-mode-map "\177" 'scroll-down) - (define-key wrolo-mode-map " " 'scroll-up) - (define-key wrolo-mode-map "a" 'show-all) - (define-key wrolo-mode-map "b" 'outline-backward-same-level) - (define-key wrolo-mode-map "e" 'rolo-edit-entry) - (define-key wrolo-mode-map "f" 'outline-forward-same-level) - (define-key wrolo-mode-map "h" 'hide-subtree) - (define-key wrolo-mode-map "m" 'rolo-mail-to) - (define-key wrolo-mode-map "n" 'outline-next-visible-heading) - (define-key wrolo-mode-map "p" 'outline-previous-visible-heading) - (define-key wrolo-mode-map "q" 'rolo-quit) - (define-key wrolo-mode-map "r" 'rolo-previous-match) - (define-key wrolo-mode-map "s" 'show-subtree) - (define-key wrolo-mode-map "\M-s" 'rolo-isearch) - (define-key wrolo-mode-map "t" 'hide-body) - (define-key wrolo-mode-map "\C-i" 'rolo-next-match) ;; {TAB} - (define-key wrolo-mode-map "\M-\C-i" 'rolo-previous-match) ;; {M-TAB} - (define-key wrolo-mode-map "u" 'outline-up-heading) - ) - -(provide 'wrolo)
--- a/lisp/ilisp/ACKNOWLEDGMENTS Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,14 +0,0 @@ -Thanks to Guido Bosch, David Braunegg, Tim Bradshaw, Thomas M. Breuel, -Hans Chalupsky, Kimball Collins, Brian Dennis, David Duff, Tom -Emerson, Michael Ernst, Scott Fahlman, David Gadbois, Robert -P. Goldman, Marty Hall, Richard Harris, Jim Healy, Christopher Hoover, -Larry Hunter, Ben Hyde, Chuck Irvine, Michael Kashket, Mark -Kantrowitz, Qiegang Long, Erik Naggum, Dan Pierson, Yusuf Pisan, Frank -Ritter, Jeffrey Mark Siskind, Neil Smithline, Richard Stallman, Larry -Stead, Jason Trenouth, Christof Ullwer, Bjorn Victor, Fred White, Ben -Wing, Matsuo Yoshihiro, Jamie Zawinski, Paul Fuqua (for the CMU-CL GC -display code) and Marco Antoniotti for bug reports, suggestions and -code. Our apologies to anyone we may have forgotten. - -Special thanks to Todd Kaufmann for the texinfo file, work on bridge, -epoch-pop and for really exercising everything.
--- a/lisp/ilisp/COPYING Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,80 +0,0 @@ -COPYING -- TERMS AND LICENSING AGREEMENT FOR ILISP -------------------------------------------------------------------------------- - -This file is part of ILISP. -Version: 5.8 -Date: 15 July 1996 - -Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell - 1993, 1994 Ivan Vasquez - 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker - 1996 Marco Antoniotti and Rick Campbell - -Other authors' names for which this Copyright notice also holds -may appear later in this file. - -Send mail to 'ilisp-request@naggum.no' to be included in the -ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -mailing list were bugs and improvements are discussed. - -------------------------------------------------------------------------------- - -ILISP if freely redistributable. Eventually it may become part of GNU -Emacs and it will in that case comply with the GPL. - -For the time being we adopt the following licensing agreement. Such -licensing agreement may be overridden by the licensing notice -contained in an individual file and for that file only. - -------------------------------------------------------------------------------- - - GENERAL LICENSE AGREEMENT AND LACK OF WARRANTY - - -This software is distributed in the hope that it will be useful (both -in and of itself and as an example of lisp programming), but WITHOUT -ANY WARRANTY. The author(s) do not accept responsibility to anyone for -the consequences of using it or for whether it serves any particular -purpose or works at all. No warranty is made about the software or its -performance. - -Use and copying of this software and the preparation of derivative -works based on this software are permitted, so long as the following -conditions are met: - o The copyright notice and this entire notice are included intact - and prominently carried on all copies and supporting documentation. - o No fees or compensation are charged for use, copies, or - access to this software. You may charge a nominal - distribution fee for the physical act of transferring a - copy, but you may not charge for the program itself. - o If you modify this software, you must cause the modified - file(s) to carry prominent notices (a Change Log) - describing the changes, who made the changes, and the date - of those changes. - o Any work distributed or published that in whole or in part - contains or is a derivative of this software or any part - thereof is subject to the terms of this agreement. The - aggregation of another unrelated program with this software - or its derivative on a volume of storage or distribution - medium does not bring the other program under the scope - of these terms. - o Permission is granted to manufacturers and distributors of - lisp compilers and interpreters to include this software - with their distribution. - -This software is made available AS IS, and is distributed without -warranty of any kind, either expressed or implied. - -In no event will the author(s) or their institutions be liable to you -for damages, including lost profits, lost monies, or other special, -incidental or consequential damages arising out of or in connection -with the use or inability to use (including but not limited to loss of -data or data being rendered inaccurate or losses sustained by third -parties or a failure of the program to operate as documented) the -program, even if you have been advised of the possibility of such -damanges, or for any claim by any other party, whether in an action of -contract, negligence, or other tortious action. - -January 4th, 1995 - -# end of file -- COPYING --
--- a/lisp/ilisp/GETTING-ILISP Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,59 +0,0 @@ -FTP directions -============== - -You can get the distribution file, `ilisp-5.8.tar.gz' via anonymous -FTP from `FTP.CS.CMU.EDU' (128.2.206.173) in -`/afs/cs/user/campbell/http/ilisp/'. - -% ftp ftp.cs.cmu.edu -Name (ftp.cs.cmu.edu:rickc): anonymous -331 Guest login ok, send username@node as password. -Password: YOUR-USER-ID@YOUR-HOSTNAME -ftp> cd /afs/cs/user/campbell/http/ilisp -250 Directory path set to /afs/cs/user/campbell/http/ilisp. -ftp> type binary -200 Type set to I. -ftp> get ilisp-5.8.tar.gz -200 PORT command successful. -150 Opening data connection for ilisp-5.8.tar.gz. -226 Transfer complete. -local: ilisp-5.8.tar.gz remote: ilisp-5.8.tar.gz -168801 bytes received. -ftp> quit -221 Goodbye. - -Or get whatever single files you need from the `untarred' -subdirectory. - -You can also get `ilisp-5.8.tar.gz' via anonymous FTP from -`FTP.ICSI.BERKELEY.EDU' in either `/pub/software/elisp/' or -`/pub/theory/marcoxa/elisp/'. - - - - -WWW directions -============== - -You can use the World Wide Web (WWW) to get the distribution file from -the anonymous FTP locations using one of the following URLs: - * ftp://ftp.cs.cmu.edu/afs/cs/user/campbell/http/ilisp/ilisp-5.8.tar.gz - - * ftp://ftp.icsi.berkeley.edu/pub/software/elisp/ilisp-5.8.tar.gz - - * ftp://ftp.icsi.berkeley.edu/pub/theory/marcoxa/ilisp-5.8.tar.gz - - You can also use the CMU Artificial Intelligence Repository: - - http://www.cs.cmu.edu/Web/Groups/AI/html/repository.html - -From there follow: `LISP', `UTIL', `EMACS' and finally `ILISP'. Use -your browser capabilities to download what you need. - -The complete URL for the distribution file in the CMU AI Repository is -http://www.cs.cmu.edu/afs/cs/project/ai-repository/ai/lang/lisp/util/emacs/ilisp/v57/ilisp57.tgz - -Other URLs for the distribution file include: - * http://www.c2.net/~campbell/ilisp/ilisp-5.8.tar.gz - - * http://www.cs.cmu.edu/~campbell/ilisp/ilisp-5.8.tar.gz
--- a/lisp/ilisp/HISTORY Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,482 +0,0 @@ -# -*- Mode: Text -*- - -ILISP HISTORY - -=============================================================================== -Version 5.8 alpha - -Fixes and enhancements since 5.7 - --- XLISP and XLISPSTAT support has been added on an experimental way. - Please give us feedback on their behavior. - --- There is now a way to disable the DEFPACKAGE feature for GCL. But - it is not turned on. You have to fix it manually by transforming two - '#+(and nil gcl)' into '#+(and t gcl)' - --- A few fixes were made to realign ILISP to Xemacs 19.14 - --- The file 'clisp.lisp' has been renamed to 'cl-ilisp.lisp', in order - to avoid confusion with the CLISP implementation of Common Lisp. - --- The file ILISP.prj (if present) can be safely ignored unless you - want to use the PRCS project control system - (http://http.cs.berkeley.edu/~jmacd/prcs-home.html) - --- Changed 'comint-ipc' and 'bridge'. They now use - 'process-send-string' instead of defining specialized versions of - it. (This was done because it appears that the newer versions of - 'comint' have a 'process-send-string' that does what these specialized - versions used to do.) - --- Added constant '+ilisp-emacs-minor-version-number+' (in 'ilcompat'). - --- Conditionalized loading of 'bridge.el' (in 'ilisp'). - --- Fixed the annoying ECL/GCL glitch in 'ilisp-kcl' and the error - regexps for KCL and IBCL in the same file - --- Patched 'comint-ipc' according to suggestion by Kazuhiro Fujieda. - --- Patched 'ilisp-out' according to suggestion by Kazuhiro Fujieda. - - -Known Bugs - --- Allegro multiprocessing output handling is still broken. This is a - though one and the maintaners cannot fix it. - -------------------------------------------------------------------------------- - -Version 5.7 - -Fixes and enhancements since 5.6: - --- ILISP now unpacks in a directory called ./ilisp-<version>. - --- Fixed various simple bugs in the init files (hooks et - similia). Check 'ilisp.el' and 'ilisp.emacs' for details. - --- Support for different Emacs versions has been broken down in - various version specific files. See: - ilcompat.el (new name for compatibility file) - ilfsf19.el - ilfsf18.el - illuc19.el = ilxemacs.el - --- ILISP is now compiled with version 19 bytecodes when - appropriate. (This should work at least for FSF 19.xx). - --- Added a primitive menubar entry. - --- Included the bug fixes for source file tracking. - --- The Makefile now contains a new target called 'loadfile', which - generates a file called 'ilisp-all.elc'. This speeds up ILISP sturtup. - --- Popping to the inferior lisp buffer is now done in a more - intelligent way in FSF-19 (i.e. if a frame with the appropriate - window is available, then that frame is raised instead of - recreating a window in the current one). - --- The ILD uniform Lisp debugger by J. Siskind has been added to the - distribution (file 'ild.mail'). ILD is not integrated yet with - ILISP, but it is important enough that people should experiment - with it. - --- The texinfo file has been fixed. - --- New dialects have been added: GCL, ECL, Harlequin Lispworks, CLISP. - --- The special-form-p/special-operator-p mess should be fixed (at - least in CMUCL). - --- Cleaned up support for Lucid, Allegro and CMULISP. - --- The file 'scheme2c.mail' contains a trick to make Scheme->C to work - with ILISP. - --- The file 'ilisp-s2c.el' contains a first cut definition of the - Scheme->C dialect. Note that this file is neither byte compiled nor - loaded. - - -Known bugs: - --- Keymap handling is still rather inflexible. Either you like the - setup or you don't. (A patch by Kimball Collins was not inserted in - the code because we feel there should be a more thorough cleanup). - --- AKCL and GCL may cause an error in the sturtup procedure of ILISP. We (the - maintainers) have been unable to track down this one since we have - not access to an AKCL or GCL environment. Please help us. - --- Source level tracking for interpreted code in CMUCL may still break down - unexpectedly. This is due to the inner working of CMUCL and there - is no easy fix. We try to fall back on the TAG machinery. - --- The menu entry does not track correctly the status of the inferior - lisp. I.e. there is no code yet that disables the menu items when - the inferior Lisp is not running anymore. - --- Package tracking is still somewhat flaky. - --- Multiprocessing Lisps may still cause problems with prompts. This - has been noticed especially with Allegro CL. - --- The "send the source even if compiled file file exist" bug is still - in place. - - -=============================================================================== -Mon, 11 Jul 94 10:48:24 EDT Version 5.6 Released - --- Works once again with GNU emacs 19.25, lemacs 19.10. and emacs 18.58. - --- The popper facility has been completely replaced by a much less - intrusive facility which has most of the original functionality. - All ilisp output is funneled through the function which is the value - of the variable ilisp-display-output-function. Several sample display - functions are provided. Do c-H m in an ilisp buffer for more info. - --- The common lisp arglist printer has been prettified somewhat. - --- Ilisp no longer tries to handle lisp errors by default. This is - controlled by the varible ilisp-handle-errors. - --- Many of the hairy regexps used to located definitions have been - broken out into separate variables. One is ilisp-cl-source-locater-patterns, - which is an alist of (function-type regexp) - --- Compile-defun, eval-defun and friends display the returned lisp value. - --- Defined variables for the init files for the built-in dialects, to ease - customization (ilisp-clisp-init-file, etc). - --- Some handy new functions: ilisp-lispm-bindings, repair-ilisp. - --- A minor bugfix in ilisp-send. - --- A simplified makefile. - -=============================================================================== -Fixes in 5.5: - --- Now works with lemacs 19.8 (to be released soon) in addition to all - the other versions of emacs around. - -=============================================================================== -Fixes in 5.4: - --- Added support for CMUCL 17b. - --- Fixed definition regexp in ilisp-locate-ilisp. Thanks to Paul - Krause. - --- Hacked popper to make output lines of one line or less get - displayed in the message buffer, depending on the variable - popper-use-message-buffer. - -=============================================================================== -Fixes in 5.3: - --- Fixes some problems in clisp.lisp - --- Makefile-ilisp now valid for Sun's distributed `make'. - --- Did the right thing regarding autoloads (yes you have to define them -in your .emacs, and make them autoload "ilisp".) See ilisp.emacs - --- Put the run-hooks calls at the end of ilisp.el where they should - be. - - "Fixes" in version 5.2 of ILISP. - -Cause more problems with autoloads and fixes a missing definition in the -Makefile-ilisp in 5.1 - - "Fixes" in version 5.1: - -It removes some correct information concerning autoloads in ilisp.texi -and ilisp.emacs that was released in 5.0 - -====================================================================== -Sat Jun 26 14:22:01 1993 Version 5.0 Released - -Changes: - -The major changes from 4.12: - ---Now works with emacs-18, fsf emacs-19, and Lucid emacs-19. - ---Major file splitting done in an attempt to modularize ILISP. - ---Added LISP-DONT-CACHE-PACKAGE lets users tell ILISP to search for the -most recent IN-PACKAGE on each eval/compile in a lisp buffer. - ---Added 'message feature for lisp-no-popper, allows output from ILISP -to be sent to the message window (instead of via the popper or the -inferior lisp buffer) if it is one line long. Useful for small -arg-lists, etc. Now the default. - ---Made the popper be off by default. To have the popper on, set -popper-pop-buffers and popper-buffers-to-skip to t in a -popper-load-hook. See the sample in popper.el - -FEATURES: - -+Support for multiple LISP dialects including Lucid, Allegro, KCL, -AKCL, IBCL and CMU on multiple machines even at the same time. - -+Dynamically sized pop-up windows that can be buried and scrolled from -any window. - -+Packages are properly handled including the distinction between -exported and internal symbols. - -+Synchronous, asynchronous or batch eval and compile of files, -regions, definitions and sexps with optional switching and automatic -calling. - -+Arglist, documentation, describe, and macroexpand. - -+Completion of filename components and LISP symbols including partial -matches. - -+Find source both with and without help from the inferior LISP. -Including CLOS methods, multiple definitions and multiple files. Also -works for automatically generated functions like defstruct. - -+Edit the callers of a function with and without help from the -inferior LISP. - -+Trace/untrace a function. - -+Esc-q works properly on paragraphs in comments, strings and code. - -+Find unbalanced parentheses. - -+Super brackets. - -+Handles editing, entering and indenting full LISP expressions. - -+Next/previous and similar history mechanism compatible with comint. - -+Handles LISP errors. - -+Result histories are maintained in the inferior LISP. - -+Does not create spurious symbols and handles case issues. - -+Raw keyboard mode allows interaction with interactive programs -through Emacs. - -+Online manuals for ILISP. - -====================================================================== -92/03/17 Version 4.12 released - -Changes: Fixed an intermittent send bug. Made it so that popper is -not required so aggressively. Ignore symbolics font information of -source. Made lisp-end-defun-text so that it would work in non-lisp -modes. Set the package for ilisp-arglist. Made error dispatch case -insensitive. Fixed lisp-directory to add files when lisp-edit-files -is t. Fixed clisp.lisp compile for lucid. Made -comint-interrupt-subjob interactive. Updated popper to run with emacs -19. Fixed popper-wraps so that shell-command gets wrapped at load -time and changed it to be a function. Added newline at end of bug -messages. Updated the cmulisp interface file to run with the lastest -CMU CL release. Made sure that *standard-output* and *error-output* -are bound to *terminal-io*. Fixed completer so that last completion -was accurate in the case of interruptions. Added a path cache to -completer. Fixed completer so that Meta-return completes to best guess -and so that the full pattern is used for disambiguation. Fixed + -history so that it is saved/restored. Fixed popper so that popping up -a window when in a popper window resuses the same window and if the -buffer is changed within a temp-buffer-show form, it works properly. -Fixed lisp-defun-end so that it no longer includes to the end of the -line. Made it so that initialization through commands did not try to -synchronize with the inferior LISP. Fixed edit-definitions-lisp so -that it would work if there is no inferior lisp. Fixed popper-wrap so -that it included numeric documentation strings. Made it so that -popper preserves the buffer point and scrolling backwards wraps -around. Incoroporated the latest version of completion. Added -documentation on global-map bindings. Added -ilisp-load-no-compile-query. Added ilisp-use-map so that keymaps can -be switched in dialect definitions. Added completer-any-delimiter to -completer. Fixed bug in completer that caused relative file names to -get erased. Fixed popper so that it handled killed buffers, popped -faster and had negative buffer lists. Fixed it so that -dialect-program doesn't get stomped by loading ilisp. Made it so that -ilisp-bug doesn't stomp on someone's unfinished message. Look for -both .elc and .el files for setting ilisp-directory. Fixed a bug in -lucid that prevented compilation of the interface files on some -implementations. Fixed epoch-pop so that it quits nicer. Fixed bug -in CMU LISP interface. Added *features* to ilisp-bug. Fixed bugs in -completer when extending directories and for Apollo and AFS. Fixed -popper so that it does not remove the trailing newline. Made -lisp-buffer smart about killed buffers. - -====================================================================== -91/05/08 Version 4.11 released - -Changes: Improved the way that completer handled filenames ending with -a / and relative pathnames. Added popper-wrap to popper for functions -that don't use with-output-to-temp-buffer. Added popper-empty-min and -popper-min-heights. Made popper-pop-buffers and popper-buffers-to-skip -default to t. Fixed lisp-prefix-p so that reusing completion tables -works better. Fixed a bug in lisp-end-defun-text that made things -weird when people did not use ;;; for top comment blocks. Improved -ilisp-bug so that it gives more information and is less likely to -break. Put interface files in their own package. Changed -ilisp-compile to funcall of compile for all except lucid. Fixed a bug -in lisp-pop-to-buffer that put the lisp in the popper buffer. Fixed a -bug in ilisp-matching-symbols that prevented pattern matching with a -pattern that matched the last word. Bare CR's now send an empty -string. Made it so that allegro init binary extensions default to -excl:*fasl-default-type* unless on a known platform. Added fboundp to -generic-function-p in ilisp-arglist. Fixed KCL and friends dialects. -Fixed a couple of small bugs in completer. Added raw keyboard mode. -Fixed lisp-pop-to-buffer so that the buffer was always selected which -fixed a bug in edit-definitions and friends. Removed space from KCL -comint-prompt-regexp. Added inspect-lisp. Fixed a bug in popper-show -that complained if buffer was a string and fixed call in -who-calls-lisp. Fixed some bugs in completer that completed too much -for local returns and that nuked the string if confirmation was -required. - -====================================================================== -91/03/19 Version 4.10 released - -Changes: Changed the default binding of close-and-send-lisp. Added -better dialect support for kcl, akcl, and ibcl. Improved the run-time -detection of PCL/CLOS in clisp.lisp. Fixed a nasty popper bug if you -tried to pop up a window when in a popper window. Made it so that -popper-other-window would switch to the popper window when called with -a C-u prefix. Added support for allegro 4.0. Made lisp-in-string -smarter about escaped " so that close-all-lisp worked better. Renamed -reparse-attribute-list and made it so that you can specify manual -packages. Improved partial completion of symbols so that it goes to -the ambiguous part. Changed it so that uncompiled interface files -complain rather than compile. Improved completer so that it completes -pathname components. Made it so that dialects could be started up -with emacs switches. Incorporated a new fancier version of -reposition-window-lisp. Fixed restore so that it no longer printed -messages when there were multiple line values restored. Added -trace-function-lisp. Improved lisp-function-name when it is in a -string. Changed initialization so that there is a dialect specific -program variable and the defaults are better and sticky. -lucid-check-prompt was hosed which of course broke everything in -Lucid. Fixed load-file-lisp so that it allows interaction and senses -compile errors better. Added process bridges. Added -comint-always-scroll. Made allegro macroexpand so that it would walk -instead. Fixed popper so that switching to the popper buffer worked. -Fixed close-all-lisp so that it did not blow away # or ' at start of -sexp. Fixed ilisp-buffer so that it complained if the buffer was -killed out from under it. Changed ilisp-filter-regexp to filter all -lone keywords. Added prefix arg to documentation-lisp so that -function call doc could be gotten. Set ilisp-directory in -initialization so that it could be built into Emacs image. Added -Franz online common lisp manual. Added reset-ilisp to reset to -top-level and made it so that delete-char would pop one level at the -end. Added call-defun-lisp and bound it to C-z y. Fixed the binding -for popper-grow-output. Added lisp-no-popper to stop using popper. -Fixed compile-defun-lisp so that it would compile the previous form in -the inferior LISP. Made it so that the entire in-package sexp is sent -to the inferior so that nicknames get set. Added package-lisp and -set-package-lisp. Removed eval-prev-sexp-lisp and made -eval-next-sexp-lisp do that with a negative prefix. Fixed -lisp-defun-name so that it returned just the function name. Added -lisp-region-name to better name regions. Improved messages in -interrupt-subjob-lisp. Added sit-for to all accept-process-output -loops to prevent locking up Emacs in Sys V. Changed how -comment-region-lisp treated the end of the region and fixed a nasty -bug for a region including the eob. Made changes to clisp.lisp for -lucid and kcl. Added better kcl dialect definition. Made it so that -end-of-defun-lisp would require ;;; at the left margin to decide that -the next definition had started. Made it so that multiple sexps could -be typed to the top-level. Made it so that all popper windows could -be skipped. Simplified the ilisp-package-regexp. - -====================================================================== -90/12/30 Version 4.00 released - -IMPROVEMENTS: Process stuff has been rewritten and much improved. If -you prefer the old eval/compile behavior, set lisp-wait-p to t in your -ilisp-load-hook. Improved edit-definitions and edit-callers so that -they support multiple definitions of any LISP object even if the -inferior LISP does not store the information. Added support for -Epoch. Separated out lisp-mode extensions, symlink fix, source stuff -and batch eval/compile. Lots of minor improvements, see details -below. - -INCOMPATIBLE CHANGES: Renamed interactive functions to put package -specification at the end so that names were quicker to specify and -some internal functions so that they were unique to ilisp. -ilisp-clisp now takes the full file name. ilisp-load-or-send-command -now takes the binary and source paths explicitly. The ilisp- prefix -was removed from dialect file names. ilisp-definition-regexp has gone -away. ilisp-prompt, ilisp-fix-error and ilisp-continue have gone away -in favor of the actual comint- variables. ilisp-expand-symlinks has -gone away. - -DETAILS: Finally fixed up how many newlines are inserted. Made it so -that the source file stuff would use a resident buffer with the same -name if available. Added ilisp-filter-length to the input filter. -When reading a symbol, the inferior lisp is no longer queried with an -empty string. newline-and-indent-ilisp will send a string w/o a new -line if called at the end of a buffer. This was so that raw character -i/o could be done in some lisps. All comint and comint-ipc variables -can now be set in hooks and the right thing will happen. Made -lisp-end-defun-text skip over leading comments. Added the functions -search-in-lisp-files and replace-in-lisp-files. Prevented the -addition of duplicate entries to the input ring and expanded its size -to 200 entries. Made lisp-def-name so that it adds the name of the -defining form and returns an empty string at the end of a buffer. -Swapped bindings of macroexpand-lisp and macroexpand-1-lisp. Fixed -expand-file-name bug if // was at the start of a filename. Fixed -obscure bug in make-local-variable. Added ilisp-other-prompt and -bol-ilisp. Added case-fold-search to appropriate places. Fixed error -recovery in ilisp-completer. Removed extra parentheses in the string -for ilisp-init-binary-command. Added documentation on scrolling the -popper window backwards. Fixed comment-region so that it handles -empty lines and deleting spaces at the start. Fixed behavior of -reindent-lisp on comments at the start and end of a buffer. Saved the -point in reposition-window-lisp. Rewrote close-all-lisp so that it -inserted a bracket if in a string and was better behaved WRT non sexp -brackets and so that it could close all brackets. Removed breaks in -lisp-end-defun-text for unclosed strings. Added comint-check-prompt -to comint-ipc so that dialects can be smarter about errors. Added -ilisp-check-prompt and allegro and lucid definitions. Changed -edit-callers so that it uses the name of the current defun as its -default. Changed popper so that it handles more windows, removes -trailing lines, is nicer about bindings and added popper-grow-output. -Also added epoch-pop for epoch. Made lisp-input-start work if the -point was at the start of the line the prompt was on. This made -reindent-lisp and close-all-lisp work in ilisp mode. Added -close-and-send-lisp. Made it so that bindings are only done after the -hooks are run. Shorter clisp error messages. Removed -ilisp-definition-regexp and replaced it with ilisp-locator. Made -message optional in ilisp-send and ilisp-send-string. Added a startup -message to ilisp buffers. Made it so that there is filename -completion when prompting for lisp program. Fixed bug in -ilisp-load-init. Made it so that if an eval/compile worked normally, -no message was displayed. Fixed lucid ilisp-list-callers so that it -does not recurse forever. Changed lisp-list-callers to who-calls-lisp -and made it so that it would display the buffer. Added ilisp-dialect -as a list of dialect names for the inferior LISP. Added partial -minibuffer completion. Improved filename completion help in -complete-lisp. Added ilisp-bug for bug reporting. Improved case -handling for clisp. popper v2.00, completer v2.00. - -====================================================================== -10/12/90 Version 3.0 released. Improved pop-up windows, symbol -completion, package handling, compilation and initialization. -Changed default binding prefix. Added trace/untrace and -evaluation of defvars. - -====================================================================== - 8/22/90 Version 2.0 released. Fixed bugs and changed initialization. - -====================================================================== - 6/11/90 Version 1.0 released.
--- a/lisp/ilisp/INSTALLATION Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,73 +0,0 @@ --*- Mode: Text -*- - -WELCOME TO ILISP. - -FIRST INSTALLATION STEP: UNPACKING AND COMPILING. - -SECOND INSTALLATION STEP: DIALECT REQUIREMENTS. - -ILISP assumes a minimum of CLtL2 compliance. This requirements -immediately clashes with the problems of some KCL-derivativs, -including GCL. Here is a list of known problems for several CL -implementations (we do not know whether there are problems with -Scheme's - please let us know). - -o All dialects - - Be sure that the variables: - - ilisp-binary-extension - ilisp-init-binary-extension - ilisp-binary-command - - Have the appropriate value. Older versions of ILISP (< 5.8) - assumed a single CL installation and suggested a change to the - hook 'ilisp-site-hook' in the 'ilisp.emacs' file. - - This should not be so anymore. - - -o KCL, AKCL, Ibuki, GCL, and ECL - - - DEFPACKAGE - You need to have your system configured with a - DEFPACKAGE. You can either generate an image which contains - it or you can arrange the init file to load it for you. - - You can find a DEFPACKAGE in the AI.Repository of CMU. - - - LOOP - Most likely the DEFPACKAGE will require a full fledged LOOP. - The same instructions apply. - - -o CMUCL - - Try to set the variables: - - cmulisp-source-directory-regexp - cmulisp-local-source-directory - - To sensible values. - - -o Harlequin - - No known extra installation glitches - - -o Lucid - - No known extra installation glitches - - -o Allegro - - No known extra installation glitches - - -o CLISP - - No known extra installation glitches - -
--- a/lisp/ilisp/Makefile Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,120 +0,0 @@ -# -*- Mode: Makefile -*- - -# Makefile -- -# This file is part of ILISP. -# Version: 5.8 -# -# Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -# 1993, 1994 Ivan Vasquez -# 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -# 1996 Marco Antoniotti and Rick Campbell -# -# Send mail to 'ilisp-request@naggum.no' to be included in the -# ILISP mailing list. - -# Note: this makefile assumes GNU make - -# Updated for XEmacs autoloads builds, but unused at present since no -# autoloads are generated, and this package hasn't been customized. - -#============================================================================== -# Various Variables - -Version = 5.8 - -# Use whichever you like most -#EMACS = xemacs -#EMACS = /usr/local/bin/emacs -EMACS = emacs - -# The SHELL variable is used only for making the distribution. -#SHELL = /bin/csh -# Tsk, tsk, Though shalt not use csh in distributed scripts. -SHELL = /bin/sh - -# These are used mostly for packaging the distribution -Ilisp_src_dir = $(shell pwd) -Ilisp_tar_dir = ilisp-$(Version) - -OtherFiles = README \ - HISTORY \ - Makefile \ - ilisp.emacs \ - INSTALLATION \ - COPYING \ - GETTING-ILISP \ - Welcome - -DocFiles = ilisp.texi - -LoadFiles = ilisp-def.elc ilisp-el.elc ilisp-sym.elc \ - ilisp-inp.elc ilisp-ind.elc ilisp-prc.elc ilisp-val.elc ilisp-out.elc \ - ilisp-mov.elc ilisp-key.elc ilisp-prn.elc ilisp-low.elc ilisp-doc.elc \ - ilisp-ext.elc ilisp-mod.elc ilisp-dia.elc ilisp-cmt.elc ilisp-rng.elc \ - ilisp-hnd.elc ilisp-utl.elc ilisp-cmp.elc ilisp-kil.elc ilisp-snd.elc \ - ilisp-xfr.elc ilisp-hi.elc ilisp-aut.elc ilisp-cl.elc ilisp-cmu.elc \ - ilisp-acl.elc ilisp-kcl.elc ilisp-luc.elc ilisp-sch.elc ilisp-hlw.elc \ - ilisp-xls.elc - - -#============================================================================== -# Rules - -compile: - $(EMACS) -batch -l ilisp-mak.el - -elc: $(LoadFiles) $(XEmacsELC) - -$(LoadFiles) : - $(EMACS) -batch -l ilisp-mak.el - -tags: - etags *.el - -clean: - $(RM) *.elc - -loadfile: - touch ilisp-all.elc - cat $(LoadFiles) > ilisp-all.elc - rm $(LoadFiles) -# Note that the redirection is done by a Bourne Shell. - -compress: - gzip *.el $(OtherFiles) $(DocFiles) - -#============================================================================== -# The following targets are used only to create a distribution file. - -dist: tarring dist_compressing - -tarring: - (cd $(Ilisp_src_dir)/..; \ - if ( $(notdir $(Ilisp_src_dir)) != $(Ilisp_tar_dir) ) \ - ln -s $(notdir $(Ilisp_src_dir)) $(Ilisp_tar_dir) ; \ - tar cvf $(Ilisp_tar_dir).tar \ - $(patsubst %,$(Ilisp_tar_dir)/%,$(OtherFiles)) \ - $(Ilisp_tar_dir)/*.el \ - $(Ilisp_tar_dir)/*.lisp \ - $(patsubst %,$(Ilisp_tar_dir)/%,$(DocFiles)) \ - $(Ilisp_tar_dir)/*.mail) - -dist_compressing: - (cd $(Ilisp_src_dir)/.. ; gzip $(Ilisp_tar_dir).tar) - -uuencoding: ../$(Ilisp_tar_dir).tar.gz - (cd $(Ilisp_src_dir)/.. ; \ - uuencode $(Ilisp_tar_dir).tar.gz $(Ilisp_tar_dir).tar.gz > il.uue) - -#autoloads: auto-autoloads.el - -#custom-load.elc: custom-load.el -# $(EMACS) -batch -q -no-site-file -f batch-byte-compile $? - -#auto-autoloads.el: $(LoadFiles:.elc=.el) -# $(EMACS) -batch -q -no-site-file \ -# -eval '(setq autoload-target-directory "'`pwd`'/")' \ -# -l autoload \ -# -f batch-update-autoloads $? - -# end of file -- Makefile --
--- a/lisp/ilisp/README Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,25 +0,0 @@ -ILISP is a powerful GNU Emacs interface to many dialects of Lisp, -including Lucid, Allegro, Harlequin LispWorks, GCL, KCL, AKCL, ECL, IBCL, -and CMUCL. - -Written by Chris McConnell <ccm+@cs.cmu.edu> and now maintained by -Marco Antoniotti <marcoxa@icsi.berkeley.edu> and -Rick Campbell <campbell@c2.net>. - -Please refer to the following files in this directory: - HISTORY: A detailed summary of changes over the course of ILISP's - existence. - GETTING-ILISP: Directions for obtaining this collection using - anonymous FTP. - INSTALLATION: Directions about how to install ILISP and specific - dialect needs. - -Please send bug reports, questions, suggestions, etc. to: - ILISP Discussion <ilisp@naggum.no> - -Please address all list administration messages, such as requests to -subscribe or unsubscribe from ilisp@naggum.no, to: - ILISP Administrivia <ilisp-request@naggum.no> - -See http://www.c2.net/~campbell/ilisp/ or -http://www.cs.cmu.edu/~campbell/ilisp/ for more information.
--- a/lisp/ilisp/Welcome Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,39 +0,0 @@ -Welcome to the ILISP Discussion mailing list. - -ILISP is a GNU Emacs package for controlling an inferior process -running a lisp dialect. You can get ILISP by anonymous ftp at -FTP.CS.CMU.EDU in the directory /afs/cs/user/campbell/http/ilisp/. -Also you can find ILISP by getting to the AI.Repository via the WWW. - -http://www.cs.cmu.edu/Web/Groups/AI/html/repository.html - -From there follow: LISP, UTIL, EMACS and finally ILISP - -Other archive sites include: - ftp://ftp.icsi.berkeley.edu/pub/software/elisp/ - http://www.c2.net/~campbell/ilisp/ - http://www.cs.cmu.edu/~campbell/ilisp/ - -ILISP is currently being maintained by Marco Antoniotti -<marcoxa@icsi.berkeley.edu> and Rick Campbell <campbell@c2.net>. -The mailing list is maintained by Erik Naggum <erik@naggum.no>. - -Please address all list administration messages, such as requests to -subscribe or unsubscribe, to: - - ILISP Administrivia <ilisp-request@naggum.no> - -Please allow a little time; -there's no list server programming running, the list is maintained by -hand. - -To send a message to everyone on the list, address it to: - - ILISP Discussion <ilisp@naggum.no> - -The list has had a very low volume lately, so you may not see messages -for a while after subscribing. - -Please note that there is no "bug" list like ilisp-bugs@naggum.no. -The primary list serves the purpose of a general bug fix and -discussion area.
--- a/lisp/ilisp/allegro.lisp Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,87 +0,0 @@ -;;; -*- Mode: Lisp -*- - -;;; allegro.lisp -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - -;;; -;;; Allegro initializations -;;; Author: Chris McConnell, ccm@cs.cmu.edu -;;; -(in-package "ILISP") - -;;; -(defun ilisp-callers (symbol package) - "Print a list of all of the functions that call FUNCTION and return -T if successful." - (ilisp-errors - (let ((function (ilisp-find-symbol symbol package)) - (callers nil) - (*print-level* nil) - (*print-length* nil) - (*package* (find-package 'lisp))) - (when (and function (fboundp function)) - (labels ((in-expression (function expression) - (cond ((null expression) nil) - ((listp expression) - (let ((header (first expression))) - (if (or (eq header function) - (and (eq header 'function) - (eq (second expression) function))) - t - (dolist (subexp expression) - (when (in-expression function subexp) - (return t))))))))) - (excl::who-references - function - #'(lambda (function) - (push (excl::fn_symdef function) callers))) - (do-all-symbols (symbol) - (when (and (fboundp symbol) - (not (compiled-function-p (symbol-function symbol))) - (in-expression function (symbol-function symbol))) - (push symbol callers))) - (dolist (caller callers) - (print caller)) - t))))) - -;;; -(defun ilisp-source-files (symbol package type) - "Print each file for PACKAGE:SYMBOL's TYPE definition on a line and -return T if successful." - (ilisp-errors - (let* ((symbol (ilisp-find-symbol symbol package)) - (type (if (equal type "any") t (ilisp-find-symbol type "keyword"))) - (paths (when symbol (excl:source-file symbol type)))) - (if paths - (progn - (if (eq type t) - (dolist (path (remove-duplicates paths - :key #'cdr :test #'equal)) - (print (namestring (cdr path)))) - (print (namestring paths))) - t) - nil)))) - -;;; -(dolist (symbol '(ilisp-callers ilisp-source-files)) - (export symbol)) -(unless (compiled-function-p #'ilisp-callers) - (format t "\"ILISP: File is not compiled, use M-x ilisp-compile-inits\"")) -
--- a/lisp/ilisp/bridge.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,438 +0,0 @@ -;;; -*-Emacs-Lisp-*- -;;;%Header -;;; Bridge process filter, V1.0 -;;; Copyright (C) 1991 Chris McConnell, ccm@cs.cmu.edu -;;; -;;; Send mail to ilisp@naggum.no if you have problems. -;;; -;;; Send mail to ilisp-request@naggum.no if you want to be on the -;;; ilisp mailing list. - -;;; This file is part of GNU Emacs. - -;;; GNU Emacs is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY. No author or distributor -;;; accepts responsibility to anyone for the consequences of using it -;;; or for whether it serves any particular purpose or works at all, -;;; unless he says so in writing. Refer to the GNU Emacs General Public -;;; License for full details. - -;;; Everyone is granted permission to copy, modify and redistribute -;;; GNU Emacs, but only under the conditions described in the -;;; GNU Emacs General Public License. A copy of this license is -;;; supposed to have been given to you along with GNU Emacs so you -;;; can know your rights and responsibilities. It should be in a -;;; file named COPYING. Among other things, the copyright notice -;;; and this notice must be preserved on all copies. - -;;; Send any bugs or comments. Thanks to Todd Kaufmann for rewriting -;;; the process filter for continuous handlers. - -;;; USAGE: M-x install-bridge will add a process output filter to the -;;; current buffer. Any output that the process does between -;;; bridge-start-regexp and bridge-end-regexp will be bundled up and -;;; passed to the first handler on bridge-handlers that matches the -;;; output using string-match. If bridge-prompt-regexp shows up -;;; before bridge-end-regexp, the bridge will be cancelled. If no -;;; handler matches the output, the first symbol in the output is -;;; assumed to be a buffer name and the rest of the output will be -;;; sent to that buffer's process. This can be used to communicate -;;; between processes or to set up two way interactions between Emacs -;;; and an inferior process. - -;;; You can write handlers that process the output in special ways. -;;; See bridge-send-handler for the default handler. The command -;;; hand-bridge is useful for testing. Keep in mind that all -;;; variables are buffer local. - -;;; YOUR .EMACS FILE: -;;; -;;; ;;; Set up load path to include bridge -;;; (setq load-path (cons "/bridge-directory/" load-path)) -;;; (autoload 'install-bridge "bridge" "Install a process bridge." t) -;;; (setq bridge-hook -;;; '(lambda () -;;; ;; Example options -;;; (setq bridge-source-insert nil) ;Don't insert in source buffer -;;; (setq bridge-destination-insert nil) ;Don't insert in dest buffer -;;; ;; Handle copy-it messages yourself -;;; (setq bridge-handlers -;;; '(("copy-it" . my-copy-handler))))) - -;;; EXAMPLE: -;;; # This pipes stdin to the named buffer in a Unix shell -;;; alias devgnu '(echo -n "\!* "; cat -; echo -n " ")' -;;; -;;; ls | devgnu *scratch* - -;;;%Parameters -(defvar bridge-hook nil - "Hook called when a bridge is installed by install-hook.") - -(defvar bridge-start-regexp "" - "*Regular expression to match the start of a process bridge in -process output. It should be followed by a buffer name, the data to -be sent and a bridge-end-regexp.") - -(defvar bridge-end-regexp " " - "*Regular expression to match the end of a process bridge in process -output.") - -(defvar bridge-prompt-regexp nil - "*Regular expression for detecting a prompt. If there is a -comint-prompt-regexp, it will be initialized to that. A prompt before -a bridge-end-regexp will stop the process bridge.") - -(defvar bridge-handlers nil - "Alist of (regexp . handler) for handling process output delimited -by bridge-start-regexp and bridge-end-regexp. The first entry on the -list whose regexp matches the output will be called on the process and -the delimited output.") - -(defvar bridge-source-insert t - "*T to insert bridge input in the source buffer minus delimiters.") - -(defvar bridge-destination-insert t - "*T for bridge-send-handler to insert bridge input into the -destination buffer minus delimiters.") - -(defvar bridge-chunk-size 512 - "*Long inputs send to comint processes are broken up into chunks of -this size. If your process is choking on big inputs, try lowering the -value.") - -;;;%Internal variables -(defvar bridge-old-filter nil - "Old filter for a bridged process buffer.") - -(defvar bridge-string nil - "The current output in the process bridge.") - -(defvar bridge-in-progress nil - "The current handler function, if any, that bridge passes strings on to, -or nil if none.") - -(defvar bridge-send-to-buffer nil - "The buffer that the default bridge-handler (bridge-send-handler) is -currently sending to, or nil if it hasn't started yet. Your handler -function can use this variable also.") - -(defvar bridge-last-failure () - "Last thing that broke the bridge handler. First item is function call -(eval'able); last item is error condition which resulted. This is provided -to help handler-writers in their debugging.") - -;;;%Utilities -(defun bridge-insert (output) - "Insert process OUTPUT into the current buffer." - (if output - (let* ((buffer (current-buffer)) - (process (get-buffer-process buffer)) - (mark (process-mark process)) - (window (selected-window)) - (at-end nil)) - (if (eq (window-buffer window) buffer) - (setq at-end (= (point) mark)) - (setq window (get-buffer-window buffer))) - (save-excursion - (goto-char mark) - (insert output) - (set-marker mark (point))) - (if window - (progn - (if at-end (goto-char mark)) - (if (not (pos-visible-in-window-p (point) window)) - (let ((original (selected-window))) - (save-excursion - (select-window window) - (recenter '(center)) - (select-window original))))))))) - -;;; -;(defun bridge-send-string (process string) -; "Send PROCESS the contents of STRING as input. -;This is equivalent to process-send-string, except that long input strings -;are broken up into chunks of size comint-input-chunk-size. Processes -;are given a chance to output between chunks. This can help prevent processes -;from hanging when you send them long inputs on some OS's." -; (let* ((len (length string)) -; (i (min len bridge-chunk-size))) -; (process-send-string process (substring string 0 i)) -; (while (< i len) -; (let ((next-i (+ i bridge-chunk-size))) -; (accept-process-output) -; (process-send-string process (substring string i (min len next-i))) -; (setq i next-i))))) - -;;; -(defun bridge-call-handler (handler proc string) - "Funcall HANDLER on PROC, STRING carefully. Error is caught if happens, -and user is signaled. State is put in bridge-last-failure. Returns t if -handler executed without error." - (let ((inhibit-quit nil) - (failed nil)) - (condition-case err - (funcall handler proc string) - (error - (ding) - (setq failed t) - (message "bridge-handler \"%s\" failed %s (see bridge-last-failure)" - handler err) - (setq bridge-last-failure - (` ((funcall '(, handler) '(, proc) (, string)) - "Caused: " - (, err)))))) - (not failed))) - -;;;%Handlers -(defun bridge-send-handler (process input) - "Send PROCESS INPUT to the buffer name found at the start of the -input. The input after the buffer name is sent to the buffer's -process if it has one. If bridge-destination-insert is T, the input -will be inserted into the buffer. If it does not have a process, it -will be inserted at the end of the buffer." - (if (null input) - (setq bridge-send-to-buffer nil) ; end of bridge - (let (buffer-and-start buffer-name dest to) - ;; if this is first time, get the buffer out of the first line - (cond ((not bridge-send-to-buffer) - (setq buffer-and-start (read-from-string input) - buffer-name (format "%s" (car (read-from-string input))) - dest (get-buffer buffer-name) - to (get-buffer-process dest) - input (substring input (cdr buffer-and-start))) - (setq bridge-send-to-buffer dest)) - (t - (setq buffer-name bridge-send-to-buffer - dest (get-buffer buffer-name) - to (get-buffer-process dest) - ))) - (if dest - (let ((buffer (current-buffer))) - (if bridge-destination-insert - (unwind-protect - (progn - (set-buffer dest) - (if to - (bridge-insert input) - (goto-char (point-max)) - (insert input))) - (set-buffer buffer))) - (if to - ;; (bridge-send-string to input) - (process-send-string to input) - )) - (error "%s is not a buffer" buffer-name))))) - -;;;%Filter -(defun bridge-filter (process output) - "Given PROCESS and some OUTPUT, check for the presence of -bridge-start-regexp. Everything prior to this will be passed to the -normal filter function or inserted in the buffer if it is nil. The -output up to bridge-end-regexp will be sent to the first handler on -bridge-handlers that matches the string. If no handlers match, the -input will be sent to bridge-send-handler. If bridge-prompt-regexp is -encountered before the bridge-end-regexp, the bridge will be cancelled." - (let ((inhibit-quit t) - (match-data (match-data)) - (buffer (current-buffer)) - (process-buffer (process-buffer process)) - (case-fold-search t) - (start 0) (end 0) - function - b-start b-start-end b-end) - (set-buffer process-buffer) ;; access locals - (setq function bridge-in-progress) - - ;; How it works: - ;; - ;; start, end delimit the part of string we are interested in; - ;; initially both 0; after an iteration we move them to next string. - - ;; b-start, b-end delimit part of string to bridge (possibly whole string); - ;; this will be string between corresponding regexps. - - ;; There are two main cases when we come into loop: - - ;; bridge in progress - ;;0 setq b-start = start - ;;1 setq b-end (or end-pattern end) - ;;4 process string - ;;5 remove handler if end found - - ;; no bridge in progress - ;;0 setq b-start if see start-pattern - ;;1 setq b-end if bstart to (or end-pattern end) - ;;2 send (substring start b-start) to normal place - ;;3 find handler (in b-start, b-end) if not set - ;;4 process string - ;;5 remove handler if end found - - ;; equivalent sections have the same numbers here; - ;; we fold them together in this code. - - (unwind-protect - (while (< end (length output)) - - ;;0 setq b-start if find - (setq b-start - (cond (bridge-in-progress - (setq b-start-end start) - start) - ((string-match bridge-start-regexp output start) - (setq b-start-end (match-end 0)) - (match-beginning 0)) - (t nil))) - ;;1 setq b-end - (setq b-end - (if b-start - (let ((end-seen (string-match bridge-end-regexp - output b-start-end))) - (if end-seen (setq end (match-end 0))) - end-seen))) - (if (not b-end) (setq end (length output) - b-end (length output))) - - ;;1.5 - if see prompt before end, remove current - (if b-start - (let ((prompt (string-match bridge-prompt-regexp - output b-start-end))) - (if (and prompt (<= (match-end 0) b-end)) - (setq b-start nil ; b-start-end start - b-end start - end (match-end 0) - bridge-in-progress nil - )))) - - ;;2 send (substring start b-start) to old filter, if any - (if (/= start (or b-start end)) ; don't bother on empty string - (let ((pass-on (substring output start (or b-start end)))) - (if bridge-old-filter - (let ((old bridge-old-filter)) - (store-match-data match-data) - (funcall old process pass-on) - ;; if filter changed, re-install ourselves - (let ((new (process-filter process))) - (if (not (eq new 'bridge-filter)) - (progn (setq bridge-old-filter new) - (set-process-filter process 'bridge-filter))))) - (set-buffer process-buffer) - (bridge-insert pass-on)))) - - ;;3 find handler (in b-start, b-end) if none current - (if (and b-start (not bridge-in-progress)) - (let ((handlers bridge-handlers)) - (while (and handlers (not function)) - (let* ((handler (car handlers)) - (m (string-match (car handler) output b-start-end))) - (if (and m (< m b-end)) - (setq function (cdr handler)) - (setq handlers (cdr handlers))))) - ;; Set default handler if none - (if (null function) - (setq function 'bridge-send-handler)) - (setq bridge-in-progress function))) - ;;4 process string - (if function - (let ((ok t)) - (if (/= b-start-end b-end) - (let ((send (substring output b-start-end b-end))) - ;; also, insert the stuff in buffer between - ;; iff bridge-source-insert. - (if bridge-source-insert (bridge-insert send)) - ;; call handler on string - (setq ok (bridge-call-handler function process send)))) - ;;5 remove handler if end found - ;; if function removed then tell it that's all - (if (or (not ok) (/= b-end end));; saw end before end-of-string - (progn - (bridge-call-handler function process nil) - ;; have to remove function too for next time around - (setq function nil - bridge-in-progress nil) - )) - )) - - ;; continue looping, in case there's more string - (setq start end) - )) - ;; protected forms: restore buffer, match-data - (set-buffer buffer) - (store-match-data match-data) - )) - -;;;%Interface -(defun install-bridge () - "Set up a process bridge in the current buffer." - (interactive) - (if (not (get-buffer-process (current-buffer))) - (error "%s does not have a process" (buffer-name (current-buffer))) - (make-local-variable 'bridge-start-regexp) - (make-local-variable 'bridge-end-regexp) - (make-local-variable 'bridge-prompt-regexp) - (make-local-variable 'bridge-handlers) - (make-local-variable 'bridge-source-insert) - (make-local-variable 'bridge-destination-insert) - (make-local-variable 'bridge-chunk-size) - (make-local-variable 'bridge-old-filter) - (make-local-variable 'bridge-string) - (make-local-variable 'bridge-in-progress) - (make-local-variable 'bridge-send-to-buffer) - (setq bridge-string nil bridge-in-progress nil - bridge-send-to-buffer nil) - (if (boundp 'comint-prompt-regexp) - (setq bridge-prompt-regexp comint-prompt-regexp)) - (let ((process (get-buffer-process (current-buffer)))) - (if process - (if (not (eq (process-filter process) 'bridge-filter)) - (progn - (setq bridge-old-filter (process-filter process)) - (set-process-filter process 'bridge-filter))) - (error "%s does not have a process" - (buffer-name (current-buffer))))) - (run-hooks 'bridge-hook) - (message "Process bridge is installed"))) - -;;; -(defun reset-bridge () - "Must be called from the process's buffer. Removes any active bridge." - (interactive) - ;; for when things get wedged - (if bridge-in-progress - (unwind-protect - (funcall bridge-in-progress (get-buffer-process - (current-buffer)) - nil) - (setq bridge-in-progress nil)) - (message "No bridge in progress."))) - -;;; -(defun remove-bridge () - "Remove bridge from the current buffer." - (interactive) - (let ((process (get-buffer-process (current-buffer)))) - (if (or (not process) (not (eq (process-filter process) 'bridge-filter))) - (error "%s has no bridge" (buffer-name (current-buffer))) - ;; remove any bridge-in-progress - (reset-bridge) - (set-process-filter process bridge-old-filter) - (funcall bridge-old-filter process bridge-string) - (message "Process bridge is removed.")))) - -;;;% Utility for testing -(defun hand-bridge (start end) - "With point at bridge-start, sends bridge-start + string + -bridge-end to bridge-filter. With prefix, use current region to send." - (interactive "r") - (let ((p0 (if current-prefix-arg (min start end) - (if (looking-at bridge-start-regexp) (point) - (error "Not looking at bridge-start-regexp")))) - (p1 (if current-prefix-arg (max start end) - (if (re-search-forward bridge-end-regexp nil t) - (point) (error "Didn't see bridge-end-regexp"))))) - - (bridge-filter (get-buffer-process (current-buffer)) - (buffer-substring p0 p1)) - )) - -(provide 'bridge)
--- a/lisp/ilisp/cl-ilisp.lisp Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,617 +0,0 @@ -;;; -*- Mode: Lisp -*- - -;;; cl-ilisp.lisp -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - - -;;; Common Lisp initializations -;;; Author: Chris McConnell, ccm@cs.cmu.edu - -;;; -;;; ange-ftp hack added by ivan Wed Mar 10 12:30:15 1993 -;;; ilisp-errors *gc-verbose* addition ivan Tue Mar 16 03:21:51 1993 -;;; -;;; Rcs_Info: clisp.lisp,v 1.26 1993/09/03 02:05:07 ivan Rel $ -;;; -;;; Revision 1.19 1993/08/24 22:01:52 ivan -;;; Use defpackage instead of just IN-PACKAGE. -;;; Renamed FUNCTION to FUN in ilisp-arglist to get around CMUCL 17b bug. -;;; -;;; Revision 1.16 1993/06/29 05:51:35 ivan -;;; Added Ed Gamble's #'readtable-case fix and Hans Chalupsky's -;;; allegro-4.1 addition. -;;; -;;; Revision 1.8 1993/06/28 00:57:42 ivan -;;; Stopped using 'COMPILED-FUNCTION-P for compiled check. -;;; -;;; Revision 1.3 1993/03/16 23:22:10 ivan -;;; Added breakp arg to ilisp-trace. -;;; -;;; - - -#+(or allegro-v4.0 allegro-v4.1) -(eval-when (compile load eval) - (setq excl:*cltl1-in-package-compatibility-p* t)) - - -(in-package "ILISP") - -;;; -;;; GCL 2.2 doesn't have defpackage (yet) so we need to put the export -;;; here. (toy@rtp.ericsson.se) -;;; -;;; Please note that while the comment and the fix posted by Richard -;;; Toy are correct, they are deprecated by at least one of the ILISP -;;; maintainers. :) By removing the 'nil' in the following #+, you -;;; will fix the problem but will not do a good service to the CL -;;; community. The right thing to do is to install DEFPACKAGE in your -;;; GCL and to write the GCL maintainers and to ask them to -;;; incorporate DEFPACKAGE in their standard builds. -;;; Marco Antoniotti <marcoxa@icsi.berkeley.edu> 19960715 -;;; - -#+(and nil gcl) -(export '(ilisp-errors - ilisp-save - ilisp-restore - ilisp-symbol-name - ilisp-find-symbol - ilisp-find-package - ilisp-eval - ilisp-compile - ilisp-describe - ilisp-inspect - ilisp-arglist - ilisp-documentation - ilisp-macroexpand - ilisp-macroexpand-1 - ilisp-trace - ilisp-untrace - ilisp-compile-file - ilisp-casify - ilisp-matching-symbols)) - - -;;; -(defvar *ilisp-old-result* nil "Used for save/restore of top level values.") - -#+:ANSI-CL -(defun special-form-p (symbol) - "Backward compatibility for non ANSI CL's." - (special-operator-p symbol)) - -;;; -(defmacro ilisp-handler-case (expression &rest handlers) - "Evaluate EXPRESSION using HANDLERS to handle errors." - handlers - (if (macro-function 'handler-case) - `(handler-case ,expression ,@handlers) - #+allegro `(excl::handler-case ,expression ,@handlers) - #+lucid `(lucid::handler-case ,expression ,@handlers) - #-(or allegro lucid) expression)) - -;;; -(defun ilisp-readtable-case (readtable) - (if (fboundp 'readtable-case) - (funcall #'readtable-case readtable) - #+allegro (case excl:*current-case-mode* - (:case-insensitive-upper :upcase) - (:case-insensitive-lower :downcase) - (otherwise :preserve)) - #-allegro :upcase)) - -;;; -(defmacro ilisp-errors (form) - "Handle errors when evaluating FORM." - `(let ((*standard-output* *terminal-io*) - (*error-output* *terminal-io*) - #+cmu - (ext:*gc-verbose* nil) ; cmulisp outputs "[GC ...]" which - ; doesn't read well... - #+ecl - (sys:*gc-verbose* nil) ; ecolisp also outputs "[GC ...]" - ) - (princ " ") ;Make sure we have output - (ilisp-handler-case - ,form - (error (error) - (with-output-to-string (string) - (format string "ILISP: ~A" error)))))) - - -;;; -(defun ilisp-save () - "Save the current state of the result history." - (declare (special / // /// + ++ +++)) - (unless *ilisp-old-result* - (setq *ilisp-old-result* (list /// // +++ ++ + /)))) - -;;; -(defun ilisp-restore () - "Restore the old result history." - (declare (special / // /// + ++ +++ * ** -)) - (setq // (pop *ilisp-old-result*) - ** (first //) - / (pop *ilisp-old-result*) - * (first /) - ++ (pop *ilisp-old-result*) - + (pop *ilisp-old-result*) - - (pop *ilisp-old-result*)) - (values-list (pop *ilisp-old-result*))) - -;;; ilisp-symbol-name -- -;;; -;;; ':capitalize' case added under suggestion by Rich Mallory. -(defun ilisp-symbol-name (symbol-name) - "Return SYMBOL-NAME with the appropriate case as a symbol." - (case (ilisp-readtable-case *readtable*) - (:upcase (string-upcase symbol-name)) - (:downcase (string-downcase symbol-name)) - (:capitalize (string-capitalize symbol-name)) - (:preserve symbol-name))) - -;;; -(defun ilisp-find-package (package-name) - "Return package PACKAGE-NAME or the current package." - (if (string-equal package-name "nil") - *package* - (or (find-package (ilisp-symbol-name package-name)) - (error "Package ~A not found" package-name)))) - -;;; -(defun ilisp-find-symbol (symbol-name package-name) - "Return the symbol associated with SYMBOL-NAME in PACKAGE-NAME trying to -handle case issues intelligently." - (find-symbol (ilisp-symbol-name symbol-name) - (ilisp-find-package package-name))) - - -;;; The following two functions were in version 5.5. -;;; They disappeared in version 5.6. I am putting them back in the -;;; distribution in order to make use of them later if the need -;;; arises. -;;; Marco Antoniotti: Jan 2 1995 -#| -(defun ilisp-filename-hack (filename) - "Strip `/user@machine:' prefix from filename." - ;; Ivan's hack for getting away with dumb /ivan@bu-conx:/foo/bar/baz - ;; filenames... - (let ((at-location (position #\@ filename)) - (colon-location (position #\: filename))) - (if (and at-location colon-location) - (subseq filename (1+ colon-location)) - filename))) - - -(defun ilisp-read-form (form package) - "Read string FORM in PACKAGE and return the resulting form." - (let ((*package* (ilisp-find-package package))) - (read-from-string form))) -|# - -;;; -(defun ilisp-eval (form package filename) - "Evaluate FORM in PACKAGE recording FILENAME as the source file." - (princ " ") - ;; Ivan's hack for getting away with dumb /ivan@bu-conx:/foo/bar/baz - ;; filenames... - (let* ((at-location (position #\@ filename)) - (colon-location (position #\: filename)) - (filename - (if (and at-location colon-location) - (subseq filename (1+ colon-location)) - filename)) - (*package* (ilisp-find-package package)) - #+allegro (excl::*source-pathname* filename) - #+allegro (excl::*redefinition-warnings* nil) - #+lucid (lucid::*source-pathname* - (if (probe-file filename) - (truename filename) - (merge-pathnames filename))) - #+lucid (lucid::*redefinition-action* nil) - #+lispworks (compiler::*input-pathname* (merge-pathnames filename)) - #+lispworks (compiler::*warn-on-non-top-level-defun* nil) - ;; The LW entries are a mix of Rich Mallory and Jason - ;; Trenouth suggestions - ;; Marco Antoniotti: Jan 2 1995. - ) - filename - (eval (read-from-string form)))) - -;;; -(defun ilisp-compile (form package filename) - "Compile FORM in PACKAGE recording FILENAME as the source file." - (princ " ") - ;; This makes sure that function forms are compiled - ;; NOTE: Rich Mallory proposed a variation of the next piece of - ;; code. for the time being we stick to the following simpler code. - ;; Marco Antoniotti: Jan 2 1995. - #-lucid - (ilisp-eval - (format nil "(funcall (compile nil '(lisp:lambda () ~A)))" - form) - package - filename) - - ;; The following piece of conditional code is left in the - ;; distribution just for historical purposes. - ;; It will disappear in the next release. - ;; Marco Antoniotti: Jan 2 1995. - #+lucid-ilisp-5.6 - (labels ((compiler (form env) - (if (and (consp form) - (eq (first form) 'function) - (consp (second form))) - #-LCL3.0 - (evalhook `(compile nil ,form) nil nil env) - #+LCL3.0 - ;; If we have just compiled a named-lambda, and the - ;; name didn't make it in to the procedure object, - ;; then stuff the appropriate symbol in to the - ;; procedure object. - (let* ((proc (evalhook `(compile nil ,form) - nil nil env)) - (old-name (and proc (sys:procedure-ref proc 1))) - (lambda (second form)) - (name (and (eq (first lambda) - 'lucid::named-lambda) - (second lambda)))) - (when (or (null old-name) - (and (listp old-name) - (eq :internal (car old-name)))) - (setf (sys:procedure-ref proc 1) name)) - proc) - (evalhook form #'compiler nil env)))) - (let ((*evalhook* #'compiler)) - (ilisp-eval form package filename))) - #+lucid - ;; Following form is a patch provided by Christopher Hoover - ;; <ch@lks.csi.com> - (let ((*package* (ilisp-find-package package)) - (lcl:*source-pathname* (if (probe-file filename) - (truename filename) - (merge-pathnames filename))) - (lcl:*redefinition-action* nil)) - (with-input-from-string (s form) - (lucid::compile-in-core-from-stream s) - (values))) - ) - -;;; -(defun ilisp-describe (sexp package) - "Describe SEXP in PACKAGE." - (ilisp-errors - (let ((*package* (ilisp-find-package package))) - (describe (eval (read-from-string sexp)))))) - -;;; -(defun ilisp-inspect (sexp package) - "Inspect SEXP in PACKAGE." - (ilisp-errors - (let ((*package* (ilisp-find-package package))) - (inspect (eval (read-from-string sexp)))))) - -;;; -(defun ilisp-arglist (symbol package) - (ilisp-errors - (let ((fn (ilisp-find-symbol symbol package)) - (*print-length* nil) - (*print-pretty* t) - (*package* (ilisp-find-package package))) - (cond ((null fn) - (format t "Symbol ~s not present in ~s." symbol package)) - ((not (fboundp fn)) - (format t "~s: undefined~%" fn)) - (t - (print-function-arglist fn))))) - (values)) - - -(defun print-function-arglist (fn) - "Pretty arglist printer" - (let* ((a (get-function-arglist fn)) - (arglist (ldiff a (member '&aux a))) - (desc (ilisp-function-short-description fn))) - (format t "~&~s~a" fn (or desc "")) - (write-string ": ") - (if arglist - (write arglist :case :downcase :escape nil) - (write-string "()")) - (terpri))) - - - -(defun ilisp-generic-function-p (symbol) - (let ((generic-p - (find-symbol "GENERIC-FUNCTION-P" - (or (find-package "PCL") - *package*)))) - (and generic-p - (fboundp generic-p) - (funcall generic-p symbol)))) - - - -(defun ilisp-function-short-description (symbol) - (cond ((macro-function symbol) - " (Macro)") - ((special-form-p symbol) - " (Special Form)") - ((ilisp-generic-function-p symbol) - " (Generic)"))) - - - -(defun get-function-arglist (symbol) - (let ((fun (symbol-function symbol))) - (cond ((ilisp-generic-function-p symbol) - (funcall - (find-symbol "GENERIC-FUNCTION-PRETTY-ARGLIST" - (or (find-package "PCL") *package*)) - fun)) - (t - #+allegro - (excl::arglist symbol) - - #+(or ibcl kcl ecl gcl) - (help symbol) - - #+lucid - (lucid::arglist symbol) - - #+lispworks - (system::function-lambda-list symbol) - - #-(or allegro lucid kcl ibcl ecl) - (documentation symbol 'function))))) - -;;; -(defun ilisp-documentation (symbol package type) - "Return the TYPE documentation for SYMBOL in PACKAGE. If TYPE is -\(qualifiers* (class ...)), the appropriate method will be found." - (ilisp-errors - (let* ((real-symbol (ilisp-find-symbol symbol package)) - (type (if (and (not (zerop (length type))) - (eq (elt type 0) #\()) - (let ((*package* (ilisp-find-package package))) - (read-from-string type)) - (ilisp-find-symbol type package)))) - (when (listp type) - (setq real-symbol - (funcall - (find-symbol "FIND-METHOD" (or (find-package "CLOS") - (find-package "PCL") - *package*)) - (symbol-function real-symbol) - (reverse - (let ((quals nil)) - (dolist (entry type quals) - (if (listp entry) - (return quals) - (setq quals (cons entry quals)))))) - (reverse - (let ((types nil)) - (dolist (class (first (last type)) types) - (setq types - (cons (funcall - (find-symbol "FIND-CLASS" - (or (find-package "CLOS") - (find-package "PCL") - *package*)) - class) types)))))))) - (if real-symbol - (if (symbolp real-symbol) - (documentation real-symbol type) - ;; Prevent compiler complaints - (eval `(documentation ,real-symbol))) - (format nil "~A has no ~A documentation" symbol type))))) - -;;; -(defun ilisp-macroexpand (expression package) - "Macroexpand EXPRESSION as long as the top level function is still a -macro." - (ilisp-errors - (let ((*print-length* nil) - (*print-level* nil) - (*package* (ilisp-find-package package))) - (pprint (#-allegro macroexpand #+allegro excl::walk - (read-from-string expression)))))) - -;;; -(defun ilisp-macroexpand-1 (expression package) - "Macroexpand EXPRESSION once." - (ilisp-errors - (let ((*print-length* nil) - (*print-level* nil) - (*package* (ilisp-find-package package))) - (pprint (macroexpand-1 (read-from-string expression)))))) - -;;; -#-lispworks -(defun ilisp-trace (symbol package breakp) - "Trace SYMBOL in PACKAGE." - (declare (ignore breakp)) ; No way to do this in CL. - (ilisp-errors - (let ((real-symbol (ilisp-find-symbol symbol package))) - (when real-symbol (eval `(trace ,real-symbol)))))) - -;;; Jason Trenouth: SEP 6 94 -- LispWorks can trace-break -#+lispworks -(defun ilisp-trace (symbol package breakp) - "Trace SYMBOL in PACKAGE." - (ilisp-errors - (let ((real-symbol (ilisp-find-symbol symbol package))) - breakp ;; idiom for (declare (ignorable breakp)) - (when real-symbol (eval `(trace (,real-symbol :break breakp))))))) - - - -(defun ilisp-untrace (symbol package) - "Untrace SYMBOL in PACKAGE." - (ilisp-errors - (let ((real-symbol (ilisp-find-symbol symbol package))) - (when real-symbol (eval `(untrace ,real-symbol)))))) - -;;; -(defun ilisp-compile-file (file extension) - "Compile FILE putting the result in FILE+EXTENSION." - (ilisp-errors - (compile-file file - :output-file - (merge-pathnames (make-pathname :type extension) file)))) - -;;; -(defun ilisp-casify (pattern string lower-p upper-p) - "Return STRING with its characters converted to the case of PATTERN, -continuing with the last case beyond the end." - (cond (lower-p (string-downcase string)) - (upper-p (string-upcase string)) - (t - (let (case) - (concatenate - 'string - (map 'string - #'(lambda (p s) - (setq case (if (upper-case-p p) - #'char-upcase - #'char-downcase)) - (funcall case s)) - pattern string) - (map 'string case (subseq string (length pattern)))))))) - -;;; -(defun ilisp-words (string) - "Return STRING broken up into words. Each word is (start end -delimiter)." - (do* ((length (length string)) - (start 0) - (end t) - (words nil)) - ((null end) (nreverse words)) - (if (setq end (position-if-not #'alphanumericp string :start start)) - (setq words (cons (list end (1+ end) t) - (if (= start end) - words - (cons (list start end nil) words))) - start (1+ end)) - (setq words (cons (list start length nil) words))))) - -;;; -(defun ilisp-match-words (string pattern words) - "Match STRING to PATTERN using WORDS." - (do* ((strlen (length string)) - (words words (cdr words)) - (word (first words) (first words)) - (start1 (first word) (first word)) - (end1 (second word) (second word)) - (delimiter (third word) (third word)) - (len (- end1 start1) (and word (- end1 start1))) - (start2 0) - (end2 len)) - ((or (null word) (null start2)) start2) - (setq end2 (+ start2 len) - start2 - (if delimiter - (position (elt pattern start1) string :start start2) - (when (and (<= end2 strlen) - (string= pattern string - :start1 start1 :end1 end1 - :start2 start2 :end2 end2)) - (1- end2)))) - (when start2 (incf start2)))) - -;;; -(defun ilisp-matching-symbols (string package &optional (function-p nil) - (external-p nil) - (prefix-p nil)) - "Return a list of the symbols that have STRING as a prefix in -PACKAGE. FUNCTION-P indicates that only symbols with a function value -should be considered. EXTERNAL-P indicates that only external symbols -should be considered. PREFIX-P means that partial matches should not -be considered. The returned strings have the same case as the -original string." - (ilisp-errors - (let* ((lower-p (notany #'upper-case-p string)) - (upper-p (notany #'lower-case-p string)) - (no-casify (eq (ilisp-readtable-case *readtable*) :preserve)) - (symbol-string (ilisp-symbol-name string)) - (length (length string)) - (results nil) - (*print-length* nil) - (*package* (ilisp-find-package package))) - (labels - ( - ;; Check SYMBOL against PATTERN - (check-symbol (symbol pattern) - (let ((name (symbol-name symbol))) - (when (and (or (not function-p) (fboundp symbol)) - (>= (length name) length) - (string= pattern name :end2 length)) - (push (list (if no-casify - name - (ilisp-casify pattern name lower-p upper-p))) - results)))) - ;; Check SYMBOL against PATTERN using WORDS - (check-symbol2 (symbol pattern words) - (let ((name (symbol-name symbol))) - (when (and (or (not function-p) (fboundp symbol)) - (ilisp-match-words name pattern words)) - (push (list (if no-casify - name - (ilisp-casify pattern name lower-p upper-p))) - results))))) - (if external-p - (do-external-symbols (symbol *package*) - (check-symbol symbol symbol-string)) - (progn - ;; KCL does not go over used symbols. - #+(or kcl ibcl ecl) - (dolist (used-package (package-use-list *package*)) - (do-external-symbols (symbol used-package) - (check-symbol symbol symbol-string))) - (do-symbols (symbol *package*) - (check-symbol symbol symbol-string)))) - (unless (or results prefix-p) - (let ((words (ilisp-words symbol-string))) - (if external-p - (do-external-symbols (symbol *package*) - (check-symbol2 symbol symbol-string words)) - (progn - ;; KCL does not go over used symbols. - #+(or kcl ibcl ecl) - (dolist (used-package (package-use-list *package*)) - (do-external-symbols (symbol used-package) - (check-symbol2 symbol symbol-string words))) - (do-symbols (symbol *package*) - (check-symbol2 symbol symbol-string words)))))) - (prin1 results) - nil)))) - - -(eval-when (load eval) - (when - #+cmu (eval:interpreted-function-p #'ilisp-matching-symbols) - #-cmu (not (compiled-function-p #'ilisp-matching-symbols)) - (format *standard-output* - "\"ILISP: File is not compiled, use M-x ilisp-compile-inits\""))) - -;;; end of file -- cl-ilisp.lisp --
--- a/lisp/ilisp/cmulisp.lisp Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,269 +0,0 @@ -;;; -*- Mode: Lisp -*- - -;;; cmulisp.lisp -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - - -;;; -;;; Todd Kaufmann May 1990 -;;; -;;; Make CMU CL run better within GNU inferior-lisp (by ccm). -;;; - - -(in-package "ILISP") - -;;;% CMU CL does not define defun as a macro -(defun ilisp-compile (form package filename) - "Compile FORM in PACKAGE recording FILENAME as the source file." - (ilisp-errors - (ilisp-eval - (format nil "(funcall (compile nil '(lambda () ~A)))" form) - package filename))) - -;;;% Stream settings, when running connected to pipes. -;;; -;;; This fixes a problem when running piped: When CMU is running as a piped -;;; process, *terminal-io* really is a terminal; ie, /dev/tty. This means an -;;; error will cause lisp to stop and wait for input from /dev/tty, which it -;;; won't be able to grab, and you'll have to restart your lisp. But we want -;;; it to use the same input that the user is typing in, ie, the pipe (stdin). -;;; This fixes that problem, which only occurs in the CMU cores of this year. -;;; - -(defvar *Fix-pipe-streams* T - "Set to Nil if you want them left alone. And tell me you don't get stuck.") - -(when (and *Fix-pipe-streams* - (lisp::synonym-stream-p *terminal-io*) - (eq (lisp::synonym-stream-symbol *terminal-io*) - 'SYSTEM::*TTY*)) - (setf *terminal-io* (make-two-way-stream system::*stdin* system::*stdout*)) - ;; *query-io* and *debug-io* are synonym streams to this, so this fixes - ;; everything. - ) - -;;;% Debugger extensions - -;;;%% Implementation of a :pop command for CMU CL debugger - -;;; -;;; Normally, errors which occur while in the debugger are just ignored, unless -;;; the user issues the "flush" command, which toggles this behavior. -;;; -(setq debug:*flush-debug-errors* nil) ;; allow multiple error levels. - -;;; This implementation of "POP" simply looks for the first restart that says -;;; "Return to debug level n" or "Return to top level." and executes it. -;;; -(debug::def-debug-command "POP" #+:new-compiler () - ;; find the first "Return to ..." restart - (if (not (boundp 'debug::*debug-restarts*)) - (error "You're not in the debugger; how can you call this!?") - (labels ((find-return-to (restart-list num) - (let ((first - (member-if - #'(lambda (restart) - (string= (funcall - (conditions::restart-report-function restart) - nil) - "Return to " :end1 10)) - restart-list))) - (cond ((zerop num) (car first)) - ((cdr first) (find-return-to (cdr first) (1- num))))))) - (let* ((level (debug::read-if-available 1)) - (first-return-to (find-return-to - debug::*debug-restarts* (1- level)))) - (if (null first-return-to) - (format *debug-io* "pop: ~d is too far" level) - (debug::invoke-restart-interactively first-return-to) - )))) - ) - - -;;;%% arglist/source-file utils. - -(defun get-correct-fn-object (sym) - "Deduce how to get the \"right\" function object and return it." - (let ((fun (or (macro-function sym) - (and (fboundp sym) (symbol-function sym))))) - (cond (fun - (when (and (= (lisp::get-type fun) #.vm:closure-header-type) - (not (eval:interpreted-function-p fun))) - (setq fun (lisp::%closure-function fun))) - fun) - (t - (error "Unknown function ~a. Check package." sym) - nil)))) - - - -(export '(arglist source-file cmulisp-trace)) - -;;;%% arglist - return arglist of function - -(defun arglist (symbol package) - (ilisp-errors - (let* ((x (ilisp-find-symbol symbol package)) - (fun (get-correct-fn-object x))) - (values - (cond ((eval:interpreted-function-p fun) - (eval:interpreted-function-arglist fun)) - ((= (lisp::get-type fun) - #.vm:funcallable-instance-header-type) - ;; generic function / method - (pcl::generic-function-pretty-arglist fun)) - ((compiled-function-p fun) - (let ((string-or-nil - (#+CMU17 lisp::%function-arglist - #-CMU17 lisp::%function-header-arglist - fun))) - (if string-or-nil - (read-from-string string-or-nil) - "No argument info."))) - (t (error "Unknown type of function"))))))) - - -;;; source-file symbol package type -- -;;; New version provided by Richard Harris <rharris@chestnut.com> with -;;; suggestions by Larry Hunter <hunter@work.nlm.nih.gov>. - -(defun source-file (symbol package type) - (declare (ignore type)) - (ilisp-errors - (let* ((x (ilisp-find-symbol symbol package)) - (fun (get-correct-fn-object x))) - (when (and fun (not (eval:interpreted-function-p fun))) - ;; The hack above is necessary because CMUCL does not - ;; correctly record source file information when 'loading' - ;; a non compiled file. - ;; In this case we fall back on the TAGS machinery. - ;; (At least as I underestand the code). - ;; Marco Antoniotti 11/22/94. - (cond (#+CMU17 (pcl::generic-function-p fun) - #-CMU17 - (= (lisp::get-type fun) - #.vm:funcallable-instance-header-type) - (dolist (method (pcl::generic-function-methods fun)) - (print-simple-source-info - (or #+CMU17 - (pcl::method-fast-function method) - (pcl::method-function method)))) - t) - (t (print-simple-source-info fun))))))) - -;;; Old version. Left here for the time being. -;(defun source-file (symbol package type) -; (declare (ignore type)) -; (ilisp-errors -; (let* ((x (ilisp-find-symbol symbol package)) -; (fun (get-correct-fn-object x))) -; (when fun -; (cond ((= (lisp::get-type fun) -; #.vm:funcallable-instance-header-type) -; ;; A PCL method! Uh boy! -; (dolist (method (pcl::generic-function-methods fun)) -; (print-simple-source-info -; (lisp::%closure-function (pcl::method-function method)))) -; t) -; (t (print-simple-source-info fun))))))) - - -;;; Patch suggested by Richard Harris <rharris@chestnut.com> - -;;; FUN-DEFINED-FROM-PATHNAME takes a symbol or function object. It -;;; returns a pathname for the file the function was defined in. If it was -;;; not defined in some file, then nil is returned. -;;; -;;; FUN-DEFINED-FROM-PATHNAME is from hemlock/rompsite.lisp (cmucl17f), -;;; with added read-time conditionalization to work in older versions -;;; of cmucl. It may need a little bit more conditionalization for -;;; some older versions of cmucl. - -(defun fun-defined-from-pathname (function) - "Returns the file where FUNCTION is defined in (if the file can be found). -Takes a symbol or function and returns the pathname for the file the -function was defined in. If it was not defined in some file, nil is -returned." - (flet ((frob (code) - (let ((info #+CMU17 (kernel:%code-debug-info code) - #-CMU17 (kernel:code-debug-info code))) - (when info - (let ((sources (c::debug-info-source info))) - (when sources - (let ((source (car sources))) - (when (eq (c::debug-source-from source) :file) - (c::debug-source-name source))))))))) - (typecase function - (symbol (fun-defined-from-pathname (fdefinition function))) - #+CMU17 - (kernel:byte-closure - (fun-defined-from-pathname - (kernel:byte-closure-function function))) - #+CMU17 - (kernel:byte-function - (frob (c::byte-function-component function))) - (function - (frob (kernel:function-code-header - (kernel:%function-self function)))) - (t nil)))) - - -;;; print-simple-source-info -- -;;; Patches suggested by Larry Hunter <hunter@work.nlm.nih.gov> and -;;; Richard Harris <rharris@chestnut.com> -;;; Nov 21, 1994. - -(defun print-simple-source-info (fun) - (let ((path (fun-defined-from-pathname fun))) - (when (and path (probe-file path)) - (print (namestring (truename path))) - t))) - - -;;; Old version (semi patched). Left here for the time being. -;(defun print-simple-source-info (fun) -; (let ((info (#+CMU17 -; kernel:%code-debug-info -; #-CMU17 -; kernel:code-debug-info -; (kernel:function-code-header fun)))) -; (when info -; (let ((sources (c::compiled-debug-info-source info))) -; (when sources -; (dolist (source sources) -; (let ((name (c::debug-source-name source))) -; (when (eq (c::debug-source-from source) :file) -; ;; Patch suggested by -; ;; hunter@work.nlm.nih.gov (Larry -; ;; Hunter) -; ;; (print (namestring name)) ; old -; (print (truename name)) -; ))) -; t))))) - - -(defun cmulisp-trace (symbol package breakp) - "Trace SYMBOL in PACKAGE." - (ilisp-errors - (let ((real-symbol (ilisp-find-symbol symbol package))) - (setq breakp (read-from-string breakp)) - (when real-symbol (eval `(trace ,real-symbol :break ,breakp))))))
--- a/lisp/ilisp/comint-ipc.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,941 +0,0 @@ -;;; -*-Emacs-Lisp-*- -;;; -;;; -;;;%Header -;;; -;;; Rcs_Info: comint-ipc.el,v 1.20 1993/09/03 02:05:07 ivan Rel $ -;;; -;;; IPC extensions for comint -;;; Copyright (C) 1990 Chris McConnell, ccm@cs.cmu.edu. -;;; -;;; Send mail to ilisp@naggum.no if you have problems. -;;; -;;; Send mail to ilisp-request@naggum.no if you want to be on the -;;; ilisp mailing list. - -;;; This file is part of GNU Emacs. - -;;; GNU Emacs is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY. No author or distributor -;;; accepts responsibility to anyone for the consequences of using it -;;; or for whether it serves any particular purpose or works at all, -;;; unless he says so in writing. Refer to the GNU Emacs General Public -;;; License for full details. - -;;; Everyone is granted permission to copy, modify and redistribute -;;; GNU Emacs, but only under the conditions described in the -;;; GNU Emacs General Public License. A copy of this license is -;;; supposed to have been given to you along with GNU Emacs so you -;;; can know your rights and responsibilities. It should be in a -;;; file named COPYING. Among other things, the copyright notice -;;; and this notice must be preserved on all copies. - -;;; This file contains extensions to multiplex the single channel of -;;; an inferior process between multiple purposes. It provides both -;;; synchronous and asynchronous sends with error handling. - -;;; USAGE: Load this file and call comint-setup-ipc in a comint -;;; buffer. This is not a standalone application. For an example of -;;; it being used see ilisp.el. - -;;; CUSTOMIZATION: See the parameters and hooks below. - -;;; INTERFACE. See the function documentation and code for more information. -;;; -;;; PROCESS INPUT: comint-send, comint-send-code, comint-default-send, -;;; comint-sync, comint-abort-sends -;;; -;;; PROCESS OUTPUT: comint-display-output, comint-display-error-output - - -;;;%Parameters -(defvar comint-log nil - "If T, then record all process input and output in a buffer called -process name.") - -(defvar comint-send-newline t - "If T then add a newline to string in comint-default-send.") - -(defvar comint-always-scroll nil - "If T then process output will always be visible in first window on buffer.") - -(defvar comint-fix-error nil - "String to send to send to the command interpreter to fix errors.") - -(defvar comint-continue nil - "String to send to continue an interrupted job.") - -(defvar comint-interrupt-regexp nil - "Regular expression for the start of an interrupt in process output.") - -(defvar comint-error-regexp nil - "Regular expression for setting comint-errorp if found in process output.") - -(defvar comint-output-buffer " *Output*" - "Name of the output buffer.") - -(defvar comint-error-buffer " *Error Output*" - "Name of the error output buffer.") - -(defvar comint-show-status t - "Set to nil to inhibit status redisplay.") - -;;;%%Hooks -(defvar comint-output-filter (function identity) - "Given the complete OUTPUT of a send, return the result of the send.") - -(defvar comint-interrupt-start 'comint-interrupt-start - "Return the start in OUTPUT of the text printed by -comint-interrupt-subjob in the inferior process.") - -(defvar comint-handler 'comint-error-popup - "Default handler for sends. When a send completes, the handler is -called with error-p, wait-p, message, output and prompt.") - -(defvar comint-update-status 'comint-update-status - "Function to update the STATUS of the inferior process. It should -set comint-status to a status string in addition to whatever else it -does.") - -(defvar comint-prompt-status 'comint-prompt-status - "Given the previous prompt and the last line output, return 'error -if an error, T if a prompt and nil otherwise. If it is a prompt, also -funcall comint-update-status to set the status. If old is nil, then -just return T if last line is a prompt.") - -;;; -(defvar comint-abort-hook nil - "List of hooks to run after sends are aborted.") - -;;;%Globals -(defvar comint-send-queue nil - "List of currently pending IPC send requests. The first element in -the queue is where output to the process will be stored. -A send record is a list of: - -string -- The string sent to the process. - -no-insert -- nil to insert output into the process buffer. If this is -being done, the results will only contain the very last line. - -wait-p -- nil if not waiting, non-nil if waiting. If it is a string, -results are inserted in the buffer until a result matches the string -as a regexp. - -status -- A symbol for the process status while the send is running. - -message -- A message to be displayed when an asynchronous send is -popped up by the handler. - -handler -- A function that given error-p, wait-p, message, output and -prompt decides if the user should be notified. If it is nil or -returns nil, then no error processing will be done. - -running -- nil if a send is waiting, T if it is running, another send -if interrupting and a string with pending output if the send was -interrupted. - -old-prompt -- The prompt before the send was sent. If it is nil, then -errors will not be detected. - -line -- The start of the last line in the results. - -result -- Cons of the output and the prompt after the send.") - -(defvar comint-end-queue nil "Pointer to the end of comint-send-queue.") -(defvar comint-queue-emptied t - "Set to T each time send queue empties.") - -(defvar comint-output nil - "Set to the output of the last send. This is useful when ilisp code -is put in the send stream.") -(defvar comint-errorp nil - "Set to T if the last send was an error.") - -(defvar comint-status " :run" "The current comint status.") -(defvar comint-original-buffer nil - "The original buffer when there was output to a comint buffer.") - -(defvar comint-last-send nil "Last send that was put in queue.") - -(defvar comint-aborting nil - "Set to T if we are aborting commands.") - -;;;%Utils -;;; -(defun comint-remove-whitespace (string) - "Remove leading and trailing whitespace in STRING." - (if string - (let* ((start (if (string-match "[^ \t\n]" string) - (match-beginning 0) - 0)) - (end start)) - (while (string-match "[ \t\n]*[^ \t\n]+" string end) - (setq end (match-end 0))) - (substring string start end)))) - -;;; -(defun comint-log (process string &optional output) - "Log to PROCESS, STRING marking as optional OUTPUT." - (if comint-log - (save-excursion - (set-buffer (get-buffer-create (process-name process))) - (goto-char (point-max)) - (if output - (progn - (insert "{") (insert string) (insert "}")) - (insert string))))) - -;;; v5.7b Removed by suggestion of erik@naggum.no (Erik Naggum). - -;;; (defun comint-send-string (proc str) -;;; "Send PROCESS the contents of STRING as input. -;;; This is equivalent to process-send-string, except that long input strings -;;; are broken up into chunks of size comint-input-chunk-size. Processes -;;; are given a chance to output between chunks. This can help prevent -;;; processes from hanging when you send them long inputs on some OS's." -;;; (comint-log proc str) -;;; (let* ((len (length str)) -;;; (i (min len comint-input-chunk-size))) -;;; (process-send-string proc (substring str 0 i)) -;;; (while (< i len) -;;; (let ((next-i (+ i comint-input-chunk-size))) -;;; (accept-process-output) -;;; (process-send-string proc (substring str i (min len next-i))) -;;; (setq i next-i))))) - -;;; v5.7b See above -(defun comint-sender (process string) - "Send to PROCESS STRING with newline if comint-send-newline." - ;; (comint-send-string process string) - (process-send-string process string) - (if comint-send-newline - (progn - (comint-log process "\n") - (process-send-string process "\n")))) - -;;; -(defun comint-interrupt-subjob () - "Interrupt the current subjob." - (interactive) - (comint-log (get-buffer-process (current-buffer)) "") - (interrupt-process nil comint-ptyp)) - -;;; -(defun comint-send-variables (send) - "Return a pointer to the start of the variables for SEND. It -returns \(running old-prompt line \(output . prompt))." - (cdr (cdr (cdr (cdr (cdr (cdr send))))))) - -;;; -(defun comint-send-results (send) - "Return the results of SEND which are \(output . prompt). If there is -an error, the prompt will be a list." - (car (cdr (cdr (cdr (comint-send-variables send)))))) - -;;; -(defun comint-send-description (send) - "Return a description of SEND." - (let* ((status (cdr (cdr (cdr send))))) - (or (car (cdr status)) ;Message - (and (stringp (car send)) (car send)) ;String - (and (car status) (symbol-name (car status)))))) - -;;; -(defun comint-interrupted () - "Return T if there is an interrupted send." - (let ((send comint-send-queue) - (done nil)) - (while (and send (not done)) - (if (stringp (car (comint-send-variables (car send)))) - (setq done t) - (setq send (cdr send)))) - done)) - - -;;;%Default hooks -(defun comint-process-sentinel (process status) - "Update PROCESS STATUS by funcalling comint-update-status." - (setq status (process-status process)) - (save-excursion - (if (buffer-name (process-buffer process)) - (set-buffer (process-buffer process))) - (funcall comint-update-status status))) - -;;; -(defun comint-interrupt-start (output) - "Return the start of comint-interrupt-regexp in OUTPUT." - (if (and comint-interrupt-regexp - (string-match comint-interrupt-regexp output)) - (match-beginning 0))) - -;;; -(defun comint-update-status (status) - "Update the process STATUS of the current buffer." - (setq comint-status (format " :%s" status)) - (if comint-show-status - (progn - (save-excursion (set-buffer (other-buffer))) - (sit-for 0)))) - -;;; -(defun comint-prompt-status (old line &optional equal) - "Called by comint-process filter with OLD and LINE, return 'error if -LINE is an error, T if it is a prompt as determined by -comint-prompt-regexp or nil otherwise. Also set the status -appropriately by funcalling comint-update-status. If specified EQUAL -will be called with old and line and should return T if line is not an -error. OLD will be nil for the first prompt." - (if (string-match comint-prompt-regexp line) - (let ((error (or (if equal - (funcall equal old line) - (or (null old) (string-equal old line))) - 'error))) - (funcall comint-update-status (if (eq error 'error) error 'ready)) - error) - nil)) - -;;; -(defun comint-insert (output) - "Insert process OUTPUT into the current buffer." - (if output - (let* ((buffer (current-buffer)) - (process (get-buffer-process buffer)) - (mark (process-mark process)) - (window (selected-window)) - (at-end nil)) - (if (eq (window-buffer window) buffer) - (setq at-end (= (point) mark)) - (setq window (get-buffer-window buffer))) - (save-excursion - (goto-char mark) - (insert output) - (set-marker mark (point))) - (if window - (progn - (if (or at-end comint-always-scroll) (goto-char mark)) - (if (not (pos-visible-in-window-p (point) window)) - (let ((original (selected-window))) - (save-excursion - (select-window window) - (recenter '(center)) - (select-window original))))))))) - -;;; -(defun comint-handle-error (output prompt keys &optional delay) - "Handle an error by beeping, displaying OUTPUT and then waiting for -the user to pause. Once there is pause, PROMPT until one of the -characters in KEYS is typed. If optional DELAY is specified, it is -the number of seconds that the user must pause. The key found will be -returned." - (save-excursion - (setq delay (or delay 1)) - (beep t) - (comint-display-error output) - (set-buffer comint-original-buffer) - (while (not (sit-for delay nil)) - (execute-kbd-macro (read-key-sequence nil))) - (if (not (get-buffer-window (get-buffer comint-error-buffer))) - (comint-display-error output)) - (let ((cursor-in-echo-area t) - (echo-keystrokes 0) - char) - (while (progn (message prompt) - (not (memq (setq char (downcase (read-char))) keys))) - (if (= char ? ) - (ilisp-scroll-output) - (setq quit-flag nil) - (beep))) - char))) - -;;; -(defun comint-error-popup (error wait-p message output prompt) - "If there is an ERROR pop up a window with MESSAGE and OUTPUT. -Nothing is done with PROMPT or WAIT-P." - (if error - (save-excursion - (with-output-to-temp-buffer comint-output-buffer - (set-buffer comint-output-buffer) - (if message (insert message)) - (insert ?\n) - (insert output) - (beep t)))) - t) - -;;; -(defun comint-process-filter (process output) - "Filter PROCESS OUTPUT. See comint-send for more information. The -first element of the comint-send-queue is the current send entry. If -the entry has a nil no-insert flag, insert the results into the -process buffer. - -If the send is an interrupt, comint-interrupt-start is funcalled on -the output and should return the start of the output of an interrupt. - -comint-prompt-status is called with the old prompt and the last line. -It should return 'error if the last line is an error, T if it is a -prompt and nil otherwise. It should also update the process status by -funcalling comint-update-status. - -If there is a send handler, it is called with \(error-p wait-p message -output prompt) and should determine what sort of notification is -appropriate and return T if errors should be fixed and NIL otherwise. - -If the prompt is an error, then comint-fix-error will be sent to fix -the error. - -When there is a prompt in the output stream, the next send will be -dispatched unless the wait flag for the send is a string. If it is a -string, then results will be discarded until one matches the string as -a regexp. - -Output to the process should only be done through the functions -comint-send or comint-default-send, or results will be mixed up." - (let* ((inhibit-quit t) - (window (selected-window)) - (comint-original-buffer (prog1 (current-buffer) - (set-buffer (process-buffer process)))) - (match-data (match-data)) - (send (car comint-send-queue)) - (no-insert (cdr send)) - (wait-p (cdr no-insert)) - (messagep (cdr (cdr wait-p))) - (handler (cdr messagep)) - (running (cdr handler)) - (old-prompt (cdr running)) - (line (cdr old-prompt)) - (result (car (cdr line))) - (old-result (car result)) - (no-insert (car no-insert)) - (message (car messagep)) - (wait-p (car wait-p)) - (sync (stringp wait-p))) - (comint-log process output t) - ;; Remove leading whitespace - (if (and (null old-result) - (save-excursion (goto-char (process-mark process)) (bolp)) - (eq (string-match "[ \t]*\n" output) 0)) - (setq output (substring output (match-end 0)))) - (rplaca result (concat old-result output)) - (while (string-match "\n" (car result) (car line)) - (rplaca line (match-end 0))) - (if (not (or sync no-insert)) - (progn - (comint-insert output) - ;; Throw away output if storing in buffer - (rplaca result (substring (car result) (car line))) - (rplaca line 0))) - (if (consp (car running)) ;Waiting for interrupt - (let ((split (funcall comint-interrupt-start (car result)))) - (if split - (let ((interrupted (car running))) - ;; Store output to previous send - (rplaca (comint-send-variables interrupted) - (substring (car result) 0 split)) - (rplaca result (substring (car result) (car line))) - (rplaca line 0) - (rplaca running t))))) - (if (not (consp (car running))) ;Look for prompt - (let* ((last (substring (car result) (car line))) - (is-prompt - (funcall comint-prompt-status (car old-prompt) last))) - (if is-prompt - (let* ((output - (if (or no-insert sync) - (funcall comint-output-filter - (substring (car result) 0 (car line))))) - (handler (car handler)) - (error (eq is-prompt 'error))) - (setq old-result (car result)) - (rplaca result output) - (rplacd result (if error (list last) last)) - (setq comint-output (car result) - comint-errorp - (or error - (and comint-error-regexp - comint-output - (string-match comint-error-regexp - comint-output)))) - (unwind-protect - ;; (if handler - ;; (setq handler - ;; (funcall handler comint-errorp wait-p - ;; message output last))) - - ;; v5.7b Patch suggested by fujieda@jaist.ac.jp - ;; (Kazuhiro Fujieda). Here is his comment. - - ;; "When the 'handler' is called, the current - ;; buffer may be changed. 'comint-process-filter' - ;; accesses some buffer-local variables, for - ;; example 'comint-send-queue' and - ;; 'comint-end-queue'. If the current buffer is - ;; changed in the 'handler', the entities of - ;; these buffer-local variables is replaced, and - ;; corrupt successive behaviors." - - ;; The code hereafter fixes the problem. - - (if handler - (save-excursion - (setq handler - (funcall handler comint-errorp wait-p - message output last)))) - - (if (and error handler no-insert comint-fix-error) - (setq comint-send-queue - (cons (list comint-fix-error t nil 'fix - "Fixing error" nil - nil nil 0 (cons nil nil)) - ;; We may have aborted - (or (cdr comint-send-queue) - comint-send-queue)))) - (if sync - (let ((match (string-match wait-p old-result))) - (if match - (progn - (rplaca - (cdr (cdr (cdr (cdr (car comint-end-queue))))) - "Done") - (if (not no-insert) - (comint-insert - (concat - (substring old-result 0 match) - (substring old-result (match-end 0))))) - (rplaca result (substring old-result - match (car line))) - (rplaca messagep "Done") - (rplaca running nil) - (comint-dispatch-send process)))) - ;; Not waiting - (rplaca messagep "Done") - (rplaca running nil) - (comint-dispatch-send process)))) - (rplacd result nil)))) - (store-match-data match-data) - (if (or (get-buffer-window comint-original-buffer) - (eq (window-buffer (minibuffer-window)) comint-original-buffer)) - (set-buffer comint-original-buffer)))) - -;;; -(defun comint-dispatch-send (process) - "Dispatch the next send in PROCESS comint-send-queue, popping the -current send if done." - (let* ((send (car comint-send-queue)) - (results (comint-send-results send)) - (prompt (cdr results))) - ;; Never pop the last record - (cond ((and (null comint-send-queue) ; Catch a bug. - (null comint-end-queue))) - - ((eq comint-send-queue comint-end-queue) - (let ((init (car send)) - (running (comint-send-variables send))) - (setq comint-queue-emptied t) - ;; Set old prompt to prompt - (if prompt - (rplaca (cdr (comint-send-variables send)) - (if (consp prompt) (car prompt) prompt))) - (rplaca send nil) - (if init - (funcall init) - (if (stringp (car running)) - ;; Continue if interrupted. There is no way to - ;; sense if the interrupted command actually - ;; started, so it is possible that a command will - ;; get lost. - (progn (funcall comint-update-status - (car (cdr (cdr (cdr send))))) - (comint-sender process comint-continue) - (comint-process-filter process (car running)) - (rplaca running t)))))) - (t - (if prompt - ;; Pop - (setq comint-send-queue (cdr comint-send-queue) - send (car comint-send-queue)) - ;; Set prompt to top-level prompt - (setq prompt (cdr (comint-send-results (car comint-end-queue))))) - (let* ((top-level (eq comint-send-queue comint-end-queue)) - (string (car send)) - (no-insert (cdr send)) - (wait-p (cdr no-insert)) - (status (cdr wait-p)) - (message (cdr status)) - (status (car status)) - (no-insert (car no-insert)) - (message (car message)) - (running (comint-send-variables send))) - (if top-level - (rplaca send nil) - (if (stringp string) (funcall comint-update-status status))) - (if (and message (not no-insert) (not (stringp (car wait-p))) - (not top-level)) - ;; Display message on first output - (comint-insert - (concat comment-start comment-start comment-start - message comment-end "\n"))) - (if (and string (not (stringp string))) - ;; Elisp code - (progn - (rplacd (comint-send-results (car comint-send-queue)) - (if (consp prompt) (car prompt) prompt)) - (funcall string) - (comint-dispatch-send process)) - (if (stringp (car running)) - ;; Continue interrupted send - (let ((output (car running))) - (if (or top-level (car (comint-send-results send)) - (not (string-equal output ""))) - ;; Continue old command - (progn - (rplaca running t) - (funcall comint-update-status status) - (comint-sender process comint-continue) - (comint-process-filter process output) - ;; Send queued default sends - (if (and top-level string) - (comint-sender process string))) - ;; Assume we have to restart the command since - ;; there is no output. There is no way to - ;; sense whether or not the inferior has - ;; started processing the previous send. This - ;; is a problem only if the original did start - ;; and had side effects. - (rplaca running nil) - (setq comint-send-queue - (cons (list comint-fix-error t nil 'fix - "Fixing error" nil - nil nil 0 (cons nil nil)) - comint-send-queue)) - (comint-dispatch-send process))) - (if (not top-level) - ;; New send, set old prompt to the prompt of previous - (rplaca (cdr (comint-send-variables send)) - (if (consp prompt) (car prompt) prompt))) - (if string - (progn - (rplaca running t) - (comint-sender process string)))))))))) - -;;; -(defun comint-interrupt (process send) - "Interrupt PROCESS to send SEND if comint-continue is defined and -the current send is not waiting. Otherwise, SEND will be the next -send." - (if (and comint-continue (not (car (cdr (cdr (car comint-send-queue)))))) - (let* ((current (car comint-send-queue)) - (interrupt - ;; string no-insert wait-p status message handler - (list nil t nil 'interrupt "Interrupt" nil - ;; running old-prompt line (output . prompt) - current nil 0 (cons nil nil)))) - (setq comint-send-queue (cons interrupt (cons send comint-send-queue))) - (funcall comint-update-status 'interrupt) - (comint-interrupt-subjob)) - (if (eq comint-send-queue comint-end-queue) - (setq comint-send-queue - (cons (car comint-send-queue) - (cons send comint-send-queue))) - (rplacd comint-send-queue (cons send (cdr comint-send-queue)))))) - -;;;%Interface -(defun comint-setup-ipc (&optional force) - "Setup for IPC in the current buffer. If called interactively, -force comint-send-queue to be initialized." - (interactive "p") - (make-local-variable 'comint-send-newline) - (make-local-variable 'comint-always-scroll) - (make-local-variable 'comint-fix-error) - (make-local-variable 'comint-continue) - (make-local-variable 'comint-interrupt-regexp) - (make-local-variable 'comint-error-regexp) - (make-local-variable 'comint-output-filter) - (make-local-variable 'comint-interrupt-start) - (make-local-variable 'comint-handler) - (make-local-variable 'comint-update-status) - (make-local-variable 'comint-prompt-status) - (make-local-variable 'comint-send-queue) - (make-local-variable 'comint-end-queue) - (make-local-variable 'comint-queue-emptied) - (make-local-variable 'comint-output) - (make-local-variable 'comint-errorp) - (make-local-variable 'comint-status) - (make-local-variable 'comint-aborting) - (if (or force (not comint-send-queue)) - (setq comint-send-queue - (list (list nil nil nil 'run "Top Level" - nil t nil 0 (cons nil nil))) - comint-end-queue comint-send-queue)) - (let ((process (get-buffer-process (current-buffer)))) - (set-process-filter process 'comint-process-filter) - (set-process-sentinel process 'comint-process-sentinel)) - (setq mode-line-process 'comint-status)) - -;;;%%Input -(defun comint-send (process string - &optional - no-insert - wait - status - message - handler - after) - "Do a send to PROCESS of STRING. Optionally specify NO-INSERT, -WAIT, STATUS, MESSAGE, HANDLER and AFTER. Without optional arguments, -this is just like process-send-string. If STRING is not a string, -then it is assumed to be an elisp function and will be called when -encountered in the send queue. The send will be the next one if WAIT, -after the last send if AFTER, otherwise it will be put at the end of -the queue. If WAIT is non-NIL or on the first send to a busy inferior, -the inferior will be interrupted if possible, see comint-interrupt for -more information. Once the send is sent, the process status will be -STATUS or 'run. Output of the send will be inserted into the process -buffer unless NO-INSERT. This function returns a list of \(result . -prompt). If WAIT is a string, output will be inserted until one -matches the string as a regexp. If WAIT is T, then PROMPT will have -the prompt when finished and RESULT will have the output. If PROMPT -is a list, then there was an error. If WAIT is not T, then the list -returned will change when the send has been sent and is finished. If -HANDLER is nil it will be set to comint-handler. If it is T, errors -will be ignored. When a send is finished, it calls handler with -\(error-p WAIT MESSAGE output prompt) which decides what to do with -the output. - -VARIABLES: - -comint-always-scroll will cause all process output to be visible. - -comint-fix-error is the string used to fix errors. - -comint-continue is the string used to continue after an interrupt. - -comint-interrupt-regexp is the default regexp to use in finding the -start of the interrupt text. - -comint-error-regexp will set comint-errorp if found in the process output. - -FUNCTIONS: Each of the functions in these variables is called with -the buffer set to the appropriate process buffer and -comint-original-buffer bound to the buffer current when the process -filter was called. - -comint-update-status is a function \(status) that is called each time -the process status changes. - -comint-prompt-status is called with the old prompt and the last line. -It should return 'error if the last line is an error, T if it is a -prompt and nil otherwise. It should also update the process status by -funcalling comint-update-status. - -comint-output-filter is a function \(output) for sends with NO-INSERT. -It should return the output string. - -comint-interrupt-start is a function \(output) that returns the start -of the interrupt text in output using comint-interrupt-regexp to find it." - (save-excursion - (set-buffer (process-buffer process)) - (let* ((inhibit-quit t) - (send (list string - no-insert - wait - (or status 'run) - message - (if (eq handler t) nil (or handler comint-handler)) - ;; running, old-prompt, line - nil nil 0 - ;; (output . prompt) - (cons nil nil))) - (pointer (comint-send-results send)) - (top-level (eq comint-send-queue comint-end-queue)) - (end (car comint-end-queue)) - (current (car comint-send-queue)) - (prompt (cdr (comint-send-results current))) - (ok nil)) - (setq comint-aborting nil) - (if (and top-level (or (stringp wait) prompt)) - (progn - (setq comint-send-queue (cons send comint-send-queue)) - (comint-dispatch-send process)) - (if (or (and wait (not after) (not prompt)) top-level) - (comint-interrupt process send) - (let ((looking t) - (next comint-send-queue)) - (if after - (while (and looking next) - (if (eq (car next) comint-last-send) - (progn - (rplacd next (cons send (cdr next))) - (setq looking nil))) - (setq next (cdr next)))) - (if looking - (progn - (rplaca comint-end-queue send) - (setq comint-end-queue - (rplacd comint-end-queue (cons end nil)))))))) - (setq comint-last-send send) - (unwind-protect - (let ((inhibit-quit nil)) - (if (eq wait t) - (while (not (cdr pointer)) - (accept-process-output) - (sit-for 0))) - (setq ok pointer)) - (if (not ok) - (if (eq send (car comint-send-queue)) - (let ((interrupt - ;; string no-insert wait status message handler - (list nil t nil 'interrupt "Interrupt" nil - ;; running old-prompt line (output . prompt) - send (car (cdr (comint-send-variables send))) - nil (cons nil nil)))) - (setq comint-send-queue - (cons interrupt (cdr comint-send-queue))) - (comint-interrupt-subjob)) - (setq comint-send-queue (delq send comint-send-queue)))))))) - -;;; -(defun comint-send-code (process code) - "Execute after the previous send in PROCESS queue CODE. You do not -want to execute synchronous sends in the code or it will lock up. " - (comint-send process code nil nil nil nil nil t)) - -;;; -(defun comint-default-send (process string) - "Send to PROCESS top-level, STRING." - (save-excursion - (set-buffer (process-buffer process)) - (let* ((top (car comint-end-queue)) - (old (car top))) - (rplaca (cdr (cdr (cdr (cdr (car comint-end-queue))))) string) - (if (eq comint-send-queue comint-end-queue) - (progn (funcall comint-update-status 'run) - (rplaca (comint-send-variables (car comint-send-queue)) t) - (rplacd (comint-send-results (car comint-send-queue)) nil) - (comint-sender process string)) - (rplaca top - (if old - (concat old (if comint-send-newline "\n") string) - string)))))) - -;;; -(defun comint-sync (process start start-regexp end end-regexp) - "Synchronize with PROCESS output stream. START will be sent with -each prompt received until START-REGEXP shows up in the stream. Then -END will be sent and all output will be discarded until END-REGEXP -shows up in the output stream." - (comint-send - process - start - nil start-regexp 'sync "Start sync" - (function (lambda (error-p wait message output prompt) - (if (not (string-match wait output)) - (comint-sender - (get-buffer-process (current-buffer)) - (car (car comint-send-queue)))) - nil))) - (comint-send - process - end - t end-regexp 'sync "End sync" - (function (lambda (&rest args) nil)))) - -;;; -(defun comint-abort-sends (&optional process) - "Abort all of the pending sends for optional PROCESS and show their -messages in *Aborted Commands*." - (interactive) - (save-excursion - (setq process (or process (get-buffer-process (current-buffer)))) - (set-buffer (process-buffer process)) - (setq comint-aborting t) - (if (not (eq comint-send-queue comint-end-queue)) - (let* ((inhibit-quit t) - (send (car comint-send-queue)) - (vars (comint-send-variables send)) - (pointer comint-send-queue) - (new nil) - (interrupt (and (car vars) - (not (cdr (comint-send-results send)))))) - (if interrupt - (progn ;Sent, but no prompt - (if (consp (car vars)) - (progn (setq new (list send)) - (rplaca (cdr (cdr (cdr (cdr (cdr send))))) - (function (lambda (&rest args) t)))) - (setq new - (list - (list nil t nil 'interrupt "Interrupt" - (function (lambda (&rest args) t)) - send (car (cdr (comint-send-variables send))) - nil (cons nil nil)))) - (comint-interrupt-subjob)))) ;Already interrupting - (save-excursion - (set-buffer (get-buffer-create "*Aborted Commands*")) - (delete-region (point-min) (point-max))) - (while (not (eq pointer comint-end-queue)) - (let ((send (car pointer))) - (if (car (cdr (cdr (cdr (cdr send))))) ;Message - (save-excursion - (set-buffer "*Aborted Commands*") - (insert (comint-send-description send)) - (insert "\n\n"))) - (if (and comint-fix-error - (stringp (car (comint-send-variables send)))) - ;; Interrupted - (setq new (cons - (list comint-fix-error t nil 'fix - "Fixing error" nil - nil nil 0 (cons nil nil)) - new))) - (setq pointer (cdr pointer)))) - (bury-buffer "*Aborted Commands*") - (rplaca (car comint-end-queue) nil) - (setq comint-send-queue - (reverse (cons (car comint-end-queue) new)) - comint-end-queue - (let ((pointer comint-send-queue)) - (while (cdr pointer) - (setq pointer (cdr pointer))) - pointer)) - (run-hooks 'comint-abort-hook) - (if (not interrupt) (comint-dispatch-send process)))))) - -;;; -(defun comint-current-send (showp) - "Show the message of the current send in the minibuffer." - (interactive "P") - (if showp - (with-output-to-temp-buffer comint-output-buffer - (let ((send comint-send-queue)) - (save-excursion - (set-buffer comint-output-buffer) - (insert "Pending commands:\n") - (while send - (let ((message (car (cdr (cdr (cdr (cdr (car send)))))))) - (if message (insert (concat message "\n")))) - (setq send (cdr send))))))) - (message - (concat "Command: " - (or (comint-send-description (car comint-send-queue)) - "Unknown")))) - - -;;; -(defun comint-display-output (text &optional buffer) - "Put TEXT in optional BUFFER and show it in a small temporary window." - (setq buffer (or buffer comint-output-buffer)) - (with-output-to-temp-buffer buffer - (save-excursion - (set-buffer buffer) - (insert text) - (set-buffer-modified-p nil))) - text) -;; Perhaps this should use ilisp-display-output. - -;;; -(defun comint-display-error (text) - "Put TEXT in the comint-error-buffer and display it." - (comint-display-output text comint-error-buffer)) - -(provide 'comint-ipc)
--- a/lisp/ilisp/comint-v18.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,987 +0,0 @@ -;;; -*-Emacs-Lisp-*- General command interpreter in a window stuff -;;; Copyright Olin Shivers (1988). -;;; Please imagine a long, tedious, legalistic 5-page gnu-style copyright -;;; notice appearing here to the effect that you may use this code any -;;; way you like, as long as you don't charge money for it, remove this -;;; notice, or hold me liable for its results. - -;;; This hopefully generalises shell mode, lisp mode, tea mode, soar mode,... -;;; Hacked from tea.el and shell.el by Olin Shivers (shivers@cs.cmu.edu). 8/88 - -;;; This file defines a general command-interpreter-in-a-buffer package -;;; (comint mode). The idea is that you can build specific process-in-a-buffer -;;; modes on top of comint mode -- e.g., lisp, shell, scheme, T, soar, .... -;;; This way, all these specific packages share a common base functionality, -;;; and a common set of bindings, which makes them easier to use (and -;;; saves code, implementation time, etc., etc.). -;;; -;;; Several packages are already defined using comint mode: -;;; - The file cmushell.el defines cmushell and cmulisp mode. -;;; Cmushell and cmulisp mode are similar to, and intended to replace, -;;; their counterparts in the standard gnu emacs release (in shell.el). -;;; These replacements are more featureful, robust, and uniform than the -;;; released versions. The key bindings in lisp mode are also more compatible -;;; with the bindings of Hemlock and Zwei (the Lisp Machine emacs). -;;; -;;; - The file cmuscheme.el defines inferior-scheme mode. -;;; - The file tea.el tunes scheme and inferior-scheme modes for T. -;;; - The file soar.el tunes lisp and inferior-lisp modes for Soar. - -;;; For documentation on the functionality provided by comint mode, and -;;; the hooks available for customising it, see the comments below. -;;; For further information on the standard derived modes (shell, -;;; inferior-lisp, inferior-scheme, ...), see the relevant source files. - -;;; Please send me bug reports, bug fixes, and extensions, so that I can -;;; merge them into the master source. - -;;; For hints on converting existing process modes (e.g., tex-mode, -;;; background, dbx, gdb, kermit, prolog, telnet) to use comint-mode -;;; instead of shell-mode, see the notes at the end of this file. - -(provide 'comint) - - -;;; Brief Command Documentation: -;;;============================================================================ -;;; Comint Mode Commands: (common to all derived modes, like cmushell & cmulisp -;;; mode) -;;; -;;; m-p comint-previous-input Cycle backwards in input history -;;; m-n comint-next-input Cycle forwards -;;; c-c r comint-previous-input-matching Search backwards in input history -;;; return comint-send-input -;;; c-a comint-bol Beginning of line; skip prompt. -;;; c-d comint-delchar-or-maybe-eof Delete char unless at end of buff. -;;; c-c c-u comint-kill-input ^u -;;; c-c c-w backward-kill-word ^w -;;; c-c c-c comint-interrupt-subjob ^c -;;; c-c c-z comint-stop-subjob ^z -;;; c-c c-\ comint-quit-subjob ^\ -;;; c-c c-o comint-kill-output Delete last batch of process output -;;; c-c c-r comint-show-output Show last batch of process output -;;; -;;; Not bound by default in comint-mode -;;; send-invisible Read a line w/o echo, and send to proc -;;; (These are bound in shell-mode) -;;; comint-dynamic-complete Complete filename at point. -;;; comint-dynamic-list-completions List completions in help buffer. -;;; comint-replace-by-expanded-filename Expand and complete filename at point; -;;; replace with expanded/completed name. -;;; comint-kill-subjob No mercy. -;;; comint-continue-subjob Send CONT signal to buffer's process -;;; group. Useful if you accidentally -;;; suspend your process (with C-c C-z). -;;; -;;; Bound for RMS -- I prefer the input history stuff, but you might like 'em. -;;; m-P comint-msearch-input Search backwards for prompt -;;; m-N comint-psearch-input Search forwards for prompt -;;; C-cR comint-msearch-input-matching Search backwards for prompt & string - -;;; comint-mode-hook is the comint mode hook. Basically for your keybindings. -;;; comint-load-hook is run after loading in this package. - - -;;; Buffer Local Variables: -;;;============================================================================ -;;; Comint mode buffer local variables: -;;; comint-prompt-regexp - string comint-bol uses to match prompt. -;;; comint-last-input-end - marker For comint-kill-output command -;;; input-ring-size - integer For the input history -;;; input-ring - ring mechanism -;;; input-ring-index - marker ... -;;; comint-last-input-match - string ... -;;; comint-get-old-input - function Hooks for specific -;;; comint-input-sentinel - function process-in-a-buffer -;;; comint-input-filter - function modes. -(defvar comint-prompt-regexp "^" - "Regexp to recognise prompts in the inferior process. -Defaults to \"^\", the null string at BOL. - -Good choices: - Canonical Lisp: \"^[^> ]*>+:? *\" (Lucid, franz, kcl, T, cscheme, oaklisp) - Lucid Common Lisp: \"^\\(>\\|\\(->\\)+\\) *\" - franz: \"^\\(->\\|<[0-9]*>:\\) *\" - kcl: \"^>+ *\" - shell: \"^[^#$%>]*[#$%>] *\" - T: \"^>+ *\" - -This is a good thing to set in mode hooks.") - -(defvar input-ring-size 30 - "Size of input history ring.") - -;;; Here are the per-interpreter hooks. -(defvar comint-get-old-input (function comint-get-old-input-default) - "Function that submits old text in comint mode. -This function is called when return is typed while the point is in old text. -It returns the text to be submitted as process input. The default is -comint-get-old-input-default, which grabs the current line, and strips off -leading text matching comint-prompt-regexp") - -(defvar comint-input-sentinel (function ignore) - "Called on each input submitted to comint mode process by comint-send-input. -Thus it can, for instance, track cd/pushd/popd commands issued to the csh.") - -(defvar comint-input-filter - (function (lambda (str) (not (string-match "\\`\\s *\\'" str)))) - "Predicate for filtering additions to input history. -Only inputs answering true to this function are saved on the input -history list. Default is to save anything that isn't all whitespace") - -(defvar comint-mode-hook '() - "Called upon entry into comint-mode") - -(defvar comint-mode-map nil) - -;; Added for ILISP -(defvar comint-input-chunk-size 512) - - - -(defun comint-mode () - "Major mode for interacting with an inferior interpreter. -Interpreter name is same as buffer name, sans the asterisks. -Return at end of buffer sends line as input. -Return not at end copies rest of line to end and sends it. - -This mode is typically customised to create inferior-lisp-mode, -shell-mode, etc.. This can be done by setting the hooks -comint-input-sentinel, comint-input-filter, and comint-get-old-input to -appropriate functions, and the variable comint-prompt-regexp to -the appropriate regular expression. - -An input history is maintained of size input-ring-size, and -can be accessed with the commands comint-next-input [\\[comint-next-input]] and -comint-previous-input [\\[comint-previous-input]]. Commands not keybound by -default are send-invisible, comint-dynamic-complete, and -comint-list-dynamic-completions. -\\{comint-mode-map} -If you accidentally suspend your process, use \\[comint-continue-subjob] -to continue it. - -Entry to this mode runs the hooks on comint-mode-hook" - (interactive) - (let ((old-ring (and (assq 'input-ring (buffer-local-variables)) - (boundp 'input-ring) - input-ring))) - (kill-all-local-variables) - (setq major-mode 'comint-mode) - (setq mode-name "Comint") - (setq mode-line-process '(": %s")) - (use-local-map comint-mode-map) - (make-local-variable 'comint-last-input-end) - (setq comint-last-input-end (make-marker)) - (make-local-variable 'comint-last-input-match) - (setq comint-last-input-match "") - (make-variable-buffer-local 'comint-prompt-regexp) ; Don't set; default - (make-variable-buffer-local 'input-ring-size) ; ...to global val. - (make-local-variable 'input-ring) - (make-local-variable 'input-ring-index) - (setq input-ring-index 0) - (make-variable-buffer-local 'comint-get-old-input) - (make-variable-buffer-local 'comint-input-sentinel) - (make-variable-buffer-local 'comint-input-filter) - (run-hooks 'comint-mode-hook) - ;Do this after the hook so the user can mung INPUT-RING-SIZE w/his hook. - ;The test is so we don't lose history if we run comint-mode twice in - ;a buffer. - (setq input-ring (if (ring-p old-ring) old-ring - (make-ring input-ring-size))))) - -(if comint-mode-map - nil - (setq comint-mode-map (make-sparse-keymap)) - (define-key comint-mode-map "\ep" 'comint-previous-input) - (define-key comint-mode-map "\en" 'comint-next-input) - (define-key comint-mode-map "\C-m" 'comint-send-input) - (define-key comint-mode-map "\C-d" 'comint-delchar-or-maybe-eof) - (define-key comint-mode-map "\C-a" 'comint-bol) - (define-key comint-mode-map "\C-c\C-u" 'comint-kill-input) - (define-key comint-mode-map "\C-c\C-w" 'backward-kill-word) - (define-key comint-mode-map "\C-c\C-c" 'comint-interrupt-subjob) - (define-key comint-mode-map "\C-c\C-z" 'comint-stop-subjob) - (define-key comint-mode-map "\C-c\C-\\" 'comint-quit-subjob) - (define-key comint-mode-map "\C-c\C-o" 'comint-kill-output) - (define-key comint-mode-map "\C-cr" 'comint-previous-input-matching) - (define-key comint-mode-map "\C-c\C-r" 'comint-show-output) - ;;; Here's the prompt-search stuff I installed for RMS to try... - (define-key comint-mode-map "\eP" 'comint-msearch-input) - (define-key comint-mode-map "\eN" 'comint-psearch-input) - (define-key comint-mode-map "\C-cR" 'comint-msearch-input-matching)) - - -;;; This function is used to make a full copy of the comint mode map, -;;; so that client modes won't interfere with each other. This function -;;; isn't necessary in emacs 18.5x, but we keep it around for 18.4x versions. -(defun full-copy-sparse-keymap (km) - "Recursively copy the sparse keymap KM" - (cond ((consp km) - (cons (full-copy-sparse-keymap (car km)) - (full-copy-sparse-keymap (cdr km)))) - (t km))) - -(defun comint-check-proc (buffer-name) - "True if there is a process associated w/buffer BUFFER-NAME, and -it is alive (status RUN or STOP)." - (let ((proc (get-buffer-process buffer-name))) - (and proc (memq (process-status proc) '(run stop))))) - -;;; Note that this guy, unlike shell.el's make-shell, barfs if you pass it () -;;; for the second argument (program). -(defun make-comint (name program &optional startfile &rest switches) - (let* ((buffer (get-buffer-create (concat "*" name "*"))) - (proc (get-buffer-process buffer))) - ;; If no process, or nuked process, crank up a new one and put buffer in - ;; comint mode. Otherwise, leave buffer and existing process alone. - (cond ((or (not proc) (not (memq (process-status proc) '(run stop)))) - (comint-exec buffer name program startfile switches) - (save-excursion - (set-buffer buffer) - (comint-mode)))) ; Install local vars, mode, keymap, ... - buffer)) - -(defun comint-exec (buffer name command startfile switches) - "Fires up a process in buffer for comint modes. -Blasts any old process running in the buffer. Doesn't set the buffer mode. -You can use this to cheaply run a series of processes in the same comint -buffer." - (save-excursion - (set-buffer buffer) - (let ((proc (get-buffer-process buffer))) ; Blast any old process. - (if proc (delete-process proc))) - ;; Crank up a new process - (let ((proc (apply 'start-process name buffer (concat exec-directory "env") - (format "TERMCAP=emacs:co#%d:tc=unknown:" - (screen-width)) - "TERM=emacs" "EMACS=t" "-" command switches))) - ;; Feed it the startfile. - (cond (startfile - ;;This is guaranteed to wait long enough - ;;but has bad results if the comint does not prompt at all - ;; (while (= size (buffer-size)) - ;; (sleep-for 1)) - ;;I hope 1 second is enough! - (sleep-for 1) - (goto-char (point-max)) - (insert-file-contents startfile) - (setq startfile (buffer-substring (point) (point-max))) - (delete-region (point) (point-max)) - (process-send-string proc startfile))) - ;; Jump to the end, and set the process mark. - (goto-char (point-max)) - (set-marker (process-mark proc) (point))) - buffer)) - - - -;;; Ring Code -;;;============================================================================ -;;; This code defines a ring data structure. A ring is a -;;; (hd-index tl-index . vector) -;;; list. You can insert to, remove from, and rotate a ring. When the ring -;;; fills up, insertions cause the oldest elts to be quietly dropped. -;;; -;;; HEAD = index of the newest item on the ring. -;;; TAIL = index of the oldest item on the ring. -;;; -;;; These functions are used by the input history mechanism, but they can -;;; be used for other purposes as well. - -(defun ring-p (x) - "T if X is a ring; NIL otherwise." - (and (consp x) (integerp (car x)) - (consp (cdr x)) (integerp (car (cdr x))) - (vectorp (cdr (cdr x))))) - -(defun make-ring (size) - "Make a ring that can contain SIZE elts" - (cons 1 (cons 0 (make-vector (+ size 1) nil)))) - -(defun ring-plus1 (index veclen) - "INDEX+1, with wraparound" - (let ((new-index (+ index 1))) - (if (= new-index veclen) 0 new-index))) - -(defun ring-minus1 (index veclen) - "INDEX-1, with wraparound" - (- (if (= 0 index) veclen index) 1)) - -(defun ring-length (ring) - (let ((hd (car ring)) (tl (car (cdr ring))) (siz (length (cdr (cdr ring))))) - (let ((len (if (<= hd tl) (+ 1 (- tl hd)) (+ 1 tl (- siz hd))))) - (if (= len siz) 0 len)))) - -(defun ring-empty-p (ring) - (= 0 (ring-length ring))) - -(defun ring-insert (ring item) - "Insert a new item onto the ring. If the ring is full, dump the oldest -item to make room." - (let* ((vec (cdr (cdr ring))) (len (length vec)) - (new-hd (ring-minus1 (car ring) len))) - (setcar ring new-hd) - (aset vec new-hd item) - (if (ring-empty-p ring) ;overflow -- dump one off the tail. - (setcar (cdr ring) (ring-minus1 (car (cdr ring)) len))))) - -(defun ring-remove (ring) - "Remove the oldest item retained on the ring." - (if (ring-empty-p ring) (error "Ring empty") - (let ((tl (car (cdr ring))) (vec (cdr (cdr ring)))) - (set-car (cdr ring) (ring-minus1 tl (length vec))) - (aref vec tl)))) - -;;; This isn't actually used in this package. I just threw it in in case -;;; someone else wanted it. If you want rotating-ring behavior on your history -;;; retrieval (analagous to kill ring behavior), this function is what you -;;; need. I should write the yank-input and yank-pop-input-or-kill to go with -;;; this, and not bind it to a key by default, so it would be available to -;;; people who want to bind it to a key. But who would want it? Blech. -(defun ring-rotate (ring n) - (if (not (= n 0)) - (if (ring-empty-p ring) ;Is this the right error check? - (error "ring empty") - (let ((hd (car ring)) (tl (car (cdr ring))) (vec (cdr (cdr ring)))) - (let ((len (length vec))) - (while (> n 0) - (setq tl (ring-plus1 tl len)) - (aset ring tl (aref ring hd)) - (setq hd (ring-plus1 hd len)) - (setq n (- n 1))) - (while (< n 0) - (setq hd (ring-minus1 hd len)) - (aset vec hd (aref vec tl)) - (setq tl (ring-minus1 tl len)) - (setq n (- n 1)))) - (set-car ring hd) - (set-car (cdr ring) tl))))) - -(defun comint-mod (n m) - "Returns N mod M. M is positive. Answer is guaranteed to be non-negative, -and less than m." - (let ((n (% n m))) - (if (>= n 0) n - (+ n - (if (>= m 0) m (- m)))))) ; (abs m) - -(defun ring-ref (ring index) - (let ((numelts (ring-length ring))) - (if (= numelts 0) (error "indexed empty ring") - (let* ((hd (car ring)) (tl (car (cdr ring))) (vec (cdr (cdr ring))) - (index (comint-mod index numelts)) - (vec-index (comint-mod (+ index hd) - (length vec)))) - (aref vec vec-index))))) - - -;;; Input history retrieval commands -;;; M-p -- previous input M-n -- next input -;;; C-c r -- previous input matching -;;; =========================================================================== - -(defun comint-previous-input (arg) - "Cycle backwards through input history." - (interactive "*p") - (let ((len (ring-length input-ring))) - (cond ((<= len 0) - (message "Empty input ring") - (ding)) - ((not (comint-after-pmark-p)) - (message "Not after process mark") - (ding)) - (t - (cond ((eq last-command 'comint-previous-input) - (delete-region (mark) (point)) - (set-mark (point))) - (t - (setq input-ring-index - (if (> arg 0) -1 - (if (< arg 0) 1 0))) - (push-mark (point)))) - (setq input-ring-index (comint-mod (+ input-ring-index arg) len)) - (message "%d" (1+ input-ring-index)) - (insert (ring-ref input-ring input-ring-index)) - (setq this-command 'comint-previous-input)) - (t (ding))))) - -(defun comint-next-input (arg) - "Cycle forwards through input history." - (interactive "*p") - (comint-previous-input (- arg))) - -(defvar comint-last-input-match "" - "Last string searched for by comint input history search, for defaulting. -Buffer local variable.") - -(defun comint-previous-input-matching (str) - "Searches backwards through input history for substring match" - (interactive (let ((s (read-from-minibuffer - (format "Command substring (default %s): " - comint-last-input-match)))) - (list (if (string= s "") comint-last-input-match s)))) -; (interactive "sCommand substring: ") - (setq comint-last-input-match str) ; update default - (let ((str (regexp-quote str)) - (len (ring-length input-ring)) - (n 0)) - (while (and (<= n len) (not (string-match str (ring-ref input-ring n)))) - (setq n (+ n 1))) - (cond ((<= n len) (comint-previous-input (+ n 1))) - (t (error "Not found."))))) - -;;; These next three commands are alternatives to the input history commands -- -;;; comint-next-input, comint-previous-input and -;;; comint-previous-input-matching. They search through the process buffer -;;; text looking for occurrences of the prompt. RMS likes them better; -;;; I don't. Bound to M-P, M-N, and C-c R (uppercase P, N, and R) for -;;; now. Try'em out. Go with what you like... - -;;; comint-msearch-input-matching prompts for a string, not a regexp. -;;; This could be considered to be the wrong thing. I decided to keep it -;;; simple, and not make the user worry about regexps. This, of course, -;;; limits functionality. - -(defun comint-psearch-input () - "Search forwards for next occurrence of prompt and skip to end of line. -\(prompt is anything matching regexp comint-prompt-regexp)" - (interactive) - (if (re-search-forward comint-prompt-regexp (point-max) t) - (end-of-line) - (error "No occurrence of prompt found"))) - -(defun comint-msearch-input () - "Search backwards for previous occurrence of prompt and skip to end of line. -Search starts from beginning of current line." - (interactive) - (let ((p (save-excursion - (beginning-of-line) - (cond ((re-search-backward comint-prompt-regexp (point-min) t) - (end-of-line) - (point)) - (t nil))))) - (if p (goto-char p) - (error "No occurrence of prompt found")))) - -(defun comint-msearch-input-matching (str) - "Search backwards for occurrence of prompt followed by STRING. -STRING is prompted for, and is NOT a regular expression." - (interactive (let ((s (read-from-minibuffer - (format "Command (default %s): " - comint-last-input-match)))) - (list (if (string= s "") comint-last-input-match s)))) -; (interactive "sCommand: ") - (setq comint-last-input-match str) ; update default - (let* ((r (concat comint-prompt-regexp (regexp-quote str))) - (p (save-excursion - (beginning-of-line) - (cond ((re-search-backward r (point-min) t) - (end-of-line) - (point)) - (t nil))))) - (if p (goto-char p) - (error "No match")))) - -(defun comint-send-input () - "Send input to process. After the process output mark, sends all text -from the process mark to point as input to the process. Before the -process output mark, calls value of variable comint-get-old-input to retrieve -old input, copies it to the end of the buffer, and sends it. A terminal -newline is also inserted into the buffer and sent to the process. In either -case, value of variable comint-input-sentinel is called on the input before -sending it. The input is entered into the input history ring, if value of -variable comint-input-filter returns T when called on the input. - -comint-get-old-input, comint-input-sentinel, and comint-input-filter are chosen -according to the command interpreter running in the buffer. E.g., -If the interpreter is the csh, - comint-get-old-input is the default: take the current line, discard any - initial string matching regexp comint-prompt-regexp. - comint-input-sentinel monitors input for \"cd\", \"pushd\", and \"popd\" - commands. When it sees one, it cd's the buffer. - comint-input-filter is the default: returns T if the input isn't all white - space. - -If the comint is Lucid Common Lisp, - comint-get-old-input snarfs the sexp ending at point. - comint-input-sentinel does nothing. - comint-input-filter returns NIL if the input matches input-filter-regexp, - which matches (1) all whitespace (2) :a, :c, etc. - -Similarly for Soar, Scheme, etc.." - (interactive) - ;; Note that the input string does not include its terminal newline. - (let ((proc (get-buffer-process (current-buffer)))) - (if (not proc) (error "Current buffer has no process") - (let* ((pmark (process-mark proc)) - (pmark-val (marker-position pmark)) - (input (if (>= (point) pmark-val) - (buffer-substring pmark (point)) - (let ((copy (funcall comint-get-old-input))) - (goto-char pmark) - (insert copy) - copy)))) - (insert ?\n) - (if (funcall comint-input-filter input) (ring-insert input-ring input)) - (funcall comint-input-sentinel input) - (process-send-string proc input) - (process-send-string proc "\n") - (set-marker (process-mark proc) (point)) - (set-marker comint-last-input-end (point)))))) - -(defun comint-get-old-input-default () - "Default for comint-get-old-input: take the current line, and discard -any initial text matching comint-prompt-regexp." - (save-excursion - (beginning-of-line) - (comint-skip-prompt) - (let ((beg (point))) - (end-of-line) - (buffer-substring beg (point))))) - -(defun comint-skip-prompt () - "Skip past the text matching regexp comint-prompt-regexp. -If this takes us past the end of the current line, don't skip at all." - (let ((eol (save-excursion (end-of-line) (point)))) - (if (and (looking-at comint-prompt-regexp) - (<= (match-end 0) eol)) - (goto-char (match-end 0))))) - - -(defun comint-after-pmark-p () - "Is point after the process output marker?" - ;; Since output could come into the buffer after we looked at the point - ;; but before we looked at the process marker's value, we explicitly - ;; serialise. This is just because I don't know whether or not emacs - ;; services input during execution of lisp commands. - (let ((proc-pos (marker-position - (process-mark (get-buffer-process (current-buffer)))))) - (<= proc-pos (point)))) - -(defun comint-bol (arg) - "Goes to the beginning of line, then skips past the prompt, if any. -If a prefix argument is given (\\[universal-argument]), then no prompt skip --- go straight to column 0. - -The prompt skip is done by skipping text matching the regular expression -comint-prompt-regexp, a buffer local variable. - -If you don't like this command, reset c-a to beginning-of-line -in your hook, comint-mode-hook." - (interactive "P") - (beginning-of-line) - (if (null arg) (comint-skip-prompt))) - -;;; These two functions are for entering text you don't want echoed or -;;; saved -- typically passwords to ftp, telnet, or somesuch. -;;; Just enter m-x send-invisible and type in your line. - -(defun comint-read-noecho (prompt) - "Prompt the user with argument PROMPT. Read a single line of text -without echoing, and return it. Note that the keystrokes comprising -the text can still be recovered (temporarily) with \\[view-lossage]. This -may be a security bug for some applications." - (let ((echo-keystrokes 0) - (answ "") - tem) - (if (and (stringp prompt) (not (string= (message prompt) ""))) - (message prompt)) - (while (not(or (= (setq tem (read-char)) ?\^m) - (= tem ?\n))) - (setq answ (concat answ (char-to-string tem)))) - (message "") - answ)) - -(defun send-invisible (str) - "Read a string without echoing, and send it to the process running -in the current buffer. A new-line is additionally sent. String is not -saved on comint input history list. -Security bug: your string can still be temporarily recovered with -\\[view-lossage]." -; (interactive (list (comint-read-noecho "Enter non-echoed text"))) - (interactive "P") ; Defeat snooping via C-x esc - (let ((proc (get-buffer-process (current-buffer)))) - (if (not proc) (error "Current buffer has no process") - (process-send-string proc - (if (stringp str) str - (comint-read-noecho "Enter non-echoed text"))) - (process-send-string proc "\n")))) - -;;; Random input hackage - -(defun comint-kill-output () - "Kill all output from interpreter since last input." - (interactive) - (let ((pmark (process-mark (get-buffer-process (current-buffer))))) - (kill-region comint-last-input-end pmark) - (goto-char pmark) - (insert "*** output flushed ***\n") - (set-marker pmark (point)))) - -(defun comint-show-output () - "Display start of this batch of interpreter output at top of window. -Also put cursor there." - (interactive) - (goto-char comint-last-input-end) - (backward-char) - (beginning-of-line) - (set-window-start (selected-window) (point)) - (end-of-line)) - -(defun comint-interrupt-subjob () - "Interrupt the current subjob." - (interactive) - (interrupt-process nil t)) - -(defun comint-kill-subjob () - "Send kill signal to the current subjob." - (interactive) - (kill-process nil t)) - -(defun comint-quit-subjob () - "Send quit signal to the current subjob." - (interactive) - (quit-process nil t)) - -(defun comint-stop-subjob () - "Stop the current subjob. -WARNING: if there is no current subjob, you can end up suspending -the top-level process running in the buffer. If you accidentally do -this, use \\[comint-continue-subjob] to resume the process. (This -is not a problem with most shells, since they ignore this signal.)" - (interactive) - (stop-process nil t)) - -(defun comint-continue-subjob () - "Send CONT signal to process buffer's process group. -Useful if you accidentally suspend the top-level process." - (interactive) - (continue-process nil t)) - -(defun comint-kill-input () - "Kill all text from last stuff output by interpreter to point." - (interactive) - (let* ((pmark (process-mark (get-buffer-process (current-buffer)))) - (p-pos (marker-position pmark))) - (if (> (point) p-pos) - (kill-region pmark (point))))) - -(defun comint-delchar-or-maybe-eof (arg) - "Delete ARG characters forward, or send an EOF to lisp if at end of buffer." - (interactive "p") - (if (eobp) - (process-send-eof) - (delete-char arg))) - - - - -;;; Support for source-file processing commands. -;;;============================================================================ -;;; Many command-interpreters (e.g., Lisp, Scheme, Soar) have -;;; commands that process files of source text (e.g. loading or compiling -;;; files). So the corresponding process-in-a-buffer modes have commands -;;; for doing this (e.g., lisp-load-file). The functions below are useful -;;; for defining these commands. -;;; -;;; Alas, these guys don't do exactly the right thing for Lisp, Scheme -;;; and Soar, in that they don't know anything about file extensions. -;;; So the compile/load interface gets the wrong default occasionally. -;;; The load-file/compile-file default mechanism could be smarter -- it -;;; doesn't know about the relationship between filename extensions and -;;; whether the file is source or executable. If you compile foo.lisp -;;; with compile-file, then the next load-file should use foo.bin for -;;; the default, not foo.lisp. This is tricky to do right, particularly -;;; because the extension for executable files varies so much (.o, .bin, -;;; .lbin, .mo, .vo, .ao, ...). - - -;;; COMINT-SOURCE-DEFAULT -- determines defaults for source-file processing -;;; commands. -;;; -;;; COMINT-CHECK-SOURCE -- if FNAME is in a modified buffer, asks you if you -;;; want to save the buffer before issuing any process requests to the command -;;; interpreter. -;;; -;;; COMINT-GET-SOURCE -- used by the source-file processing commands to prompt -;;; for the file to process. - -;;; (COMINT-SOURCE-DEFAULT previous-dir/file source-modes) -;;;============================================================================ -;;; This function computes the defaults for the load-file and compile-file -;;; commands for tea, soar, cmulisp, and cmuscheme modes. -;;; -;;; - PREVIOUS-DIR/FILE is a pair (directory . filename) from the last -;;; source-file processing command. NIL if there hasn't been one yet. -;;; - SOURCE-MODES is a list used to determine what buffers contain source -;;; files: if the major mode of the buffer is in SOURCE-MODES, it's source. -;;; Typically, (lisp-mode) or (scheme-mode). -;;; -;;; If the command is given in a file buffer whose major modes is in -;;; SOURCE-MODES, then the the filename is the default file, and the -;;; file's directory is the default directory. -;;; -;;; If the buffer isn't a source file buffer (e.g., it's the process buffer), -;;; then the default directory & file are what was used in the last source-file -;;; processing command (i.e., PREVIOUS-DIR/FILE). If this is the first time -;;; the command has been run (PREVIOUS-DIR/FILE is nil), the default directory -;;; is the cwd, with no default file. (\"no default file\" = nil) -;;; -;;; SOURCE-REGEXP is typically going to be something like (tea-mode) -;;; for T programs, (lisp-mode) for Lisp programs, (soar-mode lisp-mode) -;;; for Soar programs, etc. -;;; -;;; The function returns a pair: (default-directory . default-file). - -(defun comint-source-default (previous-dir/file source-modes) - (cond ((and buffer-file-name (memq major-mode source-modes)) - (cons (file-name-directory buffer-file-name) - (file-name-nondirectory buffer-file-name))) - (previous-dir/file) - (t - (cons default-directory nil)))) - - -;;; (COMINT-CHECK-SOURCE fname) -;;;============================================================================ -;;; Prior to loading or compiling (or otherwise processing) a file (in the CMU -;;; process-in-a-buffer modes), this function can be called on the filename. -;;; If the file is loaded into a buffer, and the buffer is modified, the user -;;; is queried to see if he wants to save the buffer before proceeding with -;;; the load or compile. - -(defun comint-check-source (fname) - (let ((buff (get-file-buffer fname))) - (if (and buff - (buffer-modified-p buff) - (y-or-n-p (format "Save buffer %s first? " - (buffer-name buff)))) - ;; save BUFF. - (let ((old-buffer (current-buffer))) - (set-buffer buff) - (save-buffer) - (set-buffer old-buffer))))) - - -;;; (COMINT-GET-SOURCE prompt prev-dir/file source-modes mustmatch-p) -;;;============================================================================ -;;; COMINT-GET-SOURCE is used to prompt for filenames in command-interpreter -;;; commands that process source files (like loading or compiling a file). -;;; It prompts for the filename, provides a default, if there is one, -;;; and returns the result filename. -;;; -;;; See COMINT-SOURCE-DEFAULT for more on determining defaults. -;;; -;;; PROMPT is the prompt string. PREV-DIR/FILE is the (directory . file) pair -;;; from the last source processing command. SOURCE-MODES is a list of major -;;; modes used to determine what file buffers contain source files. (These -;;; two arguments are used for determining defaults). If MUSTMATCH-P is true, -;;; then the filename reader will only accept a file that exists. -;;; -;;; A typical use: -;;; (interactive (comint-get-source "Compile file: " prev-lisp-dir/file -;;; "\\.lisp\\'" t)) - -(defun comint-get-source (prompt prev-dir/file source-regexp mustmatch-p) - (let* ((def (comint-source-default prev-dir/file source-regexp)) - (defdir (car def)) - (deffile (cdr def)) - (ans (read-file-name (if deffile (format "%s(default %s) " - prompt deffile) - prompt) - defdir - (concat defdir deffile) - mustmatch-p))) - (list (expand-file-name (substitute-in-file-name ans))))) - - -;;; Filename completion in a buffer -;;; =========================================================================== -;;; Useful completion functions, courtesy of the Ergo group. -;;; M-<Tab> will complete the filename at the cursor as much as possible -;;; M-? will display a list of completions in the help buffer. - -;;; Three commands: -;;; comint-dynamic-complete Complete filename at point. -;;; comint-dynamic-list-completions List completions in help buffer. -;;; comint-replace-by-expanded-filename Expand and complete filename at point; -;;; replace with expanded/completed name. - -;;; These are not installed in the comint-mode keymap. But they are -;;; available for people who want them. Shell-mode installs them: -;;; (define-key cmushell-mode-map "\M-\t" 'comint-dynamic-complete) -;;; (define-key cmushell-mode-map "\M-?" 'comint-dynamic-list-completions))) -;;; -;;; Commands like this are fine things to put in load hooks if you -;;; want them present in specific modes. Example: -;;; (setq cmushell-load-hook -;;; '((lambda () (define-key lisp-mode-map "\M-\t" -;;; 'comint-replace-by-expanded-filename)))) -;;; - - -(defun comint-match-partial-pathname () - "Returns the string of an existing filename or causes and error." - (if (save-excursion (backward-char 1) (looking-at "\\s ")) "" - (save-excursion - (re-search-backward "[^~/A-Za-z0-9---_.$#,]+") - (re-search-forward "[~/A-Za-z0-9---_.$#,]+") - (substitute-in-file-name - (buffer-substring (match-beginning 0) (match-end 0)))))) - -(defun comint-replace-by-expanded-filename () - "Replace filename at point with expanded, completed name" - (interactive) - (let* ((pathname (comint-match-partial-pathname)) - (pathdir (file-name-directory pathname)) - (pathnondir (file-name-nondirectory pathname)) - (completion (file-name-completion pathnondir - (or pathdir default-directory)))) - (cond ((null completion) - (message "No completions of %s." pathname) - (ding)) - ((eql completion t) - (message "Unique completion.")) - (t ; this means a string was returned. - (delete-region (match-beginning 0) (match-end 0)) - (insert pathdir completion))))) - -(defun comint-dynamic-complete () - "Dynamically complete the filename at point." - (interactive) - (let* ((pathname (comint-match-partial-pathname)) - (pathdir (file-name-directory pathname)) - (pathnondir (file-name-nondirectory pathname)) - (completion (file-name-completion pathnondir - (or pathdir default-directory)))) - (cond ((null completion) - (message "No completions of %s." pathname) - (ding)) - ((eql completion t) - (message "Unique completion.")) - (t ; this means a string was returned. - (insert (substring completion (length pathnondir))))))) - -(defun comint-dynamic-list-completions () - "List in help buffer all possible completions of the filename at point." - (interactive) - (let* ((pathname (comint-match-partial-pathname)) - (pathdir (file-name-directory pathname)) - (pathnondir (file-name-nondirectory pathname)) - (completions - (file-name-all-completions pathnondir - (or pathdir default-directory)))) - (cond ((null completions) - (message "No completions of %s." pathname) - (ding)) - (t (with-output-to-temp-buffer "*Help*" - (display-completion-list completions)))))) - -; Ergo bindings -; (global-set-key "\M-\t" 'comint-replace-by-expanded-filename) -; (global-set-key "\M-?" 'comint-dynamic-list-completions) -; (define-key shell-mode-map "\M-\t" 'comint-dynamic-complete) - -;;; Log the user, so I know who's using the package during the beta test -;;; period. This just inserts the user's name and current time into a -;;; central file. -(defun comint-log-user () - (interactive) - (if (file-writable-p "/afs/cs/user/shivers/lib/emacs/logdir/comint.log") - (let ((u (getenv "USER")) - (old-buff (current-buffer))) - (message "logging user in beta test database...") - (find-file "/afs/cs/user/shivers/lib/emacs/logdir/comint.log") - (cond ((search-forward u nil 'to-end) - (search-forward "| ") - (kill-line 1)) - (t (insert (format "%s\t%s\t| " u (current-time-string))))) - (insert (format "%s\n" (current-time-string))) - (let ((make-backup-files nil)) (save-buffer)) - (kill-buffer (current-buffer)) - (set-buffer old-buff)))) -(comint-log-user) - - -;;; Converting process modes to use comint mode -;;; =========================================================================== -;;; Several gnu packages (tex-mode, background, dbx, gdb, kermit, prolog, -;;; telnet are some) use the shell package as clients. Most of them would -;;; be better off using the comint package, but they predate it. -;;; -;;; Altering these packages to use comint mode should greatly -;;; improve their functionality, and is fairly easy. -;;; -;;; Renaming variables -;;; Most of the work is renaming variables and functions. These are the common -;;; ones: -;;; Local variables: -;;; last-input-end comint-last-input-end -;;; last-input-start <unnecessary> -;;; shell-prompt-pattern comint-prompt-regexp -;;; shell-set-directory-error-hook <no equivalent> -;;; Miscellaneous: -;;; shell-set-directory <unnecessary> -;;; shell-mode-map comint-mode-map -;;; Commands: -;;; shell-send-input comint-send-input -;;; shell-send-eof comint-delchar-or-maybe-eof -;;; kill-shell-input comint-kill-input -;;; interrupt-shell-subjob comint-interrupt-subjob -;;; stop-shell-subjob comint-stop-subjob -;;; quit-shell-subjob comint-quit-subjob -;;; kill-shell-subjob comint-kill-subjob -;;; kill-output-from-shell comint-kill-output -;;; show-output-from-shell comint-show-output -;;; copy-last-shell-input Use comint-previous-input/comint-next-input -;;; -;;; LAST-INPUT-START is no longer necessary because inputs are stored on the -;;; input history ring. SHELL-SET-DIRECTORY is gone, its functionality taken -;;; over by SHELL-DIRECTORY-TRACKER, the shell mode's comint-input-sentinel. -;;; Comint mode does not provide functionality equivalent to -;;; shell-set-directory-error-hook; it is gone. -;;; -;;; If you are implementing some process-in-a-buffer mode, called foo-mode, do -;;; *not* create the comint-mode local variables in your foo-mode function. -;;; This is not modular. Instead, call comint-mode, and let *it* create the -;;; necessary comint-specific local variables. Then create the -;;; foo-mode-specific local variables in foo-mode. Set the buffer's keymap to -;;; be foo-mode-map, and it's mode to be foo-mode. Set the comint-mode hooks -;;; (comint-prompt-regexp, comint-input-filter, comint-input-sentinel, -;;; comint-get-old-input) that need to be different from the defaults. Call -;;; foo-mode-hook, and you're done. Don't run the comint-mode hook yourself; -;;; comint-mode will take care of it. The following example, from cmushell.el, -;;; is typical: -;;; -;;; (defun shell-mode () -;;; (interactive) -;;; (comint-mode) -;;; (setq comint-prompt-regexp shell-prompt-pattern) -;;; (setq major-mode 'shell-mode) -;;; (setq mode-name "Shell") -;;; (cond ((not shell-mode-map) -;;; (setq shell-mode-map (full-copy-sparse-keymap comint-mode-map)) -;;; (define-key shell-mode-map "\M-\t" 'comint-dynamic-complete) -;;; (define-key shell-mode-map "\M-?" -;;; 'comint-dynamic-list-completions))) -;;; (use-local-map shell-mode-map) -;;; (make-local-variable 'shell-directory-stack) -;;; (setq shell-directory-stack nil) -;;; (setq comint-input-sentinel 'shell-directory-tracker) -;;; (run-hooks 'shell-mode-hook)) -;;; -;;; -;;; Note that make-comint is different from make-shell in that it -;;; doesn't have a default program argument. If you give make-shell -;;; a program name of NIL, it cleverly chooses one of explicit-shell-name, -;;; $ESHELL, $SHELL, or /bin/sh. If you give make-comint a program argument -;;; of NIL, it barfs. Adjust your code accordingly... -;;; - -;;; Do the user's customisation... - -(defvar comint-load-hook nil - "This hook is run when comint is loaded in. -This is a good place to put keybindings.") - -(run-hooks 'comint-load-hook)
--- a/lisp/ilisp/completer.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1026 +0,0 @@ -;;; -*-Emacs-Lisp-*- -;;;%Header -;;; -;;; Rcs_Info: completer.el,v 3.23 1993/09/03 02:05:07 ivan Rel $ -;;; -;;; Partial completion mechanism for GNU Emacs. Version 3.03 -;;; Copyright (C) 1990, 1991, 1992 Chris McConnell, ccm@cs.cmu.edu. -;;; Thanks to Bjorn Victor for suggestions, testing, and patches for -;;; file completion. - -;;; This file is part of GNU Emacs. - -;;; GNU Emacs is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY. No author or distributor -;;; accepts responsibility to anyone for the consequences of using it -;;; or for whether it serves any particular purpose or works at all, -;;; unless he says so in writing. Refer to the GNU Emacs General Public -;;; License for full details. -;;; Everyone is granted permission to copy, modify and redistribute -;;; GNU Emacs, but only under the conditions described in the -;;; GNU Emacs General Public License. A copy of this license is -;;; supposed to have been given to you along with GNU Emacs so you -;;; can know your rights and responsibilities. It should be in a -;;; file named COPYING. Among other things, the copyright notice -;;; and this notice must be preserved on all copies. - -;;; When loaded, this file extends the standard completion mechanisms -;;; so that they perform pattern matching completions. There is also -;;; an interface that allows it to be used by other programs. The -;;; completion rules are: -;;; -;;; 1) If what has been typed matches any possibility, do normal -;;; completion. -;;; -;;; 2) Otherwise, generate a regular expression such that -;;; completer-words delimit words and generate all possible matches. -;;; The variable completer-any-delimiter can be set to a character -;;; that matches any delimiter. If it were " ", then "by d" would be -;;; byte-recompile-directory. If completer-use-words is T, a match is -;;; unique if it is the only one with the same number of words. If -;;; completer-use-words is NIL, a match is unique if it is the only -;;; possibility. If you ask the completer to use its best guess, it -;;; will be the shortest match of the possibilities unless -;;; completer-exact is T. -;;; -;;; 3) For filenames, if completer-complete-filenames is T, each -;;; pathname component will be individually completed, otherwise only -;;; the final component will be completed. If you are using a -;;; distributed file system like afs, you may want to set up a -;;; symbolic link in your home directory or add pathname components to -;;; completer-file-skip so that the pathname components that go across -;;; machines do not get expanded. -;;; -;;; SPACE, TAB, LFD, RET, and ? do normal completion if possible -;;; otherwise they do partial completion. In addition, C-DEL will -;;; undo the last partial expansion or contraction. M-RET will always -;;; complete to the current match before returning. This is useful -;;; when any string is possible, but you want to complete to a string -;;; as when calling find-file. The bindings can be changed by using -;;; completer-load-hook. -;;; -;;; Modes that use comint-dynamic-complete (like cmushell and ilisp) -;;; will also do partial completion as will M-tab in Emacs LISP. -;;; -;;; Examples: -;;; a-f auto-fill-mode -;;; b--d *beginning-of-defun or byte-recompile-directory -;;; by d *byte-recompile-directory if completer-any-delimiter is " " -;;; ~/i.e *~/ilisp.el or ~/il-el.el or ~/ilisp.elc -;;; /u/mi/ /usr/misc/ -;;; - - -(require 'cl) - -;;;%Globals -;;;%%Switches -(defvar completer-load-hook nil - "Hook called when minibuffer partial completion is loaded.") - -(defvar completer-disable nil - "*If T, turn off partial completion. Use the command -\\[completer-toggle] to set this.") - -(defvar completer-complete-filenames t - "*If T, then each component of a filename will be completed, -otherwise just the final component will be completed.") - -(defvar completer-use-words nil ; jwz: this is HATEFUL! - "*If T, then prefer completions with the same number of words as the -pattern.") - -(defvar completer-words "---. <" - "*Delimiters used in partial completions. It should be a set of -characters suitable for inclusion in a [] regular expression.") - -(defvar completer-any-delimiter nil - "*If a character, then a delimiter in the pattern that matches the -character will match any delimiter in completer-words.") - -(defvar completer-file-skip "^cs/$\\|@sys\\|.edu/$\\|.gov/$\\|.com/$\\|:/$" - "*Regular expression for pathname components to not complete.") - -(defvar completer-exact nil - "*If T, then you must have an exact match. Otherwise, the shortest -string that matches the pattern will be used.") - -(defvar completer-cache-size 100 - "*Size of cache to use for partially completed pathnames.") - -(defvar completer-use-cache t - "*Set to nil to disable the partially completed pathname cache.") - -;;;%%Internal -(defvar completer-last-pattern "" - "The last pattern expanded.") - -(defvar completer-message nil - "T if temporary message was just displayed.") - -(defvar completer-path-cache nil - "Cache of (path . choices) for completer.") - -(defvar completer-string nil "Last completer string.") -(defvar completer-table nil "Last completer table.") -(defvar completer-pred nil "Last completer pred.") -(defvar completer-mode nil "Last completer mode.") -(defvar completer-result nil "Last completer result.") - -(eval-when (eval load compile) - (if (not (fboundp 'completion-display-completion-list-function)) - (setf completion-display-completion-list-function - 'display-completion-list))) - - -;;;%Utilities -(defun completer-message (message &optional point) - "Display MESSAGE at optional POINT for two seconds." - (setq point (or point (point-max)) - completer-message t) - (let ((end - (save-excursion - (goto-char point) - (insert message) - (point))) - (inhibit-quit t)) - (sit-for 2) - (delete-region point end) - (if (and quit-flag - ;;(not (eq 'lucid-19 ilisp-emacs-version-id)) - (not (string-match "Lucid" emacs-version)) - ) - (setq quit-flag nil - unread-command-char 7)))) - -;;; -(defun completer-deleter (regexp choices &optional keep) - "Destructively remove strings that match REGEXP in CHOICES and -return the modified list. If optional KEEP, then keep entries that -match regexp." - (let* ((choiceb choices) - choicep) - (if keep - (progn - (while (and choiceb (not (string-match regexp (car choiceb)))) - (setq choiceb (cdr choiceb))) - (setq choicep choiceb) - (while (cdr choicep) - (if (string-match regexp (car (cdr choicep))) - (setq choicep (cdr choicep)) - (rplacd choicep (cdr (cdr choicep)))))) - (while (and choiceb (string-match regexp (car choiceb))) - (setq choiceb (cdr choiceb))) - (setq choicep choiceb) - (while (cdr choicep) - (if (string-match regexp (car (cdr choicep))) - (rplacd choicep (cdr (cdr choicep))) - (setq choicep (cdr choicep))))) - choiceb)) - -;;;%%Regexp -(defun completer-regexp (string delimiters any) - "Convert STRING into a regexp with words delimited by characters in -DELIMITERS. Any delimiter in STRING that is the same as ANY will -match any delimiter." - (let* ((delimiter-reg (concat "[" delimiters "]")) - (limit (length string)) - (pos 0) - (regexp "^")) - (while (and (< pos limit) (string-match delimiter-reg string pos)) - (let* ((begin (match-beginning 0)) - (end (match-end 0)) - (delimiter (substring string begin end)) - (anyp (eq (elt string begin) any))) - (setq regexp - (format "%s%s[^%s]*%s" - regexp - (regexp-quote (substring string pos begin)) - (if anyp delimiters delimiter) - (if anyp delimiter-reg (regexp-quote delimiter))) - pos end))) - (if (<= pos limit) - (setq regexp (concat regexp - (regexp-quote (substring string pos limit))))))) - -;;; -(defun completer-words (regexp string &optional limit) - "Return the number of words matching REGEXP in STRING up to LIMIT." - (setq limit (or limit 1000)) - (let ((count 1) - (pos 0)) - (while (and (string-match regexp string pos) (<= count limit)) - (setq count (1+ count) - pos (match-end 0))) - count)) - -;;;%Matcher -(defun completer-matches (string choices delimiters any) - "Return STRING's matches in CHOICES using DELIMITERS and wildcard -ANY to segment the strings." - (let* ((regexp (concat "[" delimiters "]")) - (from nil) - (to 0) - (pattern nil) - (len (length string)) - (matches nil) - sub sublen choice word wordlen pat) - ;; Segment pattern - (while (< (or from 0) len) - (setq to (or (string-match regexp string (if from (1+ from))) len)) - (if (eq (elt string (or from 0)) completer-any-delimiter) - (setq sub (substring string (if from (1+ from) 0) to) - sublen (- (length sub))) - (setq sub (substring string (or from 0) to) - sublen (length sub))) - (setq pattern (cons (cons sub sublen) pattern) - from to)) - (setq pattern (reverse pattern)) - ;; Find choices that match patterns - (setq regexp (concat "[" delimiters "]")) - (while choices - (setq choice (car choices) - word pattern - from 0) - (while (and word from - (let* (begin end) - (if (< (setq wordlen (cdr (setq pat (car word)))) 0) - (setq begin (1+ from) - end (+ begin (- wordlen))) - (setq begin from - end (+ begin wordlen))) - (and (<= end (length choice)) - (or (zerop wordlen) - (string-equal - (car pat) - (substring choice begin end)))))) - (setq from (string-match regexp choice - (if (and (zerop from) (zerop wordlen)) - from - (1+ from))) - word (cdr word))) - (if (not word) (setq matches (cons choice matches))) - (setq choices (cdr choices))) - matches)) - -;;; -(defun completer-choice (string choices delimiters use-words) - "Return the best match of STRING in CHOICES with DELIMITERS between -words and T if it is unique. A match is unique if it is the only -possibility or when USE-WORDS the only possibility with the same -number of words. The shortest string of multiple possibilities will be -the best match." - (or (if (null (cdr choices)) (cons (car choices) t)) - (let* ((regexp (concat "[^" delimiters "]*[" delimiters "]")) - (words (if use-words (completer-words regexp string))) - (choice choices) - (unique-p nil) - (match nil) - (match-count nil) - (match-len 1000)) - (while choice - (let* ((current (car choice)) - (length (length current))) - (if match-count - (if (= (completer-words regexp current words) words) - (progn - (setq unique-p nil) - (if (< length match-len) - (setq match current - match-len length)))) - (if (and use-words - (= (completer-words regexp current words) words)) - (setq match current - match-len length - match-count t - unique-p t) - (if (< length match-len) - (setq match current - match-len length))))) - (setq choice (cdr choice))) - (cons match unique-p)))) - -;;;%Completer -;;;%%Utilities -(defun completer-region (delimiters) - "Return the completion region bounded by characters in DELIMITERS -for the current buffer assuming that point is in it." - (cons (save-excursion (skip-chars-backward delimiters) (point)) - (save-excursion (skip-chars-forward delimiters) (point)))) - -;;; -(defun completer-last-component (string) - "Return the start of the last filename component in STRING." - (let ((last (1- (length string)) ) - (match 0) - (end 0)) - (while (and (setq match (string-match "/" string end)) (< match last)) - (setq end (1+ match))) - end)) - -;;; -(defun completer-match-record (string matches delimiters any dir mode) - "Return (match lcs choices unique) for STRING in MATCHES with -DELIMITERS or ANY wildcards and DIR if a filename when in MODE." - (let ((pattern (if dir - (substring string (completer-last-component string)) - string)) - match) - (setq matches (completer-matches pattern matches delimiters any) - match (try-completion pattern (mapcar 'list matches))) - ;; If try-completion produced an exact match for an element in 'matches', - ;; then remove any partial matches from 'matches' and set the unique - ;; match flag. - (and (stringp match) (member match matches) (setq matches (list match))) - (if (cdr matches) - (let ((lcs (concat dir (try-completion "" (mapcar 'list matches))))) - (setq match (if (not completer-exact) - (completer-choice - pattern matches delimiters completer-use-words))) - (list (if match (concat dir (car match))) - lcs - matches - (cdr match))) - (if matches - (progn (setq match (concat dir (car matches))) - (list match match matches t)) - (list nil nil nil nil))))) - -;;;%%Complete file -(defun completer-extension-regexp (extensions) - "Return a regexp that matches to a string that ends with any string from EXTENSIONS list." - (concat "\\(" (mapconcat 'regexp-quote extensions "\\|") "\\)\\'")) - -;;; -(defun completer-flush () - "Flush completer's pathname cache." - (interactive) - (setq completer-path-cache nil)) - -;;; -(defun completer-cache (path pred words any mode) - "Check to see if PATH is in path cache with PRED, WORDS, ANY and -MODE." - (let* ((last nil) - (ptr completer-path-cache) - (size 0) - (result nil)) - (if completer-use-cache - (while ptr - (let ((current (car (car ptr)))) - (if (string-equal current path) - (progn - (if last - (progn - (rplacd last (cdr ptr)) - (rplacd ptr completer-path-cache) - (setq completer-path-cache ptr))) - (setq result (cdr (car ptr)) - ptr nil)) - (if (cdr ptr) (setq last ptr)) - (setq size (1+ size) - ptr (cdr ptr)))))) - (or result - (let* ((choices - (completer path 'read-file-name-internal pred words any - mode t))) - (if (and (or (car (cdr (cdr (cdr choices)))) - (string= path (car choices))) - (eq (elt (car choices) (1- (length (car choices)))) ?/)) - (progn - (if (>= size completer-cache-size) (rplacd last nil)) - (setq completer-path-cache - (cons (cons path choices) completer-path-cache)))) - choices)))) - -;;; -(defun completer-file (string pred words any mode) - "Return (match common-substring matches unique-p) for STRING using -read-file-name-internal for choices that pass PRED using WORDS to -delimit words. Optional ANY is a delimiter that matches any of the -delimiters in WORD. If optional MODE is nil or 'help then possible -matches will always be returned." - (let* ((case-fold-search completion-ignore-case) - (last (and (eq mode 'exit-ok) (completer-last-component string))) - (position - ;; Special hack for CMU RFS filenames - (if (string-match "^/\\.\\./[^/]*/" string) - (match-end 0) - (string-match "[^~/]" string))) - (new (substring string 0 position)) - (user (if (string= new "~") - (setq new (file-name-directory (expand-file-name new))))) - (words (concat words "/")) - (len (length string)) - (choices nil) - end - (old-choices (list nil nil nil nil))) - (while position - (let* ((begin (string-match "/" string position)) - (exact-p nil)) - (setq end (if begin (match-end 0)) - choices - ;; Ends with a /, so check files in directory - (if (and (memq mode '(nil help)) (= position len)) - (completer-match-record - "" - ;; This assumes that .. and . come at the end - (let* ((choices - (all-completions new 'read-file-name-internal)) - (choicep choices)) - (if (string= (car choicep) "../") - (cdr (cdr choicep)) - (while (cdr choicep) - (if (string= (car (cdr choicep)) "../") - (rplacd choicep nil)) - (setq choicep (cdr choicep))) - choices)) - words any new mode) - (if (eq position last) - (let ((new (concat new (substring string position)))) - (list new new nil t)) - (let ((component (substring string position end))) - (if (and end - (string-match completer-file-skip component)) - ;; Assume component is complete - (list (concat new component) - (concat new component) - nil t) - (completer-cache - (concat new component) - pred words any mode)))))) - ;; Keep going if unique or we match exactly - (if (or (car (cdr (cdr (cdr choices)))) - (setq exact-p - (string= (concat new (substring string position end)) - (car choices)))) - (setq old-choices - (let* ((lcs (car (cdr choices))) - (matches (car (cdr (cdr choices)))) - (slash (and lcs (string-match "/$" lcs)))) - (list nil - (if slash (substring lcs 0 slash) lcs) - (if (and (cdr matches) - (or (eq mode 'help) (not exact-p))) - matches) - nil)) - new (car choices) - position end) - ;; Its ok to not match user names because they may be in - ;; different root directories - (if (and (= position 1) (= (elt string 0) ?~)) - (setq new (substring string 0 end) - choices (list new new (list new) t) - user nil - position end) - (setq position nil))))) - (if (not (car choices)) - (setq choices old-choices)) - (if (and (car choices) - (not (eq mode 'help)) - (not (car (cdr (cdr (cdr choices)))))) - ;; Try removing completion ignored extensions - (let* ((extensions - (completer-extension-regexp completion-ignored-extensions)) - (choiceb (car (cdr (cdr choices)))) - (choicep choiceb) - (isext nil) - (noext nil)) - (while choicep - (if (string-match extensions (car choicep)) - (setq isext t) - (setq noext t)) - (if (and isext noext) - ;; There are matches besides extensions - (setq choiceb (completer-deleter extensions choiceb) - choicep nil) - (setq choicep (cdr choicep)))) - (if (and isext noext) - (setq choices - (completer-match-record - (if end (substring string end) "") - choiceb words any - (file-name-directory (car (cdr choices))) - mode))))) - (if user - (let ((match (car choices)) - (lcs (car (cdr choices))) - (len (length user))) - (setq choices - (cons (if match (concat "~" (substring match len))) - (cons (if lcs (concat "~" (substring lcs len))) - (cdr (cdr choices))))))) - choices)) - -;;;%Exported program interface -;;;%%Completer -(defun completer (string table pred words - &optional any mode file-p) - "Return (match common-substring matches unique-p) for STRING in -TABLE for choices that pass PRED using WORDS to delimit words. If the -flag completer-complete-filenames is T and the table is -read-file-name-internal, then filename components will be individually -expanded. Optional ANY is a delimiter that can match any delimiter in -WORDS. Optional MODE is nil for complete, 'help for help and 'exit -for exit." - (if (and (stringp completer-string) - (string= string completer-string) - (eq table completer-table) - (eq pred completer-pred) - (not file-p) - (or (eq mode completer-mode) - (not (memq table '(read-file-name-internal - read-directory-name-internal))))) - completer-result - (setq - completer-string "" - completer-table table - completer-pred pred - completer-mode mode - completer-result - (if (and completer-complete-filenames - (not file-p) (eq table 'read-file-name-internal)) - (completer-file string pred words any mode) - (let* ((file-p (or file-p (eq table 'read-file-name-internal))) - (case-fold-search completion-ignore-case) - (pattern (concat "[" words "]")) - (component (if file-p (completer-last-component string))) - (dir (if component (substring string 0 component))) - (string (if dir (substring string component) string)) - (has-words (or (string-match pattern string) - (length string)))) - (if (and file-p (string-match "^\\$" string)) - ;; Handle environment variables - (let ((match - (getenv (substring string 1 - (string-match "/" string))))) - (if match (setq match (concat match "/"))) - (list match match (list match) match)) - (let* ((choices - (all-completions - (concat dir (substring string 0 has-words)) - table pred)) - (regexp (completer-regexp string words any))) - (if choices - (completer-match-record - string - (completer-deleter regexp choices t) - words any dir mode) - (list nil nil nil nil)))))) - completer-string string) - completer-result)) - -;;;%%Display choices -(defun completer-display-choices (choices &optional match message end - display) - "Display the list of possible CHOICES with optional MATCH, MESSAGE, -END and DISPLAY. If MATCH is non-nil, it will be flagged as the best -guess. If there are no choices, display MESSAGE. END is where to put -temporary messages. If DISPLAY is present then it will be called on -each possible completion and should return a string." - (if choices - (with-output-to-temp-buffer "*Completions*" - (if (cdr choices) - (funcall completion-display-completion-list-function - (sort - (if display - (let ((old choices) - (new nil)) - (while old - (setq new (cons (funcall display (car old)) new) - old (cdr old))) - new) - (copy-sequence choices)) - (function (lambda (x y) - (string-lessp (or (car-safe x) x) - (or (car-safe y) y))))))) - (if match - (save-excursion - (set-buffer "*Completions*") - (goto-char (point-min)) - (let ((buffer-read-only nil)) - (insert "Guess = " match (if (cdr choices) ", " "") "\n"))))) - (beep) - (completer-message (or message " (No completions)") end))) - -;;;%%Goto -(defun completer-goto (match lcs choices unique delimiters words - &optional mode display) - "MATCH is the best match, LCS is the longest common substring of all -of the matches. CHOICES is a list of the possibilities, UNIQUE -indicates if MATCH is unique. DELIMITERS are possible bounding -characters for the completion region. WORDS are the characters that -delimit the words for partial matches. Replace the region bounded by -delimiters with the match if unique and the lcs otherwise unless -optional MODE is 'help. Then go to the part of the string that -disambiguates choices using WORDS to separate words and display the -possibilities if the string was not extended. If optional DISPLAY is -present then it will be called on each possible completion and should -return a string." - (setq completer-message nil) - (let* ((region (completer-region delimiters)) - (start (car region)) - (end (cdr region)) - (string (buffer-substring start end)) - (file-p (string-match "[^ ]*\\(~\\|/\\|$\\)" string)) - (no-insert (eq mode 'help)) - (message t) - (new (not (string= (buffer-substring start (point)) lcs)))) - (if unique - (if no-insert - (progn - (goto-char end) - (completer-display-choices choices match nil end display)) - (if (string= string match) - (if (not file-p) - (progn (goto-char end) - (completer-message " (Sole completion)" end))) - (completer-insert match delimiters))) - ;;Not unique - (if lcs - (let* ((regexp - (concat "[" words (if file-p "/") "]")) - (words (completer-words regexp lcs)) - point) - ;; Go to where its ambiguous - (goto-char start) - (if (not no-insert) - (progn - (insert lcs) - (setq completer-last-pattern - (list string delimiters (current-buffer) start) - start (point) - end (+ end (length lcs))))) - ;; Skip to the first delimiter in the original string - ;; beyond the ambiguous point and keep from there on - (if (re-search-forward regexp end 'move words) - (progn - (if (and (not no-insert) match) - (let ((delimiter - (progn - (string-match (regexp-quote lcs) match) - (substring match (match-end 0) - (1+ (match-end 0)))))) - (if (string-match regexp delimiter) - (insert delimiter)))) - (forward-char -1))) - (if (not no-insert) - (progn - (setq end (- end (- (point) start))) - (delete-region start (point)))))) - (if choices - (if (or no-insert (not new)) - (completer-display-choices choices match nil end display)) - (if file-p - (progn - (if (not (= (point) end)) (forward-char 1)) - (if (not (save-excursion (re-search-forward "/" end t))) - (goto-char end)))) - (if message - (progn - (beep) - (completer-message (if no-insert - " (No completions)" - " (No match)") - end))))))) - -;;;%Exported buffer interface -;;;%%Complete and go -(defun completer-complete-goto (delimiters words table pred - &optional no-insert display) - "Complete the string bound by DELIMITERS using WORDS to bound words -for partial matches in TABLE with PRED and then insert the longest -common substring unless optional NO-INSERT and go to the point of -ambiguity. If optional DISPLAY, it will be called on each match when -possible completions are shown and should return a string." - (let* ((region (completer-region delimiters))) - (apply 'completer-goto - (append (completer (buffer-substring (car region) (cdr region)) - table pred words completer-any-delimiter - no-insert) - (list delimiters words no-insert display))))) - -;;;%%Undo -(defun completer-insert (match delimiters &optional buffer undo) - "Replace the region bounded with characters in DELIMITERS by MATCH -and save it so that it can be restored by completer-undo." - (let* ((region (completer-region delimiters)) - (start (car region)) - (end (cdr region))) - (if (and undo (or (not (= start undo)) - (not (eq (current-buffer) buffer)))) - (error "No previous pattern") - (setq completer-last-pattern (list (buffer-substring start end) - delimiters - (current-buffer) - start)) - (delete-region start end) - (goto-char start) - (insert match)))) - -;;; -(defun completer-undo () - "Swap the last expansion and the last match pattern." - (interactive) - (if completer-last-pattern - (apply 'completer-insert completer-last-pattern) - (error "No previous pattern"))) - -;;;%Minibuffer specific code -;;;%%Utilities -(defun completer-minibuf-string () - "Remove dead filename specs from the minibuffer as delimited by // -or ~ or $ and return the resulting string." - (save-excursion - (goto-char (point-max)) - (if (and (eq minibuffer-completion-table 'read-file-name-internal) - (re-search-backward "//\\|/~\\|.\\$" nil t)) - (delete-region (point-min) (1+ (point)))) - (buffer-substring (point-min) (point-max)))) - -;;; -(defun completer-minibuf-exit () - "Exit the minibuffer and clear completer-last-pattern." - (interactive) - (setq completer-last-pattern nil) - (exit-minibuffer)) - -;;; -(defun completer-new-cmd (cmd) - "Return T if we can't execute the old minibuffer version of CMD." - (if (or completer-disable - (let ((string (completer-minibuf-string))) - (or - (not (string-match - (concat "[" completer-words "/~]") - string)) - (condition-case () - (let ((completion - (try-completion string - minibuffer-completion-table - minibuffer-completion-predicate))) - (if (eq minibuffer-completion-table - 'read-file-name-internal) - ;; Directories complete as themselves - (and completion - (or (not (string= string completion)) - (file-exists-p completion))) - completion)) - (error nil))))) - (progn - (funcall cmd) - nil) - t)) - -;;; -(defun completer-minibuf (&optional mode) - "Partial completion of minibuffer expressions. Optional MODE is -'help for help and 'exit for exit. - -If what has been typed so far matches any possibility normal -completion will be done. Otherwise, the string is considered to be a -pattern with words delimited by the characters in -completer-words. If completer-exact is T, the best match will be -the shortest one with the same number of words as the pattern if -possible and otherwise the shortest matching expression. If called -with a prefix, caching will be temporarily disabled. - -Examples: -a-f auto-fill-mode -r-e rmail-expunge -b--d *begining-of-defun or byte-recompile-directory -by d *byte-recompile-directory if completer-any-delimiter is \" \" -~/i.e *~/ilisp.el or ~/il-el.el or ~/ilisp.elc -/u/mi/ /usr/misc/" - (interactive) - (append - (let ((completer-use-cache (not (or (not completer-use-cache) - current-prefix-arg)))) - (completer (completer-minibuf-string) - minibuffer-completion-table - minibuffer-completion-predicate - completer-words - completer-any-delimiter - mode)) - (list "^" completer-words mode))) - -;;;%%Commands -(defun completer-toggle () - "Turn partial completion on or off." - (interactive) - (setq completer-disable (not completer-disable)) - (message (if completer-disable - "Partial completion OFF" - "Partial completion ON"))) - -;;; -(defvar completer-old-help - (lookup-key minibuffer-local-must-match-map "?") - "Old binding of ? in minibuffer completion map.") -(defun completer-help () - "Partial completion minibuffer-completion-help. -See completer-minibuf for more information." - (interactive) - (if (completer-new-cmd completer-old-help) - (apply 'completer-goto (completer-minibuf 'help)))) - -;;; -(defvar completer-old-completer - (lookup-key minibuffer-local-must-match-map "\t") - "Old binding of TAB in minibuffer completion map.") -(defun completer-complete () - "Partial completion minibuffer-complete. -See completer-minibuf for more information." - (interactive) - (if (completer-new-cmd completer-old-completer) - (apply 'completer-goto (completer-minibuf)))) - -;;; -(defvar completer-old-word - (lookup-key minibuffer-local-must-match-map " ") - "Old binding of SPACE in minibuffer completion map.") -(defun completer-word () - "Partial completion minibuffer-complete. -See completer-minibuf for more information." - (interactive) - (if (eq completer-any-delimiter ?\ ) - (insert ?\ ) - (if (completer-new-cmd completer-old-word) - (apply 'completer-goto (completer-minibuf))))) - -;;; -(defvar completer-old-exit - (lookup-key minibuffer-local-must-match-map "\n") - "Old binding of RET in minibuffer completion map.") -(defun completer-exit () - "Partial completion minibuffer-complete-and-exit. -See completer-minibuf for more information." - (interactive) - (if (completer-new-cmd completer-old-exit) - (let* ((completions (completer-minibuf 'exit)) - (match (car completions)) - (unique-p (car (cdr (cdr (cdr completions)))))) - (apply 'completer-goto completions) - (if unique-p - (completer-minibuf-exit) - (if match - (progn (completer-insert match "^") - (if minibuffer-completion-confirm - (completer-message " (Confirm)") - (completer-minibuf-exit))) - (if (not completer-message) (beep))))))) - -;;; -(defun completer-match-exit () - "Exit the minibuffer with the current best match." - (interactive) - (let* ((completions (completer-minibuf 'exit)) - (guess (car completions))) - (if (not guess) - ;; OK if last filename component doesn't match - (setq completions (completer-minibuf 'exit-ok) - guess (car completions))) - (if guess - (progn - (goto-char (point-min)) - (insert guess) - (delete-region (point) (point-max)) - (exit-minibuffer)) - (apply 'completer-goto completions)))) - -;;;%%Keymaps -;this interferes with normal undo. -;(define-key minibuffer-local-completion-map "\C-_" 'completer-undo) -(define-key minibuffer-local-completion-map "\t" 'completer-complete) -(define-key minibuffer-local-completion-map " " 'completer-word) -(define-key minibuffer-local-completion-map "?" 'completer-help) -(define-key minibuffer-local-completion-map "\n" 'completer-minibuf-exit) -(define-key minibuffer-local-completion-map "\r" 'completer-minibuf-exit) -(define-key minibuffer-local-completion-map "\M-\n" 'completer-match-exit) -(define-key minibuffer-local-completion-map "\M-\r" 'completer-match-exit) - -;this interferes with normal undo. -;(define-key minibuffer-local-must-match-map "\C-_" 'completer-undo) -(define-key minibuffer-local-must-match-map "\t" 'completer-complete) -(define-key minibuffer-local-must-match-map " " 'completer-word) -(define-key minibuffer-local-must-match-map "\n" 'completer-exit) -(define-key minibuffer-local-must-match-map "\r" 'completer-exit) -(define-key minibuffer-local-must-match-map "?" 'completer-help) -(define-key minibuffer-local-must-match-map "\M-\n" 'completer-match-exit) -(define-key minibuffer-local-must-match-map "\M-\r" 'completer-match-exit) - -;;;%comint -(defun completer-comint-dynamic-list-completions (completions) - "List in help buffer sorted COMPLETIONS. -Typing SPC flushes the help buffer." - (completer-comint-dynamic-complete-1 nil 'help)) - -(defun completer-comint-dynamic-complete-filename () - "Dynamically complete the filename at point." - (interactive) - (completer-comint-dynamic-complete-1 nil t)) - -;;; -(defun completer-comint-dynamic-complete-1 (&optional undo mode) - "Complete the previous filename or display possibilities if done -twice in a row. If called with a prefix, undo the last completion." - (interactive "P") - (if undo - (completer-undo) - ;; added by jwz: don't cache completions in shell buffer! - (setq completer-string nil) - (let ((conf (current-window-configuration)));; lemacs change - (completer-complete-goto - "^ \t\n\"" - completer-words - 'read-file-name-internal - default-directory - mode) - ;; lemacs change - (if (eq mode 'help) (comint-restore-window-config conf)) - ))) -;(fset 'comint-dynamic-complete 'completer-comint-dynamic-complete) -(fset 'comint-dynamic-complete-filename - 'completer-comint-dynamic-complete-filename) -(fset 'comint-dynamic-list-completions - 'completer-comint-dynamic-list-completions) - -;;; Set the functions again if comint is loaded -(setq comint-load-hook - (cons (function (lambda () -;; (fset 'comint-dynamic-complete -;; 'completer-comint-dynamic-complete) - (fset 'comint-dynamic-complete-filename - 'completer-comint-dynamic-complete-filename) - (fset 'comint-dynamic-list-completions - 'completer-comint-dynamic-list-completions))) - (if (and (boundp 'comint-load-hook) comint-load-hook) - (if (consp comint-load-hook) - (if (eq (car comint-load-hook) 'lambda) - (list comint-load-hook) - comint-load-hook) - (list comint-load-hook))))) - -;;;%lisp-complete-symbol -(defun lisp-complete-symbol (&optional mode) - "Perform partial completion on Lisp symbol preceding point. That -symbol is compared against the symbols that exist and any additional -characters determined by what is there are inserted. If the symbol -starts just after an open-parenthesis, only symbols with function -definitions are considered. Otherwise, all symbols with function -definitions, values or properties are considered. If called with a -negative prefix, the last completion will be undone." - (interactive "P") - (if (< (prefix-numeric-value mode) 0) - (completer-undo) - (let* ((end (save-excursion (skip-chars-forward "^ \t\n)]}\"") (point))) - (beg (save-excursion - (backward-sexp 1) - (while (= (char-syntax (following-char)) ?\') - (forward-char 1)) - (point))) - (pattern (buffer-substring beg end)) - (predicate - (if (eq (char-after (1- beg)) ?\() - 'fboundp - (function (lambda (sym) - (or (boundp sym) (fboundp sym) - (symbol-plist sym)))))) - (completion (try-completion pattern obarray predicate))) - (cond ((eq completion t)) - ((null completion) - (completer-complete-goto - "^ \t\n\(\)[]{}'`" completer-words - obarray predicate - nil - (if (not (eq predicate 'fboundp)) - (function (lambda (choice) - (if (fboundp (intern choice)) - (list choice " <f>") - choice)))))) - ((not (string= pattern completion)) - (delete-region beg end) - (insert completion)) - (t - (message "Making completion list...") - (let ((list (all-completions pattern obarray predicate))) - (or (eq predicate 'fboundp) - (let (new) - (while list - (setq new (cons (if (fboundp (intern (car list))) - (list (car list) " <f>") - (car list)) - new)) - (setq list (cdr list))) - (setq list (nreverse new)))) - (with-output-to-temp-buffer "*Help*" - (funcall completion-display-completion-list-function - (sort list (function (lambda (x y) - (string-lessp - (or (car-safe x) x) - (or (car-safe y) y)))))))) - (message "Making completion list...%s" "done")))))) - -;;;%Hooks -(provide 'completer) -(run-hooks 'completer-load-hook)
--- a/lisp/ilisp/completer.new.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1013 +0,0 @@ -;;; -*-Emacs-Lisp-*- -;;;%Header -;;; -;;; Rcs_Info: completer.el,v 3.23 1993/09/03 02:05:07 ivan Rel $ -;;; -;;; Partial completion mechanism for GNU Emacs. Version 3.03 -;;; Copyright (C) 1990, 1991, 1992 Chris McConnell, ccm@cs.cmu.edu. -;;; Thanks to Bjorn Victor for suggestions, testing, and patches for -;;; file completion. - -;;; This file is part of GNU Emacs. - -;;; GNU Emacs is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY. No author or distributor -;;; accepts responsibility to anyone for the consequences of using it -;;; or for whether it serves any particular purpose or works at all, -;;; unless he says so in writing. Refer to the GNU Emacs General Public -;;; License for full details. -;;; Everyone is granted permission to copy, modify and redistribute -;;; GNU Emacs, but only under the conditions described in the -;;; GNU Emacs General Public License. A copy of this license is -;;; supposed to have been given to you along with GNU Emacs so you -;;; can know your rights and responsibilities. It should be in a -;;; file named COPYING. Among other things, the copyright notice -;;; and this notice must be preserved on all copies. - -;;; When loaded, this file extends the standard completion mechanisms -;;; so that they perform pattern matching completions. There is also -;;; an interface that allows it to be used by other programs. The -;;; completion rules are: -;;; -;;; 1) If what has been typed matches any possibility, do normal -;;; completion. -;;; -;;; 2) Otherwise, generate a regular expression such that -;;; completer-words delimit words and generate all possible matches. -;;; The variable completer-any-delimiter can be set to a character -;;; that matches any delimiter. If it were " ", then "by d" would be -;;; byte-recompile-directory. If completer-use-words is T, a match is -;;; unique if it is the only one with the same number of words. If -;;; completer-use-words is NIL, a match is unique if it is the only -;;; possibility. If you ask the completer to use its best guess, it -;;; will be the shortest match of the possibilities unless -;;; completer-exact is T. -;;; -;;; 3) For filenames, if completer-complete-filenames is T, each -;;; pathname component will be individually completed, otherwise only -;;; the final component will be completed. If you are using a -;;; distributed file system like afs, you may want to set up a -;;; symbolic link in your home directory or add pathname components to -;;; completer-file-skip so that the pathname components that go across -;;; machines do not get expanded. -;;; -;;; SPACE, TAB, LFD, RET, and ? do normal completion if possible -;;; otherwise they do partial completion. In addition, C-DEL will -;;; undo the last partial expansion or contraction. M-RET will always -;;; complete to the current match before returning. This is useful -;;; when any string is possible, but you want to complete to a string -;;; as when calling find-file. The bindings can be changed by using -;;; completer-load-hook. -;;; -;;; Modes that use comint-dynamic-complete (like cmushell and ilisp) -;;; will also do partial completion as will M-tab in Emacs LISP. -;;; -;;; Examples: -;;; a-f auto-fill-mode -;;; b--d *beginning-of-defun or byte-recompile-directory -;;; by d *byte-recompile-directory if completer-any-delimiter is " " -;;; ~/i.e *~/ilisp.el or ~/il-el.el or ~/ilisp.elc -;;; /u/mi/ /usr/misc/ -;;; - -;;;%Globals -;;;%%Switches -(defvar completer-load-hook nil - "Hook called when minibuffer partial completion is loaded.") - -(defvar completer-disable nil - "*If T, turn off partial completion. Use the command -\\[completer-toggle] to set this.") - -(defvar completer-complete-filenames t - "*If T, then each component of a filename will be completed, -otherwise just the final component will be completed.") - -(defvar completer-use-words nil ; jwz: this is HATEFUL! - "*If T, then prefer completions with the same number of words as the -pattern.") - -(defvar completer-words "---. <" - "*Delimiters used in partial completions. It should be a set of -characters suitable for inclusion in a [] regular expression.") - -(defvar completer-any-delimiter nil - "*If a character, then a delimiter in the pattern that matches the -character will match any delimiter in completer-words.") - -(defvar completer-file-skip "^cs/$\\|@sys\\|.edu/$\\|.gov/$\\|.com/$\\|:/$" - "*Regular expression for pathname components to not complete.") - -(defvar completer-exact nil - "*If T, then you must have an exact match. Otherwise, the shortest -string that matches the pattern will be used.") - -(defvar completer-cache-size 100 - "*Size of cache to use for partially completed pathnames.") - -(defvar completer-use-cache t - "*Set to nil to disable the partially completed pathname cache.") - -;;;%%Internal -(defvar completer-last-pattern "" - "The last pattern expanded.") - -(defvar completer-message nil - "T if temporary message was just displayed.") - -(defvar completer-path-cache nil - "Cache of (path . choices) for completer.") - -(defvar completer-string nil "Last completer string.") -(defvar completer-table nil "Last completer table.") -(defvar completer-pred nil "Last completer pred.") -(defvar completer-mode nil "Last completer mode.") -(defvar completer-result nil "Last completer result.") - -;;;%Utilities -(defun completer-message (message &optional point) - "Display MESSAGE at optional POINT for two seconds." - (setq point (or point (point-max)) - completer-message t) - (let ((end - (save-excursion - (goto-char point) - (insert message) - (point))) - (inhibit-quit t)) - (sit-for 2) - (delete-region point end) - (if (and quit-flag - ;;(not (eq 'lucid-19 ilisp-emacs-version-id)) - (not (string-match "Lucid" emacs-version)) - ) - (setq quit-flag nil - unread-command-char 7)))) - -;;; -(defun completer-deleter (regexp choices &optional keep) - "Destructively remove strings that match REGEXP in CHOICES and -return the modified list. If optional KEEP, then keep entries that -match regexp." - (let* ((choiceb choices) - choicep) - (if keep - (progn - (while (and choiceb (not (string-match regexp (car choiceb)))) - (setq choiceb (cdr choiceb))) - (setq choicep choiceb) - (while (cdr choicep) - (if (string-match regexp (car (cdr choicep))) - (setq choicep (cdr choicep)) - (rplacd choicep (cdr (cdr choicep)))))) - (while (and choiceb (string-match regexp (car choiceb))) - (setq choiceb (cdr choiceb))) - (setq choicep choiceb) - (while (cdr choicep) - (if (string-match regexp (car (cdr choicep))) - (rplacd choicep (cdr (cdr choicep))) - (setq choicep (cdr choicep))))) - choiceb)) - -;;;%%Regexp -(defun completer-regexp (string delimiters any) - "Convert STRING into a regexp with words delimited by characters in -DELIMITERS. Any delimiter in STRING that is the same as ANY will -match any delimiter." - (let* ((delimiter-reg (concat "[" delimiters "]")) - (limit (length string)) - (pos 0) - (regexp "^")) - (while (and (< pos limit) (string-match delimiter-reg string pos)) - (let* ((begin (match-beginning 0)) - (end (match-end 0)) - (delimiter (substring string begin end)) - (anyp (eq (elt string begin) any))) - (setq regexp - (format "%s%s[^%s]*%s" - regexp - (regexp-quote (substring string pos begin)) - (if anyp delimiters delimiter) - (if anyp delimiter-reg delimiter)) - pos end))) - (if (<= pos limit) - (setq regexp (concat regexp - (regexp-quote (substring string pos limit))))))) - -;;; -(defun completer-words (regexp string &optional limit) - "Return the number of words matching REGEXP in STRING up to LIMIT." - (setq limit (or limit 1000)) - (let ((count 1) - (pos 0)) - (while (and (string-match regexp string pos) (<= count limit)) - (setq count (1+ count) - pos (match-end 0))) - count)) - -;;;%Matcher -(defun completer-matches (string choices delimiters any) - "Return STRING's matches in CHOICES using DELIMITERS and wildcard -ANY to segment the strings." - (let* ((regexp (concat "[" delimiters "]")) - (from nil) - (to 0) - (pattern nil) - (len (length string)) - (matches nil) - sub sublen choice word wordlen pat) - ;; Segment pattern - (while (< (or from 0) len) - (setq to (or (string-match regexp string (if from (1+ from))) len)) - (if (eq (elt string (or from 0)) completer-any-delimiter) - (setq sub (substring string (if from (1+ from) 0) to) - sublen (- (length sub))) - (setq sub (substring string (or from 0) to) - sublen (length sub))) - (setq pattern (cons (cons sub sublen) pattern) - from to)) - (setq pattern (reverse pattern)) - ;; Find choices that match patterns - (setq regexp (concat "[" delimiters "]")) - (while choices - (setq choice (car choices) - word pattern - from 0) - (while (and word from - (let* (begin end) - (if (< (setq wordlen (cdr (setq pat (car word)))) 0) - (setq begin (1+ from) - end (+ begin (- wordlen))) - (setq begin from - end (+ begin wordlen))) - (and (<= end (length choice)) - (or (zerop wordlen) - (string-equal - (car pat) - (substring choice begin end)))))) - (setq from (string-match regexp choice - (if (and (zerop from) (zerop wordlen)) - from - (1+ from))) - word (cdr word))) - (if (not word) (setq matches (cons choice matches))) - (setq choices (cdr choices))) - matches)) - -;;; -(defun completer-choice (string choices delimiters use-words) - "Return the best match of STRING in CHOICES with DELIMITERS between -words and T if it is unique. A match is unique if it is the only -possibility or when USE-WORDS the only possibility with the same -number of words. The shortest string of multiple possibilities will be -the best match." - (or (if (null (cdr choices)) (cons (car choices) t)) - (let* ((regexp (concat "[^" delimiters "]*[" delimiters "]")) - (words (if use-words (completer-words regexp string))) - (choice choices) - (unique-p nil) - (match nil) - (match-count nil) - (match-len 1000)) - (while choice - (let* ((current (car choice)) - (length (length current))) - (if match-count - (if (= (completer-words regexp current words) words) - (progn - (setq unique-p nil) - (if (< length match-len) - (setq match current - match-len length)))) - (if (and use-words - (= (completer-words regexp current words) words)) - (setq match current - match-len length - match-count t - unique-p t) - (if (< length match-len) - (setq match current - match-len length))))) - (setq choice (cdr choice))) - (cons match unique-p)))) - -;;;%Completer -;;;%%Utilities -(defun completer-region (delimiters) - "Return the completion region bounded by characters in DELIMITERS -for the current buffer assuming that point is in it." - (cons (save-excursion (skip-chars-backward delimiters) (point)) - (save-excursion (skip-chars-forward delimiters) (point)))) - -;;; -(defun completer-last-component (string) - "Return the start of the last filename component in STRING." - (let ((last (1- (length string)) ) - (match 0) - (end 0)) - (while (and (setq match (string-match "/" string end)) (< match last)) - (setq end (1+ match))) - end)) - -;;; -(defun completer-match-record (string matches delimiters any dir mode) - "Return (match lcs choices unique) for STRING in MATCHES with -DELIMITERS or ANY wildcards and DIR if a filename when in MODE." - (let ((pattern (if dir - (substring string (completer-last-component string)) - string))) - (setq matches (completer-matches pattern matches delimiters any)) - (if (cdr matches) - (let ((match - (if (not completer-exact) - (completer-choice - pattern matches delimiters completer-use-words))) - (lcs (concat dir (try-completion "" (mapcar 'list matches))))) - (list (if match (concat dir (car match))) - lcs - matches (cdr match))) - (if matches - (let ((match (concat dir (car matches)))) - (list match match matches t)) - (list nil nil nil nil))))) - -;;;%%Complete file -(defun completer-extension-regexp (extensions) - "Return a regexp that matches any of EXTENSIONS." - (let ((regexp "\\(")) - (while extensions - (setq regexp (concat regexp (car extensions) - (if (cdr extensions) "\\|")) - extensions (cdr extensions))) - (concat regexp "\\)$"))) - -;;; -(defun completer-flush () - "Flush completer's pathname cache." - (interactive) - (setq completer-path-cache nil)) - -;;; -(defun completer-cache (path pred words any mode) - "Check to see if PATH is in path cache with PRED, WORDS, ANY and -MODE." - (let* ((last nil) - (ptr completer-path-cache) - (size 0) - (result nil)) - (if completer-use-cache - (while ptr - (let ((current (car (car ptr)))) - (if (string-equal current path) - (progn - (if last - (progn - (rplacd last (cdr ptr)) - (rplacd ptr completer-path-cache) - (setq completer-path-cache ptr))) - (setq result (cdr (car ptr)) - ptr nil)) - (if (cdr ptr) (setq last ptr)) - (setq size (1+ size) - ptr (cdr ptr)))))) - (or result - (let* ((choices - (completer path 'read-file-name-internal pred words any - mode t))) - (if (and (or (car (cdr (cdr (cdr choices)))) - (string= path (car choices))) - (eq (elt (car choices) (1- (length (car choices)))) ?/)) - (progn - (if (>= size completer-cache-size) (rplacd last nil)) - (setq completer-path-cache - (cons (cons path choices) completer-path-cache)))) - choices)))) - -;;; -(defun completer-file (string pred words any mode) - "Return (match common-substring matches unique-p) for STRING using -read-file-name-internal for choices that pass PRED using WORDS to -delimit words. Optional ANY is a delimiter that matches any of the -delimiters in WORD. If optional MODE is nil or 'help then possible -matches will always be returned." - (let* ((case-fold-search completion-ignore-case) - (last (and (eq mode 'exit-ok) (completer-last-component string))) - (position - ;; Special hack for CMU RFS filenames - (if (string-match "^/\\.\\./[^/]*/" string) - (match-end 0) - (string-match "[^~/]" string))) - (new (substring string 0 position)) - (user (if (string= new "~") - (setq new (file-name-directory (expand-file-name new))))) - (words (concat words "/")) - (len (length string)) - (choices nil) - end - (old-choices (list nil nil nil nil))) - (while position - (let* ((begin (string-match "/" string position)) - (exact-p nil)) - (setq end (if begin (match-end 0)) - choices - ;; Ends with a /, so check files in directory - (if (and (memq mode '(nil help)) (= position len)) - (completer-match-record - "" - ;; This assumes that .. and . come at the end - (let* ((choices - (all-completions new 'read-file-name-internal)) - (choicep choices)) - (if (string= (car choicep) "../") - (cdr (cdr choicep)) - (while (cdr choicep) - (if (string= (car (cdr choicep)) "../") - (rplacd choicep nil)) - (setq choicep (cdr choicep))) - choices)) - words any new mode) - (if (eq position last) - (let ((new (concat new (substring string position)))) - (list new new nil t)) - (let ((component (substring string position end))) - (if (and end - (string-match completer-file-skip component)) - ;; Assume component is complete - (list (concat new component) - (concat new component) - nil t) - (completer-cache - (concat new component) - pred words any mode)))))) - ;; Keep going if unique or we match exactly - (if (or (car (cdr (cdr (cdr choices)))) - (setq exact-p - (string= (concat new (substring string position end)) - (car choices)))) - (setq old-choices - (let* ((lcs (car (cdr choices))) - (matches (car (cdr (cdr choices)))) - (slash (and lcs (string-match "/$" lcs)))) - (list nil - (if slash (substring lcs 0 slash) lcs) - (if (and (cdr matches) - (or (eq mode 'help) (not exact-p))) - matches) - nil)) - new (car choices) - position end) - ;; Its ok to not match user names because they may be in - ;; different root directories - (if (and (= position 1) (= (elt string 0) ?~)) - (setq new (substring string 0 end) - choices (list new new (list new) t) - user nil - position end) - (setq position nil))))) - (if (not (car choices)) - (setq choices old-choices)) - (if (and (car choices) - (not (eq mode 'help)) - (not (car (cdr (cdr (cdr choices)))))) - ;; Try removing completion ignored extensions - (let* ((extensions - (completer-extension-regexp completion-ignored-extensions)) - (choiceb (car (cdr (cdr choices)))) - (choicep choiceb) - (isext nil) - (noext nil)) - (while choicep - (if (string-match extensions (car choicep)) - (setq isext t) - (setq noext t)) - (if (and isext noext) - ;; There are matches besides extensions - (setq choiceb (completer-deleter extensions choiceb) - choicep nil) - (setq choicep (cdr choicep)))) - (if (and isext noext) - (setq choices - (completer-match-record - (if end (substring string end) "") - choiceb words any - (file-name-directory (car (cdr choices))) - mode))))) - (if user - (let ((match (car choices)) - (lcs (car (cdr choices))) - (len (length user))) - (setq choices - (cons (if match (concat "~" (substring match len))) - (cons (if lcs (concat "~" (substring lcs len))) - (cdr (cdr choices))))))) - choices)) - -;;;%Exported program interface -;;;%%Completer -(defun completer (string table pred words - &optional any mode file-p) - "Return (match common-substring matches unique-p) for STRING in -TABLE for choices that pass PRED using WORDS to delimit words. If the -flag completer-complete-filenames is T and the table is -read-file-name-internal, then filename components will be individually -expanded. Optional ANY is a delimiter that can match any delimiter in -WORDS. Optional MODE is nil for complete, 'help for help and 'exit -for exit." - (if (and (stringp completer-string) - (string= string completer-string) - (eq table completer-table) - (eq pred completer-pred) - (not file-p) - (or (eq mode completer-mode) - (not (memq table '(read-file-name-internal - read-directory-name-internal))))) - completer-result - (setq - completer-string "" - completer-table table - completer-pred pred - completer-mode mode - completer-result - (if (and completer-complete-filenames - (not file-p) (eq table 'read-file-name-internal)) - (completer-file string pred words any mode) - (let* ((file-p (or file-p (eq table 'read-file-name-internal))) - (case-fold-search completion-ignore-case) - (pattern (concat "[" words "]")) - (component (if file-p (completer-last-component string))) - (dir (if component (substring string 0 component))) - (string (if dir (substring string component) string)) - (has-words (or (string-match pattern string) - (length string)))) - (if (and file-p (string-match "^\\$" string)) - ;; Handle environment variables - (let ((match - (getenv (substring string 1 - (string-match "/" string))))) - (if match (setq match (concat match "/"))) - (list match match (list match) match)) - (let* ((choices - (all-completions - (concat dir (substring string 0 has-words)) - table pred)) - (regexp (completer-regexp string words any))) - (if choices - (completer-match-record - string - (completer-deleter regexp choices t) - words any dir mode) - (list nil nil nil nil)))))) - completer-string string) - completer-result)) - -;;;%%Display choices -(defun completer-display-choices (choices &optional match message end - display) - "Display the list of possible CHOICES with optional MATCH, MESSAGE, -END and DISPLAY. If MATCH is non-nil, it will be flagged as the best -guess. If there are no choices, display MESSAGE. END is where to put -temporary messages. If DISPLAY is present then it will be called on -each possible completion and should return a string." - (if choices - (with-output-to-temp-buffer " *Completions*" - (if (cdr choices) - (display-completion-list - (sort - (if display - (let ((old choices) - (new nil)) - (while old - (setq new (cons (funcall display (car old)) new) - old (cdr old))) - new) - (copy-sequence choices)) - (function (lambda (x y) - (string-lessp (or (car-safe x) x) - (or (car-safe y) y))))))) - (if match - (save-excursion - (set-buffer " *Completions*") - (goto-char (point-min)) - (insert "Guess = " match (if (cdr choices) ", " ""))))) - (beep) - (completer-message (or message " (No completions)") end))) - -;;;%%Goto -(defun completer-goto (match lcs choices unique delimiters words - &optional mode display) - "MATCH is the best match, LCS is the longest common substring of all -of the matches. CHOICES is a list of the possibilities, UNIQUE -indicates if MATCH is unique. DELIMITERS are possible bounding -characters for the completion region. WORDS are the characters that -delimit the words for partial matches. Replace the region bounded by -delimiters with the match if unique and the lcs otherwise unless -optional MODE is 'help. Then go to the part of the string that -disambiguates choices using WORDS to separate words and display the -possibilities if the string was not extended. If optional DISPLAY is -present then it will be called on each possible completion and should -return a string." - (setq completer-message nil) - (let* ((region (completer-region delimiters)) - (start (car region)) - (end (cdr region)) - (string (buffer-substring start end)) - (file-p (string-match "[^ ]*\\(~\\|/\\|$\\)" string)) - (no-insert (eq mode 'help)) - (message t) - (new (not (string= (buffer-substring start (point)) lcs)))) - (if unique - (if no-insert - (progn - (goto-char end) - (completer-display-choices choices match nil end display)) - (if (string= string match) - (if (not file-p) - (progn (goto-char end) - (completer-message " (Sole completion)" end))) - (completer-insert match delimiters))) - ;;Not unique - (if lcs - (let* ((regexp - (concat "[" words (if file-p "/") "]")) - (words (completer-words regexp lcs)) - point) - ;; Go to where its ambiguous - (goto-char start) - (if (not no-insert) - (progn - (insert lcs) - (setq completer-last-pattern - (list string delimiters (current-buffer) start) - start (point) - end (+ end (length lcs))))) - ;; Skip to the first delimiter in the original string - ;; beyond the ambiguous point and keep from there on - (if (re-search-forward regexp end 'move words) - (progn - (if (and (not no-insert) match) - (let ((delimiter - (progn - (string-match lcs match) - (substring match (match-end 0) - (1+ (match-end 0)))))) - (if (string-match regexp delimiter) - (insert delimiter)))) - (forward-char -1))) - (if (not no-insert) - (progn - (setq end (- end (- (point) start))) - (delete-region start (point)))))) - (if choices - (if (or no-insert (not new)) - (completer-display-choices choices match nil end display)) - (if file-p - (progn - (if (not (= (point) end)) (forward-char 1)) - (if (not (save-excursion (re-search-forward "/" end t))) - (goto-char end)))) - (if message - (progn - (beep) - (completer-message (if no-insert - " (No completions)" - " (No match)") - end))))))) - -;;;%Exported buffer interface -;;;%%Complete and go -(defun completer-complete-goto (delimiters words table pred - &optional no-insert display) - "Complete the string bound by DELIMITERS using WORDS to bound words -for partial matches in TABLE with PRED and then insert the longest -common substring unless optional NO-INSERT and go to the point of -ambiguity. If optional DISPLAY, it will be called on each match when -possible completions are shown and should return a string." - (let* ((region (completer-region delimiters))) - (apply 'completer-goto - (append (completer (buffer-substring (car region) (cdr region)) - table pred words completer-any-delimiter - no-insert) - (list delimiters words no-insert display))))) - -;;;%%Undo -(defun completer-insert (match delimiters &optional buffer undo) - "Replace the region bounded with characters in DELIMITERS by MATCH -and save it so that it can be restored by completer-undo." - (let* ((region (completer-region delimiters)) - (start (car region)) - (end (cdr region))) - (if (and undo (or (not (= start undo)) - (not (eq (current-buffer) buffer)))) - (error "No previous pattern") - (setq completer-last-pattern (list (buffer-substring start end) - delimiters - (current-buffer) - start)) - (delete-region start end) - (goto-char start) - (insert match)))) - -;;; -(defun completer-undo () - "Swap the last expansion and the last match pattern." - (interactive) - (if completer-last-pattern - (apply 'completer-insert completer-last-pattern) - (error "No previous pattern"))) - -;;;%Minibuffer specific code -;;;%%Utilities -(defun completer-minibuf-string () - "Remove dead filename specs from the minibuffer as delimited by // -or ~ or $ and return the resulting string." - (save-excursion - (goto-char (point-max)) - (if (and (eq minibuffer-completion-table 'read-file-name-internal) - (re-search-backward "//\\|/~\\|.\\$" nil t)) - (delete-region (point-min) (1+ (point)))) - (buffer-substring (point-min) (point-max)))) - -;;; -(defun completer-minibuf-exit () - "Exit and clear pattern." - (interactive) - (setq completer-last-pattern nil) - (exit-minibuffer)) - -;;; -(defun completer-new-cmd (cmd) - "Return T if we can't execute the old minibuffer version of CMD." - (if (or completer-disable - (let ((string (completer-minibuf-string))) - (or - (not (string-match - (concat "[" completer-words "/~]") - string)) - (condition-case () - (let ((completion - (try-completion string - minibuffer-completion-table - minibuffer-completion-predicate))) - (if (eq minibuffer-completion-table - 'read-file-name-internal) - ;; Directories complete as themselves - (and completion - (or (not (string= string completion)) - (file-exists-p completion))) - completion)) - (error nil))))) - (progn - (funcall cmd) - nil) - t)) - -;;; -(defun completer-minibuf (&optional mode) - "Partial completion of minibuffer expressions. Optional MODE is -'help for help and 'exit for exit. - -If what has been typed so far matches any possibility normal -completion will be done. Otherwise, the string is considered to be a -pattern with words delimited by the characters in -completer-words. If completer-exact is T, the best match will be -the shortest one with the same number of words as the pattern if -possible and otherwise the shortest matching expression. If called -with a prefix, caching will be temporarily disabled. - -Examples: -a-f auto-fill-mode -r-e rmail-expunge -b--d *begining-of-defun or byte-recompile-directory -by d *byte-recompile-directory if completer-any-delimiter is \" \" -~/i.e *~/ilisp.el or ~/il-el.el or ~/ilisp.elc -/u/mi/ /usr/misc/" - (interactive) - (append - (let ((completer-use-cache (not (or (not completer-use-cache) - current-prefix-arg)))) - (completer (completer-minibuf-string) - minibuffer-completion-table - minibuffer-completion-predicate - completer-words - completer-any-delimiter - mode)) - (list "^" completer-words mode))) - -;;;%%Commands -(defun completer-toggle () - "Turn partial completion on or off." - (interactive) - (setq completer-disable (not completer-disable)) - (message (if completer-disable - "Partial completion OFF" - "Partial completion ON"))) - -;;; -(defvar completer-old-help - (lookup-key minibuffer-local-must-match-map "?") - "Old binding of ? in minibuffer completion map.") -(defun completer-help () - "Partial completion minibuffer-completion-help. -See completer-minibuf for more information." - (interactive) - (if (completer-new-cmd completer-old-help) - (apply 'completer-goto (completer-minibuf 'help)))) - -;;; -(defvar completer-old-completer - (lookup-key minibuffer-local-must-match-map "\t") - "Old binding of TAB in minibuffer completion map.") -(defun completer-complete () - "Partial completion minibuffer-complete. -See completer-minibuf for more information." - (interactive) - (if (completer-new-cmd completer-old-completer) - (apply 'completer-goto (completer-minibuf)))) - -;;; -(defvar completer-old-word - (lookup-key minibuffer-local-must-match-map " ") - "Old binding of SPACE in minibuffer completion map.") -(defun completer-word () - "Partial completion minibuffer-complete. -See completer-minibuf for more information." - (interactive) - (if (eq completer-any-delimiter ?\ ) - (insert ?\ ) - (if (completer-new-cmd completer-old-word) - (apply 'completer-goto (completer-minibuf))))) - -;;; -(defvar completer-old-exit - (lookup-key minibuffer-local-must-match-map "\n") - "Old binding of RET in minibuffer completion map.") -(defun completer-exit () - "Partial completion minibuffer-complete-and-exit. -See completer-minibuf for more information." - (interactive) - (if (completer-new-cmd completer-old-exit) - (let* ((completions (completer-minibuf 'exit)) - (match (car completions)) - (unique-p (car (cdr (cdr (cdr completions)))))) - (apply 'completer-goto completions) - (if unique-p - (completer-minibuf-exit) - (if match - (progn (completer-insert match "^") - (if minibuffer-completion-confirm - (completer-message " (Confirm)") - (completer-minibuf-exit))) - (if (not completer-message) (beep))))))) - -;;; -(defun completer-match-exit () - "Exit the minibuffer with the current best match." - (interactive) - (let* ((completions (completer-minibuf 'exit)) - (guess (car completions))) - (if (not guess) - ;; OK if last filename component doesn't match - (setq completions (completer-minibuf 'exit-ok) - guess (car completions))) - (if guess - (progn - (goto-char (point-min)) - (insert guess) - (delete-region (point) (point-max)) - (exit-minibuffer)) - (apply 'completer-goto completions)))) - -;;;%%Keymaps -(define-key minibuffer-local-completion-map "\C-_" 'completer-undo) -(define-key minibuffer-local-completion-map "\t" 'completer-complete) -(define-key minibuffer-local-completion-map " " 'completer-word) -(define-key minibuffer-local-completion-map "?" 'completer-help) -(define-key minibuffer-local-completion-map "\n" 'completer-minibuf-exit) -(define-key minibuffer-local-completion-map "\r" 'completer-minibuf-exit) -(define-key minibuffer-local-completion-map "\M-\n" 'completer-match-exit) -(define-key minibuffer-local-completion-map "\M-\r" 'completer-match-exit) - -(define-key minibuffer-local-must-match-map "\C-_" 'completer-undo) -(define-key minibuffer-local-must-match-map "\t" 'completer-complete) -(define-key minibuffer-local-must-match-map " " 'completer-word) -(define-key minibuffer-local-must-match-map "\n" 'completer-exit) -(define-key minibuffer-local-must-match-map "\r" 'completer-exit) -(define-key minibuffer-local-must-match-map "?" 'completer-help) -(define-key minibuffer-local-must-match-map "\M-\n" 'completer-match-exit) -(define-key minibuffer-local-must-match-map "\M-\r" 'completer-match-exit) - -;;;%comint -(defun completer-comint-dynamic-list-completions (completions) - "List in help buffer sorted COMPLETIONS. -Typing SPC flushes the help buffer." - (completer-comint-dynamic-complete-1 nil 'help)) - -(defun completer-comint-dynamic-complete-filename () - "Dynamically complete the filename at point." - (completer-comint-dynamic-complete-1 nil t)) - -;;; -(defun completer-comint-dynamic-complete-1 (&optional undo mode) - "Complete the previous filename or display possibilities if done -twice in a row. If called with a prefix, undo the last completion." - (interactive "P") - (if undo - (completer-undo) - ;; added by jwz: don't cache completions in shell buffer! - (setq completer-string nil) - (let ((conf (current-window-configuration)));; lemacs change - (completer-complete-goto - "^ \t\n\"" - completer-words - 'read-file-name-internal - default-directory - mode) - ;; lemacs change - (if (eq mode 'help) (comint-restore-window-config conf)) - ))) -;(fset 'comint-dynamic-complete 'completer-comint-dynamic-complete) -(fset 'comint-dynamic-complete-filename - 'completer-comint-dynamic-complete-filename) -(fset 'comint-dynamic-list-completions - 'completer-comint-dynamic-list-completions) - -;;; Set the functions again if comint is loaded -(setq comint-load-hook - (cons (function (lambda () -;; (fset 'comint-dynamic-complete -;; 'completer-comint-dynamic-complete) - (fset 'comint-dynamic-complete-filename - 'completer-comint-dynamic-complete-filename) - (fset 'comint-dynamic-list-completions - 'completer-comint-dynamic-list-completions))) - (if (and (boundp 'comint-load-hook) comint-load-hook) - (if (consp comint-load-hook) - (if (eq (car comint-load-hook) 'lambda) - (list comint-load-hook) - comint-load-hook) - (list comint-load-hook))))) - -;;;%lisp-complete-symbol -(defun lisp-complete-symbol (&optional mode) - "Perform partial completion on Lisp symbol preceding point. That -symbol is compared against the symbols that exist and any additional -characters determined by what is there are inserted. If the symbol -starts just after an open-parenthesis, only symbols with function -definitions are considered. Otherwise, all symbols with function -definitions, values or properties are considered. If called with a -negative prefix, the last completion will be undone." - (interactive "P") - (if (< (prefix-numeric-value mode) 0) - (completer-undo) - (let* ((end (save-excursion (skip-chars-forward "^ \t\n)]}\"") (point))) - (beg (save-excursion - (backward-sexp 1) - (while (= (char-syntax (following-char)) ?\') - (forward-char 1)) - (point))) - (pattern (buffer-substring beg end)) - (predicate - (if (eq (char-after (1- beg)) ?\() - 'fboundp - (function (lambda (sym) - (or (boundp sym) (fboundp sym) - (symbol-plist sym)))))) - (completion (try-completion pattern obarray predicate))) - (cond ((eq completion t)) - ((null completion) - (completer-complete-goto - "^ \t\n\(\)[]{}'`" completer-words - obarray predicate - nil - (if (not (eq predicate 'fboundp)) - (function (lambda (choice) - (if (fboundp (intern choice)) - (list choice " <f>") - choice)))))) - ((not (string= pattern completion)) - (delete-region beg end) - (insert completion)) - (t - (message "Making completion list...") - (let ((list (all-completions pattern obarray predicate))) - (or (eq predicate 'fboundp) - (let (new) - (while list - (setq new (cons (if (fboundp (intern (car list))) - (list (car list) " <f>") - (car list)) - new)) - (setq list (cdr list))) - (setq list (nreverse new)))) - (with-output-to-temp-buffer "*Help*" - (display-completion-list - (sort list (function (lambda (x y) - (string-lessp - (or (car-safe x) x) - (or (car-safe y) y)))))))) - (message "Making completion list...%s" "done")))))) - -;;;%Hooks -(provide 'completer) -(run-hooks 'completer-load-hook) -
--- a/lisp/ilisp/completer.no-fun.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1013 +0,0 @@ -;;; -*-Emacs-Lisp-*- -;;;%Header -;;; -;;; Rcs_Info: completer.el,v 3.23 1993/09/03 02:05:07 ivan Rel $ -;;; -;;; Partial completion mechanism for GNU Emacs. Version 3.03 -;;; Copyright (C) 1990, 1991, 1992 Chris McConnell, ccm@cs.cmu.edu. -;;; Thanks to Bjorn Victor for suggestions, testing, and patches for -;;; file completion. - -;;; This file is part of GNU Emacs. - -;;; GNU Emacs is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY. No author or distributor -;;; accepts responsibility to anyone for the consequences of using it -;;; or for whether it serves any particular purpose or works at all, -;;; unless he says so in writing. Refer to the GNU Emacs General Public -;;; License for full details. -;;; Everyone is granted permission to copy, modify and redistribute -;;; GNU Emacs, but only under the conditions described in the -;;; GNU Emacs General Public License. A copy of this license is -;;; supposed to have been given to you along with GNU Emacs so you -;;; can know your rights and responsibilities. It should be in a -;;; file named COPYING. Among other things, the copyright notice -;;; and this notice must be preserved on all copies. - -;;; When loaded, this file extends the standard completion mechanisms -;;; so that they perform pattern matching completions. There is also -;;; an interface that allows it to be used by other programs. The -;;; completion rules are: -;;; -;;; 1) If what has been typed matches any possibility, do normal -;;; completion. -;;; -;;; 2) Otherwise, generate a regular expression such that -;;; completer-words delimit words and generate all possible matches. -;;; The variable completer-any-delimiter can be set to a character -;;; that matches any delimiter. If it were " ", then "by d" would be -;;; byte-recompile-directory. If completer-use-words is T, a match is -;;; unique if it is the only one with the same number of words. If -;;; completer-use-words is NIL, a match is unique if it is the only -;;; possibility. If you ask the completer to use its best guess, it -;;; will be the shortest match of the possibilities unless -;;; completer-exact is T. -;;; -;;; 3) For filenames, if completer-complete-filenames is T, each -;;; pathname component will be individually completed, otherwise only -;;; the final component will be completed. If you are using a -;;; distributed file system like afs, you may want to set up a -;;; symbolic link in your home directory or add pathname components to -;;; completer-file-skip so that the pathname components that go across -;;; machines do not get expanded. -;;; -;;; SPACE, TAB, LFD, RET, and ? do normal completion if possible -;;; otherwise they do partial completion. In addition, C-DEL will -;;; undo the last partial expansion or contraction. M-RET will always -;;; complete to the current match before returning. This is useful -;;; when any string is possible, but you want to complete to a string -;;; as when calling find-file. The bindings can be changed by using -;;; completer-load-hook. -;;; -;;; Modes that use comint-dynamic-complete (like cmushell and ilisp) -;;; will also do partial completion as will M-tab in Emacs LISP. -;;; -;;; Examples: -;;; a-f auto-fill-mode -;;; b--d *beginning-of-defun or byte-recompile-directory -;;; by d *byte-recompile-directory if completer-any-delimiter is " " -;;; ~/i.e *~/ilisp.el or ~/il-el.el or ~/ilisp.elc -;;; /u/mi/ /usr/misc/ -;;; - -;;;%Globals -;;;%%Switches -(defvar completer-load-hook nil - "Hook called when minibuffer partial completion is loaded.") - -(defvar completer-disable nil - "*If T, turn off partial completion. Use the command -\\[completer-toggle] to set this.") - -(defvar completer-complete-filenames t - "*If T, then each component of a filename will be completed, -otherwise just the final component will be completed.") - -(defvar completer-use-words nil ; jwz: this is HATEFUL! - "*If T, then prefer completions with the same number of words as the -pattern.") - -(defvar completer-words "---. <" - "*Delimiters used in partial completions. It should be a set of -characters suitable for inclusion in a [] regular expression.") - -(defvar completer-any-delimiter nil - "*If a character, then a delimiter in the pattern that matches the -character will match any delimiter in completer-words.") - -(defvar completer-file-skip "^cs/$\\|@sys\\|.edu/$\\|.gov/$\\|.com/$\\|:/$" - "*Regular expression for pathname components to not complete.") - -(defvar completer-exact nil - "*If T, then you must have an exact match. Otherwise, the shortest -string that matches the pattern will be used.") - -(defvar completer-cache-size 100 - "*Size of cache to use for partially completed pathnames.") - -(defvar completer-use-cache t - "*Set to nil to disable the partially completed pathname cache.") - -;;;%%Internal -(defvar completer-last-pattern "" - "The last pattern expanded.") - -(defvar completer-message nil - "T if temporary message was just displayed.") - -(defvar completer-path-cache nil - "Cache of (path . choices) for completer.") - -(defvar completer-string nil "Last completer string.") -(defvar completer-table nil "Last completer table.") -(defvar completer-pred nil "Last completer pred.") -(defvar completer-mode nil "Last completer mode.") -(defvar completer-result nil "Last completer result.") - -;;;%Utilities -(defun completer-message (message &optional point) - "Display MESSAGE at optional POINT for two seconds." - (setq point (or point (point-max)) - completer-message t) - (let ((end - (save-excursion - (goto-char point) - (insert message) - (point))) - (inhibit-quit t)) - (sit-for 2) - (delete-region point end) - (if (and quit-flag - ;;(not (eq 'lucid-19 ilisp-emacs-version-id)) - (not (string-match "Lucid" emacs-version)) - ) - (setq quit-flag nil - unread-command-char 7)))) - -;;; -(defun completer-deleter (regexp choices &optional keep) - "Destructively remove strings that match REGEXP in CHOICES and -return the modified list. If optional KEEP, then keep entries that -match regexp." - (let* ((choiceb choices) - choicep) - (if keep - (progn - (while (and choiceb (not (string-match regexp (car choiceb)))) - (setq choiceb (cdr choiceb))) - (setq choicep choiceb) - (while (cdr choicep) - (if (string-match regexp (car (cdr choicep))) - (setq choicep (cdr choicep)) - (rplacd choicep (cdr (cdr choicep)))))) - (while (and choiceb (string-match regexp (car choiceb))) - (setq choiceb (cdr choiceb))) - (setq choicep choiceb) - (while (cdr choicep) - (if (string-match regexp (car (cdr choicep))) - (rplacd choicep (cdr (cdr choicep))) - (setq choicep (cdr choicep))))) - choiceb)) - -;;;%%Regexp -(defun completer-regexp (string delimiters any) - "Convert STRING into a regexp with words delimited by characters in -DELIMITERS. Any delimiter in STRING that is the same as ANY will -match any delimiter." - (let* ((delimiter-reg (concat "[" delimiters "]")) - (limit (length string)) - (pos 0) - (regexp "^")) - (while (and (< pos limit) (string-match delimiter-reg string pos)) - (let* ((begin (match-beginning 0)) - (end (match-end 0)) - (delimiter (substring string begin end)) - (anyp (eq (elt string begin) any))) - (setq regexp - (format "%s%s[^%s]*%s" - regexp - (regexp-quote (substring string pos begin)) - (if anyp delimiters delimiter) - (if anyp delimiter-reg delimiter)) - pos end))) - (if (<= pos limit) - (setq regexp (concat regexp - (regexp-quote (substring string pos limit))))))) - -;;; -(defun completer-words (regexp string &optional limit) - "Return the number of words matching REGEXP in STRING up to LIMIT." - (setq limit (or limit 1000)) - (let ((count 1) - (pos 0)) - (while (and (string-match regexp string pos) (<= count limit)) - (setq count (1+ count) - pos (match-end 0))) - count)) - -;;;%Matcher -(defun completer-matches (string choices delimiters any) - "Return STRING's matches in CHOICES using DELIMITERS and wildcard -ANY to segment the strings." - (let* ((regexp (concat "[" delimiters "]")) - (from nil) - (to 0) - (pattern nil) - (len (length string)) - (matches nil) - sub sublen choice word wordlen pat) - ;; Segment pattern - (while (< (or from 0) len) - (setq to (or (string-match regexp string (if from (1+ from))) len)) - (if (eq (elt string (or from 0)) completer-any-delimiter) - (setq sub (substring string (if from (1+ from) 0) to) - sublen (- (length sub))) - (setq sub (substring string (or from 0) to) - sublen (length sub))) - (setq pattern (cons (cons sub sublen) pattern) - from to)) - (setq pattern (reverse pattern)) - ;; Find choices that match patterns - (setq regexp (concat "[" delimiters "]")) - (while choices - (setq choice (car choices) - word pattern - from 0) - (while (and word from - (let* (begin end) - (if (< (setq wordlen (cdr (setq pat (car word)))) 0) - (setq begin (1+ from) - end (+ begin (- wordlen))) - (setq begin from - end (+ begin wordlen))) - (and (<= end (length choice)) - (or (zerop wordlen) - (string-equal - (car pat) - (substring choice begin end)))))) - (setq from (string-match regexp choice - (if (and (zerop from) (zerop wordlen)) - from - (1+ from))) - word (cdr word))) - (if (not word) (setq matches (cons choice matches))) - (setq choices (cdr choices))) - matches)) - -;;; -(defun completer-choice (string choices delimiters use-words) - "Return the best match of STRING in CHOICES with DELIMITERS between -words and T if it is unique. A match is unique if it is the only -possibility or when USE-WORDS the only possibility with the same -number of words. The shortest string of multiple possibilities will be -the best match." - (or (if (null (cdr choices)) (cons (car choices) t)) - (let* ((regexp (concat "[^" delimiters "]*[" delimiters "]")) - (words (if use-words (completer-words regexp string))) - (choice choices) - (unique-p nil) - (match nil) - (match-count nil) - (match-len 1000)) - (while choice - (let* ((current (car choice)) - (length (length current))) - (if match-count - (if (= (completer-words regexp current words) words) - (progn - (setq unique-p nil) - (if (< length match-len) - (setq match current - match-len length)))) - (if (and use-words - (= (completer-words regexp current words) words)) - (setq match current - match-len length - match-count t - unique-p t) - (if (< length match-len) - (setq match current - match-len length))))) - (setq choice (cdr choice))) - (cons match unique-p)))) - -;;;%Completer -;;;%%Utilities -(defun completer-region (delimiters) - "Return the completion region bounded by characters in DELIMITERS -for the current buffer assuming that point is in it." - (cons (save-excursion (skip-chars-backward delimiters) (point)) - (save-excursion (skip-chars-forward delimiters) (point)))) - -;;; -(defun completer-last-component (string) - "Return the start of the last filename component in STRING." - (let ((last (1- (length string)) ) - (match 0) - (end 0)) - (while (and (setq match (string-match "/" string end)) (< match last)) - (setq end (1+ match))) - end)) - -;;; -(defun completer-match-record (string matches delimiters any dir mode) - "Return (match lcs choices unique) for STRING in MATCHES with -DELIMITERS or ANY wildcards and DIR if a filename when in MODE." - (let ((pattern (if dir - (substring string (completer-last-component string)) - string))) - (setq matches (completer-matches pattern matches delimiters any)) - (if (cdr matches) - (let ((match - (if (not completer-exact) - (completer-choice - pattern matches delimiters completer-use-words))) - (lcs (concat dir (try-completion "" (mapcar 'list matches))))) - (list (if match (concat dir (car match))) - lcs - matches (cdr match))) - (if matches - (let ((match (concat dir (car matches)))) - (list match match matches t)) - (list nil nil nil nil))))) - -;;;%%Complete file -(defun completer-extension-regexp (extensions) - "Return a regexp that matches any of EXTENSIONS." - (let ((regexp "\\(")) - (while extensions - (setq regexp (concat regexp (car extensions) - (if (cdr extensions) "\\|")) - extensions (cdr extensions))) - (concat regexp "\\)$"))) - -;;; -(defun completer-flush () - "Flush completer's pathname cache." - (interactive) - (setq completer-path-cache nil)) - -;;; -(defun completer-cache (path pred words any mode) - "Check to see if PATH is in path cache with PRED, WORDS, ANY and -MODE." - (let* ((last nil) - (ptr completer-path-cache) - (size 0) - (result nil)) - (if completer-use-cache - (while ptr - (let ((current (car (car ptr)))) - (if (string-equal current path) - (progn - (if last - (progn - (rplacd last (cdr ptr)) - (rplacd ptr completer-path-cache) - (setq completer-path-cache ptr))) - (setq result (cdr (car ptr)) - ptr nil)) - (if (cdr ptr) (setq last ptr)) - (setq size (1+ size) - ptr (cdr ptr)))))) - (or result - (let* ((choices - (completer path 'read-file-name-internal pred words any - mode t))) - (if (and (or (car (cdr (cdr (cdr choices)))) - (string= path (car choices))) - (eq (elt (car choices) (1- (length (car choices)))) ?/)) - (progn - (if (>= size completer-cache-size) (rplacd last nil)) - (setq completer-path-cache - (cons (cons path choices) completer-path-cache)))) - choices)))) - -;;; -(defun completer-file (string pred words any mode) - "Return (match common-substring matches unique-p) for STRING using -read-file-name-internal for choices that pass PRED using WORDS to -delimit words. Optional ANY is a delimiter that matches any of the -delimiters in WORD. If optional MODE is nil or 'help then possible -matches will always be returned." - (let* ((case-fold-search completion-ignore-case) - (last (and (eq mode 'exit-ok) (completer-last-component string))) - (position - ;; Special hack for CMU RFS filenames - (if (string-match "^/\\.\\./[^/]*/" string) - (match-end 0) - (string-match "[^~/]" string))) - (new (substring string 0 position)) - (user (if (string= new "~") - (setq new (file-name-directory (expand-file-name new))))) - (words (concat words "/")) - (len (length string)) - (choices nil) - end - (old-choices (list nil nil nil nil))) - (while position - (let* ((begin (string-match "/" string position)) - (exact-p nil)) - (setq end (if begin (match-end 0)) - choices - ;; Ends with a /, so check files in directory - (if (and (memq mode '(nil help)) (= position len)) - (completer-match-record - "" - ;; This assumes that .. and . come at the end - (let* ((choices - (all-completions new 'read-file-name-internal)) - (choicep choices)) - (if (string= (car choicep) "../") - (cdr (cdr choicep)) - (while (cdr choicep) - (if (string= (car (cdr choicep)) "../") - (rplacd choicep nil)) - (setq choicep (cdr choicep))) - choices)) - words any new mode) - (if (eq position last) - (let ((new (concat new (substring string position)))) - (list new new nil t)) - (let ((component (substring string position end))) - (if (and end - (string-match completer-file-skip component)) - ;; Assume component is complete - (list (concat new component) - (concat new component) - nil t) - (completer-cache - (concat new component) - pred words any mode)))))) - ;; Keep going if unique or we match exactly - (if (or (car (cdr (cdr (cdr choices)))) - (setq exact-p - (string= (concat new (substring string position end)) - (car choices)))) - (setq old-choices - (let* ((lcs (car (cdr choices))) - (matches (car (cdr (cdr choices)))) - (slash (and lcs (string-match "/$" lcs)))) - (list nil - (if slash (substring lcs 0 slash) lcs) - (if (and (cdr matches) - (or (eq mode 'help) (not exact-p))) - matches) - nil)) - new (car choices) - position end) - ;; Its ok to not match user names because they may be in - ;; different root directories - (if (and (= position 1) (= (elt string 0) ?~)) - (setq new (substring string 0 end) - choices (list new new (list new) t) - user nil - position end) - (setq position nil))))) - (if (not (car choices)) - (setq choices old-choices)) - (if (and (car choices) - (not (eq mode 'help)) - (not (car (cdr (cdr (cdr choices)))))) - ;; Try removing completion ignored extensions - (let* ((extensions - (completer-extension-regexp completion-ignored-extensions)) - (choiceb (car (cdr (cdr choices)))) - (choicep choiceb) - (isext nil) - (noext nil)) - (while choicep - (if (string-match extensions (car choicep)) - (setq isext t) - (setq noext t)) - (if (and isext noext) - ;; There are matches besides extensions - (setq choiceb (completer-deleter extensions choiceb) - choicep nil) - (setq choicep (cdr choicep)))) - (if (and isext noext) - (setq choices - (completer-match-record - (if end (substring string end) "") - choiceb words any - (file-name-directory (car (cdr choices))) - mode))))) - (if user - (let ((match (car choices)) - (lcs (car (cdr choices))) - (len (length user))) - (setq choices - (cons (if match (concat "~" (substring match len))) - (cons (if lcs (concat "~" (substring lcs len))) - (cdr (cdr choices))))))) - choices)) - -;;;%Exported program interface -;;;%%Completer -(defun completer (string table pred words - &optional any mode file-p) - "Return (match common-substring matches unique-p) for STRING in -TABLE for choices that pass PRED using WORDS to delimit words. If the -flag completer-complete-filenames is T and the table is -read-file-name-internal, then filename components will be individually -expanded. Optional ANY is a delimiter that can match any delimiter in -WORDS. Optional MODE is nil for complete, 'help for help and 'exit -for exit." - (if (and (stringp completer-string) - (string= string completer-string) - (eq table completer-table) - (eq pred completer-pred) - (not file-p) - (or (eq mode completer-mode) - (not (memq table '(read-file-name-internal - read-directory-name-internal))))) - completer-result - (setq - completer-string "" - completer-table table - completer-pred pred - completer-mode mode - completer-result - (if (and completer-complete-filenames - (not file-p) (eq table 'read-file-name-internal)) - (completer-file string pred words any mode) - (let* ((file-p (or file-p (eq table 'read-file-name-internal))) - (case-fold-search completion-ignore-case) - (pattern (concat "[" words "]")) - (component (if file-p (completer-last-component string))) - (dir (if component (substring string 0 component))) - (string (if dir (substring string component) string)) - (has-words (or (string-match pattern string) - (length string)))) - (if (and file-p (string-match "^\\$" string)) - ;; Handle environment variables - (let ((match - (getenv (substring string 1 - (string-match "/" string))))) - (if match (setq match (concat match "/"))) - (list match match (list match) match)) - (let* ((choices - (all-completions - (concat dir (substring string 0 has-words)) - table pred)) - (regexp (completer-regexp string words any))) - (if choices - (completer-match-record - string - (completer-deleter regexp choices t) - words any dir mode) - (list nil nil nil nil)))))) - completer-string string) - completer-result)) - -;;;%%Display choices -(defun completer-display-choices (choices &optional match message end - display) - "Display the list of possible CHOICES with optional MATCH, MESSAGE, -END and DISPLAY. If MATCH is non-nil, it will be flagged as the best -guess. If there are no choices, display MESSAGE. END is where to put -temporary messages. If DISPLAY is present then it will be called on -each possible completion and should return a string." - (if choices - (with-output-to-temp-buffer " *Completions*" - (if (cdr choices) - (display-completion-list - (sort - (if display - (let ((old choices) - (new nil)) - (while old - (setq new (cons (funcall display (car old)) new) - old (cdr old))) - new) - (copy-sequence choices)) - (function (lambda (x y) - (string-lessp (or (car-safe x) x) - (or (car-safe y) y))))))) - (if match - (save-excursion - (set-buffer " *Completions*") - (goto-char (point-min)) - (insert "Guess = " match (if (cdr choices) ", " ""))))) - (beep) - (completer-message (or message " (No completions)") end))) - -;;;%%Goto -(defun completer-goto (match lcs choices unique delimiters words - &optional mode display) - "MATCH is the best match, LCS is the longest common substring of all -of the matches. CHOICES is a list of the possibilities, UNIQUE -indicates if MATCH is unique. DELIMITERS are possible bounding -characters for the completion region. WORDS are the characters that -delimit the words for partial matches. Replace the region bounded by -delimiters with the match if unique and the lcs otherwise unless -optional MODE is 'help. Then go to the part of the string that -disambiguates choices using WORDS to separate words and display the -possibilities if the string was not extended. If optional DISPLAY is -present then it will be called on each possible completion and should -return a string." - (setq completer-message nil) - (let* ((region (completer-region delimiters)) - (start (car region)) - (end (cdr region)) - (string (buffer-substring start end)) - (file-p (string-match "[^ ]*\\(~\\|/\\|$\\)" string)) - (no-insert (eq mode 'help)) - (message t) - (new (not (string= (buffer-substring start (point)) lcs)))) - (if unique - (if no-insert - (progn - (goto-char end) - (completer-display-choices choices match nil end display)) - (if (string= string match) - (if (not file-p) - (progn (goto-char end) - (completer-message " (Sole completion)" end))) - (completer-insert match delimiters))) - ;;Not unique - (if lcs - (let* ((regexp - (concat "[" words (if file-p "/") "]")) - (words (completer-words regexp lcs)) - point) - ;; Go to where its ambiguous - (goto-char start) - (if (not no-insert) - (progn - (insert lcs) - (setq completer-last-pattern - (list string delimiters (current-buffer) start) - start (point) - end (+ end (length lcs))))) - ;; Skip to the first delimiter in the original string - ;; beyond the ambiguous point and keep from there on - (if (re-search-forward regexp end 'move words) - (progn - (if (and (not no-insert) match) - (let ((delimiter - (progn - (string-match lcs match) - (substring match (match-end 0) - (1+ (match-end 0)))))) - (if (string-match regexp delimiter) - (insert delimiter)))) - (forward-char -1))) - (if (not no-insert) - (progn - (setq end (- end (- (point) start))) - (delete-region start (point)))))) - (if choices - (if (or no-insert (not new)) - (completer-display-choices choices match nil end display)) - (if file-p - (progn - (if (not (= (point) end)) (forward-char 1)) - (if (not (save-excursion (re-search-forward "/" end t))) - (goto-char end)))) - (if message - (progn - (beep) - (completer-message (if no-insert - " (No completions)" - " (No match)") - end))))))) - -;;;%Exported buffer interface -;;;%%Complete and go -(defun completer-complete-goto (delimiters words table pred - &optional no-insert display) - "Complete the string bound by DELIMITERS using WORDS to bound words -for partial matches in TABLE with PRED and then insert the longest -common substring unless optional NO-INSERT and go to the point of -ambiguity. If optional DISPLAY, it will be called on each match when -possible completions are shown and should return a string." - (let* ((region (completer-region delimiters))) - (apply 'completer-goto - (append (completer (buffer-substring (car region) (cdr region)) - table pred words completer-any-delimiter - no-insert) - (list delimiters words no-insert display))))) - -;;;%%Undo -(defun completer-insert (match delimiters &optional buffer undo) - "Replace the region bounded with characters in DELIMITERS by MATCH -and save it so that it can be restored by completer-undo." - (let* ((region (completer-region delimiters)) - (start (car region)) - (end (cdr region))) - (if (and undo (or (not (= start undo)) - (not (eq (current-buffer) buffer)))) - (error "No previous pattern") - (setq completer-last-pattern (list (buffer-substring start end) - delimiters - (current-buffer) - start)) - (delete-region start end) - (goto-char start) - (insert match)))) - -;;; -(defun completer-undo () - "Swap the last expansion and the last match pattern." - (interactive) - (if completer-last-pattern - (apply 'completer-insert completer-last-pattern) - (error "No previous pattern"))) - -;;;%Minibuffer specific code -;;;%%Utilities -(defun completer-minibuf-string () - "Remove dead filename specs from the minibuffer as delimited by // -or ~ or $ and return the resulting string." - (save-excursion - (goto-char (point-max)) - (if (and (eq minibuffer-completion-table 'read-file-name-internal) - (re-search-backward "//\\|/~\\|.\\$" nil t)) - (delete-region (point-min) (1+ (point)))) - (buffer-substring (point-min) (point-max)))) - -;;; -(defun completer-minibuf-exit () - "Exit and clear pattern." - (interactive) - (setq completer-last-pattern nil) - (exit-minibuffer)) - -;;; -(defun completer-new-cmd (cmd) - "Return T if we can't execute the old minibuffer version of CMD." - (if (or completer-disable - (let ((string (completer-minibuf-string))) - (or - (not (string-match - (concat "[" completer-words "/~]") - string)) - (condition-case () - (let ((completion - (try-completion string - minibuffer-completion-table - minibuffer-completion-predicate))) - (if (eq minibuffer-completion-table - 'read-file-name-internal) - ;; Directories complete as themselves - (and completion - (or (not (string= string completion)) - (file-exists-p completion))) - completion)) - (error nil))))) - (progn - (funcall cmd) - nil) - t)) - -;;; -(defun completer-minibuf (&optional mode) - "Partial completion of minibuffer expressions. Optional MODE is -'help for help and 'exit for exit. - -If what has been typed so far matches any possibility normal -completion will be done. Otherwise, the string is considered to be a -pattern with words delimited by the characters in -completer-words. If completer-exact is T, the best match will be -the shortest one with the same number of words as the pattern if -possible and otherwise the shortest matching expression. If called -with a prefix, caching will be temporarily disabled. - -Examples: -a-f auto-fill-mode -r-e rmail-expunge -b--d *begining-of-defun or byte-recompile-directory -by d *byte-recompile-directory if completer-any-delimiter is \" \" -~/i.e *~/ilisp.el or ~/il-el.el or ~/ilisp.elc -/u/mi/ /usr/misc/" - (interactive) - (append - (let ((completer-use-cache (not (or (not completer-use-cache) - current-prefix-arg)))) - (completer (completer-minibuf-string) - minibuffer-completion-table - minibuffer-completion-predicate - completer-words - completer-any-delimiter - mode)) - (list "^" completer-words mode))) - -;;;%%Commands -(defun completer-toggle () - "Turn partial completion on or off." - (interactive) - (setq completer-disable (not completer-disable)) - (message (if completer-disable - "Partial completion OFF" - "Partial completion ON"))) - -;;; -(defvar completer-old-help - (lookup-key minibuffer-local-must-match-map "?") - "Old binding of ? in minibuffer completion map.") -(defun completer-help () - "Partial completion minibuffer-completion-help. -See completer-minibuf for more information." - (interactive) - (if (completer-new-cmd completer-old-help) - (apply 'completer-goto (completer-minibuf 'help)))) - -;;; -(defvar completer-old-completer - (lookup-key minibuffer-local-must-match-map "\t") - "Old binding of TAB in minibuffer completion map.") -(defun completer-complete () - "Partial completion minibuffer-complete. -See completer-minibuf for more information." - (interactive) - (if (completer-new-cmd completer-old-completer) - (apply 'completer-goto (completer-minibuf)))) - -;;; -(defvar completer-old-word - (lookup-key minibuffer-local-must-match-map " ") - "Old binding of SPACE in minibuffer completion map.") -(defun completer-word () - "Partial completion minibuffer-complete. -See completer-minibuf for more information." - (interactive) - (if (eq completer-any-delimiter ?\ ) - (insert ?\ ) - (if (completer-new-cmd completer-old-word) - (apply 'completer-goto (completer-minibuf))))) - -;;; -(defvar completer-old-exit - (lookup-key minibuffer-local-must-match-map "\n") - "Old binding of RET in minibuffer completion map.") -(defun completer-exit () - "Partial completion minibuffer-complete-and-exit. -See completer-minibuf for more information." - (interactive) - (if (completer-new-cmd completer-old-exit) - (let* ((completions (completer-minibuf 'exit)) - (match (car completions)) - (unique-p (car (cdr (cdr (cdr completions)))))) - (apply 'completer-goto completions) - (if unique-p - (completer-minibuf-exit) - (if match - (progn (completer-insert match "^") - (if minibuffer-completion-confirm - (completer-message " (Confirm)") - (completer-minibuf-exit))) - (if (not completer-message) (beep))))))) - -;;; -(defun completer-match-exit () - "Exit the minibuffer with the current best match." - (interactive) - (let* ((completions (completer-minibuf 'exit)) - (guess (car completions))) - (if (not guess) - ;; OK if last filename component doesn't match - (setq completions (completer-minibuf 'exit-ok) - guess (car completions))) - (if guess - (progn - (goto-char (point-min)) - (insert guess) - (delete-region (point) (point-max)) - (exit-minibuffer)) - (apply 'completer-goto completions)))) - -;;;%%Keymaps -(define-key minibuffer-local-completion-map "\C-_" 'completer-undo) -(define-key minibuffer-local-completion-map "\t" 'completer-complete) -(define-key minibuffer-local-completion-map " " 'completer-word) -(define-key minibuffer-local-completion-map "?" 'completer-help) -(define-key minibuffer-local-completion-map "\n" 'completer-minibuf-exit) -(define-key minibuffer-local-completion-map "\r" 'completer-minibuf-exit) -(define-key minibuffer-local-completion-map "\M-\n" 'completer-match-exit) -(define-key minibuffer-local-completion-map "\M-\r" 'completer-match-exit) - -(define-key minibuffer-local-must-match-map "\C-_" 'completer-undo) -(define-key minibuffer-local-must-match-map "\t" 'completer-complete) -(define-key minibuffer-local-must-match-map " " 'completer-word) -(define-key minibuffer-local-must-match-map "\n" 'completer-exit) -(define-key minibuffer-local-must-match-map "\r" 'completer-exit) -(define-key minibuffer-local-must-match-map "?" 'completer-help) -(define-key minibuffer-local-must-match-map "\M-\n" 'completer-match-exit) -(define-key minibuffer-local-must-match-map "\M-\r" 'completer-match-exit) - -;;;%comint -(defun completer-comint-dynamic-list-completions (completions) - "List in help buffer sorted COMPLETIONS. -Typing SPC flushes the help buffer." - (completer-comint-dynamic-complete-1 nil 'help)) - -(defun completer-comint-dynamic-complete-filename () - "Dynamically complete the filename at point." - (completer-comint-dynamic-complete-1 nil t)) - -;;; -(defun completer-comint-dynamic-complete-1 (&optional undo mode) - "Complete the previous filename or display possibilities if done -twice in a row. If called with a prefix, undo the last completion." - (interactive "P") - (if undo - (completer-undo) - ;; added by jwz: don't cache completions in shell buffer! - (setq completer-string nil) - (let ((conf (current-window-configuration)));; lemacs change - (completer-complete-goto - "^ \t\n\"" - completer-words - 'read-file-name-internal - default-directory - mode) - ;; lemacs change - (if (eq mode 'help) (comint-restore-window-config conf)) - ))) -;(fset 'comint-dynamic-complete 'completer-comint-dynamic-complete) -(fset 'comint-dynamic-complete-filename - 'completer-comint-dynamic-complete-filename) -(fset 'comint-dynamic-list-completions - 'completer-comint-dynamic-list-completions) - -;;; Set the functions again if comint is loaded -(setq comint-load-hook - (cons (function (lambda () -;; (fset 'comint-dynamic-complete -;; 'completer-comint-dynamic-complete) - (fset 'comint-dynamic-complete-filename - 'completer-comint-dynamic-complete-filename) - (fset 'comint-dynamic-list-completions - 'completer-comint-dynamic-list-completions))) - (if (and (boundp 'comint-load-hook) comint-load-hook) - (if (consp comint-load-hook) - (if (eq (car comint-load-hook) 'lambda) - (list comint-load-hook) - comint-load-hook) - (list comint-load-hook))))) - -;;;%lisp-complete-symbol -(defun lisp-complete-symbol (&optional mode) - "Perform partial completion on Lisp symbol preceding point. That -symbol is compared against the symbols that exist and any additional -characters determined by what is there are inserted. If the symbol -starts just after an open-parenthesis, only symbols with function -definitions are considered. Otherwise, all symbols with function -definitions, values or properties are considered. If called with a -negative prefix, the last completion will be undone." - (interactive "P") - (if (< (prefix-numeric-value mode) 0) - (completer-undo) - (let* ((end (save-excursion (skip-chars-forward "^ \t\n)]}\"") (point))) - (beg (save-excursion - (backward-sexp 1) - (while (= (char-syntax (following-char)) ?\') - (forward-char 1)) - (point))) - (pattern (buffer-substring beg end)) - (predicate - (if (eq (char-after (1- beg)) ?\() - 'fboundp - (function (lambda (sym) - (or (boundp sym) (fboundp sym) - (symbol-plist sym)))))) - (completion (try-completion pattern obarray predicate))) - (cond ((eq completion t)) - ((null completion) - (completer-complete-goto - "^ \t\n\(\)[]{}'`" completer-words - obarray predicate - nil - (if (not (eq predicate 'fboundp)) - (function (lambda (choice) - (if (fboundp (intern choice)) - (list choice " <f>") - choice)))))) - ((not (string= pattern completion)) - (delete-region beg end) - (insert completion)) - (t - (message "Making completion list...") - (let ((list (all-completions pattern obarray predicate))) - (or (eq predicate 'fboundp) - (let (new) - (while list - (setq new (cons (if (fboundp (intern (car list))) - (list (car list) " <f>") - (car list)) - new)) - (setq list (cdr list))) - (setq list (nreverse new)))) - (with-output-to-temp-buffer "*Help*" - (display-completion-list - (sort list (function (lambda (x y) - (string-lessp - (or (car-safe x) x) - (or (car-safe y) y)))))))) - (message "Making completion list...%s" "done")))))) - -;;;%Hooks -(provide 'completer) -(run-hooks 'completer-load-hook) -
--- a/lisp/ilisp/ilcompat.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,67 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilcompat.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - -;;;============================================================================ -;;; Global definitions/declarations - -(defconst +ilisp-emacs-version-id+ - (cond ((string-match "XEmacs" emacs-version) - 'xemacs) - ((string-match "Lucid" emacs-version) - (if (string-match "^19.[0-7][^0-9]" emacs-version) - 'lucid-19 - 'lucid-19-new)) - ((string-match "^19" emacs-version) - 'fsf-19) - (t 'fsf-18)) - "The version of Emacs ILISP is running in. -Declared as '(member fsf-19 fsf-19 lucid-19 lucid-19-new xemacs). -Set in ilcompat.el.") - -(defconst +ilisp-emacs-minor-version-number+ - (cond ((eq +ilisp-emacs-version-id+ 'fsf-18) 59) - ((or (eq +ilisp-emacs-version-id+ 'lucid-19) - (eq +ilisp-emacs-version-id+ 'lucid-19-new) - ) - 12) ; Does emacs-minor-version work? - ((eq +ilisp-emacs-version-id+ 'xemacs) 14) - (t emacs-minor-version))) - - -;;;============================================================================ -;;; Code - -(cond ((or (eq +ilisp-emacs-version-id+ 'lucid-19) - (eq +ilisp-emacs-version-id+ 'lucid-19-new)) - (load "illuc19")) - ((eq +ilisp-emacs-version-id+ 'xemacs) (load "ilxemacs")) - ((eq +ilisp-emacs-version-id+ 'fsf-19) (load "ilfsf19")) - ((eq +ilisp-emacs-version-id+ 'fsf-18) (load "ilfsf18")) - ) - -;;;============================================================================ -;;; Epilogue - -(provide 'compat) - -;;; end of file -- compat.el --
--- a/lisp/ilisp/ild.mail Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,433 +0,0 @@ -From @yonge.csri.toronto.edu:qobi@csri.toronto.edu Sun Jul 3 00:43:43 1994 -From: Jeffrey Mark Siskind <qobi@csri.toronto.edu> -To: campbell@c2.net (Rick Campbell) -Cc: marcoxa@cs.NYU.EDU -In-Reply-To: campbell@c2.net's message of Wed, 29 Jun 1994 19:21:41 GMT -Subject: ILISP -Reply-To: Qobi@CS.Toronto.EDU -Date: Sun, 3 Jul 1994 00:43:19 -0400 - -I think it is great that you are willing to maintain ILisp. ILisp is the most -viable Lisp development environment available. I use it many hours a day. - -I'd like to contribute an addition to ILisp. I wrote a package that uses a -standard set of single-keystroke bindings to interface with a variety of -different debuggers. It is vaguely modelled after the Symbolics debugger. It -provides two key advantages: single keystrokes for moving up and down the -stack, and a uniform interface to different debuggers. I find that useful -since I often work simultaneously with different Lisps and can never remember -the particulars of each one's debugger. - -Anyway, I think that it would be of great use to others. It shouldn't take you -very long to `officially' integrate it with ILisp. It basically works already -with Lucid, Allegro, CMUCL, and AKCL and is fairly reliable. I've used it for -years already. Not all debugger commands are available in all implementations. -Some are but I didn't know how to get them to work. These are noted in the -code. If you know how to fix them that would be great. - -I also have written an improved debugger for use with Scheme->C along with an -interface between that debugger and ILD. There are still some problems that I -have to iron out though before I release that code. - -I hereby give you permission to distribute this code to anyone subject to the -restrictions that it is available on an as is basis with no guarantee of its -correctness of suitability for any purpose, that I am not held liable for -damages resulting from its use, and that I be given credit by name for this -contribution. - Jeff (home page http://www.cdf.toronto.edu:/DCS/Personal/Siskind.html) -------------------------------------------------------------------------------- -;;; ILD: A common Common Lisp debugger user interface for ILisp. -;;; ---Jeffrey Mark Siskind - -;;; Keystroke c-u? What it does -;;; --------------------------------------------------------- -;;; m-a Abort -;;; m-c Continue -;;; c-m-n * Next stack frame -;;; c-m-p * Previous stack frame -;;; c-c < Top stack frame -;;; c-c > Bottom stack frame -;;; m-b Backtrace -;;; c-m-d Display all locals -;;; c-m-l * Display particular local -;;; c-c r Return -;;; c-m-r Retry -;;; c-x t Trap on exit -;;; c-c L Select Lisp interaction buffer -;;; c-z c-s Sets compiler options for maximally debuggablity -;;; c-z c-f Sets compiler options for fastest but least debuggable code - -(require 'ilisp) - -(deflocal ild-abort-string nil) -(deflocal ild-continue-string nil) -(deflocal ild-next-string nil) -(deflocal ild-next-string-arg nil) -(deflocal ild-previous-string nil) -(deflocal ild-previous-string-arg nil) -(deflocal ild-top-string nil) -(deflocal ild-bottom-string nil) -(deflocal ild-backtrace-string nil) -(deflocal ild-locals-string nil) -(deflocal ild-local-string-arg nil) -(deflocal ild-return-string nil) -(deflocal ild-retry-string nil) -(deflocal ild-trap-on-exit-string nil) - -(defun ild-debugger-command (string) - (process-send-string (get-buffer-process (current-buffer)) - (format "%s\n" string))) - -(defun ild-prompt () - (save-excursion - (beginning-of-line) - (comint-skip-prompt) - (eobp))) - -(defun ild-abort () - (interactive) - (if ild-abort-string - (ild-debugger-command ild-abort-string) - (beep))) - -(defun ild-continue (&optional arg) - (interactive "P") - (if (ild-prompt) - (if ild-continue-string - (ild-debugger-command ild-continue-string) - (beep)) - (if arg (capitalize-word arg) (capitalize-word 1)))) - -(defun ild-next (&optional arg) - (interactive "P") - (if arg - (if ild-next-string-arg - (ild-debugger-command (format ild-next-string-arg arg)) - (beep)) - (if ild-next-string - (ild-debugger-command ild-next-string) - (beep)))) - -(defun ild-previous (&optional arg) - (interactive "P") - (if arg - (if ild-previous-string-arg - (ild-debugger-command (format ild-previous-string-arg arg)) - (beep)) - (if ild-previous-string - (ild-debugger-command ild-previous-string) - (beep)))) - -(defun ild-top (&optional arg) - (interactive "P") - (if ild-top-string - (ild-debugger-command ild-top-string) - (beep))) - -(defun ild-bottom (&optional arg) - (interactive "P") - (if ild-bottom-string - (ild-debugger-command ild-bottom-string) - (beep))) - -(defun ild-backtrace (&optional arg) - (interactive "P") - (if (ild-prompt) - (if ild-backtrace-string - (ild-debugger-command ild-backtrace-string) - (beep)) - (if arg (backward-word arg) (backward-word 1)))) - -(defun ild-locals (&optional arg) - (interactive "P") - (if ild-locals-string - (ild-debugger-command ild-locals-string) - (beep))) - -(defun ild-local (&optional arg) - (interactive "P") - (if arg - (if ild-local-string-arg - (ild-debugger-command (format ild-local-string-arg arg)) - (beep)) - (if ild-locals-string - (ild-debugger-command ild-locals-string) - (beep)))) - -(defun ild-return () - (interactive) - (if ild-return-string - (ild-debugger-command ild-return-string) - (beep))) - -(defun ild-retry () - (interactive) - (if ild-retry-string - (ild-debugger-command ild-retry-string) - (beep))) - -(defun ild-trap-on-exit (&optional arg) - (interactive "P") - (if ild-trap-on-exit-string - (ild-debugger-command ild-trap-on-exit-string) - (beep))) - -(defun fast-lisp () - "Use the production compiler." - (interactive) - (ilisp-send "(progn (proclaim '(optimize (speed 3) (safety 0) (space 0) (compilation-speed 0) (debug 0))) #+akcl (use-fast-links t))")) - -(defun slow-lisp () - "Use the development compiler." - (interactive) - (ilisp-send "(progn (proclaim '(optimize (speed 0) (safety 3) (space 3) (compilation-speed 3) (debug 3))) #+akcl (use-fast-links nil))")) - -(defun select-lisp () - "Select the lisp buffer in one window mode" - (interactive) - (cond ((and (lisp-mem ilisp-buffer - (buffer-list) - (function (lambda (x y) (equal x (buffer-name y))))) - (get-buffer-process (get-buffer ilisp-buffer))) - (delete-other-windows) - (switch-to-buffer ilisp-buffer)) - (t (lucid) ;put your favorite Lisp here - (delete-other-windows)))) - -(defun select-ilisp (arg) - "Select the current ILISP buffer." - (interactive "P") - (if (and (not arg) - (lisp-mem - (buffer-name (current-buffer)) - ilisp-buffers - (function (lambda (x y) (equal x (format "*%s*" (car y))))))) - (setq ilisp-buffer (buffer-name (current-buffer))) - (let ((new (completing-read - (if ilisp-buffer - (format "Buffer [%s]: " - (substring ilisp-buffer 1 - (1- (length ilisp-buffer)))) - "Buffer: ") - ilisp-buffers nil t))) - (if (not (zerop (length new))) - (setq ilisp-buffer (format "*%s*" new)))))) - -;;; This fixes a bug in ILISP 4.1 - -(defun defkey-ilisp (key command &optional inferior-only) - "Define KEY as COMMAND in ilisp-mode-map and lisp-mode-map unless -optional INFERIOR-ONLY is T. If the maps do not exist they will be -created. This should only be called after ilisp-prefix is set to the -desired prefix." - (if (not ilisp-mode-map) (ilisp-bindings)) - (define-key ilisp-mode-map key command) - (if (not inferior-only) (define-key lisp-mode-map key command))) - -;;; This is a convenient command since c-Z c-W doesn't default to the whole -;;; buffer if there is no region - -(defun compile-buffer () - "Compile the current buffer" - (interactive) - (compile-region-and-go-lisp (point-min) (point-max))) - -(defkey-ilisp "\M-a" 'ild-abort t) -(defkey-ilisp "\M-c" 'ild-continue t) -(defkey-ilisp "\C-\M-n" 'ild-next t) -(defkey-ilisp "\C-\M-p" 'ild-previous t) -(defkey-ilisp "\C-c<" 'ild-top t) -(defkey-ilisp "\C-c>" 'ild-bottom t) -(defkey-ilisp "\M-b" 'ild-backtrace t) -(defkey-ilisp "\C-\M-d" 'ild-locals t) -(defkey-ilisp "\C-\M-l" 'ild-local t) -(defkey-ilisp "\C-cr" 'ild-return t) -(defkey-ilisp "\C-\M-r" 'ild-retry t) -(defkey-ilisp "\C-xt" 'ild-trap-on-exit t) -(define-key global-map "\C-cL" 'select-lisp) -(ilisp-defkey lisp-mode-map "\C-f" 'fast-lisp) -(ilisp-defkey ilisp-mode-map "\C-f" 'fast-lisp) -(ilisp-defkey lisp-mode-map "\C-s" 'slow-lisp) -(ilisp-defkey ilisp-mode-map "\C-s" 'slow-lisp) - -(defdialect clisp "Common LISP" ilisp - (setq ilisp-load-or-send-command - "(or (and (load \"%s\" :if-does-not-exist nil) t) - (and (load \"%s\" :if-does-not-exist nil) t))") - (ilisp-load-init 'clisp "clisp") - (setq ilisp-package-regexp "^[ \t]*(in-package[ \t\n]*" - ilisp-package-command "(let ((*package* *package*)) %s (package-name *package*))" - ilisp-package-name-command "(package-name *package*)" - ilisp-in-package-command "(in-package \"%s\")" - ilisp-last-command "*" - ilisp-save-command "(progn (ILISP:ilisp-save) %s\n)" - ilisp-restore-command "(ILISP:ilisp-restore)" - ilisp-block-command "(progn %s\n)" - ilisp-eval-command "(ILISP:ilisp-eval \"%s\" \"%s\" \"%s\")" - ilisp-defvar-regexp "(defvar[ \t\n]") - (setq ilisp-defvar-command - "(ILISP:ilisp-eval \"(let ((form '%s)) (progn (makunbound (second form)) (eval form)))\" \"%s\" \"%s\")") - (setq ilisp-compile-command "(ILISP:ilisp-compile \"%s\" \"%s\" \"%s\")" - ilisp-describe-command "(ILISP:ilisp-describe \"%s\" \"%s\")" - ilisp-inspect-command "(ILISP:ilisp-inspect \"%s\" \"%s\")" - ilisp-arglist-command "(ILISP:ilisp-arglist \"%s\" \"%s\")") - (setq ilisp-documentation-types - '(("function") ("variable") - ("structure") ("type") - ("setf") ("class") - ("(qualifiers* (class ...))"))) - (setq ilisp-documentation-command - "(ILISP:ilisp-documentation \"%s\" \"%s\" \"%s\")") - (setq ilisp-macroexpand-1-command - "(ILISP:ilisp-macroexpand-1 \"%s\" \"%s\")") - (setq ilisp-macroexpand-command "(ILISP:ilisp-macroexpand \"%s\" \"%s\")") - (setq ilisp-complete-command - "(ILISP:ilisp-matching-symbols \"%s\" \"%s\" %s %s %s)") - (setq ilisp-locator 'lisp-locate-clisp) - (setq ilisp-source-types - '(("function") ("macro") ("variable") - ("structure") ("type") - ("setf") ("class") - ("(qualifiers* (class ...))"))) - (setq ilisp-callers-command "(ILISP:ilisp-callers \"%s\" \"%s\")" - ilisp-trace-command "(ILISP:ilisp-trace \"%s\" \"%s\" \"%s\")" - ilisp-untrace-command "(ILISP:ilisp-untrace \"%s\" \"%s\")") - (setq ilisp-directory-command "(namestring *default-pathname-defaults*)" - ilisp-set-directory-command - "(setq *default-pathname-defaults* (parse-namestring \"%s\"))") - (setq ilisp-load-command "(load \"%s\")") - (setq ilisp-compile-file-command - "(ILISP:ilisp-compile-file \"%s\" \"%s\")")) - -(defdialect lucid "Lucid Common LISP" clisp - (ilisp-load-init 'lucid "lucid") - (setq comint-prompt-regexp "^\\(->\\)+ \\|^[^> ]*> " - comint-fix-error ":a" - ilisp-reset ":a :t" - comint-continue ":c" - comint-interrupt-regexp ">>Break: Keyboard interrupt" - comint-prompt-status - (function (lambda (old line) - (comint-prompt-status old line 'lucid-check-prompt)))) - (setq ilisp-error-regexp "ILISP:[^\"]*\\|>>[^\n]*") - (setq ilisp-source-types (append ilisp-source-types '(("any")))) - (setq ilisp-find-source-command - "(ILISP:ilisp-source-files \"%s\" \"%s\" \"%s\")") - (setq ilisp-binary-command - "(first (last lucid::*load-binary-pathname-types*))") - (setq ild-abort-string ":A" - ild-continue-string ":C" - ild-next-string ":N" - ild-next-string-arg ":N %s" - ild-previous-string ":P" - ild-previous-string-arg ":P %s" - ild-top-string ":<" - ild-bottom-string ":>" - ild-backtrace-string ":B" - ild-locals-string ":V" - ild-local-string-arg ":L %s" - ild-return-string ":R" - ild-retry-string ":F" - ild-trap-on-exit-string ":X T")) -(setq lucid-program "lisp") - -(defdialect allegro "Allegro Common LISP" clisp - (ilisp-load-init 'allegro "allegro") - (setq comint-fix-error ":pop" - ilisp-reset ":reset" - comint-continue ":cont" - comint-interrupt-regexp "Error: [^\n]* interrupt\)") - (setq comint-prompt-status - (function (lambda (old line) - (comint-prompt-status old line 'allegro-check-prompt)))) - ;; <cl> or package> at top-level - ;; [0-9c] <cl> or package> in error - ;; (setq comint-prompt-regexp "^\\(\\[[0-9]*c*\\] \\|\\)\\(<\\|\\)[^>]*> ") - (setq comint-prompt-regexp "^\\(\\[[0-9]+i?c?\\] \\|\\[step\\] \\)?\\(<?[-A-Za-z]* ?[0-9]*?>\\|[-A-Za-z0-9]+([0-9]+):\\) ") - (setq ilisp-error-regexp - "\\(ILISP:[^\"]*\\)\\|\\(Error:[^\n]*\\)\\|\\(Break:[^\n]*\\)") - - (setq ilisp-binary-command "excl:*fasl-default-type*") - (setq ilisp-source-types (append ilisp-source-types '(("any")))) - (setq ilisp-find-source-command - "(ILISP:ilisp-source-files \"%s\" \"%s\" \"%s\")") - (setq ilisp-init-binary-command - "(let ((ext (or #+m68k \"68fasl\" - #+sparc \"sfasl\" - #+iris4d \"ifasl\" - #+dec3100 \"pfasl\" - excl:*fasl-default-type*))) - #+allegro-v4.0 (setq ext (concatenate 'string ext \"4\")) - ext)") - (setq ild-abort-string ":pop" - ild-continue-string ":cont" - ild-next-string ":dn" - ild-next-string-arg ":dn %s" - ild-previous-string ":up" - ild-previous-string-arg ":up %s" - ild-top-string ":to" - ild-bottom-string ":bo" - ild-backtrace-string ":bt" - ild-locals-string ":local" - ild-local-string-arg ":local %s" - ild-return-string nil ;needs work - ild-retry-string ":rest" - ild-trap-on-exit-string ":boe")) -(setq allegro-program "cl") - -(defdialect akcl "Austin Kyoto Common LISP" kcl - (setq comint-prompt-regexp "^[-A-Z]*>+") - (setq ild-abort-string ":q" - ild-continue-string ":r" - ild-next-string ":up" - ild-next-string-arg ":up %s" - ild-previous-string ":down" - ild-previous-string-arg ":down %s" - ild-top-string ":down 1000000" - ild-bottom-string ":up 1000000" - ild-backtrace-string ":bt" - ild-locals-string ":fr" - ild-local-string-arg ":loc %s" - ild-return-string ":r" - ild-retry-string nil ;needs work - ild-trap-on-exit-string nil)) ;needs work -(setq akcl-program "akcl") - -(defdialect cmulisp "CMU Common LISP" clisp - (ilisp-load-init 'cmu "cmulisp") - (if cmulisp-local-source-directory - (setq ilisp-source-directory-fixup-alist - (list - (cons cmulisp-source-directory-regexp - cmulisp-local-source-directory))) - (message "cmulisp-local-source-directory not set.")) - (setq comint-prompt-regexp "^\\([0-9]+\\]+\\|\\*\\) " - ilisp-trace-command "(ILISP:cmulisp-trace \"%s\" \"%s\" \"%s\")" - comint-prompt-status - (function (lambda (old line) - (comint-prompt-status old line 'cmulisp-check-prompt))) - ilisp-error-regexp "ILISP:[^\"]*\\|Error [^\n]*" - ilisp-arglist-command "(ILISP:arglist \"%s\" \"%s\")" - ilisp-find-source-command "(ILISP:source-file \"%s\" \"%s\" \"%s\")" - comint-fix-error ":pop" - comint-continue ":go" - ilisp-reset ":q" - comint-interrupt-regexp "Interrupted at" - ilisp-binary-extension "sparcf") - (setq ild-abort-string ":abort" - ild-continue-string ":go" - ild-next-string ":down" - ild-next-string-arg nil ;needs work - ild-previous-string ":up" - ild-previous-string-arg nil ;needs work - ild-top-string ":bottom" - ild-bottom-string ":top" - ild-backtrace-string ":backtrace" - ild-locals-string ":l" - ild-local-string-arg "(debug:arg %s)" - ild-return-string nil ;needs work (debug:debug-return x) - ild-retry-string nil ;needs work - ild-trap-on-exit-string nil)) ;needs work -(setq cmulisp-program "cmucl") - -
--- a/lisp/ilisp/ilfsf18.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,99 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilfsf18.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - -;;;============================================================================ -;;; Prologue - -(if (string-match "2\.03" comint-version) - (fset 'comint-mem 'member)) - - -;;;============================================================================ -;;; Functions - -(defun add-hook (hook function) - " Add FUNCTION to HOOK's list. -Arguments are HOOK and FUNCTION. FUNCTION is not added if it's already -on the list." - (set hook - (if (boundp hook) - (let ((value (symbol-value hook))) - (if (and value (or (not (consp value)) (eq (car value) 'lambda))) - (setq value (cons value nil))) - (if (not (comint-mem function value)) - (setq value (append value (list function)))) - value) - (list function)))) - - -(defun ilisp-get-input-ring () - "Use instead of get-input-ring coming-input-ring or input-ring." - input-ring) - - -(defun ilisp-ring-insert (ring input) - "See 'ring-insert'." - (ring-insert ring input)) - - -(defun ilisp-temp-buffer-show-function-symbol () - "See 'temp-buffer-show-hook'." - 'temp-buffer-show-hook) - - -(defun set-ilisp-temp-buffer-show-function (val) - "See 'temp-buffer-show-hook' set function." - (setq temp-buffer-show-hook val)) - - -(defun ilisp-temp-buffer-show-function () - "See 'temp-buffer-show-hook'." - temp-buffer-show-hook) - - -(defun ilisp-input-ring-index () - "See 'input-ring-index'." - input-ring-index) - - -(defun set-ilisp-input-ring-index (n) - "See 'input-ring-index' set function." - (setq input-ring-index n)) - - -(defun ilisp-input-ring-size () - "See 'input-ring-size'." - input-ring-size) - - -(defun set-ilisp-input-ring-size (n) - "See 'input-ring-size' set function." - (setq input-ring-size n)) - - -;;;============================================================================ -;;; Epilogue - -(provide 'compat-fsf18) - -;;; end of file -- il-fsf18.el --
--- a/lisp/ilisp/ilfsf19.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,69 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilfsf19.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - -;;;============================================================================ -;;; Functions - -(defun ilisp-get-input-ring () - "Use instead of get-input-ring coming-input-ring or input-ring." - comint-input-ring) - - -(defun ilisp-ring-insert (ring input) - (ring-insert ring input)) - - -(defun ilisp-temp-buffer-show-function-symbol () - 'temp-buffer-show-function) - - -(defun set-ilisp-temp-buffer-show-function (val) - (setq temp-buffer-show-function val)) - - -(defun ilisp-temp-buffer-show-function () - temp-buffer-show-function) - - -(defun ilisp-input-ring-index () - comint-input-ring-index) - - -(defun set-ilisp-input-ring-index (n) - (setq comint-input-ring-index n)) - - -(defun ilisp-input-ring-size () - comint-input-ring-size) - - -(defun set-ilisp-input-ring-size (n) - (setq comint-input-ring-size n)) - - -;;;============================================================================ -;;; Epilogue - -(provide 'compat-fsf-19) - -;;; end of file -- fsf19.el --
--- a/lisp/ilisp/ilisp-acl.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,86 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp-acl.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - -;;; -;;; ILISP Allegro Common Lisp dialect definition -;;; - -;;; Various patches provided by Kimball Collins -;;; <kpc@ptolemy-ethernet.arc.nasa.gov> - - -;;;%%%Allegro -(defvar ilisp-allegro-init-file "allegro.lisp") - -(defun allegro-check-prompt (old new) - "Compare the break level printed at the beginning of the prompt." - (let* ((old-level (if (and old (eq 1 (string-match "[0-9]+" old))) - (string-to-int (substring old 1)) - 0)) - (new-level (if (eq 1 (string-match "[0-9]+" new)) - (string-to-int (substring new 1)) - 0))) - (<= new-level old-level))) - -;;; -(defdialect allegro "Allegro Common LISP" - clisp - (ilisp-load-init 'allegro ilisp-allegro-init-file) - (setq comint-fix-error ":pop" - ilisp-reset ":reset" - comint-continue ":cont" - comint-interrupt-regexp "Error: [^\n]* interrupt\)") - (setq comint-prompt-status - (function (lambda (old line) - (comint-prompt-status old line 'allegro-check-prompt)))) - ;; <cl> or package> at top-level - ;; [0-9c] <cl> or package> in error - ;; (setq comint-prompt-regexp "^\\(\\[[0-9]*c*\\] \\|\\)\\(<\\|\\)[^>]*> ") - ;; (setq comint-prompt-regexp "^\\(\\[[0-9]+i?c?\\] \\|\\[step\\]\\)?\\(<?[-A-Za-z]* ?[0-9]*?>\\|[-A-Za-z0-9]+([0-9]+):\\) ") - - ;; Patch by kpc 94/8/30: allow prompts that look like this: - ;; USER(23): USER(23): - (setq comint-prompt-regexp "^\\(\\(\\[[0-9]+i?c?\\] \\|\\[step\\] \\)?\\(<?[-A-Za-z]* ?[0-9]*?>\\|[-A-Za-z0-9]+([0-9]+):\\) \\)+") - - (setq ilisp-error-regexp - "\\(ILISP:[^\"]*\\)\\|\\(Error:[^\n]*\\)\\|\\(Break:[^\n]*\\)") - - (setq ilisp-binary-command "excl:*fasl-default-type*") - (setq ilisp-source-types (append ilisp-source-types '(("any")))) - - (setq ilisp-find-source-command - "(ILISP:ilisp-source-files \"%s\" \"%s\" \"%s\")") - (setq ilisp-init-binary-command - ;; Patch provided by kpc 94/8/30: distinguish among - ;; fasl-incompatible allegro versions - "(let ((ext (or #+m68k \"68fasl\" - #+sparc \"sfasl\" - #+iris4d \"ifasl\" - #+dec3100 \"pfasl\" - excl:*fasl-default-type*))) - #+allegro-v4.0 (setq ext (concatenate 'string ext \"40\")) - #+allegro-v4.1 (setq ext (concatenate 'string ext \"41\")) - #+allegro-v4.2 (setq ext (concatenate 'string ext \"42\")) - ext)")) -(if (not allegro-program) (setq allegro-program "cl")) -
--- a/lisp/ilisp/ilisp-aut.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,59 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp-aut.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - - -;;; -;;; ILISP autoloads -;;; -(autoload 'lisp-directory "ilisp-src" - "Select directories to search." t) -(autoload 'next-definition-lisp "ilisp-src" - "Edit the next definition." t) -(autoload 'edit-definitions-lisp "ilisp-src" - "Edit definitions." t) -(autoload 'search-lisp "ilisp-src" - "Search for pattern in source files." t) -(autoload 'replace-lisp "ilisp-src" - "Relace pattern in source files." t) -(autoload 'who-calls-lisp "ilisp-src" - "Show callers of a function." t) -(autoload 'next-caller-lisp "ilisp-src" - "Edit the next caller of a function." t) -(autoload 'edit-callers-lisp "ilisp-src" - "Edit the callers of a function." t) - -(autoload 'ilisp-bug "ilisp-bug" - "Send a mail message about a bug." t) - -;;;%%Changed definitions -(autoload 'mark-change-lisp "ilisp-bat" - "Mark the current defun as changed." t) -(autoload 'list-changes-lisp "ilisp-bat" - "List the current LISP changes." t) -(autoload 'clear-changes-lisp "ilisp-bat" - "Clear the list of LISP changes." t) -(autoload 'eval-changes-lisp "ilisp-bat" - "Evaluate the list of LISP changes." t) -(autoload 'compile-changes-lisp "ilisp-bat" - "Compile the list of LISP changes." t) -
--- a/lisp/ilisp/ilisp-bat.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,137 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp-bat.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - -;;; -;;; Inferior LISP interaction package batch submodule. - -;;; See ilisp.el for more information. -(defun mark-change-lisp (arg) - "Mark the current defun as being changed so that lisp-eval-changes, -or lisp-compile-changes will work on it. With a prefix, unmark." - (interactive "P") - (let (point name) - (save-excursion - (setq point (lisp-defun-begin) - name (lisp-def-name))) - (if arg - (let ((marker (car (lisp-memk point lisp-changes 'marker-position)))) - (message "%s marked as unchanged" name) - (setq lisp-changes (delq marker lisp-changes))) - (message "%s marked as changed" name) - (if (not (lisp-memk point lisp-changes 'marker-position)) - (let ((new (make-marker))) - (set-marker new point) - (setq lisp-changes (cons new lisp-changes))))))) - -;;; -(defun list-changes-lisp () - "List the name of LISP forms currently marked as being changed." - (interactive) - (let ((names (reverse (mapcar (function - (lambda (change) - (save-excursion - (set-buffer (marker-buffer change)) - (goto-char change) - (lisp-def-name)))) - lisp-changes)))) - (if names - (with-output-to-temp-buffer "*Changed-Definitions*" - (display-completion-list names) - (save-excursion - (set-buffer "*Changed-Definitions*") - (goto-char (point-min)) - (kill-line) - (insert "Changed LISP forms:"))) - (error "No changed definitions")))) - -;;; -(defun clear-changes-lisp () - "Clear the list of LISP forms currently marked as being changed." - (interactive) - (message "Cleared changes") - (setq lisp-changes nil)) - -;;; -(defun lisp-change-handler (&rest args) - "Handle an error during a batch process by keeping the change on the -list and passing it on to the normal error handler." - (let ((change (car ilisp-pending-changes))) - (if (and comint-errorp - (not (lisp-memk change lisp-changes 'marker-position))) - (setq lisp-changes (nconc lisp-changes (cons change nil))))) - (setq ilisp-pending-changes (cdr ilisp-pending-changes)) - (apply comint-handler args)) - -;;; -(defun lisp-changes (command message) - "Apply COMMAND to each of the changes and use MESSAGE to print a -message given the name of the change. If there is a positive prefix, -the change list will not be changed." - (save-excursion - (set-buffer (ilisp-buffer)) - (let ((keep (and current-prefix-arg (not (eq current-prefix-arg '-)))) - (changes (reverse lisp-changes)) - (lisp-wait-p nil)) - (setq ilisp-pending-changes (nconc ilisp-pending-changes changes) - current-prefix-arg nil) ;Prevent buffer insertion - (if comint-queue-emptied - (save-excursion - (setq comint-queue-emptied nil) - (set-buffer (get-buffer-create "*Errors*")) - (delete-region (point-min) (point-max)))) - (while changes - (let* ((change (car changes)) - name) - (set-buffer (marker-buffer change)) - (goto-char change) - (setq name (lisp-def-name)) - (forward-sexp) - (funcall command change (point) nil (format message name) - nil 'lisp-change-handler) - (setq changes (cdr changes)))) - (comint-send-code - (ilisp-process) - (function (lambda () - (save-excursion - (set-buffer (get-buffer-create "*Last-Changes*")) - (delete-region (point-min) (point-max)) - (insert (save-excursion - (set-buffer "*Errors*") - (buffer-string))))))) - (if keep - (message "Started, but keeping changes") - (message "Started changes") - (setq lisp-changes nil))))) - -;;; -(defun eval-changes-lisp () - "Evaluate the forms marked as being changed. With prefix, do not -clear the change list." - (interactive) - (lisp-changes 'eval-region-lisp "Evaluate changed %s")) - -;;; -(defun compile-changes-lisp () - "Compile the forms marked as being changed. With prefix, do not -clear the change list." - (interactive) - (lisp-changes 'compile-region-lisp "Compile changed %s"))
--- a/lisp/ilisp/ilisp-bug.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,124 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp-bug.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - -;;; -;;; ILISP bug stuff. -;;; - -;;; -;;;%Bugs -(defun ilisp-bug () - "Generate an ilisp bug report." - (interactive) - (let ((buffer - (if (y-or-n-p - (format "Is %s the buffer where the error occurred? " - (buffer-name (current-buffer)))) - (current-buffer)))) - (if (or (not buffer) (not (mail))) - (progn - (message - (if buffer - "Can't send bug report until mail buffer is empty." - "Switch to the buffer where the error occurred.")) - (beep)) - (insert ilisp-bugs-to) - (search-forward (concat "\n" mail-header-separator "\n")) - (insert "\nYour problem: \n\n") - (insert "Type C-c C-c to send\n") - (insert "======= Emacs state below: for office use only =======\n") - (forward-line 1) - (insert (emacs-version)) - (insert - (format "\nWindow System: %s %s" window-system window-system-version)) - (let ((mode (save-excursion (set-buffer buffer) major-mode)) - (match "popper-\\|completer-") - (val-buffer buffer) - string) - (if (or (memq mode lisp-source-modes) (memq mode ilisp-modes)) - (progn - (setq match (concat "ilisp-\\|comint-\\|lisp-" match) - val-buffer (save-excursion (set-buffer buffer) - (or (ilisp-buffer) buffer))) - (mapcar (function (lambda (dialect) - (setq match (concat (format "%s-\\|" (car dialect)) - match)))) - ilisp-dialects) - (save-excursion - (set-buffer buffer) - (let ((point (point)) - (start (lisp-defun-begin)) - (end (lisp-end-defun-text t))) - (setq string - (format " -Mode: %s -Start: %s -End: %s -Point: %s -Point-max: %s -Code: %s" - major-mode start end point (point-max) - (buffer-substring start end))))) - (insert string))) - (mapatoms - (function (lambda (symbol) - (if (and (boundp symbol) - (string-match match (format "%s" symbol)) - (not (eq symbol 'ilisp-documentation))) - (let ((val (save-excursion - (set-buffer val-buffer) - (symbol-value symbol)))) - (if val - (insert (format "\n%s: %s" symbol val)))))))) - (insert (format "\nLossage: %s" (key-description (recent-keys)))) - (if (and (or (memq mode lisp-source-modes) - (memq mode ilisp-modes)) - (ilisp-buffer) - (memq 'clisp (ilisp-value 'ilisp-dialect t)) - (not (cdr (ilisp-value 'comint-send-queue)))) - (progn - (insert (format "\nLISP: %s" - (comint-remove-whitespace - (car (comint-send - (save-excursion - (set-buffer buffer) - (ilisp-process)) - "(lisp-implementation-version)" - t t 'version))))) - (insert (format "\n*FEATURES*: %s" - (comint-remove-whitespace - (car (comint-send - (save-excursion - (set-buffer buffer) - (ilisp-process)) - "(let ((*print-length* nil) - (*print-level* nil)) - (print *features*) - nil)" - t t 'version))))))) - (insert ?\n) - (goto-char (point-min)) - (re-search-forward "^Subject") - (end-of-line) - (message "Send with sendmail or your favorite mail program."))))) -
--- a/lisp/ilisp/ilisp-chs.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,57 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp-chs.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - -;;; -;;; CLISP Common Lisp by Bruno Haible and XX Stoll dialect definition -;;; - -;;; clisp-hs-check-prompt doesn't after the first break because the -;;; number of ">" characters doesn't increase. - -(defun clisp-hs-check-prompt (old new) - "Compare the break level printed at the beginning of the prompt." - (let* ((was-in-break (and old (string-match "Break>" old))) - (old-level (if was-in-break - (- (match-end 0) (match-beginning 0)) - 0)) - (is-in-break (string-match "Break>" new)) - (new-level (if is-in-break - (- (match-end 0) (match-beginning 0)) - 0))) - (<= new-level old-level))) - -;;; -(defdialect clisp-hs "CLISP H.S." clisp - (setq comint-prompt-regexp "^\\([0-9]+\\. Break>\\|>\\)" - ilisp-error-regexp "^\\*\\* " - ilisp-binary-extension "fas" - comint-fix-error "Abort" - comint-continue "Continue" - comint-prompt-status - (function - (lambda (old line) - (comint-prompt-status old line 'clisp-hs-check-prompt))))) - -(if (not clisp-hs-program) (setq clisp-hs-program "clisp")) - -(provide 'ilisp-chs)
--- a/lisp/ilisp/ilisp-cl.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,142 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp-cl.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - -;;; -;;; ILISP Common Lisp dialect definition -;;; - - -;;;%%Common LISP - -(defvar ilisp-cl-ilisp-package-file "ilisp-pkg.lisp") - -(defvar ilisp-clisp-init-file "cl-ilisp.lisp") - -(defdialect clisp "Common LISP" - ilisp - (setq ilisp-load-or-send-command - "(or (and (load \"%s\" :if-does-not-exist nil) t) - (and (load \"%s\" :if-does-not-exist nil) t))") - - ;; The following line is an incredible kludge to bypass the behavior - ;; of ilisp-load-init and to stick the package file in front of - ;; everything. - ;; Check what ilisp-load-init does to understand why I am forced to - ;; do this. - ;; Marco Antoniotti 11/22/94 - (ilisp-load-init 'ilisp-package-kludge ilisp-cl-ilisp-package-file) - - (ilisp-load-init 'clisp ilisp-clisp-init-file) - (setq ilisp-package-regexp - "^[ \t]*(in-package[ \t\n]*" - - ilisp-package-command - "(let ((*package* *package*)) %s (package-name *package*))" - - ilisp-package-name-command - "(package-name *package*)" - - ilisp-in-package-command - "(in-package \"%s\")" - - ilisp-last-command - "*" - - ilisp-save-command - "(progn (ILISP:ilisp-save) %s\n)" - - ilisp-restore-command - "(ILISP:ilisp-restore)" - - ilisp-block-command - "(progn %s\n)" - - ilisp-eval-command - "(ILISP:ilisp-eval \"%s\" \"%s\" \"%s\")" - - ilisp-defvar-regexp - "(defvar[ \t\n]") - - (setq ilisp-defvar-command - "(ILISP:ilisp-eval \"(let ((form '%s)) (progn (makunbound (second form)) (eval form)))\" \"%s\" \"%s\")") - - (setq ilisp-compile-command - "(ILISP:ilisp-compile \"%s\" \"%s\" \"%s\")" - - ilisp-describe-command - "(ILISP:ilisp-describe \"%s\" \"%s\")" - - ilisp-inspect-command - "(ILISP:ilisp-inspect \"%s\" \"%s\")" - - ilisp-arglist-command - "(ILISP:ilisp-arglist \"%s\" \"%s\")") - - (setq ilisp-documentation-types - '(("function") ("variable") - ("structure") ("type") - ("setf") ("class") - ("(qualifiers* (class ...))"))) - - (setq ilisp-documentation-command - "(ILISP:ilisp-documentation \"%s\" \"%s\" \"%s\")") - - (setq ilisp-macroexpand-1-command - "(ILISP:ilisp-macroexpand-1 \"%s\" \"%s\")") - - (setq ilisp-macroexpand-command - "(ILISP:ilisp-macroexpand \"%s\" \"%s\")") - - (setq ilisp-complete-command - "(ILISP:ilisp-matching-symbols \"%s\" \"%s\" %s %s %s)") - - (setq ilisp-locator 'lisp-locate-clisp) - - (setq ilisp-source-types - '(("function") ("macro") ("variable") - ("structure") ("type") - ("setf") ("class") - ("(qualifiers* (class ...))"))) - - (setq ilisp-callers-command - "(ILISP:ilisp-callers \"%s\" \"%s\")" - - ilisp-trace-command - "(ILISP:ilisp-trace \"%s\" \"%s\" \"%s\")" - - ilisp-untrace-command - "(ILISP:ilisp-untrace \"%s\" \"%s\")") - - (setq ilisp-directory-command - "(namestring *default-pathname-defaults*)" - - ilisp-set-directory-command - "(setq *default-pathname-defaults* (parse-namestring \"%s\"))") - - (setq ilisp-load-command - "(load \"%s\")") - - (setq ilisp-compile-file-command - "(ILISP:ilisp-compile-file \"%s\" \"%s\")")) - -;;; end of file -- ilisp-cl.el --
--- a/lisp/ilisp/ilisp-cmp.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,335 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp-cmp.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - - -;;; -;;; ILISP completion -;;; -;;; -;;;%Completion -;;; The basic idea behind the completion stuff is to use as much of -;;; the standard Emacs stuff as possible. The extensions here go out -;;; to the inferior LISP to complete symbols if necessary. -;;; -(defun ilisp-display-choices (symbol choices) - "Display the possible choices for SYMBOL in alist CHOICES." - (with-output-to-temp-buffer "*Completions*" - (display-completion-list - (sort - (all-completions (lisp-symbol-name symbol) choices) - 'string-lessp)))) - -;;;%%ilisp-can-complete -(defun ilisp-can-complete (symbol function-p) - "Return T if ilisp completion can complete SYMBOL from the current table." - (and ilisp-original - (string= (lisp-symbol-package ilisp-original) - (lisp-symbol-package symbol)) - (string= (lisp-symbol-delimiter ilisp-original) - (lisp-symbol-delimiter symbol)) - (lisp-prefix-p (lisp-symbol-name ilisp-original) - (lisp-symbol-name symbol)) - (eq function-p ilisp-original-function-p))) - -;;;%%ilisp-complete -(defun ilisp-complete (symbol &optional function-p) - "Return a list of the possible completions for symbol from the -inferior LISP. If FUNCTION-P is T, only symbols with function -bindings will be considered. If no package is specified the buffer -package will be used." - (let* ((choices - (ilisp-send - (format (ilisp-value 'ilisp-complete-command) - (lisp-symbol-name symbol) (lisp-symbol-package symbol) - function-p - (string= (lisp-symbol-delimiter symbol) ":") - ilisp-prefix-match) - (if (not ilisp-complete) - (concat "Complete " - (if function-p "function ") - (lisp-buffer-symbol symbol))) - 'complete))) - (if (ilisp-value 'comint-errorp t) - (progn (lisp-display-output choices) - (error "Error completing %s" (lisp-buffer-symbol symbol))) - (setq choices (read choices) - choices (if (eq choices 'NIL) nil choices))) - (setq ilisp-original symbol - ilisp-original-function-p function-p - ilisp-original-table choices))) - -;;;%%ilisp-completion-table -(defun ilisp-completion-table (symbol function-p) - "Return the completion table for SYMBOL trying to use the current -one. If FUNCTION-P is T, only symbols with function cells will be -returned." - (if (ilisp-can-complete symbol function-p) - ilisp-original-table - (ilisp-complete symbol function-p))) - -;;;%%Minibuffer completion -(defun ilisp-restore-prefix () - "Restore the prefix from ilisp-mini-prefix at the start of the -minibuffer." - (if ilisp-mini-prefix - (save-excursion - (goto-char (point-min)) - (insert ilisp-mini-prefix) - (setq ilisp-mini-prefix nil)))) - -;;; -(defun ilisp-current-choice () - "Set up the minibuffer completion table for the current symbol. -If there is a paren at the start of the minibuffer, or there is not an -ilisp-table, this will be from the inferior LISP. Otherwise, it will -be the ilisp-table." - (if (or (null ilisp-table) (eq (char-after 1) ?\()) - (progn - (let* ((symbol-info (lisp-previous-symbol)) - (symbol (car symbol-info))) - (setq minibuffer-completion-table - (ilisp-completion-table symbol ilisp-completion-function-p))) - (save-excursion - (skip-chars-backward "^: \(") - (setq ilisp-mini-prefix (buffer-substring (point-min) (point))) - (delete-region (point-min) (point))) - ;; Nothing can match this table - (if (not minibuffer-completion-table) - (setq minibuffer-completion-table '((" "))))) - (setq minibuffer-completion-table ilisp-table - minibuffer-completion-predicate nil))) - -;;;%%Commands -(defvar ilisp-completion-help - (lookup-key minibuffer-local-must-match-map "?")) -(defun ilisp-completion-help () - "Inferior LISP minibuffer completion help." - (interactive) - (ilisp-current-choice) - (funcall ilisp-completion-help) - (ilisp-restore-prefix)) - -;;; -(defvar ilisp-completion - (lookup-key minibuffer-local-must-match-map "\t")) -(defun ilisp-completion () - "Inferior LISP minibuffer complete." - (interactive) - (ilisp-current-choice) - (funcall ilisp-completion) - (ilisp-restore-prefix)) - -;;; -(defvar ilisp-completion-word - (lookup-key minibuffer-local-must-match-map " ")) -(defun ilisp-completion-word () - "Inferior LISP minibuffer complete word." - (interactive) - (if (eq (char-after 1) ?\() - (insert " ") - (ilisp-current-choice) - (funcall ilisp-completion-word) - (ilisp-restore-prefix))) - -;;; -(defun ilisp-completion-paren () - "Only allow a paren if ilisp-paren is T." - (interactive) - (if ilisp-paren - (if (or (eq last-input-char ?\() (eq (char-after 1) ?\()) - (insert last-input-char) - (beep)) - (beep))) - -;;; -(defvar ilisp-completion-exit - (lookup-key minibuffer-local-must-match-map "\n")) -(defun ilisp-completion-exit () - "Inferior LISP completion complete and exit." - (interactive) - (if (eq (char-after 1) ?\() - (progn (find-unbalanced-lisp nil) - (exit-minibuffer)) - (if ilisp-no-complete - (exit-minibuffer) - (if (= (point-min) (point-max)) - (exit-minibuffer) - (ilisp-current-choice) - (unwind-protect (funcall ilisp-completion-exit) - (ilisp-restore-prefix)))))) - -;;;%%ilisp-completer -(defun ilisp-completer (symbol function-p) - "Complete SYMBOL from the inferior LISP using only function symbols -if FUNCTION-P is T. Return (SYMBOL LCS-SYMBOL CHOICES UNIQUEP)." - (let* ((name (lisp-symbol-name symbol)) - (table (ilisp-completion-table symbol function-p)) - (choice (and table (try-completion name table)))) - (cond ((eq choice t) ;Name is it - (list symbol symbol nil t)) - ((string= name choice) ;Name is LCS - (list symbol symbol (all-completions name table) nil)) - (choice ;New LCS - (let ((symbol - (lisp-symbol (lisp-symbol-package symbol) - (lisp-symbol-delimiter symbol) - choice))) - (list symbol symbol (all-completions choice table) nil))) - ((and (not ilisp-prefix-match) table) ;Try partial matches - (let ((matches - (completer name table nil (regexp-quote completer-words)))) - (cons (lisp-symbol (lisp-symbol-package symbol) - (lisp-symbol-delimiter symbol) - (car matches)) - (cons (lisp-symbol (lisp-symbol-package symbol) - (lisp-symbol-delimiter symbol) - (car (cdr matches))) - (cdr (cdr matches))))))))) - - -;;;%%ilisp-read -(defun ilisp-completion-map () - "Set up the ilisp-completion-map from lisp-mode-map for the ilisp -readers and return it." - (if (not ilisp-completion-map) - (progn - (if (fboundp 'set-keymap-parent) - (progn - (setq ilisp-completion-map (make-sparse-keymap)) - (set-keymap-parent ilisp-completion-map lisp-mode-map)) - (setq ilisp-completion-map (copy-keymap lisp-mode-map))) - (define-key ilisp-completion-map " " 'ilisp-completion-word) - (define-key ilisp-completion-map "\t" 'ilisp-completion) - (define-key ilisp-completion-map "?" 'ilisp-completion-help) - (define-key ilisp-completion-map "\M-\t" 'ilisp-completion) - (define-key ilisp-completion-map "\n" 'ilisp-completion-exit) - (define-key ilisp-completion-map "\r" 'ilisp-completion-exit) - (define-key ilisp-completion-map "\C-g" 'abort-recursive-edit) - (define-key ilisp-completion-map "(" 'ilisp-completion-paren) - (define-key ilisp-completion-map ")" 'ilisp-completion-paren) - (define-key ilisp-completion-map "'" nil) - (define-key ilisp-completion-map "#" nil) - (define-key ilisp-completion-map "\"" nil))) - ilisp-completion-map) - -;;; -(defun ilisp-read (prompt &optional initial-contents) - "PROMPT in the minibuffer with optional INITIAL-CONTENTS and return -the result. Completion of symbols though the inferior LISP is -allowed." - (let ((ilisp-complete t) - (ilisp-paren t) - (ilisp-no-complete t) - (ilisp-completion-package (lisp-buffer-package))) - (read-from-minibuffer prompt initial-contents - (ilisp-completion-map)))) - -;;;%%lisp-read-program -(defvar lisp-program-map nil - "Minibuffer map for reading a program and arguments.") - -;;; -(defun lisp-read-program (prompt &optional initial) - "Read a program with PROMPT and INITIAL. TAB or Esc-TAB will complete -filenames." - (if (null lisp-program-map) - (progn - (if (fboundp 'set-keymap-parent) - (progn - (setq lisp-program-map (make-sparse-keymap)) - (set-keymap-parent lisp-program-map minibuffer-local-map)) - (setq lisp-program-map (copy-keymap minibuffer-local-map))) - (define-key lisp-program-map "\M-\t" 'comint-dynamic-complete) - (define-key lisp-program-map "\t" 'comint-dynamic-complete) - (define-key lisp-program-map "?" 'comint-dynamic-list-completions))) - (read-from-minibuffer prompt initial lisp-program-map)) - -;;;%%ilisp-read-symbol -(defun ilisp-read-symbol (prompt &optional default function-p no-complete) - "PROMPT in the minibuffer with optional DEFAULT and return a symbol -from the inferior LISP. If FUNCTION-P is T, only symbols with -function values will be returned. If NO-COMPLETE is T, then -uncompleted symbols will be allowed." - (let* ((ilisp-complete t) - (ilisp-no-complete no-complete) - (ilisp-completion-package (lisp-buffer-package)) - (ilisp-completion-function-p function-p) - (string (read-from-minibuffer prompt nil (ilisp-completion-map)))) - (if (equal string "") - default - (lisp-string-to-symbol string)))) - -;;;%%ilisp-completing-read -(defun ilisp-completing-read (prompt table &optional default) - "Read with PROMPT from an alist of TABLE. No input returns DEFAULT. -Symbols are from table, other specs are in parentheses." - (let* ((ilisp-complete t) - (ilisp-table table) - (ilisp-completion-package (lisp-buffer-package)) - (ilisp-paren - (let ((entry table) (done nil)) - (while (and entry (not done)) - (setq done (= (elt (car (car entry)) 0) ?\() - entry (cdr entry))) - done)) - (string (read-from-minibuffer prompt nil (ilisp-completion-map)))) - (if (string= string "") default string))) - - - -;;;%%complete-lisp -(autoload 'complete "completion" "Complete previous symbol." t) -(defun complete-lisp (mode) - "Complete the current symbol using information from the current -ILISP buffer. If in a string, complete as a filename. If called with -a positive prefix force all symbols to be considered. If called with -a negative prefix, undo the last completion. Partial completion is -allowed unless ilisp-prefix-match is T. If a symbol starts after a -left paren or #', then only function symbols will be considered. -Package specifications are also allowed and the distinction between -internal and exported symbols is considered." - (interactive "P") - (if (< (prefix-numeric-value mode) 0) - (completer-undo) - (let* ((filep - (save-excursion - (skip-chars-backward "^ \t\n") - (= (char-after (point)) ?\")))) - (if filep - (comint-dynamic-complete) - (let* ((symbol-info (lisp-previous-symbol)) - (symbol (car symbol-info)) - (name (lisp-symbol-name symbol)) - (choice (ilisp-completer - symbol - (if (not mode) (car (cdr symbol-info))))) - (match (lisp-buffer-symbol (car choice))) - (lcs (lisp-buffer-symbol (car (cdr choice)))) - (choices (car (cdr (cdr choice)))) - (unique (car (cdr (cdr (cdr choice)))))) - (skip-chars-backward " \t\n") - (completer-goto match lcs choices unique - (ilisp-value 'ilisp-symbol-delimiters) - completer-words))) - (message "Completed")))) -
--- a/lisp/ilisp/ilisp-cmt.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,88 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp-cmt.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - -;;; -;;; ILISP comint interface code. -;;; -;;; - - -;;;%Process interface -;;;%%Comint -(defun ilisp-get-old-input () - "Snarf the sexp starting at the nearest previous prompt, or NIL if none." - (save-excursion - (let* ((begin (lisp-defun-begin)) - (pmark (process-mark (get-buffer-process (current-buffer)))) - (once (if (< (point) pmark) - (save-excursion (end-of-line) (point)))) - (end nil) - (done nil)) - (condition-case () - (while (and (not done) (< (point) (point-max))) - (forward-sexp) - (setq end (point)) - (skip-chars-forward " \t\n") - (if (and once (>= (point) once)) (setq done t))) - (error (setq end nil))) - (if end (buffer-substring begin end))))) - -;;; -(defun ilisp-input-filter (str) - "Don't save anything matching ilisp-filter-regexp or less than -ilisp-filter-length long." - (and (not (string-match ilisp-filter-regexp str)) - (> (length str) ilisp-filter-length))) - -;;; -(defun ilisp-error-filter (output) - "Keep from OUTPUT only what matches ilisp-error-regexp or everything -if there is no match." - (if (string-match (ilisp-value 'ilisp-error-regexp) output) - (substring output (match-beginning 0) (match-end 0)) - output)) - - - -(defun newline-and-indent-lisp () - "If at the end of the buffer, send the string back to the process -mark with no newline. Otherwise, insert a newline, then indent. In -an ilisp buffer the region is narrowed first. See newline-and-indent -for more information." - (interactive "*") - (if ilisp-complete - (exit-minibuffer) - (let (input) - (if (and (= (point) (point-max)) - (memq major-mode ilisp-modes) - (setq input (ilisp-get-old-input))) - (let ((process (ilisp-process)) - (comint-send-newline (not comint-send-newline))) - (funcall comint-input-sender process input) - (set-marker (process-mark process) (point))) - (save-restriction - (if (memq major-mode ilisp-modes) - (narrow-to-region (save-excursion (lisp-input-start)) - (point-max))) - (newline-and-indent)))))) -
--- a/lisp/ilisp/ilisp-cmu.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,101 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp-cmu.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - -;;; -;;; ILISP CMU Common Lisp dialect definition -;;; -;;;%%%CMULisp - -(defvar cmulisp-source-directory-regexp - "\\/afs\\/cs\\.cmu\\.edu\\/project\\/clisp\\/src\\/[0-9]*\\/" - "*Regexp to match cmulisp source code directory.") - -(defvar cmulisp-local-source-directory - nil - "*Where the cmulisp sources really are.") - -(defvar ilisp-cmulisp-init-file "cmulisp.lisp") - -(defun cmulisp-source-directory-fixup-function () - (if cmulisp-local-source-directory - (replace-match cmulisp-local-source-directory))) - -(defun cmulisp-check-prompt (old new) - "Compare the break level printed at the beginning of the prompt." - (let* ((was-in-break (and old (string-match "]+" old))) - (old-level (if was-in-break - (- (match-end 0) (match-beginning 0)) - 0)) - (is-in-break (string-match "]+" new)) - (new-level (if is-in-break - (- (match-end 0) (match-beginning 0)) - 0))) - (<= new-level old-level))) - -;;; -(defdialect cmulisp "CMU Common LISP" - clisp - (ilisp-load-init 'cmu ilisp-cmulisp-init-file) - (if cmulisp-local-source-directory - (setq ilisp-source-directory-fixup-alist - (list - (cons cmulisp-source-directory-regexp - cmulisp-local-source-directory))) - (message "cmulisp-local-source-directory not set.")) - (setq comint-prompt-regexp "^\\([0-9]+\\]+\\|\\*\\) " - ilisp-trace-command "(ILISP:cmulisp-trace \"%s\" \"%s\" \"%s\")" - comint-prompt-status - (function (lambda (old line) - (comint-prompt-status old line 'cmulisp-check-prompt))) - - ilisp-error-regexp "ILISP:[^\"]*\\|Error [^\n]*\n\n" - ;; The above regexp has been suggested by - ;; hunter@work.nlm.nih.gov (Larry Hunter) - - ilisp-arglist-command "(ILISP:arglist \"%s\" \"%s\")" - - ilisp-find-source-command "(ILISP:source-file \"%s\" \"%s\" \"%s\")" - - comint-fix-error ":pop" - - comint-continue ":go" - - ilisp-reset ":q" - - comint-interrupt-regexp "Interrupted at") - - (if (progn - (shell-command "uname -s") - (save-excursion - (set-buffer "*Shell Command Output*") - (goto-char (point-min)) - (looking-at "[Ll]inux"))) - (setq - ilisp-binary-extension "x86f" - ilisp-init-binary-extension "x86f" - ilisp-binary-command "\"x86f\"") - ;; else assume sparc. - (setq ilisp-binary-extension "sparcf" - ilisp-init-binary-extension "sparcf" - ilisp-binary-command "\"sparcf\""))) -
--- a/lisp/ilisp/ilisp-cpat.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,128 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp-cpat.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - - -;;; -;;; -;;; Compatability between GNU emacs 18, 19, and Lucid emacs 19. -;;; -;;; -(defconst ilisp-emacs-version-id - (cond ((string-match "Lucid" emacs-version) - (if (string-match "^19.[0-7][^0-9]" emacs-version) - 'lucid-19 - 'lucid-19-new)) - ((string-match "^19" emacs-version) - 'gnu-19) - (t 'gnu-18)) - "What version of emacs we are running.") - - -;; Hook stuff--this should really be a part of emacs-lisp anyway - -(defun ilisp-member (elt list) - (let ((result nil)) - (while list - (cond ((equal elt (car list)) - (setq result list - list nil)) - (t - (setq list (cdr list))))) - result)) - - -(defun ilisp-add-hook (hook function) - "Arguments are HOOK and FUNCTION. Add FUNCTION to HOOK's list. -FUNCTION is not added if it's already on the list." - (set hook - (if (boundp hook) - (let ((value (symbol-value hook))) - (if (and value (or (not (consp value)) (eq (car value) 'lambda))) - (setq value (cons value nil))) - (if (not (ilisp-member function value)) - (setq value (append value (list function)))) - value) - (list function)))) - -(if (not (fboundp 'add-hook)) - (fset 'add-hook 'ilisp-add-hook)) - - -;;; 'ilisp-where-is' has been moved (and corrected) to ilisp-key.el. - -;;; -;;; COMINT -;;; -;;; GNU, Lucid and 18 use different versions of comint with -;;; incompatible interface variables and functions. Hooray. -;;; - -;; Some very old COMINT versions are missing these. -(if (not (boundp 'comint-input-chunk-size)) - (setq comint-input-chunk-size 512)) -(if (not (boundp 'comint-ptyp)) - (setq comint-ptyp t)) - - -(defun ilisp-get-input-ring () - "Use instead of get-input-ring coming-input-ring or input-ring." - (cond ((eq ilisp-emacs-version-id 'lucid-19) - (get-input-ring)) - ((or (eq ilisp-emacs-version-id 'gnu-19) - (eq ilisp-emacs-version-id 'lucid-19-new)) - comint-input-ring) - (t input-ring))) - -(defun ilisp-ring-insert (ring input) - (if (eq ilisp-emacs-version-id 'lucid-19) - (ring-insert-new ring input) - (ring-insert ring input))) - -(defun ilisp-temp-buffer-show-function () - (if (eq ilisp-emacs-version-id 'gnu-18) - temp-buffer-show-hook - temp-buffer-show-function)) - -(defun ilisp-input-ring-index () - (if (or (eq ilisp-emacs-version-id 'gnu-19) - (eq ilisp-emacs-version-id 'lucid-19-new)) - comint-input-ring-index - input-ring-index)) - -(defun set-ilisp-input-ring-index (n) - (if (or (eq ilisp-emacs-version-id 'gnu-19) - (eq ilisp-emacs-version-id 'lucid-19-new)) - (setq comint-input-ring-index n) - (setq input-ring-index n))) - -(defun ilisp-input-ring-size () - (if (or (eq ilisp-emacs-version-id 'gnu-19) - (eq ilisp-emacs-version-id 'lucid-19-new)) - comint-input-ring-size - input-ring-size)) - -(defun set-ilisp-input-ring-size (n) - (if (or (eq ilisp-emacs-version-id 'gnu-19) - (eq ilisp-emacs-version-id 'lucid-19-new)) - (setq comint-input-ring-size n) - (setq input-ring-size n)))
--- a/lisp/ilisp/ilisp-def.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,378 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp-def.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - - -;;; -;;; ILISP defvar's -;;; - -;;;%Variables -;;;%%Deflocal -(defvar ilisp-locals '(comint-prompt-regexp - input-ring-size - comint-get-old-input - comint-input-sentinel - comint-input-filter - comint-input-sender - comint-eol-on-send - comint-send-newline - comint-always-scroll - comint-fix-error - comint-continue - comint-interrupt-regexp - comint-error-regexp - comint-output-filter - comint-interrupt-start - comint-handler - comint-update-status - comint-prompt-status - comint-abort-hook) - "List of ilisp local variables.") -(defun lisp-deflocal (local) - (if (not (memq local ilisp-locals)) - (setq ilisp-locals (cons local ilisp-locals)))) - - -;;; -(defmacro deflocal (variable default &optional documentation) - "Define an ilisp local variable." - (` (progn (lisp-deflocal '(, variable)) - (defvar (, variable) (, default) (, documentation))))) - -;;;%%Simple customization -(defvar ilisp-prefix "\C-c" "Prefix sequence for ilisp commands.") - -(deflocal ilisp-program nil - "*Program and arguments for invoking an inferior LISP. The program -can be an rsh to run on a remote machine. If there is not a common -file system, the interface files will be sent down the pipe instead. -The value of this variable is set from DIALECT-program, or inherited -from a less specific dialect if DIALECT-program is nil.") - -(defvar ilisp-motd - "ILISP V%s Use M-x ilisp-bug for problems and suggestions." - "*Message of the day format string for ILISP given VERSION. To -prevent any message from being printed, set this to nil.") - -(defvar lisp-wait-p nil - "*T if LISP eval/compile commands should wait for the result. A -minus prefix to the command will change the sense of this switch for -just the next command.") - -(defvar lisp-no-popper 'message - "*T if you want all output in the inferior LISP rather than in a -pop-up window. 'message if you want output of one line to go to the -message window (or to the inferior LISP if more). You should probably -also set comint-always-scroll to T as well so that output is always visible.") - -(defvar lisp-show-status t - "*Set to nil to stop showing process status in lisp-mode buffers.") - -(defvar ilisp-prefix-match nil - "*Set to T to match only as a prefix when completing through the -inferior LISP. This will speed up completion, but you no longer get -partial completion.") - -(deflocal ilisp-filter-regexp nil - "*What not to save on an inferior LISP's input history. -Input matching this regexp is not saved on the input history in ilisp -mode.") - -(deflocal ilisp-filter-length 3 - "*Do not save strings less than this in the command history.") - -(deflocal ilisp-other-prompt nil - "*Regexp to recognise prompts in the inferior LISP that are prompts -of non-(read/eval/print) top-levels so that bol-ilisp skips them.") - -(deflocal ilisp-raw-echo nil - "*Set this to T to cause echoing in raw keyboard mode.") - -(deflocal ilisp-load-no-compile-query nil - "*Set this to T to stop load querying about compile.") - -;;;%%%Hooks -(defvar ilisp-site-hook nil - "Hook for site customization of ilisp mode when it is loaded.") - -(defvar ilisp-load-hook '() - "Hook for customizing ilisp mode when it is loaded.") - -(defvar ilisp-mode-hook '() - "Hook for customizing ilisp mode.") - -(deflocal ilisp-init-hook nil - "Hook of functions to call on first prompt in inferior LISP.") - -;;;%%Advanced customization -;;;%%%Commands -(deflocal ilisp-reset nil - "String for resetting the top-level of the inferior LISP.") - -(deflocal ilisp-load-or-send-command nil - "Format string for loading BINARY if possible otherwise loading -FILE. If you can't load either, return NIL.") - -(deflocal ilisp-package-regexp nil - "Regular expression for finding a package specification in a buffer. -The entire sexp starting with this pattern will be passed to -ilisp-package-command to find the package.") - -(deflocal ilisp-package-command nil - "Format string to find the package given PACKAGE.") - -(deflocal ilisp-package-name-command nil - "Format string to return the name of the current package.") - -(deflocal ilisp-in-package-command nil - "Format string to set the package given PACKAGE.") - -(deflocal ilisp-last-command nil - "Format string for getting the last returned value.") - -(deflocal ilisp-save-command nil - "Format string for saving result history given FORM.") - -(deflocal ilisp-restore-command nil - "Format string for restoring result history.") - -(deflocal ilisp-block-command nil - "Format string for grouping FORMS into one.") - -(deflocal ilisp-eval-command nil - "Format string for evaluating FORM in PACKAGE from FILE.") - -(deflocal ilisp-defvar-regexp nil - "Regular expression for identifying a defvar form.") - -(deflocal ilisp-defvar-command nil - "Format string for re-evaluating DEFVAR in PACKAGE from FILE.") - -(deflocal ilisp-describe-command nil - "Format string for describing FORM in PACKAGE.") - -(deflocal ilisp-compile-command nil - "Format string for compiling FORM in PACKAGE.") - -(deflocal ilisp-inspect-command nil - "Format string for inspecting FORM in PACKAGE.") - -(deflocal ilisp-arglist-command nil - "Format string for arglist of SYMBOL in PACKAGE.") - -(deflocal ilisp-documentation-types nil - "((\"type\") ...) possible LISP documentation types.") - -(deflocal ilisp-documentation-command nil - "Format string for documentation given SYMBOL in PACKAGE and TYPE.") - -(deflocal ilisp-macroexpand-1-command nil - "Format string for top-level macroexpand given FORM and PACKAGE.") - -(deflocal ilisp-macroexpand-command nil - "Format string for macroexpand given FORM and PACKAGE.") - -(deflocal ilisp-complete-command nil - "Format string for finding possibly matching symbols given SYMBOL, -PACKAGE, FUNCTIONP, EXTERNALP and PARTIAL-MATCHP. It should print -((string) (string) ...).") - -(deflocal ilisp-callers-command nil - "Format for finding the callers of SYMBOL in PACKAGE. The function -should print out callers with one per line.") - -(deflocal ilisp-trace-command nil - "Format for tracing SYMBOL in PACKAGE.") -(deflocal ilisp-untrace-command nil - "Format for untracing SYMBOL in PACKAGE.") - -(deflocal ilisp-directory-command nil - "Format for getting default DIRECTORY.") -(deflocal ilisp-set-directory-command nil - "Format for setting default DIRECTORY.") - -(deflocal ilisp-binary-command nil - "Command to return the extension for binary files.") - -(deflocal ilisp-binary-extension nil - "*The extension to use for LISP binaries. If there is an -ilisp-binary-command, this string will be determined at initilization time.") - -(deflocal ilisp-init-binary-command nil - "Command to return the extension for initialization binary files.") - -(deflocal ilisp-init-binary-extension nil - "The extension for initialization binary files. If there is an -ilisp-init-binary-command, this string will be determined at -initilization time.") - -(deflocal ilisp-load-command nil - "Format string for loading a file in LISP given FILE.") - -(deflocal ilisp-compile-file-command nil - "Format string for compiling a file in LISP given FILE and EXTENSION.") - -;;;%%%%Source -(deflocal ilisp-source-types nil - "Alist of strings for source types. The strings can be either -symbols or list expressions since the input accepts symbols or open -ended lists as type specifiers.") - -(deflocal ilisp-find-source-command nil - "Format string for finding the source file that defined SYMBOL in -PACKAGE. It should return NIL if no source is found.") - -(deflocal ilisp-locator nil - "Function \(SYMBOL TYPE FIRST-P BACK-P) that finds the next SYMBOL TYPE -definition in the current buffer. FIRST-P is T the first time it is -called in a buffer. BACK-P is T to move backwards.") - -(deflocal ilisp-calls-locator nil - "Function \(SYMBOL TYPE FIRST-P BACK-P ) that finds calls to SYMBOL -in the current buffer. FIRST-P is T the first time it is called in a -buffer. BACK-P is T to move backwards.") - -(deflocal ilisp-source-directory-fixup-alist - nil - "*An alist of (REGEXP . FIXUP-FUNCTION) which will be applied to -lists of source filenames to be used with edit-definitions-list. -FIXUP-FUNCTION takes no arguments and should use replace-match to fix -the filenames.") - - -;;;%%%Misc -(deflocal ilisp-use-map nil "Keymap to use in ILISP mode.") - -(defvar ilisp-bugs-to "ilisp@naggum.no" "Who to send bug reports to.") - -(defvar ilisp-modes '(ilisp-mode) "List of all inferior ilisp modes.") -(defvar lisp-source-modes '(lisp-mode scheme-mode) - "Used to determine if a buffer contains Lisp source code. -If it's loaded into a buffer that is in one of these major modes, it's -considered a lisp source file by find-file-lisp, load-file-lisp and -compile-file-lisp. Used by these commands to determine defaults.") - -(deflocal ilisp-no-newline nil - "Set to T to stop ilisp from inserting a newline after a command.") - -(deflocal ilisp-error-filter nil "Function to filter error output.") -(deflocal ilisp-error-regexp nil "Regular expression to match error.") - -(deflocal ilisp-symbol-delimiters nil - "Delimiters found around symbols.") - -;;;%%Program -(defvar ilisp-completion-map nil "Keymap for reading ilisp readers.") -(defvar ilisp-epoch-running (and (boundp 'epoch::version) epoch::version) - "Non-nil if epoch is running.") -(defvar ilisp-version - "5.8" ;; ILISP-VERSION marker - "Interface version.") -(defvar ilisp-directory nil "The directory that ilisp is found in.") -(defvar ilisp-mode-map nil "Key map for ILISP.") -(defvar ilisp-raw-map nil - "Keyboard map for sending characters directly to the inferior LISP.") -(defvar ilisp-raw-message "Raw keyboard mode until C-g" - "Message for how to stop raw mode.") -(defvar ilisp-buffer nil "Name of selected ilisp buffer.") -(defvar ilisp-status nil "Status string for selected ilisp buffer.") -(defvar ilisp-buffers nil "List of ILISP buffers.") -(defvar ilisp-dialects nil "List of ILISP dialects.") - -(deflocal ilisp-load-inits nil - "Alist of dialect files to load when initializing an inferior LISP. -By default the file will be loaded from the ilisp-directory.") - -;;; This is useful to have a clause in ilisp code like: -;;; (if (memq 'allegro (ilisp-value 'ilisp-dialect)) -;;; allegro-code -;;; normal-code) -(deflocal ilisp-dialect nil - "List of the dialects that defined the current inferior LISP.") - -(defvar ilisp-initialized nil - "List of buffer names that have been initialized.") -(deflocal ilisp-initializing nil - "Set to T while waiting for inferior LISP to get initialized.") - -(deflocal ilisp-load-files nil "List of files being loaded.") - -(defvar lisp-changes nil - "List of markers for changed forms.") -(deflocal ilisp-pending-changes nil - "List of changes that are pending, but have not been confirmed yet.") - -;;;%%%Completion -;;; Dynamically bound variables for controlling reading -(defvar ilisp-complete nil "T if in minibuffer completion mode.") -(defvar ilisp-no-complete nil "T if incomplete symbols are allowed.") -(defvar ilisp-table nil "Completion table for ilisp readers.") -(defvar ilisp-paren nil "T if paren is allowed in ilisp readers.") -(defvar ilisp-completion-package nil - "Package of buffer requesting completion.") -(defvar ilisp-completion-function-p nil - "T if only symbols with function values are allowed.") - -;;; State variables for ilisp reading -(defvar ilisp-mini-prefix nil "Package and qualification from minibuffer.") -(defvar ilisp-original nil "Original string for ilisp completion.") -(defvar ilisp-original-function-p nil "Function-p for ilisp completion.") -(defvar ilisp-original-table nil "Completion table for ilisp-original.") - -;;;%Buffer -;;;%Packages -(defvar buffer-package 'not-yet-computed "Cached package name.") -(defvar buffer-mode-name nil "Original mode name.") -(defvar lisp-buffer-package nil "T if in lisp-buffer-package.") -(defvar lisp-dont-cache-package nil - "If Non-Nil then refind the most recent in-package each time.") - -;;;%Globals from ilisp-ext.el -;;; -(defvar ilisp-ext-load-hook nil "Hook to run when extensions are loaded.") -(defvar left-delimiter "\(" "*Left delimiter for find-unbalanced.") -(defvar right-delimiter "\)" "*Right delimiter for find-unbalanced.") - -;;; Copies of ilisp var definitions -(defvar ilisp-complete nil "T when ilisp is in completion mode.") -(defvar ilisp-modes '(ilisp-mode) "List of all inferior ilisp modes.") -(defvar lisp-fill-marker (make-marker) - "Keeps track of point so that it does not move during a reindent-lisp.") -(defvar ilisp-comment-marker (make-marker) - "Marker for end of a comment region.") - - -(defvar lisp-buffer-file nil - "Cons of buffer-file-name and the expanded name.") -(make-variable-buffer-local 'lisp-buffer-file) - -(defvar ilisp-last-message nil) -(defvar ilisp-last-prompt nil) - -(defvar lisp-prev-l/c-dir/file nil - "Saves the (directory . file) pair used in the last find-file-lisp, -load-file-lisp or compile-file-lisp command. Used for determining the -default in the next one.") - -(defvar ilisp-last-buffer nil - "The last used LISP buffer.")
--- a/lisp/ilisp/ilisp-dia.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,205 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp-dia.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - -;;;%%CUSTOMIZING DIALECTS -;;; -;;; ILISP is already set up with support for a number of dialects. -;;; Each dialect has a command NAME that will start an inferior LISP -;;; of that dialect. NAME-hook is a hook that will run after the -;;; default settings for NAME are set up. NAME-program is the default -;;; program for NAME. A prefix when starting a dialect will cause you -;;; to be prompted for the buffer name and the program. When setting -;;; something in a hook, you should use the most general dialect that -;;; makes sense. Dialect definitions and their hooks are executed from -;;; least specific to most specific. They will be executed before the -;;; inferior LISP is started. -;;; -;;; These are the currently supported dialects. The dialects -;;; are listed so that the indentation correponds to the hierarchical -;;; relationship between dialects. -;;; clisp -;;; allegro -;;; Clisp (Haible and Stoll) -;;; lispworks (Harlequin) -;;; lucid -;;; cmulisp -;;; kcl -;;; akcl -;;; ibcl -;;; ecl -;;; gcl -;;; scheme -;;; oaklisp -;;; Scheme->C (still "in fieri") -;;; -;;; If anyone figures out support for other dialects I would be happy -;;; to include it in future releases. -;;; -;;; ;;; Example of local changes and extensions to ilisp mode -;;; (setq ilisp-load-hook -;;; '(lambda () -;;; ;; Change the allegro lisp program -;;; (setq allegro-program "/usr/misc/bin/lisp") -;;; ;; Add a new key binding -;;; (defkey-ilisp "\C-\M-a" 'arglist-lisp) -;;; ;; Define a new subdialect to run on another machine. -;;; (defdialect cmlisp "Connection Machine LISP." -;;; lucid -;;; (setq ilisp-program -;;; "rsh power /usr/local/cm/bin/starlisp")))) -;;; -;;; ;;; Automatically load a new subdialect -;;; (autoload 'cmlisp "ilisp" "Run an inferior CM lisp." t) -;;; -;;; To define a new dialect use the macro defdialect. For examples, -;;; look at the dialect definitions in this file. There are hooks and -;;; variables for almost anything that you are likely to need to -;;; change. The relationship between dialects is hierarchical with -;;; the root values being defined in setup-ilisp. For a new dialect, -;;; you only need to change the variables that are different than in -;;; the parent dialect. - - -;;; -;;; ILISP dialect definition code. -;;; - -;;;%Dialects -(defun lisp-add-dialect (dialect) - "Add DIALECT as a supported ILISP dialect." - (if (not (lisp-memk dialect ilisp-dialects 'car)) - (setq ilisp-dialects - (cons (list dialect) ilisp-dialects)))) - -;;; -(defun ilisp-start-dialect (buffer program setup) - ;; Allow dialects to be started from command line - (if (eq current-prefix-arg 0) (setq current-prefix-arg nil)) - (setq ilisp-last-buffer (current-buffer) - buffer (if current-prefix-arg - (read-from-minibuffer "Buffer: " buffer) - buffer)) - (funcall setup buffer) - (setq ilisp-program - (or program - (if current-prefix-arg - (lisp-read-program "Program: " ilisp-program) - ilisp-program))) - (ilisp buffer setup)) - -;;; -(defmacro defdialect (dialect full-name parent &rest body) - "Define a new ILISP dialect. DIALECT is the name of the function to -invoke the inferior LISP. The hook for that LISP will be called -DIALECT-hook. The default program will be DIALECT-program. FULL-NAME -is a string that describes the inferior LISP. PARENT is the name of -the parent dialect." - (let ((setup (read (format "setup-%s" dialect))) - (hook (read (format "%s-hook" dialect))) - (program (read (format "%s-program" dialect))) - (dialects (format "%s" dialect))) - (` - (progn - (defvar (, hook) nil (, (format "*Inferior %s hook." full-name))) - (defvar (, program) nil - (, (format "*Inferior %s default program." full-name))) - (defun (, setup) (buffer) - (, (format "Set up for interacting with %s." full-name)) - (, (read (format "(setup-%s buffer)" parent))) - (,@ body) - (setq ilisp-program (or (, program) ilisp-program) - ilisp-dialect (cons '(, dialect) ilisp-dialect)) - (run-hooks '(, (read (format "%s-hook" dialect))))) - (defun (, dialect) (&optional buffer program) - (, (format "Create an inferior %s. With prefix, prompt for buffer and program." - full-name)) - (interactive (list nil nil)) - (ilisp-start-dialect (or buffer (, dialects)) - program - '(, setup)) - (setq (, program) ilisp-program)) - (lisp-add-dialect (, dialects)))))) - -;;;%%ilisp -(defun setup-ilisp (buffer) - "Set up for interacting with an inferior LISP." - (set-buffer (get-buffer-create "*ilisp-send*")) - (kill-all-local-variables) - (lisp-mode) - (setq ilisp-buffer (format "*%s*" buffer)) - (set-buffer (get-buffer-create ilisp-buffer)) - (setq major-mode 'ilisp-mode - mode-name "ILISP") - (lisp-mode-variables t) - ;; Set variables to nil - (let ((binary ilisp-binary-extension) - (init ilisp-init-binary-extension) - (vars ilisp-locals)) - (while (not (null vars)) - (make-local-variable (car vars)) - (set (car vars) nil) - (setq vars (cdr vars))) - ;; Preserve from initialization - (if binary (setq ilisp-binary-extension binary)) - (if init (setq ilisp-init-binary-extension init))) - ;; Comint defaults - (set-ilisp-input-ring-size 200) - (setq comint-prompt-regexp "^[^<> ]*>+:? *" - - comint-get-old-input 'ilisp-get-old-input - comint-input-sentinel (function ignore) - comint-input-filter 'ilisp-input-filter - comint-input-sender 'comint-default-send - comint-eol-on-send t) - ;; Comint-ipc defaults - (setq comint-send-newline t - comint-always-scroll nil - comint-output-buffer " *Output*" - comint-error-buffer " *Error Output*" - comint-error-regexp "^\"ILISP:" - comint-output-filter (function identity) - comint-interrupt-start 'comint-interrupt-start - comint-handler 'ilisp-handler - comint-update-status 'ilisp-update-status - comint-prompt-status 'comint-prompt-status - comint-abort-hook 'ilisp-abort-handler) - (setq ilisp-use-map ilisp-mode-map - ilisp-init-hook '((lambda () (ilisp-init nil nil t))) - ilisp-filter-regexp "\\`\\s *\\(:\\(\\w\\|\\s_\\)*\\)?\\s *\\'" - ilisp-filter-length 3 - ilisp-error-filter 'ilisp-error-filter - ilisp-error-regexp ".*" - ilisp-symbol-delimiters "^ \t\n\('\"#.\)<>" - ilisp-program "lisp" - ilisp-locator 'lisp-locate-ilisp - ilisp-calls-locator 'lisp-locate-calls) - (run-hooks 'ilisp-mode-hook)) - -(defun run-ilisp () - "Create an inferior LISP prompting for dialect. With prefix, prompt -for buffer name as well." - (interactive) - (let ((dialect (completing-read "Dialect: " ilisp-dialects nil t))) - (if (not (zerop (length dialect))) - (call-interactively (read dialect))))) -
--- a/lisp/ilisp/ilisp-doc.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,430 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp-doc.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - -;;; -;;; ILISP mode documentation -;;; - -(defconst ilisp-documentation - "Major mode for interacting with an inferior LISP process. Runs a -LISP interpreter as a subprocess of Emacs, with LISP I/O through an -Emacs buffer. If you have problems, use M-x ilisp-bug in the buffer -where you are having a problem to send a bug report. - -To start a LISP use M-x run-ilisp, or a specific dialect like M-x -allegro. If called with a prefix you will be prompted for a buffer -name and a program to run. The default buffer name is the name of the -dialect. The default program for a dialect will be the value of -DIALECT-program or the value of ilisp-program inherited from a less -specific dialect. If there are multiple LISP's, use the dialect name -or select-ilisp \(\\[select-ilisp]) to select the current ILISP -buffer. - -Currently supported LISP dialects include: - clisp - allegro - lucid - kcl - akcl - gcl - ecl - ibcl - cmulisp - clisp-hs - lispworks - scheme - oaklisp - -Customization: Starting a dialect runs the hooks on comint-mode-hook -and ilisp-mode-hook and then DIALECT-hooks specific to dialects in the -nesting order above. On the very first prompt in the inferior LISP, -the hooks on ilisp-init-hook are run. For more information on -creating a new dialect or variables to set in hooks, see ilisp.el. - -Most of these key bindings work in both Lisp Mode and ILISP mode. -There are a few additional and-go bindings found in Lisp Mode. -\\{ilisp-use-map} -There are also a few bindings found in global-map including: - \\[ilisp-bury-output] ilisp-bury-output - \\[ilisp-scroll-output] ilisp-scroll-output - \\[previous-buffer-lisp] previous-buffer-lisp - \\[switch-to-lisp] switch-to-lisp - -ILISP has a very flexible means for displaying output from the underlying lisp. -All output is funneled through the function bound to ilisp-display-output-function. -That function gets a single argument, the string to display, and should make it -visible to the user. The default display function, ilisp-display-output-default, -displays one-line output in the echo area and longer output in a shrink-wrapped -typeout window. This typeout window can be manipulated with \\[ilisp-bury-output] -ilisp-bury-output, \\[ilisp-scroll-output] ilisp-scroll-output, and \\[ilisp-grow-output] -ilisp-grow-output. - -An alternative to typeout windows is to always have the inferior LISP -buffer visible and have all output go there. If your are using the default -display function, then setting lisp-no-popper to T will cause all output to go -to the inferior LISP buffer. Setting comint-always-scroll to T will cause -process output to always be visible. If a command gets an error, you will be -left in the break loop. - -Here are the supplied display functions: - ilisp-display-output-default - ilisp-display-output-adaptively - ilisp-display-output-in-echo-area - ilisp-display-output-in-typeout-window - ilisp-display-output-in-lisp-listener - -Each ILISP buffer has a command history associated with it. Commands -that do not match ilisp-filter-regexp and that are longer than -ilisp-filter-length and that do not match the immediately prior -command will be added to this history. comint-previous-input -\(\\[comint-previous-input]) and comint-next-input -\(\\[comint-next-input]) cycle through the input history. -comint-previous-similar-input \(\\[comint-previous-similar-input]) -cycles through input that has the string typed so far as a prefix. - -See comint-mode documentation for more information on comint commands. - -A number of commands refer to \"defun\". A \"defun\" is a list that -starts at the left margin in a LISP buffer, or after a prompt in the -ILISP buffer. So the commands refer to the \"defun\" that contains -point. - -There are two keyboard modes for interacting with the inferior LISP, -\"interactive\" and \"raw\". Normally you are in interactive mode -where keys are interpreted as commands to EMACS and nothing is sent to -the inferior LISP unless a specific command does so. In raw mode, all -characters are passed directly to the inferior LISP without any -interpretation as EMACS commands. Keys will not be echoed unless -ilisp-raw-echo is T. Raw mode can be turned on interactively by -raw-keys-ilisp \(\\[raw-keys-ilisp]) and will continue until you type -C-g. Raw mode can also be turned on/off by inferior LISP functions if -io-bridge-ilisp \(\\[io-bridge-ilisp]) has been executed in the -inferior LISP interactively or on a hook. To turn on raw mode, a -function should print ^[1^] and to turn it off should print ^[0^]. - -When you send something to LISP, the status light will reflect the -progress of the command. If you type top-level forms ahead of the -processing, the status may indicate ready when the LISP is actually -running. In a lisp mode buffer the light will reflect the status of -the currently selected inferior LISP unless lisp-show-status is nil. -If you want to find out what command is currently running, use the -command status-lisp \(\\[status-lisp]). If you call it with a prefix, -the pending commands will be displayed as well. - -If you are want to abort the last command you can use -\(\\[keyboard-quit]). If you want to abort all commands, you should -use the command abort-commands-lisp \(\\[abort-commands-lisp]). -Commands that are aborted will be put in the buffer *Aborted Commands* -so that you can see what was aborted. If you want to abort the -currently running top-level command, use interrupt-subjob-ilisp -\(\\[interrupt-subjob-ilisp]). As a last resort, \\[panic-lisp] will -reset the ILISP state without affecting the inferior LISP so that you -can see what is happening. If you become totally frustrated, you can -also try \\[repair-ilisp]. - -bol-ilisp \(\\[bol-ilisp]) will go after the prompt as defined by -comint-prompt-regexp or ilisp-other-prompt or to the left margin with -a prefix. - -return-ilisp \(\\[return-ilisp]) knows about prompts and sexps. If an -sexp is not complete, it will indent properly. When an entire sexp is -complete, it is sent to the inferior LISP together with a new line. -If you edit old input, the input will be copied to the end of the -buffer first. - -close-and-send-lisp \(\\[close-and-send-lisp]) will close the current -sexp, indent it, then send it to the current inferior LISP. - -indent-line-ilisp \(\\[indent-line-ilisp]) indents for LISP. With -prefix, shifts rest of expression rigidly with the current line. - -newline-and-indent-lisp \(\\[newline-and-indent-lisp]) will insert a -new line and then indent to the appropriate level. If you are at the -end of the inferior LISP buffer and an sexp, the sexp will be sent to -the inferior LISP without a trailing newline. - -indent-sexp-ilisp \(\\[indent-sexp-ilisp]) will indent each line in -the next sexp. - -backward-delete-char-untabify \(\\[backward-delete-char-untabify]) -converts tabs to spaces as it moves back. - -delete-char-or-pop-ilisp \(\\[delete-char-or-pop-ilisp]) will delete -prefix characters unless you are at the end of an ILISP buffer in -which case it will pop one level in the break loop. - -reset-ilisp, \(\\[reset-ilisp]) will reset the current inferior LISP's -top-level so that it will no longer be in a break loop. - -switch-to-lisp \(\\[switch-to-lisp]) will pop to the current ILISP -buffer or if already in an ILISP buffer, it will return to the buffer -that last switched to an ILISP buffer. With a prefix, it will also go -to the end of the buffer. If you do not want it to pop, set -pop-up-windows to nil. - -call-defun-lisp \(\\[call-defun-lisp]) will put a call to the current -defun in the inferior LISP and go there. If it is a \(def* name form, -it looks up reasonable forms of name in the input history unless -called with a prefix. If not found, \(name or *name* will be inserted. -If it is not a def* form, the whole defun will be put in the buffer. - -reposition-window-lisp \(\\[reposition-window-lisp]) will scroll the -current window to show as much of the current defun and its -introductory comments as possible without moving the point. If called -with a prefix, the point will be moved if necessary to show the start -of the defun. If called more than once with the first line of the -defun showing, the introductory comments will be shown or suppressed. - -previous-buffer-lisp \(\\[previous-buffer-lisp]) will switch to the -last visited buffer in the current window or the Nth previous buffer -with a prefix. - -find-unbalanced-lisp \(\\[find-unbalanced-lisp]) will find unbalanced -parens in the current buffer. When called with a prefix it will look -in the current region. - -close-all-lisp \(\\[close-all-lisp]) will close all outstanding -parens back to the containing form, or a previous left bracket -which will be converted to a left parens. If there are too many -parens, they will be deleted unless there is text between the -last paren and the end of the defun. If called with a prefix, -all open left brackets will be closed. - -reindent-lisp \(\\[reindent-lisp]) will reindent the current paragraph -if in a comment or string. Otherwise it will close the containing -defun and reindent it. - -comment-region-lisp \(\\[comment-region-lisp]) will put prefix copies of -comment-start before and comment-end's after the lines in region. To -uncomment a region, use a minus prefix. - -The very first inferior LISP command executed may send some forms to -initialize the inferior LISP. - -Each time an inferior LISP command is executed, the last form sent can be -seen in the \*ilisp-send* buffer. - -The first time an inferior LISP mode command is executed in a Lisp -Mode buffer, the package will be determined by using the regular -expression ilisp-package-regexp to find a package sexp and then -passing that sexp to the inferior LISP through ilisp-package-command. -For the clisp dialect, this will find the first \(in-package PACKAGE) -form in the file. A buffer's package will be displayed in the mode -line. set-buffer-package-lisp \(\\[set-buffer-package-lisp]) will -update the current package from the buffer. If it is called with a -prefix, the package can be set manually. If a buffer has no -specification, forms will be evaluated in the current inferior LISP -package. package-lisp \(\\[package-lisp]) will show the current -package of the inferior LISP. set-package-lisp -\(\\[set-package-lisp]) will set the inferior LISP package to the -current buffer's package or to a manually entered package with a -prefix. - -describe-lisp, inspect-lisp, arglist-lisp, documentation-lisp, -macroexpand-1-lisp, macroexpand-lisp, edit-definitions-lisp, -who-calls-lisp, edit-callers-lisp and trace-defun-lisp will switch -whether they prompt for a response or use a default when called with a -negative prefix. If they are prompting, there is completion through -the inferior LISP by using TAB or M-TAB. When you are entering an -expression in the minibuffer, all of the normal ilisp commands like -arglist-lisp also work. - -Commands that work on a function will use the nearest previous -function symbol. This is either a symbol after a #' or the symbol at -the start of the current list. - -describe-lisp \(\\[describe-lisp]) will describe the previous sexp. -inspect-lisp \(\\[inpsect-lisp]) will inspect the previous sexp.If -there is no previous-sexp and you are in an ILISP buffer, the previous -result will be described or inspected. - -arglist-lisp \(\\[arglist-lisp]) will return the arglist of the -current function. With a numeric prefix, the leading paren will be -removed and the arglist will be inserted into the buffer. - -documentation-lisp \(\\[documentation-lisp]) infers whether function -or variable documentation is desired. With a negative prefix, you can -specify the type of documentation as well. With a positive prefix the -documentation of the current function call is returned. - -If the Franz online Common LISP manual is available, fi:clman -\(\\[fi:clman]) will get information on a specific symbol. -fi:clman-apropos \(\\[fi:clman-apropos]) will get information apropos -a specific string. Some of the documentation is specific to the -allegro dialect, but most of it is for standard Common LISP. - -macroexpand-lisp \(\\[macroexpand-lisp]) and macroexpand-1-lisp -\(\\[macroexpand-1-lisp]) will be applied to the next sexp. They will -insert their result into the buffer if called with a numeric prefix. - -complete-lisp \(\\[complete-lisp]) will try to complete the previous -symbol in the current inferior LISP. Partial completion is supported -unless ilisp-prefix-match is set to T. \(If you set it to T, inferior -LISP completions will be faster.) With partial completion, \"p--n\" -would complete to \"position-if-not\" in Common LISP. If the symbol -follows a left paren or a #', only symbols with function cells will be -considered. If the symbol starts with a \* or you call with a -positive prefix all possible completions will be considered. Only -external symbols are considered if there is a package qualification -with only one colon. The first time you try to complete a string the -longest common substring will be inserted and the cursor will be left -on the point of ambiguity. If you try to complete again, you can see -the possible completions. If you are in a string, then filename -completion will be done instead. And if you try to complete a -filename twice, you will see a list of possible completions. Filename -components are completed individually, so /u/mi/ could expand to -/usr/misc/. If you complete with a negative prefix, the most recent -completion \(symbol or filename) will be undone. - -complete \(\\[complete]) will complete the current symbol to the most -recently seen symbol in Emacs that matches what you have typed so far. -Executing it repeatedly will cycle through potential matches. This is -from the TMC completion package and there may be some delay as it is -initially loaded. - -trace-defun-lisp \(\\[trace-defun-lisp]) traces the current defun. -When called with a numeric prefix the function will be untraced. - -trace-defun-lisp-break \(\\[trace-defun-lisp-break]) traces the -current defun but sets a breakpoint in the function if possible. -When called with a numeric prefix the function will be untraced. - -default-directory-lisp \(\\[default-directory-lisp]\) sets the default -inferior LISP directory to the directory of the current buffer. If -called in an inferior LISP buffer, it sets the Emacs default-directory -the LISP default directory. - -The eval/compile commands evaluate or compile the forms specified. If -any of the forms contain an interactive command, then the command will -never return. To get out of this state, you need to use -abort-commands-lisp \(\\[abort-commands-lisp]). The eval/compile -commands verify that their expressions are balanced and then send the -form to the inferior LISP. If called with a positive prefix, the -result of the operation will be inserted into the buffer after the -form that was just sent. If lisp-wait-p is t, then EMACS will display -the result of the command in the minibuffer or a pop-up window. If -lisp-wait-p is nil, (the default) the send is done asynchronously and -the results will be brought up only if there is more than one line or -there is an error. In this case, you will be given the option of -ignoring the error, keeping it in another buffer or keeping it and -aborting all pending sends. If there is not a command already running -in the inferior LISP, you can preserve the break loop. If called with -a negative prefix, the sense of lisp-wait-p will be inverted for the -next command. The and-go versions will perform the operation and then -immediately switch to the ILISP buffer where you will see the results -of executing your form. If eval-defun-and-go-lisp -\(\\[eval-defun-and-go-lisp]) or compile-defun-and-go-lisp -\(\\[compile-defun-and-go-lisp]) is called with a prefix, a call for -the form will be inserted as well. - -When an eval is done of a single form matching ilisp-defvar-regexp, -the corresponding symbol will be unbound and the value assigned again. - -When compile-defun-lisp \(\\[compile-defun-lisp]) is called in an -inferior LISP buffer with no current form, the last form typed to the -top-level will be compiled. - -The following commands all deal with finding things in source code. -The first time that one of these commands is used, there may be some -delay while the source module is loaded. When searching files, the -first applicable rule is used: 1) try the inferior LISP, 2) try a tags -file if defined, 3) try all buffers in one of lisp-source-modes or all -files defined using lisp-directory. - -lisp-directory \(\\[lisp-directory]) defines a set of files to be -searched by the source code commands. It prompts for a directory and -sets the source files to be those in the directory that match entries -in auto-mode-alist for modes in lisp-source-modes. With a positive -prefix, the files are appended. With a negative prefix, all current -buffers that are in one of lisp-source-modes will be searched. This -is also what happens by default. Using this command stops using a -tags file. - -edit-definitions-lisp \(\\[edit-definitions-lisp]) will find a -particular type of definition for a symbol. It tries to use the rules -described above. The files to be searched are listed in the buffer -\*Edit-Definitions*. If lisp-edit-files is nil, no search will be -done if not found through the inferior LISP. The variable -ilisp-locator contains a function that when given the name and type -should be able to find the appropriate definition in the file. There -is often a flag to cause your LISP to record source files that you -will need to set in the initialization file for your LISP. The -variable is \*record-source-files* in both allegro and lucid. Once a -definition has been found, next-definition-lisp -\(\\[next-definition-lisp]) will find the next definition. \(Or the -previous definition with a prefix.) - -edit-callers-lisp \(\\[edit-callers-lisp]) will generate a list of all -of the callers of a function in the current inferior LISP and edit the -first caller using edit-definitions-lisp. Each successive call to -next-caller-lisp \(\\[next-caller-lisp]) will edit the next caller. -\(Or the previous caller with a prefix.) The list is stored in the -buffer \*All-Callers*. You can also look at the callers by doing -who-calls-lisp \(\\[who-calls-lisp]). - -search-lisp \(\\[search-lisp]) will search the current tags files, -lisp directory files or buffers in one of lisp-source-modes for a -string or a regular expression when called with a prefix. -\(\\[next-definition-lisp]) will find the next definition. \(Or the -previous definition with a prefix.) - -replace-lisp \(\\[replace-lisp]) will replace a string (or a regexp -with a prefix) in the current tags files, lisp directory files or -buffers in one of lisp-source-modes. - -The following commands all deal with making a number of changes all at -once. The first time one of these commands is used, there may be some -delay as the module is loaded. The eval/compile versions of these -commands are always executed asynchronously. - -mark-change-lisp \(\\[mark-change-lisp]) marks the current defun as -being changed. A prefix causes it to be unmarked. clear-changes-lisp -\(\\[clear-changes-lisp]) will clear all of the changes. -list-changes-lisp \(\\[list-changes-lisp]) will show the forms -currently marked. - -eval-changes-lisp \(\\[eval-changes-lisp]), or compile-changes-lisp -\(\\[compile-changes-lisp]) will evaluate or compile these changes as -appropriate. If called with a positive prefix, the changes will be -kept. If there is an error, the process will stop and show the error -and all remaining changes will remain in the list. All of the results -will be kept in the buffer *Last-Changes*. - -File commands in lisp-source-mode buffers keep track of the last used -directory and file. If the point is on a string, that will be the -default if the file exists. If the buffer is one of -lisp-source-modes, the buffer file will be the default. Otherwise, -the last file used in a lisp-source-mode will be used. - -find-file-lisp \(\\[find-file-lisp]) will find a file. If it is in a -string, that will be used as the default if it matches an existing -file. Symbolic links are expanded so that different references to the -same file will end up with the same buffer. - -load-file-lisp \(\\[load-file-lisp]) will load a file into the inferior -LISP. You will be given the opportunity to save the buffer if it has -changed and to compile the file if the compiled version is older than -the current version. - -compile-file-lisp \(\\[compile-file-lisp]) will compile a file in the -current inferior LISP.")
--- a/lisp/ilisp/ilisp-el.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,76 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp-el.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - -;;; -;;; ILISP extensions to emacs lisp -;;; - - - -;;;%Utils -;;; This should be in emacs, but it isn't. -(defun lisp-mem (item list &optional elt=) - "Test to see if ITEM is equal to an item in LIST. -Option comparison function ELT= defaults to equal." - (let ((elt= (or elt= (function equal))) - (done nil)) - (while (and list (not done)) - (if (funcall elt= item (car list)) - (setq done list) - (setq list (cdr list)))) - done)) - - - -;;;%%Misc -(defun lisp-memk (item list key) - "Test to see if ITEM is in LIST using KEY on each item in LIST -before comparing it to ITEM." - (lisp-mem item list (function (lambda (x y) - (equal x (funcall key y)))))) - -;;; This should be in emacs, but it isn't. -(defun lisp-del (item list &optional test) - "Delete ITEM from LIST using TEST comparison and return the result. -Default test is equal." - (let ((test (or test (function equal))) - (element list) - (prev nil) - (done nil)) - (while (and element (not done)) - (if (funcall test item (car element)) - (progn - (setq done t) - (if prev - (rplacd prev (cdr element)) - (setq list (cdr list)))) - (setq prev element - element (cdr element)))) - list)) - -;;; -(defun lisp-last (list) - "Return the last element of LIST." - (while (cdr list) - (setq list (cdr list))) - (car list))
--- a/lisp/ilisp/ilisp-ext.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,460 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp-ext.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - -;;; Lisp mode extensions from the ILISP package. -;;; Copyright (C) 1990, 1991, 1992 Chris McConnell, ccm@cs.cmu.edu. - -;;; This file may become part of GNU Emacs. - -;;; GNU Emacs is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY. No author or distributor -;;; accepts responsibility to anyone for the consequences of using it -;;; or for whether it serves any particular purpose or works at all, -;;; unless he says so in writing. Refer to the GNU Emacs General Public -;;; License for full details. - -;;; Everyone is granted permission to copy, modify and redistribute -;;; GNU Emacs, but only under the conditions described in the -;;; GNU Emacs General Public License. A copy of this license is -;;; supposed to have been given to you along with GNU Emacs so you -;;; can know your rights and responsibilities. It should be in a -;;; file named COPYING. Among other things, the copyright notice -;;; and this notice must be preserved on all copies. - -;;; When loaded this file adds new functionality to emacs lisp mode -;;; and lisp mode. -;;; -;;; Default bindings: -;;; -;;; M-x find-unbalanced-lisp find unbalanced parens in the current -;;; buffer. With a prefix in the current region. -;;; -;;; ] Close all open parentheses back to the start of the containing -;;; sexp, or to a previous left bracket which will be converted to a -;;; left paren. -;;; -;;; M-q Reindent comments or strings in paragraph chunks or reindent -;;; the containing sexp. -;;; -;;; M-x comment-region-lisp inserts prefix copies of the comment-start -;;; character before lines in the region and the comment-end character -;;; at the end of each line. If called with a negative prefix, that -;;; many copies are removed. -;;; -;;; C-M-r repositions the first line of the current defun to the top -;;; of the current window. -;;; -;;; C-M-l switches the current window to the previously seen buffer. -;;; -;;; EXAMPLE .emacs: -;;; -;;; (setq ilisp-ext-load-hook -;;; '(lambda () (define-key global-map "\C-\M-l" 'previous-buffer-lisp))) -;;; (require 'ilisp-ext) - -;;;%Syntax -;;; This makes it so that .'s are treated as normal characters so that -;;; 3.141 gets treated as a single lisp token. This does cause dotted -;;; pairs to be treated weird though. -(modify-syntax-entry ?. "_" lisp-mode-syntax-table) - -;;; Brackets match -(modify-syntax-entry ?\[ "(]" lisp-mode-syntax-table) -(modify-syntax-entry ?\] ")[" lisp-mode-syntax-table) - - - -;;;%Superbrackets -(defun close-all-lisp (arg) - "Unless you are in a string, insert right parentheses as necessary -to balance unmatched left parentheses back to the start of the current -defun or to a previous left bracket which is then replaced with a left -parentheses. If there are too many right parentheses, remove them -unless there is text after the extra right parentheses. If called -with a prefix, the entire expression will be closed and all open left -brackets will be replaced with left parentheses." - (interactive "P") - (let* ((point (point)) - (begin (lisp-defun-begin)) - (end (lisp-end-defun-text)) - inserted - (closed nil)) - (goto-char point) - (if (or (car (cdr (cdr (lisp-in-string begin end)))) - (save-excursion (beginning-of-line) - (looking-at "[ \t]*;"))) - (insert "]") - (if (= begin end) - (error "No sexp to close.") - (save-restriction - (narrow-to-region begin end) - (if (< point begin) - (setq point begin) - (if (> point end) - (setq point end))) - ;; Add parens at point until either the defun is closed, or we - ;; hit a square bracket. - (goto-char point) - (insert ?\)) ;So we have an sexp - (while (progn - (setq inserted (point)) - (condition-case () - (progn (backward-sexp) - (or arg - (not (eq (char-after (point)) ?\[)))) - (error (setq closed t) nil))) - ;; With an arg replace all left brackets - (if (and arg (= (char-after (point)) ?\[)) - (progn - (delete-char 1) - (insert ?\() - (backward-char))) - (forward-sexp) - (insert ?\))) - (if (< (point) point) - ;; We are at a left bracket - (let ((left (point))) - (delete-char 1) - (insert ?\() - (backward-char) - (forward-sexp)) - ;; There was not an open left bracket so close at end - (delete-region point inserted) - (goto-char begin) - (if (condition-case () (progn - (forward-sexp) - (<= (point) end)) - (error nil)) - ;; Delete extra right parens - (let ((point (point))) - (skip-chars-forward " \t)\n") - (if (or (bolp) (eobp)) - (progn - (skip-chars-backward " \t\n") - (delete-region point (point))) - (error - "There is text after the last right parentheses."))) - ;; Insert parens at end changing any left brackets - (goto-char end) - (while - (progn - (insert ?\)) - (save-excursion - (condition-case () - (progn (backward-sexp) - (if (= (char-after (point)) ?\[) - (progn - (delete-char 1) - (insert ?\() - (backward-char))) - (> (point) begin)) - (error (delete-backward-char 1) - nil)))))))))))) - -;;;%Reindentation - -;;; -(defun reindent-lisp () - "Indents code depending partially on context (comments or strings). -If in a comment, indent the comment paragraph bounded by -non-comments, blank lines or empty comment lines. If in a string, -indent the paragraph bounded by string delimiters or blank lines. -Otherwise go to the containing defun, close it and reindent the code -block." - (interactive) - (let ((region (lisp-in-string)) - (comment (concat "[ \t]*" comment-start "+[ \t]*"))) - (set-marker lisp-fill-marker (point)) - (back-to-indentation) - (cond (region - (or (= (char-after (point)) ?\") - (and (< (point) (car region)) (goto-char (car region))) - (re-search-backward "^$" (car region) 'end)) - (let ((begin (point)) - (end (car (cdr region))) - (fill-prefix nil)) - (forward-char) - (re-search-forward "^$" end 'end) - (if (= (point) end) - (progn (skip-chars-forward "^\n") - (if (not (eobp)) (forward-char)))) - (fill-region-as-paragraph begin (point)))) - ((looking-at comment) - (let ((fill-prefix - (buffer-substring - (progn (beginning-of-line) (point)) - (match-end 0)))) - (while (and (not (bobp)) (lisp-in-comment comment)) - (forward-line -1)) - (if (not (bobp)) (forward-line 1)) - (let ((begin (point))) - (while (and (lisp-in-comment comment) (not (eobp))) - (replace-match fill-prefix) - (forward-line 1)) - (if (not (eobp)) - (progn (forward-line -1) - (end-of-line) - (forward-char 1))) - (fill-region-as-paragraph begin (point))))) - (t - (goto-char lisp-fill-marker) - (close-all-lisp 1) - (lisp-defun-begin) - (indent-sexp-ilisp))) - (goto-char lisp-fill-marker) - (set-marker lisp-fill-marker nil) - (message "Done"))) - -;;;%Comment region -(defun comment-region-lisp (start end prefix) - "If prefix is positive, insert prefix copies of comment-start at the -start and comment-end at the end of each line in region. If prefix is -negative, remove all comment-start and comment-end strings from the -region." - (interactive "r\np") - (save-excursion - (goto-char end) - (if (and (not (= start end)) (bolp)) (setq end (1- end))) - (goto-char end) - (beginning-of-line) - (set-marker ilisp-comment-marker (point)) - (untabify start end) - (goto-char start) - (beginning-of-line) - (let* ((count 1) - (comment comment-start) - (comment-end (if (not (equal comment-end "")) comment-end))) - (if (> prefix 0) - (progn - (while (< count prefix) - (setq comment (concat comment-start comment) - count (1+ count))) - (while (<= (point) ilisp-comment-marker) - (beginning-of-line) - (insert comment) - (if comment-end (progn (end-of-line) (insert comment-end))) - (forward-line 1))) - (setq comment (concat comment "+")) - (while (<= (point) ilisp-comment-marker) - (back-to-indentation) - (if (looking-at comment) (replace-match "")) - (if comment-end - (progn - (re-search-backward comment-end) - (replace-match ""))) - (forward-line 1))) - (set-marker ilisp-comment-marker nil)))) - -;;;%Movement -;;; beginning-of-defun-lisp and end-of-defun-lisp are overloaded by ilisp.el -(defun beginning-of-defun-lisp (&optional stay) - "Go to the next left paren that starts at the left margin." - (interactive) - (beginning-of-defun)) - -;;; -(defun end-of-defun-lisp () - "Go to the next left paren that starts at the left margin." - (interactive) - (let ((point (point))) - (beginning-of-line) - (re-search-forward "^[ \t\n]*[^; \t\n]" nil t) - (back-to-indentation) - (if (not (bolp)) (beginning-of-defun-lisp t)) - (lisp-end-defun-text t) - (if (= point (point)) ;Already at end so move to next end - (lisp-skip (point-max)) - (if (not (or (eobp) - (= (char-after (point)) ?\n))) - (lisp-end-defun-text t))))) - -;;;%%Reposition-window -(defun count-screen-lines-lisp (start end) - "Return the number of screen lines between start and end." - (save-excursion - (save-restriction - (narrow-to-region start end) - (goto-char (point-min)) - (vertical-motion (- (point-max) (point-min)))))) - -;;; -(defun count-screen-lines-signed-lisp (start end) - "Return number of screen lines between START and END; returns a negative -number if END precedes START." - (interactive "r") - (let ((lines (count-screen-lines-lisp start end))) - (if (< start end) lines (- lines)))) - -;;; This was written by Michael D. Ernst -(defun reposition-window-lisp (&optional arg) - "Make the current definition and/or comment visible, move it to the -top of the window, or toggle the visibility of comments that precede -it. Leaves point unchanged unless supplied with prefix ARG. If the -definition is fully onscreen, it is moved to the top of the window. -If it is partly offscreen, the window is scrolled to get the -definition \(or as much as will fit) onscreen, unless point is in a -comment which is also partly offscreen, in which case the scrolling -attempts to get as much of the comment onscreen as possible. -Initially reposition-window attempts to make both the definition and -preceding comments visible. Further invocations toggle the visibility -of the comment lines. If ARG is non-nil, point may move in order to -make the whole defun visible \(if only part could otherwise be made -so), to make the defun line visible \(if point is in code and it could -not be made so, or if only comments, including the first comment line, -are visible), or to make the first comment line visible \(if point is -in a comment)." - (interactive "P") - (let* ((here (point)) - ;; change this name once I've gotten rid of references to ht. - ;; this is actually the number of the last screen line - (ht (- (window-height (selected-window)) 2)) - (line (count-screen-lines-lisp (window-start) (point))) - (comment-height - ;; The max deals with the case of cursor between defuns. - (max 0 - (count-screen-lines-signed-lisp - ;; the beginning of the preceding comment - (save-excursion - (if (not (and (bolp) (eq (char-after (point)) ?\())) - (beginning-of-defun-lisp)) - (beginning-of-defun-lisp) - (end-of-defun-lisp) - ;; Skip whitespace, newlines, and form feeds. - (re-search-forward "[^\\s \n\014]") - (backward-char 1) - (point)) - here))) - (defun-height - (count-screen-lines-signed-lisp - (save-excursion - (end-of-defun-lisp) ;associate comment with next defun - (beginning-of-defun-lisp) - (point)) - here)) - ;; This must be positive, so don't use the signed version. - (defun-depth - (count-screen-lines-lisp - here - (save-excursion (end-of-defun-lisp) (point)))) - (defun-line-onscreen-p - (and (<= defun-height line) (<= (- line defun-height) ht)))) - (cond ((or (= comment-height line) - (and (= line ht) - (> comment-height line) - ;; if defun line offscreen, we should be in case 4 - defun-line-onscreen-p)) - ;; Either first comment line is at top of screen or (point at - ;; bottom of screen, defun line onscreen, and first comment line - ;; off top of screen). That is, it looks like we just did - ;; recenter-definition, trying to fit as much of the comment - ;; onscreen as possible. Put defun line at top of screen; that - ;; is, show as much code, and as few comments, as possible. - (if (and arg (> defun-depth (1+ ht))) - ;; Can't fit whole defun onscreen without moving point. - (progn (end-of-defun-lisp) (beginning-of-defun-lisp) - (recenter 0)) - (recenter (max defun-height 0)))) - ((or (= defun-height line) - (= line 0) - (and (< line comment-height) - (< defun-height 0))) - ;; Defun line or cursor at top of screen, OR cursor in comment - ;; whose first line is offscreen. - ;; Avoid moving definition up even if defun runs offscreen; - ;; we care more about getting the comment onscreen. - (cond ((= line ht) - ;; cursor on last screen line (and so in a comment) - (if arg (progn (end-of-defun-lisp) - (beginning-of-defun-lisp))) - (recenter 0)) - ;; This condition, copied from case 4, may not be quite right - ((and arg (< ht comment-height)) - ;; Can't get first comment line onscreen. - ;; Go there and try again. - (forward-line (- comment-height)) - (beginning-of-line) - ;; was (reposition-window) - (recenter 0)) - (t - (recenter (min ht comment-height)))) - ;; (recenter (min ht comment-height)) - ) - ((and (> (+ line defun-depth -1) ht) - defun-line-onscreen-p) - ;; Defun runs off the bottom of the screen and the defun - ;; line is onscreen. Move the defun up. - (recenter (max 0 (1+ (- ht defun-depth)) defun-height))) - (t - ;; If on the bottom line and comment start is offscreen - ;; then just move all comments offscreen, or at least as - ;; far as they'll go. Try to get as much of the comments - ;; onscreen as possible. - (if (and arg (< ht comment-height)) - ;; Can't get defun line onscreen; go there and try again. - (progn (forward-line (- defun-height)) - (beginning-of-line) - (reposition-window-lisp)) - (recenter (min ht comment-height))))))) - -;;; -(defun previous-buffer-lisp (n) - "Switch to Nth previously selected buffer. N defaults to the number -of windows plus 1. That is, no argument switches to the most recently -selected buffer that is not visible. If N is 1, repeated calls will -cycle through all buffers; -1 cycles the other way. If N is greater -than 1, the first N buffers on the buffer list are rotated." - (interactive "P") - (if (not n) - (switch-to-buffer nil) - (let ((buffer-list (buffer-list))) - (setq n (prefix-numeric-value n)) - (cond ((= n 1) - (bury-buffer (current-buffer)) - (setq n 2)) - ((< n 0) - (setq buffer-list (nreverse buffer-list) - n (- n))) - (t nil)) - (while (and (> n 1) buffer-list) - (setq n (1- n) - buffer-list (cdr buffer-list)) - (while (eq (elt (buffer-name (car buffer-list)) 0) ? ) - (setq buffer-list (cdr buffer-list)))) - (if buffer-list - (switch-to-buffer (car buffer-list)) - (error "There aren't that many buffers"))))) - -;;;%Bindings -(define-key emacs-lisp-mode-map "\M-q" 'reindent-lisp) -(define-key emacs-lisp-mode-map "\M-\C-a" 'beginning-of-defun-lisp) -(define-key emacs-lisp-mode-map "\M-\C-e" 'end-of-defun-lisp) -(define-key emacs-lisp-mode-map "\C-\M-r" 'reposition-window-lisp) -(define-key emacs-lisp-mode-map "]" 'close-all-lisp) -(define-key lisp-mode-map "\M-q" 'reindent-lisp) -(define-key lisp-mode-map "\C-\M-r" 'reposition-window-lisp) -(define-key lisp-mode-map "]" 'close-all-lisp) -(define-key global-map "\M-\C-l" 'previous-buffer-lisp) - -;;; -(run-hooks 'ilisp-ext-load-hook) -(provide 'ilisp-ext)
--- a/lisp/ilisp/ilisp-hi.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,604 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp-hi.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - -;;; -;;; ILISP high level interface functions Lisp <-> Emacs -;;; - -;;;%Eval/compile -(defun lisp-send-region (start end switch message status format - &optional handler) - "Given START, END, SWITCH, MESSAGE, STATUS, FORMAT and optional -HANDLER send the region between START and END to the lisp buffer and -execute the command defined by FORMAT on the region, its package and -filename. If called with a positive prefix, the results will be -inserted at the end of the region. If SWITCH is T, the command will -be sent and the buffer switched to the inferior LISP buffer. if -SWITCH is 'call, a call will be inserted. If SWITCH is 'result the -result will be returned without being displayed. Otherwise the -results will be displayed in a popup window if lisp-wait-p is T and -the current-prefix-arg is not '- or if lisp-wait-p is nil and the -current-prefix-arg is '-. If not displayed in a pop-up window then -comint-handler will display the results in a pop-up window if they are -more than one line long, or they are from an error. STATUS will be -the process status when the command is actually executing. MESSAGE is -a message to let the user know what is going on." - (if (= start end) (error "Region is empty")) - (let ((sexp (lisp-count-pairs start end ?\( ?\))) - (string (buffer-substring start end))) - (setq string - (format (ilisp-value format) - (lisp-slashify - (if (= sexp 1) - string - (format (ilisp-value 'ilisp-block-command) string))) - (lisp-buffer-package) (buffer-file-name))) - (let ((result - (ilisp-send - string message status - (cond ((memq switch '(t call)) switch) - ((or (not (eq lisp-wait-p (lisp-minus-prefix))) - current-prefix-arg - (eq switch 'result)) nil) - (t 'dispatch)) - handler))) - - (if result - (if current-prefix-arg - (save-excursion - (goto-char end) - (insert ?\n) - (insert result)) - ;; Display the output in the usual way. - (lisp-display-output result))) - result))) - -;;;%%Eval -(defun eval-region-lisp (start end &optional switch message status handler) - "Evaluate the current region." - (interactive "r") - (setq message (or message - (concat "Evaluate " (lisp-region-name start end)))) - (let ((defvar (ilisp-value 'ilisp-defvar-regexp t))) - (if (and defvar - (save-excursion - (goto-char start) - (skip-chars-forward " \t\n") - (and (let ((case-fold-search t)) (looking-at defvar)) - (progn (forward-sexp) (skip-chars-forward " \t\n" end) - (= (point) end))))) - (lisp-send-region start end switch message (or status 'defvar) - 'ilisp-defvar-command handler) - (lisp-send-region start end switch message (or status 'eval) - 'ilisp-eval-command handler)))) - -;;; -(defun eval-next-sexp-lisp (&optional switch) - "Evaluate the next sexp." - (interactive) - (let (start end) - (save-excursion - (setq start (point)) - (forward-sexp) - (setq end (point))) - (eval-region-lisp start end switch - (format "Evaluate %s" (buffer-substring start end))))) - -;;; -(defun eval-defun-lisp (&optional switch) - "Evaluate the current form." - (interactive) - (let* ((form (lisp-defun-region-and-name)) - (result - (eval-region-lisp (car form) (car (cdr form)) (or switch 'result) - (format "Evaluating %s" (car (cdr (cdr form))))))) - ;; Display the returned value. -fmw - (lisp-display-output result))) - - -;;;%%%And go -(defun eval-region-and-go-lisp (start end) - "Evaluate the current region and switch to the current ILISP buffer." - (interactive "r") - (eval-region-lisp start end t)) - -(defun eval-next-sexp-and-go-lisp (&optional switch) - "Evaluate the next sexp and switch to the current ILISP buffer." - (interactive) - (eval-next-sexp-lisp t)) - -(defun eval-defun-and-go-lisp () - "Evaluate the current defun and switch to the current ILISP buffer. -With prefix, insert a call as well." - (interactive) - (eval-defun-lisp (if current-prefix-arg - (progn - (setq current-prefix-arg nil) - 'call) - t))) - -;;;%%Compile -(defun compile-region-lisp (start end &optional switch message status handler) - "Compile the current region." - (interactive "r") - (lisp-send-region - start end - (or switch 'result) ; Default to return the result. - (or message (concat "Compile " (lisp-region-name start end))) - (or status 'compile) - 'ilisp-compile-command - handler)) - - -;;; -(defun compile-defun-lisp (&optional switch) - "Compile the current defun or the last command in the input-ring of -an ILISP buffer if no current defun." - (interactive) - (let* ((form (lisp-defun-region-and-name)) - (start (car form)) - (end (car (cdr form)))) - (if (and (= start end) (memq major-mode ilisp-modes)) - (save-excursion - (let ((form (ring-ref (ilisp-get-input-ring) - (ilisp-input-ring-index)))) - (set-buffer "*ilisp-send*") - (delete-region (point-min) (point-max)) - (insert form) - (compile-defun-lisp))) - ;; Display the value returned by the compilation. -fmw - (let* ((thing (car (cdr (cdr form)))) - (result (compile-region-lisp start end (or switch 'result) - (format "Compiling %s" thing)))) - (lisp-display-output result))))) - -;;;%%%And-go -(defun compile-region-and-go-lisp (start end) - "Compile the current region and switch to the current ILISP buffer." - (interactive "r") - (compile-region-lisp start end t)) - -(defun compile-defun-and-go-lisp () - "Compile the current defun and switch to the current ILISP buffer." - (interactive) - (compile-defun-lisp - (if current-prefix-arg - (progn - (setq current-prefix-arg nil) - 'call) - t))) - -;;; -(defun compile-file-lisp (file-name &optional extension) - "Compile a Lisp file in the current inferior LISP and go there." - (interactive (comint-get-source - "Compile Lisp file: " lisp-prev-l/c-dir/file - lisp-source-modes nil)) - (comint-check-source file-name) ; Check to see if buffer needs saved. - (setq lisp-prev-l/c-dir/file (cons (file-name-directory file-name) - (file-name-nondirectory file-name))) - (ilisp-init t) - ;; Ivan's hack for ange-ftp pathnames... - (let ((file-name - (if (string-match "/.*?@.*:" file-name) - (substring file-name (match-end 0)) - file-name))) - (ilisp-send - (format (ilisp-value 'ilisp-compile-file-command) file-name - (or extension (ilisp-value 'ilisp-binary-extension))) - (concat "Compile " file-name) 'compile - t))) - - -;;; -(defun ilisp-compile-inits () - "Compile the initialization files for the current inferior LISP dialect." - (interactive) - (ilisp-init t) - (let ((files (ilisp-value 'ilisp-load-inits t))) - (while files - (compile-file-lisp - (expand-file-name (cdr (car files)) ilisp-directory) - (ilisp-value 'ilisp-init-binary-extension t)) - (setq files (cdr files))))) - - -;;; -(defun close-and-send-lisp () - "Close and indent the current sexp then send it to the inferior -LISP." - (interactive) - (reindent-lisp) - (if (memq major-mode ilisp-modes) - (return-ilisp) - (eval-defun-lisp))) - -;;;%Special commands -(defun describe-lisp (sexp) - "Describe the current sexp using ilisp-describe-command. With a -negative prefix, prompt for the expression. If in an ILISP buffer, -and there is no current sexp, describe ilisp-last-command." - (interactive - (list - (if (lisp-minus-prefix) - (ilisp-read "Describe: " (lisp-previous-sexp t)) - (if (memq major-mode ilisp-modes) - (if (= (point) - (process-mark (get-buffer-process (current-buffer)))) - (or (ilisp-value 'ilisp-last-command t) - (error "No sexp to describe.")) - (lisp-previous-sexp t)) - (lisp-previous-sexp t))))) - (let ((result - (ilisp-send - (format (ilisp-value 'ilisp-describe-command) - (lisp-slashify sexp) (lisp-buffer-package)) - (concat "Describe " sexp) - 'describe))) - (lisp-display-output result))) - -;;; -(defun inspect-lisp (sexp) - "Inspect the current sexp using ilisp-inspect-command. With a -prefix, prompt for the expression. If in an ILISP buffer, and there -is no current sexp, inspect ilisp-last-command." - (interactive - (list - (if current-prefix-arg - (ilisp-read "Inspect: " (lisp-previous-sexp t)) - (if (memq major-mode ilisp-modes) - (if (= (point) - (process-mark (get-buffer-process (current-buffer)))) - (or (ilisp-value 'ilisp-last-command t) - (error "No sexp to inspect.")) - (lisp-previous-sexp t)) - (lisp-previous-sexp t))))) - (ilisp-send - (format (ilisp-value 'ilisp-inspect-command) - (lisp-slashify sexp) (lisp-buffer-package)) - (concat "Inspect " sexp) - 'inspect t)) - -;;; -(defun arglist-lisp (symbol) - "Return the arglist of the currently looked at function. With a -numeric prefix, the arglist will be inserted. With a negative one, -the symbol will be prompted for." - (interactive - (let* ((function (lisp-function-name))) - (list (if (lisp-minus-prefix) - (ilisp-read-symbol - (format "Arglist [%s]: " (lisp-buffer-symbol function)) - function t) - function)))) - (if (null symbol) - (error "No symbol") - (let* ((arglist - (ilisp-send - (format (ilisp-value 'ilisp-arglist-command) - (lisp-symbol-name symbol) - (lisp-symbol-package symbol)) - nil - 'args)) - (position (string-match "(" arglist))) - ;; Insert just the stuff after the open paren, - ;; but display everything the inferior lisp prints. - (cond ((and (not (ilisp-value 'comint-errorp t)) - current-prefix-arg position) - (let ((temp (point))) - (insert (substring arglist (1+ position))) - (goto-char temp))) - - (t - (lisp-display-output arglist)))))) - - -;;; -(defun documentation-lisp (symbol type) - "Return the documentation of the previous symbol using -ilisp-documentation-command. If the symbol is at the start of a list, -it is assumed to be a function, otherwise variable documentation is -searched for. With a minus prefix, prompt for the symbol and type. -With a numeric prefix always return the current function call -documentation." - (interactive - (if (lisp-minus-prefix) - (let* ((symbol-info (lisp-previous-symbol)) - (symbol (car symbol-info)) - (doc (ilisp-read-symbol - (format "Documentation [%s]: " - (lisp-buffer-symbol symbol)) - symbol)) - (default (if (car (cdr symbol-info)) - 'function - 'variable)) - (types (ilisp-value 'ilisp-documentation-types t)) - (type - (if types - (ilisp-completing-read - (if default - (format "Type [%s]: " default) - "Type: ") - types - default)))) - (list doc (if (stringp type) (read type) type))) - (if current-prefix-arg - (list (lisp-function-name) 'function) - (let* ((symbol-info (lisp-previous-symbol))) - (list (car symbol-info) - (if (car (cdr symbol-info)) - 'function - 'variable)))))) - (lisp-display-output - (ilisp-send - (format (ilisp-value 'ilisp-documentation-command) - (lisp-symbol-name symbol) (lisp-symbol-package symbol) type) - (format "Documentation %s %s" type (lisp-buffer-symbol symbol)) - 'doc))) - -;;;%%Macroexpand -(defun lisp-macroexpand-form () - "Return the next form for macroexpanding." - (save-excursion - (skip-chars-forward " \t\n") - (let* ((begin (point)) - (end (progn (forward-sexp) (point))) - (form (buffer-substring begin end))) - (list - (if (lisp-minus-prefix) - (ilisp-read "Macroexpand: " form) - form))))) - -;;; -(defun macroexpand-lisp (form &optional top) - "Macroexpand the next sexp until it is no longer a macro. With a -prefix, insert into buffer." - (interactive (lisp-macroexpand-form)) - (if (string-match "(\\([^ \t\n)]*\\)" form) - (let ((message (concat "Macroexpand" - (if top "-1 " " ") - (substring form - (match-beginning 1) - (match-end 1)))) - result) - (setq result - (ilisp-send - (format - (ilisp-value - (if top - 'ilisp-macroexpand-1-command - 'ilisp-macroexpand-command)) - (lisp-slashify form) - (lisp-buffer-package) - (buffer-file-name)) - message 'expand)) - (if current-prefix-arg - (save-excursion (forward-sexp) (insert ?\n) (insert result)) - (lisp-display-output result))) - (error "Not a form: %s" form))) - -(defun macroexpand-1-lisp (form) - "Macroexpand the next sexp once. With a prefix, insert into buffer." - (interactive (lisp-macroexpand-form)) - (macroexpand-lisp form t)) - - - -;;;%%Trace -(defun trace-defun-lisp-break (function) - "Trace FUNCTION without arg, untrace with. Prompt for function with -negative prefix. Default function is the current defun. -Trace with :break set." - (interactive - (let ((function (lisp-defun-name))) - (if (lisp-minus-prefix) - (list (ilisp-read-symbol - (format (if current-prefix-arg - "Untrace [%s]: " - "Trace [%s]: ") - (lisp-buffer-symbol function)) - function - t)) - (list function)))) - (trace-defun-lisp-internal function (not current-prefix-arg))) - -(defun trace-defun-lisp (function) - "Trace FUNCTION without arg, untrace with. Prompt for function with -negative prefix. Default function is the current defun." - (interactive - (let ((function (lisp-defun-name))) - (if (lisp-minus-prefix) - (list (ilisp-read-symbol - (format (if current-prefix-arg - "Untrace [%s]: " - "Trace [%s]: ") - (lisp-buffer-symbol function)) - function - t)) - (list function)))) - (trace-defun-lisp-internal function nil)) - -(defun trace-defun-lisp-internal (function breakp) - (cond (function - (let ((result - (ilisp-send - (if current-prefix-arg - (format (ilisp-value 'ilisp-untrace-command) - (lisp-symbol-name function) - (lisp-symbol-package function)) - (format (ilisp-value 'ilisp-trace-command) - (lisp-symbol-name function) - (lisp-symbol-package function) - breakp)) - (format "%srace %s" (if current-prefix-arg "Unt" "T") - (lisp-buffer-symbol function)) - (if current-prefix-arg 'untrace 'trace) - ;; Change to always wait, so we can see the result. -fmw, 10/13/93 - ;; (if lisp-wait-p nil 'dispatch) - nil))) - ;; Display the value returned -fmw - (lisp-display-output result))) - (t - (error "No function to %strace" (if current-prefix-arg "un" ""))))) - - - -;;;%%Default-directory -(defun default-directory-lisp (&optional buffer) - "Set the inferior LISP default directory to the default directory of -optional BUFFER. If you are in an inferior LISP buffer, set the -default directory to the current directory of the LISP." - (interactive) - (if (and (not buffer) (memq major-mode ilisp-modes)) - (let ((dir - (ilisp-send - (ilisp-value 'ilisp-directory-command) - (format "Getting LISP directory") - 'dir))) - (if (ilisp-value 'comint-errorp t) - (progn - (lisp-display-output dir) - (error "Error getting directory")) - (setq default-directory (read dir) - lisp-prev-l/c-dir/file (cons default-directory nil)) - (message "Default directory is %s" default-directory))) - (let ((directory (save-excursion - (set-buffer (or buffer (current-buffer))) - default-directory))) - (ilisp-send - (format (ilisp-value 'ilisp-set-directory-command) directory) - (format "Set %s's directory to %s" - (buffer-name (ilisp-buffer)) directory) - 'dir - ;; (if lisp-wait-p nil 'dispatch) - ;; The above line might cause problems with Lispworks. - ;; I just set the default to 'nil'. It shouldn't harm. - ;; Marco Antoniotti: Jan 2 1995. - )))) - - -;;; -(defun load-file-lisp (file-name) - "Load a lisp file into the current inferior LISP and go there." - (interactive (comint-get-source "Load Lisp file: " lisp-prev-l/c-dir/file - lisp-source-modes nil)) - (comint-check-source file-name) ; Check to see if buffer needs saved. - (setq lisp-prev-l/c-dir/file (cons (file-name-directory file-name) - (file-name-nondirectory file-name))) - (ilisp-init t) - (let* ((extension (ilisp-value 'ilisp-binary-extension t)) - (binary (lisp-file-extension file-name extension))) - (save-excursion - (set-buffer (ilisp-buffer)) - (if (not (eq comint-send-queue comint-end-queue)) - (if (y-or-n-p "Abort commands before loading? ") - (abort-commands-lisp) - (message "Waiting for commands to finish") - (while (not (eq comint-send-queue comint-end-queue)) - (accept-process-output) - (sit-for 0)))) - (if (and (car (comint-send-variables (car comint-send-queue))) - (y-or-n-p "Interrupt top level? ")) - (let ((result (comint-send-results (car comint-send-queue)))) - (interrupt-subjob-ilisp) - (while (not (cdr result)) - (accept-process-output) - (sit-for 0))))) - (if (file-newer-than-file-p file-name binary) - (if (and (not ilisp-load-no-compile-query) - extension (y-or-n-p "Compile first? ")) - ;; Load binary if just compiled - (progn - (message "") - (compile-file-lisp file-name) - (setq file-name binary))) - ;; Load binary if it is current - (if (file-readable-p binary) (setq file-name binary))) - (switch-to-lisp t t) - - ;; Ivan's hack for ange-ftp pathnames... - (let ((file-name - (if (string-match "/.*?@.*:" file-name) - (substring file-name (match-end 0)) - file-name))) - (comint-sender - (ilisp-process) - (format (ilisp-value 'ilisp-load-command) file-name)) - (message "Loading %s" file-name)))) - - - -;;;%Source -;;;%File operations -;;; -(defun lisp-find-file (file &optional pop no-name) - "Find FILE, optionally POPping. -If optional NO-NAME is nil, and there is a buffer with a name that is -the same as the final pathname component, select that instead of -reading the file associated with the full path name. If the expanded -name of FILE and buffer match, select that buffer." - - (let* ((buffers (buffer-list)) - (position 0) - (expand-symlinks t) - (expanded (expand-file-name file)) - filename) - (if (not no-name) - (progn (while (string-match "/" file position) - (setq position (match-end 0))) - (setq filename (substring file position)))) - (while buffers - (save-excursion - (set-buffer (car buffers)) - (let* ((name (and (not no-name) (buffer-name))) - (buffer-file (buffer-file-name)) - (buffer-expanded - (cdr - (if (string-equal buffer-file (car lisp-buffer-file)) - lisp-buffer-file - (setq lisp-buffer-file - (cons buffer-file - (expand-file-name buffer-file))))))) - (if (or (and name (string-equal filename name)) - (string-equal expanded buffer-expanded)) - (setq file buffer-file - buffers nil) - (setq buffers (cdr buffers))))))) - (if pop - (lisp-pop-to-buffer (find-file-noselect file)) - (find-file file))) - -;;; -(defun find-file-lisp (file-name) - "Find a file. -If point is on a string that points to an existing -file, that will be the default. If the buffer is one of -lisp-source-modes, the buffer file will be the default. Otherwise, -the last file used in a lisp-source-mode will be used." - (interactive - (comint-get-source "Find file: " - lisp-prev-l/c-dir/file - lisp-source-modes nil)) - (setq lisp-prev-l/c-dir/file (cons (file-name-directory file-name) - (file-name-nondirectory file-name))) - (lisp-find-file file-name nil t))
--- a/lisp/ilisp/ilisp-hlw.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,78 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp-hlw.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - -;;; -;;; ILISP LispWorks Common Lisp dialect definition -;;; -;;; Independently written by: -;;; -;;; Jason Trenouth: jason@harlequin.co.uk -;;; Qiegang Long: qlong@cs.umass.edu -;;; -;;; and later merged together by Jason -;;; - -(defvar ilisp-lispworks-init-file "lispworks.lisp") - -;; may use Qiegang's instead? "[-A-Z]+ [0-9]+ : \\([0-9]+\\) >" - -(defun lispworks-break-level (prompt) - (let ((position nil)) - (if (and prompt (setq position (string-match ": [0-9]+" prompt))) - (string-to-int (substring prompt (+ 2 position))) - 0))) - -(defun lispworks-check-prompt (old new) - "Compare the break level printed at the beginning of the prompt." - (<= (lispworks-break-level new) (lispworks-break-level old))) - -;; Qiegang's prompt matcher "^\\([-A-Z]+ [0-9]+ >\\)\\|\\([-A-Z]+ [0-9]+ : [0-9]+ >\\) " -;; Qiegang's error matcher "\\(ILISP:[^\"]*\\)\\|\\(Error: [^\n]*\\)\\|\\(Break.[^\n]*\\)" - -(defdialect lispworks "LispWorks" - clisp - (ilisp-load-init 'lispworks ilisp-lispworks-init-file) - (setq comint-fix-error ":a" - ilisp-reset ":a" ;; LW doesn't have a multi-level abort yet - comint-continue ":c" - comint-interrupt-regexp "Break.\n.*") - (setq comint-prompt-status - (function (lambda (old line) - (comint-prompt-status old line 'lispworks-check-prompt)))) - ;; <cl> or package> at top-level - ;; [0-9c] <cl> or package> in error - ;; (setq comint-prompt-regexp "^\\(\\[[0-9]*c*\\] \\|\\)\\(<\\|\\)[^>]*> ") - (setq comint-prompt-regexp "^[A-Z=][-a-z0-9A-Z:= ]*[$%#>]+ *") - (setq ilisp-error-regexp "ILISP [0-9]* : [0-9]* > ") - (setq ilisp-binary-command "system::*binary-file-type*") - (setq ilisp-source-types (append ilisp-source-types '(("any")))) - (setq ilisp-directory-command "(lw:current-pathname)") - (setq ilisp-set-directory-command "(lw:change-directory \"%s\")") - (setq ilisp-find-source-command - "(ILISP:ilisp-source-files \"%s\" \"%s\" \"%s\")") - (setq ilisp-init-binary-command - "system::*binary-file-type*")) - -(if (not lispworks-program) (setq lispworks-program "lispworks")) - -(provide 'ilisp-lw)
--- a/lisp/ilisp/ilisp-hnd.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,107 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp-hnd.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - -;;; -;;; ILISP Error handler -;;; - - -;; Do not handle errors by default. -(defvar ilisp-handle-errors nil) - -;;; -(defun ilisp-handler (error-p wait-p message output prompt) - "Given ERROR-P, WAIT-P, MESSAGE, OUTPUT and PROMPT, show the message -and output if there is an error or the output is multiple lines and -let the user decide what to do." - (if (not ilisp-handle-errors) - (progn - (if message - (progn - (setq ilisp-last-message message - ilisp-last-prompt prompt) - (if (not wait-p) (lisp-display-output output)))) - nil) - (if (and (not wait-p) - (setq output (comint-remove-whitespace output)) - (or error-p (string-match "\n" output))) - (let* ((buffer (ilisp-output-buffer)) - (out (if error-p - (funcall ilisp-error-filter output) - output)) - (key - (if (and error-p (not (comint-interrupted))) - (comint-handle-error - out - "SPC-scroll, I-ignore, K-keep, A-abort sends and keep or B-break: " - '(?i ?k ?a ?b)) - (comint-handle-error - out - "SPC-scroll, I-ignore, K-keep or A-abort sends and keep: " - '(?i ?k ?a)))) - (clear comint-queue-emptied)) - (if (= key ?i) - (progn - (message "Ignore message") - (if buffer - (funcall - (ilisp-temp-buffer-show-function) - buffer) - (ilisp-bury-output)) - t) - (save-excursion - (set-buffer (get-buffer-create "*Errors*")) - (if clear (delete-region (point-min) (point-max))) - (goto-char (point-max)) - (insert message) - (insert ?\n) - (insert out) - (insert "\n\n")) - (if clear (setq comint-queue-emptied nil)) - (if (= key ?a) - (progn - (message "Abort pending commands and keep in *Errors*") - (comint-abort-sends) - t) - (if (= key ?b) - (progn - (comint-insert - (concat comment-start comment-start comment-start - message "\n" - output "\n" prompt)) - (message "Preserve break") nil) - (message "Keep error in *Errors* and continue") - t)))) - t))) - -;;; -(defun ilisp-abort-handler () - "Handle when the user aborts commands." - (setq ilisp-initializing nil - ilisp-load-files nil) - (let ((add nil)) - (while ilisp-pending-changes - (if (not (memq (car ilisp-pending-changes) lisp-changes)) - (setq add (cons (car ilisp-pending-changes) add))) - (setq ilisp-pending-changes (cdr ilisp-pending-changes))) - (setq lisp-changes (nconc lisp-changes add))))
--- a/lisp/ilisp/ilisp-ind.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,48 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp-ind.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - - -;;; -;;; ILISP indentation -;;; - - -;;;%Indentation -(defun indent-line-ilisp (&optional whole-exp) - "Indent current line as Lisp code. -With argument, indent any additional lines of the same expression -rigidly along with this one. This is restricted to the current buffer input." - (interactive "P") - (save-restriction - (if (memq major-mode ilisp-modes) - (narrow-to-region (save-excursion (lisp-input-start)) (point-max))) - (lisp-indent-line whole-exp))) - -;;; -(defun indent-sexp-ilisp () - "Indent each line of the list starting just after point." - (interactive) - (save-restriction - (if (memq major-mode ilisp-modes) - (narrow-to-region (save-excursion (lisp-input-start)) (point-max))) - (indent-sexp)))
--- a/lisp/ilisp/ilisp-inp.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,50 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp-inp.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - - -;;; -;;; ILISP input functions -;;; - -;;;%%Input -(defun lisp-at-start () - "Return the point if you are at the start of an input expression in -an inferior Lisp." - (save-excursion - (let ((point (point))) - (beginning-of-line) - (comint-skip-prompt) - (if (= point (point)) - point)))) - -;;; -(defun lisp-input-start () - "Go to the start of the input region." - (let* ((pmark (process-mark (get-buffer-process (current-buffer))))) - (if (>= (point) pmark) - (goto-char pmark) - (progn - (end-of-line) - (if (re-search-backward comint-prompt-regexp (point-min) 'stay) - (comint-skip-prompt) - (point))))))
--- a/lisp/ilisp/ilisp-kcl.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,102 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp-kcl.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - -;;; -;;; ILISP Kyoto Common Lisp dialect definition -;;; - -;;;%%%KCL--these dialects by Tom Emerson -;;; kcl-check-prompt doesn't after the first break because the -;;; number of ">" characters doesn't increase. - -(defun kcl-check-prompt (old new) - "Compare the break level printed at the beginning of the prompt." - (let* ((was-in-break (and old (string-match ">+" old))) - (old-level (if was-in-break - (- (match-end 0) (match-beginning 0)) - 0)) - (is-in-break (string-match ">+" new)) - (new-level (if is-in-break - (- (match-end 0) (match-beginning 0)) - 0))) - (<= new-level old-level))) - -;;; -(defdialect kcl "Kyoto Common LISP" clisp - (setq comint-prompt-regexp "^>+" - ilisp-error-regexp "Error: [^\n]*" - ilisp-binary-extension "o" - ilisp-init-binary-extension "o" - ilisp-binary-command "\"o\"" - comint-fix-error ":q" - comint-continue ":r" - comint-prompt-status - (function - (lambda (old line) - (comint-prompt-status old line 'kcl-check-prompt))))) -(if (not kcl-program) (setq kcl-program "kcl")) - -;;;%%%AKCL -(defdialect akcl "Austin Kyoto Common LISP" kcl) -(if (not akcl-program) (setq akcl-program "akcl")) - - -;;;%%%IBCL -(defdialect ibcl "Ibuki Common LISP" kcl - (setq comint-prompt-regexp "^[-A-Z]*>+\\|^[-A-Z]* ->" - comint-interrupt-regexp ">>Condition: Terminal Interrupt" - comint-continue ":q" - ilisp-reset ":q!" - ilisp-error-regexp ">>Error:[^\n]*")) -(if (not ibcl-program) (setq ibcl-program "ibcl")) - - -;;; GCL and ECL (at least) have slightly different compilers and -;;; runtimes, hence we need to provide different extensions for their -;;; init files. -;;; Marco Antoniotti <marcoxa@icsi.berkeley.edu> 19951028. - -;;; GCL -- I assume it is exactly as AKCL. -;;; Should check whether it is similar to IBUKI. -(defdialect gcl "GNU Common LISP" akcl - (setq comint-prompt-regexp "^>+" - ilisp-binary-extension "o" - ilisp-init-binary-extension "gcl.o" - ilisp-binary-command "\"o\"" - ilisp-init-binary-command "\"gcl.o\"" - )) -(if (not gcl-program) (setq gcl-program "gcl")) - - -;;; ECL -- Beppe Attardi's developments over AKCL - -(defdialect ecl "EcoLisp Common LISP" akcl - (setq comint-prompt-regexp "^>+" - ilisp-binary-extension "o" - ilisp-init-binary-extension "ecl.o" - ilisp-binary-command "\"o\"" - ilisp-init-binary-command "\"ecl.o\"" - )) -(if (not ecl-program) (setq ecl-program "ecl")) - -;;; end of file -- ilisp-kcl.el --
--- a/lisp/ilisp/ilisp-key.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,191 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp-key.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - - -;;; -;;; ILISP keybinding definitions. -;;; - - -;;; ilisp-where-is -- -;;; New version provided by yusuf@SPD-13.ils.nwu.edu (Yusuf Pisan) -;;; Note: this used to be in 'ilisp-cpat'. Its definition did not make -;;; much sense. Yusuf noted this and I decided to move it in -;;; this file (where I think is more approriate). -;;; 11/24/94: Marco Antoniotti - -(defun ilisp-where-is (command) - (let ((cmd (where-is-internal command nil t))) - (if cmd (key-description cmd)))) - - -;;; -;;;%Bindings -(defun ilisp-defkey (keymap key command) - "Define KEYMAP ilisp-prefix+KEY as command." - (let ((prefix-map (lookup-key keymap ilisp-prefix))) - (if (not (keymapp prefix-map)) - (setq prefix-map - (define-key keymap ilisp-prefix (make-sparse-keymap)))) - (define-key prefix-map key command))) - -(defun defkey-ilisp (key command) - "Define KEY as COMMAND in ilisp-mode-map and lisp-mode-map" - (if (not ilisp-mode-map) (ilisp-bindings)) - (define-key ilisp-mode-map key command) - (define-key lisp-mode-map key command)) - -;;; -(defun lisp-bindings (keymap &optional inferior-p) - "Set up the bindings for interacting with an inferior LISP in -KEYMAP." - (if inferior-p - (progn (define-key keymap "\C-m" 'return-ilisp) - (define-key keymap "\C-a" 'bol-ilisp) - (define-key keymap "\C-c\C-c" 'interrupt-subjob-ilisp) - (define-key keymap "\C-d" 'delete-char-or-pop-ilisp) - (ilisp-defkey keymap "#" 'raw-keys-ilisp)) - (ilisp-defkey keymap "\C-c" 'compile-defun-and-go-lisp) - (define-key keymap "\C-m" 'newline-and-indent-lisp)) - - (define-key keymap "]" 'close-all-lisp) - (define-key keymap "\M-q" 'reindent-lisp) - (define-key keymap "\C-]" 'close-and-send-lisp) - (define-key keymap "\t" 'indent-line-ilisp) - (define-key keymap "\n" 'newline-and-indent-lisp) - (define-key keymap "\M-\C-q" 'indent-sexp-ilisp) - (ilisp-defkey keymap ";" 'comment-region-lisp) - (ilisp-defkey keymap ")" 'find-unbalanced-lisp) - (define-key keymap "\M-\C-a" 'beginning-of-defun-lisp) - (define-key keymap "\M-\C-e" 'end-of-defun-lisp) - (define-key keymap "\C-\M-r" 'reposition-window-lisp) - (ilisp-defkey keymap "i" 'describe-lisp) - (ilisp-defkey keymap "I" 'inspect-lisp) - (ilisp-defkey keymap "a" 'arglist-lisp) - (ilisp-defkey keymap "d" 'documentation-lisp) - (ilisp-defkey keymap "m" 'macroexpand-1-lisp) - (ilisp-defkey keymap "M" 'macroexpand-lisp) - (define-key keymap "\M-," 'next-definition-lisp) - (define-key keymap "\M-." 'edit-definitions-lisp) - (define-key keymap "\M-?" 'search-lisp) - (define-key keymap "\M-\"" 'replace-lisp) - (ilisp-defkey keymap "^" 'edit-callers-lisp) - (define-key keymap "\M-`" 'next-caller-lisp) - (define-key keymap "\M-\t" 'complete-lisp) - (define-key keymap "\M-\C-m" 'complete) - (ilisp-defkey keymap "r" 'eval-region-lisp) - (define-key keymap "\M-\C-x" 'eval-defun-lisp) ; Gnu convention - (ilisp-defkey keymap "e" 'eval-defun-lisp) - (ilisp-defkey keymap "n" 'eval-next-sexp-lisp) - (ilisp-defkey keymap "p" 'package-lisp) - (ilisp-defkey keymap "P" 'set-package-lisp) - (ilisp-defkey keymap "w" 'compile-region-lisp) - (ilisp-defkey keymap "c" 'compile-defun-lisp) - (ilisp-defkey keymap "\C-r" 'eval-region-and-go-lisp) - (ilisp-defkey keymap "\C-e" 'eval-defun-and-go-lisp) - (ilisp-defkey keymap "\C-n" 'eval-next-sexp-and-go-lisp) - (ilisp-defkey keymap "\C-w" 'compile-region-and-go-lisp) - (ilisp-defkey keymap "t" 'trace-defun-lisp) - (ilisp-defkey keymap "!" 'default-directory-lisp) - (ilisp-defkey keymap " " 'mark-change-lisp) - (let ((ilisp-prefix (concat ilisp-prefix "*"))) - (ilisp-defkey keymap "l" 'list-changes-lisp) - (ilisp-defkey keymap "e" 'eval-changes-lisp) - (ilisp-defkey keymap "c" 'compile-changes-lisp) - (ilisp-defkey keymap "0" 'clear-changes-lisp)) - (ilisp-defkey keymap "b" 'switch-to-lisp) - (ilisp-defkey keymap "y" 'call-defun-lisp) - (ilisp-defkey keymap "z" 'reset-ilisp) - (ilisp-defkey keymap "g" 'abort-commands-lisp) - (ilisp-defkey keymap "s" 'status-lisp) - (ilisp-defkey keymap "S" 'select-ilisp) - (define-key keymap "\C-x\C-f" 'find-file-lisp) - (ilisp-defkey keymap "l" 'load-file-lisp) - (ilisp-defkey keymap "k" 'compile-file-lisp) - (ilisp-defkey keymap "A" 'fi:clman-apropos) - (ilisp-defkey keymap "D" 'fi:clman)) - - - -;; -(defun ilisp-lispm-bindings () - "Setup additional Lisp Machine-like bindings for some ilisp commands" - (interactive) - ;; Note: Changed the 'ilisp-emacs-version-id' to - ;; '+ilisp-emacs-version-id+' and the 'gnu-*' to 'fsf-*'. - ;; 25/11/94 Marco Antoniotti - (cond ((eq +ilisp-emacs-version-id+ 'fsf-18)) - ((eq +ilisp-emacs-version-id+ 'fsf-19) - (defkey-ilisp (read "[?\\S-\\C-a]") 'arglist-lisp) - (defkey-ilisp (read "[?\\S-\\C-c]") 'compile-defun-lisp) - (defkey-ilisp (read "[?\\S-\\C-d]") 'documentation-lisp) - (defkey-ilisp (read "[?\\S-\\C-e]") 'eval-defun-lisp) - (defkey-ilisp (read "[?\\S-\\C-m]") 'macroexpand-1-lisp) - (defkey-ilisp (read "[?\\M-M]") 'macroexpand-lisp)) - (t - (defkey-ilisp '(control A) 'arglist-lisp) - (defkey-ilisp '(control C) 'compile-defun-lisp) - (defkey-ilisp '(control D) 'documentation-lisp) - (defkey-ilisp '(control E) 'eval-defun-lisp) - (defkey-ilisp '(control M) 'macroexpand-1-lisp) - (defkey-ilisp '(meta M) 'macroexpand-lisp)))) - -;; Unfortunately, the read kludges are needed for this function to work -;; for GNU emacs 19 when it was compiled by Lucid. - - - - -;;; -(defun ilisp-bindings () - "Set up the key bindings for LISP and ILISP buffers." - (if (fboundp 'set-keymap-parent) - (progn - (setq ilisp-mode-map (make-sparse-keymap)) - (set-keymap-parent ilisp-mode-map comint-mode-map)) - (setq ilisp-mode-map (copy-keymap comint-mode-map))) - - ;; Remove stop and quit subjob from comint - (define-key ilisp-mode-map "\C-c\C-z" nil) - (define-key ilisp-mode-map "\C-c\C-\\" nil) - (if (fboundp 'lisp-mode-commands) - (lisp-mode-commands ilisp-mode-map)) - (lisp-bindings ilisp-mode-map t) - (if (boundp 'lisp-mode-map) - (lisp-bindings lisp-mode-map)) - (if (boundp 'scheme-mode-map) - (lisp-bindings scheme-mode-map)) - (ilisp-defkey emacs-lisp-mode-map ";" 'comment-region-lisp) - - (ilisp-defkey global-map "\C-t" 'trace-defun-lisp-break) - (ilisp-defkey global-map "b" 'switch-to-lisp) - - ;; Globally defined output-control commands. - (ilisp-defkey global-map "1" 'ilisp-bury-output) - (ilisp-defkey global-map "v" 'ilisp-scroll-output) - (ilisp-defkey global-map "G" 'ilisp-grow-output) - - (if (not (boundp 'fi:clman-mode-map)) - (setq fi:clman-mode-map (make-sparse-keymap))) - (ilisp-defkey fi:clman-mode-map "D" 'fi:clman) - (ilisp-defkey fi:clman-mode-map "A" 'fi:clman-apropos))
--- a/lisp/ilisp/ilisp-kil.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,93 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp-kil.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - - -;;; -;;; ILISP Panic/Reset/Status commands -;;; - -;;;%% Panic/Reset/Status commands -;;; -(defun status-lisp (showp) - "Show the message of the current command being executed in the -inferior LISP. With a prefix show pending sends as well." - (interactive "P") - (save-excursion - (set-buffer (ilisp-buffer)) - (comint-current-send showp))) - - -;;; -(defun reset-ilisp () - "Reset the inferior LISP top level." - (interactive) - (message "Reset LISP to top level") - (comint-simple-send (ilisp-process) (ilisp-value 'ilisp-reset))) - -;;; -(defun abort-commands-lisp (&optional message) - "Abort the commands sent to the current ilisp." - (interactive) - (if (ilisp-value comint-aborting t) - (message "Already aborted commands") - (beep) - (message (or message "Aborted commands")) - (comint-abort-sends (ilisp-process)))) - -;;; -(defun panic-lisp () - "Panic reset for the inferior LISP." - (interactive) - (save-excursion - (if (y-or-n-p "Panic reset LISP? ") - (save-excursion - (set-buffer (ilisp-buffer)) - (comint-setup-ipc t) - (message "LISP is reset, state is unknown")) - (message "")))) - -;;; -(defun repair-ilisp () - "If ilisp is not listening to you in the lisp interaction buffer, you might try this." - (interactive) - (set-buffer (ilisp-buffer)) - (comint-setup-ipc t) - (goto-char (point-max)) - (insert "()") - (return-ilisp) - (message "ILISP is working again (maybe)")) - - -;;; -(defun interrupt-subjob-ilisp () - "Interrupt the current top level command in the inferior LISP." - (interactive) - (if (not (eq comint-send-queue comint-end-queue)) - (if (y-or-n-p "Abort commands before interrupting top level? ") - (abort-commands-lisp) - (message "Waiting for commands to finish") - (while (not (eq comint-send-queue comint-end-queue)) - (accept-process-output) - (sit-for 0)))) - (message "Interrupted top level") - (comint-interrupt-subjob))
--- a/lisp/ilisp/ilisp-low.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,138 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp-low.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - - -;;; -;;; ILISP low level interface functions Lisp <-> Emacs -;;; -;;; - - - -;;;%Lisp mode extensions -;;;%%Sexps -(defun lisp-previous-sexp (&optional prefix) - "Return the previous sexp. If PREFIX is T, then prefix like ' or #' -are allowed." - (save-excursion - (condition-case () - (progn - (if (and (memq major-mode ilisp-modes) - (= (point) - (process-mark (get-buffer-process (current-buffer))))) - nil - (if (not - (or (eobp) (memq (char-after (point)) '(? ?\) ?\n ?\t)))) - (forward-sexp)) - (skip-chars-backward " \t\n") - (let ((point (point))) - (backward-sexp) - (skip-chars-backward "^ \t\n(\",") - (if (not prefix) (skip-chars-forward "#'")) - (buffer-substring (point) point)))) - (error nil)))) - -;;; -(defun lisp-def-name (&optional namep) - "Return the name of a definition assuming that you are at the start -of the sexp. If the form starts with DEF, the form start and the next -symbol will be returned. Optional NAMEP will return only the name without the defining symbol." - (let ((case-fold-search t)) - (if (looking-at - ;; (( \( (def*) (( \( (setf)) | \(?)) | \(?) (symbol) - ;; 12 3 3 45 6 65 42 1 7 7 - ;;0011\(22 def* 22 32 43\(54 setf54 43 \(?32 11 00 60 60 - "\\(\\((\\(def[^ \t\n]*\\)[ \t\n]+\\(\\((\\(setf\\)[ \t\n]+\\)\\|(?\\)\\)\\|(?\\)\\([^ \t\n)]*\\)") - (let ((symbol (buffer-substring (match-beginning 7) (match-end 7)))) - (if (match-end 6) - (concat (if (not namep) - (concat - (buffer-substring (match-beginning 3) (match-end 3)) - " ")) - "(" - (buffer-substring (match-beginning 6) (match-end 6)) - " " symbol ")") - (if (match-end 3) - (concat (if (not namep) - (concat - (buffer-substring (match-beginning 3) - (match-end 3)) - " ")) - symbol) - symbol)))))) - - -;;; -(defun lisp-minus-prefix () - "Set current-prefix-arg to its absolute value if numeric and return -T if it is a negative." - (if current-prefix-arg - (if (symbolp current-prefix-arg) - (progn (setq current-prefix-arg nil) t) - (if (< (setq current-prefix-arg - (prefix-numeric-value current-prefix-arg)) - 0) - (progn - (setq current-prefix-arg (- current-prefix-arg)) t))))) - - - -;;;%%Defuns -(defun lisp-defun-region-and-name () - "Return the region of the current defun and the name starting it." - (save-excursion - (let ((end (lisp-defun-end)) - (begin (lisp-defun-begin))) - (list begin end (lisp-def-name))))) - -;;; -(defun lisp-region-name (start end) - "Return a name for the region from START to END." - (save-excursion - (goto-char start) - (if (re-search-forward "^[ \t]*[^;\n]" end t) - (forward-char -1)) - (setq start (point)) - (goto-char end) - (re-search-backward "^[ \t]*[^;\n]" start 'move) - (end-of-line) - (skip-chars-backward " \t") - (setq end (min (point) end)) - (goto-char start) - (let ((from - (if (= (char-after (point)) ?\() - (lisp-def-name) - (buffer-substring (point) - (progn (forward-sexp) (point)))))) - (goto-char end) - (if (= (char-after (1- (point))) ?\)) - (progn - (backward-sexp) - (if (= (point) start) - from - (concat "from " from " to " (lisp-def-name)))) - (concat "from " from " to " - (buffer-substring (save-excursion - (backward-sexp) - (point)) - (1- (point))))))))
--- a/lisp/ilisp/ilisp-luc.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,63 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp-luc.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - -;;; -;;; ILISP Lucid Common Lisp dialect definition -;;; - - - -;;;%%%Lucid -(defvar ilisp-lucid-init-file "lucid.lisp") - - -(defun lucid-check-prompt (old new) - "Compare the break level printed at the beginning of the prompt." - (let* ((old-level (if (and old (eq 0 (string-match "\\(->\\)+" old))) - (- (match-end 0) (match-beginning 0)) - 0)) - (new-level (if (eq 0 (string-match "\\(->\\)+" new)) - (- (match-end 0) (match-beginning 0)) - 0))) - (<= new-level old-level))) - -;;; -(defdialect lucid "Lucid Common LISP" - clisp - (ilisp-load-init 'lucid ilisp-lucid-init-file) - (setq comint-prompt-regexp "^\\(->\\)+ \\|^[^> ]*> " - comint-fix-error ":a" - ilisp-reset ":a :t" - comint-continue ":c" - comint-interrupt-regexp ">>Break: Keyboard interrupt" - comint-prompt-status - (function (lambda (old line) - (comint-prompt-status old line 'lucid-check-prompt)))) - (setq ilisp-error-regexp "ILISP:[^\"]*\\|>>[^\n]*") - (setq ilisp-source-types (append ilisp-source-types '(("any")))) - (setq ilisp-find-source-command - "(ILISP:ilisp-source-files \"%s\" \"%s\" \"%s\")") - (setq ilisp-binary-command - "(first (last lucid::*load-binary-pathname-types*))")) - -(if (not lucid-program) (setq lucid-program "lisp"))
--- a/lisp/ilisp/ilisp-mak.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,129 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp-mak.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - - -;;; -;;; This file is used by make to compile ilisp. -;;; -;;; Note: 11/23/94 Marco Antoniotti. Actually I believe that this -;;; should be removed or redone. - -(message "ILISP Compilation: starting.") - -;;(require 'byte-compile) - -(if (not (file-exists-p "ilcompat.el")) - (error "ILISP Compilation: compatibility file 'ilcompat.el' non existent.") - (progn - (setq load-path (cons "." load-path)) - - (load "ilcompat.el") ; Need to load this beforehand - ; to use the +ilisp-emacs-version-id+ - ; constant. - - (message ";;; Emacs Version %s" +ilisp-emacs-version-id+) - - (if (eq +ilisp-emacs-version-id+ 'fsf-18) - (load "comint-v18") - (load "comint")) - - - ;; Try to generate bytecodes for emacs 19. - ;; I am no expert on the Byte Compiler. Anyone who is please send - ;; me mail. - ;; Marco Antoniotti <marcoxa@icsi.berkeley.edu> - - (if (eq +ilisp-emacs-version-id+ 'fsf-18) - (setq byte-compile-emacs18-compatibility t) - (setq byte-compile-generate-emacs19-bytecodes t - byte-compile-warnings '(redefine callargs unresolved))) - - ;; Compile compatibility files - (progn - (cond ((or (eq +ilisp-emacs-version-id+ 'lucid-19) - (eq +ilisp-emacs-version-id+ 'lucid-19-new) - (eq +ilisp-emacs-version-id+ 'xemacs)) - (byte-compile "illuc19.el") ; Note that in current version - ; of ILISP illuc19 and - ; ilxemacs are linked - ) - ((eq +ilisp-emacs-version-id+ 'fsf-19) - (byte-compile "ilfsf19.el")) - ((eq +ilisp-emacs-version-id+ 'fsf-18) - (byte-compile "ilfsf18.el")) - (t (error "ILISP Compilation: unrecogninized Emacs version %s" - +ilisp-emacs-version-id+))) - (byte-compile "ilcompat.el")) - - ;; Other files in the distribution. - - (let ((files '(completer - comint-ipc - bridge - ilisp-def - ilisp-el - ilisp-sym - ilisp-inp - ilisp-ind - - ilisp-prc - ilisp-val - ilisp-out - ilisp-mov - ilisp-key - ilisp-prn - ilisp-low - ilisp-doc - ilisp-ext - ilisp-mod - ilisp-dia - ilisp-cmt - ilisp-rng - ilisp-hnd - ilisp-utl - ilisp-cmp - ilisp-kil - ilisp-snd - ilisp-xfr - ilisp-hi - ilisp-aut - - ;; Dialects. - ilisp-cl - ilisp-cmu - ilisp-acl - ilisp-kcl - ilisp-hlw - ilisp-luc - ilisp-xls - ilisp-sch - ))) - (while files - (byte-compile-file (format "%s.el" (car files)) 0) - (load (format "%s" (car files))) - (setq files (cdr files)))) - - (message "Done"))) - -;;; end of file -- ilisp-mak.el -- -
--- a/lisp/ilisp/ilisp-menu.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,65 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp-menu.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - - -(cond ((or (string-match "XEmacs" emacs-version) - (string-match "Lucid" emacs-version))) - (t - - - (require 'simple-menu) - (setplist 'lisp-command-menu nil) - (def-menu 'lisp-command-menu - "Lisp" - "These ILISP commands are available on the menu:" - '( - ("Break Interupt current lisp." - (progn (switch-to-lisp t) - (interrupt-subjob-ilisp))) - ("Doc Menu of commands to get help on variables, etc." - documentation-lisp-command-menu) - ("Xpand macroexpand-lisp." macroexpand-lisp) - ("Eval Eval the surrounding defun." eval-defun-lisp) - ("1E&G Eval defun and goto Inferior LISP." eval-defun-and-go-lisp) - ("; Comment the region." comment-region-lisp) - (") find-unbalanced-lisp parens." find-unbalanced-lisp) - ("] close-all-lisp parens that are open." close-all-lisp) - ("Trace Traces the previous function symbol." trace-lisp) - ) - ) - - (setplist 'documentation-lisp-command-menu nil) - (def-menu 'documentation-lisp-command-menu - "Lisp help" - "These commands are available for examining Lisp structures:" - '( - ("UDoc Get user's documentation string." documentation-lisp) - ("Rglist Get the arglist for function." arglist-lisp) - ("Insp Inspect the current sexp." inspect-lisp) - ("1Insp Prompts for something to inspect." (inspect-lisp -4)) - ("Descr Describe the current sexp." describe-lisp) - ("1Descr Prompts for something to describe." (describe-lisp -4)) - ) - ))) - -(provide 'ilisp-menu)
--- a/lisp/ilisp/ilisp-mnb.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,166 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp-mnb.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - - - -;(require 'ilisp-key) - -(defvar lisp-general-menu-map (make-sparse-keymap "Lisp") - "Keymap for main LISP menu") - - -(defkey-ilisp [menu-bar lisp] - (cons "Lisp" lisp-general-menu-map)) - - -(defkey-ilisp [menu-bar lisp repair] - '("Repair Connection" . repair-ilisp)) - -(defkey-ilisp [menu-bar lisp reset] - '("Reset Connection" . reset-ilisp)) - -(defkey-ilisp [menu-bar lisp comment-region] - '("Comment Region" . comment-region)) - -;;; (defkey-ilisp [menu-bar lisp sep-1] -;;; '("-" . ilisp-nop)) - -(defkey-ilisp [menu-bar lisp macroexpand] - '("Macroexpand" . macroexpand-lisp)) - -(defkey-ilisp [menu-bar lisp macroexpand-1] - '("Macroexpand 1" . macroexpand-1-lisp)) - -(defkey-ilisp [menu-bar lisp set-package] - '("Set Lisp Package" . set-package-lisp)) - -(defkey-ilisp [menu-bar lisp set-buffer-package] - '("Set Buffer Package" . set-buffer-package-lisp)) - -(defkey-ilisp [menu-bar lisp arglist] - '("Arglist" . arglist-lisp)) - -(defkey-ilisp [menu-bar lisp documentation] - '("Documentation" . documentation-lisp)) - -(defkey-ilisp [menu-bar lisp describe] - '("Describe" . describe-lisp)) - -(defkey-ilisp [menu-bar lisp inspect] - '("Inspect" . inspect-lisp)) - -(defkey-ilisp [menu-bar lisp eval-defun] - '("Eval Defun" . eval-defun-and-go-lisp)) - -(defkey-ilisp [menu-bar lisp start-inferior-lisp] - '("Start Lisp" - "Starts an inferior lisp asking for a dialect name" - . run-ilisp)) - - -(defun ilisp-nop () nil) - -;;; Make sure the menu items are properly marked. -;;; Checking for 'ilisp-buffer' is very crufty, but I think it is OK -;;; for the time being. The function 'ilisp-initialized' is not very -;;; good for this. - -(put 'macroexpand-lisp 'menu-enable 'ilisp-buffer) -(put 'macroexpand-1-lisp 'menu-enable 'ilisp-buffer) -(put 'set-package-lisp 'menu-enable 'ilisp-buffer) -(put 'arglist-lisp 'menu-enable 'ilisp-buffer) -(put 'documentation-lisp 'menu-enable 'ilisp-buffer) -(put 'inspect-lisp 'menu-enable 'ilisp-buffer) -(put 'describe-lisp 'menu-enable 'ilisp-buffer) -(put 'eval-defun-and-go-lisp 'menu-enable 'ilisp-buffer) -(put 'run-ilisp 'menu-enable '(null ilisp-buffer)) -(put 'reset-ilisp 'menu-enable 'ilisp-buffer) -(put 'repair-ilisp 'menu-enable 'ilisp-buffer) - -(put 'comment-region 'menu-enable 'mark-active) - - -;;; ilisp-update-menu -- -;;; Update the status of the menu "Lisp". - -;; This variable should disappear! - -(defvar ilisp-process-active-p nil - "Kludge to keep track whether the Inf. Lisp is active or not.") - -(defun ilisp-update-menu (status) - (if (eq status 'exit) - (progn - ;; (setq ilisp-process-active-p nil) - (put 'macroexpand-lisp 'menu-enable 'ilisp-buffer) - (put 'macroexpand-1-lisp 'menu-enable 'ilisp-buffer) - (put 'set-package-lisp 'menu-enable 'ilisp-buffer) - (put 'arglist-lisp 'menu-enable 'ilisp-buffer) - (put 'documentation-lisp 'menu-enable 'ilisp-buffer) - (put 'inspect-lisp 'menu-enable 'ilisp-buffer) - (put 'describe-lisp 'menu-enable 'ilisp-buffer) - (put 'eval-defun-and-go-lisp 'menu-enable 'ilisp-buffer) - ;; (put 'run-ilisp 'menu-enable '(and (null ilisp-buffer) - ;; ilisp-process-active-p) - (put 'run-ilisp 'menu-enable (null ilisp-buffer)) - (put 'reset-ilisp 'menu-enable 'ilisp-buffer) - (put 'repair-ilisp 'menu-enable 'ilisp-buffer) - ) - ;; no-op otherwise - )) - -;;;(setplist 'lisp-command-menu nil) -;;;(def-menu 'lisp-command-menu -;;; "Lisp" -;;; "These ILISP commands are available on the menu:" -;;; '( -;;; ("Break Interupt current lisp." -;;; (progn (switch-to-lisp t) -;;; (interrupt-subjob-ilisp))) -;;; ("Doc Menu of commands to get help on variables, etc." -;;; documentation-lisp-command-menu) -;;; ("Xpand macroexpand-lisp." macroexpand-lisp) -;;; ("Eval Eval the surrounding defun." eval-defun-lisp) -;;; ("1E&G Eval defun and goto Inferior LISP." eval-defun-and-go-lisp) -;;; ("; Comment the region." comment-region-lisp) -;;; (") find-unbalanced-lisp parens." find-unbalanced-lisp) -;;; ("] close-all-lisp parens that are open." close-all-lisp) -;;; ("Trace Traces the previous function symbol." trace-lisp) -;;; ) -;;; ) - -;;;(setplist 'documentation-lisp-command-menu nil) -;;;(def-menu 'documentation-lisp-command-menu -;;; "Lisp help" -;;; "These commands are available for examining Lisp structures:" -;;; '( -;;; ("UDoc Get user's documentation string." documentation-lisp) -;;; ("Rglist Get the arglist for function." arglist-lisp) -;;; ("Insp Inspect the current sexp." inspect-lisp) -;;; ("1Insp Prompts for something to inspect." (inspect-lisp -4)) -;;; ("Descr Describe the current sexp." describe-lisp) -;;; ("1Descr Prompts for something to describe." (describe-lisp -4)) -;;; ) -;;; ) - -(provide 'ilisp-mnb)
--- a/lisp/ilisp/ilisp-mod.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,164 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp-mod.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - - -;;; -;;; ILISP mode top level definitions. -;;; - -;;;%ilisp-mode - -(defun ilisp-byte-code-to-list (function) - "Returns a list suitable for passing to make-byte-code from FUNCTION." - (let ((function-object - (if (symbolp function) - (symbol-function function) - function))) - (if (fboundp 'compiled-function-arglist) - ;; XEmacs - (read (concat "(" - (substring (let ((print-readably t)) - (prin1-to-string function-object)) - 2 -1) - ")")) - ;; FSFmacs - (append function-object nil)))) - -;;; -(defun ilisp-set-doc (function string) - "Set the documentation of the symbol FUNCTION to STRING." - (let* ((old-function (symbol-function function))) - (cond ((listp old-function) - ;; Probe to test whether function is in preloaded read-only - ;; memory, and if so make writable copy: - (condition-case nil - (setcar old-function (car old-function)) - (error - (setq old-function (copy-sequence old-function)) ; shallow copy only - (fset function old-function))) - (let ((ndoc-cdr (nthcdr 2 old-function))) - (if (stringp (car ndoc-cdr)) - ;; Replace the existing docstring. - (setcar ndoc-cdr string) - ;; There is no docstring. Insert the overwrite msg. - (setcdr ndoc-cdr (cons (car ndoc-cdr) (cdr ndoc-cdr))) - (setcar ndoc-cdr string)))) - (t - ;; it's an emacs19 compiled-code object - (let ((new-code (ilisp-byte-code-to-list old-function))) - (if (nthcdr 4 new-code) - (setcar (nthcdr 4 new-code) string) - (setcdr (nthcdr 3 new-code) (cons string nil))) - (fset function (apply 'make-byte-code new-code))))))) - - - -;;; -(defun ilisp-mode () - (interactive) - (run-ilisp)) - -(ilisp-set-doc 'ilisp-mode ilisp-documentation) -(ilisp-set-doc 'lisp-mode ilisp-documentation) - -;;;%%ILISP -(defun lisp-command-args (string) - "Break up STRING into (command args ...)." - (let ((len (length string)) - (position 0) - (arg 0) - (args nil)) - (while (< position len) - (if (eq (aref string position) ?\ ) - (setq args (cons (substring string arg position) args) - arg (1+ position))) - (setq position (1+ position))) - (setq args (reverse (cons (substring string arg position) args))) - args)) - - - -;;; -(defun ilisp (name setup) - "Run an inferior LISP process NAME, input and output via buffer *name*. -If there is a process already running in *name*, just switch to that buffer. -Takes the program name from the variable ilisp-program. -\(Type \\[describe-mode] in the process buffer for a list of commands.)" - (set-buffer ilisp-buffer) - (if (not (comint-check-proc ilisp-buffer)) - (let* ((dialect (car ilisp-dialect)) - (program ilisp-program) - (args (lisp-command-args program)) - ;; Use pipes so that strings can be long - (process-connection-type nil) - (names (format "%s" name)) - start) - (apply 'make-comint name (car args) nil (cdr args)) - (comint-setup-ipc) - ;; Because comint-mode kills all buffer-local variables in - ;; fsf-19 we have to re-call the setup here. - (funcall setup name) - (setq major-mode 'ilisp-mode - mode-name "ILISP") - (rplaca (car comint-send-queue) - (function (lambda () - (run-hooks 'ilisp-init-hook)))) - (setq ilisp-initialized (lisp-del ilisp-buffer ilisp-initialized)) - (if (not (lisp-memk names ilisp-buffers 'car)) - (setq ilisp-buffers (cons (list names) ilisp-buffers))) - (lisp-pop-to-buffer ilisp-buffer) - (setq start (window-start (selected-window)) - ilisp-program program) - (goto-char (point-max)) - (insert (format "Starting %s ...\n" ilisp-program)) - (set-marker (process-mark (ilisp-process)) (point)) - (funcall comint-update-status 'start) - (if ilisp-motd - (progn (lisp-display-output (format ilisp-motd ilisp-version)) - (sleep-for 3) - (set-window-start (selected-window) start))) - (if (not ilisp-prefix-match) (require 'completer))) - (lisp-pop-to-buffer ilisp-buffer)) - (use-local-map ilisp-use-map) - ;; This is necessary to get mode documentation to come out right - (set-default 'ilisp-use-map ilisp-use-map)) - - -;;;%Manual -(autoload 'fi:clman "fi/clman" - "Look up SYMBOL in the online manual with completion." t) -(autoload 'fi:clman-apropos "fi/clman" - "Do an apropos search in online manual for STRING." t) - -;;;%Bridges -(autoload 'install-bridge "bridge" "Install process bridge." t) - -;;;%Modes -(set-default 'auto-mode-alist - (append '(("\\.cl$" . lisp-mode) ("\\.lisp$" . lisp-mode)) - auto-mode-alist)) -(setq completion-ignored-extensions - (append '(".68fasl" ".sfasl" ".ifasl" ".pfasl" - ".68fasl4" ".sfasl4" ".ifasl4" ".pfasl4" - ".sbin") - completion-ignored-extensions))
--- a/lisp/ilisp/ilisp-mov.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,202 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp-mov.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - - -;;;%%Movement -(defun bol-ilisp (arg) - "Goes to the beginning of line, then skips past the prompt, if any. -If a prefix argument is given (\\[universal-argument]), then no prompt skip --- go straight to column 0. - -The prompt skip is done by skipping text matching the regular expression -comint-prompt-regexp or ilisp-other-prompt, both buffer local variables." - (interactive "P") - (beginning-of-line) - (if (null arg) - (or (comint-skip-prompt) - (if ilisp-other-prompt - (let ((comint-prompt-regexp ilisp-other-prompt)) - (comint-skip-prompt)))))) - -;;; -(defun beginning-of-defun-lisp (&optional stay) - "Go to the next left paren that starts at the left margin or after a -prompt in an ILISP buffer. If optional STAY, then do not move to -prior defun if at the start of one in an ilisp mode." - (interactive) - (if (memq major-mode ilisp-modes) - (let ((point (point))) - (if (and (not stay) (= point (lisp-input-start))) - (progn (forward-line -1) (lisp-input-start)))) - (beginning-of-defun))) - -;;; -(defun end-of-defun-lisp () - "Go to the next left paren that starts at the left margin or after a -prompt in an ILISP buffer and go to the end of the expression." - (interactive) - (let ((point (point))) - (if (memq major-mode ilisp-modes) - (beginning-of-defun-lisp t) - (if (or (lisp-in-string) - (progn (beginning-of-line) - (re-search-forward "^[ \t\n]*[^; \t\n]" nil t) - (back-to-indentation) - (not (bolp)))) - (beginning-of-defun-lisp t))) - (lisp-end-defun-text t) - (if (= point (point)) ;Already at end so move to next end - (progn - (if (memq major-mode ilisp-modes) - (re-search-forward comint-prompt-regexp (point-max) t) - (lisp-skip (point-max))) - (if (not (or (eobp) - (= (char-after (point)) ?\n))) - (lisp-end-defun-text t)))))) - -;;; -(defun lisp-defun-begin () - "Go to the start of the containing defun and return point." - (let (begin) - (if (memq major-mode ilisp-modes) - (lisp-input-start) - (if (or (eobp) (not (and (bolp) (= (char-after (point)) ?\()))) - (beginning-of-defun)) - (point)))) - -;;; -(defun lisp-defun-end (&optional no-errorp at-beginp) - "Go to the end of the containing defun and return point or nil if -there is no end." - (if (not at-beginp) (lisp-defun-begin)) - (condition-case () - (progn - (lisp-skip (point-max)) ;To skip comments on defun-end - (forward-sexp) - (point)) - (error (if no-errorp nil (error "Unbalanced parentheses"))))) - -;;; -(defun lisp-find-next-start () - "Find the start of the next line at the left margin that starts with -a character besides whitespace, a \) or ;;; and return the -point." - (if (eobp) - (point-max) - (save-excursion - (forward-char) - (if (re-search-forward "^\\(\\(;;;\\)\\|\\([^ \t\n\);]\\)\\)" nil t) - (match-beginning 0) - (point-max))))) - -;;; -(defun lisp-end-defun-text (&optional at-start) - "Go the end of the text associated with the current defun and return -point. The end is the last character before whitespace leading to -a left paren or ;;; at the left margin unless it is in a string." - (if (not at-start) (lisp-defun-begin)) - (let ((point (point)) - (boundary (lisp-find-next-start)) - (final (save-excursion - (condition-case () - (progn (forward-sexp) (point)) - (error (point-max)))))) - ;; Find the next line starting at the left margin and then check - ;; to see if it is in a string. - (while (progn - (skip-chars-forward "^\"" boundary) ;To the next string - (if (= (point) boundary) - nil ;No quote found and at limit - (let ((string-boundary ;Start of next defun - (save-excursion - (if (re-search-forward "^\(\\|^;;;" nil t) - (match-beginning 0) - (point-max))))) - (if (condition-case () - (progn (forward-sexp) t) - (error (goto-char string-boundary) nil)) - (if (>= (point) boundary) - ;; Boundary was in string - (if (> (point) string-boundary) - (progn ;String ended in next defun - (goto-char string-boundary) - nil) - (if (> (setq boundary - (lisp-find-next-start)) - final) - ;; Normal defun - (progn (goto-char final) nil) - t)) - t) - ;; Unclosed string - nil))))) - (re-search-backward "^[^; \t\n]\\|^[^;\n][ \t]*[^ \t\n]" point t) - (end-of-line) - (skip-chars-backward " \t") - (if (< (point) point) - (goto-char point) - (if (save-excursion - (let ((point (point))) - (beginning-of-line) - (if comment-start (search-forward comment-start point t)))) - (progn (next-line 1) (indent-line-ilisp))) - (point)))) - -;;; -(defun lisp-in-comment (test) - "Return T if you are in a comment." - (beginning-of-line) - (and (looking-at test) - (not (= (match-end 0) - (progn (end-of-line) (point)))))) - -;;; -(defun lisp-in-string (&optional begin end) - "Return the string region that immediately follows/precedes point or -that contains point in optional region BEGIN to END. If point is in -region, T will be returned as well." - (save-excursion - (if (not begin) - (save-excursion - (setq end (lisp-end-defun-text) - begin (lisp-defun-begin)))) - (let* ((point (progn (skip-chars-forward " \t") (point))) - (done nil)) - (goto-char begin) - (while (and (< (point) end) (not done)) - (skip-chars-forward "^\"" end) - (setq begin (point)) - (if (< begin end) - (if (and (not (bobp)) (= (char-after (1- begin)) ??)) - (forward-char) - (if (condition-case () (progn (forward-sexp) (<= (point) end)) - (error nil)) - (progn ;After string - (skip-chars-forward " \t") - (if (or (= begin point) (= point (point))) - (setq done (list begin (point) nil)) - (if (and (< begin point) (< point (point))) - (setq done (list begin (point) t))))) - ;; In string at end of buffer - (setq done (list begin end t)))))) - done)))
--- a/lisp/ilisp/ilisp-out.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,531 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp-out.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - - -;;; -;;; ILISP output, including a popper replacement. -;;; - -(defvar ilisp-output-buffer " *Output*") -(defvar ilisp-output-buffer-major-mode 'lisp-mode - "*The major mode for the ilisp typeout window.") -(defvar ilisp-output-min-height 2 - "*The minimum height of the typeout window used to display ilisp output.") -(defvar ilisp-output-max-height 25 - "*The maximum height of the typeout window used to display ilisp output.") -(defvar ilisp-display-output-function 'ilisp-display-output-default - "The name of a function to display all ilisp output. The function gets a - single argument, a string.") - - -;; Minor mode (just to get a pretty mode line). -(defvar ilisp-output-mode-line nil) -(defvar ilisp-output-mode nil "If T, then we are in the ilisp-output minor mode.") -(make-variable-buffer-local 'ilisp-output-mode) - -(or (assq 'ilisp-output-mode minor-mode-alist) - (setq minor-mode-alist - (cons '(ilisp-output-mode ilisp-output-mode-line) minor-mode-alist))) - - -(defun ilisp-output-buffer (&optional create-p) - (let ((buffer (if create-p - (get-buffer-create ilisp-output-buffer) - (get-buffer ilisp-output-buffer)))) - (or ilisp-output-mode-line - (setq ilisp-output-mode-line - (list (format - " %s bury, %s scroll" - (ilisp-where-is 'ilisp-bury-output) - (ilisp-where-is 'ilisp-scroll-output))))) - buffer)) - -(defun ilisp-output-window () - (let ((buffer (get-buffer ilisp-output-buffer))) - (if buffer - (get-buffer-window buffer)))) - - -(defun lisp-display-output (output) - "Display OUTPUT in the appropriate place. - This calls the function given by the value of ilisp-display-output-function in - order to do the real work." - (cond ((null output)) - (t - ;; Bugcheck - (if (not (stringp output)) - (error "bug: not a string in lisp-display-output")) - - (if (ilisp-value 'comint-errorp t) - (setq output (funcall (ilisp-value 'ilisp-error-filter) - output))) - (funcall ilisp-display-output-function output)))) - - - -;;; Popper replacement - - -(defun ilisp-bury-output () - "Delete the typeout window, if any" - (interactive) - (let* ((buffer (ilisp-output-buffer)) - (window (and buffer (get-buffer-window buffer)))) - (if buffer - (bury-buffer buffer)) - (if window - (ilisp-delete-window window)))) - - -(defun ilisp-show-output (&optional buffer) - "Make typeout visible, if it is not already." - (interactive) - (let ((buffer (or buffer (ilisp-output-buffer)))) - (if buffer - (ilisp-display-buffer-in-typeout-window buffer)))) - - -(defun ilisp-delete-window (window) - "Delete a window with minimal redisplay." - (let ((height (window-height window)) - (lower-window (ilisp-find-lower-window window))) - (delete-window window) - (if (and lower-window - (not (eq lower-window window))) - (let ((old-window (selected-window))) - (save-excursion - (select-window lower-window) - (set-buffer (window-buffer)) - (goto-char (window-start)) - (vertical-motion (- height)) - (set-window-start lower-window (point))) - (select-window old-window))))) - - -(defun ilisp-scroll-output (&optional lines) - "Scroll the typeout-window, if any." - (interactive "P") - (let* ((buffer (ilisp-output-buffer)) - (window (and buffer (get-buffer-window buffer))) - (old-window (selected-window))) - (if window - (unwind-protect - (progn - (select-window window) - (set-buffer buffer) - ;; it won't hurt to bind this regardless of - ;; whether or not `scroll-in-place' is loaded. - (let ((scroll-in-place nil)) - (scroll-up lines))) - (select-window old-window))))) - - -(defun ilisp-grow-output (&optional n) - "Grow the typeout window by ARG (default 1) lines." - (interactive "p") - (let* ((buffer (ilisp-output-buffer)) - (window (and buffer (get-buffer-window buffer))) - (old-window (selected-window))) - (if window - (unwind-protect - (progn - (select-window window) - (enlarge-window n)) - (if (ilisp-window-live-p old-window) - (select-window old-window)))))) - - -(defun ilisp-trim-blank-lines () - ;; Delete leading blank lines - (goto-char (point-min)) - (if (looking-at "\n+") - (replace-match "")) - ;; Delete trailing blank lines - (goto-char (point-max)) - (skip-chars-backward "\n") - (if (< (point) (point-max)) - (delete-region (1+ (point)) (point-max)))) - - -(defun ilisp-write-string-to-buffer (buffer string) - (save-excursion - (set-buffer buffer) - ;; Maybe an option to keep the old output? - (erase-buffer) - ;; New: select mode for the output buffer. - (if (not (eq major-mode ilisp-output-buffer-major-mode)) - (funcall ilisp-output-buffer-major-mode)) - (setq ilisp-output-mode t) - (princ string buffer) - (ilisp-trim-blank-lines) - (goto-char (point-min)))) - - -(defun ilisp-desired-height (buffer-or-window) - (let ((height - (cond ((bufferp buffer-or-window) - (ilisp-needed-buffer-height buffer-or-window)) - ((windowp buffer-or-window) - (ilisp-needed-window-height buffer-or-window))))) - (max window-min-height - (min ilisp-output-max-height - (max ilisp-output-min-height - height))))) - - -;; A first guess at the height needed to display this buffer. -(defun ilisp-needed-buffer-height (buffer) - (save-excursion - (set-buffer buffer) - (1+ (count-lines (point-min) (point-max))))) - - -;; The height this window must be to display its entire buffer. -(defun ilisp-needed-window-height (window) - (save-window-excursion - (select-window window) - (save-excursion - (set-buffer (window-buffer)) - (+ 3 (save-excursion - (goto-char (point-min)) - ;; Any upper bound on the height of an emacs window will - ;; do here. How about 1000. - (vertical-motion 1000)))))) - - -(defun ilisp-shrink-wrap-window (window) - (let ((previously-selected-window (selected-window)) - (buffer (window-buffer window))) - - (select-window window) - (let* ((current-height (window-height window)) - (desired-height (ilisp-desired-height window)) - (delta (- desired-height current-height))) - (enlarge-window delta) - (set-buffer buffer) - (goto-char (point-min)) - - ;; Now repair damage to the window below us, if it still exists. - (let ((lower-window (ilisp-find-lower-window window))) - (if lower-window - (progn - (select-window lower-window) - (let ((old-point (point))) - (goto-char (window-start)) - (vertical-motion delta) - (set-window-start lower-window (point)) - (goto-char old-point) - (if (not (pos-visible-in-window-p old-point)) - (recenter 0)))))) - ;; If there was no lower window, then we ought to preserve - ;; the start of the window above us, if any. - - (if (ilisp-window-live-p previously-selected-window) - (select-window previously-selected-window))))) - - - -(defun ilisp-window-live-p (window) - (let* ((initial-window (selected-window)) - (win initial-window) - (found nil)) - (while win - (cond ((eq window win) - (setq found t - win nil)) - (t - (setq win (next-window win 'no)) - (if (eq win initial-window) - (setq win nil))))) - found)) - -;; XEmacs change -- window-edges is gone in 19.12+ so use -;; next-vertical-window instead. -(defun ilisp-find-lower-window (window) - "Find the window directly below us, if any. This is probably the - window from which enlarge-window would steal lines." - (if (or (not (string-match "XEmacs" emacs-version)) - (and (= emacs-major-version 19) - (< emacs-minor-version 12))) - (let* ((bottom (nth 3 (window-edges window))) - (window* nil) - (win window)) - (while (not (eq (setq win (next-window win 'no)) - window)) - (if (and (= (nth 1 (window-edges win)) - bottom) - (null window*)) - (setq window* win))) - window*) - (next-vertical-window window))) - -;; XEmacs change -- There is now a primitive to do this. -(defun ilisp-find-top-left-most-window () - "Return the leftmost topmost window on the current screen." - (if (or (not (string-match "XEmacs" emacs-version)) - (and (= emacs-major-version 19) - (< emacs-minor-version 12))) - (let* ((window* (selected-window)) - (edges* (window-edges window*)) - (win nil) - (edges nil) - (start-window window*)) - (while (not (eq (setq win (next-window win 'no)) - start-window)) - (setq edges (window-edges win)) - (if (or (< (car (cdr edges)) (car (cdr edges*))) ; top - (and (= (car (cdr edges)) (car (cdr edges*))) - (< (car edges) (car edges*)))) ; left - (setq window* win - edges* edges))) - window*) - (frame-highest-window (selected-frame) 0))) - - -;; This causes the typeout window to be created by splitting or using the -;; top-left-most window on the current screen. That is different behavior -;; from the popper, which always split the current window. -(defun ilisp-window-to-use-for-typeout () - (ilisp-find-top-left-most-window)) - - -(defun ilisp-display-buffer-in-typeout-window (buffer) - "Display buffer in a window at the top of the screen." - (let ((window (get-buffer-window buffer))) - - ;; If buffer already has a window, keep it. - (if (null window) - ;; Otherwise, find a window to split. - (let* ((top-window (ilisp-window-to-use-for-typeout)) - (new-window nil) - (previously-selected-window (selected-window)) - (desired-height (ilisp-desired-height buffer))) - - ;; The new window is always the lower one. - (select-window top-window) - - ;; Always minimize redisplay (except in emacs 18). - (let ((split-window-keep-point nil)) - ;; If the top window is not big enough to split, commandeer it - ;; entirely. - (cond ((> desired-height (- (window-height) window-min-height)) - (setq new-window top-window)) - (t - (setq new-window (split-window-vertically desired-height))))) - - (set-window-buffer top-window buffer) - ;; The height is already correct, unless there was line wrapping. - ;; Account for that here. - (ilisp-shrink-wrap-window top-window) - - ;; Restore selected window. - (if (eq previously-selected-window top-window) - (select-window new-window) - (select-window previously-selected-window))) - - ;; Simply shrink-wrap an existing window. - (ilisp-shrink-wrap-window window)))) - - - - - - - - -;;; Various functions to which to bind ilisp-display-output-function. - -;; This function does what ilisp used to do, except that we use the -;; new "popper". - -(defun ilisp-display-output-default (output) - "Dispatch on the value of lisp-no-popper: - lisp-no-popper = nil: display output in a typeout window. - lisp-no-popper = t: display output in the ilisp buffer - otherwise: display one-line output in the echo area, multiline output in the ilisp buffer." - (cond ((null lisp-no-popper) - (ilisp-display-output-in-typeout-window output)) - ((eq lisp-no-popper t) - (ilisp-display-output-in-lisp-listener output)) - (t - (ilisp-display-output-adaptively output)))) - - -;; This is the display function I like to use. - -;; Another trick which might be useful is to dispatch on the value -;; this-command here, to make output from different ilisp commands -;; go to different places. - -(defun ilisp-display-output-adaptively (output) - "Display one-liners in the echo area, others in the typeout window" - (cond ((or (string-match "\n" output) - (> (length output) (window-width (minibuffer-window)))) - (message "See above.") - (ilisp-display-output-in-typeout-window output)) - (t - (ilisp-display-output-in-echo-area output)))) - - -(defun ilisp-display-output-in-typeout-window (output) - "Display output in a shrink-wrapped window at the top of the screen." - (let ((buffer (ilisp-output-buffer t))) - (ilisp-write-string-to-buffer buffer output) - (ilisp-display-buffer-in-typeout-window buffer))) - - -(defun ilisp-display-output-in-echo-area (output) - "Display output as a message in the echo area." - ;; First clear any existing typeout so as to not confuse the user. - (or (eq (selected-window) (ilisp-output-window)) - (ilisp-bury-output)) - - ;; v5.7: Patch suggested by hunter@work.nlm.nih.gov (Larry Hunter) - ;; If output contains '%', 'message' loses. - ;; (message (ilisp-quote-%s output)) - ;; An alternative here could be '(princ output)', as suggested by - ;; Christopher Hoover <ch@lks.csi.com> - ;; (princ output) - - ;; v5.7b: Patch suggested by fujieda@jaist.ac.jp (Kazuhiro Fujieda) - ;; Best one for FSF Emacs 19.2[89]. - (message "%s" output) - ) - - -;;; ilisp-quote-%s -- -;;; Patch suggested by hunter@work.nlm.nih.gov (Larry Hunter) - -(defun ilisp-quote-%s (string) - "Quote all the occurences of ?% in STRING in an ELisp fashion." - (mapconcat '(lambda (char) - (if (char-equal char ?%) - "%%" - (char-to-string char))) - string "")) - - -(defun ilisp-display-output-in-temp-buffer (output) - (with-output-to-temp-buffer ilisp-output-buffer - (princ output))) - - -(defun ilisp-display-output-in-lisp-listener (output) - "Display output in the ilisp buffer" - (let ((buffer (current-buffer)) - (window (selected-window))) - (unwind-protect - (progn - (lisp-pop-to-buffer (ilisp-buffer)) - (if (not (eq (current-buffer) buffer)) - (setq ilisp-last-buffer buffer)) - (comint-insert - (concat - (if ilisp-last-message - (concat ";;; " ilisp-last-message "\n")) - (comint-remove-whitespace output) - "\n" - ilisp-last-prompt)) - (setq ilisp-last-message nil)) - (if (window-point window) - (progn (select-window window) - (set-buffer buffer)))))) - - - -;;; Changed according to suggestions by Robert P. Goldman -(defun lisp-pop-to-buffer (buffer) - "Like pop-to-buffer, but select a screen that buffer was shown in." - (let ((ilisp-window (if ilisp-epoch-running - (epoch::get-buffer-window buffer) - (get-buffer-window buffer)))) - (if ilisp-window - (select-window ilisp-window) - ;; It is not currently displayed, so find some place to display - ;; it. - (progn - (cond (ilisp-epoch-running - ;; Select a screen that the buffer has been displayed in before - ;; or the current screen otherwise. - (epoch::select-screen - ;; allowed-screens in epoch 3.2, was called screens before that - (or (car (save-excursion - (set-buffer buffer) - (symbol-value 'allowed-screens))) - (epoch::current-screen)))) - - ;; Next clauses patterned after a suggestion by R. P. Goldman. - ((eq +ilisp-emacs-version-id+ 'fsf-19) - (let* ((window (get-buffer-window buffer t)) - (frame (if window (window-frame window)))) - (if (eq 'x (framep frame)) - (progn - (raise-frame frame) - (select-frame frame))))) - (t nil)) ; fsf-18, but also lucid and - ; xemacs. - ; I do not know how to make - ; them work - ; Marco Antoniotti, Jan 4th 1995 - (ilisp-bury-output) - (pop-to-buffer buffer)))) - (set-buffer buffer)) - -;(defun lisp-pop-to-buffer (buffer) -; "Like pop-to-buffer, but select a screen that buffer was shown in. -; Also, first bury any typeout-window." -; (let ((ilisp-window (if ilisp-epoch-running -; (epoch::get-buffer-window buffer) -; (get-buffer-window buffer)))) -; (if ilisp-window -; (select-window ilisp-window) -; ;; It is not currently displayed, so find some place to display it. -; (if ilisp-epoch-running -; ;; Select a screen that the buffer has been displayed in before -; ;; or the current screen otherwise. -; (epoch::select-screen -; ;; allowed-screens in epoch 3.2, was called screens before that -; (or (car (save-excursion -; (set-buffer buffer) -; (symbol-value 'allowed-screens))) -; (epoch::current-screen)))) -; ;; Do not pop to the output buffer. -; (ilisp-bury-output) -; (pop-to-buffer buffer))) -; (set-buffer buffer)) - - -;;; -(defun switch-to-lisp (eob-p &optional ilisp-only) - "If in an ILISP buffer, switch to the buffer that last switched to -an ILISP otherwise, switch to the current ILISP buffer. With -argument, positions cursor at end of buffer. If you don't want to -split windows, set pop-up-windows to NIL." - (interactive "P") - (if (and (not ilisp-only) ilisp-last-buffer - (memq major-mode ilisp-modes)) - (lisp-pop-to-buffer ilisp-last-buffer) - (if (not (memq major-mode ilisp-modes)) - (setq ilisp-last-buffer (current-buffer))) - (lisp-pop-to-buffer (ilisp-buffer)) - (cond (eob-p (goto-char (point-max))))))
--- a/lisp/ilisp/ilisp-pkg.lisp Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,86 +0,0 @@ -;;; -*- Mode: Lisp -*- - -;;; ilisp-pkg.lisp -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - - -;;; CLtL2 defpackage definition for ILISP. -;;; -;;; Common Lisp initializations -;;; -;;; Author: Marco Antoniotti, marcoxa@cs.nyu.edu - -;;;---------------------------------------------------------------------------- -;;; Prologue - -#+(or allegro-v4.0 allegro-v4.1) -(eval-when (compile load eval) - (setq excl:*cltl1-in-package-compatibility-p* t)) - - -;;;---------------------------------------------------------------------------- -;;; Definitions - -;;; ILISP package -- - -;;; -;;; GCL 2.2 doesn't have defpackage (yet) so we need to put the export -;;; here. (toy@rtp.ericsson.se) -;;; -;;; Please note that while the comment and the fix posted by Richard -;;; Toy are correct, they are deprecated by at least one of the ILISP -;;; maintainers. :) By removing the 'nil' in the following #+, you -;;; will fix the problem but will not do a good service to the CL -;;; community. The right thing to do is to install DEFPACKAGE in your -;;; GCL and to write the GCL maintainers and to ask them to -;;; incorporate DEFPACKAGE in their standard builds. -;;; Marco Antoniotti <marcoxa@icsi.berkeley.edu> 19960715 -;;; - -#-(and nil gcl) -(defpackage "ILISP" (:use "LISP" #+:CMU "CONDITIONS") - ;; The following symbols should properly 'shadow' the inherited - ;; ones. - (:export "ILISP-ERRORS" - "ILISP-SAVE" - "ILISP-RESTORE" - "ILISP-SYMBOL-NAME" - "ILISP-FIND-SYMBOL" - "ILISP-FIND-PACKAGE" - "ILISP-EVAL" - "ILISP-COMPILE" - "ILISP-DESCRIBE" - "ILISP-INSPECT" - "ILISP-ARGLIST" - "ILISP-DOCUMENTATION" - "ILISP-MACROEXPAND" - "ILISP-MACROEXPAND-1" - "ILISP-TRACE" - "ILISP-UNTRACE" - "ILISP-COMPILE-FILE" - "ILISP-CASIFY" - "ILISP-MATCHING-SYMBOLS" - "ILISP-CALLERS" - "ILISP-SOURCE-FILES") - ) -;;; ILISP -- - -;;; end of file -- ilisp-pkg.lisp --
--- a/lisp/ilisp/ilisp-prc.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,75 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp-prc.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - - -;;; -;;; ILISP process handling -;;; -;;; -(defun ilisp-process () - "Return the current ILISP process." - (get-buffer-process (ilisp-buffer))) - - -(defvar ilisp-buffer-function 'ilisp-recent-buffer - "A function of no arguments which returns the current ilisp buffer") - - -;;;%Buffer and process selection -(defun ilisp-buffer () - "Return the current ILISP buffer. This is the buffer to whose process requests are sent." - (if (memq major-mode ilisp-modes) - (current-buffer) - (let ((buffer (funcall ilisp-buffer-function))) - (or buffer - (error "You must start an inferior LISP with run-ilisp."))))) - - -(defun ilisp-recent-buffer () - "Return the most-recently selected ilisp buffer." - (if ilisp-buffer - (or (get-buffer ilisp-buffer) - (get-buffer - (setq ilisp-buffers - (lisp-del (substring ilisp-buffer 1 - (1- (length ilisp-buffer))) - ilisp-buffers - (function (lambda (s1 s2) - (string= s1 (car s2))))) - ilisp-buffer - (format "*%s*" (car (car ilisp-buffers)))))))) - - -;;; -(defun select-ilisp () - "Select the current ILISP buffer." - (interactive) - (let ((new (completing-read - (if ilisp-buffer - (format "Buffer [%s]: " - (substring ilisp-buffer 1 - (1- (length ilisp-buffer)))) - "Buffer: ") - ilisp-buffers nil t))) - (if (not (zerop (length new))) - (setq ilisp-buffer (format "*%s*" new)))))
--- a/lisp/ilisp/ilisp-prn.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,99 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp-prn.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - - -;;; -;;; -;;; ILISP paren handling -;;; -;;; - - -;;;%Unbalanced parentheses -(defun lisp-skip (end) - "Skip past whitespace, comments, backslashed characters and strings -in the current buffer as long as you are before END. This does move -the point." - (if (< (point) end) - (let ((comment (and comment-start (string-to-char comment-start))) - (done nil) - char) - (while (and (< (point) end) - (not done)) - (skip-chars-forward "\n\t " end) - (setq char (char-after (point))) - (cond ((eq char ?\") - (forward-sexp)) - ((eq char comment) - (forward-char) - (skip-chars-forward "^\n" end)) - ((eq char ?\\) - (forward-char 2)) - (t (setq done t))))))) - -;;; -(defun lisp-count-pairs (begin end left-delimiter right-delimiter) - "Return the number of top-level pairs of LEFT-DELIMITER and -RIGHT-DELIMITER between BEGIN and END. If they don't match, the point -will be placed on the offending entry." - (let ((old-point (point)) - (sexp 0) - left) - (goto-char begin) - (lisp-skip end) - (while (< (point) end) - (let ((char (char-after (point)))) - (cond ((or (eq char left-delimiter) - ;; For things other than lists - (eq (char-after (1- (point))) ?\n)) - (setq sexp (1+ sexp)) - (if (condition-case () - (progn (forward-sexp) nil) - (error t)) - (error "Extra %s" (char-to-string left-delimiter)))) - ((eq char right-delimiter) - (error "Extra %s" (char-to-string right-delimiter))) - ((< (point) end) (forward-char)))) - (lisp-skip end)) - (goto-char old-point) - sexp)) - -;;; -(defun find-unbalanced-region-lisp (start end) - "Go to the point in region where LEFT-DELIMITER and RIGHT-DELIMITER -become unbalanced. Point will be on the offending delimiter." - (interactive "r") - (lisp-count-pairs start end - (string-to-char left-delimiter) - (string-to-char right-delimiter)) - (if (not ilisp-complete) (progn (beep) (message "Delimiters balance")))) - -;;; -(defun find-unbalanced-lisp (arg) - "Go to the point in buffer where LEFT-DELIMITER and RIGHT-DELIMITER -become unbalanced. Point will be on the offending delimiter. If -called with a prefix, use the current region." - (interactive "P") - (if arg - (call-interactively 'find-unbalanced-region-lisp) - (find-unbalanced-region-lisp (point-min) (point-max))))
--- a/lisp/ilisp/ilisp-rng.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,59 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp-rng.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - - -;;; -;;; ILISP match ring. -;;; -(defun match-ring (ring regexp start) - "Return the index in RING of REGEXP starting at START." - (let ((n 0) - (len (ring-length ring))) - (while (and (< n len) - (not (string-match regexp (ring-ref ring n)))) - (setq n (1+ n))) - (if (= n len) - nil - n))) - -;;; -(defun lisp-match-ring (regexp string &optional no-insert) - "Match REGEXP in the input-ring of the current buffer and set the -ring variables to look like comint-previous-similar-input if found. -If not found insert STRING, unless NO-INSERT." - (let ((n (if regexp (match-ring (ilisp-get-input-ring) regexp 0)))) - (if n - (let ((point (progn (comint-kill-input) (point)))) - (insert (ring-ref (ilisp-get-input-ring) n)) - (save-excursion - (goto-char (+ point (length string))) - (skip-chars-forward "^ \t\n\)") - (setq point (point))) - (push-mark point) - (set-ilisp-input-ring-index n) - (setq this-command 'comint-previous-similar-input - comint-last-similar-string string) - t) - (if (and string (not no-insert)) - (progn (comint-kill-input) (insert string) t) - nil))))
--- a/lisp/ilisp/ilisp-s2c.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,82 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp-s2c.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - -;From: Jeffrey Mark Siskind <qobi@cs.toronto.edu> -;To: ilisp@naggum.no -;Subject: ILisp 5.5 and Scheme->C -;Reply-To: Qobi@cs.toronto.edu -;Date: Thu, 15 Dec 1994 22:55:05 -0500 - -;Is anybody using ILisp 5.5 with Scheme->C? I don't know much about the -;internals of ILisp and have created a defdialect by analogy with the other -;defdialect forms. - -(defdialect qsci "Qobi Scheme->C" scheme - (setq comint-fix-error ":X" - ilisp-reset ":A" - comint-continue ":C" - comint-interrupt-regexp ">>Interrupt:" - ilisp-eval-command - "(begin (eval (read (open-input-string \"%s\"))) \"%s\" \"%s\")" - ilisp-package-command "%s" ;needs work - ilisp-block-command "(begin %s)" - ilisp-load-command "(loadq \"%s\")" - ilisp-load-or-send-command "(begin \"%s\" (ld \"%s\"))" - ild-abort-string ":A" - ild-continue-string ":C" - ild-next-string ":N" - ild-previous-string ":P" - ild-top-string ":<" - ild-bottom-string ":>" - ild-backtrace-string ":B") - (ilisp-load-init 'qsci "/u/qobi/emacs/qsci")) - -(cond ((or (equal (system-name) "qobi.ai") - (equal (system-name) "dvp.cs") - (equal (system-name) "qew.cs")) - (setq qsci-program "/u/qobi/bin/sun4/5.3/qsci")) - (t (setq qsci-program "/u/qobi/bin/sun4/4.1.2/qsci"))) - -;The strange thing is that sometimes it works and sometimes it doesn't. And I -;am having difficulty figuring out what I am doing wrong. I should mention that -;I am using a customized version of Scheme->C (qsci) that has my own debugger -;instead of the default one. My debugger provides Lucid-like commands for -;moving up and down the stack, displaying backtraces and locals, aborting, -;continuing, etc. I will give any interested party a copy of my enhancements to -;Scheme->C. I also use the debugger with ILD, my extension to ILisp 5.5 that -;provides a uniform set of single keystroke commands for accessing the -;different CommonLisp/Scheme debuggers. That explains the ild-* bindings above. - -;Here are my questions: What are the appropriate values for comint-fix-error, -;ilisp-reset, comint-continue, comint-interrupt-regexp, ilisp-eval-command, -;ilsip-package-command, ilisp-block-command, ilisp-load-command, -;and ilisp-load-or-send-command. What exactly should these control strings do? -;What % arguments do they take. The minimum functionality I would like to have -;is the ILisp commands c-z l and c-z e. Later on I would like to add c-z a, -;m-TAB, and m-. but I realize that I'll need to add hooks in Scheme->C for -;these. I would ideally like to modify c-z D and c-z A to look things -;up in R4RS. - -; Jeff (home page http://www.cdf.toronto.edu/DCS/Personal/Siskind.html) - -;;; end of file -- ilisp-scc.el --
--- a/lisp/ilisp/ilisp-sch.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,55 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp-sch.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - - -;;; Scheme - -(defdialect scheme "Scheme" ilisp - (setq ilisp-block-command "(begin \n%s)") - (setq ilisp-load-command "(load \"%s\")") - ) - -(if (not scheme-program) (setq scheme-program "scheme")) - -;;;Cscheme -;;; This has a problem since interrupts cause things to crash -;(defdialect cscheme "C Scheme" -; scheme -; (setq comint-prompt-regexp -; "^[0-9]+ \\([\\]=]=>\\|Error->\\|Bkpt->\\|Debug->\\|Where->\\) ") -; (setq ilisp-program "cscheme") -; (setq ilisp-binary-extension "bin") -; ) - - -;;; Oaklisp - -(defdialect oaklisp "Oaklisp Scheme" - scheme - (setq comint-prompt-regexp ">+ ") - (setq comint-fix-error "(ret 0)") - (setq ilisp-last-command "*") - (setq ilisp-describe-command "(describe %s)")) - - -;;; end of file -- ilisp-sch.el --
--- a/lisp/ilisp/ilisp-snd.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,513 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp-snd.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - - -;;; -;;; ILISP send and support. -;;; - - -;;;%% Package / Symbol support -;;; -(defun lisp-buffer-package () - "Return the package for this buffer. The package name is a string. -If there is none, return NIL. This caches the package unless -ilisp-dont-cache-package is non-nil, so calling this more than once -is cheap." - (cond ((and (not (eq buffer-package 'not-yet-computed)) - (null lisp-dont-cache-package)) - buffer-package) - (ilisp-completion-package ilisp-completion-package) - (lisp-dont-cache-package - ;; Refind the package each time. - (let ((package (lisp-buffer-package-internal nil))) - (message "") - (setq buffer-package 'not-yet-computed) - (if package - (setq mode-name - (concat - (or buffer-mode-name - (setq buffer-mode-name mode-name)) - ":" package))) - package)) - ((or lisp-buffer-package - (memq major-mode ilisp-modes) - (not (memq major-mode lisp-source-modes))) - nil) - (t - (make-local-variable 'buffer-package) - (make-local-variable 'buffer-mode-name) - (let ((package (lisp-buffer-package-internal t))) - (message "") - (setq buffer-package package) - ;; Display package in mode line - (if package - (setq mode-name - (concat (or buffer-mode-name - (setq buffer-mode-name mode-name)) - ":" buffer-package))) - buffer-package)))) - -(defun lisp-buffer-package-internal (search-from-start) - "Returns the package of the buffer. If SEARCH-FROM-START is T then -will search from the beginning of the buffer, otherwise will search -backwards from current point." - (setq mode-line-process 'ilisp-status) - (let* ((lisp-buffer-package t) - (case-fold-search t) - (regexp (ilisp-value 'ilisp-package-regexp t)) - (spec - (if regexp - (save-excursion - (if (or (and search-from-start - (goto-char (point-min)) - (re-search-forward regexp nil t)) - (re-search-backward regexp nil t)) - (buffer-substring (match-beginning 0) - (progn - (goto-char (match-beginning 0)) - (forward-sexp) - (point))))))) - (str (format (ilisp-value 'ilisp-package-command) spec)) - (package - (if spec - (ilisp-send - str - "Finding buffer package" - 'pkg)))) - (if (ilisp-value 'comint-errorp t) - (progn - (lisp-display-output package) - (error "No package")) - (if (and package - ;; There was a bug here, used to have the second * - ;; outside of the parens. - (string-match "[ \n\t:\"]*\\([^ \n\t\"]*\\)" package)) - (setq package - (substring package - (match-beginning 1) (match-end 1))))) - package)) - -;;; -(defun package-lisp () - "Show current inferior LISP package." - (interactive) - (message "Inferior LISP package is %s" - (ilisp-send (ilisp-value 'ilisp-package-name-command) - "Finding inferior LISP package" 'pkg))) - -;;; -(defun set-package-lisp (package) - "Set inferior LISP to package of buffer or a named package with prefix." - (interactive - (let ((default (lisp-buffer-package))) - (if (or current-prefix-arg (null default)) - (let ((name - (read-string - (format "Package [%s]: " (lisp-buffer-package)) ""))) - (list (if (equal name "") default name))) - (list default)))) - (if package - (ilisp-send (format (ilisp-value 'ilisp-in-package-command) package) - (format "Set %s's package to %s" - (buffer-name (ilisp-buffer)) - package) - 'pkg 'dispatch) - (error "No package"))) - -;;; -(defun set-buffer-package-lisp (package) - "Reset the current package of the current buffer. With prefix -specify manually." - (interactive (if current-prefix-arg - (list (read-from-minibuffer "Package: " )) - (list nil))) - (if package - (setq buffer-package package - mode-name (concat (or buffer-mode-name mode-name) ":" package)) - (setq buffer-package 'not-yet-computed) - (lisp-buffer-package))) - - - -;;;%Interface functions -;;;%%Symbols -(defun lisp-string-to-symbol (string) - "Convert STRING to a symbol, (package delimiter symbol) where the -package is either package:symbol or from the current buffer." - (let* ((start (string-match ":+" string)) - (end (if start (match-end 0)))) - (if start - (lisp-symbol - (if (= start 0) - "" - (substring string 0 start)) - (substring string start end) - (substring string end)) - (let ((package (lisp-buffer-package))) - (lisp-symbol package (if package "::") string))))) - -;;; -(defun lisp-symbol-to-string (symbol) - "Convert SYMBOL to a string." - (apply 'concat symbol)) - -;;; -(defun lisp-buffer-symbol (symbol) - "Return SYMBOL as a string qualified for the current buffer." - (let ((symbol-name (lisp-symbol-name symbol)) - (pkg (lisp-symbol-package symbol)) - (delimiter (lisp-symbol-delimiter symbol))) - (cond ((string= pkg (lisp-buffer-package)) symbol-name) - ((string= pkg "") (concat ":" symbol-name)) - (pkg (concat pkg delimiter symbol-name)) - (t symbol-name)))) - -;;; -(defun lisp-previous-symbol (&optional stay) - "Return the immediately preceding symbol as ((package delimiter symbol) -function-p start end). If STAY is T, the end of the symbol will be point." - (save-excursion - (if (or (and (memq major-mode ilisp-modes) - (= (point) (process-mark (get-buffer-process - (current-buffer))))) - (progn - (skip-chars-backward " \t\n") - (or (bobp) (memq (char-after (1- (point))) '(?\) ?\"))))) - nil - (let* ((delimiters (ilisp-value 'ilisp-symbol-delimiters)) - (end (progn - (if (not stay) (skip-chars-forward delimiters)) - (point))) - (start (progn - (skip-chars-backward delimiters) - (point))) - (prefix (if (not (bobp)) (1- start))) - (function-p - (and prefix - (or (eq (char-after prefix) ?\() - (and (eq (char-after prefix) ?') - (not (bobp)) - (eq (char-after (1- prefix)) ?#))) - (not (looking-at "[^: \t\n]*:*\\*[^ \t\n]"))))) - (cons (lisp-string-to-symbol (buffer-substring start end)) - (list function-p start end)))))) - - -;;; -(defun lisp-function-name () - "Return the previous function symbol. This is either after a #' or -at the start of the current sexp. If there is no current sexp, return -nil." - (save-excursion - (let ((symbol (lisp-previous-symbol))) - (if (car (cdr symbol)) - (car symbol) - (condition-case () - (if (and (memq major-mode ilisp-modes) - (= (point) - (process-mark - (get-buffer-process (current-buffer))))) - nil - (backward-up-list 1) - (down-list 1) - (lisp-string-to-symbol - (buffer-substring (point) - (progn (forward-sexp 1) (point))))) - (error nil)))))) - - -;;; -(defun lisp-defun-name () - "Return the name of the current defun." - (save-excursion - (lisp-defun-begin) - (lisp-string-to-symbol (lisp-def-name t)))) - - -;;;%% ILISP initializations -;;; -(defun ilisp-initialized () - "Return T if the current inferior LISP has been initialized." - (memq (buffer-name (ilisp-buffer)) ilisp-initialized)) - -;;; -(defun ilisp-load-init (dialect file) - "Add FILE to the files to be loaded into the inferior LISP when -dialect is initialized. If FILE is NIL, the entry will be removed." - (let ((old (assoc dialect ilisp-load-inits))) - (if file - (if old - (rplacd old file) - (setq ilisp-load-inits (nconc ilisp-load-inits - (list (cons dialect file))))) - (if old (setq ilisp-load-inits (delq old ilisp-load-inits)))))) - -;;; -(defun ilisp-binary (init var) - "Initialize VAR to the result of INIT if VAR is NIL." - (if (not (ilisp-value var t)) - (let ((binary (ilisp-value init t))) - (if binary - (comint-send - (ilisp-process) binary - t nil 'binary nil - (` (lambda (error wait message output last) - (if (or error - (not (string-match "\"[^\"]*\"" output))) - (progn - (lisp-display-output output) - (abort-commands-lisp "No binary")) - (setq (, var) - (substring output - (1+ (match-beginning 0)) - (1- (match-end 0)))))))))))) - -;;; -(defun ilisp-done-init () - "Make sure that initialization is done and if not dispatch another check." - (if ilisp-load-files - (comint-send-code (get-buffer-process (current-buffer)) - 'ilisp-done-init) - (if ilisp-initializing - (progn - (message "Finished initializing %s" (car ilisp-dialect)) - (setq ilisp-initializing nil - ilisp-initialized - (cons (buffer-name (current-buffer)) ilisp-initialized)))))) - -;;; -(defun ilisp-init-internal (&optional sync) - "Send all of the stuff necessary to initialize." - (unwind-protect - (progn - (if sync - (comint-sync - (ilisp-process) - "\"Start sync\"" "[ \t\n]*\"Start sync\"" - "\"End sync\"" "\"End sync\"")) - (ilisp-binary 'ilisp-binary-command 'ilisp-binary-extension) - (ilisp-binary 'ilisp-init-binary-command - 'ilisp-init-binary-extension) - ;; This gets executed in the process buffer - (comint-send-code - (ilisp-process) - (function (lambda () - (let ((files ilisp-load-inits) - (done nil)) - (unwind-protect - (progn - (if (not ilisp-init-binary-extension) - (setq ilisp-init-binary-extension - ilisp-binary-extension)) - (while files - (ilisp-load-or-send - (expand-file-name - (cdr (car files)) ilisp-directory)) - (setq files (cdr files))) - (comint-send-code (ilisp-process) - 'ilisp-done-init) - (setq done t)) - (if (not done) - (progn - (setq ilisp-initializing nil) - (abort-commands-lisp)))))))) - - (set-ilisp-value 'ilisp-initializing t)) ; progn - - (if (not (ilisp-value 'ilisp-initializing t)) - (abort-commands-lisp)))) - -;;; -(defun ilisp-init (&optional waitp forcep sync) - "Initialize the current inferior LISP if necessary by loading the -files in ilisp-load-inits. Optional WAITP waits for initialization to -finish. When called interactively, force reinitialization. With a -prefix, get the binary extensions again." - (interactive - (list (if current-prefix-arg - (progn - (set-ilisp-value 'ilisp-init-binary-extension nil) - (set-ilisp-value 'ilisp-binary-extension nil) - nil)) - t)) - (if (or forcep (not (ilisp-initialized))) - (progn - (message "Started initializing ILISP") - (if (not ilisp-directory) - (setq ilisp-directory (or (ilisp-directory "ilisp.elc" load-path) - (ilisp-directory "ilisp.el" load-path)))) - (if (not (ilisp-value 'ilisp-initializing t)) - (ilisp-init-internal sync)) - (if waitp - (while (ilisp-value 'ilisp-initializing t) - (accept-process-output) - (sit-for 0)))))) - -;;; -(defun ilisp-init-and-sync () - "Synchronize with the inferior LISP and then initialize." - (ilisp-init nil nil t)) - - - -;;; -(defun call-defun-lisp (arg) - "Put a call of the current defun in the inferior LISP and go there. -If it is a \(def* name form, look up reasonable forms of name in the -input history unless called with prefix ARG. If not found, use \(name -or *name* as the call. If is not a def* form, put the whole form in -the buffer." - (interactive "P") - (if (save-excursion (lisp-defun-begin) (looking-at "(def")) - (let* ((symbol (lisp-defun-name)) - (name (lisp-symbol-name symbol)) - (package (if (lisp-symbol-package symbol) - (concat "\\(" - (lisp-symbol-package symbol) ":+\\)?"))) - (variablep (string-match "^\\*" name)) - (setfp (string-match "(setf \\([^\)]+\\)" name))) - (switch-to-lisp t t) - (cond (setfp - (setq name - (substring name (match-beginning 1) (match-end 1))) - (lisp-match-ring (if (not arg) - (concat "(setf[ \t\n]*(" - package name "[ \t\n]")) - (concat "(setf (" name))) - (variablep (lisp-match-ring (if (not arg) - (concat package name)) - name)) - (t - (let ((fun (concat "(" name))) - (setq name (regexp-quote name)) - (or (lisp-match-ring - (if (not arg) (concat "(" package name "[ \t\n\)]")) - fun - (not arg)) - (lisp-match-ring (concat "(" package - "[^ \t\n]*-*" name) - fun)))))) - (let ((form - (save-excursion - (buffer-substring (lisp-defun-begin) - (lisp-end-defun-text t))))) - (switch-to-lisp t t) - (comint-kill-input) - (insert form)))) - - - -;;; -(defun ilisp-send (string &optional message status and-go handler) - "Send STRING to the ILISP buffer, print MESSAGE set STATUS and -return the result if AND-GO is NIL, otherwise switch to ilisp if -and-go is T and show message and results. If AND-GO is 'dispatch, -then the command will be executed without waiting for results. If -AND-GO is 'call, then a call will be generated. If this is the first -time an ilisp command has been executed, the lisp will also be -initialized from the files in ilisp-load-inits. If there is an error, -comint-errorp will be T and it will be handled by HANDLER." - (ilisp-init t) - (let ((process (ilisp-process)) - (dispatch (eq and-go 'dispatch))) - (if message - (message "%s" (if dispatch - (concat "Started " message) - message))) - ;; No completion table - (setq ilisp-original nil) - (if (memq and-go '(t call)) - (progn (comint-send process string nil nil status message handler) - (if (eq and-go 'call) - (call-defun-lisp nil) - (switch-to-lisp t t)) - nil) - (let* ((save (ilisp-value 'ilisp-save-command t)) - (result - (comint-send - process - (if save (format save string) string) - ;; Interrupt without waiting - t (if (not dispatch) 'wait) status message handler))) - (if save - (comint-send - process - (ilisp-value 'ilisp-restore-command t) - t nil 'restore "Restore" t t)) - (if (not dispatch) - (progn - (while (not (cdr result)) - (sit-for 0) - (accept-process-output)) - (comint-remove-whitespace (car result)))))))) - - - -;;; -(defun ilisp-load-or-send (file) - "Try to load FILE into the inferior LISP. If the file is not -accessible in the inferior LISP as determined by -ilisp-load-or-send-command, then visit the file and send the file over -the process interface." - (let* ((command - (format (ilisp-value 'ilisp-load-or-send-command) - (lisp-file-extension - file - (ilisp-value 'ilisp-init-binary-extension t)) - file))) - (set-ilisp-value 'ilisp-load-files - (nconc (ilisp-value 'ilisp-load-files t) (list file))) - (comint-send - (ilisp-process) command t nil 'load - (format "Loading %s" file) - (function (lambda (error wait message output last) - (let* ((file (lisp-last ilisp-load-files)) - (process (get-buffer-process (current-buffer))) - (case-fold-search t)) - (if (and output - (string-match "nil" (car (lisp-last-line output)))) - (let* ((old-buffer (get-file-buffer file)) - (buffer (find-file-noselect file)) - (string (save-excursion - (set-buffer buffer) - (buffer-string)))) - (if (not old-buffer) (kill-buffer buffer)) - (if (string= "" string) - (abort-commands-lisp (format "Can't find file %s" file)) - (comint-send - process - (format ilisp-block-command string) - t nil 'send (format "Sending %s" file) - (function (lambda (error wait message output last) - (if error - (progn - (comint-display-error output) - (abort-commands-lisp - (format "Error sending %s" - (lisp-last ilisp-load-files)))) - (setq ilisp-load-files - (delq (lisp-last ilisp-load-files) - ilisp-load-files)))))))) - (if error (ilisp-handler error wait message output last)) - (setq ilisp-load-files (delq file ilisp-load-files)))))))))
--- a/lisp/ilisp/ilisp-src.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,640 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp-src.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - - -;;; See ilisp.el for more information. - -;;;%Source file operations -(if (not (boundp 'tags-file-name)) (defvar tags-file-name nil)) -(defvar lisp-last-definition nil "Last definition (name type) looked for.") -(defvar lisp-last-file nil "Last used source file.") -(defvar lisp-first-point nil "First point found in last source file.") -(defvar lisp-last-point nil "Last point in last source file.") -(defvar lisp-last-locator nil "Last source locator used.") -(defvar lisp-search nil "Set to T when searching for definitions.") -(defvar lisp-using-tags nil "Set to T when using tags.") - -;;;%%lisp-directory -(defvar lisp-edit-files t - "If T, then buffers in one of lisp-source-modes will be searched by -edit-definitions-lisp if the source cannot be found through the -inferior LISP. It can also be a list of files to edit definitions -from set up by \(\\[lisp-directory]). If it is set to nil, then no -additional files will be searched.") - -;;; -(defun lisp-extensions () - "Return a regexp for matching the extensions of files that enter one -of lisp-source-modes according to auto-mode-alist." - (let ((entries auto-mode-alist) - (extensions nil)) - (while entries - (let ((entry (car entries))) - (if (memq (cdr entry) lisp-source-modes) - (setq extensions - (concat "\\|" (car entry) extensions)))) - (setq entries (cdr entries))) - (substring extensions 2))) - -;;; -(defun lisp-directory (directory add) - "Edit the files in DIRECTORY that have an auto-mode alist entry in -lisp-source-modes. With a positive prefix, add the files on to the -already existing files. With a negative prefix, clear the list. In -either case set tags-file-name to nil so that tags are not used." - (interactive - (list (if (not (eq current-prefix-arg '-)) - (read-file-name "Lisp Directory: " - nil - default-directory - nil)) - current-prefix-arg)) - (setq tags-file-name nil) - (if (eq add '-) - (progn (setq lisp-edit-files t) - (message "No current lisp directory")) - (if add - (message "Added %s as a lisp directory" directory) - (message "%s is the lisp directory" directory)) - (setq directory (expand-file-name directory)) - (if (file-directory-p directory) - (setq lisp-edit-files - (append - (directory-files directory t (lisp-extensions)) - (if add (if (eq lisp-edit-files t) nil lisp-edit-files)))) - (error "%s is not a directory" directory)))) - -;;;%%Utilities - -(defun fix-source-filenames () - "Apply the ilisp-source-directory-fixup-alist to the current buffer - (which will be *Edit-Definitions*) to change any pre-compiled - source-file locations to point to local source file locations. - See ilisp-source-directory-fixup-alist." - (let ((alist (ilisp-value 'ilisp-source-directory-fixup-alist t)) - cons) - (if alist - (save-excursion - (while alist - (setq cons (car alist)) - (goto-char (point-min)) - (if (re-search-forward (car cons) (point-max) t) - (replace-match (cdr cons))) - (setq alist (cdr alist))))))) - -(defun lisp-setup-edit-definitions (message edit-files) - "Set up *Edit-Definitions* with MESSAGE. If EDIT-FILES is T, insert -all buffer filenames that are in one of lisp-source-modes into the -current buffer. If it is a list of files set up by lisp-directory, -insert those in the buffer. If it is a string put that in the buffer." - (setq lisp-using-tags nil - lisp-search (not (stringp edit-files))) - (set-buffer (get-buffer-create "*Edit-Definitions*")) - (erase-buffer) - (insert message) - (insert "\n\n") - (if edit-files - (progn - (if (eq edit-files t) - (let ((buffers (buffer-list))) - (while buffers - (let ((buffer (car buffers))) - (if (save-excursion - (set-buffer buffer) - (and (memq major-mode lisp-source-modes) - (buffer-file-name buffer))) - (progn (insert ?\") (insert (buffer-file-name buffer)) - (insert "\"\n")))) - (setq buffers (cdr buffers)))) - (if (stringp edit-files) - (progn (insert edit-files) - ;; Remove garbage collection messages - (replace-regexp "^;[^\n]*\n" "") - (fix-source-filenames)) - (let ((files edit-files)) - (while files - (insert ?\") - (insert (car files)) - (insert "\"\n") - (setq files (cdr files)))))) - (goto-char (point-min)) - (forward-line 2) - (set-buffer-modified-p nil)) - (error - (substitute-command-keys - "Use \\[lisp-directory] to define source files.")))) - -;;; -(defun lisp-locate-definition (locator definition file point - &optional - back pop) - "Use LOCATOR to find the next DEFINITION (symbol . type) in FILE -starting at POINT, optionally BACKWARDS and POP to buffer. Return T -if successful." - (if file - (if (not (file-exists-p file)) - (progn - (message "File %s doesn't exist!" file) - (sit-for 1) - nil) - (let* ((symbol (car definition)) - (type (cdr definition)) - (first (not (eq lisp-last-file file))) - (buffer (current-buffer)) - name) - (lisp-find-file file pop) - (if first (setq lisp-first-point (point))) - (if back - (if first - (goto-char (point-max)) - (goto-char point) - (forward-line -1) - (end-of-line)) - (goto-char point) - (if (not first) - (progn (forward-line 1) (beginning-of-line)))) - (if (eq type 't) - (message "Search %s for %s" file symbol) - (message "Searching %s for %s %s" file type - (setq name (lisp-buffer-symbol symbol)))) - (if (funcall locator symbol type first back) - (progn - (setq lisp-last-file file - lisp-last-point (point)) - (if (bolp) - (forward-line -1) - (beginning-of-line)) - (recenter 0) - (if name - (message "Found %s %s definition" type name) - (message "Found %s")) - t) - (if first - (goto-char lisp-first-point) - (set-buffer buffer) - (goto-char point)) - nil))))) - -;;; -(defun lisp-next-file (back) - "Return the next filename in *Edit-Definitions*, or nil if none." - (let ((file t) - result) - (set-buffer (get-buffer-create "*Edit-Definitions*")) - (if back - (progn (forward-line -1) - (if (looking-at "\n") - (progn - (forward-line 1) - (end-of-line) - (setq file nil))))) - (if file - (progn - (skip-chars-forward "^\"") - (if (eobp) - (progn (bury-buffer (current-buffer)) - (setq result nil)) - (let* ((start (progn (forward-char 1) (point)))) - (skip-chars-forward "^\"") - (setq file - (prog1 (buffer-substring start (point)) - (end-of-line))) - (bury-buffer (current-buffer)))))) - (if (not (eq file 't)) file))) - -;;; -(defun lisp-next-definition (back pop) - "Go to the next definition from *Edit-Definitions* going BACK with -prefix and POPPING. Return 'first if found first time, 'none if no -definition ever, T if another definition is found, and nil if no more -definitions are found." - (let ((done nil) - (result nil)) - (while - (not - (or - (setq result - (lisp-locate-definition ;Same file - lisp-last-locator - lisp-last-definition lisp-last-file lisp-last-point back)) - (let ((file (lisp-next-file back))) - (if file - (if (lisp-locate-definition - lisp-last-locator lisp-last-definition - file 1 back - (prog1 pop (setq pop nil))) - (setq result 'first) - (setq result (if (not lisp-search) 'none))) - t))))) - (set-buffer (window-buffer (selected-window))) - result)) - -;;;%%Next-definition -(defun next-definition-lisp (back &optional pop) - "Edit the next definition from *Edit-Definitions* going BACK with -prefix and optionally POPPING or call tags-loop-continue if using tags." - (interactive "P") - (if lisp-using-tags - (tags-loop-continue) - (let* ((result (lisp-next-definition back pop)) - (symbol (car lisp-last-definition)) - (type (cdr lisp-last-definition)) - (name (if (not (eq type 't)) (lisp-buffer-symbol symbol)))) - (cond ((or (eq result 'first) (eq result 't)) - (if name - (message "Found %s %s definition" type name) - (message "Found %s" symbol))) - ((eq result 'none) - (error "Can't find %s %s definition" type name)) - (t - (if name - (error "No more %s %s definitions" type name) - (message "Done"))))))) - - -;;;%%Edit-definitions -(defun edit-definitions-lisp (symbol type &optional stay search locator) - "Find the source files for the TYPE definitions of SYMBOL. If STAY, -use the same window. If SEARCH, do not look for symbol in inferior -LISP. The definition will be searched for through the inferior LISP -and if not found it will be searched for in the current tags file and -if not found in the files in lisp-edit-files set up by -\(\\[lisp-directory]) or the buffers in one of lisp-source-modes if -lisp-edit-files is T. If lisp-edit-files is nil, no search will be -done if not found through the inferior LISP. TYPES are from -ilisp-source-types which is an alist of symbol strings or list -strings. With a negative prefix, look for the current symbol as the -first type in ilisp-source-types." - (interactive - (let* ((types (ilisp-value 'ilisp-source-types t)) - (default (if types (car (car types)))) - (function (lisp-function-name)) - (symbol (lisp-buffer-symbol function))) - (if (lisp-minus-prefix) - (list function default) - (list (ilisp-read-symbol - (format "Edit Definition [%s]: " symbol) - function - nil - t) - (if types - (ilisp-completing-read - (format "Type [%s]: " default) - types default)))))) - (let* ((name (lisp-buffer-symbol symbol)) - (symbol-name (lisp-symbol-name symbol)) - (command (ilisp-value 'ilisp-find-source-command t)) - (source - (if (and command (not search) (comint-check-proc ilisp-buffer)) - (ilisp-send - (format command symbol-name - (lisp-symbol-package symbol) - type) - (concat "Finding " type " " name " definitions") - 'source ) - "nil")) - (result (and source (lisp-last-line source))) - (source-ok (not (or (ilisp-value 'comint-errorp t) - (null result) - (string-match "nil" (car result))))) - (case-fold-search t) - (tagged nil)) - (unwind-protect - (if (and tags-file-name (not source-ok)) - (progn (setq lisp-using-tags t) - (if (string-match "Lucid" emacs-version) - (find-tag symbol-name stay) - (find-tag symbol-name nil stay)) - (setq tagged t))) - (if (not tagged) - (progn - (setq lisp-last-definition (cons symbol type) - lisp-last-file nil - lisp-last-locator (or locator (ilisp-value 'ilisp-locator))) - (lisp-setup-edit-definitions - (format "%s %s definitions:" type name) - (if source-ok (cdr result) lisp-edit-files)) - (next-definition-lisp nil t)))))) - -;;;%%Searching -(defun lisp-locate-search (pattern type first back) - "Find PATTERN in the current buffer." - (if back - (search-backward pattern nil t) - (search-forward pattern nil t))) - -;;; -(defun lisp-locate-regexp (regexp type first back) - "Find REGEXP in the current buffer." - (if back - (re-search-backward regexp nil t) - (re-search-forward regexp nil t))) - -;;; -(defvar lisp-last-pattern nil "Last search regexp.") -(defun search-lisp (pattern regexp) - "Search for PATTERN through the files in lisp-edit-files if it is a -list and the current buffers in one of lisp-source-modes otherwise. -If lisp-edit-files is nil, no search will be done. If called with a -prefix, search for regexp. If there is a tags file, call tags-search instead." - (interactive - (list (read-string (if current-prefix-arg - "Search for regexp: " - "Search for: ") lisp-last-pattern) - current-prefix-arg)) - (if tags-file-name - (progn (setq lisp-using-tags t) - (tags-search (if regexp pattern (regexp-quote pattern)))) - (setq lisp-last-pattern pattern - lisp-last-definition (cons pattern t) - lisp-last-file nil - lisp-last-locator (if regexp - 'lisp-locate-regexp - 'lisp-locate-search)) - (lisp-setup-edit-definitions (format "Searching for %s:" pattern) - lisp-edit-files) - (next-definition-lisp nil nil))) - -;;;%%Replacing -(defvar lisp-last-replace nil "Last replace regexp.") -(defun replace-lisp (old new regexp) - "Query replace OLD by NEW through the files in lisp-edit-files if it -is a list and the current buffers in one of lisp-source-modes -otherwise. If lisp-edit-files is nil, no search will be done. If -called with a prefix, replace regexps. If there is a tags file, then -call tags-query-replace instead." - (interactive - (let ((old (read-string (if current-prefix-arg - "Replace regexp: " - "Replace: ") lisp-last-pattern))) - (list old - (read-string (if current-prefix-arg - (format "Replace regexp %s by: " old) - (format "Replace %s by: " old)) - lisp-last-replace) - current-prefix-arg))) - (if tags-file-name - (progn (setq lisp-using-tags t) - (tags-query-replace (if regexp old (regexp-quote old)) - new)) - (setq lisp-last-pattern old - lisp-last-replace new) - (lisp-setup-edit-definitions - (format "Replacing %s by %s:\n\n" old new) - lisp-edit-files) - (let (file) - (while (setq file (lisp-next-file nil)) - (lisp-find-file file) - (let ((point (point))) - (goto-char (point-min)) - (if (if regexp - (re-search-forward old nil t) - (search-forward old nil t)) - (progn (beginning-of-line) - (if regexp - (query-replace-regexp old new) - (query-replace old new))) - (goto-char point))))))) - -;;;%%Edit-callers -(defvar lisp-callers nil - "T if we found callers through inferior LISP.") - -;;; -(defun who-calls-lisp (function &optional no-show) - "Put the functions that call FUNCTION into the buffer *All-Callers* -and show it unless NO-SHOW is T. Return T if successful." - (interactive - (let* ((function (lisp-defun-name)) - (symbol (lisp-buffer-symbol function))) - (if (lisp-minus-prefix) - (list function) - (list (ilisp-read-symbol - (format "Who Calls [%s]: " symbol) - function - t t))))) - (let* ((name (lisp-buffer-symbol function)) - (command (ilisp-value 'ilisp-callers-command t)) - (callers - (if command - (ilisp-send - (format command - (lisp-symbol-name function) - (lisp-symbol-package function)) - (concat "Finding callers of " name) - 'callers))) - (last-line (lisp-last-line callers)) - (case-fold-search t)) - (set-buffer (get-buffer-create "*All-Callers*")) - (erase-buffer) - (insert (format "All callers of function %s:\n\n" name)) - (if (and command (not (ilisp-value 'comint-errorp t))) - (if (string-match "nil" (car last-line)) - (error "%s has no callers" name) - (message "") - (insert (cdr last-line)) - (goto-char (point-min)) - ;; Remove garbage collection messages - (replace-regexp "^;[^\n]*\n" "") - (goto-char (point-min)) - (forward-line 2) - (if (not no-show) - (if (ilisp-temp-buffer-show-function) - (funcall (ilisp-temp-buffer-show-function) - (get-buffer "*All-Callers*")) - (view-buffer "*All-Callers*"))) - t) - (insert "Using the current source files to find callers.") - nil))) - -;;; -(defun next-caller-lisp (back &optional pop) - "Edit the next caller from *All-Callers*. With prefix, edit -the previous caller. If it can't get caller information from the -inferior LISP, this will search using the current source files. See -lisp-directory." - (interactive "P") - (if (not lisp-callers) - (next-definition-lisp back pop) - (set-buffer (get-buffer-create "*All-Callers*")) - (if back (forward-line -1)) - (skip-chars-forward " \t\n") - (if (eobp) - (progn - (bury-buffer (current-buffer)) - (error "No more callers")) - (let* ((start (point)) - (caller-function - (progn - (skip-chars-forward "^ \t\n") - (buffer-substring start (point))))) - (bury-buffer (current-buffer)) - (edit-definitions-lisp (lisp-string-to-symbol caller-function) - (car (car (ilisp-value 'ilisp-source-types))) - (not pop)))))) - -;;; -(defun edit-callers-lisp (function) - "Edit the callers of FUNCTION. With a minus prefix use the symbol -at the start of the current defun." - (interactive - (let* ((function (lisp-defun-name))) - (if (lisp-minus-prefix) - (list function) - (list (ilisp-read-symbol - (format "Edit callers of [%s]: " - (lisp-buffer-symbol function)) - function - t))))) - (if (save-excursion (setq lisp-callers (who-calls-lisp function t))) - (progn - (setq lisp-last-locator (ilisp-value 'ilisp-calls-locator)) - (next-caller-lisp nil t)) - (edit-definitions-lisp function "calls" nil t - (ilisp-value 'ilisp-calls-locator)))) - -;;;%Locators -(defun lisp-re (back format &rest args) - "Search BACK if T using FORMAT applied to ARGS." - (let ((regexp (apply 'format format args))) - (if back - (re-search-backward regexp nil t) - (re-search-forward regexp nil t)))) - -;;; -(defun lisp-locate-ilisp (symbol type first back) - "Find SYMBOL's TYPE definition in the current file and return T if -successful. A definition is of the form -\(def<whitespace>(?name<whitespace>." - (lisp-re back - "^[ \t\n]*(def[^ \t\n]*[ \t\n]+(?%s[ \t\n(]+" - (regexp-quote (lisp-symbol-name symbol)))) - -;;; -(defun lisp-locate-calls (symbol type first back) - "Locate calls to SYMBOL." - (lisp-re back "\\(#'\\|(\\|'\\)%s\\([ \t\n]+\\|)\\)" - (regexp-quote (lisp-buffer-symbol symbol)))) - - -;;;%%Common LISP - -(defvar ilisp-cl-source-locater-patterns - '((setf - "^\\(.\\)?[ \t\n]*(def[^ \t\n]*\\([ \t\n]+\\(.\\)?[ \t\n]*\\|[ \t\n]*.[ \t\n]+\\)(setf\\([ \t\n]+\\(.\\)?[ \t\n]*\\|[ \t\n]*.[ \t\n]+\\)%s[ \t\n]*\\(.\\)?[ \t\n]*)") - - (function - "^\\(.\\)?[ \t\n]*(defun\\([ \t\n]+\\(.\\)?[ \t\n]*\\|[ \t\n]*.[ \t\n]+\\)%s[ \t\n(]") - - (macro - "^\\(.\\)?[ \t\n]*(defmacro\\([ \t\n]+\\(.\\)?[ \t\n]*\\|[ \t\n]*.[ \t\n]+\\)%s[ \t\n(]") - - (variable - "^\\(.\\)?[ \t\n]*(def\\(\\(var\\)\\|\\(parameter\\)\\|constant\\)\\([ \t\n]+\\(.\\)?[ \t\n]*\\|[ \t\n]*.[ \t\n]+\\)%s[ \t\n(]") - - (structure - "^\\(.\\)?[ \t\n]*(defstruct\\([ \t\n]+\\(.\\)?[ \t\n]*\\|[ \t\n]*.[ \t\n]+\\)(?[ \t\n]*\\(.\\)?[ \t\n]*%s[ \t\n(]") - - (type - "^\\(.\\)?[ \t\n]*(deftype\\([ \t\n]+\\(.\\)?[ \t\n]*\\|[ \t\n]*.[ \t\n]+\\)%s[ \t\n(]") - - (class - "^\\(.\\)?[ \t\n]*(defclass\\([ \t\n]+\\(.\\)?[ \t\n]*\\|[ \t\n]*.[ \t\n]+\\)%s[ \t\n(]") - )) - - -(defun ilisp-locate-clisp-defn (name type back) - (let ((pattern (car (cdr (assoc (intern type) ilisp-cl-source-locater-patterns))))) - (if pattern - (lisp-re back pattern name)))) - - - -(defun ilisp-locate-clos-method (name type back) - (if (string-match "(\\([^(]*\\)\\(([^)]*)\\)" type) - (let* ((quals (substring type (match-beginning 1) (match-end 1))) - (class - (read (substring type (match-beginning 2) (match-end 2)))) - (class-re nil) - (position 0)) - (while (setq position (string-match - "\\([ \t\n]+.[ \t\n]*\\|[ \t\n]*.[ \t\n]+\\|[ \t\n]+\\)" - quals position)) - (setq quals - (concat (substring quals 0 position) - "\\([ \t\n]+.[ \t\n]*\\|[ \t\n]*.[ \t\n]+\\|[ \t\n]+\\)" - (substring quals (match-end 0))))) - (while class - (setq class-re - (concat - class-re - (format - "[ \t\n]*\\(.\\)?[ \t\n]*([ \t\n]*\\(.\\)?[ \t\n]*[^ \t\n]*\\([ \t\n]+\\(.\\)?[ \t\n]*\\|[ \t\n]*.[ \t\n]+\\)%s[ \t\n]*\\(.\\)?[ \t\n]*" - (car class))) - class (cdr class))) - (lisp-re back - "^\\(.\\)?[ \t\n]*(def[^ \t\n]*\\([ \t\n]+\\(.\\)?[ \t\n]*\\|[ \t\n]*.[ \t\n]+\\)%s\\([ \t\n]+\\(.\\)?[ \t\n]*\\|[ \t\n]*.[ \t\n]+\\)%s[^ \t\n]*([^ \t\n]*%s" - name quals class-re)))) - - - - -(defun lisp-locate-clisp (symbol type first back) - "Try to find SYMBOL's TYPE definition in the current buffer and return -T if sucessful. FIRST is T if this is the first time in a file. BACK -is T to go backwards." - (let* ((name (regexp-quote (lisp-symbol-name symbol))) - (prefix - ;; Automatically generated defstruct accessors - (if (string-match "-" name) - (let ((struct (substring name 0 (1- (match-end 0))))) - (format - "^\\(.\\)?[ \t\n]*(def[^ \t\n]*\\([ \t\n]+\\(.\\)?\\|\\|[ \t\n]*.[ \t\n]+\\)(?%s[ \t\n)]\\|:conc-name\\([ \t\n]+\\(.\\)?[ \t\n]*\\|[ \t\n]*.[ \t\n]+\\)%s-" - struct struct)))) - ;; Defclass accessors - (class - "\\(:accessor\\|:writer\\|:reader\\)\\([ \t\n]+\\(.\\)?+[ \t\n]*\\|[ \t\n]*.[ \t\n]+\\)%s[ \t\n)]")) - (or - (if (equal type "any") - (lisp-re - back - (concat - "^\\(.\\)?[ \t\n]*(def[^ \t\n]*\\([ \t\n]+\\(.\\)?[ \t\n]*\\|[ \t\n]*.[ \t\n]+\\)\\((setf\\([ \t\n]+\\(.\\)?[ \t\n]*\\|[ \t\n]*.[ \t\n]+\\)\\|(?[ \t\n]*\\(.\\)?[ \t\n]*\\)%s[ \t\n)]" - (if prefix (concat "\\|" prefix)) - "\\|" - class) - name name)) - - ;; (qualifiers* (type1 type2 ...)) - (ilisp-locate-clos-method name type back) - - (ilisp-locate-clisp-defn name type back) - - ;; Standard def form - (if first (lisp-locate-ilisp symbol type first back)) - ;; Automatically generated defstruct accessors - (if (and first prefix) (lisp-re back prefix)) - ;; Defclass accessors - (lisp-re back class name) - ;; Give up! - )))
--- a/lisp/ilisp/ilisp-sym.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,49 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp-sym.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - - -;;; -;;; ILISP Lisp symbol utils. -;;; - -;;;%%Symbol -(defun lisp-symbol (package delimiter name) - "Create a LISP symbol." - (list package (if package (or delimiter "::")) name)) -(defun lisp-symbol-name (symbol) - "Return the name of SYMBOL." - (car (cdr (cdr symbol)))) -(defun lisp-symbol-package (symbol) - "Return the package of SYMBOL." - (car symbol)) -(defun lisp-symbol-delimiter (symbol) - "Return the qualifier of SYMBOL." - (car (cdr symbol))) - -;;; -(defun lisp-symbol= (symbol1 symbol2) - "Return T is SYMBOL1 is equal to SYMBOL2." - (and (string= (lisp-symbol-name symbol1) (lisp-symbol-name symbol2)) - (string= (lisp-symbol-package symbol1) (lisp-symbol-package symbol2)) - (string= (lisp-symbol-delimiter symbol1) - (lisp-symbol-delimiter symbol2))))
--- a/lisp/ilisp/ilisp-utl.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,129 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp-utl.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - - -;;; -;;; ILISP misc tools. -;;; - -(defun lisp-show-send (string) - "Show STRING in the *ilisp-send* buffer." - (save-excursion - (if (ilisp-buffer) - (set-buffer "*ilisp-send*") - (error "You must start an inferior LISP with run-ilisp.")) - (erase-buffer) - (insert string) - string)) - - -;;; -(defun lisp-slashify (string) - "Put string in the *ilisp-send* buffer, put backslashes before -quotes and backslashes and return the resulting string." - (save-excursion - (lisp-show-send string) - (set-buffer "*ilisp-send*") - (goto-char (point-min)) - (while (search-forward "\\" nil t) - (delete-char -1) - (insert "\\\\")) - (goto-char (point-min)) - (while (search-forward "\"" nil t) - (backward-char) - (insert ?\\) - (forward-char)) - (buffer-substring (point-min) (point-max)))) - - -;;;%%String -(defun lisp-prefix-p (s1 s2) - "Returns t if S1 is a prefix of S2 considering all non alphanumerics -as word delimiters." - (let ((len1 (length s1))) - (and (<= len1 (length s2)) - (let ((start 0) - (start2 0) - end - (match t)) - (while - (if (setq end (string-match "[^a-zA-Z0-9]" s1 start)) - ;; Found delimiter - (if (string= (substring s1 start end) - (substring s2 start2 (+ start2 (- end start)))) - ;; Words are the same - (progn (setq start (match-end 0)) - (if (string-match - (regexp-quote (substring s1 end start)) - s2 start2) - (setq start2 (match-end 0)) ;OK - (setq match nil))) ;Can't find delimiter - (setq match nil)) ;Words don't match - nil)) ;Ran out of delimiters in s1 - (and match - (string= (substring s1 start len1) - (substring s2 start2 (+ start2 (- len1 start))))))))) - - -;;; -(defun lisp-last-line (string) - "Return the last line of STRING with everything else." - (let* ((position 0)) - (while (string-match "\\(\n+\\)[^\n]" string position) - (setq position (match-end 1))) - (cons (substring string position) - (substring string 0 position)))) - - -;;;%%File -;;; -(defun lisp-file-extension (file extension) - "Return FILE with new EXTENSION." - (concat (substring file 0 (string-match ".[^.]*$" file)) - "." extension)) - -(defun ilisp-directory (file &optional dirs) - "Return the directory of DIRS that FILE is found in. By default -load-path is used for the directories." - (let* ((dirs (or dirs (cons "" load-path))) - (dir (car dirs))) - (while (and dir (not (file-exists-p (expand-file-name file dir)))) - (setq dirs (cdr dirs) - dir (car dirs))) - dir)) - - -;;; ilisp-update-status -- -;;; -;;; Note: changed in order to propagate the status change in the -;;; underlying process to the menu. - -(defun ilisp-update-status (status) - "Update process STATUS of the whole Ilisp system. -It updates the STATUS of the current buffer and let all lisp mode -buffers know as well. Also, do some 'exterior' things like make sure -that the menubar is in a consistent state." - (setq ilisp-status (if lisp-show-status (format " :%s" status))) - (if (not (member +ilisp-emacs-version-id+ '(xemacs lucid-19 lucid-19-new))) - (ilisp-update-menu status)) - (comint-update-status status))
--- a/lisp/ilisp/ilisp-val.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,48 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp-val.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - - -;;; -;;; ILISP buffer value interface -;;; -;;; - -;;; -(defun ilisp-value (variable &optional no-error-p) - "Return the value of VARIABLE in the ILISP buffer. -If NO-ERROR-P is NIL, then an error will be signalled if VARIABLE is nil." - (save-excursion - (set-buffer (ilisp-buffer)) - (let ((value (eval variable))) - (if value - value - (if no-error-p - nil - (error "%s is not defined." variable)))))) - -;;; -(defun set-ilisp-value (variable value) - "Set the value of VARIABLE in the ILISP buffer." - (save-excursion - (set-buffer (ilisp-buffer)) - (set variable value)))
--- a/lisp/ilisp/ilisp-xfr.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,149 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp-xfr.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - - -;;; -;;; ILISP transfer commands Lisp <-> Emacs -;;; - - -;; It's too bad that this function copies so much code from comint-send-input. -;; It ought to be a wrapper around it, instead. - -(defun return-ilisp () - "Grab the current expression with comint-get-old-input. If we have -a complete sexp, send it. Otherwise, indent appropriately." - (interactive) - (let ((proc (get-buffer-process (current-buffer)))) - (if (not proc) (error "Current buffer has no process") - (let* ((pmark (process-mark proc)) - (input (ilisp-get-old-input))) - (if input - (progn - (if (>= (point) pmark) - (goto-char (point-max)) - (goto-char pmark) - (insert input)) - (if (not ilisp-no-newline) (insert ?\n)) - (if (and (funcall comint-input-filter input) - (or (ring-empty-p (ilisp-get-input-ring)) - (not (string= (ring-ref (ilisp-get-input-ring) 0) - input)))) - (ilisp-ring-insert (ilisp-get-input-ring) input)) - (funcall comint-input-sentinel input) - ;; Ugh, comint changing under my feet.... - ;; Note: This used to be - ;; (eq ilisp-emacs-version-id 'gnu-19) - ;; 25/11/94 Marco Antoniotti - (if (eq +ilisp-emacs-version-id+ 'fsf-19) - (setq comint-input-ring-index nil)) - ;; Nuke symbol table - (setq ilisp-original nil) - (funcall comint-input-sender proc input) - (set-marker (process-mark proc) (point)) - (set-marker comint-last-input-end (point)) - (goto-char (point-max))) - (if (= pmark (point-max)) - (let ((comint-send-newline t)) - (if (not ilisp-no-newline) (insert ?\n)) - (set-marker (process-mark proc) (point)) - (funcall comint-input-sender proc "")) - (insert ?\n) - (save-restriction - (narrow-to-region pmark (point-max)) - (funcall indent-line-function)))))))) - -;;;%%Keyboard mode -(defun raw-keys-ilisp () - "Start using raw keyboard mode to send each character typed to the -inferior LISP until a key bound to interactive-keys-ilisp is -encountered. See also io-bridge-ilisp." - (interactive) - (if (not ilisp-raw-map) - (let ((map (make-keymap))) - (fillarray map 'ilisp-send-char) - (if (string-match "Lucid" emacs-version) - ;; not necessary, but friendlier. - (progn - (setq ilisp-completion-map (make-keymap)) -;; (set-keymap-name ilisp-completion-map 'ilisp-completion-map) -;; (set-keymap-parent ilisp-completion-map lisp-mode-map) - )) - (define-key map "\C-g" 'interactive-keys-ilisp) - (setq ilisp-raw-map map))) - (use-local-map ilisp-raw-map) - (message ilisp-raw-message)) - -;;; -(defun interactive-keys-ilisp () - "Go back to interactive keyboard interactions in the inferior LISP." - (interactive) - (use-local-map ilisp-use-map) - (message "Interactive keyboard mode")) - -;;; -(defun ilisp-send-char () - "Send the last typed character to the current inferior LISP echoing -if ilisp-raw-echo is T." - (interactive) - (if (ilisp-value 'ilisp-raw-echo t) - (progn - (goto-char (point-max)) - (insert last-input-char) - (set-marker (process-mark (ilisp-process)) (point)) - (set-marker comint-last-input-end (point)))) - (process-send-string (ilisp-process) - (make-string 1 last-input-char)) - (message ilisp-raw-message)) - -;;; -(defun ilisp-raw-handler (process output) - "Turn on raw keyboard mode." - (raw-keys-ilisp)) -(defun ilisp-interactive-handler (process output) - "Turn on interactive keyboard mode." - (interactive-keys-ilisp)) - -;;; -(defun io-bridge-ilisp () - "Set up so that the inferior LISP can turn on EMACS raw mode by -sending ^[1^] and turn it off by sending ^[0^]." - (interactive) - (require 'bridge) - (install-bridge) - (setq bridge-handlers (cons '("1" . ilisp-raw-handler) - (cons '("0" . ilisp-interactive-handler) - bridge-handlers)))) - -;;;%%Debugger interface -(defun delete-char-or-pop-ilisp (arg &optional killflag) - "Delete ARG characters, or pop break level if at end of buffer. -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." - (interactive "p") - (if (eobp) - (progn - (message "Pop LISP one level") - (comint-simple-send (ilisp-process) (ilisp-value 'comint-fix-error))) - (call-interactively 'delete-char (list arg killflag))))
--- a/lisp/ilisp/ilisp-xls.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,46 +0,0 @@ -;;; -*-Mode: Emacs-Lisp-*- - -;;; ilisp-xls.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - -;;; -;;; ILISP Xlisp and Xlisp-Stat dialect definition -;;; - -;;; Thanks to John Walker for supplying this file. - - -(defdialect xlisp "Xlisp" ilisp - (setq ilisp-load-command "(load \"%s\")" - ilisp-last-command "*") - ) - -(if (not xlisp-program) (setq xlisp-program "xlisp")) - -;;;%%Xlisp-Stat - -(defdialect xlispstat "Xlisp-Stat" xlisp - (setq ilisp-binary-extension "fsl" - ;; ilisp-describe-command "(help %s)")) - )) - -(if (not xlispstat-program) (setq xlispstat-program "xlispstat")) - -;;; endo of file -- ilisp-xls.el --
--- a/lisp/ilisp/ilisp.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,188 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - - -;;; Author: Chris McConnell <ccm@cs.cmu.edu> -;;; Maintainer: The Net <ilisp@naggum.no> -;;; Created: 14 Jun 1994 -;;; Version: 5.8 -;;; Keywords: lisp common-lisp scheme comint - -;;; This file may become part of GNU Emacs in the near future. - -;;; GNU Emacs is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY. No author or distributor -;;; accepts responsibility to anyone for the consequences of using it -;;; or for whether it serves any particular purpose or works at all, -;;; unless he says so in writing. Refer to the GNU Emacs General Public -;;; License for full details. - -;;; Everyone is granted permission to copy, modify and redistribute -;;; GNU Emacs, but only under the conditions described in the -;;; GNU Emacs General Public License. A copy of this license is -;;; supposed to have been given to you along with GNU Emacs so you -;;; can know your rights and responsibilities. It should be in a -;;; file named COPYING. Among other things, the copyright notice -;;; and this notice must be preserved on all copies. - -;;; ***************************************************************** -;;; Please read the texinfo file (via m-x info in emacs or tex it and -;;; print it out) for installation instructions. -;;; ***************************************************************** - -;;; This file defines a generic LISP interface that can be customized -;;; to match a specific LISP dialect. Support is already provided for -;;; a number of common LISP dialects. Lucid, Allegro and CMU are -;;; fully supported. Other LISP dialects are missing features like -;;; arglist and find-source. - -;;; Since this is built on top of the general command-interpreter-in- -;;; a-buffer mode (comint mode), it shares a common base -;;; functionality, and a common set of bindings, with all modes -;;; derived from comint mode. This makes it easier to use. - -;;; For documentation on the functionality provided by comint mode, -;;; and the hooks available for customizing it, see the file -;;; comint.el. - -;;; Throughout this file you will find comment lines with %'s on them. -;;; These lines define sections for outline mode which I use while -;;; programming to temporarily hide code. - -;;; See the documentation for ILISP mode, or read texinfo document for -;;; information. All of the EMACS function names begin or end with -;;; lisp or ilisp to separate ilisp functions from functions in other -;;; packages. Functions that work only in lisp buffers or that work -;;; in both lisp buffers and inferior lisp buffers use lisp, all other -;;; functions use ilisp. If a function is intended to be used -;;; interactively, then the lisp or ilisp comes at the end of the -;;; function name, otherwise at the start. - -;;;%%KNOWN BUGS -;;; -;;; If you type multiple things to the top level before you get a -;;; prompt, the LISP may be running with the status light indicating -;;; ready. This is because I have no way to distinguish between input -;;; to a program and that to the top level. -;;; -;;; When running a lisp on Ultrix, you need to set ilisp-program to -;;; "/bin/sh -c your/path/your-lisp-image". -;;; -;;; If you get lisp output breaking up in weird places it almost -;;; certainly means that comint-prompt-regexp is not precise enough. -;;; -;;; I would like to eat Lucid's return from break in the process -;;; filter, but I can't tell how many newlines to eat after. - - -;;;%%CONTRIBUTORS - -;; Recent contributors include (in alphabetical order): - -;; Marco Antoniotti, Robert P. Goldman, Larry Hunter, Eyvind Ness, -;; Ivan Vazquez, Fred White - - -;;;%Requirements -(if (string-match "\\`18" emacs-version) - (load "comint-v18") ; Included older version of comint. - (require 'comint)) - - -;;; This is the old call. The new one is just below. It now dispatches -;;; on the correct type of Emacs. -;;;(load "ilisp-cpat") -(load "ilcompat") - -(load "comint-ipc") - -;; This is optional -- used only by io-bridge-ilisp -(if (not (and (eq +ilisp-emacs-version-id+ 'fsf-19) - (>= +ilisp-emacs-minor-version-number+ 29))) - (load "bridge")) - -(if (load "ilisp-all.elc" t) - t - (progn ; I know it is useless in Elisp. - (load "ilisp-def") - (load "ilisp-el") - (load "ilisp-sym") - (load "ilisp-inp") - (load "ilisp-ind") - - (load "ilisp-prc") - (load "ilisp-val") - (load "ilisp-out") - (load "ilisp-mov") - (load "ilisp-key") - (load "ilisp-prn") - (load "ilisp-low") - (load "ilisp-doc") - (load "ilisp-ext") ; Some emacs-lisp - ; bindings. Lisp char syntax. - (load "ilisp-mod") - (load "ilisp-dia") - (load "ilisp-cmt") - (load "ilisp-rng") - (load "ilisp-hnd") - (load "ilisp-utl") - (load "ilisp-cmp") - (load "ilisp-kil") - (load "ilisp-snd") - (load "ilisp-xfr") - (load "ilisp-hi") - (load "ilisp-aut") - - ;; Dialects. - ;; The user will define their autoloads to load "ilisp" when trying - ;; to run their dialect. This will load all of the dialects in. - (load "ilisp-cl") - (load "ilisp-cmu") - (load "ilisp-acl") - (load "ilisp-hlw") - (load "ilisp-kcl") - (load "ilisp-luc") - (load "ilisp-sch") - )) - -;;; Create the keymaps before running the hooks. -;;; This is necessary if you want the lispm bindings in the load -;;; hook. Otherwise you need to put it AFTER the running of the hooks - -;;; (if (not ilisp-mode-map) (ilisp-bindings)) - - -;;; Now run the hooks. - -(run-hooks 'ilisp-site-hook) -;;; (run-hooks 'load-hook) -(run-hooks 'ilisp-load-hook) ; It seem s more reasonable. - -(if (not ilisp-mode-map) (ilisp-bindings)) - -;;; Optional: -; (load "ilisp-menu") -(if (not (member +ilisp-emacs-version-id+ '(xemacs lucid-19 lucid-19-new))) - (load "ilisp-mnb")) - -(provide 'ilisp)
--- a/lisp/ilisp/ilisp.emacs Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,155 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; ilisp.emacs -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. - -;;; This file shows examples of some of the things you might want to -;;; do to install or customize ILISP. You may not want to include all -;;; of them in your .emacs. For example, the default key binding -;;; prefix for ILISP is C-z and this file changes the default prefix to -;;; C-c. For more information on things that can be changed, see the -;;; file ilisp.el. - - -;;; If ilisp lives in some non-standard directory, you must tell emacs -;;; where to get it. This may or may not be necessary. - -(setq load-path (cons (expand-file-name "~jones/emacs/ilisp/") load-path)) - - -;;; If you always want partial minibuffer completion - -(require 'completer) - -;;; If want TMC completion then you will have to Ftp it yourself from think.com -;;; It's become to flaky for me to deal with. -- Ivan -;;;(load "completion") -;;;(initialize-completions) - -;;; If you want to redefine typeout-window keys: -;;;(add-hook 'ilisp-load-hook -;;; '(lambda () -;;; (define-key global-map "\C-c1" 'ilisp-bury-output) -;;; (define-key global-map "\C-cv" 'ilisp-scroll-output) -;;; (define-key global-map "\C-cg" 'ilisp-grow-output))) - - -;;; Autoload based on your LISP. You only really need the one you use. -;;; If called with a prefix, you will be prompted for a buffer and -;;; program. -;;; -;;; [Back to the old way now -- Ivan Mon Jun 28 23:30:51 1993] -;;; - -(autoload 'run-ilisp "ilisp" "Select a new inferior LISP." t) - -(autoload 'clisp "ilisp" "Inferior generic Common LISP." t) - -;;; Franz -;(autoload 'allegro "ilisp" "Inferior Allegro Common LISP." t) - -;;; Lucid -;(autoload 'lucid "ilisp" "Inferior Lucid Common LISP." t) - -;;; Harlequin -;(autoload lispworks "ilisp" "Inferior Harlequin Common LISP (LispWorks)." t) -;(autoload harlequin "ilisp" "Inferior Harlequin Common LISP (LispWorks)." t) -;(autoload pulcinella "ilisp" "Inferior Harlequin Common LISP (LispWorks)." t) -;;; Italian "Commedia dell'Arte" twist. - -;;; CMULISP -(autoload 'cmulisp "ilisp" "Inferior CMU Common LISP." t) - -;;; CLISP (Bruno Haible and XX stoll) -;(autoload 'clisp-hs "ilisp" "Inferior Haible/Stoll CLISP Common LISP." t) - -;;; KCL's -;(autoload 'kcl "ilisp" "Inferior Kyoto Common LISP." t) -(autoload 'akcl "ilisp" "Inferior Austin Kyoto Common LISP." t) -;(autoload 'ibcl "ilisp" "Ibuki Common LISP." t) -(autoload 'gcl "ilisp" "Inferior GNU Common LISP." t) -(autoload 'ecl "ilisp" "Inferior EcoLisp." t) - -;;; Xlisp -(autoload 'xlisp "ilisp" "Inferior xlisp." t) -(autoload 'xlispstat "ilisp" "Inferior xlispstat." t) - -;;; Scheme's -;(autoload 'scheme "ilisp" "Inferior generic Scheme." t) -;(autoload 'oaklisp "ilisp" "Inferior Oaklisp Scheme." t) - - -;;; Define where LISP programs are found. (This may already be done -;;; at your site.) - -;(setq allegro-program "/usr/misc/.allegro/bin/cl") - -;(setq lucid-program "/usr/misc/.lucid/bin/lisp") - -;(setq clisp-hs-program "clisp") - -;(setq lispworks-program "/somewhere/in/the/directory/tree/lispworks") - -(setq cmulisp-program "/usr/robotics/shared/lang/cmu-cl/17e/bin/lisp") - -(setq akcl-program "kcl") -;(setq gcl-program "gcl") -;(setq ecl-program "ecl") - -;(setq xlisp-program "xlisp") -;(setq xlisp-program "xlispstat") - -;;; If you run cmu-cl then set this to where your source files are. -(setq cmulisp-local-source-directory "/usr/robotics/shared/cmu-cl/17e/") - - -;;; This makes reading a lisp file load in ilisp. -(set-default 'auto-mode-alist - (append '(("\\.lisp$" . lisp-mode)) auto-mode-alist)) -(setq lisp-mode-hook '(lambda () (require 'ilisp))) - -;;; Sample load hook -(add-hook 'ilisp-load-hook - (function - (lambda () - ;; Change default key prefix to C-c - (setq ilisp-prefix "\C-c") - - ;; Make sure that you don't keep popping up the 'inferior - ;; lisp' buffer window when this is already visible in - ;; another frame. Actually this variable has more impact - ;; than that. Watch out. - ;(setq pop-up-frames t) - - (message "Running ilisp-load-hook") - ;; Define LispMachine-like key bindings, too. - ;; (ilisp-lispm-bindings) Sample initialization hook. - - ;; Set the inferior LISP directory to the directory of - ;; the buffer that spawned it on the first prompt. - (add-hook 'ilisp-init-hook - (function - (lambda () - (default-directory-lisp ilisp-last-buffer)))) - ))) - -(add-hook 'ilisp-site-hook - (function - (lambda () - (setq ilisp-init-binary-extension "sparcf") - (setq ilisp-init-binary-command "(progn \"sparcf\")") - ;; (setq ilisp-binary-extension "sparcf") - ))) - - -;;; end of file -- ilisp.emacs --
--- a/lisp/ilisp/illuc19.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,84 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; illuc19.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - - -;;;============================================================================ -;;; Functions - -(defun ilisp-get-input-ring () - "Use instead of get-input-ring coming-input-ring or input-ring." - (if (eq +ilisp-emacs-version-id+ 'lucid-19) - (get-input-ring) - ;; else lucid-19-new - comint-input-ring)) - - -(defun ilisp-ring-insert (ring input) - (if (eq +ilisp-emacs-version-id+ 'lucid-19) - (ring-insert-new ring input) - (ring-insert ring input))) - - -(defun ilisp-temp-buffer-show-function-symbol () - 'temp-buffer-show-function) - - -(defun set-ilisp-temp-buffer-show-function (val) - (setq temp-buffer-show-function val)) - - -(defun ilisp-temp-buffer-show-function () - temp-buffer-show-function) - - -(defun ilisp-input-ring-index () - (if (eq +ilisp-emacs-version-id+ 'lucid-19-new) - comint-input-ring-index - input-ring-index)) - - -(defun set-ilisp-input-ring-index (n) - (if (eq +ilisp-emacs-version-id+ 'lucid-19-new) - (setq comint-input-ring-index n) - (setq input-ring-index n))) - - -(defun ilisp-input-ring-size () - (if (eq +ilisp-emacs-version-id+ 'lucid-19-new) - comint-input-ring-size - input-ring-size)) - - -(defun set-ilisp-input-ring-size (n) - (if (eq +ilisp-emacs-version-id+ 'lucid-19-new) - (setq comint-input-ring-size n) - (setq input-ring-size n))) - - -;;============================================================================ -;;; Epilogue - -(provide 'il-luc19) - -;;; end of file -- il-luc19.el -- -
--- a/lisp/ilisp/ilxemacs.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,93 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; illuc19.el -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - -;;;============================================================================ -;;; Variables - -;;; XEmacs 19.14 doesn't have comint-input-chunk-size but earlier -;;; versions do, so we define here if needed. (toy@rtp.ericsson.se) - -(if (not (boundp 'comint-input-chunk-size)) - (setq comint-input-chunk-size 512)) - - - -;;;============================================================================ -;;; Functions - -(defun ilisp-get-input-ring () - "Use instead of get-input-ring coming-input-ring or input-ring." - (if (eq +ilisp-emacs-version-id+ 'lucid-19) - (get-input-ring) - ;; else lucid-19-new - comint-input-ring)) - - -(defun ilisp-ring-insert (ring input) - (if (eq +ilisp-emacs-version-id+ 'lucid-19) - (ring-insert-new ring input) - (ring-insert ring input))) - - -(defun ilisp-temp-buffer-show-function-symbol () - 'temp-buffer-show-function) - - -(defun set-ilisp-temp-buffer-show-function (val) - (setq temp-buffer-show-function val)) - - -(defun ilisp-temp-buffer-show-function () - temp-buffer-show-function) - - -(defun ilisp-input-ring-index () - (if (eq +ilisp-emacs-version-id+ 'lucid-19-new) - comint-input-ring-index - input-ring-index)) - - -(defun set-ilisp-input-ring-index (n) - (if (eq +ilisp-emacs-version-id+ 'lucid-19-new) - (setq comint-input-ring-index n) - (setq input-ring-index n))) - - -(defun ilisp-input-ring-size () - (if (eq +ilisp-emacs-version-id+ 'lucid-19-new) - comint-input-ring-size - input-ring-size)) - - -(defun set-ilisp-input-ring-size (n) - (if (eq +ilisp-emacs-version-id+ 'lucid-19-new) - (setq comint-input-ring-size n) - (setq input-ring-size n))) - - -;;============================================================================ -;;; Epilogue - -(provide 'il-luc19) - -;;; end of file -- il-luc19.el -- -
--- a/lisp/ilisp/lispworks.lisp Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,121 +0,0 @@ -;;; -*- Mode: Lisp -*- - -;;; lispworks.lisp -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - - -;;; LispWorks ILISP initializations. -;;; -;;; Independently written by: -;;; -;;; Jason Trenouth: jason@harlequin.co.uk -;;; Qiegang Long: qlong@cs.umass.edu -;;; -;;; and later merged together by Jason - - -(in-package "ILISP") - -(defun ilisp-callers (symbol package) - "Print a list of all of the functions that call FUNCTION. -Return T if successful." - (ilisp-errors - (let ((function-name (ilisp-find-symbol symbol package)) - (*print-level* nil) - (*print-length* nil) - (*package* (find-package 'lisp)) - (callers ()) - ) - (when (and function-name (fboundp function-name)) - (setf callers (munge-who-calls (lw:who-calls function-name))) - (dolist (caller callers) - (print caller)) - t)))) - -;; gross hack to munge who-calls output for ILISP -(defun munge-who-calls (who-calls) - (labels ((top-level-caller (form) - (if (atom form) - form - (top-level-caller (second form))))) - (delete-if-not 'symbolp - (delete-duplicates (mapcar #'top-level-caller who-calls))))) - - -;; Jason 6 SEP 94 -- tabularized Qiegang's code -;; -;; There are some problems lurking here: -;; - the mapping ought to be done by LispWorks -;; - surely you really want just three source types: -;; function, type, and variable -;; -(defconstant *source-type-translations* - '( - ("class" defclass) - ("function" ) - ("macro" ) - ("structure" defstruct) - ("setf" defsetf) - ("type" deftype) - ("variable" defvar defparameter defconstant) - )) - - -(defun translate-source-type-to-dspec (symbol type) - (let ((entry (find type *source-type-translations* - :key 'first :test 'equal))) - (if entry - (let ((wrappers (rest entry))) - (if wrappers - (loop for wrap in wrappers collecting `(,wrap ,symbol)) - `(,symbol))) - (error "unknown source type for ~S requested from ILISP: ~S" - symbol type)))) - - -(defun ilisp-source-files (symbol package type) - "Print each file for PACKAGE:SYMBOL's TYPE definition on a line and -return T if successful. A function to limit the search with type?" - (ilisp-errors - (let* ((symbol (ilisp-find-symbol symbol package)) - (all (equal type "any")) - (paths (when symbol (compiler::find-source-file symbol))) - (dspecs (or all (translate-source-type-to-dspec symbol type))) - (cands ()) - ) - (if (and paths (not all)) - (setq cands - (loop for path in paths - when (find (car path) dspecs :test 'equal) - collect path)) - (setq cands paths)) - (if cands - (progn - (dolist (file (remove-duplicates paths - :key #'cdr :test #'equal)) - (print (namestring (cadr file)))) - t) - nil)))) - -(unless (compiled-function-p #'ilisp-callers) - (format t "\"ILISP: File is not compiled, use M-x ilisp-compile-inits\"")) - -;;; end of file -- lispworks.lisp --
--- a/lisp/ilisp/lucid.lisp Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,86 +0,0 @@ -;;; -*- Mode: Lisp -*- - -;;; lucid.lisp -- - -;;; This file is part of ILISP. -;;; Version: 5.8 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker -;;; 1996 Marco Antoniotti and Rick Campbell -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@naggum.no' to be included in the -;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - - -;;; Lucid initializations -;;; Author: Chris McConnell, ccm@cs.cmu.edu -;;; -(in-package "ILISP") - -;;; -(defun ilisp-callers (symbol package &aux (list-of-callers nil)) - "Print the callers of PACKAGE::SYMBOL. Only compiled functions -currently. Return T if successful." - (ilisp-errors - (let ((function-name (ilisp-find-symbol symbol package)) - (*print-level* nil) - (*print-length* nil) - (*package* (find-package 'lisp))) - (when (and function-name (fboundp function-name)) - (flet - ((check-symbol (symbol) - (labels - ((check-function (function &optional exclusions) - (do ((i 4 (1+ i))) - ((>= i (lucid::procedure-length function))) - (let ((element (sys:procedure-ref function i))) - (cond ((eq element function-name) - (pushnew symbol list-of-callers)) - ((and (compiled-function-p element) - (not (find element exclusions))) - (check-function - element - (cons element exclusions)))))))) - (check-function (symbol-function symbol))))) - (do-all-symbols (symbol) - (when (fboundp symbol) - (check-symbol symbol))) - (dolist (caller list-of-callers) - (print caller)) - t))))) - -;;; -(defun ilisp-source-files (symbol package type) - "Print each file for PACKAGE:SYMBOL's TYPE definition on a line and -return T if successful." - (ilisp-errors - (let* ((symbol (ilisp-find-symbol symbol package)) - (all (equal type "any")) - (type (unless all (ilisp-find-symbol type package))) - (paths (when symbol - (lucid::get-source-file symbol type all)))) - (if paths - (progn - (if all - (dolist (file (remove-duplicates paths - :key #'cdr :test #'equal)) - (print (namestring (cdr file)))) - (print (namestring paths))) - t) - nil)))) - -;;; -(dolist (symbol '(ilisp-callers ilisp-source-files)) - (export symbol)) -(unless (compiled-function-p #'ilisp-callers) - (format t "\"ILISP: File is not compiled, use M-x ilisp-compile-inits\""))
--- a/lisp/ilisp/scheme2c.mail Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -From @yonge.cs.toronto.edu:qobi@cs.toronto.edu Tue Nov 1 18:50:53 1994 -From: Jeffrey Mark Siskind <qobi@cs.toronto.edu> -To: ebg@hip.atr.co.jp -Cc: ilisp@naggum.no -In-Reply-To: <9411012332.AA23484@hoshi> (message from Ed Gamble on Tue, 1 Nov 1994 18:32:03 -0500) -Subject: Re: Scheme dialect init-files -Reply-To: Qobi@cs.toronto.edu -Date: Tue, 1 Nov 1994 18:47:37 -0500 - -To get Scheme->C to work under ILisp I had to create my own executable with -the following C foreign function: - -#include <stdio.h> -void nobuff(){setbuf(stdout, (char*)0);} - -(define-c-external (nobuff) void "nobuff") -(nobuff) - -I had to do a similar thing to get SCM to work in an Epsilon process buffer -under DOS. - -This may or may not have to do with your problem. - - Jeff (home page http://www.cdf.toronto.edu/DCS/Personal/Siskind.html) - -
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/indent.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,480 @@ +;;; indent.el --- indentation commands for XEmacs + +;; Copyright (C) 1985, 1992, 1993, 1995, 1997 Free Software Foundation, Inc. + +;; Maintainer: FSF +;; Keywords: lisp, languages, tools, dumped + +;; 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. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;; Commands for making and changing indentation in text. These are +;; described in the XEmacs Reference Manual. + +;; 06/11/1997 - Convert (preceding|following)-char to char-(before|after) -slb + +;;; Code: + +(defvar standard-indent 4 "\ +Default number of columns for margin-changing functions to indent.") + +(defvar indent-line-function 'indent-to-left-margin + "Function to indent current line.") + +(defun indent-according-to-mode () + "Indent line in proper way for current major mode." + (interactive) + (funcall indent-line-function)) + +(defun indent-for-tab-command (&optional prefix-arg) + "Indent line in proper way for current major mode." + (interactive "P") + (if (eq indent-line-function 'indent-to-left-margin) + (insert-tab prefix-arg) + (if prefix-arg + (funcall indent-line-function prefix-arg) + (funcall indent-line-function)))) + +(defun insert-tab (&optional prefix-arg) + (let ((count (prefix-numeric-value prefix-arg))) + (if abbrev-mode + (expand-abbrev)) + (if indent-tabs-mode + (insert-char ?\t count) + ;; XEmacs: (Need the `1+') + (indent-to (* tab-width (1+ (/ (current-column) tab-width))))))) + +(defun indent-rigidly (start end arg) + "Indent all lines starting in the region sideways by ARG columns. +Called from a program, takes three arguments, START, END and ARG." + (interactive "r\np") + (save-excursion + (goto-char end) + (setq end (point-marker)) + (goto-char start) + (or (bolp) (forward-line 1)) + (while (< (point) end) + (let ((indent (current-indentation)) + eol-flag) + (save-excursion + (skip-chars-forward " \t") + (setq eol-flag (eolp))) + (or eol-flag + (indent-to (max 0 (+ indent arg)) 0)) + (delete-region (point) (progn (skip-chars-forward " \t") (point)))) + (forward-line 1)) + (move-marker end nil) + (setq zmacs-region-stays nil))) ; XEmacs + +(defun indent-line-to (column) + "Indent current line to COLUMN. +This function removes or adds spaces and tabs at beginning of line +only if necessary. It leaves point at end of indentation." + (back-to-indentation) + (let ((cur-col (current-column))) + (cond ((< cur-col column) + (if (> (- column (* (/ cur-col tab-width) tab-width)) tab-width) + (delete-region (point) + (progn (skip-chars-backward " ") (point)))) + (indent-to column)) + ((> cur-col column) ; too far right (after tab?) + (delete-region (progn (move-to-column column t) (point)) + (progn (back-to-indentation) (point))))))) + +(defun current-left-margin () + "Return the left margin to use for this line. +This is the value of the buffer-local variable `left-margin' plus the value +of the `left-margin' text-property at the start of the line." + (save-excursion + (back-to-indentation) + (max 0 + (+ left-margin (or (get-text-property + (if (and (eobp) (not (bobp))) + (1- (point)) (point)) + 'left-margin) 0))))) + +(defun move-to-left-margin (&optional n force) + "Move to the left margin of the current line. +With optional argument, move forward N-1 lines first. +The column moved to is the one given by the `current-left-margin' function. +If the line's indentation appears to be wrong, and this command is called +interactively or with optional argument FORCE, it will be fixed." + (interactive (list (prefix-numeric-value current-prefix-arg) t)) + (beginning-of-line n) + (skip-chars-forward " \t") + (let ((lm (current-left-margin)) + (cc (current-column))) + (cond ((> cc lm) + (if (> (move-to-column lm force) lm) + ;; If lm is in a tab and we are not forcing, move before tab + (backward-char 1))) + ((and force (< cc lm)) + (indent-to-left-margin))))) + +;; This is the default indent-line-function, +;; used in Fundamental Mode, Text Mode, etc. +(defun indent-to-left-margin () + "Indent current line to the column given by `current-left-margin'." + (indent-line-to (current-left-margin))) + +(defun delete-to-left-margin (&optional from to) + "Remove left margin indentation from a region. +This deletes to the column given by `current-left-margin'. +In no case will it delete non-whitespace. +Args FROM and TO are optional; default is the whole buffer." + (save-excursion + (goto-char (or to (point-max))) + (setq to (point-marker)) + (goto-char (or from (point-min))) + (or (bolp) (forward-line 1)) + (while (< (point) to) + (delete-region (point) (progn (move-to-left-margin nil t) (point))) + (forward-line 1)) + (move-marker to nil))) + +(defun set-left-margin (from to lm) + "Set the left margin of the region to WIDTH. +If `auto-fill-mode' is active, re-fill the region to fit the new margin." + (interactive "r\nNSet left margin to column: ") + (if (interactive-p) (setq lm (prefix-numeric-value lm))) + (save-excursion + ;; If inside indentation, start from BOL. + (goto-char from) + (skip-chars-backward " \t") + (if (bolp) (setq from (point))) + ;; Place end after whitespace + (goto-char to) + (skip-chars-forward " \t") + (setq to (point-marker))) + ;; Delete margin indentation first, but keep paragraph indentation. + (delete-to-left-margin from to) + (put-text-property from to 'left-margin lm) + (indent-rigidly from to lm) + (if auto-fill-function (save-excursion (fill-region from to nil t t))) + (move-marker to nil)) + +(defun set-right-margin (from to lm) + "Set the right margin of the region to WIDTH. +If `auto-fill-mode' is active, re-fill the region to fit the new margin." + (interactive "r\nNSet right margin to width: ") + (if (interactive-p) (setq lm (prefix-numeric-value lm))) + (save-excursion + (goto-char from) + (skip-chars-backward " \t") + (if (bolp) (setq from (point)))) + (put-text-property from to 'right-margin lm) + (if auto-fill-function (save-excursion (fill-region from to nil t t)))) + +(defun alter-text-property (from to prop func &optional object) + "Programmatically change value of a text-property. +For each region between FROM and TO that has a single value for PROPERTY, +apply FUNCTION to that value and sets the property to the function's result. +Optional fifth argument OBJECT specifies the string or buffer to operate on." + (let ((begin from) + end val) + (while (setq val (get-text-property begin prop object) + end (text-property-not-all begin to prop val object)) + (put-text-property begin end prop (funcall func val) object) + (setq begin end)) + (if (< begin to) + (put-text-property begin to prop (funcall func val) object)))) + +(defun increase-left-margin (from to inc) + "Increase or decrease the left-margin of the region. +With no prefix argument, this adds `standard-indent' of indentation. +A prefix arg (optional third arg INC noninteractively) specifies the amount +to change the margin by, in characters. +If `auto-fill-mode' is active, re-fill the region to fit the new margin." + (interactive "*r\nP") + (setq inc (if inc (prefix-numeric-value inc) standard-indent)) + (save-excursion + (goto-char from) + (skip-chars-backward " \t") + (if (bolp) (setq from (point))) + (goto-char to) + (setq to (point-marker))) + (alter-text-property from (marker-position to) 'left-margin ; XEmacs + (lambda (v) (max (- left-margin) (+ inc (or v 0))))) + (indent-rigidly from (marker-position to) inc) ; XEmacs + (if auto-fill-function + (save-excursion + (fill-region from (marker-position to) nil t t))) ; XEmacs + (move-marker to nil)) + +(defun decrease-left-margin (from to inc) + "Make the left margin of the region smaller. +With no prefix argument, decrease the indentation by `standard-indent'. +A prefix arg (optional third arg INC noninteractively) specifies the amount +to change the margin by, in characters. +If `auto-fill-mode' is active, re-fill the region to fit the new margin." + (interactive "*r\nP") + (setq inc (if inc (prefix-numeric-value inc) standard-indent)) + (increase-left-margin from to (- inc))) + +(defun increase-right-margin (from to inc) + "Increase the right-margin of the region. +With no prefix argument, increase the right margin by `standard-indent'. +A prefix arg (optional third arg INC noninteractively) specifies the amount +to change the margin by, in characters. A negative argument decreases +the right margin width. +If `auto-fill-mode' is active, re-fill the region to fit the new margin." + (interactive "r\nP") + (if (interactive-p) + (setq inc (if inc (prefix-numeric-value current-prefix-arg) + standard-indent))) + (save-excursion + (alter-text-property from to 'right-margin + (lambda (v) (+ inc (or v 0)))) + (if auto-fill-function + (fill-region from to nil t t)))) + +(defun decrease-right-margin (from to inc) + "Make the right margin of the region smaller. +With no prefix argument, decrease the right margin by `standard-indent'. +A prefix arg (optional third arg INC noninteractively) specifies the amount +of width to remove, in characters. A negative argument increases +the right margin width. +If `auto-fill-mode' is active, re-fills region to fit in new margin." + (interactive "*r\nP") + (setq inc (if inc (prefix-numeric-value inc) standard-indent)) + (increase-right-margin from to (- inc))) + +(defun beginning-of-line-text (&optional n) + "Move to the beginning of the text on this line. +With optional argument, move forward N-1 lines first. +From the beginning of the line, moves past the left-margin indentation, the +fill-prefix, and any indentation used for centering or right-justifying the +line, but does not move past any whitespace that was explicitly inserted +\(such as a tab used to indent the first line of a paragraph)." + (interactive "p") + (beginning-of-line n) + (skip-chars-forward " \t") + ;; Skip over fill-prefix. + (if (and fill-prefix + (not (string-equal fill-prefix ""))) + (if (equal fill-prefix + (buffer-substring + (point) (min (point-max) (+ (length fill-prefix) (point))))) + (forward-char (length fill-prefix))) + (if (and adaptive-fill-mode adaptive-fill-regexp + (looking-at adaptive-fill-regexp)) + (goto-char (match-end 0)))) + ;; Skip centering or flushright indentation + (if (memq (current-justification) '(center right)) + (skip-chars-forward " \t"))) + +(defvar indent-region-function nil + "Short cut function to indent region using `indent-according-to-mode'. +A value of nil means really run `indent-according-to-mode' on each line.") + +(defun indent-region (start end column) + "Indent each nonblank line in the region. +With no argument, indent each line using `indent-according-to-mode', +or use `indent-region-function' to do the whole region if that's non-nil. +If there is a fill prefix, make each line start with the fill prefix. +With argument COLUMN, indent each line to that column. +Called from a program, takes three args: START, END and COLUMN." + (interactive "r\nP") + (if (null column) + (if fill-prefix + (save-excursion + (goto-char end) + (setq end (point-marker)) + (goto-char start) + (let ((regexp (regexp-quote fill-prefix))) + (while (< (point) end) + (or (looking-at regexp) + (and (bolp) (eolp)) + (insert fill-prefix)) + (forward-line 1)))) + (if indent-region-function + (funcall indent-region-function start end) + (save-excursion + (goto-char end) + (setq end (point-marker)) + (goto-char start) + (or (bolp) (forward-line 1)) + (while (< (point) end) + (or (and (bolp) (eolp)) + (funcall indent-line-function)) + (forward-line 1)) + (move-marker end nil)))) + (setq column (prefix-numeric-value column)) + (save-excursion + (goto-char end) + (setq end (point-marker)) + (goto-char start) + (or (bolp) (forward-line 1)) + (while (< (point) end) + (delete-region (point) (progn (skip-chars-forward " \t") (point))) + (or (eolp) + (indent-to column 0)) + (forward-line 1)) + (move-marker end nil)))) + +(defun indent-relative-maybe () + "Indent a new line like previous nonblank line." + (interactive) + (indent-relative t)) + +(defun indent-relative (&optional unindented-ok) + "Space out to under next indent point in previous nonblank line. +An indent point is a non-whitespace character following whitespace. +If the previous nonblank line has no indent points beyond the +column point starts at, `tab-to-tab-stop' is done instead." + (interactive "P") + (if abbrev-mode (expand-abbrev)) + (let ((start-column (current-column)) + indent) + (save-excursion + (beginning-of-line) + (if (re-search-backward "^[^\n]" nil t) + (let ((end (save-excursion (forward-line 1) (point)))) + (move-to-column start-column) + ;; Is start-column inside a tab on this line? + (if (> (current-column) start-column) + (backward-char 1)) + (or (looking-at "[ \t]") + unindented-ok + (skip-chars-forward "^ \t" end)) + (skip-chars-forward " \t" end) + (or (= (point) end) (setq indent (current-column)))))) + (if indent + (let ((opoint (point-marker))) + (delete-region (point) (progn (skip-chars-backward " \t") (point))) + (indent-to indent 0) + (if (> opoint (point)) + (goto-char opoint)) + (move-marker opoint nil)) + (tab-to-tab-stop)))) + +(defvar tab-stop-list + '(8 16 24 32 40 48 56 64 72 80 88 96 104 112 120) + "*List of tab stop positions used by `tab-to-tab-stops'. +This should be a list of integers, ordered from smallest to largest.") + +(defvar edit-tab-stops-map nil "Keymap used in `edit-tab-stops'.") +(if edit-tab-stops-map + nil + (setq edit-tab-stops-map (make-sparse-keymap)) + (define-key edit-tab-stops-map "\C-x\C-s" 'edit-tab-stops-note-changes) + (define-key edit-tab-stops-map "\C-c\C-c" 'edit-tab-stops-note-changes)) + +(defvar edit-tab-stops-buffer nil + "Buffer whose tab stops are being edited--in case +the variable `tab-stop-list' is local in that buffer.") + +(defun edit-tab-stops () + "Edit the tab stops used by `tab-to-tab-stop'. +Creates a buffer *Tab Stops* containing text describing the tab stops. +A colon indicates a column where there is a tab stop. +You can add or remove colons and then do \\<edit-tab-stops-map>\\[edit-tab-stops-note-changes] to make changes take effect." + (interactive) + (setq edit-tab-stops-buffer (current-buffer)) + (switch-to-buffer (get-buffer-create "*Tab Stops*")) + ;; #### I18N3 should mark buffer as output-translating + (use-local-map edit-tab-stops-map) + (make-local-variable 'indent-tabs-mode) + (setq indent-tabs-mode nil) + (overwrite-mode 1) + (setq truncate-lines t) + (erase-buffer) + (let ((tabs tab-stop-list)) + (while tabs + (indent-to (car tabs) 0) + (insert ?:) + (setq tabs (cdr tabs)))) + (let ((count 0)) + (insert ?\n) + (while (< count 8) + (insert (+ count ?0)) + (insert " ") + (setq count (1+ count))) + (insert ?\n) + (while (> count 0) + (insert "0123456789") + (setq count (1- count)))) + ;; XEmacs + (insert (substitute-command-keys "\nTo install changes, type \\<edit-tab-stops-map>\\[edit-tab-stops-note-changes]")) + (goto-char (point-min))) + +(defun edit-tab-stops-note-changes () + "Put edited tab stops into effect." + (interactive) + (let (tabs) + (save-excursion + (goto-char 1) + (end-of-line) + (while (search-backward ":" nil t) + (setq tabs (cons (current-column) tabs)))) + (bury-buffer (prog1 (current-buffer) + (switch-to-buffer edit-tab-stops-buffer))) + (setq tab-stop-list tabs)) + (message "Tab stops installed")) + +(defun tab-to-tab-stop () + "Insert spaces or tabs to next defined tab-stop column. +The variable `tab-stop-list' is a list of columns at which there are tab stops. +Use \\[edit-tab-stops] to edit them interactively." + (interactive) + (and abbrev-mode (eq (char-syntax (char-before (point))) ?w) + (expand-abbrev)) + (let ((tabs tab-stop-list)) + (while (and tabs (>= (current-column) (car tabs))) + (setq tabs (cdr tabs))) + (if tabs + (let ((opoint (point))) + (skip-chars-backward " \t") + (delete-region (point) opoint) + (indent-to (car tabs))) + (insert ?\ )))) + +(defun move-to-tab-stop () + "Move point to next defined tab-stop column. +The variable `tab-stop-list' is a list of columns at which there are tab stops. +Use \\[edit-tab-stops] to edit them interactively." + (interactive) + (let ((tabs tab-stop-list)) + (while (and tabs (>= (current-column) (car tabs))) + (setq tabs (cdr tabs))) + (if tabs + (let ((before (point))) + (move-to-column (car tabs) t) + (save-excursion + (goto-char before) + ;; If we just added a tab, or moved over one, + ;; delete any superfluous spaces before the old point. + (if (and (eq (char-before (point)) ?\ ) + (eq (char-after (point)) ?\t)) + (let ((tabend (* (/ (current-column) tab-width) tab-width))) + (while (and (> (current-column) tabend) + (eq (char-before (point)) ?\ )) + (forward-char -1)) + (delete-region (point) before)))))))) + +;(define-key global-map "\t" 'indent-for-tab-command) +;(define-key esc-map "\034" 'indent-region) +;(define-key ctl-x-map "\t" 'indent-rigidly) +;(define-key esc-map "i" 'tab-to-tab-stop) + +;;; indent.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/isearch-mode.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,1619 @@ +;;; isearch-mode.el --- Incremental search minor mode. + +;; Copyright (C) 1992, 1993, 1997 Free Software Foundation, Inc. + +;; Author: Daniel LaLiberte <liberte@cs.uiuc.edu> +;; Maintainer: XEmacs Development Team +;; Keywords: extensions, dumped + +;; 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, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: Not synched with FSF. + +;;; Commentary: + +;; LCD Archive Entry: +;; isearch-mode|Daniel LaLiberte|liberte@cs.uiuc.edu +;; |A minor mode replacement for isearch.el. + +;;==================================================================== +;; Instructions + +;; Searching with isearch-mode.el should work just like isearch.el, +;; except it is done in a temporary minor mode that terminates when +;; you finish searching. + +;; Semi-modal searching is supported, using a recursive edit. If +;; isearching is started non-interactively by calling one of the +;; isearch commands (e.g. (isearch-forward), but not like gnus does +;; it: (call-interactively 'isearch-forward)), isearch-mode does not +;; return until the search is completed. You should still be able +;; switch buffers, so be careful not to get things confused. + +;; The key bindings active within isearch-mode are defined below in +;; `isearch-mode-map' which is given bindings close to the default +;; characters of isearch.el for version 19. With `isearch-mode', +;; however, you can bind multi-character keys and it should be easier +;; to add new commands. One bug though: keys with meta-prefix cannot +;; be longer than two chars. Also see minibuffer-local-isearch-map +;; for bindings active during `isearch-edit-string'. + +;; The search ring and completion commands automatically put you in +;; the minibuffer to edit the string. This gives you a chance to +;; modify the search string before executing the search. There are +;; three commands to terminate the editing: C-s and C-r exit the +;; minibuffer and search forward and reverse respectively, while C-m +;; exits and does a nonincremental search. + +;; Exiting immediately from isearch uses isearch-edit-string instead +;; of nonincremental-search, if search-nonincremental-instead is non-nil. +;; The name of this option should probably be changed if we decide to +;; keep the behavior. One difference is that isearch-edit-string does +;; not support word search yet; perhaps isearch-mode should support it +;; even for incremental searches, but how? + +;;==================================================================== +;;; Change History: + +;; Header: /import/kaplan/kaplan/liberte/Isearch/RCS/isearch-mode.el,v 1.3 92/06/29 13:10:08 liberte Exp Locker: liberte +;; Log: isearch-mode.el,v +;; +;; 20-aug-92 Hacked by jwz for Lucid Emacs 19.3. +;; +;; Revision 1.3 92/06/29 13:10:08 liberte +;; Moved modal isearch-mode handling into isearch-mode. +;; Got rid of buffer-local isearch variables. +;; isearch-edit-string used by ring adjustments, completion, and +;; nonincremental searching. C-s and C-r are additional exit commands. +;; Renamed all regex to regexp. +;; Got rid of found-start and found-point globals. +;; Generalized handling of upper-case chars. + +;; Revision 1.2 92/05/27 11:33:57 liberte +;; Emacs version 19 has a search ring, which is supported here. +;; Other fixes found in the version 19 isearch are included here. +;; +;; Also see variables search-caps-disable-folding, +;; search-nonincremental-instead, search-whitespace-regexp, and +;; commands isearch-toggle-regexp, isearch-edit-string. +;; +;; semi-modal isearching is supported. + +;; Changes for 1.1 +;; 3/18/92 Fixed invalid-regexp. +;; 3/18/92 Fixed yanking in regexps. + +;;; Code: + +(defgroup isearch nil + "Incremental search" + :prefix "search-" + :group 'matching) + + +(defun isearch-char-to-string (c) + (if (eventp c) + (make-string 1 (event-to-character c nil nil t)) + (make-string 1 c))) + +;(defun isearch-text-char-description (c) +; (isearch-char-to-string c)) + +(define-function 'isearch-text-char-description 'text-char-description) + + +;;;========================================================================= +;;; User-accessible variables + +(defvar search-last-string "" + "Last string search for by a search command. +This does not include direct calls to the primitive search functions, +and does not include searches that are aborted.") + +(defvar search-last-regexp "" + "Last string searched for by a regexp search command. +This does not include direct calls to the primitive search functions, +and does not include searches that are aborted.") + +(defconst search-exit-option t + "Non-nil means random control characters terminate incremental search.") + +(defcustom search-slow-window-lines 1 + "*Number of lines in slow search display windows. +These are the short windows used during incremental search on slow terminals. +Negative means put the slow search window at the top (normally it's at bottom) +and the value is minus the number of lines." + :type 'integer + :group 'isearch) + +(defcustom search-slow-speed 1200 + "*Highest terminal speed at which to use \"slow\" style incremental search. +This is the style where a one-line window is created to show the line +that the search has reached." + :type 'integer + :group 'isearch) + +(defcustom search-caps-disable-folding t + "*If non-nil, upper case chars disable case fold searching. +This does not apply to \"yanked\" strings." + :type 'boolean + :group 'isearch) + +(defcustom search-nonincremental-instead t + "*If non-nil, do a nonincremental search instead if exiting immediately." + :type 'boolean + :group 'isearch) + +(defcustom search-whitespace-regexp "\\(\\s \\|[\n\r]\\)+" + "*If non-nil, regular expression to match a sequence of whitespace chars." + :type 'regexp + :group 'isearch) + +;;;================================================================== +;;; Search ring. + +(defvar search-ring nil + "List of search string sequences.") +(defvar regexp-search-ring nil + "List of regular expression search string sequences.") + +(defcustom search-ring-max 16 + "*Maximum length of search ring before oldest elements are thrown away." + :type 'integer + :group 'isearch) +(defcustom regexp-search-ring-max 16 + "*Maximum length of regexp search ring before oldest elements are thrown away." + :type 'integer + :group 'isearch) + +(defvar search-ring-yank-pointer nil + "The tail of the search ring whose car is the last thing searched for.") +(defvar regexp-search-ring-yank-pointer nil + "The tail of the regular expression search ring whose car is the last +thing searched for.") + +;;;==================================================== +;;; Define isearch-mode keymap. + +(defvar isearch-mode-map + (let ((map (make-keymap))) + (set-keymap-name map 'isearch-mode-map) + + ;; Bind all printing characters to `isearch-printing-char'. + ;; This isn't normally necessary, but if a printing character were + ;; bound to something other than self-insert-command in global-map, + ;; then it would terminate the search and be executed without this. + (let ((i 32) + (str (make-string 1 0))) + (while (< i 127) + (aset str 0 i) + (define-key map str 'isearch-printing-char) + (setq i (1+ i)))) + (define-key map "\t" 'isearch-printing-char) + + ;; Several non-printing chars change the searching behavior. + ;; + (define-key map "\C-s" 'isearch-repeat-forward) + (define-key map "\M-\C-s" 'isearch-repeat-forward) + (define-key map "\C-r" 'isearch-repeat-backward) + (define-key map "\C-g" 'isearch-abort) + + (define-key map "\C-q" 'isearch-quote-char) + + (define-key map "\C-m" 'isearch-exit) + (define-key map "\C-j" 'isearch-printing-char) + (define-key map "\t" 'isearch-printing-char) + + (define-key map "\C-w" 'isearch-yank-word) + (define-key map "\C-y" 'isearch-yank-line) + (define-key map "\M-y" 'isearch-yank-kill) + + ;; Define keys for regexp chars * ? | + (define-key map "*" 'isearch-*-char) + (define-key map "?" 'isearch-*-char) + (define-key map "|" 'isearch-|-char) + + ;; Some bindings you may want to put in your isearch-mode-hook. + ;; Suggest some alternates... + ;; (define-key map "\C-t" 'isearch-toggle-regexp) + ;; (define-key map "\C-^" 'isearch-edit-string) + + ;; delete and backspace delete backward, f1 is help, and C-h can be either + (define-key map 'delete 'isearch-delete-char) + (define-key map 'backspace 'isearch-delete-char) + (define-key map '(control h) 'isearch-help-or-delete-char) + (define-key map 'f1 'isearch-mode-help) + (define-key map 'help 'isearch-mode-help) + + (define-key map "\M-n" 'isearch-ring-advance) + (define-key map "\M-p" 'isearch-ring-retreat) + (define-key map "\M- " 'isearch-whitespace-chars) + (define-key map "\M-\t" 'isearch-complete) + + (define-key map 'button2 'isearch-yank-x-selection) + + map) + "Keymap for isearch-mode.") + +(defvar minibuffer-local-isearch-map + (let ((map (make-sparse-keymap))) + ;; #### - this should also be minor-mode-ified + (set-keymap-parents map (list minibuffer-local-map)) + (set-keymap-name map 'minibuffer-local-isearch-map) + + ;;#### This should just arrange to use the usual Emacs minibuffer histories + (define-key map "\r" 'isearch-nonincremental-exit-minibuffer) + (define-key map "\M-n" 'isearch-ring-advance-edit) + (define-key map "\M-p" 'isearch-ring-retreat-edit) + (define-key map "\M-\t" 'isearch-complete-edit) + (define-key map "\C-s" 'isearch-forward-exit-minibuffer) + (define-key map "\C-r" 'isearch-reverse-exit-minibuffer) + map) + "Keymap for editing isearch strings in the minibuffer.") + +;;;======================================================== +;; Internal variables declared globally for byte-compiler. +;; These are all bound locally while editing the search string. + +(defvar isearch-forward nil) ; Searching in the forward direction. +(defvar isearch-regexp nil) ; Searching for a regexp. +(defvar isearch-word nil) ; Searching for words. + +(defvar isearch-cmds nil) ; Stack of search status sets. +(defvar isearch-string "") ; The current search string. +(defvar isearch-message "") ; text-char-description version of isearch-string + +(defvar isearch-success t) ; Searching is currently successful. +(defvar isearch-invalid-regexp nil) ; Regexp not well formed. +(defvar isearch-other-end nil) ; Start (end) of match if forward (backward). +(defvar isearch-wrapped nil) ; Searching restarted from the top (bottom). +(defvar isearch-barrier 0) +(defvar isearch-buffer nil) ; the buffer we've frobbed the keymap of + +(defvar isearch-case-fold-search nil) + +(defvar isearch-adjusted nil) +(defvar isearch-slow-terminal-mode nil) +;;; If t, using a small window. +(defvar isearch-small-window nil) +(defvar isearch-opoint 0) +;;; The window configuration active at the beginning of the search. +(defvar isearch-window-configuration nil) +(defvar isearch-selected-frame nil) + +;; Flag to indicate a yank occurred, so don't move the cursor. +(defvar isearch-yank-flag nil) + +;;; A function to be called after each input character is processed. +;;; (It is not called after characters that exit the search.) +;;; It is only set from an optional argument to `isearch-mode'. +(defvar isearch-op-fun nil) + +;;; Is isearch-mode in a recursive edit for modal searching. +(defvar isearch-recursive-edit nil) + +;;; Should isearch be terminated after doing one search? +(defvar isearch-nonincremental nil) + +;; New value of isearch-forward after isearch-edit-string. +(defvar isearch-new-forward nil) + + +(defvar isearch-mode-hook nil + "Function(s) to call after starting up an incremental search.") + +(defvar isearch-mode-end-hook nil + "Function(s) to call after terminating an incremental search.") + +;;;============================================================== +;; Minor-mode-alist changes - kind of redundant with the +;; echo area, but if isearching in multiple windows, it can be useful. + +(add-minor-mode 'isearch-mode 'isearch-mode) + +(defvar isearch-mode nil) +(make-variable-buffer-local 'isearch-mode) + +;;;=============================================================== +;;; Entry points to isearch-mode. +;;; These four functions should replace those in loaddefs.el +;;; An alternative is to fset isearch-forward etc to isearch-mode, +;;; and look at the last command to set the options accordingly. + +(defun isearch-forward (&optional regexp-p) + "Do incremental search forward. +With a prefix argument, do an incremental regular expression search instead. +\\<isearch-mode-map> +As you type characters, they add to the search string and are found. +The following non-printing keys are bound in `isearch-mode-map'. + +Type \\[isearch-delete-char] to cancel characters from end of search string. +Type \\[isearch-exit] to exit, leaving point at location found. +Type LFD (C-j) to match end of line. +Type \\[isearch-repeat-forward] to search again forward,\ + \\[isearch-repeat-backward] to search again backward. +Type \\[isearch-yank-word] to yank word from buffer onto end of search\ + string and search for it. +Type \\[isearch-yank-line] to yank rest of line onto end of search string\ + and search for it. +Type \\[isearch-quote-char] to quote control character to search for it. +Type \\[isearch-whitespace-chars] to match all whitespace chars in regexp. +\\[isearch-abort] while searching or when search has failed cancels input\ + back to what has + been found successfully. +\\[isearch-abort] when search is successful aborts and moves point to\ + starting point. + +Also supported is a search ring of the previous 16 search strings. +Type \\[isearch-ring-advance] to search for the next item in the search ring. +Type \\[isearch-ring-retreat] to search for the previous item in the search\ + ring. +Type \\[isearch-complete] to complete the search string using the search ring. + +The above keys are bound in the isearch-mode-map. To change the keys which + are special to isearch-mode, simply change the bindings in that map. + +Other control and meta characters terminate the search + and are then executed normally (depending on `search-exit-option'). + +If this function is called non-interactively, it does not return to +the calling function until the search is done. + +The bindings, more precisely: +\\{isearch-mode-map}" + +;; Non-standard bindings +;; Type \\[isearch-toggle-regexp] to toggle regular expression with normal searching. +;; Type \\[isearch-edit-string] to edit the search string in the minibuffer. +;; Terminate editing and return to incremental searching with CR. + + (interactive "_P") + (isearch-mode t (not (null regexp-p)) nil (not (interactive-p)))) + +(defun isearch-forward-regexp () + "\ +Do incremental search forward for regular expression. +Like ordinary incremental search except that your input +is treated as a regexp. See \\[isearch-forward] for more info." + (interactive "_") + (isearch-mode t t nil (not (interactive-p)))) + +(defun isearch-backward (&optional regexp-p) + "\ +Do incremental search backward. +With a prefix argument, do an incremental regular expression search instead. +See \\[isearch-forward] for more information." + (interactive "_P") + (isearch-mode nil (not (null regexp-p)) nil (not (interactive-p)))) + +(defun isearch-backward-regexp () + "\ +Do incremental search backward for regular expression. +Like ordinary incremental search except that your input +is treated as a regexp. See \\[isearch-forward] for more info." + (interactive "_") + (isearch-mode nil t nil (not (interactive-p)))) + +;; This function is way wrong, because you can't scroll the help +;; screen; as soon as you press a key, it's gone. I don't know of a +;; good way to fix it, though. -hniksic +(defun isearch-mode-help () + (interactive "_") + (let ((w (selected-window))) + (describe-function 'isearch-forward) + (select-window w)) + (isearch-update)) + + +;;;================================================================== +;; isearch-mode only sets up incremental search for the minor mode. +;; All the work is done by the isearch-mode commands. + +(defun isearch-mode (forward &optional regexp op-fun recursive-edit word-p) + "Start isearch minor mode. Called by isearch-forward, etc." + + (if executing-kbd-macro (setq recursive-edit nil)) + + (let ((inhibit-quit t)) ; don't leave things in an inconsistent state... + + ;; Initialize global vars. + (setq isearch-buffer (current-buffer) + isearch-forward forward + isearch-regexp regexp + isearch-word word-p + isearch-op-fun op-fun + isearch-case-fold-search case-fold-search + isearch-string "" + isearch-message "" + isearch-cmds nil + isearch-success t + isearch-wrapped nil + isearch-barrier (point) + isearch-adjusted nil + isearch-yank-flag nil + isearch-invalid-regexp nil + isearch-slow-terminal-mode (and (<= (device-baud-rate) + search-slow-speed) + (> (window-height) + (* 4 search-slow-window-lines))) + isearch-other-end nil + isearch-small-window nil + + isearch-opoint (point) + isearch-window-configuration (current-window-configuration) + + ;; #### - don't do this statically: isearch-mode must be FIRST in + ;; the minor-mode-map-alist -- Stig + minor-mode-map-alist (cons (cons 'isearch-mode isearch-mode-map) + minor-mode-map-alist) + isearch-selected-frame (selected-frame) + + isearch-mode (gettext " Isearch") + ) + + ;; XEmacs change: without clearing the match data, sometimes old values + ;; of isearch-other-end get used. Don't ask me why... + (store-match-data nil) + + (add-hook 'pre-command-hook 'isearch-pre-command-hook) + (set-buffer-modified-p (buffer-modified-p)) ; update modeline + (isearch-push-state) + + ) ; inhibit-quit is t before here + + (isearch-update) + (run-hooks 'isearch-mode-hook) + + ;; isearch-mode can be made modal (in the sense of not returning to + ;; the calling function until searching is completed) by entering + ;; a recursive-edit and exiting it when done isearching. + (if recursive-edit + (let ((isearch-recursive-edit t)) + (recursive-edit))) + ) + + +;;;==================================================== +;; Some high level utilities. Others below. + +(defun isearch-update () + ;; Called after each command to update the display. + (if (null unread-command-event) + (progn + (if (not (input-pending-p)) + (isearch-message)) + (if (and isearch-slow-terminal-mode + (not (or isearch-small-window + (pos-visible-in-window-p)))) + (let ((found-point (point))) + (setq isearch-small-window t) + (move-to-window-line 0) + (let ((window-min-height 1)) + (split-window nil (if (< search-slow-window-lines 0) + (1+ (- search-slow-window-lines)) + (- (window-height) + (1+ search-slow-window-lines))))) + (if (< search-slow-window-lines 0) + (progn (vertical-motion (- 1 search-slow-window-lines)) + (set-window-start (next-window) (point)) + (set-window-hscroll (next-window) + (window-hscroll)) + (set-window-hscroll (selected-window) 0)) + (other-window 1)) + (goto-char found-point))) + (if isearch-other-end + (if (< isearch-other-end (point)) + (isearch-highlight isearch-other-end (point)) + (isearch-highlight (point) isearch-other-end)) + (if (extentp isearch-extent) + (isearch-dehighlight nil))) + )) + (setq ;; quit-flag nil not for isearch-mode + isearch-adjusted nil + isearch-yank-flag nil) + ) + + +(defun isearch-done () + ;; Called by all commands that terminate isearch-mode. + (let ((inhibit-quit t)) ; danger danger! + (if (and isearch-buffer (buffer-live-p isearch-buffer)) + (save-excursion + ;; Some loser process filter might have switched the + ;; window's buffer, so be sure to set these variables back + ;; in the buffer we frobbed them in. But only if the buffer + ;; is still alive. + (set-buffer isearch-buffer) + (setq minor-mode-map-alist (delq (assoc 'isearch-mode minor-mode-map-alist) + minor-mode-map-alist)) + ;; Use remove-hook instead of just setting it to our saved value + ;; in case some process filter has created a buffer and modified + ;; the pre-command-hook in that buffer... yeah, this is obscure, + ;; and yeah, I was getting screwed by it. -jwz + (remove-hook 'pre-command-hook 'isearch-pre-command-hook) + (set-keymap-parents isearch-mode-map nil) + (setq isearch-mode nil) + (set-buffer-modified-p (buffer-modified-p));; update modeline + (isearch-dehighlight t))) + + ;; it's not critical that this be inside inhibit-quit, but leaving + ;; things in small-window-mode would be bad. + (let ((found-start (window-start (selected-window))) + (found-point (point))) + (cond ((eq (selected-frame) isearch-selected-frame) + (set-window-configuration isearch-window-configuration) + + (if isearch-small-window + (goto-char found-point) + ;; Exiting the save-window-excursion clobbers + ;; window-start; restore it. + (set-window-start (selected-window) found-start t)))) + ;; If there was movement, mark the starting position. + ;; Maybe should test difference between and set mark iff > threshold. + (if (and (buffer-live-p isearch-buffer) + (/= (point isearch-buffer) isearch-opoint)) + (progn + (push-mark isearch-opoint t nil isearch-buffer) + (or executing-kbd-macro (> (minibuffer-depth) 0) + (display-message 'command "Mark saved where search started")))) + ) + (setq isearch-buffer nil) + ) ; inhibit-quit is t before here + + (if (> (length isearch-string) 0) + ;; Update the ring data. + (if isearch-regexp + (if (not (setq regexp-search-ring-yank-pointer + (member isearch-string regexp-search-ring))) + (progn + (setq regexp-search-ring + (cons isearch-string regexp-search-ring) + regexp-search-ring-yank-pointer regexp-search-ring) + (if (> (length regexp-search-ring) regexp-search-ring-max) + (setcdr (nthcdr (1- search-ring-max) regexp-search-ring) + nil)))) + (if (not (setq search-ring-yank-pointer + ;; really need equal test instead of eq. + (member isearch-string search-ring))) + (progn + (setq search-ring (cons isearch-string search-ring) + search-ring-yank-pointer search-ring) + (if (> (length search-ring) search-ring-max) + (setcdr (nthcdr (1- search-ring-max) search-ring) nil)))))) + + (run-hooks 'isearch-mode-end-hook) + (if isearch-recursive-edit (exit-recursive-edit))) + + +;;;==================================================== +;; Commands active while inside of the isearch minor mode. + +(defun isearch-exit () + "Exit search normally. +However, if this is the first command after starting incremental +search and `search-nonincremental-instead' is non-nil, do an +incremental search via `isearch-edit-string'." + (interactive) + (if (and search-nonincremental-instead + (= 0 (length isearch-string))) + (let ((isearch-nonincremental t)) + (isearch-edit-string)) + (isearch-done))) + + +(defun isearch-edit-string () + "Edit the search string in the minibuffer. +The following additional command keys are active while editing. +\\<minibuffer-local-isearch-map> +\\[exit-minibuffer] to exit editing and resume incremental searching. +\\[isearch-forward-exit-minibuffer] to resume isearching forward. +\\[isearch-backward-exit-minibuffer] to resume isearching backward. +\\[isearch-ring-advance-edit] to replace the search string with the next\ + item in the search ring. +\\[isearch-ring-retreat-edit] to replace the search string with the next\ + item in the search ring. +\\[isearch-complete-edit] to complete the search string from the search ring." + + ;; Editing doesn't back up the search point. Should it? + (interactive) + + (condition-case nil + (let ((minibuffer-local-map minibuffer-local-isearch-map) + isearch-nonincremental ; should search nonincrementally? + isearch-new-string + isearch-new-message + (isearch-new-forward isearch-forward) + + ;; Locally bind all isearch global variables to protect them + ;; from recursive isearching. + (isearch-string isearch-string) + (isearch-message isearch-message) + (isearch-forward isearch-forward) ; set by commands below. + + (isearch-forward isearch-forward) + (isearch-regexp isearch-regexp) + (isearch-word isearch-word) + (isearch-op-fun isearch-op-fun) + (isearch-cmds isearch-cmds) + (isearch-success isearch-success) + (isearch-wrapped isearch-wrapped) + (isearch-barrier isearch-barrier) + (isearch-adjusted isearch-adjusted) + (isearch-yank-flag isearch-yank-flag) + (isearch-invalid-regexp isearch-invalid-regexp) + (isearch-other-end isearch-other-end) + (isearch-opoint isearch-opoint) + (isearch-slow-terminal-mode isearch-slow-terminal-mode) + (isearch-small-window isearch-small-window) + (isearch-recursive-edit isearch-recursive-edit) + (isearch-window-configuration (current-window-configuration)) + (isearch-selected-frame (selected-frame)) + ) + ;; Actually terminate isearching until editing is done. + ;; This is so that the user can do anything without failure, + ;; like switch buffers and start another isearch, and return. +;; (condition-case nil + (isearch-done) + ;;#### What does this mean? There is no such condition! +;; (exit nil)) ; was recursive editing + + (unwind-protect + (let ((prompt (isearch-message-prefix nil t)) + event) + ;; If the first character the user types when we prompt them + ;; for a string is the yank-word character, then go into + ;; word-search mode. Otherwise unread that character and + ;; read a string the normal way. + (let ((cursor-in-echo-area t)) + (display-message 'prompt prompt) + (setq event (next-command-event)) + (if (eq 'isearch-yank-word + (lookup-key isearch-mode-map (vector event))) + (setq isearch-word t) + (setq unread-command-event event))) + (setq isearch-new-string +;; (if (fboundp 'gmhist-old-read-from-minibuffer) +;; ;; Eschew gmhist crockery +;; (gmhist-old-read-from-minibuffer prompt isearch-string) + (read-string + prompt isearch-string + 't ;does its own history (but shouldn't) +;; (if isearch-regexp +;; ;; The search-rings aren't exactly minibuffer +;; ;; histories, but they are close enough +;; (cons 'regexp-search-ring +;; (- (length regexp-search-ring-yank-pointer) +;; (length regexp-search-ring))) +;; (cons 'search-ring +;; (- (length search-ring-yank-pointer) +;; (length search-ring)))) + ) +;; ) + isearch-new-message (mapconcat + 'isearch-text-char-description + isearch-new-string "")) + ) + ;; Always resume isearching by restarting it. + (isearch-mode isearch-forward + isearch-regexp + isearch-op-fun + isearch-recursive-edit + isearch-word) + ) + + ;; Copy new values in outer locals to isearch globals + (setq isearch-string isearch-new-string + isearch-message isearch-new-message + isearch-forward isearch-new-forward) + + ;; Empty isearch-string means use default. + (if (= 0 (length isearch-string)) + (setq isearch-string (if isearch-regexp search-last-regexp + search-last-string)) + ;; Set last search string now so it is set even if we fail. + (if search-last-regexp + (setq search-last-regexp isearch-string) + (setq search-last-string isearch-string))) + + ;; Reinvoke the pending search. + (isearch-push-state) + (isearch-search) + (isearch-update) + (if isearch-nonincremental (isearch-done))) + + (quit ; handle abort-recursive-edit + (isearch-abort) ;; outside of let to restore outside global values + ))) + +(defun isearch-nonincremental-exit-minibuffer () + (interactive) + (setq isearch-nonincremental t) + (exit-minibuffer)) + +(defun isearch-forward-exit-minibuffer () + (interactive) + (setq isearch-new-forward t) + (exit-minibuffer)) + +(defun isearch-reverse-exit-minibuffer () + (interactive) + (setq isearch-new-forward nil) + (exit-minibuffer)) + + +(defun isearch-abort () + "Quit incremental search mode if searching is successful, signalling quit. +Otherwise, revert to previous successful search and continue searching. +Use `isearch-exit' to quit without signalling." + (interactive) +;; (ding) signal instead below, if quiting + (discard-input) + (if isearch-success + ;; If search is successful, move back to starting point + ;; and really do quit. + (progn (goto-char isearch-opoint) + (isearch-done) ; exit isearch + (signal 'quit '(isearch))) ; and pass on quit signal + ;; If search is failing, rub out until it is once more successful. + (while (not isearch-success) (isearch-pop-state)) + (isearch-update))) + + +(defun isearch-repeat (direction) + ;; Utility for isearch-repeat-forward and -backward. + (if (eq isearch-forward (eq direction 'forward)) + ;; C-s in forward or C-r in reverse. + (if (equal isearch-string "") + ;; If search string is empty, use last one. + (setq isearch-string + (or (if isearch-regexp + (if regexp-search-ring-yank-pointer + (car regexp-search-ring-yank-pointer) + (car regexp-search-ring)) + (if search-ring-yank-pointer + (car search-ring-yank-pointer) + (car search-ring))) + "") + isearch-message + (mapconcat 'isearch-text-char-description + isearch-string "")) + ;; If already have what to search for, repeat it. + (or isearch-success + (progn + + (goto-char (if isearch-forward (point-min) (point-max))) + (setq isearch-wrapped t)))) + ;; C-s in reverse or C-r in forward, change direction. + (setq isearch-forward (not isearch-forward))) + + (setq isearch-barrier (point)) ; For subsequent \| if regexp. + (setq isearch-success t) + (or (equal isearch-string "") + ;; If repeating a search that found + ;; an empty string, ensure we advance. + (if (equal (match-end 0) (match-beginning 0)) + (if (if isearch-forward (eobp) (bobp)) + ;; nowhere to advance to, so fail (and wrap next time) + (progn + (setq isearch-success nil) + (and executing-kbd-macro + (not defining-kbd-macro) + (isearch-done)) + (ding nil 'isearch-failed)) + (forward-char (if isearch-forward 1 -1)) + (isearch-search)) + (isearch-search))) + (isearch-push-state) + (isearch-update)) + +(defun isearch-repeat-forward () + "Repeat incremental search forwards." + (interactive) + (isearch-repeat 'forward)) + +(defun isearch-repeat-backward () + "Repeat incremental search backwards." + (interactive) + (isearch-repeat 'backward)) + +(defun isearch-toggle-regexp () + "Toggle regexp searching on or off." + ;; The status stack is left unchanged. + (interactive) + (setq isearch-regexp (not isearch-regexp)) + (if isearch-regexp (setq isearch-word nil)) + (isearch-update)) + +(defun isearch-toggle-case-fold () + "Toggle case folding in searching on or off." + (interactive) + (setq isearch-case-fold-search + (if isearch-case-fold-search nil 'yes)) + (message "%s%s [case %ssensitive]" + (isearch-message-prefix) + isearch-message + (if isearch-case-fold-search "in" "")) + (setq isearch-adjusted t) + (sit-for 1) + (isearch-update)) + +(defun isearch-delete-char () + "Discard last input item and move point back. +If no previous match was done, just beep." + (interactive) + (if (null (cdr isearch-cmds)) + (ding nil 'isearch-quit) + (isearch-pop-state)) + (isearch-update)) + +(defun isearch-help-or-delete-char () + "Show Isearch help or delete backward in the search string. +Deletes when `delete-key-deletes-forward' is t and C-h is used for deleting +backwards." + (interactive) + (if (and delete-key-deletes-forward + (case (device-type) + ('tty (eq tty-erase-char ?\C-h)) + ('x (not (x-keysym-on-keyboard-p "BackSpace"))))) + (isearch-delete-char) + (isearch-mode-help))) + +(defun isearch-yank (chunk) + ;; Helper for isearch-yank-* functions. CHUNK can be a string or a + ;; function. + (let ((word (if (stringp chunk) + chunk + (save-excursion + (and (not isearch-forward) isearch-other-end + (goto-char isearch-other-end)) + (buffer-substring + (point) + (save-excursion + (funcall chunk) + (point))))))) + ;; if configured so that typing upper-case characters turns off case + ;; folding, then downcase the string so that yanking an upper-case + ;; word doesn't mess with case-foldedness. + (if (and search-caps-disable-folding isearch-case-fold-search) + (setq word (downcase word))) + (if isearch-regexp (setq word (regexp-quote word))) + (setq isearch-string (concat isearch-string word) + isearch-message + (concat isearch-message + (mapconcat 'isearch-text-char-description + word "")) + ;; Don't move cursor in reverse search. + isearch-yank-flag t)) + (isearch-search-and-update)) + + +(defun isearch-yank-word () + "Pull next word from buffer into search string." + (interactive) + (isearch-yank (function (lambda () (forward-word 1))))) + +(defun isearch-yank-line () + "Pull rest of line from buffer into search string." + (interactive) + (isearch-yank 'end-of-line)) + +(defun isearch-yank-kill () + "Pull rest of line from kill ring into search string." + (interactive) + (isearch-yank (current-kill 0))) + +(defun isearch-yank-sexp () + "Pull next expression from buffer into search string." + (interactive) + (isearch-yank 'forward-sexp)) + +(defun isearch-yank-x-selection () + "Pull the current X selection into the search string." + (interactive) + (isearch-yank (x-get-selection))) + +(defun isearch-yank-x-clipboard () + "Pull the current X clipboard selection into the search string." + (interactive) + (isearch-yank (x-get-clipboard))) + +(defun isearch-search-and-update () + ;; Do the search and update the display. + (if (and (not isearch-success) + ;; unsuccessful regexp search may become + ;; successful by addition of characters which + ;; make isearch-string valid + (not isearch-regexp)) + nil + ;; In reverse search, adding stuff at + ;; the end may cause zero or many more chars to be + ;; matched, in the string following point. + ;; Allow all those possibilities without moving point as + ;; long as the match does not extend past search origin. + (if (and (not isearch-forward) (not isearch-adjusted) + (condition-case () + (looking-at (if isearch-regexp isearch-string + (regexp-quote isearch-string))) + (error nil)) + (or isearch-yank-flag + (<= (match-end 0) + (min isearch-opoint isearch-barrier)))) + (setq isearch-success t + isearch-invalid-regexp nil + isearch-other-end (match-end 0)) + ;; Not regexp, not reverse, or no match at point. + (if (and isearch-other-end (not isearch-adjusted)) + (goto-char (if isearch-forward isearch-other-end + (min isearch-opoint + isearch-barrier + (1+ isearch-other-end))))) + (isearch-search) + )) + (isearch-push-state) + (if isearch-op-fun (funcall isearch-op-fun)) + (isearch-update)) + + +;; *, ?, and | chars can make a regexp more liberal. +;; They can make a regexp match sooner +;; or make it succeed instead of failing. +;; So go back to place last successful search started +;; or to the last ^S/^R (barrier), whichever is nearer. + +(defun isearch-*-char () + "Handle * and ? specially in regexps." + (interactive) + (if isearch-regexp + + (progn + (setq isearch-adjusted t) + (let ((cs (nth (if isearch-forward + 5 ; isearch-other-end + 2) ; saved (point) + (car (cdr isearch-cmds))))) + ;; (car isearch-cmds) is after last search; + ;; (car (cdr isearch-cmds)) is from before it. + (setq cs (or cs isearch-barrier)) + (goto-char + (if isearch-forward + (max cs isearch-barrier) + (min cs isearch-barrier)))))) + (isearch-process-search-char last-command-event)) + + + +(defun isearch-|-char () + "If in regexp search, jump to the barrier." + (interactive) + (if isearch-regexp + (progn + (setq isearch-adjusted t) + (goto-char isearch-barrier))) + (isearch-process-search-char last-command-event)) + +(defun isearch-quote-char () + "Quote special characters for incremental search." + (interactive) + (isearch-process-search-char (read-quoted-char (isearch-message t)))) + + +(defun isearch-return-char () + "Convert return into newline for incremental search. +Obsolete." + (interactive) + (isearch-process-search-char ?\n)) + + +(defun isearch-printing-char () + "Any other printing character => add it to the search string and search." + (interactive) + (isearch-process-search-char last-command-event)) + + +(defun isearch-whitespace-chars () + "Match all whitespace chars, if in regexp mode." + (interactive) + (if (and isearch-regexp search-whitespace-regexp) + (isearch-process-search-string search-whitespace-regexp " ") + (beep) + (isearch-process-search-char ?\ ) +; (if isearch-word +; nil +; (setq isearch-word t) +; (goto-char isearch-other-end) +; (isearch-process-search-char ?\ )) + )) + +(defun isearch-process-search-char (char) + ;; Append the char to the search string, update the message and re-search. + (isearch-process-search-string (isearch-char-to-string char) + (isearch-text-char-description char))) + +(defun isearch-process-search-string (string message) + (setq isearch-string (concat isearch-string string) + isearch-message (concat isearch-message message)) + (isearch-search-and-update)) + + +;;=========================================================== +;; Search Ring + +(defcustom search-ring-update nil + "*Non-nil if advancing or retreating in the search ring should cause search. +Default nil means edit the string from the search ring first." + :type 'boolean + :group 'isearch) + +(defun isearch-ring-adjust1 (advance) + ;; Helper for isearch-ring-adjust + (let* ((ring (if isearch-regexp regexp-search-ring search-ring)) + (length (length ring)) + (yank-pointer-name (if isearch-regexp + 'regexp-search-ring-yank-pointer + 'search-ring-yank-pointer)) + (yank-pointer (eval yank-pointer-name))) + (if (zerop length) + () + (set yank-pointer-name + (setq yank-pointer + (nthcdr (% (+ (- length (length yank-pointer)) + (if advance (1- length) 1)) + length) ring))) + (setq isearch-string (car yank-pointer) + isearch-message (mapconcat 'isearch-text-char-description + isearch-string ""))))) + +(defun isearch-ring-adjust (advance) + ;; Helper for isearch-ring-advance and isearch-ring-retreat + (if (cdr isearch-cmds) ;; is there more than one thing on stack? + (isearch-pop-state)) + (isearch-ring-adjust1 advance) + (isearch-push-state) + (if search-ring-update + (progn + (isearch-search) + (isearch-update)) + (isearch-edit-string) + )) + +(defun isearch-ring-advance () + "Advance to the next search string in the ring." + ;; This could be more general to handle a prefix arg, but who would use it. + (interactive) + (isearch-ring-adjust 'advance)) + +(defun isearch-ring-retreat () + "Retreat to the previous search string in the ring." + (interactive) + (isearch-ring-adjust nil)) + +(defun isearch-ring-adjust-edit (advance) + "Use the next or previous search string in the ring while in minibuffer." + (isearch-ring-adjust1 advance) + (erase-buffer) + (insert isearch-string)) + +(defun isearch-ring-advance-edit () + (interactive) + (isearch-ring-adjust-edit 'advance)) + +(defun isearch-ring-retreat-edit () + "Retreat to the previous search string in the ring while in the minibuffer." + (interactive) + (isearch-ring-adjust-edit nil)) + + +(defun isearch-complete1 () + ;; Helper for isearch-complete and isearch-complete-edit + ;; Return t if completion OK, + (let* ((ring (if isearch-regexp regexp-search-ring search-ring)) + (alist (mapcar (function (lambda (string) (list string))) ring)) + (completion-ignore-case case-fold-search) + (completion (try-completion isearch-string alist)) + ) + (cond + ((eq completion t) + ;; isearch-string stays the same + t) + ((or completion ; not nil, must be a string + (= 0 (length isearch-string))) ; shouldn't have to say this + (if (equal completion isearch-string) ;; no extension? + (if completion-auto-help + (with-output-to-temp-buffer "*Isearch completions*" + (display-completion-list + (all-completions isearch-string alist)))) + (setq isearch-string completion)) + t) + (t + (temp-minibuffer-message "No completion") + nil)))) + +(defun isearch-complete () + "Complete the search string from the strings on the search ring. +The completed string is then editable in the minibuffer. +If there is no completion possible, say so and continue searching." + (interactive) + (if (isearch-complete1) + (isearch-edit-string) + ;; else + (sit-for 1) + (isearch-update))) + +(defun isearch-complete-edit () + "Same as `isearch-complete' except in the minibuffer." + (interactive) + (setq isearch-string (buffer-string)) + (if (isearch-complete1) + (progn + (erase-buffer) + (insert isearch-string)))) + + +;;;============================================================== +;; The search status stack (and isearch window-local variables, not used). + +(defun isearch-top-state () +;; (fetch-window-local-variables) + (let ((cmd (car isearch-cmds))) + (setq isearch-string (car cmd) + isearch-message (car (cdr cmd)) + isearch-success (nth 3 cmd) + isearch-forward (nth 4 cmd) + isearch-other-end (nth 5 cmd) + isearch-invalid-regexp (nth 6 cmd) + isearch-wrapped (nth 7 cmd) + isearch-barrier (nth 8 cmd)) + (goto-char (car (cdr (cdr cmd)))))) + +(defun isearch-pop-state () +;; (fetch-window-local-variables) + (setq isearch-cmds (cdr isearch-cmds)) + (isearch-top-state) + ) + +(defun isearch-push-state () + (setq isearch-cmds + (cons (list isearch-string isearch-message (point) + isearch-success isearch-forward isearch-other-end + isearch-invalid-regexp isearch-wrapped isearch-barrier) + isearch-cmds))) + + +;;;================================================================== +;; Message string + +(defun isearch-message (&optional c-q-hack ellipsis) + ;; Generate and print the message string. + (let ((cursor-in-echo-area ellipsis) + (m (concat + (isearch-message-prefix c-q-hack) + isearch-message + (isearch-message-suffix c-q-hack) + ))) + (if c-q-hack m (display-message 'progress (format "%s" m))))) + +(defun isearch-message-prefix (&optional c-q-hack nonincremental) + ;; If about to search, and previous search regexp was invalid, + ;; check that it still is. If it is valid now, + ;; let the message we display while searching say that it is valid. + (and isearch-invalid-regexp + (condition-case () + (progn (re-search-forward isearch-string (point) t) + (setq isearch-invalid-regexp nil)) + (error nil))) + ;; #### - Yo! Emacs assembles strings all over the place, they can't all + ;; be internationalized in the manner proposed below... Add an explicit + ;; call to `gettext' and have the string snarfer pluck the english + ;; strings out of the comment below. XEmacs is on a purespace diet! -Stig + (let ((m (concat (if isearch-success nil "failing ") + (if isearch-wrapped "wrapped ") + (if isearch-word "word ") + (if isearch-regexp "regexp ") + (if nonincremental "search" "I-search") + (if isearch-forward nil " backward") + ": " + ))) + (aset m 0 (upcase (aref m 0))) + (gettext m))) + +(defun isearch-message-suffix (&optional c-q-hack) + (concat (if c-q-hack "^Q" "") + (if isearch-invalid-regexp + (concat " [" isearch-invalid-regexp "]") + ""))) + +;;;;; #### - yuck...this is soooo lame. Is this really worth 4k of purespace??? +;;; +;;;(let ((i (logior (if isearch-success 32 0) +;;; (if isearch-wrapped 16 0) +;;; (if isearch-word 8 0) +;;; (if isearch-regexp 4 0) +;;; (if nonincremental 2 0) +;;; (if isearch-forward 1 0)))) +;;; (cond +;;; ((= i 63) (gettext "Wrapped word regexp search: ")) ; 111111 +;;; ((= i 62) (gettext "Wrapped word regexp search backward: ")) ; 111110 +;;; ((= i 61) (gettext "Wrapped word regexp I-search: ")) ; 111101 +;;; ((= i 60) (gettext "Wrapped word regexp I-search backward: ")) ; 111100 +;;; ((= i 59) (gettext "Wrapped word search: ")) ; 111011 +;;; ((= i 58) (gettext "Wrapped word search backward: ")) ; 111010 +;;; ((= i 57) (gettext "Wrapped word I-search: ")) ; 111001 +;;; ((= i 56) (gettext "Wrapped word I-search backward: ")) ; 111000 +;;; ((= i 55) (gettext "Wrapped regexp search: ")) ; 110111 +;;; ((= i 54) (gettext "Wrapped regexp search backward: ")) ; 110110 +;;; ((= i 53) (gettext "Wrapped regexp I-search: ")) ; 110101 +;;; ((= i 52) (gettext "Wrapped regexp I-search backward: ")) ; 110100 +;;; ((= i 51) (gettext "Wrapped search: ")) ; 110011 +;;; ((= i 50) (gettext "Wrapped search backward: ")) ; 110010 +;;; ((= i 49) (gettext "Wrapped I-search: ")) ; 110001 +;;; ((= i 48) (gettext "Wrapped I-search backward: ")) ; 110000 +;;; ((= i 47) (gettext "Word regexp search: ")) ; 101111 +;;; ((= i 46) (gettext "Word regexp search backward: ")) ; 101110 +;;; ((= i 45) (gettext "Word regexp I-search: ")) ; 101101 +;;; ((= i 44) (gettext "Word regexp I-search backward: ")) ; 101100 +;;; ((= i 43) (gettext "Word search: ")) ; 101011 +;;; ((= i 42) (gettext "Word search backward: ")) ; 101010 +;;; ((= i 41) (gettext "Word I-search: ")) ; 101001 +;;; ((= i 40) (gettext "Word I-search backward: ")) ; 101000 +;;; ((= i 39) (gettext "Regexp search: ")) ; 100111 +;;; ((= i 38) (gettext "Regexp search backward: ")) ; 100110 +;;; ((= i 37) (gettext "Regexp I-search: ")) ; 100101 +;;; ((= i 36) (gettext "Regexp I-search backward: ")) ; 100100 +;;; ((= i 35) (gettext "Search: ")) ; 100011 +;;; ((= i 34) (gettext "Search backward: ")) ; 100010 +;;; ((= i 33) (gettext "I-search: ")) ; 100001 +;;; ((= i 32) (gettext "I-search backward: ")) ; 100000 +;;; ((= i 31) (gettext "Failing wrapped word regexp search: ")) ; 011111 +;;; ((= i 30) (gettext "Failing wrapped word regexp search backward: ")) ; 011110 +;;; ((= i 29) (gettext "Failing wrapped word regexp I-search: ")) ; 011101 +;;; ((= i 28) (gettext "Failing wrapped word regexp I-search backward: ")) ; 011100 +;;; ((= i 27) (gettext "Failing wrapped word search: ")) ; 011011 +;;; ((= i 26) (gettext "Failing wrapped word search backward: ")) ; 011010 +;;; ((= i 25) (gettext "Failing wrapped word I-search: ")) ; 011001 +;;; ((= i 24) (gettext "Failing wrapped word I-search backward: ")) ; 011000 +;;; ((= i 23) (gettext "Failing wrapped regexp search: ")) ; 010111 +;;; ((= i 22) (gettext "Failing wrapped regexp search backward: ")) ; 010110 +;;; ((= i 21) (gettext "Failing wrapped regexp I-search: ")) ; 010101 +;;; ((= i 20) (gettext "Failing wrapped regexp I-search backward: ")) ; 010100 +;;; ((= i 19) (gettext "Failing wrapped search: ")) ; 010011 +;;; ((= i 18) (gettext "Failing wrapped search backward: ")) ; 010010 +;;; ((= i 17) (gettext "Failing wrapped I-search: ")) ; 010001 +;;; ((= i 16) (gettext "Failing wrapped I-search backward: ")) ; 010000 +;;; ((= i 15) (gettext "Failing word regexp search: ")) ; 001111 +;;; ((= i 14) (gettext "Failing word regexp search backward: ")) ; 001110 +;;; ((= i 13) (gettext "Failing word regexp I-search: ")) ; 001101 +;;; ((= i 12) (gettext "Failing word regexp I-search backward: ")) ; 001100 +;;; ((= i 11) (gettext "Failing word search: ")) ; 001011 +;;; ((= i 10) (gettext "Failing word search backward: ")) ; 001010 +;;; ((= i 9) (gettext "Failing word I-search: ")) ; 001001 +;;; ((= i 8) (gettext "Failing word I-search backward: ")) ; 001000 +;;; ((= i 7) (gettext "Failing regexp search: ")) ; 000111 +;;; ((= i 6) (gettext "Failing regexp search backward: ")) ; 000110 +;;; ((= i 5) (gettext "Failing regexp I-search: ")) ; 000101 +;;; ((= i 4) (gettext "Failing regexp I-search backward: ")) ; 000100 +;;; ((= i 3) (gettext "Failing search: ")) ; 000011 +;;; ((= i 2) (gettext "Failing search backward: ")) ; 000010 +;;; ((= i 1) (gettext "Failing I-search: ")) ; 000001 +;;; ((= i 0) (gettext "Failing I-search backward: ")) ; 000000 +;;; (t (error "Something's rotten"))))) + + +;;;======================================================== +;;; Exiting + +(put 'isearch-printing-char 'isearch-command t) +(put 'isearch-return-char 'isearch-command t) +(put 'isearch-repeat-forward 'isearch-command t) +(put 'isearch-repeat-backward 'isearch-command t) +(put 'isearch-delete-char 'isearch-command t) +(put 'isearch-help-or-delete-char 'isearch-command t) +(put 'isearch-abort 'isearch-command t) +(put 'isearch-quote-char 'isearch-command t) +(put 'isearch-exit 'isearch-command t) +(put 'isearch-printing-char 'isearch-command t) +(put 'isearch-printing-char 'isearch-command t) +(put 'isearch-yank-word 'isearch-command t) +(put 'isearch-yank-line 'isearch-command t) +(put 'isearch-yank-kill 'isearch-command t) +(put 'isearch-yank-sexp 'isearch-command t) +(put 'isearch-*-char 'isearch-command t) +(put 'isearch-*-char 'isearch-command t) +(put 'isearch-|-char 'isearch-command t) +(put 'isearch-toggle-regexp 'isearch-command t) +(put 'isearch-toggle-case-fold 'isearch-command t) +(put 'isearch-edit-string 'isearch-command t) +(put 'isearch-mode-help 'isearch-command t) +(put 'isearch-ring-advance 'isearch-command t) +(put 'isearch-ring-retreat 'isearch-command t) +(put 'isearch-ring-advance-edit 'isearch-command t) +(put 'isearch-ring-retreat-edit 'isearch-command t) +(put 'isearch-whitespace-chars 'isearch-command t) +(put 'isearch-complete 'isearch-command t) +(put 'isearch-complete-edit 'isearch-command t) +(put 'isearch-edit-string 'isearch-command t) +(put 'isearch-toggle-regexp 'isearch-command t) +(put 'isearch-forward-exit-minibuffer 'isearch-command t) +(put 'isearch-reverse-exit-minibuffer 'isearch-command t) +(put 'isearch-nonincremental-exit-minibuffer 'isearch-command t) +(put 'isearch-yank-x-selection 'isearch-command t) +(put 'isearch-yank-x-clipboard 'isearch-command t) + +;; scrolling the scrollbar should not terminate isearch. + +;; vertical scrollbar: +(put 'scrollbar-line-up 'isearch-command t) +(put 'scrollbar-line-down 'isearch-command t) +(put 'scrollbar-page-up 'isearch-command t) +(put 'scrollbar-page-down 'isearch-command t) +(put 'scrollbar-to-top 'isearch-command t) +(put 'scrollbar-to-bottom 'isearch-command t) +(put 'scrollbar-vertical-drag 'isearch-command t) + +;; horizontal scrollbar: +(put 'scrollbar-char-left 'isearch-command t) +(put 'scrollbar-char-right 'isearch-command t) +(put 'scrollbar-page-left 'isearch-command t) +(put 'scrollbar-page-right 'isearch-command t) +(put 'scrollbar-to-left 'isearch-command t) +(put 'scrollbar-to-right 'isearch-command t) +(put 'scrollbar-horizontal-drag 'isearch-command t) + +(defun isearch-pre-command-hook () + ;; + ;; For use as the value of `pre-command-hook' when isearch-mode is active. + ;; If the command about to be executed is not one of the isearch commands, + ;; then isearch-mode is turned off before that command is executed. + ;; + ;; If the command about to be executed is self-insert-command, or is a + ;; keyboard macro of a single key sequence which is bound to self-insert- + ;; command, then we add those chars to the search ring instead of inserting + ;; them in the buffer. In this way, the set of self-searching characters + ;; need not be exhaustively enumerated, but is derived from other maps. + ;; + (cond ((not (eq (current-buffer) isearch-buffer)) + ;; If the buffer (likely meaning "frame") has changed, bail. + ;; This can also happen if a proc filter has popped up another + ;; buffer, which is arguably a bad thing for it to have done, + ;; but the way in which isearch would have hosed you in that + ;; case is unarguably even worse. -jwz + (isearch-done)) + (t + (isearch-maybe-frob-keyboard-macros) + (if (and this-command + (symbolp this-command) + (get this-command 'isearch-command)) + nil ; then continue. + (isearch-done))))) + +(defun isearch-maybe-frob-keyboard-macros () + ;; + ;; If the command about to be executed is `self-insert-command' then change + ;; the command to `isearch-printing-char' instead, meaning add the last- + ;; typed character to the search string. + ;; + ;; If `this-command' is a string or a vector (that is, a keyboard macro) + ;; and it contains only one command, which is bound to self-insert-command, + ;; then do the same thing as for self-inserting commands: arrange for that + ;; character to be added to the search string. If we didn't do this, then + ;; typing a compose sequence (a la x-compose.el) would terminate the search + ;; and insert the character, instead of searching for that character. + ;; + ;; We should continue doing this, since it's pretty much the behavior one + ;; would expect, but it will stop being so necessary once key-translation- + ;; map exists and is used by x-compose.el and things like it, since the + ;; translation will have been done before we see the keys. + ;; + (cond ((eq this-command 'self-insert-command) + (setq this-command 'isearch-printing-char)) + ((and (or (stringp this-command) (vectorp this-command)) + (eq (key-binding this-command) 'self-insert-command)) + (setq last-command-event (character-to-event (aref this-command 0)) + last-command-char (and (stringp this-command) + (aref this-command 0)) + this-command 'isearch-printing-char)) + )) + + +;;;======================================================== +;;; Highlighting + +(defcustom isearch-highlight t + "*Whether isearch and query-replace should highlight the text which +currently matches the search-string.") + +(defvar isearch-extent nil) + +;; this face is initialized by x-faces.el since isearch is preloaded. +;; this face is now created in initialize-faces +;;(make-face 'isearch) + +(defun isearch-make-extent (begin end) + (let ((x (make-extent begin end (current-buffer)))) + ;; make the isearch extent always take prescedence over any mouse- + ;; highlighted extents we may be passing through, since isearch, being + ;; modal, is more interesting (there's nothing they could do with a + ;; mouse-highlighted extent while in the midst of a search anyway). + (set-extent-priority x (1+ mouse-highlight-priority)) + (set-extent-face x 'isearch) + (setq isearch-extent x))) + +(defun isearch-highlight (begin end) + (if (null isearch-highlight) + nil + ;; make sure isearch-extent is in the current buffer + (cond ((not (extentp isearch-extent)) + (isearch-make-extent begin end)) + ((not (eq (extent-object isearch-extent) (current-buffer))) + (delete-extent isearch-extent) + (isearch-make-extent begin end))) + (set-extent-endpoints isearch-extent begin end))) + +(defun isearch-dehighlight (totally) + (if (and isearch-highlight isearch-extent) + (if totally + (let ((inhibit-quit t)) + (if (extentp isearch-extent) + (delete-extent isearch-extent)) + (setq isearch-extent nil)) + (if (extentp isearch-extent) + (detach-extent isearch-extent) + (setq isearch-extent nil))))) + + +;;;======================================================== +;;; Searching + +(defun isearch-search () + ;; Do the search with the current search string. + (isearch-message nil t) + (if (and isearch-case-fold-search search-caps-disable-folding) + (setq isearch-case-fold-search (isearch-no-upper-case-p isearch-string))) + + (setq isearch-mode (if case-fold-search + (if isearch-case-fold-search + " Isearch" ;As God Intended Mode + " ISeARch") ;Warn about evil case via StuDLYcAps. + "Isearch" +; (if isearch-case-fold-search +; " isearch" ;Presumably case-sensitive losers +; ;will notice this 1-char difference. +; " Isearch") ;Weenie mode. + )) + (condition-case lossage + (let ((inhibit-quit nil) + (case-fold-search isearch-case-fold-search)) + (if isearch-regexp (setq isearch-invalid-regexp nil)) + (setq isearch-success + (funcall + (cond (isearch-word + (if isearch-forward + 'word-search-forward 'word-search-backward)) + (isearch-regexp + (if isearch-forward + 're-search-forward 're-search-backward)) + (t + (if isearch-forward 'search-forward 'search-backward))) + isearch-string nil t)) + (if isearch-success + (setq isearch-other-end + (if isearch-forward (match-beginning 0) (match-end 0))))) + + (quit (setq unread-command-event (character-to-event (quit-char))) + (setq isearch-success nil)) + + (invalid-regexp + (setq isearch-invalid-regexp (car (cdr lossage))) + (if (string-match + "\\`Premature \\|\\`Unmatched \\|\\`Invalid " + isearch-invalid-regexp) + (setq isearch-invalid-regexp (gettext "incomplete input"))))) + + (if isearch-success + nil + + ;; If we're being run inside a keyboard macro, then the call to + ;; ding will signal an error (to terminate the macro). We must + ;; turn off isearch-mode first, so that we aren't still in isearch + ;; mode after the macro exits. Note that isearch-recursive-edit + ;; must not be true if a keyboard macro is executing. + (if (and executing-kbd-macro (not defining-kbd-macro)) + (progn + (isearch-done) + (ding nil 'isearch-failed))) + + ;; Ding if failed this time after succeeding last time. + (and (nth 3 (car isearch-cmds)) + (ding nil 'isearch-failed)) + (goto-char (nth 2 (car isearch-cmds))))) + +;;;================================================= +;; This is called from incremental-search +;; if the first input character is the exit character. + +;; We store the search string in `isearch-string' +;; which has been bound already by `isearch-search' +;; so that, when we exit, it is copied into `search-last-string'. + +;(defun nonincremental-search (forward regexp) +; ;; This may be broken. Anyway, it is replaced by the isearch-edit-string. +; ;; Missing features: word search option, command history. +; (setq isearch-forward forward +; isearch-regexp regexp) +; (let (char function +; inhibit-quit +; (cursor-in-echo-area t)) +; ;; Prompt assuming not word search, +; (setq isearch-message +; (if isearch-regexp +; (if isearch-forward "Regexp search: " +; "Regexp search backward: ") +; (if isearch-forward "Search: " "Search backward: "))) +; (message "%s" isearch-message) +; ;; Read 1 char and switch to word search if it is ^W. +; (setq char (read-char)) +; (if (eq char search-yank-word-char) +; (setq isearch-message (if isearch-forward "Word search: " +; "Word search backward: ")) +; ;; Otherwise let that 1 char be part of the search string. +; (setq unread-command-event (character-to-event char)) +; ) +; (setq function +; (if (eq char search-yank-word-char) +; (if isearch-forward 'word-search-forward 'word-search-backward) +; (if isearch-regexp +; (if isearch-forward 're-search-forward 're-search-backward) +; (if isearch-forward 'search-forward 'search-backward)))) +; ;; Read the search string with corrected prompt. +; (setq isearch-string (read-string isearch-message isearch-string)) +; ;; Empty means use default. +; (if (= 0 (length isearch-string)) +; (setq isearch-string search-last-string) +; ;; Set last search string now so it is set even if we fail. +; (setq search-last-string isearch-string)) +; ;; Since we used the minibuffer, we should be available for redo. +; (setq command-history +; (cons (list function isearch-string) command-history)) +; ;; Go ahead and search. +; (if search-caps-disable-folding +; (setq isearch-case-fold-search +; (isearch-no-upper-case-p isearch-string))) +; (let ((case-fold-search isearch-case-fold-search)) +; (funcall function isearch-string)))) + + +(defun isearch-no-upper-case-p (string) + "Return t if there are no upper case chars in string. +But upper case chars preceded by \\ do not count since they +have special meaning in a regexp." + ;; this incorrectly returns t for "\\\\A" + (let ((case-fold-search nil)) + (not (string-match "\\(^\\|[^\\]\\)[A-Z]" string)))) + +;; Used by etags.el and info.el +(defmacro with-caps-disable-folding (string &rest body) "\ +Eval BODY with `case-fold-search' let to nil if STRING contains +uppercase letters and `search-caps-disable-folding' is t." + `(let ((case-fold-search + (if (and case-fold-search search-caps-disable-folding) + (isearch-no-upper-case-p ,string) + case-fold-search))) + ,@body)) +(put 'with-caps-disable-folding 'lisp-indent-function 1) +(put 'with-caps-disable-folding 'edebug-form-spec '(form body)) + +;;; isearch-mode.el ends here
--- a/lisp/iso/auto-autoloads.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,31 +0,0 @@ -;;; DO NOT MODIFY THIS FILE -(if (featurep 'iso-autoloads) (error "Already loaded")) - -;;;### (autoloads (iso-accents-mode) "iso-acc" "iso/iso-acc.el") - -(autoload 'iso-accents-mode "iso-acc" "\ -Toggle ISO Accents mode, in which accents modify the following letter. -This permits easy insertion of accented characters according to ISO-8859-1. -When Iso-accents mode is enabled, accent character keys -\(`, ', \", ^, / and ~) do not self-insert; instead, they modify the following -letter key so that it inserts an ISO accented letter. - -You can customize ISO Accents mode to a particular language -with the command `iso-accents-customize'. - -Special combinations: ~c gives a c with cedilla, -~d gives an Icelandic eth (d with dash). -~t gives an Icelandic thorn. -\"s gives German sharp s. -/a gives a with ring. -/e gives an a-e ligature. -~< and ~> give guillemots. -~! gives an inverted exclamation mark. -~? gives an inverted question mark. - -With an argument, a positive argument enables ISO Accents mode, -and a negative argument disables it." t nil) - -;;;*** - -(provide 'iso-autoloads)
--- a/lisp/iso/iso-acc.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,503 +0,0 @@ -;;; iso-acc.el --- minor mode providing electric accent keys - -;; Copyright (C) 1993, 1994, 1996 Free Software Foundation, Inc. - -;; Author: Johan Vromans -;; Maintainer: Alexandre Oliva <oliva@dcc.unicamp.br> -;; Keywords: i18n -;; $Revision: 1.6 $ -;; $Date: 1997/07/07 00:52:57 $ - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; Function `iso-accents-mode' activates a minor mode in which -;; typewriter "dead keys" are emulated. The purpose of this emulation -;; is to provide a simple means for inserting accented characters -;; according to the ISO-8859-1 and other character sets. -;; -;; In `iso-accents-mode', pseudo accent characters are used to -;; introduce accented keys. The pseudo-accent characters are: -;; -;; ' (minute) -> grave accent -;; ` (backtick) -> acute accent -;; " (second) -> diaeresis -;; ^ (caret) -> circumflex -;; ~ (tilde) -> tilde over the character -;; / (slash) -> slash through the character -;; Also: /A is A-with-ring and /E is AE ligature. -;; . (dot) -> dot over the character -;; , (cedilla) -> cedilla under the character (some languages only) -;; -;; The action taken depends on the key that follows the pseudo accent. -;; In general: -;; -;; pseudo-accent + appropriate letter -> accented letter -;; pseudo-accent + space -> pseudo-accent (except comma) -;; pseudo-accent + pseudo-accent -> accent (if available) -;; pseudo-accent + other -> pseudo-accent + other -;; -;; If the pseudo-accent is followed by anything else than a -;; self-insert-command, the dead-key code is terminated, the -;; pseudo-accent inserted 'as is' and the bell is rung to signal this. -;; -;; Function `iso-accents-mode' can be used to enable the iso accents -;; minor mode, or disable it. - -;; If you want only some of these characters to serve as accents, -;; add a language to `iso-languages' which specifies the accent characters -;; that you want, then select the language with `iso-accents-customize'. - -;;; Code: - -(provide 'iso-acc) - -;; multiple Emacs versions compatibility section - -(if (fboundp 'make-char) - (defun iso-make-char (charset char) - (cond - ((integerp char) (make-char charset char)) - ((and (char-or-string-p char) (not (stringp char))) char) - (t (error "invalid character")))) - (defun iso-make-char (charset char) "Returns its second argument" char)) - -(if (fboundp 'read-event) - (defalias 'iso-read-event 'read-event) - (defun iso-read-event () - (event-key (next-command-event)))) - -(if (fboundp 'character-to-event) - (progn - (defun iso-char-list-to-event (l) - "returns an event containing the given list of characters" - (character-to-event l)) - (defun iso-char-to-event (ch) - "returns an event containing the given character" - (iso-char-list-to-event (list ch)))) - (defalias 'iso-char-to-event 'identity) - (defalias 'iso-char-list-to-event 'identity)) - -(if (fboundp 'this-single-command-keys) () - (if (string-match "Lucid" (version)) - (defun this-single-command-keys () - (setq this-command (not (this-command-keys))) - (this-command-keys)) - (defun this-single-command-keys () (this-command-keys)))) - -;; end of compatibility section - -(defvar iso-languages - '(("catalan" - ;; Note this includes some extra characters used in Spanish, - ;; on the idea that someone who uses Catalan is likely to use Spanish - ;; as well. - (?' (?A . ?\301) (?E . ?\311) (?I . ?\315) (?O . ?\323) (?U . ?\332) - (?a . ?\341) (?e . ?\351) (?i . ?\355) (?o . ?\363) (?u . ?\372) - (?\ . ?')) - (?` (?A . ?\300) (?E . ?\310) (?O . ?\322) - (?a . ?\340) (?e . ?\350) (?o . ?\362) (?\ . ?`)) - (?\" (?I . ?\317) (?U . ?\334) (?i . ?\357) (?u . ?\374) (?\ . ?\")) - (?~ (?C . ?\307) (?N . ?\321) (?c . ?\347) (?n . ?\361) - (?> . ?\273) (?< . ?\253) (?! . ?\241) (?? . ?\277) - (?\ . ?~))) - - ("esperanto" - (?^ (?H . ?\246) (?J . ?\254) (?h . ?\266) (?j . ?\274) (?C . ?\306) - (?G . ?\330) (?S . ?\336) (?c . ?\346) (?g . ?\370) (?s . ?\376) - (?^ . ?^) (?\ . ?^)) - (?~ (?U . ?\335) (?u . ?\375) (?\ . ?~))) - - ("french" - (?' (?E . ?\311) (?C . ?\307) - (?e . ?\351) (?c . ?\347) - (?\ . ?') (space . ?')) - (?` (?A . ?\300) (?E . ?\310) (?U . ?\331) - (?a . ?\340) (?e . ?\350) (?u . ?\371) - (?\ . ?`) (space . ?`)) - (?^ (?A . ?\302) (?E . ?\312) (?I . ?\316) (?O . ?\324) (?U . ?\333) - (?a . ?\342) (?e . ?\352) (?i . ?\356) (?o . ?\364) (?u . ?\373) - (?\ . ?^) (space . ?^)) - (?\" (?E . ?\313) (?I . ?\317) - (?e . ?\353) (?i . ?\357) - (?\ . ?\") (space . ?\")) - (?~ (?< . ?\253) (?> . ?\273) - (?C . ?\307) (?c . ?\347) - (?\ . ?~) (space . ?~)) - (?, (?c . ?\347) (?C . ?\307) (?, . ?,))) - - ("german" - (?\" (?A . ?\304) (?O . ?\326) (?U . ?\334) - (?a . ?\344) (?o . ?\366) (?u . ?\374) (?s . ?\337) (?\ . ?\"))) - - ("irish" - (?' (?A . ?\301) (?E . ?\311) (?I . ?\315) (?O . ?\323) (?U . ?\332) - (?a . ?\341) (?e . ?\351) (?i . ?\355) (?o . ?\363) (?u . ?\372) - (?\ . ?') (space . ?'))) - - ("portuguese" - (?' (?A . ?\301) (?E . ?\311) (?I . ?\315) (?O . ?\323) (?U . ?\332) - (?C . ?\307) (?a . ?\341) (?e . ?\351) (?i . ?\355) (?o . ?\363) - (?u . ?\372) (?c . ?\347) (?\ . ?') (space . ?')) - (?` (?A . ?\300) (?a . ?\340) (?\ . ?`) (space . ?`)) - (?^ (?A . ?\302) (?E . ?\312) (?O . ?\324) (?a . ?\342) (?e . ?\352) - (?o . ?\364) (?\ . ?^) (space . ?^)) - (?\" (?U . ?\334) (?u . ?\374) (?\ . ?\") (space . ?\")) - (?~ (?A . ?\303) (?O . ?\325) - (?a . ?\343) (?o . ?\365) - (?\ . ?~) (space . ?~)) - (?, (?c . ?\347) (?C . ?\307) (?, . ?,))) - - ("spanish" - (?' (?A . ?\301) (?E . ?\311) (?I . ?\315) (?O . ?\323) (?U . ?\332) - (?a . ?\341) (?e . ?\351) (?i . ?\355) (?o . ?\363) (?u . ?\372) - (?\ . ?')) - (?\" (?U . ?\334) (?u . ?\374) (?\ . ?\")) - (?~ (?N . ?\321) (?n . ?\361) (?> . ?\273) (?< . ?\253) (?! . ?\241) - (?? . ?\277) (?\ . ?~))) - - ("latin-1" - (?' (?A . ?\301) (?E . ?\311) (?I . ?\315) (?O . ?\323) (?U . ?\332) - (?Y . ?\335) (?a . ?\341) (?e . ?\351) (?i . ?\355) (?o . ?\363) - (?u . ?\372) (?y . ?\375) (?' . ?\264) (?\ . ?') (space . ?')) - (?` (?A . ?\300) (?E . ?\310) (?I . ?\314) (?O . ?\322) (?U . ?\331) - (?a . ?\340) (?e . ?\350) (?i . ?\354) (?o . ?\362) (?u . ?\371) - (?` . ?`) (?\ . ?`) (space . ?`)) - (?^ (?A . ?\302) (?E . ?\312) (?I . ?\316) (?O . ?\324) (?U . ?\333) - (?a . ?\342) (?e . ?\352) (?i . ?\356) (?o . ?\364) (?u . ?\373) - (?^ . ?^) (?\ . ?^) (space . ?^)) - (?\" (?A . ?\304) (?E . ?\313) (?I . ?\317) (?O . ?\326) (?U . ?\334) - (?a . ?\344) (?e . ?\353) (?i . ?\357) (?o . ?\366) (?s . ?\337) - (?u . ?\374) (?y . ?\377) (?\" . ?\250) (?\ . ?\") (space . ?\")) - (?~ (?A . ?\303) (?C . ?\307) (?D . ?\320) (?N . ?\321) (?O . ?\325) - (?T . ?\336) (?a . ?\343) (?c . ?\347) (?d . ?\360) (?n . ?\361) - (?o . ?\365) (?t . ?\376) (?> . ?\273) (?< . ?\253) (?~ . ?\270) - (?! . ?\241) (?? . ?\277) - (?\ . ?~) (space . ?~)) - (?/ (?A . ?\305) (?E . ?\306) (?O . ?\330) (?a . ?\345) (?e . ?\346) - (?o . ?\370) (?/ . ?\260) (?\ . ?/) (space . ?/))) - - ("latin-2" latin-iso8859-2 - (?' (?A . ?\301) (?C . ?\306) (?D . ?\320) (?E . ?\311) (?I . ?\315) - (?L . ?\305) (?N . ?\321) (?O . ?\323) (?R . ?\300) (?S . ?\246) - (?U . ?\332) (?Y . ?\335) (?Z . ?\254) - (?a . ?\341) (?c . ?\346) (?d . ?\360) (?e . ?\351) (?i . ?\355) - (?l . ?\345) (?n . ?\361) (?o . ?\363) (?r . ?\340) (?s . ?\266) - (?u . ?\372) (?y . ?\375) (?z . ?\274) - (?' . ?\264) (?\ . ?') (space . ?')) - (?` (?A . ?\241) (?C . ?\307) (?E . ?\312) (?L . ?\243) (?S . ?\252) - (?T . ?\336) (?Z . ?\257) - (?a . ?\261) (?l . ?\263) (?c . ?\347) (?e . ?\352) (?s . ?\272) - (?t . ?\376) (?z . ?\277) - (?` . ?\252) - (?. . ?\377) (?\ . ?`) (space . ?`)) - (?^ (?A . ?\302) (?I . ?\316) (?O . ?\324) - (?a . ?\342) (?i . ?\356) (?o . ?\364) - (?^ . ?^) ; no special code? - (?\ . ?^) (space . ?^)) - (?\" (?A . ?\304) (?E . ?\313) (?O . ?\326) (?U . ?\334) - (?a . ?\344) (?e . ?\353) (?o . ?\366) (?s . ?\337) (?u . ?\374) - (?\" . ?\250) - (?\ . ?\") (space . ?\")) - (?~ (?A . ?\303) (?C . ?\310) (?D . ?\317) (?L . ?\245) (?N . ?\322) - (?O . ?\325) (?R . ?\330) (?S . ?\251) (?T . ?\253) (?U . ?\333) - (?Z . ?\256) - (?a . ?\343) (?c . ?\350) (?d . ?\357) (?l . ?\265) (?n . ?\362) - (?o . ?\365) (?r . ?\370) (?s . ?\271) (?t . ?\273) (?u . ?\373) - (?z . ?\276) - (?v . ?\242) ; v accent - (?~ . ?\242) ; v accent - (?. . ?\270) ; cedilla accent - (?\ . ?~) (space . ?~))) - - ("latin-3" latin-iso8859-3 - (?' (?A . ?\301) (?E . ?\311) (?I . ?\315) (?O . ?\323) (?U . ?\332) - (?a . ?\341) (?e . ?\351) (?i . ?\355) (?o . ?\363) (?u . ?\372) - (?' . ?\264) (?\ . ?') (space . ?')) - (?` (?A . ?\300) (?E . ?\310) (?I . ?\314) (?O . ?\322) (?U . ?\331) - (?a . ?\340) (?e . ?\350) (?i . ?\354) (?o . ?\362) (?u . ?\371) - (?` . ?`) (?\ . ?`) (space . ?`)) - (?^ (?A . ?\302) (?C . ?\306) (?E . ?\312) (?G . ?\330) - (?H . ?\246) (?I . ?\316) (?J . ?\254) (?O . ?\324) - (?S . ?\336) (?U . ?\333) - (?a . ?\342) (?c . ?\346) (?e . ?\352) (?g . ?\370) (?h . ?\266) - (?i . ?\356) (?j . ?\274) (?o . ?\364) (?s . ?\376) (?u . ?\373) - (?^ . ?^) (?\ . ?^) (space . \^)) - (?\" (?A . ?\304) (?E . ?\313) (?I . ?\317) (?O . ?\326) (?U . ?\334) - (?a . ?\344) (?e . ?\353) (?i . ?\357) (?o . ?\366) (?u . ?\374) - (?s . ?\337) - (?\" . ?\250) (?\ . ?\") (space . ?\")) - (?. (?C . ?\305) (?G . ?\325) (?I . ?\251) (?Z . ?\257) - (?c . ?\345) (?g . ?\365) (?z . ?\277)) - (?~ (?A . ?\303) (?C . ?\307) (?D . ?\320) (?G . ?\253) (?N . ?\321) - (?O . ?\325) (?S . ?\252) (?U . ?\335) - (?a . ?\343) (?c . ?\347) (?d . ?\360) (?g . ?\273) (?n . ?\361) - (?o . ?\365) (?s . ?\252) (?u . ?\375) - (?h . ?\261) (?$ . ?\245) (?` . ?\242) - (?~ . ?\270) (?\ . ?~) (space . ?~)) - (?/ (?C . ?\305) (?G . ?\325) (?H . ?\241) (?I . ?\251) (?Z . ?\257) - (?c . ?\345) (?g . ?\365) (?h . ?\261) (?i . ?\271) (?z . ?\277) - (?r . ?\256) (?. . ?\377) (?# . ?\243) (?$ . ?\244) - (?/ . ?\260) (?\ . ?/) (space . ?/))) - ) - "List of language-specific customizations for the ISO Accents mode. - -Each element of the list is of the form - - (LANGUAGE [CHARSET] - (PSEUDO-ACCENT MAPPINGS) - (PSEUDO-ACCENT MAPPINGS) - ...) - -LANGUAGE is a string naming the language. -CHARSET (which may be omitted) is the symbol name - of the character set used in this language. - If CHARSET is omitted, latin-iso8859-1 is the default. -PSEUDO-ACCENT is a char specifying an accent key. -MAPPINGS are cons cells of the form (CHAR . ISO-CHAR). - -The net effect is that the key sequence PSEUDO-ACCENT CHAR is mapped -to ISO-CHAR on input.") - -(defvar iso-language nil - "Language for which ISO Accents mode is currently customized. -Change it with the `iso-accents-customize' function.") - -(defvar iso-accents-list nil - "Association list for ISO accent combinations, for the chosen language.") - -(defvar iso-accents-charset 'latin-iso8859-1 - "Charset that will be used for generated characters.") - -(defvar iso-accents-mode nil - "*Non-nil enables ISO Accents mode. -Setting this variable makes it local to the current buffer. -See the function `iso-accents-mode'.") -(make-variable-buffer-local 'iso-accents-mode) - -(defvar iso-accents-enable '(?' ?` ?^ ?\" ?~ ?/ ?, ?.) - "*List of accent keys that become prefixes in ISO Accents mode. -The default is (?' ?` ?^ ?\" ?~ ?/ ?, ?.), which contains all the supported -accent keys. If you set this variable to a list in which some of those -characters are missing, the missing ones do not act as accents. - -Note that if you specify a language with `iso-accents-customize', -that can also turn off certain prefixes (whichever ones are not needed in -the language you choose).") - -(defun iso-accents-accent-key (prompt) - "Modify the following character by adding an accent to it." - ;; Pick up the accent character. - (if (and iso-accents-mode - (memq last-input-char iso-accents-enable)) - (iso-accents-compose prompt) - (char-to-string last-input-char))) - -(defun iso-accents-compose (prompt) - (let* ((first-char last-input-char) - (list (assq first-char iso-accents-list)) - (charset iso-accents-charset) - ;; Wait for the second key and look up the combination. - (second-char (if (or prompt - (not (eq (key-binding "a") - 'self-insert-command)) - ;; Not at start of a key sequence. - (> (length (this-single-command-keys)) 1) - ;; Called from anything but the command loop. - this-command) - (progn - (message "%s%c" - (or prompt "Compose with ") - first-char) - (iso-read-event)) - (insert first-char) - (prog1 (iso-read-event) - (delete-region (1- (point)) (point))))) - (entry (cdr (assq second-char list)))) - (if entry - (progn - (if (and (consp entry) (symbolp (car entry))) - (setq charset (car entry) - entry (cdr entry))) - ;; Found it: return the mapped char - (vector - (iso-char-to-event (iso-make-char charset entry)))) - ;; Otherwise, advance and schedule the second key for execution. - (setq unread-command-events (cons (iso-char-list-to-event - (list second-char)) - unread-command-events)) - (vector (iso-char-to-event first-char))))) - -;; It is a matter of taste if you want the minor mode indicated -;; in the mode line... -;; If so, uncomment the next four lines. -;; (or (assq 'iso-accents-mode minor-mode-alist) -;; (setq minor-mode-alist -;; (append minor-mode-alist -;; '((iso-accents-mode " ISO-Acc"))))) - -;;;###autoload -(defun iso-accents-mode (&optional arg) - "Toggle ISO Accents mode, in which accents modify the following letter. -This permits easy insertion of accented characters according to ISO-8859-1. -When Iso-accents mode is enabled, accent character keys -\(`, ', \", ^, / and ~) do not self-insert; instead, they modify the following -letter key so that it inserts an ISO accented letter. - -You can customize ISO Accents mode to a particular language -with the command `iso-accents-customize'. - -Special combinations: ~c gives a c with cedilla, -~d gives an Icelandic eth (d with dash). -~t gives an Icelandic thorn. -\"s gives German sharp s. -/a gives a with ring. -/e gives an a-e ligature. -~< and ~> give guillemots. -~! gives an inverted exclamation mark. -~? gives an inverted question mark. - -With an argument, a positive argument enables ISO Accents mode, -and a negative argument disables it." - - (interactive "P") - - (if (if arg - ;; Negative arg means switch it off. - (<= (prefix-numeric-value arg) 0) - ;; No arg means toggle. - iso-accents-mode) - (setq iso-accents-mode nil) - - ;; Enable electric accents. - (setq iso-accents-mode t))) - -(defun iso-accents-customize (language) - "Customize the ISO accents machinery for a particular language. -It selects the customization based on the specifications in the -`iso-languages' variable." - (interactive (list (completing-read "Language: " iso-languages nil t))) - (let ((table (cdr (assoc language iso-languages))) - tail) - (if (not table) - (error "Unknown language `%s'" language) - (setq iso-accents-charset (if (symbolp (car table)) - (car table) - 'latin-iso8859-1)) - (if (symbolp (car table)) - (setq table (cdr table))) - (setq iso-language language - iso-accents-list table) - (if key-translation-map - (substitute-key-definition - 'iso-accents-accent-key nil key-translation-map) - (setq key-translation-map (make-sparse-keymap))) - ;; Set up translations for all the characters that are used as - ;; accent prefixes in this language. - (setq tail iso-accents-list) - (while tail - (define-key key-translation-map (vector (iso-char-to-event - (car (car tail)))) - 'iso-accents-accent-key) - (setq tail (cdr tail)))))) - -(defun iso-accentuate (start end) - "Convert two-character sequences in region into accented characters. -Noninteractively, this operates on text from START to END. -This uses the same conversion that ISO Accents mode uses for type-in." - (interactive "r") - (save-excursion - (save-restriction - (narrow-to-region start end) - (goto-char start) - (forward-char 1) - (let (entry) - (while (< (point) end) - (if (and (memq (preceding-char) iso-accents-enable) - (setq entry (cdr (assq (following-char) (assq (preceding-char) iso-accents-list))))) - (progn - (forward-char -1) - (delete-char 2) - (insert entry) - (setq end (1- end))) - (forward-char 1))))))) - -(defun iso-accent-rassoc-unit (value alist) - (let (elt acc) - (while (and alist (not elt)) - (setq acc (car (car alist)) - elt (car (rassq value (cdr (car alist)))) - alist (cdr alist))) - (if elt - (cons acc elt)))) - -(defun iso-unaccentuate (start end) - "Convert accented characters in the region into two-character sequences. -Noninteractively, this operates on text from START to END. -This uses the opposite of the conversion done by ISO Accents mode for type-in." - (interactive "r") - (save-excursion - (save-restriction - (narrow-to-region start end) - (goto-char start) - (let (entry) - (while (< (point) end) - (if (and (> (following-char) 127) - (setq entry (iso-accent-rassoc-unit (following-char) - iso-accents-list))) - (progn - (delete-char 1) - (insert (car entry) (cdr entry)) - (setq end (1+ end))) - (forward-char 1))))))) - -(defun iso-deaccentuate (start end) - "Convert accented characters in the region into unaccented characters. -Noninteractively, this operates on text from START to END." - (interactive "r") - (save-excursion - (save-restriction - (narrow-to-region start end) - (goto-char start) - (let (entry) - (while (< (point) end) - (if (and (> (following-char) 127) - (setq entry (iso-accent-rassoc-unit (following-char) - iso-accents-list))) - (progn - (delete-char 1) - (insert (cdr entry))) - (forward-char 1))))))) - -;; Set up the default settings. -(iso-accents-customize "latin-1") - -;; Use Iso-Accents mode in the minibuffer -;; if it was in use in the previous buffer. -(defun iso-acc-minibuf-setup () - (setq iso-accents-mode - (save-excursion - (set-buffer (window-buffer minibuffer-scroll-window)) - iso-accents-mode))) - -(if (boundp 'minibuffer-setup-hook) - (add-hook 'minibuffer-setup-hook 'iso-acc-minibuf-setup) - (add-hook 'minibuf-setup-hook 'iso-acc-minibuf-setup)) - -;;; iso-acc.el ends here
--- a/lisp/iso/iso-ascii.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,148 +0,0 @@ -;;; iso-ascii.el --- set up char tables for ISO 8859/1 on ASCII terminals. - -;; Copyright (C) 1987, 1995 Free Software Foundation, Inc. - -;; Author: Howard Gayle -;; Maintainer: FSF -;; Keywords: i18n - -;; 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.34. - -;;; Commentary: - -;; Written by Howard Gayle. See display-table.el for details. - -;; This code sets up to display ISO 8859/1 characters on plain -;; ASCII terminals. The display strings for the characters are -;; more-or-less based on TeX. - -;;; Code: - -(require 'disp-table) - -(defvar iso-ascii-convenient nil - "*Non-nil means `iso-ascii' should aim for convenience, not precision.") - -(defun iso-ascii-display (code string &optional convenient-string) - (if iso-ascii-convenient - (setq string (or convenient-string string)) - (setq string (concat "{" string "}"))) - (standard-display-ascii code string)) - -(iso-ascii-display 160 "_" " ") ; NBSP (no-break space) -(iso-ascii-display 161 "!") ; inverted exclamation mark -(iso-ascii-display 162 "c") ; cent sign -(iso-ascii-display 163 "GBP") ; pound sign -(iso-ascii-display 164 "$") ; general currency sign -(iso-ascii-display 165 "JPY") ; yen sign -(iso-ascii-display 166 "|") ; broken vertical line -(iso-ascii-display 167 "S" "(S)") ; section sign -(iso-ascii-display 168 "\"") ; diaeresis -(iso-ascii-display 169 "C" "(C)") ; copyright sign -(iso-ascii-display 170 "_a") ; ordinal indicator, feminine -(iso-ascii-display 171 "<<") ; left angle quotation mark -(iso-ascii-display 172 "~") ; not sign -(iso-ascii-display 173 "-") ; soft hyphen -(iso-ascii-display 174 "R" "(R)") ; registered sign -(iso-ascii-display 175 "=") ; macron -(iso-ascii-display 176 "o") ; degree sign -(iso-ascii-display 177 "+-") ; plus or minus sign -(iso-ascii-display 178 "2") ; superscript two -(iso-ascii-display 179 "3") ; superscript three -(iso-ascii-display 180 "'") ; acute accent -(iso-ascii-display 181 "u") ; micro sign -(iso-ascii-display 182 "P" "{P}") ; pilcrow -(iso-ascii-display 183 ".") ; middle dot -(iso-ascii-display 184 ",") ; cedilla -(iso-ascii-display 185 "1") ; superscript one -(iso-ascii-display 186 "_o") ; ordinal indicator, masculine -(iso-ascii-display 187 ">>") ; right angle quotation mark -(iso-ascii-display 188 "1/4") ; fraction one-quarter -(iso-ascii-display 189 "1/2") ; fraction one-half -(iso-ascii-display 190 "3/4") ; fraction three-quarters -(iso-ascii-display 191 "?") ; inverted question mark -(iso-ascii-display 192 "`A") ; A with grave accent -(iso-ascii-display 193 "'A") ; A with acute accent -(iso-ascii-display 194 "^A") ; A with circumflex accent -(iso-ascii-display 195 "~A") ; A with tilde -(iso-ascii-display 196 "\"A") ; A with diaeresis or umlaut mark -(iso-ascii-display 197 "AA") ; A with ring -(iso-ascii-display 198 "AE") ; AE diphthong -(iso-ascii-display 199 ",C") ; C with cedilla -(iso-ascii-display 200 "`E") ; E with grave accent -(iso-ascii-display 201 "'E") ; E with acute accent -(iso-ascii-display 202 "^E") ; E with circumflex accent -(iso-ascii-display 203 "\"E") ; E with diaeresis or umlaut mark -(iso-ascii-display 204 "`I") ; I with grave accent -(iso-ascii-display 205 "'I") ; I with acute accent -(iso-ascii-display 206 "^I") ; I with circumflex accent -(iso-ascii-display 207 "\"I") ; I with diaeresis or umlaut mark -(iso-ascii-display 208 "-D") ; D with stroke, Icelandic eth -(iso-ascii-display 209 "~N") ; N with tilde -(iso-ascii-display 210 "`O") ; O with grave accent -(iso-ascii-display 211 "'O") ; O with acute accent -(iso-ascii-display 212 "^O") ; O with circumflex accent -(iso-ascii-display 213 "~O") ; O with tilde -(iso-ascii-display 214 "\"O") ; O with diaeresis or umlaut mark -(iso-ascii-display 215 "x") ; multiplication sign -(iso-ascii-display 216 "/O") ; O with slash -(iso-ascii-display 217 "`U") ; U with grave accent -(iso-ascii-display 218 "'U") ; U with acute accent -(iso-ascii-display 219 "^U") ; U with circumflex accent -(iso-ascii-display 220 "\"U") ; U with diaeresis or umlaut mark -(iso-ascii-display 221 "'Y") ; Y with acute accent -(iso-ascii-display 222 "TH") ; capital thorn, Icelandic -(iso-ascii-display 223 "ss") ; small sharp s, German -(iso-ascii-display 224 "`a") ; a with grave accent -(iso-ascii-display 225 "'a") ; a with acute accent -(iso-ascii-display 226 "^a") ; a with circumflex accent -(iso-ascii-display 227 "~a") ; a with tilde -(iso-ascii-display 228 "\"a") ; a with diaeresis or umlaut mark -(iso-ascii-display 229 "aa") ; a with ring -(iso-ascii-display 230 "ae") ; ae diphthong -(iso-ascii-display 231 ",c") ; c with cedilla -(iso-ascii-display 232 "`e") ; e with grave accent -(iso-ascii-display 233 "'e") ; e with acute accent -(iso-ascii-display 234 "^e") ; e with circumflex accent -(iso-ascii-display 235 "\"e") ; e with diaeresis or umlaut mark -(iso-ascii-display 236 "`i") ; i with grave accent -(iso-ascii-display 237 "'i") ; i with acute accent -(iso-ascii-display 238 "^i") ; i with circumflex accent -(iso-ascii-display 239 "\"i") ; i with diaeresis or umlaut mark -(iso-ascii-display 240 "-d") ; d with stroke, Icelandic eth -(iso-ascii-display 241 "~n") ; n with tilde -(iso-ascii-display 242 "`o") ; o with grave accent -(iso-ascii-display 243 "'o") ; o with acute accent -(iso-ascii-display 244 "^o") ; o with circumflex accent -(iso-ascii-display 245 "~o") ; o with tilde -(iso-ascii-display 246 "\"o") ; o with diaeresis or umlaut mark -(iso-ascii-display 247 "/") ; division sign -(iso-ascii-display 248 "/o") ; o with slash -(iso-ascii-display 249 "`u") ; u with grave accent -(iso-ascii-display 250 "'u") ; u with acute accent -(iso-ascii-display 251 "^u") ; u with circumflex accent -(iso-ascii-display 252 "\"u") ; u with diaeresis or umlaut mark -(iso-ascii-display 253 "'y") ; y with acute accent -(iso-ascii-display 254 "th") ; small thorn, Icelandic -(iso-ascii-display 255 "\"y") ; small y with diaeresis or umlaut mark - -(provide 'iso-ascii) - -;;; iso-ascii.el ends here
--- a/lisp/iso/iso-cvt.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,719 +0,0 @@ -;;; iso-cvt.el --- translate to ISO 8859-1 from/to net/TeX conventions -;; This file was formerly called gm-lingo.el. - -;; Copyright (C) 1993, 1994 Free Software Foundation, Inc. - -;; Author: Michael Gschwind <mike@vlsivie.tuwien.ac.at> -;; Keywords: tex, iso, latin, i18n - -;; 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.34. - -;;; Commentary: - -;; This lisp code serves two purposes, both of which involve -;; the translation of various conventions for representing European -;; character sets to ISO 8859-1. - -;; Net support: -;; Various conventions exist in Newsgroups on how to represent national -;; characters. The functions provided here translate these net conventions -;; to ISO. -;; -;; Calling `iso-german' will turn the net convention for umlauts ("a etc.) -;; into ISO latin1 umlauts for easy reading. -;; 'iso-spanish' will turn net conventions for representing spanish -;; to ISO latin1. (Note that accents are omitted in news posts most -;; of the time, only enye is escaped.) - -;; TeX support -;; This mode installs hooks which change TeX files to ISO Latin-1 for -;; simplified editing. When the TeX file is saved, ISO latin1 characters are -;; translated back to escape sequences. -;; -;; An alternative is a TeX style that handles 8 bit ISO files -;; (available on ftp.vlsivie.tuwien.ac.at in /pub/8bit) -;; - but these files are difficult to transmit ... so while the net is -;; still @ 7 bit this may be useful - -;;; TO DO: -;; The net support should install hooks (like TeX support does) -;; which recognizes certain news groups and translates all articles from -;; those groups. -;; -;; Cover more cases for translation (There is an infinite number of ways to -;; represent accented characters in TeX) - -;;; SEE ALSO: -;; If you are interested in questions related to using the ISO 8859-1 -;; characters set (configuring emacs, Unix, etc. to use ISO), then you -;; can get the ISO 8859-1 FAQ via anonymous ftp from -;; ftp.vlsivie.tuwien.ac.at in /pub/bit/FAQ-ISO-8859-1 - -;;; Code: - -(provide 'iso-cvt) - -(defvar iso-spanish-trans-tab - '( - ("~n" "ñ") - ("\([a-zA-Z]\)#" "\\1ñ") - ("~N" "Ñ") - ("\\([-a-zA-Z\"`]\\)\"u" "\\1ü") - ("\\([-a-zA-Z\"`]\\)\"U" "\\1Ü") - ("\\([-a-zA-Z]\\)'o" "\\1ó") - ("\\([-a-zA-Z]\\)'O" "\\Ó") - ("\\([-a-zA-Z]\\)'e" "\\1é") - ("\\([-a-zA-Z]\\)'E" "\\1É") - ("\\([-a-zA-Z]\\)'a" "\\1á") - ("\\([-a-zA-Z]\\)'A" "\\1A") - ("\\([-a-zA-Z]\\)'i" "\\1í") - ("\\([-a-zA-Z]\\)'I" "\\1Í") - ) - "Spanish translation table.") - -(defun iso-translate-conventions (trans-tab) - "Use the translation table TRANS-TAB to translate the current buffer." - (save-excursion - (goto-char (point-min)) - (let ((work-tab trans-tab) - (buffer-read-only nil) - (case-fold-search nil)) - (while work-tab - (save-excursion - (let ((trans-this (car work-tab))) - (while (re-search-forward (car trans-this) nil t) - (replace-match (car (cdr trans-this)) t nil))) - (setq work-tab (cdr work-tab))))))) - -(defun iso-spanish () - "Translate net conventions for Spanish to ISO 8859-1." - (interactive) - (iso-translate-conventions iso-spanish-trans-tab)) - -(defvar iso-aggressive-german-trans-tab - '( - ("\"a" "ä") - ("\"A" "Ä") - ("\"o" "ö") - ("\"O" "Ö") - ("\"u" "ü") - ("\"U" "Ü") - ("\"s" "ß") - ("\\\\3" "ß") - ) - "German translation table. -This table uses an aggressive translation approach and may erroneously -translate too much.") - -(defvar iso-conservative-german-trans-tab - '( - ("\\([-a-zA-Z\"`]\\)\"a" "\\1ä") - ("\\([-a-zA-Z\"`]\\)\"A" "\\1Ä") - ("\\([-a-zA-Z\"`]\\)\"o" "\\1ö") - ("\\([-a-zA-Z\"`]\\)\"O" "\\1Ö") - ("\\([-a-zA-Z\"`]\\)\"u" "\\1ü") - ("\\([-a-zA-Z\"`]\\)\"U" "\\1Ü") - ("\\([-a-zA-Z\"`]\\)\"s" "\\1ß") - ("\\([-a-zA-Z\"`]\\)\\\\3" "\\1ß") - ) - "German translation table. -This table uses a conservative translation approach and may translate too -little.") - - -(defvar iso-german-trans-tab iso-aggressive-german-trans-tab - "Currently active translation table for German.") - -(defun iso-german () - "Translate net conventions for German to ISO 8859-1." - (interactive) - (iso-translate-conventions iso-german-trans-tab)) - -(defvar iso-iso2tex-trans-tab - '( - ("ä" "{\\\\\"a}") - ("à" "{\\\\`a}") - ("á" "{\\\\'a}") - ("ã" "{\\\\~a}") - ("â" "{\\\\^a}") - ("ë" "{\\\\\"e}") - ("è" "{\\\\`e}") - ("é" "{\\\\'e}") - ("ê" "{\\\\^e}") - ("ï" "{\\\\\"\\\\i}") - ("ì" "{\\\\`\\\\i}") - ("í" "{\\\\'\\\\i}") - ("î" "{\\\\^\\\\i}") - ("ö" "{\\\\\"o}") - ("ò" "{\\\\`o}") - ("ó" "{\\\\'o}") - ("õ" "{\\\\~o}") - ("ô" "{\\\\^o}") - ("ü" "{\\\\\"u}") - ("ù" "{\\\\`u}") - ("ú" "{\\\\'u}") - ("û" "{\\\\^u}") - ("Ä" "{\\\\\"A}") - ("À" "{\\\\`A}") - ("Á" "{\\\\'A}") - ("Ã" "{\\\\~A}") - ("Â" "{\\\\^A}") - ("Ë" "{\\\\\"E}") - ("È" "{\\\\`E}") - ("É" "{\\\\'E}") - ("Ê" "{\\\\^E}") - ("Ï" "{\\\\\"I}") - ("Ì" "{\\\\`I}") - ("Í" "{\\\\'I}") - ("Î" "{\\\\^I}") - ("Ö" "{\\\\\"O}") - ("Ò" "{\\\\`O}") - ("Ó" "{\\\\'O}") - ("Õ" "{\\\\~O}") - ("Ô" "{\\\\^O}") - ("Ü" "{\\\\\"U}") - ("Ù" "{\\\\`U}") - ("Ú" "{\\\\'U}") - ("Û" "{\\\\^U}") - ("ñ" "{\\\\~n}") - ("Ñ" "{\\\\~N}") - ("ç" "{\\\\c c}") - ("Ç" "{\\\\c C}") - ("ß" "{\\\\ss}") - ("\306" "{\\\\AE}") - ("\346" "{\\\\ae}") - ("\305" "{\\\\AA}") - ("\345" "{\\\\aa}") - ("\251" "{\\\\copyright}") - ("£" "{\\\\pounds}") - ("¶" "{\\\\P}") - ("§" "{\\\\S}") - ("¿" "{?`}") - ("¡" "{!`}") - ) - "Translation table for translating ISO 8859-1 characters to TeX sequences.") - - - - -(defun iso-iso2tex () - "Translate ISO 8859-1 characters to TeX sequences." - (interactive) - (iso-translate-conventions iso-iso2tex-trans-tab)) - - -(defvar iso-tex2iso-trans-tab - '( - ("{\\\\\"a}" "ä") - ("{\\\\`a}" "à") - ("{\\\\'a}" "á") - ("{\\\\~a}" "ã") - ("{\\\\^a}" "â") - ("{\\\\\"e}" "ë") - ("{\\\\`e}" "è") - ("{\\\\'e}" "é") - ("{\\\\^e}" "ê") - ("{\\\\\"\\\\i}" "ï") - ("{\\\\`\\\\i}" "ì") - ("{\\\\'\\\\i}" "í") - ("{\\\\^\\\\i}" "î") - ("{\\\\\"i}" "ï") - ("{\\\\`i}" "ì") - ("{\\\\'i}" "í") - ("{\\\\^i}" "î") - ("{\\\\\"o}" "ö") - ("{\\\\`o}" "ò") - ("{\\\\'o}" "ó") - ("{\\\\~o}" "õ") - ("{\\\\^o}" "ô") - ("{\\\\\"u}" "ü") - ("{\\\\`u}" "ù") - ("{\\\\'u}" "ú") - ("{\\\\^u}" "û") - ("{\\\\\"A}" "Ä") - ("{\\\\`A}" "À") - ("{\\\\'A}" "Á") - ("{\\\\~A}" "Ã") - ("{\\\\^A}" "Â") - ("{\\\\\"E}" "Ë") - ("{\\\\`E}" "È") - ("{\\\\'E}" "É") - ("{\\\\^E}" "Ê") - ("{\\\\\"I}" "Ï") - ("{\\\\`I}" "Ì") - ("{\\\\'I}" "Í") - ("{\\\\^I}" "Î") - ("{\\\\\"O}" "Ö") - ("{\\\\`O}" "Ò") - ("{\\\\'O}" "Ó") - ("{\\\\~O}" "Õ") - ("{\\\\^O}" "Ô") - ("{\\\\\"U}" "Ü") - ("{\\\\`U}" "Ù") - ("{\\\\'U}" "Ú") - ("{\\\\^U}" "Û") - ("{\\\\~n}" "ñ") - ("{\\\\~N}" "Ñ") - ("{\\\\c c}" "ç") - ("{\\\\c C}" "Ç") - ("\\\\\"a" "ä") - ("\\\\`a" "à") - ("\\\\'a" "á") - ("\\\\~a" "ã") - ("\\\\^a" "â") - ("\\\\\"e" "ë") - ("\\\\`e" "è") - ("\\\\'e" "é") - ("\\\\^e" "ê") - ("\\\\\"\\\\i" "ï") - ("\\\\`\\\\i" "ì") - ("\\\\'\\\\i" "í") - ("\\\\^\\\\i" "î") - ("\\\\\"i" "ï") - ("\\\\`i" "ì") - ("\\\\'i" "í") - ("\\\\^i" "î") - ("\\\\\"o" "ö") - ("\\\\`o" "ò") - ("\\\\'o" "ó") - ("\\\\~o" "õ") - ("\\\\^o" "ô") - ("\\\\\"u" "ü") - ("\\\\`u" "ù") - ("\\\\'u" "ú") - ("\\\\^u" "û") - ("\\\\\"A" "Ä") - ("\\\\`A" "À") - ("\\\\'A" "Á") - ("\\\\~A" "Ã") - ("\\\\^A" "Â") - ("\\\\\"E" "Ë") - ("\\\\`E" "È") - ("\\\\'E" "É") - ("\\\\^E" "Ê") - ("\\\\\"I" "Ï") - ("\\\\`I" "Ì") - ("\\\\'I" "Í") - ("\\\\^I" "Î") - ("\\\\\"O" "Ö") - ("\\\\`O" "Ò") - ("\\\\'O" "Ó") - ("\\\\~O" "Õ") - ("\\\\^O" "Ô") - ("\\\\\"U" "Ü") - ("\\\\`U" "Ù") - ("\\\\'U" "Ú") - ("\\\\^U" "Û") - ("\\\\~n" "ñ") - ("\\\\~N" "Ñ") - ("\\\\\"{a}" "ä") - ("\\\\`{a}" "à") - ("\\\\'{a}" "á") - ("\\\\~{a}" "ã") - ("\\\\^{a}" "â") - ("\\\\\"{e}" "ë") - ("\\\\`{e}" "è") - ("\\\\'{e}" "é") - ("\\\\^{e}" "ê") - ("\\\\\"{\\\\i}" "ï") - ("\\\\`{\\\\i}" "ì") - ("\\\\'{\\\\i}" "í") - ("\\\\^{\\\\i}" "î") - ("\\\\\"{i}" "ï") - ("\\\\`{i}" "ì") - ("\\\\'{i}" "í") - ("\\\\^{i}" "î") - ("\\\\\"{o}" "ö") - ("\\\\`{o}" "ò") - ("\\\\'{o}" "ó") - ("\\\\~{o}" "õ") - ("\\\\^{o}" "ô") - ("\\\\\"{u}" "ü") - ("\\\\`{u}" "ù") - ("\\\\'{u}" "ú") - ("\\\\^{u}" "û") - ("\\\\\"{A}" "Ä") - ("\\\\`{A}" "À") - ("\\\\'{A}" "Á") - ("\\\\~{A}" "Ã") - ("\\\\^{A}" "Â") - ("\\\\\"{E}" "Ë") - ("\\\\`{E}" "È") - ("\\\\'{E}" "É") - ("\\\\^{E}" "Ê") - ("\\\\\"{I}" "Ï") - ("\\\\`{I}" "Ì") - ("\\\\'{I}" "Í") - ("\\\\^{I}" "Î") - ("\\\\\"{O}" "Ö") - ("\\\\`{O}" "Ò") - ("\\\\'{O}" "Ó") - ("\\\\~{O}" "Õ") - ("\\\\^{O}" "Ô") - ("\\\\\"{U}" "Ü") - ("\\\\`{U}" "Ù") - ("\\\\'{U}" "Ú") - ("\\\\^{U}" "Û") - ("\\\\~{n}" "ñ") - ("\\\\~{N}" "Ñ") - ("\\\\c{c}" "ç") - ("\\\\c{C}" "Ç") - ("{\\\\ss}" "ß") - ("{\\\\AE}" "\306") - ("{\\\\ae}" "\346") - ("{\\\\AA}" "\305") - ("{\\\\aa}" "\345") - ("{\\\\copyright}" "\251") - ("\\\\copyright{}" "\251") - ("{\\\\pounds}" "£" ) - ("{\\\\P}" "¶" ) - ("{\\\\S}" "§" ) - ("\\\\pounds{}" "£" ) - ("\\\\P{}" "¶" ) - ("\\\\S{}" "§" ) - ("{\\?`}" "¿") - ("{!`}" "¡") - ("\\?`" "¿") - ("!`" "¡") - ) - "Translation table for translating TeX sequences to ISO 8859-1 characters. -This table is not exhaustive (and due to TeX's power can never be). It only -contains commonly used sequences.") - -(defun iso-tex2iso () - "Translate TeX sequences to ISO 8859-1 characters." - (interactive) - (iso-translate-conventions iso-tex2iso-trans-tab)) - -(defvar iso-gtex2iso-trans-tab - '( - ("{\\\\\"a}" "ä") - ("{\\\\`a}" "à") - ("{\\\\'a}" "á") - ("{\\\\~a}" "ã") - ("{\\\\^a}" "â") - ("{\\\\\"e}" "ë") - ("{\\\\`e}" "è") - ("{\\\\'e}" "é") - ("{\\\\^e}" "ê") - ("{\\\\\"\\\\i}" "ï") - ("{\\\\`\\\\i}" "ì") - ("{\\\\'\\\\i}" "í") - ("{\\\\^\\\\i}" "î") - ("{\\\\\"i}" "ï") - ("{\\\\`i}" "ì") - ("{\\\\'i}" "í") - ("{\\\\^i}" "î") - ("{\\\\\"o}" "ö") - ("{\\\\`o}" "ò") - ("{\\\\'o}" "ó") - ("{\\\\~o}" "õ") - ("{\\\\^o}" "ô") - ("{\\\\\"u}" "ü") - ("{\\\\`u}" "ù") - ("{\\\\'u}" "ú") - ("{\\\\^u}" "û") - ("{\\\\\"A}" "Ä") - ("{\\\\`A}" "À") - ("{\\\\'A}" "Á") - ("{\\\\~A}" "Ã") - ("{\\\\^A}" "Â") - ("{\\\\\"E}" "Ë") - ("{\\\\`E}" "È") - ("{\\\\'E}" "É") - ("{\\\\^E}" "Ê") - ("{\\\\\"I}" "Ï") - ("{\\\\`I}" "Ì") - ("{\\\\'I}" "Í") - ("{\\\\^I}" "Î") - ("{\\\\\"O}" "Ö") - ("{\\\\`O}" "Ò") - ("{\\\\'O}" "Ó") - ("{\\\\~O}" "Õ") - ("{\\\\^O}" "Ô") - ("{\\\\\"U}" "Ü") - ("{\\\\`U}" "Ù") - ("{\\\\'U}" "Ú") - ("{\\\\^U}" "Û") - ("{\\\\~n}" "ñ") - ("{\\\\~N}" "Ñ") - ("{\\\\c c}" "ç") - ("{\\\\c C}" "Ç") - ("\\\\\"a" "ä") - ("\\\\`a" "à") - ("\\\\'a" "á") - ("\\\\~a" "ã") - ("\\\\^a" "â") - ("\\\\\"e" "ë") - ("\\\\`e" "è") - ("\\\\'e" "é") - ("\\\\^e" "ê") - ("\\\\\"\\\\i" "ï") - ("\\\\`\\\\i" "ì") - ("\\\\'\\\\i" "í") - ("\\\\^\\\\i" "î") - ("\\\\\"i" "ï") - ("\\\\`i" "ì") - ("\\\\'i" "í") - ("\\\\^i" "î") - ("\\\\\"o" "ö") - ("\\\\`o" "ò") - ("\\\\'o" "ó") - ("\\\\~o" "õ") - ("\\\\^o" "ô") - ("\\\\\"u" "ü") - ("\\\\`u" "ù") - ("\\\\'u" "ú") - ("\\\\^u" "û") - ("\\\\\"A" "Ä") - ("\\\\`A" "À") - ("\\\\'A" "Á") - ("\\\\~A" "Ã") - ("\\\\^A" "Â") - ("\\\\\"E" "Ë") - ("\\\\`E" "È") - ("\\\\'E" "É") - ("\\\\^E" "Ê") - ("\\\\\"I" "Ï") - ("\\\\`I" "Ì") - ("\\\\'I" "Í") - ("\\\\^I" "Î") - ("\\\\\"O" "Ö") - ("\\\\`O" "Ò") - ("\\\\'O" "Ó") - ("\\\\~O" "Õ") - ("\\\\^O" "Ô") - ("\\\\\"U" "Ü") - ("\\\\`U" "Ù") - ("\\\\'U" "Ú") - ("\\\\^U" "Û") - ("\\\\~n" "ñ") - ("\\\\~N" "Ñ") - ("\\\\\"{a}" "ä") - ("\\\\`{a}" "à") - ("\\\\'{a}" "á") - ("\\\\~{a}" "ã") - ("\\\\^{a}" "â") - ("\\\\\"{e}" "ë") - ("\\\\`{e}" "è") - ("\\\\'{e}" "é") - ("\\\\^{e}" "ê") - ("\\\\\"{\\\\i}" "ï") - ("\\\\`{\\\\i}" "ì") - ("\\\\'{\\\\i}" "í") - ("\\\\^{\\\\i}" "î") - ("\\\\\"{i}" "ï") - ("\\\\`{i}" "ì") - ("\\\\'{i}" "í") - ("\\\\^{i}" "î") - ("\\\\\"{o}" "ö") - ("\\\\`{o}" "ò") - ("\\\\'{o}" "ó") - ("\\\\~{o}" "õ") - ("\\\\^{o}" "ô") - ("\\\\\"{u}" "ü") - ("\\\\`{u}" "ù") - ("\\\\'{u}" "ú") - ("\\\\^{u}" "û") - ("\\\\\"{A}" "Ä") - ("\\\\`{A}" "À") - ("\\\\'{A}" "Á") - ("\\\\~{A}" "Ã") - ("\\\\^{A}" "Â") - ("\\\\\"{E}" "Ë") - ("\\\\`{E}" "È") - ("\\\\'{E}" "É") - ("\\\\^{E}" "Ê") - ("\\\\\"{I}" "Ï") - ("\\\\`{I}" "Ì") - ("\\\\'{I}" "Í") - ("\\\\^{I}" "Î") - ("\\\\\"{O}" "Ö") - ("\\\\`{O}" "Ò") - ("\\\\'{O}" "Ó") - ("\\\\~{O}" "Õ") - ("\\\\^{O}" "Ô") - ("\\\\\"{U}" "Ü") - ("\\\\`{U}" "Ù") - ("\\\\'{U}" "Ú") - ("\\\\^{U}" "Û") - ("\\\\~{n}" "ñ") - ("\\\\~{N}" "Ñ") - ("\\\\c{c}" "ç") - ("\\\\c{C}" "Ç") - ("{\\\\ss}" "ß") - ("{\\\\AE}" "\306") - ("{\\\\ae}" "\346") - ("{\\\\AA}" "\305") - ("{\\\\aa}" "\345") - ("{\\\\copyright}" "\251") - ("\\\\copyright{}" "\251") - ("{\\\\pounds}" "£" ) - ("{\\\\P}" "¶" ) - ("{\\\\S}" "§" ) - ("\\\\pounds{}" "£" ) - ("\\\\P{}" "¶" ) - ("\\\\S{}" "§" ) - ("?`" "¿") - ("!`" "¡") - ("{?`}" "¿") - ("{!`}" "¡") - ("\"a" "ä") - ("\"A" "Ä") - ("\"o" "ö") - ("\"O" "Ö") - ("\"u" "ü") - ("\"U" "Ü") - ("\"s" "ß") - ("\\\\3" "ß") - ) - "Translation table for translating German TeX sequences to ISO 8859-1. -This table is not exhaustive (and due to TeX's power can never be). It only -contains commonly used sequences.") - -(defvar iso-iso2gtex-trans-tab - '( - ("ä" "\"a") - ("à" "{\\\\`a}") - ("á" "{\\\\'a}") - ("ã" "{\\\\~a}") - ("â" "{\\\\^a}") - ("ë" "{\\\\\"e}") - ("è" "{\\\\`e}") - ("é" "{\\\\'e}") - ("ê" "{\\\\^e}") - ("ï" "{\\\\\"\\\\i}") - ("ì" "{\\\\`\\\\i}") - ("í" "{\\\\'\\\\i}") - ("î" "{\\\\^\\\\i}") - ("ö" "\"o") - ("ò" "{\\\\`o}") - ("ó" "{\\\\'o}") - ("õ" "{\\\\~o}") - ("ô" "{\\\\^o}") - ("ü" "\"u") - ("ù" "{\\\\`u}") - ("ú" "{\\\\'u}") - ("û" "{\\\\^u}") - ("Ä" "\"A") - ("À" "{\\\\`A}") - ("Á" "{\\\\'A}") - ("Ã" "{\\\\~A}") - ("Â" "{\\\\^A}") - ("Ë" "{\\\\\"E}") - ("È" "{\\\\`E}") - ("É" "{\\\\'E}") - ("Ê" "{\\\\^E}") - ("Ï" "{\\\\\"I}") - ("Ì" "{\\\\`I}") - ("Í" "{\\\\'I}") - ("Î" "{\\\\^I}") - ("Ö" "\"O") - ("Ò" "{\\\\`O}") - ("Ó" "{\\\\'O}") - ("Õ" "{\\\\~O}") - ("Ô" "{\\\\^O}") - ("Ü" "\"U") - ("Ù" "{\\\\`U}") - ("Ú" "{\\\\'U}") - ("Û" "{\\\\^U}") - ("ñ" "{\\\\~n}") - ("Ñ" "{\\\\~N}") - ("ç" "{\\\\c c}") - ("Ç" "{\\\\c C}") - ("ß" "\"s") - ("\306" "{\\\\AE}") - ("\346" "{\\\\ae}") - ("\305" "{\\\\AA}") - ("\345" "{\\\\aa}") - ("\251" "{\\\\copyright}") - ("£" "{\\\\pounds}") - ("¶" "{\\\\P}") - ("§" "{\\\\S}") - ("¿" "{?`}") - ("¡" "{!`}") - ) - "Translation table for translating ISO 8859-1 characters to German TeX.") - -(defun iso-gtex2iso () - "Translate German TeX sequences to ISO 8859-1 characters." - (interactive) - (iso-translate-conventions iso-gtex2iso-trans-tab)) - - -(defun iso-iso2gtex () - "Translate ISO 8859-1 characters to German TeX sequences." - (interactive) - (iso-translate-conventions iso-iso2gtex-trans-tab)) - - -(defun iso-german-tex-p () - "Check if tex buffer is German LaTeX." - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (re-search-forward "\\\\documentstyle\\[.*german.*\\]" nil t)))) - -(defun iso-fix-iso2tex () - "Turn ISO 8859-1 (aka. ISO Latin-1) buffer into TeX sequences. -If German TeX is used, German TeX sequences are generated." - (if (or (equal major-mode 'latex-mode) - (equal major-mode 'LaTeX-mode)) ; AucTeX wants this - (if (iso-german-tex-p) - (iso-iso2gtex) - (iso-iso2tex))) - (if (or (equal major-mode 'tex-mode) - (equal major-mode 'TeX-mode) ; AucTeX wants this - (equal major-mode 'plain-tex-mode)) - (iso-iso2tex))) - -(defun iso-fix-tex2iso () - "Turn TeX sequences into ISO 8859-1 (aka. ISO Latin-1) characters. -This function recognizes German TeX buffers." - (if (or (equal major-mode 'latex-mode) - (equal major-mode 'Latex-mode)) ; AucTeX wants this - (if (iso-german-tex-p) - (iso-gtex2iso) - (iso-tex2iso))) - (if (or (equal major-mode 'tex-mode) - (equal major-mode 'TeX-mode) ; AucTeX wants this - (equal major-mode 'plain-tex-mode)) - (iso-tex2iso))) - -(defun iso-cvt-ffh () - "find-file-hook for iso-cvt.el." - (iso-fix-tex2iso) - (set-buffer-modified-p nil)) - -(defun iso-cvt-wfh () - "write file hook for iso-cvt.el." - (iso-fix-iso2tex)) - -(defun iso-cvt-ash () - "after save hook for iso-cvt.el." - (iso-fix-tex2iso) - (set-buffer-modified-p nil)) - -(add-hook 'find-file-hooks 'iso-cvt-ffh) -(add-hook 'write-file-hooks 'iso-cvt-wfh) -(add-hook 'after-save-hook 'iso-cvt-ash) - -;;; iso-cvt.el ends here
--- a/lisp/iso/iso-insert.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,634 +0,0 @@ -;;; iso-insert.el --- insert functions for ISO 8859/1. - -;; Copyright (C) 1987, 1994 Free Software Foundation, Inc. - -;; Author: Howard Gayle -;; Maintainer: FSF -;; Keywords: i18n - -;; 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.34. - -;;; Commentary: - -;; Written by Howard Gayle. See case-table.el for details. - -;;; #### I think there may be some functionality overlap between this file -;;; and x-compose.el. Should think about integrating. - -;;; Code: - -(defun insert-no-break-space () - (interactive "*") - (insert 160) -) - -(defun insert-inverted-exclamation-mark () - (interactive "*") - (insert 161) -) - -(defun insert-cent-sign () - (interactive "*") - (insert 162) -) - -(defun insert-pound-sign () - (interactive "*") - (insert 163) -) - -(defun insert-general-currency-sign () - (interactive "*") - (insert 164) -) - -(defun insert-yen-sign () - (interactive "*") - (insert 165) -) - -(defun insert-broken-vertical-line () - (interactive "*") - (insert 166) -) - -(defun insert-section-sign () - (interactive "*") - (insert 167) -) - -(defun insert-diaeresis () - (interactive "*") - (insert 168) -) - -(defun insert-copyright-sign () - (interactive "*") - (insert 169) -) - -(defun insert-ordinal-indicator-feminine () - (interactive "*") - (insert 170) -) - -(defun insert-angle-quotation-mark-left () - (interactive "*") - (insert 171) -) - -(defun insert-not-sign () - (interactive "*") - (insert 172) -) - -(defun insert-soft-hyphen () - (interactive "*") - (insert 173) -) - -(defun insert-registered-sign () - (interactive "*") - (insert 174) -) - -(defun insert-macron () - (interactive "*") - (insert 175) -) - -(defun insert-degree-sign () - (interactive "*") - (insert 176) -) - -(defun insert-plus-or-minus-sign () - (interactive "*") - (insert 177) -) - -(defun insert-superscript-two () - (interactive "*") - (insert 178) -) - -(defun insert-superscript-three () - (interactive "*") - (insert 179) -) - -(defun insert-acute-accent () - (interactive "*") - (insert 180) -) - -(defun insert-micro-sign () - (interactive "*") - (insert 181) -) - -(defun insert-pilcrow () - (interactive "*") - (insert 182) -) - -(defun insert-middle-dot () - (interactive "*") - (insert 183) -) - -(defun insert-cedilla () - (interactive "*") - (insert 184) -) - -(defun insert-superscript-one () - (interactive "*") - (insert 185) -) - -(defun insert-ordinal-indicator-masculine () - (interactive "*") - (insert 186) -) - -(defun insert-angle-quotation-mark-right () - (interactive "*") - (insert 187) -) - -(defun insert-fraction-one-quarter () - (interactive "*") - (insert 188) -) - -(defun insert-fraction-one-half () - (interactive "*") - (insert 189) -) - -(defun insert-fraction-three-quarters () - (interactive "*") - (insert 190) -) - -(defun insert-inverted-question-mark () - (interactive "*") - (insert 191) -) - -(defun insert-A-grave () - (interactive "*") - (insert 192) -) - -(defun insert-A-acute () - (interactive "*") - (insert 193) -) - -(defun insert-A-circumflex () - (interactive "*") - (insert 194) -) - -(defun insert-A-tilde () - (interactive "*") - (insert 195) -) - -(defun insert-A-umlaut () - (interactive "*") - (insert 196) -) - -(defun insert-A-ring () - (interactive "*") - (insert 197) -) - -(defun insert-AE () - (interactive "*") - (insert 198) -) - -(defun insert-C-cedilla () - (interactive "*") - (insert 199) -) - -(defun insert-E-grave () - (interactive "*") - (insert 200) -) - -(defun insert-E-acute () - (interactive "*") - (insert 201) -) - -(defun insert-E-circumflex () - (interactive "*") - (insert 202) -) - -(defun insert-E-umlaut () - (interactive "*") - (insert 203) -) - -(defun insert-I-grave () - (interactive "*") - (insert 204) -) - -(defun insert-I-acute () - (interactive "*") - (insert 205) -) - -(defun insert-I-circumflex () - (interactive "*") - (insert 206) -) - -(defun insert-I-umlaut () - (interactive "*") - (insert 207) -) - -(defun insert-D-stroke () - (interactive "*") - (insert 208) -) - -(defun insert-N-tilde () - (interactive "*") - (insert 209) -) - -(defun insert-O-grave () - (interactive "*") - (insert 210) -) - -(defun insert-O-acute () - (interactive "*") - (insert 211) -) - -(defun insert-O-circumflex () - (interactive "*") - (insert 212) -) - -(defun insert-O-tilde () - (interactive "*") - (insert 213) -) - -(defun insert-O-umlaut () - (interactive "*") - (insert 214) -) - -(defun insert-multiplication-sign () - (interactive "*") - (insert 215) -) - -(defun insert-O-slash () - (interactive "*") - (insert 216) -) - -(defun insert-U-grave () - (interactive "*") - (insert 217) -) - -(defun insert-U-acute () - (interactive "*") - (insert 218) -) - -(defun insert-U-circumflex () - (interactive "*") - (insert 219) -) - -(defun insert-U-umlaut () - (interactive "*") - (insert 220) -) - -(defun insert-Y-acute () - (interactive "*") - (insert 221) -) - -(defun insert-THORN () - (interactive "*") - (insert 222) -) - -(defun insert-ss () - (interactive "*") - (insert 223) -) - -(defun insert-a-grave () - (interactive "*") - (insert 224) -) - -(defun insert-a-acute () - (interactive "*") - (insert 225) -) - -(defun insert-a-circumflex () - (interactive "*") - (insert 226) -) - -(defun insert-a-tilde () - (interactive "*") - (insert 227) -) - -(defun insert-a-umlaut () - (interactive "*") - (insert 228) -) - -(defun insert-a-ring () - (interactive "*") - (insert 229) -) - -(defun insert-ae () - (interactive "*") - (insert 230) -) - -(defun insert-c-cedilla () - (interactive "*") - (insert 231) -) - -(defun insert-e-grave () - (interactive "*") - (insert 232) -) - -(defun insert-e-acute () - (interactive "*") - (insert 233) -) - -(defun insert-e-circumflex () - (interactive "*") - (insert 234) -) - -(defun insert-e-umlaut () - (interactive "*") - (insert 235) -) - -(defun insert-i-grave () - (interactive "*") - (insert 236) -) - -(defun insert-i-acute () - (interactive "*") - (insert 237) -) - -(defun insert-i-circumflex () - (interactive "*") - (insert 238) -) - -(defun insert-i-umlaut () - (interactive "*") - (insert 239) -) - -(defun insert-d-stroke () - (interactive "*") - (insert 240) -) - -(defun insert-n-tilde () - (interactive "*") - (insert 241) -) - -(defun insert-o-grave () - (interactive "*") - (insert 242) -) - -(defun insert-o-acute () - (interactive "*") - (insert 243) -) - -(defun insert-o-circumflex () - (interactive "*") - (insert 244) -) - -(defun insert-o-tilde () - (interactive "*") - (insert 245) -) - -(defun insert-o-umlaut () - (interactive "*") - (insert 246) -) - -(defun insert-division-sign () - (interactive "*") - (insert 247) -) - -(defun insert-o-slash () - (interactive "*") - (insert 248) -) - -(defun insert-u-grave () - (interactive "*") - (insert 249) -) - -(defun insert-u-acute () - (interactive "*") - (insert 250) -) - -(defun insert-u-circumflex () - (interactive "*") - (insert 251) -) - -(defun insert-u-umlaut () - (interactive "*") - (insert 252) -) - -(defun insert-y-acute () - (interactive "*") - (insert 253) -) - -(defun insert-thorn () - (interactive "*") - (insert 254) -) - -(defun insert-y-umlaut () - (interactive "*") - (insert 255) -) - -(defvar 8859-1-map nil "Keymap for ISO 8859/1 character insertion.") -(if 8859-1-map nil - (setq 8859-1-map (make-keymap)) - (define-key 8859-1-map " " 'insert-no-break-space) - (define-key 8859-1-map "!" 'insert-inverted-exclamation-mark) - (define-key 8859-1-map "\"" (make-sparse-keymap)) - (define-key 8859-1-map "\"\"" 'insert-diaeresis) - (define-key 8859-1-map "\"A" 'insert-A-umlaut) - (define-key 8859-1-map "\"E" 'insert-E-umlaut) - (define-key 8859-1-map "\"I" 'insert-I-umlaut) - (define-key 8859-1-map "\"O" 'insert-O-umlaut) - (define-key 8859-1-map "\"U" 'insert-U-umlaut) - (define-key 8859-1-map "\"a" 'insert-a-umlaut) - (define-key 8859-1-map "\"e" 'insert-e-umlaut) - (define-key 8859-1-map "\"i" 'insert-i-umlaut) - (define-key 8859-1-map "\"o" 'insert-o-umlaut) - (define-key 8859-1-map "\"u" 'insert-u-umlaut) - (define-key 8859-1-map "\"y" 'insert-y-umlaut) - (define-key 8859-1-map "'" (make-sparse-keymap)) - (define-key 8859-1-map "''" 'insert-acute-accent) - (define-key 8859-1-map "'A" 'insert-A-acute) - (define-key 8859-1-map "'E" 'insert-E-acute) - (define-key 8859-1-map "'I" 'insert-I-acute) - (define-key 8859-1-map "'O" 'insert-O-acute) - (define-key 8859-1-map "'U" 'insert-U-acute) - (define-key 8859-1-map "'Y" 'insert-Y-acute) - (define-key 8859-1-map "'a" 'insert-a-acute) - (define-key 8859-1-map "'e" 'insert-e-acute) - (define-key 8859-1-map "'i" 'insert-i-acute) - (define-key 8859-1-map "'o" 'insert-o-acute) - (define-key 8859-1-map "'u" 'insert-u-acute) - (define-key 8859-1-map "'y" 'insert-y-acute) - (define-key 8859-1-map "$" 'insert-general-currency-sign) - (define-key 8859-1-map "+" 'insert-plus-or-minus-sign) - (define-key 8859-1-map "," (make-sparse-keymap)) - (define-key 8859-1-map ",," 'insert-cedilla) - (define-key 8859-1-map ",C" 'insert-C-cedilla) - (define-key 8859-1-map ",c" 'insert-c-cedilla) - (define-key 8859-1-map "-" 'insert-soft-hyphen) - (define-key 8859-1-map "." 'insert-middle-dot) - (define-key 8859-1-map "/" (make-sparse-keymap)) - (define-key 8859-1-map "//" 'insert-division-sign) - (define-key 8859-1-map "/O" 'insert-O-slash) - (define-key 8859-1-map "/o" 'insert-o-slash) - (define-key 8859-1-map "1" (make-sparse-keymap)) - (define-key 8859-1-map "1/" (make-sparse-keymap)) - (define-key 8859-1-map "1/2" 'insert-fraction-one-half) - (define-key 8859-1-map "1/4" 'insert-fraction-one-quarter) - (define-key 8859-1-map "3" (make-sparse-keymap)) - (define-key 8859-1-map "3/" (make-sparse-keymap)) - (define-key 8859-1-map "3/4" 'insert-fraction-three-quarters) - (define-key 8859-1-map "<" 'insert-angle-quotation-mark-left) - (define-key 8859-1-map "=" 'insert-macron) - (define-key 8859-1-map ">" 'insert-angle-quotation-mark-right) - (define-key 8859-1-map "?" 'insert-inverted-question-mark) - (define-key 8859-1-map "A" 'insert-A-ring) - (define-key 8859-1-map "E" 'insert-AE) - (define-key 8859-1-map "C" 'insert-copyright-sign) - (define-key 8859-1-map "D" 'insert-D-stroke) - (define-key 8859-1-map "L" 'insert-pound-sign) - (define-key 8859-1-map "P" 'insert-pilcrow) - (define-key 8859-1-map "R" 'insert-registered-sign) - (define-key 8859-1-map "S" 'insert-section-sign) - (define-key 8859-1-map "T" 'insert-THORN) - (define-key 8859-1-map "Y" 'insert-yen-sign) - (define-key 8859-1-map "^" (make-sparse-keymap)) - (define-key 8859-1-map "^1" 'insert-superscript-one) - (define-key 8859-1-map "^2" 'insert-superscript-two) - (define-key 8859-1-map "^3" 'insert-superscript-three) - (define-key 8859-1-map "^A" 'insert-A-circumflex) - (define-key 8859-1-map "^E" 'insert-E-circumflex) - (define-key 8859-1-map "^I" 'insert-I-circumflex) - (define-key 8859-1-map "^O" 'insert-O-circumflex) - (define-key 8859-1-map "^U" 'insert-U-circumflex) - (define-key 8859-1-map "^a" 'insert-a-circumflex) - (define-key 8859-1-map "^e" 'insert-e-circumflex) - (define-key 8859-1-map "^i" 'insert-i-circumflex) - (define-key 8859-1-map "^o" 'insert-o-circumflex) - (define-key 8859-1-map "^u" 'insert-u-circumflex) - (define-key 8859-1-map "_" (make-sparse-keymap)) - (define-key 8859-1-map "_a" 'insert-ordinal-indicator-feminine) - (define-key 8859-1-map "_o" 'insert-ordinal-indicator-masculine) - (define-key 8859-1-map "`" (make-sparse-keymap)) - (define-key 8859-1-map "`A" 'insert-A-grave) - (define-key 8859-1-map "`E" 'insert-E-grave) - (define-key 8859-1-map "`I" 'insert-I-grave) - (define-key 8859-1-map "`O" 'insert-O-grave) - (define-key 8859-1-map "`U" 'insert-U-grave) - (define-key 8859-1-map "`a" 'insert-a-grave) - (define-key 8859-1-map "`e" 'insert-e-grave) - (define-key 8859-1-map "`i" 'insert-i-grave) - (define-key 8859-1-map "`o" 'insert-o-grave) - (define-key 8859-1-map "`u" 'insert-u-grave) - (define-key 8859-1-map "a" 'insert-a-ring) - (define-key 8859-1-map "e" 'insert-ae) - (define-key 8859-1-map "c" 'insert-cent-sign) - (define-key 8859-1-map "d" 'insert-d-stroke) - (define-key 8859-1-map "o" 'insert-degree-sign) - (define-key 8859-1-map "s" 'insert-ss) - (define-key 8859-1-map "t" 'insert-thorn) - (define-key 8859-1-map "u" 'insert-micro-sign) - (define-key 8859-1-map "x" 'insert-multiplication-sign) - (define-key 8859-1-map "|" 'insert-broken-vertical-line) - (define-key 8859-1-map "~" (make-sparse-keymap)) - (define-key 8859-1-map "~A" 'insert-A-tilde) - (define-key 8859-1-map "~N" 'insert-N-tilde) - (define-key 8859-1-map "~O" 'insert-O-tilde) - (define-key 8859-1-map "~a" 'insert-a-tilde) - (define-key 8859-1-map "~n" 'insert-n-tilde) - (define-key 8859-1-map "~o" 'insert-o-tilde) - (define-key 8859-1-map "~~" 'insert-not-sign) - (if (not (lookup-key global-map "\C-x8")) - (define-key global-map "\C-x8" 8859-1-map)) -) - -(provide 'iso-insert) - -;;; iso-insert.el ends here
--- a/lisp/iso/iso-swed.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,153 +0,0 @@ -;;; iso-swed.el --- set up char tables for ISO 8859/1 for Swedish/Finnish ttys - -;; Copyright (C) 1987 Free Software Foundation, Inc. - -;; Author: Howard Gayle -;; Maintainer: FSF -;; Keywords: i18n - -;; 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.34. - -;;; Commentary: - -;; Written by Howard Gayle. See case-table.el for details. - -;;; Code: - -;; This code sets up to display ISO 8859/1 characters on -;; terminals that have ASCII in the G0 set and a Swedish/Finnish -;; version of ISO 646 in the G1 set. The G1 set differs from -;; ASCII as follows: -;; -;; ASCII G1 -;; $ general currency sign -;; @ capital E with acute accent -;; [ capital A with diaeresis or umlaut mark -;; \ capital O with diaeresis or umlaut mark -;; ] capital A with ring -;; ^ capital U with diaeresis or umlaut mark -;; ` small e with acute accent -;; { small a with diaeresis or umlaut mark -;; | small o with diaeresis or umlaut mark -;; } small a with ring -;; ~ small u with diaeresis or umlaut mark - -(require 'disp-table) - -(standard-display-ascii 160 "{_}") ; NBSP (no-break space) -(standard-display-ascii 161 "{!}") ; inverted exclamation mark -(standard-display-ascii 162 "{c}") ; cent sign -(standard-display-ascii 163 "{GBP}") ; pound sign -(standard-display-g1 164 ?$) ; general currency sign -(standard-display-ascii 165 "{JPY}") ; yen sign -(standard-display-ascii 166 "{|}") ; broken vertical line -(standard-display-ascii 167 "{S}") ; section sign -(standard-display-ascii 168 "{\"}") ; diaeresis -(standard-display-ascii 169 "{C}") ; copyright sign -(standard-display-ascii 170 "{_a}") ; ordinal indicator, feminine -(standard-display-ascii 171 "{<<}") ; left angle quotation mark -(standard-display-ascii 172 "{~}") ; not sign -(standard-display-ascii 173 "{-}") ; soft hyphen -(standard-display-ascii 174 "{R}") ; registered sign -(standard-display-ascii 175 "{=}") ; macron -(standard-display-ascii 176 "{o}") ; degree sign -(standard-display-ascii 177 "{+-}") ; plus or minus sign -(standard-display-ascii 178 "{2}") ; superscript two -(standard-display-ascii 179 "{3}") ; superscript three -(standard-display-ascii 180 "{'}") ; acute accent -(standard-display-ascii 181 "{u}") ; micro sign -(standard-display-ascii 182 "{P}") ; pilcrow -(standard-display-ascii 183 "{.}") ; middle dot -(standard-display-ascii 184 "{,}") ; cedilla -(standard-display-ascii 185 "{1}") ; superscript one -(standard-display-ascii 186 "{_o}") ; ordinal indicator, masculine -(standard-display-ascii 187 "{>>}") ; right angle quotation mark -(standard-display-ascii 188 "{1/4}") ; fraction one-quarter -(standard-display-ascii 189 "{1/2}") ; fraction one-half -(standard-display-ascii 190 "{3/4}") ; fraction three-quarters -(standard-display-ascii 191 "{?}") ; inverted question mark -(standard-display-ascii 192 "{`A}") ; A with grave accent -(standard-display-ascii 193 "{'A}") ; A with acute accent -(standard-display-ascii 194 "{^A}") ; A with circumflex accent -(standard-display-ascii 195 "{~A}") ; A with tilde -(standard-display-g1 196 ?[) ; A with diaeresis or umlaut mark -(standard-display-g1 197 ?]) ; A with ring -(standard-display-ascii 198 "{AE}") ; AE diphthong -(standard-display-ascii 199 "{,C}") ; C with cedilla -(standard-display-ascii 200 "{`E}") ; E with grave accent -(standard-display-g1 201 ?@) ; E with acute accent -(standard-display-ascii 202 "{^E}") ; E with circumflex accent -(standard-display-ascii 203 "{\"E}") ; E with diaeresis or umlaut mark -(standard-display-ascii 204 "{`I}") ; I with grave accent -(standard-display-ascii 205 "{'I}") ; I with acute accent -(standard-display-ascii 206 "{^I}") ; I with circumflex accent -(standard-display-ascii 207 "{\"I}") ; I with diaeresis or umlaut mark -(standard-display-ascii 208 "{-D}") ; D with stroke, Icelandic eth -(standard-display-ascii 209 "{~N}") ; N with tilde -(standard-display-ascii 210 "{`O}") ; O with grave accent -(standard-display-ascii 211 "{'O}") ; O with acute accent -(standard-display-ascii 212 "{^O}") ; O with circumflex accent -(standard-display-ascii 213 "{~O}") ; O with tilde -(standard-display-g1 214 ?\\) ; O with diaeresis or umlaut mark -(standard-display-ascii 215 "{x}") ; multiplication sign -(standard-display-ascii 216 "{/O}") ; O with slash -(standard-display-ascii 217 "{`U}") ; U with grave accent -(standard-display-ascii 218 "{'U}") ; U with acute accent -(standard-display-ascii 219 "{^U}") ; U with circumflex accent -(standard-display-g1 220 ?^) ; U with diaeresis or umlaut mark -(standard-display-ascii 221 "{'Y}") ; Y with acute accent -(standard-display-ascii 222 "{TH}") ; capital thorn, Icelandic -(standard-display-ascii 223 "{ss}") ; small sharp s, German -(standard-display-ascii 224 "{`a}") ; a with grave accent -(standard-display-ascii 225 "{'a}") ; a with acute accent -(standard-display-ascii 226 "{^a}") ; a with circumflex accent -(standard-display-ascii 227 "{~a}") ; a with tilde -(standard-display-g1 228 ?{) ; a with diaeresis or umlaut mark -(standard-display-g1 229 ?}) ; a with ring -(standard-display-ascii 230 "{ae}") ; ae diphthong -(standard-display-ascii 231 "{,c}") ; c with cedilla -(standard-display-ascii 232 "{`e}") ; e with grave accent -(standard-display-g1 233 ?`) ; e with acute accent -(standard-display-ascii 234 "{^e}") ; e with circumflex accent -(standard-display-ascii 235 "{\"e}") ; e with diaeresis or umlaut mark -(standard-display-ascii 236 "{`i}") ; i with grave accent -(standard-display-ascii 237 "{'i}") ; i with acute accent -(standard-display-ascii 238 "{^i}") ; i with circumflex accent -(standard-display-ascii 239 "{\"i}") ; i with diaeresis or umlaut mark -(standard-display-ascii 240 "{-d}") ; d with stroke, Icelandic eth -(standard-display-ascii 241 "{~n}") ; n with tilde -(standard-display-ascii 242 "{`o}") ; o with grave accent -(standard-display-ascii 243 "{'o}") ; o with acute accent -(standard-display-ascii 244 "{^o}") ; o with circumflex accent -(standard-display-ascii 245 "{~o}") ; o with tilde -(standard-display-g1 246 ?|) ; o with diaeresis or umlaut mark -(standard-display-ascii 247 "{/}") ; division sign -(standard-display-ascii 248 "{/o}") ; o with slash -(standard-display-ascii 249 "{`u}") ; u with grave accent -(standard-display-ascii 250 "{'u}") ; u with acute accent -(standard-display-ascii 251 "{^u}") ; u with circumflex accent -(standard-display-g1 252 ?~) ; u with diaeresis or umlaut mark -(standard-display-ascii 253 "{'y}") ; y with acute accent -(standard-display-ascii 254 "{th}") ; small thorn, Icelandic -(standard-display-ascii 255 "{\"y}") ; small y with diaeresis or umlaut mark - -(provide 'iso-swed) - -;;; iso-swed.el ends here
--- a/lisp/iso/iso-syntax.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,108 +0,0 @@ -;;; iso-syntax.el --- set up case-conversion and syntax tables for ISO 8859/1 - -;; Copyright (C) 1988 Free Software Foundation, Inc. - -;; Author: Howard Gayle -;; Maintainer: FSF -;; Keywords: i18n - -;; 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.34. - -;;; Commentary: - -;; Written by Howard Gayle. See case-table.el for details. - -;;; Code: - -(require 'case-table) - -(let ((downcase (standard-case-table))) - (set-case-syntax 160 " " downcase) ; NBSP (no-break space) - (set-case-syntax 161 "." downcase) ; inverted exclamation mark - (set-case-syntax 162 "w" downcase) ; cent sign - (set-case-syntax 163 "w" downcase) ; pound sign - (set-case-syntax 164 "w" downcase) ; general currency sign - (set-case-syntax 165 "w" downcase) ; yen sign - (set-case-syntax 166 "_" downcase) ; broken vertical line - (set-case-syntax 167 "w" downcase) ; section sign - (set-case-syntax 168 "w" downcase) ; diaeresis - (set-case-syntax 169 "_" downcase) ; copyright sign - (set-case-syntax 170 "w" downcase) ; ordinal indicator, feminine - (set-case-syntax-delims 171 187 downcase) ; angle quotation marks - (set-case-syntax 172 "_" downcase) ; not sign - (set-case-syntax 173 "_" downcase) ; soft hyphen - (set-case-syntax 174 "_" downcase) ; registered sign - (set-case-syntax 175 "w" downcase) ; macron - (set-case-syntax 176 "_" downcase) ; degree sign - (set-case-syntax 177 "_" downcase) ; plus or minus sign - (set-case-syntax 178 "w" downcase) ; superscript two - (set-case-syntax 179 "w" downcase) ; superscript three - (set-case-syntax 180 "w" downcase) ; acute accent - (set-case-syntax 181 "_" downcase) ; micro sign - (set-case-syntax 182 "w" downcase) ; pilcrow - (set-case-syntax 183 "_" downcase) ; middle dot - (set-case-syntax 184 "w" downcase) ; cedilla - (set-case-syntax 185 "w" downcase) ; superscript one - (set-case-syntax 186 "w" downcase) ; ordinal indicator, masculine - ;; 187 ; See 171 above. - (set-case-syntax 188 "_" downcase) ; fraction one-quarter - (set-case-syntax 189 "_" downcase) ; fraction one-half - (set-case-syntax 190 "_" downcase) ; fraction three-quarters - (set-case-syntax 191 "." downcase) ; inverted question mark - (set-case-syntax-pair 192 224 downcase) ; A with grave accent - (set-case-syntax-pair 193 225 downcase) ; A with acute accent - (set-case-syntax-pair 194 226 downcase) ; A with circumflex accent - (set-case-syntax-pair 195 227 downcase) ; A with tilde - (set-case-syntax-pair 196 228 downcase) ; A with diaeresis or umlaut mark - (set-case-syntax-pair 197 229 downcase) ; A with ring - (set-case-syntax-pair 198 230 downcase) ; AE diphthong - (set-case-syntax-pair 199 231 downcase) ; C with cedilla - (set-case-syntax-pair 200 232 downcase) ; E with grave accent - (set-case-syntax-pair 201 233 downcase) ; E with acute accent - (set-case-syntax-pair 202 234 downcase) ; E with circumflex accent - (set-case-syntax-pair 203 235 downcase) ; E with diaeresis or umlaut mark - (set-case-syntax-pair 204 236 downcase) ; I with grave accent - (set-case-syntax-pair 205 237 downcase) ; I with acute accent - (set-case-syntax-pair 206 238 downcase) ; I with circumflex accent - (set-case-syntax-pair 207 239 downcase) ; I with diaeresis or umlaut mark - (set-case-syntax-pair 208 240 downcase) ; D with stroke, Icelandic eth - (set-case-syntax-pair 209 241 downcase) ; N with tilde - (set-case-syntax-pair 210 242 downcase) ; O with grave accent - (set-case-syntax-pair 211 243 downcase) ; O with acute accent - (set-case-syntax-pair 212 244 downcase) ; O with circumflex accent - (set-case-syntax-pair 213 245 downcase) ; O with tilde - (set-case-syntax-pair 214 246 downcase) ; O with diaeresis or umlaut mark - (set-case-syntax 215 "_" downcase) ; multiplication sign - (set-case-syntax-pair 216 248 downcase) ; O with slash - (set-case-syntax-pair 217 249 downcase) ; U with grave accent - (set-case-syntax-pair 218 250 downcase) ; U with acute accent - (set-case-syntax-pair 219 251 downcase) ; U with circumflex accent - (set-case-syntax-pair 220 252 downcase) ; U with diaeresis or umlaut mark - (set-case-syntax-pair 221 253 downcase) ; Y with acute accent - (set-case-syntax-pair 222 254 downcase) ; thorn, Icelandic - (set-case-syntax 223 "w" downcase) ; small sharp s, German - (set-case-syntax 247 "_" downcase) ; division sign - (set-case-syntax 255 "w" downcase) ; small y with diaeresis or umlaut mark - (set-standard-case-table downcase) -) - -(provide 'iso-syntax) - -;;; iso-syntax.el ends here
--- a/lisp/iso/iso8859-1.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,190 +0,0 @@ -;; Sets the case and syntax tables for the ISO-8859/1 character set. -;; Copyright (C) 1992 Free Software Foundation, Inc. - -;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -;; created by jwz, 19-aug-92. - -(let ((table (standard-syntax-table))) - ;; - ;; The symbol characters - ;; - (modify-syntax-entry ?\240 "_" table) ; nobreakspace - (modify-syntax-entry ?\241 "." table) ; exclamdown - (modify-syntax-entry ?\242 "_" table) ; cent - (modify-syntax-entry ?\243 "_" table) ; sterling - (modify-syntax-entry ?\244 "_" table) ; currency - (modify-syntax-entry ?\245 "_" table) ; yen - (modify-syntax-entry ?\246 "_" table) ; brokenbar - (modify-syntax-entry ?\247 "_" table) ; section - (modify-syntax-entry ?\250 "_" table) ; diaeresis - (modify-syntax-entry ?\251 "_" table) ; copyright - (modify-syntax-entry ?\252 "_" table) ; ordfeminine - (modify-syntax-entry ?\253 "(\273" table) ; guillemotleft - (modify-syntax-entry ?\254 "_" table) ; notsign - (modify-syntax-entry ?\255 "_" table) ; hyphen - (modify-syntax-entry ?\256 "_" table) ; registered - (modify-syntax-entry ?\257 "_" table) ; macron - (modify-syntax-entry ?\260 "_" table) ; degree - (modify-syntax-entry ?\261 "_" table) ; plusminus - (modify-syntax-entry ?\262 "_" table) ; twosuperior - (modify-syntax-entry ?\263 "_" table) ; threesuperior - (modify-syntax-entry ?\264 "_" table) ; acute - (modify-syntax-entry ?\265 "_" table) ; mu - (modify-syntax-entry ?\266 "_" table) ; paragraph - (modify-syntax-entry ?\267 "_" table) ; periodcentered - (modify-syntax-entry ?\270 "_" table) ; cedilla - (modify-syntax-entry ?\271 "_" table) ; onesuperior - (modify-syntax-entry ?\272 "_" table) ; masculine - (modify-syntax-entry ?\273 ")\253" table) ; guillemotright - (modify-syntax-entry ?\274 "_" table) ; onequarter - (modify-syntax-entry ?\275 "_" table) ; onehalf - (modify-syntax-entry ?\276 "_" table) ; threequarters - (modify-syntax-entry ?\277 "_" table) ; questiondown - ;; - ;; the upper-case characters (plus "multiply" and "ssharp") - ;; - (modify-syntax-entry ?\300 "w" table) ; Agrave - (modify-syntax-entry ?\301 "w" table) ; Aacute - (modify-syntax-entry ?\302 "w" table) ; Acircumflex - (modify-syntax-entry ?\303 "w" table) ; Atilde - (modify-syntax-entry ?\304 "w" table) ; Adiaeresis - (modify-syntax-entry ?\305 "w" table) ; Aring - (modify-syntax-entry ?\306 "w" table) ; AE - (modify-syntax-entry ?\307 "w" table) ; Ccedilla - (modify-syntax-entry ?\310 "w" table) ; Egrave - (modify-syntax-entry ?\311 "w" table) ; Eacute - (modify-syntax-entry ?\312 "w" table) ; Ecircumflex - (modify-syntax-entry ?\313 "w" table) ; Ediaeresis - (modify-syntax-entry ?\314 "w" table) ; Igrave - (modify-syntax-entry ?\315 "w" table) ; Iacute - (modify-syntax-entry ?\316 "w" table) ; Icircumflex - (modify-syntax-entry ?\317 "w" table) ; Idiaeresis - (modify-syntax-entry ?\320 "w" table) ; ETH - (modify-syntax-entry ?\321 "w" table) ; Ntilde - (modify-syntax-entry ?\322 "w" table) ; Ograve - (modify-syntax-entry ?\323 "w" table) ; Oacute - (modify-syntax-entry ?\324 "w" table) ; Ocircumflex - (modify-syntax-entry ?\325 "w" table) ; Otilde - (modify-syntax-entry ?\326 "w" table) ; Odiaeresis - (modify-syntax-entry ?\327 "_" table) ; multiply - (modify-syntax-entry ?\330 "w" table) ; Ooblique - (modify-syntax-entry ?\331 "w" table) ; Ugrave - (modify-syntax-entry ?\332 "w" table) ; Uacute - (modify-syntax-entry ?\333 "w" table) ; Ucircumflex - (modify-syntax-entry ?\334 "w" table) ; Udiaeresis - (modify-syntax-entry ?\335 "w" table) ; Yacute - (modify-syntax-entry ?\336 "w" table) ; THORN - (modify-syntax-entry ?\337 "w" table) ; ssharp - ;; - ;; the lower-case characters (plus "division" and "ydiaeresis") - ;; - (modify-syntax-entry ?\340 "w" table) ; agrave - (modify-syntax-entry ?\341 "w" table) ; aacute - (modify-syntax-entry ?\342 "w" table) ; acircumflex - (modify-syntax-entry ?\343 "w" table) ; atilde - (modify-syntax-entry ?\344 "w" table) ; adiaeresis - (modify-syntax-entry ?\345 "w" table) ; aring - (modify-syntax-entry ?\346 "w" table) ; ae - (modify-syntax-entry ?\347 "w" table) ; ccedilla - (modify-syntax-entry ?\350 "w" table) ; egrave - (modify-syntax-entry ?\351 "w" table) ; eacute - (modify-syntax-entry ?\352 "w" table) ; ecircumflex - (modify-syntax-entry ?\353 "w" table) ; ediaeresis - (modify-syntax-entry ?\354 "w" table) ; igrave - (modify-syntax-entry ?\355 "w" table) ; iacute - (modify-syntax-entry ?\356 "w" table) ; icircumflex - (modify-syntax-entry ?\357 "w" table) ; idiaeresis - (modify-syntax-entry ?\360 "w" table) ; eth - (modify-syntax-entry ?\361 "w" table) ; ntilde - (modify-syntax-entry ?\362 "w" table) ; ograve - (modify-syntax-entry ?\363 "w" table) ; oacute - (modify-syntax-entry ?\364 "w" table) ; ocircumflex - (modify-syntax-entry ?\365 "w" table) ; otilde - (modify-syntax-entry ?\366 "w" table) ; odiaeresis - (modify-syntax-entry ?\367 "_" table) ; division - (modify-syntax-entry ?\370 "w" table) ; ooblique - (modify-syntax-entry ?\371 "w" table) ; ugrave - (modify-syntax-entry ?\372 "w" table) ; uacute - (modify-syntax-entry ?\373 "w" table) ; ucircumflex - (modify-syntax-entry ?\374 "w" table) ; udiaeresis - (modify-syntax-entry ?\375 "w" table) ; yacute - (modify-syntax-entry ?\376 "w" table) ; thorn - (modify-syntax-entry ?\377 "w" table) ; ydiaeresis - ) - - -(defconst iso8859/1-case-table nil - "The case table for ISO-8859/1 characters.") - -;;; This macro expands into -;;; (setq iso8859/1-case-table (purecopy '("..." nil nil nil))) -;;; doing the computation of the case table at compile-time. - -((macro - . (lambda (&rest pairs) - (let ((downcase (make-string 256 0)) - (i 0)) - (while (< i 256) - (aset downcase i (if (and (>= i ?A) (<= i ?Z)) (+ i 32) i)) - (setq i (1+ i))) - (while pairs - (aset downcase (car (car pairs)) (car (cdr (car pairs)))) - (setq pairs (cdr pairs))) - (cons 'setq - (cons 'iso8859/1-case-table - (list (list 'purecopy - (list 'quote - (list downcase nil nil nil))))))))) - - (?\300 ?\340) ; Agrave - (?\301 ?\341) ; Aacute - (?\302 ?\342) ; Acircumflex - (?\303 ?\343) ; Atilde - (?\304 ?\344) ; Adiaeresis - (?\305 ?\345) ; Aring - (?\306 ?\346) ; AE - (?\307 ?\347) ; Ccedilla - (?\310 ?\350) ; Egrave - (?\311 ?\351) ; Eacute - (?\312 ?\352) ; Ecircumflex - (?\313 ?\353) ; Ediaeresis - (?\314 ?\354) ; Igrave - (?\315 ?\355) ; Iacute - (?\316 ?\356) ; Icircumflex - (?\317 ?\357) ; Idiaeresis - (?\320 ?\360) ; ETH - (?\321 ?\361) ; Ntilde - (?\322 ?\362) ; Ograve - (?\323 ?\363) ; Oacute - (?\324 ?\364) ; Ocircumflex - (?\325 ?\365) ; Otilde - (?\326 ?\366) ; Odiaeresis - (?\330 ?\370) ; Ooblique - (?\331 ?\371) ; Ugrave - (?\332 ?\372) ; Uacute - (?\333 ?\373) ; Ucircumflex - (?\334 ?\374) ; Udiaeresis - (?\335 ?\375) ; Yacute - (?\336 ?\376) ; THORN - ) - -(set-standard-case-table (mapcar 'copy-sequence iso8859/1-case-table)) - -(setq-default ctl-arrow 'iso-8859/1) - -(provide 'iso8859-1)
--- a/lisp/iso/swedish.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,156 +0,0 @@ -;;; swedish.el --- miscellaneous functions for dealing with Swedish. - -;; Copyright (C) 1988 Free Software Foundation, Inc. - -;; Author: Howard Gayle -;; Maintainer: FSF -;; Keywords: i18n - -;; 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.34. - -;;; Code: - -;; Written by Howard Gayle. See case-table.el for details. - -;; See iso-swed.el for a description of the character set. - -(require 'iso-syntax) - -(defvar swedish-re - "[ \t\n]\\(och\\|att\\|en\\|{r\\|\\[R\\|p}\\|P\\]\\|som\\|det\\|av\\|den\\|f|r\\|F\\\\R\\)[ \t\n.,?!:;'\")}]" - "Regular expression for common Swedish words.") - -(defvar swascii-to-8859-trans - (let ((string (make-string 256 ? )) - (i 0)) - (while (< i 256) - (aset string i i) - (setq i (1+ i))) - (aset string ?\[ 196) - (aset string ?\] 197) - (aset string ?\\ 214) - (aset string ?^ 220) - (aset string ?\{ 228) - (aset string ?\} 229) - (aset string ?\` 233) - (aset string ?\| 246) - (aset string ?~ 252) - string) - "Trans table from SWASCII to 8859.") - -; $ is not converted because it almost always means US -; dollars, not general currency sign. @ is not converted -; because it is more likely to be an at sign in a mail address -; than an E with acute accent. - -(defun swascii-to-8859-buffer () - "Convert characters in buffer from Swedish/Finnish-ascii to ISO 8859/1. -Works even on read-only buffers. `$' and `@' are not converted." - (interactive) - (let ((buffer-read-only nil)) - (translate-region (point-min) (point-max) swascii-to-8859-trans))) - -(defun swascii-to-8859-buffer-maybe () - "Call swascii-to-8859-buffer if the buffer looks like Swedish-ascii. -Leaves point just after the word that looks Swedish." - (interactive) - (let ((case-fold-search t)) - (if (re-search-forward swedish-re nil t) - (swascii-to-8859-buffer)))) - -(setq rmail-show-message-hook 'swascii-to-8859-buffer-maybe) - -(or (boundp 'news-group-hook-alist) (setq news-group-hook-alist nil)) -(setq news-group-hook-alist - (append '(("^swnet." . swascii-to-8859-buffer-maybe)) - news-group-hook-alist)) - -(defvar 8859-to-swascii-trans - (let ((string (make-string 256 ? )) - (i 0)) - (while (< i 256) - (aset string i i) - (setq i (1+ i))) - (aset string 164 ?$) - (aset string 196 ?\[) - (aset string 197 ?\]) - (aset string 201 ?@) - (aset string 214 ?\\) - (aset string 220 ?^) - (aset string 228 ?\{) - (aset string 229 ?\}) - (aset string 233 ?\`) - (aset string 246 ?\|) - (aset string 252 ?~) - string) - "8859 to SWASCII trans table.") - -(defun 8859-to-swascii-buffer () - "Convert characters in buffer from ISO 8859/1 to Swedish/Finnish-ascii." - (interactive "*") - (translate-region (point-min) (point-max) 8859-to-swascii-trans)) - -(setq mail-send-hook '8859-to-swascii-buffer) -(setq news-inews-hook '8859-to-swascii-buffer) - -;; It's not clear what purpose is served by a separate -;; Swedish mode that differs from Text mode only in having -;; a separate abbrev table. Nothing says that the abbrevs you -;; define in Text mode have to be English! - -;(defvar swedish-mode-abbrev-table nil -; "Abbrev table used while in swedish mode.") -;(define-abbrev-table 'swedish-mode-abbrev-table ()) - -;(defun swedish-mode () -; "Major mode for editing Swedish text intended for humans to -;read. Special commands:\\{text-mode-map} -;Turning on swedish-mode calls the value of the variable -;text-mode-hook, if that value is non-nil." -; (interactive) -; (kill-all-local-variables) -; (use-local-map text-mode-map) -; (setq mode-name "Swedish") -; (setq major-mode 'swedish-mode) -; (setq local-abbrev-table swedish-mode-abbrev-table) -; (set-syntax-table text-mode-syntax-table) -; (run-hooks 'text-mode-hook)) - -;(defun indented-swedish-mode () -; "Major mode for editing indented Swedish text intended for -;humans to read.\\{indented-text-mode-map} -;Turning on indented-swedish-mode calls the value of the -;variable text-mode-hook, if that value is non-nil." -; (interactive) -; (kill-all-local-variables) -; (use-local-map text-mode-map) -; (define-abbrev-table 'swedish-mode-abbrev-table ()) -; (setq local-abbrev-table swedish-mode-abbrev-table) -; (set-syntax-table text-mode-syntax-table) -; (make-local-variable 'indent-line-function) -; (setq indent-line-function 'indent-relative-maybe) -; (use-local-map indented-text-mode-map) -; (setq mode-name "Indented Swedish") -; (setq major-mode 'indented-swedish-mode) -; (run-hooks 'text-mode-hook)) - -(provide 'swedish) - -;;; swedish.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/iso8859-1.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,206 @@ +;;; iso8859-1.el --- Set case and syntax tables for Latin 1 + +;; Copyright (C) 1992, 1997 Free Software Foundation, Inc. + +;; Author: Jamie Zawinski <jwz@netscape.com> +;; Created: 19-aug-92 +;; Maintainer: XEmacs Development Team +;; Keywords: internal, dumped + +;; 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 synched + +;;; Commentary: + +;; created by jwz, 19-aug-92. +;; Sets the case and syntax tables for the ISO-8859/1 character set. + +;;; Code: + +(let ((table (standard-syntax-table))) + ;; + ;; The symbol characters + ;; + (modify-syntax-entry ?\240 "_" table) ; nobreakspace + (modify-syntax-entry ?\241 "." table) ; exclamdown + (modify-syntax-entry ?\242 "_" table) ; cent + (modify-syntax-entry ?\243 "_" table) ; sterling + (modify-syntax-entry ?\244 "_" table) ; currency + (modify-syntax-entry ?\245 "_" table) ; yen + (modify-syntax-entry ?\246 "_" table) ; brokenbar + (modify-syntax-entry ?\247 "_" table) ; section + (modify-syntax-entry ?\250 "_" table) ; diaeresis + (modify-syntax-entry ?\251 "_" table) ; copyright + (modify-syntax-entry ?\252 "_" table) ; ordfeminine + (modify-syntax-entry ?\253 "(\273" table) ; guillemotleft + (modify-syntax-entry ?\254 "_" table) ; notsign + (modify-syntax-entry ?\255 "_" table) ; hyphen + (modify-syntax-entry ?\256 "_" table) ; registered + (modify-syntax-entry ?\257 "_" table) ; macron + (modify-syntax-entry ?\260 "_" table) ; degree + (modify-syntax-entry ?\261 "_" table) ; plusminus + (modify-syntax-entry ?\262 "_" table) ; twosuperior + (modify-syntax-entry ?\263 "_" table) ; threesuperior + (modify-syntax-entry ?\264 "_" table) ; acute + (modify-syntax-entry ?\265 "_" table) ; mu + (modify-syntax-entry ?\266 "_" table) ; paragraph + (modify-syntax-entry ?\267 "_" table) ; periodcentered + (modify-syntax-entry ?\270 "_" table) ; cedilla + (modify-syntax-entry ?\271 "_" table) ; onesuperior + (modify-syntax-entry ?\272 "_" table) ; masculine + (modify-syntax-entry ?\273 ")\253" table) ; guillemotright + (modify-syntax-entry ?\274 "_" table) ; onequarter + (modify-syntax-entry ?\275 "_" table) ; onehalf + (modify-syntax-entry ?\276 "_" table) ; threequarters + (modify-syntax-entry ?\277 "_" table) ; questiondown + ;; + ;; the upper-case characters (plus "multiply" and "ssharp") + ;; + (modify-syntax-entry ?\300 "w" table) ; Agrave + (modify-syntax-entry ?\301 "w" table) ; Aacute + (modify-syntax-entry ?\302 "w" table) ; Acircumflex + (modify-syntax-entry ?\303 "w" table) ; Atilde + (modify-syntax-entry ?\304 "w" table) ; Adiaeresis + (modify-syntax-entry ?\305 "w" table) ; Aring + (modify-syntax-entry ?\306 "w" table) ; AE + (modify-syntax-entry ?\307 "w" table) ; Ccedilla + (modify-syntax-entry ?\310 "w" table) ; Egrave + (modify-syntax-entry ?\311 "w" table) ; Eacute + (modify-syntax-entry ?\312 "w" table) ; Ecircumflex + (modify-syntax-entry ?\313 "w" table) ; Ediaeresis + (modify-syntax-entry ?\314 "w" table) ; Igrave + (modify-syntax-entry ?\315 "w" table) ; Iacute + (modify-syntax-entry ?\316 "w" table) ; Icircumflex + (modify-syntax-entry ?\317 "w" table) ; Idiaeresis + (modify-syntax-entry ?\320 "w" table) ; ETH + (modify-syntax-entry ?\321 "w" table) ; Ntilde + (modify-syntax-entry ?\322 "w" table) ; Ograve + (modify-syntax-entry ?\323 "w" table) ; Oacute + (modify-syntax-entry ?\324 "w" table) ; Ocircumflex + (modify-syntax-entry ?\325 "w" table) ; Otilde + (modify-syntax-entry ?\326 "w" table) ; Odiaeresis + (modify-syntax-entry ?\327 "_" table) ; multiply + (modify-syntax-entry ?\330 "w" table) ; Ooblique + (modify-syntax-entry ?\331 "w" table) ; Ugrave + (modify-syntax-entry ?\332 "w" table) ; Uacute + (modify-syntax-entry ?\333 "w" table) ; Ucircumflex + (modify-syntax-entry ?\334 "w" table) ; Udiaeresis + (modify-syntax-entry ?\335 "w" table) ; Yacute + (modify-syntax-entry ?\336 "w" table) ; THORN + (modify-syntax-entry ?\337 "w" table) ; ssharp + ;; + ;; the lower-case characters (plus "division" and "ydiaeresis") + ;; + (modify-syntax-entry ?\340 "w" table) ; agrave + (modify-syntax-entry ?\341 "w" table) ; aacute + (modify-syntax-entry ?\342 "w" table) ; acircumflex + (modify-syntax-entry ?\343 "w" table) ; atilde + (modify-syntax-entry ?\344 "w" table) ; adiaeresis + (modify-syntax-entry ?\345 "w" table) ; aring + (modify-syntax-entry ?\346 "w" table) ; ae + (modify-syntax-entry ?\347 "w" table) ; ccedilla + (modify-syntax-entry ?\350 "w" table) ; egrave + (modify-syntax-entry ?\351 "w" table) ; eacute + (modify-syntax-entry ?\352 "w" table) ; ecircumflex + (modify-syntax-entry ?\353 "w" table) ; ediaeresis + (modify-syntax-entry ?\354 "w" table) ; igrave + (modify-syntax-entry ?\355 "w" table) ; iacute + (modify-syntax-entry ?\356 "w" table) ; icircumflex + (modify-syntax-entry ?\357 "w" table) ; idiaeresis + (modify-syntax-entry ?\360 "w" table) ; eth + (modify-syntax-entry ?\361 "w" table) ; ntilde + (modify-syntax-entry ?\362 "w" table) ; ograve + (modify-syntax-entry ?\363 "w" table) ; oacute + (modify-syntax-entry ?\364 "w" table) ; ocircumflex + (modify-syntax-entry ?\365 "w" table) ; otilde + (modify-syntax-entry ?\366 "w" table) ; odiaeresis + (modify-syntax-entry ?\367 "_" table) ; division + (modify-syntax-entry ?\370 "w" table) ; ooblique + (modify-syntax-entry ?\371 "w" table) ; ugrave + (modify-syntax-entry ?\372 "w" table) ; uacute + (modify-syntax-entry ?\373 "w" table) ; ucircumflex + (modify-syntax-entry ?\374 "w" table) ; udiaeresis + (modify-syntax-entry ?\375 "w" table) ; yacute + (modify-syntax-entry ?\376 "w" table) ; thorn + (modify-syntax-entry ?\377 "w" table) ; ydiaeresis + ) + + +(defconst iso8859/1-case-table nil + "The case table for ISO-8859/1 characters.") + +;;; This macro expands into +;;; (setq iso8859/1-case-table (purecopy '("..." nil nil nil))) +;;; doing the computation of the case table at compile-time. + +((macro + . (lambda (&rest pairs) + (let ((downcase (make-string 256 0)) + (i 0)) + (while (< i 256) + (aset downcase i (if (and (>= i ?A) (<= i ?Z)) (+ i 32) i)) + (setq i (1+ i))) + (while pairs + (aset downcase (car (car pairs)) (car (cdr (car pairs)))) + (setq pairs (cdr pairs))) + (cons 'setq + (cons 'iso8859/1-case-table + (list (list 'purecopy + (list 'quote + (list downcase nil nil nil))))))))) + + (?\300 ?\340) ; Agrave + (?\301 ?\341) ; Aacute + (?\302 ?\342) ; Acircumflex + (?\303 ?\343) ; Atilde + (?\304 ?\344) ; Adiaeresis + (?\305 ?\345) ; Aring + (?\306 ?\346) ; AE + (?\307 ?\347) ; Ccedilla + (?\310 ?\350) ; Egrave + (?\311 ?\351) ; Eacute + (?\312 ?\352) ; Ecircumflex + (?\313 ?\353) ; Ediaeresis + (?\314 ?\354) ; Igrave + (?\315 ?\355) ; Iacute + (?\316 ?\356) ; Icircumflex + (?\317 ?\357) ; Idiaeresis + (?\320 ?\360) ; ETH + (?\321 ?\361) ; Ntilde + (?\322 ?\362) ; Ograve + (?\323 ?\363) ; Oacute + (?\324 ?\364) ; Ocircumflex + (?\325 ?\365) ; Otilde + (?\326 ?\366) ; Odiaeresis + (?\330 ?\370) ; Ooblique + (?\331 ?\371) ; Ugrave + (?\332 ?\372) ; Uacute + (?\333 ?\373) ; Ucircumflex + (?\334 ?\374) ; Udiaeresis + (?\335 ?\375) ; Yacute + (?\336 ?\376) ; THORN + ) + +(set-standard-case-table (mapcar 'copy-sequence iso8859/1-case-table)) + +(setq-default ctl-arrow 'iso-8859/1) + +(provide 'iso8859-1) + +;;; iso8859-1.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/itimer-autosave.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,114 @@ +;;; itimer-autosave.el --- Autosave functions with itimers + +;; Copyright status unknown + +;; Maintainer: XEmacs Development Team +;; Keywords: internal, dumped + +;; 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: + +;; This file is dumped with XEmacs. + +;; itimer-driven auto-saves + +;;; Code: + +;jwz: this is preloaded so don't ;;;###autoload +(defvar auto-save-timeout 960 + "*Number of seconds idle time before auto-save. +Zero or nil means disable auto-saving due to idleness. + +The actual amount of idle time between auto-saves is logarithmically related +to the size of the current buffer. This variable is the number of seconds +after which an auto-save will happen when the current buffer is 50k or less; +the timeout will be 2 1/4 times this in a 200k buffer, 3 3/4 times this in a +1000k buffer, and 4 1/2 times this in a 2000k buffer. + +See also the variable `auto-save-interval', which controls auto-saving based +on the number of characters typed.") + +;jwz: this is preloaded so don't ;;;###autoload +(defvar auto-gc-threshold (/ gc-cons-threshold 3) + "*GC when this many bytes have been consed since the last GC, +and the user has been idle for `auto-save-timeout' seconds.") + +(defun auto-save-itimer () + "For use as a itimer callback function. +Auto-saves and garbage-collects based on the size of the current buffer +and the value of `auto-save-timeout', `auto-gc-threshold', and the current +keyboard idle-time." + (if (or (null auto-save-timeout) + (<= auto-save-timeout 0) + (eq (minibuffer-window) (selected-window))) + nil + (let ((buf-size (1+ (ash (buffer-size) -8))) + (delay-level 0) + (now (current-time)) + delay) + (while (> buf-size 64) + (setq delay-level (1+ delay-level) + buf-size (- buf-size (ash buf-size -2)))) + (if (< delay-level 4) + (setq delay-level 4)) + ;; delay_level is 4 for files under around 50k, 7 at 100k, 9 at 200k, + ;; 11 at 300k, and 12 at 500k, 15 at 1 meg, and 17 at 2 meg. + (setq delay (/ (* delay-level auto-save-timeout) 4)) + (let ((idle-time (if (or (not (consp last-input-time)) + (/= (car now) (car last-input-time))) + (1+ delay) + (- (car (cdr now)) (cdr last-input-time))))) + (and (> idle-time delay) + (do-auto-save)) + (and (> idle-time auto-save-timeout) + (> (consing-since-gc) auto-gc-threshold) + (garbage-collect))))) + ;; Look at the itimer that's currently running; if the user has changed + ;; the value of auto-save-timeout, modify this itimer to have the correct + ;; restart time. There will be some latency between when the user changes + ;; this variable and when it takes effect, but it will happen eventually. + (let ((self (get-itimer "auto-save"))) + (or self (error "auto-save-itimer can't find itself")) + (if (and auto-save-timeout (> auto-save-timeout 4)) + (or (= (itimer-restart self) (/ auto-save-timeout 4)) + (set-itimer-restart self (/ auto-save-timeout 4))))) + nil) + +(defun itimer-init-auto-gc () + (or noninteractive ; may be being run from after-init-hook in -batch mode. + (get-itimer "auto-save") + ;; the time here is just the first interval; if the user changes it + ;; later, it will adjust. + (let ((time (max 2 (/ (or auto-save-timeout 30) 4)))) + (start-itimer "auto-save" 'auto-save-itimer time time)))) + +(cond (purify-flag + ;; This file is being preloaded into an emacs about to be dumped. + ;; So arrange for the auto-save itimer to be started once emacs + ;; is launched. + (add-hook 'after-init-hook 'itimer-init-auto-gc)) + (t + ;; Otherwise, this file is being loaded into a normal, interactive + ;; emacs. Start the auto-save timer now. + (itimer-init-auto-gc))) + + +;;; itimer-autosave.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/itimer.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,871 @@ +;;; itimer.el --- Interval timers for XEmacs + +;; Copyright (C) 1988, 1991, 1993, 1997 Kyle E. Jones + +;; Author: Kyle Jones <kyle_jones@wonderworks.com> +;; Keywords: internal, dumped + +;; 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: + +;; This file is dumped with XEmacs. + +;; Send bug reports to kyle_jones@wonderworks.com + +;;; Code: + +(provide 'itimer) + +;; `itimer' feature means Emacs-Lisp programmers get: +;; itimerp +;; itimer-live-p +;; itimer-value +;; itimer-restart +;; itimer-function +;; itimer-uses-arguments +;; itimer-function-arguments +;; set-itimer-value +;; set-itimer-restart +;; set-itimer-function +;; set-itimer-uses-arguments +;; set-itimer-function-arguments +;; get-itimer +;; start-itimer +;; read-itimer +;; delete-itimer +;; activate-itimer +;; +;; Interactive users get these commands: +;; edit-itimers +;; list-itimers +;; start-itimer +;; +;; See the doc strings of these functions for more information. + +(defvar itimer-version "1.06" + "Version number of the itimer package.") + +(defvar itimer-list nil + "List of all active itimers.") + +(defvar itimer-process nil + "Process that drives all itimers, if a subprocess is being used.") + +(defvar itimer-timer nil + "Emacs internal timer that drives the itimer system, if a subprocess +is not being used to drive the system.") + +(defvar itimer-timer-last-wakeup nil + "The time the timer driver function last ran.") + +(defvar itimer-short-interval (if (featurep 'lisp-float-type) 1e-3 1) + "Interval used for scheduling an event a very short time in the future. +Used internally to make the scheduler wake up early. +Unit is seconds.") + +;; This value is maintained internally; it does not determine +;; itimer granularity. Itimer granularity is 1 second if your +;; Emacs doens't support floats or your system doesn't have a +;; clock with microsecond granularity. Otherwise granularity is +;; to the microsend, although you can't possibly get timers to be +;; executed with this kind of accuracy in practice. There will +;; be delays due to system and Emacs internal activity that delay +;; dealing with syunchronous events and process output. +(defvar itimer-next-wakeup itimer-short-interval + "Itimer process will wakeup to service running itimers within this +many seconds.") + +(defvar itimer-edit-map nil + "Keymap used when in Itimer Edit mode.") + +(if itimer-edit-map + () + (setq itimer-edit-map (make-sparse-keymap)) + (define-key itimer-edit-map "s" 'itimer-edit-set-field) + (define-key itimer-edit-map "d" 'itimer-edit-delete-itimer) + (define-key itimer-edit-map "q" 'itimer-edit-quit) + (define-key itimer-edit-map "\t" 'itimer-edit-next-field) + (define-key itimer-edit-map " " 'next-line) + (define-key itimer-edit-map "n" 'next-line) + (define-key itimer-edit-map "p" 'previous-line) + (define-key itimer-edit-map "\C-?" 'itimer-edit-previous-field) + (define-key itimer-edit-map "x" 'start-itimer) + (define-key itimer-edit-map "?" 'itimer-edit-help)) + +(defvar itimer-inside-driver nil) + +(defvar itimer-edit-start-marker nil) + +;; macros must come first... or byte-compile'd code will throw back its +;; head and scream. + +(defmacro itimer-decrement (variable) + (list 'setq variable (list '1- variable))) + +(defmacro itimer-increment (variable) + (list 'setq variable (list '1+ variable))) + +(defmacro itimer-signum (n) + (list 'if (list '> n 0) 1 + (list 'if (list 'zerop n) 0 -1))) + +;; Itimer access functions should behave as if they were subrs. These +;; macros are used to check the arguments to the itimer functions and +;; signal errors appropriately if the arguments are not valid. + +(defmacro check-itimer (var) + "If VAR is not bound to an itimer, signal wrong-type-argument. +This is a macro." + (list 'setq var + (list 'if (list 'itimerp var) var + (list 'signal ''wrong-type-argument + (list 'list ''itimerp var))))) + +(defmacro check-itimer-coerce-string (var) + "If VAR is not bound to a string, look up the itimer that it names and +bind VAR to it. Otherwise if VAR is not bound to an itimer, signal +wrong-type-argument. This is a macro." + (list 'setq var + (list 'cond + (list (list 'itimerp var) var) + (list (list 'stringp var) (list 'get-itimer var)) + (list t (list 'signal ''wrong-type-argument + (list 'list ''string-or-itimer-p var)))))) + +(defmacro check-nonnegative-number (var) + "If VAR is not bound to a number, signal wrong-type-argument. +If VAR is not bound to a positive number, signal args-out-of-range. +This is a macro." + (list 'setq var + (list 'if (list 'not (list 'numberp var)) + (list 'signal ''wrong-type-argument + (list 'list ''natnump var)) + (list 'if (list '< var 0) + (list 'signal ''args-out-of-range (list 'list var)) + var)))) + +(defmacro check-string (var) + "If VAR is not bound to a string, signal wrong-type-argument. +This is a macro." + (list 'setq var + (list 'if (list 'stringp var) var + (list 'signal ''wrong-type-argument + (list 'list ''stringp var))))) + +;; Functions to access and modify itimer attributes. + +(defun itimerp (obj) + "Returns non-nil iff OBJ is an itimer." + (and (consp obj) (eq (length obj) 8))) + +(defun itimer-live-p (obj) + "Returns non-nil iff OBJ is an itimer and is active. +``Active'' means Emacs will run it when it expires. +`activate-timer' must be called on a itimer to make it active. +Itimers started with `start-itimer' are automatically active." + (and (itimerp obj) (memq obj itimer-list))) + +(defun itimer-name (itimer) + "Returns the name of ITIMER." + (check-itimer itimer) + (car itimer)) + +(defun itimer-value (itimer) + "Returns the number of seconds until ITIMER expires." + (check-itimer itimer) + (nth 1 itimer)) + +(defun itimer-restart (itimer) + "Returns the value to which ITIMER will be set at restart. +nil is returned if this itimer doesn't restart." + (check-itimer itimer) + (nth 2 itimer)) + +(defun itimer-function (itimer) + "Returns the function of ITIMER. +This function is called each time ITIMER expires." + (check-itimer itimer) + (nth 3 itimer)) + +(defun itimer-is-idle (itimer) + "Returns non-nil if ITIMER is an idle timer. +Normal timers expire after a set interval. Idle timers expire +only after Emacs has been idle for a specific interval. ``Idle'' +means no command events within the interval." + (check-itimer itimer) + (nth 4 itimer)) + +(defun itimer-uses-arguments (itimer) + "Returns non-nil if the function of ITIMER will be called with arguments. +ITIMER's function is called with the arguments each time ITIMER expires. +The arguments themselves are retrievable with `itimer-function-arguments'." + (check-itimer itimer) + (nth 5 itimer)) + +(defun itimer-function-arguments (itimer) + "Returns the function arguments of ITIMER as a list. +ITIMER's function is called with these argument each timer ITIMER expires." + (check-itimer itimer) + (nth 6 itimer)) + +(defun itimer-recorded-run-time (itimer) + (check-itimer itimer) + (nth 7 itimer)) + +(defun set-itimer-value (itimer value) + "Set the timeout value of ITIMER to be VALUE. +Itimer will expire is this many seconds. +If your version of Emacs supports floating point numbers then +VALUE can be a floating point number. Otherwise it +must be an integer. +Returns VALUE." + (check-itimer itimer) + (check-nonnegative-number value) + (let ((inhibit-quit t)) + ;; If the itimer is in the active list, and under the new + ;; timeout value would expire before we would normally + ;; wakeup, wakeup now and recompute a new wakeup time. + (or (and (< value itimer-next-wakeup) + (and (itimer-name itimer) (get-itimer (itimer-name itimer))) + (progn (itimer-driver-wakeup) + (setcar (cdr itimer) value) + (itimer-driver-wakeup) + t )) + (setcar (cdr itimer) value)) + value)) + +;; Same as set-itimer-value but does not wakeup the driver. +;; Only should be used by the drivers when processing expired timers. +(defun set-itimer-value-internal (itimer value) + (check-itimer itimer) + (check-nonnegative-number value) + (setcar (cdr itimer) value)) + +(defun set-itimer-restart (itimer restart) + "Set the restart value of ITIMER to be RESTART. +If RESTART is nil, ITIMER will not restart when it expires. +If your version of Emacs supports floating point numbers then +RESTART can be a floating point number. Otherwise it +must be an integer. +Returns RESTART." + (check-itimer itimer) + (if restart (check-nonnegative-number restart)) + (setcar (cdr (cdr itimer)) restart)) + +(defun set-itimer-function (itimer function) + "Set the function of ITIMER to be FUNCTION. +FUNCTION will be called when itimer expires. +Returns FUNCTION." + (check-itimer itimer) + (setcar (nthcdr 3 itimer) function)) + +(defun set-itimer-is-idle (itimer flag) + "Sets flag that says whether ITIMER is an idle timer. +If FLAG is non-nil, then ITIMER will eb considered an idle timer. +Returns FLAG." + (check-itimer itimer) + (setcar (nthcdr 4 itimer) flag)) + +(defun set-itimer-uses-arguments (itimer flag) + "Sets flag that says whether the function of ITIMER is called with arguments. +If FLAG is non-nil, then the function will be called with one argument, +otherwise the function will be called with no arguments. +Returns FLAG." + (check-itimer itimer) + (setcar (nthcdr 5 itimer) flag)) + +(defun set-itimer-function-arguments (itimer &optional arguments) + "Set the function arguments of ITIMER to be ARGUMENTS. +The function of ITIMER will be called with ARGUMENTS when itimer expires. +Returns ARGUMENTS." + (check-itimer itimer) + (setcar (nthcdr 6 itimer) arguments)) + +(defun set-itimer-recorded-run-time (itimer time) + (check-itimer itimer) + (setcar (nthcdr 7 itimer) time)) + +(defun get-itimer (name) + "Return itimer named NAME, or nil if there is none." + (check-string name) + (assoc name itimer-list)) + +(defun read-itimer (prompt &optional initial-input) + "Read the name of an itimer from the minibuffer and return the itimer +associated with that name. The user is prompted with PROMPT. +Optional second arg INITIAL-INPUT non-nil is inserted into the + minibuffer as initial user input." + (get-itimer (completing-read prompt itimer-list nil 'confirm initial-input))) + +(defun delete-itimer (itimer) + "Deletes ITIMER. ITIMER may be an itimer or the name of one." + (check-itimer-coerce-string itimer) + (setq itimer-list (delq itimer itimer-list))) + +(defun start-itimer (name function value &optional restart + is-idle with-args &rest function-arguments) + "Start an itimer. +Arguments are + NAME, FUNCTION, VALUE &optional RESTART, IS-IDLE, WITH-ARGS, &rest FUNCTION-ARGUMENTS. +NAME is an identifier for the itimer. It must be a string. If an itimer + already exists with this name, NAME will be modified slightly to until + it is unique. +FUNCTION should be a function (or symbol naming one). It + will be called each time the itimer expires with arguments of + FUNCTION-ARGUMENTS. The function can access the itimer that + invoked it through the variable `current-itimer'. If WITH-ARGS + is nil then FUNCTION is called with no arguments. This is for + backward compatibility with older versions of the itimer + package which always called FUNCTION with no arguments. +VALUE is the number of seconds until this itimer expires. + If your version of Emacs supports floating point numbers then + you can VALUE can be a floating point number. Otherwise it + must be an integer. +Optional fourth arg RESTART non-nil means that this itimer should be + restarted automatically after its function is called. Normally an itimer + is deleted at expiration after its function has returned. + If non-nil RESTART should be a number indicating the value at which the + itimer should be set at restart time. +Optional fifth arg IS-IDLE specified if this is an idle timer. + Normal timers eexpire after a set interval. Idle timers expire + only after Emacs has been idle for specific interval. ``Idle'' + means no command events within the interval. +Returns the newly created itimer." + (interactive + (list (completing-read "Start itimer: " itimer-list) + (read (completing-read "Itimer function: " obarray 'fboundp)) + (let (value) + (while (or (not (numberp value)) (< value 0)) + (setq value (read-from-minibuffer "Itimer value: " nil nil t))) + value) + (let ((restart t)) + (while (and restart (or (not (numberp restart)) (< restart 0))) + (setq restart (read-from-minibuffer "Itimer restart: " + nil nil t))) + restart) + ;; hard to imagine the user specifying these interactively + nil + nil )) + (check-string name) + (check-nonnegative-number value) + (if restart (check-nonnegative-number restart)) + ;; Make proposed itimer name unique if it's not already. + (let ((oname name) + (num 2)) + (while (get-itimer name) + (setq name (concat oname "<" num ">")) + (itimer-increment num))) + (activate-itimer (list name value restart function is-idle + with-args function-arguments (list 0 0 0))) + (car itimer-list)) + +(defun make-itimer () + "Create an unactivated itimer. +The itimer will not begin running until activated with `activate-itimer'. +Set the itimer's expire interval with `set-itimer-value'. +Set the itimer's function interval with `set-itimer-function'. +Once this is done, the timer can be activated." + (list nil 0 nil 'ignore nil nil nil (list 0 0 0))) + +(defun activate-itimer (itimer) + "Activate ITIMER, which was previously created with `make-itimer'. +ITIMER will be added to the global list of running itimers, +its FUNCTION will be called when it expires, and so on." + (check-itimer itimer) + (if (memq itimer itimer-list) + (error "itimer already activated")) + (if (not (numberp (itimer-value itimer))) + (error "itimer timeout value not a number: %s" (itimer-value itimer))) + (if (<= (itimer-value itimer) 0) + (error "itimer timeout value not positive: %s" (itimer-value itimer))) + ;; If there's no itimer driver/process, start one now. + ;; Otherwise wake up the itimer driver so that seconds slept before + ;; the new itimer is created won't be counted against it. + (if (or itimer-process itimer-timer) + (itimer-driver-wakeup) + (itimer-driver-start)) + ;; Roll a unique name for the timer if it doesn't have a name + ;; already. + (if (not (stringp (car itimer))) + (let ((name "itimer-0") + (oname "itimer-") + (num 1)) + (while (get-itimer name) + (setq name (concat oname "<" num ">")) + (itimer-increment num)) + (setcar itimer name)) + ;; signal an error if the timer's name matches an already + ;; activated timer. + (if (get-itimer (itimer-name itimer)) + (error "itimer named \"%s\" already existing and activated" + (itimer-name itimer)))) + (let ((inhibit-quit t)) + ;; add the itimer to the global list + (setq itimer-list (cons itimer itimer-list)) + ;; If the itimer process is scheduled to wake up too late for + ;; the itimer we wake it up to calculate a correct wakeup + ;; value giving consideration to the newly added itimer. + (if (< (itimer-value itimer) itimer-next-wakeup) + (itimer-driver-wakeup)))) + +;; User level functions to list and modify existing itimers. +;; Itimer Edit major mode, and the editing commands thereof. + +(defun list-itimers () + "Pop up a buffer containing a list of all itimers. +The major mode of the buffer is Itimer Edit mode. This major mode provides +commands to manipulate itimers; see the documentation for +`itimer-edit-mode' for more information." + (interactive) + (let* ((buf (get-buffer-create "*Itimer List*")) + (opoint (point)) + (standard-output buf) + (itimers (reverse itimer-list))) + (set-buffer buf) + (itimer-edit-mode) + (setq buffer-read-only nil) + (erase-buffer) + (insert +"Name Value Restart Function Idle Arguments" +"\n" +"---- ----- ------- -------- ---- --------") + (if (null itimer-edit-start-marker) + (setq itimer-edit-start-marker (point))) + (while itimers + (newline 1) + (prin1 (itimer-name (car itimers))) + (tab-to-tab-stop) + (insert (itimer-truncate-string + (format "%5.5s" (itimer-value (car itimers))) 5)) + (tab-to-tab-stop) + (insert (itimer-truncate-string + (format "%5.5s" (itimer-restart (car itimers))) 5)) + (tab-to-tab-stop) + (insert (itimer-truncate-string + (format "%.19s" (itimer-function (car itimers))) 19)) + (tab-to-tab-stop) + (if (itimer-is-idle (car itimers)) + (insert "yes") + (insert "no")) + (tab-to-tab-stop) + (if (itimer-uses-arguments (car itimers)) + (prin1 (itimer-function-arguments (car itimers))) + (prin1 'NONE)) + (setq itimers (cdr itimers))) + ;; restore point + (goto-char opoint) + (if (< (point) itimer-edit-start-marker) + (goto-char itimer-edit-start-marker)) + (setq buffer-read-only t) + (display-buffer buf))) + +(defun edit-itimers () + "Display a list of all itimers and select it for editing. +The major mode of the buffer containing the listing is Itimer Edit mode. +This major mode provides commands to manipulate itimers; see the documentation +for `itimer-edit-mode' for more information." + (interactive) + ;; since user is editing, make sure displayed data is reasonably up-to-date + (if (or itimer-process itimer-timer) + (itimer-driver-wakeup)) + (list-itimers) + (select-window (get-buffer-window "*Itimer List*")) + (goto-char itimer-edit-start-marker) + (if itimer-list + (progn + (forward-sexp 2) + (backward-sexp))) + (message "type q to quit, ? for help")) + +;; no point in making this interactive. +(defun itimer-edit-mode () + "Major mode for manipulating itimers. +Attributes of running itimers are changed by moving the cursor to the +desired field and typing `s' to set that field. The field will then be +set to the value read from the minibuffer. + +Commands: +TAB move forward a field +DEL move backward a field +s set a field +d delete the selected itimer +x start a new itimer +? help" + (kill-all-local-variables) + (make-local-variable 'tab-stop-list) + (setq major-mode 'itimer-edit-mode + mode-name "Itimer Edit" + truncate-lines t + tab-stop-list '(22 32 40 60 67)) + (abbrev-mode 0) + (auto-fill-mode 0) + (buffer-disable-undo (current-buffer)) + (use-local-map itimer-edit-map) + (set-syntax-table emacs-lisp-mode-syntax-table)) + +(put 'itimer-edit-mode 'mode-class 'special) + +(defun itimer-edit-help () + "Help function for Itimer Edit." + (interactive) + (if (eq last-command 'itimer-edit-help) + (describe-mode) + (message "TAB, DEL select fields, (s)et field, (d)elete itimer (type ? for more help)"))) + +(defun itimer-edit-quit () + "End Itimer Edit." + (interactive) + (bury-buffer (current-buffer)) + (if (one-window-p t) + (switch-to-buffer (other-buffer (current-buffer))) + (delete-window))) + +(defun itimer-edit-set-field () + (interactive) + ;; First two lines in list buffer are headers. + ;; Cry out against the luser who attempts to change a field there. + (if (<= (point) itimer-edit-start-marker) + (error "")) + ;; field-value must be initialized to be something other than a + ;; number, symbol, or list. + (let (itimer field (field-value "")) + (setq itimer (save-excursion + ;; read the name of the itimer from the beginning of + ;; the current line. + (beginning-of-line) + (get-itimer (read (current-buffer)))) + field (save-excursion + (itimer-edit-beginning-of-field) + (let ((opoint (point)) + (n 0)) + ;; count the number of sexprs until we reach the cursor + ;; and use this info to determine which field the user + ;; wants to modify. + (beginning-of-line) + (while (and (>= opoint (point)) (< n 6)) + (forward-sexp 2) + (backward-sexp) + (itimer-increment n)) + (cond ((eq n 1) (error "Cannot change itimer name.")) + ((eq n 2) 'value) + ((eq n 3) 'restart) + ((eq n 4) 'function) + ((eq n 5) 'is-idle) + (t 'function-argument))))) + (cond ((eq field 'value) + (let ((prompt "Set itimer value: ")) + (while (not (natnump field-value)) + (setq field-value (read-from-minibuffer prompt nil nil t))))) + ((eq field 'restart) + (let ((prompt "Set itimer restart: ")) + (while (and field-value (not (natnump field-value))) + (setq field-value (read-from-minibuffer prompt nil nil t))))) + ((eq field 'function) + (let ((prompt "Set itimer function: ")) + (while (not (or (and (symbolp field-value) (fboundp field-value)) + (and (consp field-value) + (memq (car field-value) '(lambda macro))))) + (setq field-value + (read (completing-read prompt obarray 'fboundp nil)))))) + ((eq field 'is-idle) + (setq field-value (not (itimer-is-idle itimer)))) + ((eq field 'function-argument) + (let ((prompt "Set itimer function argument: ")) + (setq field-value (read-expression prompt)) + (cond ((not (listp field-value)) + (setq field-value (list field-value)))) + (if (null field-value) + (set-itimer-uses-arguments itimer nil) + (set-itimer-uses-arguments itimer t))))) + ;; set the itimer field + (funcall (intern (concat "set-itimer-" (symbol-name field))) + itimer field-value) + ;; move to beginning of field to be changed + (itimer-edit-beginning-of-field) + ;; modify the list buffer to reflect the change. + (let (buffer-read-only kill-ring) + (kill-sexp 1) + (kill-region (point) (progn (skip-chars-forward " \t") (point))) + (prin1 field-value (current-buffer)) + (if (not (eolp)) + (tab-to-tab-stop)) + (backward-sexp)))) + +(defun itimer-edit-delete-itimer () + (interactive) + ;; First two lines in list buffer are headers. + ;; Cry out against the luser who attempts to change a field there. + (if (<= (point) itimer-edit-start-marker) + (error "")) + (delete-itimer + (read-itimer "Delete itimer: " + (save-excursion (beginning-of-line) (read (current-buffer))))) + ;; update list information + (list-itimers)) + +(defun itimer-edit-next-field (count) + (interactive "p") + (itimer-edit-beginning-of-field) + (cond ((> (itimer-signum count) 0) + (while (not (zerop count)) + (forward-sexp) + ;; wrap from eob to itimer-edit-start-marker + (if (eobp) + (progn + (goto-char itimer-edit-start-marker) + (forward-sexp))) + (forward-sexp) + (backward-sexp) + ;; treat fields at beginning of line as if they weren't there. + (if (bolp) + (progn + (forward-sexp 2) + (backward-sexp))) + (itimer-decrement count))) + ((< (itimer-signum count) 0) + (while (not (zerop count)) + (backward-sexp) + ;; treat fields at beginning of line as if they weren't there. + (if (bolp) + (backward-sexp)) + ;; wrap from itimer-edit-start-marker to field at eob. + (if (<= (point) itimer-edit-start-marker) + (progn + (goto-char (point-max)) + (backward-sexp))) + (itimer-increment count))))) + +(defun itimer-edit-previous-field (count) + (interactive "p") + (itimer-edit-next-field (- count))) + +(defun itimer-edit-beginning-of-field () + (let ((forw-back (save-excursion (forward-sexp) (backward-sexp) (point))) + (back (save-excursion (backward-sexp) (point)))) + (cond ((eq forw-back back) (backward-sexp)) + ((eq forw-back (point)) t) + (t (backward-sexp))))) + +(defun itimer-truncate-string (str len) + (if (<= (length str) len) + str + (substring str 0 len))) + +;; internals of the itimer implementation. + +(defun itimer-run-expired-timers (time-elapsed) + (let ((itimers (copy-sequence itimer-list)) + (itimer) + (next-wakeup 600) + (idle-time) + (last-event-time) + (recorded-run-time) + ;; process filters can be hit by stray C-g's from the user, + ;; so we must protect this stuff appropriately. + ;; Quit's are allowed from within itimer functions, but we + ;; catch them and print a message. + (inhibit-quit t)) + (setq next-wakeup 600) + (if (and (boundp 'last-input-time) (consp last-input-time)) + (setq last-event-time (list (car last-input-time) + (cdr last-input-time) + 0) + idle-time (itimer-time-difference (current-time) + last-event-time)) + ;; no way to do this under FSF Emacs yet. + (setq last-event-time '(0 0 0) + idle-time 0)) + (while itimers + (setq itimer (car itimers)) + (if (itimer-is-idle itimer) + (setq recorded-run-time (itimer-recorded-run-time itimer)) + (set-itimer-value-internal itimer (max 0 (- (itimer-value itimer) + time-elapsed)))) + (if (if (itimer-is-idle itimer) + (or (> (itimer-time-difference recorded-run-time + last-event-time) + 0) + (< idle-time (itimer-value itimer))) + (> (itimer-value itimer) 0)) + (setq next-wakeup + (if (itimer-is-idle itimer) + (if (< idle-time (itimer-value itimer)) + (min next-wakeup (- (itimer-value itimer) idle-time)) + (min next-wakeup (itimer-value itimer))) + (min next-wakeup (itimer-value itimer)))) + (and (itimer-is-idle itimer) + (set-itimer-recorded-run-time itimer (current-time))) + ;; itimer has expired, we must call its function. + ;; protect our local vars from the itimer function. + ;; allow keyboard quit to occur, but catch and report it. + ;; provide the variable `current-itimer' in case the function + ;; is interested. + (unwind-protect + (condition-case condition-data + (save-match-data + (let* ((current-itimer itimer) + (quit-flag nil) + (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) + (if (itimer-uses-arguments current-itimer) + (apply (itimer-function current-itimer) + (itimer-function-arguments current-itimer)) + (funcall (itimer-function current-itimer))))) + (error (message "itimer \"%s\" signaled: %s" (itimer-name itimer) + (prin1-to-string condition-data))) + (quit (message "itimer \"%s\" quit" (itimer-name itimer)))) + ;; restart the itimer if we should, otherwise delete it. + (if (null (itimer-restart itimer)) + (delete-itimer itimer) + (set-itimer-value-internal itimer (itimer-restart itimer)) + (setq next-wakeup (min next-wakeup (itimer-value itimer)))))) + (setq itimers (cdr itimers))) + ;; if user is editing itimers, update displayed info + (if (eq major-mode 'itimer-edit-mode) + (list-itimers)) + next-wakeup )) + +(defun itimer-process-filter (process string) + ;; If the itimer process dies and generates output while doing + ;; so, we may be called before the process-sentinel. Sanity + ;; check the output just in case... + (if (not (string-match "^[0-9]" string)) + (progn (message "itimer process gave odd output: %s" string) + ;; it may be still alive and waiting for input + (process-send-string itimer-process "3\n")) + ;; if there are no active itimers, return quickly. + (if itimer-list + (let ((wakeup nil)) + (unwind-protect + (setq wakeup (itimer-run-expired-timers (string-to-int string))) + (and (null wakeup) (process-send-string process "1\n"))) + (setq itimer-next-wakeup wakeup)) + (setq itimer-next-wakeup 600)) + ;; tell itimer-process when to wakeup again + (process-send-string itimer-process + (concat (int-to-string itimer-next-wakeup) + "\n")))) + +(defun itimer-process-sentinel (process message) + (let ((inhibit-quit t)) + (if (eq (process-status process) 'stop) + (continue-process process) + ;; not stopped, so it must have died. + ;; cleanup first... + (delete-process process) + (setq itimer-process nil) + ;; now, if there are any active itimers then we need to immediately + ;; start another itimer process, otherwise we can wait until the next + ;; start-itimer call, which will start one automatically. + (if (null itimer-list) + () + ;; there may have been an error message in the echo area; + ;; give the user at least a little time to read it. + (sit-for 2) + (message "itimer process %s... respawning." (substring message 0 -1)) + (itimer-process-start))))) + +(defun itimer-process-start () + (let ((inhibit-quit t) + (process-connection-type nil)) + (setq itimer-process (start-process "itimer" nil "itimer")) + (process-kill-without-query itimer-process) + (set-process-filter itimer-process 'itimer-process-filter) + (set-process-sentinel itimer-process 'itimer-process-sentinel) + ;; Tell itimer process to wake up quickly, so that a correct + ;; wakeup time can be computed. Zero loses because of + ;; underlying itimer implementations that use 0 to mean + ;; `disable the itimer'. + (setq itimer-next-wakeup itimer-short-interval) + (process-send-string itimer-process + (format "%s\n" itimer-next-wakeup)))) + +(defun itimer-process-wakeup () + (interrupt-process itimer-process) + (accept-process-output)) + +(defun itimer-timer-start () + (let ((inhibit-quit t)) + (setq itimer-next-wakeup itimer-short-interval + itimer-timer-last-wakeup (current-time) + itimer-timer (add-timeout itimer-short-interval + 'itimer-timer-driver nil nil)))) + +(defun itimer-timer-wakeup () + (let ((inhibit-quit t)) + (cond ((fboundp 'disable-timeout) + (disable-timeout itimer-timer)) + ((fboundp 'cancel-timer) + (cancel-timer itimer-timer))) + (setq itimer-timer (add-timeout itimer-short-interval + 'itimer-timer-driver nil 5)))) + +(defun itimer-time-difference (t1 t2) + (let (usecs secs 65536-secs carry) + (setq usecs (- (nth 2 t1) (nth 2 t2))) + (if (< usecs 0) + (setq carry 1 + usecs (+ usecs 1000000)) + (setq carry 0)) + (setq secs (- (nth 1 t1) (nth 1 t2) carry)) + (if (< secs 0) + (setq carry 1 + secs (+ secs 65536)) + (setq carry 0)) + (setq 65536-secs (- (nth 0 t1) (nth 0 t2) carry)) + ;; loses for interval larger than the maximum signed Lisp integer. + ;; can't really be helped. + (+ (* 65536-secs 65536) + secs + (/ usecs (if (featurep 'lisp-float-type) 1e6 1000000))))) + +(defun itimer-timer-driver (&rest ignored) + ;; inhibit quit because if the user quits at an inopportune + ;; time, the timer process won't bne launched again and the + ;; system stops working. itimer-run-expired-timers allows + ;; individual timer function to be aborted, so the user can + ;; escape a feral timer function. + (if (not itimer-inside-driver) + (let* ((inhibit-quit t) + (itimer-inside-driver t) + (now (current-time)) + (elapsed (itimer-time-difference now itimer-timer-last-wakeup)) + (sleep nil)) + (setq itimer-timer-last-wakeup now + sleep (itimer-run-expired-timers elapsed)) + (disable-timeout itimer-timer) + (setq itimer-next-wakeup sleep + itimer-timer (add-timeout sleep 'itimer-timer-driver nil 5))))) + +(defun itimer-driver-start () + (if (fboundp 'add-timeout) + (itimer-timer-start) + (itimer-process-start))) + +(defun itimer-driver-wakeup () + (if (fboundp 'add-timeout) + (itimer-timer-wakeup) + (itimer-process-wakeup))) + +;;; itimer.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/keydefs.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,628 @@ +;;; keydefs.el --- Define standard keybindings. + +;; Copyright (C) 1992-4, 1997 Free Software Foundation, Inc. + +;; Maintainer: XEmacs Development Team +;; Keywords: internal, dumped + +;; 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, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;; All the global bindings should be here so that one can reload things +;; like files.el without trashing one's personal bindings. + +;;; Synched up with: Not synched with FSF. + +;;; Commentary: + +;; This file is dumped with XEmacs + +;;; Code: + +;; created by C code +(defvar global-map (current-global-map) "\ +Default global keymap mapping XEmacs keyboard input into commands. +The value is a keymap which is usually (but not necessarily) XEmacs's +global map.") + +;; created by C code +(defvar esc-map (symbol-function 'ESC-prefix) "\ +Default keymap for ESC (meta) commands. +The normal global definition of the character ESC indirects to this keymap.") + +(set-keymap-name global-map 'global-map) +(set-keymap-name esc-map 'ESC-prefix) + +(define-prefix-command 'Control-X-prefix t) +(defvar ctl-x-map (symbol-function 'Control-X-prefix) "\ +Default keymap for C-x commands. +The normal global definition of the character C-x indirects to this keymap.") +(define-key global-map "\C-x" 'Control-X-prefix) + +(define-prefix-command 'ctl-x-4-prefix t) +(defvar ctl-x-4-map (symbol-function 'ctl-x-4-prefix) "\ +Keymap for subcommands of C-x 4") +(define-key global-map "\C-x4" 'ctl-x-4-prefix) + +(define-prefix-command 'ctl-x-5-prefix t) +(defvar ctl-x-5-map (symbol-function 'ctl-x-5-prefix) "\ +Keymap for subcommands of C-x 5") +(define-key global-map "\C-x5" 'ctl-x-5-prefix) + +(define-prefix-command 'mode-specific-command-prefix t) +(defvar mode-specific-map (symbol-function 'mode-specific-command-prefix) "\ +Keymap for characters following C-c.") +(define-key global-map "\C-c" 'mode-specific-command-prefix) + +;; FSFmacs buffer.c + +(define-key global-map "\C-xb" 'switch-to-buffer) +(define-key global-map "\C-xk" 'kill-buffer) +(define-key global-map "\C-x\C-b" 'list-buffers) +(put 'erase-buffer 'disabled t) ;from buffer.c + +;; FSFmacs casefiddle.c + +(define-key global-map "\C-x\C-u" 'upcase-region) +;; This is silly with zmacs regions +;(put 'upcase-region 'disabled t) +(define-key global-map "\C-x\C-l" 'downcase-region) +;; This is silly with zmacs regions +;(put 'downcase-region 'disabled t) +(define-key global-map "\M-u" 'upcase-region-or-word) +(define-key global-map "\M-l" 'downcase-region-or-word) +(define-key global-map "\M-c" 'capitalize-region-or-word) + +;; FSFmacs cmds.c + +(let ((n 33)) + (while (<= n 255) + (if (not (= n 127)) + (define-key global-map n 'self-insert-command)) + (setq n (1+ n)))) +(define-key global-map " " 'self-insert-command) + +(define-key global-map "\C-a" 'beginning-of-line) +(define-key global-map "\C-b" 'backward-char) +(define-key global-map "\C-e" 'end-of-line) +(define-key global-map "\C-f" 'forward-char) +(define-key global-map "\C-d" 'delete-char) +(define-key global-map 'delete 'backward-or-forward-delete-char) +(define-key global-map '(meta delete) 'backward-or-forward-kill-word) +(define-key global-map [(control x) (delete)] 'backward-or-forward-kill-sentence) + +;; FSFmacs files.el + +(define-key global-map "\C-x\C-f" 'find-file) +(define-key global-map "\C-x\C-q" 'toggle-read-only) +(define-key global-map "\C-x\C-r" 'find-file-read-only) +(define-key global-map "\C-x\C-v" 'find-alternate-file) +(define-key global-map "\C-x\C-s" 'save-buffer) +(define-key global-map "\C-xs" 'save-some-buffers) +(define-key global-map "\C-x\C-w" 'write-file) +(define-key global-map "\C-xi" 'insert-file) +(define-key global-map "\M-~" 'not-modified) +(define-key global-map "\C-x\C-d" 'list-directory) +(define-key global-map "\C-x\C-c" 'save-buffers-kill-emacs) + +(define-key global-map "\C-x4f" 'find-file-other-window) +(define-key global-map "\C-x4r" 'find-file-read-only-other-window) +(define-key global-map "\C-x4\C-f" 'find-file-other-window) +(define-key global-map "\C-x4b" 'switch-to-buffer-other-window) +(define-key global-map "\C-x4\C-o" 'display-buffer) + +(define-key global-map "\C-x5b" 'switch-to-buffer-other-frame) +(define-key global-map "\C-x5f" 'find-file-other-frame) +(define-key global-map "\C-x5\C-f" 'find-file-other-frame) +(define-key global-map "\C-x5r" 'find-file-read-only-other-frame) + +;; FSFmacs frame.c +;FSFmacs has these. It's probably a good idea to provide ways of hooking +;these events, but it's unlikely that it's a good idea to do it this way. +;Just provide a hook, like the existing `select-frame-hook', +;`deselect-frame-hook', `map-frame-hook', and `unmap-frame-hook'. +;#### ergo need hooks for delete-frame and iconify-frame +;(define-key global-map 'switch-frame 'handle-switch-frame) +;(define-key global-map 'delete-frame 'handle-delete-frame) +;(define-key global-map 'iconify-frame 'ignore-event) +;(define-key global-map 'make-frame-visible 'ignore-event) + +;; FSFmacs frame.el + +;; New FSF19 bindings: C-x 5 as prefix for window commands +(define-key global-map "\C-x52" 'make-frame) +(define-key global-map "\C-x50" 'delete-frame) +(define-key global-map "\C-x5o" 'other-frame) + +;; FSFmacs help.el + +(define-key global-map (vector help-char) 'help-command) +(define-key global-map 'help 'help-command) +(define-key global-map 'f1 'help-command) + +;; FSFmacs indent.el + +;;(define-key global-map "\t" 'self-insert-command) +(define-key global-map "\t" 'indent-for-tab-command) +(define-key global-map "\M-\C-\\" 'indent-region) +(define-key global-map "\C-x\t" 'indent-rigidly) +(define-key global-map "\M-i" 'tab-to-tab-stop) +;; XEmacs addition: +(define-key global-map [(shift tab)] 'tab-to-tab-stop) + +;; FSFmacs isearch.el + +(define-key global-map "\C-s" 'isearch-forward) +(define-key global-map "\C-r" 'isearch-backward) +(define-key global-map "\M-\C-s" 'isearch-forward-regexp) +(define-key global-map "\M-\C-r" 'isearch-backward-regexp) + +;; FSFmacs keyboard.c + +(define-key global-map "\C-z" 'suspend-emacs-or-iconify-frame) +(define-key global-map "\C-x\C-z" 'suspend-or-iconify-emacs) + +;; FSFmacs loaddefs.el + +;; New FSF19 bindings: C-x n as a prefix for narrowing commands. +(define-key global-map "\C-xn" (let ((map (make-sparse-keymap))) + (set-keymap-name map 'narrowing-prefix) + map)) +(put 'narrow-to-region 'disabled t) +(define-key global-map "\C-xnn" 'narrow-to-region) +(define-key global-map "\C-xnw" 'widen) +(define-key global-map "\C-xnd" 'narrow-to-defun) +;; Old v18 bindings +;(define-key global-map "\C-xn" 'narrow-to-region) +;(define-key global-map "\C-xw" 'widen) + +(define-key global-map "\C-j" 'newline-and-indent) +(define-key global-map "\C-m" 'newline) +(define-key global-map "\C-o" 'open-line) +(define-key global-map "\M-\C-o" 'split-line) +(define-key global-map "\C-q" 'quoted-insert) +(define-key global-map "\M-^" 'delete-indentation) +(define-key global-map "\M-\\" 'delete-horizontal-space) +(define-key global-map "\M-m" 'back-to-indentation) +(define-key global-map "\C-x\C-o" 'delete-blank-lines) +(define-key global-map "\M- " 'just-one-space) +(define-key global-map "\M-z" 'zap-to-char) +(define-key global-map "\M-=" 'count-lines-region) +(define-key global-map "\C-x=" 'what-cursor-position) +(define-key global-map "\M-:" 'eval-expression) +;; Define ESC ESC : like ESC : for people who type ESC ESC out of habit. +(define-key global-map "\M-\e:" 'eval-expression) +;(define-key global-map "\M-\e" 'eval-expression) +;; Do we really need to disable this now that it is harder to type +;; by accident? +;; (put 'eval-expression 'disabled t) +;; Changed from C-x ESC so that function keys work following C-x. +(define-key global-map "\C-x\e\e" 'repeat-complex-command) +;(define-key global-map "\C-x\e" 'repeat-complex-command) +(define-key global-map "\C-xu" 'advertised-undo) +;; Many people are used to typing C-/ on X terminals and getting C-_. +(define-key global-map '(control /) 'undo) +(define-key global-map "\C-_" 'undo) +(define-key global-map "\M-!" 'shell-command) +(define-key global-map "\M-|" 'shell-command-on-region) + +(define-key global-map "\C-u" 'universal-argument) +;; Make Control-0 - Control-9 set the prefix argument, like Meta-0. +(let ((i ?0)) + (while (<= i ?9) + (define-key global-map (list 'meta i) 'digit-argument) + (define-key global-map (list 'control i) 'digit-argument) + (define-key global-map (list 'control 'meta i) 'digit-argument) + (setq i (1+ i)))) +(define-key global-map '(meta -) 'negative-argument) +(define-key global-map '(control -) 'negative-argument) +(define-key global-map '(control meta -) 'negative-argument) + +(define-key global-map "\C-k" 'kill-line) +(define-key global-map "\C-w" 'kill-region) +(define-key global-map "\M-w" 'kill-ring-save) +(define-key global-map "\M-\C-w" 'append-next-kill) +(define-key global-map "\C-y" 'yank) +(define-key global-map "\M-y" 'yank-pop) + +;; Old v18 binding +;(define-key global-map "\C-xa" 'append-to-buffer) + +(define-key global-map "\C-@" 'set-mark-command) +;; Many people are used to typing C-SPC and getting C-@. +(define-key global-map '(control ? ) 'set-mark-command) +(define-key global-map "\C-x\C-x" 'exchange-point-and-mark) +(define-key global-map "\C-x\C-@" 'pop-global-mark) +(define-key global-map [(control x) (control ? )] 'pop-global-mark) + +(define-key global-map "\C-n" 'next-line) +(define-key global-map "\C-p" 'previous-line) +;(define-key global-map "\C-x\C-n" 'set-goal-column) +;; XEmacs: +;;; Many people have said they rarely use this feature, and often type +;;; it by accident. Maybe it shouldn't even be on a key. +;;; Done. -hniksic +;(put 'set-goal-column 'disabled t) + +(define-key global-map [menu] 'execute-extended-command) +(define-key global-map [find] 'search-forward) + +(define-key global-map "\C-t" 'transpose-chars) +(define-key global-map "\M-t" 'transpose-words) +(define-key global-map "\M-\C-t" 'transpose-sexps) +(define-key global-map "\C-x\C-t" 'transpose-lines) + +(define-key global-map "\M-;" 'indent-for-comment) +(define-key global-map "\M-j" 'indent-new-comment-line) +(define-key global-map "\M-\C-j" 'indent-new-comment-line) +(define-key global-map "\C-x;" 'set-comment-column) +(define-key global-map "\C-xf" 'set-fill-column) +(define-key global-map "\C-x$" 'set-selective-display) + +(define-key global-map "\M-@" 'mark-word) +(define-key global-map "\M-f" 'forward-word) +(define-key global-map "\M-b" 'backward-word) +(define-key global-map "\M-d" 'kill-word) + +(define-key global-map "\M-<" 'beginning-of-buffer) +(define-key global-map "\M->" 'end-of-buffer) +(define-key global-map "\C-xh" 'mark-whole-buffer) +(define-key global-map "\M-\\" 'delete-horizontal-space) + +(define-key global-map "\M-\C-f" 'forward-sexp) +(define-key global-map "\M-\C-b" 'backward-sexp) +(define-key global-map "\M-\C-u" 'backward-up-list) +(define-key global-map "\M-\C-@" 'mark-sexp) +(define-key global-map "\M-\C-d" 'down-list) +(define-key global-map "\M-\C-k" 'kill-sexp) +(define-key global-map "\M-\C-n" 'forward-list) +(define-key global-map "\M-\C-p" 'backward-list) +(define-key global-map "\M-\C-a" 'beginning-of-defun) +(define-key global-map "\M-\C-e" 'end-of-defun) +(define-key global-map "\M-\C-h" 'mark-defun) +(define-key global-map "\M-\(" 'insert-parentheses) +(define-key global-map "\M-\)" 'move-past-close-and-reindent) +(define-key global-map "\M-\t" 'lisp-complete-symbol) + +(define-key global-map '(control meta backspace) 'backward-kill-sexp) +(define-key global-map '(control meta delete) 'backward-or-forward-kill-sexp) + + +(define-key global-map "\C-x/" 'point-to-register) +(define-key global-map "\C-xj" 'jump-to-register) +(define-key global-map "\C-xx" 'copy-to-register) +(define-key global-map "\C-xg" 'insert-register) +;; Old v18 binding +;(define-key global-map "\C-xr" 'copy-rectangle-to-register) + +;; New FSF19 bindings: C-x r as a prefix for register commands +(define-key global-map "\C-xr" (let ((map (make-sparse-keymap))) + (set-keymap-name map 'rectangle-prefix) + map)) +(define-key global-map "\C-xr\C-@" 'point-to-register) +(define-key global-map "\C-xr " 'point-to-register) +(define-key global-map "\C-xrj" 'jump-to-register) +(define-key global-map "\C-xrs" 'copy-to-register) +(define-key global-map "\C-xrx" 'copy-to-register) +(define-key global-map "\C-xri" 'insert-register) +(define-key global-map "\C-xrg" 'insert-register) +(define-key global-map "\C-xrr" 'copy-rectangle-to-register) +(define-key global-map "\C-xrc" 'clear-rectangle) +(define-key global-map "\C-xrk" 'kill-rectangle) +(define-key global-map "\C-xry" 'yank-rectangle) +(define-key global-map "\C-xro" 'open-rectangle) +(define-key global-map "\C-xrt" 'string-rectangle) +(define-key global-map "\C-xrw" 'window-configuration-to-register) +;(define-key global-map "\C-xrf" 'frame-configuration-to-register) + +(define-key global-map "\M-q" 'fill-paragraph-or-region) +;(define-key global-map "\M-q" 'fill-paragraph) +;(define-key global-map "\M-g" 'fill-region) ;now bound to goto-line +(define-key global-map "\C-x." 'set-fill-prefix) + +; Using {} instead of [] is 1) FSF compatible and 2) allows function +; keys to work on ttys. M-[ is the beginning of most the function key +; sequences. +(define-key global-map "\M-{" 'backward-paragraph) +(define-key global-map "\M-}" 'forward-paragraph) +(define-key global-map "\M-h" 'mark-paragraph) +(define-key global-map "\M-a" 'backward-sentence) +(define-key global-map "\M-e" 'forward-sentence) +(define-key global-map "\M-k" 'kill-sentence) +;;(define-key global-map "\C-x\177" 'backward-kill-sentence) + +(define-key global-map "\C-x[" 'backward-page) +(define-key global-map "\C-x]" 'forward-page) +(define-key global-map "\C-x\C-p" 'mark-page) +(define-key global-map "\C-xl" 'count-lines-page) +(define-key global-map "\C-xnp" 'narrow-to-page) +;; Old v18 bindings +;(define-key global-map "\C-xp" 'narrow-to-page) +(put 'narrow-to-page 'disabled t) + +;; Old v18 bindings +;(define-key global-map "\C-x\C-a" 'add-mode-abbrev) +;(define-key global-map "\C-x+" 'add-global-abbrev) +;(define-key global-map "\C-x\C-h" 'inverse-add-mode-abbrev) +;(define-key global-map "\C-x-" 'inverse-add-global-abbrev) + +(define-key global-map "\M-'" 'abbrev-prefix-mark) +(define-key global-map "\C-x'" 'expand-abbrev) + +;; New FSF19 bindings: C-x a as a prefix for abbrev commands +(define-key global-map "\C-xal" 'add-mode-abbrev) +(define-key global-map "\C-xa\C-a" 'add-mode-abbrev) +(define-key global-map "\C-xag" 'add-global-abbrev) +(define-key global-map "\C-xa+" 'add-mode-abbrev) +(define-key global-map "\C-xaig" 'inverse-add-global-abbrev) +(define-key global-map "\C-xail" 'inverse-add-mode-abbrev) +(define-key global-map "\C-xa-" 'inverse-add-global-abbrev) +(define-key global-map "\C-xae" 'expand-abbrev) +(define-key global-map "\C-xa'" 'expand-abbrev) + +(define-key global-map "\M-\C-l" 'switch-to-other-buffer) + +;; Default binding of "Backspace" is no longer the same as delete. +;; Default binding of "Control-h" is help. +(define-key global-map 'backspace 'delete-backward-char) +(define-key global-map '(meta backspace) 'backward-kill-word) + +(define-key global-map "\M-\C-z" 'activate-region) + +;; FSFmacs macros.c + +(define-key global-map "\C-xe" 'call-last-kbd-macro) +(define-key global-map "\C-x\(" 'start-kbd-macro) +(define-key global-map "\C-x\)" 'end-kbd-macro) + +;; FSFmacs macros.el + +(define-key global-map "\C-xq" 'kbd-macro-query) + + +;; FSFmacs minibuffer.c +; see also minibuf.el + +(define-key global-map "\M-\C-c" 'exit-recursive-edit) +(define-key global-map "\C-]" 'abort-recursive-edit) +(define-key global-map "\M-x" 'execute-extended-command) + +;; FSFmacs window.c + +(define-key global-map "\C-x0" 'delete-window) +(define-key global-map "\C-x1" 'delete-other-windows) +(define-key global-map "\C-x2" 'split-window-vertically) +(define-key global-map "\C-x3" 'split-window-horizontally) +;; Old XEmacs binding +;;(define-key global-map "\C-x5" 'split-window-horizontally) +(define-key global-map "\C-xo" 'other-window) +(define-key global-map "\C-x^" 'enlarge-window) +(define-key global-map "\C-x<" 'scroll-left) +(define-key global-map "\C-x>" 'scroll-right) + +(define-key global-map "\C-v" 'scroll-up) +(define-key global-map "\M-v" 'scroll-down) +(define-key global-map "\M-\C-v" 'scroll-other-window) +; meta-shift-V, that is. +(define-key global-map '(meta V) 'scroll-other-window-down) + +(define-key global-map "\C-l" 'recenter) +(define-key global-map "\M-r" 'move-to-window-line) + +;; FSFmacs window.el + +(define-key global-map "\C-x6" 'window-configuration-to-register) +;(define-key global-map "\C-x7" 'jump-to-register);ie register-to-window-config +(define-key global-map "\C-x}" 'enlarge-window-horizontally) +(define-key global-map "\C-x{" 'shrink-window-horizontally) +;; New FSF19 bindings +(define-key global-map "\C-x-" 'shrink-window-if-larger-than-buffer) +(define-key global-map "\C-x+" 'balance-windows) +(define-key ctl-x-4-map "0" 'kill-buffer-and-window) + +;;(define-key global-map "\C-g" 'keyboard-quit) +(let ((ch (quit-char))) + (if (or (characterp ch) (integerp ch)) + (setq ch (char-to-string ch))) + (define-key global-map ch 'keyboard-quit)) +(define-key global-map "\e\e\e" 'keyboard-escape-quit) + + + + + + +(define-key global-map "\M-%" 'query-replace) + + +; autoloaded +;(define-key global-map "\C-x4a" 'add-change-log-entry-other-window) + +; autoloaded +;(define-key global-map "\C-x`" 'next-error) + +; autoloaded +;(define-key global-map "\M-/" 'dabbrev-expand) + +; autoloaded +;(define-key global-map "\C-xd" 'dired) + +; autoloaded +;(define-key global-map "\C-x4d" 'dired-other-window) + +(define-key global-map "\M-$" 'ispell-word) + +(define-key global-map "\C-xm" 'compose-mail) +(define-key global-map "\C-x4m" 'compose-mail-other-window) +(define-key global-map "\C-x5m" 'compose-mail-other-frame) + +(define-key global-map "\M-." 'find-tag) + +(define-key global-map "\C-x4." 'find-tag-other-window) + +(define-key global-map "\M-," 'tags-loop-continue) + + +(define-key global-map '(control <) 'mark-beginning-of-buffer) +(define-key global-map '(control >) 'mark-end-of-buffer) + +(define-key global-map "\C-x\C-e" 'eval-last-sexp) ;bogus! + + +(define-key global-map "\M-g" 'goto-line) + +;; Keypad type things + +;; I removed all the fkey crap, because where-is is now smart enough +;; to show all bindings. --ben + +;;; These aren't bound to kbd macros like "\C-b" so that they have the +;; expected behavior even in, for example, vi-mode. + +;; We use here symbolic names, assuming that the corresponding keys will +;; generate these keysyms. This is not true on Suns, but x-win-sun.el +;; fixes that. If it turns out that the semantics of these keys should +;; differ from server to server, this should be moved into server-specific +;; files, but these appear to be the standard Motif and PC bindings. + +;; movement by units +(define-key global-map 'left 'backward-char) +(define-key global-map 'up 'previous-line) +(define-key global-map 'right 'forward-char) +(define-key global-map 'down 'next-line) + +;; movement by pages +(define-key global-map 'prior 'scroll-down) +(define-key global-map 'next 'scroll-up) + +;; movement to the limits +(define-key global-map 'home 'beginning-of-line) +(define-key global-map 'end 'end-of-line) + +;;; Miscellaneous key bindings +(define-key global-map 'again 'repeat-complex-command) +(define-key global-map 'insert 'overwrite-mode) + +;;; These aren't bound to kbd macros like "\C-b" so that they have the +;; expected behavior even in, for example, vi-mode. + +;; We use here symbolic names, assuming that the corresponding keys will +;; generate these keysyms. This is not true on Suns, but x-win-sun.el +;; fixes that. If it turns out that the semantics of these keys should +;; differ from server to server, this should be moved into server-specific +;; files, but these appear to be the standard Motif and PC bindings. + +;; potential R6isms +(define-key global-map 'kp-left 'backward-char) +(define-key global-map 'kp-up 'previous-line) +(define-key global-map 'kp-right 'forward-char) +(define-key global-map 'kp-down 'next-line) + + +;; movement by larger blocks +(define-key global-map '(control left) 'backward-word) +(define-key global-map '(control up) #'(lambda () + (interactive "_") + (forward-line -6))) +(define-key global-map '(control right) 'forward-word) +(define-key global-map '(control down) #'(lambda () + (interactive "_") + (forward-line 6))) + +;; context-sensitive movement +(define-key global-map '(meta left) 'backward-sexp) +(define-key global-map '(meta right) 'forward-sexp) +(define-key global-map '(meta up) 'backward-paragraph) +(define-key global-map '(meta down) 'forward-paragraph) + +;; movement by pages +(define-key global-map '(control prior) 'scroll-right) +(define-key global-map '(control next) 'scroll-left) +;; potential R6isms +(define-key global-map 'kp-prior 'scroll-down) +(define-key global-map 'kp-next 'scroll-up) +(define-key global-map '(control kp-prior) 'scroll-right) +(define-key global-map '(control kp-next) 'scroll-left) + + +;; movement to the limits +(define-key global-map '(control home) 'beginning-of-buffer) +(define-key global-map '(control end) 'end-of-buffer) +(define-key global-map 'begin 'beginning-of-line) +(define-key global-map '(control begin) 'beginning-of-buffer) +;; potential R6isms +(define-key global-map 'kp-home 'beginning-of-line) +(define-key global-map '(control kp-home) 'beginning-of-buffer) +(define-key global-map 'kp-end 'end-of-line) +(define-key global-map '(control kp-end) 'end-of-buffer) + +;; movement between windows +(define-key global-map '(control tab) 'other-window) +(define-key global-map '(control shift tab) 'backward-other-window) + +;; movement in other windows +(define-key global-map '(meta next) 'scroll-other-window) +(define-key global-map '(meta prior) 'scroll-other-window-down) +(define-key global-map '(meta home) 'beginning-of-buffer-other-window) +(define-key global-map '(meta end) 'end-of-buffer-other-window) +;; potential R6isms +(define-key global-map '(meta kp-next) 'scroll-other-window) +(define-key global-map '(meta kp-prior) 'scroll-other-window-down) +(define-key global-map '(meta kp-home) 'beginning-of-buffer-other-window) +(define-key global-map '(meta kp-end) 'end-of-buffer-other-window) + +;; potential R6isms +(define-key global-map 'redo 'repeat-complex-command) +(define-key global-map 'kp-insert 'overwrite-mode) +(define-key global-map 'kp-delete 'backward-delete-char-untabify) + +(define-key global-map 'kp-enter [return]) ; do whatever RET does now +(define-key global-map 'kp-tab [tab]) + +(define-key global-map 'undo 'undo) +(define-key global-map 'help 'help-for-help) + +(define-key global-map 'kp-space 'self-insert-command) +(define-key global-map 'kp-equal 'self-insert-command) +(define-key global-map 'kp-multiply 'self-insert-command) +(define-key global-map 'kp-add 'self-insert-command) +(define-key global-map 'kp-separator 'self-insert-command) +(define-key global-map 'kp-subtract 'self-insert-command) +(define-key global-map 'kp-decimal 'self-insert-command) +(define-key global-map 'kp-divide 'self-insert-command) + +(define-key global-map 'kp-0 'self-insert-command) +(define-key global-map 'kp-1 'self-insert-command) +(define-key global-map 'kp-2 'self-insert-command) +(define-key global-map 'kp-3 'self-insert-command) +(define-key global-map 'kp-4 'self-insert-command) +(define-key global-map 'kp-5 'self-insert-command) +(define-key global-map 'kp-6 'self-insert-command) +(define-key global-map 'kp-7 'self-insert-command) +(define-key global-map 'kp-8 'self-insert-command) +(define-key global-map 'kp-9 'self-insert-command) + +(define-key global-map 'select 'function-key-error) +(define-key global-map 'print 'function-key-error) +(define-key global-map 'execute 'execute-extended-command) +(define-key global-map 'clearline 'function-key-error) +(define-key global-map 'insertline 'open-line) +(define-key global-map 'deleteline 'kill-line) +(define-key global-map 'insertchar 'function-key-error) +(define-key global-map 'deletechar 'delete-char) + +;;; keydefs.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/keymap.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,484 @@ +;; keymap.el --- Keymap functions for XEmacs. + +;; Copyright (C) 1993-4, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp. + +;; Maintainer: XEmacs Development Team +;; Keywords: internals, dumped + +;; 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, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: FSF 19.28. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;;; Note: FSF does not have a file keymap.el. This stuff is +;;; in keymap.c. + +;Prevent the \{...} documentation construct +;from mentioning keys that run this command. + +;;; Code: + +(put 'undefined 'suppress-keymap t) + +(defun undefined () + (interactive) + (ding)) + +(defun suppress-keymap (map &optional nodigits) + "Make MAP override all normally self-inserting keys to be undefined. +Normally, as an exception, digits and minus-sign are set to make prefix args, +but optional second arg NODIGITS non-nil treats them like other chars." + (substitute-key-definition 'self-insert-command 'undefined map global-map) + (or nodigits + (let ((string (make-string 1 ?0))) + (define-key map "-" 'negative-argument) + ;; Make plain numbers do numeric args. + (while (<= (aref string 0) ?9) + (define-key map string 'digit-argument) + (incf (aref string 0)))))) + +(defun substitute-key-definition (olddef newdef keymap &optional oldmap prefix) + "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF. +In other words, OLDDEF is replaced with NEWDEF wherever it appears. +Prefix keymaps are checked recursively. If optional fourth argument OLDMAP +is specified, we redefine in KEYMAP as NEWDEF those chars which are defined +as OLDDEF in OLDMAP, unless that keybinding is already present in keymap. +If optional fifth argument PREFIX is defined, then only those occurrences of +OLDDEF found in keymaps accessible through the keymap bound to PREFIX in +KEYMAP are redefined. See also `accessible-keymaps'." + (let ((maps (accessible-keymaps (or oldmap keymap) prefix)) + (shadowing (not (null oldmap))) + prefix map) + (while maps + (setq prefix (car (car maps)) + map (cdr (car maps)) + maps (cdr maps)) + ;; Substitute in this keymap + (map-keymap #'(lambda (key binding) + (if (eq binding olddef) + ;; The new bindings always go in KEYMAP even if we + ;; found them in OLDMAP or one of it's children. + ;; If KEYMAP will be shadowing OLDMAP, then do not + ;; redefine the key if there is another binding + ;; in KEYMAP that will shadow OLDDEF. + (or (and shadowing + (lookup-key keymap key)) + ;; define-key will give an error if a prefix + ;; of the key is already defined. Otherwise + ;; it will define the key in the map. + ;; #### - Perhaps this should be protected? + (define-key + keymap + (vconcat prefix (list key)) + newdef)))) + map) + ))) + + +;; From Bill Dubuque <wgd@martigny.ai.mit.edu> + +;; This used to wrap forms into an interactive lambda. It is unclear +;; to me why this is needed in this function. Anyway, +;; `key-or-menu-binding' doesn't do it, so this function no longer +;; does it, either. +(defun insert-key-binding (key) ; modeled after describe-key + "Insert the command bound to KEY." + (interactive "kInsert command bound to key: ") + (let ((defn (key-or-menu-binding key))) + (if (or (null defn) (integerp defn)) + (error "%s is undefined" (key-description key)) + (if (or (stringp defn) (vectorp defn)) + (setq defn (key-binding defn))) ;; a keyboard macro + (insert (format "%s" defn))))) + +;; From Bill Dubuque <wgd@martigny.ai.mit.edu> +(defun read-command-or-command-sexp (prompt) + "Read a command symbol or command sexp. +A command sexp is wrapped in an interactive lambda if needed. +Prompts with PROMPT." + ;; Todo: it would be better if we could reject symbols that are not + ;; commandp (as does 'read-command') but that is not easy to do + ;; because we must supply arg4 = require-match = nil for sexp case. + (let ((result (car (read-from-string + (completing-read prompt obarray 'commandp))))) + (if (and (consp result) + (not (eq (car result) 'lambda))) + `(lambda () + (interactive) + ,result) + result))) + +(defun local-key-binding (keys) + "Return the binding for command KEYS in current local keymap only. +KEYS is a string, a vector of events, or a vector of key-description lists +as described in the documentation for the `define-key' function. +The binding is probably a symbol with a function definition; see +the documentation for `lookup-key' for more information." + (let ((map (current-local-map))) + (if map + (lookup-key map keys) + nil))) + +(defun global-key-binding (keys) + "Return the binding for command KEYS in current global keymap only. +KEYS is a string or vector of events, a sequence of keystrokes. +The binding is probably a symbol with a function definition; see +the documentation for `lookup-key' for more information." + (lookup-key (current-global-map) keys)) + +;; from Bill Dubuque <wgd@martigny.ai.mit.edu> +(defun global-set-key (key command) + "Give KEY a global binding as COMMAND. +COMMAND is a symbol naming an interactively-callable function. +KEY is a string, a vector of events, or a vector of key-description lists +as described in the documentation for the `define-key' function. +Note that if KEY has a local binding in the current buffer +that local binding will continue to shadow any global binding." + ;;(interactive "KSet key globally: \nCSet key %s to command: ") + (interactive (list (setq key (read-key-sequence "Set key globally: ")) + ;; Command sexps are allowed here so that this arg + ;; may be supplied interactively via insert-key-binding. + (read-command-or-command-sexp + (format "Set key %s to command: " + (key-description key))))) + (define-key (current-global-map) key command) + nil) + +;; from Bill Dubuque <wgd@martigny.ai.mit.edu> +(defun local-set-key (key command) + "Give KEY a local binding as COMMAND. +COMMAND is a symbol naming an interactively-callable function. +KEY is a string, a vector of events, or a vector of key-description lists +as described in the documentation for the `define-key' function. +The binding goes in the current buffer's local map, +which is shared with other buffers in the same major mode." + ;;(interactive "KSet key locally: \nCSet key %s locally to command: ") + (interactive (list (setq key (read-key-sequence "Set key locally: ")) + ;; Command sexps are allowed here so that this arg + ;; may be supplied interactively via insert-key-binding. + (read-command-or-command-sexp + (format "Set key %s locally to command: " + (key-description key))))) + (if (null (current-local-map)) + (use-local-map (make-sparse-keymap))) + (define-key (current-local-map) key command) + nil) + +(defun global-unset-key (key) + "Remove global binding of KEY. +KEY is a string, a vector of events, or a vector of key-description lists +as described in the documentation for the `define-key' function." + (interactive "kUnset key globally: ") + (global-set-key key nil)) + +(defun local-unset-key (key) + "Remove local binding of KEY. +KEY is a string, a vector of events, or a vector of key-description lists +as described in the documentation for the `define-key' function." + (interactive "kUnset key locally: ") + (if (current-local-map) + (define-key (current-local-map) key nil))) + + +;; Yet more RMS brain-death. +(defun minor-mode-key-binding (key &optional accept-default) + "Find the visible minor mode bindings of KEY. +Return an alist of pairs (MODENAME . BINDING), where MODENAME is +the symbol which names the minor mode binding KEY, and BINDING is +KEY's definition in that mode. In particular, if KEY has no +minor-mode bindings, return nil. If the first binding is a +non-prefix, all subsequent bindings will be omitted, since they would +be ignored. Similarly, the list doesn't include non-prefix bindings +that come after prefix bindings. + +If optional argument ACCEPT-DEFAULT is non-nil, recognize default +bindings; see the description of `lookup-key' for more details about this." + (let ((tail minor-mode-map-alist) + a s v) + (while tail + (setq a (car tail) + tail (cdr tail)) + (and (consp a) + (symbolp (setq s (car a))) + (boundp s) + (symbol-value s) + ;; indirect-function deals with autoloadable keymaps + (setq v (indirect-function (cdr a))) + (setq v (lookup-key v key accept-default)) + ;; Terminate loop, with v set to non-nil value + (setq tail nil))) + v)) + + +(defun current-minor-mode-maps () + "Return a list of keymaps for the minor modes of the current buffer." + (let ((l '()) + (tail minor-mode-map-alist) + a s v) + (while tail + (setq a (car tail) + tail (cdr tail)) + (and (consp a) + (symbolp (setq s (car a))) + (boundp s) + (symbol-value s) + ;; indirect-function deals with autoloadable keymaps + (setq v (indirect-function (cdr a))) + (setq l (cons v l)))) + (nreverse l))) + + +;;#### What a crock +(defun define-prefix-command (name &optional mapvar) + "Define COMMAND as a prefix command. +A new sparse keymap is stored as COMMAND's function definition. +If second optional argument MAPVAR is not specified, + COMMAND's value (as well as its function definition) is set to the keymap. +If a second optional argument MAPVAR is given and is not `t', + the map is stored as its value. +Regardless of MAPVAR, COMMAND's function-value is always set to the keymap." + (let ((map (make-sparse-keymap name))) + (fset name map) + (cond ((not mapvar) + (set name map)) + ((eq mapvar 't) + ) + (t + (set mapvar map))) + name)) + + +;;; Converting vectors of events to a read-equivalent form. +;;; This is used both by call-interactively (for the command history) +;;; and by macros.el (for saving keyboard macros to a file). + +;; ### why does (events-to-keys [backspace]) return "\C-h"? +;; BTW, this function is a mess, and macros.el does *not* use it, in +;; spite of the above comment. `format-kbd-macro' is used to save +;; keyboard macros to a file. +(defun events-to-keys (events &optional no-mice) + "Given a vector of event objects, returns a vector of key descriptors, +or a string (if they all fit in the ASCII range). +Optional arg NO-MICE means that button events are not allowed." + (if (and events (symbolp events)) (setq events (vector events))) + (cond ((stringp events) + events) + ((not (vectorp events)) + (signal 'wrong-type-argument (list 'vectorp events))) + ((let* ((length (length events)) + (string (make-string length 0)) + c ce + (i 0)) + (while (< i length) + (setq ce (aref events i)) + (or (eventp ce) (setq ce (character-to-event ce))) + ;; Normalize `c' to `?c' and `(control k)' to `?\C-k' + ;; By passing t for the `allow-meta' arg we could get kbd macros + ;; with meta in them to translate to the string form instead of + ;; the list/symbol form; but I expect that would cause confusion, + ;; so let's use the list/symbol form whenever there's + ;; any ambiguity. + (setq c (event-to-character ce)) + (if (and c + character-set-property + (key-press-event-p ce)) + (cond ((symbolp (event-key ce)) + (if (get (event-key ce) character-set-property) + ;; Don't use a string for `backspace' and `tab' to + ;; avoid that unpleasant little ambiguity. + (setq c nil))) + ((and (= (event-modifier-bits ce) 1) ;control + (integerp (event-key ce))) + (let* ((te (character-to-event c))) + (if (and (symbolp (event-key te)) + (get (event-key te) character-set-property)) + ;; Don't "normalize" (control i) to tab + ;; to avoid the ambiguity in the other direction + (setq c nil)) + (deallocate-event te))))) + (if c + (aset string i c) + (setq i length string nil)) + (setq i (1+ i))) + string)) + (t + (let* ((length (length events)) + (new (copy-sequence events)) + event mods key + (i 0)) + (while (< i length) + (setq event (aref events i)) + (cond ((key-press-event-p event) + (setq mods (event-modifiers event) + key (event-key event)) + (if (numberp key) + (setq key (intern (make-string 1 key)))) + (aset new i (if mods + (nconc mods (cons key nil)) + key))) + ((misc-user-event-p event) + (aset new i (list 'menu-selection + (event-function event) + (event-object event)))) + ((or (button-press-event-p event) + (button-release-event-p event)) + (if no-mice + (error + "Mouse events can't be saved in keyboard macros.")) + (setq mods (event-modifiers event) + key (intern (concat "button" + (event-button event) + (if (button-release-event-p event) + "up" "")))) + (aset new i (if mods + (nconc mods (cons key nil)) + key))) + ((or (and event (symbolp event)) + (and (consp event) (symbolp (car event)))) + (aset new i event)) + (t + (signal 'wrong-type-argument (list 'eventp event)))) + (setq i (1+ i))) + new)))) + + +(defun next-key-event () + "Return the next available keyboard event." + (let (event) + (while (not (key-press-event-p (setq event (next-command-event)))) + (dispatch-event event)) + event)) + +(defun key-sequence-list-description (keys) + "Convert a key sequence KEYS to the full [(modifiers... key)...] form. +Argument KEYS can be in any form accepted by `define-key' function." + (let ((vec + (cond ((vectorp keys) + keys) + ((stringp keys) + (vconcat keys)) + (t + (vector keys)))) + (event-to-list + #'(lambda (ev) + (append (event-modifiers ev) (list (event-key ev)))))) + (mapvector + #'(lambda (key) + (cond ((key-press-event-p key) + (funcall event-to-list key)) + ((characterp key) + (funcall event-to-list (character-to-event key))) + ((listp key) + key) + (t + (list key)))) + vec))) + + +;;; Support keyboard commands to turn on various modifiers. + +;;; These functions -- which are not commands -- each add one modifier +;;; to the following event. + +(defun event-apply-alt-modifier (ignore-prompt) + (event-apply-modifier 'alt)) +(defun event-apply-super-modifier (ignore-prompt) + (event-apply-modifier 'super)) +(defun event-apply-hyper-modifier (ignore-prompt) + (event-apply-modifier 'hyper)) +(defun event-apply-shift-modifier (ignore-prompt) + (event-apply-modifier 'shift)) +(defun event-apply-control-modifier (ignore-prompt) + (event-apply-modifier 'control)) +(defun event-apply-meta-modifier (ignore-prompt) + (event-apply-modifier 'meta)) + +;;; #### `key-translate-map' is ignored for now. +(defun event-apply-modifier (symbol) + "Return the next key event, with a modifier flag applied. +SYMBOL is the name of this modifier, as a symbol. +`function-key-map' is scanned for prefix bindings." + (let (events binding) + ;; read keystrokes scanning `function-key-map' + (while (keymapp + (setq binding + (lookup-key + function-key-map + (vconcat + (setq events + (append events (list (next-key-event))))))))) + (if binding ; found a binding + (progn + ;; allow for several modifiers + (if (and (symbolp binding) (fboundp binding)) + (setq binding (funcall binding nil))) + (setq events (append binding nil)) + ;; put remaining keystrokes back into input queue + (setq unread-command-events + (mapcar 'character-to-event (cdr events)))) + (setq unread-command-events (cdr events))) + ;; add a modifier SYMBOL to the first keystroke or event + (vector + (append (list symbol) + (delq symbol + (aref (key-sequence-list-description (car events)) 0)))))) + +(defun synthesize-keysym (ignore-prompt) + "Read a sequence of keys, and returned the corresponding key symbol. +The characters must be from the [-_a-zA-Z0-9]. Reading is terminated + by RET (which is discarded)." + (let ((continuep t) + event char list) + (while continuep + (setq event (next-key-event)) + (cond ((and (setq char (event-to-character event)) + (or (memq char '(?- ?_)) + (eq ?w (char-syntax char (standard-syntax-table))))) + ;; Advance a character. + (push char list)) + ((or (memq char '(?\r ?\n)) + (memq (event-key event) '(return newline))) + ;; Legal termination. + (setq continuep nil)) + (char + ;; Illegal character. + (error "Illegal character in keysym: %c" char)) + (t + ;; Illegal event. + (error "Event has no character equivalent: %s" event)))) + (vector (intern (concat "" (nreverse list)))))) + +;; This looks dirty. The following code should maybe go to another +;; file, and `create-console-hook' should maybe default to nil. +(add-hook + 'create-console-hook + #'(lambda (console) + (letf (((selected-console) console)) + (define-key function-key-map [?\C-x ?@ ?h] 'event-apply-hyper-modifier) + (define-key function-key-map [?\C-x ?@ ?s] 'event-apply-super-modifier) + (define-key function-key-map [?\C-x ?@ ?m] 'event-apply-meta-modifier) + (define-key function-key-map [?\C-x ?@ ?S] 'event-apply-shift-modifier) + (define-key function-key-map [?\C-x ?@ ?c] 'event-apply-control-modifier) + (define-key function-key-map [?\C-x ?@ ?a] 'event-apply-alt-modifier) + (define-key function-key-map [?\C-x ?@ ?k] 'synthesize-keysym)))) + +;;; keymap.el ends here
--- a/lisp/language/cyrillic.el Mon Aug 13 10:03:54 2007 +0200 +++ b/lisp/language/cyrillic.el Mon Aug 13 10:04:58 2007 +0200 @@ -146,12 +146,12 @@ ;; (define-coding-system-alias 'koi8-r 'cyrillic-koi8) ;; (define-coding-system-alias 'koi8 'cyrillic-koi8) -(make-coding-system - 'koi8-r 'ccl - "Coding-system used for KOI8-R." - `(decode ,ccl-decode-koi8 - encode ,ccl-encode-koi8 - mnemonic "KOI8")) +;; (make-coding-system +;; 'koi8-r 'ccl +;; "Coding-system used for KOI8-R." +;; `(decode ,ccl-decode-koi8 +;; encode ,ccl-encode-koi8 +;; mnemonic "KOI8")) ;;(define-coding-system-alias 'koi8-r 'koi8)
--- a/lisp/language/european.el Mon Aug 13 10:03:54 2007 +0200 +++ b/lisp/language/european.el Mon Aug 13 10:04:58 2007 +0200 @@ -199,7 +199,7 @@ (documentation . ("\ These languages are supported with the Latin-2 (ISO-8859-2) character set: Albanian, Czech, English, German, Hungarian, Polish, Romanian, - Serbian or Croatian, Slovak, Slovene, and Swedish. + Serbian, Croatian, Slovak, Slovene, and Swedish. " . describe-european-environment-map)) ))
--- a/lisp/language/japanese.el Mon Aug 13 10:03:54 2007 +0200 +++ b/lisp/language/japanese.el Mon Aug 13 10:04:58 2007 +0200 @@ -218,7 +218,7 @@ (set-language-info-alist "Japanese" '((setup-function . setup-japanese-environment) - (tutorial . "TUTORIAL.jp") + (tutorial . "TUTORIAL.ja") (charset . (japanese-jisx0208 japanese-jisx0208-1978 japanese-jisx0212 latin-jisx0201 katakana-jisx0201))
--- a/lisp/language/korean.el Mon Aug 13 10:03:54 2007 +0200 +++ b/lisp/language/korean.el Mon Aug 13 10:04:58 2007 +0200 @@ -140,7 +140,7 @@ (set-language-info-alist "Korean" '((setup-function . setup-korean-environment) - (tutorial . "TUTORIAL.kr") + (tutorial . "TUTORIAL.ko") (charset . (korean-ksc5601)) (coding-system . (iso-2022-kr euc-kr)) (sample-text . "Hangul ($(CGQ1[(B) $(C>H3gGO<<?d(B, $(C>H3gGO=J4O1n(B")
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/lib-complete.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,346 @@ +;;; lib-complete.el --- Completion on the lisp search path + +;; Copyright (C) 1997 Free Software Foundation, Inc. +;; Copyright (C) Mike Williams <mike-w@cs.aukuni.ac.nz> 1991 + +;; Author: Mike Williams <mike-w@cs.aukuni.ac.nz> +;; Maintainer: XEmacs Development Team +;; Keywords: lisp, extensions, dumped +;; Created: Sat Apr 20 17:47:21 1991 + +;; 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: + +;; This file is dumped with XEmacs. + +;; ======================================================================== +;; lib-complete.el -- Completion on a search path +;; Author : Mike Williams <mike-w@cs.aukuni.ac.nz> +;; Created On : Sat Apr 20 17:47:21 1991 +;; Last Modified By: Heiko M|nkel <muenkel@tnt.uni-hannover.de> +;; Additional XEmacs integration By: Chuck Thompson <cthomp@cs.uiuc.edu> +;; Last Modified On: Thu Jul 1 14:23:00 1994 +;; RCS Info : $Revision: 1.2 $ $Locker: $ +;; ======================================================================== +;; NOTE: XEmacs must be redumped if this file is changed. +;; +;; Copyright (C) Mike Williams <mike-w@cs.aukuni.ac.nz> 1991 +;; +;; Keywords: utility, lisp + +;; Many thanks to Hallvard Furuseth <hallvard@ifi.uio.no> for his +;; helpful suggestions. + +;; The function locate-file is removed, because of its incompatibility +;; with the buildin function of the lemacs 19.10 (Heiko M|nkel). + +;; There is now the new function find-library in this package. + +;;; ChangeLog: + +;; 4/26/97: sb Mule-ize. + +;;; Code: + +;;=== Determine completions for filename in search path =================== + +(defun library-all-completions (FILE SEARCH-PATH &optional FULL FAST) + "Return all completions for FILE in any directory on SEARCH-PATH. +If optional third argument FULL is non-nil, returned pathnames should be + absolute rather than relative to some directory on the SEARCH-PATH. +If optional fourth argument FAST is non-nil, don't sort the completions, + or remove duplicates." + (setq FILE (or FILE "")) + (if (file-name-absolute-p FILE) + ;; It's an absolute file name, so don't need SEARCH-PATH + (progn + (setq FILE (expand-file-name FILE)) + (file-name-all-completions + (file-name-nondirectory FILE) (file-name-directory FILE))) + (let ((subdir (file-name-directory FILE)) + (file (file-name-nondirectory FILE)) + all-completions) + ;; Make list of completions in each directory on SEARCH-PATH + (while SEARCH-PATH + (let* ((dir (concat (file-name-as-directory + (expand-file-name (car SEARCH-PATH))) + subdir)) + (dir-prefix (if FULL dir subdir))) + (if (file-directory-p dir) + (let ((subdir-completions + (file-name-all-completions file dir))) + (while subdir-completions + (setq all-completions + (cons (concat dir-prefix (car subdir-completions)) + all-completions)) + (setq subdir-completions (cdr subdir-completions)))))) + (setq SEARCH-PATH (cdr SEARCH-PATH))) + (if FAST all-completions + (let ((sorted (nreverse (sort all-completions 'string<))) + compressed) + (while sorted + (if (equal (car sorted) (car compressed)) nil + (setq compressed (cons (car sorted) compressed))) + (setq sorted (cdr sorted))) + compressed))))) + +;;=== Utilities =========================================================== + +(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)) + (save-excursion + (goto-char (point-max)) + (let ((orig-pmax (point-max))) + (unwind-protect + (progn + (insert " " (, MESSAGE)) (goto-char orig-pmax) + (sit-for 0) ; Redisplay + (,@ FORMS)) + (delete-region orig-pmax (point-max))))) + (prog2 + (message "%s" (, MESSAGE)) + (progn (,@ FORMS)) + (message ""))))) +#+infodock (defalias 'lib-funcall-with-msg 'progn-with-message) + +(put 'progn-with-message 'lisp-indent-hook 1) +#+infodock (put 'lib-funcall-with-message 'lisp-indent-hook 1) + +;;=== Completion caching ================================================== + +(defconst lib-complete:cache nil + "Used within read-library and read-library-internal to prevent +costly repeated calls to library-all-completions. +Format is a list of lists of the form + + ([<path> <subdir>] <cache-record> <cache-record> ...) + +where each <cache-record> has the form + + (<root> <modtimes> <completion-table>)") +#+infodock (defvaralias 'lib-completions 'lib-complete:cache) + +(defun lib-complete:better-root (ROOT1 ROOT2) + "Return non-nil if ROOT1 is a superset of ROOT2." + (and (equal (file-name-directory ROOT1) (file-name-directory ROOT2)) + (string-match + (concat "^" (regexp-quote (file-name-nondirectory ROOT1))) + ROOT2))) + +(defun lib-complete:get-completion-table (FILE PATH FILTER) + (let* ((subdir (file-name-directory FILE)) + (root (file-name-nondirectory FILE)) + (PATH + (mapcar + (function (lambda (dir) (file-name-as-directory + (expand-file-name (or dir ""))))) + PATH)) + (key (vector PATH subdir FILTER)) + (real-dirs + (if subdir + (mapcar (function (lambda (dir) (concat dir subdir))) PATH) + PATH)) + (path-modtimes + (mapcar + (function (lambda (fn) (if fn (nth 5 (file-attributes fn))))) + real-dirs)) + (cache-entry (assoc key lib-complete:cache)) + (cache-records (cdr cache-entry))) + ;; Look for cached entry + (catch 'table + (while cache-records + (if (and + (lib-complete:better-root (nth 0 (car cache-records)) root) + (equal (nth 1 (car cache-records)) path-modtimes)) + (throw 'table (nth 2 (car cache-records)))) + (setq cache-records (cdr cache-records))) + ;; Otherwise build completions + (let ((completion-list + (progn-with-message "(building completion table...)" + (library-all-completions FILE PATH nil 'fast))) + (completion-table (make-vector 127 0))) + (while completion-list + (let ((completion + (if (or (not FILTER) + (file-directory-p (car completion-list))) + (car completion-list) + (funcall FILTER (car completion-list))))) + (if completion + (intern completion completion-table))) + (setq completion-list (cdr completion-list))) + ;; Cache the completions + (lib-complete:cache-completions key root + path-modtimes completion-table) + completion-table)))) + +(defvar lib-complete:max-cache-size 40 + "*Maximum number of search paths which are cached.") + +(defun lib-complete:cache-completions (key root modtimes table) + (let* ((cache-entry (assoc key lib-complete:cache)) + (cache-records (cdr cache-entry)) + (new-cache-records (list (list root modtimes table)))) + (if (not cache-entry) nil + ;; Remove old cache entry + (setq lib-complete:cache (delq cache-entry lib-complete:cache)) + ;; Copy non-redundant entries from old cache entry + (while cache-records + (if (or (equal root (nth 0 (car cache-records))) + (lib-complete:better-root root (nth 0 (car cache-records)))) + nil + (setq new-cache-records + (cons (car cache-records) new-cache-records))) + (setq cache-records (cdr cache-records)))) + ;; Add entry to front of cache + (setq lib-complete:cache + (cons (cons key (nreverse new-cache-records)) lib-complete:cache)) + ;; Trim cache + (let ((tail (nthcdr lib-complete:max-cache-size lib-complete:cache))) + (if tail (setcdr tail nil))))) + +;;=== Read a filename, with completion in a search path =================== + +(defun read-library-internal (FILE FILTER FLAG) + "Don't call this." + ;; Relies on read-library-internal-search-path being let-bound + (let ((completion-table + (lib-complete:get-completion-table + FILE read-library-internal-search-path FILTER))) + (cond + ((not completion-table) nil) + ;; Completion table is filtered before use, so the PREDICATE + ;; argument is redundant. + ((eq FLAG nil) (try-completion FILE completion-table nil)) + ((eq FLAG t) (all-completions FILE completion-table nil)) + ((eq FLAG 'lambda) (and (intern-soft FILE completion-table) t)) + ))) + +(defun read-library (PROMPT SEARCH-PATH &optional DEFAULT MUST-MATCH + FULL FILTER) + "Read library name, prompting with PROMPT and completing in directories +from SEARCH-PATH. A nil in the search path represents the current +directory. Completions for a given search-path are cached, with the +cache being invalidated whenever one of the directories on the path changes. +Default to DEFAULT if user enters a null string. +Optional fourth arg MUST-MATCH non-nil means require existing file's name. + Non-nil and non-t means also require confirmation after completion. +Optional fifth argument FULL non-nil causes a full pathname, rather than a + relative pathname, to be returned. Note that FULL implies MUST-MATCH. +Optional sixth argument FILTER can be used to provide a function to + filter the completions. This function is passed the filename, and should + return a transformed filename (possibly a null transformation) or nil, + indicating that the filename should not be included in the completions." + (let* ((read-library-internal-search-path SEARCH-PATH) + (library (completing-read PROMPT 'read-library-internal + FILTER (or MUST-MATCH FULL) nil))) + (cond + ((equal library "") DEFAULT) + (FULL (locate-file library read-library-internal-search-path + ;; decompression doesn't work with Mule -slb + (if (featurep 'mule) + ".el:.elc" + ".el:.el.gz:.elc"))) + (t library)))) + +;; NOTE: as a special case, read-library may be used to read a filename +;; relative to the current directory, returning a *relative* pathname +;; (read-file-name returns a full pathname). +;; +;; eg. (read-library "Local header: " '(nil) nil) + +(defun get-library-path () + "Front end to read-library" + (read-library "Find Library file: " load-path nil t t + (function (lambda (fn) + (cond + ;; decompression doesn't work with mule -slb + ((string-match (if (featurep 'mule) + "\\.el$" + "\\.el\\(\\.gz\\)?$") fn) + (substring fn 0 (match-beginning 0)))))) + )) + +;;=== Replacement for load-library with completion ======================== + +(defun load-library (library) + "Load the library named LIBRARY. +This is an interface to the function `load'." + (interactive + (list (read-library "Load Library: " load-path nil nil nil + (function (lambda (fn) + (cond + ((string-match "\\.elc?$" fn) + (substring fn 0 (match-beginning 0)))))) + ))) + (load library)) + +;;=== find-library with completion (Author: Heiko Muenkel) =================== + +(defun find-library (library &optional codesys) + "Find and edit the source for the library named LIBRARY. +The extension of the LIBRARY must be omitted. +Under XEmacs/Mule, the optional second argument specifies the +coding system to use when decoding the file. Interactively, +with a prefix argument, you will be prompted for the coding system." + (interactive + (list (get-library-path) + (if current-prefix-arg + (read-coding-system "Coding System: ")))) + (find-file library codesys)) + +(defun find-library-other-window (library &optional codesys) + "Load the library named LIBRARY in another window. +Under XEmacs/Mule, the optional second argument specifies the +coding system to use when decoding the file. Interactively, +with a prefix argument, you will be prompted for the coding system." + (interactive + (list (get-library-path) + (if current-prefix-arg + (read-coding-system "Coding System: ")))) + (find-file-other-window library codesys)) +#+infodock (defalias 'lib-edit-other-window 'find-library-other-window) + +(defun find-library-other-frame (library &optional codesys) + "Load the library named LIBRARY in a newly-created frame. +Under XEmacs/Mule, the optional second argument specifies the +coding system to use when decoding the file. Interactively, +with a prefix argument, you will be prompted for the coding system." + (interactive + (list (get-library-path) + (if current-prefix-arg + (read-coding-system "Coding System: ")))) + (find-file-other-frame library codesys)) + +; This conflicts with an existing binding +;(define-key global-map "\C-xl" 'find-library) +(define-key global-map "\C-x4l" 'find-library-other-window) +(define-key global-map "\C-x5l" 'find-library-other-frame) + +#+infodock (defalias 'lib-where-is 'locate-library) + +#+infodock (provide 'lib) +(provide 'lib-complete) + +;;; lib-complete.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/lisp-mode.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,1007 @@ +;;; lisp-mode.el --- Lisp mode, and its idiosyncratic commands. + +;; Copyright (C) 1985, 1996, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1995 Tinker Systems + +;; Maintainer: FSF +;; Keywords: lisp, languages, dumped + +;; 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.34 (but starting to diverge). + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;; The base major mode for editing Lisp code (used also for Emacs Lisp). +;; This mode is documented in the Emacs manual + +;; July/05/97 slb Converted to use easymenu. + +;;; Code: + +(defvar lisp-mode-syntax-table nil "") +(defvar emacs-lisp-mode-syntax-table nil "") +(defvar lisp-mode-abbrev-table nil "") + +;; XEmacs change +(defvar lisp-interaction-mode-popup-menu nil) +(defvar lisp-interaction-mode-popup-menu-1 + (purecopy '("Lisp-Interaction" + ["Evaluate Last S-expression" eval-last-sexp t] + ["Evaluate Entire Buffer" eval-current-buffer t] + ["Evaluate Region" eval-region (region-exists-p)] + "---" + ["Evaluate This Defun" eval-defun t] + ;; FSF says "Instrument Function for Debugging" + ["Debug This Defun" edebug-defun t] + "---" + ["Trace a Function" trace-function-background t] + ["Untrace All Functions" untrace-all (fboundp 'untrace-all)] + "---" + ["Comment Out Region" comment-region (region-exists-p)] + ["Indent Region" indent-region (region-exists-p)] + ["Indent Line" lisp-indent-line t] + "---" + ["Debug On Error" (setq debug-on-error (not debug-on-error)) + :style toggle :selected debug-on-error] + ["Debug On Quit" (setq debug-on-quit (not debug-on-quit)) + :style toggle :selected debug-on-quit] + ["Debug on Signal" (setq debug-on-signal (not debug-on-signal)) + :style toggle :selected debug-on-signal] + ))) + +(defvar emacs-lisp-mode-popup-menu nil) +(defvar emacs-lisp-mode-popup-menu-1 + (purecopy + (nconc + '("Emacs-Lisp" + ["Byte-compile This File" emacs-lisp-byte-compile t] + ["Byte-recompile Directory..." byte-recompile-directory t] + "---") + (cdr lisp-interaction-mode-popup-menu-1)))) + +;Don't have a menubar entry in Lisp Interaction mode. Otherwise, the +;*scratch* buffer has a Lisp menubar item! Very confusing. +;(defvar lisp-interaction-mode-menubar-menu +; (purecopy (cons "Lisp" (cdr lisp-interaction-mode-popup-menu)))) + +(defvar emacs-lisp-mode-menubar-menu nil) +(defvar emacs-lisp-mode-menubar-menu-1 + (purecopy (cons "Lisp" (cdr emacs-lisp-mode-popup-menu-1)))) + +(if (not emacs-lisp-mode-syntax-table) + (let ((i 0)) + (setq emacs-lisp-mode-syntax-table (make-syntax-table)) + (while (< i ?0) + (modify-syntax-entry i "_ " emacs-lisp-mode-syntax-table) + (setq i (1+ i))) + (setq i (1+ ?9)) + (while (< i ?A) + (modify-syntax-entry i "_ " emacs-lisp-mode-syntax-table) + (setq i (1+ i))) + (setq i (1+ ?Z)) + (while (< i ?a) + (modify-syntax-entry i "_ " emacs-lisp-mode-syntax-table) + (setq i (1+ i))) + (setq i (1+ ?z)) + (while (< i 128) + (modify-syntax-entry i "_ " emacs-lisp-mode-syntax-table) + (setq i (1+ i))) + (modify-syntax-entry ? " " emacs-lisp-mode-syntax-table) + (modify-syntax-entry ?\t " " emacs-lisp-mode-syntax-table) + (modify-syntax-entry ?\n "> " emacs-lisp-mode-syntax-table) + ;; Give CR the same syntax as newline, for selective-display. + (modify-syntax-entry ?\^m "> " emacs-lisp-mode-syntax-table) + ;; XEmacs change + ;; Treat ^L as whitespace. + (modify-syntax-entry ?\f " " emacs-lisp-mode-syntax-table) + (modify-syntax-entry ?\; "< " emacs-lisp-mode-syntax-table) + (modify-syntax-entry ?` "' " emacs-lisp-mode-syntax-table) + (modify-syntax-entry ?' "' " emacs-lisp-mode-syntax-table) + (modify-syntax-entry ?, "' " emacs-lisp-mode-syntax-table) + ;; Used to be singlequote; changed for flonums. + (modify-syntax-entry ?. "_ " emacs-lisp-mode-syntax-table) + (modify-syntax-entry ?# "' " emacs-lisp-mode-syntax-table) + (modify-syntax-entry ?\" "\" " emacs-lisp-mode-syntax-table) + (modify-syntax-entry ?\\ "\\ " emacs-lisp-mode-syntax-table) + (modify-syntax-entry ?\( "() " emacs-lisp-mode-syntax-table) + (modify-syntax-entry ?\) ")( " emacs-lisp-mode-syntax-table) + (modify-syntax-entry ?\[ "(] " emacs-lisp-mode-syntax-table) + (modify-syntax-entry ?\] ")[ " emacs-lisp-mode-syntax-table))) + +(if (not lisp-mode-syntax-table) + (progn (setq lisp-mode-syntax-table + (copy-syntax-table emacs-lisp-mode-syntax-table)) + (modify-syntax-entry ?\| "\" " lisp-mode-syntax-table) + (modify-syntax-entry ?\[ "_ " lisp-mode-syntax-table) + ;; XEmacs changes + (modify-syntax-entry ?\] "_ " lisp-mode-syntax-table) + ;; + ;; If emacs was compiled with NEW_SYNTAX, then do + ;; CL's #| |# block comments. + (if (= 8 (length (parse-partial-sexp (point) (point)))) + (progn + (modify-syntax-entry ?# "' 58" lisp-mode-syntax-table) + (modify-syntax-entry ?| ". 67" lisp-mode-syntax-table)) + ;; else, old style + (modify-syntax-entry ?\| "\" " lisp-mode-syntax-table)))) + +(define-abbrev-table 'lisp-mode-abbrev-table ()) + +;(defvar lisp-imenu-generic-expression +; '( +; (nil +; "^\\s-*(def\\(un\\|subst\\|macro\\|advice\\)\\s-+\\([-A-Za-z0-9+]+\\)" 2) +; ("Variables" +; "^\\s-*(def\\(var\\|const\\)\\s-+\\([-A-Za-z0-9+]+\\)" 2) +; ("Types" +; "^\\s-*(def\\(type\\|struct\\|class\\|ine-condition\\)\\s-+\\([-A-Za-z0-9+]+\\)" +; 2)) +; +; "Imenu generic expression for Lisp mode. See `imenu-generic-expression'.") + +(defun lisp-mode-variables (lisp-syntax) + (cond (lisp-syntax + (set-syntax-table lisp-mode-syntax-table))) + (setq local-abbrev-table lisp-mode-abbrev-table) + (make-local-variable 'paragraph-start) + (setq paragraph-start (concat page-delimiter "\\|$" )) + (make-local-variable 'paragraph-separate) + (setq paragraph-separate paragraph-start) + (make-local-variable 'paragraph-ignore-fill-prefix) + (setq paragraph-ignore-fill-prefix t) + (make-local-variable 'fill-paragraph-function) + (setq fill-paragraph-function 'lisp-fill-paragraph) + ;; Adaptive fill mode gets in the way of auto-fill, + ;; and should make no difference for explicit fill + ;; because lisp-fill-paragraph should do the job. + (make-local-variable 'adaptive-fill-mode) + (setq adaptive-fill-mode nil) + (make-local-variable 'indent-line-function) + (setq indent-line-function 'lisp-indent-line) + (make-local-variable 'indent-region-function) + (setq indent-region-function 'lisp-indent-region) + (make-local-variable 'parse-sexp-ignore-comments) + (setq parse-sexp-ignore-comments t) + (make-local-variable 'outline-regexp) + (setq outline-regexp ";;; \\|(....") + (make-local-variable 'comment-start) + (setq comment-start ";") + ;; XEmacs change + (set (make-local-variable 'block-comment-start) ";;") + (make-local-variable 'comment-start-skip) + ;; Look within the line for a ; following an even number of backslashes + ;; after either a non-backslash or the line beginning. + (setq comment-start-skip "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *") + (make-local-variable 'comment-column) + (setq comment-column 40) + (make-local-variable 'comment-indent-function) + (setq comment-indent-function 'lisp-comment-indent) + ;; XEmacs changes +; (make-local-variable 'imenu-generic-expression) +; (setq imenu-generic-expression lisp-imenu-generic-expression) + (set (make-local-variable 'dabbrev-case-fold-search) nil) + (set (make-local-variable 'dabbrev-case-replace) nil) + ) + + +(defvar shared-lisp-mode-map () + "Keymap for commands shared by all sorts of Lisp modes.") + +(if shared-lisp-mode-map + () + (setq shared-lisp-mode-map (make-sparse-keymap)) + ;; XEmacs changes + (set-keymap-name shared-lisp-mode-map 'shared-lisp-mode-map) + (define-key shared-lisp-mode-map "\M-;" 'lisp-indent-for-comment) + (define-key shared-lisp-mode-map "\e\C-q" 'indent-sexp)) + +(defvar emacs-lisp-mode-map () + "Keymap for Emacs Lisp mode. +All commands in `shared-lisp-mode-map' are inherited by this map.") + +(if emacs-lisp-mode-map + () + ;; XEmacs: Ignore FSF nconc stuff + (setq emacs-lisp-mode-map (make-sparse-keymap)) + (set-keymap-name emacs-lisp-mode-map 'emacs-lisp-mode-map) + (set-keymap-parents emacs-lisp-mode-map (list shared-lisp-mode-map)) + (define-key emacs-lisp-mode-map "\e\t" 'lisp-complete-symbol) + (define-key emacs-lisp-mode-map "\e\C-x" 'eval-defun) + ;; XEmacs: Not sure what the FSF menu bindings are. I hope XEmacs + ;; doesn't need them. +) + +(defun emacs-lisp-byte-compile () + "Byte compile the file containing the current buffer." + (interactive) + (if buffer-file-name + ;; XEmacs change. Force buffer save first + (progn + (save-buffer) + (byte-compile-file buffer-file-name)) + (error "The buffer must be saved in a file first."))) + +(defun emacs-lisp-byte-compile-and-load () + "Byte-compile the current file (if it has changed), then load compiled code." + (interactive) + (or buffer-file-name + (error "The buffer must be saved in a file first")) + (require 'bytecomp) + ;; Recompile if file or buffer has changed since last compilation. + (if (and (buffer-modified-p) + (y-or-n-p (format "save buffer %s first? " (buffer-name)))) + (save-buffer)) + (let ((compiled-file-name (byte-compile-dest-file buffer-file-name))) + (if (file-newer-than-file-p compiled-file-name buffer-file-name) + (load-file compiled-file-name) + (byte-compile-file buffer-file-name t)))) + +(defun emacs-lisp-mode () + "Major mode for editing Lisp code to run in Emacs. +Commands: +Delete converts tabs to spaces as it moves back. +Blank lines separate paragraphs. Semicolons start comments. +\\{emacs-lisp-mode-map} +Entry to this mode calls the value of `emacs-lisp-mode-hook' +if that value is non-nil." + (interactive) + (kill-all-local-variables) + (use-local-map emacs-lisp-mode-map) + (set-syntax-table emacs-lisp-mode-syntax-table) + ;; XEmacs changes + (setq major-mode 'emacs-lisp-mode + ;; mode-popup-menu emacs-lisp-mode-popup-menu + mode-name "Emacs-Lisp") + ;; (if (and (featurep 'menubar) + ;; current-menubar) + ;; (progn + ;; make a local copy of the menubar, so our modes don't + ;; change the global menubar + ;; (set-buffer-menubar current-menubar) + ;; (add-submenu nil emacs-lisp-mode-menubar-menu))) + (unless emacs-lisp-mode-popup-menu + (easy-menu-define emacs-lisp-mode-popup-menu emacs-lisp-mode-map "" + emacs-lisp-mode-popup-menu-1)) + (easy-menu-add emacs-lisp-mode-popup-menu) + (lisp-mode-variables nil) + (run-hooks 'emacs-lisp-mode-hook)) + +(defvar lisp-mode-map () + "Keymap for ordinary Lisp mode. +All commands in `shared-lisp-mode-map' are inherited by this map.") + +(if lisp-mode-map + () + ;; XEmacs changes + (setq lisp-mode-map (make-sparse-keymap)) + (set-keymap-name lisp-mode-map 'lisp-mode-map) + (set-keymap-parents lisp-mode-map (list shared-lisp-mode-map)) + (define-key lisp-mode-map "\e\C-x" 'lisp-send-defun) + ;; gag, no. use ilisp. -jwz +;; (define-key lisp-mode-map "\C-c\C-z" 'run-lisp) + ) + +(defun lisp-mode () + "Major mode for editing Lisp code for Lisps other than GNU Emacs Lisp. +Commands: +Delete converts tabs to spaces as it moves back. +Blank lines separate paragraphs. Semicolons start comments. +\\{lisp-mode-map} +Note that `run-lisp' may be used either to start an inferior Lisp job +or to switch back to an existing one. + +Entry to this mode calls the value of `lisp-mode-hook' +if that value is non-nil." + (interactive) + (kill-all-local-variables) + (use-local-map lisp-mode-map) + (setq major-mode 'lisp-mode) + (setq mode-name "Lisp") + (lisp-mode-variables t) + (set-syntax-table lisp-mode-syntax-table) + (run-hooks 'lisp-mode-hook)) + +;; This will do unless shell.el is loaded. +;; XEmacs change +(defun lisp-send-defun () + "Send the current defun to the Lisp process made by \\[run-lisp]." + (interactive) + (error "Process lisp does not exist")) + +;; XEmacs change: emacs-lisp-mode-map is a more appropriate parent. +(defvar lisp-interaction-mode-map () + "Keymap for Lisp Interaction mode. +All commands in `shared-lisp-mode-map' are inherited by this map.") + +(if lisp-interaction-mode-map + () + ;; XEmacs set keymap our way + (setq lisp-interaction-mode-map (make-sparse-keymap)) + (set-keymap-name lisp-interaction-mode-map 'lisp-interaction-mode-map) + (set-keymap-parents lisp-interaction-mode-map (list emacs-lisp-mode-map)) + (define-key lisp-interaction-mode-map "\e\C-x" 'eval-defun) + (define-key lisp-interaction-mode-map "\e\t" 'lisp-complete-symbol) + (define-key lisp-interaction-mode-map "\n" 'eval-print-last-sexp)) + +(defun lisp-interaction-mode () + "Major mode for typing and evaluating Lisp forms. +Like Lisp mode except that \\[eval-print-last-sexp] evals the Lisp expression +before point, and prints its value into the buffer, advancing point. + +Commands: +Delete converts tabs to spaces as it moves back. +Paragraphs are separated only by blank lines. +Semicolons start comments. +\\{lisp-interaction-mode-map} +Entry to this mode calls the value of `lisp-interaction-mode-hook' +if that value is non-nil." + (interactive) + (kill-all-local-variables) + (use-local-map lisp-interaction-mode-map) + (setq major-mode 'lisp-interaction-mode) + (setq mode-name "Lisp Interaction") + ;; XEmacs change + ;; (setq mode-popup-menu lisp-interaction-mode-popup-menu) + (unless lisp-interaction-mode-popup-menu + (easy-menu-define lisp-interaction-mode-popup-menu + lisp-interaction-mode-map + "" + lisp-interaction-mode-popup-menu-1)) + (easy-menu-add lisp-interaction-mode-popup-menu) + + (set-syntax-table emacs-lisp-mode-syntax-table) + (lisp-mode-variables nil) + (run-hooks 'lisp-interaction-mode-hook)) + +(defun eval-print-last-sexp () + "Evaluate sexp before point; print value into current buffer." + (interactive) + (let ((standard-output (current-buffer))) + (terpri) + (eval-last-sexp t) + (terpri))) + +;; XEmacs change +(defcustom eval-interactive-verbose t + "*Non-nil means that interactive evaluation can print messages. +The messages are printed when the expression is treated differently +using `\\[eval-last-sexp]' and `\\[eval-defun]' than it than it would have been +treated noninteractively. + +The printed messages are \"defvar treated as defconst\" and \"defcustom + evaluation forced\". See `eval-interactive' for more details." + :type 'boolean + :group 'lisp) + +(defun eval-interactive (expr) + "Like `eval' except that it transforms defvars to defconsts. +The evaluation of defcustom forms is forced." + (cond ((and (consp expr) + (eq (car expr) 'defvar) + (> (length expr) 2)) + (eval (cons 'defconst (cdr expr))) + (and eval-interactive-verbose + (message "defvar treated as defconst")) + (sit-for 1) + (message "") + (nth 1 expr)) + ((and (consp expr) + (eq (car expr) 'defcustom) + (> (length expr) 2) + (default-boundp (nth 1 expr))) + ;; Force variable to be bound + (set-default (nth 1 expr) (eval (nth 2 expr))) + ;; And evaluate the defcustom + (eval expr) + (and eval-interactive-verbose + (message "defcustom evaluation forced")) + (sit-for 1) + (message "") + (nth 1 expr)) + (t + (eval expr)))) + +;; XEmacs change, based on Bob Weiner suggestion +(defun eval-last-sexp (eval-last-sexp-arg-internal) ;dynamic scoping wonderment + "Evaluate sexp before point; print value in minibuffer. +With argument, print output into current buffer." + (interactive "P") + (let ((standard-output (if eval-last-sexp-arg-internal (current-buffer) t)) + (opoint (point))) + (prin1 (let ((stab (syntax-table)) + expr) + (eval-interactive + (unwind-protect + (save-excursion + (set-syntax-table emacs-lisp-mode-syntax-table) + (forward-sexp -1) + (save-restriction + (narrow-to-region (point-min) opoint) + (setq expr (read (current-buffer))) + (if (and (consp expr) + (eq (car expr) 'interactive)) + (list 'quote + (call-interactively + (eval (` (lambda (&rest args) + (, expr) args))))) + expr))) + (set-syntax-table stab))))))) + +(defun eval-defun (eval-defun-arg-internal) + "Evaluate defun that point is in or before. +Print value in minibuffer. +With argument, insert value in current buffer after the defun." + (interactive "P") + (let ((standard-output (if eval-defun-arg-internal (current-buffer) t))) + (prin1 (eval-interactive (save-excursion + (end-of-defun) + (beginning-of-defun) + (read (current-buffer))))))) + + +(defun lisp-comment-indent () + (if (looking-at "\\s<\\s<\\s<") + (current-column) + (if (looking-at "\\s<\\s<") + (let ((tem (calculate-lisp-indent))) + (if (listp tem) (car tem) tem)) + (skip-chars-backward " \t") + (max (if (bolp) 0 (1+ (current-column))) + comment-column)))) + +;; XEmacs change +(defun lisp-indent-for-comment () + "Indent this line's comment appropriately, or insert an empty comment. +If adding a new comment on a blank line, use `block-comment-start' instead +of `comment-start' to open the comment." + ;; by Stig@hackvan.com + ;; #### - This functionality, the recognition of block-comment-{start,end}, + ;; will perhaps be standardized across modes and move to indent-for-comment. + (interactive) + (if (and block-comment-start + (save-excursion (beginning-of-line) (looking-at "^[ \t]*$"))) + (insert block-comment-start)) + (indent-for-comment)) + +(defconst lisp-indent-offset nil "") +(defconst lisp-indent-function 'lisp-indent-function "") + +(defun lisp-indent-line (&optional whole-exp) + "Indent current line as Lisp code. +With argument, indent any additional lines of the same expression +rigidly along with this one." + (interactive "P") + (let ((indent (calculate-lisp-indent)) shift-amt beg end + (pos (- (point-max) (point)))) + (beginning-of-line) + (setq beg (point)) + (skip-chars-forward " \t") + (if (looking-at "\\s<\\s<\\s<") + ;; Don't alter indentation of a ;;; comment line. + (goto-char (- (point-max) pos)) + (if (and (looking-at "\\s<") (not (looking-at "\\s<\\s<"))) + ;; Single-semicolon comment lines should be indented + ;; as comment lines, not as code. + (progn (indent-for-comment) (forward-char -1)) + (if (listp indent) (setq indent (car indent))) + (setq shift-amt (- indent (current-column))) + (if (zerop shift-amt) + nil + (delete-region beg (point)) + (indent-to indent))) + ;; If initial point was within line's indentation, + ;; position after the indentation. Else stay at same point in text. + (if (> (- (point-max) pos) (point)) + (goto-char (- (point-max) pos))) + ;; If desired, shift remaining lines of expression the same amount. + (and whole-exp (not (zerop shift-amt)) + (save-excursion + (goto-char beg) + (forward-sexp 1) + (setq end (point)) + (goto-char beg) + (forward-line 1) + (setq beg (point)) + (> end beg)) + (indent-code-rigidly beg end shift-amt))))) + +(defvar calculate-lisp-indent-last-sexp) + +(defun calculate-lisp-indent (&optional parse-start) + "Return appropriate indentation for current line as Lisp code. +In usual case returns an integer: the column to indent to. +Can instead return a list, whose car is the column to indent to. +This means that following lines at the same level of indentation +should not necessarily be indented the same way. +The second element of the list is the buffer position +of the start of the containing expression." + (save-excursion + (beginning-of-line) + (let ((indent-point (point)) + ;; XEmacs change (remove paren-depth) + state ;;paren-depth + ;; setting this to a number inhibits calling hook + (desired-indent nil) + (retry t) + calculate-lisp-indent-last-sexp containing-sexp) + (if parse-start + (goto-char parse-start) + (beginning-of-defun)) + ;; Find outermost containing sexp + (while (< (point) indent-point) + (setq state (parse-partial-sexp (point) indent-point 0))) + ;; Find innermost containing sexp + (while (and retry + state + ;; XEmacs change (remove paren-depth) + (> ;;(setq paren-depth (elt state 0)) + (elt state 0) + 0)) + (setq retry nil) + (setq calculate-lisp-indent-last-sexp (elt state 2)) + (setq containing-sexp (elt state 1)) + ;; Position following last unclosed open. + (goto-char (1+ containing-sexp)) + ;; Is there a complete sexp since then? + (if (and calculate-lisp-indent-last-sexp + (> calculate-lisp-indent-last-sexp (point))) + ;; Yes, but is there a containing sexp after that? + (let ((peek (parse-partial-sexp calculate-lisp-indent-last-sexp + indent-point 0))) + (if (setq retry (car (cdr peek))) (setq state peek))))) + (if retry + nil + ;; Innermost containing sexp found + (goto-char (1+ containing-sexp)) + (if (not calculate-lisp-indent-last-sexp) + ;; indent-point immediately follows open paren. + ;; Don't call hook. + (setq desired-indent (current-column)) + ;; Find the start of first element of containing sexp. + (parse-partial-sexp (point) calculate-lisp-indent-last-sexp 0 t) + (cond ((looking-at "\\s(") + ;; First element of containing sexp is a list. + ;; Indent under that list. + ) + ((> (save-excursion (forward-line 1) (point)) + calculate-lisp-indent-last-sexp) + ;; This is the first line to start within the containing sexp. + ;; It's almost certainly a function call. + (if (= (point) calculate-lisp-indent-last-sexp) + ;; Containing sexp has nothing before this line + ;; except the first element. Indent under that element. + nil + ;; Skip the first element, find start of second (the first + ;; argument of the function call) and indent under. + (progn (forward-sexp 1) + (parse-partial-sexp (point) + calculate-lisp-indent-last-sexp + 0 t))) + (backward-prefix-chars)) + (t + ;; Indent beneath first sexp on same line as + ;; calculate-lisp-indent-last-sexp. Again, it's + ;; almost certainly a function call. + (goto-char calculate-lisp-indent-last-sexp) + (beginning-of-line) + (parse-partial-sexp (point) calculate-lisp-indent-last-sexp + 0 t) + (backward-prefix-chars))))) + ;; Point is at the point to indent under unless we are inside a string. + ;; Call indentation hook except when overridden by lisp-indent-offset + ;; or if the desired indentation has already been computed. + (let ((normal-indent (current-column))) + (cond ((elt state 3) + ;; Inside a string, don't change indentation. + (goto-char indent-point) + (skip-chars-forward " \t") + (current-column)) + (desired-indent) + ((and (boundp 'lisp-indent-function) + lisp-indent-function + (not retry)) + (or (funcall lisp-indent-function indent-point state) + normal-indent)) + ;; XEmacs change: + ;; lisp-indent-offset shouldn't override lisp-indent-function ! + ((and (integerp lisp-indent-offset) containing-sexp) + ;; Indent by constant offset + (goto-char containing-sexp) + (+ normal-indent lisp-indent-offset)) + (t + normal-indent)))))) + +(defun lisp-indent-function (indent-point state) + ;; free reference to `calculate-lisp-indent-last-sexp' + ;; in #'calculate-lisp-indent + (let ((normal-indent (current-column))) + (goto-char (1+ (elt state 1))) + (parse-partial-sexp (point) calculate-lisp-indent-last-sexp 0 t) + (if (and (elt state 2) + (not (looking-at "\\sw\\|\\s_"))) + ;; car of form doesn't seem to be a a symbol + (progn + (if (not (> (save-excursion (forward-line 1) (point)) + calculate-lisp-indent-last-sexp)) + (progn (goto-char calculate-lisp-indent-last-sexp) + (beginning-of-line) + (parse-partial-sexp (point) + calculate-lisp-indent-last-sexp 0 t))) + ;; Indent under the list or under the first sexp on the same + ;; line as calculate-lisp-indent-last-sexp. Note that first + ;; thing on that line has to be complete sexp since we are + ;; inside the innermost containing sexp. + (backward-prefix-chars) + (current-column)) + (let ((function (buffer-substring (point) + (progn (forward-sexp 1) (point)))) + method) + (setq method (or (get (intern-soft function) 'lisp-indent-function) + (get (intern-soft function) 'lisp-indent-hook))) + (cond ((or (eq method 'defun) + (and (null method) + (> (length function) 3) + (string-match "\\`def" function))) + (lisp-indent-defform state indent-point)) + ((integerp method) + (lisp-indent-specform method state + indent-point normal-indent)) + (method + (funcall method state indent-point))))))) + +(defconst lisp-body-indent 2 + "Number of columns to indent the second line of a `(def...)' form.") + +(defun lisp-indent-specform (count state indent-point normal-indent) + (let ((containing-form-start (elt state 1)) + (i count) + body-indent containing-form-column) + ;; Move to the start of containing form, calculate indentation + ;; to use for non-distinguished forms (> count), and move past the + ;; function symbol. lisp-indent-function guarantees that there is at + ;; least one word or symbol character following open paren of containing + ;; form. + (goto-char containing-form-start) + (setq containing-form-column (current-column)) + (setq body-indent (+ lisp-body-indent containing-form-column)) + (forward-char 1) + (forward-sexp 1) + ;; Now find the start of the last form. + (parse-partial-sexp (point) indent-point 1 t) + (while (and (< (point) indent-point) + (condition-case () + (progn + (setq count (1- count)) + (forward-sexp 1) + (parse-partial-sexp (point) indent-point 1 t)) + (error nil)))) + ;; Point is sitting on first character of last (or count) sexp. + (if (> count 0) + ;; A distinguished form. If it is the first or second form use double + ;; lisp-body-indent, else normal indent. With lisp-body-indent bound + ;; to 2 (the default), this just happens to work the same with if as + ;; the older code, but it makes unwind-protect, condition-case, + ;; with-output-to-temp-buffer, et. al. much more tasteful. The older, + ;; less hacked, behavior can be obtained by replacing below with + ;; (list normal-indent containing-form-start). + (if (<= (- i count) 1) + (list (+ containing-form-column (* 2 lisp-body-indent)) + containing-form-start) + (list normal-indent containing-form-start)) + ;; A non-distinguished form. Use body-indent if there are no + ;; distinguished forms and this is the first undistinguished form, + ;; or if this is the first undistinguished form and the preceding + ;; distinguished form has indentation at least as great as body-indent. + (if (or (and (= i 0) (= count 0)) + (and (= count 0) (<= body-indent normal-indent))) + body-indent + normal-indent)))) + +(defun lisp-indent-defform (state indent-point) + (goto-char (car (cdr state))) + (forward-line 1) + (if (> (point) (car (cdr (cdr state)))) + (progn + (goto-char (car (cdr state))) + (+ lisp-body-indent (current-column))))) + + +;; (put 'progn 'lisp-indent-function 0), say, causes progn to be indented +;; like defun if the first form is placed on the next line, otherwise +;; it is indented like any other form (i.e. forms line up under first). + +(put 'lambda 'lisp-indent-function 'defun) +(put 'autoload 'lisp-indent-function 'defun) +(put 'progn 'lisp-indent-function 0) +(put 'prog1 'lisp-indent-function 1) +(put 'prog2 'lisp-indent-function 2) +(put 'save-excursion 'lisp-indent-function 0) +(put 'save-window-excursion 'lisp-indent-function 0) +(put 'save-selected-window 'lisp-indent-function 0) +(put 'save-restriction 'lisp-indent-function 0) +(put 'save-match-data 'lisp-indent-function 0) +(put 'let 'lisp-indent-function 1) +(put 'let* 'lisp-indent-function 1) +(put 'while 'lisp-indent-function 1) +(put 'if 'lisp-indent-function 2) +(put 'catch 'lisp-indent-function 1) +(put 'condition-case 'lisp-indent-function 2) +(put 'unwind-protect 'lisp-indent-function 1) +(put 'save-current-buffer 'lisp-indent-function 0) +(put 'with-current-buffer 'lisp-indent-function 1) +(put 'with-temp-file 'lisp-indent-function 1) +(put 'with-temp-buffer 'lisp-indent-function 0) +(put 'with-output-to-string 'lisp-indent-function 0) +(put 'with-output-to-temp-buffer 'lisp-indent-function 1) +(put 'display-message 'lisp-indent-function 1) +(put 'display-warning 'lisp-indent-function 1) +(put 'global-set-key 'lisp-indent-function 1) + +(defun indent-sexp (&optional endpos) + "Indent each line of the list starting just after point. +If optional arg ENDPOS is given, indent each line, stopping when +ENDPOS is encountered." + (interactive) + (let ((indent-stack (list nil)) + (next-depth 0) + ;; If ENDPOS is non-nil, use nil as STARTING-POINT + ;; so that calculate-lisp-indent will find the beginning of + ;; the defun we are in. + ;; If ENDPOS is nil, it is safe not to scan before point + ;; since every line we indent is more deeply nested than point is. + (starting-point (if endpos nil (point))) + (last-point (point)) + last-depth bol outer-loop-done inner-loop-done state this-indent) + (or endpos + ;; Get error now if we don't have a complete sexp after point. + (save-excursion (forward-sexp 1))) + (save-excursion + (setq outer-loop-done nil) + (while (if endpos (< (point) endpos) + (not outer-loop-done)) + (setq last-depth next-depth + inner-loop-done nil) + ;; Parse this line so we can learn the state + ;; to indent the next line. + ;; This inner loop goes through only once + ;; unless a line ends inside a string. + (while (and (not inner-loop-done) + (not (setq outer-loop-done (eobp)))) + (setq state (parse-partial-sexp (point) (progn (end-of-line) (point)) + nil nil state)) + (setq next-depth (car state)) + ;; If the line contains a comment other than the sort + ;; that is indented like code, + ;; indent it now with indent-for-comment. + ;; Comments indented like code are right already. + ;; In any case clear the in-comment flag in the state + ;; because parse-partial-sexp never sees the newlines. + (if (car (nthcdr 4 state)) + (progn (indent-for-comment) + (end-of-line) + (setcar (nthcdr 4 state) nil))) + ;; If this line ends inside a string, + ;; go straight to next line, remaining within the inner loop, + ;; and turn off the \-flag. + (if (car (nthcdr 3 state)) + (progn + (forward-line 1) + (setcar (nthcdr 5 state) nil)) + (setq inner-loop-done t))) + (and endpos + (<= next-depth 0) + (progn + (setq indent-stack (append indent-stack + (make-list (- next-depth) nil)) + last-depth (- last-depth next-depth) + next-depth 0))) + (or outer-loop-done endpos + (setq outer-loop-done (<= next-depth 0))) + (if outer-loop-done + (forward-line 1) + (while (> last-depth next-depth) + (setq indent-stack (cdr indent-stack) + last-depth (1- last-depth))) + (while (< last-depth next-depth) + (setq indent-stack (cons nil indent-stack) + last-depth (1+ last-depth))) + ;; Now go to the next line and indent it according + ;; to what we learned from parsing the previous one. + (forward-line 1) + (setq bol (point)) + (skip-chars-forward " \t") + ;; But not if the line is blank, or just a comment + ;; (except for double-semi comments; indent them as usual). + (if (or (eobp) (looking-at "\\s<\\|\n")) + nil + (if (and (car indent-stack) + (>= (car indent-stack) 0)) + (setq this-indent (car indent-stack)) + (let ((val (calculate-lisp-indent + (if (car indent-stack) (- (car indent-stack)) + starting-point)))) + (if (integerp val) + (setcar indent-stack + (setq this-indent val)) + (setcar indent-stack (- (car (cdr val)))) + (setq this-indent (car val))))) + (if (/= (current-column) this-indent) + (progn (delete-region bol (point)) + (indent-to this-indent))))) + (or outer-loop-done + (setq outer-loop-done (= (point) last-point)) + (setq last-point (point))))))) + +;; Indent every line whose first char is between START and END inclusive. +(defun lisp-indent-region (start end) + (save-excursion + (let ((endmark (copy-marker end))) + (goto-char start) + (and (bolp) (not (eolp)) + (lisp-indent-line)) + (indent-sexp endmark) + (set-marker endmark nil)))) + +;;;; Lisp paragraph filling commands. + +(defun lisp-fill-paragraph (&optional justify) + "Like \\[fill-paragraph], but handle Emacs Lisp comments. +If any of the current line is a comment, fill the comment or the +paragraph of it that point is in, preserving the comment's indentation +and initial semicolons." + (interactive "P") + (let ( + ;; Non-nil if the current line contains a comment. + has-comment + + ;; Non-nil if the current line contains code and a comment. + has-code-and-comment + + ;; If has-comment, the appropriate fill-prefix for the comment. + comment-fill-prefix + ) + + ;; Figure out what kind of comment we are looking at. + (save-excursion + (beginning-of-line) + (cond + + ;; A line with nothing but a comment on it? + ((looking-at "[ \t]*;[; \t]*") + (setq has-comment t + comment-fill-prefix (buffer-substring (match-beginning 0) + (match-end 0)))) + + ;; A line with some code, followed by a comment? Remember that the + ;; semi which starts the comment shouldn't be part of a string or + ;; character. + ;; XEmacs Try this the FSF and see if it works. +; ((progn +; (while (not (looking-at ";\\|$")) +; (skip-chars-forward "^;\n\"\\\\?") +; (cond +; ((eq (char-after (point)) ?\\) (forward-char 2)) +; ((memq (char-after (point)) '(?\" ??)) (forward-sexp 1)))) +; (looking-at ";+[\t ]*")) +; (setq has-comment t) + ((condition-case nil + (save-restriction + (narrow-to-region (point-min) + (save-excursion (end-of-line) (point))) + (while (not (looking-at ";\\|$")) + (skip-chars-forward "^;\n\"\\\\?") + (cond + ((eq (char-after (point)) ?\\) (forward-char 2)) + ((memq (char-after (point)) '(?\" ??)) (forward-sexp 1)))) + (looking-at ";+[\t ]*")) + (error nil)) + (setq has-comment t has-code-and-comment t) + (setq comment-fill-prefix + (concat (make-string (/ (current-column) 8) ?\t) + (make-string (% (current-column) 8) ?\ ) + (buffer-substring (match-beginning 0) (match-end 0))))))) + + (if (not has-comment) + (fill-paragraph justify) + + ;; Narrow to include only the comment, and then fill the region. + (save-excursion + (save-restriction + (beginning-of-line) + (narrow-to-region + ;; Find the first line we should include in the region to fill. + (save-excursion + (while (and (zerop (forward-line -1)) + (looking-at "^[ \t]*;"))) + ;; We may have gone too far. Go forward again. + (or (looking-at ".*;") + (forward-line 1)) + (point)) + ;; Find the beginning of the first line past the region to fill. + (save-excursion + (while (progn (forward-line 1) + (looking-at "^[ \t]*;"))) + (point))) + + ;; Lines with only semicolons on them can be paragraph boundaries. + (let* ((paragraph-start (concat paragraph-start "\\|[ \t;]*$")) + (paragraph-separate (concat paragraph-start "\\|[ \t;]*$")) + (paragraph-ignore-fill-prefix nil) + (fill-prefix comment-fill-prefix) + (after-line (if has-code-and-comment + (save-excursion + (forward-line 1) (point)))) + (end (progn + (forward-paragraph) + (or (bolp) (newline 1)) + (point))) + ;; If this comment starts on a line with code, + ;; include that like in the filling. + (beg (progn (backward-paragraph) + (if (eq (point) after-line) + (forward-line -1)) + (point)))) + (fill-region-as-paragraph beg end + justify nil + (save-excursion + (goto-char beg) + (if (looking-at fill-prefix) + nil + (re-search-forward comment-start-skip) + (point)))))))) + t)) + +(defun indent-code-rigidly (start end arg &optional nochange-regexp) + "Indent all lines of code, starting in the region, sideways by ARG columns. +Does not affect lines starting inside comments or strings, assuming that +the start of the region is not inside them. + +Called from a program, takes args START, END, COLUMNS and NOCHANGE-REGEXP. +The last is a regexp which, if matched at the beginning of a line, +means don't indent that line." + (interactive "r\np") + (let (state) + (save-excursion + (goto-char end) + (setq end (point-marker)) + (goto-char start) + (or (bolp) + (setq state (parse-partial-sexp (point) + (progn + (forward-line 1) (point)) + nil nil state))) + (while (< (point) end) + (or (car (nthcdr 3 state)) + (and nochange-regexp + (looking-at nochange-regexp)) + ;; If line does not start in string, indent it + (let ((indent (current-indentation))) + (delete-region (point) (progn (skip-chars-forward " \t") (point))) + (or (eolp) + (indent-to (max 0 (+ indent arg)) 0)))) + (setq state (parse-partial-sexp (point) + (progn + (forward-line 1) (point)) + nil nil state)))))) + +(provide 'lisp-mode) + +;;; lisp-mode.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/lisp.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,358 @@ +;;; lisp.el --- Lisp editing commands for XEmacs + +;; Copyright (C) 1985, 1986, 1994, 1997 Free Software Foundation, Inc. + +;; Maintainer: FSF +;; Keywords: lisp, languages, dumped + +;; 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: Emacs/Mule zeta. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;; Lisp editing commands to go with Lisp major mode. + +;; 06/11/1997 - Use char-(after|before) instead of +;; (following|preceding)-char. -slb + +;;; Code: + +;; Note that this variable is used by non-lisp modes too. +(defcustom defun-prompt-regexp nil + "*Non-nil => regexp to ignore, before the character that starts a defun. +This is only necessary if the opening paren or brace is not in column 0. +See `beginning-of-defun'." + :type '(choice (const :tag "none" nil) + regexp) + :group 'lisp) + +(make-variable-buffer-local 'defun-prompt-regexp) + +(defcustom parens-require-spaces t + "Non-nil => `insert-parentheses' should insert whitespace as needed." + :type 'boolean + :group 'editing-basics + :group 'lisp) + +(defun forward-sexp (&optional arg) + "Move forward across one balanced expression (sexp). +With argument, do it that many times. Negative arg -N means +move backward across N balanced expressions." + ;; XEmacs change (for zmacs regions) + (interactive "_p") + (or arg (setq arg 1)) + ;; XEmacs: evil hack! The other half of the evil hack below. + (if (and (> arg 0) (looking-at "#s(")) + (goto-char (+ (point) 2))) + ;; XEmacs change -- don't bomb out if unbalanced sexp + (goto-char (or (scan-sexps (point) arg) (buffer-end arg))) + (if (< arg 0) (backward-prefix-chars)) + ;; XEmacs: evil hack! Skip back over #s so that structures are read + ;; properly. the current cheesified syntax tables just aren't up to + ;; this. + (if (and (< arg 0) + (eq (char-after (point)) ?\() + (>= (- (point) (point-min)) 2) + (eq (char-after (- (point) 1)) ?s) + (eq (char-after (- (point) 2)) ?#)) + (goto-char (- (point) 2)))) + +(defun backward-sexp (&optional arg) + "Move backward across one balanced expression (sexp). +With argument, do it that many times. Negative arg -N means +move forward across N balanced expressions." + ;; XEmacs change (for zmacs regions) + (interactive "_p") + (or arg (setq arg 1)) + (forward-sexp (- arg))) + +(defun mark-sexp (arg) + "Set mark ARG sexps from point. +The place mark goes is the same place \\[forward-sexp] would +move to with the same argument. +Repeat this command to mark more sexps in the same direction." + (interactive "p") + ;; XEmacs change + (mark-something 'mark-sexp 'forward-sexp arg)) + +(defun forward-list (&optional arg) + "Move forward across one balanced group of parentheses. +With argument, do it that many times. +Negative arg -N means move backward across N groups of parentheses." + ;; XEmacs change + (interactive "_p") + (or arg (setq arg 1)) + (goto-char (or (scan-lists (point) arg 0) (buffer-end arg)))) + +(defun backward-list (&optional arg) + "Move backward across one balanced group of parentheses. +With argument, do it that many times. +Negative arg -N means move forward across N groups of parentheses." + ;; XEmacs change (for zmacs regions) + (interactive "_p") + (or arg (setq arg 1)) + (forward-list (- arg))) + +(defun down-list (arg) + "Move forward down one level of parentheses. +With argument, do this that many times. +A negative argument means move backward but still go down a level. +In Lisp programs, an argument is required." + ;; XEmacs change (for zmacs regions) + (interactive "_p") + (let ((inc (if (> arg 0) 1 -1))) + (while (/= arg 0) + (goto-char (or (scan-lists (point) inc -1) (buffer-end arg))) + (setq arg (- arg inc))))) + +(defun backward-up-list (arg) + "Move backward out of one level of parentheses. +With argument, do this that many times. +A negative argument means move forward but still to a less deep spot. +In Lisp programs, an argument is required." + (interactive "_p") + (up-list (- arg))) + +(defun up-list (arg) + "Move forward out of one level of parentheses. +With argument, do this that many times. +A negative argument means move backward but still to a less deep spot. +In Lisp programs, an argument is required." + ;; XEmacs change (for zmacs regions) + (interactive "_p") + (let ((inc (if (> arg 0) 1 -1))) + (while (/= arg 0) + (goto-char (or (scan-lists (point) inc 1) (buffer-end arg))) + (setq arg (- arg inc))))) + +(defun kill-sexp (arg) + "Kill the sexp (balanced expression) following the cursor. +With argument, kill that many sexps after the cursor. +Negative arg -N means kill N sexps before the cursor." + (interactive "p") + (let ((opoint (point))) + (forward-sexp arg) + (kill-region opoint (point)))) + +(defun backward-kill-sexp (arg) + "Kill the sexp (balanced expression) preceding the cursor. +With argument, kill that many sexps before the cursor. +Negative arg -N means kill N sexps after the cursor." + (interactive "p") + (kill-sexp (- arg))) + +(defun beginning-of-defun (&optional arg) + "Move backward to the beginning of a defun. +With argument, do it that many times. Negative arg -N +means move forward to Nth following beginning of defun. +Returns t unless search stops due to beginning or end of buffer. + +Normally a defun starts when there is an char with open-parenthesis +syntax at the beginning of a line. If `defun-prompt-regexp' is +non-nil, then a string which matches that regexp may precede the +open-parenthesis, and point ends up at the beginning of the line." + ;; XEmacs change (for zmacs regions) + (interactive "_p") + (and (beginning-of-defun-raw arg) + (progn (beginning-of-line) t))) + +(defun beginning-of-defun-raw (&optional arg) + "Move point to the character that starts a defun. +This is identical to beginning-of-defun, except that point does not move +to the beginning of the line when `defun-prompt-regexp' is non-nil." + (interactive "p") + (and arg (< arg 0) (not (eobp)) (forward-char 1)) + (and (re-search-backward (if defun-prompt-regexp + (concat "^\\s(\\|" + "\\(" defun-prompt-regexp "\\)\\s(") + "^\\s(") + nil 'move (or arg 1)) + (progn (goto-char (1- (match-end 0)))) t)) + +;; XEmacs change (optional buffer parameter) +(defun buffer-end (arg &optional buffer) + "Return `point-max' of BUFFER if ARG is > 0; return `point-min' otherwise. +BUFFER defaults to the current buffer if omitted." + (if (> arg 0) (point-max buffer) (point-min buffer))) + +(defun end-of-defun (&optional arg) + "Move forward to next end of defun. With argument, do it that many times. +Negative argument -N means move back to Nth preceding end of defun. + +An end of a defun occurs right after the close-parenthesis that matches +the open-parenthesis that starts a defun; see `beginning-of-defun'." + ;; XEmacs change (for zmacs regions) + (interactive "_p") + (if (or (null arg) (= arg 0)) (setq arg 1)) + (let ((first t)) + (while (and (> arg 0) (< (point) (point-max))) + (let ((pos (point))) ; XEmacs -- remove unused npos. + (while (progn + (if (and first + (progn + (end-of-line 1) + (beginning-of-defun-raw 1))) + nil + (or (bobp) (forward-char -1)) + (beginning-of-defun-raw -1)) + (setq first nil) + (forward-list 1) + (skip-chars-forward " \t") + (if (looking-at "\\s<\\|\n") + (forward-line 1)) + (<= (point) pos)))) + (setq arg (1- arg))) + (while (< arg 0) + (let ((pos (point))) + (beginning-of-defun-raw 1) + (forward-sexp 1) + (forward-line 1) + (if (>= (point) pos) + (if (beginning-of-defun-raw 2) + (progn + (forward-list 1) + (skip-chars-forward " \t") + (if (looking-at "\\s<\\|\n") + (forward-line 1))) + (goto-char (point-min))))) + (setq arg (1+ arg))))) + +(defun mark-defun () + "Put mark at end of this defun, point at beginning. +The defun marked is the one that contains point or follows point." + (interactive) + (push-mark (point)) + (end-of-defun) + (push-mark (point) nil t) + (beginning-of-defun) + (re-search-backward "^\n" (- (point) 1) t)) + +(defun narrow-to-defun (&optional arg) + "Make text outside current defun invisible. +The defun visible is the one that contains point or follows point." + (interactive) + (save-excursion + (widen) + (end-of-defun) + (let ((end (point))) + (beginning-of-defun) + (narrow-to-region (point) end)))) + +(defun insert-parentheses (arg) + "Enclose following ARG sexps in parentheses. Leave point after open-paren. +A negative ARG encloses the preceding ARG sexps instead. +No argument is equivalent to zero: just insert `()' and leave point between. +If `parens-require-spaces' is non-nil, this command also inserts a space +before and after, depending on the surrounding characters." + (interactive "P") + (if arg (setq arg (prefix-numeric-value arg)) + (setq arg 0)) + (cond ((> arg 0) (skip-chars-forward " \t")) + ((< arg 0) (forward-sexp arg) (setq arg (- arg)))) + (and parens-require-spaces + (not (bobp)) + (memq (char-syntax (char-before (point))) '(?w ?_ ?\) )) + (insert " ")) + (insert ?\() + (save-excursion + (or (eq arg 0) (forward-sexp arg)) + (insert ?\)) + (and parens-require-spaces + (not (eobp)) + (memq (char-syntax (char-after (point))) '(?w ?_ ?\( )) + (insert " ")))) + +(defun move-past-close-and-reindent () + "Move past next `)', delete indentation before it, then indent after it." + (interactive) + (up-list 1) + (forward-char -1) + (while (save-excursion ; this is my contribution + (let ((before-paren (point))) + (back-to-indentation) + (= (point) before-paren))) + (delete-indentation)) + (forward-char 1) + (newline-and-indent)) + +(defun lisp-complete-symbol () + "Perform completion on Lisp symbol preceding point. +Compare that symbol against the known Lisp symbols. + +The context determines which symbols are considered. +If the symbol starts just after an open-parenthesis, only symbols +with function definitions are considered. Otherwise, all symbols with +function definitions, values or properties are considered." + (interactive) + (let* ((end (point)) + (buffer-syntax (syntax-table)) + (beg (unwind-protect + (save-excursion + ;; XEmacs change + (if emacs-lisp-mode-syntax-table + (set-syntax-table emacs-lisp-mode-syntax-table)) + (backward-sexp 1) + (while (eq (char-syntax (char-after (point))) ?\') + (forward-char 1)) + (point)) + (set-syntax-table buffer-syntax))) + (pattern (buffer-substring beg end)) + (predicate + (if (eq (char-after (1- beg)) ?\() + 'fboundp + ;; XEmacs change + #'(lambda (sym) + (or (boundp sym) (fboundp sym) + (symbol-plist sym))))) + (completion (try-completion pattern obarray predicate))) + (cond ((eq completion t)) + ((null completion) + (message "Can't find completion for \"%s\"" pattern) + (ding)) + ((not (string= pattern completion)) + (delete-region beg end) + (insert completion)) + (t + (message "Making completion list...") + (let ((list (all-completions pattern obarray predicate)) + ;FSFmacs crock unnecessary in XEmacs + ;see minibuf.el + ;(completion-fixup-function + ; (function (lambda () (if (save-excursion + ; (goto-char (max (point-min) + ; (- (point) 4))) + ; (looking-at " <f>")) + ; (forward-char -4)))) + ) + (or (eq predicate 'fboundp) + (let (new) + (while list + (setq new (cons (if (fboundp (intern (car list))) + (list (car list) " <f>") + (car list)) + new)) + (setq list (cdr list))) + (setq list (nreverse new)))) + (with-output-to-temp-buffer "*Completions*" + (display-completion-list list))) + (message "Making completion list...%s" "done"))))) + +;;; lisp.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/list-mode.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,579 @@ +;;; list-mode.el --- Major mode for buffers containing lists of items + +;; Copyright (C) 1992-4, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1996 Ben Wing. + +;; Maintainer: XEmacs Development Team +;; Keywords: extensions, dumped + +;; 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 synched + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;; Cleanup, merging with FSF by Ben Wing, January 1996 + +;;; Code: + +(defvar list-mode-extent nil) +(make-variable-buffer-local 'list-mode-extent) + +(defvar list-mode-map nil + "Local map for buffers containing lists of items.") +(or list-mode-map + (let ((map (setq list-mode-map (make-sparse-keymap 'list-mode-map)))) + (suppress-keymap map) + (define-key map 'button2up 'list-mode-item-mouse-selected) + (define-key map 'button2 'undefined) + (define-key map "\C-m" 'list-mode-item-keyboard-selected) + (substitute-key-definition 'forward-char 'next-list-mode-item map + global-map) + (substitute-key-definition 'backward-char 'previous-list-mode-item map + global-map))) + +(defun list-mode () + "Major mode for buffer containing lists of items." + (interactive) + (kill-all-local-variables) + (use-local-map list-mode-map) + (setq mode-name "List") + (setq major-mode 'list-mode) + (make-local-hook 'post-command-hook) + (add-hook 'post-command-hook 'set-list-mode-extent nil t) + (make-local-hook 'pre-command-hook) + (add-hook 'pre-command-hook 'list-mode-extent-pre-hook nil t) + (make-local-variable 'next-line-add-newlines) + (setq next-line-add-newlines nil) + (setq list-mode-extent nil) + (set-specifier text-cursor-visible-p nil (current-buffer)) + (setq buffer-read-only t) + (goto-char (point-min)) + (run-hooks 'list-mode-hook)) + +;; List mode is suitable only for specially formatted data. +(put 'list-mode 'mode-class 'special) + +(defvar list-mode-extent-old-point nil + "The value of point when pre-command-hook is called. +Used to determine the direction of motion.") +(make-variable-buffer-local 'list-mode-extent-old-point) + +(defun list-mode-extent-pre-hook () + (setq list-mode-extent-old-point (point)) + ;(setq atomic-extent-goto-char-p nil) +) + +(defun set-list-mode-extent () + "Move to the closest list item and set up the extent for it. +This is called from `post-command-hook'." + (cond ((get-char-property (point) 'list-mode-item)) + ((and (> (point) (point-min)) + (get-char-property (1- (point)) 'list-mode-item)) + (goto-char (1- (point)))) + (t + (let ((pos (point)) + dirflag) + ;this fucks things up more than it helps. + ;atomic-extent-goto-char-p as currently defined is all broken, + ;since it will be triggered if the command *ever* runs goto-char! + ;(if atomic-extent-goto-char-p + ; (setq dirflag 1) + (if (and list-mode-extent-old-point + (> pos list-mode-extent-old-point)) + (setq dirflag 1) + (setq dirflag -1)) + (next-list-mode-item dirflag) + (or (get-char-property (point) 'list-mode-item) + (next-list-mode-item (- dirflag)))))) + (or (and list-mode-extent + (eq (current-buffer) (extent-object list-mode-extent))) + (progn + (setq list-mode-extent (make-extent nil nil (current-buffer))) + (set-extent-face list-mode-extent 'list-mode-item-selected))) + (let ((ex (extent-at (point) nil 'list-mode-item nil 'at))) + (if ex + (progn + (set-extent-endpoints list-mode-extent + (extent-start-position ex) + (extent-end-position ex)) + (auto-show-make-region-visible (extent-start-position ex) + (extent-end-position ex))) + (detach-extent list-mode-extent)))) + +(defun previous-list-mode-item (n) + "Move to the previous item in list-mode." + (interactive "p") + (next-list-mode-item (- n))) + +(defun next-list-mode-item (n) + "Move to the next item in list-mode. +With prefix argument N, move N items (negative N means move backward)." + (interactive "p") + (while (and (> n 0) (not (eobp))) + (let ((prop (get-char-property (point) 'list-mode-item)) + (end (point-max))) + ;; If in a completion, move to the end of it. + (if prop + (goto-char (next-single-property-change (point) 'list-mode-item + nil end))) + ;; Move to start of next one. + (goto-char (next-single-property-change (point) + 'list-mode-item nil end))) + (setq n (1- n))) + (while (and (< n 0) (not (bobp))) + (let ((prop (get-char-property (1- (point)) 'list-mode-item)) + (end (point-min))) + ;; If in a completion, move to the start of it. + (if prop + (goto-char (previous-single-property-change + (point) 'list-mode-item nil end))) + ;; Move to end of the previous completion. + (goto-char (previous-single-property-change (point) 'list-mode-item + nil end)) + ;; Move to the start of that one. + (goto-char (previous-single-property-change (point) 'list-mode-item nil + end))) + (setq n (1+ n)))) + +(defun list-mode-item-selected-1 (extent event) + (let ((func (extent-property extent 'list-mode-item-activate-callback)) + (user-data (extent-property extent 'list-mode-item-user-data))) + (if func + (funcall func event extent user-data)))) + +;; we could make these two be just one function, but we want to be +;; able to refer to them in DOC strings. + +(defun list-mode-item-keyboard-selected () + (interactive) + (list-mode-item-selected-1 (extent-at (point) (current-buffer) + 'list-mode-item nil 'at) + nil)) + +(defun list-mode-item-mouse-selected (event) + (interactive "e") + ;; Sometimes event-closest-point returns nil. + ;; So beep instead of bombing. + (let ((point (event-closest-point event))) + (if point + (list-mode-item-selected-1 (extent-at point + (event-buffer event) + 'list-mode-item nil 'at) + event) + (ding)))) + +(defun add-list-mode-item (start end &optional buffer activate-callback + user-data) + "Add a new list item in list-mode, from START to END in BUFFER. +BUFFER defaults to the current buffer. +This works by creating an extent for the span of text in question. +If ACTIVATE-CALLBACK is non-nil, it should be a function of three + arguments (EVENT EXTENT USER-DATA) that will be called when button2 + is pressed on the extent. USER-DATA comes from the optional + USER-DATA argument." + (let ((extent (make-extent start end buffer))) + (set-extent-property extent 'list-mode-item t) + (set-extent-property extent 'start-open t) + (if activate-callback + (progn + (set-extent-property extent 'mouse-face 'highlight) + (set-extent-property extent 'list-mode-item-activate-callback + activate-callback) + (set-extent-property extent 'list-mode-item-user-data user-data))) + extent)) + + +;; Define the major mode for lists of completions. + + +(defvar completion-highlight-first-word-only nil + "*Completion will only highlight the first blank delimited word if t. +If the variable in not t or nil, the string is taken as a regexp to match for end +of highlight") + +(defvar completion-setup-hook nil + "Normal hook run at the end of setting up the text of a completion buffer.") + +; Unnecessary FSFmacs crock. We frob the extents directly in +; display-completion-list, so no "heuristics" like this are necessary. +;(defvar completion-fixup-function nil +; "A function to customize how completions are identified in completion lists. +;`completion-setup-function' calls this function with no arguments +;each time it has found what it thinks is one completion. +;Point is at the end of the completion in the completion list buffer. +;If this function moves point, it can alter the end of that completion.") + +(defvar completion-default-help-string + '(concat + (if (device-on-window-system-p) + (substitute-command-keys + "Click \\<list-mode-map>\\[list-mode-item-mouse-selected] on a completion to select it.\n") "") + (substitute-command-keys + "Type \\<minibuffer-local-completion-map>\\[advertised-switch-to-completions] or \\[switch-to-completions] to move to this buffer, for keyboard selection.\n\n")) + "Form the evaluate to get a help string for completion lists. +This string is inserted at the beginning of the buffer. +See `display-completion-list'.") + +(defun display-completion-list (completions &rest cl-keys) + "Display the list of completions, COMPLETIONS, using `standard-output'. +Each element may be just a symbol or string or may be a list of two + strings to be printed as if concatenated. +Frob a mousable extent onto each completion. This extent has properties + 'mouse-face (so it highlights when the mouse passes over it) and + 'list-mode-item (so it can be located). + +Keywords: + :activate-callback (default is `default-choose-completion') + See `add-list-mode-item'. + :user-data + Value passed to activation callback. + :window-width + If non-nil, width to use in displaying the list, instead of the + actual window's width. + :help-string (default is the value of `completion-default-help-string') + Form to evaluate to get a string to insert at the beginning of + the completion list buffer. This is evaluated when that buffer + is the current buffer and after it has been put into + completion-list-mode. + :reference-buffer (default is the current buffer) + This specifies the value of `completion-reference-buffer' in + the completion buffer. This specifies the buffer (normally a + minibuffer) that `default-choose-completion' will insert the + completion into. + +At the end, run the normal hook `completion-setup-hook'. +It can find the completion buffer in `standard-output'. +If `completion-highlight-first-word-only' is non-nil, then only the start + of the string is highlighted." + ;; #### I18N3 should set standard-output to be (temporarily) + ;; output-translating. + (cl-parsing-keywords + ((:activate-callback 'default-choose-completion) + :user-data + :reference-buffer + (:help-string completion-default-help-string) + :window-width) + () + (let ((old-buffer (current-buffer)) + (bufferp (bufferp standard-output))) + (if bufferp + (set-buffer standard-output)) + (if (null completions) + (princ (gettext + "There are no possible completions of what you have typed.")) + (let ((win-width + (or cl-window-width + (if bufferp + ;; This needs fixing for the case of windows + ;; that aren't the same width's the frame. + ;; Sadly, the window it will appear in is not known + ;; until after the text has been made. + + ;; We have to use last-nonminibuf-frame here + ;; and not selected-frame because if a + ;; minibuffer-only frame is being used it will + ;; be the selected-frame at the point this is + ;; run. We keep the selected-frame call around + ;; just in case. + (frame-width (or (last-nonminibuf-frame) + (selected-frame))) + 80)))) + (let ((count 0) + (max-width 0)) + ;; Find longest completion + (let ((tail completions)) + (while tail + (let* ((elt (car tail)) + (len (cond ((stringp elt) + (length elt)) + ((and (consp elt) + (stringp (car elt)) + (stringp (car (cdr elt)))) + (+ (length (car elt)) + (length (car (cdr elt))))) + (t + (signal 'wrong-type-argument + (list 'stringp elt)))))) + (if (> len max-width) + (setq max-width len)) + (setq count (1+ count) + tail (cdr tail))))) + + (setq max-width (+ 2 max-width)) ; at least two chars between cols + (let ((rows (let ((cols (min (/ win-width max-width) count))) + (if (<= cols 1) + count + (progn + ;; re-space the columns + (setq max-width (/ win-width cols)) + (if (/= (% count cols) 0) ; want ceiling... + (1+ (/ count cols)) + (/ count cols))))))) + (princ (gettext "Possible completions are:")) + (let ((tail completions) + (r 0) + (regexp-string + (if (eq t + completion-highlight-first-word-only) + "[ \t]" + completion-highlight-first-word-only))) + (while (< r rows) + (terpri) + (let ((indent 0) + (column 0) + (tail2 tail)) + (while tail2 + (let ((elt (car tail2))) + (if (/= indent 0) + (if bufferp + (indent-to indent 2) + (while (progn (write-char ?\ ) + (setq column (1+ column)) + (< column indent))))) + (setq indent (+ indent max-width)) + (let ((start (point)) + end) + ;; Frob some mousable extents in there too! + (if (consp elt) + (progn + (princ (car elt)) + (princ (car (cdr elt))) + (or bufferp + (setq column + (+ column + (length (car elt)) + (length (car (cdr elt))))))) + (progn + (princ elt) + (or bufferp + (setq column (+ column (length + elt)))))) + (add-list-mode-item + start + (progn + (setq end (point)) + (or + (and completion-highlight-first-word-only + (goto-char start) + (re-search-forward regexp-string end t) + (match-beginning 0)) + end)) + nil cl-activate-callback cl-user-data) + (goto-char end))) + (setq tail2 (nthcdr rows tail2))) + (setq tail (cdr tail) + r (1+ r))))))))) + (if bufferp + (set-buffer old-buffer))) + (save-excursion + (let ((mainbuf (or cl-reference-buffer (current-buffer)))) + (set-buffer standard-output) + (completion-list-mode) + (make-local-variable 'completion-reference-buffer) + (setq completion-reference-buffer mainbuf) +;;; The value 0 is right in most cases, but not for file name completion. +;;; so this has to be turned off. +;;; (setq completion-base-size 0) + (goto-char (point-min)) + (let ((buffer-read-only nil)) + (insert (eval cl-help-string))) + ;; unnecessary FSFmacs crock + ;;(forward-line 1) + ;;(while (re-search-forward "[^ \t\n]+\\( [^ \t\n]+\\)*" nil t) + ;; (let ((beg (match-beginning 0)) + ;; (end (point))) + ;; (if completion-fixup-function + ;; (funcall completion-fixup-function)) + ;; (put-text-property beg (point) 'mouse-face 'highlight) + ;; (put-text-property beg (point) 'list-mode-item t) + ;; (goto-char end))))) + )) + (run-hooks 'completion-setup-hook))) + +(defvar completion-display-completion-list-function 'display-completion-list + "Function to set up the list of completions in the completion buffer. +The function is called with one argument, the sorted list of completions. +Particular minibuffer interface functions (e.g. `read-file-name') may +want to change this. To do that, set a local value for this variable +in the minibuffer; that ensures that other minibuffer invocations will +not be affected.") + +(defun minibuffer-completion-help () + "Display a list of possible completions of the current minibuffer contents. +The list of completions is determined by calling `all-completions', +passing it the current minibuffer contents, the value of +`minibuffer-completion-table', and the value of +`minibuffer-completion-predicate'. The list is displayed by calling +the value of `completion-display-completion-list-function' on the sorted +list of completions, with the standard output set to the completion +buffer." + (interactive) + (message "Making completion list...") + (let ((completions (all-completions (buffer-string) + minibuffer-completion-table + minibuffer-completion-predicate))) + (message nil) + (if (null completions) + (progn + (ding nil 'no-completion) + (temp-minibuffer-message " [No completions]")) + (with-output-to-temp-buffer "*Completions*" + (funcall completion-display-completion-list-function + (sort completions #'string-lessp)))))) + +(define-derived-mode completion-list-mode list-mode + "Completion List" + "Major mode for buffers showing lists of possible completions. +Type \\<completion-list-mode-map>\\[choose-completion] in the completion list\ + to select the completion near point. +Use \\<completion-list-mode-map>\\[mouse-choose-completion] to select one\ + with the mouse." + (make-local-variable 'completion-base-size) + (setq completion-base-size nil)) + +(let ((map completion-list-mode-map)) + (define-key map "\e\e\e" 'delete-completion-window) + (define-key map "\C-g" 'minibuffer-keyboard-quit) + (define-key map "q" 'abort-recursive-edit) + (define-key map " " (lambda () (interactive) + (select-window (minibuffer-window)))) + (define-key map "\t" (lambda () (interactive) + (select-window (minibuffer-window))))) + +(defvar completion-reference-buffer nil + "Record the buffer that was current when the completion list was requested. +This is a local variable in the completion list buffer. +Initial value is nil to avoid some compiler warnings.") + +(defvar completion-base-size nil + "Number of chars at beginning of minibuffer not involved in completion. +This is a local variable in the completion list buffer +but it talks about the buffer in `completion-reference-buffer'. +If this is nil, it means to compare text to determine which part +of the tail end of the buffer's text is involved in completion.") + +(defun delete-completion-window () + "Delete the completion list window. +Go to the window from which completion was requested." + (interactive) + (let ((buf completion-reference-buffer)) + (delete-window (selected-window)) + (if (get-buffer-window buf) + (select-window (get-buffer-window buf))))) + +(defun completion-do-in-minibuffer () + (interactive "_") + (save-excursion + (set-buffer (window-buffer (minibuffer-window))) + (call-interactively (key-binding (this-command-keys))))) + +(defun default-choose-completion (event extent buffer) + "Click on an alternative in the `*Completions*' buffer to choose it." + (and (button-event-p event) + ;; Give temporary modes such as isearch a chance to turn off. + (run-hooks 'mouse-leave-buffer-hook)) + (or buffer (setq buffer (symbol-value-in-buffer + 'completion-reference-buffer + (or (and (button-event-p event) + (event-buffer event)) + (current-buffer))))) + (save-selected-window + (and (button-event-p event) + (select-window (event-window event))) + (if (and (one-window-p t 'selected-frame) + (window-dedicated-p (selected-window))) + ;; This is a special buffer's frame + (iconify-frame (selected-frame)) + (or (window-dedicated-p (selected-window)) + (bury-buffer)))) + (choose-completion-string (extent-string extent) + buffer + completion-base-size)) + +;; Delete the longest partial match for STRING +;; that can be found before POINT. +(defun choose-completion-delete-max-match (string) + (let ((len (min (length string) + (- (point) (point-min))))) + (goto-char (- (point) (length string))) + (if completion-ignore-case + (setq string (downcase string))) + (while (and (> len 0) + (let ((tail (buffer-substring (point) + (+ (point) len)))) + (if completion-ignore-case + (setq tail (downcase tail))) + (not (string= tail (substring string 0 len))))) + (setq len (1- len)) + (forward-char 1)) + (delete-char len))) + +;; Switch to BUFFER and insert the completion choice CHOICE. +;; BASE-SIZE, if non-nil, says how many characters of BUFFER's text +;; to keep. If it is nil, use choose-completion-delete-max-match instead. +(defun choose-completion-string (choice &optional buffer base-size) + (let ((buffer (or buffer completion-reference-buffer))) + ;; If BUFFER is a minibuffer, barf unless it's the currently + ;; active minibuffer. + (if (and (string-match "\\` \\*Minibuf-[0-9]+\\*\\'" (buffer-name buffer)) + (or (not (active-minibuffer-window)) + (not (equal buffer + (window-buffer (active-minibuffer-window)))))) + (error "Minibuffer is not active for completion") + ;; Insert the completion into the buffer where completion was requested. + (set-buffer buffer) + (if base-size + (delete-region (+ base-size (point-min)) (point)) + (choose-completion-delete-max-match choice)) + (insert choice) + (remove-text-properties (- (point) (length choice)) (point) + '(highlight nil)) + ;; Update point in the window that BUFFER is showing in. + (let ((window (get-buffer-window buffer t))) + (set-window-point window (point))) + ;; If completing for the minibuffer, exit it with this choice. + (and (equal buffer (window-buffer (minibuffer-window))) + minibuffer-completion-table + (exit-minibuffer))))) + +(define-key minibuffer-local-completion-map [prior] + 'switch-to-completions) +(define-key minibuffer-local-must-match-map [prior] + 'switch-to-completions) +(define-key minibuffer-local-completion-map "\M-v" + 'advertised-switch-to-completions) +(define-key minibuffer-local-must-match-map "\M-v" + 'advertised-switch-to-completions) + +(defalias 'advertised-switch-to-completions 'switch-to-completions) +(defun switch-to-completions () + "Select the completion list window." + (interactive) + ;; Make sure we have a completions window. + (or (get-buffer-window "*Completions*") + (minibuffer-completion-help)) + (if (not (get-buffer-window "*Completions*")) + nil + (select-window (get-buffer-window "*Completions*")) + (goto-char (next-single-property-change (point-min) 'list-mode-item nil + (point-max))))) + +;;; list-mode.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/loaddefs.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,394 @@ +;;; loaddefs.el --- define standard autoloads of other files + +;; Copyright (C) 1985, 1986, 1987, 1992-1995 Free Software Foundation, Inc. + +;; Maintainer: XEmacs +;; Keywords: internal + +;; 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, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: Not synched with FSF. + +;;; Commentary: + +;;; !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +;;; Special formatting conventions are used in this file! +;;; +;;; a backslash-newline is used at the beginning of a documentation string +;;; when that string should be stored in the file lib-src/DOCnnn, not in core. +;;; +;;; Such strings read into Lisp as numbers (during the pure-loading phase). +;;; +;;; But you must obey certain rules to make sure the string is understood +;;; and goes into lib-src/DOCnnn properly. Otherwise, the string will not go +;;; anywhere! +;;; +;;; The doc string must appear in the standard place in a call to +;;; defun, autoload, defvar or defconst. No Lisp macros are recognized. +;;; The open-paren starting the definition must appear in column 0. +;;; +;;; In defvar and defconst, there is an additional rule: +;;; The double-quote that starts the string must be on the same +;;; line as the defvar or defconst. +;;; !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +;;; ********************************************************************** +;;; You should never need to write autoloads by hand and put them here. +;;; +;;; It is no longer necessary. Instead use autoload.el to maintain them +;;; for you. Just insert ";;;###autoload" before defuns or defmacros you +;;; want to be autoloaded, or other forms you want copied into loaddefs.el +;;; (defvars, key definitions, etc.). For example, +;;; ;;;###autoload +;;; (defun foobar () ....) +;;; ;;;###autoload (define-key global-map "f" 'foobar) +;;; ;;;###autoload +;;; (defvar foobar-var nil "\ +;;; This is foobar-var's doc-string.") +;;; +;;; Then do M-x update-file-autoloads on the file to update loaddefs.el. +;;; +;;; You can also use M-x update-directory-autoloads to update the autoloads +;;; in loaddefs.el for all .el files in the lisp/ directory, or M-x +;;; update-autoloads-here to update the autoloads for each file that +;;; already has an autoload section in this file. +;;; ********************************************************************** + + +;;; Code: + +;; These variables are used by autoloadable packages. +;; They are defined here so that they do not get overridden +;; by the loading of those packages. + + +;; Names in directory that end in one of these +;; are ignored in completion, +;; 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")))) + + +(setq debug-ignored-errors + '(beginning-of-line + beginning-of-buffer + end-of-line + end-of-buffer + end-of-file buffer-read-only + "\\`Previous command was not a yank\\'" + "\\`Minibuffer is not active for completion\\'" + "\\`No \\(following\\|preceding\\) item in .*-history\\'" + "\\`No recursive edit is in progress\\'" + "\\`Changes to be undone are outside visible portion of buffer\\'" + "\\`No further undo information\\'" + "\\`No undo information in this buffer\\'" + "\\`Buffer modified since last undo/redo, cannot redo" + "\\`Save not confirmed\\'" + "\\`Canceled\\'" + "\\`\\(Revert\\|Steal\\|Recover-file\\) cancelled\\.\\'" + + ;; comint + "\\`Not at command line\\'" + "\\`Empty input ring\\'" + "\\`No history\\'" + "\\`Not found\\'" ;; To common? + "\\`Current buffer has no process\\'" + + ;; dabbrev + "\\`No \\(further \\)?dynamic expansion for .* found\\.?\\'" + + ;; Completion + "\\`To complete, the point must be after a symbol at least [0-9]* character long\\.\\'" + "\\`The string \".*\" is too short to be saved as a completion\\.\\'" + + ;; Compile + "\\`No more errors\\( yet\\|\\)\\'" + + ;; Gnus + ;"\\`NNTP: Connection closed\\.\\'" + + ;; info + "\\`Node has no Previous\\'" + "\\`No \".*\" in index\\'" + + ;; imenu + ;"\\`No items suitable for an index found in this buffer\\.\\'" + ;"\\`The mode \".*\" does not take full advantage of imenu\\.el yet\\.\\'" + + ;; ispell + "\\`No word found to check!\\'" + + ;; man + "\\`.* not found\\'" + "\\`No more history\\.\\'" + + ;; etags + "\\`File .* is not a valid tag table\\'" + "\\`File .* is not a valid tags file\\'" + "\\`All files processed\\.\\'" + "No TAGS file name supplied\\'" + "\\`Nothing to complete\\'" + + ;; BBDB + "\\`no previous record\\'" + "\\`no next record\\'")) + +(make-variable-buffer-local 'indent-tabs-mode) + + +;;; This code also was not generated by autoload.el, because VM goes out +;;; of its way to be perverse. + +(autoload 'vm "vm" + "\ +View Mail: an alternate mail reader for emacs. +Optional first arg FOLDER specifies the folder to visit. It defaults +to the value of vm-primary-inbox. The folder buffer is put into VM +mode, a major mode for reading mail. + +Prefix arg or optional second arg READ-ONLY non-nil indicates +that the folder should be considered read only. No attribute +changes, messages additions or deletions will be allowed in the +visited folder. + +Visiting the primary inbox causes any contents of the system mailbox to +be moved and appended to the resulting buffer. + +All the messages can be read by repeatedly pressing SPC. Use `n'ext and +`p'revious to move about in the folder. Messages are marked for +deletion with `d', and saved to another folder with `s'. Quitting VM +with `q' expunges deleted messages and saves the buffered folder to +disk. + +See the documentation for vm-mode for more information." + t) + +(autoload 'vm-mode "vm" + "\ +View Mail: an alternate mail reader for emacs. + +Commands: + h - summarize folder contents + j - discard cached information about the current message + + n - go to next message + p - go to previous message + N - like `n' but ignores skip-variable settings + P - like `p' but ignores skip-variable settings + M-n - go to next unread message + M-p - go to previous unread message + RET - go to numbered message (uses prefix arg or prompts in minibuffer) + TAB - go to last message seen + M-s - incremental search through the folder + + t - display hidden headers + SPC - scroll forward a page (if at end of message, then display next message) + b - scroll backward a page + < - go to beginning of current message + > - go to end of current message + + d - delete message, prefix arg deletes messages forward (flag as deleted) + C-d - delete message, prefix arg deletes messages backward (flag as deleted) + u - undelete + k - flag for deletion all messages with same subject as the current message + + r - reply (only to the sender of the message) + R - reply with included text for current message + M-r - extract and resend bounced message + f - followup (reply to all recipients of message) + F - followup with included text from the current message + z - forward the current message + m - send a message + B - resend the current message to another user. + c - continue composing the most recent message you were composing + + @ - digestify and mail entire folder contents (the folder is not modified) + * - burst a digest into individual messages, and append and assimilate these + message into the current folder. + + G - sort messages by various keys + + g - get any new mail that has arrived in the system mailbox + (new mail is appended to the disk and buffer copies of the + primary inbox.) + v - visit another mail folder + V - visit a virtual folder + + e - edit the current message + + s - save current message in a folder (appends if folder already exists) + w - write current message to a file without its headers (appends if exists) + S - save entire folder to disk, expunging deleted messages + A - save unfiled messages to their vm-auto-folder-alist specified folders + # - expunge deleted messages (without saving folder) + q - quit VM, deleted messages are expunged, folder saved to disk + x - exit VM with no change to the folder + + M N - use marks; the next vm command will affect only marked messages + if it makes sense for the command to do so + + M M - mark the current message + M U - unmark the current message + M m - mark all messages + M u - unmark all messages + M ? - help for the mark commands + + W S - save the current window configuration to a name + W D - delete a window configuration + W W - apply a configuration + W ? - help for the window configuration commands + + C-_ - undo, special undo that retracts the most recent + changes in message attributes. Expunges and saves + cannot be undone. C-x u is also bound to this + command. + + L - reload your VM init file, ~/.vm + + ? - help + + ! - run a shell command + | - run a shell command with the current message as input + + M-C - view conditions under which you may redistribute VM + M-W - view the details of VM's lack of a warranty + +Variables: + vm-auto-center-summary + vm-auto-folder-alist + vm-auto-folder-case-fold-search + vm-auto-get-new-mail + vm-auto-next-message + vm-berkeley-mail-compatibility + vm-check-folder-types + vm-convert-folder-types + vm-circular-folders + vm-confirm-new-folders + vm-confirm-quit + vm-crash-box + vm-delete-after-archiving + vm-delete-after-bursting + vm-delete-after-saving + vm-delete-empty-folders + vm-digest-burst-type + vm-digest-center-preamble + vm-digest-preamble-format + vm-digest-send-type + vm-folder-directory + vm-folder-read-only + vm-follow-summary-cursor + vm-forwarded-headers + vm-forwarding-digest-type + vm-forwarding-subject-format + vm-gargle-uucp + vm-highlighted-header-regexp + vm-honor-page-delimiters + vm-in-reply-to-format + vm-included-text-attribution-format + vm-included-text-prefix + vm-inhibit-startup-message + vm-invisible-header-regexp + vm-jump-to-new-messages + vm-jump-to-unread-messages + vm-keep-sent-messages + vm-mail-header-from + vm-mail-mode-hook + vm-mail-window-percentage + vm-mode-hook + vm-move-after-deleting + vm-move-after-undeleting + vm-mutable-windows + vm-preview-lines + vm-preview-read-messages + vm-primary-inbox + vm-recognize-pop-maildrops + vm-reply-ignored-addresses + vm-reply-subject-prefix + vm-resend-bounced-headers + vm-resend-bounced-discard-header-regexp + vm-resend-headers + vm-resend-discard-header-regexp + vm-retain-message-order + vm-rfc1153-digest-discard-header-regexp + vm-rfc1153-digest-headers + vm-rfc934-digest-discard-header-regexp + vm-rfc934-digest-headers + vm-search-using-regexps + vm-skip-deleted-messages + vm-skip-read-messages + vm-spool-files + vm-startup-with-summary + vm-strip-reply-headers + vm-summary-format + vm-unforwarded-header-regexp + vm-virtual-folder-alist + vm-virtual-mirror + vm-visible-headers + vm-visit-when-saving + vm-window-configuration-file +" + t) + +(autoload 'vm-visit-folder "vm" + "\ +Visit a mail file with View Mail, an alternate mail reader for emacs. +See the description of the `vm' and `vm-mode' functions. + +VM will parse and present its messages to you in the usual way. + +First arg FOLDER specifies the mail file to visit. When this +command is called interactively the file name is read from the +minibuffer. + +Prefix arg or optional second arg READ-ONLY non-nil indicates +that the folder should be considered read only. No attribute +changes, messages additions or deletions will be allowed in the +visited folder." + t) + +(autoload 'vm-mail "vm" + "\ +Send a mail message from within View Mail, or from without." + t) + + +;;; Load in generated autoloads (made by autoload.el). +;; (condition-case nil + ;; (load "auto-autoloads") + ;; (file-error nil)) +(let ((dir load-path)) + (while dir + (condition-case nil + (load (concat (car dir) "auto-autoloads")) + (t nil)) + (pop dir))) + +;;; Local Variables: +;;; no-byte-compile: t +;;; no-update-autoloads: t +;;; End: +;;; loaddefs.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/loadup-el.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,25 @@ +;; 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, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: Not in FSF. + +; always take .el files. +; don't put stuff into pure segment to avoid pure-space-exceeded error. + +(let ((load-ignore-elc-files t) + (purify-flag nil)) + (load "loadup.el"))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/loadup.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,214 @@ +;;; loadup.el --- load up standardly loaded Lisp files for XEmacs. + +;; Copyright (C) 1985, 1986, 1992, 1994 Free Software Foundation, Inc. +;; Copyright (C) 1996 Richard Mlynarik. +;; Copyright (C) 1995, 1996 Ben Wing. + +;; Keywords: internal + +;; 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: Last synched with FSF 19.30, with wild divergence since. + +;;; Commentary: + +;; It is not a good idea to edit this file. Use site-init.el or site-load.el +;; instead. +;; +;; This is loaded into a bare Emacs to make a dumpable one. + +;;; Code: + +(if (fboundp 'error) + (error "loadup.el already loaded!")) + +(define-function 'defalias 'define-function) +(defvar running-xemacs t + "Non-nil when the current emacsen is XEmacs.") +(defvar preloaded-file-list nil + "List of files preloaded into the XEmacs binary image.") + +(call-with-condition-handler + ;; This is awfully damn early to be getting an error, right? + 'really-early-error-handler + #'(lambda () + ;; message not defined yet ... + (external-debugging-output (format "\nUsing load-path %s" load-path)) + + ;; We don't want to have any undo records in the dumped XEmacs. + (buffer-disable-undo (get-buffer "*scratch*")) + + ;; lread.c (or src/Makefile.in.in) has prepended "${srcdir}/../lisp/" + ;; to load-path, which is how this file has been found. At this point, + ;; enough of emacs has been initialized that we can call directory-files + ;; and get the rest of the dirs (so that we can dump stuff from modes/ + ;; and packages/.) + ;; + (let ((temp-path (expand-file-name "." (car load-path)))) + (setq source-directory temp-path) + (setq load-path (nconc (mapcar + #'(lambda (i) (concat i "/")) + (directory-files temp-path t "^[^-.]" + nil 'dirs-only)) + (cons (file-name-as-directory temp-path) + load-path)))) + + (setq load-warn-when-source-newer t ; set to nil at the end + load-warn-when-source-only t) + + ;; Inserted for debugging. Something is corrupting a single symbol + ;; somewhere to have an integer 0 property list. -slb 6/28/1997. + (defun test-atoms () + (mapatoms + #'(lambda (symbol) + (condition-case nil + (get symbol 'custom-group) + (t (princ + (format "Bad plist in %s, %s\n" + (symbol-name symbol) + (prin1-to-string (object-plist symbol))))))))) + + ;; garbage collect after loading every file in an attempt to + ;; minimize the size of the dumped image (if we don't do this, + ;; there will be lots of extra space in the data segment filled + ;; with garbage-collected junk) + (defmacro load-gc (file) + (list 'prog1 (list 'load file) + ;; '(test-atoms) + '(garbage-collect))) + ;; Need a minimal number hardcoded to get going for now. + ;; (load-gc "backquote") ; needed for defsubst etc. + ;; (load-gc "bytecomp-runtime") ; define defsubst + ;; (load-gc "subr") ; load the most basic Lisp functions + ;; (load-gc "replace") ; match-string used in version.el. + ;; (load-gc "version.el") ; Ignore compiled-by-mistake version.elc + ;; (load-gc "cl") + ;; (load-gc "featurep") ; OBSOLETE now + (load "dumped-lisp.el") + (let ((dumped-lisp-packages preloaded-file-list) + file) + (while (setq file (car dumped-lisp-packages)) + (load-gc file) + (setq dumped-lisp-packages (cdr dumped-lisp-packages))) + (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))) + (fmakunbound 'load-gc)) + )) ;; end of call-with-condition-handler + + +;; Fix up the preloaded file list +(setq preloaded-file-list (mapcar #'file-name-sans-extension + preloaded-file-list)) + +(setq load-warn-when-source-newer t ; set to t at top of file + load-warn-when-source-only nil) + +(setq debugger 'debug) + +(when (member "no-site-file" command-line-args) + (setq site-start-file nil)) + +;; If you want additional libraries to be preloaded and their +;; doc strings kept in the DOC file rather than in core, +;; you may load them with a "site-load.el" file. +;; 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)) + +;;FSFmacs randomness +;;(if (fboundp 'x-popup-menu) +;; (precompute-menubar-bindings)) +;;; Turn on recording of which commands get rebound, +;;; for the sake of the next call to precompute-menubar-bindings. +;(setq define-key-rebound-commands nil) + + +;; Note: all compiled Lisp files loaded above this point +;; must be among the ones parsed by make-docfile +;; to construct DOC. Any that are not processed +;; for DOC will not have doc strings in the dumped XEmacs. + +;; Don't bother with these if we're running temacs, i.e. if we're +;; just debugging don't waste time finding doc strings. + +;; purify-flag is nil if called from loadup-el.el. +(when purify-flag + (message "Finding pointers to doc strings...") + ;; (test-atoms) ; Debug -- Doesn't happen here + (Snarf-documentation "DOC") + ;; (test-atoms) ; Debug -- Doesn't happen here + (message "Finding pointers to doc strings...done") + (Verify-documentation) + ;; (test-atoms) ; Debug -- Doesn't happen here + ) + +;; 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)) +(setq current-load-list nil) +(garbage-collect) + +;;; At this point, we're ready to resume undo recording for scratch. +(buffer-enable-undo "*scratch*") + +;; Dump into the name `xemacs' (only) +(when (member "dump" command-line-args) + (message "Dumping under the name xemacs") + (condition-case () (delete-file "xemacs") (file-error nil)) + (when (fboundp 'really-free) + (really-free)) + (dump-emacs "xemacs" "temacs") + (kill-emacs)) + +(when (member "run-temacs" command-line-args) + (message "\nBootstrapping from temacs...") + (setq purify-flag nil) + ;; Remove all args up to and including "run-temacs" + (apply #'run-emacs-from-temacs (cdr (member "run-temacs" command-line-args))) + ;; run-emacs-from-temacs doesn't actually return anyway. + (kill-emacs)) + +;; Avoid error if user loads some more libraries now. +(setq purify-flag nil) + +;; XEmacs change +;; If you are using 'recompile', then you should have used -l loadup-el.el +;; 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))) + +;; For machines with CANNOT_DUMP defined in config.h, +;; this file must be loaded each time Emacs is run. +;; So run the startup code now. + +(when (not (fboundp 'dump-emacs)) + ;; Avoid loading loadup.el a second time! + (setq command-line-args (cdr (cdr command-line-args))) + (eval top-level)) + +;;; loadup.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/make-docfile.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,197 @@ +;;; make-docfile.el --- Cache docstrings in external file + + +;; Copyright (C) 1985, 1986, 1992-1995, 1997 Free Software Foundation, Inc. + +;; Author: Unknown +;; Maintainer: Steven L Baur <steve@altair.xemacs.org> +;; Keywords: internal + +;; 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: + +;; This is a front-end to the make-docfile program that gathers up all the +;; lisp files that will be dumped with XEmacs. It would probably be best +;; to just move make-docfile.c completely to lisp and be done with it. + +;;; Code: + +(defvar options nil) +(defvar processed nil) +(defvar docfile nil) +(defvar docfile-buffer nil) +(defvar site-file-list nil) +(defvar docfile-out-of-date nil) + +;; Gobble up the stuff we don't wish to pass on. +(setq command-line-args (cdr (cdr (cdr (cdr command-line-args))))) + +;; First gather up the command line options. +(let (done) + (while (and (null done) command-line-args) + (let ((arg (car command-line-args))) + (cond ((or (string-equal arg "-o") ; Specify DOC file name + (string-equal arg "-a") ; Append to DOC file + (string-equal arg "-d")) ; Set working directory + (if (string-equal arg "-o") + (setq docfile (car (cdr command-line-args)))) + (setq options (cons arg options)) + (setq options (cons (car (cdr command-line-args)) options))) + ((string-equal arg "-i") ; Set site files to scan + (setq site-file-list (car (cdr command-line-args)))) + (t (setq done t))) + (if (null done) + (setq command-line-args (cdr (cdr command-line-args))))))) +(setq options (nreverse options)) + +;; (print (concat "Options: " (prin1-to-string options))) + +;; Next process the list of C files. +(while command-line-args + (let ((arg (car command-line-args))) + (if (null (member arg processed)) + (progn + (if (and (null docfile-out-of-date) + (file-newer-than-file-p arg docfile)) + (setq docfile-out-of-date t)) + (setq processed (cons arg processed))))) + (setq command-line-args (cdr command-line-args))) + +;; Then process the list of Lisp files. +(define-function 'defalias 'define-function) +(let ((temp-path (expand-file-name "." (car load-path)))) + (setq load-path (nconc (mapcar + #'(lambda (i) (concat i "/")) + (directory-files temp-path t "^[^-.]" + nil 'dirs-only)) + (cons (file-name-as-directory temp-path) + load-path)))) + +;; Then process the autoloads +(setq autoload-file-name "auto-autoloads.elc") +(setq source-directory (concat default-directory "../lisp")) +;; (print (concat "Source directory: " source-directory)) +(require 'packages) + +;; We must have some lisp support at this point + +;(load "backquote") +;(load "bytecomp-runtime") +;(load "subr") +;(load "replace") +;(load "version.el") +;(load "cl") + +;; (load "featurep") + +(let (preloaded-file-list) + (load (concat default-directory "../lisp/prim/dumped-lisp.el")) + (setq preloaded-file-list + (append preloaded-file-list packages-hardcoded-lisp)) + (while preloaded-file-list + (let ((arg0 (packages-add-suffix (car preloaded-file-list))) + arg) + (setq arg (locate-library arg0)) + (if (null arg) + (princ (format "Error: dumped file %s does not exist\n" arg0)) + (if (null (member arg processed)) + (progn + (if (and (null docfile-out-of-date) + (file-newer-than-file-p arg docfile)) + (setq docfile-out-of-date t)) + (setq processed (cons arg processed))))) + (setq preloaded-file-list (cdr preloaded-file-list))))) + +;; Finally process the list of site-loaded files. +(if site-file-list + (let (site-load-packages) + (load site-file-list t t) + (while site-load-packages + (let ((arg (car site-load-packages))) + (if (null (member arg processed)) + (progn + (if (and (null docfile-out-of-date) + (file-newer-than-file-p arg docfile)) + (setq docfile-out-of-date t)) + (setq processed (cons arg processed))))) + (setq site-load-packages (cdr site-load-packages))))) + +(packages-find-packages package-path t) + +(let ((autoloads (list-autoloads-path))) + ;; (print (concat "Autoloads: " (prin1-to-string autoloads))) + (while autoloads + (let ((arg (car autoloads))) + (if (null (member arg processed)) + (progn + ;; (print arg) + (if (and (null docfile-out-of-date) + (file-newer-than-file-p arg docfile)) + (setq docfile-out-of-date t)) + (setq processed (cons arg processed)))) + (setq autoloads (cdr autoloads))))) + +;; Now fire up make-docfile and we're done + +(setq processed (nreverse processed)) + +;; (print (prin1-to-string (append options processed))) + +(if docfile-out-of-date + (progn + (princ "Spawning make-docfile ...") + ;; (print (prin1-to-string (append options processed))) + + (setq exec-path (list (concat default-directory "../lib-src"))) + + ;; (locate-file-clear-hashing nil) + (if (memq system-type '(berkeley-unix next-mach)) + ;; Suboptimal, but we have a unresolved bug somewhere in the + ;; low-level process code + (call-process-internal + "/bin/csh" + nil + t + nil + "-fc" + (mapconcat + 'identity + (append + (list (concat default-directory "../lib-src/make-docfile")) + options processed) + " ")) + ;; (print (prin1-to-string (append options processed))) + (apply 'call-process-internal + ;; (concat default-directory "../lib-src/make-docfile") + "make-docfile" + nil + t + nil + (append options processed))) + + (princ "Spawning make-docfile ...done\n") + ;; (write-region-internal (point-min) (point-max) "/tmp/DOC") + ) + (princ "DOC file is up to date\n")) + +(kill-emacs) + +;;; make-docfile.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/map-ynp.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,292 @@ +;;; map-ynp.el --- General-purpose boolean question-asker. + +;; Copyright (C) 1991-1995, 1997 Free Software Foundation, Inc. + +;; Author: Roland McGrath <roland@gnu.ai.mit.edu> +;; Keywords: lisp, extensions, dumped + +;; 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: Emacs/Mule zeta. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;; map-y-or-n-p is a general-purpose question-asking function. +;; It asks a series of y/n questions (a la y-or-n-p), and decides to +;; applies an action to each element of a list based on the answer. +;; The nice thing is that you also get some other possible answers +;; to use, reminiscent of query-replace: ! to answer y to all remaining +;; questions; ESC or q to answer n to all remaining questions; . to answer +;; y once and then n for the remainder; and you can get help with C-h. + +;;; Code: + +(defun map-y-or-n-p (prompter actor list &optional help action-alist + no-cursor-in-echo-area) + "Ask a series of boolean questions. +Takes args PROMPTER ACTOR LIST, and optional args HELP and ACTION-ALIST. + +LIST is a list of objects, or a function of no arguments to return the next +object or nil. + +If PROMPTER is a string, the prompt is \(format PROMPTER OBJECT\). If not +a string, PROMPTER is a function of one arg (an object from LIST), which +returns a string to be used as the prompt for that object. If the return +value is not a string, it may be nil to ignore the object or non-nil to act +on the object without asking the user. + +ACTOR is a function of one arg (an object from LIST), +which gets called with each object that the user answers `yes' for. + +If HELP is given, it is a list (OBJECT OBJECTS ACTION), +where OBJECT is a string giving the singular noun for an elt of LIST; +OBJECTS is the plural noun for elts of LIST, and ACTION is a transitive +verb describing ACTOR. The default is \(\"object\" \"objects\" \"act on\"\). + +At the prompts, the user may enter y, Y, or SPC to act on that object; +n, N, or DEL to skip that object; ! to act on all following objects; +ESC or q to exit (skip all following objects); . (period) to act on the +current object and then exit; or \\[help-command] to get help. + +If ACTION-ALIST is given, it is an alist (KEY FUNCTION HELP) of extra keys +that will be accepted. KEY is a character; FUNCTION is a function of one +arg (an object from LIST); HELP is a string. When the user hits KEY, +FUNCTION is called. If it returns non-nil, the object is considered +\"acted upon\", and the next object from LIST is processed. If it returns +nil, the prompt is repeated for the same object. + +Final optional argument NO-CURSOR-IN-ECHO-AREA non-nil says not to set +`cursor-in-echo-area' while prompting. + +This function uses `query-replace-map' to define the standard responses, +but not all of the responses which `query-replace' understands +are meaningful here. + +Returns the number of actions taken." + (let* ((actions 0) + user-keys mouse-event map prompt char elt def + ;; Non-nil means we should use mouse menus to ask. + ;; use-menus + ;;delayed-switch-frame + (next (if (or (and list (symbolp list)) + (subrp list) + (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)))))) + (if (should-use-dialog-box-p) + ;; Make a list describing a dialog box. + (let (;; (object (capitalize (or (nth 0 help) "object"))) + ;; (objects (capitalize (or (nth 1 help) "objects"))) + ;; (action (capitalize (or (nth 2 help) "act on"))) + ) + (setq map `(("Yes" . act) ("No" . skip) +; bogus crap. --ben +; ((, (if help +; (capitalize +; (or (nth 3 help) +; (concat action " All " objects))) +; "Do All")) . automatic) +; ((, (if help +; (capitalize +; (or (nth 4 help) +; (concat action " " object " And Quit"))) +; "Do it and Quit")) . act-and-exit) +; ((, (capitalize +; (or (and help (nth 5 help)) "Quit"))) +; . exit) + ("Yes All" . automatic) + ("No All" . exit) + ("Cancel" . quit) + ,@(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))))) + action-alist ", ") + " ") + "") + ;; Make a map that defines each user key as a vector containing + ;; its definition. + ;; XEmacs + map (let ((foomap (make-sparse-keymap))) + (mapcar #'(lambda (elt) + (define-key + foomap + (if (characterp (car elt)) + (char-to-string (car elt)) + (car elt)) + (vector (nth 1 elt)))) + action-alist) + (set-keymap-parents foomap (list query-replace-map)) + foomap))) + (unwind-protect + (progn + (if (stringp prompter) + (setq prompter (` (lambda (object) + (format (, prompter) object))))) + (while (funcall next) + (setq prompt (funcall prompter elt)) + (cond ((stringp prompt) + ;; Prompt the user about this object. + (setq quit-flag nil) + (if mouse-event ; XEmacs + (setq def (or (get-dialog-box-response + mouse-event + (cons prompt map)) + 'quit)) + ;; Prompt in the echo area. + (let ((cursor-in-echo-area (not no-cursor-in-echo-area))) + (display-message + 'prompt + (format "%s(y, n, !, ., q, %sor %s) " + prompt user-keys + (key-description (vector help-char)))) + (setq char (next-command-event)) + ;; Show the answer to the question. + (display-message + 'prompt + (format + "%s(y, n, !, ., q, %sor %s) %s" + prompt user-keys + (key-description (vector help-char)) + (single-key-description char)))) + (setq def (lookup-key map (vector char)))) + (cond ((eq def 'exit) + (setq next (function (lambda () nil)))) + ((eq def 'act) + ;; Act on the object. + (funcall actor elt) + (setq actions (1+ actions))) + ((eq def 'skip) + ;; Skip the object. + ) + ((eq def 'act-and-exit) + ;; Act on the object and then exit. + (funcall actor elt) + (setq actions (1+ actions) + next (function (lambda () nil)))) + ((or (eq def 'quit) (eq def 'exit-prefix)) + (setq quit-flag t) + (setq next (` (lambda () + (setq next '(, next)) + '(, elt))))) + ((eq def 'automatic) + ;; Act on this and all following objects. + ;; (if (funcall prompter elt) ; Emacs + (if (eval (funcall prompter elt)) + (progn + (funcall actor elt) + (setq actions (1+ actions)))) + (while (funcall next) + ;; (funcall prompter elt) ; Emacs + (if (eval (funcall prompter elt)) + (progn + (funcall actor elt) + (setq actions (1+ actions)))))) + ((eq def 'help) + (with-output-to-temp-buffer "*Help*" + (princ + (let ((object (if help (nth 0 help) "object")) + (objects (if help (nth 1 help) "objects")) + (action (if help (nth 2 help) "act on"))) + (concat + (format "Type SPC or `y' to %s the current %s; +DEL or `n' to skip the current %s; +! to %s all remaining %s; +ESC or `q' to exit;\n" + action object object action objects) + (mapconcat (function + (lambda (elt) + (format "%c to %s" + (nth 0 elt) + (nth 2 elt)))) + action-alist + ";\n") + (if action-alist ";\n") + (format "or . (period) to %s \ +the current %s and exit." + action object)))) + (save-excursion + (set-buffer standard-output) + (help-mode))) + + (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)))))) + ;((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))))) + (t + ;; Random char. + (message "Type %s for help." + (key-description (vector help-char))) + (beep) + (sit-for 1) + (setq next (` (lambda () + (setq next '(, next)) + '(, elt))))))) + ((eval prompt) + (progn + (funcall actor elt) + (setq actions (1+ actions))))))) + ;;(if delayed-switch-frame + ;; (setq unread-command-events + ;; (cons delayed-switch-frame unread-command-events)))) + ;; ((eval prompt) + ;; (progn + ;; (funcall actor elt) + ;; (setq actions (1+ actions))))) + ) + ;; Clear the last prompt from the minibuffer. + (clear-message 'prompt) + ;; Return the number of actions that were taken. + actions)) + +;;; map-ynp.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/menubar.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,526 @@ +;;; menubar.el --- Menubar support for XEmacs + +;; Copyright (C) 1991-4, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp. +;; Copyright (C) 1995, 1996 Ben Wing. + +;; Maintainer: XEmacs Development Team +;; Keywords: internal, extensions, dumped + +;; 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, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: Not in FSF. (Completely divergent from FSF menu-bar.el) + +;;; Commentary: + +;; This file is dumped with XEmacs (when menubar support is compiled in). + +;; Some stuff in FSF menu-bar.el is in x-menubar.el + +;;; Code: + +(defvar default-menubar nil) + +;; this function is considered "part of the lexicon" by many, +;; so we'll leave it here. +(defun kill-this-buffer () ; for the menubar + "Kill the current buffer." + (interactive) + (kill-buffer (current-buffer))) + +(defun set-menubar-dirty-flag () + "Tell XEmacs that the menubar has to be updated. +NOTE: XEmacs now recognizes when you set a different value for +`current-menubar'. You *only* need to call this function if you +destructively modify a part of the menubar and don't set `current-menubar'. +Note that all the functions that modify a menu call this automatically." + (setq-default current-menubar (default-value 'current-menubar))) + +;; #### shouldn't this perhaps be `copy-tree'? +(defun set-menubar (menubar) + "Set the default menubar to be MENUBAR. +See `current-menubar' for a description of the syntax of a menubar." + (check-menu-syntax menubar t) + (setq-default current-menubar (copy-sequence menubar))) + +(defun set-buffer-menubar (menubar) + "Set the buffer-local menubar to be MENUBAR. +See `current-menubar' for a description of the syntax of a menubar." + (check-menu-syntax menubar t) + (make-local-variable 'current-menubar) + (setq current-menubar (copy-sequence menubar))) + +(defun check-menu-syntax (menu &optional menubar-p) + ;; The C code does syntax checking on the value of `current-menubar', + ;; but it's better to do it early, before things have gotten messed up. + (if menubar-p + nil + (or (stringp (car menu)) + (signal 'error + (list "menu name (first element) must be a string" menu))) + ;;(or (cdr menu) (signal 'error (list "menu is empty" menu))) + (setq menu (cdr menu))) + (let (menuitem item) + (while (keywordp (setq item (car menu))) + (or (memq item '(:config :included :filter :accelerator)) + (signal 'error + (list "menu keyword must be :config, :included, :accelerator or :filter" + item))) + (if (or (not (cdr menu)) + (vectorp (nth 1 menu)) + (keywordp (nth 1 menu))) + (signal 'error (list "strange keyword value" item (nth 1 menu)))) + (setq menu (nthcdr 2 menu))) + (while menu + (setq menuitem (car menu)) + (cond + ((stringp menuitem) + (and (string-match "^\\(-+\\|=+\\):\\(.*\\)" menuitem) + (setq item (match-string 2 menuitem)) + (or (member item '(;; Motif-compatible + "singleLine" + "doubleLine" + "singleDashedLine" + "doubleDashedLine" + "noLine" + "shadowEtchedIn" + "shadowEtchedOut" + "shadowEtchedInDash" + "shadowEtchedOutDash" + ;; non-Motif (Lucid menubar widget only) + "shadowDoubleEtchedIn" + "shadowDoubleEtchedOut" + "shadowDoubleEtchedInDash" + "shadowDoubleEtchedOutDash" + )) + (signal 'error (list "bogus separator style in menu item" item))) + )) + ((null menuitem) + (or menubar-p + (signal 'error (list "nil is only permitted in the top level of menubars")))) + ((consp menuitem) + (check-menu-syntax menuitem)) + ((vectorp menuitem) + (let ((L (length menuitem)) + plistp) + (and (< L 3) + (signal 'error + (list "button descriptors must be at least 3 long" + menuitem))) + (setq plistp (or (>= L 5) (keywordp (aref menuitem 2)))) + (or (stringp (aref menuitem 0)) + (signal 'error + (list + "first element of a button must be a string (the label)" + menuitem))) + (or plistp + (< L 4) + (null (aref menuitem 3)) + (stringp (aref menuitem 3)) + (signal 'error + (list + "fourth element of a button must be a string (the label suffix)" + menuitem))) + (if plistp + (let ((i 2) + selp + style + item) + (while (< i L) + (setq item (aref menuitem i)) + (cond ((not (memq item '(:active :suffix :keys :style + :full :included :selected + :accelerator))) + (signal 'error + (list (if (keywordp item) + "unknown menu item keyword" + "not a keyword") + item menuitem))) + ((eq item :style) + (setq style (aref menuitem (1+ i))) + (or (memq style '(nil toggle radio button text)) + (signal 'error (list "unknown style" style + menuitem)))) + ((eq item :selected) (setq selp t)) + ) + (setq i (+ i (if (eq item :full) 1 2)))) + (if (and selp (not (memq style '(toggle button radio)))) + (signal 'error + (list + ":selected only makes sense with :style toggle, radio, or button" + menuitem))) + ))) + ) + (t (signal 'error (list "unrecognised menu descriptor" menuitem)))) + (setq menu (cdr menu))))) + + +;;; menu manipulation functions + +(defun find-menu-item (menubar item-path-list &optional parent) + "Search MENUBAR for item given by ITEM-PATH-LIST starting from PARENT. +Returns (ITEM . PARENT), where PARENT is the immediate parent of + the item found. +If the item does not exist, the car of the returned value is nil. +If some menu in the ITEM-PATH-LIST does not exist, an error is signalled." + (or (listp item-path-list) + (signal 'wrong-type-argument (list 'listp item-path-list))) + (or parent (setq item-path-list (mapcar 'normalize-menu-item-name item-path-list))) + (if (not (consp menubar)) + nil + (let ((rest menubar) + result) + (if (stringp (car rest)) + (setq rest (cdr rest))) + (while (keywordp (car rest)) + (setq rest (cddr rest))) + (while rest + (if (and (car rest) + (equal (car item-path-list) + (normalize-menu-item-name (if (vectorp (car rest)) + (aref (car rest) 0) + (if (stringp (car rest)) + (car rest) + (car (car rest))))))) + (setq result (car rest) rest nil) + (setq rest (cdr rest)))) + (if (cdr item-path-list) + (if (consp result) + (find-menu-item (cdr result) (cdr item-path-list) result) + (if result + (signal 'error (list (gettext "not a submenu") result)) + (signal 'error (list (gettext "no such submenu") (car item-path-list))))) + (cons result parent))))) + +(defun add-menu-item-1 (leaf-p menu-path new-item before) + ;; This code looks like it could be cleaned up some more + ;; Do we really need 6 calls to find-menu-item? + (when before (setq before (normalize-menu-item-name before))) + (let* ((item-name + (cond ((vectorp new-item) (aref new-item 0)) + ((consp new-item) (car new-item)) + (t nil))) + (menubar current-menubar) + (menu (condition-case () + (car (find-menu-item menubar menu-path)) + (error nil))) + (item-found (cond + ((null item-name) + nil) + ((not (listp menu)) + (signal 'error (list (gettext "not a submenu") + menu-path))) + (menu + (find-menu-item (cdr menu) (list item-name))) + (t + (find-menu-item menubar (list item-name))) + ))) + (unless menubar + (error "`current-menubar' is nil: can't add menus to it.")) + (unless menu + (let ((rest menu-path) + (so-far menubar)) + (while rest +;;; (setq menu (car (find-menu-item (cdr so-far) (list (car rest))))) + (setq menu + (if (eq so-far menubar) + (car (find-menu-item so-far (list (car rest)))) + (car (find-menu-item (cdr so-far) (list (car rest)))))) + (unless menu + (let ((rest2 so-far)) + (while (and (cdr rest2) (car (cdr rest2))) + (setq rest2 (cdr rest2))) + (setcdr rest2 + (nconc (list (setq menu (list (car rest)))) + (cdr rest2))))) + (setq so-far menu) + (setq rest (cdr rest))))) + (if (and item-found (car item-found)) + ;; hack the item in place. + (if menu + ;; Isn't it very bad form to use nsubstitute for side effects? + (nsubstitute new-item (car item-found) menu) + (setq current-menubar (nsubstitute new-item + (car item-found) + current-menubar))) + ;; OK, we have to add the whole thing... + ;; if BEFORE is specified, try to add it there. + (unless menu (setq menu current-menubar)) + (when before + (setq before (car (find-menu-item menu (list before))))) + (let ((rest menu) + (added-before nil)) + (while rest + (if (eq before (car (cdr rest))) + (progn + (setcdr rest (cons new-item (cdr rest))) + (setq rest nil added-before t)) + (setq rest (cdr rest)))) + (when (not added-before) + ;; adding before the first item on the menubar itself is harder + (if (and (eq menu menubar) (eq before (car menu))) + (setq menu (cons new-item menu) + current-menubar menu) + ;; otherwise, add the item to the end. + (nconc menu (list new-item)))))) + (set-menubar-dirty-flag) + new-item)) + +(defun add-menu-button (menu-path menu-leaf &optional before) + "Add a menu item to some menu, creating the menu first if necessary. +If the named item exists already, it is changed. +MENU-PATH identifies the menu under which the new menu item should be inserted. + It is a list of strings; for example, (\"File\") names the top-level \"File\" + menu. (\"File\" \"Foo\") names a hypothetical submenu of \"File\". +MENU-LEAF is a menubar leaf node. See the documentation of `current-menubar'. +BEFORE, if provided, is the name of a menu item before which this item should + be added, if this item is not on the menu already. If the item is already + present, it will not be moved." + (add-menu-item-1 t menu-path menu-leaf before)) + +;; I actually liked the old name better, but the interface has changed too +;; drastically to keep it. --Stig +(defun add-submenu (menu-path submenu &optional before) + "Add a menu to the menubar or one of its submenus. +If the named menu exists already, it is changed. +MENU-PATH identifies the menu under which the new menu should be inserted. + It is a list of strings; for example, (\"File\") names the top-level \"File\" + menu. (\"File\" \"Foo\") names a hypothetical submenu of \"File\". + If MENU-PATH is nil, then the menu will be added to the menubar itself. +SUBMENU is the new menu to add. + See the documentation of `current-menubar' for the syntax. +BEFORE, if provided, is the name of a menu before which this menu should + be added, if this menu is not on its parent already. If the menu is already + present, it will not be moved." + (check-menu-syntax submenu nil) + (add-menu-item-1 nil menu-path submenu before)) + +(defun purecopy-menubar (x) + ;; this calls purecopy on the strings, and the contents of the vectors, + ;; but not on the vectors themselves, or the conses - those must be + ;; writable. + (cond ((vectorp x) + (let ((i (length x))) + (while (> i 0) + (aset x (1- i) (purecopy (aref x (1- i)))) + (setq i (1- i)))) + x) + ((consp x) + (let ((rest x)) + (while rest + (setcar rest (purecopy-menubar (car rest))) + (setq rest (cdr rest)))) + x) + (t + (purecopy x)))) + +(defun delete-menu-item (path) + "Remove the named menu item from the menu hierarchy. +PATH is a list of strings which identify the position of the menu item in +the menu hierarchy. The documentation of `add-submenu' describes menu-paths." + (let* ((pair (condition-case nil (find-menu-item current-menubar path) + (error nil))) + (item (car pair)) + (parent (or (cdr pair) current-menubar))) + (if (not item) + nil + ;; the menubar is the only special case, because other menus begin + ;; with their name. + (if (eq parent current-menubar) + (setq current-menubar (delq item parent)) + (delq item parent)) + (set-menubar-dirty-flag) + item))) + +(defun relabel-menu-item (path new-name) + "Change the string of the specified menu item. +PATH is a list of strings which identify the position of the menu item in +the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" +under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the +menu item called \"Item\" under the \"Foo\" submenu of \"Menu\". +NEW-NAME is the string that the menu item will be printed as from now on." + (or (stringp new-name) + (setq new-name (signal 'wrong-type-argument (list 'stringp new-name)))) + (let* ((menubar current-menubar) + (pair (find-menu-item menubar path)) + (item (car pair)) + (menu (cdr pair))) + (or item + (signal 'error (list (if menu (gettext "No such menu item") + (gettext "No such menu")) + path))) + (if (and (consp item) + (stringp (car item))) + (setcar item new-name) + (aset item 0 new-name)) + (set-menubar-dirty-flag) + item)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; these are all bad style. Why in the world would we put evaluable forms +;; into the menubar if we didn't want people to use 'em? +;; x-font-menu.el is the only known offender right now and that ought to be +;; rehashed a bit. +;; + +(defun enable-menu-item-1 (path toggle-p on-p) + (let (menu item) + (if (and (vectorp path) (> (length path) 2)) ; limited syntax checking... + (setq item path) + (let* ((menubar current-menubar) + (pair (find-menu-item menubar path))) + (setq item (car pair) + menu (cdr pair)) + (or item + (signal 'error (list (if menu + "No such menu item" + "No such menu") + path))) + (if (consp item) + (error "%S is a menu, not a menu item" path)))) + (if (or (> (length item) 4) + (and (symbolp (aref item 2)) + (= ?: (aref (symbol-name (aref item 2)) 0)))) + ;; plist-like syntax + (let ((i 2) + (keyword (if toggle-p :selected :active)) + (ok nil)) + (while (< i (length item)) + (cond ((eq (aref item i) keyword) + (aset item (1+ i) on-p) + (setq ok t))) + (setq i (+ i 2))) + (cond (ok nil) + (toggle-p + (signal 'error (list "not a toggle menu item" item))) + (t + ;; Need to copy the item to extend it, sigh... + (let ((cons (memq item menu)) + (new-item (vconcat item (list keyword on-p)))) + (if cons + (setcar cons (setq item new-item)) + (if menu + (error "couldn't find %S on its parent?" item) + (error "no %S slot to set: %S" keyword item))))))) + ;; positional syntax + (if toggle-p + (signal 'error (list "not a toggle menu item" item)) + (aset item 2 on-p))) + (set-menubar-dirty-flag) + item)) + +(defun enable-menu-item (path) + "Make the named menu item be selectable. +PATH is a list of strings which identify the position of the menu item in +the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" +under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the +menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"." + (enable-menu-item-1 path nil t)) + +(defun disable-menu-item (path) + "Make the named menu item be unselectable. +PATH is a list of strings which identify the position of the menu item in +the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" +under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the +menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"." + (enable-menu-item-1 path nil nil)) + +(defun select-toggle-menu-item (path) + "Make the named toggle- or radio-style menu item be in the `selected' state. +PATH is a list of strings which identify the position of the menu item in +the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" +under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the +menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"." + (enable-menu-item-1 path t t)) + +(defun deselect-toggle-menu-item (path) + "Make the named toggle- or radio-style menu item be in the `unselected' state. +PATH is a list of strings which identify the position of the menu item in +the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" +under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the +menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"." + (enable-menu-item-1 path t nil)) + + +(defun get-popup-menu-response (menu-desc &optional event) + "Pop up the given menu and wait for a response. +This blocks until the response is received, and returns the misc-user +event that encapsulates the response. To execute it, you can do + (funcall (event-function response) (event-object response)) +If no response was received, nil is returned. + +MENU-DESC and EVENT are as in the call to `popup-menu'." + ;; partially stolen from w3 + (let ((echo-keystrokes 0) + new-event) + (popup-menu menu-desc event) + (catch 'popup-done + (while t + (setq new-event (next-command-event new-event)) + (cond ((misc-user-event-p new-event) + (throw 'popup-done new-event)) + ((not (popup-up-p)) + (setq unread-command-events (cons new-event + unread-command-events)) + (throw 'popup-done nil)) + ((button-release-event-p new-event);; don't beep twice + nil) + ((event-matches-key-specifier-p (quit-char)) + (signal 'quit nil)) + (t + (beep) + (message "please make a choice from the menu."))))))) + +(defun popup-menu-and-execute-in-window (menu-desc event) + "Pop up the given menu and execute its response in EVENT's window. +This blocks until the response is received, temporarily selects +EVENT's window, and executes the command specified in the response. +EVENT can also be a window. See `popup-menu' for the semantics of +MENU-DESC." + (let ((response + (get-popup-menu-response menu-desc + (and (eventp event) event)))) + (and (misc-user-event-p response) + (save-selected-window + (select-window (if (windowp event) event + (event-window event))) + (funcall (event-function response) + (event-object response)))))) + +;; provide default bindings for menu accelerator map +(and (boundp 'menu-accelerator-map) + (keymapp menu-accelerator-map) + (progn + (define-key menu-accelerator-map "\e" 'menu-escape) + (define-key menu-accelerator-map [left] 'menu-left) + (define-key menu-accelerator-map [right] 'menu-right) + (define-key menu-accelerator-map [up] 'menu-up) + (define-key menu-accelerator-map [down] 'menu-down) + (define-key menu-accelerator-map [return] 'menu-select) + (define-key menu-accelerator-map [kp_down] 'menu-down) + (define-key menu-accelerator-map [kp_up] 'menu-down) + (define-key menu-accelerator-map [kp_left] 'menu-left) + (define-key menu-accelerator-map [kp_right] 'menu-right) + (define-key menu-accelerator-map [kp_enter] 'menu-select) + (define-key menu-accelerator-map "\C-g" 'menu-quit))) + + +(provide 'menubar) + +;;; menubar.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/minibuf.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,2112 @@ +;;; minibuf.el --- Minibuffer functions for XEmacs + +;; Copyright (C) 1992, 1993, 1994, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1995 Tinker Systems +;; Copyright (C) 1995, 1996 Ben Wing + +;; Author: Richard Mlynarik +;; Created: 2-Oct-92 +;; Maintainer: XEmacs Development Team +;; Keywords: internal, dumped + +;; 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, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: all the minibuffer history stuff is synched with +;;; 19.30. Not sure about the rest. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;; Written by Richard Mlynarik 2-Oct-92 + +;; 06/11/1997 - Use char-(after|before) instead of +;; (following|preceding)-char. -slb + +;;; Code: + +(defgroup minibuffer nil + "Minibuffer customizations" + :group 'environment) + + +(defcustom insert-default-directory t + "*Non-nil means when reading a filename start with default dir in minibuffer." + :type 'boolean + :group 'minibuffer) + +(defcustom minibuffer-history-uniquify t + "*Non-nil means when adding an item to a minibuffer history, remove +previous occurances of the same item from the history list first, +rather than just consing the new element onto the front of the list." + :type 'boolean + :group 'minibuffer) + +(defvar minibuffer-completion-table nil + "Alist or obarray used for completion in the minibuffer. +This becomes the ALIST argument to `try-completion' and `all-completions'. + +The value may alternatively be a function, which is given three arguments: + STRING, the current buffer contents; + PREDICATE, the predicate for filtering possible matches; + CODE, which says what kind of things to do. +CODE can be nil, t or `lambda'. +nil means to return the best completion of STRING, nil if there is none, + or t if it is was already a unique completion. +t means to return a list of all possible completions of STRING. +`lambda' means to return t if STRING is a valid completion as it stands.") + +(defvar minibuffer-completion-predicate nil + "Within call to `completing-read', this holds the PREDICATE argument.") + +(defvar minibuffer-completion-confirm nil + "Non-nil => demand confirmation of completion before exiting minibuffer.") + +(defvar minibuffer-confirm-incomplete nil + "If true, then in contexts where completing-read allows answers which +are not valid completions, an extra RET must be typed to confirm the +response. This is helpful for catching typos, etc.") + +(defcustom completion-auto-help t + "*Non-nil means automatically provide help for invalid completion input." + :type 'boolean + :group 'minibuffer) + +(defcustom enable-recursive-minibuffers nil + "*Non-nil means to allow minibuffer commands while in the minibuffer. +More precisely, this variable makes a difference when the minibuffer window +is the selected window. If you are in some other window, minibuffer commands +are allowed even if a minibuffer is active." + :type 'boolean + :group 'minibuffer) + +(defcustom minibuffer-max-depth 1 + ;; See comment in #'minibuffer-max-depth-exceeded + "*Global maximum number of minibuffers allowed; +compare to enable-recursive-minibuffers, which is only consulted when the +minibuffer is reinvoked while it is the selected window." + :type '(choice integer + (const :tag "Indefinite" nil)) + :group 'minibuffer) + +;; Moved to C. The minibuffer prompt must be setup before this is run +;; and that can only be done from the C side. +;(defvar minibuffer-setup-hook nil +; "Normal hook run just after entry to minibuffer.") + +(defvar minibuffer-exit-hook nil + "Normal hook run just after exit from minibuffer.") + +(defvar minibuffer-help-form nil + "Value that `help-form' takes on inside the minibuffer.") + +(defvar minibuffer-local-map + (let ((map (make-sparse-keymap 'minibuffer-local-map))) + map) + "Default keymap to use when reading from the minibuffer.") + +(defvar minibuffer-local-completion-map + (let ((map (make-sparse-keymap 'minibuffer-local-completion-map))) + (set-keymap-parents map (list minibuffer-local-map)) + map) + "Local keymap for minibuffer input with completion.") + +(defvar minibuffer-local-must-match-map + (let ((map (make-sparse-keymap 'minibuffer-must-match-map))) + (set-keymap-parents map (list minibuffer-local-completion-map)) + map) + "Local keymap for minibuffer input with completion, for exact match.") + +;; (define-key minibuffer-local-map "\C-g" 'abort-recursive-edit) +(define-key minibuffer-local-map "\C-g" 'minibuffer-keyboard-quit) ;; moved here from pending-del.el +(define-key minibuffer-local-map "\r" 'exit-minibuffer) +(define-key minibuffer-local-map "\n" 'exit-minibuffer) + +;; Historical crock. Unused by anything but user code, if even that +;(defvar minibuffer-local-ns-map +; (let ((map (make-sparse-keymap 'minibuffer-local-ns-map))) +; (set-keymap-parents map (list minibuffer-local-map)) +; map) +; "Local keymap for the minibuffer when spaces are not allowed.") +;(define-key minibuffer-local-ns-map [space] 'exit-minibuffer) +;(define-key minibuffer-local-ns-map [tab] 'exit-minibuffer) +;(define-key minibuffer-local-ns-map [?\?] 'self-insert-and-exit) + +(define-key minibuffer-local-completion-map "\t" 'minibuffer-complete) +(define-key minibuffer-local-completion-map " " 'minibuffer-complete-word) +(define-key minibuffer-local-completion-map "?" 'minibuffer-completion-help) +(define-key minibuffer-local-must-match-map "\r" 'minibuffer-complete-and-exit) +(define-key minibuffer-local-must-match-map "\n" 'minibuffer-complete-and-exit) + +(define-key minibuffer-local-map "\M-n" 'next-history-element) +(define-key minibuffer-local-map "\M-p" 'previous-history-element) +(define-key minibuffer-local-map '[next] "\M-n") +(define-key minibuffer-local-map '[prior] "\M-p") +(define-key minibuffer-local-map "\M-r" 'previous-matching-history-element) +(define-key minibuffer-local-map "\M-s" 'next-matching-history-element) +(define-key minibuffer-local-must-match-map [next] + 'next-complete-history-element) +(define-key minibuffer-local-must-match-map [prior] + 'previous-complete-history-element) + +;; This is an experiment--make up and down arrows do history. +(define-key minibuffer-local-map [up] 'previous-history-element) +(define-key minibuffer-local-map [down] 'next-history-element) +(define-key minibuffer-local-completion-map [up] 'previous-history-element) +(define-key minibuffer-local-completion-map [down] 'next-history-element) +(define-key minibuffer-local-must-match-map [up] 'previous-history-element) +(define-key minibuffer-local-must-match-map [down] 'next-history-element) + +(defvar read-expression-map (let ((map (make-sparse-keymap + 'read-expression-map))) + (set-keymap-parents map + (list minibuffer-local-map)) + (define-key map "\M-\t" 'lisp-complete-symbol) + map) + "Minibuffer keymap used for reading Lisp expressions.") + +(defvar read-shell-command-map + (let ((map (make-sparse-keymap 'read-shell-command-map))) + (set-keymap-parents map (list minibuffer-local-map)) + (define-key map "\t" 'comint-dynamic-complete) + (define-key map "\M-\t" 'comint-dynamic-complete) + (define-key map "\M-?" 'comint-dynamic-list-completions) + map) + "Minibuffer keymap used by shell-command and related commands.") + +(defcustom use-dialog-box t + "*Variable controlling usage of the dialog box. +If nil, the dialog box will never be used, even in response to mouse events." + :type 'boolean + :group 'minibuffer) + +(defcustom minibuffer-electric-file-name-behavior t + "*If non-nil, slash and tilde in certain places cause immediate deletion. +These are the same places where this behavior would occur later on anyway, +in `substitute-in-file-name'." + :type 'boolean + :group 'minibuffer) + +(defun minibuffer-electric-slash () + ;; by Stig@hackvan.com + (interactive) + (and minibuffer-electric-file-name-behavior + (eq ?/ (char-before (point))) + (not (save-excursion + (goto-char (point-min)) + (and (looking-at "^/.+:~?") + (re-search-forward "^/.+:~?[^/]*" nil t) + (progn + (delete-region (point) (point-max)) + t)))) + (not (eq (point) (1+ (point-min)))) ; permit `//hostname/path/to/file' + (not (eq ?: (char-after (- (point) 2)))) ; permit `http://url/goes/here' + (delete-region (point-min) (point))) + (insert ?/)) + +(defun minibuffer-electric-tilde () + (interactive) + (and minibuffer-electric-file-name-behavior + (eq ?/ (char-before (point))) + ;; permit URL's with //, for e.g. http://hostname/~user + (not (save-excursion (search-backward "//" nil t))) + (delete-region (point-min) (point))) + (insert ?~)) + +(defvar read-file-name-map + (let ((map (make-sparse-keymap 'read-file-name-map))) + (set-keymap-parents map (list minibuffer-local-completion-map)) + (define-key map "/" 'minibuffer-electric-slash) + (define-key map "~" 'minibuffer-electric-tilde) + map + )) + +(defvar read-file-name-must-match-map + (let ((map (make-sparse-keymap 'read-file-name-map))) + (set-keymap-parents map (list minibuffer-local-must-match-map)) + (define-key map "/" 'minibuffer-electric-slash) + (define-key map "~" 'minibuffer-electric-tilde) + map + )) + +(defun minibuffer-keyboard-quit () + "Abort recursive edit. +If `zmacs-regions' is true, and the zmacs region is active in this buffer, +then this key deactivates the region without beeping." + (interactive) + (if (and (region-active-p) + (eq (current-buffer) (zmacs-region-buffer))) + ;; pseudo-zmacs compatibility: don't beep if this ^G is simply + ;; deactivating the region. If it is inactive, beep. + nil + (abort-recursive-edit))) + +;;;; Guts of minibuffer invocation + +;;#### The only things remaining in C are +;; "Vminibuf_prompt" and the display junk +;; "minibuf_prompt_width" and "minibuf_prompt_pix_width" +;; Also "active_frame", though I suspect I could already +;; hack that in Lisp if I could make any sense of the +;; complete mess of frame/frame code in XEmacs. +;; Vminibuf_prompt could easily be made Lisp-bindable. +;; I suspect that minibuf_prompt*_width are actually recomputed +;; by redisplay as needed -- or could be arranged to be so -- +;; and that there could be need for read-minibuffer-internal to +;; save and restore them. +;;#### The only other thing which read-from-minibuffer-internal does +;; which we can't presently do in Lisp is move the frame cursor +;; to the start of the minibuffer line as it returns. This is +;; a rather nice touch and should be preserved -- probably by +;; providing some Lisp-level mechanism (extension to cursor-in-echo-area ?) +;; to effect it. + + +;; Like reset_buffer in FSF's buffer.c +;; (Except that kill-all-local-variables doesn't nuke 'permanent-local +;; variables -- we preserve them, reset_buffer doesn't.) +(defun reset-buffer (buffer) + (with-current-buffer buffer + ;(if (fboundp 'unlock-buffer) (unlock-buffer)) + (kill-all-local-variables) + (setq buffer-read-only nil) + (erase-buffer) + ;(setq default-directory nil) + (setq buffer-file-name nil) + (setq buffer-file-truename nil) + (set-buffer-modified-p nil) + (setq buffer-backed-up nil) + (setq buffer-auto-save-file-name nil) + (set-buffer-dedicated-frame buffer nil) + buffer)) + +(defvar minibuffer-history-variable 'minibuffer-history + "History list symbol to add minibuffer values to. +Each minibuffer output is added with + (set minibuffer-history-variable + (cons STRING (symbol-value minibuffer-history-variable)))") +(defvar minibuffer-history-position) + +;; Added by hniksic: +(defvar initial-minibuffer-history-position) +(defvar current-minibuffer-contents) +(defvar current-minibuffer-point) + +(defcustom minibuffer-history-minimum-string-length 3 + "*If this variable is non-nil, a string will not be added to the +minibuffer history if its length is less than that value." + :type '(choice (const :tag "Any" nil) + integer) + :group 'minibuffer) + +(define-error 'input-error "Keyboard input error") + +(put 'input-error 'display-error + #'(lambda (error-object stream) + (princ (cadr error-object) stream))) + +(defun read-from-minibuffer (prompt &optional initial-contents + keymap + readp + history + abbrev-table) + "Read a string from the minibuffer, prompting with string PROMPT. +If optional second arg INITIAL-CONTENTS is non-nil, it is a string + to be inserted into the minibuffer before reading input. + If INITIAL-CONTENTS is (STRING . POSITION), the initial input + is STRING, but point is placed POSITION characters into the string. +Third arg KEYMAP is a keymap to use whilst reading; + 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: + in other words, do `(car (read-from-string INPUT-STRING))' +Fifth arg HISTORY, if non-nil, specifies a history list + and optionally the initial position in the list. + It can be a symbol, which is the history list variable to use, + or it can be a cons cell (HISTVAR . HISTPOS). + In that case, HISTVAR is the history list variable to use, + and HISTPOS is the initial position (the position in the list + which INITIAL-CONTENTS corresponds to). + If HISTORY is `t', no history will be recorded. + Positions are counted starting from 1 at the beginning of the list. +Sixth arg ABBREV-TABLE, if non-nil, becomes the value of `local-abbrev-table' + in the minibuffer. + +See also the variable completion-highlight-first-word-only for control over + completion display." + (if (and (not enable-recursive-minibuffers) + (> (minibuffer-depth) 0) + (eq (selected-window) (minibuffer-window))) + (error "Command attempted to use minibuffer while in minibuffer")) + + (if (and minibuffer-max-depth + (> minibuffer-max-depth 0) + (>= (minibuffer-depth) minibuffer-max-depth)) + (minibuffer-max-depth-exceeded)) + + ;; catch this error before the poor user has typed something... + (if history + (if (symbolp history) + (or (boundp history) + (error "History list %S is unbound" history)) + (or (boundp (car history)) + (error "History list %S is unbound" (car history))))) + + (if (noninteractive) + (progn + ;; XEmacs in -batch mode calls minibuffer: print the prompt. + (message "%s" (gettext prompt)) + ;;#### force-output + + ;;#### Should this even be falling though to the code below? + ;;#### How does this stuff work now, anyway? + )) + (let* ((dir default-directory) + (owindow (selected-window)) + (oframe (selected-frame)) + (window (minibuffer-window)) + (buffer (if (eq (minibuffer-depth) 0) + (window-buffer window) + (get-buffer-create (format " *Minibuf-%d" + (minibuffer-depth))))) + (frame (window-frame window)) + (mconfig (if (eq frame (selected-frame)) + nil (current-window-configuration frame))) + (oconfig (current-window-configuration)) + ;; dynamic scope sucks sucks sucks sucks sucks sucks. + ;; `M-x doctor' makes history a local variable, and thus + ;; our binding above is buffer-local and doesn't apply + ;; once we switch buffers!!!! We demand better scope! + (_history_ history)) + (unwind-protect + (progn + (set-buffer (reset-buffer buffer)) + (setq default-directory dir) + (make-local-variable 'print-escape-newlines) + (setq print-escape-newlines t) + (make-local-variable 'current-minibuffer-contents) + (make-local-variable 'current-minibuffer-point) + (make-local-variable 'initial-minibuffer-history-position) + (setq current-minibuffer-contents "" + current-minibuffer-point 1) + (if (not minibuffer-smart-completion-tracking-behavior) + nil + (make-local-variable 'mode-motion-hook) + (or mode-motion-hook + ;;####disgusting + (setq mode-motion-hook 'minibuffer-smart-mouse-tracker)) + (make-local-variable 'mouse-track-click-hook) + (add-hook 'mouse-track-click-hook + 'minibuffer-smart-maybe-select-highlighted-completion)) + (set-window-buffer window buffer) + (select-window window) + (set-window-hscroll window 0) + (buffer-enable-undo buffer) + (message nil) + (if initial-contents + (if (consp initial-contents) + (progn + (insert (car initial-contents)) + (goto-char (1+ (cdr initial-contents))) + (setq current-minibuffer-contents (car initial-contents) + current-minibuffer-point (cdr initial-contents))) + (insert initial-contents) + (setq current-minibuffer-contents initial-contents + current-minibuffer-point (point)))) + (use-local-map (or keymap minibuffer-local-map)) + (let ((mouse-grabbed-buffer + (and minibuffer-smart-completion-tracking-behavior + (current-buffer))) + (current-prefix-arg current-prefix-arg) + (help-form minibuffer-help-form) + (minibuffer-history-variable (cond ((not _history_) + 'minibuffer-history) + ((consp _history_) + (car _history_)) + (t + _history_))) + (minibuffer-history-position (cond ((consp _history_) + (cdr _history_)) + (t + 0))) + (minibuffer-scroll-window owindow)) + (setq initial-minibuffer-history-position + minibuffer-history-position) + (if abbrev-table + (setq local-abbrev-table abbrev-table + abbrev-mode t)) + ;; This is now run from read-minibuffer-internal + ;(if minibuffer-setup-hook + ; (run-hooks 'minibuffer-setup-hook)) + ;(message nil) + (if (eq 't + (catch 'exit + (if (> (recursion-depth) (minibuffer-depth)) + (let ((standard-output t) + (standard-input t)) + (read-minibuffer-internal prompt)) + (read-minibuffer-internal prompt)))) + ;; Translate an "abort" (throw 'exit 't) + ;; into a real quit + (signal 'quit '()) + ;; return value + (let* ((val (progn (set-buffer buffer) + (if minibuffer-exit-hook + (run-hooks 'minibuffer-exit-hook)) + (buffer-string))) + (histval val) + (err nil)) + (if readp + (condition-case e + (let ((v (read-from-string val))) + (if (< (cdr v) (length val)) + (save-match-data + (or (string-match "[ \t\n]*\\'" val (cdr v)) + (error "Trailing garbage following expression")))) + (setq v (car v)) + ;; total total kludge + (if (stringp v) (setq v (list 'quote v))) + (setq val v)) + (end-of-file + (setq err + '(input-error "End of input before end of expression"))) + (error (setq err e)))) + ;; Add the value to the appropriate history list unless + ;; it's already the most recent element, or it's only + ;; two characters long. + (if (and (symbolp minibuffer-history-variable) + (boundp minibuffer-history-variable)) + (let ((list (symbol-value minibuffer-history-variable))) + (or (eq list t) + (null val) + (and list (equal histval (car list))) + (and (stringp val) + minibuffer-history-minimum-string-length + (< (length val) + minibuffer-history-minimum-string-length)) + (set minibuffer-history-variable + (if minibuffer-history-uniquify + (cons histval (remove histval list)) + (cons histval list)))))) + (if err (signal (car err) (cdr err))) + val)))) + ;; stupid display code requires this for some reason + (set-buffer buffer) + (buffer-disable-undo buffer) + (setq buffer-read-only nil) + (erase-buffer) + + ;; restore frame configurations + (if (and mconfig (frame-live-p oframe) + (eq frame (selected-frame))) + ;; if we changed frames (due to surrogate minibuffer), + ;; and we're still on the new frame, go back to the old one. + (select-frame oframe)) + (if mconfig (set-window-configuration mconfig)) + (set-window-configuration oconfig)))) + + +(defun minibuffer-max-depth-exceeded () + ;; + ;; This signals an error if an Nth minibuffer is invoked while N-1 are + ;; already active, whether the minibuffer window is selected or not. + ;; Since, under X, it's easy to jump out of the minibuffer (by doing M-x, + ;; getting distracted, and clicking elsewhere) many many novice users have + ;; had the problem of having multiple minibuffers build up, even to the + ;; point of exceeding max-lisp-eval-depth. Since the variable + ;; enable-recursive-minibuffers historically/crockishly is only consulted + ;; when the minibuffer is currently active (like typing M-x M-x) it doesn't + ;; help in this situation. + ;; + ;; This routine also offers to edit .emacs for you to get rid of this + ;; complaint, like `disabled' commands do, since it's likely that non-novice + ;; users will be annoyed by this change, so we give them an easy way to get + ;; rid of it forever. + ;; + (beep t 'minibuffer-limit-exceeded) + (message + "Minibuffer already active: abort it with `^]', enable new one with `n': ") + (let ((char (let ((cursor-in-echo-area t)) ; #### doesn't always work?? + (read-char)))) + (cond + ((eq char ?n) + (cond + ((y-or-n-p "Enable recursive minibuffers for other sessions too? ") + ;; This is completely disgusting, but it's basically what novice.el + ;; does. This kind of thing should be generalized. + (setq minibuffer-max-depth nil) + (save-excursion + (set-buffer + (find-file-noselect + (substitute-in-file-name custom-file))) + (goto-char (point-min)) + (if (re-search-forward + "^(setq minibuffer-max-depth \\([0-9]+\\|'?nil\\|'?()\\))\n" + nil t) + (delete-region (match-beginning 0 ) (match-end 0)) + ;; Must have been disabled by default. + (goto-char (point-max))) + (insert"\n(setq minibuffer-max-depth nil)\n") + (save-buffer)) + (message "Multiple minibuffers enabled") + (sit-for 1)))) + ((eq char ? ) + (abort-recursive-edit)) + (t + (error "Minibuffer already active"))))) + + +;;;; Guts of minibuffer completion + + +;; Used by minibuffer-do-completion +(defvar last-exact-completion) + +(defun temp-minibuffer-message (m) + (let ((savemax (point-max))) + (save-excursion + (goto-char (point-max)) + (message nil) + (insert m)) + (let ((inhibit-quit t)) + (sit-for 2) + (delete-region savemax (point-max)) + ;; If the user types a ^G while we're in sit-for, then quit-flag + ;; gets set. In this case, we want that ^G to be interpreted + ;; as a normal character, and act just like typeahead. + (if (and quit-flag (not unread-command-event)) + (setq unread-command-event (character-to-event (quit-char)) + quit-flag nil))))) + + +;; Determines whether buffer-string is an exact completion +(defun exact-minibuffer-completion-p (buffer-string) + (cond ((not minibuffer-completion-table) + ;; Empty alist + nil) + ((vectorp minibuffer-completion-table) + (let ((tem (intern-soft buffer-string + minibuffer-completion-table))) + (if (or tem + (and (string-equal buffer-string "nil") + ;; intern-soft loses for 'nil + (catch 'found + (mapatoms #'(lambda (s) + (if (string-equal + (symbol-name s) + buffer-string) + (throw 'found t))) + minibuffer-completion-table) + nil))) + (if minibuffer-completion-predicate + (funcall minibuffer-completion-predicate + tem) + t) + nil))) + ((and (consp minibuffer-completion-table) + ;;#### Emacs-Lisp truly sucks! + ;; lambda, autoload, etc + (not (symbolp (car minibuffer-completion-table)))) + (if (not completion-ignore-case) + (assoc buffer-string minibuffer-completion-table) + (let ((s (upcase buffer-string)) + (tail minibuffer-completion-table) + tem) + (while tail + (setq tem (car (car tail))) + (if (or (equal tem buffer-string) + (equal tem s) + (equal (upcase tem) s)) + (setq s 'win + tail nil) ;exit + (setq tail (cdr tail)))) + (eq s 'win)))) + (t + (funcall minibuffer-completion-table + buffer-string + minibuffer-completion-predicate + 'lambda))) + ) + +;; 0 'none no possible completion +;; 1 'unique was already an exact and unique completion +;; 3 'exact was already an exact (but nonunique) completion +;; NOT USED 'completed-exact-unique completed to an exact and completion +;; 4 'completed-exact completed to an exact (but nonunique) completion +;; 5 'completed some completion happened +;; 6 'uncompleted no completion happened +(defun minibuffer-do-completion-1 (buffer-string completion) + (cond ((not completion) + 'none) + ((eq completion t) + ;; exact and unique match + 'unique) + (t + ;; It did find a match. Do we match some possibility exactly now? + (let ((completedp (not (string-equal completion buffer-string)))) + (if completedp + (progn + ;; Some completion happened + (erase-buffer) + (insert completion) + (setq buffer-string completion))) + (if (exact-minibuffer-completion-p buffer-string) + ;; An exact completion was possible + (if completedp +;; Since no callers need to know the difference, don't bother +;; with this (potentially expensive) discrimination. +;; (if (eq (try-completion completion +;; minibuffer-completion-table +;; minibuffer-completion-predicate) +;; 't) +;; 'completed-exact-unique + 'completed-exact +;; ) + 'exact) + ;; Not an exact match + (if completedp + 'completed + 'uncompleted)))))) + + +(defun minibuffer-do-completion (buffer-string) + (let* ((completion (try-completion buffer-string + minibuffer-completion-table + minibuffer-completion-predicate)) + (status (minibuffer-do-completion-1 buffer-string completion)) + (last last-exact-completion)) + (setq last-exact-completion nil) + (cond ((eq status 'none) + ;; No completions + (ding nil 'no-completion) + (temp-minibuffer-message " [No match]")) + ((eq status 'unique) + ) + (t + ;; It did find a match. Do we match some possibility exactly now? + (if (not (string-equal completion buffer-string)) + (progn + ;; Some completion happened + (erase-buffer) + (insert completion) + (setq buffer-string completion))) + (cond ((eq status 'exact) + ;; If the last exact completion and this one were + ;; the same, it means we've already given a + ;; "Complete but not unique" message and that the + ;; user's hit TAB again, so now we give help. + (setq last-exact-completion completion) + (if (equal buffer-string last) + (minibuffer-completion-help))) + ((eq status 'uncompleted) + (if completion-auto-help + (minibuffer-completion-help) + (temp-minibuffer-message " [Next char not unique]"))) + (t + nil)))) + status)) + + +;;;; completing-read + +(defun completing-read (prompt table + &optional predicate require-match + initial-contents history) + "Read a string in the minibuffer, with completion. +Args: PROMPT, TABLE, PREDICATE, REQUIRE-MATCH, INITIAL-CONTENTS, HISTORY. +PROMPT is a string to prompt with; normally it ends in a colon and a space. +TABLE is an alist whose elements' cars are strings, or an obarray. +PREDICATE limits completion to a subset of TABLE. +See `try-completion' for more details on completion, TABLE, and PREDICATE. +If REQUIRE-MATCH is non-nil, the user is not allowed to exit unless + the input is (or completes to) an element of TABLE or is null. + If it is also not t, Return does not exit if it does non-null completion. +If INITIAL-CONTENTS is non-nil, insert it in the minibuffer initially. + If it is (STRING . POSITION), the initial input + is STRING, but point is placed POSITION characters into the string. +HISTORY, if non-nil, specifies a history list + and optionally the initial position in the list. + It can be a symbol, which is the history list variable to use, + or it can be a cons cell (HISTVAR . HISTPOS). + In that case, HISTVAR is the history list variable to use, + and HISTPOS is the initial position (the position in the list + which INITIAL-CONTENTS corresponds to). + If HISTORY is `t', no history will be recorded. + Positions are counted starting from 1 at the beginning of the list. +Completion ignores case if the ambient value of + `completion-ignore-case' is non-nil." + (let ((minibuffer-completion-table table) + (minibuffer-completion-predicate predicate) + (minibuffer-completion-confirm (if (eq require-match 't) nil t)) + (last-exact-completion nil)) + (read-from-minibuffer prompt + initial-contents + (if (not require-match) + minibuffer-local-completion-map + minibuffer-local-must-match-map) + nil + history))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Minibuffer completion commands ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +(defun minibuffer-complete () + "Complete the minibuffer contents as far as possible. +Return nil if there is no valid completion, else t. +If no characters can be completed, display a list of possible completions. +If you repeat this command after it displayed such a list, +scroll the window of possible completions." + (interactive) + ;; If the previous command was not this, then mark the completion + ;; buffer obsolete. + (or (eq last-command this-command) + (setq minibuffer-scroll-window nil)) + (let ((window minibuffer-scroll-window)) + (if (and window (windowp window) (window-buffer window) + (buffer-name (window-buffer window))) + ;; If there's a fresh completion window with a live buffer + ;; and this command is repeated, scroll that window. + (let ((obuf (current-buffer))) + (unwind-protect + (progn + (set-buffer (window-buffer window)) + (if (pos-visible-in-window-p (point-max) window) + ;; If end is in view, scroll up to the beginning. + (set-window-start window (point-min)) + ;; Else scroll down one frame. + (scroll-other-window))) + (set-buffer obuf)) + nil) + (let ((status (minibuffer-do-completion (buffer-string)))) + (if (eq status 'none) + nil + (progn + (cond ((eq status 'unique) + (temp-minibuffer-message + " [Sole completion]")) + ((eq status 'exact) + (temp-minibuffer-message + " [Complete, but not unique]"))) + t)))))) + + +(defun minibuffer-complete-and-exit () + "Complete the minibuffer contents, and maybe exit. +Exit if the name is valid with no completion needed. +If name was completed to a valid match, +a repetition of this command will exit." + (interactive) + (if (= (point-min) (point-max)) + ;; Crockishly allow user to specify null string + (throw 'exit nil)) + (let ((buffer-string (buffer-string))) + ;; Short-cut -- don't call minibuffer-do-completion if we already + ;; have an (possibly nonunique) exact completion. + (if (exact-minibuffer-completion-p buffer-string) + (throw 'exit nil)) + (let ((status (minibuffer-do-completion buffer-string))) + (if (or (eq status 'unique) + (eq status 'exact) + (if (or (eq status 'completed-exact) + (eq status 'completed-exact-unique)) + (if minibuffer-completion-confirm + (progn (temp-minibuffer-message " [Confirm]") + nil) + t))) + (throw 'exit nil))))) + + +(defun self-insert-and-exit () + "Terminate minibuffer input." + (interactive) + (self-insert-command 1) + (throw 'exit nil)) + +(defun exit-minibuffer () + "Terminate this minibuffer argument. +If minibuffer-confirm-incomplete is true, and we are in a completing-read +of some kind, and the contents of the minibuffer is not an existing +completion, requires an additional RET before the minibuffer will be exited +\(assuming that RET was the character that invoked this command: +the character in question must be typed again)." + (interactive) + (if (not minibuffer-confirm-incomplete) + (throw 'exit nil)) + (let ((buffer-string (buffer-string))) + (if (exact-minibuffer-completion-p buffer-string) + (throw 'exit nil)) + (let ((completion (if (not minibuffer-completion-table) + t + (try-completion buffer-string + minibuffer-completion-table + minibuffer-completion-predicate)))) + (if (or (eq completion 't) + ;; Crockishly allow user to specify null string + (string-equal buffer-string "")) + (throw 'exit nil)) + (if completion ;; rewritten for I18N3 snarfing + (temp-minibuffer-message " [incomplete; confirm]") + (temp-minibuffer-message " [no completions; confirm]")) + (let ((event (let ((inhibit-quit t)) + (prog1 + (next-command-event) + (setq quit-flag nil))))) + (cond ((equal event last-command-event) + (throw 'exit nil)) + ((equal (quit-char) (event-to-character event)) + ;; Minibuffer abort. + (throw 'exit t))) + (dispatch-event event))))) + +;;;; minibuffer-complete-word + + +;;;#### I think I have done this correctly; it certainly is simpler +;;;#### than what the C code seemed to be trying to do. +(defun minibuffer-complete-word () + "Complete the minibuffer contents at most a single word. +After one word is completed as much as possible, a space or hyphen +is added, provided that matches some possible completion. +Return nil if there is no valid completion, else t." + (interactive) + (let* ((buffer-string (buffer-string)) + (completion (try-completion buffer-string + minibuffer-completion-table + minibuffer-completion-predicate)) + (status (minibuffer-do-completion-1 buffer-string completion))) + (cond ((eq status 'none) + (ding nil 'no-completion) + (temp-minibuffer-message " [No match]") + nil) + ((eq status 'unique) + ;; New message, only in this new Lisp code + (temp-minibuffer-message " [Sole completion]") + t) + (t + (cond ((or (eq status 'uncompleted) + (eq status 'exact)) + (let ((foo #'(lambda (s) + (condition-case nil + (if (try-completion + (concat buffer-string s) + minibuffer-completion-table + minibuffer-completion-predicate) + (progn + (goto-char (point-max)) + (insert s) + t) + nil) + (error nil)))) + (char last-command-char)) + ;; Try to complete by adding a word-delimiter + (or (and (characterp char) (> char 0) + (funcall foo (char-to-string char))) + (and (not (eq char ?\ )) + (funcall foo " ")) + (and (not (eq char ?\-)) + (funcall foo "-")) + (progn + (if completion-auto-help + (minibuffer-completion-help) + ;; New message, only in this new Lisp code + ;; rewritten for I18N3 snarfing + (if (eq status 'exact) + (temp-minibuffer-message + " [Complete, but not unique]") + (temp-minibuffer-message " [Ambiguous]"))) + nil)))) + (t + (erase-buffer) + (insert completion) + ;; First word-break in stuff found by completion + (goto-char (point-min)) + (let ((len (length buffer-string)) + n) + (if (and (< len (length completion)) + (catch 'match + (setq n 0) + (while (< n len) + (if (char-equal + (upcase (aref buffer-string n)) + (upcase (aref completion n))) + (setq n (1+ n)) + (throw 'match nil))) + t) + (progn + (goto-char (point-min)) + (forward-char len) + (re-search-forward "\\W" nil t))) + (delete-region (point) (point-max)) + (goto-char (point-max)))) + t)))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; "Smart minibuffer" hackery ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; ("Kludgy minibuffer hackery" is perhaps a better name) + +;; This works by setting `mouse-grabbed-buffer' to the minibuffer, +;; defining button2 in the minibuffer keymap to +;; `minibuffer-smart-select-highlighted-completion', and setting the +;; mode-motion-hook of the minibuffer to `minibuffer-mouse-tracker'. +;; By setting `mouse-grabbed-buffer', the minibuffer's keymap and +;; mode-motion-hook apply (for mouse motion and presses) no matter +;; what buffer the mouse is over. Then, `minibuffer-mouse-tracker' +;; examines the text under the mouse looking for something that looks +;; like a completion, and causes it to be highlighted, and +;; `minibuffer-smart-select-highlighted-completion' looks for a +;; flagged completion under the mouse and inserts it. This has the +;; following advantages: +;; +;; -- filenames and such in any buffer can be inserted by clicking, +;; not just completions +;; +;; but the following disadvantages: +;; +;; -- unless you're aware of the "filename in any buffer" feature, +;; the fact that strings in arbitrary buffers get highlighted appears +;; as a bug +;; -- mouse motion can cause ange-ftp actions -- bad bad bad. +;; +;; There's some hackery in minibuffer-mouse-tracker to try to avoid the +;; ange-ftp stuff, but it doesn't work. +;; + +(defcustom minibuffer-smart-completion-tracking-behavior nil + "*If non-nil, look for completions under mouse in all buffers. +This allows you to click on something that looks like a completion +and have it selected, regardless of what buffer it is in. + +This is not enabled by default because + +-- The \"mysterious\" highlighting in normal buffers is confusing to + people not expecting it, and looks like a bug +-- If ange-ftp is enabled, this tracking sometimes causes ange-ftp + action as a result of mouse motion, which is *bad bad bad*. + Hopefully this bug will be fixed at some point." + :type 'boolean + :group 'minibuffer) + +(defun minibuffer-smart-mouse-tracker (event) + ;; Used as the mode-motion-hook of the minibuffer window, which is the + ;; value of `mouse-grabbed-buffer' while the minibuffer is active. If + ;; the word under the mouse is a valid minibuffer completion, then it + ;; is highlighted. + ;; + ;; We do some special voodoo when we're reading a pathname, because + ;; the way filename completion works is funny. Possibly there's some + ;; more general way this could be dealt with... + ;; + ;; We do some further voodoo when reading a pathname that is an + ;; ange-ftp or efs path, because causing FTP activity as a result of + ;; mouse motion is a really bad time. + ;; + (and minibuffer-smart-completion-tracking-behavior + (event-point event) + ;; avoid conflict with display-completion-list extents + (not (extent-at (event-point event) + (event-buffer event) + 'list-mode-item)) + (let ((filename-kludge-p (eq minibuffer-completion-table + 'read-file-name-internal))) + (mode-motion-highlight-internal + event + #'(lambda () (default-mouse-track-beginning-of-word + (if filename-kludge-p 'nonwhite t))) + #'(lambda () + (let ((p (point)) + (string "")) + (default-mouse-track-end-of-word + (if filename-kludge-p 'nonwhite t)) + (if (and (/= p (point)) minibuffer-completion-table) + (setq string (buffer-substring p (point)))) + (if (string-match "\\`[ \t\n]*\\'" string) + (goto-char p) + (if filename-kludge-p + (setq string (minibuffer-smart-select-kludge-filename + string))) + ;; try-completion bogusly returns a string even when + ;; that string is complete if that string is also a + ;; prefix for other completions. This means that we + ;; can't just do the obvious thing, (eq t + ;; (try-completion ...)). + (let (comp) + (if (and filename-kludge-p + ;; #### evil evil evil evil + (or (and (fboundp 'ange-ftp-ftp-path) + (ange-ftp-ftp-path string)) + (and (fboundp 'efs-ftp-path) + (efs-ftp-path string)))) + (setq comp t) + (setq comp + (try-completion string + minibuffer-completion-table + minibuffer-completion-predicate))) + (or (eq comp t) + (and (equal comp string) + (or (null minibuffer-completion-predicate) + (stringp + minibuffer-completion-predicate) ; ??? + (funcall minibuffer-completion-predicate + (if (vectorp + minibuffer-completion-table) + (intern-soft + string + minibuffer-completion-table) + string)))) + (goto-char p)))))))))) + +(defun minibuffer-smart-select-kludge-filename (string) + (save-excursion + (set-buffer mouse-grabbed-buffer) ; the minibuf + (let ((kludge-string (concat (buffer-string) string))) + (if (or (and (fboundp 'ange-ftp-ftp-path) + (ange-ftp-ftp-path kludge-string)) + (and (fboundp 'efs-ftp-path) (efs-ftp-path kludge-string))) + ;; #### evil evil evil, but more so. + string + (append-expand-filename (buffer-string) string))))) + +(defun minibuffer-smart-select-highlighted-completion (event) + "Select the highlighted text under the mouse as a minibuffer response. +When the minibuffer is being used to prompt the user for a completion, +any valid completions which are visible on the frame will highlight +when the mouse moves over them. Clicking \\<minibuffer-local-map>\ +\\[minibuffer-smart-select-highlighted-completion] will select the +highlighted completion under the mouse. + +If the mouse is clicked while not over a highlighted completion, +then the global binding of \\[minibuffer-smart-select-highlighted-completion] \ +will be executed instead. In this\nway you can get at the normal global \ +behavior of \\[minibuffer-smart-select-highlighted-completion] as well as +the special minibuffer behavior." + (interactive "e") + (if minibuffer-smart-completion-tracking-behavior + (minibuffer-smart-select-highlighted-completion-1 event t) + (let ((command (lookup-key global-map + (vector current-mouse-event)))) + (if command (call-interactively command))))) + +(defun minibuffer-smart-select-highlighted-completion-1 (event global-p) + (let* ((filename-kludge-p (eq minibuffer-completion-table + 'read-file-name-internal)) + completion + command-p + (evpoint (event-point event)) + (evextent (and evpoint (extent-at evpoint (event-buffer event) + 'list-mode-item)))) + (if evextent + ;; avoid conflict with display-completion-list extents. + ;; if we find one, do that behavior instead. + (list-mode-item-selected-1 evextent event) + (save-excursion + (let* ((buffer (window-buffer (event-window event))) + (p (event-point event)) + (extent (and p (extent-at p buffer 'mouse-face)))) + (set-buffer buffer) + (if (not (and (extent-live-p extent) + (eq (extent-object extent) (current-buffer)) + (not (extent-detached-p extent)))) + (setq command-p t) + ;; ...else user has selected a highlighted completion. + (setq completion + (buffer-substring (extent-start-position extent) + (extent-end-position extent))) + (if filename-kludge-p + (setq completion (minibuffer-smart-select-kludge-filename + completion))) + ;; remove the extent so that it's not hanging around in + ;; *Completions* + (detach-extent extent) + (set-buffer mouse-grabbed-buffer) + (erase-buffer) + (insert completion)))) + ;; we need to execute the command or do the throw outside of the + ;; save-excursion. + (cond ((and command-p global-p) + (let ((command (lookup-key global-map + (vector current-mouse-event)))) + (if command + (call-interactively command) + (if minibuffer-completion-table + (error + "Highlighted words are valid completions. You may select one.") + (error "no completions"))))) + ((not command-p) + ;; things get confused if the minibuffer is terminated while + ;; not selected. + (select-window (minibuffer-window)) + (if (and filename-kludge-p (file-directory-p completion)) + ;; if the user clicked middle on a directory name, display the + ;; files in that directory. + (progn + (goto-char (point-max)) + (minibuffer-completion-help)) + ;; otherwise, terminate input + (throw 'exit nil))))))) + +(defun minibuffer-smart-maybe-select-highlighted-completion + (event &optional click-count) + "Like minibuffer-smart-select-highlighted-completion but does nothing if +there is no completion (as opposed to executing the global binding). Useful +as the value of `mouse-track-click-hook'." + (interactive "e") + (minibuffer-smart-select-highlighted-completion-1 event nil)) + +(define-key minibuffer-local-map 'button2 + 'minibuffer-smart-select-highlighted-completion) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Minibuffer History ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defvar minibuffer-history '() + "Default minibuffer history list. +This is used for all minibuffer input except when an alternate history +list is specified.") + +;; Some other history lists: +;; +(defvar minibuffer-history-search-history '()) +(defvar function-history '()) +(defvar variable-history '()) +(defvar buffer-history '()) +(defvar shell-command-history '()) +(defvar file-name-history '()) + +(defvar read-expression-history nil) + +(defvar minibuffer-history-sexp-flag nil ;weird FSF Emacs kludge + "Non-nil when doing history operations on `command-history'. +More generally, indicates that the history list being acted on +contains expressions rather than strings.") + +(defun previous-matching-history-element (regexp n) + "Find the previous history element that matches REGEXP. +\(Previous history elements refer to earlier actions.) +With prefix argument N, search for Nth previous match. +If N is negative, find the next or Nth next match." + (interactive + (let ((enable-recursive-minibuffers t) + (minibuffer-history-sexp-flag nil)) + (if (eq 't (symbol-value minibuffer-history-variable)) + (error "History is not being recorded in this context")) + (list (read-from-minibuffer "Previous element matching (regexp): " + (car minibuffer-history-search-history) + minibuffer-local-map + nil + 'minibuffer-history-search-history) + (prefix-numeric-value current-prefix-arg)))) + (let ((history (symbol-value minibuffer-history-variable)) + prevpos + (pos minibuffer-history-position)) + (if (eq history t) + (error "History is not being recorded in this context")) + (while (/= n 0) + (setq prevpos pos) + (setq pos (min (max 1 (+ pos (if (< n 0) -1 1))) (length history))) + (if (= pos prevpos) + (if (= pos 1) ;; rewritten for I18N3 snarfing + (error "No later matching history item") + (error "No earlier matching history item"))) + (if (string-match regexp + (if minibuffer-history-sexp-flag + (let ((print-level nil)) + (prin1-to-string (nth (1- pos) history))) + (nth (1- pos) history))) + (setq n (+ n (if (< n 0) 1 -1))))) + (setq minibuffer-history-position pos) + (setq current-minibuffer-contents (buffer-string) + current-minibuffer-point (point)) + (erase-buffer) + (let ((elt (nth (1- pos) history))) + (insert (if minibuffer-history-sexp-flag + (let ((print-level nil)) + (prin1-to-string elt)) + elt))) + (goto-char (point-min))) + (if (or (eq (car (car command-history)) 'previous-matching-history-element) + (eq (car (car command-history)) 'next-matching-history-element)) + (setq command-history (cdr command-history)))) + +(defun next-matching-history-element (regexp n) + "Find the next history element that matches REGEXP. +\(The next history element refers to a more recent action.) +With prefix argument N, search for Nth next match. +If N is negative, find the previous or Nth previous match." + (interactive + (let ((enable-recursive-minibuffers t) + (minibuffer-history-sexp-flag nil)) + (if (eq t (symbol-value minibuffer-history-variable)) + (error "History is not being recorded in this context")) + (list (read-from-minibuffer "Next element matching (regexp): " + (car minibuffer-history-search-history) + minibuffer-local-map + nil + 'minibuffer-history-search-history) + (prefix-numeric-value current-prefix-arg)))) + (previous-matching-history-element regexp (- n))) + +(defun next-history-element (n) + "Insert the next element of the minibuffer history into the minibuffer." + (interactive "p") + (if (eq 't (symbol-value minibuffer-history-variable)) + (error "History is not being recorded in this context")) + (unless (zerop n) + (when (eq minibuffer-history-position + initial-minibuffer-history-position) + (setq current-minibuffer-contents (buffer-string) + current-minibuffer-point (point))) + (let ((narg (- minibuffer-history-position n))) + (cond ((< narg 0) + (error "No following item in %s" minibuffer-history-variable)) + ((> narg (length (symbol-value minibuffer-history-variable))) + (error "No preceding item in %s" minibuffer-history-variable))) + (erase-buffer) + (setq minibuffer-history-position narg) + (if (eq narg initial-minibuffer-history-position) + (progn + (insert current-minibuffer-contents) + (goto-char current-minibuffer-point)) + (let ((elt (nth (1- minibuffer-history-position) + (symbol-value minibuffer-history-variable)))) + (insert + (if (not (stringp elt)) + (let ((print-level nil)) + (condition-case nil + (let ((print-readably t) + (print-escape-newlines t)) + (prin1-to-string elt)) + (error (prin1-to-string elt)))) + elt))) + ;; FSF has point-min here. + (goto-char (point-max)))))) + +(defun previous-history-element (n) + "Inserts the previous element of the minibuffer history into the minibuffer." + (interactive "p") + (next-history-element (- n))) + +(defun next-complete-history-element (n) + "Get next element of history which is a completion of minibuffer contents." + (interactive "p") + (let ((point-at-start (point))) + (next-matching-history-element + (concat "^" (regexp-quote (buffer-substring (point-min) (point)))) n) + ;; next-matching-history-element always puts us at (point-min). + ;; Move to the position we were at before changing the buffer contents. + ;; This is still sensical, because the text before point has not changed. + (goto-char point-at-start))) + +(defun previous-complete-history-element (n) + "Get previous element of history which is a completion of minibuffer contents." + (interactive "p") + (next-complete-history-element (- n))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; reading various things from a minibuffer ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun read-expression (prompt &optional initial-contents history) + "Return a Lisp object read using the minibuffer. +Prompt with PROMPT. If non-nil, optional second arg INITIAL-CONTENTS +is a string to insert in the minibuffer before reading. +Third arg HISTORY, if non-nil, specifies a history list." + (let ((minibuffer-history-sexp-flag t) + ;; Semi-kludge to get around M-x C-x o M-ESC trying to do completion. + (minibuffer-completion-table nil)) + (read-from-minibuffer prompt + initial-contents + read-expression-map + t + (or history 'read-expression-history) + lisp-mode-abbrev-table))) + +(defun read-string (prompt &optional initial-contents history) + "Return a string from the minibuffer, prompting with string PROMPT. +If non-nil, optional second arg INITIAL-CONTENTS is a string to insert +in the minibuffer before reading. +Third arg HISTORY, if non-nil, specifies a history list." + (let ((minibuffer-completion-table nil)) + (read-from-minibuffer prompt + initial-contents + minibuffer-local-map + nil history))) + +(defun eval-minibuffer (prompt &optional initial-contents history) + "Return value of Lisp expression read using the minibuffer. +Prompt with PROMPT. If non-nil, optional second arg INITIAL-CONTENTS +is a string to insert in the minibuffer before reading. +Third arg HISTORY, if non-nil, specifies a history list." + (eval (read-expression prompt initial-contents history))) + +;;;#### Screw this crock!! +;(defun read-no-blanks-input (prompt &optional initial-contents) +; "Read a string from the terminal, not allowing blanks. +;Prompt with PROMPT. If non-nil, optional second arg INITIAL-CONTENTS +;is a string to insert in the minibuffer before reading." +; (let ((minibuffer-completion-table nil)) +; (read-from-minibuffer prompt +; initial-contents +; minibuffer-local-ns-map +; nil))) + +;; The name `command-history' is already taken +(defvar read-command-history '()) + +(defun read-command (prompt) + "Read the name of a command and return as a symbol. +Prompts with PROMPT." + (intern (completing-read prompt obarray 'commandp t nil + ;; 'command-history is not right here: that's a + ;; list of evalable forms, not a history list. + 'read-command-history + ))) + +(defun read-function (prompt) + "Read the name of a function and return as a symbol. +Prompts with PROMPT." + (intern (completing-read prompt obarray 'fboundp t nil + 'function-history))) + +(defun read-variable (prompt) + "Read the name of a user variable and return it as a symbol. +Prompts with PROMPT. +A user variable is one whose documentation starts with a `*' character." + (intern (completing-read prompt obarray 'user-variable-p t nil + 'variable-history))) + +(defun read-buffer (prompt &optional default require-match) + "Read the name of a buffer and return as a string. +Prompts with PROMPT. Optional second arg DEFAULT is value to return if user +enters an empty line. If optional third arg REQUIRE-MATCH is non-nil, +only existing buffer names are allowed." + (let ((prompt (if default + (format "%s(default %s) " + (gettext prompt) (if (bufferp default) + (buffer-name default) + default)) + prompt)) + (alist (mapcar #'(lambda (b) (cons (buffer-name b) b)) + (buffer-list))) + result) + (while (progn + (setq result (completing-read prompt alist nil require-match + nil 'buffer-history)) + (cond ((not (equal result "")) + nil) + ((not require-match) + (setq result default) + nil) + ((not default) + t) + ((not (get-buffer default)) + t) + (t + (setq result default) + nil)))) + (if (bufferp result) + (buffer-name result) + result))) + +(defun read-number (prompt &optional integers-only) + "Reads a number from the minibuffer." + (let ((pred (if integers-only 'integerp 'numberp)) + num) + (while (not (funcall pred num)) + (setq num (condition-case () + (let ((minibuffer-completion-table nil)) + (read-from-minibuffer + prompt (if num (prin1-to-string num)) nil t + t)) ;no history + (invalid-read-syntax nil) + (end-of-file nil))) + (or (funcall pred num) (beep))) + num)) + +(defun read-shell-command (prompt &optional initial-input history) + "Just like read-string, but uses read-shell-command-map: +\\{read-shell-command-map}" + (let ((minibuffer-completion-table nil)) + (read-from-minibuffer prompt initial-input read-shell-command-map + nil (or history 'shell-command-history)))) + + +;;; This read-file-name stuff probably belongs in files.el + +;; Quote "$" as "$$" to get it past substitute-in-file-name +(defun un-substitute-in-file-name (string) + (let ((regexp "\\$") + (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)))) + +(defun read-file-name-2 (history prompt dir default + must-match initial-contents + completer) + (if (not dir) + (setq dir default-directory)) + (setq dir (abbreviate-file-name dir t)) + (let* ((insert (cond ((and (not insert-default-directory) + (not initial-contents)) + "") + (initial-contents + (cons (un-substitute-in-file-name + (concat dir initial-contents)) + (length dir))) + (t + (un-substitute-in-file-name dir)))) + (val (let ((completion-ignore-case (or completion-ignore-case + (eq system-type 'vax-vms)))) + ;; Hateful, broken, case-sensitive un*x +;;; (completing-read prompt +;;; completer +;;; dir +;;; 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))) + )) +;;; ;; Kludge! Put "/foo/bar" on history rather than "/default//foo/bar" +;;; (let ((hist (cond ((not history) 'minibuffer-history) +;;; ((consp history) (car history)) +;;; (t history)))) +;;; (if (and val +;;; hist +;;; (not (eq hist 't)) +;;; (boundp hist) +;;; (equal (car-safe (symbol-value hist)) val)) +;;; (let ((e (condition-case nil +;;; (expand-file-name val) +;;; (error nil)))) +;;; (if (and e (not (equal e val))) +;;; (set hist (cons e (cdr (symbol-value hist)))))))) + + (cond ((not val) + (error "No file name specified")) + ((and default + (equal val (if (consp insert) (car insert) insert))) + default) + (t + (substitute-in-file-name val))))) + +;; #### this function should use minibuffer-completion-table +;; or something. But that is sloooooow. +;; #### all this shit needs better documentation!!!!!!!! +(defun read-file-name-activate-callback (event extent dir-p) + ;; used as the activate-callback of the filename list items + ;; in the completion buffer, in place of default-choose-completion. + ;; if a regular file was selected, we call default-choose-completion + ;; (which just inserts the string in the minibuffer and calls + ;; exit-minibuffer). If a directory was selected, we display + ;; the contents of the directory. + (let* ((file (extent-string extent)) + (completion-buf (extent-object extent)) + (minibuf (symbol-value-in-buffer 'completion-reference-buffer + completion-buf)) + (in-dir (file-name-directory (buffer-substring nil nil minibuf))) + (full (expand-file-name file in-dir))) + (if (not (file-directory-p full)) + (default-choose-completion event extent minibuf) + (erase-buffer minibuf) + (insert-string (file-name-as-directory + (abbreviate-file-name full t)) minibuf) + (reset-buffer completion-buf) + (let ((standard-output completion-buf)) + (display-completion-list + (delete "." (directory-files full nil nil nil (if dir-p 'directory))) + :user-data dir-p + :reference-buffer minibuf + :activate-callback 'read-file-name-activate-callback) + (goto-char (point-min) completion-buf))))) + +(defun read-file-name-1 (history prompt dir default + must-match initial-contents + completer) + (if (should-use-dialog-box-p) + ;; this calls read-file-name-2 + (mouse-read-file-name-1 history prompt dir default must-match + initial-contents completer) + (let ((rfhookfun + (lambda () + (set + (make-local-variable + 'completion-display-completion-list-function) + #'(lambda (completions) + (display-completion-list + completions + :user-data (not (eq completer 'read-file-name-internal)) + :activate-callback + 'read-file-name-activate-callback))) + ;; kludge! + (remove-hook 'minibuffer-setup-hook rfhookfun) + ))) + (unwind-protect + (progn + (add-hook 'minibuffer-setup-hook rfhookfun) + (read-file-name-2 history prompt dir default must-match + initial-contents completer)) + (remove-hook 'minibuffer-setup-hook rfhookfun))))) + +(defun read-file-name (prompt + &optional dir default must-match initial-contents + history) + "Read file name, prompting with PROMPT and completing in directory DIR. +This will prompt with a dialog box if appropriate, according to + `should-use-dialog-box-p'. +Value is not expanded---you must call `expand-file-name' yourself. +Value is subject to interpreted by substitute-in-file-name however. +Default name to DEFAULT if user enters a null string. + (If DEFAULT is omitted, the visited file name is used, + except that if INITIAL-CONTENTS is specified, that combined with DIR is + used.) +Fourth arg MUST-MATCH non-nil means require existing file's name. + Non-nil and non-t means also require confirmation after completion. +Fifth arg INITIAL-CONTENTS specifies text to start with. +Sixth arg HISTORY specifies the history list to use. Default is + `file-name-history'. +DIR defaults to current buffer's directory default." + (read-file-name-1 + (or history 'file-name-history) + prompt dir (or default + (if initial-contents (expand-file-name initial-contents dir) + buffer-file-name)) + must-match initial-contents + ;; A separate function (not an anonymous lambda-expression) + ;; and passed as a symbol because of disgusting kludges in various + ;; places which do stuff like (let ((filename-kludge-p (eq minibuffer-completion-table 'read-file-name-internal))) ...) + 'read-file-name-internal)) + +(defun read-directory-name (prompt + &optional dir default must-match initial-contents) + "Read directory name, prompting with PROMPT and completing in directory DIR. +This will prompt with a dialog box if appropriate, according to + `should-use-dialog-box-p'. +Value is not expanded---you must call `expand-file-name' yourself. +Value is subject to interpreted by substitute-in-file-name however. +Default name to DEFAULT if user enters a null string. + (If DEFAULT is omitted, the current buffer's default directory is used.) +Fourth arg MUST-MATCH non-nil means require existing directory's name. + Non-nil and non-t means also require confirmation after completion. +Fifth arg INITIAL-CONTENTS specifies text to start with. +Sixth arg HISTORY specifies the history list to use. Default is + `file-name-history'. +DIR defaults to current buffer's directory default." + (read-file-name-1 + 'file-name-history + prompt dir (or default default-directory) must-match initial-contents + 'read-directory-name-internal)) + + +;; Environment-variable completion hack +(defun read-file-name-internal-1 (string dir action completer) + (if (not (string-match + "\\([^$]\\|\\`\\)\\(\\$\\$\\)*\\$\\([A-Za-z0-9_]*\\|{[^}]*\\)\\'" + string)) + ;; Not doing environment-variable completion hack + (let* ((orig (if (equal string "") nil string)) + (sstring (if orig (substitute-in-file-name string) string)) + (specdir (if orig (file-name-directory sstring) nil))) + (funcall completer + action + orig + sstring + specdir + (if specdir (expand-file-name specdir dir) dir) + (if orig (file-name-nondirectory sstring) string))) + ;; An odd number of trailing $'s + (let* ((start (match-beginning 3)) + (env (substring string + (cond ((= start (length string)) + ;; "...$" + start) + ((= (aref string start) ?{) + ;; "...${..." + (1+ start)) + (t + start)))) + (head (substring string 0 (1- start))) + (alist #'(lambda () + (mapcar #'(lambda (x) + (cons (substring x 0 (string-match "=" x)) + 'nil)) + process-environment)))) + + (cond ((eq action 'lambda) + nil) + ((eq action 't) + ;; all completions + (mapcar #'(lambda (p) + (if (and (> (length p) 0) + ;;#### Unix-specific + ;;#### -- need absolute-pathname-p + (/= (aref p 0) ?/)) + (concat "$" p) + (concat head "$" p))) + (all-completions env (funcall alist)))) + (t ;; 'nil + ;; complete + (let* ((e (funcall alist)) + (val (try-completion env e))) + (cond ((stringp val) + (if (string-match "[^A-Za-z0-9_]" val) + (concat head + "${" val + ;; completed uniquely? + (if (eq (try-completion val e) 't) + "}" "")) + (concat head "$" val))) + ((eql val 't) + (concat head + (un-substitute-in-file-name (getenv env)))) + (t nil)))))))) + + +(defun read-file-name-internal (string dir action) + (read-file-name-internal-1 + string dir action + #'(lambda (action orig string specdir dir name) + (cond ((eq action 'lambda) + (if (not orig) + nil + (let ((sstring (condition-case nil + (expand-file-name string) + (error nil)))) + (if (not sstring) + ;; Some pathname syntax error in string + nil + (file-exists-p sstring))))) + ((eq action 't) + ;; all completions + (mapcar #'un-substitute-in-file-name + (file-name-all-completions name dir))) + (t;; 'nil + ;; complete + (let* ((d (or dir default-directory)) + (val (file-name-completion name d))) + (if (and (eq val 't) + (not (null completion-ignored-extensions))) + ;;#### (file-name-completion "foo") returns 't + ;; when both "foo" and "foo~" exist and the latter + ;; is "pruned" by completion-ignored-extensions. + ;; I think this is a bug in file-name-completion. + (setq val (let ((completion-ignored-extensions '())) + (file-name-completion name d)))) + (if (stringp val) + (un-substitute-in-file-name (if specdir + (concat specdir val) + val)) + (let ((tem (un-substitute-in-file-name string))) + (if (not (equal tem orig)) + ;; substitute-in-file-name did something + tem + val))))))))) + +(defun read-directory-name-internal (string dir action) + (read-file-name-internal-1 + string dir action + #'(lambda (action orig string specdir dir name) + (let* ((dirs #'(lambda (fn) + (let ((l (if (equal name "") + (directory-files + dir + nil + "" + nil + 'directories) + (directory-files + dir + nil + (concat "\\`" (regexp-quote name)) + nil + 'directories)))) + (mapcar fn + (cond ((eq system-type 'vax-vms) + l) + (t + ;; Wretched unix + (delete "." l)))))))) + (cond ((eq action 'lambda) + ;; complete? + (if (not orig) + nil + (file-directory-p string))) + ((eq action 't) + ;; all completions + (funcall dirs #'(lambda (n) + (un-substitute-in-file-name + (file-name-as-directory n))))) + (t + ;; complete + (let ((val (try-completion + name + (funcall dirs + #'(lambda (n) + (list (file-name-as-directory + n))))))) + (if (stringp val) + (un-substitute-in-file-name (if specdir + (concat specdir val) + val)) + (let ((tem (un-substitute-in-file-name string))) + (if (not (equal tem orig)) + ;; substitute-in-file-name did something + tem + val)))))))))) + +(defun append-expand-filename (file-string string) + "Append STRING to FILE-STRING differently depending on whether STRING +is a username (~string), an environment variable ($string), +or a filename (/string). The resultant string is returned with the +environment variable or username expanded and resolved to indicate +whether it is a file(/result) or a directory (/result/)." + (let ((file + (cond ((string-match "\\([~$]\\)\\([^~$/]*\\)$" file-string) + (cond ((string= (substring file-string + (match-beginning 1) + (match-end 1)) "~") + (concat (substring file-string 0 (match-end 1)) + string)) + (t (substitute-in-file-name + (concat (substring file-string 0 (match-end 1)) + string))))) + (t (concat (file-name-directory + (substitute-in-file-name file-string)) string)))) + result) + + (cond ((stringp (setq result (and (file-exists-p (expand-file-name file)) + (read-file-name-internal + (condition-case nil + (expand-file-name file) + (error file)) + "" nil)))) + result) + (t file)))) + +(defun mouse-file-display-completion-list (window dir minibuf user-data) + (let ((standard-output (window-buffer window))) + (condition-case nil + (display-completion-list + (directory-files dir nil nil nil t) + :window-width (* 2 (window-width window)) + :activate-callback + 'mouse-read-file-name-activate-callback + :user-data user-data + :reference-buffer minibuf + :help-string "") + (t nil)))) + +(defun mouse-directory-display-completion-list (window dir minibuf user-data) + (let ((standard-output (window-buffer window))) + (condition-case nil + (display-completion-list + (delete "." (directory-files dir nil nil nil 1)) + :window-width (window-width window) + :activate-callback + 'mouse-read-file-name-activate-callback + :user-data user-data + :reference-buffer minibuf + :help-string "") + (t nil)))) + +(defun mouse-read-file-name-activate-callback (event extent user-data) + (let* ((file (extent-string extent)) + (minibuf (symbol-value-in-buffer 'completion-reference-buffer + (extent-object extent))) + (in-dir (buffer-substring nil nil minibuf)) + (full (expand-file-name file in-dir)) + (filebuf (nth 0 user-data)) + (dirbuff (nth 1 user-data)) + (filewin (nth 2 user-data)) + (dirwin (nth 3 user-data))) + (if (file-regular-p full) + (default-choose-completion event extent minibuf) + (erase-buffer minibuf) + (insert-string (file-name-as-directory + (abbreviate-file-name full t)) minibuf) + (reset-buffer filebuf) + (if (not dirbuff) + (mouse-directory-display-completion-list filewin full minibuf + user-data) + (mouse-file-display-completion-list filewin full minibuf user-data) + (reset-buffer dirbuff) + (mouse-directory-display-completion-list dirwin full minibuf + user-data))))) + +;; this is rather cheesified but gets the job done. +(defun mouse-read-file-name-1 (history prompt dir default + must-match initial-contents + completer) + (let* ((file-p (eq 'read-file-name-internal completer)) + (filebuf (get-buffer-create "*Completions*")) + (dirbuff (and file-p (generate-new-buffer " *mouse-read-file*"))) + (butbuff (generate-new-buffer " *mouse-read-file*")) + (frame (make-dialog-frame)) + filewin dirwin + user-data) + (unwind-protect + (progn + (reset-buffer filebuf) + (select-frame frame) + (let ((window-min-height 1)) + ;; #### should be 2 not 3, but that causes + ;; "window too small to split" errors for some + ;; people (but not for me ...) There's a more + ;; fundamental bug somewhere. + (split-window nil (- (frame-height frame) 3))) + (if file-p + (progn + (split-window-horizontally 16) + (setq filewin (frame-rightmost-window frame) + dirwin (frame-leftmost-window frame)) + (set-window-buffer filewin filebuf) + (set-window-buffer dirwin dirbuff)) + (setq filewin (frame-highest-window frame)) + (set-window-buffer filewin filebuf)) + (setq user-data (list filebuf dirbuff filewin dirwin)) + (set-window-buffer (frame-lowest-window frame) butbuff) + (set-buffer butbuff) + (when (featurep 'scrollbar) + (set-specifier scrollbar-width 0 butbuff)) + (insert " ") + (insert-gui-button (make-gui-button "OK" + (lambda (foo) + (exit-minibuffer)))) + (insert " ") + (insert-gui-button (make-gui-button "Cancel" + (lambda (foo) + (abort-recursive-edit)))) + (let ((rfhookfun + (lambda () + (if (not file-p) + (mouse-directory-display-completion-list + filewin dir (current-buffer) user-data) + (mouse-file-display-completion-list filewin dir + (current-buffer) + user-data) + (mouse-directory-display-completion-list dirwin dir + (current-buffer) + user-data)) + (set + (make-local-variable + 'completion-display-completion-list-function) + #'(lambda (completions) + (display-completion-list + completions + :help-string "" + :activate-callback + 'mouse-read-file-name-activate-callback + :user-data user-data))) + ;; kludge! + (remove-hook 'minibuffer-setup-hook rfhookfun) + )) + (rfcshookfun + ;; kludge! + ;; #### I really need to flesh out the object + ;; hierarchy better to avoid these kludges. + (lambda () + (save-excursion + (set-buffer standard-output) + (setq truncate-lines t))))) + (unwind-protect + (progn + (add-hook 'minibuffer-setup-hook rfhookfun) + (add-hook 'completion-setup-hook rfcshookfun) + (read-file-name-2 history prompt dir default + must-match initial-contents + completer)) + (remove-hook 'minibuffer-setup-hook rfhookfun) + (remove-hook 'completion-setup-hook rfcshookfun)))) + (delete-frame frame) + (kill-buffer filebuf) + (kill-buffer butbuff) + (and dirbuff (kill-buffer dirbuff))))) + +(defun read-face (prompt &optional must-match) + "Read the name of a face from the minibuffer and return it as a symbol." + (intern (completing-read prompt obarray 'find-face must-match))) + +;; #### - wrong place for this variable? Exactly. We probably want +;; `color-list' to be a console method, so `tty-color-list' becomes +;; obsolete, and `read-color-completion-table' conses (mapcar #'list +;; (color-list)), optionally caching the results. + +;; Ben wanted all of the possibilities from the `configure' script used +;; here, but I think this is way too many. I already trimmed the R4 variants +;; and a few obvious losers from the list. --Stig +(defvar x-library-search-path '("/usr/X11R6/lib/X11/" + "/usr/X11R5/lib/X11/" + "/usr/lib/X11R6/X11/" + "/usr/lib/X11R5/X11/" + "/usr/local/X11R6/lib/X11/" + "/usr/local/X11R5/lib/X11/" + "/usr/local/lib/X11R6/X11/" + "/usr/local/lib/X11R5/X11/" + "/usr/X11/lib/X11/" + "/usr/lib/X11/" + "/usr/local/lib/X11/" + "/usr/X386/lib/X11/" + "/usr/x386/lib/X11/" + "/usr/XFree86/lib/X11/" + "/usr/unsupported/lib/X11/" + "/usr/athena/lib/X11/" + "/usr/local/x11r5/lib/X11/" + "/usr/lpp/Xamples/lib/X11/" + "/usr/openwin/lib/X11/" + "/usr/openwin/share/lib/X11/") + "Search path used by `read-color' to find rgb.txt.") + +(defvar x-read-color-completion-table) + +(defun read-color-completion-table () + (case (device-type) + ;; #### Evil device-type dependency + (x + (if (boundp 'x-read-color-completion-table) + x-read-color-completion-table + (let ((rgb-file (locate-file "rgb.txt" x-library-search-path)) + clist color p) + (if (not rgb-file) + ;; prevents multiple searches for rgb.txt if we can't find it + (setq x-read-color-completion-table nil) + (with-current-buffer (get-buffer-create " *colors*") + (reset-buffer (current-buffer)) + (insert-file-contents rgb-file) + (while (not (eobp)) + ;; skip over comments + (while (looking-at "^!") + (end-of-line) + (forward-char 1)) + (skip-chars-forward "0-9 \t") + (setq p (point)) + (end-of-line) + (setq color (buffer-substring p (point)) + clist (cons (list color) clist)) + ;; Ugh. If we want to be able to complete the lowercase form + ;; of the color name, we need to add it twice! Yuck. + (let ((dcase (downcase color))) + (or (string= dcase color) + (push (list dcase) clist))) + (forward-char 1)) + (kill-buffer (current-buffer)))) + (setq x-read-color-completion-table clist) + x-read-color-completion-table))) + (tty + (mapcar #'list (tty-color-list))))) + +(defun read-color (prompt &optional must-match initial-contents) + "Read the name of a color from the minibuffer. +On X devices, this uses `x-library-search-path' to find rgb.txt in order + to build a completion table. +On TTY devices, this uses `tty-color-list'." + (let ((table (read-color-completion-table))) + (completing-read prompt table nil (and table must-match) + initial-contents))) + + +;; #### The doc string for read-non-nil-coding system gets lost if we +;; only include these if the mule feature is present. Strangely, +;; read-coding-system doesn't. + +;;(if (featurep 'mule) + +(defun read-coding-system (prompt) + "Read a coding-system (or nil) from the minibuffer. +Prompting with string PROMPT." + (intern (completing-read prompt obarray 'find-coding-system t))) + +(defun read-non-nil-coding-system (prompt) + "Read a non-nil coding-system from the minibuffer. +Prompt with string PROMPT." + (let ((retval (intern ""))) + (while (= 0 (length (symbol-name retval))) + (setq retval (intern (completing-read prompt obarray + 'find-coding-system + t)))) + retval)) + +;;) ;; end of (featurep 'mule) + + + +(defcustom force-dialog-box-use nil + "*If non-nil, always use a dialog box for asking questions, if possible. +You should *bind* this, not set it. This is useful if you're doing +something mousy but which wasn't actually invoked using the mouse." + :type 'boolean + :group 'minibuffer) + +;; We include this here rather than dialog.el so it is defined +;; even when dialog boxes are not present. +(defun should-use-dialog-box-p () + "If non-nil, questions should be asked with a dialog box instead of the +minibuffer. This looks at `last-command-event' to see if it was a mouse +event, and checks whether dialog-support exists and the current device +supports dialog boxes. + +The dialog box is totally disabled if the variable `use-dialog-box' +is set to nil." + (and (featurep 'dialog) + (device-on-window-system-p) + use-dialog-box + (or force-dialog-box-use + (button-press-event-p last-command-event) + (button-release-event-p last-command-event) + (misc-user-event-p last-command-event)))) + +;;; minibuf.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/misc.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,68 @@ +;;; misc.el --- miscellaneous functions for XEmacs + +;; Copyright (C) 1989, 1997 Free Software Foundation, Inc. + +;; Maintainer: FSF +;; Keywords: extensions, dumped + +;; 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.34. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;; 06/11/1997 - Use char-(after|before) instead of +;; (following|preceding)-char. -slb + +;;; Code: + +(defun copy-from-above-command (&optional arg) + "Copy characters from previous nonblank line, starting just above point. +Copy ARG characters, but not past the end of that line. +If no argument given, copy the entire rest of the line. +The characters copied are inserted in the buffer before point." + (interactive "P") + (let ((cc (current-column)) + n + (string "")) + (save-excursion + (beginning-of-line) + (backward-char 1) + (skip-chars-backward "\ \t\n") + (move-to-column cc) + ;; Default is enough to copy the whole rest of the line. + (setq n (if arg (prefix-numeric-value arg) (point-max))) + ;; If current column winds up in middle of a tab, + ;; copy appropriate number of "virtual" space chars. + (if (< cc (current-column)) + (if (eq (char-before (point)) ?\t) + (progn + (setq string (make-string (min n (- (current-column) cc)) ?\ )) + (setq n (- n (min n (- (current-column) cc))))) + ;; In middle of ctl char => copy that whole char. + (backward-char 1))) + (setq string (concat string + (buffer-substring + (point) + (min (save-excursion (end-of-line) (point)) + (+ n (point))))))) + (insert string))) + +;;; misc.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mode-motion.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,141 @@ +;;; mode-motion.el --- Mode-specific mouse-highlighting of text. + +;; Copyright (C) 1992, 1993, 1997 Free Software Foundation, Inc. + +;; Maintainer: XEmacs Development Team +;; Keywords: internal, mouse, dumped + +;; 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, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: Not in FSF. + +;;; Commentary: + +;; This file is dumped with XEmacs (when window system support is compiled in). + +;;; Code: + +(defvar mode-motion-hook nil + "Function or functions which are called whenever the mouse moves. +You should normally use this rather than `mouse-motion-handler', which +does some additional window-system-dependent things. This hook is local +to every buffer, and should normally be set up by major-modes which want +to use special highlighting. Every time the mouse moves over a window, +the mode-motion-hook of the buffer of that window is run.") + +(make-variable-buffer-local 'mode-motion-hook) + +(defvar mode-motion-extent nil) +(make-variable-buffer-local 'mode-motion-extent) + +(defvar mode-motion-help-echo-string nil + "String to be added as the 'help-echo property of the mode-motion extent. +In order for this to work, you need to add the hook function +`mode-motion-add-help-echo' to the mode-motion hook. If this is a function, +it will be called with one argument (the event) and should return a string +to be added. This variable is local to every buffer.") +(make-variable-buffer-local 'mode-motion-help-echo-string) + +(defun mode-motion-ensure-extent-ok (event) + (let ((buffer (event-buffer event))) + (if (and (extent-live-p mode-motion-extent) + (eq buffer (extent-object mode-motion-extent))) + nil + (setq mode-motion-extent (make-extent nil nil buffer)) + (set-extent-property mode-motion-extent 'mouse-face 'highlight)))) + +(defun mode-motion-highlight-internal (event backward forward) + (let* ((buffer (event-buffer event)) + (point (and buffer (event-point event)))) + (if (and buffer + (not (eq buffer mouse-grabbed-buffer))) + ;; #### ack!! Too many calls to save-window-excursion / + ;; save-excursion (x-track-pointer calls, so does + ;; minibuf-mouse-tracker ...) This needs to be looked + ;; into. It's complicated by the fact that sometimes + ;; a mode-motion-hook might really want to change + ;; the point. + ;; + ;; #### The save-excursion must come before the + ;; save-window-excursion in order to function properly. I + ;; haven't given this much thought. Is it a bug that this + ;; ordering is necessary or is it correct behavior? + (save-excursion + (save-window-excursion + (set-buffer buffer) + (mode-motion-ensure-extent-ok event) + (if point + (progn + (goto-char point) + (condition-case nil (funcall backward) (error nil)) + (setq point (point)) + (condition-case nil (funcall forward) (error nil)) + (if (eq point (point)) + (detach-extent mode-motion-extent) + (set-extent-endpoints mode-motion-extent point (point)))) + ;; not over text; zero the extent. + (detach-extent mode-motion-extent))))))) + +(defun mode-motion-highlight-line (event) + "For use as the value of `mode-motion-hook' -- highlight line under mouse." + (mode-motion-highlight-internal event 'beginning-of-line 'end-of-line)) + +(defun mode-motion-highlight-word (event) + "For use as the value of `mode-motion-hook' -- highlight word under mouse." + (mode-motion-highlight-internal + event + #'(lambda () (default-mouse-track-beginning-of-word nil)) + #'(lambda () (default-mouse-track-end-of-word nil)))) + +(defun mode-motion-highlight-symbol (event) + "For use as the value of `mode-motion-hook' -- highlight symbol under mouse." + (mode-motion-highlight-internal + event + #'(lambda () (default-mouse-track-beginning-of-word t)) + #'(lambda () (default-mouse-track-end-of-word t)))) + +(defun mode-motion-highlight-sexp (event) + "For use as the value of `mode-motion-hook' -- highlight form under mouse." + (mode-motion-highlight-internal + event + #'(lambda () + (if (= (char-syntax (following-char)) ?\() + nil + (goto-char (scan-sexps (point) -1)))) + #'(lambda () + (if (= (char-syntax (following-char)) ?\)) + (forward-char 1)) + (goto-char (scan-sexps (point) 1))))) + +(defun mode-motion-add-help-echo (event) + "For use as the value of `mode-motion-hook' -- add a 'help-echo property. +This causes the string in the 'help-echo property to be displayed when the +mouse moves over the extent. See `mode-motion-help-echo-string' for +documentation on how to control the string that is added." + (mode-motion-ensure-extent-ok event) + (let ((string (cond ((null mode-motion-help-echo-string) nil) + ((stringp mode-motion-help-echo-string) + mode-motion-help-echo-string) + (t (funcall mode-motion-help-echo-string event))))) + (if (stringp string) + (set-extent-property mode-motion-extent 'help-echo string)))) + + +(provide 'mode-motion) + +;;; mode-motion.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/modeline.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,549 @@ +;;; modeline.el --- modeline hackery. + +;; Copyright (C) 1988, 1992-1994, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1995, 1996 Ben Wing. + +;; Maintainer: XEmacs Development Team +;; Keywords: extensions, dumped + +;; 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, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: Not in FSF. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;;; Code: + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; General mouse modeline stuff ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgroup modeline nil + "Modeline customizations" + :group 'environment) + +(defcustom drag-modeline-event-lag 150 + "*The pause (in msecs) between drag modeline events before redisplaying. +If this value is too small, dragging will be choppy because redisplay cannot +keep up. If it is too large, dragging will be choppy because of the explicit +redisplay delay specified." + :type 'integer + :group 'modeline) + +(defcustom modeline-click-swaps-buffers nil + "*If non-nil, clicking on the modeline changes the current buffer. +Click on the left half of the modeline cycles forward through the +buffer list and clicking on the right half cycles backward." + :type 'boolean + :group 'modeline) + +(defun mouse-drag-modeline (event) + "Resize a window by dragging its modeline. +This command should be bound to a button-press event in modeline-map. +Holding down a mouse button and moving the mouse up and down will +make the clicked-on window taller or shorter." + (interactive "e") + (or (button-press-event-p event) + (error "%s must be invoked by a mouse-press" this-command)) + (or (event-over-modeline-p event) + (error "not over a modeline")) + (let ((done nil) + (depress-line (event-y event)) + (start-event-frame (event-frame event)) + (start-event-window (event-window event)) + (start-nwindows (count-windows t)) + (last-timestamp 0) + default-line-height + modeline-height + should-enlarge-minibuffer + event min-height minibuffer y top bot edges wconfig growth) + (setq minibuffer (minibuffer-window start-event-frame) + default-line-height (face-height 'default start-event-window) + min-height (+ (* window-min-height default-line-height) + ;; Don't let the window shrink by a + ;; non-multiple of the default line + ;; height. (enlarge-window -1) will do + ;; this if the difference between the + ;; current window height and the minimum + ;; window height is less than the height + ;; of the default font. These extra + ;; lost pixels of height don't come back + ;; if you grow the window again. This + ;; can make it impossible to drag back + ;; to the exact original size, which is + ;; disconcerting. + (% (window-pixel-height start-event-window) + default-line-height)) + modeline-height + (if (specifier-instance has-modeline-p start-event-window) + (+ (face-height 'modeline start-event-window) + (* 2 (specifier-instance modeline-shadow-thickness + start-event-window))) + (* 2 (specifier-instance modeline-shadow-thickness + start-event-window)))) + (if (not (eq (window-frame minibuffer) start-event-frame)) + (setq minibuffer nil)) + (if (and (null minibuffer) (one-window-p t)) + (error "Attempt to resize sole window")) + ;; if this is the bottommost ordinary window, then to + ;; move its modeline the minibuffer must be enlarged. + (setq should-enlarge-minibuffer + (and minibuffer (window-lowest-p start-event-window))) + ;; loop reading events + (while (not done) + (setq event (next-event event)) + ;; requeue event and quit if this is a misc-user, eval or + ;; keypress event. + ;; quit if this is a button press or release event, or if the event + ;; occurred in some other frame. + ;; drag if this is a mouse motion event and the time + ;; between this event and the last event is greater than + ;; drag-modeline-event-lag. + ;; do nothing if this is any other kind of event. + (cond ((or (misc-user-event-p event) + (key-press-event-p event)) + (setq unread-command-events (nconc unread-command-events + (list event)) + done t)) + ((button-release-event-p event) + (setq done t) + (if modeline-click-swaps-buffers + (mouse-release-modeline event depress-line))) + ((button-event-p event) + (setq done t)) + ((not (motion-event-p event)) + (dispatch-event event)) + ((not (eq start-event-frame (event-frame event))) + (setq done t)) + ((< (abs (- (event-timestamp event) last-timestamp)) + drag-modeline-event-lag) + nil) + (t + (setq last-timestamp (event-timestamp event) + y (event-y-pixel event) + edges (window-pixel-edges start-event-window) + top (nth 1 edges) + bot (nth 3 edges)) + ;; scale back a move that would make the + ;; window too short. + (cond ((< (- y top (- modeline-height)) min-height) + (setq y (+ top min-height (- modeline-height))))) + ;; compute size change needed + (setq growth (- y bot (/ (- modeline-height) 2)) + wconfig (current-window-configuration)) + ;; grow/shrink minibuffer? + (if should-enlarge-minibuffer + (progn + ;; yes. scale back shrinkage if it + ;; would make the minibuffer less than 1 + ;; line tall. + ;; + ;; also flip the sign of the computed growth, + ;; since if we want to grow the window with the + ;; modeline we need to shrink the minibuffer + ;; and vice versa. + (if (and (> growth 0) + (< (- (window-pixel-height minibuffer) + growth) + default-line-height)) + (setq growth + (- (window-pixel-height minibuffer) + default-line-height))) + (setq growth (- growth)))) + ;; window grow and shrink by lines not pixels, so + ;; divide the pixel height by the height of the + ;; default face. + (setq growth (/ growth default-line-height)) + ;; grow/shrink the window + (enlarge-window growth nil (if should-enlarge-minibuffer + minibuffer + start-event-window)) + ;; if this window's growth caused another + ;; window to be deleted because it was too + ;; short, rescind the change. + ;; + ;; if size change caused space to be stolen + ;; from a window above this one, rescind the + ;; change, but only if we didn't grow/shrink + ;; the minibuffer. minibuffer size changes + ;; can cause all windows to shrink... no way + ;; around it. + (if (or (/= start-nwindows (count-windows t)) + (and (not should-enlarge-minibuffer) + (/= top (nth 1 (window-pixel-edges + start-event-window))))) + (set-window-configuration wconfig))))))) + +;; from Bob Weiner (bob_weiner@pts.mot.com) +(defun mouse-release-modeline (event line-num) + "Handle modeline click EVENT on LINE-NUM 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. +Args are: EVENT, the mouse release event, and LINE-NUM, the line number +within the frame at which the mouse was first depressed." + (if (= line-num (event-y event)) + ;; Button press and release are at same line, treat this as + ;; a click and switch buffers. + (if (< (event-x event) (/ (window-width (event-window event)) 2)) + ;; On left half of modeline, bury current buffer, + ;; displaying second buffer on list. + (mouse-bury-buffer event) + ;; On right half of modeline, raise and display bottommost + ;; buffer in buffer list. + (mouse-unbury-buffer event)))) + +(defconst modeline-menu + '("Window Commands" + ["Delete Window Above" delete-window t] + ["Delete Other Windows" delete-other-windows t] + ["Split Window Above" split-window-vertically t] + ["Split Window Horizontally" split-window-horizontally t] + ["Balance Windows" balance-windows t] + )) + +(defun modeline-menu (event) + (interactive "e") + (popup-menu-and-execute-in-window + (cons (format "Window Commands for %S:" + (buffer-name (event-buffer event))) + (cdr modeline-menu)) + event)) + +(defvar modeline-map (make-sparse-keymap 'modeline-map) + "Keymap consulted for mouse-clicks on the modeline of a window. +This variable may be buffer-local; its value will be looked up in +the buffer of the window whose modeline was clicked upon.") + +(define-key modeline-map 'button1 'mouse-drag-modeline) +;; button2 selects the window without setting point +(define-key modeline-map 'button2 (lambda () (interactive "@"))) +(define-key modeline-map 'button3 'modeline-menu) + +(make-face 'modeline-mousable "Face for mousable portions of the modeline.") +(set-face-parent 'modeline-mousable 'modeline) +(when (featurep 'x) + (set-face-foreground 'modeline-mousable "firebrick" 'global '(color x)) + (set-face-font 'modeline-mousable [bold] nil '(mono x)) + (set-face-font 'modeline-mousable [bold] nil '(grayscale x))) + +(defmacro make-modeline-command-wrapper (command) + `#'(lambda (event) + (interactive "e") + (save-selected-window + (select-window (event-window event)) + (call-interactively ',(eval command))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Minor modes ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defvar minor-mode-alist nil + "Alist saying how to show minor modes in the modeline. +Each element looks like (VARIABLE STRING); +STRING is included in the modeline iff VARIABLE's value is non-nil. + +Actually, STRING need not be a string; any possible modeline element +is okay. See `modeline-format'.") + +;; Used by C code (lookup-key and friends) but defined here. +(defvar minor-mode-map-alist nil + "Alist of keymaps to use for minor modes. +Each element looks like (VARIABLE . KEYMAP); KEYMAP is used to read +key sequences and look up bindings iff VARIABLE's value is non-nil. +If two active keymaps bind the same key, the keymap appearing earlier +in the list takes precedence.") + +(make-face 'modeline-mousable-minor-mode + "Face for mousable minor-mode strings in the modeline.") +(set-face-parent 'modeline-mousable-minor-mode 'modeline-mousable) +(when (featurep 'x) + (set-face-foreground 'modeline-mousable-minor-mode + '(((color x) . "green4") + ((color x) . "forestgreen")) 'global)) + +(defvar modeline-mousable-minor-mode-extent (make-extent nil nil) + ;; alliteration at its finest. + "Extent managing the mousable minor mode modeline strings.") +(set-extent-face modeline-mousable-minor-mode-extent + 'modeline-mousable-minor-mode) + +;; This replaces the idiom +;; +;; (or (assq 'isearch-mode minor-mode-alist) +;; (setq minor-mode-alist +;; (purecopy +;; (append minor-mode-alist +;; '((isearch-mode isearch-mode)))))) + +(defvar place) +(defun add-minor-mode (toggle name &optional keymap after toggle-fun) + "Add a minor mode to `minor-mode-alist' and `minor-mode-map-alist'. +TOGGLE is a symbol whose value as a variable specifies whether the +minor mode is active. NAME is the name that should appear in the +modeline (it should either be a string beginning with a space or a +symbol). KEYMAP is a keymap to make active when the minor mode is +active. AFTER is the toggling symbol used for another minor mode. If +AFTER is non-nil, then it is used to position the new mode in the +minor-mode alists. TOGGLE-FUN specifies an interactive function that +is called to toggle the mode on and off; this affects what happens +when button2 is pressed on the mode, and when button3 is pressed +somewhere in the list of modes. If TOGGLE-FUN is nil and TOGGLE names +an interactive function, TOGGLE is used as the toggle function. + +Example: (add-minor-mode 'view-minor-mode \" View\" view-mode-map)" + (let (el place + (add-elt #'(lambda (elt sym) + (cond ((null after) ; add to front + (set sym (cons elt (symbol-value sym)))) + ((and (not (eq after t)) + (setq place (memq (assq after + (symbol-value sym)) + (symbol-value sym)))) + (setq elt (cons elt (cdr place))) + (setcdr place elt)) + (t + (set sym (append (symbol-value sym) (list elt)))) + ) + (symbol-value sym))) + toggle-keymap) + (if toggle-fun + (if (not (commandp toggle-fun)) + (error "not an interactive function: %S" toggle-fun)) + (if (commandp toggle) + (setq toggle-fun toggle))) + (if (and toggle-fun name) + (progn + (setq toggle-keymap (make-sparse-keymap + (intern (concat "modeline-minor-" + (symbol-name toggle) + "-map")))) + (define-key toggle-keymap 'button2 + ;; defeat the DUMB-ASS byte-compiler, which tries to + ;; expand the macro at compile time and fucks up. + (eval '(make-modeline-command-wrapper toggle-fun))) + (put toggle 'modeline-toggle-function toggle-fun))) + (and name + (let ((hacked-name + (if toggle-keymap + (cons (let ((extent (make-extent nil nil))) + (set-extent-keymap extent toggle-keymap) + (set-extent-property + extent 'help-echo + (concat "button2 turns off " + (if (symbolp toggle-fun) + (symbol-name toggle-fun) + (symbol-name toggle)))) + extent) + (cons + modeline-mousable-minor-mode-extent + name)) + name))) + (if (setq el (assq toggle minor-mode-alist)) + (setcdr el (list hacked-name)) + (funcall add-elt + (list toggle hacked-name) + 'minor-mode-alist)))) + (and keymap + (if (setq el (assq toggle minor-mode-map-alist)) + (setcdr el keymap) + (funcall add-elt + (cons toggle keymap) + 'minor-mode-map-alist))) + )) + +(add-minor-mode 'abbrev-mode " Abbrev") +(add-minor-mode 'overwrite-mode 'overwrite-mode) +(add-minor-mode 'auto-fill-function " Fill" nil nil 'auto-fill-mode) +;; not really a minor mode... +(add-minor-mode 'defining-kbd-macro " Def") + +(defun modeline-minor-mode-menu (event) + (interactive "e") + (save-excursion + (set-buffer (event-buffer event)) + (popup-menu-and-execute-in-window + (cons (format "Minor Mode Commands for %S:" + (buffer-name (event-buffer event))) + (apply 'nconc + (mapcar + #'(lambda (x) + (let* ((toggle-sym (car x)) + (toggle-fun + (or (get toggle-sym + 'modeline-toggle-function) + (and (fboundp toggle-sym) + (commandp toggle-sym) + toggle-sym)))) + (if (not toggle-fun) nil + (list (vector + (concat (if (and (boundp toggle-sym) + (symbol-value toggle-sym)) + "turn off " "turn on ") + (if (symbolp toggle-fun) + (symbol-name toggle-fun) + (symbol-name toggle-sym))) + + toggle-fun + t))))) + minor-mode-alist))) + event))) + +(defvar modeline-minor-mode-map (make-sparse-keymap 'modeline-minor-mode-map) + "Keymap consulted for mouse-clicks on the minor-mode modeline list.") +(define-key modeline-minor-mode-map 'button3 'modeline-minor-mode-menu) + +(defvar modeline-minor-mode-extent (make-extent nil nil) + "Extent covering the minor mode modeline strings.") +(set-extent-face modeline-minor-mode-extent 'modeline-mousable) +(set-extent-keymap modeline-minor-mode-extent modeline-minor-mode-map) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Other ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun modeline-buffers-menu (event) + (interactive "e") + (popup-menu-and-execute-in-window + '("Buffers Popup Menu" + :filter buffers-menu-filter + ["List All Buffers" list-buffers t] + "--" + ) + event)) + +(defvar modeline-buffer-id-left-map + (make-sparse-keymap 'modeline-buffer-id-left-map) +"Keymap consulted for mouse-clicks on the left half of the buffer-id string.") + +(defvar modeline-buffer-id-right-map + (make-sparse-keymap 'modeline-buffer-id-right-map) +"Keymap consulted for mouse-clicks on the right half of the buffer-id string.") + +(define-key modeline-buffer-id-left-map 'button2 'mouse-unbury-buffer) +(define-key modeline-buffer-id-right-map 'button2 'mouse-bury-buffer) +(define-key modeline-buffer-id-left-map 'button3 'modeline-buffers-menu) +(define-key modeline-buffer-id-right-map 'button3 'modeline-buffers-menu) + +(make-face 'modeline-buffer-id + "Face for the buffer ID string in the modeline.") +(set-face-parent 'modeline-buffer-id 'modeline) +(when (featurep 'x) + (set-face-foreground 'modeline-buffer-id "blue4" 'global '(color x))) +(when (featurep 'x) + (set-face-font 'modeline-buffer-id [bold-italic] nil '(mono x)) + (set-face-font 'modeline-buffer-id [bold-italic] nil '(grayscale x))) +(when (featurep 'tty) + (set-face-font 'modeline-buffer-id [bold-italic] nil 'tty)) + +(defvar modeline-buffer-id-extent (make-extent nil nil) + "Extent covering the whole of the buffer-id string.") +(set-extent-face modeline-buffer-id-extent 'modeline-buffer-id) + +(defvar modeline-buffer-id-left-extent (make-extent nil nil) +"Extent covering the left half of the buffer-id string.") +(set-extent-keymap modeline-buffer-id-left-extent + modeline-buffer-id-left-map) +(set-extent-property modeline-buffer-id-left-extent 'help-echo + "button2 cycles to the previous buffer") + +(defvar modeline-buffer-id-right-extent (make-extent nil nil) +"Extent covering the right half of the buffer-id string.") +(set-extent-keymap modeline-buffer-id-right-extent + modeline-buffer-id-right-map) +(set-extent-property modeline-buffer-id-right-extent 'help-echo + "button2 cycles to the next buffer") + +(defconst modeline-buffer-identification + (list (cons modeline-buffer-id-left-extent (purecopy "XEmacs%N:")) + ; this used to be "XEmacs:" + (cons modeline-buffer-id-right-extent (purecopy " %17b"))) + "Modeline control for identifying the buffer being displayed. +Its default value is \"XEmacs: %17b\" (NOT!). Major modes that edit things +other than ordinary files may change this (e.g. Info, Dired,...)") +(make-variable-buffer-local 'modeline-buffer-identification) + +(defconst modeline-process nil + "Modeline control for displaying info on process status. +Normally nil in most modes, since there is no process to display.") +(make-variable-buffer-local 'modeline-process) + +(defvar modeline-modified-map (make-sparse-keymap 'modeline-modified-map) + "Keymap consulted for mouse-clicks on the modeline-modified string.") +(define-key modeline-modified-map 'button2 + (make-modeline-command-wrapper 'modeline-toggle-read-only)) + +(defvar modeline-modified-extent (make-extent nil nil) + "Extent covering the modeline-modified string.") +(set-extent-face modeline-modified-extent 'modeline-mousable) +(set-extent-keymap modeline-modified-extent modeline-modified-map) +(set-extent-property modeline-modified-extent 'help-echo + "button2 toggles the buffer's read-only status") + +(defconst modeline-modified (purecopy '("--%1*%1+-")) + "Modeline control for displaying whether current buffer is modified.") +(make-variable-buffer-local 'modeline-modified) + +(defvar modeline-narrowed-map (make-sparse-keymap 'modeline-narrowed-map) + "Keymap consulted for mouse-clicks on the modeline-narrowed string.") +(define-key modeline-narrowed-map 'button2 + (make-modeline-command-wrapper 'widen)) + +(defvar modeline-narrowed-extent (make-extent nil nil) + "Extent covering the modeline-narrowed string.") +(set-extent-face modeline-narrowed-extent 'modeline-mousable) +(set-extent-keymap modeline-narrowed-extent modeline-narrowed-map) +(set-extent-property modeline-narrowed-extent 'help-echo + "button2 widens the buffer") + +(setq-default + modeline-format + (list + (purecopy "") + (cons modeline-modified-extent 'modeline-modified) + (cons modeline-buffer-id-extent 'modeline-buffer-identification) + (purecopy " ") + 'global-mode-string + (purecopy " %[(") + (cons modeline-minor-mode-extent (list "" 'mode-name 'minor-mode-alist)) + (cons modeline-narrowed-extent "%n") + 'modeline-process + (purecopy ")%]----") + (purecopy '(line-number-mode "L%l--")) + (purecopy '(column-number-mode "C%c--")) + (purecopy '(-3 . "%p")) + (purecopy "-%-"))) + +;;; Added for XEmacs 20.3. Provide wrapper for vc since it may not always be +;;; present, and its symbols are not visible this early in the dump if it +;;; is. + +(defun modeline-toggle-read-only () + "Change whether this buffer is visiting its file read-only. +With arg, set read-only iff arg is positive. +This function is designed to be called when the read-only indicator on the +modeline is clicked. It will call `vc-toggle-read-only' if available, +otherwise it will call the usual `toggle-read-only'." + (interactive) + (if (fboundp 'vc-toggle-read-only) + (vc-toggle-read-only) + (toggle-read-only))) + +;;; modeline.el ends here
--- a/lisp/modes/abbrev.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,531 +0,0 @@ -;;; abbrev.el --- abbrev mode commands for Emacs - -;; Copyright (C) 1985, 1986, 1987, 1992 Free Software Foundation, Inc. - -;; Keywords: abbrev - -;; 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.34 (With some additions) - -;;; Commentary: - -;; This facility is documented in the Emacs Manual. - -;;; Code: - -;jwz: this is preloaded so don't ;;;###autoload -(defcustom only-global-abbrevs nil "\ -*Non-nil means user plans to use global abbrevs only. -Makes the commands to define mode-specific abbrevs define global ones instead." - :type 'boolean - :group 'abbrev) - -;;; XEmacs: the following block of code is not in FSF -(defvar abbrev-table-name-list '() - "List of symbols whose values are abbrev tables.") - -(defvar abbrevs-changed nil - "Set non-nil by defining or altering any word abbrevs. -This causes `save-some-buffers' to offer to save the abbrevs.") - -(defun make-abbrev-table () - "Create a new, empty abbrev table object." - (make-vector 59 0)) ; 59 is prime - -(defun clear-abbrev-table (table) - "Undefine all abbrevs in abbrev table TABLE, leaving it empty." - (fillarray table 0) - (setq abbrevs-changed t) - nil) - - -(defun define-abbrev-table (name defs) - "Define TABNAME (a symbol) as an abbrev table name. -Define abbrevs in it according to DEFINITIONS, which is a list of elements -of the form (ABBREVNAME EXPANSION HOOK USECOUNT)." - (let ((table (and (boundp name) (symbol-value name)))) - (cond ((vectorp table)) - ((not table) - (setq table (make-abbrev-table)) - (set name table) - (setq abbrev-table-name-list (cons name abbrev-table-name-list))) - (t - (setq table (signal 'wrong-type-argument (list 'vectorp table))) - (set name table))) - (while defs - (apply (function define-abbrev) table (car defs)) - (setq defs (cdr defs))))) - -(defun define-abbrev (table name &optional expansion hook count) - "Define an abbrev in TABLE named NAME, to expand to EXPANSION or call HOOK. -NAME and EXPANSION are strings. Hook is a function or `nil'. -To undefine an abbrev, define it with an expansion of `nil'." - (or (not expansion) - (stringp expansion) - (setq expansion (signal 'wrong-type-argument - (list 'stringp expansion)))) - (or (not count) - (integerp count) - (setq count (signal 'wrong-type-argument - (list 'fixnump count)))) - (or (vectorp table) - (setq table (signal 'wrong-type-argument - (list 'vectorp table)))) - (let* ((sym (intern name table)) - (oexp (and (boundp sym) (symbol-value sym))) - (ohook (and (fboundp sym) (symbol-function sym)))) - (unless (and (equal ohook hook) - (stringp oexp) - (stringp expansion) - (string-equal oexp expansion)) - (setq abbrevs-changed t) - ;; If there is a non-word character in the string, set the flag. - (if (string-match "\\W" name) - (set (intern " " table) nil))) - (set sym expansion) - (fset sym hook) - (setplist sym (or count 0)) - name)) - - -;; Fixup stuff from bootstrap def of define-abbrev-table in subr.el -(let ((l abbrev-table-name-list)) - (while l - (let ((fixup (car l))) - (if (consp fixup) - (progn - (setq abbrev-table-name-list (delq fixup abbrev-table-name-list)) - (define-abbrev-table (car fixup) (cdr fixup)))) - (setq l (cdr l)))) - ;; These are no longer initialised by C code - (if (not global-abbrev-table) - (progn - (setq global-abbrev-table (make-abbrev-table)) - (setq abbrev-table-name-list (cons 'global-abbrev-table - abbrev-table-name-list)))) - (if (not fundamental-mode-abbrev-table) - (progn - (setq fundamental-mode-abbrev-table (make-abbrev-table)) - (setq abbrev-table-name-list (cons 'fundamental-mode-abbrev-table - abbrev-table-name-list)))) - (and (eq major-mode 'fundamental-mode) - (not local-abbrev-table) - (setq local-abbrev-table fundamental-mode-abbrev-table))) - - -(defun define-global-abbrev (name expansion) - "Define ABBREV as a global abbreviation for EXPANSION." - (interactive "sDefine global abbrev: \nsExpansion for %s: ") - (define-abbrev global-abbrev-table - (downcase name) expansion nil 0)) - -(defun define-mode-abbrev (name expansion) - "Define ABBREV as a mode-specific abbreviation for EXPANSION." - (interactive "sDefine mode abbrev: \nsExpansion for %s: ") - (define-abbrev (or local-abbrev-table - (error "Major mode has no abbrev table")) - (downcase name) expansion nil 0)) - -(defun abbrev-symbol (abbrev &optional table) - "Return the symbol representing abbrev named ABBREV. -This symbol's name is ABBREV, but it is not the canonical symbol of that name; -it is interned in an abbrev-table rather than the normal obarray. -The value is nil if that abbrev is not defined. -Optional second arg TABLE is abbrev table to look it up in. -The default is to try buffer's mode-specific abbrev table, then global table." - (let ((frob (function (lambda (table) - (let ((sym (intern-soft abbrev table))) - (if (and (boundp sym) - (stringp (symbol-value sym))) - sym - nil)))))) - (if table - (funcall frob table) - (or (and local-abbrev-table - (funcall frob local-abbrev-table)) - (funcall frob global-abbrev-table))))) - -(defun abbrev-expansion (abbrev &optional table) - "Return the string that ABBREV expands into in the current buffer. -Optionally specify an abbrev table as second arg; -then ABBREV is looked up in that table only." - (let ((sym (abbrev-symbol abbrev table))) - (if sym - (symbol-value sym) - nil))) - -(defun unexpand-abbrev () - "Undo the expansion of the last abbrev that expanded. -This differs from ordinary undo in that other editing done since then -is not undone." - (interactive) - (if (or (< last-abbrev-location (point-min)) - (> last-abbrev-location (point-max)) - (not (stringp last-abbrev-text))) - nil - (let* ((opoint (point)) - (val (symbol-value last-abbrev)) - (adjust (length val))) - ;; This isn't correct if (symbol-function last-abbrev-text) - ;; was used to do the expansion - (goto-char last-abbrev-location) - (delete-region last-abbrev-location (+ last-abbrev-location adjust)) - (insert last-abbrev-text) - (setq adjust (- adjust (length last-abbrev-text))) - (setq last-abbrev-text nil) - (if (< last-abbrev-location opoint) - (goto-char (- opoint adjust)) - (goto-char opoint))))) - - - -(defun insert-abbrev-table-description (name human-readable) - "Insert before point a full description of abbrev table named NAME. -NAME is a symbol whose value is an abbrev table. -If optional 2nd arg HUMAN is non-nil, insert a human-readable description. -Otherwise the description is an expression, -a call to `define-abbrev-table', which would -define the abbrev table NAME exactly as it is currently defined." - (let ((table (symbol-value name)) - (stream (current-buffer))) - (message "Abbrev-table %s..." name) - (if human-readable - (progn - (prin1 (list name) stream) - ;; Need two terpri's or cretinous edit-abbrevs blows out - (terpri stream) - (terpri stream) - (mapatoms (function (lambda (sym) - (if (symbol-value sym) - (let* ((n (prin1-to-string (symbol-name sym))) - (pos (length n))) - (princ n stream) - (while (< pos 14) - (write-char ?\ stream) - (setq pos (1+ pos))) - (princ (format " %-5S " (symbol-plist sym)) - stream) - (if (not (symbol-function sym)) - (prin1 (symbol-value sym) stream) - (progn - (setq n (prin1-to-string (symbol-value sym)) - pos (+ pos 6 (length n))) - (princ n stream) - (while (< pos 45) - (write-char ?\ stream) - (setq pos (1+ pos))) - (prin1 (symbol-function sym) stream))) - (terpri stream))))) - table) - (terpri stream)) - (progn - (princ "\(define-abbrev-table '" stream) - (prin1 name stream) - (princ " '\(\n" stream) - (mapatoms (function (lambda (sym) - (if (symbol-value sym) - (progn - (princ " " stream) - (prin1 (list (symbol-name sym) - (symbol-value sym) - (symbol-function sym) - (symbol-plist sym)) - stream) - (terpri stream))))) - table) - (princ " \)\)\n" stream))) - (terpri stream)) - (message "")) -;;; End code not in FSF - -(defun abbrev-mode (arg) - "Toggle abbrev mode. -With argument ARG, turn abbrev mode on iff ARG is positive. -In abbrev mode, inserting an abbreviation causes it to expand -and be replaced by its expansion." - (interactive "P") - (setq abbrev-mode - (if (null arg) (not abbrev-mode) - (> (prefix-numeric-value arg) 0))) - ;; XEmacs change - (redraw-modeline)) - - -(defvar edit-abbrevs-map nil - "Keymap used in edit-abbrevs.") -(if edit-abbrevs-map - nil - (setq edit-abbrevs-map (make-sparse-keymap)) - ;; XEmacs change - (set-keymap-name edit-abbrevs-map 'edit-abbrevs-map) - (define-key edit-abbrevs-map "\C-x\C-s" 'edit-abbrevs-redefine) - (define-key edit-abbrevs-map "\C-c\C-c" 'edit-abbrevs-redefine)) - -(defun kill-all-abbrevs () - "Undefine all defined abbrevs." - (interactive) - (let ((tables abbrev-table-name-list)) - (while tables - (clear-abbrev-table (symbol-value (car tables))) - (setq tables (cdr tables))))) - -(defun insert-abbrevs () - "Insert after point a description of all defined abbrevs. -Mark is set after the inserted text." - (interactive) - (push-mark - (save-excursion - (let ((tables abbrev-table-name-list)) - (while tables - (insert-abbrev-table-description (car tables) t) - (setq tables (cdr tables)))) - (point)))) - -(defun list-abbrevs () - "Display a list of all defined abbrevs." - (interactive) - (display-buffer (prepare-abbrev-list-buffer))) - -(defun prepare-abbrev-list-buffer () - (save-excursion - (set-buffer (get-buffer-create "*Abbrevs*")) - (erase-buffer) - (let ((tables abbrev-table-name-list)) - (while tables - (insert-abbrev-table-description (car tables) t) - (setq tables (cdr tables)))) - (goto-char (point-min)) - (set-buffer-modified-p nil) - (edit-abbrevs-mode)) - (get-buffer-create "*Abbrevs*")) - -(defun edit-abbrevs-mode () - "Major mode for editing the list of abbrev definitions. -\\{edit-abbrevs-map}" - (interactive) - (setq major-mode 'edit-abbrevs-mode) - (setq mode-name "Edit-Abbrevs") - (use-local-map edit-abbrevs-map)) - -(defun edit-abbrevs () - "Alter abbrev definitions by editing a list of them. -Selects a buffer containing a list of abbrev definitions. -You can edit them and type \\<edit-abbrevs-map>\\[edit-abbrevs-redefine] to redefine abbrevs -according to your editing. -Buffer contains a header line for each abbrev table, - which is the abbrev table name in parentheses. -This is followed by one line per abbrev in that table: -NAME USECOUNT EXPANSION HOOK -where NAME and EXPANSION are strings with quotes, -USECOUNT is an integer, and HOOK is any valid function -or may be omitted (it is usually omitted)." - (interactive) - (switch-to-buffer (prepare-abbrev-list-buffer))) - -(defun edit-abbrevs-redefine () - "Redefine abbrevs according to current buffer contents." - (interactive) - (define-abbrevs t) - (set-buffer-modified-p nil)) - -(defun define-abbrevs (&optional arg) - "Define abbrevs according to current visible buffer contents. -See documentation of `edit-abbrevs' for info on the format of the -text you must have in the buffer. -With argument, eliminate all abbrev definitions except -the ones defined from the buffer now." - (interactive "P") - (if arg (kill-all-abbrevs)) - (save-excursion - (goto-char (point-min)) - (while (and (not (eobp)) (re-search-forward "^(" nil t)) - (let* ((buf (current-buffer)) - (table (read buf)) - abbrevs name hook exp count) - (forward-line 1) - (while (progn (forward-line 1) - (not (eolp))) - (setq name (read buf) count (read buf) exp (read buf)) - (skip-chars-backward " \t\n\f") - (setq hook (if (not (eolp)) (read buf))) - (skip-chars-backward " \t\n\f") - (setq abbrevs (cons (list name exp hook count) abbrevs))) - (define-abbrev-table table abbrevs))))) - -(defun read-abbrev-file (&optional file quietly) - "Read abbrev definitions from file written with `write-abbrev-file'. -Optional argument FILE is the name of the file to read; -it defaults to the value of `abbrev-file-name'. -Optional second argument QUIETLY non-nil means don't print anything." - (interactive "fRead abbrev file: ") - (load (if (and file (> (length file) 0)) file abbrev-file-name) - nil quietly) - (setq save-abbrevs t abbrevs-changed nil)) - -(defun quietly-read-abbrev-file (&optional file) - "Read abbrev definitions from file written with write-abbrev-file. -Optional argument FILE is the name of the file to read; -it defaults to the value of `abbrev-file-name'. -Does not print anything." - ;(interactive "fRead abbrev file: ") - (read-abbrev-file file t)) - -(defun write-abbrev-file (file) - "Write all abbrev definitions to a file of Lisp code. -The file written can be loaded in another session to define the same abbrevs. -The argument FILE is the file name to write." - (interactive - (list - (read-file-name "Write abbrev file: " - (file-name-directory (expand-file-name abbrev-file-name)) - abbrev-file-name))) - (or (and file (> (length file) 0)) - (setq file abbrev-file-name)) - (save-excursion - (set-buffer (get-buffer-create " write-abbrev-file")) - (erase-buffer) - (let ((tables abbrev-table-name-list)) - (while tables - (insert-abbrev-table-description (car tables) nil) - (setq tables (cdr tables)))) - (write-region 1 (point-max) file) - (erase-buffer))) - -(defun add-mode-abbrev (arg) - "Define mode-specific abbrev for last word(s) before point. -Argument is how many words before point form the expansion; -or zero means the region is the expansion. -A negative argument means to undefine the specified abbrev. -Reads the abbreviation in the minibuffer. - -Don't use this function in a Lisp program; use `define-abbrev' instead." - ;; XEmacs change: - (interactive "P") - (add-abbrev - (if only-global-abbrevs - global-abbrev-table - (or local-abbrev-table - (error "No per-mode abbrev table"))) - "Mode" arg)) - -(defun add-global-abbrev (arg) - "Define global (all modes) abbrev for last word(s) before point. -The prefix argument specifies the number of words before point that form the -expansion; or zero means the region is the expansion. -A negative argument means to undefine the specified abbrev. -This command uses the minibuffer to read the abbreviation. - -Don't use this function in a Lisp program; use `define-abbrev' instead." - ;; XEmacs change: - (interactive "P") - (add-abbrev global-abbrev-table "Global" arg)) - -(defun add-abbrev (table type arg) - ;; XEmacs change: - (if (and (not arg) (region-active-p)) (setq arg 0) - (setq arg (prefix-numeric-value arg))) - (let ((exp (and (>= arg 0) - (buffer-substring - (point) - (if (= arg 0) (mark) - (save-excursion (forward-word (- arg)) (point)))))) - name) - (setq name - (read-string (format (if exp "%s abbrev for \"%s\": " - "Undefine %s abbrev: ") - type exp))) - (set-text-properties 0 (length name) nil name) - (if (or (null exp) - (not (abbrev-expansion name table)) - (y-or-n-p (format "%s expands to \"%s\"; redefine? " - name (abbrev-expansion name table)))) - (define-abbrev table (downcase name) exp)))) - -(defun inverse-add-mode-abbrev (arg) - "Define last word before point as a mode-specific abbrev. -With prefix argument N, defines the Nth word before point. -This command uses the minibuffer to read the expansion. -Expands the abbreviation after defining it." - (interactive "p") - (inverse-add-abbrev - (if only-global-abbrevs - global-abbrev-table - (or local-abbrev-table - (error "No per-mode abbrev table"))) - "Mode" arg)) - -(defun inverse-add-global-abbrev (arg) - "Define last word before point as a global (mode-independent) abbrev. -With prefix argument N, defines the Nth word before point. -This command uses the minibuffer to read the expansion. -Expands the abbreviation after defining it." - (interactive "p") - (inverse-add-abbrev global-abbrev-table "Global" arg)) - -(defun inverse-add-abbrev (table type arg) - (let (name nameloc exp) - (save-excursion - (forward-word (- arg)) - (setq name (buffer-substring (point) (progn (forward-word 1) - (setq nameloc (point)))))) - (set-text-properties 0 (length name) nil name) - (setq exp (read-string (format "%s expansion for \"%s\": " - type name))) - (if (or (not (abbrev-expansion name table)) - (y-or-n-p (format "%s expands to \"%s\"; redefine? " - name (abbrev-expansion name table)))) - (progn - (define-abbrev table (downcase name) exp) - (save-excursion - (goto-char nameloc) - (expand-abbrev)))))) - -(defun abbrev-prefix-mark (&optional arg) - "Mark current point as the beginning of an abbrev. -Abbrev to be expanded starts here rather than at beginning of word. -This way, you can expand an abbrev with a prefix: insert the prefix, -use this command, then insert the abbrev." - (interactive "P") - (or arg (expand-abbrev)) - (setq abbrev-start-location (point-marker) - abbrev-start-location-buffer (current-buffer)) - (insert "-")) - -(defun expand-region-abbrevs (start end &optional noquery) - "For abbrev occurrence in the region, offer to expand it. -The user is asked to type y or n for each occurrence. -A prefix argument means don't query; expand all abbrevs. -If called from a Lisp program, arguments are START END &optional NOQUERY." - (interactive "r\nP") - (save-excursion - (goto-char start) - (let ((lim (- (point-max) end)) - pnt string) - (while (and (not (eobp)) - (progn (forward-word 1) - (<= (setq pnt (point)) (- (point-max) lim)))) - (if (abbrev-expansion - (setq string - (buffer-substring - (save-excursion (forward-word -1) (point)) - pnt))) - (if (or noquery (y-or-n-p (format "Expand `%s'? " string))) - (expand-abbrev))))))) - -;;; abbrev.el ends here
--- a/lisp/modes/ada-mode.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,3942 +0,0 @@ -;;; ada-mode.el --- An Emacs major-mode for editing Ada source. - -;; Copyright (C) 1994, 1995, 1997 Free Software Foundation, Inc. - -;; Authors: Rolf Ebert <ebert@inf.enst.fr> -;; Markus Heritsch <Markus.Heritsch@studbox.uni-stuttgart.de> -;; Keywords: languages oop ada -;; Rolf Ebert's version: 2.27 - -;; 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. - -;;; This mode is a complete rewrite of a major mode for editing Ada 83 -;;; and Ada 95 source code under Emacs-19. It contains completely new -;;; indenting code and support for code browsing (see ada-xref). - -;;; Synched up with: FSF 20.1 - -;;; USAGE -;;; ===== -;;; Emacs should enter Ada mode when you load an Ada source (*.ad[abs]). -;;; -;;; When you have entered ada-mode, you may get more info by pressing -;;; C-h m. You may also get online help describing various functions by: -;;; C-h d <Name of function you want described> - - -;;; HISTORY -;;; ======= -;;; The first Ada mode for GNU Emacs was written by V. Broman in -;;; 1985. He based his work on the already existing Modula-2 mode. -;;; This was distributed as ada.el in versions of Emacs prior to 19.29. -;;; -;;; Lynn Slater wrote an extensive Ada mode in 1989. It consisted of -;;; several files with support for dired commands and other nice -;;; things. It is currently available from the PAL -;;; (wuarchive.wustl.edu:/languages/ada) as ada-mode-1.06a.tar.Z. -;;; -;;; The probably very first Ada mode (called electric-ada.el) was -;;; written by Steven D. Litvintchouk and Steven M. Rosen for the -;;; Gosling Emacs. L. Slater based his development on ada.el and -;;; electric-ada.el. -;;; -;;; The current Ada mode is a complete rewrite by M. Heritsch and -;;; R. Ebert. Some ideas from the Ada mode mailing list have been -;;; added. Some of the functionality of L. Slater's mode has not -;;; (yet) been recoded in this new mode. Perhaps you prefer sticking -;;; to his version. - - -;;; KNOWN BUGS -;;; ========== -;;; -;;; In the presence of comments and/or incorrect syntax -;;; ada-format-paramlist produces weird results. -;;; ------------------- -;;; Character constants with otherwise syntactic relevant characters -;;; like `(' or `"' throw indentation off the track. Fontification -;;; should work now in Emacs-19.35 -;;; C : constant Character := Character'('"'); -;;; ------------------- - - -;;; TODO -;;; ==== -;;; -;;; o bodify-single-subprogram -;;; o make a function "separate" and put it in the corresponding file. - - - -;;; CREDITS -;;; ======= -;;; -;;; Many thanks to -;;; Philippe Waroquiers (PW) <philippe@cfmu.eurocontrol.be> in particular, -;;; woodruff@stc.llnl.gov (John Woodruff) -;;; jj@ddci.dk (Jesper Joergensen) -;;; gse@ocsystems.com (Scott Evans) -;;; comar@LANG8.CS.NYU.EDU (Cyrille Comar) -;;; and others for their valuable hints. - -;;;-------------------- -;;; USER OPTIONS -;;;-------------------- - - -;; ---- customize support - -(defgroup ada nil - "Major mode for editing Ada source in Emacs" - :group 'languages) - -;; ---- configure indentation - -(defcustom ada-indent 3 - "*Defines the size of Ada indentation." - :type 'integer - :group 'ada) - -(defcustom ada-broken-indent 2 - "*# of columns to indent the continuation of a broken line." - :type 'integer - :group 'ada) - -(defcustom ada-label-indent -4 - "*# of columns to indent a label." - :type 'integer - :group 'ada) - -(defcustom ada-stmt-end-indent 0 - "*# of columns to indent a statement end keyword in a separate line. -Examples are 'is', 'loop', 'record', ..." - :type 'integer - :group 'ada) - -(defcustom ada-when-indent 3 - "*Defines the indentation for 'when' relative to 'exception' or 'case'." - :type 'integer - :group 'ada) - -(defcustom ada-indent-record-rel-type 3 - "*Defines the indentation for 'record' relative to 'type' or 'use'." - :type 'integer - :group 'ada) - -(defcustom ada-indent-comment-as-code t - "*If non-nil, comment-lines get indented as Ada code." - :type 'boolean - :group 'ada) - -(defcustom ada-indent-is-separate t - "*If non-nil, 'is separate' or 'is abstract' on a single line are indented." - :type 'boolean - :group 'ada) - -(defcustom ada-indent-to-open-paren t - "*If non-nil, indent according to the innermost open parenthesis." - :type 'boolean - :group 'ada) - -(defcustom ada-search-paren-char-count-limit 3000 - "*Search that many characters for an open parenthesis." - :type 'integer - :group 'ada) - - -;; ---- other user options - -(defcustom ada-tab-policy 'indent-auto - "*Control behaviour of the TAB key. -Must be one of `indent-rigidly', `indent-auto', `gei', `indent-af' -or `always-tab'. - -`indent-rigidly' : always adds ada-indent blanks at the beginning of the line. -`indent-auto' : use indentation functions in this file. -`gei' : use David Kågedal's Generic Indentation Engine. -`indent-af' : use Gary E. Barnes' ada-format.el -`always-tab' : do indent-relative." - :type '(choice (const indent-auto) - (const indent-rigidly) - (const gei) - (const indent-af) - (const always-tab)) - :group 'ada) - -(defcustom ada-move-to-declaration nil - "*If non-nil, `ada-move-to-start' moves point to the subprog declaration, -not to 'begin'." - :type 'boolean - :group 'ada) - -(defcustom ada-spec-suffix ".ads" - "*Suffix of Ada specification files." - :type 'string - :group 'ada) - -(defcustom ada-body-suffix ".adb" - "*Suffix of Ada body files." - :type 'string - :group 'ada) - -(defcustom ada-spec-suffix-as-regexp "\\.ads$" - "*Regexp to find Ada specification files." - :type 'string - :group 'ada) - -(defcustom ada-body-suffix-as-regexp "\\.adb$" - "*Regexp to find Ada body files." - :type 'string - :group 'ada) - -(defvar ada-other-file-alist - (list - (list ada-spec-suffix-as-regexp (list ada-body-suffix)) - (list ada-body-suffix-as-regexp (list ada-spec-suffix)) - ) - "*Alist of extensions to find given the current file's extension. - -This list should contain the most used extensions before the others, -since the search algorithm searches sequentially through each directory -specified in `ada-search-directories'. If a file is not found, a new one -is created with the first matching extension (`.adb' yields `.ads').") - -(defcustom ada-search-directories - '("." "/usr/adainclude" "/usr/local/adainclude" "/opt/gnu/adainclude") - "*List of directories to search for Ada files. -See the description for the `ff-search-directories' variable." - :type '(repeat (choice :tag "Directory" - (const :tag "default" nil) - (directory :format "%v"))) - :group 'ada) - -(defcustom ada-language-version 'ada95 - "*Do we program in `ada83' or `ada95'?" - :type '(choice (const ada83) - (const ada95)) - :group 'ada) - -(defcustom ada-case-keyword 'downcase-word - "*Function to call to adjust the case of Ada keywords. -It may be `downcase-word', `upcase-word', `ada-loose-case-word' or -`capitalize-word'." - :type '(choice (const downcase-word) - (const upcase-word) - (const capitalize-word) - (const ada-loose-case-word)) - :group 'ada) - -(defcustom ada-case-identifier 'ada-loose-case-word - "*Function to call to adjust the case of an Ada identifier. -It may be `downcase-word', `upcase-word', `ada-loose-case-word' or -`capitalize-word'." - :type '(choice (const downcase-word) - (const upcase-word) - (const capitalize-word) - (const ada-loose-case-word)) - :group 'ada) - -(defcustom ada-case-attribute 'capitalize-word - "*Function to call to adjust the case of Ada attributes. -It may be `downcase-word', `upcase-word', `ada-loose-case-word' or -`capitalize-word'." - :type '(choice (const downcase-word) - (const upcase-word) - (const capitalize-word) - (const ada-loose-case-word)) - :group 'ada) - -(defcustom ada-auto-case t - "*Non-nil automatically changes case of preceding word while typing. -Casing is done according to `ada-case-keyword', `ada-case-identifier' -and `ada-case-attribute'." - :type 'boolean - :group 'ada) - -(defcustom ada-clean-buffer-before-saving t - "*If non-nil, `remove-trailing-spaces' and `untabify' buffer before saving." - :type 'boolean - :group 'ada) - -(defvar ada-mode-hook nil - "*List of functions to call when Ada mode is invoked. -This is a good place to add Ada environment specific bindings.") - -(defcustom ada-external-pretty-print-program "aimap" - "*External pretty printer to call from within Ada mode." - :type 'string - :group 'ada) - -(defcustom ada-tmp-directory "/tmp/" - "*Directory to store the temporary file for the Ada pretty printer." - :type 'string - :group 'ada) - -(defcustom ada-compile-options "-c" - "*Buffer local options passed to the Ada compiler. -These options are used when the compiler is invoked on the current buffer." - :type 'string - :group 'ada) -(make-variable-buffer-local 'ada-compile-options) - -(defcustom ada-make-options "-c" - "*Buffer local options passed to `ada-compiler-make' (usually `gnatmake'). -These options are used when `gnatmake' is invoked on the current buffer." - :type 'string - :group 'ada) -(make-variable-buffer-local 'ada-make-options) - -(defcustom ada-compiler-syntax-check "gcc -c -gnats" - "*Compiler command with options for syntax checking." - :type 'string - :group 'ada) - -(defcustom ada-compiler-make "gnatmake" - "*The `make' command for the given compiler." - :type 'string - :group 'ada) - -(defcustom ada-fill-comment-prefix "-- " - "*This is inserted in the first columns when filling a comment paragraph." - :type 'string - :group 'ada) - -(defcustom ada-fill-comment-postfix " --" - "*This is inserted at the end of each line when filling a comment paragraph. -with `ada-fill-comment-paragraph-postfix'." - :type 'string - :group 'ada) - -(defcustom ada-krunch-args "0" - "*Argument of gnatkr, a string containing the max number of characters. -Set to 0, if you don't use crunched filenames." - :type 'string - :group 'ada) - -;;; ---- end of user configurable variables - - -(defvar ada-mode-abbrev-table nil - "Abbrev table used in Ada mode.") -(define-abbrev-table 'ada-mode-abbrev-table ()) - -(defvar ada-mode-map () - "Local keymap used for Ada mode.") - -(defvar ada-mode-syntax-table nil - "Syntax table to be used for editing Ada source code.") - -(defvar ada-mode-symbol-syntax-table nil - "Syntax table for Ada, where `_' is a word constituent.") - -(defconst ada-83-keywords - "\\<\\(abort\\|abs\\|accept\\|access\\|all\\|and\\|array\\|\ -at\\|begin\\|body\\|case\\|constant\\|declare\\|delay\\|delta\\|\ -digits\\|do\\|else\\|elsif\\|end\\|entry\\|exception\\|exit\\|for\\|\ -function\\|generic\\|goto\\|if\\|in\\|is\\|limited\\|loop\\|mod\\|\ -new\\|not\\|null\\|of\\|or\\|others\\|out\\|package\\|pragma\\|\ -private\\|procedure\\|raise\\|range\\|record\\|rem\\|renames\\|\ -return\\|reverse\\|select\\|separate\\|subtype\\|task\\|terminate\\|\ -then\\|type\\|use\\|when\\|while\\|with\\|xor\\)\\>" -; "\\<\\(a\\(b\\(ort\\|s\\)\\|cce\\(pt\\|ss\\)\\|ll\\|nd\\|rray\\|t\\)\\|\ -;b\\(egin\\|ody\\)\\|c\\(ase\\|onstant\\)\\|\ -;d\\(e\\(clare\\|l\\(ay\\|ta\\)\\)\\|igits\\|o\\)\\|\ -;e\\(ls\\(e\\|if\\)\\|n\\(d\\|try\\)\\|x\\(ception\\|it\\)\\)\\|\ -;f\\(or\\|unction\\)\\|g\\(eneric\\|oto\\)\\|i[fns]\\|l\\(imited\\|oop\\)\\|\ -;mod\\|n\\(ew\\|ot\\|ull\\)\\|o\\([fr]\\|thers\\|ut\\)\\|\ -;p\\(ackage\\|r\\(agma\\|ivate\\|ocedure\\)\\)\\|\ -;r\\(a\\(ise\\|nge\\)\\|e\\(cord\\|m\\|names\\|turn\\|verse\\)\\)\\|\ -;s\\(e\\(lect\\|parate\\)\\|ubtype\\)\\|use\\| -;t\\(ask\\|erminate\\|hen\\|ype\\)\\|w\\(h\\(en\\|ile\\)\\|ith\\)\\|xor\\)\\>" - "Regular expression for looking at Ada83 keywords.") - -(defconst ada-95-keywords - "\\<\\(abort\\|abs\\|abstract\\|accept\\|access\\|aliased\\|\ -all\\|and\\|array\\|at\\|begin\\|body\\|case\\|constant\\|declare\\|\ -delay\\|delta\\|digits\\|do\\|else\\|elsif\\|end\\|entry\\|\ -exception\\|exit\\|for\\|function\\|generic\\|goto\\|if\\|in\\|\ -is\\|limited\\|loop\\|mod\\|new\\|not\\|null\\|of\\|or\\|others\\|\ -out\\|package\\|pragma\\|private\\|procedure\\|protected\\|raise\\|\ -range\\|record\\|rem\\|renames\\|requeue\\|return\\|reverse\\|\ -select\\|separate\\|subtype\\|tagged\\|task\\|terminate\\|then\\|\ -type\\|until\\|use\\|when\\|while\\|with\\|xor\\)\\>" - "Regular expression for looking at Ada95 keywords.") - -(defvar ada-keywords ada-95-keywords - "Regular expression for looking at Ada keywords.") - -(defvar ada-ret-binding nil - "Variable to save key binding of RET when casing is activated.") - -(defvar ada-lfd-binding nil - "Variable to save key binding of LFD when casing is activated.") - -;;; ---- Regexps to find procedures/functions/packages - -(defconst ada-ident-re - "[a-zA-Z0-9_\\.]+" - "Regexp matching Ada (qualified) identifiers.") - -(defvar ada-procedure-start-regexp - "^[ \t]*\\(procedure\\|function\\|task\\)[ \t\n]+\\([a-zA-Z0-9_\\.]+\\)" - "Regexp used to find Ada procedures/functions.") - -(defvar ada-package-start-regexp - "^[ \t]*\\(package\\)" - "Regexp used to find Ada packages") - - -;;; ---- regexps for indentation functions - -(defvar ada-block-start-re - "\\<\\(begin\\|select\\|declare\\|private\\|or\\|generic\\|\ -exception\\|loop\\|else\\|\ -\\(\\(limited\\|abstract\\|tagged\\)[ \t]+\\)*record\\)\\>" - "Regexp for keywords starting Ada blocks.") - -(defvar ada-end-stmt-re - "\\(;\\|=>\\|^[ \t]*separate[ \t]+([a-zA-Z0-9_\\.]+)\\|\ -\\<\\(begin\\|else\\|record\\|loop\\|select\\|do\\|then\\|\ -declare\\|generic\\|private\\)\\>\\|\ -^[ \t]*\\(package\\|procedure\\|function\\)\\>[ \ta-zA-Z0-9_\\.]+\\<is\\>\\|\ -^[ \t]*exception\\>\\)" - "Regexp of possible ends for a non-broken statement. -A new statement starts after these.") - -(defvar ada-loop-start-re - "\\<\\(for\\|while\\|loop\\)\\>" - "Regexp for the start of a loop.") - -(defvar ada-subprog-start-re - "\\<\\(procedure\\|protected\\|package\\|function\\|\ -task\\|accept\\|entry\\)\\>" - "Regexp for the start of a subprogram.") - -(defvar ada-named-block-re - "[ \t]*[a-zA-Z_0-9]+ *:[^=]" - "Regexp of the name of a block or loop.") - - -;; Written by Christian Egli <Christian.Egli@hcsd.hac.com> -;; -(defvar ada-imenu-generic-expression - '((nil "^\\s-*\\(procedure\\|function\\)\\s-+\\([A-Za-z0-9_]+\\)" 2) - ("Type Defs" "^\\s-*\\(sub\\)?type\\s-+\\([A-Za-z0-9_]+\\)" 2)) - - "Imenu generic expression for Ada mode. See `imenu-generic-expression'.") - -;;;------------- -;;; functions -;;;------------- - -(defun ada-xemacs () - (or (string-match "Lucid" emacs-version) - (string-match "XEmacs" emacs-version))) - -(defun ada-create-syntax-table () - "Create the syntax table for Ada mode." - ;; There are two different syntax-tables. The standard one declares - ;; `_' as a symbol constituent, in the second one, it is a word - ;; constituent. For some search and replacing routines we - ;; temporarily switch between the two. - (setq ada-mode-syntax-table (make-syntax-table)) - (set-syntax-table ada-mode-syntax-table) - - ;; define string brackets (`%' is alternative string bracket, but - ;; almost never used as such and throws font-lock and indentation - ;; off the track.) - (modify-syntax-entry ?% "$" ada-mode-syntax-table) - (modify-syntax-entry ?\" "\"" ada-mode-syntax-table) - - (modify-syntax-entry ?\# "$" ada-mode-syntax-table) - - (modify-syntax-entry ?: "." ada-mode-syntax-table) - (modify-syntax-entry ?\; "." ada-mode-syntax-table) - (modify-syntax-entry ?& "." ada-mode-syntax-table) - (modify-syntax-entry ?\| "." ada-mode-syntax-table) - (modify-syntax-entry ?+ "." ada-mode-syntax-table) - (modify-syntax-entry ?* "." ada-mode-syntax-table) - (modify-syntax-entry ?/ "." ada-mode-syntax-table) - (modify-syntax-entry ?= "." ada-mode-syntax-table) - (modify-syntax-entry ?< "." ada-mode-syntax-table) - (modify-syntax-entry ?> "." ada-mode-syntax-table) - (modify-syntax-entry ?$ "." ada-mode-syntax-table) - (modify-syntax-entry ?\[ "." ada-mode-syntax-table) - (modify-syntax-entry ?\] "." ada-mode-syntax-table) - (modify-syntax-entry ?\{ "." ada-mode-syntax-table) - (modify-syntax-entry ?\} "." ada-mode-syntax-table) - (modify-syntax-entry ?. "." ada-mode-syntax-table) - (modify-syntax-entry ?\\ "." ada-mode-syntax-table) - (modify-syntax-entry ?\' "." ada-mode-syntax-table) - - ;; a single hyphen is punctuation, but a double hyphen starts a comment - (modify-syntax-entry ?- ". 12" ada-mode-syntax-table) - - ;; and \f and \n end a comment - (modify-syntax-entry ?\f "> " ada-mode-syntax-table) - (modify-syntax-entry ?\n "> " ada-mode-syntax-table) - - ;; define what belongs in Ada symbols - (modify-syntax-entry ?_ "_" ada-mode-syntax-table) - - ;; define parentheses to match - (modify-syntax-entry ?\( "()" ada-mode-syntax-table) - (modify-syntax-entry ?\) ")(" ada-mode-syntax-table) - - (setq ada-mode-symbol-syntax-table (copy-syntax-table ada-mode-syntax-table)) - (modify-syntax-entry ?_ "w" ada-mode-symbol-syntax-table) - ) - - -;;;###autoload -(defun ada-mode () - "Ada mode is the major mode for editing Ada code. - -Bindings are as follows: (Note: 'LFD' is control-j.) - - Indent line '\\[ada-tab]' - Indent line, insert newline and indent the new line. '\\[newline-and-indent]' - - Re-format the parameter-list point is in '\\[ada-format-paramlist]' - Indent all lines in region '\\[ada-indent-region]' - Call external pretty printer program '\\[ada-call-pretty-printer]' - - Adjust case of identifiers and keywords in region '\\[ada-adjust-case-region]' - Adjust case of identifiers and keywords in buffer '\\[ada-adjust-case-buffer]' - - Call EXTERNAL pretty printer (if you have one) '\\[ada-call-pretty-printer]' - - Fill comment paragraph '\\[ada-fill-comment-paragraph]' - Fill comment paragraph and justify each line '\\[ada-fill-comment-paragraph-justify]' - Fill comment paragraph, justify and append postfix '\\[ada-fill-comment-paragraph-postfix]' - - Next func/proc/task '\\[ada-next-procedure]' Previous func/proc/task '\\[ada-previous-procedure]' - Next package '\\[ada-next-package]' Previous package '\\[ada-previous-package]' - - Goto matching start of current 'end ...;' '\\[ada-move-to-start]' - Goto end of current block '\\[ada-move-to-end]' - -Comments are handled using standard GNU Emacs conventions, including: - Start a comment '\\[indent-for-comment]' - Comment region '\\[comment-region]' - Uncomment region '\\[ada-uncomment-region]' - Continue comment on next line '\\[indent-new-comment-line]' - -If you use imenu.el: - Display index-menu of functions & procedures '\\[imenu]' - -If you use find-file.el: - Switch to other file (Body <-> Spec) '\\[ff-find-other-file]' - or '\\[ff-mouse-find-other-file] - Switch to other file in other window '\\[ada-ff-other-window]' - or '\\[ff-mouse-find-other-file-other-window] - If you use this function in a spec and no body is available, it gets created - with body stubs. - -If you use ada-xref.el: - Goto declaration: '\\[ada-point-and-xref]' on the identifier - or '\\[ada-goto-declaration]' with point on the identifier - Complete identifier: '\\[ada-complete-identifier]' - Execute Gnatf: '\\[ada-gnatf-current]'" - - (interactive) - (kill-all-local-variables) - - (make-local-variable 'require-final-newline) - (setq require-final-newline t) - - (make-local-variable 'comment-start) - (setq comment-start "-- ") - - ;; comment end must be set because it may hold a wrong value if - ;; this buffer had been in another mode before. RE - (make-local-variable 'comment-end) - (setq comment-end "") - - (make-local-variable 'comment-start-skip) ;; used by autofill - (setq comment-start-skip "--+[ \t]*") - - (make-local-variable 'indent-line-function) - (setq indent-line-function 'ada-indent-current-function) - - (make-local-variable 'fill-column) - (setq fill-column 75) - - (make-local-variable 'comment-column) - (setq comment-column 40) - - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments t) - - (make-local-variable 'case-fold-search) - (setq case-fold-search t) - - (make-local-variable 'outline-regexp) - (setq outline-regexp "[^\n\^M]") - (make-local-variable 'outline-level) - (setq outline-level 'ada-outline-level) - - (make-local-variable 'fill-paragraph-function) - (setq fill-paragraph-function 'ada-fill-comment-paragraph) - ;;(make-local-variable 'adaptive-fill-regexp) - - (make-local-variable 'imenu-generic-expression) - (setq imenu-generic-expression ada-imenu-generic-expression) - - (if (ada-xemacs) nil ; XEmacs uses properties - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults - '((ada-font-lock-keywords - ada-font-lock-keywords-1 ada-font-lock-keywords-2) - nil t - ((?\_ . "w")(?\. . "w")) - beginning-of-line - (font-lock-syntactic-keywords . ada-font-lock-syntactic-keywords))) - - ;; Set up support for find-file.el. - (make-variable-buffer-local 'ff-other-file-alist) - (make-variable-buffer-local 'ff-search-directories) - (setq ff-other-file-alist 'ada-other-file-alist - ff-search-directories 'ada-search-directories - ff-pre-load-hooks 'ff-which-function-are-we-in - ff-post-load-hooks 'ff-set-point-accordingly - ff-file-created-hooks 'ada-make-body)) - - (setq major-mode 'ada-mode) - (setq mode-name "Ada") - - (use-local-map ada-mode-map) - - (if ada-mode-syntax-table - (set-syntax-table ada-mode-syntax-table) - (ada-create-syntax-table)) - - (if ada-clean-buffer-before-saving - (progn - ;; remove all spaces at the end of lines in the whole buffer. - (add-hook 'local-write-file-hooks 'ada-remove-trailing-spaces) - ;; convert all tabs to the correct number of spaces. - (add-hook 'local-write-file-hooks 'ada-untabify-buffer))) - - - ;; add menu 'Ada' to the menu bar - (ada-add-ada-menu) - - (run-hooks 'ada-mode-hook) - - ;; the following has to be done after running the ada-mode-hook - ;; because users might want to set the values of these variable - ;; inside the hook (MH) - - (cond ((eq ada-language-version 'ada83) - (setq ada-keywords ada-83-keywords)) - ((eq ada-language-version 'ada95) - (setq ada-keywords ada-95-keywords))) - - (if ada-auto-case - (ada-activate-keys-for-case))) - - -;;;-------------------------- -;;; Compile support -;;;-------------------------- - -(defun ada-check-syntax () - "Check syntax of the current buffer. -Uses the function `compile' to execute `ada-compiler-syntax-check'." - (interactive) - (let ((old-compile-command compile-command)) - (setq compile-command (concat ada-compiler-syntax-check - (if (eq ada-language-version 'ada83) - "-gnat83 ") - " " ada-compile-options " " - (buffer-name))) - (setq compile-command (read-from-minibuffer - "enter command for syntax check: " - compile-command)) - (compile compile-command) - ;; restore old compile-command - (setq compile-command old-compile-command))) - -(defun ada-make-local () - "Bring current Ada unit up-to-date. -Uses the function `compile' to execute `ada-compile-make'." - (interactive) - (let ((old-compile-command compile-command)) - (setq compile-command (concat ada-compiler-make - " " ada-make-options " " - (buffer-name))) - (setq compile-command (read-from-minibuffer - "enter command for local make: " - compile-command)) - (compile compile-command) - ;; restore old compile-command - (setq compile-command old-compile-command))) - - - - -;;;-------------------------- -;;; Fill Comment Paragraph -;;;-------------------------- - -(defun ada-fill-comment-paragraph-justify () - "Fills current comment paragraph and justifies each line as well." - (interactive) - (ada-fill-comment-paragraph t)) - - -(defun ada-fill-comment-paragraph-postfix () - "Fills current comment paragraph and justifies each line as well. -Prompts for a postfix to be appended to each line." - (interactive) - (ada-fill-comment-paragraph t t)) - - -(defun ada-fill-comment-paragraph (&optional justify postfix) - "Fills the current comment paragraph. -If JUSTIFY is non-nil, each line is justified as well. -If POSTFIX and JUSTIFY are non-nil, `ada-fill-comment-postfix' is appended -to each filled and justified line. -If `ada-indent-comment-as-code' is non-nil, the paragraph is idented." - (interactive "P") - (let ((opos (point-marker)) - (begin nil) - (end nil) - (end-2 nil) - (indent nil) - (ada-fill-comment-old-postfix "") - (fill-prefix nil)) - - ;; check if inside comment - (if (not (ada-in-comment-p)) - (error "not inside comment")) - - ;; prompt for postfix if wanted - (if (and justify - postfix) - (setq ada-fill-comment-postfix - (read-from-minibuffer "enter new postfix string: " - ada-fill-comment-postfix))) - - ;; prompt for old postfix to remove if necessary - (if (and justify - postfix) - (setq ada-fill-comment-old-postfix - (read-from-minibuffer "enter already existing postfix string: " - ada-fill-comment-postfix))) - - ;; - ;; find limits of paragraph - ;; - (message "filling comment paragraph ...") - (save-excursion - (back-to-indentation) - ;; find end of paragraph - (while (and (looking-at "--.*$") - (not (looking-at "--[ \t]*$"))) - (forward-line 1) - (back-to-indentation)) - (beginning-of-line) - (setq end (point-marker)) - (goto-char opos) - ;; find begin of paragraph - (back-to-indentation) - (while (and (looking-at "--.*$") - (not (looking-at "--[ \t]*$"))) - (forward-line -1) - (back-to-indentation)) - (forward-line 1) - ;; get indentation to calculate width for filling - (ada-indent-current) - (back-to-indentation) - (setq indent (current-column)) - (setq begin (point-marker))) - - ;; delete old postfix if necessary - (if (and justify - postfix) - (save-excursion - (goto-char begin) - (while (re-search-forward (concat ada-fill-comment-old-postfix - "\n") - end t) - (replace-match "\n")))) - - ;; delete leading whitespace and uncomment - (save-excursion - (goto-char begin) - (beginning-of-line) - (while (re-search-forward "^[ \t]*--[ \t]*" end t) - (replace-match ""))) - - ;; calculate fill width - (setq fill-column (- fill-column indent - (length ada-fill-comment-prefix) - (if postfix - (length ada-fill-comment-postfix) - 0))) - ;; fill paragraph - (fill-region begin (1- end) justify) - (setq fill-column (+ fill-column indent - (length ada-fill-comment-prefix) - (if postfix - (length ada-fill-comment-postfix) - 0))) - ;; find end of second last line - (save-excursion - (goto-char end) - (forward-line -2) - (end-of-line) - (setq end-2 (point-marker))) - - ;; re-comment and re-indent region - (save-excursion - (goto-char begin) - (indent-to indent) - (insert ada-fill-comment-prefix) - (while (re-search-forward "\n" (1- end-2) t) - (replace-match (concat "\n" ada-fill-comment-prefix)) - (beginning-of-line) - (indent-to indent))) - - ;; append postfix if wanted - (if (and justify - postfix - ada-fill-comment-postfix) - (progn - ;; append postfix up to there - (save-excursion - (goto-char begin) - (while (re-search-forward "\n" (1- end-2) t) - (replace-match (concat ada-fill-comment-postfix "\n"))) - - ;; fill last line and append postfix - (end-of-line) - (insert-char ? - (- fill-column - (current-column) - (length ada-fill-comment-postfix))) - (insert ada-fill-comment-postfix)))) - - ;; delete the extra line that gets inserted somehow(??) - (save-excursion - (goto-char (1- end)) - (end-of-line) - (delete-char 1)) - - (message "filling comment paragraph ... done") - (goto-char opos)) - t) - - -;;;--------------------------------;;; -;;; Call External Pretty Printer ;;; -;;;--------------------------------;;; - -(defun ada-call-pretty-printer () - "Calls the external Pretty Printer. -The name is specified in `ada-external-pretty-print-program'. Saves the -current buffer in a directory specified by `ada-tmp-directory', -starts the pretty printer as external process on that file and then -reloads the beautified program in the buffer and cleans up -`ada-tmp-directory'." - (interactive) - (let ((filename-with-path buffer-file-name) - (curbuf (current-buffer)) - (orgpos (point)) - (mesgbuf nil) ;; for byte-compiling - (file-path (file-name-directory buffer-file-name)) - (filename-without-path (file-name-nondirectory buffer-file-name)) - (tmp-file-with-directory - (concat ada-tmp-directory - (file-name-nondirectory buffer-file-name)))) - ;; - ;; save buffer in temporary file - ;; - (message "saving current buffer to temporary file ...") - (write-file tmp-file-with-directory) - (auto-save-mode nil) - (message "saving current buffer to temporary file ... done") - ;; - ;; call external pretty printer program - ;; - - (message "running external pretty printer ...") - ;; create a temporary buffer for messages of pretty printer - (setq mesgbuf (get-buffer-create "Pretty Printer Messages")) - ;; execute pretty printer on temporary file - (call-process ada-external-pretty-print-program - nil mesgbuf t - tmp-file-with-directory) - ;; display messages if there are some - (if (buffer-modified-p mesgbuf) - ;; show the message buffer - (display-buffer mesgbuf t) - ;; kill the message buffer - (kill-buffer mesgbuf)) - (message "running external pretty printer ... done") - ;; - ;; kill current buffer and load pretty printer output - ;; or restore old buffer - ;; - (if (y-or-n-p - "Really replace current buffer with pretty printer output ? ") - (progn - (set-buffer-modified-p nil) - (kill-buffer curbuf) - (find-file tmp-file-with-directory)) - (message "old buffer contents restored")) - ;; - ;; delete temporary file and restore information of current buffer - ;; - (delete-file tmp-file-with-directory) - (set-visited-file-name filename-with-path) - (auto-save-mode t) - (goto-char orgpos))) - - -;;;--------------- -;;; auto-casing -;;;--------------- - -;; from Philippe Waroquiers <philippe@cfmu.eurocontrol.be> -;; modified by RE and MH - -(defun ada-after-keyword-p () - ;; returns t if cursor is after a keyword. - (save-excursion - (forward-word -1) - (and (save-excursion - (or - (= (point) (point-min)) - (backward-char 1)) - (not (looking-at "_"))) ; (MH) - (looking-at (concat ada-keywords "[^_]"))))) - -(defun ada-in-char-const-p () - ;; Returns t if point is inside a character constant. - ;; We assume to be in a constant if the previous and the next character - ;; are "'". - (save-excursion - (if (> (point) 1) - (and - (progn - (forward-char 1) - (looking-at "'")) - (progn - (forward-char -2) - (looking-at "'"))) - nil))) - - -(defun ada-adjust-case (&optional force-identifier) - "Adjust the case of the word before the just typed character. -Respect options `ada-case-keyword', `ada-case-identifier', and -`ada-case-attribute'. -If FORCE-IDENTIFIER is non-nil then also adjust keyword as identifier." ; (MH) - (forward-char -1) - (if (and (> (point) 1) (not (or (ada-in-string-p) - (ada-in-comment-p) - (ada-in-char-const-p)))) - (if (eq (char-syntax (char-after (1- (point)))) ?w) - (if (save-excursion - (forward-word -1) - (or (= (point) (point-min)) - (backward-char 1)) - (looking-at "'")) - (funcall ada-case-attribute -1) - (if (and - (not force-identifier) ; (MH) - (ada-after-keyword-p)) - (funcall ada-case-keyword -1) - (funcall ada-case-identifier -1))))) - (forward-char 1)) - - -(defun ada-adjust-case-interactive (arg) - (interactive "P") - (let ((lastk last-command-char)) - (cond ((or (eq lastk ?\n) - (eq lastk ?\r)) - ;; horrible kludge - (insert " ") - (ada-adjust-case) - ;; horrible dekludge - (delete-backward-char 1) - ;; some special keys and their bindings - (cond - ((eq lastk ?\n) - (funcall ada-lfd-binding)) - ((eq lastk ?\r) - (funcall ada-ret-binding)))) - ((eq lastk ?\C-i) (ada-tab)) - ((self-insert-command (prefix-numeric-value arg)))) - ;; if there is a keyword in front of the underscore - ;; then it should be part of an identifier (MH) - (if (eq lastk ?_) - (ada-adjust-case t) - (ada-adjust-case)))) - - -(defun ada-activate-keys-for-case () - ;; save original keybindings to allow swapping ret/lfd - ;; when casing is activated - ;; the 'or ...' is there to be sure that the value will not - ;; be changed again when Ada mode is called more than once (MH) - (or ada-ret-binding - (setq ada-ret-binding (key-binding "\C-M"))) - (or ada-lfd-binding - (setq ada-lfd-binding (key-binding "\C-j"))) - ;; call case modifying function after certain keys. - (mapcar (function (lambda(key) (define-key - ada-mode-map - (char-to-string key) - 'ada-adjust-case-interactive))) - '( ?` ?~ ?! ?@ ?# ?$ ?% ?^ ?& ?* ?( ?) ?- ?= ?+ ?[ ?{ ?] ?} - ?_ ?\\ ?| ?\; ?: ?' ?\" ?< ?, ?. ?> ?? ?/ ?\n 32 ?\r ))) -;; deleted ?\t from above list - -;; -;; added by MH -;; -(defun ada-loose-case-word (&optional arg) - "Capitalizes the first letter and the letters following `_'. -ARG is ignored, it's there to fit the standard casing functions' style." - (let ((pos (point)) - (first t)) - (skip-chars-backward "a-zA-Z0-9_") - (while (or first - (search-forward "_" pos t)) - (and first - (setq first nil)) - (insert-char (upcase (following-char)) 1) - (delete-char 1)) - (goto-char pos))) - - -;; -;; added by MH -;; modified by JSH to handle attributes -;; -(defun ada-adjust-case-region (from to) - "Adjusts the case of all words in the region. -Attention: This function might take very long for big regions !" - (interactive "*r") - (let ((begin nil) - (end nil) - (keywordp nil) - (attribp nil)) - (unwind-protect - (save-excursion - (set-syntax-table ada-mode-symbol-syntax-table) - (goto-char to) - ;; - ;; loop: look for all identifiers, keywords, and attributes - ;; - (while (re-search-backward - "[^a-zA-Z0-9_]\\([a-zA-Z0-9_]+\\)[^a-zA-Z0-9_]" - from - t) - ;; - ;; print status message - ;; - (message "adjusting case ... %5d characters left" (- (point) from)) - (setq attribp (looking-at "'[a-zA-Z0-9_]+[^']")) - (forward-char 1) - (or - ;; do nothing if it is a string or comment - (ada-in-string-or-comment-p) - (progn - ;; - ;; get the identifier or keyword or attribute - ;; - (setq begin (point)) - (setq keywordp (looking-at (concat ada-keywords "[^_]"))) - (skip-chars-forward "a-zA-Z0-9_") - ;; - ;; casing according to user-option - ;; - (if keywordp - (funcall ada-case-keyword -1) - (if attribp - (funcall ada-case-attribute -1) - (funcall ada-case-identifier -1))) - (goto-char begin)))) - (message "adjusting case ... done")) - (set-syntax-table ada-mode-syntax-table)))) - - -;; -;; added by MH -;; -(defun ada-adjust-case-buffer () - "Adjusts the case of all words in the whole buffer. -ATTENTION: This function might take very long for big buffers !" - (interactive "*") - (ada-adjust-case-region (point-min) (point-max))) - - -;;;------------------------;;; -;;; Format Parameter Lists ;;; -;;;------------------------;;; - -(defun ada-format-paramlist () - "Reformats a parameter list. -ATTENTION: 1) Comments inside the list are killed ! - 2) If the syntax is not correct (especially, if there are - semicolons missing), it can get totally confused ! -In such a case, use `undo', correct the syntax and try again." - - (interactive) - (let ((begin nil) - (end nil) - (delend nil) - (paramlist nil)) - (unwind-protect - (progn - (set-syntax-table ada-mode-symbol-syntax-table) - - ;; check if really inside parameter list - (or (ada-in-paramlist-p) - (error "not in parameter list")) - ;; - ;; find start of current parameter-list - ;; - (ada-search-ignore-string-comment - (concat ada-subprog-start-re "\\|\\<body\\>" ) t nil) - (ada-search-ignore-string-comment "(" nil nil t) - (backward-char 1) - (setq begin (point)) - - ;; - ;; find end of parameter-list - ;; - (forward-sexp 1) - (setq delend (point)) - (delete-char -1) - - ;; - ;; find end of last parameter-declaration - ;; - (ada-search-ignore-string-comment "[^ \t\n]" t nil t) - (forward-char 1) - (setq end (point)) - - ;; - ;; build a list of all elements of the parameter-list - ;; - (setq paramlist (ada-scan-paramlist (1+ begin) end)) - - ;; - ;; delete the original parameter-list - ;; - (delete-region begin (1- delend)) - - ;; - ;; insert the new parameter-list - ;; - (goto-char begin) - (ada-insert-paramlist paramlist)) - - ;; - ;; restore syntax-table - ;; - (set-syntax-table ada-mode-syntax-table) - ))) - - -(defun ada-scan-paramlist (begin end) - ;; Scans a parameter-list between BEGIN and END and returns a list - ;; of its contents. - ;; The list has the following format: - ;; - ;; Name of Param in? out? access? Name of Type Default-Exp or nil - ;; - ;; ( ('Name_Param_1' t nil t Type_Param_1 ':= expression') - ;; ('Name_Param_2' nil nil t Type_Param_2 nil) ) - - (let ((paramlist (list)) - (param (list)) - (notend t) - (apos nil) - (epos nil) - (semipos nil) - (match-cons nil)) - - (goto-char begin) - ;; - ;; loop until end of last parameter - ;; - (while notend - - ;; - ;; find first character of parameter-declaration - ;; - (ada-goto-next-non-ws) - (setq apos (point)) - - ;; - ;; find last character of parameter-declaration - ;; - (if (setq match-cons - (ada-search-ignore-string-comment "[ \t\n]*;" nil end t)) - (progn - (setq epos (car match-cons)) - (setq semipos (cdr match-cons))) - (setq epos end)) - - ;; - ;; read name(s) of parameter(s) - ;; - (goto-char apos) - (looking-at "\\([a-zA-Z0-9_, \t\n]*[a-zA-Z0-9_]\\)[ \t\n]*:[^=]") - - (setq param (list (buffer-substring (match-beginning 1) - (match-end 1)))) - (ada-search-ignore-string-comment ":" nil epos t) - - ;; - ;; look for 'in' - ;; - (setq apos (point)) - (setq param - (append param - (list - (consp - (ada-search-ignore-string-comment "\\<in\\>" - nil - epos - t))))) - - ;; - ;; look for 'out' - ;; - (goto-char apos) - (setq param - (append param - (list - (consp - (ada-search-ignore-string-comment "\\<out\\>" - nil - epos - t))))) - - ;; - ;; look for 'access' - ;; - (goto-char apos) - (setq param - (append param - (list - (consp - (ada-search-ignore-string-comment "\\<access\\>" - nil - epos - t))))) - - ;; - ;; skip 'in'/'out'/'access' - ;; - (goto-char apos) - (ada-goto-next-non-ws) - (while (looking-at "\\<\\(in\\|out\\|access\\)\\>") - (forward-word 1) - (ada-goto-next-non-ws)) - - ;; - ;; read type of parameter - ;; - (looking-at "\\<[a-zA-Z0-9_\\.\\']+\\>") - (setq param - (append param - (list - (buffer-substring (match-beginning 0) - (match-end 0))))) - - ;; - ;; read default-expression, if there is one - ;; - (goto-char (setq apos (match-end 0))) - (setq param - (append param - (list - (if (setq match-cons - (ada-search-ignore-string-comment ":=" - nil - epos - t)) - (buffer-substring (car match-cons) - epos) - nil)))) - ;; - ;; add this parameter-declaration to the list - ;; - (setq paramlist (append paramlist (list param))) - - ;; - ;; check if it was the last parameter - ;; - (if (eq epos end) - (setq notend nil) - (goto-char semipos)) - - ) ; end of loop - - (reverse paramlist))) - - -(defun ada-insert-paramlist (paramlist) - ;; Inserts a formatted PARAMLIST in the buffer. - ;; See doc of `ada-scan-paramlist' for the format. - (let ((i (length paramlist)) - (parlen 0) - (typlen 0) - (temp 0) - (inp nil) - (outp nil) - (accessp nil) - (column nil) - (orgpoint 0) - (firstcol nil)) - - ;; - ;; loop until last parameter - ;; - (while (not (zerop i)) - (setq i (1- i)) - - ;; - ;; get max length of parameter-name - ;; - (setq parlen - (if (<= parlen (setq temp - (length (nth 0 (nth i paramlist))))) - temp - parlen)) - - ;; - ;; get max length of type-name - ;; - (setq typlen - (if (<= typlen (setq temp - (length (nth 4 (nth i paramlist))))) - temp - typlen)) - - ;; - ;; is there any 'in' ? - ;; - (setq inp - (or inp - (nth 1 (nth i paramlist)))) - - ;; - ;; is there any 'out' ? - ;; - (setq outp - (or outp - (nth 2 (nth i paramlist)))) - - ;; - ;; is there any 'access' ? - ;; - (setq accessp - (or accessp - (nth 3 (nth i paramlist))))) ; end of loop - - ;; - ;; does paramlist already start on a separate line ? - ;; - (if (save-excursion - (re-search-backward "^.\\|[^ \t]" nil t) - (looking-at "^.")) - ;; yes => re-indent it - (ada-indent-current) - ;; - ;; no => insert newline and indent it - ;; - (progn - (ada-indent-current) - (newline) - (delete-horizontal-space) - (setq orgpoint (point)) - (setq column (save-excursion - (funcall (ada-indent-function) orgpoint))) - (indent-to column) - )) - - (insert "(") - - (setq firstcol (current-column)) - (setq i (length paramlist)) - - ;; - ;; loop until last parameter - ;; - (while (not (zerop i)) - (setq i (1- i)) - (setq column firstcol) - - ;; - ;; insert parameter-name, space and colon - ;; - (insert (nth 0 (nth i paramlist))) - (indent-to (+ column parlen 1)) - (insert ": ") - (setq column (current-column)) - - ;; - ;; insert 'in' or space - ;; - (if (nth 1 (nth i paramlist)) - (insert "in ") - (if (and - (or inp - accessp) - (not (nth 3 (nth i paramlist)))) - (insert " "))) - - ;; - ;; insert 'out' or space - ;; - (if (nth 2 (nth i paramlist)) - (insert "out ") - (if (and - (or outp - accessp) - (not (nth 3 (nth i paramlist)))) - (insert " "))) - - ;; - ;; insert 'access' - ;; - (if (nth 3 (nth i paramlist)) - (insert "access ")) - - (setq column (current-column)) - - ;; - ;; insert type-name and, if necessary, space and default-expression - ;; - (insert (nth 4 (nth i paramlist))) - (if (nth 5 (nth i paramlist)) - (progn - (indent-to (+ column typlen 1)) - (insert (nth 5 (nth i paramlist))))) - - ;; - ;; check if it was the last parameter - ;; - (if (not (zerop i)) - ;; no => insert ';' and newline and indent - (progn - (insert ";") - (newline) - (indent-to firstcol)) - ;; yes - (insert ")")) - - ) ; end of loop - - ;; - ;; if anything follows, except semicolon: - ;; put it in a new line and indent it - ;; - (if (not (looking-at "[ \t]*[;\n]")) - (ada-indent-newline-indent)) - - )) - - -;;;----------------------------;;; -;;; Move To Matching Start/End ;;; -;;;----------------------------;;; - -(defun ada-move-to-start () - "Moves point to the matching start of the current Ada structure." - (interactive) - (let ((pos (point))) - (unwind-protect - (progn - (set-syntax-table ada-mode-symbol-syntax-table) - - (message "searching for block start ...") - (save-excursion - ;; - ;; do nothing if in string or comment or not on 'end ...;' - ;; or if an error occurs during processing - ;; - (or - (ada-in-string-or-comment-p) - (and (progn - (or (looking-at "[ \t]*\\<end\\>") - (backward-word 1)) - (or (looking-at "[ \t]*\\<end\\>") - (backward-word 1)) - (or (looking-at "[ \t]*\\<end\\>") - (error "not on end ...;"))) - (ada-goto-matching-start 1) - (setq pos (point)) - - ;; - ;; on 'begin' => go on, according to user option - ;; - ada-move-to-declaration - (looking-at "\\<begin\\>") - (ada-goto-matching-decl-start) - (setq pos (point)))) - - ) ; end of save-excursion - - ;; now really move to the found position - (goto-char pos) - (message "searching for block start ... done")) - - ;; - ;; restore syntax-table - ;; - (set-syntax-table ada-mode-syntax-table)))) - - -(defun ada-move-to-end () - "Moves point to the matching end of the current block around point. -Moves to 'begin' if in a declarative part." - (interactive) - (let ((pos (point)) - (decstart nil) - (packdecl nil)) - (unwind-protect - (progn - (set-syntax-table ada-mode-symbol-syntax-table) - - (message "searching for block end ...") - (save-excursion - - (forward-char 1) - (cond - ;; directly on 'begin' - ((save-excursion - (ada-goto-previous-word) - (looking-at "\\<begin\\>")) - (ada-goto-matching-end 1)) - ;; on first line of defun declaration - ((save-excursion - (and (ada-goto-stmt-start) - (looking-at "\\<function\\>\\|\\<procedure\\>" ))) - (ada-search-ignore-string-comment "\\<begin\\>")) - ;; on first line of task declaration - ((save-excursion - (and (ada-goto-stmt-start) - (looking-at "\\<task\\>" ) - (forward-word 1) - (ada-search-ignore-string-comment "[^ \n\t]") - (not (backward-char 1)) - (looking-at "\\<body\\>"))) - (ada-search-ignore-string-comment "\\<begin\\>")) - ;; accept block start - ((save-excursion - (and (ada-goto-stmt-start) - (looking-at "\\<accept\\>" ))) - (ada-goto-matching-end 0)) - ;; package start - ((save-excursion - (and (ada-goto-matching-decl-start t) - (looking-at "\\<package\\>"))) - (ada-goto-matching-end 1)) - ;; inside a 'begin' ... 'end' block - ((save-excursion - (ada-goto-matching-decl-start t)) - (ada-search-ignore-string-comment "\\<begin\\>")) - ;; (hopefully ;-) everything else - (t - (ada-goto-matching-end 1))) - (setq pos (point)) - - ) ; end of save-excursion - - ;; now really move to the found position - (goto-char pos) - (message "searching for block end ... done")) - - ;; - ;; restore syntax-table - ;; - (set-syntax-table ada-mode-syntax-table)))) - - -;;;-----------------------------;;; -;;; Functions For Indentation ;;; -;;;-----------------------------;;; - -;; ---- main functions for indentation - -(defun ada-indent-region (beg end) - "Indents the region using `ada-indent-current' on each line." - (interactive "*r") - (goto-char beg) - (let ((block-done 0) - (lines-remaining (count-lines beg end)) - (msg (format "indenting %4d lines %%4d lines remaining ..." - (count-lines beg end))) - (endmark (copy-marker end))) - ;; catch errors while indenting - (condition-case err - (while (< (point) endmark) - (if (> block-done 9) - (progn (message msg lines-remaining) - (setq block-done 0))) - (if (looking-at "^$") nil - (ada-indent-current)) - (forward-line 1) - (setq block-done (1+ block-done)) - (setq lines-remaining (1- lines-remaining))) - ;; show line number where the error occurred - (error - (error "line %d: %s" (1+ (count-lines (point-min) (point))) err) nil)) - (message "indenting ... done"))) - - -(defun ada-indent-newline-indent () - "Indents the current line, inserts a newline and then indents the new line." - (interactive "*") - (ada-indent-current) - (newline) - (ada-indent-current)) - - -(defun ada-indent-current () - "Indents current line as Ada code. -This works by two steps: - 1) It moves point to the end of the previous code line. - Then it calls the function to calculate the indentation for the - following line as if a newline would be inserted there. - The calculated column # is saved and the old position of point - is restored. - 2) Then another function is called to calculate the indentation for - the current line, based on the previously calculated column #." - - (interactive) - - (unwind-protect - (progn - (set-syntax-table ada-mode-symbol-syntax-table) - - (let ((line-end) - (orgpoint (point-marker)) - (cur-indent) - (prev-indent) - (prevline t)) - - ;; - ;; first step - ;; - (save-excursion - (if (ada-goto-prev-nonblank-line t) - ;; - ;; we are not in the first accessible line in the buffer - ;; - (progn - ;;(end-of-line) - ;;(forward-char 1) - ;; we are already at the BOL - (forward-line 1) - (setq line-end (point)) - (setq prev-indent - (save-excursion - (funcall (ada-indent-function) line-end)))) - (progn ; first line of buffer -> set indent - (beginning-of-line) ; to 0 - (delete-horizontal-space) - (setq prevline nil)))) - - (if prevline - ;; - ;; we are not in the first accessible line in the buffer - ;; - (progn - ;; - ;; second step - ;; - (back-to-indentation) - (setq cur-indent (ada-get-current-indent prev-indent)) - ;; only reindent if indentation is different then the current - (if (= (current-column) cur-indent) - nil - (delete-horizontal-space) - (indent-to cur-indent)) - ;; - ;; restore position of point - ;; - (goto-char orgpoint) - (if (< (current-column) (current-indentation)) - (back-to-indentation)))))) - - ;; - ;; restore syntax-table - ;; - (set-syntax-table ada-mode-syntax-table))) - - -(defun ada-get-current-indent (prev-indent) - ;; Returns the column # to indent the current line to. - ;; PREV-INDENT is the indentation resulting from the previous lines. - (let ((column nil) - (pos nil) - (match-cons nil)) - - (cond - ;; - ;; in open parenthesis, but not in parameter-list - ;; - ((and - ada-indent-to-open-paren - (not (ada-in-paramlist-p)) - (setq column (ada-in-open-paren-p))) - ;; check if we have something like this (Table_Component_Type => - ;; Source_File_Record,) - (save-excursion - (if (and (ada-search-ignore-string-comment "[^ \t]" t nil) - (looking-at "\n") - (ada-search-ignore-string-comment "[^ \t\n]" t nil) - (looking-at ">")) - (setq column (+ ada-broken-indent column)))) - column) - - ;; - ;; end - ;; - ((looking-at "\\<end\\>") - (let ((label 0)) - (save-excursion - (ada-goto-matching-start 1) - - ;; - ;; found 'loop' => skip back to 'while' or 'for' - ;; if 'loop' is not on a separate line - ;; - (if (and - (looking-at "\\<loop\\>") - (save-excursion - (back-to-indentation) - (not (looking-at "\\<loop\\>")))) - (if (save-excursion - (and - (setq match-cons - (ada-search-ignore-string-comment - ada-loop-start-re t nil)) - (not (looking-at "\\<loop\\>")))) - (progn - (goto-char (car match-cons)) - (save-excursion - (beginning-of-line) - (if (looking-at ada-named-block-re) - (setq label (- ada-label-indent))))))) - - (+ (current-indentation) label)))) - ;; - ;; exception - ;; - ((looking-at "\\<exception\\>") - (save-excursion - (ada-goto-matching-start 1) - (current-indentation))) - ;; - ;; when - ;; - ((looking-at "\\<when\\>") - (save-excursion - (ada-goto-matching-start 1) - (+ (current-indentation) ada-when-indent))) - ;; - ;; else - ;; - ((looking-at "\\<else\\>") - (if (save-excursion - (ada-goto-previous-word) - (looking-at "\\<or\\>")) - prev-indent - (save-excursion - (ada-goto-matching-start 1 nil t) - (current-indentation)))) - ;; - ;; elsif - ;; - ((looking-at "\\<elsif\\>") - (save-excursion - (ada-goto-matching-start 1 nil t) - (current-indentation))) - ;; - ;; then - ;; - ((looking-at "\\<then\\>") - (if (save-excursion - (ada-goto-previous-word) - (looking-at "\\<and\\>")) - prev-indent - (save-excursion - (ada-search-ignore-string-comment "\\<elsif\\>\\|\\<if\\>" t nil) - (+ (current-indentation) ada-stmt-end-indent)))) - ;; - ;; loop - ;; - ((looking-at "\\<loop\\>") - (setq pos (point)) - (save-excursion - (goto-char (match-end 0)) - (ada-goto-stmt-start) - (if (looking-at "\\<loop\\>\\|\\<if\\>") - prev-indent - (progn - (if (not (looking-at ada-loop-start-re)) - (ada-search-ignore-string-comment ada-loop-start-re - nil pos)) - (if (looking-at "\\<loop\\>") - prev-indent - (+ (current-indentation) ada-stmt-end-indent)))))) - ;; - ;; begin - ;; - ((looking-at "\\<begin\\>") - (save-excursion - (if (ada-goto-matching-decl-start t) - (current-indentation) - prev-indent))) - ;; - ;; is - ;; - ((looking-at "\\<is\\>") - (if (and - ada-indent-is-separate - (save-excursion - (goto-char (match-end 0)) - (ada-goto-next-non-ws (save-excursion - (end-of-line) - (point))) - (looking-at "\\<abstract\\>\\|\\<separate\\>"))) - (save-excursion - (ada-goto-stmt-start) - (+ (current-indentation) ada-indent)) - (save-excursion - (ada-goto-stmt-start) - (+ (current-indentation) ada-stmt-end-indent)))) - ;; - ;; record - ;; - ((looking-at "\\<record\\>") - (save-excursion - (ada-search-ignore-string-comment - "\\<\\(type\\|use\\)\\>" t nil) - (if (looking-at "\\<use\\>") - (ada-search-ignore-string-comment "\\<for\\>" t nil)) - (+ (current-indentation) ada-indent-record-rel-type))) - ;; - ;; or as statement-start - ;; - ((ada-looking-at-semi-or) - (save-excursion - (ada-goto-matching-start 1) - (current-indentation))) - ;; - ;; private as statement-start - ;; - ((ada-looking-at-semi-private) - (save-excursion - (ada-goto-matching-decl-start) - (current-indentation))) - ;; - ;; new/abstract/separate - ;; - ((looking-at "\\<\\(new\\|abstract\\|separate\\)\\>") - (- prev-indent ada-indent (- ada-broken-indent))) - ;; - ;; return - ;; - ((looking-at "\\<return\\>") - (save-excursion - (forward-sexp -1) - (if (and (looking-at "(") - (save-excursion - (backward-sexp 2) - (looking-at "\\<function\\>"))) - (1+ (current-column)) - prev-indent))) - ;; - ;; do - ;; - ((looking-at "\\<do\\>") - (save-excursion - (ada-goto-stmt-start) - (+ (current-indentation) ada-stmt-end-indent))) - ;; - ;; package/function/procedure - ;; - ((and (looking-at "\\<\\(package\\|function\\|procedure\\)\\>") - (save-excursion - (forward-char 1) - (ada-goto-stmt-start) - (looking-at "\\<\\(package\\|function\\|procedure\\)\\>"))) - (save-excursion - ;; look for 'generic' - (if (and (ada-goto-matching-decl-start t) - (looking-at "generic")) - (current-column) - prev-indent))) - ;; - ;; label - ;; - ((looking-at "\\<[a-zA-Z0-9_]+[ \t\n]*:[^=]") - (if (ada-in-decl-p) - prev-indent - (+ prev-indent ada-label-indent))) - ;; - ;; identifier and other noindent-statements - ;; - ((looking-at "\\<[a-zA-Z0-9_]+[ \t\n]*") - prev-indent) - ;; - ;; beginning of a parameter list - ;; - ((looking-at "(") - prev-indent) - ;; - ;; end of a parameter list - ;; - ((looking-at ")") - (save-excursion - (forward-char 1) - (backward-sexp 1) - (current-column))) - ;; - ;; comment - ;; - ((looking-at "--") - (if ada-indent-comment-as-code - prev-indent - (current-indentation))) - ;; - ;; unknown syntax - maybe this should signal an error ? - ;; - (t - prev-indent)))) - - -(defun ada-indent-function (&optional nomove) - ;; Returns the function to calculate the indentation for the current - ;; line according to the previous statement, ignoring the contents - ;; of the current line after point. Moves point to the beginning of - ;; the current statement, if NOMOVE is nil. - - (let ((orgpoint (point)) - (func nil)) - ;; - ;; inside a parameter-list - ;; - (if (ada-in-paramlist-p) - (setq func 'ada-get-indent-paramlist) - (progn - ;; - ;; move to beginning of current statement - ;; - (if (not nomove) - (ada-goto-stmt-start)) - ;; - ;; no beginning found => don't change indentation - ;; - (if (and - (eq orgpoint (point)) - (not nomove)) - (setq func 'ada-get-indent-nochange) - - (cond - ;; - ((and - ada-indent-to-open-paren - (ada-in-open-paren-p)) - (setq func 'ada-get-indent-open-paren)) - ;; - ((looking-at "\\<end\\>") - (setq func 'ada-get-indent-end)) - ;; - ((looking-at ada-loop-start-re) - (setq func 'ada-get-indent-loop)) - ;; - ((looking-at ada-subprog-start-re) - (setq func 'ada-get-indent-subprog)) - ;; - ((looking-at ada-block-start-re) - (setq func 'ada-get-indent-block-start)) - ;; - ((looking-at "\\<type\\>") - (setq func 'ada-get-indent-type)) - ;; - ((looking-at "\\<\\(els\\)?if\\>") - (setq func 'ada-get-indent-if)) - ;; - ((looking-at "\\<case\\>") - (setq func 'ada-get-indent-case)) - ;; - ((looking-at "\\<when\\>") - (setq func 'ada-get-indent-when)) - ;; - ((looking-at "--") - (setq func 'ada-get-indent-comment)) - ;; - ((looking-at "[a-zA-Z0-9_]+[ \t\n]*:[^=]") - (setq func 'ada-get-indent-label)) - ;; - ((looking-at "\\<separate\\>") - (setq func 'ada-get-indent-nochange)) - (t - (setq func 'ada-get-indent-noindent)))))) - - func)) - - -;; ---- functions to return indentation for special cases - -(defun ada-get-indent-open-paren (orgpoint) - ;; Returns the indentation (column #) for the new line after ORGPOINT. - ;; Assumes point to be behind an open parenthesis not yet closed. - (ada-in-open-paren-p)) - - -(defun ada-get-indent-nochange (orgpoint) - ;; Returns the indentation (column #) of the current line. - (save-excursion - (forward-line -1) - (current-indentation))) - - -(defun ada-get-indent-paramlist (orgpoint) - ;; Returns the indentation (column #) for the new line after ORGPOINT. - ;; Assumes point to be inside a parameter-list. - (save-excursion - (ada-search-ignore-string-comment "[^ \t\n]" t nil t) - (cond - ;; - ;; in front of the first parameter - ;; - ((looking-at "(") - (goto-char (match-end 0)) - (current-column)) - ;; - ;; in front of another parameter - ;; - ((looking-at ";") - (goto-char (cdr (ada-search-ignore-string-comment "(\\|;" t nil t))) - (ada-goto-next-non-ws) - (current-column)) - ;; - ;; inside a parameter declaration - ;; - (t - (goto-char (cdr (ada-search-ignore-string-comment "(\\|;" t nil t))) - (ada-goto-next-non-ws) - (+ (current-column) ada-broken-indent))))) - - -(defun ada-get-indent-end (orgpoint) - ;; Returns the indentation (column #) for the new line after ORGPOINT. - ;; Assumes point to be at the beginning of an end-statement. - ;; Therefore it has to find the corresponding start. This can be a little - ;; slow, if it has to search through big files with many nested blocks. - ;; Signals an error if the corresponding block-start doesn't match. - (let ((defun-name nil) - (label 0) - (indent nil)) - ;; - ;; is the line already terminated by ';' ? - ;; - (if (save-excursion - (ada-search-ignore-string-comment ";" nil orgpoint)) - ;; - ;; yes, look what's following 'end' - ;; - (progn - (forward-word 1) - (ada-goto-next-non-ws) - (cond - ;; - ;; loop/select/if/case/record/select - ;; - ((looking-at "\\<\\(loop\\|select\\|if\\|case\\|record\\)\\>") - (save-excursion - (ada-check-matching-start - (buffer-substring (match-beginning 0) - (match-end 0))) - (if (looking-at "\\<\\(loop\\|record\\)\\>") - (progn - (forward-word 1) - (ada-goto-stmt-start))) - ;; a label ? => skip it - (if (looking-at ada-named-block-re) - (progn - (setq label (- ada-label-indent)) - (goto-char (match-end 0)) - (ada-goto-next-non-ws))) - ;; really looking-at the right thing ? - (or (looking-at (concat "\\<\\(" - "loop\\|select\\|if\\|case\\|" - "record\\|while\\|type\\)\\>")) - (progn - (ada-search-ignore-string-comment - (concat "\\<\\(" - "loop\\|select\\|if\\|case\\|" - "record\\|while\\|type\\)\\>"))) - (backward-word 1)) - (+ (current-indentation) label))) - ;; - ;; a named block end - ;; - ((looking-at ada-ident-re) - (setq defun-name (buffer-substring (match-beginning 0) - (match-end 0))) - (save-excursion - (ada-goto-matching-start 0) - (ada-check-defun-name defun-name) - (current-indentation))) - ;; - ;; a block-end without name - ;; - ((looking-at ";") - (save-excursion - (ada-goto-matching-start 0) - (if (looking-at "\\<begin\\>") - (progn - (setq indent (current-column)) - (if (ada-goto-matching-decl-start t) - (current-indentation) - indent))))) - ;; - ;; anything else - should maybe signal an error ? - ;; - (t - (+ (current-indentation) ada-broken-indent)))) - - (+ (current-indentation) ada-broken-indent)))) - - -(defun ada-get-indent-case (orgpoint) - ;; Returns the indentation (column #) for the new line after ORGPOINT. - ;; Assumes point to be at the beginning of a case-statement. - (let ((cur-indent (current-indentation)) - (match-cons nil) - (opos (point))) - (cond - ;; - ;; case..is..when..=> - ;; - ((save-excursion - (setq match-cons (and - ;; the `=>' must be after the keyword `is'. - (ada-search-ignore-string-comment - "\\<is\\>" nil orgpoint) - (ada-search-ignore-string-comment - "[ \t\n]+=>" nil orgpoint)))) - (save-excursion - (goto-char (car match-cons)) - (if (not (ada-search-ignore-string-comment "\\<when\\>" t opos)) - (error "missing 'when' between 'case' and '=>'")) - (+ (current-indentation) ada-indent))) - ;; - ;; case..is..when - ;; - ((save-excursion - (setq match-cons (ada-search-ignore-string-comment - "\\<when\\>" nil orgpoint))) - (goto-char (cdr match-cons)) - (+ (current-indentation) ada-broken-indent)) - ;; - ;; case..is - ;; - ((save-excursion - (setq match-cons (ada-search-ignore-string-comment - "\\<is\\>" nil orgpoint))) - (+ (current-indentation) ada-when-indent)) - ;; - ;; incomplete case - ;; - (t - (+ (current-indentation) ada-broken-indent))))) - - -(defun ada-get-indent-when (orgpoint) - ;; Returns the indentation (column #) for the new line after ORGPOINT. - ;; Assumes point to be at the beginning of an when-statement. - (let ((cur-indent (current-indentation))) - (if (ada-search-ignore-string-comment - "[ \t\n]+=>" nil orgpoint) - (+ cur-indent ada-indent) - (+ cur-indent ada-broken-indent)))) - - -(defun ada-get-indent-if (orgpoint) - ;; Returns the indentation (column #) for the new line after ORGPOINT. - ;; Assumes point to be at the beginning of an if-statement. - (let ((cur-indent (current-indentation)) - (match-cons nil)) - ;; - ;; if..then ? - ;; - (if (ada-search-but-not - "\\<then\\>" "\\<and\\>[ \t\n]+\\<then\\>" nil orgpoint) - - (progn - ;; - ;; 'then' first in separate line ? - ;; => indent according to 'then' - ;; - (if (save-excursion - (back-to-indentation) - (looking-at "\\<then\\>")) - (setq cur-indent (current-indentation))) - (forward-word 1) - ;; - ;; something follows 'then' ? - ;; - (if (setq match-cons - (ada-search-ignore-string-comment - "[^ \t\n]" nil orgpoint)) - (progn - (goto-char (car match-cons)) - (+ ada-indent - (- cur-indent (current-indentation)) - (funcall (ada-indent-function t) orgpoint))) - - (+ cur-indent ada-indent))) - - (+ cur-indent ada-broken-indent)))) - - -(defun ada-get-indent-block-start (orgpoint) - ;; Returns the indentation (column #) for the new line after - ;; ORGPOINT. Assumes point to be at the beginning of a block start - ;; keyword. - (let ((cur-indent (current-indentation)) - (pos nil)) - (cond - ((save-excursion - (forward-word 1) - (setq pos (car (ada-search-ignore-string-comment - "[^ \t\n]" nil orgpoint)))) - (goto-char pos) - (save-excursion - (funcall (ada-indent-function t) orgpoint))) - ;; - ;; nothing follows the block-start - ;; - (t - (+ (current-indentation) ada-indent))))) - - -(defun ada-get-indent-subprog (orgpoint) - ;; Returns the indentation (column #) for the new line after ORGPOINT. - ;; Assumes point to be at the beginning of a subprog-/package-declaration. - (let ((match-cons nil) - (cur-indent (current-indentation)) - (foundis nil) - (addind 0) - (fstart (point))) - ;; - ;; is there an 'is' in front of point ? - ;; - (if (save-excursion - (setq match-cons - (ada-search-ignore-string-comment - "\\<\\(is\\|do\\)\\>" nil orgpoint))) - ;; - ;; yes, then skip to its end - ;; - (progn - (setq foundis t) - (goto-char (cdr match-cons))) - ;; - ;; no, then goto next non-ws, if there is one in front of point - ;; - (progn - (if (ada-search-ignore-string-comment "[^ \t\n]" nil orgpoint) - (ada-goto-next-non-ws) - (goto-char orgpoint)))) - - (cond - ;; - ;; nothing follows 'is' - ;; - ((and - foundis - (save-excursion - (not (ada-search-ignore-string-comment - "[^ \t\n]" nil orgpoint t)))) - (+ cur-indent ada-indent)) - ;; - ;; is abstract/separate/new ... - ;; - ((and - foundis - (save-excursion - (setq match-cons - (ada-search-ignore-string-comment - "\\<\\(separate\\|new\\|abstract\\)\\>" - nil orgpoint)))) - (goto-char (car match-cons)) - (ada-search-ignore-string-comment ada-subprog-start-re t) - (ada-get-indent-noindent orgpoint)) - ;; - ;; something follows 'is' - ;; - ((and - foundis - (save-excursion - (ada-search-ignore-string-comment "[^ \t\n]" nil orgpoint)) - (ada-goto-next-non-ws) - (funcall (ada-indent-function t) orgpoint))) - ;; - ;; no 'is' but ';' - ;; - ((save-excursion - (ada-search-ignore-string-comment ";" nil orgpoint)) - cur-indent) - ;; - ;; no 'is' or ';' - ;; - (t - (+ cur-indent ada-broken-indent))))) - - -(defun ada-get-indent-noindent (orgpoint) - ;; Returns the indentation (column #) for the new line after ORGPOINT. - ;; Assumes point to be at the beginning of a 'noindent statement'. - (let ((label 0)) - (save-excursion - (beginning-of-line) - (if (looking-at ada-named-block-re) - (setq label (- ada-label-indent)))) - (if (save-excursion - (ada-search-ignore-string-comment ";" nil orgpoint)) - (+ (current-indentation) label) - (+ (current-indentation) ada-broken-indent label)))) - - -(defun ada-get-indent-label (orgpoint) - ;; Returns the indentation (column #) for the new line after ORGPOINT. - ;; Assumes point to be at the beginning of a label or variable declaration. - ;; Checks the context to decide if it's a label or a variable declaration. - ;; This check might be a bit slow. - (let ((match-cons nil) - (cur-indent (current-indentation))) - (goto-char (cdr (ada-search-ignore-string-comment ":"))) - (cond - ;; - ;; loop label - ;; - ((save-excursion - (setq match-cons (ada-search-ignore-string-comment - ada-loop-start-re nil orgpoint))) - (goto-char (car match-cons)) - (ada-get-indent-loop orgpoint)) - ;; - ;; declare label - ;; - ((save-excursion - (setq match-cons (ada-search-ignore-string-comment - "\\<declare\\|begin\\>" nil orgpoint))) - (save-excursion - (goto-char (car match-cons)) - (+ (current-indentation) ada-indent))) - ;; - ;; complete statement following colon - ;; - ((save-excursion - (ada-search-ignore-string-comment ";" nil orgpoint)) - (if (ada-in-decl-p) - cur-indent ; variable-declaration - (- cur-indent ada-label-indent))) ; label - ;; - ;; broken statement - ;; - ((save-excursion - (ada-search-ignore-string-comment "[^ \t\n]" nil orgpoint)) - (if (ada-in-decl-p) - (+ cur-indent ada-broken-indent) - (+ cur-indent ada-broken-indent (- ada-label-indent)))) - ;; - ;; nothing follows colon - ;; - (t - (if (ada-in-decl-p) - (+ cur-indent ada-broken-indent) ; variable-declaration - (- cur-indent ada-label-indent)))))) ; label - - -(defun ada-get-indent-loop (orgpoint) - ;; Returns the indentation (column #) for the new line after ORGPOINT. - ;; Assumes point to be at the beginning of a loop statement - ;; or (unfortunately) also a for ... use statement. - (let ((match-cons nil) - (pos (point)) - (label (save-excursion - (beginning-of-line) - (if (looking-at ada-named-block-re) - (- ada-label-indent) - 0)))) - - (cond - - ;; - ;; statement complete - ;; - ((save-excursion - (ada-search-ignore-string-comment ";" nil orgpoint)) - (+ (current-indentation) label)) - ;; - ;; simple loop - ;; - ((looking-at "loop\\>") - (+ (ada-get-indent-block-start orgpoint) label)) - - ;; - ;; 'for'- loop (or also a for ... use statement) - ;; - ((looking-at "for\\>") - (cond - ;; - ;; for ... use - ;; - ((save-excursion - (and - (goto-char (match-end 0)) - (ada-search-ignore-string-comment "[^ /n/t]" nil orgpoint) - (not (backward-char 1)) - (not (zerop (skip-chars-forward "_a-zA-Z0-9'"))) - (ada-search-ignore-string-comment "[^ /n/t]" nil orgpoint) - (not (backward-char 1)) - (looking-at "\\<use\\>") - ;; - ;; check if there is a 'record' before point - ;; - (progn - (setq match-cons (ada-search-ignore-string-comment - "\\<record\\>" nil orgpoint)) - t))) - (if match-cons - (goto-char (car match-cons))) - (+ (current-indentation) ada-indent)) - ;; - ;; for..loop - ;; - ((save-excursion - (setq match-cons (ada-search-ignore-string-comment - "\\<loop\\>" nil orgpoint))) - (goto-char (car match-cons)) - ;; - ;; indent according to 'loop', if it's first in the line; - ;; otherwise to 'for' - ;; - (if (not (save-excursion - (back-to-indentation) - (looking-at "\\<loop\\>"))) - (goto-char pos)) - (+ (current-indentation) ada-indent label)) - ;; - ;; for-statement is broken - ;; - (t - (+ (current-indentation) ada-broken-indent label)))) - - ;; - ;; 'while'-loop - ;; - ((looking-at "while\\>") - ;; - ;; while..loop ? - ;; - (if (save-excursion - (setq match-cons (ada-search-ignore-string-comment - "\\<loop\\>" nil orgpoint))) - - (progn - (goto-char (car match-cons)) - ;; - ;; indent according to 'loop', if it's first in the line; - ;; otherwise to 'while'. - ;; - (if (not (save-excursion - (back-to-indentation) - (looking-at "\\<loop\\>"))) - (goto-char pos)) - (+ (current-indentation) ada-indent label)) - - (+ (current-indentation) ada-broken-indent label)))))) - - -(defun ada-get-indent-type (orgpoint) - ;; Returns the indentation (column #) for the new line after ORGPOINT. - ;; Assumes point to be at the beginning of a type statement. - (let ((match-dat nil)) - (cond - ;; - ;; complete record declaration - ;; - ((save-excursion - (and - (setq match-dat (ada-search-ignore-string-comment "\\<end\\>" - nil - orgpoint)) - (ada-goto-next-non-ws) - (looking-at "\\<record\\>") - (forward-word 1) - (ada-goto-next-non-ws) - (looking-at ";"))) - (goto-char (car match-dat)) - (current-indentation)) - ;; - ;; record type - ;; - ((save-excursion - (setq match-dat (ada-search-ignore-string-comment "\\<record\\>" - nil - orgpoint))) - (goto-char (car match-dat)) - (+ (current-indentation) ada-indent)) - ;; - ;; complete type declaration - ;; - ((save-excursion - (ada-search-ignore-string-comment ";" nil orgpoint)) - (current-indentation)) - ;; - ;; "type ... is", but not "type ... is ...", which is broken - ;; - ((save-excursion - (and - (ada-search-ignore-string-comment "\\<is\\>" nil orgpoint) - (not (ada-search-ignore-string-comment "[^ \t\n]" nil orgpoint)))) - (+ (current-indentation) ada-indent)) - ;; - ;; broken statement - ;; - (t - (+ (current-indentation) ada-broken-indent))))) - - -;;; ---- support-functions for indentation - -;;; ---- searching and matching - -(defun ada-goto-stmt-start (&optional limit) - ;; Moves point to the beginning of the statement that point is in or - ;; after. Returns the new position of point. Beginnings are found - ;; by searching for 'ada-end-stmt-re' and then moving to the - ;; following non-ws that is not a comment. LIMIT is actually not - ;; used by the indentation functions. - (let ((match-dat nil) - (orgpoint (point))) - - (setq match-dat (ada-search-prev-end-stmt limit)) - (if match-dat - ;; - ;; found a previous end-statement => check if anything follows - ;; - (progn - (if (not - (save-excursion - (goto-char (cdr match-dat)) - (ada-search-ignore-string-comment - "[^ \t\n]" nil orgpoint))) - ;; - ;; nothing follows => it's the end-statement directly in - ;; front of point => search again - ;; - (setq match-dat (ada-search-prev-end-stmt limit))) - ;; - ;; if found the correct end-statement => goto next non-ws - ;; - (if match-dat - (goto-char (cdr match-dat))) - (ada-goto-next-non-ws)) - - ;; - ;; no previous end-statement => we are at the beginning of the - ;; accessible part of the buffer - ;; - (progn - (goto-char (point-min)) - ;; - ;; skip to the very first statement, if there is one - ;; - (if (setq match-dat - (ada-search-ignore-string-comment - "[^ \t\n]" nil orgpoint)) - (goto-char (car match-dat)) - (goto-char orgpoint)))) - - - (point))) - - -(defun ada-search-prev-end-stmt (&optional limit) - ;; Moves point to previous end-statement. Returns a cons cell whose - ;; car is the beginning and whose cdr the end of the match. - ;; End-statements are defined by 'ada-end-stmt-re'. Checks for - ;; certain keywords if they follow 'end', which means they are no - ;; end-statement there. - (let ((match-dat nil) - (pos nil) - (found nil)) - ;; - ;; search until found or beginning-of-buffer - ;; - (while - (and - (not found) - (setq match-dat (ada-search-ignore-string-comment ada-end-stmt-re - t - limit))) - - (goto-char (car match-dat)) - (if (not (ada-in-open-paren-p)) - ;; - ;; check if there is an 'end' in front of the match - ;; - (if (not (and - (looking-at - "\\<\\(record\\|loop\\|select\\|else\\|then\\)\\>") - (save-excursion - (ada-goto-previous-word) - (looking-at "\\<\\(end\\|or\\|and\\)\\>")))) - (save-excursion - (goto-char (cdr match-dat)) - (ada-goto-next-word) - (if (not (looking-at "\\<\\(separate\\|new\\)\\>")) - (setq found t))) - - (forward-word -1)))) ; end of loop - - (if found - match-dat - nil))) - - -(defun ada-goto-next-non-ws (&optional limit) - ;; Skips whitespaces, newlines and comments to next non-ws - ;; character. Signals an error if there is no more such character - ;; and limit is nil. - (let ((match-cons nil)) - (setq match-cons (ada-search-ignore-string-comment - "[^ \t\n]" nil limit t)) - (if match-cons - (goto-char (car match-cons)) - (if (not limit) - (error "no more non-ws") - nil)))) - - -(defun ada-goto-stmt-end (&optional limit) - ;; Moves point to the end of the statement that point is in or - ;; before. Returns the new position of point or nil if not found. - (if (ada-search-ignore-string-comment ada-end-stmt-re nil limit) - (point) - nil)) - - -(defun ada-goto-next-word (&optional backward) - ;; Moves point to the beginning of the next word of Ada code. - ;; If BACKWARD is non-nil, jump to the beginning of the previous word. - ;; Returns the new position of point or nil if not found. - (let ((match-cons nil) - (orgpoint (point))) - (if (not backward) - (skip-chars-forward "_a-zA-Z0-9\\.")) - (if (setq match-cons - (ada-search-ignore-string-comment "\\w" backward nil t)) - ;; - ;; move to the beginning of the word found - ;; - (progn - (goto-char (car match-cons)) - (skip-chars-backward "_a-zA-Z0-9") - (point)) - ;; - ;; if not found, restore old position of point - ;; - (progn - (goto-char orgpoint) - 'nil)))) - - -(defun ada-goto-previous-word () - ;; Moves point to the beginning of the previous word of Ada code. - ;; Returns the new position of point or nil if not found. - (ada-goto-next-word t)) - - -(defun ada-check-matching-start (keyword) - ;; Signals an error if matching block start is not KEYWORD. - ;; Moves point to the matching block start. - (ada-goto-matching-start 0) - (if (not (looking-at (concat "\\<" keyword "\\>"))) - (error "matching start is not '%s'" keyword))) - - -(defun ada-check-defun-name (defun-name) - ;; Checks if the name of the matching defun really is DEFUN-NAME. - ;; Assumes point to be already positioned by 'ada-goto-matching-start'. - ;; Moves point to the beginning of the declaration. - - ;; - ;; named block without a `declare' - ;; - (if (save-excursion - (ada-goto-previous-word) - (looking-at (concat "\\<" defun-name "\\> *:"))) - t ; do nothing - ;; - ;; 'accept' or 'package' ? - ;; - (if (not (looking-at "\\<\\(accept\\|package\\|task\\|protected\\)\\>")) - (ada-goto-matching-decl-start)) - ;; - ;; 'begin' of 'procedure'/'function'/'task' or 'declare' - ;; - (save-excursion - ;; - ;; a named 'declare'-block ? - ;; - (if (looking-at "\\<declare\\>") - (ada-goto-stmt-start) - ;; - ;; no, => 'procedure'/'function'/'task'/'protected' - ;; - (progn - (forward-word 2) - (backward-word 1) - ;; - ;; skip 'body' 'type' - ;; - (if (looking-at "\\<\\(body\\|type\\)\\>") - (forward-word 1)) - (forward-sexp 1) - (backward-sexp 1))) - ;; - ;; should be looking-at the correct name - ;; - (if (not (looking-at (concat "\\<" defun-name "\\>"))) - (error "matching defun has different name: %s" - (buffer-substring (point) - (progn (forward-sexp 1) (point)))))))) - - -(defun ada-goto-matching-decl-start (&optional noerror nogeneric) - ;; Moves point to the matching declaration start of the current 'begin'. - ;; If NOERROR is non-nil, it only returns nil if no match was found. - (let ((nest-count 1) - (pos nil) - (first t) - (flag nil)) - ;; - ;; search backward for interesting keywords - ;; - (while (and - (not (zerop nest-count)) - (ada-search-ignore-string-comment - (concat "\\<\\(" - "is\\|separate\\|end\\|declare\\|new\\|begin\\|generic" - "\\)\\>") t)) - ;; - ;; calculate nest-depth - ;; - (cond - ;; - ((looking-at "end") - (ada-goto-matching-start 1 noerror) - (if (looking-at "begin") - (setq nest-count (1+ nest-count)))) - ;; - ((looking-at "declare\\|generic") - (setq nest-count (1- nest-count)) - (setq first nil)) - ;; - ((looking-at "is") - ;; check if it is only a type definition, but not a protected - ;; type definition, which should be handled like a procedure. - (if (or (looking-at "is +<>") - (save-excursion - (ada-goto-previous-word) - (skip-chars-backward "a-zA-Z0-9_.'") - (if (save-excursion - (backward-char 1) - (looking-at ")")) - (progn - (forward-char 1) - (backward-sexp 1) - (skip-chars-backward "a-zA-Z0-9_.'") - )) - (ada-goto-previous-word) - (and - (looking-at "\\<type\\>") - (save-match-data - (ada-goto-previous-word) - (not (looking-at "\\<protected\\>")))) - )); end of `or' - (goto-char (match-beginning 0)) - (progn - (setq nest-count (1- nest-count)) - (setq first nil)))) - - ;; - ((looking-at "new") - (if (save-excursion - (ada-goto-previous-word) - (looking-at "is")) - (goto-char (match-beginning 0)))) - ;; - ((and first - (looking-at "begin")) - (setq nest-count 0) - (setq flag t)) - ;; - (t - (setq nest-count (1+ nest-count)) - (setq first nil))) - - ) ;; end of loop - - ;; check if declaration-start is really found - (if (not - (and - (zerop nest-count) - (not flag) - (if (looking-at "is") - (ada-search-ignore-string-comment ada-subprog-start-re t) - (looking-at "declare\\|generic")))) - (if noerror nil - (error "no matching proc/func/task/declare/package/protected")) - t))) - - -(defun ada-goto-matching-start (&optional nest-level noerror gotothen) - ;; Moves point to the beginning of a block-start. Which block - ;; depends on the value of NEST-LEVEL, which defaults to zero. If - ;; NOERROR is non-nil, it only returns nil if no matching start was - ;; found. If GOTOTHEN is non-nil, point moves to the 'then' - ;; following 'if'. - (let ((nest-count (if nest-level nest-level 0)) - (found nil) - (pos nil)) - - ;; - ;; search backward for interesting keywords - ;; - (while (and - (not found) - (ada-search-ignore-string-comment - (concat "\\<\\(" - "end\\|loop\\|select\\|begin\\|case\\|do\\|" - "if\\|task\\|package\\|record\\|protected\\)\\>") - t)) - - ;; - ;; calculate nest-depth - ;; - (cond - ;; found block end => increase nest depth - ((looking-at "end") - (setq nest-count (1+ nest-count))) - ;; found loop/select/record/case/if => check if it starts or - ;; ends a block - ((looking-at "loop\\|select\\|record\\|case\\|if") - (setq pos (point)) - (save-excursion - ;; - ;; check if keyword follows 'end' - ;; - (ada-goto-previous-word) - (if (looking-at "\\<end\\> *[^;]") - ;; it ends a block => increase nest depth - (progn - (setq nest-count (1+ nest-count)) - (setq pos (point))) - ;; it starts a block => decrease nest depth - (setq nest-count (1- nest-count)))) - (goto-char pos)) - ;; found package start => check if it really is a block - ((looking-at "package") - (save-excursion - (ada-search-ignore-string-comment "\\<is\\>") - (ada-goto-next-non-ws) - ;; ignore it if it is only a declaration with 'new' - (if (not (looking-at "\\<new\\>")) - (setq nest-count (1- nest-count))))) - ;; found task start => check if it has a body - ((looking-at "task") - (save-excursion - (forward-word 1) - (ada-goto-next-non-ws) - ;; ignore it if it has no body - (if (not (looking-at "\\<body\\>")) - (setq nest-count (1- nest-count))))) - ;; all the other block starts - (t - (setq nest-count (1- nest-count)))) ; end of 'cond' - - ;; match is found, if nest-depth is zero - ;; - (setq found (zerop nest-count))) ; end of loop - - (if found - ;; - ;; match found => is there anything else to do ? - ;; - (progn - (cond - ;; - ;; found 'if' => skip to 'then', if it's on a separate line - ;; and GOTOTHEN is non-nil - ;; - ((and - gotothen - (looking-at "if") - (save-excursion - (ada-search-ignore-string-comment "\\<then\\>" nil nil) - (back-to-indentation) - (looking-at "\\<then\\>"))) - (goto-char (match-beginning 0))) - ;; - ;; found 'do' => skip back to 'accept' - ;; - ((looking-at "do") - (if (not (ada-search-ignore-string-comment "\\<accept\\>" t nil)) - (error "missing 'accept' in front of 'do'")))) - (point)) - - (if noerror - nil - (error "no matching start"))))) - - -(defun ada-goto-matching-end (&optional nest-level noerror) - ;; Moves point to the end of a block. Which block depends on the - ;; value of NEST-LEVEL, which defaults to zero. If NOERROR is - ;; non-nil, it only returns nil if found no matching start. - (let ((nest-count (if nest-level nest-level 0)) - (found nil)) - - ;; - ;; search forward for interesting keywords - ;; - (while (and - (not found) - (ada-search-ignore-string-comment - (concat "\\<\\(end\\|loop\\|select\\|begin\\|case\\|" - "if\\|task\\|package\\|record\\|do\\)\\>"))) - - ;; - ;; calculate nest-depth - ;; - (backward-word 1) - (cond - ;; found block end => decrease nest depth - ((looking-at "\\<end\\>") - (setq nest-count (1- nest-count)) - ;; skip the following keyword - (if (progn - (skip-chars-forward "end") - (ada-goto-next-non-ws) - (looking-at "\\<\\(loop\\|select\\|record\\|case\\|if\\)\\>")) - (forward-word 1))) - ;; found package start => check if it really starts a block - ((looking-at "\\<package\\>") - (ada-search-ignore-string-comment "\\<is\\>") - (ada-goto-next-non-ws) - ;; ignore and skip it if it is only a 'new' package - (if (not (looking-at "\\<new\\>")) - (setq nest-count (1+ nest-count)) - (skip-chars-forward "new"))) - ;; all the other block starts - (t - (setq nest-count (1+ nest-count)) - (forward-word 1))) ; end of 'cond' - - ;; match is found, if nest-depth is zero - ;; - (setq found (zerop nest-count))) ; end of loop - - (if (not found) - (if noerror - nil - (error "no matching end")) - t))) - - -(defun ada-forward-sexp-ignore-comment () - ;; Skips one sexp forward, ignoring comments. - (while (looking-at "[ \t\n]*--") - (skip-chars-forward "[ \t\n]") - (end-of-line)) - (forward-sexp 1)) - - -(defun ada-search-ignore-string-comment - (search-re &optional backward limit paramlists) - ;; Regexp-Search for SEARCH-RE, ignoring comments, strings and - ;; parameter lists, if PARAMLISTS is nil. Returns a cons cell of - ;; begin and end of match data or nil, if not found. - (let ((found nil) - (begin nil) - (end nil) - (pos nil) - (search-func - (if backward 're-search-backward - 're-search-forward))) - - ;; - ;; search until found or end-of-buffer - ;; - (while (and (not found) - (funcall search-func search-re limit 1)) - (setq begin (match-beginning 0)) - (setq end (match-end 0)) - - (cond - ;; - ;; found in comment => skip it - ;; - ((ada-in-comment-p) - (if backward - (progn - (re-search-backward "--" nil 1) - (goto-char (match-beginning 0))) - (progn - (forward-line 1) - (beginning-of-line)))) - ;; - ;; found in string => skip it - ;; - ((ada-in-string-p) - (if backward - (progn - (re-search-backward "\"" nil 1) ; "\"\\|#" don't treat # - (goto-char (match-beginning 0)))) - (re-search-forward "\"" nil 1)) - ;; - ;; found character constant => ignore it - ;; - ((save-excursion - (setq pos (- (point) (if backward 1 2))) - (and (char-after pos) - (= (char-after pos) ?') - (= (char-after (+ pos 2)) ?'))) - ()) - ;; - ;; found a parameter-list but should ignore it => skip it - ;; - ((and (not paramlists) - (ada-in-paramlist-p)) - (if backward - (ada-search-ignore-string-comment "(" t nil t))) - ;; - ;; directly in front of a comment => skip it, if searching forward - ;; - ((save-excursion - (goto-char begin) - (looking-at "--")) - (if (not backward) - (progn - (forward-line 1) - (beginning-of-line)))) - ;; - ;; found what we were looking for - ;; - (t - (setq found t)))) ; end of loop - - (if found - (cons begin end) - nil))) - - -(defun ada-search-but-not (search-re not-search-re &optional backward limit) - ;; Searches SEARCH-RE, ignoring parts of NOT-SEARCH-RE, strings, - ;; comments and parameter-lists. - (let ((begin nil) - (end nil) - (begin-not nil) - (begin-end nil) - (end-not nil) - (ret-cons nil) - (found nil)) - - ;; - ;; search until found or end-of-buffer - ;; - (while (and - (not found) - (save-excursion - (setq ret-cons - (ada-search-ignore-string-comment search-re - backward limit)) - (if (consp ret-cons) - (progn - (setq begin (car ret-cons)) - (setq end (cdr ret-cons)) - t) - nil))) - - (if (or - ;; - ;; if no NO-SEARCH-RE was found - ;; - (not - (save-excursion - (setq ret-cons - (ada-search-ignore-string-comment not-search-re - backward nil)) - (if (consp ret-cons) - (progn - (setq begin-not (car ret-cons)) - (setq end-not (cdr ret-cons)) - t) - nil))) - ;; - ;; or this NO-SEARCH-RE is not a part of the SEARCH-RE - ;; found before. - ;; - (or - (<= end-not begin) - (>= begin-not end))) - - (setq found t) - - ;; - ;; not found the correct match => skip this match - ;; - (goto-char (if backward - begin - end)))) ; end of loop - - (if found - (progn - (goto-char begin) - (cons begin end)) - nil))) - - -(defun ada-goto-prev-nonblank-line ( &optional ignore-comment) - ;; Moves point to the beginning of previous non-blank line, - ;; ignoring comments if IGNORE-COMMENT is non-nil. - ;; It returns t if a matching line was found. - (let ((notfound t) - (newpoint nil)) - - (save-excursion - ;; - ;; backward one line, if there is one - ;; - (if (zerop (forward-line -1)) - ;; - ;; there is some kind of previous line - ;; - (progn - (beginning-of-line) - (setq newpoint (point)) - - ;; - ;; search until found or beginning-of-buffer - ;; - (while (and (setq notfound - (or (looking-at "[ \t]*$") - (and (looking-at "[ \t]*--") - ignore-comment))) - (not (ada-in-limit-line-p))) - (forward-line -1) - ;;(beginning-of-line) - (setq newpoint (point))) ; end of loop - - )) ; end of if - - ) ; end of save-excursion - - (if notfound nil - (progn - (goto-char newpoint) - t)))) - - -(defun ada-goto-next-nonblank-line ( &optional ignore-comment) - ;; Moves point to next non-blank line, - ;; ignoring comments if IGNORE-COMMENT is non-nil. - ;; It returns t if a matching line was found. - (let ((notfound t) - (newpoint nil)) - - (save-excursion - ;; - ;; forward one line - ;; - (if (zerop (forward-line 1)) - ;; - ;; there is some kind of previous line - ;; - (progn - (beginning-of-line) - (setq newpoint (point)) - - ;; - ;; search until found or end-of-buffer - ;; - (while (and (setq notfound - (or (looking-at "[ \t]*$") - (and (looking-at "[ \t]*--") - ignore-comment))) - (not (ada-in-limit-line-p))) - (forward-line 1) - (beginning-of-line) - (setq newpoint (point))) ; end of loop - - )) ; end of if - - ) ; end of save-excursion - - (if notfound nil - (progn - (goto-char newpoint) - t)))) - - -;; ---- boolean functions for indentation - -(defun ada-in-decl-p () - ;; Returns t if point is inside a declarative part. - ;; Assumes point to be at the end of a statement. - (or - (ada-in-paramlist-p) - (save-excursion - (ada-goto-matching-decl-start t)))) - - -(defun ada-looking-at-semi-or () - ;; Returns t if looking-at an 'or' following a semicolon. - (save-excursion - (and (looking-at "\\<or\\>") - (progn - (forward-word 1) - (ada-goto-stmt-start) - (looking-at "\\<or\\>"))))) - - -(defun ada-looking-at-semi-private () - ;; Returns t if looking-at an 'private' following a semicolon. - (save-excursion - (and (looking-at "\\<private\\>") - (progn - (forward-word 1) - (ada-goto-stmt-start) - (looking-at "\\<private\\>"))))) - - -;;; make a faster??? ada-in-limit-line-p not using count-lines -(defun ada-in-limit-line-p () - ;; return t if point is in first or last accessible line. - (or (save-excursion (beginning-of-line) (= (point-min) (point))) - (save-excursion (end-of-line) (= (point-max) (point))))) - - -(defun ada-in-comment-p () - ;; Returns t if inside a comment. - (nth 4 (parse-partial-sexp - (save-excursion (beginning-of-line) (point)) - (point)))) - - -(defun ada-in-string-p () - ;; Returns t if point is inside a string - ;; (Taken from pascal-mode.el, modified by MH). - (save-excursion - (and - (nth 3 (parse-partial-sexp - (save-excursion - (beginning-of-line) - (point)) (point))) - ;; check if 'string quote' is only a character constant - (progn - (re-search-backward "\"" nil t) ; `#' is not taken as a string delimiter - (not (= (char-after (1- (point))) ?')))))) - - -(defun ada-in-string-or-comment-p () - ;; Returns t if point is inside a string, a comment, or a character constant. - (let ((parse-result (parse-partial-sexp - (save-excursion (beginning-of-line) (point)) (point)))) - (or ;; in-comment-p - (nth 4 parse-result) - ;; in-string-p - (and - (nth 3 parse-result) - ;; check if 'string quote' is only a character constant - (progn - (re-search-backward "\"" nil t) ; `#' not regarded a string delimiter - (not (= (char-after (1- (point))) ?')))) - ;; in-char-const-p - (ada-in-char-const-p)))) - - -(defun ada-in-paramlist-p () - ;; Returns t if point is inside a parameter-list - ;; following 'function'/'procedure'/'package'. - (save-excursion - (and - (re-search-backward "(\\|)" nil t) - ;; inside parentheses ? - (looking-at "(") - (backward-word 2) - ;; right keyword before parenthesis ? - (looking-at (concat "\\<\\(" - "procedure\\|function\\|body\\|package\\|" - "task\\|entry\\|accept\\)\\>")) - (re-search-forward ")\\|:" nil t) - ;; at least one ':' inside the parentheses ? - (not (backward-char 1)) - (looking-at ":")))) - - -;; not really a boolean function ... -(defun ada-in-open-paren-p () - ;; If point is somewhere behind an open parenthesis not yet closed, - ;; it returns the column # of the first non-ws behind this open - ;; parenthesis, otherwise nil." - (let ((start (if (<= (point) ada-search-paren-char-count-limit) - (point-min) - (save-excursion - (goto-char (- (point) ada-search-paren-char-count-limit)) - (beginning-of-line) - (point)))) - parse-result - (col nil)) - (setq parse-result (parse-partial-sexp start (point))) - (if (nth 1 parse-result) - (save-excursion - (goto-char (1+ (nth 1 parse-result))) - (if (save-excursion - (re-search-forward "[^ \t]" nil 1) - (backward-char 1) - (and - (not (looking-at "\n")) - (setq col (current-column)))) - col - (current-column))) - nil))) - - - -;;;----------------------;;; -;;; Behaviour Of TAB Key ;;; -;;;----------------------;;; - -(defun ada-tab () - "Do indenting or tabbing according to `ada-tab-policy'." - (interactive) - (cond ((eq ada-tab-policy 'indent-and-tab) (error "not implemented")) - ;; ada-indent-and-tab - ((eq ada-tab-policy 'indent-rigidly) (ada-tab-hard)) - ((eq ada-tab-policy 'indent-auto) (ada-indent-current)) - ((eq ada-tab-policy 'gei) (ada-tab-gei)) - ((eq ada-tab-policy 'indent-af) (af-indent-line)) ; GEB - ((eq ada-tab-policy 'always-tab) (error "not implemented")) - )) - - -(defun ada-untab (arg) - "Delete leading indenting according to `ada-tab-policy'." - (interactive "P") - (cond ((eq ada-tab-policy 'indent-rigidly) (ada-untab-hard)) - ((eq ada-tab-policy 'indent-af) (backward-delete-char-untabify ; GEB - (prefix-numeric-value arg) ; GEB - arg)) ; GEB - ((eq ada-tab-policy 'indent-auto) (error "not implemented")) - ((eq ada-tab-policy 'always-tab) (error "not implemented")) - )) - - -(defun ada-indent-current-function () - "Ada mode version of the indent-line-function." - (interactive "*") - (let ((starting-point (point-marker))) - (ada-beginning-of-line) - (ada-tab) - (if (< (point) starting-point) - (goto-char starting-point)) - (set-marker starting-point nil) - )) - - -(defun ada-tab-hard () - "Indent current line to next tab stop." - (interactive) - (save-excursion - (beginning-of-line) - (insert-char ? ada-indent)) - (if (save-excursion (= (point) (progn (beginning-of-line) (point)))) - (forward-char ada-indent))) - - -(defun ada-untab-hard () - "indent current line to previous tab stop." - (interactive) - (let ((bol (save-excursion (progn (beginning-of-line) (point)))) - (eol (save-excursion (progn (end-of-line) (point))))) - (indent-rigidly bol eol (- 0 ada-indent)))) - - - -;;;---------------;;; -;;; Miscellaneous ;;; -;;;---------------;;; - -(defun ada-remove-trailing-spaces () - "remove trailing spaces in the whole buffer." - (interactive) - (save-match-data - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (while (re-search-forward "[ \t]+$" (point-max) t) - (replace-match "" nil nil)))))) - - -(defun ada-untabify-buffer () -;; change all tabs to spaces - (save-excursion - (untabify (point-min) (point-max)) - nil)) - - -(defun ada-uncomment-region (beg end) - "delete `comment-start' at the beginning of a line in the region." - (interactive "r") - (comment-region beg end -1)) - - -;; define a function to support find-file.el if loaded -(defun ada-ff-other-window () - "Find other file in other window using `ff-find-other-file'." - (interactive) - (and (fboundp 'ff-find-other-file) - (ff-find-other-file t))) - -;; inspired by Laurent.GUERBY@enst-bretagne.fr -(defun ada-gnat-style () - "Clean up comments, `(' and `,' for GNAT style checking switch." - (interactive) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward "-- ?\\([^ -]\\)" nil t) - (replace-match "-- \\1")) - (goto-char (point-min)) - (while (re-search-forward "\\>(" nil t) - (replace-match " (")) - (goto-char (point-min)) - (while (re-search-forward ",\\<" nil t) - (replace-match ", ")) - )) - - - -;;;-------------------------------;;; -;;; Moving To Procedures/Packages ;;; -;;;-------------------------------;;; - -(defun ada-next-procedure () - "Moves point to next procedure." - (interactive) - (end-of-line) - (if (re-search-forward ada-procedure-start-regexp nil t) - (goto-char (match-beginning 1)) - (error "No more functions/procedures/tasks"))) - -(defun ada-previous-procedure () - "Moves point to previous procedure." - (interactive) - (beginning-of-line) - (if (re-search-backward ada-procedure-start-regexp nil t) - (goto-char (match-beginning 1)) - (error "No more functions/procedures/tasks"))) - -(defun ada-next-package () - "Moves point to next package." - (interactive) - (end-of-line) - (if (re-search-forward ada-package-start-regexp nil t) - (goto-char (match-beginning 1)) - (error "No more packages"))) - -(defun ada-previous-package () - "Moves point to previous package." - (interactive) - (beginning-of-line) - (if (re-search-backward ada-package-start-regexp nil t) - (goto-char (match-beginning 1)) - (error "No more packages"))) - - -;;;----------------------- -;;; define keymap for Ada -;;;----------------------- - -(if (not ada-mode-map) - (progn - (setq ada-mode-map (make-sparse-keymap)) - - ;; Indentation and Formatting - (define-key ada-mode-map "\C-j" 'ada-indent-newline-indent) - (define-key ada-mode-map "\t" 'ada-tab) - (define-key ada-mode-map "\C-c\C-l" 'ada-indent-region) - (if (ada-xemacs) - (define-key ada-mode-map '(shift tab) 'ada-untab) - (define-key ada-mode-map [S-tab] 'ada-untab)) - (define-key ada-mode-map "\C-c\C-f" 'ada-format-paramlist) - (define-key ada-mode-map "\C-c\C-p" 'ada-call-pretty-printer) -;;; We don't want to make meta-characters case-specific. -;;; (define-key ada-mode-map "\M-Q" 'ada-fill-comment-paragraph-justify) - (define-key ada-mode-map "\M-\C-q" 'ada-fill-comment-paragraph-postfix) - - ;; Movement -;;; It isn't good to redefine these. What should be done instead? -- rms. -;;; (define-key ada-mode-map "\M-e" 'ada-next-package) -;;; (define-key ada-mode-map "\M-a" 'ada-previous-package) - (define-key ada-mode-map "\M-\C-e" 'ada-next-procedure) - (define-key ada-mode-map "\M-\C-a" 'ada-previous-procedure) - (define-key ada-mode-map "\C-c\C-a" 'ada-move-to-start) - (define-key ada-mode-map "\C-c\C-e" 'ada-move-to-end) - - ;; Compilation - (define-key ada-mode-map "\C-c\C-c" 'compile) - (define-key ada-mode-map "\C-c\C-v" 'ada-check-syntax) - (define-key ada-mode-map "\C-c\C-m" 'ada-make-local) - - ;; Casing - (define-key ada-mode-map "\C-c\C-r" 'ada-adjust-case-region) - (define-key ada-mode-map "\C-c\C-b" 'ada-adjust-case-buffer) - - (define-key ada-mode-map "\177" 'backward-delete-char-untabify) - - ;; Use predefined function of emacs19 for comments (RE) - (define-key ada-mode-map "\C-c;" 'comment-region) - (define-key ada-mode-map "\C-c:" 'ada-uncomment-region) - - ;; Change basic functionality - - ;; `substitute-key-definition' is not defined equally in Emacs - ;; and XEmacs, you cannot put in an optional 4th parameter in - ;; XEmacs. I don't think it's necessary, so I leave it out for - ;; Emacs as well. If you encounter any problems with the - ;; following three functions, please tell me. RE - (mapcar (function (lambda (pair) - (substitute-key-definition (car pair) (cdr pair) - ada-mode-map))) - '((beginning-of-line . ada-beginning-of-line) - (end-of-line . ada-end-of-line) - (forward-to-indentation . ada-forward-to-indentation) - )) - ;; else Emacs - ;;(mapcar (lambda (pair) - ;; (substitute-key-definition (car pair) (cdr pair) - ;; ada-mode-map global-map)) - - )) - - -;;;------------------- -;;; define menu 'Ada' -;;;------------------- - -(require 'easymenu) - -(defun ada-add-ada-menu () - "Adds the menu 'Ada' to the menu bar in Ada mode." - (easy-menu-define ada-mode-menu ada-mode-map "Menu keymap for Ada mode." - '("Ada" - ["Next Package" ada-next-package t] - ["Previous Package" ada-previous-package t] - ["Next Procedure" ada-next-procedure t] - ["Previous Procedure" ada-previous-procedure t] - ["Goto Start" ada-move-to-start t] - ["Goto End" ada-move-to-end t] - ["------------------" nil nil] - ["Indent Current Line (TAB)" - ada-indent-current-function t] - ["Indent Lines in Region" ada-indent-region t] - ["Format Parameter List" ada-format-paramlist t] - ["Pretty Print Buffer" ada-call-pretty-printer t] - ["------------" nil nil] - ["Fill Comment Paragraph" - ada-fill-comment-paragraph t] - ["Justify Comment Paragraph" - ada-fill-comment-paragraph-justify t] - ["Postfix Comment Paragraph" - ada-fill-comment-paragraph-postfix t] - ["------------" nil nil] - ["Adjust Case Region" ada-adjust-case-region t] - ["Adjust Case Buffer" ada-adjust-case-buffer t] - ["----------" nil nil] - ["Comment Region" comment-region t] - ["Uncomment Region" ada-uncomment-region t] - ["----------------" nil nil] - ["Global Make" compile (fboundp 'compile)] - ["Local Make" ada-make-local t] - ["Check Syntax" ada-check-syntax t] - ["Next Error" next-error (fboundp 'next-error)] - ["---------------" nil nil] - ["Index" imenu (fboundp 'imenu)] - ["--------------" nil nil] - ["Other File Other Window" ada-ff-other-window - (fboundp 'ff-find-other-file)] - ["Other File" ff-find-other-file - (fboundp 'ff-find-other-file)])) - (if (ada-xemacs) (progn - (easy-menu-add ada-mode-menu) - (setq mode-popup-menu (cons "Ada mode" ada-mode-menu))))) - - - -;;;------------------------------- -;;; Define Some Support Functions -;;;------------------------------- - -(defun ada-beginning-of-line (&optional arg) - (interactive "P") - (cond - ((eq ada-tab-policy 'indent-af) (af-beginning-of-line arg)) - (t (beginning-of-line arg)) - )) - -(defun ada-end-of-line (&optional arg) - (interactive "P") - (cond - ((eq ada-tab-policy 'indent-af) (af-end-of-line arg)) - (t (end-of-line arg)) - )) - -(defun ada-current-column () - (cond - ((eq ada-tab-policy 'indent-af) (af-current-column)) - (t (current-column)) - )) - -(defun ada-forward-to-indentation (&optional arg) - (interactive "P") - (cond - ((eq ada-tab-policy 'indent-af) (af-forward-to-indentation arg)) - (t (forward-to-indentation arg)) - )) - -;;;--------------------------------------------------- -;;; support for find-file.el -;;;--------------------------------------------------- - - -;;;###autoload -(defun ada-make-filename-from-adaname (adaname) - "Determine the filename of a package/procedure from its own Ada name." - ;; this is done simply by calling `gnatkr', when we work with GNAT. It - ;; must be a more complex function in other compiler environments. - (interactive "s") - (let (krunch-buf) - (setq krunch-buf (generate-new-buffer "*gkrunch*")) - (save-excursion - (set-buffer krunch-buf) - ;; send adaname to external process `gnatkr'. - (call-process "gnatkr" nil krunch-buf nil - adaname ada-krunch-args) - ;; fetch output of that process - (setq adaname (buffer-substring - (point-min) - (progn - (goto-char (point-min)) - (end-of-line) - (point)))) - (kill-buffer krunch-buf))) - (setq adaname adaname) ;; can I avoid this statement? - ) - - -;;; functions for placing the cursor on the corresponding subprogram -(defun ada-which-function-are-we-in () - "Determine whether we are on a function definition/declaration. -If that is the case remember the name of that function." - - (setq ff-function-name nil) - - (save-excursion - (if (re-search-backward ada-procedure-start-regexp nil t) - (setq ff-function-name (buffer-substring (match-beginning 0) - (match-end 0))) - ; we didn't find a procedure start, perhaps there is a package - (if (re-search-backward ada-package-start-regexp nil t) - (setq ff-function-name (buffer-substring (match-beginning 0) - (match-end 0))) - )))) - - -;;;--------------------------------------------------- -;;; support for font-lock -;;;--------------------------------------------------- - -;; Strings are a real pain in Ada because a single quote character is -;; overloaded as a string quote and type/instance delimiter. By default, a -;; single quote is given punctuation syntax in `ada-mode-syntax-table'. -;; So, for Font Lock mode purposes, we mark single quotes as having string -;; syntax when the gods that created Ada determine them to be. sm. - -(defconst ada-font-lock-syntactic-keywords - ;; Mark single quotes as having string quote syntax in 'c' instances. - '(("\\(\'\\).\\(\'\\)" (1 (7 . ?\')) (2 (7 . ?\'))))) - -(defconst ada-font-lock-keywords-1 - (list - ;; - ;; handle "type T is access function return S;" - ;; - (list "\\<\\(function[ \t]+return\\)\\>" '(1 font-lock-keyword-face) ) - ;; - ;; accept, entry, function, package (body), protected (body|type), - ;; pragma, procedure, task (body) plus name. - (list (concat - "\\<\\(" - "accept\\|" - "entry\\|" - "function\\|" - "package[ \t]+body\\|" - "package\\|" - "pragma\\|" - "procedure\\|" - "protected[ \t]+body\\|" - "protected[ \t]+type\\|" - "protected\\|" -;; "p\\(\\(ackage\\|rotected\\)\\(\\|[ \t]+\\(body\\|type\\)\\)\ -;;\\|r\\(agma\\|ocedure\\)\\)\\|" - "task[ \t]+body\\|" - "task[ \t]+type\\|" - "task" -;; "task\\(\\|[ \t]+body\\)" - "\\)\\>[ \t]*" - "\\(\\sw+\\(\\.\\sw*\\)*\\)?") - '(1 font-lock-keyword-face) '(2 font-lock-function-name-face nil t))) - "Subdued level highlighting for Ada mode.") - -(defconst ada-font-lock-keywords-2 - (append ada-font-lock-keywords-1 - (list - ;; - ;; Main keywords, except those treated specially below. - (concat "\\<\\(" -; ("abort" "abs" "abstract" "accept" "access" "aliased" "all" -; "and" "array" "at" "begin" "case" "declare" "delay" "delta" -; "digits" "do" "else" "elsif" "entry" "exception" "exit" "for" -; "generic" "if" "in" "is" "limited" "loop" "mod" "not" -; "null" "or" "others" "private" "protected" -; "range" "record" "rem" "renames" "requeue" "return" "reverse" -; "select" "separate" "tagged" "task" "terminate" "then" "until" -; "while" "xor") - "a\\(b\\(ort\\|s\\(\\|tract\\)\\)\\|cce\\(pt\\|ss\\)\\|" - "l\\(iased\\|l\\)\\|nd\\|rray\\|t\\)\\|begin\\|case\\|" - "d\\(e\\(clare\\|l\\(ay\\|ta\\)\\)\\|igits\\|o\\)\\|" - "e\\(ls\\(e\\|if\\)\\|ntry\\|x\\(ception\\|it\\)\\)\\|for\\|" - "generic\\|i[fns]\\|l\\(imited\\|oop\\)\\|mod\\|n\\(ot\\|ull\\)\\|" - "o\\(r\\|thers\\|ut\\)\\|pr\\(ivate\\|otected\\)\\|" - "r\\(a\\(ise\\|nge\\)\\|e\\(cord\\|m\\|names\\|queue\\|turn\\|verse\\)\\)\\|" - "se\\(lect\\|parate\\)\\|" - "t\\(agged\\|erminate\\|hen\\)\\|until\\|" ; task removed - "wh\\(ile\\|en\\)\\|xor" ; "when" added - "\\)\\>") - ;; - ;; Anything following end and not already fontified is a body name. - '("\\<\\(end\\)\\>\\([ \t]+\\)?\\([a-zA-Z0-9_\\.]+\\)?" - (1 font-lock-keyword-face) (3 font-lock-function-name-face nil t)) - ;; - ;; Variable name plus optional keywords followed by a type name. Slow. -; (list (concat "\\<\\(\\sw+\\)\\>[ \t]*:?[ \t]*" -; "\\(access\\|constant\\|in\\|in[ \t]+out\\|out\\)?[ \t]*" -; "\\(\\sw+\\)?") -; '(1 font-lock-variable-name-face) -; '(2 font-lock-keyword-face nil t) '(3 font-lock-type-face nil t)) - ;; - ;; Optional keywords followed by a type name. - (list (concat ; ":[ \t]*" - "\\<\\(access\\|constant\\|in[ \t]+out\\|in\\|out\\)\\>" - "[ \t]*" - "\\(\\sw+\\)?") - '(1 font-lock-keyword-face nil t) '(2 font-lock-type-face nil t)) - ;; - ;; Keywords followed by a type or function name. - (list (concat "\\<\\(" - "new\\|of\\|subtype\\|type" - "\\)\\>[ \t]*\\(\\sw+\\)?[ \t]*\\((\\)?") - '(1 font-lock-keyword-face) - '(2 (if (match-beginning 4) - font-lock-function-name-face - font-lock-type-face) nil t)) - ;; - ;; Keywords followed by a (comma separated list of) reference. - (list (concat "\\<\\(goto\\|raise\\|use\\|with\\)\\>" ; "when" removed - ; "[ \t]*\\(\\sw+\\(\\.\\sw*\\)*\\)?") ; RE - "[ \t]*\\([a-zA-Z0-9_\\.\\|, ]+\\)\\W") - '(1 font-lock-keyword-face) '(2 font-lock-reference-face nil t)) - ;; - ;; Goto tags. - '("<<\\(\\sw+\\)>>" 1 font-lock-reference-face) - )) - "Gaudy level highlighting for Ada mode.") - -(defvar ada-font-lock-keywords ada-font-lock-keywords-1 - "Default expressions to highlight in Ada mode.") - - -;; set font-lock properties for XEmacs -(if (ada-xemacs) - (put 'ada-mode 'font-lock-defaults - '(ada-font-lock-keywords - nil t ((?\_ . "w")(?\. . "w")) beginning-of-line))) - -;;; -;;; support for outline -;;; - -;; used by outline-minor-mode -(defun ada-outline-level () - (save-excursion - (skip-chars-forward "\t ") - (current-column))) - -;;; -;;; generate body -;;; -(defun ada-gen-comment-until-proc () - ;; comment until spec of a procedure or a function. - (forward-line 1) - (set-mark-command (point)) - (if (re-search-forward ada-procedure-start-regexp nil t) - (progn (goto-char (match-beginning 1)) - (comment-region (mark) (point))) - (error "No more functions/procedures"))) - - -(defun ada-gen-treat-proc (match) - ;; make dummy body of a procedure/function specification. - ;; MATCH is a cons cell containing the start and end location of the - ;; last search for ada-procedure-start-regexp. - (goto-char (car match)) - (let (proc-found func-found procname functype) - (cond - ((or (setq proc-found (looking-at "^[ \t]*procedure")) - (setq func-found (looking-at "^[ \t]*function"))) - ;; treat it as a proc/func - (forward-word 2) - (forward-word -1) - (setq procname (buffer-substring (point) (cdr match))) ; store proc name - - ;; goto end of procname - (goto-char (cdr match)) - - ;; skip over parameterlist - (forward-sexp) - ;; if function, skip over 'return' and result type. - (if func-found - (progn - (forward-word 1) - (skip-chars-forward " \t\n") - (setq functype (buffer-substring (point) - (progn - (skip-chars-forward - "a-zA-Z0-9_\.") - (point)))))) - ;; look for next non WS - (cond - ((looking-at "[ \t]*;") - (delete-region (match-beginning 0) (match-end 0)) ;; delete the ';' - (ada-indent-newline-indent) - (insert " is") - (ada-indent-newline-indent) - (if func-found - (progn - (insert "Result : ") - (insert functype) - (insert ";") - (ada-indent-newline-indent))) - (insert "begin -- ") - (insert procname) - (ada-indent-newline-indent) - (insert "null;") - (ada-indent-newline-indent) - (if func-found - (progn - (insert "return Result;") - (ada-indent-newline-indent))) - (insert "end ") - (insert procname) - (insert ";") - (ada-indent-newline-indent) - ) - ;; else - ((looking-at "[ \t\n]*is") - ;; do nothing - ) - ((looking-at "[ \t\n]*rename") - ;; do nothing - ) - (t - (message "unknown syntax"))) - )))) - - -(defun ada-make-body () - "Create an Ada package body in the current buffer. -The potential old buffer contents is deleted first, then we copy the -spec buffer in here and modify it to make it a body. - -This function typically is to be hooked into `ff-file-created-hooks'." - (interactive) - (delete-region (point-min) (point-max)) - (insert-buffer (car (cdr (buffer-list)))) - (ada-mode) - - (let (found) - (if (setq found - (ada-search-ignore-string-comment ada-package-start-regexp)) - (progn (goto-char (cdr found)) - (insert " body") - ;; (forward-line -1) - ;;(comment-region (point-min) (point)) - ) - (error "No package")) - - ;; (comment-until-proc) - ;; does not work correctly - ;; must be done by hand - - (while (setq found - (ada-search-ignore-string-comment ada-procedure-start-regexp)) - (ada-gen-treat-proc found)))) - - -;;; provide ourself - -(provide 'ada-mode) - -;;; ada-mode.el ends here
--- a/lisp/modes/ada-stmt.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,630 +0,0 @@ -;;; ada-stmt.el - An extension to Ada mode for inserting statement templates. - -;; Copyright (C) 1987, 1993, 1994, 1996, 1997 Free Software Foundation, Inc. - -;; Authors: Daniel Pfeiffer, Markus Heritsch, Rolf Ebert <ebert@waporo.muc.de> -;; Maintainer: Rolf Ebert <ebert@waporo.muc.de> -;; Keywords: languages, ada -;; Rolf Ebert's version: 2.26 - -;;; Commentary: - -;; -;; put the following statement in your .emacs: -;; (require 'ada-stmt) -;; - -;;; History: - -;; Created May 1987. -;; Original version from V. Bowman as in ada.el of Emacs-18 -;; (borrowed heavily from Mick Jordan's Modula-2 package for GNU, -;; as modified by Peter Robinson, Michael Schmidt, and Tom Perrine.) -;; -;; Sep 1993. Daniel Pfeiffer <pfeiffer@cict.fr> (DP) -;; Introduced statement.el for smaller code and user configurability. -;; -;; Nov 1993. Rolf Ebert <ebert@enpc.fr> (RE) Moved the -;; skeleton generation into this separate file. The code still is -;; essentially written by DP -;; -;; Adapted Jun 1994. Markus Heritsch -;; <Markus.Heritsch@studbox.uni-stuttgart.de> (MH) -;; added menu bar support for templates -;; -;; 1994/12/02 Christian Egli <cegli@hcsd.hac.com> -;; General cleanup and bug fixes. -;; -;; 1995/12/20 John Hutchison <hutchiso@epi.syr.ge.com> -;; made it work with skeleton.el from emacs-19.30. Several -;; enhancements and bug fixes. - -;; BUGS: -;;;> I have the following suggestions for the function template: 1) I -;;;> don't want it automatically assigning it a name for the return variable. I -;;;> never want it to be called "Result" because that is nondescriptive. If you -;;;> must define a variable, give me the ability to specify its name. -;;;> -;;;> 2) You do not provide a type for variable 'Result'. Its type is the same -;;;> as the function's return type, which the template knows, so why force me -;;;> to type it in? -;;;> - -;;;It would be nice if one could configure such layout details separately -;;;without patching the LISP code. Maybe the metalanguage used in ada-stmt.el -;;;could be taken even further, providing the user with some nice syntax -;;;for describing layout. Then my own hacks would survive the next -;;;update of the package :-) - - -;;; Code: - -(require 'ada-mode) -(load "skeleton") ;; bug in 19.28 through 19.30 skeleton.el, not provided. -(require 'easymenu) - -(defvar ada-stmt-use-debug t - "*Toggle to insert ada debug code parts.") - - -(defvar ada-debug-call-str "pragma Debug (%s);" - "*Debug call code to insert.") - - -(defvar ada-debug-exception-str "pragma Debug (%s);" - "*Debug exception code to insert." ) - - - -(defun ada-func-or-proc-name () - ;; Get the name of the current function or procedure." - (save-excursion - (let ((case-fold-search t)) - (if (re-search-backward ada-procedure-start-regexp nil t) - (buffer-substring (match-beginning 2) (match-end 2)) - "NAME?")))) - - -(defun ada-toggle-debugging () - "Toggles behaviour of `ada-debug-info-insertion'." - (interactive) - (setq ada-stmt-use-debug (not ada-stmt-use-debug)) - (if ada-stmt-use-debug - (message "Debugging enabled") - (message "Debugging disabled"))) - - -(defvar ada-template-map nil - "Keymap used in Ada mode for smart template operations.") - - -(let ((ada-mp (make-sparse-keymap))) - (define-key ada-mp "h" 'ada-header) -; (define-key ada-mp "p" 'ada-toggle-prompt-pseudo) - (define-key ada-mp "(" 'insert-parentheses) - (define-key ada-mp "\C-a" 'ada-array) - (define-key ada-mp "b" 'ada-exception-block) - (define-key ada-mp "d" 'ada-declare-block) - (define-key ada-mp "c" 'ada-case) - (define-key ada-mp "\C-e" 'ada-elsif) - (define-key ada-mp "e" 'ada-else) - (define-key ada-mp "\C-k" 'ada-package-spec) - (define-key ada-mp "k" 'ada-package-body) - (define-key ada-mp "\C-p" 'ada-procedure-spec) - (define-key ada-mp "\C-f" 'ada-function-spec) - (define-key ada-mp "p" 'ada-subprogram-body) - (define-key ada-mp "f" 'ada-for-loop) - (define-key ada-mp "i" 'ada-if) - (define-key ada-mp "l" 'ada-loop) - (define-key ada-mp "\C-r" 'ada-record) - (define-key ada-mp "\C-s" 'ada-subtype) - (define-key ada-mp "S" 'ada-tabsize) - (define-key ada-mp "\C-t" 'ada-task-spec) - (define-key ada-mp "t" 'ada-task-body) - (define-key ada-mp "\C-y" 'ada-type) - (define-key ada-mp "\C-v" 'ada-private) - (define-key ada-mp "u" 'ada-use) - (define-key ada-mp "\C-u" 'ada-with) - (define-key ada-mp "\C-w" 'ada-when) - (define-key ada-mp "w" 'ada-while-loop) - (define-key ada-mp "\C-x" 'ada-exception) - (define-key ada-mp "x" 'ada-exit) - (setq ada-template-map ada-mp)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Place the templates into Ada Mode. They may be inserted under any key. -;; C-c C-t will be the default. If you use templates alot, you -;; may want to consider moving the binding to another key in your .emacs -;; file. Be sure to (require 'ada-stmt) first. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;(define-key ada-mode-map "\C-ct" ada-template-map) -(define-key ada-mode-map "\C-c\C-t" ada-template-map) - -;;; ---- statement skeletons ------------------------------------------ - -(define-skeleton ada-array - "Insert array type definition. Uses the minibuffer to prompt -for component type and index subtypes." - () - "array (" ("index definition: " str ", " ) -2 ") of " _ ?\;) - - -(define-skeleton ada-case - "Build skeleton case statement, prompting for the selector expression. -Also builds the first when clause." - "[selector expression]: " - "case " str " is" \n - > "when " ("discrete choice: " str " | ") -3 " =>" \n - > _ \n - < < "end case;") - - -(define-skeleton ada-when - "Start a case statement alternative with a when clause." - () - < "when " ("discrete choice: " str " | ") -3 " =>" \n - >) - - -(define-skeleton ada-declare-block - "Insert a block with a declare part. -Indent for the first declaration." - "[block name]: " - < str & ?: & \n - > "declare" \n - > _ \n - < "begin" \n - > \n - < "end " str | -1 ?\;) - - -(define-skeleton ada-exception-block - "Insert a block with an exception part. -Indent for the first line of code." - "[block name]: " - < str & ?: & \n - > "begin" \n - > _ \n - < "exception" \n - > \n - < "end " str | -1 ?\;) - - -(define-skeleton ada-exception - "Insert an indented exception part into a block." - () - < "exception" \n - >) - - -(define-skeleton ada-exit-1 - "Insert then exit condition of the exit statement, prompting for condition." - "[exit condition]: " - "when " str | -5) - - -(define-skeleton ada-exit - "Insert an exit statement, prompting for loop name and condition." - "[name of loop to exit]: " - "exit " str & ?\ - (ada-exit-1) - | -1 ?\;) - - -(defun ada-header () - "Insert a descriptive header at the top of the file." - (interactive "*") - (save-excursion - (goto-char (point-min)) - (if (fboundp 'make-header) - (make-header) - (ada-header-tmpl)))) - - -(define-skeleton ada-header-tmpl - "Insert a comment block containing the module title, author, etc." - "[Description]: " - "-- -*- Mode: Ada -*-" - "\n-- Filename : " (buffer-name) - "\n-- Description : " str - "\n-- Author : " (user-full-name) - "\n-- Created On : " (current-time-string) - "\n-- Last Modified By: ." - "\n-- Last Modified On: ." - "\n-- Update Count : 0" - "\n-- Status : Unknown, Use with caution!" - "\n") - - -(define-skeleton ada-display-comment - "Inserts three comment lines, making a display comment." - () - "--\n-- " _ "\n--") - - -(define-skeleton ada-if - "Insert skeleton if statment, prompting for a boolean-expression." - "[condition]: " - "if " str " then" \n - > _ \n - < "end if;") - - -(define-skeleton ada-elsif - "Add an elsif clause to an if statement, -prompting for the boolean-expression." - "[condition]: " - < "elsif " str " then" \n - >) - - -(define-skeleton ada-else - "Add an else clause inside an if-then-end-if clause." - () - < "else" \n - >) - - -(define-skeleton ada-loop - "Insert a skeleton loop statement. The exit statement is added by hand." - "[loop name]: " - < str & ?: & \n - > "loop" \n - > _ \n - < "end loop " str | -1 ?\;) - - -(define-skeleton ada-for-loop-prompt-variable - "Prompt for the loop variable." - "[loop variable]: " - str) - - -(define-skeleton ada-for-loop-prompt-range - "Prompt for the loop range." - "[loop range]: " - str) - - -(define-skeleton ada-for-loop - "Build a skeleton for-loop statement, prompting for the loop parameters." - "[loop name]: " - < str & ?: & \n - > "for " - (ada-for-loop-prompt-variable) - " in " - (ada-for-loop-prompt-range) - " loop" \n - > _ \n - < "end loop " str | -1 ?\;) - - -(define-skeleton ada-while-loop-prompt-entry-condition - "Prompt for the loop entry condition." - "[entry condition]: " - str) - - -(define-skeleton ada-while-loop - "Insert a skeleton while loop statement." - "[loop name]: " - < str & ?: & \n - > "while " - (ada-while-loop-prompt-entry-condition) - " loop" \n - > _ \n - < "end loop " str | -1 ?\;) - - -(define-skeleton ada-package-spec - "Insert a skeleton package specification." - "[package name]: " - "package " str " is" \n - > _ \n - < "end " str ?\;) - - -(define-skeleton ada-package-body - "Insert a skeleton package body -- includes a begin statement." - "[package name]: " - "package body " str " is" \n - > _ \n -; < "begin" \n - < "end " str ?\;) - - -(define-skeleton ada-private - "Undent and start a private section of a package spec. Reindent." - () - < "private" \n - >) - - -(define-skeleton ada-function-spec-prompt-return - "Prompts for function result type." - "[result type]: " - str) - - -(define-skeleton ada-function-spec - "Insert a function specification. Prompts for name and arguments." - "[function name]: " - "function " str - " (" ("[parameter_specification]: " str "; " ) -2 ")" - " return " - (ada-function-spec-prompt-return) - ";" \n ) - - -(define-skeleton ada-procedure-spec - "Insert a procedure specification, prompting for its name and arguments." - "[procedure name]: " - "procedure " str - " (" ("[parameter_specification]: " str "; " ) -2 ")" - ";" \n ) - - -(define-skeleton ada-subprogram-body - "Insert frame for subprogram body. -Invoke right after `ada-function-spec' or `ada-procedure-spec'." - () - ;; Remove `;' from subprogram decl - (save-excursion - (ada-search-ignore-string-comment ada-subprog-start-re t nil) - (ada-search-ignore-string-comment "(" nil nil t) - (backward-char 1) - (forward-sexp 1) - (if (looking-at ";") - (delete-char 1))) - < "is" \n - > _ \n - < "begin" \n - > (if ada-stmt-use-debug - (format ada-debug-call-str (ada-func-or-proc-name))) \n - > \n - < (if ada-stmt-use-debug - "exception") & \n - > (if ada-stmt-use-debug - "when others =>") & \n - > (if ada-stmt-use-debug - (format ada-debug-exception-str (ada-func-or-proc-name))) \n - < < "end " - (ada-func-or-proc-name) - ?\;) - - -(define-skeleton ada-separate - "Finish a body stub with `separate'." - () - > "separate;" \n - <) - - -;(define-skeleton ada-with -; "Inserts a with clause, prompting for the list of units depended upon." -; "[list of units depended upon]: " -; "with " str ?\;) - -;(define-skeleton ada-use -; "Inserts a use clause, prompting for the list of packages used." -; "[list of packages used]: " -; "use " str ?\;) - - -(define-skeleton ada-record - "Insert a skeleton record type declaration." - () - "record" \n - > _ \n - < "end record;") - - -(define-skeleton ada-subtype - "Start insertion of a subtype declaration, prompting for the subtype name." - "[subtype name]: " - "subtype " str " is " _ ?\; - (not (message "insert subtype indication."))) - - -(define-skeleton ada-type - "Start insertion of a type declaration, prompting for the type name." - "[type name]: " - "type " str ?\( - ("[discriminant specs]: " str " ") - | (backward-delete-char 1) | ?\) - " is " - (not (message "insert type definition."))) - - -(define-skeleton ada-task-body - "Insert a task body, prompting for the task name." - "[task name]: " - "task body " str " is\n" - "begin\n" - > _ \n - < "end " str ";" ) - - -(define-skeleton ada-task-spec - "Insert a task specification, prompting for the task name." - "[task name]: " - "task " str - " (" ("[discriminant]: " str "; ") ") is\n" - > "entry " _ \n - <"end " str ";" ) - - -(define-skeleton ada-get-param1 - "Prompt for arguments and if any enclose them in brackets." - () - ("[parameter_specification]: " str "; " ) & -2 & ")" - ) - - -(define-skeleton ada-get-param - "Prompt for arguments and if any enclose them in brackets." - () - " (" - (ada-get-param1) | -2 - ) - - -(define-skeleton ada-entry - "Insert a task entry, prompting for the entry name." - "[entry name]: " - "entry " str - (ada-get-param) - ";" \n -; (ada-indent-current) -) - - -(define-skeleton ada-entry-family-prompt-discriminant - "Insert a entry specification, prompting for the entry name." - "[discriminant name]: " - str) - - -(define-skeleton ada-entry-family - "Insert a entry specification, prompting for the entry name." - "[entry name]: " - "entry " str - " (" (ada-entry-family-prompt-discriminant) ")" - (ada-get-param) - ";" \n - ;(ada-indent-current) -) - - -(define-skeleton ada-select - "Insert a select block." - () - "select\n" - > _ \n - < "end select;") - - -(define-skeleton ada-accept-1 - "Insert a condition statement, prompting for the condition name." - "[condition]: " - "when " str | -5 ) - - -(define-skeleton ada-accept-2 - "Insert an accept statement, prompting for the name and arguments." - "[accept name]: " - > "accept " str - (ada-get-param) -; " (" ("[parameter_specification]: " str "; ") -2 ")" - " do" \n - > _ \n - < "end " str ";" ) - - -(define-skeleton ada-accept - "Insert an accept statement (prompt for condition, name and arguments)." - () - > (ada-accept-1) & " =>\n" - (ada-accept-2) -) - - -(define-skeleton ada-or-accept - "Insert a or statement, prompting for the condition name." - () - < "or\n" - (ada-accept) -) - - -(define-skeleton ada-or-delay - "Insert a delay statement, prompting for the delay value." - "[delay value]: " - < "or\n" - > "delay " str ";") - - -(define-skeleton ada-or-terminate - "Insert a terminate statement." - () - < "or\n" - > "terminate;") - - -;; ---- -(defun ada-adjust-case-skeleton () - "Adjusts the case of the text inserted by a skeleton." - (save-excursion - (let ((aa-end (point))) - (ada-adjust-case-region - (progn (goto-char beg) (forward-word -1) (point)) - (goto-char aa-end)) - ))) - - -;; ---- add menu 'Statements' in Ada mode (MH) -(defun ada-add-statement-menu () - "Adds the menu 'Statements' to the menu bar in Ada mode." - (easy-menu-define ada-stmt-menu ada-mode-map - "Menu for statement templates in Ada." - '("Statements" -; ["Toggle Prompt/Pseudo Code" toggle-skeleton-no-prompt t] - ["Toggle: Debugging" ada-toggle-debugging t] -; ["-------" nil nil] - ["Header" (ada-header) t] - ["-------" nil nil] - ["package Body" (ada-package-body) t] - ["package Spec" (ada-package-spec) t] - ["function Spec" (ada-function-spec) t] - ["procedure Spec" (ada-procedure-spec) t] - ["proc/func Body" (ada-subprogram-body) t] - ["task Body" (ada-task-body) t] - ["task Spec" (ada-task-spec) t] - ["declare Block" (ada-declare-block) t] - ["exception Block" (ada-exception-block) t] - ["------" nil nil] - ["entry" (ada-entry) t] - ["entry family" (ada-entry-family) t] - ["select" (ada-select) t] - ["accept" (ada-accept) t] - ["or accept" (ada-or-accept) t] - ["or delay" (ada-or-delay) t] - ["or terminate" (ada-or-terminate) t] - ["-----" nil nil] - ["type" (ada-type) t] - ["private" (ada-private) t] - ["subtype" (ada-subtype) t] - ["record" (ada-record) t] - ["array" (ada-array) t] - ["------" nil nil] - ["if" (ada-if) t] - ["else" (ada-else) t] - ["elsif" (ada-elsif) t] - ["case" (ada-case) t] - ["-----" nil nil] - ["while Loop" (ada-while-loop) t] - ["for Loop" (ada-for-loop) t] - ["loop" (ada-loop) t] - ["---" nil nil] - ["exception" (ada-exception) t] - ["exit" (ada-exit) t] - ["when" (ada-when) t] - )) - (if (ada-xemacs) - (progn - (easy-menu-add ada-stmt-menu) - (setq mode-popup-menu (cons "Ada Mode" ada-stmt-menu))))) - - - -(add-hook 'ada-mode-hook 'ada-add-statement-menu) -(add-hook 'ada-mode-hook '(lambda () - (setq skeleton-further-elements - '((< '(backward-delete-char-untabify - (min ada-indent (current-column)))))) - (add-hook 'skeleton-end-hook - 'ada-adjust-case-skeleton))) - -(provide 'ada-stmt) - -;;; ada-stmt.el ends here
--- a/lisp/modes/arc-mode.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1594 +0,0 @@ -;;; arc-mode.el --- simple editing of archives - -;; Copyright (C) 1995 Free Software Foundation, Inc. - -;; Author: Morten Welinder (terra@diku.dk) -;; Keywords: archives msdog editing major-mode -;; Favourite-brand-of-beer: None, I hate beer. - -;; 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.34. - -;;; Commentary: - -;; NAMING: "arc" is short for "archive" and does not refer specifically -;; to files whose name end in ".arc" -;; -;; This code does not decode any files internally, although it does -;; understand the directory level of the archives. For this reason, -;; you should expect this code to need more fiddling than tar-mode.el -;; (although it at present has fewer bugs :-) In particular, I have -;; not tested this under Ms-Dog myself. -;; ------------------------------------- -;; INTERACTION: arc-mode.el should play together with -;; -;; * ange-ftp.el: Remote archives (i.e., ones that ange-ftp has brought -;; to you) are handled by doing all updates on a local -;; copy. When you make changes to a remote file the -;; changes will first take effect when the archive buffer -;; is saved. You will be warned about this. -;; -;; * dos-fns.el: (Part of Emacs 19). You get automatic ^M^J <--> ^J -;; conversion. -;; -;; arc-mode.el does not work well with crypt++.el; for the archives as -;; such this could be fixed (but wouldn't be useful) by declaring such -;; archives to be "remote". For the members this is a general Emacs -;; problem that 19.29's file formats may fix. -;; ------------------------------------- -;; ARCHIVE TYPES: Currently only the archives below are handled, but the -;; structure for handling just about anything is in place. -;; -;; Arc Lzh Zip Zoo -;; -------------------------------- -;; View listing Intern Intern Intern Intern -;; Extract member Y Y Y Y -;; Save changed member Y Y Y Y -;; Add new member N N N N -;; Delete member Y Y Y Y -;; Rename member Y Y N N -;; Chmod - Y Y - -;; Chown - Y - - -;; Chgrp - Y - - -;; -;; Special thanks to Bill Brodie <wbrodie@panix.com> for very useful tips -;; on the first released version of this package. -;; -;; This code is partly based on tar-mode.el from Emacs. -;; ------------------------------------- -;; ARCHIVE STRUCTURES: -;; (This is mostly for myself.) -;; -;; ARC A series of (header,file). No interactions among members. -;; -;; LZH A series of (header,file). Headers are checksummed. No -;; interaction among members. -;; -;; ZIP A series of (lheader,fil) followed by a "central directory" -;; which is a series of (cheader) followed by an end-of- -;; central-dir record possibly followed by junk. The e-o-c-d -;; links to c-d. cheaders link to lheaders which are basically -;; cut-down versions of the cheaders. -;; -;; ZOO An archive header followed by a series of (header,file). -;; Each member header points to the next. The archive is -;; terminated by a bogus header with a zero next link. -;; ------------------------------------- -;; HOOKS: `foo' means one of the supported archive types. -;; -;; archive-mode-hook -;; archive-foo-mode-hook -;; archive-extract-hooks - -;;; Code: - -;; ------------------------------------------------------------------------- -;; Section: Configuration. - -(defgroup archive nil - "Simple editing of archives." - :group 'data) - -(defgroup archive-arc nil - "ARC-specific options to archive." - :group 'archive) - -(defgroup archive-lzh nil - "LZH-specific options to archive." - :group 'archive) - -(defgroup archive-zip nil - "ZIP-specific options to archive." - :group 'archive) - -(defgroup archive-zoo nil - "ZOO-specific options to archive." - :group 'archive) - - -(defcustom archive-dos-members t - "*If non-nil then recognize member files using ^M^J as line terminator." - :type 'boolean - :group 'archive) - -(defcustom archive-tmpdir - (expand-file-name - (make-temp-name (if (eq system-type 'ms-dos) "ar" "archive.tmp")) - (or (getenv "TMPDIR") (getenv "TMP") "/tmp")) - "*Directory for temporary files made by arc-mode.el" - :type 'directory - :group 'archive) - -(defcustom archive-remote-regexp "^/[^/:]*[^/:.]:" - "*Regexp recognizing archive files names that are not local. -A non-local file is one whose file name is not proper outside Emacs. -A local copy of the archive will be used when updating." - :type 'regexp - :group 'archive) - -(defcustom archive-extract-hooks nil - "*Hooks to run when an archive member has been extracted." - :type 'hook - :group 'archive) -;; ------------------------------ -;; Arc archive configuration - -;; We always go via a local file since there seems to be no reliable way -;; to extract to stdout without junk getting added. -(defcustom archive-arc-extract - '("arc" "x") - "*Program and its options to run in order to extract an arc file member. -Extraction should happen to the current directory. Archive and member -name will be added." - :type '(list (string :tag "Program") - (repeat :tag "Options" - :inline t - (string :format "%v"))) - :group 'archive-arc) - -(defcustom archive-arc-expunge - '("arc" "d") - "*Program and its options to run in order to delete arc file members. -Archive and member names will be added." - :type '(list (string :tag "Program") - (repeat :tag "Options" - :inline t - (string :format "%v"))) - :group 'archive-arc) - -(defcustom archive-arc-write-file-member - '("arc" "u") - "*Program and its options to run in order to update an arc file member. -Archive and member name will be added." - :type '(list (string :tag "Program") - (repeat :tag "Options" - :inline t - (string :format "%v"))) - :group 'archive-arc) -;; ------------------------------ -;; Lzh archive configuration - -(defcustom archive-lzh-extract - '("lha" "pq") - "*Program and its options to run in order to extract an lzh file member. -Extraction should happen to standard output. Archive and member name will -be added." - :type '(list (string :tag "Program") - (repeat :tag "Options" - :inline t - (string :format "%v"))) - :group 'archive-lzh) - -(defcustom archive-lzh-expunge - '("lha" "d") - "*Program and its options to run in order to delete lzh file members. -Archive and member names will be added." - :type '(list (string :tag "Program") - (repeat :tag "Options" - :inline t - (string :format "%v"))) - :group 'archive-lzh) - -(defcustom archive-lzh-write-file-member - '("lha" "a") - "*Program and its options to run in order to update an lzh file member. -Archive and member name will be added." - :type '(list (string :tag "Program") - (repeat :tag "Options" - :inline t - (string :format "%v"))) - :group 'archive-lzh) -;; ------------------------------ -;; Zip archive configuration - -(defcustom archive-zip-use-pkzip (memq system-type '(ms-dos windows-nt)) - "*If non-nil then pkzip option are used instead of zip options. -Only set to true for msdog systems!" - :type 'boolean - :group 'archive-zip) - -(defcustom archive-zip-extract - (if archive-zip-use-pkzip '("pkunzip" "-e") '("unzip" "-qq" "-c")) - "*Program and its options to run in order to extract a zip file member. -Extraction should happen to standard output. Archive and member name will -be added. If `archive-zip-use-pkzip' is non-nil then this program is -expected to extract to a file junking the directory part of the name." - :type '(list (string :tag "Program") - (repeat :tag "Options" - :inline t - (string :format "%v"))) - :group 'archive-zip) - -;; For several reasons the latter behaviour is not desirable in general. -;; (1) It uses more disk space. (2) Error checking is worse or non- -;; existent. (3) It tends to do funny things with other systems' file -;; names. - -(defcustom archive-zip-expunge - (if archive-zip-use-pkzip '("pkzip" "-d") '("zip" "-d" "-q")) - "*Program and its options to run in order to delete zip file members. -Archive and member names will be added." - :type '(list (string :tag "Program") - (repeat :tag "Options" - :inline t - (string :format "%v"))) - :group 'archive-zip) - -(defcustom archive-zip-update - (if archive-zip-use-pkzip '("pkzip" "-u") '("zip" "-q")) - "*Program and its options to run in order to update a zip file member. -Options should ensure that specified directory will be put into the zip -file. Archive and member name will be added." - :type '(list (string :tag "Program") - (repeat :tag "Options" - :inline t - (string :format "%v"))) - :group 'archive-zip) - -(defcustom archive-zip-update-case - (if archive-zip-use-pkzip archive-zip-update '("zip" "-q" "-k")) - "*Program and its options to run in order to update a case fiddled zip member. -Options should ensure that specified directory will be put into the zip file. -Archive and member name will be added." - :type '(list (string :tag "Program") - (repeat :tag "Options" - :inline t - (string :format "%v"))) - :group 'archive-zip) - -(defcustom archive-zip-case-fiddle t - "*If non-nil then zip file members are case fiddled. -Case fiddling will only happen for members created by a system that -uses caseless file names." - :type 'boolean - :group 'archive-zip) -;; ------------------------------ -;; Zoo archive configuration - -(defcustom archive-zoo-extract - '("zoo" "xpq") - "*Program and its options to run in order to extract a zoo file member. -Extraction should happen to standard output. Archive and member name will -be added." - :type '(list (string :tag "Program") - (repeat :tag "Options" - :inline t - (string :format "%v"))) - :group 'archive-zoo) - -(defcustom archive-zoo-expunge - '("zoo" "DqPP") - "*Program and its options to run in order to delete zoo file members. -Archive and member names will be added." - :type '(list (string :tag "Program") - (repeat :tag "Options" - :inline t - (string :format "%v"))) - :group 'archive-zoo) - -(defcustom archive-zoo-write-file-member - '("zoo" "a") - "*Program and its options to run in order to update a zoo file member. -Archive and member name will be added." - :type '(list (string :tag "Program") - (repeat :tag "Options" - :inline t - (string :format "%v"))) - :group 'archive-zoo) -;; ------------------------------------------------------------------------- -;; Section: Variables - -(defvar archive-subtype nil "*Symbol describing archive type.") -(defvar archive-file-list-start nil "*Position of first contents line.") -(defvar archive-file-list-end nil "*Position just after last contents line.") -(defvar archive-proper-file-start nil "*Position of real archive's start.") -(defvar archive-read-only nil "*Non-nil if the archive is read-only on disk.") -(defvar archive-remote nil "*Non-nil if the archive is outside file system.") -(defvar archive-local-name nil "*Name of local copy of remote archive.") -(defvar archive-mode-map nil "*Local keymap for archive mode listings.") -(defvar archive-file-name-indent nil "*Column where file names start.") - -(defvar archive-alternate-display nil - "*Non-nil when alternate information is shown.") -(make-variable-buffer-local 'archive-alternate-display) -(put 'archive-alternate-display 'permanent-local t) - -(defvar archive-superior-buffer nil "*In archive members, points to archive.") -(put 'archive-superior-buffer 'permanent-local t) - -(defvar archive-subfile-mode nil "*Non-nil in archive member buffers.") -(make-variable-buffer-local 'archive-subfile-mode) -(put 'archive-subfile-mode 'permanent-local t) - -;; buffer-file-type is a per-buffer variable in the msdog configuration -(if (boundp 'buffer-file-type) nil - (defvar buffer-file-type nil - "*Nil for dos-style text file, non-nil otherwise.") - (make-variable-buffer-local 'buffer-file-type) - (put 'buffer-file-type 'permanent-local t) - (setq-default buffer-file-type nil)) - -(defvar archive-subfile-dos nil - "Negation of `buffer-file-type' which see.") -(make-variable-buffer-local 'archive-subfile-dos) -(put 'archive-subfile-dos 'permanent-local t) - -(defvar archive-files nil "Vector of file descriptors. Each descriptor is -a vector of [ext-file-name int-file-name case-fiddled mode ...]") -(make-variable-buffer-local 'archive-files) - -;; XEmacs change -(defvar archive-xemacs - (string-match "\\(Lucid\\|XEmacs\\)" emacs-version) - "*Non-nil when running under Lucid Emacs or XEmacs.") -;; ------------------------------------------------------------------------- -;; Section: Support functions. - -(defsubst archive-name (suffix) - (intern (concat "archive-" (symbol-name archive-subtype) "-" suffix))) - -(defun archive-l-e (str &optional len) - "Convert little endian string/vector to integer. -Alternatively, first argument may be a buffer position in the current buffer -in which case a second argument, length, should be supplied." - (if (stringp str) - (setq len (length str)) - (setq str (buffer-substring str (+ str len)))) - (let ((result 0) - (i 0)) - (while (< i len) - (setq i (1+ i) - result (+ (ash result 8) (aref str (- len i))))) - result)) - -(defun archive-int-to-mode (mode) - "Turn an integer like 0700 (i.e., 448) into a mode string like -rwx------" - (let ((str (make-string 10 ?-))) - (or (zerop (logand 16384 mode)) (aset str 0 ?d)) - (or (zerop (logand 8192 mode)) (aset str 0 ?c)) ; completeness - (or (zerop (logand 256 mode)) (aset str 1 ?r)) - (or (zerop (logand 128 mode)) (aset str 2 ?w)) - (or (zerop (logand 64 mode)) (aset str 3 ?x)) - (or (zerop (logand 32 mode)) (aset str 4 ?r)) - (or (zerop (logand 16 mode)) (aset str 5 ?w)) - (or (zerop (logand 8 mode)) (aset str 6 ?x)) - (or (zerop (logand 4 mode)) (aset str 7 ?r)) - (or (zerop (logand 2 mode)) (aset str 8 ?w)) - (or (zerop (logand 1 mode)) (aset str 9 ?x)) - (or (zerop (logand 1024 mode)) (aset str 3 (if (zerop (logand 64 mode)) - ?S ?s))) - (or (zerop (logand 2048 mode)) (aset str 6 (if (zerop (logand 8 mode)) - ?S ?s))) - str)) - -(defun archive-calc-mode (oldmode newmode &optional error) - "From the integer OLDMODE and the string NEWMODE calculate a new file mode. -NEWMODE may be an octal number including a leading zero in which case it -will become the new mode.\n -NEWMODE may also be a relative specification like \"og-rwx\" in which case -OLDMODE will be modified accordingly just like chmod(2) would have done.\n -If optional third argument ERROR is non-nil an error will be signaled if -the mode is invalid. If ERROR is nil then nil will be returned." - (cond ((string-match "^0[0-7]*$" newmode) - (let ((result 0) - (len (length newmode)) - (i 1)) - (while (< i len) - (setq result (+ (lsh result 3) (aref newmode i) (- ?0)) - i (1+ i))) - (logior (logand oldmode 65024) result))) - ((string-match "^\\([agou]+\\)\\([---+=]\\)\\([rwxst]+\\)$" newmode) - (let ((who 0) - (result oldmode) - (op (aref newmode (match-beginning 2))) - (bits 0) - (i (match-beginning 3))) - (while (< i (match-end 3)) - (let ((rwx (aref newmode i))) - (setq bits (logior bits (cond ((= rwx ?r) 292) - ((= rwx ?w) 146) - ((= rwx ?x) 73) - ((= rwx ?s) 3072) - ((= rwx ?t) 512))) - i (1+ i)))) - (while (< who (match-end 1)) - (let* ((whoc (aref newmode who)) - (whomask (cond ((= whoc ?a) 4095) - ((= whoc ?u) 1472) - ((= whoc ?g) 2104) - ((= whoc ?o) 7)))) - (if (= op ?=) - (setq result (logand result (lognot whomask)))) - (if (= op ?-) - (setq result (logand result (lognot (logand whomask bits)))) - (setq result (logior result (logand whomask bits))))) - (setq who (1+ who))) - result)) - (t - (if error - (error "Invalid mode specification: %s" newmode))))) - -(defun archive-dosdate (date) - "Stringify dos packed DATE record." - (let ((year (+ 1980 (logand (ash date -9) 127))) - (month (logand (ash date -5) 15)) - (day (logand date 31))) - (if (or (> month 12) (< month 1)) - "" - (format "%2d-%s-%d" - day - (aref ["Jan" "Feb" "Mar" "Apr" "May" "Jun" - "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"] (1- month)) - year)))) - -(defun archive-dostime (time) - "Stringify dos packed TIME record." - (let ((hour (logand (ash time -11) 31)) - (minute (logand (ash time -5) 53)) - (second (* 2 (logand time 31)))) ; 2 seconds resolution - (format "%02d:%02d:%02d" hour minute second))) - -;;(defun archive-unixdate (low high) -;; "Stringify unix (LOW HIGH) date." -;; (let ((str (current-time-string (cons high low)))) -;; (format "%s-%s-%s" -;; (substring str 8 9) -;; (substring str 4 7) -;; (substring str 20 24)))) - -;;(defun archive-unixtime (low high) -;; "Stringify unix (LOW HIGH) time." -;; (let ((str (current-time-string (cons high low)))) -;; (substring str 11 19))) - -(defun archive-get-lineno () - (if (>= (point) archive-file-list-start) - (count-lines archive-file-list-start - (save-excursion (beginning-of-line) (point))) - 0)) - -(defun archive-get-descr (&optional noerror) - "Return the descriptor vector for file at point. -Does not signal an error if optional second argument NOERROR is non-nil." - (let ((no (archive-get-lineno))) - (if (and (>= (point) archive-file-list-start) - (< no (length archive-files))) - (let ((item (aref archive-files no))) - (if (vectorp item) - item - (if (not noerror) - (error "Entry is not a regular member of the archive")))) - (if (not noerror) - (error "Line does not describe a member of the archive"))))) -;; ------------------------------------------------------------------------- -;; Section: the mode definition - -;;;###autoload -(defun archive-mode (&optional force) - "Major mode for viewing an archive file in a dired-like way. -You can move around using the usual cursor motion commands. -Letters no longer insert themselves. -Type `e' to pull a file out of the archive and into its own buffer; -or click mouse-2 on the file's line in the archive mode buffer. - -If you edit a sub-file of this archive (as with the `e' command) and -save it, the contents of that buffer will be saved back into the -archive. - -\\{archive-mode-map}" - ;; This is not interactive because you shouldn't be turning this - ;; mode on and off. You can corrupt things that way. - (if (zerop (buffer-size)) - ;; At present we cannot create archives from scratch - (funcall default-major-mode) - (if (and (not force) archive-files) nil - (let* ((type (archive-find-type)) - (typename (copy-sequence (symbol-name type)))) - (aset typename 0 (upcase (aref typename 0))) - (kill-all-local-variables) - (make-local-variable 'archive-subtype) - (setq archive-subtype type) - - ;; Buffer contains treated image of file before the file contents - (make-local-variable 'revert-buffer-function) - (setq revert-buffer-function 'archive-mode-revert) - (auto-save-mode 0) - (make-local-variable 'local-write-file-hooks) - (add-hook 'local-write-file-hooks 'archive-write-file) - - ;; Real file contents is binary - (make-local-variable 'require-final-newline) - (setq require-final-newline nil) - (make-local-variable 'enable-local-variables) - (setq enable-local-variables nil) - (setq buffer-file-type t) - - (make-local-variable 'archive-read-only) - (setq archive-read-only (not (file-writable-p (buffer-file-name)))) - - ;; Should we use a local copy when accessing from outside Emacs? - (make-local-variable 'archive-local-name) - (make-local-variable 'archive-remote) - (setq archive-remote (string-match archive-remote-regexp - (buffer-file-name))) - - (setq major-mode 'archive-mode) - (setq mode-name (concat typename "-Archive")) - ;; Run archive-foo-mode-hook and archive-mode-hook - (run-hooks (archive-name "mode-hook") 'archive-mode-hook) - (use-local-map archive-mode-map)) - - (make-local-variable 'archive-proper-file-start) - (make-local-variable 'archive-file-list-start) - (make-local-variable 'archive-file-list-end) - (make-local-variable 'archive-file-name-indent) - (archive-summarize) - (setq buffer-read-only t)))) - -;; Archive mode is suitable only for specially formatted data. -(put 'archive-mode 'mode-class 'special) - -(defun archive-quit () - "Bury the current archive buffer." - (interactive) - (bury-buffer)) - -;; ------------------------------------------------------------------------- -;; Section: Key maps - -(if archive-mode-map nil - (setq archive-mode-map (make-keymap)) - (suppress-keymap archive-mode-map) - (define-key archive-mode-map " " 'archive-next-line) - (define-key archive-mode-map "a" 'archive-alternate-display) - ;;(define-key archive-mode-map "c" 'archive-copy) - (define-key archive-mode-map "d" 'archive-flag-deleted) - (define-key archive-mode-map "\C-d" 'archive-flag-deleted) - (define-key archive-mode-map "e" 'archive-extract) - (define-key archive-mode-map "f" 'archive-extract) - (define-key archive-mode-map "\C-m" 'archive-extract) - (define-key archive-mode-map "g" 'revert-buffer) - (define-key archive-mode-map "h" 'describe-mode) - (define-key archive-mode-map "m" 'archive-mark) - (define-key archive-mode-map "n" 'archive-next-line) - (define-key archive-mode-map "\C-n" 'archive-next-line) - (define-key archive-mode-map [down] 'archive-next-line) - (define-key archive-mode-map "o" 'archive-extract-other-window) - (define-key archive-mode-map "p" 'archive-previous-line) - (define-key archive-mode-map "\C-p" 'archive-previous-line) - (define-key archive-mode-map [up] 'archive-previous-line) - (define-key archive-mode-map "r" 'archive-rename-entry) - (define-key archive-mode-map "u" 'archive-unflag) - (define-key archive-mode-map "\M-\C-?" 'archive-unmark-all-files) - (define-key archive-mode-map "v" 'archive-view) - (define-key archive-mode-map "x" 'archive-expunge) - (define-key archive-mode-map 'backspace 'archive-unflag-backwards) - (define-key archive-mode-map 'delete 'archive-unflag-backwards) - (define-key archive-mode-map "E" 'archive-extract-other-window) - (define-key archive-mode-map "M" 'archive-chmod-entry) - (define-key archive-mode-map "G" 'archive-chgrp-entry) - (define-key archive-mode-map "O" 'archive-chown-entry) - - (if archive-xemacs - (progn - ;; Not a nice "solution" but it'll have to do - (define-key archive-mode-map "q" 'archive-quit) - (define-key archive-mode-map "\C-xu" 'archive-undo) - (define-key archive-mode-map "\C-_" 'archive-undo)) - (substitute-key-definition 'undo 'archive-undo - archive-mode-map global-map)) - - (define-key archive-mode-map - (if archive-xemacs 'button2 [mouse-2]) 'archive-mouse-extract) - - (if archive-xemacs - () ; out of luck - ;; Get rid of the Edit menu bar item to save space. - (define-key archive-mode-map [menu-bar edit] 'undefined) - - (define-key archive-mode-map [menu-bar immediate] - (cons "Immediate" (make-sparse-keymap "Immediate"))) - (define-key archive-mode-map [menu-bar immediate alternate] - '("Alternate Display" . archive-alternate-display)) - (put 'archive-alternate-display 'menu-enable - '(boundp (archive-name "alternate-display"))) - (define-key archive-mode-map [menu-bar immediate view] - '("View This File" . archive-view)) - (define-key archive-mode-map [menu-bar immediate display] - '("Display in Other Window" . archive-display-other-window)) - (define-key archive-mode-map [menu-bar immediate find-file-other-window] - '("Find in Other Window" . archive-extract-other-window)) - (define-key archive-mode-map [menu-bar immediate find-file] - '("Find This File" . archive-extract)) - - (define-key archive-mode-map [menu-bar mark] - (cons "Mark" (make-sparse-keymap "Mark"))) - (define-key archive-mode-map [menu-bar mark unmark-all] - '("Unmark All" . archive-unmark-all-files)) - (define-key archive-mode-map [menu-bar mark deletion] - '("Flag" . archive-flag-deleted)) - (define-key archive-mode-map [menu-bar mark unmark] - '("Unflag" . archive-unflag)) - (define-key archive-mode-map [menu-bar mark mark] - '("Mark" . archive-mark)) - - (define-key archive-mode-map [menu-bar operate] - (cons "Operate" (make-sparse-keymap "Operate"))) - (define-key archive-mode-map [menu-bar operate chown] - '("Change Owner..." . archive-chown-entry)) - (put 'archive-chown-entry 'menu-enable - '(fboundp (archive-name "chown-entry"))) - (define-key archive-mode-map [menu-bar operate chgrp] - '("Change Group..." . archive-chgrp-entry)) - (put 'archive-chgrp-entry 'menu-enable - '(fboundp (archive-name "chgrp-entry"))) - (define-key archive-mode-map [menu-bar operate chmod] - '("Change Mode..." . archive-chmod-entry)) - (put 'archive-chmod-entry 'menu-enable - '(fboundp (archive-name "chmod-entry"))) - (define-key archive-mode-map [menu-bar operate rename] - '("Rename to..." . archive-rename-entry)) - (put 'archive-rename-entry 'menu-enable - '(fboundp (archive-name "rename-entry"))) - ;;(define-key archive-mode-map [menu-bar operate copy] - ;; '("Copy to..." . archive-copy)) - (define-key archive-mode-map [menu-bar operate expunge] - '("Expunge Marked Files" . archive-expunge)) - )) - -(let* ((item1 '(archive-subfile-mode " Archive")) - (item2 '(archive-subfile-dos " Dos")) - (items (if (memq system-type '(ms-dos windows-nt)) - (list item1) ; msdog has its own indicator - (list item1 item2)))) - (or (member item1 minor-mode-alist) - (setq minor-mode-alist (append items minor-mode-alist)))) -;; ------------------------------------------------------------------------- -(defun archive-find-type () - (widen) - (goto-char (point-min)) - ;; The funny [] here make it unlikely that the .elc file will be treated - ;; as an archive by other software. - (let (case-fold-search) - (cond ((looking-at "[P]K\003\004") 'zip) - ((looking-at "..-l[hz][0-9]-") 'lzh) - ((looking-at "....................[\334]\247\304\375") 'zoo) - ((and (looking-at "\C-z") ; signature too simple, IMHO - (string-match "\\.[aA][rR][cC]$" - (or buffer-file-name (buffer-name)))) - 'arc) - (t (error "Buffer format not recognized."))))) -;; ------------------------------------------------------------------------- -(defun archive-summarize () - "Parse the contents of the archive file in the current buffer. -Place a dired-like listing on the front; -then narrow to it, so that only that listing -is visible (and the real data of the buffer is hidden)." - (widen) - (let (buffer-read-only) - (message "Parsing archive file...") - (buffer-disable-undo (current-buffer)) - (setq archive-files (funcall (archive-name "summarize"))) - (message "Parsing archive file...done.") - (setq archive-proper-file-start (point-marker)) - (narrow-to-region (point-min) (point)) - (set-buffer-modified-p nil) - (buffer-enable-undo)) - (goto-char archive-file-list-start) - (archive-next-line 0)) - -(defun archive-resummarize () - "Recreate the contents listing of an archive." - (let ((modified (buffer-modified-p)) - (no (archive-get-lineno)) - buffer-read-only) - (widen) - (delete-region (point-min) archive-proper-file-start) - (archive-summarize) - (set-buffer-modified-p modified) - (goto-char archive-file-list-start) - (archive-next-line no))) - -(defun archive-summarize-files (files) - "Insert a description of a list of files annotated with proper mouse face" - (setq archive-file-list-start (point-marker)) - (setq archive-file-name-indent (if files (aref (car files) 1) 0)) - ;; We don't want to do an insert for each element since that takes too - ;; long when the archive -- which has to be moved in memory -- is large. - (insert - (apply - (function concat) - (mapcar - (function - (lambda (fil) - ;; Using `concat' here copies the text also, so we can add - ;; properties without problems. - (let ((text (concat (aref fil 0) "\n"))) - (if archive-xemacs - () ; out of luck - (put-text-property (aref fil 1) (aref fil 2) - 'mouse-face 'highlight - text)) - text))) - files))) - (setq archive-file-list-end (point-marker))) - -(defun archive-alternate-display () - "Toggle alternative display. -To avoid very long lines some archive mode don't show all information. -This function changes the set of information shown for each files." - (interactive) - (setq archive-alternate-display (not archive-alternate-display)) - (archive-resummarize)) -;; ------------------------------------------------------------------------- -;; Section: Local archive copy handling - -(defun archive-maybe-copy (archive) - (if archive-remote - (let ((start (point-max))) - (setq archive-local-name (expand-file-name - (file-name-nondirectory archive) - archive-tmpdir)) - (make-directory archive-tmpdir t) - (save-restriction - (widen) - (write-region start (point-max) archive-local-name nil 'nomessage)) - archive-local-name) - (if (buffer-modified-p) (save-buffer)) - archive)) - -(defun archive-maybe-update (unchanged) - (if archive-remote - (let ((name archive-local-name) - (modified (buffer-modified-p)) - buffer-read-only) - (if unchanged nil - (erase-buffer) - (insert-file-contents name) - (archive-mode t)) - (archive-delete-local name) - (if (not unchanged) - (message "Archive file must be saved for changes to take effect")) - (set-buffer-modified-p (or modified (not unchanged)))))) - -(defun archive-delete-local (name) - "Delete file NAME and its parents up to and including `archive-tmpdir'." - (let ((again t) - (top (directory-file-name (file-name-as-directory archive-tmpdir)))) - (condition-case nil - (delete-file name) - (error nil)) - (while again - (setq name (directory-file-name (file-name-directory name))) - (condition-case nil - (delete-directory name) - (error nil)) - (if (string= name top) (setq again nil))))) -;; ------------------------------------------------------------------------- -;; Section: Member extraction - -(defun archive-mouse-extract (event) - "Extract a file whose name you click on." - (interactive "e") - (mouse-set-point event) - (switch-to-buffer - (save-excursion - (archive-extract) - (current-buffer)))) - -(defun archive-extract (&optional other-window-p) - "In archive mode, extract this entry of the archive into its own buffer." - (interactive) - (let* ((view-p (eq other-window-p 'view)) - (descr (archive-get-descr)) - (ename (aref descr 0)) - (iname (aref descr 1)) - (archive-buffer (current-buffer)) - (arcdir default-directory) - (archive (buffer-file-name)) - (arcname (file-name-nondirectory archive)) - (bufname (concat (file-name-nondirectory iname) " (" arcname ")")) - (extractor (archive-name "extract")) - (read-only-p (or archive-read-only view-p)) - (buffer (get-buffer bufname)) - (just-created nil)) - (if buffer - nil - (setq archive (archive-maybe-copy archive)) - (setq buffer (get-buffer-create bufname)) - (setq just-created t) - (save-excursion - (set-buffer buffer) - (setq buffer-file-name - (expand-file-name (concat arcname ":" iname))) - (setq buffer-file-truename - (abbreviate-file-name buffer-file-name)) - ;; Set the default-directory to the dir of the superior buffer. - (setq default-directory arcdir) - (make-local-variable 'archive-superior-buffer) - (setq archive-superior-buffer archive-buffer) - (make-local-variable 'local-write-file-hooks) - (add-hook 'local-write-file-hooks 'archive-write-file-member) - (setq archive-subfile-mode descr) - (setq archive-subfile-dos nil - buffer-file-type t) - (if (fboundp extractor) - (funcall extractor archive ename) - (archive-*-extract archive ename (symbol-value extractor))) - (if archive-dos-members (archive-check-dos)) - (goto-char (point-min)) - (rename-buffer bufname) - (setq buffer-read-only read-only-p) - (setq buffer-undo-list nil) - (set-buffer-modified-p nil) - (setq buffer-saved-size (buffer-size)) - (normal-mode) - ;; Just in case an archive occurs inside another archive. - (if (eq major-mode 'archive-mode) - (setq archive-remote t)) - (run-hooks 'archive-extract-hooks)) - (archive-maybe-update t)) - (if view-p - (progn - (view-buffer buffer) - (and just-created (setq view-exit-action 'kill-buffer))) - (if (eq other-window-p 'display) - (display-buffer buffer) - (if other-window-p - (switch-to-buffer-other-window buffer) - (switch-to-buffer buffer)))))) - -(defun archive-*-extract (archive name command) - (let* ((default-directory (file-name-as-directory archive-tmpdir)) - (tmpfile (expand-file-name (file-name-nondirectory name) - default-directory))) - (make-directory (directory-file-name default-directory) t) - (apply 'call-process - (car command) - nil - nil - nil - (append (cdr command) (list archive name))) - (insert-file-contents tmpfile) - (archive-delete-local tmpfile))) - -(defun archive-extract-by-stdout (archive name command) - (let ((binary-process-output t)) ; for Ms-Dos - (apply 'call-process - (car command) - nil - t - nil - (append (cdr command) (list archive name))))) - -(defun archive-extract-other-window () - "In archive mode, find this member in another window." - (interactive) - (archive-extract t)) - -(defun archive-display-other-window () - "In archive mode, display this member in another window." - (interactive) - (archive-extract 'display)) - -(defun archive-view () - "In archive mode, view the member on this line." - (interactive) - (archive-extract 'view)) - -(defun archive-add-new-member (arcbuf name) - "Add current buffer to the archive in ARCBUF naming it NAME." - (interactive - (list (get-buffer - (read-buffer "Buffer containing archive: " - ;; Find first archive buffer and suggest that - (let ((bufs (buffer-list))) - (while (and bufs (not (eq (save-excursion - (set-buffer (car bufs)) - major-mode) - 'archive-mode))) - (setq bufs (cdr bufs))) - (if bufs - (car bufs) - (error "There are no archive buffers"))) - t)) - (read-string "File name in archive: " - (if buffer-file-name - (file-name-nondirectory buffer-file-name) - "")))) - (save-excursion - (set-buffer arcbuf) - (or (eq major-mode 'archive-mode) - (error "Buffer is not an archive buffer")) - (if archive-read-only - (error "Archive is read-only"))) - (if (eq arcbuf (current-buffer)) - (error "An archive buffer cannot be added to itself")) - (if (string= name "") - (error "Archive members may not be given empty names")) - (let ((func (save-excursion (set-buffer arcbuf) - (archive-name "add-new-member"))) - (membuf (current-buffer))) - (if (fboundp func) - (save-excursion - (set-buffer arcbuf) - (funcall func buffer-file-name membuf name)) - (error "Adding a new member is not supported for this archive type")))) -;; ------------------------------------------------------------------------- -;; Section: IO stuff - -(defun archive-check-dos (&optional force) - "*Possibly handle a buffer with ^M^J terminated lines." - (save-restriction - (widen) - (save-excursion - (goto-char (point-min)) - (setq archive-subfile-dos - (or force (not (search-forward-regexp "[^\r]\n" nil t)))) - (setq buffer-file-type (not archive-subfile-dos)) - (if archive-subfile-dos - (let ((modified (buffer-modified-p))) - (buffer-disable-undo (current-buffer)) - (goto-char (point-min)) - (while (search-forward "\r\n" nil t) - (replace-match "\n")) - (buffer-enable-undo) - (set-buffer-modified-p modified)))))) - -(defun archive-write-file-member () - (if archive-subfile-dos - (save-restriction - (widen) - (save-excursion - (goto-char (point-min)) - ;; We don't want our ^M^J <--> ^J changes to show in the undo list - (let ((undo-list buffer-undo-list)) - (unwind-protect - (progn - (setq buffer-undo-list t) - (while (search-forward "\n" nil t) - (replace-match "\r\n")) - (setq archive-subfile-dos nil) - (setq buffer-file-type t) - ;; OK, we're now have explicit ^M^Js -- save and re-unixfy - (archive-write-file-member)) - (progn - (archive-check-dos t) - (setq buffer-undo-list undo-list)))) - t)) - (save-excursion - (save-restriction - (message "Updating archive...") - (widen) - (let ((writer (save-excursion (set-buffer archive-superior-buffer) - (archive-name "write-file-member"))) - (archive (save-excursion (set-buffer archive-superior-buffer) - (buffer-file-name)))) - (if (fboundp writer) - (funcall writer archive archive-subfile-mode) - (archive-*-write-file-member archive - archive-subfile-mode - (symbol-value writer)))) - (set-buffer-modified-p nil) - (message "Updating archive...done") - (set-buffer archive-superior-buffer) - (revert-buffer) - t)))) - -(defun archive-*-write-file-member (archive descr command) - (let* ((ename (aref descr 0)) - (tmpfile (expand-file-name ename archive-tmpdir)) - (top (directory-file-name (file-name-as-directory archive-tmpdir))) - (default-directory (file-name-as-directory top))) - (unwind-protect - (progn - (make-directory (file-name-directory tmpfile) t) - (write-region (point-min) (point-max) tmpfile nil 'nomessage) - (if (aref descr 3) - ;; Set the file modes, but make sure we can read it. - (set-file-modes tmpfile (logior ?\400 (aref descr 3)))) - (let ((exitcode (apply 'call-process - (car command) - nil - nil - nil - (append (cdr command) (list archive ename))))) - (if (equal exitcode 0) - nil - (error "Updating was unsuccessful (%S)" exitcode)))) - (archive-delete-local tmpfile)))) - -(defun archive-write-file () - (save-excursion - (write-region archive-proper-file-start (point-max) buffer-file-name nil t) - (set-buffer-modified-p nil) - t)) -;; ------------------------------------------------------------------------- -;; Section: Marking and unmarking. - -(defun archive-flag-deleted (p &optional type) - "In archive mode, mark this member to be deleted from the archive. -With a prefix argument, mark that many files." - (interactive "p") - (or type (setq type ?D)) - (beginning-of-line) - (let ((sign (if (>= p 0) +1 -1)) - (modified (buffer-modified-p)) - buffer-read-only) - (while (not (zerop p)) - (if (archive-get-descr t) - (progn - (delete-char 1) - (insert type))) - (forward-line sign) - (setq p (- p sign))) - (set-buffer-modified-p modified)) - (archive-next-line 0)) - -(defun archive-unflag (p) - "In archive mode, un-mark this member if it is marked to be deleted. -With a prefix argument, un-mark that many files forward." - (interactive "p") - (archive-flag-deleted p ? )) - -(defun archive-unflag-backwards (p) - "In archive mode, un-mark this member if it is marked to be deleted. -With a prefix argument, un-mark that many members backward." - (interactive "p") - (archive-flag-deleted (- p) ? )) - -(defun archive-unmark-all-files () - "Remove all marks." - (interactive) - (let ((modified (buffer-modified-p)) - buffer-read-only) - (save-excursion - (goto-char archive-file-list-start) - (while (< (point) archive-file-list-end) - (or (= (following-char) ? ) - (progn (delete-char 1) (insert ? ))) - (forward-line 1))) - (set-buffer-modified-p modified))) - -(defun archive-mark (p) - "In archive mode, mark this member for group operations. -With a prefix argument, mark that many members. -Use \\[archive-unmark-all-files] to remove all marks." - (interactive "p") - (archive-flag-deleted p ?*)) - -(defun archive-get-marked (mark &optional default) - (let (files) - (save-excursion - (goto-char archive-file-list-start) - (while (< (point) archive-file-list-end) - (if (= (following-char) mark) - (setq files (cons (archive-get-descr) files))) - (forward-line 1))) - (or (nreverse files) - (and default - (list (archive-get-descr)))))) -;; ------------------------------------------------------------------------- -;; Section: Operate - -(defun archive-next-line (p) - (interactive "p") - (forward-line p) - (or (eobp) - (forward-char archive-file-name-indent))) - -(defun archive-previous-line (p) - (interactive "p") - (archive-next-line (- p))) - -(defun archive-chmod-entry (new-mode) - "Change the protection bits associated with all marked or this member. -The new protection bits can either be specified as an octal number or -as a relative change like \"g+rw\" as for chmod(2)" - (interactive "sNew mode (octal or relative): ") - (if archive-read-only (error "Archive is read-only")) - (let ((func (archive-name "chmod-entry"))) - (if (fboundp func) - (progn - (funcall func new-mode (archive-get-marked ?* t)) - (archive-resummarize)) - (error "Setting mode bits is not supported for this archive type")))) - -(defun archive-chown-entry (new-uid) - "Change the owner of all marked or this member." - (interactive "nNew uid: ") - (if archive-read-only (error "Archive is read-only")) - (let ((func (archive-name "chown-entry"))) - (if (fboundp func) - (progn - (funcall func new-uid (archive-get-marked ?* t)) - (archive-resummarize)) - (error "Setting owner is not supported for this archive type")))) - -(defun archive-chgrp-entry (new-gid) - "Change the group of all marked or this member." - (interactive "nNew gid: ") - (if archive-read-only (error "Archive is read-only")) - (let ((func (archive-name "chgrp-entry"))) - (if (fboundp func) - (progn - (funcall func new-gid (archive-get-marked ?* t)) - (archive-resummarize)) - (error "Setting group is not supported for this archive type")))) - -(defun archive-expunge () - "Do the flagged deletions." - (interactive) - (let (files) - (save-excursion - (goto-char archive-file-list-start) - (while (< (point) archive-file-list-end) - (if (= (following-char) ?D) - (setq files (cons (aref (archive-get-descr) 0) files))) - (forward-line 1))) - (setq files (nreverse files)) - (and files - (or (not archive-read-only) - (error "Archive is read-only")) - (or (yes-or-no-p (format "Really delete %d member%s? " - (length files) - (if (null (cdr files)) "" "s"))) - (error "Operation aborted")) - (let ((archive (archive-maybe-copy (buffer-file-name))) - (expunger (archive-name "expunge"))) - (if (fboundp expunger) - (funcall expunger archive files) - (archive-*-expunge archive files (symbol-value expunger))) - (archive-maybe-update nil) - (if archive-remote - (archive-resummarize) - (revert-buffer)))))) - -(defun archive-*-expunge (archive files command) - (apply 'call-process - (car command) - nil - nil - nil - (append (cdr command) (cons archive files)))) - -(defun archive-rename-entry (newname) - "Change the name associated with this entry in the tar file." - (interactive "sNew name: ") - (if archive-read-only (error "Archive is read-only")) - (if (string= newname "") - (error "Archive members may not be given empty names")) - (let ((func (archive-name "rename-entry")) - (descr (archive-get-descr))) - (if (fboundp func) - (progn - (funcall func (buffer-file-name) newname descr) - (archive-resummarize)) - (error "Renaming is not supported for this archive type")))) - -;; Revert the buffer and recompute the dired-like listing. -(defun archive-mode-revert (&optional no-autosave no-confirm) - (let ((no (archive-get-lineno))) - (setq archive-files nil) - (let ((revert-buffer-function nil)) - (revert-buffer t t)) - (archive-mode) - (goto-char archive-file-list-start) - (archive-next-line no))) - -(defun archive-undo () - "Undo in an archive buffer. -This doesn't recover lost files, it just undoes changes in the buffer itself." - (interactive) - (let (buffer-read-only) - (undo))) -;; ------------------------------------------------------------------------- -;; Section: Arc Archives - -(defun archive-arc-summarize () - (let ((p 1) - (totalsize 0) - (maxlen 8) - files - visual) - (while (and (< (+ p 29) (point-max)) - (eq (char-after p) ?\C-z) - (> (char-after (1+ p)) 0)) - (let* ((namefld (buffer-substring (+ p 2) (+ p 2 13))) - (fnlen (or (string-match "\0" namefld) 13)) - (efnname (substring namefld 0 fnlen)) - (csize (archive-l-e (+ p 15) 4)) - (moddate (archive-l-e (+ p 19) 2)) - (modtime (archive-l-e (+ p 21) 2)) - (ucsize (archive-l-e (+ p 25) 4)) - (fiddle (string= efnname (upcase efnname))) - (ifnname (if fiddle (downcase efnname) efnname)) - (text (format " %8d %-11s %-8s %s" - ucsize - (archive-dosdate moddate) - (archive-dostime modtime) - ifnname))) - (setq maxlen (max maxlen fnlen) - totalsize (+ totalsize ucsize) - visual (cons (vector text - (- (length text) (length ifnname)) - (length text)) - visual) - files (cons (vector efnname ifnname fiddle nil (1- p)) - files) - p (+ p 29 csize)))) - (goto-char (point-min)) - (let ((dash (concat "- -------- ----------- -------- " - (make-string maxlen ?-) - "\n"))) - (insert "M Length Date Time File\n" - dash) - (archive-summarize-files (nreverse visual)) - (insert dash - (format " %8d %d file%s" - totalsize - (length files) - (if (= 1 (length files)) "" "s")) - "\n")) - (apply 'vector (nreverse files)))) - -(defun archive-arc-rename-entry (archive newname descr) - (if (string-match "[:\\\\/]" newname) - (error "File names in arc files may not contain a path")) - (if (> (length newname) 12) - (error "File names in arc files are limited to 12 characters")) - (let ((name (concat newname (substring "\0\0\0\0\0\0\0\0\0\0\0\0\0" - (length newname)))) - buffer-read-only) - (save-restriction - (save-excursion - (widen) - (goto-char (+ archive-proper-file-start (aref descr 4) 2)) - (delete-char 13) - (insert name))))) -;; ------------------------------------------------------------------------- -;; Section: Lzh Archives - -(defun archive-lzh-summarize () - (let ((p 1) - (totalsize 0) - (maxlen 8) - files - visual) - (while (progn (goto-char p) (looking-at "..-l[hz][0-9]-")) - (let* ((hsize (char-after p)) - (csize (archive-l-e (+ p 7) 4)) - (ucsize (archive-l-e (+ p 11) 4)) - (modtime (archive-l-e (+ p 15) 2)) - (moddate (archive-l-e (+ p 17) 2)) - (fnlen (char-after (+ p 21))) - (efnname (buffer-substring (+ p 22) (+ p 22 fnlen))) - (fiddle (string= efnname (upcase efnname))) - (ifnname (if fiddle (downcase efnname) efnname)) - (p2 (+ p 22 fnlen)) - (creator (if (>= (- hsize fnlen) 24) (char-after (+ p2 2)) 0)) - (mode (if (eq creator ?U) (archive-l-e (+ p2 8) 2) ?\666)) - (modestr (if mode (archive-int-to-mode mode) "??????????")) - (uid (if (eq creator ?U) (archive-l-e (+ p2 10) 2))) - (gid (if (eq creator ?U) (archive-l-e (+ p2 12) 2))) - (text (if archive-alternate-display - (format " %8d %5S %5S %s" - ucsize - (or uid "?") - (or gid "?") - ifnname) - (format " %10s %8d %-11s %-8s %s" - modestr - ucsize - (archive-dosdate moddate) - (archive-dostime modtime) - ifnname)))) - (setq maxlen (max maxlen fnlen) - totalsize (+ totalsize ucsize) - visual (cons (vector text - (- (length text) (length ifnname)) - (length text)) - visual) - files (cons (vector efnname ifnname fiddle mode (1- p)) - files) - p (+ p hsize 2 csize)))) - (goto-char (point-min)) - (let ((dash (concat (if archive-alternate-display - "- -------- ----- ----- " - "- ---------- -------- ----------- -------- ") - (make-string maxlen ?-) - "\n")) - (header (if archive-alternate-display - "M Length Uid Gid File\n" - "M Filemode Length Date Time File\n")) - (sumline (if archive-alternate-display - " %8d %d file%s" - " %8d %d file%s"))) - (insert header dash) - (archive-summarize-files (nreverse visual)) - (insert dash - (format sumline - totalsize - (length files) - (if (= 1 (length files)) "" "s")) - "\n")) - (apply 'vector (nreverse files)))) - -(defconst archive-lzh-alternate-display t) - -(defun archive-lzh-extract (archive name) - (archive-extract-by-stdout archive name archive-lzh-extract)) - -(defun archive-lzh-resum (p count) - (let ((sum 0)) - (while (> count 0) - (setq count (1- count) - sum (+ sum (char-after p)) - p (1+ p))) - (logand sum 255))) - -(defun archive-lzh-rename-entry (archive newname descr) - (save-restriction - (save-excursion - (widen) - (let* ((p (+ archive-proper-file-start (aref descr 4))) - (oldhsize (char-after p)) - (oldfnlen (char-after (+ p 21))) - (newfnlen (length newname)) - (newhsize (+ oldhsize newfnlen (- oldfnlen))) - buffer-read-only) - (if (> newhsize 255) - (error "The file name is too long")) - (goto-char (+ p 21)) - (delete-char (1+ oldfnlen)) - (insert newfnlen newname) - (goto-char p) - (delete-char 2) - (insert newhsize (archive-lzh-resum p newhsize)))))) - -(defun archive-lzh-ogm (newval files errtxt ofs) - (save-restriction - (save-excursion - (widen) - (while files - (let* ((fil (car files)) - (p (+ archive-proper-file-start (aref fil 4))) - (hsize (char-after p)) - (fnlen (char-after (+ p 21))) - (p2 (+ p 22 fnlen)) - (creator (if (>= (- hsize fnlen) 24) (char-after (+ p2 2)) 0)) - buffer-read-only) - (if (= creator ?U) - (progn - (or (numberp newval) - (setq newval (funcall newval (archive-l-e (+ p2 ofs) 2)))) - (goto-char (+ p2 ofs)) - (delete-char 2) - (insert (logand newval 255) (lsh newval -8)) - (goto-char (1+ p)) - (delete-char 1) - (insert (archive-lzh-resum (1+ p) hsize))) - (message "Member %s does not have %s field" - (aref fil 1) errtxt))) - (setq files (cdr files)))))) - -(defun archive-lzh-chown-entry (newuid files) - (archive-lzh-ogm newuid files "an uid" 10)) - -(defun archive-lzh-chgrp-entry (newgid files) - (archive-lzh-ogm newgid files "a gid" 12)) - -(defun archive-lzh-chmod-entry (newmode files) - (archive-lzh-ogm - ;; This should work even though newmode will be dynamically accessed. - (function (lambda (old) (archive-calc-mode old newmode t))) - files "a unix-style mode" 8)) -;; ------------------------------------------------------------------------- -;; Section: Zip Archives - -(defun archive-zip-summarize () - (goto-char (- (point-max) (- 22 18))) - (search-backward-regexp "[P]K\005\006") - (let ((p (1+ (archive-l-e (+ (point) 16) 4))) - (maxlen 8) - (totalsize 0) - files - visual) - (while (string= "PK\001\002" (buffer-substring p (+ p 4))) - (let* ((creator (char-after (+ p 5))) - (method (archive-l-e (+ p 10) 2)) - (modtime (archive-l-e (+ p 12) 2)) - (moddate (archive-l-e (+ p 14) 2)) - (ucsize (archive-l-e (+ p 24) 4)) - (fnlen (archive-l-e (+ p 28) 2)) - (exlen (archive-l-e (+ p 30) 2)) - (fclen (archive-l-e (+ p 32) 2)) - (lheader (archive-l-e (+ p 42) 4)) - (efnname (buffer-substring (+ p 46) (+ p 46 fnlen))) - (isdir (and (= ucsize 0) - (string= (file-name-nondirectory efnname) ""))) - (mode (cond ((memq (char-int creator) '(2 3)) ; Unix + VMS - (archive-l-e (+ p 40) 2)) - ((memq (char-int creator) - '(0 5 6 7 10 11)) ; Dos etc. - (logior ?\444 - (if isdir (logior 16384 ?\111) 0) - (if (zerop - (logand 1 (char-after (+ p 38)))) - ?\222 0))) - (t nil))) - (modestr (if mode (archive-int-to-mode mode) "??????????")) - (fiddle (and archive-zip-case-fiddle - (not (not (memq (char-int creator) '(0 2 4 5 9)))))) - (ifnname (if fiddle (downcase efnname) efnname)) - (text (format " %10s %8d %-11s %-8s %s" - modestr - ucsize - (archive-dosdate moddate) - (archive-dostime modtime) - ifnname))) - (setq maxlen (max maxlen fnlen) - totalsize (+ totalsize ucsize) - visual (cons (vector text - (- (length text) (length ifnname)) - (length text)) - visual) - files (cons (if isdir - nil - (vector efnname ifnname fiddle mode - (list (1- p) lheader))) - files) - p (+ p 46 fnlen exlen fclen)))) - (goto-char (point-min)) - (let ((dash (concat "- ---------- -------- ----------- -------- " - (make-string maxlen ?-) - "\n"))) - (insert "M Filemode Length Date Time File\n" - dash) - (archive-summarize-files (nreverse visual)) - (insert dash - (format " %8d %d file%s" - totalsize - (length files) - (if (= 1 (length files)) "" "s")) - "\n")) - (apply 'vector (nreverse files)))) - -(defun archive-zip-extract (archive name) - (if archive-zip-use-pkzip - (archive-*-extract archive name archive-zip-extract) - (archive-extract-by-stdout archive name archive-zip-extract))) - -(defun archive-zip-write-file-member (archive descr) - (archive-*-write-file-member - archive - descr - (if (aref descr 2) archive-zip-update-case archive-zip-update))) - -(defun archive-zip-chmod-entry (newmode files) - (save-restriction - (save-excursion - (widen) - (while files - (let* ((fil (car files)) - (p (+ archive-proper-file-start (car (aref fil 4)))) - (creator (char-after (+ p 5))) - (oldmode (aref fil 3)) - (newval (archive-calc-mode oldmode newmode t)) - buffer-read-only) - (cond ((memq (char-int creator) '(2 3)) ; Unix + VMS - (goto-char (+ p 40)) - (delete-char 2) - (insert (logand newval 255) (lsh newval -8))) - ((memq (char-int creator) '(0 5 6 7 10 11)) ; Dos etc. - (goto-char (+ p 38)) - (insert (logior (logand (char-after (point)) 254) - (logand (logxor 1 (lsh newval -7)) 1))) - (delete-char 1)) - (t (message "Don't know how to change mode for this member")))) - (setq files (cdr files)))))) -;; ------------------------------------------------------------------------- -;; Section: Zoo Archives - -(defun archive-zoo-summarize () - (let ((p (1+ (archive-l-e 25 4))) - (maxlen 8) - (totalsize 0) - files - visual) - (while (and (string= "\334\247\304\375" (buffer-substring p (+ p 4))) - (> (archive-l-e (+ p 6) 4) 0)) - (let* ((next (1+ (archive-l-e (+ p 6) 4))) - (moddate (archive-l-e (+ p 14) 2)) - (modtime (archive-l-e (+ p 16) 2)) - (ucsize (archive-l-e (+ p 20) 4)) - (namefld (buffer-substring (+ p 38) (+ p 38 13))) - (dirtype (char-after (+ p 4))) - (lfnlen (if (= dirtype 2) (char-after (+ p 56)) 0)) - (ldirlen (if (= dirtype 2) (char-after (+ p 57)) 0)) - (fnlen (+ ldirlen - (if (> lfnlen 0) - (1- lfnlen) - (or (string-match "\0" namefld) 13)))) - (efnname (concat - (if (> ldirlen 0) - (concat (buffer-substring - (+ p 58 lfnlen) (+ p 58 lfnlen ldirlen -1)) - "/") - "") - (if (> lfnlen 0) - (buffer-substring (+ p 58) (+ p 58 lfnlen -1)) - (substring namefld 0 fnlen)))) - (fiddle (and (= lfnlen 0) (string= efnname (upcase efnname)))) - (ifnname (if fiddle (downcase efnname) efnname)) - (text (format " %8d %-11s %-8s %s" - ucsize - (archive-dosdate moddate) - (archive-dostime modtime) - ifnname))) - (setq maxlen (max maxlen fnlen) - totalsize (+ totalsize ucsize) - visual (cons (vector text - (- (length text) (length ifnname)) - (length text)) - visual) - files (cons (vector efnname ifnname fiddle nil (1- p)) - files) - p next))) - (goto-char (point-min)) - (let ((dash (concat "- -------- ----------- -------- " - (make-string maxlen ?-) - "\n"))) - (insert "M Length Date Time File\n" - dash) - (archive-summarize-files (nreverse visual)) - (insert dash - (format " %8d %d file%s" - totalsize - (length files) - (if (= 1 (length files)) "" "s")) - "\n")) - (apply 'vector (nreverse files)))) - -(defun archive-zoo-extract (archive name) - (archive-extract-by-stdout archive name archive-zoo-extract)) -;; ------------------------------------------------------------------------- -(provide 'archive-mode) - -;;; arc-mode.el ends here.
--- a/lisp/modes/asm-mode.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,261 +0,0 @@ -;;; asm-mode.el --- mode for editing assembler code - -;; Copyright (C) 1991 Free Software Foundation, Inc. - -;; Author: Eric S. Raymond <esr@snark.thyrsus.com> -;; Maintainer: FSF -;; Keywords: tools, languages - -;; 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.34. - -;;; Commentary: - -;; This mode was written by Eric S. Raymond <esr@snark.thyrsus.com>, -;; inspired by an earlier asm-mode by Martin Neitzel. - -;; This minor mode is based on text mode. It defines a private abbrev table -;; that can be used to save abbrevs for assembler mnemonics. It binds just -;; five keys: -;; -;; TAB tab to next tab stop -;; : outdent preceding label, tab to tab stop -;; comment char place or move comment -;; asm-comment-char specifies which character this is; -;; you can use a different character in different -;; Asm mode buffers. -;; C-j, C-m newline and tab to tab stop -;; -;; Code is indented to the first tab stop level. - -;; This mode runs two hooks: -;; 1) An asm-mode-set-comment-hook before the part of the initialization -;; depending on asm-comment-char, and -;; 2) an asm-mode-hook at the end of initialization. - -;;; Code: - -(defgroup asm nil - "Assembler programming" - :group 'languages) - - -(defcustom asm-comment-char ?; - "*The comment-start character assumed by Asm mode." - :type 'sexp - :group 'asm) - -;; XEmacs change (This is the primary difference, why was this -;; feature removed? -sb) -(defcustom asm-support-c-comments-p t - "*Support C style comments. If t C style comments will be -supported. This is mainly for the benefit of font-lock." - :type 'boolean - :group 'asm) - -(defcustom asm-mode-syntax-table nil - "Syntax table used while in Asm mode.") - -(defvar asm-mode-abbrev-table nil - "Abbrev table used while in Asm mode.") -(define-abbrev-table 'asm-mode-abbrev-table ()) - -(defvar asm-mode-map nil - "Keymap for Asm mode.") - -(if asm-mode-map - nil - ;; XEmacs change - (setq asm-mode-map (make-sparse-keymap 'asm-mode-map)) - ;; Note that the comment character isn't set up until asm-mode is called. - (define-key asm-mode-map ":" 'asm-colon) - (define-key asm-mode-map "\C-c;" 'comment-region) - (define-key asm-mode-map "\C-i" 'tab-to-tab-stop) - (define-key asm-mode-map "\C-j" 'asm-newline) - (define-key asm-mode-map "\C-m" 'asm-newline) - ) - -(defconst asm-font-lock-keywords - '(("^\\(\\(\\sw\\|\\s_\\)+\\)\\>:?[ \t]*\\(\\sw+\\)?" - (1 font-lock-function-name-face) (3 font-lock-keyword-face nil t)) - ("^\\s +\\(\\(\\sw\\|\\s_\\)+\\)" 1 font-lock-keyword-face)) - "Additional expressions to highlight in Assembler mode.") - -;; XEmacs change -(put 'asm-mode 'font-lock-defaults '(asm-font-lock-keywords)) -(defvar asm-code-level-empty-comment-pattern nil) -(defvar asm-flush-left-empty-comment-pattern nil) -(defvar asm-inline-empty-comment-pattern nil) - -;;;###autoload -(defun asm-mode () - "Major mode for editing typical assembler code. -Features a private abbrev table and the following bindings: - -\\[asm-colon]\toutdent a preceding label, tab to next tab stop. -\\[tab-to-tab-stop]\ttab to next tab stop. -\\[asm-newline]\tnewline, then tab to next tab stop. -\\[asm-comment]\tsmart placement of assembler comments. - -The character used for making comments is set by the variable -`asm-comment-char' (which defaults to `?;'). - -Alternatively, you may set this variable in `asm-mode-set-comment-hook', -which is called near the beginning of mode initialization. - -Turning on Asm mode runs the hook `asm-mode-hook' at the end of initialization. - -Special commands: -\\{asm-mode-map} -" - (interactive) - (kill-all-local-variables) - (setq mode-name "Assembler") - (setq major-mode 'asm-mode) - (setq local-abbrev-table asm-mode-abbrev-table) - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults '(asm-font-lock-keywords)) - (make-local-variable 'asm-mode-syntax-table) - (setq asm-mode-syntax-table (make-syntax-table)) - (set-syntax-table asm-mode-syntax-table) - - (run-hooks 'asm-mode-set-comment-hook) - ;; Make our own local child of asm-mode-map - ;; so we can define our own comment character. - ;; XEmacs change - (let ((ourmap (make-sparse-keymap))) - (set-keymap-parents ourmap (list asm-mode-map)) - (use-local-map ourmap)) - (local-set-key (vector asm-comment-char) 'asm-comment) - ;; XEmacs change - (if asm-support-c-comments-p - (progn - (modify-syntax-entry ?/ ". 14" asm-mode-syntax-table) - (modify-syntax-entry ?* ". 23" asm-mode-syntax-table) - (modify-syntax-entry asm-comment-char "< b" asm-mode-syntax-table) - (modify-syntax-entry ?\n "> b" asm-mode-syntax-table)) - (progn - (modify-syntax-entry asm-comment-char - "<" asm-mode-syntax-table) - (modify-syntax-entry ?\n - ">" asm-mode-syntax-table))) - (let ((cs (regexp-quote (char-to-string asm-comment-char)))) - (make-local-variable 'comment-start) - (setq comment-start (concat cs " ")) - (make-local-variable 'comment-start-skip) - (setq comment-start-skip (concat cs "+[ \t]*")) - (setq asm-inline-empty-comment-pattern (concat "^.+" cs "+ *$")) - (setq asm-code-level-empty-comment-pattern (concat "^[\t ]+" cs cs " *$")) - (setq asm-flush-left-empty-comment-pattern (concat "^" cs cs cs " *$")) - ) - (make-local-variable 'comment-end) - (setq comment-end "") - (make-local-variable 'comment-column) - (setq comment-column 32) - (setq fill-prefix "\t") - (run-hooks 'asm-mode-hook)) - -(defun asm-colon () - "Insert a colon; if it follows a label, delete the label's indentation." - (interactive) - (save-excursion - (beginning-of-line) - (if (looking-at "[ \t]+\\(\\sw\\|\\s_\\)+$") - (delete-horizontal-space))) - (insert ":") - (tab-to-tab-stop) - ) - -(defun asm-newline () - "Insert LFD + fill-prefix, to bring us back to code-indent level." - (interactive) - (if (eolp) (delete-horizontal-space)) - (insert "\n") - (tab-to-tab-stop) - ) - -(defun asm-line-matches (pattern &optional withcomment) - (save-excursion - (beginning-of-line) - (looking-at pattern))) - -(defun asm-pop-comment-level () - ;; Delete an empty comment ending current line. Then set up for a new one, - ;; on the current line if it was all comment, otherwise above it - (end-of-line) - (delete-horizontal-space) - (while (= (preceding-char) asm-comment-char) - (delete-backward-char 1)) - (delete-horizontal-space) - (if (bolp) - nil - (beginning-of-line) - (open-line 1)) - ) - - -(defun asm-comment () - "Convert an empty comment to a `larger' kind, or start a new one. -These are the known comment classes: - - 1 -- comment to the right of the code (at the comment-column) - 2 -- comment on its own line, indented like code - 3 -- comment on its own line, beginning at the left-most column. - -Suggested usage: while writing your code, trigger asm-comment -repeatedly until you are satisfied with the kind of comment." - (interactive) - (cond - - ;; Blank line? Then start comment at code indent level. - ((asm-line-matches "^[ \t]*$") - (delete-horizontal-space) - (tab-to-tab-stop) - (insert asm-comment-char comment-start)) - - ;; Nonblank line with no comment chars in it? - ;; Then start a comment at the current comment column - ((asm-line-matches (format "^[^%c\n]+$" asm-comment-char)) - (indent-for-comment)) - - ;; Flush-left comment present? Just insert character. - ((asm-line-matches asm-flush-left-empty-comment-pattern) - (insert asm-comment-char)) - - ;; Empty code-level comment already present? - ;; Then start flush-left comment, on line above if this one is nonempty. - ((asm-line-matches asm-code-level-empty-comment-pattern) - (asm-pop-comment-level) - (insert asm-comment-char asm-comment-char comment-start)) - - ;; Empty comment ends line? - ;; Then make code-level comment, on line above if this one is nonempty. - ((asm-line-matches asm-inline-empty-comment-pattern) - (asm-pop-comment-level) - (tab-to-tab-stop) - (insert asm-comment-char comment-start)) - - ;; If all else fails, insert character - (t - (insert asm-comment-char)) - - ) - (end-of-line)) - -;;; asm-mode.el ends here
--- a/lisp/modes/auto-show.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,199 +0,0 @@ -;;; auto-show.el --- perform automatic horizontal scrolling as point moves - -;; This file is in the public domain. - -;; Author: Pete Ware <ware@cis.ohio-state.edu> -;; Modified by: Ben Wing <wing@666.com> -;; Maintainer: XEmacs Development Team -;; Keywords: extensions, internal - -;; 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: Emacs/Mule zeta. - -;;; Commentary: - -;; This file provides functions that -;; automatically scroll the window horizontally when the point moves -;; off the left or right side of the window. - -;; Once this library is loaded, automatic horizontal scrolling -;; occurs whenever long lines are being truncated. -;; To request truncation of long lines, set the variable -;; Setting the variable `truncate-lines' to non-nil. -;; You can do this for all buffers as follows: -;; -;; (set-default 'truncate-lines t) - -;; Here is how to do it for C mode only: -;; -;; (set-default 'truncate-lines nil) ; this is the original value -;; (defun my-c-mode-hook () -;; "Run when C-mode starts up. Changes ..." -;; ... set various personal preferences ... -;; (setq truncate-lines t)) -;; (add-hook 'c-mode-hook 'my-c-mode-hook) -;; -;; -;; As a finer level of control, you can still have truncated lines but -;; without the automatic horizontal scrolling by setting the buffer -;; local variable `auto-show-mode' to nil. The default value is t. -;; The command `auto-show-mode' toggles the value of the variable -;; `auto-show-mode'. - -;;; Code: - -(defgroup auto-show nil - "Perform automatic horizontal scrolling as point moves." - :group 'display - :group 'extensions) - -;; This is preloaded, so we don't need special :set, :require, etc. -(defcustom auto-show-mode t - "*Non-nil enables automatic horizontal scrolling, when lines are truncated. -The default value is t. To change the default, do this: - (set-default 'auto-show-mode nil) -See also command `auto-show-mode'. -This variable has no effect when lines are not being truncated. -This variable is automatically local in each buffer where it is set." - :type 'boolean - :group 'auto-show) - -(make-variable-buffer-local 'auto-show-mode) - -(defcustom auto-show-shift-amount 8 - "*Extra columns to scroll. for automatic horizontal scrolling." - :type 'integer - :group 'auto-show) - -(defcustom auto-show-show-left-margin-threshold 50 - "*Threshold column for automatic horizontal scrolling to the right. -If point is before this column, we try to scroll to make the left margin -visible. Setting this to 0 disables this feature." - :type 'number - :group 'auto-show) - -(defun auto-show-truncationp () - "True if line truncation is enabled for the selected window." - ;; XEmacs change (use specifiers) - ;; ### There should be a more straightforward way to do this from elisp. - (or truncate-lines - (and truncate-partial-width-windows - (< (+ (window-width) - (specifier-instance left-margin-width) - (specifier-instance right-margin-width)) - (frame-width))))) - -(defun auto-show-mode (arg) - "Turn automatic horizontal scroll mode on or off. -With arg, turn auto scrolling on if arg is positive, off otherwise. -This mode is enabled or disabled for each buffer individually. -It takes effect only when `truncate-lines' is non-nil." - (interactive "P") - (setq auto-show-mode - (if (null arg) - (not auto-show-mode) - (> (prefix-numeric-value arg) 0)))) - -;; XEmacs addition: -(defvar auto-show-inhibiting-commands - '(scrollbar-char-left - scrollbar-char-right - scrollbar-page-left - scrollbar-page-right - scrollbar-to-left - scrollbar-to-right - scrollbar-horizontal-drag) - "Commands that inhibit auto-show behavior. -This normally includes the horizontal scrollbar commands.") - -;; XEmacs addition: -(defun auto-show-should-take-action-p () - (and auto-show-mode (auto-show-truncationp) - (equal (window-buffer) (current-buffer)) - (not (memq this-command auto-show-inhibiting-commands)))) - -;; XEmacs addition: -(defun auto-show-make-region-visible (start end) - "Move point in such a way that the region (START, END) is visible. -This only does anything if auto-show-mode is enabled, and it doesn't -actually do any horizontal scrolling; rather, it just sets things up so -that the region will be visible when `auto-show-make-point-visible' -is next called (this happens after every command)." - (if (auto-show-should-take-action-p) - (let* ((col (current-column)) ;column on line point is at - (scroll (window-hscroll));how far window is scrolled - (w-width (- (window-width) - (if (> scroll 0) - 2 1))) ;how wide window is on the screen - (right-col (+ scroll w-width)) - (start-col (save-excursion (goto-char start) (current-column))) - (end-col (save-excursion (goto-char end) (current-column)))) - (cond ((and (>= start-col scroll) - (<= end-col right-col)) - ;; already completely visible - nil) - ((< start-col scroll) - (scroll-right (- scroll start-col))) - (t - (scroll-left (- end-col right-col))))))) - -(defun auto-show-make-point-visible (&optional ignore-arg) - "Scroll horizontally to make point visible, if that is enabled. -This function only does something if `auto-show-mode' is non-nil -and longlines are being truncated in the selected window. -See also the command `auto-show-mode'." - (interactive) - ;; XEmacs change - (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 - (w-width (- (window-width) - (if (> scroll 0) - 2 1))) ;how wide window is on the screen - (right-col (+ scroll w-width))) - (if (and (< col auto-show-show-left-margin-threshold) - (< col (window-width)) - (> scroll 0)) - (scroll-right scroll) - (if (< col scroll) ;to the left of the screen - (scroll-right (+ (- scroll col) auto-show-shift-amount)) - (if (or (> col right-col) ;to the right of the screen - (and (= col right-col) - (not (eolp)))) - (scroll-left (+ auto-show-shift-amount - (- col (+ scroll w-width)))))))))) - -;; XEmacs change: -;; #### instead of this, we kludgily call it from the C code, to make sure -;; that it's done after any other things on post-command-hook (which might -;; move point). -;; Do auto-scrolling after commands. -;;(add-hook 'post-command-hook 'auto-show-make-point-visible) - -;; If being dumped, turn it on right away. -(when (boundp 'load-gc) - (auto-show-mode 1)) - -;; Do auto-scrolling in comint buffers after process output also. -; XEmacs -- don't do this now, it messes up comint. -;(add-hook 'comint-output-filter-functions 'auto-show-make-point-visible t) - -(provide 'auto-show) - -;; auto-show.el ends here
--- a/lisp/modes/cperl-mode.el Mon Aug 13 10:03:54 2007 +0200 +++ b/lisp/modes/cperl-mode.el Mon Aug 13 10:04:58 2007 +0200 @@ -1,15 +1,13 @@ -;;; This code started from the following message of long time ago (IZ): - -;;;; From: olson@mcs.anl.gov (Bob Olson) -;;;; Newsgroups: comp.lang.perl -;;;; Subject: cperl-mode: Another perl mode for Gnuemacs -;;;; Date: 14 Aug 91 15:20:01 GMT - -;; Perl code editing commands for XEmacs +;;; cperl-mode.el --- Perl code editing commands for XEmacs + ;; Copyright (C) 1985-1996 Bob Olson, Ilya Zakharevich ;; Copyright (C) 1997 granted to FSF for changes made by ;; Karl M. Hegbloom <karlheg@inetarena.com> +;; Author: Bob Olson, Ilya Zakharevich +;; Maintainer: Karl M. Hegbloom <karlheg@inetarena.com> +;; Keywords: languages + ;; This file is part of XEmacs. It may be distributed either under the ;; same terms as XEmacs, or under the same terms as Perl. You should ;; have received a copy of Perl Artistic license along with the Perl @@ -37,12 +35,21 @@ ;;; Karl M. Hegbloom <karlheg@inetarena.com> ;; Original Vendor Version Number: (mostly based on...) -;; $Id: cperl-mode.el,v 1.15 1997/10/31 14:52:54 steve Exp $ +;; $Id: cperl-mode.el,v 1.16 1997/11/08 23:36:57 steve Exp $ ;; Increment the final digit once per XEmacs-only revision, the other ;; for merges. (sound ok?) ;;; XEmacs Version Number: 1.35-1 +;;; Commentary: + +;; This code started from the following message of long time ago (IZ): + +;; From: olson@mcs.anl.gov (Bob Olson) +;; Newsgroups: comp.lang.perl +;; Subject: cperl-mode: Another perl mode for Gnuemacs +;; Date: 14 Aug 91 15:20:01 GMT + ;; This mode should autoload when you edit a perl file under XEmacs. ;;; DO NOT FORGET to read micro-docs. (available from `Perl' menu). <<<<<< @@ -418,6 +425,8 @@ ;;; Can use `syntax-table' property when generating TAGS ;;; (governed by `cperl-use-syntax-table-text-property-for-tags'). +;;; Code: + (defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version))
--- a/lisp/modes/custom-load.el Mon Aug 13 10:03:54 2007 +0200 +++ b/lisp/modes/custom-load.el Mon Aug 13 10:04:58 2007 +0200 @@ -3,10 +3,9 @@ ;;; Code: -(custom-add-loads 'extensions '("auto-show" "strokes")) +(custom-add-loads 'extensions '("strokes")) (custom-add-loads 'message '("sendmail")) (custom-add-loads 'prolog '("prolog")) -(custom-add-loads 'auto-show '("auto-show")) (custom-add-loads 'mouse '("outl-mouse" "strokes")) (custom-add-loads 'mail-abbrevs '("mail-abbrevs")) (custom-add-loads 'pascal '("pascal")) @@ -20,7 +19,7 @@ (custom-add-loads 'docs '("texinfo")) (custom-add-loads 'lisp-indent '("cl-indent")) (custom-add-loads 'tools '("hideshow" "lazy-shot" "make-mode")) -(custom-add-loads 'lisp '("lisp-mode" "cl-indent" "strokes")) +(custom-add-loads 'lisp '("cl-indent" "strokes")) (custom-add-loads 'reftex '("reftex")) (custom-add-loads 'outlines '("hideshow" "outl-mouse" "whitespace-mode")) (custom-add-loads 'f90 '("f90")) @@ -34,7 +33,6 @@ (custom-add-loads 'frames '("rsz-minibuf")) (custom-add-loads 'cperl-electric '("cperl-mode")) (custom-add-loads 'verilog '("verilog-mode")) -(custom-add-loads 'abbrev '("abbrev")) (custom-add-loads 'f90-indent '("f90")) (custom-add-loads 'strokes '("strokes")) (custom-add-loads 'lazy-shot '("lazy-shot")) @@ -52,7 +50,6 @@ (custom-add-loads 'cperl-indent '("cperl-mode")) (custom-add-loads 'archive-zoo '("arc-mode")) (custom-add-loads 'archive-zip '("arc-mode")) -(custom-add-loads 'display '("auto-show")) (custom-add-loads 'faces '("cperl-mode" "lazy-shot")) (custom-add-loads 'hideshow '("hideshow")) (custom-add-loads 'vhdl '("vhdl-mode"))
--- a/lisp/modes/f90.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1694 +0,0 @@ -;;; f90.el --- Fortran-90 mode (free format) - -;; Copyright (C) 1995, 1996 Free Software Foundation, Inc. - -;; Author: Torbj\"orn Einarsson <T.Einarsson@clab.ericsson.se> -;; Created: Apr. 18, 1996 -;; Keywords: fortran, f90, languages - -;; 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 of the License, 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; if not, write to the Free Software Foundation, -;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -;;; Synched up with: FSF 19.34. - -;;; Commentary: - -;; Smart mode for editing F90 programs in FREE FORMAT. -;; Knows about continuation lines, named structured statements, and other -;; new features in F90 including HPF (High Performance Fortran) structures. -;; The basic feature is to provide an accurate indentation of F90 programs. -;; In addition, there are many more features like automatic matching of all -;; end statements, an auto-fill function to break long lines, a join-lines -;; function which joins continued lines etc etc. -;; To facilitate typing, a fairly complete list of abbreviations is provided. -;; For example, `i is short-hand for integer (if abbrev-mode is on). - -;; There are two separate features for highlighting the code. -;; 1) Upcasing or capitalizing of all keywords. -;; 2) Colors/fonts using font-lock-mode. (only when using X-windows) -;; Automatic upcase of downcase of keywords is controlled by the parameter -;; f90-auto-keyword-case. - -;; The indentations of lines starting with ! is determined by the first of the -;; following matches (the values in the left column are the default values): - -;; start-string/regexp indent variable holding start-string/regexp -;; !!! 0 -;; !hpf\\$ (re) 0 f90-directive-comment-re -;; !!$ 0 f90-comment-region -;; ! (re) as code f90-indented-comment-re -;; default comment-column - -;; Ex: Here is the result of 3 different settings of f90-indented-comment-re -;; f90-indented-comment-re !-indentation !!-indentation -;; ! as code as code -;; !! comment-column as code -;; ![^!] as code comment-column -;; Trailing comments are indented to comment-column with indent-for-comment M-; -;; f90-comment-region (C-c;) toggles insertion of f90-comment-region in region. - -;; One common convention for free vs. fixed format is that free-format files -;; have the ending .f90 while the fixed format files have the ending .f. -;; To make f90-mode work, put this file in, for example, your directory -;; ~/lisp, and be sure that you have the following in your .emacs-file -;; (setq load-path (append load-path '("~/lisp"))) -;; (autoload 'f90-mode "f90" -;; "Major mode for editing Fortran 90 code in free format." t) -;; (setq auto-mode-alist (append auto-mode-alist -;; (list '("\\.f90$" . f90-mode)))) -;; Once you have entered f90-mode, you may get more info by using -;; the command describe-mode (C-h m). For online help describing various -;; functions use C-h f <Name of function you want described> - -;; To customize the f90-mode for your taste, use, for example: -;; (you don't have to specify values for all the parameters below) -;;(setq f90-mode-hook -;; '(lambda () (setq f90-do-indent 3 -;; f90-if-indent 3 -;; f90-type-indent 3 -;; f90-program-indent 2 -;; f90-continuation-indent 5 -;; f90-comment-region "!!$" -;; f90-directive-comment-re "!hpf\\$" -;; f90-indented-comment-re "!" -;; f90-break-delimiters "[-+\\*/,><=% \t]" -;; f90-break-before-delimiters t -;; f90-beginning-ampersand t -;; f90-smart-end 'blink -;; f90-auto-keyword-case nil -;; f90-leave-line-no nil -;; f90-startup-message t -;; indent-tabs-mode nil -;; ) -;; ;;The rest is not default. -;; (abbrev-mode 1) ; turn on abbreviation mode -;; (f90-auto-fill-mode 1) ; turn on auto-filling -;; (turn-on-font-lock) ; for highlighting -;; (if f90-auto-keyword-case ; change case of all keywords on startup -;; (f90-change-keywords f90-auto-keyword-case)) -;; )) -;; in your .emacs file (the shown values are the defaults). You can also -;; change the values of the lists f90-keywords etc. -;; The auto-fill and abbreviation minor modes are accessible from the menu, -;; or by using M-x f90-auto-fill-mode and M-x abbrev-mode, respectively. - -;; Remarks -;; 1) Line numbers are by default left-justified. If f90-leave-line-no is -;; non-nil, the line numbers are never touched. -;; 2) Multi-; statements like > do i=1,20 ; j=j+i ; end do < are not handled -;; correctly, but I imagine them to be rare. -;; 3) Regexps for hilit19 are no longer supported. -;; 4) For FIXED FORMAT code, use the ordinary fortran mode. -;; 5) This mode does not work under emacs-18.x. -;; 6) Preprocessor directives, i.e., lines starting with # are left-justified -;; and are untouched by all case-changing commands. There is, at present, no -;; mechanism for treating multi-line directives (continued by \ ). -;; 7) f77 do-loops do 10 i=.. ; ; 10 continue are not correctly indented. -;; You are urged to use f90-do loops (with labels if you wish). -;; 8) The highlighting mode under XEmacs is not as complete as under Emacs. - -;; List of user commands -;; f90-previous-statement f90-next-statement -;; f90-beginning-of-subprogram f90-end-of-subprogram f90-mark-subprogram -;; f90-comment-region -;; f90-indent-line f90-indent-new-line -;; f90-indent-region (can be called by calling indent-region) -;; f90-indent-subprogram -;; f90-break-line f90-join-lines -;; f90-auto-fill-mode -;; f90-fill-region -;; f90-insert-end -;; f90-upcase-keywords f90-upcase-region-keywords -;; f90-downcase-keywords f90-downcase-region-keywords -;; f90-capitalize-keywords f90-capitalize-region-keywords - -;; Thanks to all the people who have tested the mode. Special thanks to Jens -;; Bloch Helmers for encouraging me to write this code, for creative -;; suggestions as well as for the lists of hpf-commands. -;; Also thanks to the authors of the fortran and pascal modes, on which some -;; of this code is built. - -;;; Code: - -(eval-when-compile - (defvar deactivate-mark) - (defvar mark-active)) - -(defconst bug-f90-mode "T.Einarsson@clab.ericsson.se" - "Address of mailing list for F90 mode bugs.") - -;; User options - -(defgroup f90 nil - "Fortran-90 mode" - :group 'fortran) - -(defgroup f90-indent nil - "Fortran-90 indentation" - :prefix "f90-" - :group 'f90) - - -(defcustom f90-do-indent 3 - "*Extra indentation applied to DO blocks." - :type 'integer - :group 'f90-indent) - -(defcustom f90-if-indent 3 - "*Extra indentation applied to IF, SELECT CASE, WHERE and FORALL blocks." - :type 'integer - :group 'f90-indent) - -(defcustom f90-type-indent 3 - "*Extra indentation applied to TYPE, INTERFACE and BLOCK DATA blocks." - :type 'integer - :group 'f90-indent) - -(defcustom f90-program-indent 2 - "*Extra indentation applied to PROGRAM/MODULE/SUBROUTINE/FUNCTION blocks." - :type 'integer - :group 'f90-indent) - -(defcustom f90-continuation-indent 5 - "*Extra indentation applied to F90 continuation lines." - :type 'integer - :group 'f90-indent) - -(defcustom f90-comment-region "!!$" - "*String inserted by \\[f90-comment-region]\ - at start of each line in region." - :type 'string - :group 'f90-indent) - -(defcustom f90-indented-comment-re "!" - "*Regexp saying which comments to be indented like code." - :type 'regexp - :group 'f90-indent) - -(defcustom f90-directive-comment-re "!hpf\\$" - "*Regexp of comment-like directive like \"!HPF\\\\$\", not to be indented." - :type 'regexp - :group 'f90-indent) - -(defcustom f90-beginning-ampersand t - "*t makes automatic insertion of \& at beginning of continuation line." - :type 'boolean - :group 'f90) - -(defcustom f90-smart-end 'blink - "*From an END statement, check and fill the end using matching block start. -Allowed values are 'blink, 'no-blink, and nil, which determine -whether to blink the matching beginning." - :type '(choice (const blink) (const no-blink) (const nil)) - :group 'f90) - -(defcustom f90-break-delimiters "[-+\\*/><=,% \t]" - "*Regexp holding list of delimiters at which lines may be broken." - :type 'regexp - :group 'f90) - -(defcustom f90-break-before-delimiters t - "*Non-nil causes `f90-do-auto-fill' to break lines before delimiters." - :type 'regexp - :group 'f90) - -(defcustom f90-auto-keyword-case nil - "*Automatic case conversion of keywords. - The options are 'downcase-word, 'upcase-word, 'capitalize-word and nil" - :type '(choice (const downcase-word) (const upcase-word) - (const capitalize-word) (const nil)) - :group 'f90) - -(defcustom f90-leave-line-no nil - "*If nil, left-justify linenumbers." - :type 'boolean - :group 'f90) - -(defcustom f90-startup-message t - "*Non-nil displays a startup message when F90 mode is first called." - :type 'boolean - :group 'f90) - -(defconst f90-keywords-re - ;;("allocate" "allocatable" "assign" "assignment" "backspace" "block" - ;;"call" "case" "character" "close" "common" "complex" "contains" - ;;"continue" "cycle" "data" "deallocate" "dimension" "do" "double" "else" - ;;"elseif" "elsewhere" "end" "enddo" "endfile" "endif" "entry" "equivalence" - ;;"exit" "external" "forall" "format" "function" "goto" "if" "implicit" - ;;"include" "inquire" "integer" "intent" "interface" "intrinsic" "logical" - ;;"module" "namelist" "none" "nullify" "only" "open" "operator" "optional" "parameter" - ;;"pause" "pointer" "precision" "print" "private" "procedure" "program" - ;;"public" "read" "real" "recursive" "result" "return" "rewind" "save" "select" - ;;"sequence" "stop" "subroutine" "target" "then" "type" "use" "where" - ;;"while" "write") - (concat - "\\<\\(a\\(llocat\\(able\\|e\\)\\|ssign\\(\\|ment\\)\\)\\|b\\(ackspace\\|" - "lock\\)\\|c\\(a\\(ll\\|se\\)\\|haracter\\|lose\\|o\\(m\\(mon\\|plex\\)\\|" - "nt\\(ains\\|inue\\)\\)\\|ycle\\)\\|d\\(ata\\|eallocate\\|imension\\|" - "o\\(\\|uble\\)\\)\\|e\\(lse\\(\\|if\\|where\\)\\|n\\(d\\(\\|do\\|file\\|" - "if\\)\\|try\\)\\|quivalence\\|x\\(it\\|ternal\\)\\)\\|f\\(or\\(all\\|" - "mat\\)\\|unction\\)\\|goto\\|i\\(f\\|mplicit\\|n\\(clude\\|quire\\|t\\(" - "e\\(ger\\|nt\\|rface\\)\\|rinsic\\)\\)\\)\\|logical\\|module\\|n\\(" - "amelist\\|one\\|ullify\\)\\|o\\(nly\\|p\\(en\\|erator\\|tional\\)\\)\\|p\\(a\\(" - "rameter\\|use\\)\\|ointer\\|r\\(ecision\\|i\\(nt\\|vate\\)\\|o\\(" - "cedure\\|gram\\)\\)\\|ublic\\)\\|re\\(a[dl]\\|cursive\\|sult\\|turn\\|wind\\)\\|" - "s\\(ave\\|e\\(lect\\|quence\\)\\|top\\|ubroutine\\)\\|t\\(arget\\|hen\\|" - "ype\\)\\|use\\|w\\(h\\(ere\\|ile\\)\\|rite\\)\\)\\>") - "Regexp for F90 keywords.") - -(defconst f90-keywords-level-3-re - ;; ("allocate" "allocatable" "assign" "assignment" "backspace" "close" - ;; "deallocate" "dimension" "endfile" "entry" "equivalence" "external" - ;; "inquire" "intent" "intrinsic" "nullify" "only" "open" "operator" - ;; "optional" "parameter" "pause" "pointer" "print" "private" "public" - ;; "read" "recursive" "result" "rewind" "save" "select" "sequence" - ;; "target" "write") - (concat - "\\<\\(a\\(llocat\\(able\\|e\\)\\|ssign\\(\\|ment\\)\\)\\|backspace\\|" - "close\\|d\\(eallocate\\|imension\\)\\|e\\(n\\(dfile\\|try\\)\\|" - "quivalence\\|xternal\\)\\|" - "in\\(quire\\|t\\(ent\\|rinsic\\)\\)\\|nullify\\|" - "o\\(nly\\|p\\(en\\|erator\\|tional\\)\\)\\|" - "p\\(a\\(rameter\\|use\\)\\|ointer\\|ri\\(nt\\|vate\\)\\|ublic\\)\\|re\\(" - "ad\\|cursive\\|sult\\|wind\\)\\|s\\(ave\\|e\\(lect\\|quence\\)\\)\\|target\\|" - "write\\)\\>") -"Keyword-regexp for font-lock level >= 3.") - - -(defconst f90-procedures-re - ;; ("abs" "achar" "acos" "adjustl" "adjustr" "aimag" "aint" "all" "allocated" - ;; "anint" "any" "asin" "associated" "atan" "atan2" "bit_size" "btest" - ;; "ceiling" "char" "cmplx" "conjg" "cos" "cosh" "count" "cshift" - ;; "date_and_time" "dble" "digits" "dim" "dot_product" "dprod" "eoshift" - ;; "epsilon" "exp" "exponent" "floor" "fraction" "huge" "iachar" "iand" - ;; "ibclr" "ibits" "ibset" "ichar" "ieor" "index" "int" "ior" "ishft" - ;; "ishftc" "kind" "lbound" "len" "len_trim" "lge" "lgt" "lle" "llt" "log" - ;; "logical" "log10" "matmul" "max" "maxexponent" "maxloc" "maxval" "merge" - ;; "min" "minexponent" "minloc" "minval" "mod" "modulo" "mvbits" "nearest" - ;; "nint" "not" "pack" "precision" "present" "product" "radix" - ;; "random_number" "random_seed" "range" "real" "repeat" "reshape" - ;; "rrspacing" "scale" "scan" "selected_int_kind" "selected_real_kind" - ;; "set_exponent" "shape" "sign" "sin" "sinh" "size" "spacing" "spread" - ;; "sqrt" "sum" "system_clock" "tan" "tanh" "tiny" "transfer" "transpose" - ;; "trim" "ubound" "unpack" "verify") - ;; A left paranthesis to avoid highlighting non-procedures. - ;; Real is taken out here to avoid highlighting declarations. - (concat - "\\<\\(a\\(bs\\|c\\(har\\|os\\)\\|djust[lr]\\|i\\(mag\\|nt\\)\\|ll\\(\\|" - "ocated\\)\\|n\\(int\\|y\\)\\|s\\(in\\|sociated\\)\\|tan2?\\)\\|b\\(" - "it_size\\|test\\)\\|c\\(eiling\\|har\\|mplx\\|o\\(njg\\|sh?\\|unt\\)\\|" - "shift\\)\\|d\\(ate_and_time\\|ble\\|i\\(gits\\|m\\)\\|ot_product\\|prod" - "\\)\\|e\\(oshift\\|psilon\\|xp\\(\\|onent\\)\\)\\|f\\(loor\\|" - "raction\\)\\|huge\\|i\\(a\\(char\\|nd\\)\\|b\\(clr\\|its\\|set\\)\\|" - "char\\|eor\\|n\\(dex\\|t\\)\\|or\\|shftc?\\)\\|kind\\|l\\(bound\\|" - "en\\(\\|_trim\\)\\|g[et]\\|l[et]\\|og\\(\\|10\\|ical\\)\\)\\|m\\(a\\(" - "tmul\\|x\\(\\|exponent\\|loc\\|val\\)\\)\\|erge\\|in\\(\\|exponent\\|" - "loc\\|val\\)\\|od\\(\\|ulo\\)\\|vbits\\)\\|n\\(earest\\|int\\|ot\\)\\|" - "p\\(ack\\|r\\(e\\(cision\\|sent\\)\\|oduct\\)\\)\\|r\\(a\\(dix\\|n\\(" - "dom_\\(number\\|seed\\)\\|ge\\)\\)\\|e\\(peat\\|shape\\)\\|rspacing\\)\\|" - "s\\(ca\\(le\\|n\\)\\|e\\(lected_\\(int_kind\\|real_kind\\)\\|" - "t_exponent\\)\\|hape\\|i\\(gn\\|nh?\\|ze\\)\\|p\\(acing\\|read\\)\\|" - "qrt\\|um\\|ystem_clock\\)\\|t\\(anh?\\|iny\\|r\\(ans\\(fer\\|pose\\)\\|" - "im\\)\\)\\|u\\(bound\\|npack\\)\\|verify\\)[ \t]*(") - "Regexp whose first part matches F90 intrinsic procedures.") - -(defconst f90-operators-re -;; "and" "or" "not" "eqv" "neqv" "eq" "ne" "lt" "le" "gt" "ge" "true" "false" - (concat - "\\.\\(and\\|eqv?\\|false\\|g[et]\\|l[et]\\|n\\(e\\(\\|qv\\)\\|" - "ot\\)\\|or\\|true\\)\\.") - "Regexp matching intrinsic operators.") - -(defconst f90-hpf-keywords-re - ;; Intrinsic procedures - ;; ("all_prefix" "all_scatter" "all_suffix" "any_prefix" "any_scatter" - ;; "any_suffix" "copy_prefix" "copy_scatter" "copy_suffix" "count_prefix" - ;; "count_scatter" "count_suffix" "grade_down" "grade_up" "hpf_alignment" - ;; "hpf_template" "hpf_distribution" "iall" "iall_prefix" "iall_scatter" - ;; "iall_suffix" "iany" "iany_prefix" "iany_scatter" "iany_suffix" "iparity" - ;; "iparity_prefix" "iparity_scatter" "iparity_suffix" "leadz" - ;; "maxval_prefix" "maxval_scatter" "maxval_suffix" "minval_prefix" - ;; "minval_scatter" "minval_suffix" "parity" "parity_prefix" - ;; "parity_scatter" "parity_suffix" "popcnt" "poppar" "product_prefix" - ;; "product_scatter" "product_suffix" "sum_prefix" "sum_scatter" - ;; "sum_suffix" "ilen" "number_of_processors" "processors_shape") - ;; Directives - ;; ("align" "distribute" "dynamic" "inherit" "template" "processors" - ;; "realign" "redistribute" "independent") - ;; Keywords - ;; ("pure" "extrinsic" "new" "with" "onto" "block" "cyclic") - (concat - "\\<\\(a\\(l\\(ign\\|l_\\(prefix\\|s\\(catter\\|uffix\\)\\)\\)\\|ny_\\(" - "prefix\\|s\\(catter\\|uffix\\)\\)\\)\\|block\\|c\\(o\\(py_\\(prefix\\|" - "s\\(catter\\|uffix\\)\\)\\|unt_\\(prefix\\|s\\(catter\\|uffix\\)\\)\\)\\|" - "yclic\\)\\|d\\(istribute\\|ynamic\\)\\|extrinsic\\|grade_\\(down\\|" - "up\\)\\|hpf_\\(alignment\\|distribution\\|template\\)\\|i\\(a\\(ll\\(\\|" - "_\\(prefix\\|s\\(catter\\|uffix\\)\\)\\)\\|ny\\(\\|_\\(prefix\\|s\\(" - "catter\\|uffix\\)\\)\\)\\)\\|len\\|n\\(dependent\\|herit\\)\\|parity\\(\\|" - "_\\(prefix\\|s\\(catter\\|uffix\\)\\)\\)\\)\\|leadz\\|m\\(axval_\\(" - "prefix\\|s\\(catter\\|uffix\\)\\)\\|inval_\\(prefix\\|s\\(catter\\|" - "uffix\\)\\)\\)\\|n\\(ew\\|umber_of_processors\\)\\|onto\\|p\\(arity\\(\\|" - "_\\(prefix\\|s\\(catter\\|uffix\\)\\)\\)\\|op\\(cnt\\|par\\)\\|ro\\(" - "cessors\\(\\|_shape\\)\\|duct_\\(prefix\\|s\\(catter\\|uffix\\)\\)\\)\\|" - "ure\\)\\|re\\(align\\|distribute\\)\\|sum_\\(prefix\\|s\\(catter\\|" - "uffix\\)\\)\\|template\\|with\\)\\>") - "Regexp for all HPF keywords, procedures and directives.") - -;; Highlighting patterns - -(defvar f90-font-lock-keywords-1 - (if (string-match "XEmacs" emacs-version) - (list ; XEmacs - '("\\<\\(end[ \t]*\\(program\\|module\\|function\\|subroutine\\|type\\)\\)\\>" - 1 font-lock-keyword-face) - '("\\<\\(end[ \t]*\\(program\\|module\\|function\\|subroutine\\|type\\)\\)\\>[ \t]*\\(\\sw+\\)" - 3 font-lock-function-name-face) - '("\\<\\(program\\|call\\|module\\|subroutine\\|function\\|use\\)\\>" - 1 font-lock-keyword-face) - '("\\<\\(program\\|call\\|module\\|subroutine\\|function\\|use\\)\\>[ \t]*\\(\\sw+\\)" - 2 font-lock-function-name-face nil t) - ;; Special highlighting of "module procedure foo-list" - '("\\<\\(module[ \t]*procedure\\)\\>" 1 font-lock-keyword-face t) - ;; Highlight definition of new type - '("\\<\\(type\\)[ \t]*\\(,.*::[ \t]*\\|[ \t]+\\)\\(\\sw+\\)" - 1 font-lock-keyword-face) - '("\\<\\(type\\)[ \t]*\\(,.*::[ \t]*\\|[ \t]+\\)\\(\\sw+\\)" - 3 font-lock-function-name-face) - "\\<\\(\\(end[ \t]*\\)?\\(interface\\|block[ \t]*data\\)\\|contains\\)\\>") - (list ; Emacs - '("\\<\\(end[ \t]*\\(program\\|module\\|function\\|subroutine\\|type\\)\\)\\>[ \t]*\\(\\sw+\\)?" - (1 font-lock-keyword-face) (3 font-lock-function-name-face nil t)) - '("\\<\\(program\\|call\\|module\\|subroutine\\|function\\|use\\)\\>[ \t]*\\(\\sw+\\)?" - (1 font-lock-keyword-face) (2 font-lock-function-name-face nil t)) - ;; Special highlighting of "module procedure foo-list" - '("\\<\\(module[ \t]*procedure\\)\\>" (1 font-lock-keyword-face t)) - ;; Highlight definition of new type - '("\\<\\(type\\)[ \t]*\\(,.*::[ \t]*\\|[ \t]+\\)\\(\\sw+\\)" - (1 font-lock-keyword-face) (3 font-lock-function-name-face)) - "\\<\\(\\(end[ \t]*\\)?\\(interface\\|block[ \t]*data\\)\\|contains\\)\\>")) - "This does fairly subdued highlighting of comments and function calls.") - -(defvar f90-font-lock-keywords-2 - (append f90-font-lock-keywords-1 - (if (string-match "XEmacs" emacs-version) - (list ; XEmacs - ;; Variable declarations (avoid the real function call) - '("^[ \t0-9]*\\(real\\|integer\\|c\\(haracter\\|omplex\\)\\|logical\\|type[ \t]*(\\sw+)\\)" - 1 font-lock-type-face) - '("^[ \t0-9]*\\(real\\|integer\\|c\\(haracter\\|omplex\\)\\|logical\\|type[ \t]*(\\sw+)\\)\\(.*::\\|[ \t]*(.*)\\)?\\(.*\\)" - 4 font-lock-doc-string-face) - ;; do, if and select constructs - '("\\<\\(end[ \t]*\\(do\\|if\\|select\\)\\)\\>" - 1 font-lock-keyword-face) - '("\\<\\(end[ \t]*\\(do\\|if\\|select\\)\\)\\>\\([ \t]+\\(\\sw+\\)\\)" - 3 font-lock-doc-string-face) - '("^[ \t0-9]*\\(\\(\\sw+\\)[ \t]*:[ \t]*\\)\\(\\(if\\|do\\([ \t]*while\\)?\\|select[ \t]*case\\)\\)\\>" - 2 font-lock-doc-string-face) - '("^[ \t0-9]*\\(\\(\\sw+\\)[ \t]*:[ \t]*\\)?\\(\\(if\\|do\\([ \t]*while\\)?\\|select[ \t]*case\\)\\)\\>" - 3 font-lock-keyword-face) - ;; implicit declaration - '("\\<\\(implicit\\)[ \t]*\\(real\\|integer\\|c\\(haracter\\|omplex\\)\\|logical\\|type[ \t]*(\\sw+)\\|none\\)\\>" - 1 font-lock-keyword-face) - '("\\<\\(implicit\\)[ \t]*\\(real\\|integer\\|c\\(haracter\\|omplex\\)\\|logical\\|type[ \t]*(\\sw+)\\|none\\)\\>" - 2 font-lock-type-face) - '("\\<\\(namelist\\|common\\)[ \t]*\/\\(\\sw+\\)?\/" - 1 font-lock-keyword-face) - '("\\<\\(namelist\\|common\\)[ \t]*\/\\(\\sw+\\)\/" - 2 font-lock-doc-string-face nil t) - '("\\<\\(where\\|forall\\)[ \t]*(" . 1) - "\\<e\\(lse\\([ \t]*if\\|where\\)?\\|nd[ \t]*\\(where\\|forall\\)\\)\\>" - "\\<\\(then\\|continue\\|format\\|include\\|stop\\|return\\)\\>" - '("\\<\\(exit\\|cycle\\)\\>" - 1 font-lock-keyword-face) - '("\\<\\(exit\\|cycle\\)[ \t]*\\(\\sw+\\)2\\>" - 2 font-lock-doc-string-face) - '("\\<\\(case\\)[ \t]*\\(default\\|(\\)" . 1) - '("\\<\\(do\\|go *to\\)\\>[ \t]*\\([0-9]+\\)" - 1 font-lock-keyword-face) - '("\\<\\(do\\|go *to\\)\\>[ \t]*\\([0-9]+\\)" - 2 font-lock-doc-string-face) - '("^[ \t]*\\([0-9]+\\)" 1 font-lock-doc-string-face t)) - (list ; Emacs - ;; Variable declarations (avoid the real function call) - '("^[ \t0-9]*\\(real\\|integer\\|c\\(haracter\\|omplex\\)\\|logical\\|type[ \t]*(\\sw+)\\)\\(.*::\\|[ \t]*(.*)\\)?\\(.*\\)" - (1 font-lock-type-face) (4 font-lock-variable-name-face)) - ;; do, if and select constructs - '("\\<\\(end[ \t]*\\(do\\|if\\|select\\)\\)\\>\\([ \t]+\\(\\sw+\\)\\)?" - (1 font-lock-keyword-face) (3 font-lock-reference-face nil t)) - '("^[ \t0-9]*\\(\\(\\sw+\\)[ \t]*:[ \t]*\\)?\\(\\(if\\|do\\([ \t]*while\\)?\\|select[ \t]*case\\)\\)\\>" - (2 font-lock-reference-face nil t) (3 font-lock-keyword-face)) - ;; implicit declaration - '("\\<\\(implicit\\)[ \t]*\\(real\\|integer\\|c\\(haracter\\|omplex\\)\\|logical\\|type[ \t]*(\\sw+)\\|none\\)\\>" (1 font-lock-keyword-face) (2 font-lock-type-face)) - '("\\<\\(namelist\\|common\\)[ \t]*\/\\(\\sw+\\)?\/" (1 font-lock-keyword-face) (2 font-lock-reference-face nil t)) - '("\\<\\(where\\|forall\\)[ \t]*(" . 1) - "\\<e\\(lse\\([ \t]*if\\|where\\)?\\|nd[ \t]*\\(where\\|forall\\)\\)\\>" - "\\<\\(then\\|continue\\|format\\|include\\|stop\\|return\\)\\>" - '("\\<\\(exit\\|cycle\\)[ \t]*\\(\\sw+\\)?\\>" - (1 font-lock-keyword-face) (2 font-lock-reference-face nil t)) - '("\\<\\(case\\)[ \t]*\\(default\\|(\\)" . 1) - '("\\<\\(do\\|go *to\\)\\>[ \t]*\\([0-9]+\\)" - (1 font-lock-keyword-face) (2 font-lock-reference-face)) - '("^[ \t]*\\([0-9]+\\)" (1 font-lock-reference-face t))))) - "Highlights declarations, do-loops and other constructions") - -(defvar f90-font-lock-keywords-3 - (append f90-font-lock-keywords-2 - (list - f90-keywords-level-3-re - f90-operators-re - (if (string-match "XEmacs" emacs-version) - (append (list f90-procedures-re) '(1 font-lock-keyword-face t)) - (list f90-procedures-re '(1 font-lock-keyword-face t))) - "\\<real\\>" ; Avoid overwriting real defs. - )) - "Highlights all F90 keywords and intrinsic procedures.") - -(defvar f90-font-lock-keywords-4 - (append f90-font-lock-keywords-3 - (list f90-hpf-keywords-re)) - "Highlights all F90 and HPF keywords.") - -(defvar f90-font-lock-keywords - f90-font-lock-keywords-2 - "*Default expressions to highlight in F90 mode.") - -;; syntax table -(defvar f90-mode-syntax-table nil - "Syntax table in use in F90 mode buffers.") - -(if f90-mode-syntax-table - () - (setq f90-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?\! "<" f90-mode-syntax-table) ; beg. comment - (modify-syntax-entry ?\n ">" f90-mode-syntax-table) ; end comment - (modify-syntax-entry ?\' "\"" f90-mode-syntax-table) ; string quote - (modify-syntax-entry ?\" "\"" f90-mode-syntax-table) ; string quote - (modify-syntax-entry ?\` "w" f90-mode-syntax-table) ; for abbrevs - (modify-syntax-entry ?\r " " f90-mode-syntax-table) ; return is whitespace - (modify-syntax-entry ?+ "." f90-mode-syntax-table) - (modify-syntax-entry ?- "." f90-mode-syntax-table) - (modify-syntax-entry ?= "." f90-mode-syntax-table) - (modify-syntax-entry ?* "." f90-mode-syntax-table) - (modify-syntax-entry ?/ "." f90-mode-syntax-table) - (modify-syntax-entry ?\\ "/" f90-mode-syntax-table) - (modify-syntax-entry ?. "." f90-mode-syntax-table) - (modify-syntax-entry ?% "." f90-mode-syntax-table) ; not in f77 - (modify-syntax-entry ?$ "_" f90-mode-syntax-table) - (modify-syntax-entry ?@ "_" f90-mode-syntax-table) - (modify-syntax-entry ?_ "_" f90-mode-syntax-table) - ) ; escape chars - -;; keys -(defvar f90-mode-map () - "Keymap used in F90 mode.") - -(if f90-mode-map - () - (setq f90-mode-map (make-sparse-keymap)) - (define-key f90-mode-map "`" 'f90-abbrev-start) - (define-key f90-mode-map "\C-c;" 'f90-comment-region) - (define-key f90-mode-map "\C-\M-a" 'f90-beginning-of-subprogram) - (define-key f90-mode-map "\C-\M-e" 'f90-end-of-subprogram) - (define-key f90-mode-map "\C-\M-h" 'f90-mark-subprogram) - (define-key f90-mode-map "\C-\M-q" 'f90-indent-subprogram) - (define-key f90-mode-map "\C-j" 'f90-indent-new-line) ; LFD equals C-j - (define-key f90-mode-map "\r" 'newline) - (define-key f90-mode-map "\C-c\r" 'f90-break-line) - ;; (define-key f90-mode-map [M-return] 'f90-break-line) - (define-key f90-mode-map "\C-c\C-d" 'f90-join-lines) - (define-key f90-mode-map "\C-c\C-f" 'f90-fill-region) - (define-key f90-mode-map "\C-c\C-p" 'f90-previous-statement) - (define-key f90-mode-map "\C-c\C-n" 'f90-next-statement) - (define-key f90-mode-map "\C-c\C-w" 'f90-insert-end) - (define-key f90-mode-map "\t" 'f90-indent-line)) - -;; menus -(if (string-match "XEmacs" emacs-version) - (defvar f90-xemacs-menu - '("F90" - ["Indent Subprogram" f90-indent-subprogram t] - ["Mark Subprogram" f90-mark-subprogram t] - ["Beginning of Subprogram" f90-beginning-of-subprogram t] - ["End of Subprogram" f90-end-of-subprogram t] - "-----" - ["(Un)Comment Region" f90-comment-region t] - ["Indent Region" indent-region t] - ["Fill Region" f90-fill-region t] - "-----" - ["Break Line at Point" f90-break-line t] - ["Join with Next Line" f90-join-lines t] - ["Insert Newline" newline t] - ["Insert End" f90-insert-end t] - "-----" - ["Upcase Keywords (buffer)" f90-upcase-keywords t] - ["Upcase Keywords (region)" f90-upcase-region-keywords - t] - ["Capitalize Keywords (buffer)" f90-capitalize-keywords t] - ["Capitalize Keywords (region)" - f90-capitalize-region-keywords t] - ["Downcase Keywords (buffer)" f90-downcase-keywords t] - ["Downcase Keywords (region)" - f90-downcase-region-keywords t] - "-----" - ["Toggle abbrev-mode" abbrev-mode t] - ["Toggle auto-fill" f90-auto-fill-mode t]) - "XEmacs menu for F90 mode.") - ;; Emacs - (define-key f90-mode-map [menu-bar] (make-sparse-keymap)) - (define-key f90-mode-map [menu-bar f90] - (cons "F90" (make-sparse-keymap "f90"))) - (define-key f90-mode-map [menu-bar f90 abbrev-mode] - '("Toggle abbrev-mode" . abbrev-mode)) - (define-key f90-mode-map [menu-bar f90 f90-auto-fill-mode] - '("Toggle auto-fill" . f90-auto-fill-mode)) - (define-key f90-mode-map [menu-bar f90 f90-downcase-region-keywords] - '("Downcase Keywords (region)" . f90-downcase-region-keywords)) - (define-key f90-mode-map [menu-bar f90 f90-downcase-keywords] - '("Downcase Keywords (buffer)" . f90-downcase-keywords)) - (define-key f90-mode-map [menu-bar f90 f90-capitalize-keywords] - '("Capitalize Keywords (region)" . f90-capitalize-region-keywords)) - (define-key f90-mode-map [menu-bar f90 f90-capitalize-region-keywords] - '("Capitalize Keywords (buffer)" . f90-capitalize-keywords)) - (define-key f90-mode-map [menu-bar f90 f90-upcase-region-keywords] - '("Upcase Keywords (region)" . f90-upcase-region-keywords)) - (define-key f90-mode-map [menu-bar f90 f90-upcase-keywords] - '("Upcase Keywords (buffer)" . f90-upcase-keywords)) - (define-key f90-mode-map [menu-bar f90 f90-insert-end] - '("Insert end" . f90-insert-end)) - (define-key f90-mode-map [menu-bar f90 f90-join-lines] - '("Join with Next Line" . f90-join-lines)) - (define-key f90-mode-map [menu-bar f90 f90-break-line] - '("Break Line at Point" . f90-break-line)) - (define-key f90-mode-map [menu-bar f90 f90-fill-region] - '("Fill Region" . f90-fill-region)) - (define-key f90-mode-map [menu-bar f90 indent-region] - '("Indent Region" . indent-region)) - (define-key f90-mode-map [menu-bar f90 f90-comment-region] - '("(Un)Comment Region" . f90-comment-region)) - (define-key f90-mode-map [menu-bar f90 f90-end-of-subprogram] - '("End of Subprogram" . f90-end-of-subprogram)) - (define-key f90-mode-map [menu-bar f90 f90-beginning-of-subprogram] - '("Beginning of Subprogram" . f90-beginning-of-subprogram)) - (define-key f90-mode-map [menu-bar f90 f90-mark-subprogram] - '("Mark Subprogram" . f90-mark-subprogram)) - (define-key f90-mode-map [menu-bar f90 f90-indent-subprogram] - '("Indent Subprogram" . f90-indent-subprogram))) - -;; Regexps for finding program structures. -(defconst f90-blocks-re - "\\(block[ \t]*data\\|do\\|if\\|interface\\|function\\|module\\|\ -program\\|select\\|subroutine\\|type\\|where\\|forall\\)\\>") -(defconst f90-program-block-re - "\\(program\\|module\\|subroutine\\|function\\)") -(defconst f90-else-like-re - "\\(else\\([ \t]*if\\|where\\)?\\|case[ \t]*\\(default\\|(\\)\\)") -(defconst f90-end-if-re - "end[ \t]*\\(if\\|select\\|where\\|forall\\)\\>") -(defconst f90-end-type-re - "end[ \t]*\\(type\\|interface\\|block[ \t]*data\\)") -(defconst f90-type-def-re - "\\<\\(type\\)[ \t]*\\(,.*::[ \t]*\\|[ \t]+\\)\\(\\sw+\\)") -(defconst f90-no-break-re "\\(\\*\\*\\|//\\|=>\\)") -;; A temporary position to make region operators faster -(defvar f90-cache-position nil) -(make-variable-buffer-local 'f90-cache-position) - -;; Imenu support -(defvar f90-imenu-generic-expression - (cons - (concat - "^[ \t0-9]*\\(" - "program[ \t]+\\(\\sw+\\)\\|" - "module[ \t]+\\(\\sw+\\)[ \t]*\\(!\\|$\\)\\|" - "\\(pure\\|recursive\\|extrinsic([^)]+)\\)?[ \t]*" - "subroutine[ \t]+\\(\\sw+\\)\\|" - ; avoid end function, but allow for most other things - "\\([^!]*\\([^e!].[^ \t!]\\|.[^n!][^ \t!]\\|..[^d \t!]\\)" - "\\|[^!]?[^!]?\\)[ \t]*function[ \t]+\\(\\sw+\\)" - "\\)") - (list 2 3 6 9)) - "imenu generic expression for F90 mode.") - -;; When compiling under GNU Emacs, load imenu during compilation. If -;; you have 19.22 or earlier, comment this out, or get imenu. -(and (fboundp 'eval-when-compile) - (eval-when-compile - (if (not (string-match "XEmacs" emacs-version)) - (require 'imenu)) - ())) - - - -;; abbrevs have generally two letters, except standard types `c, `i, `r, `t -(defvar f90-mode-abbrev-table nil) -(if f90-mode-abbrev-table - () - (let ((ac abbrevs-changed)) - (define-abbrev-table 'f90-mode-abbrev-table ()) - (define-abbrev f90-mode-abbrev-table "`al" "allocate" nil) - (define-abbrev f90-mode-abbrev-table "`ab" "allocatable" nil) - (define-abbrev f90-mode-abbrev-table "`as" "assignment" nil) - (define-abbrev f90-mode-abbrev-table "`ba" "backspace" nil) - (define-abbrev f90-mode-abbrev-table "`bd" "block data" nil) - (define-abbrev f90-mode-abbrev-table "`c" "character" nil) - (define-abbrev f90-mode-abbrev-table "`cl" "close" nil) - (define-abbrev f90-mode-abbrev-table "`cm" "common" nil) - (define-abbrev f90-mode-abbrev-table "`cx" "complex" nil) - (define-abbrev f90-mode-abbrev-table "`cn" "contains" nil) - (define-abbrev f90-mode-abbrev-table "`cy" "cycle" nil) - (define-abbrev f90-mode-abbrev-table "`de" "deallocate" nil) - (define-abbrev f90-mode-abbrev-table "`df" "define" nil) - (define-abbrev f90-mode-abbrev-table "`di" "dimension" nil) - (define-abbrev f90-mode-abbrev-table "`dw" "do while" nil) - (define-abbrev f90-mode-abbrev-table "`el" "else" nil) - (define-abbrev f90-mode-abbrev-table "`eli" "else if" nil) - (define-abbrev f90-mode-abbrev-table "`elw" "elsewhere" nil) - (define-abbrev f90-mode-abbrev-table "`eq" "equivalence" nil) - (define-abbrev f90-mode-abbrev-table "`ex" "external" nil) - (define-abbrev f90-mode-abbrev-table "`ey" "entry" nil) - (define-abbrev f90-mode-abbrev-table "`fl" "forall" nil) - (define-abbrev f90-mode-abbrev-table "`fo" "format" nil) - (define-abbrev f90-mode-abbrev-table "`fu" "function" nil) - (define-abbrev f90-mode-abbrev-table "`fa" ".false." nil) - (define-abbrev f90-mode-abbrev-table "`im" "implicit none" nil) - (define-abbrev f90-mode-abbrev-table "`in " "include" nil) - (define-abbrev f90-mode-abbrev-table "`i" "integer" nil) - (define-abbrev f90-mode-abbrev-table "`it" "intent" nil) - (define-abbrev f90-mode-abbrev-table "`if" "interface" nil) - (define-abbrev f90-mode-abbrev-table "`lo" "logical" nil) - (define-abbrev f90-mode-abbrev-table "`mo" "module" nil) - (define-abbrev f90-mode-abbrev-table "`na" "namelist" nil) - (define-abbrev f90-mode-abbrev-table "`nu" "nullify" nil) - (define-abbrev f90-mode-abbrev-table "`op" "optional" nil) - (define-abbrev f90-mode-abbrev-table "`pa" "parameter" nil) - (define-abbrev f90-mode-abbrev-table "`po" "pointer" nil) - (define-abbrev f90-mode-abbrev-table "`pr" "print" nil) - (define-abbrev f90-mode-abbrev-table "`pi" "private" nil) - (define-abbrev f90-mode-abbrev-table "`pm" "program" nil) - (define-abbrev f90-mode-abbrev-table "`pu" "public" nil) - (define-abbrev f90-mode-abbrev-table "`r" "real" nil) - (define-abbrev f90-mode-abbrev-table "`rc" "recursive" nil) - (define-abbrev f90-mode-abbrev-table "`rt" "return" nil) - (define-abbrev f90-mode-abbrev-table "`rw" "rewind" nil) - (define-abbrev f90-mode-abbrev-table "`se" "select" nil) - (define-abbrev f90-mode-abbrev-table "`sq" "sequence" nil) - (define-abbrev f90-mode-abbrev-table "`su" "subroutine" nil) - (define-abbrev f90-mode-abbrev-table "`ta" "target" nil) - (define-abbrev f90-mode-abbrev-table "`tr" ".true." nil) - (define-abbrev f90-mode-abbrev-table "`t" "type" nil) - (define-abbrev f90-mode-abbrev-table "`wh" "where" nil) - (define-abbrev f90-mode-abbrev-table "`wr" "write" nil) - (setq abbrevs-changed ac))) - -;;;###autoload -(defun f90-mode () - "Major mode for editing Fortran 90 code in free format. - -\\[f90-indent-new-line] corrects current indentation and creates new\ - indented line. -\\[f90-indent-line] indents the current line correctly. -\\[f90-indent-subprogram] indents the current subprogram. - -Type `? or `\\[help-command] to display a list of built-in\ - abbrevs for F90 keywords. - -Key definitions: -\\{f90-mode-map} - -Variables controlling indentation style and extra features: - - f90-do-indent - Extra indentation within do blocks. (default 3) - f90-if-indent - Extra indentation within if/select case/where/forall blocks. (default 3) - f90-type-indent - Extra indentation within type/interface/block-data blocks. (default 3) - f90-program-indent - Extra indentation within program/module/subroutine/function blocks. - (default 2) - f90-continuation-indent - Extra indentation applied to continuation lines. (default 5) - f90-comment-region - String inserted by \\[f90-comment-region] at start of each line in - region. (default \"!!!$\") - f90-indented-comment-re - Regexp determining the type of comment to be intended like code. - (default \"!\") - f90-directive-comment-re - Regexp of comment-like directive like \"!HPF\\\\$\", not to be indented. - (default \"!hpf\\\\$\") - f90-break-delimiters - Regexp holding list of delimiters at which lines may be broken. - (default \"[-+*/><=,% \\t]\") - f90-break-before-delimiters - Non-nil causes `f90-do-auto-fill' to break lines before delimiters. - (default t) - f90-beginning-ampersand - Automatic insertion of \& at beginning of continuation lines. (default t) - f90-smart-end - From an END statement, check and fill the end using matching block start. - Allowed values are 'blink, 'no-blink, and nil, which determine - whether to blink the matching beginning.) (default 'blink) - f90-auto-keyword-case - Automatic change of case of keywords. (default nil) - The possibilities are 'downcase-word, 'upcase-word, 'capitalize-word. - f90-leave-line-no - Do not left-justify line numbers. (default nil) - f90-startup-message - Set to nil to inhibit message first time F90 mode is used. (default t) - f90-keywords-re - List of keywords used for highlighting/upcase-keywords etc. - -Turning on F90 mode calls the value of the variable `f90-mode-hook' -with no args, if that value is non-nil." - (interactive) - (kill-all-local-variables) - (setq major-mode 'f90-mode) - (setq mode-name "F90") - (setq local-abbrev-table f90-mode-abbrev-table) - (set-syntax-table f90-mode-syntax-table) - (use-local-map f90-mode-map) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'f90-indent-line) - (make-local-variable 'indent-region-function) - (setq indent-region-function 'f90-indent-region) - (make-local-variable 'require-final-newline) - (setq require-final-newline t) - (make-local-variable 'comment-start) - (setq comment-start "!") - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "!+ *") - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'f90-comment-indent) - (make-local-variable 'abbrev-all-caps) - (setq abbrev-all-caps t) - (setq indent-tabs-mode nil) - ;; Setting up things for font-lock - (if (string-match "XEmacs" emacs-version) - (progn - (put 'f90-mode 'font-lock-keywords-case-fold-search t) - (if (and current-menubar - (not (assoc "F90" current-menubar))) - (progn - (set-buffer-menubar (copy-sequence current-menubar)) - (add-submenu nil f90-xemacs-menu))))) - ;; XEmacs: (Don't need a special case, since both emacsen work alike -sb) - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults - '((f90-font-lock-keywords f90-font-lock-keywords-1 - f90-font-lock-keywords-2 - f90-font-lock-keywords-3 - f90-font-lock-keywords-4) - nil t)) - ;; Tell imenu how to handle f90. - (make-local-variable 'imenu-generic-expression) - (setq imenu-generic-expression f90-imenu-generic-expression) - (run-hooks 'f90-mode-hook) - (if f90-startup-message - (message "Emacs F90 mode; please report bugs to %s" bug-f90-mode)) - (setq f90-startup-message nil)) - -;; inline-functions -(defsubst f90-get-beg-of-line () - (save-excursion (beginning-of-line) (point))) - -(defsubst f90-get-end-of-line () - (save-excursion (end-of-line) (point))) - -(defsubst f90-in-string () - (let ((beg-pnt - (if (and f90-cache-position (> (point) f90-cache-position)) - f90-cache-position - (point-min)))) - (nth 3 (parse-partial-sexp beg-pnt (point))))) - -(defsubst f90-in-comment () - (let ((beg-pnt - (if (and f90-cache-position (> (point) f90-cache-position)) - f90-cache-position - (point-min)))) - (nth 4 (parse-partial-sexp beg-pnt (point))))) - -(defsubst f90-line-continued () - (save-excursion - (let ((bol (f90-get-beg-of-line))) - (end-of-line) - (while (f90-in-comment) - (search-backward "!" bol) - (skip-chars-backward "!")) - (skip-chars-backward " \t") - (= (preceding-char) ?&)))) - -(defsubst f90-current-indentation () - "Return indentation of current line. -Line-numbers are considered whitespace characters." - (save-excursion - (beginning-of-line) (skip-chars-forward " \t0-9") - (current-column))) - -(defsubst f90-indent-to (col &optional no-line-number) - "Indent current line to column COL. -If no-line-number nil, jump over a possible line-number." - (beginning-of-line) - (if (not no-line-number) - (skip-chars-forward " \t0-9")) - (delete-horizontal-space) - (if (zerop (current-column)) - (indent-to col) - (indent-to col 1))) - -(defsubst f90-match-piece (arg) - (if (match-beginning arg) - (buffer-substring (match-beginning arg) (match-end arg)))) - -(defsubst f90-get-present-comment-type () - (save-excursion - (let ((type nil) (eol (f90-get-end-of-line))) - (if (f90-in-comment) - (progn - (beginning-of-line) - (re-search-forward "[!]+" eol) - (while (f90-in-string) - (re-search-forward "[!]+" eol)) - (setq type (buffer-substring (match-beginning 0) (match-end 0))))) - type))) - -(defsubst f90-equal-symbols (a b) - "Compare strings neglecting case and allowing for nil value." - (let ((a-local (if a (downcase a) nil)) - (b-local (if b (downcase b) nil))) - (equal a-local b-local))) - -;; XEmacs 19.11 & 19.12 gives back a single char when matching an empty regular -;; expression. Therefore, the next 2 functions are longer than necessary. - -(defsubst f90-looking-at-do () - "Return (\"do\" name) if a do statement starts after point. -Name is nil if the statement has no label." - (if (looking-at "\\(\\(\\sw+\\)[ \t]*\:\\)?[ \t]*\\(do\\)\\>") - (let (label - (struct (f90-match-piece 3))) - (if (looking-at "\\(\\sw+\\)[ \t]*\:") - (setq label (f90-match-piece 1))) - (list struct label)))) - -(defsubst f90-looking-at-select-case () - "Return (\"select\" name) if a select-case statement starts after point. -Name is nil if the statement has no label." - (if (looking-at "\\(\\(\\sw+\\)[ \t]*\:\\)?[ \t]*\\(select\\)[ \t]*case[ \t]*(") - (let (label - (struct (f90-match-piece 3))) - (if (looking-at "\\(\\sw+\\)[ \t]*\:") - (setq label (f90-match-piece 1))) - (list struct label)))) - -(defsubst f90-looking-at-if-then () - "Return (\"if\" name) if an if () then statement starts after point. -Name is nil if the statement has no label." - (save-excursion - (let (struct (label nil)) - (if (looking-at "\\(\\(\\sw+\\)[ \t]*\:\\)?[ \t]*\\(if\\)\\>") - (progn - (setq struct (f90-match-piece 3)) - (if (looking-at "\\(\\sw+\\)[ \t]*\:") - (setq label (f90-match-piece 1))) - (goto-char (scan-lists (point) 1 0)) - (skip-chars-forward " \t") - (if (or (looking-at "then\\>") - (if (f90-line-continued) - (progn - (f90-next-statement) - (skip-chars-forward " \t0-9&") - (looking-at "then\\>")))) - (list struct label))))))) - -(defsubst f90-looking-at-where-or-forall () - "Return (kind nil) if where/forall...end starts after point." - (save-excursion - (let (command) - (if (looking-at "\\(where\\|forall\\)[ \t]*(") - (progn - (setq command (list (f90-match-piece 1) nil)) - (goto-char (scan-lists (point) 1 0)) - (skip-chars-forward " \t") - (if (looking-at "\\(!\\|$\\)") - command)))))) - -(defsubst f90-looking-at-type-like () - "Return (kind name) at the start of a type/interface/block-data block. -Name is non-nil only for type." - (cond - ((looking-at f90-type-def-re) - (list (f90-match-piece 1) (f90-match-piece 3))) - ((looking-at "\\(interface\\|block[\t]*data\\)\\>") - (list (f90-match-piece 1) nil)))) - -(defsubst f90-looking-at-program-block-start () - "Return (kind name) if a program block with name name starts after point." - (cond - ((looking-at "\\(program\\)[ \t]+\\(\\sw+\\)\\>") - (list (f90-match-piece 1) (f90-match-piece 2))) - ((and (not (looking-at "module[ \t]*procedure\\>")) - (looking-at "\\(module\\)[ \t]+\\(\\sw+\\)\\>")) - (list (f90-match-piece 1) (f90-match-piece 2))) - ((looking-at (concat - "\\(pure\\|recursive\\|extrinsic([^)]+)\\)?[ \t]*" - "\\(subroutine\\)[ \t]+\\(\\sw+\\)")) - (list (f90-match-piece 2) (f90-match-piece 3))) - ((and (not (looking-at "end[ \t]*function")) - (looking-at "[^!\"\&\\n]*\\(function\\)[ \t]+\\(\\sw+\\)")) - (list (f90-match-piece 1) (f90-match-piece 2))))) - -(defsubst f90-looking-at-program-block-end () - "Return list of type and name of end of block." - (if (looking-at (concat "end[ \t]*" f90-blocks-re - "?\\([ \t]+\\(\\sw+\\)\\)?\\>")) - (list (f90-match-piece 1) (f90-match-piece 3)))) - -(defsubst f90-comment-indent () - (cond ((looking-at "!!!") 0) - ((and f90-directive-comment-re - (looking-at f90-directive-comment-re)) 0) - ((looking-at (regexp-quote f90-comment-region)) 0) - ((looking-at f90-indented-comment-re) - (f90-calculate-indent)) - (t (skip-chars-backward " \t") - (max (if (bolp) 0 (1+ (current-column))) comment-column)))) - -(defsubst f90-present-statement-cont () - "Return continuation properties of present statement." - (let (pcont cont) - (save-excursion - (setq pcont (if (f90-previous-statement) (f90-line-continued) nil))) - (setq cont (f90-line-continued)) - (cond ((and (not pcont) (not cont)) 'single) - ((and (not pcont) cont) 'begin) - ((and pcont (not cont)) 'end) - ((and pcont cont) 'middle) - (t (error))))) - -(defsubst f90-indent-line-no () - (if f90-leave-line-no - () - (if (and (not (zerop (skip-chars-forward " \t"))) - (looking-at "[0-9]")) - (delete-horizontal-space))) - (skip-chars-forward " \t0-9")) - -(defsubst f90-no-block-limit () - (let ((eol (f90-get-end-of-line))) - (save-excursion - (not (or (looking-at "end") - (looking-at "\\(do\\|if\\|else\\|select[ \t]*case\\|\ -case\\|where\\|forall\\)\\>") - (looking-at "\\(program\\|module\\|interface\\|\ -block[ \t]*data\\)\\>") - (looking-at "\\(contains\\|\\sw+[ \t]*:\\)") - (looking-at f90-type-def-re) - (re-search-forward "\\(function\\|subroutine\\)" eol t)))))) - -(defsubst f90-update-line () - (let (bol eol) - (if f90-auto-keyword-case - (progn (setq bol (f90-get-beg-of-line) - eol (f90-get-end-of-line)) - (if f90-auto-keyword-case - (f90-change-keywords f90-auto-keyword-case bol eol)))))) - -(defun f90-get-correct-indent () - "Get correct indent for a line starting with line number. -Does not check type and subprogram indentation." - (let ((epnt (f90-get-end-of-line)) icol cont) - (save-excursion - (while (and (f90-previous-statement) - (or (progn - (setq cont (f90-present-statement-cont)) - (or (eq cont 'end) (eq cont 'middle))) - (looking-at "[ \t]*[0-9]")))) - (setq icol (current-indentation)) - (beginning-of-line) - (if (re-search-forward "\\(if\\|do\\|select\\|where\\|forall\\)" - (f90-get-end-of-line) t) - (progn - (beginning-of-line) (skip-chars-forward " \t") - (cond ((f90-looking-at-do) - (setq icol (+ icol f90-do-indent))) - ((or (f90-looking-at-if-then) - (f90-looking-at-where-or-forall) - (f90-looking-at-select-case)) - (setq icol (+ icol f90-if-indent)))) - (end-of-line))) - (while (re-search-forward - "\\(if\\|do\\|select\\|where\\|forall\\)" epnt t) - (beginning-of-line) (skip-chars-forward " \t0-9") - (cond ((f90-looking-at-do) - (setq icol (+ icol f90-do-indent))) - ((or (f90-looking-at-if-then) - (f90-looking-at-where-or-forall) - (f90-looking-at-select-case)) - (setq icol (+ icol f90-if-indent))) - ((looking-at f90-end-if-re) - (setq icol (- icol f90-if-indent))) - ((looking-at "end[ \t]*do\\>") - (setq icol (- icol f90-do-indent)))) - (end-of-line)) - icol))) - - -(defun f90-calculate-indent () - "Calculate the indent column based on previous statements." - (interactive) - (let (icol cont (case-fold-search t) (pnt (point))) - (save-excursion - (if (not (f90-previous-statement)) - (setq icol 0) - (setq cont (f90-present-statement-cont)) - (if (eq cont 'end) - (while (not (eq 'begin (f90-present-statement-cont))) - (f90-previous-statement))) - (cond ((eq cont 'begin) - (setq icol (+ (f90-current-indentation) - f90-continuation-indent))) - ((eq cont 'middle) (setq icol(current-indentation))) - (t (setq icol (f90-current-indentation)) - (skip-chars-forward " \t") - (if (looking-at "[0-9]") - (setq icol (f90-get-correct-indent)) - (cond ((or (f90-looking-at-if-then) - (f90-looking-at-where-or-forall) - (f90-looking-at-select-case) - (looking-at f90-else-like-re)) - (setq icol (+ icol f90-if-indent))) - ((f90-looking-at-do) - (setq icol (+ icol f90-do-indent))) - ((f90-looking-at-type-like) - (setq icol (+ icol f90-type-indent))) - ((or (f90-looking-at-program-block-start) - (looking-at "contains[ \t]*\\($\\|!\\)")) - (setq icol (+ icol f90-program-indent))))) - (goto-char pnt) - (beginning-of-line) - (cond ((looking-at "[ \t]*$")) - ((looking-at "[ \t]*#") ; Check for cpp directive. - (setq icol 0)) - (t - (skip-chars-forward " \t0-9") - (cond ((or (looking-at f90-else-like-re) - (looking-at f90-end-if-re)) - (setq icol (- icol f90-if-indent))) - ((looking-at "end[ \t]*do\\>") - (setq icol (- icol f90-do-indent))) - ((looking-at f90-end-type-re) - (setq icol (- icol f90-type-indent))) - ((or (looking-at "contains[ \t]*\\(!\\|$\\)") - (f90-looking-at-program-block-end)) - (setq icol (- icol f90-program-indent)))))) - )))) - icol)) - -;; Statement = statement line, a line which is neither blank, nor a comment. -(defun f90-previous-statement () - "Move point to beginning of the previous F90 statement. -Return nil if no previous statement is found." - (interactive) - (let (not-first-statement) - (beginning-of-line) - (while (and (setq not-first-statement (zerop (forward-line -1))) - (looking-at "[ \t0-9]*\\(!\\|$\\|#\\)"))) - not-first-statement)) - -(defun f90-next-statement () - "Move point to beginning of the next F90 statement. -Return nil if no later statement is found." - (interactive) - (let (not-last-statement) - (beginning-of-line) - (while (and (setq not-last-statement - (and (zerop (forward-line 1)) - (not (eobp)))) - (looking-at "[ \t0-9]*\\(!\\|$\\)"))) - not-last-statement)) - -(defun f90-beginning-of-subprogram () - "Move point to the beginning of subprogram. -Return (type name) or nil if not found." - (interactive) - (let ((count 1) (case-fold-search t) matching-beg) - (beginning-of-line) (skip-chars-forward " \t0-9") - (if (setq matching-beg (f90-looking-at-program-block-start)) - (setq count (- count 1))) - (while (and (not (zerop count)) - (re-search-backward f90-program-block-re nil 'move)) - (beginning-of-line) (skip-chars-forward " \t0-9") - (cond - ((setq matching-beg (f90-looking-at-program-block-start)) - (setq count (- count 1))) - ((f90-looking-at-program-block-end) - (setq count (+ count 1))))) - (beginning-of-line) - (if (zerop count) - matching-beg - (message "No beginning-found.") - nil))) - -(defun f90-end-of-subprogram () - "Move point to the end of subprogram. -Return (type name) or nil if not found." - (interactive) - (let ((count 1) (case-fold-search t) matching-end) - (beginning-of-line) (skip-chars-forward " \t0-9") - (if (setq matching-end (f90-looking-at-program-block-end)) - (setq count (1- count))) - (end-of-line) - (while (and (not (zerop count)) - (re-search-forward f90-program-block-re nil 'move)) - (beginning-of-line) (skip-chars-forward " \t0-9") - (cond ((f90-looking-at-program-block-start) - (setq count (+ count 1))) - ((setq matching-end (f90-looking-at-program-block-end)) - (setq count (1- count )))) - (end-of-line)) - (forward-line 1) - (if (zerop count) - matching-end - (message "No end found.") - nil))) - -(defun f90-mark-subprogram () - "Put mark at end of F90 subprogram, point at beginning. -Marks are pushed and highlight (grey shadow) is turned on." - (interactive) - (let ((pos (point)) program) - (f90-end-of-subprogram) - (push-mark (point) t) - (goto-char pos) - (setq program (f90-beginning-of-subprogram)) - ;; The keywords in the preceding lists assume case-insensitivity. - (if (string-match "XEmacs" emacs-version) - (zmacs-activate-region) - (setq mark-active t) - (setq deactivate-mark nil)) - program)) - -(defun f90-comment-region (beg-region end-region) - "Comment/uncomment every line in the region. -Insert f90-comment-region at the beginning of every line in the region -or, if already present, remove it." - (interactive "*r") - (let ((end (make-marker))) - (set-marker end end-region) - (goto-char beg-region) - (beginning-of-line) - (if (looking-at (regexp-quote f90-comment-region)) - (delete-region (point) (match-end 0)) - (insert f90-comment-region)) - (while (and (zerop (forward-line 1)) - (< (point) (marker-position end))) - (if (looking-at (regexp-quote f90-comment-region)) - (delete-region (point) (match-end 0)) - (insert f90-comment-region))) - (set-marker end nil))) - -(defun f90-indent-line (&optional no-update) - "Indent current line as F90 code." - (interactive) - (let (indent (no-line-number nil) (pos (make-marker)) (case-fold-search t)) - (set-marker pos (point)) - (beginning-of-line) ; Digits after & \n are not line-no - (if (save-excursion (and (f90-previous-statement) (f90-line-continued))) - (progn (setq no-line-number t) (skip-chars-forward " \t")) - (f90-indent-line-no)) - (if (looking-at "!") - (setq indent (f90-comment-indent)) - (if (and (looking-at "end") f90-smart-end) - (f90-match-end)) - (setq indent (f90-calculate-indent))) - (if (zerop (- indent (current-column))) - nil - (f90-indent-to indent no-line-number)) - ;; If initial point was within line's indentation, - ;; position after the indentation. Else stay at same point in text. - (if (< (point) (marker-position pos)) - (goto-char (marker-position pos))) - (if (not no-update) (f90-update-line)) - (if (and auto-fill-function - (> (save-excursion (end-of-line) (current-column)) fill-column)) - (save-excursion (f90-do-auto-fill))) - (set-marker pos nil))) - -(defun f90-indent-new-line () - "Reindent the current F90 line, insert a newline and indent the newline. -An abbrev before point is expanded if `abbrev-mode' is non-nil. -If run in the middle of a line, the line is not broken." - (interactive) - (let (string cont (case-fold-search t)) - (if abbrev-mode (expand-abbrev)) - (beginning-of-line) ; Reindent where likely to be needed. - (f90-indent-line-no) - (if (or (looking-at "\\(end\\|else\\|!\\)")) - (f90-indent-line 'no-update)) - (end-of-line) - (delete-horizontal-space) ;Destroy trailing whitespace - (setq string (f90-in-string)) - (setq cont (f90-line-continued)) - (if (and string (not cont)) (insert "&")) - (f90-update-line) - (newline) - (if (or string (and cont f90-beginning-ampersand)) (insert "&")) - (f90-indent-line 'no-update))) - - -(defun f90-indent-region (beg-region end-region) - "Indent every line in region by forward parsing." - (interactive "*r") - (let ((end-region-mark (make-marker)) (save-point (point-marker)) - (block-list nil) ind-lev ind-curr ind-b cont - struct beg-struct end-struct) - (set-marker end-region-mark end-region) - (goto-char beg-region) - ;; first find a line which is not a continuation line or comment - (beginning-of-line) - (while (and (looking-at "[ \t]*[0-9]*\\(!\\|#\\|[ \t]*$\\)") - (progn (f90-indent-line 'no-update) - (zerop (forward-line 1))) - (< (point) end-region-mark))) - (setq cont (f90-present-statement-cont)) - (while (and (or (eq cont 'middle) (eq cont 'end)) - (f90-previous-statement)) - (setq cont (f90-present-statement-cont))) - ;; process present line for beginning of block - (setq f90-cache-position (point)) - (f90-indent-line 'no-update) - (setq ind-lev (f90-current-indentation)) - (setq ind-curr ind-lev) - (beginning-of-line) (skip-chars-forward " \t0-9") - (setq struct nil) - (setq ind-b (cond ((setq struct (f90-looking-at-do)) f90-do-indent) - ((or (setq struct (f90-looking-at-if-then)) - (setq struct (f90-looking-at-select-case)) - (setq struct (f90-looking-at-where-or-forall)) - (looking-at f90-else-like-re)) - f90-if-indent) - ((setq struct (f90-looking-at-type-like)) - f90-type-indent) - ((or(setq struct (f90-looking-at-program-block-start)) - (looking-at "contains[ \t]*\\($\\|!\\)")) - f90-program-indent))) - (if ind-b (setq ind-lev (+ ind-lev ind-b))) - (if struct (setq block-list (cons struct block-list))) - (while (and (f90-line-continued) (zerop (forward-line 1)) - (< (point) end-region-mark)) - (if (not (zerop (- (current-indentation) - (+ ind-curr f90-continuation-indent)))) - (f90-indent-to (+ ind-curr f90-continuation-indent) 'no-line-no))) - ;; process all following lines - (while (and (zerop (forward-line 1)) (< (point) end-region-mark)) - (beginning-of-line) - (f90-indent-line-no) - (setq f90-cache-position (point)) - (cond ((looking-at "[ \t]*$") (setq ind-curr 0)) - ((looking-at "[ \t]*#") (setq ind-curr 0)) - ((looking-at "!") (setq ind-curr (f90-comment-indent))) - ((f90-no-block-limit) (setq ind-curr ind-lev)) - ((looking-at f90-else-like-re) (setq ind-curr - (- ind-lev f90-if-indent))) - ((looking-at "contains[ \t]*\\($\\|!\\)") - (setq ind-curr (- ind-lev f90-program-indent))) - ((setq ind-b - (cond ((setq struct (f90-looking-at-do)) f90-do-indent) - ((or (setq struct (f90-looking-at-if-then)) - (setq struct (f90-looking-at-select-case)) - (setq struct (f90-looking-at-where-or-forall))) - f90-if-indent) - ((setq struct (f90-looking-at-type-like)) - f90-type-indent) - ((setq struct (f90-looking-at-program-block-start)) - f90-program-indent))) - (setq ind-curr ind-lev) - (if ind-b (setq ind-lev (+ ind-lev ind-b))) - (setq block-list (cons struct block-list))) - ((setq end-struct (f90-looking-at-program-block-end)) - (setq beg-struct (car block-list) - block-list (cdr block-list)) - (if f90-smart-end - (save-excursion - (f90-block-match (car beg-struct)(car (cdr beg-struct)) - (car end-struct)(car (cdr end-struct))))) - (setq ind-b - (cond ((looking-at f90-end-if-re) f90-if-indent) - ((looking-at "end[ \t]*do\\>") f90-do-indent) - ((looking-at f90-end-type-re) f90-type-indent) - ((f90-looking-at-program-block-end) - f90-program-indent))) - (if ind-b (setq ind-lev (- ind-lev ind-b))) - (setq ind-curr ind-lev)) - (t (setq ind-curr ind-lev))) - ;; do the indentation if necessary - (if (not (zerop (- ind-curr (current-column)))) - (f90-indent-to ind-curr)) - (while (and (f90-line-continued) (zerop (forward-line 1)) - (< (point) end-region-mark)) - (if (not (zerop (- (current-indentation) - (+ ind-curr f90-continuation-indent)))) - (f90-indent-to (+ ind-curr f90-continuation-indent) 'no-line-no)))) - ;; restore point etc - (setq f90-cache-position nil) - (goto-char save-point) - (set-marker end-region-mark nil) - (set-marker save-point nil) - (if (string-match "XEmacs" emacs-version) - (zmacs-deactivate-region) - (deactivate-mark)))) - -(defun f90-indent-subprogram () - "Properly indent the subprogram which contains point." - (interactive) - (save-excursion - (let (program) - (setq program (f90-mark-subprogram)) - (if program - (progn - (message "Indenting %s %s..." - (car program) (car (cdr program))) - (f90-indent-region (point) (mark)) - (message "Indenting %s %s...done" - (car program) (car (cdr program)))) - (message "Indenting the whole file...") - (f90-indent-region (point) (mark)) - (message "Indenting the whole file...done"))))) - -;; autofill and break-line -(defun f90-break-line (&optional no-update) - "Break line at point, insert continuation marker(s) and indent." - (interactive) - (let (ctype) - (cond ((f90-in-string) - (insert "&") (newline) (insert "&")) - ((f90-in-comment) - (delete-horizontal-space) - (setq ctype (f90-get-present-comment-type)) - (newline) (insert (concat ctype " "))) - (t (delete-horizontal-space) - (insert "&") - (if (not no-update) (f90-update-line)) - (newline) - (if f90-beginning-ampersand (insert "& "))))) - (if (not no-update) (f90-indent-line))) - -(defun f90-find-breakpoint () - "From fill-column, search backward for break-delimiter." - (let ((bol (f90-get-beg-of-line))) - (re-search-backward f90-break-delimiters bol) - (if f90-break-before-delimiters - (progn (backward-char) - (if (not (looking-at f90-no-break-re)) - (forward-char))) - (if (looking-at f90-no-break-re) - (forward-char 2) - (forward-char))))) - -(defun f90-auto-fill-mode (arg) - "Toggle f90-auto-fill mode. -With ARG, turn `f90-auto-fill' mode on iff ARG is positive. -In `f90-auto-fill' mode, inserting a space at a column beyond `fill-column' -automatically breaks the line at a previous space." - (interactive "P") - (prog1 (setq auto-fill-function - (if (if (null arg) - (not auto-fill-function) - (> (prefix-numeric-value arg) 0)) - 'f90-do-auto-fill)) - (force-mode-line-update))) - -(defun f90-do-auto-fill () - "Break line if non-white characters beyond fill-column." - (interactive) - ;; Break the line before or after the last delimiter (non-word char). - ;; Will not break **, //, or => (specified by f90-no-break-re). - ;; Start by checking that line is longer than fill-column. - (if (> (save-excursion (end-of-line) (current-column)) fill-column) - (progn - (move-to-column fill-column) - (if (and (looking-at "[ \t]*$") (not (f90-in-string))) - (delete-horizontal-space) - (f90-find-breakpoint) - (f90-break-line) - (end-of-line))))) - -(defun f90-join-lines () - "Join present line with next line, if this line ends with \&." - (interactive) - (let (pos (oldpos (point))) - (end-of-line) - (skip-chars-backward " \t") - (cond ((= (preceding-char) ?&) - (delete-char -1) - (setq pos (point)) - (forward-line 1) - (skip-chars-forward " \t") - (if (looking-at "\&") (delete-char 1)) - (delete-region pos (point)) - (if (not (f90-in-string)) - (progn (delete-horizontal-space) (insert " "))) - (if (and auto-fill-function - (> (save-excursion (end-of-line) - (current-column)) - fill-column)) - (f90-do-auto-fill)) - (goto-char oldpos) - t)))) - -(defun f90-fill-region (beg-region end-region) - "Fill every line in region by forward parsing. Join lines if possible." - (interactive "*r") - (let ((end-region-mark (make-marker)) - (f90-smart-end nil) (f90-auto-keyword-case nil) indent (go-on t) - (af-function auto-fill-function) (auto-fill-function nil)) - (set-marker end-region-mark end-region) - (goto-char beg-region) - (while go-on - ;; join as much as possible - (while (f90-join-lines)); - (setq indent (+ (f90-current-indentation) f90-continuation-indent)) - ;; chop the line if necessary - (while (> (save-excursion (end-of-line) (current-column)) - fill-column) - (move-to-column fill-column) - (if (and (looking-at "[ \t]*$") (not (f90-in-string))) - (delete-horizontal-space) - (f90-find-breakpoint) - (f90-break-line 'no-update) - (f90-indent-to indent 'no-line-no))) - (setq go-on (and (< (point) (marker-position end-region-mark)) - (zerop (forward-line 1)))) - (setq f90-cache-position (point))) - (setq auto-fill-function af-function) - (setq f90-cache-position nil) - (if (string-match "XEmacs" emacs-version) - (zmacs-deactivate-region) - (deactivate-mark)))) - -(defun f90-block-match (beg-block beg-name end-block end-name) - "Match end-struct with beg-struct and complete end-block if possible. -Leave point at the end of line." - (search-forward "end" (f90-get-end-of-line)) - (catch 'no-match - (if (not (f90-equal-symbols beg-block end-block)) - (if end-block - (progn - (message "END %s does not match %s." end-block beg-block) - (end-of-line) - (throw 'no-match nil)) - (message "Inserting %s." beg-block) - (insert (concat " " beg-block))) - (search-forward end-block)) - (if (not (f90-equal-symbols beg-name end-name)) - (cond ((and beg-name (not end-name)) - (message "Inserting %s." beg-name) - (insert (concat " " beg-name))) - ((and beg-name end-name) - (message "Replacing %s with %s." end-name beg-name) - (search-forward end-name) - (replace-match beg-name)) - ((and (not beg-name) end-name) - (message "Deleting %s." end-name) - (search-forward end-name) - (replace-match ""))) - (if end-name (search-forward end-name))) - (if (not (looking-at "[ \t]*!")) (delete-horizontal-space)))) - -(defun f90-match-end () - "From an end foo statement, find the corresponding foo including name." - (interactive) - (let ((count 1) (top-of-window (window-start)) (matching-beg nil) - (end-point (point)) (case-fold-search t) - beg-name end-name beg-block end-block end-struct) - (if (save-excursion (beginning-of-line) (skip-chars-forward " \t0-9") - (setq end-struct (f90-looking-at-program-block-end))) - (progn - (setq end-block (car end-struct)) - (setq end-name (car (cdr end-struct))) - (save-excursion - (beginning-of-line) - (while - (and (not (zerop count)) - (let ((stop nil) notexist) - (while (not stop) - (setq notexist - (not (re-search-backward - (concat "\\(" f90-blocks-re "\\)") nil t))) - (if notexist - (setq stop t) - (setq stop - (not (or (f90-in-string) - (f90-in-comment)))))) - (not notexist))) - (beginning-of-line) (skip-chars-forward " \t0-9") - (cond ((setq matching-beg - (cond - ((f90-looking-at-do)) - ((f90-looking-at-if-then)) - ((f90-looking-at-where-or-forall)) - ((f90-looking-at-select-case)) - ((f90-looking-at-type-like)) - ((f90-looking-at-program-block-start)))) - (setq count (- count 1))) - ((looking-at (concat "end[ \t]*" f90-blocks-re "\\b")) - (setq count (+ count 1))))) - (if (not (zerop count)) - (message "No matching beginning.") - (f90-update-line) - (if (eq f90-smart-end 'blink) - (if (< (point) top-of-window) - (message "Matches %d: %s" - (what-line) - (buffer-substring - (progn (beginning-of-line) (point)) - (progn (end-of-line) (point)))) - (sit-for 1))) - (setq beg-block (car matching-beg)) - (setq beg-name (car (cdr matching-beg))) - (goto-char end-point) - (beginning-of-line) - (f90-block-match beg-block beg-name end-block end-name))))))) - -(defun f90-insert-end () - "Inserts an complete end statement matching beginning of present block." - (interactive) - (let ((f90-smart-end (if f90-smart-end f90-smart-end 'blink))) - (insert "end") - (f90-indent-new-line))) - -;; abbrevs and keywords - -(defun f90-abbrev-start () - "Typing `\\[help-command] or `? lists all the F90 abbrevs. -Any other key combination is executed normally." - (interactive) - (let (e c) - (insert last-command-char) - (if (string-match "XEmacs" emacs-version) - (progn - (setq e (next-command-event)) - (setq c (event-to-character e))) - (setq c (read-event))) - ;; insert char if not equal to `?' - (if (or (= c ??) (eq c help-char)) - (f90-abbrev-help) - (if (string-match "XEmacs" emacs-version) - (setq unread-command-event e) - (setq unread-command-events (list c)))))) - -(defun f90-abbrev-help () - "List the currently defined abbrevs in F90 mode." - (interactive) - (message "Listing abbrev table...") - (display-buffer (f90-prepare-abbrev-list-buffer)) - (message "Listing abbrev table...done")) - -(defun f90-prepare-abbrev-list-buffer () - (save-excursion - (set-buffer (get-buffer-create "*Abbrevs*")) - (erase-buffer) - (insert-abbrev-table-description 'f90-mode-abbrev-table t) - (goto-char (point-min)) - (set-buffer-modified-p nil) - (edit-abbrevs-mode)) - (get-buffer-create "*Abbrevs*")) - -(defun f90-upcase-keywords () - "Upcase all F90 keywords in the buffer." - (interactive) - (f90-change-keywords 'upcase-word)) - -(defun f90-capitalize-keywords () - "Capitalize all F90 keywords in the buffer." - (interactive) - (f90-change-keywords 'capitalize-word)) - -(defun f90-downcase-keywords () - "Downcase all F90 keywords in the buffer." - (interactive) - (f90-change-keywords 'downcase-word)) - -(defun f90-upcase-region-keywords (beg end) - "Upcase all F90 keywords in the region." - (interactive "*r") - (f90-change-keywords 'upcase-word beg end)) - -(defun f90-capitalize-region-keywords (beg end) - "Capitalize all F90 keywords in the region." - (interactive "*r") - (f90-change-keywords 'capitalize-word beg end)) - -(defun f90-downcase-region-keywords (beg end) - "Downcase all F90 keywords in the region." - (interactive "*r") - (f90-change-keywords 'downcase-word beg end)) - -;; Change the keywords according to argument. -(defun f90-change-keywords (change-word &optional beg end) - (save-excursion - (setq beg (if beg beg (point-min))) - (setq end (if end end (point-max))) - (let ((keyword-re - (concat "\\(" - f90-keywords-re "\\|" f90-procedures-re "\\|" - f90-hpf-keywords-re "\\|" f90-operators-re "\\)")) - (ref-point (point-min)) state - (modified (buffer-modified-p)) saveword back-point) - (goto-char beg) - (unwind-protect - (while (re-search-forward keyword-re end t) - (if (progn - (setq state (parse-partial-sexp ref-point (point))) - (or (nth 3 state) (nth 4 state) - (save-excursion ; Check for cpp directive. - (beginning-of-line) - (skip-chars-forward " \t0-9") - (looking-at "#")))) - () - (setq ref-point (point) - back-point (save-excursion (backward-word 1) (point))) - (setq saveword (buffer-substring back-point ref-point)) - (funcall change-word -1) - (or (string= saveword (buffer-substring back-point ref-point)) - (setq modified t)))) - (or modified (set-buffer-modified-p nil)))))) - -(provide 'f90) - -;;; f90.el ends here
--- a/lisp/modes/fortran-misc.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,210 +0,0 @@ -;;; fortran-misc.el --- Routines than can be used with fortran mode. - -;;; Copyright (c) 1992 Free Software Foundation, Inc. - -;; Author: Various authors. -;; Maintainer: -;; Version -;; Keywords: languages - -;; This file is not part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: - -;;; This file contains various routines that may be useful with GNU emacs -;;; fortran mode, but just don't seem to fit in. - -(defun fortran-fill-statement () - "Fill a fortran statement up to `fill-column'." - (interactive) - (if (save-excursion - (beginning-of-line) - (or (looking-at "[ \t]*$") - (looking-at comment-line-start-skip) - (and comment-start-skip - (looking-at (concat "[ \t]*" comment-start-skip))))) - (fortran-indent-line) - (let ((opos (point)) (beg) (cfi)) - (save-excursion - (fortran-next-statement) - (fortran-previous-statement) - (setq cfi (calculate-fortran-indent)) - (setq beg (point))) - (save-excursion - (goto-char beg) - (save-excursion - ;;(beginning-of-line) - (if (or (not (= cfi (fortran-current-line-indentation))) - (and (re-search-forward "^[ \t]*[0-9]+" (+ (point) 4) t) - (not (fortran-line-number-indented-correctly-p)))) - (fortran-indent-to-column cfi))) - (while (progn - (forward-line 1) - (or (looking-at " [^ 0\n]") - (looking-at "\t[1-9]"))) - (delete-indentation) - (delete-char 2) - (delete-horizontal-space)) - (fortran-previous-statement) - (if (> (save-excursion (end-of-line) (current-column)) fill-column) - (fortran-do-auto-fill))) - (if (< (point) opos) (goto-char opos)) - (let ((cfi (calculate-fortran-indent))) - (if (< (current-column) cfi) - (move-to-column cfi)))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; The upcase/downcase and beautifier code is originally from Ralph Finch -;;; (rfinch@water.ca.gov). -;;; -(defun fortran-downcase-subprogram () - "Properly downcases the Fortran subprogram which contains point." - (interactive) - (save-excursion - (mark-fortran-subprogram) - (message "Downcasing subprogram...") - (fortran-downcase-region (point) (mark))) - (message "Downcasing subprogram...done.")) - -(defun fortran-downcase-region (start end) - "Downcase region, excluding comment lines and anything -between quote marks." - (interactive "r") - (fortran-case-region start end nil)) - -(defun fortran-upcase-region (start end) - "Upcase region, excluding comment lines and anything -between quote marks." - (interactive "r") - (fortran-case-region start end t)) - -(defun fortran-upcase-subprogram () - "Properly upcases the Fortran subprogram which contains point." - (interactive) - (save-excursion - (mark-fortran-subprogram) - (message "Upcasing subprogram...") - (fortran-upcase-region (point) (mark))) - (message "Upcasing subprogram...done.")) - -(defun fortran-case-region (start end up) - "Upcase region if UP is t, downcase, if UP downcase region, - excluding comment lines and anything between quote marks." - (let* ((start-re-comment "^[cC*#]") - (end-re-comment "$") - (start-re-quote "'") - (end-re-quote "\\('\\|$\\)") - (start-re-dquote (char-to-string ?\")) - (end-re-dquote (concat "\\(" start-re-dquote "\\|$\\)")) - (strt) (fin)) - (save-excursion - (save-restriction - (narrow-to-region start end) - (goto-char (point-min)) - (if (inside-re start-re-comment end-re-comment) - (re-search-forward end-re-comment end 0)) - (if (inside-re start-re-quote end-re-quote) - (re-search-forward end-re-quote end 0)) - (if (inside-re start-re-dquote end-re-dquote) - (re-search-forward end-re-dquote end 0)) - (setq strt (point)) - (while (< (point) (point-max)) - (re-search-forward - (concat "\\(" start-re-comment "\\|" - start-re-quote "\\|" start-re-dquote "\\)") end 0) - (setq fin (point)) - (if up - (upcase-region strt fin) - (downcase-region strt fin)) - (if (inside-re start-re-comment end-re-comment) - (re-search-forward end-re-comment end 0)) - (if (inside-re start-re-quote end-re-quote) - (re-search-forward end-re-quote end 0)) - (if (inside-re start-re-dquote end-re-dquote) - (re-search-forward end-re-dquote end 0)) - (setq strt (point))))))) - -(defun inside-re (start-re end-re) - "Returns t if inside a starting regexp and an ending regexp -on the same line." - (interactive "s") - (let ((start-line) (end-line)) - (save-excursion - (setq start-line (progn (beginning-of-line) (point))) - (setq end-line (progn (end-of-line) (point)))) - (if (and (save-excursion - (re-search-backward start-re start-line t)) - (save-excursion - (re-search-forward end-re end-line t))) - t - nil))) - -;;; Note: Just as with some other routines, fortran-beautify-line -;;; assumes trailing blanks are not significant. Code may need -;;; to be adjusted to comply with this. - - -(defun fortran-beautify-subprogram (&optional downit) - "Beautify Fortran subprogram: -1) Remove trailing blanks. -2) Replace all continuation characters with fortran-continuation-char. -3) Replace all empty comment lines with blank lines. -4) Replace all multiple blank lines with one blank line. -5) Indent. -6) With prefix arg, downcase the subprogram, avoiding comments and -quoted strings." - (interactive "P") - (save-excursion - (mark-fortran-subprogram) - (message "Beautifying subprogram...") - (fortran-beautify-region (point) (mark) downit)) - (message "Beautify subprogram...done.")) - -(defun fortran-beautify-region (start end &optional downit) - "Beautify region in a Fortran program: -1) Remove trailing blanks. -2) Replace all continuation characters with fortran-continuation-char. -3) Replace all empty comment lines with blank lines. -4) Replace all multiple blank lines with one blank line. -5) Indent. -6) With prefix arg, downcase the region, avoiding comments and - quoted strings." - (interactive "r\nP") - (save-excursion - (save-restriction - (let ((m1 (make-marker)) - (m2 (make-marker))) - (set-marker m1 start) - (set-marker m2 end) - (indent-region start end nil) - (narrow-to-region m1 m2) - (goto-char (point-min)) ; trailing blanks - (perform-replace "[ \t]+$" "" nil t nil) - (goto-char (point-min)) ; continuation characters - (perform-replace (concat "^ [^ " fortran-continuation-string - "]" ) - (concat " " fortran-continuation-string) - nil t nil) - (goto-char (point-min)) ; empty comments - (perform-replace "^[cC][ \t]*$" "" nil t nil) - (goto-char (point-min)) ; multiple blank lines - (perform-replace "\n\n\n+" "\n\n" nil t nil) - (if downit - (fortran-downcase-region (point-min) (point-max))) - ))) - -)
--- a/lisp/modes/fortran.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1749 +0,0 @@ -;;; fortran.el --- Fortran mode for GNU Emacs - -;; Copyright (c) 1986, 1993, 1994, 1995 Free Software Foundation, Inc. - -;; Author: Michael D. Prange <prange@erl.mit.edu> -;; Maintainer: bug-fortran-mode@erl.mit.edu -;; Version 1.30.6-x (July 27, 1995) -;; Keywords: languages - -;; 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.34. - -;;; Commentary: - -;; Fortran mode has been upgraded and is now maintained by Stephen A. Wood -;; (saw@cebaf.gov). It now will use either fixed format continuation line -;; markers (character in 6th column), or tab format continuation line style -;; (digit after a TAB character.) A auto-fill mode has been added to -;; automatically wrap fortran lines that get too long. - -;; We acknowledge many contributions and valuable suggestions by -;; Lawrence R. Dodd, Ralf Fassel, Ralph Finch, Stephen Gildea, -;; Dr. Anil Gokhale, Ulrich Mueller, Mark Neale, Eric Prestemon, -;; Gary Sabot and Richard Stallman. - -;; This file may be used with GNU Emacs version 18.xx if the following -;; variable and function substitutions are made. -;; Replace: -;; frame-width with screen-width -;; auto-fill-function with auto-fill-hook -;; comment-indent-function with comment-indent-hook -;; (setq unread-command-events (list c)) with (setq unread-command-char c) - -;; Bugs to bug-fortran-mode@erl.mit.edu - -;;; Code: - -(defconst fortran-mode-version "version 1.30.6-x") - -(defgroup fortran nil - "Fortran mode for Emacs" - :group 'languages) - -(defgroup fortran-indent nil - "Indentation variables in Fortran mode" - :prefix "fortran-" - :group 'fortran) - -(defgroup fortran-comment nil - "Comment-handling variables in Fortran mode" - :prefix "fortran-" - :group 'fortran) - - -;;;###autoload -(defcustom fortran-tab-mode-default nil - "*Default tabbing/carriage control style for empty files in Fortran mode. -A value of t specifies tab-digit style of continuation control. -A value of nil specifies that continuation lines are marked -with a character in column 6." - :type 'boolean - :group 'fortran-indent) - -;; Buffer local, used to display mode line. -(defcustom fortran-tab-mode-string nil - "String to appear in mode line when TAB format mode is on." - :type '(choice (const nil) string) - :group 'fortran-indent) - -(defcustom fortran-do-indent 3 - "*Extra indentation applied to DO blocks." - :type 'integer - :group 'fortran-indent) - -(defcustom fortran-if-indent 3 - "*Extra indentation applied to IF blocks." - :type 'integer - :group 'fortran-indent) - -(defcustom fortran-structure-indent 3 - "*Extra indentation applied to STRUCTURE, UNION, MAP and INTERFACE blocks." - :type 'integer - :group 'fortran-indent) - -(defcustom fortran-continuation-indent 5 - "*Extra indentation applied to Fortran continuation lines." - :type 'integer - :group 'fortran-indent) - -(defcustom fortran-comment-indent-style 'fixed - "*nil forces comment lines not to be touched, -'fixed makes fixed comment indentation to `fortran-comment-line-extra-indent' -columns beyond `fortran-minimum-statement-indent-fixed' (for -`indent-tabs-mode' of nil) or `fortran-minimum-statement-indent-tab' (for -`indent-tabs-mode' of t), and 'relative indents to current -Fortran indentation plus `fortran-comment-line-extra-indent'." - :type '(radio (const nil) (const fixed) (const relative)) - :group 'fortran-indent) - -(defcustom fortran-comment-line-extra-indent 0 - "*Amount of extra indentation for text within full-line comments." - :type 'integer - :group 'fortran-indent - :group 'fortran-comment) - -(defcustom comment-line-start nil - "*Delimiter inserted to start new full-line comment." - :type '(choice string (const nil)) - :group 'fortran-comment) - -(defcustom comment-line-start-skip nil - "*Regexp to match the start of a full-line comment." - :type '(choice string (const nil)) - :group 'fortran-comment) - -(defcustom fortran-minimum-statement-indent-fixed 6 - "*Minimum statement indentation for fixed format continuation style." - :type 'integer - :group 'fortran-indent) - -(defcustom fortran-minimum-statement-indent-tab (max tab-width 6) - "*Minimum statement indentation for TAB format continuation style." - :type 'integer - :group 'fortran-indent) - -;; Note that this is documented in the v18 manuals as being a string -;; of length one rather than a single character. -;; The code in this file accepts either format for compatibility. -(defcustom fortran-comment-indent-char " " - "*Single-character string inserted for Fortran comment indentation. -Normally a space." - :type 'string - :group 'fortran-comment) - -(defcustom fortran-line-number-indent 1 - "*Maximum indentation for Fortran line numbers. -5 means right-justify them within their five-column field." - :type 'integer - :group 'fortran-indent) - -(defcustom fortran-check-all-num-for-matching-do nil - "*Non-nil causes all numbered lines to be treated as possible DO loop ends." - :type 'boolean - :group 'fortran) - -(defcustom fortran-blink-matching-if nil - "*Non-nil causes \\[fortran-indent-line] on ENDIF statement to blink on matching IF. -Also, from an ENDDO statement blink on matching DO [WHILE] statement." - :type 'boolean - :group 'fortran) - -(defcustom fortran-continuation-string "$" - "*Single-character string used for Fortran continuation lines. -In fixed format continuation style, this character is inserted in -column 6 by \\[fortran-split-line] to begin a continuation line. -Also, if \\[fortran-indent-line] finds this at the beginning of a line, it will -convert the line into a continuation line of the appropriate style. -Normally $." - :type 'string - :group 'fortran) - -(defcustom fortran-comment-region "c$$$" - "*String inserted by \\[fortran-comment-region]\ - at start of each line in region." - :type 'string - :group 'fortran-comment) - -(defcustom fortran-electric-line-number t - "*Non-nil causes line number digits to be moved to the correct column as\ - typed." - :type 'boolean - :group 'fortran) - -(defcustom fortran-startup-message t - "*Non-nil displays a startup message when Fortran mode is first called." - :type 'boolean - :group 'fortran) - -(defvar fortran-column-ruler-fixed - "0 4 6 10 20 30 40 5\ -\0 60 70\n\ -\[ ]|{ | | | | | | | | \ -\| | | | |}\n" - "*String displayed above current line by \\[fortran-column-ruler]. -This variable used in fixed format mode.") - -(defvar fortran-column-ruler-tab - "0 810 20 30 40 5\ -\0 60 70\n\ -\[ ]| { | | | | | | | | \ -\| | | | |}\n" - "*String displayed above current line by \\[fortran-column-ruler]. -This variable used in TAB format mode.") - -(defconst bug-fortran-mode "bug-fortran-mode@erl.mit.edu" - "Address of mailing list for Fortran mode bugs.") - -(defvar fortran-mode-syntax-table nil - "Syntax table in use in Fortran mode buffers.") - -(defvar fortran-analyze-depth 100 - "Number of lines to scan to determine whether to use fixed or TAB format\ - style.") - -(defcustom fortran-break-before-delimiters t - "*Non-nil causes `fortran-fill' to break lines before delimiters." - :type 'boolean - :group 'fortran) - -(if fortran-mode-syntax-table - () - (setq fortran-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?\; "w" fortran-mode-syntax-table) - (modify-syntax-entry ?\r " " fortran-mode-syntax-table) - (modify-syntax-entry ?+ "." fortran-mode-syntax-table) - (modify-syntax-entry ?- "." fortran-mode-syntax-table) - (modify-syntax-entry ?= "." fortran-mode-syntax-table) - ;; XEmacs change - ;;(modify-syntax-entry ?* "." fortran-mode-syntax-table) - (modify-syntax-entry ?/ "." fortran-mode-syntax-table) - (modify-syntax-entry ?\' "\"" fortran-mode-syntax-table) - (modify-syntax-entry ?\" "\"" fortran-mode-syntax-table) - (modify-syntax-entry ?\\ "/" fortran-mode-syntax-table) - (modify-syntax-entry ?. "_" fortran-mode-syntax-table) - (modify-syntax-entry ?_ "_" fortran-mode-syntax-table) - (modify-syntax-entry ?$ "_" fortran-mode-syntax-table) - (modify-syntax-entry ?@ "_" fortran-mode-syntax-table) - (modify-syntax-entry ?\! "<" fortran-mode-syntax-table) - ;; XEmacs change - ;;(modify-syntax-entry ?\n ">" fortran-mode-syntax-table) - - ;; XEmacs: an attempt to make font-lock understand fortran comments. - (modify-syntax-entry ?\n "> 1" fortran-mode-syntax-table) - (modify-syntax-entry ?* ". 2" fortran-mode-syntax-table) - (modify-syntax-entry ?c "w 2" fortran-mode-syntax-table) - (modify-syntax-entry ?C "w 2" fortran-mode-syntax-table) - - ) - -;; Comments are real pain in Fortran because there is no way to represent the -;; standard comment syntax in an Emacs syntax table (we can for VAX-style). -;; Therefore an unmatched quote in a standard comment will throw fontification -;; off on the wrong track. So we do syntactic fontification with regexps. - -;; Regexps done by simon@gnu with help from Ulrik Dickow <dickow@nbi.dk> and -;; probably others Si's forgotten about (sorry). - -(defconst fortran-font-lock-keywords-1 nil - "Subdued level highlighting for Fortran mode.") - -(defconst fortran-font-lock-keywords-2 nil - "Medium level highlighting for Fortran mode.") - -(defconst fortran-font-lock-keywords-3 nil - "Gaudy level highlighting for Fortran mode.") - -(let ((comment-chars "c!*") - (fortran-type-types -; (make-regexp -; (let ((simple-types '("character" "byte" "integer" "logical" -; "none" "real" "complex" -; "double[ \t]*precision" "double[ \t]*complex")) -; (structured-types '("structure" "union" "map")) -; (other-types '("record" "dimension" "parameter" "common" "save" -; "external" "intrinsic" "data" "equivalence"))) -; (append -; (mapcar (lambda (x) (concat "implicit[ \t]*" x)) simple-types) -; simple-types -; (mapcar (lambda (x) (concat "end[ \t]*" x)) structured-types) -; structured-types -; other-types))) - (concat "byte\\|c\\(haracter\\|om\\(mon\\|plex\\)\\)\\|" - "d\\(ata\\|imension\\|ouble" - "[ \t]*\\(complex\\|precision\\)\\)\\|" - "e\\(nd[ \t]*\\(map\\|structure\\|union\\)\\|" - "quivalence\\|xternal\\)\\|" - "i\\(mplicit[ \t]*\\(byte\\|" - "c\\(haracter\\|omplex\\)\\|" - "double[ \t]*\\(complex\\|precision\\)\\|" - "integer\\|logical\\|none\\|real\\)\\|" - "nt\\(eger\\|rinsic\\)\\)\\|" - "logical\\|map\\|none\\|parameter\\|re\\(al\\|cord\\)\\|" - "s\\(ave\\|tructure\\)\\|union")) - (fortran-keywords -; ("continue" "format" "end" "enddo" "if" "then" "else" "endif" -; "elseif" "while" "inquire" "stop" "return" "include" "open" -; "close" "read" "write" "format" "print") - (concat "c\\(lose\\|ontinue\\)\\|" - "e\\(lse\\(\\|if\\)\\|nd\\(\\|do\\|if\\)\\)\\|format\\|" - "i\\(f\\|n\\(clude\\|quire\\)\\)\\|open\\|print\\|" - "re\\(ad\\|turn\\)\\|stop\\|then\\|w\\(hile\\|rite\\)")) - (fortran-logicals -; ("and" "or" "not" "lt" "le" "eq" "ge" "gt" "ne" "true" "false") - "and\\|eq\\|false\\|g[et]\\|l[et]\\|n\\(e\\|ot\\)\\|or\\|true")) - - (setq fortran-font-lock-keywords-1 - (list - ;; - ;; Fontify syntactically (assuming strings cannot be quoted or span lines). - (cons (concat "^[" comment-chars "].*") 'font-lock-comment-face) - '(fortran-match-!-comment . font-lock-comment-face) - (list (concat "^[^" comment-chars "\t\n]" (make-string 71 ?.) "\\(.*\\)") - '(1 font-lock-comment-face)) - '("'[^'\n]*'?" . font-lock-string-face) - ;; - ;; Program, subroutine and function declarations, plus calls. - (list (concat "\\<\\(block[ \t]*data\\|call\\|entry\\|function\\|" - "program\\|subroutine\\)\\>[ \t]*\\(\\(\\sw\\|\\s_\\)+\\)?") - '(1 font-lock-keyword-face) - '(2 font-lock-function-name-face nil t)))) - - (setq fortran-font-lock-keywords-2 - (append fortran-font-lock-keywords-1 - (list - ;; - ;; Fontify all type specifiers (must be first; see below). - (cons (concat "\\<\\(" fortran-type-types "\\)\\>") 'font-lock-type-face) - ;; - ;; Fontify all builtin keywords (except logical, do and goto; see below). - (concat "\\<\\(" fortran-keywords "\\)\\>") - ;; - ;; Fontify all builtin operators. - (concat "\\.\\(" fortran-logicals "\\)\\.") - ;; - ;; Fontify do/goto keywords and targets, and goto tags. - (list "\\<\\(do\\|go *to\\)\\>[ \t]*\\([0-9]+\\)?" - '(1 font-lock-keyword-face) - '(2 font-lock-reference-face nil t)) - (cons "^ *\\([0-9]+\\)" 'font-lock-reference-face)))) - - (setq fortran-font-lock-keywords-3 - (append - ;; - ;; The list `fortran-font-lock-keywords-1'. - fortran-font-lock-keywords-1 - ;; - ;; Fontify all type specifiers plus their declared items. - (list - (list (concat "\\<\\(" fortran-type-types "\\)\\>[ \t(/]*\\(*\\)?") - ;; Fontify the type specifier. - '(1 font-lock-type-face) - ;; Fontify each declaration item (or just the /.../ block name). - '(font-lock-match-c++-style-declaration-item-and-skip-to-next - ;; Start after any *(...) expression. - (and (match-beginning 15) (forward-sexp 1)) - ;; No need to clean up. - nil - ;; Fontify as a variable name, functions are fontified elsewhere. - (1 font-lock-variable-name-face nil t)))) - ;; - ;; Things extra to `fortran-font-lock-keywords-3' (must be done first). - (list - ;; - ;; Fontify goto-like `err=label'/`end=label' in read/write statements. - '(", *\\(e\\(nd\\|rr\\)\\)\\> *\\(= *\\([0-9]+\\)\\)?" - (1 font-lock-keyword-face) (4 font-lock-reference-face nil t)) - ;; - ;; Highlight standard continuation character and in a TAB-formatted line. - '("^ \\([^ 0]\\)" 1 font-lock-string-face) - '("^\t\\([1-9]\\)" 1 font-lock-string-face)) - ;; - ;; The list `fortran-font-lock-keywords-2' less that for types (see above). - (cdr (nthcdr (length fortran-font-lock-keywords-1) - fortran-font-lock-keywords-2)))) - ) - -(defvar fortran-font-lock-keywords fortran-font-lock-keywords-1 - "Default expressions to highlight in Fortran mode.") - -;; XEmacs change -(put 'fortran-mode 'font-lock-defaults '((fortran-font-lock-keywords - fortran-font-lock-keywords-1 - fortran-font-lock-keywords-2 - fortran-font-lock-keywords-3) - t t ((?/ . "$/")))) - -;; Our previous version. - -;(defconst fortran-font-lock-keywords-1 -; (purecopy -; (list -; ;; fontify comments -; '("^[cC*].*$" . font-lock-comment-face) -; ;; -; ;; fontify preprocessor directives. -; '("^#[ \t]*[a-z]+" . font-lock-preprocessor-face) -; ;; -; ;; fontify names being defined. -; '("^#[ \t]*\\(define\\|undef\\)[ \t]+\\(\\(\\sw\\|\\s_\\)+\\)" 2 -; font-lock-function-name-face) -; ;; -; ;; fontify other preprocessor lines. -; '("^#[ \t]*\\(if\\|ifn?def\\|elif\\)[ \t]+\\([^\n]+\\)" -; 2 font-lock-function-name-face t) - -; ;; Subroutine and function declarations -; '("^[ \t]*subroutine.*$" . font-lock-function-name-face) -; '("^[ \t].*function.*$" . font-lock-function-name-face) -; '("^[ \t].*program.*$" . font-lock-function-name-face) -; '("^[ \t].*entry.*$" . font-lock-function-name-face) -; )) -; "For consideration as a value of `fortran-font-lock-keywords'. -;This does fairly subdued highlighting of comments and function names.") - -;(defconst fortran-font-lock-keywords-2 -; (purecopy -; (append fortran-font-lock-keywords-1 -; (list -; ;; Variable declarations -; '("^[ \t]*\\(\\(integer\\|logical\\|real\\|complex\\|double[ \t]*precision\\|character\\|parameter\\)[^ \t]*\\)" -; 1 font-lock-keyword-face) -; ;; Common blocks, external, etc -; '("^[ \t]*\\(common\\|save\\|external\\|intrinsic\\|data\\)" 1 font-lock-keyword-face) -; ;; Other keywords -; '("^[ \t]*[0-9]*[ \t]*\\(if\\)[ \t]*(" -; 1 font-lock-keyword-face) - -; ;; Then -; ;; '("^\\(\\([ \t]*[0-9]*[ \t]*\\)\\|\\( [^ ]\\)\\).*[ \t]*\\(then\\)[ \t]*" -; ;; 4 font-lock-keyword-face) -; '("\\(then\\)[ \t]*$" 1 font-lock-keyword-face) - -; ;; '("^[ \t]*[0-9]*[ \t]*\\(end[ \t]*if\\)[ \t]*$" -; '("\\(end[ \t]*if\\)[ \t]*$" -; 1 font-lock-keyword-face) -; ;; '("\\(else[ \t]*\\(if\\)?\\)" -; ;; the below works better <mdb@cdc.noaa.gov> -; '("^[ \t]*[0-9]*[ \t]*\\(else[ \t]*\\(if\\)?\\)" -; 1 font-lock-keyword-face) -; '("^[ \t]*[0-9]*[ \t]*\\(do\\)[ \t]*[0-9]+" -; 1 font-lock-keyword-face) -; '("^[ \t]*[0-9]*[ \t]*\\(do\\)[ \t]*[a-z0-9_$]+[ \t]*=" -; 1 font-lock-keyword-face) -; '("^[ \t]*[0-9]*[ \t]*\\(end[ \t]*do\\)" -; 1 font-lock-keyword-face) -; '("^[ \t]*[0-9]+[ \t]*\\(continue\\)" 1 font-lock-keyword-face) -; '("^[ \t]*[0-9]*[ \t]*\\(call\\)" 1 font-lock-keyword-face) -; '("^[ \t]*[0-9]*[ \t]*\\(go[ \t]*to\\)" 1 font-lock-keyword-face) - -; '("^[ \t]*[0-9]*[ \t]*\\(open\\|close\\|read\\|write\\|format\\)[ \t]*(" -; 1 font-lock-keyword-face) -; '("^[ \t]*[0-9]*[ \t]*\\(print\\)[ \t]*[*'0-9]+" 1 font-lock-keyword-face) - -; '("^[ \t]*[0-9]*[ \t]*\\(end\\|return\\)[ \t]*$" 1 font-lock-keyword-face) - -; '("^[ \t]*[0-9]*[ \t]*\\(stop\\)[ \t]*['0-9]*" 1 font-lock-keyword-face) - -; ;; Boolean and relational operations, logical true and false -; '("\\.\\(and\\|or\\|not\\|lt\\|le\\|eq\\|ge\\|gt\\|ne\\|true\\|false\\)\\." -; . font-lock-keyword-face) -; ))) -; "For consideration as a value of `fortran-font-lock-keywords'. -;This highlights variable types, \"keywords,\" etc.") - - -(defvar fortran-mode-map () - "Keymap used in Fortran mode.") -(if fortran-mode-map - () - (setq fortran-mode-map (make-sparse-keymap)) - (define-key fortran-mode-map ";" 'fortran-abbrev-start) - (define-key fortran-mode-map "\C-c;" 'fortran-comment-region) - (define-key fortran-mode-map "\e\C-a" 'beginning-of-fortran-subprogram) - (define-key fortran-mode-map "\e\C-e" 'end-of-fortran-subprogram) - (define-key fortran-mode-map "\e;" 'fortran-indent-comment) - (define-key fortran-mode-map "\e\C-h" 'mark-fortran-subprogram) - (define-key fortran-mode-map "\e\n" 'fortran-split-line) - (define-key fortran-mode-map "\n" 'fortran-indent-new-line) - (define-key fortran-mode-map "\e\C-q" 'fortran-indent-subprogram) - (define-key fortran-mode-map "\C-c\C-w" 'fortran-window-create-momentarily) - (define-key fortran-mode-map "\C-c\C-r" 'fortran-column-ruler) - (define-key fortran-mode-map "\C-c\C-p" 'fortran-previous-statement) - (define-key fortran-mode-map "\C-c\C-n" 'fortran-next-statement) - (define-key fortran-mode-map "\t" 'fortran-indent-line) - (define-key fortran-mode-map "0" 'fortran-electric-line-number) - (define-key fortran-mode-map "1" 'fortran-electric-line-number) - (define-key fortran-mode-map "2" 'fortran-electric-line-number) - (define-key fortran-mode-map "3" 'fortran-electric-line-number) - (define-key fortran-mode-map "4" 'fortran-electric-line-number) - (define-key fortran-mode-map "5" 'fortran-electric-line-number) - (define-key fortran-mode-map "6" 'fortran-electric-line-number) - (define-key fortran-mode-map "7" 'fortran-electric-line-number) - (define-key fortran-mode-map "8" 'fortran-electric-line-number) - (define-key fortran-mode-map "9" 'fortran-electric-line-number)) - -(defvar fortran-mode-abbrev-table nil) -(if fortran-mode-abbrev-table - () - (let ((ac abbrevs-changed)) - (define-abbrev-table 'fortran-mode-abbrev-table ()) - (define-abbrev fortran-mode-abbrev-table ";au" "automatic" nil) - (define-abbrev fortran-mode-abbrev-table ";b" "byte" nil) - (define-abbrev fortran-mode-abbrev-table ";bd" "block data" nil) - (define-abbrev fortran-mode-abbrev-table ";ch" "character" nil) - (define-abbrev fortran-mode-abbrev-table ";cl" "close" nil) - (define-abbrev fortran-mode-abbrev-table ";c" "continue" nil) - (define-abbrev fortran-mode-abbrev-table ";cm" "common" nil) - (define-abbrev fortran-mode-abbrev-table ";cx" "complex" nil) - (define-abbrev fortran-mode-abbrev-table ";df" "define" nil) - (define-abbrev fortran-mode-abbrev-table ";di" "dimension" nil) - (define-abbrev fortran-mode-abbrev-table ";do" "double" nil) - (define-abbrev fortran-mode-abbrev-table ";dc" "double complex" nil) - (define-abbrev fortran-mode-abbrev-table ";dp" "double precision" nil) - (define-abbrev fortran-mode-abbrev-table ";dw" "do while" nil) - (define-abbrev fortran-mode-abbrev-table ";e" "else" nil) - (define-abbrev fortran-mode-abbrev-table ";ed" "enddo" nil) - (define-abbrev fortran-mode-abbrev-table ";el" "elseif" nil) - (define-abbrev fortran-mode-abbrev-table ";en" "endif" nil) - (define-abbrev fortran-mode-abbrev-table ";eq" "equivalence" nil) - (define-abbrev fortran-mode-abbrev-table ";ew" "endwhere" nil) - (define-abbrev fortran-mode-abbrev-table ";ex" "external" nil) - (define-abbrev fortran-mode-abbrev-table ";ey" "entry" nil) - (define-abbrev fortran-mode-abbrev-table ";f" "format" nil) - (define-abbrev fortran-mode-abbrev-table ";fa" ".false." nil) - (define-abbrev fortran-mode-abbrev-table ";fu" "function" nil) - (define-abbrev fortran-mode-abbrev-table ";g" "goto" nil) - (define-abbrev fortran-mode-abbrev-table ";im" "implicit" nil) - (define-abbrev fortran-mode-abbrev-table ";ib" "implicit byte" nil) - (define-abbrev fortran-mode-abbrev-table ";ic" "implicit complex" nil) - (define-abbrev fortran-mode-abbrev-table ";ich" "implicit character" nil) - (define-abbrev fortran-mode-abbrev-table ";ii" "implicit integer" nil) - (define-abbrev fortran-mode-abbrev-table ";il" "implicit logical" nil) - (define-abbrev fortran-mode-abbrev-table ";ir" "implicit real" nil) - (define-abbrev fortran-mode-abbrev-table ";inc" "include" nil) - (define-abbrev fortran-mode-abbrev-table ";in" "integer" nil) - (define-abbrev fortran-mode-abbrev-table ";intr" "intrinsic" nil) - (define-abbrev fortran-mode-abbrev-table ";l" "logical" nil) - (define-abbrev fortran-mode-abbrev-table ";n" "namelist" nil) - (define-abbrev fortran-mode-abbrev-table ";o" "open" nil) ; was ;op - (define-abbrev fortran-mode-abbrev-table ";pa" "parameter" nil) - (define-abbrev fortran-mode-abbrev-table ";pr" "program" nil) - (define-abbrev fortran-mode-abbrev-table ";ps" "pause" nil) - (define-abbrev fortran-mode-abbrev-table ";p" "print" nil) - (define-abbrev fortran-mode-abbrev-table ";rc" "record" nil) - (define-abbrev fortran-mode-abbrev-table ";re" "real" nil) - (define-abbrev fortran-mode-abbrev-table ";r" "read" nil) - (define-abbrev fortran-mode-abbrev-table ";rt" "return" nil) - (define-abbrev fortran-mode-abbrev-table ";rw" "rewind" nil) - (define-abbrev fortran-mode-abbrev-table ";s" "stop" nil) - (define-abbrev fortran-mode-abbrev-table ";sa" "save" nil) - (define-abbrev fortran-mode-abbrev-table ";st" "structure" nil) - (define-abbrev fortran-mode-abbrev-table ";sc" "static" nil) - (define-abbrev fortran-mode-abbrev-table ";su" "subroutine" nil) - (define-abbrev fortran-mode-abbrev-table ";tr" ".true." nil) - (define-abbrev fortran-mode-abbrev-table ";ty" "type" nil) - (define-abbrev fortran-mode-abbrev-table ";vo" "volatile" nil) - (define-abbrev fortran-mode-abbrev-table ";w" "write" nil) - (define-abbrev fortran-mode-abbrev-table ";wh" "where" nil) - (setq abbrevs-changed ac))) - -;;;###autoload -(defun fortran-mode () - "Major mode for editing Fortran code. -\\[fortran-indent-line] indents the current Fortran line correctly. -DO statements must not share a common CONTINUE. - -Type ;? or ;\\[help-command] to display a list of built-in\ - abbrevs for Fortran keywords. - -Key definitions: -\\{fortran-mode-map} - -Variables controlling indentation style and extra features: - - comment-start - Normally nil in Fortran mode. If you want to use comments - starting with `!', set this to the string \"!\". - fortran-do-indent - Extra indentation within do blocks. (default 3) - fortran-if-indent - Extra indentation within if blocks. (default 3) - fortran-structure-indent - Extra indentation within structure, union, map and interface blocks. - (default 3) - fortran-continuation-indent - Extra indentation applied to continuation statements. (default 5) - fortran-comment-line-extra-indent - Amount of extra indentation for text within full-line comments. (default 0) - fortran-comment-indent-style - nil means don't change indentation of text in full-line comments, - fixed means indent that text at `fortran-comment-line-extra-indent' beyond - the value of `fortran-minimum-statement-indent-fixed' (for fixed - format continuation style) or `fortran-minimum-statement-indent-tab' - (for TAB format continuation style). - relative means indent at `fortran-comment-line-extra-indent' beyond the - indentation for a line of code. - (default 'fixed) - fortran-comment-indent-char - Single-character string to be inserted instead of space for - full-line comment indentation. (default \" \") - fortran-minimum-statement-indent-fixed - Minimum indentation for Fortran statements in fixed format mode. (def.6) - fortran-minimum-statement-indent-tab - Minimum indentation for Fortran statements in TAB format mode. (default 9) - fortran-line-number-indent - Maximum indentation for line numbers. A line number will get - less than this much indentation if necessary to avoid reaching - column 5. (default 1) - fortran-check-all-num-for-matching-do - Non-nil causes all numbered lines to be treated as possible \"continue\" - statements. (default nil) - fortran-blink-matching-if - Non-nil causes \\[fortran-indent-line] on an ENDIF statement to blink on - matching IF. Also, from an ENDDO statement, blink on matching DO [WHILE] - statement. (default nil) - fortran-continuation-string - Single-character string to be inserted in column 5 of a continuation - line. (default \"$\") - fortran-comment-region - String inserted by \\[fortran-comment-region] at start of each line in - region. (default \"c$$$\") - fortran-electric-line-number - Non-nil causes line number digits to be moved to the correct column - as typed. (default t) - fortran-break-before-delimiters - Non-nil causes `fortran-fill' breaks lines before delimiters. - (default t) - fortran-startup-message - Set to nil to inhibit message first time Fortran mode is used. - -Turning on Fortran mode calls the value of the variable `fortran-mode-hook' -with no args, if that value is non-nil." - (interactive) - (kill-all-local-variables) - (if fortran-startup-message - (message "Emacs Fortran mode %s. Bugs to %s" - fortran-mode-version bug-fortran-mode)) - (setq fortran-startup-message nil) - (setq local-abbrev-table fortran-mode-abbrev-table) - (set-syntax-table fortran-mode-syntax-table) - ;; Font Lock mode support. (Removed for XEmacs) - ;; (make-local-variable 'font-lock-defaults) - ;; (setq font-lock-defaults '((fortran-font-lock-keywords - ;; fortran-font-lock-keywords-1 - ;; fortran-font-lock-keywords-2 - ;; fortran-font-lock-keywords-3) - ;; t t ((?/ . "$/")))) - (make-local-variable 'fortran-break-before-delimiters) - (setq fortran-break-before-delimiters t) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'fortran-indent-line) - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'fortran-comment-hook) - (make-local-variable 'comment-line-start-skip) - (setq comment-line-start-skip - "^[Cc*]\\(\\([^ \t\n]\\)\\2\\2*\\)?[ \t]*\\|^#.*") - (make-local-variable 'comment-line-start) - (setq comment-line-start "c") - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "![ \t]*") - (make-local-variable 'comment-start) - (setq comment-start nil) - (make-local-variable 'require-final-newline) - (setq require-final-newline t) - (make-local-variable 'abbrev-all-caps) - (setq abbrev-all-caps t) - (make-local-variable 'indent-tabs-mode) - (setq indent-tabs-mode nil) -;;;(setq abbrev-mode t) ; ?? (abbrev-mode 1) instead?? - (setq fill-column 72) ; Already local? - (use-local-map fortran-mode-map) - (setq mode-name "Fortran") - (setq major-mode 'fortran-mode) -;;;(make-local-variable 'fortran-tab-mode) - (make-local-variable 'fortran-comment-line-extra-indent) - (make-local-variable 'fortran-minimum-statement-indent-fixed) - (make-local-variable 'fortran-minimum-statement-indent-tab) - (make-local-variable 'fortran-column-ruler-fixed) - (make-local-variable 'fortran-column-ruler-tab) - (make-local-variable 'fortran-tab-mode-string) - (setq fortran-tab-mode-string " TAB-format") - (setq indent-tabs-mode (fortran-analyze-file-format)) - (run-hooks 'fortran-mode-hook)) - -(defun fortran-comment-hook () - (save-excursion - (skip-chars-backward " \t") - (max (+ 1 (current-column)) - comment-column))) - -(defun fortran-indent-comment () - "Align or create comment on current line. -Existing comments of all types are recognized and aligned. -If the line has no comment, a side-by-side comment is inserted and aligned -if the value of comment-start is not nil. -Otherwise, a separate-line comment is inserted, on this line -or on a new line inserted before this line if this line is not blank." - (interactive) - (beginning-of-line) - ;; Recognize existing comments of either kind. - (cond ((looking-at comment-line-start-skip) - (fortran-indent-line)) - ((fortran-find-comment-start-skip) ; catches any inline comment and - ; leaves point after comment-start-skip - (if comment-start-skip - (progn (goto-char (match-beginning 0)) - (if (not (= (current-column) (fortran-comment-hook))) - (progn (delete-horizontal-space) - (indent-to (fortran-comment-hook))))) - (end-of-line))) ; otherwise goto end of line or sth else? - ;; No existing comment. - ;; If side-by-side comments are defined, insert one, - ;; unless line is now blank. - ((and comment-start (not (looking-at "^[ \t]*$"))) - (end-of-line) - (delete-horizontal-space) - (indent-to (fortran-comment-hook)) - (insert comment-start)) - ;; Else insert separate-line comment, making a new line if nec. - (t - (if (looking-at "^[ \t]*$") - (delete-horizontal-space) - (beginning-of-line) - (insert "\n") - (forward-char -1)) - (insert comment-line-start) - (insert-char (if (stringp fortran-comment-indent-char) - (aref fortran-comment-indent-char 0) - fortran-comment-indent-char) - (- (calculate-fortran-indent) (current-column)))))) - -(defun fortran-comment-region (beg-region end-region arg) - "Comments every line in the region. -Puts fortran-comment-region at the beginning of every line in the region. -BEG-REGION and END-REGION are args which specify the region boundaries. -With non-nil ARG, uncomments the region." - (interactive "*r\nP") - (let ((end-region-mark (make-marker)) (save-point (point-marker))) - (set-marker end-region-mark end-region) - (goto-char beg-region) - (beginning-of-line) - (if (not arg) ;comment the region - (progn (insert fortran-comment-region) - (while (and (= (forward-line 1) 0) - (< (point) end-region-mark)) - (insert fortran-comment-region))) - (let ((com (regexp-quote fortran-comment-region))) ;uncomment the region - (if (looking-at com) - (delete-region (point) (match-end 0))) - (while (and (= (forward-line 1) 0) - (< (point) end-region-mark)) - (if (looking-at com) - (delete-region (point) (match-end 0)))))) - (goto-char save-point) - (set-marker end-region-mark nil) - (set-marker save-point nil))) - -(defun fortran-abbrev-start () - "Typing ;\\[help-command] or ;? lists all the Fortran abbrevs. -Any other key combination is executed normally." - (interactive) - ;; XEmacs change - (let (e c) - (insert last-command-char) - (setq e (next-command-event) - c (event-to-character e)) - ;; insert char if not equal to `?' - (if (or (= c ??) (eq c help-char)) - (fortran-abbrev-help) - (setq unread-command-events (list e))))) - -(defun fortran-abbrev-help () - "List the currently defined abbrevs in Fortran mode." - (interactive) - (message "Listing abbrev table...") - (display-buffer (fortran-prepare-abbrev-list-buffer)) - (message "Listing abbrev table...done")) - -(defun fortran-prepare-abbrev-list-buffer () - (save-excursion - (set-buffer (get-buffer-create "*Abbrevs*")) - (erase-buffer) - (insert-abbrev-table-description 'fortran-mode-abbrev-table t) - (goto-char (point-min)) - (set-buffer-modified-p nil) - (edit-abbrevs-mode)) - (get-buffer-create "*Abbrevs*")) - -(defun fortran-column-ruler () - "Inserts a column ruler momentarily above current line, till next keystroke. -The ruler is defined by the value of `fortran-column-ruler-fixed' when in fixed -format mode, and `fortran-column-ruler-tab' when in TAB format mode. -The key typed is executed unless it is SPC." - (interactive) - (momentary-string-display - (if indent-tabs-mode - fortran-column-ruler-tab - fortran-column-ruler-fixed) - (save-excursion - (beginning-of-line) - (if (eq (window-start (selected-window)) - (window-point (selected-window))) - (progn (forward-line) (point)) - (point))) - nil "Type SPC or any command to erase ruler.")) - -(defun fortran-window-create () - "Makes the window 72 columns wide. -See also `fortran-window-create-momentarily'." - (interactive) - (condition-case error - (progn - (let ((window-min-width 2)) - (if (< (window-width) (frame-width)) - (enlarge-window-horizontally (- (frame-width) - (window-width) 1))) - (split-window-horizontally 73) - (other-window 1) - (switch-to-buffer " fortran-window-extra" t) - (select-window (previous-window)))) - (error (message "No room for Fortran window.") - 'error))) - -(defun fortran-window-create-momentarily (&optional arg) - "Momentarily makes the window 72 columns wide. -Optional ARG non-nil and non-unity disables the momentary feature. -See also `fortran-window-create'." - (interactive "p") - (if (or (not arg) - (= arg 1)) - (save-window-excursion - (if (not (equal (fortran-window-create) 'error)) - (progn (message "Type SPC to continue editing.") - ;; XEmacs change - (let ((char (next-command-event))) - (or (equal (event-to-character char) ? ) - (setq unread-command-events (list char))))))) - (fortran-window-create))) - -(defun fortran-split-line () - "Break line at point and insert continuation marker and alignment." - (interactive) - (delete-horizontal-space) - (if (save-excursion (beginning-of-line) (looking-at comment-line-start-skip)) - (insert "\n" comment-line-start " ") - (if indent-tabs-mode - (progn - (insert "\n\t") - (insert-char (fortran-numerical-continuation-char) 1)) - (insert "\n " fortran-continuation-string)));Space after \n important - (fortran-indent-line)) ;when the cont string is C, c or *. - -(defun fortran-numerical-continuation-char () - "Return a digit for tab-digit style of continuation lines. -If, previous line is a tab-digit continuation line, returns that digit -plus one. Otherwise return 1. Zero not allowed." - (save-excursion - (forward-line -1) - (if (looking-at "\t[1-9]") - (+ ?1 (% (- (char-after (+ (point) 1)) ?0) 9)) - ?1))) - -(defun delete-horizontal-regexp (chars) - "Delete all characters in CHARS around point. -CHARS is like the inside of a [...] in a regular expression -except that ] is never special and \ quotes ^, - or \." - (interactive "*s") - (skip-chars-backward chars) - (delete-region (point) (progn (skip-chars-forward chars) (point)))) - -(defun fortran-electric-line-number (arg) - "Self insert, but if part of a Fortran line number indent it automatically. -Auto-indent does not happen if a numeric arg is used." - (interactive "P") - (if (or arg (not fortran-electric-line-number)) - (if arg - (self-insert-command (prefix-numeric-value arg)) - (self-insert-command 1)) - (if (or (and (= 5 (current-column)) - (save-excursion - (beginning-of-line) - (looking-at " ")));In col 5 with only spaces to left. - (and (= (if indent-tabs-mode - fortran-minimum-statement-indent-tab - fortran-minimum-statement-indent-fixed) (current-column)) - (save-excursion - (beginning-of-line) - (looking-at "\t"));In col 8 with a single tab to the left. - (not (or (eq last-command 'fortran-indent-line) - (eq last-command - 'fortran-indent-new-line)))) - (save-excursion - (re-search-backward "[^ \t0-9]" - (save-excursion - (beginning-of-line) - (point)) - t)) ;not a line number - (looking-at "[0-9]") ;within a line number - ) - (self-insert-command (prefix-numeric-value arg)) - (skip-chars-backward " \t") - (insert last-command-char) - (fortran-indent-line)))) - -(defun beginning-of-fortran-subprogram () - "Moves point to the beginning of the current Fortran subprogram." - (interactive) - (let ((case-fold-search t)) - (beginning-of-line -1) - (re-search-backward "^[ \t0-9]*end\\b[ \t]*[^ \t=(a-z]" nil 'move) - (if (looking-at "^[ \t0-9]*end\\b[ \t]*[^ \t=(a-z]") - (forward-line 1)))) - -(defun end-of-fortran-subprogram () - "Moves point to the end of the current Fortran subprogram." - (interactive) - (let ((case-fold-search t)) - (beginning-of-line 2) - (re-search-forward "^[ \t0-9]*end\\b[ \t]*[^ \t=(a-z]" nil 'move) - (goto-char (match-beginning 0)) - (forward-line 1))) - -(defun mark-fortran-subprogram () - "Put mark at end of Fortran subprogram, point at beginning. -The marks are pushed." - (interactive) - (end-of-fortran-subprogram) - (push-mark (point)) - (beginning-of-fortran-subprogram)) - -(defun fortran-previous-statement () - "Moves point to beginning of the previous Fortran statement. -Returns `first-statement' if that statement is the first -non-comment Fortran statement in the file, and nil otherwise." - (interactive) - (let (not-first-statement continue-test) - (beginning-of-line) - (setq continue-test - (and - (not (looking-at comment-line-start-skip)) - (or (looking-at - (concat "[ \t]*" (regexp-quote fortran-continuation-string))) - (or (looking-at " [^ 0\n]") - (looking-at "\t[1-9]"))))) - (while (and (setq not-first-statement (= (forward-line -1) 0)) - (or (looking-at comment-line-start-skip) - (looking-at "[ \t]*$") - (looking-at " [^ 0\n]") - (looking-at "\t[1-9]") - (looking-at (concat "[ \t]*" comment-start-skip))))) - (cond ((and continue-test - (not not-first-statement)) - (message "Incomplete continuation statement.")) - (continue-test - (fortran-previous-statement)) - ((not not-first-statement) - 'first-statement)))) - -(defun fortran-next-statement () - "Moves point to beginning of the next Fortran statement. -Returns `last-statement' if that statement is the last -non-comment Fortran statement in the file, and nil otherwise." - (interactive) - (let (not-last-statement) - (beginning-of-line) - (while (and (setq not-last-statement - (and (= (forward-line 1) 0) - (not (eobp)))) - (or (looking-at comment-line-start-skip) - (looking-at "[ \t]*$") - (looking-at " [^ 0\n]") - (looking-at "\t[1-9]") - (looking-at (concat "[ \t]*" comment-start-skip))))) - (if (not not-last-statement) - 'last-statement))) - -(defun fortran-blink-matching-if () - ;; From a Fortran ENDIF statement, blink the matching IF statement. - (let ((top-of-window (window-start)) matching-if - (endif-point (point)) message) - (if (save-excursion (beginning-of-line) - (skip-chars-forward " \t0-9") - (looking-at "end[ \t]*if\\b")) - (progn - (if (not (setq matching-if (fortran-beginning-if))) - (setq message "No matching if.") - (if (< matching-if top-of-window) - (save-excursion - (goto-char matching-if) - (beginning-of-line) - (setq message - (concat "Matches " - (buffer-substring - (point) (progn (end-of-line) (point)))))))) - (if message - (message "%s" message) - (goto-char matching-if) - (sit-for 1) - (goto-char endif-point)))))) - -(defun fortran-blink-matching-do () - ;; From a Fortran ENDDO statement, blink on the matching DO or DO WHILE - ;; statement. This is basically copied from fortran-blink-matching-if. - (let ((top-of-window (window-start)) matching-do - (enddo-point (point)) message) - (if (save-excursion (beginning-of-line) - (skip-chars-forward " \t0-9") - (looking-at "end[ \t]*do\\b")) - (progn - (if (not (setq matching-do (fortran-beginning-do))) - (setq message "No matching do.") - (if (< matching-do top-of-window) - (save-excursion - (goto-char matching-do) - (beginning-of-line) - (setq message - (concat "Matches " - (buffer-substring - (point) (progn (end-of-line) (point)))))))) - (if message - (message "%s" message) - (goto-char matching-do) - (sit-for 1) - (goto-char enddo-point)))))) - -(defun fortran-mark-do () - "Put mark at end of Fortran DO [WHILE]-ENDDO construct, point at beginning. -The marks are pushed." - (interactive) - (let (enddo-point do-point) - (if (setq enddo-point (fortran-end-do)) - (if (not (setq do-point (fortran-beginning-do))) - (message "No matching do.") - ;; Set mark, move point. - (goto-char enddo-point) - (push-mark) - (goto-char do-point))))) - -(defun fortran-end-do () - ;; Search forward for first unmatched ENDDO. Return point or nil. - (if (save-excursion (beginning-of-line) - (skip-chars-forward " \t0-9") - (looking-at "end[ \t]*do\\b")) - ;; Sitting on one. - (match-beginning 0) - ;; Search for one. - (save-excursion - (let ((count 1)) - (while (and (not (= count 0)) - (not (eq (fortran-next-statement) 'last-statement)) - ;; Keep local to subprogram - (not (looking-at "^[ \t0-9]*end\\b[ \t]*[^ \t=(a-z]"))) - - (skip-chars-forward " \t0-9") - (cond ((looking-at "end[ \t]*do\\b") - (setq count (- count 1))) - ((looking-at "do[ \t]+[^0-9]") - (setq count (+ count 1))))) - (and (= count 0) - ;; All pairs accounted for. - (point)))))) - -(defun fortran-beginning-do () - ;; Search backwards for first unmatched DO [WHILE]. Return point or nil. - (if (save-excursion (beginning-of-line) - (skip-chars-forward " \t0-9") - (looking-at "do[ \t]+")) - ;; Sitting on one. - (match-beginning 0) - ;; Search for one. - (save-excursion - (let ((count 1)) - (while (and (not (= count 0)) - (not (eq (fortran-previous-statement) 'first-statement)) - ;; Keep local to subprogram - (not (looking-at "^[ \t0-9]*end\\b[ \t]*[^ \t=(a-z]"))) - - (skip-chars-forward " \t0-9") - (cond ((looking-at "do[ \t]+[^0-9]") - (setq count (- count 1))) - ((looking-at "end[ \t]*do\\b") - (setq count (+ count 1))))) - - (and (= count 0) - ;; All pairs accounted for. - (point)))))) - -(defun fortran-mark-if () - "Put mark at end of Fortran IF-ENDIF construct, point at beginning. -The marks are pushed." - (interactive) - (let (endif-point if-point) - (if (setq endif-point (fortran-end-if)) - (if (not (setq if-point (fortran-beginning-if))) - (message "No matching if.") - ;; Set mark, move point. - (goto-char endif-point) - (push-mark) - (goto-char if-point))))) - -(defun fortran-end-if () - ;; Search forwards for first unmatched ENDIF. Return point or nil. - (if (save-excursion (beginning-of-line) - (skip-chars-forward " \t0-9") - (looking-at "end[ \t]*if\\b")) - ;; Sitting on one. - (match-beginning 0) - ;; Search for one. The point has been already been moved to first - ;; letter on line but this should not cause troubles. - (save-excursion - (let ((count 1)) - (while (and (not (= count 0)) - (not (eq (fortran-next-statement) 'last-statement)) - ;; Keep local to subprogram. - (not (looking-at - "^[ \t0-9]*end\\b[ \t]*[^ \t=(a-z]"))) - - (skip-chars-forward " \t0-9") - (cond ((looking-at "end[ \t]*if\\b") - (setq count (- count 1))) - - ((looking-at "if[ \t]*(") - (save-excursion - (if (or - (looking-at ".*)[ \t]*then\\b[ \t]*[^ \t(=a-z0-9]") - (let (then-test) ; Multi-line if-then. - (while - (and (= (forward-line 1) 0) - ;; Search forward for then. - (or (looking-at " [^ 0\n]") - (looking-at "\t[1-9]")) - (not - (setq then-test - (looking-at - ".*then\\b[ \t]*[^ \t(=a-z0-9]"))))) - then-test)) - (setq count (+ count 1))))))) - - (and (= count 0) - ;; All pairs accounted for. - (point)))))) - -(defun fortran-beginning-if () - ;; Search backwards for first unmatched IF-THEN. Return point or nil. - (if (save-excursion - ;; May be sitting on multi-line if-then statement, first move to - ;; beginning of current statement. Note: `fortran-previous-statement' - ;; moves to previous statement *unless* current statement is first - ;; one. Only move forward if not first-statement. - (if (not (eq (fortran-previous-statement) 'first-statement)) - (fortran-next-statement)) - (skip-chars-forward " \t0-9") - (and - (looking-at "if[ \t]*(") - (save-match-data - (or (looking-at ".*)[ \t]*then\\b[ \t]*[^ \t(=a-z0-9]") - ;; Multi-line if-then. - (let (then-test) - (while - (and (= (forward-line 1) 0) - ;; Search forward for then. - (or (looking-at " [^ 0\n]") - (looking-at "\t[1-9]")) - (not - (setq then-test - (looking-at - ".*then\\b[ \t]*[^ \t(=a-z0-9]"))))) - then-test))))) - ;; Sitting on one. - (match-beginning 0) - ;; Search for one. - (save-excursion - (let ((count 1)) - (while (and (not (= count 0)) - (not (eq (fortran-previous-statement) 'first-statement)) - ;; Keep local to subprogram. - (not (looking-at - "^[ \t0-9]*end\\b[ \t]*[^ \t=(a-z]"))) - - (skip-chars-forward " \t0-9") - (cond ((looking-at "if[ \t]*(") - (save-excursion - (if (or - (looking-at ".*)[ \t]*then\\b[ \t]*[^ \t(=a-z0-9]") - (let (then-test) ; Multi-line if-then. - (while - (and (= (forward-line 1) 0) - ;; Search forward for then. - (or (looking-at " [^ 0\n]") - (looking-at "\t[1-9]")) - (not - (setq then-test - (looking-at - ".*then\\b[ \t]*[^ \t(=a-z0-9]"))))) - then-test)) - (setq count (- count 1))))) - ((looking-at "end[ \t]*if\\b") - (setq count (+ count 1))))) - - (and (= count 0) - ;; All pairs accounted for. - (point)))))) - -(defun fortran-indent-line () - "Indents current Fortran line based on its contents and on previous lines." - (interactive) - (let ((cfi (calculate-fortran-indent))) - (save-excursion - (beginning-of-line) - (if (or (not (= cfi (fortran-current-line-indentation))) - (and (re-search-forward "^[ \t]*[0-9]+" (+ (point) 4) t) - (not (fortran-line-number-indented-correctly-p)))) - (fortran-indent-to-column cfi) - (beginning-of-line) - (if (and (not (looking-at comment-line-start-skip)) - (fortran-find-comment-start-skip)) - (fortran-indent-comment)))) - ;; Never leave point in left margin. - (if (< (current-column) cfi) - (move-to-column cfi)) - (if (and auto-fill-function - (> (save-excursion (end-of-line) (current-column)) fill-column)) - (save-excursion - (end-of-line) - (fortran-fill))) - (if fortran-blink-matching-if - (progn - (fortran-blink-matching-if) - (fortran-blink-matching-do))))) - -(defun fortran-indent-new-line () - "Reindent the current Fortran line, insert a newline and indent the newline. -An abbrev before point is expanded if `abbrev-mode' is non-nil." - (interactive) - (if abbrev-mode (expand-abbrev)) - (save-excursion - (beginning-of-line) - (skip-chars-forward " \t") - (if (or (looking-at "[0-9]") ;Reindent only where it is most - (looking-at "end") ;likely to be necessary - (looking-at "else") - (looking-at (regexp-quote fortran-continuation-string))) - (fortran-indent-line))) - (newline) - (fortran-indent-line)) - -(defun fortran-indent-subprogram () - "Properly indents the Fortran subprogram which contains point." - (interactive) - (save-excursion - (mark-fortran-subprogram) - (message "Indenting subprogram...") - (indent-region (point) (mark t) nil)) ; XEmacs change - (message "Indenting subprogram...done.")) - -(defun calculate-fortran-indent () - "Calculates the Fortran indent column based on previous lines." - (let (icol first-statement (case-fold-search t) - (fortran-minimum-statement-indent - (if indent-tabs-mode - fortran-minimum-statement-indent-tab - fortran-minimum-statement-indent-fixed))) - (save-excursion - (setq first-statement (fortran-previous-statement)) - (if first-statement - (setq icol fortran-minimum-statement-indent) - (progn - (if (= (point) (point-min)) - (setq icol fortran-minimum-statement-indent) - (setq icol (fortran-current-line-indentation))) - (skip-chars-forward " \t0-9") - (cond ((looking-at "if[ \t]*(") - (if (or (looking-at ".*)[ \t]*then\\b[ \t]*[^ \t_$(=a-z0-9]") - (let (then-test) ;multi-line if-then - (while (and (= (forward-line 1) 0) - ;;search forward for then - (or (looking-at " [^ 0\n]") - (looking-at "\t[1-9]")) - (not (setq then-test (looking-at - ".*then\\b[ \t]\ -*[^ \t_$(=a-z0-9]"))))) - then-test)) - (setq icol (+ icol fortran-if-indent)))) - ((looking-at "\\(else\\|elseif\\)\\b") - (setq icol (+ icol fortran-if-indent))) - ((looking-at "select[ \t]*case[ \t](.*)\\b") - (setq icol (+ icol fortran-if-indent))) - ((looking-at "case[ \t]*(.*)[ \t]*\n") - (setq icol (+ icol fortran-if-indent))) - ((looking-at "case[ \t]*default\\b") - (setq icol (+ icol fortran-if-indent))) - ((looking-at "\\(otherwise\\|else[ \t]*where\\)\\b") - (setq icol (+ icol fortran-if-indent))) - ((looking-at "where[ \t]*(.*)[ \t]*\n") - (setq icol (+ icol fortran-if-indent))) - ((looking-at "do\\b") - (setq icol (+ icol fortran-do-indent))) - ((looking-at - "\\(structure\\|union\\|map\\|interface\\)\\b[ \t]*[^ \t=(a-z]") - (setq icol (+ icol fortran-structure-indent))) - ((looking-at "end\\b[ \t]*[^ \t=(a-z]") - ;; Previous END resets indent to minimum - (setq icol fortran-minimum-statement-indent)))))) - (save-excursion - (beginning-of-line) - (cond ((looking-at "[ \t]*$")) - ((looking-at comment-line-start-skip) - (cond ((eq fortran-comment-indent-style 'relative) - (setq icol (+ icol fortran-comment-line-extra-indent))) - ((eq fortran-comment-indent-style 'fixed) - (setq icol (+ fortran-minimum-statement-indent - fortran-comment-line-extra-indent)))) - (setq fortran-minimum-statement-indent 0)) - ((or (looking-at (concat "[ \t]*" - (regexp-quote - fortran-continuation-string))) - (looking-at " [^ 0\n]") - (looking-at "\t[1-9]")) - (setq icol (+ icol fortran-continuation-indent))) - ((looking-at "[ \t]*#") ; Check for cpp directive. - (setq fortran-minimum-statement-indent 0 icol 0)) - (first-statement) - ((and fortran-check-all-num-for-matching-do - (looking-at "[ \t]*[0-9]+") - (fortran-check-for-matching-do)) - (setq icol (- icol fortran-do-indent))) - (t - (skip-chars-forward " \t0-9") - (cond ((looking-at "end[ \t]*if\\b") - (setq icol (- icol fortran-if-indent))) - ((looking-at "\\(else\\|elseif\\)\\b") - (setq icol (- icol fortran-if-indent))) - ((looking-at "case[ \t]*(.*)[ \t]*\n") - (setq icol (- icol fortran-if-indent))) - ((looking-at "case[ \t]*default\\b") - (setq icol (- icol fortran-if-indent))) - ((looking-at "\\(otherwise\\|else[ \t]*where\\)\\b") - (setq icol (- icol fortran-if-indent))) - ((looking-at "end[ \t]*where\\b") - (setq icol (- icol fortran-if-indent))) - ((and (looking-at "continue\\b") - (fortran-check-for-matching-do)) - (setq icol (- icol fortran-do-indent))) - ((looking-at "end[ \t]*do\\b") - (setq icol (- icol fortran-do-indent))) - ((looking-at - "end[ \t]*\ -\\(structure\\|union\\|map\\|interface\\)\\b[ \t]*[^ \t=(a-z]") - (setq icol (- icol fortran-structure-indent))) - ((looking-at - "end[ \t]*select\\b[ \t]*[^ \t=(a-z]") - (setq icol (- icol fortran-if-indent))) - ((and (looking-at "end\\b[ \t]*[^ \t=(a-z]") - (not (= icol fortran-minimum-statement-indent))) - (message "Warning: `end' not in column %d. Probably\ - an unclosed block." fortran-minimum-statement-indent)))))) - (max fortran-minimum-statement-indent icol))) - -(defun fortran-current-line-indentation () - "Indentation of current line, ignoring Fortran line number or continuation. -This is the column position of the first non-whitespace character -aside from the line number and/or column 5/8 line-continuation character. -For comment lines, returns indentation of the first -non-indentation text within the comment." - (save-excursion - (beginning-of-line) - (cond ((looking-at comment-line-start-skip) - (goto-char (match-end 0)) - (skip-chars-forward - (if (stringp fortran-comment-indent-char) - fortran-comment-indent-char - (char-to-string fortran-comment-indent-char)))) - ((or (looking-at " [^ 0\n]") - (looking-at "\t[1-9]")) - (goto-char (match-end 0))) - (t - ;; Move past line number. - (skip-chars-forward "[ \t0-9]");From Uli - )) - ;; Move past whitespace. - (skip-chars-forward " \t") - (current-column))) - -(defun fortran-indent-to-column (col) - "Indents current line with spaces to column COL. -notes: 1) A non-zero/non-blank character in column 5 indicates a continuation - line, and this continuation character is retained on indentation; - 2) If `fortran-continuation-string' is the first non-whitespace - character, this is a continuation line; - 3) A non-continuation line which has a number as the first - non-whitespace character is a numbered line. - 4) A TAB followed by a digit indicates a continuation line." - (save-excursion - (beginning-of-line) - (if (looking-at comment-line-start-skip) - (if fortran-comment-indent-style - (let ((char (if (stringp fortran-comment-indent-char) - (aref fortran-comment-indent-char 0) - fortran-comment-indent-char))) - (goto-char (match-end 0)) - (delete-horizontal-regexp (concat " \t" (char-to-string char))) - (insert-char char (- col (current-column))))) - (if (looking-at "\t[1-9]") - (if indent-tabs-mode - (goto-char (match-end 0)) - (delete-char 2) - (insert " ") - (insert fortran-continuation-string)) - (if (looking-at " [^ 0\n]") - (if indent-tabs-mode - (progn (delete-char 6) - (insert "\t") - (insert-char (fortran-numerical-continuation-char) 1)) - (forward-char 6)) - (delete-horizontal-space) - ;; Put line number in columns 0-4 - ;; or put continuation character in column 5. - (cond ((eobp)) - ((looking-at (regexp-quote fortran-continuation-string)) - (if indent-tabs-mode - (progn - (indent-to - (if indent-tabs-mode - fortran-minimum-statement-indent-tab - fortran-minimum-statement-indent-fixed)) - (delete-char 1) - (insert-char (fortran-numerical-continuation-char) 1)) - (indent-to 5) - (forward-char 1))) - ((looking-at "[0-9]+") - (let ((extra-space (- 5 (- (match-end 0) (point))))) - (if (< extra-space 0) - (message "Warning: line number exceeds 5-digit limit.") - (indent-to (min fortran-line-number-indent extra-space)))) - (skip-chars-forward "0-9"))))) - ;; Point is now after any continuation character or line number. - ;; Put body of statement where specified. - (delete-horizontal-space) - (indent-to col) - ;; Indent any comment following code on the same line. - (if (and comment-start-skip - (fortran-find-comment-start-skip)) - (progn (goto-char (match-beginning 0)) - (if (not (= (current-column) (fortran-comment-hook))) - (progn (delete-horizontal-space) - (indent-to (fortran-comment-hook))))))))) - -(defun fortran-line-number-indented-correctly-p () - "Return t if current line's line number is correctly indented. -Do not call if there is no line number." - (save-excursion - (beginning-of-line) - (skip-chars-forward " \t") - (and (<= (current-column) fortran-line-number-indent) - (or (= (current-column) fortran-line-number-indent) - (progn (skip-chars-forward "0-9") - (= (current-column) 5)))))) - -(defun fortran-check-for-matching-do () - "When called from a numbered statement, returns t if matching DO is found. -Otherwise return a nil." - (let (charnum - (case-fold-search t)) - (save-excursion - (beginning-of-line) - (if (looking-at "[ \t]*[0-9]+") - (progn - (skip-chars-forward " \t") - (skip-chars-forward "0") ;skip past leading zeros - (setq charnum (buffer-substring (point) - (progn (skip-chars-forward "0-9") - (point)))) - (beginning-of-line) - (and (re-search-backward - (concat "\\(^[ \t0-9]*end\\b[ \t]*[^ \t=(a-z]\\)\\|" - "\\(^[ \t0-9]*do[ \t]*0*" charnum "\\b\\)\\|" - "\\(^[ \t]*0*" charnum "\\b\\)") - nil t) - (looking-at (concat "^[ \t0-9]*do[ \t]*0*" charnum)))))))) - -(defun fortran-find-comment-start-skip () - "Move to past `comment-start-skip' found on current line. -Return t if `comment-start-skip' found, nil if not." -;;; In order to move point only if comment-start-skip is found, -;;; this one uses a lot of save-excursions. Note that re-search-forward -;;; moves point even if comment-start-skip is inside a string-constant. -;;; Some code expects certain values for match-beginning and end - (interactive) - (if (save-excursion - (re-search-forward comment-start-skip - (save-excursion (end-of-line) (point)) t)) - (let ((save-match-beginning (match-beginning 0)) - (save-match-end (match-end 0))) - (if (fortran-is-in-string-p (match-beginning 0)) - (save-excursion - (goto-char save-match-end) - (fortran-find-comment-start-skip)) ; recurse for rest of line - (goto-char save-match-beginning) - (re-search-forward comment-start-skip - (save-excursion (end-of-line) (point)) t) - (goto-char (match-end 0)) - t)) - nil)) - -;;;From: simon@gnu (Simon Marshall) -;;; Find the next ! not in a string. -(defun fortran-match-!-comment (limit) - (let (found) - (while (and (setq found (search-forward "!" limit t)) - (fortran-is-in-string-p (point)))) - (if (not found) - nil - ;; Cheaper than `looking-at' "!.*". - (store-match-data - (list (1- (point)) (progn (end-of-line) (min (point) limit)))) - t))) - -;; The above function is about 10% faster than the below... -;;(defun fortran-match-!-comment (limit) -;; (let (found) -;; (while (and (setq found (re-search-forward "!.*" limit t)) -;; (fortran-is-in-string-p (match-beginning 0)))) -;; found)) - -;;;From: ralf@up3aud1.gwdg.de (Ralf Fassel) -;;; Test if TAB format continuation lines work. -(defun fortran-is-in-string-p (where) - "Return non-nil if POS (a buffer position) is inside a Fortran string, -nil else." - (save-excursion - (goto-char where) - (cond - ((bolp) nil) ; bol is never inside a string - ((save-excursion ; comment lines too - (beginning-of-line)(looking-at comment-line-start-skip)) nil) - (t (let (;; ok, serious now. Init some local vars: - (parse-state '(0 nil nil nil nil nil 0)) - (quoted-comment-start (if comment-start - (regexp-quote comment-start))) - (not-done t) - parse-limit - end-of-line - ) - ;; move to start of current statement - (fortran-next-statement) - (fortran-previous-statement) - ;; now parse up to WHERE - (while not-done - (if (or ;; skip to next line if: - ;; - comment line? - (looking-at comment-line-start-skip) - ;; - at end of line? - (eolp) - ;; - not in a string and after comment-start? - (and (not (nth 3 parse-state)) - comment-start - (equal comment-start - (char-to-string (preceding-char))))) - ;; get around a bug in forward-line in versions <= 18.57 - (if (or (> (forward-line 1) 0) (eobp)) - (setq not-done nil)) - ;; else: - ;; if we are at beginning of code line, skip any - ;; whitespace, labels and tab continuation markers. - (if (bolp) (skip-chars-forward " \t0-9")) - ;; if we are in column <= 5 now, check for continuation char - (cond ((= 5 (current-column)) (forward-char 1)) - ((and (< (current-column) 5) - (equal fortran-continuation-string - (char-to-string (following-char))) - (forward-char 1)))) - ;; find out parse-limit from here - (setq end-of-line (save-excursion (end-of-line)(point))) - (setq parse-limit (min where end-of-line)) - ;; parse max up to comment-start, if non-nil and in current line - (if comment-start - (save-excursion - (if (re-search-forward quoted-comment-start end-of-line t) - (setq parse-limit (min (point) parse-limit))))) - ;; now parse if still in limits - (if (< (point) where) - (setq parse-state (parse-partial-sexp - (point) parse-limit nil nil parse-state)) - (setq not-done nil)) - )) - ;; result is - (nth 3 parse-state)))))) - -(defun fortran-auto-fill-mode (arg) - "Toggle fortran-auto-fill mode. -With ARG, turn `fortran-auto-fill' mode on iff ARG is positive. -In `fortran-auto-fill' mode, inserting a space at a column beyond `fill-column' -automatically breaks the line at a previous space." - (interactive "P") - (prog1 (setq auto-fill-function - (if (if (null arg) - (not auto-fill-function) - (> (prefix-numeric-value arg) 0)) - 'fortran-do-auto-fill - nil)) - (redraw-modeline))) - -(defun fortran-do-auto-fill () - (if (> (current-column) fill-column) - (fortran-indent-line))) - -(defun fortran-fill () - (interactive) - (let* ((opoint (point)) - (bol (save-excursion (beginning-of-line) (point))) - (eol (save-excursion (end-of-line) (point))) - (bos (min eol (+ bol (fortran-current-line-indentation)))) - (quote - (save-excursion - (goto-char bol) - (if (looking-at comment-line-start-skip) - nil ; OK to break quotes on comment lines. - (move-to-column fill-column) - (cond ((fortran-is-in-string-p (point)) - (save-excursion (re-search-backward "[^']'[^']" bol t) - (if fortran-break-before-delimiters - (point) - (1+ (point))))) - (t nil))))) - ;; - ;; decide where to split the line. If a position for a quoted - ;; string was found above then use that, else break the line - ;; before the last delimiter. - ;; Delimiters are whitespace, commas, and operators. - ;; Will break before a pair of *'s. - ;; - (fill-point - (or quote - (save-excursion - (move-to-column (1+ fill-column)) - (skip-chars-backward "^ \t\n,'+-/*=)" -;;; (if fortran-break-before-delimiters -;;; "^ \t\n,'+-/*=" "^ \t\n,'+-/*=)") - ) - (if (<= (point) (1+ bos)) - (progn - (move-to-column (1+ fill-column)) -;;;what is this doing??? - (if (not (re-search-forward "[\t\n,'+-/*)=]" eol t)) - (goto-char bol)))) - (if (bolp) - (re-search-forward "[ \t]" opoint t) - (forward-char -1) - (if (looking-at "'") - (forward-char 1) - (skip-chars-backward " \t\*"))) - (if fortran-break-before-delimiters - (point) - (1+ (point)))))) - ) - ;; if we are in an in-line comment, don't break unless the - ;; line of code is longer than it should be. Otherwise - ;; break the line at the column computed above. - ;; - ;; Need to use fortran-find-comment-start-skip to make sure that quoted !'s - ;; don't prevent a break. - (if (not (or (save-excursion - (if (and (re-search-backward comment-start-skip bol t) - (not (fortran-is-in-string-p (point)))) - (progn - (skip-chars-backward " \t") - (< (current-column) (1+ fill-column))))) - (save-excursion - (goto-char fill-point) - (bolp)))) - (if (> (save-excursion - (goto-char fill-point) (current-column)) - (1+ fill-column)) - (progn (goto-char fill-point) - (fortran-break-line)) - (save-excursion - (if (> (save-excursion - (goto-char fill-point) - (current-column)) - (+ (calculate-fortran-indent) fortran-continuation-indent)) - (progn - (goto-char fill-point) - (fortran-break-line)))))) - )) -(defun fortran-break-line () - (let ((bol (save-excursion (beginning-of-line) (point))) - (eol (save-excursion (end-of-line) (point))) - (comment-string nil)) - - (save-excursion - (if (and comment-start-skip (fortran-find-comment-start-skip)) - (progn - (re-search-backward comment-start-skip bol t) - (setq comment-string (buffer-substring (point) eol)) - (delete-region (point) eol)))) -;;; Forward line 1 really needs to go to next non white line - (if (save-excursion (forward-line 1) - (or (looking-at " [^ 0\n]") - (looking-at "\t[1-9]"))) - (progn - (end-of-line) - (delete-region (point) (match-end 0)) - (delete-horizontal-space) - (fortran-fill)) - (fortran-split-line)) - (if comment-string - (save-excursion - (goto-char bol) - (end-of-line) - (delete-horizontal-space) - (indent-to (fortran-comment-hook)) - (insert comment-string))))) - -(defun fortran-analyze-file-format () - "Returns nil if fixed format is used, t if TAB formatting is used. -Use `fortran-tab-mode-default' if no non-comment statements are found in the -file before the end or the first `fortran-analyze-depth' lines." - (let ((i 0)) - (save-excursion - (goto-char (point-min)) - (setq i 0) - (while (not (or - (eobp) - (looking-at "\t") - (looking-at " ") - (> i fortran-analyze-depth))) - (forward-line) - (setq i (1+ i))) - (cond - ((looking-at "\t") t) - ((looking-at " ") nil) - (fortran-tab-mode-default t) - (t nil))))) - -(or (assq 'fortran-tab-mode-string minor-mode-alist) - (setq minor-mode-alist (cons - '(fortran-tab-mode-string - (indent-tabs-mode fortran-tab-mode-string)) - minor-mode-alist))) - -(provide 'fortran) - -;;; fortran.el ends here
--- a/lisp/modes/ksh-mode.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1307 +0,0 @@ -;; ksh-mode.el --- sh (ksh, bash) script editing mode for GNU Emacs. - -;; Copyright (C) 1992-96 Gary Ellison. - -;; 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. - -;; $Source: /afs/informatik.uni-tuebingen.de/local/web/xemacs/xemacs-cvs/XEmacs/xemacs/lisp/modes/Attic/ksh-mode.el,v $ -- -;; -;; LCD Archive Entry: -;; ksh-mode|Gary F. Ellison|Gary.F.Ellison@ATT.COM -;; |Mode for editing sh/ksh/bash scripts -;; |$Date: 1997/06/14 20:31:11 $|$Revision: 1.4 $|~/modes/ksh-mode.el.Z| - -;; Author: Gary F. Ellison <Gary.F.Ellison@ATT.COM> -;; AT&T Laboratories -;; 6200 East Broad Street -;; Columbus, Ohio 43213 USA -;; -;; Maintainer: Gary F. Ellison <Gary.F.Ellison@ATT.COM> -;; Created: Fri Jun 19 -;; $Revision: 1.4 $ -;; Keywords: shell, korn, bourne, sh, ksh, bash -;; -;; Delta On $Date: 1997/06/14 20:31:11 $ -;; Last Modified By: Gary Ellison -;; Last Modified On: Mon Sep 11 12:26:47 1995 -;; Update Count : 35 -;; Status : Highly Functional -;; - -;;; Commentary: - -;; -;; Description: -;; sh, ksh, and bash script editing commands for emacs. -;; -;; Installation: -;; Put ksh-mode.el in some directory in your load-path. -;; Refer to the installation section of ksh-mode's function definition. -;; -;; Usage: -;; This major mode assists shell script writers with indentation -;; control and control structure construct matching in much the same -;; fashion as other programming language modes. Invoke describe-mode -;; for more information. -;; -;; Bugs: -;; When the ksh-align-to-keyword is non-nil and the nester -;; is a multi-command expression with a compound command -;; the lines following the compound end will align incorrectly -;; to the compound command instead of it's current indentation. -;; The fix will probably require the detection of syntax elements -;; in the nesting line. -;; -;; Function ending brace "}" must be on a separate line for indent-line -;; to do the right thing. -;; -;; Explicit function definition matching will proclaim in the minibuffer -;; "No matching compound command" followed by "Matched ... " -;; -;; indent-for-comment fails to recognize a comment starting in column 0, -;; hence it moves the comment-start in comment-column. - -;;; Code: - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; HISTORY -;; 6-Apr-96 Gary Ellison <gary.f.ellison@att.com> -;; Depreciated font-lock-doc-string-face. -;; Narly keywords inside strings bug fixed. -;; -;; 8-Aug-95 Jack Repenning <jackr@sgi.com> -;; Fix documentation of `ksh-align-to-keyword' to conform to the 23 -;; Feb default change. Search for keywords obeying case, since the -;; shell does. -;; -;; 23-Feb-1995 Gary Ellison -;; Merged Jonathan Stigelman <Stig@hackvan.com> into 2.5 souce. -;; -;; 23 Feb 1995 Jonathan Stigelman <Stig@hackvan.com> -;; Reshuffled documentation to make the format more consistant with other -;; elisp. Added autoload and removed autoloading instructions from the -;; ksh-mode docstring. Changed default value for `ksh-align-to-keyword' -;; to nil because it doesn't work properly. -;; -;; 2-Aug-1994 Gary Ellison -;; Last Modified: Mon Jun 13 16:52:55 1994 #29 (Gary Ellison) -;; - Syntax table modifications to better support sexp navigation and -;; parsing. -;; - Fixed keyword regexps. Keywords were not being recoginized on the -;; same line as " ' `. -;; -;; 13-Jun-1994 Gary Ellison -;; Last Modified: Wed Mar 30 14:12:26 1994 #28 (Gary Ellison) -;; - Minor excursion problem fixed in ksh-indent-command. -;; -;; 30-Mar-1994 Gary Ellison -;; Last Modified: Fri Mar 25 15:42:29 1994 #25 (Gary Ellison) -;; - Implement user customizable ksh-comment-regexp. -;; - Make the keyword vs line indentation alignment customizable -;; by calling ksh-align-to-keyword based on variable of same -;; name. (If the code is obfuscated or convoluted I can attribute -;; this to a severe head cold and not malice :) -;; -;; 25-Mar-1994 Gary Ellison -;; Last Modified: Fri Feb 4 13:06:30 1994 #23 (Gary Ellison) -;; - Nest relative to the line indentation not the keywords -;; column. -;; -;; 4-Feb-1994 Gary Ellison -;; Last Modified: Wed Nov 10 10:03:01 1993 #18 (Gary Ellison) -;; - Add direct support for font-lock-mode. Thanks Espen Skoglund -;; for the regular expressions. -;; -;; 10-Nov-1993 Gary Ellison -;; Last Modified: Tue Oct 12 15:23:06 1993 #17 (Gary Ellison) -;; Fix message on ksh-match-and-tell to not get invalid format -;; when a % appears in the string. -;; -;; 12-Oct-1993 Espen Skoglund <espensk@stud.cs.uit.no>. -;; Last Modified: Tue Oct 12 15:03:01 1993 #16 (Gary Ellison) -;; Apply Line continuation patch supplied by Espen Skoglund -;; -;; 1-Sep-1993 Gary Ellison -;; Last Modified: Tue Aug 17 17:18:18 1993 #14 (Gary Ellison) -;; Get rid of this-line hack in ksh-get-nester-column. -;; -;; 17-Aug-1993 Gary Ellison -;; Last Modified: Mon Jun 21 14:00:43 1993 #13 (Gary Ellison) -;; Code uses builtin current-indentation instead of lisp defun -;; ksh-indentation-on-this-line (thanks to Tom Tromey). -;; More and better doc strings. -;; -;; 5-Aug-1993 Tom Tromey <tromey@cns.caltech.edu> -;; Last Modified: Thu Aug 5 11:09:12 1993 #12 (Tom Tromey) -;; ksh-indent-region skips blank lines. Uses let binding instead -;; of setq. No longer marks buffer modified if indentation -;; doesn't change. -;; -;; 21-Jun-1993 Gary Ellison -;; Last Modified: Mon Mar 29 15:05:34 1993 #11 (Gary Ellison) -;; Use make-local-variables instead of make-variables-buffer-local -;; ksh-indent now supports nil (keyword aligned) or number (offset) -;; Support ksh-tab-always-indent feature -;; Variables offsetting indentation renamed to better reflect their -;; role. -;; Integrate keyword completion feature supplied by -;; Haavard Rue <hrue@imf.unit.no>. -;; -;; 29-Mar-1993 Gary Ellison -;; Last Modified: Tue Sep 29 16:14:02 1992 #10 (Gary Ellison) -;; Integrate line continuation patch supplied by -;; Haavard Rue <hrue@imf.unit.no> -;; Name back to ksh-mode to avoid confusion with sh-mode -;; by Thomas W. Strong, Jr. <strong+@cmu.edu>. -;; -;; 29-Sep-1992 Gary Ellison -;; Last Modified: Wed Sep 2 08:51:40 1992 #9 (Gary Ellison) -;; Full support of ksh88 case items. -;; Align statements under "do" and "then" keywords one position -;; past the keyword. -;; -;; 2-Sep-1992 Gary Ellison -;; Last Modified: Tue Aug 4 14:34:35 1992 #8 (Gary Ellison) -;; Use make-variable-buffer-local instead of make-local-variable -;; Get rid of superflous ksh-default variables. -;; Use end of word match \b for "then", "do", "else", "elif" -;; Support process substitution lists and exclude ksh 88 case items -;; Use default-tab-width for indentation defaults. -;; Moved installation instructions to the mode level documentation -;; section. -;; Fixed auto-mode-alist documentation. -;; -;; 24-Jul-1992 Gary Ellison -;; Last Modified: Fri Jul 24 09:45:11 1992 #7 (Gary Ellison) -;; Modified ksh-indent-region to use marker versus fixed end point. -;; comment-start-skip regexp no longer fooled by parameter substitution. -;; Added constant ksh-mode-version. -;; -;; 21-Jul-1992 Gary Ellison -;; Last Modified: Tue Jul 21 15:53:57 1992 #6 (Gary Ellison) -;; Indent with tabs instead of spaces. -;; Can handle just about all styles. -;; Anti-newline in REs. -;; Word delim "\b" in REs -;; More syntax entries. -;; Variables with regexp suffix abbreviated to re -;; Better } handling -;; Implemented minimal indent-region-function -;; Mode documentation corrected. -;; Minor lisp source format changes. -;; -;; 29-Jun-1992 Gary Ellison -;; Last Modified: Mon Jun 29 15:39:35 1992 #5 (Gary Ellison) -;; Optimize line-to-string -;; Implicit/Explicit functions aok -;; More indentation variables -;; Superfluous defun killed. -;; renamed to sh-mode -;; -;; 22-Jun-1992 Gary Ellison -;; Last Modified: Mon Jun 22 15:01:14 1992 #4 (Gary Ellison) -;; Cleanup pre att.emacs posting -;; -;; 19-Jun-1992 Gary Ellison -;; Last Modified: Fri Jun 19 17:19:14 1992 #3 (Gary Ellison) -;; Minimal case indent handling -;; -;; 19-Jun-1992 Gary Ellison -;; Last Modified: Fri Jun 19 16:23:26 1992 #2 (Gary Ellison) -;; Nesting handled except for case statement -;; -;; 19-Jun-1992 Gary Ellison -;; Last Modified: Fri Jun 19 10:03:07 1992 #1 (Gary Ellison) -;; Conception of this mode. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defconst ksh-mode-version "$Revision: 1.4 $" - "*Version numbers of this version of ksh-mode") - -;; -;; Variables controlling indentation style -;; - -(defvar ksh-indent 2 - ;; perhaps c-basic-offset would be okay to use as a default, but using - ;; default-tab-width as the default is ridiculous --Stig - "*Indentation of ksh statements with respect to containing block. A value -of nil indicates compound list keyword \(\"do\" and \"then\"\) alignment.") -(defvar ksh-case-item-offset ksh-indent - "*Additional indentation for case items within a case statement.") -(defvar ksh-case-indent nil - "*Additional indentation for statements under case items.") -(defvar ksh-group-offset (- ksh-indent) - "*Additional indentation for keywords \"do\" and \"then\".") -(defvar ksh-brace-offset 0 - "*Additional indentation of \"{\" under functions or brace groupings.") -(defvar ksh-multiline-offset 1 - "*Additional indentation of line that is preceded of a line ending with a -\\ to make it continue on next line.") -(defvar ksh-match-and-tell t - "*If non-nil echo in the minibuffer the matching compound command -for the \"done\", \"}\", \"fi\", or \"esac\". ") -(defvar ksh-tab-always-indent t - "*Controls the operation of the TAB key. If t (the default), always -reindent the current line. If nil, indent the current line only if -point is at the left margin or in the line's indentation; otherwise -insert a tab.") - -(defvar ksh-align-to-keyword nil - ;; #### - this is broken, so it should be disabled by default --Stig - "*Controls whether nested constructs align from the keyword or -the current indentation. If non-nil, indentation will be relative to -the column the keyword starts. If nil, indentation will be relative to -the current indentation of the line the keyword is on. -The default value is non-nil. The non-nil case doesn't work very well.") - -(defvar ksh-comment-regexp "^\\s *#" - "*Regular expression used to recognize comments. Customize to support -ksh-like languages.") - -(defun ksh-current-indentation () - nil - ) -;; -(fset 'ksh-current-indentation 'current-column) -;; -;; Variables controlling completion -(defvar ksh-completion-list '()) -(make-variable-buffer-local 'ksh-completion-list) -(set-default 'ksh-completion-list '()) - -;; -;; -type- : type number, 0:misc, 1:variable, 2:function -;; -regexp-: regexp used to parse the script -;; -match- : used by match-beginning/end to pickup target -;; -(defvar ksh-completion-type-misc 0) -(defvar ksh-completion-regexp-var "\\([A-Za-z_0-9]+\\)=") -(defvar ksh-completion-type-var 1) -(defvar ksh-completion-match-var 1) -(defvar ksh-completion-regexp-var2 "\\$\\({\\|{#\\)?\\([A-Za-z_0-9]+\\)[#%:}]?") -(defvar ksh-completion-match-var2 2) -(defvar ksh-completion-regexp-function - "\\(function\\)?[ \t]*\\([A-Za-z_0-9]+\\)[ \t]*([ \t]*)") -(defvar ksh-completion-type-function 2) -(defvar ksh-completion-match-function 2) - -;; -;; Variable controlling fontification -;; -(defvar ksh-keywords '("for" "in" "do" "done" "select" "case" "esac" "if" -"then" "elif" "else" "fi" "while" "until" "function" "time" -"alias" "bg" "break" "continue" "cd" "exit" "echo" "fc" "fg" "getopts" "jobs" -"kill" "let" "newgrp" "print" "pwd" "read" "readonly" "return" "set" "shift" -"test" "times" "trap" "typeset" "ulimit" "umask" "unalias" "unset" "wait" "whence")) - -;; '("\\<function[ \t]+\\([^(; \t]+\\)" 1 font-lock-function-name-face) -(defconst ksh-font-lock-keywords - (list - ;; Fontify [[ ]] expressions - '("\\(\\[.*\\]\\)" 1 font-lock-string-face t) - ;; Fontify keywords - (cons (concat - "\\(\\<" - (mapconcat 'identity ksh-keywords "\\>\\|\\<") - "\\>\\)") - 1) - ;; Fontify function names - '("\\<function[ \t]+\\([^(; \t]+\\)" 1 font-lock-function-name-face) - '("\\(^[ \t]*[A-Za-z_][A-Za-z_0-9]*[ \t]*()\\)" 1 font-lock-function-name-face) - )) - -;; XEmacs addition -(put 'ksh-mode 'font-lock-keywords 'ksh-font-lock-keywords) - -;; -;; Context/indentation regular expressions -;; -;; indenting expressions -;; -;(defconst ksh-then-do-re "^[^#\n]*\\s\"*\\b\\(then\\|do\\)\\b" -(defconst ksh-then-do-re "\\s *\\b\\(then\\|do\\)\\b" - "*Regexp used to locate grouping keywords: \"then\" and \"do\"" ) - -(defconst ksh-do-re "\\s *\\bdo\\(\\b\\|$\\)" - "*Regexp used to match keyword: do") - -(defconst ksh-then-re "\\s *\\bthen\\(\\b\\|$\\)" - "*Regexp used to match keyword: then") - -;; -;; Structure starting/indenting keywords -;; -(defconst ksh-else-re "\\s *\\belse\\(\\b\\|$\\)" - "*Regexp used to match keyword: else") - -(defconst ksh-elif-re "\\s *\\belif\\(\\b\\|$\\)" - "*Regexp used to match keyword: elif") - -(defconst ksh-brace-re "\\S>*{[ \t\n]" - "*Regexp used to match syntactic entity: { ") - -(defconst ksh-case-item-end-re "\\S>*;;[ \t\n]" - "*Regexp used to match case item end syntactic entity: ;;") - -(defconst ksh-keywords-re - "\\s *\\b\\(else\\|if\\|elif\\|case\\|while\\|for\\|until\\|select\\)\\b" - "*Regexp used to detect compound command keywords: if, else, elif case, -while, for, until, and select") - - -(defconst ksh-if-re "\\s *\\b\\(if\\)\\b" - "*Regexp used to match keyword: if") - -(defconst ksh-iteration-keywords-re - "\\s *\\b\\(while\\|for\\|until\\|select\\)\\b" - "*Match one of the keywords: while, until, for, select") - -(defconst ksh-case-re "\\s *\\bcase\\b" - "*Regexp used to match keyword: case") - -(defconst ksh-explicit-func-re - "^\\s *\\(function\\s [a-zA-z_][a-zA-Z0-1_]*\\)\\b" - "*Match an explicit function definition: function name") - -(defconst ksh-implicit-func-re - "^\\s *\\([a-zA-z_][a-zA-Z0-1_]*\\)\\s *()\\s *" - "*Match an implicit function definition: name ()") - -(defconst ksh-func-brace-re "^\\s *\\(.*{\\)[ \t\n]+" - "*Match a implicit function definition brace: name { ") - -;; -;; indenting -(defconst ksh-case-item-re "^[^#\n]*\\s\"*\\()\\)" - "*Regexp used to match case-items including ksh88") - -(defconst ksh-paren-re "^[^#\n]*\\s\"*)[ \t\n]+" - "*Regexp used to match compound list & case items") - -;; -;; structure ending keyword regular expressions -(defconst ksh-fi-re "\\s *\\bfi\\b" - "*Regexp used to match keyword: fi") - -(defconst ksh-esac-re "\\s *\\besac\\b" - "*Regexp used to match keyword: esac") - -(defconst ksh-done-re "\\s *\\bdone\\b" - "*Regexp used to match keyword: done") - -(defconst ksh-brace-end-re "\\s *}\\s *" - "*Regexp used to match function brace-groups") - -(defconst ksh-multiline-re "^.*\\\\$" - "*Regexp used to match a line with a statement using more lines.") - -;; -;; -;; Create mode specific tables -(defvar ksh-mode-syntax-table nil - "Syntax table used while in ksh mode.") -(if ksh-mode-syntax-table - () - (setq ksh-mode-syntax-table (make-syntax-table (standard-syntax-table))) - (modify-syntax-entry ?\( "." ksh-mode-syntax-table) - (modify-syntax-entry ?\) "." ksh-mode-syntax-table) - (modify-syntax-entry ?{ "." ksh-mode-syntax-table) - (modify-syntax-entry ?} "." ksh-mode-syntax-table) - (modify-syntax-entry ?\[ "(]" ksh-mode-syntax-table) - (modify-syntax-entry ?\] ")[" ksh-mode-syntax-table) - (modify-syntax-entry ?\' "\"" ksh-mode-syntax-table) - (modify-syntax-entry ?` "\"" ksh-mode-syntax-table) - (modify-syntax-entry ?\n ">" ksh-mode-syntax-table) - (modify-syntax-entry ?\f ">" ksh-mode-syntax-table) - (modify-syntax-entry ?# "<" ksh-mode-syntax-table) - (modify-syntax-entry ?_ "_" ksh-mode-syntax-table) - (modify-syntax-entry ?< "." ksh-mode-syntax-table) - (modify-syntax-entry ?> "." ksh-mode-syntax-table) - (modify-syntax-entry ?& "." ksh-mode-syntax-table) - (modify-syntax-entry ?| "." ksh-mode-syntax-table) - (modify-syntax-entry ?$ "\\" ksh-mode-syntax-table) - (modify-syntax-entry ?% "." ksh-mode-syntax-table) - (modify-syntax-entry ?= "." ksh-mode-syntax-table) - (modify-syntax-entry ?/ "." ksh-mode-syntax-table) - (modify-syntax-entry ?+ "." ksh-mode-syntax-table) - (modify-syntax-entry ?* "." ksh-mode-syntax-table) - (modify-syntax-entry ?- "." ksh-mode-syntax-table) - (modify-syntax-entry ?\; "." ksh-mode-syntax-table) - (modify-syntax-entry ?: "." ksh-mode-syntax-table) - ) - -(defvar ksh-mode-abbrev-table nil - "Abbrev table used while in ksh mode.") -(define-abbrev-table 'ksh-mode-abbrev-table ()) - -(defvar ksh-mode-map nil - "Keymap used in ksh mode") - -(if ksh-mode-map - () - (setq ksh-mode-map (make-sparse-keymap)) - (define-key ksh-mode-map "\t" 'ksh-indent-command) -;; (define-key ksh-mode-map "\t" 'ksh-indent-line) - (define-key ksh-mode-map "\C-j" 'reindent-then-newline-and-indent) - (define-key ksh-mode-map "\e\t" 'ksh-complete-symbol) - (define-key ksh-mode-map "\C-c\t" 'ksh-completion-init-and-pickup) - ) - - -;;;###autoload -(defun ksh-mode () - "ksh-mode $Revision: 1.4 $ - Major mode for editing (Bourne, Korn or Bourne again) -shell scripts. -Special key bindings and commands: -\\{ksh-mode-map} -Variables controlling indentation style: -ksh-indent - Indentation of ksh statements with respect to containing block. - Default value is 2. -ksh-case-indent - Additional indentation for statements under case items. - Default value is nil which will align the statements one position - past the \")\" of the pattern. -ksh-case-item-offset - Additional indentation for case items within a case statement. - Default value is 2. -ksh-group-offset - Additional indentation for keywords \"do\" and \"then\". - Default value is -2. -ksh-brace-offset - Additional indentation of \"{\" under functions or brace groupings. - Default value is 0. -ksh-multiline-offset - Additional indentation of line that is preceded of a line ending with a - \\ to make it continue on next line. -ksh-tab-always-indent - Controls the operation of the TAB key. If t (the default), always - reindent the current line. If nil, indent the current line only if - point is at the left margin or in the line's indentation; otherwise - insert a tab. -ksh-match-and-tell - If non-nil echo in the minibuffer the matching compound command - for the \"done\", \"}\", \"fi\", or \"esac\". Default value is t. - -ksh-align-to-keyword - Controls whether nested constructs align from the keyword or - the current indentation. If non-nil, indentation will be relative to - the column the keyword starts. If nil, indentation will be relative to - the current indentation of the line the keyword is on. - The default value is non-nil. - -ksh-comment-regexp - Regular expression used to recognize comments. Customize to support - ksh-like languages. Default value is \"\^\\\\s *#\". - -Style Guide. - By setting - (setq ksh-indent default-tab-width) - (setq ksh-group-offset 0) - - The following style is obtained: - - if [ -z $foo ] - then - bar # <-- ksh-group-offset is additive to ksh-indent - foo - fi - - By setting - (setq ksh-indent default-tab-width) - (setq ksh-group-offset (- 0 ksh-indent)) - - The following style is obtained: - - if [ -z $foo ] - then - bar - foo - fi - - By setting - (setq ksh-case-item-offset 1) - (setq ksh-case-indent nil) - - The following style is obtained: - - case x in * - foo) bar # <-- ksh-case-item-offset - baz;; # <-- ksh-case-indent aligns with \")\" - foobar) foo - bar;; - esac - - By setting - (setq ksh-case-item-offset 1) - (setq ksh-case-indent 6) - - The following style is obtained: - - case x in * - foo) bar # <-- ksh-case-item-offset - baz;; # <-- ksh-case-indent - foobar) foo - bar;; - esac - - -Installation: - - (setq ksh-mode-hook - (function (lambda () - (font-lock-mode 1) ;; font-lock the buffer - (setq ksh-indent 8) - (setq ksh-group-offset -8) - (setq ksh-brace-offset -8) - (setq ksh-tab-always-indent t) - (setq ksh-match-and-tell t) - (setq ksh-align-to-keyword t) ;; Turn on keyword alignment - )))" - ;; - ;; and away we go - (interactive) - (kill-all-local-variables) - (use-local-map ksh-mode-map) - (setq major-mode 'ksh-mode) - (setq mode-name "Ksh") - (setq local-abbrev-table ksh-mode-abbrev-table) - (set-syntax-table ksh-mode-syntax-table) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'ksh-indent-line) - (make-local-variable 'indent-region-function) - (setq indent-region-function 'ksh-indent-region) - (make-local-variable 'comment-start) - (setq comment-start "# ") - (make-local-variable 'comment-end) - (setq comment-end "") - (make-local-variable 'comment-column) - (setq comment-column 32) - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "#+ *") - ;; - ;; config font-lock mode - (make-local-variable 'font-lock-keywords) - (setq font-lock-keywords ksh-font-lock-keywords) - ;; - ;; Let the user customize - (run-hooks 'ksh-mode-hook) - (if (not ksh-align-to-keyword) - (ksh-align-to-keyword -1) - ) - ) ;; defun - -;; -;; Support functions - -(defun ksh-align-to-keyword (&optional arg) - "Toggle value of ksh-align-to-keyword and rebind the ksh-current-indentation -function. With arg, force alignment to keyword if and only if arg is positive." - (interactive) - (if (null arg) ;just toggle - (cond ((not ksh-align-to-keyword) - (setq ksh-align-to-keyword t) - (fset 'ksh-current-indentation 'current-column)) - (t - (setq ksh-align-to-keyword nil) - (fset 'ksh-current-indentation 'current-indentation)) - ) - (cond ((natnump arg) - (setq ksh-align-to-keyword t) - (fset 'ksh-current-indentation 'current-column)) - (t - (setq ksh-align-to-keyword nil) - (fset 'ksh-current-indentation 'current-indentation)) - )) - ) - -(defun ksh-current-line () - "Return the vertical position of point in the buffer. -Top line is 1." - (+ (count-lines (point-min) (point)) - (if (= (current-column) 0) 1 0)) - ) - - -(defun ksh-line-to-string () - "From point, construct a string from all characters on -current line" - (skip-chars-forward " \t") ;; skip tabs as well as spaces - (buffer-substring (point) - (progn - (end-of-line 1) - (point)))) - -(defun ksh-get-nest-level () - "Return a 2 element list (nest-level nest-line) describing where the -current line should nest." - (let ((case-fold-search) - (level)) - (save-excursion - (forward-line -1) - (while (and (not (bobp)) - (null level)) - (if (and (not (looking-at "^\\s *$")) - (not (save-excursion - (forward-line -1) - (beginning-of-line) - (looking-at ksh-multiline-re))) - (not (looking-at ksh-comment-regexp))) - (setq level (cons (current-indentation) - (ksh-current-line))) - (forward-line -1) - );; if - );; while - (if (null level) - (cons (current-indentation) (ksh-current-line)) - level) - ) - ) - ) - -(defun ksh-looking-at-compound-list () - "Return true if current line contains compound list initiating keyword" - (or - (looking-at ksh-do-re) - (looking-at ksh-then-re) - ) ;; or - ) ;; defun - -(defun ksh-looking-at-case-item () - "Return true if current line is a case-item .vs. paren compound list" - (save-excursion - (beginning-of-line) - ;; - ;; Handle paren indentation constructs for this line - (cond ((looking-at ksh-paren-re) - (goto-line (cdr (ksh-get-nest-level))) - ;; - ;; The question is whether this is really a case item or just - ;; parenthesized compound list. - (cond ((or (looking-at ksh-case-re) - (looking-at ksh-case-item-end-re))) - ;; - ;; turns out to be a parenthesized compound list - ;; so propigate the nil for cond - ) - )) - ) - ) ;; defun - - -(defun ksh-get-case-indent () - "Return the column of the closest open case statement" - (save-excursion - (let ( - (nest-list (ksh-get-compound-level ksh-case-re ksh-esac-re (point))) - ) - (if (null nest-list) - (progn - (if ksh-match-and-tell - (message "No matching case for ;;")) - 0) - (car nest-list))) - ) - ) - - -;; -;; Functions which make this mode what it is -;; - -(defun ksh-get-nester-column (nest-line) - "Return the column to indent to with respect to nest-line taking -into consideration keywords and other nesting constructs." - (save-excursion - (let ((fence-post) -; (start-post) - (nester-column) - (case-fold-search) - (start-line (ksh-current-line))) - (cond - ;; - ;; Handle case item indentation constructs for this line - ((ksh-looking-at-case-item) - (save-excursion - (goto-line nest-line) - (back-to-indentation) - (let ((fence-post (ksh-eol-point))) - ;; - ;; Now know there is a case-item so detect whether - ;; it is first under case, just another case-item, or - ;; a case-item and case-item-end all rolled together. - ;; - (cond ((ksh-search-forward-sexp ksh-case-re fence-post) - (+ (ksh-current-indentation) ksh-case-item-offset)) - - ((ksh-looking-at-case-item) - (current-indentation)) - - ((looking-at ksh-case-item-end-re) - (end-of-line) - (+ (ksh-get-case-indent) ksh-case-item-offset)) - ) - ))) - (t;; Not a case-item. What to do relative to the nest-line? - (save-excursion - (goto-line nest-line) -; (setq start-post (point)) - (setq fence-post (ksh-eol-point)) - (setq nester-column - (save-excursion - (cond - ;; - ;; Check if we are in a continued statement - ((and (looking-at ksh-multiline-re) - (save-excursion - (goto-line (1- start-line)) - (looking-at ksh-multiline-re))) - (+ (current-indentation) ksh-multiline-offset)) - ;; In order to locate the column of the keyword, - ;; which might be embedded within a case-item, - ;; it is necessary to iterate over sexp. - ((progn - (save-excursion - (back-to-indentation) - (if (ksh-search-forward-sexp ksh-keywords-re fence-post) - (progn - ;; - ;; special pun intended 'case' - (if (looking-at ksh-case-re) - (+ (ksh-current-indentation) - ksh-case-item-offset) - (+ (ksh-current-indentation) - (if (null ksh-indent) - 2 ksh-indent)))) - nil)) - )) - ;; - ;; handle then or do - ((progn - (save-excursion - (back-to-indentation) - (if (ksh-search-forward-sexp ksh-then-do-re fence-post) - (progn - (if (null ksh-indent) - (+ (ksh-current-indentation) 1) - (+ (ksh-current-indentation) ksh-indent))) - nil)))) - - ((looking-at ksh-brace-re) - (+ (current-indentation) - (if (null ksh-indent) - 2 ksh-indent) - )) - ;; - ;; Forces functions to first column - ((or (looking-at ksh-implicit-func-re) - (looking-at ksh-explicit-func-re)) - (if (looking-at ksh-func-brace-re) - (if (null ksh-indent) - 2 ksh-indent) - ksh-brace-offset)) - - ;; - ;; Need to first detect the end of a case-item - ((looking-at ksh-case-item-end-re) - (end-of-line) - (+ (ksh-get-case-indent) ksh-case-item-offset)) - ;; - ;; Now detect first statement under a case item - ((ksh-looking-at-case-item) - (if (null ksh-case-indent) - (progn - (re-search-forward ksh-case-item-re fence-post t) - (goto-char (match-end 1)) - (+ (current-column) 1)) - (+ (current-indentation) ksh-case-indent))) - - ;; This is hosed when using current-column - ;; and there is a multi-command expression as the - ;; nester. - (t (current-indentation))) - ) - ));; excursion over - ;; - ;; Handle additional indentation constructs for this line - (cond ((ksh-looking-at-compound-list) - (+ nester-column ksh-group-offset)) - ((looking-at ksh-brace-re) - (+ nester-column ksh-brace-offset)) - (t nester-column)) - );; Not a case-item - ) - );;let - );; excursion - ) ;; defun - -(defun ksh-indent-command () - "Indent current line relative to containing block and allow for -ksh-tab-always-indent customization" - (interactive) - (let (case-fold-search) - (cond ((save-excursion - (skip-chars-backward " \t") - (bolp)) - (ksh-indent-line)) - (ksh-tab-always-indent - (save-excursion - (ksh-indent-line))) - (t (insert-tab)) - )) - ) - - -(defun ksh-indent-line () - "Indent current line as far as it should go according -to the syntax/context" - (interactive) - (let (case-fold-search) - (save-excursion - (beginning-of-line) - (if (bobp) - nil - ;; - ;; Align this line to current nesting level - (let* - ( - (level-list (ksh-get-nest-level)) ; Where to nest against - ;; (last-line-level (car level-list)) - (this-line-level (current-indentation)) - (nester-column (ksh-get-nester-column (cdr level-list))) - (struct-match (ksh-match-structure-and-reindent)) - ) - (if struct-match - (setq nester-column struct-match)) - (if (eq nester-column this-line-level) - nil - (beginning-of-line) - (let ((beg (point))) - (back-to-indentation) - (delete-region beg (point))) - (indent-to nester-column)) - );; let* - );; if - );; excursion - ;; - ;; Position point on this line - (let* - ( - (this-line-level (current-indentation)) - (this-bol (ksh-bol-point)) - (this-point (- (point) this-bol)) - ) - (cond ((> this-line-level this-point);; point in initial white space - (back-to-indentation)) - (t nil) - );; cond - );; let* - );; let - );; defun - - -(defun ksh-match-indent-level (begin-re end-re) - "Match the compound command and indent. Return nil on no match, -indentation to use for this line otherwise." - (interactive) - (let* ((case-fold-search) - (nest-list - (save-excursion - (ksh-get-compound-level begin-re end-re (point)) - )) - ) ;; bindings - (if (null nest-list) - (progn - (if ksh-match-and-tell - (message "No matching compound command")) - nil) ;; Propagate a miss. - (let* ( - (nest-level (car nest-list)) - (match-line (cdr nest-list)) - ) ;; bindings - (if ksh-match-and-tell - (save-excursion - (goto-line match-line) - (message "Matched ... %s" (ksh-line-to-string)) - ) ;; excursion - ) ;; if ksh-match-and-tell - nest-level ;;Propagate a hit. - ) ;; let* - ) ;; if - ) ;; let* - ) ;; defun ksh-match-indent-level - -(defun ksh-match-structure-and-reindent () - "If the current line matches one of the indenting keywords -or one of the control structure ending keywords then reindent. Also -if ksh-match-and-tell is non-nil the matching structure will echo in -the minibuffer" - (interactive) - (let (case-fold-search) - (save-excursion - (beginning-of-line) - (back-to-indentation) - (cond ((looking-at ksh-else-re) - (ksh-match-indent-level ksh-if-re ksh-fi-re)) - ((looking-at ksh-elif-re) - (ksh-match-indent-level ksh-if-re ksh-fi-re)) - ((looking-at ksh-fi-re) - (ksh-match-indent-level ksh-if-re ksh-fi-re)) - ((looking-at ksh-done-re) - (ksh-match-indent-level ksh-iteration-keywords-re ksh-done-re)) - ((looking-at ksh-esac-re) - (ksh-match-indent-level ksh-case-re ksh-esac-re)) - ;; - ((looking-at ksh-brace-end-re) - (cond - ((ksh-match-indent-level ksh-implicit-func-re ksh-brace-end-re)) - ((ksh-match-indent-level ksh-explicit-func-re ksh-brace-end-re)) - ((ksh-match-indent-level ksh-func-brace-re ksh-brace-end-re)) - (t nil))) - (t nil) - );; cond - ) - )) - - -(defun ksh-search-backward-sexp (sexp-re fence-post) - (let - ((old-pnt (point)) - (sentinal nil) - ) - (while - (progn - (if (not sentinal) - (backward-sexp 1)) - (and (> (point) fence-post) - (not sentinal)) - ) - (if (looking-at sexp-re) - (save-excursion ;avoid comment foolage - (let ((key-fence (point))) - (beginning-of-line) - (back-to-indentation) - (while (and (ksh-search-forward-sexp sexp-re key-fence) - (< (point) key-fence))) - - (if (= key-fence (point)) - (setq sentinal t)) - )) - )) - - (if (< (point) fence-post) - (progn (goto-char old-pnt) - nil) - t) - )) - -(defun ksh-forward-sexp () - "Special incantation to march over syntax expressions and -avoid all sorts of nonsense" - (if (char-equal ?< (char-syntax (char-after (point)))) - (end-of-line) - (if (char-equal ?. (char-syntax (char-after (point)))) - (forward-char) - (forward-sexp 1)) - ) - (if (eolp) - (forward-line)) - (skip-chars-forward ") \t") ;damn case - ) - -(defun ksh-search-forward-sexp (sexp-re fence-post) - "Search for an sexp. Return t on success with point at the -beginning of the sexp. Return nil on failure and restoring point -to it's original position" - (let - ((old-pnt (point)) - ) - (while (and (< (point) fence-post) - (not (looking-at sexp-re))) - (ksh-forward-sexp)) - - (if (> (point) fence-post) - (progn (goto-char old-pnt) - nil) - t) - )) - - -(defun ksh-get-compound-level - (begin-re end-re anchor-point &optional balance-list) - "Determine how much to indent this structure. Return a list (level line) -of the matching compound command or nil if no match found." - (let* - (;; Locate the next compound begin keyword bounded by point-min - (match-point - (if (and (ksh-search-backward-sexp begin-re (point-min)) - (>= (point) (point-min)) - ) - (point) - 0)) - - (nest-column (if (zerop match-point) - 1 - (progn - (goto-char match-point) - (ksh-current-indentation)))) - (nest-list (cons 0 0)) ;; sentinel cons since cdr is >= 1 - ) - (if (zerop match-point) - nil ;; graceful exit from recursion - (progn - (if (nlistp balance-list) - (setq balance-list (list))) - ;; Now search forward from matching start keyword for end keyword - ;; which will locate interceding compound commands - (while (and (consp nest-list) (zerop (cdr nest-list)) - (ksh-search-forward-sexp end-re anchor-point) - (> anchor-point (point)) - ) - (if (not (memq (point) balance-list)) - (progn - (setq balance-list (cons (point) balance-list)) - (goto-char match-point) ;; beginning of compound cmd - (setq nest-list - (ksh-get-compound-level begin-re end-re - anchor-point balance-list)) - ) - (ksh-forward-sexp) - )) - - (cond ((consp nest-list) - (if (zerop (cdr nest-list)) - (progn - (goto-char match-point) - (cons nest-column (ksh-current-line))) - nest-list)) - (t nil) - ) - ) - ) - ) - ) - - -(defun ksh-indent-region (start end) - "From start to end, indent each line." - ;; The algorithm is just moving through the region line by line with - ;; the match noise turned off. Only modifies nonempty lines. - (save-excursion - (let (ksh-match-and-tell - (endmark (copy-marker end))) - - (goto-char start) - (beginning-of-line) - (setq start (point)) - (while (> (marker-position endmark) start) - (if (not (and (bolp) (eolp))) - (ksh-indent-line)) - (forward-line 1) - (setq start (point))) - - (set-marker endmark nil) - ) - ) - ) - -;; -;; Completion code supplied by Haavard Rue <hrue@imf.unit.no>. -;; -;; -;; add a completion with a given type to the list -;; -(defun ksh-addto-alist (completion type) - (setq ksh-completion-list - (append ksh-completion-list - (list (cons completion type))))) -;; -;; init the list and pickup all -;; -(defun ksh-completion-init-and-pickup () - (interactive) - (let (case-fold-search) - (ksh-completion-list-init) - (ksh-pickup-all))) - -;; -;; init the list -;; -(defun ksh-completion-list-init () - (interactive) - (setq ksh-completion-list - (list - (cons "if" ksh-completion-type-misc) - (cons "while" ksh-completion-type-misc) - (cons "until" ksh-completion-type-misc) - (cons "select" ksh-completion-type-misc) - (cons "for" ksh-completion-type-misc) - (cons "continue" ksh-completion-type-misc) - (cons "function" ksh-completion-type-misc) - (cons "fi" ksh-completion-type-misc) - (cons "case" ksh-completion-type-misc) - (cons "esac" ksh-completion-type-misc) - (cons "break" ksh-completion-type-misc) - (cons "exit" ksh-completion-type-misc) - (cons "done" ksh-completion-type-misc) - (cons "do" ksh-completion-type-misc)))) - -(defun ksh-eol-point () - (save-excursion - (end-of-line) - (point))) - -(defun ksh-bol-point () - (save-excursion - (beginning-of-line) - (point))) - -(defun ksh-pickup-all () - "Pickup all completions in buffer." - (interactive) - (ksh-pickup-completion-driver (point-min) (point-max) t)) - -(defun ksh-pickup-this-line () - "Pickup all completions in current line." - (interactive) - (ksh-pickup-completion-driver (ksh-bol-point) (ksh-eol-point) nil)) - -(defun ksh-pickup-completion-driver (pmin pmax message) - "Driver routine for ksh-pickup-completion." - (if message - (message "pickup completion...")) - (let* ( - (i1 - (ksh-pickup-completion ksh-completion-regexp-var - ksh-completion-type-var - ksh-completion-match-var - pmin pmax)) - (i2 - (ksh-pickup-completion ksh-completion-regexp-var2 - ksh-completion-type-var - ksh-completion-match-var2 - pmin pmax)) - (i3 - (ksh-pickup-completion ksh-completion-regexp-function - ksh-completion-type-function - ksh-completion-match-function - pmin pmax))) - (if message - (message "pickup %d variables and %d functions." (+ i1 i2) i3)))) - -(defun ksh-pickup-completion (regexp type match pmin pmax) - "Pickup completion in region and addit to the list, if not already -there." - (let ((i 0) kw obj) - (save-excursion - (goto-char pmin) - (while (and - (re-search-forward regexp pmax t) - (match-beginning match) - (setq kw (buffer-substring - (match-beginning match) - (match-end match)))) - (progn - (setq obj (assoc kw ksh-completion-list)) - (if (or (equal nil obj) - (and (not (equal nil obj)) - (not (= type (cdr obj))))) - (progn - (setq i (1+ i)) - (ksh-addto-alist kw type)))))) - i)) - -(defun ksh-complete-symbol () - "Perform completion." - (interactive) - (let* ((case-fold-search) - (end (point)) - (beg (unwind-protect - (save-excursion - (backward-sexp 1) - (while (= (char-syntax (following-char)) ?\') - (forward-char 1)) - (point)))) - (pattern (buffer-substring beg end)) - (predicate - ;; - ;; ` or $( mark a function - ;; - (save-excursion - (goto-char beg) - (if (or - (save-excursion - (backward-char 1) - (looking-at "`")) - (save-excursion - (backward-char 2) - (looking-at "\\$("))) - (function (lambda (sym) - (equal (cdr sym) ksh-completion-type-function))) - ;; - ;; a $, ${ or ${# mark a variable - ;; - (if (or - (save-excursion - (backward-char 1) - (looking-at "\\$")) - (save-excursion - (backward-char 2) - (looking-at "\\${")) - (save-excursion - (backward-char 3) - (looking-at "\\${#"))) - (function (lambda (sym) - (equal (cdr sym) - ksh-completion-type-var))) - ;; - ;; don't know. use 'em all - ;; - (function (lambda (sym) t)))))) - ;; - (completion (try-completion pattern ksh-completion-list predicate))) - ;; - (cond ((eq completion t)) - ;; - ;; oops, what is this ? - ;; - ((null completion) - (message "Can't find completion for \"%s\"" pattern)) - ;; - ;; insert - ;; - ((not (string= pattern completion)) - (delete-region beg end) - (insert completion)) - ;; - ;; write possible completion in the minibuffer, - ;; use this instead of a separate buffer (usual) - ;; - (t - (let ((list (all-completions pattern ksh-completion-list predicate)) - (string "")) - (while list - (progn - (setq string (concat string (format "%s " (car list)))) - (setq list (cdr list)))) - (message string)))))) - -(provide 'ksh-mode) -;;; ksh-mode.el ends here
--- a/lisp/modes/lazy-shot.el Mon Aug 13 10:03:54 2007 +0200 +++ b/lisp/modes/lazy-shot.el Mon Aug 13 10:04:58 2007 +0200 @@ -22,13 +22,13 @@ ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. -;;; Synched up with: Not in FSF (mostly equivalent to lazy-lock 2.06 -;;; in FSF 19.34). +;;; Synched up with: Not in FSF (mostly equivalent to lazy-lock 2.09 +;;; in FSF 20.2). ;;; Commentary: ;;; This is an experimental demand based font-lock implemenation. It -;;; is almost equal in functionality and interface to lazy-lock 2.06 +;;; is almost equal in functionality and interface to lazy-lock 2.09 ;;; Does somebody really need defer-locking? ;;; ;;; To use: put @@ -116,18 +116,19 @@ "Toggle Lazy Lock mode. With arg, turn Lazy Lock mode on if and only if arg is positive." (interactive "P") - (set (make-local-variable 'lazy-shot-mode) - (and (if arg (> (prefix-numeric-value arg) 0) (not lazy-shot-mode)))) - (cond ((and lazy-shot-mode (not font-lock-mode)) - ;; Turned on `lazy-shot-mode' rather than `font-lock-mode'. - (let ((font-lock-support-mode 'lazy-shot-mode)) - (font-lock-mode t))) - (lazy-shot-mode - ;; Turn ourselves on. - (lazy-shot-install)) - (t - ;; Turn ourselves off. - (lazy-shot-unstall)))) + (let ((was-on lazy-shot-mode)) + (set (make-local-variable 'lazy-shot-mode) + (and (if arg (> (prefix-numeric-value arg) 0) (not lazy-shot-mode)))) + (cond ((and lazy-shot-mode (not font-lock-mode)) + ;; Turned on `lazy-shot-mode' rather than `font-lock-mode'. + (let ((font-lock-support-mode 'lazy-shot-mode)) + (font-lock-mode t))) + (lazy-shot-mode + ;; Turn ourselves on. + (lazy-shot-install)) + (was-on + ;; Turn ourselves off. + (lazy-shot-unstall))))) (custom-add-option 'font-lock-mode-hook 'turn-on-lazy-lock) @@ -151,6 +152,7 @@ "Lazy lock the EXTENT when it has become visisble." (lazy-shot-lock-extent extent nil)) + (defun lazy-shot-lock-extent (extent stealth) "Font-lock the EXTENT. Called from redisplay-trigger functions and stealth locking functions" @@ -159,22 +161,35 @@ (end (extent-end-position extent)) (buffer (extent-object extent))) (delete-extent extent) - (save-excursion - ;; Should inhibit quit here - (set-buffer buffer) ;; with-current-buffer is silly here - ;; This magic should really go into font-lock-fonity-region - (goto-char start) - (setq start (point-at-bol)) - (goto-char end) - (setq end (point-at-bol 2)) - (lazy-shot-clean-up-extents start end) - (if (or lazy-shot-verbose (and stealth lazy-shot-stealth-verbose)) - (display-message 'progress - (format "Lazy-shot fontifying %sfrom %s to %s in %s" - (if stealth "stealthy " "") start end buffer))) - ;; and a allow quit here - (save-match-data - (font-lock-fontify-region start end)))))) + (lazy-shot-fontify-internal buffer start end + (or lazy-shot-verbose + (and stealth + lazy-shot-stealth-verbose)) + (if stealth "stealthy " ""))))) + +(defun lazy-shot-fontify-internal (buffer start end verbose message) + (save-excursion + ;; Should inhibit quit here + (set-buffer buffer) ;; with-current-buffer is silly here + ;; This magic should really go into font-lock-fonity-region + (goto-char start) + (setq start (point-at-bol)) + (goto-char end) + (setq end (point-at-bol 2)) + (lazy-shot-clean-up-extents start end) + ;; and a allow quit here + (if verbose + (display-message 'progress + (format "Lazy-shot fontifying %sfrom %s to %s in %s" + message start end buffer))) + (save-match-data + (font-lock-fontify-region start end)))) + +;; Note this is suboptimal but works for now. It is not called that often. +(defun lazy-shot-fontify-region (start end &optional buffer) + (lazy-shot-fontify-internal (or buffer (current-buffer)) + start end lazy-shot-verbose + "on request ")) (defun lazy-shot-stealth-lock (buffer) "Find an extent to lazy lock in buffer." @@ -235,9 +250,15 @@ (setq font-lock-fontified (and lazy-shot-minimum-size (>= (buffer-size) lazy-shot-minimum-size))) (lazy-shot-install-extents font-lock-fontified) - (lazy-shot-install-timer font-lock-fontified)) + (lazy-shot-install-timer font-lock-fontified) + (add-hook 'font-lock-after-fontify-buffer-hook + 'lazy-shot-unstall-after-fontify)) -(defun lazy-shot-unstall () +;; Kludge needed untill lazy-lock-fontify-region is more intelligent +(defun lazy-shot-unstall-after-fontify () + (lazy-shot-unstall 1)) + +(defun lazy-shot-unstall (&optional no-fontify) ;; Stop the timer (when lazy-shot-stealth-timer (delete-itimer lazy-shot-stealth-timer) @@ -246,14 +267,10 @@ (map-extents (lambda (e arg) (delete-extent e) nil) nil nil nil nil nil 'initial-redisplay-function 'lazy-shot-redisplay-function) - ;; - ;; Remove the fontification hooks. - (remove-hook 'after-change-functions 'lazy-shot-defer-after-change t) - ;; - ;; If Font Lock mode is still enabled, reinstall its hook. - (when font-lock-mode - (add-hook 'after-change-functions 'font-lock-after-change-function nil t))) - + (when (and font-lock-mode (not no-fontify)) + (save-restriction + (widen) + (lazy-shot-fontify-region (point-min) (point-max))))) (provide 'lazy-shot)
--- a/lisp/modes/lisp-mode.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1005 +0,0 @@ -;;; lisp-mode.el --- Lisp mode, and its idiosyncratic commands. - -;; Copyright (C) 1985, 1996 Free Software Foundation, Inc. -;; Copyright (C) 1995 Tinker Systems - -;; Maintainer: FSF -;; Keywords: lisp, languages - -;; 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.34 (but starting to diverge). - -;;; Commentary: - -;; The base major mode for editing Lisp code (used also for Emacs Lisp). -;; This mode is documented in the Emacs manual - -;; July/05/97 slb Converted to use easymenu. - -;;; Code: - -(defvar lisp-mode-syntax-table nil "") -(defvar emacs-lisp-mode-syntax-table nil "") -(defvar lisp-mode-abbrev-table nil "") - -;; XEmacs change -(defvar lisp-interaction-mode-popup-menu nil) -(defvar lisp-interaction-mode-popup-menu-1 - (purecopy '("Lisp-Interaction" - ["Evaluate Last S-expression" eval-last-sexp t] - ["Evaluate Entire Buffer" eval-current-buffer t] - ["Evaluate Region" eval-region (region-exists-p)] - "---" - ["Evaluate This Defun" eval-defun t] - ;; FSF says "Instrument Function for Debugging" - ["Debug This Defun" edebug-defun t] - "---" - ["Trace a Function" trace-function-background t] - ["Untrace All Functions" untrace-all (fboundp 'untrace-all)] - "---" - ["Comment Out Region" comment-region (region-exists-p)] - ["Indent Region" indent-region (region-exists-p)] - ["Indent Line" lisp-indent-line t] - "---" - ["Debug On Error" (setq debug-on-error (not debug-on-error)) - :style toggle :selected debug-on-error] - ["Debug On Quit" (setq debug-on-quit (not debug-on-quit)) - :style toggle :selected debug-on-quit] - ["Debug on Signal" (setq debug-on-signal (not debug-on-signal)) - :style toggle :selected debug-on-signal] - ))) - -(defvar emacs-lisp-mode-popup-menu nil) -(defvar emacs-lisp-mode-popup-menu-1 - (purecopy - (nconc - '("Emacs-Lisp" - ["Byte-compile This File" emacs-lisp-byte-compile t] - ["Byte-recompile Directory..." byte-recompile-directory t] - "---") - (cdr lisp-interaction-mode-popup-menu-1)))) - -;Don't have a menubar entry in Lisp Interaction mode. Otherwise, the -;*scratch* buffer has a Lisp menubar item! Very confusing. -;(defvar lisp-interaction-mode-menubar-menu -; (purecopy (cons "Lisp" (cdr lisp-interaction-mode-popup-menu)))) - -(defvar emacs-lisp-mode-menubar-menu nil) -(defvar emacs-lisp-mode-menubar-menu-1 - (purecopy (cons "Lisp" (cdr emacs-lisp-mode-popup-menu-1)))) - -(if (not emacs-lisp-mode-syntax-table) - (let ((i 0)) - (setq emacs-lisp-mode-syntax-table (make-syntax-table)) - (while (< i ?0) - (modify-syntax-entry i "_ " emacs-lisp-mode-syntax-table) - (setq i (1+ i))) - (setq i (1+ ?9)) - (while (< i ?A) - (modify-syntax-entry i "_ " emacs-lisp-mode-syntax-table) - (setq i (1+ i))) - (setq i (1+ ?Z)) - (while (< i ?a) - (modify-syntax-entry i "_ " emacs-lisp-mode-syntax-table) - (setq i (1+ i))) - (setq i (1+ ?z)) - (while (< i 128) - (modify-syntax-entry i "_ " emacs-lisp-mode-syntax-table) - (setq i (1+ i))) - (modify-syntax-entry ? " " emacs-lisp-mode-syntax-table) - (modify-syntax-entry ?\t " " emacs-lisp-mode-syntax-table) - (modify-syntax-entry ?\n "> " emacs-lisp-mode-syntax-table) - ;; Give CR the same syntax as newline, for selective-display. - (modify-syntax-entry ?\^m "> " emacs-lisp-mode-syntax-table) - ;; XEmacs change - ;; Treat ^L as whitespace. - (modify-syntax-entry ?\f " " emacs-lisp-mode-syntax-table) - (modify-syntax-entry ?\; "< " emacs-lisp-mode-syntax-table) - (modify-syntax-entry ?` "' " emacs-lisp-mode-syntax-table) - (modify-syntax-entry ?' "' " emacs-lisp-mode-syntax-table) - (modify-syntax-entry ?, "' " emacs-lisp-mode-syntax-table) - ;; Used to be singlequote; changed for flonums. - (modify-syntax-entry ?. "_ " emacs-lisp-mode-syntax-table) - (modify-syntax-entry ?# "' " emacs-lisp-mode-syntax-table) - (modify-syntax-entry ?\" "\" " emacs-lisp-mode-syntax-table) - (modify-syntax-entry ?\\ "\\ " emacs-lisp-mode-syntax-table) - (modify-syntax-entry ?\( "() " emacs-lisp-mode-syntax-table) - (modify-syntax-entry ?\) ")( " emacs-lisp-mode-syntax-table) - (modify-syntax-entry ?\[ "(] " emacs-lisp-mode-syntax-table) - (modify-syntax-entry ?\] ")[ " emacs-lisp-mode-syntax-table))) - -(if (not lisp-mode-syntax-table) - (progn (setq lisp-mode-syntax-table - (copy-syntax-table emacs-lisp-mode-syntax-table)) - (modify-syntax-entry ?\| "\" " lisp-mode-syntax-table) - (modify-syntax-entry ?\[ "_ " lisp-mode-syntax-table) - ;; XEmacs changes - (modify-syntax-entry ?\] "_ " lisp-mode-syntax-table) - ;; - ;; If emacs was compiled with NEW_SYNTAX, then do - ;; CL's #| |# block comments. - (if (= 8 (length (parse-partial-sexp (point) (point)))) - (progn - (modify-syntax-entry ?# "' 58" lisp-mode-syntax-table) - (modify-syntax-entry ?| ". 67" lisp-mode-syntax-table)) - ;; else, old style - (modify-syntax-entry ?\| "\" " lisp-mode-syntax-table)))) - -(define-abbrev-table 'lisp-mode-abbrev-table ()) - -;(defvar lisp-imenu-generic-expression -; '( -; (nil -; "^\\s-*(def\\(un\\|subst\\|macro\\|advice\\)\\s-+\\([-A-Za-z0-9+]+\\)" 2) -; ("Variables" -; "^\\s-*(def\\(var\\|const\\)\\s-+\\([-A-Za-z0-9+]+\\)" 2) -; ("Types" -; "^\\s-*(def\\(type\\|struct\\|class\\|ine-condition\\)\\s-+\\([-A-Za-z0-9+]+\\)" -; 2)) -; -; "Imenu generic expression for Lisp mode. See `imenu-generic-expression'.") - -(defun lisp-mode-variables (lisp-syntax) - (cond (lisp-syntax - (set-syntax-table lisp-mode-syntax-table))) - (setq local-abbrev-table lisp-mode-abbrev-table) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat page-delimiter "\\|$" )) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate paragraph-start) - (make-local-variable 'paragraph-ignore-fill-prefix) - (setq paragraph-ignore-fill-prefix t) - (make-local-variable 'fill-paragraph-function) - (setq fill-paragraph-function 'lisp-fill-paragraph) - ;; Adaptive fill mode gets in the way of auto-fill, - ;; and should make no difference for explicit fill - ;; because lisp-fill-paragraph should do the job. - (make-local-variable 'adaptive-fill-mode) - (setq adaptive-fill-mode nil) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'lisp-indent-line) - (make-local-variable 'indent-region-function) - (setq indent-region-function 'lisp-indent-region) - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments t) - (make-local-variable 'outline-regexp) - (setq outline-regexp ";;; \\|(....") - (make-local-variable 'comment-start) - (setq comment-start ";") - ;; XEmacs change - (set (make-local-variable 'block-comment-start) ";;") - (make-local-variable 'comment-start-skip) - ;; Look within the line for a ; following an even number of backslashes - ;; after either a non-backslash or the line beginning. - (setq comment-start-skip "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *") - (make-local-variable 'comment-column) - (setq comment-column 40) - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'lisp-comment-indent) - ;; XEmacs changes -; (make-local-variable 'imenu-generic-expression) -; (setq imenu-generic-expression lisp-imenu-generic-expression) - (set (make-local-variable 'dabbrev-case-fold-search) nil) - (set (make-local-variable 'dabbrev-case-replace) nil) - ) - - -(defvar shared-lisp-mode-map () - "Keymap for commands shared by all sorts of Lisp modes.") - -(if shared-lisp-mode-map - () - (setq shared-lisp-mode-map (make-sparse-keymap)) - ;; XEmacs changes - (set-keymap-name shared-lisp-mode-map 'shared-lisp-mode-map) - (define-key shared-lisp-mode-map "\M-;" 'lisp-indent-for-comment) - (define-key shared-lisp-mode-map "\e\C-q" 'indent-sexp)) - -(defvar emacs-lisp-mode-map () - "Keymap for Emacs Lisp mode. -All commands in `shared-lisp-mode-map' are inherited by this map.") - -(if emacs-lisp-mode-map - () - ;; XEmacs: Ignore FSF nconc stuff - (setq emacs-lisp-mode-map (make-sparse-keymap)) - (set-keymap-name emacs-lisp-mode-map 'emacs-lisp-mode-map) - (set-keymap-parents emacs-lisp-mode-map (list shared-lisp-mode-map)) - (define-key emacs-lisp-mode-map "\e\t" 'lisp-complete-symbol) - (define-key emacs-lisp-mode-map "\e\C-x" 'eval-defun) - ;; XEmacs: Not sure what the FSF menu bindings are. I hope XEmacs - ;; doesn't need them. -) - -(defun emacs-lisp-byte-compile () - "Byte compile the file containing the current buffer." - (interactive) - (if buffer-file-name - ;; XEmacs change. Force buffer save first - (progn - (save-buffer) - (byte-compile-file buffer-file-name)) - (error "The buffer must be saved in a file first."))) - -(defun emacs-lisp-byte-compile-and-load () - "Byte-compile the current file (if it has changed), then load compiled code." - (interactive) - (or buffer-file-name - (error "The buffer must be saved in a file first")) - (require 'bytecomp) - ;; Recompile if file or buffer has changed since last compilation. - (if (and (buffer-modified-p) - (y-or-n-p (format "save buffer %s first? " (buffer-name)))) - (save-buffer)) - (let ((compiled-file-name (byte-compile-dest-file buffer-file-name))) - (if (file-newer-than-file-p compiled-file-name buffer-file-name) - (load-file compiled-file-name) - (byte-compile-file buffer-file-name t)))) - -(defun emacs-lisp-mode () - "Major mode for editing Lisp code to run in Emacs. -Commands: -Delete converts tabs to spaces as it moves back. -Blank lines separate paragraphs. Semicolons start comments. -\\{emacs-lisp-mode-map} -Entry to this mode calls the value of `emacs-lisp-mode-hook' -if that value is non-nil." - (interactive) - (kill-all-local-variables) - (use-local-map emacs-lisp-mode-map) - (set-syntax-table emacs-lisp-mode-syntax-table) - ;; XEmacs changes - (setq major-mode 'emacs-lisp-mode - ;; mode-popup-menu emacs-lisp-mode-popup-menu - mode-name "Emacs-Lisp") - ;; (if (and (featurep 'menubar) - ;; current-menubar) - ;; (progn - ;; make a local copy of the menubar, so our modes don't - ;; change the global menubar - ;; (set-buffer-menubar current-menubar) - ;; (add-submenu nil emacs-lisp-mode-menubar-menu))) - (unless emacs-lisp-mode-popup-menu - (easy-menu-define emacs-lisp-mode-popup-menu emacs-lisp-mode-map "" - emacs-lisp-mode-popup-menu-1)) - (easy-menu-add emacs-lisp-mode-popup-menu) - (lisp-mode-variables nil) - (run-hooks 'emacs-lisp-mode-hook)) - -(defvar lisp-mode-map () - "Keymap for ordinary Lisp mode. -All commands in `shared-lisp-mode-map' are inherited by this map.") - -(if lisp-mode-map - () - ;; XEmacs changes - (setq lisp-mode-map (make-sparse-keymap)) - (set-keymap-name lisp-mode-map 'lisp-mode-map) - (set-keymap-parents lisp-mode-map (list shared-lisp-mode-map)) - (define-key lisp-mode-map "\e\C-x" 'lisp-send-defun) - ;; gag, no. use ilisp. -jwz -;; (define-key lisp-mode-map "\C-c\C-z" 'run-lisp) - ) - -(defun lisp-mode () - "Major mode for editing Lisp code for Lisps other than GNU Emacs Lisp. -Commands: -Delete converts tabs to spaces as it moves back. -Blank lines separate paragraphs. Semicolons start comments. -\\{lisp-mode-map} -Note that `run-lisp' may be used either to start an inferior Lisp job -or to switch back to an existing one. - -Entry to this mode calls the value of `lisp-mode-hook' -if that value is non-nil." - (interactive) - (kill-all-local-variables) - (use-local-map lisp-mode-map) - (setq major-mode 'lisp-mode) - (setq mode-name "Lisp") - (lisp-mode-variables t) - (set-syntax-table lisp-mode-syntax-table) - (run-hooks 'lisp-mode-hook)) - -;; This will do unless shell.el is loaded. -;; XEmacs change -(defun lisp-send-defun () - "Send the current defun to the Lisp process made by \\[run-lisp]." - (interactive) - (error "Process lisp does not exist")) - -;; XEmacs change: emacs-lisp-mode-map is a more appropriate parent. -(defvar lisp-interaction-mode-map () - "Keymap for Lisp Interaction mode. -All commands in `shared-lisp-mode-map' are inherited by this map.") - -(if lisp-interaction-mode-map - () - ;; XEmacs set keymap our way - (setq lisp-interaction-mode-map (make-sparse-keymap)) - (set-keymap-name lisp-interaction-mode-map 'lisp-interaction-mode-map) - (set-keymap-parents lisp-interaction-mode-map (list emacs-lisp-mode-map)) - (define-key lisp-interaction-mode-map "\e\C-x" 'eval-defun) - (define-key lisp-interaction-mode-map "\e\t" 'lisp-complete-symbol) - (define-key lisp-interaction-mode-map "\n" 'eval-print-last-sexp)) - -(defun lisp-interaction-mode () - "Major mode for typing and evaluating Lisp forms. -Like Lisp mode except that \\[eval-print-last-sexp] evals the Lisp expression -before point, and prints its value into the buffer, advancing point. - -Commands: -Delete converts tabs to spaces as it moves back. -Paragraphs are separated only by blank lines. -Semicolons start comments. -\\{lisp-interaction-mode-map} -Entry to this mode calls the value of `lisp-interaction-mode-hook' -if that value is non-nil." - (interactive) - (kill-all-local-variables) - (use-local-map lisp-interaction-mode-map) - (setq major-mode 'lisp-interaction-mode) - (setq mode-name "Lisp Interaction") - ;; XEmacs change - ;; (setq mode-popup-menu lisp-interaction-mode-popup-menu) - (unless lisp-interaction-mode-popup-menu - (easy-menu-define lisp-interaction-mode-popup-menu - lisp-interaction-mode-map - "" - lisp-interaction-mode-popup-menu-1)) - (easy-menu-add lisp-interaction-mode-popup-menu) - - (set-syntax-table emacs-lisp-mode-syntax-table) - (lisp-mode-variables nil) - (run-hooks 'lisp-interaction-mode-hook)) - -(defun eval-print-last-sexp () - "Evaluate sexp before point; print value into current buffer." - (interactive) - (let ((standard-output (current-buffer))) - (terpri) - (eval-last-sexp t) - (terpri))) - -;; XEmacs change -(defcustom eval-interactive-verbose t - "*Non-nil means that interactive evaluation can print messages. -The messages are printed when the expression is treated differently -using `\\[eval-last-sexp]' and `\\[eval-defun]' than it than it would have been -treated noninteractively. - -The printed messages are \"defvar treated as defconst\" and \"defcustom - evaluation forced\". See `eval-interactive' for more details." - :type 'boolean - :group 'lisp) - -(defun eval-interactive (expr) - "Like `eval' except that it transforms defvars to defconsts. -The evaluation of defcustom forms is forced." - (cond ((and (consp expr) - (eq (car expr) 'defvar) - (> (length expr) 2)) - (eval (cons 'defconst (cdr expr))) - (and eval-interactive-verbose - (message "defvar treated as defconst")) - (sit-for 1) - (message "") - (nth 1 expr)) - ((and (consp expr) - (eq (car expr) 'defcustom) - (> (length expr) 2) - (default-boundp (nth 1 expr))) - ;; Force variable to be bound - (set-default (nth 1 expr) (eval (nth 2 expr))) - ;; And evaluate the defcustom - (eval expr) - (and eval-interactive-verbose - (message "defcustom evaluation forced")) - (sit-for 1) - (message "") - (nth 1 expr)) - (t - (eval expr)))) - -;; XEmacs change, based on Bob Weiner suggestion -(defun eval-last-sexp (eval-last-sexp-arg-internal) ;dynamic scoping wonderment - "Evaluate sexp before point; print value in minibuffer. -With argument, print output into current buffer." - (interactive "P") - (let ((standard-output (if eval-last-sexp-arg-internal (current-buffer) t)) - (opoint (point))) - (prin1 (let ((stab (syntax-table)) - expr) - (eval-interactive - (unwind-protect - (save-excursion - (set-syntax-table emacs-lisp-mode-syntax-table) - (forward-sexp -1) - (save-restriction - (narrow-to-region (point-min) opoint) - (setq expr (read (current-buffer))) - (if (and (consp expr) - (eq (car expr) 'interactive)) - (list 'quote - (call-interactively - (eval (` (lambda (&rest args) - (, expr) args))))) - expr))) - (set-syntax-table stab))))))) - -(defun eval-defun (eval-defun-arg-internal) - "Evaluate defun that point is in or before. -Print value in minibuffer. -With argument, insert value in current buffer after the defun." - (interactive "P") - (let ((standard-output (if eval-defun-arg-internal (current-buffer) t))) - (prin1 (eval-interactive (save-excursion - (end-of-defun) - (beginning-of-defun) - (read (current-buffer))))))) - - -(defun lisp-comment-indent () - (if (looking-at "\\s<\\s<\\s<") - (current-column) - (if (looking-at "\\s<\\s<") - (let ((tem (calculate-lisp-indent))) - (if (listp tem) (car tem) tem)) - (skip-chars-backward " \t") - (max (if (bolp) 0 (1+ (current-column))) - comment-column)))) - -;; XEmacs change -(defun lisp-indent-for-comment () - "Indent this line's comment appropriately, or insert an empty comment. -If adding a new comment on a blank line, use `block-comment-start' instead -of `comment-start' to open the comment." - ;; by Stig@hackvan.com - ;; #### - This functionality, the recognition of block-comment-{start,end}, - ;; will perhaps be standardized across modes and move to indent-for-comment. - (interactive) - (if (and block-comment-start - (save-excursion (beginning-of-line) (looking-at "^[ \t]*$"))) - (insert block-comment-start)) - (indent-for-comment)) - -(defconst lisp-indent-offset nil "") -(defconst lisp-indent-function 'lisp-indent-function "") - -(defun lisp-indent-line (&optional whole-exp) - "Indent current line as Lisp code. -With argument, indent any additional lines of the same expression -rigidly along with this one." - (interactive "P") - (let ((indent (calculate-lisp-indent)) shift-amt beg end - (pos (- (point-max) (point)))) - (beginning-of-line) - (setq beg (point)) - (skip-chars-forward " \t") - (if (looking-at "\\s<\\s<\\s<") - ;; Don't alter indentation of a ;;; comment line. - (goto-char (- (point-max) pos)) - (if (and (looking-at "\\s<") (not (looking-at "\\s<\\s<"))) - ;; Single-semicolon comment lines should be indented - ;; as comment lines, not as code. - (progn (indent-for-comment) (forward-char -1)) - (if (listp indent) (setq indent (car indent))) - (setq shift-amt (- indent (current-column))) - (if (zerop shift-amt) - nil - (delete-region beg (point)) - (indent-to indent))) - ;; If initial point was within line's indentation, - ;; position after the indentation. Else stay at same point in text. - (if (> (- (point-max) pos) (point)) - (goto-char (- (point-max) pos))) - ;; If desired, shift remaining lines of expression the same amount. - (and whole-exp (not (zerop shift-amt)) - (save-excursion - (goto-char beg) - (forward-sexp 1) - (setq end (point)) - (goto-char beg) - (forward-line 1) - (setq beg (point)) - (> end beg)) - (indent-code-rigidly beg end shift-amt))))) - -(defvar calculate-lisp-indent-last-sexp) - -(defun calculate-lisp-indent (&optional parse-start) - "Return appropriate indentation for current line as Lisp code. -In usual case returns an integer: the column to indent to. -Can instead return a list, whose car is the column to indent to. -This means that following lines at the same level of indentation -should not necessarily be indented the same way. -The second element of the list is the buffer position -of the start of the containing expression." - (save-excursion - (beginning-of-line) - (let ((indent-point (point)) - ;; XEmacs change (remove paren-depth) - state ;;paren-depth - ;; setting this to a number inhibits calling hook - (desired-indent nil) - (retry t) - calculate-lisp-indent-last-sexp containing-sexp) - (if parse-start - (goto-char parse-start) - (beginning-of-defun)) - ;; Find outermost containing sexp - (while (< (point) indent-point) - (setq state (parse-partial-sexp (point) indent-point 0))) - ;; Find innermost containing sexp - (while (and retry - state - ;; XEmacs change (remove paren-depth) - (> ;;(setq paren-depth (elt state 0)) - (elt state 0) - 0)) - (setq retry nil) - (setq calculate-lisp-indent-last-sexp (elt state 2)) - (setq containing-sexp (elt state 1)) - ;; Position following last unclosed open. - (goto-char (1+ containing-sexp)) - ;; Is there a complete sexp since then? - (if (and calculate-lisp-indent-last-sexp - (> calculate-lisp-indent-last-sexp (point))) - ;; Yes, but is there a containing sexp after that? - (let ((peek (parse-partial-sexp calculate-lisp-indent-last-sexp - indent-point 0))) - (if (setq retry (car (cdr peek))) (setq state peek))))) - (if retry - nil - ;; Innermost containing sexp found - (goto-char (1+ containing-sexp)) - (if (not calculate-lisp-indent-last-sexp) - ;; indent-point immediately follows open paren. - ;; Don't call hook. - (setq desired-indent (current-column)) - ;; Find the start of first element of containing sexp. - (parse-partial-sexp (point) calculate-lisp-indent-last-sexp 0 t) - (cond ((looking-at "\\s(") - ;; First element of containing sexp is a list. - ;; Indent under that list. - ) - ((> (save-excursion (forward-line 1) (point)) - calculate-lisp-indent-last-sexp) - ;; This is the first line to start within the containing sexp. - ;; It's almost certainly a function call. - (if (= (point) calculate-lisp-indent-last-sexp) - ;; Containing sexp has nothing before this line - ;; except the first element. Indent under that element. - nil - ;; Skip the first element, find start of second (the first - ;; argument of the function call) and indent under. - (progn (forward-sexp 1) - (parse-partial-sexp (point) - calculate-lisp-indent-last-sexp - 0 t))) - (backward-prefix-chars)) - (t - ;; Indent beneath first sexp on same line as - ;; calculate-lisp-indent-last-sexp. Again, it's - ;; almost certainly a function call. - (goto-char calculate-lisp-indent-last-sexp) - (beginning-of-line) - (parse-partial-sexp (point) calculate-lisp-indent-last-sexp - 0 t) - (backward-prefix-chars))))) - ;; Point is at the point to indent under unless we are inside a string. - ;; Call indentation hook except when overridden by lisp-indent-offset - ;; or if the desired indentation has already been computed. - (let ((normal-indent (current-column))) - (cond ((elt state 3) - ;; Inside a string, don't change indentation. - (goto-char indent-point) - (skip-chars-forward " \t") - (current-column)) - (desired-indent) - ((and (boundp 'lisp-indent-function) - lisp-indent-function - (not retry)) - (or (funcall lisp-indent-function indent-point state) - normal-indent)) - ;; XEmacs change: - ;; lisp-indent-offset shouldn't override lisp-indent-function ! - ((and (integerp lisp-indent-offset) containing-sexp) - ;; Indent by constant offset - (goto-char containing-sexp) - (+ normal-indent lisp-indent-offset)) - (t - normal-indent)))))) - -(defun lisp-indent-function (indent-point state) - ;; free reference to `calculate-lisp-indent-last-sexp' - ;; in #'calculate-lisp-indent - (let ((normal-indent (current-column))) - (goto-char (1+ (elt state 1))) - (parse-partial-sexp (point) calculate-lisp-indent-last-sexp 0 t) - (if (and (elt state 2) - (not (looking-at "\\sw\\|\\s_"))) - ;; car of form doesn't seem to be a a symbol - (progn - (if (not (> (save-excursion (forward-line 1) (point)) - calculate-lisp-indent-last-sexp)) - (progn (goto-char calculate-lisp-indent-last-sexp) - (beginning-of-line) - (parse-partial-sexp (point) - calculate-lisp-indent-last-sexp 0 t))) - ;; Indent under the list or under the first sexp on the same - ;; line as calculate-lisp-indent-last-sexp. Note that first - ;; thing on that line has to be complete sexp since we are - ;; inside the innermost containing sexp. - (backward-prefix-chars) - (current-column)) - (let ((function (buffer-substring (point) - (progn (forward-sexp 1) (point)))) - method) - (setq method (or (get (intern-soft function) 'lisp-indent-function) - (get (intern-soft function) 'lisp-indent-hook))) - (cond ((or (eq method 'defun) - (and (null method) - (> (length function) 3) - (string-match "\\`def" function))) - (lisp-indent-defform state indent-point)) - ((integerp method) - (lisp-indent-specform method state - indent-point normal-indent)) - (method - (funcall method state indent-point))))))) - -(defconst lisp-body-indent 2 - "Number of columns to indent the second line of a `(def...)' form.") - -(defun lisp-indent-specform (count state indent-point normal-indent) - (let ((containing-form-start (elt state 1)) - (i count) - body-indent containing-form-column) - ;; Move to the start of containing form, calculate indentation - ;; to use for non-distinguished forms (> count), and move past the - ;; function symbol. lisp-indent-function guarantees that there is at - ;; least one word or symbol character following open paren of containing - ;; form. - (goto-char containing-form-start) - (setq containing-form-column (current-column)) - (setq body-indent (+ lisp-body-indent containing-form-column)) - (forward-char 1) - (forward-sexp 1) - ;; Now find the start of the last form. - (parse-partial-sexp (point) indent-point 1 t) - (while (and (< (point) indent-point) - (condition-case () - (progn - (setq count (1- count)) - (forward-sexp 1) - (parse-partial-sexp (point) indent-point 1 t)) - (error nil)))) - ;; Point is sitting on first character of last (or count) sexp. - (if (> count 0) - ;; A distinguished form. If it is the first or second form use double - ;; lisp-body-indent, else normal indent. With lisp-body-indent bound - ;; to 2 (the default), this just happens to work the same with if as - ;; the older code, but it makes unwind-protect, condition-case, - ;; with-output-to-temp-buffer, et. al. much more tasteful. The older, - ;; less hacked, behavior can be obtained by replacing below with - ;; (list normal-indent containing-form-start). - (if (<= (- i count) 1) - (list (+ containing-form-column (* 2 lisp-body-indent)) - containing-form-start) - (list normal-indent containing-form-start)) - ;; A non-distinguished form. Use body-indent if there are no - ;; distinguished forms and this is the first undistinguished form, - ;; or if this is the first undistinguished form and the preceding - ;; distinguished form has indentation at least as great as body-indent. - (if (or (and (= i 0) (= count 0)) - (and (= count 0) (<= body-indent normal-indent))) - body-indent - normal-indent)))) - -(defun lisp-indent-defform (state indent-point) - (goto-char (car (cdr state))) - (forward-line 1) - (if (> (point) (car (cdr (cdr state)))) - (progn - (goto-char (car (cdr state))) - (+ lisp-body-indent (current-column))))) - - -;; (put 'progn 'lisp-indent-function 0), say, causes progn to be indented -;; like defun if the first form is placed on the next line, otherwise -;; it is indented like any other form (i.e. forms line up under first). - -(put 'lambda 'lisp-indent-function 'defun) -(put 'autoload 'lisp-indent-function 'defun) -(put 'progn 'lisp-indent-function 0) -(put 'prog1 'lisp-indent-function 1) -(put 'prog2 'lisp-indent-function 2) -(put 'save-excursion 'lisp-indent-function 0) -(put 'save-window-excursion 'lisp-indent-function 0) -(put 'save-selected-window 'lisp-indent-function 0) -(put 'save-restriction 'lisp-indent-function 0) -(put 'save-match-data 'lisp-indent-function 0) -(put 'let 'lisp-indent-function 1) -(put 'let* 'lisp-indent-function 1) -(put 'while 'lisp-indent-function 1) -(put 'if 'lisp-indent-function 2) -(put 'catch 'lisp-indent-function 1) -(put 'condition-case 'lisp-indent-function 2) -(put 'unwind-protect 'lisp-indent-function 1) -(put 'save-current-buffer 'lisp-indent-function 0) -(put 'with-current-buffer 'lisp-indent-function 1) -(put 'with-temp-file 'lisp-indent-function 1) -(put 'with-temp-buffer 'lisp-indent-function 0) -(put 'with-output-to-string 'lisp-indent-function 0) -(put 'with-output-to-temp-buffer 'lisp-indent-function 1) -(put 'display-message 'lisp-indent-function 1) -(put 'display-warning 'lisp-indent-function 1) -(put 'global-set-key 'lisp-indent-function 1) - -(defun indent-sexp (&optional endpos) - "Indent each line of the list starting just after point. -If optional arg ENDPOS is given, indent each line, stopping when -ENDPOS is encountered." - (interactive) - (let ((indent-stack (list nil)) - (next-depth 0) - ;; If ENDPOS is non-nil, use nil as STARTING-POINT - ;; so that calculate-lisp-indent will find the beginning of - ;; the defun we are in. - ;; If ENDPOS is nil, it is safe not to scan before point - ;; since every line we indent is more deeply nested than point is. - (starting-point (if endpos nil (point))) - (last-point (point)) - last-depth bol outer-loop-done inner-loop-done state this-indent) - (or endpos - ;; Get error now if we don't have a complete sexp after point. - (save-excursion (forward-sexp 1))) - (save-excursion - (setq outer-loop-done nil) - (while (if endpos (< (point) endpos) - (not outer-loop-done)) - (setq last-depth next-depth - inner-loop-done nil) - ;; Parse this line so we can learn the state - ;; to indent the next line. - ;; This inner loop goes through only once - ;; unless a line ends inside a string. - (while (and (not inner-loop-done) - (not (setq outer-loop-done (eobp)))) - (setq state (parse-partial-sexp (point) (progn (end-of-line) (point)) - nil nil state)) - (setq next-depth (car state)) - ;; If the line contains a comment other than the sort - ;; that is indented like code, - ;; indent it now with indent-for-comment. - ;; Comments indented like code are right already. - ;; In any case clear the in-comment flag in the state - ;; because parse-partial-sexp never sees the newlines. - (if (car (nthcdr 4 state)) - (progn (indent-for-comment) - (end-of-line) - (setcar (nthcdr 4 state) nil))) - ;; If this line ends inside a string, - ;; go straight to next line, remaining within the inner loop, - ;; and turn off the \-flag. - (if (car (nthcdr 3 state)) - (progn - (forward-line 1) - (setcar (nthcdr 5 state) nil)) - (setq inner-loop-done t))) - (and endpos - (<= next-depth 0) - (progn - (setq indent-stack (append indent-stack - (make-list (- next-depth) nil)) - last-depth (- last-depth next-depth) - next-depth 0))) - (or outer-loop-done endpos - (setq outer-loop-done (<= next-depth 0))) - (if outer-loop-done - (forward-line 1) - (while (> last-depth next-depth) - (setq indent-stack (cdr indent-stack) - last-depth (1- last-depth))) - (while (< last-depth next-depth) - (setq indent-stack (cons nil indent-stack) - last-depth (1+ last-depth))) - ;; Now go to the next line and indent it according - ;; to what we learned from parsing the previous one. - (forward-line 1) - (setq bol (point)) - (skip-chars-forward " \t") - ;; But not if the line is blank, or just a comment - ;; (except for double-semi comments; indent them as usual). - (if (or (eobp) (looking-at "\\s<\\|\n")) - nil - (if (and (car indent-stack) - (>= (car indent-stack) 0)) - (setq this-indent (car indent-stack)) - (let ((val (calculate-lisp-indent - (if (car indent-stack) (- (car indent-stack)) - starting-point)))) - (if (integerp val) - (setcar indent-stack - (setq this-indent val)) - (setcar indent-stack (- (car (cdr val)))) - (setq this-indent (car val))))) - (if (/= (current-column) this-indent) - (progn (delete-region bol (point)) - (indent-to this-indent))))) - (or outer-loop-done - (setq outer-loop-done (= (point) last-point)) - (setq last-point (point))))))) - -;; Indent every line whose first char is between START and END inclusive. -(defun lisp-indent-region (start end) - (save-excursion - (let ((endmark (copy-marker end))) - (goto-char start) - (and (bolp) (not (eolp)) - (lisp-indent-line)) - (indent-sexp endmark) - (set-marker endmark nil)))) - -;;;; Lisp paragraph filling commands. - -(defun lisp-fill-paragraph (&optional justify) - "Like \\[fill-paragraph], but handle Emacs Lisp comments. -If any of the current line is a comment, fill the comment or the -paragraph of it that point is in, preserving the comment's indentation -and initial semicolons." - (interactive "P") - (let ( - ;; Non-nil if the current line contains a comment. - has-comment - - ;; Non-nil if the current line contains code and a comment. - has-code-and-comment - - ;; If has-comment, the appropriate fill-prefix for the comment. - comment-fill-prefix - ) - - ;; Figure out what kind of comment we are looking at. - (save-excursion - (beginning-of-line) - (cond - - ;; A line with nothing but a comment on it? - ((looking-at "[ \t]*;[; \t]*") - (setq has-comment t - comment-fill-prefix (buffer-substring (match-beginning 0) - (match-end 0)))) - - ;; A line with some code, followed by a comment? Remember that the - ;; semi which starts the comment shouldn't be part of a string or - ;; character. - ;; XEmacs Try this the FSF and see if it works. -; ((progn -; (while (not (looking-at ";\\|$")) -; (skip-chars-forward "^;\n\"\\\\?") -; (cond -; ((eq (char-after (point)) ?\\) (forward-char 2)) -; ((memq (char-after (point)) '(?\" ??)) (forward-sexp 1)))) -; (looking-at ";+[\t ]*")) -; (setq has-comment t) - ((condition-case nil - (save-restriction - (narrow-to-region (point-min) - (save-excursion (end-of-line) (point))) - (while (not (looking-at ";\\|$")) - (skip-chars-forward "^;\n\"\\\\?") - (cond - ((eq (char-after (point)) ?\\) (forward-char 2)) - ((memq (char-after (point)) '(?\" ??)) (forward-sexp 1)))) - (looking-at ";+[\t ]*")) - (error nil)) - (setq has-comment t has-code-and-comment t) - (setq comment-fill-prefix - (concat (make-string (/ (current-column) 8) ?\t) - (make-string (% (current-column) 8) ?\ ) - (buffer-substring (match-beginning 0) (match-end 0))))))) - - (if (not has-comment) - (fill-paragraph justify) - - ;; Narrow to include only the comment, and then fill the region. - (save-excursion - (save-restriction - (beginning-of-line) - (narrow-to-region - ;; Find the first line we should include in the region to fill. - (save-excursion - (while (and (zerop (forward-line -1)) - (looking-at "^[ \t]*;"))) - ;; We may have gone too far. Go forward again. - (or (looking-at ".*;") - (forward-line 1)) - (point)) - ;; Find the beginning of the first line past the region to fill. - (save-excursion - (while (progn (forward-line 1) - (looking-at "^[ \t]*;"))) - (point))) - - ;; Lines with only semicolons on them can be paragraph boundaries. - (let* ((paragraph-start (concat paragraph-start "\\|[ \t;]*$")) - (paragraph-separate (concat paragraph-start "\\|[ \t;]*$")) - (paragraph-ignore-fill-prefix nil) - (fill-prefix comment-fill-prefix) - (after-line (if has-code-and-comment - (save-excursion - (forward-line 1) (point)))) - (end (progn - (forward-paragraph) - (or (bolp) (newline 1)) - (point))) - ;; If this comment starts on a line with code, - ;; include that like in the filling. - (beg (progn (backward-paragraph) - (if (eq (point) after-line) - (forward-line -1)) - (point)))) - (fill-region-as-paragraph beg end - justify nil - (save-excursion - (goto-char beg) - (if (looking-at fill-prefix) - nil - (re-search-forward comment-start-skip) - (point)))))))) - t)) - -(defun indent-code-rigidly (start end arg &optional nochange-regexp) - "Indent all lines of code, starting in the region, sideways by ARG columns. -Does not affect lines starting inside comments or strings, assuming that -the start of the region is not inside them. - -Called from a program, takes args START, END, COLUMNS and NOCHANGE-REGEXP. -The last is a regexp which, if matched at the beginning of a line, -means don't indent that line." - (interactive "r\np") - (let (state) - (save-excursion - (goto-char end) - (setq end (point-marker)) - (goto-char start) - (or (bolp) - (setq state (parse-partial-sexp (point) - (progn - (forward-line 1) (point)) - nil nil state))) - (while (< (point) end) - (or (car (nthcdr 3 state)) - (and nochange-regexp - (looking-at nochange-regexp)) - ;; If line does not start in string, indent it - (let ((indent (current-indentation))) - (delete-region (point) (progn (skip-chars-forward " \t") (point))) - (or (eolp) - (indent-to (max 0 (+ indent arg)) 0)))) - (setq state (parse-partial-sexp (point) - (progn - (forward-line 1) (point)) - nil nil state)))))) - -(provide 'lisp-mode) - -;;; lisp-mode.el ends here
--- a/lisp/modes/list-mode.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,565 +0,0 @@ -;;; list-mode.el -;; Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc. -;; Copyright (C) 1996 Ben Wing. - -;; 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. - -;; Cleanup, merging with FSF by Ben Wing, January 1996 - -(defvar list-mode-extent nil) -(make-variable-buffer-local 'list-mode-extent) - -(defvar list-mode-map nil - "Local map for buffers containing lists of items.") -(or list-mode-map - (let ((map (setq list-mode-map (make-sparse-keymap 'list-mode-map)))) - (suppress-keymap map) - (define-key map 'button2up 'list-mode-item-mouse-selected) - (define-key map 'button2 'undefined) - (define-key map "\C-m" 'list-mode-item-keyboard-selected) - (substitute-key-definition 'forward-char 'next-list-mode-item map - global-map) - (substitute-key-definition 'backward-char 'previous-list-mode-item map - global-map))) - -(defun list-mode () - "Major mode for buffer containing lists of items." - (interactive) - (kill-all-local-variables) - (use-local-map list-mode-map) - (setq mode-name "List") - (setq major-mode 'list-mode) - (make-local-hook 'post-command-hook) - (add-hook 'post-command-hook 'set-list-mode-extent nil t) - (make-local-hook 'pre-command-hook) - (add-hook 'pre-command-hook 'list-mode-extent-pre-hook nil t) - (make-local-variable 'next-line-add-newlines) - (setq next-line-add-newlines nil) - (setq list-mode-extent nil) - (set-specifier text-cursor-visible-p nil (current-buffer)) - (setq buffer-read-only t) - (goto-char (point-min)) - (run-hooks 'list-mode-hook)) - -;; List mode is suitable only for specially formatted data. -(put 'list-mode 'mode-class 'special) - -(defvar list-mode-extent-old-point nil - "The value of point when pre-command-hook is called. -Used to determine the direction of motion.") -(make-variable-buffer-local 'list-mode-extent-old-point) - -(defun list-mode-extent-pre-hook () - (setq list-mode-extent-old-point (point)) - ;(setq atomic-extent-goto-char-p nil) -) - -(defun set-list-mode-extent () - "Move to the closest list item and set up the extent for it. -This is called from `post-command-hook'." - (cond ((get-char-property (point) 'list-mode-item)) - ((and (> (point) (point-min)) - (get-char-property (1- (point)) 'list-mode-item)) - (goto-char (1- (point)))) - (t - (let ((pos (point)) - dirflag) - ;this fucks things up more than it helps. - ;atomic-extent-goto-char-p as currently defined is all broken, - ;since it will be triggered if the command *ever* runs goto-char! - ;(if atomic-extent-goto-char-p - ; (setq dirflag 1) - (if (and list-mode-extent-old-point - (> pos list-mode-extent-old-point)) - (setq dirflag 1) - (setq dirflag -1)) - (next-list-mode-item dirflag) - (or (get-char-property (point) 'list-mode-item) - (next-list-mode-item (- dirflag)))))) - (or (and list-mode-extent - (eq (current-buffer) (extent-object list-mode-extent))) - (progn - (setq list-mode-extent (make-extent nil nil (current-buffer))) - (set-extent-face list-mode-extent 'list-mode-item-selected))) - (let ((ex (extent-at (point) nil 'list-mode-item nil 'at))) - (if ex - (progn - (set-extent-endpoints list-mode-extent - (extent-start-position ex) - (extent-end-position ex)) - (auto-show-make-region-visible (extent-start-position ex) - (extent-end-position ex))) - (detach-extent list-mode-extent)))) - -(defun previous-list-mode-item (n) - "Move to the previous item in list-mode." - (interactive "p") - (next-list-mode-item (- n))) - -(defun next-list-mode-item (n) - "Move to the next item in list-mode. -With prefix argument N, move N items (negative N means move backward)." - (interactive "p") - (while (and (> n 0) (not (eobp))) - (let ((prop (get-char-property (point) 'list-mode-item)) - (end (point-max))) - ;; If in a completion, move to the end of it. - (if prop - (goto-char (next-single-property-change (point) 'list-mode-item - nil end))) - ;; Move to start of next one. - (goto-char (next-single-property-change (point) - 'list-mode-item nil end))) - (setq n (1- n))) - (while (and (< n 0) (not (bobp))) - (let ((prop (get-char-property (1- (point)) 'list-mode-item)) - (end (point-min))) - ;; If in a completion, move to the start of it. - (if prop - (goto-char (previous-single-property-change - (point) 'list-mode-item nil end))) - ;; Move to end of the previous completion. - (goto-char (previous-single-property-change (point) 'list-mode-item - nil end)) - ;; Move to the start of that one. - (goto-char (previous-single-property-change (point) 'list-mode-item nil - end))) - (setq n (1+ n)))) - -(defun list-mode-item-selected-1 (extent event) - (let ((func (extent-property extent 'list-mode-item-activate-callback)) - (user-data (extent-property extent 'list-mode-item-user-data))) - (if func - (funcall func event extent user-data)))) - -;; we could make these two be just one function, but we want to be -;; able to refer to them in DOC strings. - -(defun list-mode-item-keyboard-selected () - (interactive) - (list-mode-item-selected-1 (extent-at (point) (current-buffer) - 'list-mode-item nil 'at) - nil)) - -(defun list-mode-item-mouse-selected (event) - (interactive "e") - ;; Sometimes event-closest-point returns nil. - ;; So beep instead of bombing. - (let ((point (event-closest-point event))) - (if point - (list-mode-item-selected-1 (extent-at point - (event-buffer event) - 'list-mode-item nil 'at) - event) - (ding)))) - -(defun add-list-mode-item (start end &optional buffer activate-callback - user-data) - "Add a new list item in list-mode, from START to END in BUFFER. -BUFFER defaults to the current buffer. -This works by creating an extent for the span of text in question. -If ACTIVATE-CALLBACK is non-nil, it should be a function of three - arguments (EVENT EXTENT USER-DATA) that will be called when button2 - is pressed on the extent. USER-DATA comes from the optional - USER-DATA argument." - (let ((extent (make-extent start end buffer))) - (set-extent-property extent 'list-mode-item t) - (set-extent-property extent 'start-open t) - (if activate-callback - (progn - (set-extent-property extent 'mouse-face 'highlight) - (set-extent-property extent 'list-mode-item-activate-callback - activate-callback) - (set-extent-property extent 'list-mode-item-user-data user-data))) - extent)) - - -;; Define the major mode for lists of completions. - - -(defvar completion-highlight-first-word-only nil - "*Completion will only highlight the first blank delimited word if t. -If the variable in not t or nil, the string is taken as a regexp to match for end -of highlight") - -(defvar completion-setup-hook nil - "Normal hook run at the end of setting up the text of a completion buffer.") - -; Unnecessary FSFmacs crock. We frob the extents directly in -; display-completion-list, so no "heuristics" like this are necessary. -;(defvar completion-fixup-function nil -; "A function to customize how completions are identified in completion lists. -;`completion-setup-function' calls this function with no arguments -;each time it has found what it thinks is one completion. -;Point is at the end of the completion in the completion list buffer. -;If this function moves point, it can alter the end of that completion.") - -(defvar completion-default-help-string - '(concat - (if (device-on-window-system-p) - (substitute-command-keys - "Click \\<list-mode-map>\\[list-mode-item-mouse-selected] on a completion to select it.\n") "") - (substitute-command-keys - "Type \\<minibuffer-local-completion-map>\\[advertised-switch-to-completions] or \\[switch-to-completions] to move to this buffer, for keyboard selection.\n\n")) - "Form the evaluate to get a help string for completion lists. -This string is inserted at the beginning of the buffer. -See `display-completion-list'.") - -(defun display-completion-list (completions &rest cl-keys) - "Display the list of completions, COMPLETIONS, using `standard-output'. -Each element may be just a symbol or string or may be a list of two - strings to be printed as if concatenated. -Frob a mousable extent onto each completion. This extent has properties - 'mouse-face (so it highlights when the mouse passes over it) and - 'list-mode-item (so it can be located). - -Keywords: - :activate-callback (default is `default-choose-completion') - See `add-list-mode-item'. - :user-data - Value passed to activation callback. - :window-width - If non-nil, width to use in displaying the list, instead of the - actual window's width. - :help-string (default is the value of `completion-default-help-string') - Form to evaluate to get a string to insert at the beginning of - the completion list buffer. This is evaluated when that buffer - is the current buffer and after it has been put into - completion-list-mode. - :reference-buffer (default is the current buffer) - This specifies the value of `completion-reference-buffer' in - the completion buffer. This specifies the buffer (normally a - minibuffer) that `default-choose-completion' will insert the - completion into. - -At the end, run the normal hook `completion-setup-hook'. -It can find the completion buffer in `standard-output'. -If `completion-highlight-first-word-only' is non-nil, then only the start - of the string is highlighted." - ;; #### I18N3 should set standard-output to be (temporarily) - ;; output-translating. - (cl-parsing-keywords - ((:activate-callback 'default-choose-completion) - :user-data - :reference-buffer - (:help-string completion-default-help-string) - :window-width) - () - (let ((old-buffer (current-buffer)) - (bufferp (bufferp standard-output))) - (if bufferp - (set-buffer standard-output)) - (if (null completions) - (princ (gettext - "There are no possible completions of what you have typed.")) - (let ((win-width - (or cl-window-width - (if bufferp - ;; This needs fixing for the case of windows - ;; that aren't the same width's the frame. - ;; Sadly, the window it will appear in is not known - ;; until after the text has been made. - - ;; We have to use last-nonminibuf-frame here - ;; and not selected-frame because if a - ;; minibuffer-only frame is being used it will - ;; be the selected-frame at the point this is - ;; run. We keep the selected-frame call around - ;; just in case. - (frame-width (or (last-nonminibuf-frame) - (selected-frame))) - 80)))) - (let ((count 0) - (max-width 0)) - ;; Find longest completion - (let ((tail completions)) - (while tail - (let* ((elt (car tail)) - (len (cond ((stringp elt) - (length elt)) - ((and (consp elt) - (stringp (car elt)) - (stringp (car (cdr elt)))) - (+ (length (car elt)) - (length (car (cdr elt))))) - (t - (signal 'wrong-type-argument - (list 'stringp elt)))))) - (if (> len max-width) - (setq max-width len)) - (setq count (1+ count) - tail (cdr tail))))) - - (setq max-width (+ 2 max-width)) ; at least two chars between cols - (let ((rows (let ((cols (min (/ win-width max-width) count))) - (if (<= cols 1) - count - (progn - ;; re-space the columns - (setq max-width (/ win-width cols)) - (if (/= (% count cols) 0) ; want ceiling... - (1+ (/ count cols)) - (/ count cols))))))) - (princ (gettext "Possible completions are:")) - (let ((tail completions) - (r 0) - (regexp-string - (if (eq t - completion-highlight-first-word-only) - "[ \t]" - completion-highlight-first-word-only))) - (while (< r rows) - (terpri) - (let ((indent 0) - (column 0) - (tail2 tail)) - (while tail2 - (let ((elt (car tail2))) - (if (/= indent 0) - (if bufferp - (indent-to indent 2) - (while (progn (write-char ?\ ) - (setq column (1+ column)) - (< column indent))))) - (setq indent (+ indent max-width)) - (let ((start (point)) - end) - ;; Frob some mousable extents in there too! - (if (consp elt) - (progn - (princ (car elt)) - (princ (car (cdr elt))) - (or bufferp - (setq column - (+ column - (length (car elt)) - (length (car (cdr elt))))))) - (progn - (princ elt) - (or bufferp - (setq column (+ column (length - elt)))))) - (add-list-mode-item - start - (progn - (setq end (point)) - (or - (and completion-highlight-first-word-only - (goto-char start) - (re-search-forward regexp-string end t) - (match-beginning 0)) - end)) - nil cl-activate-callback cl-user-data) - (goto-char end))) - (setq tail2 (nthcdr rows tail2))) - (setq tail (cdr tail) - r (1+ r))))))))) - (if bufferp - (set-buffer old-buffer))) - (save-excursion - (let ((mainbuf (or cl-reference-buffer (current-buffer)))) - (set-buffer standard-output) - (completion-list-mode) - (make-local-variable 'completion-reference-buffer) - (setq completion-reference-buffer mainbuf) -;;; The value 0 is right in most cases, but not for file name completion. -;;; so this has to be turned off. -;;; (setq completion-base-size 0) - (goto-char (point-min)) - (let ((buffer-read-only nil)) - (insert (eval cl-help-string))) - ;; unnecessary FSFmacs crock - ;;(forward-line 1) - ;;(while (re-search-forward "[^ \t\n]+\\( [^ \t\n]+\\)*" nil t) - ;; (let ((beg (match-beginning 0)) - ;; (end (point))) - ;; (if completion-fixup-function - ;; (funcall completion-fixup-function)) - ;; (put-text-property beg (point) 'mouse-face 'highlight) - ;; (put-text-property beg (point) 'list-mode-item t) - ;; (goto-char end))))) - )) - (run-hooks 'completion-setup-hook))) - -(defvar completion-display-completion-list-function 'display-completion-list - "Function to set up the list of completions in the completion buffer. -The function is called with one argument, the sorted list of completions. -Particular minibuffer interface functions (e.g. `read-file-name') may -want to change this. To do that, set a local value for this variable -in the minibuffer; that ensures that other minibuffer invocations will -not be affected.") - -(defun minibuffer-completion-help () - "Display a list of possible completions of the current minibuffer contents. -The list of completions is determined by calling `all-completions', -passing it the current minibuffer contents, the value of -`minibuffer-completion-table', and the value of -`minibuffer-completion-predicate'. The list is displayed by calling -the value of `completion-display-completion-list-function' on the sorted -list of completions, with the standard output set to the completion -buffer." - (interactive) - (message "Making completion list...") - (let ((completions (all-completions (buffer-string) - minibuffer-completion-table - minibuffer-completion-predicate))) - (message nil) - (if (null completions) - (progn - (ding nil 'no-completion) - (temp-minibuffer-message " [No completions]")) - (with-output-to-temp-buffer "*Completions*" - (funcall completion-display-completion-list-function - (sort completions #'string-lessp)))))) - -(define-derived-mode completion-list-mode list-mode - "Completion List" - "Major mode for buffers showing lists of possible completions. -Type \\<completion-list-mode-map>\\[choose-completion] in the completion list\ - to select the completion near point. -Use \\<completion-list-mode-map>\\[mouse-choose-completion] to select one\ - with the mouse." - (make-local-variable 'completion-base-size) - (setq completion-base-size nil)) - -(let ((map completion-list-mode-map)) - (define-key map "\e\e\e" 'delete-completion-window) - (define-key map "\C-g" 'minibuffer-keyboard-quit) - (define-key map "q" 'abort-recursive-edit) - (define-key map " " (lambda () (interactive) - (select-window (minibuffer-window)))) - (define-key map "\t" (lambda () (interactive) - (select-window (minibuffer-window))))) - -(defvar completion-reference-buffer nil - "Record the buffer that was current when the completion list was requested. -This is a local variable in the completion list buffer. -Initial value is nil to avoid some compiler warnings.") - -(defvar completion-base-size nil - "Number of chars at beginning of minibuffer not involved in completion. -This is a local variable in the completion list buffer -but it talks about the buffer in `completion-reference-buffer'. -If this is nil, it means to compare text to determine which part -of the tail end of the buffer's text is involved in completion.") - -(defun delete-completion-window () - "Delete the completion list window. -Go to the window from which completion was requested." - (interactive) - (let ((buf completion-reference-buffer)) - (delete-window (selected-window)) - (if (get-buffer-window buf) - (select-window (get-buffer-window buf))))) - -(defun completion-do-in-minibuffer () - (interactive "_") - (save-excursion - (set-buffer (window-buffer (minibuffer-window))) - (call-interactively (key-binding (this-command-keys))))) - -(defun default-choose-completion (event extent buffer) - "Click on an alternative in the `*Completions*' buffer to choose it." - (and (button-event-p event) - ;; Give temporary modes such as isearch a chance to turn off. - (run-hooks 'mouse-leave-buffer-hook)) - (or buffer (setq buffer (symbol-value-in-buffer - 'completion-reference-buffer - (or (and (button-event-p event) - (event-buffer event)) - (current-buffer))))) - (save-selected-window - (and (button-event-p event) - (select-window (event-window event))) - (if (and (one-window-p t 'selected-frame) - (window-dedicated-p (selected-window))) - ;; This is a special buffer's frame - (iconify-frame (selected-frame)) - (or (window-dedicated-p (selected-window)) - (bury-buffer)))) - (choose-completion-string (extent-string extent) - buffer - completion-base-size)) - -;; Delete the longest partial match for STRING -;; that can be found before POINT. -(defun choose-completion-delete-max-match (string) - (let ((len (min (length string) - (- (point) (point-min))))) - (goto-char (- (point) (length string))) - (if completion-ignore-case - (setq string (downcase string))) - (while (and (> len 0) - (let ((tail (buffer-substring (point) - (+ (point) len)))) - (if completion-ignore-case - (setq tail (downcase tail))) - (not (string= tail (substring string 0 len))))) - (setq len (1- len)) - (forward-char 1)) - (delete-char len))) - -;; Switch to BUFFER and insert the completion choice CHOICE. -;; BASE-SIZE, if non-nil, says how many characters of BUFFER's text -;; to keep. If it is nil, use choose-completion-delete-max-match instead. -(defun choose-completion-string (choice &optional buffer base-size) - (let ((buffer (or buffer completion-reference-buffer))) - ;; If BUFFER is a minibuffer, barf unless it's the currently - ;; active minibuffer. - (if (and (string-match "\\` \\*Minibuf-[0-9]+\\*\\'" (buffer-name buffer)) - (or (not (active-minibuffer-window)) - (not (equal buffer - (window-buffer (active-minibuffer-window)))))) - (error "Minibuffer is not active for completion") - ;; Insert the completion into the buffer where completion was requested. - (set-buffer buffer) - (if base-size - (delete-region (+ base-size (point-min)) (point)) - (choose-completion-delete-max-match choice)) - (insert choice) - (remove-text-properties (- (point) (length choice)) (point) - '(highlight nil)) - ;; Update point in the window that BUFFER is showing in. - (let ((window (get-buffer-window buffer t))) - (set-window-point window (point))) - ;; If completing for the minibuffer, exit it with this choice. - (and (equal buffer (window-buffer (minibuffer-window))) - minibuffer-completion-table - (exit-minibuffer))))) - -(define-key minibuffer-local-completion-map [prior] - 'switch-to-completions) -(define-key minibuffer-local-must-match-map [prior] - 'switch-to-completions) -(define-key minibuffer-local-completion-map "\M-v" - 'advertised-switch-to-completions) -(define-key minibuffer-local-must-match-map "\M-v" - 'advertised-switch-to-completions) - -(defalias 'advertised-switch-to-completions 'switch-to-completions) -(defun switch-to-completions () - "Select the completion list window." - (interactive) - ;; Make sure we have a completions window. - (or (get-buffer-window "*Completions*") - (minibuffer-completion-help)) - (if (not (get-buffer-window "*Completions*")) - nil - (select-window (get-buffer-window "*Completions*")) - (goto-char (next-single-property-change (point-min) 'list-mode-item nil - (point-max)))))
--- a/lisp/modes/m4-mode.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,209 +0,0 @@ -;;; m4-mode.el --- m4 code editing commands for Emacs - -;; Author: Andrew Csillag (drew@staff.prodigy.com) -;; Maintainer: Andrew Csillag (drew@staff.prodigy.com) -;; Keywords: languages, faces - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; A smart editing mode for m4 macro definitions. It seems to have most of the -;; syntax right (sexp motion commands work, but function motion commands don't). -;; It also sets the font-lock syntax stuff for colorization - -;; By Drew Csillag (drew@staff.prodigy.com) -;; $Id: m4-mode.el,v 1.4 1997/05/23 01:36:24 steve Exp $ - -;; History: - -;; Date Version Who Action -;; -------- ------- --- ---- -;; 09/13/96 1.0 DC Created -;; 09/26/96 1.1 DC added syntax table stuff so now matches `'s -;; now can use C-c C-b to m4 on buffer,C-c C-r for region -;; added m4-comment-region (C-c C-c) -;; 09/27/96 1.2 DC Redid header comment -;; 1.3 DC more cosmetic fixes -;; 1.4 DC removed m4-comment-region, using comment-region instead -;; 10/03/96 DC added provide line -;; 10/24/96 1.5 DC fixed keyword regexp -;; 10/29/96 1.6 DC added m4_keywords for --prefix-builtins -;; fixed syntax table so _define_ isn't keywordified -;; 10/29/96 1.8 DC fixed a problem where comments go fontified incorrectly -;; if they had quotes in them -;; 11/21/96 1.9 DC collapsed 4 regexps into 1 and removed a duplicate, -;; removed a duplicate backslash -;; 05/16/97 1.10 DC added contributed fixes and enhancements from -;; Martin Buchholz -;; Can now specify options to m4 via m4-program-options -;; Now terminates m4 processes when the buffer send -is -;; done -;; dnl and m4_dnl recognized as comment starters - -;; To Do's: - -;; * want to make m4-m4-(buffer|region) look sorta like M-x compile look&feel ? -;; * sexp motion commands don't seem to work right - -;; to autoload m4 lisp code: -;; (autoload 'm4-mode "m4-mode" nil t) -;; -;; or can use (load "m4-mode") or (require 'm4-mode) to just load it -;; -;; to try to "auto-detect" m4 files: -;; (setq auto-mode-alist -;; (cons '(".*\\.m4$" . m4-mode) -;; auto-mode-alist)) - -;;; Thanks: -;;; to Akim Demaille and Terry Jones for the bug reports -;;; to Simon Marshall for the regexp tip -;;; to Martin Buchholz for some general fixes - -;;; Code: - -;;path to the m4 program -(defvar m4-program - (cond - ((file-exists-p "/usr/local/bin/m4") "/usr/local/bin/m4") - ((file-exists-p "/usr/bin/m4") "/usr/bin/m4") - ((file-exists-p "/bin/m4") "/bin/m4") - ((file-exists-p "/usr/ccs/bin/m4") "/usr/ccs/bin/m4") - ) -) - -;;options to m4 -(defconst m4-program-options nil) -;;to use --prefix-builtins, you can use -;;(defconst m4-program-options '("-P")) -;;or -;;(defconst m4-program-options '("--prefix-builtins")) - -;;thank god for make-regexp.el! -(defvar m4-font-lock-keywords - `( - ("\\(\\bdnl\\b\\|\\bm4_dnl\\b\\|^\\#\\).*$" . -font-lock-comment-face) - ("\\$[*#@0-9]" . font-lock-variable-name-face) - -("\\b\\(builtin\\|change\\(com\\|quote\\|word\\)\\|d\\(e\\(bug\\(file\\|mode\\)\\|cr\\|f\\(ine\\|n\\)\\)\\|iv\\(ert\\|num\\)\\|nl\\|umpdef\\)\\|e\\(rrprint\\|syscmd\\|val\\)\\|f\\(ile\\|ormat\\)\\|gnu\\|i\\(f\\(def\\|else\\)\\|n\\(c\\(lude\\|r\\)\\|d\\(ex\\|ir\\)\\)\\)\\|l\\(en\\|ine\\)\\|m\\(4\\(exit\\|wrap\\)\\|aketemp\\)\\|p\\(atsubst\\|opdef\\|ushdef\\)\\|regexp\\|s\\(hift\\|include\\|ubstr\\|ys\\(cmd\\|val\\)\\)\\|tra\\(ceo\\(ff\\|n\\)\\|nslit\\)\\|un\\(d\\(efine\\|ivert\\)\\|ix\\)\\)\\b" -. font-lock-keyword-face) - -("\\b\\(m4_\\(builtin\\|change\\(com\\|quote\\|word\\)\\|d\\(e\\(bug\\(file\\|mode\\)\\|cr\\|f\\(ine\\|n\\)\\)\\|iv\\(ert\\|num\\)\\|nl\\|umpdef\\)\\|e\\(rrprint\\|syscmd\\|val\\)\\|f\\(ile\\|ormat\\)\\|i\\(f\\(def\\|else\\)\\|n\\(c\\(lude\\|r\\)\\|d\\(ex\\|ir\\)\\)\\)\\|l\\(en\\|ine\\)\\|m\\(4\\(_undefine\\|exit\\|wrap\\)\\|aketemp\\)\\|p\\(atsubst\\|opdef\\|ushdef\\)\\|regexp\\|s\\(hift\\|include\\|ubstr\\|ys\\(cmd\\|val\\)\\)\\|tra\\(ceo\\(ff\\|n\\)\\|nslit\\)\\|undivert\\)\\)\\b" -. font-lock-keyword-face) - "default font-lock-keywords") -) - -;;this may still need some work -(defvar m4-mode-syntax-table nil - "syntax table used in m4 mode") -(setq m4-mode-syntax-table (make-syntax-table)) -(modify-syntax-entry ?` "('" m4-mode-syntax-table) -(modify-syntax-entry ?' ")`" m4-mode-syntax-table) -(modify-syntax-entry ?# "<\n" m4-mode-syntax-table) -(modify-syntax-entry ?\n ">#" m4-mode-syntax-table) -(modify-syntax-entry ?{ "_" m4-mode-syntax-table) -(modify-syntax-entry ?} "_" m4-mode-syntax-table) -(modify-syntax-entry ?* "." m4-mode-syntax-table) -(modify-syntax-entry ?_ "_" m4-mode-syntax-table) -(modify-syntax-entry ?\" "w" m4-mode-syntax-table) - -(defvar m4-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\C-c\C-b" 'm4-m4-buffer) - (define-key map "\C-c\C-r" 'm4-m4-region) - (define-key map "\C-c\C-c" 'comment-region) - map)) - -(defun m4-end-m4 (process event) - (cond ((equal event "kill\n") (princ "m4 process done")) - (t (princ - (format "Process: %s had the event `%s'" process event))))) - -(defun m4-start-m4 () - (eval (append (append '(start-process "m4process" "*m4 output*" -m4-program) - m4-program-options) '("-e"))) - (set-process-sentinel (get-process "m4process") 'm4-end-m4) -) - -(defun m4-m4-buffer () - "send contents of the current buffer to m4" - (interactive) - (m4-start-m4) - (process-send-region "m4process" (point-min) (point-max)) - (process-send-eof "m4process") - (switch-to-buffer-other-window "*m4 output*") - (delete-process "m4process") -) - - -(defun m4-m4-region () - "send contents of the current region to m4" - (interactive) - (m4-start-m4) - (process-send-region "m4process" (point) (mark)) - (process-send-eof "m4process") - (switch-to-buffer-other-window "*m4 output*") -) - -(defun m4-mode () - "A major-mode to edit m4 macro files -\\{m4-mode-map} -" - (interactive) - (kill-all-local-variables) - (use-local-map m4-mode-map) - - (make-local-variable 'comment-start) - (setq comment-start "#") - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments t) - - - (make-local-variable 'font-lock-defaults) - (setq major-mode 'm4-mode - mode-name "m4" - font-lock-defaults '(m4-font-lock-keywords nil) - ) - (set-syntax-table m4-mode-syntax-table) - (run-hooks 'm4-mode-hook)) - -(provide 'm4-mode) -;;stuff to play with for debugging -;(char-to-string (char-syntax ?`)) - -;;;how I generate the nasty looking regexps at the top -;;;(make-regexp '("builtin" "changecom" "changequote" "changeword" "debugfile" -;;; "debugmode" "decr" "define" "defn" "divert" "divnum" "dnl" -;;; "dumpdef" "errprint" "esyscmd" "eval" "file" "format" "gnu" -;;; "ifdef" "ifelse" "include" "incr" "index" "indir" "len" "line" -;;; "m4exit" "m4wrap" "maketemp" "patsubst" "popdef" "pushdef" "regexp" -;;; "shift" "sinclude" "substr" "syscmd" "sysval" "traceoff" "traceon" -;;; "translit" "undefine" "undivert" "unix")) -;;;(make-regexp '("m4_builtin" "m4_changecom" "m4_changequote" "m4_changeword" -;;; "m4_debugfile" "m4_debugmode" "m4_decr" "m4_define" "m4_defn" -;;; "m4_divert" "m4_divnum" "m4_dnl" "m4_dumpdef" "m4_errprint" -;;; "m4_esyscmd" "m4_eval" "m4_file" "m4_format" "m4_ifdef" "m4_ifelse" -;;; "m4_include" "m4_incr" "m4_index" "m4_indir" "m4_len" "m4_line" -;;; "m4_m4exit" "m4_m4wrap" "m4_maketemp" "m4_patsubst" "m4_popdef" -;;; "m4_pushdef" "m4_regexp" "m4_shift" "m4_sinclude" "m4_substr" -;;; "m4_syscmd" "m4_sysval" "m4_traceoff" "m4_traceon" "m4_translit" -;;; "m4_m4_undefine" "m4_undivert"))
--- a/lisp/modes/sendmail.el Mon Aug 13 10:03:54 2007 +0200 +++ b/lisp/modes/sendmail.el Mon Aug 13 10:04:58 2007 +0200 @@ -513,6 +513,8 @@ (interactive "P") (mail-bury arg)) +(defvar rmail-summary-buffer) + (defun mail-bury (arg) "Bury this mail buffer." (let ((newbuf (other-buffer (current-buffer)))) @@ -859,8 +861,12 @@ (setq mail-do-fcc-cached-timezone (buffer-substring (point-min) (1- (point-max))))))))) -(eval-when-compile - (require 'vm-misc)) +;; Can't do this now that VM is unbundled. +;; The lack of vm-misc is handled in mail-do-fcc-vm-internal. +;;(eval-when-compile +;; (require 'vm-misc)) + +(defvar rmail-total-messages) (defun mail-do-fcc-rmail-internal (buffer) (or (eq major-mode 'rmail-mode) (error "this only works in rmail-mode")) @@ -900,24 +906,30 @@ (forward-line) (delete-region (point-min) (point)))) - ;; Largely copied from #'vm-save-message in vm-save.el - (vm-save-restriction - (widen) - (goto-char (point-max)) - (if foreign-folder-p - (vm-write-string (current-buffer) - (vm-leading-message-separator vm-folder-type))) - (insert-buffer-substring buffer) - (if foreign-folder-p - (vm-write-string (current-buffer) - (vm-trailing-message-separator vm-folder-type))) + ;; Use eval to inhibit compilation of the following code. + ;; The code contains macros, and to compile them a (reuqire + ;; 'vm-misc) is needed. When VM stopped being bundled with + ;; XEmacs, this require call became impossible. + (eval + (quote + ;; Largely copied from #'vm-save-message in vm-save.el + (vm-save-restriction + (widen) + (goto-char (point-max)) + (if foreign-folder-p + (vm-write-string (current-buffer) + (vm-leading-message-separator vm-folder-type))) + (insert-buffer-substring buffer) + (if foreign-folder-p + (vm-write-string (current-buffer) + (vm-trailing-message-separator vm-folder-type))) - (vm-increment vm-messages-not-on-disk) - (vm-set-buffer-modified-p t) - (vm-clear-modification-flag-undos) - (vm-check-for-killed-summary) - (vm-assimilate-new-messages) - (vm-update-summary-and-mode-line)))) + (vm-increment vm-messages-not-on-disk) + (vm-set-buffer-modified-p t) + (vm-clear-modification-flag-undos) + (vm-check-for-killed-summary) + (vm-assimilate-new-messages) + (vm-update-summary-and-mode-line)))))) ;;(defun mail-sent-via () ;; "Make a Sent-via header line from each To or CC header line."
--- a/lisp/modes/sh-script.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1532 +0,0 @@ -;;; sh-script.el --- shell-script editing commands for Emacs - -;; Copyright (C) 1993, 1994, 1995, 1996 by Free Software Foundation, Inc. - -;; Author: Daniel.Pfeiffer@Informatik.START.dbp.de, fax (+49 69) 7588-2389 -;; Version: 2.0e -;; Maintainer: FSF -;; Keywords: languages, unix - -;; 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.34. - -;;; Commentary: - -;; Major mode for editing shell scripts. Bourne, C and rc shells as well -;; as various derivatives are supported and easily derived from. Structured -;; statements can be inserted with one command or abbrev. Completion is -;; available for filenames, variables known from the script, the shell and -;; the environment as well as commands. - -;;; Known Bugs: - -;; - In Bourne the keyword `in' is not anchored to case, for, select ... -;; - Variables in `"' strings aren't fontified because there's no way of -;; syntactically distinguishing those from `'' strings. - -;;; Code: - -;; page 1: variables and settings -;; page 2: mode-command and utility functions -;; page 3: statement syntax-commands for various shells -;; page 4: various other commands - -(require 'executable) - -(defgroup sh nil - "Shell programming mode." - :group 'unix - :group 'languages) - - -;;; interpreter-mode-alist is not compatible between Emacs and XEmacs. -;;; So fake it. - -(defvar sh-interpreter-mode-alist - '(("perl" . perl-mode) - ("perl5" . perl-mode) - ("wish" . tcl-mode) - ("wishx" . tcl-mode) - ("tcl" . tcl-mode) - ("tclsh" . tcl-mode) - ("awk" . awk-mode) - ("mawk" . awk-mode) - ("nawk" . awk-mode) - ("gawk" . awk-mode) - ("scm" . scheme-mode) - ("ash" . sh-mode) - ("bash" . sh-mode) - ("csh" . sh-mode) - ("dtksh" . sh-mode) - ("es" . sh-mode) - ("itcsh" . sh-mode) - ("jsh" . sh-mode) - ("ksh" . sh-mode) - ("oash" . sh-mode) - ("pdksh" . sh-mode) - ("rc" . sh-mode) - ("sh" . sh-mode) - ("sh5" . sh-mode) - ("tcsh" . sh-mode) - ("wksh" . sh-mode) - ("wsh" . sh-mode) - ("zsh" . sh-mode) - ("tail" . text-mode) - ("more" . text-mode) - ("less" . text-mode) - ("pg" . text-mode)) - "Alist mapping interpreter names to major modes. -This alist applies to files whose first line starts with `#!'. -Each element looks like (INTERPRETER . MODE). -The car of each element is compared with -the name of the interpreter specified in the first line. -If it matches, mode MODE is selected.") - -(defcustom sh-mode-hook nil - "*Hook run by `sh-mode'." - :type 'hook - :group 'sh) - -(defcustom sh-set-shell-hook nil - "*Hook run by `sh-set-shell'." - :type 'hook - :group 'sh) - -(defcustom sh-ancestor-alist - '((ash . sh) - (bash . jsh) - (dtksh . ksh) - (es . rc) - (itcsh . tcsh) - (jcsh . csh) - (jsh . sh) - (ksh . ksh88) - (ksh88 . jsh) - (oash . sh) - (pdksh . ksh88) - (posix . sh) - (tcsh . csh) - (wksh . ksh88) - (wsh . sh) - (zsh . ksh88)) - "*Alist showing the direct ancestor of various shells. -This is the basis for `sh-feature'. See also `sh-alias-alist'. -By default we have the following three hierarchies: - -csh C Shell - jcsh C Shell with Job Control - tcsh Toronto C Shell - itcsh ? Toronto C Shell -rc Plan 9 Shell - es Extensible Shell -sh Bourne Shell - ash ? Shell - jsh Bourne Shell with Job Control - bash GNU Bourne Again Shell - ksh88 Korn Shell '88 - ksh Korn Shell '93 - dtksh CDE Desktop Korn Shell - pdksh Public Domain Korn Shell - wksh Window Korn Shell - zsh Z Shell - oash SCO OA (curses) Shell - posix IEEE 1003.2 Shell Standard - wsh ? Shell" - :type '(repeat (cons symbol symbol)) - :group 'sh) - - -(defcustom sh-alias-alist - ;; XEmacs: Linux is spelled `linux' - (nconc (if (eq system-type 'linux) - '((csh . tcsh) - (ksh . pdksh))) - ;; for the time being - '((ksh . ksh88) - (sh5 . sh))) - "*Alist for transforming shell names to what they really are. -Use this where the name of the executable doesn't correspond to the type of -shell it really is." - :type '(repeat (cons symbol symbol)) - :group 'sh) - - -(defcustom sh-shell-file (or (getenv "SHELL") "/bin/sh") - "*The executable file name for the shell being programmed." - :type 'string - :group 'sh) - - -(defcustom sh-shell-arg - ;; bash does not need any options when run in a shell script, - '((bash) - (csh . "-f") - (pdksh) - ;; Bill_Mann@praxisint.com says -p with ksh can do harm. - (ksh88) - ;; -p means don't initialize functions from the environment. - (rc . "-p") - ;; Someone proposed -motif, but we don't want to encourage - ;; use of a non-free widget set. - (wksh) - ;; -f means don't run .zshrc. - (zsh . "-f")) - "*Single argument string for the magic number. See `sh-feature'." - :type '(repeat (cons (symbol :tag "Shell") - (choice (const :tag "No Arguments" nil) - (string :tag "Arguments") - (cons :format "Evaluate: %v" - (const :format "" eval) - sexp)))) - :group 'sh) - -(defvar sh-shell-variables nil - "Alist of shell variable names that should be included in completion. -These are used for completion in addition to all the variables named -in `process-environment'. Each element looks like (VAR . VAR), where -the car and cdr are the same symbol.") - -(defvar sh-shell-variables-initialized nil - "Non-nil if `sh-shell-variables' is initialized.") - -(defun sh-canonicalize-shell (shell) - "Convert a shell name SHELL to the one we should handle it as." - (or (symbolp shell) - (setq shell (intern shell))) - (or (cdr (assq shell sh-alias-alist)) - shell)) - -(defvar sh-shell (sh-canonicalize-shell (file-name-nondirectory sh-shell-file)) - "The shell being programmed. This is set by \\[sh-set-shell].") - -;;; I turned off this feature because it doesn't permit typing commands -;;; in the usual way without help. -;;;(defvar sh-abbrevs -;;; '((csh eval sh-abbrevs shell -;;; "switch" 'sh-case -;;; "getopts" 'sh-while-getopts) - -;;; (es eval sh-abbrevs shell -;;; "function" 'sh-function) - -;;; (ksh88 eval sh-abbrevs sh -;;; "select" 'sh-select) - -;;; (rc eval sh-abbrevs shell -;;; "case" 'sh-case -;;; "function" 'sh-function) - -;;; (sh eval sh-abbrevs shell -;;; "case" 'sh-case -;;; "function" 'sh-function -;;; "until" 'sh-until -;;; "getopts" 'sh-while-getopts) - -;;; ;; The next entry is only used for defining the others -;;; (shell "for" sh-for -;;; "loop" sh-indexed-loop -;;; "if" sh-if -;;; "tmpfile" sh-tmp-file -;;; "while" sh-while) - -;;; (zsh eval sh-abbrevs ksh88 -;;; "repeat" 'sh-repeat)) -;;; "Abbrev-table used in Shell-Script mode. See `sh-feature'. -;;;Due to the internal workings of abbrev tables, the shell name symbol is -;;;actually defined as the table for the like of \\[edit-abbrevs].") - - - -(defvar sh-mode-syntax-table - '((csh eval identity sh) - (sh eval sh-mode-syntax-table () - ;; #'s meanings depend on context which can't be expressed here - ;; ?\# "<" - ;; ?\^l ">#" - ;; ?\n ">#" - ?\" "\"\"" - ?\' "\"'" - ?\` ".`" - ?$ "_" - ?! "_" - ?% "_" - ?: "_" - ?. "_" - ?^ "_" - ?~ "_") - (rc eval sh-mode-syntax-table sh - ?\" "_" - ?\` ".")) - "Syntax-table used in Shell-Script mode. See `sh-feature'.") - - - -(defvar sh-mode-map - (let ((map (make-sparse-keymap)) - (menu-map (make-sparse-keymap "Insert"))) - (define-key map "\C-c(" 'sh-function) - (define-key map "\C-c\C-w" 'sh-while) - (define-key map "\C-c\C-u" 'sh-until) - (define-key map "\C-c\C-t" 'sh-tmp-file) - (define-key map "\C-c\C-s" 'sh-select) - (define-key map "\C-c\C-r" 'sh-repeat) - (define-key map "\C-c\C-o" 'sh-while-getopts) - (define-key map "\C-c\C-l" 'sh-indexed-loop) - (define-key map "\C-c\C-i" 'sh-if) - (define-key map "\C-c\C-f" 'sh-for) - (define-key map "\C-c\C-c" 'sh-case) - - (define-key map "=" 'sh-assignment) - (define-key map "\C-c+" 'sh-add) - (define-key map "\C-\M-x" 'sh-execute-region) - (define-key map "\C-c\C-x" 'executable-interpret) - (define-key map "<" 'sh-maybe-here-document) - (define-key map "(" 'skeleton-pair-insert-maybe) - (define-key map "{" 'skeleton-pair-insert-maybe) - (define-key map "[" 'skeleton-pair-insert-maybe) - (define-key map "'" 'skeleton-pair-insert-maybe) - (define-key map "`" 'skeleton-pair-insert-maybe) - (define-key map "\"" 'skeleton-pair-insert-maybe) - - (define-key map "\t" 'sh-indent-line) - (substitute-key-definition 'complete-tag 'comint-dynamic-complete - map (current-global-map)) - (substitute-key-definition 'newline-and-indent 'sh-newline-and-indent - map (current-global-map)) -;; GDF - Don't mess around with the DEL bindings -;; (substitute-key-definition 'delete-backward-char -;; 'backward-delete-char-untabify -;; map (current-global-map)) - (define-key map "\C-c:" 'sh-set-shell) - (substitute-key-definition 'beginning-of-defun - 'sh-beginning-of-compound-command - map (current-global-map)) - (substitute-key-definition 'backward-sentence 'sh-beginning-of-command - map (current-global-map)) - (substitute-key-definition 'forward-sentence 'sh-end-of-command - map (current-global-map)) - (define-key map [menu-bar insert] (cons "Insert" menu-map)) - (define-key menu-map [sh-while] '("While Loop" . sh-while)) - (define-key menu-map [sh-until] '("Until Loop" . sh-until)) - (define-key menu-map [sh-tmp-file] '("Temporary File" . sh-tmp-file)) - (define-key menu-map [sh-select] '("Select Statement" . sh-select)) - (define-key menu-map [sh-repeat] '("Repeat Loop" . sh-repeat)) - (define-key menu-map [sh-while-getopts] - '("Options Loop" . sh-while-getopts)) - (define-key menu-map [sh-indexed-loop] - '("Indexed Loop" . sh-indexed-loop)) - (define-key menu-map [sh-if] '("If Statement" . sh-if)) - (define-key menu-map [sh-for] '("For Loop" . sh-for)) - (define-key menu-map [sh-case] '("Case Statement" . sh-case)) - map) - "Keymap used in Shell-Script mode.") - - - -(defcustom sh-dynamic-complete-functions - '(shell-dynamic-complete-environment-variable - shell-dynamic-complete-command - comint-dynamic-complete-filename) - "*Functions for doing TAB dynamic completion." - :type '(repeat function) - :group 'sh) - - -(defcustom sh-require-final-newline - '((csh . t) - (pdksh . t) - (rc eval . require-final-newline) - (sh eval . require-final-newline)) - "*Value of `require-final-newline' in Shell-Script mode buffers. -See `sh-feature'." - :type '(repeat (cons (symbol :tag "Shell") - (choice (const :tag "require" t) - (cons :format "Evaluate: %v" - (const :format "" eval) - sexp)))) - :group 'sh) - - -(defcustom sh-comment-prefix - '((csh . "\\(^\\|[^$]\\|\\$[^{]\\)") - (rc eval identity csh) - (sh . "\\(^\\|[ \t|&;()]\\)")) - "*Regexp matching what may come before a comment `#'. -This must contain one \\(grouping\\) since it is the basis for fontifying -comments as well as for `comment-start-skip'. -See `sh-feature'." - :type '(repeat (cons (symbol :tag "Shell") - (choice regexp - (cons :format "Evaluate: %v" - (const :format "" eval) - sexp)))) - :group 'sh) - - -(defcustom sh-assignment-regexp - '((csh . "\\<\\([a-zA-Z0-9_]+\\)\\(\\[.+\\]\\)?[ \t]*[-+*/%^]?=") - ;; actually spaces are only supported in let/(( ... )) - (ksh88 . "\\<\\([a-zA-Z0-9_]+\\)\\(\\[.+\\]\\)?[ \t]*\\([-+*/%&|~^]\\|<<\\|>>\\)?=") - (rc . "\\<\\([a-zA-Z0-9_*]+\\)[ \t]*=") - (sh . "\\<\\([a-zA-Z0-9_]+\\)=")) - "*Regexp for the variable name and what may follow in an assignment. -First grouping matches the variable name. This is upto and including the `=' -sign. See `sh-feature'." - :type '(repeat (cons (symbol :tag "Shell") - (choice regexp - (cons :format "Evaluate: %v" - (const :format "" eval) - sexp)))) - :group 'sh) - - -(defcustom sh-indentation 4 - "The width for further indentation in Shell-Script mode." - :type 'integer - :group 'sh) - - -(defcustom sh-remember-variable-min 3 - "*Don't remember variables less than this length for completing reads." - :type 'integer - :group 'sh) - - -(defvar sh-header-marker nil - "When non-`nil' is the end of header for prepending by \\[sh-execute-region]. -That command is also used for setting this variable.") - - -(defcustom sh-beginning-of-command - "\\([;({`|&]\\|\\`\\|[^\\]\n\\)[ \t]*\\([/~a-zA-Z0-9:]\\)" - "*Regexp to determine the beginning of a shell command. -The actual command starts at the beginning of the second \\(grouping\\)." - :type 'regexp - :group 'sh) - - -(defcustom sh-end-of-command - "\\([/~a-zA-Z0-9:]\\)[ \t]*\\([;#)}`|&]\\|$\\)" - "*Regexp to determine the end of a shell command. -The actual command ends at the end of the first \\(grouping\\)." - :type 'regexp - :group 'sh) - - - -(defvar sh-here-document-word "EOF" - "Word to delimit here documents.") - -(defvar sh-test - '((sh "[ ]" . 2) - (ksh88 "[[ ]]" . 3)) - "Initial input in Bourne if, while and until skeletons. See `sh-feature'.") - - -;; customized this out of sheer bravado. not for the faint of heart. -;; but it *did* have an asterisk in the docstring! -(defcustom sh-builtins - '((bash eval sh-append posix - "alias" "bg" "bind" "builtin" "declare" "dirs" "enable" "fc" "fg" - "help" "history" "jobs" "kill" "let" "local" "popd" "pushd" "source" - "suspend" "typeset" "unalias") - - ;; The next entry is only used for defining the others - (bourne eval sh-append shell - "eval" "export" "getopts" "newgrp" "pwd" "read" "readonly" - "times" "ulimit") - - (csh eval sh-append shell - "alias" "chdir" "glob" "history" "limit" "nice" "nohup" "rehash" - "setenv" "source" "time" "unalias" "unhash") - - (dtksh eval identity wksh) - - (es "access" "apids" "cd" "echo" "eval" "false" "let" "limit" "local" - "newpgrp" "result" "time" "umask" "var" "vars" "wait" "whatis") - - (jsh eval sh-append sh - "bg" "fg" "jobs" "kill" "stop" "suspend") - - (jcsh eval sh-append csh - "bg" "fg" "jobs" "kill" "notify" "stop" "suspend") - - (ksh88 eval sh-append bourne - "alias" "bg" "false" "fc" "fg" "jobs" "kill" "let" "print" "time" - "typeset" "unalias" "whence") - - (oash eval sh-append sh - "checkwin" "dateline" "error" "form" "menu" "newwin" "oadeinit" - "oaed" "oahelp" "oainit" "pp" "ppfile" "scan" "scrollok" "wattr" - "wclear" "werase" "win" "wmclose" "wmmessage" "wmopen" "wmove" - "wmtitle" "wrefresh") - - (pdksh eval sh-append ksh88 - "bind") - - (posix eval sh-append sh - "command") - - (rc "builtin" "cd" "echo" "eval" "limit" "newpgrp" "shift" "umask" "wait" - "whatis") - - (sh eval sh-append bourne - "hash" "test" "type") - - ;; The next entry is only used for defining the others - (shell "cd" "echo" "eval" "set" "shift" "umask" "unset" "wait") - - (wksh eval sh-append ksh88 - "Xt[A-Z][A-Za-z]*") - - (zsh eval sh-append ksh88 - "autoload" "bindkey" "builtin" "chdir" "compctl" "declare" "dirs" - "disable" "disown" "echotc" "enable" "functions" "getln" "hash" - "history" "integer" "limit" "local" "log" "popd" "pushd" "r" - "readonly" "rehash" "sched" "setopt" "source" "suspend" "true" - "ttyctl" "type" "unfunction" "unhash" "unlimit" "unsetopt" "vared" - "which")) - "*List of all shell builtins for completing read and fontification. -Note that on some systems not all builtins are available or some are -implemented as aliases. See `sh-feature'." - :type '(repeat (cons (symbol :tag "Shell") - (choice (repeat string) - (cons :format "Evaluate: %v" - (const :format "" eval) - sexp)))) - :group 'sh) - - - -(defcustom sh-leading-keywords - '((csh "else") - - (es "true" "unwind-protect" "whatis") - - (rc "else") - - (sh "do" "elif" "else" "if" "then" "trap" "type" "until" "while")) - "*List of keywords that may be immediately followed by a builtin or keyword. -Given some confusion between keywords and builtins depending on shell and -system, the distinction here has been based on whether they influence the -flow of control or syntax. See `sh-feature'." - :type '(repeat (cons (symbol :tag "Shell") - (choice (repeat string) - (cons :format "Evaluate: %v" - (const :format "" eval) - sexp)))) - :group 'sh) - - -(defcustom sh-other-keywords - '((bash eval sh-append bourne - "bye" "logout") - - ;; The next entry is only used for defining the others - (bourne eval sh-append shell - "done" "esac" "fi" "for" "function" "in" "return") - - (csh eval sh-append shell - "breaksw" "default" "end" "endif" "endsw" "foreach" "goto" - "if" "logout" "onintr" "repeat" "switch" "then" "while") - - (es "break" "catch" "exec" "exit" "fn" "for" "forever" "fork" "if" - "return" "throw" "while") - - (ksh88 eval sh-append bourne - "select") - - (rc "break" "case" "exec" "exit" "fn" "for" "if" "in" "return" "switch" - "while") - - ;; The next entry is only used for defining the others - (shell "break" "case" "continue" "exec" "exit") - - (zsh eval sh-append bash - "select")) - "*List of keywords not in `sh-leading-keywords'. -See `sh-feature'." - :type '(repeat (cons (symbol :tag "Shell") - (choice (repeat string) - (cons :format "Evaluate: %v" - (const :format "" eval) - sexp)))) - :group 'sh) - - - -(defvar sh-variables - '((bash eval sh-append sh - "allow_null_glob_expansion" "auto_resume" "BASH" "BASH_VERSION" - "cdable_vars" "ENV" "EUID" "FCEDIT" "FIGNORE" "glob_dot_filenames" - "histchars" "HISTFILE" "HISTFILESIZE" "history_control" "HISTSIZE" - "hostname_completion_file" "HOSTTYPE" "IGNOREEOF" "ignoreeof" - "LINENO" "MAIL_WARNING" "noclobber" "nolinks" "notify" - "no_exit_on_failed_exec" "NO_PROMPT_VARS" "OLDPWD" "OPTERR" "PPID" - "PROMPT_COMMAND" "PS4" "pushd_silent" "PWD" "RANDOM" "REPLY" - "SECONDS" "SHLVL" "TMOUT" "UID") - - (csh eval sh-append shell - "argv" "cdpath" "child" "echo" "histchars" "history" "home" - "ignoreeof" "mail" "noclobber" "noglob" "nonomatch" "path" "prompt" - "shell" "status" "time" "verbose") - - (es eval sh-append shell - "apid" "cdpath" "CDPATH" "history" "home" "ifs" "noexport" "path" - "pid" "prompt" "signals") - - (jcsh eval sh-append csh - "notify") - - (ksh88 eval sh-append sh - "ENV" "ERRNO" "FCEDIT" "FPATH" "HISTFILE" "HISTSIZE" "LINENO" - "OLDPWD" "PPID" "PS3" "PS4" "PWD" "RANDOM" "REPLY" "SECONDS" - "TMOUT") - - (oash eval sh-append sh - "FIELD" "FIELD_MAX" "LAST_KEY" "OALIB" "PP_ITEM" "PP_NUM") - - (rc eval sh-append shell - "apid" "apids" "cdpath" "CDPATH" "history" "home" "ifs" "path" "pid" - "prompt" "status") - - (sh eval sh-append shell - "CDPATH" "IFS" "OPTARG" "OPTIND" "PS1" "PS2") - - ;; The next entry is only used for defining the others - (shell "COLUMNS" "EDITOR" "HOME" "HUSHLOGIN" "LANG" "LC_COLLATE" - "LC_CTYPE" "LC_MESSAGES" "LC_MONETARY" "LC_NUMERIC" "LC_TIME" - "LINES" "LOGNAME" "MAIL" "MAILCHECK" "MAILPATH" "PAGER" "PATH" - "SHELL" "TERM" "TERMCAP" "TERMINFO" "VISUAL") - - (tcsh eval sh-append csh - "addsuffix" "ampm" "autocorrect" "autoexpand" "autolist" - "autologout" "chase_symlinks" "correct" "dextract" "edit" "el" - "fignore" "gid" "histlit" "HOST" "HOSTTYPE" "HPATH" - "ignore_symlinks" "listjobs" "listlinks" "listmax" "matchbeep" - "nobeep" "NOREBIND" "oid" "printexitvalue" "prompt2" "prompt3" - "pushdsilent" "pushdtohome" "recexact" "recognize_only_executables" - "rmstar" "savehist" "SHLVL" "showdots" "sl" "SYSTYPE" "tcsh" "term" - "tperiod" "tty" "uid" "version" "visiblebell" "watch" "who" - "wordchars") - - (zsh eval sh-append ksh88 - "BAUD" "bindcmds" "cdpath" "DIRSTACKSIZE" "fignore" "FIGNORE" "fpath" - "HISTCHARS" "hostcmds" "hosts" "HOSTS" "LISTMAX" "LITHISTSIZE" - "LOGCHECK" "mailpath" "manpath" "NULLCMD" "optcmds" "path" "POSTEDIT" - "prompt" "PROMPT" "PROMPT2" "PROMPT3" "PROMPT4" "psvar" "PSVAR" - "READNULLCMD" "REPORTTIME" "RPROMPT" "RPS1" "SAVEHIST" "SPROMPT" - "STTY" "TIMEFMT" "TMOUT" "TMPPREFIX" "varcmds" "watch" "WATCH" - "WATCHFMT" "WORDCHARS" "ZDOTDIR")) - "List of all shell variables available for completing read. -See `sh-feature'.") - - - -(defvar sh-font-lock-keywords - '((csh eval sh-append shell - '("\\${?[#?]?\\([A-Za-z_][A-Za-z0-9_]*\\|0\\)" 1 - font-lock-variable-name-face)) - - (es eval sh-append executable-font-lock-keywords - '("\\$#?\\([A-Za-z_][A-Za-z0-9_]*\\|[0-9]+\\)" 1 - font-lock-variable-name-face)) - - (rc eval identity es) - - (sh eval sh-append shell - '("\\$\\({#?\\)?\\([A-Za-z_][A-Za-z0-9_]*\\|[-#?@!]\\)" 2 - font-lock-variable-name-face)) - - ;; The next entry is only used for defining the others - (shell eval sh-append executable-font-lock-keywords - '("\\\\[^A-Za-z0-9]" 0 font-lock-string-face) - '("\\${?\\([A-Za-z_][A-Za-z0-9_]*\\|[0-9]+\\|[$*_]\\)" 1 - font-lock-variable-name-face))) - "*Rules for highlighting shell scripts. See `sh-feature'.") - -(defvar sh-font-lock-keywords-1 - '((sh "[ \t]in\\>")) - "*Additional rules for highlighting shell scripts. See `sh-feature'.") - -(defvar sh-font-lock-keywords-2 () - "*Yet more rules for highlighting shell scripts. See `sh-feature'.") - -(defvar sh-font-lock-keywords-only t - "*Value of `font-lock-keywords-only' for highlighting shell scripts. -Default value is `t' because Emacs' syntax is not expressive enough to -detect that $# does not start a comment. Thus comments are fontified by -regexp which means that a single apostrophe in a comment turns everything -upto the next one or end of buffer into a string.") - -;; mode-command and utility functions - -;;;###autoload -(put 'sh-mode 'mode-class 'special) - -;;;###autoload -(defun sh-mode () - "Major mode for editing shell scripts. -This mode works for many shells, since they all have roughly the same syntax, -as far as commands, arguments, variables, pipes, comments etc. are concerned. -Unless the file's magic number indicates the shell, your usual shell is -assumed. Since filenames rarely give a clue, they are not further analyzed. - -This mode adapts to the variations between shells (see `sh-set-shell') by -means of an inheritance based feature lookup (see `sh-feature'). This -mechanism applies to all variables (including skeletons) that pertain to -shell-specific features. - -The default style of this mode is that of Rosenblatt's Korn shell book. -The syntax of the statements varies with the shell being used. The -following commands are available, based on the current shell's syntax: - -\\[sh-case] case statement -\\[sh-for] for loop -\\[sh-function] function definition -\\[sh-if] if statement -\\[sh-indexed-loop] indexed loop from 1 to n -\\[sh-while-getopts] while getopts loop -\\[sh-repeat] repeat loop -\\[sh-select] select loop -\\[sh-until] until loop -\\[sh-while] while loop - -\\[backward-delete-char-untabify] Delete backward one position, even if it was a tab. -\\[sh-newline-and-indent] Delete unquoted space and indent new line same as this one. -\\[sh-end-of-command] Go to end of successive commands. -\\[sh-beginning-of-command] Go to beginning of successive commands. -\\[sh-set-shell] Set this buffer's shell, and maybe its magic number. -\\[sh-execute-region] Have optional header and region be executed in a subshell. - -\\[sh-maybe-here-document] Without prefix, following an unquoted < inserts here document. -{, (, [, ', \", ` - Unless quoted with \\, insert the pairs {}, (), [], or '', \"\", ``. - -If you generally program a shell different from your login shell you can -set `sh-shell-file' accordingly. If your shell's file name doesn't correctly -indicate what shell it is use `sh-alias-alist' to translate. - -If your shell gives error messages with line numbers, you can use \\[executable-interpret] -with your script for an edit-interpret-debug cycle." - (interactive) - (kill-all-local-variables) - (use-local-map sh-mode-map) - (make-local-variable 'indent-line-function) - (make-local-variable 'indent-region-function) - (make-local-variable 'skeleton-end-hook) - (make-local-variable 'paragraph-start) - (make-local-variable 'paragraph-separate) - (make-local-variable 'comment-start) - (make-local-variable 'comment-start-skip) - (make-local-variable 'require-final-newline) - (make-local-variable 'sh-header-marker) - (make-local-variable 'sh-shell-file) - (make-local-variable 'sh-shell) - (make-local-variable 'skeleton-pair-alist) - (make-local-variable 'skeleton-pair-filter) - (make-local-variable 'comint-dynamic-complete-functions) - (make-local-variable 'comint-prompt-regexp) - (make-local-variable 'font-lock-keywords) - (make-local-variable 'font-lock-defaults) - (make-local-variable 'skeleton-filter) - (make-local-variable 'skeleton-newline-indent-rigidly) - (make-local-variable 'sh-shell-variables) - (make-local-variable 'sh-shell-variables-initialized) - (setq major-mode 'sh-mode - mode-name "Shell-script" - indent-line-function 'sh-indent-line - ;; not very clever, but enables wrapping skeletons around regions - indent-region-function (lambda (b e) - (save-excursion - (goto-char b) - (skip-syntax-backward "-") - (setq b (point)) - (goto-char e) - (skip-syntax-backward "-") - (indent-rigidly b (point) sh-indentation))) - skeleton-end-hook (lambda () - (or (eolp) (newline) (indent-relative))) - paragraph-start (concat page-delimiter "\\|$") - paragraph-separate paragraph-start - comment-start "# " - comint-dynamic-complete-functions sh-dynamic-complete-functions - ;; we can't look if previous line ended with `\' - comint-prompt-regexp "^[ \t]*" - font-lock-defaults - `((sh-font-lock-keywords - sh-font-lock-keywords-1 - sh-font-lock-keywords-2) - ,sh-font-lock-keywords-only - nil - ((?/ . "w") (?~ . "w") (?. . "w") (?- . "w") (?_ . "w"))) - skeleton-pair-alist '((?` _ ?`)) - skeleton-pair-filter 'sh-quoted-p - skeleton-further-elements '((< '(- (min sh-indentation - (current-column))))) - skeleton-filter 'sh-feature - skeleton-newline-indent-rigidly t) - (save-excursion - ;; parse or insert magic number for exec() and set all variables depending - ;; on the shell thus determined - (goto-char (point-min)) - (and (zerop (buffer-size)) - (not buffer-read-only) - (sh-set-shell sh-shell-file))) - (run-hooks 'sh-mode-hook)) -;;;###autoload -(defalias 'shell-script-mode 'sh-mode) - -;;; XEmacs -(put 'sh-mode 'font-lock-defaults - `((sh-font-lock-keywords - sh-font-lock-keywords-1 - sh-font-lock-keywords-2) - ,sh-font-lock-keywords-only - nil - ((?/ . "w") (?~ . "w") (?. . "w") (?- . "w") (?_ . "w")))) - - -(defun sh-font-lock-keywords (&optional keywords) - "Function to get simple fontification based on `sh-font-lock-keywords'. -This adds rules for comments and assignments." - (sh-feature sh-font-lock-keywords - (lambda (list) - `((,(concat (sh-feature sh-comment-prefix) "\\(#.*\\)") - 2 font-lock-comment-face t) - (,(sh-feature sh-assignment-regexp) - 1 font-lock-variable-name-face) - ,@keywords - ,@list)))) - -(defun sh-font-lock-keywords-1 (&optional builtins) - "Function to get better fontification including keywords." - (let ((keywords (concat "\\([;(){}`|&]\\|^\\)[ \t]*\\(\\(\\(" - (mapconcat 'identity - (sh-feature sh-leading-keywords) - "\\|") - "\\)[ \t]+\\)?\\(" - (mapconcat 'identity - (append (sh-feature sh-leading-keywords) - (sh-feature sh-other-keywords)) - "\\|") - "\\)"))) - (sh-font-lock-keywords - `(,@(if builtins - `((,(concat keywords "[ \t]+\\)?\\(" - (mapconcat 'identity (sh-feature sh-builtins) "\\|") - "\\)\\>") - (2 font-lock-keyword-face nil t) - (6 font-lock-function-name-face)) - ,@(sh-feature sh-font-lock-keywords-2))) - (,(concat keywords "\\)\\>") - 2 font-lock-keyword-face) - ,@(sh-feature sh-font-lock-keywords-1))))) - -(defun sh-font-lock-keywords-2 () - "Function to get better fontification including keywords and builtins." - (sh-font-lock-keywords-1 t)) - - -(defun sh-set-shell (shell &optional no-query-flag insert-flag) - "Set this buffer's shell to SHELL (a string). -Makes this script executable via `executable-set-magic'. -Calls the value of `sh-set-shell-hook' if set." - (interactive (list (completing-read "Name or path of shell: " - ;; XEmacs change - sh-interpreter-mode-alist - (lambda (x) (eq (cdr x) 'sh-mode))) - (eq executable-query 'function) - t)) - (setq sh-shell (intern (file-name-nondirectory shell)) - sh-shell (or (cdr (assq sh-shell sh-alias-alist)) - sh-shell)) - (setq sh-shell-file (executable-set-magic shell (sh-feature sh-shell-arg))) - (setq require-final-newline (sh-feature sh-require-final-newline) -;;; local-abbrev-table (sh-feature sh-abbrevs) - font-lock-defaults-computed nil - ;; Next two lines kill XEmacs - ;font-lock-keywords nil ; force resetting - ;font-lock-syntax-table nil - comment-start-skip (concat (sh-feature sh-comment-prefix) "#+[\t ]*") - mode-line-process (format "[%s]" sh-shell) - sh-shell-variables nil - sh-shell-variables-initialized nil - shell (sh-feature sh-variables)) - (set-syntax-table (sh-feature sh-mode-syntax-table)) - (while shell - (sh-remember-variable (car shell)) - (setq shell (cdr shell))) - (and (boundp 'font-lock-mode) - font-lock-mode - ;; Gnu Emacs, doesn't work - (font-lock-mode (font-lock-mode 0))) - ;; (font-lock-fontify-buffer)) - (run-hooks 'sh-set-shell-hook)) - - - -(defun sh-feature (list &optional function) - "Index ALIST by the current shell. -If ALIST isn't a list where every element is a cons, it is returned as is. -Else indexing follows an inheritance logic which works in two ways: - - - Fall back on successive ancestors (see `sh-ancestor-alist') as long as - the alist contains no value for the current shell. - - - If the value thus looked up is a list starting with `eval' its `cdr' is - first evaluated. If that is also a list and the first argument is a - symbol in ALIST it is not evaluated, but rather recursively looked up in - ALIST to allow the function called to define the value for one shell to be - derived from another shell. While calling the function, is the car of the - alist element is the current shell. - The value thus determined is physically replaced into the alist. - -Optional FUNCTION is applied to the determined value and the result is cached -in ALIST." - (or (if (consp list) - (let ((l list)) - (while (and l (consp (car l))) - (setq l (cdr l))) - (if l list))) - (if function - (cdr (assoc (setq function (cons sh-shell function)) list))) - (let ((sh-shell sh-shell) - elt val) - (while (and sh-shell - (not (setq elt (assq sh-shell list)))) - (setq sh-shell (cdr (assq sh-shell sh-ancestor-alist)))) - (if (and (consp (setq val (cdr elt))) - (eq (car val) 'eval)) - (setcdr elt - (setq val - (eval (if (consp (setq val (cdr val))) - (let ((sh-shell (car (cdr val))) - function) - (if (assq sh-shell list) - (setcar (cdr val) - (list 'quote - (sh-feature list)))) - val) - val))))) - (if function - (nconc list - (list (cons function - (setq sh-shell (car function) - val (funcall (cdr function) val)))))) - val))) - - - -;;; I commented this out because nobody calls it -- rms. -;;;(defun sh-abbrevs (ancestor &rest list) -;;; "Iff it isn't, define the current shell as abbrev table and fill that. -;;;Abbrev table will inherit all abbrevs from ANCESTOR, which is either an abbrev -;;;table or a list of (NAME1 EXPANSION1 ...). In addition it will define abbrevs -;;;according to the remaining arguments NAMEi EXPANSIONi ... -;;;EXPANSION may be either a string or a skeleton command." -;;; (or (if (boundp sh-shell) -;;; (symbol-value sh-shell)) -;;; (progn -;;; (if (listp ancestor) -;;; (nconc list ancestor)) -;;; (define-abbrev-table sh-shell ()) -;;; (if (vectorp ancestor) -;;; (mapatoms (lambda (atom) -;;; (or (eq atom 0) -;;; (define-abbrev (symbol-value sh-shell) -;;; (symbol-name atom) -;;; (symbol-value atom) -;;; (symbol-function atom)))) -;;; ancestor)) -;;; (while list -;;; (define-abbrev (symbol-value sh-shell) -;;; (car list) -;;; (if (stringp (car (cdr list))) -;;; (car (cdr list)) -;;; "") -;;; (if (symbolp (car (cdr list))) -;;; (car (cdr list)))) -;;; (setq list (cdr (cdr list))))) -;;; (symbol-value sh-shell))) - - -(defun sh-mode-syntax-table (table &rest list) - "Copy TABLE and set syntax for successive CHARs according to strings S." - (setq table (copy-syntax-table table)) - (while list - (modify-syntax-entry (car list) (car (cdr list)) table) - (setq list (cdr (cdr list)))) - table) - - -(defun sh-append (ancestor &rest list) - "Return list composed of first argument (a list) physically appended to rest." - (nconc list ancestor)) - - -(defun sh-modify (skeleton &rest list) - "Modify a copy of SKELETON by replacing I1 with REPL1, I2 with REPL2 ..." - (setq skeleton (copy-sequence skeleton)) - (while list - (setcar (or (nthcdr (car list) skeleton) - (error "Index %d out of bounds" (car list))) - (car (cdr list))) - (setq list (nthcdr 2 list))) - skeleton) - - -(defun sh-indent-line () - "Indent as far as preceding non-empty line, then by steps of `sh-indentation'. -Lines containing only comments are considered empty." - (interactive) - (let ((previous (save-excursion - (while (and (not (bobp)) - (not (eq (point-min) (point-at-bol))) - (progn - (forward-line -1) - (back-to-indentation) - (or (eolp) - (eq (following-char) ?#))))) - (current-column))) - current) - (save-excursion - (indent-to (if (eq this-command 'newline-and-indent) - previous - (if (< (current-column) - (setq current (progn (back-to-indentation) - (current-column)))) - (if (eolp) previous 0) - (delete-region (point) - (progn (beginning-of-line) (point))) - (if (eolp) - (max previous (* (1+ (/ current sh-indentation)) - sh-indentation)) - (* (1+ (/ current sh-indentation)) sh-indentation)))))) - (if (< (current-column) (current-indentation)) - (skip-chars-forward " \t")))) - - -(defun sh-execute-region (start end &optional flag) - "Pass optional header and region to a subshell for noninteractive execution. -The working directory is that of the buffer, and only environment variables -are already set which is why you can mark a header within the script. - -With a positive prefix ARG, instead of sending region, define header from -beginning of buffer to point. With a negative prefix ARG, instead of sending -region, clear header." - (interactive "r\nP") - (if flag - (setq sh-header-marker (if (> (prefix-numeric-value flag) 0) - (point-marker))) - (if sh-header-marker - (save-excursion - (let (buffer-undo-list) - (goto-char sh-header-marker) - (append-to-buffer (current-buffer) start end) - (shell-command-on-region (point-min) - (setq end (+ sh-header-marker - (- end start))) - sh-shell-file) - (delete-region sh-header-marker end))) - (shell-command-on-region start end (concat sh-shell-file " -"))))) - - -(defun sh-remember-variable (var) - "Make VARIABLE available for future completing reads in this buffer." - (or (< (length var) sh-remember-variable-min) - (getenv var) - (assoc var sh-shell-variables) - (setq sh-shell-variables (cons (cons var var) sh-shell-variables))) - var) - - - -(defun sh-quoted-p () - "Is point preceded by an odd number of backslashes?" - (eq -1 (% (save-excursion (skip-chars-backward "\\\\")) 2))) - -;; statement syntax-commands for various shells - -;; You are welcome to add the syntax or even completely new statements as -;; appropriate for your favorite shell. - -(define-skeleton sh-case - "Insert a case/switch statement. See `sh-feature'." - (csh "expression: " - "switch( " str " )" \n - > "case " (read-string "pattern: ") ?: \n - > _ \n - "breaksw" \n - ( "other pattern, %s: " - < "case " str ?: \n - > _ \n - "breaksw" \n) - < "default:" \n - > _ \n - resume: - < < "endsw") - (es) - (rc "expression: " - "switch( " str " ) {" \n - > "case " (read-string "pattern: ") \n - > _ \n - ( "other pattern, %s: " - < "case " str \n - > _ \n) - < "case *" \n - > _ \n - resume: - < < ?}) - (sh "expression: " - "case " str " in" \n - > (read-string "pattern: ") ?\) \n - > _ \n - ";;" \n - ( "other pattern, %s: " - < str ?\) \n - > _ \n - ";;" \n) - < "*)" \n - > _ \n - resume: - < < "esac")) -(put 'sh-case 'menu-enable '(sh-feature sh-case)) - - - -(define-skeleton sh-for - "Insert a for loop. See `sh-feature'." - (csh eval sh-modify sh - 1 "foreach " - 3 " ( " - 5 " )" - 15 "end") - (es eval sh-modify rc - 3 " = ") - (rc eval sh-modify sh - 1 "for( " - 5 " ) {" - 15 ?}) - (sh "Index variable: " - "for " str " in " _ "; do" \n - > _ | ?$ & (sh-remember-variable str) \n - < "done")) - - - -(define-skeleton sh-indexed-loop - "Insert an indexed loop from 1 to n. See `sh-feature'." - (bash eval identity posix) - (csh "Index variable: " - "@ " str " = 1" \n - "while( $" str " <= " (read-string "upper limit: ") " )" \n - > _ ?$ str \n - "@ " str "++" \n - < "end") - (es eval sh-modify rc - 3 " =") - (ksh88 "Index variable: " - "integer " str "=0" \n - "while (( ( " str " += 1 ) <= " - (read-string "upper limit: ") - " )); do" \n - > _ ?$ (sh-remember-variable str) \n - < "done") - (posix "Index variable: " - str "=1" \n - "while [ $" str " -le " - (read-string "upper limit: ") - " ]; do" \n - > _ ?$ str \n - str ?= (sh-add (sh-remember-variable str) 1) \n - < "done") - (rc "Index variable: " - "for( " str " in" " `{awk 'BEGIN { for( i=1; i<=" - (read-string "upper limit: ") - "; i++ ) print i }'}) {" \n - > _ ?$ (sh-remember-variable str) \n - < ?}) - (sh "Index variable: " - "for " str " in `awk 'BEGIN { for( i=1; i<=" - (read-string "upper limit: ") - "; i++ ) print i }'`; do" \n - > _ ?$ (sh-remember-variable str) \n - < "done")) - - -(defun sh-shell-initialize-variables () - "Scan the buffer for variable assignments. -Add these variables to `sh-shell-variables'." - (message "Scanning buffer `%s' for variable assignments..." (buffer-name)) - (save-excursion - (goto-char (point-min)) - (setq sh-shell-variables-initialized t) - (while (search-forward "=" nil t) - (sh-assignment 0))) - (message "Scanning buffer `%s' for variable assignments...done" - (buffer-name))) - -(defvar sh-add-buffer) - -(defun sh-add-completer (string predicate code) - "Do completion using `sh-shell-variables', but initialize it first. -This function is designed for use as the \"completion table\", -so it takes three arguments: - STRING, the current buffer contents; - PREDICATE, the predicate for filtering possible matches; - CODE, which says what kind of things to do. -CODE can be nil, t or `lambda'. -nil means to return the best completion of STRING, or nil if there is none. -t means to return a list of all possible completions of STRING. -`lambda' means to return t if STRING is a valid completion as it stands." - (let ((sh-shell-variables - (save-excursion - (set-buffer sh-add-buffer) - (or sh-shell-variables-initialized - (sh-shell-initialize-variables)) - (nconc (mapcar (lambda (var) - (let ((name - (substring var 0 (string-match "=" var)))) - (cons name name))) - process-environment) - sh-shell-variables)))) - (cond ((null code) - (try-completion string sh-shell-variables predicate)) - ((eq code t) - (all-completions string sh-shell-variables predicate)) - ((eq code 'lambda) - (assoc string sh-shell-variables))))) - -(defun sh-add (var delta) - "Insert an addition of VAR and prefix DELTA for Bourne (type) shell." - (interactive - (let ((sh-add-buffer (current-buffer))) - (list (completing-read "Variable: " 'sh-add-completer) - (prefix-numeric-value current-prefix-arg)))) - (insert (sh-feature '((bash . "$[ ") - (ksh88 . "$(( ") - (posix . "$(( ") - (rc . "`{expr $") - (sh . "`expr $") - (zsh . "$[ "))) - (sh-remember-variable var) - (if (< delta 0) " - " " + ") - (number-to-string (abs delta)) - (sh-feature '((bash . " ]") - (ksh88 . " ))") - (posix . " ))") - (rc . "}") - (sh . "`") - (zsh . " ]"))))) - - - -(define-skeleton sh-function - "Insert a function definition. See `sh-feature'." - (bash eval sh-modify ksh88 - 3 "() {") - (ksh88 "name: " - "function " str " {" \n - > _ \n - < "}") - (rc eval sh-modify ksh88 - 1 "fn ") - (sh () - "() {" \n - > _ \n - < "}")) - - - -(define-skeleton sh-if - "Insert an if statement. See `sh-feature'." - (csh "condition: " - "if( " str " ) then" \n - > _ \n - ( "other condition, %s: " - < "else if( " str " ) then" \n - > _ \n) - < "else" \n - > _ \n - resume: - < "endif") - (es "condition: " - "if { " str " } {" \n - > _ \n - ( "other condition, %s: " - < "} { " str " } {" \n - > _ \n) - < "} {" \n - > _ \n - resume: - < ?}) - (rc eval sh-modify csh - 3 " ) {" - 8 '( "other condition, %s: " - < "} else if( " str " ) {" \n - > _ \n) - 10 "} else {" - 17 ?}) - (sh "condition: " - '(setq input (sh-feature sh-test)) - "if " str "; then" \n - > _ \n - ( "other condition, %s: " - < "elif " str "; then" \n - > _ \n) - < "else" \n - > _ \n - resume: - < "fi")) - - - -(define-skeleton sh-repeat - "Insert a repeat loop definition. See `sh-feature'." - (es nil - "forever {" \n - > _ \n - < ?}) - (zsh "factor: " - "repeat " str "; do"\n - > _ \n - < "done")) -(put 'sh-repeat 'menu-enable '(sh-feature sh-repeat)) - - - -(define-skeleton sh-select - "Insert a select statement. See `sh-feature'." - (ksh88 "Index variable: " - "select " str " in " _ "; do" \n - > ?$ str \n - < "done")) -(put 'sh-select 'menu-enable '(sh-feature sh-select)) - - - -(define-skeleton sh-tmp-file - "Insert code to setup temporary file handling. See `sh-feature'." - (bash eval identity ksh88) - (csh (file-name-nondirectory (buffer-file-name)) - "set tmp = /tmp/" str ".$$" \n - "onintr exit" \n _ - (and (goto-char (point-max)) - (not (bolp)) - ?\n) - "exit:\n" - "rm $tmp* >&/dev/null" >) - (es (file-name-nondirectory (buffer-file-name)) - "local( signals = $signals sighup sigint; tmp = /tmp/" str ".$pid ) {" \n - > "catch @ e {" \n - > "rm $tmp^* >[2]/dev/null" \n - "throw $e" \n - < "} {" \n - > _ \n - < ?} \n - < ?}) - (ksh88 eval sh-modify sh - 6 "EXIT") - (rc (file-name-nondirectory (buffer-file-name)) - "tmp = /tmp/" str ".$pid" \n - "fn sigexit { rm $tmp^* >[2]/dev/null }") - (sh (file-name-nondirectory (buffer-file-name)) - "TMP=/tmp/" str ".$$" \n - "trap \"rm $TMP* 2>/dev/null\" " ?0)) - - - -(define-skeleton sh-until - "Insert an until loop. See `sh-feature'." - (sh "condition: " - '(setq input (sh-feature sh-test)) - "until " str "; do" \n - > _ \n - < "done")) -(put 'sh-until 'menu-enable '(sh-feature sh-until)) - - - -(define-skeleton sh-while - "Insert a while loop. See `sh-feature'." - (csh eval sh-modify sh - 2 "while( " - 4 " )" - 10 "end") - (es eval sh-modify rc - 2 "while { " - 4 " } {") - (rc eval sh-modify csh - 4 " ) {" - 10 ?}) - (sh "condition: " - '(setq input (sh-feature sh-test)) - "while " str "; do" \n - > _ \n - < "done")) - - - -(define-skeleton sh-while-getopts - "Insert a while getopts loop. See `sh-feature'. -Prompts for an options string which consists of letters for each recognized -option followed by a colon `:' if the option accepts an argument." - (bash eval sh-modify sh - 18 "${0##*/}") - (csh nil - "while( 1 )" \n - > "switch( \"$1\" )" \n - '(setq input '("- x" . 2)) - > > - ( "option, %s: " - < "case " '(eval str) - '(if (string-match " +" str) - (setq v1 (substring str (match-end 0)) - str (substring str 0 (match-beginning 0))) - (setq v1 nil)) - str ?: \n - > "set " v1 & " = $2" | -4 & _ \n - (if v1 "shift") & \n - "breaksw" \n) - < "case --:" \n - > "shift" \n - < "default:" \n - > "break" \n - resume: - < < "endsw" \n - "shift" \n - < "end") - (ksh88 eval sh-modify sh - 16 "print" - 18 "${0##*/}" - 36 "OPTIND-1") - (posix eval sh-modify sh - 18 "$(basename $0)") - (sh "optstring: " - "while getopts :" str " OPT; do" \n - > "case $OPT in" \n - > > - '(setq v1 (append (vconcat str) nil)) - ( (prog1 (if v1 (char-to-string (car v1))) - (if (eq (nth 1 v1) ?:) - (setq v1 (nthcdr 2 v1) - v2 "\"$OPTARG\"") - (setq v1 (cdr v1) - v2 nil))) - < str "|+" str ?\) \n - > _ v2 \n - ";;" \n) - < "*)" \n - > "echo" " \"usage: " "`basename $0`" - " [+-" '(setq v1 (point)) str - '(save-excursion - (while (search-backward ":" v1 t) - (replace-match " ARG] [+-" t t))) - (if (eq (preceding-char) ?-) -5) - "] [--] ARGS...\"" \n - "exit 2" \n - < < "esac" \n - < "done" \n - "shift " (sh-add "OPTIND" -1))) -(put 'sh-while-getopts 'menu-enable '(sh-feature sh-while-getopts)) - - - -(defun sh-assignment (arg) - "Remember preceding identifier for future completion and do self-insert." - (interactive "p") - (self-insert-command arg) - (if (<= arg 1) - (sh-remember-variable - (save-excursion - (if (re-search-forward (sh-feature sh-assignment-regexp) - (prog1 (point) - (beginning-of-line 1)) - t) - (match-string 1)))))) - - - -(defun sh-maybe-here-document (arg) - "Inserts self. Without prefix, following unquoted `<' inserts here document. -The document is bounded by `sh-here-document-word'." - (interactive "*P") - (self-insert-command (prefix-numeric-value arg)) - (or arg - (not (eq (char-after (- (point) 2)) last-command-char)) - (save-excursion - (backward-char 2) - (sh-quoted-p)) - (progn - (insert sh-here-document-word) - (or (eolp) (looking-at "[ \t]") (insert ? )) - (end-of-line 1) - (while - (sh-quoted-p) - (end-of-line 2)) - (newline) - (save-excursion (insert ?\n sh-here-document-word))))) - - -;; various other commands - -(autoload 'comint-dynamic-complete "comint" - "Dynamically perform completion at point." t) - -(autoload 'shell-dynamic-complete-command "shell" - "Dynamically complete the command at point." t) - -(autoload 'comint-dynamic-complete-filename "comint" - "Dynamically complete the filename at point." t) - -(autoload 'shell-dynamic-complete-environment-variable "shell" - "Dynamically complete the environment variable at point." t) - - - -(defun sh-newline-and-indent () - "Strip unquoted whitespace, insert newline, and indent like current line." - (interactive "*") - (indent-to (prog1 (current-indentation) - (delete-region (point) - (progn - (or (zerop (skip-chars-backward " \t")) - (if (sh-quoted-p) - (forward-char))) - (point))) - (newline)))) - - - -(defun sh-beginning-of-command () - "Move point to successive beginnings of commands." - (interactive) - (if (re-search-backward sh-beginning-of-command nil t) - (goto-char (match-beginning 2)))) - - -(defun sh-end-of-command () - "Move point to successive ends of commands." - (interactive) - (if (re-search-forward sh-end-of-command nil t) - (goto-char (match-end 1)))) - -(provide 'sh-script) -;;; sh-script.el ends here
--- a/lisp/modes/simula.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1330 +0,0 @@ -;;; simula.el --- SIMULA 87 code editing commands for Emacs - -;; Copyright (C) 1992 Free Software Foundation, Inc. - -;; Author: Hans Henrik Eriksen <hhe@ifi.uio.no> -;; Maintainer: simula-mode@ifi.uio.no -;; Version: 0.992 -;; Adapted-By: ESR -;; Keywords: languages - -;; 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. - -;;; Commentary: - -;; A major mode for editing the Simula language. It knows about Simula -;; syntax and standard indentation commands. It also provides convenient -;; abbrevs for Simula keywords. -;; -;; Hans Henrik Eriksen (the author) may be reached at: -;; Institutt for informatikk, -;; Universitetet i Oslo - -;;; Code: - -(provide 'simula-mode) - -(defgroup simula nil - "SIMULA 87 code editing commands for Emacs." - :group 'languages) - - -(defcustom simula-tab-always-indent nil - "*Non-nil means TAB in SIMULA mode should always reindent the current line. -Otherwise TAB indents only when point is within -the run of whitespace at the beginning of the line." - :type 'boolean - :group 'simula) - -(defcustom simula-indent-level 3 - "*Indentation of SIMULA statements with respect to containing block." - :type 'integer - :group 'simula) - -(defcustom simula-substatement-offset 3 - "*Extra indentation after DO, THEN, ELSE, WHEN and OTHERWISE." - :type 'integer - :group 'simula) - -(defcustom simula-continued-statement-offset 3 - "*Extra indentation for lines not starting a statement or substatement. -If value is a list, each line in a multipleline continued statement -will have the car of the list extra indentation with respect to -the previous line of the statement." - :type 'integer - :group 'simula) - -(defcustom simula-label-offset -4711 - "*Offset of SIMULA label lines relative to usual indentation." - :type 'integer - :group 'simula) - -(defcustom simula-if-indent '(0 . 0) - "*Extra indentation of THEN and ELSE with respect to the starting IF. -Value is a cons cell, the car is extra THEN indentation and the cdr -extra ELSE indentation. IF after ELSE is indented as the starting IF." - :type '(cons (integer :tag "THEN") - (integer :tag "ELSE")) - :group 'simula) - -(defcustom simula-inspect-indent '(0 . 0) - "*Extra indentation of WHEN and OTHERWISE with respect to the INSPECT. -Value is a cons cell, the car is extra WHEN indentation -and the cdr extra OTHERWISE indentation." - :type '(cons (integer :tag "WHEN") - (integer :tag "OTHERWISE")) - :group 'simula) - -(defcustom simula-electric-indent nil - "*Non-nil means `simula-indent-line' function may reindent previous line." - :type 'boolean - :group 'simula) - -(defcustom simula-abbrev-keyword 'upcase - "*Specify how to convert case for SIMULA keywords. -Value is one of the symbols `upcase', `downcase', `capitalize', -\(as in) `abbrev-table' or nil if they should not be changed." - :type '(choice (const upcase) (const downcase) (const capitalize) - (const abbrev-table) (const nil)) - :group 'simula) - -(defcustom simula-abbrev-stdproc 'abbrev-table - "*Specify how to convert case for standard SIMULA procedure and class names. -Value is one of the symbols `upcase', `downcase', `capitalize', -\(as in) `abbrev-table', or nil if they should not be changed." - :type '(choice (const upcase) (const downcase) (const capitalize) - (const abbrev-table) (const nil)) - :group 'simula) - -(defcustom simula-abbrev-file nil - "*File with extra abbrev definitions for use in SIMULA mode. -These are used together with the standard abbrev definitions for SIMULA. -Please note that the standard definitions are required -for SIMULA mode to function correctly." - :type '(choice (const :tag "None") - file) - :group 'simula) - -(defvar simula-mode-syntax-table nil - "Syntax table in SIMULA mode buffers.") - -(if simula-mode-syntax-table - () - (setq simula-mode-syntax-table (copy-syntax-table nil)) - (modify-syntax-entry ?! "<" simula-mode-syntax-table) - (modify-syntax-entry ?$ "." simula-mode-syntax-table) - (modify-syntax-entry ?% "." simula-mode-syntax-table) - (modify-syntax-entry ?' "\"" simula-mode-syntax-table) - (modify-syntax-entry ?\( "()" simula-mode-syntax-table) - (modify-syntax-entry ?\) ")(" simula-mode-syntax-table) - (modify-syntax-entry ?\; ">" simula-mode-syntax-table) - (modify-syntax-entry ?\[ "." simula-mode-syntax-table) - (modify-syntax-entry ?\\ "." simula-mode-syntax-table) - (modify-syntax-entry ?\] "." simula-mode-syntax-table) - (modify-syntax-entry ?_ "w" simula-mode-syntax-table) - (modify-syntax-entry ?\| "." simula-mode-syntax-table) - (modify-syntax-entry ?\{ "." simula-mode-syntax-table) - (modify-syntax-entry ?\} "." simula-mode-syntax-table)) - -(defvar simula-mode-map () - "Keymap used in SIMULA mode.") - -(if simula-mode-map - () - (setq simula-mode-map (make-sparse-keymap)) - (define-key simula-mode-map "\C-c\C-u" 'simula-backward-up-level) - (define-key simula-mode-map "\C-c\C-p" 'simula-previous-statement) - (define-key simula-mode-map "\C-c\C-d" 'simula-forward-down-level) - (define-key simula-mode-map "\C-c\C-n" 'simula-next-statement) - ;(define-key simula-mode-map "\C-c\C-g" 'simula-goto-definition) - ;(define-key simula-mode-map "\C-c\C-h" 'simula-standard-help) - (define-key simula-mode-map ":" 'simula-electric-label) - (define-key simula-mode-map "\t" 'simula-indent-command)) - -(defvar simula-mode-abbrev-table nil - "Abbrev table in SIMULA mode buffers") - - -(defun simula-mode () - "Major mode for editing SIMULA code. -\\{simula-mode-map} -Variables controlling indentation style: - simula-tab-always-indent - Non-nil means TAB in SIMULA mode should always reindent the current line, - regardless of where in the line point is when the TAB command is used. - simula-indent-level - Indentation of SIMULA statements with respect to containing block. - simula-substatement-offset - Extra indentation after DO, THEN, ELSE, WHEN and OTHERWISE. - simula-continued-statement-offset 3 - Extra indentation for lines not starting a statement or substatement, - e.g. a nested FOR-loop. If value is a list, each line in a multiple- - line continued statement will have the car of the list extra indentation - with respect to the previous line of the statement. - simula-label-offset -4711 - Offset of SIMULA label lines relative to usual indentation. - simula-if-indent '(0 . 0) - Extra indentation of THEN and ELSE with respect to the starting IF. - Value is a cons cell, the car is extra THEN indentation and the cdr - extra ELSE indentation. IF after ELSE is indented as the starting IF. - simula-inspect-indent '(0 . 0) - Extra indentation of WHEN and OTHERWISE with respect to the - corresponding INSPECT. Value is a cons cell, the car is - extra WHEN indentation and the cdr extra OTHERWISE indentation. - simula-electric-indent nil - If this variable is non-nil, `simula-indent-line' - will check the previous line to see if it has to be reindented. - simula-abbrev-keyword 'upcase - Determine how SIMULA keywords will be expanded. Value is one of - the symbols `upcase', `downcase', `capitalize', (as in) `abbrev-table', - or nil if they should not be changed. - simula-abbrev-stdproc 'abbrev-table - Determine how standard SIMULA procedure and class names will be - expanded. Value is one of the symbols `upcase', `downcase', `capitalize', - (as in) `abbrev-table', or nil if they should not be changed. - -Turning on SIMULA mode calls the value of the variable simula-mode-hook -with no arguments, if that value is non-nil - -Warning: simula-mode-hook should not read in an abbrev file without calling -the function simula-install-standard-abbrevs afterwards, preferably not -at all." - (interactive) - (kill-all-local-variables) - (use-local-map simula-mode-map) - (setq major-mode 'simula-mode) - (setq mode-name "SIMULA") - (make-local-variable 'comment-column) - (setq comment-column 40) - (make-local-variable 'end-comment-column) - (setq end-comment-column 75) - (set-syntax-table simula-mode-syntax-table) - (make-local-variable 'paragraph-start) - (setq paragraph-start "[ \t]*$\\|\\f") - (make-local-variable 'paragraph-separate) - (setq paragraph-separate paragraph-start) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'simula-indent-line) - (make-local-variable 'require-final-newline) - (setq require-final-newline t) - (make-local-variable 'comment-start) - (setq comment-start "! ") - (make-local-variable 'comment-end) - (setq comment-end " ;") - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "!+ *") - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments nil) - (make-local-variable 'comment-multi-line) - (setq comment-multi-line t) - (if simula-mode-abbrev-table - () - (if simula-abbrev-file - (read-abbrev-file simula-abbrev-file) - (define-abbrev-table 'simula-mode-abbrev-table ())) - (let (abbrevs-changed) - (simula-install-standard-abbrevs))) - (setq local-abbrev-table simula-mode-abbrev-table) - (abbrev-mode 1) - (run-hooks 'simula-mode-hook)) - - - -(defun simula-indent-line () - "Indent this line as SIMULA code. -If `simula-electric-indent' is non-nil, indent previous line if necessary." - (let ((origin (- (point-max) (point))) - (indent (simula-calculate-indent)) - (case-fold-search t)) - (unwind-protect - (progn - ;; - ;; manually expand abbrev on last line, if any - ;; - (end-of-line 0) - (expand-abbrev) - ;; now maybe we should reindent that line - (if simula-electric-indent - (progn - (beginning-of-line) - (skip-chars-forward " \t\f") - (if (and - (looking-at - "\\(end\\|if\\|then\\|else\\|when\\|otherwise\\)\\>") - (not (simula-context))) - ;; yes - reindent - (let ((post-indent (simula-calculate-indent))) - (if (eq (current-indentation) post-indent) - () - (delete-horizontal-space) - (indent-to post-indent))))))) - (goto-char (- (point-max) origin)) - (if (eq (current-indentation) indent) - (back-to-indentation) - (delete-horizontal-space) - (indent-to indent))))) - - -(defun simula-indent-command (&optional whole-exp) - "Indent current line as SIMULA code, or insert TAB character. -If `simula-tab-always-indent' is non-nil, always indent current line. -Otherwise, indent only if point is before any non-whitespace -character on the line. - -A numeric argument, regardless of its value, means indent rigidly -all the lines of the SIMULA statement after point so that this line -becomes properly indented. -The relative indentation among the lines of the statement are preserved." - (interactive "P") - (let ((case-fold-search t)) - (if (or whole-exp simula-tab-always-indent - (save-excursion - (skip-chars-backward " \t\f") - (bolp))) - ;; reindent current line - (let ((indent (save-excursion - (beginning-of-line) - (simula-calculate-indent))) - (current (current-indentation)) - (origin (- (point-max) (point))) - (bol (save-excursion - (skip-chars-backward " \t\f") - (bolp))) - beg end) - (unwind-protect - (if (eq current indent) - (if (save-excursion - (skip-chars-backward " \t\f") - (bolp)) - (back-to-indentation)) - (beginning-of-line) - (delete-horizontal-space) - (indent-to indent)) - (if (not bol) - (goto-char (- (point-max) origin)))) - (setq origin (point)) - (if whole-exp - (save-excursion - (beginning-of-line 2) - (setq beg (point)) - (goto-char origin) - (simula-next-statement 1) - (setq end (point)) - (if (and (> end beg) (not (eq indent current))) - (indent-code-rigidly beg end (- indent current) "%"))))) - (insert-tab)))) - - -(defun simula-context () - "Returns value according to syntactic SIMULA context of point. - 0 point inside COMMENT comment - 1 point on SIMULA-compiler directive line - 2 point inside END comment - 3 point inside string - 4 point inside character constant - nil otherwise." - ;; first, find out if this is a compiler directive line - (if (save-excursion - (beginning-of-line) - (eq (following-char) ?%)) - ;; YES - return 1 - 1 - (save-excursion - ;; The current line is NOT a compiler directive line. - ;; Now, the strategy is to search backward to find a semicolon - ;; that is NOT inside a string. The point after semicolon MUST be - ;; outside a comment, since semicolons are comment-ending and - ;; comments are non-recursive. We take advantage of the fact - ;; that strings MUST end on the same line as they started, so - ;; that we can easily decide whether we are inside a string or not. - (let (return-value (origin (point))) - (skip-chars-backward "^;" (point-min)) - ;; found semicolon or beginning of buffer - (let (loopvalue (saved-point origin)) - (while (and (not (bobp)) - (if (progn - (beginning-of-line) - ;; compiler directive line? If so, cont searching.. - (eq (following-char) ?%)) - t - (while (< (point) saved-point) - (skip-chars-forward "^;\"'") - (forward-char 1) - (cond - ((eq (preceding-char) ?\;) - (setq saved-point (point))) - ((eq (preceding-char) ?\") - (skip-chars-forward "^\";") - (if (eq (following-char) ?\;) - (setq saved-point (point) loopvalue t) - (forward-char 1))) - (t - (if (eq (following-char) ?') - (forward-char 1)) - (skip-chars-forward "^';") - (if (eq (following-char) ?\;) - (setq saved-point (point) loopvalue t) - (forward-char 1))))) - loopvalue)) - (backward-char 1) - (skip-chars-backward "^;") - (setq saved-point (point) loopvalue nil))) - ;; Now we are CERTAIN that we are outside comments and strings. - ;; The job now is to search forward again towards the origin - ;; skipping directives, comments and strings correctly, - ;; so that we know what context we are in when we find the origin. - (while (and - (< (point) origin) - (re-search-forward - "\\<end\\>\\|!\\|\"\\|'\\|^%\\|\\<comment\\>" origin 'move)) - (cond - ((memq (preceding-char) '(?d ?D)) - (setq return-value 2) - (while (and (memq (preceding-char) '(?d ?D)) (not return-value)) - (while (and (re-search-forward - ";\\|\\<end\\>\\|\\<else\\>\\|\\<otherwise\\>\\|\\<when\\>\\|^%" - origin 'move) - (eq (preceding-char) ?%)) - (beginning-of-line 2))) - (if (looking-at "[ \t\n\f]*\\(;\\|\\<end\\>\\|\\<else\\>\\|\\<otherwise\\>\\|\\<when\\>\\)") - (setq return-value nil))) - ((memq (preceding-char) '(?! ?t ?T)) - ; skip comment - (setq return-value 0) - (skip-chars-forward "^%;" origin) - (while (and return-value (< (point) origin)) - (if (eq (following-char) ?\;) - (setq return-value nil) - (if (bolp) - (beginning-of-line 2) ; skip directive inside comment - (forward-char 1)) ; or single '%' - (skip-chars-forward "^%;" origin)))) - ((eq (preceding-char) ?\") - (if (not (search-forward "\"" origin 'move)) - (setq return-value 3))) - ((eq (preceding-char) ?\') - (if (or (eq (point) origin) (eobp)) - (setq return-value 4) - (forward-char 1) - (if (not (search-forward "'" origin 'move)) - (setq return-value 4)))) - ;; compiler directive line - skip - (t (beginning-of-line 2)))) - return-value) - ))) - - -(defun simula-electric-label () - "If this is a label that starts the line, reindent the line." - (interactive) - (expand-abbrev) - (insert ?:) - (let ((origin (- (point-max) (point))) - (case-fold-search t) - ;; don't mix a label with an assignment operator := :- - ;; therefore look at next typed character... - (next-char (if (fboundp 'next-command-event) - (event-to-character (setq unread-command-events - (list (next-command-event)))) - ;; FSFmacs - (setq unread-command-events (list (read-event))))) - ;(com-char last-command-char) -- unused - ) - (unwind-protect - ;; Problem: find out if character just read is a command char - ;; that would insert something after ':' making it a label. - ;; At least \n, \r (and maybe \t) falls into this category. - ;; This is a real crock, it depends on traditional keymap - ;; bindings, that is, printing characters doing self-insert, - ;; and no other command sequence inserting '-' or '='. - ;; simula-electric-label can be easily fooled... - (if (and (not (memq next-char '(?= ?-))) - (or (memq next-char '(?\n ?\r)) - (and (eq next-char ?\t) - simula-tab-always-indent) - (not (memq (following-char) '(?= ?-)))) - (not (simula-context)) - ;; label? - (progn - (backward-char 1) - (skip-chars-backward " \t\f") - (skip-chars-backward "a-zA-Z0-9_") - (if (looking-at "virtual\\>") - nil - (skip-chars-backward " \t\f") - (bolp)))) - (let ((amount (simula-calculate-indent))) - (delete-horizontal-space) - (indent-to amount))) - (goto-char (- (point-max) origin))))) - - -(defun simula-backward-up-level (count) - "Move backward up COUNT block levels. -If COUNT is negative, move forward up block level instead." - (interactive "p") - (let ((origin (point)) - (case-fold-search t)) - (condition-case () - (if (> count 0) - (while (> count 0) - (re-search-backward "\\<begin\\>\\|\\<end\\>") - (if (not (simula-context)) - (setq count (if (memq (following-char) '(?b ?B)) - (1- count) - (1+ count))))) - (while (< count 0) - (re-search-forward "\\<begin\\>\\|\\<end\\>") - (backward-word 1) - (if (not (simula-context)) - (setq count (if (memq (following-char) '(?e ?E)) - (1+ count) - (1- count)))) - (backward-word -1))) - ;; If block level not found, jump back to origin and signal an error - (error (progn - (goto-char origin) - (error "No higher block level"))) - (quit (progn - (goto-char origin) - (signal 'quit nil)))))) - - -(defun simula-forward-down-level (count) - "Move forward down COUNT block levels. -If COUNT is negative, move backward down block level instead." - (interactive "p") - ;; When we search for a deeper block level, we must never - ;; get out of the block where we started -> count >= start-count - (let ((start-count count) - (origin (point)) - (case-fold-search t)) - (condition-case () - (if (< count 0) - (while (< count 0) - (re-search-backward "\\<begin\\>\\|\\<end\\>") - (if (not (simula-context)) - (setq count (if (memq (following-char) '(?e ?E)) - (1+ count) - (1- count)))) - (if (< count start-count) (signal 'error nil))) - (while (> count 0) - (re-search-forward "\\<begin\\>\\|\\<end\\>") - (backward-word 1) - (if (not (simula-context)) - (setq count (if (memq (following-char) '(?b ?B)) - (1- count) - (1+ count)))) - (backward-word -1) - ;; deeper level has to be found within starting block - (if (> count start-count) (signal 'error nil)))) - ;; If block level not found, jump back to origin and signal an error - (error (progn - (goto-char origin) - (error "No containing block level"))) - (quit (progn - (goto-char origin) - (signal 'quit nil)))))) - - -(defun simula-previous-statement (count) - "Move backward COUNT statements. -If COUNT is negative, move forward instead." - (interactive "p") - (if (< count 0) - (simula-next-statement (- count)) - (let (status - (case-fold-search t) - (origin (point))) - (condition-case () - (progn - (simula-skip-comment-backward) - (if (memq (preceding-char) '(?n ?N)) - (progn - (backward-word 1) - (if (not (looking-at "\\<begin\\>")) - (backward-word -1))) - (if (eq (preceding-char) ?\;) - (backward-char 1))) - (while (and (natnump (setq count (1- count))) - (setq status (simula-search-backward - ";\\|\\<begin\\>" nil 'move)))) - (if status - (progn - (if (eq (following-char) ?\;) - (forward-char 1) - (backward-word -1)))) - (simula-skip-comment-forward)) - (error (progn (goto-char origin) - (error "Incomplete statement (too many ENDs)"))) - (quit (progn (goto-char origin) (signal 'quit nil))))))) - - -(defun simula-next-statement (count) - "Move forward COUNT statements. -If COUNT is negative, move backward instead." - (interactive "p") - (if (< count 0) - (simula-previous-statement (- count)) - (let (status - (case-fold-search t) - (origin (point))) - (condition-case () - (progn - (simula-skip-comment-forward) - (if (looking-at "\\<end\\>") (forward-word 1)) - (while (and (natnump (setq count (1- count))) - (setq status (simula-search-forward - ";\\|\\<end\\>" (point-max) 'move)))) - (if (and status (/= (preceding-char) ?\;)) - (progn - (backward-word 1) - (simula-skip-comment-backward)))) - (error (progn (goto-char origin) - (error "Incomplete statement (too few ENDs)"))) - (quit (progn (goto-char origin) (signal 'quit nil))))))) - - -(defun simula-skip-comment-backward () - "Search towards bob to find first char that is outside a comment." - (interactive) - (catch 'simula-out - (let (context) - (while t - (skip-chars-backward " \t\n\f") - (if (eq (preceding-char) ?\;) - (save-excursion - (backward-char 1) - (setq context (simula-context))) - (setq context (simula-context))) - (cond - ((memq context '(nil 3 4)) - ;; check to see if we found a label - (if (and (eq (preceding-char) ?:) - (not (memq (following-char) '(?- ?=))) - (save-excursion - (skip-chars-backward ": \t\fa-zA-Z0-9_") - (not (looking-at "virtual\\>")))) - (skip-chars-backward ": \t\fa-zA-Z0-9_") - (throw 'simula-out nil))) - ((eq context 0) - ;; since we are inside a comment, it must start somewhere! - (while (and (re-search-backward "!\\|\\<comment\\>") - (memq (simula-context) '(0 1))))) - ((eq context 1) - (end-of-line 0) - (if (bobp) - (throw 'simula-out nil))) - ((eq context 2) - ;; an END-comment must belong to an END - (re-search-backward "\\<end\\>") - (forward-word 1) - (throw 'simula-out nil)) - ;; should be impossible to get here.. - ))))) - - -(defun simula-skip-comment-forward () - "Search towards eob to find first char that is outside a comment." - ;; this function assumes we start with point .outside a comment - (interactive) - (catch 'simula-out - (while t - (skip-chars-forward " \t\n\f") - (cond - ((looking-at "!\\|\\<comment\\>") - (search-forward ";" nil 'move)) - ((and (bolp) (eq (following-char) ?%)) - (beginning-of-line 2)) - ((and (looking-at "[a-z0-9_]*[ \t\f]*:[^-=]") - (not (looking-at "virtual\\>"))) - (skip-chars-forward "a-zA-Z0-9_ \t\f:")) - (t - (throw 'simula-out t)))))) - - -(defun simula-forward-up-level () - (let ((continue-loop t) - (origin (point)) - (case-fold-search t) - return-value - temp) - (while continue-loop - (if (re-search-backward "\\<begin\\>\\|\\<end\\>" (point-min) 'move) - (setq temp (simula-context) - return-value (and (memq (preceding-char) '(?d ?D)) - (memq temp '(nil 2))) - continue-loop (and (not return-value) - (simula-forward-up-level))) - (setq continue-loop nil))) - (if return-value - t - (goto-char origin) - nil))) - - -(defun simula-calculate-indent () - (save-excursion - (let ((where (simula-context)) - (origin (point)) - (indent 0) - continued - start-line - temp - found-end - prev-cont) - (cond - ((eq where 0) - ;; - ;; Comment. - ;; If comment started on previous non-blank line, indent to the - ;; column where the comment started, else indent as that line. - ;; - (skip-chars-backward " \t\n\f") - (while (and (not (bolp)) (eq (simula-context) 0)) - (re-search-backward "^\\|!\\|\\<comment\\>")) - (skip-chars-forward " \t\n\f") - (prog1 - (current-column) - (goto-char origin))) - ;; - ;; Detect missing string delimiters - ;; - ((eq where 3) - (error "Inside string")) - ((eq where 4) - (error "Inside character constant")) - ;; - ;; check to see if inside ()'s - ;; - ((setq temp (simula-inside-parens)) - temp) - ;; - ;; Calculate non-comment indentation - (t - ;; first, find out if this line starts with something that needs - ;; special indentation (END/IF/THEN/ELSE/WHEN/OTHERWISE or label) - ;; - (skip-chars-forward " \t\f") - (cond - ;; - ;; END - ;; - ((looking-at "end\\>") - (setq indent (- simula-indent-level) - found-end t)) - ;; - ;; IF/THEN/ELSE - ;; - ((looking-at "if\\>\\|then\\>\\|else\\>") - ;; search for the *starting* IF - (cond - ((memq (following-char) '(?T ?t)) - (setq indent (car simula-if-indent))) - ((memq (following-char) '(?E ?e)) - (setq indent (cdr simula-if-indent))) - (t - (forward-word 1) - (setq indent 0))) - (simula-find-if)) - ;; - ;; WHEN/OTHERWISE - ;; - ((looking-at "when\\>\\|otherwise\\>") - ;; search for corresponding INSPECT - (if (memq (following-char) '(?W ?w)) - (setq indent (car simula-inspect-indent)) - (setq indent (cdr simula-inspect-indent))) - (simula-find-inspect)) - ;; - ;; label: - ;; - ((and (not (looking-at "virtual\\>")) - (looking-at "[a-z0-9_]*[ \t\f]*:[^-=]")) - (setq indent simula-label-offset))) - ;; find line with non-comment text - (simula-skip-comment-backward) - (if (and found-end - (not (eq (preceding-char) ?\;)) - (if (memq (preceding-char) '(?N ?n)) - (save-excursion - (backward-word 1) - (not (looking-at "begin\\>"))) - t)) - (progn - (simula-previous-statement 1) - (simula-skip-comment-backward))) - (setq start-line - (save-excursion (beginning-of-line) (point)) - ;; - perhaps this is a continued statement - continued - (save-excursion - (and (not (bobp)) - ;; (not found-end) - (if (eq (char-syntax (preceding-char)) ?w) - (progn - (backward-word 1) - (not (looking-at - "begin\\|then\\|else\\|when\\|otherwise\\|do" - ))) - (not (memq (preceding-char) '(?: ?\;))))))) - ;; - ;; MAIN calculation loop - count BEGIN/DO etc. - ;; - (while (not (bolp)) - (if (re-search-backward - ";\\|\\<\\(begin\\|end\\|if\\|else\\|then\\|when\\|otherwise\\|do\\)\\>" - start-line 'move) - (if (simula-context) - ();; found something in a comment/string - ignore - (setq temp (following-char)) - (cond - ((eq temp ?\;) - (simula-previous-statement 1)) - ((looking-at "begin\\>") - (setq indent (+ indent simula-indent-level))) - ((looking-at "end\\>") - (forward-word 1) - (simula-previous-statement 1)) - ((looking-at "do\\>") - (setq indent (+ indent simula-substatement-offset)) - (simula-find-do-match)) - ((looking-at "\\(if\\|then\\|else\\)\\>") - (if (memq temp '(?I ?i)) - (forward-word 1) - (setq indent (+ indent - simula-substatement-offset - (if (memq temp '(?T ?t)) - (car simula-if-indent) - (cdr simula-if-indent))))) - (simula-find-if)) - ((looking-at "\\<when\\>\\|\\<otherwise\\>") - (setq indent (+ indent - simula-substatement-offset - (if (memq temp '(?W ?w)) - (car simula-if-indent) - (cdr simula-if-indent)))) - (simula-find-inspect))) - ;; found the start of a [sub]statement - ;; add indentation for continued statement - (if continued - (setq indent - (+ indent - (if (listp simula-continued-statement-offset) - (car simula-continued-statement-offset) - simula-continued-statement-offset)))) - (setq start-line - (save-excursion (beginning-of-line) (point)) - continued nil)) - ;; search failed .. point is at beginning of line - ;; determine if we should continue searching - ;; (at or before comment or label) - ;; temp = t means finished - (setq temp - (and (not (simula-context)) - (save-excursion - (skip-chars-forward " \t\f") - (or (looking-at "virtual") - (not - (looking-at - "!\\|comment\\>\\|[a-z0-9_]*[ \t\f]*:[^-=]"))))) - prev-cont continued) - ;; if we are finished, find current line's indentation - (if temp - (setq indent (+ indent (current-indentation)))) - ;; find next line with non-comment SIMULA text - ;; maybe indent extra if statement continues - (simula-skip-comment-backward) - (setq continued - (and (not (bobp)) - (if (eq (char-syntax (preceding-char)) ?w) - (save-excursion - (backward-word 1) - (not (looking-at - "begin\\|then\\|else\\|when\\|otherwise\\|do"))) - (not (memq (preceding-char) '(?: ?\;)))))) - ;; if we the state of the continued-variable - ;; changed, add indentation for continued statement - (if (or (and prev-cont (not continued)) - (and continued - (listp simula-continued-statement-offset))) - (setq indent - (+ indent - (if (listp simula-continued-statement-offset) - (car simula-continued-statement-offset) - simula-continued-statement-offset)))) - ;; while ends if point is at beginning of line at loop test - (if (not temp) - (setq start-line (save-excursion (beginning-of-line) (point))) - (beginning-of-line)))) - ;; - ;; return indentation - ;; - indent))))) - - -(defun simula-find-if () - "Find starting IF of a IF-THEN[-ELSE[-IF-THEN...]] statement." - (catch 'simula-out - (while t - (if (and (simula-search-backward "\\<if\\>\\|;\\|\\<begin\\>"nil t) - (memq (following-char) '(?I ?i))) - (save-excursion - ;; - ;; find out if this IF was really the start of the IF statement - ;; - (simula-skip-comment-backward) - (if (and (eq (char-syntax (preceding-char)) ?w) - (progn - (backward-word 1) - (looking-at "else\\>"))) - () - (throw 'simula-out t))) - (if (not (looking-at "\\<if\\>")) - (error "Missing IF or misplaced BEGIN or ';' (can't find IF)") - ;; - ;; we were at the starting IF in the first place.. - ;; - (throw 'simula-out t)))))) - - -(defun simula-find-inspect () - "Find INSPECT matching WHEN or OTHERWISE." - (catch 'simula-out - (let ((level 0)) - ;; - ;; INSPECTs can be nested, have to find the corresponding one - ;; - (while t - (if (and (simula-search-backward "\\<inspect\\>\\|\\<otherwise\\>\\|;" - nil t) - (/= (following-char) ?\;)) - (if (memq (following-char) '(?O ?o)) - (setq level (1+ level)) - (if (zerop level) - (throw 'simula-out t) - (setq level (1- level)))) - (error "Missing INSPECT or misplaced ';' (can't find INSPECT)")))))) - - -(defun simula-find-do-match () - "Find keyword matching DO: FOR, WHILE, INSPECT or WHEN" - (while (and (re-search-backward - "\\<\\(do\\|for\\|while\\|inspect\\|when\\|end\\|begin\\)\\>\\|;" - nil 'move) - (simula-context))) - (if (and (looking-at "\\<\\(for\\|while\\|inspect\\|when\\)\\>") - (not (simula-context))) - () ;; found match - (error "No matching FOR, WHILE or INSPECT for DO, or misplaced ';'"))) - - -(defun simula-inside-parens () - "Return position after `(' on line if inside parentheses, nil otherwise." - (save-excursion - (let ((parlevel 0)) - (catch 'simula-out - (while t - (if (re-search-backward "(\\|)\\|;" nil t) - (if (eq (simula-context) nil) - ;; found something - check it out - (cond - ((eq (following-char) ?\;) - (if (zerop parlevel) - (throw 'simula-out nil) - (error "Parenthesis mismatch or misplaced ';'"))) - ((eq (following-char) ?\() - (if (zerop parlevel) - (throw 'simula-out (1+ (current-column))) - (setq parlevel (1- parlevel)))) - (t (setq parlevel (1+ parlevel)))) - );; nothing - inside comment or string - ;; search failed - (throw 'simula-out nil))))))) - - -(defun simula-goto-definition () - "Goto point of definition of variable, procedure or class." - (interactive)) - - -(defun simula-expand-stdproc () - (if (or (not simula-abbrev-stdproc) (simula-context)) - (unexpand-abbrev) - (cond - ((eq simula-abbrev-stdproc 'upcase) (upcase-word -1)) - ((eq simula-abbrev-stdproc 'downcase) (downcase-word -1)) - ((eq simula-abbrev-stdproc 'capitalize) (capitalize-word -1))))) - - -(defun simula-expand-keyword () - (if (or (not simula-abbrev-keyword) (simula-context)) - (unexpand-abbrev) - (cond - ((eq simula-abbrev-keyword 'upcase) (upcase-word -1)) - ((eq simula-abbrev-keyword 'downcase) (downcase-word -1)) - ((eq simula-abbrev-keyword 'capitalize) (capitalize-word -1))))) - - -(defun simula-electric-keyword () - "Expand SIMULA keyword. If it starts the line, reindent." - ;; redisplay - (let ((show-char (eq this-command 'self-insert-command))) - ;; If the abbrev expansion results in reindentation, the user may have - ;; to wait some time before the character he typed is displayed - ;; (the char causing the expansion is inserted AFTER the hook function - ;; is called). This is annoying in case of normal characters. - ;; However, if the user pressed a key bound to newline, it is better - ;; to have the line inserted after the begin-end match. - (if show-char - (progn - (insert-char last-command-char 1) - (sit-for 0) - (backward-char 1))) - (if (let ((where (simula-context)) - (case-fold-search t)) - (if where - (if (and (eq where 2) (eq (char-syntax (preceding-char)) ?w)) - (save-excursion - (backward-word 1) - (not (looking-at "end\\>")))))) - (unexpand-abbrev) - (cond - ((not simula-abbrev-keyword) (unexpand-abbrev)) - ((eq simula-abbrev-keyword 'upcase) (upcase-word -1)) - ((eq simula-abbrev-keyword 'downcase) (downcase-word -1)) - ((eq simula-abbrev-keyword 'capitalize) (capitalize-word -1))) - (let ((pos (- (point-max) (point))) - (case-fold-search t) - ) - (condition-case nil - (progn - ;; check if the expanded word is on the beginning of the line. - (if (and (eq (char-syntax (preceding-char)) ?w) - (progn - (backward-word 1) - (if (looking-at "end\\>") - (save-excursion - (simula-backward-up-level 1) - (if (pos-visible-in-window-p) - (sit-for 1) - (message - (concat "Matches " - (buffer-substring - (point) - (+ (point) (window-width)))))))) - (skip-chars-backward " \t\f") - (bolp))) - (let ((indent (simula-calculate-indent))) - (if (eq indent (current-indentation)) - () - (delete-horizontal-space) - (indent-to indent))) - (skip-chars-forward " \t\f")) - ;; check for END - blow whistles and ring bells - - (goto-char (- (point-max) pos)) - (if show-char - (delete-char 1))) - (quit (goto-char (- (point-max) pos)))))))) - - -(defun simula-search-backward (string &optional limit move) - (setq string (concat string "\\|\\<end\\>")) - (let (level) - (catch 'simula-out - (while (re-search-backward string limit move) - (if (simula-context) - () - (if (looking-at "\\<end\\>") - (progn - (setq level 0) - (while (natnump level) - (re-search-backward "\\<begin\\>\\|\\<end\\>") - (if (simula-context) - () - (setq level (if (memq (following-char) '(?b ?B)) - (1- level) - (1+ level)))))) - (throw 'simula-out t))))))) - - -(defun simula-search-forward (string &optional limit move) - (setq string (concat string "\\|\\<begin\\>")) - (let (level) - (catch 'exit - (while (re-search-forward string limit move) - (goto-char (match-beginning 0)) - (if (simula-context) - (goto-char (1- (match-end 0))) - (if (looking-at "\\<begin\\>") - (progn - (goto-char (1- (match-end 0))) - (setq level 0) - (while (natnump level) - (re-search-forward "\\<begin\\>\\|\\<end\\>") - (backward-word 1) - (if (not (simula-context)) - (setq level (if (memq (following-char) '(?e ?E)) - (1- level) - (1+ level)))) - (backward-word -1))) - (goto-char (1- (match-end 0))) - (throw 'exit t))))))) - - -(defun simula-install-standard-abbrevs () - "Define Simula keywords, procedures and classes in local abbrev table." - ;; procedure and class names are as of the SIMULA 87 standard. - (interactive) - (mapcar (function (lambda (args) - (apply 'define-abbrev simula-mode-abbrev-table args))) - '(("abs" "Abs" simula-expand-stdproc) - ("accum" "Accum" simula-expand-stdproc) - ("activate" "ACTIVATE" simula-expand-keyword) - ("addepsilon" "AddEpsilon" simula-expand-stdproc) - ("after" "AFTER" simula-expand-keyword) - ("and" "AND" simula-expand-keyword) - ("arccos" "ArcCos" simula-expand-stdproc) - ("arcsin" "ArcSin" simula-expand-stdproc) - ("arctan" "ArcTan" simula-expand-stdproc) - ("arctan2" "ArcTan2" simula-expand-stdproc) - ("array" "ARRAY" simula-expand-keyword) - ("at" "AT" simula-expand-keyword) - ("before" "BEFORE" simula-expand-keyword) - ("begin" "BEGIN" simula-expand-keyword) - ("blanks" "Blanks" simula-expand-stdproc) - ("boolean" "BOOLEAN" simula-expand-keyword) - ("breakoutimage" "BreakOutImage" simula-expand-stdproc) - ("bytefile" "ByteFile" simula-expand-stdproc) - ("call" "Call" simula-expand-stdproc) - ("cancel" "Cancel" simula-expand-stdproc) - ("cardinal" "Cardinal" simula-expand-stdproc) - ("char" "Char" simula-expand-stdproc) - ("character" "CHARACTER" simula-expand-keyword) - ("checkpoint" "CheckPoint" simula-expand-stdproc) - ("class" "CLASS" simula-expand-keyword) - ("clear" "Clear" simula-expand-stdproc) - ("clocktime" "ClockTime" simula-expand-stdproc) - ("close" "Close" simula-expand-stdproc) - ("comment" "COMMENT" simula-expand-keyword) - ("constant" "Constant" simula-expand-stdproc) - ("copy" "Copy" simula-expand-stdproc) - ("cos" "Cos" simula-expand-stdproc) - ("cosh" "CosH" simula-expand-stdproc) - ("cotan" "CoTan" simula-expand-stdproc) - ("cputime" "CpuTime" simula-expand-stdproc) - ("current" "Current" simula-expand-stdproc) - ("datetime" "DateTime" simula-expand-stdproc) - ("decimalmark" "DecimalMark" simula-expand-stdproc) - ("delay" "DELAY" simula-expand-keyword) - ("deleteimage" "DeleteImage" simula-expand-stdproc) - ("detach" "Detach" simula-expand-stdproc) - ("digit" "Digit" simula-expand-stdproc) - ("directbytefile" "DirectByteFile" simula-expand-stdproc) - ("directfile" "DirectFile" simula-expand-stdproc) - ("discrete" "Discrete" simula-expand-stdproc) - ("do" "DO" simula-expand-keyword) - ("downcase" "Downcase" simula-expand-stdproc) - ("draw" "Draw" simula-expand-stdproc) - ("eject" "Eject" simula-expand-stdproc) - ("else" "ELSE" simula-electric-keyword) - ("empty" "Empty" simula-expand-stdproc) - ("end" "END" simula-electric-keyword) - ("endfile" "Endfile" simula-expand-stdproc) - ("entier" "Entier" simula-expand-stdproc) - ("eq" "EQ" simula-expand-keyword) - ("eqv" "EQV" simula-expand-keyword) - ("erlang" "Erlang" simula-expand-stdproc) - ("error" "Error" simula-expand-stdproc) - ("evtime" "EvTime" simula-expand-stdproc) - ("exp" "Exp" simula-expand-stdproc) - ("external" "EXTERNAL" simula-expand-keyword) - ("false" "FALSE" simula-expand-keyword) - ("field" "Field" simula-expand-stdproc) - ("file" "File" simula-expand-stdproc) - ("first" "First" simula-expand-stdproc) - ("follow" "Follow" simula-expand-stdproc) - ("for" "FOR" simula-expand-keyword) - ("ge" "GE" simula-expand-keyword) - ("getchar" "GetChar" simula-expand-stdproc) - ("getfrac" "GetFrac" simula-expand-stdproc) - ("getint" "GetInt" simula-expand-stdproc) - ("getreal" "GetReal" simula-expand-stdproc) - ("go" "GO" simula-expand-keyword) - ("goto" "GOTO" simula-expand-keyword) - ("gt" "GT" simula-expand-keyword) - ("head" "Head" simula-expand-stdproc) - ("hidden" "HIDDEN" simula-expand-keyword) - ("histd" "HistD" simula-expand-stdproc) - ("histo" "Histo" simula-expand-stdproc) - ("hold" "Hold" simula-expand-stdproc) - ("idle" "Idle" simula-expand-stdproc) - ("if" "IF" simula-expand-keyword) - ("image" "Image" simula-expand-stdproc) - ("imagefile" "ImageFile" simula-expand-stdproc) - ("imp" "IMP" simula-expand-keyword) - ("in" "IN" simula-expand-keyword) - ("inbyte" "InByte" simula-expand-stdproc) - ("inbytefile" "InByteFile" simula-expand-stdproc) - ("inchar" "InChar" simula-expand-stdproc) - ("infile" "InFile" simula-expand-stdproc) - ("infrac" "InFrac" simula-expand-stdproc) - ("inimage" "InImage" simula-expand-stdproc) - ("inint" "InInt" simula-expand-stdproc) - ("inner" "INNER" simula-expand-keyword) - ("inreal" "InReal" simula-expand-stdproc) - ("inrecord" "InRecord" simula-expand-stdproc) - ("inspect" "INSPECT" simula-expand-keyword) - ("integer" "INTEGER" simula-expand-keyword) - ("intext" "InText" simula-expand-stdproc) - ("into" "Into" simula-expand-stdproc) - ("is" "IS" simula-expand-keyword) - ("isochar" "ISOChar" simula-expand-stdproc) - ("isopen" "IsOpen" simula-expand-stdproc) - ("isorank" "ISORank" simula-expand-stdproc) - ("label" "LABEL" simula-expand-keyword) - ("last" "Last" simula-expand-stdproc) - ("lastitem" "LastItem" simula-expand-stdproc) - ("lastloc" "LastLoc" simula-expand-stdproc) - ("le" "LE" simula-expand-keyword) - ("length" "Length" simula-expand-stdproc) - ("letter" "Letter" simula-expand-stdproc) - ("line" "Line" simula-expand-stdproc) - ("linear" "Linear" simula-expand-stdproc) - ("linesperpage" "LinesPerPage" simula-expand-stdproc) - ("link" "Link" simula-expand-stdproc) - ("linkage" "Linkage" simula-expand-stdproc) - ("ln" "Ln" simula-expand-stdproc) - ("locate" "Locate" simula-expand-stdproc) - ("location" "Location" simula-expand-stdproc) - ("lock" "Lock" simula-expand-stdproc) - ("locked" "Locked" simula-expand-stdproc) - ("log10" "Log10" simula-expand-stdproc) - ("long" "LONG" simula-expand-keyword) - ("lowcase" "LowCase" simula-expand-stdproc) - ("lowerbound" "LowerBound" simula-expand-stdproc) - ("lowten" "LowTen" simula-expand-stdproc) - ("lt" "LT" simula-expand-keyword) - ("main" "Main" simula-expand-stdproc) - ("max" "Max" simula-expand-stdproc) - ("maxint" "MaxInt" simula-expand-stdproc) - ("maxlongreal" "MaxLongReal" simula-expand-stdproc) - ("maxloc" "MaxLoc" simula-expand-stdproc) - ("maxrank" "MaxRank" simula-expand-stdproc) - ("maxreal" "MaxReal" simula-expand-stdproc) - ("min" "Min" simula-expand-stdproc) - ("minint" "MinInt" simula-expand-stdproc) - ("minlongreal" "MinLongReal" simula-expand-stdproc) - ("minrank" "MinRank" simula-expand-stdproc) - ("minreal" "MinReal" simula-expand-stdproc) - ("mod" "Mod" simula-expand-stdproc) - ("more" "More" simula-expand-stdproc) - ("name" "NAME" simula-expand-keyword) - ("ne" "NE" simula-expand-keyword) - ("negexp" "NegExp" simula-expand-stdproc) - ("new" "NEW" simula-expand-keyword) - ("nextev" "NextEv" simula-expand-stdproc) - ("none" "NONE" simula-expand-keyword) - ("normal" "Normal" simula-expand-stdproc) - ("not" "NOT" simula-expand-keyword) - ("notext" "NOTEXT" simula-expand-keyword) - ("open" "Open" simula-expand-stdproc) - ("or" "OR" simula-expand-keyword) - ("otherwise" "OTHERWISE" simula-electric-keyword) - ("out" "Out" simula-expand-stdproc) - ("outbyte" "OutByte" simula-expand-stdproc) - ("outbytefile" "OutByteFile" simula-expand-stdproc) - ("outchar" "OutChar" simula-expand-stdproc) - ("outfile" "OutFile" simula-expand-stdproc) - ("outfix" "OutFix" simula-expand-stdproc) - ("outfrac" "OutFrac" simula-expand-stdproc) - ("outimage" "OutImage" simula-expand-stdproc) - ("outint" "OutInt" simula-expand-stdproc) - ("outreal" "OutReal" simula-expand-stdproc) - ("outrecord" "OutRecord" simula-expand-stdproc) - ("outtext" "OutText" simula-expand-stdproc) - ("page" "Page" simula-expand-stdproc) - ("passivate" "Passivate" simula-expand-stdproc) - ("poisson" "Poisson" simula-expand-stdproc) - ("pos" "Pos" simula-expand-stdproc) - ("precede" "Precede" simula-expand-stdproc) - ("pred" "Pred" simula-expand-stdproc) - ("prev" "Prev" simula-expand-stdproc) - ("printfile" "PrintFile" simula-expand-stdproc) - ("prior" "PRIOR" simula-expand-keyword) - ("procedure" "PROCEDURE" simula-expand-keyword) - ("process" "Process" simula-expand-stdproc) - ("protected" "PROTECTED" simula-expand-keyword) - ("putchar" "PutChar" simula-expand-stdproc) - ("putfix" "PutFix" simula-expand-stdproc) - ("putfrac" "PutFrac" simula-expand-stdproc) - ("putint" "PutInt" simula-expand-stdproc) - ("putreal" "PutReal" simula-expand-stdproc) - ("qua" "QUA" simula-expand-keyword) - ("randint" "RandInt" simula-expand-stdproc) - ("rank" "Rank" simula-expand-stdproc) - ("reactivate" "REACTIVATE" simula-expand-keyword) - ("real" "REAL" simula-expand-keyword) - ("ref" "REF" simula-expand-keyword) - ("resume" "Resume" simula-expand-stdproc) - ("setaccess" "SetAccess" simula-expand-stdproc) - ("setpos" "SetPos" simula-expand-stdproc) - ("short" "SHORT" simula-expand-keyword) - ("sign" "Sign" simula-expand-stdproc) - ("simset" "SimSet" simula-expand-stdproc) - ("simulaid" "SimulaId" simula-expand-stdproc) - ("simulation" "Simulation" simula-expand-stdproc) - ("sin" "Sin" simula-expand-stdproc) - ("sinh" "SinH" simula-expand-stdproc) - ("sourceline" "SourceLine" simula-expand-stdproc) - ("spacing" "Spacing" simula-expand-stdproc) - ("sqrt" "Sqrt" simula-expand-stdproc) - ("start" "Start" simula-expand-stdproc) - ("step" "STEP" simula-expand-keyword) - ("strip" "Strip" simula-expand-stdproc) - ("sub" "Sub" simula-expand-stdproc) - ("subepsilon" "SubEpsilon" simula-expand-stdproc) - ("suc" "Suc" simula-expand-stdproc) - ("switch" "SWITCH" simula-expand-keyword) - ("sysin" "SysIn" simula-expand-stdproc) - ("sysout" "SysOut" simula-expand-stdproc) - ("tan" "Tan" simula-expand-stdproc) - ("tanh" "TanH" simula-expand-stdproc) - ("terminate_program" "Terminate_Program" simula-expand-stdproc) - ("terminated" "Terminated" simula-expand-stdproc) - ("text" "TEXT" simula-expand-keyword) - ("then" "THEN" simula-electric-keyword) - ("this" "THIS" simula-expand-keyword) - ("time" "Time" simula-expand-stdproc) - ("to" "TO" simula-expand-keyword) - ("true" "TRUE" simula-expand-keyword) - ("uniform" "Uniform" simula-expand-stdproc) - ("unlock" "Unlock" simula-expand-stdproc) - ("until" "UNTIL" simula-expand-keyword) - ("upcase" "Upcase" simula-expand-stdproc) - ("upperbound" "UpperBound" simula-expand-stdproc) - ("value" "VALUE" simula-expand-keyword) - ("virtual" "VIRTUAL" simula-expand-keyword) - ("wait" "Wait" simula-expand-stdproc) - ("when" "WHEN" simula-electric-keyword) - ("while" "WHILE" simula-expand-keyword)))) - -;;; simula.el ends here
--- a/lisp/modes/strokes.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2089 +0,0 @@ -;;; strokes.el -- Control XEmacs through mouse strokes -- -;; Thursday September 4 12:40:41 EDT 1997 - -;; Copyright (C) 1997 Free Software Foundation, Inc. - -;; Author: David Bakhash <cadet@mit.edu> -;; Maintainer: David Bakhash <cadet@mit.edu> -;; Version: 2.4-beta -;; Created: 12 April 1997 -;; Keywords: lisp, mouse, extensions - -;; 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 of the License, or -;; (at your option) any later version. - -;; XEmacs program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with 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: - -;; This package is written for for XEmacs v20.*. This is the strokes -;; package. It is intended to allow the user to control XEmacs by -;; means of mouse strokes. Once strokes is loaded, you can always get -;; help be invoking `strokes-help': - -;; > M-x strokes-help - -;; and you can learn how to use the package. A mouse stroke, for now, -;; can be defined as holding the middle button, for instance, and then -;; moving the mouse in whatever pattern you wish, which you have set -;; XEmacs to understand as mapping to a given command. For example, -;; you may wish the have a mouse stroke that looks like a capital `C' -;; which means `copy-region-as-kill'. Treat strokes just like you do -;; key bindings. For example, XEmacs sets key bindings globally with -;; the `global-set-key' command. Likewise, you can do - -;; > M-x global-set-stroke - -;; to interactively program in a stroke. It would be wise to set the -;; first one to this very command, so that from then on, you invoke -;; `global-set-stroke' with a stroke. likewise, there may eventually -;; be a `local-set-stroke' command, also analogous to `local-set-key'. - -;; You can always unset the last stroke definition with the command - -;; > M-x strokes-unset-last-stroke - -;; and the last stroke that was added to `strokes-global-map' will be -;; removed. - -;; Other analogies between strokes and key bindings are as follows: - -;; 1) To describe a stroke binding, you can type - -;; > M-x describe-stroke - -;; analogous to `describe-key'. It's also wise to have a -;; stroke, like an `h', for help, or a `?', mapped to -;; `describe-stroke'. - -;; 2) stroke bindings are set internally through the Lisp function -;; `define-stroke', similar to the `define-key' function. some -;; examples for a 3x3 stroke grid would be - -;; (define-stroke c-mode-stroke-map -;; '((0 . 0) (1 . 1) (2 . 2)) -;; 'kill-region) -;; (define-stroke strokes-global-map -;; '((0 . 0) (0 . 1) (0 . 2) (1 . 2) (2 . 2)) -;; 'list-buffers) - -;; however, if you would probably just have the user enter in -;; the stroke interactively and then set the stroke to whatever -;; he/she entered. The Lisp function to interactively read a -;; stroke is `strokes-read-stroke'. This is especially helpful -;; when you're on a fast computer that can handle a 9x9 stroke -;; grid. - -;; NOTE: only global stroke bindings are currently implemented, -;; however mode- and buffer-local stroke bindings may eventually -;; be implemented in a future version. - -;; The important variables to be aware of for this package are listed -;; below. They can all be altered through the customizing package via - -;; > M-x customize - -;; and customizing the group named `strokes'. You can also read -;; documentation on the variables there. - -;; `strokes-minimum-match-score' (determines the threshold of error -;; that makes a stroke acceptable or unacceptable. If your strokes -;; aren't matching, then you should raise this variable. - -;; `strokes-grid-resolution' (determines the grid dimensions that you -;; use when defining/reading strokes. The finer the grid your -;; computer can handle, the more you can do, but even a 3x3 grid is -;; pretty cool.) The default value (7) should be fine for most decent -;; computers. NOTE: This variable should not be set to a number less -;; than 3. - -;; `strokes-display-strokes-buffer' will allow you to hide the strokes -;; buffer when doing simple strokes. This is a speedup for slow -;; computers as well as people who don't want to see their strokes. - -;; If you find that your mouse is accelerating too fast, you can -;; execute the UNIX X command to slow it down. A good possibility is - -;; % xset m 5/4 8 - -;; which seems, heuristically, to work okay, without much disruption. - -;; Whenever you load in the strokes package, you will be able to save -;; what you've done upon exiting XEmacs. You can also do - -;; > M-x save-strokes - -;; and it will save your strokes in ~/.strokes, or you may wish to -;; change this by setting the variable `strokes-file'. - -;; Note that internally, all of the routines that are part of this -;; package are able to deal with complex strokes, as they are a -;; superset of simple strokes. However, the default of this package -;; will map mouse button2 to the command `strokes-do-stroke', and NOT -;; `strokes-do-complex-stroke'. If you wish to use complex strokes, -;; you will have to override this key mapping. Complex strokes are -;; terminated with mouse button3. The strokes package will not -;; interfere with `mouse-yank', but you may want to examine how this -;; is done (see the variable `strokes-click-command') - -;; To get strokes to work as part of your your setup, then you'll have -;; put the strokes package in your load-path (preferably -;; byte-compiled) and then add the following to your .emacs file (or -;; wherever you put XEmacs-specific startup preferences): - -;; (and (console-on-window-system-p) -;; (require 'strokes)) - -;; Once loaded, you can start stroking. You can also toggle between -;; strokes mode by simple typing - -;; > M-x strokes-mode - -;; I am now in the process of porting this package to Emacs. I also -;; hope that, with the help of others, this package will be useful in -;; entering in pictographic-like language text using the mouse -;; (i.e. Korean). Japanese and Chinese are a bit trickier, but I'm -;; sure that with help it can be done. The next version will allow -;; the user to enter strokes which "remove the pencil from the paper" -;; so to speak, so one character can have multiple strokes. - -;; You can read more about strokes at: - -;; http://www.mit.edu/people/cadet/strokes-help.html - -;; If you're interested in using strokes for writing English into -;; XEmacs using strokes, then you'll want to read about it on the web -;; page above or just download from -;; http://www.mit.edu/people/cadet/strokes-abc.el, which is nothing -;; but a file with some helper commands for inserting alphanumerics -;; and punctuation. - -;; Great thanks to Rob Ristroph for his generosity in letting me use -;; his PC to develop this, Jason Johnson for his help in algorithms, -;; Euna Kim for her help in Korean, and massive thanks to the helpful -;; guys on the help instance on athena (zeno, jered, amu, gsstark, -;; ghudson, etc) Special thanks to Steve Baur, Kyle Jones, and Hrvoje -;; Niksic for all their help. And special thanks to Dave Gillespie -;; for all the elisp help--he is responsible for helping me use the cl -;; macros at (near) max speed. - -;; Tasks: (what I'm getting ready for future version)... -;; 2) use 'strokes-read-complex-stroke for korean, etc. -;; 4) buffer-local 'strokes-local-map, and mode-stroke-maps would be nice -;; 6) add some hooks, like `strokes-read-stroke-hook' -;; 7) See what people think of the factory settings. Should I change -;; them? They're all pretty arbitrary in a way. I guess they -;; should be minimal, but computers are getting lots faster, and -;; if I choose the defaults too conservatively, then strokes will -;; surely disappoint some people on decent machines (until they -;; figure out M-x customize). I need feedback. -;; Other: I always have the most beta version of strokes, so if you -;; want it just let me know. - -;;; Change Log: - -;; 1.3: provided user variable `strokes-use-strokes-buffer' to let -;; users hide the strokes and strokes buffer when entering simple -;; strokes. -;; 1.3: cleaned up most leaks. -;; 1.3: with Jari Aalto's help, cleaned up overall program. -;; 1.3: added `strokes-help' for help on strokes -;; 1.3: fixed 'strokes-load-hook bug -;; 1.3: email address change: now <cadet@mit.edu> -;; 1.3: added `strokes-report-bug' based on efs/dired's -;; `dired-report-bug' -;; 1.3: added more dialog-box queries for mouse-event stuff. -;; 1.4: allowed strokes to invoke kbd macros as well (thanks gsstark!) -;; 2.0: fixed up ordering of certain functions. -;; 2.0: fixed bug applying to strokes in dedicated and minibuffer -;; windows. -;; 2.0: punted the C-h way of invoking strokes help routines. -;; 2.0: fixed `strokes-define-stroke' so it would error check against -;; defining strokes that were too short (really clicks) 2.0: -;; added `strokes-toggle-strokes-buffer' interactive function -;; 2.0: added `customize' support, thanks to patch from Hrvoje -;; (thanks) -;; 2.1: strokes no longer forces `mouse-yank-at-point' to t on -;; mouse-yank (i.e. `mouse-yank-at-point' is up to you again) -;; 2.1: toggling strokes-mode off and then back on no longer deletes -;; the strokes that you programmed in but didn't save before -;; toggling off strokes-mode. -;; 2.1: advised may functions for modes like VM and w3 so that they -;; too can use strokes, while still maintaining old button2 -;; functionality. -;; 2.1: with Steve's help, got the autoload for `strokes-mode' and -;; fixed up the package so loading it does not enable strokes -;; until user calls `strokes-mode'. -;; 2.2: made sure that abbrev-mode was off in the ` *strokes*' buffer -;; 2.2: added more dired advice for mouse permissions commands -;; 2.2: added some checks to see if saving strokes is really necessary -;; so the user doesn't get prompted aimlessly. -;; 2.2: change the `strokes-lift' symbol to a keyword of value -;; `:strokes-lift' for legibility. IF YOUR OLD STROKES DON'T -;; WORK, THIS IS PROBABLY WHY. -;; 2.2: I might have to change this back to `'strokes-lift' because -;; the keyword fails in emacs, though I don't know why. -;; 2.2: `strokes-describe-stroke' is nicer during recursive edits -;; 2.2: provided `strokes-fill-stroke' to fill in empty spaces of strokes -;; as an important step towards platform (speed) independence. -;; Because of this, I moved the global setting of -;; `strokes-last-stroke' from -;; `strokes-eliminate-consecutive-redundancies' to -;; `strokes-fill-stroke' since the latter comes later in -;; processing a user stroke. -;; 2.2: Finally changed the defaults, so now `strokes-grid-resolution' is 9 -;; and `strokes-minimum-match-score' is 1000 by default. This -;; will surely mess some people up, but if so, just set it back -;; w/ M-x customize. -;; 2.2: Fixed up the mechanism for updating the -;; `strokes-window-configuration'. Now it only uses one function -;; (`strokes-update-window-configuration') which does it all, and -;; much more efficiently (thanks RMS!). -;; 2.2 Fixed up the appearance of the *strokes* buffer so that there -;; are no ugly line truncations, and I got rid of the bug which -;; would draw the stroke on the wrong line. I still wish that -;; `event-closest-point' was smarter. In fact, -;; `event-closest-point' does *not* do what its name suggests. -;; 2.3 Added more to `strokes-update-window-configuration' so it goes -;; to hell less often -;; 2.3 `strokes-mode' no longer will undefined keys unless it's sure -;; that the user had had them mapped to a strokes command. -;; 2.3 Added more magic autoload statements so strokes work more -;; smoothly. similarly, I made strokes-mode turn itself on when -;; the user defines a stroke (thanks Hrvoje). -;; 2.3 Added "Strokes" to the modeline when strokes is on, and allow -;; toggling strokes with mouse button2. -;; 2.3 Added `list-strokes', which is a really nice function which -;; graphically lists all the strokes that the user has defined -;; and their corresponding commands. `list-strokes' will -;; appropriately colorize the pixmaps to display some time info. -;; 2.4 Added all new functionality to strokes by allowing the user to -;; enter strokes in graphically into XEmacs, allowing true graphic -;; editing, Chinese/Japanese, etc. User simply uses C-button2 to -;; draw strokes (function: `strokes-compose-complex-stroke'). Then -;; after the glyph gets inserted into the current buffer at (point), -;; the use can treat that glyph as any other character, and -;; copy/paste/delete/undo, etc. Also, when the user would like to -;; save/send the glyphs (to other XEmacs users, of course), he/she -;; can use the helper functions: -;; -;; i. M-x strokes-encode-buffer -- Ascii-encodes and compresses -;; strokes to base-64. -;; ii. M-x strokes-decode-buffer -- Decodes ascii-encoded strokes -;; back into glyphs. -;; 2.4 With help from Kyle fixed the itimer (timeout event) bug, where I -;; forgot to check for timeouts. -;; 2.4 Around this time, made a successful port of strokes.el for emacs. -;; 2.4 Made added `strokes-xpm-header' as a variable. -;; 2.4 Changed the default value of `strokes-character' from `o' to -;; `@' since it looks nicer when drawn. -;; 2.4 Changed `strokes-click-p' so that it considers only a stroke -;; of length <= 1 a click, as opposed to a length 2 being a -;; click. -;; 2.4 Totally made the the function `strokes-read-stroke' (and a bit -;; on `strokes-read-complex-stroke') more efficient and robust, -;; making the former use the optional event passed to it, and -;; thus not losing the first mouse event position when reading a -;; stroke on the fly. -;; 2.4 Finally fixed the mouse-yank / mouse-yank-at-point bug (after -;; months of struggling with it). I simply inserted a (sit-for 0) -;; before the (command-execute strokes-click-command) and that -;; patched it up. I'd thought that it was a kludge, but I later -;; found out that it wasn't, as redisplay has several states, and -;; command-execute often must decide which of two states must be -;; considered when executing a command. The (sit-for 0) merely -;; allowed redisplay to be sure to wait for the ` *strokes*' -;; buffer to vanish before executing the command (thanks for the -;; explanation of why my frobbing worked Kyle). Fixing this bug -;; also (magically) fixed the bug which prevented strokes from -;; executing a stroke in a mode which had it's own binding for -;; button-2, such as w3 when the variable -;; `strokes-use-strokes-buffer' is non-nil. It used to be that -;; if you chose to view your strokes, then you couldn't use -;; strokes properly in modes like VM or w3. Now you can! -;; 2.4 Replaced `kill-emacs-hook' with `kill-emacs-query-functions' -;; for prompting the user to save his/her strokes, since -;; `kill-emacs-hook' was not the right hook to use. -;; 2.4 Having `strokes-update-window-configuration' bound to -;; `select-frame-hook' was a heavy function for such a commonly -;; run hook -- especially since event-Xt.c (?) will add the -;; eval-event to the event queue. So the effect was that if XEmacs -;; was doing an interpreter-intensive task while the user (re)selected -;; the frame n times, then the intensive window config updating -;; took place n times. So to deal, I put in some extra checks to -;; see if the frame parameters really changed, making an update -;; worthwhile. See `strokes-update-window-configuration-plist'. -;; 2.4 For XEmacs 20.*, all hashtables were changed to char-tables, -;; since this is more modern, more efficient, and faster. God only -;; knows how inefficient the hash function was before the advent of -;; char-tables. I also did this out of necessity since MIT's -;; version of XEmacs-20.2 was hashtable-buggy. - -;;; Code: - -;;; Requirements and provisions... - -(autoload 'reporter-submit-bug-report "reporter") -(autoload 'mail-position-on-field "sendmail") -(eval-when-compile - (mapc 'require '(xpm-mode pp annotations reporter advice view-less))) - -;;; Constants... - -(defconst strokes-version "2.4-beta") - -(defconst strokes-bug-address "cadet@mit.edu") - -(defconst strokes-lift :strokes-lift - "Symbol representing a stroke lift event for complex strokes. -Complex strokes are those which contain two or more simple strokes. -This will be useful for when XEmacs understands Chinese.") - -(defconst strokes-xpm-header "/* XPM */ -static char * stroke_xpm[] = { -/* width height ncolors cpp [x_hot y_hot] */ -\"33 33 9 1 26 23\", -/* colors */ -\" c none s none\", -\"* c #000000 s foreground\", -\"R c #FFFF00000000\", -\"O c #FFFF80000000\", -\"Y c #FFFFFFFF0000\", -\"G c #0000FFFF0000\", -\"B c #00000000FFFF\", -\"P c #FFFF0000FFFF\", -\". c #45458B8B0000\", -/* pixels */\n" - "The header to all xpm buffers created by strokes") - -;;; user variables... - -(defgroup strokes nil - "Control Emacs through mouse strokes." - :group 'mouse - :group 'lisp - :group 'extensions) - -;; This is an internal variable, but we defcustom it so Customize can -;; use it. -;;;###autoload -(defcustom strokes-mode nil - "Non-nil when `strokes' is globally enabled." - :type 'boolean - :set (lambda (symbol value) - (strokes-mode (or value 0))) - :initialize 'custom-initialize-default - :require 'strokes - :group 'strokes) - -(defcustom strokes-modeline-string " Strokes" - "*Modeline identification when strokes are on \(default is \" Strokes\"\)." - :type 'string - :group 'strokes) - -(defcustom strokes-character ?@ - "*Character used when drawing strokes in the strokes buffer. -\(The default is lower-case `@', which works okay\)." - :type 'character - :group 'strokes) - -(defcustom strokes-minimum-match-score 1000 - "*Minimum score for a stroke to be considered a possible match. -Requiring a perfect match would set this variable to 0. -The default value is 1000, but it's mostly dependent on how precisely -you manage to replicate your user-defined strokes. It also depends on -the value of `strokes-grid-resolution', since a higher grid resolution -will correspond to more sample points, and thus more distance -measurements. Usually, this is not a problem since you first set -`strokes-grid-resolution' based on what your computer seems to be able -to handle (though the defaults are usually more than sufficent), and -then you can set `strokes-minimum-match-score' to something that works -for you. The only purpose of this variable is to insure that if you -do a bogus stroke that really doesn't match any of the predefined -ones, then strokes should NOT pick the one that came closest." - :type 'integer - :group 'strokes) - -(defcustom strokes-grid-resolution 9 - "*Integer defining dimensions of the stroke grid. -The grid is a square grid, where STROKES-GRID-RESOLUTION defaults to -`9', making a 9x9 grid whose coordinates go from (0 . 0) on the top -left to ((STROKES-GRID-RESOLUTION - 1) . (STROKES-GRID-RESOLUTION - 1)) -on the bottom right. The greater the resolution, the more intricate -your strokes can be. -NOTE: This variable should be odd and MUST NOT be less than 3 and need - not be greater than 33, which is the resolution of the pixmaps. -WARNING: Changing the value of this variable will gravely affect the - strokes you have already programmed in. You should try to - figure out what it should be based on your needs and on how - quick the particular platform(s) you're operating on, and - only then start programming in your custom strokes." - :type 'integer - :group 'strokes) - -(defcustom strokes-file "~/.strokes" - "*File containing saved strokes for stroke-mode (default is ~/.strokes)." - :type 'file - :group 'strokes) - -(defcustom strokes-buffer-name " *strokes*" - "The buffer that the strokes take place in (default is ` *strokes*')." - :type 'string - :group 'strokes) - -(defcustom strokes-use-strokes-buffer t - "*If non-nil, the strokes buffer is used and strokes are displayed. -If nil, strokes will be read the same, however the user will not be -able to see the strokes. This be helpful for people who don't like -the delay in switching to the strokes buffer." - :type 'boolean - :group 'strokes) - -(defcustom strokes-click-command 'mouse-yank - "*Command to execute when stroke is actually a `click' event. -This is set to `mouse-yank' by default." - :type 'function - :group 'strokes) - -;;; internal variables... - -(defvar strokes-window-configuration nil - "The special window configuration used when entering strokes. -This is set properly in the function `strokes-update-window-configuration'.") - -(defvar strokes-window-configuration-plist - (list 'frame nil 'frame-height nil 'frame-width nil) - "Plist describing the state of the current strokes-window-configuration. -The plist consists of the following keys: - -'frame Frame to draw strokes in. -'frame-height Height of the frame. -'frame-width Width of the frame.") - -(defvar strokes-last-stroke nil - "Last stroke entered by the user. -Its value gets set every time the function -`strokes-fill-stroke' gets called, -since that is the best time to set the variable") - -(defvar strokes-global-map '() - "Association list of strokes and their definitions. -Each entry is (STROKE . COMMAND) where STROKE is itself a list of -coordinates (X . Y) where X and Y are lists of positions on the -normalized stroke grid, with the top left at (0 . 0). COMMAND is the -corresponding interactive function") - -(defvar strokes-load-hook nil - "Function or functions to be called when `strokes' is loaded.") - -;;; ### NOT IMPLEMENTED YET ### -;;(defvar edit-strokes-menu -;; '("Edit-Strokes" -;; ["Add stroke..." strokes-global-set-stroke t] -;; ["Delete stroke..." strokes-edit-delete-stroke t] -;; ["Change stroke" strokes-smaller t] -;; ["Change definition" strokes-larger t] -;; ["[Re]List Strokes chronologically" strokes-list-strokes t] -;; ["[Re]List Strokes alphabetically" strokes-list-strokes t] -;; ["Quit" strokes-edit-quit t] -;; )) - -;;; Macros... - -(defmacro strokes-while-inhibiting-garbage-collector (&rest forms) - "Execute FORMS without interference from the garbage collector." - `(let ((gc-cons-threshold 134217727)) - ,@forms)) - -(defsubst strokes-click-p (stroke) - "Non-nil if STROKE is really click." - (< (length stroke) 2)) - -;;; old, but worked pretty good (just in case)... -;;(defmacro strokes-define-stroke (stroke-map stroke def) -;; "Add STROKE to STROKE-MAP alist with given command DEF" -;; (list 'if (list '< (list 'length stroke) 3) -;; (list 'error -;; "That's a click, not a stroke. See `strokes-click-command'") -;; (list 'setq stroke-map (list 'cons (list 'cons stroke def) -;; (list 'remassoc stroke stroke-map))))) - -(defmacro strokes-define-stroke (stroke-map stroke def) - "Add STROKE to STROKE-MAP alist with given command DEF." - `(if (strokes-click-p ,stroke) - (error "That's a click, not a stroke; see `strokes-click-command'") - (setq ,stroke-map (cons (cons ,stroke ,def) - (remassoc ,stroke ,stroke-map))))) - -(defalias 'define-stroke 'strokes-define-stroke) - -(defsubst strokes-square (x) - "Returns the square of the number X" - (* x x)) - -(defsubst strokes-distance-squared (p1 p2) - "Gets the distance (squared) between to points P1 and P2. -P1 and P2 are cons cells in the form (X . Y)." - (let ((x1 (car p1)) - (y1 (cdr p1)) - (x2 (car p2)) - (y2 (cdr p2))) - (+ (strokes-square (- x2 x1)) - (strokes-square (- y2 y1))))) - -;;; Advice for various functions... - -;; I'd originally wanted to write a macro that would just take in the -;; generic functions which use mouse button2 in various modes. Most -;; of them are identical in form: they take an event as the single -;; argument and then do their thing. I tried writing a macro that -;; looked something like this, but failed. Advice just ain't that -;; easy. The one that bugged me the most was `Manual-follow-xref', -;; because that had &rest arguments, and I didn't know how to work -;; around it in defadvice. However, I was able to fix up most of the -;; important modes (i.e. the ones I use all the time). One `bug' in -;; the program that I just can't seem to figure out is why I can only -;; advise other button2 functions successfully when the variable -;; `strokes-use-strokes-buffer' is nil. I did all the -;; save-excursion/save-window-excursion stuff SPECIFICALLY so that -;; using the strokes buffer or not would absolutely not affect any -;; other part of the program. If someone can figure out how to make -;; the following advices work w/ regardless of that variable -;; `strokes-use-strokes-buffer', then that would be a great victory. -;; If someone out there would be kind enough to make the commented -;; code below work, I'd be grateful. By the way, I put the `protect' -;; keywords there to insure that if a stroke went bad, then -;; `strokes-click-command' would be set back. If this isn't -;; necessary, then feel free to let me know. - -;; For what follows, I really wanted something that would work like this: - -;;(strokes-fix-button2 'vm-mouse-button-2) - -;; Or even better, I could have simply done something like: - -;;(mapcar 'strokes-fix-button2 -;; '(vm-mouse-button-2 -;; rmail-summary-mouse-goto-msg -;; <rest of them>)) - -;;; With help from Hans (author of advice.el)... -(defmacro strokes-fix-button2-command (command) - "Fix COMMAND so that it can also work with strokes. -COMMAND must take one event argument. -Example of how one might fix up a command that's bound to button2 -and which is an interactive funcion of one event argument: - -\(strokes-fix-button2-command 'vm-mouse-button-2)" - (let ((command (eval command))) - `(progn - (defadvice ,command (around strokes-fix-button2 compile preactivate) - ,(format "Fix %s to work with strokes." command) - (let ((strokes-click-command - ',(intern (format "ad-Orig-%s" command)))) - (strokes-do-stroke (ad-get-arg 0))))))) - -(defvar strokes-insinuated nil) - -(defun strokes-insinuate () - "Insinuate Emacs with strokes advices." - (unless strokes-insinuated - (strokes-fix-button2-command 'vm-mouse-button-2) - (strokes-fix-button2-command 'rmail-summary-mouse-goto-msg) - (strokes-fix-button2-command 'Buffer-menu-mouse-select) - (strokes-fix-button2-command 'w3-widget-button-click) - (strokes-fix-button2-command 'widget-image-button-press) - (strokes-fix-button2-command 'Info-follow-clicked-node) - (strokes-fix-button2-command 'compile-mouse-goto-error) - (strokes-fix-button2-command 'gdbsrc-select-or-yank) - (strokes-fix-button2-command 'hypropos-mouse-get-doc) - (strokes-fix-button2-command 'gnus-mouse-pick-group) - (strokes-fix-button2-command 'gnus-mouse-pick-article) - (strokes-fix-button2-command 'gnus-article-push-button) - (strokes-fix-button2-command 'dired-mouse-find-file) - (strokes-fix-button2-command 'url-dired-find-file-mouse) - (strokes-fix-button2-command 'dired-u-r-mouse-toggle) - (strokes-fix-button2-command 'dired-u-w-mouse-toggle) - (strokes-fix-button2-command 'dired-u-x-mouse-toggle) - (strokes-fix-button2-command 'dired-g-r-mouse-toggle) - (strokes-fix-button2-command 'dired-g-w-mouse-toggle) - (strokes-fix-button2-command 'dired-g-x-mouse-toggle) - (strokes-fix-button2-command 'dired-o-r-mouse-toggle) - (strokes-fix-button2-command 'dired-o-w-mouse-toggle) - (strokes-fix-button2-command 'isearch-yank-x-selection) - (strokes-fix-button2-command 'occur-mode-mouse-goto) - (strokes-fix-button2-command 'cvs-mouse-find-file)) - (setq strokes-insinuated t)) - -;;; I can fix the customize widget button click, but then -;;; people will get confused when they try to customize -;;; strokes with the mouse and customize tells them that -;;; `strokes-click-command' is mapped to `ad-Orig-widget-button-click' -;;(strokes-fix-button2-command 'widget-button-click) - -;;; without the advice, each advised function would look like... -;;(defadvice vm-mouse-button-2 (around vm-strokes activate protect) -;; "Allow strokes to work in VM." -;; (if strokes-use-strokes-buffer -;; ;; then strokes is no good and we'll have to use the original -;; ad-do-it -;; ;; otherwise, we can make strokes work too... -;; (let ((strokes-click-command 'ad-Orig-vm-mouse-button-2)) -;; (strokes-do-stroke (ad-get-arg 0))))) - -;;; Functions... - -(defun strokes-lift-p (object) - "Return non-nil if object is a stroke-lift." - (eq object strokes-lift)) - -(defun strokes-unset-last-stroke () - "Undo the last stroke definition." - (interactive) - (let ((command (cdar strokes-global-map))) - (if (y-or-n-p-maybe-dialog-box - (format "really delete last stroke definition, defined to `%s'? " - command)) - (progn - (setq strokes-global-map (cdr strokes-global-map)) - (message "That stroke has been deleted")) - (message "Nothing done")))) - -;;;###autoload -(defun strokes-global-set-stroke (stroke command) - "Interactively give STROKE the global binding as COMMAND. -Operated just like `global-set-key', except for strokes. -COMMAND is a symbol naming an interactively-callable function. STROKE -is a list of sampled positions on the stroke grid as described in the -documentation for the `strokes-define-stroke' function." - (interactive - (list - (and (or strokes-mode (strokes-mode t)) - (strokes-read-complex-stroke - "Define a new stroke. Draw with button1 (or 2). End with button3...")) - (read-command-or-command-sexp "command to map stroke to: "))) - (strokes-define-stroke strokes-global-map stroke command)) - -;;;###autoload -(defalias 'global-set-stroke 'strokes-global-set-stroke) - -;;(defun global-unset-stroke (stroke); FINISH THIS DEFUN! -;; "delete all strokes matching STROKE from `strokes-global-map', -;; letting the user input -;; the stroke with the mouse" -;; (interactive -;; (list -;; (strokes-read-stroke "Enter the stroke you want to delete..."))) -;; (strokes-define-stroke 'strokes-global-map stroke command)) - -(defun strokes-get-grid-position (stroke-extent position &optional grid-resolution) - "Map POSITION to a new grid position based on its STROKE-EXTENT and GRID-RESOLUTION. -STROKE-EXTENT as a list \(\(XMIN . YMIN\) \(XMAX . YMAX\)\). -If POSITION is a `strokes-lift', then it is itself returned. -Optional GRID-RESOLUTION may be used in place of STROKES-GRID-RESOLUTION. -The grid is a square whose dimesion is [0,GRID-RESOLUTION)." - (cond ((consp position) ; actual pixel location - (let ((grid-resolution (or grid-resolution strokes-grid-resolution)) - (x (car position)) - (y (cdr position)) - (xmin (caar stroke-extent)) - (ymin (cdar stroke-extent)) - ;; the `1+' is there to insure that the - ;; formula evaluates correctly at the boundaries - (xmax (1+ (caadr stroke-extent))) - (ymax (1+ (cdadr stroke-extent)))) - (cons (floor (* grid-resolution - (/ (float (- x xmin)) - (- xmax xmin)))) - (floor (* grid-resolution - (/ (float (- y ymin)) - (- ymax ymin))))))) - ((strokes-lift-p position) ; stroke lift - strokes-lift))) - -(defun strokes-get-stroke-extent (pixel-positions) - "From a list of absolute PIXEL-POSITIONS, returns absolute spatial extent. -The return value is a list ((XMIN . YMIN) (XMAX . YMAX))." - (if pixel-positions - (let ((xmin (caar pixel-positions)) - (xmax (caar pixel-positions)) - (ymin (cdar pixel-positions)) - (ymax (cdar pixel-positions)) - (rest (cdr pixel-positions))) - (while rest - (if (consp (car rest)) - (let ((x (caar rest)) - (y (cdar rest))) - (if (< x xmin) - (setq xmin x)) - (if (> x xmax) - (setq xmax x)) - (if (< y ymin) - (setq ymin y)) - (if (> y ymax) - (setq ymax y)))) - (setq rest (cdr rest))) - (let ((delta-x (- xmax xmin)) - (delta-y (- ymax ymin))) - (if (> delta-x delta-y) - (setq ymin (- ymin - (/ (- delta-x delta-y) - 2)) - ymax (+ ymax - (/ (- delta-x delta-y) - 2))) - (setq xmin (- xmin - (/ (- delta-y delta-x) - 2)) - xmax (+ xmax - (/ (- delta-y delta-x) - 2)))) - (list (cons xmin ymin) - (cons xmax ymax)))) - nil)) - -(defun strokes-eliminate-consecutive-redundancies (entries) - "Returns a list with no consecutive redundant entries." - ;; defun a grande vitesse grace a Dave G. - (loop for element on entries - if (not (equal (car element) (cadr element))) - collect (car element))) -;; (loop for element on entries -;; nconc (if (not (equal (car el) (cadr el))) -;; (list (car el))))) -;; yet another (orig) way of doing it... -;; (if entries -;; (let* ((current (car entries)) -;; (rest (cdr entries)) -;; (non-redundant-list (list current)) -;; (next nil)) -;; (while rest -;; (setq next (car rest)) -;; (if (equal current next) -;; (setq rest (cdr rest)) -;; (setq non-redundant-list (cons next non-redundant-list) -;; current next -;; rest (cdr rest)))) -;; (nreverse non-redundant-list)) -;; nil)) - -(defun strokes-renormalize-to-grid (positions &optional grid-resolution) - "Map POSITIONS to a new grid whose dimensions are based on GRID-RESOLUTION. -POSITIONS is a list of positions and stroke-lifts. -Optional GRID-RESOLUTION may be used in place of STROKES-GRID-RESOLUTION. -The grid is a square whose dimesion is [0,GRID-RESOLUTION)." - (or grid-resolution (setq grid-resolution strokes-grid-resolution)) - (let ((stroke-extent (strokes-get-stroke-extent positions))) - (mapcar (function - (lambda (pos) - (strokes-get-grid-position stroke-extent pos grid-resolution))) - positions))) - -(defun strokes-fill-stroke (unfilled-stroke &optional force) - "Fill in missing grid locations in the list of UNFILLED-STROKE. -If FORCE is non-nil, then fill the stroke even if it's `stroke-click'. -NOTE: This is where the global variable `strokes-last-stroke' is set." - (setq strokes-last-stroke ; this is global - (if (and (strokes-click-p unfilled-stroke) - (not force)) - unfilled-stroke - (loop for grid-locs on unfilled-stroke - nconc (let* ((current (car grid-locs)) - (current-is-a-point-p (consp current)) - (next (cadr grid-locs)) - (next-is-a-point-p (consp next)) - (both-are-points-p (and current-is-a-point-p - next-is-a-point-p)) - (x1 (and current-is-a-point-p - (car current))) - (y1 (and current-is-a-point-p - (cdr current))) - (x2 (and next-is-a-point-p - (car next))) - (y2 (and next-is-a-point-p - (cdr next))) - (delta-x (and both-are-points-p - (- x2 x1))) - (delta-y (and both-are-points-p - (- y2 y1))) - (slope (and both-are-points-p - (if (zerop delta-x) - nil ; undefined vertical slope - (/ (float delta-y) - delta-x))))) - (cond ((not both-are-points-p) - (list current)) - ((null slope) ; undefinded vertical slope - (if (>= delta-y 0) - (loop for y from y1 below y2 - collect (cons x1 y)) - (loop for y from y1 above y2 - collect (cons x1 y)))) - ((zerop slope) ; (= y1 y2) - (if (>= delta-x 0) - (loop for x from x1 below x2 - collect (cons x y1)) - (loop for x from x1 above x2 - collect (cons x y1)))) - ((>= (abs delta-x) (abs delta-y)) - (if (> delta-x 0) - (loop for x from x1 below x2 - collect (cons x - (+ y1 - (round (* slope - (- x x1)))))) - (loop for x from x1 above x2 - collect (cons x - (+ y1 - (round (* slope - (- x x1)))))))) - (t ; (< (abs delta-x) (abs delta-y)) - (if (> delta-y 0) - (loop for y from y1 below y2 - collect (cons (+ x1 - (round (/ (- y y1) - slope))) - y)) - (loop for y from y1 above y2 - collect (cons (+ x1 - (round (/ (- y y1) - slope))) - y)))))))))) - -(defun strokes-rate-stroke (stroke1 stroke2) - "Rates STROKE1 with STROKE2 and returns a score based on a distance metric. -Note: the rating is an error rating, and therefore, a return of 0 -represents a perfect match. Also note that the order of stroke -arguments is order-independent for the algorithm used here." - (if (and stroke1 stroke2) - (let ((rest1 (cdr stroke1)) - (rest2 (cdr stroke2)) - (err (strokes-distance-squared (car stroke1) - (car stroke2)))) - (while (and rest1 rest2) - (while (and (consp (car rest1)) - (consp (car rest2))) - (setq err (+ err - (strokes-distance-squared (car rest1) - (car rest2))) - stroke1 rest1 - stroke2 rest2 - rest1 (cdr stroke1) - rest2 (cdr stroke2))) - (cond ((and (strokes-lift-p (car rest1)) - (strokes-lift-p (car rest2))) - (setq rest1 (cdr rest1) - rest2 (cdr rest2))) - ((strokes-lift-p (car rest2)) - (while (consp (car rest1)) - (setq err (+ err - (strokes-distance-squared (car rest1) - (car stroke2))) - rest1 (cdr rest1)))) - ((strokes-lift-p (car rest1)) - (while (consp (car rest2)) - (setq err (+ err - (strokes-distance-squared (car stroke1) - (car rest2))) - rest2 (cdr rest2)))))) - (if (null rest2) - (while (consp (car rest1)) - (setq err (+ err - (strokes-distance-squared (car rest1) - (car stroke2))) - rest1 (cdr rest1)))) - (if (null rest1) - (while (consp (car rest2)) - (setq err (+ err - (strokes-distance-squared (car stroke1) - (car rest2))) - rest2 (cdr rest2)))) - (if (or (strokes-lift-p (car rest1)) - (strokes-lift-p (car rest2))) - (setq err nil) - err)) - nil)) - -(defun strokes-match-stroke (stroke stroke-map) - "Finds the best matching command of STROKE in STROKE-MAP. -Returns the corresponding match as (COMMAND . SCORE)." - (if (and stroke stroke-map) - (let ((score (strokes-rate-stroke stroke (caar stroke-map))) - (command (cdar stroke-map)) - (map (cdr stroke-map))) - (while map - (let ((newscore (strokes-rate-stroke stroke (caar map)))) - (if (or (and newscore score (< newscore score)) - (and newscore (null score))) - (setq score newscore - command (cdar map))) - (setq map (cdr map)))) - (if score - (cons command score) - nil)) - nil)) - -;;;###autoload -(defun strokes-read-stroke (&optional prompt event) - "Read a simple stroke (interactively) and return the stroke. -Optional PROMPT in minibuffer displays before and during stroke reading. -This function will display the stroke interactively as it is being -entered in the strokes buffer if the variable -`strokes-use-strokes-buffer' is non-nil. -Optional EVENT is acceptable as the starting event of the stroke" - (save-excursion - (let ((pix-locs nil) - (grid-locs nil) - (safe-to-draw-p nil)) - (strokes-while-inhibiting-garbage-collector - (if strokes-use-strokes-buffer - ;; switch to the strokes buffer and - ;; display the stroke as it's being read - (save-window-excursion - (set-window-configuration strokes-window-configuration) - (when prompt - (setq event (next-command-event event prompt)) - (or (button-press-event-p event) - (error "You must draw with the mouse"))) - (or event (setq event (next-event nil prompt) - safe-to-draw-p t)) - (unwind-protect - (progn - (while (not (button-release-event-p event)) - (if (mouse-event-p event) - (let ((point (event-closest-point event))) - (if (and point safe-to-draw-p) - ;; we can draw that point - (progn - (goto-char point) - (subst-char-in-region point (1+ point) ?\ strokes-character)) - ;; otherwise, we can start drawing the next time... - (setq safe-to-draw-p t)) - (push (cons (event-x-pixel event) - (event-y-pixel event)) - pix-locs)) - ;; otherwise, if it's not a mouse-event... - (dispatch-event event)) - (setq event (next-event event)))) - ;; protected - ;; clean up strokes buffer and then bury it. - (when (equal (buffer-name) strokes-buffer-name) - (subst-char-in-region (point-min) (point-max) strokes-character ?\ ) - (goto-char (point-min)) - (bury-buffer)))) - ;; Otherwise, don't use strokes buffer and read stroke silently - (when prompt - (setq event (next-command-event event prompt)) - (or (button-press-event-p event) - (error "You must draw with the mouse"))) - (or event (setq event (next-event nil prompt))) - (while (not (button-release-event-p event)) - (if (mouse-event-p event) - (push (cons (event-x-pixel event) - (event-y-pixel event)) - pix-locs) - (dispatch-event event)) - (setq event (next-event event))))) - (setq grid-locs (strokes-renormalize-to-grid (nreverse pix-locs))) - (strokes-fill-stroke (strokes-eliminate-consecutive-redundancies grid-locs))))) - -(defun strokes-read-complex-stroke (&optional prompt event) - "Read a complex stroke (interactively) and return the stroke. -Optional PROMPT in minibuffer displays before and during stroke reading. -Note that a complex stroke allows the user to pen-up and pen-down. This -is implemented by allowing the user to paint with button1 or button2 and -then complete the stroke with button3. -Optional EVENT is acceptable as the starting event of the stroke" - (save-excursion - (save-window-excursion - (strokes-while-inhibiting-garbage-collector - (set-window-configuration strokes-window-configuration) - (let ((pix-locs nil) - (grid-locs nil) - (safe-to-draw-p nil)) - (when prompt - (setq event (next-command-event event prompt)) - (or (button-press-event-p event) - (error "You must draw with the mouse"))) - (or event (setq event (next-event nil prompt) - safe-to-draw-p t)) - (unwind-protect - (progn - (while (not (and (button-press-event-p event) - (eq (event-button event) 3))) - (while (not (button-release-event-p event)) - (if (mouse-event-p event) - (let ((point (event-closest-point event))) - (if (and point safe-to-draw-p) - ;; we can draw that point - (progn - (goto-char point) - (subst-char-in-region point (1+ point) ?\ strokes-character)) - ;; otherwise, we can start drawing the next time... - (setq safe-to-draw-p t)) - (push (cons (event-x-pixel event) - (event-y-pixel event)) - pix-locs)) - (dispatch-event event)) - (setq event (next-event event prompt))) - (push strokes-lift pix-locs) - (while (not (button-press-event-p event)) - (dispatch-event event) - (setq event (next-event event prompt)))) - (setq pix-locs (nreverse (cdr pix-locs))) - ;; minor bug fix here for when user enters ` *strokes*' - ;; buffer with a click instead of a drag... - (when (strokes-lift-p (car pix-locs)) - (setq pix-locs (cdr pix-locs))) - (setq grid-locs (strokes-renormalize-to-grid pix-locs)) - (strokes-fill-stroke - (strokes-eliminate-consecutive-redundancies grid-locs))) - ;; protected - (when (equal (buffer-name) strokes-buffer-name) - (subst-char-in-region (point-min) (point-max) strokes-character ?\ ) - (goto-char (point-min)) - (bury-buffer)))))))) - -(defun strokes-execute-stroke (stroke) - "Given STROKE, execute the command which corresponds to it. -The command will be executed provided one exists for that stroke, -based on the variable `strokes-minimum-match-score'. -If no stroke matches, nothing is done and return value is nil." - (let* ((match (strokes-match-stroke stroke strokes-global-map)) - (command (car match)) - (score (cdr match))) - (cond ((strokes-click-p stroke) - ;; This is the case of a `click' type event. - ;; The `sit-for' is a minor frob that has to do with timing - ;; problems. Without the `sit-for', mouse-yank will not - ;; yank at the proper location if the user opted for - ;; mouse-yank-at-point to be nil (i.e. mouse-yank takes - ;; place at pointer position). The sit-for tells redisplay - ;; to be sure to wait for the `*strokes*' buffer to vanish - ;; from consideration when deciding on a point to be used - ;; for mouse-yank. - (sit-for 0) - (command-execute strokes-click-command)) - ((and match (<= score strokes-minimum-match-score)) - (message "%s" command) - (command-execute command)) - ((null strokes-global-map) - (if (file-exists-p strokes-file) - (and (y-or-n-p-maybe-dialog-box - (format "No strokes loaded. Load `%s'? " - strokes-file)) - (strokes-load-user-strokes)) - (error "No strokes defined; use `global-set-stroke'"))) - (t - (error - "No stroke matches; see variable `strokes-minimum-match-score'") - nil)))) - -;;;###autoload -(defun strokes-do-stroke (event) - "Read a simple stroke from the user and then exectute its command. -This must be bound to a mouse event." - (interactive "e") - (or strokes-mode (strokes-mode t)) - (strokes-execute-stroke (strokes-read-stroke nil event))) - -;;;###autoload -(defun strokes-do-complex-stroke (event) - "Read a complex stroke from the user and then exectute its command. -This must be bound to a mouse event." - (interactive "e") - (or strokes-mode (strokes-mode t)) - (strokes-execute-stroke (strokes-read-complex-stroke nil event))) - -;;;###autoload -(defun strokes-describe-stroke (stroke) - "Displays the command which STROKE maps to, reading STROKE interactively." - (interactive - (list - (strokes-read-complex-stroke - "Enter stroke to describe; end with button3..."))) - (let* ((match (strokes-match-stroke stroke strokes-global-map)) - (command (or (and (strokes-click-p stroke) - strokes-click-command) - (car match))) - (score (cdr match))) - (if (or (and match - (<= score strokes-minimum-match-score)) - (and (strokes-click-p stroke) - strokes-click-command)) - (message "That stroke maps to `%s'" command) - (message "That stroke is undefined")) - (sleep-for 1))) ; helpful for recursive edits - -;;;###autoload -(defalias 'describe-stroke 'strokes-describe-stroke) - -;;;###autoload -(defun strokes-help () - "Get instructional help on using the the `strokes' package." - (interactive) - (with-displaying-help-buffer - (function - (lambda () - (save-excursion - (let ((helpdoc - "This is help for the strokes package. - -If you find something wrong with strokes, or feel that it can be -improved in some way, then please feel free to email me: - -David Bakhash <cadet@mit.edu> - -or just do - -M-x strokes-report-bug - ------------------------------------------------------------- - -** Strokes... - -The strokes package allows you to define strokes (that you make with -the mouse or other pointer device) that XEmacs can interpret as -corresponding to commands, and then executes the commands. It does -character recognition, so you don't have to worry about getting it -right every time. - -Strokes also allows you to compose documents graphically. You can -fully edit documents in Chinese, Japanese, etc. based on XEmacs -strokes. Once you've done so, you can ascii compress-and-encode them -and then safely save them for later use, send letters to friends -(using XEmacs, of course). Strokes will later decode these documents, -extracting the strokes for editing use once again, so the editing -cycle can continue. - -Strokes are easy to program and fun to use. To start strokes going, -you'll want to put the following line in your .emacs file: - -(if window-system - (require 'strokes)) - -This will load strokes when and only when you start XEmacs on a window -system (i.e. that has a pointer (mouse) device, etc.). - -To toggle strokes-mode, you just do - -> M-x strokes-mode - -** Strokes for controlling the behavior of XEmacs... - -When you're ready to start defining strokes, just use the command - -> M-x global-set-stroke - -You will see a ` *strokes*' buffer which is waiting for you to enter in -your stroke. When you enter in the stroke, you draw with button1 or -button2, and then end with button3. Next, you enter in the command -which will be executed when that stroke is invoked. Simple as that. -For now, try to define a stroke to copy a region. This is a popular -edit command, so type - -> M-x global-set-stroke - -Then, in the ` *strokes*' buffer, draw the letter `C' (for `copy') -and then, when it asks you to enter the command to map that to, type - -> copy-region-as-kill - -That's about as hard as it gets. -Remember: paint with button1 or button2 and then end with button3. - -If ever you want to know what a certain strokes maps to, then do - -> M-x describe-stroke - -and you can enter in any arbitrary stroke. Remember: The strokes -package lets you program in simple and complex (multi-lift) strokes. -The only difference is how you *invoke* the two. You will most likely -use simple strokes, as complex strokes were developed for -Chinese/Japanese/Korean. So the middle mouse button (button2) will -invoke the command `strokes-do-stroke' in buffers where button2 doesn't -already have a meaning other than its original, which is `mouse-yank'. -But don't worry: `mouse-yank' will still work with strokes (see the -variable `strokes-click-command'). - -If ever you define a stroke which you don't like, then you can unset -it with the command - -> M-x strokes-unset-last-stroke - -You can always get an idea of what your current strokes look like with -the command - -> M-x list-strokes - -Your strokes will be displayed in alphabetical order (based on command -names) and the beginning of each simple stroke will be marked by a -color dot. Since you may have several simple strokes in a complex -stroke, the dot colors are arranged in the rainbow color sequence, -`ROYGBIV'. If you want a listing of your strokes from most recent -down, then use a prefix argument: - -> C-u M-x list-strokes - -Your strokes are stored as you enter them. They get saved in a file -called ~/.strokes, along with other strokes configuration variables. -You can change this location by setting the variable `strokes-file'. -You will be prompted to save them when you exit XEmacs, or you can save -them with - -> M-x save-strokes - -Your strokes get loaded automatically when you enable `strokes-mode'. -You can also load in your user-defined strokes with - -> M-x load-user-strokes - -** Strokes for pictographic editing... - -If you'd like to create graphical files with strokes, you'll have to -be running XEmacs on a window system, with XPM support. You use the -binding C-button2 to start drawing your strokes. These are just -complex strokes, and thus you continue drawing with buttons 1 or 2 and -end with button-3. Then the stroke glyph gets inserted into the -buffer. You treat it like any other character, which you can copy, -paste, delete, move, etc. The command which is bound to C-button2 is -called `strokes-compose-complex-stroke'. When all is done, you may -want to send the file, or save it. This is done with - -> M-x strokes-encode-buffer - -Likewise, to decode the strokes from a strokes-encoded buffer you do - -> M-x strokes-decode-buffer - -** A few more important things... - -o The command `strokes-do-complex-stroke' is invoked with M-button2, so that you - can execute complex strokes (i.e. with more than one lift) if preferred. - -o Strokes are a bit computer-dependent in that they depend somewhat on - the speed of the computer you're working on. This means that you - may have to tweak some variables. You can read about them in the - commentary of `strokes.el'. Better to just use apropos and read their - docstrings. All variables/functions start with `strokes'. The one - variable which many people wanted to see was - `strokes-use-strokes-buffer' which allows the user to use strokes - silently--without displaying the strokes. All variables can be set - by customizing the group named `strokes' via the customization package: - - > M-x customize")) - (princ helpdoc standard-output))))))) - -(defun strokes-report-bug () - "Submit a bug report for strokes." - (interactive) - (let ((reporter-prompt-for-summary-p t)) - (or (boundp 'reporter-version) - (setq reporter-version - "Your version of reporter is obsolete. Please upgrade.")) - (reporter-submit-bug-report - strokes-bug-address "Strokes" - (cons - 'strokes-version - (nconc - (mapcar - 'intern - (sort - (let (completion-ignore-case) - (all-completions "strokes-" obarray 'user-variable-p)) - 'string-lessp)) - (list 'reporter-version))) - (function - (lambda () - (save-excursion - (mail-position-on-field "subject") - (beginning-of-line) - (skip-chars-forward "^:\n") - (if (looking-at ": Strokes;") - (progn - (goto-char (match-end 0)) - (delete-char -1) - (insert " " strokes-version " bug:"))))))))) - -(defsubst strokes-fill-current-buffer-with-whitespace () - "Erase the contents of the current buffer and fill it with whitespace." - (erase-buffer) - (loop repeat (frame-height) do - (insert-char ?\ (1- (frame-width))) - (newline)) - (goto-char (point-min))) - -(defun strokes-window-configuration-changed-p () - "Non-nil if the `strokes-window-configuration' frame properties changed. -This is based on the last time the `strokes-window-configuration was updated." - (not (and (eq (selected-frame) - (plist-get strokes-window-configuration-plist - 'frame)) - (eq (frame-height) - (plist-get strokes-window-configuration-plist - 'frame-height)) - (eq (frame-width) - (plist-get strokes-window-configuration-plist - 'frame-width))))) - -(defun strokes-update-window-configuration-plist () - "Update the `strokes-window-configuration-plist' based on the current state." - (plist-put strokes-window-configuration-plist - 'frame - (selected-frame)) - (plist-put strokes-window-configuration-plist - 'frame-height - (frame-height)) - (plist-put strokes-window-configuration-plist - 'frame-width - (frame-width))) - -(defun strokes-update-window-configuration () - "Update the `strokes-window-configuration'." - (interactive) - (let ((current-window (selected-window))) - (cond ((or (window-minibuffer-p current-window) - (window-dedicated-p current-window)) - ;; don't try to update strokes window configuration - ;; if window is dedicated or a minibuffer - nil) - ((or (interactive-p) - (not (buffer-live-p (get-buffer strokes-buffer-name))) - (null strokes-window-configuration)) - ;; create `strokes-window-configuration' from scratch... - (save-excursion - (save-window-excursion - (get-buffer-create strokes-buffer-name) - (set-window-buffer current-window strokes-buffer-name) - (delete-other-windows) - (fundamental-mode) - (auto-save-mode 0) - (if (featurep 'font-lock) - (font-lock-mode 0)) - (abbrev-mode 0) - (buffer-disable-undo (current-buffer)) - (setq truncate-lines nil) - (strokes-fill-current-buffer-with-whitespace) - (setq strokes-window-configuration (current-window-configuration)) - (strokes-update-window-configuration-plist) - (bury-buffer)))) - ((strokes-window-configuration-changed-p) ; simple update - ;; update the strokes-window-configuration for this - ;; specific frame... - (save-excursion - (save-window-excursion - (set-window-buffer current-window strokes-buffer-name) - (delete-other-windows) - (strokes-fill-current-buffer-with-whitespace) - (setq strokes-window-configuration (current-window-configuration)) - (strokes-update-window-configuration-plist) - (bury-buffer))))))) - -;;;###autoload -(defun strokes-load-user-strokes () - "Load user-defined strokes from file named by `strokes-file'." - (interactive) - (cond ((and (file-exists-p strokes-file) - (file-readable-p strokes-file)) - (load-file strokes-file)) - ((interactive-p) - (error "Trouble loading user-defined strokes; nothing done")) - (t - (message "No user-defined strokes, sorry")))) - -;;;###autoload -(defalias 'load-user-strokes 'strokes-load-user-strokes) - -(defun strokes-prompt-user-save-strokes () - "Save user-defined strokes to file named by `strokes-file'." - (interactive) - (save-excursion - (let ((current strokes-global-map)) - (unwind-protect - (progn - (setq strokes-global-map nil) - (strokes-load-user-strokes) - (if (and (not (equal current strokes-global-map)) - (or (interactive-p) - (yes-or-no-p-maybe-dialog-box "save your strokes? "))) - (progn - (require 'pp) ; pretty-print variables - (message "Saving strokes in %s..." strokes-file) - (get-buffer-create "*saved-strokes*") - (set-buffer "*saved-strokes*") - (erase-buffer) - (emacs-lisp-mode) - (goto-char (point-min)) - (insert-string - ";; -*- Syntax: Emacs-Lisp; Mode: emacs-lisp -*-\n") - (insert-string (format ";;; saved strokes for %s, as of %s\n\n" - (user-full-name) - (format-time-string "%B %e, %Y" nil))) - (message "Saving strokes in %s..." strokes-file) - (insert-string (format "(setq strokes-global-map '%s)" - (pp current))) - (message "Saving strokes in %s..." strokes-file) - (indent-region (point-min) (point-max) nil) - (write-region (point-min) - (point-max) - strokes-file)) - (message "(no changes need to be saved)"))) - ;; protected - (if (get-buffer "*saved-strokes*") - (kill-buffer (get-buffer "*saved-strokes*"))) - (setq strokes-global-map current))))) - -(defalias 'save-strokes 'strokes-prompt-user-save-strokes) - -(defun strokes-toggle-strokes-buffer (&optional arg) - "Toggle the use of the strokes buffer. -In other words, toggle the variabe `strokes-use-strokes-buffer'. -With ARG, use strokes buffer if and only if ARG is positive or true. -Returns value of `strokes-use-strokes-buffer'." - (interactive "P") - (setq strokes-use-strokes-buffer - (if arg (> (prefix-numeric-value arg) 0) - (not strokes-use-strokes-buffer)))) - -(defun strokes-xpm-for-stroke (&optional stroke bufname b/w-only) - "Create an xpm pixmap for the given STROKE in buffer `*strokes-xpm*'. -If STROKE is not supplied, then `strokes-last-stroke' will be used. -Optional BUFNAME to name something else. -The pixmap will contain time information via rainbow dot colors -where each individual strokes begins. -Optional B/W-ONLY non-nil will create a mono pixmap, not intended -for trying to figure out the order of strokes, but rather for reading -the stroke as a character in some language." - (interactive) - (save-excursion - (let ((buf (get-buffer-create (or bufname "*strokes-xpm*"))) - (stroke (strokes-eliminate-consecutive-redundancies - (strokes-fill-stroke - (strokes-renormalize-to-grid (or stroke - strokes-last-stroke) - 31)))) - (lift-flag t) - (rainbow-chars (list ?R ?O ?Y ?G ?B ?P))) ; ROYGBIV w/o indigo - (set-buffer buf) - (erase-buffer) - (insert strokes-xpm-header) - (loop repeat 33 do - (insert-char ?\") - (insert-char ?\ 33) - (insert "\",") - (newline) - finally - (forward-line -1) - (end-of-line) - (insert "}\n")) - (loop for point in stroke - for x = (car-safe point) - for y = (cdr-safe point) do - (cond ((consp point) - ;; draw a point, and possibly a starting-point - (if (and lift-flag (not b/w-only)) - ;; mark starting point with the appropriate color - (let ((char (or (car rainbow-chars) ?\.))) - (loop for i from 0 to 2 do - (loop for j from 0 to 2 do - (goto-line (+ 16 i y)) - (forward-char (+ 1 j x)) - (delete-char 1) - (insert-char char))) - (setq rainbow-chars (cdr rainbow-chars) - lift-flag nil)) - ;; Otherwise, just plot the point... - (goto-line (+ 17 y)) - (forward-char (+ 2 x)) - (subst-char-in-region (point) (1+ (point)) ?\ ?\*))) - ((strokes-lift-p point) - ;; a lift--tell the loop to X out the next point... - (setq lift-flag t)))) - (when (interactive-p) - (require 'xpm-mode) - (pop-to-buffer "*strokes-xpm*") - ;; (xpm-mode 1) - (xpm-show-image) - (goto-char (point-min)))))) - -;;; Strokes Edit stuff... ### NOT IMLEMENTED YET ### - -;;(defun strokes-edit-quit () -;; (interactive) -;; (or (one-window-p t 0) -;; (delete-window)) -;; (kill-buffer "*Strokes List*")) - -;;(define-derived-mode edit-strokes-mode list-mode -;; "Edit-Strokes" -;; "Major mode for `edit-strokes' and `list-strokes' buffers. - -;;Editing commands: - -;;\\{edit-strokes-mode-map}" -;; (setq truncate-lines nil -;; auto-show-mode nil ; don't want problems here either -;; mode-popup-menu edit-strokes-menu) ; what about extent-specific stuff? -;; (and (featurep 'menubar) -;; current-menubar -;; (set (make-local-variable 'current-menubar) -;; (copy-sequence current-menubar)) -;; (add-submenu nil edit-strokes-menu))) - -;;(let ((map edit-strokes-mode-map)) -;; (define-key map "<" 'beginning-of-buffer) -;; (define-key map ">" 'end-of-buffer) -;; ;; (define-key map "c" 'strokes-copy-other-face) -;; ;; (define-key map "C" 'strokes-copy-this-face) -;; ;; (define-key map "s" 'strokes-smaller) -;; ;; (define-key map "l" 'strokes-larger) -;; ;; (define-key map "b" 'strokes-bold) -;; ;; (define-key map "i" 'strokes-italic) -;; (define-key map "e" 'strokes-list-edit) -;; ;; (define-key map "f" 'strokes-font) -;; ;; (define-key map "u" 'strokes-underline) -;; ;; (define-key map "t" 'strokes-truefont) -;; ;; (define-key map "F" 'strokes-foreground) -;; ;; (define-key map "B" 'strokes-background) -;; ;; (define-key map "D" 'strokes-doc-string) -;; (define-key map "a" 'strokes-global-set-stroke) -;; (define-key map "d" 'strokes-list-delete-stroke) -;; ;; (define-key map "n" 'strokes-list-next) -;; ;; (define-key map "p" 'strokes-list-prev) -;; ;; (define-key map " " 'strokes-list-next) -;; ;; (define-key map "\C-?" 'strokes-list-prev) -;; (define-key map "g" 'strokes-list-strokes) ; refresh display -;; (define-key map "q" 'strokes-edit-quit) -;; (define-key map [(control c) (control c)] 'bury-buffer)) - -;;;;;###autoload -;;(defun strokes-edit-strokes (&optional chronological strokes-map) -;; ;; ### DEAL WITH THE 2nd ARGUMENT ISSUE! ### -;; "Edit strokes in a pop-up buffer containing strokes and their definitions. -;;If STROKES-MAP is not given, `strokes-global-map' will be used instead. - -;;Editing commands: - -;;\\{edit-faces-mode-map}" -;; (interactive "P") -;; (pop-to-buffer (get-buffer-create "*Strokes List*")) -;; (reset-buffer (current-buffer)) ; handy function from minibuf.el -;; (setq strokes-map (or strokes-map -;; strokes-global-map -;; (progn -;; (strokes-load-user-strokes) -;; strokes-global-map))) -;; (or chronological -;; (setq strokes-map (sort (copy-sequence strokes-map) -;; 'strokes-alphabetic-lessp))) -;; ;; (push-window-configuration) -;; (insert -;; "Command Stroke\n" -;; "------- ------") -;; (loop for def in strokes-map -;; for i from 0 to (1- (length strokes-map)) do -;; (let ((stroke (car def)) -;; (command-name (symbol-name (cdr def)))) -;; (strokes-xpm-for-stroke stroke " *strokes-xpm*") -;; (newline 2) -;; (insert-char ?\ 45) -;; (beginning-of-line) -;; (insert command-name) -;; (beginning-of-line) -;; (forward-char 45) -;; (set (intern (format "strokes-list-annotation-%d" i)) -;; (make-annotation (make-glyph -;; (list -;; (vector 'xpm -;; :data (buffer-substring -;; (point-min " *strokes-xpm*") -;; (point-max " *strokes-xpm*") -;; " *strokes-xpm*")) -;; [string :data "[Stroke]"])) -;; (point) 'text)) -;; (set-annotation-data (symbol-value (intern (format "strokes-list-annotation-%d" i))) -;; def)) -;; finally do (kill-region (1+ (point)) (point-max))) -;; (edit-strokes-mode) -;; (goto-char (point-min))) - -;;;;;###autoload -;;(defalias 'edit-strokes 'strokes-edit-strokes) - -;;;###autoload -(defun strokes-list-strokes (&optional chronological strokes-map) - "Pop up a buffer containing an alphabetical listing of strokes in STROKES-MAP. -With CHRONOLOGICAL prefix arg \(\\[universal-argument]\) list strokes -chronologically by command name. -If STROKES-MAP is not given, `strokes-global-map' will be used instead." - (interactive "P") - (setq strokes-map (or strokes-map - strokes-global-map - (progn - (strokes-load-user-strokes) - strokes-global-map))) - (if (not chronological) - ;; then alphabetize the strokes based on command names... - (setq strokes-map (sort (copy-sequence strokes-map) - 'strokes-alphabetic-lessp))) - (push-window-configuration) - (set-buffer (get-buffer-create "*Strokes List*")) - (setq buffer-read-only nil) - (erase-buffer) - (insert - "Command Stroke\n" - "------- ------") - (loop for def in strokes-map do - (let ((stroke (car def)) - (command-name (symbol-name (cdr def)))) - (strokes-xpm-for-stroke stroke " *strokes-xpm*") - (newline 2) - (insert-char ?\ 45) - (beginning-of-line) - (insert command-name) - (beginning-of-line) - (forward-char 45) - (make-annotation (make-glyph - (list - (vector 'xpm - :data (buffer-substring - (point-min " *strokes-xpm*") - (point-max " *strokes-xpm*") - " *strokes-xpm*")) - [string :data "[Image]"])) - (point) 'text)) - finally do (kill-region (1+ (point)) (point-max))) - (view-buffer "*Strokes List*" t) - (goto-char (point-min)) - (define-key view-minor-mode-map [(q)] (lambda () - (interactive) - (view-quit) - (pop-window-configuration) - ;; (bury-buffer "*Strokes List*") - (define-key view-minor-mode-map [(q)] 'view-quit)))) - -(defun strokes-alphabetic-lessp (stroke1 stroke2) - "T iff command name for STROKE1 is less than STROKE2's in lexicographic order." - (let ((command-name-1 (symbol-name (cdr stroke1))) - (command-name-2 (symbol-name (cdr stroke2)))) - (string-lessp command-name-1 command-name-2))) - -;;;###autoload -(defalias 'list-strokes 'strokes-list-strokes) - -;;;###autoload -(defun strokes-mode (&optional arg) - "Toggle strokes being enabled. -With ARG, turn strokes on if and only if ARG is positive or true. -Note that `strokes-mode' is a global mode. Think of it as a minor -mode in all buffers when activated. -By default, strokes are invoked with mouse button-2. You can define -new strokes with - -> M-x global-set-stroke - -To use strokes for pictographic editing, such as Chinese/Japanese, use -Sh-button-2, which draws strokes and inserts them. Encode/decode your -strokes with - -> M-x strokes-encode-buffer -> M-x strokes-decode-buffer" - (interactive "P") - (let ((on-p (if arg - (> (prefix-numeric-value arg) 0) - (not strokes-mode)))) - (cond ((not (device-on-window-system-p)) - (warn "Can't use strokes without windows")) - (on-p ; turn on strokes - (strokes-insinuate) - (and (file-exists-p strokes-file) - (null strokes-global-map) - (strokes-load-user-strokes)) - (add-hook 'kill-emacs-query-functions - 'strokes-prompt-user-save-strokes) - (add-hook 'select-frame-hook - 'strokes-update-window-configuration) - (strokes-update-window-configuration) - (define-key global-map [(button2)] 'strokes-do-stroke) - (define-key global-map [(meta button2)] 'strokes-do-complex-stroke) - ;; (define-key global-map [(control button2)] 'strokes-do-complex-stroke) - (define-key global-map [(control button2)] - 'strokes-compose-complex-stroke) - (ad-activate-regexp "^strokes-") ; advise button2 commands - (setq strokes-mode t)) - (t ; turn off strokes - (if (get-buffer strokes-buffer-name) - (kill-buffer (get-buffer strokes-buffer-name))) - (remove-hook 'select-frame-hook - 'strokes-update-window-configuration) - (if (string-match "^strokes-" (symbol-name (key-binding [(button2)]))) - (define-key global-map [(button2)] strokes-click-command)) - (if (string-match "^strokes-" (symbol-name (key-binding [(meta button2)]))) - (global-unset-key [(meta button2)])) - (if (string-match "^strokes-" (symbol-name (key-binding [(control button2)]))) - (global-unset-key [(control button2)])) - ;; (if (string-match "^strokes-" (symbol-name (key-binding [(shift button2)]))) - ;; (global-unset-key [(shift button2)])) - (ad-deactivate-regexp "^strokes-") ; unadvise strokes-button2 commands - (setq strokes-mode nil)))) - (redraw-modeline)) - -(add-minor-mode 'strokes-mode strokes-modeline-string nil nil 'strokes-mode) - -;;;; strokes-xpm stuff (later may be separate)... - -;; This is the stuff that will eventuall be used for composing letters in -;; any language, compression, decompression, graphics, editing, etc. - -(require 'atomic-extents) ; might as well say - ; (require 'not-so-atomic-extents) - ; but what can you do? - -;;(unless (find-face 'strokes-char-face) - -(defface strokes-char-face '((t (:background "lightgray"))) - "Face for strokes characters." - :group 'strokes) - -(defconst strokes-char-table (make-char-table 'generic) ; - "The table which stores values for the character keys.") -(put-char-table ?0 0 strokes-char-table) -(put-char-table ?1 1 strokes-char-table) -(put-char-table ?2 2 strokes-char-table) -(put-char-table ?3 3 strokes-char-table) -(put-char-table ?4 4 strokes-char-table) -(put-char-table ?5 5 strokes-char-table) -(put-char-table ?6 6 strokes-char-table) -(put-char-table ?7 7 strokes-char-table) -(put-char-table ?8 8 strokes-char-table) -(put-char-table ?9 9 strokes-char-table) -(put-char-table ?a 10 strokes-char-table) -(put-char-table ?b 11 strokes-char-table) -(put-char-table ?c 12 strokes-char-table) -(put-char-table ?d 13 strokes-char-table) -(put-char-table ?e 14 strokes-char-table) -(put-char-table ?f 15 strokes-char-table) -(put-char-table ?g 16 strokes-char-table) -(put-char-table ?h 17 strokes-char-table) -(put-char-table ?i 18 strokes-char-table) -(put-char-table ?j 19 strokes-char-table) -(put-char-table ?k 20 strokes-char-table) -(put-char-table ?l 21 strokes-char-table) -(put-char-table ?m 22 strokes-char-table) -(put-char-table ?n 23 strokes-char-table) -(put-char-table ?o 24 strokes-char-table) -(put-char-table ?p 25 strokes-char-table) -(put-char-table ?q 26 strokes-char-table) -(put-char-table ?r 27 strokes-char-table) -(put-char-table ?s 28 strokes-char-table) -(put-char-table ?t 29 strokes-char-table) -(put-char-table ?u 30 strokes-char-table) -(put-char-table ?v 31 strokes-char-table) -(put-char-table ?w 32 strokes-char-table) -(put-char-table ?x 33 strokes-char-table) -(put-char-table ?y 34 strokes-char-table) -(put-char-table ?z 35 strokes-char-table) -(put-char-table ?A 36 strokes-char-table) -(put-char-table ?B 37 strokes-char-table) -(put-char-table ?C 38 strokes-char-table) -(put-char-table ?D 39 strokes-char-table) -(put-char-table ?E 40 strokes-char-table) -(put-char-table ?F 41 strokes-char-table) -(put-char-table ?G 42 strokes-char-table) -(put-char-table ?H 43 strokes-char-table) -(put-char-table ?I 44 strokes-char-table) -(put-char-table ?J 45 strokes-char-table) -(put-char-table ?K 46 strokes-char-table) -(put-char-table ?L 47 strokes-char-table) -(put-char-table ?M 48 strokes-char-table) -(put-char-table ?N 49 strokes-char-table) -(put-char-table ?O 50 strokes-char-table) -(put-char-table ?P 51 strokes-char-table) -(put-char-table ?Q 52 strokes-char-table) -(put-char-table ?R 53 strokes-char-table) -(put-char-table ?S 54 strokes-char-table) -(put-char-table ?T 55 strokes-char-table) -(put-char-table ?U 56 strokes-char-table) -(put-char-table ?V 57 strokes-char-table) -(put-char-table ?W 58 strokes-char-table) -(put-char-table ?X 59 strokes-char-table) -(put-char-table ?Y 60 strokes-char-table) -(put-char-table ?Z 61 strokes-char-table) - -(defconst strokes-base64-chars - ;; I can easily have made this a vector of single-character strings, - ;; like (vector "0" "1" "2" ...), and then the program would run - ;; faster since it wouldn't then have to call `char-to-string' when it - ;; did the `concat'. I left them as chars here because I want - ;; *them* to change `concat' so that it accepts chars and deals with - ;; them properly. i.e. the form: (concat "abc" ?T "xyz") should - ;; return "abcTxyz" NOT "abc84xyz" (XEmacs 19.*) and NOT an error - ;; (XEmacs 20.*). - ;; (vector "0" "1" "2" "3" "4" "5" "6" "7" "8" "9" - ;; "a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l" "m" "n" "o" - ;; "p" "q" "r" "s" "t" "u" "v" "w" "x" "y" "z" "A" "B" "C" "D" - ;; "E" "F" "G" "H" "I" "J" "K" "L" "M" "N" "O" "P" "Q" "R" "S" - ;; "T" "U" "V" "W" "X" "Y" "Z") - (vector ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9 - ?a ?b ?c ?d ?e ?f ?g ?h ?i ?j ?k ?l ?m ?n ?o ?p ?q ?r ?s ?t ?u ?v ?w ?x ?y ?z - ?A ?B ?C ?D ?E ?F ?G ?H ?I ?J ?K ?L ?M ?N ?O ?P ?Q ?R ?S ?T ?U ?V ?W ?X ?Y ?Z) - "Character vector for fast lookup of base-64 encoding of numbers in [0,61].") - -(defsubst strokes-xpm-char-on-p (char) - "Non-nil if CHAR represents an `on' bit in the xpm." - (char= char ?*)) - -(defsubst strokes-xpm-char-bit-p (char) - "Non-nil if CHAR represents an `on' or `off' bit in the xpm." - (or (char= char ?\ ) - (char= char ?*))) - -;;(defsubst strokes-xor (a b) ### Should I make this an inline function? ### -;; "T iff one and only one of A and B is non-nil; otherwise, returns nil. -;;NOTE: Don't use this as a numeric xor since it treats all non-nil -;; values as t including `0' (zero)." -;; (eq (null a) (not (null b)))) - -(defsubst strokes-xpm-encode-length-as-string (length) - "Given some LENGTH in [0,62) do a fast lookup of it's encoding." - (char-to-string (aref strokes-base64-chars length))) - -(defsubst strokes-xpm-decode-char (character) - "Given a CHARACTER, do a fast lookup to find its corresponding integer value." - (get-char-table character strokes-char-table)) - -(defun strokes-xpm-to-compressed-string (&optional xpm-buffer) - "Convert the xpm in XPM-BUFFER into a compressed string representing the stroke. -XPM-BUFFER is an optional argument, and defaults to `*strokes-xpm*'." - (save-excursion - (set-buffer (setq xpm-buffer (or xpm-buffer "*strokes-xpm*"))) - (goto-char (point-min)) - (search-forward "/* pixels */") ; skip past header junk - (forward-char 2) - ;; a note for below: - ;; the `current-char' is the char being counted -- NOT the char at (point) - ;; which happens to be called `char-at-point' - (let ((compressed-string "+/") ; initialize the output - (count 0) ; keep a current count of - ; `current-char' - (last-char-was-on-p t) ; last entered stream - ; represented `on' bits - (current-char-is-on-p nil) ; current stream represents `on' bits - (char-at-point (char-after))) ; read the first char - (while (not (char= char-at-point ?})) ; a `}' denotes the - ; end of the pixmap - (cond ((zerop count) ; must restart counting - ;; check to see if the `char-at-point' is an actual pixmap bit - (when (strokes-xpm-char-bit-p char-at-point) - (setq count 1 - current-char-is-on-p (strokes-xpm-char-on-p char-at-point))) - (forward-char 1)) - ((= count 61) ; maximum single char's - ; encoding length - (setq compressed-string (concat compressed-string - ;; add a zero-length - ;; encoding when - ;; necessary - (when (eq last-char-was-on-p - current-char-is-on-p) - ;; "0" - (strokes-xpm-encode-length-as-string 0)) - (strokes-xpm-encode-length-as-string 61)) - last-char-was-on-p current-char-is-on-p - count 0)) ; note that we just set - ; count=0 and *don't* advance - ; (point) - ((strokes-xpm-char-bit-p char-at-point) ; an actual xpm bit - (if (eq current-char-is-on-p - (strokes-xpm-char-on-p char-at-point)) - ;; yet another of the same bit-type, so we continue - ;; counting... - (progn - (incf count) - (forward-char 1)) - ;; otherwise, it's the opposite bit-type, so we do a - ;; write and then restart count ### NOTE (for myself - ;; to be aware of) ### I really should advance - ;; (point) in this case instead of letting another - ;; iteration go through and letting the case: count=0 - ;; take care of this stuff for me. That's why - ;; there's no (forward-char 1) below. - (setq compressed-string (concat compressed-string - ;; add a zero-length - ;; encoding when - ;; necessary - (when (eq last-char-was-on-p - current-char-is-on-p) - ;; "0" - (strokes-xpm-encode-length-as-string 0)) - (strokes-xpm-encode-length-as-string count)) - count 0 - last-char-was-on-p current-char-is-on-p))) - (t ; ELSE it's some other useless - ; char, like `"' or `,' - (forward-char 1))) - (setq char-at-point (char-after))) - (concat compressed-string - (when (> count 0) - (concat (when (eq last-char-was-on-p - current-char-is-on-p) - ;; "0" - (strokes-xpm-encode-length-as-string 0)) - (strokes-xpm-encode-length-as-string count))) - "/")))) - -;;;###autoload -(defun strokes-decode-buffer (&optional buffer force) - "Decode stroke strings in BUFFER and display their corresponding glyphs. -Optional BUFFER defaults to the current buffer. -Optional FORCE non-nil will ignore the buffer's read-only status." - (interactive) - ;; (interactive "*bStrokify buffer: ") - (save-excursion - (set-buffer (setq buffer (get-buffer (or buffer (current-buffer))))) - (when (or (not buffer-read-only) - force - inhibit-read-only - (y-or-n-p-maybe-dialog-box - (format "Buffer %s is read-only. Strokify anyway? " buffer))) - (let ((inhibit-read-only t)) - (message "Strokifying %s..." buffer) - (goto-char (point-min)) - (let (ext string) - ;; The comment below is what i'd have to do if I wanted to - ;; deal with random newlines in the midst of the compressed - ;; strings. If I do this, I'll also have to change - ;; `strokes-xpm-to-compress-string' to deal with the newline, - ;; and possibly other whitespace stuff. YUCK! - ;; (while (re-search-forward "\\+/\\(\\w\\|\\)+/" nil t nil (get-buffer buffer)) - (while (re-search-forward "\\+/\\w+/" nil t nil buffer) - (setq string (buffer-substring (+ 2 (match-beginning 0)) - (1- (match-end 0)))) - (strokes-xpm-for-compressed-string string " *strokes-xpm*") - (replace-match " ") - (setq ext (make-extent (1- (point)) (point))) - (set-extent-property ext 'type 'stroke-glyph) - (set-extent-property ext 'start-open t) - (set-extent-property ext 'end-open t) - (set-extent-property ext 'detachable t) - (set-extent-property ext 'duplicable t) - (set-extent-property ext 'data string) - (set-extent-face ext 'default) - (set-extent-end-glyph ext (make-glyph - (list - (vector 'xpm - :data (buffer-substring - (point-min " *strokes-xpm*") - (point-max " *strokes-xpm*") - " *strokes-xpm*")) - [string :data "[Stroke]"]))))) - (message "Strokifying %s...done" buffer))))) - -(defun strokes-encode-buffer (&optional buffer force) - "Convert the glyphs in BUFFER to thier base-64 ASCII representations. -Optional BUFFER defaults to the current buffer. -Optional FORCE non-nil will ignore the buffer's read-only status." - ;; ### NOTE !!! ### (for me) - ;; For later on, you can/should make the inserted strings atomic - ;; extents, so that the users have a clue that they shouldn't be - ;; editing inside them. Plus, if you make them extents, you can - ;; very easily just hide the glyphs, so if you unstrokify, and the - ;; restrokify, then those that already are glyphed don't need to be - ;; re-calculated, etc. It's just nicer that way. The only things - ;; to worry about is cleanup (i.e. do the glyphs get gc'd when the - ;; buffer is killed? - ;; (interactive "*bUnstrokify buffer: ") - (interactive) - (save-excursion - (set-buffer (setq buffer (or buffer (current-buffer)))) - (when (or (not buffer-read-only) - force - inhibit-read-only - (y-or-n-p-maybe-dialog-box - (format "Buffer %s is read-only. Encode anyway? " buffer))) - (message "Encoding strokes in %s..." buffer) - ;; (map-extents - ;; (lambda (ext buf) - ;; (when (eq (extent-property ext 'type) 'stroke-glyph) - ;; (goto-char (extent-start-position ext)) - ;; (delete-char 1) ; ### What the hell do I do here? ### - ;; (insert "+/" (extent-property ext 'data) "/") - ;; (delete-extent ext)))))) - (let ((inhibit-read-only t) - (start nil)) - (loop repeat 2 do ; ### KLUDGE!!! This it pure crap! ### - (map-extents - (lambda (ext buf) - (when (eq (extent-property ext 'type) 'stroke-glyph) - (setq start (goto-char (extent-start-position ext))) - ;; (insert "+/" (extent-property ext 'data) "/") - (insert-string "+/") - (insert-string (extent-property ext 'data)) - (insert-string "/") - (delete-char 1) - (set-extent-endpoints ext start (point)) - (set-extent-property ext 'type 'stroke-string) - (set-extent-property ext 'atomic t) - ;; (set-extent-property ext 'read-only t) - (set-extent-face ext 'strokes-char-face) - (set-extent-property ext 'stroke-glyph (extent-end-glyph ext)) - (set-extent-end-glyph ext nil)))))) - (message "Encoding strokes in %s...done" buffer)))) - -(defun strokes-xpm-for-compressed-string (compressed-string &optional bufname) - "Convert the stroke represented by COMPRESSED-STRING into an xpm. -Store xpm in buffer BUFNAME if supplied \(default is `*strokes-xpm*'\)" - (save-excursion - (or bufname (setq bufname "*strokes-xpm*")) - (erase-buffer (set-buffer (get-buffer-create bufname))) - (insert compressed-string) - (goto-char (point-min)) - (let ((current-char-is-on-p nil)) - (while (not (eobp)) - (insert-char - (if current-char-is-on-p - ?* - ?\ ) - (strokes-xpm-decode-char (char-after))) - (delete-char 1) - (setq current-char-is-on-p (not current-char-is-on-p))) - (goto-char (point-min)) - (loop repeat 33 do - (insert-char ?\") - (forward-char 33) - (insert "\",\n")) - (goto-char (point-min)) - (insert strokes-xpm-header)))) - -;;;###autoload -(defun strokes-compose-complex-stroke () - ;; ### NOTE !!! ### - ;; Even though we have lexical scoping, it's somewhat ugly how I - ;; pass around variables in the global name space. I can/should - ;; change this. - "Read a complex stroke and insert its glyph into the current buffer." - (interactive "*") - (let ((strokes-grid-resolution 33)) - (strokes-read-complex-stroke) - (strokes-xpm-for-stroke nil " *strokes-xpm*" t) - (insert (strokes-xpm-to-compressed-string " *strokes-xpm*")) - (strokes-decode-buffer))) - -(provide 'strokes) -(run-hooks 'strokes-load-hook) - -;;; strokes.el ends here
--- a/lisp/modes/tcl.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2261 +0,0 @@ -;; tcl.el --- Tcl code editing commands for Emacs - -;; Copyright (C) 1994 Free Software Foundation, Inc. - -;; Maintainer: Tom Tromey <tromey@busco.lanl.gov> -;; Author: Tom Tromey <tromey@busco.lanl.gov> -;; Chris Lindblad <cjl@lcs.mit.edu> -;; Keywords: languages tcl modes -;; Version: 1.50 - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 1, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -;; HOW TO INSTALL: -;; Put the following forms in your .emacs to enable autoloading of Tcl -;; mode, and auto-recognition of ".tcl" files. -;; -;; (autoload 'tcl-mode "tcl" "Tcl mode." t) -;; (autoload 'inferior-tcl "tcl" "Run inferior Tcl process." t) -;; (setq auto-mode-alist (append '(("\\.tcl$" . tcl-mode)) auto-mode-alist)) -;; -;; If you plan to use the interface to the TclX help files, you must -;; set the variable tcl-help-directory-list to point to the topmost -;; directories containing the TclX help files. Eg: -;; -;; (setq tcl-help-directory-list '("/usr/local/lib/tclx/help")) -;; -;; Also you will want to add the following to your .emacs: -;; -;; (autoload 'tcl-help-on-word "tcl" "Help on Tcl commands" t) -;; -;; FYI a *very* useful thing to do is nroff all the Tk man pages and -;; put them in a subdir of the help system. -;; - -;;; Commentary: - -;; LCD Archive Entry: -;; tcl|Tom Tromey|tromey@busco.lanl.gov| -;; Major mode for editing Tcl| -;; 1996/03/23 05:14:50|1.50|~/modes/tcl.el.Z| - -;; CUSTOMIZATION NOTES: -;; * tcl-proc-list can be used to customize a list of things that -;; "define" other things. Eg in my project I put "defvar" in this -;; list. -;; * tcl-typeword-list is similar, but uses font-lock-type-face. -;; * tcl-keyword-list is a list of keywords. I've generally used this -;; for flow-control words. Eg I add "unwind_protect" to this list. -;; * tcl-type-alist can be used to minimally customize indentation -;; according to context. - -;; Change log: -;; tcl.el,v -;; Revision 1.50 1996/03/23 05:14:50 tromey -;; (tcl-using-emacs-19): Work with XEmacs 20.0. From Ben Wing. -;; -;; Revision 1.49 1995/12/07 18:27:47 tromey -;; (add-log-tcl-defun): Don't use tcl-beginning-of-defun; just go to end -;; of line before searching. -;; -;; Revision 1.48 1995/12/07 18:18:21 tromey -;; (add-log-tcl-defun): Now uses tcl-beginning-of-defun. -;; -;; Revision 1.47 1995/08/22 17:49:45 tromey -;; (tcl-hilit): New function from "Chris Alfeld" <calfeld@math.utah.edu> -;; (tcl-mode): Call it -;; -;; Revision 1.46 1995/08/07 16:02:01 tromey -;; (tcl-do-auto-fill): Only fill past fill-column; for 19.29. -;; (tcl-auto-fill-mode): Use force-mode-line-update. -;; -;; Revision 1.45 1995/07/23 23:51:25 tromey -;; (tcl-word-no-props): New function. -;; (tcl-figure-type): Use it. -;; (tcl-current-word): Ditto. -;; -;; Revision 1.44 1995/07/23 20:26:47 tromey -;; Doc fixes. -;; -;; Revision 1.43 1995/07/17 19:59:49 tromey -;; (inferior-tcl-mode): Use modeline-process if it exists. -;; -;; Revision 1.42 1995/07/17 19:55:25 tromey -;; XEmacs currently must use tcl-internal-end-of-defun -;; -;; Revision 1.41 1995/07/14 21:54:56 tromey -;; Changes to make menus work in XEmacs. -;; From Mike Scheidler <c23mts@kocrsv01.delcoelect.com> -;; -;; Revision 1.40 1995/07/11 03:13:15 tromey -;; (tcl-mode): Customize for new dabbrev. -;; -;; Revision 1.39 1995/07/09 21:58:03 tromey -;; (tcl-do-fill-paragraph): New function. -;; (tcl-mode): Set up for paragraph filling. -;; -;; Revision 1.38 1995/07/09 21:30:32 tromey -;; (tcl-mode): Fixes to 19.29 paragraph variables. -;; -;; Revision 1.37 1995/07/09 18:52:16 tromey -;; (tcl-do-auto-fill): Set fill-prefix. -;; -;; Revision 1.36 1995/07/09 01:07:57 tromey -;; (tcl-imenu-create-index-function): Work with imenu from Emacs 19.29 -;; -;; Revision 1.35 1995/06/27 20:12:00 tromey -;; (tcl-type-alist): More itcl changes. -;; -;; Revision 1.34 1995/06/27 20:06:05 tromey -;; More changes for itcl. -;; Bug fixes for Emacs 19.29. -;; -;; Revision 1.33 1995/06/27 20:01:29 tromey -;; (tcl-set-proc-regexp): Allow leading spaces. -;; (tcl-proc-list): Changes for itcl. -;; (tcl-typeword-list): Ditto. -;; (tcl-keyword-list): Ditto. -;; -;; Revision 1.32 1995/05/11 22:12:49 tromey -;; (tcl-type-alist): Include entry for "proc". -;; -;; Revision 1.31 1995/05/10 23:38:12 tromey -;; (tcl-add-fsf-menu): Use make-lucid-menu-keymap, not -;; "make-xemacs-menu-keymap". -;; -;; Revision 1.30 1995/05/10 18:22:21 tromey -;; Bug fix in menu code for XEmacs. -;; -;; Revision 1.29 1995/05/09 21:36:53 tromey -;; Changed "Lucid Emacs" to "XEmacs". -;; Tcl's popup menu now added to existing one, courtesy -;; dfarmer@evolving.com (Doug Farmer) -;; -;; Revision 1.28 1995/04/08 19:52:50 tromey -;; (tcl-outline-level): New function -;; (tcl-mode): Added outline-handling stuff. -;; From Jesper Pedersen <blackie@imada.ou.dk> -;; -;; Revision 1.27 1994/10/11 02:01:27 tromey -;; (tcl-mode): imenu-create-index-function made buffer local. -;; -;; Revision 1.26 1994/09/01 18:06:24 tromey -;; Added filename completion in inferior tcl mode -;; -;; Revision 1.25 1994/08/22 15:56:24 tromey -;; tcl-load-file default to current buffer. -;; -;; Revision 1.24 1994/08/21 20:33:05 tromey -;; Fixed bug in tcl-guess-application. -;; -;; Revision 1.23 1994/08/21 03:54:45 tromey -;; Keybindings don't overshadown comint bindings. -;; -;; Revision 1.22 1994/07/26 00:46:07 tromey -;; Emacs 18 changes from Carl Witty. -;; -;; Revision 1.21 1994/07/14 22:49:21 tromey -;; Added ";;;###autoload" comments where appropriate. -;; -; Revision 1.20 1994/06/05 16:57:22 tromey -; tcl-current-word does the right thing in inferior-tcl-mode. -; -; Revision 1.19 1994/06/03 21:09:19 tromey -; Another menu fix. -; -; Revision 1.18 1994/06/03 20:39:14 tromey -; Fixed menu bug. -; -; Revision 1.17 1994/06/03 00:47:15 tromey -; Fixed bug in bug-reporting code. -; -; Revision 1.16 1994/05/26 05:06:14 tromey -; Menu items now sensitive as appropriate. -; -; Revision 1.15 1994/05/22 20:38:11 tromey -; Added bug-report keybindings and menu entries. -; -; Revision 1.14 1994/05/22 20:18:28 tromey -; Even more compile stuff. -; -; Revision 1.13 1994/05/22 20:17:15 tromey -; Moved emacs version checking code to very beginning. -; -; Revision 1.12 1994/05/22 20:14:59 tromey -; Compile fixes. -; -; Revision 1.11 1994/05/22 20:12:44 tromey -; Fixed mark-defun for 19.23. -; More menu fixes. -; -; Revision 1.10 1994/05/22 20:02:03 tromey -; Fixed bug with M-;. -; Wrote bug-reporting code. -; -; Revision 1.9 1994/05/22 05:26:51 tromey -; Fixes for imenu. -; -; Revision 1.8 1994/05/22 03:38:07 tromey -; Fixed menu support. -; -; Revision 1.7 1994/05/03 01:23:42 tromey -; *** empty log message *** -; -; Revision 1.6 1994/04/23 16:23:36 tromey -; Wrote tcl-indent-for-comment -; -;; -;; 18-Mar-1994 Tom Tromey Fourth beta release. -;; Added {un,}comment-region to menu. Idea from -;; Mike Scheidler <c23mts@kocrsv01.delcoelect.com> -;; 17-Mar-1994 Tom Tromey -;; Fixed tcl-restart-with-file. Bug fix attempt in -;; tcl-internal-end-of-defun. -;; 16-Mar-1994 Tom Tromey Third beta release -;; Added support code for menu (from Tcl mode written by -;; schmid@fb3-s7.math.TU-Berlin.DE (Gregor Schmid)). -;; 12-Mar-1994 Tom Tromey -;; Better documentation for inferior-tcl-buffer. Wrote -;; tcl-restart-with-file. Wrote Lucid Emacs menu (but no -;; code to install it). -;; 12-Mar-1994 Tom Tromey -;; Wrote tcl-guess-application. Another stab at making -;; tcl-omit-ws-regexp work. -;; 10-Mar-1994 Tom Tromey Second beta release -;; Last Modified: Thu Mar 10 01:24:25 1994 (Tom Tromey) -;; Wrote perl-mode style line indentation command. -;; Wrote more documentation. Added tcl-continued-indent-level. -;; Integrated help code. -;; 8-Mar-1994 Tom Tromey -;; Last Modified: Tue Mar 8 11:58:44 1994 (Tom Tromey) -;; Bug fixes. -;; 6-Mar-1994 Tom Tromey -;; Last Modified: Sun Mar 6 18:55:41 1994 (Tom Tromey) -;; Updated auto-newline support. -;; 6-Mar-1994 Tom Tromey Beta release -;; Last Modified: Sat Mar 5 17:24:32 1994 (Tom Tromey) -;; Wrote tcl-hashify-buffer. Other minor bug fixes. -;; 5-Mar-1994 Tom Tromey -;; Last Modified: Sat Mar 5 16:11:20 1994 (Tom Tromey) -;; Wrote electric-hash code. -;; 3-Mar-1994 Tom Tromey -;; Last Modified: Thu Mar 3 02:53:40 1994 (Tom Tromey) -;; Added code to handle auto-fill in comments. -;; Added imenu support code. -;; Cleaned up code. -;; Better font-lock support. -;; 28-Feb-1994 Tom Tromey -;; Last Modified: Mon Feb 28 14:08:05 1994 (Tom Tromey) -;; Made tcl-figure-type more easily configurable. -;; 28-Feb-1994 Tom Tromey -;; Last Modified: Mon Feb 28 01:02:58 1994 (Tom Tromey) -;; Wrote inferior-tcl mode. -;; 16-Feb-1994 Tom Tromey -;; Last Modified: Wed Feb 16 17:05:19 1994 (Tom Tromey) -;; Added support for font-lock-mode. -;; 29-Oct-1993 Tom Tromey -;; Last Modified: Sun Oct 24 17:39:14 1993 (Tom Tromey) -;; Patches from Guido Bosch to make things work with Lucid Emacs. -;; 22-Oct-1993 Tom Tromey -;; Last Modified: Fri Oct 22 15:26:46 1993 (Tom Tromey) -;; Made many characters have "_" syntax class; suggested by Guido -;; Bosch <Guido.Bosch@loria.fr>. Note that this includes the "$" -;; character, which might be a change you'd notice. -;; 21-Oct-1993 Tom Tromey -;; Last Modified: Thu Oct 21 20:28:40 1993 (Tom Tromey) -;; More fixes for tcl-omit-ws-regexp. -;; 20-Oct-1993 Tom Tromey -;; Started keeping history. Fixed tcl-{beginning,end}-of-defun. -;; Added some code to make things work with Emacs 18. - -;; THANKS TO: -;; Guido Bosch <Guido.Bosch@loria.fr> -;; pgs1002@esc.cam.ac.uk (Dr P.G. Sjoerdsma) -;; Mike Scheidler <c23mts@kocrsv01.delcoelect.com> -;; Matt Newman <men@charney.colorado.edu> -;; rwhitby@research.canon.oz.au (Rod Whitby) -;; h9118101@hkuxa.hku.hk (Yip Chi Lap [Beta]) -;; Pertti Tapio Kasanen <ptk@delta.hut.fi> -;; schmid@fb3-s7.math.TU-Berlin.DE (Gregor Schmid) -;; warsaw@nlm.nih.gov (Barry A. Warsaw) -;; Carl Witty <cwitty@ai.mit.edu> -;; T. V. Raman <raman@crl.dec.com> -;; Jesper Pedersen <blackie@imada.ou.dk> -;; dfarmer@evolving.com (Doug Farmer) -;; "Chris Alfeld" <calfeld@math.utah.edu> -;; Ben Wing <wing@666.com> - -;; KNOWN BUGS: -;; * indent-region should skip blank lines. (It does in v19, so I'm -;; not motivated to fix it here). -;; * In Tcl "#" is not always a comment character. This can confuse -;; tcl.el in certain circumstances. For now the only workaround is -;; to enclose offending hash characters in quotes or precede it with -;; a backslash. Note that using braces won't work -- quotes change -;; the syntax class of characters between them, while braces do not. -;; The electric-# mode helps alleviate this problem somewhat. -;; * indent-tcl-exp is untested. -;; * Doesn't work under Emacs 18 yet. -;; * There's been a report that font-lock does strange things under -;; Lucid Emacs 19.6. For instance in "proc foobar", the space -;; before "foobar" is highlighted. - -;; TODO: -;; * make add-log-tcl-defun smarter. should notice if we are in the -;; middle of a defun, or between defuns. should notice if point is -;; on first line of defun (or maybe even in comments before defun). -;; * Allow continuation lines to be indented under the first argument -;; of the preceding line, like this: -;; [list something \ -;; something-else] -;; * There is a request that indentation work like this: -;; button .fred -label Fred \ -;; -command {puts fred} -;; * Should have tcl-complete-symbol that queries the inferior process. -;; * Should have describe-symbol that works by sending the magic -;; command to a tclX process. -;; * Need C-x C-e binding (tcl-eval-last-exp). -;; * Write indent-region function that is faster than indenting each -;; line individually. -;; * tcl-figure-type should stop at "beginning of line" (only ws -;; before point, and no "\" on previous line). (see tcl-real-command-p). -;; * overrides some comint keybindings; fix. -;; * Trailing \ will eat blank lines. Should deal with this. -;; (this would help catch some potential bugs). -;; * Inferior should display in half the screen, not the whole screen. -;; * Indentation should deal with "switch". -;; * Consider writing code to find help files automatically (for -;; common cases). -;; * `#' shouldn't insert `\#' when point is in string. - - - -;;; Code: - -;; I sure wish Emacs had a package that made it easy to extract this -;; sort of information. Strange definition works with XEmacs 20.0. -(defconst tcl-using-emacs-19 (not (string-match "18\\." emacs-version)) - "Nil unless using Emacs 19 (XEmacs or FSF).") - -;; FIXME this will break on Emacs 19.100. -(defconst tcl-using-emacs-19-23 - (string-match "19\\.\\(2[3-9]\\|[3-9][0-9]\\)" emacs-version) - "Nil unless using Emacs 19-23 or later.") - -(defconst tcl-using-xemacs-19 (string-match "XEmacs" emacs-version) - "Nil unless using XEmacs).") - -(require 'comint) - -;; When compiling under GNU Emacs, load imenu during compilation. If -;; you have 19.22 or earlier, comment this out, or get imenu. -(and (fboundp 'eval-when-compile) - (eval-when-compile - (if (and (string-match "19\\." emacs-version) - (not (string-match "XEmacs" emacs-version))) - (require 'imenu)) - ())) - -(defconst tcl-version "1.50") -(defconst tcl-maintainer "Tom Tromey <tromey@drip.colorado.edu>") - -;; -;; User variables. -;; - -(defgroup tcl nil - "Tcl programming language." - :group 'languages) - - -(defcustom tcl-indent-level 4 - "*Indentation of Tcl statements with respect to containing block." - :type 'integer - :group 'tcl) - -(defcustom tcl-continued-indent-level 4 - "*Indentation of continuation line relative to first line of command." - :type 'integer - :group 'tcl) - -(defcustom tcl-auto-newline nil - "*Non-nil means automatically newline before and after braces -inserted in Tcl code." - :type 'boolean - :group 'tcl) - -(defcustom tcl-tab-always-indent t - "*Control effect of TAB key. -If t (the default), always indent current line. -If nil and point is not in the indentation area at the beginning of -the line, a TAB is inserted. -Other values cause the first possible action from the following list -to take place: - - 1. Move from beginning of line to correct indentation. - 2. Delete an empty comment. - 3. Move forward to start of comment, indenting if necessary. - 4. Move forward to end of line, indenting if necessary. - 5. Create an empty comment. - 6. Move backward to start of comment, indenting if necessary." - :type '(choice (const :tag "on" t) - (const :tag "off" nil) - (sexp :format "%t\n" :tag "The Works" other)) - :group 'tcl) - -(defcustom tcl-use-hairy-comment-detector t - "*If not `nil', then the more complicated, but slower, comment -detecting function is used. This variable is only used in GNU Emacs -19 (the fast function is always used elsewhere)." - :type 'boolean - :group 'tcl) - -(defcustom tcl-electric-hash-style 'smart - "*Style of electric hash insertion to use. -Possible values are 'backslash, meaning that `\\' quoting should be -done; 'quote, meaning that `\"' quoting should be done; 'smart, -meaning that the choice between 'backslash and 'quote should be -made depending on the number of hashes inserted; or nil, meaning that -no quoting should be done. Any other value for this variable is -taken to mean 'smart. The default is 'smart." - :type '(choice (const backslash) (const quote) (const smart)) - :group 'tcl) - -(defcustom tcl-help-directory-list nil - "*List of topmost directories containing TclX help files" - :type '(repeat directory) - :group 'tcl) - -(defcustom tcl-use-smart-word-finder t - "*If not nil, use a better way of finding the current word when -looking up help on a Tcl command." - :type 'boolean - :group 'tcl) - -(defcustom tcl-application "wish" - "*Name of Tcl application to run in inferior Tcl mode." - :type 'string - :group 'tcl) - -(defcustom tcl-command-switches nil - "*Switches to supply to `tcl-application'." - :type '(repeat string) - :group 'tcl) - -(defcustom tcl-prompt-regexp "^\\(% \\|\\)" - "*If not nil, a regexp that will match the prompt in the inferior process. -If nil, the prompt is the name of the application with \">\" appended. - -The default is \"^\\(% \\|\\)\", which will match the default primary -and secondary prompts for tclsh and wish." - :type 'regexp - :group 'tcl) - -(defcustom inferior-tcl-source-command "source %s\n" - "*Format-string for building a Tcl command to load a file. -This format string should use `%s' to substitute a file name -and should result in a Tcl expression that will command the -inferior Tcl to load that file. The filename will be appropriately -quoted for Tcl." - :type 'string - :group 'tcl) - -;; -;; Keymaps, abbrevs, syntax tables. -;; - -(defvar tcl-mode-abbrev-table nil - "Abbrev table in use in Tcl-mode buffers.") -(if tcl-mode-abbrev-table - () - (define-abbrev-table 'tcl-mode-abbrev-table ())) - -(defvar tcl-mode-map () - "Keymap used in Tcl mode.") - -(defvar tcl-mode-syntax-table nil - "Syntax table in use in Tcl-mode buffers.") -(if tcl-mode-syntax-table - () - (setq tcl-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?% "_" tcl-mode-syntax-table) - (modify-syntax-entry ?@ "_" tcl-mode-syntax-table) - (modify-syntax-entry ?& "_" tcl-mode-syntax-table) - (modify-syntax-entry ?* "_" tcl-mode-syntax-table) - (modify-syntax-entry ?+ "_" tcl-mode-syntax-table) - (modify-syntax-entry ?- "_" tcl-mode-syntax-table) - (modify-syntax-entry ?. "_" tcl-mode-syntax-table) - (modify-syntax-entry ?: "_" tcl-mode-syntax-table) - (modify-syntax-entry ?! "_" tcl-mode-syntax-table) - (modify-syntax-entry ?$ "_" tcl-mode-syntax-table) ; FIXME use "'"? - (modify-syntax-entry ?/ "_" tcl-mode-syntax-table) - (modify-syntax-entry ?~ "_" tcl-mode-syntax-table) - (modify-syntax-entry ?< "_" tcl-mode-syntax-table) - (modify-syntax-entry ?= "_" tcl-mode-syntax-table) - (modify-syntax-entry ?> "_" tcl-mode-syntax-table) - (modify-syntax-entry ?| "_" tcl-mode-syntax-table) - (modify-syntax-entry ?\( "()" tcl-mode-syntax-table) - (modify-syntax-entry ?\) ")(" tcl-mode-syntax-table) - (modify-syntax-entry ?\; "." tcl-mode-syntax-table) - (modify-syntax-entry ?\n "> " tcl-mode-syntax-table) - (modify-syntax-entry ?\f "> " tcl-mode-syntax-table) - (modify-syntax-entry ?# "< " tcl-mode-syntax-table)) - -(defvar inferior-tcl-mode-map nil - "Keymap used in Inferior Tcl mode.") - -;; XEmacs menu. -(defvar tcl-xemacs-menu - '(["Beginning of function" tcl-beginning-of-defun t] - ["End of function" tcl-end-of-defun t] - ["Mark function" tcl-mark-defun t] - ["Indent region" indent-region (tcl-mark)] - ["Comment region" comment-region (tcl-mark)] - ["Uncomment region" tcl-uncomment-region (tcl-mark)] - "----" - ["Show Tcl process buffer" inferior-tcl t] - ["Send function to Tcl process" tcl-eval-defun - (and inferior-tcl-buffer (get-buffer inferior-tcl-buffer))] - ["Send region to Tcl process" tcl-eval-region - (and inferior-tcl-buffer (get-buffer inferior-tcl-buffer))] - ["Send file to Tcl process" tcl-load-file - (and inferior-tcl-buffer (get-buffer inferior-tcl-buffer))] - ["Restart Tcl process with file" tcl-restart-with-file t] - "----" - ["Tcl help" tcl-help-on-word tcl-help-directory-list] - ["Send bug report" tcl-submit-bug-report t]) - "XEmacs menu for Tcl mode.") - -;; GNU Emacs does menus via keymaps. Do it in a function in case we -;; later decide to add it to inferior Tcl mode as well. -(defun tcl-add-fsf-menu (map) - (define-key map [menu-bar] (make-sparse-keymap)) - ;; This fails in Emacs 19.22 and earlier. - (require 'lmenu) - (let ((menu (make-lucid-menu-keymap "Tcl" tcl-xemacs-menu))) - (define-key map [menu-bar tcl] (cons "Tcl" menu)) - ;; The following is intended to compute the key sequence - ;; information for the menu. It doesn't work. - (x-popup-menu nil menu))) - -(defun tcl-fill-mode-map () - (define-key tcl-mode-map "{" 'tcl-electric-char) - (define-key tcl-mode-map "}" 'tcl-electric-brace) - (define-key tcl-mode-map "[" 'tcl-electric-char) - (define-key tcl-mode-map "]" 'tcl-electric-char) - (define-key tcl-mode-map ";" 'tcl-electric-char) - (define-key tcl-mode-map "#" 'tcl-electric-hash) - ;; FIXME. - (define-key tcl-mode-map "\e\C-a" 'tcl-beginning-of-defun) - ;; FIXME. - (define-key tcl-mode-map "\e\C-e" 'tcl-end-of-defun) - ;; FIXME. - (define-key tcl-mode-map "\e\C-h" 'tcl-mark-defun) - (define-key tcl-mode-map "\e\C-q" 'indent-tcl-exp) - (define-key tcl-mode-map "\t" 'tcl-indent-command) - (define-key tcl-mode-map "\M-;" 'tcl-indent-for-comment) - (define-key tcl-mode-map "\M-\C-x" 'tcl-eval-defun) - (define-key tcl-mode-map "\C-c\C-b" 'tcl-submit-bug-report) - (and (fboundp 'comment-region) - (define-key tcl-mode-map "\C-c\C-c" 'comment-region)) - (define-key tcl-mode-map "\C-c\C-i" 'tcl-help-on-word) - (define-key tcl-mode-map "\C-c\C-v" 'tcl-eval-defun) - (define-key tcl-mode-map "\C-c\C-f" 'tcl-load-file) - (define-key tcl-mode-map "\C-c\C-t" 'inferior-tcl) - (define-key tcl-mode-map "\C-c\C-x" 'tcl-eval-region) - (define-key tcl-mode-map "\C-c\C-s" 'switch-to-tcl) - - ;; Make menus. - (if (and tcl-using-emacs-19 (not tcl-using-xemacs-19)) - (progn - (tcl-add-fsf-menu tcl-mode-map)))) - -(defun tcl-fill-inferior-map () - (define-key inferior-tcl-mode-map "\t" 'comint-dynamic-complete) - (define-key inferior-tcl-mode-map "\M-?" - 'comint-dynamic-list-filename-completions) - (define-key inferior-tcl-mode-map "\e\C-a" 'tcl-beginning-of-defun) - (define-key inferior-tcl-mode-map "\e\C-e" 'tcl-end-of-defun) - (define-key inferior-tcl-mode-map "\M-\C-x" 'tcl-eval-defun) - (define-key inferior-tcl-mode-map "\C-c\C-b" 'tcl-submit-bug-report) - (define-key inferior-tcl-mode-map "\C-c\C-i" 'tcl-help-on-word) - (define-key inferior-tcl-mode-map "\C-c\C-v" 'tcl-eval-defun) - (define-key inferior-tcl-mode-map "\C-c\C-f" 'tcl-load-file) - (define-key inferior-tcl-mode-map "\C-c\C-t" 'inferior-tcl) - (define-key inferior-tcl-mode-map "\C-c\C-x" 'tcl-eval-region) - (define-key inferior-tcl-mode-map "\C-c\C-s" 'switch-to-tcl)) - -(if tcl-mode-map - () - (setq tcl-mode-map (make-sparse-keymap)) - (tcl-fill-mode-map)) - -(if inferior-tcl-mode-map - () - ;; FIXME Use keymap inheritance here? FIXME we override comint - ;; keybindings here. Maybe someone has a better set? - (setq inferior-tcl-mode-map (copy-keymap comint-mode-map)) - (tcl-fill-inferior-map)) - - -(defvar inferior-tcl-buffer nil - "*The current inferior-tcl process buffer. - -MULTIPLE PROCESS SUPPORT -=========================================================================== -To run multiple Tcl processes, you start the first up with -\\[inferior-tcl]. It will be in a buffer named `*inferior-tcl*'. -Rename this buffer with \\[rename-buffer]. You may now start up a new -process with another \\[inferior-tcl]. It will be in a new buffer, -named `*inferior-tcl*'. You can switch between the different process -buffers with \\[switch-to-buffer]. - -Commands that send text from source buffers to Tcl processes -- like -`tcl-eval-defun' or `tcl-load-file' -- have to choose a process to -send to, when you have more than one Tcl process around. This is -determined by the global variable `inferior-tcl-buffer'. Suppose you -have three inferior Lisps running: - Buffer Process - foo inferior-tcl - bar inferior-tcl<2> - *inferior-tcl* inferior-tcl<3> -If you do a \\[tcl-eval-defun] command on some Lisp source code, what -process do you send it to? - -- If you're in a process buffer (foo, bar, or *inferior-tcl*), - you send it to that process. -- If you're in some other buffer (e.g., a source file), you - send it to the process attached to buffer `inferior-tcl-buffer'. -This process selection is performed by function `inferior-tcl-proc'. - -Whenever \\[inferior-tcl] fires up a new process, it resets -`inferior-tcl-buffer' to be the new process's buffer. If you only run -one process, this does the right thing. If you run multiple -processes, you can change `inferior-tcl-buffer' to another process -buffer with \\[set-variable].") - -;; -;; Hooks and other customization. -;; - -(defcustom tcl-mode-hook nil - "Hook run on entry to Tcl mode. - -Several functions exist which are useful to run from your -`tcl-mode-hook' (see each function's documentation for more -information): - - tcl-guess-application - Guesses a default setting for `tcl-application' based on any - \"#!\" line at the top of the file. - tcl-hashify-buffer - Quotes all \"#\" characters that don't correspond to actual - Tcl comments. (Useful when editing code not originally created - with this mode). - tcl-auto-fill-mode - Auto-filling of Tcl comments. - -Emacs 19 users can add functions to the hook with `add-hook': - - (add-hook 'tcl-mode-hook 'tcl-guess-application) - -Emacs 18 users must use `setq': - - (setq tcl-mode-hook (cons 'tcl-guess-application tcl-mode-hook))" - :type 'hook - :group 'tcl) - - -(defcustom inferior-tcl-mode-hook nil - "Hook for customizing Inferior Tcl mode." - :type 'hook - :group 'tcl) - -(defvar tcl-proc-list - '("proc" "method" "itcl_class") - "List of commands whose first argument defines something. -This exists because some people (eg, me) use \"defvar\" et al. -Call `tcl-set-proc-regexp' and `tcl-set-font-lock-keywords' -after changing this list.") - -(defvar tcl-proc-regexp nil - "Regexp to use when matching proc headers.") - -(defvar tcl-typeword-list - '("global" "upvar" "inherit" "public" "protected" "common") - "List of Tcl keywords denoting \"type\". Used only for highlighting. -Call `tcl-set-font-lock-keywords' after changing this list.") - -;; Generally I've picked control operators to be keywords. -(defvar tcl-keyword-list - '("if" "then" "else" "elseif" "for" "foreach" "break" "continue" "while" - "eval" "case" "in" "switch" "default" "exit" "error" "proc" "return" - "uplevel" "constructor" "destructor" "itcl_class" "loop" "for_array_keys" - "for_recursive_glob" "for_file") - "List of Tcl keywords. Used only for highlighting. -Default list includes some TclX keywords. -Call `tcl-set-font-lock-keywords' after changing this list.") - -(defvar tcl-font-lock-keywords nil - "Keywords to highlight for Tcl. See variable `font-lock-keywords'. -This variable is generally set from `tcl-proc-regexp', -`tcl-typeword-list', and `tcl-keyword-list' by the function -`tcl-set-font-lock-keywords'.") - -;; FIXME need some way to recognize variables because array refs look -;; like 2 sexps. -(defvar tcl-type-alist - '( - ("proc" nil tcl-expr tcl-commands) - ("method" nil tcl-expr tcl-commands) - ("destructor" tcl-commands) - ("constructor" tcl-commands) - ("expr" tcl-expr) - ("catch" tcl-commands) - ("if" tcl-expr "then" tcl-commands) - ("elseif" tcl-expr "then" tcl-commands) - ("elseif" tcl-expr tcl-commands) - ("if" tcl-expr tcl-commands) - ("while" tcl-expr tcl-commands) - ("for" tcl-commands tcl-expr tcl-commands tcl-commands) - ("foreach" nil nil tcl-commands) - ("for_file" nil nil tcl-commands) - ("for_array_keys" nil nil tcl-commands) - ("for_recursive_glob" nil nil nil tcl-commands) - ;; Loop handling is not perfect, because the third argument can be - ;; either a command or an expr, and there is no real way to look - ;; forward. - ("loop" nil tcl-expr tcl-expr tcl-commands) - ("loop" nil tcl-expr tcl-commands) - ) - "Alist that controls indentation. -\(Actually, this really only controls what happens on continuation lines). -Each entry looks like `(KEYWORD TYPE ...)'. -Each type entry describes a sexp after the keyword, and can be one of: -* nil, meaning that this sexp has no particular type. -* tcl-expr, meaning that this sexp is an arithmetic expression. -* tcl-commands, meaning that this sexp holds Tcl commands. -* a string, which must exactly match the string at the corresponding - position for a match to be made. - -For example, the entry for the \"loop\" command is: - - (\"loop\" nil tcl-expr tcl-commands) - -This means that the \"loop\" command has three arguments. The first -argument is ignored (for indentation purposes). The second argument -is a Tcl expression, and the last argument is Tcl commands.") - -(defvar tcl-explain-indentation nil - "If not `nil', debugging message will be printed during indentation.") - - - -;; -;; Work around differences between various versions of Emacs. -;; - -;; We use this because Lemacs 19.9 has what we need. -(defconst tcl-pps-has-arg-6 - (or tcl-using-emacs-19 - (and tcl-using-xemacs-19 - (condition-case nil - (progn - (parse-partial-sexp (point) (point) nil nil nil t) - t) - (error nil)))) - "t if using an emacs which supports sixth (\"commentstop\") argument -to parse-partial-sexp.") - -;; Its pretty bogus to have to do this, but there is no easier way to -;; say "match not syntax-1 and not syntax-2". Too bad you can't put -;; \s in [...]. This sickness is used in Emacs 19 to match a defun -;; starter. (It is used for this in v18 as well). -;;(defconst tcl-omit-ws-regexp -;; (concat "^\\(\\s" -;; (mapconcat 'char-to-string "w_.()\"\\$'/" "\\|\\s") -;; "\\)\\S(*") -;; "Regular expression that matches everything except space, comment -;;starter, and comment ender syntax codes.") - -;; FIXME? Instead of using the hairy regexp above, we just use a -;; simple one. -;;(defconst tcl-omit-ws-regexp "^[^] \t\n#}]\\S(*" -;; "Regular expression used in locating function definitions.") - -;; Here's another stab. I think this one actually works. Now the -;; problem seems to be that there is a bug in Emacs 19.22 where -;; end-of-defun doesn't really use the brace matching the one that -;; trails defun-prompt-regexp. -(defconst tcl-omit-ws-regexp "^[^ \t\n#}][^\n}]+}*[ \t]+") - -(defun tcl-internal-beginning-of-defun (&optional arg) - "Move backward to next beginning-of-defun. -With argument, do this that many times. -Returns t unless search stops due to end of buffer." - (interactive "p") - (if (or (null arg) (= arg 0)) - (setq arg 1)) - (let (success) - (while (progn - (setq arg (1- arg)) - (and (>= arg 0) - (setq success - (re-search-backward tcl-omit-ws-regexp nil 'move 1)))) - (while (and (looking-at "[]#}]") - (setq success - (re-search-backward tcl-omit-ws-regexp nil 'move 1))))) - (beginning-of-line) - (not (null success)))) - -(defun tcl-internal-end-of-defun (&optional arg) - "Move forward to next end of defun. -An end of a defun is found by moving forward from the beginning of one." - (interactive "p") - (if (or (null arg) (= arg 0)) (setq arg 1)) - (let ((start (point))) - ;; Was forward-char. I think this works a little better. - (forward-line) - (tcl-beginning-of-defun) - (while (> arg 0) - (while (and (re-search-forward tcl-omit-ws-regexp nil 'move 1) - (progn (beginning-of-line) t) - (looking-at "[]#}]") - (progn (forward-line) t))) - (let ((next-line (save-excursion - (forward-line) - (point)))) - (while (< (point) next-line) - (forward-sexp))) - (forward-line) - (if (> (point) start) (setq arg (1- arg)))))) - -;; In Emacs 19, we can use begining-of-defun as long as we set up a -;; certain regexp. In Emacs 18, we need our own function. -(fset 'tcl-beginning-of-defun - (if tcl-using-emacs-19 - 'beginning-of-defun - 'tcl-internal-beginning-of-defun)) - -;; Ditto end-of-defun. -(fset 'tcl-end-of-defun - (if (and tcl-using-emacs-19 (not tcl-using-xemacs-19)) - 'end-of-defun - 'tcl-internal-end-of-defun)) - -;; Internal mark-defun that is used for losing Emacsen. -(defun tcl-internal-mark-defun () - "Put mark at end of Tcl function, point at beginning." - (interactive) - (push-mark (point)) - (tcl-end-of-defun) - (if tcl-using-emacs-19 - (push-mark (point) nil t) - (push-mark (point))) - (tcl-beginning-of-defun) - (backward-paragraph)) - -;; In GNU Emacs 19-23 and later, mark-defun works as advertised. I -;; don't know about XEmacs, so for now it and Emacs 18 just lose. -(fset 'tcl-mark-defun - (if tcl-using-emacs-19-23 - 'mark-defun - 'tcl-internal-mark-defun)) - -;; In GNU Emacs 19, mark takes an additional "force" argument. I -;; don't know about XEmacs, so I'm just assuming it is the same. -;; Emacs 18 doesn't have this argument. -(defun tcl-mark () - "Return mark, or nil if none." - (if tcl-using-emacs-19 - (mark t) - (mark))) - - - -;; -;; Some helper functions. -;; - -(defun tcl-set-proc-regexp () - "Set `tcl-proc-regexp' from variable `tcl-proc-list'." - (setq tcl-proc-regexp (concat "^\\s-*\\(" - (mapconcat 'identity tcl-proc-list "\\|") - "\\)[ \t]+"))) - -(defun tcl-set-font-lock-keywords () - "Set `tcl-font-lock-keywords'. -Uses variables `tcl-proc-regexp' and `tcl-keyword-list'." - (setq tcl-font-lock-keywords - (list - ;; Names of functions (and other "defining things"). - (list (concat tcl-proc-regexp "\\([^ \t\n]+\\)") - 2 'font-lock-function-name-face) - - ;; Names of type-defining things. - (list (concat "\\(\\s-\\|^\\)\\(" - ;; FIXME Use 'regexp-quote? - (mapconcat 'identity tcl-typeword-list "\\|") - "\\)\\(\\s-\\|$\\)") - 2 'font-lock-type-face) - - ;; Keywords. Only recognized if surrounded by whitespace. - ;; FIXME consider using "not word or symbol", not - ;; "whitespace". - (cons (concat "\\(\\s-\\|^\\)\\(" - ;; FIXME Use regexp-quote? - (mapconcat 'identity tcl-keyword-list "\\|") - "\\)\\(\\s-\\|$\\)") - 2) - ))) - -(if tcl-proc-regexp - () - (tcl-set-proc-regexp)) - -(if tcl-font-lock-keywords - () - (tcl-set-font-lock-keywords)) - - - -;; -;; The mode itself. -;; - -;;;###autoload -(defun tcl-mode () - "Major mode for editing Tcl code. -Expression and list commands understand all Tcl brackets. -Tab indents for Tcl code. -Paragraphs are separated by blank lines only. -Delete converts tabs to spaces as it moves back. - -Variables controlling indentation style: - tcl-indent-level - Indentation of Tcl statements within surrounding block. - tcl-continued-indent-level - Indentation of continuation line relative to first line of command. - -Variables controlling user interaction with mode (see variable -documentation for details): - tcl-tab-always-indent - Controls action of TAB key. - tcl-auto-newline - Non-nil means automatically newline before and after braces, brackets, - and semicolons inserted in Tcl code. - tcl-electric-hash-style - Controls action of `#' key. - tcl-use-hairy-comment-detector - If t, use more complicated, but slower, comment detector. - This variable is only used in GNU Emacs 19. - tcl-use-smart-word-finder - If not nil, use a smarter, Tcl-specific way to find the current - word when looking up help on a Tcl command. - -Turning on Tcl mode calls the value of the variable `tcl-mode-hook' -with no args, if that value is non-nil. Read the documentation for -`tcl-mode-hook' to see what kinds of interesting hook functions -already exist. - -Commands: -\\{tcl-mode-map}" - (interactive) - (kill-all-local-variables) - (use-local-map tcl-mode-map) - (setq major-mode 'tcl-mode) - (setq mode-name "Tcl") - (setq local-abbrev-table tcl-mode-abbrev-table) - (set-syntax-table tcl-mode-syntax-table) - - (make-local-variable 'paragraph-start) - (make-local-variable 'paragraph-separate) - (if (and tcl-using-emacs-19-23 - (>= emacs-minor-version 29)) - (progn - ;; In Emacs 19.29, you aren't supposed to start these with a - ;; ^. - (setq paragraph-start "$\\| ") - (setq paragraph-separate paragraph-start)) - (setq paragraph-start (concat "^$\\|" page-delimiter)) - (setq paragraph-separate paragraph-start)) - (make-local-variable 'paragraph-ignore-fill-prefix) - (setq paragraph-ignore-fill-prefix t) - (make-local-variable 'fill-paragraph-function) - (setq fill-paragraph-function 'tcl-do-fill-paragraph) - - (make-local-variable 'indent-line-function) - (setq indent-line-function 'tcl-indent-line) - ;; Tcl doesn't require a final newline. - ;; (make-local-variable 'require-final-newline) - ;; (setq require-final-newline t) - - (make-local-variable 'comment-start) - (setq comment-start "# ") - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "#+ *") - (make-local-variable 'comment-column) - (setq comment-column 40) - (make-local-variable 'comment-end) - (setq comment-end "") - - (make-local-variable 'outline-regexp) - (setq outline-regexp "[^\n\^M]") - (make-local-variable 'outline-level) - (setq outline-level 'tcl-outline-level) - - (make-local-variable 'font-lock-keywords) - (setq font-lock-keywords tcl-font-lock-keywords) - - ;; The following only really makes sense under GNU Emacs 19. - (make-local-variable 'imenu-create-index-function) - (setq imenu-create-index-function 'tcl-imenu-create-index-function) - (make-local-variable 'parse-sexp-ignore-comments) - - ;; Settings for new dabbrev code. - (make-local-variable 'dabbrev-case-fold-search) - (setq dabbrev-case-fold-search nil) - (make-local-variable 'dabbrev-case-replace) - (setq dabbrev-case-replace nil) - (make-local-variable 'dabbrev-abbrev-skip-leading-regexp) - (setq dabbrev-abbrev-skip-leading-regexp "[$!]") - (make-local-variable 'dabbrev-abbrev-char-regexp) - (setq dabbrev-abbrev-char-regexp "\\sw\\|\\s_") - - (if tcl-using-emacs-19 - (progn - ;; This can only be set to t in Emacs 19 and XEmacs. - ;; Emacs 18 and Epoch lose. - (setq parse-sexp-ignore-comments t) - ;; XEmacs has defun-prompt-regexp, but I don't believe - ;; that it works for end-of-defun -- only for - ;; beginning-of-defun. - (make-local-variable 'defun-prompt-regexp) - (setq defun-prompt-regexp tcl-omit-ws-regexp) - ;; The following doesn't work in Lucid Emacs 19.6, but maybe - ;; it will appear in later versions. - (make-local-variable 'add-log-current-defun-function) - (setq add-log-current-defun-function 'add-log-tcl-defun)) - (setq parse-sexp-ignore-comments nil)) - - ;; Put Tcl menu into menubar for XEmacs. This happens - ;; automatically for GNU Emacs. - (if (and tcl-using-xemacs-19 - current-menubar - (not (assoc "Tcl" current-menubar))) - (progn - (set-buffer-menubar (copy-sequence current-menubar)) - (add-menu nil "Tcl" tcl-xemacs-menu))) - ;; Append Tcl menu to popup menu for XEmacs. - (if (and tcl-using-xemacs-19 (boundp 'mode-popup-menu)) - (setq mode-popup-menu - (cons (concat mode-name " Mode Commands") tcl-xemacs-menu))) - - ;; If hilit19 is loaded, add our stuff. - (if (featurep 'hilit19) - (tcl-hilit)) - - (run-hooks 'tcl-mode-hook)) - - - -;; This is used for braces, brackets, and semi (except for closing -;; braces, which are handled specially). -(defun tcl-electric-char (arg) - "Insert character and correct line's indentation." - (interactive "p") - ;; Indent line first; this looks better if parens blink. - (tcl-indent-line) - (self-insert-command arg) - (if (and tcl-auto-newline (= last-command-char ?\;)) - (progn - (newline) - (tcl-indent-line)))) - -;; This is used for closing braces. If tcl-auto-newline is set, can -;; insert a newline both before and after the brace, depending on -;; context. FIXME should this be configurable? Does anyone use this? -(defun tcl-electric-brace (arg) - "Insert character and correct line's indentation." - (interactive "p") - ;; If auto-newlining and there is stuff on the same line, insert a - ;; newline first. - (if tcl-auto-newline - (progn - (if (save-excursion - (skip-chars-backward " \t") - (bolp)) - () - (tcl-indent-line) - (newline)) - ;; In auto-newline case, must insert a newline after each - ;; brace. So an explicit loop is needed. - (while (> arg 0) - (insert last-command-char) - (tcl-indent-line) - (newline) - (setq arg (1- arg)))) - (self-insert-command arg)) - (tcl-indent-line)) - - - -(defun tcl-indent-command (&optional arg) - "Indent current line as Tcl code, or in some cases insert a tab character. -If tcl-tab-always-indent is t (the default), always indent current line. -If tcl-tab-always-indent is nil and point is not in the indentation -area at the beginning of the line, a TAB is inserted. -Other values of tcl-tab-always-indent cause the first possible action -from the following list to take place: - - 1. Move from beginning of line to correct indentation. - 2. Delete an empty comment. - 3. Move forward to start of comment, indenting if necessary. - 4. Move forward to end of line, indenting if necessary. - 5. Create an empty comment. - 6. Move backward to start of comment, indenting if necessary." - (interactive "p") - (cond - ((not tcl-tab-always-indent) - ;; Indent if in indentation area, otherwise insert TAB. - (if (<= (current-column) (current-indentation)) - (tcl-indent-line) - (self-insert-command arg))) - ((eq tcl-tab-always-indent t) - ;; Always indent. - (tcl-indent-line)) - (t - ;; "Perl-mode" style TAB command. - (let* ((ipoint (point)) - (eolpoint (progn - (end-of-line) - (point))) - (comment-p (tcl-in-comment))) - (cond - ((= ipoint (save-excursion - (beginning-of-line) - (point))) - (beginning-of-line) - (tcl-indent-line) - ;; If indenting didn't leave us in column 0, go to the - ;; indentation. Otherwise leave point at end of line. This - ;; is a hack. - (if (= (point) (save-excursion - (beginning-of-line) - (point))) - (end-of-line) - (back-to-indentation))) - ((and comment-p (looking-at "[ \t]*$")) - ;; Empty comment, so delete it. We also delete any ";" - ;; characters at the end of the line. I think this is - ;; friendlier, but I don't know how other people will feel. - (backward-char) - (skip-chars-backward " \t;") - (delete-region (point) eolpoint)) - ((and comment-p (< ipoint (point))) - ;; Before comment, so skip to it. - (tcl-indent-line) - (indent-for-comment)) - ((/= ipoint eolpoint) - ;; Go to end of line (since we're not there yet). - (goto-char eolpoint) - (tcl-indent-line)) - ((not comment-p) - (tcl-indent-line) - (tcl-indent-for-comment)) - (t - ;; Go to start of comment. We don't leave point where it is - ;; because we want to skip comment-start-skip. - (tcl-indent-line) - (indent-for-comment))))))) - -(defun tcl-indent-line () - "Indent current line as Tcl code. -Return the amount the indentation changed by." - (let ((indent (calculate-tcl-indent nil)) - beg shift-amt - (case-fold-search nil) - (pos (- (point-max) (point)))) - (beginning-of-line) - (setq beg (point)) - (cond ((eq indent nil) - (setq indent (current-indentation))) - (t - (skip-chars-forward " \t") - (if (listp indent) (setq indent (car indent))) - (cond ((= (following-char) ?}) - (setq indent (- indent tcl-indent-level))) - ((= (following-char) ?\]) - (setq indent (- indent 1)))))) - (skip-chars-forward " \t") - (setq shift-amt (- indent (current-column))) - (if (zerop shift-amt) - (if (> (- (point-max) pos) (point)) - (goto-char (- (point-max) pos))) - (delete-region beg (point)) - (indent-to indent) - ;; If initial point was within line's indentation, - ;; position after the indentation. Else stay at same point in text. - (if (> (- (point-max) pos) (point)) - (goto-char (- (point-max) pos)))) - shift-amt)) - -(defun tcl-figure-type () - "Determine type of sexp at point. -This is either 'tcl-expr, 'tcl-commands, or nil. Puts point at start -of sexp that indicates types. - -See documentation for variable `tcl-type-alist' for more information." - (let ((count 0) - result - word-stack) - (while (and (< count 5) - (not result)) - (condition-case nil - (progn - ;; FIXME should use "tcl-backward-sexp", which would skip - ;; over entire variables, etc. - (backward-sexp) - (if (looking-at "[a-zA-Z_]+") - (let ((list tcl-type-alist) - entry) - (setq word-stack (cons (tcl-word-no-props) word-stack)) - (while (and list (not result)) - (setq entry (car list)) - (setq list (cdr list)) - (let ((index 0)) - (while (and entry (<= index count)) - ;; Abort loop if string does not match word on - ;; stack. - (and (stringp (car entry)) - (not (string= (car entry) - (nth index word-stack))) - (setq entry nil)) - (setq entry (cdr entry)) - (setq index (1+ index))) - (and (> index count) - (not (stringp (car entry))) - (setq result (car entry))) - ))) - (setq word-stack (cons nil word-stack)))) - (error nil)) - (setq count (1+ count))) - (and tcl-explain-indentation - (message "Indentation type %s" result)) - result)) - -(defun calculate-tcl-indent (&optional parse-start) - "Return appropriate indentation for current line as Tcl code. -In usual case returns an integer: the column to indent to. -Returns nil if line starts inside a string, t if in a comment." - (save-excursion - (beginning-of-line) - (let* ((indent-point (point)) - (case-fold-search nil) - (continued-line - (save-excursion - (if (bobp) - nil - (backward-char) - (= ?\\ (preceding-char))))) - (continued-indent-value (if continued-line - tcl-continued-indent-level - 0)) - state - containing-sexp - found-next-line) - (if parse-start - (goto-char parse-start) - (tcl-beginning-of-defun)) - (while (< (point) indent-point) - (setq parse-start (point)) - (setq state (parse-partial-sexp (point) indent-point 0)) - (setq containing-sexp (car (cdr state)))) - (cond ((or (nth 3 state) (nth 4 state)) - ;; Inside comment or string. Return nil or t if should - ;; not change this line - (nth 4 state)) - ((null containing-sexp) - ;; Line is at top level. - continued-indent-value) - (t - ;; Set expr-p if we are looking at the expression part of - ;; an "if", "expr", etc statement. Set commands-p if we - ;; are looking at the body part of an if, while, etc - ;; statement. FIXME Should check for "for" loops here. - (goto-char containing-sexp) - (let* ((sexpr-type (tcl-figure-type)) - (expr-p (eq sexpr-type 'tcl-expr)) - (commands-p (eq sexpr-type 'tcl-commands)) - (expr-start (point))) - ;; Find the first statement in the block and indent - ;; like it. The first statement in the block might be - ;; on the same line, so what we do is skip all - ;; "virtually blank" lines, looking for a non-blank - ;; one. A line is virtually blank if it only contains - ;; a comment and whitespace. FIXME continued comments - ;; aren't supported. They are a wart on Tcl anyway. - ;; We do it this funky way because we want to know if - ;; we've found a statement on some line _after_ the - ;; line holding the sexp opener. - (goto-char containing-sexp) - (forward-char) - (if (and (< (point) indent-point) - (looking-at "[ \t]*\\(#.*\\)?$")) - (progn - (forward-line) - (while (and (< (point) indent-point) - (looking-at "[ \t]*\\(#.*\\)?$")) - (setq found-next-line t) - (forward-line)))) - (if (or continued-line - (/= (char-after containing-sexp) ?{) - expr-p) - (progn - ;; Line is continuation line, or the sexp opener - ;; is not a curly brace, or we are are looking at - ;; an `expr' expression (which must be split - ;; specially). So indentation is column of first - ;; good spot after sexp opener (with some added - ;; in the continued-line case). If there is no - ;; nonempty line before the indentation point, we - ;; use the column of the character after the sexp - ;; opener. - (if (>= (point) indent-point) - (progn - (goto-char containing-sexp) - (forward-char)) - (skip-chars-forward " \t")) - (+ (current-column) continued-indent-value)) - ;; After a curly brace, and not a continuation line. - ;; So take indentation from first good line after - ;; start of block, unless that line is on the same - ;; line as the opening brace. In this case use the - ;; indentation of the opening brace's line, plus - ;; another indent step. If we are in the body part - ;; of an "if" or "while" then the indentation is - ;; taken from the line holding the start of the - ;; statement. - (if (and (< (point) indent-point) - found-next-line) - (current-indentation) - (if commands-p - (goto-char expr-start) - (goto-char containing-sexp)) - (+ (current-indentation) tcl-indent-level))))))))) - - - -(defun indent-tcl-exp () - "Indent each line of the Tcl grouping following point." - (interactive) - (let ((indent-stack (list nil)) - (contain-stack (list (point))) - (case-fold-search nil) - outer-loop-done inner-loop-done state ostate - this-indent last-sexp continued-line - (next-depth 0) - last-depth) - (save-excursion - (forward-sexp 1)) - (save-excursion - (setq outer-loop-done nil) - (while (and (not (eobp)) (not outer-loop-done)) - (setq last-depth next-depth) - ;; Compute how depth changes over this line - ;; plus enough other lines to get to one that - ;; does not end inside a comment or string. - ;; Meanwhile, do appropriate indentation on comment lines. - (setq inner-loop-done nil) - (while (and (not inner-loop-done) - (not (and (eobp) (setq outer-loop-done t)))) - (setq ostate state) - (setq state (parse-partial-sexp (point) (progn (end-of-line) (point)) - nil nil state)) - (setq next-depth (car state)) - (if (and (car (cdr (cdr state))) - (>= (car (cdr (cdr state))) 0)) - (setq last-sexp (car (cdr (cdr state))))) - (if (or (nth 4 ostate)) - (tcl-indent-line)) - (if (or (nth 3 state)) - (forward-line 1) - (setq inner-loop-done t))) - (if (<= next-depth 0) - (setq outer-loop-done t)) - (if outer-loop-done - nil - ;; If this line had ..))) (((.. in it, pop out of the levels - ;; that ended anywhere in this line, even if the final depth - ;; doesn't indicate that they ended. - (while (> last-depth (nth 6 state)) - (setq indent-stack (cdr indent-stack) - contain-stack (cdr contain-stack) - last-depth (1- last-depth))) - (if (/= last-depth next-depth) - (setq last-sexp nil)) - ;; Add levels for any parens that were started in this line. - (while (< last-depth next-depth) - (setq indent-stack (cons nil indent-stack) - contain-stack (cons nil contain-stack) - last-depth (1+ last-depth))) - (if (null (car contain-stack)) - (setcar contain-stack - (or (car (cdr state)) - (save-excursion - (forward-sexp -1) - (point))))) - (forward-line 1) - (setq continued-line - (save-excursion - (backward-char) - (= (preceding-char) ?\\))) - (skip-chars-forward " \t") - (if (eolp) - nil - (if (and (car indent-stack) - (>= (car indent-stack) 0)) - ;; Line is on an existing nesting level. - (setq this-indent (car indent-stack)) - ;; Just started a new nesting level. - ;; Compute the standard indent for this level. - (let ((val (calculate-tcl-indent - (if (car indent-stack) - (- (car indent-stack)))))) - (setcar indent-stack - (setq this-indent val)) - (setq continued-line nil))) - (cond ((not (numberp this-indent))) - ((= (following-char) ?}) - (setq this-indent (- this-indent tcl-indent-level))) - ((= (following-char) ?\]) - (setq this-indent (- this-indent 1)))) - ;; Put chosen indentation into effect. - (or (null this-indent) - (= (current-column) - (if continued-line - (+ this-indent tcl-indent-level) - this-indent)) - (progn - (delete-region (point) (progn (beginning-of-line) (point))) - (indent-to - (if continued-line - (+ this-indent tcl-indent-level) - this-indent))))))))) - ) - - - -;; -;; Interfaces to other packages. -;; - -(defun tcl-imenu-create-index-function () - "Generate alist of indices for imenu." - (let ((re (concat tcl-proc-regexp "\\([^ \t\n{]+\\)")) - alist prev-pos) - (goto-char (point-min)) - (imenu-progress-message prev-pos 0) - (save-match-data - (while (re-search-forward re nil t) - (imenu-progress-message prev-pos) - ;; Position on start of proc name, not beginning of line. - (setq alist (cons - (cons (buffer-substring (match-beginning 2) (match-end 2)) - (match-beginning 2)) - alist)))) - (imenu-progress-message prev-pos 100) - (nreverse alist))) - -;; FIXME Definition of function is very ad-hoc. Should use -;; tcl-beginning-of-defun. Also has incestuous knowledge about the -;; format of tcl-proc-regexp. -(defun add-log-tcl-defun () - "Return name of Tcl function point is in, or nil." - (save-excursion - (end-of-line) - (if (re-search-backward (concat tcl-proc-regexp "\\([^ \t\n{]+\\)") nil t) - (buffer-substring (match-beginning 2) - (match-end 2))))) - -(defun tcl-outline-level () - (save-excursion - (skip-chars-forward " \t") - (current-column))) - - - -;; -;; Helper functions for inferior Tcl mode. -;; - -;; This exists to let us delete the prompt when commands are sent -;; directly to the inferior Tcl. See gud.el for an explanation of how -;; it all works (I took it from there). This stuff doesn't really -;; work as well as I'd like it to. But I don't believe there is -;; anything useful that can be done. -(defvar inferior-tcl-delete-prompt-marker nil) - -(defun tcl-filter (proc string) - (let ((inhibit-quit t)) - (save-excursion - (set-buffer (process-buffer proc)) - (goto-char (process-mark proc)) - ;; Delete prompt if requested. - (if (marker-buffer inferior-tcl-delete-prompt-marker) - (progn - (delete-region (point) inferior-tcl-delete-prompt-marker) - (set-marker inferior-tcl-delete-prompt-marker nil))))) - (if tcl-using-emacs-19 - (comint-output-filter proc string) - (funcall comint-output-filter string))) - -(defun tcl-send-string (proc string) - (save-excursion - (set-buffer (process-buffer proc)) - (goto-char (process-mark proc)) - (beginning-of-line) - (if (looking-at comint-prompt-regexp) - (set-marker inferior-tcl-delete-prompt-marker (point)))) - (comint-send-string proc string)) - -(defun tcl-send-region (proc start end) - (save-excursion - (set-buffer (process-buffer proc)) - (goto-char (process-mark proc)) - (beginning-of-line) - (if (looking-at comint-prompt-regexp) - (set-marker inferior-tcl-delete-prompt-marker (point)))) - (comint-send-region proc start end)) - -(defun switch-to-tcl (eob-p) - "Switch to inferior Tcl process buffer. -With argument, positions cursor at end of buffer." - (interactive "P") - (if (get-buffer inferior-tcl-buffer) - (pop-to-buffer inferior-tcl-buffer) - (error "No current inferior Tcl buffer")) - (cond (eob-p - (push-mark) - (goto-char (point-max))))) - -(defun inferior-tcl-proc () - "Return current inferior Tcl process. -See variable `inferior-tcl-buffer'." - (let ((proc (get-buffer-process (if (eq major-mode 'inferior-tcl-mode) - (current-buffer) - inferior-tcl-buffer)))) - (or proc - (error "No Tcl process; see variable `inferior-tcl-buffer'")))) - -(defun tcl-eval-region (start end &optional and-go) - "Send the current region to the inferior Tcl process. -Prefix argument means switch to the Tcl buffer afterwards." - (interactive "r\nP") - (let ((proc (inferior-tcl-proc))) - (tcl-send-region proc start end) - (tcl-send-string proc "\n") - (if and-go (switch-to-tcl t)))) - -(defun tcl-eval-defun (&optional and-go) - "Send the current defun to the inferior Tcl process. -Prefix argument means switch to the Tcl buffer afterwards." - (interactive "P") - (save-excursion - (tcl-end-of-defun) - (let ((end (point))) - (tcl-beginning-of-defun) - (tcl-eval-region (point) end))) - (if and-go (switch-to-tcl t))) - - - -;; -;; Inferior Tcl mode itself. -;; - -(defun inferior-tcl-mode () - "Major mode for interacting with Tcl interpreter. - -A Tcl process can be started with M-x inferior-tcl. - -Entry to this mode runs the hooks comint-mode-hook and -inferior-tcl-mode-hook, in that order. - -You can send text to the inferior Tcl process from other buffers -containing Tcl source. - -Variables controlling Inferior Tcl mode: - tcl-application - Name of program to run. - tcl-command-switches - Command line arguments to `tcl-application'. - tcl-prompt-regexp - Matches prompt. - inferior-tcl-source-command - Command to use to read Tcl file in running application. - inferior-tcl-buffer - The current inferior Tcl process buffer. See variable - documentation for details on multiple-process support. - -The following commands are available: -\\{inferior-tcl-mode-map}" - (interactive) - (comint-mode) - (setq comint-prompt-regexp (or tcl-prompt-regexp - (concat "^" - (regexp-quote tcl-application) - ">"))) - (setq major-mode 'inferior-tcl-mode) - (setq mode-name "Inferior Tcl") - (if (boundp 'modeline-process) - (setq modeline-process '(": %s")) ; For XEmacs. - (setq mode-line-process '(": %s"))) - (use-local-map inferior-tcl-mode-map) - (setq local-abbrev-table tcl-mode-abbrev-table) - (set-syntax-table tcl-mode-syntax-table) - (if tcl-using-emacs-19 - (progn - (make-local-variable 'defun-prompt-regexp) - (setq defun-prompt-regexp tcl-omit-ws-regexp))) - (make-local-variable 'inferior-tcl-delete-prompt-marker) - (setq inferior-tcl-delete-prompt-marker (make-marker)) - (set-process-filter (get-buffer-process (current-buffer)) 'tcl-filter) - (run-hooks 'inferior-tcl-mode-hook)) - -;;;###autoload -(defun inferior-tcl (cmd) - "Run inferior Tcl process. -Prefix arg means enter program name interactively. -See documentation for function `inferior-tcl-mode' for more information." - (interactive - (list (if current-prefix-arg - (read-string "Run Tcl: " tcl-application) - tcl-application))) - (if (not (comint-check-proc "*inferior-tcl*")) - (progn - (set-buffer (apply (function make-comint) "inferior-tcl" cmd nil - tcl-command-switches)) - (inferior-tcl-mode))) - (make-local-variable 'tcl-application) - (setq tcl-application cmd) - (setq inferior-tcl-buffer "*inferior-tcl*") - (switch-to-buffer "*inferior-tcl*")) - -(and (fboundp 'defalias) - (defalias 'run-tcl 'inferior-tcl)) - - - -;; -;; Auto-fill support. -;; - -(defun tcl-real-command-p () - "Return nil if point is not at the beginning of a command. -A command is the first word on an otherwise empty line, or the -first word following a semicolon, opening brace, or opening bracket." - (save-excursion - (skip-chars-backward " \t") - (cond - ((bobp) t) - ((bolp) - (backward-char) - ;; Note -- continued comments are not supported here. I - ;; consider those to be a wart on the language. - (not (eq ?\\ (preceding-char)))) - (t - (memq (preceding-char) '(?\; ?{ ?\[)))))) - -;; FIXME doesn't actually return t. See last case. -(defun tcl-real-comment-p () - "Return t if point is just after the `#' beginning a real comment. -Does not check to see if previous char is actually `#'. -A real comment is either at the beginning of the buffer, -preceded only by whitespace on the line, or has a preceding -semicolon, opening brace, or opening bracket on the same line." - (save-excursion - (backward-char) - (tcl-real-command-p))) - -(defun tcl-hairy-scan-for-comment (state end always-stop) - "Determine if point is in a comment. -Returns a list of the form `(FLAG . STATE)'. STATE can be used -as input to future invocations. FLAG is nil if not in comment, -t otherwise. If in comment, leaves point at beginning of comment. -Only works in Emacs 19. See also `tcl-simple-scan-for-comment', a -simpler version that is often right, and works in Emacs 18." - (let ((bol (save-excursion - (goto-char end) - (beginning-of-line) - (point))) - real-comment - last-cstart) - (while (and (not last-cstart) (< (point) end)) - (setq real-comment nil) ;In case we've looped around and it is - ;set. - (setq state (parse-partial-sexp (point) end nil nil state t)) - (if (nth 4 state) - (progn - ;; If ALWAYS-STOP is set, stop even if we don't have a - ;; real comment, or if the comment isn't on the same line - ;; as the end. - (if always-stop (setq last-cstart (point))) - ;; If we have a real comment, then set the comment - ;; starting point if we are on the same line as the ending - ;; location. - (setq real-comment (tcl-real-comment-p)) - (if real-comment - (progn - (and (> (point) bol) (setq last-cstart (point))) - ;; NOTE Emacs 19 has a misfeature whereby calling - ;; parse-partial-sexp with COMMENTSTOP set and with - ;; an initial list that says point is in a comment - ;; will cause an immediate return. So we must skip - ;; over the comment ourselves. - (beginning-of-line 2))) - ;; Frob the state to make it look like we aren't in a - ;; comment. - (setcar (nthcdr 4 state) nil)))) - (and last-cstart - (goto-char last-cstart)) - (cons real-comment state))) - -(defun tcl-hairy-in-comment () - "Return t if point is in a comment, and leave point at beginning -of comment." - (let ((save (point))) - (tcl-beginning-of-defun) - (car (tcl-hairy-scan-for-comment nil save nil)))) - -(defun tcl-simple-in-comment () - "Return t if point is in comment, and leave point at beginning -of comment. This is faster that `tcl-hairy-in-comment', but is -correct less often." - (let ((save (point)) - comment) - (beginning-of-line) - (while (and (< (point) save) (not comment)) - (search-forward "#" save 'move) - (setq comment (tcl-real-comment-p))) - comment)) - -(defun tcl-in-comment () - "Return t if point is in comment, and leave point at beginning -of comment." - (if (and tcl-pps-has-arg-6 - tcl-use-hairy-comment-detector) - (tcl-hairy-in-comment) - (tcl-simple-in-comment))) - -(defun tcl-do-fill-paragraph (ignore) - "fill-paragraph function for Tcl mode. Only fills in a comment." - (let (in-comment col where) - (save-excursion - (end-of-line) - (setq in-comment (tcl-in-comment)) - (if in-comment - (progn - (setq where (1+ (point))) - (setq col (1- (current-column)))))) - (and in-comment - (save-excursion - (back-to-indentation) - (= col (current-column))) - ;; In a comment. Set the fill prefix, and find the paragraph - ;; boundaries by searching for lines that look like - ;; comment-only lines. - (let ((fill-prefix (buffer-substring (progn - (beginning-of-line) - (point)) - where)) - p-start p-end) - ;; Search backwards. - (save-excursion - (while (looking-at "^[ \t]*#") - (forward-line -1)) - (forward-line) - (setq p-start (point))) - - ;; Search forwards. - (save-excursion - (while (looking-at "^[ \t]*#") - (forward-line)) - (setq p-end (point))) - - ;; Narrow and do the fill. - (save-restriction - (narrow-to-region p-start p-end) - (fill-paragraph ignore))))) - t) - -(defun tcl-do-auto-fill () - "Auto-fill function for Tcl mode. Only auto-fills in a comment." - (if (> (current-column) fill-column) - (let ((fill-prefix "# ") - in-comment col) - (save-excursion - (setq in-comment (tcl-in-comment)) - (if in-comment - (setq col (1- (current-column))))) - (if in-comment - (progn - (do-auto-fill) - (save-excursion - (back-to-indentation) - (delete-region (point) (save-excursion - (beginning-of-line) - (point))) - (indent-to-column col))))))) - - - -;; -;; Help-related code. -;; - -(defvar tcl-help-saved-dirs nil - "Saved help directories. -If `tcl-help-directory-list' changes, this allows `tcl-help-on-word' -to update the alist.") - -(defvar tcl-help-alist nil - "Alist with command names as keys and filenames as values.") - -(defun tcl-help-snarf-commands (dirlist) - "Build alist of commands and filenames." - (while dirlist - (let ((files (directory-files (car dirlist) t))) - (while files - (if (and (file-directory-p (car files)) - (not - (let ((fpart (file-name-nondirectory (car files)))) - (or (equal fpart ".") - (equal fpart ".."))))) - (let ((matches (directory-files (car files) t))) - (while matches - (or (file-directory-p (car matches)) - (setq tcl-help-alist - (cons - (cons (file-name-nondirectory (car matches)) - (car matches)) - tcl-help-alist))) - (setq matches (cdr matches))))) - (setq files (cdr files)))) - (setq dirlist (cdr dirlist)))) - -(defun tcl-reread-help-files () - "Set up to re-read files, and then do it." - (interactive) - (message "Building Tcl help file index...") - (setq tcl-help-saved-dirs tcl-help-directory-list) - (setq tcl-help-alist nil) - (tcl-help-snarf-commands tcl-help-directory-list) - (message "Building Tcl help file index...done")) - -(defun tcl-word-no-props () - "Like current-word, but strips properties." - (let ((word (current-word))) - (and (fboundp 'set-text-properties) - (set-text-properties 0 (length word) nil word)) - word)) - -(defun tcl-current-word (flag) - "Return current command word, or nil. -If FLAG is nil, just uses `current-word'. -Otherwise scans backward for most likely Tcl command word." - (if (and flag - (memq major-mode '(tcl-mode inferior-tcl-mode))) - (condition-case nil - (save-excursion - ;; Look backward for first word actually in alist. - (if (bobp) - () - (while (and (not (bobp)) - (not (tcl-real-command-p))) - (backward-sexp))) - (if (assoc (tcl-word-no-props) tcl-help-alist) - (tcl-word-no-props))) - (error nil)) - (tcl-word-no-props))) - -;;;###autoload -(defun tcl-help-on-word (command &optional arg) - "Get help on Tcl command. Default is word at point. -Prefix argument means invert sense of `tcl-use-smart-word-finder'." - (interactive - (list - (progn - (if (not (equal tcl-help-directory-list tcl-help-saved-dirs)) - (tcl-reread-help-files)) - (let ((word (tcl-current-word - (if current-prefix-arg - (not tcl-use-smart-word-finder) - tcl-use-smart-word-finder)))) - (completing-read - (if (or (null word) (string= word "")) - "Help on Tcl command: " - (format "Help on Tcl command (default %s): " word)) - tcl-help-alist nil t))) - current-prefix-arg)) - (if (not (equal tcl-help-directory-list tcl-help-saved-dirs)) - (tcl-reread-help-files)) - (if (string= command "") - (setq command (tcl-current-word - (if arg - (not tcl-use-smart-word-finder) - tcl-use-smart-word-finder)))) - (let* ((help (get-buffer-create "*Tcl help*")) - (cell (assoc command tcl-help-alist)) - (file (and cell (cdr cell)))) - (set-buffer help) - (delete-region (point-min) (point-max)) - (if file - (progn - (insert "*** " command "\n\n") - (insert-file-contents file)) - (if (string= command "") - (insert "Magical Pig!") - (insert "Tcl command " command " not in help\n"))) - (set-buffer-modified-p nil) - (goto-char (point-min)) - (display-buffer help))) - - - -;; -;; Other interactive stuff. -;; - -(defvar tcl-previous-dir/file nil - "Record last directory and file used in loading. -This holds a cons cell of the form `(DIRECTORY . FILE)' -describing the last `tcl-load-file' command.") - -(defun tcl-load-file (file &optional and-go) - "Load a Tcl file into the inferior Tcl process. -Prefix argument means switch to the Tcl buffer afterwards." - (interactive - (list - ;; car because comint-get-source returns a list holding the - ;; filename. - (car (comint-get-source "Load Tcl file: " - (or (and - (eq major-mode 'tcl-mode) - (buffer-file-name)) - tcl-previous-dir/file) - '(tcl-mode) t)) - current-prefix-arg)) - (comint-check-source file) - (setq tcl-previous-dir/file (cons (file-name-directory file) - (file-name-nondirectory file))) - (tcl-send-string (inferior-tcl-proc) - (format inferior-tcl-source-command (tcl-quote file))) - (if and-go (switch-to-tcl t))) - -(defun tcl-restart-with-file (file &optional and-go) - "Restart inferior Tcl with file. -If an inferior Tcl process exists, it is killed first. -Prefix argument means switch to the Tcl buffer afterwards." - (interactive - (list - (car (comint-get-source "Restart with Tcl file: " - (or (and - (eq major-mode 'tcl-mode) - (buffer-file-name)) - tcl-previous-dir/file) - '(tcl-mode) t)) - current-prefix-arg)) - (let* ((buf (if (eq major-mode 'inferior-tcl-mode) - (current-buffer) - inferior-tcl-buffer)) - (proc (and buf (get-process buf)))) - (cond - ((not (and buf (get-buffer buf))) - ;; I think this will be ok. - (inferior-tcl tcl-application) - (tcl-load-file file and-go)) - ((or - (not (comint-check-proc buf)) - (yes-or-no-p - "A Tcl process is running, are you sure you want to reset it? ")) - (save-excursion - (comint-check-source file) - (setq tcl-previous-dir/file (cons (file-name-directory file) - (file-name-nondirectory file))) - (comint-exec (get-buffer-create buf) - (if proc - (process-name proc) - "inferior-tcl") - tcl-application file tcl-command-switches) - (if and-go (switch-to-tcl t))))))) - -;; FIXME I imagine you can do this under Emacs 18. I just don't know -;; how. -(defun tcl-auto-fill-mode (&optional arg) - "Like `auto-fill-mode', but controls filling of Tcl comments." - (interactive "P") - (and (not tcl-using-emacs-19) - (error "You must use Emacs 19 to get this feature.")) - ;; Following code taken from "auto-fill-mode" (simple.el). - (prog1 - (setq auto-fill-function - (if (if (null arg) - (not auto-fill-function) - (> (prefix-numeric-value arg) 0)) - 'tcl-do-auto-fill - nil)) - (force-mode-line-update))) - -;; hilit19 support from "Chris Alfeld" <calfeld@math.utah.edu> -(defun tcl-hilit () - (hilit-set-mode-patterns - '(tcl-mode) - '( - ("\\(^ *\\|\; *\\)#.*$" nil comment) - ("[^\\]\\(\\$[A-Za-z0-9\\-\\_./\\(\\)]+\\)" 1 label) - ("[^_]\\<\\(append\\|array\\|auto_execok\\|auto_load\\|auto_mkindex\\|auto_reset\\|break\\|case\\|catch\\|cd\\|close\\|concat\\|continue\\|eof\\|error\\|eval\\|exec\\|exit\\|expr\\|file\\|flush\\|for\\|foreach\\|format\\|gets\\|glob\\|global\\|history\\|if\\|incr\\|info\\|join\\|lappend\\|lindex\\|linsert\\|list\\|llength\\|lrange\\|lreplace\\|lsearch\\|lsort\\|open\\|pid\\|proc\\|puts\\|pwd\\|read\\|regexp\\|regsub\\|rename\\|return\\|scan\\|seek\\|set\\|source\\|split\\|string\\|switch\\|tell\\|time\\|trace\\|unknown\\|unset\\|uplevel\\|upvar\\|while\\)\\>[^_]" 1 keyword) ; tcl keywords - ("[^_]\\<\\(after\\|bell\\|bind\\|bindtags\\|clipboard\\|destroy\\|fileevent\\|focus\\|grab\\|image\\|lower\\|option\\|pack\\|place\\|raise\\|scale\\|selection\\|send\\|subst\\|tk\\|tk_popup\\|tkwait\\|update\\|winfo\\|wm\\)\\>[^_]" 1 define) ; tk keywords - ("[^_]\\<\\(button\\|canvas\\|checkbutton\\|entry\\|frame\\|label\\|listbox\\|menu\\|menubutton\\|message\\|radiobutton\\|scrollbar\\|text\\|toplevel\\)\\>[^_]" 1 decl) ; tk widgets - ("[^_]\\<\\(tix\\((ButtonBox\\|Baloon\\|Control\\|DirList\\|ExFileSelectBox\\|ExFileSelectDialog\\|FileEntry\\|HList\\|LabelEntry\\|LabelFrame\\|NoteBook\\|OptionMenu\\|PanedWindow\\|PopupMenu\\|ScrolledHList\\|ScrolledText\\|ScrolledWindow\\|Select\\|StdButtonBox\\)\\)\\>[^_]" 1 defun) ; tix widgets - ("[{}\\\"\\(\\)]" nil include) ; misc punctuation - ))) - -(defun tcl-electric-hash (&optional count) - "Insert a `#' and quote if it does not start a real comment. -Prefix arg is number of `#'s to insert. -See variable `tcl-electric-hash-style' for description of quoting -styles." - (interactive "p") - (or count (setq count 1)) - (if (> count 0) - (let ((type - (if (eq tcl-electric-hash-style 'smart) - (if (> count 3) ; FIXME what is "smart"? - 'quote - 'backslash) - tcl-electric-hash-style)) - comment) - (if type - (progn - (save-excursion - (insert "#") - (setq comment (tcl-in-comment))) - (delete-char 1) - (and tcl-explain-indentation (message "comment: %s" comment)) - (cond - ((eq type 'quote) - (if (not comment) - (insert "\""))) - ((eq type 'backslash) - ;; The following will set count to 0, so the - ;; insert-char can still be run. - (if (not comment) - (while (> count 0) - (insert "\\#") - (setq count (1- count))))) - (t nil)))) - (insert-char ?# count)))) - -(defun tcl-hashify-buffer () - "Quote all `#'s in current buffer that aren't Tcl comments." - (interactive) - (save-excursion - (goto-char (point-min)) - (if (and tcl-pps-has-arg-6 tcl-use-hairy-comment-detector) - (let (state - result) - (while (< (point) (point-max)) - (setq result (tcl-hairy-scan-for-comment state (point-max) t)) - (if (car result) - (beginning-of-line 2) - (backward-char) - (if (eq ?# (following-char)) - (insert "\\")) - (forward-char)) - (setq state (cdr result)))) - (while (and (< (point) (point-max)) - (search-forward "#" nil 'move)) - (if (tcl-real-comment-p) - (beginning-of-line 2) - ;; There's really no good way for the simple converter to - ;; work. So we just quote # if it isn't already quoted. - ;; Bogus, but it works. - (backward-char) - (if (not (eq ?\\ (preceding-char))) - (insert "\\")) - (forward-char)))))) - -(defun tcl-indent-for-comment () - "Indent this line's comment to comment column, or insert an empty comment. -Is smart about syntax of Tcl comments. -Parts of this were taken from indent-for-comment (simple.el)." - (interactive "*") - (end-of-line) - (or (tcl-in-comment) - (progn - ;; Not in a comment, so we have to insert one. Create an - ;; empty comment (since there isn't one on this line). If - ;; line is not blank, make sure we insert a ";" first. - (skip-chars-backward " \t") - (let ((eolpoint (point))) - (beginning-of-line) - (if (/= (point) eolpoint) - (progn - (goto-char eolpoint) - (insert - (if (tcl-real-command-p) "" ";") - "# ") - (backward-char)))))) - ;; Point is just after the "#" starting a comment. Move it as - ;; appropriate. - (let* ((indent (if comment-indent-hook - (funcall comment-indent-hook) - (funcall comment-indent-function))) - (begpos (progn - (backward-char) - (point)))) - (if (/= begpos indent) - (progn - (skip-chars-backward " \t" (save-excursion - (beginning-of-line) - (point))) - (delete-region (point) begpos) - (indent-to indent))) - (looking-at comment-start-skip) ; Always true. - (goto-char (match-end 0)) - ;; I don't like the effect of the next two. - ;;(skip-chars-backward " \t" (match-beginning 0)) - ;;(skip-chars-backward "^ \t" (match-beginning 0)) - )) - -;; The following was inspired by the Tcl editing mode written by -;; Gregor Schmid <schmid@fb3-s7.math.TU-Berlin.DE>. His version also -;; attempts to snarf the command line options from the command line, -;; but I didn't think that would really be that helpful (doesn't seem -;; like it owould be right enough. His version also looks for the -;; "#!/bin/csh ... exec" hack, but that seemed even less useful. -;; FIXME should make sure that the application mentioned actually -;; exists. -(defun tcl-guess-application () - "Attempt to guess Tcl application by looking at first line. -The first line is assumed to look like \"#!.../program ...\"." - (save-excursion - (goto-char (point-min)) - (if (looking-at "#![^ \t]*/\\([^ \t\n/]+\\)\\([ \t]\\|$\\)") - (progn - (make-local-variable 'tcl-application) - (setq tcl-application (buffer-substring (match-beginning 1) - (match-end 1))))))) - -;; This only exists to put on the menubar. I couldn't figure out any -;; other way to do it. FIXME should take "number of #-marks" -;; argument. -(defun tcl-uncomment-region (beg end) - "Uncomment region." - (interactive "r") - (comment-region beg end -1)) - - - -;; -;; XEmacs menu support. -;; Taken from schmid@fb3-s7.math.TU-Berlin.DE (Gregor Schmid), -;; who wrote a different Tcl mode. -;; We also have support for menus in FSF. We do this by -;; loading the XEmacs menu emulation code. -;; - -(defun tcl-popup-menu (e) - (interactive "@e") - (and tcl-using-emacs-19 - (not tcl-using-xemacs-19) - (if tcl-using-emacs-19-23 - (require 'lmenu) - ;; CAVEATS: - ;; * lmenu.el provides 'menubar, which is bogus. - ;; * lmenu.el causes menubars to be turned on everywhere. - ;; Doubly bogus! - ;; Both of these problems are fixed in Emacs 19.23. People - ;; using an Emacs before that just suffer. - (require 'menubar "lmenu"))) ;; This is annoying - ;; IMHO popup-menu should be autoloaded in FSF Emacs. Oh well. - (popup-menu tcl-xemacs-menu)) - - - -;; -;; Quoting and unquoting functions. -;; - -;; This quoting is sufficient to protect eg a filename from any sort -;; of expansion or splitting. Tcl quoting sure sucks. -(defun tcl-quote (string) - "Quote STRING according to Tcl rules." - (mapconcat (function (lambda (char) - (if (memq char '(?[ ?] ?{ ?} ?\\ ?\" ?$ ? ?\;)) - (concat "\\" (char-to-string char)) - (char-to-string char)))) - string "")) - - - -;; -;; Bug reporting. -;; - -(and (fboundp 'eval-when-compile) - (eval-when-compile - (require 'reporter))) - -(defun tcl-submit-bug-report () - "Submit via mail a bug report on Tcl mode." - (interactive) - (require 'reporter) - (and - (y-or-n-p "Do you really want to submit a bug report on Tcl mode? ") - (reporter-submit-bug-report - tcl-maintainer - (concat "Tcl mode " tcl-version) - '(tcl-indent-level - tcl-continued-indent-level - tcl-auto-newline - tcl-tab-always-indent - tcl-use-hairy-comment-detector - tcl-electric-hash-style - tcl-help-directory-list - tcl-use-smart-word-finder - tcl-application - tcl-command-switches - tcl-prompt-regexp - inferior-tcl-source-command - tcl-using-emacs-19 - tcl-using-emacs-19-23 - tcl-using-xemacs-19 - tcl-proc-list - tcl-proc-regexp - tcl-typeword-list - tcl-keyword-list - tcl-font-lock-keywords - tcl-pps-has-arg-6)))) - - - -(provide 'tcl) - -;;; tcl.el ends here -
--- a/lisp/modes/text-mode.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,178 +0,0 @@ -;;; text-mode.el --- text mode, and its idiosyncratic commands. - -;; Copyright (C) 1985, 1992, 1994 Free Software Foundation, Inc. - -;; Maintainer: FSF - -;; 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.34. - -;;; Commentary: - -;; This package provides the fundamental text mode documented in the -;; Emacs user's manual. - -;;; Code: - -(defvar text-mode-syntax-table nil - "Syntax table used while in text mode.") - -(defvar text-mode-abbrev-table nil - "Abbrev table used while in text mode.") -(define-abbrev-table 'text-mode-abbrev-table ()) - -(if text-mode-syntax-table - () - (setq text-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?\" ". " text-mode-syntax-table) - (modify-syntax-entry ?\\ ". " text-mode-syntax-table) - (modify-syntax-entry ?' "w " text-mode-syntax-table)) - -(defvar text-mode-map nil - "Keymap for Text mode. -Many other modes, such as Mail mode, Outline mode and Indented Text mode, -inherit all the commands defined in this map.") - -(if text-mode-map - () - (setq text-mode-map (make-sparse-keymap)) - ;; XEmacs change - (set-keymap-name text-mode-map 'text-mode-map) - (define-key text-mode-map "\e\t" 'ispell-complete-word) - (define-key text-mode-map "\t" 'tab-to-tab-stop) - (define-key text-mode-map "\es" 'center-line) - (define-key text-mode-map "\eS" 'center-paragraph)) - - -;(defun non-saved-text-mode () -; "Like text-mode, but delete auto save file when file is saved for real." -; (text-mode) -; (make-local-variable 'delete-auto-save-files) -; (setq delete-auto-save-files t)) - -(defun text-mode () - "Major mode for editing text intended for humans to read. -Special commands: -\\{text-mode-map} -Turning on Text mode calls the value of the variable `text-mode-hook', -if that value is non-nil." - (interactive) - (kill-all-local-variables) - (use-local-map text-mode-map) - (setq mode-name "Text") - (setq major-mode 'text-mode) - (setq local-abbrev-table text-mode-abbrev-table) - (set-syntax-table text-mode-syntax-table) - (run-hooks 'text-mode-hook)) - -(defvar indented-text-mode-map () - "Keymap for Indented Text mode. -All the commands defined in Text mode are inherited unless overridden.") - -(if indented-text-mode-map - () - ;; Make different definition for TAB before the one in text-mode-map, but - ;; share the rest. - ;; XEmacs change - (setq indented-text-mode-map (make-sparse-keymap)) - (set-keymap-name indented-text-mode-map 'indented-text-mode-map) - (set-keymap-parents indented-text-mode-map (list text-mode-map)) - (define-key indented-text-mode-map "\t" 'indent-relative)) - -(defun indented-text-mode () - "Major mode for editing text with indented paragraphs. -In this mode, paragraphs are delimited only by blank lines. -You can thus get the benefit of adaptive filling - (see the variable `adaptive-fill-mode'). -\\{indented-text-mode-map} -Turning on `indented-text-mode' calls the value of the variable -`text-mode-hook', if that value is non-nil." - (interactive) - (kill-all-local-variables) - (use-local-map text-mode-map) - (define-abbrev-table 'text-mode-abbrev-table ()) - (setq local-abbrev-table text-mode-abbrev-table) - (set-syntax-table text-mode-syntax-table) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'indent-relative-maybe) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat "$\\|" page-delimiter)) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate paragraph-start) - (use-local-map indented-text-mode-map) - (setq mode-name "Indented Text") - (setq major-mode 'indented-text-mode) - (run-hooks 'text-mode-hook 'indented-text-mode-hook)) - -(defun center-paragraph () - "Center each nonblank line in the paragraph at or after point. -See `center-line' for more info." - (interactive) - (save-excursion - (forward-paragraph) - (or (bolp) (newline 1)) - (let ((end (point))) - (backward-paragraph) - (center-region (point) end)))) - -(defun center-region (from to) - "Center each nonblank line starting in the region. -See `center-line' for more info." - (interactive "r") - (if (> from to) - (let ((tem to)) - (setq to from from tem))) - (save-excursion - (save-restriction - (narrow-to-region from to) - (goto-char from) - (while (not (eobp)) - (or (save-excursion (skip-chars-forward " \t") (eolp)) - (center-line)) - (forward-line 1))))) - -(defun center-line (&optional nlines) - "Center the line point is on, within the width specified by `fill-column'. -This means adjusting the indentation so that it equals -the distance between the end of the text and `fill-column'. -The argument NLINES says how many lines to center." - (interactive "P") - (if nlines (setq nlines (prefix-numeric-value nlines))) - (while (not (eq nlines 0)) - (save-excursion - (let ((lm (current-left-margin)) - line-length) - (beginning-of-line) - (delete-horizontal-space) - (end-of-line) - (delete-horizontal-space) - (setq line-length (current-column)) - (if (> (- fill-column lm line-length) 0) - (indent-line-to - (+ lm (/ (- fill-column lm line-length) 2)))))) - (cond ((null nlines) - (setq nlines 0)) - ((> nlines 0) - (setq nlines (1- nlines)) - (forward-line 1)) - ((< nlines 0) - (setq nlines (1+ nlines)) - (forward-line -1))))) - -;;; text-mode.el ends here
--- a/lisp/modes/verilog-mode.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,3308 +0,0 @@ -;;; verilog-mode.el --- major mode for editing verilog source in Emacs -;; -;; $Header: /afs/informatik.uni-tuebingen.de/local/web/xemacs/xemacs-cvs/XEmacs/xemacs/lisp/modes/Attic/verilog-mode.el,v 1.7 1997/07/26 22:09:50 steve Exp $ - -;; Copyright (C) 1996 Free Software Foundation, Inc. - -;; Author: Michael McNamara (mac@silicon-sorcery.com) -;; President, Silicon Sorcery -;; Keywords: languages - -;; This file is part of GNU Emacs. - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2 of the License, or -;; (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, write to the Free Software -;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: - -;;; This mode borrows heavily from the pascal-mode and the cc-mode of emacs - -;;; USAGE -;;; ===== - -;;; A major mode for editing Verilog HDL source code. When you have -;;; entered Verilog mode, you may get more info by pressing C-h m. You -;;; may also get online help describing various functions by: C-h f -;;; <Name of function you want described> - -;;; To set up automatic verilog mode, put this file in your load path, -;;; and include stuff like this in your .emacs: - -; (autoload 'verilog-mode "verilog-mode" "Verilog mode" t ) -; (setq auto-mode-alist (cons '("\\.v\\'" . verilog-mode) auto-mode-alist)) -; (setq auto-mode-alist (cons '("\\.dv\\'" . verilog-mode) auto-mode-alist)) - -;;; If you want to customize Verilog mode to fit your needs better, -;;; you may add these lines (the values of the variables presented -;;; here are the defaults): -;;; -;;; ;; User customization for Verilog mode -;;; (setq verilog-indent-level 3 -;;; verilog-indent-level-module 3 -;;; verilog-indent-level-declaration 3 -;;; verilog-indent-level-behavorial 3 -;;; verilog-case-indent 2 -;;; verilog-auto-newline t -;;; verilog-auto-indent-on-newline t -;;; verilog-tab-always-indent t -;;; verilog-auto-endcomments t -;;; verilog-minimum-comment-distance 40 -;;; verilog-indent-begin-after-if t -;;; verilog-auto-lineup '(all)) - -;;; KNOWN BUGS / BUGREPORTS -;;; ======================= This is beta code, and likely has -;;; bugs. Please report any and all bugs to me at mac@silicon-sorcery.com. -;; -;;; Code: - -(provide 'verilog-mode) - -;; This variable will always hold the version number of the mode -(defconst verilog-mode-version "$$Revision: 1.7 $$" - "Version of this verilog mode.") - -;; -;; A hack so we can support either custom, or the old defvar -;; -(eval-and-compile - (condition-case () - (require 'custom) - (error nil)) - (if (and (featurep 'custom) (fboundp 'custom-declare-variable)) - nil ;; We've got what we needed - ;; We have the old custom-library, hack around it! - (defmacro defgroup (&rest args) - nil) - (defmacro customize (&rest args) - (message "Sorry, Customise is not available with this version of emacs")) - (defmacro defcustom (var value doc &rest args) - (` (defvar (, var) (, value) (, doc)))))) - -(defun verilog-customize () - "Link to customize screen for Verilog" - (interactive) - (customize 'verilog) - ) - -(defgroup verilog nil - "Faciliates easy editing of Verilog source text" - :group 'languages) - -(defcustom verilog-indent-level 3 - "*Indentation of Verilog statements with respect to containing block." - :group 'verilog - :type 'integer - ) - -(defcustom verilog-indent-level-module 3 - "* Indentation of Module level Verilog statements. (eg always, initial) - Set to 0 to get initial and always statements lined up - on the left side of your screen." - :group 'verilog - :type 'integer - ) - -(defcustom verilog-indent-level-declaration 3 - "*Indentation of declarations with respect to containing block. - Set to 0 to get them list right under containing block." - :group 'verilog - :type 'integer - ) - -(defcustom verilog-indent-level-behavorial 3 - "*Absolute indentation of first begin in a task or function block - Set to 0 to get such code to start at the left side of the screen." - :group 'verilog - :type 'integer - ) - -(defcustom verilog-cexp-indent 1 - "*Indentation of Verilog statements split across lines." - :group 'verilog - :type 'integer - ) - -(defcustom verilog-case-indent 2 - "*Indentation for case statements." - :group 'verilog - :type 'integer - ) - -(defcustom verilog-auto-newline t - "*Non-nil means automatically newline after semicolons" - :group 'verilog - :type 'integer - ) - -(defcustom verilog-auto-indent-on-newline t - "*Non-nil means automatically indent line after newline" - :group 'verilog - :type 'integer - ) - -(defcustom verilog-tab-always-indent t - "*Non-nil means TAB in Verilog mode should always reindent the - current line, regardless of where in the line point is when the TAB - command is used." - :group 'verilog - :type 'integer - ) - -(defcustom verilog-indent-begin-after-if t - "*If true, indent begin statements following if, else, while, for - and repeat. otherwise, line them up." - :group 'verilog - :type 'boolean ) - -(defcustom verilog-auto-endcomments t - "*Non-nil means a comment /* ... */ is set after the ends which ends - cases and functions. The name of the function or case will be set - between the braces." - :group 'verilog - :type 'boolean ) - -(defcustom verilog-minimum-comment-distance 40 - "*Minimum distance between begin and end required before a comment - will be inserted. Setting this variable to zero results in every - end aquiring a comment; the default avoids too many redundanet - comments in tight quarters" - :group 'verilog - :type 'integer - ) - -(defvar verilog-auto-lineup '(all) - "*List of contexts where auto lineup of :'s or ='s should be done. -Elements can be of type: 'declaration' or 'case', which will do auto -lineup in declarations or case-statements respectively. The word 'all' -will do all lineups. '(case declaration) for instance will do lineup -in case-statements and parameterlist, while '(all) will do all -lineups." - ) - -(defvar verilog-mode-abbrev-table nil - "Abbrev table in use in Verilog-mode buffers.") - -(defvar verilog-font-lock-keywords-after-1930 - '( - ;; - ("^\\s-*\\(function\\|task\\|module\\|macromodule\\|primitive\\)\\>" - 1 font-lock-keyword-face) - ("^\\s-*\\(function\\|task\\|module\\|macromodule\\|primitive\\)\\>\\s-*\\(\\sw+\\)" - 2 font-lock-function-name-face nil t) - ("\\\\\\s-*" 0 'font-lock-function-name-face) - ("\\(@\\)\\|\\(#\\s-*\\(\\(\[0-9\]+\\('[hdxbo][0-9_xz]*\\)?\\)\\|\\((\[^)\]*)\\|\\sw+\\)\\)\\)" 0 font-lock-type-face) - ("\\(`\\s-*[A-Za-z][A-Za-z0-9_]*\\)" 0 font-lock-type-face) - ("\\<\\(in\\(teger\\|put\\|out\\)\\|parameter\\|defparam\\|output\\|supply[01]?\\|event\\|tri\\(0\\|1\\|reg\\|and\\|or\\)?\\|w\\(ire\\|or\\|and\\)\\|time\\|re\\(al\\(time\\)?\\|g\\)\\)\\>" - 0 font-lock-type-face) - ("\\(\\$[a-zA-Z][a-zA-Z0-9_\\$]*\\)\\|\\(\\<\\(begin\\|case[xz]?\\|end\\(case\\|function\\|task\\|module\\|table\\|primitive\\|specify\\)?\\|a\\(ssign\\|lways\\)\\|default\\|initial\\|table\\|\\(pos\\|neg\\)edge\\|else\\|for\\(ever\\|k\\)?\\|join\\|if\\|repeat\\|then\\|while\\|specify\\)\\>\\)" - 0 font-lock-keyword-face) - ) -) - -(defvar verilog-font-lock-keywords-before-1930 - '( - ("^\\s-*\\(function\\|task\\|module\\|macromodule\\|primitive\\)\\>" . 1) - ("^\\s-*\\(function\\|task\\|module\\|macromodule\\|primitive\\)\\>\\s-*\\(\\sw+\\)" - 2 font-lock-function-name-face nil t) - ("\\(\\\\\\s-*\\)\\|\\(`[ \t]*[A-Za-z][A-Za-z0-9_]*\\)" 0 font-lock-function-name-face) - ("[@#]" . font-lock-type-face) - ("\\<\\(in\\(teger\\|put\\|out\\)\\|parameter\\|defparam\\|output\\|supply[01]?\\|event\\|tri\\(0\\|1\\|reg\\|and\\|or\\)?\\|w\\(ire\\|or\\|and\\)\\|time\\|re\\(al\\(time\\)?\\|g\\)\\)\\>" - 0 font-lock-type-face) - ("\\(\\$[a-zA-Z][a-zA-Z0-9_\\$]*\\)\\|\\(\\<\\(begin\\|case[xz]?\\|end\\(case\\|function\\|task\\|module\\|table\\|primitive\\|specify\\)?\\|a\\(ssign\\|lways\\)\\|default\\|initial\\|table\\|\\(pos\\|neg\\)edge\\|else\\|for\\(ever\\|k\\)?\\|join\\|if\\|repeat\\|then\\|while\\|specify\\)\\>\\)" . font-lock-keyword-face) - ) -) - -;; Insure we have certain packages - -(if (fboundp 'eval-when-compile) - (eval-when-compile - (condition-case nil - (require 'imenu) - (error nil)) - (condition-case nil - (require 'reporter) - (error nil)) - (condition-case nil - (require 'easymenu) - (error nil)))) - -(defvar verilog-imenu-generic-expression - '((nil "^\\s-*\\(\\(m\\(odule\\|acromodule\\)\\)\\|primitive\\)\\s-+\\([a-zA-Z0-9_.:]+\\)" 3) - ("*Vars*" "^\\s-*\\(reg\\|wire\\)\\)\\s-+\\(\\|\\[[^\\]+]\\s-+\\)\\([-A-Za-z0-9+]+\\)" 3)) - "Imenu expression for Verilog-mode. See `imenu-generic-expression'.") - -(defvar verilog-mode-abbrev-table nil - "Abbrev table in use in Verilog-mode buffers.") - - -(define-abbrev-table 'verilog-mode-abbrev-table ()) - -(defvar verilog-mode-map () - "Keymap used in Verilog mode.") -(if verilog-mode-map - () - (setq verilog-mode-map (make-sparse-keymap)) - (define-key verilog-mode-map ";" 'electric-verilog-semi) - (define-key verilog-mode-map ":" 'electric-verilog-colon) - (define-key verilog-mode-map "=" 'electric-verilog-equal) - (define-key verilog-mode-map "\`" 'electric-verilog-tick) - (define-key verilog-mode-map "\t" 'electric-verilog-tab) - (define-key verilog-mode-map "\r" 'electric-verilog-terminate-line) - (define-key verilog-mode-map "\M-\C-b" 'electric-verilog-backward-sexp) - (define-key verilog-mode-map "\M-\C-f" 'electric-verilog-forward-sexp) - (define-key verilog-mode-map "\M-\r" (function (lambda () - (interactive) (electric-verilog-terminate-line 1)))) - (define-key verilog-mode-map "\M-\t" 'verilog-complete-word) - (define-key verilog-mode-map "\M-?" 'verilog-show-completions) - (define-key verilog-mode-map "\M-\C-h" 'verilog-mark-defun) - (define-key verilog-mode-map "\C-c\C-b" 'verilog-insert-block) - (define-key verilog-mode-map "\C-cb" 'verilog-label-be) - (define-key verilog-mode-map "\C-ci" 'verilog-pretty-declarations) - (define-key verilog-mode-map "\C-cC-b" 'verilog-submit-bug-report) - (define-key verilog-mode-map "\M-*" 'verilog-star-comment) - (define-key verilog-mode-map "\C-c\C-c" 'verilog-comment-region) - (define-key verilog-mode-map "\C-c\C-u" 'verilog-uncomment-region) - (define-key verilog-mode-map "\M-\C-a" 'verilog-beg-of-defun) - (define-key verilog-mode-map "\M-\C-e" 'verilog-end-of-defun) - (define-key verilog-mode-map "\C-c\C-d" 'verilog-goto-defun) - ) - -;; menus - -(if (string-match "XEmacs" emacs-version) - (defvar verilog-xemacs-menu - '("Verilog" - ["Line up declarations around point" verilog-pretty-declarations t] - ["Redo/insert comments on every end" verilog-label-be t] - "----" - ["Beginning of function" verilog-beg-of-defun t] - ["End of function" verilog-end-of-defun t] - ["Mark function" verilog-mark-defun t] - "----" - ["Move to beginning of block" electric-verilog-backward-sexp t] - ["Move to end of block" electric-verilog-forward-sexp t] - "----" - ["Comment Region" verilog-comment-region t] - ["UnComment Region" verilog-uncomment-region t] - ["Multi-line comment insert" verilog-star-comment t] - "----" - ["Insert begin-end block" verilog-insert-block t] - ["Complete word" verilog-complete-word t] - "----" - ["Submit bug report" verilog-submit-bug-report t] - ["Customize Verilog Mode..." verilog-customize t] - "XEmacs menu for VERILOG mode.")) - (progn - (easy-menu-define verilog-menu verilog-mode-map "Menu for Verilog mode" - '("Verilog" - ["Line up declarations around point" verilog-pretty-declarations t] - ["Redo/insert comments on every end" verilog-label-be t] - "----" - ["Beginning of function" verilog-beg-of-defun t] - ["End of function" verilog-end-of-defun t] - ["Mark function" verilog-mark-defun t] - "----" - ["Move to beginning of block" electric-verilog-backward-sexp t] - ["Move to end of block" electric-verilog-forward-sexp t] - "----" - ["Comment Region" verilog-comment-region t] - ["UnComment Region" verilog-uncomment-region t] - ["Multi-line comment insert" verilog-star-comment t] - "----" - ["Insert begin-end block" verilog-insert-block t] - ["Complete word" verilog-complete-word t] - "----" - ["Submit bug report" verilog-submit-bug-report t] - ["Customize Verilog Mode..." verilog-customize t] - )))) - -(defvar verilog-mode-abbrev-table nil - "Abbrev table in use in Verilog-mode buffers.") - -(define-abbrev-table 'verilog-mode-abbrev-table ()) - - -;;; -;;; Regular expressions used to calculate indent, etc. -;;; -(defconst verilog-symbol-re "\\<[a-zA-Z_][a-zA-Z_0-9.]*\\>") -(defconst verilog-case-re "\\(\\<case[xz]?\\>\\)") -;; Want to match -;; aa : -;; aa,bb : -;; a[34:32] : -;; a, -;; b : -(defconst - verilog-no-indent-begin-re - "\\<\\(if\\|else\\|while\\|for\\|repeat\\|always\\)\\>") -(defconst verilog-ends-re - (concat - "\\(\\<else\\>\\)\\|" - "\\(\\<if\\>\\)\\|" - "\\(\\<end\\>\\)\\|" - "\\(\\<join\\>\\)\\|" - "\\(\\<endcase\\>\\)\\|" - "\\(\\<endtable\\>\\)\\|" - "\\(\\<endspecify\\>\\)\\|" - "\\(\\<endfunction\\>\\)\\|" - "\\(\\<endtask\\>\\)")) - - -(defconst verilog-enders-re - (concat "\\(\\<endcase\\>\\)\\|" - "\\(\\<end\\>\\)\\|" - "\\(\\<end\\(\\(function\\)\\|\\(task\\)\\|" - "\\(module\\)\\|\\(primitive\\)\\)\\>\\)")) -(defconst verilog-endcomment-reason-re - (concat - "\\(\\<fork\\>\\)\\|" - "\\(\\<begin\\>\\)\\|" - "\\(\\<if\\>\\)\\|" - "\\(\\<else\\>\\)\\|" - "\\(\\<end\\>.*\\<else\\>\\)\\|" - "\\(\\<task\\>\\)\\|" - "\\(\\<function\\>\\)\\|" - "\\(\\<initial\\>\\)\\|" - "\\(\\<always\\>\\(\[ \t\]*@\\)?\\)\\|" - "\\(\\<while\\>\\)\\|" - "\\(\\<for\\(ever\\)?\\>\\)\\|" - "\\(\\<repeat\\>\\)\\|\\(\\<wait\\>\\)\\|" - "#")) - -(defconst verilog-named-block-re "begin[ \t]*:") -(defconst verilog-beg-block-re - ;; "begin" "case" "casex" "fork" "casez" "table" "specify" "function" "task" - "\\(\\<\\(begin\\>\\|case\\(\\>\\|x\\>\\|z\\>\\)\\|f\\(ork\\>\\|unction\\>\\)\\|specify\\>\\|ta\\(ble\\>\\|sk\\>\\)\\)\\)") - -(defconst verilog-beg-block-re-1 - "\\<\\(begin\\)\\|\\(case[xz]?\\)\\|\\(fork\\)\\|\\(table\\)\\|\\(specify\\)\\|\\(function\\)\\|\\(task\\)\\>") -(defconst verilog-end-block-re - ;; "end" "join" "endcase" "endtable" "endspecify" "endtask" "endfunction" - "\\<\\(end\\(\\>\\|case\\>\\|function\\>\\|specify\\>\\|ta\\(ble\\>\\|sk\\>\\)\\)\\|join\\>\\)") - -(defconst verilog-end-block-re-1 "\\(\\<end\\>\\)\\|\\(\\<endcase\\>\\)\\|\\(\\<join\\>\\)\\|\\(\\<endtable\\>\\)\\|\\(\\<endspecify\\>\\)\\|\\(\\<endfunction\\>\\)\\|\\(\\<endtask\\>\\)") -(defconst verilog-declaration-re - ;; "input" "inout" "output" "integer" "parameter" "defparam" "event" - ;; "real" "reg" "realtime" "time" "tri" "tri0" "tri1" "trireg" "triand" - ;; "trior" "supply0" "supply1" "wire" "wor" "wand" -"\\(\\<\\(defparam\\>\\|event\\>\\|in\\(out\\>\\|put\\>\\|teger\\>\\)\\|output\\>\\|parameter\\>\\|re\\(al\\(\\>\\|time\\>\\)\\|g\\>\\)\\|supply\\(0\\>\\|1\\>\\)\\|t\\(ime\\>\\|ri\\(0\\>\\|1\\>\\|\\>\\|and\\>\\|or\\>\\|reg\\>\\)\\)\\|w\\(and\\>\\|ire\\>\\|or\\>\\)\\)\\)") -(defconst verilog-declaration-re-1 (concat "^[ \t]*" verilog-declaration-re "[ \t]*\\(\\[[^]]*\\][ \t]*\\)?")) -(defconst verilog-declaration-re-2 (concat "[ \t]*" verilog-declaration-re "[ \t]*\\(\\[[^]]*\\][ \t]*\\)?")) -(defconst verilog-defun-re - ;;"module" "macromodule" "primitive" - "\\(\\<\\(m\\(acromodule\\>\\|odule\\>\\)\\|primitive\\>\\)\\)") -(defconst verilog-end-defun-re - ;; "endmodule" "endprimitive" -"\\(\\<end\\(module\\>\\|primitive\\>\\)\\)") -(defconst verilog-zero-indent-re - (concat verilog-defun-re "\\|" verilog-end-defun-re)) -(defconst verilog-directive-re - ;; "`else" "`ifdef" "`endif" "`define" "`undef" "`include" - "\\(\\<`\\(define\\>\\|e\\(lse\\>\\|ndif\\>\\)\\|i\\(fdef\\>\\|nclude\\>\\)\\|undef\\>\\)\\)") -(defconst verilog-autoindent-lines-re - ;; "macromodule" "module" "primitive" "end" "endcase" "endfunction" - ;; "endtask" "endmodule" "endprimitive" "endspecify" "endtable" "join" - ;; "begin" "else" "`else" "`ifdef" "`endif" "`define" "`undef" "`include" - "\\(\\<\\(`\\(define\\>\\|e\\(lse\\>\\|ndif\\>\\)\\|i\\(fdef\\>\\|nclude\\>\\)\\|undef\\>\\)\\|begin\\>\\|e\\(lse\\>\\|nd\\(\\>\\|case\\>\\|function\\>\\|module\\>\\|primitive\\>\\|specify\\>\\|ta\\(ble\\>\\|sk\\>\\)\\)\\)\\|join\\>\\|m\\(acromodule\\>\\|odule\\>\\)\\|primitive\\>\\)\\)") - -(defconst verilog-behavorial-block-beg-re - "\\(\\<initial\\>\\|\\<always\\>\\|\\<function\\>\\|\\<task\\>\\)") -(defconst verilog-indent-reg - (concat - "\\(\\<begin\\>\\|\\<case[xz]?\\>\\|\\<specify\\>\\|\\<fork\\>\\|\\<table\\>\\)\\|" - "\\(\\<end\\>\\|\\<join\\>\\|\\<endcase\\>\\|\\<endtable\\>\\|\\<endspecify\\>\\)\\|" - "\\(\\<module\\>\\|\\<macromodule\\>\\|\\<primitive\\>\\|\\<initial\\>\\|\\<always\\>\\)\\|" - "\\(\\<endmodule\\>\\|\\<endprimitive\\>\\)\\|" - "\\(\\<endtask\\>\\|\\<endfunction\\>\\)\\|" - "\\(\\<function\\>\\|\\<task\\>\\)" - ;; "\\|\\(\\<if\\>\\|\\<else\\>\\)" - )) -(defconst verilog-indent-re - "\\(\\<\\(always\\>\\|begin\\>\\|case\\(\\>\\|x\\>\\|z\\>\\)\\|end\\(\\>\\|case\\>\\|function\\>\\|module\\>\\|primitive\\>\\|specify\\>\\|ta\\(ble\\>\\|sk\\>\\)\\)\\|f\\(ork\\>\\|unction\\>\\)\\|initial\\>\\|join\\>\\|m\\(acromodule\\>\\|odule\\>\\)\\|primitive\\>\\|specify\\>\\|ta\\(ble\\>\\|sk\\>\\)\\)\\)") - -(defconst verilog-defun-level-re - ;; "module" "macromodule" "primitive" "initial" "always" "endtask" "endfunction" - "\\(\\<\\(always\\>\\|end\\(function\\>\\|task\\>\\)\\|initial\\>\\|m\\(acromodule\\>\\|odule\\>\\)\\|primitive\\>\\)\\)") -(defconst verilog-cpp-level-re - ;;"endmodule" "endprimitive" - "\\(\\<end\\(module\\>\\|primitive\\>\\)\\)") -(defconst verilog-behavorial-level-re - ;; "function" "task" - "\\(\\<\\(function\\>\\|task\\>\\)\\)") -(defconst verilog-complete-reg - ;; "always" "repeat" "case" "casex" "casez" "while" "if" "for" "forever" - "\\(\\<\\(always\\>\\|case\\(\\>\\|x\\>\\|z\\>\\)\\|else\\|for\\(\\>\\|ever\\>\\)\\|if\\>\\|repeat\\>\\|while\\>\\)\\)") -(defconst verilog-end-statement-re - (concat "\\(" verilog-beg-block-re "\\)\\|\\(" - verilog-end-block-re "\\)")) -(defconst verilog-endcase-re - (concat verilog-case-re "\\|" - "\\(endcase\\)\\|" - verilog-defun-re - )) -;;; Strings used to mark beginning and end of excluded text -(defconst verilog-exclude-str-start "/* -----\\/----- EXCLUDED -----\\/-----") -(defconst verilog-exclude-str-end " -----/\\----- EXCLUDED -----/\\----- */") - -(defconst verilog-emacs-features - (let ((major (and (boundp 'emacs-major-version) - emacs-major-version)) - (minor (and (boundp 'emacs-minor-version) - emacs-minor-version)) - flavor comments) - ;; figure out version numbers if not already discovered - (and (or (not major) (not minor)) - (string-match "\\([0-9]+\\).\\([0-9]+\\)" emacs-version) - (setq major (string-to-int (substring emacs-version - (match-beginning 1) - (match-end 1))) - minor (string-to-int (substring emacs-version - (match-beginning 2) - (match-end 2))))) - (if (not (and major minor)) - (error "Cannot figure out the major and minor version numbers.")) - ;; calculate the major version - (cond - ((= major 18) (setq major 'v18)) ;Emacs 18 - ((= major 4) (setq major 'v18)) ;Epoch 4 - ((= major 20) (setq major 'v20 - flavor 'XEmacs)) - ((= major 19) (setq major 'v19 ;Emacs 19 - flavor (if (or (string-match "Lucid" emacs-version) - (string-match "XEmacs" emacs-version)) - 'XEmacs 'FSF))) - ;; I don't know - (t (error "Cannot recognize major version number: %s" major))) - ;; XEmacs 19 uses 8-bit modify-syntax-entry flags, as do all - ;; patched Emacs 19, Emacs 18, Epoch 4's. Only Emacs 19 uses a - ;; 1-bit flag. Let's be as smart as we can about figuring this - ;; out. - (if (or (eq major 'v20) (eq major 'v19)) - (let ((table (copy-syntax-table))) - (modify-syntax-entry ?a ". 12345678" table) - (cond - ;; XEmacs pre 20 and Emacs pre 19.30 use vectors for syntax tables. - ((vectorp table) - (if (= (logand (lsh (aref table ?a) -16) 255) 255) - (setq comments '8-bit) - (setq comments '1-bit))) - ;; XEmacs 20 is known to be 8-bit - ((eq flavor 'XEmacs) (setq comments '8-bit)) - ;; Emacs 19.30 and beyond are known to be 1-bit - ((eq flavor 'FSF) (setq comments '1-bit)) - ;; Don't know what this is - (t (error "Couldn't figure out syntax table format.")) - )) - ;; Emacs 18 has no support for dual comments - (setq comments 'no-dual-comments)) - ;; lets do some minimal sanity checking. - (if (or - ;; Lemacs before 19.6 had bugs - (and (eq major 'v19) (eq flavor 'XEmacs) (< minor 6)) - ;; Emacs 19 before 19.21 has known bugs - (and (eq major 'v19) (eq flavor 'FSF) (< minor 21)) - ) - (with-output-to-temp-buffer "*verilog-mode warnings*" - (print (format -"The version of Emacs that you are running, %s, -has known bugs in its syntax parsing routines which will affect the -performance of verilog-mode. You should strongly consider upgrading to the -latest available version. verilog-mode may continue to work, after a -fashion, but strange indentation errors could be encountered." - emacs-version)))) - ;; Emacs 18, with no patch is not too good - (if (and (eq major 'v18) (eq comments 'no-dual-comments)) - (with-output-to-temp-buffer "*verilog-mode warnings*" - (print (format -"The version of Emacs 18 you are running, %s, -has known deficiencies in its ability to handle the dual verilog -(and C++) comments, (e.g. the // and /* */ comments). This will -not be much of a problem for you if you only use the /* */ comments, -but you really should strongly consider upgrading to one of the latest -Emacs 19's. In Emacs 18, you may also experience performance degradations. -Emacs 19 has some new built-in routines which will speed things up for you. -Because of these inherent problems, verilog-mode is not supported -on emacs-18." - emacs-version)))) - ;; Emacs 18 with the syntax patches are no longer supported - (if (and (eq major 'v18) (not (eq comments 'no-dual-comments))) - (with-output-to-temp-buffer "*verilog-mode warnings*" - (print (format -"You are running a syntax patched Emacs 18 variant. While this should -work for you, you may want to consider upgrading to Emacs 19. -The syntax patches are no longer supported either for verilog-mode.")))) - (list major comments)) - "A list of features extant in the Emacs you are using. -There are many flavors of Emacs out there, each with different -features supporting those needed by verilog-mode. Here's the current -supported list, along with the values for this variable: - - Vanilla Emacs 18/Epoch 4: (v18 no-dual-comments) - Emacs 18/Epoch 4 (patch2): (v18 8-bit) - XEmacs (formerly Lucid) 19: (v19 8-bit) - XEmacs 20: (v20 8-bit) - Emacs 19: (v19 1-bit).") - -(defconst verilog-comment-start-regexp "//\\|/\\*" - "Dual comment value for `comment-start-regexp'.") - -(defun verilog-populate-syntax-table (table) - ;; Populate the syntax TABLE - ;; DO NOT TRY TO SET _ (UNDERSCORE) TO WORD CLASS! - (modify-syntax-entry ?\\ "\\" table) - (modify-syntax-entry ?+ "." table) - (modify-syntax-entry ?- "." table) - (modify-syntax-entry ?= "." table) - (modify-syntax-entry ?% "." table) - (modify-syntax-entry ?< "." table) - (modify-syntax-entry ?> "." table) - (modify-syntax-entry ?& "." table) - (modify-syntax-entry ?| "." table) - (modify-syntax-entry ?_ "w" table) - (modify-syntax-entry ?\' "." table) -) - -(defun verilog-setup-dual-comments (table) - ;; Set up TABLE to handle block and line style comments - (cond - ((memq '8-bit verilog-emacs-features) - ;; XEmacs (formerly Lucid) has the best implementation - (modify-syntax-entry ?/ ". 1456" table) - (modify-syntax-entry ?* ". 23" table) - (modify-syntax-entry ?\n "> b" table) - ;; Give CR the same syntax as newline, for selective-display - (modify-syntax-entry ?\^m "> b" table)) - ((memq '1-bit verilog-emacs-features) - ;; Emacs 19 does things differently, but we can work with it - (modify-syntax-entry ?/ ". 124b" table) - (modify-syntax-entry ?* ". 23" table) - (modify-syntax-entry ?\n "> b" table) - ;; Give CR the same syntax as newline, for selective-display - (modify-syntax-entry ?\^m "> b" table)) - )) - -(defvar verilog-mode-syntax-table nil - "Syntax table used in verilog-mode buffers.") -(if verilog-mode-syntax-table - () - (setq verilog-mode-syntax-table (make-syntax-table)) - (verilog-populate-syntax-table verilog-mode-syntax-table) - ;; add extra comment syntax - (verilog-setup-dual-comments verilog-mode-syntax-table) - ) - -(defvar verilog-font-lock-keywords nil - "keyword highlighting used in verilog-mode buffers.") -(defvar verilog-font-lock-keywords-1 nil - "keyword highlighting used in verilog-mode buffers.") -(defvar verilog-font-lock-keywords-2 nil - "keyword highlighting used in verilog-mode buffers.") -(defvar verilog-font-lock-keywords-3 nil - "keyword highlighting used in verilog-mode buffers.") -(defvar verilog-font-lock-keywords-4 nil - "keyword highlighting used in verilog-mode buffers.") -(if verilog-font-lock-keywords - () - (cond - ;; We can assume 8-bit syntax table emacsen aupport new syntax - ((memq '8-bit verilog-emacs-features) - (setq verilog-font-lock-keywords verilog-font-lock-keywords-after-1930 - verilog-font-lock-keywords-1 verilog-font-lock-keywords-after-1930 - verilog-font-lock-keywords-2 verilog-font-lock-keywords-after-1930 - verilog-font-lock-keywords-3 verilog-font-lock-keywords-after-1930 - verilog-font-lock-keywords-4 verilog-font-lock-keywords-after-1930) - ) - (t - (setq verilog-font-lock-keywords verilog-font-lock-keywords-before-1930 - verilog-font-lock-keywords-1 verilog-font-lock-keywords-before-1930 - verilog-font-lock-keywords-2 verilog-font-lock-keywords-before-1930 - verilog-font-lock-keywords-3 verilog-font-lock-keywords-before-1930 - verilog-font-lock-keywords-4 verilog-font-lock-keywords-before-1930) - ) - ) - ) - -;;; -;;; Macros -;;; - -(defsubst verilog-re-search-forward (REGEXP BOUND NOERROR) - "Like re-search-forward, but skips over matches in comments or strings" - (set-match-data '(nil nil)) - (while (and - (re-search-forward REGEXP BOUND NOERROR) - (and (verilog-skip-forward-comment-or-string) - (progn - (store-match-data '(nil nil)) - (if BOUND - (< (point) BOUND) - t) - ) - ) - ) - ) - (match-end 0)) - -(defsubst verilog-re-search-backward (REGEXP BOUND NOERROR) - "Like re-search-backward, but skips over matches in comments or strings" - (set-match-data '(nil nil)) - (while (and - (re-search-backward REGEXP BOUND NOERROR) - (verilog-skip-backward-comment-or-string) - (not (set-match-data '(nil nil)))) - ()) - (match-end 0)) - -(defsubst verilog-get-beg-of-line (&optional arg) - (save-excursion - (beginning-of-line arg) - (point))) - -(defsubst verilog-get-end-of-line (&optional arg) - (save-excursion - (end-of-line arg) - (point))) - -(defun verilog-declaration-end () - (search-forward ";")) - -(defun electric-verilog-backward-sexp () - "Move backward over a sexp" - (interactive) - ;; before that see if we are in a comment - (verilog-backward-sexp) -) -(defun electric-verilog-forward-sexp () - "Move backward over a sexp" - (interactive) - ;; before that see if we are in a comment - (verilog-forward-sexp) -) - -(defun verilog-backward-sexp () - (let ((reg) - (elsec 1) - (found nil) - ) - (if (not (looking-at "\\<")) - (forward-word -1)) - (cond - ((verilog-skip-backward-comment-or-string) - ) - ((looking-at "\\<else\\>") - (setq reg (concat - verilog-end-block-re - "\\|\\(\\<else\\>\\)" - "\\|\\(\\<if\\>\\)" - )) - (while (and (not found) - (verilog-re-search-backward reg nil 'move)) - (cond - ((match-end 1) ; endblock - ; try to leap back to matching outward block by striding across - ; indent level changing tokens then immediately - ; previous line governs indentation. - (verilog-leap-to-head) - ) - ((match-end 2) ; else, we're in deep - (setq elsec (1+ elsec)) - ) - ((match-end 3) ; found it - (setq elsec (1- elsec)) - (if (= 0 elsec) - ;; Now previous line describes syntax - (setq found 't) - )) - ) - ) - ) - ((looking-at verilog-end-block-re) - (verilog-leap-to-head) - ) - ((looking-at "\\(endmodule\\>\\)\\|\\(\\<endprimitive\\>\\)") - (cond - ((match-end 1) - (verilog-re-search-backward "\\<\\(macro\\)?module\\>" nil 'move)) - ((match-end 2) - (verilog-re-search-backward "\\<primitive\\>" nil 'move)) - (t - (backward-sexp 1)))) - (t - (backward-sexp)) - ) ;; cond - ) - ) -(defun verilog-forward-sexp () - (let ((reg) - (st (point))) - (if (not (looking-at "\\<")) - (forward-word -1)) - (cond - ((verilog-skip-forward-comment-or-string) - (verilog-forward-syntactic-ws) - ) - ((looking-at verilog-beg-block-re-1);; begin|fork|case|table|specify - (cond - ((match-end 1) ; end - ;; Search forward for matching begin - (setq reg "\\(\\<begin\\>\\)\\|\\(\\<end\\>\\)" ) - ) - ((match-end 2) ; endcase - ;; Search forward for matching case - (setq reg "\\(\\<case[xz]?\\>[^:]\\)\\|\\(\\<endcase\\>\\)" ) - ) - ((match-end 3) ; join - ;; Search forward for matching fork - (setq reg "\\(\\<fork\\>\\)\\|\\(\\<join\\>\\)" ) - ) - ((match-end 4) ; endtable - ;; Search forward for matching table - (setq reg "\\(\\<table\\>\\)\\|\\(\\<endtable\\>\\)" ) - ) - ((match-end 5) ; endspecify - ;; Search forward for matching specify - (setq reg "\\(\\<specify\\>\\)\\|\\(\\<endspecify\\>\\)" ) - ) - ((match-end 6) ; endfunction - ;; Search forward for matching function - (setq reg "\\(\\<function\\>\\)\\|\\(\\<endfunction\\>\\)" ) - ) - ((match-end 7) ; endspecify - ;; Search forward for matching task - (setq reg "\\(\\<task\\>\\)\\|\\(\\<endtask\\>\\)" ) - ) - ) - (if (forward-word 1) - (catch 'skip - (let ((nest 1)) - (while (verilog-re-search-forward reg nil 'move) - (cond - ((match-end 2) ; end - (setq nest (1- nest)) - (if (= 0 nest) - (throw 'skip 1))) - ((match-end 1) ; begin - (setq nest (1+ nest))))) - ) - ) - ) - ) - ((looking-at "\\(\\<\\(macro\\)?module\\>\\)\\|\\(\\<primitive\\>\\)") - (cond - ((match-end 1) - (verilog-re-search-forward "\\<endmodule\\>" nil 'move)) - ((match-end 2) - (verilog-re-search-forward "\\<endprimitive\\>" nil 'move)) - (t - (goto-char st) - (if (= (following-char) ?\) ) - (forward-char 1) - (forward-sexp 1))))) - (t - (goto-char st) - (if (= (following-char) ?\) ) - (forward-char 1) - (forward-sexp 1))) - ) ;; cond - ) - ) - - -(defun verilog-declaration-beg () - (verilog-re-search-backward verilog-declaration-re (bobp) t)) - -(defsubst verilog-within-string () - (save-excursion - (nth 3 (parse-partial-sexp (verilog-get-beg-of-line) (point))))) - -(put 'verilog-mode 'font-lock-defaults - '((verilog-font-lock-keywords-after-1930 ) - nil ;; nil means highlight strings & comments as well as keywords - nil ;; nil means keywords must match case - nil ;; syntax table handled elsewhere - verilog-beg-of-defun ;; function to move to beginning of reasonable region to highlight - )) - -;;;###autoload -(defun verilog-mode () -"Major mode for editing Verilog code. \\<verilog-mode-map> -NEWLINE, TAB indents for Verilog code. -Delete converts tabs to spaces as it moves back. -Supports highlighting. - -Variables controlling indentation/edit style: - - verilog-indent-level (default 3) - Indentation of Verilog statements with respect to containing block. - verilog-indent-level-module (default 3) - Absolute indentation of Module level Verilog statements. - Set to 0 to get initial and always statements lined up - on the left side of your screen. - verilog-indent-level-declaration (default 3) - Indentation of declarations with respect to containing block. - Set to 0 to get them list right under containing block. - verilog-indent-level-behavorial (default 3) - Indentation of first begin in a task or function block - Set to 0 to get such code to linedup underneath the task or function keyword - verilog-cexp-indent (default 1) - Indentation of Verilog statements broken across lines. - verilog-case-indent (default 2) - Indentation for case statements. - verilog-auto-newline (default nil) - Non-nil means automatically newline after semicolons and the punctation - mark after an end. - verilog-auto-indent-on-newline (default t) - Non-nil means automatically indent line after newline - verilog-tab-always-indent (default t) - Non-nil means TAB in Verilog mode should always reindent the current line, - regardless of where in the line point is when the TAB command is used. - verilog-indent-begin-after-if (default t) - Non-nil means to indent begin statements following a preceding - if, else, while, for and repeat statements, if any. otherwise, - the begin is lined up with the preceding token. If t, you get: - if (a) - begin - otherwise you get: - if (a) - begin - verilog-auto-endcomments (default t) - Non-nil means a comment /* ... */ is set after the ends which ends - cases, tasks, functions and modules. - The type and name of the object will be set between the braces. - verilog-minimum-comment-distance (default 40) - Minimum distance between begin and end required before a comment - will be inserted. Setting this variable to zero results in every - end aquiring a comment; the default avoids too many redundanet - comments in tight quarters. - verilog-auto-lineup (default `(all)) - List of contexts where auto lineup of :'s or ='s should be done. - -Turning on Verilog mode calls the value of the variable verilog-mode-hook with -no args, if that value is non-nil. -Other useful functions are: -\\[verilog-complete-word]\t-complete word with appropriate possibilities - (functions, verilog keywords...) -\\[verilog-comment-region]\t- Put marked area in a comment, fixing - nested comments. -\\[verilog-uncomment-region]\t- Uncomment an area commented with \ -\\[verilog-comment-region]. -\\[verilog-insert-block]\t- insert begin ... end; -\\[verilog-star-comment]\t- insert /* ... */ -\\[verilog-mark-defun]\t- Mark function. -\\[verilog-beg-of-defun]\t- Move to beginning of current function. -\\[verilog-end-of-defun]\t- Move to end of current function. -\\[verilog-label-be]\t- Label matching begin ... end, fork ... join - and case ... endcase statements; -" - (interactive) - (kill-all-local-variables) - (use-local-map verilog-mode-map) - (setq major-mode 'verilog-mode) - (setq mode-name "Verilog") - (setq local-abbrev-table verilog-mode-abbrev-table) - (set-syntax-table verilog-mode-syntax-table) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'verilog-indent-line) - (setq comment-indent-function 'verilog-indent-comment) - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments nil) - (make-local-variable 'comment-start) - (make-local-variable 'comment-end) - (make-local-variable 'comment-multi-line) - (make-local-variable 'comment-start-skip) - (setq comment-start "// " - comment-end "" - comment-start-skip "/\\*+ *\\|// *" - comment-multi-line nil) - ;; Setting up things for font-lock - (if (string-match "XEmacs" emacs-version) - (progn - (if (and current-menubar - (not (assoc "Verilog" current-menubar))) - (progn - (set-buffer-menubar (copy-sequence current-menubar)) - (add-submenu nil verilog-xemacs-menu))) )) - ;; Stuff for GNU emacs - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults - '((verilog-font-lock-keywords verilog-font-lock-keywords-1 - verilog-font-lock-keywords-2 - verilog-font-lock-keywords-3 - verilog-font-lock-keywords-4) - nil t)) - ;; Tell imenu how to handle verilog. - (make-local-variable 'imenu-generic-expression) - (setq imenu-generic-expression verilog-imenu-generic-expression) - ;; End GNU emacs stuff - (run-hooks 'verilog-mode-hook)) - - -;;; -;;; Electric functions -;;; -(defun electric-verilog-terminate-line (&optional arg) - "Terminate line and indent next line." - (interactive) - ;; before that see if we are in a comment - (let ((state - (save-excursion - (parse-partial-sexp (point-min) (point))))) - (cond - ((nth 7 state) ; Inside // comment - (if (eolp) - (progn - (delete-horizontal-space) - (newline)) - (progn - (newline) - (insert-string "// ") - (beginning-of-line) - )) - (verilog-indent-line) - ) - ((nth 4 state) ; Inside any comment (hence /**/) - (newline) - (beginning-of-line) - (verilog-indent-comment t) - ) - ((eolp) - ;; First, check if current line should be indented - (if (save-excursion - (delete-horizontal-space) - (beginning-of-line) - (skip-chars-forward " \t") - (if (looking-at verilog-autoindent-lines-re) - (let ((indent-str (verilog-indent-line))) - ;; Maybe we should set some endcomments - (if verilog-auto-endcomments - (verilog-set-auto-endcomments indent-str arg)) - (end-of-line) - (delete-horizontal-space) - (if arg - () - (newline)) - nil) - (progn - (end-of-line) - (delete-horizontal-space) - 't - ))) - (newline) - (forward-line 1) - ) - ;; Indent next line - (if verilog-auto-indent-on-newline - (verilog-indent-line)) - ) - (t - (newline) - ) - ) - ) - ) - -(defun electric-verilog-semi () - "Insert `;' character and reindent the line." - (interactive) - (insert last-command-char) - (if (verilog-in-comment-or-string-p) - () - (save-excursion - (beginning-of-line) - (verilog-indent-line)) - (if (and verilog-auto-newline - (= 0 (verilog-parenthesis-depth))) - (electric-verilog-terminate-line)))) - -(defun electric-verilog-colon () - "Insert `:' and do all indentions except line indent on this line." - (interactive) - (insert last-command-char) - ;; Do nothing if within string. - (if (or - (verilog-within-string) - (not (verilog-in-case-region-p))) - () - (save-excursion - (let ((p (point)) - (lim (progn (verilog-beg-of-statement) (point)))) - (goto-char p) - (verilog-backward-case-item lim) - (verilog-indent-line))) -;; (let ((verilog-tab-always-indent nil)) -;; (verilog-indent-line)) - ) - ) - -(defun electric-verilog-equal () - "Insert `=', and do indention if within block." - (interactive) - (insert last-command-char) -;; Could auto line up expressions, but not yet -;; (if (eq (car (verilog-calculate-indent)) 'block) -;; (let ((verilog-tab-always-indent nil)) -;; (verilog-indent-command))) -) - - -(defun electric-verilog-tick () - "Insert back-tick, and indent to coulmn 0 if this is a CPP directive." - (interactive) - (insert last-command-char) - (if (save-excursion - (beginning-of-line) - (looking-at -"^[ \t]*\`\\(\\<ifdef\\>\\|\\\<else\\>\\|\\<endif\\>\\|\\<define\\>\\)")) - (save-excursion (beginning-of-line) - (delete-horizontal-space)))) - -(defun electric-verilog-tab () - "Function called when TAB is pressed in Verilog mode." - (interactive) - ;; If verilog-tab-always-indent, indent the beginning of the line. - (if verilog-tab-always-indent - (let* ( - (boi-point - (save-excursion - (beginning-of-line) - (skip-chars-forward " \t") - (let (type state ) - (setq type (verilog-indent-line)) - (setq state (car type)) - (cond - ((eq state 'block) - (if (looking-at verilog-behavorial-block-beg-re ) - (error - (concat - "The reserved word \"" - (buffer-substring (match-beginning 0) (match-end 0)) - "\" must be at the behavorial level!")))) - )) - (back-to-indentation) - (point)))) - (if (< (point) boi-point) - (back-to-indentation))) - (progn (insert "\t")) - ) - ) - - - -;;; -;;; Interactive functions -;;; -(defun verilog-insert-block () - "Insert Verilog begin ... end; block in the code with right indentation." - (interactive) - (verilog-indent-line) - (insert "begin") - (electric-verilog-terminate-line) - (save-excursion - (electric-verilog-terminate-line) - (insert "end") - (beginning-of-line) - (verilog-indent-line))) - -(defun verilog-star-comment () - "Insert Verilog star comment at point." - (interactive) - (verilog-indent-line) - (insert "/*") - (save-excursion - (newline) - (insert " */")) - (newline) - (insert " * ")) - -(defun verilog-mark-defun () - "Mark the current verilog function (or procedure). -This puts the mark at the end, and point at the beginning." - (interactive) - (push-mark (point)) - (verilog-end-of-defun) - (push-mark (point)) - (verilog-beg-of-defun) - (if (fboundp 'zmacs-activate-region) - (zmacs-activate-region))) - -(defun verilog-comment-region (start end) - "Put the region into a Verilog comment. -The comments that are in this area are \"deformed\": -`*)' becomes `!(*' and `}' becomes `!{'. -These deformed comments are returned to normal if you use -\\[verilog-uncomment-region] to undo the commenting. - -The commented area starts with `verilog-exclude-str-start', and ends with -`verilog-include-str-end'. But if you change these variables, -\\[verilog-uncomment-region] won't recognize the comments." - (interactive "r") - (save-excursion - ;; Insert start and endcomments - (goto-char end) - (if (and (save-excursion (skip-chars-forward " \t") (eolp)) - (not (save-excursion (skip-chars-backward " \t") (bolp)))) - (forward-line 1) - (beginning-of-line)) - (insert verilog-exclude-str-end) - (setq end (point)) - (newline) - (goto-char start) - (beginning-of-line) - (insert verilog-exclude-str-start) - (newline) - ;; Replace end-comments within commented area - (goto-char end) - (save-excursion - (while (re-search-backward "\\*/" start t) - (replace-match "*-/" t t))) - (save-excursion - (let ((s+1 (1+ start))) - (while (re-search-backward "/\\*" s+1 t) - (replace-match "/-*" t t)))) - ) -) - -(defun verilog-uncomment-region () - "Uncomment a commented area; change deformed comments back to normal. -This command does nothing if the pointer is not in a commented -area. See also `verilog-comment-region'." - (interactive) - (save-excursion - (let ((start (point)) - (end (point))) - ;; Find the boundaries of the comment - (save-excursion - (setq start (progn (search-backward verilog-exclude-str-start nil t) - (point))) - (setq end (progn (search-forward verilog-exclude-str-end nil t) - (point)))) - ;; Check if we're really inside a comment - (if (or (equal start (point)) (<= end (point))) - (message "Not standing within commented area.") - (progn - ;; Remove endcomment - (goto-char end) - (beginning-of-line) - (let ((pos (point))) - (end-of-line) - (delete-region pos (1+ (point)))) - ;; Change comments back to normal - (save-excursion - (while (re-search-backward "\\*-/" start t) - (replace-match "*/" t t))) - (save-excursion - (while (re-search-backward "/-\\*" start t) - (replace-match "/*" t t))) - ;; Remove startcomment - (goto-char start) - (beginning-of-line) - (let ((pos (point))) - (end-of-line) - (delete-region pos (1+ (point))))))))) - -(defun verilog-beg-of-defun () - "Move backward to the beginning of the current function or procedure." - (interactive) - (verilog-re-search-backward verilog-defun-re nil 'move) - ) -(defun verilog-end-of-defun () - (interactive) - (verilog-re-search-forward verilog-end-defun-re nil 'move) - ) - -(defun verilog-label-be (&optional arg) - "Label matching begin ... end, fork ... join and case ... endcase - statements in this module; With argument, first kill any existing - labels." - (interactive) - (let ((cnt 0) - (oldpos (point)) - (b (progn - (verilog-beg-of-defun) - (point-marker))) - (e (progn - (verilog-end-of-defun) - (point-marker))) - ) - (goto-char (marker-position b)) - (if (> (- e b) 200) - (message "Relabeling module...")) - (while (and - (> (marker-position e) (point)) - (verilog-re-search-forward - (concat - "\\<end\\(\\(function\\)\\|\\(task\\)\\|\\(module\\)\\|" - "\\(primitive\\)\\|\\(case\\)\\)?\\>" - "\\|\\(`endif\\)\\|\\(`else\\)") - nil 'move)) - (goto-char (match-beginning 0)) - (let ((indent-str (verilog-indent-line))) - (verilog-set-auto-endcomments indent-str 't) - (end-of-line) - (delete-horizontal-space) - ) - (setq cnt (1+ cnt)) - (if (= 9 (% cnt 10)) - (message "%d..." cnt)) - ) - (goto-char oldpos) - (if (or - (> (- e b) 200) - (> cnt 20)) - (message "%d lines autocommented" cnt)) - ) - ) -(defun verilog-beg-of-statement () - "Move backward to beginning of statement" - (interactive) - (while (save-excursion - (and - (not (looking-at verilog-complete-reg)) - (verilog-backward-syntactic-ws) - (not (or (bolp) (= (preceding-char) ?\;))) - ) - ) - (skip-chars-backward " \t") - (verilog-backward-token)) - (let ((last (point))) - (while (progn - (setq last (point)) - (and (not (looking-at verilog-complete-reg)) - (verilog-continued-line)))) - (goto-char last) - (verilog-forward-syntactic-ws) - ) - ) - -(defun verilog-beg-of-statement-1 () - "Move backward to beginning of statement" - (interactive) - (let ((pt (point))) - - (while (and (not (looking-at verilog-complete-reg)) - (setq pt (point)) - (verilog-backward-token) - (setq pt (point)) - (verilog-backward-syntactic-ws) - (not (bolp)) - (not (= (preceding-char) ?\;))) - ) - (goto-char pt) - (while (progn - (setq pt (point)) - (and (not (looking-at verilog-complete-reg)) - (not (= (preceding-char) ?\;)) - (verilog-continued-line)))) - (goto-char pt) - (verilog-forward-syntactic-ws) - ) - ) -(defun verilog-end-of-statement () - "Move forward to end of current statement." - (interactive) - (let ((nest 0) pos) - (or (looking-at verilog-beg-block-re) - ;; Skip to end of statement - (setq pos (catch 'found - (while t - (forward-sexp 1) - (verilog-skip-forward-comment-or-string) - (cond ((looking-at "[ \t]*;") - (skip-chars-forward "^;") - (forward-char 1) - (throw 'found (point))) - ((save-excursion - (forward-sexp -1) - (looking-at verilog-beg-block-re)) - (goto-char (match-beginning 0)) - (throw 'found nil)) - ((eobp) - (throw 'found (point)))))))) - (if (not pos) - ;; Skip a whole block - (catch 'found - (while t - (verilog-re-search-forward verilog-end-statement-re nil 'move) - (setq nest (if (match-end 1) - (1+ nest) - (1- nest))) - (cond ((eobp) - (throw 'found (point))) - ((= 0 nest) - (throw 'found (verilog-end-of-statement)))))) - pos))) -(defun verilog-in-case-region-p () - "Return TRUE if in a case region: more specifically, point @ in the - line foo : @ begin" - (interactive) - (save-excursion - (if (and - (progn (verilog-forward-syntactic-ws) - (looking-at "\\<begin\\>")) - (progn (verilog-backward-syntactic-ws) - (= (preceding-char) ?\:))) - (catch 'found - (let ((nest 1)) - (while t - (verilog-re-search-backward - (concat "\\(\\<module\\>\\)\\|\\(\\<case[xz]?\\>[^:]\\)\\|" - "\\(\\<endcase\\>\\)\\>") - nil 'move) - (cond - ((match-end 3) - (setq nest (1+ nest))) - ((match-end 2) - (if (= nest 1) - (throw 'found 1)) - (setq nest (1- nest)) - ) - ( t - (throw 'found (= nest 0))) - ) - ) - ) - ) - nil) - ) - ) -(defun verilog-backward-case-item (lim) - "Skip backward to nearest enclosing case item" - (interactive) - (let ( - (str 'nil) - (lim1 - (progn - (save-excursion - (verilog-re-search-backward verilog-endcomment-reason-re - lim 'move) - (point))))) - ;; Try to find the real : - (if (save-excursion (search-backward ":" lim1 t)) - (let ((colon 0) - b e ) - (while - (and - (< colon 1) - (verilog-re-search-backward "\\(\\[\\)\\|\\(\\]\\)\\|\\(:\\)" - lim1 'move)) - (cond - ((match-end 1) ;; [ - (setq colon (1+ colon)) - (if (>= colon 0) - (error "unbalanced ["))) - ((match-end 2) ;; ] - (setq colon (1- colon))) - - ((match-end 3) ;; : - (setq colon (1+ colon))) - - ) - ) - ;; Skip back to begining of case item - (skip-chars-backward "\t ") - (verilog-skip-backward-comment-or-string) - (setq e (point)) - (setq b - (progn - (if - (verilog-re-search-backward - "\\<\\(case[zx]?\\)\\>\\|;\\|\\<end\\>" nil 'move) - (progn - (cond - ((match-end 1) - (goto-char (match-end 1)) - (verilog-forward-ws&directives) - (if (looking-at "(") - (progn - (forward-sexp) - (verilog-forward-ws&directives) - )) - (point)) - (t - (goto-char (match-end 0)) - (verilog-forward-ws&directives) - (point)) - )) - (error "Malformed case item") - ) - ) - ) - (setq str (buffer-substring b e)) - (if - (setq e - (string-match - "[ \t]*\\(\\(\n\\)\\|\\(//\\)\\|\\(/\\*\\)\\)" str)) - (setq str (concat (substring str 0 e) "..."))) - str) - 'nil) - ) - ) - - -;;; -;;; Other functions -;;; - -(defun kill-existing-comment () - "kill autocomment on this line" - (save-excursion - (let* ( - (e (progn - (end-of-line) - (point))) - (b (progn - (beginning-of-line) - (search-forward "//" e t)))) - (if b - (delete-region (- b 2) e)) - ) - ) - ) - -(defun verilog-set-auto-endcomments (indent-str kill-existing-comment) - "Insert `// case: 7 ' or `// NAME ' on this line if appropriate. -Insert `// case expr ' if this line ends a case block. -Insert `// ifdef FOO ' if this line ends code conditional on FOO. -Insert `// NAME ' if this line ends a module or primitive named NAME." - (save-excursion - (cond - (; Comment close preprocessor directives - (and - (looking-at "\\(`endif\\)\\|\\(`else\\)") - (or kill-existing-comment - (not (save-excursion - (end-of-line) - (search-backward "//" (verilog-get-beg-of-line) t))))) - (let ( (reg "\\(`else\\)\\|\\(`ifdef\\)\\|\\(`endif\\)") - (nest 1) - b e - (else (if (match-end 2) - 1 - 0)) - ) - (end-of-line) - (if kill-existing-comment - (kill-existing-comment)) - (delete-horizontal-space) - (save-excursion - (backward-sexp 1) - (while (and (/= nest 0) - (verilog-re-search-backward reg nil 'move)) - (cond - ((match-end 1) ; `else - (if (= nest 1) - (setq else 1))) - ((match-end 2) ; `ifdef - (setq nest (1- nest))) - ((match-end 3) ; `endif - (setq nest (1+ nest))) - )) - (if (match-end 0) - (setq b (progn - (skip-chars-forward "^ \t") - (verilog-forward-syntactic-ws) - (point)) - e (progn - (skip-chars-forward "a-zA-Z0-9_") - (point) - )))) - (if b - (if (> (- (point) b) verilog-minimum-comment-distance) - (insert (concat (if - (= else 0) - " // ifdef " - " // !ifdef ") - (buffer-substring b e)))) - (progn - (insert " // unmatched `endif") - (ding 't)) - ))) - - (; Comment close case/function/task/module and named block - (and (looking-at "\\<end") - (or kill-existing-comment - (not (save-excursion - (end-of-line) - (search-backward "//" (verilog-get-beg-of-line) t))))) - (let ((type (car indent-str))) - (if (eq type 'declaration) - () - (if - (looking-at verilog-enders-re) - (cond - (;- This is a case block; search back for the start of this case - (match-end 1) - - (let ((err 't) - (str "UNMATCHED!!")) - (save-excursion - (verilog-leap-to-head) - (if (match-end 0) - (progn - (goto-char (match-end 1)) - (setq str (concat (buffer-substring (match-beginning 1) (match-end 1)) - (verilog-get-expr))) - (setq err nil)))) - (end-of-line) - (if kill-existing-comment - (kill-existing-comment)) - (delete-horizontal-space) - (insert (concat " // " str )) - (if err (ding 't)) - )) - - (;- This is a begin..end block - (match-end 2) - (let ((str " // UNMATCHED !!") - (err 't) - (here (point)) - there - cntx - ) - (save-excursion - (verilog-leap-to-head) - (setq there (point)) - (if (not (match-end 0)) - (progn - (goto-char here) - (end-of-line) - (if kill-existing-comment - (kill-existing-comment)) - (delete-horizontal-space) - (insert str) - (ding 't) - ) - (let ( sp - (lim (save-excursion (verilog-beg-of-defun) (point))) - (here (point)) - ) - (cond - (;-- handle named block differently - (looking-at verilog-named-block-re) - (search-forward ":") - (setq there (point)) - (setq str (verilog-get-expr)) - (setq err nil) - (setq str (concat " // block: " str ))) - - ((verilog-in-case-region-p) ;-- handle case item differently - (goto-char here) - (setq str (verilog-backward-case-item lim)) - (setq there (point)) - (setq err nil) - (setq str (concat " // case: " str )) - ) - (;- try to find "reason" for this begin - (cond - (; - (eq here (progn - (verilog-backward-token) - (verilog-beg-of-statement) - (point))) - (setq err nil) - (setq str "")) - ((looking-at verilog-endcomment-reason-re) - (setq there (match-end 0)) - (setq cntx (concat - (buffer-substring (match-beginning 0) (match-end 0)) " ")) - (cond - (; - (match-end 2) - (setq err nil) - (save-excursion - (goto-char sp) - (if (and (verilog-continued-line) - (looking-at "\\<repeat\\>\\|\\<wait\\>\\|\\<always\\>")) - (progn - (goto-char (match-end 0)) - (setq there (point)) - (setq str - (concat " // " - (buffer-substring (match-beginning 0) (match-end 0)) " " - (verilog-get-expr)))) - (setq str "") - ) - ) - ) - (;- else - (match-end 4) - (let ((nest 0) - ( reg "\\(\\<begin\\>\\)\\|\\(\\<end\\>\\)\\|\\(\\<if\\>\\)") - ) - (catch 'skip - (while (verilog-re-search-backward reg nil 'move) - (cond - ((match-end 1) ; begin - (setq nest (1- nest))) - ((match-end 2) ; end - (setq nest (1+ nest))) - ((match-end 3) - (if (= 0 nest) - (progn - (goto-char (match-end 0)) - (setq there (point)) - (setq err nil) - (setq str (verilog-get-expr)) - (setq str (concat " // else: !if" str )) - (throw 'skip 1)) - ))) - ) - ) - ) - ) - (;- end else - (match-end 5) - (goto-char there) - (let ((nest 0) - ( reg "\\(\\<begin\\>\\)\\|\\(\\<end\\>\\)\\|\\(\\<if\\>\\)") - ) - (catch 'skip - (while (verilog-re-search-backward reg nil 'move) - (cond - ((match-end 1) ; begin - (setq nest (1- nest))) - ((match-end 2) ; end - (setq nest (1+ nest))) - ((match-end 3) - (if (= 0 nest) - (progn - (goto-char (match-end 0)) - (setq there (point)) - (setq err nil) - (setq str (verilog-get-expr)) - (setq str (concat " // else: !if" str )) - (throw 'skip 1)) - ))) - ) - ) - ) - ) - - (;- task/function/initial et cetera - t - (match-end 0) - (goto-char (match-end 0)) - (setq there (point)) - (setq err nil) - (setq str (verilog-get-expr)) - (setq str (concat " // " cntx str ))) - - (;-- otherwise... - (setq str " // auto-endcomment confused ") - ) - ) - ) - ((and - (verilog-in-case-region-p) ;-- handle case item differently - (progn - (setq there (point)) - (goto-char here) - (setq str (verilog-backward-case-item lim)))) - (setq err nil) - (setq str (concat " // case: " str )) - ) - ) - ) - ) - ) - (goto-char here) - (end-of-line) - (if kill-existing-comment - (kill-existing-comment)) - (delete-horizontal-space) - (if (or err - (> (- here there) verilog-minimum-comment-distance)) - (insert str)) - (if err (ding 't)) - ) - ) - ) - ) - - - (;- this is end{function,task,module} - t - (let (string reg (width nil)) - (end-of-line) - (if kill-existing-comment - (kill-existing-comment)) - (delete-horizontal-space) - (backward-sexp) - (cond - ((match-end 5) - (setq reg "\\(\\<function\\>\\)\\|\\(\\<\\(endfunction\\|task\\|\\(macro\\)?module\\|primitive\\)\\>\\)") - (setq width "\\([ \t]*\\[[^]]*\\]\\)?") - ) - ((match-end 6) - (setq reg "\\(\\<task\\>\\)\\|\\(\\<\\(endtask\\|function\\|\\(macro\\)?module\\|primitive\\)\\>\\)")) - ((match-end 7) - (setq reg "\\(\\<\\(macro\\)?module\\>\\)\\|\\<endmodule\\>")) - ((match-end 8) - (setq reg "\\(\\<primitive\\>\\)\\|\\(\\<\\(endprimitive\\|function\\|task\\|\\(macro\\)?module\\)\\>\\)")) - ) - (let (b e) - (save-excursion - (verilog-re-search-backward reg nil 'move) - (cond - ((match-end 1) - (setq b (progn - (skip-chars-forward "^ \t") - (verilog-forward-ws&directives) - (if (and width (looking-at width)) - (progn - (goto-char (match-end 0)) - (verilog-forward-ws&directives) - )) - (point)) - e (progn - (skip-chars-forward "a-zA-Z0-9_") - (point))) - (setq string (buffer-substring b e))) - (t - (ding 't) - (setq string "unmactched end(function|task|module|primitive)"))))) - (end-of-line) - (insert (concat " // " string ))) - ) - ) - ) - ) - ) - ) - ) - ) - ) - -(defun verilog-get-expr() - "Grab expression at point, e.g, case ( a | b & (c ^d))" - (let* ((b (progn - (verilog-forward-syntactic-ws) - (skip-chars-forward " \t") - (point))) - (e (let ((par 1)) - (cond - ((looking-at "(") - (forward-char 1) - (while (and (/= par 0) - (verilog-re-search-forward "\\((\\)\\|\\()\\)" nil 'move)) - (cond - ((match-end 1) - (setq par (1+ par))) - ((match-end 2) - (setq par (1- par))))) - (point)) - ((looking-at "\\[") - (forward-char 1) - (while (and (/= par 0) - (verilog-re-search-forward "\\(\\[\\)\\|\\(\\]\\)" nil 'move)) - (cond - ((match-end 1) - (setq par (1+ par))) - ((match-end 2) - (setq par (1- par))))) - (verilog-forward-syntactic-ws) - (skip-chars-forward "^ \t\n") - (point)) - ((looking-at "/[/\\*]") - b) - ('t - (skip-chars-forward "^: \t\n") - (point) - )))) - (str (buffer-substring b e))) - (if (setq e (string-match "[ \t]*\\(\\(\n\\)\\|\\(//\\)\\|\\(/\\*\\)\\)" str)) - (setq str (concat (substring str 0 e) "..."))) - str) - ) - - -;;; -;;; Indentation -;;; -(defconst verilog-indent-alist - '((block . (+ ind verilog-indent-level)) - (case . (+ ind verilog-case-indent)) - (cparenexp . (+ ind verilog-indent-level)) - (cexp . (+ ind verilog-indent-level)) - (defun . verilog-indent-level-module) - (declaration . verilog-indent-level-declaration) - (tf . verilog-indent-level) - (behavorial . (+ verilog-indent-level-behavorial verilog-indent-level-module)) - (statement . ind) - (cpp . 0) - (comment . (verilog-indent-comment)) - (unknown . 3) - (string . 0))) - -(defun verilog-calculate-indent () - "Calculate the indent of the current Verilog line, through examination -of previous lines. Once a line is found that is definitive as to the -type of the current line, return that lines' indent level and it's -type. Return a list of two elements: (INDENT-TYPE INDENT-LEVEL)." - (save-excursion - (let* ((starting_position (point)) - (par 0) - (begin (looking-at "[ \t]*begin\\>")) - (type (catch 'nesting - ;; Keep working backwards until we can figure out - ;; what type of statement this is. - ;; Basically we need to figure out - ;; 1) if this is a continuation of the previous line; - ;; 2) are we in a block scope (begin..end) - - ;; if we are in a comment, done. - (if (verilog-in-star-comment-p) (throw 'nesting 'comment)) - - ;; if we are in a parenthesized list, done. - (if (verilog-in-paren) (progn (setq par 1) (throw 'nesting 'block))) - - ;; See if we are continuing a previous line - (while t - ;; trap out if we crawl off the top of the buffer - (if (bobp) (throw 'nesting 'cpp)) - - (if (verilog-continued-line-1) - (let ((sp (point))) - (if (and - (not (looking-at verilog-complete-reg)) - (verilog-continued-line-1)) - (progn (goto-char sp) - (throw 'nesting 'cexp)) - (goto-char sp)) - - (if (and begin - (not verilog-indent-begin-after-if) - (looking-at verilog-no-indent-begin-re)) - (throw 'nesting 'statement) - (progn - (throw 'nesting 'cexp) - ) - )) - - ;; not a continued line - (goto-char starting_position)) - - (if (looking-at "\\<else\\>") - ;; search back for governing if, striding across begin..end pairs - ;; appropriately - (let ((elsec 1)) - (while (verilog-re-search-backward verilog-ends-re nil 'move) - (cond - ((match-end 1) ; else, we're in deep - (setq elsec (1+ elsec)) - ) - ((match-end 2) ; found it - (setq elsec (1- elsec)) - (if (= 0 elsec) - ;; Now previous line describes syntax - (throw 'nesting 'statement) - )) - (t ; endblock - ; try to leap back to matching outward block by striding across - ; indent level changing tokens then immediately - ; previous line governs indentation. - (let ((reg)(nest 1)) -;; (looking-at verilog-end-block-re-1);; end|join|endcase|endtable|endspecify - (cond - ((match-end 3) ; end - ;; Search back for matching begin - (setq reg "\\(\\<begin\\>\\)\\|\\(\\<end\\>\\)" ) - ) - ((match-end 4) ; endcase - ;; Search back for matching case - (setq reg "\\(\\<case[xz]?\\>[^:]\\)\\|\\(\\<endcase\\>\\)" ) - ) - ((match-end 5) ; join - ;; Search back for matching fork - (setq reg "\\(\\<fork\\>\\)\\|\\(\\<join\\>\\)" ) - ) - ((match-end 6) ; endtable - ;; Search back for matching table - (setq reg "\\(\\<table\\>\\)\\|\\(\\<endtable\\>\\)" ) - ) - ((match-end 7) ; endspecify - ;; Search back for matching specify - (setq reg "\\(\\<specify\\>\\)\\|\\(\\<endspecify\\>\\)" ) - ) - ((match-end 8) ; endfunction - ;; Search back for matching function - (setq reg "\\(\\<function\\>\\)\\|\\(\\<endfunction\\>\\)" ) - ) - ((match-end 9) ; endtask - ;; Search back for matching task - (setq reg "\\(\\<task\\>\\)\\|\\(\\<endtask\\>\\)" ) - ) - ) - (catch 'skip - (while (verilog-re-search-backward reg nil 'move) - (cond - ((match-end 1) ; begin - (setq nest (1- nest)) - (if (= 0 nest) - (throw 'skip 1))) - ((match-end 2) ; end - (setq nest (1+ nest))))) - ) - ) - ) - ) - ) - ) - ) - (throw 'nesting (verilog-calc-1)) - ) - ) - ) - ) - ;; Return type of block and indent level. - (if (not type) - (setq type 'cpp)) - (if (> par 0) ; Unclosed Parenthesis - (list 'cparenexp par) - (cond - ((eq type 'case) - (list type (verilog-case-indent-level))) - ((eq type 'statement) - (list type (current-column))) - ((eq type 'defun) - (list type 0)) - (t - (list type (verilog-indent-level))))) - ) - ) - ) -(defun verilog-calc-1 () - "" - (catch 'nesting - (while (verilog-re-search-backward verilog-indent-re nil 'move) - (cond - ((looking-at verilog-beg-block-re-1) - (cond - ((match-end 2) (throw 'nesting 'case)) - (t (throw 'nesting 'block)))) - - ((looking-at verilog-end-block-re) - (verilog-leap-to-head) - (if (verilog-in-case-region-p) - (progn - (verilog-leap-to-case-head) - (if (looking-at verilog-case-re) - (throw 'nesting 'case)) - ))) - - ((looking-at verilog-defun-level-re) - (throw 'nesting 'defun)) - - ((looking-at verilog-cpp-level-re) - (throw 'nesting 'cpp)) - - ((looking-at verilog-behavorial-level-re) - (throw 'nesting 'behavorial)) - - ((bobp) - (throw 'nesting 'cpp)) - ) - ) - ) - ) - -(defun verilog-leap-to-case-head () "" - (let ((nest 1)) - (while (/= 0 nest) - (verilog-re-search-backward "\\(\\<case[xz]?\\>[^:]\\)\\|\\(\\<endcase\\>\\)" nil 'move) - (cond - ((match-end 1) - (setq nest (1- nest))) - ((match-end 2) - (setq nest (1+ nest))) - ((bobp) - (ding 't) - (setq nest 0)) - ) - ) - ) - ) - -(defun verilog-leap-to-head () - "Move point to the head of this block; jump from end to matching begin, - from endcase to matching case, and so on." - (let (reg - snest - (nest 1)) - (cond - ((looking-at "\\<end\\>") - ;; Search back for matching begin - (setq reg (concat "\\(\\<begin\\>\\)\\|\\(\\<end\\>\\)\\|" - "\\(\\<endcase\\>\\)\\|\\(\\<join\\>\\)" ))) - - ((looking-at "\\<endcase\\>") - ;; Search back for matching case - (setq reg "\\(\\<case[xz]?\\>\\)\\|\\(\\<endcase\\>\\)" ) - ) - ((looking-at "\\<join\\>") - ;; Search back for matching fork - (setq reg "\\(\\<fork\\>\\)\\|\\(\\<join\\>\\)" ) - ) - ((looking-at "\\<endtable\\>") - ;; Search back for matching table - (setq reg "\\(\\<table\\>\\)\\|\\(\\<endtable\\>\\)" ) - ) - ((looking-at "\\<endspecify\\>") - ;; Search back for matching specify - (setq reg "\\(\\<specify\\>\\)\\|\\(\\<endspecify\\>\\)" ) - ) - ((looking-at "\\<endfunction\\>") - ;; Search back for matching function - (setq reg "\\(\\<function\\>\\)\\|\\(\\<endfunction\\>\\)" ) - ) - ((looking-at "\\<endtask\\>") - ;; Search back for matching task - (setq reg "\\(\\<task\\>\\)\\|\\(\\<endtask\\>\\)" ) - ) - ) - (catch 'skip - (let (sreg) - (while (verilog-re-search-backward reg nil 'move) - (cond - ((match-end 1) ; begin - (setq nest (1- nest)) - (if (= 0 nest) - ;; Now previous line describes syntax - (throw 'skip 1)) - (if (and snest - (= snest nest)) - (setq reg sreg)) - ) - ((match-end 2) ; end - (setq nest (1+ nest)) - ) - ((match-end 3) - ;; endcase, jump to case - (setq snest nest) - (setq nest (1+ nest)) - (setq sreg reg) - (setq reg "\\(\\<case[xz]?\\>[^:]\\)\\|\\(\\<endcase\\>\\)" ) - ) - ((match-end 4) - ;; join, jump to fork - (setq snest nest) - (setq nest (1+ nest)) - (setq sreg reg) - (setq reg "\\(\\<fork\\>\\)\\|\\(\\<join\\>\\)" ) - ) - ) - ) - ) - ) - ) - ) - -(defun verilog-continued-line-1 () - "Return true if this is a continued line. - Set point to where line starts" - (let ((continued 't)) - (if (eq 0 (forward-line -1)) - (progn - (end-of-line) - (verilog-backward-ws&directives) - (if (bobp) - (setq continued nil) - (setq continued (verilog-backward-token)) - ) - ) - (setq continued nil) - ) - continued) - ) - -(defun verilog-continued-line () - "Return true if this is a continued line. - Set point to where line starts" - (let ((continued 't)) - (if (eq 0 (forward-line -1)) - (progn - (end-of-line) - (verilog-backward-ws&directives) - (if (bobp) - (setq continued nil) - (while (and continued - (save-excursion - (skip-chars-backward " \t") - (not (bolp)))) - (setq continued (verilog-backward-token)) - ) ;; while - ) - ) - (setq continued nil) - ) - continued) - ) - -(defun verilog-backward-token () - "step backward token, returning true if we are now at an end of line token" - (verilog-backward-syntactic-ws) - (cond - ((bolp) - nil) - (;-- Anything ending in a ; is complete - (= (preceding-char) ?\;) - nil) - (;-- Could be 'case (foo)' or 'always @(bar)' which is complete - (= (preceding-char) ?\)) - (progn - (backward-char) - (backward-up-list 1) - (verilog-backward-syntactic-ws) - (forward-word -1) - (not (looking-at "\\<case[xz]?\\>[^:]")))) - (;-- any of begin|initial|while are complete statements; 'begin : foo' is also complete - t - (forward-word -1) - (cond - ( - (looking-at "\\(else\\)\\|\\(initial\\>\\)\\|\\(always\\>\\)") - t) - ( - (looking-at verilog-indent-reg) - nil) - (t - (let - ((back (point))) - (verilog-backward-syntactic-ws) - (cond - ((= (preceding-char) ?\:) - (backward-char) - (verilog-backward-syntactic-ws) - (backward-sexp) - (if (looking-at "begin") - nil - t) - ) - ((= (preceding-char) ?\#) - (backward-char) - t) - ((= (preceding-char) ?\`) - (backward-char) - t) - - (t - (goto-char back) - t) - ) - ) - ) - ) - ) - ) -) - -(defun verilog-backward-syntactic-ws (&optional lim) - ;; Backward skip over syntactic whitespace for Emacs 19. - (save-restriction - (let* ((lim (or lim (point-min))) - (here lim) - bol - ) - (if (< lim (point)) - (progn - (narrow-to-region lim (point)) - (while (/= here (point)) - (setq here (point)) - (forward-comment (-(buffer-size))) - (save-excursion - (setq bol (progn (beginning-of-line) (point)))) - (search-backward "//" bol t) - ))) - )) - t) - -(defun verilog-forward-syntactic-ws (&optional lim) - ;; forward skip over syntactic whitespace for Emacs 19. - (save-restriction - (let* ((lim (or lim (point-max))) - (here lim) - ) - (if (> lim (point)) - (progn - (narrow-to-region (point) lim) - (while (/= here (point)) - (setq here (point)) - (forward-comment (buffer-size)) - ))) - ))) - -(defun verilog-backward-ws&directives (&optional lim) - ;; Backward skip over syntactic whitespace and compiler directives for Emacs 19. - (save-restriction - (let* ((lim (or lim (point-min))) - (here lim) - jump - ) - (if (< lim (point)) - (progn - (let ((state - (save-excursion - (parse-partial-sexp (point-min) (point))))) - (cond - ((nth 4 state) ;; in /* */ comment - (verilog-re-search-backward "/\*" nil 'move) - ) - ((nth 7 state) ;; in // comment - (verilog-re-search-backward "//" nil 'move) - ))) - (narrow-to-region lim (point)) - (while (/= here (point)) - (setq here (point)) - (forward-comment (-(buffer-size))) - (save-excursion - (beginning-of-line) - (if (looking-at "[ \t]*\\(`define\\)\\|\\(`ifdef\\)\\|\\(`else\\)\\|\\(`endif\\)\\|\\(`timescale\\)\\|\\(`include\\)") - (setq jump t) - (setq jump nil))) - (if jump - (beginning-of-line)) - ))) - ))) - -(defun verilog-forward-ws&directives (&optional lim) - ;; forward skip over syntactic whitespace and compiler directives for Emacs 19. - (save-restriction - (let* ((lim (or lim (point-max))) - (here lim) - jump - ) - (if (> lim (point)) - (progn - (let ((state - (save-excursion - (parse-partial-sexp (point-min) (point))))) - (cond - ((nth 4 state) ;; in /* */ comment - (verilog-re-search-forward "/\*" nil 'move) - ) - ((nth 7 state) ;; in // comment - (verilog-re-search-forward "//" nil 'move) - ))) - (narrow-to-region (point) lim) - (while (/= here (point)) - (setq here (point)) - (forward-comment (buffer-size)) - (save-excursion - (beginning-of-line) - (if (looking-at "[ \t]*\\(`define\\)\\|\\(`ifdef\\)\\|\\(`else\\)\\|\\(`endif\\)\\|\\(`timescale\\)") - (setq jump t))) - (if jump - (beginning-of-line 2)) - ))) - ))) -(defun verilog-parenthesis-depth () - "Return non zero if in parenthetical-expression" - (save-excursion - (car (parse-partial-sexp (point-min) (point))))) - -(defun verilog-in-comment-or-string-p () - "Return true if in a string or comment" - (let ((state - (save-excursion - (parse-partial-sexp (point-min) (point))))) - (or (nth 3 state) (nth 4 state) (nth 7 state))) ; Inside string or comment - ) - -(defun verilog-in-star-comment-p () - "Return true if in a star comment" - (let ((state - (save-excursion - (parse-partial-sexp (point-min) (point))))) - (nth 4 state)) - ) - -(defun verilog-in-paren () - "Return true if in a parenthetical expression" - (let ((state - (save-excursion - (parse-partial-sexp (point-min) (point))))) - (/= 0 (nth 0 state))) - ) - -(defun verilog-skip-forward-comment-or-string () - "Return true if in a string or comment" - (let ((state - (save-excursion - (parse-partial-sexp (point-min) (point))))) - (cond - ((nth 3 state) ;Inside string - (goto-char (nth 3 state)) - t) - ((nth 7 state) ;Inside // comment - (forward-line 1) - t) - ((nth 4 state) ;Inside any comment (hence /**/) - (search-forward "*/")) - (t - nil) - ) - ) - ) - -(defun verilog-skip-backward-comment-or-string () - "Return true if in a string or comment" - (let ((state - (save-excursion - (parse-partial-sexp (point-min) (point))))) - (cond - ((nth 3 state) ;Inside string - (search-backward "\"") - t) - ((nth 7 state) ;Inside // comment - (search-backward "//") - t) - ((nth 4 state) ;Inside /* */ comment - (search-backward "/*") - t) - (t - nil) - ) - ) - ) - -(defun verilog-skip-forward-comment-p () - "If in comment, move to end and return true" - (let (state) - (progn - (setq state - (save-excursion - (parse-partial-sexp (point-min) (point)))) - (cond - ((nth 3 state) - t) - ((nth 7 state) ;Inside // comment - (end-of-line) - (forward-char 1) - t) - ((nth 4 state) ;Inside any comment - t) - (t - nil) - ) - ) - ) - ) - -(defun verilog-indent-line-relative () - "Cheap version of indent line that only looks at - a few lines to determine indent level" - (interactive) - (let ((indent-str)) - (save-excursion - (beginning-of-line) - (if (looking-at "^[ \t]*$") - (cond ;- A blank line; No need to be too smart. - ((bobp) - (setq indent-str (list 'cpp 0))) - ((verilog-continued-line) - (let ((sp (point))) - (if (verilog-continued-line) - (progn (goto-char sp) - (setq indent-str (list 'statement (verilog-indent-level)))) - (goto-char sp) - (setq indent-str (list 'block (verilog-indent-level)))))) - (t - (setq indent-str (verilog-calculate-indent)))) - (setq indent-str (verilog-calculate-indent)) - ) - ) - (verilog-do-indent indent-str) - ) - ) -(defun verilog-indent-line () - "Indent for special part of code." - (if (looking-at verilog-directive-re) - ;; We could nicely nest `ifdef's, but... - (progn - (delete-horizontal-space) - (indent-to 0) - (list 'cpp 0)) ; Return verilog-calculate-indent data - (verilog-do-indent (verilog-calculate-indent))) - ) - -(defun verilog-do-indent (indent-str) - "" - (let ((type (car indent-str)) - (ind (car (cdr indent-str)))) - (delete-horizontal-space) - (cond - (; handle continued exp - (eq type 'cexp) - (let ((here (point))) - (verilog-backward-syntactic-ws) - (cond - ((= (preceding-char) ?\,) - (let* ( fst - (column - (save-excursion - (backward-char 1) - (verilog-beg-of-statement) - (setq fst (point)) - (if (looking-at verilog-declaration-re) - (progn ;; we have multiple words - (goto-char (match-end 0)) - (skip-chars-forward " \t") - (if (= (following-char) ?\[) - (progn - (forward-char 1) - (backward-up-list -1) - (skip-chars-forward " \t") - ) - ) - ) - (;; we have a single word - goto-char fst) - ) - (current-column) - ) - ) - ) - (goto-char here) - (beginning-of-line) - (delete-horizontal-space) - (indent-to column)) - ) - ((= (preceding-char) ?\) ) - (goto-char here) - (indent-to (eval (cdr (assoc type verilog-indent-alist)))) - ) - (t - (goto-char here) - (let ((val)) - (verilog-beg-of-statement) - (if (verilog-re-search-forward "=[ \\t]*" here 'move) - (setq val (current-column)) - (setq val (eval (cdr (assoc type verilog-indent-alist))))) - (goto-char here) - (indent-to val) - ) - ) - ) - ) - ) - (; handle inside parenthetical expressions - (eq type 'cparenexp) - (let ((column (save-excursion - (backward-up-list 1) - (forward-char 1) - (skip-chars-forward " \t") - (current-column)))) - (beginning-of-line) - (delete-horizontal-space) - (indent-to column))) - - (;-- Handle the ends - (looking-at verilog-end-block-re ) - (if (eq type 'statement) - (indent-to (- ind verilog-indent-level)) - (indent-to ind))) - (;-- Case -- maybe line 'em up - (and (eq type 'case) (not (looking-at "^[ \t]*$"))) - (progn - (cond - ((looking-at "\\<endcase\\>") - (indent-to ind)) - (t - (indent-to (eval (cdr (assoc type verilog-indent-alist)))) - )))) - - - (;-- defun - (and (eq type 'defun) - (looking-at verilog-zero-indent-re)) - (indent-to 0)) - - (;-- declaration - (and (or - (eq type 'defun) - (eq type 'block)) - (looking-at verilog-declaration-re)) - (verilog-indent-declaration ind)) - - (;-- Everything else - t - (let ((val (eval (cdr (assoc type verilog-indent-alist))))) - (indent-to val) - )) - ) - (if (looking-at "[ \t]+$") - (skip-chars-forward " \t")) - indent-str ; Return indent data - ) -) - -(defun verilog-indent-level () - "Return the indent-level the current statement has." - (save-excursion - (beginning-of-line) - (skip-chars-forward " \t") - (current-column))) - - -(defun verilog-case-indent-level () - "Return the indent-level the current statement has. -Do not count named blocks or case-statements." - (save-excursion - (skip-chars-forward " \t") - (cond - ((looking-at verilog-named-block-re) - (current-column)) - ((and (not (looking-at verilog-case-re)) - (looking-at "^[^:;]+[ \t]*:")) - (search-forward ":" nil t) - (skip-chars-forward " \t") - (current-column)) - (t - (current-column))))) - -(defun verilog-indent-comment (&optional arg) - "Indent current line as comment. -If optional arg is non-nil, just return the -column number the line should be indented to." - (let* ((stcol - (cond - ((verilog-in-star-comment-p) - (save-excursion - (re-search-backward "/\\*" nil t) - (1+(current-column)))) - ( comment-column - comment-column ) - (t - (save-excursion - (re-search-backward "//" nil t) - (current-column))) - ) - )) - (if arg - (progn - (delete-horizontal-space) - (indent-to stcol)) - stcol - ) - ) - ) - -;;; - -(defun verilog-pretty-declarations () - "Line up declarations arround point" - (interactive) - (save-excursion - (if (progn - (verilog-beg-of-statement-1) - (looking-at verilog-declaration-re)) - (let* ((m1 (make-marker)) - (e) (r) - (here (point)) - (start - (progn - (verilog-beg-of-statement-1) - (while (looking-at verilog-declaration-re) - (beginning-of-line) - (setq e (point)) - (verilog-backward-syntactic-ws) - (backward-char) - (verilog-beg-of-statement-1)) - e)) - (end - (progn - (goto-char here) - (verilog-end-of-statement) - (setq e (point)) ;Might be on last line - (verilog-forward-syntactic-ws) - (while (looking-at verilog-declaration-re) - (beginning-of-line) - (verilog-end-of-statement) - (setq e (point)) - (verilog-forward-syntactic-ws) - ) - e)) - (edpos (set-marker (make-marker) end)) - (ind) - (base-ind - (progn - (goto-char start) - (verilog-do-indent (verilog-calculate-indent)) - (verilog-forward-ws&directives) - (current-column) - )) - ) - (goto-char end) - (goto-char start) - (if (> (- end start) 100) - (message "Lining up declarations..(please stand by)")) - ;; Get the begining of line indent first - (while (progn (setq e (marker-position edpos)) - (< (point) e)) - (delete-horizontal-space) - (indent-to base-ind) - (forward-line)) - ;; Now find biggest prefix - (setq ind (verilog-get-lineup-indent start edpos)) - ;; Now indent each line. - (goto-char start) - (while (progn (setq e (marker-position edpos)) - (setq r (- e (point))) - (> r 0)) - (setq e (point)) - (message "%d" r) - (cond - ((looking-at verilog-declaration-re-1) - (let ((p (match-end 0))) - (set-marker m1 p) - (if (verilog-re-search-forward "\\[" p 'move) - (progn - (forward-char -1) - (just-one-space) - (goto-char (marker-position m1)) - (just-one-space) - (indent-to ind) - ) - (progn - (just-one-space) - (indent-to ind)) - ) - )) - ((verilog-continued-line-1) - (goto-char e) - (delete-horizontal-space) - (indent-to ind)) - (t ; Must be comment or white space - (goto-char e) - (verilog-forward-ws&directives) - (forward-line -1) - ) - ) - (forward-line 1) - ) - (message "") - ) - ) - ) - ) -(defun verilog-indent-declaration (baseind) - "Indent current lines as declaration, lining up the variable names - based on previous declaration's indentation." - (interactive) - (let ((pos (point-marker)) - (lim (save-excursion - (verilog-re-search-backward "\\(\\<begin\\>\\)\\|\\(\\<module\\>\\)" nil 'move) - (point))) - (ind) - (m1 (make-marker)) - ) - ;; Use previous declaration (in this module) as template. - (if (verilog-re-search-backward verilog-declaration-re-1 lim t) - (progn - (goto-char (match-end 0)) - (setq ind (current-column)) - (goto-char pos) - (beginning-of-line) - (indent-to (+ baseind (eval (cdr (assoc 'declaration verilog-indent-alist))))) - (if (looking-at verilog-declaration-re-2) - (let ((p (match-end 0))) - (set-marker m1 p) - (if (verilog-re-search-forward "\\[" p 'move) - (progn - (forward-char -1) - (just-one-space) - (goto-char (marker-position m1)) - (just-one-space) - (indent-to ind) - ) - (progn - (just-one-space) - (indent-to ind) - ) - ) - ) - ) - ) - (indent-to (+ baseind (eval (cdr (assoc 'declaration verilog-indent-alist))))) - ) - (goto-char pos) - ) - ) - -; "Return the indent level that will line up several lines within the region -;from b to e nicely. The lineup string is str." -(defun verilog-get-lineup-indent (b edpos) - (save-excursion - (let ((ind 0) e) - (goto-char b) - ;; Get rightmost position - (while (progn (setq e (marker-position edpos)) - (< (point) e)) - (if (verilog-re-search-forward verilog-declaration-re-1 e 'move) - (progn - (goto-char (match-end 0)) - (verilog-backward-syntactic-ws) - (if (> (current-column) ind) - (setq ind (current-column))) - (goto-char (match-end 0))))) - (if (> ind 0) - (1+ ind) - ;; No lineup-string found - (goto-char b) - (end-of-line) - (skip-chars-backward " \t") - (1+ (current-column)))))) - -;; A useful mode debugging aide -(defun verilog-comment-depth (type val) - "" - (save-excursion - (let - ((b (prog2 - (beginning-of-line) - (point-marker) - (end-of-line))) - (e (point-marker))) - (if (re-search-backward " /\\* \[#-\]# \[a-z\]+ \[0-9\]+ ## \\*/" b t) - (progn - (replace-match " /* -# ## */") - (end-of-line)) - (progn - (end-of-line) - (insert " /* ## ## */")))) - (backward-char 6) - (insert - (format "%s %d" type val)) - ) - ) -;;; -;;; -;;; Completion -;;; -(defvar verilog-str nil) -(defvar verilog-all nil) -(defvar verilog-pred nil) -(defvar verilog-buffer-to-use nil) -(defvar verilog-flag nil) -(defvar verilog-toggle-completions nil - "*Non-nil means \\<verilog-mode-map>\\[verilog-complete-word] should try all possible completions one by one. -Repeated use of \\[verilog-complete-word] will show you all of them. -Normally, when there is more than one possible completion, -it displays a list of all possible completions.") - - -(defvar verilog-type-keywords - '("buf" "bufif0" "bufif1" "cmos" "defparam" "inout" "input" - "integer" "nand" "nmos" "nor" "not" "notif0" "notif1" "or" "output" "parameter" - "pmos" "pull0" "pull1" "pullup" "rcmos" "real" "realtime" "reg" "rnmos" "rpmos" "rtran" - "rtranif0" "rtranif1" "time" "tran" "tranif0" "tranif1" "tri" "tri0" "tri1" - "triand" "trior" "trireg" "wand" "wire" "wor" "xnor" "xor" ) - "*Keywords for types used when completing a word in a declaration or parmlist. -\(eg. integer, real, char.) The types defined within the Verilog program -will be completed runtime, and should not be added to this list.") - -(defvar verilog-defun-keywords - '("begin" "function" "task" "initial" "always" "assign" "posedge" "negedge" "endmodule") - "*Keywords to complete when standing at first word of a line in declarative scope. -\(eg. initial, always, begin, assign.) -The procedures and variables defined within the Verilog program -will be completed runtime and should not be added to this list.") - -(defvar verilog-block-keywords - '("begin" "fork" "join" "case" "end" "if" "else" "for" "while" "repeat") - "*Keywords to complete when standing at first word of a line in behavorial scope. -\(eg. begin, if, then, else, for, fork.) -The procedures and variables defined within the Verilog program -will be completed runtime and should not be added to this list.") - -(defvar verilog-tf-keywords - '("begin" "fork" "join" "case" "end" "endtask" "endfunction" "if" "else" "for" "while" "repeat") - "*Keywords to complete when standing at first word of a line in a task or function scope. -\(eg. begin, if, then, else, for, fork.) -The procedures and variables defined within the Verilog program -will be completed runtime and should not be added to this list.") - -(defvar verilog-case-keywords - '("begin" "fork" "join" "case" "end" "endcase" "if" "else" "for" "repeat") - "*Keywords to complete when standing at first word of a line in behavorial scope. -\(eg. begin, if, then, else, for, fork.) -The procedures and variables defined within the Verilog program -will be completed runtime and should not be added to this list.") - -(defvar verilog-separator-keywords - '("else" "then" "begin") - "*Keywords to complete when NOT standing at the first word of a statement. -\(eg. else, then.) -Variables and function names defined within the -Verilog program are completed runtime and should not be added to this list.") - -(defun verilog-string-diff (str1 str2) - "Return index of first letter where STR1 and STR2 differs." - (catch 'done - (let ((diff 0)) - (while t - (if (or (> (1+ diff) (length str1)) - (> (1+ diff) (length str2))) - (throw 'done diff)) - (or (equal (aref str1 diff) (aref str2 diff)) - (throw 'done diff)) - (setq diff (1+ diff)))))) - -;; Calculate all possible completions for functions if argument is `function', -;; completions for procedures if argument is `procedure' or both functions and -;; procedures otherwise. - -(defun verilog-func-completion (type) - ;; Build regular expression for module/task/function names - (if (string= verilog-str "") - (setq verilog-str "[a-zA-Z_]")) - (let ((verilog-str (concat (cond - ((eq type 'module) "\\<\\(module\\)\\s +") - ((eq type 'tf) "\\<\\(task\\|function\\)\\s +") - (t "\\<\\(task\\|function\\|module\\)\\s +")) - "\\<\\(" verilog-str "[a-zA-Z0-9_.]*\\)\\>")) - match) - - (if (not (looking-at verilog-defun-re)) - (verilog-re-search-backward verilog-defun-re nil t)) - (forward-char 1) - - ;; Search through all reachable functions - (goto-char (point-min)) - (while (verilog-re-search-forward verilog-str (point-max) t) - (progn (setq match (buffer-substring (match-beginning 2) - (match-end 2))) - (if (or (null verilog-pred) - (funcall verilog-pred match)) - (setq verilog-all (cons match verilog-all))))) - (if (match-beginning 0) - (goto-char (match-beginning 0))))) - -(defun verilog-get-completion-decl () - ;; Macro for searching through current declaration (var, type or const) - ;; for matches of `str' and adding the occurence tp `all' - (let ((end (save-excursion (verilog-declaration-end) - (point))) - match) - ;; Traverse lines - (while (< (point) end) - (if (verilog-re-search-forward verilog-declaration-re-1 (verilog-get-end-of-line) t) - ;; Traverse current line - (while (and (verilog-re-search-forward - (concat "\\((\\|\\<\\(var\\|type\\|const\\)\\>\\)\\|" - verilog-symbol-re) - (verilog-get-beg-of-line) t) - (not (match-end 1))) - (setq match (buffer-substring (match-beginning 0) (match-end 0))) - (if (string-match (concat "\\<" verilog-str) match) - (if (or (null verilog-pred) - (funcall verilog-pred match)) - (setq verilog-all (cons match verilog-all)))))) - (if (verilog-re-search-forward "\\<record\\>" (verilog-get-end-of-line) t) - (verilog-declaration-end) - (forward-line 1))))) - -(defun verilog-type-completion () - "Calculate all possible completions for types." - (let ((start (point)) - goon) - ;; Search for all reachable type declarations - (while (or (verilog-beg-of-defun) - (setq goon (not goon))) - (save-excursion - (if (and (< start (prog1 (save-excursion (verilog-end-of-defun) - (point)) - (forward-char 1))) - (verilog-re-search-forward - "\\<type\\>\\|\\<\\(begin\\|function\\|procedure\\)\\>" - start t) - (not (match-end 1))) - ;; Check current type declaration - (verilog-get-completion-decl)))))) - -(defun verilog-var-completion () - "Calculate all possible completions for variables (or constants)." - nil) -; Not done yet; in 1.99 perhaps -; (let ((start (point)) -; goon twice) -; ;; Search for all reachable var declarations -; (while (or (verilog-beg-of-defun) -; (setq goon (not goon))) -; (save-excursion -; (if (> start (prog1 (save-excursion (verilog-end-of-defun) -; (point)))) -; () ; Declarations not reacable -; (cond ((and (verilog-re-search-forward verilog-declaration-re start t) -; ;; Check var/const declarations -; (verilog-get-completion-decl))))))))) - - -(defun verilog-keyword-completion (keyword-list) - "Give list of all possible completions of keywords in KEYWORD-LIST." - (mapcar '(lambda (s) - (if (string-match (concat "\\<" verilog-str) s) - (if (or (null verilog-pred) - (funcall verilog-pred s)) - (setq verilog-all (cons s verilog-all))))) - keyword-list)) - -;; Function passed to completing-read, try-completion or -;; all-completions to get completion on STR. If predicate is non-nil, -;; it must be a function to be called for every match to check if this -;; should really be a match. If flag is t, the function returns a list -;; of all possible completions. If it is nil it returns a string, the -;; longest possible completion, or t if STR is an exact match. If flag -;; is 'lambda, the function returns t if STR is an exact match, nil -;; otherwise. - -(defun verilog-completion (verilog-str verilog-pred verilog-flag) - (save-excursion - (let ((verilog-all nil)) - ;; Set buffer to use for searching labels. This should be set - ;; within functions which use verilog-completions - (set-buffer verilog-buffer-to-use) - - ;; Determine what should be completed - (let ((state (car (verilog-calculate-indent)))) - (cond ((eq state 'defun) - (save-excursion (verilog-var-completion)) - (verilog-func-completion 'module) - (verilog-keyword-completion verilog-defun-keywords)) - - ((eq state 'block) - (save-excursion (verilog-var-completion)) - (verilog-func-completion 'tf) - (verilog-keyword-completion verilog-block-keywords)) - - ((eq state 'case) - (save-excursion (verilog-var-completion)) - (verilog-func-completion 'tf) - (verilog-keyword-completion verilog-case-keywords)) - - ((eq state 'tf) - (save-excursion (verilog-var-completion)) - (verilog-func-completion 'tf) - (verilog-keyword-completion verilog-tf-keywords)) - - (t;--Anywhere else - (save-excursion (verilog-var-completion)) - (verilog-func-completion 'both) - (verilog-keyword-completion verilog-separator-keywords)))) - - ;; Now we have built a list of all matches. Give response to caller - (verilog-completion-response)))) - -(defun verilog-completion-response () - (cond ((or (equal verilog-flag 'lambda) (null verilog-flag)) - ;; This was not called by all-completions - (if (null verilog-all) - ;; Return nil if there was no matching label - nil - ;; Get longest string common in the labels - (let* ((elm (cdr verilog-all)) - (match (car verilog-all)) - (min (length match)) - tmp) - (if (string= match verilog-str) - ;; Return t if first match was an exact match - (setq match t) - (while (not (null elm)) - ;; Find longest common string - (if (< (setq tmp (verilog-string-diff match (car elm))) min) - (progn - (setq min tmp) - (setq match (substring match 0 min)))) - ;; Terminate with match=t if this is an exact match - (if (string= (car elm) verilog-str) - (progn - (setq match t) - (setq elm nil)) - (setq elm (cdr elm))))) - ;; If this is a test just for exact match, return nil ot t - (if (and (equal verilog-flag 'lambda) (not (equal match 't))) - nil - match)))) - ;; If flag is t, this was called by all-completions. Return - ;; list of all possible completions - (verilog-flag - verilog-all))) - -(defvar verilog-last-word-numb 0) -(defvar verilog-last-word-shown nil) -(defvar verilog-last-completions nil) - -(defun verilog-complete-word () - "Complete word at current point. -\(See also `verilog-toggle-completions', `verilog-type-keywords', -`verilog-start-keywords' and `verilog-separator-keywords'.)" - (interactive) - (let* ((b (save-excursion (skip-chars-backward "a-zA-Z0-9_") (point))) - (e (save-excursion (skip-chars-forward "a-zA-Z0-9_") (point))) - (verilog-str (buffer-substring b e)) - ;; The following variable is used in verilog-completion - (verilog-buffer-to-use (current-buffer)) - (allcomp (if (and verilog-toggle-completions - (string= verilog-last-word-shown verilog-str)) - verilog-last-completions - (all-completions verilog-str 'verilog-completion))) - (match (if verilog-toggle-completions - "" (try-completion - verilog-str (mapcar '(lambda (elm) - (cons elm 0)) allcomp))))) - ;; Delete old string - (delete-region b e) - - ;; Toggle-completions inserts whole labels - (if verilog-toggle-completions - (progn - ;; Update entry number in list - (setq verilog-last-completions allcomp - verilog-last-word-numb - (if (>= verilog-last-word-numb (1- (length allcomp))) - 0 - (1+ verilog-last-word-numb))) - (setq verilog-last-word-shown (elt allcomp verilog-last-word-numb)) - ;; Display next match or same string if no match was found - (if (not (null allcomp)) - (insert "" verilog-last-word-shown) - (insert "" verilog-str) - (message "(No match)"))) - ;; The other form of completion does not necessarly do that. - - ;; Insert match if found, or the original string if no match - (if (or (null match) (equal match 't)) - (progn (insert "" verilog-str) - (message "(No match)")) - (insert "" match)) - ;; Give message about current status of completion - (cond ((equal match 't) - (if (not (null (cdr allcomp))) - (message "(Complete but not unique)") - (message "(Sole completion)"))) - ;; Display buffer if the current completion didn't help - ;; on completing the label. - ((and (not (null (cdr allcomp))) (= (length verilog-str) - (length match))) - (with-output-to-temp-buffer "*Completions*" - (display-completion-list allcomp)) - ;; Wait for a keypress. Then delete *Completion* window - (momentary-string-display "" (point)) - (delete-window (get-buffer-window (get-buffer "*Completions*"))) - ))))) - -(defun verilog-show-completions () - "Show all possible completions at current point." - (interactive) - (let* ((b (save-excursion (skip-chars-backward "a-zA-Z0-9_") (point))) - (e (save-excursion (skip-chars-forward "a-zA-Z0-9_") (point))) - (verilog-str (buffer-substring b e)) - ;; The following variable is used in verilog-completion - (verilog-buffer-to-use (current-buffer)) - (allcomp (if (and verilog-toggle-completions - (string= verilog-last-word-shown verilog-str)) - verilog-last-completions - (all-completions verilog-str 'verilog-completion)))) - ;; Show possible completions in a temporary buffer. - (with-output-to-temp-buffer "*Completions*" - (display-completion-list allcomp)) - ;; Wait for a keypress. Then delete *Completion* window - (momentary-string-display "" (point)) - (delete-window (get-buffer-window (get-buffer "*Completions*"))))) - - -(defun verilog-get-default-symbol () - "Return symbol around current point as a string." - (save-excursion - (buffer-substring (progn - (skip-chars-backward " \t") - (skip-chars-backward "a-zA-Z0-9_") - (point)) - (progn - (skip-chars-forward "a-zA-Z0-9_") - (point))))) - -(defun verilog-build-defun-re (str &optional arg) - "Return function/task/module starting with STR as regular expression. -With optional second arg non-nil, STR is the complete name of the instruction." - (if arg - (concat "^\\(function\\|task\\|module\\)[ \t]+\\(" str "\\)\\>") - (concat "^\\(function\\|task\\|module\\)[ \t]+\\(" str "[a-zA-Z0-9_]*\\)\\>"))) - -;; Function passed to completing-read, try-completion or -;; all-completions to get completion on any function name. If -;; predicate is non-nil, it must be a function to be called for every -;; match to check if this should really be a match. If flag is t, the -;; function returns a list of all possible completions. If it is nil -;; it returns a string, the longest possible completion, or t if STR -;; is an exact match. If flag is 'lambda, the function returns t if -;; STR is an exact match, nil otherwise. - -(defun verilog-comp-defun (verilog-str verilog-pred verilog-flag) - (save-excursion - (let ((verilog-all nil) - match) - - ;; Set buffer to use for searching labels. This should be set - ;; within functions which use verilog-completions - (set-buffer verilog-buffer-to-use) - - (let ((verilog-str verilog-str)) - ;; Build regular expression for functions - (if (string= verilog-str "") - (setq verilog-str (verilog-build-defun-re "[a-zA-Z_]")) - (setq verilog-str (verilog-build-defun-re verilog-str))) - (goto-char (point-min)) - - ;; Build a list of all possible completions - (while (verilog-re-search-forward verilog-str nil t) - (setq match (buffer-substring (match-beginning 2) (match-end 2))) - (if (or (null verilog-pred) - (funcall verilog-pred match)) - (setq verilog-all (cons match verilog-all))))) - - ;; Now we have built a list of all matches. Give response to caller - (verilog-completion-response)))) - -(defun verilog-goto-defun () - "Move to specified Verilog module/task/function. -The default is a name found in the buffer around point." - (interactive) - (let* ((default (verilog-get-default-symbol)) - ;; The following variable is used in verilog-comp-function - (verilog-buffer-to-use (current-buffer)) - (default (if (verilog-comp-defun default nil 'lambda) - default "")) - (label (if (not (string= default "")) - ;; Do completion with default - (completing-read (concat "Label: (default " default ") ") - 'verilog-comp-defun nil t "") - ;; There is no default value. Complete without it - (completing-read "Label: " - 'verilog-comp-defun nil t "")))) - ;; If there was no response on prompt, use default value - (if (string= label "") - (setq label default)) - ;; Goto right place in buffer if label is not an empty string - (or (string= label "") - (progn - (goto-char (point-min)) - (re-search-forward (verilog-build-defun-re label t)) - (beginning-of-line))))) -(defun verilog-showscopes () - "list all scopes in this module" - (interactive) - (let ( - (buffer (current-buffer)) - (linenum 1) - (nlines 0) - (first 1) - (prevpos (point-min)) - (final-context-start (make-marker)) - (regexp "\\(module\\s-+\\w+\\s-*(\\)\\|\\(\\w+\\s-+\\w+\\s-*(\\)") - ) - (with-output-to-temp-buffer "*Occur*" - (save-excursion - (message (format "Searching for %s ..." regexp)) - ;; Find next match, but give up if prev match was at end of buffer. - (while (and (not (= prevpos (point-max))) - (verilog-re-search-forward regexp nil t)) - (goto-char (match-beginning 0)) - (beginning-of-line) - (save-match-data - (setq linenum (+ linenum (count-lines prevpos (point))))) - (setq prevpos (point)) - (goto-char (match-end 0)) - (let* ((start (save-excursion - (goto-char (match-beginning 0)) - (forward-line (if (< nlines 0) nlines (- nlines))) - (point))) - (end (save-excursion - (goto-char (match-end 0)) - (if (> nlines 0) - (forward-line (1+ nlines)) - (forward-line 1)) - (point))) - (tag (format "%3d" linenum)) - (empty (make-string (length tag) ?\ )) - tem) - (save-excursion - (setq tem (make-marker)) - (set-marker tem (point)) - (set-buffer standard-output) - (setq occur-pos-list (cons tem occur-pos-list)) - (or first (zerop nlines) - (insert "--------\n")) - (setq first nil) - (insert-buffer-substring buffer start end) - (backward-char (- end start)) - (setq tem (if (< nlines 0) (- nlines) nlines)) - (while (> tem 0) - (insert empty ?:) - (forward-line 1) - (setq tem (1- tem))) - (let ((this-linenum linenum)) - (set-marker final-context-start - (+ (point) (- (match-end 0) (match-beginning 0)))) - (while (< (point) final-context-start) - (if (null tag) - (setq tag (format "%3d" this-linenum))) - (insert tag ?:))))))) - (set-buffer-modified-p nil)))) - -(defun verilog-submit-bug-report () - "Submit via mail a bug report on lazy-lock.el." - (interactive) - (let ((reporter-prompt-for-summary-p t)) - (reporter-submit-bug-report - "verilog-mode-bugs@silicon-sorcery.com" - (concat "verilog-mode v" (substring verilog-mode-version 12 -3)) - '(verilog-indent-level - verilog-indent-level-module - verilog-indent-level-declaration - verilog-indent-level-behavorial - verilog-case-indent - verilog-auto-newline - verilog-auto-indent-on-newline - verilog-tab-always-indent - verilog-auto-endcomments - verilog-minimum-comment-distance - verilog-indent-begin-after-if - verilog-auto-lineup) - nil nil - (concat "Hi Mac, - -I want to report a bug. I've read the `Bugs' section of `Info' on -Emacs, so I know how to make a clear and unambiguous report. To get -to that Info section, I typed - -M-x info RET m " invocation-name " RET m bugs RET - -Before I go further, I want to say that Verilog mode has changed my life. -I save so much time, my files are colored nicely, my co workers respect -my coding ability... until now. I'd really appreciate anything you -could do to help me out with this minor deficiency in the product. - -To reproduce the bug, start a fresh Emacs via " invocation-name " --no-init-file -no-site-file'. In a new buffer, in verilog mode, type -the code included below. - -Given those lines, I expected [[Fill in here]] to happen; -but instead, [[Fill in here]] happens!. - -== The code: ==")))) - -;;; verilog.el ends here
--- a/lisp/modes/view-process-xemacs.el Mon Aug 13 10:03:54 2007 +0200 +++ b/lisp/modes/view-process-xemacs.el Mon Aug 13 10:04:58 2007 +0200 @@ -315,7 +315,8 @@ (defun View-process-install-pulldown-menu () "Installs a pulldown menu for the `View-process-mode'." - (if (and current-menubar + (if (and (featurep 'menubar) + current-menubar (not (assoc View-process-pulldown-menu-name current-menubar))) (progn (set-buffer-menubar (copy-sequence current-menubar))
--- a/lisp/modes/view.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,479 +0,0 @@ -;;; view.el --- peruse file or buffer without editing. - -;; Copyright (C) 1985, 1989, 1994, 1995 Free Software Foundation, Inc. - -;; Author: K. Shane Hartman -;; Keywords: wp unix -;; Maintainer: FSF - -;; 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.34. - -;;; Commentary: - -;; This package provides the `view' minor mode documented in the Emacs -;; user's manual. - -;; XEmacs: We don't autoload this because we use `view-less' instead. -;; #### I junked the old version and replaced it with FSF's latest version. -;; Perhaps something needs integrating into view-less. - -;;; Code: - -;; XEmacs (to try to forestall complaints). -(when (featurep 'view-less) - (error "Can't load view.el and view-less.el in same session.")) - -(defvar view-highlight-face 'highlight - ;; XEmacs change - "*The extent face used for highlighting the match found by View mode search.") - -(defvar view-mode nil "Non-nil if View mode is enabled.") -(make-variable-buffer-local 'view-mode) - -(defvar view-mode-auto-exit nil - "Non-nil means scrolling past the end of buffer exits View mode. -Some commands, such as \\[view-file], set this to t locally; -+the only way to override that is to set it to nil using `view-mode-hook'.") - -(make-variable-buffer-local 'view-mode-auto-exit) - -(defvar view-old-buffer-read-only nil) -(make-variable-buffer-local 'view-old-buffer-read-only) -(defvar view-old-Helper-return-blurb) -(make-variable-buffer-local 'view-old-Helper-return-blurb) - -(defvar view-scroll-size nil) -(make-variable-buffer-local 'view-scroll-size) - -(defvar view-last-regexp nil) -(make-variable-buffer-local 'view-last-regexp) - -(defvar view-exit-action nil) -(make-variable-buffer-local 'view-exit-action) -(defvar view-return-here nil) -(make-variable-buffer-local 'view-return-here) -(defvar view-exit-position nil) -(make-variable-buffer-local 'view-exit-position) - -;; XEmacs change -(defvar view-extent nil - "Extent used to display where a search operation found its match. -This is local in each buffer, once it is used.") -(make-variable-buffer-local 'view-extent) - -(or (assq 'view-mode minor-mode-alist) - (setq minor-mode-alist - (cons '(view-mode " View") minor-mode-alist))) - -(defvar view-mode-map nil) -(if view-mode-map - nil - (setq view-mode-map (make-keymap 'view-mode-map)) - ;; We used to call suppress-keymap here, but that isn't good in a minor mode. - ;; Self-inserting characters will beep anyway, since the buffer is read-only, - ;; and we should not interfere with letters that serve as useful commands. - (define-key view-mode-map "q" 'view-exit) - (define-key view-mode-map "<" 'beginning-of-buffer) - (define-key view-mode-map ">" 'end-of-buffer) - (define-key view-mode-map "\ev" 'View-scroll-lines-backward) - (define-key view-mode-map "\C-v" 'View-scroll-lines-forward) - (define-key view-mode-map " " 'View-scroll-lines-forward) - (define-key view-mode-map "\C-?" 'View-scroll-lines-backward) - (define-key view-mode-map "\n" 'View-scroll-one-more-line) - (define-key view-mode-map "\r" 'View-scroll-one-more-line) - (define-key view-mode-map "z" 'View-scroll-lines-forward-set-scroll-size) - (define-key view-mode-map "g" 'View-goto-line) - (define-key view-mode-map "=" 'what-line) - (define-key view-mode-map "." 'set-mark-command) - (define-key view-mode-map "'" 'View-back-to-mark) - (define-key view-mode-map "@" 'View-back-to-mark) - (define-key view-mode-map "x" 'exchange-point-and-mark) - (define-key view-mode-map "h" 'describe-mode) - (define-key view-mode-map "?" 'describe-mode) - (define-key view-mode-map "s" 'isearch-forward) - (define-key view-mode-map "r" 'isearch-backward) - (define-key view-mode-map "/" 'View-search-regexp-forward) - (define-key view-mode-map "\\" 'View-search-regexp-backward) - ;; This conflicts with the standard binding of isearch-regexp-forward - (define-key view-mode-map "\e\C-s" 'View-search-regexp-forward) - (define-key view-mode-map "\e\C-r" 'View-search-regexp-backward) - (define-key view-mode-map "n" 'View-search-last-regexp-forward) - (define-key view-mode-map "p" 'View-search-last-regexp-backward) - ) - -(or (assq 'view-mode minor-mode-map-alist) - (setq minor-mode-map-alist - (cons (cons 'view-mode view-mode-map) minor-mode-map-alist))) - - -(defun view-file (file-name) - "View FILE in View mode, returning to previous buffer when done. -The usual Emacs commands are not available; instead, -a special set of commands (mostly letters and punctuation) -are defined for moving around in the buffer. -Space scrolls forward, Delete scrolls backward. -For list of all View commands, type ? or h while viewing. - -This command runs the normal hook `view-mode-hook'." - (interactive "fView file: ") - (let ((old-buf (current-buffer)) - (had-a-buf (get-file-buffer file-name)) - (buf-to-view (find-file-noselect file-name))) - ;; This used to pass t as second argument, - ;; but then the buffer did not show up in the Buffers menu. - (switch-to-buffer buf-to-view had-a-buf) - (view-mode-enter old-buf - (and (not had-a-buf) (not (buffer-modified-p buf-to-view)) - 'kill-buffer)))) - -(defun view-file-other-window (file-name) - "View FILE in View mode in other window. -Return to previous buffer when done. -The usual Emacs commands are not available; instead, -a special set of commands (mostly letters and punctuation) -are defined for moving around in the buffer. -Space scrolls forward, Delete scrolls backward. -For list of all View commands, type ? or h while viewing. - -This command runs the normal hook `view-mode-hook'." - (interactive "fView file: ") - (let ((old-arrangement (current-window-configuration)) - (had-a-buf (get-file-buffer file-name)) - (buf-to-view (find-file-noselect file-name))) - (switch-to-buffer-other-window buf-to-view) - (view-mode-enter old-arrangement - (and (not had-a-buf) (not (buffer-modified-p buf-to-view)) - 'kill-buffer)))) - -(defun view-buffer (buffer-name) - "View BUFFER in View mode, returning to previous buffer when done. -The usual Emacs commands are not available; instead, -a special set of commands (mostly letters and punctuation) -are defined for moving around in the buffer. -Space scrolls forward, Delete scrolls backward. -For list of all View commands, type ? or h while viewing. - -This command runs the normal hook `view-mode-hook'." - (interactive "bView buffer: ") - (let ((old-buf (current-buffer))) - (switch-to-buffer buffer-name t) - (view-mode-enter old-buf nil))) - -(defun view-buffer-other-window (buffer-name not-return) - "View BUFFER in View mode in another window. -Return to previous buffer when done, unless NOT-RETURN is non-nil. - -The usual Emacs commands are not available in View mode; instead, -a special set of commands (mostly letters and punctuation) -are defined for moving around in the buffer. -Space scrolls forward, Delete scrolls backward. -For list of all View commands, type ? or h while viewing. - -This command runs the normal hook `view-mode-hook'." - (interactive "bView buffer:\nP") - (let ((return-to (and not-return (current-window-configuration)))) - (switch-to-buffer-other-window buffer-name) - (view-mode-enter return-to))) - -(defun view-mode (&optional arg) - "Toggle View mode. -With a prefix argument, turn View mode on if the argument is >= zero -and off if it is not. - -If you use this function to turn on View mode, then subsequently -\"exiting\" View mode does nothing except turn View mode off. The -other way to turn View mode on is by calling `view-mode-enter'; -that is what Lisp programs usually use. - -Letters do not insert themselves. Instead these commands are provided. -Most commands take prefix arguments. Commands dealing with lines -default to \"scroll size\" lines (initially size of window). -Search commands default to a repeat count of one. - -M-< or < move to beginning of buffer. -M-> or > move to end of buffer. -C-v or Space scroll forward lines. -M-v or DEL scroll backward lines. -CR or LF scroll forward one line (backward with prefix argument). -z like Space except set number of lines for further - scrolling commands to scroll by. -C-u and Digits provide prefix arguments. `-' denotes negative argument. -= prints the current line number. -g goes to line given by prefix argument. -/ or M-C-s searches forward for regular expression -\\ or M-C-r searches backward for regular expression. -n searches forward for last regular expression. -p searches backward for last regular expression. -C-@ or . set the mark. -x exchanges point and mark. -C-s or s do forward incremental search. -C-r or r do reverse incremental search. -@ or ' return to mark and pops mark ring. - Mark ring is pushed at start of every - successful search and when jump to line to occurs. - The mark is set on jump to buffer start or end. -? or h provide help message (list of commands). -\\[help-command] provides help (list of commands or description of a command). -C-n moves down lines vertically. -C-p moves upward lines vertically. -C-l recenters the screen. -q exit view-mode and return to previous buffer." - (interactive "P") - (setq view-mode - (if (null arg) - (not view-mode) - (> (prefix-numeric-value arg) 0))) - (force-mode-line-update)) - -(defun view-mode-enter (&optional prev-buffer action) - "Enter View mode, a Minor mode for viewing text but not editing it. -See the function `view-mode' for more details. - -This function runs the normal hook `view-mode-hook'. - -\\{view-mode-map}" -; Not interactive because dangerous things happen -; if you call it without passing a buffer as argument -; and they are not easy to fix. -; (interactive) - (setq view-old-buffer-read-only buffer-read-only) - (setq view-old-Helper-return-blurb - (and (boundp 'Helper-return-blurb) Helper-return-blurb)) - - ;; Enable view-exit to make use of the data we just saved - ;; and to perform the exit action. - (setq view-mode-auto-exit t) - - (setq buffer-read-only t) - (setq view-mode t) - (setq Helper-return-blurb - (format "continue viewing %s" - (if (buffer-file-name) - (file-name-nondirectory (buffer-file-name)) - (buffer-name)))) - - (setq view-exit-action action) - (setq view-return-here prev-buffer) - (setq view-exit-position (point-marker)) - - (beginning-of-line) - (setq goal-column nil) - - (run-hooks 'view-mode-hook) - (message - (substitute-command-keys - "Type \\[help-command] for help, \\[describe-mode] for commands, \\[view-exit] to quit."))) - -(defun view-exit () - "Exit from view-mode. -If you viewed an existing buffer, that buffer returns to its previous mode. -If you viewed a file that was not present in Emacs, its buffer is killed." - (interactive) - (setq view-mode nil) - ;; XEmacs change - (and view-extent (delete-extent view-extent)) - (force-mode-line-update) - (cond (view-mode-auto-exit - (setq buffer-read-only view-old-buffer-read-only) - (setq view-mode-auto-exit nil) - - (goto-char view-exit-position) - (set-marker view-exit-position nil) - - ;; Now do something to the buffer that we were viewing - ;; (such as kill it). - (let ((viewed-buffer (current-buffer)) - (action view-exit-action)) - (cond - ((bufferp view-return-here) - (switch-to-buffer view-return-here)) - ((window-configuration-p view-return-here) - (set-window-configuration view-return-here))) - (if action (funcall action viewed-buffer)))))) - -(defun view-window-size () (1- (window-height))) - -(defun view-scroll-size () - (min (view-window-size) (or view-scroll-size (view-window-size)))) - -(defvar view-mode-hook nil - "Normal hook run when starting to view a buffer or file.") - -;(defun view-last-command (&optional who what) -; (setq view-last-command-entry this-command) -; (setq view-last-command who) -; (setq view-last-command-argument what)) - -;(defun View-repeat-last-command () -; "Repeat last command issued in View mode." -; (interactive) -; (if (and view-last-command -; (eq view-last-command-entry last-command)) -; (funcall view-last-command view-last-command-argument)) -; (setq this-command view-last-command-entry)) - -(defun View-goto-line (line) - "Move to line LINE in View mode. -Display is centered at LINE. Sets mark at starting position and pushes -mark ring." - (interactive "p") - (push-mark) - (goto-line line) - (recenter (/ (view-window-size) 2))) - -(defun View-scroll-lines-forward (&optional lines) - "Scroll forward in View mode, or exit if end of text is visible. -No arg means whole window full, or number of lines set by \\[View-scroll-lines-forward-set-scroll-size]. -Arg is number of lines to scroll." - (interactive "P") - (setq lines - (if lines (prefix-numeric-value lines) - (view-scroll-size))) - (if (and (pos-visible-in-window-p (point-max)) - ;; Allow scrolling backward at the end of the buffer. - (> lines 0) - view-mode-auto-exit) - (view-exit) - ;; (view-last-command 'View-scroll-lines-forward lines) - (if (>= lines (view-window-size)) - (scroll-up nil) - (if (>= (- lines) (view-window-size)) - (scroll-down nil) - (scroll-up lines))) - (cond ((pos-visible-in-window-p (point-max)) - (goto-char (point-max)) - (message "%s" - (substitute-command-keys - "End. Type \\[view-exit] to quit viewing.")))) - (move-to-window-line -1) - (beginning-of-line))) - -(defun View-scroll-lines-forward-set-scroll-size (&optional lines) - "Scroll forward LINES lines in View mode, setting the \"scroll size\". -This is the number of lines which \\[View-scroll-lines-forward] and \\[View-scroll-lines-backward] scroll by default. -The absolute value of LINES is used, so this command can be used to scroll -backwards (but \"scroll size\" is always positive). If LINES is greater than -window height or omitted, then window height is assumed. If LINES is less -than window height then scrolling context is provided from previous screen." - (interactive "P") - (if (not lines) - (setq view-scroll-size (view-window-size)) - (setq lines (prefix-numeric-value lines)) - (setq view-scroll-size - (min (if (> lines 0) lines (- lines)) (view-window-size)))) - (View-scroll-lines-forward lines)) - -(defun View-scroll-one-more-line (&optional arg) - "Scroll one more line up in View mode. -With ARG scroll one line down." - (interactive "P") - (View-scroll-lines-forward (if (not arg) 1 -1))) - -(defun View-scroll-lines-backward (&optional lines) - "Scroll backward in View mode. -No arg means whole window full, or number of lines set by \\[View-scroll-lines-forward-set-scroll-size]. -Arg is number of lines to scroll." - (interactive "P") - (View-scroll-lines-forward (if lines - (- (prefix-numeric-value lines)) - (- (view-scroll-size))))) - -(defun View-search-regexp-forward (n regexp) - "Search forward for Nth occurrence of REGEXP. -Displays line found at center of window. REGEXP is remembered for -searching with \\[View-search-last-regexp-forward] and \\[View-search-last-regexp-backward]. Sets mark at starting position and pushes mark ring. - -The variable `view-highlight-face' controls the face that is used -for highlighting the match that is found." - (interactive "p\nsSearch forward (regexp): ") -;;;(view-last-command 'View-search-last-regexp-forward n) - (view-search n (if (equal regexp "") view-last-regexp regexp))) - -(defun View-search-regexp-backward (n regexp) - "Search backward from window start for Nth instance of REGEXP. -Displays line found at center of window. REGEXP is remembered for -searching with \\[View-search-last-regexp-forward] and \\[View-search-last-regexp-backward]. Sets mark at starting position and pushes mark ring. - -The variable `view-highlight-face' controls the face that is used -for highlighting the match that is found." - (interactive "p\nsSearch backward (regexp): ") - (View-search-regexp-forward (- n) - (if (equal regexp "") view-last-regexp regexp))) - -(defun View-search-last-regexp-forward (n) - "Search forward from window end for Nth instance of last regexp. -Displays line found at center of window. Sets mark at starting position -and pushes mark ring. - -The variable `view-highlight-face' controls the face that is used -for highlighting the match that is found." - (interactive "p") - (if view-last-regexp - (View-search-regexp-forward n view-last-regexp) - (error "No previous View-mode search"))) - -(defun View-search-last-regexp-backward (n) - "Search backward from window start for Nth instance of last regexp. -Displays line found at center of window. Sets mark at starting position and -pushes mark ring. - -The variable `view-highlight-face' controls the face that is used -for highlighting the match that is found." - (interactive "p") - (if view-last-regexp - (View-search-regexp-backward n view-last-regexp) - (error "No previous View-mode search"))) - -(defun View-back-to-mark (&optional ignore) - "Return to last mark set in View mode, else beginning of file. -Displays line at center of window. Pops mark ring so successive -invocations return to earlier marks." - (interactive) - (goto-char (or (mark t) (point-min))) - (pop-mark) - (recenter (/ (view-window-size) 2))) - -(defun view-search (times regexp) - (setq view-last-regexp regexp) - (let (where) - (save-excursion - (move-to-window-line (if (< times 0) 0 -1)) - (if (re-search-forward regexp nil t times) - (setq where (point)))) - (if where - (progn - (push-mark) - (goto-char where) - ;; XEmacs change. - (if view-extent - (set-extent-endpoints view-extent (match-beginning 0) - (match-end 0)) - (setq view-extent - (make-extent (match-beginning 0) (match-end 0)))) - (set-extent-face view-extent view-highlight-face) - (beginning-of-line) - (recenter (/ (view-window-size) 2))) - (message "Can't find occurrence %d of %s" times regexp) - (sit-for 4)))) - - -(provide 'view) - -;;; view.el ends here
--- a/lisp/modes/vrml-mode.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,784 +0,0 @@ -;;; vrml-mode.el --- major mode for editing VRML (.wrl) files - -;; Copyright (C) 1994 Free Software Foundation, Inc. -;; Copyright (C) 1996 Ben Wing. - -;; Author: Ben Wing <wing@666.com> -;; Keywords: languages vrml modes - -;; 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: - -;; Mostly bastardized from tcl.el. - -;; HOW TO INSTALL: -;; Put the following forms in your .emacs to enable autoloading of VRML -;; mode, and auto-recognition of ".wrl" files. -;; -;; (autoload 'vrml-mode "vrml" "VRML mode." t) -;; (setq auto-mode-alist (append '(("\\.wrl\\'" . vrml-mode)) -;; auto-mode-alist)) -;; - -;;; Code: - -;; -;; User variables. -;; - -(defgroup vrml nil - "Major mode for editing VRML (.wrl) files." - :group 'languages) - - -(defcustom vrml-indent-level 3 - "*Indentation of VRML statements with respect to containing block." - :type 'integer - :group 'vrml) - -(defcustom vrml-auto-newline nil - "*Non-nil means automatically newline before and after braces -inserted in VRML code." - :type 'boolean - :group 'vrml) - -(defcustom vrml-tab-always-indent t - "*Control effect of TAB key. -If t (the default), always indent current line. -If nil and point is not in the indentation area at the beginning of -the line, a TAB is inserted. -Other values cause the first possible action from the following list -to take place: - - 1. Move from beginning of line to correct indentation. - 2. Delete an empty comment. - 3. Move forward to start of comment, indenting if necessary. - 4. Move forward to end of line, indenting if necessary. - 5. Create an empty comment. - 6. Move backward to start of comment, indenting if necessary." - :type '(choice (const :tag "on" t) - (const :tag "off" nil) - (sexp :format "%t\n" :tag "The Works" other)) - :group 'vrml) - -(defcustom vrml-use-hairy-comment-detector t - "*If not `nil', then the more complicated, but slower, comment -detecting function is used." - :type 'boolean - :group 'vrml) - -(defvar vrml-mode-abbrev-table nil - "Abbrev table used while in VRML mode.") -(define-abbrev-table 'vrml-mode-abbrev-table ()) - -(defvar vrml-mode-map () - "Keymap used in VRML mode.") -(if (null vrml-mode-map) - (progn - (setq vrml-mode-map (make-sparse-keymap)) - (set-keymap-name vrml-mode-map 'vrml-mode-map) - (define-key vrml-mode-map "{" 'vrml-electric-brace) - (define-key vrml-mode-map "}" 'vrml-electric-brace) - (define-key vrml-mode-map "\e\C-q" 'indent-vrml-exp) - (define-key vrml-mode-map "\t" 'vrml-indent-command) - (define-key vrml-mode-map "\M-;" 'vrml-indent-for-comment) - )) - -(defvar vrml-mode-syntax-table nil - "Syntax table in use in vrml-mode buffers.") - -(if vrml-mode-syntax-table - () - (setq vrml-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?\n ">" vrml-mode-syntax-table) - (modify-syntax-entry ?\f ">" vrml-mode-syntax-table) - (modify-syntax-entry ?\# "<" vrml-mode-syntax-table) - (modify-syntax-entry ?\\ "\\" vrml-mode-syntax-table) - (modify-syntax-entry ?% "_" vrml-mode-syntax-table) - (modify-syntax-entry ?@ "_" vrml-mode-syntax-table) - (modify-syntax-entry ?& "_" vrml-mode-syntax-table) - (modify-syntax-entry ?* "_" vrml-mode-syntax-table) - (modify-syntax-entry ?- "_" vrml-mode-syntax-table) - (modify-syntax-entry ?: "_" vrml-mode-syntax-table) - (modify-syntax-entry ?! "_" vrml-mode-syntax-table) - (modify-syntax-entry ?$ "_" vrml-mode-syntax-table) - (modify-syntax-entry ?/ "_" vrml-mode-syntax-table) - (modify-syntax-entry ?~ "_" vrml-mode-syntax-table) - (modify-syntax-entry ?< "_" vrml-mode-syntax-table) - (modify-syntax-entry ?= "_" vrml-mode-syntax-table) - (modify-syntax-entry ?> "_" vrml-mode-syntax-table) - (modify-syntax-entry ?| "_" vrml-mode-syntax-table) - (modify-syntax-entry ?+ "." vrml-mode-syntax-table) - (modify-syntax-entry ?\' "\"" vrml-mode-syntax-table)) - -(defcustom vrml-mode-hook nil - "Hook run on entry to VRML mode." - :type 'hook - :group 'vrml) - -(defvar vrml-keyword-list - '( - ; shape nodes: - "AsciiText" "Cone" "Cube" "Cylinder" "IndexedFaceSet" "IndexedLineSet" - "PointSet" "Sphere" - ; geometry and material nodes: - "Coordinate3" "FontStyle" "Info" "LOD" "Material" "MaterialBinding" - "Normal" "NormalBinding" "Texture2" "Texture2Transform" - "TextureCoordinate2" "ShapeHints" - ; transformation nodes: - "MatrixTransform" "Rotation" "Scale" "Transform" "Translation" - ;camera nodes: - "OrthographicCamera" "PerspectiveCamera" - ;lighting nodes: - "DirectionalLight" "PointLight" "SpotLight" - ;group nodes: - "Group" "Separator" "Switch" "TransformSeparator" "WWWAnchor" - ;other: - "WWWInline" - ;new VRML 2.0 nodes (#### not yet classified) - "Anchor" "Appearance" "AudioClip" "Background" "Billboard" "Box" - "Collision" "Color" "ColorInterpolator" "Coordinate" - "CoordinateInterpolator" "CylinderSensor" "DiskSensor" "ElevationGrid" - "Extrusion" "Fog" "FontStyle" "ImageTexture" "Inline" "MovieTexture" - "NavigationInfo" "NormalInterpolator" "OrientationInterpolator" - "PixelTexture" "PlaneSensor" "PositionInterpolator" "ProximitySensor" - "ScalarInterpolator" "Script" "Shape" "Sound" "SphereSensor" "Text" - "TextureTransform" "TextureCoordinate" "TimeSensor" "TouchSensor" - "Viewpoint" "VisibilitySensor" "WorldInfo" - ;VRML 2.0 node fields - "eventIn" "eventOut" "field" "exposedField" - ;misc. VRML 2.0 keywords (DEF, PROTO, EXTERNPROTO handled below) - "USE" "ROUTE" "TO" "IS" "TRUE" "FALSE" "NULL" -)) - -(defconst vrml-font-lock-keywords - (list - ;; Names of functions (and other "defining things"). - (list "\\(DEF\\|PROTO\\|EXTERNPROTO\\)[ \t\n]+\\([^ \t\n]+\\)" - 2 'font-lock-function-name-face) - - ;; Keywords. Only recognized if surrounded by whitespace. - ;; FIXME consider using "not word or symbol", not - ;; "whitespace". - (cons (concat "\\(\\s-\\|^\\)\\(" - ;; FIXME Use regexp-quote? - (mapconcat 'identity vrml-keyword-list "\\|") - "\\)\\(\\s-\\|$\\)") - 2) - ) - "Keywords to highlight for VRML. See variable `font-lock-keywords'.") - -;;;###autoload -(defun vrml-mode () - "Major mode for editing VRML code. -Expression and list commands understand all VRML brackets. -Tab indents for VRML code. -Paragraphs are separated by blank lines only. -Delete converts tabs to spaces as it moves back. - -Variables controlling indentation style: - vrml-indent-level - Indentation of VRML statements within surrounding block. - -Variables controlling user interaction with mode (see variable -documentation for details): - vrml-tab-always-indent - Controls action of TAB key. - vrml-auto-newline - Non-nil means automatically newline before and after braces - inserted in VRML code. - -Turning on VRML mode calls the value of the variable `vrml-mode-hook' -with no args, if that value is non-nil. Read the documentation for -`vrml-mode-hook' to see what kinds of interesting hook functions -already exist. - -Commands: -\\{vrml-mode-map}" - (interactive) - (kill-all-local-variables) - (use-local-map vrml-mode-map) - (setq major-mode 'vrml-mode) - (setq mode-name "VRML") - (setq local-abbrev-table vrml-mode-abbrev-table) - (set-syntax-table vrml-mode-syntax-table) - - (make-local-variable 'paragraph-start) - (make-local-variable 'paragraph-separate) - (if (fboundp 'move-to-left-margin) - (progn - ;; In FSF Emacs 19.29 / XEmacs 19.14, you aren't supposed to - ;; start these with a ^. - (setq paragraph-start "$\\| ") - (setq paragraph-separate paragraph-start)) - (setq paragraph-start (concat "^$\\|" page-delimiter)) - (setq paragraph-separate paragraph-start)) - (make-local-variable 'paragraph-ignore-fill-prefix) - (setq paragraph-ignore-fill-prefix t) - (make-local-variable 'fill-paragraph-function) - (setq fill-paragraph-function 'vrml-do-fill-paragraph) - - (make-local-variable 'indent-line-function) - (setq indent-line-function 'vrml-indent-line) - (make-local-variable 'require-final-newline) - (setq require-final-newline t) - - (make-local-variable 'comment-start) - (setq comment-start "# ") - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "#+ *") - (make-local-variable 'comment-column) - (setq comment-column 40) - (make-local-variable 'comment-end) - (setq comment-end "") - - (make-local-variable 'outline-regexp) - (setq outline-regexp "[^\n\^M]") - (make-local-variable 'outline-level) - (setq outline-level 'vrml-outline-level) - - (make-local-variable 'font-lock-keywords) - (setq font-lock-keywords vrml-font-lock-keywords) - - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments t) - - (make-local-variable 'defun-prompt-regexp) - (setq defun-prompt-regexp "^[^ \t\n#}][^\n}]+}*[ \t]+") - - ;; Settings for new dabbrev code. - (make-local-variable 'dabbrev-case-fold-search) - (setq dabbrev-case-fold-search nil) - (make-local-variable 'dabbrev-case-replace) - (setq dabbrev-case-replace nil) - (make-local-variable 'dabbrev-abbrev-skip-leading-regexp) - (setq dabbrev-abbrev-skip-leading-regexp "[$!]") - (make-local-variable 'dabbrev-abbrev-char-regexp) - (setq dabbrev-abbrev-char-regexp "\\sw\\|\\s_") - - (run-hooks 'vrml-mode-hook)) - -;; This is used for closing braces. If vrml-auto-newline is set, can -;; insert a newline both before and after the brace, depending on -;; context. FIXME should this be configurable? Does anyone use this? -(defun vrml-electric-brace (arg) - "Insert character and correct line's indentation." - (interactive "p") - ;; If auto-newlining and there is stuff on the same line, insert a - ;; newline first. - (if vrml-auto-newline - (progn - (if (save-excursion - (skip-chars-backward " \t") - (bolp)) - () - (vrml-indent-line) - (newline)) - ;; In auto-newline case, must insert a newline after each - ;; brace. So an explicit loop is needed. - (while (> arg 0) - (insert last-command-char) - (vrml-indent-line) - (newline) - (setq arg (1- arg)))) - (self-insert-command arg)) - (vrml-indent-line)) - - - -(defun vrml-indent-command (&optional arg) - "Indent current line as VRML code, or in some cases insert a tab character. -If vrml-tab-always-indent is t (the default), always indent current line. -If vrml-tab-always-indent is nil and point is not in the indentation -area at the beginning of the line, a TAB is inserted. -Other values of vrml-tab-always-indent cause the first possible action -from the following list to take place: - - 1. Move from beginning of line to correct indentation. - 2. Delete an empty comment. - 3. Move forward to start of comment, indenting if necessary. - 4. Move forward to end of line, indenting if necessary. - 5. Create an empty comment. - 6. Move backward to start of comment, indenting if necessary." - (interactive "p") - (cond - ((not vrml-tab-always-indent) - ;; Indent if in indentation area, otherwise insert TAB. - (if (<= (current-column) (current-indentation)) - (vrml-indent-line) - (self-insert-command arg))) - ((eq vrml-tab-always-indent t) - ;; Always indent. - (vrml-indent-line)) - (t - ;; "Perl-mode" style TAB command. - (let* ((ipoint (point)) - (eolpoint (progn - (end-of-line) - (point))) - (comment-p (vrml-in-comment))) - (cond - ((= ipoint (save-excursion - (beginning-of-line) - (point))) - (beginning-of-line) - (vrml-indent-line) - ;; If indenting didn't leave us in column 0, go to the - ;; indentation. Otherwise leave point at end of line. This - ;; is a hack. - (if (= (point) (save-excursion - (beginning-of-line) - (point))) - (end-of-line) - (back-to-indentation))) - ((and comment-p (looking-at "[ \t]*$")) - ;; Empty comment, so delete it. We also delete any ";" - ;; characters at the end of the line. I think this is - ;; friendlier, but I don't know how other people will feel. - (backward-char) - (skip-chars-backward " \t;") - (delete-region (point) eolpoint)) - ((and comment-p (< ipoint (point))) - ;; Before comment, so skip to it. - (vrml-indent-line) - (indent-for-comment)) - ((/= ipoint eolpoint) - ;; Go to end of line (since we're not there yet). - (goto-char eolpoint) - (vrml-indent-line)) - ((not comment-p) - (vrml-indent-line) - (vrml-indent-for-comment)) - (t - ;; Go to start of comment. We don't leave point where it is - ;; because we want to skip comment-start-skip. - (vrml-indent-line) - (indent-for-comment))))))) - -(defun vrml-indent-line () - "Indent current line as VRML code. -Return the amount the indentation changed by." - (let ((indent (calculate-vrml-indent nil)) - beg shift-amt - (case-fold-search nil) - (pos (- (point-max) (point)))) - (beginning-of-line) - (setq beg (point)) - (cond ((eq indent nil) - (setq indent (current-indentation))) - (t - (skip-chars-forward " \t") - (if (listp indent) (setq indent (car indent))) - (cond ((= (following-char) ?}) - (setq indent (- indent vrml-indent-level))) - ((= (following-char) ?\]) - (setq indent (- indent 1)))))) - (skip-chars-forward " \t") - (setq shift-amt (- indent (current-column))) - (if (zerop shift-amt) - (if (> (- (point-max) pos) (point)) - (goto-char (- (point-max) pos))) - (delete-region beg (point)) - (indent-to indent) - ;; If initial point was within line's indentation, - ;; position after the indentation. Else stay at same point in text. - (if (> (- (point-max) pos) (point)) - (goto-char (- (point-max) pos)))) - shift-amt)) - -(defun calculate-vrml-indent (&optional parse-start) - "Return appropriate indentation for current line as VRML code. -In usual case returns an integer: the column to indent to. -Returns nil if line starts inside a string, t if in a comment." - (save-excursion - (beginning-of-line) - (let* ((indent-point (point)) - (case-fold-search nil) - state - containing-sexp - found-next-line) - (if parse-start - (goto-char parse-start) - (beginning-of-defun)) - (while (< (point) indent-point) - (setq parse-start (point)) - (setq state (parse-partial-sexp (point) indent-point 0)) - (setq containing-sexp (car (cdr state)))) - (cond ((or (nth 3 state) (nth 4 state)) - ;; Inside comment or string. Return nil or t if should - ;; not change this line - (nth 4 state)) - ((null containing-sexp) - ;; Line is at top level. - 0) - (t - (goto-char containing-sexp) - (let* ((expr-start (point))) - ;; Find the first statement in the block and indent - ;; like it. The first statement in the block might be - ;; on the same line, so what we do is skip all - ;; "virtually blank" lines, looking for a non-blank - ;; one. A line is virtually blank if it only contains - ;; a comment and whitespace. We do it this funky way - ;; because we want to know if we've found a statement - ;; on some line _after_ the line holding the sexp - ;; opener. - (goto-char containing-sexp) - (forward-char) - (if (and (< (point) indent-point) - (looking-at "[ \t]*\\(#.*\\)?$")) - (progn - (forward-line) - (while (and (< (point) indent-point) - (looking-at "[ \t]*\\(#.*\\)?$")) - (setq found-next-line t) - (forward-line)))) - (if (not (or (= (char-after containing-sexp) ?{) - (and (= (char-after containing-sexp) ?\[) - (save-excursion - (goto-char containing-sexp) - (skip-chars-backward " \t\n") - (forward-char -8) - (looking-at "children"))))) - (progn - ;; Line is continuation line, or the sexp opener - ;; is not a curly brace, or we are looking at - ;; an `expr' expression (which must be split - ;; specially). So indentation is column of first - ;; good spot after sexp opener. If there is no - ;; nonempty line before the indentation point, we - ;; use the column of the character after the sexp - ;; opener. - (if (>= (point) indent-point) - (progn - (goto-char containing-sexp) - (forward-char)) - (skip-chars-forward " \t")) - (current-column)) - ;; After a curly brace, and not a continuation line. - ;; So take indentation from first good line after - ;; start of block, unless that line is on the same - ;; line as the opening brace. In this case use the - ;; indentation of the opening brace's line, plus - ;; another indent step. If we are in the body part - ;; of an "if" or "while" then the indentation is - ;; taken from the line holding the start of the - ;; statement. - (if (and (< (point) indent-point) - found-next-line) - (current-indentation) - (if t ; commands-p - (goto-char expr-start) - (goto-char containing-sexp)) - (+ (current-indentation) vrml-indent-level))))))))) - - - -(defun indent-vrml-exp () - "Indent each line of the VRML grouping following point." - (interactive) - (let ((indent-stack (list nil)) - (contain-stack (list (point))) - (case-fold-search nil) - outer-loop-done inner-loop-done state ostate - this-indent last-sexp - (next-depth 0) - last-depth) - (save-excursion - (forward-sexp 1)) - (save-excursion - (setq outer-loop-done nil) - (while (and (not (eobp)) (not outer-loop-done)) - (setq last-depth next-depth) - ;; Compute how depth changes over this line - ;; plus enough other lines to get to one that - ;; does not end inside a comment or string. - ;; Meanwhile, do appropriate indentation on comment lines. - (setq inner-loop-done nil) - (while (and (not inner-loop-done) - (not (and (eobp) (setq outer-loop-done t)))) - (setq ostate state) - (setq state (parse-partial-sexp (point) (progn (end-of-line) (point)) - nil nil state)) - (setq next-depth (car state)) - (if (and (car (cdr (cdr state))) - (>= (car (cdr (cdr state))) 0)) - (setq last-sexp (car (cdr (cdr state))))) - (if (or (nth 4 ostate)) - (vrml-indent-line)) - (if (or (nth 3 state)) - (forward-line 1) - (setq inner-loop-done t))) - (if (<= next-depth 0) - (setq outer-loop-done t)) - (if outer-loop-done - nil - ;; If this line had ..))) (((.. in it, pop out of the levels - ;; that ended anywhere in this line, even if the final depth - ;; doesn't indicate that they ended. - (while (> last-depth (nth 6 state)) - (setq indent-stack (cdr indent-stack) - contain-stack (cdr contain-stack) - last-depth (1- last-depth))) - (if (/= last-depth next-depth) - (setq last-sexp nil)) - ;; Add levels for any parens that were started in this line. - (while (< last-depth next-depth) - (setq indent-stack (cons nil indent-stack) - contain-stack (cons nil contain-stack) - last-depth (1+ last-depth))) - (if (null (car contain-stack)) - (setcar contain-stack - (or (car (cdr state)) - (save-excursion - (forward-sexp -1) - (point))))) - (forward-line 1) - (skip-chars-forward " \t") - (if (eolp) - nil - (if (and (car indent-stack) - (>= (car indent-stack) 0)) - ;; Line is on an existing nesting level. - (setq this-indent (car indent-stack)) - ;; Just started a new nesting level. - ;; Compute the standard indent for this level. - (let ((val (calculate-vrml-indent - (if (car indent-stack) - (- (car indent-stack)))))) - (setcar indent-stack - (setq this-indent val)) - )) - (cond ((not (numberp this-indent))) - ((= (following-char) ?}) - (setq this-indent (- this-indent vrml-indent-level))) - ((= (following-char) ?\]) - (setq this-indent (- this-indent 1)))) - ;; Put chosen indentation into effect. - (or (null this-indent) - (= (current-column) - this-indent) - (progn - (delete-region (point) (progn (beginning-of-line) (point))) - (indent-to - this-indent)))))))) - ) - -;; -;; Auto-fill support. -;; - -(defun vrml-real-command-p () - "Return nil if point is not at the beginning of a command. -A command is the first word on an otherwise empty line, or the -first word following an opening brace." - (save-excursion - (skip-chars-backward " \t") - (cond - ((bobp) t) - ((bolp) - (backward-char) - ;; Note -- continued comments are not supported here. I - ;; consider those to be a wart on the language. - (not (eq ?\\ (preceding-char)))) - (t - (memq (preceding-char) '(?{)))))) - -;; FIXME doesn't actually return t. See last case. -(defun vrml-real-comment-p () - "Return t if point is just after the `#' beginning a real comment. -Does not check to see if previous char is actually `#'. -A real comment is either at the beginning of the buffer, -preceded only by whitespace on the line, or has a preceding -semicolon, opening brace, or opening bracket on the same line." - (save-excursion - (backward-char) - (vrml-real-command-p))) - -(defun vrml-hairy-scan-for-comment (state end always-stop) - "Determine if point is in a comment. -Returns a list of the form `(FLAG . STATE)'. STATE can be used -as input to future invocations. FLAG is nil if not in comment, -t otherwise. If in comment, leaves point at beginning of comment. -See also `vrml-simple-scan-for-comment', a simpler version that is -often right." - (let ((bol (save-excursion - (goto-char end) - (beginning-of-line) - (point))) - real-comment - last-cstart) - (while (and (not last-cstart) (< (point) end)) - (setq real-comment nil) ;In case we've looped around and it is - ;set. - (setq state (parse-partial-sexp (point) end nil nil state t)) - (if (nth 4 state) - (progn - ;; If ALWAYS-STOP is set, stop even if we don't have a - ;; real comment, or if the comment isn't on the same line - ;; as the end. - (if always-stop (setq last-cstart (point))) - ;; If we have a real comment, then set the comment - ;; starting point if we are on the same line as the ending - ;; location. - (setq real-comment (vrml-real-comment-p)) - (if real-comment - (progn - (and (> (point) bol) (setq last-cstart (point))) - ;; NOTE Emacs 19 has a misfeature whereby calling - ;; parse-partial-sexp with COMMENTSTOP set and with - ;; an initial list that says point is in a comment - ;; will cause an immediate return. So we must skip - ;; over the comment ourselves. - (beginning-of-line 2))) - ;; Frob the state to make it look like we aren't in a - ;; comment. - (setcar (nthcdr 4 state) nil)))) - (and last-cstart - (goto-char last-cstart)) - (cons real-comment state))) - -(defun vrml-hairy-in-comment () - "Return t if point is in a comment, and leave point at beginning -of comment." - (let ((save (point))) - (beginning-of-defun) - (car (vrml-hairy-scan-for-comment nil save nil)))) - -(defun vrml-simple-in-comment () - "Return t if point is in comment, and leave point at beginning -of comment. This is faster than `vrml-hairy-in-comment', but is -correct less often." - (let ((save (point)) - comment) - (beginning-of-line) - (while (and (< (point) save) (not comment)) - (search-forward "#" save 'move) - (setq comment (vrml-real-comment-p))) - comment)) - -(defun vrml-in-comment () - "Return t if point is in comment, and leave point at beginning -of comment." - (if vrml-use-hairy-comment-detector - (vrml-hairy-in-comment) - (vrml-simple-in-comment))) - -(defun vrml-do-fill-paragraph (ignore) - "fill-paragraph function for VRML mode. Only fills in a comment." - (let (in-comment col where) - (save-excursion - (end-of-line) - (setq in-comment (vrml-in-comment)) - (if in-comment - (progn - (setq where (1+ (point))) - (setq col (1- (current-column)))))) - (and in-comment - (save-excursion - (back-to-indentation) - (= col (current-column))) - ;; In a comment. Set the fill prefix, and find the paragraph - ;; boundaries by searching for lines that look like - ;; comment-only lines. - (let ((fill-prefix (buffer-substring (progn - (beginning-of-line) - (point)) - where)) - p-start p-end) - ;; Search backwards. - (save-excursion - (while (looking-at "^[ \t]*#") - (forward-line -1)) - (forward-line) - (setq p-start (point))) - - ;; Search forwards. - (save-excursion - (while (looking-at "^[ \t]*#") - (forward-line)) - (setq p-end (point))) - - ;; Narrow and do the fill. - (save-restriction - (narrow-to-region p-start p-end) - (fill-paragraph ignore))))) - t) - -(defun vrml-do-auto-fill () - "Auto-fill function for VRML mode. Only auto-fills in a comment." - (if (> (current-column) fill-column) - (let ((fill-prefix "# ") - in-comment col) - (save-excursion - (setq in-comment (vrml-in-comment)) - (if in-comment - (setq col (1- (current-column))))) - (if in-comment - (progn - (do-auto-fill) - (save-excursion - (back-to-indentation) - (delete-region (point) (save-excursion - (beginning-of-line) - (point))) - (indent-to-column col))))))) - -(defun vrml-indent-for-comment () - "Indent this line's comment to comment column, or insert an empty comment. -Is smart about syntax of VRML comments. -Parts of this were taken from indent-for-comment (simple.el)." - (interactive "*") - (end-of-line) - (or (vrml-in-comment) - (progn - ;; Not in a comment, so we have to insert one. Create an - ;; empty comment (since there isn't one on this line). - (skip-chars-backward " \t") - (let ((eolpoint (point))) - (beginning-of-line) - (if (/= (point) eolpoint) - (progn - (goto-char eolpoint) - (insert - "# ") - (backward-char)))))) - ;; Point is just after the "#" starting a comment. Move it as - ;; appropriate. - (let* ((indent (funcall comment-indent-function)) - (begpos (progn - (backward-char) - (point)))) - (if (/= begpos indent) - (progn - (skip-chars-backward " \t" (save-excursion - (beginning-of-line) - (point))) - (delete-region (point) begpos) - (indent-to indent))) - (looking-at comment-start-skip) ; Always true. - (goto-char (match-end 0)) - ;; I don't like the effect of the next two. - ;;(skip-chars-backward " \t" (match-beginning 0)) - ;;(skip-chars-backward "^ \t" (match-beginning 0)) - )) - -;;; vrml-mode.el ends here
--- a/lisp/modes/whitespace-mode.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,586 +0,0 @@ -;;; whitespace-mode.el -- minor mode for making whitespace visible - -;; Copyright (C) 1994, 1995, 1996 Heiko Muenkel - -;; Author: Heiko Muenkel <muenkel@tnt.uni-hannover.de> -;; Keywords: modes, extensions - -;; 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; if not, write to the Free Software -;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Synched up with: FSF 19.34. - -;;; Commentary: - -;; $Id: whitespace-mode.el,v 1.5 1997/09/17 05:19:29 steve Exp $ -;; Description: -;; -;; This is a minor mode, which highlights whitespaces (blanks and -;; tabs) with different faces, so that it is easier to -;; distinguish between them. -;; Toggle the mode with: M-x whitespace-mode -;; or with: M-x whitespace-incremental-mode -;; The second one should be used in big files. -;; -;; If you want to know how the whitespaces are highlighted then -;; type: M-x whitespace-show-faces -;; -;; There are 2 hook variables `whitespace-incremental-mode-hook' -;; and `whitespace-mode-hook' to customize the mode. -;; -;; Look at the variable `whitespace-chars', if you only want to -;; highlight tabs or blanks and not both. -;; -;; Set `whitespace-install-toolbar-icon' to t, if you want a -;; toolbar icon for this mode. -;; -;; Set `whitespace-install-submenu' to t, if you want a submenu -;; for this mode. Sorry, at the moment there is no menu for the -;; Emacs 19. -;; -;; Thanks to Mike Scheidler for the toolbar icon code. -;; -;; Installation: -;; -;; Put the files whitespace-mode.el and adapt.el in one of your -;; load-path directories and the following lines (without the -;; comment signs) in your .emacs (adapt.el is already in the -;; XEmacs 19.12). -;; -;; (autoload 'whitespace-mode "whitespace-mode" -;; "Toggle whitespace mode. -;; With arg, turn whitespace mode on iff arg is positive. -;; In whitespace mode the different whitespaces (tab, blank return) -;; are highlighted with different faces. The faces are: -;; `whitespace-blank-face', `whitespace-tab-face' and -;; `whitespace-return-face'." -;; t) -;; -;; (autoload 'whitespace-incremental-mode "whitespace-mode" -;; "Toggle whitespace incremental mode. -;; With arg, turn whitespace incremental mode on iff arg is positive. -;; In whitespace incremental mode the different whitespaces (tab and -;; blank) are highlighted with different faces. The faces are: -;; `whitespace-blank-face' and `whitespace-tab-face'. -;; Use the command `whitespace-show-faces' to show their values. -;; In this mode only these tabs and blanks are highlighted, which are in -;; the region from (point) - (window-heigh) to (point) + (window-heigh)." - -;;; Code: - -(provide 'whitespace-mode) -(require 'adapt) - -;;; variables: - -(defgroup whitespace nil - "Minor mode for making whitespace visible" - :group 'outlines - :group 'matching) - - -(defcustom whitespace-mode nil - "Non-nil, if the `whitespace-mode' is active." - :type 'boolean - :set (lambda (symbol value) - (whitespace-mode (or value 0))) - :require 'whitespace-mode - :initialize 'custom-initialize-default - :group 'whitespace) - -(make-variable-buffer-local 'whitespace-mode) - -(defcustom whitespace-chars 'tabs-and-blanks - "*Determines, which whitespaces are highlighted. -Valid values are: -'tabs-and-blanks => tabs and blanks are highlighted; -'tabs => only tabs are highlighted; -'blanks => only blanks are highlighted;. - -Changing this variable during the whitespace-*-mode is active could lead -to wrong highlighted whitespaces." - :type '(radio (const tabs-and-blanks) - (const tabs) - (const blanks)) - :group 'whitespace) - -(make-variable-buffer-local 'whitespace-chars) - -(defcustom whitespace-mode-hook nil - "*Run after the `whitespace-mode' is switched on." - :type 'hook - :group 'whitespace) - -(defcustom whitespace-incremental-mode-hook nil - "*Run after the `whitespace-incremental-mode' is switched on." - :type 'hook - :group 'whitespace) - - -(if (adapt-xemacsp) -(progn - -(defcustom whitespace-install-toolbar-icon nil - "Set it to t, if a toolbar icon should be installed during loading this file. -The icon calls the function 'whitespace-toolbar-function'." - :type 'boolean - :group 'whitespace) - -(defcustom whitespace-install-submenu nil - "Set it to t, if a submenu should be installed during loading this file." - :type 'boolean - :group 'whitespace) - -)) - - -(defcustom whitespace-toolbar-function 'whitespace-incremental-mode - "*The toolbar icon for the whitespace mode calls this function. -Valid values are: 'whitespace--mode and 'whitespace-incremental-mode." - :type 'function - :group 'whitespace) - -(defcustom whitespace-blank-and-tab-search-string "\\( \\)\\|\\(\t\\)" - "The regexp used to search for tabs and blanks." - :type 'regexp - :group 'whitespace) - -(defcustom whitespace-tab-search-string "\t" - "The search string used to find tabs." - :type 'string - :group 'whitespace) - -(defcustom whitespace-blank-search-string " " - "The search string used to find blanks." - :type 'string - :group 'whitespace) - -(defface whitespace-blank-face - '((t - (:background "LightBlue1"))) - "Face to show blanks with" - :group 'whitespace) - -(defface whitespace-tab-face - '((t - (:background "yellow" :underline t))) - "Face to show TABs with" - :group 'whitespace) - -(defun whitespace-show-faces () - "Shows the faces used by the `whitespace-mode'." - (interactive) - (save-excursion - (let ((actual-buffer-name (buffer-name (current-buffer))) - (actual-whitespace-chars whitespace-chars) - (whitespace-mode-active (or whitespace-mode - whitespace-incremental-mode)) - (buffer (get-buffer-create "*Help*"))) - (set-buffer buffer) - (setq whitespace-chars actual-whitespace-chars) - (delete-region (point-min) (point-max)) - (insert "In the whitespace minor mode\n" - " this \" ") - (whitespace-highlight-region (1- (point)) (point)) - (insert "\" is a blank, highlighted with `whitespace-blank-face' and\n" - " this \"\t") - (whitespace-highlight-region (1- (point)) (point)) - (insert "\" is a tab, highlighted with `whitespace-tab-face'.") - - (newline 2) - (if (eq whitespace-chars 'blanks) - (insert - "The highlighting of tabs is switched off.\n") - (if (eq whitespace-chars 'tabs) - (insert - "The highlighting of blanks is switched off.\n"))) - (newline) - (if whitespace-mode-active - (insert "A whitespace minor mode is active in the buffer\n " - actual-buffer-name - ".\n") - (insert "No whitespace minor mode is active in the buffer\n " - actual-buffer-name - ".\n")) - (show-temp-buffer-in-current-frame buffer) - ))) - -;;; -(defun whitespace-highlight-chars-in-region (char-string from to face) - "Highlights the CHAR-STRING in the region from FROM to TO with the FACE." - (while (search-forward char-string end t) - (let ((extent)) - (cond ((match-beginning 0) - (setq extent (make-extent (match-beginning 0) (match-end 0))) - (set-extent-face extent face) - )) - (set-extent-property extent 'start-open t) - (set-extent-property extent 'end-open t) - ))) - -(defun whitespace-highlight-region (from to) - "Highlights the whitespaces in the region from FROM to TO." - (let ((start (min from to)) - (end (max from to))) - (save-excursion - ;; (message "Highlighting tabs and blanks...") - (goto-char start) - (cond ((eq whitespace-chars 'tabs-and-blanks) - (while (search-forward-regexp - whitespace-blank-and-tab-search-string end t) - (let ((extent)) - (cond ((match-beginning 1) ; blanks ? - (setq extent (make-extent (match-beginning 1) - (match-end 1))) - (set-extent-face extent 'whitespace-blank-face) - ) - ((match-beginning 2) ; tabs ? - (setq extent (make-extent (match-beginning 2) - (match-end 2))) - (set-extent-face extent 'whitespace-tab-face) - ) - ) - (set-extent-property extent 'start-open t) - (set-extent-property extent 'end-open t) - ))) - ((eq whitespace-chars 'tabs) - (whitespace-highlight-chars-in-region whitespace-tab-search-string - from - to - 'whitespace-tab-face)) - ((eq whitespace-chars 'blanks) - (whitespace-highlight-chars-in-region - whitespace-blank-search-string - from - to - 'whitespace-blank-face)) - (t (error "ERROR: Bad value of whitespace-highlight-char"))) - ;; (message "") - ))) - -(defun whitespace-highlight-buffer () - "Highlights the whitespaces in the current buffer." - (whitespace-highlight-region (point-min) (point-max)) -) - -(defsubst whitespace-find-next-highlighted-region (from to) - "Returns nil or the next highlighted region." - (map-extents '(lambda (extent dummy) - (if (extent-property extent 'whitespace-highlighted-region) - extent)) - nil - from - to)) - -(defun whitespace-incremental-highlight (from to) - "Highligthts the region from FROM to TO incremental." - (save-excursion - (goto-char from) - (let ((extent (extent-at (point) nil 'whitespace-highlighted-region)) - (next-extent nil) - (start nil)) - (while (< (point) to) - (if extent - (goto-char (extent-end-position extent))) - (if (< (point) to) - (progn - (setq start (point)) - - (setq next-extent (whitespace-find-next-highlighted-region - start - to)) - (if extent - (if next-extent - (progn - (set-extent-endpoints extent - (extent-start-position extent) - (extent-end-position next-extent) - ) - (whitespace-highlight-region start - (1- - (extent-start-position - next-extent))) - (delete-extent next-extent)) - (set-extent-endpoints extent - (extent-start-position extent) - to) - (whitespace-highlight-region start to)) - (if next-extent - (progn - (setq extent next-extent) - (whitespace-highlight-region start - (1- (extent-start-position - next-extent))) - (set-extent-endpoints extent - start - (extent-end-position next-extent))) - (setq extent (make-extent start to)) - (set-extent-property extent 'whitespace-highlighted-region t) - (whitespace-highlight-region start to))) - )))))) - - -(defun whitespace-highlight-window () - "Highlights the whitespaces in the current window." - (whitespace-incremental-highlight (save-excursion - (forward-line (- (window-height))) - (point)) - (save-excursion - (forward-line (window-height)) - (point)))) - -(defun whitespace-dehighlight-region (start end) - "Dehighlights the whitespaces in the region from START to END." - (map-extents '(lambda (extent dummy) - (if (or (eq (extent-face extent) 'whitespace-blank-face) - (eq (extent-face extent) 'whitespace-tab-face) - (extent-property extent - 'whitespace-highlighted-region)) - (progn - (delete-extent extent) - nil))) - nil - start - end - ) - ) - -(defun whitespace-dehighlight-buffer () - "Dehighlights the whitespaces in the current buffer." - (whitespace-dehighlight-region (point-min) (point-max)) - ) - -(defun whitespace-highlight-after-change-function (beg end old-len) - "Called, when any modification is made to buffer text. Highlights -the whitespaces (blanks and tabs) in the region from BEG to -END. OLD-LEN isn't used, but provided from the after-change hook." - (if (or (eq beg end) - (null whitespace-mode)) - nil - (whitespace-dehighlight-region beg end) - (whitespace-highlight-region beg end))) - -(defun whitespace-mode (&optional arg) - "Toggle whitespace mode. -With arg, turn whitespace mode on iff arg is positive. -In whitespace mode the different whitespaces (tab and blank) -are highlighted with different faces. The faces are: -`whitespace-blank-face' and `whitespace-tab-face'. -Use the command `whitespace-show-faces' to show their values." - (interactive "P") - (setq whitespace-mode - (if (null arg) (not whitespace-mode) - (> (prefix-numeric-value arg) 0))) - (if (and whitespace-mode whitespace-incremental-mode) - (progn - (whitespace-incremental-highlight (point-min) (point-max)) - (setq whitespace-incremental-mode nil) - (remove-hook 'post-command-hook 'whitespace-highlight-window) - (run-hooks 'whitespace-mode-hook) - ) - (setq whitespace-incremental-mode nil) - (remove-hook 'post-command-hook 'whitespace-highlight-window) - (redraw-modeline) ;(force-mode-line-update) - (if whitespace-mode - (progn - (whitespace-highlight-buffer) - (make-local-variable 'after-change-functions) - (add-hook 'after-change-functions - 'whitespace-highlight-after-change-function) - (run-hooks 'whitespace-mode-hook)) - (whitespace-dehighlight-buffer) - (remove-hook 'after-change-functions - 'whitespace-highlight-after-change-function) - (remove-hook 'post-command-hook 'whitespace-highlight-window) - ))) - -(defvar whitespace-incremental-mode nil - "Non-nil, if the `whitespace-incremental-mode' is active.") - -(make-variable-buffer-local 'whitespace-incremental-mode) - -(defun whitespace-incremental-mode (&optional arg) - "Toggle whitespace incremental mode. -With arg, turn whitespace incremental mode on iff arg is positive. -In whitespace incremental mode the different whitespaces (tab and blank) -are highlighted with different faces. The faces are: -`whitespace-blank-face' and `whitespace-tab-face'. -Use the command `whitespace-show-faces' to show their values. -In this mode only these tabs and blanks are highlighted, which are in -the region from (point) - (window-heigh) to (point) + (window-heigh)." - (interactive "P") - (setq whitespace-incremental-mode - (if (null arg) (not whitespace-incremental-mode) - (> (prefix-numeric-value arg) 0))) - (if (and whitespace-mode whitespace-incremental-mode) - (set-extent-property (make-extent (point-min) (point-max)) - 'whitespace-highlighted-region - t)) - (setq whitespace-mode nil) - (redraw-modeline) ;(force-mode-line-update) - ;(set-buffer-modified-p (buffer-modified-p)) ;No-op, but updates mode line. - (if whitespace-incremental-mode - (progn - (whitespace-highlight-window) - (make-local-variable 'post-command-hook) - (add-hook 'post-command-hook 'whitespace-highlight-window) - (make-local-variable 'after-change-functions) - (add-hook 'after-change-functions - 'whitespace-highlight-after-change-function) - (run-hooks 'whitespace-incremental-mode-hook)) - (whitespace-dehighlight-buffer) - (remove-hook 'after-change-functions - 'whitespace-highlight-after-change-function) - (remove-hook 'post-command-hook 'whitespace-highlight-window) - )) - - -;;; Add whitespace-mode and whitespace-incremental-mode to the minor-mode-alist - -(or (assq 'whitespace-mode minor-mode-alist) - (setq minor-mode-alist - (cons '(whitespace-mode " WSP") minor-mode-alist))) - -(or (assq 'whitespace-incremental-mode minor-mode-alist) - (setq minor-mode-alist - (cons '(whitespace-incremental-mode " WSPI") minor-mode-alist))) - - -;;; Menu for the whitespace mode - -(defun whitespace-set-whitespace-chars (new-whitespace-chars) - "Sets the variable `whitespace-chars' and activates the change." - (interactive (list (read (completing-read "Whitespaces to highlight: " - '(("tabs-and-blanks") - ("tabs") - ("blanks")) - nil - t - (symbol-name 'whitespace-chars))))) - (if (eq whitespace-chars new-whitespace-chars) - nil ; nothing to do - (setq whitespace-chars new-whitespace-chars) - (setq-default whitespace-chars new-whitespace-chars) - (cond (whitespace-mode (whitespace-mode) - (whitespace-mode)) - (whitespace-incremental-mode (whitespace-incremental-mode) - (whitespace-incremental-mode)) - ))) - -(defvar whitespace-menu nil - "A menu for the whitespace minor mode.") - -(setq whitespace-menu - '("Whitespace Menu" - ["Highlight Whitespaces" - whitespace-mode - :style toggle - :selected whitespace-mode] - ["Incremental Highlighting" - whitespace-incremental-mode - :style toggle - :selected whitespace-incremental-mode - ] - "---" - ["Show Whitespace Faces" whitespace-show-faces t] - "---" - ["Highlight Tabs & Blanks" - (whitespace-set-whitespace-chars 'tabs-and-blanks) - :style radio - :selected (eq whitespace-chars 'tabs-and-blanks)] - ["Highlight Only Tabs" - (whitespace-set-whitespace-chars 'tabs) - :style radio - :selected (eq whitespace-chars 'tabs)] - ["Highlight Only Blanks" - (whitespace-set-whitespace-chars 'blanks) - :style radio - :selected (eq whitespace-chars 'blanks)] - )) - -(if (and (boundp 'whitespace-install-submenu) whitespace-install-submenu) - (add-submenu '("Apps") whitespace-menu)) - -;;; Toolbar icon for the XEmacs - -(if (featurep 'toolbar) - -(defvar toolbar-wspace-icon - (toolbar-make-button-list - "/* XPM */ -static char * whitespace[] = { -\"28 28 4 1\", -\" c Gray75 s backgroundToolBarColor\", -\". c black\", -\"X c Gray60\", -\"o c white\", -\" \", -\" \", -\" \", -\" \", -\" .. . \", -\" XXX.XXXXXX . \", -\" Xoo.oooooXX . \", -\" .. .. ..o.o..oo..X... .. \", -\" . . X.o..o.ooX. X. . . \", -\" . . .oo.oo.ooX.XX. .... \", -\" ... .oo.oo.ooo.oo. . \", -\" . .Xoo.oo.ooo.oo. . . \", -\" . .Xo...o..o...o.. .. \", -\" XooooooooooooX \", -\" XooooooooooooX \", -\" .... ....ooo...ooo... .. \", -\" . . .oo.o.oo.oo.oX. . . \", -\" . .oo.ooo..oo.oX .... \", -\" .. .oo.o..o.oo.oX . \", -\" . . .oo.o.oo.oo.oX. . . \", -\" .... ...oo.....oo.. .. \", -\" .ooooooooooooX \", -\" .XXXXXXXXXXXXX \", -\" . \", -\" ... \", -\" \", -\" \", -\" \" -};") - "A whitespace icon.") -) - -(defun whitespace-toolbar-function () - "Calls the function determined by `whitespace-toolbar-function'." - (interactive) - (call-interactively whitespace-toolbar-function)) - -(if (and (adapt-xemacsp) - whitespace-install-toolbar-icon - (featurep 'toolbar) - (eq (device-type (selected-device)) 'x)) - (let ((tb (mapcar #'(lambda (e) - (elt e 1)) (specifier-instance default-toolbar)))) - (and (not (member 'whitespace-toolbar-function tb)) - (toolbar-add-item - [toolbar-wspace-icon whitespace-toolbar-function - t "Toggle whitespace mode"] - (let ((n (or - (position 'toolbar-replace tb) - (position 'toolbar-undo tb) - (position 'toolbar-paste tb) - (position 'toolbar-copy tb) - (position 'toolbar-cut tb)))) - (if n (1+ n) (length tb))))))) - -;;; whitespace-mode.el ends here
--- a/lisp/modes/winmgr-mode.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,170 +0,0 @@ -;;; winmgr-mode.el --- generic window manager mode - -;; Author: ??? -;; Maintainer: David Konerding (rafael@cse.ucsc.edu) -;; Modifications by: Stefan Strobel <strobel@lia.univ-savoie.fr> -;; Barry A. Warsaw <bwarsaw@python.org> -;; Created: ??? -;; Keywords: languages - -;; Copyright (C) 199? Someone Claim It - -;; 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 of the License, 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; 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: - -;; This package is a major mode for editing window configuration files and -;; also defines font-lock keywords for such files. - -;; winmgr-mode mode will automatically get turned on if you visit a -;; a file whose name looks like that of a configuration file -;; (IE, .fvwmrc, .mwmrc, .tvtwmrc, etc) - -;; The current font-lock keywords are: - -;; any word of upper or lower case letters at the start of a line -;; followed by whitespace gets colored using -;; font-lock-function-name-face. - -;; any word of upper or lower case letters at the start of a line -;; followed by a "(" (IE, an m4 macro) gets colored using -;; font-lock-comment-face - -;; Put this in your .emacs : -;; -;;(setq auto-mode-alist -;; (append '(("\\.[A-Za-z]*wm$" . winmgr-mode) -;; ("\\.[A-Za-z]*wmrc" . winmgr-mode) -;; auto-mode-alist)) -;; -;;(autoload 'winmgr-mode "winmgr-mode" -;; "Mode for editing window manager config files") -;; -;;(add-hook 'winmgr-mode-hook -;; '(lambda () -;; (font-lock-mode t) -;; (setq font-lock-keywords winmgr-font-lock-keywords) -;; (font-lock-fontify-buffer))) -;; - - -;;; Code: - -(defgroup winmgr nil - "Generic window manager mode." - :tag "Window Managers" - :group 'languages) - - -(defcustom winmgr-basic-offset 4 - "*Number of spaces per indentation level." - :type 'integer - :group 'winmgr) - -(defcustom winmgr-mode-hook nil - "Hook to be run when `winmgr-mode' is entered." - :type 'hook - :group 'winmgr) - - -(defface font-lock-m4-face - '((((class color)) - (:foreground "blue")) - (t - (:underline t))) - "Font-lock face for M4 macros." - :group 'winmgr) - -(defvar winmgr-font-lock-keywords - '(("^[A-Za-z]+[ \n\t]" . font-lock-function-name-face) - ;;("^#.*" . font-lock-comment-face) - ("^[A-Za-z]+(.*)" . font-lock-m4-face)) - "Default font-lock keywords.") - - -;; major-mode stuff -(defvar winmgr-mode-abbrev-table nil - "Abbrev table used in `winmgr-mode' buffers.") -(define-abbrev-table 'winmgr-mode-abbrev-table ()) - - -(defvar winmgr-mode-syntax-table nil - "Syntax table used in `winmgr-mode' buffers.") -(if winmgr-mode-syntax-table - () - (setq winmgr-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?\# "<" winmgr-mode-syntax-table) - (modify-syntax-entry ?\n ">" winmgr-mode-syntax-table)) - - -(defvar winmgr-mode-map () - "Keymap used in `winmgr-mode' buffers.") -(if winmgr-mode-map - () - (setq winmgr-mode-map (make-sparse-keymap)) - ;; So far there aren't any winmgr-mode specific functions - ) - - -;;;###autoload -(defun winmgr-mode () - "Major mode for editing winmgr config files." - (interactive) - (kill-all-local-variables) - (set-syntax-table winmgr-mode-syntax-table) - (setq major-mode 'winmgr-mode - mode-name "Winmgr" - local-abbrev-table winmgr-mode-abbrev-table) - (use-local-map winmgr-mode-map) - ;; local variables - (make-local-variable 'parse-sexp-ignore-comments) - (make-local-variable 'comment-start) - (make-local-variable 'comment-end) - (make-local-variable 'indent-line-function) - ;; now set their values - (setq parse-sexp-ignore-comments t - comment-start "# " - comment-end "" - indent-line-function 'winmgr-indent-line-function) - (run-hooks 'winmgr-mode-hook)) - - -;; indentation commands - -(defun winmgr-indent-line-function () - "Indent line based on depth in parentheses. -See the variable `winmgr-basic-offset.'" - ;; find the beginning of this construct - (let ((depth 0) - (here (point))) - (condition-case nil - (while t - (backward-up-list 1) - (setq depth (1+ depth))) - (error nil)) - (goto-char here) - (beginning-of-line) - (delete-horizontal-space) - (insert-char ?\040 (* depth winmgr-basic-offset)))) - - -(provide 'winmgr-mode) - -;;; winmgr-mode.el ends here
--- a/lisp/modes/xpm-mode.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,454 +0,0 @@ -;;; xpm-mode.el --- minor mode for editing XPM files - -;; Copyright (C) 1995 Joe Rumsey <ogre@netcom.com> -;; Copyright (C) 1995 Rich Williams <rdw@hplb.hpl.hp.com> - -;; Authors: Joe Rumsey <ogre@netcom.com> -;; Rich Williams <rdw@hplb.hpl.hp.com> -;; Cleanup: Chuck Thompson <cthomp@cs.uiuc.edu> - -;; Version: 1.5 -;; Last Modified: Rich Williams <rdw@hplb.hpl.hp.com>, 13 July 1995 -;; Keywords: data tools - -;; 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. - -;; -;; xpm mode: Display xpm files in color -;; -;; thanks to Rich Williams for mods to do this without font-lock-mode, -;; resulting in much improved performance and a better display -;; (headers don't get colored strangely). Also for the palette toolbar. -;; -;; Non-standard minor mode in that it starts picture-mode automatically. -;; -;; To get this turned on automatically for .xpms, add an entry -;; ("\\.xpm" . xpm-mode) -;; to your auto-mode-alist. For example, my .emacs has this: (abbreviated) -;; (setq auto-mode-alist (mapcar 'purecopy -;; '(("\\.c$" . c-mode) -;; ("\\.h$" . c-mode) -;; ("\\.el$" . emacs-lisp-mode) -;; ("\\.emacs$" . emacs-lisp-mode) -;; ("\\.a$" . c-mode) -;; ("\\.xpm" . xpm-mode)))) -;; (autoload 'xpm-mode "xpm-mode") -;; -;; I am a lisp newbie, practically everything in here I had to look up -;; in the manual. It probably shows, suggestions for coding -;; improvements are welcomed. -;; -;; May fail on some xpm's. Seems to be fine with files generated by -;; xpaint and ppmtoxpm anyway. Will definitely fail on xpm's with -;; more than one character per pixel. Not that hard to fix, but I've -;; never seen one like that. -;; -;; If your default font is proportional, this will not be very useful. -;; - -(require 'annotations) - -(defvar xpm-pixel-values nil) -(defvar xpm-glyph nil) -(defvar xpm-anno nil) -(defvar xpm-paint-string nil) -(defvar xpm-chars-per-pixel 1) -(defvar xpm-palette nil) -(defvar xpm-always-update-image nil - "If non-nil, update actual-size image after every click or drag movement. -Otherwise, only update on button releases or when asked to. This is slow.") - -(make-variable-buffer-local 'xpm-palette) -(make-variable-buffer-local 'xpm-chars-per-pixel) -(make-variable-buffer-local 'xpm-paint-string) -(make-variable-buffer-local 'xpm-glyph) -(make-variable-buffer-local 'xpm-anno) -(make-variable-buffer-local 'xpm-pixel-values) -;(make-variable-buffer-local 'xpm-faces-used) - -(defun xpm-make-face (name) - "Makes a face with name xpm-NAME, and colour NAME." - (let ((face (make-face (intern (concat "xpm-" name)) - "Temporary xpm-mode face" t))) - (set-face-background face name) - (set-face-foreground face "black") - face)) - -(defun xpm-init () - "Treat the current buffer as an xpm file and colorize it." - (interactive) - (require 'picture) - - (setq xpm-pixel-values nil) - (xpm-clear-extents) - (setq xpm-palette nil) - - (message "Finding number of colors...") - (save-excursion - (goto-char (point-min)) - (beginning-of-line) - (next-line 1) - (while (not (looking-at "\\s-*\"")) - (next-line 1)) - (next-line 1) - (while (not (looking-at "\\s-*\"")) - (next-line 1)) - - (save-excursion - (goto-char (point-min)) - (if (re-search-forward - "\"\\s-*\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-*" - (point-max) t) - (setq xpm-chars-per-pixel (string-to-int (match-string 4))))) - - (let ((co 0)) - (while (< co (xpm-num-colors)) - (progn - (xpm-parse-color) - (setq co (1+ co)) - (next-line 1) - (beginning-of-line))))) - (if (not (eq major-mode 'picture-mode)) - (picture-mode)) - (if (featurep 'toolbar) - (progn - (set-specifier left-toolbar-width (cons (selected-frame) 16)) - (set-specifier left-toolbar (cons (current-buffer) xpm-palette)))) - (message "Parsing body...") - (xpm-color-data) - (message "Parsing body...done") - (xpm-show-image)) - -(defun xpm-clear-extents () - (let (cur-extent - next-extent) - (setq cur-extent (next-extent (current-buffer))) - (setq next-extent (next-extent cur-extent)) - (while cur-extent - (delete-extent cur-extent) - (setq cur-extent next-extent) - (setq next-extent (next-extent cur-extent))))) - -(defun xpm-color-data () - (interactive) - (save-excursion - (xpm-goto-body-line 0) - (let (ext - pixel-chars - pixel-color) - (while (and (< (point) (point-max)) - (< (+ (point) xpm-chars-per-pixel) (point-max))) - (setq pixel-chars - (buffer-substring (point) (+ (point) xpm-chars-per-pixel)) - pixel-color (assoc pixel-chars xpm-pixel-values) - ext (make-extent (point) (+ (point) xpm-chars-per-pixel))) - (if pixel-color - (progn - (set-extent-face ext (cdr pixel-color))) - (set-extent-face ext 'default)) - (forward-char xpm-chars-per-pixel))))) - -(defun xpm-num-colors () - (save-excursion - (goto-char (point-min)) - (if (re-search-forward - "\"\\s-*\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-*" - (point-max) t) - (string-to-int (match-string 3)) - (error "Unable to parse xpm information")))) - -(defun xpm-make-solid-pixmap (colour width height) - (let ((x 0) - (y 0) - (line nil) - (total nil)) - (setq line ",\n\"") - (while (< x width) - (setq line (concat line ".") - x (+ x 1))) - (setq line (concat line "\"") - total (format "/* XPM */\nstatic char * %s[] = {\n\"%d %d 1 1\",\n\". c %s\"" - colour width height colour)) - (while (< y height) - (setq total (concat total line) - y (+ y 1))) - (make-glyph (concat total "};\n")))) - -(defun xpm-store-color (str color) - "Add STR to xpm-pixel-values with a new face set to background COLOR -if STR already has an entry, the existing face will be used, with the -new color replacing the old (on the display only, not in the xpm color -defs!)" - (let (new-face) - (setq new-face (xpm-make-face color)) - (set-face-background new-face color) - (let ((ccc (color-rgb-components (make-color-specifier color)))) - (if (> (length ccc) 0) - (if (or (or (> (elt ccc 0) 32767) - (> (elt ccc 1) 32767)) - (> (elt ccc 2) 32767)) - (set-face-foreground new-face "black") - (set-face-foreground new-face "white")))) - (setq xpm-pixel-values (cons (cons str new-face) xpm-pixel-values)) - (if (featurep 'toolbar) - (setq xpm-palette - (cons (vector - (list (xpm-make-solid-pixmap color 12 12)) - ;; Major cool things with quotes..... - (` - (lambda (event) - (interactive "e") - (xpm-toolbar-select-colour event (, str)))) - t - color) xpm-palette))) - )) - -(defun xpm-parse-color () - "Parse xpm color string from current line and set the color" - (interactive) - (let (end) - (save-excursion - (end-of-line) - (setq end (point)) - (beginning-of-line) - (if (re-search-forward - ;; Generate a regexp on the fly - (concat "\"\\(" (make-string xpm-chars-per-pixel ?.) "\\)" ; chars - "\\s-+\\([c]\\)" ; there are more classes than 'c' - "\\s-+\\([^\"]+\\)\"") - end t) - (progn - (xpm-store-color (match-string 1) (match-string 3)) - (list (match-string 1) (match-string 3))) - (error "Unable to parse color"))))) - -(defun xpm-add-color (str color) - "add a color to an xpm's list of color defs" - (interactive "sPixel character: -sPixel color (any valid X color string):") - (save-excursion - (goto-char (point-min)) - (while (not (looking-at "\\s-*\"")) - (next-line 1)) - (next-line 1) - (while (not (looking-at "\\s-*\"")) - (next-line 1)) - (let ((co 0)) - (while (< co (xpm-num-colors)) - (next-line 1) - (setq co (1+ co)))) - (insert (format "\"%s\tc %s\",\n" str color)) - (previous-line 1) - (xpm-parse-color) - - (goto-char (point-min)) - (while (not (looking-at "\\s-*\"")) - (next-line 1)) - (let ((entry 0)) - (while (or (= (char-after (point)) ? ) (= (char-after (point)) ?\")) - (forward-char 1)) - (while (< entry 2) - (progn - (if (eq (char-after (point)) ? ) - (progn - (setq entry (1+ entry)) - (while (eq (char-after (point)) ? ) - (forward-char 1))) - (forward-char 1)))) - (let ((old-colors (xpm-num-colors))) - (while (and (>= (char-after (point)) ?0) (<= (char-after (point)) ?9)) - (delete-char 1)) - (insert (int-to-string (1+ old-colors))))))) - - -(defun xpm-goto-color-def (def) - "move to color DEF in the xpm header" - (interactive "nColor number:") - (goto-char (point-min)) - (while (not (looking-at "\\s-*\"")) - (next-line 1)) - (next-line 1) - (while (not (looking-at "\\s-*\"")) - (next-line 1)) - (next-line def)) - -(defun xpm-goto-body-line (line) - "move to LINE lines down from the start of the body of an xpm" - (interactive "nBody line:") - (goto-char (point-min)) - (xpm-goto-color-def (xpm-num-colors)) - (next-line line)) - -(defun xpm-show-image () - "Display the xpm in the current buffer at the end of the topmost line" - (interactive) - (save-excursion - (if (annotationp xpm-anno) - (delete-annotation xpm-anno)) - (setq xpm-glyph (make-glyph - (vector 'xpm :data - (buffer-substring (point-min) (point-max))))) - (goto-char (point-min)) - (end-of-line) - (setq xpm-anno (make-annotation xpm-glyph (point) 'text)))) - -(defun xpm-hide-image () - "Remove the image of the xpm from the buffer" - (interactive) - (if (annotationp xpm-anno) - (delete-annotation xpm-anno))) - -(defun xpm-in-body () - (let ((p (point))) - (save-excursion - (xpm-goto-body-line 0) - (> p (point))))) - -(defvar xpm-mode nil) -(make-variable-buffer-local 'xpm-mode) -(add-minor-mode 'xpm-mode " XPM" nil) -(defvar xpm-mode-map (make-keymap)) - -(defun xpm-toolbar-select-colour (event chars) - "Toolbar button" - (let* ((button (event-toolbar-button event)) - (help (toolbar-button-help-string button))) - (message "Toolbar selected %s (%s)" help chars) - (setq xpm-palette - (mapcar #'(lambda (but) - (aset but 2 (not (eq help (aref but 3)))) - but) - xpm-palette) - xpm-paint-string chars) - (set-specifier left-toolbar (cons (current-buffer) xpm-palette)))) - -(defun xpm-mouse-paint (event) - (interactive "e") - (mouse-set-point event) - (if (xpm-in-body) - ;; in body, overwrite the paint string where the mouse is clicked - (progn - (insert xpm-paint-string) - (delete-char (length xpm-paint-string))) - ;; otherwise, select the color defined by the line where the mouse - ;; was clicked - (save-excursion - (beginning-of-line) - (forward-char 1) - (setq xpm-paint-string (buffer-substring (point) (1+ (point))))))) - -(defun xpm-mouse-down (event n) -; (interactive "ep") - (mouse-set-point event) - (if (xpm-in-body) - ;; in body, overwrite the paint string where the mouse is clicked - (progn - (insert xpm-paint-string) - (delete-char (length xpm-paint-string)) - (if xpm-always-update-image - (xpm-show-image)) - (let ((ext (make-extent (1- (point)) - (+ (1- (point)) xpm-chars-per-pixel))) - (pixel-color (assoc xpm-paint-string xpm-pixel-values))) - (if pixel-color - (set-extent-face ext (cdr pixel-color)) - (set-extent-face ext 'default)))) - ;; otherwise, select the color defined by the line where the mouse - ;; was clicked - (save-excursion - (beginning-of-line) - (forward-char 1) - (setq xpm-paint-string (buffer-substring (point) (1+ (point))))))) - -(defun xpm-mouse-drag (event n timeout) - (or timeout - (progn - (mouse-set-point event) - (if (xpm-in-body) - ;; Much improved by not using font-lock-mode - (or (string= xpm-paint-string - (buffer-substring (point) - (+ (length xpm-paint-string) - (point)))) - (progn - (insert-char (string-to-char xpm-paint-string) 1) - ; (insert xpm-paint-string) - (delete-char (length xpm-paint-string)) - (if xpm-always-update-image - (xpm-show-image)) - (let ((ext (make-extent - (1- (point)) - (+ (1- (point)) xpm-chars-per-pixel))) - (pixel-color - (assoc xpm-paint-string xpm-pixel-values))) - (if pixel-color - (set-extent-face ext (cdr pixel-color)) - (set-extent-face ext 'default))))))))) - -(defun xpm-mouse-up (event n) - (xpm-show-image)) - -;;;###autoload -(defun xpm-mode (&optional arg) - "Treat the current buffer as an xpm file and colorize it. - - Shift-button-1 lets you paint by dragging the mouse. Shift-button-1 on a -color definition line will change the current painting color to that line's -value. - - Characters inserted from the keyboard will NOT be colored properly yet. -Use the mouse, or do xpm-init (\\[xpm-init]) after making changes. - -\\[xpm-add-color] Add a new color, prompting for character and value -\\[xpm-show-image] show the current image at the top of the buffer -\\[xpm-parse-color] parse the current line's color definition and add - it to the color table. Provided as a means of changing colors. -XPM minor mode bindings: -\\{xpm-mode-map}" - - (interactive "P") - (setq xpm-mode - (if (null arg) (not xpm-mode) - (> (prefix-numeric-value arg) 0))) - (if xpm-mode - (progn - (xpm-init) - (make-local-variable 'mouse-track-down-hook) - (make-local-variable 'mouse-track-drag-hook) - (make-local-variable 'mouse-track-up-hook) - (make-local-variable 'mouse-track-drag-up-hook) - (make-local-variable 'mouse-track-click-hook) - (setq mouse-track-down-hook 'xpm-mouse-down) - (setq mouse-track-drag-hook 'xpm-mouse-drag) - (setq mouse-track-up-hook 'xpm-mouse-up) - (setq mouse-track-drag-up-hook 'xpm-mouse-up) - (setq mouse-track-click-hook nil) - (or (assq 'xpm-mode minor-mode-map-alist) - (progn - (define-key xpm-mode-map [(control c) r] 'xpm-show-image) - (define-key xpm-mode-map [(shift button1)] 'mouse-track) - (define-key xpm-mode-map [button1] 'mouse-track-default) - (define-key xpm-mode-map [(control c) c] 'xpm-add-color) - (define-key xpm-mode-map [(control c) p] 'xpm-parse-color) - (setq minor-mode-map-alist (cons (cons 'xpm-mode xpm-mode-map) - minor-mode-map-alist))))))) - -(provide 'xpm-mode) -;;; xpm-mode.el ends here
--- a/lisp/modes/xrdb-mode.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,444 +0,0 @@ -;;; xrdb-mode.el --- mode for editing X resource database files - -;; Author: 1994-1997 Barry A. Warsaw -;; Maintainer: tools-help@python.org -;; Created: May 1994 -;; Version: 1.21 -;; Last Modified: 1997/02/24 03:34:56 -;; Keywords: data languages - -;; Copyright (C) 1994 Barry A. Warsaw - -;; This file is not part of GNU Emacs. - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2 of the License, or -;; (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, write to the Free Software -;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: -;; -;; In 1994 I wrote: -;; -;; "I used to be like you. I used to hack on X resource database files -;; all the time, and when I did, I found this mode to be fairly -;; useful. It's by no means perfect. At one time I had a collection -;; of hacks that did some nice indentation of resource lines, but -;; they were not organized in any way. This mode was my attempt to -;; congeal this mess into a proper major mode. I release it now, not -;; because it will change your life, but because I don't plan to do -;; anything more with it. -;; -;; I have since been enlightened and no longer have to cavort with -;; mere mortal X hackers anymore. I like my brain cells, so now I -;; use NEXTSTEP where all is glory. Or would you say I traded one -;; vice for another? Hmm... Anyway, if you are still down in the -;; trenches and would like to inherit this file, let me know. I -;; don't intend to do any work on it any more... unless I lose my -;; place in paradise. I promise to be good, Steve. :-) :-)" -;; -;; I have fallen from grace and have been kicked out of paradise. So -;; has Steve Jobs apparently :-) -;; -;; To use, put the following in your .emacs: -;; -;; (autoload 'xrdb-mode "xrdb-mode" "Mode for editing X resource files" t) -;; -;; You may also want something like: -;; -;; (setq auto-mode-alist -;; (append '(("\\.Xdefaults$" . xrdb-mode) -;; ("\\.Xenvironment$" . xrdb-mode) -;; ("\\.Xresources$" . xrdb-mode) -;; ) -;; auto-mode-alist)) - - -;; Code: - - -;; These variables are available for your customization -(defgroup xrdb nil - "Mode for editing X resource database files." - :group 'data - :group 'languages) - -(defcustom xrdb-mode-hook nil - "*Hook to be run when `xrdb-mode' is entered." - :type 'hook - :group 'xrdb) - -(defcustom xrdb-subdivide-by 'paragraph - "*Extent of alignment calculations. -Can be one of `buffer', `paragraph', `page', or `line'. Do a -\\[describe-function] xrdb-indent-buffer RET for more information." - :type '(radio (const buffer) (const paragraph) - (const page) (const line)) - :group 'xrdb) - - - -;; no need to customize anything below this line -(defconst xrdb-comment-re "^[ \t]*[!]" - "Character which starts a comment.") -(defconst xrdb-separator-char ?: - "Character which separates resource specs from values.") - - -;; utilities -(defsubst xrdb-point (position) - ;; Returns the value of point at certain commonly referenced POSITIONs. - ;; POSITION can be one of the following symbols: - ;; - ;; bol -- beginning of line - ;; eol -- end of line - ;; bod -- beginning of defun - ;; boi -- back to indentation - ;; ionl -- indentation of next line - ;; iopl -- indentation of previous line - ;; bonl -- beginning of next line - ;; bopl -- beginning of previous line - ;; bop -- beginning of paragraph - ;; eop -- end of paragraph - ;; bopg -- beginning of page - ;; eopg -- end of page - ;; - ;; This function does not modify point or mark. - (let ((here (point))) - (cond - ((eq position 'bol) (beginning-of-line)) - ((eq position 'eol) (end-of-line)) - ((eq position 'boi) (back-to-indentation)) - ((eq position 'bonl) (forward-line 1)) - ((eq position 'bopl) (forward-line -1)) - ((eq position 'bop) (forward-paragraph -1)) - ((eq position 'eop) (forward-paragraph 1)) - ((eq position 'bopg) (forward-page -1)) - ((eq position 'eopg) (forward-page 1)) - (t - (error "unknown buffer position requested: %s" position))) - (prog1 - (point) - (goto-char here)) - )) - -(defsubst xrdb-skip-to-separator () - ;; skip forward from the beginning of the line to the separator - ;; character as given by xrdb-separator-char. Returns t if the - ;; char was found, otherwise, nil. - (beginning-of-line) - (skip-chars-forward - (concat "^" (char-to-string xrdb-separator-char)) - (xrdb-point 'eol)) - (= (following-char) xrdb-separator-char)) - - - -;; commands -(defun xrdb-electric-separator (arg) - "Insert the separator character. -Re-align the line unless an argument is given." - (interactive "P") - ;; first insert the character - (self-insert-command (prefix-numeric-value arg)) - ;; only do electric behavior if arg is not given - (if (not arg) - (xrdb-align-to (xrdb-point 'bol) - (xrdb-point 'bonl) - (save-excursion - (beginning-of-line) - (forward-comment (- (point-max))) - (beginning-of-line) - (xrdb-skip-to-separator) - (current-column))))) - -(defun xrdb-align-to (start end goalcolumn) - (interactive "r\nnAlign to column: ") - (save-excursion - (save-restriction - (narrow-to-region start end) - (beginning-of-buffer) - (while (< (point) (point-max)) - (if (and (not (looking-at xrdb-comment-re)) - (xrdb-skip-to-separator) - goalcolumn) - (indent-code-rigidly (xrdb-point 'bol) - (xrdb-point 'bonl) - (- goalcolumn (current-column)))) - (forward-line 1))))) - -(defun xrdb-indent-line (arg) - "Re-align current line." - (interactive "P") - ;; narrow to the region specified by xrdb-subdivide-by - (save-excursion - (save-restriction - (widen) - (cond - ((eq xrdb-subdivide-by 'buffer)) - ((eq xrdb-subdivide-by 'page) - (narrow-to-page)) - ((eq xrdb-subdivide-by 'paragraph) - (narrow-to-region (xrdb-point 'bop) (xrdb-point 'eop))) - (t - (narrow-to-region (xrdb-point 'bopl) (xrdb-point 'bonl)) - )) - ;; indent line - (xrdb-align-to (xrdb-point 'bol) (xrdb-point 'bonl) - (xrdb-region-goal-column)) - ))) - -(defun xrdb-indent-region (start end) - "Re-align region." - (interactive "r") - ;; narrow to region - (save-excursion - (save-restriction - (narrow-to-region start end) - (xrdb-align-to (point-min) (point-max) (xrdb-region-goal-column)) - ))) - -(defun xrdb-indent-page () - "Re-align the current page." - (interactive) - (save-excursion - (save-restriction - (narrow-to-page) - (xrdb-align-to (point-min) (point-max) (xrdb-region-goal-column)) - ))) - -(defun xrdb-indent-paragraph () - "Re-align the current paragraph." - (interactive) - (save-excursion - (save-restriction - (narrow-to-region (xrdb-point 'bop) (xrdb-point 'eop)) - (xrdb-align-to (point-min) (point-max) (xrdb-region-goal-column)) - ))) - -(defun xrdb-indent-buffer (arg) - "Re-align the entire buffer. -Alignment calculations are controlled by the variable -`xrdb-subdivide-by', which can take the values `buffer', `paragraph', -`page', or `line', with the following meanings: - - buffer - all non-comment lines are aligned with the longest line in - the buffer. Since every line must be scanned, this will - take the longest to perform. - - paragraph - alignment of lines spanning paragraphs. A paragraph is - defined as all contiguous lines between blank or comment - lines. - - page - alignment of lines spanning pages (i.e. separated by - page-delimiter, usually ^L). - - none - alignment of lines based on the previous line. - -With optional \\[universal-argument], queries for alignment subdivision." - (interactive "P") - (let ((align-by (if (not arg) - xrdb-subdivide-by - (completing-read - "Align by: " - '(("buffer" . buffer) - ("paragraph" . paragraph) - ("page" . page) - ("line" . line)) - nil t (format "%s" xrdb-subdivide-by))))) - (message "Aligning by %s..." align-by) - (save-excursion - (save-restriction - (widen) - (cond - ;; by buffer - ((eq align-by 'buffer) - (xrdb-align-to (point-min) (point-max) (xrdb-region-goal-column))) - ;; by paragraph - ((eq align-by 'paragraph) - (beginning-of-buffer) - (while (< (point) (point-max)) - (narrow-to-region (point) (xrdb-point 'eop)) - (xrdb-align-to (point-min) (point-max) (xrdb-region-goal-column)) - (beginning-of-buffer) - (widen) - (forward-paragraph 1) - )) - ;; by page - ((eq align-by 'page) - (beginning-of-buffer) - (while (< (point) (point-max)) - (narrow-to-region (point) (xrdb-point 'eopg)) - (xrdb-align-to (point-min) (point-max) (xrdb-region-goal-column)) - (beginning-of-buffer) - (widen) - (forward-page 1) - )) - ;; by line - (t - (beginning-of-buffer) - (let ((prev-goalcol 0)) - (while (< (point) (point-max)) - ;; skip comments and blank lines - (if (not (looking-at paragraph-start)) - (progn - (xrdb-align-to (xrdb-point 'bol) (xrdb-point 'bonl) - prev-goalcol) - (xrdb-skip-to-separator) - (setq prev-goalcol (- (point) (xrdb-point 'boi))) - )) - (forward-line 1)))) - ))) - (message "Aligning by %s... done." align-by) - )) - - -;; major-mode stuff -(defvar xrdb-mode-abbrev-table nil - "Abbrev table used in `xrdb-mode' buffers.") -(define-abbrev-table 'xrdb-mode-abbrev-table ()) - - -(defvar xrdb-mode-syntax-table nil - "Syntax table used in `xrdb-mode' buffers.") -(if xrdb-mode-syntax-table - () - (setq xrdb-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?! "<" xrdb-mode-syntax-table) - (modify-syntax-entry ?\n ">" xrdb-mode-syntax-table)) - - -(defvar xrdb-mode-map () - "Keymap used in `xrdb-mode' buffers.") -(if xrdb-mode-map - () - (setq xrdb-mode-map (make-sparse-keymap)) - (let ((ekey (char-to-string xrdb-separator-char))) - ;; make the separator key electric - (define-key xrdb-mode-map ekey 'xrdb-electric-separator) - (define-key xrdb-mode-map "\t" 'xrdb-indent-line) - (define-key xrdb-mode-map "\C-c\C-a" 'xrdb-indent-paragraph) - (define-key xrdb-mode-map "\C-c\C-b" 'xrdb-submit-bug-report) - (define-key xrdb-mode-map "\C-c\C-p" 'xrdb-indent-page) - (define-key xrdb-mode-map "\C-c\C-r" 'xrdb-indent-region) - (define-key xrdb-mode-map "\C-c\C-u" 'xrdb-indent-buffer) - (define-key xrdb-mode-map "\C-c>" 'xrdb-align-to) - )) - -;;;###autoload -(defun xrdb-mode () - "Major mode for editing xrdb config files" - (interactive) - (kill-all-local-variables) - (set-syntax-table xrdb-mode-syntax-table) - (setq major-mode 'xrdb-mode - mode-name "xrdb" - local-abbrev-table xrdb-mode-abbrev-table) - (use-local-map xrdb-mode-map) - ;; local variables - (make-local-variable 'parse-sexp-ignore-comments) - (make-local-variable 'comment-start) - (make-local-variable 'comment-end) - (make-local-variable 'paragraph-start) - (make-local-variable 'paragraph-separate) - (make-local-variable 'paragraph-ignore-fill-prefix) - ;; now set their values - (setq parse-sexp-ignore-comments t - comment-start "! " - comment-end "") - (setq indent-region-function 'xrdb-indent-region - paragraph-ignore-fill-prefix t - paragraph-start (concat "^[ \t]*$\\|^[ \t]*[!]\\|" page-delimiter) - paragraph-separate paragraph-start) - (run-hooks 'xrdb-mode-hook)) - - - -;; faces and font-locking -(defvar xrdb-option-name-face 'xrdb-option-name-face - "Face for option name on a line in an X resource db file") -(defvar xrdb-option-value-face 'xrdb-option-value-face - "Face for option value on a line in an X resource db file") - -(make-face 'xrdb-option-name-face) -(make-face 'xrdb-option-value-face) - -(defun xrdb-font-lock-mode-hook () - (or (face-differs-from-default-p 'xrdb-option-name-face) - (copy-face 'font-lock-keyword-face 'xrdb-option-name-face)) - (or (face-differs-from-default-p 'xrdb-option-value-face) - (copy-face 'font-lock-string-face 'xrdb-option-value-face)) - (remove-hook 'font-lock-mode-hook 'xrdb-font-lock-mode-hook)) -(add-hook 'font-lock-mode-hook 'xrdb-font-lock-mode-hook) - -(defvar xrdb-font-lock-keywords - (list '("^[ \t]*\\([^\n:]*:\\)[ \t]*\\(.*\\)$" - (1 xrdb-option-name-face) - (2 xrdb-option-value-face))) - "Additional expressions to highlight in X resource db mode.") -(put 'xrdb-mode 'font-lock-defaults '(xrdb-font-lock-keywords)) - - - -;; commands -(defun xrdb-region-goal-column () - ;; Returns the goal column of the current region. Assumes the - ;; buffer has been narrowed to the region to scan. - (save-excursion - (beginning-of-buffer) - (let ((goalcol -1) - linecol) - (while (< (point) (point-max)) - ;; skip any comments - (if (and (not (looking-at xrdb-comment-re)) - (xrdb-skip-to-separator) - (< goalcol (setq linecol (current-column))) - ) - (setq goalcol linecol)) - (forward-line 1)) - (if (< goalcol 0) - nil - goalcol)))) - - - -;; submitting bug reports - -(defconst xrdb-version "1.21" - "xrdb-mode version number.") - -(defconst xrdb-mode-help-address "tools-help@python.org" - "Address for xrdb-mode bug reports.") - -(eval-when-compile - (require 'reporter)) - -(defun xrdb-submit-bug-report () - "Submit via mail a bug report on xrdb-mode." - (interactive) - ;; load in reporter - (let ((reporter-prompt-for-summary-p t) - (varlist '(xrdb-subdivide-by - xrdb-mode-hook - ))) - (and (if (y-or-n-p "Do you want to submit a report on xrdb-mode? ") - t - (message "") - nil) - (require 'reporter) - (reporter-submit-bug-report - xrdb-mode-help-address "xrdb-mode" varlist nil nil "Dear Barry,") - ))) - - -(provide 'xrdb-mode) -;; xrdb-mode.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mouse.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,1506 @@ +;;; mouse.el --- window system-independent mouse support. + +;; Copyright (C) 1988, 1992-4, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1995 Tinker Systems +;; Copyright (C) 1995, 1996 Ben Wing. + +;; Maintainer: XEmacs Development Team +;; Keywords: mouse, dumped + +;; 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, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: Not synched with FSF. Almost completely divergent. + +;;; Commentary: + +;; This file is dumped with XEmacs (when window system support is compiled in). + +;;; Code: + +(provide 'mouse) + +(global-set-key 'button1 'mouse-track) +(global-set-key '(shift button1) 'mouse-track-adjust) +(global-set-key '(control button1) 'mouse-track-insert) +(global-set-key '(control shift button1) 'mouse-track-delete-and-insert) +(global-set-key '(meta button1) 'mouse-track-do-rectangle) + +;; enable drag regions (ograf@fga.de) +;; if button2 is dragged from within a region, this becomes a drop +(if (featurep '(or offix cde)) + (global-set-key 'button2 'mouse-drag-or-yank) + (global-set-key 'button2 'mouse-yank)) + +;; enable drops from OffiX (ograf@fga.de) +;; accept any button1,2,3 drop with `mouse-offix-drop' +(cond ((featurep 'offix) + (global-set-key 'drop1 'mouse-offix-drop) + (global-set-key 'drop2 'mouse-offix-drop) + (global-set-key 'drop3 'mouse-offix-drop))) + +(defcustom mouse-track-rectangle-p nil + "*If true, then dragging out a region with the mouse selects rectangles +instead of simple start/end regions." + :type 'boolean + :group 'mouse) + +(defcustom mouse-yank-at-point nil + "*If non-nil, the function `mouse-yank' will yank text at the cursor location. +Otherwise, the cursor will be moved to the location of the pointer click before +text is inserted." + :type 'boolean + :group 'mouse) + +(defcustom mouse-highlight-text 'context + "*Choose the default double-click highlighting behaviour. +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)." + :type '(choice (const context) + (const word) + (const symbol)) + :group 'mouse) + +(defvar mouse-yank-function 'mouse-consolidated-yank + "Function that is called upon by `mouse-yank' to actually insert text.") + +(defun mouse-consolidated-yank () + (interactive) + (case (device-type) + (x (x-yank-function)) + (tty (yank)) + (otherwise (yank)))) + + +(defun mouse-select () + "Select Emacs window the mouse is on." + (interactive "@")) + +(defun mouse-delete-window () + "Delete the Emacs window the mouse is on." + (interactive "@") + (delete-window)) + +(defun mouse-keep-one-window () + "Select Emacs window mouse is on, then kill all other Emacs windows." + (interactive "@") + (delete-other-windows)) + +(defun mouse-select-and-split () + "Select Emacs window mouse is on, then split it vertically in half." + (interactive "@") + (split-window-vertically nil)) + +(defun mouse-set-point (event) + "Select Emacs window mouse is on, and move point to mouse position." + (interactive "@e") + (let ((window (event-window event)) + (pos (event-point event)) + (close-pos (event-closest-point event))) + (or window (error "not in a window")) + (select-window window) + (if (and pos (> pos 0)) + ;; If the event was over a text char, it's easy. + (goto-char (max (min pos (point-max)) (point-min))) + (if (and close-pos (> close-pos 0)) + (goto-char (max (min close-pos (point-max)) (point-min))) + ;; When the event occurs outside of the frame directly to the + ;; left or right of a modeline, close-point is nil, but + ;; event-over-modeline is also nil. That will drop us to this + ;; point. So instead of erroring, just return nil. + nil)))) + +(defun mouse-yank (event) + "Paste text with the mouse. +If the variable `mouse-yank-at-point' is nil, then pasting occurs at the +location of the click; otherwise, pasting occurs at the current cursor +location." + (interactive "e") + (and (not mouse-yank-at-point) + (mouse-set-point event)) + (funcall mouse-yank-function)) + +(defun click-inside-extent-p (click extent) + "Returns non-nil if the button event is within the bounds of the primary +selection-extent, nil otherwise." + ;; stig@hackvan.com + (let ((ewin (event-window click)) + (epnt (event-point click))) + (and ewin + epnt + extent + (eq (window-buffer ewin) + (extent-object extent)) + (extent-start-position extent) + (> epnt (extent-start-position extent)) + (> (extent-end-position extent) epnt)))) + +(defun click-inside-selection-p (click) + (or (click-inside-extent-p click primary-selection-extent) + (click-inside-extent-p click zmacs-region-extent) + )) + +(defun point-inside-extent-p (extent) + "Returns non-nil if the point is within or just after the bounds of the +primary selection-extent, nil otherwise." + ;; stig@hackvan.com + (and extent + (eq (current-buffer) + (extent-object extent)) + (> (point) (extent-start-position extent)) + (>= (extent-end-position extent) (point)))) + +(defun point-inside-selection-p () + ;; by Stig@hackvan.com + (or (point-inside-extent-p primary-selection-extent) + (point-inside-extent-p zmacs-region-extent))) + +(defun mouse-drag-or-yank (event) + "Either drag or paste the current selection. If the variable + `mouse-yank-at-point' is non-nil, then moves the cursor to the location of + the click before pasting. + This functions has to be improved. Until now it is just a (working) test." + ;; by Oliver Graf <ograf@fga.de> + (interactive "e") + (if (click-inside-extent-p event zmacs-region-extent) + ;; okay, this is a drag + (cond ((featurep 'offix) + (offix-start-drag-region event + (extent-start-position zmacs-region-extent) + (extent-end-position zmacs-region-extent))) + ((featurep 'cde) + ;; should also work with CDE + (cde-start-drag + (extent-start-position zmacs-region-extent) + (extent-end-position zmacs-region-extent))) + (t (error "No offix or CDE support compiled in"))) + ;; no drag, call region-funct + (and (not mouse-yank-at-point) + (mouse-set-point event)) + (funcall mouse-yank-function)) + ) + +(defun mouse-offix-drop (event) + "Do something with an OffiX drop event. Inserts Text drops and + executes appropriate commands for specific drops. + Text drops follow the `mouse-yank-at-point' variable." + ;; by Oliver Graf <ograf@fga.de> + (interactive "e") + (let ((type (car (event-drag-and-drop-data event))) + (data (cadr (event-drag-and-drop-data event))) + (frame (event-channel event))) + (cond ((= type 2) + (let ((x pop-up-windows)) + (setq pop-up-windows nil) + (pop-to-buffer (find-file-noselect data) nil frame) + (make-frame-visible frame) + (setq pop-up-windows x))) + ((= type 3) + (let ((x pop-up-windows)) + (setq pop-up-windows nil) + (while (not (eq data ())) + (pop-to-buffer (find-file-noselect (car data)) nil frame) + (setq data (cdr data))) + (make-frame-visible frame) + (setq pop-up-windows x))) + ((= type 4) + (and (not mouse-yank-at-point) + (mouse-set-point event)) + (insert data)) + ((= type 5) (dired data)) + ((or (= type 6) (= type 7)) (dired data)) ;; this is junk + ((= type 8) (funcall browse-url-browser-function data)) + ((= type 9) + (let ((buf (generate-new-buffer "DndMIME"))) + (set-buffer buf) + (pop-to-buffer buf nil frame) + (insert data) + (make-frame-visible frame))) + (t ;; this is raw data or unknown stuff + (let ((buf (generate-new-buffer "DndRawData"))) + (set-buffer buf) + (pop-to-buffer buf nil frame) + (insert data) + (hexlify-buffer) + (make-frame-visible frame)))))) + +(defun mouse-eval-sexp (click force-window) + "Evaluate the sexp under the mouse. Usually, this is the last sexp before +the click, but if you click on a left paren, then it is the sexp beginning +with the paren that is evaluated. Also, since strings evaluate to themselves, +they're fed to re-search-forward and the matched region is highlighted until +the mouse button is released. + +Perhaps the most useful thing about this function is that the evaluation of +the expression which is clicked upon is relative not to the window where you +click, but to the current window and the current position of point. Thus, +you can use `mouse-eval-sexp' to interactively test code that acts upon a +buffer...something you cannot do with the standard `eval-last-sexp' function. +It's also fantastic for debugging regular expressions." + ;; by Stig@hackvan.com + (interactive "e\nP") + (let (exp val result-str) + (setq exp (save-window-excursion + (save-excursion + (mouse-set-point click) + (save-excursion + (or (looking-at "(") (forward-sexp -1)) + (read (point-marker)))))) + (cond ((stringp exp) + (if (setq val (re-search-forward exp nil t)) + (let* ((oo (make-extent (match-beginning 0) (match-end 0)))) + (set-extent-face oo 'highlight) + (set-extent-priority oo 1000) + ;; wait for button release... + (setq unread-command-event (next-command-event)) + (delete-extent oo)) + (message "Regex \"%s\" not found" exp) + (ding nil 'quiet))) + (t (setq val (if (fboundp 'eval-interactive) + (eval-interactive exp) + (eval exp))))) + (setq result-str (prin1-to-string val)) + ;; #### -- need better test + (if (and (not force-window) + (<= (length result-str) (window-width (selected-window)))) + (message "%s" result-str) + (with-output-to-temp-buffer "*Mouse-Eval*" + (condition-case nil + (pprint val) + (error (prin1 val)))) + ))) + +(defun mouse-line-length (event) + "Print the length of the line indicated by the pointer." + (interactive "@e") + (save-excursion + (mouse-set-point event) + (message "Line length: %d" (- (point-at-eol) (point-at-bol)))) + (sleep-for 1)) + +(defun mouse-set-mark (event) + "Select Emacs window mouse is on, and set mark at mouse position. +Display cursor at that position for a second." + (interactive "@e") + (let ((point-save (point))) + (unwind-protect + (progn (mouse-set-point event) + (push-mark nil t) + (sit-for 1)) + (goto-char point-save)))) + +(defun mouse-scroll (event) + "Scroll point to the mouse position." + (interactive "@e") + (save-excursion + (mouse-set-point event) + (recenter 0) + (scroll-right (event-x event)))) + +(defun mouse-del-char (event) + "Delete the char pointed to by the mouse." + (interactive "@e") + (save-excursion + (mouse-set-point event) + (delete-char 1 nil))) + +(defun mouse-kill-line (event) + "Kill the line pointed to by the mouse." + (interactive "@e") + (save-excursion + (mouse-set-point event) + (kill-line nil))) + +(defun mouse-bury-buffer (event) + "Bury the buffer pointed to by the mouse, thus selecting the next one." + (interactive "e") + (save-selected-window + (select-window (event-window event)) + (bury-buffer))) + +(defun mouse-unbury-buffer (event) + "Unbury and select the most recently buried buffer." + (interactive "e") + (save-selected-window + (select-window (event-window event)) + (let* ((bufs (buffer-list)) + (entry (1- (length bufs))) + val) + (while (not (setq val (nth entry bufs) + val (and (/= (aref (buffer-name val) 0) + ? ) + val))) + (setq entry (1- entry))) + (switch-to-buffer val)))) + +(defun narrow-window-to-region (m n) + "Narrow window to region between point and last mark" + (interactive "r") + (save-excursion + (save-restriction + (if (eq (selected-window) (next-window)) + (split-window)) + (goto-char m) + (recenter 0) + (if (eq (selected-window) + (if (zerop (minibuffer-depth)) + (next-window))) + () + (shrink-window (- (- (window-height) (count-lines m n)) 1)))))) + +(defun mouse-window-to-region (event) + "Narrow window to region between cursor and mouse pointer." + (interactive "@e") + (let ((point-save (point))) + (unwind-protect + (progn (mouse-set-point event) + (push-mark nil t) + (sit-for 1)) + (goto-char point-save) + (narrow-window-to-region (region-beginning) (region-end))))) + +(defun mouse-ignore () + "Don't do anything." + (interactive)) + + +;; +;; Commands for the scroll bar. +;; + +;; this stuff has never ever been used and should be junked. + +;; Vertical bar + +;(defun mouse-scroll-down (nlines) +; "Junk me, please." +; (interactive "@p") +; (scroll-down nlines)) + +;(defun mouse-scroll-up (nlines) +; "Junk me, please." +; (interactive "@p") +; (scroll-up nlines)) + +;(defun mouse-scroll-down-full () +; "Junk me, please." +; (interactive "@") +; (scroll-down nil)) + +;(defun mouse-scroll-up-full () +; "Junk me, please." +; (interactive "@") +; (scroll-up nil)) + +;(defun mouse-scroll-move-cursor (nlines) +; "Junk me, please." +; (interactive "@p") +; (move-to-window-line nlines)) + +;(defun mouse-scroll-absolute (event) +; "Junk me, please." +; (interactive "@e") +; (let* ((position (event-x event)) +; (length (event-y event)) +; (size (buffer-size)) +; (scale-factor (max 1 (/ 8000000 size))) +; (newpos (* (/ (* (/ size scale-factor) position) length) +; scale-factor))) +; (goto-char newpos) +; (recenter '(4)))) + +;; These scroll while the invoking button is depressed. + +;(defvar scrolled-lines 0) +;(defvar scroll-speed 1) + +;(defun incr-scroll-down (event) +; "Junk me, please." +; (interactive "@e") +; (setq scrolled-lines 0) +; (incremental-scroll scroll-speed)) + +;(defun incr-scroll-up (event) +; "Junk me, please." +; (interactive "@e") +; (setq scrolled-lines 0) +; (incremental-scroll (- scroll-speed))) + +;(defun incremental-scroll (n) +; "Junk me, please." +; (let ((down t)) +; (while down +; (sit-for mouse-track-scroll-delay) +; (cond ((input-pending-p) +; (let ((event (next-command-event))) +; (if (or (button-press-event-p event) +; (button-release-event-p event)) +; (setq down nil)) +; (dispatch-event event)))) +; (setq scrolled-lines (1+ (* scroll-speed scrolled-lines))) +; (scroll-down n)))) + +;(defun incr-scroll-stop (event) +; "Junk me, please." +; (interactive "@e") +; (setq scrolled-lines 0) +; (sleep-for 1)) + + +;(defun mouse-scroll-left (ncolumns) +; "Junk me, please." +; (interactive "@p") +; (scroll-left ncolumns)) + +;(defun mouse-scroll-right (ncolumns) +; "Junk me, please." +; (interactive "@p") +; (scroll-right ncolumns)) + +;(defun mouse-scroll-left-full () +; "Junk me, please." +; (interactive "@") +; (scroll-left nil)) + +;(defun mouse-scroll-right-full () +; "Junk me, please." +; (interactive "@") +; (scroll-right nil)) + +;(defun mouse-scroll-move-cursor-horizontally (ncolumns) +; "Junk me, please." +; (interactive "@p") +; (move-to-column ncolumns)) + +;(defun mouse-scroll-absolute-horizontally (event) +; "Junk me, please." +; (interactive "@e") +; (set-window-hscroll (selected-window) 33)) + + + +;;; mouse/selection tracking +;;; generalized mouse-track + +(defvar default-mouse-track-normalize-point-function + 'default-mouse-track-normalize-point + "Function called to normalize position of point. +Called with two arguments: TYPE depends on the number of times that the +mouse has been clicked and is a member of `default-mouse-track-type-list', +FORWARDP determines the direction in which the point should be moved.") + +(defvar mouse-track-down-hook nil + "Function or functions called when the user presses the mouse. +This hook is invoked by `mouse-track'; thus, it will not be called +for any buttons with a different binding. The functions will be +called with two arguments: the button-press event and a click +count (see `mouse-track-click-hook'). + +If any function returns non-nil, the remaining functions will not be +called. + +Note that most applications should take action when the mouse is +released, not when it is pressed.'") + +(defvar mouse-track-drag-hook nil + "Function or functions called when the user drags the mouse. +This hook is invoked by `mouse-track'; thus, it will not be called +for any buttons with a different binding. The functions will be +called with three arguments: the mouse-motion event, a click +count (see `mouse-track-click-hook'), and whether the call to +this hook occurred as a result of a drag timeout (see +`mouse-track-scroll-delay'). + +If any function returns non-nil, the remaining functions will not be +called. + +Note that no calls to this function will be made until the user +initiates a drag (i.e. moves the mouse more than a certain +threshold in either the X or the Y direction, as defined by +`mouse-track-x-threshold' and `mouse-track-y-threshold'). + +See also `mouse-track-drag-up-hook'.") + +(defvar mouse-track-drag-up-hook nil + "Function or functions called when the user finishes a drag. +This hook is invoked by `mouse-track'; thus, it will not be called +for any buttons with a different binding. The functions will be +called with two arguments: the button-press event and a click +count (see `mouse-track-click-hook'). + +If any function returns non-nil, the remaining functions will not be +called. + +Note that this hook will not be invoked unless the user has +initiated a drag, i.e. moved the mouse more than a certain threshold +(see `mouse-track-drag-hook'). When this function is invoked, +`mouse-track-drag-hook' will have been invoked at least once. + +See also `mouse-track-click-hook'.") + +(defvar mouse-track-click-hook nil + "Function or functions called when the user clicks the mouse. +`Clicking' means pressing and releasing the mouse without having +initiated a drag (i.e. without having moved more than a certain +threshold -- see `mouse-track-drag-hook'). + +This hook is invoked by `mouse-track'; thus, it will not be called +for any buttons with a different binding. The functions will be +called with two arguments: the button-release event and a click +count, which specifies the number of times that the mouse has been +clicked in a series of clicks, each of which is separated by at most +`mouse-track-multi-click-time'. This can be used to implement actions +that are called on double clicks, triple clicks, etc. + +If any function returns non-nil, the remaining functions will not be +called. + +See also `mouse-track-drag-up-hook.") + +(defvar mouse-track-up-hook nil + "Function or functions called when the user releases the mouse. +This hook is invoked by `mouse-track'; thus, it will not be called +for any buttons with a different binding. The functions will be +called with two arguments: the button-release event and a click +count (see `mouse-track-click-hook'). + +For many applications, it is more appropriate to use one or both +of `mouse-track-click-hook' and `mouse-track-drag-up-hook'.") + +(defvar mouse-track-cleanup-hook nil + "Function or functions called when `mouse-track' terminates. +This hook will be called in all circumstances, even upon a +non-local exit out of `mouse-track', and so is useful for +doing cleanup work such as removing extents that may have +been created during the operation of `mouse-track'. + +Unlike all of the other mouse-track hooks, this is a \"normal\" +hook: the hook functions are called with no arguments, and +all hook functions are called regardless of their return +values.") + +(defcustom mouse-track-multi-click-time 400 + "*Maximum number of milliseconds allowed between clicks for a multi-click. +See `mouse-track-click-hook'." + :type 'integer + :group 'mouse) + +(defcustom mouse-track-scroll-delay 100 + "Maximum of milliseconds between calls to `mouse-track-drag-hook'. +If the user is dragging the mouse (i.e. the button is held down and +a drag has been initiated) and does not move the mouse for this many +milliseconds, the hook will be called with t as the value of the +WAS-TIMEOUT parameter. This can be used to implement scrolling +in a selection when the user drags the mouse out the window it +was in. + +A value of nil disables the timeout feature." + :type '(choice integer (const :tag "Disabled" nil)) + :group 'mouse) + +(defvar mouse-track-x-threshold '(face-width 'default) + "Minimum number of pixels in the X direction for a drag to be initiated. +If the mouse is moved more than either the X or Y threshold while the +button is held down (see also `mouse-track-y-threshold'), then a drag +is initiated; otherwise the gesture is considered to be a click. +See `mouse-track'. + +The value should be either a number of a form to be evaluated to +produce a number.") + +(defvar mouse-track-y-threshold '(face-height 'default) + "Minimum number of pixels in the Y direction for a drag to be initiated. +If the mouse is moved more than either the X or Y threshold while the +button is held down (see also `mouse-track-x-threshold'), then a drag +is initiated; otherwise the gesture is considered to be a click. +See `mouse-track'. + +The value should be either a number of a form to be evaluated to +produce a number.") + +;; these variables are private to mouse-track. +(defvar mouse-track-up-time nil) +(defvar mouse-track-up-x nil) +(defvar mouse-track-up-y nil) +(defvar mouse-track-timeout-id nil) +(defvar mouse-track-click-count nil) + +(defun mouse-track-set-timeout (event) + (if mouse-track-timeout-id + (disable-timeout mouse-track-timeout-id)) + (if mouse-track-scroll-delay + (setq mouse-track-timeout-id + (add-timeout (/ mouse-track-scroll-delay 1000.0) + 'mouse-track-scroll-undefined + (copy-event event))))) + +(defun mouse-track-run-hook (hook event &rest args) + ;; ugh, can't use run-special-hook-with-args because we + ;; have to get the value using symbol-value-in-buffer. + ;; Doing a save-excursion/set-buffer is wrong because + ;; the hook might want to change the buffer, but just + ;; doing a set-buffer is wrong because the hook might + ;; not want to change the buffer. + (let ((buffer (event-buffer event))) + (if mouse-grabbed-buffer (setq buffer mouse-grabbed-buffer)) + (if buffer + (let ((value (symbol-value-in-buffer hook buffer nil))) + (if (and (listp value) (not (eq (car value) 'lambda))) + (let (retval) + (while (and value + (not (setq retval (apply (car value) event args)))) + (setq value (cdr value))) + retval) + (apply value event args)))))) + +(defun mouse-track-scroll-undefined (random) + ;; the old implementation didn't actually define this function, + ;; and in normal use it won't ever be called because the timeout + ;; will either be removed before it fires or will be picked off + ;; with next-event and not dispatched. However, if you're + ;; attempting to debug a click-hook (which is pretty damn + ;; difficult to do), this function may get called. +) + +(defun mouse-track (event) + "Make a selection with the mouse. This should be bound to a mouse button. +The behavior of XEmacs during mouse selection is customizable using various +hooks and variables: see `mouse-track-click-hook', `mouse-track-drag-hook', +`mouse-track-drag-up-hook', `mouse-track-down-hook', `mouse-track-up-hook', +`mouse-track-cleanup-hook', `mouse-track-multi-click-time', +`mouse-track-scroll-delay', `mouse-track-x-threshold', and +`mouse-track-y-threshold'. + +Default handlers are provided to implement standard selecting/positioning +behavior. You can explicitly request this default behavior, and override +any custom-supplied handlers, by using the function `mouse-track-default' +instead of `mouse-track'. + +Default behavior is as follows: + +If you click-and-drag, the selection will be set to the region between the +point of the initial click and the point at which you release the button. +These positions need not be ordered. + +If you click-and-release without moving the mouse, then the point is moved +and the selection is disowned (there will be no selection owner). The mark +will be set to the previous position of point. + +If you double-click, the selection will extend by symbols instead of by +characters. If you triple-click, the selection will extend by lines. + +If you drag the mouse off the top or bottom of the window, you can select +pieces of text which are larger than the visible part of the buffer; the +buffer will scroll as necessary. + +The selected text becomes the current X Selection. The point will be left +at the position at which you released the button, and the mark will be left +at the initial click position." + (interactive "e") + (let ((mouse-down t) + (xthresh (eval mouse-track-x-threshold)) + (ythresh (eval mouse-track-y-threshold)) + (orig-x (event-x-pixel event)) + (orig-y (event-y-pixel event)) + (buffer (event-buffer event)) + (mouse-grabbed-buffer (event-buffer event)) + mouse-moved) + (if (or (not mouse-track-up-x) + (not mouse-track-up-y) + (not mouse-track-up-time) + (> (- (event-timestamp event) mouse-track-up-time) + mouse-track-multi-click-time) + (> (abs (- mouse-track-up-x orig-x)) xthresh) + (> (abs (- mouse-track-up-y orig-y)) ythresh)) + (setq mouse-track-click-count 1) + (setq mouse-track-click-count (1+ mouse-track-click-count))) + (if (not (event-window event)) + (error "Not over a window.")) + (mouse-track-run-hook 'mouse-track-down-hook + event mouse-track-click-count) + (unwind-protect + (while mouse-down + (setq event (next-event event)) + (cond ((motion-event-p event) + (if (and (not mouse-moved) + (or (> (abs (- (event-x-pixel event) orig-x)) + xthresh) + (> (abs (- (event-y-pixel event) orig-y)) + ythresh))) + (setq mouse-moved t)) + (if mouse-moved + (mouse-track-run-hook 'mouse-track-drag-hook + event mouse-track-click-count nil)) + (mouse-track-set-timeout event)) + ((and (timeout-event-p event) + (eq (event-function event) + 'mouse-track-scroll-undefined)) + (if mouse-moved + (mouse-track-run-hook 'mouse-track-drag-hook + (event-object event) mouse-track-click-count t)) + (mouse-track-set-timeout (event-object event))) + ((button-release-event-p event) + (setq mouse-track-up-time (event-timestamp event)) + (setq mouse-track-up-x (event-x-pixel event)) + (setq mouse-track-up-y (event-y-pixel event)) + (setq mouse-down nil) + (mouse-track-run-hook 'mouse-track-up-hook + event mouse-track-click-count) + (if mouse-moved + (mouse-track-run-hook 'mouse-track-drag-up-hook + event mouse-track-click-count) + (mouse-track-run-hook 'mouse-track-click-hook + event mouse-track-click-count))) + ((key-press-event-p event) + (error "Selection aborted")) + (t + (dispatch-event event)))) + ;; protected + (if mouse-track-timeout-id + (disable-timeout mouse-track-timeout-id)) + (setq mouse-track-timeout-id nil) + (and buffer + (save-excursion + (set-buffer buffer) + (run-hooks 'mouse-track-cleanup-hook)))))) + + +;;;;;;;;;;;; default handlers: new version of mouse-track + +(defvar default-mouse-track-type nil) +(defvar default-mouse-track-type-list '(char word line)) +(defvar default-mouse-track-window nil) +(defvar default-mouse-track-extent nil) +(defvar default-mouse-track-adjust nil) +(defvar default-mouse-track-min-anchor nil) +(defvar default-mouse-track-max-anchor nil) +(defvar default-mouse-track-result nil) +(defvar default-mouse-track-down-event nil) + +(defun default-mouse-track-set-point-in-window (event window) + (if (not (and (not (event-over-modeline-p event)) + (eq (event-window event) window) + (let ((p (event-closest-point event))) + (and p (pos-visible-in-window-p p window))))) + nil + (mouse-set-point event) + t)) + +(defun default-mouse-track-scroll-and-set-point (event window) + (select-window window) + (let ((edges (window-pixel-edges window)) + (row (event-y-pixel event)) + (height (face-height 'default))) + (cond ((< (abs (- row (nth 1 edges))) (abs (- row (nth 3 edges)))) + ;; closer to window's top than to bottom, so move up + (let ((delta (max 1 (/ (- (nth 1 edges) row) height)))) + (condition-case () (scroll-down delta) (error)) + (goto-char (window-start)))) + ((>= (point) (point-max))) + (t + ;; scroll by one line if over the modeline or a clipped line + (let ((delta (if (or (event-over-modeline-p event) + (< row (nth 3 edges))) + 1 + (+ (/ (- row (nth 3 edges)) height) 1))) + (close-pos (event-closest-point event))) + (condition-case () (scroll-up delta) (error)) + (if (and close-pos (pos-visible-in-window-p close-pos)) + (goto-char close-pos) + (goto-char (window-end)) + (vertical-motion delta) + ;; window-end reports the end of the clipped line, even if + ;; scroll-on-clipped-lines is t. compensate. + ;; (If window-end gets fixed this can be removed.) + (if (not (pos-visible-in-window-p (max (1- (point)) + (point-min)))) + (vertical-motion -1)) + (condition-case () (backward-char 1) + (error (end-of-line))))))))) + + +;; This remembers the last position at which the user clicked, for the +;; benefit of mouse-track-adjust (for example, button1; scroll until the +;; position of the click is off the frame; then Sh-button1 to select the +;; new region. +(defvar default-mouse-track-previous-point nil) + +(defun default-mouse-track-set-point (event window) + (if (default-mouse-track-set-point-in-window event window) + nil + (default-mouse-track-scroll-and-set-point event window))) + +(defsubst default-mouse-track-beginning-of-word (symbolp) + (let ((word-constituent (cond ((eq symbolp t) "\\w\\|\\s_\\|\\s'") + ((null symbolp) "\\w") + (t "[^ \t\n]"))) + (white-space "[ \t]")) + (cond ((bobp) nil) + ((looking-at word-constituent) + (backward-char) + (while (and (not (bobp)) (looking-at word-constituent)) + (backward-char)) + (if (or (not (bobp)) (not (looking-at word-constituent))) + (forward-char))) + ((looking-at white-space) + (backward-char) + (while (looking-at white-space) + (backward-char)) + (forward-char))))) + +(defun default-mouse-track-end-of-word (symbolp) + (let ((word-constituent (cond ((eq symbolp t) "\\w\\|\\s_\\|\\s'") + ((null symbolp) "\\w") + (t "[^ \t\n]"))) + (white-space "[ \t]")) + (cond ((looking-at word-constituent) ; word or symbol constituent + (while (looking-at word-constituent) + (forward-char))) + ((looking-at white-space) ; word or symbol constituent + (while (looking-at white-space) + (forward-char)))))) + +;; Decide what will be the SYMBOLP argument to +;; default-mouse-track-{beginning,end}-of-word, according to the +;; syntax of the current character and value of mouse-highlight-text. +(defsubst default-mouse-symbolp (syntax) + (cond ((eq mouse-highlight-text 'context) + (eq syntax ?_)) + ((eq mouse-highlight-text 'symbol) + t) + (t + nil))) + +(defun default-mouse-track-normalize-point (type forwardp) + (cond ((eq type 'word) + ;; trap the beginning and end of buffer errors + (ignore-errors + (setq type (char-syntax (char-after (point)))) + (if forwardp + (if (= type ?\() + (goto-char (scan-sexps (point) 1)) + (if (= type ?\)) + (forward-char 1) + (default-mouse-track-end-of-word + (default-mouse-symbolp type)))) + (if (= type ?\)) + (goto-char (scan-sexps (1+ (point)) -1)) + (default-mouse-track-beginning-of-word + (default-mouse-symbolp type)))))) + ((eq type 'line) + (if forwardp (end-of-line) (beginning-of-line))) + ((eq type 'buffer) + (if forwardp (end-of-buffer) (beginning-of-buffer))))) + +(defun default-mouse-track-next-move (min-anchor max-anchor extent) + (let ((anchor (if (<= (point) min-anchor) max-anchor min-anchor))) + (funcall default-mouse-track-normalize-point-function + default-mouse-track-type (> (point) anchor)) + (if (consp extent) + (default-mouse-track-next-move-rect anchor (point) extent) + (if extent + (if (<= anchor (point)) + (set-extent-endpoints extent anchor (point)) + (set-extent-endpoints extent (point) anchor)))))) + +(defun default-mouse-track-next-move-rect (start end extents &optional pad-p) + (if (< end start) + (let ((tmp start)) (setq start end end tmp))) + (cond + ((= start end) ; never delete the last remaining extent + (mapcar 'delete-extent (cdr extents)) + (setcdr extents nil) + (set-extent-endpoints (car extents) start start)) + (t + (let ((indent-tabs-mode nil) ; if pad-p, don't use tabs + (rest extents) + left right last p) + (save-excursion + (save-restriction + (goto-char end) + (setq right (current-column)) + (goto-char start) + (setq left (current-column)) + (if (< right left) + (let ((tmp left)) + (setq left right right tmp) + (setq start (- start (- right left)) + end (+ end (- right left))))) + ;; End may have been set to a value greater than point-max if drag + ;; or movement extends to end of buffer, so reset it. + (setq end (min end (point-max))) + (beginning-of-line) + (narrow-to-region (point) end) + (goto-char start) + (while (and rest (not (eobp))) + (setq p (point)) + (move-to-column right pad-p) + (set-extent-endpoints (car rest) p (point)) + ;; this code used to look at the return value + ;; of forward-line, but that doesn't work because + ;; forward-line has bogus behavior: If you're on + ;; the last line of a buffer but not at the very + ;; end, forward-line will move you to the very + ;; end and return 0 instead of 1, like it should. + ;; the result was frequent infinite loops here, + ;; creating very large numbers of extents at + ;; the same position. There was an N^2 sorting + ;; algorithm in extents.c for extents at a + ;; particular position, and the result was very + ;; bad news. + (forward-line 1) + (if (not (eobp)) + (move-to-column left pad-p)) + (setq last rest + rest (cdr rest))) + (cond (rest + (mapcar 'delete-extent rest) + (setcdr last nil)) + ((not (eobp)) + (while (not (eobp)) + (setq p (point)) + (move-to-column right pad-p) + (let ((e (make-extent p (point)))) + (set-extent-face e (extent-face (car extents))) + (set-extent-priority e (extent-priority (car extents))) + (setcdr last (cons e nil)) + (setq last (cdr last))) + (forward-line 1) + (if (not (eobp)) + (move-to-column left pad-p)) + ))))) + )))) + +(defun default-mouse-track-has-selection-p (buffer) + (and (or (not (eq 'x (console-type))) + (x-selection-owner-p)) + (extent-live-p primary-selection-extent) + (not (extent-detached-p primary-selection-extent)) + (eq buffer (extent-object primary-selection-extent)))) + +(defun default-mouse-track-anchor (adjust previous-point) + (if adjust + (if (default-mouse-track-has-selection-p (current-buffer)) + (let ((start (extent-start-position primary-selection-extent)) + (end (extent-end-position primary-selection-extent))) + (cond ((< (point) start) end) + ((> (point) end) start) + ((> (- (point) start) (- end (point))) start) + (t end))) + previous-point) + (point))) + +(defun default-mouse-track-maybe-own-selection (pair type) + (let ((start (car pair)) + (end (cdr pair))) + (or (= start end) (push-mark (if (= (point) start) end start))) + (cond (zmacs-regions + (if (= start end) + nil + ;; #### UTTER KLUDGE. + ;; If we don't have this sit-for here, then triple-clicking + ;; will result in the line not being highlighted as it + ;; should. What appears to be happening is this: + ;; + ;; -- each time the button goes down, the selection is + ;; disowned (see comment "remove the existing selection + ;; to unclutter the display", below). + ;; -- this causes a SelectionClear event to be sent to + ;; XEmacs. + ;; -- each time the button goes up except the first, the + ;; selection is owned again. + ;; -- later, XEmacs processes the SelectionClear event. + ;; The selection code attempts to keep track of the + ;; time that it last asserted the selection, and + ;; compare it to the time of the SelectionClear event, + ;; to see if it's a bogus notification or not (as + ;; is the case here). However, for some unknown + ;; reason this doesn't work in the triple-clicking + ;; case, and the selection code bogusly thinks this + ;; SelectionClear event is the real thing. + ;; -- putting the sit-for in causes the pending + ;; SelectionClear events to get processed before + ;; the selection is reasserted, so everything works + ;; out OK. + ;; + ;; Presumably(?) this means there is a weird timing bug + ;; in the selection code, but there's not a chance in hell + ;; that I have the patience to track it down. Blame the + ;; designers of X for fucking everything up so badly. + ;; + ;; This was originally a sit-for 0 but that wasn't + ;; sufficient to make things work. Even this isn't + ;; 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. + ;; + (sit-for 0.15 t) + (zmacs-activate-region))) + ((eq 'x (console-type)) + (if (= start end) + (x-disown-selection type) + (if (consp default-mouse-track-extent) + ;; own the rectangular region + ;; this is a hack + (let ((r default-mouse-track-extent)) + (save-excursion + (set-buffer (get-buffer-create " *rect yank temp buf*")) + (while r + (insert (extent-string (car r)) "\n") + (setq r (cdr r))) + (x-own-selection (buffer-substring (point-min) (point-max))) + (kill-buffer (current-buffer)))) + (x-own-selection (cons (set-marker (make-marker) start) + (set-marker (make-marker) end)) + type))))) + (if (and (eq 'x (console-type)) + (not (= start end))) + ;; I guess cutbuffers should do something with rectangles too. + ;; does anybody use them? + (x-store-cutbuffer (buffer-substring start end))))) + +(defun default-mouse-track-deal-with-down-event (click-count) + (let ((event default-mouse-track-down-event)) + (if (null event) nil + (select-frame (event-frame event)) + (let ((adjust default-mouse-track-adjust) + ;; ####When you click on the splash-screen, + ;; event-{closest-,}point can be out of bounds. Should + ;; event-closest-point really be allowed to return a bad + ;; position like that? Maybe pixel_to_glyph_translation + ;; needs to invalidate its cache when the buffer changes. + ;; -dkindred@cs.cmu.edu + (close-pos (save-excursion + (set-buffer (event-buffer event)) + (let ((p (event-closest-point event))) + (and p (min (max p (point-min)) (point-max)))))) + extent previous-point) + + (if (not (event-window event)) + (error "not over window?")) + (setq default-mouse-track-type + (nth (mod (1- click-count) + (length default-mouse-track-type-list)) + default-mouse-track-type-list)) + (setq default-mouse-track-window (event-window event)) + ;; Note that the extent used here is NOT the extent which + ;; ends up as the value of zmacs-region-extent - this one is used + ;; just during mouse-dragging. + (setq default-mouse-track-extent + (make-extent close-pos close-pos (event-buffer event))) + (setq extent default-mouse-track-extent) + (set-extent-face extent 'zmacs-region) + ;; While the selection is being dragged out, give the selection extent + ;; slightly higher priority than any mouse-highlighted extent, so that + ;; the exact endpoints of the selection will be visible while the mouse + ;; is down. Normally, the selection and mouse highlighting have the + ;; same priority, so that conflicts between the two of them are + ;; resolved by the usual size-and-endpoint-comparison method. + (set-extent-priority extent (1+ mouse-highlight-priority)) + (if mouse-track-rectangle-p + (setq default-mouse-track-extent + (list default-mouse-track-extent))) + + (setq previous-point + (if (and adjust + (markerp default-mouse-track-previous-point) + (eq (current-buffer) + (marker-buffer default-mouse-track-previous-point))) + (marker-position default-mouse-track-previous-point) + (point))) + (default-mouse-track-set-point event default-mouse-track-window) + (if (not adjust) + (if (markerp default-mouse-track-previous-point) + (set-marker default-mouse-track-previous-point (point)) + (setq default-mouse-track-previous-point (point-marker)))) + ;; + ;; adjust point to a word or line boundary if appropriate + (let ((anchor (default-mouse-track-anchor adjust previous-point))) + (setq default-mouse-track-min-anchor + (save-excursion (goto-char anchor) + (funcall + default-mouse-track-normalize-point-function + default-mouse-track-type nil) + (point))) + (setq default-mouse-track-max-anchor + (save-excursion (goto-char anchor) + (funcall + default-mouse-track-normalize-point-function + default-mouse-track-type t) + (point)))) + ;; + ;; remove the existing selection to unclutter the display + (if (not adjust) + (cond (zmacs-regions + (zmacs-deactivate-region)) + ((eq 'x (console-type)) + (x-disown-selection))))) + (setq default-mouse-track-down-event nil)))) + +(defun default-mouse-track-down-hook (event click-count) + (setq default-mouse-track-down-event (copy-event event)) + nil) + +(defun default-mouse-track-cleanup-extents-hook () + (remove-hook 'pre-command-hook 'default-mouse-track-cleanup-extents-hook) + (let ((extent default-mouse-track-extent)) + (if (consp extent) ; rectangle-p + (mapcar 'delete-extent extent) + (if extent + (delete-extent extent))))) + +(defun default-mouse-track-cleanup-hook () + (if zmacs-regions + (funcall 'default-mouse-track-cleanup-extents-hook) + (let ((extent default-mouse-track-extent) + (func #'(lambda (e) + (and (extent-live-p e) + (set-extent-face e 'primary-selection))))) + (add-hook 'pre-command-hook 'default-mouse-track-cleanup-extents-hook) + (if (consp extent) ; rectangle-p + (mapcar func extent) + (if extent + (funcall func extent)))))) + +(defun default-mouse-track-cleanup-extent () + (let ((dead-func + (function (lambda (x) + (or (not (extent-live-p x)) + (extent-detached-p x))))) + (extent default-mouse-track-extent)) + (if (consp extent) + (if (funcall dead-func extent) + (let (newval) + (mapcar (function (lambda (x) + (if (not (funcall dead-func x)) + (setq newval (cons x newval))))) + extent) + (setq default-mouse-track-extent (nreverse newval)))) + (if (funcall dead-func extent) + (setq default-mouse-track-extent nil))))) + +(defun default-mouse-track-drag-hook (event click-count was-timeout) + (default-mouse-track-deal-with-down-event click-count) + (default-mouse-track-set-point event default-mouse-track-window) + (default-mouse-track-cleanup-extent) + (default-mouse-track-next-move default-mouse-track-min-anchor + default-mouse-track-max-anchor + default-mouse-track-extent) + t) + +(defun default-mouse-track-return-dragged-selection (event) + (default-mouse-track-cleanup-extent) + (let ((extent default-mouse-track-extent) + result) + (default-mouse-track-set-point-in-window event default-mouse-track-window) + (default-mouse-track-next-move default-mouse-track-min-anchor + default-mouse-track-max-anchor + extent) + (cond ((consp extent) ; rectangle-p + (let ((first (car extent)) + (last (car (setq extent (nreverse extent))))) + ;; nreverse is destructive so we need to reset this + (setq default-mouse-track-extent extent) + (setq result (cons (extent-start-position first) + (extent-end-position last))) + ;; kludge to fix up region when dragging backwards... + (if (and (/= (point) (extent-start-position first)) + (/= (point) (extent-end-position last)) + (= (point) (extent-end-position first))) + (goto-char (car result))))) + (extent + (setq result (cons (extent-start-position extent) + (extent-end-position extent))))) + ;; Minor kludge: if we're selecting in line-mode, include the + ;; final newline. It's hard to do this in *-normalize-point. + (if (and result (eq default-mouse-track-type 'line)) + (let ((end-p (= (point) (cdr result)))) + (goto-char (cdr result)) + (if (not (eobp)) + (setcdr result (1+ (cdr result)))) + (goto-char (if end-p (cdr result) (car result))))) +;;; ;; Minor kludge sub 2. If in char mode, and we drag the +;;; ;; mouse past EOL, include the newline. +;;; ;; +;;; ;; Major problem: can't easily distinguish between being +;;; ;; just past the last char on a line, and well past it, +;;; ;; to determine whether or not to include it in the region +;;; ;; +;;; (if nil ; (eq default-mouse-track-type 'char) +;;; (let ((after-end-p (and (not (eobp)) +;;; (eolp) +;;; (> (point) (car result))))) +;;; (if after-end-p +;;; (progn +;;; (setcdr result (1+ (cdr result))) +;;; (goto-char (cdr result)))))) + result)) + +(defun default-mouse-track-drag-up-hook (event click-count) + (let ((result (default-mouse-track-return-dragged-selection event))) + (if result + (default-mouse-track-maybe-own-selection result 'PRIMARY))) + t) + +(defun default-mouse-track-click-hook (event click-count) + (default-mouse-track-drag-hook event click-count nil) + (default-mouse-track-drag-up-hook event click-count) + t) + +(add-hook 'mouse-track-down-hook 'default-mouse-track-down-hook) +(add-hook 'mouse-track-drag-hook 'default-mouse-track-drag-hook) +(add-hook 'mouse-track-drag-up-hook 'default-mouse-track-drag-up-hook) +(add-hook 'mouse-track-click-hook 'default-mouse-track-click-hook) +(add-hook 'mouse-track-cleanup-hook 'default-mouse-track-cleanup-hook) + + +;;;;;;;;;;;; other mouse-track stuff (mostly associated with the +;;;;;;;;;;;; default handlers) + +(defun mouse-track-default (event) + "Invoke `mouse-track' with only the default handlers active." + (interactive "e") + (let ((mouse-track-down-hook 'default-mouse-track-down-hook) + (mouse-track-drag-hook 'default-mouse-track-drag-hook) + (mouse-track-drag-up-hook 'default-mouse-track-drag-up-hook) + (mouse-track-click-hook 'default-mouse-track-click-hook) + (mouse-track-cleanup-hook 'default-mouse-track-cleanup-hook)) + (mouse-track event))) + +(defun mouse-track-do-rectangle (event) + "Like `mouse-track' but selects rectangles instead of regions." + (interactive "e") + (let ((mouse-track-rectangle-p t)) + (mouse-track event))) + +(defun mouse-track-adjust (event) + "Extend the existing selection. This should be bound to a mouse button. +The selection will be enlarged or shrunk so that the point of the mouse +click is one of its endpoints. This function in fact behaves fairly +similarly to `mouse-track', but begins by extending the existing selection +(or creating a new selection from the previous text cursor position to +the current mouse position) instead of creating a new, empty selection. + +The mouse-track handlers are run from this command just like from +`mouse-track'. Therefore, do not call this command from a mouse-track +handler!" + (interactive "e") + (let ((default-mouse-track-adjust t)) + (mouse-track event))) + +(defun mouse-track-adjust-default (event) + "Extend the existing selection, using only the default handlers. +This is just like `mouse-track-adjust' but will override any +custom mouse-track handlers that the user may have installed." + (interactive "e") + (let ((default-mouse-track-adjust t)) + (mouse-track-default event))) + +(defvar mouse-track-insert-selected-region nil) + +(defun mouse-track-insert-drag-up-hook (event click-count) + (setq mouse-track-insert-selected-region + (default-mouse-track-return-dragged-selection event))) + +(defun mouse-track-insert (event &optional delete) + "Make a selection with the mouse and insert it at point. +This is exactly the same as the `mouse-track' command on \\[mouse-track], +except that point is not moved; the selected text is immediately inserted +after being selected\; and the selection is immediately disowned afterwards." + (interactive "*e") + (setq mouse-track-insert-selected-region nil) + (let ((mouse-track-drag-up-hook 'mouse-track-insert-drag-up-hook) + (mouse-track-click-hook 'mouse-track-insert-click-hook) + s) + (save-excursion + (save-window-excursion + (mouse-track event) + (if (consp mouse-track-insert-selected-region) + (let ((pair mouse-track-insert-selected-region)) + (setq s (prog1 + (buffer-substring (car pair) (cdr pair)) + (if delete + (kill-region (car pair) (cdr pair))))))))) + (or (null s) (equal s "") (insert s)))) + +(defun mouse-track-insert-click-hook (event click-count) + (default-mouse-track-drag-hook event click-count nil) + (mouse-track-insert-drag-up-hook event click-count) + t) + +(defun mouse-track-delete-and-insert (event) + "Make a selection with the mouse and insert it at point. +This is exactly the same as the `mouse-track' command on \\[mouse-track], +except that point is not moved; the selected text is immediately inserted +after being selected\; and the text of the selection is deleted." + (interactive "*e") + (mouse-track-insert event t)) + +;;;;;;;;;;;;;;;;;;;;;;;; + + +(defvar inhibit-help-echo nil + "Inhibits display of `help-echo' extent properties in the minibuffer.") +(defvar last-help-echo-object nil) +(defvar help-echo-owns-message nil) + +(defun clear-help-echo (&optional ignored-frame) + (if help-echo-owns-message + (progn + (setq help-echo-owns-message nil + last-help-echo-object nil) + (clear-message 'help-echo)))) + +(defun show-help-echo (mess) + ;; (clear-help-echo) + (setq help-echo-owns-message t) + (display-message 'help-echo mess)) + +(add-hook 'mouse-leave-frame-hook 'clear-help-echo) + +;; It may be a good idea to move this to C, for better performance of +;; extent highlighting and pointer changes. +(defun default-mouse-motion-handler (event) + "For use as the value of `mouse-motion-handler'. +This implements the various pointer-shape variables, +as well as extent highlighting, help-echo, toolbar up/down, +and `mode-motion-hook'." + (let* ((frame (or (event-frame event) (selected-frame))) + (window (event-window event)) + (buffer (event-buffer event)) + (modeline-point (and buffer (event-modeline-position event))) + (modeline-string (and modeline-point + (symbol-value-in-buffer + 'generated-modeline-string buffer))) + ;; point must be invalidated by modeline-point. + (point (and buffer (not modeline-point) + (event-point event))) + (extent (or (and point + (extent-at point buffer 'mouse-face)) + (and modeline-point + (extent-at modeline-point modeline-string + ;; Modeline extents don't have a + ;; mouse-face property set. + 'help-echo)))) + (glyph-extent1 (event-glyph-extent event)) + (glyph-extent (and glyph-extent1 + (extent-live-p glyph-extent1) + glyph-extent1)) + ;; This is an extent: + (user-pointer1 (or (and glyph-extent + (extent-property glyph-extent 'pointer) + glyph-extent) + (and point (extent-at point buffer 'pointer)) + (and modeline-point + (extent-at modeline-point modeline-string + 'pointer)))) + ;; And this should be a glyph: + (user-pointer (and user-pointer1 (extent-live-p user-pointer1) + (extent-property user-pointer1 'pointer))) + (button (event-toolbar-button event)) + (help (or (and glyph-extent (extent-property glyph-extent 'help-echo) + glyph-extent) + (and button (not (null (toolbar-button-help-string button))) + button) + (and point + (extent-at point buffer 'help-echo)) + (and modeline-point + (extent-at modeline-point modeline-string + 'help-echo)))) + ;; vars is a list of glyph variables to check for a pointer + ;; value. + (vars (cond + ;; Checking if button is non-nil is not sufficent + ;; since the pointer could be over a blank portion + ;; of the toolbar. + ((event-over-toolbar-p event) + '(toolbar-pointer-glyph nontext-pointer-glyph + text-pointer-glyph)) + ((or extent glyph-extent) + '(selection-pointer-glyph text-pointer-glyph)) + ((event-over-modeline-p event) + '(modeline-pointer-glyph nontext-pointer-glyph + text-pointer-glyph)) + (point '(text-pointer-glyph)) + (buffer '(nontext-pointer-glyph text-pointer-glyph)) + (t '(nontext-pointer-glyph text-pointer-glyph)))) + pointer) + (and user-pointer (glyphp user-pointer) + (push 'user-pointer vars)) + (while (and vars (not (pointer-image-instance-p pointer))) + (setq pointer (glyph-image-instance (symbol-value (car vars)) + (or window frame)) + vars (cdr vars))) + + (if (pointer-image-instance-p pointer) + (set-frame-pointer frame pointer)) + + ;; If last-pressed-toolbar-button is not nil, then check and see + ;; if we have moved to a new button and adjust the down flags + ;; accordingly. + (when (and (featurep 'toolbar) toolbar-active) + (unless (eq last-pressed-toolbar-button button) + (release-previous-toolbar-button event) + (and button (press-toolbar-button event)))) + + (cond (extent (highlight-extent extent t)) + (glyph-extent (highlight-extent glyph-extent t)) + (t (highlight-extent nil nil))) + (cond ((extentp help) + (or inhibit-help-echo + (eq help last-help-echo-object) ;save some time + (let ((hprop (extent-property help 'help-echo))) + (setq last-help-echo-object help) + (or (stringp hprop) + (setq hprop (funcall hprop help))) + (and hprop (show-help-echo hprop))))) + ((and (featurep 'toolbar) + (toolbar-button-p help) + (toolbar-button-enabled-p help)) + (or (not toolbar-help-enabled) + (eq help last-help-echo-object) ;save some time + (let ((hstring (toolbar-button-help-string button))) + (setq last-help-echo-object help) + (or (stringp hstring) + (setq hstring (funcall hstring help))) + (show-help-echo hstring)))) + (last-help-echo-object + (clear-help-echo))) + (if mouse-grabbed-buffer (setq buffer mouse-grabbed-buffer)) + (if (and buffer (symbol-value-in-buffer 'mode-motion-hook buffer nil)) + (with-current-buffer buffer + (run-hook-with-args 'mode-motion-hook event) + + ;; If the mode-motion-hook created a highlightable extent around + ;; the mouse-point, highlight it right away. Otherwise it wouldn't + ;; be highlighted until the *next* motion event came in. + (if (and point + (null extent) + (setq extent (extent-at point + (event-buffer event) ; not buffer + 'mouse-face))) + (highlight-extent extent t))))) + nil) + +(setq mouse-motion-handler 'default-mouse-motion-handler) + +;;; mouse.el ends here
--- a/lisp/mule/mule-cmds.el Mon Aug 13 10:03:54 2007 +0200 +++ b/lisp/mule/mule-cmds.el Mon Aug 13 10:04:58 2007 +0200 @@ -99,13 +99,12 @@ (setq keyboard-coding-system coding-system) ;;(setq default-process-coding-system (cons coding-system coding-system)) (add-hook 'comint-exec-hook - (lambda () - (let ((proc (get-buffer-process (current-buffer)))) - (set-process-input-coding-system proc coding-system) - (set-process-output-coding-system proc coding-system) - ))) - (setq file-name-coding-system coding-system) - ) + `(lambda () + (let ((proc (get-buffer-process (current-buffer)))) + (set-process-input-coding-system proc ',coding-system) + (set-process-output-coding-system proc ',coding-system))) + 'append) + (setq file-name-coding-system coding-system)) (defun prefer-coding-system (coding-system) "Add CODING-SYSTEM at the front of the priority list for automatic detection.
--- a/lisp/mule/mule-help.el Mon Aug 13 10:03:54 2007 +0200 +++ b/lisp/mule/mule-help.el Mon Aug 13 10:04:58 2007 +0200 @@ -55,19 +55,24 @@ (setq buffer-auto-save-file-name nil) (insert-file-contents (expand-file-name filename data-directory)) (goto-char (point-min)) - (search-forward "\n<<") - (beginning-of-line) - (delete-region (point) (progn (end-of-line) (point))) - (let ((n (- (window-height (selected-window)) - (count-lines (point-min) (point)) - 6))) - (if (< n 12) - (newline n) - ;; Some people get confused by the large gap. - (newline (/ n 2)) - (insert "[Middle of page left blank for didactic purposes. " - "Text continues below]") - (newline (- n (/ n 2))))) + ;; The 'didactic' blank lines: Possibly insert blank lines + ;; around <<nya nya nya>>, and change << >> to [ ]. + (if (re-search-forward "^<<.+>>") + (let ((n (- (window-height (selected-window)) + (count-lines (point-min) (point-at-bol)) + 6))) + (if (< n 12) + (progn (beginning-of-line) (kill-line)) + ;; Some people get confused by the large gap + (delete-backward-char 2) + (insert "]") + (beginning-of-line) + (save-excursion + (delete-char 2) + (insert "[")) + (newline (/ n 2)) + (next-line 1) + (newline (- n (/ n 2)))))) (goto-char (point-min)) (set-buffer-modified-p nil))))
--- a/lisp/mule/mule-init.el Mon Aug 13 10:03:54 2007 +0200 +++ b/lisp/mule/mule-init.el Mon Aug 13 10:04:58 2007 +0200 @@ -66,22 +66,22 @@ ;; MULE keymap codes were moved to mule-cmds.el. -(define-key help-map "T" 'help-with-tutorial-for-mule) +;; (define-key help-map "T" 'help-with-tutorial-for-mule) -(defvar help-with-tutorial-language-alist - '(("Japanese" . ".jp") - ("Korean" . ".kr") - ("Thai" . ".th"))) +;; (defvar help-with-tutorial-language-alist +;; '(("Japanese" . ".jp") +;; ("Korean" . ".kr") +;; ("Thai" . ".th"))) -(defun help-with-tutorial-for-mule (language) - "Select the Mule learn-by-doing tutorial." - (interactive (list (let ((completion-ignore-case t) - lang) - (completing-read - "Language: " - help-with-tutorial-language-alist)))) - (setq language (cdr (assoc language help-with-tutorial-language-alist))) - (help-with-tutorial (concat "mule/TUTORIAL" (or language "")))) +;(defun help-with-tutorial-for-mule (language) +; "Select the Mule learn-by-doing tutorial." +; (interactive (list (let ((completion-ignore-case t) +; lang) +; (completing-read +; "Language: " +; help-with-tutorial-language-alist)))) +; (setq language (cdr (assoc language help-with-tutorial-language-alist))) +; (help-with-tutorial (concat "mule/TUTORIAL" (or language "")))) (defvar auto-language-alist '(("^ja" . "Japanese")
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/objects.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,149 @@ +;;; objects.el --- Lisp interface to C window-system objects + +;; Copyright (C) 1994, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1995 Ben Wing + +;; Author: Chuck Thompson <cthomp@xemacs.org> +;; Author: Ben Wing <wing@666.com> +;; Maintainer: XEmacs Development Team +;; Keywords: faces, internal, dumped + +;; 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, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: Not in FSF. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;;; Code: + +(defun ws-object-property-1 (function object domain &optional matchspec) + (let ((instance (if matchspec + (specifier-matching-instance object matchspec domain) + (specifier-instance object domain)))) + (and instance (funcall function instance)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; font specifiers + +(defun make-font-specifier (spec-list) + "Create a new `font' specifier object with the given specification list. +SPEC-LIST can be a list of specifications (each of which is a cons of a +locale and a list of instantiators), a single instantiator, or a list +of instantiators. See `make-specifier' for more information about +specifiers." + (make-specifier-and-init 'font spec-list)) + +(defun font-name (font &optional domain charset) + "Return the name of the FONT in the specified DOMAIN, if any. +FONT should be a font specifier object and DOMAIN is normally a window +and defaults to the selected window if omitted. This is equivalent +to using `specifier-instance' and applying `font-instance-name' to +the result. See `make-specifier' for more information about specifiers." + (ws-object-property-1 'font-instance-name font domain charset)) + +(defun font-ascent (font &optional domain charset) + "Return the ascent of the FONT in the specified DOMAIN, if any. +FONT should be a font specifier object and DOMAIN is normally a window +and defaults to the selected window if omitted. This is equivalent +to using `specifier-instance' and applying `font-instance-ascent' to +the result. See `make-specifier' for more information about specifiers." + (ws-object-property-1 'font-instance-ascent font domain charset)) + +(defun font-descent (font &optional domain charset) + "Return the descent of the FONT in the specified DOMAIN, if any. +FONT should be a font specifier object and DOMAIN is normally a window +and defaults to the selected window if omitted. This is equivalent +to using `specifier-instance' and applying `font-instance-descent' to +the result. See `make-specifier' for more information about specifiers." + (ws-object-property-1 'font-instance-descent font domain charset)) + +(defun font-width (font &optional domain charset) + "Return the width of the FONT in the specified DOMAIN, if any. +FONT should be a font specifier object and DOMAIN is normally a window +and defaults to the selected window if omitted. This is equivalent +to using `specifier-instance' and applying `font-instance-width' to +the result. See `make-specifier' for more information about specifiers." + (ws-object-property-1 'font-instance-width font domain charset)) + +(defun font-height (font &optional domain charset) + "Return the height of the FONT in the specified DOMAIN, if any. +FONT should be a font specifier object and DOMAIN is normally a window +and defaults to the selected window if omitted. This is equivalent +to using `specifier-instance' and applying `font-instance-height' to +the result. See `make-specifier' for more information about specifiers." + (ws-object-property-1 'font-instance-height font domain charset)) + +(defun font-proportional-p (font &optional domain charset) + "Return whether FONT is proportional in the specified DOMAIN, if known. +FONT should be a font specifier object and DOMAIN is normally a window +and defaults to the selected window if omitted. This is equivalent +to using `specifier-instance' and applying `font-instance-proportional-p' to +the result. See `make-specifier' for more information about specifiers." + (ws-object-property-1 'font-instance-proportional-p font domain charset)) + +(defun font-properties (font &optional domain charset) + "Return the properties of the FONT in the specified DOMAIN, if any. +FONT should be a font specifier object and DOMAIN is normally a window +and defaults to the selected window if omitted. This is equivalent +to using `specifier-instance' and applying `font-instance-properties' +to the result. See `make-specifier' for more information about specifiers." + (ws-object-property-1 'font-instance-properties font domain charset)) + +(defun font-truename (font &optional domain charset) + "Return the truename of the FONT in the specified DOMAIN, if any. +FONT should be a font specifier object and DOMAIN is normally a window +and defaults to the selected window if omitted. This is equivalent +to using `specifier-instance' and applying `font-instance-truename' +to the result. See `make-specifier' for more information about specifiers." + (ws-object-property-1 'font-instance-truename font domain charset)) + +(defun font-instance-height (font-instance) + "Return the height in pixels of FONT-INSTANCE. +The returned value is the maximum height for all characters in the font,\n\ +and is equivalent to the sum of the font instance's ascent and descent." + (+ (font-instance-ascent font-instance) + (font-instance-descent font-instance))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; color specifiers + +(defun make-color-specifier (spec-list) + "Create a new `color' specifier object with the given specification list. +SPEC-LIST can be a list of specifications (each of which is a cons of a +locale and a list of instantiators), a single instantiator, or a list +of instantiators. See `make-specifier' for a detailed description of +how specifiers work." + (make-specifier-and-init 'color spec-list)) + +(defun color-name (color &optional domain) + "Return the name of the COLOR in the specified DOMAIN, if any. +COLOR should be a color specifier object and DOMAIN is normally a window +and defaults to the selected window if omitted. This is equivalent +to using `specifier-instance' and applying `color-instance-name' to +the result. See `make-specifier' for more information about specifiers." + (ws-object-property-1 'color-instance-name color domain)) + +(defun color-rgb-components (color &optional domain) + "Return the RGB components of the COLOR in the specified DOMAIN, if any. +COLOR should be a color specifier object and DOMAIN is normally a window +and defaults to the selected window if omitted. This is equivalent +to using `specifier-instance' and applying `color-instance-rgb-components' +to the result. See `make-specifier' for more information about specifiers." + (ws-object-property-1 'color-instance-rgb-components color domain)) + +;;; objects.el ends here.
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/obsolete.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,700 @@ +;;; obsolete.el --- obsoleteness support + +;; Copyright (C) 1985-1994, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1994, 1995 Amdahl Corporation. +;; Copyright (C) 1995 Sun Microsystems. + +;; Maintainer: XEmacs Development Team +;; Keywords: internal, dumped + +;; 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, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: Not in FSF. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;; The obsoleteness support used to be scattered throughout various +;; source files. We put the stuff in one place to remove the junkiness +;; from other source files and to facilitate creating/updating things +;; like sysdep.el. + +;;; Code: + +(defsubst define-obsolete-function-alias (oldfun newfun) + "Define OLDFUN as an obsolete alias for function NEWFUN. +This makes calling OLDFUN equivalent to calling NEWFUN and marks OLDFUN +as obsolete." + (define-function oldfun newfun) + (make-obsolete oldfun newfun)) + +(defsubst define-compatible-function-alias (oldfun newfun) + "Define OLDFUN as a compatible alias for function NEWFUN. +This makes calling OLDFUN equivalent to calling NEWFUN and marks OLDFUN +as provided for compatibility only." + (define-function oldfun newfun) + (make-compatible oldfun newfun)) + +(defsubst define-obsolete-variable-alias (oldvar newvar) + "Define OLDVAR as an obsolete alias for variable NEWVAR. +This makes referencing or setting OLDVAR equivalent to referencing or +setting NEWVAR and marks OLDVAR as obsolete. +If OLDVAR was bound and NEWVAR was not, Set NEWVAR to OLDVAR. + +Note: Use this before any other references (defvar/defcustom) to NEWVAR" + (let ((needs-setting (and (boundp oldvar) (not (boundp newvar)))) + (value (and (boundp oldvar) (symbol-value oldvar)))) + (defvaralias oldvar newvar) + (make-obsolete-variable oldvar newvar) + (and needs-setting (set newvar value)))) + +(defsubst define-compatible-variable-alias (oldvar newvar) + "Define OLDVAR as a compatible alias for variable NEWVAR. +This makes referencing or setting OLDVAR equivalent to referencing or +setting NEWVAR and marks OLDVAR as provided for compatibility only." + (defvaralias oldvar newvar) + (make-compatible-variable oldvar newvar)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;; device stuff + +(make-compatible-variable 'window-system "use (console-type)") +(make-obsolete-variable 'meta-flag + "use the `set-input-mode' function instead.") + +(defun x-display-color-p (&optional device) + "Returns non-nil if DEVICE is a color device." + (eq 'color (device-class device))) +(make-compatible 'x-display-color-p 'device-class) + +(define-function 'x-color-display-p 'x-display-color-p) +(make-compatible 'x-display-color-p 'device-class) + +(defun x-display-grayscale-p (&optional device) + "Returns non-nil if DEVICE is a grayscale device." + (eq 'grayscale (device-class device))) +(make-compatible 'x-display-grayscale-p 'device-class) + +(define-function 'x-grayscale-display-p 'x-display-grayscale-p) +(make-compatible 'x-display-grayscale-p 'device-class) + +(define-compatible-function-alias 'x-display-pixel-width 'device-pixel-width) +(define-compatible-function-alias 'x-display-pixel-height + 'device-pixel-height) +(define-compatible-function-alias 'x-display-planes 'device-bitplanes) +(define-compatible-function-alias 'x-display-color-cells 'device-color-cells) + +(define-obsolete-function-alias 'baud-rate 'device-baud-rate) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;; events + +(define-obsolete-function-alias 'menu-event-p 'misc-user-event-p) +(make-obsolete-variable 'unread-command-char 'unread-command-events) +(make-obsolete 'sleep-for-millisecs "use sleep-for with a float") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;; extents + +(defun extent-data (extent) + "Obsolete. Returns the `data' property of the given extent." + (extent-property extent 'data)) +(make-obsolete 'set-window-dot 'set-window-point) + +(defun set-extent-data (extent data) + "Obsolete. Sets the `data' property of the given extent." + (set-extent-property extent 'data data)) +(make-obsolete 'set-extent-data 'set-extent-property) + +(define-obsolete-function-alias 'extent-buffer 'extent-object) + +(defun set-extent-attribute (extent attr &optional clearp) + "" ;; obsoleteness info will be displayed, so no need for anything more. + (cond ((eq attr 'write-protected) + (set-extent-property extent 'read-only t)) + ((eq attr 'unhighlight) + (set-extent-property extent 'mouse-face nil)) + ((eq attr 'writable) + (set-extent-property extent 'read-only nil)) + ((eq attr 'visible) + (set-extent-property extent 'invisible nil)) + (t + (set-extent-property extent attr t)))) +(make-obsolete 'set-extent-attribute 'set-extent-property) + +(defun extent-glyph (extent) + "" ;; obsoleteness info will be displayed, so no need for anything more. + (or (extent-begin-glyph extent) + (extent-end-glyph extent))) +(make-obsolete 'extent-glyph + "use `extent-begin-glyph' or `extent-end-glyph' instead.") + +(defun extent-layout (extent) + "" ;; obsoleteness info will be displayed, so no need for anything more. + (extent-begin-glyph-layout extent)) +(make-obsolete 'extent-layout + "use `extent-begin-glyph-layout' or `extent-end-glyph-layout' instead.") + +(defun set-extent-layout (extent layout) + "" ;; obsoleteness info will be displayed, so no need for anything more. + (set-extent-begin-glyph-layout extent layout)) +(make-obsolete 'set-extent-layout + "use `set-extent-begin-glyph-layout' or `set-extent-end-glyph-layout' instead.") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;; frames + +(define-obsolete-variable-alias 'select-screen-hook 'select-frame-hook) +(define-obsolete-variable-alias 'deselect-screen-hook 'deselect-frame-hook) +(define-obsolete-variable-alias 'auto-raise-screen 'auto-raise-frame) +(define-obsolete-variable-alias 'auto-lower-screen 'auto-lower-frame) +(define-obsolete-variable-alias 'get-screen-for-buffer-default-screen-name + 'get-frame-for-buffer-default-frame-name) + +(define-obsolete-function-alias 'buffer-dedicated-screen + 'buffer-dedicated-frame) +(define-obsolete-function-alias 'deiconify-screen 'deiconify-frame) +(define-obsolete-function-alias 'delete-screen 'delete-frame) +(define-obsolete-function-alias 'event-screen 'event-frame) +(define-obsolete-function-alias 'find-file-other-screen 'find-file-other-frame) +(define-obsolete-function-alias 'find-file-read-only-other-screen + 'find-file-read-only-other-frame) +(define-obsolete-function-alias 'live-screen-p 'frame-live-p) +(define-obsolete-function-alias 'screen-height 'frame-height) +(define-obsolete-function-alias 'screen-iconified-p 'frame-iconified-p) +(define-obsolete-function-alias 'screen-list 'frame-list) +(define-obsolete-function-alias 'screen-live-p 'frame-live-p) +(define-obsolete-function-alias 'screen-name 'frame-name) +(define-obsolete-function-alias 'screen-parameters 'frame-parameters) +(define-obsolete-function-alias 'screen-pixel-height 'frame-pixel-height) +(define-obsolete-function-alias 'screen-pixel-width 'frame-pixel-width) +(define-obsolete-function-alias 'screen-root-window 'frame-root-window) +(define-obsolete-function-alias 'screen-selected-window 'frame-selected-window) +(define-obsolete-function-alias 'screen-totally-visible-p + 'frame-totally-visible-p) +(define-obsolete-function-alias 'screen-visible-p 'frame-visible-p) +(define-obsolete-function-alias 'screen-width 'frame-width) +(define-obsolete-function-alias 'screenp 'framep) +(define-obsolete-function-alias 'get-screen-for-buffer 'get-frame-for-buffer) +(define-obsolete-function-alias 'get-screen-for-buffer-noselect + 'get-frame-for-buffer-noselect) +(define-obsolete-function-alias 'get-other-screen 'get-other-frame) +(define-obsolete-function-alias 'iconify-screen 'iconify-frame) +(define-obsolete-function-alias 'lower-screen 'lower-frame) +(define-obsolete-function-alias 'mail-other-screen 'mail-other-frame) +(define-obsolete-function-alias 'make-screen 'make-frame) +(define-obsolete-function-alias 'make-screen-invisible 'make-frame-invisible) +(define-obsolete-function-alias 'make-screen-visible 'make-frame-visible) +(define-obsolete-function-alias 'modify-screen-parameters + 'modify-frame-parameters) +(define-obsolete-function-alias 'new-screen 'new-frame) +(define-obsolete-function-alias 'next-screen 'next-frame) +(define-obsolete-function-alias 'next-multiscreen-window + 'next-multiframe-window) +(define-obsolete-function-alias 'other-screen 'other-frame) +(define-obsolete-function-alias 'previous-screen 'previous-frame) +(define-obsolete-function-alias 'previous-multiscreen-window + 'previous-multiframe-window) +(define-obsolete-function-alias 'raise-screen 'raise-frame) +(define-obsolete-function-alias 'redraw-screen 'redraw-frame) +(define-obsolete-function-alias 'select-screen 'select-frame) +(define-obsolete-function-alias 'selected-screen 'selected-frame) +(define-obsolete-function-alias 'set-buffer-dedicated-screen + 'set-buffer-dedicated-frame) +(define-obsolete-function-alias 'set-screen-height 'set-frame-height) +(define-obsolete-function-alias 'set-screen-position 'set-frame-position) +(define-obsolete-function-alias 'set-screen-size 'set-frame-size) +(define-obsolete-function-alias 'set-screen-width 'set-frame-width) +(define-obsolete-function-alias 'show-temp-buffer-in-current-screen + 'show-temp-buffer-in-current-frame) +(define-obsolete-function-alias 'switch-to-buffer-other-screen + 'switch-to-buffer-other-frame) +(define-obsolete-function-alias 'visible-screen-list 'visible-frame-list) +(define-obsolete-function-alias 'window-screen 'window-frame) +(define-obsolete-function-alias 'x-set-screen-pointer + 'set-frame-pointer) +(define-obsolete-function-alias 'x-set-frame-pointer + 'set-frame-pointer) + +(define-obsolete-variable-alias 'screen-title-format 'frame-title-format) +(define-obsolete-variable-alias 'screen-icon-title-format + 'frame-icon-title-format) +(define-obsolete-variable-alias 'terminal-screen 'terminal-frame) +(define-obsolete-variable-alias 'delete-screen-hook 'delete-frame-hook) +(define-obsolete-variable-alias 'create-screen-hook 'create-frame-hook) +(define-obsolete-variable-alias 'mouse-enter-screen-hook + 'mouse-enter-frame-hook) +(define-obsolete-variable-alias 'mouse-leave-screen-hook + 'mouse-leave-frame-hook) +(define-obsolete-variable-alias 'map-screen-hook 'map-frame-hook) +(define-obsolete-variable-alias 'unmap-screen-hook 'unmap-frame-hook) +(define-obsolete-variable-alias 'default-screen-alist 'default-frame-alist) +(define-obsolete-variable-alias 'default-screen-name 'default-frame-name) +(define-obsolete-variable-alias 'x-screen-defaults 'default-x-frame-alist) + +(defun x-create-screen (parms window-id) + "" + (if (not (eq 'x (device-type (selected-device)))) + (error "Cannot create X frames on non-X device")) + (make-frame (append parms (list (list 'window-id window-id))) + (selected-device))) +(make-obsolete 'x-create-screen 'make-frame) + +(defun frame-first-window (frame) + "Returns the topmost, leftmost window of FRAME. +If omitted, FRAME defaults to the currently selected frame." + (frame-highest-window frame 0)) +(make-compatible 'frame-first-window 'frame-highest-window) + +(define-obsolete-variable-alias 'initial-frame-alist 'initial-frame-plist) +(define-obsolete-variable-alias 'minibuffer-frame-alist + 'minibuffer-frame-plist) +(define-obsolete-variable-alias 'pop-up-frame-alist 'pop-up-frame-plist) +(define-obsolete-variable-alias 'special-display-frame-alist + 'special-display-frame-plist) + +;; Defined in C. + +(define-obsolete-variable-alias 'default-frame-alist 'default-frame-plist) +(define-obsolete-variable-alias 'default-x-frame-alist 'default-x-frame-plist) +(define-obsolete-variable-alias 'default-tty-frame-alist + 'default-tty-frame-plist) + +(make-compatible 'frame-parameters 'frame-property) +(defun frame-parameters (&optional frame) + "Return the parameters-alist of frame FRAME. +It is a list of elements of the form (PARM . VALUE), where PARM is a symbol. +The meaningful PARMs depend on the kind of frame. +If FRAME is omitted, return information on the currently selected frame. + +See the variables `default-frame-plist', `default-x-frame-plist', and +`default-tty-frame-plist' for a description of the parameters meaningful +for particular types of frames." + (or frame (setq frame (selected-frame))) + ;; #### This relies on a `copy-sequence' of the user properties in + ;; `frame-properties'. Removing that would make `frame-properties' more + ;; efficient but this function less efficient, as we couldn't be + ;; destructive. Since most callers now use `frame-parameters', we'll + ;; do it this way. Should probably change this at some point in the + ;; future. + (destructive-plist-to-alist (frame-properties frame))) + +(make-compatible 'modify-frame-parameters 'set-frame-properties) +(defun modify-frame-parameters (frame alist) + "Modify the properties of frame FRAME according to ALIST. +ALIST is an alist of properties to change and their new values. +Each element of ALIST has the form (PARM . VALUE), where PARM is a symbol. +The meaningful PARMs depend on the kind of frame. + +See `set-frame-properties' for built-in property names." + ;; it would be nice to be destructive here but that's not safe. + (set-frame-properties frame (alist-to-plist alist))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;; faces + +(define-obsolete-function-alias 'list-faces-display 'edit-faces) +(define-obsolete-function-alias 'list-faces 'face-list) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;; files + +(make-obsolete-variable 'trim-versions-without-asking 'delete-old-versions) +;;; Old XEmacs name; kept around for compatibility. +(define-obsolete-variable-alias 'after-write-file-hooks 'after-save-hook) +(define-obsolete-function-alias 'truename 'file-truename) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;; hooks + +(make-obsolete-variable 'auto-fill-hook 'auto-fill-function) +(make-obsolete-variable 'blink-paren-hook 'blink-paren-function) +(make-obsolete-variable 'lisp-indent-hook 'lisp-indent-function) +(make-obsolete-variable 'comment-indent-hook 'comment-indent-function) +(make-obsolete-variable 'temp-buffer-show-hook + 'temp-buffer-show-function) +(make-obsolete-variable 'inhibit-local-variables + "use `enable-local-variables' (with the reversed sense).") +(make-obsolete-variable 'suspend-hooks 'suspend-hook) +(make-obsolete-variable 'first-change-function 'first-change-hook) +(make-obsolete-variable 'before-change-function + "use before-change-functions; which is a list of functions rather than a single function.") +(make-obsolete-variable 'after-change-function + "use after-change-functions; which is a list of functions rather than a single function.") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;; insertion and deletion + +(define-compatible-function-alias 'insert-and-inherit 'insert) +(define-compatible-function-alias 'insert-before-markers-and-inherit + 'insert-before-markers) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;; keymaps + +(defun keymap-parent (keymap) + "Returns the first parent of the given keymap." + (car (keymap-parents keymap))) +(make-compatible 'keymap-parent 'keymap-parents) + +(defun set-keymap-parent (keymap parent) + "Makes the given keymap have (only) the given parent." + (set-keymap-parents keymap (if parent (list parent) '())) + parent) +(make-compatible 'set-keymap-parent 'set-keymap-parents) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;; menu stuff + +(defun add-menu-item (menu-path item-name function enabled-p &optional before) + "Obsolete. See the function `add-menu-button'." + (or item-name (error "must specify an item name")) + (add-menu-button menu-path (vector item-name function enabled-p) before)) +(make-obsolete 'add-menu-item 'add-menu-button) + +(defun add-menu (menu-path menu-name menu-items &optional before) + "See the function `add-submenu'." + (or menu-name (error (gettext "must specify a menu name"))) + (or menu-items (error (gettext "must specify some menu items"))) + (add-submenu menu-path (cons menu-name menu-items) before)) +;; Can't make this obsolete. easymenu depends on it. +(make-compatible 'add-menu 'add-submenu) + +(define-obsolete-function-alias 'popup-menu-up-p 'popup-up-p) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;; minibuffer + +(define-compatible-function-alias 'read-minibuffer + 'read-expression) ; misleading name +(define-compatible-function-alias 'read-input 'read-string) +(make-obsolete 'read-no-blanks-input 'read-string) ; mocklisp crud + +;;;;;;;;;;;;;;;;;;;;;;;;;;;; misc + +;; (defun user-original-login-name () +;; "Return user's login name from original login. +;; This tries to remain unaffected by `su', by looking in environment variables." +;; (or (getenv "LOGNAME") (getenv "USER") (user-login-name))) +(define-obsolete-function-alias 'user-original-login-name 'user-login-name) + +; old names +(define-obsolete-function-alias 'wholenump 'natnump) +(define-obsolete-function-alias 'show-buffer 'set-window-buffer) +(define-obsolete-function-alias 'buffer-flush-undo 'buffer-disable-undo) +(define-obsolete-function-alias 'eval-current-buffer 'eval-buffer) +(define-obsolete-function-alias 'byte-code-function-p + 'compiled-function-p) ;FSFmacs + +;;(make-obsolete 'mod '%) ; mod and % are different now + +(make-obsolete 'ring-mod 'mod) + +(make-obsolete 'current-time-seconds 'current-time) +;; too bad there's not a way to check for aref, assq, and nconc +;; being called on the values of functions known to return keymaps, +;; or known to return vectors of events instead of strings... + +(define-obsolete-function-alias 'run-special-hook-with-args + 'run-hook-with-args-until-success) + +(make-obsolete-variable 'executing-macro 'executing-kbd-macro) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;; modeline + +(define-compatible-function-alias 'redraw-mode-line 'redraw-modeline) +(define-compatible-function-alias 'force-mode-line-update + 'redraw-modeline) ;; FSF compatibility +(define-compatible-variable-alias 'mode-line-map 'modeline-map) +(define-compatible-variable-alias 'mode-line-buffer-identification + 'modeline-buffer-identification) +(define-compatible-variable-alias 'mode-line-process 'modeline-process) +(define-compatible-variable-alias 'mode-line-modified 'modeline-modified) +(make-compatible-variable 'mode-line-inverse-video + "use set-face-highlight-p and set-face-reverse-p") +(define-compatible-variable-alias 'default-mode-line-format + 'default-modeline-format) +(define-compatible-variable-alias 'mode-line-format 'modeline-format) +(define-compatible-variable-alias 'mode-line-menu 'modeline-menu) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;; mouse + +;;; (defun mouse-eval-last-sexpr (event) +;;; (interactive "@e") +;;; (save-excursion +;;; (mouse-set-point event) +;;; (eval-last-sexp nil))) + +(define-obsolete-function-alias 'mouse-eval-last-sexpr 'mouse-eval-sexp) + +(defun read-mouse-position (frame) + (cdr (mouse-position (frame-device frame)))) +(make-obsolete 'read-mouse-position 'mouse-position) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;; `point' + +(define-obsolete-function-alias 'dot 'point) +(define-obsolete-function-alias 'dot-marker 'point-marker) +(define-obsolete-function-alias 'dot-min 'point-min) +(define-obsolete-function-alias 'dot-max 'point-max) +(define-obsolete-function-alias 'window-dot 'window-point) +(define-obsolete-function-alias 'set-window-dot 'set-window-point) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;; processes + +(define-obsolete-function-alias 'send-string 'process-send-string) +(define-obsolete-function-alias 'send-region 'process-send-region) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;; redisplay + +(defun redraw-display (&optional device) + (if (eq device t) + (mapcar 'redisplay-device (device-list)) + (redisplay-device device))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;; stuff replaced by specifiers + +(defun screen-scrollbar-width (&optional screen) + ;; specifier-specs is the inverse of set-specifier, but + ;; the way this function was defined, specifier-instance + ;; is closer. + (specifier-instance scrollbar-width (or screen (selected-frame)))) +(make-obsolete 'screen-scrollbar-width + "use (specifier-instance scrollbar-width ...).") + +(defun set-screen-scrollbar-width (screen value) + (set-specifier scrollbar-width (cons screen value))) +(make-obsolete 'set-screen-scrollbar-width + "use (set-specifier scrollbar-width ...).") + +(defun set-screen-left-margin-width (value &optional screen) + (set-specifier left-margin-width + (cons (or screen (selected-frame)) value))) +(make-obsolete 'set-screen-left-margin-width + "use (set-specifier left-margin-width ...).") + +(defun set-screen-right-margin-width (value &optional screen) + (set-specifier right-margin-width + (cons (or screen (selected-frame)) value))) +(make-obsolete 'set-screen-right-margin-width + "use (set-specifier right-margin-width ...).") + +(defun set-buffer-left-margin-width (value &optional buffer) + (set-specifier left-margin-width (cons (or buffer (current-buffer)) value))) +(make-obsolete 'set-buffer-left-margin-width + "use (set-specifier left-margin-width ...).") + +(defun set-buffer-right-margin-width (value &optional buffer) + (set-specifier right-margin-width (cons (or buffer (current-buffer)) value))) +(make-obsolete 'set-buffer-right-margin-width + "use (set-specifier right-margin-width ...).") + +(defun screen-left-margin-width (&optional screen) + (specifier-specs left-margin-width (or screen (selected-frame)))) +(make-obsolete 'screen-left-margin-width + "use (specifier-specs left-margin-width ...).") + +(defun screen-right-margin-width (&optional screen) + (specifier-specs right-margin-width (or screen (selected-frame)))) +(make-obsolete 'screen-right-margin-width + "use (specifier-specs right-margin-width ...).") + +(defun buffer-left-margin-width (&optional buffer) + (specifier-specs left-margin-width (or buffer (current-buffer)))) +(make-obsolete 'buffer-left-margin-width + "use (specifier-specs left-margin-width ...).") + +(defun buffer-right-margin-width (&optional buffer) + (specifier-specs right-margin-width (or buffer (current-buffer)))) +(make-obsolete 'buffer-right-margin-width + "use (specifier-specs right-margin-width ...).") + +(defun x-set-frame-icon-pixmap (frame image-instance &optional mask-ignored) + "Set the icon of the given frame to the given image instance, +which should be an image instance object (as returned by +`make-image-instance'), a glyph object (as returned by `make-glyph'), +or nil. If a glyph object is given, the glyph will be instantiated on +the frame to produce an image instance object. + +If the given image instance has a mask, that will be used as the icon mask; +however, not all window managers support this. + +The window manager is also not required to support color pixmaps, +only bitmaps (one plane deep). + +Optional third argument is ignored. If you're concerned about this +incomplete backwards incompatibility, you should convert your code +to use `frame-icon-glyph' -- you can specify a mask for an XBM file +using the standard image instantiator format." + (if (glyphp image-instance) + (setq image-instance (glyph-image-instance image-instance frame))) + (set-glyph-image frame-icon-glyph image-instance frame)) +(make-obsolete 'x-set-frame-icon-pixmap + "use (set-glyph-image frame-icon-glyph ...).") +(defalias 'x-set-screen-icon-pixmap 'x-set-frame-icon-pixmap) +(make-obsolete 'x-set-screen-icon-pixmap + "use (set-glyph-image frame-icon-glyph ...).") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;; window-system objects + +(define-obsolete-function-alias 'pixel-name 'color-name) + +;; compatibility function -- a front-end to make-glyph +(defun make-pixmap (name &optional locale) + "Create a glyph with NAME as an image specifier and locale LOCALE. +The file should be in `XBM' or `XPM' format. +If the XBMLANGPATH environment variable is set, it will be searched for + matching files. Next, the directories listed in the `x-bitmap-file-path' + variable will be searched (this variable is initialized from the + \"*bitmapFilePath\" resource). Finally, the XEmacs etc/ directory + (the value of `data-directory') will be searched. +The file argument may also be a list of the form (width height data) where + width and height are the size in pixels, and data is a string, containing + the raw bits of the bitmap. (Bitmaps specified this way can only be one bit + deep.) +If compiled with support for XPM, the file argument may also be a string + which is the contents of an XPM file (that is, a string beginning with the + characters \"/* XPM */\"; see the XPM documentation). +The optional second argument is the specifier locale for this pixmap glyph. +The returned object is a glyph object. To get the actual pixmap object for +a given frame, use the function `glyph-instance'." + (if (consp name) + (setq name (vector 'xbm :data name))) + (make-glyph name)) +(make-obsolete 'make-pixmap 'make-glyph) + +(defun make-cursor (name &optional fg bg device) + "Creates a pointer image instance with NAME as an image specifier. +The optional second and third arguments are the foreground and background + colors. They may be color name strings or `pixel' objects. +The optional fourth argument is the device on which to allocate the cursor + (defaults to the selected device). +This allocates a new pointer in the X server, and signals an error if the + pointer is unknown or cannot be allocated. + +A pointer name can take many different forms. It can be: + - any of the standard cursor names from appendix B of the Xlib manual + (also known as the file <X11/cursorfont.h>) minus the XC_ prefix; + - the name of a font, and glyph index into it of the form + \"FONT fontname index [[mask-font] mask-index]\"; + - the name of a bitmap or pixmap file; + - or an image instance object, as returned by `make-image-instance'. + +If it is an image instance or pixmap file, and that pixmap comes with a + mask, then that mask will be used. If it is an image instance, it must + have only one plane, since X pointers may only have two colors. If it is a + pixmap file, then the file will be read in monochrome. + +If it is a bitmap file, and if a bitmap file whose name is the name of the + pointer with \"msk\" or \"Mask\" appended exists, then that second bitmap + will be used as the mask. For example, a pair of files might be named + \"pointer.xbm\" and \"pointer.xbmmsk\". + +The returned object is a normal, first-class lisp object. The way you +`deallocate' the pointer is the way you deallocate any other lisp object: +you drop all pointers to it and allow it to be garbage collected. When +these objects are GCed, the underlying X data is deallocated as well." + ;; #### ignores fg and bg + (make-image-instance name device '(pointer))) +(make-obsolete 'make-cursor 'make-image-instance) + +(define-obsolete-function-alias 'pixmap-width 'glyph-width) +(define-obsolete-function-alias 'pixmap-contributes-to-line-height-p + 'glyph-contrib-p-instance) +(define-obsolete-function-alias 'set-pixmap-contributes-to-line-height + 'set-glyph-contrib-p) + +;; the functionality of column.el has been moved into C +(defalias 'display-column-mode 'column-number-mode) + +(defun x-color-values (color &optional frame) + "Return a description of the color named COLOR on frame FRAME. +The value is a list of integer RGB values--(RED GREEN BLUE). +These values appear to range from 0 to 65280 or 65535, depending +on the system; white is (65280 65280 65280) or (65535 65535 65535). +If FRAME is omitted or nil, use the selected frame." + (color-instance-rgb-components (make-color-instance color))) +(make-compatible 'x-color-values 'color-instance-rgb-components) + +;; Two loser functions which shouldn't be used. +(make-obsolete 'following-char 'char-after) +(make-obsolete 'preceding-char 'char-before) + + +;; The following several functions are useful in GNU Emacs 20 because +;; of the multibyte "characters" the internal representation of which +;; leaks into Lisp. In XEmacs/Mule they are trivial and unnecessary. +;; We provide them for compatibility reasons solely. + +(defun string-to-sequence (string type) + "Convert STRING to a sequence of TYPE which contains characters in STRING. +TYPE should be `list' or `vector'. +Multibyte characters are concerned." + (ecase type + (list + (mapcar #'identity string)) + (vector + (mapvector #'identity string)))) + +(defun string-to-list (string) + "Return a list of characters in STRING." + (mapcar #'identity string)) + +(defun string-to-vector (string) + "Return a vector of characters in STRING." + (mapvector #'identity string)) + +(defun store-substring (string idx obj) + "Embed OBJ (string or character) at index IDX of STRING." + (let* ((str (cond ((stringp obj) obj) + ((characterp obj) (char-to-string obj)) + (t (error + "Invalid argument (should be string or character): %s" + obj)))) + (string-len (length string)) + (len (length str)) + (i 0)) + (while (and (< i len) (< idx string-len)) + (aset string idx (aref str i)) + (setq idx (1+ idx) i (1+ i))) + string)) + +;; ### 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 +;; 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. +The optional 2nd arg START-COLUMN, if non-nil, specifies +the starting column; that means to return the characters occupying +columns START-COLUMN ... END-COLUMN of STR. + +The optional 3rd arg PADDING, if non-nil, specifies a padding character +to add at the end of the result if STR doesn't reach column END-COLUMN, +or if END-COLUMN comes in the middle of a character in STR. +PADDING is also added at the beginning of the result +if column START-COLUMN appears in the middle of a character in STR. + +If PADDING is nil, no padding is added in these cases, so +the resulting string may be narrower than END-COLUMN." + (or start-column + (setq start-column 0)) + (let ((len (length str))) + (concat (substring str (min start-column len) (min end-column len)) + (and padding (> end-column len) + (make-string (- end-column len) padding))))) + +(defalias 'truncate-string 'truncate-string-to-width) +(make-obsolete 'truncate-string 'truncate-string-to-width) + +;; Keywords already do The Right Thing in XEmacs +(make-compatible 'define-widget-keywords "Just use them") + +(make-obsolete 'function-called-at-point 'function-at-point) + +;;; obsolete.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/packages.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,251 @@ +;;; packages.el --- Low level support for XEmacs packages + +;; Copyright (C) 1997 Free Software Foundation, Inc. + +;; Author: Steven L Baur <steve@altair.xemacs.org> +;; Keywords: internal, lisp, dumped + +;; 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: + +;; This file is dumped with XEmacs. + +;; This file provides low level facilities for XEmacs startup -- +;; particularly regarding the package setup. This code has to run in +;; what we call "bare temacs" -- i.e. XEmacs without the usual Lisp +;; environment. Pay special attention: + +;; - not to use the `lambda' macro. Use #'(lambda ...) instead. +;; (this goes for any package loaded before `subr.el'.) +;; +;; - not to use macros, because they are not yet available (and this +;; file must be loadable uncompiled.) This rules out CL-style +;; macros like `when', for instance. +;; +;; - not to use `defcustom'. If you must add user-customizable +;; variables here, use `defvar', and add the variable to +;; `cus-start.el'. + +;; Because of all this, make sure that the stuff you put here really +;; belongs here. + + +;;; Code: + +(defvar autoload-file-name "auto-autoloads.el" + "Filename that autoloads are expected to be found in.") + +(defvar packages-hardcoded-lisp + '( + ;; "startup" + ) + "Lisp packages that are always dumped with XEmacs") + +(defvar packages-useful-lisp + '("bytecomp" + "byte-optimize" + "advice" + "shadow" + "cl-macs") + "Lisp packages that need early byte compilation.") + +(defvar packages-unbytecompiled-lisp + '("paths.el" + "version.el") + "Lisp packages that should not be byte compiled.") + + +;; Copied from help.el, could possibly move it to here permanently. +;; Unlike the FSF version, our `locate-library' uses the `locate-file' +;; primitive, which should make it lightning-fast. + +(defun locate-library (library &optional nosuffix path interactive-call) + "Show the precise file name of Emacs library LIBRARY. +This command searches the directories in `load-path' like `M-x load-library' +to find the file that `M-x load-library RET LIBRARY RET' would load. +Optional second arg NOSUFFIX non-nil means don't add suffixes `.elc' or `.el' +to the specified name LIBRARY. + +If the optional third arg PATH is specified, that list of directories +is used instead of `load-path'." + (interactive (list (read-string "Locate library: ") + nil nil + t)) + (let ((result + (locate-file + library + (or path load-path) + (cond ((or (rassq 'jka-compr-handler file-name-handler-alist) + (and (boundp 'find-file-hooks) + (member 'crypt-find-file-hook find-file-hooks))) + ;; Compression involved. + (if nosuffix + ":.gz:.Z" + ".elc:.elc.gz:elc.Z:.el:.el.gz:.el.Z::.gz:.Z")) + (t + ;; No compression. + (if nosuffix + "" + ".elc:.el:"))) + 4))) + (and interactive-call + (if result + (message "Library is file %s" result) + (message "No library %s in search path" library))) + result)) + +(defun packages-add-suffix (str) + (if (null (string-match "\\.el\\'" str)) + (concat str ".elc") + str)) + +(defun list-autoloads-path () + "List autoloads from precomputed load-path." + (let ((path load-path) + autoloads) + (while path + (if (file-exists-p (concat (car path) + autoload-file-name)) + (setq autoloads (cons (concat (car path) + autoload-file-name) + autoloads))) + (setq path (cdr path))) + autoloads)) + +(defun list-autoloads () + "List autoload files in (what will be) the normal lisp search path. +This function is used during build to find where the global symbol files so +they can be perused for their useful information." + ;; Source directory may not be initialized yet. + ;; (print (prin1-to-string load-path)) + (if (null source-directory) + (setq source-directory (concat (car load-path) "/.."))) + (let ((files (directory-files source-directory t ".*")) + file autolist) + (while (setq file (car-safe files)) + (if (and (file-directory-p file) + (file-exists-p (concat file "/" autoload-file-name))) + (setq autolist (cons (concat file "/" autoload-file-name) + autolist))) + (setq files (cdr files))) + autolist)) + +;; The following function is called from temacs +(defun packages-find-packages-1 (package path-only user-package) + "Search the supplied directory for associated directories. +The top level is assumed to look like: +info/ Contain texinfo files for lisp installed in this hierarchy +etc/ Contain data files for lisp installled in this hiearchy +lisp/ Contain directories which either have straight lisp code + or are self-contained packages of their own. + +This is an internal function. Do not call it after startup." + ;; Info files + (if (and (null path-only) (file-directory-p (concat package "/info"))) + (let ((dir (concat package "/info/"))) + (if (not (member dir Info-default-directory-list)) + (nconc Info-default-directory-list (list dir))))) + ;; Data files + (if (and (null path-only) (file-directory-p (concat package "/etc"))) + (setq data-directory-list + (cons (concat package "/etc/") data-directory-list))) + ;; Lisp files + (if (file-directory-p (concat package "/lisp")) + (progn +; (print (concat "DIR: " +; (if user-package "[USER]" "") +; package +; "/lisp/")) + (setq load-path (cons (concat package "/lisp/") load-path)) + (if user-package + (condition-case nil + (load (concat package "/lisp/" + (file-name-sans-extension autoload-file-name))) + (t nil))) + (let ((dirs (directory-files (concat package "/lisp/") + t "^[^-.]" nil 'dirs-only)) + dir) + (while dirs + (setq dir (car dirs)) +; (print (concat "DIR: " dir "/")) + (setq load-path (cons (concat dir "/") load-path)) + (if user-package + (condition-case nil + (progn +; (print +; (concat dir "/" +; (file-name-sans-extension autoload-file-name))) + (load + (concat dir "/" + (file-name-sans-extension autoload-file-name)))) + (t nil))) + (packages-find-packages-1 dir path-only user-package) + (setq dirs (cdr dirs))))))) + +;; The following function is called from temacs +(defun packages-find-packages (pkg-path path-only &optional suppress-user) + "Search the supplied path for additional info/etc/lisp directories. +Lisp directories if configured prior to build time will have equivalent +status as bundled packages. +If the argument `path-only' is non-nil, only the `load-path' will be set, +otherwise data directories and info directories will be added. +If the optional argument `suppress-user' is non-nil, package directories +rooted in a user login directory (like ~/.xemacs) will not be searched. +This is used at dump time to suppress the builder's local environment." + (let ((path (reverse pkg-path)) + dir) + (while path + (setq dir (car path)) + ;; (prin1 (concat "Find: " (expand-file-name dir) "\n")) + (if (null (and (or suppress-user inhibit-package-init) + (string-match "^~" dir))) + (progn + ;; (print dir) + (packages-find-packages-1 (expand-file-name dir) + path-only + (string-match "^~" dir)))) + (setq path (cdr path))))) + +;; Data-directory is really a list now. Provide something to search it for +;; directories. + +(defun locate-data-directory (name &optional dir-list) + "Locate a directory in a search path DIR-LIST (a list of directories). +If no DIR-LIST is supplied, it defaults to `data-directory-list'." + (unless dir-list + (setq dir-list data-directory-list)) + (let (found found-dir) + (while (and (null found-dir) dir-list) + (setq found (concat (car dir-list) name "/") + found-dir (file-directory-p found)) + (or found-dir + (setq found nil)) + (setq dir-list (cdr dir-list))) + found)) + +;; If we are being loaded as part of being dumped, bootstrap the rest of the +;; load-path for loaddefs. +(if (fboundp 'load-gc) + (packages-find-packages package-path t t)) + +(provide 'packages) + +;;; packages.el ends here
--- a/lisp/packages/auto-save.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,541 +0,0 @@ -;; -*- Emacs-Lisp -*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: auto-save.el -;; Version: $Revision: 1.6 $ -;; RCS: -;; Description: Safer autosaving with support for efs and /tmp. -;; This version of auto-save is designed to work with efs, -;; instead of ange-ftp. -;; Author: Sebastian Kremer <sk@thp.uni-koeln.de>, -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defconst auto-save-version (substring "$Revision: 1.6 $" 11 -2) - "Version number of auto-save.") - -;;; Copyright (C) 1992 by Sebastian Kremer <sk@thp.uni-koeln.de> - -;;; This program is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 1, or (at your option) -;;; any later version. - -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. - -;;; You should have received a copy of the GNU General Public License -;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -;;;; OVERVIEW ========================================================== - -;;; Combines autosaving for efs (to a local or remote directory) -;;; with the ability to do autosaves to a fixed directory on a local -;;; disk, in case NFS is slow. The auto-save file used for -;;; /usr/foo/bar/baz.txt -;;; will be -;;; AUTOSAVE/#\!usr\!foo\!bar\!baz.txt# -;;; assuming AUTOSAVE is the non-nil value of the variable -;;; `auto-save-directory'. - -;;; Takes care that autosave files for non-file-buffers (e.g. *mail*) -;;; from two simultaneous Emacses don't collide. - -;;; Autosaves even if the current directory is not writable. - -;;; Can limit autosave names to 14 characters using a hash function, -;;; see `auto-save-hash-p'. - -;;; See `auto-save-directory' and `make-auto-save-file-name' and -;;; references therein for complete documentation. - -;;; Meta-x recover-all-files will effectively do recover-file on all -;;; files whose autosave file is newer (one of the benefits of having -;;; all autosave files in the same place). - -;;;; INSTALLATION ====================================================== - -;;; Put this file into your load-path and the following in your ~/.emacs: - -;;; If you want to autosave in the fixed directory /tmp/USER-autosave/ -;;; (setq auto-save-directory -;;; (concat "/tmp/" (user-login-name) "-autosave/")) - -;;; If you don't want to save in /tmp (e.g., because it is swap -;;; mounted) but rather in ~/autosave/ -;;; (setq auto-save-directory (expand-file-name "~/autosave/")) - -;;; If you want to save each file in its own directory (the default) -;;; (setq auto-save-directory nil) -;;; You still can take advantage of autosaving efs remote files -;;; in a fixed local directory, `auto-save-directory-fallback' will -;;; be used. - -;;; If you want to use 14 character hashed autosave filenames -;;; (setq auto-save-hash-p t) - -;;; Finally, put this line after the others in your ~/.emacs: -;;; (require 'auto-save) - - -;;;; ACKNOWLEDGEMENT =================================================== - -;;; This code is loosely derived from autosave-in-tmp.el by Jamie -;;; Zawinski <jwz@netscape.com> (the version I had was last modified 22 -;;; dec 90 jwz) and code submitted to ange-ftp-lovers on Sun, 5 Apr -;;; 92 23:20:47 EDT by drw@BOURBAKI.MIT.EDU (Dale R. Worley). -;;; auto-save.el tries to cover the functionality of those two -;;; packages. - -;;; Valuable comments and help from Dale Worley, Andy Norman, Jamie -;;; Zawinski and Sandy Rutherford are gratefully acknowledged. - -;;;; PROVISION ======================================================== - -(provide 'auto-save) - -;;;; CUSTOMIZATION ===================================================== - -(defgroup auto-save nil - "Autosaving with support for efs and /tmp." - :group 'data) - -(put 'auto-save-interval 'custom-type 'integer) -(put 'auto-save-interval 'factory-value '(300)) -(custom-add-to-group 'auto-save 'auto-save-interval 'custom-variable) - -(defcustom auto-save-directory nil - - ;;; Don't make this user-variable-p, it should be set in .emacs and - ;;; left at that. In particular, it should remain constant across - ;;; several Emacs session to make recover-all-files work. - - "If non-nil, fixed directory for autosaving: all autosave files go -there. If this directory does not yet exist at load time, it is -created and its mode is set to 0700 so that nobody else can read your -autosave files. - -If nil, each autosave files goes into the same directory as its -corresponding visited file. - -A non-nil `auto-save-directory' could be on a local disk such as in -/tmp, then auto-saves will always be fast, even if NFS or the -automounter is slow. In the usual case of /tmp being locally mounted, -note that if you run emacs on two different machines, they will not -see each other's auto-save files. - -The value \(expand-file-name \"~/autosave/\"\) might be better if /tmp -is mounted from swap (possible in SunOS, type `df /tmp' to find out) -and thus vanishes after a reboot, or if your system is particularly -thorough when cleaning up /tmp, clearing even non-empty subdirectories. - -It should never be an efs remote filename because that would -defeat `efs-auto-save-remotely'. - -Unless you set `auto-save-hash-p', you shouldn't set this to a -directory in a filesystem that does not support long filenames, since -a file named - - /home/sk/lib/emacs/lisp/auto-save.el - -will have a longish filename like - - AUTO-SAVE-DIRECTORY/#\\!home\\!sk\\!lib\\!emacs\\!lisp\\!auto-save.el# - -as auto save file. - -See also variables `auto-save-directory-fallback', -`efs-auto-save' and `efs-auto-save-remotely'." - :type '(choice (const :tag "Same as file" nil) - directory) - :group 'auto-save) - - -(defcustom auto-save-hash-p nil - "If non-nil, hashed autosave names of length 14 are used. -This is to avoid autosave filenames longer than 14 characters. -The directory used is `auto-save-hash-directory' regardless of -`auto-save-directory'. -Hashing defeats `recover-all-files', you have to recover files -individually by doing `recover-file'." - :type 'boolean - :group 'auto-save) - -;;; This defvar is in efs.el now, but doesn't hurt to give it here as -;;; well so that loading first auto-save.el does not abort. -(or (boundp 'efs-auto-save) (defvar efs-auto-save 0)) -(or (boundp 'efs-auto-save-remotely) (defvar efs-auto-save-remotely nil)) - -(defcustom auto-save-offer-delete nil - "*If non-nil, `recover-all-files' offers to delete autosave files -that are out of date or were dismissed for recovering. -Special value 'always deletes those files silently." - :type '(choice (const :tag "on" t) - (const :tag "off" nil) - (const :tag "Delete silently" always)) - :group 'auto-save) - -;;;; end of customization - - -;;; Preparations to be done at load time - -(defvar auto-save-directory-fallback (expand-file-name "~/autosave/") - ;; not user-variable-p, see above - "Directory used for local autosaving of remote files if -both `auto-save-directory' and `efs-auto-save-remotely' are nil. -Also used if a working directory to be used for autosaving is not writable. -This *must* always be the name of directory that exists or can be -created by you, never nil.") - -(defvar auto-save-hash-directory - (expand-file-name "hash/" (or auto-save-directory - auto-save-directory-fallback)) - "If non-nil, directory used for hashed autosave filenames.") - -(defun auto-save-check-directory (var) - (let ((dir (symbol-value var))) - (if (null dir) - nil - ;; Expand and store back into the variable - (set var (setq dir (expand-file-name dir))) - ;; Make sure directory exists - (if (file-directory-p dir) - nil - ;; Else we create and chmod 0700 the directory - (setq dir (directory-file-name dir)) ; some systems need this - (if (fboundp 'make-directory) ; V19 or tree dired - (make-directory dir) - (call-process "mkdir" nil nil nil dir)) - (set-file-modes dir (* 7 8 8)))))) - -(mapcar (function auto-save-check-directory) - '(auto-save-directory auto-save-directory-fallback)) - -(and auto-save-hash-p - (auto-save-check-directory 'auto-save-hash-directory)) - - -;;; Computing an autosave name for a file and vice versa - -(defun make-auto-save-file-name ();; redefines files.el - ;; auto-save-file-name-p need not be redefined. - - "Return file name to use for auto-saves of current buffer. -Does not consider `auto-save-visited-file-name'; that is checked -before calling this function. - -Offers to autosave all files in the same `auto-save-directory'. All -autosave files can then be recovered at once with function -`recover-all-files'. - -Takes care to make autosave files for files accessed through efs -be local files if variable `efs-auto-save-remotely' is nil. - -Takes care of slashes in buffer names to prevent autosave errors. - -Takes care that autosave files for buffers not visiting any file (such -as `*mail*') from two simultaneous Emacses don't collide by prepending -the Emacs pid. - -Uses 14 character autosave names if `auto-save-hash-p' is true. - -Autosaves even if the current directory is not writable, using -directory `auto-save-directory-fallback'. - -You can redefine this for customization (he he :-). -See also function `auto-save-file-name-p'." - - ;; We have to be very careful about not signalling an error in this - ;; function since files.el does not provide for this (e.g. find-file - ;; would fail for each new file). - - (condition-case error-data - (let* ((file-name (or (and (boundp 'buffer-file-truename) - buffer-file-truename - ;; Make sure that the file name is expanded. - (expand-file-name buffer-file-name)) - (and buffer-file-name - (expand-file-name buffer-file-name)))) - ;; So autosavename looks like #%...#, roughly as with the - ;; old make-auto-save-file-name function. The - ;; make-temp-name inserts the pid of this Emacs: this - ;; avoids autosaving from two Emacses into the same file. - ;; It cannot be recovered automatically then because in - ;; the next Emacs session (the one after the crash) the - ;; pid will be different, but file-less buffers like - ;; *mail* must be recovered manually anyway. - - ;; jwz: putting the emacs PID in the auto-save file name is bad - ;; news, because that defeats auto-save-recovery of *mail* - ;; buffers -- the (sensible) code in sendmail.el calls - ;; (make-auto-save-file-name) to determine whether there is - ;; unsent, auto-saved mail to recover. If that mail came from a - ;; previous emacs process (far and away the most likely case) - ;; then this can never succeed as the pid differs. -;; (name-prefix (if file-name nil (make-temp-name "#%"))) - (name-prefix (if file-name nil "#%")) - - (save-name (or file-name - ;; Prevent autosave errors. Buffername - ;; (to become non-dir part of filename) will - ;; be unslashified twice. Don't care. - (auto-save-unslashify-name (buffer-name)))) - (remote-p (and (stringp file-name) - (fboundp 'efs-ftp-path) - (efs-ftp-path file-name)))) - ;; Return the appropriate auto save file name: - (expand-file-name;; a buffername needs this, a filename not - (if remote-p - (if efs-auto-save-remotely - (auto-save-name-in-same-directory save-name) - ;; We have to use the `fixed-directory' now since the - ;; `same-directory' would be remote. - ;; It will use the fallback if needed. - (auto-save-name-in-fixed-directory save-name)) - ;; Else it is a local file (or a buffer without a file, hence - ;; the name-prefix). - ;; Hashed files always go into the special hash dir, never - ;; in the same directory, to make recognizing reliable. - (if (or auto-save-directory auto-save-hash-p) - (auto-save-name-in-fixed-directory save-name name-prefix) - (auto-save-name-in-same-directory save-name name-prefix))))) - - ;; If any error occurs in the above code, return what the old - ;; version of this function would have done. It is not ok to - ;; return nil, e.g., when after-find-file tests - ;; file-newer-than-file-p, nil would bomb. - - (error (progn - (message "make-auto-save-file-name %s" error-data) - (sit-for 2) - (if buffer-file-name - (concat (file-name-directory buffer-file-name) - "#" - (file-name-nondirectory buffer-file-name) - "#") - (expand-file-name (concat "#%" (buffer-name) "#"))))))) - -(defun auto-save-original-name (savename) - "Reverse of `make-auto-save-file-name'. -Returns nil if SAVENAME was not associated with a file (e.g., it came -from an autosaved `*mail*' buffer) or does not appear to be an -autosave file at all. -Hashed files are not understood, see `auto-save-hash-p'." - (let ((basename (file-name-nondirectory savename)) - (savedir (file-name-directory savename))) - (cond ((or (not (auto-save-file-name-p basename)) - (string-match "^#%" basename)) - nil) - ;; now we know it looks like #...# thus substring is safe to use - ((or (equal savedir auto-save-directory) ; 2nd arg may be nil - (equal savedir auto-save-directory-fallback)) - ;; it is of the `-fixed-directory' type - (auto-save-slashify-name (substring basename 1 -1))) - (t - ;; else it is of `-same-directory' type - (concat savedir (substring basename 1 -1)))))) - -(defun auto-save-name-in-fixed-directory (filename &optional prefix) - ;; Unslashify and enclose the whole FILENAME in `#' to make an auto - ;; save file in the auto-save-directory, or if that is nil, in - ;; auto-save-directory-fallback (which must be the name of an - ;; existing directory). If the results would be too long for 14 - ;; character filenames, and `auto-save-hash-p' is set, hash FILENAME - ;; into a shorter name. - ;; Optional PREFIX is string to use instead of "#" to prefix name. - (let ((base-name (concat (or prefix "#") - (auto-save-unslashify-name filename) - "#"))) - (if (and auto-save-hash-p - auto-save-hash-directory - (> (length base-name) 14)) - (expand-file-name (auto-save-cyclic-hash-14 filename) - auto-save-hash-directory) - (expand-file-name base-name - (or auto-save-directory - auto-save-directory-fallback))))) - -(defun auto-save-name-in-same-directory (filename &optional prefix) - ;; Enclose the non-directory part of FILENAME in `#' to make an auto - ;; save file in the same directory as FILENAME. But if this - ;; directory is not writable, use auto-save-directory-fallback. - ;; FILENAME is assumed to be in non-directory form (no trailing slash). - ;; It may be a name without a directory part (pesumably it really - ;; comes from a buffer name then), the fallback is used then. - ;; Optional PREFIX is string to use instead of "#" to prefix name. - (let ((directory (file-name-directory filename))) - (or (null directory) - (file-writable-p directory) - (setq directory auto-save-directory-fallback)) - (concat directory ; (concat nil) is "" - (or prefix "#") - (file-name-nondirectory filename) - "#"))) - -(defun auto-save-unslashify-name (s) - ;; "Quote any slashes in string S by replacing them with the two - ;;characters `\\!'. - ;;Also, replace any backslash by double backslash, to make it one-to-one." - (let ((limit 0)) - (while (string-match "[/\\]" s limit) - (setq s (concat (substring s 0 (match-beginning 0)) - (if (string= (substring s - (match-beginning 0) - (match-end 0)) - "/") - "\\!" - "\\\\") - (substring s (match-end 0)))) - (setq limit (1+ (match-end 0))))) - s) - -(defun auto-save-slashify-name (s) - ;;"Reverse of `auto-save-unslashify-name'." - (let (pos) - (while (setq pos (string-match "\\\\[\\!]" s pos)) - (setq s (concat (substring s 0 pos) - (if (eq ?! (aref s (1+ pos))) "/" "\\") - (substring s (+ pos 2))) - pos (1+ pos)))) - s) - - -;;; Hashing for autosave names - -;;; Hashing function contributed by Andy Norman <ange@hplb.hpl.hp.com> -;;; based upon C code from pot@fly.cnuce.cnr.IT (Francesco Potorti`). - -(defun auto-save-cyclic-hash-14 (s) - ;; "Hash string S into a string of length 14. - ;; A 7-bytes cyclic code for burst correction is calculated on a - ;; byte-by-byte basis. The polynomial used is D^7 + D^6 + D^3 +1. - ;; The resulting string consists of hexadecimal digits [0-9a-f]. - ;; In particular, it contains no slash, so it can be used as autosave name." - (let ((crc (make-string 7 0)) - result) - (mapcar - (function - (lambda (new) - (setq new (+ new (aref crc 6))) - (aset crc 6 (+ (aref crc 5) new)) - (aset crc 5 (aref crc 4)) - (aset crc 4 (aref crc 3)) - (aset crc 3 (+ (aref crc 2) new)) - (aset crc 2 (aref crc 1)) - (aset crc 1 (aref crc 0)) - (aset crc 0 new))) - s) - (setq result (format "%02x%02x%02x%02x%02x%02x%02x" - (aref crc 0) - (aref crc 1) - (aref crc 2) - (aref crc 3) - (aref crc 4) - (aref crc 5) - (aref crc 6))) - result)) - -;; This leaves two characters that could be used to wrap it in `#' or -;; make two filenames from it: one for autosaving, and another for a -;; file containing the name of the autosaved filed, to make hashing -;; reversible. -(defun auto-save-cyclic-hash-12 (s) - "Outputs the 12-characters ascii hex representation of a 6-bytes -cyclic code for burst correction calculated on STRING on a -byte-by-byte basis. The used polynomial is D^6 + D^5 + D^4 + D^3 +1." - (let ((crc (make-string 6 0))) - (mapcar - (function - (lambda (new) - (setq new (+ new (aref crc 5))) - (aset crc 5 (+ (aref crc 4) new)) - (aset crc 4 (+ (aref crc 3) new)) - (aset crc 3 (+ (aref crc 2) new)) - (aset crc 2 (aref crc 1)) - (aset crc 1 (aref crc 0)) - (aset crc 0 new))) - s) - (format "%02x%02x%02x%02x%02x%02x" - (aref crc 0) - (aref crc 1) - (aref crc 2) - (aref crc 3) - (aref crc 4) - (aref crc 5)))) - - - -;;; Recovering files - -(defun recover-all-files (&optional silent) - "Do recover-file for all autosave files which are current. -Only works if you have a non-nil `auto-save-directory'. - -Optional prefix argument SILENT means to be silent about non-current -autosave files. This is useful if invoked automatically at Emacs -startup. - -If `auto-save-offer-delete' is t, this function will offer to delete -old or rejected autosave files. - -Hashed files (see `auto-save-hash-p') are not understood, use -`recover-file' to recover them individually." - (interactive "P") - (let ((savefiles (directory-files auto-save-directory t "^#")) - afile ; the auto save file - file ; its original file - (total 0) ; # of files offered to recover - (count 0)) ; # of files actually recovered - (or (equal auto-save-directory auto-save-directory-fallback) - (setq savefiles - (append savefiles - (directory-files auto-save-directory-fallback t "^#")))) - (while savefiles - (setq afile (car savefiles) - file (auto-save-original-name afile) - savefiles (cdr savefiles)) - (cond ((and file (not (file-newer-than-file-p afile file))) - (message "autosave file \"%s\" is not current." afile) - (sit-for 2)) - (t - (setq total (1+ total)) - (with-output-to-temp-buffer "*Directory*" - (apply 'call-process "ls" nil standard-output nil - "-l" afile (if file (list file)))) - (if (yes-or-no-p (format "Recover %s from auto save file? " - (or file "non-file buffer"))) - (let* ((obuf (current-buffer)) - (buf (set-buffer - (if file - (find-file-noselect file t) - (generate-new-buffer "*recovered*")))) - (buffer-read-only nil)) - (erase-buffer) - (insert-file-contents afile nil) - (condition-case () - (after-find-file nil) - (error nil)) - (setq buffer-auto-save-file-name nil) - (setq count (1+ count)) - (message "\ -Auto-save off in buffer \"%s\" till you do M-x auto-save-mode." - (buffer-name)) - (set-buffer obuf) - (sit-for 1)) - ;; If not used for recovering, offer to delete - ;; autosave file - (and auto-save-offer-delete - (or (eq 'always auto-save-offer-delete) - (yes-or-no-p - (format "Delete autosave file for `%s'? " file))) - (delete-file afile)))))) - (if (zerop total) - (or silent (message "Nothing to recover.")) - (message "%d/%d file%s recovered." count total (if (= count 1) "" "s")))) - (if (get-buffer "*Directory*") (kill-buffer "*Directory*"))) - -;;; end of auto-save.el
--- a/lisp/packages/balloon-help.el Mon Aug 13 10:03:54 2007 +0200 +++ b/lisp/packages/balloon-help.el Mon Aug 13 10:04:58 2007 +0200 @@ -494,20 +494,22 @@ frame) (set-window-buffer (frame-selected-window frame) balloon-help-buffer) (set-specifier has-modeline-p (cons frame nil)) - (set-specifier top-toolbar-height (cons frame 0)) - (set-specifier left-toolbar-width (cons frame 0)) - (set-specifier right-toolbar-width (cons frame 0)) - (set-specifier bottom-toolbar-height (cons frame 0)) - (set-specifier top-toolbar-visible-p (cons frame nil)) - (set-specifier left-toolbar-visible-p (cons frame nil)) - (set-specifier right-toolbar-visible-p (cons frame nil)) - (set-specifier bottom-toolbar-visible-p (cons frame nil)) - (set-specifier top-toolbar (cons frame nil)) - (set-specifier left-toolbar (cons frame nil)) - (set-specifier right-toolbar (cons frame nil)) - (set-specifier bottom-toolbar (cons frame nil)) - (set-specifier scrollbar-width (cons frame 0)) - (set-specifier scrollbar-height (cons frame 0)) + (when (featurep 'toolbar) + (set-specifier top-toolbar-height (cons frame 0)) + (set-specifier left-toolbar-width (cons frame 0)) + (set-specifier right-toolbar-width (cons frame 0)) + (set-specifier bottom-toolbar-height (cons frame 0)) + (set-specifier top-toolbar-visible-p (cons frame nil)) + (set-specifier left-toolbar-visible-p (cons frame nil)) + (set-specifier right-toolbar-visible-p (cons frame nil)) + (set-specifier bottom-toolbar-visible-p (cons frame nil)) + (set-specifier top-toolbar (cons frame nil)) + (set-specifier left-toolbar (cons frame nil)) + (set-specifier right-toolbar (cons frame nil)) + (set-specifier bottom-toolbar (cons frame nil))) + (when (featurep 'scrollbar) + (set-specifier scrollbar-width (cons frame 0)) + (set-specifier scrollbar-height (cons frame 0))) (set-specifier text-cursor-visible-p (cons frame nil)) (set-specifier has-modeline-p (cons frame nil)) (set-specifier modeline-shadow-thickness (cons frame 0))
--- a/lisp/packages/buff-menu.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,637 +0,0 @@ -;;; buff-menu.el --- buffer menu main function and support functions. - -;; Copyright (C) 1985, 86, 87, 93, 94, 95 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: extensions - -;; 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.34 except as noted. - -;;; Commentary: - -;; Edit, delete, or change attributes of all currently active Emacs -;; buffers from a list summarizing their state. A good way to browse -;; any special or scratch buffers you have loaded, since you can't find -;; them by filename. The single entry point is `Buffer-menu-mode', -;; normally bound to C-x C-b. - -;;; Change Log: - -;; Merged by esr with recent mods to Emacs 19 buff-menu, 23 Mar 1993 -;; -;; Modified by Bob Weiner, Motorola, Inc., 4/14/89 -;; -;; Added optional backup argument to 'Buffer-menu-unmark' to make it undelete -;; current entry and then move to previous one. -;; -;; Based on FSF code dating back to 1985. - -;;; Code: - -;;;Trying to preserve the old window configuration works well in -;;;simple scenarios, when you enter the buffer menu, use it, and exit it. -;;;But it does strange things when you switch back to the buffer list buffer -;;;with C-x b, later on, when the window configuration is different. -;;;The choice seems to be, either restore the window configuration -;;;in all cases, or in no cases. -;;;I decided it was better not to restore the window config at all. -- rms. - -;;;But since then, I changed buffer-menu to use the selected window, -;;;so q now once again goes back to the previous window configuration. - -;;;(defvar Buffer-menu-window-config nil -;;; "Window configuration saved from entry to `buffer-menu'.") - -; Put buffer *Buffer List* into proper mode right away -; so that from now on even list-buffers is enough to get a buffer menu. - -(defvar Buffer-menu-buffer-column 4) - -(defvar Buffer-menu-mode-map nil "") - -(if Buffer-menu-mode-map - () - (setq Buffer-menu-mode-map (make-keymap)) - (suppress-keymap Buffer-menu-mode-map t) - (set-keymap-name Buffer-menu-mode-map 'Buffer-menu-mode-map) ; XEmacs - (define-key Buffer-menu-mode-map "q" 'Buffer-menu-quit) - (define-key Buffer-menu-mode-map "v" 'Buffer-menu-select) - (define-key Buffer-menu-mode-map "2" 'Buffer-menu-2-window) - (define-key Buffer-menu-mode-map "1" 'Buffer-menu-1-window) - (define-key Buffer-menu-mode-map "f" 'Buffer-menu-this-window) - (define-key Buffer-menu-mode-map "\C-m" 'Buffer-menu-this-window) - (define-key Buffer-menu-mode-map "o" 'Buffer-menu-other-window) - (define-key Buffer-menu-mode-map "\C-o" 'Buffer-menu-switch-other-window) - (define-key Buffer-menu-mode-map "s" 'Buffer-menu-save) - (define-key Buffer-menu-mode-map "d" 'Buffer-menu-delete) - (define-key Buffer-menu-mode-map "k" 'Buffer-menu-delete) - (define-key Buffer-menu-mode-map "\C-d" 'Buffer-menu-delete-backwards) - (define-key Buffer-menu-mode-map "\C-k" 'Buffer-menu-delete) - (define-key Buffer-menu-mode-map "x" 'Buffer-menu-execute) - (define-key Buffer-menu-mode-map " " 'next-line) - (define-key Buffer-menu-mode-map "n" 'next-line) - (define-key Buffer-menu-mode-map "p" 'previous-line) - (define-key Buffer-menu-mode-map 'backspace 'Buffer-menu-backup-unmark) - (define-key Buffer-menu-mode-map 'delete 'Buffer-menu-backup-unmark) - (define-key Buffer-menu-mode-map "~" 'Buffer-menu-not-modified) - (define-key Buffer-menu-mode-map "?" 'describe-mode) - (define-key Buffer-menu-mode-map "u" 'Buffer-menu-unmark) - (define-key Buffer-menu-mode-map "m" 'Buffer-menu-mark) - (define-key Buffer-menu-mode-map "t" 'Buffer-menu-visit-tags-table) - (define-key Buffer-menu-mode-map "%" 'Buffer-menu-toggle-read-only) - (define-key Buffer-menu-mode-map "g" 'revert-buffer) - (define-key Buffer-menu-mode-map 'button2 'Buffer-menu-mouse-select) - (define-key Buffer-menu-mode-map 'button3 'Buffer-menu-popup-menu) - ) - -;; Buffer Menu mode is suitable only for specially formatted data. -(put 'Buffer-menu-mode 'mode-class 'special) - -(defun Buffer-menu-mode () - "Major mode for editing a list of buffers. -Each line describes one of the buffers in Emacs. -Letters do not insert themselves; instead, they are commands. -\\<Buffer-menu-mode-map> -\\[Buffer-menu-mouse-select] -- select buffer you click on, in place of the buffer menu. -\\[Buffer-menu-this-window] -- select current line's buffer in place of the buffer menu. -\\[Buffer-menu-other-window] -- select that buffer in another window, - so the buffer menu buffer remains visible in its window. -\\[Buffer-menu-switch-other-window] -- make another window display that buffer. -\\[Buffer-menu-mark] -- mark current line's buffer to be displayed. -\\[Buffer-menu-select] -- select current line's buffer. - Also show buffers marked with m, in other windows. -\\[Buffer-menu-1-window] -- select that buffer in full-frame window. -\\[Buffer-menu-2-window] -- select that buffer in one window, - together with buffer selected before this one in another window. -\\[Buffer-menu-visit-tags-table] -- visit-tags-table this buffer. -\\[Buffer-menu-not-modified] -- clear modified-flag on that buffer. -\\[Buffer-menu-save] -- mark that buffer to be saved, and move down. -\\[Buffer-menu-delete] -- mark that buffer to be deleted, and move down. -\\[Buffer-menu-delete-backwards] -- mark that buffer to be deleted, and move up. -\\[Buffer-menu-execute] -- delete or save marked buffers. -\\[Buffer-menu-unmark] -- remove all kinds of marks from current line. - With prefix argument, also move up one line. -\\[Buffer-menu-backup-unmark] -- back up a line and remove marks. -\\[Buffer-menu-toggle-read-only] -- toggle read-only status of buffer on this line." - (kill-all-local-variables) - (use-local-map Buffer-menu-mode-map) - (setq major-mode 'Buffer-menu-mode) - (setq mode-name "Buffer Menu") - (make-local-variable 'revert-buffer-function) - (setq revert-buffer-function 'Buffer-menu-revert-function) - (setq truncate-lines t) - (setq buffer-read-only t) - (make-local-variable 'mouse-track-click-hook) ; XEmacs - (add-hook 'mouse-track-click-hook 'Buffer-menu-maybe-mouse-select) ; XEmacs - (run-hooks 'buffer-menu-mode-hook)) - -(defun Buffer-menu-revert-function (ignore1 ignore2) - (list-buffers)) - -(defun Buffer-menu-buffer (error-if-non-existent-p) - "Return buffer described by this line of buffer menu." - (let* ((where (save-excursion - (beginning-of-line) - (+ (point) Buffer-menu-buffer-column))) - (name (and (not (eobp)) (get-text-property where 'buffer-name)))) - (if name - (or (get-buffer name) - (if error-if-non-existent-p - (error "No buffer named `%s'" name) - nil)) - (if error-if-non-existent-p - (error "No buffer on this line") - nil)))) - -(defun buffer-menu (&optional arg) - "Make a menu of buffers so you can save, delete or select them. -With argument, show only buffers that are visiting files. -Type ? after invocation to get help on commands available. -Type q immediately to make the buffer menu go away." - (interactive "P") -;;; (setq Buffer-menu-window-config (current-window-configuration)) - (switch-to-buffer (list-buffers-noselect arg)) - (message - "Commands: d, s, x, u; f, o, 1, 2, m, v; ~, %%; q to quit; ? for help.")) - -(defun buffer-menu-other-window (&optional arg) - "Display a list of buffers in another window. -With the buffer list buffer, you can save, delete or select the buffers. -With argument, show only buffers that are visiting files. -Type ? after invocation to get help on commands available. -Type q immediately to make the buffer menu go away." - (interactive "P") -;;; (setq Buffer-menu-window-config (current-window-configuration)) - (switch-to-buffer-other-window (list-buffers-noselect arg)) - (message - "Commands: d, s, x, u; f, o, 1, 2, m, v; ~, %%; q to quit; ? for help.")) - -(defun Buffer-menu-quit () - "Quit the buffer menu." - (interactive) - (let ((buffer (current-buffer))) - ;; Switch away from the buffer menu and bury it. - (switch-to-buffer (other-buffer)) - (bury-buffer buffer))) - -(defun Buffer-menu-mark () - "Mark buffer on this line for being displayed by \\<Buffer-menu-mode-map>\\[Buffer-menu-select] command." - (interactive) - (beginning-of-line) - (if (looking-at " [-M]") - (ding) - (let ((buffer-read-only nil)) - (delete-char 1) - (insert ?>) - (forward-line 1)))) - -(defun Buffer-menu-unmark (&optional backup) - "Cancel all requested operations on buffer on this line and move down. -Optional ARG means move up." - (interactive "P") - (beginning-of-line) - (if (looking-at " [-M]") - (ding) - (let* ((buf (Buffer-menu-buffer t)) - (mod (buffer-modified-p buf)) - (readonly (save-excursion (set-buffer buf) buffer-read-only)) - (buffer-read-only nil)) - (delete-char 3) - (insert (if readonly (if mod " *%" " %") (if mod " * " " "))))) - (forward-line (if backup -1 1))) - -(defun Buffer-menu-backup-unmark () - "Move up and cancel all requested operations on buffer on line above." - (interactive) - (forward-line -1) - (Buffer-menu-unmark) - (forward-line -1)) - -(defun Buffer-menu-delete (&optional arg) - "Mark buffer on this line to be deleted by \\<Buffer-menu-mode-map>\\[Buffer-menu-execute] command. -Prefix arg is how many buffers to delete. -Negative arg means delete backwards." - (interactive "p") - (beginning-of-line) - (if (looking-at " [-M]") ;header lines - (ding) - (let ((buffer-read-only nil)) - (if (or (null arg) (= arg 0)) - (setq arg 1)) - (while (> arg 0) - (delete-char 1) - (insert ?D) - (forward-line 1) - (setq arg (1- arg))) - (while (< arg 0) - (delete-char 1) - (insert ?D) - (forward-line -1) - (setq arg (1+ arg)))))) - -(defun Buffer-menu-delete-backwards (&optional arg) - "Mark buffer on this line to be deleted by \\<Buffer-menu-mode-map>\\[Buffer-menu-execute] command -and then move up one line. Prefix arg means move that many lines." - (interactive "p") - (Buffer-menu-delete (- (or arg 1))) - (while (looking-at " [-M]") - (forward-line 1))) - -(defun Buffer-menu-save () - "Mark buffer on this line to be saved by \\<Buffer-menu-mode-map>\\[Buffer-menu-execute] command." - (interactive) - (beginning-of-line) - (if (looking-at " [-M]") ;header lines - (ding) - (let ((buffer-read-only nil)) - (forward-char 1) - (delete-char 1) - (insert ?S) - (forward-line 1)))) - -(defun Buffer-menu-not-modified (&optional arg) - "Mark buffer on this line as unmodified (no changes to save)." - (interactive "P") - (save-excursion - (set-buffer (Buffer-menu-buffer t)) - (set-buffer-modified-p arg)) - (save-excursion - (beginning-of-line) - (forward-char 1) - (if (= (char-after (point)) (if arg ? ?*)) - (let ((buffer-read-only nil)) - (delete-char 1) - (insert (if arg ?* ? )))))) - -(defun Buffer-menu-execute () - "Save and/or delete buffers marked with \\<Buffer-menu-mode-map>\\[Buffer-menu-save] or \\<Buffer-menu-mode-map>\\[Buffer-menu-delete] commands." - (interactive) - (save-excursion - (goto-char (point-min)) - (forward-line 1) - (while (re-search-forward "^.S" nil t) - (let ((modp nil)) - (save-excursion - (set-buffer (Buffer-menu-buffer t)) - (save-buffer) - (setq modp (buffer-modified-p))) - (let ((buffer-read-only nil)) - (delete-char -1) - (insert (if modp ?* ? )))))) - (save-excursion - (goto-char (point-min)) - (forward-line 1) - (let ((buff-menu-buffer (current-buffer)) - (buffer-read-only nil)) - (while (search-forward "\nD" nil t) - (forward-char -1) - (let ((buf (Buffer-menu-buffer nil))) - (or (eq buf nil) - (eq buf buff-menu-buffer) - (save-excursion (kill-buffer buf)))) - (if (Buffer-menu-buffer nil) - (progn (delete-char 1) - (insert ? )) - (delete-region (point) (progn (forward-line 1) (point))) - (forward-char -1)))))) - -(defun Buffer-menu-select () - "Select this line's buffer; also display buffers marked with `>'. -You can mark buffers with the \\<Buffer-menu-mode-map>\\[Buffer-menu-mark] command. -This command deletes and replaces all the previously existing windows -in the selected frame." - (interactive) - (let ((buff (Buffer-menu-buffer t)) - (menu (current-buffer)) - (others ()) - tem) - (goto-char (point-min)) - (while (search-forward "\n>" nil t) - (setq tem (Buffer-menu-buffer t)) - (let ((buffer-read-only nil)) - (delete-char -1) - (insert ?\ )) - (or (eq tem buff) (memq tem others) (setq others (cons tem others)))) - (setq others (nreverse others) - tem (/ (1- (frame-height)) (1+ (length others)))) - (delete-other-windows) - (switch-to-buffer buff) - (or (eq menu buff) - (bury-buffer menu)) - (if (equal (length others) 0) - (progn -;;; ;; Restore previous window configuration before displaying -;;; ;; selected buffers. -;;; (if Buffer-menu-window-config -;;; (progn -;;; (set-window-configuration Buffer-menu-window-config) -;;; (setq Buffer-menu-window-config nil))) - (switch-to-buffer buff)) - (while others - (split-window nil tem) - (other-window 1) - (switch-to-buffer (car others)) - (setq others (cdr others))) - (other-window 1) ;back to the beginning! -))) - - - -(defun Buffer-menu-visit-tags-table () - "Visit the tags table in the buffer on this line. See `visit-tags-table'." - (interactive) - (let ((file (buffer-file-name (Buffer-menu-buffer t)))) - (if file - (visit-tags-table file) - (error "Specified buffer has no file")))) - -(defun Buffer-menu-1-window () - "Select this line's buffer, alone, in full frame." - (interactive) - (switch-to-buffer (Buffer-menu-buffer t)) - (bury-buffer (other-buffer)) - (delete-other-windows) - ;; XEmacs: - ;; This is to get w->force_start set to nil. Don't ask me, I only work here. - (set-window-buffer (selected-window) (current-buffer))) - -(defun Buffer-menu-mouse-select (event) - "Select the buffer whose line you click on." - (interactive "e") - (let (buffer) - (save-excursion - (set-buffer (event-buffer event)) ; XEmacs - (save-excursion - (goto-char (event-point event)) ; XEmacs - (setq buffer (Buffer-menu-buffer t)))) - (select-window (event-window event)) ; XEmacs - (if (and (window-dedicated-p (selected-window)) - (eq (selected-window) (frame-root-window))) - (switch-to-buffer-other-frame buffer) - (switch-to-buffer buffer)))) - -;; XEmacs -(defun Buffer-menu-maybe-mouse-select (event &optional click-count) - (interactive "e") - (and (>= click-count 2) - (let ((buffer (current-buffer)) - (point (point)) - (config (current-window-configuration))) - (condition-case nil - (progn - (Buffer-menu-mouse-select event) - t) - (error - (set-window-configuration config) - (set-buffer buffer) - (goto-char point) - nil))))) - -(defun Buffer-menu-this-window () - "Select this line's buffer in this window." - (interactive) - (switch-to-buffer (Buffer-menu-buffer t))) - -(defun Buffer-menu-other-window () - "Select this line's buffer in other window, leaving buffer menu visible." - (interactive) - (switch-to-buffer-other-window (Buffer-menu-buffer t))) - -(defun Buffer-menu-switch-other-window () - "Make the other window select this line's buffer. -The current window remains selected." - (interactive) - (display-buffer (Buffer-menu-buffer t))) - -(defun Buffer-menu-2-window () - "Select this line's buffer, with previous buffer in second window." - (interactive) - (let ((buff (Buffer-menu-buffer t)) - (menu (current-buffer)) - (pop-up-windows t)) - (delete-other-windows) - (switch-to-buffer (other-buffer)) - (pop-to-buffer buff) - (bury-buffer menu))) - -(defun Buffer-menu-toggle-read-only () - "Toggle read-only status of buffer on this line, perhaps via version control." - (interactive) - (let (char) - (save-excursion - (set-buffer (Buffer-menu-buffer t)) - (vc-toggle-read-only) - (setq char (if buffer-read-only ?% ? ))) - (save-excursion - (beginning-of-line) - (forward-char 2) - (if (/= (following-char) char) - (let (buffer-read-only) - (delete-char 1) - (insert char)))))) - -;; XEmacs -(defvar Buffer-menu-popup-menu - '("Buffer Commands" - ["Select Buffer" Buffer-menu-select t] - ["Select buffer Other Window" Buffer-menu-other-window t] - ["Clear Buffer Modification Flag" Buffer-menu-not-modified t] - "----" - ["Mark Buffer for Selection" Buffer-menu-mark t] - ["Mark Buffer for Save" Buffer-menu-save t] - ["Mark Buffer for Deletion" Buffer-menu-delete t] - ["Unmark Buffer" Buffer-menu-unmark t] - "----" - ["Delete/Save Marked Buffers" Buffer-menu-execute t] - )) - -;; XEmacs -(defun Buffer-menu-popup-menu (event) - (interactive "e") - (mouse-set-point event) - (beginning-of-line) - (let ((buffer (Buffer-menu-buffer nil))) - (if buffer - (popup-menu - (nconc (list (car Buffer-menu-popup-menu) - (concat - "Commands on buffer \"" (buffer-name buffer) "\":") - "----") - (cdr Buffer-menu-popup-menu))) - (error "no buffer on this line")))) - - -;; XEmacs -(defvar list-buffers-header-line - (purecopy (concat " MR Buffer Size Mode File\n" - " -- ------ ---- ---- ----\n"))) - -;; XEmacs -(defvar list-buffers-identification 'default-list-buffers-identification - "String used to identify this buffer, or a function of one argument -to generate such a string. This variable is always buffer-local.") -(make-variable-buffer-local 'list-buffers-identification) - -;; XEmacs -;;;###autoload -(defvar list-buffers-directory nil) - -;;;###autoload -(make-variable-buffer-local 'list-buffers-directory) - -;; #### not synched -(defun default-list-buffers-identification (output) - (save-excursion - (let ((file (or (buffer-file-name (current-buffer)) - (and (boundp 'list-buffers-directory) - list-buffers-directory))) - (size (buffer-size)) - (mode mode-name) - eob p s col) - (set-buffer output) - (end-of-line) - (setq eob (point)) - (prin1 size output) - (setq p (point)) - ;; right-justify the size - (move-to-column 19 t) - (setq col (point)) - (if (> eob col) - (goto-char eob)) - (setq s (- 6 (- p col))) - (while (> s 0) ; speed/consing tradeoff... - (insert ? ) - (setq s (1- s))) - (end-of-line) - (indent-to 27 1) - (insert mode) - (if (not file) - nil - ;; if the mode-name is really long, clip it for the filename - (if (> 0 (setq s (- 39 (current-column)))) - (delete-char (max s (- eob (point))))) - (indent-to 40 1) - (insert file))))) - -;; #### not synched -(defun list-buffers-internal (output &optional predicate) - (let ((current (current-buffer)) - (buffers (buffer-list))) - (save-excursion - (set-buffer output) - (setq buffer-read-only nil) - (erase-buffer) - (buffer-disable-undo output) - (insert list-buffers-header-line) - - (while buffers - (let* ((col1 19) - (buffer (car buffers)) - (name (buffer-name buffer)) - this-buffer-line-start) - (setq buffers (cdr buffers)) - (cond ((null name)) ;deleted buffer - ((and predicate - (not (if (stringp predicate) - (string-match predicate name) - (funcall predicate buffer)))) - nil) - (t - (set-buffer buffer) - (let ((ro buffer-read-only) - (id list-buffers-identification)) - (set-buffer output) - (setq this-buffer-line-start (point)) - (insert (if (eq buffer current) - (progn (setq current (point)) ?\.) - ?\ )) - (insert (if (buffer-modified-p buffer) - ?\* - ?\ )) - (insert (if ro - ?\% - ?\ )) - (if (string-match "[\n\"\\ \t]" name) - (let ((print-escape-newlines t)) - (prin1 name output)) - (insert ?\ name)) - (indent-to col1 1) - (cond ((stringp id) - (insert id)) - (id - (set-buffer buffer) - (condition-case e - (funcall id output) - (error - (princ "***" output) (prin1 e output))) - (set-buffer output) - (goto-char (point-max))))) - (put-nonduplicable-text-property this-buffer-line-start - (point) - 'buffer-name name) - (put-nonduplicable-text-property this-buffer-line-start - (point) - 'highlight t) - (insert ?\n))))) - - (Buffer-menu-mode) - (if (not (bufferp current)) - (goto-char current))))) -;(define-key ctl-x-map "\C-b" 'list-buffers) - -(defun list-buffers (&optional files-only) - "Display a list of names of existing buffers. -The list is displayed in a buffer named `*Buffer List*'. -Note that buffers with names starting with spaces are omitted. -Non-null optional arg FILES-ONLY means mention only file buffers. - -The M column contains a * for buffers that are modified. -The R column contains a % for buffers that are read-only." - (interactive (list (if current-prefix-arg t nil))) ; XEmacs - (display-buffer (list-buffers-noselect files-only))) - -;; #### not synched -(defun list-buffers-noselect (&optional files-only) - "Create and return a buffer with a list of names of existing buffers. -The buffer is named `*Buffer List*'. -Note that buffers with names starting with spaces are omitted. -Non-null optional arg FILES-ONLY means mention only file buffers. - -The M column contains a * for buffers that are modified. -The R column contains a % for buffers that are read-only." - (let ((buffer (get-buffer-create "*Buffer List*"))) - (list-buffers-internal buffer - (if (memq files-only '(t nil)) - #'(lambda (b) - (let ((n (buffer-name b))) - (cond ((and (/= 0 (length n)) - (= (aref n 0) ?\ )) - ;;don't mention if starts with " " - nil) - (files-only - (buffer-file-name b)) - (t - t)))) - files-only)) - buffer)) - -(provide 'buff-menu) - -;;; buff-menu.el ends here
--- a/lisp/packages/custom-load.el Mon Aug 13 10:03:54 2007 +0200 +++ b/lisp/packages/custom-load.el Mon Aug 13 10:04:58 2007 +0200 @@ -19,7 +19,6 @@ (custom-add-loads 'environment '("gnuserv")) (custom-add-loads 'texinfo '("texnfo-tex")) (custom-add-loads 'terminals '("gnuserv")) -(custom-add-loads 'auto-save '("auto-save")) (custom-add-loads 'ispell '("ispell")) (custom-add-loads 'mail '("feedmail" "metamail" "supercite")) (custom-add-loads 'ps-print-face '("ps-print")) @@ -51,7 +50,7 @@ (custom-add-loads 'local '("gopher")) (custom-add-loads 'keyboard '("pending-del")) (custom-add-loads 'hyper-apropos-faces '("hyper-apropos")) -(custom-add-loads 'data '("auto-save" "jka-compr" "saveplace" "tar-mode" "time-stamp")) +(custom-add-loads 'data '("jka-compr" "saveplace" "tar-mode" "time-stamp")) (custom-add-loads 'ps-print '("ps-print")) (custom-add-loads 'compression '("jka-compr")) (custom-add-loads 'comm '("gopher"))
--- a/lisp/packages/desktop.el Mon Aug 13 10:03:54 2007 +0200 +++ b/lisp/packages/desktop.el Mon Aug 13 10:04:58 2007 +0200 @@ -104,7 +104,7 @@ (eval-when-compile ;; We use functions from these modules ;; We can't (require 'mh-e) since that wants to load something. - (mapcar 'require '(info dired reporter))) + (require 'info)) ;; ---------------------------------------------------------------------------- ;; USER OPTIONS -- settings you might want to play with. ;; ----------------------------------------------------------------------------
--- a/lisp/packages/font-lock.el Mon Aug 13 10:03:54 2007 +0200 +++ b/lisp/packages/font-lock.el Mon Aug 13 10:04:58 2007 +0200 @@ -1204,7 +1204,9 @@ (cond ((and (boundp 'fast-lock-mode) fast-lock-mode) (fast-lock-mode -1)) ((and (boundp 'lazy-lock-mode) lazy-lock-mode) - (lazy-lock-mode -1)))) + (lazy-lock-mode -1)) + ((and (boundp 'lazy-shot-mode) lazy-shot-mode) + (lazy-shot-mode -1)))) ;; Do something special for these packages after fontifying. I prefer a hook. (defun font-lock-after-fontify-buffer ()
--- a/lisp/packages/hyper-apropos.el Mon Aug 13 10:03:54 2007 +0200 +++ b/lisp/packages/hyper-apropos.el Mon Aug 13 10:04:58 2007 +0200 @@ -304,7 +304,11 @@ (insert-char ?\ (let ((l (- 30 (length (format "%S" fn))))) (if (natnump l) l 0))) (and hyper-apropos-show-brief-docs - (setq doc (documentation fn)) + (setq doc + ;; A symbol's function slot can point to an unbound symbol. + ;; In that case, `documentation' will fail. + (ignore-errors + (documentation fn))) (if (string-match "^([^\n\t )]+[\t ]*\\([^\n)]+\\)?)\\(:[\t ]*\\|\n?\\'\\)" doc)
--- a/lisp/packages/info.el Mon Aug 13 10:03:54 2007 +0200 +++ b/lisp/packages/info.el Mon Aug 13 10:04:58 2007 +0200 @@ -1907,7 +1907,7 @@ (defun Info-elisp-ref (func) "Look up an Emacs Lisp function in the Elisp manual in the Info system. This command is designed to be used whether you are already in Info or not." - (interactive (let ((fn (funcall find-function-function)) + (interactive (let ((fn (function-at-point)) (enable-recursive-minibuffers t) val) (setq val (completing-read
--- a/lisp/packages/ps-print.el Mon Aug 13 10:03:54 2007 +0200 +++ b/lisp/packages/ps-print.el Mon Aug 13 10:04:58 2007 +0200 @@ -2728,7 +2728,10 @@ (if (and (boundp 'lazy-lock-mode) lazy-lock-mode) (if (fboundp 'lazy-lock-fontify-region) (lazy-lock-fontify-region start end) ; the new - (lazy-lock-fontify-buffer)))) ; the old + (lazy-lock-fontify-buffer))) ; the old + (if (and (boundp 'lazy-shot-mode) lazy-shot-mode) ;; temporary untill + (lazy-shot-fontify-region start end))) ;; lazy-shot is renamed + (defun ps-generate-postscript-with-faces (from to) ;; Build the reference lists of faces if necessary.
--- a/lisp/packages/rcompile.el Mon Aug 13 10:03:54 2007 +0200 +++ b/lisp/packages/rcompile.el Mon Aug 13 10:04:58 2007 +0200 @@ -192,6 +192,6 @@ ;; compilation-parse-errors will find referenced files by ange-ftp. (save-excursion (set-buffer compilation-last-buffer) - (setq comint-file-name-prefix (concat "/" host ":"))))) + (setq comint-file-name-prefix (concat "/" user "@" host ":"))))) ;;; rcompile.el ends here
--- a/lisp/packages/remote.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,304 +0,0 @@ -;; remote.el version 2.6 -;; -;; Module to do remote editing via rcp. Assume .rhosts files are -;; set up properly on both machines. -;; Modeled after ftp.el by MLY.PREP.AI.MIT.EDU -;; -;; Nick Tran -;; University of Minnesota -;; Summer 87 -;; -;;; Synched up with: Not in FSF. - -;; Almost complete rewrite. Added minor mode support, better -;; defaults, rewrote find-remote-file, wrote read-remote-file-name, -;; insert-remote-file, find-file, find-alternate-remote-file, -;; get-remote-file-or-buffer, get-remote-buffer, process-wait, -;; remote-rcp-error. Also general clean up, error handling, etc. -;; Eric Raible Wednesday Sept 5, 1988 -;; -;; Automatically set major mode, added prefix arg support for most -;; file operations to toggle sense of remote editing. -;; Eric Raible Thursday October 6, 1988 -;; -;; Manipulate buffer name more appropriately -;; Eric Raible Friday October 7, 1988 -;; -;; For write-remote-file, allow default of file part of remote name. -;; Eric Raible Tuesday October 11, 1988 - -(defvar default-remote-host "navier:" - "The host to use for remote file operations when none other is appropriate.") - -(defvar track-default-remote-host t - "Controls whether default-remote-host is changed after reading a remote file name. -When non-nil, default-remote-host will have the value of the last remote host read.") - -(make-variable-buffer-local 'buffer-remote-file-name) -(set-default 'buffer-remote-file-name "") -(make-variable-buffer-local 'remote-editing) - -(defvar rcp (cond ((file-exists-p "/bin/rcp") "/bin/rcp") - ((file-exists-p "/usr/bsd/rcp") "/usr/bsd/rcp") - (t "rcp"))) - -(if (assoc 'remote-editing minor-mode-alist) - () - (setq minor-mode-alist (cons '(remote-editing " Remote") minor-mode-alist))) - -(defun remote-editing (arg) - "Toggle remote-editing mode. -With arg, turn on remote editing mode iff arg is positive, otherwise just toggle it. - -In remote editing mode, the normal bindings for find-file, -find-file-read-only, find-alternate-file, save-buffer, write-file, -and insert-file are changed to operate on a remote system by default. - -When remote editing, a prefix arg allows local file operations. When not -remote editing, a prefix arg allows remote file operations. - -It is assumed that .rhosts files are set up properly on both machines." - (interactive "P") - (setq remote-editing - (if (null arg) (not remote-editing) - (> (prefix-numeric-value arg) 0))) - (set-buffer-modified-p (buffer-modified-p))) ;No-op, but updates mode line. - -(global-set-key "\C-xr" 'remote-editing) - -;;; -;;; Macro used as front-end to normal file operation key bindings to decide between -;;; local and remote modes. Automatically constructs doc string and includes prefix arg -;;; to temporarily toggle sense of remote-editing. -;;; -(defmacro def-local-or-remote (binding name remote local) - (let ((r (symbol-name (eval remote))) - (l (symbol-name (eval local)))) - (list 'progn - (list 'global-set-key binding (list 'quote name)) - (list 'defun name '(arg) - (concat "Call either " r " or " l ". -If remote-editing (which see), call " r ", else call " l ". - -See also the documentation for " r " and " l ".") - '(interactive "P") - (list 'call-interactively - (list 'if '(xor remote-editing arg) - remote - local)))))) - -(def-local-or-remote "\C-x\C-f" find-local-or-remote-file 'find-remote-file 'find-file) -(def-local-or-remote "\C-x\C-r" find-local-or-remote-file-read-only 'find-remote-file-read-only 'find-file-read-only) -(def-local-or-remote "\C-x\C-v" find-alternate-local-or-remote-file 'find-alternate-remote-file 'find-alternate-file) -(def-local-or-remote "\C-x\C-s" save-local-or-remote-buffer 'save-remote-buffer 'save-buffer) -(def-local-or-remote "\C-x\C-w" write-local-or-remote-file 'write-remote-file 'write-file) -(def-local-or-remote "\C-xi" insert-local-or-remote-file 'insert-remote-file 'insert-file) - -(defun find-remote-file (host file) - "Edit remote file HOST:FILE (using rcp). -This command is similiar to find-file, but uses rcp to read the file from -a remote machine. Also see remote-editing." - (interactive (read-remote-file-name "Find remote file")) - (let ((buffer-or-file (get-remote-file-or-buffer host file "retrieve")) - local-file) - (if buffer-or-file - (if (bufferp buffer-or-file) - (switch-to-buffer buffer-or-file) - (setq local-file buffer-or-file) - (let ((buf (generate-new-buffer - (concat host (file-name-nondirectory file))))) - (switch-to-buffer buf) - (if (not (file-exists-p local-file)) - (message "(New remote file)") - (insert-file-contents local-file) - (set-buffer-modified-p nil) - (delete-file local-file)) - ;; dynamic binding for normal-mode - (let ((buffer-file-name (concat host file))) - (normal-mode) - (remote-editing 1) - (setq buffer-remote-file-name buffer-file-name - buffer-offer-save t))))))) - -(defun find-remote-file-read-only () - "Edit remote file FILENAME, but mark buffer as read-only. -Also see find-remote-file and remote-editing." - (interactive) - (call-interactively 'find-remote-file) - (setq buffer-read-only t)) - -(defun find-alternate-remote-file () - "Find alternate file using rcp. -This command is similiar to find-alternate-file, but uses rcp to read the file from -a remote machine. Also see remote-editing." - (interactive) - (and (buffer-modified-p) - (not buffer-read-only) - (not (yes-or-no-p (format "Buffer %s is modified; kill anyway? " - (buffer-name)))) - (error "Aborted")) - (let ((obuf (current-buffer)) - (oname (buffer-name))) - (rename-buffer " **lose**") - (unwind-protect - (apply 'find-remote-file - (read-remote-file-name "Find remote alternate file")) - (if (eq obuf (current-buffer)) - (rename-buffer oname) - (kill-buffer obuf))))) - -(defun save-remote-buffer () - "Save a file using rcp. -This command is similiar to save-buffer, but uses rcp to write the file back -to a remote machine. Also see remote-editing." - (interactive) - (if (buffer-modified-p) - (if (zerop (length buffer-remote-file-name)) - (call-interactively 'write-remote-file) - (do-write-remote-file buffer-remote-file-name)) - (message "(No changes need to be saved)"))) - -(defun write-remote-file (host file) - "Write a file HOST:FILE using rcp. -This command is similiar to write-file, but uses rcp to write the file back -to a remote machine. Also see remote-editing." - (interactive (read-remote-file-name "Write remote file" 'no-file-ok)) - (do-write-remote-file (concat host file))) - -(defun insert-remote-file (host file) - "Insert a remote file HOST:FILE using rcp. -This command is similiar to insert-file, but uses rcp to read the file from -a remote machine. Also see remote-editing." - (interactive (read-remote-file-name "Insert remote file")) - (let ((f-or-b (get-remote-file-or-buffer host file "insert"))) - (if f-or-b - (if (bufferp f-or-b) - (insert-buffer f-or-b) - (insert-file f-or-b) - (delete-file f-or-b))))) - -;;; -;;; Internal routines -;;; - -(defun do-write-remote-file (file) - (let* ((temp (concat "/tmp/" (buffer-name))) - (output (save-excursion - (prog1 (set-buffer (get-buffer-create "*Rcp Output*")) - (erase-buffer)))) - (cursor-in-echo-area t) - time) - ;; write-file doesn't quite do it. - (save-restriction - (widen) - (write-region (point-min) (point-max) temp nil 'no-message)) - (message "Sending %s..." file) - (if (setq time (process-wait (start-process "rcp" output rcp temp file))) - (progn - (if remote-editing - (let ((new-name (concat (host-part-only file) - (file-name-nondirectory (file-part-only file))))) - (or (get-buffer new-name) (rename-buffer new-name)) - (set-buffer-modified-p nil))) - (setq buffer-remote-file-name file) - (message "%d bytes in %d seconds" (buffer-size) time) - (delete-file temp)) - (remote-rcp-error output buffer-remote-file-name "update")))) - -(defun get-remote-file-or-buffer (host file message) - "Return a remote file as either a buffer or a file. -If the file HOST:FILE already has been read in, return the buffer -that contains it; otherwise try and rcp the file to the local machine. -If successful, return the local file name." - (let ((remote (concat host file)) - (temp (concat "/tmp/" (file-name-nondirectory file))) - time) - (if (string= file (file-name-directory file)) - (progn - (message "Remote directory listing not yet implemented") - nil) - (or (get-remote-buffer remote) ;; already exists - (let* ((output (save-excursion - (prog1 (set-buffer (get-buffer-create "*Rcp Output*")) - (erase-buffer)))) - (cursor-in-echo-area t)) - (message "Retrieving %s..." remote) - (if (setq time (process-wait (start-process "rcp" output rcp remote temp))) - (progn - (message "%d bytes in %d seconds" - (nth 7 (file-attributes temp)) time) - temp) - (remote-rcp-error output remote message))))))) - -(defun get-remote-buffer (name) - (save-window-excursion - (let ((buffers (buffer-list)) found) - (while (and (not found) buffers) - (set-buffer (car buffers)) - (if (string= name buffer-remote-file-name) - (setq found (car buffers))) - (setq buffers (cdr buffers))) - found))) - -(defun read-remote-file-name (prompt &optional no-file-ok) - "Read a remote file specification, and return list (host file). -Prompting with PROMPT, read a string of the form host:file. The default -value is derived from the remote file name, or if there is none, then -from the global default (default-remote-host)." - (let* ((host (or (host-part-only buffer-remote-file-name) - default-remote-host)) - (result (concat host (file-name-directory - (or (file-part-only buffer-remote-file-name) - "")))) - (prompt (concat prompt " (host:file): ")) - file) - (setq result (read-no-blanks-input prompt result)) - (while (not (string-match (if no-file-ok - ".+:" - ".+:.+") - result)) - (setq result (read-no-blanks-input prompt result))) - (setq host (host-part-only result) - file (file-part-only result)) - (and track-default-remote-host - (setq default-remote-host host)) - (list host - (if (or (null file) (string= file (file-name-directory file))) - (concat file (or (if (not (string= buffer-remote-file-name "")) - (file-name-nondirectory - (file-part-only buffer-remote-file-name))) - (file-part-only (buffer-name)) - (buffer-name))) - file)))) - -(defun host-part-only (name) - (if (string-match ".+:" name) - (substring name 0 (match-end 0)))) - -(defun file-part-only (name) - (if (string-match ".+:\\(.+\\)" name) - (substring name (match-beginning 1) (match-end 1)))) - -(defun xor (a b) - (eq (null a) (not (null b)))) - -(defun process-wait (proc) - (let ((time 0)) - (while (eq (process-status proc) 'run) - (setq time (1+ time)) - (sleep-for 1)) - (if (and (eq (process-status proc) 'exit) - (eq (process-exit-status proc) 0)) - time - nil))) - -(defun remote-rcp-error (buffer file-name message) - (save-window-excursion - (switch-to-buffer buffer) - (delete-other-windows) - (goto-char 1) - (insert (format "Unable to %s %s\n\n" message file-name)) - (goto-char (point-max)) - (message "Hit any character to continue") - (read-char) - (bury-buffer buffer)))
--- a/lisp/packages/tar-mode.el Mon Aug 13 10:03:54 2007 +0200 +++ b/lisp/packages/tar-mode.el Mon Aug 13 10:04:58 2007 +0200 @@ -562,10 +562,11 @@ (cond ((string-match "XEmacs" emacs-version) (require 'mode-motion) (setq mode-motion-hook 'mode-motion-highlight-line) - (if (and current-menubar (not (assoc "Tar" current-menubar))) - (progn - (set-buffer-menubar (copy-sequence current-menubar)) - (add-menu nil "Tar" (cdr tar-menu)))) + (when (and (boundp 'current-menubar) + current-menubar + (not (assoc "Tar" current-menubar))) + (set-buffer-menubar (copy-sequence current-menubar)) + (add-menu nil "Tar" (cdr tar-menu))) )) (run-hooks 'tar-mode-hook) )
--- a/lisp/packages/time.el Mon Aug 13 10:03:54 2007 +0200 +++ b/lisp/packages/time.el Mon Aug 13 10:04:58 2007 +0200 @@ -183,7 +183,7 @@ :group 'display-time :type 'boolean) -(defvar display-time-icons-dir (concat data-directory "time/")) +(defvar display-time-icons-dir (locate-data-directory "time")) (defcustom display-time-mail-sign-string " Mail" "The string used as mail indicator in the echo area @@ -225,7 +225,7 @@ (string :tag "Color"))) (defcustom display-time-mail-balloon 'display-time-mail-balloon - "What to use to generate the ballon frame of the \"mail\" glyph + "What to use to generate the balloon frame of the \"mail\" glyph if balloon-help is loaded. This can be the function display-time-mail-balloon, nil or a string." :group 'display-time-balloon @@ -234,7 +234,7 @@ (string))) (defcustom display-time-no-mail-balloon "No mail is good mail." - "The string used in the ballon frame of the \"no mail\" glyph + "The string used in the balloon frame of the \"no mail\" glyph if balloon-help is loaded. This can also be nil" :group 'display-time-balloon :type '(choice (const nil) @@ -273,13 +273,13 @@ (defcustom display-time-mail-balloon-from-width 20 "The width of the `From:' part of the mail balloon. -You need to have ballon-help loaded to use this" +You need to have balloon-help loaded to use this" :group 'display-time-balloon :type 'number) (defcustom display-time-mail-balloon-subject-width 25 "The width of the `Subject:' part of the mail balloon. -You need to have ballon-help loaded to use this" +You need to have balloon-help loaded to use this" :group 'display-time-balloon :type 'number) @@ -288,7 +288,7 @@ This denotes the mail group gnus would decide to put this message in. For getting this information, it consults the relevant variables from gnus (nnmail-split-methods). -You need to have ballon-help loaded to use this" +You need to have balloon-help loaded to use this" :group 'display-time-balloon :type 'number)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/page.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,157 @@ +;;; page.el --- page motion commands for emacs. + +;; Copyright (C) 1985, 1997 Free Software Foundation, Inc. + +;; Maintainer: FSF +;; Keywords: extensions, dumped + +;; 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.34. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;; This code provides the page-oriented movement and selection commands +;; documented in the XEmacs Reference Manual. + +;;; Code: + +(defun forward-page (&optional count) + "Move forward to page boundary. With arg, repeat, or go back if negative. +A page boundary is any line whose beginning matches the regexp +`page-delimiter'." + (interactive "_p") ; XEmacs + (or count (setq count 1)) + (while (and (> count 0) (not (eobp))) + ;; In case the page-delimiter matches the null string, + ;; don't find a match without moving. + (if (bolp) (forward-char 1)) + (if (re-search-forward page-delimiter nil t) + nil + (goto-char (point-max))) + (setq count (1- count))) + (while (and (< count 0) (not (bobp))) + ;; In case the page-delimiter matches the null string, + ;; don't find a match without moving. + (and (save-excursion (re-search-backward page-delimiter nil t)) + (= (match-end 0) (point)) + (goto-char (match-beginning 0))) + (forward-char -1) + (if (re-search-backward page-delimiter nil t) + ;; We found one--move to the end of it. + (goto-char (match-end 0)) + ;; We found nothing--go to beg of buffer. + (goto-char (point-min))) + (setq count (1+ count)))) + +(defun backward-page (&optional count) + "Move backward to page boundary. With arg, repeat, or go fwd if negative. +A page boundary is any line whose beginning matches the regexp +`page-delimiter'." + (interactive "_p") ; XEmacs + (or count (setq count 1)) + (forward-page (- count))) + +(defun mark-page (&optional arg) + "Put mark at end of page, point at beginning. +A numeric arg specifies to move forward or backward by that many pages, +thus marking a page other than the one point was originally in." + (interactive "P") + (setq arg (if arg (prefix-numeric-value arg) 0)) + (if (> arg 0) + (forward-page arg) + (if (< arg 0) + (forward-page (1- arg)))) + (forward-page) + (push-mark nil t t) + (forward-page -1)) + +(defun narrow-to-page (&optional arg) + "Make text outside current page invisible. +A numeric arg specifies to move forward or backward by that many pages, +thus showing a page other than the one point was originally in." + (interactive "P") + (setq arg (if arg (prefix-numeric-value arg) 0)) + (save-excursion + (widen) + (if (> arg 0) + (forward-page arg) + (if (< arg 0) + (forward-page (1- arg)))) + ;; Find the end of the page. + (forward-page) + ;; If we stopped due to end of buffer, stay there. + ;; If we stopped after a page delimiter, put end of restriction + ;; at the beginning of that line. + (if (save-excursion + (goto-char (match-beginning 0)) ; was (beginning-of-line) + (looking-at page-delimiter)) + (beginning-of-line)) + (narrow-to-region (point) + (progn + ;; Find the top of the page. + (forward-page -1) + ;; If we found beginning of buffer, stay there. + ;; If extra text follows page delimiter on same line, + ;; include it. + ;; Otherwise, show text starting with following line. + (if (and (eolp) (not (bobp))) + (forward-line 1)) + (point))))) +(put 'narrow-to-page 'disabled t) + +(defun count-lines-page () + "Report number of lines on current page, and how many are before or after point." + (interactive "_") ; XEmacs + (save-excursion + (let ((opoint (point)) beg end + total before after) + (forward-page) + (beginning-of-line) + (or (looking-at page-delimiter) + (end-of-line)) + (setq end (point)) + (backward-page) + (setq beg (point)) + (setq total (count-lines beg end) + before (count-lines beg opoint) + after (count-lines opoint end)) + (message "Page has %d lines (%d + %d)" total before after)))) + +(defun what-page () + "Print page and line number of point." + (interactive "_") ; XEmacs + (save-restriction + (widen) + (save-excursion + (beginning-of-line) + (let ((count 1) + (opoint (point))) + (goto-char 1) + (while (re-search-forward page-delimiter opoint t) + (setq count (1+ count))) + (message "Page %d, line %d" + count + (1+ (count-lines (point) opoint))))))) + +;;; Place `provide' at end of file. +(provide 'page) + +;;; page.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/paragraphs.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,354 @@ +;;; paragraphs.el --- paragraph and sentence parsing. + +;; Copyright (C) 1985, 86, 87, 91, 94, 95, 97 Free Software Foundation, Inc. + +;; Maintainer: FSF +;; Keywords: wp, dumped + +;; 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.34. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;; This package provides the paragraph-oriented commands documented in the +;; XEmacs Reference Manual. + +;; 06/11/1997 - Use char-(after|before) instead of +;; (following|preceding)-char. -slb + +;;; Code: + +(defvar use-hard-newlines nil + "Non-nil means to distinguish hard and soft newlines. +When this is non-nil, the functions `newline' and `open-line' add the +text-property `hard' to newlines that they insert. Also, a line is +only considered as a candidate to match `paragraph-start' or +`paragraph-separate' if it follows a hard newline. Newlines not +marked hard are called \"soft\", and are always internal to +paragraphs. The fill functions always insert soft newlines. + +Each buffer has its own value of this variable.") +(make-variable-buffer-local 'use-hard-newlines) + +;; XEmacs - use purecopy +(defconst paragraph-start (purecopy "[ \t\n\f]") "\ +*Regexp for beginning of a line that starts OR separates paragraphs. +This regexp should match lines that separate paragraphs +and should also match lines that start a paragraph +\(and are part of that paragraph). + +This is matched against the text at the left margin, which is not necessarily +the beginning of the line, so it should never use \"^\" as an anchor. This +ensures that the paragraph functions will work equally well within a region +of text indented by a margin setting. + +The variable `paragraph-separate' specifies how to distinguish +lines that start paragraphs from lines that separate them. + +If the variable `use-hard-newlines' is non-nil, then only lines following a +hard newline are considered to match.") + +;; paragraph-start requires a hard newline, but paragraph-separate does not: +;; It is assumed that paragraph-separate is distinctive enough to be believed +;; whenever it occurs, while it is reasonable to set paragraph-start to +;; something very minimal, even including "." (which makes every hard newline +;; start a new paragraph). + +;; XEmacs -- use purecopy +(defconst paragraph-separate (purecopy "[ \t\f]*$") "\ +*Regexp for beginning of a line that separates paragraphs. +If you change this, you may have to change paragraph-start also. + +This is matched against the text at the left margin, which is not necessarily +the beginning of the line, so it should not use \"^\" as an anchor. This +ensures that the paragraph functions will work equally within a region of +text indented by a margin setting.") + +;; XEmacs -- use purecopy +(defconst sentence-end (purecopy "[.?!][]\"')}]*\\($\\| $\\|\t\\| \\)[ \t\n]*") "\ +*Regexp describing the end of a sentence. +All paragraph boundaries also end sentences, regardless. + +In order to be recognized as the end of a sentence, the ending period, +question mark, or exclamation point must be followed by two spaces, +unless it's inside some sort of quotes or parenthesis.") + +;; XEmacs -- use purecopy +(defconst page-delimiter (purecopy "^\014") "\ +*Regexp describing line-beginnings that separate pages.") + +(defvar paragraph-ignore-fill-prefix nil "\ +Non-nil means the paragraph commands are not affected by `fill-prefix'. +This is desirable in modes where blank lines are the paragraph delimiters.") + +(defun forward-paragraph (&optional arg) + "Move forward to end of paragraph. +With arg N, do it N times; negative arg -N means move backward N paragraphs. + +A line which `paragraph-start' matches either separates paragraphs +\(if `paragraph-separate' matches it also) or is the first line of a paragraph. +A paragraph end is the beginning of a line which is not part of the paragraph +to which the end of the previous line belongs, or the end of the buffer." + (interactive "_p") ; XEmacs + (or arg (setq arg 1)) + (let* ((fill-prefix-regexp + (and fill-prefix (not (equal fill-prefix "")) + (not paragraph-ignore-fill-prefix) + (regexp-quote fill-prefix))) + ;; Remove ^ from paragraph-start and paragraph-sep if they are there. + ;; These regexps shouldn't be anchored, because we look for them + ;; starting at the left-margin. This allows paragraph commands to + ;; work normally with indented text. + ;; This hack will not find problem cases like "whatever\\|^something". + (paragraph-start (if (and (not (equal "" paragraph-start)) + (equal ?^ (aref paragraph-start 0))) + (substring paragraph-start 1) + paragraph-start)) + (paragraph-separate (if (and (not (equal "" paragraph-start)) + (equal ?^ (aref paragraph-separate 0))) + (substring paragraph-separate 1) + paragraph-separate)) + (paragraph-separate + (if fill-prefix-regexp + (concat paragraph-separate "\\|" + fill-prefix-regexp "[ \t]*$") + paragraph-separate)) + ;; This is used for searching. + (sp-paragraph-start (concat "^[ \t]*\\(" paragraph-start "\\)")) + start) + (while (and (< arg 0) (not (bobp))) + (if (and (not (looking-at paragraph-separate)) + (re-search-backward "^\n" (max (1- (point)) (point-min)) t) + (looking-at paragraph-separate)) + nil + (setq start (point)) + ;; Move back over paragraph-separating lines. + (forward-char -1) (beginning-of-line) + (while (and (not (bobp)) + (progn (move-to-left-margin) + (looking-at paragraph-separate))) + (forward-line -1)) + (if (bobp) + nil + ;; Go to end of the previous (non-separating) line. + (end-of-line) + ;; Search back for line that starts or separates paragraphs. + (if (if fill-prefix-regexp + ;; There is a fill prefix; it overrides paragraph-start. + (let (multiple-lines) + (while (and (progn (beginning-of-line) (not (bobp))) + (progn (move-to-left-margin) + (not (looking-at paragraph-separate))) + (looking-at fill-prefix-regexp)) + (if (not (= (point) start)) + (setq multiple-lines t)) + (forward-line -1)) + (move-to-left-margin) + ;; Don't move back over a line before the paragraph + ;; which doesn't start with fill-prefix + ;; unless that is the only line we've moved over. + (and (not (looking-at fill-prefix-regexp)) + multiple-lines + (forward-line 1)) + (not (bobp))) + (while (and (re-search-backward sp-paragraph-start nil 1) + ;; Found a candidate, but need to check if it is a + ;; REAL paragraph-start. + (not (bobp)) + (progn (setq start (point)) + (move-to-left-margin) + (not (looking-at paragraph-separate))) + (or (not (looking-at paragraph-start)) + (and use-hard-newlines + (not (get-text-property (1- start) + 'hard))))) + (goto-char start)) + (> (point) (point-min))) + ;; Found one. + (progn + ;; Move forward over paragraph separators. + ;; We know this cannot reach the place we started + ;; because we know we moved back over a non-separator. + (while (and (not (eobp)) + (progn (move-to-left-margin) + (looking-at paragraph-separate))) + (forward-line 1)) + ;; If line before paragraph is just margin, back up to there. + (end-of-line 0) + (if (> (current-column) (current-left-margin)) + (forward-char 1) + (skip-chars-backward " \t") + (if (not (bolp)) + (forward-line 1)))) + ;; No starter or separator line => use buffer beg. + (goto-char (point-min))))) + (setq arg (1+ arg))) + (while (and (> arg 0) (not (eobp))) + ;; Move forward over separator lines, and one more line. + (while (prog1 (and (not (eobp)) + (progn (move-to-left-margin) (not (eobp))) + (looking-at paragraph-separate)) + (forward-line 1))) + (if fill-prefix-regexp + ;; There is a fill prefix; it overrides paragraph-start. + (while (and (not (eobp)) + (progn (move-to-left-margin) (not (eobp))) + (not (looking-at paragraph-separate)) + (looking-at fill-prefix-regexp)) + (forward-line 1)) + (while (and (re-search-forward sp-paragraph-start nil 1) + (progn (setq start (match-beginning 0)) + (goto-char start) + (not (eobp))) + (progn (move-to-left-margin) + (not (looking-at paragraph-separate))) + (or (not (looking-at paragraph-start)) + (and use-hard-newlines + (not (get-text-property (1- start) 'hard))))) + (forward-char 1)) + (if (< (point) (point-max)) + (goto-char start))) + (setq arg (1- arg))))) + +(defun backward-paragraph (&optional arg) + "Move backward to start of paragraph. +With arg N, do it N times; negative arg -N means move forward N paragraphs. + +A paragraph start is the beginning of a line which is a +`first-line-of-paragraph' or which is ordinary text and follows a +paragraph-separating line; except: if the first real line of a +paragraph is preceded by a blank line, the paragraph starts at that +blank line. + +See `forward-paragraph' for more information." + (interactive "_p") ; XEmacs + (or arg (setq arg 1)) + (forward-paragraph (- arg))) + +(defun mark-paragraph () + "Put point at beginning of this paragraph, mark at end. +The paragraph marked is the one that contains point or follows point." + (interactive) + (forward-paragraph 1) + (push-mark nil t t) + (backward-paragraph 1)) + +(defun kill-paragraph (arg) + "Kill forward to end of paragraph. +With arg N, kill forward to Nth end of paragraph; +negative arg -N means kill backward to Nth start of paragraph." + (interactive "*p") ; XEmacs + (kill-region (point) (progn (forward-paragraph arg) (point)))) + +(defun backward-kill-paragraph (arg) + "Kill back to start of paragraph. +With arg N, kill back to Nth start of paragraph; +negative arg -N means kill forward to Nth end of paragraph." + (interactive "*p") ; XEmacs + (kill-region (point) (progn (backward-paragraph arg) (point)))) + +(defun transpose-paragraphs (arg) + "Interchange this (or next) paragraph with previous one." + (interactive "*p") + (transpose-subr 'forward-paragraph arg)) + +(defun start-of-paragraph-text () + (let ((opoint (point)) npoint) + (forward-paragraph -1) + (setq npoint (point)) + (skip-chars-forward " \t\n") + ;; If the range of blank lines found spans the original start point, + ;; try again from the beginning of it. + ;; Must be careful to avoid infinite loop + ;; when following a single return at start of buffer. + (if (and (>= (point) opoint) (< npoint opoint)) + (progn + (goto-char npoint) + (if (> npoint (point-min)) + (start-of-paragraph-text)))))) + +(defun end-of-paragraph-text () + (let ((opoint (point))) + (forward-paragraph 1) + (if (eq (char-before (point)) ?\n) (forward-char -1)) + (if (<= (point) opoint) + (progn + (forward-char 1) + (if (< (point) (point-max)) + (end-of-paragraph-text)))))) + +(defun forward-sentence (&optional arg) + "Move forward to next `sentence-end'. With argument, repeat. +With negative argument, move backward repeatedly to `sentence-beginning'. + +The variable `sentence-end' is a regular expression that matches ends of +sentences. Also, every paragraph boundary terminates sentences as well." + (interactive "_p") ; XEmacs + (or arg (setq arg 1)) + (while (< arg 0) + (let ((par-beg (save-excursion (start-of-paragraph-text) (point)))) + (if (re-search-backward (concat sentence-end "[^ \t\n]") par-beg t) + (goto-char (1- (match-end 0))) + (goto-char par-beg))) + (setq arg (1+ arg))) + (while (> arg 0) + (let ((par-end (save-excursion (end-of-paragraph-text) (point)))) + (if (re-search-forward sentence-end par-end t) + (skip-chars-backward " \t\n") + (goto-char par-end))) + (setq arg (1- arg)))) + +(defun backward-sentence (&optional arg) + "Move backward to start of sentence. With arg, do it arg times. +See `forward-sentence' for more information." + (interactive "_p") ; XEmacs + (or arg (setq arg 1)) + (forward-sentence (- arg))) + +(defun kill-sentence (&optional arg) + "Kill from point to end of sentence. +With arg, repeat; negative arg -N means kill back to Nth start of sentence." + (interactive "*p") ; XEmacs + (kill-region (point) (progn (forward-sentence arg) (point)))) + +(defun backward-kill-sentence (&optional arg) + "Kill back from point to start of sentence. +With arg, repeat, or kill forward to Nth end of sentence if negative arg -N." + (interactive "*p") ; XEmacs + (kill-region (point) (progn (backward-sentence arg) (point)))) + +(defun mark-end-of-sentence (arg) + "Put mark at end of sentence. Arg works as in `forward-sentence'." + (interactive "p") + ;; FSF Version: +; (push-mark +; (save-excursion +; (forward-sentence arg) +; (point)) +; nil t)) + (mark-something 'mark-end-of-sentence 'forward-sentence arg)) + +(defun transpose-sentences (arg) + "Interchange this (next) and previous sentence." + (interactive "*p") + (transpose-subr 'forward-sentence arg)) + +;;; paragraphs.el ends here
--- a/lisp/paths.el Mon Aug 13 10:03:54 2007 +0200 +++ b/lisp/paths.el Mon Aug 13 10:04:58 2007 +0200 @@ -1,9 +1,9 @@ ;;; paths.el --- define pathnames for use by various Emacs commands. -;; Copyright (C) 1986, 1988, 1993, 1994 Free Software Foundation, Inc. +;; Copyright (C) 1986, 1988, 1993, 1994, 1997 Free Software Foundation, Inc. ;; Maintainer: FSF -;; Keywords: internal +;; Keywords: internal, dumped ;; This file is part of XEmacs. @@ -25,6 +25,8 @@ ;;; Commentary: +;; This file is dumped with XEmacs. + ;; These are default settings for names of certain files and directories ;; that Emacs needs to refer to from time to time.
--- a/lisp/pcl-cvs/ChangeLog Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,879 +0,0 @@ -1997-10-09 SL Baur <steve@altair.xemacs.org> - - * pcl-cvs.el (cvs-changelog-ours-p): Grok new ChangeLog format. - -1997-08-28 SL Baur <steve@altair.xemacs.org> - - * pcl-cvs.el (cvs-changelog-ours-p): correct for drift in - `user-full-name' semantics. - -Fri May 2 20:04:35 1997 Steven L Baur <steve@altair.xemacs.org> - - * pcl-cvs.el (cvs-update): Inhibit dialog box usage in call to - cvs-do-update as this bombs when this function is invoked from a - menu. - -Wed Mar 19 23:25:26 1997 Steven L Baur <steve@altair.xemacs.org> - - * pcl-cvs.el (cvs-changelog-ours-p): Use function. - -Sat Dec 21 22:37:37 1996 Neal Becker <neal@ctd.comsat.com> - - * pcl-cvs.el: Synched with pcl-cvs.el from cvs-1.9. - -Tue Jan 23 13:02:24 1996 Greg A. Woods <woods@most.weird.com> - - * pcl-cvs.el (pcl-cvs-bugs-address): change the default address - as suggested by Per Cederqvist. - * pcl-cvs.el: removed comments refering to Signum, etc. - -Sun Jan 21 12:51:12 1996 Greg A. Woods <woods@most.weird.com> - - * pcl-cvs.el (cvs-parse-stderr): fix typo (missing '\') that was - causing occasional un-reported, un-traced, failures that simply - said something like "RE missing '\(' or '\\('" -- hopefully this - is the last such bug! - -Tue Jan 16 13:57:16 1996 Jim Kingdon <kingdon@harvey.cyclic.com> - - * Makefile.in: Rename "dist" target back to "dist-dir". The - latter is what actually gets used. - (pcl-cvs.dvi): Restore srcdir to pcl-cvs.texinfo. Fix typo - (pcl-cvs.texifo -> pcl-cvs.texinfo). - (TEXINDEX,TEX,SET_TEXINPUTS): New variables. - (.el.elc): Copy .el file to build dir so .elc file gets put there. - (dist-dir): Fix typo (cvs.info -> pcl-cvs.info). - * cookie.el: New file, copied from elib 1.0. - * README: Remove note about requiring elib; it claimed that CVS - contained a copy of elib, but it lied. - * pcl-cvs.el: Change (require 'cookie) to (load "cookie.el"). - * pcl-cvs-lucid.el: Change (require 'pcl-cvs) to (load "pcl-cvs.el"). - -Fri Jan 12 10:32:14 1996 Greg A. Woods <woods@most.weird.com> - - * pcl-cvs.elc, pcl-cvs-lucid.elc: removed - - * pcl-cvs.el: run through the spell checker... - - noted some free variables in comments - (cvs-inhibit-copyright-message): move this above - cvs-startup-message to keep the compiler quiet - - * compile-all.el: removed (use make for dependency checking!) - - * Makefile.in: tweak various comments and echo messages... - (elcfiles): removed this target. - (.SUFFIXES, .el.elc): added support for elisp files. - (CORE): new macro -- list of files all .elc depend on [still empty] - (BATCHFLAGS): new macro -- flags to pass to emacs - (OBJDIR_DISTFILES): added ELCFILES to be shipped in distribution - - * README: fix the RCS Id. - - * INSTALL: re-copy formatted makeinfo output from pcl-cvs.info, - just to keep everything in proper synchronisation. - - * pcl-cvs.texinfo (Pcl-cvs installation): update to match Karl's - new wording from INSTALL. - -Wed Jan 10 22:04:35 1996 Karl Fogel <kfogel@floss.red-bean.com> - - * INSTALL: make first item read a little more smoothly. - - * README: note that pcl-cvs has been tested under 19.30. - -Wed Jan 10 17:59:00 1996 Greg A. Woods <woods@most.weird.com> - - * ChangeLog.woods: these are changes integrated in from my - own pcl-cvs repository module, and based on the original PCL-CVS - Version 1.05 release. They include most, if not all, of the - changes from the Cygnus and Cyclic CVS contrib versions of - PCL-CVS (i.e. the changes noted below). - -Sat Dec 30 15:01:45 1995 Karl Fogel <kfogel@floss.cyclic.com> - - * pcl-cvs.el (cvs-changelog-ours-p): check that - `add-log-full-name' and `add-log-mailing-address' are non-nil, in - addition to checking that they are boundp. - -Thu Dec 21 16:45:48 1995 Karl Fogel <kfogel@occs.cs.oberlin.edu> - - * pcl-cvs.el (cvs-parse-stderr): ignore kerberos connection - failure, since CVS will automatically try rsh next. I think this - is okay because if a person needs to know that kerberos failed, - then chances are the rsh failed too, and *that* error message will - clue them in that something's afoot. - -Wed Nov 22 11:01:50 1995 Joshua Cowan <jcowan@hermit.reslife.okstate.edu> - - * pcl-cvs.el (cvs-changelog-ours-p): use `user-full-name' if - `add-log-full-name' unbound, as not every uses the stuff in - add-log.el. Same with `add-log-mailing-address'. - (cvs-changelog-entries): change to `change-log-mode' unless - already in it. - -Sun Jul 9 20:57:11 1995 Karl Fogel <kfogel@floss.cyclic.com> - - * "/bin/rmdir" as default, not "/usr/local/bin/rmdir". - -Fri Jun 16 15:24:34 1995 Jim Kingdon (kingdon@cyclic.com) - - * pcl-cvs.elc, pcl-cvs-lucid.elc: Added. - - * Makefile.in: Rename from Makefile and set srcdir. - -Thu May 18 17:10:27 1995 Jim Blandy <jimb@totoro.bio.indiana.edu> - - Automatically guess CVS log entries from ChangeLog contents. - * pcl-cvs.el (cvs-mode-changelog-commit): New command. - (cvs-changelog-full-paragraphs): New variable. - (cvs-changelog-name, cvs-narrow-changelog, - cvs-changelog-paragraph, cvs-changelog-subparagraph, - cvs-changelog-entry, cvs-changelog-ours-p, cvs-relative-path, - cvs-changelog-entries, cvs-changelog-insert-entries, cvs-union, - cvs-insert-changelog-entries, cvs-edit-delete-common-indentation): - New functions. - (cvs-mode-map): Bind 'C' to cvs-mode-changelog-commit. - (cvs-mode): Mention cvs-mode-changelog-commit in docstring. - - Give the info files names ending in ".info". - * Makefile (INFOFILES, install_info): Change pcl-cvs to - pcl-cvs.info. - (pcl-cvs.info): Target renamed from pcl-cvs. - (DISTFILES): pcl-cvs removed; we handle the info files explicitly - in the dist-dir target. - (dist-dir): Depend on pcl-cvs.info. Distribute pcl-cvs.info*. - * pcl-cvs.texinfo: Change @setfilename appropriately. - * INSTALL: Updated. - * .cvsignore: Correctly ignore the info files. - - * README: Note that pcl-cvs has been tested under 19.28, and that - the "cookie" naming conflict was resolved in 19.11. - - * Makefile (pcl-cvs-lucid.elc): Changed this target from - pcl-cvs-lucid.el. That's a source file, for goodness' sake! - -Tue May 9 13:56:50 1995 Jim Blandy <jimb@totoro.bio.indiana.edu> - - * Change references to "Cygnus's remote CVS" to "Cyclic CVS". - -Wed May 3 13:55:27 1995 Jim Blandy <jimb@totoro.bio.indiana.edu> - - * pcl-cvs.el (cvs-parse-stderr): Handle colons after both - "rcsmerge" and "warning". - -Fri Apr 28 22:38:14 1995 Jim Blandy <jimb@totoro.bio.indiana.edu> - - * Makefile (ELFILES): Include pcl-cvs-startup.el. - (info, pcl-cvs): Call makeinfo appropriately for modern versions. - (pcl-cvs.aux): List dependency on pcl-cvs.texinfo. - (pcl-cvs.ps): New target. - (DVIPS): New variable. - (dist-dir): Renamed from dist, updated to accept DISTDIR value - passed from parent. - (DISTFILES): New varible. - (pcl-cvs.elc, pcl-cvs-lucid.elc): Add targets to elcfiles target. - -Tue Apr 25 21:33:49 1995 Jim Blandy <jimb@totoro.bio.indiana.edu> - - * pcl-cvs.el: (cvs-parse-stderr): Recognize "conflicts" as well as - "overlaps" before "during merge." - -Thu Feb 16 12:17:20 1995 Jim Blandy <jimb@totoro.bio.indiana.edu> - - * pcl-cvs.el (cvs-parse-stderr): Recognize "conflicts found in..." - messages attributed to "cvs server", as well as "cvs update". - -Sat Feb 4 01:47:01 1995 Jim Blandy <jimb@totoro.bio.indiana.edu> - - * pcl-cvs.el: Deal with the 'P' action, produced by remote CVS. - (cvs-parse-stdout): Treat 'P' like 'U' --- file is updated. - -Tue Jan 31 23:31:39 1995 Jim Blandy <jimb@totoro.bio.indiana.edu> - - * pcl-cvs.el (cvs-cvsroot-required): New variable. - (cvs-do-update): If cvs-cvsroot-required is not set, don't complain if - CVSROOT and cvs-cvsroot are both unset. - -Sun Jan 22 21:22:22 1995 Jim Blandy <jimb@totoro.bio.indiana.edu> - - * pcl-cvs.el (cvs-parse-stderr): - Some changes for Cygnus's Remote CVS. Treat - messages like "cvs server: Updating DIRECTORY" as we treat those like - "cvs update: Updating DIRECTORY". Ignore other messages starting with - "cvs server". - - * pcl-cvs.el (cvs-parse-stderr): Re-indent. - - * .cvsignore: Add ignore list for Texinfo litter. - - * Makefile (lispdir): Set appropriately for totoro. - * pcl-cvs.el (cvs-program, cvs-diff-program, cvs-rmdir-program): Same. - -Tue Jun 1 00:00:03 1993 Per Cederqvist (ceder@lysator.liu.se) - - * Release 1.05. (This release was promised before the end of May, - but I didn't quite make it. No, I didn't fake the date above). - -Mon May 31 01:32:25 1993 Per Cederqvist (ceder@lysator.liu.se) - - * Removed the elib sub-directory. Users must now get the Elib - library separately. - * pcl-cvs.texinfo: Document it. - - * pcl-cvs-lucid.el: A new version, supplied by Jamie Zawinsky, - added. - - * pcl-cvs Id 68: Transform RCS keywords - * Makefile (pcl-cvs-$(VER)): Remove the $ signs in most files in - the distribution. - - * pcl-cvs Id 76: Extra " in cvs-mode-add. - * pcl-cvs.el (cvs-mode-add): Don't add the extra level of quotes - around the log message, since it doesn't work with CVS. - - * pcl-cvs Id 56: '-d <CVSROOT>' support in pcl-cvs - * pcl-cvs.el (cvs-change-cvsroot): New function. - - * pcl-cvs Id 77: *cvs* isn't cleared properly - * pcl-cvs.el (cvs-do-update): Always erase the *cvs* buffer and - re-create the collection. - - * pcl-cvs.el (cvs-do-update): Set mode-line-process in the *cvs* - buffer. - * pcl-cvs.el (cvs-mode): Reset mode-line-process. - - * pcl-cvs Id 59: sort .cvsignore alphabetically! - * pcl-cvs.el (cvs-sort-ignore-file): New variable. - * pcl-cvs.el (cvs-mode-ignore): Use it. - * pcl-cvs.texinfo: Document it. - - * pcl-cvs Id 75: Require final newline. - * pcl-cvs.el (cvs-commit-buffer-require-final-newline): New - variable. - * pcl-cvs.el (cvs-edit-done): Use it. - * pcl-cvs.texinfo: Document it. - - * pcl-cvs Id 72: make clean deletes lucid-emacs.el - * dist-makefile (ELCFILES): Fixed a typo. - - * pcl-cvs Id 46: "cvs remove f" "touch f" "cvs update f" -> parse err. - * pcl-cvs.el (cvs-fileinfo->type): New type: REM-EXIST. - * pcl-cvs.el (cvs-shadow-entry-p): A REMOVED that follows a - REM-EXIST is a shadow. - * pcl-cvs.el (cvs-parse-stderr): Recognize the "should be removed - and is still there" message. - * pcl-cvs.el (cvs-pp): Recognize REM-EXIST. - * pcl-cvs.el (cvs-mode-undo-local-changes): Recognize and complain - about REM-EXIST. Defensive test added: complain about unknown types. - - * pcl-cvs.el (cvs-mode-add): Add an extra level of quotes around - the log message. This is apparently needed by RCVS. <This change - has been removed. --ceder>. - - * pcl-cvs.el (cvs-parse-stderr): Ignore output from RCVS. - -Tue Apr 27 00:48:40 1993 Per Cederqvist (ceder@lysator.liu.se) - - * pcl-cvs.el (cvs-startup-message): Now a defconst instead of a - defvar. - * pcl-cvs.el (cvs-mode-commit): Add a defvar for it. - - * dist-makefile (EMACS): Use $(EMACS) instead of hard-coding 'emacs'. - -Sat Apr 17 12:47:10 1993 Per Cederqvist (ceder@lysator.liu.se) - - * Release 1.04. - - * pcl-cvs.texinfo: Updated the Contributors node. - - * pcl-cvs Id 58: Lucid GNU Emacs support - * pcl-cvs-lucid.el: New file, contributed by the people at Lucid. - * pcl-cvs.el: Autoload pcl-cvs-lucid if running in an Lucid GNU - Emacs. - * compile-all.el: (files-to-compile): Add pcl-cvs-lucid. - * dist-makefile (ELFILES, ELCFILES): Dito. - - * pcl-cvs Id 55: cvs-diff-backup swaps old and new version. - * pcl-cvs.el (cvs-diff-backup-extractor): Old version should be - first. - * pcl-cvs.el (cvs-mode-diff-backup): Call cvs-backup-diffable - correctly. - - * pcl-cvs Id 64: elib substitute - * dist-makefile (install): Warn about Elib. - * pcl-cvs.texinfo: Talk about Elib. - - * pcl-cvs Id 50: Committing the *commit* buffer twice. - * pcl-cvs.el (cvs-edit-done): Report an error if cvs-commit-list - is empty, and empty it when the commit is done. - - * pcl-cvs Id 56: '-d <CVSROOT>' support. - * pcl-cvs.el (cvs-cvsroot): New variable. - * pcl-cvs.el (cvs-do-update, all callers of cvs-execute-list): Use - it everywhere CVS is called, to override CVSROOT. - * pcl-cvs.texinfo (Customization): Document it. - -Thu Apr 1 00:34:55 1993 Per Cederqvist (ceder@lysator.liu.se) - - * pcl-cvs.el (cvs-retrieve-revision-to-tmpfile): Exit status nil - from call-process means everything was successful in some Emacs - versions. - - * pcl-cvs.el (cvs-mode-map): Bind "q" to bury-buffer. - * pcl-cvs.texinfo: Document it. - -Thu Mar 11 00:05:03 1993 Per Cederqvist (ceder@lysator.liu.se) - - * Release 1.03-Emerge (not released). - - * Makefile (pcl-cvs-$(VER)): Don't includ elib-dll-debug.el in the - distribution. (It's included as elib/dll-debug.el). - - * pcl-cvs.el (cvs-mode): Document the "e" key (cvs-mode-emerge). - -Tue Mar 9 00:02:57 1993 Per Cederqvist (ceder@lysator.liu.se) - - * pcl-cvs.texinfo (Emerge): New node. - - * pcl-cvs.el (cvs-kill-buffer-visiting): New function. - - * pcl-cvs.el (cvs-mode-emerge): Handle Conflict and Merged files. - - * pcl-cvs.el (cvs-retrieve-revision-to-tmpfile): Handle any revision. - - * pcl-cvs.el (cvs-fileinfo-*): Store base-revision instead of - backup-file. - - * pcl-cvs.el (cvs-backup-diffable): The file is only diffable if - the backup file is readable. - - * pcl-cvs.el (cvs-mode-map): Bind "e" to cvs-mode-emerge instead - of cvs-mode-find-file (which is anyhow bound to "f"). - -Mon Mar 8 23:06:52 1993 Per Cederqvist (ceder@lysator.liu.se) - - * pcl-cvs.el (cvs-mode-emerge): New function. Currently only - handles emerge of Modified files. - - * pcl-cvs.el (cvs-retrieve-revision-to-tmpfile): New function. - -Sun Jan 24 20:07:18 1993 Per Cederqvist (ceder@lysator.liu.se) - - * elib-dll-debug.el: Moved to elib. - -Mon Jan 18 00:35:59 1993 Per Cederqvist (ceder@mauritz) - - * pcl-cvs.el (cvs-do-update): Added a probably unnecessary sit-for. - - * Release 1.03-Elib-0.05.1 (not released). - - * Elib 0.05 compatibility: - * elib-dll-debug.el, pcl-cvs-buffer.el, test-dll.el: Fix the - require strings. - * pcl-cvs.el (cvs-pp): Insert the string. - - * Release 1.03-Elib-0.05 (not released). - - * elib: New directory, containing the parts of elib that are - required for pcl-cvs. Changes to the files in that directory - that are present in Elib are documented in the ChangeLog of - Elib, not here. - * Makefile (pcl-cvs-$(VER)): Copy the new dir to the distribution. - * dist-makefile (ELFILES, ELCFILES): Don't include the Elib files. - -Fri Jan 8 02:43:49 1993 Per Cederqvist (ceder@konrad) - - * pcl-cvs.el (cvs-mode-map): Bind "e" to cvs-mode-find-file, like - in dired. - -Sun Jan 3 23:25:13 1993 Per Cederqvist (ceder@konrad) - - * elib-dll.el, elib-node.el, cookie.el: Moved to the elib package. - Pcl-cvs now requires elib. - -Tue Dec 29 22:06:57 1992 Per Cederqvist (ceder@konrad) - - * pcl-cvs.el: Tracked the latest (last?) rename of all functions - in cookie.el. - -Thu Sep 24 00:29:16 1992 Per Cederqvist (ceder@robert) - - * pcl-cvs.texinfo (Archives): This version is not distributed with - CVS 1.3, so don't claim that it is. - -Fri Aug 21 15:17:08 1992 Per Cederqvist (ceder@maskros) - - * pcl-cvs.el (cvs-parse-stderr): Fixed two "(set head" that should - be "(setq head". - -Thu Aug 20 05:53:58 1992 Per Cederqvist (ceder@robin) - - * cookie.el: Changes to this file is documented in the ChangeLog - of elib in the future. - -Tue Aug 18 03:30:28 1992 Per Cederqvist (ceder@robin) - - * pcl-cvs.el: Don't use cookie-last-tin (which no longer exists). - - * cookie.el: Use prefix cookie:: for internal functions. - - * cookie.el: (cookie:enter-after, cookie:enter-before, - cookie:nth-cookie): Implemented. - * cookie.el: No longer define (impl). - - * cookie.el: More renames: - cookie:next-cookie -> cookie:goto-next-tin - cookie:previous-cookie -> cookie:goto-previous-tin - tin-next -> cookie:next-tin - tin-previous -> cookie:previous-tin - tin-nth -> cookie:nth-tin - tin-delete -> cookie:delete-tin - cookie:collect -> cookie:collect-cookies - cookie:tin-collect -> cookie:collect-tins - (new) -> cookie:tin-collect-cookies - (new) -> cookie:tin-collect-tins - cookie:refresh -> cookie:refresh-all - tin-invalidate-tins -> cookie:invalidate-tins - -Mon Aug 17 01:39:49 1992 Per Cederqvist (ceder@robin) - - * cookie.el (cookie:set-buffer-bind-dll-let*): New macro. Used in - many places instead of cookie:set-buffer-bind-dll. - * cookie.el (cookie:set-buffer-bind-dll): Renamed the macro - cookie:set-buffer to this. - - * pcl-cvs.el (cvs-use-temp-buffer): Set default-directory. - -Sun Aug 16 20:51:30 1992 Per Cederqvist (ceder@robin) - - * pcl-cvs.el (cvs-add-sub): Fixed call to cvs-add-file-update-buffer. - -Sat Aug 8 20:28:21 1992 Per Cederqvist (ceder@robin) - - * Release 1.03-Cookie-II (not released). - - * pcl-cvs.el (cvs-mode-diff-cvs): Don't care about the exit status - from ``cvs diff''. - - * pcl-cvs.el (cvs-mode): Document cvs-mode-undo-local-changes. - * pcl-cvs.el (cvs-diffable): New function. - - * pcl-cvs.el: Use the new cookie package. - * pcl-cvs.el (cvs-cookie-handle): New variable. - * pcl-cvs.el (cvs-do-update): User the new cookie:create - interface, and cookie:clear if the buffer already existed. Make - the buffer read-only. - * pcl-cvs.el (cvs-mode-next-line, cvs-mode-previous-line): New - functions (used instead of cookie:next-cookie and - cookie:previous-cookie). - - * cookie.el: Major redesign. The handle that is passed to all - cookie functions is now a new datatype, and not the buffer that - the cookies resides in. This way it is possible to have more than - one set of cookies in a buffer. Things that used to be - buffer-local variables are now fields in the handle data type. - cookie-last-tin is no longer available. - * cookie.el (cookie:create): The buffer is not cleared, nor set to - be read-only. - * cookie.el (cookie:next-cookie, cookie:previous-cookie): Since - the first argument is now a handle and not a buffer, these can no - longer be called interactively. You have to write a small wrapper - about them. - * cookie.el (cookie:buffer): New function. - -Tue Aug 4 03:02:25 1992 Per Cederqvist (ceder@robert) - - * pcl-cvs.texinfo (Bugs): Renamed "Reporting bugs and ideas" to - "Bugs" and added a table of known bugs/FAQ:s. - -Mon Aug 3 00:19:39 1992 Per Cederqvist (ceder@robert) - - * pcl-cvs.el, pcl-cvs.texinfo: Big Renaming Time! - The commands that operate in the *cvs* buffer: - cvs-add-change-log-entry-other-window -> cvs-mode-add-change-log-entry-other-window - cvs-mark-all-files -> cvs-mode-mark-all-files - cvs-revert-updated-buffers -> cvs-mode-revert-updated-buffers - cvs-undo-local-changes -> cvs-mode-undo-local-changes - cvs-unmark-up -> cvs-mode-unmark-up - cvs-acknowledge -> cvs-mode-acknowledge - cvs-unmark-all-files -> cvs-mode-unmark-all-files - cvs-add -> cvs-mode-add - cvs-diff-backup -> cvs-mode-diff-backup - cvs-commit -> cvs-mode-commit - cvs-diff-cvs -> cvs-mode-diff-cvs - cvs-find-file -> cvs-mode-find-file - cvs-update-no-prompt -> cvs-mode-update-no-prompt - cvs-ignore -> cvs-mode-ignore - cvs-log -> cvs-mode-log - cvs-mark -> cvs-mode-mark - cvs-find-file-other-window -> cvs-mode-find-file-other-window - cvs-remove-file -> cvs-mode-remove-file - cvs-status -> cvs-mode-status - cvs-remove-handled -> cvs-mode-remove-handled - cvs-unmark -> cvs-mode-unmark - - * pcl-cvs.el (cvs-cvs-diff-flags): Variable deleted. - * pcl-cvs.el (cvs-diff-cvs): Use cvs-diff-flags instead. - * pcl-cvs.texinfo (Customization): Update the doc. - - * pcl-cvs.el (cvs-diff-cvs): Handle exit status 0 (no diffs), 1 - (diffs) and other (error). - * pcl-cvs.el (cvs-execute-list): Add support for this kind of - thing. - - * Revert buffers for committed files: - * pcl-cvs.el (cvs-auto-revert-after-commit): New variable. - * pcl-cvs.texinfo (Committing changes, Customization): Document - it. - * pcl-cvs.el (cvs-after-commit-function): New function. - - * pcl-cvs.el (cvs-execute-list): Return the exit status or nil. - * pcl-cvs.el (cvs-edit-done, cvs-diff-cvs, cvs-remove-file, - cvs-undo-local-changes, cvs-add, cvs-status, cvs-log): Use the - exit status to generate an error message. - - - * pcl-cvs.el (cvs-do-update): It should be "cvs -n update -l", not - "cvs -l update -n". Put the -n and/or -l in the message that is - displayed in the *cvs* buffer during the update. - -Sat Aug 1 00:55:49 1992 Per Cederqvist (ceder@robert) - - * cookie.el (cookie-sort): New function. - - * cookie.el (cookie-clear): Rewritten. No longer clears all local - variables. - -Tue Jul 28 17:21:17 1992 Per Cederqvist (ceder@robin) - - * pcl-cvs.el (cvs-parse-stderr): Try to handle the output from RCS - when it is compiled without DIFF3_BIN and a conflict occurs. - - * pcl-cvs.texinfo (Getting Started): Fixed typo. - - * pcl-cvs-startup.el (cvs-update-other-window): Make the autoload - be interactive. - -Mon Jul 27 19:36:40 1992 Per Cederqvist (ceder@robin) - - * pcl-cvs.el (cvs-revert-updated-buffers, cvs-revert-fileinfo): - New functions. - * pcl-cvs.texinfo (Reverting your buffers): Document it. - - * pcl-cvs.el (cvs-fileinfo->full-path): New function. - * pcl-cvs.el (cvs-full-path): Use it. - - * cookie.el (cookie-map, cookie-map-reverse): Better doc- - string. Removed the unused local variable 'result'. - - * compile-all.el: Renamed elib-files to files-to-compare. - * compile-all.el (compile-pcl-cvs): Bind load-path in a let - statement instead of globally. - -Thu Jul 23 19:02:41 1992 Per Cederqvist (ceder@robin) - - * pcl-cvs.el (cvs-do-update): Check that CVSROOT is set. - * pcl-cvs.el (cvs-diff-cvs): Check that cvs-cvs-diff-flags is a - list. - * pcl-cvs.el (cvs-diff-backup): Check that cvs-diff-flags is a - list. - -Tue Jul 21 11:27:39 1992 Per Cederqvist (ceder@robin) - - * pcl-cvs.el (cvs-parse-error): Make the *cvs* buffer writeable - before trying to write the email message. Require sendmail before - trying to switch to mail-mode. - - * pcl-cvs.el (cvs-do-update): Check that cvs-program exists. - - * pcl-cvs.el (cvs-skip-line): Fixed bracketing error. - -Mon Jul 20 10:31:51 1992 Per Cederqvist (ceder@robin) - - * Release 1.03. - - * pcl-cvs.el, cookie.el: Indentation fixes. - - * Makefile (pcl-cvs-$(VER)): Include NEWS in the distribution. - - * pcl-cvs.el (cvs-rm-program): Deleted. - * pcl-cvs.el (cvs-rmdir-program, cvs-lock-file): New variables. - - * Handle lock files in a nicer way: - * pcl-cvs.el (cvs-update-filter, cvs-delete-lock, - cvs-lock-file-p): New functions. - * pcl-cvs.el (cvs-do-update, cvs-sentinel): Redirect stdout to the - temporary file, not stderr. Use cvs-update-filter. - * pcl-cvs.el (cvs-parse-update): New arguments. - * pcl-cvs.el (cvs-parse-buffer): Renamed to cvs-parse-update. - * pcl-cvs.el (cvs-stderr-file): Renamed to cvs-stdout-file. - * pcl-cvs.texinfo (Miscellaneous commands, Updating the - directory): Document cvs-delete-lock. - - * pcl-cvs.el (cvs-mode): Don't reset buffer-read-only. - - * pcl-cvs.el (cvs-find-file-other-window): Don't save-some-buffers. - -Thu Jul 16 00:19:58 1992 Per Cederqvist (ceder@robin) - - * pcl-cvs.el, test-cookie-el: Use the new names from cookie.el. - - * cookie.el: Big Renaming Time! - External functions: - cookie-next -> tin-next - cookie-previous -> tin-previous - cookie-nth -> tin-nth - cookie-delete -> tin-delete - cookie-filter-tins -> tin-filter - cookie-get-selection -> tin-get-selection - cookie-start-marker -> tin-start-marker - cookie-end-marker -> tin-end-marker - cookie-invalidate-tins -> tin-invalidate-tins - cookie-collect-tins -> tin-collect - cookie-collect-cookies -> cookie-collect - Internal functions: - cookie-create-tin -> cookie-create-wrapper - cookie-tin-start-marker -> cookie-wrapper-start-marker - cookie-tin-cookie-safe -> cookie-wrapper-cookie-safe - cookie-tin-cookie -> cookie-wrapper-cookie - set-cookie-tin-start-marker -> cookie-wrapper-set-start-marker - set-cookie-tin-cookie -> cookie-wrapper-set-cookie - cookie-tin-p -> cookie-wrapper-p - cookie-create-tin-and-insert -> cookie-create-wrapper-and-insert - - * pcl-cvs.el (cvs-find-file, cvs-find-file-other-window): Signal - an appropriate error message if the *cvs* buffer is empty. - - * cookie.el (cookie-create): Make the buffer read-only. - * cookie.el (cookie-create-tin-and-insert, cookie-refresh, - cookie-delete-tin-internal, cookie-refresh-tin): Bind - buffer-read-only to nil while changing the contents of - the buffer. - - * pcl-cvs.el (cvs-byte-compile-files): New function. - * pcl-cvs.texinfo (Miscellaneous commands): Document it. - - * pcl-cvs.el (cvs-diff-ignore-marks): New variable. - * pcl-cvs.el (cvs-diff-cvs, cvs-diff-backup): Don't consider - marked files to be selected if a prefix argument is given XOR the - variable cvs-diff-ignore-marks is non-nil. - * pcl-cvs.el (cvs-get-marked): New optional argument `ignore-marks'. - * pcl-cvs.texinfo (Customization, Viewing differences): Document - this behaviour. - - * pcl-cvs.el (cvs-undo-local-changes): New function. - * pcl-cvs.texinfo (Undoing changes): Document - cvs-undo-local-changes. - * pcl-cvs.el (cvs-mode-map): cvs-unmark-all-files moved from "U" - to "ESC DEL". cvs-undo-local-changes bound to "U". - * pcl-cvs.texinfo (Marking files): Document ESC DEL. - - * pcl-cvs.el (cvs-skip-line): New arguments. All callers updated. - Now calls cvs-parse-error if a parse error occurs. - * pcl-cvs.el (cvs-parse-error): New function that creates a bug - report. - * pcl-cvs.el (cvs-parse-stderr, cvs-parse-stdout): New arguments. - The only caller (cvs-parse-buffer) updated. Call cvs-parse-error - in case of parse error. - - * pcl-cvs.el (pcl-cvs-version): New variable. - - * cookie.el (cookie-create): Kill all local variables in the buffer. - -Fri Jul 10 11:17:40 1992 Per Cederqvist (ceder@robin) - - * Release 1.03beta1. - -Thu Jul 9 03:12:00 1992 Per Cederqvist (ceder@robin) - - * pcl-cvs.el (cvs-update-running): New variable. - * pcl-cvs.el (cvs-do-update): Use it instead of the previous local - variable cvs-process (that no longer exists). Make sure that only - one `cvs update' runs at any given moment. - * pcl-cvs.el (cvs-sentinel): Reset cvs-update-running when the - update process exits. - - * pcl-cvs.el (cvs-update): Switch to the *cvs* buffer. - * pcl-cvs.el (cvs-update-other-window): New function. - * pcl-cvs-startup.el (cvs-update-other-window): Added a autoload - for it. - * pcl-cvs.el (cvs-do-update): Don't pop up any buffer in a window - - let cvs-update or cvs-update-other-window handle that. Also - don't kill the *cvs* buffer, but rather insert a "Running cvs..." - message into it. - * pcl-cvs.el (cvs-parse-buffer): Don't change the window - configuration. - - * pcl-cvs.el (cvs-create-fileinfo, cvs-pp, cvs-fileninfo->type): - New type for a fileinfo: MESSAGE. - - * pcl-cvs.el (cvs-cvs-buffer): Deleted the variable. Use - cvs-buffer-name instead. (I no longer have any plans to allow more - than one cvs update to run at the same time - things only get - confusing). Changed all places where cvs-cvs-buffer was used. - - * pcl-cvs.el: Take care of update programs (the -u option in the - modules file): - * pcl-cvs.el (cvs-update-prog-output-skip-regexp): New variable. - * pcl-cvs.el (cvs-parse-stdout): Skip output from the update - program (using cvs-update-prog-output-skip-regexp). - * pcl-cvs.texinfo (Future enhancements): Document that the - solution is not as good as it should be. - * pcl-cvs.texinfo (Customization): Document the variable. - -Wed Jul 8 20:29:44 1992 Per Cederqvist (ceder@robin) - - * pcl-cvs.el (cvs-do-update): Check that this-dir really exists - and is a directory, and that this-dir/CVS exists and is a - directory. - -Tue Jul 7 01:02:24 1992 Per Cederqvist (ceder@robin) - - * pcl-cvs.texinfo (Customization): Document TMPDIR. - - * This chunk of modifications should make it possible to run - pcl-cvs on hosts that do not line-buffer stdout (such as - DECstation). They work by diverting stdout and stderr from - `cvs update' and later sorting them together. - * pcl-cvs.el (cvs-parse-stderr): Don't fail to parse conflict - data. - * pcl-cvs.el (cvs-remove-stdout-shadows, cvs-shadow-entry-p): New - functions. - * pcl-cvs.el (cvs-parse-buffer): Use it. - * pcl-cvs.el (cvs-remove-empty-directories): New function. - * pcl-cvs.el (cvs-remove-handled, cvs-parse-buffer): Use it. - * pcl-cvs.el (cvs-get-current-dir): New argument ROOT-DIR. All - calls to cvs-get-current-dir updated. - * pcl-cvs.el (cvs-do-update): Allocate a tmp file. Use cvs-shell - (typically /bin/sh) to redirect stderr from CVS to the tmp file. - * pcl-cvs.el (cvs-sentinel): Handle the tmp file. Remove it when - it is parsed. - * pcl-cvs.el (cvs-parse-buffer): New argument STDERR-BUFFER. All - calls to cvs-parse-buffer updated. Rewritten to handle the - separation of stderr and stdout. - * pcl-cvs.el (cvs-shell, cvs-stderr-file): New variables. - * pcl-cvs.el (cvs-compare-fileinfos, cvs-parse-stderr, - cvs-parse-stdout): New functions. - - * pcl-cvs.el (cvs-parse-buffer): Some modifications for output - from RCS 5.6. - -Tue Apr 7 09:11:27 1992 Per Cederqvist (ceder@leopold) - - * Release 1.02. - - * pcl-cvs.el (cvs-diff-backup, cvs-edit-done, cvs-status): Call - save-some-buffers. - - * pcl-cvs.el (cvs-diff-backup-extractor): Fixed syntax error. - - * Makefile, README, compile-all.el, dist-makefile, pcl-cvs.el, - pcl-cvs.texinfo (XXRELEASEXX): A magic string that is substituted - for the current release number when a distribution is made. - (Release 1.01 says that it is release 1.00). - - * pcl-cvs.el (cvs-find-file): Added missing pair of parenthesis. - -Mon Mar 30 14:25:26 1992 Per Cederqvist (ceder@leopold) - - * Release 1.01. - - * pcl-cvs.el (cvs-parse-buffer): The message when waiting for a - lock has been changed. - -Sun Mar 29 05:29:57 1992 Per Cederqvist (ceder@leopold) - - * Release 1.00. - - * pcl-cvs.el (cvs-do-update, cvs-sentinel, cvs-parse-buffer): - Major rewrite of buffer and window selection and handling. - The *cvs* buffer is now killed whenever a new "cvs update" is - initiated. The -update buffer is replaced with the *cvs* - buffer when the update is completed. - -Sat Mar 28 21:03:05 1992 Per Cederqvist (ceder@robin) - - * pcl-cvs.el (cvs-delete-unused-temporary-buffers): Fixed it. - - * pcl-cvs.el (cvs-auto-remove-handled): New variable. - * pcl-cvs.el (cvs-edit-done): Use it. - * pcl-cvs.texinfo (Customization, Removing handled entries): - Document it. - - * pcl-cvs.el (cvs-mode): Turn of the undo feature. It really - isn't useful in a cookie buffer... - - * pcl-cvs.el (cvs-edit-done): Committing a file now looks more - like diffing a file. The window handling is better. - * pcl-cvs.el (cvs-use-temp-buffer): The &optional switch is no - longer needed. - -Mon Mar 23 00:20:33 1992 Per Cederqvist (ceder@robin) - - * Release 0.97. - - * pcl-cvs.el (default-directory): Make sure it always ends in a - slash. fileinfo->dir does NOT end in a slash, and I had forgotten - to call file-name-as-directory in various places. - - * pcl-cvs.el (cvs-diff-backup-extractor): Signal an error if a - fileinfo without backup file is given. - - * pcl-cvs.el (cvs-mode): Added documentation. - - * pcl-cvs.el (cvs-execute-list): Fix the order of files in the - same directory. - - * pcl-cvs.el (cvs-log-flags, cvs-status-flags): New variables. - * pcl-cvs.el (cvs-log, cvs-status): Use them. - * pcl-cvs.texinfo (Customization): Document them. - - * pcl-cvs.el (cvs-diff-backup): Filter non-backup-diffable files - at an earlier stage, like cvs-commit does. - - * pcl-cvs.el (cvs-diff-flags): New variable. - * pcl-cvs.el (cvs-diff-backup): Use it. - * pcl-cvs.texinfo (Customization): Document it. - - * pcl-cvs.el (cvs-execute-single-file-list): Remove &rest before - last argument. No callers needed updating. - - * pcl-cvs.el (cvs-execute-list): Remove the &rest before the last - argument (constant-args). Update all callers of cvs-execute-list - to use the new calling convention. - * pcl-cvs.el (cvs-cvs-diff-flags): Now a list of strings instead - of a string. - * pcl-cvs.texinfo (Customization): Document the change to - cvs-cvs-diff-flags. - - * Release 0.96. - - * pcl-cvs.el (cvs-cvs-diff-flags): New variable. - * pcl-cvs.el (cvs-diff-cvs): Use it. - * pcl-cvs.texinfo (Customization, Viewing differences): Document it. - - * pcl-cvs.el (cvs-use-temp-buffe): Don't switch to the temporary - buffer. Use display-buffer and set-buffer instead. This way - cvs-log, cvs-status, cvs-diff-cvs and friends don't select the - temporary buffer. The cursor will remain in the *cvs* buffer. - -Sun Mar 22 21:50:18 1992 Per Cederqvist (ceder@robin) - - * pcl-cvs.el (cvs-find-file, cvs-find-file-other-window): Don't - prompt when reading in a directory in dired. - - * Makefile (pcl-cvs-$(VER)): Include pcl-cvs-startup.el in the - distribution. - - * dist-makefile (pcl-cvs.dvi): Don't fail even if texindex does - not exist. - - * pcl-cvs.texinfo (@setchapternewpage): Changed from 'off' to 'on'. - * pcl-cvs.texinfo (Variable index): Joined into function index. - * pcl-cvs.texinfo (Key index): add a description about the key. - * pcl-cvs.texinfo: Many other small changes. - -Wed Mar 18 01:58:38 1992 Per Cederqvist (ceder@leopold) - - * Use GNU General Public License version 2. -
--- a/lisp/pcl-cvs/INSTALL Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,94 +0,0 @@ -This text is copied from the TeXinfo manual for pcl-cvs. - -Installation of the pcl-cvs program -=================================== - - 1. Possibly edit the file `Makefile' to reflect the situation at your - site. We say "possibly" because the version of pcl-cvs included - with CVS uses a configuration mechanism integrated with the overall - mechanisms used by the CVS build and install procedures. Thus the - file `Makefile' will be generated automatically from the file - `Makefile.in', and it should not be necessary to edit it further. - - If you do have to edit the `Makefile', the only things you have to - change is the definition of `lispdir' and `infodir'. The elisp - files will be copied to `lispdir', and the info file(s) to - `infodir'. - - 2. Configure pcl-cvs.el - - There are a couple of pathnames that you have to check to make - sure that they match your system. They appear early in the file - `pcl-cvs.el'. - - *NOTE:* If your system is running emacs 18.57 or earlier you MUST - uncomment the line that says: - (setq delete-exited-processes nil) - - Setting `delete-exited-processes' to `nil' works around a bug in - emacs that causes it to dump core. The bug was fixed in emacs - 18.58. - - 3. Release 1.05 and later of pcl-cvs requires parts of the Elib - library, version 1.0 or later. Elib is available via anonymous - ftp from prep.ai.mit.edu in `pub/gnu/elib-1.0.tar.gz', and from a - lot of other sites that mirror prep. Get Elib, and install it, - before proceeding. - - *NOTE:* The version of pcl-cvs included with CVS includes a copy - of Elib in the sub-directory `elib' under the `contrib/pcl-cvs' - directory. - - 4. Type `make install' in the source directory. This will - byte-compile all `.el' files and copy the `*.elc' files into the - directory you specified in step 1. - - If you want to install the `*.el' files too, you can type `make - install-el' to do so. - - If you only want to create the compiled elisp files, but don't - want to install them, you can type `make' without parameters. - - 5. Edit the file `default.el' in your emacs lisp directory (usually - `/usr/gnu/lib/emacs/site-lisp' or something similar) and enter the - contents of the file `pcl-cvs-startup.el' into it. It contains a - couple of `auto-load's that facilitates the use of pcl-cvs. - - -Installation of the on-line manual. -=================================== - - 1. Create the info file(s) `pcl-cvs.info*' from `pcl-cvs.texinfo' by - typing `make info'. If you don't have the program `makeinfo' you - can get it by anonymous ftp from e.g. `prep.ai.mit.edu' as - `pub/gnu/texinfo-3.7.tar.gz' (there might be a newer version there - when you read this). - - 2. Install the info file(s) `pcl-cvs.info*' into your standard `info' - directory. You should be able to do this by typing `make - install-info'. - - 3. Edit the file `dir' in the `info' directory and enter one line to - contain a pointer to the info file(s) `pcl-cvs.info*'. The line - can, for instance, look like this: - - * Pcl-cvs: (pcl-cvs). An Emacs front-end to CVS. - -How to make typeset documentation from pcl-cvs.texinfo -====================================================== - - If you have TeX installed at your site, you can make a typeset manual -from `pcl-cvs.texinfo'. - - 1. Run TeX by typing ``make pcl-cvs.dvi''. You will not get the - indices unless you have the `texindex' program. - - 2. Convert the resulting device independent file `pcl-cvs.dvi' to a - form which your printer can output and print it. If you have a - postscript printer there is a program, `dvi2ps', which does. There - is also a program which comes together with TeX, `dvips', which - you can use. - - --- -#ident "@(#)cvs/contrib/pcl-cvs:$Name: r20-0b30 $Id: INSTALL,v 1.1.1.1 1996/12/18 22:42:58 steve Exp $"
--- a/lisp/pcl-cvs/NEWS Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,149 +0,0 @@ -This is the NEWS file for pcl-cvs, an Emacs elisp front-end to CVS. - -User-visible changes in the un-official CVS release of pcl-cvs -from the official 1.05 release to 1.05-CVS-$Name: r20-0b30 $: - -* Support for using ChangeLog files, including hooks to automatically - guess CVS log entries from ChangeLog contents. - -* Support for client/server CVS (versions 1.5 through 1.7 and newer). - -* New commands for tagging files and directory trees (still needs to - be made to run in the background). - -* Better support for recognizing and handling unknown directories. - -* An attempt at new ediff and emerge interfaces (still needs work!), - including attempts to make vendor-branch merging work. - -* In a possibly misguided attempt to make it easier to see the effects - of changes that affect several files, diff output is now stored in a - uniqe buffer for each file. - -* Some commands now have default flags (cvs-*-flags). - -* Proper quoting of command line arguments displayed in *cvs-tmp*. - -* More hacking with getting CVSROOT right, though probably all - pointless, since CVS should do the right thing all the time. - -* Elib is back, at least in the CVS distribution. - -* Lots of minor bug fixes, tweaks, cleanup, re-indentation, etc. - -* Some minor tweaks, fixes, re-indentation, etc., in the - documentation. - - -User-visible changes in pcl-cvs from 1.04 to 1.05: - -* Elib is no longer distributed with pcl-cvs. You must get Elib - separately, for instance from ftp.lysator.liu.se in pub/emacs. - -* The Lucid Emacs support works again. - -* A new function, cvs-change-cvsroot, can be used to interactively - switch between CVS repositories. - -* The mode line in the *cvs* buffer now indicates when a "cvs update" - is running. - -* The .cvsignore file is automatically sorted alphabetically (to - reduce the risk of conflicts when two people add different files - simultaneously). This behaviour can be turned off with - cvs-sort-ignore-file. - -* A trailing newline is always added in commit log messages. This - behaviour can be turned off with - cvs-commit-buffer-require-final-newline. - -* This version of pcl-cvs should work together with RCVS. I have not - tested this myself, though. - -* Plus some bug fixes. (Note that the version of cookie.el that is - distributed with pcl-cvs 1.04 contains errors that affects pcl-cvs. - You should get Elib 0.07). - - -User-visible changes in pcl-cvs from 1.03 to 1.04: - -* Support for Emerge. Hitting "e" on a file that is Modified, Merged - or in Conflict will start Emerge, an interactive file merger written - in Emacs Lisp. This requires Emerge version 4. Emerge is not - included in this package. If you can't find it anywhere else, you - can get in from ftp.lysator.liu.se in pub/emacs. This package makes - it a lot easier to resolve conflicts. - -* Emacs will now automatically revert your buffers when the CVS - commands pcl-cvs issues causes the file to change. This automatic - revert never occurs if the buffer contents did not agree with the - file prior to the command. - -* If you are running Lucid GNU Emacs, you will get some fonts and - mouse support. This was contributed from people at Lucid. - -* The variable cvs-cvsroot can be used to select the location if the - repository. You no longer need to exit Emacs, setenv CVSROOT, and - start a new Emacs if you work with multiple repositories. - -* The "q" key can be used to hide the *cvs* buffer. - -* The name of the commands in the *cvs* have changed. If it was called - cvs-foo, it will now be called cvs-mode-foo. See the ChangeLog - entry from Tue Aug 4 03:02:25 1992 for a complete list of changes. - -* The variable cvs-cvs-diff-flags is no longer used. Instead, - cvs-diff-flags is always used. - -* Plus a lot of bug fixes. - - -User-visible changes in pcl-cvs from 1.02 to 1.03: - -* Output from CVS to stdout and stderr is separated and parsed - independently. In that way pcl-cvs should work regardless of - whether stdout is buffered or line-buffered. Pcl-cvs should now - work with CVS 1.3 without modifications on hosts such as - DECstations. - -* Pcl-cvs now fully supports RCS version 5.6 as well as 5.5. - -* New functions: - - + cvs-undo-local-changes ("U") - Undo all your modifications - to a file and get the newest - version from the repository. - + cvs-update-other-window - Similar to cvs-update. - + cvs-byte-compile-files - Byte compile the selected files. - -* cvs-update now displays the *cvs* buffer, which initially contains a - small message ("Running `cvs update' in /foo/bar/gazonk/...") until - the update is ready. The *cvs* buffer no longer pops up when the - update is ready. It often failed to pop up, due to race conditions - that are very hard to solve (and I doubt that they were at all - solvable). - -* cvs-unmark-all-files is moved from "U" to "ESC DEL" to be - "compatible" with dired. - -* cvs-diff ("d") and cvs-diff-backup ("b") can be configured to work - on only the file the cursor is positioned on, and ignore any marked - files. A prefix argument toggles this. - -* Only one `cvs update' can be run at a time. (It was previously - possible to start more than one simultaneously, but pcl-cvs could - not really handle more than one.) - -* Some rudimentary support for programs that CVS runs at update (due - to the -u switch in the modules file). - -* Pcl-cvs now automatically generates a bug report if it can't parse - the output from CVS. - -* The *cvs* buffer is read-only. - -* Pcl-cvs now creates temporary files in $TMPDIR if that environment - variable is set (otherwise it uses /tmp). - ----End of file NEWS--- -#ident "@(#)cvs/contrib/pcl-cvs:$Name: r20-0b30 $:$Id: NEWS,v 1.1.1.1 1996/12/18 22:42:58 steve Exp $"
--- a/lisp/pcl-cvs/README Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,25 +0,0 @@ -This is the readme file for pcl-cvs, release 1.05-CVS-$Name: r20-0b30 $. - -Pcl-cvs is a front-end to CVS versions 1.5 through 1.7. It integrates -the most frequently used CVS commands into an emacs interface. - -There may be some configuration that needs to be done in pcl-cvs.el to -get it to work. See the instructions in the file INSTALL. - -Full documentation is in Texinfo format in the file pcl-cvs.texinfo. To -browse this document online, or in the emacs info mode, you will need to -process this file with the makeinfo program, which can also be found on -prep.ai.mit.edu in pub/gnu. - -If you have been using a previous version of pcl-cvs (for instance the -official 1.05 release, or any previous releases) you should read through -the file NEWS to see what has changed. - -This release has been tested under, Emacs 19.28 and Emacs 19.30. - -Per Cederqvist -(updated by Jim Blandy, Greg A. Woods, Karl Fogel) - --- -#OrigId "@(#) Id: README,v 1.14 1993/05/31 22:43:36 ceder Exp " -#ident "@(#)cvs/contrib/pcl-cvs:$Name: r20-0b30 $:$Id: README,v 1.1.1.1 1996/12/18 22:42:58 steve Exp $"
--- a/lisp/pcl-cvs/auto-autoloads.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -;;; DO NOT MODIFY THIS FILE -(if (featurep 'pcl-cvs-autoloads) (error "Already loaded")) - -;;;### (autoloads (pcl-cvs-fontify) "pcl-cvs-xemacs" "pcl-cvs/pcl-cvs-xemacs.el") - -(autoload 'pcl-cvs-fontify "pcl-cvs-xemacs" nil nil nil) - -;;;*** - -;;;### (autoloads (cvs-update-other-window cvs-update) "pcl-cvs" "pcl-cvs/pcl-cvs.el") - -(autoload 'cvs-update "pcl-cvs" "\ -Run a 'cvs update' in the current working directory. Feed the -output to a *cvs* buffer and run cvs-mode on it. -If optional prefix argument LOCAL is non-nil, 'cvs update -l' is run." t nil) - -(autoload 'cvs-update-other-window "pcl-cvs" "\ -Run a 'cvs update' in the current working directory. Feed the -output to a *cvs* buffer, display it in the other window, and run -cvs-mode on it. - -If optional prefix argument LOCAL is non-nil, 'cvs update -l' is run." t nil) - -;;;*** - -(provide 'pcl-cvs-autoloads)
--- a/lisp/pcl-cvs/cookie.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1137 +0,0 @@ -;;; $Id: cookie.el,v 1.1.1.1 1996/12/18 22:42:58 steve Exp $ -;;; cookie.el -- Utility to display cookies in buffers - -;; Copyright (C) 1991-1995 Free Software Foundation - -;; Author: Per Cederqvist <ceder@lysator.liu.se> -;; Inge Wallin <inge@lysator.liu.se> -;; Maintainer: elib-maintainers@lysator.liu.se -;; Created: 3 Aug 1992 -;; Keywords: extensions, lisp - -;;; This program is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 2 of the License, or -;;; (at your option) any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with GNU Elib; see the file COPYING. If not, write to -;;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;;; Boston, MA 02111-1307, USA -;;; - - -;;; Commentary: - -;;; Introduction -;;; ============ -;;; -;;; Cookie is a package that implements a connection between an -;;; dll (a doubly linked list) and the contents of a buffer. -;;; Possible uses are dired (have all files in a list, and show them), -;;; buffer-list, kom-prioritize (in the LysKOM elisp client) and -;;; others. pcl-cvs.el uses cookie.el. -;;; -;;; A `cookie' can be any lisp object. When you use the cookie -;;; package you specify a pretty-printer, a function that inserts -;;; a printable representation of the cookie in the buffer. (The -;;; pretty-printer should use "insert" and not -;;; "insert-before-markers"). -;;; -;;; A `collection' consists of a doubly linked list of cookies, a -;;; header, a footer and a pretty-printer. It is displayed at a -;;; certain point in a certain buffer. (The buffer and point are -;;; fixed when the collection is created). The header and the footer -;;; are constant strings. They appear before and after the cookies. -;;; (Currently, once set, they can not be changed). -;;; -;;; Cookie does not affect the mode of the buffer in any way. It -;;; merely makes it easy to connect an underlying data representation -;;; to the buffer contents. -;;; -;;; A `tin' is an object that contains one cookie. There are -;;; functions in this package that given a tin extracts the cookie, or -;;; gives the next or previous tin. (All tins are linked together in -;;; a doubly linked list. The 'previous' tin is the one that appears -;;; before the other in the buffer.) You should not do anything with -;;; a tin except pass it to the functions in this package. -;;; -;;; A collection is a very dynamic thing. You can easily add or -;;; delete cookies. You can sort all cookies in a collection (you -;;; have to supply a function that compares two cookies). You can -;;; apply a function to all cookies in a collection, et c, et c. -;;; -;;; Remember that a cookie can be anything. Your imagination is the -;;; limit! It is even possible to have another collection as a -;;; cookie. In that way some kind of tree hierarchy can be created. -;;; -;;; Full documentation will, God willing, soon be available in a -;;; Texinfo manual. - - - -;;; Coding conventions -;;; ================== -;;; -;;; All functions that are intended for external use begin with one of -;;; the prefixes "cookie-", "collection-" or "tin-". The prefix -;;; "elib-" is used for internal functions and macros. There are -;;; currently no global or buffer-local variables used. -;;; -;;; Many function operate on `tins' instead of `cookies'. To avoid -;;; confusion most of the function names include the string "cookie" -;;; or "tin" to show this. -;;; -;;; Most doc-strings contains an "Args:" line that lists the -;;; arguments. -;;; -;;; The internal functions don't contain any doc-strings. RMS thinks -;;; this is a good way to save space. - - - -;;; INTERNAL DOCUMENTATION (Your understanding of this package might -;;; increase if you read it, but you should not exploit the knowledge -;;; you gain. The internal details might change without notice). -;;; -;;; A collection is implemented as an dll (a doubly linked list). -;;; The first and last element on the list are always the header and -;;; footer (as strings). Any remaining entries are `wrappers'. -;;; -;;; At the implementation level a `tin' is really an elib-node that -;;; consists of -;;; left Pointer to previous tin -;;; right Pointer to next tin -;;; data Holder of a `wrapper'. -;;; These internals of an elib-node are in fact unknown to cookie.el. -;;; It uses dll.el to handle everything that deals with the -;;; doubly linked list. -;;; -;;; The wrapper data type contains -;;; start-marker Position of the printed representation of the -;;; cookie in the buffer. -;;; cookie The user-supplied cookie. -;;; -;;; The wrapper is not accessible to the user of this package. - -;;; Code: - -(require 'dll) -(provide 'cookie) - - -;;; ================================================================ -;;; Internal macros for use in the cookie package - - -(put 'elib-set-buffer-bind-dll 'lisp-indent-hook 1) - -(defmacro elib-set-buffer-bind-dll (collection &rest forms) - - ;; Execute FORMS with collection->buffer selected as current buffer, - ;; and dll bound to collection->dll. - ;; Return value of last form in FORMS. INTERNAL USE ONLY. - - (let ((old-buffer (make-symbol "old-buffer")) - (hnd (make-symbol "collection"))) - (` (let* (((, old-buffer) (current-buffer)) - ((, hnd) (, collection)) - (dll (elib-collection->dll (, hnd)))) - (set-buffer (elib-collection->buffer (, hnd))) - (unwind-protect - (progn (,@ forms)) - (set-buffer (, old-buffer))))))) - - -(put 'elib-set-buffer-bind-dll-let* 'lisp-indent-hook 2) - -(defmacro elib-set-buffer-bind-dll-let* (collection varlist &rest forms) - - ;; Execute FORMS with collection->buffer selected as current buffer, - ;; dll bound to collection->dll, and VARLIST bound as in a let*. - ;; dll will be bound when VARLIST is initialized, but the current - ;; buffer will *not* have been changed. - ;; Return value of last form in FORMS. INTERNAL USE ONLY. - - (let ((old-buffer (make-symbol "old-buffer")) - (hnd (make-symbol "collection"))) - (` (let* (((, old-buffer) (current-buffer)) - ((, hnd) (, collection)) - (dll (elib-collection->dll (, hnd))) - (,@ varlist)) - (set-buffer (elib-collection->buffer (, hnd))) - (unwind-protect - (progn (,@ forms)) - (set-buffer (, old-buffer))))))) - - -(defmacro elib-filter-hf (collection tin) - - ;; Evaluate TIN once and return it. BUT if it is - ;; the header or the footer in COLLECTION return nil instead. - ;; Args: COLLECTION TIN - ;; INTERNAL USE ONLY. - - (let ((tempvar (make-symbol "tin")) - (tmpcoll (make-symbol "tmpcollection"))) - (` (let (((, tempvar) (, tin)) - ((, tmpcoll) (, collection))) - (if (or (eq (, tempvar) (elib-collection->header (, tmpcoll))) - (eq (, tempvar) (elib-collection->footer (, tmpcoll)))) - nil - (, tempvar)))))) - - - -;;; ================================================================ -;;; Internal data types for use in the cookie package - -;;; Yes, I know about cl.el, but I don't like it. /ceder - -;;; The wrapper data type. - -(defun elib-create-wrapper (start-marker cookie) - ;; Create a wrapper. INTERNAL USE ONLY. - (cons 'WRAPPER (vector start-marker cookie))) - -(defun elib-wrapper->start-marker (wrapper) - ;; Get start-marker from wrapper. INTERNAL USE ONLY. - (elt (cdr wrapper) 0)) - -(defun elib-wrapper->cookie-safe (wrapper) - ;; Get cookie from wrapper. INTERNAL USE ONLY. - ;; Returns nil if given nil as input. - ;; Since (elt nil 1) returns nil in emacs version 18.57 and 18.58 - ;; this can be defined in this way. The documentation in the info - ;; file says that elt should signal an error in that case. I think - ;; it is the documentation that is buggy. (The bug is reported). - (elt (cdr wrapper) 1)) - -(defun elib-wrapper->cookie (wrapper) - ;; Get cookie from wrapper. INTERNAL USE ONLY. - (elt (cdr wrapper) 1)) - - - -;;; The collection data type - -(defun elib-create-collection (buffer pretty-printer - header-wrapper footer-wrapper - dll) - ;; Create a collection. INTERNAL USE ONLY. - (cons 'COLLECTION - ;; The last element is a pointer to the last tin - ;; the cursor was at, or nil if that is unknown. - (vector buffer - pretty-printer - header-wrapper footer-wrapper - dll nil))) - - -(defun elib-collection->buffer (collection) - ;; Get buffer from COLLECTION. - (elt (cdr collection) 0)) - -(defun elib-collection->pretty-printer (collection) - ;; Get pretty-printer from COLLECTION. - (elt (cdr collection) 1)) - -(defun elib-collection->header (collection) - ;; Get header from COLLECTION. - (elt (cdr collection) 2)) - -(defun elib-collection->footer (collection) - ;; Get footer from COLLECTION. - (elt (cdr collection) 3)) - -(defun elib-collection->dll (collection) - ;; Get dll from COLLECTION. - (elt (cdr collection) 4)) - -(defun elib-collection->last-tin (collection) - ;; Get last-tin from COLLECTION. - (elt (cdr collection) 5)) - - - -(defun elib-set-collection->buffer (collection buffer) - ;; Change the buffer. Args: COLLECTION BUFFER. - (aset (cdr collection) 0 buffer)) - -(defun elib-set-collection->pretty-printer (collection pretty-printer) - ;; Change the pretty-printer. Args: COLLECTION PRETTY-PRINTER. - (aset (cdr collection) 1 pretty-printer)) - -(defun elib-set-collection->header (collection header) - ;; Change the header. Args: COLLECTION HEADER. - (aset (cdr collection) 2 header)) - -(defun elib-set-collection->footer (collection footer) - ;; Change the footer. Args: COLLECTION FOOTER. - (aset (cdr collection) 3 footer)) - -(defun elib-set-collection->dll (collection dll) - ;; Change the dll. Args: COLLECTION DLL. - (aset (cdr collection) 4 dll)) - -(defun elib-set-collection->last-tin (collection last-tin) - ;; Change the last-tin. Args: COLLECTION LAST-TIN. - (aset (cdr collection) 5 last-tin)) - - -;;; ================================================================ -;;; Internal functions for use in the cookie package - -(defun elib-abs (x) - ;; Return the absolute value of x - (max x (- x))) - -(defun elib-create-wrapper-and-insert (cookie string pos) - ;; Insert STRING at POS in current buffer. Remember the start - ;; position. Create a wrapper containing that start position and the - ;; COOKIE. - ;; INTERNAL USE ONLY. - - (save-excursion - (goto-char pos) - ;; Remember the position as a number so that it doesn't move - ;; when we insert the string. - (let ((start (if (markerp pos) - (marker-position pos) - pos)) - (buffer-read-only nil)) - ;; Use insert-before-markers so that the marker for the - ;; next cookie is updated. - (insert-before-markers string) - - ;; Always insert a newline. You want invisible cookies? You - ;; lose. (At least in this version). FIXME-someday. (It is - ;; harder to fix than it might seem. All markers have to point - ;; to the right place all the time...) - (insert-before-markers ?\n) - (elib-create-wrapper (copy-marker start) cookie)))) - - -(defun elib-create-wrapper-and-pretty-print (cookie - pretty-printer pos) - ;; Call PRETTY-PRINTER with point set at POS in current buffer. - ;; Remember the start position. Create a wrapper containing that - ;; start position and the COOKIE. - ;; INTERNAL USE ONLY. - - (save-excursion - (goto-char pos) - ;; Remember the position as a number so that it doesn't move - ;; when we insert the string. - (let ((start (if (markerp pos) - (marker-position pos) - pos)) - (buffer-read-only nil)) - ;; Insert the trailing newline using insert-before-markers - ;; so that the start position for the next cookie is updated. - (insert-before-markers ?\n) - ;; Move back, and call the pretty-printer. - (backward-char 1) - (funcall pretty-printer cookie) - (elib-create-wrapper (copy-marker start) cookie)))) - - -(defun elib-delete-tin-internal (collection tin) - ;; Delete a cookie string from COLLECTION. INTERNAL USE ONLY. - ;; Can not be used on the footer. Returns the wrapper that is deleted. - ;; The start-marker in the wrapper is set to nil, so that it doesn't - ;; consume any more resources. - (let ((dll (elib-collection->dll collection)) - (buffer-read-only nil)) - ;; If we are about to delete the tin pointed at by last-tin, - ;; set last-tin to nil. - (if (eq (elib-collection->last-tin collection) tin) - (elib-set-collection->last-tin collection nil)) - - (delete-region (elib-wrapper->start-marker (dll-element dll tin)) - (elib-wrapper->start-marker - (dll-element dll (dll-next dll tin)))) - (set-marker (elib-wrapper->start-marker (dll-element dll tin)) nil) - ;; Delete the tin, and return the wrapper. - (dll-delete dll tin))) - -(defun elib-refresh-tin (collection tin) - ;; Redisplay the cookie represented by TIN. INTERNAL USE ONLY. - ;; Args: COLLECTION TIN - ;; Can not be used on the footer. dll *must* be bound to - ;; (elib-collection->dll collection). - - (let ((buffer-read-only nil)) - (save-excursion - ;; First, remove the string from the buffer: - (delete-region (elib-wrapper->start-marker (dll-element dll tin)) - (1- (marker-position - (elib-wrapper->start-marker - (dll-element dll (dll-next dll tin)))))) - - ;; Calculate and insert the string. - - (goto-char (elib-wrapper->start-marker (dll-element dll tin))) - (funcall (elib-collection->pretty-printer collection) - (elib-wrapper->cookie (dll-element dll tin)))))) - - -(defun elib-pos-before-middle-p (collection pos tin1 tin2) - - ;; Return true if for the cookies in COLLECTION, POS is in the first - ;; half of the region defined by TIN1 and TIN2. - - (let ((dll (elib-collection->dll collection))) - (< pos (/ (+ (elib-wrapper->start-marker (dll-element dll tin1)) - (elib-wrapper->start-marker (dll-element dll tin2))) - 2)))) - - -;;; =========================================================================== -;;; Public members of the cookie package - - -(defun collection-create (buffer pretty-printer - &optional header footer pos) - "Create an empty collection of cookies. -Args: BUFFER PRETTY-PRINTER &optional HEADER FOOTER POS. - -The collection will be inserted in BUFFER. BUFFER may be a -buffer or a buffer name. It is created if it does not exist. - -PRETTY-PRINTER should be a function that takes one argument, a -cookie, and inserts a string representing it in the buffer (at -point). The string PRETTY-PRINTER inserts may be empty or span -several linse. A trailing newline will always be inserted -automatically. The PRETTY-PRINTER should use insert, and not -insert-before-markers. - -Optional third argument HEADER is a string that will always be -present at the top of the collection. HEADER should end with a -newline. Optionaly fourth argument FOOTER is similar, and will -always be inserted at the bottom of the collection. - -Optional fifth argument POS is a buffer position, specifying -where the collection will be inserted. It defaults to the -begining of the buffer." - - (let ((new-collection - (elib-create-collection (get-buffer-create buffer) - pretty-printer nil nil (dll-create)))) - - (elib-set-buffer-bind-dll new-collection - ;; Set default values - (if (not header) - (setq header "")) - (if (not footer) - (setq footer "")) - (if (not pos) - (setq pos (point-min)) - (if (markerp pos) - (set pos (marker-position pos)))) ;Force header to be above footer. - - (let ((foot (elib-create-wrapper-and-insert footer footer pos)) - (head (elib-create-wrapper-and-insert header header pos))) - - (dll-enter-first dll head) - (dll-enter-last dll foot) - (elib-set-collection->header new-collection (dll-nth dll 0)) - (elib-set-collection->footer new-collection (dll-nth dll -1)))) - - ;; Return the collection - new-collection)) - - -(defun tin-cookie (collection tin) - "Get the cookie from a TIN. Args: COLLECTION TIN." - (elib-wrapper->cookie (dll-element (cookie->dll collection) tin))) - -(defun cookie-enter-first (collection cookie) - "Enter a COOKIE first in the cookie collection COLLECTION. -Args: COLLECTION COOKIE." - - (elib-set-buffer-bind-dll collection - - ;; It is always safe to insert an element after the first element, - ;; because the header is always present. (dll-nth dll 0) should - ;; therefore never return nil. - - (dll-enter-after - dll - (dll-nth dll 0) - (elib-create-wrapper-and-pretty-print - cookie - (elib-collection->pretty-printer collection) - (elib-wrapper->start-marker - (dll-element dll (dll-nth dll 1))))))) - - -(defun cookie-enter-last (collection cookie) - "Enter a COOKIE last in the cookie-collection COLLECTION. -Args: COLLECTION COOKIE." - - (elib-set-buffer-bind-dll collection - - ;; Remember that the header and footer are always present. There - ;; is no need to check if (dll-nth dll -1) returns nil - it never - ;; does. - - (dll-enter-before - dll - (dll-nth dll -1) - (elib-create-wrapper-and-pretty-print - cookie - (elib-collection->pretty-printer collection) - (elib-wrapper->start-marker (dll-last dll)))))) - - -(defun cookie-enter-after-tin (collection tin cookie) - "Enter a new COOKIE after TIN. -Args: COLLECTION TIN COOKIE." - (elib-set-buffer-bind-dll collection - (dll-enter-after - dll tin - (elib-create-wrapper-and-pretty-print - cookie - (elib-collection->pretty-printer collection) - (elib-wrapper->start-marker (dll-element dll (dll-next dll tin))))))) - - -(defun cookie-enter-before-tin (collection tin cookie) - "Enter a new COOKIE before TIN. -Args: COLLECTION TIN COOKIE." - (elib-set-buffer-bind-dll collection - (dll-enter-before - dll tin - (elib-create-wrapper-and-pretty-print - cookie - (elib-collection->pretty-printer collection) - (elib-wrapper->start-marker (dll-element dll tin)))))) - - -(defun tin-next (collection tin) - "Get the next tin. Args: COLLECTION TIN. -Returns nil if TIN is nil or the last cookie." - (if tin - (elib-filter-hf - collection (dll-next (elib-collection->dll collection) tin)) - nil)) - -(defun tin-previous (collection tin) - "Get the previous tin. Args: COLLECTION TIN. -Returns nil if TIN is nil or the first cookie." - (if tin - (elib-filter-hf - collection - (dll-previous (elib-collection->dll collection) tin)) - nil)) - - -(defun tin-nth (collection n) - "Return the Nth tin. Args: COLLECTION N. -N counts from zero. Nil is returned if there is less than N cookies. -If N is negative, return the -(N+1)th last element. -Thus, (tin-nth dll 0) returns the first node, -and (tin-nth dll -1) returns the last node. - -Use tin-cookie to extract the cookie from the tin (or use -cookie-nth instead)." - - ;; Skip the header (or footer, if n is negative). - (if (< n 0) - (setq n (1- n)) - (setq n (1+ n))) - - (elib-filter-hf collection - (dll-nth (elib-collection->dll collection) n))) - -(defun cookie-nth (collection n) - "Return the Nth cookie. Args: COLLECTION N. -N counts from zero. Nil is returned if there is less than N cookies. -If N is negative, return the -(N+1)th last element. -Thus, (cookie-nth dll 0) returns the first cookie, -and (cookie-nth dll -1) returns the last cookie." - - ;; Skip the header (or footer, if n is negative). - (if (< n 0) - (setq n (1- n)) - (setq n (1+ n))) - - (let* ((dll (elib-collection->dll collection)) - (tin (elib-filter-hf collection (dll-nth dll n)))) - (if tin - (elib-wrapper->cookie (dll-element dll tin)) - nil))) - -(defun tin-delete (collection tin) - "Delete a tin from a collection. Args: COLLECTION TIN. -The cookie in the tin is returned." - - (elib-set-buffer-bind-dll collection - (elib-wrapper->cookie - (elib-delete-tin-internal collection tin)))) - - -(defun cookie-delete-first (collection) - "Delete first cookie and return it. Args: COLLECTION. -Returns nil if there are no cookies left in the collection." - - (elib-set-buffer-bind-dll-let* collection - ((tin (dll-nth dll 1))) ;Skip the header. - - ;; We have to check that we do not try to delete the footer. - (if (eq tin (elib-collection->footer collection)) - nil - (elib-wrapper->cookie (elib-delete-tin-internal collection tin))))) - - -(defun cookie-delete-last (collection) - "Delete last cookie and return it. Args: COLLECTION. -Returns nil if there is no cookie left in the collection." - - (elib-set-buffer-bind-dll-let* collection - ((tin (dll-nth dll -2))) ;Skip the footer. - ;; We have to check that we do not try to delete the header. - (if (eq tin (elib-collection->header collection)) - nil - (elib-wrapper->cookie (elib-delete-tin-internal collection tin))))) - -(defun cookie-first (collection) - "Return the first cookie in COLLECTION. The cookie is not removed." - - (let* ((dll (elib-collection->dll collection)) - (tin (elib-filter-hf collection (dll-nth dll -1)))) - (if tin - (elib-wrapper->cookie (dll-element dll tin))))) - - - -(defun cookie-last (collection) - "Return the last cookie in COLLECTION. The cookie is not removed." - - (let* ((dll (elib-collection->dll collection)) - (tin (elib-filter-hf collection (dll-nth dll -2)))) - (if tin - (elib-wrapper->cookie (dll-element dll tin))))) - - -(defun collection-empty (collection) - "Return true if there are no cookies in COLLECTION." - - (eq (dll-nth (elib-collection->dll collection) 1) - (elib-collection->footer collection))) - - -(defun collection-length (collection) - "Return the number of cookies in COLLECTION." - - ;; Don't count the footer and header. - (- (dll-length (elib-collection->dll collection)) 2)) - - -(defun collection-list-cookies (collection) - "Return a list of all cookies in COLLECTION." - - (elib-set-buffer-bind-dll-let* collection - ((result nil) - (header (elib-collection->header collection)) - (tin (dll-nth dll -2))) - (while (not (eq tin header)) - (setq result (cons (elib-wrapper->cookie (dll-element dll tin)) - result)) - (setq tin (dll-previous dll tin))) - result)) - - -(defun collection-clear (collection) - "Remove all cookies in COLLECTION." - - (elib-set-buffer-bind-dll-let* collection - ((header (elib-collection->header collection)) - (footer (elib-collection->footer collection))) - - ;; We have to bind buffer-read-only separately, so that the - ;; current buffer is correct. - (let ((buffer-read-only nil)) - (delete-region (elib-wrapper->start-marker - (dll-element dll (dll-nth dll 1))) - (elib-wrapper->start-marker - (dll-element dll footer)))) - (setq dll (dll-create-from-list (list (dll-element dll header) - (dll-element dll footer)))) - (elib-set-collection->dll collection dll) - - ;; Re-set the header and footer, since they are now new objects. - ;; elib-filter-hf uses eq to compare objects to them... - (elib-set-collection->header collection (dll-nth dll 0)) - (elib-set-collection->footer collection (dll-nth dll -1)))) - - -(defun cookie-map (map-function collection &rest map-args) - "Apply MAP-FUNCTION to all cookies in COLLECTION. -MAP-FUNCTION is applied to the first element first. -If MAP-FUNCTION returns non-nil the cookie will be refreshed (its -pretty-printer will be called once again). - -Note that the buffer for COLLECTION will be current buffer when MAP-FUNCTION -is called. MAP-FUNCTION must restore the current buffer to BUFFER before -it returns, if it changes it. - -If more than two arguments are given to cookie-map, remaining -arguments will be passed to MAP-FUNCTION." - - (elib-set-buffer-bind-dll-let* collection - ((footer (elib-collection->footer collection)) - (tin (dll-nth dll 1))) - - (while (not (eq tin footer)) - - (if (apply map-function - (elib-wrapper->cookie (dll-element dll tin)) - map-args) - (elib-refresh-tin collection tin)) - - (setq tin (dll-next dll tin))))) - - - -(defun cookie-map-reverse (map-function collection &rest map-args) - "Apply MAP-FUNCTION to all cookies in COLLECTION. -MAP-FUNCTION is applied to the last cookie first. -If MAP-FUNCTION returns non-nil the cookie will be refreshed. - -Note that the buffer for COLLECTION will be current buffer when MAP-FUNCTION -is called. MAP-FUNCTION must restore the current buffer to BUFFER before -it returns, if it changes the current buffer. - -If more than two arguments are given to cookie-map, remaining -arguments will be passed to MAP-FUNCTION." - - (elib-set-buffer-bind-dll-let* collection - ((header (elib-collection->header collection)) - (tin (dll-nth dll -2))) - - (while (not (eq tin header)) - - (if (apply map-function - (elib-wrapper->cookie (dll-element dll tin)) - map-args) - (elib-refresh-tin collection tin)) - - (setq tin (dll-previous dll tin))))) - - - -(defun collection-append-cookies (collection cookie-list) - "Insert all cookies in the list COOKIE-LIST last in COLLECTION. -Args: COLLECTION COOKIE-LIST." - - (while cookie-list - (cookie-enter-last collection (car cookie-list)) - (setq cookie-list (cdr cookie-list)))) - - -(defun collection-filter-cookies (collection predicate &rest extra-args) - "Remove all cookies in COLLECTION for which PREDICATE returns nil. -Args: COLLECTION PREDICATE &rest EXTRA-ARGS. -Note that the buffer for COLLECTION will be current-buffer when PREDICATE -is called. PREDICATE must restore the current buffer before it returns -if it changes it. - -The PREDICATE is called with the cookie as its first argument. If any -EXTRA-ARGS are given to collection-filter-cookies they will be passed to the -PREDICATE." - - (elib-set-buffer-bind-dll-let* collection - ((tin (dll-nth dll 1)) - (footer (elib-collection->footer collection)) - (next nil)) - (while (not (eq tin footer)) - (setq next (dll-next dll tin)) - (if (apply predicate - (elib-wrapper->cookie (dll-element dll tin)) - extra-args) - nil - (elib-delete-tin-internal collection tin)) - (setq tin next)))) - - -(defun collection-filter-tins (collection predicate &rest extra-args) - "Remove all cookies in COLLECTION for which PREDICATE returns nil. -Note that the buffer for COLLECTION will be current-buffer when PREDICATE -is called. PREDICATE must restore the current buffer before it returns -if it changes it. - -The PREDICATE is called with one argument, the tin. If any EXTRA-ARGS -are given to collection-filter-cookies they will be passed to the PREDICATE." - - (elib-set-buffer-bind-dll-let* collection - ((tin (dll-nth dll 1)) - (footer (elib-collection->footer collection)) - (next nil)) - (while (not (eq tin footer)) - (setq next (dll-next dll tin)) - (if (apply predicate tin extra-args) - nil - (elib-delete-tin-internal collection tin)) - (setq tin next)))) - - -(defun tin-locate (collection pos &optional guess) - "Return the tin that POS (a buffer position) is within. -Args: COLLECTION POS &optional GUESS. -POS may be a marker or an integer. -GUESS should be a tin that it is likely that POS is near. - -If POS points before the first cookie, the first cookie is returned. -If POS points after the last cookie, the last cookie is returned. -If the COLLECTION is empty, nil is returned." - - (elib-set-buffer-bind-dll-let* collection - ((footer (elib-collection->footer collection))) - - (cond - ;; No cookies present? - ((eq (dll-nth dll 1) (dll-nth dll -1)) - nil) - - ;; Before first cookie? - ((< pos (elib-wrapper->start-marker - (dll-element dll (dll-nth dll 1)))) - (dll-nth dll 1)) - - ;; After last cookie? - ((>= pos (elib-wrapper->start-marker (dll-last dll))) - (dll-nth dll -2)) - - ;; We now know that pos is within a cookie. - (t - ;; Make an educated guess about which of the three known - ;; cookies (the first, the last, or GUESS) is nearest. - (let* ((best-guess (dll-nth dll 1)) - (distance (elib-abs (- pos (elib-wrapper->start-marker - (dll-element dll best-guess)))))) - (if guess - (let* ((g guess) ;Check the guess, if given. - (d (elib-abs - (- pos (elib-wrapper->start-marker - (dll-element dll g)))))) - (cond - ((< d distance) - (setq distance d) - (setq best-guess g))))) - - (let* ((g (dll-nth dll -1)) ;Check the last cookie - (d (elib-abs - (- pos (elib-wrapper->start-marker - (dll-element dll g)))))) - (cond - ((< d distance) - (setq distance d) - (setq best-guess g)))) - - (if (elib-collection->last-tin collection) ;Check "previous". - (let* ((g (elib-collection->last-tin collection)) - (d (elib-abs - (- pos (elib-wrapper->start-marker - (dll-element dll g)))))) - (cond - ((< d distance) - (setq distance d) - (setq best-guess g))))) - - ;; best-guess is now a "best guess". - - ;; Find the correct cookie. First determine in which direction - ;; it lies, and then move in that direction until it is found. - - (cond - ;; Is pos after the guess? - ((>= pos - (elib-wrapper->start-marker (dll-element dll best-guess))) - - ;; Loop until we are exactly one cookie too far down... - (while (>= pos (elib-wrapper->start-marker - (dll-element dll best-guess))) - (setq best-guess (dll-next dll best-guess))) - - ;; ...and return the previous cookie. - (dll-previous dll best-guess)) - - ;; Pos is before best-guess - (t - - (while (< pos (elib-wrapper->start-marker - (dll-element dll best-guess))) - (setq best-guess (dll-previous dll best-guess))) - - best-guess))))))) - - -;;(defun tin-start-marker (collection tin) -;; "Return start-position of a cookie in COLLECTION. -;;Args: COLLECTION TIN. -;;The marker that is returned should not be modified in any way, -;;and is only valid until the contents of the cookie buffer changes." -;; -;; (elib-wrapper->start-marker -;; (dll-element (elib-collection->dll collection) tin))) - - -;;(defun tin-end-marker (collection tin) -;; "Return end-position of a cookie in COLLECTION. -;;Args: COLLECTION TIN. -;;The marker that is returned should not be modified in any way, -;;and is only valid until the contents of the cookie buffer changes." -;; -;; (let ((dll (elib-collection->dll collection))) -;; (elib-wrapper->start-marker -;; (dll-element dll (dll-next dll tin))))) - - - -(defun collection-refresh (collection) - "Refresh all cookies in COLLECTION. - -The pretty-printer that was specified when the COLLECTION was created -will be called for all cookies in COLLECTION. - -Note that tin-invalidate is more efficient if only a small -number of cookies needs to be refreshed." - - (elib-set-buffer-bind-dll-let* collection - - ((header (elib-collection->header collection)) - (footer (elib-collection->footer collection))) - - (let ((buffer-read-only nil)) - (delete-region (elib-wrapper->start-marker - (dll-element dll (dll-nth dll 1))) - (elib-wrapper->start-marker - (dll-element dll footer))) - - (goto-char (elib-wrapper->start-marker - (dll-element dll footer))) - - (let ((tin (dll-nth dll 1))) - (while (not (eq tin footer)) - - (set-marker (elib-wrapper->start-marker (dll-element dll tin)) - (point)) - (funcall (elib-collection->pretty-printer collection) - (elib-wrapper->cookie (dll-element dll tin))) - (insert "\n") - (setq tin (dll-next dll tin))))) - - (set-marker (elib-wrapper->start-marker (dll-element dll footer)) - (point)))) - - -(defun tin-invalidate (collection &rest tins) - "Refresh some cookies. Args: COLLECTION &rest TINS. -The pretty-printer that for COLLECTION will be called for all TINS." - - (elib-set-buffer-bind-dll collection - - (while tins - (elib-refresh-tin collection (car tins)) - (setq tins (cdr tins))))) - - -(defun collection-set-goal-column (collection goal) - "Set goal-column for COLLECTION. -Args: COLLECTION GOAL. -goal-column is made buffer-local. - -There will eventually be a better way to specify the cursor position." - (elib-set-buffer-bind-dll collection - (make-local-variable 'goal-column) - (setq goal-column goal))) - - -(defun tin-goto-previous (collection pos arg) - "Move point to the ARGth previous cookie. -Don't move if we are at the first cookie, or if COLLECTION is empty. -Args: COLLECTION POS ARG. -Returns the tin we move to." - - (elib-set-buffer-bind-dll-let* collection - ((tin (tin-locate - collection pos (elib-collection->last-tin collection)))) - - (cond - (tin - (while (and tin (> arg 0)) - (setq arg (1- arg)) - (setq tin (dll-previous dll tin))) - - ;; Never step above the first cookie. - - (if (null (elib-filter-hf collection tin)) - (setq tin (dll-nth dll 1))) - - (goto-char - (elib-wrapper->start-marker - (dll-element dll tin))) - - (if goal-column - (move-to-column goal-column)) - (elib-set-collection->last-tin collection tin) - tin)))) - - -(defun tin-goto-next (collection pos arg) - "Move point to the ARGth next cookie. -Don't move if we are at the last cookie. -Args: COLLECTION POS ARG. -Returns the tin." - - ;;Need to do something clever with (current-buffer)... - ;;Previously, when the buffer was used instead of the collection, this line - ;;did the trick. No longer so... This is hard to do right! Remember that a - ;;cookie can contain a collection! - ;;(interactive (list (current-buffer) (point) - ;; (prefix-numeric-value current-prefix-arg))) - - (elib-set-buffer-bind-dll-let* collection - ((tin (tin-locate - collection pos (elib-collection->last-tin collection)))) - - (while (and tin (> arg 0)) - (setq arg (1- arg)) - (setq tin (dll-next dll tin))) - - ;; Never step below the first cookie. - - (if (null (elib-filter-hf collection tin)) - (setq tin (dll-nth dll -2))) - - (goto-char - (elib-wrapper->start-marker - (dll-element dll tin))) - - (if goal-column - (move-to-column goal-column)) - - (elib-set-collection->last-tin collection tin) - tin)) - - -(defun tin-goto (collection tin) - "Move point to TIN. Args: COLLECTION TIN." - (elib-set-buffer-bind-dll collection - (goto-char - (elib-wrapper->start-marker - (dll-element dll tin))) - - (if goal-column - (move-to-column goal-column)) - - (elib-set-collection->last-tin collection tin))) - - -(defun collection-collect-tin (collection predicate &rest predicate-args) - "Select cookies from COLLECTION using PREDICATE. -Return a list of all selected tins. - -PREDICATE is a function that takes a cookie as its first argument. - -The tins on the returned list will appear in the same order as in the -buffer. You should not rely on in which order PREDICATE is called. - -Note that the buffer the COLLECTION is displayed in is current-buffer -when PREDICATE is called. If PREDICATE must restore current-buffer if -it changes it. - -If more than two arguments are given to collection-collect-tin the remaining -arguments will be passed to PREDICATE." - - (elib-set-buffer-bind-dll-let* collection - ((header (elib-collection->header collection)) - (tin (dll-nth dll -2)) - (result nil)) - - ;; Collect the tins, starting at the last one, so that they - ;; appear in the correct order in the result (which is cons'ed - ;; together). - - (while (not (eq tin header)) - - (if (apply predicate - (elib-wrapper->cookie (dll-element dll tin)) - predicate-args) - (setq result (cons tin result))) - - (setq tin (dll-previous dll tin))) - result)) - - -(defun collection-collect-cookie (collection predicate &rest predicate-args) - "Select cookies from COLLECTION using PREDICATE. -Return a list of all selected cookies. - -PREDICATE is a function that takes a cookie as its first argument. - -The cookies on the returned list will appear in the same order as in -the buffer. You should not rely on in which order PREDICATE is -called. - -Note that the buffer the COLLECTION is displayed in is current-buffer -when PREDICATE is called. If PREDICATE must restore current-buffer if -it changes it. - -If more than two arguments are given to collection-collect-cookie the -remaining arguments will be passed to PREDICATE." - - (elib-set-buffer-bind-dll-let* collection - ((header (elib-collection->header collection)) - (tin (dll-nth dll -2)) - result) - - (while (not (eq tin header)) - - (if (apply predicate - (elib-wrapper->cookie (dll-element dll tin)) - predicate-args) - (setq result (cons (elib-wrapper->cookie (dll-element dll tin)) - result))) - - (setq tin (dll-previous dll tin))) - result)) - - -(defun cookie-sort (collection predicate) - "Sort the cookies in COLLECTION, stably, comparing elements using PREDICATE. -PREDICATE is called with two cookies, and should return T -if the first cookie is \"less\" than the second. - -All cookies will be refreshed when the sort is complete." - - (elib-set-collection->last-tin collection nil) - - (collection-append-cookies - collection - (prog1 (sort (collection-list-cookies collection) predicate) - (collection-clear collection)))) - - -(defun collection-buffer (collection) - "Return the buffer that is associated with COLLECTION. -Returns nil if the buffer has been deleted." - (let ((buf (elib-collection->buffer collection))) - (if (buffer-name buf) - buf - nil))) - - -;;; Local Variables: -;;; eval: (put 'elib-set-buffer-bind-dll 'lisp-indent-hook 1) -;;; eval: (put 'elib-set-buffer-bind-dll-let* 'lisp-indent-hook 2) -;;; End: - -;;; cookie.el ends here
--- a/lisp/pcl-cvs/dll-debug.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,315 +0,0 @@ -;;; dll-debug -- A slow implementation of dll for debugging. -;;; $Id: dll-debug.el,v 1.1.1.1 1996/12/18 22:42:58 steve Exp $ - -;; Copyright (C) 1991-1995 Free Software Foundation - -;; Author: Per Cederqvist <ceder@lysator.liu.se> -;; Maintainer: elib-maintainers@lysator.liu.se -;; Created: before 24 Sep 1991 -;; Keywords: extensions, lisp - -;;; This program is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 2 of the License, or -;;; (at your option) any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with GNU Elib; see the file COPYING. If not, write to -;;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;;; Boston, MA 02111-1307, USA - -;;; Commentary: - -;;; This is a plug-in replacement for dll.el. It is dreadfully -;;; slow, but it facilitates debugging. Don't trust the comments in -;;; this file too much. -(provide 'dll) - -;;; -;;; A doubly linked list consists of one cons cell which holds the tag -;;; 'DL-LIST in the car cell and the list in the cdr -;;; cell. The doubly linked list is implemented as a normal list. You -;;; should use dll.el and not this package in debugged code. This -;;; package is not written for speed... -;;; - -;;; Code: - -;;; ================================================================ -;;; Internal functions for use in the doubly linked list package - -(defun dll-get-dummy-node (dll) - - ;; Return the dummy node. INTERNAL USE ONLY. - dll) - -(defun dll-list-nodes (dll) - - ;; Return a list of all nodes in DLL. INTERNAL USE ONLY. - - (cdr dll)) - -(defun dll-set-from-node-list (dll list) - - ;; Set the contents of DLL to the nodes in LIST. - ;; INTERNAL USE ONLY. - - (setcdr dll list)) - -(defun dll-get-node-before (dll node) - ;; Return the node in DLL that points to NODE. Use - ;; (dll-get-node-before some-list nil) to get the last node. - ;; INTERNAL USE ONLY. - (while (and dll (not (eq (cdr dll) node))) - (setq dll (cdr dll))) - (if (not dll) - (error "Node not on list")) - dll) - -(defmacro dll-insert-after (node element) - (let ((node-v (make-symbol "node")) - (element-v (make-symbol "element"))) - (` (let (((, node-v) (, node)) - ((, element-v) (, element))) - (setcdr (, node-v) (cons (, element-v) (cdr (, node-v)))))))) - -;;; =================================================================== -;;; The public functions which operate on doubly linked lists. - -(defmacro dll-element (dll node) - - "Get the element of a NODE in a doubly linked list DLL. -Args: DLL NODE." - - (` (car (, node)))) - - -(defun dll-create () - "Create an empty doubly linked list." - (cons 'DL-LIST nil)) - - -(defun dll-p (object) - "Return t if OBJECT is a doubly linked list, otherwise return nil." - (eq (car-safe object) 'DL-LIST)) - - -(defun dll-enter-first (dll element) - "Add an element first on a doubly linked list. -Args: DLL ELEMENT." - (setcdr dll (cons element (cdr dll)))) - - -(defun dll-enter-last (dll element) - "Add an element last on a doubly linked list. -Args: DLL ELEMENT." - (dll-insert-after (dll-get-node-before dll nil) element)) - - -(defun dll-enter-after (dll node element) - "In the doubly linked list DLL, insert a node containing ELEMENT after NODE. -Args: DLL NODE ELEMENT." - - (dll-get-node-before dll node) - (dll-insert-after node element)) - - -(defun dll-enter-before (dll node element) - "In the doubly linked list DLL, insert a node containing ELEMENT before NODE. -Args: DLL NODE ELEMENT." - - (dll-insert-after (dll-get-node-before dll node) element)) - - - -(defun dll-next (dll node) - "Return the node after NODE, or nil if NODE is the last node. -Args: DLL NODE." - - (dll-get-node-before dll node) - (cdr node)) - - -(defun dll-previous (dll node) - "Return the node before NODE, or nil if NODE is the first node. -Args: DLL NODE." - - (let ((prev (dll-get-node-before dll node))) - (if (eq dll prev) - nil - prev))) - - -(defun dll-delete (dll node) - - "Delete NODE from the doubly linked list DLL. -Args: DLL NODE. Return the element of node." - - (setcdr (dll-get-node-before dll node) (cdr node)) - (car node)) - - -(defun dll-delete-first (dll) - - "Delete the first NODE from the doubly linked list DLL. -Return the element. Args: DLL. Returns nil if the DLL was empty." - - (prog1 - (car (cdr dll)) - (setcdr dll (cdr (cdr dll))))) - - -(defun dll-delete-last (dll) - - "Delete the last NODE from the doubly linked list DLL. -Return the element. Args: DLL. Returns nil if the DLL was empty." - - (let* ((last (dll-get-node-before dll nil)) - (semilast (dll-get-node-before dll last))) - (if (eq last dll) - nil - (setcdr semilast nil) - (car last)))) - - -(defun dll-first (dll) - - "Return the first element on the doubly linked list DLL. -Return nil if the list is empty. The element is not removed." - - (car (cdr dll))) - - - - -(defun dll-last (dll) - - "Return the last element on the doubly linked list DLL. -Return nil if the list is empty. The element is not removed." - - (let ((last (dll-get-node-before dll nil))) - (if (eq last dll) - nil - (car last)))) - - - -(defun dll-nth (dll n) - - "Return the Nth node from the doubly linked list DLL. - Args: DLL N -N counts from zero. If DLL is not that long, nil is returned. -If N is negative, return the -(N+1)th last element. -Thus, (dll-nth dll 0) returns the first node, -and (dll-nth dll -1) returns the last node." - - ;; Branch 0 ("follow left pointer") is used when n is negative. - ;; Branch 1 ("follow right pointer") is used otherwise. - - (if (>= n 0) - (nthcdr n (cdr dll)) - (unwind-protect - (progn (setcdr dll (nreverse (cdr dll))) - (nthcdr (- n) dll)) - (setcdr dll (nreverse (cdr dll)))))) - -(defun dll-empty (dll) - - "Return t if the doubly linked list DLL is empty, nil otherwise" - - (not (cdr dll))) - -(defun dll-length (dll) - - "Returns the number of elements in the doubly linked list DLL." - - (length (cdr dll))) - - - -(defun dll-copy (dll &optional element-copy-fnc) - - "Return a copy of the doubly linked list DLL. -If optional second argument ELEMENT-COPY-FNC is non-nil it should be -a function that takes one argument, an element, and returns a copy of it. -If ELEMENT-COPY-FNC is not given the elements are not copied." - - (if element-copy-fnc - (cons 'DL-LIST (mapcar element-copy-fnc (cdr dll))) - (copy-sequence dll))) - - -(defun dll-all (dll) - - "Return all elements on the double linked list DLL as an ordinary list." - - (cdr dll)) - - -(defun dll-clear (dll) - - "Clear the doubly linked list DLL, i.e. make it completely empty." - - (setcdr dll nil)) - - -(defun dll-map (map-function dll) - - "Apply MAP-FUNCTION to all elements in the doubly linked list DLL. -The function is applied to the first element first." - - (mapcar map-function (cdr dll))) - - -(defun dll-map-reverse (map-function dll) - - "Apply MAP-FUNCTION to all elements in the doubly linked list DLL. -The function is applied to the last element first." - - (unwind-protect - (setcdr dll (nreverse (cdr dll))) - (mapcar map-function (cdr dll)) - (setcdr dll (nreverse (cdr dll))))) - - -(defun dll-create-from-list (list) - - "Given an elisp LIST create a doubly linked list with the same elements." - - (cons 'DL-LIST list)) - - - -(defun dll-sort (dll predicate) - - "Sort the doubly linked list DLL, stably, comparing elements using PREDICATE. -Returns the sorted list. DLL is modified by side effects. -PREDICATE is called with two elements of DLL, and should return T -if the first element is \"less\" than the second." - - (setcdr dll (sort (cdr dll) predicate)) - dll) - - -(defun dll-filter (dll predicate) - - "Remove all elements in the doubly linked list DLL for which PREDICATE -return nil." - - (let* ((prev dll) - (node (cdr dll))) - - (while node - (cond - ((funcall predicate (car node)) - (setq prev node)) - (t - (setcdr prev (cdr node)))) - (setq node (cdr node))))) - -;; dll-debug.el ends here
--- a/lisp/pcl-cvs/dll.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,399 +0,0 @@ -;;; $Id: dll.el,v 1.1.1.1 1996/12/18 22:42:58 steve Exp $ -;;; elib-dll.el -- Some primitives for Doubly linked lists. - -;; Copyright (C) 1991-1995 Free Software Foundation - -;; Author: Per Cederqvist <ceder@lysator.liu.se> -;; Maintainer: elib-maintainers@lysator.liu.se -;; Created: 24 Sep 1991 -;; Keywords: extensions, lisp - -;;; This program is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 2 of the License, or -;;; (at your option) any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with GNU Elib; see the file COPYING. If not, write to -;;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;;; Boston, MA 02111-1307, USA -;;; -;;; Author: Per Cederqvist -;;; ceder@lysator.liu.se. - -(require 'elib-node) -(provide 'dll) - -;;; Commentary: - -;;; A doubly linked list consists of one cons cell which holds the tag -;;; 'DL-LIST in the car cell and a pointer to a dummy node in the cdr -;;; cell. The doubly linked list is implemented as a circular list -;;; with the dummy node first and last. The dummy node is recognized -;;; by comparing it to the node which the cdr of the cons cell points -;;; to. -;;; - -;;; Code: - -;;; ================================================================ -;;; Internal functions for use in the doubly linked list package - -(defun dll-get-dummy-node (dll) - - ;; Return the dummy node. INTERNAL USE ONLY. - (cdr dll)) - -(defun dll-list-nodes (dll) - - ;; Return a list of all nodes in DLL. INTERNAL USE ONLY. - - (let* ((result nil) - (dummy (dll-get-dummy-node dll)) - (node (elib-node-left dummy))) - - (while (not (eq node dummy)) - (setq result (cons node result)) - (setq node (elib-node-left node))) - - result)) - -(defun dll-set-from-node-list (dll list) - - ;; Set the contents of DLL to the nodes in LIST. - ;; INTERNAL USE ONLY. - - (dll-clear dll) - (let* ((dummy (dll-get-dummy-node dll)) - (left dummy)) - (while list - (elib-node-set-left (car list) left) - (elib-node-set-right left (car list)) - (setq left (car list)) - (setq list (cdr list))) - - (elib-node-set-right left dummy) - (elib-node-set-left dummy left))) - - -;;; =================================================================== -;;; The public functions which operate on doubly linked lists. - -(defmacro dll-element (dll node) - - "Get the element of a NODE in a doubly linked list DLL. -Args: DLL NODE." - - (` (elib-node-data (, node)))) - - -(defun dll-create () - "Create an empty doubly linked list." - (let ((dummy-node (elib-node-create nil nil nil))) - (elib-node-set-right dummy-node dummy-node) - (elib-node-set-left dummy-node dummy-node) - (cons 'DL-LIST dummy-node))) - -(defun dll-p (object) - "Return t if OBJECT is a doubly linked list, otherwise return nil." - (eq (car-safe object) 'DL-LIST)) - -(defun dll-enter-first (dll element) - "Add an element first on a doubly linked list. -Args: DLL ELEMENT." - (dll-enter-after - dll - (dll-get-dummy-node dll) - element)) - - -(defun dll-enter-last (dll element) - "Add an element last on a doubly linked list. -Args: DLL ELEMENT." - (dll-enter-before - dll - (dll-get-dummy-node dll) - element)) - - -(defun dll-enter-after (dll node element) - "In the doubly linked list DLL, insert a node containing ELEMENT after NODE. -Args: DLL NODE ELEMENT." - - (let ((new-node (elib-node-create - node (elib-node-right node) - element))) - (elib-node-set-left (elib-node-right node) new-node) - (elib-node-set-right node new-node))) - - -(defun dll-enter-before (dll node element) - "In the doubly linked list DLL, insert a node containing ELEMENT before NODE. -Args: DLL NODE ELEMENT." - - (let ((new-node (elib-node-create - (elib-node-left node) node - element))) - (elib-node-set-right (elib-node-left node) new-node) - (elib-node-set-left node new-node))) - - - -(defun dll-next (dll node) - "Return the node after NODE, or nil if NODE is the last node. -Args: DLL NODE." - - (if (eq (elib-node-right node) (dll-get-dummy-node dll)) - nil - (elib-node-right node))) - - -(defun dll-previous (dll node) - "Return the node before NODE, or nil if NODE is the first node. -Args: DLL NODE." - - (if (eq (elib-node-left node) (dll-get-dummy-node dll)) - nil - (elib-node-left node))) - - -(defun dll-delete (dll node) - - "Delete NODE from the doubly linked list DLL. -Args: DLL NODE. Return the element of node." - - ;; This is a no-op when applied to the dummy node. This will return - ;; nil if applied to the dummy node since it always contains nil. - - (elib-node-set-right (elib-node-left node) (elib-node-right node)) - (elib-node-set-left (elib-node-right node) (elib-node-left node)) - (dll-element dll node)) - - - -(defun dll-delete-first (dll) - - "Delete the first NODE from the doubly linked list DLL. -Return the element. Args: DLL. Returns nil if the DLL was empty." - - ;; Relies on the fact that dll-delete does nothing and - ;; returns nil if given the dummy node. - - (dll-delete dll (elib-node-right (dll-get-dummy-node dll)))) - - -(defun dll-delete-last (dll) - - "Delete the last NODE from the doubly linked list DLL. -Return the element. Args: DLL. Returns nil if the DLL was empty." - - ;; Relies on the fact that dll-delete does nothing and - ;; returns nil if given the dummy node. - - (dll-delete dll (elib-node-left (dll-get-dummy-node dll)))) - - -(defun dll-first (dll) - - "Return the first element on the doubly linked list DLL. -Return nil if the list is empty. The element is not removed." - - (if (eq (elib-node-right (dll-get-dummy-node dll)) - (dll-get-dummy-node dll)) - nil - (elib-node-data (elib-node-right (dll-get-dummy-node dll))))) - - - - -(defun dll-last (dll) - - "Return the last element on the doubly linked list DLL. -Return nil if the list is empty. The element is not removed." - - (if (eq (elib-node-left (dll-get-dummy-node dll)) - (dll-get-dummy-node dll)) - nil - (elib-node-data (elib-node-left (dll-get-dummy-node dll))))) - - - -(defun dll-nth (dll n) - - "Return the Nth node from the doubly linked list DLL. - Args: DLL N -N counts from zero. If DLL is not that long, nil is returned. -If N is negative, return the -(N+1)th last element. -Thus, (dll-nth dll 0) returns the first node, -and (dll-nth dll -1) returns the last node." - - ;; Branch 0 ("follow left pointer") is used when n is negative. - ;; Branch 1 ("follow right pointer") is used otherwise. - - (let* ((dummy (dll-get-dummy-node dll)) - (branch (if (< n 0) 0 1)) - (node (elib-node-branch dummy branch))) - - (if (< n 0) - (setq n (- -1 n))) - - (while (and (not (eq dummy node)) - (> n 0)) - (setq node (elib-node-branch node branch)) - (setq n (1- n))) - - (if (eq dummy node) - nil - node))) - - -(defun dll-empty (dll) - - "Return t if the doubly linked list DLL is empty, nil otherwise" - - (eq (elib-node-left (dll-get-dummy-node dll)) - (dll-get-dummy-node dll))) - -(defun dll-length (dll) - - "Returns the number of elements in the doubly linked list DLL." - - (let* ((dummy (dll-get-dummy-node dll)) - (node (elib-node-right dummy)) - (n 0)) - - (while (not (eq node dummy)) - (setq node (elib-node-right node)) - (setq n (1+ n))) - - n)) - - - -(defun dll-copy (dll &optional element-copy-fnc) - - "Return a copy of the doubly linked list DLL. -If optional second argument ELEMENT-COPY-FNC is non-nil it should be -a function that takes one argument, an element, and returns a copy of it. -If ELEMENT-COPY-FNC is not given the elements are not copied." - - (let ((result (dll-create)) - (node (dll-nth dll 0))) - (if element-copy-fnc - - ;; Copy the elements with the user-supplied function. - (while node - (dll-enter-last result - (funcall element-copy-fnc - (dll-element dll node))) - (setq node (dll-next dll node))) - - ;; Don't try to copy the elements - they might be - ;; circular lists, or anything at all... - (while node - (dll-enter-last result (dll-element dll node)) - (setq node (dll-next dll node)))) - - result)) - - - -(defun dll-all (dll) - - "Return all elements on the double linked list DLL as an ordinary list." - - (let* ((result nil) - (dummy (dll-get-dummy-node dll)) - (node (elib-node-left dummy))) - - (while (not (eq node dummy)) - (setq result (cons (dll-element dll node) result)) - (setq node (elib-node-left node))) - - result)) - - -(defun dll-clear (dll) - - "Clear the doubly linked list DLL, i.e. make it completely empty." - - (elib-node-set-left (dll-get-dummy-node dll) (dll-get-dummy-node dll)) - (elib-node-set-right (dll-get-dummy-node dll) (dll-get-dummy-node dll))) - - -(defun dll-map (map-function dll) - - "Apply MAP-FUNCTION to all elements in the doubly linked list DLL. -The function is applied to the first element first." - - (let* ((dummy (dll-get-dummy-node dll)) - (node (elib-node-right dummy))) - - (while (not (eq node dummy)) - (funcall map-function (dll-element dll node)) - (setq node (elib-node-right node))))) - - -(defun dll-map-reverse (map-function dll) - - "Apply MAP-FUNCTION to all elements in the doubly linked list DLL. -The function is applied to the last element first." - - (let* ((dummy (dll-get-dummy-node dll)) - (node (elib-node-left dummy))) - - (while (not (eq node dummy)) - (funcall map-function (dll-element dll node)) - (setq node (elib-node-left node))))) - - -(defun dll-create-from-list (list) - - "Given an elisp LIST create a doubly linked list with the same elements." - - (let ((dll (dll-create))) - (while list - (dll-enter-last dll (car list)) - (setq list (cdr list))) - dll)) - - - -(defun dll-sort (dll predicate) - - "Sort the doubly linked list DLL, stably, comparing elements using PREDICATE. -Returns the sorted list. DLL is modified by side effects. -PREDICATE is called with two elements of DLL, and should return T -if the first element is \"less\" than the second." - - (dll-set-from-node-list - dll (sort (dll-list-nodes dll) - (function (lambda (x1 x2) - (funcall predicate - (dll-element dll x1) - (dll-element dll x2)))))) - dll) - - -(defun dll-filter (dll predicate) - - "Remove all elements in the doubly linked list DLL for which PREDICATE -returns nil." - - (let* ((dummy (dll-get-dummy-node dll)) - (node (elib-node-right dummy)) - next) - - (while (not (eq node dummy)) - (setq next (elib-node-right node)) - (if (funcall predicate (dll-element dll node)) - nil - (dll-delete dll node)) - (setq node next)))) - -;; dll.el ends here
--- a/lisp/pcl-cvs/elib-node.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,109 +0,0 @@ -;;;; $Id: elib-node.el,v 1.1.1.1 1996/12/18 22:42:58 steve Exp $ -;;;; Nodes used in binary trees and doubly linked lists. - -;; Copyright (C) 1991-1995 Free Software Foundation - -;; Author: Per Cederqvist <ceder@lysator.liu.se> -;; Inge Wallin <inge@lysator.liu.se> -;; Maintainer: elib-maintainers@lysator.liu.se -;; Created: 20 May 1991 -;; Keywords: extensions, lisp - -;;;; This file is part of the GNU Emacs lisp library, Elib. -;;;; -;;;; GNU Elib 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. -;;;; -;;;; GNU Elib is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with GNU Elib; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;;;; Boston, MA 02111-1307, USA -;;;; -;;;; Author: Inge Wallin -;;;; - -;;; Commentary: - -;;; A node is implemented as an array with three elements, using -;;; (elt node 0) as the left pointer -;;; (elt node 1) as the right pointer -;;; (elt node 2) as the data -;;; -;;; Some types of trees, e.g. AVL trees, need bigger nodes, but -;;; as long as the first three parts are the left pointer, the -;;; right pointer and the data field, these macros can be used. -;;; - -;;; Code: - -(provide 'elib-node) - - -(defmacro elib-node-create (left right data) - - ;; Create a tree node from LEFT, RIGHT and DATA. - (` (vector (, left) (, right) (, data)))) - - -(defmacro elib-node-left (node) - - ;; Return the left pointer of NODE. - (` (aref (, node) 0))) - - -(defmacro elib-node-right (node) - - ;; Return the right pointer of NODE. - (` (aref (, node) 1))) - - -(defmacro elib-node-data (node) - - ;; Return the data of NODE. - (` (aref (, node) 2))) - - -(defmacro elib-node-set-left (node newleft) - - ;; Set the left pointer of NODE to NEWLEFT. - (` (aset (, node) 0 (, newleft)))) - - -(defmacro elib-node-set-right (node newright) - - ;; Set the right pointer of NODE to NEWRIGHT. - (` (aset (, node) 1 (, newright)))) - - -(defmacro elib-node-set-data (node newdata) - ;; Set the data of NODE to NEWDATA. - (` (aset (, node) 2 (, newdata)))) - - - -(defmacro elib-node-branch (node branch) - - ;; Get value of a branch of a node. - ;; - ;; NODE is the node, and BRANCH is the branch. - ;; 0 for left pointer, 1 for right pointer and 2 for the data." - (` (aref (, node) (, branch)))) - - -(defmacro elib-node-set-branch (node branch newval) - - ;; Set value of a branch of a node. - ;; - ;; NODE is the node, and BRANCH is the branch. - ;; 0 for left pointer, 1 for the right pointer and 2 for the data. - ;; NEWVAL is new value of the branch." - (` (aset (, node) (, branch) (, newval)))) - -;;; elib-node.el ends here.
--- a/lisp/pcl-cvs/pcl-cvs-startup.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,17 +0,0 @@ -;;;#ident "@(#)OrigId: pcl-cvs-startup.el,v 1.4 1993/05/31 18:40:33 ceder Exp " -;;; -;;;#ident "@(#)cvs/contrib/pcl-cvs:$Name: r20-0b30 $:$Id: pcl-cvs-startup.el,v 1.1.1.1 1996/12/18 22:42:58 steve Exp $" -;;; -(autoload 'cvs-update "pcl-cvs" - "Run a 'cvs update' in the current working directory. Feed the -output to a *cvs* buffer and run cvs-mode on it. -If optional prefix argument LOCAL is non-nil, 'cvs update -l' is run." - t) - -(autoload 'cvs-update-other-window "pcl-cvs" - "Run a 'cvs update' in the current working directory. Feed the -output to a *cvs* buffer, display it in the other window, and run -cvs-mode on it. - -If optional prefix argument LOCAL is non-nil, 'cvs update -l' is run." - t)
--- a/lisp/pcl-cvs/pcl-cvs-xemacs.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,136 +0,0 @@ -;;; Mouse and font support for PCL-CVS 1.3 running in XEmacs -;; @(#) Id: pcl-cvs-xemacs.el,v 1.2 1993/05/31 19:37:34 ceder Exp -;; Copyright (C) 1992-1993 Free Software Foundation, Inc. - -;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. - - -;; This simply adds a menu of the common CVS commands to the menubar and to -;; the right mouse button. Clicking right moves point, and then pops up a -;; menu from which commands can be executed. -;; -;; This could stand to be a lot more clever: for example, the "Commit Changes" -;; command should only be active on files for which there is something to -;; commit. Also, some indication of which files the command applies to -;; (especially in the presence of multiple marked files) would be nice. -;; -;; Middle-click runs find-file. - - -(require 'pcl-cvs) -;(load "pcl-cvs.el") - -(defvar cvs-menu - '("CVS" - ["Find File" cvs-mode-find-file t] - ["Find File Other Window" cvs-mode-find-file-other-window t] - ["Interactively Merge (emerge)" cvs-mode-emerge t] - ["Diff against Repository" cvs-mode-diff-cvs t] - ["Diff against Backup Version" cvs-mode-diff-backup t] - "----" - ["Update sources from Repository" cvs-mode-update-no-prompt t] - ["Commit Changes to Repository" cvs-mode-commit t] - ["Revert File from Repository" cvs-mode-undo-local-changes t] - ["Add File to Repository" cvs-mode-add t] - ["Remove File from Repository" cvs-mode-remove-file t] - ["Ignore File" cvs-mode-ignore t] - ["Hide File" cvs-mode-acknowledge t] - ["Hide Handled Files" cvs-mode-remove-handled t] - "----" - ["Add ChangeLog Entry" cvs-mode-add-change-log-entry-other-window t] - ["Show CVS Log" cvs-mode-log t] - ["Show CVS Status" cvs-mode-status t] - "----" - ["Mark File" cvs-mode-mark t] - ["Unmark File" cvs-mode-unmark t] - ["Mark All Files" cvs-mode-mark-all-files t] - ["Unmark All Files" cvs-mode-unmark-all-files t] - "----" - ["Quit" bury-buffer t] - )) - -(defun cvs-menu (e) - (interactive "e") - (mouse-set-point e) - (beginning-of-line) - (or (looking-at "^[* ] ") (error "No CVS file line here")) - (popup-menu cvs-menu)) - -(defun cvs-mouse-find-file (e) - (interactive "e") - (mouse-set-point e) - (beginning-of-line) - (or (looking-at "^[* ] ") (error "No CVS file line here")) - (cvs-mode-find-file (point))) - -(define-key cvs-mode-map 'button3 'cvs-menu) -(define-key cvs-mode-map 'button2 'cvs-mouse-find-file) - -(make-face 'cvs-header-face) -(make-face 'cvs-filename-face) -(make-face 'cvs-status-face) - -(or (face-differs-from-default-p 'cvs-header-face) - (copy-face 'italic 'cvs-header-face)) - -(or (face-differs-from-default-p 'cvs-filename-face) - (copy-face 'bold 'cvs-filename-face)) - -(or (face-differs-from-default-p 'cvs-status-face) - (copy-face 'bold-italic 'cvs-status-face)) - - -(defun pcl-mode-motion-highlight-line (event) - (if (save-excursion - (let* ((window (event-window event)) - (buffer (and window (event-buffer event))) - (point (and buffer (event-point event)))) - (and point - (progn - (set-buffer buffer) - (goto-char point) - (beginning-of-line) - (looking-at "^[* ] "))))) - (mode-motion-highlight-line event))) - -(defconst pcl-cvs-font-lock-keywords - '(("^In directory \\(.+\\)$" 1 cvs-header-face) - ("^[* ] \\w+ +\\(ci\\)" 1 cvs-status-face) - ("^[* ] \\(Conflict\\|Merged\\)" 1 cvs-status-face) - ("^[* ] \\w+ +\\(ci +\\)?\\(.+\\)$" 2 cvs-filename-face) - ) - "Patterns to highlight in the *cvs* buffer.") - -;;;###autoload -(defun pcl-cvs-fontify () - ;; - ;; set up line highlighting - (require 'mode-motion) - (setq mode-motion-hook 'pcl-mode-motion-highlight-line) - ;; - ;; set up menubar - (if (and current-menubar (not (assoc "CVS" current-menubar))) - (progn - (set-buffer-menubar (copy-sequence current-menubar)) - (add-menu nil "CVS" (cdr cvs-menu)))) - ;; - ;; fontify mousable lines - (set (make-local-variable 'font-lock-keywords) pcl-cvs-font-lock-keywords) - (font-lock-mode 1) - ) - -(add-hook 'cvs-mode-hook 'pcl-cvs-fontify)
--- a/lisp/pcl-cvs/pcl-cvs.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,3496 +0,0 @@ -;;; -;;;#ident "@(#)OrigId: pcl-cvs.el,v 1.93 1993/05/31 22:44:00 ceder Exp " -;;; -;;;#ident "@(#)cvs/contrib/pcl-cvs:$Name: r20-4b2 $:$Id: pcl-cvs.el,v 1.7 1997/10/31 14:53:04 steve Exp $" -;;; -;;; pcl-cvs.el -- A Front-end to CVS 1.3 or later. -;;; Release 1.05-CVS-$Name: r20-4b2 $. -;;; Copyright (C) 1991, 1992, 1993 Per Cederqvist - -;;; This program is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 2 of the License, or -;;; (at your option) any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;;; 02111-1307, USA. - -;;; See below for installation instructions. - -;;; There is an TeXinfo file that describes this package. You should read it -;;; to get the most from this package. - -;;; Mail questions and bug reports regarding this version (as included in -;;; CVS-1.7 or newer) to the pcl-cvs support team at <pcl-cvs@cyclic.com>. - -;;; Don't try to use this with CVS 1.2 or earlier. It won't work. Get CVS 1.7 -;;; or newer. Use the version of RCS best suited for the version of CVS you're -;;; using. - -(require 'cookie) ; from ELIB-1.0 -(require 'add-log) ; for all the ChangeLog goodies - -;;; ------------------------------------------------------- -;;; START OF THINGS TO CHECK WHEN INSTALLING - -;; also use $GNU here, since may folks might install CVS as a GNU package -;; -(defun cvs-find-program (program) - (let ((path (list (getenv "LOCAL") - (getenv "GNU") - "/usr/local/bin" - "/usr/bin" - "/bin"))) - (while path - (if (stringp (car path)) - (let ((abs-program (expand-file-name program (car path)))) - (if (file-executable-p abs-program) - (setq path nil - program abs-program)))) - (setq path (cdr path))) - program)) - -(defvar cvs-program (cvs-find-program "cvs") - "*Full path to the cvs executable.") - -;; SunOS-4.1.1_U1 has "diff.c 1.12 88/08/04 SMI; from UCB 4.6 86/04/03" -;; -(defvar cvs-diff-program (cvs-find-program "diff") - "*Full path to the best diff program you've got. -NOTE: there are some nasty bugs in the context diff variants of some vendor -versions, such as the one in SunOS-4.1.1_U1") - -(defvar cvs-rmdir-program "/bin/rmdir" - "*Full path to the rmdir program. Typically /bin/rmdir.") - -(defvar cvs-shell "/bin/sh" - "*Full path to a shell that can do redirection on stdout.") - -;;; Options to control various features: - -(defvar cvs-changelog-full-paragraphs t - "If non-nil, include full ChangeLog paragraphs in the CVS log. -This may be set in the ``local variables'' section of a ChangeLog, to -indicate the policy for that ChangeLog. - -A ChangeLog paragraph is a bunch of log text containing no blank lines; -a paragraph usually describes a set of changes with a single purpose, -but perhaps spanning several functions in several files. Changes in -different paragraphs are unrelated. - -You could argue that the CVS log entry for a file should contain the -full ChangeLog paragraph mentioning the change to the file, even though -it may mention other files, because that gives you the full context you -need to understand the change. This is the behaviour you get when this -variable is set to t. - -On the other hand, you could argue that the CVS log entry for a change -should contain only the text for the changes which occurred in that -file, because the CVS log is per-file. This is the behaviour you get -when this variable is set to nil.") - -(defvar cvs-cvsroot-required nil - "*Specifies whether CVS needs to be told where the repository is. - -In CVS 1.3, if your CVSROOT environment variable is not set, and you -do not set the `cvs-cvsroot' lisp variable, CVS will have no idea -where to find the repository, and refuse to run. CVS 1.4 and later -store the repository path with the working directories, so most -operations don't need to be told where the repository is. - -If you work with multiple repositories with CVS 1.4, it's probably -advisable to leave your CVSROOT environment variable unset, set this -variable to nil, and let CVS figure out where the repository is for -itself.") - -(defvar cvs-cvsroot nil - "*Specifies where the (current) cvs master repository is. -Overrides the $CVSROOT variable by sending \" -d dir\" to all cvs commands. -This switch is useful if you have multiple CVS repositories, and are not using -a modern version of CVS that stores the current repository in CVS/Root.") - -;; Uncomment the following line if you are running on 18.57 or earlier. -;(setq delete-exited-processes nil) -;; Emacs version 18.57 and earlier is likely to crash if -;; delete-exited-processes is t, since the sentinel uses lots of -;; memory, and 18.57 forgets to GCPROT a variable if -;; delete-exited-processes is t. - -;;; END OF THINGS TO CHECK WHEN INSTALLING -;;; -------------------------------------------------------- - -(defconst pcl-cvs-version "1.05-CVS-$Name: r20-4b2 $" - "A string denoting the current release version of pcl-cvs.") - -;; You are NOT allowed to disable this message by default. However, you -;; are encouraged to inform your users that by adding -;; (setq cvs-inhibit-copyright-message t) -;; to their .emacs they can get rid of it. Just don't add that line -;; to your default.el! -(defvar cvs-inhibit-copyright-message nil - "*Non-nil means don't display a Copyright message in the ``*cvs*'' buffer.") - -(defconst cvs-startup-message - (if cvs-inhibit-copyright-message - "PCL-CVS release 1.05-CVS-$Name: r20-4b2 $" - "PCL-CVS release 1.05 from CVS release $Name: r20-4b2 $. -Copyright (C) 1992, 1993 Per Cederqvist -Pcl-cvs comes with absolutely no warranty; for details consult the manual. -This is free software, and you are welcome to redistribute it under certain -conditions; again, consult the TeXinfo manual for details.") - "*Startup message for CVS.") - -(defconst pcl-cvs-bugs-address "pcl-cvs-auto-bugs@cyclic.com" - "The destination address used for the default bug report form.") - -(defvar cvs-stdout-file nil - "Name of the file that holds the output that CVS sends to stdout. -This variable is buffer local.") - -(defvar cvs-lock-file nil - "Full path to a lock file that CVS is waiting for (or was waiting for).") - -(defvar cvs-bakprefix ".#" - "The prefix that CVS prepends to files when rcsmerge'ing.") - -(defvar cvs-erase-input-buffer nil - "*Non-nil if input buffers should be cleared before asking for new info.") - -(defvar cvs-auto-remove-handled nil - "*Non-nil if cvs-mode-remove-handled should be called automatically. -If this is set to any non-nil value, entries that do not need to be checked in -will be removed from the *cvs* buffer after every cvs-mode-commit command.") - -(defvar cvs-auto-remove-handled-directories nil - "*Non-nil if cvs-mode-remove-handled and cvs-update should automatically -remove empty directories. -If this is set to any non-nil value, directories that do not contain any files -to be checked in will be removed from the *cvs* buffer.") - -(defvar cvs-sort-ignore-file t - "*Non-nil if cvs-mode-ignore should sort the .cvsignore automatically.") - -(defvar cvs-auto-revert-after-commit t - "*Non-nil if committed buffers should be automatically reverted.") - -(defconst cvs-cursor-column 14 - "Column to position cursor in in cvs-mode. -Column 0 is left-most column.") - -(defvar cvs-mode-map nil - "Keymap for the cvs mode.") - -(defvar cvs-edit-mode-map nil - "Keymap for the cvs edit mode (used when editing cvs log messages).") - -(defvar cvs-buffer-name "*cvs*" - "Name of the cvs buffer.") - -(defvar cvs-commit-prompt-buffer "*cvs-commit-message*" - "Name of buffer in which the user is prompted for a log message when -committing files.") - -(defvar cvs-commit-buffer-require-final-newline t - "*t says silently put a newline at the end of commit log messages. -Non-nil but not t says ask user whether to add a newline in each such case. -nil means don't add newlines.") - -(defvar cvs-temp-buffer-name "*cvs-tmp*" - "*Name of the cvs temporary buffer. -Output from cvs is placed here by synchronous commands.") - -(defvar cvs-diff-ignore-marks nil - "*Non-nil if cvs-diff and cvs-mode-diff-backup should ignore any marked files. -Normally they run diff on the files that are marked (with cvs-mode-mark), -or the file under the cursor if no files are marked. If this variable -is set to a non-nil value they will always run diff on the file on the -current line.") - -;;; (setq cvs-status-flags '("-v")) -(defvar cvs-status-flags '("-v") - "*List of flags to pass to ``cvs status''. Default is \"-v\".") - -;;; (setq cvs-log-flags nil) -(defvar cvs-log-flags nil - "*List of flags to pass to ``cvs log''. Default is none.") - -;;; (setq cvs-tag-flags nil) -(defvar cvs-tag-flags nil - "*List of extra flags to pass to ``cvs tag''. Default is none.") - -;;; (setq cvs-rtag-flags nil) -(defvar cvs-rtag-flags nil - "*List of extra flags to pass to ``cvs rtag''. Default is none.") - -;;; (setq cvs-diff-flags '("-u")) -(defvar cvs-diff-flags '("-u") - "*List of flags to use as flags to pass to ``diff'' and ``cvs diff''. -Used by cvs-mode-diff-cvs and cvs-mode-diff-backup. Default is \"-u\". - -Set this to \"-u\" to get a Unidiff format, or \"-c\" to get context diffs.") - -;;; (setq cvs-update-optional-flags nil) -(defvar cvs-update-optional-flags nil - "*List of strings to use as optional flags to pass to ``cvs update''. Used -by cvs-do-update, called by cvs-update, cvs-update-other-window, -cvs-mode-update-no-prompt, and cvs-examine. Default is none. - -For example set this to \"-j VENDOR_PREV_RELEASE -j VENDOR_TOP_RELEASE\" to -perform an update after a new vendor release has been imported. - -To restrict the update to the current working directory, set this to \"-l\".") - -(defvar cvs-update-prog-output-skip-regexp "$" - "*A regexp that matches the end of the output from all cvs update programs. -That is, output from any programs that are run by CVS (by the flag -u in the -`modules' file - see cvs(5)) when `cvs update' is performed should terminate -with a line that this regexp matches. It is enough that some part of the line -is matched. - -The default (a single $) fits programs without output.") - -;;; -------------------------------------------------------- -;;; The variables below are used internally by pcl-cvs. You should -;;; never change them. - -(defvar cvs-buffers-to-delete nil - "List of temporary buffers that should be discarded as soon as possible. -Due to a bug in emacs 18.57 the sentinel can't discard them reliably.") - -(defvar cvs-update-running nil - "This is set to nil when no process is running, and to -the process when a cvs update process is running.") - -(defvar cvs-cookie-handle nil - "Handle for the cookie structure that is displayed in the *cvs* buffer.") - -(defvar cvs-commit-list nil - "Used internally by pcl-cvs.") - -;;; The cvs data structure: -;;; -;;; When the `cvs update' is ready we parse the output. Every file -;;; that is affected in some way is added as a cookie of fileinfo -;;; (as defined below). -;;; - -;;; cvs-fileinfo - -;;; Constructor: - -(defun cvs-create-fileinfo (type - dir - file-name - full-log) - "Create a fileinfo from all parameters. -Arguments: TYPE DIR FILE-NAME FULL-LOG. -A fileinfo is a vector with the following fields: - -[0] handled True if this file doesn't require further action. -[1] marked t/nil -[2] type One of - UPDATED - file copied from repository - PATCHED - file update with patch from repository - MODIFIED - modified by you, unchanged in - repository - ADDED - added by you, not yet committed - REMOVED - removed by you, not yet committed - CVS-REMOVED- removed, since file no longer exists - in the repository. - MERGED - successful merge - CONFLICT - conflict when merging (if pcl-cvs did it) - REM-CONFLICT-removed in repository, but altered - locally. - MOD-CONFLICT-removed locally, changed in repository. - REM-EXIST - removed locally, but still exists. - DIRCHANGE - A change of directory. - UNKNOWN - An unknown file. - UNKNOWN-DIR- An unknown directory. - MOVE-AWAY - A file that is in the way. - REPOS-MISSING- The directory has vanished from the - repository. - MESSAGE - This is a special fileinfo that is used - to display a text that should be in - full-log. -[3] dir Directory the file resides in. Should not end with slash. -[4] file-name The file name. -[5] backup-file The name of a backup file created during a merge. - Only valid for MERGED and CONFLICT files. -[6] base-revision The revision that the working file was based on. - Only valid for MERGED and CONFLICT files. -[7] head-revision The revision that the newly merged changes came from - Only valid for MERGED and CONFLICT files. -[8] backup-revision The revision of the cvs backup file (original working rev.) - Only valid for MERGED and CONFLICT files. -[9] cvs-diff-buffer A buffer that contains a 'cvs diff file'. -[10] vendor-diff-buffer A buffer that contains a 'diff base-file head-file'. -[11] backup-diff-buffer A buffer that contains a 'diff file backup-file'. -[12] full-log The output from cvs, unparsed. -[13] mod-time Modification time of file used for *-diff-buffer." - - (cons - 'CVS-FILEINFO - (vector nil nil type dir file-name nil nil nil nil nil nil nil full-log nil nil))) - -;;; Selectors: - -(defun cvs-fileinfo->handled (cvs-fileinfo) - "Get the `handled' field from CVS-FILEINFO." - (elt (cdr cvs-fileinfo) 0)) - -(defun cvs-fileinfo->marked (cvs-fileinfo) - "Check if CVS-FILEINFO is marked." - (elt (cdr cvs-fileinfo) 1)) - -(defun cvs-fileinfo->type (cvs-fileinfo) - "Get type from CVS-FILEINFO. -Type is one of UPDATED, PATCHED, MODIFIED, ADDED, REMOVED, CVS-REMOVED, MERGED, -CONFLICT, REM-CONFLICT, MOD-CONFLICT, REM-EXIST, DIRCHANGE, UNKNOWN, -UNKNOWN-DIR, MOVE-AWAY, REPOS-MISSING or MESSAGE." - (elt (cdr cvs-fileinfo) 2)) - -(defun cvs-fileinfo->dir (cvs-fileinfo) - "Get dir from CVS-FILEINFO. -The directory name does not end with a slash." - (elt (cdr cvs-fileinfo) 3)) - -(defun cvs-fileinfo->file-name (cvs-fileinfo) - "Get file-name from CVS-FILEINFO." - (elt (cdr cvs-fileinfo) 4)) - -(defun cvs-fileinfo->backup-file (cvs-fileinfo) - "Get backup-file from CVS-FILEINFO." - (elt (cdr cvs-fileinfo) 5)) - -(defun cvs-fileinfo->base-revision (cvs-fileinfo) - "Get the base revision from CVS-FILEINFO." - (elt (cdr cvs-fileinfo) 6)) - -(defun cvs-fileinfo->head-revision (cvs-fileinfo) - "Get the head revision from CVS-FILEINFO." - (elt (cdr cvs-fileinfo) 7)) - -(defun cvs-fileinfo->backup-revision (cvs-fileinfo) - "Get the backup revision from CVS-FILEINFO." - (elt (cdr cvs-fileinfo) 8)) - -(defun cvs-fileinfo->cvs-diff-buffer (cvs-fileinfo) - "Get cvs-diff-buffer from CVS-FILEINFO." - (elt (cdr cvs-fileinfo) 9)) - -(defun cvs-fileinfo->vendor-diff-buffer (cvs-fileinfo) - "Get backup-diff-buffer from CVS-FILEINFO." - (elt (cdr cvs-fileinfo) 10)) - -(defun cvs-fileinfo->backup-diff-buffer (cvs-fileinfo) - "Get backup-diff-buffer from CVS-FILEINFO." - (elt (cdr cvs-fileinfo) 11)) - -(defun cvs-fileinfo->full-log (cvs-fileinfo) - "Get full-log from CVS-FILEINFO." - (elt (cdr cvs-fileinfo) 12)) - -(defun cvs-fileinfo->mod-time (cvs-fileinfo) - "Get mod-time from CVS-FILEINFO." - (elt (cdr cvs-fileinfo) 13)) - -;;; Modifiers: - -(defun cvs-set-fileinfo->handled (cvs-fileinfo newval) - "Set handled in CVS-FILEINFO to NEWVAL." - (aset (cdr cvs-fileinfo) 0 newval)) - -(defun cvs-set-fileinfo->marked (cvs-fileinfo newval) - "Set marked in CVS-FILEINFO to NEWVAL." - (aset (cdr cvs-fileinfo) 1 newval)) - -(defun cvs-set-fileinfo->type (cvs-fileinfo newval) - "Set type in CVS-FILEINFO to NEWVAL." - (aset (cdr cvs-fileinfo) 2 newval)) - -(defun cvs-set-fileinfo->dir (cvs-fileinfo newval) - "Set dir in CVS-FILEINFO to NEWVAL. -The directory should now end with a slash." - (aset (cdr cvs-fileinfo) 3 newval)) - -(defun cvs-set-fileinfo->file-name (cvs-fileinfo newval) - "Set file-name in CVS-FILEINFO to NEWVAL." - (aset (cdr cvs-fileinfo) 4 newval)) - -(defun cvs-set-fileinfo->backup-file (cvs-fileinfo newval) - "Set backup-file in CVS-FILEINFO to NEWVAL." - (aset (cdr cvs-fileinfo) 5 newval)) - -(defun cvs-set-fileinfo->base-revision (cvs-fileinfo newval) - "Set base-revision in CVS-FILEINFO to NEWVAL." - (aset (cdr cvs-fileinfo) 6 newval)) - -(defun cvs-set-fileinfo->head-revision (cvs-fileinfo newval) - "Set head-revision in CVS-FILEINFO to NEWVAL." - (aset (cdr cvs-fileinfo) 7 newval)) - -(defun cvs-set-fileinfo->backup-revision (cvs-fileinfo newval) - "Set backup-revision in CVS-FILEINFO to NEWVAL." - (aset (cdr cvs-fileinfo) 8 newval)) - -(defun cvs-set-fileinfo->cvs-diff-buffer (cvs-fileinfo newval) - "Set cvs-diff-buffer in CVS-FILEINFO to NEWVAL." - (aset (cdr cvs-fileinfo) 9 newval)) - -(defun cvs-set-fileinfo->vendor-diff-buffer (cvs-fileinfo newval) - "Set vendor-diff-buffer in CVS-FILEINFO to NEWVAL." - (aset (cdr cvs-fileinfo) 10 newval)) - -(defun cvs-set-fileinfo->backup-diff-buffer (cvs-fileinfo newval) - "Set backup-diff-buffer in CVS-FILEINFO to NEWVAL." - (aset (cdr cvs-fileinfo) 11 newval)) - -(defun cvs-set-fileinfo->full-log (cvs-fileinfo newval) - "Set full-log in CVS-FILEINFO to NEWVAL." - (aset (cdr cvs-fileinfo) 12 newval)) - -(defun cvs-set-fileinfo->mod-time (cvs-fileinfo newval) - "Set full-log in CVS-FILEINFO to NEWVAL." - (aset (cdr cvs-fileinfo) 13 newval)) - -;;; Predicate: - -(defun cvs-fileinfo-p (object) - "Return t if OBJECT is a cvs-fileinfo." - (eq (car-safe object) 'CVS-FILEINFO)) - -;;;; End of types. - -;;---------- -(defun cvs-use-temp-buffer () - "Display a temporary buffer in another window and select it. -The selected window will not be changed. The temporary buffer will -be erased and writable." - - (let ((dir default-directory)) - (display-buffer (get-buffer-create cvs-temp-buffer-name)) - (set-buffer cvs-temp-buffer-name) - (setq buffer-read-only nil) - (setq default-directory dir) - (erase-buffer))) - -;;---------- -(defun cvs-examine (directory &optional local) - "Run a 'cvs -n update' in the current working directory. -That is, check what needs to be done, but don't change the disc. -Feed the output to a *cvs* buffer and run cvs-mode on it. -If optional prefix argument LOCAL is non-nil, 'cvs update -l' is run. -WARNING: this doesn't work very well yet...." - - ;; TODO: this should do everything cvs-update does... - ;; for example, for CONFLICT files, it should setup fileinfo appropriately - - (interactive (list (read-file-name "CVS Update (directory): " - nil default-directory nil) - current-prefix-arg)) - (cvs-do-update directory local 'noupdate)) - -;;---------- -;;;###autoload -(defun cvs-update (directory &optional local) - "Run a 'cvs update' in the current working directory. Feed the -output to a *cvs* buffer and run cvs-mode on it. -If optional prefix argument LOCAL is non-nil, 'cvs update -l' is run." - - (interactive (list (read-file-name "CVS Update (directory): " - nil default-directory nil) - current-prefix-arg)) - ;; If the previous prompt was in a dialog box, the save-some-buffers - ;; call in cvs-do-update will lose. - (let ((use-dialog-box nil)) - (cvs-do-update directory local nil)) - (switch-to-buffer cvs-buffer-name)) - -;;---------- -;;;###autoload -(defun cvs-update-other-window (directory &optional local) - "Run a 'cvs update' in the current working directory. Feed the -output to a *cvs* buffer, display it in the other window, and run -cvs-mode on it. - -If optional prefix argument LOCAL is non-nil, 'cvs update -l' is run." - - (interactive (list (read-file-name "CVS Update other window (directory): " - nil default-directory nil) - current-prefix-arg)) - (cvs-do-update directory local nil) - (switch-to-buffer-other-window cvs-buffer-name)) - -;;---------- -(defun cvs-filter (predicate list &rest extra-args) - "Apply PREDICATE to each element on LIST. -Args: PREDICATE LIST &rest EXTRA-ARGS. - -Return a new list consisting of those elements that PREDICATE -returns non-nil for. - -If more than two arguments are given the remaining args are -passed to PREDICATE." - - ;; Avoid recursion - this should work for LONG lists also! - (let* ((head (cons 'dummy-header nil)) - (tail head)) - (while list - (if (apply predicate (car list) extra-args) - (setq tail (setcdr tail (list (car list))))) - (setq list (cdr list))) - (cdr head))) - -;;---------- -(defun cvs-mode-update-no-prompt () - "Run cvs update in current directory." - - (interactive) - (cvs-do-update default-directory nil nil)) - -;;---------- -(defun cvs-do-update (directory local dont-change-disc) - "Do a 'cvs update' in DIRECTORY. -Args: DIRECTORY LOCAL DONT-CHANGE-DISC. - -If LOCAL is non-nil 'cvs update -l' is executed. -If DONT-CHANGE-DISC is non-nil 'cvs -n update' is executed. -Both LOCAL and DONT-CHANGE-DISC may be non-nil simultaneously. - -*Note*: DONT-CHANGE-DISC does not yet work. The parser gets confused." - - (save-some-buffers) - ;; Ensure that it is safe to do an update. If not, ask user - ;; for confirmation. - (if (and (boundp 'cvs-cookie-handle) (collection-buffer cvs-cookie-handle)) - (if (collection-collect-tin - cvs-cookie-handle - '(lambda (cookie) (eq (cvs-fileinfo->type cookie) 'CONFLICT))) - (if (not - (yes-or-no-p - "Only update if conflicts have been resolved. Continue? ")) - (error "Update aborted by user request.")))) - (if (not (file-exists-p cvs-program)) - (error "%s: file not found (check setting of cvs-program)" - cvs-program)) - (let* ((this-dir (file-name-as-directory (expand-file-name directory))) - (update-buffer (generate-new-buffer - (concat " " (file-name-nondirectory - (substring this-dir 0 -1)) - "-update"))) - (temp-name (make-temp-name - (concat (file-name-as-directory - (or (getenv "TMPDIR") "/tmp")) - "pcl-cvs."))) - (args nil)) - - ;; Check that this-dir exists and is a directory that is under CVS contr. - - (if (not (file-directory-p this-dir)) - (error "%s is not a directory." this-dir)) - (if (not (file-directory-p (concat this-dir "CVS"))) - (error "%s does not contain CVS controlled files." this-dir)) - (if (file-readable-p (concat this-dir "CVS/Root")) - (save-excursion ; read CVS/Root into cvs-cvsroot - (find-file (concat this-dir "CVS/Root")) - (goto-char (point-min)) - (setq cvs-cvsroot (buffer-substring (point) - (progn (end-of-line) (point)))) - (if (not cvs-cvsroot) - (error "Invalid contents of %sCVS/Root" this-dir)) - (kill-buffer (current-buffer))) - (if (and cvs-cvsroot-required - (not (or (getenv "CVSROOT") cvs-cvsroot))) - (error "Both cvs-cvsroot and environment variable CVSROOT are unset, and no CVS/Root."))) - - ;; Check that at most one `cvs update' is run at any time. - - (if (and cvs-update-running (process-status cvs-update-running) - (or (eq (process-status cvs-update-running) 'run) - (eq (process-status cvs-update-running) 'stop))) - (error "Can't run two `cvs update' simultaneously.")) - - (if (not (listp cvs-update-optional-flags)) - (error "cvs-update-optional-flags should be set using cvs-set-update-optional-flags")) - - ;; Generate "-d /master -n update -l". - (setq args (concat (if cvs-cvsroot (concat " -d " cvs-cvsroot)) - (if dont-change-disc " -n ") - " update " - (if local " -l ") - (if cvs-update-optional-flags - (mapconcat 'identity - (copy-sequence cvs-update-optional-flags) - " ")))) - - ;; Set up the buffer that receives the stderr output from "cvs update". - (set-buffer update-buffer) - (setq default-directory this-dir) - (make-local-variable 'cvs-stdout-file) - (setq cvs-stdout-file temp-name) - - (setq cvs-update-running - (let ((process-connection-type nil)) ; Use a pipe, not a pty. - (start-process "cvs" update-buffer cvs-shell "-c" - (concat cvs-program " " args " > " temp-name)))) - - (setq mode-line-process - (concat ": " - (symbol-name (process-status cvs-update-running)))) - ; XEmacs change - (redraw-modeline) ; Update the mode line. - (set-process-sentinel cvs-update-running 'cvs-sentinel) - (set-process-filter cvs-update-running 'cvs-update-filter) - (set-marker (process-mark cvs-update-running) (point-min)) - - (save-excursion - (set-buffer (get-buffer-create cvs-buffer-name)) - (setq buffer-read-only nil) - (erase-buffer) - (cvs-mode)) - - (setq cvs-cookie-handle - (collection-create - cvs-buffer-name 'cvs-pp - cvs-startup-message ;See comment above cvs-startup-message. - "---------- End -----")) - - (cookie-enter-first - cvs-cookie-handle - (cvs-create-fileinfo - 'MESSAGE nil nil (concat "\n Running `cvs " args "' in " this-dir - "...\n"))) - - (save-excursion - (set-buffer cvs-buffer-name) - (setq mode-line-process - (concat ": " - (symbol-name (process-status cvs-update-running)))) - ; XEmacs change - (redraw-modeline) ; Update the mode line. - (setq buffer-read-only t)) - - ;; Work around a bug in emacs 18.57 and earlier. - (setq cvs-buffers-to-delete - (cvs-delete-unused-temporary-buffers cvs-buffers-to-delete))) - - ;; The following line is said to improve display updates on some - ;; emacses. It shouldn't be needed, but it does no harm. - (sit-for 0)) - -;;---------- -(defun cvs-delete-unused-temporary-buffers (list) - "Delete all buffers on LIST that is not visible. -Return a list of all buffers that still is alive." - - (cond - ((null list) nil) - ((get-buffer-window (car list)) - (cons (car list) - (cvs-delete-unused-temporary-buffers (cdr list)))) - (t - (kill-buffer (car list)) - (cvs-delete-unused-temporary-buffers (cdr list))))) - -;;---------- -(put 'cvs-mode 'mode-class 'special) - -;;---------- -(defun cvs-mode () - "\\<cvs-mode-map>Mode used for pcl-cvs, a front-end to CVS. - -To get to the \"*cvs*\" buffer you should use ``\\[execute-extended-command] cvs-update''. - -Full documentation is in the Texinfo file. Here are the most useful commands: - -\\[cvs-mode-previous-line] Move up. \\[cvs-mode-next-line] Move down. -\\[cvs-mode-commit] Commit file. \\[cvs-mode-update-no-prompt] Re-update directory. -\\[cvs-mode-mark] Mark file/dir. \\[cvs-mode-unmark] Unmark file/dir. -\\[cvs-mode-mark-all-files] Mark all files. \\[cvs-mode-unmark-all-files] Unmark all files. -\\[cvs-mode-find-file] Edit file/run Dired. \\[cvs-mode-find-file-other-window] Find file or run Dired in other window. -\\[cvs-mode-ignore] Add file to ./.cvsignore. \\[cvs-mode-add-change-log-entry-other-window] Write ChangeLog in other window. -\\[cvs-mode-add] Add to repository. \\[cvs-mode-remove-file] Remove file. -\\[cvs-mode-diff-cvs] Diff with base revision. \\[cvs-mode-diff-backup] Diff backup file. -\\[cvs-mode-ediff] Ediff base rev & backup. \\[cvs-mode-diff-vendor] Show merge from vendor branch. -\\[cvs-mode-emerge] Emerge base rev & backup. \\[cvs-mode-diff-backup] Diff backup file. -\\[cvs-mode-acknowledge] Delete line from buffer. \\[cvs-mode-remove-handled] Remove processed entries. -\\[cvs-mode-log] Run ``cvs log''. \\[cvs-mode-status] Run ``cvs status''. -\\[cvs-mode-tag] Run ``cvs tag''. \\[cvs-mode-rtag] Run ``cvs rtag''. -\\[cvs-mode-changelog-commit] Like \\[cvs-mode-commit], but get default log text from ChangeLog. -\\[cvs-mode-undo-local-changes] Revert the last checked in version - discard your changes to the file. - -Entry to this mode runs cvs-mode-hook. -This description is updated for release 1.05-CVS-$Name: r20-4b2 $ of pcl-cvs. - -All bindings: -\\{cvs-mode-map}" - - (interactive) - (setq major-mode 'cvs-mode) - (setq mode-name "CVS") - (setq mode-line-process nil) -;; for older v18 emacs -;;(buffer-flush-undo (current-buffer)) - (buffer-disable-undo (current-buffer)) - (make-local-variable 'goal-column) - (setq goal-column cvs-cursor-column) - (use-local-map cvs-mode-map) - (run-hooks 'cvs-mode-hook)) - -;;---------- -(defun cvs-sentinel (proc msg) - "Sentinel for the cvs update process. -This is responsible for parsing the output from the cvs update when -it is finished." - - (cond - ((null (buffer-name (process-buffer proc))) - ;; buffer killed - (set-process-buffer proc nil)) - ((memq (process-status proc) '(signal exit)) - (let* ((obuf (current-buffer)) - (omax (point-max)) - (opoint (point))) - ;; save-excursion isn't the right thing if - ;; process-buffer is current-buffer - (unwind-protect - (progn - (set-buffer (process-buffer proc)) - (setq mode-line-process - (concat ": " - (symbol-name (process-status proc)))) - (let* ((out-file cvs-stdout-file) - (stdout-buffer (find-file-noselect out-file))) - (save-excursion - (set-buffer stdout-buffer) - (rename-buffer (concat " " - (file-name-nondirectory out-file)) t)) - (cvs-parse-update stdout-buffer (process-buffer proc)) - (setq cvs-buffers-to-delete - (cons (process-buffer proc) - (cons stdout-buffer - cvs-buffers-to-delete))) - (delete-file out-file))) - (message "CVS update process has completed.") ; XEmacs - (set-buffer-modified-p (buffer-modified-p)) - (setq cvs-update-running nil)) - (if (equal obuf (process-buffer proc)) - nil - (set-buffer (process-buffer proc)) - (if (< opoint omax) - (goto-char opoint)) - (set-buffer obuf)))))) - -;;---------- -(defun cvs-update-filter (proc string) - "Filter function for pcl-cvs. -This function gets the output that CVS sends to stderr. It inserts it -into (process-buffer proc) but it also checks if CVS is waiting for a -lock file. If so, it inserts a message cookie in the *cvs* buffer." - - (let ((old-buffer (current-buffer)) - (data (match-data))) - (unwind-protect - (progn - (set-buffer (process-buffer proc)) - (save-excursion - ;; Insert the text, moving the process-marker. - (goto-char (process-mark proc)) - (insert string) - (set-marker (process-mark proc) (point)) - ;; Delete any old lock message - (if (tin-nth cvs-cookie-handle 1) - (tin-delete cvs-cookie-handle - (tin-nth cvs-cookie-handle 1))) - ;; Check if CVS is waiting for a lock. - (beginning-of-line 0) ;Move to beginning of last - ;complete line. - (cond - ((looking-at - "^cvs \\(update\\|server\\): \\[..:..:..\\] waiting for \\(.*\\)lock in \\(.*\\)$") - (setq cvs-lock-file (buffer-substring (match-beginning 3) - (match-end 3))) - (cookie-enter-last - cvs-cookie-handle - (cvs-create-fileinfo - 'MESSAGE nil nil - (concat "\tWaiting for " - (buffer-substring (match-beginning 2) - (match-end 2)) - "lock in " cvs-lock-file - ".\n\t (type M-x cvs-delete-lock to delete it)"))))))) - (store-match-data data) - (set-buffer old-buffer)))) - -;;---------- -(defun cvs-delete-lock () - "Delete the lock file that CVS is waiting for. -Note that this can be dangerous. You should only do this -if you are convinced that the process that created the lock is dead." - - (interactive) - (cond - ((not (or (file-exists-p - (concat (file-name-as-directory cvs-lock-file) "#cvs.lock")) - (cvs-filter (function cvs-lock-file-p) - (directory-files cvs-lock-file)))) - (error "No lock files found.")) - ((yes-or-no-p (concat "Really delete locks in " cvs-lock-file "? ")) - ;; Re-read the directory -- the locks might have disappeared. - (let ((locks (cvs-filter (function cvs-lock-file-p) - (directory-files cvs-lock-file)))) - (while locks - (delete-file (concat (file-name-as-directory cvs-lock-file) - (car locks))) - (setq locks (cdr locks))) - (cvs-remove-directory - (concat (file-name-as-directory cvs-lock-file) "#cvs.lock")))))) - -;;---------- -(defun cvs-remove-directory (dir) - "Remove a directory." - - (if (file-directory-p dir) - (call-process cvs-rmdir-program nil nil nil dir) - (error "Not a directory: %s" dir)) - (if (file-exists-p dir) - (error "Could not remove directory %s" dir))) - -;;---------- -(defun cvs-lock-file-p (file) - "Return true if FILE looks like a CVS lock file." - - (or - (string-match "^#cvs.tfl.[0-9]+$" file) - (string-match "^#cvs.rfl.[0-9]+$" file) - (string-match "^#cvs.wfl.[0-9]+$" file))) - -;;---------- -(defun cvs-quote-multiword-string (str) - "Return STR surrounded in single quotes if it contains whitespace." - (cond ((string-match "[ \t\n]" str) - (concat "'" str "'")) - (t - str))) - -;;---------- -;; this should be in subr.el or some similar place.... -(defun parse-string (str &optional regexp) - "Explode the string STR into a list of words ala strtok(3). Optional REGEXP -defines regexp matching word separator, which defaults to \"[ \\t\\n]+\"." - (let (str-list ; new list - str-token ; "index" of next token - (str-start 0) ; "index" of current token - (str-sep (if regexp - regexp - "[ \t\n]+"))) - (while (setq str-token (string-match str-sep str str-start)) - (setq str-list - (nconc str-list - (list (substring str str-start str-token)))) - (setq str-start (match-end 0))) - ;; tag on the remainder as the final item - (if (not (>= str-start (length str))) - (setq str-list - (nconc str-list - (list (substring str str-start))))) - str-list)) - -;;---------- -(defun cvs-make-list (str) - "Return list of words made from the string STR." - (cond ((string-match "[ \t\n]+" str) - (let ((new-str (parse-string str "[ \t\n]+"))) - ;; this is ugly, but assume if the first element is empty, there are - ;; no more elements. - (cond ((string= (car new-str) "") - nil) - (t - new-str)))) - ((string= str "") - nil) - (t - (list str)))) - -;;---------- -(defun cvs-skip-line (stdout stderr regexp &optional arg) - "Like forward-line, but check that the skipped line matches REGEXP. -Args: STDOUT STDERR REGEXP &optional ARG. - -If it doesn't match REGEXP a bug report is generated and displayed. -STDOUT and STDERR is only used to do that. - -If optional ARG, a number, is given the ARGth parenthesized expression -in the REGEXP is returned as a string. -Point should be in column 1 when this function is called." - - (cond - ((looking-at regexp) - (forward-line 1) - (if arg - (buffer-substring (match-beginning arg) - (match-end arg)))) - (t - (cvs-parse-error stdout - stderr - (if (eq (current-buffer) stdout) - 'STDOUT - 'STDERR) - (point) - regexp)))) - -;;---------- -(defun cvs-get-current-dir (root-dir dirname) - "Return current working directory, suitable for cvs-parse-update. -Args: ROOT-DIR DIRNAME. - -Concatenates ROOT-DIR and DIRNAME to form an absolute path." - - (if (string= "." dirname) - (substring root-dir 0 -1) - (concat root-dir dirname))) - -;;---------- -(defun cvs-compare-fileinfos (a b) - "Compare fileinfo A with fileinfo B and return t if A is `less'." - - (cond - ;; Sort acording to directories. - ((string< (cvs-fileinfo->dir a) (cvs-fileinfo->dir b)) t) - ((not (string= (cvs-fileinfo->dir a) (cvs-fileinfo->dir b))) nil) - ;; The DIRCHANGE entry is always first within the directory. - ((and (eq (cvs-fileinfo->type a) 'DIRCHANGE) - (not (eq (cvs-fileinfo->type b) 'DIRCHANGE))) t) - ((and (eq (cvs-fileinfo->type b) 'DIRCHANGE) - (not (eq (cvs-fileinfo->type a) 'DIRCHANGE))) nil) - ;; All files are sorted by file name. - ((string< (cvs-fileinfo->file-name a) (cvs-fileinfo->file-name b))))) - -;;---------- -(defun cvs-parse-error (stdout-buffer stderr-buffer err-buf pos &optional indicator) - "Handle a parse error when parsing the output from cvs. -Args: STDOUT-BUFFER STDERR-BUFFER ERR-BUF POS &optional INDICATOR. - -ERR-BUF should be 'STDOUT or 'STDERR." - - (setq pos (1- pos)) - (set-buffer cvs-buffer-name) - (setq buffer-read-only nil) - (erase-buffer) - (insert "To: " pcl-cvs-bugs-address "\n") - (insert "Subject: pcl-cvs release" pcl-cvs-version " parse error.\n") - (insert (concat mail-header-separator "\n")) - (insert "This bug report is automatically generated by pcl-cvs\n") - (insert "because it doesn't understand some output from CVS. Below\n") - (insert "is detailed information about the error. Please send\n") - (insert "this, together with any information you think might be\n") - (insert "useful for me to fix the bug, to the address above. But\n") - (insert "please check the \"known problems\" section of the\n") - (insert "documentation first. Note that this buffer contains\n") - (insert "information that you might consider confidential. You\n") - (insert "are encouraged to read through it before sending it.\n") - (insert "\n") - (insert "Press C-c C-c to send this email.\n\n") - (insert "Please state the version of these programs you are using:\n\n") - (insert "RCS: \ndiff: \n\n") - - (let* ((stdout (save-excursion (set-buffer stdout-buffer) (buffer-string))) - (stderr (save-excursion (set-buffer stderr-buffer) (buffer-string))) - (errstr (if (eq err-buf 'STDOUT) stdout stderr)) - (errline-end (string-match "\n" errstr pos)) - (errline (substring errstr pos errline-end))) - (insert (format "Offending line (%d chars): >" (- errline-end pos))) - (insert errline) - (insert "<\n") - (insert "Sent to " (symbol-name err-buf) " at pos " (format "%d\n" pos)) - (if indicator - (insert "Optional args: \"" indicator "\".\n")) - (insert "\nEmacs-version: " (emacs-version) "\n") - (insert "Pcl-cvs Version: " - "@(#)OrigId: pcl-cvs.el,v 1.93 1993/05/31 22:44:00 ceder Exp\n") - (insert "CVS Version: " - "@(#)lisp/pcl-cvs:$Name: r20-4b2 $:$Id: pcl-cvs.el,v 1.7 1997/10/31 14:53:04 steve Exp $\n\n") - (insert (format "--- Contents of stdout buffer (%d chars) ---\n" - (length stdout))) - (insert stdout) - (insert "--- End of stdout buffer ---\n") - (insert (format "--- Contents of stderr buffer (%d chars) ---\n" - (length stderr))) - (insert stderr) - (insert "--- End of stderr buffer ---\n") - (insert "\nEnd of bug report.\n") - (require 'sendmail) - (mail-mode) - (error "CVS parse error - please report this bug."))) - -;;---------- -(defun cvs-parse-update (stdout-buffer stderr-buffer) - "Parse the output from `cvs update'. - -Args: STDOUT-BUFFER STDERR-BUFFER. - -This functions parses the from `cvs update' (which should be -separated in its stdout- and stderr-components) and prints a -pretty representation of it in the *cvs* buffer. - -Signals an error if unexpected output was detected in the buffer." - - (let* ((head (cons 'dummy nil)) - (tail (cvs-parse-stderr stdout-buffer stderr-buffer - head default-directory)) - (root-dir default-directory)) - (cvs-parse-stdout stdout-buffer stderr-buffer tail root-dir) - (setq head (sort (cdr head) (function cvs-compare-fileinfos))) - (collection-clear cvs-cookie-handle) - (collection-append-cookies cvs-cookie-handle head) - (cvs-remove-stdout-shadows) - (if cvs-auto-remove-handled-directories - (cvs-remove-empty-directories)) - (set-buffer cvs-buffer-name) - (cvs-mode) - ;; XEmacs - tedium should let you know when it's ended... - (if (pos-visible-in-window-p (point-min)) - nil ; assume that the user will see it... - (ding t 'ready) - (message "CVS update is ready.")) - (goto-char (point-min)) - (tin-goto-previous cvs-cookie-handle (point-min) 1) - (setq default-directory root-dir))) - -;;---------- -(defun cvs-remove-stdout-shadows () - "Remove entries in the *cvs* buffer that comes from both stdout and stderr. -If there is two entries for a single file the second one should be -deleted. (Remember that sort uses a stable sort algorithm, so one can -be sure that the stderr entry is always first)." - - (collection-filter-tins cvs-cookie-handle - (function - (lambda (tin) - (not (cvs-shadow-entry-p tin)))))) - -;;---------- -(defun cvs-shadow-entry-p (tin) - "Return non-nil if TIN is a shadow entry. -Args: TIN. - -A TIN is a shadow entry if the previous tin contains the same file." - - (let* ((previous-tin (tin-previous cvs-cookie-handle tin)) - (curr (tin-cookie cvs-cookie-handle tin)) - (prev (and previous-tin - (tin-cookie cvs-cookie-handle previous-tin)))) - (and - prev curr - (string= (cvs-fileinfo->file-name prev) - (cvs-fileinfo->file-name curr)) - (string= (cvs-fileinfo->dir prev) - (cvs-fileinfo->dir curr)) - (or - (and (eq (cvs-fileinfo->type prev) 'CONFLICT) - (eq (cvs-fileinfo->type curr) 'CONFLICT)) - (and (eq (cvs-fileinfo->type prev) 'MERGED) - (eq (cvs-fileinfo->type curr) 'MODIFIED)) - (and (eq (cvs-fileinfo->type prev) 'REM-EXIST) - (eq (cvs-fileinfo->type curr) 'REMOVED)))))) - -;;---------- -(defun cvs-find-backup-file (filename &optional dirname) - "Look for a backup file for FILENAME, optionally in directory DIRNAME, and if -there is one, return the name of the first file found as a string." - - (if (eq dirname nil) - (setq dirname default-directory)) - (car (directory-files dirname nil (concat "^\\" cvs-bakprefix filename - "\\.")))) - -;;---------- -(defun cvs-find-backup-revision (filename) - "Take FILENAME as the name of a cvs backup file and return the revision of -that file as a string." - - (substring filename - (+ 1 (string-match "\\.\\([0-9.]+\\)$" filename)))) - -;;---------- -(defun cvs-parse-stderr (stdout-buffer stderr-buffer head dir) - "Parse the output from CVS that is written to stderr. -Args: STDOUT-BUFFER STDERR-BUFFER HEAD DIR - -STDOUT-BUFFER holds the output that cvs sent to stdout. It is only -used to create a bug report in case there is a parse error. -STDERR-BUFFER is the buffer that holds the output to parse. -HEAD is a cons-cell, the head of the list that is built. -DIR is the directory the `cvs update' was run in. - -This function returns the last cons-cell in the list that is built." - - (save-window-excursion - (set-buffer stderr-buffer) - (goto-char (point-min)) - (let ((current-dir dir) - (root-dir dir)) - - (while (< (point) (point-max)) - (cond - - ;; CVS is descending a subdirectory. - - ((looking-at - "^cvs \\(server\\|update\\): Updating \\(.*\\)$") - (setq current-dir - (cvs-get-current-dir - root-dir - (buffer-substring (match-beginning 2) (match-end 2)))) - (setcdr head (list (cvs-create-fileinfo - 'DIRCHANGE - current-dir - "." ; the old version had nil here??? - (buffer-substring (match-beginning 0) - (match-end 0))))) - (setq head (cdr head)) - (forward-line 1)) - - ;; File removed, since it is removed (by third party) in repository. - - ((or (looking-at - "^cvs \\(update\\|server\\): warning: \\(.*\\) is not (any longer) pertinent") - (looking-at - "^cvs \\(update\\|server\\): \\(.*\\) is no longer in the repository")) - - (setcdr head (list (cvs-create-fileinfo - 'CVS-REMOVED - current-dir - (file-name-nondirectory - (buffer-substring (match-beginning 2) - (match-end 2))) - (buffer-substring (match-beginning 0) - (match-end 0))))) - (setq head (cdr head)) - (forward-line 1)) - - ;; File removed by you, but recreated by cvs. Ignored. Will say - ;; "Updated" on the next line. - - ((looking-at - "^cvs \\(update\\|server\\): warning: .* was lost$") - (forward-line 1)) - - ;; File unknown for some reason. - ;; FIXME: is it really a good idea to add this as unknown here? - - ((looking-at - "cvs \\(update\\|server\\): nothing known about \\(.*\\)$") - (let ((filename (buffer-substring (match-beginning 2) - (match-end 2)))) - (if (file-directory-p filename) - (setcdr head (list (cvs-create-fileinfo - 'UNKNOWN-DIR - current-dir - "." - (buffer-substring (match-beginning 0) - (match-end 0))))) - (setcdr head (list (cvs-create-fileinfo - 'UNKNOWN - current-dir - (file-name-nondirectory filename) - (buffer-substring (match-beginning 0) - (match-end 0))))))) - (setq head (cdr head)) - (forward-line 1)) - - ;; A file that has been created by you, but added to the cvs - ;; repository by another. - - ((looking-at - "^cvs \\(update\\|server\\): move away \\(.*\\); it is in the way$") - (setcdr head (list (cvs-create-fileinfo - 'MOVE-AWAY - current-dir - (file-name-nondirectory - (buffer-substring (match-beginning 2) - (match-end 2))) - (buffer-substring (match-beginning 0) - (match-end 0))))) - (setq head (cdr head)) - (forward-line 1)) - - ;; Cvs waits for a lock. Ignore. - - ((looking-at - "^cvs \\(update\\|server\\): \\[..:..:..\\] waiting for .*lock in ") - (forward-line 1)) - ((looking-at - "^cvs \\(update\\|server\\): \\[..:..:..\\] obtained lock in ") - (forward-line 1)) - - ;; File removed in repository, but edited by you. - - ((looking-at - "^cvs \\(update\\|server\\): conflict: \\(.*\\) is modified but no longer in the repository$") - (setcdr head (list - (cvs-create-fileinfo - 'REM-CONFLICT - current-dir - (file-name-nondirectory - (buffer-substring (match-beginning 2) - (match-end 2))) - (buffer-substring (match-beginning 0) - (match-end 0))))) - (setq head (cdr head)) - (forward-line 1)) - - ;; File removed in repository, but edited by someone else. - - ((looking-at - "^cvs \\(update\\|server\\): conflict: removed \\(.*\\) was modified by second party") - (setcdr head - (list - (cvs-create-fileinfo - 'MOD-CONFLICT - current-dir - (buffer-substring (match-beginning 1) - (match-end 1)) - (buffer-substring (match-beginning 0) - (match-end 0))))) - (setq head (cdr head)) - (forward-line 1)) - - ;; File removed in repository, but not in local directory. - - ((looking-at - "^cvs \\(update\\|server\\): \\(.*\\) should be removed and is still there") - (setcdr head - (list - (cvs-create-fileinfo - 'REM-EXIST - current-dir - (buffer-substring (match-beginning 2) - (match-end 2)) - (buffer-substring (match-beginning 0) - (match-end 0))))) - (setq head (cdr head)) - (forward-line 1)) - - ;; Error searching for repository - - ((looking-at - "^cvs \\(update\\|server\\): in directory ") - (let ((start (point))) - (forward-line 1) - (cvs-skip-line stdout-buffer stderr-buffer - (regexp-quote "cvs [update aborted]: there is no repository ")) - (setcdr head (list (cvs-create-fileinfo - 'REPOS-MISSING - current-dir - nil - (buffer-substring start (point))))) - (setq head (cdr head)))) - - ;; Silly warning from attempted conflict resolution. Ignored. - ;; FIXME: Should it be? - ;; eg.: "cvs update: cannot find revision APC-web-update in file .cvsignore" - ;; - ((looking-at - "^cvs \\(update\\|server\\): cannot find revision \\(.*\\) in file \\(.*\\)$") - (forward-line 1) - (message "%s" (buffer-substring (match-beginning 0) (match-end 0)))) - - ;; CVS has decided to merge someone elses changes into this document. - ;; About to start an rcsmerge operation... - ;; - ((looking-at - "^RCS file: ") - - ;; skip the "RCS file:" line... - (forward-line 1) - - (let ((complex-start (point)) - base-revision ; the first revision retrieved to merge from - head-revision ; the second revision retrieved to merge from - filename ; the name of the file being merged - backup-file ; the name of the backup of the working file - backup-revision) ; the revision of the original working file - - (setq base-revision - (cvs-skip-line stdout-buffer stderr-buffer - "^retrieving revision \\(.*\\)$" - 1)) - (setq head-revision - (cvs-skip-line stdout-buffer stderr-buffer - "^retrieving revision \\(.*\\)$" - 1)) - (setq filename - (cvs-skip-line stdout-buffer stderr-buffer - "^Merging differences between [0-9.]+ and [0-9.]+ into \\(.*\\)$" - 1)) - (setq backup-file - (cvs-find-backup-file filename current-dir)) - (setq backup-revision - (cvs-find-backup-revision backup-file)) - - ;; Was there a conflict during the merge? - - (cond - - ;;;; From CVS-1.3 & RCS-5.6.0.1 with GNU-Diffutils-2.5: - ;;;; "cvs update -j OLD-REV -j NEW-REV ." - ;; - ;; RCS file: /big/web-CVS/apc/cmd/Main/logout.sh,v - ;; retrieving revision 1.1.1.1 - ;; retrieving revision 1.1.1.2 - ;; Merging differences between 1.1.1.1 and 1.1.1.2 into logout.sh - ;; rcsmerge warning: overlaps during merge - - ((looking-at - ;; Allow both RCS 5.5 and 5.6. (5.6 prints "rcs" and " warning"). - "^\\(rcs\\)?merge[:]*\\( warning\\)?: \\(overlaps\\|conflicts\\) during merge$") - - ;; Yes, this is a conflict. - (cvs-skip-line stdout-buffer stderr-buffer - "^\\(rcs\\)?merge[:]*\\( warning\\)?: \\(overlaps\\|conflicts\\) during merge$") - - ;; this line doesn't seem to appear in all cases -- perhaps only - ;; in "-j A -j B" usage, in which case this indicates ???? - (cvs-skip-line stdout-buffer stderr-buffer - "^cvs \\(update\\|server\\): conflicts found in ") - - (let ((fileinfo - (cvs-create-fileinfo - 'CONFLICT current-dir - filename - (buffer-substring complex-start (point))))) - - ;; squirrel away info about the files that were retrieved for merging - (cvs-set-fileinfo->base-revision fileinfo base-revision) - (cvs-set-fileinfo->head-revision fileinfo head-revision) - (cvs-set-fileinfo->backup-revision fileinfo backup-revision) - (cvs-set-fileinfo->backup-file fileinfo backup-file) - - (setcdr head (list fileinfo)) - (setq head (cdr head)))) - - ;; Was it a conflict, and was RCS compiled without DIFF3_BIN, in - ;; which case this is a failed conflict resolution? - - ((looking-at - ;; Allow both RCS 5.5 and 5.6. (5.6 prints "rcs" and " warning"). - "^\\(rcs\\)?merge\\( warning\\)?: overlaps or other problems during merge$") - - (cvs-skip-line stdout-buffer stderr-buffer - "^\\(rcs\\)?merge\\( warning\\)?: overlaps or other problems during merge$") - (cvs-skip-line stdout-buffer stderr-buffer - "^cvs update: could not merge ") - (cvs-skip-line stdout-buffer stderr-buffer - "^cvs update: restoring .* from backup file ") - (let ((fileinfo - (cvs-create-fileinfo - 'CONFLICT current-dir - filename - (buffer-substring complex-start (point))))) - (setcdr head (list fileinfo)) - (setq head (cdr head)))) - - ;; Not a conflict; it must be a succesful merge. - - (t - (let ((fileinfo - (cvs-create-fileinfo - 'MERGED current-dir - filename - (buffer-substring complex-start (point))))) - (cvs-set-fileinfo->base-revision fileinfo base-revision) - (cvs-set-fileinfo->head-revision fileinfo head-revision) - (cvs-set-fileinfo->backup-revision fileinfo backup-revision) - (cvs-set-fileinfo->backup-file fileinfo backup-file) - (setcdr head (list fileinfo)) - (setq head (cdr head))))))) - - ;; Patch failure message with CVS client. - ;; Ignore, since a failed patch implies that the file proper - ;; subsequently will be fetched from the server. - ((looking-at - "^[0-9]+ out of [0-9]+ hunks failed--saving rejects to ") - (forward-line 1)) - - ;; Error messages from CVS (incomplete) - - ((looking-at - "^cvs \\(update\\|server\\): \\(invalid option .*\\)$") - (error "Interface problem with CVS: %s" - (buffer-substring (match-beginning 2) (match-end 2)))) - - ;; network errors - - ;; Kerberos connection attempted but failed. This is not - ;; really an error, as CVS will automatically fall back to - ;; rsh. Plus it tries kerberos, if available, even when rsh - ;; is what you really wanted. - - ((looking-at - "^cvs update: kerberos connect:.*$") - (forward-line 1) - (message "Remote CVS: %s" - (buffer-substring (match-beginning 0) (match-end 0)))) - - ;; And when kerberos *does* fail, cvs prints out some stuff - ;; as it tries rsh. Ignore that stuff too. - - ((looking-at - "^cvs update: trying to start server using rsh$") - (forward-line 1)) - - ((looking-at - "^\\([^:]*\\) Connection timed out") - (error "Remote CVS: %s" - (buffer-substring (match-beginning 0) (match-end 0)))) - - ((looking-at - "^Permission denied.") - (error "Remote CVS: %s" - (buffer-substring (match-beginning 0) (match-end 0)))) - - ((looking-at - "^cvs \\[update aborted\\]: premature end of file from server") - (error "Remote CVS: %s" - (buffer-substring (match-beginning 0) (match-end 0)))) - - ;; Empty line. Probably inserted by mistake by user (or developer :-) - ;; Ignore. - - ((looking-at - "^$") - (forward-line 1)) - - ((looking-at - "^Executing ssh-askpass to query the password") - (forward-line 1)) - - ;; top-level parser (cond) default clause - - (t - (cvs-skip-line stdout-buffer stderr-buffer - "^UN-MATCHABLE-OUTPUT")))))) - - ;; cause this function to return the head of the parser output list - head) - -;;---------- -(defun cvs-parse-stdout (stdout-buffer stderr-buffer head root-dir) - "Parse the output from CVS that is written to stderr. -Args: STDOUT-BUFFER STDERR-BUFFER HEAD ROOT-DIR - -STDOUT-BUFFER is the buffer that holds the output to parse. -STDERR-BUFFER holds the output that cvs sent to stderr. It is only -used to create a bug report in case there is a parse error. - -HEAD is a cons-cell, the head of the list that is built. -ROOT-DIR is the directory the `cvs update' was run in. - -This function doesn't return anything particular." - - (save-window-excursion - (set-buffer stdout-buffer) - (goto-char (point-min)) - (while (< (point) (point-max)) - (cond - - ;; M: The file is modified by the user, and untouched in the repository. - ;; A: The file is "cvs add"ed, but not "cvs ci"ed. - ;; R: The file is "cvs remove"ed, but not "cvs ci"ed. - ;; C: Conflict (only useful if a join was done and stderr has info...) - ;; U: The file is copied from the repository. - ;; ?: Unknown file or directory. - - ((looking-at - "^\\([MARCUP?]\\) \\(.*\\)$") - (let* - ((c (char-after (match-beginning 1))) - (full-path (concat (file-name-as-directory root-dir) - (buffer-substring (match-beginning 2) - (match-end 2)))) - (isdir (file-directory-p full-path)) - (fileinfo (cvs-create-fileinfo - (cond ((eq c ?M) 'MODIFIED) - ((eq c ?A) 'ADDED) - ((eq c ?R) 'REMOVED) - ((eq c ?C) 'CONFLICT) - ((eq c ?U) 'UPDATED) - ((eq c ?P) 'PATCHED) - ((eq c ??) (if isdir - 'UNKNOWN-DIR - 'UNKNOWN))) - (substring (file-name-directory full-path) 0 -1) - (file-name-nondirectory full-path) - (buffer-substring (match-beginning 0) (match-end 0))))) - ;; Updated and Patched files require no further action. - (if (memq c '(?U ?P)) - (cvs-set-fileinfo->handled fileinfo t)) - - ;; Link this last on the list. - (setcdr head (list fileinfo)) - (setq head (cdr head)) - (forward-line 1))) - - ;; Executing a program because of the -u option in modules. - ((looking-at - "^cvs \\(update\\|server\\): Executing") - ;; Skip by any output the program may generate to stdout. - ;; Note that pcl-cvs will get seriously confused if the - ;; program prints anything to stderr. - (re-search-forward cvs-update-prog-output-skip-regexp) - (forward-line 1)) - - ;; Patch informational message with CVS client. - ;; Ignore, since this simply tells us that the patch in question - ;; already has been applied to the file. - ((looking-at - "^.* already contains the differences between .* and ") - (forward-line 1)) - - (t - (cvs-parse-error stdout-buffer stderr-buffer 'STDOUT (point) - "cvs-parse-stdout")))))) - -;;---------- -(defun cvs-pp (fileinfo) - "Pretty print FILEINFO. Insert a printed representation in current buffer. -For use by the cookie package." - - (let ((a (cvs-fileinfo->type fileinfo)) - (s (if (cvs-fileinfo->marked fileinfo) - "*" " ")) - (f (cvs-fileinfo->file-name fileinfo)) - (ci (if (cvs-fileinfo->handled fileinfo) - " " "ci"))) - (insert - (cond - ((eq a 'UPDATED) - (format "%s Updated %s" s f)) - ((eq a 'PATCHED) - (format "%s Patched %s" s f)) - ((eq a 'MODIFIED) - (format "%s Modified %s %s" s ci f)) - ((eq a 'MERGED) - (format "%s Merged %s %s" s ci f)) - ((eq a 'CONFLICT) - (format "%s Conflict %s" s f)) - ((eq a 'ADDED) - (format "%s Added %s %s" s ci f)) - ((eq a 'REMOVED) - (format "%s Removed %s %s" s ci f)) - ((eq a 'UNKNOWN) - (format "%s Unknown %s" s f)) - ((eq a 'UNKNOWN-DIR) - (format "%s Unknown dir %s" s f)) - ((eq a 'CVS-REMOVED) - (format "%s Removed from repository: %s" s f)) - ((eq a 'REM-CONFLICT) - (format "%s Conflict: Removed from repository, changed by you: %s" s f)) - ((eq a 'MOD-CONFLICT) - (format "%s Conflict: Removed by you, changed in repository: %s" s f)) - ((eq a 'REM-EXIST) - (format "%s Conflict: Removed by you, but still exists: %s" s f)) - ((eq a 'DIRCHANGE) - (format "\nIn directory %s:" (cvs-fileinfo->dir fileinfo))) - ((eq a 'MOVE-AWAY) - (format "%s Move away %s - it is in the way" s f)) - ((eq a 'REPOS-MISSING) - (format " This repository directory is missing! Remove this directory manually.")) - ((eq a 'MESSAGE) - (cvs-fileinfo->full-log fileinfo)) - (t - (format "%s Internal error! %s" s f)))))) - - -;;; You can define your own keymap in .emacs. pcl-cvs.el won't overwrite it. - -(if cvs-mode-map - nil - (setq cvs-mode-map (make-keymap)) - (suppress-keymap cvs-mode-map) - (define-prefix-command 'cvs-mode-map-control-c-prefix) - (define-key cvs-mode-map "\C-?" 'cvs-mode-unmark-up) - (define-key cvs-mode-map "\C-k" 'cvs-mode-acknowledge) - (define-key cvs-mode-map "\C-n" 'cvs-mode-next-line) - (define-key cvs-mode-map "\C-p" 'cvs-mode-previous-line) - ;; ^C- keys are used to set various flags to control CVS features - (define-key cvs-mode-map "\C-c" 'cvs-mode-map-control-c-prefix) - (define-key cvs-mode-map "\C-c\C-c" 'cvs-change-cvsroot) - (define-key cvs-mode-map "\C-c\C-d" 'cvs-set-diff-flags) - (define-key cvs-mode-map "\C-c\C-l" 'cvs-set-log-flags) - (define-key cvs-mode-map "\C-c\C-s" 'cvs-set-status-flags) - (define-key cvs-mode-map "\C-c\C-u" 'cvs-set-update-optional-flags) - ;; M- keys are usually those that operate on modules - (define-key cvs-mode-map "\M-\C-?" 'cvs-mode-unmark-all-files) - (define-key cvs-mode-map "\M-C" 'cvs-mode-rcs2log) ; i.e. "Create a ChangeLog" - (define-key cvs-mode-map "\M-a" 'cvs-mode-admin) - (define-key cvs-mode-map "\M-c" 'cvs-mode-checkout) - (define-key cvs-mode-map "\M-o" 'cvs-mode-checkout-other-window) - (define-key cvs-mode-map "\M-p" 'cvs-mode-rdiff) ; i.e. "create a Patch" - (define-key cvs-mode-map "\M-r" 'cvs-mode-release) - (define-key cvs-mode-map "\M-t" 'cvs-mode-rtag) - ;; keys that operate on files - (define-key cvs-mode-map " " 'cvs-mode-next-line) - (define-key cvs-mode-map "?" 'describe-mode) - (define-key cvs-mode-map "A" 'cvs-mode-add-change-log-entry-other-window) - (define-key cvs-mode-map "B" 'cvs-mode-byte-compile-files) - (define-key cvs-mode-map "C" 'cvs-mode-changelog-commit) - (define-key cvs-mode-map "E" 'cvs-mode-emerge) - (define-key cvs-mode-map "G" 'cvs-update) - (define-key cvs-mode-map "M" 'cvs-mode-mark-all-files) - (define-key cvs-mode-map "Q" 'cvs-examine) - (define-key cvs-mode-map "R" 'cvs-mode-revert-updated-buffers) - (define-key cvs-mode-map "U" 'cvs-mode-undo-local-changes) - (define-key cvs-mode-map "a" 'cvs-mode-add) - (define-key cvs-mode-map "b" 'cvs-mode-diff-backup) - (define-key cvs-mode-map "c" 'cvs-mode-commit) - (define-key cvs-mode-map "d" 'cvs-mode-diff-cvs) - (define-key cvs-mode-map "e" 'cvs-mode-ediff) - (define-key cvs-mode-map "f" 'cvs-mode-find-file) - (define-key cvs-mode-map "g" 'cvs-mode-update-no-prompt) - (define-key cvs-mode-map "i" 'cvs-mode-ignore) - (define-key cvs-mode-map "l" 'cvs-mode-log) - (define-key cvs-mode-map "m" 'cvs-mode-mark) - (define-key cvs-mode-map "n" 'cvs-mode-next-line) - (define-key cvs-mode-map "o" 'cvs-mode-find-file-other-window) - (define-key cvs-mode-map "p" 'cvs-mode-previous-line) - (define-key cvs-mode-map "q" 'bury-buffer) - (define-key cvs-mode-map "r" 'cvs-mode-remove-file) - (define-key cvs-mode-map "s" 'cvs-mode-status) - (define-key cvs-mode-map "t" 'cvs-mode-tag) - (define-key cvs-mode-map "u" 'cvs-mode-unmark) - (define-key cvs-mode-map "v" 'cvs-mode-diff-vendor) - (define-key cvs-mode-map "x" 'cvs-mode-remove-handled)) - -;;---------- -(defun cvs-get-marked (&optional ignore-marks ignore-contents) - "Return a list of all selected tins. -Args: &optional IGNORE-MARKS IGNORE-CONTENTS. - -If there are any marked tins, and IGNORE-MARKS is nil, return them. Otherwise, -if the cursor selects a directory, return all files in it, unless there are -none, in which case just return the directory; or unless IGNORE-CONTENTS is not -nil, in which case also just return the directory. Otherwise return (a list -containing) the file the cursor points to, or an empty list if it doesn't point -to a file at all." - - (cond - ;; Any marked cookies? - ((and (not ignore-marks) - (collection-collect-tin cvs-cookie-handle 'cvs-fileinfo->marked))) - ;; Nope. - ((and (not ignore-contents) - (let ((sel (tin-locate cvs-cookie-handle (point)))) - (cond - ;; If a directory is selected, all it members are returned. - ((and sel (eq (cvs-fileinfo->type (tin-cookie cvs-cookie-handle - sel)) - 'DIRCHANGE)) - (let ((retsel - (collection-collect-tin cvs-cookie-handle - 'cvs-dir-member-p - (cvs-fileinfo->dir (tin-cookie - cvs-cookie-handle sel))))) - (if retsel - retsel - (list sel)))) - (t - (list sel)))))) - (t - (list (tin-locate cvs-cookie-handle (point)))))) - -;;---------- -(defun cvs-dir-member-p (fileinfo dir) - "Return true if FILEINFO represents a file in directory DIR." - - (and (not (eq (cvs-fileinfo->type fileinfo) 'DIRCHANGE)) - (string= (cvs-fileinfo->dir fileinfo) dir))) - -;;---------- -(defun cvs-dir-empty-p (tin) - "Return non-nil if TIN is a directory that is empty. -Args: CVS-BUF TIN." - - (and (eq (cvs-fileinfo->type (tin-cookie cvs-cookie-handle tin)) 'DIRCHANGE) - (or (not (tin-next cvs-cookie-handle tin)) - (eq (cvs-fileinfo->type - (tin-cookie cvs-cookie-handle - (tin-next cvs-cookie-handle tin))) - 'DIRCHANGE)))) - -;;---------- -(defun cvs-mode-revert-updated-buffers () - "Revert any buffers that are UPDATED, PATCHED, MERGED or CONFLICT." - - (interactive) - (cookie-map (function cvs-revert-fileinfo) cvs-cookie-handle)) - -;;---------- -(defun cvs-revert-fileinfo (fileinfo) - "Revert the buffer that holds the file in FILEINFO if it has changed, -and if the type is UPDATED, PATCHED, MERGED or CONFLICT." - - (let* ((type (cvs-fileinfo->type fileinfo)) - (file (cvs-fileinfo->full-path fileinfo)) - (buffer (get-file-buffer file))) - ;; For a revert to happen... - (cond - ((and - ;; ...the type must be one that justifies a revert... - (or (eq type 'UPDATED) - (eq type 'PATCHED) - (eq type 'MERGED) - (eq type 'CONFLICT)) - ;; ...and the user must be editing the file... - buffer) - (save-excursion - (set-buffer buffer) - (cond - ((buffer-modified-p) - (error "%s: edited since last cvs-update." - (buffer-file-name))) - ;; Go ahead and revert the file. - (t (revert-buffer 'dont-use-auto-save-file 'dont-ask)))))))) - -;;---------- -(defun cvs-mode-remove-handled () - "Remove all lines that are handled. -Empty directories are removed." - - (interactive) - ;; Pass one: remove files that are handled. - (collection-filter-cookies cvs-cookie-handle - (function - (lambda (fileinfo) - (not (cvs-fileinfo->handled fileinfo))))) - ;; Pass two: remove empty directories. - (if cvs-auto-remove-handled-directories - (cvs-remove-empty-directories))) - -;;---------- -(defun cvs-remove-empty-directories () - "Remove empty directories in the *cvs* buffer." - - (collection-filter-tins cvs-cookie-handle - (function - (lambda (tin) - (not (cvs-dir-empty-p tin)))))) - -;;---------- -(defun cvs-mode-mark (pos) - "Mark a fileinfo. -Args: POS. - -If the fileinfo is a directory, all the contents of that directory are marked -instead. A directory can never be marked. POS is a buffer position." - - (interactive "d") - (let* ((tin (tin-locate cvs-cookie-handle pos)) - (sel (tin-cookie cvs-cookie-handle tin))) - (cond - ;; Does POS point to a directory? If so, mark all files in that directory. - ((eq (cvs-fileinfo->type sel) 'DIRCHANGE) - (cookie-map - (function (lambda (f dir) - (cond - ((cvs-dir-member-p f dir) - (cvs-set-fileinfo->marked f t) - t)))) ; Tell cookie to redisplay this cookie. - cvs-cookie-handle - (cvs-fileinfo->dir sel))) - (t - (cvs-set-fileinfo->marked sel t) - (tin-invalidate cvs-cookie-handle tin) - (tin-goto-next cvs-cookie-handle pos 1))))) - -;;---------- -(defun cvs-committable (tin) - "Check if the TIN is committable. -It is committable if it - a) is not handled and - b) is either MODIFIED, ADDED, REMOVED, MERGED or CONFLICT." - - (let* ((fileinfo (tin-cookie cvs-cookie-handle tin)) - (type (cvs-fileinfo->type fileinfo))) - (and (not (cvs-fileinfo->handled fileinfo)) - (or (eq type 'MODIFIED) - (eq type 'ADDED) - (eq type 'REMOVED) - (eq type 'MERGED) - (eq type 'CONFLICT))))) - -;;---------- -(defun cvs-mode-commit () - "Check in all marked files, or the current file. -The user will be asked for a log message in a buffer. -If cvs-erase-input-buffer is non-nil that buffer will be erased. -Otherwise mark and point will be set around the entire contents of the -buffer so that it is easy to kill the contents of the buffer with \\[kill-region]." - - (interactive) - (let* ((cvs-buf (current-buffer)) - (marked (cvs-filter (function cvs-committable) - (cvs-get-marked)))) - (if (null marked) - (error "Nothing to commit!") - (pop-to-buffer (get-buffer-create cvs-commit-prompt-buffer)) - (goto-char (point-min)) - - (if cvs-erase-input-buffer - (erase-buffer) - (push-mark (point-max))) - (cvs-edit-mode) - (make-local-variable 'cvs-commit-list) - (setq cvs-commit-list marked) - (message "Press C-c C-c when you are done editing.")))) - -;;---------- -(defun cvs-edit-done () - "Commit the files to the repository." - - (interactive) - (if (null cvs-commit-list) - (error "You have already committed the files")) - (if (and (> (point-max) 1) - (/= (char-after (1- (point-max))) ?\n) - (or (eq cvs-commit-buffer-require-final-newline t) - (and cvs-commit-buffer-require-final-newline - (yes-or-no-p - (format "Buffer %s does not end in newline. Add one? " - (buffer-name)))))) - (save-excursion - (goto-char (point-max)) - (insert ?\n))) - (save-some-buffers) - (let ((cc-list cvs-commit-list) - (cc-buffer (get-buffer cvs-buffer-name)) - (msg-buffer (current-buffer)) - (msg (buffer-substring (point-min) (point-max)))) - (pop-to-buffer cc-buffer) - (bury-buffer msg-buffer) - (cvs-use-temp-buffer) - (message "Committing...") - (if (cvs-execute-list cc-list cvs-program - (if cvs-cvsroot - (list "-d" cvs-cvsroot "commit" "-m" msg) - (list "commit" "-m" msg)) - "Committing %s...") - (error "Something went wrong. Check the %s buffer carefully." - cvs-temp-buffer-name)) - ;; FIXME: don't do any of this if the commit fails. - (let ((ccl cc-list)) - (while ccl - (cvs-after-commit-function (tin-cookie cvs-cookie-handle (car ccl))) - (setq ccl (cdr ccl)))) - (apply 'tin-invalidate cvs-cookie-handle cc-list) - (set-buffer msg-buffer) - (setq cvs-commit-list nil) - (set-buffer cc-buffer) - (if cvs-auto-remove-handled - (cvs-mode-remove-handled))) - - (message "Committing... Done.")) - -;;---------- -(defun cvs-after-commit-function (fileinfo) - "Do everything that needs to be done when FILEINFO has been committed. -The fileinfo->handle is set, and if the buffer is present it is reverted." - - (cvs-set-fileinfo->handled fileinfo t) - (if cvs-auto-revert-after-commit - (let* ((file (cvs-fileinfo->full-path fileinfo)) - (buffer (get-file-buffer file))) - ;; For a revert to happen... - (if buffer - ;; ...the user must be editing the file... - (save-excursion - (set-buffer buffer) - (if (not (buffer-modified-p)) - ;; ...but it must be unmodified. - (revert-buffer 'dont-use-auto-save-file 'dont-ask))))))) - -;;---------- -(defun cvs-execute-list (tin-list program constant-args &optional message-fmt) - "Run PROGRAM on all elements on TIN-LIST. -Args: TIN-LIST PROGRAM CONSTANT-ARGS. - -The PROGRAM will be called with pwd set to the directory the files reside -in. CONSTANT-ARGS should be a list of strings. The arguments given to the -program will be CONSTANT-ARGS followed by all the files (from TIN-LIST) that -resides in that directory. If the files in TIN-LIST resides in different -directories the PROGRAM will be run once for each directory (if all files in -the same directory appears after each other). - -Any output from PROGRAM will be inserted in the current buffer. - -This function return nil if all went well, or the numerical exit status or a -signal name as a string. Note that PROGRAM might be called several times. This -will return non-nil if something goes wrong, but there is no way to know which -process that failed. - -If MESSAGE-FMT is not nil, then message is called to display progress with -MESSAGE-FMT as the string. MESSAGE-FMT should contain one %s for the arg-list -being passed to PROGRAM." - - ;; FIXME: something seems wrong with the error checking here.... - - (let ((exitstatus nil)) - (while tin-list - (let ((current-dir (cvs-fileinfo->dir (tin-cookie cvs-cookie-handle - (car tin-list)))) - arg-list - arg-str) - - ;; Collect all marked files in this directory. - - (while (and tin-list - (string= current-dir - (cvs-fileinfo->dir (tin-cookie cvs-cookie-handle - (car tin-list))))) - (setq arg-list - (cons (cvs-fileinfo->file-name - (tin-cookie cvs-cookie-handle (car tin-list))) - arg-list)) - (setq tin-list (cdr tin-list))) - - (setq arg-list (nreverse arg-list)) - - ;; Execute the command on all the files that were collected. - - (if message-fmt - (message message-fmt - (mapconcat 'cvs-quote-multiword-string - arg-list - " "))) - (setq default-directory (file-name-as-directory current-dir)) - (insert (format "=== cd %s\n" default-directory)) - (insert (format "=== %s %s\n\n" - program - (mapconcat 'cvs-quote-multiword-string - (nconc (copy-sequence constant-args) - arg-list) - " "))) - (let ((res (apply 'call-process program nil t t - (nconc (copy-sequence constant-args) arg-list)))) - ;; Remember the first, or highest, exitstatus. - (if (and (not (and (integerp res) (zerop res))) - (or (null exitstatus) - (and (integerp exitstatus) (= 1 exitstatus)))) - (setq exitstatus res))) - (goto-char (point-max)) - (if message-fmt - (message message-fmt - (mapconcat 'cvs-quote-multiword-string - (nconc (copy-sequence arg-list) '("Done.")) - " "))) - exitstatus)))) - -;;---------- -;;;; +++ not currently used! -(defun cvs-execute-single-file-list (tin-list extractor program constant-args - &optional cleanup message-fmt) - "Run PROGRAM on all elements on TIN-LIST. -Args: TIN-LIST EXTRACTOR PROGRAM CONSTANT-ARGS &optional CLEANUP. - -The PROGRAM will be called with pwd set to the directory the files -reside in. CONSTANT-ARGS is a list of strings to pass as arguments to -PROGRAM. The arguments given to the program will be CONSTANT-ARGS -followed by the list that EXTRACTOR returns. - -EXTRACTOR will be called once for each file on TIN-LIST. It is given -one argument, the cvs-fileinfo. It can return t, which means ignore -this file, or a list of arguments to send to the program. - -If CLEANUP is not nil, the filenames returned by EXTRACTOR are deleted. - -If MESSAGE-FMT is not nil, then message is called to display progress with -MESSAGE-FMT as the string. MESSAGE-FMT should contain one %s for the arg-list -being passed to PROGRAM." - - (while tin-list - (let ((current-dir (file-name-as-directory - (cvs-fileinfo->dir - (tin-cookie cvs-cookie-handle - (car tin-list))))) - (arg-list - (funcall extractor - (tin-cookie cvs-cookie-handle (car tin-list))))) - - ;; Execute the command unless extractor returned t. - - (if (eq arg-list t) - nil - (setq default-directory current-dir) - (insert (format "=== cd %s\n" default-directory)) - (insert (format "=== %s %s\n\n" - program - (mapconcat 'cvs-quote-multiword-string - (nconc (copy-sequence constant-args) - arg-list) - " "))) - (if message-fmt - (message message-fmt (mapconcat 'cvs-quote-multiword-string - arg-list - " "))) - (apply 'call-process program nil t t - (nconc (copy-sequence constant-args) arg-list)) - (goto-char (point-max)) - (if message-fmt - (message message-fmt (mapconcat 'cvs-quote-multiword-string - (nconc arg-list '("Done.")) - " "))) - (if cleanup - (while arg-list -;;;; (kill-buffer ?????) - (delete-file (car arg-list)) - (setq arg-list (cdr arg-list)))))) - (setq tin-list (cdr tin-list)))) - -;;---------- -(defun cvs-edit-mode () - "\\<cvs-edit-mode-map>Mode for editing cvs log messages. -Commands: -\\[cvs-edit-done] checks in the file when you are ready. -This mode is based on fundamental mode." - - (interactive) - (use-local-map cvs-edit-mode-map) - (setq major-mode 'cvs-edit-mode) - (setq mode-name "CVS Log") - (auto-fill-mode 1)) - -;;---------- -(if cvs-edit-mode-map - nil - (setq cvs-edit-mode-map (make-sparse-keymap)) - (define-prefix-command 'cvs-edit-mode-control-c-prefix) - (define-key cvs-edit-mode-map "\C-c" 'cvs-edit-mode-control-c-prefix) - (define-key cvs-edit-mode-map "\C-c\C-c" 'cvs-edit-done)) - -;;---------- -(defun cvs-diffable (tins) - "Return a list of all tins on TINS that it makes sense to run -``cvs diff'' on." - - ;; +++ There is an unnecessary (nreverse) here. Get the list the - ;; other way around instead! - (let ((result nil)) - (while tins - (let ((type (cvs-fileinfo->type - (tin-cookie cvs-cookie-handle (car tins))))) - (if (or (eq type 'MODIFIED) - (eq type 'UPDATED) - (eq type 'PATCHED) - (eq type 'MERGED) - (eq type 'CONFLICT) - (eq type 'REMOVED) ;+++Does this line make sense? - (eq type 'ADDED)) ;+++Does this line make sense? - (setq result (cons (car tins) result))) - (setq tins (cdr tins)))) - (nreverse result))) - -;;---------- -(defun cvs-mode-diff-cvs (&optional ignore-marks) - "Diff the selected files against the head revisions in the repository. - -If the variable cvs-diff-ignore-marks is non-nil any marked files will not be -considered to be selected. An optional prefix argument will invert the -influence from cvs-diff-ignore-marks. - -The flags in the variable cvs-diff-flags will be passed to ``cvs diff''. - -The resulting diffs are placed in the cvs-fileinfo->cvs-diff-buffer." - - (interactive "P") - (if (not (listp cvs-diff-flags)) - (error "cvs-diff-flags should be set using cvs-set-diff-flags.")) - (save-some-buffers) - (message "cvsdiffing...") - (let ((marked-file-list (cvs-diffable - (cvs-get-marked - (or (and ignore-marks (not cvs-diff-ignore-marks)) - (and (not ignore-marks) cvs-diff-ignore-marks)))))) - (while marked-file-list - (let ((fileinfo-to-diff (tin-cookie cvs-cookie-handle - (car marked-file-list))) - (local-def-directory (file-name-as-directory - (cvs-fileinfo->dir - (tin-cookie cvs-cookie-handle - (car marked-file-list)))))) - (message "cvsdiffing %s..." - (cvs-fileinfo->file-name fileinfo-to-diff)) - - ;; FIXME: this seems messy to test and set buffer name at this point.... - (if (not (cvs-fileinfo->cvs-diff-buffer fileinfo-to-diff)) - (cvs-set-fileinfo->cvs-diff-buffer fileinfo-to-diff - (concat "*cvs-diff-" - (cvs-fileinfo->file-name - fileinfo-to-diff) - "-in-" - local-def-directory - "*"))) - (display-buffer (get-buffer-create - (cvs-fileinfo->cvs-diff-buffer fileinfo-to-diff))) - (set-buffer (cvs-fileinfo->cvs-diff-buffer fileinfo-to-diff)) - (setq buffer-read-only nil) - (setq default-directory local-def-directory) - (erase-buffer) - (insert (format "=== cd %s\n" default-directory)) - (insert (format "=== cvs %s\n\n" - (mapconcat 'cvs-quote-multiword-string - (nconc (if cvs-cvsroot - (list "-d" cvs-cvsroot "diff") - '("diff")) - (copy-sequence cvs-diff-flags) - (list (cvs-fileinfo->file-name - fileinfo-to-diff))) - " "))) - (if (apply 'call-process cvs-program nil t t - (nconc (if cvs-cvsroot - (list "-d" cvs-cvsroot "diff") - '("diff")) - (copy-sequence cvs-diff-flags) - (list (cvs-fileinfo->file-name fileinfo-to-diff)))) - (message "cvsdiffing %s... Done." - (cvs-fileinfo->file-name fileinfo-to-diff)) - (message "cvsdiffing %s... No differences found." - (cvs-fileinfo->file-name fileinfo-to-diff))) - (goto-char (point-max)) - (setq marked-file-list (cdr marked-file-list))))) - (message "cvsdiffing... Done.")) - -;;---------- -(defun cvs-mode-diff-backup (&optional ignore-marks) - "Diff the files against the backup file. -This command can be used on files that are marked with \"Merged\" -or \"Conflict\" in the *cvs* buffer. - -If the variable cvs-diff-ignore-marks is non-nil any marked files will -not be considered to be selected. An optional prefix argument will -invert the influence from cvs-diff-ignore-marks. - -The flags in cvs-diff-flags will be passed to ``diff''. - -The resulting diffs are placed in the cvs-fileinfo->backup-diff-buffer." - - (interactive "P") - (if (not (listp cvs-diff-flags)) - (error "cvs-diff-flags should be set using cvs-set-diff-flags.")) - (save-some-buffers) - (let ((marked-file-list (cvs-filter - (function cvs-backup-diffable) - (cvs-get-marked - (or - (and ignore-marks (not cvs-diff-ignore-marks)) - (and (not ignore-marks) cvs-diff-ignore-marks)))))) - (if (null marked-file-list) - (error "No ``Conflict'' or ``Merged'' file selected!")) - (message "backup diff...") - (while marked-file-list - (let ((fileinfo-to-diff (tin-cookie cvs-cookie-handle - (car marked-file-list))) - (local-def-directory (file-name-as-directory - (cvs-fileinfo->dir - (tin-cookie cvs-cookie-handle - (car marked-file-list))))) - (backup-temp-files (cvs-diff-backup-extractor - (tin-cookie cvs-cookie-handle - (car marked-file-list))))) - (message "backup diff %s..." - (cvs-fileinfo->file-name fileinfo-to-diff)) - - ;; FIXME: this seems messy to test and set buffer name at this point.... - (if (not (cvs-fileinfo->backup-diff-buffer fileinfo-to-diff)) - (cvs-set-fileinfo->backup-diff-buffer fileinfo-to-diff - (concat "*cvs-diff-" - (cvs-fileinfo->backup-file - fileinfo-to-diff) - "-to-" - (cvs-fileinfo->file-name - fileinfo-to-diff) - "-in" - local-def-directory - "*"))) - (display-buffer (get-buffer-create - (cvs-fileinfo->backup-diff-buffer fileinfo-to-diff))) - (set-buffer (cvs-fileinfo->backup-diff-buffer fileinfo-to-diff)) - (setq buffer-read-only nil) - (setq default-directory local-def-directory) - (erase-buffer) - (insert (format "=== cd %s\n" default-directory)) - (insert (format "=== %s %s\n\n" - cvs-diff-program - (mapconcat 'cvs-quote-multiword-string - (nconc (copy-sequence cvs-diff-flags) - backup-temp-files) - " "))) - (apply 'call-process cvs-diff-program nil t t - (nconc (copy-sequence cvs-diff-flags) backup-temp-files)) - (goto-char (point-max)) - (message "backup diff %s... Done." - (cvs-fileinfo->file-name fileinfo-to-diff)) - (setq marked-file-list (cdr marked-file-list))))) - (message "backup diff... Done.")) - -;;---------- -(defun cvs-mode-diff-vendor (&optional ignore-marks) - "Diff the revisions merged into the current file. I.e. show what changes -were merged in. - -This command can be used on files that are marked with \"Merged\" -or \"Conflict\" in the *cvs* buffer. - -If the variable cvs-diff-ignore-marks is non-nil any marked files will -not be considered to be selected. An optional prefix argument will -invert the influence from cvs-diff-ignore-marks. - -The flags in cvs-diff-flags will be passed to ``diff''. - -The resulting diffs are placed in the cvs-fileinfo->vendor-diff-buffer." - - (interactive "P") - (if (not (listp cvs-diff-flags)) - (error "cvs-diff-flags should be set using cvs-set-diff-flags.")) - (save-some-buffers) - (let ((marked-file-list (cvs-filter - (function cvs-vendor-diffable) - (cvs-get-marked - (or - (and ignore-marks (not cvs-diff-ignore-marks)) - (and (not ignore-marks) cvs-diff-ignore-marks)))))) - (if (null marked-file-list) - (error "No ``Conflict'' or ``Merged'' file selected!")) - (message "vendor diff...") - (while marked-file-list - (let ((fileinfo-to-diff (tin-cookie cvs-cookie-handle - (car marked-file-list))) - (local-def-directory (file-name-as-directory - (cvs-fileinfo->dir - (tin-cookie cvs-cookie-handle - (car marked-file-list))))) - (vendor-temp-files (cvs-diff-vendor-extractor - (tin-cookie cvs-cookie-handle - (car marked-file-list))))) - (message "vendor diff %s..." - (cvs-fileinfo->file-name fileinfo-to-diff)) - (if (not (cvs-fileinfo->vendor-diff-buffer fileinfo-to-diff)) - (cvs-set-fileinfo->vendor-diff-buffer fileinfo-to-diff - (concat "*cvs-diff-" - (cvs-fileinfo->file-name - fileinfo-to-diff) - "-of-" - (cvs-fileinfo->base-revision - fileinfo-to-diff) - "-to-" - (cvs-fileinfo->head-revision - fileinfo-to-diff) - "-in-" - local-def-directory - "*"))) - (display-buffer (get-buffer-create - (cvs-fileinfo->vendor-diff-buffer fileinfo-to-diff))) - (set-buffer (cvs-fileinfo->vendor-diff-buffer fileinfo-to-diff)) - (setq buffer-read-only nil) - (setq default-directory local-def-directory) - (erase-buffer) - (insert (format "=== cd %s\n" default-directory)) - (insert (format "=== %s %s\n\n" - cvs-diff-program - (mapconcat 'cvs-quote-multiword-string - (nconc (copy-sequence cvs-diff-flags) - vendor-temp-files) - " "))) - (apply 'call-process cvs-diff-program nil t t - (nconc (copy-sequence cvs-diff-flags) vendor-temp-files)) - (goto-char (point-max)) - (message "vendor diff %s... Done." - (cvs-fileinfo->file-name fileinfo-to-diff)) - (while vendor-temp-files - (cvs-kill-buffer-visiting (car vendor-temp-files)) - (delete-file (car vendor-temp-files)) - (setq vendor-temp-files (cdr vendor-temp-files))) - (setq marked-file-list (cdr marked-file-list))))) - (message "vendor diff... Done.")) - -;;---------- -(defun cvs-backup-diffable (tin) - "Check if the TIN is backup-diffable. -It must have a backup file to be diffable." - - (file-readable-p - (cvs-fileinfo->backup-file (tin-cookie cvs-cookie-handle tin)))) - -;;---------- -(defun cvs-vendor-diffable (tin) - "Check if the TIN is vendor-diffable. -It must have head and base revision info to be diffable." - - (and - (cvs-fileinfo->base-revision (tin-cookie cvs-cookie-handle tin)) - (cvs-fileinfo->head-revision (tin-cookie cvs-cookie-handle tin)))) - -;;---------- -(defun cvs-diff-backup-extractor (fileinfo) - "Return the filename and the name of the backup file as a list. -Signal an error if there is no backup file." - - (if (not (file-readable-p (cvs-fileinfo->backup-file fileinfo))) - (error "%s has no backup file." - (concat - (file-name-as-directory (cvs-fileinfo->dir fileinfo)) - (cvs-fileinfo->file-name fileinfo)))) - (list (cvs-fileinfo->backup-file fileinfo) - (cvs-fileinfo->file-name fileinfo))) - -;;---------- -(defun cvs-diff-vendor-extractor (fileinfo) - "Retrieve and return the filenames of the vendor branch revisions as a list. -Signal an error if there is no info for the vendor revisions." - - (list (cvs-retrieve-revision-to-tmpfile fileinfo - (cvs-fileinfo->base-revision - fileinfo)) - (cvs-retrieve-revision-to-tmpfile fileinfo - (cvs-fileinfo->head-revision - fileinfo)))) - -;;---------- -(defun cvs-mode-find-file-other-window (pos) - "Select a buffer containing the file in another window. -Args: POS." - - (interactive "d") - (let ((tin (tin-locate cvs-cookie-handle pos))) - (if tin - (let ((type (cvs-fileinfo->type (tin-cookie cvs-cookie-handle tin)))) - (cond - ((or (eq type 'REMOVED) - (eq type 'CVS-REMOVED)) - (error "Can't visit a removed file.")) - ((eq type 'DIRCHANGE) - (let ((obuf (current-buffer)) - (odir default-directory)) - (setq default-directory - (file-name-as-directory - (cvs-fileinfo->dir - (tin-cookie cvs-cookie-handle tin)))) - (dired-other-window default-directory) - (set-buffer obuf) - (setq default-directory odir))) - (t - (find-file-other-window (cvs-full-path tin))))) - (error "There is no file to find.")))) - -;;---------- -(defun cvs-fileinfo->full-path (fileinfo) - "Return the full path for the file that is described in FILEINFO." - - (concat - (file-name-as-directory - (cvs-fileinfo->dir fileinfo)) - (cvs-fileinfo->file-name fileinfo))) - -;;---------- -(defun cvs-full-path (tin) - "Return the full path for the file that is described in TIN." - - (cvs-fileinfo->full-path (tin-cookie cvs-cookie-handle tin))) - -;;---------- -(defun cvs-mode-find-file (pos) - "Select a buffer containing the file in another window. -Args: POS." - - (interactive "d") - (let* ((cvs-buf (current-buffer)) - (tin (tin-locate cvs-cookie-handle pos))) - (if tin - (let* ((fileinfo (tin-cookie cvs-cookie-handle tin)) - (type (cvs-fileinfo->type fileinfo))) - (cond - ((or (eq type 'REMOVED) - (eq type 'CVS-REMOVED)) - (error "Can't visit a removed file.")) - ((eq type 'DIRCHANGE) - (let ((odir default-directory)) - (setq default-directory - (file-name-as-directory (cvs-fileinfo->dir fileinfo))) - (dired default-directory) - (set-buffer cvs-buf) - (setq default-directory odir))) - (t - (find-file (cvs-full-path tin))))) - (error "There is no file to find.")))) - -;;---------- -(defun cvs-mode-mark-all-files () - "Mark all files. -Directories are not marked." - - (interactive) - (cookie-map (function (lambda (cookie) - (cond - ((not (eq (cvs-fileinfo->type cookie) 'DIRCHANGE)) - (cvs-set-fileinfo->marked cookie t) - t)))) - cvs-cookie-handle)) - -;;---------- -(defun cvs-mode-unmark (pos) - "Unmark a fileinfo. -Args: POS." - - (interactive "d") - (let* ((tin (tin-locate cvs-cookie-handle pos)) - (sel (tin-cookie cvs-cookie-handle tin))) - (cond - ((eq (cvs-fileinfo->type sel) 'DIRCHANGE) - (cookie-map - (function (lambda (f dir) - (cond - ((cvs-dir-member-p f dir) - (cvs-set-fileinfo->marked f nil) - t)))) - cvs-cookie-handle - (cvs-fileinfo->dir sel))) - (t - (cvs-set-fileinfo->marked sel nil) - (tin-invalidate cvs-cookie-handle tin) - (tin-goto-next cvs-cookie-handle pos 1))))) - -;;---------- -(defun cvs-mode-unmark-all-files () - "Unmark all files. -Directories are also unmarked, but that doesn't matter, since -they should always be unmarked." - - (interactive) - (cookie-map (function (lambda (cookie) - (cvs-set-fileinfo->marked cookie nil) - t)) - cvs-cookie-handle)) - -;;---------- -(defun cvs-do-removal (tins) - "Remove files. -Args: TINS. - -TINS is a list of tins that the user wants to delete. The files are deleted. -If the type of the tin is 'UNKNOWN or 'UNKNOWN-DIR the tin is removed from the -buffer. If it is anything else the file is added to a list that should be `cvs -remove'd and the tin is changed to be of type 'REMOVED. - -Returns a list of tins files that should be `cvs remove'd." - - (cvs-use-temp-buffer) - (mapcar 'cvs-insert-full-path tins) - (cond - ((and tins (yes-or-no-p (format "Delete %d files? " (length tins)))) - (let (files-to-remove) - (while tins - (let* ((tin (car tins)) - (fileinfo (tin-cookie cvs-cookie-handle tin)) - (filepath (cvs-full-path tin)) - (type (cvs-fileinfo->type fileinfo))) - (if (or (eq type 'REMOVED) - (eq type 'CVS-REMOVED)) - nil - ;; if it doesn't exist, as a file or directory, ignore it - (cond ((file-directory-p filepath) - (call-process cvs-rmdir-program nil nil nil filepath)) - ((file-exists-p filepath) - (delete-file filepath))) - (if (or (eq type 'UNKNOWN) - (eq type 'UNKNOWN-DIR) - (eq type 'MOVE-AWAY)) - (tin-delete cvs-cookie-handle tin) - (setq files-to-remove (cons tin files-to-remove)) - (cvs-set-fileinfo->type fileinfo 'REMOVED) - (cvs-set-fileinfo->handled fileinfo nil) - (tin-invalidate cvs-cookie-handle tin)))) - (setq tins (cdr tins))) - files-to-remove)) - (t nil))) - -;;---------- -(defun cvs-mode-remove-file () - "Remove all marked files." - - (interactive) - (let ((files-to-remove (cvs-do-removal (cvs-get-marked)))) - (if (null files-to-remove) - nil - (cvs-use-temp-buffer) - (message "removing from repository...") - (if (cvs-execute-list files-to-remove cvs-program - (if cvs-cvsroot - (list "-d" cvs-cvsroot "remove") - '("remove")) - "removing %s from repository...") - (error "CVS exited with non-zero exit status.") - (message "removing from repository... Done."))))) - -;;---------- -(defun cvs-mode-undo-local-changes () - "Undo local changes to all marked files. -The file is removed and `cvs update FILE' is run." - - (interactive) - (let ((tins-to-undo (cvs-get-marked))) - (cvs-use-temp-buffer) - (mapcar 'cvs-insert-full-path tins-to-undo) - (cond - ((and tins-to-undo (yes-or-no-p (format "Undo changes to %d files? " - (length tins-to-undo)))) - (let (files-to-update) - (while tins-to-undo - (let* ((tin (car tins-to-undo)) - (fileinfo (tin-cookie cvs-cookie-handle tin)) - (type (cvs-fileinfo->type fileinfo))) - (cond - ((or - (eq type 'UPDATED) - (eq type 'PATCHED) - (eq type 'MODIFIED) - (eq type 'MERGED) - (eq type 'CONFLICT) - (eq type 'CVS-REMOVED) - (eq type 'REM-CONFLICT) - (eq type 'MOVE-AWAY) - (eq type 'REMOVED)) - (if (not (eq type 'REMOVED)) - (delete-file (cvs-full-path tin))) - (setq files-to-update (cons tin files-to-update)) - (cvs-set-fileinfo->type fileinfo 'UPDATED) - (cvs-set-fileinfo->handled fileinfo t) - (tin-invalidate cvs-cookie-handle tin)) - - ((eq type 'MOD-CONFLICT) - (error "Use cvs-mode-add instead on %s." - (cvs-fileinfo->file-name fileinfo))) - - ((eq type 'REM-CONFLICT) - (error "Can't deal with a file you have removed and recreated.")) - - ((eq type 'DIRCHANGE) - (error "Undo on directories not supported (yet).")) - - ((eq type 'ADDED) - (error "There is no old revision to get for %s" - (cvs-fileinfo->file-name fileinfo))) - (t (error "cvs-mode-undo-local-changes: can't handle an %s" - type))) - - (setq tins-to-undo (cdr tins-to-undo)))) - (cvs-use-temp-buffer) - (message "Re-getting files from repository...") - (if (cvs-execute-list files-to-update cvs-program - (if cvs-cvsroot - (list "-d" cvs-cvsroot "update") - '("update")) - "Re-getting %s from repository...") - (error "CVS exited with non-zero exit status.") - (message "Re-getting files from repository... Done."))))))) - -;;---------- -(defun cvs-mode-acknowledge () - "Remove all marked files from the buffer." - - (interactive) - (mapcar (function (lambda (tin) - (tin-delete cvs-cookie-handle tin))) - (cvs-get-marked))) - -;;---------- -(defun cvs-mode-unmark-up (pos) - "Unmark the file on the previous line. -Takes one argument POS, a buffer position." - - (interactive "d") - (let ((tin (tin-goto-previous cvs-cookie-handle pos 1))) - (cond - (tin - (cvs-set-fileinfo->marked (tin-cookie cvs-cookie-handle tin) - nil) - (tin-invalidate cvs-cookie-handle tin))))) - -;;---------- -(defun cvs-mode-previous-line (arg) - "Go to the previous line. -If a prefix argument is given, move by that many lines." - - (interactive "p") - (tin-goto-previous cvs-cookie-handle (point) arg)) - -;;---------- -(defun cvs-mode-next-line (arg) - "Go to the next line. -If a prefix argument is given, move by that many lines." - - (interactive "p") - (tin-goto-next cvs-cookie-handle (point) arg)) - -;;---------- -(defun cvs-add-file-update-buffer (tin) - "Sub-function to cvs-mode-add. Internal use only. Update the display. Return -non-nil if `cvs add' should be called on this file. -Args: TIN. - -Returns 'DIR, 'ADD, 'ADD-DIR, or 'RESURRECT." - - (let ((fileinfo (tin-cookie cvs-cookie-handle tin))) - (cond - ((eq (cvs-fileinfo->type fileinfo) 'UNKNOWN-DIR) - (cvs-set-fileinfo->full-log fileinfo "new directory added with cvs-mode-add") - 'ADD-DIR) - ((eq (cvs-fileinfo->type fileinfo) 'UNKNOWN) - (cvs-set-fileinfo->type fileinfo 'ADDED) - (cvs-set-fileinfo->full-log fileinfo "new file added with cvs-mode-add") - (tin-invalidate cvs-cookie-handle tin) - 'ADD) - ((eq (cvs-fileinfo->type fileinfo) 'REMOVED) - (cvs-set-fileinfo->type fileinfo 'UPDATED) - (cvs-set-fileinfo->full-log fileinfo "file resurrected with cvs-mode-add") - (cvs-set-fileinfo->handled fileinfo t) - (tin-invalidate cvs-cookie-handle tin) - 'RESURRECT)))) - -;;---------- -(defun cvs-add-sub (cvs-buf candidates) - "Internal use only. -Args: CVS-BUF CANDIDATES. - -CANDIDATES is a list of tins. Updates the CVS-BUF and returns a list of lists. -The first list is unknown tins that shall be `cvs add -m msg'ed. -The second list is unknown directory tins that shall be `cvs add -m msg'ed. -The third list is removed files that shall be `cvs add'ed (resurrected)." - - (let (add add-dir resurrect) - (while candidates - (let ((type (cvs-add-file-update-buffer (car candidates)))) - (cond ((eq type 'ADD) - (setq add (cons (car candidates) add))) - ((eq type 'ADD-DIR) - (setq add-dir (cons (car candidates) add-dir))) - ((eq type 'RESURRECT) - (setq resurrect (cons (car candidates) resurrect))))) - (setq candidates (cdr candidates))) - (list add add-dir resurrect))) - -;;---------- -(defun cvs-mode-add () - "Add marked files to the cvs repository." - - (interactive) - (let* ((buf (current-buffer)) - (marked (cvs-get-marked)) - (result (cvs-add-sub buf marked)) - (added (car result)) - (newdirs (car (cdr result))) - (resurrect (car (cdr (cdr result)))) - (msg (if (or added newdirs) - (read-from-minibuffer "Enter description: ")))) - - (if (or resurrect (or added newdirs)) - (cvs-use-temp-buffer)) - - (cond (resurrect - (message "Resurrecting files from repository...") - (if (cvs-execute-list resurrect - cvs-program - (if cvs-cvsroot - (list "-d" cvs-cvsroot "add") - '("add")) - "Resurrecting %s from repository...") - (error "CVS exited with non-zero exit status.") - (message "Resurrecting files from repository... Done.")))) - - (cond (added - (message "Adding new files to repository...") - (if (cvs-execute-list added - cvs-program - (if cvs-cvsroot - (list "-d" cvs-cvsroot "add" "-m" msg) - (list "add" "-m" msg)) - "Adding %s to repository...") - (error "CVS exited with non-zero exit status.") - (message "Adding new files to repository... Done.")))) - - (cond (newdirs - (message "Adding new directories to repository...") - (if (cvs-execute-list newdirs - cvs-program - (if cvs-cvsroot - (list "-d" cvs-cvsroot "add" "-m" msg) - (list "add" "-m" msg)) - "Adding %s to repository...") - (error "CVS exited with non-zero exit status.") - (while newdirs - (let* ((tin (car newdirs)) - (fileinfo (tin-cookie cvs-cookie-handle tin)) - (newdir (cvs-fileinfo->file-name fileinfo))) - (cvs-set-fileinfo->dir fileinfo - (concat (cvs-fileinfo->dir fileinfo) - "/" - newdir)) - (cvs-set-fileinfo->type fileinfo 'DIRCHANGE) - (cvs-set-fileinfo->file-name fileinfo ".") - (tin-invalidate cvs-cookie-handle tin) - (setq newdirs (cdr newdirs)))) - ;; FIXME: this should really run cvs-update-no-prompt on the - ;; subdir and insert everthing in the current list. - (message "You must re-update to visit the new directories.")))))) - -;;---------- -(defun cvs-mode-ignore () - "Arrange so that CVS ignores the selected files and directories. -This command ignores files/dirs that are flagged as `Unknown'." - - (interactive) - (mapcar (function (lambda (tin) - (let* ((fileinfo (tin-cookie cvs-cookie-handle tin)) - (type (cvs-fileinfo->type fileinfo))) - (cond ((or (eq type 'UNKNOWN) - (eq type 'UNKNOWN-DIR)) - (cvs-append-to-ignore fileinfo) - (tin-delete cvs-cookie-handle tin)))))) - (cvs-get-marked))) - -;;---------- -(defun cvs-append-to-ignore (fileinfo) - "Append the file in fileinfo to the .cvsignore file" - - (save-window-excursion - (set-buffer (find-file-noselect (concat (file-name-as-directory - (cvs-fileinfo->dir fileinfo)) - ".cvsignore"))) - (goto-char (point-max)) - (if (not (zerop (current-column))) - (insert "\n")) - (insert (cvs-fileinfo->file-name fileinfo) "\n") - (if cvs-sort-ignore-file - (sort-lines nil (point-min) (point-max))) - (save-buffer))) - -;;---------- -(defun cvs-mode-status () - "Show cvs status for all marked files." - - (interactive) - (save-some-buffers) - (if (not (listp cvs-status-flags)) - (error "cvs-status-flags should be set using cvs-set-status-flags.")) - (let ((marked (cvs-get-marked nil t))) - (cvs-use-temp-buffer) - (message "Running cvs status ...") - (if (cvs-execute-list marked - cvs-program - (append (if cvs-cvsroot (list "-d" cvs-cvsroot)) - (list "-Q" "status") - cvs-status-flags) - "Running cvs -Q status %s...") - (error "CVS exited with non-zero exit status.") - (message "Running cvs -Q status ... Done.")))) - -;;---------- -(defun cvs-mode-log () - "Display the cvs log of all selected files." - - (interactive) - (if (not (listp cvs-log-flags)) - (error "cvs-log-flags should be set using cvs-set-log-flags.")) - (let ((marked (cvs-get-marked nil t))) - (cvs-use-temp-buffer) - (message "Running cvs log ...") - (if (cvs-execute-list marked - cvs-program - (append (if cvs-cvsroot (list "-d" cvs-cvsroot)) - (list "log") - cvs-log-flags) - "Running cvs log %s...") - (error "CVS exited with non-zero exit status.") - (message "Running cvs log ... Done.")))) - -;;---------- -(defun cvs-mode-tag () - "Run 'cvs tag' on all selected files." - - (interactive) - (if (not (listp cvs-tag-flags)) - (error "cvs-tag-flags should be set using cvs-set-tag-flags.")) - (let ((marked (cvs-get-marked nil t)) - (tag-args (cvs-make-list (read-string "Tag name (and flags): ")))) - (cvs-use-temp-buffer) - (message "Running cvs tag ...") - (if (cvs-execute-list marked - cvs-program - (append (if cvs-cvsroot (list "-d" cvs-cvsroot)) - (list "tag") - cvs-tag-flags - tag-args) - "Running cvs tag %s...") - (error "CVS exited with non-zero exit status.") - (message "Running cvs tag ... Done.")))) - -;;---------- -(defun cvs-mode-rtag () - "Run 'cvs rtag' on all selected files." - - (interactive) - (if (not (listp cvs-rtag-flags)) - (error "cvs-rtag-flags should be set using cvs-set-rtag-flags.")) - (let ((marked (cvs-get-marked nil t)) - ;; FIXME: should give selection from the modules file - (module-name (read-string "Module name: ")) - ;; FIXME: should also ask for an existing tag *or* date - (rtag-args (cvs-make-list (read-string "Tag name (and flags): ")))) - (cvs-use-temp-buffer) - (message "Running cvs rtag ...") - (if (cvs-execute-list marked - cvs-program - (append (if cvs-cvsroot (list "-d" cvs-cvsroot)) - (list "rtag") - cvs-rtag-flags - rtag-args - (list module-name)) - "Running cvs rtag %s...") - (error "CVS rtag exited with non-zero exit status.") - (message "Running cvs rtag ... Done.")))) - -;;---------- -(defun cvs-mode-byte-compile-files () - "Run byte-compile-file on all selected files that end in '.el'." - - (interactive) - (let ((marked (cvs-get-marked))) - (while marked - (let ((filename (cvs-full-path (car marked)))) - (if (string-match "\\.el$" filename) - (byte-compile-file filename))) - (setq marked (cdr marked))))) - -;;---------- -(defun cvs-insert-full-path (tin) - "Insert full path to the file described in TIN in the current buffer." - - (insert (format "%s\n" (cvs-full-path tin)))) - -;;---------- -(defun cvs-mode-add-change-log-entry-other-window (pos) - "Add a ChangeLog entry in the ChangeLog of the current directory. -Args: POS." - - (interactive "d") - (let* ((cvs-buf (current-buffer)) - (odir default-directory) - (obfname buffer-file-name) - (tin (tin-locate cvs-cookie-handle pos)) - (fileinfo (tin-cookie cvs-cookie-handle tin)) - (fname (cvs-fileinfo->file-name fileinfo)) - (dname (file-name-as-directory (cvs-fileinfo->dir fileinfo)))) - (setq change-log-default-name nil) ; this rarely correct in 19.28 - (setq buffer-file-name (cond (fname - fname) - (t - nil))) - (setq default-directory (cond (dname - dname) - (t - odir))) - (add-change-log-entry-other-window) - (set-buffer cvs-buf) - (setq default-directory odir) - (setq buffer-file-name obfname))) - -;;---------- -(defun print-cvs-tin (foo) - "Debug utility." - - (let ((cookie (tin-cookie cvs-cookie-handle foo)) - (stream (get-buffer-create "pcl-cvs-debug"))) - (princ "==============\n" stream) - (princ (cvs-fileinfo->file-name cookie) stream) - (princ "\n" stream) - (princ (cvs-fileinfo->dir cookie) stream) - (princ "\n" stream) - (princ (cvs-fileinfo->full-log cookie) stream) - (princ "\n" stream) - (princ (cvs-fileinfo->marked cookie) stream) - (princ "\n" stream))) - -;;---------- -;; NOTE: the variable cvs-emerge-tmp-head-file will be "free" when compiling -(defun cvs-mode-emerge (pos) - "Emerge appropriate revisions of the selected file. -Args: POS." - - (interactive "d") - (let* ((cvs-buf (current-buffer)) - (tin (tin-locate cvs-cookie-handle pos))) - (if (boundp 'cvs-emerge-tmp-head-file) - (error "There can only be one emerge session active at a time.")) - (if tin - (let* ((fileinfo (tin-cookie cvs-cookie-handle tin)) - (type (cvs-fileinfo->type fileinfo))) - (cond - ((eq type 'MODIFIED) ; merge repository head rev. with working file - (require 'emerge) - (setq cvs-emerge-tmp-head-file ; trick to prevent multiple runs - (cvs-retrieve-revision-to-tmpfile fileinfo)) - (unwind-protect - (if (not (emerge-files - t ; arg - (cvs-fileinfo->full-path fileinfo) ; file-A - ;; this is an un-avoidable compiler reference to a free variable - cvs-emerge-tmp-head-file ; file-B - (cvs-fileinfo->full-path fileinfo) ; file-out - nil ; start-hooks - '(lambda () ; quit-hooks - (delete-file cvs-emerge-tmp-head-file) - (makunbound 'cvs-emerge-tmp-head-file)))) - (error "Emerge session failed")))) - - ;; re-do the same merge rcsmerge supposedly just did.... - ((or (eq type 'MERGED) - (eq type 'CONFLICT)) ; merge backup-working=A, head=B, base=ancestor - (require 'emerge) - (setq cvs-emerge-tmp-head-file ; trick to prevent multiple runs - (cvs-retrieve-revision-to-tmpfile fileinfo - (cvs-fileinfo->head-revision - fileinfo))) - (let ((cvs-emerge-tmp-backup-working-file - (cvs-fileinfo->backup-file fileinfo)) - (cvs-emerge-tmp-ancestor-file - (cvs-retrieve-revision-to-tmpfile fileinfo - (cvs-fileinfo->base-revision - fileinfo)))) - (unwind-protect - (if (not (emerge-files-with-ancestor - t ; arg - cvs-emerge-tmp-backup-working-file ; file-A - ;; this is an un-avoidable compiler reference to a free variable - cvs-emerge-tmp-head-file ; file-B - cvs-emerge-tmp-ancestor-file ; file-ancestor - (cvs-fileinfo->full-path fileinfo) ; file-out - nil ; start-hooks - '(lambda () ; quit-hooks - (delete-file cvs-emerge-tmp-backup-file) - (delete-file cvs-emerge-tmp-ancestor-file) - (delete-file cvs-emerge-tmp-head-file) - (makunbound 'cvs-emerge-tmp-head-file)))) - (error "Emerge session failed"))))) - (t - (error "Can only e-merge \"Modified\", \"Merged\" or \"Conflict\" files")))) - (error "There is no file to e-merge.")))) - -;;---------- -;; NOTE: the variable ediff-version may be "free" when compiling -(defun cvs-mode-ediff (pos) - "Ediff appropriate revisions of the selected file. -Args: POS." - - (interactive "d") - (if (boundp 'cvs-ediff-tmp-head-file) - (error "There can only be one ediff session active at a time.")) - (require 'ediff) - (if (and (boundp 'ediff-version) - (>= (string-to-number ediff-version) 2.0)) ; FIXME real number? - (run-ediff-from-cvs-buffer pos) - (cvs-old-ediff-interface pos))) - -(defun cvs-old-ediff-interface (pos) - "Emerge like interface for older ediffs. -Args: POS" - - (let* ((cvs-buf (current-buffer)) - (tin (tin-locate cvs-cookie-handle pos))) - (if tin - (let* ((fileinfo (tin-cookie cvs-cookie-handle tin)) - (type (cvs-fileinfo->type fileinfo))) - (cond - ((eq type 'MODIFIED) ; diff repository head rev. with working file - ;; should this be inside the unwind-protect, and should the - ;; makeunbound be an unwindform? - (setq cvs-ediff-tmp-head-file ; trick to prevent multiple runs - (cvs-retrieve-revision-to-tmpfile fileinfo)) - (unwind-protect - (if (not (ediff-files ; check correct ordering of args - (cvs-fileinfo->full-path fileinfo) ; file-A - ;; this is an un-avoidable compiler reference to a free variable - cvs-ediff-tmp-head-file ; file-B - '(lambda () ; startup-hooks - (make-local-hook 'ediff-cleanup-hooks) - (add-hook 'ediff-cleanup-hooks - '(lambda () - (ediff-janitor) - (delete-file cvs-ediff-tmp-head-file) - (makunbound 'cvs-ediff-tmp-head-file)) - nil t)))) - (error "Ediff session failed")))) - - ;; look at the merge rcsmerge supposedly just did.... - ((or (eq type 'MERGED) - (eq type 'CONFLICT)) ; diff backup-working=A, head=B, base=ancestor - (if (not (boundp 'ediff-version)) - (error "ediff version way too old for 3-way diff")) - (if (<= (string-to-number ediff-version) 1.9) ; FIXME real number? - (error "ediff version %s too old for 3-way diff" ediff-version)) - (setq cvs-ediff-tmp-head-file ; trick to prevent multiple runs - (cvs-retrieve-revision-to-tmpfile fileinfo - (cvs-fileinfo->head-revision - fileinfo))) - (let ((cvs-ediff-tmp-backup-working-file - (cvs-fileinfo->backup-file fileinfo)) - (cvs-ediff-tmp-ancestor-file - (cvs-retrieve-revision-to-tmpfile fileinfo - (cvs-fileinfo->base-revision - fileinfo)))) - (unwind-protect - (if (not (ediff-files3 ; check correct ordering of args - cvs-ediff-tmp-backup-working-file ; file-A - ;; this is an un-avoidable compiler reference to a free variable - cvs-ediff-tmp-head-file ; file-B - cvs-ediff-tmp-ancestor-file ; file-ancestor - '(lambda () ; start-hooks - (make-local-hook 'ediff-cleanup-hooks) - (add-hook 'ediff-cleanup-hooks - '(lambda () - (ediff-janitor) - (delete-file cvs-ediff-tmp-backup-file) - (delete-file cvs-ediff-tmp-ancestor-file) - (delete-file cvs-ediff-tmp-head-file) - (makunbound 'cvs-ediff-tmp-head-file)) - nil t)))) - (error "Ediff session failed"))))) - - ((not (or (eq type 'UNKNOWN) - (eq type 'UNKNOWN-DIR))) ; i.e. UPDATED or PATCHED ???? - ;; this should really diff the current working file with the previous - ;; rev. on the current branch (i.e. not the head, since that's what - ;; the current file should be) - (setq cvs-ediff-tmp-head-file ; trick to prevent multiple runs - (cvs-retrieve-revision-to-tmpfile fileinfo - (read-string "Rev #/tag to diff against: " - (cvs-fileinfo->head-revision - fileinfo)))) - (unwind-protect - (if (not (ediff-files ; check correct ordering of args - (cvs-fileinfo->full-path fileinfo) ; file-A - ;; this is an un-avoidable compiler reference to a free variable - cvs-ediff-tmp-head-file ; file-B - '(lambda () ; startup-hooks - (make-local-hook 'ediff-cleanup-hooks) - (add-hook 'ediff-cleanup-hooks - '(lambda () - (ediff-janitor) - (delete-file cvs-ediff-tmp-head-file) - (makunbound 'cvs-ediff-tmp-head-file)) - nil t)))) - (error "Ediff session failed")))) - (t - (error "Can not ediff \"Unknown\" files")))) - (error "There is no file to ediff.")))) - -;;---------- -(defun cvs-retrieve-revision-to-tmpfile (fileinfo &optional revision) - "Retrieve the latest revision of the file in FILEINFO to a temporary file. -If second optional argument REVISION is given, retrieve that revision instead." - - (let - ((temp-name (make-temp-name - (concat (file-name-as-directory - (or (getenv "TMPDIR") "/tmp")) - "pcl-cvs." revision)))) - (cvs-kill-buffer-visiting temp-name) - (if (and revision - (stringp revision) - (not (string= revision ""))) - (message "Retrieving revision %s..." revision) - (message "Retrieving latest revision...")) - (let ((res (call-process cvs-shell nil nil nil "-c" - (concat cvs-program " update -p " - (if (and revision - (stringp revision) - (not (string= revision ""))) - (concat "-r " revision " ") - "") - (cvs-fileinfo->full-path fileinfo) - " > " temp-name)))) - (if (and res (not (and (integerp res) (zerop res)))) - (error "Something went wrong retrieving revision %s: %s" - revision res)) - - (if revision - (message "Retrieving revision %s... Done." revision) - (message "Retrieving latest revision... Done.")) - (save-excursion - (set-buffer (find-file-noselect temp-name)) - (rename-buffer (concat " " (file-name-nondirectory temp-name)) t)) - temp-name))) - -;;---------- -(defun cvs-kill-buffer-visiting (filename) - "If there is any buffer visiting FILENAME, kill it (without confirmation)." - - (let ((l (buffer-list))) - (while l - (if (string= (buffer-file-name (car l)) filename) - (kill-buffer (car l))) - (setq l (cdr l))))) - -;;---------- -(defun cvs-change-cvsroot () - "Ask for a new cvsroot." - - (interactive) - (cvs-set-cvsroot (read-file-name "New CVSROOT: " cvs-cvsroot))) - -;;---------- -(defun cvs-set-cvsroot (newroot) - "Change the cvsroot." - - (if (or (file-directory-p (expand-file-name "CVSROOT" newroot)) - (y-or-n-p (concat "Warning: no CVSROOT found inside repository." - " Change cvs-cvsroot anyhow?"))) - (setq cvs-cvsroot newroot))) - -;;---------- -(defun cvs-set-diff-flags () - "Ask for new setting of cvs-diff-flags." - - (interactive) - (let ((old-value (mapconcat 'identity - (copy-sequence cvs-diff-flags) " "))) - (setq cvs-diff-flags - (cvs-make-list (read-string "Diff flags: " old-value))))) - -;;---------- -(defun cvs-set-update-optional-flags () - "Ask for new setting of cvs-update-optional-flags." - - (interactive) - (let ((old-value (mapconcat 'identity - (copy-sequence cvs-update-optional-flags) " "))) - (setq cvs-update-optional-flags - (cvs-make-list (read-string "Update optional flags: " old-value))))) - -;;---------- -(defun cvs-set-status-flags () - "Ask for new setting of cvs-status-flags." - - (interactive) - (let ((old-value (mapconcat 'identity - (copy-sequence cvs-status-flags) " "))) - (setq cvs-status-flags - (cvs-make-list (read-string "Status flags: " old-value))))) - -;;---------- -(defun cvs-set-log-flags () - "Ask for new setting of cvs-log-flags." - - (interactive) - (let ((old-value (mapconcat 'identity - (copy-sequence cvs-log-flags) " "))) - (setq cvs-log-flags - (cvs-make-list (read-string "Log flags: " old-value))))) - -;;---------- -(defun cvs-set-tag-flags () - "Ask for new setting of cvs-tag-flags." - - (interactive) - (let ((old-value (mapconcat 'identity - (copy-sequence cvs-tag-flags) " "))) - (setq cvs-tag-flags - (cvs-make-list (read-string "Tag flags: " old-value))))) - -;;---------- -(defun cvs-set-rtag-flags () - "Ask for new setting of cvs-rtag-flags." - - (interactive) - (let ((old-value (mapconcat 'identity - (copy-sequence cvs-rtag-flags) " "))) - (setq cvs-rtag-flags - (cvs-make-list (read-string "Rtag flags: " old-value))))) - -;;---------- -(if (string-match "XEmacs" emacs-version) - (progn - ;; now marked to autload in pcl-cvs-xemacs - ;(autoload 'pcl-cvs-fontify "pcl-cvs-xemacs") - (add-hook 'cvs-mode-hook 'pcl-cvs-fontify))) - -(defun cvs-changelog-name (directory) - "Return the name of the ChangeLog file that handles DIRECTORY. -This is in DIRECTORY or one of its parents. -Signal an error if we can't find an appropriate ChangeLog file." - (let ((dir (file-name-as-directory directory)) - file) - (while (and dir - (not (file-exists-p - (setq file (expand-file-name "ChangeLog" dir))))) - (let ((last dir)) - (setq dir (file-name-directory (directory-file-name dir))) - (if (equal last dir) - (setq dir nil)))) - (or dir - (error "Can't find ChangeLog for %s" directory)) - file)) - -(defun cvs-narrow-changelog () - "Narrow to the top page of the current buffer, a ChangeLog file. -Actually, the narrowed region doesn't include the date line. -A \"page\" in a ChangeLog file is the area between two dates." - (or (eq major-mode 'change-log-mode) - (error "cvs-narrow-changelog: current buffer isn't a ChangeLog")) - - (goto-char (point-min)) - - ;; Skip date line and subsequent blank lines. - (forward-line 1) - (if (looking-at "[ \t\n]*\n") - (goto-char (match-end 0))) - - (let ((start (point))) - (forward-page 1) - (narrow-to-region start (point)) - (goto-char (point-min)))) - -(defun cvs-changelog-paragraph () - "Return the bounds of the ChangeLog paragraph containing point. -If we are between paragraphs, return the previous paragraph." - (save-excursion - (beginning-of-line) - (if (looking-at "^[ \t]*$") - (skip-chars-backward " \t\n" (point-min))) - (list (progn - (if (re-search-backward "^[ \t]*\n" nil 'or-to-limit) - (goto-char (match-end 0))) - (point)) - (if (re-search-forward "^[ \t\n]*$" nil t) - (match-beginning 0) - (point))))) - -(defun cvs-changelog-subparagraph () - "Return the bounds of the ChangeLog subparagraph containing point. -A subparagraph is a block of non-blank lines beginning with an asterisk. -If we are between sub-paragraphs, return the previous subparagraph." - (save-excursion - (end-of-line) - (if (search-backward "*" nil t) - (list (progn (beginning-of-line) (point)) - (progn - (forward-line 1) - (if (re-search-forward "^[ \t]*[\n*]" nil t) - (match-beginning 0) - (point-max)))) - (list (point) (point))))) - -(defun cvs-changelog-entry () - "Return the bounds of the ChangeLog entry containing point. -The variable `cvs-changelog-full-paragraphs' decides whether an -\"entry\" is a paragraph or a subparagraph; see its documentation string -for more details." - (if cvs-changelog-full-paragraphs - (cvs-changelog-paragraph) - (cvs-changelog-subparagraph))) - -;; NOTE: the variable user-full-name may be "free" when compiling -(defun cvs-changelog-ours-p () - "See if ChangeLog entry at point is for the current user, today. -Return non-nil iff it is." - ;; Code adapted from add-change-log-entry. - (or (looking-at (concat (regexp-quote (substring (current-time-string) - 0 10)) - ".* " - (regexp-quote (substring (current-time-string) -4)) - "[ \t]+" - (regexp-quote (if (and (boundp 'add-log-full-name) - add-log-full-name) - add-log-full-name - (or (and (boundp 'user-full-name) - user-full-name) - (user-full-name)))) - " <" - (regexp-quote (if (and - (boundp 'add-log-mailing-address) - add-log-mailing-address) - add-log-mailing-address - (user-mail-address))))) - ;; New ChangeLog format (as of XEmacs 20.3) - (looking-at (concat (funcall add-log-time-format) - "[ \t]+" - (regexp-quote (if (and (boundp 'add-log-full-name) - add-log-full-name) - add-log-full-name - (or (and (boundp 'user-full-name) - user-full-name) - (user-full-name)))) - " *<" - (regexp-quote (if (and - (boundp 'add-log-mailing-address) - add-log-mailing-address) - add-log-mailing-address - (user-mail-address))))))) - - - -(defun cvs-relative-path (base child) - "Return a directory path relative to BASE for CHILD. -If CHILD doesn't seem to be in a subdirectory of BASE, just return -the full path to CHILD." - (let ((base (file-name-as-directory (expand-file-name base))) - (child (expand-file-name child))) - (or (string= base (substring child 0 (length base))) - (error "cvs-relative-path: %s isn't in %s" child base)) - (substring child (length base)))) - -(defun cvs-changelog-entries (file) - "Return the ChangeLog entries for FILE, and the ChangeLog they came from. -The return value looks like this: - (LOGBUFFER (ENTRYSTART . ENTRYEND) ...) -where LOGBUFFER is the name of the ChangeLog buffer, and each -\(ENTRYSTART . ENTRYEND\) pair is a buffer region." - (save-excursion - (set-buffer (find-file-noselect - (cvs-changelog-name - (file-name-directory - (expand-file-name file))))) - (or (eq major-mode 'change-log-mode) - (change-log-mode)) - (goto-char (point-min)) - (if (looking-at "[ \t\n]*\n") - (goto-char (match-end 0))) - (if (not (cvs-changelog-ours-p)) - (list (current-buffer)) - (save-restriction - (cvs-narrow-changelog) - (goto-char (point-min)) - - ;; Search for the name of FILE relative to the ChangeLog. If that - ;; doesn't occur anywhere, they're not using full relative - ;; filenames in the ChangeLog, so just look for FILE; we'll accept - ;; some false positives. - (let ((pattern (cvs-relative-path - (file-name-directory buffer-file-name) file))) - (if (or (string= pattern "") - (not (save-excursion - (search-forward pattern nil t)))) - (setq pattern file)) - - (let (texts) - (while (search-forward pattern nil t) - (let ((entry (cvs-changelog-entry))) - (setq texts (cons entry texts)) - (goto-char (elt entry 1)))) - - (cons (current-buffer) texts))))))) - -(defun cvs-changelog-insert-entries (buffer regions) - "Insert those regions in BUFFER specified in REGIONS. -Sort REGIONS front-to-back first." - (let ((regions (sort regions 'car-less-than-car)) - (last)) - (while regions - (if (and last (< last (car (car regions)))) - (newline)) - (setq last (elt (car regions) 1)) - (apply 'insert-buffer-substring buffer (car regions)) - (setq regions (cdr regions))))) - -(defun cvs-union (set1 set2) - "Return the union of SET1 and SET2, according to `equal'." - (while set2 - (or (member (car set2) set1) - (setq set1 (cons (car set2) set1))) - (setq set2 (cdr set2))) - set1) - -(defun cvs-insert-changelog-entries (files) - "Given a list of files FILES, insert the ChangeLog entries for them." - (let ((buffer-entries nil)) - - ;; Add each buffer to buffer-entries, and associate it with the list - ;; of entries we want from that file. - (while files - (let* ((entries (cvs-changelog-entries (car files))) - (pair (assq (car entries) buffer-entries))) - (if pair - (setcdr pair (cvs-union (cdr pair) (cdr entries))) - (setq buffer-entries (cons entries buffer-entries)))) - (setq files (cdr files))) - - ;; Now map over each buffer in buffer-entries, sort the entries for - ;; each buffer, and extract them as strings. - (while buffer-entries - (cvs-changelog-insert-entries (car (car buffer-entries)) - (cdr (car buffer-entries))) - (if (and (cdr buffer-entries) (cdr (car buffer-entries))) - (newline)) - (setq buffer-entries (cdr buffer-entries))))) - -(defun cvs-edit-delete-common-indentation () - "Unindent the current buffer rigidly until at least one line is flush left." - (save-excursion - (let ((common 100000)) - (goto-char (point-min)) - (while (< (point) (point-max)) - (if (not (looking-at "^[ \t]*$")) - (setq common (min common (current-indentation)))) - (forward-line 1)) - (indent-rigidly (point-min) (point-max) (- common))))) - -(defun cvs-mode-changelog-commit () - "Check in all marked files, or the current file. -Ask the user for a log message in a buffer. - -This is just like `\\[cvs-mode-commit]', except that it tries to provide -appropriate default log messages by looking at the ChangeLog. The -idea is to write your ChangeLog entries first, and then use this -command to commit your changes. - -To select default log text, we: -- find the ChangeLog entries for the files to be checked in, -- verify that the top entry in the ChangeLog is on the current date - and by the current user; if not, we don't provide any default text, -- search the ChangeLog entry for paragraphs containing the names of - the files we're checking in, and finally -- use those paragraphs as the log text." - - (interactive) - - (let* ((cvs-buf (current-buffer)) - (marked (cvs-filter (function cvs-committable) - (cvs-get-marked)))) - (if (null marked) - (error "Nothing to commit!") - (pop-to-buffer (get-buffer-create cvs-commit-prompt-buffer)) - (goto-char (point-min)) - - (erase-buffer) - (cvs-insert-changelog-entries - (mapcar (lambda (tin) - (let ((cookie (tin-cookie cvs-cookie-handle tin))) - (expand-file-name - (cvs-fileinfo->file-name cookie) - (cvs-fileinfo->dir cookie)))) - marked)) - (cvs-edit-delete-common-indentation) - - (cvs-edit-mode) - (make-local-variable 'cvs-commit-list) - (setq cvs-commit-list marked) - (message "Press C-c C-c when you are done editing.")))) - -(provide 'pcl-cvs) - -;;; pcl-cvs.el ends here
--- a/lisp/prim/about.el Mon Aug 13 10:03:54 2007 +0200 +++ b/lisp/prim/about.el Mon Aug 13 10:04:58 2007 +0200 @@ -195,7 +195,9 @@ (interactive) (unless (about-get-buffer "*About XEmacs*") (widget-insert (about-center xemacs-logo)) - (widget-create 'default :format "%t" :tag-glyph xemacs-logo) + (widget-create 'default + :format "%t" + :tag-glyph xemacs-logo) (widget-insert "\n") (let* ((emacs-short-version (concat emacs-major-version "." emacs-minor-version)) @@ -546,14 +548,18 @@ (setq glyph (cond ((stringp data) (make-glyph - (list (vector 'xpm :data data) - (vector 'string :data "[Image]")))) + (if (featurep 'xpm) + `([xpm :data ,data] + [string :data "[Image]"]) + `([string :data "[Image]"])))) ((eq data 'error) (make-glyph [string :data "[Error]"])) (file (make-glyph - (list (vector 'xpm :file file) - (vector 'string :data "[Image]")))) + (if (featurep 'xbm) + `([xbm :data ,data] + [string :data "[Image]"]) + `([string :data "[Image]"])))) (t (make-glyph [nothing])))) (set-glyph-property glyph 'baseline 100) @@ -1303,6 +1309,7 @@ (print-short "Pekka Marjola" "pema@iki.fi") (print-short "Simon Marshall" "simon@gnu.ai.mit.edu") (print-short "Dave Mason" "dmason@plg.uwaterloo.ca") + (print-short "Jason R Mastaler" "jason@4b.org") (print-short "Jaye Mathisen" "mrcpu@cdsnet.net") (print-short "Jason McLaren" "mclaren@math.mcgill.ca") (print-short "Michael McNamara" "mac@silicon-sorcery.com") @@ -1353,6 +1360,7 @@ (print-short "Cotton Seed" "cottons@cybercom.net") (print-short "Axel Seibert" "seiberta@informatik.tu-muenchen.de") (print-short "Odd-Magne Sekkingstad" "oddms@ii.uib.no") + (print-short "Justin Sheehy" "justin@linus.mitre.org") (print-short "John Shen" "zfs60@cas.org") (print-short "Murata Shuuichirou" "mrt@mickey.ai.kyutech.ac.jp") (print-short "Matt Simmons" "simmonmt@acm.org")
--- a/lisp/prim/advocacy.el Mon Aug 13 10:03:54 2007 +0200 +++ b/lisp/prim/advocacy.el Mon Aug 13 10:04:58 2007 +0200 @@ -1,8 +1,8 @@ ;;; advocacy.el -- blatant XEmacs self promotion -;; Copyright (C) 1996 Miranova Systems, Inc. +;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. ;; Copyright (C) 1996 Chuck Thompson <cthomp@xemacs.org> -;; Original Author: Steve L Baur <steve@miranova.com> +;; Original Author: Steve L Baur <steve@altair.xemacs.org> ;; This file is part of XEmacs. @@ -22,7 +22,7 @@ ;; Boston, MA 02111-1307, USA. ;;;###autoload -(defvar xemacs-praise-sound-file "sounds/im_so_happy.au" +(defvar xemacs-praise-sound-file "im_so_happy.au" "The name of an audio file containing something to play when praising XEmacs") @@ -57,8 +57,10 @@ (or (and (file-exists-p xemacs-praise-sound-file) xemacs-praise-sound-file) (and (file-exists-p - (concat data-directory xemacs-praise-sound-file)) - (concat data-directory xemacs-praise-sound-file))))) + (concat (locate-data-directory "sounds") + xemacs-praise-sound-file)) + (concat (locate-data-directory "sounds") + xemacs-praise-sound-file))))) (if (and (device-sound-enabled-p) sound-file) (progn (sit-for 0)
--- a/lisp/prim/auto-autoloads.el Mon Aug 13 10:03:54 2007 +0200 +++ b/lisp/prim/auto-autoloads.el Mon Aug 13 10:04:58 2007 +0200 @@ -10,7 +10,7 @@ ;;;### (autoloads (all-hail-emacs all-hail-xemacs praise-be-unto-emacs praise-be-unto-xemacs) "advocacy" "prim/advocacy.el") -(defvar xemacs-praise-sound-file "sounds/im_so_happy.au" "\ +(defvar xemacs-praise-sound-file "im_so_happy.au" "\ The name of an audio file containing something to play when praising XEmacs")
--- a/lisp/prim/backquote.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,287 +0,0 @@ -;;; backquote.el --- Full backquote support for elisp. Reverse compatible too. - -;; Keywords: extensions - -;;; Synched up with: Not synched with FSF. - -;;; The bulk of the code is originally from CMU Common Lisp (original notice -;;; below). -;;; -;;; It correctly supports nested backquotes and backquoted vectors. -;;; -;;; Converted to work with elisp by Miles Bader <miles@cogsci.ed.ac.uk> -;;; -;;; Changes by Jonathan Stigelman <Stig@hackvan.com>: -;;; - Documentation added -;;; - support for old-backquote-compatibility-hook nixed because the -;;; old-backquote compatibility is now done in the reader... -;;; - nixed support for |,.| because -;;; (a) it's not in CLtl2 -;;; (b) ",.foo" is the same as ". ,foo" -;;; (c) because RMS isn't interested in using this version of backquote.el -;;; -;;; wing@666.com; added ,. support back in: -;;; (a) yes, it is in CLtl2. Read closely on page 529. -;;; (b) RMS in 19.30 adds C support for ,. even if it's not really -;;; handled. -;;; -;;; ********************************************************************** -;;; This code was written as part of the CMU Common Lisp project at -;;; Carnegie Mellon University, and has been placed in the public domain. -;;; If you want to use this code or any part of CMU Common Lisp, please contact -;;; Scott Fahlman or slisp-group@cs.cmu.edu. -;;; -;;; ********************************************************************** -;;; -;;; BACKQUOTE: Code Spice Lispified by Lee Schumacher. -;;; -;;; The flags passed back by BQ-PROCESS-2 can be interpreted as follows: -;;; -;;; |`,|: [a] => a -;;; NIL: [a] => a ;the NIL flag is used only when a is NIL -;;; T: [a] => a ;the T flag is used when a is self-evaluating -;;; QUOTE: [a] => (QUOTE a) -;;; APPEND: [a] => (APPEND . a) -;;; NCONC: [a] => (NCONC . a) -;;; LIST: [a] => (LIST . a) -;;; LIST*: [a] => (LIST* . a) -;;; -;;; The flags are combined according to the following set of rules: -;;; ([a] means that a should be converted according to the previous table) -;;; -;;; \ car || otherwise | QUOTE or | |`,@| | |`,.| -;;;cdr \ || | T or NIL | | -;;;============================================================================ -;;; |`,| ||LIST* ([a] [d]) |LIST* ([a] [d]) |APPEND (a [d]) |NCONC (a [d]) -;;; NIL ||LIST ([a]) |QUOTE (a) |<hair> a |<hair> a -;;;QUOTE or T||LIST* ([a] [d]) |QUOTE (a . d) |APPEND (a [d]) |NCONC (a [d]) -;;; APPEND ||LIST* ([a] [d]) |LIST* ([a] [d]) |APPEND (a . d) |NCONC (a [d]) -;;; NCONC ||LIST* ([a] [d]) |LIST* ([a] [d]) |APPEND (a [d]) |NCONC (a . d) -;;; LIST ||LIST ([a] . d) |LIST ([a] . d) |APPEND (a [d]) |NCONC (a [d]) -;;; LIST* ||LIST* ([a] . d) |LIST* ([a] . d) |APPEND (a [d]) |NCONC (a [d]) -;;; -;;;<hair> involves starting over again pretending you had read ".,a)" instead -;;; of ",@a)" -;;; - -;;; -;;; -;;; -;;; -;;; -;;; -;;; -;;; -;;; -;;; - -;;; These are the forms it expects: |backquote| |`| |,| |,@| and |,.|. -(defconst bq-backquote-marker 'backquote) -(defconst bq-backtick-marker '\`) ; remnant of the old lossage -(defconst bq-comma-marker '\,) -(defconst bq-at-marker '\,@) -(defconst bq-dot-marker '\,\.) - -;;; ---------------------------------------------------------------- - -(fset '\` 'backquote) - -(defmacro backquote (template) - "Expand the internal representation of a backquoted TEMPLATE into a lisp form. - -The backquote character is like the quote character in that it prevents the -template which follows it from being evaluated, except that backquote -permits you to evaluate portions of the quoted template. A comma character -inside TEMPLATE indicates that the following item should be evaluated. A -comma character may be followed by an at-sign, which indicates that the form -which follows should be evaluated and inserted and \"spliced\" into the -template. Forms following ,@ must evaluate to lists. - -Here is how to use backquotes: - (setq p 'b - q '(c d e)) - `(a ,p ,@q) -> (a b c d e) - `(a . b) -> (a . b) - `(a . ,p) -> (a . b) - -The XEmacs lisp reader expands lisp backquotes as it reads them. -Examples: - `atom is read as (backquote atom) - `(a ,b ,@(c d e)) is read as (backquote (a (\\, b) (\\,\\@ (c d e)))) - `(a . ,p) is read as (backquote (a \\, p)) - -\(backquote TEMPLATE) is a macro that produces code to construct TEMPLATE. -Note that this is very slow in interpreted code, but fast if you compile. -TEMPLATE is one or more nested lists or vectors, which are `almost quoted'. -They are copied recursively, with elements preceded by comma evaluated. - (backquote (a b)) == (list 'a 'b) - (backquote (a [b c])) == (list 'a (vector 'b 'c)) - -However, certain special lists are not copied. They specify substitution. -Lists that look like (\\, EXP) are evaluated and the result is substituted. - (backquote (a (\\, (+ x 5)))) == (list 'a (+ x 5)) - -Elements of the form (\\,\\@ EXP) are evaluated and then all the elements -of the result are substituted. This result must be a list; it may -be `nil'. - -Elements of the form (\\,\\. EXP) are evaluated and then all the elements -of the result are concatenated to the list of preceding elements in the list. -They must occur as the last element of a list (not a vector). -EXP may evaluate to nil. - -As an example, a simple macro `push' could be written: - (defmacro push (v l) - `(setq ,l (cons ,@(list v l)))) -or as - (defmacro push (v l) - `(setq ,l (cons ,v ,l))) - -For backwards compatibility, old-style emacs-lisp backquotes are still read. - OLD STYLE NEW STYLE - (` (foo (, bar) (,@ bing))) `(foo ,bar ,@bing) - -Because of the old-style backquote support, you cannot use a new-style -backquoted form as the first element of a list. Perhaps some day this -restriction will go away, but for now you should be wary of it: - (`(this ,will ,@fail)) - ((` (but (, this) will (,@ work)))) -This is an extremely rare thing to need to do in lisp." - (bq-process template)) - -;;; ---------------------------------------------------------------- - -(defconst bq-comma-flag 'unquote) -(defconst bq-at-flag 'unquote-splicing) -(defconst bq-dot-flag 'unquote-nconc-splicing) - -(defun bq-process (form) - (let* ((flag-result (bq-process-2 form)) - (flag (car flag-result)) - (result (cdr flag-result))) - (cond ((eq flag bq-at-flag) - (error ",@ after ` in form: %s" form)) - ((eq flag bq-dot-flag) - (error ",. after ` in form: %s" form)) - (t - (bq-process-1 flag result))))) - -;;; ---------------------------------------------------------------- - -(defun bq-vector-contents (vec) - (let ((contents nil) - (n (length vec))) - (while (> n 0) - (setq n (1- n)) - (setq contents (cons (aref vec n) contents))) - contents)) - -;;; This does the expansion from table 2. -(defun bq-process-2 (code) - (cond ((vectorp code) - (let* ((dflag-d - (bq-process-2 (bq-vector-contents code)))) - (cons 'vector (bq-process-1 (car dflag-d) (cdr dflag-d))))) - ((atom code) - (cond ((null code) (cons nil nil)) - ((or (numberp code) (eq code t)) - (cons t code)) - (t (cons 'quote code)))) - ((eq (car code) bq-at-marker) - (cons bq-at-flag (nth 1 code))) - ((eq (car code) bq-dot-marker) - (cons bq-dot-flag (nth 1 code))) - ((eq (car code) bq-comma-marker) - (bq-comma (nth 1 code))) - ((or (eq (car code) bq-backquote-marker) - (eq (car code) bq-backtick-marker)) ; old lossage - (bq-process-2 (bq-process (nth 1 code)))) - (t (let* ((aflag-a (bq-process-2 (car code))) - (aflag (car aflag-a)) - (a (cdr aflag-a))) - (let* ((dflag-d (bq-process-2 (cdr code))) - (dflag (car dflag-d)) - (d (cdr dflag-d))) - (if (eq dflag bq-at-flag) - ;; get the errors later. - (error ",@ after dot in %s" code)) - (if (eq dflag bq-dot-flag) - (error ",. after dot in %s" code)) - (cond - ((eq aflag bq-at-flag) - (if (null dflag) - (bq-comma a) - (cons 'append - (cond ((eq dflag 'append) - (cons a d )) - (t (list a (bq-process-1 dflag d))))))) - ((eq aflag bq-dot-flag) - (if (null dflag) - (bq-comma a) - (cons 'nconc - (cond ((eq dflag 'nconc) - (cons a d)) - (t (list a (bq-process-1 dflag d))))))) - ((null dflag) - (if (memq aflag '(quote t nil)) - (cons 'quote (list a)) - (cons 'list (list (bq-process-1 aflag a))))) - ((memq dflag '(quote t)) - (if (memq aflag '(quote t nil)) - (cons 'quote (cons a d )) - (cons 'list* (list (bq-process-1 aflag a) - (bq-process-1 dflag d))))) - (t (setq a (bq-process-1 aflag a)) - (if (memq dflag '(list list*)) - (cons dflag (cons a d)) - (cons 'list* - (list a (bq-process-1 dflag d))))))))))) - -;;; This handles the <hair> cases -(defun bq-comma (code) - (cond ((atom code) - (cond ((null code) - (cons nil nil)) - ((or (numberp code) (eq code 't)) - (cons t code)) - (t (cons bq-comma-flag code)))) - ((eq (car code) 'quote) - (cons (car code) (car (cdr code)))) - ((memq (car code) '(append list list* nconc)) - (cons (car code) (cdr code))) - ((eq (car code) 'cons) - (cons 'list* (cdr code))) - (t (cons bq-comma-flag code)))) - -;;; This handles table 1. -(defun bq-process-1 (flag thing) - (cond ((or (eq flag bq-comma-flag) - (memq flag '(t nil))) - thing) - ((eq flag 'quote) - (list 'quote thing)) - ((eq flag 'vector) - (list 'apply '(function vector) thing)) - (t (cons (cdr - (assq flag - '((cons . cons) - (list* . bq-list*) - (list . list) - (append . append) - (nconc . nconc)))) - thing)))) - -;;; ---------------------------------------------------------------- - -(defmacro bq-list* (&rest args) - "Returns a list of its arguments with last cons a dotted pair." - (setq args (reverse args)) - (let ((result (car args))) - (setq args (cdr args)) - (while args - (setq result (list 'cons (car args) result)) - (setq args (cdr args))) - result)) - -(provide 'backquote) -
--- a/lisp/prim/buffer.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,102 +0,0 @@ -;;; buffer.el --- buffer routines taken from C -;;; Copyright (C) 1985-1989, 1992-1995 Free Software Foundation, Inc. -;;; Copyright (C) 1995 Sun Microsystems. -;;; Copyright (C) 1995, 1996 Ben Wing. - -;; 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, 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: FSF 19.30 buffer.c. - -;;; Code: - -(defun switch-to-buffer (bufname &optional norecord) - "Select buffer BUFNAME in the current window. -BUFNAME may be a buffer or a buffer name. -Optional second arg NORECORD non-nil means -do not put this buffer at the front of the list of recently selected ones. - -WARNING: This is NOT the way to work on another buffer temporarily -within a Lisp program! Use `set-buffer' instead. That avoids messing with -the window-buffer correspondences." - (interactive "BSwitch to buffer: ") - ;; #ifdef I18N3 - ;; #### Doc string should indicate that the buffer name will get - ;; translated. - ;; #endif - (if (eq (minibuffer-window) (selected-window)) - (error "Cannot switch buffers in minibuffer window")) - (if (window-dedicated-p (selected-window)) - (error "Cannot switch buffers in a dedicated window")) - (let (buf) - (if (null bufname) - (setq buf (other-buffer (current-buffer))) - (setq buf (get-buffer bufname)) - (if (null buf) - (progn - (setq buf (get-buffer-create bufname)) - (set-buffer-major-mode buf)))) - (push-window-configuration) - (set-buffer buf) - (or norecord (record-buffer buf)) - (set-window-buffer (if (eq (selected-window) (minibuffer-window)) - (next-window (minibuffer-window)) - (selected-window)) - buf) - buf)) - -(defun pop-to-buffer (bufname &optional not-this-window-p on-frame) - "Select buffer BUFNAME in some window, preferably a different one. -If BUFNAME is nil, then some other buffer is chosen. -If `pop-up-windows' is non-nil, windows can be split to do this. -If optional second arg NOT-THIS-WINDOW-P is non-nil, insist on finding -another window even if BUFNAME is already visible in the selected window. -If optional third arg is non-nil, it is the frame to pop to this -buffer on. -If `focus-follows-mouse' is non-nil, keyboard focus is left unchanged." - ;; #ifdef I18N3 - ;; #### Doc string should indicate that the buffer name will get - ;; translated. - ;; #endif - ;; This is twisted. It is evil to throw the keyboard focus around - ;; willy-nilly if the user wants focus-follows-mouse. - (let ((oldbuf (current-buffer)) - buf window frame) - (if (null bufname) - (setq buf (other-buffer (current-buffer))) - (setq buf (get-buffer bufname)) - (if (null buf) - (progn - (setq buf (get-buffer-create bufname)) - (set-buffer-major-mode buf)))) - (push-window-configuration) - (set-buffer buf) - (setq window (display-buffer buf not-this-window-p on-frame)) - (setq frame (window-frame window)) - ;; if the display-buffer hook decided to show this buffer in another - ;; frame, then select that frame, (unless obeying focus-follows-mouse -sb). - (if (and (not focus-follows-mouse) - (not (eq frame (selected-frame)))) - (select-frame frame)) - (record-buffer buf) - (if (and focus-follows-mouse - on-frame - (not (eq on-frame (selected-frame)))) - (set-buffer oldbuf) - ;; select-window will modify the internal keyboard focus of XEmacs - (select-window window)) - buf))
--- a/lisp/prim/cmdloop.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,540 +0,0 @@ -;;; cmdloop.el --- support functions for the top-level command loop. - -;; Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc. - -;; 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, 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: FSF 19.30. (Some of the stuff below is in FSF's subr.el.) - -;; Written by Richard Mlynarik 8-Jul-92 - -(defun recursion-depth () - "Return the current depth in recursive edits." - (+ command-loop-level (minibuffer-depth))) - -(defun top-level () - "Exit all recursive editing levels." - (interactive) - (throw 'top-level nil)) - -(defun exit-recursive-edit () - "Exit from the innermost recursive edit or minibuffer." - (interactive) - (if (> (recursion-depth) 0) - (throw 'exit nil)) - (error "No recursive edit is in progress")) - -(defun abort-recursive-edit () - "Abort the command that requested this recursive edit or minibuffer input." - (interactive) - (if (> (recursion-depth) 0) - (throw 'exit t)) - (error "No recursive edit is in progress")) - -;; (defun keyboard-quit () -;; "Signal a `quit' condition." -;; (interactive) -;; (deactivate-mark) -;; (signal 'quit nil)) - -;; moved here from pending-del. -(defun keyboard-quit () - "Signal a `quit' condition. -If this character is typed while lisp code is executing, it will be treated - as an interrupt. -If this character is typed at top-level, this simply beeps. -If `zmacs-regions' is true, and the zmacs region is active in this buffer, -then this key deactivates the region without beeping or signalling." - (interactive) - (if (and (region-active-p) - (eq (current-buffer) (zmacs-region-buffer))) - ;; pseudo-zmacs compatibility: don't beep if this ^G is simply - ;; deactivating the region. If it is inactive, beep. - nil - (signal 'quit nil))) - -(defvar buffer-quit-function nil - "Function to call to \"quit\" the current buffer, or nil if none. -\\[keyboard-escape-quit] calls this function when its more local actions -\(such as cancelling a prefix argument, minibuffer or region) do not apply.") - -(defun keyboard-escape-quit () - "Exit the current \"mode\" (in a generalized sense of the word). -This command can exit an interactive command such as `query-replace', -can clear out a prefix argument or a region, -can get out of the minibuffer or other recursive edit, -cancel the use of the current buffer (for special-purpose buffers), -or go back to just one window (by deleting all but the selected window)." - (interactive) - (cond ((eq last-command 'mode-exited) nil) - ((> (minibuffer-depth) 0) - (abort-recursive-edit)) - (current-prefix-arg - nil) - ((region-active-p) - (zmacs-deactivate-region)) - ((> (recursion-depth) 0) - (exit-recursive-edit)) - (buffer-quit-function - (funcall buffer-quit-function)) - ((not (one-window-p t)) - (delete-other-windows)) - ((string-match "^ \\*" (buffer-name (current-buffer))) - (bury-buffer)))) - -;;#### This should really be a ring of last errors. -(defvar last-error nil - "#### Document me.") - -;; #### Provisionally turned on for XEmacs 20.3beta. -(defcustom errors-deactivate-region nil - "*Non-nil means that errors will cause the region to be deactivated." - :type 'boolean - :group 'editing-basics) - -(defun command-error (error-object) - (let ((inhibit-quit t) - (debug-on-error nil) - (etype (car-safe error-object))) - (setq quit-flag nil) - (setq standard-output t) - (setq standard-input t) - (setq executing-kbd-macro nil) - (and errors-deactivate-region - (zmacs-deactivate-region)) - (discard-input) - - (setq last-error error-object) - - (message nil) - (ding nil (cond ((eq etype 'undefined-keystroke-sequence) - (if (and (vectorp (nth 1 error-object)) - (/= 0 (length (nth 1 error-object))) - (button-event-p (aref (nth 1 error-object) 0))) - 'undefined-click - 'undefined-key)) - ((eq etype 'quit) - 'quit) - ((memq etype '(end-of-buffer beginning-of-buffer)) - 'buffer-bound) - ((eq etype 'buffer-read-only) - 'read-only) - (t 'command-error))) - (display-error error-object t) - - (if (noninteractive) - (progn - (message "XEmacs exiting.") - (kill-emacs -1))) - t)) - -(defun describe-last-error () - "Redisplay the last error-message. See the variable `last-error'." - (interactive) - (with-displaying-help-buffer - (lambda () - (princ "Last error was:\n" standard-output) - (display-error last-error standard-output)))) - - -;;#### Must be done later in the loadup sequence -;(define-key (symbol-function 'help-command) "e" 'describe-last-error) - - -(defun truncate-command-history-for-gc () - (let ((tail (nthcdr 30 command-history))) - (if tail (setcdr tail nil))) - (let ((tail (nthcdr 30 values))) - (if tail (setcdr tail nil))) - ) - -(add-hook 'pre-gc-hook 'truncate-command-history-for-gc) - - -;;;; Object-oriented programming at its finest - -;; Now in src/print.c; used by Ferror_message_string and others -;(defun display-error (error-object stream) ;(defgeneric report-condition ...) -; "Display `error-object' on `stream' in a user-friendly way." -; (funcall (or (let ((type (car-safe error-object))) -; (catch 'error -; (and (consp error-object) -; (symbolp type) -; ;;(stringp (get type 'error-message)) -; (consp (get type 'error-conditions)) -; (let ((tail (cdr error-object))) -; (while (not (null tail)) -; (if (consp tail) -; (setq tail (cdr tail)) -; (throw 'error nil))) -; t) -; ;; (check-type condition condition) -; (get type 'error-conditions) -; ;; Search class hierarchy -; (let ((tail (get type 'error-conditions))) -; (while (not (null tail)) -; (cond ((not (and (consp tail) -; (symbolp (car tail)))) -; (throw 'error nil)) -; ((get (car tail) 'display-error) -; (throw 'error (get (car tail) -; 'display-error))) -; (t -; (setq tail (cdr tail))))) -; ;; Default method -; #'(lambda (error-object stream) -; (let ((type (car error-object)) -; (tail (cdr error-object)) -; (first t) -; (print-message-label 'error)) -; (if (eq type 'error) -; (progn (princ (car tail) stream) -; (setq tail (cdr tail))) -; (princ (or (gettext (get type 'error-message)) type) -; stream)) -; (while tail -; (princ (if first ": " ", ") stream) -; (prin1 (car tail) stream) -; (setq tail (cdr tail) -; first nil)))))))) -; #'(lambda (error-object stream) -; (princ (gettext "Peculiar error ") stream) -; (prin1 error-object stream))) -; error-object stream)) - -(put 'file-error 'display-error - #'(lambda (error-object stream) - (let ((tail (cdr error-object)) - (first t)) - (princ (car tail) stream) - (while (setq tail (cdr tail)) - (princ (if first ": " ", ") stream) - (princ (car tail) stream) - (setq first nil))))) - -(put 'undefined-keystroke-sequence 'display-error - #'(lambda (error-object stream) - (princ (key-description (car (cdr error-object))) stream) - ;; #### I18N3: doesn't localize properly. - (princ (gettext " not defined.") stream) ; doo dah, doo dah. - )) - - -(defcustom teach-extended-commands-p t - "*If true, then `\\[execute-extended-command]' will teach you keybindings. -Any time you execute a command with \\[execute-extended-command] which has a -shorter keybinding, you will be shown the alternate binding before the -command executes. There is a short pause after displaying the binding, -before executing it; the length can be controlled by -`teach-extended-commands-timeout'." - :type 'boolean - :group 'keyboard) - -(defcustom teach-extended-commands-timeout 4 - "*How long to pause after displaying a keybinding before executing. -The value is measured in seconds. This only applies if -`teach-extended-commands-p' is true." - :type 'number - :group 'keyboard) - -;That damn RMS went off and implemented something differently, after -;we had already implemented it. We can't support both properly until -;we have Lisp magic variables. -;(defvar suggest-key-bindings t -; "*FSFmacs equivalent of `teach-extended-commands-*'. -;Provided for compatibility only. -;Non-nil means show the equivalent key-binding when M-x command has one. -;The value can be a length of time to show the message for. -;If the value is non-nil and not a number, we wait 2 seconds.") -; -;(make-obsolete-variable 'suggest-key-bindings 'teach-extended-commands-p) - -(defun execute-extended-command (prefix-arg) - "Read a command name from the minibuffer using 'completing-read'. -Then call the specified command using 'command-execute' and return its -return value. If the command asks for a prefix argument, supply the -value of the current raw prefix argument, or the value of PREFIX-ARG -when called from Lisp." - (interactive "P") - ;; Note: This doesn't hack "this-command-keys" - (let ((prefix-arg prefix-arg)) - (setq this-command (read-command - ;; Note: this has the hard-wired - ;; "C-u" and "M-x" string bug in common - ;; with all GNU Emacs's. - ;; (i.e. it prints C-u and M-x regardless of - ;; whether some other keys were actually bound - ;; to `execute-extended-command' and - ;; `universal-argument'. - (cond ((eq prefix-arg '-) - "- M-x ") - ((equal prefix-arg '(4)) - "C-u M-x ") - ((integerp prefix-arg) - (format "%d M-x " prefix-arg)) - ((and (consp prefix-arg) - (integerp (car prefix-arg))) - (format "%d M-x " (car prefix-arg))) - (t - "M-x "))))) - - (if (and teach-extended-commands-p - (interactive-p)) - ;; We need to fiddle with keys: remember the keys, run the - ;; command, and show the keys (if any). - (let ((_execute_command_keys_ (where-is-internal this-command)) - (_execute_command_name_ this-command)) ; the name can change - (command-execute this-command t) - (when (and _execute_command_keys_ - ;; Wait for a while, so the user can see a message - ;; printed, if any. - (sit-for 1)) - (display-message - 'no-log - (format "Command `%s' is bound to key%s: %s" - _execute_command_name_ - (if (cdr _execute_command_keys_) "s" "") - (sorted-key-descriptions _execute_command_keys_))) - (sit-for teach-extended-commands-timeout) - (clear-message 'no-log))) - ;; Else, just run the command. - (command-execute this-command t))) - - -;;; C code calls this; the underscores in the variable names are to avoid -;;; cluttering the specbind namespace (lexical scope! lexical scope!) -;;; Putting this in Lisp instead of C slows kbd macros by 50%. -;(defun command-execute (_command &optional _record-flag) -; "Execute CMD as an editor command. -;CMD must be a symbol that satisfies the `commandp' predicate. -;Optional second arg RECORD-FLAG non-nil -;means unconditionally put this command in `command-history'. -;Otherwise, that is done only if an arg is read using the minibuffer." -; (let ((_prefix prefix-arg) -; (_cmd (indirect-function _command))) -; (setq prefix-arg nil -; this-command _command -; current-prefix-arg _prefix -; zmacs-region-stays nil) -; ;; #### debug_on_next_call = 0; -; (cond ((and (symbolp _command) -; (get _command 'disabled)) -; (run-hooks disabled-command-hook)) -; ((or (stringp _cmd) (vectorp _cmd)) -; ;; If requested, place the macro in the command history. -; ;; For other sorts of commands, call-interactively takes -; ;; care of this. -; (if _record-flag -; (setq command-history -; (cons (list 'execute-kbd-macro _cmd _prefix) -; command-history))) -; (execute-kbd-macro _cmd _prefix)) -; (t -; (call-interactively _command _record-flag))))) - -(defun y-or-n-p-minibuf (prompt) - "Ask user a \"y or n\" question. Return t if answer is \"y\". -Takes one argument, which is the string to display to ask the question. -It should end in a space; `y-or-n-p' adds `(y or n) ' to it. -No confirmation of the answer is requested; a single character is enough. -Also accepts Space to mean yes, or Delete to mean no." - (save-excursion - (let* ((pre "") - (yn (gettext "(y or n) ")) - ;; we need to translate the prompt ourselves because of the - ;; strange way we handle it. - (prompt (gettext prompt)) - event) - (while (stringp yn) - (if (let ((cursor-in-echo-area t) - (inhibit-quit t)) - (message "%s%s%s" pre prompt yn) - (setq event (next-command-event event)) - (condition-case nil - (prog1 - (or quit-flag (eq 'keyboard-quit (key-binding event))) - (setq quit-flag nil)) - (wrong-type-argument t))) - (progn - (message "%s%s%s%s" pre prompt yn (single-key-description event)) - (setq quit-flag nil) - (signal 'quit '()))) - (let* ((keys (events-to-keys (vector event))) - (def (lookup-key query-replace-map keys))) - (cond ((eq def 'skip) - (message "%s%sNo" prompt yn) - (setq yn nil)) - ((eq def 'act) - (message "%s%sYes" prompt yn) - (setq yn t)) - ((eq def 'recenter) - (recenter)) - ((or (eq def 'quit) (eq def 'exit-prefix)) - (signal 'quit '())) - ((button-release-event-p event) ; ignore them - nil) - (t - (message "%s%s%s%s" pre prompt yn - (single-key-description event)) - (ding nil 'y-or-n-p) - (discard-input) - (if (= (length pre) 0) - (setq pre (gettext "Please answer y or n. "))))))) - yn))) - -(defun yes-or-no-p-minibuf (prompt) - "Ask user a yes-or-no question. Return t if answer is yes. -Takes one argument, which is the string to display to ask the question. -It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it. -The user must confirm the answer with RET, -and can edit it until it has been confirmed." - (save-excursion - (let ((p (concat (gettext prompt) (gettext "(yes or no) "))) - (ans "")) - (while (stringp ans) - (setq ans (downcase (read-string p nil t))) ;no history - (cond ((string-equal ans (gettext "yes")) - (setq ans 't)) - ((string-equal ans (gettext "no")) - (setq ans 'nil)) - (t - (ding nil 'yes-or-no-p) - (discard-input) - (message "Please answer yes or no.") - (sleep-for 2)))) - ans))) - -;; these may be redefined later, but make the original def easily encapsulable -(define-function 'yes-or-no-p 'yes-or-no-p-minibuf) -(define-function 'y-or-n-p 'y-or-n-p-minibuf) - - -(defun read-char () - "Read a character from the command input (keyboard or macro). -If a mouse click or non-ASCII character is detected, an error is -signalled. The character typed is returned as an ASCII value. This -is most likely the wrong thing for you to be using: consider using -the `next-command-event' function instead." - (save-excursion - (let* ((inhibit-quit t) - (event (next-command-event))) - (prog1 (or (event-to-character event) - ;; Kludge. If the event we read was a mouse-release, - ;; discard it and read the next one. - (if (button-release-event-p event) - (event-to-character (next-command-event event))) - (error "Key read has no ASCII equivalent %S" event)) - ;; this is not necessary, but is marginally more efficient than GC. - (deallocate-event event))))) - -(defun read-char-exclusive () - "Read a character from the command input (keyboard or macro). -If a mouse click or non-ASCII character is detected, it is discarded. -The character typed is returned as an ASCII value. This is most likely -the wrong thing for you to be using: consider using the -`next-command-event' function instead." - (let ((inhibit-quit t) - event ch) - (while (progn - (setq event (next-command-event)) - (setq ch (event-to-character event)) - (deallocate-event event) - (null ch))) - ch)) - -(defun read-quoted-char (&optional prompt) - "Like `read-char', except that if the first character read is an octal -digit, we read up to two more octal digits and return the character -represented by the octal number consisting of those digits. -Optional argument PROMPT specifies a string to use to prompt the user." - (save-excursion - (let ((count 0) (code 0) - (prompt (and prompt (gettext prompt))) - char event) - (while (< count 3) - (let ((inhibit-quit (zerop count)) - ;; Don't let C-h get the help message--only help function keys. - (help-char nil) - (help-form - "Type the special character you want to use, -or three octal digits representing its character code.")) - (and prompt (display-message 'prompt (format "%s-" prompt))) - (setq event (next-command-event) - char (or (event-to-character event nil nil t) - (error "key read cannot be inserted in a buffer: %S" - event))) - (if inhibit-quit (setq quit-flag nil))) - (cond ((null char)) - ((and (<= ?0 char) (<= char ?7)) - (setq code (+ (* code 8) (- char ?0)) - count (1+ count)) - (and prompt (display-message - 'prompt - (setq prompt (format "%s %c" prompt char))))) - ((> count 0) - (setq unread-command-event event - count 259)) - (t (setq code char count 259)))) - ;; Turn a meta-character into a character with the 0200 bit set. - (logior (if (/= (logand code ?\M-\^@) 0) 128 0) - (logand 255 code))))) - -(defun momentary-string-display (string pos &optional exit-char message) - "Momentarily display STRING in the buffer at POS. -Display remains until next character is typed. -If the char is EXIT-CHAR (optional third arg, default is SPC) it is swallowed; -otherwise it is then available as input (as a command if nothing else). -Display MESSAGE (optional fourth arg) in the echo area. -If MESSAGE is nil, instructions to type EXIT-CHAR are displayed there." - (or exit-char (setq exit-char ?\ )) - (let ((buffer-read-only nil) - ;; Don't modify the undo list at all. - (buffer-undo-list t) - (modified (buffer-modified-p)) - (name buffer-file-name) - insert-end) - (unwind-protect - (progn - (save-excursion - (goto-char pos) - ;; defeat file locking... don't try this at home, kids! - (setq buffer-file-name nil) - (insert-before-markers (gettext string)) - (setq insert-end (point)) - ;; If the message end is off frame, recenter now. - (if (> (window-end) insert-end) - (recenter (/ (window-height) 2))) - ;; If that pushed message start off the frame, - ;; scroll to start it at the top of the frame. - (move-to-window-line 0) - (if (> (point) pos) - (progn - (goto-char pos) - (recenter 0)))) - (message (or message (gettext "Type %s to continue editing.")) - (single-key-description exit-char)) - (let ((event (save-excursion (next-command-event)))) - (or (eq (event-to-character event) exit-char) - (setq unread-command-event event)))) - (if insert-end - (save-excursion - (delete-region pos insert-end))) - (setq buffer-file-name name) - (set-buffer-modified-p modified)))) - -;;; cmdloop.el ends here
--- a/lisp/prim/console.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,46 +0,0 @@ -;;; console.el --- miscellaneous console functions not written in C - -;; Copyright (C) 1994, 1995 Board of Trustees, University of Illinois -;; Copyright (C) 1995, 1996 Ben Wing - -;; Keywords: internal - -;; 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, 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: Not in FSF. - -;;; Commentary: - -;;; Code: - -(defun quit-char (&optional console) - "Return the character that causes a QUIT to happen. -This is normally C-g. Optional arg CONSOLE specifies the console -that the information is returned for; nil means the current console." - (nth 3 (current-input-mode console))) - -(defun resume-pid-console (pid) - "Resume the consoles with a controlling process of PID." - (mapc (lambda (c) - (if (and (eq (console-type c) 'tty) - (eql pid (console-tty-controlling-process c))) - (resume-console c))) - (console-list)) - nil) - -;;; console.el ends here
--- a/lisp/prim/custom-load.el Mon Aug 13 10:03:54 2007 +0200 +++ b/lisp/prim/custom-load.el Mon Aug 13 10:04:58 2007 +0200 @@ -3,36 +3,9 @@ ;;; Code: -(custom-add-loads 'mouse '("mouse")) -(custom-add-loads 'minibuffer '("simple" "minibuf")) -(custom-add-loads 'log-message '("simple")) -(custom-add-loads 'environment '("frame" "minibuf" "modeline" "sound")) +(custom-add-loads 'environment '("sound")) (custom-add-loads 'sound '("sound")) -(custom-add-loads 'auto-save '("files")) -(custom-add-loads 'mail '("simple")) -(custom-add-loads 'editing-basics '("cmdloop" "simple" "files" "lisp")) -(custom-add-loads 'help-appearance '("help")) -(custom-add-loads 'lisp '("lisp" "find-func")) -(custom-add-loads 'help '("help")) -(custom-add-loads 'keyboard '("cmdloop")) -(custom-add-loads 'warnings '("simple")) -(custom-add-loads 'backup '("files")) -(custom-add-loads 'frames '("frame" "window-xemacs" "gui")) -(custom-add-loads 'abbrev '("files")) +(custom-add-loads 'lisp '("find-func")) (custom-add-loads 'find-function '("find-func")) -(custom-add-loads 'dired '("files")) -(custom-add-loads 'killing '("simple")) -(custom-add-loads 'paren-blinking '("simple")) -(custom-add-loads 'find-file '("files")) -(custom-add-loads 'files '("files")) -(custom-add-loads 'fill-comments '("simple")) -(custom-add-loads 'windows '("window" "window-xemacs")) -(custom-add-loads 'fill '("simple")) -(custom-add-loads 'faces '("faces")) -(custom-add-loads 'vc '("files")) -(custom-add-loads 'isearch '("isearch-mode")) -(custom-add-loads 'modeline '("modeline")) -(custom-add-loads 'editing '("simple")) -(custom-add-loads 'matching '("simple" "isearch-mode")) ;;; custom-load.el ends here
--- a/lisp/prim/device.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,75 +0,0 @@ -;;; device.el --- miscellaneous device functions not written in C - -;;;; Copyright (C) 1994, 1995 Board of Trustees, University of Illinois -;;;; Copyright (C) 1995, 1996 Ben Wing - -;; Keywords: internal - -;; 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, 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: Not in FSF. - -(defun device-list () - "Return a list of all devices." - (apply 'nconc (mapcar 'console-device-list (console-list)))) - -(defun device-type (&optional device) - "Return the type of the specified device (e.g. `x' or `tty'). -This is equivalent to the type of the device's console. -Value is `tty' for a tty device (a character-only terminal), -`x' for a device that is a screen on an X display, -`ns' for a device that is a NeXTstep connection (not yet implemented), -`win32' for a device that is a Windows or Windows NT connection (not yet - implemented), -`pc' for a device that is a direct-write MS-DOS screen (not yet implemented), -`stream' for a stream device (which acts like a stdio stream), and -`dead' for a deleted device." - (or device (setq device (selected-device))) - (if (not (device-live-p device)) 'dead - (console-type (device-console device)))) - -(defun make-tty-device (&optional tty terminal-type controlling-process) - "Create a new device on TTY. - TTY should be the name of a tty device file (e.g. \"/dev/ttyp3\" under -SunOS et al.), as returned by the `tty' command. A value of nil means -use the stdin and stdout as passed to XEmacs from the shell. - If TERMINAL-TYPE is non-nil, it should be a string specifying the -type of the terminal attached to the specified tty. If it is nil, -the terminal type will be inferred from the TERM environment variable. - If CONTROLLING-PROCESS is non-nil, it should be an integer -specifying the process id of the process in control of the specified tty. If -it is nil, it is assumes to be the value returned by emacs-pid." - (make-device 'tty tty (list 'terminal-type terminal-type - 'controlling-process controlling-process))) - -(defun make-x-device (&optional display) - "Create a new device connected to DISPLAY." - (make-device 'x display)) - -(defun device-on-window-system-p (&optional device) - "Return non-nil if DEVICE is on a window system. -This generally means that there is support for the mouse, the menubar, -the toolbar, glyphs, etc." - (or device (setq device (selected-device))) - (console-on-window-system-p (device-console device))) - -(defalias 'valid-device-type-p 'valid-console-type-p) -(defalias 'device-type-list 'console-type-list) -(defalias 'device-pixel-depth 'device-bitplanes) - -;;; device.el ends here
--- a/lisp/prim/dialog.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,146 +0,0 @@ -;; Dialog-box support. -;; Copyright (C) 1991, 1992, 1993, 1994 Free Software Foundation, Inc. - -;; 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, 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: Not in FSF. - -(defun yes-or-no-p-dialog-box (prompt) - "Ask user a \"y or n\" question with a popup dialog box. -Returns t if answer is \"yes\". -Takes one argument, which is the string to display to ask the question." - (let ((echo-keystrokes 0) - event) - (popup-dialog-box - ;; "Non-violent language please!" says Robin. - (cons prompt '(["Yes" yes t] ["No" no t] nil ["Cancel" abort t]))) -; (cons prompt '(["Yes" yes t] ["No" no t] nil ["Abort" abort t]))) - (catch 'ynp-done - (while t - (setq event (next-command-event event)) - (cond ((and (misc-user-event-p event) (eq (event-object event) 'yes)) - (throw 'ynp-done t)) - ((and (misc-user-event-p event) (eq (event-object event) 'no)) - (throw 'ynp-done nil)) - ((and (misc-user-event-p event) - (or (eq (event-object event) 'abort) - (eq (event-object event) 'menu-no-selection-hook))) - (signal 'quit nil)) - ((button-release-event-p event) ;; don't beep twice - nil) - (t - (beep) - (message "please answer the dialog box"))))))) - -(defun yes-or-no-p-maybe-dialog-box (prompt) - "Ask user a yes-or-no question. Return t if answer is yes. -The question is asked with a dialog box or the minibuffer, as appropriate. -Takes one argument, which is the string to display to ask the question. -It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it. -The user must confirm the answer with RET, -and can edit it until it as been confirmed." - (if (should-use-dialog-box-p) - (yes-or-no-p-dialog-box prompt) - (yes-or-no-p-minibuf prompt))) - -(defun y-or-n-p-maybe-dialog-box (prompt) - "Ask user a \"y or n\" question. Return t if answer is \"y\". -Takes one argument, which is the string to display to ask the question. -The question is asked with a dialog box or the minibuffer, as appropriate. -It should end in a space; `y-or-n-p' adds `(y or n) ' to it. -No confirmation of the answer is requested; a single character is enough. -Also accepts Space to mean yes, or Delete to mean no." - (if (should-use-dialog-box-p) - (yes-or-no-p-dialog-box prompt) - (y-or-n-p-minibuf prompt))) - -(if (fboundp 'popup-dialog-box) - (progn - (fset 'yes-or-no-p 'yes-or-no-p-maybe-dialog-box) - (fset 'y-or-n-p 'y-or-n-p-maybe-dialog-box))) - -;; this is call-compatible with the horribly-named FSF Emacs function -;; `x-popup-dialog'. I refuse to use that name. -(defun get-dialog-box-response (position contents) - ;; by Stig@hackvan.com - ;; modified by pez@atlantic2.sbi.com - "Pop up a dialog box and return user's selection. -POSITION specifies which frame to use. -This is normally an event or a window or frame. -If POSITION is t or nil, it means to use the frame the mouse is on. -The dialog box appears in the middle of the specified frame. - -CONTENTS specifies the alternatives to display in the dialog box. -It is a list of the form (TITLE ITEM1 ITEM2...). -Each ITEM is a cons cell (STRING . VALUE). -The return value is VALUE from the chosen item. - -An ITEM may also be just a string--that makes a nonselectable item. -An ITEM may also be nil--that means to put all preceding items -on the left of the dialog box and all following items on the right." - (cond - ((eventp position) - (select-frame (event-frame position))) - ((framep position) - (select-frame position)) - ((windowp position) - (select-window position))) - (let ((dbox (cons (car contents) - (mapcar #'(lambda (x) - (cond - ((null x) - nil) - ((stringp x) - `[,x 'ignore nil]) ;this will never get - ;selected - (t - `[,(car x) (throw 'result ',(cdr x)) t]))) - (cdr contents)) - ))) - (catch 'result - (popup-dialog-box dbox) - (dispatch-event (next-command-event))))) - -(defun message-box (fmt &rest args) - "Display a message, in a dialog box if possible. -If the selected device has no dialog-box support, use the echo area. -The arguments are the same as to `format'. - -If the only argument is nil, clear any existing message; let the -minibuffer contents show." - (if (and (null fmt) (null args)) - (progn - (clear-message nil) - nil) - (let ((str (apply 'format fmt args))) - (if (device-on-window-system-p) - (get-dialog-box-response nil (list str (cons "OK" t))) - (display-message 'message str)) - str))) - -(defun message-or-box (fmt &rest args) - "Display a message in a dialog box or in the echo area.\n\ -If this command was invoked with the mouse, use a dialog box.\n\ -Otherwise, use the echo area. -The arguments are the same as to `format'. - -If the only argument is nil, clear any existing message; let the -minibuffer contents show." - (if (should-use-dialog-box-p) - (apply 'message-box fmt args) - (apply 'message fmt args)))
--- a/lisp/prim/dumped-lisp.el Mon Aug 13 10:03:54 2007 +0200 +++ b/lisp/prim/dumped-lisp.el Mon Aug 13 10:04:58 2007 +0200 @@ -8,14 +8,11 @@ "cl" "cl-extra" "cl-seq" - "cl/auto-autoloads" ; Prevents problems later - ;;"featurep" "widget" "custom" ; Before the world so everything can be ; customized "cus-start" ; for customization of builtin variables "cmdloop" -;; (or (fboundp 'recursive-edit) (load-gc "cmdloop1")) "keymap" "syntax" "device" @@ -55,7 +52,7 @@ ;; (load-gc "hyper-apropos") Soon... #-mule "files-nomule" "files" - "lib-complete" + #+xemacs "lib-complete" ; InfoDock uses an older version "format" "indent" "isearch-mode" @@ -75,34 +72,14 @@ "lisp-mode" "text-mode" "fill" - ;; "cc-mode" ; as FSF goes so go we .. - ;; "scroll-in-place" ; We're not ready for this :-( - ;; we no longer load buff-menu automatically. - ;; it will get autoloaded if needed. - - ;; Before this will work again, the different system types will need - ;; to have features named for them. + "auto-save" ; Added for 20.4 -; (cond ; Differences based on system-type -; ((eq system-type 'vax-vms) -; (load-gc "vmsproc") -; (load-gc "vms-patch")) -; ((eq system-type 'windows-nt) -; ;; (load-gc "ls-lisp") #+windows-nt "winnt" -; ((eq system-type 'ms-dos) -; ;; (load-gc "ls-lisp") -; (load-gc "dos-fns") -; (load-gc "disp-table"))) ; needed to setup ibm-pc char set, - ; see internal.el #+lisp-float-type "float-sup" "itimer" ; for vars auto-save-timeout and ; auto-gc-threshold "itimer-autosave" #+toolbar "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)) #+scrollbar "scrollbar" #+menubar "menubar" #+dialog "dialog" @@ -150,7 +127,7 @@ #+mule "language/misc-lang" ;; #+mule "language/thai" #+mule "language/viet-chars" - #+mule "language/vietnamese" +;; #+mule "language/vietnamese" ;; Specialized language support #+(and mule CANNA) "canna-leim" @@ -177,6 +154,9 @@ #+x "x-misc" #+x "x-init" #+(and x toolbar) "x-toolbar" +;; preload the w32gui code. + #+w32 "w32-faces" + #+w32 "w32-init" ;; preload the TTY init code. #+tty "tty-init" ;;; Formerly in tooltalk/tooltalk-load.el @@ -190,10 +170,10 @@ ;; #+energize "energize/energize-load.el" ;;; formerly in sunpro/sunpro-load.el ;; #+(and mule sparcworks) "mime-setup" - #+sparcworks "cc-mode" + #+sparcworks "cc-mode" ; Requires cc-mode package #+sparcworks "sunpro-init" #+sparcworks "ring" - #+sparcworks "comint" + #+sparcworks "comint" ; Requires comint package #+sparcworks "annotations" ;;; formerly in eos/sun-eos-load.el ;; #+sparcworks "sun-eos-init"
--- a/lisp/prim/events.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,154 +0,0 @@ -;;; events.el --- event functions. - -;;;; Copyright (C) 1996 Ben Wing. - -;; Maintainer: Martin Buchholz -;; Keywords: internal event - -;; 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, 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: Not in FSF. - -;;; Code: - - -(defun event-console (event) - "Return the console that EVENT occurred on. -This will be nil for some types of events (e.g. eval events)." - (cdfw-console (event-channel event))) - -(defun event-device (event) - "Return the device that EVENT occurred on. -This will be nil for some types of events (e.g. keyboard and eval events)." - (dfw-device (event-channel event))) - -(defun event-frame (event) - "Return the frame that EVENT occurred on. -This will be nil for some types of events (e.g. keyboard and eval events)." - (fw-frame (event-channel event))) - -(defun event-buffer (event) - "Return the buffer of the window over which mouse event EVENT occurred. -Return nil unless both (mouse-event-p EVENT) and -(event-over-text-area-p EVENT) are non-nil." - (let ((window (event-window event))) - (and (windowp window) (window-buffer window)))) - -(defalias 'allocate-event 'make-event) - - -(defun key-press-event-p (object) - "Return t if OBJECT is a key-press event." - (and (event-live-p object) (eq 'key-press (event-type object)))) - -(defun button-press-event-p (object) - "Return t if OBJECT is a mouse button-press event." - (and (event-live-p object) (eq 'button-press (event-type object)))) - -(defun button-release-event-p (object) - "Return t if OBJECT is a mouse button-release event." - (and (event-live-p object) (eq 'button-release (event-type object)))) - -(defun button-event-p (object) - "Return t if OBJECT is a mouse button-press or button-release event." - (and (event-live-p object) - (memq (event-type object) '(button-press button-release)) - t)) - -(defun motion-event-p (object) - "Return t if OBJECT is a mouse motion event." - (and (event-live-p object) (eq 'motion (event-type object)))) - -(defun mouse-event-p (object) - "Return t if OBJECT is a mouse button-press, button-release or motion event." - (and (event-live-p object) - (memq (event-type object) '(button-press button-release motion)) - t)) - -(defun process-event-p (object) - "Return t if OBJECT is a process-output event." - (and (event-live-p object) (eq 'process (event-type object)))) - -(defun timeout-event-p (object) - "Return t if OBJECT is a timeout event." - (and (event-live-p object) (eq 'timeout (event-type object)))) - -(defun eval-event-p (object) - "Return t if OBJECT is an eval event." - (and (event-live-p object) (eq 'eval (event-type object)))) - -(defun misc-user-event-p (object) - "Return t if OBJECT is a misc-user event. -A misc-user event is a user event that is not a keypress or mouse click; -normally this means a menu selection or scrollbar action." - (and (event-live-p object) (eq 'misc-user (event-type object)))) - -;; You could just as easily use event-glyph but we include this for -;; consistency. - -(defun event-over-glyph-p (object) - "Return t if OBJECT is a mouse event occurring over a glyph. -Mouse events are events of type button-press, button-release or motion." - (and (event-live-p object) (event-glyph object) t)) - -(defun keyboard-translate (&rest pairs) - "Translate character or keysym FROM to TO at a low level. -Multiple FROM-TO pairs may be specified. - -See `keyboard-translate-table' for more information." - (while pairs - (puthash (pop pairs) (pop pairs) keyboard-translate-table))) - -(put 'backspace 'ascii-character ?\b) -(put 'delete 'ascii-character ?\177) -(put 'tab 'ascii-character ?\t) -(put 'linefeed 'ascii-character ?\n) -(put 'clear 'ascii-character 12) -(put 'return 'ascii-character ?\r) -(put 'escape 'ascii-character ?\e) -(put 'space 'ascii-character ? ) - - ;; Do the same voodoo for the keypad keys. I used to bind these to keyboard - ;; macros (for instance, kp-0 was bound to "0") so that they would track the - ;; bindings of the corresponding keys by default, but that made the display - ;; of M-x describe-bindings much harder to read, so now we'll just bind them - ;; to self-insert by default. Not a big difference... - -(put 'kp-0 'ascii-character ?0) -(put 'kp-1 'ascii-character ?1) -(put 'kp-2 'ascii-character ?2) -(put 'kp-3 'ascii-character ?3) -(put 'kp-4 'ascii-character ?4) -(put 'kp-5 'ascii-character ?5) -(put 'kp-6 'ascii-character ?6) -(put 'kp-7 'ascii-character ?7) -(put 'kp-8 'ascii-character ?8) -(put 'kp-9 'ascii-character ?9) - -(put 'kp-space 'ascii-character ? ) -(put 'kp-tab 'ascii-character ?\t) -(put 'kp-enter 'ascii-character ?\r) -(put 'kp-equal 'ascii-character ?=) -(put 'kp-multiply 'ascii-character ?*) -(put 'kp-add 'ascii-character ?+) -(put 'kp-separator 'ascii-character ?,) -(put 'kp-subtract 'ascii-character ?-) -(put 'kp-decimal 'ascii-character ?.) -(put 'kp-divide 'ascii-character ?/) - -;;; events.el ends here
--- a/lisp/prim/extents.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,92 +0,0 @@ -;;; extents.el --- miscellaneous extent functions not written in C - -;;;; Copyright (C) 1993, 1994 Free Software Foundation, Inc. - -;; Keywords: internal - -;; 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, 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: Not in FSF. - -; some help from stig@hackvan.com here. - -;; an alternative to map-extents. -(defun mapcar-extents (function &optional predicate buffer-or-string from to - flags property value) - "Applies FUNCTION to all extents which overlap a region in BUFFER-OR-STRING. -The region is delimited by FROM and TO. FUNCTION is called with -one argument, the extent. A list of the values returned by FUNCTION -is returned. An optional PREDICATE may be used to further limit the -extents over which FUNCTION is mapped. The optional arguments FLAGS, -PROPERTY, and VALUE may also be used to control the extents passed to -PREDICATE or FUNCTION. See also `map-extents'." - (let (*result*) - (map-extents (if predicate - #'(lambda (ex junk) - (and (funcall predicate ex) - (setq *result* (cons (funcall function ex) - *result*))) - nil) - #'(lambda (ex junk) - (setq *result* (cons (funcall function ex) - *result*)) - nil)) - buffer-or-string from to nil flags property value) - (nreverse *result*))) - -(defun extent-list (&optional buffer-or-string from to flags) - "Return a list of the extents in BUFFER-OR-STRING. -BUFFER-OR-STRING defaults to the current buffer if omitted. -FROM and TO can be used to limit the range over which extents are -returned; if omitted, all extents in the buffer or string are returned. - -More specifically, if a range is specified using FROM and TO, only -extents that overlap the range (i.e. begin or end inside of the range) -are included in the list. FROM and TO default to the beginning and -end of BUFFER-OR-STRING, respectively. - -FLAGS controls how end cases are treated. For a discussion of this, -and exactly what ``overlap'' means, see `map-extents'. - -If you want to map a function over the extents in a buffer or string, -consider using `map-extents' or `mapcar-extents' instead." - (mapcar-extents 'identity nil buffer-or-string from to flags)) - -(defun extent-string (extent) - "Return the string delimited by the bounds of EXTENT." - (let ((object (extent-object extent))) - (if (bufferp object) - (buffer-substring (extent-start-position extent) - (extent-end-position extent) - object) - (substring object - (extent-start-position extent) - (extent-end-position extent))))) - -(defun extent-descendants (extent) - "Return a list of all descendants of EXTENT, including EXTENT. -This recursively applies `extent-children' to any children of -EXTENT, until no more children can be found." - (let ((children (extent-children extent))) - (if children - (apply 'nconc (mapcar 'extent-descendants children)) - (list extent)))) - -(defun set-extent-keymap (extent keymap) - "Set EXTENT's `keymap' property to KEYMAP." - (set-extent-property extent 'keymap keymap))
--- a/lisp/prim/faces.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1651 +0,0 @@ -;;; faces.el --- Lisp interface to the C "face" structure - -;; Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc. -;; Copyright (C) 1995 Board of Trustees, University of Illinois -;; Copyright (C) 1995, 1996 Ben Wing - -;; Author: Ben Wing <wing@666.com> -;; Keywords: faces internal -;; -;; face implementation #1 (used Lisp vectors and parallel C vectors; -;; FSFmacs still uses this) authored by Jamie Zawinski <jwz@netscape.com> -;; pre Lucid-Emacs 19.0. -;; -;; face implementation #2 (used one face object per frame per face) -;; authored by Jamie Zawinski for 19.9. -;; -;; face implementation #3 (use one face object per face) originally -;; authored for 19.12 by Chuck Thompson <cthomp@cs.uiuc.edu>, -;; rewritten by Ben Wing with the advent of specifiers. - -;; 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 synched with FSF. Almost completely divergent. -;;; Some stuff in FSF's faces.el is in our x-faces.el. - -(defun read-face-name (prompt) - (let (face) - (while (= (length face) 0) ; nil or "" - (setq face (completing-read prompt - (mapcar (lambda (x) (list (symbol-name x))) - (face-list)) - nil t))) - (intern face))) - -(defun face-interactive (what &optional bool) - (let* ((fn (intern (concat "face-" what "-instance"))) - (face (read-face-name (format "Set %s of face: " what))) - (default (if (fboundp fn) - ;; #### we should distinguish here between - ;; explicitly setting the value to be the - ;; same as the default face's value, and - ;; not setting a value at all. - (funcall fn face))) - (value (if bool - (y-or-n-p (format "Should face %s be %s? " - (symbol-name face) bool)) - (read-string (format "Set %s of face %s to: " - what (symbol-name face)) - (cond ((font-instance-p default) - (font-instance-name default)) - ((color-instance-p default) - (color-instance-name default)) - ((image-instance-p default) - (image-instance-file-name default)) - (t default)))))) - (list face (if (equal value "") nil value)))) - -(defconst built-in-face-specifiers - (built-in-face-specifiers) - "A list of the built-in face properties that are specifiers.") - -(defun face-property (face property &optional locale tag-set exact-p) - "Return FACE's value of the given PROPERTY. - -If LOCALE is omitted, the FACE's actual value for PROPERTY will be - returned. For built-in properties, this will be a specifier object - of a type appropriate to the property (e.g. a font or color - specifier). For other properties, this could be anything. - -If LOCALE is supplied, then instead of returning the actual value, - the specification(s) for the given locale or locale type will - be returned. This will only work if the actual value of - PROPERTY is a specifier (this will always be the case for built-in - properties, but not or not may apply to user-defined properties). - If the actual value of PROPERTY is not a specifier, this value - will simply be returned regardless of LOCALE. - -The return value will be a list of instantiators (e.g. strings - specifying a font or color name), or a list of specifications, each - of which is a cons of a locale and a list of instantiators. - Specifically, if LOCALE is a particular locale (a buffer, window, - frame, device, or 'global), a list of instantiators for that locale - will be returned. Otherwise, if LOCALE is a locale type (one of - the symbols 'buffer, 'window, 'frame, or 'device), the specifications - for all locales of that type will be returned. Finally, if LOCALE is - 'all, the specifications for all locales of all types will be returned. - -The specifications in a specifier determine what the value of - PROPERTY will be in a particular \"domain\" or set of circumstances, - which is typically a particular Emacs window along with the buffer - it contains and the frame and device it lies within. The value - is derived from the instantiator associated with the most specific - locale (in the order buffer, window, frame, device, and 'global) - that matches the domain in question. In other words, given a domain - (i.e. an Emacs window, usually), the specifier for PROPERTY will first - be searched for a specification whose locale is the buffer contained - within that window; then for a specification whose locale is the window - itself; then for a specification whose locale is the frame that the - window is contained within; etc. The first instantiator that is - valid for the domain (usually this means that the instantiator is - recognized by the device [i.e. the X server or TTY device] that the - domain is on. The function `face-property-instance' actually does - all this, and is used to determine how to display the face. - -See `set-face-property' for the built-in property-names." - - (setq face (get-face face)) - (let ((value (get face property))) - (if (and locale - (or (memq property built-in-face-specifiers) - (specifierp value))) - (setq value (specifier-specs value locale tag-set exact-p))) - value)) - -(defun convert-face-property-into-specifier (face property) - "Convert PROPERTY on FACE into a specifier, if it's not already." - (setq face (get-face face)) - (let ((specifier (get face property))) - ;; if a user-property does not have a specifier but a - ;; locale was specified, put a specifier there. - ;; If there was already a value there, convert it to a - ;; specifier with the value as its 'global instantiator. - (unless (specifierp specifier) - (let ((new-specifier (make-specifier 'generic))) - (if (or (not (null specifier)) - ;; make sure the nil returned from `get' wasn't - ;; actually the value of the property - (null (get face property t))) - (add-spec-to-specifier new-specifier specifier)) - (setq specifier new-specifier) - (put face property specifier))))) - -(defun face-property-instance (face property - &optional domain default no-fallback) - "Return the instance of FACE's PROPERTY in the specified DOMAIN. - -Under most circumstances, DOMAIN will be a particular window, - and the returned instance describes how the specified property - actually is displayed for that window and the particular buffer - in it. Note that this may not be the same as how the property - appears when the buffer is displayed in a different window or - frame, or how the property appears in the same window if you - switch to another buffer in that window; and in those cases, - the returned instance would be different. - -The returned instance will typically be a color-instance, - font-instance, or pixmap-instance object, and you can query - it using the appropriate object-specific functions. For example, - you could use `color-instance-rgb-components' to find out the - RGB (red, green, and blue) components of how the 'background - property of the 'highlight face is displayed in a particular - window. The results might be different from the results - you would get for another window (perhaps the user - specified a different color for the frame that window is on; - or perhaps the same color was specified but the window is - on a different X server, and that X server has different RGB - values for the color from this one). - -DOMAIN defaults to the selected window if omitted. - -DOMAIN can be a frame or device, instead of a window. The value - returned for a such a domain is used in special circumstances - when a more specific domain does not apply; for example, a frame - value might be used for coloring a toolbar, which is conceptually - attached to a frame rather than a particular window. The value - is also useful in determining what the value would be for a - particular window within the frame or device, if it is not - overridden by a more specific specification. - -If PROPERTY does not name a built-in property, its value will - simply be returned unless it is a specifier object, in which case - it will be instanced using `specifier-instance'. - -Optional arguments DEFAULT and NO-FALLBACK are the same as in - `specifier-instance'." - - (setq face (get-face face)) - (let ((value (get face property))) - (if (specifierp value) - (setq value (specifier-instance value domain default no-fallback))) - value)) - -(defun face-property-matching-instance (face property matchspec - &optional domain default - no-fallback) - "Return the instance of FACE's PROPERTY matching MATCHSPEC in DOMAIN. -Currently the only useful value for MATCHSPEC is a charset, when used -in conjunction with the face's font; this allows you to retrieve a -font that can be used to display a particular charset, rather than just -any font. - -Other than MATCHSPEC, this function is identical to `face-property-instance'. -See also `specifier-matching-instance' for a fuller description of the -matching process." - - (setq face (get-face face)) - (let ((value (get face property))) - (if (specifierp value) - (setq value (specifier-matching-instance value matchspec domain - default no-fallback))) - value)) - -(defun set-face-property (face property value &optional locale tag-set - how-to-add) - "Change a property of a FACE. - -NOTE: If you want to remove a property from a face, use `remove-face-property' - rather than attempting to set a value of nil for the property. - -For built-in properties, the actual value of the property is a - specifier and you cannot change this; but you can change the - specifications within the specifier, and that is what this function - will do. For user-defined properties, you can use this function - to either change the actual value of the property or, if this value - is a specifier, change the specifications within it. - -If PROPERTY is a built-in property, the specifications to be added to - this property can be supplied in many different ways: - - -- If VALUE is a simple instantiator (e.g. a string naming a font or - color) or a list of instantiators, then the instantiator(s) will - be added as a specification of the property for the given LOCALE - (which defaults to 'global if omitted). - -- If VALUE is a list of specifications (each of which is a cons of - a locale and a list of instantiators), then LOCALE must be nil - (it does not make sense to explicitly specify a locale in this - case), and specifications will be added as given. - -- If VALUE is a specifier (as would be returned by `face-property' - if no LOCALE argument is given), then some or all of the - specifications in the specifier will be added to the property. - In this case, the function is really equivalent to - `copy-specifier' and LOCALE has the same semantics (if it is - a particular locale, the specification for the locale will be - copied; if a locale type, specifications for all locales of - that type will be copied; if nil or 'all, then all - specifications will be copied). - -HOW-TO-ADD should be either nil or one of the symbols 'prepend, - 'append, 'remove-tag-set-prepend, 'remove-tag-set-append, 'remove-locale, - 'remove-locale-type, or 'remove-all. See `copy-specifier' and - `add-spec-to-specifier' for a description of what each of - these means. Most of the time, you do not need to worry about - this argument; the default behavior usually is fine. - -In general, it is OK to pass an instance object (e.g. as returned - by `face-property-instance') as an instantiator in place of - an actual instantiator. In such a case, the instantiator used - to create that instance object will be used (for example, if - you set a font-instance object as the value of the 'font - property, then the font name used to create that object will - be used instead). If some cases, however, doing this - conversion does not make sense, and this will be noted in - the documentation for particular types of instance objects. - -If PROPERTY is not a built-in property, then this function will - simply set its value if LOCALE is nil. However, if LOCALE is - given, then this function will attempt to add VALUE as the - instantiator for the given LOCALE, using `add-spec-to-specifier'. - If the value of the property is not a specifier, it will - automatically be converted into a 'generic specifier. - - -The following symbols have predefined meanings: - - foreground The foreground color of the face. - For valid instantiators, see `color-specifier-p'. - - background The background color of the face. - For valid instantiators, see `color-specifier-p'. - - font The font used to display text covered by this face. - For valid instantiators, see `font-specifier-p'. - - display-table The display table of the face. - This should be a vector of 256 elements. - - background-pixmap The pixmap displayed in the background of the face. - Only used by faces on X devices. - For valid instantiators, see `image-specifier-p'. - - underline Underline all text covered by this face. - For valid instantiators, see `face-boolean-specifier-p'. - - strikethru Draw a line through all text covered by this face. - For valid instantiators, see `face-boolean-specifier-p'. - - highlight Highlight all text covered by this face. - Only used by faces on TTY devices. - For valid instantiators, see `face-boolean-specifier-p'. - - dim Dim all text covered by this face. - Only used by faces on TTY devices. - For valid instantiators, see `face-boolean-specifier-p'. - - blinking Blink all text covered by this face. - Only used by faces on TTY devices. - For valid instantiators, see `face-boolean-specifier-p'. - - reverse Reverse the foreground and background colors. - Only used by faces on TTY devices. - For valid instantiators, see `face-boolean-specifier-p'. - - doc-string Description of what the face's normal use is. - NOTE: This is not a specifier, unlike all - the other built-in properties, and cannot - contain locale-specific values." - - (setq face (get-face face)) - (if (memq property built-in-face-specifiers) - (set-specifier (get face property) value locale tag-set how-to-add) - - ;; This section adds user defined properties. - (if (not locale) - (put face property value) - (convert-face-property-into-specifier face property) - (add-spec-to-specifier (get face property) value locale tag-set - how-to-add))) - value) - -(defun remove-face-property (face property &optional locale tag-set exact-p) - "Remove a property from a face. -For built-in properties, this is analogous to `remove-specifier'. -See `remove-specifier' for the meaning of the LOCALE, TAG-SET, and EXACT-P -arguments." - (or locale (setq locale 'all)) - (if (memq property built-in-face-specifiers) - (remove-specifier (face-property face property) locale tag-set exact-p) - (if (eq locale 'all) - (remprop (get-face face) property) - (convert-face-property-into-specifier face property) - (remove-specifier (face-property face property) locale tag-set - exact-p)))) - -(defun reset-face (face &optional locale tag-set exact-p) - "Clear all existing built-in specifications from FACE. -This makes FACE inherit all its display properties from 'default. -WARNING: Be absolutely sure you want to do this!!! It is a dangerous -operation and is not undoable. - -The arguments LOCALE, TAG-SET and EXACT-P are the same as for -`remove-specifier'." - (mapc (lambda (x) - (remove-specifier (face-property face x) locale tag-set exact-p)) - built-in-face-specifiers) - nil) - -(defun set-face-parent (face parent &optional locale tag-set how-to-add) - "Set the parent of FACE to PARENT, for all properties. -This makes all properties of FACE inherit from PARENT." - (setq parent (get-face parent)) - (mapcar (lambda (x) - (set-face-property face x (vector parent) locale tag-set - how-to-add)) - (delq 'display-table - (delq 'background-pixmap - (copy-sequence built-in-face-specifiers)))) - (set-face-background-pixmap face (vector 'inherit ':face parent) - locale tag-set how-to-add) - nil) - -(defun face-doc-string (face) - "Return the documentation string for FACE." - (face-property face 'doc-string)) - -(defun set-face-doc-string (face doc-string) - "Change the documentation string of FACE to DOC-STRING." - (interactive (face-interactive "doc-string")) - (set-face-property face 'doc-string doc-string)) - -(defun face-font-name (face &optional domain charset) - "Return the font name of the given face, or nil if it is unspecified. -DOMAIN is as in `face-font-instance'." - (let ((f (face-font-instance face domain charset))) - (and f (font-instance-name f)))) - -(defun face-font (face &optional locale tag-set exact-p) - "Return the font of the given face, or nil if it is unspecified. - -FACE may be either a face object or a symbol representing a face. - -LOCALE may be a locale (the instantiators for that particular locale - will be returned), a locale type (the specifications for all locales - of that type will be returned), 'all (all specifications will be - returned), or nil (the actual specifier object will be returned). - -See `face-property' for more information." - (face-property face 'font locale tag-set exact-p)) - -(defun face-font-instance (face &optional domain charset) - "Return the instance of the given face's font in the given domain. - -FACE may be either a face object or a symbol representing a face. - -Normally DOMAIN will be a window or nil (meaning the selected window), - and an instance object describing how the font appears in that - particular window and buffer will be returned. - -See `face-property-instance' for more information." - (if charset - (face-property-matching-instance face 'font charset domain) - (face-property-instance face 'font domain))) - -(defun set-face-font (face font &optional locale tag-set how-to-add) - "Change the font of the given face. - -FACE may be either a face object or a symbol representing a face. - -FONT should be an instantiator (see `font-specifier-p'), a list of - instantiators, an alist of specifications (each mapping a - locale to an instantiator list), or a font specifier object. - -If FONT is an alist, LOCALE must be omitted. If FONT is a - specifier object, LOCALE can be a locale, a locale type, 'all, - or nil; see `copy-specifier' for its semantics. Otherwise LOCALE - specifies the locale under which the specified instantiator(s) - will be added, and defaults to 'global. - -See `set-face-property' for more information." - (interactive (face-interactive "font")) - (set-face-property face 'font font locale tag-set how-to-add)) - -(defun face-foreground (face &optional locale tag-set exact-p) - "Return the foreground of the given face, or nil if it is unspecified. - -FACE may be either a face object or a symbol representing a face. - -LOCALE may be a locale (the instantiators for that particular locale - will be returned), a locale type (the specifications for all locales - of that type will be returned), 'all (all specifications will be - returned), or nil (the actual specifier object will be returned). - -See `face-property' for more information." - (face-property face 'foreground locale tag-set exact-p)) - -(defun face-foreground-instance (face &optional domain default no-fallback) - "Return the instance of the given face's foreground in the given domain. - -FACE may be either a face object or a symbol representing a face. - -Normally DOMAIN will be a window or nil (meaning the selected window), - and an instance object describing how the foreground appears in that - particular window and buffer will be returned. - -See `face-property-instance' for more information." - (face-property-instance face 'foreground domain default no-fallback)) - -(defun face-foreground-name (face &optional domain default no-fallback) - "Return the name of the given face's foreground color in the given domain. - -FACE may be either a face object or a symbol representing a face. - -Normally DOMAIN will be a window or nil (meaning the selected window), - and an instance object describing how the background appears in that - particular window and buffer will be returned. - -See `face-property-instance' for more information." - (color-instance-name (face-foreground-instance - face domain default no-fallback))) - -(defun set-face-foreground (face color &optional locale tag-set how-to-add) - "Change the foreground of the given face. - -FACE may be either a face object or a symbol representing a face. - -COLOR should be an instantiator (see `color-specifier-p'), a list of - instantiators, an alist of specifications (each mapping a locale to - an instantiator list), or a color specifier object. - -If COLOR is an alist, LOCALE must be omitted. If COLOR is a - specifier object, LOCALE can be a locale, a locale type, 'all, - or nil; see `copy-specifier' for its semantics. Otherwise LOCALE - specifies the locale under which the specified instantiator(s) - will be added, and defaults to 'global. - -See `set-face-property' for more information." - (interactive (face-interactive "foreground")) - (set-face-property face 'foreground color locale tag-set how-to-add)) - -(defun face-background (face &optional locale tag-set exact-p) - "Return the background of the given face, or nil if it is unspecified. - -FACE may be either a face object or a symbol representing a face. - -LOCALE may be a locale (the instantiators for that particular locale - will be returned), a locale type (the specifications for all locales - of that type will be returned), 'all (all specifications will be - returned), or nil (the actual specifier object will be returned). - -See `face-property' for more information." - (face-property face 'background locale tag-set exact-p)) - -(defun face-background-instance (face &optional domain default no-fallback) - "Return the instance of the given face's background in the given domain. - -FACE may be either a face object or a symbol representing a face. - -Normally DOMAIN will be a window or nil (meaning the selected window), - and an instance object describing how the background appears in that - particular window and buffer will be returned. - -See `face-property-instance' for more information." - (face-property-instance face 'background domain default no-fallback)) - -(defun face-background-name (face &optional domain default no-fallback) - "Return the name of the given face's background color in the given domain. - -FACE may be either a face object or a symbol representing a face. - -Normally DOMAIN will be a window or nil (meaning the selected window), - and an instance object describing how the background appears in that - particular window and buffer will be returned. - -See `face-property-instance' for more information." - (color-instance-name (face-background-instance - face domain default no-fallback))) - -(defun set-face-background (face color &optional locale tag-set how-to-add) - "Change the background of the given face. - -FACE may be either a face object or a symbol representing a face. - -COLOR should be an instantiator (see `color-specifier-p'), a list of - instantiators, an alist of specifications (each mapping a locale to - an instantiator list), or a color specifier object. - -If COLOR is an alist, LOCALE must be omitted. If COLOR is a - specifier object, LOCALE can be a locale, a locale type, 'all, - or nil; see `copy-specifier' for its semantics. Otherwise LOCALE - specifies the locale under which the specified instantiator(s) - will be added, and defaults to 'global. - -See `set-face-property' for more information." - (interactive (face-interactive "background")) - (set-face-property face 'background color locale tag-set how-to-add)) - -(defun face-background-pixmap (face &optional locale tag-set exact-p) - "Return the background pixmap of the given face, or nil if it is unspecified. -This property is only used on X devices. - -FACE may be either a face object or a symbol representing a face. - -LOCALE may be a locale (the instantiators for that particular locale - will be returned), a locale type (the specifications for all locales - of that type will be returned), 'all (all specifications will be - returned), or nil (the actual specifier object will be returned). - -See `face-property' for more information." - (face-property face 'background-pixmap locale tag-set exact-p)) - -(defun face-background-pixmap-instance (face &optional domain default - no-fallback) - "Return the instance of the given face's background pixmap in the given domain. - -FACE may be either a face object or a symbol representing a face. - -Normally DOMAIN will be a window or nil (meaning the selected window), - and an instance object describing how the background appears in that - particular window and buffer will be returned. - -See `face-property-instance' for more information." - (face-property-instance face 'background-pixmap domain default no-fallback)) - -(defun set-face-background-pixmap (face pixmap &optional locale tag-set - how-to-add) - "Change the background pixmap of the given face. -This property is only used on X devices. - -FACE may be either a face object or a symbol representing a face. - -PIXMAP should be an instantiator (see `image-specifier-p'), a list - of instantiators, an alist of specifications (each mapping a locale - to an instantiator list), or an image specifier object. - -If PIXMAP is an alist, LOCALE must be omitted. If PIXMAP is a - specifier object, LOCALE can be a locale, a locale type, 'all, - or nil; see `copy-specifier' for its semantics. Otherwise LOCALE - specifies the locale under which the specified instantiator(s) - will be added, and defaults to 'global. - -See `set-face-property' for more information." - (interactive (face-interactive "background-pixmap")) - (set-face-property face 'background-pixmap pixmap locale tag-set how-to-add)) - -(defun face-display-table (face &optional locale tag-set exact-p) - "Return the display table of the given face. - -A vector (as returned by `make-display-table') will be returned. - -LOCALE may be a locale (the instantiators for that particular locale - will be returned), a locale type (the specifications for all locales - of that type will be returned), 'all (all specifications will be - returned), or nil (the actual specifier object will be returned). - -See `face-property' for more information." - (face-property face 'display-table locale tag-set exact-p)) - -(defun face-display-table-instance (face &optional domain default no-fallback) - "Return the instance of FACE's display table in DOMAIN. -A vector (as returned by `make-display-table') will be returned. - -See `face-property-instance' for the semantics of the DOMAIN argument." - (face-property-instance face 'display-table domain default no-fallback)) - -(defun set-face-display-table (face display-table &optional locale tag-set - how-to-add) - "Change the display table of the given face. -DISPLAY-TABLE should be a vector as returned by `make-display-table'. - -See `set-face-property' for the semantics of the LOCALE, TAG-SET, and - HOW-TO-ADD arguments." - (interactive (face-interactive "display-table")) - (set-face-property face 'display-table display-table locale tag-set - how-to-add)) - -;; The following accessors and mutators are, IMHO, good -;; implementation. Cf. with `make-face-bold'. - -(defun face-underline-p (face &optional domain default no-fallback) - "Return whether the given face is underlined. -See `face-property-instance' for the semantics of the DOMAIN argument." - (face-property-instance face 'underline domain default no-fallback)) - -(defun set-face-underline-p (face underline-p &optional locale tag-set - how-to-add) - "Change whether the given face is underlined. -UNDERLINE-P is normally a face-boolean instantiator; see - `face-boolean-specifier-p'. -See `set-face-property' for the semantics of the LOCALE, TAG-SET, and - HOW-TO-ADD arguments." - (interactive (face-interactive "underline-p" "underlined")) - (set-face-property face 'underline underline-p locale tag-set how-to-add)) - -(defun face-strikethru-p (face &optional domain default no-fallback) - "Return whether the given face is strikethru-d (i.e. struck through). -See `face-property-instance' for the semantics of the DOMAIN argument." - (face-property-instance face 'strikethru domain default no-fallback)) - -(defun set-face-strikethru-p (face strikethru-p &optional locale tag-set - how-to-add) - "Change whether the given face is strikethru-d (i.e. struck through). -STRIKETHRU-P is normally a face-boolean instantiator; see - `face-boolean-specifier-p'. -See `set-face-property' for the semantics of the LOCALE, TAG-SET, and - HOW-TO-ADD arguments." - (interactive (face-interactive "strikethru-p" "strikethru-d")) - (set-face-property face 'strikethru strikethru-p locale tag-set how-to-add)) - -(defun face-highlight-p (face &optional domain default no-fallback) - "Return whether the given face is highlighted (TTY domains only). -See `face-property-instance' for the semantics of the DOMAIN argument." - (face-property-instance face 'highlight domain default no-fallback)) - -(defun set-face-highlight-p (face highlight-p &optional locale tag-set - how-to-add) - "Change whether the given face is highlighted (TTY locales only). -HIGHLIGHT-P is normally a face-boolean instantiator; see - `face-boolean-specifier-p'. -See `set-face-property' for the semantics of the LOCALE, TAG-SET, and - HOW-TO-ADD arguments." - (interactive (face-interactive "highlight-p" "highlighted")) - (set-face-property face 'highlight highlight-p locale tag-set how-to-add)) - -(defun face-dim-p (face &optional domain default no-fallback) - "Return whether the given face is dimmed (TTY domains only). -See `face-property-instance' for the semantics of the DOMAIN argument." - (face-property-instance face 'dim domain default no-fallback)) - -(defun set-face-dim-p (face dim-p &optional locale tag-set how-to-add) - "Change whether the given face is dimmed (TTY locales only). -DIM-P is normally a face-boolean instantiator; see - `face-boolean-specifier-p'. -See `set-face-property' for the semantics of the LOCALE, TAG-SET, and - HOW-TO-ADD arguments." - (interactive (face-interactive "dim-p" "dimmed")) - (set-face-property face 'dim dim-p locale tag-set how-to-add)) - -(defun face-blinking-p (face &optional domain default no-fallback) - "Return whether the given face is blinking (TTY domains only). -See `face-property-instance' for the semantics of the DOMAIN argument." - (face-property-instance face 'blinking domain default no-fallback)) - -(defun set-face-blinking-p (face blinking-p &optional locale tag-set - how-to-add) - "Change whether the given face is blinking (TTY locales only). -BLINKING-P is normally a face-boolean instantiator; see - `face-boolean-specifier-p'. -See `set-face-property' for the semantics of the LOCALE, TAG-SET, and - HOW-TO-ADD arguments." - (interactive (face-interactive "blinking-p" "blinking")) - (set-face-property face 'blinking blinking-p locale tag-set how-to-add)) - -(defun face-reverse-p (face &optional domain default no-fallback) - "Return whether the given face is reversed (TTY domains only). -See `face-property-instance' for the semantics of the DOMAIN argument." - (face-property-instance face 'reverse domain default no-fallback)) - -(defun set-face-reverse-p (face reverse-p &optional locale tag-set how-to-add) - "Change whether the given face is reversed (TTY locales only). -REVERSE-P is normally a face-boolean instantiator; see - `face-boolean-specifier-p'. -See `set-face-property' for the semantics of the LOCALE, TAG-SET, and - HOW-TO-ADD arguments." - (interactive (face-interactive "reverse-p" "reversed")) - (set-face-property face 'reverse reverse-p locale tag-set how-to-add)) - - -(defun face-property-equal (face1 face2 prop domain) - (equal (face-property-instance face1 prop domain) - (face-property-instance face2 prop domain))) - -(defun face-equal-loop (props face1 face2 domain) - (while (and props - (face-property-equal face1 face2 (car props) domain)) - (setq props (cdr props))) - (null props)) - -(defun face-equal (face1 face2 &optional domain) - "True if the given faces will display in the same way. -See `face-property-instance' for the semantics of the DOMAIN argument." - (if (null domain) (setq domain (selected-window))) - (if (not (valid-specifier-domain-p domain)) - (error "Invalid specifier domain")) - (let ((device (dfw-device domain)) - (common-props '(foreground background font display-table underline)) - (x-props '(background-pixmap strikethru)) - (tty-props '(highlight dim blinking reverse))) - - ;; First check the properties which are used in common between the - ;; x and tty devices. Then, check those properties specific to - ;; the particular device type. - (and (face-equal-loop common-props face1 face2 domain) - (cond ((eq 'tty (device-type device)) - (face-equal-loop tty-props face1 face2 domain)) - ((eq 'x (device-type device)) - (face-equal-loop x-props face1 face2 domain)) - (t t))))) - -(defun face-differs-from-default-p (face &optional domain) - "True if the given face will display differently from the default face. -See `face-property-instance' for the semantics of the DOMAIN argument." - (not (face-equal face 'default domain))) - - -;; This function is a terrible, disgusting hack!!!! Need to -;; separate out the font elements as separate face properties! - -;; WE DEMAND LEXICAL SCOPING!!! -;; WE DEMAND LEXICAL SCOPING!!! -;; WE DEMAND LEXICAL SCOPING!!! -;; WE DEMAND LEXICAL SCOPING!!! -;; WE DEMAND LEXICAL SCOPING!!! -;; WE DEMAND LEXICAL SCOPING!!! -;; WE DEMAND LEXICAL SCOPING!!! -;; WE DEMAND LEXICAL SCOPING!!! -;; WE DEMAND LEXICAL SCOPING!!! -;; WE DEMAND LEXICAL SCOPING!!! -;; WE DEMAND LEXICAL SCOPING!!! -;; WE DEMAND LEXICAL SCOPING!!! -;; WE DEMAND LEXICAL SCOPING!!! -;; WE DEMAND LEXICAL SCOPING!!! -;; WE DEMAND LEXICAL SCOPING!!! -(defun frob-face-property (face property func &optional locale) - "Change the specifier for FACE's PROPERTY according to FUNC, in LOCALE. -This function is ugly and messy and is primarily used as an internal -helper function for `make-face-bold' et al., so you probably don't -want to use it or read the rest of the documentation. But if you do ... - -FUNC should be a function of two arguments (an instance and a device) -that returns a modified name that is valid for the given device. -If LOCALE specifies a valid domain (i.e. a window, frame, or device), -this function instantiates the specifier over that domain, applies FUNC -to the resulting instance, and adds the result back as an instantiator -for that locale. Otherwise, LOCALE should be a locale, locale type, or -'all (defaults to 'all if omitted). For each specification thusly -included: if the locale given is a valid domain, FUNC will be -iterated over all valid instantiators for the device of the domain -until a non-nil result is found (if there is no such result, the -first valid instantiator is used), and that result substituted for -the specification; otherwise, the process just outlined is -iterated over each existing device and the concatenated results -substituted for the specification." - (let ((sp (face-property face property))) - (if (valid-specifier-domain-p locale) - ;; this is easy. - (let* ((inst (face-property-instance face property locale)) - (name (and inst (funcall func inst (dfw-device locale))))) - (when name - (add-spec-to-specifier sp name locale))) - ;; otherwise, map over all specifications ... - ;; but first, some further kludging: - ;; (1) if we're frobbing the global property, make sure - ;; that something is there (copy from the default face, - ;; if necessary). Otherwise, something like - ;; (make-face-larger 'modeline) - ;; won't do anything at all if the modeline simply - ;; inherits its font from 'default. - ;; (2) if we're frobbing a particular locale, nothing would - ;; happen if that locale has no instantiators. So signal - ;; an error to indicate this. - (if (and (or (eq locale 'global) (eq locale 'all) (not locale)) - (not (face-property face property 'global))) - (copy-specifier (face-property 'default property) - (face-property face property) - 'global)) - (if (and (valid-specifier-locale-p locale) - (not (face-property face property locale))) - (error "Property must have a specification in locale %S" locale)) - (map-specifier - sp - (lambda (sp locale inst-list func) - (let* ((device (dfw-device locale)) - ;; if a device can be derived from the locale, - ;; call frob-face-property-1 for that device. - ;; Otherwise map frob-face-property-1 over each device. - (result - (if device - (list (frob-face-property-1 sp device inst-list func)) - (mapcar (lambda (device) - (frob-face-property-1 sp device - inst-list func)) - (device-list)))) - new-result) - ;; remove duplicates and nils from the obtained list of - ;; instantiators. - (mapcar (lambda (arg) - (when (and arg (not (member arg new-result))) - (setq new-result (cons arg new-result)))) - result) - ;; add back in. - (add-spec-list-to-specifier sp (list (cons locale new-result))) - ;; tell map-specifier to keep going. - nil)) - locale - func)))) - -(defun frob-face-property-1 (sp device inst-list func) - (let - (first-valid result) - (while (and inst-list (not result)) - (let* ((inst-pair (car inst-list)) - (tag-set (car inst-pair)) - (sp-inst (specifier-instance-from-inst-list - sp device (list inst-pair)))) - (if sp-inst - (progn - (if (not first-valid) - (setq first-valid inst-pair)) - (setq result (funcall func sp-inst device)) - (if result - (setq result (cons tag-set result)))))) - (setq inst-list (cdr inst-list))) - (or result first-valid))) - -(defun frob-face-font-2 (face locale unfrobbed-face frobbed-face - tty-thunk x-thunk standard-face-mapping) - ;; another kludge to make things more intuitive. If we're - ;; inheriting from a standard face in this locale, frob the - ;; inheritance as appropriate. Else, if, after the first X frobbing - ;; pass, the face hasn't changed and still looks like the standard - ;; unfrobbed face (e.g. 'default), make it inherit from the standard - ;; frobbed face (e.g. 'bold). Regardless of things, do the TTY - ;; frobbing. - - ;; yuck -- The LOCALE argument to make-face-bold is not actually a locale, - ;; but is a "locale, locale-type, or nil for all". So ... do our extra - ;; frobbing only if it's actually a locale; or for nil, do the frobbing - ;; on 'global. This specifier stuff needs some rethinking. - (let* ((the-locale (cond ((null locale) 'global) - ((valid-specifier-locale-p locale) locale) - (t nil))) - (specs (and the-locale (face-font face the-locale nil t))) - (change-it (and specs (cdr (assoc specs standard-face-mapping))))) - (if (and change-it - (not (memq (face-name (find-face face)) - '(default bold italic bold-italic)))) - (progn - (or (equal change-it t) - (set-face-property face 'font change-it the-locale)) - (funcall tty-thunk)) - (let* ((domain (cond ((null the-locale) nil) - ((valid-specifier-domain-p the-locale) the-locale) - ;; OK, this next one is truly a kludge, but - ;; it results in more intuitive behavior most - ;; of the time. (really!) - ((or (eq the-locale 'global) (eq the-locale 'all)) - (selected-device)) - (t nil))) - (inst (and domain (face-property-instance face 'font domain)))) - (funcall tty-thunk) - (funcall x-thunk) - ;; If it's reasonable to do the inherit-from-standard-face trick, - ;; and it's called for, then do it now. - (or (null domain) - (not (equal inst (face-property-instance face 'font domain))) - ;; don't do it for standard faces, or you'll get inheritance loops. - ;; #### This makes XEmacs seg fault! fix this bug. - (memq (face-name (find-face face)) - '(default bold italic bold-italic)) - (not (equal (face-property-instance face 'font domain) - (face-property-instance unfrobbed-face 'font domain))) - (set-face-property face 'font (vector frobbed-face) - the-locale)))))) - -(defun make-face-bold (face &optional locale) - "Make the face bold, if possible. -This will attempt to make the font bold for X locales and will set the -highlight flag for TTY locales. - -If LOCALE is nil, omitted, or `all', this will attempt to frob all -font specifications for FACE to make them appear bold. Similarly, if -LOCALE is a locale type, this frobs all font specifications for locales -of that type. If LOCALE is a particular locale, what happens depends on -what sort of locale is given. If you gave a device, frame, or window, -then it's always possible to determine what the font actually will be, -so this is determined and the resulting font is frobbed and added back as a -specification for this locale. If LOCALE is a buffer, however, you can't -determine what the font will actually be unless there's actually a -specification given for that particular buffer (otherwise, it depends -on what window and frame the buffer appears in, and might not even be -well-defined if the buffer appears multiple times in different places); -therefore you will get an error unless there's a specification for the -buffer. - -Finally, in some cases (specifically, when LOCALE is not a locale type), -if the frobbing didn't actually make the font look any different -\(this happens, for example, if your font specification is already bold -or has no bold equivalent), and currently looks like the font of the -'default face, it is set to inherit from the 'bold face. This is kludgy -but it makes `make-face-bold' have more intuitive behavior in many -circumstances." - (interactive (list (read-face-name "Make which face bold: "))) - (frob-face-font-2 - face locale 'default 'bold - (lambda () - ;; handle TTY specific entries - (when (featurep 'tty) - (set-face-highlight-p face t locale 'tty))) - (lambda () - ;; handle X specific entries - (frob-face-property face 'font 'x-make-font-bold locale)) - '(([default] . [bold]) - ([bold] . t) - ([italic] . [bold-italic]) - ([bold-italic] . t)))) - -(defun make-face-italic (face &optional locale) - "Make the face italic, if possible. -This will attempt to make the font italic for X locales and will set -the underline flag for TTY locales. -See `make-face-bold' for the semantics of the LOCALE argument and -for more specifics on exactly how this function works." - (interactive (list (read-face-name "Make which face italic: "))) - (frob-face-font-2 - face locale 'default 'italic - (lambda () - ;; handle TTY specific entries - (when (featurep 'tty) - (set-face-underline-p face t locale 'tty))) - (lambda () - ;; handle X specific entries - (frob-face-property face 'font 'x-make-font-italic locale)) - '(([default] . [italic]) - ([bold] . [bold-italic]) - ([italic] . t) - ([bold-italic] . t)))) - -(defun make-face-bold-italic (face &optional locale) - "Make the face bold and italic, if possible. -This will attempt to make the font bold-italic for X locales and will -set the highlight and underline flags for TTY locales. -See `make-face-bold' for the semantics of the LOCALE argument and -for more specifics on exactly how this function works." - (interactive (list (read-face-name "Make which face bold-italic: "))) - (frob-face-font-2 - face locale 'default 'bold-italic - (lambda () - ;; handle TTY specific entries - (when (featurep 'tty) - (set-face-highlight-p face t locale 'tty) - (set-face-underline-p face t locale 'tty))) - (lambda () - ;; handle X specific entries - (frob-face-property face 'font 'x-make-font-bold-italic locale)) - '(([default] . [italic]) - ([bold] . [bold-italic]) - ([italic] . [bold-italic]) - ([bold-italic] . t)))) - -(defun make-face-unbold (face &optional locale) - "Make the face non-bold, if possible. -This will attempt to make the font non-bold for X locales and will -unset the highlight flag for TTY locales. -See `make-face-bold' for the semantics of the LOCALE argument and -for more specifics on exactly how this function works." - (interactive (list (read-face-name "Make which face non-bold: "))) - (frob-face-font-2 - face locale 'bold 'default - (lambda () - ;; handle TTY specific entries - (when (featurep 'tty) - (set-face-highlight-p face nil locale 'tty))) - (lambda () - ;; handle X specific entries - (frob-face-property face 'font 'x-make-font-unbold locale)) - '(([default] . t) - ([bold] . [default]) - ([italic] . t) - ([bold-italic] . [italic])))) - -(defun make-face-unitalic (face &optional locale) - "Make the face non-italic, if possible. -This will attempt to make the font non-italic for X locales and will -unset the underline flag for TTY locales. -See `make-face-bold' for the semantics of the LOCALE argument and -for more specifics on exactly how this function works." - (interactive (list (read-face-name "Make which face non-italic: "))) - (frob-face-font-2 - face locale 'italic 'default - (lambda () - ;; handle TTY specific entries - (when (featurep 'tty) - (set-face-underline-p face nil locale 'tty))) - (lambda () - ;; handle X specific entries - (frob-face-property face 'font 'x-make-font-unitalic locale)) - '(([default] . t) - ([bold] . t) - ([italic] . [default]) - ([bold-italic] . [bold])))) - - -;; Why do the following two functions lose so badly in so many -;; circumstances? - -(defun make-face-smaller (face &optional locale) - "Make the font of the given face be smaller, if possible. -LOCALE works as in `make-face-bold' et al., but the ``inheriting- -from-the-bold-face'' operations described there are not done -because they don't make sense in this context." - (interactive (list (read-face-name "Shrink which face: "))) - ;; handle X specific entries - (frob-face-property face 'font 'x-find-smaller-font locale)) - -(defun make-face-larger (face &optional locale) - "Make the font of the given face be larger, if possible. -See `make-face-smaller' for the semantics of the LOCALE argument." - (interactive (list (read-face-name "Enlarge which face: "))) - ;; handle X specific entries - (frob-face-property face 'font 'x-find-larger-font locale)) - -(defun invert-face (face &optional locale) - "Swap the foreground and background colors of the face." - (interactive (list (read-face-name "Invert face: "))) - (if (valid-specifier-domain-p locale) - (let ((foreface (face-foreground-instance face locale))) - (set-face-foreground face (face-background-instance face locale) - locale) - (set-face-background face foreface locale)) - (let ((forespec (copy-specifier (face-foreground face) nil locale))) - (copy-specifier (face-background face) (face-foreground face) locale) - (copy-specifier forespec (face-background face) locale)))) - - -;;; Convenience functions - -(defun face-ascent (face &optional domain charset) - "Return the ascent of a face. -See `face-property-instance' for the semantics of the DOMAIN argument." - (font-ascent (face-font face) domain charset)) - -(defun face-descent (face &optional domain charset) - "Return the descent of a face. -See `face-property-instance' for the semantics of the DOMAIN argument." - (font-descent (face-font face) domain charset)) - -(defun face-width (face &optional domain charset) - "Return the width of a face. -See `face-property-instance' for the semantics of the DOMAIN argument." - (font-width (face-font face) domain charset)) - -(defun face-height (face &optional domain charset) - "Return the height of a face. -See `face-property-instance' for the semantics of the DOMAIN argument." - (+ (face-ascent face domain charset) (face-descent face domain charset))) - -(defun face-proportional-p (face &optional domain charset) - "Return whether FACE is proportional. -See `face-property-instance' for the semantics of the DOMAIN argument." - (font-proportional-p (face-font face) domain charset)) - - -;; Functions that used to be in cus-face.el, but logically go here. - -(defcustom frame-background-mode nil - "*The brightness of the background. -Set this to the symbol dark if your background color is dark, light if -your background is light, or nil (default) if you want Emacs to -examine the brightness for you." - :group 'faces - :type '(choice (choice-item dark) - (choice-item light) - (choice-item :tag "Auto" nil))) - -;; The old variable that many people still have in .emacs files. -(define-obsolete-variable-alias 'custom-background-mode - 'frame-background-mode) - -(defun get-frame-background-mode (frame) - "Detect background mode for FRAME." - (let* ((color-instance (face-background-instance 'default frame)) - (mode (condition-case nil - (if (< (apply '+ (color-instance-rgb-components - color-instance)) 65536) - 'dark 'light) - ;; Here, we get an error on a TTY. As we don't have - ;; a good way of detecting whether a TTY is light or - ;; dark, we'll guess it's dark. - (error 'dark)))) - (set-frame-property frame 'background-mode mode) - mode)) - -(defun extract-custom-frame-properties (frame) - "Return a plist with the frame properties of FRAME used by custom." - (list 'type (or (frame-property frame 'display-type) - (device-type (frame-device frame))) - 'class (device-class (frame-device frame)) - 'background (or frame-background-mode - (frame-property frame 'background-mode) - (get-frame-background-mode frame)))) - -(defcustom init-face-from-resources t - "If non nil, attempt to initialize faces from the resource database." - :group 'faces - :type 'boolean) - -;; Old name, used by custom. Also, FSFmacs name. -(defvaralias 'initialize-face-resources 'init-face-from-resources) - -(defun face-spec-set (face spec &optional frame) - "Set FACE's face attributes according to the first matching entry in SPEC. -If optional FRAME is non-nil, set it for that frame only. -If it is nil, then apply SPEC to each frame individually. -See `defface' for information about SPEC." - (if frame - (progn - (reset-face face frame) - (face-display-set face spec frame) - (init-face-from-resources face frame)) - (let ((frames (relevant-custom-frames))) - (reset-face face) - (face-display-set face spec) - (while frames - (face-display-set face spec (car frames)) - (pop frames)) - (init-face-from-resources face)))) - -(defun face-display-set (face spec &optional frame) - "Set FACE to the attributes to the first matching entry in SPEC. -Iff optional FRAME is non-nil, set it for that frame only. -See `defface' for information about SPEC." - (while spec - (let ((display (caar spec)) - (atts (cadar spec))) - (pop spec) - (when (face-spec-set-match-display display frame) - ;; Avoid creating frame local duplicates of the global face. - (unless (and frame (eq display (get face 'custom-face-display))) - (apply 'face-custom-attributes-set face frame atts)) - (unless frame - (put face 'custom-face-display display)) - (setq spec nil))))) - -(defvar default-custom-frame-properties nil - "The frame properties used for the global faces. -Frames not matching these propertiess should have frame local faces. -The value should be nil, if uninitialized, or a plist otherwise. -See `defface' for a list of valid keys and values for the plist.") - -(defun get-custom-frame-properties (&optional frame) - "Return a plist with the frame properties of FRAME used by custom. -If FRAME is nil, return the default frame properties." - (cond (frame - ;; Try to get from cache. - (let ((cache (frame-property frame 'custom-properties))) - (unless cache - ;; Oh well, get it then. - (setq cache (extract-custom-frame-properties frame)) - ;; and cache it... - (set-frame-property frame 'custom-properties cache)) - cache)) - (default-custom-frame-properties) - (t - (setq default-custom-frame-properties - (extract-custom-frame-properties (selected-frame)))))) - -(defun face-spec-set-match-display (display frame) - "Non-nil iff DISPLAY matches FRAME. -DISPLAY is part of a spec such as can be used in `defface'. -If FRAME is nil, the current FRAME is used." - (if (eq display t) - t - (let* ((props (get-custom-frame-properties frame)) - (type (plist-get props 'type)) - (class (plist-get props 'class)) - (background (plist-get props 'background)) - (match t) - (entries display) - entry req options) - (while (and entries match) - (setq entry (car entries) - entries (cdr entries) - req (car entry) - options (cdr entry) - match (case req - (type (memq type options)) - (class (memq class options)) - (background (memq background options)) - (t (warn "Unknown req `%S' with options `%S'" - req options) - nil)))) - match))) - -(defun relevant-custom-frames () - "List of frames whose custom properties differ from the default." - (let ((relevant nil) - (default (get-custom-frame-properties)) - (frames (frame-list)) - frame) - (while frames - (setq frame (car frames) - frames (cdr frames)) - (unless (equal default (get-custom-frame-properties frame)) - (push frame relevant))) - relevant)) - -(defun initialize-custom-faces (&optional frame) - "Initialize all custom faces for FRAME. -If FRAME is nil or omitted, initialize them for all frames." - (mapc (lambda (symbol) - (let ((spec (or (get symbol 'saved-face) - (get symbol 'face-defface-spec)))) - (when spec - ;; No need to init-face-from-resources -- code in - ;; `init-frame-faces' does it already. - (face-display-set symbol spec frame)))) - (face-list))) - -(defun custom-initialize-frame (frame) - "Initialize frame-local custom faces for FRAME if necessary." - (unless (equal (get-custom-frame-properties) - (get-custom-frame-properties frame)) - (initialize-custom-faces frame))) - - -(defun make-empty-face (name &optional doc-string temporary) - "Like `make-face', but doesn't query the resource database." - (let ((init-face-from-resources nil)) - (make-face name doc-string temporary))) - -(defun init-face-from-resources (face &optional locale) - "Initialize FACE from the resource database. -If LOCALE is specified, it should be a frame, device, or 'global, and -the face will be resourced over that locale. Otherwise, the face will -be resourced over all possible locales (i.e. all frames, all devices, -and 'global)." - (cond ((null init-face-from-resources) - ;; Do nothing. - ) - ((not locale) - ;; Global, set for all frames. - (progn - (init-face-from-resources face 'global) - (let ((devices (device-list))) - (while devices - (init-face-from-resources face (car devices)) - (setq devices (cdr devices)))) - (let ((frames (frame-list))) - (while frames - (init-face-from-resources face (car frames)) - (setq frames (cdr frames)))))) - (t - ;; Specific. - (let ((devtype (cond ((devicep locale) (device-type locale)) - ((framep locale) (frame-type locale)) - (t nil)))) - (cond ((or (and (not devtype) (featurep 'x)) (eq 'x devtype)) - (x-init-face-from-resources face locale)) - ((or (not devtype) (eq 'tty devtype)) - ;; Nothing to do for TTYs? - )))))) - -(defun init-device-faces (device) - ;; First, add any device-local face resources. - (when init-face-from-resources - (loop for face in (face-list) do - (init-face-from-resources face device)) - ;; Then do any device-specific initialization. - (cond ((eq 'x (device-type device)) - (x-init-device-faces device)) - ;; Nothing to do for TTYs? - ) - (init-other-random-faces device))) - -(defun init-frame-faces (frame) - (when init-face-from-resources - ;; First, add any frame-local face resources. - (loop for face in (face-list) do - (init-face-from-resources face frame)) - ;; Then do any frame-specific initialization. - (cond ((eq 'x (frame-type frame)) - (x-init-frame-faces frame)) - ;; Is there anything which should be done for TTY's? - ))) - -;; #### This is somewhat X-specific, and is called when the first -;; X device is created (even if there were TTY devices created -;; beforehand). The concept of resources has not been generalized -;; outside of X-specificness, so we have to live with this -;; breach of device-independence. - -(defun init-global-faces () - ;; Look for global face resources. - (loop for face in (face-list) do - (init-face-from-resources face 'global)) - ;; Further X frobbing. - (x-init-global-faces) - ;; for bold and the like, make the global specification be bold etc. - ;; if the user didn't already specify a value. These will also be - ;; frobbed further in init-other-random-faces. - (unless (face-font 'bold 'global) - (make-face-bold 'bold 'global)) - ;; - (unless (face-font 'italic 'global) - (make-face-italic 'italic 'global)) - ;; - (unless (face-font 'bold-italic 'global) - (make-face-bold-italic 'bold-italic 'global) - (unless (face-font 'bold-italic 'global) - (copy-face 'bold 'bold-italic) - (make-face-italic 'bold-italic))) - - (when (face-equal 'bold 'bold-italic) - (copy-face 'italic 'bold-italic) - (make-face-bold 'bold-italic)) - ;; - ;; Nothing more to be done for X or TTY's? - ) - - -;; These warnings are there for a reason. Just specify your fonts -;; correctly. Deal with it. Additionally, one can use -;; `log-warning-minimum-level' instead of this. -;(defvar inhibit-font-complaints nil -; "Whether to suppress complaints about incomplete sets of fonts.") - -(defun face-complain-about-font (face device) - (if (symbolp face) (setq face (symbol-name face))) -;; (if (not inhibit-font-complaints) - (display-warning - 'font - (let ((default-name (face-font-name 'default device))) - (format "%s: couldn't deduce %s %s version of the font -%S. - -Please specify X resources to make the %s face -visually distinguishable from the default face. -For example, you could add one of the following to $HOME/Emacs: - -Emacs.%s.attributeFont: -dt-*-medium-i-* -or -Emacs.%s.attributeForeground: hotpink\n" - invocation-name - (if (string-match "\\`[aeiouAEIOU]" face) "an" "a") - face - default-name - face - face - face - )))) - - -;; #### This is quite a mess. We should use the custom mechanism for -;; most of this stuff. Currently we don't do it, because Custom -;; doesn't use specifiers (yet.) FSF does it the Right Way. - -;; For instance, the definition of `bold' should be something like -;; (defface bold ((t (:bold t))) "Bold text.") -- and `:bold t' should -;; make sure that everything works properly. - -(defun init-other-random-faces (device) - "Initializes the colors and fonts of the bold, italic, bold-italic, -zmacs-region, list-mode-item-selected, highlight, primary-selection, -secondary-selection, and isearch faces when each device is created. If -you want to add code to do stuff like this, use the create-device-hook." - - ;; try to make 'bold look different from the default on this device. - ;; If that doesn't work at all, then issue a warning. - (unless (face-differs-from-default-p 'bold device) - (make-face-bold 'bold device) - (unless (face-differs-from-default-p 'bold device) - (make-face-unbold 'bold device) - (unless (face-differs-from-default-p 'bold device) - ;; the luser specified one of the bogus font names - (face-complain-about-font 'bold device)))) - - ;; Similar for italic. - ;; It's unreasonable to expect to be able to make a font italic all - ;; the time. For many languages, italic is an alien concept. - ;; Basically, because italic is not a globally meaningful concept, - ;; the use of the italic face should really be oboleted. - - ;; I disagree with above. In many languages, the concept of capital - ;; letters is just as alien, and yet we use them. Italic is here to - ;; stay. -hniksic - - ;; In a Solaris Japanese environment, there just aren't any italic - ;; fonts - period. CDE recognizes this reality, and fonts - ;; -dt-interface user-medium-r-normal-*-*-*-*-*-*-*-*-* don't come - ;; in italic versions. So we first try to make the font bold before - ;; complaining. - (unless (face-differs-from-default-p 'italic device) - (make-face-italic 'italic device) - (unless (face-differs-from-default-p 'italic device) - (make-face-bold 'italic device) - (unless (face-differs-from-default-p 'italic device) - (face-complain-about-font 'italic device)))) - - ;; similar for bold-italic. - (unless (face-differs-from-default-p 'bold-italic device) - (make-face-bold-italic 'bold-italic device) - ;; if we couldn't get a bold-italic version, try just bold. - (unless (face-differs-from-default-p 'bold-italic device) - (make-face-bold 'bold-italic device) - ;; if we couldn't get bold or bold-italic, then that's probably because - ;; the default font is bold, so make the `bold-italic' face be unbold. - (unless (face-differs-from-default-p 'bold-italic device) - (make-face-unbold 'bold-italic device) - (make-face-italic 'bold-italic device) - (unless (face-differs-from-default-p 'bold-italic device) - ;; if that didn't work, try plain italic - ;; (can this ever happen? what the hell.) - (make-face-italic 'bold-italic device) - (unless (face-differs-from-default-p 'bold-italic device) - ;; then bitch and moan. - (face-complain-about-font 'bold-italic device)))))) - - ;; Set the text-cursor colors unless already specified. - (when (and (not (eq 'tty (device-type device))) - (not (face-background 'text-cursor 'global)) - (face-property-equal 'text-cursor 'default 'background device)) - (set-face-background 'text-cursor [default foreground] 'global - nil 'append)) - (when (and (not (eq 'tty (device-type device))) - (not (face-foreground 'text-cursor 'global)) - (face-property-equal 'text-cursor 'default 'foreground device)) - (set-face-foreground 'text-cursor [default background] 'global - nil 'append)) - - ;; Set the secondary-selection color unless already specified. - (unless (or (face-differs-from-default-p 'highlight device) - (face-background 'highlight 'global)) - ;; some older servers don't recognize "darkseagreen2" - (set-face-background 'highlight - '((color . "darkseagreen2") - (color . "green")) - 'global nil 'append) - (set-face-background 'highlight "gray53" 'global 'grayscale 'append)) - (unless (or (face-differs-from-default-p 'highlight device) - (face-background-pixmap 'highlight 'global)) - (set-face-background-pixmap 'highlight [nothing] 'global 'color 'append) - (set-face-background-pixmap 'highlight [nothing] 'global 'grayscale 'append) - (set-face-background-pixmap 'highlight "gray1" 'global 'mono 'append)) - ;; if the highlight face isn't distinguished on this device, - ;; at least try inverting it. - (unless (face-differs-from-default-p 'highlight device) - (invert-face 'highlight device)) - - ;; first time through, set the zmacs-region color if it's not already - ;; specified. - (unless (or (face-differs-from-default-p 'zmacs-region device) - (face-background 'zmacs-region 'global)) - (set-face-background 'zmacs-region "gray65" 'global 'color) - (set-face-background 'zmacs-region "gray65" 'global 'grayscale)) - (unless (or (face-differs-from-default-p 'zmacs-region device) - (face-background-pixmap 'zmacs-region 'global)) - (set-face-background-pixmap 'zmacs-region [nothing] 'global 'color) - (set-face-background-pixmap 'zmacs-region [nothing] 'global 'grayscale) - (set-face-background-pixmap 'zmacs-region "gray3" 'global 'mono)) - ;; if the zmacs-region face isn't distinguished on this device, - ;; at least try inverting it. - (unless (face-differs-from-default-p 'zmacs-region device) - (invert-face 'zmacs-region device)) - - ;; first time through, set the list-mode-item-selected color if it's - ;; not already specified. - (unless (or (face-differs-from-default-p 'list-mode-item-selected device) - (face-background 'list-mode-item-selected 'global)) - (set-face-background 'list-mode-item-selected "gray68" 'global 'color) - (set-face-background 'list-mode-item-selected "gray68" 'global 'grayscale) - (unless (face-foreground 'list-mode-item-selected 'global) - (set-face-background 'list-mode-item-selected - [default foreground] 'global '(mono x)) - (set-face-foreground 'list-mode-item-selected - [default background] 'global '(mono x)))) - ;; if the list-mode-item-selected face isn't distinguished on this device, - ;; at least try inverting it. - (unless (face-differs-from-default-p 'list-mode-item-selected device) - (invert-face 'list-mode-item-selected device)) - - ;; Set the primary-selection color unless already specified. - (unless (or (face-differs-from-default-p 'primary-selection device) - (face-background 'primary-selection 'global)) - (set-face-background 'primary-selection "gray65" 'global 'color) - (set-face-background 'primary-selection "gray65" 'global 'grayscale)) - (unless (or (face-differs-from-default-p 'secondary-selection device) - (face-background-pixmap 'primary-selection 'global)) - (set-face-background-pixmap 'primary-selection "gray3" 'global 'mono)) - ;; If the primary-selection face isn't distinguished on this device, - ;; at least try inverting it. - (unless (face-differs-from-default-p 'primary-selection device) - (invert-face 'primary-selection device)) - - ;; Set the secondary-selection color unless already specified. - (unless (or (face-differs-from-default-p 'secondary-selection device) - (face-background 'secondary-selection 'global)) - (set-face-background 'secondary-selection - '((color . "paleturquoise") - (color . "green")) - 'global) - (set-face-background 'secondary-selection "gray53" 'global - 'grayscale)) - (unless (or (face-differs-from-default-p 'secondary-selection device) - (face-background-pixmap 'secondary-selection 'global)) - (set-face-background-pixmap 'secondary-selection "gray1" 'global 'mono)) - ;; If the secondary-selection face isn't distinguished on this device, - ;; at least try inverting it. - (unless (face-differs-from-default-p 'secondary-selection device) - (invert-face 'secondary-selection device)) - - ;; Set the isearch color if unless already specified. - (unless (or (face-differs-from-default-p 'isearch device) - (face-background 'isearch 'global)) - ;; TTY's and some older X servers don't recognize "paleturquoise" - (set-face-background 'isearch - '((color . "paleturquoise") - (color . "green")) - 'global)) - ;; if the isearch face isn't distinguished (e.g. we're not on a color - ;; display), at least try making it bold. - (unless (face-differs-from-default-p 'isearch device) - (set-face-font 'isearch [bold])) - ) - -;; New function with 20.1, suggested by Per Abrahamsen, coded by Kyle Jones. -(defun set-face-stipple (face pixmap &optional frame) - "Change the stipple pixmap of face FACE to PIXMAP. -This is an Emacs compatibility function; consider using -set-face-background-pixmap instead. - -PIXMAP should be a string, the name of a file of pixmap data. -The directories listed in the `x-bitmap-file-path' variable are searched. -Any kind of image file for which XEmacs has builtin support can be used. - -Alternatively, PIXMAP may be a list of the form (WIDTH HEIGHT -DATA) where WIDTH and HEIGHT are the size in pixels, and DATA is -a string, containing the raw bits of the bitmap. XBM data is -expected in this case, other types of image data will not work. - -If the optional FRAME argument is provided, change only -in that frame; otherwise change each frame." - (while (not (find-face face)) - (setq face (signal 'wrong-type-argument (list 'facep face)))) - (while (cond ((stringp pixmap) - (unless (file-readable-p pixmap) - (setq pixmap `[xbm :file ,pixmap])) - nil) - ((and (consp pixmap) (= (length pixmap) 3)) - (setq pixmap `[xbm :data ,pixmap]) - nil) - (t t)) - (setq pixmap (signal 'wrong-type-argument - (list 'stipple-pixmap-p pixmap)))) - (while (and frame (not (framep frame))) - (setq frame (signal 'wrong-type-argument (list 'framep frame)))) - (set-face-background-pixmap face pixmap frame)) - - -;; Create the remaining standard faces now. This way, packages that we dump -;; can reference these faces as parents. -;; -;; The default, modeline, left-margin, right-margin, text-cursor, -;; and pointer faces are created in C. - -(make-face 'bold "Bold text.") -(make-face 'italic "Italic text.") -(make-face 'bold-italic "Bold-italic text.") -(make-face 'underline "Underlined text.") -(or (face-differs-from-default-p 'underline) - (set-face-underline-p 'underline t 'global)) -(make-face 'zmacs-region "Used on highlightes region between point and mark.") -(make-face 'isearch "Used on region matched by isearch.") -(make-face 'list-mode-item-selected - "Face for the selected list item in list-mode.") -(make-face 'highlight "Highlight face.") -(make-face 'primary-selection "Primary selection face.") -(make-face 'secondary-selection "Secondary selection face.") - -;; Several useful color faces. -(dolist (color '(red green blue yellow)) - (make-face color (concat (symbol-name color) " text.")) - (set-face-foreground color (symbol-name color) nil 'color)) - -;; Make some useful faces. This happens very early, before creating -;; the first non-stream device. We initialize the tty global values here. -;; We cannot initialize the X global values here because they depend -;; on having already resourced the global face specs, which happens -;; when the first X device is created. - -(set-face-background-pixmap 'modeline [nothing]) - -(when (featurep 'tty) - (set-face-highlight-p 'bold t 'global 'tty) - (set-face-underline-p 'italic t 'global 'tty) - (set-face-highlight-p 'bold-italic t 'global 'tty) - (set-face-underline-p 'bold-italic t 'global 'tty) - (set-face-highlight-p 'highlight t 'global 'tty) - (set-face-reverse-p 'text-cursor t 'global 'tty) - (set-face-reverse-p 'modeline t 'global 'tty) - (set-face-reverse-p 'zmacs-region t 'global 'tty) - (set-face-reverse-p 'primary-selection t 'global 'tty) - (set-face-underline-p 'secondary-selection t 'global 'tty) - (set-face-reverse-p 'list-mode-item-selected t 'global 'tty) - (set-face-reverse-p 'isearch t 'global 'tty) - ) - -;;; faces.el ends here
--- a/lisp/prim/files-nomule.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,91 +0,0 @@ -;;; files-nomule.el --- file I/O stubs when not under Mule. - -;; Copyright (C) 1985-1987, 1992-1994 Free Software Foundation, Inc. -;; Copyright (C) 1995 Sun Microsystems. - -;; 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, 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: FSF 19.34 (files.el). (Is it? Please check) - -;;; Commentary: - -;; These stubs were moved from the bottom of files.el. - -;;; Code: - -(defun insert-file-contents (filename &optional visit beg end replace) - "Insert contents of file FILENAME after point. -Returns list of absolute file name and length of data inserted. -If second argument VISIT is non-nil, the buffer's visited filename -and last save file modtime are set, and it is marked unmodified. -If visiting and the file does not exist, visiting is completed -before the error is signaled. - -The optional third and fourth arguments BEG and END -specify what portion of the file to insert. -If VISIT is non-nil, BEG and END must be nil. -If optional fifth argument REPLACE is non-nil, -it means replace the current buffer contents (in the accessible portion) -with the file contents. This is better than simply deleting and inserting -the whole thing because (1) it preserves some marker positions -and (2) it puts less data in the undo list." - (insert-file-contents-internal filename visit beg end replace nil nil)) - -(defun write-region (start end filename &optional append visit lockname coding-system) - "Write current region into specified file. -By default, the file's existing contents are replaced by the specified region. -When called from a program, takes three arguments: -START, END and FILENAME. START and END are buffer positions. -Optional fourth argument APPEND if non-nil means - append to existing file contents (if any). -Optional fifth argument VISIT if t means - set the last-save-file-modtime of buffer to this file's modtime - and mark buffer not modified. -If VISIT is a string, it is a second file name; - the output goes to FILENAME, but the buffer is marked as visiting VISIT. - VISIT is also the file name to lock and unlock for clash detection. -If VISIT is neither t nor nil nor a string, - that means do not print the \"Wrote file\" message. -The optional sixth arg LOCKNAME, if non-nil, specifies the name to - use for locking and unlocking, overriding FILENAME and VISIT. -Kludgy feature: if START is a string, then that string is written -to the file, instead of any buffer contents, and END is ignored. -Optional seventh argument CODING-SYSTEM is meaningful only if support - for Mule is present in XEmacs and specifies the coding system - used to encode the text when it is written out, and defaults to - the value of `buffer-file-coding-system' in the current buffer. - When Mule support is not present, the CODING-SYSTEM argument is - ignored." - (interactive "r\nFWrite region to file: ") - (write-region-internal start end filename append visit lockname nil)) - -(defun load (file &optional noerror nomessage nosuffix) - "Execute a file of Lisp code named FILE. -First try FILE with `.elc' appended, then try with `.el', - then try FILE unmodified. -This function searches the directories in `load-path'. -If optional second arg NOERROR is non-nil, - report no error if FILE doesn't exist. -Print messages at start and end of loading unless - optional third arg NOMESSAGE is non-nil (ignored in -batch mode). -If optional fourth arg NOSUFFIX is non-nil, don't try adding - suffixes `.elc' or `.el' to the specified name FILE. -Return t if file exists." - (load-internal file noerror nomessage nosuffix nil nil)) - -;;; files-nomule.el ends here
--- a/lisp/prim/files.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,3096 +0,0 @@ -;;; files.el --- file input and output commands for XEmacs. - -;; Copyright (C) 1985-1987, 1992-1995, 1997 Free Software Foundation, Inc. -;; Copyright (C) 1995 Sun Microsystems. - -;; 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.34 [Partial]. -;;; Warning: Merging this file is tough. Beware. - -;;; Commentary: - -;; Defines most of XEmacs's file- and directory-handling functions, -;; including basic file visiting, backup generation, link handling, -;; ITS-id version control, load- and write-hook handling, and the like. - -;;; Code: - -;; XEmacs: Avoid compilation warnings. -(defvar coding-system-for-read) -(defvar buffer-file-coding-system) - -(defgroup backup nil - "Backups of edited data files." - :group 'files) - -(defgroup find-file nil - "Finding and editing files." - :group 'files) - - -;; XEmacs: In buffer.c -;(defconst delete-auto-save-files t -; "*Non-nil means delete auto-save file when a buffer is saved or killed.") - -;; FSF has automount-dir-prefix. Our directory-abbrev-alist is more general. -;; note: tmp_mnt bogosity conversion is established in paths.el. -(defcustom directory-abbrev-alist nil - "*Alist of abbreviations for file directories. -A list of elements of the form (FROM . TO), each meaning to replace -FROM with TO when it appears in a directory name. -This replacement is done when setting up the default directory of a -newly visited file. *Every* FROM string should start with \\\\` or ^. - -Use this feature when you have directories which you normally refer to -via absolute symbolic links or to eliminate automounter mount points -from the beginning of your filenames. Make TO the name of the link, -and FROM the name it is linked to." - :type '(repeat (cons :format "%v" - :value ("\\`" . "") - (regexp :tag "From") - (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)) - "*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. - -Renaming means that XEmacs renames the existing file so that it is a -backup file, then writes the buffer into a new file. Any other names -that the old file had will now refer to the backup file. The new file -is owned by you and its group is defaulted. - -Copying means that XEmacs copies the existing file into the backup -file, then writes the buffer on top of the existing file. Any other -names that the old file had will now refer to the new (edited) file. -The file's owner and group are unchanged. - -The choice of renaming or copying is controlled by the variables -`backup-by-copying', `backup-by-copying-when-linked' and -`backup-by-copying-when-mismatch'. See also `backup-inhibited'." - :type 'boolean - :group 'backup) - -;; Do this so that local variables based on the file name -;; are not overridden by the major mode. -(defvar backup-inhibited nil - "Non-nil means don't make a backup, regardless of the other parameters. -This variable is intended for use by making it local to a buffer. -But it is local only if you make it local.") -(put 'backup-inhibited 'permanent-local t) - -(defcustom backup-by-copying nil - "*Non-nil means always use copying to create backup files. -See documentation of variable `make-backup-files'." - :type 'boolean - :group 'backup) - -(defcustom backup-by-copying-when-linked nil - "*Non-nil means use copying to create backups for files with multiple names. -This causes the alternate names to refer to the latest version as edited. -This variable is relevant only if `backup-by-copying' is nil." - :type 'boolean - :group 'backup) - -(defcustom backup-by-copying-when-mismatch nil - "*Non-nil means create backups by copying if this preserves owner or group. -Renaming may still be used (subject to control of other variables) -when it would not result in changing the owner or group of the file; -that is, for files which are owned by you and whose group matches -the default for a new file created there by you. -This variable is relevant only if `backup-by-copying' is nil." - :type 'boolean - :group 'backup) - -(defvar backup-enable-predicate - '(lambda (name) - (or (< (length name) 5) - (not (string-equal "/tmp/" (substring name 0 5))))) - "Predicate that looks at a file name and decides whether to make backups. -Called with an absolute file name as argument, it returns t to enable backup.") - -(defcustom buffer-offer-save nil - "*Non-nil in a buffer means offer to save the buffer on exit -even if the buffer is not visiting a file. -Automatically local in all buffers." - :type 'boolean - :group 'find-file) -(make-variable-buffer-local 'buffer-offer-save) - -;; FSF uses normal defconst -(defvaralias 'find-file-visit-truename 'find-file-use-truenames) -(defvaralias 'find-file-existing-other-name 'find-file-compare-truenames) - -(defcustom revert-without-query nil - "*Specify which files should be reverted without query. -The value is a list of regular expressions. -If the file name matches one of these regular expressions, -then `revert-buffer' reverts the file without querying -if the file has changed on disk and you have not edited the buffer." - :type '(repeat (regexp "")) - :group 'find-file) - -(defvar buffer-file-number nil - "The device number and file number of the file visited in the current buffer. -The value is a list of the form (FILENUM DEVNUM). -This pair of numbers uniquely identifies the file. -If the buffer is visiting a new file, the value is nil.") -(make-variable-buffer-local 'buffer-file-number) -(put 'buffer-file-number 'permanent-local t) - -(defvar buffer-file-numbers-unique (not (memq system-type '(windows-nt))) - "Non-nil means that buffer-file-number uniquely identifies files.") - -(defcustom file-precious-flag nil - "*Non-nil means protect against I/O errors while saving files. -Some modes set this non-nil in particular buffers. - -This feature works by writing the new contents into a temporary file -and then renaming the temporary file to replace the original. -In this way, any I/O error in writing leaves the original untouched, -and there is never any instant where the file is nonexistent. - -Note that this feature forces backups to be made by copying. -Yet, at the same time, saving a precious file -breaks any hard links between it and other files." - :type 'boolean - :group 'backup) - -(defcustom version-control nil - "*Control use of version numbers for backup files. -t means make numeric backup versions unconditionally. -nil means make them for files that have some already. -`never' means do not make them." - :type 'boolean - :group 'backup - :group 'vc) - -;; This is now defined in efs. -;(defvar dired-kept-versions 2 -; "*When cleaning directory, number of versions to keep.") - -(defcustom delete-old-versions nil - "*If t, delete excess backup versions silently. -If nil, ask confirmation. Any other value prevents any trimming." - :type '(choice (const :tag "Delete" t) - (const :tag "Ask" nil) - (sexp :tag "Leave" :format "%t\n" other)) - :group 'backup) - -(defcustom kept-old-versions 2 - "*Number of oldest versions to keep when a new numbered backup is made." - :type 'integer - :group 'backup) - -(defcustom kept-new-versions 2 - "*Number of newest versions to keep when a new numbered backup is made. -Includes the new backup. Must be > 0" - :type 'integer - :group 'backup) - -(defcustom require-final-newline nil - "*Value of t says silently ensure a file ends in a newline when it is saved. -Non-nil but not t says ask user whether to add a newline when there isn't one. -nil means don't add newlines." - :type '(choice (const :tag "Off" nil) - (const :tag "Add" t) - (sexp :tag "Ask" :format "%t\n" ask)) - :group 'editing-basics) - -(defcustom auto-save-default t - "*Non-nil says by default do auto-saving of every file-visiting buffer." - :type 'boolean - :group 'auto-save) - -(defcustom auto-save-visited-file-name nil - "*Non-nil says auto-save a buffer in the file it is visiting, when practical. -Normally auto-save files are written under other names." - :type 'boolean - :group 'auto-save) - -(defcustom save-abbrevs nil - "*Non-nil means save word abbrevs too when files are saved. -Loading an abbrev file sets this to t." - :type 'boolean - :group 'abbrev) - -(defcustom find-file-run-dired t - "*Non-nil says run dired if `find-file' is given the name of a directory." - :type 'boolean - :group 'find-file) - -;;;It is not useful to make this a local variable. -;;;(put 'find-file-not-found-hooks 'permanent-local t) -(defvar find-file-not-found-hooks nil - "List of functions to be called for `find-file' on nonexistent file. -These functions are called as soon as the error is detected. -`buffer-file-name' is already set up. -The functions are called in the order given until one of them returns non-nil.") - -;;;It is not useful to make this a local variable. -;;;(put 'find-file-hooks 'permanent-local t) -(defvar find-file-hooks nil - "List of functions to be called after a buffer is loaded from a file. -The buffer's local variables (if any) will have been processed before the -functions are called.") - -(defvar write-file-hooks nil - "List of functions to be called before writing out a buffer to a file. -If one of them returns non-nil, the file is considered already written -and the rest are not called. -These hooks are considered to pertain to the visited file. -So this list is cleared if you change the visited file name. -See also `write-contents-hooks' and `continue-save-buffer'.") -;;; However, in case someone does make it local... -(put 'write-file-hooks 'permanent-local t) - -(defvar local-write-file-hooks nil - "Just like `write-file-hooks', except intended for per-buffer use. -The functions in this list are called before the ones in -`write-file-hooks'. - -This variable is meant to be used for hooks that have to do with a -particular visited file. Therefore, it is a permanent local, so that -changing the major mode does not clear it. However, calling -`set-visited-file-name' does clear it.") -(make-variable-buffer-local 'local-write-file-hooks) -(put 'local-write-file-hooks 'permanent-local t) - - -;; #### think about this (added by Sun). -(put 'after-set-visited-file-name-hooks 'permanent-local t) -(defvar after-set-visited-file-name-hooks nil - "List of functions to be called after \\[set-visited-file-name] -or during \\[write-file]. -You can use this hook to restore local values of write-file-hooks, -after-save-hook, and revert-buffer-function, which pertain -to a specific file and therefore are normally killed by a rename. -Put hooks pertaining to the buffer contents on write-contents-hooks -and revert-buffer-insert-file-contents-function.") - -(defvar write-contents-hooks nil - "List of functions to be called before writing out a buffer to a file. -If one of them returns non-nil, the file is considered already written -and the rest are not called. -These hooks are considered to pertain to the buffer's contents, -not to the particular visited file; thus, `set-visited-file-name' does -not clear this variable, but changing the major mode does clear it. -See also `write-file-hooks' and `continue-save-buffer'.") - -;; XEmacs addition -;; Energize needed this to hook into save-buffer at a lower level; we need -;; to provide a new output method, but don't want to have to duplicate all -;; of the backup file and file modes logic.that does not occur if one uses -;; a write-file-hook which returns non-nil. -(put 'write-file-data-hooks 'permanent-local t) -(defvar write-file-data-hooks nil - "List of functions to be called to put the bytes on disk. -These functions receive the name of the file to write to as argument. -The default behavior is to call - (write-region (point-min) (point-max) filename nil t) -If one of them returns non-nil, the file is considered already written -and the rest are not called. -These hooks are considered to pertain to the visited file. -So this list is cleared if you change the visited file name. -See also `write-file-hooks'.") - -(defcustom enable-local-variables t - "*Control use of local-variables lists in files you visit. -The value can be t, nil or something else. -A value of t means local-variables lists are obeyed; -nil means they are ignored; anything else means query. - -The command \\[normal-mode] always obeys local-variables lists -and ignores this variable." - :type '(choice (const :tag "Obey" t) - (const :tag "Ignore" nil) - (sexp :tag "Query" :format "%t\n" other)) - :group 'find-file) - -(defcustom enable-local-eval 'maybe - "*Control processing of the \"variable\" `eval' in a file's local variables. -The value can be t, nil or something else. -A value of t means obey `eval' variables; -nil means ignore them; anything else means query. - -The command \\[normal-mode] always obeys local-variables lists -and ignores this variable." - :type '(choice (const :tag "Obey" t) - (const :tag "Ignore" nil) - (sexp :tag "Query" :format "%t\n" other)) - :group 'find-file) - -;; Avoid losing in versions where CLASH_DETECTION is disabled. -(or (fboundp 'lock-buffer) - (defalias 'lock-buffer 'ignore)) -(or (fboundp 'unlock-buffer) - (defalias 'unlock-buffer 'ignore)) - -;;FSFmacs bastardized ange-ftp cruft -;; This hook function provides support for ange-ftp host name -;; completion. It runs the usual ange-ftp hook, but only for -;; completion operations. Having this here avoids the need -;; to load ange-ftp when it's not really in use. -;(defun ange-ftp-completion-hook-function (op &rest args) -; (if (memq op '(file-name-completion file-name-all-completions)) -; (apply 'ange-ftp-hook-function op args) -; (let ((inhibit-file-name-handlers -; (cons 'ange-ftp-completion-hook-function -; (and (eq inhibit-file-name-operation op) -; inhibit-file-name-handlers))) -; (inhibit-file-name-operation op)) -; (apply op args)) - -(defun convert-standard-filename (filename) - "Convert a standard file's name to something suitable for the current OS. -This function's standard definition is trivial; it just returns the argument. -However, on some systems, the function is redefined -with a definition that really does change some file names." - filename) - -(defun pwd () - "Show the current default directory." - (interactive nil) - (message "Directory %s" default-directory)) - -(defvar cd-path nil - "Value of the CDPATH environment variable, as a list. -Not actually set up until the first time you use it.") - -(defvar path-separator ":" - "Character used to separate concatenated paths.") - -(defun parse-colon-path (cd-path) - "Explode a colon-separated list of paths into a string list." - (and cd-path - (let (cd-list (cd-start 0) cd-colon) - (setq cd-path (concat cd-path path-separator)) - (while (setq cd-colon (string-match path-separator cd-path cd-start)) - (setq cd-list - (nconc cd-list - (list (if (= cd-start cd-colon) - nil - (substitute-in-file-name - (file-name-as-directory - (substring cd-path cd-start cd-colon))))))) - (setq cd-start (+ cd-colon 1))) - cd-list))) - -(defun cd-absolute (dir) - "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))) - ;; XEmacs change: stig@hackvan.com - (if find-file-use-truenames - (setq dir (file-truename dir))) - (setq dir (abbreviate-file-name (expand-file-name dir))) - (cond ((not (file-directory-p dir)) - (error "%s is not a directory" dir)) - ;; this breaks ange-ftp, which doesn't (can't?) overload `file-executable-p'. - ;;((not (file-executable-p dir)) - ;; (error "Cannot cd to %s: Permission denied" dir)) - (t - (setq default-directory dir)))) - -(defun cd (dir) - "Make DIR become the current buffer's default directory. -If your environment includes a `CDPATH' variable, try each one of that -colon-separated list of directories when resolving a relative directory name." - (interactive - ;; XEmacs change? (read-file-name => read-directory-name) - (list (read-directory-name "Change default directory: " - default-directory default-directory - (and (member cd-path '(nil ("./"))) - (null (getenv "CDPATH")))))) - (if (file-name-absolute-p dir) - (cd-absolute (expand-file-name dir)) - ;; XEmacs - (if (null cd-path) - ;;#### Unix-specific - (let ((trypath (parse-colon-path (getenv "CDPATH")))) - (setq cd-path (or trypath (list "./"))))) - (or (catch 'found - (mapcar #'(lambda (x) - (let ((f (expand-file-name (concat x dir)))) - (if (file-directory-p f) - (progn - (cd-absolute f) - (throw 'found t))))) - cd-path) - nil) - ;; jwz: give a better error message to those of us with the - ;; good taste not to use a kludge like $CDPATH. - (if (equal cd-path '("./")) - (error "No such directory: %s" (expand-file-name dir)) - (error "Directory not found in $CDPATH: %s" dir))))) - -(defun load-file (file) - "Load the Lisp file named FILE." - (interactive "fLoad file: ") - (load (expand-file-name file) nil nil t)) - -; We now dump utils/lib-complete.el which has improved versions of this. -;(defun load-library (library) -; "Load the library named LIBRARY. -;This is an interface to the function `load'." -; (interactive "sLoad library: ") -; (load library)) -; -;(defun find-library (library) -; "Find the library of Lisp code named LIBRARY. -;This searches `load-path' for a file named either \"LIBRARY\" or \"LIBRARY.el\"." -; (interactive "sFind library file: ") -; (let ((f (locate-file library load-path ":.el:"))) -; (if f -; (find-file f) -; (error "Couldn't locate library %s" library)))) - -(defun file-local-copy (file &optional buffer) - "Copy the file FILE into a temporary file on this machine. -Returns the name of the local copy, or nil, if FILE is directly -accessible." - (let ((handler (find-file-name-handler file 'file-local-copy))) - (if handler - (funcall handler 'file-local-copy file) - nil))) - -;; XEmacs change block -; We have this in C and use the realpath() system call. - -;(defun file-truename (filename &optional counter prev-dirs) -; "Return the truename of FILENAME, which should be absolute. -;The truename of a file name is found by chasing symbolic links -;both at the level of the file and at the level of the directories -;containing it, until no links are left at any level. -; -;The arguments COUNTER and PREV-DIRS are used only in recursive calls. -;Do not specify them in other calls." -; ;; COUNTER can be a cons cell whose car is the count of how many more links -; ;; to chase before getting an error. -; ;; PREV-DIRS can be a cons cell whose car is an alist -; ;; of truenames we've just recently computed. -; ;; The last test looks dubious, maybe `+' is meant here? --simon. -; (if (or (string= filename "") (string= filename "~") -; (and (string= (substring filename 0 1) "~") -; (string-match "~[^/]*" filename))) -; (progn -; (setq filename (expand-file-name filename)) -; (if (string= filename "") -; (setq filename "/")))) -; (or counter (setq counter (list 100))) -; (let (done -; ;; For speed, remove the ange-ftp completion handler from the list. -; ;; We know it's not needed here. -; ;; For even more speed, do this only on the outermost call. -; (file-name-handler-alist -; (if prev-dirs file-name-handler-alist -; (let ((tem (copy-sequence file-name-handler-alist))) -; (delq (rassq 'ange-ftp-completion-hook-function tem) tem))))) -; (or prev-dirs (setq prev-dirs (list nil))) -; ;; If this file directly leads to a link, process that iteratively -; ;; so that we don't use lots of stack. -; (while (not done) -; (setcar counter (1- (car counter))) -; (if (< (car counter) 0) -; (error "Apparent cycle of symbolic links for %s" filename)) -; (let ((handler (find-file-name-handler filename 'file-truename))) -; ;; For file name that has a special handler, call handler. -; ;; This is so that ange-ftp can save time by doing a no-op. -; (if handler -; (setq filename (funcall handler 'file-truename filename) -; done t) -; (let ((dir (or (file-name-directory filename) default-directory)) -; target dirfile) -; ;; Get the truename of the directory. -; (setq dirfile (directory-file-name dir)) -; ;; If these are equal, we have the (or a) root directory. -; (or (string= dir dirfile) -; ;; If this is the same dir we last got the truename for, -; ;; save time--don't recalculate. -; (if (assoc dir (car prev-dirs)) -; (setq dir (cdr (assoc dir (car prev-dirs)))) -; (let ((old dir) -; (new (file-name-as-directory (file-truename dirfile counter prev-dirs)))) -; (setcar prev-dirs (cons (cons old new) (car prev-dirs))) -; (setq dir new)))) -; (if (equal ".." (file-name-nondirectory filename)) -; (setq filename -; (directory-file-name (file-name-directory (directory-file-name dir))) -; done t) -; (if (equal "." (file-name-nondirectory filename)) -; (setq filename (directory-file-name dir) -; done t) -; ;; Put it back on the file name. -; (setq filename (concat dir (file-name-nondirectory filename))) -; ;; Is the file name the name of a link? -; (setq target (file-symlink-p filename)) -; (if target -; ;; Yes => chase that link, then start all over -; ;; since the link may point to a directory name that uses links. -; ;; We can't safely use expand-file-name here -; ;; since target might look like foo/../bar where foo -; ;; is itself a link. Instead, we handle . and .. above. -; (setq filename -; (if (file-name-absolute-p target) -; target -; (concat dir target)) -; done nil) -; ;; No, we are done! -; (setq done t)))))))) -; filename)) - -;; XEmacs addition. Called from `insert-file-contents-internal' -;; at the appropriate time. -(defun compute-buffer-file-truename (&optional buffer) - "Recomputes BUFFER's value of `buffer-file-truename' -based on the current value of `buffer-file-name'. -BUFFER defaults to the current buffer if unspecified." - (save-excursion - (set-buffer (or buffer (current-buffer))) - (cond ((null buffer-file-name) - (setq buffer-file-truename nil)) - ((setq buffer-file-truename (file-truename buffer-file-name)) - ;; it exists, we're done. - nil) - (t - ;; the file doesn't exist, but maybe the directory does. - (let* ((dir (file-name-directory buffer-file-name)) - (truedir (file-truename dir))) - (if truedir (setq dir truedir)) - (setq buffer-file-truename - (expand-file-name (file-name-nondirectory buffer-file-name) - dir))))) - (if (and find-file-use-truenames buffer-file-truename) - (setq buffer-file-name (abbreviate-file-name buffer-file-truename) - default-directory (file-name-directory buffer-file-name))) - buffer-file-truename)) -;; End XEmacs change block - -(defun file-chase-links (filename) - "Chase links in FILENAME until a name that is not a link. -Does not examine containing directories for links, -unlike `file-truename'." - (let (tem (count 100) (newname filename)) - (while (setq tem (file-symlink-p newname)) - (if (= count 0) - (error "Apparent cycle of symbolic links for %s" filename)) - ;; In the context of a link, `//' doesn't mean what XEmacs thinks. - (while (string-match "//+" tem) - (setq tem (concat (substring tem 0 (1+ (match-beginning 0))) - (substring tem (match-end 0))))) - ;; Handle `..' by hand, since it needs to work in the - ;; target of any directory symlink. - ;; This code is not quite complete; it does not handle - ;; embedded .. in some cases such as ./../foo and foo/bar/../../../lose. - (while (string-match "\\`\\.\\./" tem) ;#### Unix specific - (setq tem (substring tem 3)) - (setq newname (file-name-as-directory - ;; Do the .. by hand. - (directory-file-name - (file-name-directory - ;; Chase links in the default dir of the symlink. - (file-chase-links - (directory-file-name - (file-name-directory newname)))))))) - (setq newname (expand-file-name tem (file-name-directory newname))) - (setq count (1- count))) - newname)) - -(defun switch-to-other-buffer (arg) - "Switch to the previous buffer. With a numeric arg, n, switch to the nth -most recent buffer. With an arg of 0, buries the current buffer at the -bottom of the buffer stack." - (interactive "p") - (if (eq arg 0) - (bury-buffer (current-buffer))) - (switch-to-buffer - (if (<= arg 1) (other-buffer (current-buffer)) - (nth (1+ arg) (buffer-list))))) - -(defun switch-to-buffer-other-window (buffer) - "Select buffer BUFFER in another window." - (interactive "BSwitch to buffer in other window: ") - (let ((pop-up-windows t)) - ;; XEmacs: this used to have (selected-frame) as the third argument, - ;; but this is obnoxious. If the user wants the buffer in a - ;; different frame, then it should be this way. - - ;; Change documented above undone --mrb - (pop-to-buffer buffer t (selected-frame)))) - -(defun switch-to-buffer-other-frame (buffer) - "Switch to buffer BUFFER in a newly-created frame." - (interactive "BSwitch to buffer in other frame: ") - (let* ((name (get-frame-name-for-buffer buffer)) - (frame (make-frame (if name - (list (cons 'name (symbol-name name))))))) - (pop-to-buffer buffer t frame) - (make-frame-visible frame) - buffer)) - -(defun find-file (filename &optional codesys) - "Edit file FILENAME. -Switch to a buffer visiting file FILENAME, -creating one if none already exists. -Under XEmacs/Mule, optional second argument specifies the -coding system to use when decoding the file. Interactively, -with a prefix argument, you will be prompted for the coding system." - (interactive "FFind file: \nZCoding system: ") - (if codesys - (let ((coding-system-for-read - (get-coding-system codesys))) - (switch-to-buffer (find-file-noselect filename))) - (switch-to-buffer (find-file-noselect filename)))) - -(defun find-file-other-window (filename &optional codesys) - "Edit file FILENAME, in another window. -May create a new window, or reuse an existing one. -See the function `display-buffer'. -Under XEmacs/Mule, optional second argument specifies the -coding system to use when decoding the file. Interactively, -with a prefix argument, you will be prompted for the coding system." - (interactive "FFind file in other window: \nZCoding system: ") - (if codesys - (let ((coding-system-for-read - (get-coding-system codesys))) - (switch-to-buffer-other-window (find-file-noselect filename))) - (switch-to-buffer-other-window (find-file-noselect filename)))) - -(defun find-file-other-frame (filename &optional codesys) - "Edit file FILENAME, in a newly-created frame. -Under XEmacs/Mule, optional second argument specifies the -coding system to use when decoding the file. Interactively, -with a prefix argument, you will be prompted for the coding system." - (interactive "FFind file in other frame: \nZCoding system: ") - (if codesys - (let ((coding-system-for-read - (get-coding-system codesys))) - (switch-to-buffer-other-frame (find-file-noselect filename))) - (switch-to-buffer-other-frame (find-file-noselect filename)))) - -(defun find-file-read-only (filename &optional codesys) - "Edit file FILENAME but don't allow changes. -Like \\[find-file] but marks buffer as read-only. -Use \\[toggle-read-only] to permit editing. -Under XEmacs/Mule, optional second argument specifies the -coding system to use when decoding the file. Interactively, -with a prefix argument, you will be prompted for the coding system." - (interactive "fFind file read-only: \nZCoding system: ") - (if codesys - (let ((coding-system-for-read - (get-coding-system codesys))) - (find-file filename)) - (find-file filename)) - (setq buffer-read-only t) - (current-buffer)) - -(defun find-file-read-only-other-window (filename &optional codesys) - "Edit file FILENAME in another window but don't allow changes. -Like \\[find-file-other-window] but marks buffer as read-only. -Use \\[toggle-read-only] to permit editing. -Under XEmacs/Mule, optional second argument specifies the -coding system to use when decoding the file. Interactively, -with a prefix argument, you will be prompted for the coding system." - (interactive "fFind file read-only other window: \nZCoding system: ") - (if codesys - (let ((coding-system-for-read - (get-coding-system codesys))) - (find-file-other-window filename)) - (find-file-other-window filename)) - (setq buffer-read-only t) - (current-buffer)) - -(defun find-file-read-only-other-frame (filename &optional codesys) - "Edit file FILENAME in another frame but don't allow changes. -Like \\[find-file-other-frame] but marks buffer as read-only. -Use \\[toggle-read-only] to permit editing. -Under XEmacs/Mule, optional second argument specifies the -coding system to use when decoding the file. Interactively, -with a prefix argument, you will be prompted for the coding system." - (interactive "fFind file read-only other frame: \nZCoding system: ") - (if codesys - (let ((coding-system-for-read - (get-coding-system codesys))) - (find-file-other-frame filename)) - (find-file-other-frame filename)) - (setq buffer-read-only t) - (current-buffer)) - -(defun find-alternate-file-other-window (filename &optional codesys) - "Find file FILENAME as a replacement for the file in the next window. -This command does not select that window. -Under XEmacs/Mule, optional second argument specifies the -coding system to use when decoding the file. Interactively, -with a prefix argument, you will be prompted for the coding system." - (interactive - (save-selected-window - (other-window 1) - (let ((file buffer-file-name) - (file-name nil) - (file-dir nil)) - (and file - (setq file-name (file-name-nondirectory file) - file-dir (file-name-directory file))) - (list (read-file-name - "Find alternate file: " file-dir nil nil file-name) - (if (and current-prefix-arg (featurep 'mule)) - (read-coding-system "Coding-system: ")))))) - (if (one-window-p) - (find-file-other-window filename) - (save-selected-window - (other-window 1) - (find-alternate-file filename codesys)))) - -(defun find-alternate-file (filename &optional codesys) - "Find file FILENAME, select its buffer, kill previous buffer. -If the current buffer now contains an empty file that you just visited -\(presumably by mistake), use this command to visit the file you really want. -Under XEmacs/Mule, optional second argument specifies the -coding system to use when decoding the file. Interactively, -with a prefix argument, you will be prompted for the coding system." - (interactive - (let ((file buffer-file-name) - (file-name nil) - (file-dir nil)) - (and file - (setq file-name (file-name-nondirectory file) - file-dir (file-name-directory file))) - (list (read-file-name - "Find alternate file: " file-dir nil nil file-name) - (if (and current-prefix-arg (featurep 'mule)) - (read-coding-system "Coding-system: "))))) - (and (buffer-modified-p) (buffer-file-name) - ;; (not buffer-read-only) - (not (yes-or-no-p (format - "Buffer %s is modified; kill anyway? " - (buffer-name)))) - (error "Aborted")) - (let ((obuf (current-buffer)) - (ofile buffer-file-name) - (onum buffer-file-number) - (otrue buffer-file-truename) - (oname (buffer-name))) - (if (get-buffer " **lose**") - (kill-buffer " **lose**")) - (rename-buffer " **lose**") - (setq buffer-file-name nil) - (setq buffer-file-number nil) - (setq buffer-file-truename nil) - (unwind-protect - (progn - (unlock-buffer) - (if codesys - (let ((coding-system-for-read - (get-coding-system codesys))) - (find-file filename)) - (find-file filename))) - (cond ((eq obuf (current-buffer)) - (setq buffer-file-name ofile) - (setq buffer-file-number onum) - (setq buffer-file-truename otrue) - (lock-buffer) - (rename-buffer oname)))) - (or (eq (current-buffer) obuf) - (kill-buffer obuf)))) - -(defun create-file-buffer (filename) - "Create a suitably named buffer for visiting FILENAME, and return it. -FILENAME (sans directory) is used unchanged if that name is free; -otherwise a string <2> or <3> or ... is appended to get an unused name." - (let ((handler (find-file-name-handler filename 'create-file-buffer))) - (if handler - (funcall handler 'create-file-buffer filename) - (let ((lastname (file-name-nondirectory filename))) - (if (string= lastname "") - (setq lastname filename)) - (generate-new-buffer lastname))))) - -(defun generate-new-buffer (name) - "Create and return a buffer with a name based on NAME. -Choose the buffer's name using `generate-new-buffer-name'." - (get-buffer-create (generate-new-buffer-name name))) - -(defvar abbreviated-home-dir nil - "The user's homedir abbreviated according to `directory-abbrev-alist'.") - -(defun abbreviate-file-name (filename &optional hack-homedir) - "Return a version of FILENAME shortened using `directory-abbrev-alist'. -See documentation of variable `directory-abbrev-alist' for more information. -If optional argument HACK-HOMEDIR is non-nil, then this also substitutes -\"~\" for the user's home directory." - (let ((handler (find-file-name-handler filename 'abbreviate-file-name))) - (if handler - (funcall handler 'abbreviate-file-name filename hack-homedir) - ;; Get rid of the prefixes added by the automounter. - ;;(if (and (string-match automount-dir-prefix filename) - ;; (file-exists-p (file-name-directory - ;; (substring filename (1- (match-end 0)))))) - ;; (setq filename (substring filename (1- (match-end 0))))) - (let ((tail directory-abbrev-alist)) - ;; If any elt of directory-abbrev-alist matches this name, - ;; abbreviate accordingly. - (while tail - (if (string-match (car (car tail)) filename) - (setq filename - (concat (cdr (car tail)) (substring filename (match-end 0))))) - (setq tail (cdr tail)))) - (if hack-homedir - (progn - ;; Compute and save the abbreviated homedir name. - ;; We defer computing this until the first time it's needed, to - ;; give time for directory-abbrev-alist to be set properly. - ;; We include a slash at the end, to avoid spurious matches - ;; such as `/usr/foobar' when the home dir is `/usr/foo'. - (or abbreviated-home-dir - (setq abbreviated-home-dir - (let ((abbreviated-home-dir "$foo")) - (concat "\\`" (regexp-quote (abbreviate-file-name - (expand-file-name "~"))) - "\\(/\\|\\'\\)")))) - ;; If FILENAME starts with the abbreviated homedir, - ;; make it start with `~' instead. - (if (and (string-match abbreviated-home-dir filename) - ;; 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)) - (save-match-data - (string-match "^[a-zA-Z]:/$" filename))))) - (setq filename - (concat "~" - (substring filename - (match-beginning 1) (match-end 1)) - (substring filename (match-end 0))))))) - 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." - :type '(repeat (string :tag "Name")) - :group 'find-file) - -;; This function is needed by FSF vc.el. I hope somebody can make it -;; work for XEmacs. -sb. -(defun find-buffer-visiting (filename) - "Return the buffer visiting file FILENAME (a string). -This is like `get-file-buffer', except that it checks for any buffer -visiting the same file, possibly under a different name. -If there is no such live buffer, return nil." - (let ((buf (get-file-buffer filename)) - (truename (abbreviate-file-name (file-truename filename)))) - (or buf - (let ((list (buffer-list)) found) - (while (and (not found) list) - (save-excursion - (set-buffer (car list)) - (if (and buffer-file-name - (string= buffer-file-truename truename)) - (setq found (car list)))) - (setq list (cdr list))) - found) - (let ((number (nthcdr 10 (file-attributes truename))) - (list (buffer-list)) found) - (and buffer-file-numbers-unique - number - (while (and (not found) list) - (save-excursion - (set-buffer (car list)) - (if (and buffer-file-number - (equal buffer-file-number number) - ;; Verify this buffer's file number - ;; still belongs to its file. - (file-exists-p buffer-file-name) - (equal (nthcdr 10 (file-attributes buffer-file-name)) - number)) - (setq found (car list)))) - (setq list (cdr list)))) - found)))) - -(defun insert-file-contents-literally (filename &optional visit beg end replace) - "Like `insert-file-contents', q.v., but only reads in the file. -A buffer may be modified in several ways after reading into the buffer due -to advanced Emacs features, such as file-name-handlers, format decoding, -find-file-hooks, etc. - This function ensures that none of these modifications will take place." - (let ((file-name-handler-alist nil) - (format-alist nil) - (after-insert-file-functions nil) - (find-buffer-file-type-function - (if (fboundp 'find-buffer-file-type) - (symbol-function 'find-buffer-file-type) - nil))) - (unwind-protect - (progn - (fset 'find-buffer-file-type (lambda (filename) t)) - (insert-file-contents filename visit beg end replace)) - (if find-buffer-file-type-function - (fset 'find-buffer-file-type find-buffer-file-type-function) - (fmakunbound 'find-buffer-file-type))))) - -(defun find-file-noselect (filename &optional nowarn rawfile) - "Read file FILENAME into a buffer and return the buffer. -If a buffer exists visiting FILENAME, return that one, but -verify that the file has not changed since visited or saved. -The buffer is not selected, just returned to the caller. -If NOWARN is non-nil, warning messages about several potential -problems will be suppressed." - (setq filename (abbreviate-file-name (expand-file-name filename))) - (if (file-directory-p filename) - (if find-file-run-dired - (dired-noselect (if find-file-use-truenames - (abbreviate-file-name (file-truename filename)) - filename)) - (error "%s is a directory." filename)) - (let* ((buf (get-file-buffer filename)) -; (truename (abbreviate-file-name (file-truename filename))) - (number (nthcdr 10 (file-attributes (file-truename filename)))) -; (number (and buffer-file-truename -; (nthcdr 10 (file-attributes buffer-file-truename)))) -; ;; Find any buffer for a file which has same truename. -; (other (and (not buf) (find-buffer-visiting filename))) - (error nil)) - -; ;; Let user know if there is a buffer with the same truename. -; (if (and (not buf) same-truename (not nowarn)) -; (message "%s and %s are the same file (%s)" -; filename (buffer-file-name same-truename) -; truename) -; (if (and (not buf) same-number (not nowarn)) -; (message "%s and %s are the same file" -; filename (buffer-file-name same-number)))) -; ;; Optionally also find that buffer. -; (if (or find-file-existing-other-name find-file-visit-truename) -; (setq buf (or same-truename same-number))) - - (when (and buf - (or find-file-compare-truenames find-file-use-truenames) - (not nowarn)) - (save-excursion - (set-buffer buf) - (if (not (string-equal buffer-file-name filename)) - (message "%s and %s are the same file (%s)" - filename buffer-file-name - buffer-file-truename)))) - - (if buf - (or nowarn - (verify-visited-file-modtime buf) - (cond ((not (file-exists-p filename)) - (error "File %s no longer exists!" filename)) - ;; Certain files should be reverted automatically - ;; if they have changed on disk and not in the buffer. - ((and (not (buffer-modified-p buf)) - (let (found) - (dolist (rx revert-without-query found) - (when (string-match rx filename) - (setq found t))))) - (with-current-buffer buf - (message "Reverting file %s..." filename) - (revert-buffer t t) - (message "Reverting file %s... done" filename))) - ((yes-or-no-p - (if (string= (file-name-nondirectory filename) - (buffer-name buf)) - (format - (if (buffer-modified-p buf) - (gettext "File %s changed on disk. Discard your edits? ") - (gettext "File %s changed on disk. Reread from disk? ")) - (file-name-nondirectory filename)) - (format - (if (buffer-modified-p buf) - (gettext "File %s changed on disk. Discard your edits in %s? ") - (gettext "File %s changed on disk. Reread from disk into %s? ")) - (file-name-nondirectory filename) - (buffer-name buf)))) - (save-excursion - (set-buffer buf) - (revert-buffer t t))))) - ;; Else: we must create a new buffer for filename - (save-excursion -;;; The truename stuff makes this obsolete. -;;; (let* ((link-name (car (file-attributes filename))) -;;; (linked-buf (and (stringp link-name) -;;; (get-file-buffer link-name)))) -;;; (if (bufferp linked-buf) -;;; (message "Symbolic link to file in buffer %s" -;;; (buffer-name linked-buf)))) - (setq buf (create-file-buffer filename)) - (set-buffer-major-mode buf) - (set-buffer buf) - (erase-buffer) - (if rawfile - (condition-case () - (insert-file-contents-literally filename t) - (file-error - ;; Unconditionally set error - (setq error t))) - (condition-case e - (insert-file-contents filename t) - (file-error - ;; Run find-file-not-found-hooks until one returns non-nil. - (or (run-hook-with-args-until-success 'find-file-not-found-hooks) - ;; If they fail too, set error. - (setq error e))))) - ;; Find the file's truename, and maybe use that as visited name. - ;; automatically computed in XEmacs. -; (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)) -; (if find-file-visit-truename -; (setq buffer-file-name -; (setq filename -; (expand-file-name buffer-file-truename)))) - (and find-file-use-truenames - ;; This should be in C. Put pathname abbreviations that have - ;; been explicitly requested back into the pathname. Most - ;; importantly, strip out automounter /tmp_mnt directories so - ;; that auto-save will work - (setq buffer-file-name (abbreviate-file-name buffer-file-name))) - ;; Set buffer's default directory to that of the file. - (setq default-directory (file-name-directory buffer-file-name)) - ;; Turn off backup files for certain file names. Since - ;; this is a permanent local, the major mode won't eliminate it. - (and (not (funcall backup-enable-predicate buffer-file-name)) - (progn - (make-local-variable 'backup-inhibited) - (setq backup-inhibited t))) - (if rawfile - nil - (after-find-file error (not nowarn)) - (setq buf (current-buffer))))) - buf))) - -(defvar after-find-file-from-revert-buffer nil) - -(defun after-find-file (&optional error warn noauto - after-find-file-from-revert-buffer - nomodes) - "Called after finding a file and by the default revert function. -Sets buffer mode, parses local variables. -Optional args ERROR, WARN, and NOAUTO: ERROR non-nil means there was an -error in reading the file. WARN non-nil means warn if there -exists an auto-save file more recent than the visited file. -NOAUTO means don't mess with auto-save mode. -Fourth arg AFTER-FIND-FILE-FROM-REVERT-BUFFER non-nil - means this call was from `revert-buffer'. -Fifth arg NOMODES non-nil means don't alter the file's modes. -Finishes by calling the functions in `find-file-hooks'." - (setq buffer-read-only (not (file-writable-p buffer-file-name))) - (if noninteractive - nil - (let* (not-serious - (msg - (cond ((and error (file-attributes buffer-file-name)) - (setq buffer-read-only t) - (gettext "File exists, but cannot be read.")) - ((not buffer-read-only) - (if (and warn - (file-newer-than-file-p (make-auto-save-file-name) - buffer-file-name)) - (format "%s has auto save data; consider M-x recover-file" - (setq not-serious t) - (if error (gettext "(New file)") nil)))) - ((not error) - (setq not-serious t) - (gettext "Note: file is write protected")) - ((file-attributes (directory-file-name default-directory)) - (gettext "File not found and directory write-protected")) - ((file-exists-p (file-name-directory buffer-file-name)) - (setq buffer-read-only nil)) - (t - ;; If the directory the buffer is in doesn't exist, - ;; offer to create it. It's better to do this now - ;; than when we save the buffer, because we want - ;; autosaving to work. - (setq buffer-read-only nil) - ;; XEmacs - (or (file-exists-p (file-name-directory buffer-file-name)) - (if (yes-or-no-p - (format - "The directory containing %s does not exist. Create? " - (abbreviate-file-name buffer-file-name))) - (make-directory (file-name-directory - buffer-file-name) - t))) - nil)))) - (if msg - (progn - (message msg) - (or not-serious (sit-for 1 t))))) - (if (and auto-save-default (not noauto)) - (auto-save-mode t))) - (unless nomodes - (normal-mode t) - (run-hooks 'find-file-hooks))) - -(defun normal-mode (&optional find-file) - "Choose the major mode for this buffer automatically. -Also sets up any specified local variables of the file. -Uses the visited file name, the -*- line, and the local variables spec. - -This function is called automatically from `find-file'. In that case, -we may set up specified local variables depending on the value of -`enable-local-variables': if it is t, we do; if it is nil, we don't; -otherwise, we query. `enable-local-variables' is ignored if you -run `normal-mode' explicitly." - (interactive) - (or find-file (funcall (or default-major-mode 'fundamental-mode))) - (and (condition-case err - (progn (set-auto-mode) - t) - (error (message "File mode specification error: %s" - (prin1-to-string err)) - nil)) - (condition-case err - (hack-local-variables (not find-file)) - (error (message "File local-variables error: %s" - (prin1-to-string err)))))) - -(defvar auto-mode-alist - '(("\\.te?xt\\'" . text-mode) - ("\\.[ch]\\'" . c-mode) - ("\\.el\\'" . emacs-lisp-mode) - ("\\.\\([CH]\\|cc\\|hh\\)\\'" . c++-mode) - ("\\.[ch]\\(pp\\|xx\\|\\+\\+\\)\\'" . c++-mode) - ("\\.java\\'" . java-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. - ("\\.p[lm]\\'" . perl-mode) - ("\\.py\\'" . python-mode) - ("\\.texi\\(nfo\\)?\\'" . texinfo-mode) - ("\\.ad[abs]\\'" . ada-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) - ("\\$CHANGE_LOG\\$\\.TXT" . change-log-mode) - ("\\.scm\\(\\.[0-9]*\\)?\\'" . scheme-mode) - ("\\.e\\'" . eiffel-mode) - ("\\.mss\\'" . scribe-mode) - ("\\.m\\([mes]\\|an\\)\\'" . nroff-mode) - ("\\.icn\\'" . icon-mode) - ("\\.\\([ckz]?sh\\|shar\\)\\'" . 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 should 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) - ("\\.bib\\'" . bibtex-mode) - ("\\.article\\'" . text-mode) - ("\\.letter\\'" . text-mode) - ("\\.\\(tcl\\|exp\\)\\'" . tcl-mode) - ("\\.wrl\\'" . vrml-mode) - ("\\.awk\\'" . awk-mode) - ("\\.prolog\\'" . prolog-mode) - ("\\.tar\\'" . tar-mode) - ("\\.\\(arc\\|zip\\|lzh\\|zoo\\)\\'" . archive-mode) - ;; Mailer puts message to be edited in - ;; /tmp/Re.... or Message - ("^/tmp/Re" . text-mode) - ("/Message[0-9]*\\'" . text-mode) - ("/drafts/[0-9]+\\'" . mh-letter-mode) - ;; some news reader is reported to use this - ("^/tmp/fol/" . text-mode) - ("\\.y\\'" . c-mode) - ("\\.lex\\'" . c-mode) - ("\\.m\\'" . objc-mode) - ("\\.oak\\'" . scheme-mode) - ("\\.s?html?\\'" . html-mode) - ("\\.htm?l?3\\'" . html3-mode) - ("\\.\\(sgml?\\|dtd\\)\\'" . sgml-mode) - ("\\.c?ps\\'" . postscript-mode) - ;; .emacs following a directory delimiter - ;; in either Unix or VMS syntax. - ("[]>:/]\\..*emacs\\'" . emacs-lisp-mode) - ;; _emacs following a directory delimiter - ;; in MsDos syntax - ("[:/]_emacs\\'" . emacs-lisp-mode) - ("\\.m4\\'" . autoconf-mode) - ("configure\\.in\\'" . autoconf-mode) - ("\\.ml\\'" . lisp-mode) - ("\\.ma?k\\'" . makefile-mode) - ("[Mm]akefile\\(\\.\\|\\'\\)" . makefile-mode) - ("\\.X\\(defaults\\|environment\\|resources\\|modmap\\)\\'" . xrdb-mode) - ("/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) - ) -"Alist of filename patterns vs. corresponding major mode functions. -Each element looks like (REGEXP . FUNCTION) or (REGEXP FUNCTION NON-NIL). -\(NON-NIL stands for anything that is not nil; the value does not matter.) -Visiting a file whose name matches REGEXP specifies FUNCTION as the -mode function to use. FUNCTION will be called, unless it is nil. - -If the element has the form (REGEXP FUNCTION NON-NIL), then after -calling FUNCTION (if it's not nil), we delete the suffix that matched -REGEXP and search the list again for another match.") - -(defconst interpreter-mode-alist - '(("^#!.*csh" . sh-mode) - ("^#!.*sh\\b" . sh-mode) - ("^#!.*\\b\\(scope\\|wish\\|tcl\\|expect\\)" . tcl-mode) - ("perl" . perl-mode) - ("python" . python-mode) - ("awk\\b" . awk-mode) - ("rexx" . rexx-mode) - ("scm" . scheme-mode) - ("^:" . sh-mode)) - "Alist mapping interpreter names to major modes. -This alist is used to guess the major mode of a file based on the -contents of the first line. This line often contains something like: -#!/bin/sh -but may contain something more imaginative like -#! /bin/env python -or -eval 'exec perl -w -S $0 ${1+\"$@\"}'. - -Each alist element looks like (INTERPRETER . MODE). -The car of each element is a regular expression which is compared -with the name of the interpreter specified in the first line. -If it matches, mode MODE is selected.") - -(defconst inhibit-first-line-modes-regexps (purecopy '("\\.tar\\'")) - "List of regexps; if one matches a file name, don't look for `-*-'.") - -(defconst inhibit-first-line-modes-suffixes nil - "List of regexps for what to ignore, for `inhibit-first-line-modes-regexps'. -When checking `inhibit-first-line-modes-regexps', we first discard -from the end of the file name anything that matches one of these regexps.") - -(defvar user-init-file - "" ; set by command-line - "File name including directory of user's initialization file.") - -(defun set-auto-mode () - "Select major mode appropriate for current buffer. -This checks for a -*- mode tag in the buffer's text, -compares the filename against the entries in `auto-mode-alist', -or checks the interpreter that runs this file against -`interpreter-mode-alist'. - -It does not check for the `mode:' local variable in the -Local Variables section of the file; for that, use `hack-local-variables'. - -If `enable-local-variables' is nil, this function does not check for a --*- mode tag." - (save-excursion - ;; Look for -*-MODENAME-*- or -*- ... mode: MODENAME; ... -*- - ;; Do this by calling the hack-local-variables helper to avoid redundancy. - ;; We bind enable-local-variables to nil this time because we're going to - ;; call hack-local-variables-prop-line again later, "for real." - (or (let ((enable-local-variables nil)) - (hack-local-variables-prop-line nil)) - ;; It's not in the -*- line, so check the auto-mode-alist, unless - ;; this buffer isn't associated with a file. - (null buffer-file-name) - (let ((name (file-name-sans-versions buffer-file-name)) - (keep-going t)) - (while keep-going - (setq keep-going nil) - (let ((alist auto-mode-alist) - (mode nil)) - ;; Find first matching alist entry. - (let ((case-fold-search - (memq system-type '(vax-vms windows-nt)))) - (while (and (not mode) alist) - (if (string-match (car (car alist)) name) - (if (and (consp (cdr (car alist))) - (nth 2 (car alist))) - (progn - (setq mode (car (cdr (car alist))) - name (substring name 0 (match-beginning 0)) - keep-going t)) - (setq mode (cdr (car alist)) - keep-going nil))) - (setq alist (cdr alist)))) - ;; If we can't deduce a mode from the file name, - ;; look for an interpreter specified in the first line. - (if (and (null mode) - (save-excursion ; XEmacs - (goto-char (point-min)) - (looking-at "#!"))) - (let ((firstline - (buffer-substring - (point-min) - (save-excursion - (goto-char (point-min)) (end-of-line) (point))))) - (setq alist interpreter-mode-alist) - (while alist - (if (string-match (car (car alist)) firstline) - (progn - (setq mode (cdr (car alist))) - (setq alist nil)) - (setq alist (cdr alist)))))) - (if mode - (funcall mode)) - )))))) - -(defvar hack-local-variables-hook nil - "Normal hook run after processing a file's local variables specs. -Major modes can use this to examine user-specified local variables -in order to initialize other data structure based on them. - -This hook runs even if there were no local variables or if their -evaluation was suppressed. See also `enable-local-variables' and -`enable-local-eval'.") - -(defun hack-local-variables (&optional force) - "Parse, and bind or evaluate as appropriate, any local variables -for current buffer." - ;; Don't look for -*- if this file name matches any - ;; of the regexps in inhibit-first-line-modes-regexps. - (if (or (null buffer-file-name) ; don't lose if buffer has no file! - (not (let ((temp inhibit-first-line-modes-regexps) - (name (if buffer-file-name - (file-name-sans-versions buffer-file-name) - (buffer-name)))) - (while (let ((sufs inhibit-first-line-modes-suffixes)) - (while (and sufs (not - (string-match (car sufs) name))) - (setq sufs (cdr sufs))) - sufs) - (setq name (substring name 0 (match-beginning 0)))) - (while (and temp - (not (string-match (car temp) name))) - (setq temp (cdr temp)) - temp)))) - (progn - ;; Look for variables in the -*- line. - (hack-local-variables-prop-line force) - ;; Look for "Local variables:" block in last page. - (hack-local-variables-last-page force))) - (run-hooks 'hack-local-variables-hook)) - -;;; Local variables may be specified in the last page of the file (within 3k -;;; from the end of the file and after the last ^L) in the form -;;; -;;; Local variables: -;;; variable-name: variable-value -;;; end: -;;; -;;; The lines may begin with a common prefix, like ";;; " in the above -;;; example. They may also have a common suffix (" */" for example). In -;;; this form, the local variable "mode" can be used to change the major -;;; mode, and the local variable "eval" can be used to evaluate an arbitrary -;;; form. -;;; -;;; Local variables may also be specified in the first line of the file. -;;; Embedded in this line are a pair of "-*-" sequences. What lies between -;;; them are variable-name/variable-value pairs, like: -;;; -;;; -*- mode: emacs-lisp -*- -;;; or -*- mode: postscript; version-control: never -*- -;;; or -*- tags-file-name: "/foo/bar/TAGS" -*- -;;; -;;; The local variable "eval" is not used with this form. For hysterical -;;; reasons, the syntax "-*- modename -*-" is allowed as well. -;;; - -(defun hack-local-variables-p (modeline) - (or (eq enable-local-variables t) - (and enable-local-variables - (save-window-excursion - (condition-case nil - (switch-to-buffer (current-buffer)) - (error - ;; If we fail to switch in the selected window, - ;; it is probably a minibuffer. - ;; So try another window. - (condition-case nil - (switch-to-buffer-other-window (current-buffer)) - (error - (switch-to-buffer-other-frame (current-buffer)))))) - (or modeline (save-excursion - (beginning-of-line) - (set-window-start (selected-window) (point)))) - (y-or-n-p (format - "Set local variables as specified %s of %s? " - (if modeline "in -*- line" "at end") - (if buffer-file-name - (file-name-nondirectory buffer-file-name) - (concat "buffer " (buffer-name))))))))) - -(defun hack-local-variables-last-page (&optional force) - ;; Set local variables set in the "Local Variables:" block of the last page. - (save-excursion - (goto-char (point-max)) - (search-backward "\n\^L" (max (- (point-max) 3000) (point-min)) 'move) - (if (let ((case-fold-search t)) - (and (search-forward "Local Variables:" nil t) - (or force - (hack-local-variables-p nil)))) - (let ((continue t) - prefix prefixlen suffix beg - (enable-local-eval enable-local-eval)) - ;; The prefix is what comes before "local variables:" in its line. - ;; The suffix is what comes after "local variables:" in its line. - (skip-chars-forward " \t") - (or (eolp) - (setq suffix (buffer-substring (point) - (progn (end-of-line) (point))))) - (goto-char (match-beginning 0)) - (or (bolp) - (setq prefix - (buffer-substring (point) - (progn (beginning-of-line) (point))))) - (if prefix (setq prefixlen (length prefix) - prefix (regexp-quote prefix))) - (if suffix (setq suffix (concat (regexp-quote suffix) "$"))) - (while continue - ;; Look at next local variable spec. - (if selective-display (re-search-forward "[\n\C-m]") - (forward-line 1)) - ;; Skip the prefix, if any. - (if prefix - (if (looking-at prefix) - (forward-char prefixlen) - (error "Local variables entry is missing the prefix"))) - ;; Find the variable name; strip whitespace. - (skip-chars-forward " \t") - (setq beg (point)) - (skip-chars-forward "^:\n") - (if (eolp) (error "Missing colon in local variables entry")) - (skip-chars-backward " \t") - (let* ((str (buffer-substring beg (point))) - (var (read str)) - val) - ;; Setting variable named "end" means end of list. - (if (string-equal (downcase str) "end") - (setq continue nil) - ;; Otherwise read the variable value. - (skip-chars-forward "^:") - (forward-char 1) - (setq val (read (current-buffer))) - (skip-chars-backward "\n") - (skip-chars-forward " \t") - (or (if suffix (looking-at suffix) (eolp)) - (error "Local variables entry is terminated incorrectly")) - ;; Set the variable. "Variables" mode and eval are funny. - (hack-one-local-variable var val)))))))) - -;; jwz - New Version 20.1/19.15 -(defun hack-local-variables-prop-line (&optional force) - ;; Set local variables specified in the -*- line. - ;; Returns t if mode was set. - (let ((result nil)) - (save-excursion - (goto-char (point-min)) - (skip-chars-forward " \t\n\r") - (let ((end (save-excursion - ;; If the file begins with "#!" - ;; (un*x exec interpreter magic), look - ;; for mode frobs in the first two - ;; lines. You cannot necessarily - ;; put them in the first line of - ;; such a file without screwing up - ;; the interpreter invocation. - (end-of-line (and (looking-at "^#!") 2)) - (point)))) - ;; Parse the -*- line into the `result' alist. - (cond ((not (search-forward "-*-" end t)) - ;; doesn't have one. - (setq force t)) - ((looking-at "[ \t]*\\([^ \t\n\r:;]+\\)\\([ \t]*-\\*-\\)") - ;; Antiquated form: "-*- ModeName -*-". - (setq result - (list (cons 'mode - (intern (buffer-substring - (match-beginning 1) - (match-end 1))))) - )) - (t - ;; Usual form: '-*-' [ <variable> ':' <value> ';' ]* '-*-' - ;; (last ";" is optional). - (save-excursion - (if (search-forward "-*-" end t) - (setq end (- (point) 3)) - (error "-*- not terminated before end of line"))) - (while (< (point) end) - (or (looking-at "[ \t]*\\([^ \t\n:]+\\)[ \t]*:[ \t]*") - (error "malformed -*- line")) - (goto-char (match-end 0)) - ;; There used to be a downcase here, - ;; but the manual didn't say so, - ;; and people want to set var names that aren't all lc. - (let ((key (intern (buffer-substring - (match-beginning 1) - (match-end 1)))) - (val (save-restriction - (narrow-to-region (point) end) - (read (current-buffer))))) - ;; Case sensitivity! Icepicks in my forehead! - (if (equal (downcase (symbol-name key)) "mode") - (setq key 'mode)) - (setq result (cons (cons key val) result)) - (skip-chars-forward " \t;"))) - (setq result (nreverse result)))))) - - (let ((set-any-p (or force (hack-local-variables-p t))) - (mode-p nil)) - (while result - (let ((key (car (car result))) - (val (cdr (car result)))) - (cond ((eq key 'mode) - (and enable-local-variables - (setq mode-p t) - (funcall (intern (concat (downcase (symbol-name val)) - "-mode"))))) - (set-any-p - (hack-one-local-variable key val)) - (t - nil))) - (setq result (cdr result))) - mode-p))) - -(defconst ignored-local-variables - (list 'enable-local-eval) - "Variables to be ignored in a file's local variable spec.") - -;; Get confirmation before setting these variables as locals in a file. -(put 'debugger 'risky-local-variable t) -(put 'enable-local-eval 'risky-local-variable t) -(put 'ignored-local-variables 'risky-local-variable t) -(put 'eval 'risky-local-variable t) -(put 'file-name-handler-alist 'risky-local-variable t) -(put 'minor-mode-map-alist 'risky-local-variable t) -(put 'after-load-alist 'risky-local-variable t) -(put 'buffer-file-name 'risky-local-variable t) -(put 'buffer-auto-save-file-name 'risky-local-variable t) -(put 'buffer-file-truename 'risky-local-variable t) -(put 'exec-path 'risky-local-variable t) -(put 'load-path 'risky-local-variable t) -(put 'exec-directory 'risky-local-variable t) -(put 'process-environment 'risky-local-variable t) -;; Don't wait for outline.el to be loaded, for the sake of outline-minor-mode. -(put 'outline-level 'risky-local-variable t) -(put 'rmail-output-file-alist 'risky-local-variable t) - -;; This one is safe because the user gets to check it before it is used. -(put 'compile-command 'safe-local-variable t) - -;(defun hack-one-local-variable-quotep (exp) -; (and (consp exp) (eq (car exp) 'quote) (consp (cdr exp)))) - -;; "Set" one variable in a local variables spec. -;; A few variable names are treated specially. -(defun hack-one-local-variable (var val) - (cond ((eq var 'mode) - (funcall (intern (concat (downcase (symbol-name val)) - "-mode")))) - ((memq var ignored-local-variables) - nil) - ;; "Setting" eval means either eval it or do nothing. - ;; Likewise for setting hook variables. - ((or (get var 'risky-local-variable) - (and - (string-match "-hooks?$\\|-functions?$\\|-forms?$\\|-program$\\|-command$" - (symbol-name var)) - (not (get var 'safe-local-variable)))) -; ;; Permit evaling a put of a harmless property -; ;; if the args do nothing tricky. -; (if (or (and (eq var 'eval) -; (consp val) -; (eq (car val) 'put) -; (hack-one-local-variable-quotep (nth 1 val)) -; (hack-one-local-variable-quotep (nth 2 val)) -; ;; Only allow safe values of lisp-indent-hook; -; ;; not functions. -; (or (numberp (nth 3 val)) -; (equal (nth 3 val) ''defun)) -; (memq (nth 1 (nth 2 val)) -; '(lisp-indent-hook))) - (if (and (not (zerop (user-uid))) - (or (eq enable-local-eval t) - (and enable-local-eval - (save-window-excursion - (switch-to-buffer (current-buffer)) - (save-excursion - (beginning-of-line) - (set-window-start (selected-window) (point))) - (setq enable-local-eval - (y-or-n-p (format "Process `eval' or hook local variables in file %s? " - (file-name-nondirectory buffer-file-name)))))))) - (if (eq var 'eval) - (save-excursion (eval val)) - (make-local-variable var) - (set var val)) - (message "Ignoring `eval:' in file's local variables"))) - ;; Ordinary variable, really set it. - (t (make-local-variable var) - (set var val)))) - -(defun set-visited-file-name (filename) - "Change name of file visited in current buffer to FILENAME. -The next time the buffer is saved it will go in the newly specified file. -nil or empty string as argument means make buffer not be visiting any file. -Remember to delete the initial contents of the minibuffer -if you wish to pass an empty string as the argument." - (interactive "FSet visited file name: ") - (if (buffer-base-buffer) - (error "An indirect buffer cannot visit a file")) - (let (truename) - (if filename - (setq filename - (if (string-equal filename "") - nil - (expand-file-name filename)))) - (if filename - (progn - (setq truename (file-truename filename)) - ;; #### Do we need to check if truename is non-nil? - (if find-file-use-truenames - (setq filename truename)))) - (or (equal filename buffer-file-name) - (progn - (and filename (lock-buffer filename)) - (unlock-buffer))) - (setq buffer-file-name filename) - (if filename ; make buffer name reflect filename. - (let ((new-name (file-name-nondirectory buffer-file-name))) - (if (string= new-name "") - (error "Empty file name")) - (if (eq system-type 'vax-vms) - (setq new-name (downcase new-name))) - (setq default-directory (file-name-directory buffer-file-name)) - (or (string= new-name (buffer-name)) - (rename-buffer new-name t)))) - (setq buffer-backed-up nil) - (clear-visited-file-modtime) - (compute-buffer-file-truename) ; insert-file-contents does this too. -; ;; Abbreviate the file names of the buffer. -; (if truename -; (progn -; (setq buffer-file-truename (abbreviate-file-name truename)) -; (if find-file-visit-truename -; (setq buffer-file-name buffer-file-truename)))) - (setq buffer-file-number - (if filename - (nthcdr 10 (file-attributes buffer-file-name)) - nil))) - ;; write-file-hooks is normally used for things like ftp-find-file - ;; that visit things that are not local files as if they were files. - ;; Changing to visit an ordinary local file instead should flush the hook. - (kill-local-variable 'write-file-hooks) - (kill-local-variable 'after-save-hook) - (kill-local-variable 'local-write-file-hooks) - (kill-local-variable 'write-file-data-hooks) - (kill-local-variable 'revert-buffer-function) - (kill-local-variable 'backup-inhibited) - ;; If buffer was read-only because of version control, - ;; that reason is gone now, so make it writable. - (if (and (boundp 'vc-mode) vc-mode) - (setq buffer-read-only nil)) - (kill-local-variable 'vc-mode) - ;; Turn off backup files for certain file names. - ;; Since this is a permanent local, the major mode won't eliminate it. - (and (not (funcall backup-enable-predicate buffer-file-name)) - (progn - (make-local-variable 'backup-inhibited) - (setq backup-inhibited t))) - (let ((oauto buffer-auto-save-file-name)) - ;; If auto-save was not already on, turn it on if appropriate. - (if (not buffer-auto-save-file-name) - (and buffer-file-name auto-save-default - (auto-save-mode t)) - ;; If auto save is on, start using a new name. - ;; We deliberately don't rename or delete the old auto save - ;; for the old visited file name. This is because perhaps - ;; the user wants to save the new state and then compare with the - ;; previous state from the auto save file. - (setq buffer-auto-save-file-name - (make-auto-save-file-name))) - ;; Rename the old auto save file if any. - (and oauto buffer-auto-save-file-name - (file-exists-p oauto) - (rename-file oauto buffer-auto-save-file-name t))) - (if buffer-file-name - (set-buffer-modified-p t)) - ;; #### ?? - (run-hooks 'after-set-visited-file-name-hooks)) - -(defun write-file (filename &optional confirm codesys) - "Write current buffer into file FILENAME. -Makes buffer visit that file, and marks it not modified. -If the buffer is already visiting a file, you can specify -a directory name as FILENAME, to write a file of the same -old name in that directory. -If optional second arg CONFIRM is non-nil, -ask for confirmation for overwriting an existing file. -Under XEmacs/Mule, optional third argument specifies the -coding system to use when encoding the file. Interactively, -with a prefix argument, you will be prompted for the coding system." -;; (interactive "FWrite file: ") - (interactive - (list (if buffer-file-name - (read-file-name "Write file: " - nil nil nil nil) - (read-file-name "Write file: " - (cdr (assq 'default-directory - (buffer-local-variables))) - nil nil (buffer-name))) - t - (if (and current-prefix-arg (featurep 'mule)) - (read-coding-system "Coding system: ")))) - (and (eq (current-buffer) mouse-grabbed-buffer) - (error "Can't write minibuffer window")) - (or (null filename) (string-equal filename "") - (progn - ;; If arg is just a directory, - ;; use same file name, but in that directory. - (if (and (file-directory-p filename) buffer-file-name) - (setq filename (concat (file-name-as-directory filename) - (file-name-nondirectory buffer-file-name)))) - (and confirm - (file-exists-p filename) - (or (y-or-n-p (format "File `%s' exists; overwrite? " filename)) - (error "Canceled"))) - (set-visited-file-name filename))) - (set-buffer-modified-p t) - (setq buffer-read-only nil) - (if codesys - (let ((buffer-file-coding-system (get-coding-system codesys))) - (save-buffer)) - (save-buffer))) - -(defun backup-buffer () - "Make a backup of the disk file visited by the current buffer, if appropriate. -This is normally done before saving the buffer the first time. -If the value is non-nil, it is the result of `file-modes' on the original file; -this means that the caller, after saving the buffer, should change the modes -of the new file to agree with the old modes." - (if buffer-file-name - (let ((handler (find-file-name-handler buffer-file-name 'backup-buffer))) - (if handler - (funcall handler 'backup-buffer) - (if (and make-backup-files - (not backup-inhibited) - (not buffer-backed-up) - (file-exists-p buffer-file-name) - (memq (aref (elt (file-attributes buffer-file-name) 8) 0) - '(?- ?l))) - (let ((real-file-name buffer-file-name) - backup-info backupname targets setmodes) - ;; If specified name is a symbolic link, chase it to the target. - ;; Thus we make the backups in the directory where the real file is. - (setq real-file-name (file-chase-links real-file-name)) - (setq backup-info (find-backup-file-name real-file-name) - backupname (car backup-info) - targets (cdr backup-info)) -;;; (if (file-directory-p buffer-file-name) -;;; (error "Cannot save buffer in directory %s" buffer-file-name)) - (if backup-info - (condition-case () - (let ((delete-old-versions - ;; If have old versions to maybe delete, - ;; ask the user to confirm now, before doing anything. - ;; But don't actually delete til later. - (and targets - (or (eq delete-old-versions t) - (eq delete-old-versions nil)) - (or delete-old-versions - (y-or-n-p (format "Delete excess backup versions of %s? " - real-file-name)))))) - ;; Actually write the back up file. - (condition-case () - (if (or file-precious-flag - ; (file-symlink-p buffer-file-name) - backup-by-copying - (and backup-by-copying-when-linked - (> (file-nlinks real-file-name) 1)) - (and backup-by-copying-when-mismatch - (let ((attr (file-attributes real-file-name))) - (or (nth 9 attr) - (not (file-ownership-preserved-p real-file-name)))))) - (condition-case () - (copy-file real-file-name backupname t t) - (file-error - ;; If copying fails because file BACKUPNAME - ;; is not writable, delete that file and try again. - (if (and (file-exists-p backupname) - (not (file-writable-p backupname))) - (delete-file backupname)) - (copy-file real-file-name backupname t t))) - ;; rename-file should delete old backup. - (rename-file real-file-name backupname t) - (setq setmodes (file-modes backupname))) - (file-error - ;; If trouble writing the backup, write it in ~. - (setq backupname (expand-file-name "~/%backup%~")) - (message "Cannot write backup file; backing up in ~/%%backup%%~") - (sleep-for 1) - (condition-case () - (copy-file real-file-name backupname t t) - (file-error - ;; If copying fails because file BACKUPNAME - ;; is not writable, delete that file and try again. - (if (and (file-exists-p backupname) - (not (file-writable-p backupname))) - (delete-file backupname)) - (copy-file real-file-name backupname t t))))) - (setq buffer-backed-up t) - ;; Now delete the old versions, if desired. - (if delete-old-versions - (while targets - (condition-case () - (delete-file (car targets)) - (file-error nil)) - (setq targets (cdr targets)))) - setmodes) - (file-error nil))))))))) - -(defun file-name-sans-versions (name &optional keep-backup-version) - "Return FILENAME sans backup versions or strings. -This is a separate procedure so your site-init or startup file can -redefine it. -If the optional argument KEEP-BACKUP-VERSION is non-nil, -we do not remove backup version numbers, only true file version numbers." - (let ((handler (find-file-name-handler name 'file-name-sans-versions))) - (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)))))))) - -(defun file-ownership-preserved-p (file) - "Returns t if deleting FILE and rewriting it would preserve the owner." - (let ((handler (find-file-name-handler file 'file-ownership-preserved-p))) - (if handler - (funcall handler 'file-ownership-preserved-p file) - (let ((attributes (file-attributes file))) - ;; Return t if the file doesn't exist, since it's true that no - ;; information would be lost by an (attempted) delete and create. - (or (null attributes) - (= (nth 2 attributes) (user-uid))))))) - -(defun file-name-sans-extension (filename) - "Return FILENAME sans final \"extension\". -The extension, in a file name, is the part that follows the last `.'." - (save-match-data - (let ((file (file-name-sans-versions (file-name-nondirectory filename))) - directory) - (if (string-match "\\.[^.]*\\'" file) - (if (setq directory (file-name-directory filename)) - (expand-file-name (substring file 0 (match-beginning 0)) - directory) - (substring file 0 (match-beginning 0))) - filename)))) - -(defun make-backup-file-name (file) - "Create the non-numeric backup file name for FILE. -This is a separate function so you can redefine it for customization." - (if (eq system-type 'ms-dos) - (let ((fn (file-name-nondirectory file))) - (concat (file-name-directory file) - (if (string-match "\\([^.]*\\)\\(\\..*\\)?" fn) - (substring fn 0 (match-end 1))) - ".bak")) - (concat file "~"))) - -(defun backup-file-name-p (file) - "Return non-nil if FILE is a backup file name (numeric or not). -This is a separate function so you can redefine it for customization. -You may need to redefine `file-name-sans-versions' as well." - (if (eq system-type 'ms-dos) - (string-match "\\.bak\\'" file) - (string-match "~\\'" file))) - -;; This is used in various files. -;; The usage of bv-length is not very clean, -;; but I can't see a good alternative, -;; so as of now I am leaving it alone. -(defun backup-extract-version (fn) - "Given the name of a numeric backup file, return the backup number. -Uses the free variable `bv-length', whose value should be -the index in the name where the version number begins." - (declare (special bv-length)) - (if (and (string-match "[0-9]+~\\'" fn bv-length) - (= (match-beginning 0) bv-length)) - (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 - and whose cdr is a list of old versions to consider deleting now. -If the value is nil, don't make a backup." - (let ((handler (find-file-name-handler fn 'find-backup-file-name))) - ;; Run a handler for this function so that ange-ftp can refuse to do it. - (if handler - (funcall handler 'find-backup-file-name fn) - (if (eq version-control 'never) - (list (make-backup-file-name fn)) - (let* ((base-versions (concat (file-name-nondirectory fn) ".~")) - ;; used by backup-extract-version: - (bv-length (length base-versions)) - possibilities - (versions nil) - (high-water-mark 0) - (deserve-versions-p nil) - (number-to-delete 0)) - (condition-case () - (setq possibilities (file-name-all-completions - base-versions - (file-name-directory fn)) - versions (sort (mapcar - #'backup-extract-version - possibilities) - '<) - high-water-mark (apply #'max 0 versions) - deserve-versions-p (or version-control - (> high-water-mark 0)) - number-to-delete (- (length versions) - kept-old-versions kept-new-versions -1)) - (file-error - (setq possibilities nil))) - (if (not deserve-versions-p) - (list (make-backup-file-name fn)) - (cons (concat fn ".~" (int-to-string (1+ high-water-mark)) "~") - (if (and (> number-to-delete 0) - ;; Delete nothing if there is overflow - ;; in the number of versions to keep. - (>= (+ kept-new-versions kept-old-versions -1) 0)) - (mapcar #'(lambda (n) - (concat fn ".~" (int-to-string n) "~")) - (let ((v (nthcdr kept-old-versions versions))) - (rplacd (nthcdr (1- number-to-delete) v) ()) - v)))))))))) - -(defun file-nlinks (filename) - "Return number of names file FILENAME has." - (car (cdr (file-attributes filename)))) - -(defun file-relative-name (filename &optional directory) - "Convert FILENAME to be relative to DIRECTORY (default: default-directory)." - (setq filename (expand-file-name filename) - directory (file-name-as-directory (expand-file-name - (or directory default-directory)))) - (let ((ancestor "")) - (while (not (string-match (concat "^" (regexp-quote directory)) filename)) - (setq directory (file-name-directory (substring directory 0 -1)) - ancestor (concat "../" ancestor))) - (concat ancestor (substring filename (match-end 0))))) - -(defun save-buffer (&optional args) - "Save current buffer in visited file if modified. Versions described below. - -By default, makes the previous version into a backup file - if previously requested or if this is the first save. -With 1 or 3 \\[universal-argument]'s, marks this version - to become a backup when the next save is done. -With 2 or 3 \\[universal-argument]'s, - unconditionally makes the previous version into a backup file. -With argument of 0, never makes the previous version into a backup file. - -If a file's name is FOO, the names of its numbered backup versions are - FOO.~i~ for various integers i. A non-numbered backup file is called FOO~. -Numeric backups (rather than FOO~) will be made if value of - `version-control' is not the atom `never' and either there are already - numeric versions of the file being backed up, or `version-control' is - non-nil. -We don't want excessive versions piling up, so there are variables - `kept-old-versions', which tells XEmacs how many oldest versions to keep, - and `kept-new-versions', which tells how many newest versions to keep. - Defaults are 2 old versions and 2 new. -`dired-kept-versions' controls dired's clean-directory (.) command. -If `delete-old-versions' is nil, system will query user - before trimming versions. Otherwise it does it silently." - (interactive "_p") - (let ((modp (buffer-modified-p)) - (large (> (buffer-size) 50000)) - (make-backup-files (or (and make-backup-files (not (eq args 0))) - (memq args '(16 64))))) - (and modp (memq args '(16 64)) (setq buffer-backed-up nil)) - (if (and modp large) (display-message - 'progress (format "Saving file %s..." - (buffer-file-name)))) - (basic-save-buffer) - (and modp (memq args '(4 64)) (setq buffer-backed-up nil)))) - -(defun delete-auto-save-file-if-necessary (&optional force) - "Delete auto-save file for current buffer if `delete-auto-save-files' is t. -Normally delete only if the file was written by this XEmacs -since the last real save, but optional arg FORCE non-nil means delete anyway." - (and buffer-auto-save-file-name delete-auto-save-files - (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)) - (set-buffer-auto-saved)))) - -;; XEmacs change (from Sun) -;; used to communicate with continue-save-buffer: -(defvar continue-save-buffer-hooks-tail nil) - -;; Not in FSFmacs -(defun basic-write-file-data (realname truename) - ;; call the hooks until the bytes are put - ;; call write-region as a last resort - (let ((region-written nil) - (hooks write-file-data-hooks)) - (while (and hooks (not region-written)) - (setq region-written (funcall (car hooks) realname) - hooks (cdr hooks))) - (if (not region-written) - (write-region (point-min) (point-max) realname nil t truename)))) - -(put 'after-save-hook 'permanent-local t) -(defvar after-save-hook nil - "Normal hook that is run after a buffer is saved to its file. -These hooks are considered to pertain to the visited file. -So this list is cleared if you change the visited file name.") - -(defun files-fetch-hook-value (hook) - (let ((localval (symbol-value hook)) - (globalval (default-value hook))) - (if (memq t localval) - (setq localval (append (delq t localval) (delq t globalval)))) - localval)) - -(defun basic-save-buffer () - "Save the current buffer in its visited file, if it has been modified. -After saving the buffer, run `after-save-hook'." - (interactive) - (save-excursion - ;; In an indirect buffer, save its base buffer instead. - (if (buffer-base-buffer) - (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 - (expand-file-name - (read-file-name "File to save in: ") nil))) - (and (file-exists-p filename) - (or (y-or-n-p (format "File `%s' exists; overwrite? " - filename)) - (error "Canceled"))) - (set-visited-file-name filename))) - (or (verify-visited-file-modtime (current-buffer)) - (not (file-exists-p buffer-file-name)) - (yes-or-no-p - (format "%s has changed since visited or saved. Save anyway? " - (file-name-nondirectory buffer-file-name))) - (error "Save not confirmed")) - (save-restriction - (widen) - (and (> (point-max) 1) - (/= (char-after (1- (point-max))) ?\n) - (not (and (eq selective-display t) - (= (char-after (1- (point-max))) ?\r))) - (or (eq require-final-newline t) - (and require-final-newline - (y-or-n-p - (format "Buffer %s does not end in newline. Add one? " - (buffer-name))))) - (save-excursion - (goto-char (point-max)) - (insert ?\n))) - ;; - ;; Run the write-file-hooks until one returns non-null. - ;; Bind after-save-hook to nil while running the - ;; write-file-hooks so that if this function is called - ;; recursively (from inside a write-file-hook) the - ;; after-hooks will only get run once (from the - ;; outermost call). - ;; - ;; Ugh, have to duplicate logic of run-hook-with-args-until-success - (let ((hooks (append (files-fetch-hook-value 'write-contents-hooks) - (files-fetch-hook-value - 'local-write-file-hooks) - (files-fetch-hook-value 'write-file-hooks))) - (after-save-hook nil) - (local-write-file-hooks nil) - (write-contents-hooks nil) - (write-file-hooks nil) - done) - (while (and hooks - (let ((continue-save-buffer-hooks-tail hooks)) - (not (setq done (funcall (car hooks)))))) - (setq hooks (cdr hooks))) - ;; If a hook returned t, file is already "written". - ;; Otherwise, write it the usual way now. - (if (not done) - (basic-save-buffer-1))) - ;; XEmacs: next two clauses (buffer-file-number setting and - ;; set-file-modes) moved into basic-save-buffer-1. - ) - ;; If the auto-save file was recent before this command, - ;; delete it now. - (delete-auto-save-file-if-necessary recent-save) - ;; Support VC `implicit' locking. - (when (fboundp 'vc-after-save) - (vc-after-save)) - (run-hooks 'after-save-hook)) - (display-message 'no-log "(No changes need to be saved)")))) - -;; This does the "real job" of writing a buffer into its visited file -;; and making a backup file. This is what is normally done -;; but inhibited if one of write-file-hooks returns non-nil. -;; It returns a value to store in setmodes. -(defun basic-save-buffer-1 () - (let (setmodes tempsetmodes) - (if (not (file-writable-p buffer-file-name)) - (let ((dir (file-name-directory buffer-file-name))) - (if (not (file-directory-p dir)) - (error "%s is not a directory" dir) - (if (not (file-exists-p buffer-file-name)) - (error "Directory %s write-protected" dir) - (if (yes-or-no-p - (format "File %s is write-protected; try to save anyway? " - (file-name-nondirectory - buffer-file-name))) - (setq tempsetmodes t) - (error - "Attempt to save to a file which you aren't allowed to write")))))) - (or buffer-backed-up - (setq setmodes (backup-buffer))) - (let ((dir (file-name-directory buffer-file-name))) - (if (and file-precious-flag - (file-writable-p dir)) - ;; If file is precious, write temp name, then rename it. - ;; This requires write access to the containing dir, - ;; which is why we don't try it if we don't have that access. - (let ((realname buffer-file-name) - tempname nogood i succeed - (old-modtime (visited-file-modtime))) - (setq i 0) - (setq nogood t) - ;; Find the temporary name to write under. - (while nogood - (setq tempname (format "%s#tmp#%d" dir i)) - (setq nogood (file-exists-p tempname)) - (setq i (1+ i))) - (unwind-protect - (progn (clear-visited-file-modtime) - (write-region (point-min) (point-max) - tempname nil realname - buffer-file-truename) - (setq succeed t)) - ;; If writing the temp file fails, - ;; delete the temp file. - (or succeed - (progn - (delete-file tempname) - (set-visited-file-modtime old-modtime)))) - ;; Since we have created an entirely new file - ;; and renamed it, make sure it gets the - ;; right permission bits set. - (setq setmodes (file-modes buffer-file-name)) - ;; We succeeded in writing the temp file, - ;; so rename it. - (rename-file tempname buffer-file-name t)) - ;; If file not writable, see if we can make it writable - ;; temporarily while we write it. - ;; But no need to do so if we have just backed it up - ;; (setmodes is set) because that says we're superseding. - (cond ((and tempsetmodes (not setmodes)) - ;; Change the mode back, after writing. - (setq setmodes (file-modes buffer-file-name)) - (set-file-modes buffer-file-name 511))) - (basic-write-file-data buffer-file-name buffer-file-truename))) - (setq buffer-file-number - (if buffer-file-name - (nth 10 (file-attributes buffer-file-name)) - nil)) - (if setmodes - (condition-case () - (set-file-modes buffer-file-name setmodes) - (error nil))))) - -;; XEmacs change, from Sun -(defun continue-save-buffer () - "Provide a clean way for a write-file-hook to wrap AROUND -the execution of the remaining hooks and writing to disk. -Do not call this function except from a functions -on the write-file-hooks or write-contents-hooks list. -A hook that calls this function must return non-nil, -to signal completion to its caller. continue-save-buffer -always returns non-nil." - (let ((hooks (cdr (or continue-save-buffer-hooks-tail - (error - "continue-save-buffer called outside a write-file-hook!")))) - (done nil)) - ;; Do something like this: - ;; (let ((write-file-hooks hooks)) (basic-save-buffer)) - ;; First run the rest of the hooks. - (while (and hooks - (let ((continue-save-buffer-hooks-tail hooks)) - (not (setq done (funcall (car hooks)))))) - (setq hooks (cdr hooks))) - ;; - ;; If a hook returned t, file is already "written". - (if (not done) - (basic-save-buffer-1)) - 'continue-save-buffer)) - -(defcustom save-some-buffers-query-display-buffer xemacs-betaname - "*Non-nil makes `\\[save-some-buffers]' switch to the buffer offered for saving." - :type 'boolean - :group 'editing-basics) - -(defun save-some-buffers (&optional arg exiting) - "Save some modified file-visiting buffers. Asks user about each one. -Optional argument (the prefix) non-nil means save all with no questions. -Optional second argument EXITING means ask about certain non-file buffers - as well as about file buffers." - (interactive "P") - (save-excursion - (save-window-excursion - ;; This can bomb during autoloads generation - (when (and (not noninteractive) - save-some-buffers-query-display-buffer) - (delete-other-windows)) - ;; XEmacs - do not use queried flag - (let ((files-done - (map-y-or-n-p - (function - (lambda (buffer) - (and (buffer-modified-p buffer) - (not (buffer-base-buffer buffer)) - ;; XEmacs addition: - (not (symbol-value-in-buffer 'save-buffers-skip buffer)) - (or - (buffer-file-name buffer) - (and exiting - (progn - (set-buffer buffer) - (and buffer-offer-save (> (buffer-size) 0))))) - (if arg - t - (when save-some-buffers-query-display-buffer - (condition-case nil - (switch-to-buffer buffer t) - (error nil))) - (if (buffer-file-name buffer) - (format "Save file %s? " - (buffer-file-name buffer)) - (format "Save buffer %s? " - (buffer-name buffer))))))) - (function - (lambda (buffer) - (set-buffer buffer) - (condition-case () - (save-buffer) - (error nil)))) - (buffer-list) - '("buffer" "buffers" "save") - ;;instead of this we just say "yes all", "no all", etc. - ;;"save all the rest" - ;;"save only this buffer" "save no more buffers") - ;; this is rather bogus. --ben - ;; (it makes the dialog box too big, and you get an error - ;; "wrong type argument: framep, nil" when you hit q after - ;; choosing the option from the dialog box) -; (list (list ?\C-r (lambda (buf) -; (view-buffer buf) -; (setq view-exit-action -; '(lambda (ignore) -; (exit-recursive-edit))) -; (recursive-edit) -; ;; Return nil to ask about BUF again. -; nil) -; "display the current buffer")) - )) - (abbrevs-done - (and save-abbrevs abbrevs-changed - (progn - (if (or arg - (y-or-n-p (format "Save abbrevs in %s? " abbrev-file-name))) - (write-abbrev-file nil)) - ;; Don't keep bothering user if he says no. - (setq abbrevs-changed nil) - t)))) - (or (> files-done 0) abbrevs-done - (display-message 'no-log "(No files need saving)")))))) - - -(defun not-modified (&optional arg) - "Mark current buffer as unmodified, not needing to be saved. -With prefix arg, mark buffer as modified, so \\[save-buffer] will save. - -It is not a good idea to use this function in Lisp programs, because it -prints a message in the minibuffer. Instead, use `set-buffer-modified-p'." - (interactive "_P") - (if arg ;; rewritten for I18N3 snarfing - (display-message 'command "Modification-flag set") - (display-message 'command "Modification-flag cleared")) - (set-buffer-modified-p arg)) - -(defun toggle-read-only (&optional arg) - "Change whether this buffer is visiting its file read-only. -With arg, set read-only iff arg is positive." - (interactive "_P") - (setq buffer-read-only - (if (null arg) - (not buffer-read-only) - (> (prefix-numeric-value arg) 0))) - ;; Force modeline redisplay - (redraw-modeline)) - -(defun insert-file (filename &optional codesys) - "Insert contents of file FILENAME into buffer after point. -Set mark after the inserted text. - -Under XEmacs/Mule, optional second argument specifies the -coding system to use when decoding the file. Interactively, -with a prefix argument, you will be prompted for the coding system. - -This function is meant for the user to run interactively. -Don't call it from programs! Use `insert-file-contents' instead. -\(Its calling sequence is different; see its documentation)." - (interactive "*fInsert file: \nZCoding system: ") - (if (file-directory-p filename) - (signal 'file-error (list "Opening input file" "file is a directory" - filename))) - (let ((tem - (if codesys - (let ((coding-system-for-read - (get-coding-system codesys))) - (insert-file-contents filename)) - (insert-file-contents filename)))) - (push-mark (+ (point) (car (cdr tem)))))) - -(defun append-to-file (start end filename &optional codesys) - "Append the contents of the region to the end of file FILENAME. -When called from a function, expects three arguments, -START, END and FILENAME. START and END are buffer positions -saying what text to write. -Under XEmacs/Mule, optional fourth argument specifies the -coding system to use when encoding the file. Interactively, -with a prefix argument, you will be prompted for the coding system." - (interactive "r\nFAppend to file: \nZCoding system: ") - (if codesys - (let ((buffer-file-coding-system (get-coding-system codesys))) - (write-region start end filename t)) - (write-region start end filename t))) - -(defun file-newest-backup (filename) - "Return most recent backup file for FILENAME or nil if no backups exist." - (let* ((filename (expand-file-name filename)) - (file (file-name-nondirectory filename)) - (dir (file-name-directory filename)) - (comp (file-name-all-completions file dir)) - newest) - (while comp - (setq file (concat dir (car comp)) - comp (cdr comp)) - (if (and (backup-file-name-p file) - (or (null newest) (file-newer-than-file-p file newest))) - (setq newest file))) - newest)) - -(defun rename-uniquely () - "Rename current buffer to a similar name not already taken. -This function is useful for creating multiple shell process buffers -or multiple mail buffers, etc." - (interactive) - (save-match-data - (let* ((base-name (if (and (string-match "<[0-9]+>\\'" (buffer-name)) - (not (and buffer-file-name - (string= (buffer-name) - (file-name-nondirectory - buffer-file-name))))) - ;; If the existing buffer name has a <NNN>, - ;; which isn't part of the file name (if any), - ;; then get rid of that. - (substring (buffer-name) 0 (match-beginning 0)) - (buffer-name))) - (new-buf (generate-new-buffer base-name)) - (name (buffer-name new-buf))) - (kill-buffer new-buf) - (rename-buffer name) - (redraw-modeline)))) - -(defun make-directory-path (path) - "Create all the directories along path that don't exist yet." - (interactive "Fdirectory path to create: ") - (make-directory path t)) - -(defun make-directory (dir &optional parents) - "Create the directory DIR and any nonexistent parent dirs. -Interactively, the default choice of directory to create -is the current default directory for file names. -That is useful when you have visited a file in a nonexistent directory. - -Noninteractively, the second (optional) argument PARENTS says whether -to create parent directories if they don't exist." - (interactive (list (let ((current-prefix-arg current-prefix-arg)) - (read-directory-name "Create directory: ")) - current-prefix-arg)) - (let ((handler (find-file-name-handler dir 'make-directory))) - (if handler - (funcall handler 'make-directory dir parents) - (if (not parents) - (make-directory-internal dir) - (let ((dir (directory-file-name (expand-file-name dir))) - create-list) - (while (not (file-exists-p dir)) - (setq create-list (cons dir create-list) - dir (directory-file-name (file-name-directory dir)))) - (while create-list - (make-directory-internal (car create-list)) - (setq create-list (cdr create-list)))))))) - -(put 'revert-buffer-function 'permanent-local t) -(defvar revert-buffer-function nil - "Function to use to revert this buffer, or nil to do the default. -The function receives two arguments IGNORE-AUTO and NOCONFIRM, -which are the arguments that `revert-buffer' received.") - -(put 'revert-buffer-insert-file-contents-function 'permanent-local t) -(defvar revert-buffer-insert-file-contents-function nil - "Function to use to insert contents when reverting this buffer. -Gets two args, first the nominal file name to use, -and second, t if reading the auto-save file.") - -(defvar before-revert-hook nil - "Normal hook for `revert-buffer' to run before reverting. -If `revert-buffer-function' is used to override the normal revert -mechanism, this hook is not used.") - -(defvar after-revert-hook nil - "Normal hook for `revert-buffer' to run after reverting. -Note that the hook value that it runs is the value that was in effect -before reverting; that makes a difference if you have buffer-local -hook functions. - -If `revert-buffer-function' is used to override the normal revert -mechanism, this hook is not used.") - -(defvar revert-buffer-internal-hook nil - "Don't use this.") - -(defun revert-buffer (&optional ignore-auto noconfirm preserve-modes) - "Replace the buffer text with the text of the visited file on disk. -This undoes all changes since the file was visited or saved. -With a prefix argument, offer to revert from latest auto-save file, if -that is more recent than the visited file. - -This command also works for special buffers that contain text which -doesn't come from a file, but reflects some other data base instead: -for example, Dired buffers and buffer-list buffers. In these cases, -it reconstructs the buffer contents from the appropriate data base. - -When called from Lisp, the first argument is IGNORE-AUTO; only offer -to revert from the auto-save file when this is nil. Note that the -sense of this argument is the reverse of the prefix argument, for the -sake of backward compatibility. IGNORE-AUTO is optional, defaulting -to nil. - -Optional second argument NOCONFIRM means don't ask for confirmation at -all. - -Optional third argument PRESERVE-MODES non-nil means don't alter -the files modes. Normally we reinitialize them using `normal-mode'. - -If the value of `revert-buffer-function' is non-nil, it is called to -do the work. - -The default revert function runs the hook `before-revert-hook' at the -beginning and `after-revert-hook' at the end." - ;; I admit it's odd to reverse the sense of the prefix argument, but - ;; there is a lot of code out there which assumes that the first - ;; argument should be t to avoid consulting the auto-save file, and - ;; there's no straightforward way to encourage authors to notice a - ;; reversal of the argument sense. So I'm just changing the user - ;; interface, but leaving the programmatic interface the same. - (interactive (list (not current-prefix-arg))) - (if revert-buffer-function - (funcall revert-buffer-function ignore-auto noconfirm) - (let* ((opoint (point)) - (auto-save-p (and (not ignore-auto) - (recent-auto-save-p) - buffer-auto-save-file-name - (file-readable-p buffer-auto-save-file-name) - (y-or-n-p - "Buffer has been auto-saved recently. Revert from auto-save file? "))) - (file-name (if auto-save-p - buffer-auto-save-file-name - buffer-file-name))) - (cond ((null file-name) - (error "Buffer does not seem to be associated with any file")) - ((or noconfirm - (and (not (buffer-modified-p)) - (let (found) - (dolist (rx revert-without-query found) - (when (string-match rx file-name) - (setq found t))))) - (yes-or-no-p (format "Revert buffer from file %s? " - file-name))) - (run-hooks 'before-revert-hook) - ;; If file was backed up but has changed since, - ;; we shd make another backup. - (and (not auto-save-p) - (not (verify-visited-file-modtime (current-buffer))) - (setq buffer-backed-up nil)) - ;; Get rid of all undo records for this buffer. - (or (eq buffer-undo-list t) - (setq buffer-undo-list nil)) - ;; Effectively copy the after-revert-hook status, - ;; since after-find-file will clobber it. - (let ((global-hook (default-value 'after-revert-hook)) - (local-hook-p (local-variable-p 'after-revert-hook - (current-buffer))) - (local-hook (and (local-variable-p 'after-revert-hook - (current-buffer)) - after-revert-hook))) - (let (buffer-read-only - ;; Don't make undo records for the reversion. - (buffer-undo-list t)) - (if revert-buffer-insert-file-contents-function - (funcall revert-buffer-insert-file-contents-function - file-name auto-save-p) - (if (not (file-exists-p file-name)) - (error "File %s no longer exists!" file-name)) - ;; Bind buffer-file-name to nil - ;; so that we don't try to lock the file. - (let ((buffer-file-name nil)) - (or auto-save-p - (unlock-buffer))) - (widen) - (insert-file-contents file-name (not auto-save-p) - nil nil t))) - (goto-char (min opoint (point-max))) - ;; Recompute the truename in case changes in symlinks - ;; have changed the truename. - ;XEmacs: already done by insert-file-contents - ;;(setq buffer-file-truename - ;;(abbreviate-file-name (file-truename buffer-file-name))) - (after-find-file nil nil t t preserve-modes) - ;; Run after-revert-hook as it was before we reverted. - (setq-default revert-buffer-internal-hook global-hook) - (if local-hook-p - (progn - (make-local-variable 'revert-buffer-internal-hook) - (setq revert-buffer-internal-hook local-hook)) - (kill-local-variable 'revert-buffer-internal-hook)) - (run-hooks 'revert-buffer-internal-hook)) - t))))) - -(defun recover-file (file) - "Visit file FILE, but get contents from its last auto-save file." - ;; Actually putting the file name in the minibuffer should be used - ;; only rarely. - ;; Not just because users often use the default. - (interactive "FRecover file: ") - (setq file (expand-file-name file)) - (let ((handler (or (find-file-name-handler file 'recover-file) - (find-file-name-handler - (let ((buffer-file-name file)) - (make-auto-save-file-name)) - 'recover-file)))) - (if handler - (funcall handler 'recover-file file) - (if (auto-save-file-name-p file) - (error "%s is an auto-save file" file)) - (let ((file-name (let ((buffer-file-name file)) - (make-auto-save-file-name)))) - (cond ((if (file-exists-p file) - (not (file-newer-than-file-p file-name file)) - (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))) - (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)) - (erase-buffer) - (insert-file-contents file-name nil)) - (after-find-file nil nil t)) - (t (error "Recover-file cancelled."))))))) - -(defun recover-session () - "Recover auto save files from a previous Emacs session. -This command first displays a Dired buffer showing you the -previous sessions that you could recover from. -To choose one, move point to the proper line and then type C-c C-c. -Then you'll be asked about a number of files to recover." - (interactive) - (dired (concat auto-save-list-file-prefix "*")) - (goto-char (point-min)) - (or (looking-at "Move to the session you want to recover,") - (let ((inhibit-read-only t)) - (insert "Move to the session you want to recover,\n" - "then type C-c C-c to select it.\n\n" - "You can also delete some of these files;\n" - "type d on a line to mark that file for deletion.\n\n"))) - (use-local-map (let ((map (make-sparse-keymap))) - (set-keymap-parents map (list (current-local-map))) - map)) - (define-key (current-local-map) "\C-c\C-c" 'recover-session-finish)) - -(defun recover-session-finish () - "Choose one saved session to recover auto-save files from. -This command is used in the special Dired buffer created by -\\[recover-session]." - (interactive) - ;; Get the name of the session file to recover from. - (let ((file (dired-get-filename)) - files - (buffer (get-buffer-create " *recover*"))) - ;; #### dired-do-flagged-delete in FSF. - ;; This version is for ange-ftp - ;;(dired-do-deletions t) - ;; This version is for efs - (dired-expunge-deletions) - (unwind-protect - (save-excursion - ;; Read in the auto-save-list file. - (set-buffer buffer) - (erase-buffer) - (insert-file-contents file) - ;; Loop thru the text of that file - ;; and get out the names of the files to recover. - (while (not (eobp)) - (let (thisfile autofile) - (if (eolp) - ;; This is a pair of lines for a non-file-visiting buffer. - ;; Get the auto-save file name and manufacture - ;; a "visited file name" from that. - (progn - (forward-line 1) - (setq autofile - (buffer-substring-no-properties - (point) - (save-excursion - (end-of-line) - (point)))) - (setq thisfile - (expand-file-name - (substring - (file-name-nondirectory autofile) - 1 -1) - (file-name-directory autofile))) - (forward-line 1)) - ;; This pair of lines is a file-visiting - ;; buffer. Use the visited file name. - (progn - (setq thisfile - (buffer-substring-no-properties - (point) (progn (end-of-line) (point)))) - (forward-line 1) - (setq autofile - (buffer-substring-no-properties - (point) (progn (end-of-line) (point)))) - (forward-line 1))) - ;; Ignore a file if its auto-save file does not exist now. - (if (file-exists-p autofile) - (setq files (cons thisfile files))))) - (setq files (nreverse files)) - ;; The file contains a pair of line for each auto-saved buffer. - ;; The first line of the pair contains the visited file name - ;; or is empty if the buffer was not visiting a file. - ;; The second line is the auto-save file name. - (if files - (map-y-or-n-p "Recover %s? " - (lambda (file) - (condition-case nil - (save-excursion (recover-file file)) - (error - "Failed to recover `%s'" file))) - files - '("file" "files" "recover")) - (message "No files can be recovered from this session now"))) - (kill-buffer buffer)))) - -(defun kill-some-buffers () - "For each buffer, ask whether to kill it." - (interactive) - (let ((list (buffer-list))) - (while list - (let* ((buffer (car list)) - (name (buffer-name buffer))) - (and (not (string-equal name "")) - (/= (aref name 0) ? ) - (yes-or-no-p - (format - (if (buffer-modified-p buffer) - (gettext "Buffer %s HAS BEEN EDITED. Kill? ") - (gettext "Buffer %s is unmodified. Kill? ")) - name)) - (kill-buffer buffer))) - (setq list (cdr list))))) - -(defun auto-save-mode (arg) - "Toggle auto-saving of contents of current buffer. -With prefix argument ARG, turn auto-saving on if positive, else off." - (interactive "P") - (setq buffer-auto-save-file-name - (and (if (null arg) - (or (not buffer-auto-save-file-name) - ;; If autosave is off because buffer has shrunk, - ;; then toggling should turn it on. - (< buffer-saved-size 0)) - (or (eq arg t) (listp arg) (and (integerp arg) (> arg 0)))) - (if (and buffer-file-name auto-save-visited-file-name - (not buffer-read-only)) - buffer-file-name - (make-auto-save-file-name)))) - ;; If -1 was stored here, to temporarily turn off saving, - ;; turn it back on. - (and (< buffer-saved-size 0) - (setq buffer-saved-size 0)) - (if (interactive-p) - (if buffer-auto-save-file-name ;; rewritten for I18N3 snarfing - (display-message 'command "Auto-save on (in this buffer)") - (display-message 'command "Auto-save off (in this buffer)"))) - buffer-auto-save-file-name) - -(defun rename-auto-save-file () - "Adjust current buffer's auto save file name for current conditions. -Also rename any existing auto save file, if it was made in this session." - (let ((osave buffer-auto-save-file-name)) - (setq buffer-auto-save-file-name - (make-auto-save-file-name)) - (if (and osave buffer-auto-save-file-name - (not (string= buffer-auto-save-file-name buffer-file-name)) - (not (string= buffer-auto-save-file-name osave)) - (file-exists-p osave) - (recent-auto-save-p)) - (rename-file osave buffer-auto-save-file-name t)))) - -;; see also ../packages/auto-save.el -(defun make-auto-save-file-name (&optional filename) - "Return file name to use for auto-saves of current buffer. -Does not consider `auto-save-visited-file-name' as that variable is checked -before calling this function. You can redefine this for customization. -See also `auto-save-file-name-p'." - (let ((fname (or filename buffer-file-name)) - name) - (setq name - (if fname - (concat (file-name-directory fname) - "#" - (file-name-nondirectory fname) - "#") - - ;; Deal with buffers that don't have any associated files. (Mail - ;; mode tends to create a good number of these.) - - (let ((buffer-name (buffer-name)) - (limit 0)) - ;; Use technique from Sebastian Kremer's auto-save - ;; package to turn slashes into \\!. This ensures that - ;; the auto-save buffer name is unique. - - ;; #### - yuck! yuck! yuck! move this functionality - ;; somewhere else and make the name translation customizable. - ;; Using "\!" as part of a filename on a UNIX filesystem is nearly - ;; IMPOSSIBLE to get past a shell parser. -stig - - (while (string-match "[/\\]" buffer-name limit) - (setq buffer-name - (concat (substring buffer-name 0 (match-beginning 0)) - (if (string= (substring buffer-name - (match-beginning 0) - (match-end 0)) - "/") - "\\!" - "\\\\") - (substring buffer-name (match-end 0)))) - (setq limit (1+ (match-end 0)))) - - ;; (expand-file-name (format "#%s#%s#" (buffer-name) (make-temp-name ""))) - - ;; jwz: putting the emacs PID in the auto-save file name - ;; is bad news, because that defeats auto-save-recovery of - ;; *mail* buffers -- the (sensible) code in sendmail.el - ;; calls (make-auto-save-file-name) to determine whether - ;; there is unsent, auto-saved mail to recover. If that - ;; mail came from a previous emacs process (far and away - ;; the most likely case) then this can never succeed as - ;; the pid differs. - - (expand-file-name (format "#%s#" buffer-name))) - )) - ;; don't try to write auto-save files in unwritable places. Unless - ;; there's already an autosave file here, put ours somewhere safe. --Stig - (if (or (file-writable-p name) - (file-exists-p name)) - name - (expand-file-name (concat "~/" (file-name-nondirectory name)))))) - -(defun auto-save-file-name-p (filename) - "Return non-nil if FILENAME can be yielded by `make-auto-save-file-name'. -FILENAME should lack slashes. -You can redefine this for customization." - (string-match "\\`#.*#\\'" filename)) - -(defcustom list-directory-brief-switches - (if (eq system-type 'vax-vms) "" "-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") - "*Switches for list-directory to pass to `ls' for verbose listing," - :type 'string - :group 'dired) - -(defun list-directory (dirname &optional verbose) - "Display a list of files in or matching DIRNAME, a la `ls'. -DIRNAME is globbed by the shell if necessary. -Prefix arg (second arg if noninteractive) means supply -l switch to `ls'. -Actions controlled by variables `list-directory-brief-switches' -and `list-directory-verbose-switches'." - (interactive (let ((pfx current-prefix-arg)) - (list (read-file-name (if pfx (gettext "List directory (verbose): ") - (gettext "List directory (brief): ")) - nil default-directory nil) - pfx))) - (let ((switches (if verbose list-directory-verbose-switches - list-directory-brief-switches))) - (or dirname (setq dirname default-directory)) - (setq dirname (expand-file-name dirname)) - (with-output-to-temp-buffer "*Directory*" - (buffer-disable-undo standard-output) - (princ "Directory ") - (princ dirname) - (terpri) - (save-excursion - (set-buffer "*Directory*") - (setq default-directory (file-name-directory dirname)) - (let ((wildcard (not (file-directory-p dirname)))) - (insert-directory dirname switches wildcard (not wildcard))))))) - -(defvar insert-directory-program "ls" - "Absolute or relative name of the `ls' program used by `insert-directory'.") - -;; insert-directory -;; - must insert _exactly_one_line_ describing FILE if WILDCARD and -;; FULL-DIRECTORY-P is nil. -;; The single line of output must display FILE's name as it was -;; given, namely, an absolute path name. -;; - must insert exactly one line for each file if WILDCARD or -;; FULL-DIRECTORY-P is t, plus one optional "total" line -;; before the file lines, plus optional text after the file lines. -;; Lines are delimited by "\n", so filenames containing "\n" are not -;; allowed. -;; File lines should display the basename. -;; - must be consistent with -;; - functions dired-move-to-filename, (these two define what a file line is) -;; dired-move-to-end-of-filename, -;; dired-between-files, (shortcut for (not (dired-move-to-filename))) -;; dired-insert-headerline -;; dired-after-subdir-garbage (defines what a "total" line is) -;; - variable dired-subdir-regexp -(defun insert-directory (file switches &optional wildcard full-directory-p) - "Insert directory listing for FILE, formatted according to SWITCHES. -Leaves point after the inserted text. -SWITCHES may be a string of options, or a list of strings. -Optional third arg WILDCARD means treat FILE as shell wildcard. -Optional fourth arg FULL-DIRECTORY-P means file is a directory and -switches do not contain `d', so that a full listing is expected. - -This works by running a directory listing program -whose name is in the variable `insert-directory-program'. -If WILDCARD, it also runs the shell specified by `shell-file-name'." - ;; We need the directory in order to find the right handler. - (let ((handler (find-file-name-handler (expand-file-name file) - 'insert-directory))) - (if handler - (funcall handler 'insert-directory file switches - wildcard full-directory-p) - (if (eq system-type 'vax-vms) - (vms-read-directory file switches (current-buffer)) - (if wildcard - ;; Run ls in the directory of the file pattern we asked for. - (let ((default-directory - (if (file-name-absolute-p file) - (file-name-directory file) - (file-name-directory (expand-file-name file)))) - (pattern (file-name-nondirectory file)) - (beg 0)) - ;; Quote some characters that have special meanings in shells; - ;; but don't quote the wildcards--we want them to be special. - ;; We also currently don't quote the quoting characters - ;; in case people want to use them explicitly to quote - ;; wildcard characters. - ;;#### Unix-specific - (while (string-match "[ \t\n;<>&|()#$]" pattern beg) - (setq pattern - (concat (substring pattern 0 (match-beginning 0)) - "\\" - (substring pattern (match-beginning 0))) - beg (1+ (match-end 0)))) - (call-process shell-file-name nil t nil - "-c" (concat "\\" ;; Disregard shell aliases! - insert-directory-program - " -d " - (if (stringp switches) - switches - (mapconcat 'identity switches " ")) - " " - pattern))) - ;; SunOS 4.1.3, SVr4 and others need the "." to list the - ;; directory if FILE is a symbolic link. - (apply 'call-process - insert-directory-program nil t nil - (let (list) - (if (listp switches) - (setq list switches) - (if (not (equal switches "")) - (progn - ;; Split the switches at any spaces - ;; so we can pass separate options as separate args. - (while (string-match " " switches) - (setq list (cons (substring switches 0 (match-beginning 0)) - list) - switches (substring switches (match-end 0)))) - (setq list (cons switches list))))) - (append list - (list - (if full-directory-p - (concat (file-name-as-directory file) - ;;#### Unix-specific - ".") - file)))))))))) - -(defvar kill-emacs-query-functions nil - "Functions to call with no arguments to query about killing XEmacs. -If any of these functions returns nil, killing Emacs is cancelled. -`save-buffers-kill-emacs' (\\[save-buffers-kill-emacs]) calls these functions, -but `kill-emacs', the low level primitive, does not. -See also `kill-emacs-hook'.") - -(defun save-buffers-kill-emacs (&optional arg) - "Offer to save each buffer, then kill this XEmacs process. -With prefix arg, silently save all file-visiting buffers, then kill." - (interactive "P") - (save-some-buffers arg t) - (and (or (not (memq t (mapcar #'(lambda (buf) (and (buffer-file-name buf) - (buffer-modified-p buf))) - (buffer-list)))) - (yes-or-no-p "Modified buffers exist; exit anyway? ")) - (or (not (fboundp 'process-list)) - ;; process-list is not defined on VMS. - (let ((processes (process-list)) - active) - (while processes - (and (memq (process-status (car processes)) '(run stop open)) - (let ((val (process-kill-without-query (car processes)))) - (process-kill-without-query (car processes) val) - val) - (setq active t)) - (setq processes (cdr processes))) - (or - (not active) - (save-excursion - (save-window-excursion - (delete-other-windows) - (list-processes) - (yes-or-no-p - "Active processes exist; kill them and exit anyway? ")))))) - ;; Query the user for other things, perhaps. - (run-hook-with-args-until-failure 'kill-emacs-query-functions) - (kill-emacs))) - -(defun symlink-expand-file-name (filename) - "If FILENAME is a symlink, return its non-symlink equivalent. -Unlike `file-truename', this doesn't chase symlinks in directory -components of the file or expand a relative pathname into an -absolute one." - (let ((count 20)) - (while (and (> count 0) (file-symlink-p filename)) - (setq filename (file-symlink-p filename) - count (1- count))) - (if (> count 0) - filename - (error "Apparently circular symlink path")))) - -;; Suggested by Michael Kifer <kifer@CS.SunySB.EDU> -(defun file-remote-p (file-name) - "Test whether FILE-NAME is looked for on a remote system." - (cond ((not allow-remote-paths) nil) - ((featurep 'ange-ftp) (ange-ftp-ftp-path file-name)) - (t (efs-ftp-path file-name)))) - -;;; files.el ends here
--- a/lisp/prim/fill.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1058 +0,0 @@ -;;; fill.el --- fill commands for XEmacs. - -;; Copyright (C) 1985, 86, 92, 94, 95, 1997 Free Software Foundation, Inc. - -;; Keywords: wp - -;; 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.34. - -;;; Commentary: - -;; All the commands for filling text. These are documented in the XEmacs -;; Reference Manual. - -;; 97/3/14 Jareth Hein (jhod@po.iijnet.or.jp) added functions for kinsoku (asian text -;; line break processing) -;; 97/06/11 Steve Baur (steve@altair.xemacs.org) converted broken -;; following-char/preceding-char calls to char-after/char-before. - -;;; Code: - -(defconst fill-individual-varying-indent nil - "*Controls criterion for a new paragraph in `fill-individual-paragraphs'. -Non-nil means changing indent doesn't end a paragraph. -That mode can handle paragraphs with extra indentation on the first line, -but it requires separator lines between paragraphs. -A value of nil means that any change in indentation starts a new paragraph.") - -(defconst sentence-end-double-space t - "*Non-nil means a single space does not end a sentence. -This variable applies only to filling, not motion commands. To -change the behavior of motion commands, see `sentence-end'.") - -(defconst colon-double-space nil - "*Non-nil means put two spaces after a colon when filling.") - -(defvar fill-paragraph-function nil - "Mode-specific function to fill a paragraph, or nil if there is none. -If the function returns nil, then `fill-paragraph' does its normal work.") - -(defun set-fill-prefix () - "Set the fill prefix to the current line up to point. -Filling expects lines to start with the fill prefix and -reinserts the fill prefix in each resulting line." - (interactive) - (setq fill-prefix (buffer-substring - (save-excursion (move-to-left-margin) (point)) - (point))) - (if (equal fill-prefix "") - (setq fill-prefix nil)) - (if fill-prefix - (message "fill-prefix: \"%s\"" fill-prefix) - (message "fill-prefix cancelled"))) - -(defconst adaptive-fill-mode t - "*Non-nil means determine a paragraph's fill prefix from its text.") - -;; #### - this is still weak. Yeah, there's filladapt, but this should -;; still be better... --Stig -(defconst adaptive-fill-regexp (purecopy "[ \t]*\\([#;>*]+ +\\)?") - "*Regexp to match text at start of line that constitutes indentation. -If Adaptive Fill mode is enabled, whatever text matches this pattern -on the second line of a paragraph is used as the standard indentation -for the paragraph. If the paragraph has just one line, the indentation -is taken from that line.") - -(defvar adaptive-fill-function nil - "*Function to call to choose a fill prefix for a paragraph. -This function is used when `adaptive-fill-regexp' does not match.") - -;; Added for kinsoku processing. Use this instead of -;; (skip-chars-backward "^ \t\n") -;; (skip-chars-backward "^ \n" linebeg) -(defun fill-move-backward-to-break-point (regexp &optional lim) - (let ((opoint (point))) - ;; 93.8.23 by kawamoto@ics.es.osaka-u.ac.jp - ;; case of first 'word' being longer than fill-column - (if (not (re-search-backward regexp lim 'move)) - nil - ;; we have skipped backward SPC or WAN (word-across-newline). So move point forward again. - (forward-char) - (if (< opoint (point)) - (forward-char -1))))) - -;; Added for kinsoku processing. Use instead of -;; (re-search-forward "[ \t]" opoint t) -;; (skip-chars-forward "^ \n") -;; (skip-chars-forward "^ \n") -(defun fill-move-forward-to-break-point (regexp &optional lim) - (let ((opoint (point))) - (if (not (re-search-forward regexp lim 'move)) - nil - (forward-char -1) - (if (< (point) opoint) - (forward-char)))) - (if (featurep 'mule) (kinsoku-process-extend))) - -(defun fill-end-of-sentence-p () - (save-excursion - (skip-chars-backward " ]})\"'") - (memq (char-before (point)) '(?. ?? ?!)))) - -(defun current-fill-column () - "Return the fill-column to use for this line. -The fill-column to use for a buffer is stored in the variable `fill-column', -but can be locally modified by the `right-margin' text property, which is -subtracted from `fill-column'. - -The fill column to use for a line is the first column at which the column -number equals or exceeds the local fill-column - right-margin difference." - (save-excursion - (if fill-column - (let* ((here (progn (beginning-of-line) (point))) - (here-col 0) - (eol (progn (end-of-line) (point))) - margin fill-col change col) - ;; Look separately at each region of line with a different right-margin. - (while (and (setq margin (get-text-property here 'right-margin) - fill-col (- fill-column (or margin 0)) - change (text-property-not-all - here eol 'right-margin margin)) - (progn (goto-char (1- change)) - (setq col (current-column)) - (< col fill-col))) - (setq here change - here-col col)) - (max here-col fill-col))))) - -(defun canonically-space-region (beg end) - "Remove extra spaces between words in region. -Leave one space between words, two at end of sentences or after colons -\(depending on values of `sentence-end-double-space' and `colon-double-space'). -Remove indentation from each line." - (interactive "r") - ;;;### 97/3/14 jhod: Do I have to add anything here for kinsoku? - (save-excursion - (goto-char beg) - ;; XEmacs - (ENE/stig from fa-extras.el): Skip the start of a comment. - (and comment-start-skip - (looking-at comment-start-skip) - (goto-char (match-end 0))) - ;; Nuke tabs; they get screwed up in a fill. - ;; This is quick, but loses when a tab follows the end of a sentence. - ;; Actually, it is difficult to tell that from "Mr.\tSmith". - ;; Blame the typist. - (subst-char-in-region beg end ?\t ?\ ) - (while (and (< (point) end) - (re-search-forward " *" end t)) - (delete-region - (+ (match-beginning 0) - ;; Determine number of spaces to leave: - (save-excursion - (skip-chars-backward " ]})\"'") - (cond ((and sentence-end-double-space - (memq (char-before (point)) '(?. ?? ?!))) 2) - ((and colon-double-space - (eq (char-before (point)) ?:)) 2) - ((char-equal (char-before (point)) ?\n) 0) - (t 1)))) - (match-end 0))) - ;; Make sure sentences ending at end of line get an extra space. - ;; loses on split abbrevs ("Mr.\nSmith") - (goto-char beg) - (while (and (< (point) end) - (re-search-forward "[.?!][])}\"']*$" end t)) - ;; We insert before markers in case a caller such as - ;; do-auto-fill has done a save-excursion with point at the end - ;; of the line and wants it to stay at the end of the line. - (insert ? )))) -;; XEmacs: we don't have this function. -;; (insert-before-markers-and-inherit ? )))) - -;; XEmacs -- added DONT-SKIP-FIRST. Port of older code changes by Stig. -;; #### probably this junk is broken -- do-auto-fill doesn't actually use -;; it. If so, it should be removed. - -(defun fill-context-prefix (from to &optional first-line-regexp - dont-skip-first) - "Compute a fill prefix from the text between FROM and TO. -This uses the variables `adaptive-fill-prefix' and `adaptive-fill-function'. -If FIRST-LINE-REGEXP is non-nil, then when taking a prefix from the -first line, insist it must match FIRST-LINE-REGEXP." - (save-excursion - (goto-char from) - (if (eolp) (forward-line 1)) - ;; Move to the second line unless there is just one. - (let ((firstline (point)) - ;; Non-nil if we are on the second line. - at-second - result) - ;; XEmacs change - (if (not dont-skip-first) - (forward-line 1)) - (if (>= (point) to) - (goto-char firstline) - (setq at-second t)) - (move-to-left-margin) - ;; XEmacs change - (let ((start (point)) - ; jhod: no longer used? - ;(eol (save-excursion (end-of-line) (point))) - ) - (setq result - (if (not (looking-at paragraph-start)) - (cond ((and adaptive-fill-regexp (looking-at adaptive-fill-regexp)) - (buffer-substring-no-properties start (match-end 0))) - (adaptive-fill-function (funcall adaptive-fill-function))))) - (and result - (or at-second - (null first-line-regexp) - (string-match first-line-regexp result)) - result))))) - -;; XEmacs (stig) - this is pulled out of fill-region-as-paragraph so that it -;; can also be called from do-auto-fill -;; #### But it's not used there. Chuck pulled it out because it broke things. -(defun maybe-adapt-fill-prefix (&optional from to dont-skip-first) - (if (and adaptive-fill-mode - (or (null fill-prefix) (string= fill-prefix ""))) - (setq fill-prefix (fill-context-prefix from to nil dont-skip-first)))) - -(defun fill-region-as-paragraph (from to &optional justify - nosqueeze squeeze-after) - "Fill the region as one paragraph. -It removes any paragraph breaks in the region and extra newlines at the end, -indents and fills lines between the margins given by the -`current-left-margin' and `current-fill-column' functions. -It leaves point at the beginning of the line following the paragraph. - -Normally performs justification according to the `current-justification' -function, but with a prefix arg, does full justification instead. - -From a program, optional third arg JUSTIFY can specify any type of -justification. Fourth arg NOSQUEEZE non-nil means not to make spaces -between words canonical before filling. Fifth arg SQUEEZE-AFTER, if non-nil, -means don't canonicalize spaces before that position. - -If `sentence-end-double-space' is non-nil, then period followed by one -space does not end a sentence, so don't break a line there." - (interactive - (progn - ;; XEmacs addition: - (barf-if-buffer-read-only nil (region-beginning) (region-end)) - (list (region-beginning) (region-end) - (if current-prefix-arg 'full)))) - ;; Arrange for undoing the fill to restore point. - (if (and buffer-undo-list (not (eq buffer-undo-list t))) - (setq buffer-undo-list (cons (point) buffer-undo-list))) - - ;; Make sure "to" is the endpoint. - (goto-char (min from to)) - (setq to (max from to)) - ;; Ignore blank lines at beginning of region. - (skip-chars-forward " \t\n") - - (let ((from-plus-indent (point)) - (oneleft nil)) - - (beginning-of-line) - (setq from (point)) - - ;; Delete all but one soft newline at end of region. - ;; And leave TO before that one. - (goto-char to) - (while (and (> (point) from) (eq ?\n (char-after (1- (point))))) - (if (and oneleft - (not (and use-hard-newlines - (get-text-property (1- (point)) 'hard)))) - (delete-backward-char 1) - (backward-char 1) - (setq oneleft t))) - (setq to (point)) - - ;; If there was no newline, and there is text in the paragraph, then - ;; create a newline. - (if (and (not oneleft) (> to from-plus-indent)) - (newline)) - (goto-char from-plus-indent)) - - (if (not (> to (point))) - nil ; There is no paragraph, only whitespace: exit now. - - (or justify (setq justify (current-justification))) - - ;; Don't let Adaptive Fill mode alter the fill prefix permanently. - (let ((fill-prefix fill-prefix)) - ;; Figure out how this paragraph is indented, if desired. - ;; XEmacs: move some code here to a separate function. - (maybe-adapt-fill-prefix from to t) - - (save-restriction - (goto-char from) - (beginning-of-line) - (narrow-to-region (point) to) - - (if (not justify) ; filling disabled: just check indentation - (progn - (goto-char from) - (while (not (eobp)) - (if (and (not (eolp)) - (< (current-indentation) (current-left-margin))) - (indent-to-left-margin)) - (forward-line 1))) - - (if use-hard-newlines - (remove-text-properties from (point-max) '(hard nil))) - ;; Make sure first line is indented (at least) to left margin... - (if (or (memq justify '(right center)) - (< (current-indentation) (current-left-margin))) - (indent-to-left-margin)) - ;; Delete the fill prefix from every line except the first. - ;; The first line may not even have a fill prefix. - (goto-char from) - (let ((fpre (and fill-prefix (not (equal fill-prefix "")) - (concat "[ \t]*" - (regexp-quote fill-prefix) - "[ \t]*")))) - (and fpre - (progn - (if (>= (+ (current-left-margin) (length fill-prefix)) - (current-fill-column)) - (error "fill-prefix too long for specified width")) - (goto-char from) - (forward-line 1) - (while (not (eobp)) - (if (looking-at fpre) - (delete-region (point) (match-end 0))) - (forward-line 1)) - (goto-char from) - (if (looking-at fpre) - (goto-char (match-end 0))) - (setq from (point))))) - ;; Remove indentation from lines other than the first. - (beginning-of-line 2) - (indent-region (point) (point-max) 0) - (goto-char from) - - ;; FROM, and point, are now before the text to fill, - ;; but after any fill prefix on the first line. - - ;; Make sure sentences ending at end of line get an extra space. - ;; loses on split abbrevs ("Mr.\nSmith") - (while (re-search-forward "[.?!][])}\"']*$" nil t) - ;; XEmacs change (no insert-and-inherit) - (or (eobp) (insert ?\ ?\ ))) - (goto-char from) - (skip-chars-forward " \t") - ;; Then change all newlines to spaces. - ;;; 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. - (if (not (and (featurep 'mule) - (stringp word-across-newline))) - (subst-char-in-region from (point-max) ?\n ?\ ) - ;; - ;; WAN +NL+WAN --> WAN + WAN - ;; not(WAN)+NL+WAN --> not(WAN) + WAN - ;; WAN +NL+not(WAN) --> WAN + not(WAN) - ;; SPC +NL+not(WAN) --> SPC + not(WAN) - ;; not(WAN)+NL+not(WAN) --> not(WAN) + SPC + not(WAN) - ;; - (goto-char from) - (end-of-line) - (while (not (eobp)) - ;; Insert SPC only when point is between nonWAN. Insert - ;; before deleting to preserve marker if possible. - (if (or (prog2 ; check following char. - (forward-char) ; skip newline - (or (eobp) - (looking-at word-across-newline)) - (forward-char -1)) - (prog2 ; check previous char. - (forward-char -1) - (or (eq (char-after (point)) ?\ ) - (looking-at word-across-newline)) - (forward-char))) - nil - (insert ?\ )) - (delete-char 1) ; delete newline - (end-of-line))) - ;; end patch - (goto-char from) - (skip-chars-forward " \t") - (if (and nosqueeze (not (eq justify 'full))) - nil - (canonically-space-region (or squeeze-after (point)) (point-max)) - (goto-char (point-max)) - (delete-horizontal-space) - ;; XEmacs change (no insert-and-inherit) - (insert " ")) - (goto-char (point-min)) - - ;; This is the actual filling loop. - (let ((prefixcol 0) linebeg - (re-break-point (if (featurep 'mule) - (concat "[ \n\t]\\|" word-across-newline) - "[ \n\t]"))) - (while (not (eobp)) - (setq linebeg (point)) - (move-to-column (1+ (current-fill-column))) - (if (eobp) - (or nosqueeze (delete-horizontal-space)) - ;; Move back to start of word. - ;; 97/3/14 jhod: Kinsoku - ;(skip-chars-backward "^ \n" linebeg) - (fill-move-backward-to-break-point re-break-point linebeg) - ;; end patch - ;; Don't break after a period followed by just one space. - ;; Move back to the previous place to break. - ;; The reason is that if a period ends up at the end of a line, - ;; further fills will assume it ends a sentence. - ;; If we now know it does not end a sentence, - ;; avoid putting it at the end of the line. - (if sentence-end-double-space - (while (and (> (point) (+ linebeg 2)) - (eq (char-before (point)) ?\ ) - (not (eq (char-after (point)) ?\ )) - (eq (char-after (- (point) 2)) ?\.)) - (forward-char -2) - ;; 97/3/14 jhod: Kinsoku - ;(skip-chars-backward "^ \n" linebeg))) - (fill-move-backward-to-break-point re-break-point linebeg))) - (if (featurep 'mule) (kinsoku-process)) - ;end patch - - ;; If the left margin and fill prefix by themselves - ;; pass the fill-column. or if they are zero - ;; but we have no room for even one word, - ;; keep at least one word anyway. - ;; This handles ALL BUT the first line of the paragraph. - (if (if (zerop prefixcol) - (save-excursion - (skip-chars-backward " \t" linebeg) - (bolp)) - (>= prefixcol (current-column))) - ;; Ok, skip at least one word. - ;; Meanwhile, don't stop at a period followed by one space. - (let ((first t)) - (move-to-column prefixcol) - (while (and (not (eobp)) - (or first - (and (not (bobp)) - sentence-end-double-space - (save-excursion (forward-char -1) - (and (looking-at "\\. ") - (not (looking-at "\\. "))))))) - (skip-chars-forward " \t") - ;; 94/3/14 jhod: Kinsoku - ;(skip-chars-forward "^ \n\t") - (fill-move-forward-to-break-point re-break-point) - ;; end patch - (setq first nil))) - ;; Normally, move back over the single space between the words. - (if (eq (char-before (point)) ?\ ) - (forward-char -1))) - ;; If the left margin and fill prefix by themselves - ;; pass the fill-column, keep at least one word. - ;; This handles the first line of the paragraph. - (if (and (zerop prefixcol) - (let ((fill-point (point)) nchars) - (save-excursion - (move-to-left-margin) - (setq nchars (- fill-point (point))) - (or (< nchars 0) - (and fill-prefix - (< nchars (length fill-prefix)) - (string= (buffer-substring (point) fill-point) - (substring fill-prefix 0 nchars))))))) - ;; Ok, skip at least one word. But - ;; don't stop at a period followed by just one space. - (let ((first t)) - (while (and (not (eobp)) - (or first - (and (not (bobp)) - sentence-end-double-space - (save-excursion (forward-char -1) - (and (looking-at "\\. ") - (not (looking-at "\\. "))))))) - (skip-chars-forward " \t") - ;; 97/3/14 jhod: Kinsoku - ;(skip-chars-forward "^ \t\n") - (fill-move-forward-to-break-point re-break-point) - ;; end patch - (setq first nil)))) - ;; Check again to see if we got to the end of the paragraph. - (if (save-excursion (skip-chars-forward " \t") (eobp)) - (or nosqueeze (delete-horizontal-space)) - ;; Replace whitespace here with one newline, then indent to left - ;; margin. - (skip-chars-backward " \t") - ;; 97/3/14 jhod: More kinsoku stuff - (if (featurep 'mule) - ;; WAN means chars which match word-across-newline. - ;; (0) | SPC + SPC* <EOB> --> NL - ;; (1) WAN | SPC + SPC* --> WAN + SPC + NL - ;; (2) | SPC + SPC* + WAN --> SPC + NL + WAN - ;; (3) '.' | SPC + nonSPC --> '.' + SPC + NL + nonSPC - ;; (4) '.' | SPC + SPC --> '.' + NL - ;; (5) | SPC* --> NL - (let ((start (point)) ; 92.6.30 by K.Handa - (ch (char-after (point)))) - (if (and (= ch ? ) - (progn ; not case (0) -- 92.6.30 by K.Handa - (skip-chars-forward " \t") - (not (eobp))) - (or - (progn ; case (1) - (goto-char start) - (forward-char -1) - (looking-at word-across-newline)) - (progn ; case (2) - (goto-char start) - (skip-chars-forward " \t") - (and (not (eobp)) - (looking-at word-across-newline) - ;; never leave space after the end of sentence - (not (fill-end-of-sentence-p)))) - (progn ; case (3) - (goto-char (1+ start)) - (and (not (eobp)) - (not (eq (char-after (point)) ? )) - (fill-end-of-sentence-p))))) - ;; We should keep one SPACE before NEWLINE. (1),(2),(3) - (goto-char (1+ start)) - ;; We should delete all SPACES around break point. (4),(5) - (goto-char start)))) - ;; end of patch - (insert ?\n) - ;; Give newline the properties of the space(s) it replaces - (set-text-properties (1- (point)) (point) - (text-properties-at (point))) - (indent-to-left-margin) - ;; Insert the fill prefix after indentation. - ;; Set prefixcol so whitespace in the prefix won't get lost. - (and fill-prefix (not (equal fill-prefix "")) - (progn - (insert fill-prefix) - (setq prefixcol (current-column)))))) - ;; Justify the line just ended, if desired. - (if justify - (if (save-excursion (skip-chars-forward " \t") (eobp)) - (progn - (delete-horizontal-space) - (justify-current-line justify t t)) - (forward-line -1) - (justify-current-line justify nil t) - (forward-line 1)))))) - ;; Leave point after final newline. - (goto-char (point-max))) - (forward-char 1)))) - -(defun fill-paragraph (arg) - "Fill paragraph at or after point. Prefix arg means justify as well. -If `sentence-end-double-space' is non-nil, then period followed by one -space does not end a sentence, so don't break a line there. - -If `fill-paragraph-function' is non-nil, we call it (passing our -argument to it), and if it returns non-nil, we simply return its value." - (interactive (list (if current-prefix-arg 'full))) - (or (and fill-paragraph-function - (let ((function fill-paragraph-function) - fill-paragraph-function) - (funcall function arg))) - (let ((before (point))) - (save-excursion - (forward-paragraph) - (or (bolp) (newline 1)) - (let ((end (point)) - (beg (progn (backward-paragraph) (point)))) - (goto-char before) - (if use-hard-newlines - ;; Can't use fill-region-as-paragraph, since this paragraph may - ;; still contain hard newlines. See fill-region. - (fill-region beg end arg) - (fill-region-as-paragraph beg end arg))))))) - -(defun fill-region (from to &optional justify nosqueeze to-eop) - "Fill each of the paragraphs in the region. -Prefix arg (non-nil third arg, if called from program) means justify as well. - -Noninteractively, fourth arg NOSQUEEZE non-nil means to leave -whitespace other than line breaks untouched, and fifth arg TO-EOP -non-nil means to keep filling to the end of the paragraph (or next -hard newline, if `use-hard-newlines' is on). - -If `sentence-end-double-space' is non-nil, then period followed by one -space does not end a sentence, so don't break a line there." - (interactive - (progn - ;; XEmacs addition: - (barf-if-buffer-read-only nil (region-beginning) (region-end)) - (list (region-beginning) (region-end) - (if current-prefix-arg 'full)))) - (let (end beg) - (save-restriction - (goto-char (max from to)) - (if to-eop - (progn (skip-chars-backward "\n") - (forward-paragraph))) - (setq end (point)) - (goto-char (setq beg (min from to))) - (beginning-of-line) - (narrow-to-region (point) end) - (while (not (eobp)) - (let ((initial (point)) - end) - ;; If using hard newlines, break at every one for filling - ;; purposes rather than using paragraph breaks. - (if use-hard-newlines - (progn - (while (and (setq end (text-property-any (point) (point-max) - 'hard t)) - (not (eq ?\n (char-after end))) - (not (= end (point-max)))) - (goto-char (1+ end))) - (setq end (if end (min (point-max) (1+ end)) (point-max))) - (goto-char initial)) - (forward-paragraph 1) - (setq end (point)) - (forward-paragraph -1)) - (if (< (point) beg) - (goto-char beg)) - (if (>= (point) initial) - (fill-region-as-paragraph (point) end justify nosqueeze) - (goto-char end))))))) - -;; XEmacs addition: from Tim Bradshaw <tfb@edinburgh.ac.uk> -(defun fill-paragraph-or-region (arg) - "Fill the current region, if it's active; otherwise, fill the paragraph. -See `fill-paragraph' and `fill-region' for more information." - (interactive "*P") - (if (region-active-p) - (fill-region (point) (mark) arg) - (fill-paragraph arg))) - - -(defconst default-justification 'left - "*Method of justifying text not otherwise specified. -Possible values are `left', `right', `full', `center', or `none'. -The requested kind of justification is done whenever lines are filled. -The `justification' text-property can locally override this variable. -This variable automatically becomes buffer-local when set in any fashion.") -(make-variable-buffer-local 'default-justification) - -(defun current-justification () - "How should we justify this line? -This returns the value of the text-property `justification', -or the variable `default-justification' if there is no text-property. -However, it returns nil rather than `none' to mean \"don't justify\"." - (let ((j (or (get-text-property - ;; Make sure we're looking at paragraph body. - (save-excursion (skip-chars-forward " \t") - (if (and (eobp) (not (bobp))) - (1- (point)) (point))) - 'justification) - default-justification))) - (if (eq 'none j) - nil - j))) - -(defun set-justification (begin end value &optional whole-par) - "Set the region's justification style. -The kind of justification to use is prompted for. -If the mark is not active, this command operates on the current paragraph. -If the mark is active, the region is used. However, if the beginning and end -of the region are not at paragraph breaks, they are moved to the beginning and -end of the paragraphs they are in. -If `use-hard-newlines' is true, all hard newlines are taken to be paragraph -breaks. - -When calling from a program, operates just on region between BEGIN and END, -unless optional fourth arg WHOLE-PAR is non-nil. In that case bounds are -extended to include entire paragraphs as in the interactive command." - ;; XEmacs change (was mark-active) - (interactive (list (if (region-active-p) (region-beginning) (point)) - (if (region-active-p) (region-end) (point)) - (let ((s (completing-read - "Set justification to: " - '(("left") ("right") ("full") - ("center") ("none")) - nil t))) - (if (equal s "") (error "")) - (intern s)) - t)) - (save-excursion - (save-restriction - (if whole-par - (let ((paragraph-start (if use-hard-newlines "." paragraph-start)) - (paragraph-ignore-fill-prefix (if use-hard-newlines t - paragraph-ignore-fill-prefix))) - (goto-char begin) - (while (and (bolp) (not (eobp))) (forward-char 1)) - (backward-paragraph) - (setq begin (point)) - (goto-char end) - (skip-chars-backward " \t\n" begin) - (forward-paragraph) - (setq end (point)))) - - (narrow-to-region (point-min) end) - (unjustify-region begin (point-max)) - (put-text-property begin (point-max) 'justification value) - (fill-region begin (point-max) nil t)))) - -(defun set-justification-none (b e) - "Disable automatic filling for paragraphs in the region. -If the mark is not active, this applies to the current paragraph." - ;; XEmacs change (was mark-active) - (interactive (list (if (region-active-p) (region-beginning) (point)) - (if (region-active-p) (region-end) (point)))) - (set-justification b e 'none t)) - -(defun set-justification-left (b e) - "Make paragraphs in the region left-justified. -This is usually the default, but see the variable `default-justification'. -If the mark is not active, this applies to the current paragraph." - ;; XEmacs change (was mark-active) - (interactive (list (if (region-active-p) (region-beginning) (point)) - (if (region-active-p) (region-end) (point)))) - (set-justification b e 'left t)) - -(defun set-justification-right (b e) - "Make paragraphs in the region right-justified: -Flush at the right margin and ragged on the left. -If the mark is not active, this applies to the current paragraph." - ;; XEmacs change (was mark-active) - (interactive (list (if (region-active-p) (region-beginning) (point)) - (if (region-active-p) (region-end) (point)))) - (set-justification b e 'right t)) - -(defun set-justification-full (b e) - "Make paragraphs in the region fully justified: -This makes lines flush on both margins by inserting spaces between words. -If the mark is not active, this applies to the current paragraph." - ;; XEmacs change (was mark-active) - (interactive (list (if (region-active-p) (region-beginning) (point)) - (if (region-active-p) (region-end) (point)))) - (set-justification b e 'full t)) - -(defun set-justification-center (b e) - "Make paragraphs in the region centered. -If the mark is not active, this applies to the current paragraph." - ;; XEmacs change (was mark-active) - (interactive (list (if (region-active-p) (region-beginning) (point)) - (if (region-active-p) (region-end) (point)))) - (set-justification b e 'center t)) - -;; 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" - (if (boundp 'space-insertable) - (if (re-search-backward space-insertable nil t) - (progn (forward-char 1) - t) - nil) - (search-backward " " nil t))) - -;; A line has up to six parts: -;; -;; >>> hello. -;; [Indent-1][FP][ Indent-2 ][text][trailing whitespace][newline] -;; -;; "Indent-1" is the left-margin indentation; normally it ends at column -;; given by the `current-left-margin' function. -;; "FP" is the fill-prefix. It can be any string, including whitespace. -;; "Indent-2" is added to justify a line if the `current-justification' is -;; `center' or `right'. In `left' and `full' justification regions, any -;; whitespace there is part of the line's text, and should not be changed. -;; Trailing whitespace is not counted as part of the line length when -;; center- or right-justifying. -;; -;; All parts of the line are optional, although the final newline can -;; only be missing on the last line of the buffer. - -(defun justify-current-line (&optional how eop nosqueeze) - "Do some kind of justification on this line. -Normally does full justification: adds spaces to the line to make it end at -the column given by `current-fill-column'. -Optional first argument HOW specifies alternate type of justification: -it can be `left', `right', `full', `center', or `none'. -If HOW is t, will justify however the `current-justification' function says to. -If HOW is nil or missing, full justification is done by default. -Second arg EOP non-nil means that this is the last line of the paragraph, so -it will not be stretched by full justification. -Third arg NOSQUEEZE non-nil means to leave interior whitespace unchanged, -otherwise it is made canonical." - (interactive) - (if (eq t how) (setq how (or (current-justification) 'none)) - (if (null how) (setq how 'full) - (or (memq how '(none left right center)) - (setq how 'full)))) - (or (memq how '(none left)) ; No action required for these. - (let ((fc (current-fill-column)) - (pos (point-marker)) - fp-end ; point at end of fill prefix - beg ; point at beginning of line's text - end ; point at end of line's text - indent ; column of `beg' - endcol ; column of `end' - ncols) ; new indent point or offset - (end-of-line) - ;; Check if this is the last line of the paragraph. - (if (and use-hard-newlines (null eop) - (get-text-property (point) 'hard)) - (setq eop t)) - (skip-chars-backward " \t") - ;; Quick exit if it appears to be properly justified already - ;; or there is no text. - (if (or (bolp) - (and (memq how '(full right)) - (= (current-column) fc))) - nil - (setq end (point)) - (beginning-of-line) - (skip-chars-forward " \t") - ;; Skip over fill-prefix. - (if (and fill-prefix - (not (string-equal fill-prefix "")) - (equal fill-prefix - (buffer-substring - (point) (min (point-max) (+ (length fill-prefix) - (point)))))) - (forward-char (length fill-prefix)) - (if (and adaptive-fill-mode - (looking-at adaptive-fill-regexp)) - (goto-char (match-end 0)))) - (setq fp-end (point)) - (skip-chars-forward " \t") - ;; This is beginning of the line's text. - (setq indent (current-column)) - (setq beg (point)) - (goto-char end) - (setq endcol (current-column)) - - ;; HOW can't be null or left--we would have exited already - (cond ((eq 'right how) - (setq ncols (- fc endcol)) - (if (< ncols 0) - ;; Need to remove some indentation - (delete-region - (progn (goto-char fp-end) - (if (< (current-column) (+ indent ncols)) - (move-to-column (+ indent ncols) t)) - (point)) - (progn (move-to-column indent) (point))) - ;; Need to add some - (goto-char beg) - (indent-to (+ indent ncols)) - ;; If point was at beginning of text, keep it there. - (if (= beg pos) - (move-marker pos (point))))) - - ((eq 'center how) - ;; Figure out how much indentation is needed - (setq ncols (+ (current-left-margin) - (/ (- fc (current-left-margin) ;avail. space - (- endcol indent)) ;text width - 2))) - (if (< ncols indent) - ;; Have too much indentation - remove some - (delete-region - (progn (goto-char fp-end) - (if (< (current-column) ncols) - (move-to-column ncols t)) - (point)) - (progn (move-to-column indent) (point))) - ;; Have too little - add some - (goto-char beg) - (indent-to ncols) - ;; If point was at beginning of text, keep it there. - (if (= beg pos) - (move-marker pos (point))))) - - ((eq 'full how) - ;; Insert extra spaces between words to justify line - (save-restriction - (narrow-to-region beg end) - (or nosqueeze - (canonically-space-region beg end)) - (goto-char (point-max)) - (setq ncols (- fc endcol)) - ;; Ncols is number of additional spaces needed - (if (> ncols 0) - (if (and (not eop) - ;; 97/3/14 jhod: Kinsoku - (find-space-insertable-point)) ;(search-backward " " nil t)) - (while (> ncols 0) - (let ((nmove (+ 3 (random 3)))) - (while (> nmove 0) - (or (find-space-insertable-point) ;(search-backward " " nil t) - (progn - (goto-char (point-max)) - (find-space-insertable-point))) ;(search-backward " "))) - (skip-chars-backward " ") - (setq nmove (1- nmove)))) - ;; XEmacs change - (insert " ") - (skip-chars-backward " ") - (setq ncols (1- ncols))))))) - (t (error "Unknown justification value")))) - (goto-char pos) - (move-marker pos nil))) - nil) - -(defun unjustify-current-line () - "Remove justification whitespace from current line. -If the line is centered or right-justified, this function removes any -indentation past the left margin. If the line is full-justified, it removes -extra spaces between words. It does nothing in other justification modes." - (let ((justify (current-justification))) - (cond ((eq 'left justify) nil) - ((eq nil justify) nil) - ((eq 'full justify) ; full justify: remove extra spaces - (beginning-of-line-text) - (canonically-space-region - (point) (save-excursion (end-of-line) (point)))) - ((memq justify '(center right)) - (save-excursion - (move-to-left-margin nil t) - ;; Position ourselves after any fill-prefix. - (if (and fill-prefix - (not (string-equal fill-prefix "")) - (equal fill-prefix - (buffer-substring - (point) (min (point-max) (+ (length fill-prefix) - (point)))))) - (forward-char (length fill-prefix))) - (delete-region (point) (progn (skip-chars-forward " \t") - (point)))))))) - -(defun unjustify-region (&optional begin end) - "Remove justification whitespace from region. -For centered or right-justified regions, this function removes any indentation -past the left margin from each line. For full-justified lines, it removes -extra spaces between words. It does nothing in other justification modes. -Arguments BEGIN and END are optional; default is the whole buffer." - (save-excursion - (save-restriction - (if end (narrow-to-region (point-min) end)) - (goto-char (or begin (point-min))) - (while (not (eobp)) - (unjustify-current-line) - (forward-line 1))))) - - -(defun fill-nonuniform-paragraphs (min max &optional justifyp mailp) - "Fill paragraphs within the region, allowing varying indentation within each. -This command divides the region into \"paragraphs\", -only at paragraph-separator lines, then fills each paragraph -using as the fill prefix the smallest indentation of any line -in the paragraph. - -When calling from a program, pass range to fill as first two arguments. - -Optional third and fourth arguments JUSTIFY and MAIL-FLAG: -JUSTIFY to justify paragraphs (prefix arg), -MAIL-FLAG for a mail message, i. e. don't fill header lines." - (interactive (list (region-beginning) (region-end) - (if current-prefix-arg 'full))) - (let ((fill-individual-varying-indent t)) - (fill-individual-paragraphs min max justifyp mailp))) - -(defun fill-individual-paragraphs (min max &optional justify mailp) - "Fill paragraphs of uniform indentation within the region. -This command divides the region into \"paragraphs\", -treating every change in indentation level as a paragraph boundary, -then fills each paragraph using its indentation level as the fill prefix. - -When calling from a program, pass range to fill as first two arguments. - -Optional third and fourth arguments JUSTIFY and MAIL-FLAG: -JUSTIFY to justify paragraphs (prefix arg), -MAIL-FLAG for a mail message, i. e. don't fill header lines." - (interactive (list (region-beginning) (region-end) - (if current-prefix-arg 'full))) - (save-restriction - (save-excursion - (goto-char min) - (beginning-of-line) - (narrow-to-region (point) max) - (if mailp - (while (and (not (eobp)) - (or (looking-at "[ \t]*[^ \t\n]+:") - (looking-at "[ \t]*$"))) - (if (looking-at "[ \t]*[^ \t\n]+:") - (search-forward "\n\n" nil 'move) - (forward-line 1)))) - (narrow-to-region (point) max) - ;; Loop over paragraphs. - (while (progn (skip-chars-forward " \t\n") (not (eobp))) - (move-to-left-margin) - (let ((start (point)) - fill-prefix fill-prefix-regexp) - ;; Find end of paragraph, and compute the smallest fill-prefix - ;; that fits all the lines in this paragraph. - (while (progn - ;; Update the fill-prefix on the first line - ;; and whenever the prefix good so far is too long. - (if (not (and fill-prefix - (looking-at fill-prefix-regexp))) - (setq fill-prefix - (if (and adaptive-fill-mode adaptive-fill-regexp - (looking-at adaptive-fill-regexp)) - (match-string 0) - (buffer-substring - (point) - (save-excursion (skip-chars-forward " \t") - (point)))) - fill-prefix-regexp (regexp-quote fill-prefix))) - (forward-line 1) - (if (bolp) - ;; If forward-line went past a newline - ;; move further to the left margin. - (move-to-left-margin)) - ;; Now stop the loop if end of paragraph. - (and (not (eobp)) - (if fill-individual-varying-indent - ;; If this line is a separator line, with or - ;; without prefix, end the paragraph. - (and - (not (looking-at paragraph-separate)) - (save-excursion - (not (and (looking-at fill-prefix-regexp) - ;; XEmacs change - (progn - (forward-char (length fill-prefix)) - (looking-at paragraph-separate)))))) - ;; If this line has more or less indent - ;; than the fill prefix wants, end the paragraph. - (and (looking-at fill-prefix-regexp) - (save-excursion - (not - (progn - (forward-char (length fill-prefix)) - (or (looking-at paragraph-separate) - (looking-at paragraph-start)))))))))) - ;; Fill this paragraph, but don't add a newline at the end. - (let ((had-newline (bolp))) - (fill-region-as-paragraph start (point) justify) - (or had-newline (delete-char -1)))))))) - -;;; fill.el ends here
--- a/lisp/prim/float-sup.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,65 +0,0 @@ -;;; float-sup.el --- detect absence of floating-point support in XEmacs runtime - -;; Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: internal - -;; 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.34. - -;;; Code: - -;; Provide a meaningful error message if we are running on -;; bare (non-float) emacs. -;; Can't test for 'floatp since that may be defined by float-imitation -;; packages like float.el in this very directory. - -;; XEmacs change -(or (featurep 'lisp-float-type) - (error "Floating point was disabled at compile time")) - -;; define pi and e via math-lib calls. (much less prone to killer typos.) -;; XEmacs change (purecopy) -(defconst pi (purecopy (* 4 (atan 1))) "The value of Pi (3.1415926...)") -(defconst e (purecopy (exp 1)) "The value of e (2.7182818...)") - -;; Careful when editing this file ... typos here will be hard to spot. -;; (defconst pi 3.14159265358979323846264338327 -;; "The value of Pi (3.14159265358979323846264338327...)") - -;; XEmacs change (purecopy) -(defconst degrees-to-radians (purecopy (/ pi 180.0)) - "Degrees to radian conversion constant") -(defconst radians-to-degrees (purecopy (/ 180.0 pi)) - "Radian to degree conversion constant") - -;; these expand to a single multiply by a float when byte compiled - -(defmacro degrees-to-radians (x) - "Convert ARG from degrees to radians." - (list '* (/ pi 180.0) x)) -(defmacro radians-to-degrees (x) - "Convert ARG from radians to degrees." - (list '* (/ 180.0 pi) x)) - -;; Provided in C code in XEmacs -;; (provide 'lisp-float-type) - -;;; float-sup.el ends here
--- a/lisp/prim/format.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,831 +0,0 @@ -;;; format.el --- read and save files in multiple formats - -;; Copyright (c) 1994, 1995, 1997 Free Software Foundation - -;; Author: Boris Goldowsky <boris@gnu.ai.mit.edu> -;; Keywords: extensions - -;; 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: Emacs/Mule zeta. - -;;; Commentary: - -;; This file defines a unified mechanism for saving & loading files stored -;; in different formats. `format-alist' contains information that directs -;; Emacs to call an encoding or decoding function when reading or writing -;; files that match certain conditions. -;; -;; When a file is visited, its format is determined by matching the -;; beginning of the file against regular expressions stored in -;; `format-alist'. If this fails, you can manually translate the buffer -;; using `format-decode-buffer'. In either case, the formats used are -;; listed in the variable `buffer-file-format', and become the default -;; format for saving the buffer. To save a buffer in a different format, -;; change this variable, or use `format-write-file'. -;; -;; Auto-save files are normally created in the same format as the visited -;; file, but the variable `auto-save-file-format' can be set to a -;; particularly fast or otherwise preferred format to be used for -;; auto-saving (or nil to do no encoding on auto-save files, but then you -;; risk losing any text-properties in the buffer). -;; -;; You can manually translate a buffer into or out of a particular format -;; with the functions `format-encode-buffer' and `format-decode-buffer'. -;; To translate just the region use the functions `format-encode-region' -;; and `format-decode-region'. -;; -;; You can define a new format by writing the encoding and decoding -;; functions, and adding an entry to `format-alist'. See enriched.el for -;; an example of how to implement a file format. There are various -;; functions defined in this file that may be useful for writing the -;; encoding and decoding functions: -;; * `format-annotate-region' and `format-deannotate-region' allow a -;; single alist of information to be used for encoding and decoding. -;; The alist defines a correspondence between strings in the file -;; ("annotations") and text-properties in the buffer. -;; * `format-replace-strings' is similarly useful for doing simple -;; string->string translations in a reversible manner. - -;;; Code: - -(put 'buffer-file-format 'permanent-local t) - -(defvar format-alist - '((image/jpeg "JPEG image" "\377\330\377\340\000\020JFIF" - image-decode-jpeg nil t image-mode) - (image/gif "GIF image" "GIF8[79]" - image-decode-gif nil t image-mode) - (image/png "Portable Network Graphics" "\211PNG" - image-decode-png nil t image-mode) - (image/x-xpm "XPM image" "/\\* XPM \\*/" - image-decode-xpm nil t image-mode) - (text/enriched "Extended MIME text/enriched format." - "Content-[Tt]ype:[ \t]*text/enriched" - enriched-decode enriched-encode t enriched-mode) - (text/richtext "Extended MIME obsolete text/richtext format." - "Content-[Tt]ype:[ \t]*text/richtext" - richtext-decode richtext-encode t enriched-mode) - (plain "Standard ASCII format, no text properties." - ;; Plain only exists so that there is an obvious neutral choice in - ;; the completion list. - nil nil nil nil nil)) - "List of information about understood file formats. -Elements are of the form \(NAME DOC-STR REGEXP FROM-FN TO-FN MODIFY MODE-FN). -NAME is a symbol, which is stored in `buffer-file-format'. -DOC-STR should be a single line providing more information about the - format. It is currently unused, but in the future will be shown to - the user if they ask for more information. -REGEXP is a regular expression to match against the beginning of the file; - it should match only files in that format. -FROM-FN is called to decode files in that format; it gets two args, BEGIN - and END, and can make any modifications it likes, returning the new - end. It must make sure that the beginning of the file no longer - matches REGEXP, or else it will get called again. -TO-FN is called to encode a region into that format; it is passed three - arguments: BEGIN, END, and BUFFER. BUFFER is the original buffer that - the data being written came from, which the function could use, for - example, to find the values of local variables. TO-FN should either - return a list of annotations like `write-region-annotate-functions', - or modify the region and return the new end. -MODIFY, if non-nil, means the TO-FN wants to modify the region. If nil, - TO-FN will not make any changes but will instead return a list of - annotations. -MODE-FN, if specified, is called when visiting a file with that format.") - -;;; Basic Functions (called from Lisp) - -(defun format-annotate-function (format from to) - "Returns annotations for writing region as FORMAT. -FORMAT is a symbol naming one of the formats defined in `format-alist', -it must be a single symbol, not a list like `buffer-file-format'. -FROM and TO delimit the region to be operated on in the current buffer. -This function works like a function on `write-region-annotate-functions': -it either returns a list of annotations, or returns with a different buffer -current, which contains the modified text to write. - -For most purposes, consider using `format-encode-region' instead." - ;; This function is called by write-region (actually build-annotations) - ;; for each element of buffer-file-format. - (let* ((info (assq format format-alist)) - (to-fn (nth 4 info)) - (modify (nth 5 info))) - (if to-fn - (if modify - ;; To-function wants to modify region. Copy to safe place. - (let ((copy-buf (get-buffer-create " *Format Temp*"))) - (copy-to-buffer copy-buf from to) - (set-buffer copy-buf) - (format-insert-annotations write-region-annotations-so-far from) - (funcall to-fn (point-min) (point-max)) - nil) - ;; Otherwise just call function, it will return annotations. - (funcall to-fn from to))))) - -(defun format-decode (format length &optional visit-flag) - ;; This function is called by insert-file-contents whenever a file is read. - "Decode text from any known FORMAT. -FORMAT is a symbol appearing in `format-alist' or a list of such symbols, -or nil, in which case this function tries to guess the format of the data by -matching against the regular expressions in `format-alist'. After a match is -found and the region decoded, the alist is searched again from the beginning -for another match. - -Second arg LENGTH is the number of characters following point to operate on. -If optional third arg VISIT-FLAG is true, set `buffer-file-format' -to the list of formats used, and call any mode functions defined for those -formats. - -Returns the new length of the decoded region. - -For most purposes, consider using `format-decode-region' instead." - (let ((mod (buffer-modified-p)) - (begin (point)) - (end (+ (point) length))) - (if (null format) - ;; Figure out which format it is in, remember list in `format'. - (let ((try format-alist)) - (while try - (let* ((f (car try)) - (regexp (nth 2 f)) - (p (point))) - (if (and regexp (looking-at regexp) - (< (match-end 0) (+ begin length))) - (progn - (setq format (cons (car f) format)) - ;; Decode it - (if (nth 3 f) (setq end (funcall (nth 3 f) begin end))) - ;; Call visit function if required - (if (and visit-flag (nth 6 f)) (funcall (nth 6 f) 1)) - ;; Safeguard against either of the functions changing pt. - (goto-char p) - ;; Rewind list to look for another format - (setq try format-alist)) - (setq try (cdr try)))))) - ;; Deal with given format(s) - (or (listp format) (setq format (list format))) - (let ((do format) f) - (while do - (or (setq f (assq (car do) format-alist)) - (error "Unknown format" (car do))) - ;; Decode: - (if (nth 3 f) (setq end (funcall (nth 3 f) begin end))) - ;; Call visit function if required - (if (and visit-flag (nth 6 f)) (funcall (nth 6 f) 1)) - (setq do (cdr do))))) - (if visit-flag - (setq buffer-file-format format)) - (set-buffer-modified-p mod) - ;; Return new length of region - (- end begin))) - -;;; -;;; Interactive functions & entry points -;;; - -(defun format-decode-buffer (&optional format) - "Translate the buffer from some FORMAT. -If the format is not specified, this function attempts to guess. -`buffer-file-format' is set to the format used, and any mode-functions -for the format are called." - (interactive - (list (format-read "Translate buffer from format (default: guess): "))) - (save-excursion - (goto-char (point-min)) - (format-decode format (buffer-size) t))) - -(defun format-decode-region (from to &optional format) - "Decode the region from some format. -Arg FORMAT is optional; if omitted the format will be determined by looking -for identifying regular expressions at the beginning of the region." - (interactive - (list (region-beginning) (region-end) - (format-read "Translate region from format (default: guess): "))) - (save-excursion - (goto-char from) - (format-decode format (- to from) nil))) - -(defun format-encode-buffer (&optional format) - "Translate the buffer into FORMAT. -FORMAT defaults to `buffer-file-format'. It is a symbol naming one of the -formats defined in `format-alist', or a list of such symbols." - (interactive - (list (format-read (format "Translate buffer to format (default %s): " - buffer-file-format)))) - (format-encode-region (point-min) (point-max) format)) - -(defun format-encode-region (beg end &optional format) - "Translate the region into some FORMAT. -FORMAT defaults to `buffer-file-format', it is a symbol naming -one of the formats defined in `format-alist', or a list of such symbols." - (interactive - (list (region-beginning) (region-end) - (format-read (format "Translate region to format (default %s): " - buffer-file-format)))) - (if (null format) (setq format buffer-file-format)) - (if (symbolp format) (setq format (list format))) - (save-excursion - (goto-char end) - (let ( ; (cur-buf (current-buffer)) - (end (point-marker))) - (while format - (let* ((info (assq (car format) format-alist)) - (to-fn (nth 4 info)) - (modify (nth 5 info)) - ;; result - ) - (if to-fn - (if modify - (setq end (funcall to-fn beg end (current-buffer))) - (format-insert-annotations - (funcall to-fn beg end (current-buffer))))) - (setq format (cdr format))))))) - -(defun format-write-file (filename format) - "Write current buffer into a FILE using some FORMAT. -Makes buffer visit that file and sets the format as the default for future -saves. If the buffer is already visiting a file, you can specify a directory -name as FILE, to write a file of the same old name in that directory." - (interactive - ;; Same interactive spec as write-file, plus format question. - (let* ((file (if buffer-file-name - (read-file-name "Write file: " - nil nil nil nil) - (read-file-name "Write file: " - (cdr (assq 'default-directory - (buffer-local-variables))) - nil nil (buffer-name)))) - (fmt (format-read (format "Write file `%s' in format: " - (file-name-nondirectory file))))) - (list file fmt))) - (setq buffer-file-format format) - (write-file filename)) - -(defun format-find-file (filename format) - "Find the file FILE using data format FORMAT. -If FORMAT is nil then do not do any format conversion." - (interactive - ;; Same interactive spec as write-file, plus format question. - (let* ((file (read-file-name "Find file: ")) - (fmt (format-read (format "Read file `%s' in format: " - (file-name-nondirectory file))))) - (list file fmt))) - (let ((format-alist nil)) - (find-file filename)) - (if format - (format-decode-buffer format))) - -(defun format-insert-file (filename format &optional beg end) - "Insert the contents of file FILE using data format FORMAT. -If FORMAT is nil then do not do any format conversion. -The optional third and fourth arguments BEG and END specify -the part of the file to read. - -The return value is like the value of `insert-file-contents': -a list (ABSOLUTE-FILE-NAME . SIZE)." - (interactive - ;; Same interactive spec as write-file, plus format question. - (let* ((file (read-file-name "Find file: ")) - (fmt (format-read (format "Read file `%s' in format: " - (file-name-nondirectory file))))) - (list file fmt))) - (let (value size) - (let ((format-alist nil)) - (setq value (insert-file-contents filename nil beg end)) - (setq size (nth 1 value))) - (if format - (setq size (format-decode format size) - value (cons (car value) size))) - value)) - -(defun format-read (&optional prompt) - "Read and return the name of a format. -Return value is a list, like `buffer-file-format'; it may be nil. -Formats are defined in `format-alist'. Optional arg is the PROMPT to use." - (let* ((table (mapcar (lambda (x) (list (symbol-name (car x)))) - format-alist)) - (ans (completing-read (or prompt "Format: ") table nil t))) - (if (not (equal "" ans)) (list (intern ans))))) - - -;;; -;;; Below are some functions that may be useful in writing encoding and -;;; decoding functions for use in format-alist. -;;; - -(defun format-replace-strings (alist &optional reverse beg end) - "Do multiple replacements on the buffer. -ALIST is a list of (from . to) pairs, which should be proper arguments to -`search-forward' and `replace-match' respectively. -Optional 2nd arg REVERSE, if non-nil, means the pairs are (to . from), so that -you can use the same list in both directions if it contains only literal -strings. -Optional args BEGIN and END specify a region of the buffer to operate on." - (save-excursion - (save-restriction - (or beg (setq beg (point-min))) - (if end (narrow-to-region (point-min) end)) - (while alist - (let ((from (if reverse (cdr (car alist)) (car (car alist)))) - (to (if reverse (car (cdr alist)) (cdr (car alist))))) - (goto-char beg) - (while (search-forward from nil t) - (goto-char (match-beginning 0)) - (insert to) - (set-text-properties (- (point) (length to)) (point) - (text-properties-at (point))) - (delete-region (point) (+ (point) (- (match-end 0) - (match-beginning 0))))) - (setq alist (cdr alist))))))) - -;;; Some list-manipulation functions that we need. - -(defun format-delq-cons (cons list) - "Remove the given CONS from LIST by side effect, -and return the new LIST. Since CONS could be the first element -of LIST, write `\(setq foo \(format-delq-cons element foo))' to be sure of -changing the value of `foo'." - (if (eq cons list) - (cdr list) - (let ((p list)) - (while (not (eq (cdr p) cons)) - (if (null p) (error "format-delq-cons: not an element.")) - (setq p (cdr p))) - ;; Now (cdr p) is the cons to delete - (setcdr p (cdr cons)) - list))) - -(defun format-make-relatively-unique (a b) - "Delete common elements of lists A and B, return as pair. -Compares using `equal'." - (let* ((acopy (copy-sequence a)) - (bcopy (copy-sequence b)) - (tail acopy)) - (while tail - (let ((dup (member (car tail) bcopy)) - (next (cdr tail))) - (if dup (setq acopy (format-delq-cons tail acopy) - bcopy (format-delq-cons dup bcopy))) - (setq tail next))) - (cons acopy bcopy))) - -(defun format-common-tail (a b) - "Given two lists that have a common tail, return it. -Compares with `equal', and returns the part of A that is equal to the -equivalent part of B. If even the last items of the two are not equal, -returns nil." - (let ((la (length a)) - (lb (length b))) - ;; Make sure they are the same length - (if (> la lb) - (setq a (nthcdr (- la lb) a)) - (setq b (nthcdr (- lb la) b)))) - (while (not (equal a b)) - (setq a (cdr a) - b (cdr b))) - a) - -(defun format-reorder (items order) - "Arrange ITEMS to following partial ORDER. -Elements of ITEMS equal to elements of ORDER will be rearranged to follow the -ORDER. Unmatched items will go last." - (if order - (let ((item (member (car order) items))) - (if item - (cons (car item) - (format-reorder (format-delq-cons item items) - (cdr order))) - (format-reorder items (cdr order)))) - items)) - -(put 'face 'format-list-valued t) ; These text-properties take values -(put 'unknown 'format-list-valued t) ; that are lists, the elements of which - ; should be considered separately. - ; See format-deannotate-region and - ; format-annotate-region. - -;;; -;;; Decoding -;;; - -(defun format-deannotate-region (from to translations next-fn) - "Translate annotations in the region into text properties. -This sets text properties between FROM to TO as directed by the -TRANSLATIONS and NEXT-FN arguments. - -NEXT-FN is a function that searches forward from point for an annotation. -It should return a list of 4 elements: \(BEGIN END NAME POSITIVE). BEGIN and -END are buffer positions bounding the annotation, NAME is the name searched -for in TRANSLATIONS, and POSITIVE should be non-nil if this annotation marks -the beginning of a region with some property, or nil if it ends the region. -NEXT-FN should return nil if there are no annotations after point. - -The basic format of the TRANSLATIONS argument is described in the -documentation for the `format-annotate-region' function. There are some -additional things to keep in mind for decoding, though: - -When an annotation is found, the TRANSLATIONS list is searched for a -text-property name and value that corresponds to that annotation. If the -text-property has several annotations associated with it, it will be used only -if the other annotations are also in effect at that point. The first match -found whose annotations are all present is used. - -The text property thus determined is set to the value over the region between -the opening and closing annotations. However, if the text-property name has a -non-nil `format-list-valued' property, then the value will be consed onto the -surrounding value of the property, rather than replacing that value. - -There are some special symbols that can be used in the \"property\" slot of -the TRANSLATIONS list: PARAMETER and FUNCTION \(spelled in uppercase). -Annotations listed under the pseudo-property PARAMETER are considered to be -arguments of the immediately surrounding annotation; the text between the -opening and closing parameter annotations is deleted from the buffer but saved -as a string. The surrounding annotation should be listed under the -pseudo-property FUNCTION. Instead of inserting a text-property for this -annotation, the function listed in the VALUE slot is called to make whatever -changes are appropriate. The function's first two arguments are the START and -END locations, and the rest of the arguments are any PARAMETERs found in that -region. - -Any annotations that are found by NEXT-FN but not defined by TRANSLATIONS -are saved as values of the `unknown' text-property \(which is list-valued). -The TRANSLATIONS list should usually contain an entry of the form - \(unknown \(nil format-annotate-value)) -to write these unknown annotations back into the file." - (save-excursion - (save-restriction - (narrow-to-region (point-min) to) - (goto-char from) - (let (next open-ans todo - ;; loc - unknown-ans) - (while (setq next (funcall next-fn)) - (let* ((loc (nth 0 next)) - (end (nth 1 next)) - (name (nth 2 next)) - (positive (nth 3 next)) - (found nil)) - - ;; Delete the annotation - (delete-region loc end) - (if positive - ;; Positive annotations are stacked, remembering location - (setq open-ans (cons (list name loc) open-ans)) - ;; It is a negative annotation: - ;; Close the top annotation & add its text property. - ;; If the file's nesting is messed up, the close might not match - ;; the top thing on the open-annotations stack. - ;; If no matching annotation is open, just ignore the close. - (if (not (assoc name open-ans)) - (message "Extra closing annotation (%s) in file" name) - ;; If one is open, but not on the top of the stack, close - ;; the things in between as well. Set `found' when the real - ;; one is closed. - (while (not found) - (let* ((top (car open-ans)) ; first on stack: should match. - (top-name (car top)) - (start (car (cdr top))) ; location of start - (params (cdr (cdr top))) ; parameters - (aalist translations) - (matched nil)) - (if (equal name top-name) - (setq found t) - (message "Improper nesting in file.")) - ;; Look through property names in TRANSLATIONS - (while aalist - (let ((prop (car (car aalist))) - (alist (cdr (car aalist)))) - ;; And look through values for each property - (while alist - (let ((value (car (car alist))) - (ans (cdr (car alist)))) - (if (member top-name ans) - ;; This annotation is listed, but still have to - ;; check if multiple annotations are satisfied - (if (member 'nil (mapcar - (lambda (r) - (assoc r open-ans)) - ans)) - nil ; multiple ans not satisfied - ;; Yes, all set. - ;; If there are multiple annotations going - ;; into one text property, adjust the - ;; begin points of the other annotations - ;; so that we don't get double marking. - (let ((to-reset ans) - this-one) - (while to-reset - (setq this-one - (assoc (car to-reset) - (cdr open-ans))) - (if this-one - (setcar (cdr this-one) loc)) - (setq to-reset (cdr to-reset)))) - ;; Set loop variables to nil so loop - ;; will exit. - (setq alist nil aalist nil matched t - ;; pop annotation off stack. - open-ans (cdr open-ans)) - (cond - ;; Check for pseudo-properties - ((eq prop 'PARAMETER) - ;; This is a parameter of the top open ann: - ;; delete text and use as arg. - (if open-ans - ;; (If nothing open, discard). - (setq open-ans - (cons (append (car open-ans) - (list - (buffer-substring - start loc))) - (cdr open-ans)))) - (delete-region start loc)) - ((eq prop 'FUNCTION) - ;; Not a property, but a function to call. - (let ((rtn (apply value start loc params))) - (if rtn (setq todo (cons rtn todo))))) - (t - ;; Normal property/value pair - (setq todo - (cons (list start loc prop value) - todo))))))) - (setq alist (cdr alist)))) - (setq aalist (cdr aalist))) - (if matched - nil - ;; Didn't find any match for the annotation: - ;; Store as value of text-property `unknown'. - (setq open-ans (cdr open-ans)) - (setq todo (cons (list start loc 'unknown top-name) - todo)) - (setq unknown-ans (cons name unknown-ans))))))))) - - ;; Once entire file has been scanned, add the properties. - (while todo - (let* ((item (car todo)) - (from (nth 0 item)) - (to (nth 1 item)) - (prop (nth 2 item)) - (val (nth 3 item))) - - (put-text-property - from to prop - (cond ((numberp val) ; add to ambient value if numeric - (+ val (or (get-text-property from prop) 0))) - ((get prop 'format-list-valued) ; value gets consed onto - ; list-valued properties - (let ((prev (get-text-property from prop))) - (cons val (if (listp prev) prev (list prev))))) - (t val)))) ; normally, just set to val. - (setq todo (cdr todo))) - - (if unknown-ans - (message "Unknown annotations: %s" unknown-ans)))))) - -;;; -;;; Encoding -;;; - -(defun format-insert-annotations (list &optional offset) - "Apply list of annotations to buffer as `write-region' would. -Inserts each element of the given LIST of buffer annotations at its -appropriate place. Use second arg OFFSET if the annotations' locations are -not relative to the beginning of the buffer: annotations will be inserted -at their location-OFFSET+1 \(ie, the offset is treated as the character number -of the first character in the buffer)." - (if (not offset) - (setq offset 0) - (setq offset (1- offset))) - (let ((l (reverse list))) - (while l - (goto-char (- (car (car l)) offset)) - (insert (cdr (car l))) - (setq l (cdr l))))) - -(defun format-annotate-value (old new) - "Return OLD and NEW as a \(close . open) annotation pair. -Useful as a default function for TRANSLATIONS alist when the value of the text -property is the name of the annotation that you want to use, as it is for the -`unknown' text property." - (cons (if old (list old)) - (if new (list new)))) - -(defun format-annotate-region (from to trans format-fn ignore) - "Generate annotations for text properties in the region. -Searches for changes between FROM and TO, and describes them with a list of -annotations as defined by alist TRANSLATIONS and FORMAT-FN. IGNORE lists text -properties not to consider; any text properties that are neither ignored nor -listed in TRANSLATIONS are warned about. -If you actually want to modify the region, give the return value of this -function to `format-insert-annotations'. - -Format of the TRANSLATIONS argument: - -Each element is a list whose car is a PROPERTY, and the following -elements are VALUES of that property followed by the names of zero or more -ANNOTATIONS. Whenever the property takes on that value, the annotations -\(as formatted by FORMAT-FN) are inserted into the file. -When the property stops having that value, the matching negated annotation -will be inserted \(it may actually be closed earlier and reopened, if -necessary, to keep proper nesting). - -If the property's value is a list, then each element of the list is dealt with -separately. - -If a VALUE is numeric, then it is assumed that there is a single annotation -and each occurrence of it increments the value of the property by that number. -Thus, given the entry \(left-margin \(4 \"indent\")), if the left margin -changes from 4 to 12, two <indent> annotations will be generated. - -If the VALUE is nil, then instead of annotations, a function should be -specified. This function is used as a default: it is called for all -transitions not explicitly listed in the table. The function is called with -two arguments, the OLD and NEW values of the property. It should return -lists of annotations like `format-annotate-location' does. - - The same structure can be used in reverse for reading files." - (let ((all-ans nil) ; All annotations - becomes return value - (open-ans nil) ; Annotations not yet closed - (loc nil) ; Current location - (not-found nil)) ; Properties that couldn't be saved - (while (or (null loc) - (and (setq loc (next-property-change loc nil to)) - (< loc to))) - (or loc (setq loc from)) - (let* ((ans (format-annotate-location loc (= loc from) ignore trans)) - (neg-ans (format-reorder (aref ans 0) open-ans)) - (pos-ans (aref ans 1)) - (ignored (aref ans 2))) - (setq not-found (append ignored not-found) - ignore (append ignored ignore)) - ;; First do the negative (closing) annotations - (while neg-ans - ;; Check if it's missing. This can happen (eg, a numeric property - ;; going negative can generate closing annotations before there are - ;; any open). Warn user & ignore. - (if (not (member (car neg-ans) open-ans)) - (message "Can't close %s: not open." (car neg-ans)) - (while (not (equal (car neg-ans) (car open-ans))) - ;; To close anno. N, need to first close ans 1 to N-1, - ;; remembering to re-open them later. - (setq pos-ans (cons (car open-ans) pos-ans)) - (setq all-ans - (cons (cons loc (funcall format-fn (car open-ans) nil)) - all-ans)) - (setq open-ans (cdr open-ans))) - ;; Now remove the one we're really interested in from open list. - (setq open-ans (cdr open-ans)) - ;; And put the closing annotation here. - (setq all-ans - (cons (cons loc (funcall format-fn (car neg-ans) nil)) - all-ans))) - (setq neg-ans (cdr neg-ans))) - ;; Now deal with positive (opening) annotations - (let ( ; (p pos-ans) - ) - (while pos-ans - (setq open-ans (cons (car pos-ans) open-ans)) - (setq all-ans - (cons (cons loc (funcall format-fn (car pos-ans) t)) - all-ans)) - (setq pos-ans (cdr pos-ans)))))) - - ;; Close any annotations still open - (while open-ans - (setq all-ans - (cons (cons to (funcall format-fn (car open-ans) nil)) - all-ans)) - (setq open-ans (cdr open-ans))) - (if not-found - (message "These text properties could not be saved:\n %s" - not-found)) - (nreverse all-ans))) - -;;; Internal functions for format-annotate-region. - -(defun format-annotate-location (loc all ignore trans) - "Return annotation(s) needed at LOCATION. -This includes any properties that change between LOC-1 and LOC. -If ALL is true, don't look at previous location, but generate annotations for -all non-nil properties. -Third argument IGNORE is a list of text-properties not to consider. - -Return value is a vector of 3 elements: -1. List of names of the annotations to close -2. List of the names of annotations to open. -3. List of properties that were ignored or couldn't be annotated." - (let* ((prev-loc (1- loc)) - (before-plist (if all nil (text-properties-at prev-loc))) - (after-plist (text-properties-at loc)) - p negatives positives prop props not-found) - ;; make list of all property names involved - (setq p before-plist) - (while p - (if (not (memq (car p) props)) - (setq props (cons (car p) props))) - (setq p (cdr (cdr p)))) - (setq p after-plist) - (while p - (if (not (memq (car p) props)) - (setq props (cons (car p) props))) - (setq p (cdr (cdr p)))) - - (while props - (setq prop (car props) - props (cdr props)) - (if (memq prop ignore) - nil ; If it's been ignored before, ignore it now. - (let ((before (if all nil (car (cdr (memq prop before-plist))))) - (after (car (cdr (memq prop after-plist))))) - (if (equal before after) - nil ; no change; ignore - (let ((result (format-annotate-single-property-change - prop before after trans))) - (if (not result) - (setq not-found (cons prop not-found)) - (setq negatives (nconc negatives (car result)) - positives (nconc positives (cdr result))))))))) - (vector negatives positives not-found))) - -(defun format-annotate-single-property-change (prop old new trans) - "Return annotations for PROPERTY changing from OLD to NEW. -These are searched for in the TRANSLATIONS alist. -If NEW does not appear in the list, but there is a default function, then that -function is called. -Annotations to open and to close are returned as a dotted pair." - (let ((prop-alist (cdr (assoc prop trans))) - ;; default - ) - (if (not prop-alist) - nil - ;; If property is numeric, nil means 0 - (cond ((and (numberp old) (null new)) - (setq new 0)) - ((and (numberp new) (null old)) - (setq old 0))) - ;; If either old or new is a list, have to treat both that way. - (if (or (consp old) (consp new)) - (let* ((old (if (listp old) old (list old))) - (new (if (listp new) new (list new))) - ;; (tail (format-common-tail old new)) - close open) - (while old - (setq close - (append (car (format-annotate-atomic-property-change - prop-alist (car old) nil)) - close) - old (cdr old))) - (while new - (setq open - (append (cdr (format-annotate-atomic-property-change - prop-alist nil (car new))) - open) - new (cdr new))) - (format-make-relatively-unique close open)) - (format-annotate-atomic-property-change prop-alist old new))))) - -(defun format-annotate-atomic-property-change (prop-alist old new) - "Internal function annotate a single property change. -PROP-ALIST is the relevant segment of a TRANSLATIONS list. -OLD and NEW are the values." - (cond - ;; Numerical annotation - use difference - ((and (numberp old) (numberp new)) - (let* ((entry (progn - (while (and (car (car prop-alist)) - (not (numberp (car (car prop-alist))))) - (setq prop-alist (cdr prop-alist))) - (car prop-alist))) - (increment (car (car prop-alist))) - (n (ceiling (/ (float (- new old)) (float increment)))) - (anno (car (cdr (car prop-alist))))) - (if (> n 0) - (cons nil (make-list n anno)) - (cons (make-list (- n) anno) nil)))) - - ;; Standard annotation - (t (let ((close (and old (cdr (assoc old prop-alist)))) - (open (and new (cdr (assoc new prop-alist))))) - (if (or close open) - (format-make-relatively-unique close open) - ;; Call "Default" function, if any - (let ((default (assq nil prop-alist))) - (if default - (funcall (car (cdr default)) old new)))))))) - -;; format.el ends here
--- a/lisp/prim/frame.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1296 +0,0 @@ -;;; frame.el --- multi-frame management independent of window systems. - -;;;; Copyright (C) 1993, 1994 Free Software Foundation, Inc. -;;;; Copyright (C) 1995, 1996 Ben Wing. - -;; Maintainer: FSF -;; Keywords: internal - -;; 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, 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: FSF 19.30. - -;;; Code: - -(defgroup frames nil - "Support for Emacs frames and window systems." - :group 'environment) - -; No need for `frame-creation-function'. - -;;; The initial value given here for this must ask for a minibuffer. -;;; There must always exist a frame with a minibuffer, and after we -;;; delete the terminal frame, this will be the only frame. -(defcustom initial-frame-plist '(minibuffer t) - "Plist of frame properties for creating the initial X window frame. -You can set this in your `.emacs' file; for example, - (setq initial-frame-plist '(top 1 left 1 width 80 height 55)) -Properties specified here supersede the values given in `default-frame-plist'. -The format of this can also be an alist for backward compatibility. - -If the value calls for a frame without a minibuffer, and you have not created -a minibuffer frame on your own, one is created according to -`minibuffer-frame-plist'. - -You can specify geometry-related options for just the initial frame -by setting this variable in your `.emacs' file; however, they won't -take effect until Emacs reads `.emacs', which happens after first creating -the frame. If you want the frame to have the proper geometry as soon -as it appears, you need to use this three-step process: -* Specify X resources to give the geometry you want. -* Set `default-frame-plist' to override these options so that they - don't affect subsequent frames. -* Set `initial-frame-plist' in a way that matches the X resources, - to override what you put in `default-frame-plist'." - :type '(repeat (group :inline t - (symbol :tag "Property") - (sexp :tag "Value"))) - :group 'frames) - -(defcustom minibuffer-frame-plist '(width 80 height 2 menubar-visible-p nil - default-toolbar-visible-p nil) - "Plist of frame properties for initially creating a minibuffer frame. -You can set this in your `.emacs' file; for example, - (setq minibuffer-frame-plist '(top 1 left 1 width 80 height 2)) -Properties specified here supersede the values given in -`default-frame-plist'. -The format of this can also be an alist for backward compatibility." - :type '(repeat (group :inline t - (symbol :tag "Property") - (sexp :tag "Value"))) - :group 'frames) - -(defcustom pop-up-frame-plist nil - "Plist of frame properties used when creating pop-up frames. -Pop-up frames are used for completions, help, and the like. -This variable can be set in your init file, like this: - (setq pop-up-frame-plist '(width 80 height 20)) -These supersede the values given in `default-frame-plist'. -The format of this can also be an alist for backward compatibility." - :type '(repeat (group :inline t - (symbol :tag "Property") - (sexp :tag "Value"))) - :group 'frames) - -(setq pop-up-frame-function - (function (lambda () - (make-frame pop-up-frame-plist)))) - -(defcustom special-display-frame-plist '(height 14 width 80 unsplittable t) - "*Plist of frame properties used when creating special frames. -Special frames are used for buffers whose names are in -`special-display-buffer-names' and for buffers whose names match -one of the regular expressions in `special-display-regexps'. -This variable can be set in your init file, like this: - (setq special-display-frame-plist '(width 80 height 20)) -These supersede the values given in `default-frame-plist'. -The format of this can also be an alist for backward compatibility." - :type '(repeat (group :inline t - (symbol :tag "Property") - (sexp :tag "Value"))) - :group 'frames) - -(defun safe-alist-to-plist (cruftiness) - (if (consp (car cruftiness)) - (alist-to-plist cruftiness) - cruftiness)) - -;; Display BUFFER in its own frame, reusing an existing window if any. -;; Return the window chosen. -;; Currently we do not insist on selecting the window within its frame. -;; If ARGS is a plist, use it as a list of frame property specs. -;; #### Change, not compatible with FSF: This stuff is all so incredibly -;; junky anyway that I doubt it makes any difference. -;; If ARGS is a list whose car is t, -;; use (cadr ARGS) as a function to do the work. -;; Pass it BUFFER as first arg, and (cddr ARGS) gives the rest of the args. -(defun special-display-popup-frame (buffer &optional args) - ;; if we can't display simultaneous multiple frames, just return - ;; nil and let the normal behavior take over. - (and (device-on-window-system-p) - (if (and args (eq t (car args))) - (apply (cadr args) buffer (cddr args)) - (let ((window (get-buffer-window buffer t))) - (if window - ;; If we have a window already, make it visible. - (let ((frame (window-frame window))) - (make-frame-visible frame) - (raise-frame frame) - window) - ;; If no window yet, make one in a new frame. - (let ((frame - (make-frame (append (safe-alist-to-plist args) - (safe-alist-to-plist - special-display-frame-plist))))) - (set-window-buffer (frame-selected-window frame) buffer) - (set-window-dedicated-p (frame-selected-window frame) t) - (frame-selected-window frame))))))) - -(setq special-display-function 'special-display-popup-frame) - -;;; Handle delete-frame events from the X server. -;(defun handle-delete-frame (event) -; (interactive "e") -; (let ((frame (posn-window (event-start event))) -; (i 0) -; (tail (frame-list))) -; (while tail -; (and (frame-visible-p (car tail)) -; (not (eq (car tail) frame)) -; (setq i (1+ i))) -; (setq tail (cdr tail))) -; (if (> i 0) -; (delete-frame frame t) -; (kill-emacs)))) - - -;;;; Arrangement of frames at startup - -;;; 1) Load the window system startup file from the lisp library and read the -;;; high-priority arguments (-q and the like). The window system startup -;;; file should create any frames specified in the window system defaults. -;;; -;;; 2) If no frames have been opened, we open an initial text frame. -;;; -;;; 3) Once the init file is done, we apply any newly set properties -;;; in initial-frame-plist to the frame. - -;; These are now called explicitly at the proper times, -;; since that is easier to understand. -;; Actually using hooks within Emacs is bad for future maintenance. --rms. -;; (add-hook 'before-init-hook 'frame-initialize) -;; (add-hook 'window-setup-hook 'frame-notice-user-settings) - -;;; If we create the initial frame, this is it. -(defvar frame-initial-frame nil) - -;; Record the properties used in frame-initialize to make the initial frame. -(defvar frame-initial-frame-plist) - -(defvar frame-initial-geometry-arguments nil) - -(defun canonicalize-frame-plists () - (setq initial-frame-plist (safe-alist-to-plist initial-frame-plist)) - (setq default-frame-plist (safe-alist-to-plist default-frame-plist))) - -;;; startup.el calls this function before loading the user's init -;;; file - if there is no frame with a minibuffer open now, create -;;; one to display messages while loading the init file. -(defun frame-initialize () - ;; In batch mode, we actually use the initial terminal device for output. - (canonicalize-frame-plists) - (if (not (noninteractive)) - (progn - ;; Don't call select-frame here - focus is a matter of WM policy. - - ;; If there is no frame with a minibuffer besides the terminal - ;; frame, then we need to create the opening frame. Make sure - ;; it has a minibuffer, but let initial-frame-plist omit the - ;; minibuffer spec. - (or (delq terminal-frame (minibuffer-frame-list)) - (progn - (setq frame-initial-frame-plist - (append initial-frame-plist default-frame-plist)) - ;; FSFmacs has scroll-bar junk here that we don't need. - (setq default-minibuffer-frame - (setq frame-initial-frame - (make-frame initial-frame-plist - (car (delq terminal-device - (device-list)))))) - ;; Delete any specifications for window geometry properties - ;; so that we won't reapply them in frame-notice-user-settings. - ;; It would be wrong to reapply them then, - ;; because that would override explicit user resizing. - (setq initial-frame-plist - (frame-remove-geometry-props initial-frame-plist)))) - ;; At this point, we know that we have a frame open, so we - ;; can delete the terminal device. - (delete-device terminal-device) - (setq terminal-frame nil) - - ;; FSFmacs sets frame-creation-function here, but no need. - ))) - -;;; startup.el calls this function after loading the user's init -;;; file. Now default-frame-plist and initial-frame-plist contain -;;; information to which we must react; do what needs to be done. -(defun frame-notice-user-settings () - - ;; FSFmacs has menu-bar junk here that we don't need. - - (canonicalize-frame-plists) - - ;; Creating and deleting frames may shift the selected frame around, - ;; and thus the current buffer. Protect against that. We don't - ;; want to use save-excursion here, because that may also try to set - ;; the buffer of the selected window, which fails when the selected - ;; window is the minibuffer. - (let ((old-buffer (current-buffer))) - - ;; If the initial frame is still around, apply initial-frame-plist - ;; and default-frame-plist to it. - (if (frame-live-p frame-initial-frame) - - ;; The initial frame we create above always has a minibuffer. - ;; If the user wants to remove it, or make it a minibuffer-only - ;; frame, then we'll have to delete the current frame and make a - ;; new one; you can't remove or add a root window to/from an - ;; existing frame. - ;; - ;; NOTE: default-frame-plist was nil when we created the - ;; existing frame. We need to explicitly include - ;; default-frame-plist in the properties of the screen we - ;; create here, so that its new value, gleaned from the user's - ;; .emacs file, will be applied to the existing screen. - (if (not (eq (car - (or (and (lax-plist-member - initial-frame-plist 'minibuffer) - (list (lax-plist-get initial-frame-plist - 'minibuffer))) - (and (lax-plist-member default-frame-plist - 'minibuffer) - (list (lax-plist-get default-frame-plist - 'minibuffer))) - '(t))) - t)) - ;; Create the new frame. - (let (props - ) - ;; If the frame isn't visible yet, wait till it is. - ;; If the user has to position the window, - ;; Emacs doesn't know its real position until - ;; the frame is seen to be visible. - - (if (frame-property frame-initial-frame 'initially-unmapped) - nil - (while (not (frame-visible-p frame-initial-frame)) - (sleep-for 1))) - (setq props (frame-properties frame-initial-frame)) - ;; Get rid of `name' unless it was specified explicitly before. - (or (lax-plist-member frame-initial-frame-plist 'name) - (setq props (lax-plist-remprop props 'name))) - (setq props (append initial-frame-plist default-frame-plist - props - nil)) - ;; Get rid of `reverse', because that was handled - ;; when we first made the frame. - (laxputf props 'reverse nil) - ;; Get rid of `window-id', otherwise make-frame will - ;; think we're trying to setup an external widget. - (laxremf props 'window-id) - (if (lax-plist-member frame-initial-geometry-arguments 'height) - (laxremf props 'height)) - (if (lax-plist-member frame-initial-geometry-arguments 'width) - (laxremf props 'width)) - (if (lax-plist-member frame-initial-geometry-arguments 'left) - (laxremf props 'left)) - (if (lax-plist-member frame-initial-geometry-arguments 'top) - (laxremf props 'top)) - - ;; Now create the replacement initial frame. - (make-frame - ;; Use the geometry args that created the existing - ;; frame, rather than the props we get for it. - (append '(user-size t user-position t) - frame-initial-geometry-arguments - props)) - ;; The initial frame, which we are about to delete, may be - ;; the only frame with a minibuffer. If it is, create a - ;; new one. - (or (delq frame-initial-frame (minibuffer-frame-list)) - (make-initial-minibuffer-frame nil)) - - ;; If the initial frame is serving as a surrogate - ;; minibuffer frame for any frames, we need to wean them - ;; onto a new frame. The default-minibuffer-frame - ;; variable must be handled similarly. - (let ((users-of-initial - (filtered-frame-list - #'(lambda (frame) - (and (not (eq frame frame-initial-frame)) - (eq (window-frame - (minibuffer-window frame)) - frame-initial-frame)))))) - (if (or users-of-initial - (eq default-minibuffer-frame frame-initial-frame)) - - ;; Choose an appropriate frame. Prefer frames which - ;; are only minibuffers. - (let* ((new-surrogate - (car - (or (filtered-frame-list - #'(lambda (frame) - (eq 'only - (frame-property frame 'minibuffer)))) - (minibuffer-frame-list)))) - (new-minibuffer (minibuffer-window new-surrogate))) - - (if (eq default-minibuffer-frame frame-initial-frame) - (setq default-minibuffer-frame new-surrogate)) - - ;; Wean the frames using frame-initial-frame as - ;; their minibuffer frame. - (mapcar - #' - (lambda (frame) - (set-frame-property frame 'minibuffer - new-minibuffer)) - users-of-initial)))) - - ;; Redirect events enqueued at this frame to the new frame. - ;; Is this a good idea? - ;; Probably not, since this whole redirect-frame-focus - ;; stuff is a load of trash, and so is this function we're in. - ;; --ben - ;(redirect-frame-focus frame-initial-frame new) - - ;; Finally, get rid of the old frame. - (delete-frame frame-initial-frame t)) - - ;; Otherwise, we don't need all that rigamarole; just apply - ;; the new properties. - (let (newprops allprops tail) - (setq allprops (append initial-frame-plist - default-frame-plist)) - (if (lax-plist-member frame-initial-geometry-arguments 'height) - (laxremf allprops 'height)) - (if (lax-plist-member frame-initial-geometry-arguments 'width) - (remf allprops 'width)) - (if (lax-plist-member frame-initial-geometry-arguments 'left) - (laxremf allprops 'left)) - (if (lax-plist-member frame-initial-geometry-arguments 'top) - (laxremf allprops 'top)) - (setq tail allprops) - ;; Find just the props that have changed since we first - ;; made this frame. Those are the ones actually set by - ;; the init file. For those props whose values we already knew - ;; (such as those spec'd by command line options) - ;; it is undesirable to specify the parm again - ;; once the user has seen the frame and been able to alter it - ;; manually. - (while tail - (let (newval oldval) - (setq oldval (lax-plist-get frame-initial-frame-plist - (car tail))) - (setq newval (lax-plist-get allprops (car tail))) - (or (eq oldval newval) - (laxputf newprops (car tail) newval))) - (setq tail (cddr tail))) - (set-frame-properties frame-initial-frame newprops) - ;silly FSFmacs junk - ;if (lax-plist-member newprops 'font) - ; (frame-update-faces frame-initial-frame)) - - ))) - - ;; Restore the original buffer. - (set-buffer old-buffer) - - ;; Make sure the initial frame can be GC'd if it is ever deleted. - ;; Make sure frame-notice-user-settings does nothing if called twice. - (setq frame-initial-frame nil))) - -(defun make-initial-minibuffer-frame (device) - (let ((props (append '(minibuffer only) - (safe-alist-to-plist minibuffer-frame-plist)))) - (make-frame props device))) - - -;;;; Creation of additional frames, and other frame miscellanea - -(defun get-other-frame () - "Return some frame other than the current frame, creating one if necessary." - (let* ((this (selected-frame)) - ;; search visible frames first - (next (next-frame this 'visible-nomini))) - ;; then search iconified frames - (if (eq this next) - (setq next (next-frame 'visible-iconic-nomini))) - (if (eq this next) - ;; otherwise, make a new frame - (make-frame) - next))) - -(defun next-multiframe-window () - "Select the next window, regardless of which frame it is on." - (interactive) - (select-window (next-window (selected-window) - (> (minibuffer-depth) 0) - t))) - -(defun previous-multiframe-window () - "Select the previous window, regardless of which frame it is on." - (interactive) - (select-window (previous-window (selected-window) - (> (minibuffer-depth) 0) - t))) - -(defun make-frame-on-device (type connection &optional props) - "Create a frame of type TYPE on CONNECTION. -TYPE should be a symbol naming the device type, i.e. one of - -x An X display. CONNECTION should be a standard display string - such as \"unix:0\", or nil for the display specified on the - command line or in the DISPLAY environment variable. Only if - support for X was compiled into XEmacs. -tty A standard TTY connection or terminal. CONNECTION should be - a TTY device name such as \"/dev/ttyp2\" (as determined by - the Unix command `tty') or nil for XEmacs' standard input - and output (usually the TTY in which XEmacs started). Only - if support for TTY's was compiled into XEmacs. -ns A connection to a machine running the NeXTstep windowing - system. Not currently implemented. -win32 A connection to a machine running Microsoft Windows NT or - Windows 95. Not currently implemented. -pc A direct-write MS-DOS frame. Not currently implemented. - -PROPS should be a plist of properties, as in the call to `make-frame'. - -If a connection to CONNECTION already exists, it is reused; otherwise, -a new connection is opened." - (make-frame props (make-device type connection props))) - -;; Alias, kept temporarily. -(defalias 'new-frame 'make-frame) - -; FSFmacs has make-frame here. We have it in C, so no need for -; frame-creation-function. - -(defun filtered-frame-list (predicate &optional device) - "Return a list of all live frames which satisfy PREDICATE. -If optional second arg DEVICE is non-nil, restrict the frames - returned to that device." - (let ((frames (if device (device-frame-list device) - (frame-list))) - good-frames) - (while (consp frames) - (if (funcall predicate (car frames)) - (setq good-frames (cons (car frames) good-frames))) - (setq frames (cdr frames))) - good-frames)) - -(defun minibuffer-frame-list (&optional device) - "Return a list of all frames with their own minibuffers. -If optional second arg DEVICE is non-nil, restrict the frames - returned to that device." - (filtered-frame-list - #'(lambda (frame) - (eq frame (window-frame (minibuffer-window frame)))) - device)) - -(defun frame-minibuffer-only-p (frame) - "Return non-nil if FRAME is a minibuffer-only frame." - (eq (frame-root-window frame) (minibuffer-window frame))) - -(defun frame-remove-geometry-props (plist) - "Return the property list PLIST, but with geometry specs removed. -This deletes all bindings in PLIST for `top', `left', `width', -`height', `user-size' and `user-position' properties. -Emacs uses this to avoid overriding explicit moves and resizings from -the user during startup." - (setq plist (canonicalize-lax-plist (copy-sequence plist))) - (mapcar #'(lambda (propname) - (if (lax-plist-member plist propname) - (progn - (setq frame-initial-geometry-arguments - (cons propname - (cons (lax-plist-get plist propname) - frame-initial-geometry-arguments))) - (setq plist (lax-plist-remprop plist propname))))) - '(height width top left user-size user-position)) - plist) - -(defun other-frame (arg) - "Select the ARG'th different visible frame, and raise it. -All frames are arranged in a cyclic order. -This command selects the frame ARG steps away in that order. -A negative ARG moves in the opposite order." - (interactive "p") - (let ((frame (selected-frame))) - (while (> arg 0) - (setq frame (next-frame frame 'visible-nomini)) - (setq arg (1- arg))) - (while (< arg 0) - (setq frame (previous-frame frame 'visible-nomini)) - (setq arg (1+ arg))) - (raise-frame frame) - (select-frame frame) - ;this is a bad idea; you should in general never warp the - ;pointer unless the user asks for this. Furthermore, - ;our version of `set-mouse-position' takes a window, - ;not a frame. - ;(set-mouse-position (selected-frame) (1- (frame-width)) 0) - ;some weird FSFmacs randomness - ;(if (fboundp 'unfocus-frame) - ; (unfocus-frame)))) - )) - -;; XEmacs-added utility functions - -; this is in C in FSFmacs -(defun frame-list () - "Return a list of all frames on all devices/consoles." - ;; Lists are copies, so nconc is safe here. - (apply 'nconc (mapcar 'device-frame-list (device-list)))) - -(defun frame-type (&optional frame) - "Return the type of the specified frame (e.g. `x' or `tty'). -This is equivalent to the type of the frame's device. -Value is `tty' for a tty frame (a character-only terminal), -`x' for a frame that is an X window, -`ns' for a frame that is a NeXTstep window (not yet implemented), -`win32' for a frame that is a Windows or Windows NT window (not yet - implemented), -`pc' for a frame that is a direct-write MS-DOS frame (not yet implemented), -`stream' for a stream frame (which acts like a stdio stream), and -`dead' for a deleted frame." - (or frame (setq frame (selected-frame))) - (if (not (frame-live-p frame)) 'dead - (device-type (frame-device frame)))) - -(defun device-or-frame-p (object) - "Return non-nil if OBJECT is a device or frame." - (or (devicep object) - (framep object))) - -(defun device-or-frame-type (device-or-frame) - "Return the type (e.g. `x' or `tty') of DEVICE-OR-FRAME. -DEVICE-OR-FRAME should be a device or a frame object. See `device-type' -for a description of the possible types." - (if (devicep device-or-frame) - (device-type device-or-frame) - (frame-type device-or-frame))) - -(defun fw-frame (obj) - "Given a frame or window, return the associated frame. -Return nil otherwise." - (cond ((windowp obj) (window-frame obj)) - ((framep obj) obj) - (t nil))) - - -;;;; Frame configurations - -(defun current-frame-configuration () - "Return a list describing the positions and states of all frames. -Its car is `frame-configuration'. -Each element of the cdr is a list of the form (FRAME PLIST WINDOW-CONFIG), -where - FRAME is a frame object, - PLIST is a property list specifying some of FRAME's properties, and - WINDOW-CONFIG is a window configuration object for FRAME." - (cons 'frame-configuration - (mapcar (function - (lambda (frame) - (list frame - (frame-properties frame) - (current-window-configuration frame)))) - (frame-list)))) - -(defun set-frame-configuration (configuration &optional nodelete) - "Restore the frames to the state described by CONFIGURATION. -Each frame listed in CONFIGURATION has its position, size, window -configuration, and other properties set as specified in CONFIGURATION. -Ordinarily, this function deletes all existing frames not -listed in CONFIGURATION. But if optional second argument NODELETE -is given and non-nil, the unwanted frames are iconified instead." - (or (frame-configuration-p configuration) - (signal 'wrong-type-argument - (list 'frame-configuration-p configuration))) - (let ((config-plist (cdr configuration)) - frames-to-delete) - (mapc (lambda (frame) - (let ((properties (assq frame config-plist))) - (if properties - (progn - (set-frame-properties - frame - ;; Since we can't set a frame's minibuffer status, - ;; we might as well omit the parameter altogether. - (lax-plist-remprop (nth 1 properties) 'minibuffer)) - (set-window-configuration (nth 2 properties))) - (setq frames-to-delete (cons frame frames-to-delete))))) - (frame-list)) - (if nodelete - ;; Note: making frames invisible here was tried - ;; but led to some strange behavior--each time the frame - ;; was made visible again, the window manager asked afresh - ;; for where to put it. - (mapc 'iconify-frame frames-to-delete) - (mapc 'delete-frame frames-to-delete)))) - -; this function is in subr.el in FSFmacs. -; that's because they don't always include frame.el, while we do. - -(defun frame-configuration-p (object) - "Return non-nil if OBJECT seems to be a frame configuration. -Any list whose car is `frame-configuration' is assumed to be a frame -configuration." - (and (consp object) - (eq (car object) 'frame-configuration))) - - -;; FSFmacs has functions `frame-width', `frame-height' here. -;; We have them in C. - -;; FSFmacs has weird functions `set-default-font', `set-background-color', -;; `set-foreground-color' here. They don't do sensible things like -;; set faces; instead they set frame properties (??!!) and call -;; useless functions such as `frame-update-faces' and -;; `frame-update-face-colors'. - -;; FSFmacs has functions `set-cursor-color', `set-mouse-color', and -;; `set-border-color', which refer to frame properties. -;; #### We need to use specifiers here. - -;(defun auto-raise-mode (arg) -; "Toggle whether or not the selected frame should auto-raise. -;With arg, turn auto-raise mode on if and only if arg is positive. -;Note that this controls Emacs's own auto-raise feature. -;Some window managers allow you to enable auto-raise for certain windows. -;You can use that for Emacs windows if you wish, but if you do, -;that is beyond the control of Emacs and this command has no effect on it." -; (interactive "P") -; (if (null arg) -; (setq arg -; (if (frame-property (selected-frame) 'auto-raise) -; -1 1))) -; (set-frame-property (selected-frame) 'auto-raise (> arg 0))) - -;(defun auto-lower-mode (arg) -; "Toggle whether or not the selected frame should auto-lower. -;With arg, turn auto-lower mode on if and only if arg is positive. -;Note that this controls Emacs's own auto-lower feature. -;Some window managers allow you to enable auto-lower for certain windows. -;You can use that for Emacs windows if you wish, but if you do, -;that is beyond the control of Emacs and this command has no effect on it." -; (interactive "P") -; (if (null arg) -; (setq arg -; (if (frame-property (selected-frame) 'auto-lower) -; -1 1))) -; (set-frame-property (selected-frame) 'auto-lower (> arg 0))) - -;; FSFmacs has silly functions `toggle-scroll-bar', -;; `toggle-horizontal-scrollbar' - -;;; Iconifying emacs. -;;; -;;; The function iconify-emacs replaces every non-iconified emacs window -;;; with a *single* icon. Iconified emacs windows are left alone. When -;;; emacs is in this globally-iconified state, de-iconifying any emacs icon -;;; will uniconify all frames that were visible, and iconify all frames -;;; that were not. This is done by temporarily changing the value of -;;; `map-frame-hook' to `deiconify-emacs' (which should never be called -;;; except from the map-frame-hook while emacs is iconified). -;;; -;;; The title of the icon representing all emacs frames is controlled by -;;; the variable `icon-name'. This is done by temporarily changing the -;;; value of `frame-icon-title-format'. Unfortunately, this changes the -;;; titles of all emacs icons, not just the "big" icon. -;;; -;;; It would be nice if existing icons were removed and restored by -;;; iconifying the emacs process, but I couldn't make that work yet. - -(defvar icon-name nil) ; set this at run time, not load time. - -(defvar iconification-data nil) - -(defun iconify-emacs () - "Replace every non-iconified FRAME with a *single* icon. -Iconified frames are left alone. When XEmacs is in this -globally-iconified state, de-iconifying any emacs icon will uniconify -all frames that were visible, and iconify all frames that were not." - (interactive) - (if iconification-data (error "already iconified?")) - (let* ((frames (frame-list)) - (rest frames) - (me (selected-frame)) - frame) - (while rest - (setq frame (car rest)) - (setcar rest (cons frame (frame-visible-p frame))) -; (if (memq (cdr (car rest)) '(icon nil)) -; (progn -; (make-frame-visible frame) ; deiconify, and process the X event -; (sleep-for 500 t) ; process X events; I really want to XSync() here -; )) - (or (eq frame me) (make-frame-invisible frame)) - (setq rest (cdr rest))) - (or (boundp 'map-frame-hook) (setq map-frame-hook nil)) - (or icon-name - (setq icon-name (concat invocation-name " @ " (system-name)))) - (setq iconification-data - (list frame-icon-title-format map-frame-hook frames) - frame-icon-title-format icon-name - map-frame-hook 'deiconify-emacs) - (iconify-frame me))) - - -(defun deiconify-emacs (&optional ignore) - (or iconification-data (error "not iconified?")) - (setq frame-icon-title-format (car iconification-data) - map-frame-hook (car (cdr iconification-data)) - iconification-data (car (cdr (cdr iconification-data)))) - (while iconification-data - (let ((visibility (cdr (car iconification-data)))) - (cond (visibility ;; JV (Note non-nil means visible in XEmacs) - (make-frame-visible (car (car iconification-data)))) -; (t ;; (eq visibility 'icon) ;; JV Not in XEmacs!!! -; (make-frame-visible (car (car iconification-data))) -; (sleep-for 500 t) ; process X events; I really want to XSync() here -; (iconify-frame (car (car iconification-data)))) - ;; (t nil) - )) - (setq iconification-data (cdr iconification-data)))) - -(defun suspend-or-iconify-emacs () - "Calls iconify-emacs if frame is an X frame, otherwise calls suspend-emacs" - (interactive) - (cond - ((eq (frame-type) 'x) - (iconify-emacs)) - ((and (eq (frame-type) 'tty) - (console-tty-controlling-process (selected-console))) - (suspend-console (selected-console))) - (t - (suspend-emacs)))) - -;; This is quite a mouthful, but it should be descriptive, as it's -;; bound to C-z -(defun suspend-emacs-or-iconify-frame () - "Iconify current frame if it is an X frame, otherwise suspend Emacs." - (interactive) - (cond ((eq (frame-type) 'x) - (iconify-frame)) - ((and (eq (frame-type) 'tty) - (console-tty-controlling-process (selected-console))) - (suspend-console (selected-console))) - (t - (suspend-emacs)))) - - -;;; auto-raise and auto-lower - -(defcustom auto-raise-frame nil - "*If true, frames will be raised to the top when selected. -Under X, most ICCCM-compliant window managers will have an option to do this -for you, but this variable is provided in case you're using a broken WM." - :type 'boolean - :group 'frames) - -(defcustom auto-lower-frame nil - "*If true, frames will be lowered to the bottom when no longer selected. -Under X, most ICCCM-compliant window managers will have an option to do this -for you, but this variable is provided in case you're using a broken WM." - :type 'boolean - :group 'frames) - -(defun default-select-frame-hook () - "Implements the `auto-raise-frame' variable. -For use as the value of `select-frame-hook'." - (if auto-raise-frame (raise-frame (selected-frame)))) - -(defun default-deselect-frame-hook () - "Implements the `auto-lower-frame' variable. -For use as the value of `deselect-frame-hook'." - (if auto-lower-frame (lower-frame (selected-frame)))) - -(or select-frame-hook - (add-hook 'select-frame-hook 'default-select-frame-hook)) - -(or deselect-frame-hook - (add-hook 'deselect-frame-hook 'default-deselect-frame-hook)) - -(defun default-drag-and-drop-functions (frame filepath &optional data) - "Implements the `drag-and-drop-functions' variable. -For use as the value of `drag-and-drop-functions'. -A file is popped up in a new buffer, some data without -is inserted at point." - ;; changed this back -- hope it works for CDE ;-) Oliver Graf <ograf@fga.de> - ;; the OffiX drop stuff has moved to mouse.el (mouse-offix-drop) - (if data - (insert data) - (let ((x pop-up-windows)) - (setq pop-up-windows nil) - (pop-to-buffer (find-file-noselect filepath) nil frame) - (make-frame-visible frame) - (setq pop-up-windows x)))) - -(and (boundp 'drag-and-drop-functions) - (or drag-and-drop-functions - (add-hook 'drag-and-drop-functions 'default-drag-and-drop-functions))) - -(defun cde-start-drag (begin end) - "Implements the CDE drag operation. -Calls the internal function cde-start-drag-internal to do the actual work." - (interactive "_r") - (if (featurep 'cde) - ;; Avoid build-time doc string warning by calling the function - ;; in the following roundabout way: - (funcall (intern "cde-start-drag-internal") - (buffer-substring-no-properties begin end)) - (error "CDE functionality not compiled in."))) - -;; the OffiX drag stuff will soon move also (perhaps mouse.el) -;; if the drag event is done -(defun offix-start-drag (event data &optional type) - "Implements the OffiX drag operation. -Calls the internal function offix-start-drag-internal to do the actual work. -If type is not given, DndText is assumed." - ;; Oliver Graf <ograf@fga.de> - (interactive "esi") - (if (featurep 'offix) - (funcall (intern "offix-start-drag-internal") event data type) - (error "OffiX functionality not compiled in."))) - -(defun offix-start-drag-region (event begin end) - "Implements the OffiX drag operation for a region. -Calls the internal function offix-start-drag-internal to do the actual work. -This always assumes DndText as type." - ;; Oliver Graf <ograf@fga.de> - (interactive "_er") - (if (featurep 'offix) - (funcall (intern "offix-start-drag-internal") - event (buffer-substring-no-properties begin end)) - (error "OffiX functionality not compiled in."))) - - - -;;; Application-specific frame-management - -(defvar get-frame-for-buffer-default-frame-name nil - "The default frame to select; see doc of `get-frame-for-buffer'.") - -(defvar get-frame-for-buffer-default-instance-limit nil) - -(defun get-frame-name-for-buffer (buffer) - (let ((mode (and (get-buffer buffer) - (save-excursion (set-buffer buffer) - major-mode)))) - (or (get mode 'frame-name) - get-frame-for-buffer-default-frame-name))) - -(defun get-frame-for-buffer-make-new-frame (buffer &optional frame-name plist) - (let* ((fr (make-frame plist)) - (w (frame-root-window fr))) - ;; - ;; Make the one buffer being displayed in this newly created - ;; frame be the buffer of interest, instead of something - ;; random, so that it won't be shown in two-window mode. - ;; Avoid calling switch-to-buffer here, since that's something - ;; people might want to call this routine from. - ;; - ;; (If the root window doesn't have a buffer, then that means - ;; there is more than one window on the frame, which can only - ;; happen if the user has done something funny on the frame- - ;; creation-hook. If that's the case, leave it alone.) - ;; - (if (window-buffer w) - (set-window-buffer w buffer)) - fr)) - -(defun get-frame-for-buffer-noselect (buffer - &optional not-this-window-p on-frame) - "Return a frame in which to display BUFFER. -This is a subroutine of `get-frame-for-buffer' (which see)." - (let (name limit) - (cond - ((or on-frame (eq (selected-window) (minibuffer-window))) - ;; don't switch frames if a frame was specified, or to list - ;; completions from the minibuffer, etc. - nil) - - ((setq name (get-frame-name-for-buffer buffer)) - ;; - ;; This buffer's mode expressed a preference for a frame of a particular - ;; name. That always takes priority. - ;; - (let ((limit (get name 'instance-limit)) - (defaults (get name 'frame-defaults)) - (matching-frames '()) - frames frame already-visible) - ;; Sort the list so that iconic frames will be found last. They - ;; will be used too, but mapped frames take precedence. And - ;; fully visible frames come before occluded frames. - ;; Hidden frames come after really visible ones - (setq frames - (sort (frame-list) - #'(lambda (s1 s2) - (cond ((frame-totally-visible-p s2) - nil) - ((not (frame-visible-p s2)) - (frame-visible-p s1)) - ((eq (frame-visible-p s2) 'hidden) - (eq (frame-visible-p s1) t )) - ((not (frame-totally-visible-p s2)) - (and (frame-visible-p s1) - (frame-totally-visible-p s1))))))) - ;; but the selected frame should come first, even if it's occluded, - ;; to minimize thrashing. - (setq frames (cons (selected-frame) - (delq (selected-frame) frames))) - - (setq name (symbol-name name)) - (while frames - (setq frame (car frames)) - (if (equal name (frame-name frame)) - (if (get-buffer-window buffer frame) - (setq already-visible frame - frames nil) - (setq matching-frames (cons frame matching-frames)))) - (setq frames (cdr frames))) - (cond (already-visible - already-visible) - ((or (null matching-frames) - (eq limit 0) ; means create with reckless abandon - (and limit (< (length matching-frames) limit))) - (get-frame-for-buffer-make-new-frame - buffer - name - (alist-to-plist (acons 'name name - (plist-to-alist defaults))))) - (t - ;; do not switch any of the window/buffer associations in an - ;; existing frame; this function only picks a frame; the - ;; determination of which windows on it get reused is up to - ;; display-buffer itself. -;; (or (window-dedicated-p (selected-window)) -;; (switch-to-buffer buffer)) - (car matching-frames))))) - - ((setq limit get-frame-for-buffer-default-instance-limit) - ;; - ;; This buffer's mode did not express a preference for a frame of a - ;; particular name, but the user wants a new frame rather than - ;; reusing the existing one. - (let* ((defname - (or (plist-get default-frame-plist 'name) - default-frame-name)) - (frames - (sort (filtered-frame-list #'(lambda (x) - (or (frame-visible-p x) - (frame-iconified-p x)))) - #'(lambda (s1 s2) - (cond ((and (frame-visible-p s1) - (not (frame-visible-p s2)))) - ((and (eq (frame-visible-p s1) t) - (eq (frame-visible-p s2) 'hidden))) - ((and (frame-visible-p s2) - (not (frame-visible-p s1))) - nil) - ((and (equal (frame-name s1) defname) - (not (equal (frame-name s2) defname)))) - ((and (equal (frame-name s2) defname) - (not (equal (frame-name s1) defname))) - nil) - ((frame-totally-visible-p s2) - nil) - (t)))))) - ;; put the selected frame last. The user wants a new frame, - ;; so don't reuse the existing one unless forced to. - (setq frames (append (delq (selected-frame) frames) (list frames))) - (if (or (eq limit 0) ; means create with reckless abandon - (< (length frames) limit)) - (get-frame-for-buffer-make-new-frame buffer) - (car frames)))) - - (t - ;; - ;; This buffer's mode did not express a preference for a frame of a - ;; particular name. So try to find a frame already displaying this - ;; buffer. - ;; - (let ((w (or (get-buffer-window buffer 'visible) ; check visible first - (get-buffer-window buffer 0)))) ; then iconic - (cond ((null w) - ;; It's not in any window - return nil, meaning no frame has - ;; preference. - nil) - ((and not-this-window-p - (eq (selected-frame) (window-frame w))) - ;; It's in a window, but on this frame, and we have been - ;; asked to pick another window. Return nil, meaning no - ;; frame has preference. - nil) - (t - ;; Otherwise, return the frame of the buffer's window. - (window-frame w)))))))) - - -;; The pre-display-buffer-function is called for effect, so this needs to -;; actually select the frame it wants. Fdisplay_buffer() takes notice of -;; changes to the selected frame. -(defun get-frame-for-buffer (buffer &optional not-this-window-p on-frame) - "Select and return a frame in which to display BUFFER. -Normally, the buffer will simply be displayed in the current frame. -But if the symbol naming the major-mode of the buffer has a 'frame-name -property (which should be a symbol), then the buffer will be displayed in -a frame of that name. If there is no frame of that name, then one is -created. - -If the major-mode doesn't have a 'frame-name property, then the frame -named by `get-frame-for-buffer-default-frame-name' will be used. If -that is nil (the default) then the currently selected frame will used. - -If the frame-name symbol has an 'instance-limit property (an integer) -then each time a buffer of the mode in question is displayed, a new frame -with that name will be created, until there are `instance-limit' of them. -If instance-limit is 0, then a new frame will be created each time. - -If a buffer is already displayed in a frame, then `instance-limit' is -ignored, and that frame is used. - -If the frame-name symbol has a 'frame-defaults property, then that is -prepended to the `default-frame-plist' when creating a frame for the -first time. - -This function may be used as the value of `pre-display-buffer-function', -to cause the display-buffer function and its callers to exhibit the above -behavior." - (let ((frame (get-frame-for-buffer-noselect - buffer not-this-window-p on-frame))) - (if (not (eq frame (selected-frame))) - frame - (select-frame frame) - (or (frame-visible-p frame) - ;; If the frame was already visible, just focus on it. - ;; If it wasn't visible (it was just created, or it used - ;; to be iconified) then uniconify, raise, etc. - (make-frame-visible frame)) - frame))) - -(defun frames-of-buffer (&optional buffer visible-only) - "Return list of frames that BUFFER is currently being displayed on. -If the buffer is being displayed on the currently selected frame, that frame -is first in the list. VISIBLE-ONLY will only list non-iconified frames." - (let ((list (windows-of-buffer buffer)) - (cur-frame (selected-frame)) - next-frame frames save-frame) - - (while list - (if (memq (setq next-frame (window-frame (car list))) - frames) - nil - (if (eq cur-frame next-frame) - (setq save-frame next-frame) - (and - (or (not visible-only) - (frame-visible-p next-frame)) - (setq frames (append frames (list next-frame)))))) - (setq list (cdr list))) - - (if save-frame - (append (list save-frame) frames) - frames))) - -(defcustom temp-buffer-shrink-to-fit nil - "*When non-nil resize temporary output buffers to minimize blank lines." - :type 'boolean - :group 'frames) - -(defcustom temp-buffer-max-height .5 - "*Proportion of frame to use for temp windows." - :type 'number - :group 'frames) - -(defun show-temp-buffer-in-current-frame (buffer) - "For use as the value of temp-buffer-show-function: -always displays the buffer in the current frame, regardless of the behavior -that would otherwise be introduced by the `pre-display-buffer-function', which -is normally set to `get-frame-for-buffer' (which see)." - (let ((pre-display-buffer-function nil)) ; turn it off, whatever it is - (let ((window (display-buffer buffer))) - (if (not (eq (last-nonminibuf-frame) (window-frame window))) - ;; only the pre-display-buffer-function should ever do this. - (error "display-buffer switched frames on its own!!")) - (setq minibuffer-scroll-window window) - (set-window-start window 1) ; obeys narrowing - (set-window-point window 1) - (when temp-buffer-shrink-to-fit - (let* ((temp-window-size (round (* temp-buffer-max-height - (frame-height (window-frame window))))) - (size (window-displayed-height window))) - (when (< size temp-window-size) - (enlarge-window (- temp-window-size size) nil window))) - (shrink-window-if-larger-than-buffer window)) - nil))) - -(setq pre-display-buffer-function 'get-frame-for-buffer) -(setq temp-buffer-show-function 'show-temp-buffer-in-current-frame) - - -;; from Bob Weiner <bweiner@pts.mot.com>, modified by Ben Wing -(defun delete-other-frames (&optional frame) - "Delete all but FRAME (or the selected frame)." - (interactive) - (mapc 'delete-frame (delq (or frame (selected-frame)) (frame-list)))) - -;; By adding primitives to directly access the window hierarchy, -;; we can move many functions into Lisp. We do it this way -;; because the implementations are simpler in Lisp, and because -;; new functions like this can be added without requiring C -;; additions. - -(defun frame-utmost-window-2 (window position left-right-p major-end-p - minor-end-p) - ;; LEFT-RIGHT-P means we're looking for the leftmost or rightmost - ;; window, instead of the highest or lowest. In this case, we - ;; say that the "major axis" goes left-to-right instead of top-to- - ;; bottom. The "minor axis" always goes perpendicularly. - ;; - ;; If MAJOR-END-P is t, we're looking for a windows that abut the - ;; end (i.e. right or bottom) of the major axis, instead of the - ;; start. - ;; - ;; If MINOR-END-P is t, then we want to start counting from the - ;; end of the minor axis instead of the beginning. - ;; - ;; Here's the general idea: Imagine we're trying to count the number - ;; of windows that abut the top; call this function foo(). So, we - ;; start with the root window. If this is a vertical combination - ;; window, then foo() applied to the root window is the same as - ;; foo() applied to the first child. If the root is a horizontal - ;; combination window, then foo() applied to the root is the - ;; same as the sum of foo() applied to each of the children. - ;; Otherwise, the root window is a leaf window, and foo() is 1. - ;; Now it's clear that, each time foo() encounters a leaf window, - ;; it's encountering a different window that abuts the top. - ;; With a little examining, you can see that foo encounters the - ;; top-abutting windows in order from left to right. We can - ;; modify foo() to return the nth top-abutting window by simply - ;; keeping a global variable that is decremented each time - ;; foo() encounters a leaf window and would return 1. If the - ;; global counter gets to zero, we've encountered the window - ;; we were looking for, so we exit right away using a `throw'. - ;; Otherwise, we make sure that all normal paths return nil. - - (let (child) - (cond ((setq child (if left-right-p - (window-first-hchild window) - (window-first-vchild window))) - (if major-end-p - (while (window-next-child child) - (setq child (window-next-child child)))) - (frame-utmost-window-2 child position left-right-p major-end-p - minor-end-p)) - ((setq child (if left-right-p - (window-first-vchild window) - (window-first-hchild window))) - (if minor-end-p - (while (window-next-child child) - (setq child (window-next-child child)))) - (while child - (frame-utmost-window-2 child position left-right-p major-end-p - minor-end-p) - (setq child (if minor-end-p - (window-previous-child child) - (window-next-child child)))) - nil) - (t - (setcar position (1- (car position))) - (if (= (car position) 0) - (throw 'fhw-exit window) - nil))))) - -(defun frame-utmost-window-1 (frame position left-right-p major-end-p) - (let (minor-end-p) - (or frame (setq frame (selected-frame))) - (or position (setq position 0)) - (if (>= position 0) - (setq position (1+ position)) - (setq minor-end-p t) - (setq position (- position))) - (catch 'fhw-exit - ;; we use a cons here as a simple form of call-by-reference. - ;; scheme has "boxes" for the same purpose. - (frame-utmost-window-2 (frame-root-window frame) (list position) - left-right-p major-end-p minor-end-p)))) - - -(defun frame-highest-window (&optional frame position) - "Return the highest window on FRAME which is at POSITION. -If omitted, FRAME defaults to the currently selected frame. -POSITION is used to distinguish between multiple windows that abut - the top of the frame: 0 means the leftmost window abutting the - top of the frame, 1 the next-leftmost, etc. POSITION can also - be less than zero: -1 means the rightmost window abutting the - top of the frame, -2 the next-rightmost, etc. -If omitted, POSITION defaults to 0, i.e. the leftmost highest window. -If there is no window at the given POSITION, return nil." - (frame-utmost-window-1 frame position nil nil)) - -(defun frame-lowest-window (&optional frame position) - "Return the lowest window on FRAME which is at POSITION. -If omitted, FRAME defaults to the currently selected frame. -POSITION is used to distinguish between multiple windows that abut - the bottom of the frame: 0 means the leftmost window abutting the - bottom of the frame, 1 the next-leftmost, etc. POSITION can also - be less than zero: -1 means the rightmost window abutting the - bottom of the frame, -2 the next-rightmost, etc. -If omitted, POSITION defaults to 0, i.e. the leftmost lowest window. -If there is no window at the given POSITION, return nil." - (frame-utmost-window-1 frame position nil t)) - -(defun frame-leftmost-window (&optional frame position) - "Return the leftmost window on FRAME which is at POSITION. -If omitted, FRAME defaults to the currently selected frame. -POSITION is used to distinguish between multiple windows that abut - the left edge of the frame: 0 means the highest window abutting the - left edge of the frame, 1 the next-highest, etc. POSITION can also - be less than zero: -1 means the lowest window abutting the - left edge of the frame, -2 the next-lowest, etc. -If omitted, POSITION defaults to 0, i.e. the highest leftmost window. -If there is no window at the given POSITION, return nil." - (frame-utmost-window-1 frame position t nil)) - -(defun frame-rightmost-window (&optional frame position) - "Return the rightmost window on FRAME which is at POSITION. -If omitted, FRAME defaults to the currently selected frame. -POSITION is used to distinguish between multiple windows that abut - the right edge of the frame: 0 means the highest window abutting the - right edge of the frame, 1 the next-highest, etc. POSITION can also - be less than zero: -1 means the lowest window abutting the - right edge of the frame, -2 the next-lowest, etc. -If omitted, POSITION defaults to 0, i.e. the highest rightmost window. -If there is no window at the given POSITION, return nil." - (frame-utmost-window-1 frame position t t)) - - - -;; frame properties. - -(defun set-frame-property (frame prop val) - "Set property PROP of FRAME to VAL. See `set-frame-properties'." - (set-frame-properties frame (list prop val))) - -(defun frame-height (&optional frame) - "Return number of lines available for display on FRAME." - (frame-property frame 'height)) - -(defun frame-width (&optional frame) - "Return number of columns available for display on FRAME." - (frame-property frame 'width)) - -(put 'cursor-color 'frame-property-alias [text-cursor background]) -(put 'modeline 'frame-property-alias 'has-modeline-p) - - -(provide 'frame) - -;;; frame.el ends here
--- a/lisp/prim/glyphs.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,682 +0,0 @@ -;;; glyphs.el --- Lisp interface to C glyphs - -;; Copyright (C) 1994, 1997 Free Software Foundation, Inc. -;; Copyright (C) 1995, 1996 Ben Wing. - -;; Author: Chuck Thompson <cthomp@cs.uiuc.edu>, Ben Wing <wing@666.com> -;; Maintainer: XEmacs Development Team -;; Keywords: extensions, internal - -;; 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, 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: Not in FSF. - -;;; Commentary: - -;;; Code: - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; font specifiers - -(defun make-image-specifier (spec-list) - "Create a new `image' specifier object with the given specification list. -SPEC-LIST can be a list of specifications (each of which is a cons of a -locale and a list of instantiators), a single instantiator, or a list -of instantiators. See `make-specifier' for more information about -specifiers." - (make-specifier-and-init 'image spec-list)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; glyphs - -(defconst built-in-glyph-specifiers - '(image contrib-p baseline) - "A list of the built-in face properties that are specifiers.") - -(defun glyph-property (glyph property &optional locale) - "Return GLYPH's value of the given PROPERTY. - -If LOCALE is omitted, the GLYPH's actual value for PROPERTY will be - returned. For built-in properties, this will be a specifier object - of a type appropriate to the property (e.g. a font or color - specifier). For other properties, this could be anything. - -If LOCALE is supplied, then instead of returning the actual value, - the specification(s) for the given locale or locale type will - be returned. This will only work if the actual value of - PROPERTY is a specifier (this will always be the case for built-in - properties, but not or not may apply to user-defined properties). - If the actual value of PROPERTY is not a specifier, this value - will simply be returned regardless of LOCALE. - -The return value will be a list of instantiators (e.g. strings - specifying a font or color name), or a list of specifications, each - of which is a cons of a locale and a list of instantiators. - Specifically, if LOCALE is a particular locale (a buffer, window, - frame, device, or 'global), a list of instantiators for that locale - will be returned. Otherwise, if LOCALE is a locale type (one of - the symbols 'buffer, 'window, 'frame, 'device, 'device-class, or - 'device-type), the specifications for all locales of that type will - be returned. Finally, if LOCALE is 'all, the specifications for all - locales of all types will be returned. - -The specifications in a specifier determine what the value of - PROPERTY will be in a particular \"domain\" or set of circumstances, - which is typically a particular Emacs window along with the buffer - it contains and the frame and device it lies within. The value - is derived from the instantiator associated with the most specific - locale (in the order buffer, window, frame, device, and 'global) - that matches the domain in question. In other words, given a domain - (i.e. an Emacs window, usually), the specifier for PROPERTY will first - be searched for a specification whose locale is the buffer contained - within that window; then for a specification whose locale is the window - itself; then for a specification whose locale is the frame that the - window is contained within; etc. The first instantiator that is - valid for the domain (usually this means that the instantiator is - recognized by the device [i.e. the X server or TTY device] that the - domain is on. The function `glyph-property-instance' actually does - all this, and is used to determine how to display the glyph. - -See `set-glyph-property' for the built-in property-names." - (check-argument-type 'glyphp glyph) - (let ((value (get glyph property))) - (if (and locale - (or (memq property built-in-glyph-specifiers) - (specifierp value))) - (setq value (specifier-specs value locale))) - value)) - -(defun convert-glyph-property-into-specifier (glyph property) - "Convert PROPERTY on GLYPH into a specifier, if it's not already." - (check-argument-type 'glyphp glyph) - (let ((specifier (get glyph property))) - ;; if a user-property does not have a specifier but a - ;; locale was specified, put a specifier there. - ;; If there was already a value there, convert it to a - ;; specifier with the value as its 'global instantiator. - (if (not (specifierp specifier)) - (let ((new-specifier (make-specifier 'generic))) - (if (or (not (null specifier)) - ;; make sure the nil returned from `get' wasn't - ;; actually the value of the property - (null (get glyph property t))) - (add-spec-to-specifier new-specifier specifier)) - (setq specifier new-specifier) - (put glyph property specifier))))) - -(defun glyph-property-instance (glyph property - &optional domain default no-fallback) - "Return the instance of GLYPH's PROPERTY in the specified DOMAIN. - -Under most circumstances, DOMAIN will be a particular window, - and the returned instance describes how the specified property - actually is displayed for that window and the particular buffer - in it. Note that this may not be the same as how the property - appears when the buffer is displayed in a different window or - frame, or how the property appears in the same window if you - switch to another buffer in that window; and in those cases, - the returned instance would be different. - -DOMAIN defaults to the selected window if omitted. - -DOMAIN can be a frame or device, instead of a window. The value - returned for a such a domain is used in special circumstances - when a more specific domain does not apply; for example, a frame - value might be used for coloring a toolbar, which is conceptually - attached to a frame rather than a particular window. The value - is also useful in determining what the value would be for a - particular window within the frame or device, if it is not - overridden by a more specific specification. - -If PROPERTY does not name a built-in property, its value will - simply be returned unless it is a specifier object, in which case - it will be instanced using `specifier-instance'. - -Optional arguments DEFAULT and NO-FALLBACK are the same as in - `specifier-instance'." - (check-argument-type 'glyphp glyph) - (let ((value (get glyph property))) - (if (specifierp value) - (setq value (specifier-instance value domain default no-fallback))) - value)) - -(defun set-glyph-property (glyph property value &optional locale tag-set - how-to-add) - "Change a property of a GLYPH. - -NOTE: If you want to remove a property from a glyph, use - `remove-glyph-property' rather than attempting to set a value of nil - for the property. - -For built-in properties, the actual value of the property is a - specifier and you cannot change this; but you can change the - specifications within the specifier, and that is what this function - will do. For user-defined properties, you can use this function - to either change the actual value of the property or, if this value - is a specifier, change the specifications within it. - -If PROPERTY is a built-in property, the specifications to be added to - this property can be supplied in many different ways: - - -- If VALUE is a simple instantiator (e.g. a string naming a font or - color) or a list of instantiators, then the instantiator(s) will - be added as a specification of the property for the given LOCALE - (which defaults to 'global if omitted). - -- If VALUE is a list of specifications (each of which is a cons of - a locale and a list of instantiators), then LOCALE must be nil - (it does not make sense to explicitly specify a locale in this - case), and specifications will be added as given. - -- If VALUE is a specifier (as would be returned by `glyph-property' - if no LOCALE argument is given), then some or all of the - specifications in the specifier will be added to the property. - In this case, the function is really equivalent to - `copy-specifier' and LOCALE has the same semantics (if it is - a particular locale, the specification for the locale will be - copied; if a locale type, specifications for all locales of - that type will be copied; if nil or 'all, then all - specifications will be copied). - -HOW-TO-ADD should be either nil or one of the symbols 'prepend, - 'append, 'remove-tag-set-prepend, 'remove-tag-set-append, 'remove-locale, - 'remove-locale-type, or 'remove-all. See `copy-specifier' and - `add-spec-to-specifier' for a description of what each of - these means. Most of the time, you do not need to worry about - this argument; the default behavior usually is fine. - -In general, it is OK to pass an instance object (e.g. as returned - by `glyph-property-instance') as an instantiator in place of - an actual instantiator. In such a case, the instantiator used - to create that instance object will be used (for example, if - you set a font-instance object as the value of the 'font - property, then the font name used to create that object will - be used instead). If some cases, however, doing this - conversion does not make sense, and this will be noted in - the documentation for particular types of instance objects. - -If PROPERTY is not a built-in property, then this function will - simply set its value if LOCALE is nil. However, if LOCALE is - given, then this function will attempt to add VALUE as the - instantiator for the given LOCALE, using `add-spec-to-specifier'. - If the value of the property is not a specifier, it will - automatically be converted into a 'generic specifier. - - -The following symbols have predefined meanings: - - image The image used to display the glyph. - - baseline Percent above baseline that glyph is to be - displayed. - - contrib-p Whether the glyph contributes to the - height of the line it's on. - - face Face of this glyph (*not* a specifier)." - (check-argument-type 'glyphp glyph) - (if (memq property built-in-glyph-specifiers) - (set-specifier (get glyph property) value locale tag-set how-to-add) - - ;; This section adds user defined properties. - (if (not locale) - (put glyph property value) - (convert-glyph-property-into-specifier glyph property) - (add-spec-to-specifier (get glyph property) value locale tag-set - how-to-add))) - value) - -(defun remove-glyph-property (glyph property &optional locale tag-set exact-p) - "Remove a property from a glyph. -For built-in properties, this is analogous to `remove-specifier'. -See `remove-specifier' for the meaning of the LOCALE, TAG-SET, and EXACT-P - arguments." - (or locale (setq locale 'all)) - (if (memq property built-in-glyph-specifiers) - (remove-specifier (glyph-property glyph property) locale tag-set exact-p) - (if (eq locale 'all) - (remprop glyph property) - (convert-glyph-property-into-specifier glyph property) - (remove-specifier (glyph-property glyph property) locale tag-set - exact-p)))) - -(defun glyph-face (glyph) - "Return the face of GLYPH." - (glyph-property glyph 'face)) - -(defun set-glyph-face (glyph face) - "Change the face of GLYPH to FACE." -; (interactive (glyph-interactive "face")) - (set-glyph-property glyph 'face face)) - -(defun glyph-image (glyph &optional locale) - "Return the image of the given glyph, or nil if it is unspecified. - -LOCALE may be a locale (the instantiators for that particular locale - will be returned), a locale type (the specifications for all locales - of that type will be returned), 'all (all specifications will be - returned), or nil (the actual specifier object will be returned). - -See `glyph-property' for more information." - (glyph-property glyph 'image locale)) - -(defun glyph-image-instance (glyph &optional domain default no-fallback) - "Return the instance of the given glyph's image in the given domain. - -Normally DOMAIN will be a window or nil (meaning the selected window), - and an instance object describing how the image appears in that - particular window and buffer will be returned. - -See `glyph-property-instance' for more information." - (glyph-property-instance glyph 'image domain default no-fallback)) - -(defun set-glyph-image (glyph spec &optional locale tag-set how-to-add) - "Change the image of the given glyph. - -SPEC should be an instantiator (a string or vector; see - `image-specifier-p' for a description of possible values here), - a list of (possibly tagged) instantiators, an alist of specifications - (each mapping a locale to an instantiator list), or an image specifier - object. - -If SPEC is an alist, LOCALE must be omitted. If SPEC is a - specifier object, LOCALE can be a locale, a locale type, 'all, - or nil; see `copy-specifier' for its semantics. Otherwise LOCALE - specifies the locale under which the specified instantiator(s) - will be added, and defaults to 'global. - -See `set-glyph-property' for more information." - ; (interactive (glyph-interactive "image")) - (set-glyph-property glyph 'image spec locale tag-set how-to-add)) - -(defun glyph-contrib-p (glyph &optional locale) - "Return whether GLYPH contributes to its line height. - -LOCALE may be a locale (the instantiators for that particular locale - will be returned), a locale type (the specifications for all locales - of that type will be returned), 'all (all specifications will be - returned), or nil (the actual specifier object will be returned). - -See `glyph-property' for more information." - (glyph-property glyph 'contrib-p locale)) - -(defun glyph-contrib-p-instance (glyph &optional domain default no-fallback) - "Return the instance of the GLYPH's 'contrib-p property in the given domain. - -Normally DOMAIN will be a window or nil (meaning the selected window), - and an instance object describing what the 'contrib-p property is in - that particular window and buffer will be returned. - -See `glyph-property-instance' for more information." - (glyph-property-instance glyph 'contrib-p domain default no-fallback)) - -(defun set-glyph-contrib-p (glyph spec &optional locale tag-set how-to-add) - "Change the contrib-p of the given glyph. - -SPEC should be an instantiator (t or nil), a list of (possibly - tagged) instantiators, an alist of specifications (each mapping a - locale to an instantiator list), or a boolean specifier object. - -If SPEC is an alist, LOCALE must be omitted. If SPEC is a - specifier object, LOCALE can be a locale, a locale type, 'all, - or nil; see `copy-specifier' for its semantics. Otherwise LOCALE - specifies the locale under which the specified instantiator(s) - will be added, and defaults to 'global. - -See `set-glyph-property' for more information." - ; (interactive (glyph-interactive "contrib-p")) - (set-glyph-property glyph 'contrib-p spec locale tag-set how-to-add)) - -(defun glyph-baseline (glyph &optional locale) - "Return the baseline of the given glyph, or nil if it is unspecified. - -LOCALE may be a locale (the instantiators for that particular locale - will be returned), a locale type (the specifications for all locales - of that type will be returned), 'all (all specifications will be - returned), or nil (the actual specifier object will be returned). - -See `glyph-property' for more information." - (glyph-property glyph 'baseline locale)) - -(defun glyph-baseline-instance (glyph &optional domain default no-fallback) - "Return the instance of the given glyph's baseline in the given domain. - -Normally DOMAIN will be a window or nil (meaning the selected window), - and an integer or nil (specifying the baseline in that particular - window and buffer) will be returned. - -See `glyph-property-instance' for more information." - (glyph-property-instance glyph 'baseline domain default no-fallback)) - -(defun set-glyph-baseline (glyph spec &optional locale tag-set how-to-add) - "Change the baseline of the given glyph. - -SPEC should be an instantiator (an integer [a percentage above the - baseline of the line the glyph is on] or nil), a list of (possibly - tagged) instantiators, an alist of specifications (each mapping a - locale to an instantiator list), or a generic specifier object. - -If SPEC is an alist, LOCALE must be omitted. If SPEC is a - specifier object, LOCALE can be a locale, a locale type, 'all, - or nil; see `copy-specifier' for its semantics. Otherwise LOCALE - specifies the locale under which the specified instantiator(s) - will be added, and defaults to 'global. - -See `set-glyph-property' for more information." - ; (interactive (glyph-interactive "baseline")) - (set-glyph-property glyph 'baseline spec locale tag-set how-to-add)) - -(defun make-glyph (&optional spec-list type) - "Create a new `glyph' object of type TYPE. - -TYPE should be one of `buffer' (used for glyphs in an extent, the modeline, -the toolbar, or elsewhere in a buffer), `pointer' (used for the mouse-pointer), -or `icon' (used for a frame's icon), and defaults to `buffer'. - -SPEC-LIST is used to initialize the glyph's image. It is typically an -image instantiator (a string or a vector; see `image-specifier-p' for -a detailed description of the valid image instantiators), but can also -be a list of such instantiators (each one in turn is tried until an -image is successfully produced), a cons of a locale (frame, buffer, etc.) -and an instantiator, a list of such conses, or any other form accepted -by `canonicalize-spec-list'. See `make-specifier' for more information -about specifiers." - (let ((glyph (make-glyph-internal type))) - (and spec-list (set-glyph-image glyph spec-list)) - glyph)) - -(defun buffer-glyph-p (object) - "t if OBJECT is a glyph of type `buffer'." - (and (glyphp object) (eq 'buffer (glyph-type object)))) - -(defun pointer-glyph-p (object) - "t if OBJECT is a glyph of type `pointer'." - (and (glyphp object) (eq 'pointer (glyph-type object)))) - -(defun icon-glyph-p (object) - "t if OBJECT is a glyph of type `icon'." - (and (glyphp object) (eq 'icon (glyph-type object)))) - -(defun make-pointer-glyph (&optional spec-list) - "Create a new `pointer-glyph' object with the given specification list. - -This is equivalent to calling `make-glyph' and specifying a type of -`pointer'. - -SPEC-LIST is used to initialize the glyph's image. It is typically an -image instantiator (a string or a vector; see `image-specifier-p' for -a detailed description of the valid image instantiators), but can also -be a list of such instantiators (each one in turn is tried until an -image is successfully produced), a cons of a locale (frame, buffer, etc.) -and an instantiator, a list of such conses, or any other form accepted -by `canonicalize-spec-list'. See `make-specifier' for more information -about specifiers. - -You can also create a glyph with an empty SPEC-LIST and add image -instantiators afterwards using `set-glyph-image'." - (make-glyph spec-list 'pointer)) - -(defun make-icon-glyph (&optional spec-list) - "Create a new `icon-glyph' object with the given specification list. - -This is equivalent to calling `make-glyph' and specifying a type of -`icon'. - -SPEC-LIST is used to initialize the glyph's image. It is typically an -image instantiator (a string or a vector; see `image-specifier-p' for -a detailed description of the valid image instantiators), but can also -be a list of such instantiators (each one in turn is tried until an -image is successfully produced), a cons of a locale (frame, buffer, etc.) -and an instantiator, a list of such conses, or any other form accepted -by `canonicalize-spec-list'. See `make-specifier' for more information -about specifiers. - -You can also create a glyph with an empty SPEC-LIST and add image -instantiators afterwards using `set-glyph-image'." - (make-glyph spec-list 'icon)) - -(defun nothing-image-instance-p (object) - "t if OBJECT is an image instance of type `nothing'." - (and (image-instance-p object) (eq 'nothing (image-instance-type object)))) - -(defun text-image-instance-p (object) - "t if OBJECT is an image instance of type `text'." - (and (image-instance-p object) (eq 'text (image-instance-type object)))) - -(defun mono-pixmap-image-instance-p (object) - "t if OBJECT is an image instance of type `mono-pixmap'." - (and (image-instance-p object) (eq 'mono-pixmap - (image-instance-type object)))) - -(defun color-pixmap-image-instance-p (object) - "t if OBJECT is an image instance of type `color-pixmap'." - (and (image-instance-p object) (eq 'color-pixmap - (image-instance-type object)))) - -(defun pointer-image-instance-p (object) - "t if OBJECT is an image instance of type `pointer'." - (and (image-instance-p object) (eq 'pointer (image-instance-type object)))) - -(defun subwindow-image-instance-p (object) - "t if OBJECT is an image instance of type `subwindow'. -Subwindows are not implemented in this version of XEmacs." - (and (image-instance-p object) (eq 'subwindow (image-instance-type object)))) - -;;;;;;;;;; the built-in glyphs - -(defvar text-pointer-glyph (make-pointer-glyph) - "*The shape of the mouse-pointer when over text. -This is a glyph; use `set-glyph-image' to change it.") -(set-glyph-face text-pointer-glyph 'pointer) - -(defvar nontext-pointer-glyph (make-pointer-glyph) - "*The shape of the mouse-pointer when over a buffer, but not over text. -This is a glyph; use `set-glyph-image' to change it. -If unspecified in a particular domain, `text-pointer-glyph' is used.") -(set-glyph-face nontext-pointer-glyph 'pointer) - -(defvar modeline-pointer-glyph (make-pointer-glyph) - "*The shape of the mouse-pointer when over the modeline. -This is a glyph; use `set-glyph-image' to change it. -If unspecified in a particular domain, `nontext-pointer-glyph' is used.") -(set-glyph-face modeline-pointer-glyph 'pointer) - -(defvar selection-pointer-glyph (make-pointer-glyph) - "*The shape of the mouse-pointer when over a selectable text region. -This is a glyph; use `set-glyph-image' to change it. -If unspecified in a particular domain, `text-pointer-glyph' is used.") -(set-glyph-face selection-pointer-glyph 'pointer) - -(defvar busy-pointer-glyph (make-pointer-glyph) - "*The shape of the mouse-pointer when XEmacs is busy. -This is a glyph; use `set-glyph-image' to change it. -If unspecified in a particular domain, the pointer is not changed -when XEmacs is busy.") -(set-glyph-face busy-pointer-glyph 'pointer) - -(defvar toolbar-pointer-glyph (make-pointer-glyph) - "*The shape of the mouse-pointer when over a toolbar. -This is a glyph; use `set-glyph-image' to change it. -If unspecified in a particular domain, `nontext-pointer-glyph' is used.") -(set-glyph-face toolbar-pointer-glyph 'pointer) - -;; The following three are in C. -(if (featurep 'menubar) - (set-glyph-face menubar-pointer-glyph 'pointer)) -(if (featurep 'scrollbar) - (set-glyph-face scrollbar-pointer-glyph 'pointer)) -(set-glyph-face gc-pointer-glyph 'pointer) - -;; Now add the magic access/set behavior. - -(defun dontusethis-set-value-glyph-handler (sym args fun harg handler) - (error "Use `set-glyph-image' to set `%s'" sym)) -(defun dontusethis-make-unbound-glyph-handler (sym args fun harg handler) - (error "Can't `makunbound' `%s'" sym)) -(defun dontusethis-make-local-glyph-handler (sym args fun harg handler) - (error "Use `set-glyph-image' to make local values for `%s'" sym)) - -(defun define-constant-glyph (sym) - (dontusethis-set-symbol-value-handler - sym 'set-value - 'dontusethis-set-value-glyph-handler) - (dontusethis-set-symbol-value-handler - sym 'make-unbound - 'dontusethis-make-unbound-glyph-handler) - (dontusethis-set-symbol-value-handler - sym 'make-local - 'dontusethis-make-local-glyph-handler) - ;; Make frame properties magically work with glyph variables. - (put sym 'const-glyph-variable t)) - -(define-constant-glyph 'text-pointer-glyph) -(define-constant-glyph 'nontext-pointer-glyph) -(define-constant-glyph 'modeline-pointer-glyph) -(define-constant-glyph 'selection-pointer-glyph) -(define-constant-glyph 'busy-pointer-glyph) -(define-constant-glyph 'gc-pointer-glyph) -(define-constant-glyph 'toolbar-pointer-glyph) -(define-constant-glyph 'menubar-pointer-glyph) -(define-constant-glyph 'scrollbar-pointer-glyph) - -(define-constant-glyph 'octal-escape-glyph) -(define-constant-glyph 'control-arrow-glyph) -(define-constant-glyph 'invisible-text-glyph) -(define-constant-glyph 'hscroll-glyph) -(define-constant-glyph 'truncation-glyph) -(define-constant-glyph 'continuation-glyph) - -(define-constant-glyph 'frame-icon-glyph) - -;; backwards compatibility garbage - -(defun dontusethis-old-pointer-shape-handler (sym args fun harg handler) - (let ((value (car args))) - (if (null value) - (remove-specifier harg 'global) - (set-glyph-image (symbol-value harg) value)))) - -;; It might or might not be garbage, but it's rude. Make these -;; 'compatible instead of 'obsolete. -slb -(defun define-obsolete-pointer-glyph (old new) - (define-compatible-variable-alias old new) - (dontusethis-set-symbol-value-handler - old 'set-value 'dontusethis-old-pointer-shape-handler new)) - -;;; (defvar x-pointer-shape nil) -(define-obsolete-pointer-glyph 'x-pointer-shape 'text-pointer-glyph) - -;;; (defvar x-nontext-pointer-shape nil) -(define-obsolete-pointer-glyph 'x-nontext-pointer-shape 'nontext-pointer-glyph) - -;;; (defvar x-mode-pointer-shape nil) -(define-obsolete-pointer-glyph 'x-mode-pointer-shape 'modeline-pointer-glyph) - -;;; (defvar x-selection-pointer-shape nil) -(define-obsolete-pointer-glyph 'x-selection-pointer-shape - 'selection-pointer-glyph) - -;;; (defvar x-busy-pointer-shape nil) -(define-obsolete-pointer-glyph 'x-busy-pointer-shape 'busy-pointer-glyph) - -;;; (defvar x-gc-pointer-shape nil) -(define-obsolete-pointer-glyph 'x-gc-pointer-shape 'gc-pointer-glyph) - -;;; (defvar x-toolbar-pointer-shape nil) -(define-obsolete-pointer-glyph 'x-toolbar-pointer-shape 'toolbar-pointer-glyph) - -;;;;;;;;;; initialization - -(defun init-glyphs () - ;; initialize default image types - (if (featurep 'x) - (set-console-type-image-conversion-list 'x - `(,@(if (featurep 'xpm) '(("\\.xpm\\'" [xpm :file nil] 2))) - ("\\.xbm\\'" [xbm :file nil] 2) - ,@(if (featurep 'xpm) '(("\\`/\\* XPM \\*/" [xpm :data nil] 2))) - ,@(if (featurep 'xface) '(("\\`X-Face:" [xface :data nil] 2))) - ,@(if (featurep 'gif) '(("\\.gif\\'" [gif :file nil] 2) - ("\\`GIF8[79]" [gif :data nil] 2))) - ,@(if (featurep 'jpeg) '(("\\.jpe?g\\'" [jpeg :file nil] 2))) - ;; all of the JFIF-format JPEG's that I've seen begin with - ;; the following. I have no idea if this is standard. - ,@(if (featurep 'jpeg) '(("\\`\377\330\377\340\000\020JFIF" - [jpeg :data nil] 2))) - ,@(if (featurep 'png) '(("\\.png\\'" [png :file nil] 2))) - ,@(if (featurep 'png) '(("\\`\211PNG" [png :data nil] 2))) - ("" [autodetect :data nil] 2)))) - ;; #### this should really be formatted-string, not string but we - ;; don't have it implemented yet - ;; - ;; #define could also mean a bitmap as well as a version 1 XPM. Who - ;; cares. We don't want the file contents getting converted to a - ;; string in either case which is why the entry is there. - (if (featurep 'tty) - (progn - (set-console-type-image-conversion-list - 'tty - '(("^#define" [string :data "[xpm]"]) - ("\\`X-Face:" [string :data "[xface]"]) - ("\\`/\\* XPM \\*/" [string :data "[xpm]"]) - ("\\`GIF87" [string :data "[gif]"]) - ("\\`\377\330\340\000\020JFIF" [string :data "[jpeg]"]) - ("" [string :data nil] 2) - ;; this last one is here for pointers and icons and such -- - ;; strings are not allowed so they will be ignored. - ("" [nothing]))) - - ;; finish initializing truncation glyph -- created internally - ;; because it has a built-in bitmap - (set-glyph-image truncation-glyph "$" 'global 'tty) - - ;; finish initializing continuation glyph -- created internally - ;; because it has a built-in bitmap - (set-glyph-image continuation-glyph "\\" 'global 'tty) - - ;; finish initializing hscroll glyph -- created internally - ;; because it has a built-in bitmap - (set-glyph-image hscroll-glyph "$" 'global 'tty))) - - (set-glyph-image octal-escape-glyph "\\") - (set-glyph-image control-arrow-glyph "^") - (set-glyph-image invisible-text-glyph " ...") - ;; (set-glyph-image hscroll-glyph "$") - - ;; finish initializing xemacs logo -- created internally because it - ;; has a built-in bitmap - (if (featurep 'xpm) - (set-glyph-image xemacs-logo - (concat "../etc/" - (if emacs-beta-version - "xemacs-beta.xpm" - "xemacs.xpm")) - 'global 'x)) - (cond ((featurep 'xpm) - (set-glyph-image frame-icon-glyph - (concat "../etc/" "xemacs-icon.xpm") - 'global 'x)) - ((featurep 'x) - (set-glyph-image frame-icon-glyph - (concat "../etc/" "xemacs-icon2.xbm") - 'global 'x))) - - (if (featurep 'tty) - (set-glyph-image xemacs-logo - "XEmacs <insert spiffy graphic logo here>" - 'global 'tty)) -) - -(init-glyphs) - -;;; glyphs.el ends here.
--- a/lisp/prim/gui.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,110 +0,0 @@ -;;; gui.el --- Basic GUI functions for XEmacs. - -;; Copyright (C) 1996 Ben Wing - -;; Maintainer: XEmacs Development Team -;; Keywords: internal - -;; 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, 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -(defcustom dialog-frame-plist '(width 60 height 20) - "Plist of frame properties for initially creating a dialog frame. -Properties specified here supersede the values given in -`default-frame-plist'." - :type '(repeat (group :inline t - (symbol :tag "Property") - (sexp :tag "Value"))) - :group 'frames) - -(defun make-dialog-frame (&optional props parent) - "Create a frame suitable for use as a dialog box. -The frame is made a child of PARENT (defaults to the selected frame), -and has additional properties PROPS, as well as `dialog-frame-plist'. -Normally it also has no modelines, menubars, or toolbars." - (or parent (setq parent (selected-frame))) - (let* ((ftop (frame-property parent 'top)) - (fleft (frame-property parent 'left)) - (fwidth (frame-pixel-width parent)) - (fheight (frame-pixel-height parent)) - (fonth (font-height (face-font 'default))) - (fontw (font-width (face-font 'default))) - (props (append props dialog-frame-plist)) - (dfheight (plist-get props 'height)) - (dfwidth (plist-get props 'width)) - ;; under FVWM at least, if I don't specify the initial position, - ;; it ends up always at (0, 0). xwininfo doesn't tell me - ;; that there are any program-specified position hints, so - ;; it must be an FVWM bug. So just be smashing and position - ;; in the center of the selected frame. - (frame (make-frame - (append props - `(popup ,parent initially-unmapped t - menubar-visible-p nil - has-modeline-p nil - default-toolbar-visible-p nil - modeline-shadow-thickness 0 - left ,(+ fleft (- (/ fwidth 2) - (/ (* dfwidth fontw) - 2))) - top ,(+ ftop (- (/ fheight 2) - (/ (* dfheight fonth) - 2)))))))) - (set-face-foreground 'modeline [default foreground] frame) - (set-face-background 'modeline [default background] frame) - (make-frame-visible frame) - frame)) - -(defvar gui-button-shadow-thickness 2) - -(defun gui-button-p (object) - "True if OBJECT is a GUI button." - (and (vectorp object) - (> (length object) 0) - (eq 'gui-button (aref object 0)))) - -(make-face 'gui-button-face "Face used for gui buttons") -(if (not (face-differs-from-default-p 'gui-button-face)) - (progn - (set-face-background 'gui-button-face "grey75") - (set-face-foreground 'gui-button-face "black"))) - -(defun make-gui-button (string &optional action user-data) - "Make a GUI button whose label is STRING and whose action is ACTION. -If the button is inserted in a buffer and then clicked on, and ACTION -is non-nil, ACTION will be called with one argument, USER-DATA." - (vector 'gui-button - (if (featurep 'xpm) - (xpm-button-create - string gui-button-shadow-thickness - (color-instance-name (face-foreground-instance 'gui-button-face)) - (color-instance-name (face-background-instance 'gui-button-face))) - (xbm-button-create string gui-button-shadow-thickness)) - action user-data)) - -(defun insert-gui-button (button &optional pos buffer) - "Insert GUI button BUTTON at POS in BUFFER." - (check-argument-type 'gui-button-p button) - (let ((annotation - (make-annotation (make-glyph (car (aref button 1))) - pos 'text buffer nil - (make-glyph (cadr (aref button 1))))) - (action (aref button 2))) - (and action - (progn - (set-annotation-action annotation action) - (set-annotation-data annotation (aref button 3))))))
--- a/lisp/prim/help-nomule.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,99 +0,0 @@ -;;; help-nomule.el --- Help functions when not in Mule - -;; Copyright (C) 1997 by Free Software Foundation, Inc. - -;; Maintainer: XEmacs Development Team -;; Keywords: help, internal - -;; 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: - -;; - -;;; Code: - -(defconst tutorial-supported-languages - '(("French" fr iso-8859-1) - ("German" de iso-8859-1) - ("Norwegian" no iso-8859-1) - ("Croatian" hr iso-8859-2)) - "Alist of supported languages in TUTORIAL files. -Add languages here, as more are translated.") - -;; TUTORIAL arg is XEmacs addition -(defun help-with-tutorial (&optional tutorial language) - "Select the XEmacs learn-by-doing tutorial. -Optional arg TUTORIAL specifies the tutorial file; default is \"TUTORIAL\". -With a prefix argument, choose the language." - (interactive "i\nP") - (or tutorial - (setq tutorial "TUTORIAL")) - (when (and language (consp language)) - (let ((completion-ignore-case t)) - (setq language (assoc (completing-read "Language: " - tutorial-supported-languages - nil t) - tutorial-supported-languages)))) - (when language - (setq tutorial (format "%s.%s" tutorial (cadr language)))) - (let ((file (expand-file-name tutorial "~"))) - (delete-other-windows) - (let ((buffer (or (get-file-buffer file) - (create-file-buffer file))) - (window-configuration (current-window-configuration))) - (condition-case error-data - (progn - (switch-to-buffer buffer) - (setq buffer-file-name file) - (setq default-directory (expand-file-name "~/")) - (setq buffer-auto-save-file-name nil) - ;; Because of non-Mule users, TUTORIALs are not coded - ;; independently, so we must guess the coding according to - ;; the language. - (let ((coding-system-for-read (nth 2 language))) - (insert-file-contents (expand-file-name tutorial - data-directory))) - (goto-char (point-min)) - (search-forward "\n<<") - (delete-region (point-at-bol) (point-at-eol)) - (let ((n (- (window-height (selected-window)) - (count-lines (point-min) (point)) - 6))) - (if (< n 12) - (newline n) - ;; Some people get confused by the large gap. - (newline (/ n 2)) - (insert "[Middle of page left blank for didactic purposes. " - "Text continues below]") - (newline (- n (/ n 2))))) - (goto-char (point-min)) - (set-buffer-modified-p nil)) - ;; TUTORIAL was not found: kill the buffer and restore the - ;; window configuration. - (file-error (kill-buffer buffer) - (set-window-configuration window-configuration) - ;; Now, signal the error - (signal (car error-data) (cdr error-data))))))) - - -(provide 'help-nomule) - -;;; help-nomule.el ends here \ No newline at end of file
--- a/lisp/prim/help.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1328 +0,0 @@ -;;; help.el --- help commands for XEmacs. - -;; Copyright (C) 1985, 1986, 1992, 1993, 1994 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: help, internal - -;; 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, 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: FSF 19.30. - -;;; Commentary: - -;; This code implements XEmacs's on-line help system, the one invoked by -;;`M-x help-for-help'. - -;; 06/11/1997 -- Converted to use char-after instead of broken -;; following-char. -slb - -;;; Code: - -;#### FSFmacs -;; Get the macro make-help-screen when this is compiled, -;; or run interpreted, but not when the compiled code is loaded. -;(eval-when-compile (require 'help-macro)) - -(defgroup help-appearance nil - "Appearance of help buffers" - :group 'help) - -(defvar help-map (let ((map (make-sparse-keymap))) - (set-keymap-name map 'help-map) - (set-keymap-prompt - map (purecopy (gettext "(Type ? for further options)"))) - map) - "Keymap for characters following the Help key.") - -;; global-map definitions moved to keydefs.el -(fset 'help-command help-map) - -(define-key help-map (vector help-char) 'help-for-help) -(define-key help-map "?" 'help-for-help) -(define-key help-map 'help 'help-for-help) - -(define-key help-map "\C-l" 'describe-copying) ; on \C-c in FSFmacs -(define-key help-map "\C-d" 'describe-distribution) -(define-key help-map "\C-w" 'describe-no-warranty) -(define-key help-map "a" 'hyper-apropos) ; 'command-apropos in FSFmacs -(define-key help-map "A" 'command-apropos) - -(define-key help-map "b" 'describe-bindings) -(define-key help-map "B" 'describe-beta) -(define-key help-map "\C-p" 'describe-pointer) - -(define-key help-map "C" 'customize) -(define-key help-map "c" 'describe-key-briefly) -(define-key help-map "k" 'describe-key) - -(define-key help-map "d" 'describe-function) -(define-key help-map "e" 'describe-last-error) -(define-key help-map "f" 'describe-function) - -(define-key help-map "F" 'xemacs-local-faq) - -;;; Setup so Hyperbole can be autoloaded from a key. -;;; Choose a key on which to place the Hyperbole menus. -;;; For most people this key binding will work and will be equivalent -;;; to {C-h h}. -;;; -(or (where-is-internal 'hyperbole) - (where-is-internal 'hui:menu) - (define-key help-map "h" 'hyperbole)) -(autoload 'hyperbole "hsite" "Hyperbole info manager menus." t) - -(define-key help-map "i" 'info) -(define-key help-map '(control i) 'Info-query) -;; FSFmacs has Info-goto-emacs-command-node on C-f, no binding -;; for Info-elisp-ref -(define-key help-map '(control c) 'Info-goto-emacs-command-node) -(define-key help-map '(control k) 'Info-goto-emacs-key-command-node) -(define-key help-map '(control f) 'Info-elisp-ref) - -(define-key help-map "l" 'view-lossage) - -(define-key help-map "m" 'describe-mode) - -(define-key help-map "\C-n" 'view-emacs-news) -(define-key help-map "n" 'view-emacs-news) - -(define-key help-map "p" 'finder-by-keyword) -(autoload 'finder-by-keyword "finder" - "Find packages matching a given keyword." t) - -(define-key help-map "s" 'describe-syntax) - -(define-key help-map "t" 'help-with-tutorial) - -(define-key help-map "w" 'where-is) - -(define-key help-map "v" 'describe-variable) - -(if (fboundp 'view-last-error) - (define-key help-map "e" 'view-last-error)) - - -(define-key help-map "q" 'help-quit) - -;#### This stuff was an attempt to have font locking and hyperlinks in the -;help buffer, but it doesn't really work. Some of this stuff comes from -;FSF Emacs; but the FSF Emacs implementation is rather broken, as usual. -;What needs to happen is this: -; -; -- we probably need a "hyperlink mode" from which help-mode is derived. -; -- this means we probably need multiple inheritance of modes! -; Thankfully this is not hard to implement; we already have the -; ability for a keymap to have multiple parents. However, we'd -; have to define any multiply-inherited-from modes using a standard -; `define-mode' construction instead of manually doing it, because -; we don't want each guy calling `kill-all-local-variables' and -; messing up the previous one. -; -- we need to scan the buffer ourselves (not from font-lock, because -; the user might not have font-lock enabled) and highlight only -; those words that are *documented* functions and variables (and -; probably excluding words without dashes in them unless enclosed -; in quotes, so that common words like "list" and "point" don't -; become hyperlinks. -; -- we should *not* use font-lock keywords like below. Instead we -; should add the font-lock stuff ourselves during the scanning phase, -; if font-lock is enabled in this buffer. - -;(defun help-follow-reference (event extent user-data) -; (let ((symbol (intern-soft (extent-string extent)))) -; (cond ((and symbol (fboundp symbol)) -; (describe-function symbol)) -; ((and symbol (boundp symbol)) -; (describe-variable symbol)) -; (t nil)))) - -;(defvar help-font-lock-keywords -; (let ((name-char "[-+a-zA-Z0-9_*]") (sym-char "[-+a-zA-Z0-9_:*]")) -; (list -; ;; -; ;; The symbol itself. -; (list (concat "\\`\\(" name-char "+\\)\\(:\\)?") -; '(1 (if (match-beginning 2) -; 'font-lock-function-name-face -; 'font-lock-variable-name-face) -; nil t)) -; ;; -; ;; Words inside `' which tend to be symbol names. -; (list (concat "`\\(" sym-char sym-char "+\\)'") -; 1 '(prog1 -; 'font-lock-reference-face -; (add-list-mode-item (match-beginning 1) -; (match-end 1) -; nil -; 'help-follow-reference)) -; t) -; ;; -; ;; CLisp `:' keywords as references. -; (list (concat "\\<:" sym-char "+\\>") 0 'font-lock-reference-face t))) -; "Default expressions to highlight in Help mode.") - -;(put 'help-mode 'font-lock-defaults '(help-font-lock-keywords)) - -(define-derived-mode help-mode view-major-mode "Help" - "Major mode for viewing help text. -Entry to this mode runs the normal hook `help-mode-hook'. -Commands: -\\{help-mode-map}" - ) - -(define-key help-mode-map "q" 'help-mode-quit) -(define-key help-mode-map "f" 'find-function-at-point) - -(defun describe-function-at-point () - "Describe directly the function at point in the other window." - (interactive) - (let ((symb (function-at-point))) - (when symb - (describe-function symb)))) -(defun describe-variable-at-point () - "Describe directly the variable at point in the other window." - (interactive) - (let ((symb (variable-at-point))) - (when symb - (describe-variable symb)))) -(defun help-next-symbol () - "Move point to the next quoted symbol." - (interactive) - (search-forward "`" nil t)) -(defun help-prev-symbol () - "Move point to the previous quoted symbol." - (interactive) - (search-backward "'" nil t)) -(define-key help-mode-map "d" 'describe-function-at-point) -(define-key help-mode-map "v" 'describe-variable-at-point) -(define-key help-mode-map [tab] 'help-next-symbol) -(define-key help-mode-map [(shift tab)] 'help-prev-symbol) - - -(defun help-mode-quit () - "Exits from help mode, possibly restoring the previous window configuration. -Bury the help buffer to the end of the buffer list." - (interactive) - (let ((buf (current-buffer))) - (cond ((frame-property (selected-frame) 'help-window-config) - (set-window-configuration - (frame-property (selected-frame) 'help-window-config)) - (set-frame-property (selected-frame) 'help-window-config nil)) - ((not (one-window-p)) - (delete-window))) - (bury-buffer buf))) - -(defun help-quit () - (interactive) - nil) - -;; This is a grody hack of the same genotype as `advertised-undo'; if the -;; bindings of Backspace and C-h are the same, we want the menubar to claim -;; that `info' in invoked with `C-h i', not `BS i'. - -(defun deprecated-help-command () - (interactive) - (if (eq 'help-command (key-binding "\C-h")) - (setq unread-command-event (character-to-event ?\C-h)) - (help-for-help))) - -;;(define-key global-map 'backspace 'deprecated-help-command) - -;; This function has been moved to help-nomule.el and mule-help.el. -;; TUTORIAL arg is XEmacs addition -;(defun help-with-tutorial (&optional tutorial) -; "Select the XEmacs learn-by-doing tutorial. -;Optional arg TUTORIAL specifies the tutorial file; default is \"TUTORIAL\"." -; (interactive) -; (if (null tutorial) -; (setq tutorial "TUTORIAL")) -; (let ((file (expand-file-name (concat "~/" tutorial)))) -; (delete-other-windows) -; (if (get-file-buffer file) -; (switch-to-buffer (get-file-buffer file)) -; (switch-to-buffer (create-file-buffer file)) -; (setq buffer-file-name file) -; (setq default-directory (expand-file-name "~/")) -; (setq buffer-auto-save-file-name nil) -; (insert-file-contents (expand-file-name tutorial data-directory)) -; (goto-char (point-min)) -; (search-forward "\n<<") -; (delete-region (point-at-bol) (point-at-eol)) -; (let ((n (- (window-height (selected-window)) -; (count-lines (point-min) (point)) -; 6))) -; (if (< n 12) -; (newline n) -; ;; Some people get confused by the large gap. -; (newline (/ n 2)) -; (insert "[Middle of page left blank for didactic purposes. " -; "Text continues below]") -; (newline (- n (/ n 2))))) -; (goto-char (point-min)) -; (set-buffer-modified-p nil)))) - -;; used by describe-key, describe-key-briefly, insert-key-binding, etc. - -(defun key-or-menu-binding (key &optional menu-flag) - "Return the command invoked by KEY. -Like `key-binding', but handles menu events and toolbar presses correctly. -KEY is any value returned by `next-command-event'. -MENU-FLAG is a symbol that should be set to T if KEY is a menu event, - or NIL otherwise" - (let (defn) - (and menu-flag (set menu-flag nil)) - ;; If the key typed was really a menu selection, grab the form out - ;; of the event object and intuit the function that would be called, - ;; and describe that instead. - (if (and (vectorp key) (= 1 (length key)) - (or (misc-user-event-p (aref key 0)) - (eq (car-safe (aref key 0)) 'menu-selection))) - (let ((event (aref key 0))) - (setq defn (if (eventp event) - (list (event-function event) (event-object event)) - (cdr event))) - (and menu-flag (set menu-flag t)) - (when (eq (car defn) 'eval) - (setq defn (car (cdr defn)))) - (when (eq (car-safe defn) 'call-interactively) - (setq defn (car (cdr defn)))) - (when (and (consp defn) (null (cdr defn))) - (setq defn (car defn)))) - ;; else - (setq defn (key-binding key))) - ;; kludge: if a toolbar button was pressed on, try to find the - ;; binding of the toolbar button. - (if (and (eq defn 'press-toolbar-button) - (vectorp key) - (button-press-event-p (aref key (1- (length key))))) - ;; wait for the button release. We're on shaky ground here ... - (let ((event (next-command-event)) - button) - (if (and (button-release-event-p event) - (event-over-toolbar-p event) - (eq 'release-and-activate-toolbar-button - (key-binding (vector event))) - (setq button (event-toolbar-button event))) - (toolbar-button-callback button) - ;; if anything went wrong, try returning the binding of - ;; the button-up event, of the original binding - (or (key-or-menu-binding (vector event)) - defn))) - ;; no toolbar kludge - defn) - )) - -(defun describe-key-briefly (key) - "Print the name of the function KEY invokes. KEY is a string." - (interactive "kDescribe key briefly: ") - (let (defn menup) - (setq defn (key-or-menu-binding key 'menup)) - (if (or (null defn) (integerp defn)) - (message "%s is undefined" (key-description key)) - ;; If it's a keyboard macro which trivially invokes another command, - ;; document that instead. - (if (or (stringp defn) (vectorp defn)) - (setq defn (or (key-binding defn) - defn))) - (let ((last-event (and (vectorp key) - (aref key (1- (length key)))))) - (message (if (or (button-press-event-p last-event) - (button-release-event-p last-event)) - (gettext "%s at that spot runs the command %s") - (gettext "%s runs the command %s")) - ;; This used to say 'This menu item' but it could also - ;; be a scrollbar event. We can't distinguish at the - ;; moment. - (if menup "This item" (key-description key)) - (if (symbolp defn) defn (prin1-to-string defn))))))) - -;; #### this is a horrible piece of shit function that should -;; not exist. In FSF 19.30 this function has gotten three times -;; as long and has tons and tons of dumb shit checking -;; special-display-buffer-names and such crap. I absolutely -;; refuse to insert that Ebolification here. I wanted to delete -;; this function entirely but Mly bitched. -;; -;; If your user-land code calls this function, rewrite it to -;; call with-displaying-help-buffer. - -(defun print-help-return-message (&optional function) - "Display or return message saying how to restore windows after help command. -Computes a message and applies the optional argument FUNCTION to it. -If FUNCTION is nil, applies `message' to it, thus printing it." - (and (not (get-buffer-window standard-output)) - (funcall - (or function 'message) - (concat - (substitute-command-keys - (if (one-window-p t) - (if pop-up-windows - (gettext "Type \\[delete-other-windows] to remove help window.") - (gettext "Type \\[switch-to-buffer] RET to remove help window.")) - (gettext "Type \\[switch-to-buffer-other-window] RET to restore the other window."))) - (substitute-command-keys - (gettext " \\[scroll-other-window] to scroll the help.")))))) - -(defcustom help-selects-help-window t - "*If nil, use the \"old Emacs\" behavior for Help buffers. -This just displays the buffer in another window, rather than selecting -the window." - :type 'boolean - :group 'help-appearance) - -;; Use this function for displaying help when C-h something is pressed -;; or in similar situations. Do *not* use it when you are displaying -;; a help message and then prompting for input in the minibuffer -- -;; this macro usually selects the help buffer, which is not what you -;; want in those situations. - -;;; ### Should really be a macro (as suggested above) to eliminate the -;;; requirement of caller to code a lambda form in THUNK -- mrb -(defun with-displaying-help-buffer (thunk) - (let ((winconfig (current-window-configuration)) - (was-one-window (one-window-p)) - (help-not-visible - (not (and (windows-of-buffer "*Help*") ;shortcut - (member (selected-frame) - (mapcar 'window-frame - (windows-of-buffer "*Help*"))))))) - (prog1 (with-output-to-temp-buffer "*Help*" - (prog1 (funcall thunk) - (save-excursion - (set-buffer standard-output) - (help-mode)))) - (let ((helpwin (get-buffer-window "*Help*"))) - (when helpwin - (with-current-buffer (window-buffer helpwin) - ;; If the *Help* buffer is already displayed on this - ;; frame, don't override the previous configuration - (when help-not-visible - (set-frame-property (selected-frame) - 'help-window-config winconfig))) - (when help-selects-help-window - (select-window helpwin)) - (cond ((eq helpwin (selected-window)) - (display-message 'command - (substitute-command-keys "Type \\[help-mode-quit] to remove help window, \\[scroll-up] to scroll the help."))) - (was-one-window - (display-message 'command - (substitute-command-keys "Type \\[delete-other-windows] to remove help window, \\[scroll-other-window] to scroll the help."))) - (t - (display-message 'command - (substitute-command-keys "Type \\[switch-to-buffer-other-window] to restore the other window, \\[scroll-other-window] to scroll the help."))))))))) - -(defun describe-key (key) - "Display documentation of the function invoked by KEY. -KEY is a string, or vector of events. -When called interactively, KEY may also be a menu selection." - (interactive "kDescribe key: ") - (let ((defn (key-or-menu-binding key))) - (if (or (null defn) (integerp defn)) - (message "%s is undefined" (key-description key)) - (with-displaying-help-buffer - (lambda () - (princ (key-description key)) - (princ " runs ") - (if (symbolp defn) (princ (format "`%S'" defn)) - (prin1 defn)) - (princ "\n\n") - (cond ((or (stringp defn) (vectorp defn)) - (let ((cmd (key-binding defn))) - (if (not cmd) - (princ "a keyboard macro") - (progn - (princ "a keyboard macro which runs the command ") - (prin1 cmd) - (princ ":\n\n") - (if (documentation cmd) (princ (documentation cmd))))))) - ((and (consp defn) (not (eq 'lambda (car-safe defn)))) - (let ((describe-function-show-arglist nil)) - (describe-function-1 (car defn) standard-output))) - ((symbolp defn) - (describe-function-1 defn standard-output)) - ((documentation defn) - (princ (documentation defn))) - (t - (princ "not documented")))))))) - -(defun describe-mode () - "Display documentation of current major mode and minor modes. -For this to work correctly for a minor mode, the mode's indicator variable -\(listed in `minor-mode-alist') must also be a function whose documentation -describes the minor mode." - (interactive) - (with-displaying-help-buffer - (lambda () - ;; XEmacs change: print the major-mode documentation before - ;; the minor modes. - (princ mode-name) - (princ " mode:\n") - (princ (documentation major-mode)) - (princ "\n\n----\n\n") - (let ((minor-modes minor-mode-alist)) - (while minor-modes - (let* ((minor-mode (car (car minor-modes))) - (indicator (car (cdr (car minor-modes))))) - ;; Document a minor mode if it is listed in minor-mode-alist, - ;; bound locally in this buffer, non-nil, and has a function - ;; definition. - (if (and (boundp minor-mode) - (symbol-value minor-mode) - (fboundp minor-mode)) - (let ((pretty-minor-mode minor-mode)) - (if (string-match "-mode\\'" (symbol-name minor-mode)) - (setq pretty-minor-mode - (capitalize - (substring (symbol-name minor-mode) - 0 (match-beginning 0))))) - (while (and (consp indicator) (extentp (car indicator))) - (setq indicator (cdr indicator))) - (while (and indicator (symbolp indicator)) - (setq indicator (symbol-value indicator))) - (princ (format "%s minor mode (indicator%s):\n" - pretty-minor-mode indicator)) - (princ (documentation minor-mode)) - (princ "\n\n----\n\n")))) - (setq minor-modes (cdr minor-modes))))))) - -;; So keyboard macro definitions are documented correctly -(fset 'defining-kbd-macro (symbol-function 'start-kbd-macro)) - -(defun describe-distribution () - "Display info on how to obtain the latest version of XEmacs." - (interactive) - (find-file-read-only - (expand-file-name "DISTRIB" data-directory))) - -(defun describe-beta () - "Display info on how to deal with Beta versions of XEmacs." - (interactive) - (find-file-read-only - (expand-file-name "BETA" data-directory)) - (goto-char (point-min))) - -(defun describe-copying () - "Display info on how you may redistribute copies of XEmacs." - (interactive) - (find-file-read-only - (expand-file-name "COPYING" data-directory)) - (goto-char (point-min))) - -(defun describe-pointer () - "Show a list of all defined mouse buttons, and their definitions." - (interactive) - (describe-bindings nil t)) - -(defun describe-project () - "Display info on the GNU project." - (interactive) - (find-file-read-only - (expand-file-name "GNU" data-directory)) - (goto-char (point-min))) - -(defun describe-no-warranty () - "Display info on all the kinds of warranty XEmacs does NOT have." - (interactive) - (describe-copying) - (let (case-fold-search) - (search-forward "NO WARRANTY") - (recenter 0))) - -(defun describe-bindings (&optional prefix mouse-only-p) - "Show a list of all defined keys, and their definitions. -The list is put in a buffer, which is displayed. -If the optional argument PREFIX is supplied, only commands which -start with that sequence of keys are described. -If the second argument (prefix arg, interactively) is non-null -then only the mouse bindings are displayed." - (interactive (list nil current-prefix-arg)) - (with-displaying-help-buffer - (lambda () - (describe-bindings-1 prefix mouse-only-p)))) - -(defun describe-bindings-1 (&optional prefix mouse-only-p) - (let ((heading (if mouse-only-p - (gettext "button binding\n------ -------\n") - (gettext "key binding\n--- -------\n"))) - (buffer (current-buffer)) - (minor minor-mode-map-alist) - (local (current-local-map)) - (shadow '())) - (set-buffer standard-output) - (while minor - (let ((sym (car (car minor))) - (map (cdr (car minor)))) - (if (symbol-value-in-buffer sym buffer nil) - (progn - (insert (format "Minor Mode Bindings for `%s':\n" - sym) - heading) - (describe-bindings-internal map nil shadow prefix mouse-only-p) - (insert "\n") - (setq shadow (cons map shadow)))) - (setq minor (cdr minor)))) - (if local - (progn - (insert "Local Bindings:\n" heading) - (describe-bindings-internal local nil shadow prefix mouse-only-p) - (insert "\n") - (setq shadow (cons local shadow)))) - (insert "Global Bindings:\n" heading) - (describe-bindings-internal (current-global-map) - nil shadow prefix mouse-only-p) - (when (and prefix function-key-map (not mouse-only-p)) - (insert "\nFunction key map translations:\n" heading) - (describe-bindings-internal function-key-map nil nil prefix mouse-only-p)) - (set-buffer buffer))) - -(defun describe-prefix-bindings () - "Describe the bindings of the prefix used to reach this command. -The prefix described consists of all but the last event -of the key sequence that ran this command." - (interactive) - (let* ((key (this-command-keys)) - (prefix (make-vector (1- (length key)) nil)) - i) - (setq i 0) - (while (< i (length prefix)) - (aset prefix i (aref key i)) - (setq i (1+ i))) - (with-displaying-help-buffer - (lambda () - (princ "Key bindings starting with ") - (princ (key-description prefix)) - (princ ":\n\n") - (describe-bindings-1 prefix nil))))) - -;; Make C-h after a prefix, when not specifically bound, -;; run describe-prefix-bindings. -(setq prefix-help-command 'describe-prefix-bindings) - -(defun view-emacs-news () - "Display info on recent changes to XEmacs." - (interactive) - #-infodock (require 'outl-mouse) - (find-file (expand-file-name "NEWS" data-directory))) - -(defun xemacs-www-page () - "Go to the XEmacs World Wide Web page." - (interactive) - (funcall browse-url-browser-function "http://www.xemacs.org/")) - -(defun xemacs-www-faq () - "View the latest and greatest XEmacs FAQ using the World Wide Web." - (interactive) - (funcall browse-url-browser-function "http://www.xemacs.org/faq/index.html")) - -(defun xemacs-local-faq () - "View the local copy of the XEmacs FAQ. -If you have access to the World Wide Web, you should use `xemacs-www-faq' -instead, to ensure that you get the most up-to-date information." - (interactive) - (save-window-excursion - (info) - (Info-find-node "xemacs-faq" "Top")) - (switch-to-buffer "*info*")) - -(defcustom view-lossage-key-count 100 - "*Number of keys `view-lossage' shows. -The maximum number of available keys is governed by `recent-keys-ring-size'." - :type 'integer - :group 'help) - -(defcustom view-lossage-message-count 100 - "*Number of minibuffer messages `view-lossage' shows." - :type 'integer - :group 'help) - -(defun view-lossage () - "Display recent input keystrokes and recent minibuffer messages. -The number of keys shown is controlled by `view-lossage-key-count'. -The number of messages shown is controlled by `view-lossage-message-count'." - (interactive) - (with-displaying-help-buffer - (lambda () - (princ (key-description (recent-keys view-lossage-key-count))) - (save-excursion - (set-buffer standard-output) - (goto-char (point-min)) - (insert "Recent keystrokes:\n\n") - (while (progn (move-to-column 50) (not (eobp))) - (search-forward " " nil t) - (insert "\n"))) - ;; XEmacs addition - (princ "\n\n\nRecent minibuffer messages (most recent first):\n\n") - (save-excursion - (let ((buffer (get-buffer " *Message-Log*")) - (count 0) - oldpoint) - (set-buffer buffer) - (goto-char (point-max)) - (set-buffer standard-output) - (while (and (> (point buffer) (point-min buffer)) - (< count view-lossage-message-count)) - (setq oldpoint (point buffer)) - (forward-line -1 buffer) - (insert-buffer-substring buffer (point buffer) oldpoint) - (setq count (1+ count)))))))) - -(define-function 'help 'help-for-help) -;; #### FSF calls `make-help-screen' here. We need to port `help-macro.el'. -(defun help-for-help () - "You have typed \\[help-for-help], the help character. Type a Help option: -\(Use SPC or DEL to scroll through this text. Type \\<help-map>\\[help-quit] to exit the Help command.) - -\\[hyper-apropos] Type a substring; it shows a hypertext list of - functions and variables that contain that substring. - See also the `apropos' command. -\\[command-apropos] Type a substring; it shows a list of commands - (interactively callable functions) that contain that substring. -\\[describe-bindings] Table of all key bindings. -\\[describe-key-briefly] Type a command key sequence; - it displays the function name that sequence runs. -\\[Info-goto-emacs-command-node] Type a function name; it displays the Info node for that command. -\\[describe-function] Type a function name; it shows its documentation. -\\[Info-elisp-ref] Type a function name; it jumps to the full documentation - in the XEmacs Lisp Programmer's Manual. -\\[xemacs-local-faq] Local copy of the XEmacs FAQ. -\\[info] Info documentation reader. -\\[Info-query] Type an Info file name; it displays it in Info reader. -\\[describe-key] Type a command key sequence; - it displays the documentation for the command bound to that key. -\\[Info-goto-emacs-key-command-node] Type a command key sequence; - it displays the Info node for the command bound to that key. -\\[view-lossage] Recent input keystrokes and minibuffer messages. -\\[describe-mode] Documentation of current major and minor modes. -\\[view-emacs-news] News of recent XEmacs changes. -\\[finder-by-keyword] Type a topic keyword; it finds matching packages. -\\[describe-pointer] Table of all mouse-button bindings. -\\[describe-syntax] Contents of syntax table with explanations. -\\[help-with-tutorial] XEmacs learn-by-doing tutorial. -\\[describe-variable] Type a variable name; it displays its documentation and value. -\\[where-is] Type a command name; it displays which keystrokes invoke that command. -\\[describe-distribution] XEmacs ordering information. -\\[describe-no-warranty] Information on absence of warranty for XEmacs. -\\[describe-copying] XEmacs copying permission (General Public License)." - (interactive) - (let ((help-key (copy-event last-command-event)) - event char) - (message (gettext "A B C F I K L M N P S T V W C-c C-d C-n C-w. Type %s again for more help: ") - ;; arrgh, no room for "C-i C-k C-f" !! - (single-key-description help-key)) - (setq event (next-command-event) - char (event-to-character event)) - (if (or (equal event help-key) - (eq char ??) - (eq 'help-command (key-binding event))) - (save-window-excursion - (switch-to-buffer "*Help*") - ;; #### I18N3 should mark buffer as output-translating - (delete-other-windows) - (let ((buffer-read-only nil)) - (erase-buffer) - (insert (documentation 'help-for-help))) - (goto-char (point-min)) - (while (or (equal event help-key) - (eq char ??) - (eq 'help-command (key-binding event)) - (eq char ?\ ) - (eq 'scroll-up (key-binding event)) - (eq char ?\177) - (and (not (eq char ?b)) - (eq 'scroll-down (key-binding event)))) - (if (or (eq char ?\ ) - (eq 'scroll-up (key-binding event))) - (scroll-up)) - (if (or (eq char ?\177) - (and (not (eq char ?b)) - (eq 'scroll-down (key-binding event)))) - (scroll-down)) - ;; write this way for I18N3 snarfing - (if (pos-visible-in-window-p (point-max)) - (message "A B C F I K L M N P S T V W C-c C-d C-n C-w C-i C-k C-f: ") - (message "A B C F I K L M N P S T V W C-c C-d C-n C-w C-i C-k C-f or Space to scroll: ")) - (let ((cursor-in-echo-area t)) - (setq event (next-command-event event) - char (or (event-to-character event) event)))))) - (let ((defn (or (lookup-key help-map (vector event)) - (and (numberp char) - (lookup-key help-map (make-string 1 (downcase char))))))) - (message nil) - (if defn - (call-interactively defn) - (ding))))) - -(defun function-called-at-point () - "Return the function which is called by the list containing point. -If that gives no function, return the function whose name is around point. -If that doesn't give a function, return nil." - (or (condition-case () - (save-excursion - (save-restriction - (narrow-to-region (max (point-min) (- (point) 1000)) (point-max)) - (backward-up-list 1) - (forward-char 1) - (let (obj) - (setq obj (read (current-buffer))) - (and (symbolp obj) (fboundp obj) obj)))) - (error nil)) - (condition-case () - (let ((stab (syntax-table))) - (unwind-protect - (save-excursion - (set-syntax-table emacs-lisp-mode-syntax-table) - (or (not (zerop (skip-syntax-backward "_w"))) - (eq (char-syntax (char-after (point))) ?w) - (eq (char-syntax (char-after (point))) ?_) - (forward-sexp -1)) - (skip-chars-forward "`'") - (let ((obj (read (current-buffer)))) - (and (symbolp obj) (fboundp obj) obj))) - (set-syntax-table stab))) - (error nil)))) - -(defun function-at-point () - "Return the function whose name is around point. -If that gives no function, return the function which is called by the -list containing point. If that doesn't give a function, return nil. - -If `function-at-point-function' is non nil, the function it names is -called instead." - (if (and (fboundp function-at-point-function) - (not (eq function-at-point-function 'function-at-point))) - (funcall function-at-point-function) - (or (condition-case () - (let ((stab (syntax-table))) - (unwind-protect - (save-excursion - (set-syntax-table emacs-lisp-mode-syntax-table) - (or (not (zerop (skip-syntax-backward "_w"))) - (eq (char-syntax (char-after (point))) ?w) - (eq (char-syntax (char-after (point))) ?_) - (forward-sexp -1)) - (skip-chars-forward "`'") - (let ((obj (read (current-buffer)))) - (and (symbolp obj) (fboundp obj) obj))) - (set-syntax-table stab))) - (error nil)) - (condition-case () - (save-excursion - (save-restriction - (narrow-to-region (max (point-min) (- (point) 1000)) - (point-max)) - (backward-up-list 1) - (forward-char 1) - (let (obj) - (setq obj (read (current-buffer))) - (and (symbolp obj) (fboundp obj) obj)))) - (error nil))))) - -;; Default to nil for the non-hackers? Not until we find a way to -;; distinguish hackers from non-hackers automatically! -(defcustom describe-function-show-arglist t - "*If non-nil, describe-function will show its arglist, -unless the function is autoloaded." - :type 'boolean - :group 'help-appearance) - -(defcustom function-at-point-function nil - "*Set this to name an alternative function to be used by -`function-at-point' instead of itself. - -For example `function-called-at-point'." - :type 'function - :group 'help) - -(defun describe-function-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-function (function) - "Display the full documentation of FUNCTION (a symbol). -When run interactively, it defaults to any function found by -`function-at-point'." - (interactive - (let* ((fn (function-at-point)) - (val (let ((enable-recursive-minibuffers t)) - (completing-read - (if fn - (format (gettext "Describe function (default %s): ") - fn) - (gettext "Describe function: ")) - obarray 'fboundp t nil 'function-history)))) - (list (if (equal val "") fn (intern val))))) - (with-displaying-help-buffer - (lambda () - (describe-function-1 function standard-output) - ;; Return the text we displayed. - (buffer-string nil nil standard-output)))) - -(defun function-obsolete-p (function) - "Return non-nil if FUNCTION is obsolete." - (not (null (get function 'byte-obsolete-info)))) - -(defun function-obsoleteness-doc (function) - "If FUNCTION is obsolete, return a string describing this." - (let ((obsolete (get function 'byte-obsolete-info))) - (if obsolete - (format "Obsolete; %s" - (if (stringp (car obsolete)) - (car obsolete) - (format "use `%s' instead." (car obsolete))))))) - -(defun function-compatible-p (function) - "Return non-nil if FUNCTION is present for Emacs compatibility." - (not (null (get function 'byte-compatible-info)))) - -(defun function-compatibility-doc (function) - "If FUNCTION is Emacs compatible, return a string describing this." - (let ((compatible (get function 'byte-compatible-info))) - (if compatible - (format "Emacs Compatible; %s" - (if (stringp (car compatible)) - (car compatible) - (format "use `%s' instead." (car compatible))))))) - -;Here are all the possibilities below spelled out, for the benefit -;of the I18N3 snarfer. -; -;(gettext "a built-in function") -;(gettext "an interactive built-in function") -;(gettext "a built-in macro") -;(gettext "an interactive built-in macro") -;(gettext "a compiled Lisp function") -;(gettext "an interactive compiled Lisp function") -;(gettext "a compiled Lisp macro") -;(gettext "an interactive compiled Lisp macro") -;(gettext "a Lisp function") -;(gettext "an interactive Lisp function") -;(gettext "a Lisp macro") -;(gettext "an interactive Lisp macro") -;(gettext "a mocklisp function") -;(gettext "an interactive mocklisp function") -;(gettext "a mocklisp macro") -;(gettext "an interactive mocklisp macro") -;(gettext "an autoloaded Lisp function") -;(gettext "an interactive autoloaded Lisp function") -;(gettext "an autoloaded Lisp macro") -;(gettext "an interactive autoloaded Lisp macro") - -(defun describe-function-1 (function stream &optional nodoc) - (princ (format "`%S' is " function) stream) - (let* ((def function) - (doc (condition-case nil - (or (documentation function) - (gettext "not documented")) - (void-function ""))) - aliases file-name autoload-file kbd-macro-p fndef macrop) - (while (and (symbolp def) (fboundp def)) - (when (not (eq def function)) - (setq aliases - (if aliases - ;; I18N3 Need gettext due to concat - (concat aliases - (format - "\n which is an alias for `%s', " - (symbol-name def))) - (format "an alias for `%s', " (symbol-name def))))) - (setq def (symbol-function def))) - (if (compiled-function-p def) - (setq file-name (compiled-function-annotation def))) - (if (eq 'macro (car-safe def)) - (setq fndef (cdr def) - file-name (and (compiled-function-p (cdr def)) - (compiled-function-annotation (cdr def))) - macrop t) - (setq fndef def)) - (if aliases (princ aliases stream)) - (let ((int #'(lambda (string an-p macro-p) - (princ (format - (gettext (concat - (cond ((commandp def) - "an interactive ") - (an-p "an ") - (t "a ")) - "%s" - (if macro-p " macro" " function"))) - string) - stream)))) - (cond ((or (stringp def) (vectorp def)) - (princ "a keyboard macro." stream) - (setq kbd-macro-p t)) - ((subrp fndef) - (funcall int "built-in" nil macrop)) - ((compiled-function-p fndef) - (funcall int "compiled Lisp" nil macrop)) -; XEmacs -- we handle aliases above. -; ((symbolp fndef) -; (princ (format "alias for `%s'" -; (prin1-to-string def)) stream)) - ((eq (car-safe fndef) 'lambda) - (funcall int "Lisp" nil macrop)) - ((eq (car-safe fndef) 'mocklisp) - (funcall int "mocklisp" nil macrop)) - ((eq (car-safe def) 'autoload) - (setq autoload-file (elt def 1)) - (funcall int "autoloaded Lisp" t (elt def 4))) - ((and (symbolp def) (not (fboundp def))) - (princ "a symbol with a void (unbound) function definition." stream)) - (t - nil))) - (princ "\n") - (if autoload-file - (princ (format " -- autoloads from \"%s\"\n" autoload-file) stream)) - (or file-name - (setq file-name (describe-function-find-file function))) - (if file-name - (princ (format " -- loaded from \"%s\"\n" file-name)) stream) -;; (terpri stream) - (if describe-function-show-arglist - (let ((arglist - (cond ((compiled-function-p fndef) - (compiled-function-arglist fndef)) - ((eq (car-safe fndef) 'lambda) - (nth 1 fndef)) - ((and (subrp fndef) - (string-match - "[\n\t ]*\narguments: ?(\\(.*\\))\n?\\'" - doc)) - (prog1 - (substring doc (match-beginning 1) (match-end 1)) - (setq doc (substring doc 0 (match-beginning 0))))) - (t t)))) - (if (listp arglist) - (progn -;; (princ " ") - (princ (cons function - (mapcar (lambda (arg) - (if (memq arg '(&optional &rest)) - arg - (intern (upcase (symbol-name arg))))) - arglist)) stream) - (terpri stream))) - (if (stringp arglist) - (princ (format "(%s %s)\n" function arglist) stream)))) - (terpri stream) - (cond (kbd-macro-p - (princ "These characters are executed:\n\n\t" stream) - (princ (key-description def) stream) - (cond ((setq def (key-binding def)) - (princ (format "\n\nwhich executes the command %S.\n\n" def) stream) - (describe-function-1 def stream)))) - (nodoc nil) - (t - ;; tell the user about obsoleteness. - ;; If the function is obsolete and is aliased, don't - ;; even bother to report the documentation, as a further - ;; encouragement to use the new function. - (let ((obsolete (function-obsoleteness-doc function)) - (compatible (function-compatibility-doc function))) - (when obsolete - (princ obsolete stream) - (terpri stream) - (terpri stream)) - (when compatible - (princ compatible stream) - (terpri stream) - (terpri stream)) - (unless (and obsolete aliases) - (princ doc stream) - (unless (or (equal doc "") - (eq ?\n (aref doc (1- (length doc))))) - (terpri stream)))))))) - - -;;; ## this doesn't seem to be used for anything -;; (defun describe-function-arglist (function) -;; (interactive (list (or (function-at-point) -;; (error "no function call at point")))) -;; (let ((b nil)) -;; (unwind-protect -;; (save-excursion -;; (set-buffer (setq b (get-buffer-create " *arglist*"))) -;; (buffer-disable-undo b) -;; (erase-buffer) -;; (describe-function-1 function b t) -;; (goto-char (point-min)) -;; (end-of-line) -;; (or (eobp) (delete-char 1)) -;; (just-one-space) -;; (end-of-line) -;; (message (buffer-substring (point-min) (point)))) -;; (and b (kill-buffer b))))) - - -(defun variable-at-point () - (ignore-errors - (let ((stab (syntax-table))) - (unwind-protect - (save-excursion - (set-syntax-table emacs-lisp-mode-syntax-table) - (or (not (zerop (skip-syntax-backward "_w"))) - (eq (char-syntax (char-after (point))) ?w) - (eq (char-syntax (char-after (point))) ?_) - (forward-sexp -1)) - (skip-chars-forward "'") - (let ((obj (read (current-buffer)))) - (and (symbolp obj) (boundp obj) obj))) - (set-syntax-table stab))))) - -(defun variable-obsolete-p (variable) - "Return non-nil if VARIABLE is obsolete." - (not (null (get variable 'byte-obsolete-variable)))) - -(defun variable-obsoleteness-doc (variable) - "If VARIABLE is obsolete, return a string describing this." - (let ((obsolete (get variable 'byte-obsolete-variable))) - (if obsolete - (format "Obsolete; %s" - (if (stringp obsolete) - obsolete - (format "use `%s' instead." obsolete)))))) - -(defun variable-compatible-p (variable) - "Return non-nil if VARIABLE is Emacs compatible." - (not (null (get variable 'byte-compatible-variable)))) - -(defun variable-compatibility-doc (variable) - "If VARIABLE is Emacs compatible, return a string describing this." - (let ((compatible (get variable 'byte-compatible-variable))) - (if compatible - (format "Emacs Compatible; %s" - (if (stringp compatible) - compatible - (format "use `%s' instead." compatible)))))) - -(defun built-in-variable-doc (variable) - "Return a string describing whether VARIABLE is built-in." - (let ((type (built-in-variable-type variable))) - (case type - (integer "a built-in integer variable") - (const-integer "a built-in constant integer variable") - (boolean "a built-in boolean variable") - (const-boolean "a built-in constant boolean variable") - (object "a simple built-in variable") - (const-object "a simple built-in constant variable") - (const-specifier "a built-in constant specifier variable") - (current-buffer "a built-in buffer-local variable") - (const-current-buffer "a built-in constant buffer-local variable") - (default-buffer "a built-in default buffer-local variable") - (selected-console "a built-in console-local variable") - (const-selected-console "a built-in constant console-local variable") - (default-console "a built-in default console-local variable") - (t - (if type "an unknown type of built-in variable?" - "a variable declared in Lisp"))))) - -(defun describe-variable (variable) - "Display the full documentation of VARIABLE (a symbol)." - (interactive - (let* ((v (variable-at-point)) - (val (let ((enable-recursive-minibuffers t)) - (completing-read - (if v - (format "Describe variable (default %s): " v) - (gettext "Describe variable: ")) - obarray 'boundp t nil 'variable-history)))) - (list (if (equal val "") v (intern val))))) - (with-displaying-help-buffer - (lambda () - (let ((origvar variable) - aliases) - (let ((print-escape-newlines t)) - (princ (format "`%s' is " (symbol-name variable))) - (while (variable-alias variable) - (let ((newvar (variable-alias variable))) - (if aliases - ;; I18N3 Need gettext due to concat - (setq aliases - (concat aliases - (format "\n which is an alias for `%s'," - (symbol-name newvar)))) - (setq aliases - (format "an alias for `%s'," - (symbol-name newvar)))) - (setq variable newvar))) - (if aliases - (princ (format "%s" aliases))) - (princ (built-in-variable-doc variable)) - (princ ".\n\n") - (princ "Value: ") - (if (not (boundp variable)) - (princ "void") - (prin1 (symbol-value variable))) - (terpri) - (cond ((local-variable-p variable (current-buffer)) - (let* ((void (cons nil nil)) - (def (condition-case nil - (default-value variable) - (error void)))) - (princ "This value is specific to the current buffer.") - (terpri) - (if (local-variable-p variable nil) - (progn - (princ "(Its value is local to each buffer.)") - (terpri))) - (if (if (eq def void) - (boundp variable) - (not (eq (symbol-value variable) def))) - ;; #### I18N3 doesn't localize properly! - (progn (princ "Its default-value is ") - (if (eq def void) - (princ "void.") - (prin1 def)) - (terpri))))) - ((local-variable-p variable (current-buffer) t) - (princ "Setting it would make its value buffer-local.\n")))) - (terpri) - (princ "Documentation:") - (terpri) - (let ((doc (documentation-property variable 'variable-documentation)) - (obsolete (variable-obsoleteness-doc origvar)) - (compatible (variable-compatibility-doc origvar))) - (when obsolete - (princ obsolete) - (terpri) - (terpri)) - (when compatible - (princ compatible) - (terpri) - (terpri)) - ;; don't bother to print anything if variable is obsolete and aliased. - (when (or (not obsolete) (not aliases)) - (if doc - ;; note: documentation-property calls substitute-command-keys. - (princ doc) - (princ "not documented as a variable.")) - (terpri))) - ;; Return the text we displayed. - (buffer-string nil nil standard-output))))) - -(defun sorted-key-descriptions (keys &optional separator) - "Sort and separate the key descriptions for KEYS. -The sorting is done by length (shortest bindings first), and the bindings -are separated with SEPARATOR (\", \" by default)." - (mapconcat 'key-description - (sort keys #'(lambda (x y) - (< (length x) (length y)))) - (or separator ", "))) - -(defun where-is (definition) - "Print message listing key sequences that invoke specified command. -Argument is a command definition, usually a symbol with a function definition. -When run interactively, it defaults to any function found by -`function-at-point'." - (interactive - (let ((fn (function-at-point)) - (enable-recursive-minibuffers t) - val) - (setq val (read-command - (if fn (format "Where is command (default %s): " fn) - "Where is command: "))) - (list (if (equal (symbol-name val) "") - fn val)))) - (let ((keys (where-is-internal definition))) - (if keys - (message "%s is on %s" definition (sorted-key-descriptions keys)) - (message "%s is not on any keys" definition))) - nil) - -;; `locate-library' moved to "packages.el" - - -;; Functions ported from C into Lisp in XEmacs - -(defun describe-syntax () - "Describe the syntax specifications in the syntax table. -The descriptions are inserted in a buffer, which is then displayed." - (interactive) - (with-displaying-help-buffer - (lambda () - ;; defined in syntax.el - (describe-syntax-table (syntax-table) standard-output)))) - -(defun list-processes () - "Display a list of all processes. -\(Any processes listed as Exited or Signaled are actually eliminated -after the listing is made.)" - (interactive) - (with-output-to-temp-buffer "*Process List*" - (set-buffer standard-output) - (buffer-disable-undo standard-output) - (make-local-variable 'truncate-lines) - (setq truncate-lines t) - (let ((stream standard-output)) - ;; 00000000001111111111222222222233333333334444444444 - ;; 01234567890123456789012345678901234567890123456789 - ;; rewritten for I18N3. This one should stay rewritten - ;; so that the dashes will line up properly. - (princ "Proc Status Buffer Tty Command\n---- ------ ------ --- -------\n" stream) - (let ((tail (process-list))) - (while tail - (let* ((p (car tail)) - (pid (process-id p)) - (s (process-status p))) - (setq tail (cdr tail)) - (princ (format "%-13s" (process-name p)) stream) - ;(if (and (eq system-type 'vax-vms) - ; (eq s 'signal) - ; (< (process-exit-status p) NSIG)) - ; (princ (aref sys_errlist (process-exit-status p)) stream)) - (princ s stream) - (if (and (eq s 'exit) (/= (process-exit-status p) 0)) - (princ (format " %d" (process-exit-status p)) stream)) - (if (memq s '(signal exit closed)) - ;; Do delete-exited-processes' work - (delete-process p)) - (indent-to 22 1) ;#### - (let ((b (process-buffer p))) - (cond ((not b) - (princ "(none)" stream)) - ((not (buffer-name b)) - (princ "(killed)" stream)) - (t - (princ (buffer-name b) stream)))) - (indent-to 37 1) ;#### - (let ((tn (process-tty-name p))) - (cond ((not tn) - (princ "(none)" stream)) - (t - (princ (format "%s" tn) stream)))) - (indent-to 49 1) ;#### - (if (not (integerp pid)) - (progn - (princ "network stream connection " stream) - (princ (car pid) stream) - (princ "@" stream) - (princ (cdr pid) stream)) - (let ((cmd (process-command p))) - (while cmd - (princ (car cmd) stream) - (setq cmd (cdr cmd)) - (if cmd (princ " " stream))))) - (terpri stream))))))) - -;; `find-function' et al moved to "find-func.el" - -;;; help.el ends here
--- a/lisp/prim/indent.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,478 +0,0 @@ -;;; indent.el --- indentation commands for XEmacs - -;; Copyright (C) 1985, 1992, 1993, 1995, 1997 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: lisp languages tools - -;; 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. - -;;; Commentary: - -;; Commands for making and changing indentation in text. These are -;; described in the XEmacs Reference Manual. - -;; 06/11/1997 - Convert (preceding|following)-char to char-(before|after) -slb - -;;; Code: - -(defvar standard-indent 4 "\ -Default number of columns for margin-changing functions to indent.") - -(defvar indent-line-function 'indent-to-left-margin - "Function to indent current line.") - -(defun indent-according-to-mode () - "Indent line in proper way for current major mode." - (interactive) - (funcall indent-line-function)) - -(defun indent-for-tab-command (&optional prefix-arg) - "Indent line in proper way for current major mode." - (interactive "P") - (if (eq indent-line-function 'indent-to-left-margin) - (insert-tab prefix-arg) - (if prefix-arg - (funcall indent-line-function prefix-arg) - (funcall indent-line-function)))) - -(defun insert-tab (&optional prefix-arg) - (let ((count (prefix-numeric-value prefix-arg))) - (if abbrev-mode - (expand-abbrev)) - (if indent-tabs-mode - (insert-char ?\t count) - ;; XEmacs: (Need the `1+') - (indent-to (* tab-width (1+ (/ (current-column) tab-width))))))) - -(defun indent-rigidly (start end arg) - "Indent all lines starting in the region sideways by ARG columns. -Called from a program, takes three arguments, START, END and ARG." - (interactive "r\np") - (save-excursion - (goto-char end) - (setq end (point-marker)) - (goto-char start) - (or (bolp) (forward-line 1)) - (while (< (point) end) - (let ((indent (current-indentation)) - eol-flag) - (save-excursion - (skip-chars-forward " \t") - (setq eol-flag (eolp))) - (or eol-flag - (indent-to (max 0 (+ indent arg)) 0)) - (delete-region (point) (progn (skip-chars-forward " \t") (point)))) - (forward-line 1)) - (move-marker end nil) - (setq zmacs-region-stays nil))) ; XEmacs - -(defun indent-line-to (column) - "Indent current line to COLUMN. -This function removes or adds spaces and tabs at beginning of line -only if necessary. It leaves point at end of indentation." - (back-to-indentation) - (let ((cur-col (current-column))) - (cond ((< cur-col column) - (if (> (- column (* (/ cur-col tab-width) tab-width)) tab-width) - (delete-region (point) - (progn (skip-chars-backward " ") (point)))) - (indent-to column)) - ((> cur-col column) ; too far right (after tab?) - (delete-region (progn (move-to-column column t) (point)) - (progn (back-to-indentation) (point))))))) - -(defun current-left-margin () - "Return the left margin to use for this line. -This is the value of the buffer-local variable `left-margin' plus the value -of the `left-margin' text-property at the start of the line." - (save-excursion - (back-to-indentation) - (max 0 - (+ left-margin (or (get-text-property - (if (and (eobp) (not (bobp))) - (1- (point)) (point)) - 'left-margin) 0))))) - -(defun move-to-left-margin (&optional n force) - "Move to the left margin of the current line. -With optional argument, move forward N-1 lines first. -The column moved to is the one given by the `current-left-margin' function. -If the line's indentation appears to be wrong, and this command is called -interactively or with optional argument FORCE, it will be fixed." - (interactive (list (prefix-numeric-value current-prefix-arg) t)) - (beginning-of-line n) - (skip-chars-forward " \t") - (let ((lm (current-left-margin)) - (cc (current-column))) - (cond ((> cc lm) - (if (> (move-to-column lm force) lm) - ;; If lm is in a tab and we are not forcing, move before tab - (backward-char 1))) - ((and force (< cc lm)) - (indent-to-left-margin))))) - -;; This is the default indent-line-function, -;; used in Fundamental Mode, Text Mode, etc. -(defun indent-to-left-margin () - "Indent current line to the column given by `current-left-margin'." - (indent-line-to (current-left-margin))) - -(defun delete-to-left-margin (&optional from to) - "Remove left margin indentation from a region. -This deletes to the column given by `current-left-margin'. -In no case will it delete non-whitespace. -Args FROM and TO are optional; default is the whole buffer." - (save-excursion - (goto-char (or to (point-max))) - (setq to (point-marker)) - (goto-char (or from (point-min))) - (or (bolp) (forward-line 1)) - (while (< (point) to) - (delete-region (point) (progn (move-to-left-margin nil t) (point))) - (forward-line 1)) - (move-marker to nil))) - -(defun set-left-margin (from to lm) - "Set the left margin of the region to WIDTH. -If `auto-fill-mode' is active, re-fill the region to fit the new margin." - (interactive "r\nNSet left margin to column: ") - (if (interactive-p) (setq lm (prefix-numeric-value lm))) - (save-excursion - ;; If inside indentation, start from BOL. - (goto-char from) - (skip-chars-backward " \t") - (if (bolp) (setq from (point))) - ;; Place end after whitespace - (goto-char to) - (skip-chars-forward " \t") - (setq to (point-marker))) - ;; Delete margin indentation first, but keep paragraph indentation. - (delete-to-left-margin from to) - (put-text-property from to 'left-margin lm) - (indent-rigidly from to lm) - (if auto-fill-function (save-excursion (fill-region from to nil t t))) - (move-marker to nil)) - -(defun set-right-margin (from to lm) - "Set the right margin of the region to WIDTH. -If `auto-fill-mode' is active, re-fill the region to fit the new margin." - (interactive "r\nNSet right margin to width: ") - (if (interactive-p) (setq lm (prefix-numeric-value lm))) - (save-excursion - (goto-char from) - (skip-chars-backward " \t") - (if (bolp) (setq from (point)))) - (put-text-property from to 'right-margin lm) - (if auto-fill-function (save-excursion (fill-region from to nil t t)))) - -(defun alter-text-property (from to prop func &optional object) - "Programmatically change value of a text-property. -For each region between FROM and TO that has a single value for PROPERTY, -apply FUNCTION to that value and sets the property to the function's result. -Optional fifth argument OBJECT specifies the string or buffer to operate on." - (let ((begin from) - end val) - (while (setq val (get-text-property begin prop object) - end (text-property-not-all begin to prop val object)) - (put-text-property begin end prop (funcall func val) object) - (setq begin end)) - (if (< begin to) - (put-text-property begin to prop (funcall func val) object)))) - -(defun increase-left-margin (from to inc) - "Increase or decrease the left-margin of the region. -With no prefix argument, this adds `standard-indent' of indentation. -A prefix arg (optional third arg INC noninteractively) specifies the amount -to change the margin by, in characters. -If `auto-fill-mode' is active, re-fill the region to fit the new margin." - (interactive "*r\nP") - (setq inc (if inc (prefix-numeric-value inc) standard-indent)) - (save-excursion - (goto-char from) - (skip-chars-backward " \t") - (if (bolp) (setq from (point))) - (goto-char to) - (setq to (point-marker))) - (alter-text-property from (marker-position to) 'left-margin ; XEmacs - (lambda (v) (max (- left-margin) (+ inc (or v 0))))) - (indent-rigidly from (marker-position to) inc) ; XEmacs - (if auto-fill-function - (save-excursion - (fill-region from (marker-position to) nil t t))) ; XEmacs - (move-marker to nil)) - -(defun decrease-left-margin (from to inc) - "Make the left margin of the region smaller. -With no prefix argument, decrease the indentation by `standard-indent'. -A prefix arg (optional third arg INC noninteractively) specifies the amount -to change the margin by, in characters. -If `auto-fill-mode' is active, re-fill the region to fit the new margin." - (interactive "*r\nP") - (setq inc (if inc (prefix-numeric-value inc) standard-indent)) - (increase-left-margin from to (- inc))) - -(defun increase-right-margin (from to inc) - "Increase the right-margin of the region. -With no prefix argument, increase the right margin by `standard-indent'. -A prefix arg (optional third arg INC noninteractively) specifies the amount -to change the margin by, in characters. A negative argument decreases -the right margin width. -If `auto-fill-mode' is active, re-fill the region to fit the new margin." - (interactive "r\nP") - (if (interactive-p) - (setq inc (if inc (prefix-numeric-value current-prefix-arg) - standard-indent))) - (save-excursion - (alter-text-property from to 'right-margin - (lambda (v) (+ inc (or v 0)))) - (if auto-fill-function - (fill-region from to nil t t)))) - -(defun decrease-right-margin (from to inc) - "Make the right margin of the region smaller. -With no prefix argument, decrease the right margin by `standard-indent'. -A prefix arg (optional third arg INC noninteractively) specifies the amount -of width to remove, in characters. A negative argument increases -the right margin width. -If `auto-fill-mode' is active, re-fills region to fit in new margin." - (interactive "*r\nP") - (setq inc (if inc (prefix-numeric-value inc) standard-indent)) - (increase-right-margin from to (- inc))) - -(defun beginning-of-line-text (&optional n) - "Move to the beginning of the text on this line. -With optional argument, move forward N-1 lines first. -From the beginning of the line, moves past the left-margin indentation, the -fill-prefix, and any indentation used for centering or right-justifying the -line, but does not move past any whitespace that was explicitly inserted -\(such as a tab used to indent the first line of a paragraph)." - (interactive "p") - (beginning-of-line n) - (skip-chars-forward " \t") - ;; Skip over fill-prefix. - (if (and fill-prefix - (not (string-equal fill-prefix ""))) - (if (equal fill-prefix - (buffer-substring - (point) (min (point-max) (+ (length fill-prefix) (point))))) - (forward-char (length fill-prefix))) - (if (and adaptive-fill-mode adaptive-fill-regexp - (looking-at adaptive-fill-regexp)) - (goto-char (match-end 0)))) - ;; Skip centering or flushright indentation - (if (memq (current-justification) '(center right)) - (skip-chars-forward " \t"))) - -(defvar indent-region-function nil - "Short cut function to indent region using `indent-according-to-mode'. -A value of nil means really run `indent-according-to-mode' on each line.") - -(defun indent-region (start end column) - "Indent each nonblank line in the region. -With no argument, indent each line using `indent-according-to-mode', -or use `indent-region-function' to do the whole region if that's non-nil. -If there is a fill prefix, make each line start with the fill prefix. -With argument COLUMN, indent each line to that column. -Called from a program, takes three args: START, END and COLUMN." - (interactive "r\nP") - (if (null column) - (if fill-prefix - (save-excursion - (goto-char end) - (setq end (point-marker)) - (goto-char start) - (let ((regexp (regexp-quote fill-prefix))) - (while (< (point) end) - (or (looking-at regexp) - (and (bolp) (eolp)) - (insert fill-prefix)) - (forward-line 1)))) - (if indent-region-function - (funcall indent-region-function start end) - (save-excursion - (goto-char end) - (setq end (point-marker)) - (goto-char start) - (or (bolp) (forward-line 1)) - (while (< (point) end) - (or (and (bolp) (eolp)) - (funcall indent-line-function)) - (forward-line 1)) - (move-marker end nil)))) - (setq column (prefix-numeric-value column)) - (save-excursion - (goto-char end) - (setq end (point-marker)) - (goto-char start) - (or (bolp) (forward-line 1)) - (while (< (point) end) - (delete-region (point) (progn (skip-chars-forward " \t") (point))) - (or (eolp) - (indent-to column 0)) - (forward-line 1)) - (move-marker end nil)))) - -(defun indent-relative-maybe () - "Indent a new line like previous nonblank line." - (interactive) - (indent-relative t)) - -(defun indent-relative (&optional unindented-ok) - "Space out to under next indent point in previous nonblank line. -An indent point is a non-whitespace character following whitespace. -If the previous nonblank line has no indent points beyond the -column point starts at, `tab-to-tab-stop' is done instead." - (interactive "P") - (if abbrev-mode (expand-abbrev)) - (let ((start-column (current-column)) - indent) - (save-excursion - (beginning-of-line) - (if (re-search-backward "^[^\n]" nil t) - (let ((end (save-excursion (forward-line 1) (point)))) - (move-to-column start-column) - ;; Is start-column inside a tab on this line? - (if (> (current-column) start-column) - (backward-char 1)) - (or (looking-at "[ \t]") - unindented-ok - (skip-chars-forward "^ \t" end)) - (skip-chars-forward " \t" end) - (or (= (point) end) (setq indent (current-column)))))) - (if indent - (let ((opoint (point-marker))) - (delete-region (point) (progn (skip-chars-backward " \t") (point))) - (indent-to indent 0) - (if (> opoint (point)) - (goto-char opoint)) - (move-marker opoint nil)) - (tab-to-tab-stop)))) - -(defvar tab-stop-list - '(8 16 24 32 40 48 56 64 72 80 88 96 104 112 120) - "*List of tab stop positions used by `tab-to-tab-stops'. -This should be a list of integers, ordered from smallest to largest.") - -(defvar edit-tab-stops-map nil "Keymap used in `edit-tab-stops'.") -(if edit-tab-stops-map - nil - (setq edit-tab-stops-map (make-sparse-keymap)) - (define-key edit-tab-stops-map "\C-x\C-s" 'edit-tab-stops-note-changes) - (define-key edit-tab-stops-map "\C-c\C-c" 'edit-tab-stops-note-changes)) - -(defvar edit-tab-stops-buffer nil - "Buffer whose tab stops are being edited--in case -the variable `tab-stop-list' is local in that buffer.") - -(defun edit-tab-stops () - "Edit the tab stops used by `tab-to-tab-stop'. -Creates a buffer *Tab Stops* containing text describing the tab stops. -A colon indicates a column where there is a tab stop. -You can add or remove colons and then do \\<edit-tab-stops-map>\\[edit-tab-stops-note-changes] to make changes take effect." - (interactive) - (setq edit-tab-stops-buffer (current-buffer)) - (switch-to-buffer (get-buffer-create "*Tab Stops*")) - ;; #### I18N3 should mark buffer as output-translating - (use-local-map edit-tab-stops-map) - (make-local-variable 'indent-tabs-mode) - (setq indent-tabs-mode nil) - (overwrite-mode 1) - (setq truncate-lines t) - (erase-buffer) - (let ((tabs tab-stop-list)) - (while tabs - (indent-to (car tabs) 0) - (insert ?:) - (setq tabs (cdr tabs)))) - (let ((count 0)) - (insert ?\n) - (while (< count 8) - (insert (+ count ?0)) - (insert " ") - (setq count (1+ count))) - (insert ?\n) - (while (> count 0) - (insert "0123456789") - (setq count (1- count)))) - ;; XEmacs - (insert (substitute-command-keys "\nTo install changes, type \\<edit-tab-stops-map>\\[edit-tab-stops-note-changes]")) - (goto-char (point-min))) - -(defun edit-tab-stops-note-changes () - "Put edited tab stops into effect." - (interactive) - (let (tabs) - (save-excursion - (goto-char 1) - (end-of-line) - (while (search-backward ":" nil t) - (setq tabs (cons (current-column) tabs)))) - (bury-buffer (prog1 (current-buffer) - (switch-to-buffer edit-tab-stops-buffer))) - (setq tab-stop-list tabs)) - (message "Tab stops installed")) - -(defun tab-to-tab-stop () - "Insert spaces or tabs to next defined tab-stop column. -The variable `tab-stop-list' is a list of columns at which there are tab stops. -Use \\[edit-tab-stops] to edit them interactively." - (interactive) - (and abbrev-mode (eq (char-syntax (char-before (point))) ?w) - (expand-abbrev)) - (let ((tabs tab-stop-list)) - (while (and tabs (>= (current-column) (car tabs))) - (setq tabs (cdr tabs))) - (if tabs - (let ((opoint (point))) - (skip-chars-backward " \t") - (delete-region (point) opoint) - (indent-to (car tabs))) - (insert ?\ )))) - -(defun move-to-tab-stop () - "Move point to next defined tab-stop column. -The variable `tab-stop-list' is a list of columns at which there are tab stops. -Use \\[edit-tab-stops] to edit them interactively." - (interactive) - (let ((tabs tab-stop-list)) - (while (and tabs (>= (current-column) (car tabs))) - (setq tabs (cdr tabs))) - (if tabs - (let ((before (point))) - (move-to-column (car tabs) t) - (save-excursion - (goto-char before) - ;; If we just added a tab, or moved over one, - ;; delete any superfluous spaces before the old point. - (if (and (eq (char-before (point)) ?\ ) - (eq (char-after (point)) ?\t)) - (let ((tabend (* (/ (current-column) tab-width) tab-width))) - (while (and (> (current-column) tabend) - (eq (char-before (point)) ?\ )) - (forward-char -1)) - (delete-region (point) before)))))))) - -;(define-key global-map "\t" 'indent-for-tab-command) -;(define-key esc-map "\034" 'indent-region) -;(define-key ctl-x-map "\t" 'indent-rigidly) -;(define-key esc-map "i" 'tab-to-tab-stop) - -;;; indent.el ends here
--- a/lisp/prim/isearch-mode.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1610 +0,0 @@ -;; Incremental search minor mode. -;; Copyright (C) 1992, 1993 Free Software Foundation, Inc. - -;; LCD Archive Entry: -;; isearch-mode|Daniel LaLiberte|liberte@cs.uiuc.edu -;; |A minor mode replacement for isearch.el. - -;; 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, 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: Not synched with FSF. - -;;;==================================================================== -;; Instructions - -;; Searching with isearch-mode.el should work just like isearch.el, -;; except it is done in a temporary minor mode that terminates when -;; you finish searching. - -;; Semi-modal searching is supported, using a recursive edit. If -;; isearching is started non-interactively by calling one of the -;; isearch commands (e.g. (isearch-forward), but not like gnus does -;; it: (call-interactively 'isearch-forward)), isearch-mode does not -;; return until the search is completed. You should still be able -;; switch buffers, so be careful not to get things confused. - -;; The key bindings active within isearch-mode are defined below in -;; `isearch-mode-map' which is given bindings close to the default -;; characters of isearch.el for version 19. With `isearch-mode', -;; however, you can bind multi-character keys and it should be easier -;; to add new commands. One bug though: keys with meta-prefix cannot -;; be longer than two chars. Also see minibuffer-local-isearch-map -;; for bindings active during `isearch-edit-string'. - -;; The search ring and completion commands automatically put you in -;; the minibuffer to edit the string. This gives you a chance to -;; modify the search string before executing the search. There are -;; three commands to terminate the editing: C-s and C-r exit the -;; minibuffer and search forward and reverse respectively, while C-m -;; exits and does a nonincremental search. - -;; Exiting immediately from isearch uses isearch-edit-string instead -;; of nonincremental-search, if search-nonincremental-instead is non-nil. -;; The name of this option should probably be changed if we decide to -;; keep the behavior. One difference is that isearch-edit-string does -;; not support word search yet; perhaps isearch-mode should support it -;; even for incremental searches, but how? - -;;;==================================================================== -;;; Change History - -;;; Header: /import/kaplan/kaplan/liberte/Isearch/RCS/isearch-mode.el,v 1.3 92/06/29 13:10:08 liberte Exp Locker: liberte -;;; Log: isearch-mode.el,v -;;; -;;; 20-aug-92 Hacked by jwz for Lucid Emacs 19.3. -;;; -;;; Revision 1.3 92/06/29 13:10:08 liberte -;;; Moved modal isearch-mode handling into isearch-mode. -;;; Got rid of buffer-local isearch variables. -;;; isearch-edit-string used by ring adjustments, completion, and -;;; nonincremental searching. C-s and C-r are additional exit commands. -;;; Renamed all regex to regexp. -;;; Got rid of found-start and found-point globals. -;;; Generalized handling of upper-case chars. - -;;; Revision 1.2 92/05/27 11:33:57 liberte -;;; Emacs version 19 has a search ring, which is supported here. -;;; Other fixes found in the version 19 isearch are included here. -;;; -;;; Also see variables search-caps-disable-folding, -;;; search-nonincremental-instead, search-whitespace-regexp, and -;;; commands isearch-toggle-regexp, isearch-edit-string. -;;; -;;; semi-modal isearching is supported. - -;;; Changes for 1.1 -;;; 3/18/92 Fixed invalid-regexp. -;;; 3/18/92 Fixed yanking in regexps. - - -(defgroup isearch nil - "Incremental search" - :prefix "search-" - :group 'matching) - - -(defun isearch-char-to-string (c) - (if (eventp c) - (make-string 1 (event-to-character c nil nil t)) - (make-string 1 c))) - -;(defun isearch-text-char-description (c) -; (isearch-char-to-string c)) - -(define-function 'isearch-text-char-description 'text-char-description) - - -;;;========================================================================= -;;; User-accessible variables - -(defvar search-last-string "" - "Last string search for by a search command. -This does not include direct calls to the primitive search functions, -and does not include searches that are aborted.") - -(defvar search-last-regexp "" - "Last string searched for by a regexp search command. -This does not include direct calls to the primitive search functions, -and does not include searches that are aborted.") - -(defconst search-exit-option t - "Non-nil means random control characters terminate incremental search.") - -(defcustom search-slow-window-lines 1 - "*Number of lines in slow search display windows. -These are the short windows used during incremental search on slow terminals. -Negative means put the slow search window at the top (normally it's at bottom) -and the value is minus the number of lines." - :type 'integer - :group 'isearch) - -(defcustom search-slow-speed 1200 - "*Highest terminal speed at which to use \"slow\" style incremental search. -This is the style where a one-line window is created to show the line -that the search has reached." - :type 'integer - :group 'isearch) - -(defcustom search-caps-disable-folding t - "*If non-nil, upper case chars disable case fold searching. -This does not apply to \"yanked\" strings." - :type 'boolean - :group 'isearch) - -(defcustom search-nonincremental-instead t - "*If non-nil, do a nonincremental search instead if exiting immediately." - :type 'boolean - :group 'isearch) - -(defcustom search-whitespace-regexp "\\(\\s \\|[\n\r]\\)+" - "*If non-nil, regular expression to match a sequence of whitespace chars." - :type 'regexp - :group 'isearch) - -;;;================================================================== -;;; Search ring. - -(defvar search-ring nil - "List of search string sequences.") -(defvar regexp-search-ring nil - "List of regular expression search string sequences.") - -(defcustom search-ring-max 16 - "*Maximum length of search ring before oldest elements are thrown away." - :type 'integer - :group 'isearch) -(defcustom regexp-search-ring-max 16 - "*Maximum length of regexp search ring before oldest elements are thrown away." - :type 'integer - :group 'isearch) - -(defvar search-ring-yank-pointer nil - "The tail of the search ring whose car is the last thing searched for.") -(defvar regexp-search-ring-yank-pointer nil - "The tail of the regular expression search ring whose car is the last -thing searched for.") - -;;;==================================================== -;;; Define isearch-mode keymap. - -(defvar isearch-mode-map - (let ((map (make-keymap))) - (set-keymap-name map 'isearch-mode-map) - - ;; Bind all printing characters to `isearch-printing-char'. - ;; This isn't normally necessary, but if a printing character were - ;; bound to something other than self-insert-command in global-map, - ;; then it would terminate the search and be executed without this. - (let ((i 32) - (str (make-string 1 0))) - (while (< i 127) - (aset str 0 i) - (define-key map str 'isearch-printing-char) - (setq i (1+ i)))) - (define-key map "\t" 'isearch-printing-char) - - ;; Several non-printing chars change the searching behavior. - ;; - (define-key map "\C-s" 'isearch-repeat-forward) - (define-key map "\M-\C-s" 'isearch-repeat-forward) - (define-key map "\C-r" 'isearch-repeat-backward) - (define-key map "\C-g" 'isearch-abort) - - (define-key map "\C-q" 'isearch-quote-char) - - (define-key map "\C-m" 'isearch-exit) - (define-key map "\C-j" 'isearch-printing-char) - (define-key map "\t" 'isearch-printing-char) - - (define-key map "\C-w" 'isearch-yank-word) - (define-key map "\C-y" 'isearch-yank-line) - (define-key map "\M-y" 'isearch-yank-kill) - - ;; Define keys for regexp chars * ? | - (define-key map "*" 'isearch-*-char) - (define-key map "?" 'isearch-*-char) - (define-key map "|" 'isearch-|-char) - - ;; Some bindings you may want to put in your isearch-mode-hook. - ;; Suggest some alternates... - ;; (define-key map "\C-t" 'isearch-toggle-regexp) - ;; (define-key map "\C-^" 'isearch-edit-string) - - ;; delete and backspace delete backward, f1 is help, and C-h can be either - (define-key map 'delete 'isearch-delete-char) - (define-key map 'backspace 'isearch-delete-char) - (define-key map '(control h) 'isearch-help-or-delete-char) - (define-key map 'f1 'isearch-mode-help) - (define-key map 'help 'isearch-mode-help) - - (define-key map "\M-n" 'isearch-ring-advance) - (define-key map "\M-p" 'isearch-ring-retreat) - (define-key map "\M- " 'isearch-whitespace-chars) - (define-key map "\M-\t" 'isearch-complete) - - (define-key map 'button2 'isearch-yank-x-selection) - - map) - "Keymap for isearch-mode.") - -(defvar minibuffer-local-isearch-map - (let ((map (make-sparse-keymap))) - ;; #### - this should also be minor-mode-ified - (set-keymap-parents map (list minibuffer-local-map)) - (set-keymap-name map 'minibuffer-local-isearch-map) - - ;;#### This should just arrange to use the usual Emacs minibuffer histories - (define-key map "\r" 'isearch-nonincremental-exit-minibuffer) - (define-key map "\M-n" 'isearch-ring-advance-edit) - (define-key map "\M-p" 'isearch-ring-retreat-edit) - (define-key map "\M-\t" 'isearch-complete-edit) - (define-key map "\C-s" 'isearch-forward-exit-minibuffer) - (define-key map "\C-r" 'isearch-reverse-exit-minibuffer) - map) - "Keymap for editing isearch strings in the minibuffer.") - -;;;======================================================== -;; Internal variables declared globally for byte-compiler. -;; These are all bound locally while editing the search string. - -(defvar isearch-forward nil) ; Searching in the forward direction. -(defvar isearch-regexp nil) ; Searching for a regexp. -(defvar isearch-word nil) ; Searching for words. - -(defvar isearch-cmds nil) ; Stack of search status sets. -(defvar isearch-string "") ; The current search string. -(defvar isearch-message "") ; text-char-description version of isearch-string - -(defvar isearch-success t) ; Searching is currently successful. -(defvar isearch-invalid-regexp nil) ; Regexp not well formed. -(defvar isearch-other-end nil) ; Start (end) of match if forward (backward). -(defvar isearch-wrapped nil) ; Searching restarted from the top (bottom). -(defvar isearch-barrier 0) -(defvar isearch-buffer nil) ; the buffer we've frobbed the keymap of - -(defvar isearch-case-fold-search nil) - -(defvar isearch-adjusted nil) -(defvar isearch-slow-terminal-mode nil) -;;; If t, using a small window. -(defvar isearch-small-window nil) -(defvar isearch-opoint 0) -;;; The window configuration active at the beginning of the search. -(defvar isearch-window-configuration nil) -(defvar isearch-selected-frame nil) - -;; Flag to indicate a yank occurred, so don't move the cursor. -(defvar isearch-yank-flag nil) - -;;; A function to be called after each input character is processed. -;;; (It is not called after characters that exit the search.) -;;; It is only set from an optional argument to `isearch-mode'. -(defvar isearch-op-fun nil) - -;;; Is isearch-mode in a recursive edit for modal searching. -(defvar isearch-recursive-edit nil) - -;;; Should isearch be terminated after doing one search? -(defvar isearch-nonincremental nil) - -;; New value of isearch-forward after isearch-edit-string. -(defvar isearch-new-forward nil) - - -(defvar isearch-mode-hook nil - "Function(s) to call after starting up an incremental search.") - -(defvar isearch-mode-end-hook nil - "Function(s) to call after terminating an incremental search.") - -;;;============================================================== -;; Minor-mode-alist changes - kind of redundant with the -;; echo area, but if isearching in multiple windows, it can be useful. - -(add-minor-mode 'isearch-mode 'isearch-mode) - -(defvar isearch-mode nil) -(make-variable-buffer-local 'isearch-mode) - -;;;=============================================================== -;;; Entry points to isearch-mode. -;;; These four functions should replace those in loaddefs.el -;;; An alternative is to fset isearch-forward etc to isearch-mode, -;;; and look at the last command to set the options accordingly. - -(defun isearch-forward (&optional regexp-p) - "Do incremental search forward. -With a prefix argument, do an incremental regular expression search instead. -\\<isearch-mode-map> -As you type characters, they add to the search string and are found. -The following non-printing keys are bound in `isearch-mode-map'. - -Type \\[isearch-delete-char] to cancel characters from end of search string. -Type \\[isearch-exit] to exit, leaving point at location found. -Type LFD (C-j) to match end of line. -Type \\[isearch-repeat-forward] to search again forward,\ - \\[isearch-repeat-backward] to search again backward. -Type \\[isearch-yank-word] to yank word from buffer onto end of search\ - string and search for it. -Type \\[isearch-yank-line] to yank rest of line onto end of search string\ - and search for it. -Type \\[isearch-quote-char] to quote control character to search for it. -Type \\[isearch-whitespace-chars] to match all whitespace chars in regexp. -\\[isearch-abort] while searching or when search has failed cancels input\ - back to what has - been found successfully. -\\[isearch-abort] when search is successful aborts and moves point to\ - starting point. - -Also supported is a search ring of the previous 16 search strings. -Type \\[isearch-ring-advance] to search for the next item in the search ring. -Type \\[isearch-ring-retreat] to search for the previous item in the search\ - ring. -Type \\[isearch-complete] to complete the search string using the search ring. - -The above keys are bound in the isearch-mode-map. To change the keys which - are special to isearch-mode, simply change the bindings in that map. - -Other control and meta characters terminate the search - and are then executed normally (depending on `search-exit-option'). - -If this function is called non-interactively, it does not return to -the calling function until the search is done. - -The bindings, more precisely: -\\{isearch-mode-map}" - -;; Non-standard bindings -;; Type \\[isearch-toggle-regexp] to toggle regular expression with normal searching. -;; Type \\[isearch-edit-string] to edit the search string in the minibuffer. -;; Terminate editing and return to incremental searching with CR. - - (interactive "_P") - (isearch-mode t (not (null regexp-p)) nil (not (interactive-p)))) - -(defun isearch-forward-regexp () - "\ -Do incremental search forward for regular expression. -Like ordinary incremental search except that your input -is treated as a regexp. See \\[isearch-forward] for more info." - (interactive "_") - (isearch-mode t t nil (not (interactive-p)))) - -(defun isearch-backward (&optional regexp-p) - "\ -Do incremental search backward. -With a prefix argument, do an incremental regular expression search instead. -See \\[isearch-forward] for more information." - (interactive "_P") - (isearch-mode nil (not (null regexp-p)) nil (not (interactive-p)))) - -(defun isearch-backward-regexp () - "\ -Do incremental search backward for regular expression. -Like ordinary incremental search except that your input -is treated as a regexp. See \\[isearch-forward] for more info." - (interactive "_") - (isearch-mode nil t nil (not (interactive-p)))) - -;; This function is way wrong, because you can't scroll the help -;; screen; as soon as you press a key, it's gone. I don't know of a -;; good way to fix it, though. -hniksic -(defun isearch-mode-help () - (interactive "_") - (let ((w (selected-window))) - (describe-function 'isearch-forward) - (select-window w)) - (isearch-update)) - - -;;;================================================================== -;; isearch-mode only sets up incremental search for the minor mode. -;; All the work is done by the isearch-mode commands. - -(defun isearch-mode (forward &optional regexp op-fun recursive-edit word-p) - "Start isearch minor mode. Called by isearch-forward, etc." - - (if executing-kbd-macro (setq recursive-edit nil)) - - (let ((inhibit-quit t)) ; don't leave things in an inconsistent state... - - ;; Initialize global vars. - (setq isearch-buffer (current-buffer) - isearch-forward forward - isearch-regexp regexp - isearch-word word-p - isearch-op-fun op-fun - isearch-case-fold-search case-fold-search - isearch-string "" - isearch-message "" - isearch-cmds nil - isearch-success t - isearch-wrapped nil - isearch-barrier (point) - isearch-adjusted nil - isearch-yank-flag nil - isearch-invalid-regexp nil - isearch-slow-terminal-mode (and (<= (device-baud-rate) - search-slow-speed) - (> (window-height) - (* 4 search-slow-window-lines))) - isearch-other-end nil - isearch-small-window nil - - isearch-opoint (point) - isearch-window-configuration (current-window-configuration) - - ;; #### - don't do this statically: isearch-mode must be FIRST in - ;; the minor-mode-map-alist -- Stig - minor-mode-map-alist (cons (cons 'isearch-mode isearch-mode-map) - minor-mode-map-alist) - isearch-selected-frame (selected-frame) - - isearch-mode (gettext " Isearch") - ) - - ;; XEmacs change: without clearing the match data, sometimes old values - ;; of isearch-other-end get used. Don't ask me why... - (store-match-data nil) - - (add-hook 'pre-command-hook 'isearch-pre-command-hook) - (set-buffer-modified-p (buffer-modified-p)) ; update modeline - (isearch-push-state) - - ) ; inhibit-quit is t before here - - (isearch-update) - (run-hooks 'isearch-mode-hook) - - ;; isearch-mode can be made modal (in the sense of not returning to - ;; the calling function until searching is completed) by entering - ;; a recursive-edit and exiting it when done isearching. - (if recursive-edit - (let ((isearch-recursive-edit t)) - (recursive-edit))) - ) - - -;;;==================================================== -;; Some high level utilities. Others below. - -(defun isearch-update () - ;; Called after each command to update the display. - (if (null unread-command-event) - (progn - (if (not (input-pending-p)) - (isearch-message)) - (if (and isearch-slow-terminal-mode - (not (or isearch-small-window - (pos-visible-in-window-p)))) - (let ((found-point (point))) - (setq isearch-small-window t) - (move-to-window-line 0) - (let ((window-min-height 1)) - (split-window nil (if (< search-slow-window-lines 0) - (1+ (- search-slow-window-lines)) - (- (window-height) - (1+ search-slow-window-lines))))) - (if (< search-slow-window-lines 0) - (progn (vertical-motion (- 1 search-slow-window-lines)) - (set-window-start (next-window) (point)) - (set-window-hscroll (next-window) - (window-hscroll)) - (set-window-hscroll (selected-window) 0)) - (other-window 1)) - (goto-char found-point))) - (if isearch-other-end - (if (< isearch-other-end (point)) - (isearch-highlight isearch-other-end (point)) - (isearch-highlight (point) isearch-other-end)) - (if (extentp isearch-extent) - (isearch-dehighlight nil))) - )) - (setq ;; quit-flag nil not for isearch-mode - isearch-adjusted nil - isearch-yank-flag nil) - ) - - -(defun isearch-done () - ;; Called by all commands that terminate isearch-mode. - (let ((inhibit-quit t)) ; danger danger! - (if (and isearch-buffer (buffer-live-p isearch-buffer)) - (save-excursion - ;; Some loser process filter might have switched the - ;; window's buffer, so be sure to set these variables back - ;; in the buffer we frobbed them in. But only if the buffer - ;; is still alive. - (set-buffer isearch-buffer) - (setq minor-mode-map-alist (delq (assoc 'isearch-mode minor-mode-map-alist) - minor-mode-map-alist)) - ;; Use remove-hook instead of just setting it to our saved value - ;; in case some process filter has created a buffer and modified - ;; the pre-command-hook in that buffer... yeah, this is obscure, - ;; and yeah, I was getting screwed by it. -jwz - (remove-hook 'pre-command-hook 'isearch-pre-command-hook) - (set-keymap-parents isearch-mode-map nil) - (setq isearch-mode nil) - (set-buffer-modified-p (buffer-modified-p));; update modeline - (isearch-dehighlight t))) - - ;; it's not critical that this be inside inhibit-quit, but leaving - ;; things in small-window-mode would be bad. - (let ((found-start (window-start (selected-window))) - (found-point (point))) - (cond ((eq (selected-frame) isearch-selected-frame) - (set-window-configuration isearch-window-configuration) - - (if isearch-small-window - (goto-char found-point) - ;; Exiting the save-window-excursion clobbers - ;; window-start; restore it. - (set-window-start (selected-window) found-start t)))) - ;; If there was movement, mark the starting position. - ;; Maybe should test difference between and set mark iff > threshold. - (if (and (buffer-live-p isearch-buffer) - (/= (point isearch-buffer) isearch-opoint)) - (progn - (push-mark isearch-opoint t nil isearch-buffer) - (or executing-kbd-macro (> (minibuffer-depth) 0) - (display-message 'command "Mark saved where search started")))) - ) - (setq isearch-buffer nil) - ) ; inhibit-quit is t before here - - (if (> (length isearch-string) 0) - ;; Update the ring data. - (if isearch-regexp - (if (not (setq regexp-search-ring-yank-pointer - (member isearch-string regexp-search-ring))) - (progn - (setq regexp-search-ring - (cons isearch-string regexp-search-ring) - regexp-search-ring-yank-pointer regexp-search-ring) - (if (> (length regexp-search-ring) regexp-search-ring-max) - (setcdr (nthcdr (1- search-ring-max) regexp-search-ring) - nil)))) - (if (not (setq search-ring-yank-pointer - ;; really need equal test instead of eq. - (member isearch-string search-ring))) - (progn - (setq search-ring (cons isearch-string search-ring) - search-ring-yank-pointer search-ring) - (if (> (length search-ring) search-ring-max) - (setcdr (nthcdr (1- search-ring-max) search-ring) nil)))))) - - (run-hooks 'isearch-mode-end-hook) - (if isearch-recursive-edit (exit-recursive-edit))) - - -;;;==================================================== -;; Commands active while inside of the isearch minor mode. - -(defun isearch-exit () - "Exit search normally. -However, if this is the first command after starting incremental -search and `search-nonincremental-instead' is non-nil, do an -incremental search via `isearch-edit-string'." - (interactive) - (if (and search-nonincremental-instead - (= 0 (length isearch-string))) - (let ((isearch-nonincremental t)) - (isearch-edit-string)) - (isearch-done))) - - -(defun isearch-edit-string () - "Edit the search string in the minibuffer. -The following additional command keys are active while editing. -\\<minibuffer-local-isearch-map> -\\[exit-minibuffer] to exit editing and resume incremental searching. -\\[isearch-forward-exit-minibuffer] to resume isearching forward. -\\[isearch-backward-exit-minibuffer] to resume isearching backward. -\\[isearch-ring-advance-edit] to replace the search string with the next\ - item in the search ring. -\\[isearch-ring-retreat-edit] to replace the search string with the next\ - item in the search ring. -\\[isearch-complete-edit] to complete the search string from the search ring." - - ;; Editing doesn't back up the search point. Should it? - (interactive) - - (condition-case nil - (let ((minibuffer-local-map minibuffer-local-isearch-map) - isearch-nonincremental ; should search nonincrementally? - isearch-new-string - isearch-new-message - (isearch-new-forward isearch-forward) - - ;; Locally bind all isearch global variables to protect them - ;; from recursive isearching. - (isearch-string isearch-string) - (isearch-message isearch-message) - (isearch-forward isearch-forward) ; set by commands below. - - (isearch-forward isearch-forward) - (isearch-regexp isearch-regexp) - (isearch-word isearch-word) - (isearch-op-fun isearch-op-fun) - (isearch-cmds isearch-cmds) - (isearch-success isearch-success) - (isearch-wrapped isearch-wrapped) - (isearch-barrier isearch-barrier) - (isearch-adjusted isearch-adjusted) - (isearch-yank-flag isearch-yank-flag) - (isearch-invalid-regexp isearch-invalid-regexp) - (isearch-other-end isearch-other-end) - (isearch-opoint isearch-opoint) - (isearch-slow-terminal-mode isearch-slow-terminal-mode) - (isearch-small-window isearch-small-window) - (isearch-recursive-edit isearch-recursive-edit) - (isearch-window-configuration (current-window-configuration)) - (isearch-selected-frame (selected-frame)) - ) - ;; Actually terminate isearching until editing is done. - ;; This is so that the user can do anything without failure, - ;; like switch buffers and start another isearch, and return. -;; (condition-case nil - (isearch-done) - ;;#### What does this mean? There is no such condition! -;; (exit nil)) ; was recursive editing - - (unwind-protect - (let ((prompt (isearch-message-prefix nil t)) - event) - ;; If the first character the user types when we prompt them - ;; for a string is the yank-word character, then go into - ;; word-search mode. Otherwise unread that character and - ;; read a string the normal way. - (let ((cursor-in-echo-area t)) - (display-message 'prompt prompt) - (setq event (next-command-event)) - (if (eq 'isearch-yank-word - (lookup-key isearch-mode-map (vector event))) - (setq isearch-word t) - (setq unread-command-event event))) - (setq isearch-new-string -;; (if (fboundp 'gmhist-old-read-from-minibuffer) -;; ;; Eschew gmhist crockery -;; (gmhist-old-read-from-minibuffer prompt isearch-string) - (read-string - prompt isearch-string - 't ;does its own history (but shouldn't) -;; (if isearch-regexp -;; ;; The search-rings aren't exactly minibuffer -;; ;; histories, but they are close enough -;; (cons 'regexp-search-ring -;; (- (length regexp-search-ring-yank-pointer) -;; (length regexp-search-ring))) -;; (cons 'search-ring -;; (- (length search-ring-yank-pointer) -;; (length search-ring)))) - ) -;; ) - isearch-new-message (mapconcat - 'isearch-text-char-description - isearch-new-string "")) - ) - ;; Always resume isearching by restarting it. - (isearch-mode isearch-forward - isearch-regexp - isearch-op-fun - isearch-recursive-edit - isearch-word) - ) - - ;; Copy new values in outer locals to isearch globals - (setq isearch-string isearch-new-string - isearch-message isearch-new-message - isearch-forward isearch-new-forward) - - ;; Empty isearch-string means use default. - (if (= 0 (length isearch-string)) - (setq isearch-string (if isearch-regexp search-last-regexp - search-last-string)) - ;; Set last search string now so it is set even if we fail. - (if search-last-regexp - (setq search-last-regexp isearch-string) - (setq search-last-string isearch-string))) - - ;; Reinvoke the pending search. - (isearch-push-state) - (isearch-search) - (isearch-update) - (if isearch-nonincremental (isearch-done))) - - (quit ; handle abort-recursive-edit - (isearch-abort) ;; outside of let to restore outside global values - ))) - -(defun isearch-nonincremental-exit-minibuffer () - (interactive) - (setq isearch-nonincremental t) - (exit-minibuffer)) - -(defun isearch-forward-exit-minibuffer () - (interactive) - (setq isearch-new-forward t) - (exit-minibuffer)) - -(defun isearch-reverse-exit-minibuffer () - (interactive) - (setq isearch-new-forward nil) - (exit-minibuffer)) - - -(defun isearch-abort () - "Quit incremental search mode if searching is successful, signalling quit. -Otherwise, revert to previous successful search and continue searching. -Use `isearch-exit' to quit without signalling." - (interactive) -;; (ding) signal instead below, if quiting - (discard-input) - (if isearch-success - ;; If search is successful, move back to starting point - ;; and really do quit. - (progn (goto-char isearch-opoint) - (isearch-done) ; exit isearch - (signal 'quit '(isearch))) ; and pass on quit signal - ;; If search is failing, rub out until it is once more successful. - (while (not isearch-success) (isearch-pop-state)) - (isearch-update))) - - -(defun isearch-repeat (direction) - ;; Utility for isearch-repeat-forward and -backward. - (if (eq isearch-forward (eq direction 'forward)) - ;; C-s in forward or C-r in reverse. - (if (equal isearch-string "") - ;; If search string is empty, use last one. - (setq isearch-string - (or (if isearch-regexp - (if regexp-search-ring-yank-pointer - (car regexp-search-ring-yank-pointer) - (car regexp-search-ring)) - (if search-ring-yank-pointer - (car search-ring-yank-pointer) - (car search-ring))) - "") - isearch-message - (mapconcat 'isearch-text-char-description - isearch-string "")) - ;; If already have what to search for, repeat it. - (or isearch-success - (progn - - (goto-char (if isearch-forward (point-min) (point-max))) - (setq isearch-wrapped t)))) - ;; C-s in reverse or C-r in forward, change direction. - (setq isearch-forward (not isearch-forward))) - - (setq isearch-barrier (point)) ; For subsequent \| if regexp. - (setq isearch-success t) - (or (equal isearch-string "") - ;; If repeating a search that found - ;; an empty string, ensure we advance. - (if (equal (match-end 0) (match-beginning 0)) - (if (if isearch-forward (eobp) (bobp)) - ;; nowhere to advance to, so fail (and wrap next time) - (progn - (setq isearch-success nil) - (and executing-kbd-macro - (not defining-kbd-macro) - (isearch-done)) - (ding nil 'isearch-failed)) - (forward-char (if isearch-forward 1 -1)) - (isearch-search)) - (isearch-search))) - (isearch-push-state) - (isearch-update)) - -(defun isearch-repeat-forward () - "Repeat incremental search forwards." - (interactive) - (isearch-repeat 'forward)) - -(defun isearch-repeat-backward () - "Repeat incremental search backwards." - (interactive) - (isearch-repeat 'backward)) - -(defun isearch-toggle-regexp () - "Toggle regexp searching on or off." - ;; The status stack is left unchanged. - (interactive) - (setq isearch-regexp (not isearch-regexp)) - (if isearch-regexp (setq isearch-word nil)) - (isearch-update)) - -(defun isearch-toggle-case-fold () - "Toggle case folding in searching on or off." - (interactive) - (setq isearch-case-fold-search - (if isearch-case-fold-search nil 'yes)) - (message "%s%s [case %ssensitive]" - (isearch-message-prefix) - isearch-message - (if isearch-case-fold-search "in" "")) - (setq isearch-adjusted t) - (sit-for 1) - (isearch-update)) - -(defun isearch-delete-char () - "Discard last input item and move point back. -If no previous match was done, just beep." - (interactive) - (if (null (cdr isearch-cmds)) - (ding nil 'isearch-quit) - (isearch-pop-state)) - (isearch-update)) - -(defun isearch-help-or-delete-char () - "Show Isearch help or delete backward in the search string. -Deletes when `delete-key-deletes-forward' is t and C-h is used for deleting -backwards." - (interactive) - (if (and delete-key-deletes-forward - (case (device-type) - ('tty (eq tty-erase-char ?\C-h)) - ('x (not (x-keysym-on-keyboard-p "BackSpace"))))) - (isearch-delete-char) - (isearch-mode-help))) - -(defun isearch-yank (chunk) - ;; Helper for isearch-yank-* functions. CHUNK can be a string or a - ;; function. - (let ((word (if (stringp chunk) - chunk - (save-excursion - (and (not isearch-forward) isearch-other-end - (goto-char isearch-other-end)) - (buffer-substring - (point) - (save-excursion - (funcall chunk) - (point))))))) - ;; if configured so that typing upper-case characters turns off case - ;; folding, then downcase the string so that yanking an upper-case - ;; word doesn't mess with case-foldedness. - (if (and search-caps-disable-folding isearch-case-fold-search) - (setq word (downcase word))) - (if isearch-regexp (setq word (regexp-quote word))) - (setq isearch-string (concat isearch-string word) - isearch-message - (concat isearch-message - (mapconcat 'isearch-text-char-description - word "")) - ;; Don't move cursor in reverse search. - isearch-yank-flag t)) - (isearch-search-and-update)) - - -(defun isearch-yank-word () - "Pull next word from buffer into search string." - (interactive) - (isearch-yank (function (lambda () (forward-word 1))))) - -(defun isearch-yank-line () - "Pull rest of line from buffer into search string." - (interactive) - (isearch-yank 'end-of-line)) - -(defun isearch-yank-kill () - "Pull rest of line from kill ring into search string." - (interactive) - (isearch-yank (current-kill 0))) - -(defun isearch-yank-sexp () - "Pull next expression from buffer into search string." - (interactive) - (isearch-yank 'forward-sexp)) - -(defun isearch-yank-x-selection () - "Pull the current X selection into the search string." - (interactive) - (isearch-yank (x-get-selection))) - -(defun isearch-yank-x-clipboard () - "Pull the current X clipboard selection into the search string." - (interactive) - (isearch-yank (x-get-clipboard))) - -(defun isearch-search-and-update () - ;; Do the search and update the display. - (if (and (not isearch-success) - ;; unsuccessful regexp search may become - ;; successful by addition of characters which - ;; make isearch-string valid - (not isearch-regexp)) - nil - ;; In reverse search, adding stuff at - ;; the end may cause zero or many more chars to be - ;; matched, in the string following point. - ;; Allow all those possibilities without moving point as - ;; long as the match does not extend past search origin. - (if (and (not isearch-forward) (not isearch-adjusted) - (condition-case () - (looking-at (if isearch-regexp isearch-string - (regexp-quote isearch-string))) - (error nil)) - (or isearch-yank-flag - (<= (match-end 0) - (min isearch-opoint isearch-barrier)))) - (setq isearch-success t - isearch-invalid-regexp nil - isearch-other-end (match-end 0)) - ;; Not regexp, not reverse, or no match at point. - (if (and isearch-other-end (not isearch-adjusted)) - (goto-char (if isearch-forward isearch-other-end - (min isearch-opoint - isearch-barrier - (1+ isearch-other-end))))) - (isearch-search) - )) - (isearch-push-state) - (if isearch-op-fun (funcall isearch-op-fun)) - (isearch-update)) - - -;; *, ?, and | chars can make a regexp more liberal. -;; They can make a regexp match sooner -;; or make it succeed instead of failing. -;; So go back to place last successful search started -;; or to the last ^S/^R (barrier), whichever is nearer. - -(defun isearch-*-char () - "Handle * and ? specially in regexps." - (interactive) - (if isearch-regexp - - (progn - (setq isearch-adjusted t) - (let ((cs (nth (if isearch-forward - 5 ; isearch-other-end - 2) ; saved (point) - (car (cdr isearch-cmds))))) - ;; (car isearch-cmds) is after last search; - ;; (car (cdr isearch-cmds)) is from before it. - (setq cs (or cs isearch-barrier)) - (goto-char - (if isearch-forward - (max cs isearch-barrier) - (min cs isearch-barrier)))))) - (isearch-process-search-char last-command-event)) - - - -(defun isearch-|-char () - "If in regexp search, jump to the barrier." - (interactive) - (if isearch-regexp - (progn - (setq isearch-adjusted t) - (goto-char isearch-barrier))) - (isearch-process-search-char last-command-event)) - -(defun isearch-quote-char () - "Quote special characters for incremental search." - (interactive) - (isearch-process-search-char (read-quoted-char (isearch-message t)))) - - -(defun isearch-return-char () - "Convert return into newline for incremental search. -Obsolete." - (interactive) - (isearch-process-search-char ?\n)) - - -(defun isearch-printing-char () - "Any other printing character => add it to the search string and search." - (interactive) - (isearch-process-search-char last-command-event)) - - -(defun isearch-whitespace-chars () - "Match all whitespace chars, if in regexp mode." - (interactive) - (if (and isearch-regexp search-whitespace-regexp) - (isearch-process-search-string search-whitespace-regexp " ") - (beep) - (isearch-process-search-char ?\ ) -; (if isearch-word -; nil -; (setq isearch-word t) -; (goto-char isearch-other-end) -; (isearch-process-search-char ?\ )) - )) - -(defun isearch-process-search-char (char) - ;; Append the char to the search string, update the message and re-search. - (isearch-process-search-string (isearch-char-to-string char) - (isearch-text-char-description char))) - -(defun isearch-process-search-string (string message) - (setq isearch-string (concat isearch-string string) - isearch-message (concat isearch-message message)) - (isearch-search-and-update)) - - -;;=========================================================== -;; Search Ring - -(defcustom search-ring-update nil - "*Non-nil if advancing or retreating in the search ring should cause search. -Default nil means edit the string from the search ring first." - :type 'boolean - :group 'isearch) - -(defun isearch-ring-adjust1 (advance) - ;; Helper for isearch-ring-adjust - (let* ((ring (if isearch-regexp regexp-search-ring search-ring)) - (length (length ring)) - (yank-pointer-name (if isearch-regexp - 'regexp-search-ring-yank-pointer - 'search-ring-yank-pointer)) - (yank-pointer (eval yank-pointer-name))) - (if (zerop length) - () - (set yank-pointer-name - (setq yank-pointer - (nthcdr (% (+ (- length (length yank-pointer)) - (if advance (1- length) 1)) - length) ring))) - (setq isearch-string (car yank-pointer) - isearch-message (mapconcat 'isearch-text-char-description - isearch-string ""))))) - -(defun isearch-ring-adjust (advance) - ;; Helper for isearch-ring-advance and isearch-ring-retreat - (if (cdr isearch-cmds) ;; is there more than one thing on stack? - (isearch-pop-state)) - (isearch-ring-adjust1 advance) - (isearch-push-state) - (if search-ring-update - (progn - (isearch-search) - (isearch-update)) - (isearch-edit-string) - )) - -(defun isearch-ring-advance () - "Advance to the next search string in the ring." - ;; This could be more general to handle a prefix arg, but who would use it. - (interactive) - (isearch-ring-adjust 'advance)) - -(defun isearch-ring-retreat () - "Retreat to the previous search string in the ring." - (interactive) - (isearch-ring-adjust nil)) - -(defun isearch-ring-adjust-edit (advance) - "Use the next or previous search string in the ring while in minibuffer." - (isearch-ring-adjust1 advance) - (erase-buffer) - (insert isearch-string)) - -(defun isearch-ring-advance-edit () - (interactive) - (isearch-ring-adjust-edit 'advance)) - -(defun isearch-ring-retreat-edit () - "Retreat to the previous search string in the ring while in the minibuffer." - (interactive) - (isearch-ring-adjust-edit nil)) - - -(defun isearch-complete1 () - ;; Helper for isearch-complete and isearch-complete-edit - ;; Return t if completion OK, - (let* ((ring (if isearch-regexp regexp-search-ring search-ring)) - (alist (mapcar (function (lambda (string) (list string))) ring)) - (completion-ignore-case case-fold-search) - (completion (try-completion isearch-string alist)) - ) - (cond - ((eq completion t) - ;; isearch-string stays the same - t) - ((or completion ; not nil, must be a string - (= 0 (length isearch-string))) ; shouldn't have to say this - (if (equal completion isearch-string) ;; no extension? - (if completion-auto-help - (with-output-to-temp-buffer "*Isearch completions*" - (display-completion-list - (all-completions isearch-string alist)))) - (setq isearch-string completion)) - t) - (t - (temp-minibuffer-message "No completion") - nil)))) - -(defun isearch-complete () - "Complete the search string from the strings on the search ring. -The completed string is then editable in the minibuffer. -If there is no completion possible, say so and continue searching." - (interactive) - (if (isearch-complete1) - (isearch-edit-string) - ;; else - (sit-for 1) - (isearch-update))) - -(defun isearch-complete-edit () - "Same as `isearch-complete' except in the minibuffer." - (interactive) - (setq isearch-string (buffer-string)) - (if (isearch-complete1) - (progn - (erase-buffer) - (insert isearch-string)))) - - -;;;============================================================== -;; The search status stack (and isearch window-local variables, not used). - -(defun isearch-top-state () -;; (fetch-window-local-variables) - (let ((cmd (car isearch-cmds))) - (setq isearch-string (car cmd) - isearch-message (car (cdr cmd)) - isearch-success (nth 3 cmd) - isearch-forward (nth 4 cmd) - isearch-other-end (nth 5 cmd) - isearch-invalid-regexp (nth 6 cmd) - isearch-wrapped (nth 7 cmd) - isearch-barrier (nth 8 cmd)) - (goto-char (car (cdr (cdr cmd)))))) - -(defun isearch-pop-state () -;; (fetch-window-local-variables) - (setq isearch-cmds (cdr isearch-cmds)) - (isearch-top-state) - ) - -(defun isearch-push-state () - (setq isearch-cmds - (cons (list isearch-string isearch-message (point) - isearch-success isearch-forward isearch-other-end - isearch-invalid-regexp isearch-wrapped isearch-barrier) - isearch-cmds))) - - -;;;================================================================== -;; Message string - -(defun isearch-message (&optional c-q-hack ellipsis) - ;; Generate and print the message string. - (let ((cursor-in-echo-area ellipsis) - (m (concat - (isearch-message-prefix c-q-hack) - isearch-message - (isearch-message-suffix c-q-hack) - ))) - (if c-q-hack m (display-message 'progress (format "%s" m))))) - -(defun isearch-message-prefix (&optional c-q-hack nonincremental) - ;; If about to search, and previous search regexp was invalid, - ;; check that it still is. If it is valid now, - ;; let the message we display while searching say that it is valid. - (and isearch-invalid-regexp - (condition-case () - (progn (re-search-forward isearch-string (point) t) - (setq isearch-invalid-regexp nil)) - (error nil))) - ;; #### - Yo! Emacs assembles strings all over the place, they can't all - ;; be internationalized in the manner proposed below... Add an explicit - ;; call to `gettext' and have the string snarfer pluck the english - ;; strings out of the comment below. XEmacs is on a purespace diet! -Stig - (let ((m (concat (if isearch-success nil "failing ") - (if isearch-wrapped "wrapped ") - (if isearch-word "word ") - (if isearch-regexp "regexp ") - (if nonincremental "search" "I-search") - (if isearch-forward nil " backward") - ": " - ))) - (aset m 0 (upcase (aref m 0))) - (gettext m))) - -(defun isearch-message-suffix (&optional c-q-hack) - (concat (if c-q-hack "^Q" "") - (if isearch-invalid-regexp - (concat " [" isearch-invalid-regexp "]") - ""))) - -;;;;; #### - yuck...this is soooo lame. Is this really worth 4k of purespace??? -;;; -;;;(let ((i (logior (if isearch-success 32 0) -;;; (if isearch-wrapped 16 0) -;;; (if isearch-word 8 0) -;;; (if isearch-regexp 4 0) -;;; (if nonincremental 2 0) -;;; (if isearch-forward 1 0)))) -;;; (cond -;;; ((= i 63) (gettext "Wrapped word regexp search: ")) ; 111111 -;;; ((= i 62) (gettext "Wrapped word regexp search backward: ")) ; 111110 -;;; ((= i 61) (gettext "Wrapped word regexp I-search: ")) ; 111101 -;;; ((= i 60) (gettext "Wrapped word regexp I-search backward: ")) ; 111100 -;;; ((= i 59) (gettext "Wrapped word search: ")) ; 111011 -;;; ((= i 58) (gettext "Wrapped word search backward: ")) ; 111010 -;;; ((= i 57) (gettext "Wrapped word I-search: ")) ; 111001 -;;; ((= i 56) (gettext "Wrapped word I-search backward: ")) ; 111000 -;;; ((= i 55) (gettext "Wrapped regexp search: ")) ; 110111 -;;; ((= i 54) (gettext "Wrapped regexp search backward: ")) ; 110110 -;;; ((= i 53) (gettext "Wrapped regexp I-search: ")) ; 110101 -;;; ((= i 52) (gettext "Wrapped regexp I-search backward: ")) ; 110100 -;;; ((= i 51) (gettext "Wrapped search: ")) ; 110011 -;;; ((= i 50) (gettext "Wrapped search backward: ")) ; 110010 -;;; ((= i 49) (gettext "Wrapped I-search: ")) ; 110001 -;;; ((= i 48) (gettext "Wrapped I-search backward: ")) ; 110000 -;;; ((= i 47) (gettext "Word regexp search: ")) ; 101111 -;;; ((= i 46) (gettext "Word regexp search backward: ")) ; 101110 -;;; ((= i 45) (gettext "Word regexp I-search: ")) ; 101101 -;;; ((= i 44) (gettext "Word regexp I-search backward: ")) ; 101100 -;;; ((= i 43) (gettext "Word search: ")) ; 101011 -;;; ((= i 42) (gettext "Word search backward: ")) ; 101010 -;;; ((= i 41) (gettext "Word I-search: ")) ; 101001 -;;; ((= i 40) (gettext "Word I-search backward: ")) ; 101000 -;;; ((= i 39) (gettext "Regexp search: ")) ; 100111 -;;; ((= i 38) (gettext "Regexp search backward: ")) ; 100110 -;;; ((= i 37) (gettext "Regexp I-search: ")) ; 100101 -;;; ((= i 36) (gettext "Regexp I-search backward: ")) ; 100100 -;;; ((= i 35) (gettext "Search: ")) ; 100011 -;;; ((= i 34) (gettext "Search backward: ")) ; 100010 -;;; ((= i 33) (gettext "I-search: ")) ; 100001 -;;; ((= i 32) (gettext "I-search backward: ")) ; 100000 -;;; ((= i 31) (gettext "Failing wrapped word regexp search: ")) ; 011111 -;;; ((= i 30) (gettext "Failing wrapped word regexp search backward: ")) ; 011110 -;;; ((= i 29) (gettext "Failing wrapped word regexp I-search: ")) ; 011101 -;;; ((= i 28) (gettext "Failing wrapped word regexp I-search backward: ")) ; 011100 -;;; ((= i 27) (gettext "Failing wrapped word search: ")) ; 011011 -;;; ((= i 26) (gettext "Failing wrapped word search backward: ")) ; 011010 -;;; ((= i 25) (gettext "Failing wrapped word I-search: ")) ; 011001 -;;; ((= i 24) (gettext "Failing wrapped word I-search backward: ")) ; 011000 -;;; ((= i 23) (gettext "Failing wrapped regexp search: ")) ; 010111 -;;; ((= i 22) (gettext "Failing wrapped regexp search backward: ")) ; 010110 -;;; ((= i 21) (gettext "Failing wrapped regexp I-search: ")) ; 010101 -;;; ((= i 20) (gettext "Failing wrapped regexp I-search backward: ")) ; 010100 -;;; ((= i 19) (gettext "Failing wrapped search: ")) ; 010011 -;;; ((= i 18) (gettext "Failing wrapped search backward: ")) ; 010010 -;;; ((= i 17) (gettext "Failing wrapped I-search: ")) ; 010001 -;;; ((= i 16) (gettext "Failing wrapped I-search backward: ")) ; 010000 -;;; ((= i 15) (gettext "Failing word regexp search: ")) ; 001111 -;;; ((= i 14) (gettext "Failing word regexp search backward: ")) ; 001110 -;;; ((= i 13) (gettext "Failing word regexp I-search: ")) ; 001101 -;;; ((= i 12) (gettext "Failing word regexp I-search backward: ")) ; 001100 -;;; ((= i 11) (gettext "Failing word search: ")) ; 001011 -;;; ((= i 10) (gettext "Failing word search backward: ")) ; 001010 -;;; ((= i 9) (gettext "Failing word I-search: ")) ; 001001 -;;; ((= i 8) (gettext "Failing word I-search backward: ")) ; 001000 -;;; ((= i 7) (gettext "Failing regexp search: ")) ; 000111 -;;; ((= i 6) (gettext "Failing regexp search backward: ")) ; 000110 -;;; ((= i 5) (gettext "Failing regexp I-search: ")) ; 000101 -;;; ((= i 4) (gettext "Failing regexp I-search backward: ")) ; 000100 -;;; ((= i 3) (gettext "Failing search: ")) ; 000011 -;;; ((= i 2) (gettext "Failing search backward: ")) ; 000010 -;;; ((= i 1) (gettext "Failing I-search: ")) ; 000001 -;;; ((= i 0) (gettext "Failing I-search backward: ")) ; 000000 -;;; (t (error "Something's rotten"))))) - - -;;;======================================================== -;;; Exiting - -(put 'isearch-printing-char 'isearch-command t) -(put 'isearch-return-char 'isearch-command t) -(put 'isearch-repeat-forward 'isearch-command t) -(put 'isearch-repeat-backward 'isearch-command t) -(put 'isearch-delete-char 'isearch-command t) -(put 'isearch-help-or-delete-char 'isearch-command t) -(put 'isearch-abort 'isearch-command t) -(put 'isearch-quote-char 'isearch-command t) -(put 'isearch-exit 'isearch-command t) -(put 'isearch-printing-char 'isearch-command t) -(put 'isearch-printing-char 'isearch-command t) -(put 'isearch-yank-word 'isearch-command t) -(put 'isearch-yank-line 'isearch-command t) -(put 'isearch-yank-kill 'isearch-command t) -(put 'isearch-yank-sexp 'isearch-command t) -(put 'isearch-*-char 'isearch-command t) -(put 'isearch-*-char 'isearch-command t) -(put 'isearch-|-char 'isearch-command t) -(put 'isearch-toggle-regexp 'isearch-command t) -(put 'isearch-toggle-case-fold 'isearch-command t) -(put 'isearch-edit-string 'isearch-command t) -(put 'isearch-mode-help 'isearch-command t) -(put 'isearch-ring-advance 'isearch-command t) -(put 'isearch-ring-retreat 'isearch-command t) -(put 'isearch-ring-advance-edit 'isearch-command t) -(put 'isearch-ring-retreat-edit 'isearch-command t) -(put 'isearch-whitespace-chars 'isearch-command t) -(put 'isearch-complete 'isearch-command t) -(put 'isearch-complete-edit 'isearch-command t) -(put 'isearch-edit-string 'isearch-command t) -(put 'isearch-toggle-regexp 'isearch-command t) -(put 'isearch-forward-exit-minibuffer 'isearch-command t) -(put 'isearch-reverse-exit-minibuffer 'isearch-command t) -(put 'isearch-nonincremental-exit-minibuffer 'isearch-command t) -(put 'isearch-yank-x-selection 'isearch-command t) -(put 'isearch-yank-x-clipboard 'isearch-command t) - -;; scrolling the scrollbar should not terminate isearch. - -;; vertical scrollbar: -(put 'scrollbar-line-up 'isearch-command t) -(put 'scrollbar-line-down 'isearch-command t) -(put 'scrollbar-page-up 'isearch-command t) -(put 'scrollbar-page-down 'isearch-command t) -(put 'scrollbar-to-top 'isearch-command t) -(put 'scrollbar-to-bottom 'isearch-command t) -(put 'scrollbar-vertical-drag 'isearch-command t) - -;; horizontal scrollbar: -(put 'scrollbar-char-left 'isearch-command t) -(put 'scrollbar-char-right 'isearch-command t) -(put 'scrollbar-page-left 'isearch-command t) -(put 'scrollbar-page-right 'isearch-command t) -(put 'scrollbar-to-left 'isearch-command t) -(put 'scrollbar-to-right 'isearch-command t) -(put 'scrollbar-horizontal-drag 'isearch-command t) - -(defun isearch-pre-command-hook () - ;; - ;; For use as the value of `pre-command-hook' when isearch-mode is active. - ;; If the command about to be executed is not one of the isearch commands, - ;; then isearch-mode is turned off before that command is executed. - ;; - ;; If the command about to be executed is self-insert-command, or is a - ;; keyboard macro of a single key sequence which is bound to self-insert- - ;; command, then we add those chars to the search ring instead of inserting - ;; them in the buffer. In this way, the set of self-searching characters - ;; need not be exhaustively enumerated, but is derived from other maps. - ;; - (cond ((not (eq (current-buffer) isearch-buffer)) - ;; If the buffer (likely meaning "frame") has changed, bail. - ;; This can also happen if a proc filter has popped up another - ;; buffer, which is arguably a bad thing for it to have done, - ;; but the way in which isearch would have hosed you in that - ;; case is unarguably even worse. -jwz - (isearch-done)) - (t - (isearch-maybe-frob-keyboard-macros) - (if (and this-command - (symbolp this-command) - (get this-command 'isearch-command)) - nil ; then continue. - (isearch-done))))) - -(defun isearch-maybe-frob-keyboard-macros () - ;; - ;; If the command about to be executed is `self-insert-command' then change - ;; the command to `isearch-printing-char' instead, meaning add the last- - ;; typed character to the search string. - ;; - ;; If `this-command' is a string or a vector (that is, a keyboard macro) - ;; and it contains only one command, which is bound to self-insert-command, - ;; then do the same thing as for self-inserting commands: arrange for that - ;; character to be added to the search string. If we didn't do this, then - ;; typing a compose sequence (a la x-compose.el) would terminate the search - ;; and insert the character, instead of searching for that character. - ;; - ;; We should continue doing this, since it's pretty much the behavior one - ;; would expect, but it will stop being so necessary once key-translation- - ;; map exists and is used by x-compose.el and things like it, since the - ;; translation will have been done before we see the keys. - ;; - (cond ((eq this-command 'self-insert-command) - (setq this-command 'isearch-printing-char)) - ((and (or (stringp this-command) (vectorp this-command)) - (eq (key-binding this-command) 'self-insert-command)) - (setq last-command-event (character-to-event (aref this-command 0)) - last-command-char (and (stringp this-command) - (aref this-command 0)) - this-command 'isearch-printing-char)) - )) - - -;;;======================================================== -;;; Highlighting - -(defcustom isearch-highlight t - "*Whether isearch and query-replace should highlight the text which -currently matches the search-string.") - -(defvar isearch-extent nil) - -;; this face is initialized by x-faces.el since isearch is preloaded. -;; this face is now created in initialize-faces -;;(make-face 'isearch) - -(defun isearch-make-extent (begin end) - (let ((x (make-extent begin end (current-buffer)))) - ;; make the isearch extent always take prescedence over any mouse- - ;; highlighted extents we may be passing through, since isearch, being - ;; modal, is more interesting (there's nothing they could do with a - ;; mouse-highlighted extent while in the midst of a search anyway). - (set-extent-priority x (1+ mouse-highlight-priority)) - (set-extent-face x 'isearch) - (setq isearch-extent x))) - -(defun isearch-highlight (begin end) - (if (null isearch-highlight) - nil - ;; make sure isearch-extent is in the current buffer - (cond ((not (extentp isearch-extent)) - (isearch-make-extent begin end)) - ((not (eq (extent-object isearch-extent) (current-buffer))) - (delete-extent isearch-extent) - (isearch-make-extent begin end))) - (set-extent-endpoints isearch-extent begin end))) - -(defun isearch-dehighlight (totally) - (if (and isearch-highlight isearch-extent) - (if totally - (let ((inhibit-quit t)) - (if (extentp isearch-extent) - (delete-extent isearch-extent)) - (setq isearch-extent nil)) - (if (extentp isearch-extent) - (detach-extent isearch-extent) - (setq isearch-extent nil))))) - - -;;;======================================================== -;;; Searching - -(defun isearch-search () - ;; Do the search with the current search string. - (isearch-message nil t) - (if (and isearch-case-fold-search search-caps-disable-folding) - (setq isearch-case-fold-search (isearch-no-upper-case-p isearch-string))) - - (setq isearch-mode (if case-fold-search - (if isearch-case-fold-search - " Isearch" ;As God Intended Mode - " ISeARch") ;Warn about evil case via StuDLYcAps. - "Isearch" -; (if isearch-case-fold-search -; " isearch" ;Presumably case-sensitive losers -; ;will notice this 1-char difference. -; " Isearch") ;Weenie mode. - )) - (condition-case lossage - (let ((inhibit-quit nil) - (case-fold-search isearch-case-fold-search)) - (if isearch-regexp (setq isearch-invalid-regexp nil)) - (setq isearch-success - (funcall - (cond (isearch-word - (if isearch-forward - 'word-search-forward 'word-search-backward)) - (isearch-regexp - (if isearch-forward - 're-search-forward 're-search-backward)) - (t - (if isearch-forward 'search-forward 'search-backward))) - isearch-string nil t)) - (if isearch-success - (setq isearch-other-end - (if isearch-forward (match-beginning 0) (match-end 0))))) - - (quit (setq unread-command-event (character-to-event (quit-char))) - (setq isearch-success nil)) - - (invalid-regexp - (setq isearch-invalid-regexp (car (cdr lossage))) - (if (string-match - "\\`Premature \\|\\`Unmatched \\|\\`Invalid " - isearch-invalid-regexp) - (setq isearch-invalid-regexp (gettext "incomplete input"))))) - - (if isearch-success - nil - - ;; If we're being run inside a keyboard macro, then the call to - ;; ding will signal an error (to terminate the macro). We must - ;; turn off isearch-mode first, so that we aren't still in isearch - ;; mode after the macro exits. Note that isearch-recursive-edit - ;; must not be true if a keyboard macro is executing. - (if (and executing-kbd-macro (not defining-kbd-macro)) - (progn - (isearch-done) - (ding nil 'isearch-failed))) - - ;; Ding if failed this time after succeeding last time. - (and (nth 3 (car isearch-cmds)) - (ding nil 'isearch-failed)) - (goto-char (nth 2 (car isearch-cmds))))) - -;;;================================================= -;; This is called from incremental-search -;; if the first input character is the exit character. - -;; We store the search string in `isearch-string' -;; which has been bound already by `isearch-search' -;; so that, when we exit, it is copied into `search-last-string'. - -;(defun nonincremental-search (forward regexp) -; ;; This may be broken. Anyway, it is replaced by the isearch-edit-string. -; ;; Missing features: word search option, command history. -; (setq isearch-forward forward -; isearch-regexp regexp) -; (let (char function -; inhibit-quit -; (cursor-in-echo-area t)) -; ;; Prompt assuming not word search, -; (setq isearch-message -; (if isearch-regexp -; (if isearch-forward "Regexp search: " -; "Regexp search backward: ") -; (if isearch-forward "Search: " "Search backward: "))) -; (message "%s" isearch-message) -; ;; Read 1 char and switch to word search if it is ^W. -; (setq char (read-char)) -; (if (eq char search-yank-word-char) -; (setq isearch-message (if isearch-forward "Word search: " -; "Word search backward: ")) -; ;; Otherwise let that 1 char be part of the search string. -; (setq unread-command-event (character-to-event char)) -; ) -; (setq function -; (if (eq char search-yank-word-char) -; (if isearch-forward 'word-search-forward 'word-search-backward) -; (if isearch-regexp -; (if isearch-forward 're-search-forward 're-search-backward) -; (if isearch-forward 'search-forward 'search-backward)))) -; ;; Read the search string with corrected prompt. -; (setq isearch-string (read-string isearch-message isearch-string)) -; ;; Empty means use default. -; (if (= 0 (length isearch-string)) -; (setq isearch-string search-last-string) -; ;; Set last search string now so it is set even if we fail. -; (setq search-last-string isearch-string)) -; ;; Since we used the minibuffer, we should be available for redo. -; (setq command-history -; (cons (list function isearch-string) command-history)) -; ;; Go ahead and search. -; (if search-caps-disable-folding -; (setq isearch-case-fold-search -; (isearch-no-upper-case-p isearch-string))) -; (let ((case-fold-search isearch-case-fold-search)) -; (funcall function isearch-string)))) - - -(defun isearch-no-upper-case-p (string) - "Return t if there are no upper case chars in string. -But upper case chars preceded by \\ do not count since they -have special meaning in a regexp." - ;; this incorrectly returns t for "\\\\A" - (let ((case-fold-search nil)) - (not (string-match "\\(^\\|[^\\]\\)[A-Z]" string)))) - -;; Used by etags.el and info.el -(defmacro with-caps-disable-folding (string &rest body) "\ -Eval BODY with `case-fold-search' let to nil if STRING contains -uppercase letters and `search-caps-disable-folding' is t." - `(let ((case-fold-search - (if (and case-fold-search search-caps-disable-folding) - (isearch-no-upper-case-p ,string) - case-fold-search))) - ,@body)) -(put 'with-caps-disable-folding 'lisp-indent-function 1) -(put 'with-caps-disable-folding 'edebug-form-spec '(form body)) -
--- a/lisp/prim/itimer-autosave.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,109 +0,0 @@ -;;; itimer-autosave.el --- Autosave functions with itimers - -;; Copyright status unknown - -;; 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: - -;; itimer-driven auto-saves - -;;; Code: - -;jwz: this is preloaded so don't ;;;###autoload -(defvar auto-save-timeout 960 - "*Number of seconds idle time before auto-save. -Zero or nil means disable auto-saving due to idleness. - -The actual amount of idle time between auto-saves is logarithmically related -to the size of the current buffer. This variable is the number of seconds -after which an auto-save will happen when the current buffer is 50k or less; -the timeout will be 2 1/4 times this in a 200k buffer, 3 3/4 times this in a -1000k buffer, and 4 1/2 times this in a 2000k buffer. - -See also the variable `auto-save-interval', which controls auto-saving based -on the number of characters typed.") - -;jwz: this is preloaded so don't ;;;###autoload -(defvar auto-gc-threshold (/ gc-cons-threshold 3) - "*GC when this many bytes have been consed since the last GC, -and the user has been idle for `auto-save-timeout' seconds.") - -(defun auto-save-itimer () - "For use as a itimer callback function. -Auto-saves and garbage-collects based on the size of the current buffer -and the value of `auto-save-timeout', `auto-gc-threshold', and the current -keyboard idle-time." - (if (or (null auto-save-timeout) - (<= auto-save-timeout 0) - (eq (minibuffer-window) (selected-window))) - nil - (let ((buf-size (1+ (ash (buffer-size) -8))) - (delay-level 0) - (now (current-time)) - delay) - (while (> buf-size 64) - (setq delay-level (1+ delay-level) - buf-size (- buf-size (ash buf-size -2)))) - (if (< delay-level 4) - (setq delay-level 4)) - ;; delay_level is 4 for files under around 50k, 7 at 100k, 9 at 200k, - ;; 11 at 300k, and 12 at 500k, 15 at 1 meg, and 17 at 2 meg. - (setq delay (/ (* delay-level auto-save-timeout) 4)) - (let ((idle-time (if (or (not (consp last-input-time)) - (/= (car now) (car last-input-time))) - (1+ delay) - (- (car (cdr now)) (cdr last-input-time))))) - (and (> idle-time delay) - (do-auto-save)) - (and (> idle-time auto-save-timeout) - (> (consing-since-gc) auto-gc-threshold) - (garbage-collect))))) - ;; Look at the itimer that's currently running; if the user has changed - ;; the value of auto-save-timeout, modify this itimer to have the correct - ;; restart time. There will be some latency between when the user changes - ;; this variable and when it takes effect, but it will happen eventually. - (let ((self (get-itimer "auto-save"))) - (or self (error "auto-save-itimer can't find itself")) - (if (and auto-save-timeout (> auto-save-timeout 4)) - (or (= (itimer-restart self) (/ auto-save-timeout 4)) - (set-itimer-restart self (/ auto-save-timeout 4))))) - nil) - -(defun itimer-init-auto-gc () - (or noninteractive ; may be being run from after-init-hook in -batch mode. - (get-itimer "auto-save") - ;; the time here is just the first interval; if the user changes it - ;; later, it will adjust. - (let ((time (max 2 (/ (or auto-save-timeout 30) 4)))) - (start-itimer "auto-save" 'auto-save-itimer time time)))) - -(cond (purify-flag - ;; This file is being preloaded into an emacs about to be dumped. - ;; So arrange for the auto-save itimer to be started once emacs - ;; is launched. - (add-hook 'after-init-hook 'itimer-init-auto-gc)) - (t - ;; Otherwise, this file is being loaded into a normal, interactive - ;; emacs. Start the auto-save timer now. - (itimer-init-auto-gc))) - - -;;; itimer-autosave.el ends here
--- a/lisp/prim/itimer.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,855 +0,0 @@ -;;; Interval timers for GNU Emacs -;;; Copyright (C) 1988, 1991, 1993, 1997 Kyle E. Jones -;;; -;;; This program is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 2, or (at your option) -;;; any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; A copy of the GNU General Public License can be obtained from this -;;; program's author (send electronic mail to kyle@uunet.uu.net) or from -;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA -;;; 02139, USA. -;;; -;;; Send bug reports to kyle_jones@wonderworks.com - -(provide 'itimer) - -;; `itimer' feature means Emacs-Lisp programmers get: -;; itimerp -;; itimer-live-p -;; itimer-value -;; itimer-restart -;; itimer-function -;; itimer-uses-arguments -;; itimer-function-arguments -;; set-itimer-value -;; set-itimer-restart -;; set-itimer-function -;; set-itimer-uses-arguments -;; set-itimer-function-arguments -;; get-itimer -;; start-itimer -;; read-itimer -;; delete-itimer -;; activate-itimer -;; -;; Interactive users get these commands: -;; edit-itimers -;; list-itimers -;; start-itimer -;; -;; See the doc strings of these functions for more information. - -(defvar itimer-version "1.06" - "Version number of the itimer package.") - -(defvar itimer-list nil - "List of all active itimers.") - -(defvar itimer-process nil - "Process that drives all itimers, if a subprocess is being used.") - -(defvar itimer-timer nil - "Emacs internal timer that drives the itimer system, if a subprocess -is not being used to drive the system.") - -(defvar itimer-timer-last-wakeup nil - "The time the timer driver function last ran.") - -(defvar itimer-short-interval (if (featurep 'lisp-float-type) 1e-3 1) - "Interval used for scheduling an event a very short time in the future. -Used internally to make the scheduler wake up early. -Unit is seconds.") - -;; This value is maintained internally; it does not determine -;; itimer granularity. Itimer granularity is 1 second if your -;; Emacs doens't support floats or your system doesn't have a -;; clock with microsecond granularity. Otherwise granularity is -;; to the microsend, although you can't possibly get timers to be -;; executed with this kind of accuracy in practice. There will -;; be delays due to system and Emacs internal activity that delay -;; dealing with syunchronous events and process output. -(defvar itimer-next-wakeup itimer-short-interval - "Itimer process will wakeup to service running itimers within this -many seconds.") - -(defvar itimer-edit-map nil - "Keymap used when in Itimer Edit mode.") - -(if itimer-edit-map - () - (setq itimer-edit-map (make-sparse-keymap)) - (define-key itimer-edit-map "s" 'itimer-edit-set-field) - (define-key itimer-edit-map "d" 'itimer-edit-delete-itimer) - (define-key itimer-edit-map "q" 'itimer-edit-quit) - (define-key itimer-edit-map "\t" 'itimer-edit-next-field) - (define-key itimer-edit-map " " 'next-line) - (define-key itimer-edit-map "n" 'next-line) - (define-key itimer-edit-map "p" 'previous-line) - (define-key itimer-edit-map "\C-?" 'itimer-edit-previous-field) - (define-key itimer-edit-map "x" 'start-itimer) - (define-key itimer-edit-map "?" 'itimer-edit-help)) - -(defvar itimer-inside-driver nil) - -(defvar itimer-edit-start-marker nil) - -;; macros must come first... or byte-compile'd code will throw back its -;; head and scream. - -(defmacro itimer-decrement (variable) - (list 'setq variable (list '1- variable))) - -(defmacro itimer-increment (variable) - (list 'setq variable (list '1+ variable))) - -(defmacro itimer-signum (n) - (list 'if (list '> n 0) 1 - (list 'if (list 'zerop n) 0 -1))) - -;; Itimer access functions should behave as if they were subrs. These -;; macros are used to check the arguments to the itimer functions and -;; signal errors appropriately if the arguments are not valid. - -(defmacro check-itimer (var) - "If VAR is not bound to an itimer, signal wrong-type-argument. -This is a macro." - (list 'setq var - (list 'if (list 'itimerp var) var - (list 'signal ''wrong-type-argument - (list 'list ''itimerp var))))) - -(defmacro check-itimer-coerce-string (var) - "If VAR is not bound to a string, look up the itimer that it names and -bind VAR to it. Otherwise if VAR is not bound to an itimer, signal -wrong-type-argument. This is a macro." - (list 'setq var - (list 'cond - (list (list 'itimerp var) var) - (list (list 'stringp var) (list 'get-itimer var)) - (list t (list 'signal ''wrong-type-argument - (list 'list ''string-or-itimer-p var)))))) - -(defmacro check-nonnegative-number (var) - "If VAR is not bound to a number, signal wrong-type-argument. -If VAR is not bound to a positive number, signal args-out-of-range. -This is a macro." - (list 'setq var - (list 'if (list 'not (list 'numberp var)) - (list 'signal ''wrong-type-argument - (list 'list ''natnump var)) - (list 'if (list '< var 0) - (list 'signal ''args-out-of-range (list 'list var)) - var)))) - -(defmacro check-string (var) - "If VAR is not bound to a string, signal wrong-type-argument. -This is a macro." - (list 'setq var - (list 'if (list 'stringp var) var - (list 'signal ''wrong-type-argument - (list 'list ''stringp var))))) - -;; Functions to access and modify itimer attributes. - -(defun itimerp (obj) - "Returns non-nil iff OBJ is an itimer." - (and (consp obj) (eq (length obj) 8))) - -(defun itimer-live-p (obj) - "Returns non-nil iff OBJ is an itimer and is active. -``Active'' means Emacs will run it when it expires. -`activate-timer' must be called on a itimer to make it active. -Itimers started with `start-itimer' are automatically active." - (and (itimerp obj) (memq obj itimer-list))) - -(defun itimer-name (itimer) - "Returns the name of ITIMER." - (check-itimer itimer) - (car itimer)) - -(defun itimer-value (itimer) - "Returns the number of seconds until ITIMER expires." - (check-itimer itimer) - (nth 1 itimer)) - -(defun itimer-restart (itimer) - "Returns the value to which ITIMER will be set at restart. -nil is returned if this itimer doesn't restart." - (check-itimer itimer) - (nth 2 itimer)) - -(defun itimer-function (itimer) - "Returns the function of ITIMER. -This function is called each time ITIMER expires." - (check-itimer itimer) - (nth 3 itimer)) - -(defun itimer-is-idle (itimer) - "Returns non-nil if ITIMER is an idle timer. -Normal timers expire after a set interval. Idle timers expire -only after Emacs has been idle for a specific interval. ``Idle'' -means no command events within the interval." - (check-itimer itimer) - (nth 4 itimer)) - -(defun itimer-uses-arguments (itimer) - "Returns non-nil if the function of ITIMER will be called with arguments. -ITIMER's function is called with the arguments each time ITIMER expires. -The arguments themselves are retrievable with `itimer-function-arguments'." - (check-itimer itimer) - (nth 5 itimer)) - -(defun itimer-function-arguments (itimer) - "Returns the function arguments of ITIMER as a list. -ITIMER's function is called with these argument each timer ITIMER expires." - (check-itimer itimer) - (nth 6 itimer)) - -(defun itimer-recorded-run-time (itimer) - (check-itimer itimer) - (nth 7 itimer)) - -(defun set-itimer-value (itimer value) - "Set the timeout value of ITIMER to be VALUE. -Itimer will expire is this many seconds. -If your version of Emacs supports floating point numbers then -VALUE can be a floating point number. Otherwise it -must be an integer. -Returns VALUE." - (check-itimer itimer) - (check-nonnegative-number value) - (let ((inhibit-quit t)) - ;; If the itimer is in the active list, and under the new - ;; timeout value would expire before we would normally - ;; wakeup, wakeup now and recompute a new wakeup time. - (or (and (< value itimer-next-wakeup) - (and (itimer-name itimer) (get-itimer (itimer-name itimer))) - (progn (itimer-driver-wakeup) - (setcar (cdr itimer) value) - (itimer-driver-wakeup) - t )) - (setcar (cdr itimer) value)) - value)) - -;; Same as set-itimer-value but does not wakeup the driver. -;; Only should be used by the drivers when processing expired timers. -(defun set-itimer-value-internal (itimer value) - (check-itimer itimer) - (check-nonnegative-number value) - (setcar (cdr itimer) value)) - -(defun set-itimer-restart (itimer restart) - "Set the restart value of ITIMER to be RESTART. -If RESTART is nil, ITIMER will not restart when it expires. -If your version of Emacs supports floating point numbers then -RESTART can be a floating point number. Otherwise it -must be an integer. -Returns RESTART." - (check-itimer itimer) - (if restart (check-nonnegative-number restart)) - (setcar (cdr (cdr itimer)) restart)) - -(defun set-itimer-function (itimer function) - "Set the function of ITIMER to be FUNCTION. -FUNCTION will be called when itimer expires. -Returns FUNCTION." - (check-itimer itimer) - (setcar (nthcdr 3 itimer) function)) - -(defun set-itimer-is-idle (itimer flag) - "Sets flag that says whether ITIMER is an idle timer. -If FLAG is non-nil, then ITIMER will eb considered an idle timer. -Returns FLAG." - (check-itimer itimer) - (setcar (nthcdr 4 itimer) flag)) - -(defun set-itimer-uses-arguments (itimer flag) - "Sets flag that says whether the function of ITIMER is called with arguments. -If FLAG is non-nil, then the function will be called with one argument, -otherwise the function will be called with no arguments. -Returns FLAG." - (check-itimer itimer) - (setcar (nthcdr 5 itimer) flag)) - -(defun set-itimer-function-arguments (itimer &optional arguments) - "Set the function arguments of ITIMER to be ARGUMENTS. -The function of ITIMER will be called with ARGUMENTS when itimer expires. -Returns ARGUMENTS." - (check-itimer itimer) - (setcar (nthcdr 6 itimer) arguments)) - -(defun set-itimer-recorded-run-time (itimer time) - (check-itimer itimer) - (setcar (nthcdr 7 itimer) time)) - -(defun get-itimer (name) - "Return itimer named NAME, or nil if there is none." - (check-string name) - (assoc name itimer-list)) - -(defun read-itimer (prompt &optional initial-input) - "Read the name of an itimer from the minibuffer and return the itimer -associated with that name. The user is prompted with PROMPT. -Optional second arg INITIAL-INPUT non-nil is inserted into the - minibuffer as initial user input." - (get-itimer (completing-read prompt itimer-list nil 'confirm initial-input))) - -(defun delete-itimer (itimer) - "Deletes ITIMER. ITIMER may be an itimer or the name of one." - (check-itimer-coerce-string itimer) - (setq itimer-list (delq itimer itimer-list))) - -(defun start-itimer (name function value &optional restart - is-idle with-args &rest function-arguments) - "Start an itimer. -Arguments are - NAME, FUNCTION, VALUE &optional RESTART, IS-IDLE, WITH-ARGS, &rest FUNCTION-ARGUMENTS. -NAME is an identifier for the itimer. It must be a string. If an itimer - already exists with this name, NAME will be modified slightly to until - it is unique. -FUNCTION should be a function (or symbol naming one). It - will be called each time the itimer expires with arguments of - FUNCTION-ARGUMENTS. The function can access the itimer that - invoked it through the variable `current-itimer'. If WITH-ARGS - is nil then FUNCTION is called with no arguments. This is for - backward compatibility with older versions of the itimer - package which always called FUNCTION with no arguments. -VALUE is the number of seconds until this itimer expires. - If your version of Emacs supports floating point numbers then - you can VALUE can be a floating point number. Otherwise it - must be an integer. -Optional fourth arg RESTART non-nil means that this itimer should be - restarted automatically after its function is called. Normally an itimer - is deleted at expiration after its function has returned. - If non-nil RESTART should be a number indicating the value at which the - itimer should be set at restart time. -Optional fifth arg IS-IDLE specified if this is an idle timer. - Normal timers eexpire after a set interval. Idle timers expire - only after Emacs has been idle for specific interval. ``Idle'' - means no command events within the interval. -Returns the newly created itimer." - (interactive - (list (completing-read "Start itimer: " itimer-list) - (read (completing-read "Itimer function: " obarray 'fboundp)) - (let (value) - (while (or (not (numberp value)) (< value 0)) - (setq value (read-from-minibuffer "Itimer value: " nil nil t))) - value) - (let ((restart t)) - (while (and restart (or (not (numberp restart)) (< restart 0))) - (setq restart (read-from-minibuffer "Itimer restart: " - nil nil t))) - restart) - ;; hard to imagine the user specifying these interactively - nil - nil )) - (check-string name) - (check-nonnegative-number value) - (if restart (check-nonnegative-number restart)) - ;; Make proposed itimer name unique if it's not already. - (let ((oname name) - (num 2)) - (while (get-itimer name) - (setq name (concat oname "<" num ">")) - (itimer-increment num))) - (activate-itimer (list name value restart function is-idle - with-args function-arguments (list 0 0 0))) - (car itimer-list)) - -(defun make-itimer () - "Create an unactivated itimer. -The itimer will not begin running until activated with `activate-itimer'. -Set the itimer's expire interval with `set-itimer-value'. -Set the itimer's function interval with `set-itimer-function'. -Once this is done, the timer can be activated." - (list nil 0 nil 'ignore nil nil nil (list 0 0 0))) - -(defun activate-itimer (itimer) - "Activate ITIMER, which was previously created with `make-itimer'. -ITIMER will be added to the global list of running itimers, -its FUNCTION will be called when it expires, and so on." - (check-itimer itimer) - (if (memq itimer itimer-list) - (error "itimer already activated")) - (if (not (numberp (itimer-value itimer))) - (error "itimer timeout value not a number: %s" (itimer-value itimer))) - (if (<= (itimer-value itimer) 0) - (error "itimer timeout value not positive: %s" (itimer-value itimer))) - ;; If there's no itimer driver/process, start one now. - ;; Otherwise wake up the itimer driver so that seconds slept before - ;; the new itimer is created won't be counted against it. - (if (or itimer-process itimer-timer) - (itimer-driver-wakeup) - (itimer-driver-start)) - ;; Roll a unique name for the timer if it doesn't have a name - ;; already. - (if (not (stringp (car itimer))) - (let ((name "itimer-0") - (oname "itimer-") - (num 1)) - (while (get-itimer name) - (setq name (concat oname "<" num ">")) - (itimer-increment num)) - (setcar itimer name)) - ;; signal an error if the timer's name matches an already - ;; activated timer. - (if (get-itimer (itimer-name itimer)) - (error "itimer named \"%s\" already existing and activated" - (itimer-name itimer)))) - (let ((inhibit-quit t)) - ;; add the itimer to the global list - (setq itimer-list (cons itimer itimer-list)) - ;; If the itimer process is scheduled to wake up too late for - ;; the itimer we wake it up to calculate a correct wakeup - ;; value giving consideration to the newly added itimer. - (if (< (itimer-value itimer) itimer-next-wakeup) - (itimer-driver-wakeup)))) - -;; User level functions to list and modify existing itimers. -;; Itimer Edit major mode, and the editing commands thereof. - -(defun list-itimers () - "Pop up a buffer containing a list of all itimers. -The major mode of the buffer is Itimer Edit mode. This major mode provides -commands to manipulate itimers; see the documentation for -`itimer-edit-mode' for more information." - (interactive) - (let* ((buf (get-buffer-create "*Itimer List*")) - (opoint (point)) - (standard-output buf) - (itimers (reverse itimer-list))) - (set-buffer buf) - (itimer-edit-mode) - (setq buffer-read-only nil) - (erase-buffer) - (insert -"Name Value Restart Function Idle Arguments" -"\n" -"---- ----- ------- -------- ---- --------") - (if (null itimer-edit-start-marker) - (setq itimer-edit-start-marker (point))) - (while itimers - (newline 1) - (prin1 (itimer-name (car itimers))) - (tab-to-tab-stop) - (insert (itimer-truncate-string - (format "%5.5s" (itimer-value (car itimers))) 5)) - (tab-to-tab-stop) - (insert (itimer-truncate-string - (format "%5.5s" (itimer-restart (car itimers))) 5)) - (tab-to-tab-stop) - (insert (itimer-truncate-string - (format "%.19s" (itimer-function (car itimers))) 19)) - (tab-to-tab-stop) - (if (itimer-is-idle (car itimers)) - (insert "yes") - (insert "no")) - (tab-to-tab-stop) - (if (itimer-uses-arguments (car itimers)) - (prin1 (itimer-function-arguments (car itimers))) - (prin1 'NONE)) - (setq itimers (cdr itimers))) - ;; restore point - (goto-char opoint) - (if (< (point) itimer-edit-start-marker) - (goto-char itimer-edit-start-marker)) - (setq buffer-read-only t) - (display-buffer buf))) - -(defun edit-itimers () - "Display a list of all itimers and select it for editing. -The major mode of the buffer containing the listing is Itimer Edit mode. -This major mode provides commands to manipulate itimers; see the documentation -for `itimer-edit-mode' for more information." - (interactive) - ;; since user is editing, make sure displayed data is reasonably up-to-date - (if (or itimer-process itimer-timer) - (itimer-driver-wakeup)) - (list-itimers) - (select-window (get-buffer-window "*Itimer List*")) - (goto-char itimer-edit-start-marker) - (if itimer-list - (progn - (forward-sexp 2) - (backward-sexp))) - (message "type q to quit, ? for help")) - -;; no point in making this interactive. -(defun itimer-edit-mode () - "Major mode for manipulating itimers. -Attributes of running itimers are changed by moving the cursor to the -desired field and typing `s' to set that field. The field will then be -set to the value read from the minibuffer. - -Commands: -TAB move forward a field -DEL move backward a field -s set a field -d delete the selected itimer -x start a new itimer -? help" - (kill-all-local-variables) - (make-local-variable 'tab-stop-list) - (setq major-mode 'itimer-edit-mode - mode-name "Itimer Edit" - truncate-lines t - tab-stop-list '(22 32 40 60 67)) - (abbrev-mode 0) - (auto-fill-mode 0) - (buffer-disable-undo (current-buffer)) - (use-local-map itimer-edit-map) - (set-syntax-table emacs-lisp-mode-syntax-table)) - -(put 'itimer-edit-mode 'mode-class 'special) - -(defun itimer-edit-help () - "Help function for Itimer Edit." - (interactive) - (if (eq last-command 'itimer-edit-help) - (describe-mode) - (message "TAB, DEL select fields, (s)et field, (d)elete itimer (type ? for more help)"))) - -(defun itimer-edit-quit () - "End Itimer Edit." - (interactive) - (bury-buffer (current-buffer)) - (if (one-window-p t) - (switch-to-buffer (other-buffer (current-buffer))) - (delete-window))) - -(defun itimer-edit-set-field () - (interactive) - ;; First two lines in list buffer are headers. - ;; Cry out against the luser who attempts to change a field there. - (if (<= (point) itimer-edit-start-marker) - (error "")) - ;; field-value must be initialized to be something other than a - ;; number, symbol, or list. - (let (itimer field (field-value "")) - (setq itimer (save-excursion - ;; read the name of the itimer from the beginning of - ;; the current line. - (beginning-of-line) - (get-itimer (read (current-buffer)))) - field (save-excursion - (itimer-edit-beginning-of-field) - (let ((opoint (point)) - (n 0)) - ;; count the number of sexprs until we reach the cursor - ;; and use this info to determine which field the user - ;; wants to modify. - (beginning-of-line) - (while (and (>= opoint (point)) (< n 6)) - (forward-sexp 2) - (backward-sexp) - (itimer-increment n)) - (cond ((eq n 1) (error "Cannot change itimer name.")) - ((eq n 2) 'value) - ((eq n 3) 'restart) - ((eq n 4) 'function) - ((eq n 5) 'is-idle) - (t 'function-argument))))) - (cond ((eq field 'value) - (let ((prompt "Set itimer value: ")) - (while (not (natnump field-value)) - (setq field-value (read-from-minibuffer prompt nil nil t))))) - ((eq field 'restart) - (let ((prompt "Set itimer restart: ")) - (while (and field-value (not (natnump field-value))) - (setq field-value (read-from-minibuffer prompt nil nil t))))) - ((eq field 'function) - (let ((prompt "Set itimer function: ")) - (while (not (or (and (symbolp field-value) (fboundp field-value)) - (and (consp field-value) - (memq (car field-value) '(lambda macro))))) - (setq field-value - (read (completing-read prompt obarray 'fboundp nil)))))) - ((eq field 'is-idle) - (setq field-value (not (itimer-is-idle itimer)))) - ((eq field 'function-argument) - (let ((prompt "Set itimer function argument: ")) - (setq field-value (read-expression prompt)) - (cond ((not (listp field-value)) - (setq field-value (list field-value)))) - (if (null field-value) - (set-itimer-uses-arguments itimer nil) - (set-itimer-uses-arguments itimer t))))) - ;; set the itimer field - (funcall (intern (concat "set-itimer-" (symbol-name field))) - itimer field-value) - ;; move to beginning of field to be changed - (itimer-edit-beginning-of-field) - ;; modify the list buffer to reflect the change. - (let (buffer-read-only kill-ring) - (kill-sexp 1) - (kill-region (point) (progn (skip-chars-forward " \t") (point))) - (prin1 field-value (current-buffer)) - (if (not (eolp)) - (tab-to-tab-stop)) - (backward-sexp)))) - -(defun itimer-edit-delete-itimer () - (interactive) - ;; First two lines in list buffer are headers. - ;; Cry out against the luser who attempts to change a field there. - (if (<= (point) itimer-edit-start-marker) - (error "")) - (delete-itimer - (read-itimer "Delete itimer: " - (save-excursion (beginning-of-line) (read (current-buffer))))) - ;; update list information - (list-itimers)) - -(defun itimer-edit-next-field (count) - (interactive "p") - (itimer-edit-beginning-of-field) - (cond ((> (itimer-signum count) 0) - (while (not (zerop count)) - (forward-sexp) - ;; wrap from eob to itimer-edit-start-marker - (if (eobp) - (progn - (goto-char itimer-edit-start-marker) - (forward-sexp))) - (forward-sexp) - (backward-sexp) - ;; treat fields at beginning of line as if they weren't there. - (if (bolp) - (progn - (forward-sexp 2) - (backward-sexp))) - (itimer-decrement count))) - ((< (itimer-signum count) 0) - (while (not (zerop count)) - (backward-sexp) - ;; treat fields at beginning of line as if they weren't there. - (if (bolp) - (backward-sexp)) - ;; wrap from itimer-edit-start-marker to field at eob. - (if (<= (point) itimer-edit-start-marker) - (progn - (goto-char (point-max)) - (backward-sexp))) - (itimer-increment count))))) - -(defun itimer-edit-previous-field (count) - (interactive "p") - (itimer-edit-next-field (- count))) - -(defun itimer-edit-beginning-of-field () - (let ((forw-back (save-excursion (forward-sexp) (backward-sexp) (point))) - (back (save-excursion (backward-sexp) (point)))) - (cond ((eq forw-back back) (backward-sexp)) - ((eq forw-back (point)) t) - (t (backward-sexp))))) - -(defun itimer-truncate-string (str len) - (if (<= (length str) len) - str - (substring str 0 len))) - -;; internals of the itimer implementation. - -(defun itimer-run-expired-timers (time-elapsed) - (let ((itimers (copy-sequence itimer-list)) - (itimer) - (next-wakeup 600) - (idle-time) - (last-event-time) - (recorded-run-time) - ;; process filters can be hit by stray C-g's from the user, - ;; so we must protect this stuff appropriately. - ;; Quit's are allowed from within itimer functions, but we - ;; catch them and print a message. - (inhibit-quit t)) - (setq next-wakeup 600) - (if (and (boundp 'last-input-time) (consp last-input-time)) - (setq last-event-time (list (car last-input-time) - (cdr last-input-time) - 0) - idle-time (itimer-time-difference (current-time) - last-event-time)) - ;; no way to do this under FSF Emacs yet. - (setq last-event-time '(0 0 0) - idle-time 0)) - (while itimers - (setq itimer (car itimers)) - (if (itimer-is-idle itimer) - (setq recorded-run-time (itimer-recorded-run-time itimer)) - (set-itimer-value-internal itimer (max 0 (- (itimer-value itimer) - time-elapsed)))) - (if (if (itimer-is-idle itimer) - (or (> (itimer-time-difference recorded-run-time - last-event-time) - 0) - (< idle-time (itimer-value itimer))) - (> (itimer-value itimer) 0)) - (setq next-wakeup - (if (itimer-is-idle itimer) - (if (< idle-time (itimer-value itimer)) - (min next-wakeup (- (itimer-value itimer) idle-time)) - (min next-wakeup (itimer-value itimer))) - (min next-wakeup (itimer-value itimer)))) - (and (itimer-is-idle itimer) - (set-itimer-recorded-run-time itimer (current-time))) - ;; itimer has expired, we must call its function. - ;; protect our local vars from the itimer function. - ;; allow keyboard quit to occur, but catch and report it. - ;; provide the variable `current-itimer' in case the function - ;; is interested. - (unwind-protect - (condition-case condition-data - (save-match-data - (let* ((current-itimer itimer) - (quit-flag nil) - (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) - (if (itimer-uses-arguments current-itimer) - (apply (itimer-function current-itimer) - (itimer-function-arguments current-itimer)) - (funcall (itimer-function current-itimer))))) - (error (message "itimer \"%s\" signaled: %s" (itimer-name itimer) - (prin1-to-string condition-data))) - (quit (message "itimer \"%s\" quit" (itimer-name itimer)))) - ;; restart the itimer if we should, otherwise delete it. - (if (null (itimer-restart itimer)) - (delete-itimer itimer) - (set-itimer-value-internal itimer (itimer-restart itimer)) - (setq next-wakeup (min next-wakeup (itimer-value itimer)))))) - (setq itimers (cdr itimers))) - ;; if user is editing itimers, update displayed info - (if (eq major-mode 'itimer-edit-mode) - (list-itimers)) - next-wakeup )) - -(defun itimer-process-filter (process string) - ;; If the itimer process dies and generates output while doing - ;; so, we may be called before the process-sentinel. Sanity - ;; check the output just in case... - (if (not (string-match "^[0-9]" string)) - (progn (message "itimer process gave odd output: %s" string) - ;; it may be still alive and waiting for input - (process-send-string itimer-process "3\n")) - ;; if there are no active itimers, return quickly. - (if itimer-list - (let ((wakeup nil)) - (unwind-protect - (setq wakeup (itimer-run-expired-timers (string-to-int string))) - (and (null wakeup) (process-send-string process "1\n"))) - (setq itimer-next-wakeup wakeup)) - (setq itimer-next-wakeup 600)) - ;; tell itimer-process when to wakeup again - (process-send-string itimer-process - (concat (int-to-string itimer-next-wakeup) - "\n")))) - -(defun itimer-process-sentinel (process message) - (let ((inhibit-quit t)) - (if (eq (process-status process) 'stop) - (continue-process process) - ;; not stopped, so it must have died. - ;; cleanup first... - (delete-process process) - (setq itimer-process nil) - ;; now, if there are any active itimers then we need to immediately - ;; start another itimer process, otherwise we can wait until the next - ;; start-itimer call, which will start one automatically. - (if (null itimer-list) - () - ;; there may have been an error message in the echo area; - ;; give the user at least a little time to read it. - (sit-for 2) - (message "itimer process %s... respawning." (substring message 0 -1)) - (itimer-process-start))))) - -(defun itimer-process-start () - (let ((inhibit-quit t) - (process-connection-type nil)) - (setq itimer-process (start-process "itimer" nil "itimer")) - (process-kill-without-query itimer-process) - (set-process-filter itimer-process 'itimer-process-filter) - (set-process-sentinel itimer-process 'itimer-process-sentinel) - ;; Tell itimer process to wake up quickly, so that a correct - ;; wakeup time can be computed. Zero loses because of - ;; underlying itimer implementations that use 0 to mean - ;; `disable the itimer'. - (setq itimer-next-wakeup itimer-short-interval) - (process-send-string itimer-process - (format "%s\n" itimer-next-wakeup)))) - -(defun itimer-process-wakeup () - (interrupt-process itimer-process) - (accept-process-output)) - -(defun itimer-timer-start () - (let ((inhibit-quit t)) - (setq itimer-next-wakeup itimer-short-interval - itimer-timer-last-wakeup (current-time) - itimer-timer (add-timeout itimer-short-interval - 'itimer-timer-driver nil nil)))) - -(defun itimer-timer-wakeup () - (let ((inhibit-quit t)) - (cond ((fboundp 'disable-timeout) - (disable-timeout itimer-timer)) - ((fboundp 'cancel-timer) - (cancel-timer itimer-timer))) - (setq itimer-timer (add-timeout itimer-short-interval - 'itimer-timer-driver nil 5)))) - -(defun itimer-time-difference (t1 t2) - (let (usecs secs 65536-secs carry) - (setq usecs (- (nth 2 t1) (nth 2 t2))) - (if (< usecs 0) - (setq carry 1 - usecs (+ usecs 1000000)) - (setq carry 0)) - (setq secs (- (nth 1 t1) (nth 1 t2) carry)) - (if (< secs 0) - (setq carry 1 - secs (+ secs 65536)) - (setq carry 0)) - (setq 65536-secs (- (nth 0 t1) (nth 0 t2) carry)) - ;; loses for interval larger than the maximum signed Lisp integer. - ;; can't really be helped. - (+ (* 65536-secs 65536) - secs - (/ usecs (if (featurep 'lisp-float-type) 1e6 1000000))))) - -(defun itimer-timer-driver (&rest ignored) - ;; inhibit quit because if the user quits at an inopportune - ;; time, the timer process won't bne launched again and the - ;; system stops working. itimer-run-expired-timers allows - ;; individual timer function to be aborted, so the user can - ;; escape a feral timer function. - (if (not itimer-inside-driver) - (let* ((inhibit-quit t) - (itimer-inside-driver t) - (now (current-time)) - (elapsed (itimer-time-difference now itimer-timer-last-wakeup)) - (sleep nil)) - (setq itimer-timer-last-wakeup now - sleep (itimer-run-expired-timers elapsed)) - (disable-timeout itimer-timer) - (setq itimer-next-wakeup sleep - itimer-timer (add-timeout sleep 'itimer-timer-driver nil 5))))) - -(defun itimer-driver-start () - (if (fboundp 'add-timeout) - (itimer-timer-start) - (itimer-process-start))) - -(defun itimer-driver-wakeup () - (if (fboundp 'add-timeout) - (itimer-timer-wakeup) - (itimer-process-wakeup)))
--- a/lisp/prim/keydefs.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,622 +0,0 @@ -;; Define standard keybindings. -;; Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc. - -;; 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, 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;; All the global bindings should be here so that one can reload things -;; like files.el without trashing one's personal bindings. - -;;; Synched up with: Not synched with FSF. - -;;; Commentary: - -;;; Code: - -;; created by C code -(defvar global-map (current-global-map) "\ -Default global keymap mapping XEmacs keyboard input into commands. -The value is a keymap which is usually (but not necessarily) XEmacs's -global map.") - -;; created by C code -(defvar esc-map (symbol-function 'ESC-prefix) "\ -Default keymap for ESC (meta) commands. -The normal global definition of the character ESC indirects to this keymap.") - -(set-keymap-name global-map 'global-map) -(set-keymap-name esc-map 'ESC-prefix) - -(define-prefix-command 'Control-X-prefix t) -(defvar ctl-x-map (symbol-function 'Control-X-prefix) "\ -Default keymap for C-x commands. -The normal global definition of the character C-x indirects to this keymap.") -(define-key global-map "\C-x" 'Control-X-prefix) - -(define-prefix-command 'ctl-x-4-prefix t) -(defvar ctl-x-4-map (symbol-function 'ctl-x-4-prefix) "\ -Keymap for subcommands of C-x 4") -(define-key global-map "\C-x4" 'ctl-x-4-prefix) - -(define-prefix-command 'ctl-x-5-prefix t) -(defvar ctl-x-5-map (symbol-function 'ctl-x-5-prefix) "\ -Keymap for subcommands of C-x 5") -(define-key global-map "\C-x5" 'ctl-x-5-prefix) - -(define-prefix-command 'mode-specific-command-prefix t) -(defvar mode-specific-map (symbol-function 'mode-specific-command-prefix) "\ -Keymap for characters following C-c.") -(define-key global-map "\C-c" 'mode-specific-command-prefix) - -;; FSFmacs buffer.c - -(define-key global-map "\C-xb" 'switch-to-buffer) -(define-key global-map "\C-xk" 'kill-buffer) -(define-key global-map "\C-x\C-b" 'list-buffers) -(put 'erase-buffer 'disabled t) ;from buffer.c - -;; FSFmacs casefiddle.c - -(define-key global-map "\C-x\C-u" 'upcase-region) -;; This is silly with zmacs regions -;(put 'upcase-region 'disabled t) -(define-key global-map "\C-x\C-l" 'downcase-region) -;; This is silly with zmacs regions -;(put 'downcase-region 'disabled t) -(define-key global-map "\M-u" 'upcase-region-or-word) -(define-key global-map "\M-l" 'downcase-region-or-word) -(define-key global-map "\M-c" 'capitalize-region-or-word) - -;; FSFmacs cmds.c - -(let ((n 33)) - (while (<= n 255) - (if (not (= n 127)) - (define-key global-map n 'self-insert-command)) - (setq n (1+ n)))) -(define-key global-map " " 'self-insert-command) - -(define-key global-map "\C-a" 'beginning-of-line) -(define-key global-map "\C-b" 'backward-char) -(define-key global-map "\C-e" 'end-of-line) -(define-key global-map "\C-f" 'forward-char) -(define-key global-map "\C-d" 'delete-char) -(define-key global-map 'delete 'backward-or-forward-delete-char) -(define-key global-map '(meta delete) 'backward-or-forward-kill-word) -(define-key global-map [(control x) (delete)] 'backward-or-forward-kill-sentence) - -;; FSFmacs files.el - -(define-key global-map "\C-x\C-f" 'find-file) -(define-key global-map "\C-x\C-q" 'toggle-read-only) -(define-key global-map "\C-x\C-r" 'find-file-read-only) -(define-key global-map "\C-x\C-v" 'find-alternate-file) -(define-key global-map "\C-x\C-s" 'save-buffer) -(define-key global-map "\C-xs" 'save-some-buffers) -(define-key global-map "\C-x\C-w" 'write-file) -(define-key global-map "\C-xi" 'insert-file) -(define-key global-map "\M-~" 'not-modified) -(define-key global-map "\C-x\C-d" 'list-directory) -(define-key global-map "\C-x\C-c" 'save-buffers-kill-emacs) - -(define-key global-map "\C-x4f" 'find-file-other-window) -(define-key global-map "\C-x4r" 'find-file-read-only-other-window) -(define-key global-map "\C-x4\C-f" 'find-file-other-window) -(define-key global-map "\C-x4b" 'switch-to-buffer-other-window) -(define-key global-map "\C-x4\C-o" 'display-buffer) - -(define-key global-map "\C-x5b" 'switch-to-buffer-other-frame) -(define-key global-map "\C-x5f" 'find-file-other-frame) -(define-key global-map "\C-x5\C-f" 'find-file-other-frame) -(define-key global-map "\C-x5r" 'find-file-read-only-other-frame) - -;; FSFmacs frame.c -;FSFmacs has these. It's probably a good idea to provide ways of hooking -;these events, but it's unlikely that it's a good idea to do it this way. -;Just provide a hook, like the existing `select-frame-hook', -;`deselect-frame-hook', `map-frame-hook', and `unmap-frame-hook'. -;#### ergo need hooks for delete-frame and iconify-frame -;(define-key global-map 'switch-frame 'handle-switch-frame) -;(define-key global-map 'delete-frame 'handle-delete-frame) -;(define-key global-map 'iconify-frame 'ignore-event) -;(define-key global-map 'make-frame-visible 'ignore-event) - -;; FSFmacs frame.el - -;; New FSF19 bindings: C-x 5 as prefix for window commands -(define-key global-map "\C-x52" 'make-frame) -(define-key global-map "\C-x50" 'delete-frame) -(define-key global-map "\C-x5o" 'other-frame) - -;; FSFmacs help.el - -(define-key global-map (vector help-char) 'help-command) -(define-key global-map 'help 'help-command) -(define-key global-map 'f1 'help-command) - -;; FSFmacs indent.el - -;;(define-key global-map "\t" 'self-insert-command) -(define-key global-map "\t" 'indent-for-tab-command) -(define-key global-map "\M-\C-\\" 'indent-region) -(define-key global-map "\C-x\t" 'indent-rigidly) -(define-key global-map "\M-i" 'tab-to-tab-stop) -;; XEmacs addition: -(define-key global-map [(shift tab)] 'tab-to-tab-stop) - -;; FSFmacs isearch.el - -(define-key global-map "\C-s" 'isearch-forward) -(define-key global-map "\C-r" 'isearch-backward) -(define-key global-map "\M-\C-s" 'isearch-forward-regexp) -(define-key global-map "\M-\C-r" 'isearch-backward-regexp) - -;; FSFmacs keyboard.c - -(define-key global-map "\C-z" 'suspend-emacs-or-iconify-frame) -(define-key global-map "\C-x\C-z" 'suspend-or-iconify-emacs) - -;; FSFmacs loaddefs.el - -;; New FSF19 bindings: C-x n as a prefix for narrowing commands. -(define-key global-map "\C-xn" (let ((map (make-sparse-keymap))) - (set-keymap-name map 'narrowing-prefix) - map)) -(put 'narrow-to-region 'disabled t) -(define-key global-map "\C-xnn" 'narrow-to-region) -(define-key global-map "\C-xnw" 'widen) -(define-key global-map "\C-xnd" 'narrow-to-defun) -;; Old v18 bindings -;(define-key global-map "\C-xn" 'narrow-to-region) -;(define-key global-map "\C-xw" 'widen) - -(define-key global-map "\C-j" 'newline-and-indent) -(define-key global-map "\C-m" 'newline) -(define-key global-map "\C-o" 'open-line) -(define-key global-map "\M-\C-o" 'split-line) -(define-key global-map "\C-q" 'quoted-insert) -(define-key global-map "\M-^" 'delete-indentation) -(define-key global-map "\M-\\" 'delete-horizontal-space) -(define-key global-map "\M-m" 'back-to-indentation) -(define-key global-map "\C-x\C-o" 'delete-blank-lines) -(define-key global-map "\M- " 'just-one-space) -(define-key global-map "\M-z" 'zap-to-char) -(define-key global-map "\M-=" 'count-lines-region) -(define-key global-map "\C-x=" 'what-cursor-position) -(define-key global-map "\M-:" 'eval-expression) -;; Define ESC ESC : like ESC : for people who type ESC ESC out of habit. -(define-key global-map "\M-\e:" 'eval-expression) -;(define-key global-map "\M-\e" 'eval-expression) -;; Do we really need to disable this now that it is harder to type -;; by accident? -;; (put 'eval-expression 'disabled t) -;; Changed from C-x ESC so that function keys work following C-x. -(define-key global-map "\C-x\e\e" 'repeat-complex-command) -;(define-key global-map "\C-x\e" 'repeat-complex-command) -(define-key global-map "\C-xu" 'advertised-undo) -;; Many people are used to typing C-/ on X terminals and getting C-_. -(define-key global-map '(control /) 'undo) -(define-key global-map "\C-_" 'undo) -(define-key global-map "\M-!" 'shell-command) -(define-key global-map "\M-|" 'shell-command-on-region) - -(define-key global-map "\C-u" 'universal-argument) -;; Make Control-0 - Control-9 set the prefix argument, like Meta-0. -(let ((i ?0)) - (while (<= i ?9) - (define-key global-map (list 'meta i) 'digit-argument) - (define-key global-map (list 'control i) 'digit-argument) - (define-key global-map (list 'control 'meta i) 'digit-argument) - (setq i (1+ i)))) -(define-key global-map '(meta -) 'negative-argument) -(define-key global-map '(control -) 'negative-argument) -(define-key global-map '(control meta -) 'negative-argument) - -(define-key global-map "\C-k" 'kill-line) -(define-key global-map "\C-w" 'kill-region) -(define-key global-map "\M-w" 'kill-ring-save) -(define-key global-map "\M-\C-w" 'append-next-kill) -(define-key global-map "\C-y" 'yank) -(define-key global-map "\M-y" 'yank-pop) - -;; Old v18 binding -;(define-key global-map "\C-xa" 'append-to-buffer) - -(define-key global-map "\C-@" 'set-mark-command) -;; Many people are used to typing C-SPC and getting C-@. -(define-key global-map '(control ? ) 'set-mark-command) -(define-key global-map "\C-x\C-x" 'exchange-point-and-mark) -(define-key global-map "\C-x\C-@" 'pop-global-mark) -(define-key global-map [(control x) (control ? )] 'pop-global-mark) - -(define-key global-map "\C-n" 'next-line) -(define-key global-map "\C-p" 'previous-line) -;(define-key global-map "\C-x\C-n" 'set-goal-column) -;; XEmacs: -;;; Many people have said they rarely use this feature, and often type -;;; it by accident. Maybe it shouldn't even be on a key. -;;; Done. -hniksic -;(put 'set-goal-column 'disabled t) - -(define-key global-map [menu] 'execute-extended-command) -(define-key global-map [find] 'search-forward) - -(define-key global-map "\C-t" 'transpose-chars) -(define-key global-map "\M-t" 'transpose-words) -(define-key global-map "\M-\C-t" 'transpose-sexps) -(define-key global-map "\C-x\C-t" 'transpose-lines) - -(define-key global-map "\M-;" 'indent-for-comment) -(define-key global-map "\M-j" 'indent-new-comment-line) -(define-key global-map "\M-\C-j" 'indent-new-comment-line) -(define-key global-map "\C-x;" 'set-comment-column) -(define-key global-map "\C-xf" 'set-fill-column) -(define-key global-map "\C-x$" 'set-selective-display) - -(define-key global-map "\M-@" 'mark-word) -(define-key global-map "\M-f" 'forward-word) -(define-key global-map "\M-b" 'backward-word) -(define-key global-map "\M-d" 'kill-word) - -(define-key global-map "\M-<" 'beginning-of-buffer) -(define-key global-map "\M->" 'end-of-buffer) -(define-key global-map "\C-xh" 'mark-whole-buffer) -(define-key global-map "\M-\\" 'delete-horizontal-space) - -(define-key global-map "\M-\C-f" 'forward-sexp) -(define-key global-map "\M-\C-b" 'backward-sexp) -(define-key global-map "\M-\C-u" 'backward-up-list) -(define-key global-map "\M-\C-@" 'mark-sexp) -(define-key global-map "\M-\C-d" 'down-list) -(define-key global-map "\M-\C-k" 'kill-sexp) -(define-key global-map "\M-\C-n" 'forward-list) -(define-key global-map "\M-\C-p" 'backward-list) -(define-key global-map "\M-\C-a" 'beginning-of-defun) -(define-key global-map "\M-\C-e" 'end-of-defun) -(define-key global-map "\M-\C-h" 'mark-defun) -(define-key global-map "\M-\(" 'insert-parentheses) -(define-key global-map "\M-\)" 'move-past-close-and-reindent) -(define-key global-map "\M-\t" 'lisp-complete-symbol) - -(define-key global-map '(control meta backspace) 'backward-kill-sexp) -(define-key global-map '(control meta delete) 'backward-or-forward-kill-sexp) - - -(define-key global-map "\C-x/" 'point-to-register) -(define-key global-map "\C-xj" 'jump-to-register) -(define-key global-map "\C-xx" 'copy-to-register) -(define-key global-map "\C-xg" 'insert-register) -;; Old v18 binding -;(define-key global-map "\C-xr" 'copy-rectangle-to-register) - -;; New FSF19 bindings: C-x r as a prefix for register commands -(define-key global-map "\C-xr" (let ((map (make-sparse-keymap))) - (set-keymap-name map 'rectangle-prefix) - map)) -(define-key global-map "\C-xr\C-@" 'point-to-register) -(define-key global-map "\C-xr " 'point-to-register) -(define-key global-map "\C-xrj" 'jump-to-register) -(define-key global-map "\C-xrs" 'copy-to-register) -(define-key global-map "\C-xrx" 'copy-to-register) -(define-key global-map "\C-xri" 'insert-register) -(define-key global-map "\C-xrg" 'insert-register) -(define-key global-map "\C-xrr" 'copy-rectangle-to-register) -(define-key global-map "\C-xrc" 'clear-rectangle) -(define-key global-map "\C-xrk" 'kill-rectangle) -(define-key global-map "\C-xry" 'yank-rectangle) -(define-key global-map "\C-xro" 'open-rectangle) -(define-key global-map "\C-xrt" 'string-rectangle) -(define-key global-map "\C-xrw" 'window-configuration-to-register) -;(define-key global-map "\C-xrf" 'frame-configuration-to-register) - -(define-key global-map "\M-q" 'fill-paragraph-or-region) -;(define-key global-map "\M-q" 'fill-paragraph) -;(define-key global-map "\M-g" 'fill-region) ;now bound to goto-line -(define-key global-map "\C-x." 'set-fill-prefix) - -; Using {} instead of [] is 1) FSF compatible and 2) allows function -; keys to work on ttys. M-[ is the beginning of most the function key -; sequences. -(define-key global-map "\M-{" 'backward-paragraph) -(define-key global-map "\M-}" 'forward-paragraph) -(define-key global-map "\M-h" 'mark-paragraph) -(define-key global-map "\M-a" 'backward-sentence) -(define-key global-map "\M-e" 'forward-sentence) -(define-key global-map "\M-k" 'kill-sentence) -;;(define-key global-map "\C-x\177" 'backward-kill-sentence) - -(define-key global-map "\C-x[" 'backward-page) -(define-key global-map "\C-x]" 'forward-page) -(define-key global-map "\C-x\C-p" 'mark-page) -(define-key global-map "\C-xl" 'count-lines-page) -(define-key global-map "\C-xnp" 'narrow-to-page) -;; Old v18 bindings -;(define-key global-map "\C-xp" 'narrow-to-page) -(put 'narrow-to-page 'disabled t) - -;; Old v18 bindings -;(define-key global-map "\C-x\C-a" 'add-mode-abbrev) -;(define-key global-map "\C-x+" 'add-global-abbrev) -;(define-key global-map "\C-x\C-h" 'inverse-add-mode-abbrev) -;(define-key global-map "\C-x-" 'inverse-add-global-abbrev) - -(define-key global-map "\M-'" 'abbrev-prefix-mark) -(define-key global-map "\C-x'" 'expand-abbrev) - -;; New FSF19 bindings: C-x a as a prefix for abbrev commands -(define-key global-map "\C-xal" 'add-mode-abbrev) -(define-key global-map "\C-xa\C-a" 'add-mode-abbrev) -(define-key global-map "\C-xag" 'add-global-abbrev) -(define-key global-map "\C-xa+" 'add-mode-abbrev) -(define-key global-map "\C-xaig" 'inverse-add-global-abbrev) -(define-key global-map "\C-xail" 'inverse-add-mode-abbrev) -(define-key global-map "\C-xa-" 'inverse-add-global-abbrev) -(define-key global-map "\C-xae" 'expand-abbrev) -(define-key global-map "\C-xa'" 'expand-abbrev) - -(define-key global-map "\M-\C-l" 'switch-to-other-buffer) - -;; Default binding of "Backspace" is no longer the same as delete. -;; Default binding of "Control-h" is help. -(define-key global-map 'backspace 'delete-backward-char) -(define-key global-map '(meta backspace) 'backward-kill-word) - -(define-key global-map "\M-\C-z" 'activate-region) - -;; FSFmacs macros.c - -(define-key global-map "\C-xe" 'call-last-kbd-macro) -(define-key global-map "\C-x\(" 'start-kbd-macro) -(define-key global-map "\C-x\)" 'end-kbd-macro) - -;; FSFmacs macros.el - -(define-key global-map "\C-xq" 'kbd-macro-query) - - -;; FSFmacs minibuffer.c -; see also minibuf.el - -(define-key global-map "\M-\C-c" 'exit-recursive-edit) -(define-key global-map "\C-]" 'abort-recursive-edit) -(define-key global-map "\M-x" 'execute-extended-command) - -;; FSFmacs window.c - -(define-key global-map "\C-x0" 'delete-window) -(define-key global-map "\C-x1" 'delete-other-windows) -(define-key global-map "\C-x2" 'split-window-vertically) -(define-key global-map "\C-x3" 'split-window-horizontally) -;; Old XEmacs binding -;;(define-key global-map "\C-x5" 'split-window-horizontally) -(define-key global-map "\C-xo" 'other-window) -(define-key global-map "\C-x^" 'enlarge-window) -(define-key global-map "\C-x<" 'scroll-left) -(define-key global-map "\C-x>" 'scroll-right) - -(define-key global-map "\C-v" 'scroll-up) -(define-key global-map "\M-v" 'scroll-down) -(define-key global-map "\M-\C-v" 'scroll-other-window) -; meta-shift-V, that is. -(define-key global-map '(meta V) 'scroll-other-window-down) - -(define-key global-map "\C-l" 'recenter) -(define-key global-map "\M-r" 'move-to-window-line) - -;; FSFmacs window.el - -(define-key global-map "\C-x6" 'window-configuration-to-register) -;(define-key global-map "\C-x7" 'jump-to-register);ie register-to-window-config -(define-key global-map "\C-x}" 'enlarge-window-horizontally) -(define-key global-map "\C-x{" 'shrink-window-horizontally) -;; New FSF19 bindings -(define-key global-map "\C-x-" 'shrink-window-if-larger-than-buffer) -(define-key global-map "\C-x+" 'balance-windows) -(define-key ctl-x-4-map "0" 'kill-buffer-and-window) - -;;(define-key global-map "\C-g" 'keyboard-quit) -(let ((ch (quit-char))) - (if (or (characterp ch) (integerp ch)) - (setq ch (char-to-string ch))) - (define-key global-map ch 'keyboard-quit)) -(define-key global-map "\e\e\e" 'keyboard-escape-quit) - - - - - - -(define-key global-map "\M-%" 'query-replace) - - -; autoloaded -;(define-key global-map "\C-x4a" 'add-change-log-entry-other-window) - -; autoloaded -;(define-key global-map "\C-x`" 'next-error) - -; autoloaded -;(define-key global-map "\M-/" 'dabbrev-expand) - -; autoloaded -;(define-key global-map "\C-xd" 'dired) - -; autoloaded -;(define-key global-map "\C-x4d" 'dired-other-window) - -(define-key global-map "\M-$" 'ispell-word) - -(define-key global-map "\C-xm" 'compose-mail) -(define-key global-map "\C-x4m" 'compose-mail-other-window) -(define-key global-map "\C-x5m" 'compose-mail-other-frame) - -(define-key global-map "\M-." 'find-tag) - -(define-key global-map "\C-x4." 'find-tag-other-window) - -(define-key global-map "\M-," 'tags-loop-continue) - - -(define-key global-map '(control <) 'mark-beginning-of-buffer) -(define-key global-map '(control >) 'mark-end-of-buffer) - -(define-key global-map "\C-x\C-e" 'eval-last-sexp) ;bogus! - - -(define-key global-map "\M-g" 'goto-line) - -;; Keypad type things - -;; I removed all the fkey crap, because where-is is now smart enough -;; to show all bindings. --ben - -;;; These aren't bound to kbd macros like "\C-b" so that they have the -;; expected behavior even in, for example, vi-mode. - -;; We use here symbolic names, assuming that the corresponding keys will -;; generate these keysyms. This is not true on Suns, but x-win-sun.el -;; fixes that. If it turns out that the semantics of these keys should -;; differ from server to server, this should be moved into server-specific -;; files, but these appear to be the standard Motif and PC bindings. - -;; movement by units -(define-key global-map 'left 'backward-char) -(define-key global-map 'up 'previous-line) -(define-key global-map 'right 'forward-char) -(define-key global-map 'down 'next-line) - -;; movement by pages -(define-key global-map 'prior 'scroll-down) -(define-key global-map 'next 'scroll-up) - -;; movement to the limits -(define-key global-map 'home 'beginning-of-line) -(define-key global-map 'end 'end-of-line) - -;;; Miscellaneous key bindings -(define-key global-map 'again 'repeat-complex-command) -(define-key global-map 'insert 'overwrite-mode) - -;;; These aren't bound to kbd macros like "\C-b" so that they have the -;; expected behavior even in, for example, vi-mode. - -;; We use here symbolic names, assuming that the corresponding keys will -;; generate these keysyms. This is not true on Suns, but x-win-sun.el -;; fixes that. If it turns out that the semantics of these keys should -;; differ from server to server, this should be moved into server-specific -;; files, but these appear to be the standard Motif and PC bindings. - -;; potential R6isms -(define-key global-map 'kp-left 'backward-char) -(define-key global-map 'kp-up 'previous-line) -(define-key global-map 'kp-right 'forward-char) -(define-key global-map 'kp-down 'next-line) - - -;; movement by larger blocks -(define-key global-map '(control left) 'backward-word) -(define-key global-map '(control up) #'(lambda () - (interactive "_") - (forward-line -6))) -(define-key global-map '(control right) 'forward-word) -(define-key global-map '(control down) #'(lambda () - (interactive "_") - (forward-line 6))) - -;; context-sensitive movement -(define-key global-map '(meta left) 'backward-sexp) -(define-key global-map '(meta right) 'forward-sexp) -(define-key global-map '(meta up) 'backward-paragraph) -(define-key global-map '(meta down) 'forward-paragraph) - -;; movement by pages -(define-key global-map '(control prior) 'scroll-right) -(define-key global-map '(control next) 'scroll-left) -;; potential R6isms -(define-key global-map 'kp-prior 'scroll-down) -(define-key global-map 'kp-next 'scroll-up) -(define-key global-map '(control kp-prior) 'scroll-right) -(define-key global-map '(control kp-next) 'scroll-left) - - -;; movement to the limits -(define-key global-map '(control home) 'beginning-of-buffer) -(define-key global-map '(control end) 'end-of-buffer) -(define-key global-map 'begin 'beginning-of-line) -(define-key global-map '(control begin) 'beginning-of-buffer) -;; potential R6isms -(define-key global-map 'kp-home 'beginning-of-line) -(define-key global-map '(control kp-home) 'beginning-of-buffer) -(define-key global-map 'kp-end 'end-of-line) -(define-key global-map '(control kp-end) 'end-of-buffer) - -;; movement between windows -(define-key global-map '(control tab) 'other-window) -(define-key global-map '(control shift tab) 'backward-other-window) - -;; movement in other windows -(define-key global-map '(meta next) 'scroll-other-window) -(define-key global-map '(meta prior) 'scroll-other-window-down) -(define-key global-map '(meta home) 'beginning-of-buffer-other-window) -(define-key global-map '(meta end) 'end-of-buffer-other-window) -;; potential R6isms -(define-key global-map '(meta kp-next) 'scroll-other-window) -(define-key global-map '(meta kp-prior) 'scroll-other-window-down) -(define-key global-map '(meta kp-home) 'beginning-of-buffer-other-window) -(define-key global-map '(meta kp-end) 'end-of-buffer-other-window) - -;; potential R6isms -(define-key global-map 'redo 'repeat-complex-command) -(define-key global-map 'kp-insert 'overwrite-mode) -(define-key global-map 'kp-delete 'backward-delete-char-untabify) - -(define-key global-map 'kp-enter [return]) ; do whatever RET does now -(define-key global-map 'kp-tab [tab]) - -(define-key global-map 'undo 'undo) -(define-key global-map 'help 'help-for-help) - -(define-key global-map 'kp-space 'self-insert-command) -(define-key global-map 'kp-equal 'self-insert-command) -(define-key global-map 'kp-multiply 'self-insert-command) -(define-key global-map 'kp-add 'self-insert-command) -(define-key global-map 'kp-separator 'self-insert-command) -(define-key global-map 'kp-subtract 'self-insert-command) -(define-key global-map 'kp-decimal 'self-insert-command) -(define-key global-map 'kp-divide 'self-insert-command) - -(define-key global-map 'kp-0 'self-insert-command) -(define-key global-map 'kp-1 'self-insert-command) -(define-key global-map 'kp-2 'self-insert-command) -(define-key global-map 'kp-3 'self-insert-command) -(define-key global-map 'kp-4 'self-insert-command) -(define-key global-map 'kp-5 'self-insert-command) -(define-key global-map 'kp-6 'self-insert-command) -(define-key global-map 'kp-7 'self-insert-command) -(define-key global-map 'kp-8 'self-insert-command) -(define-key global-map 'kp-9 'self-insert-command) - -(define-key global-map 'select 'function-key-error) -(define-key global-map 'print 'function-key-error) -(define-key global-map 'execute 'execute-extended-command) -(define-key global-map 'clearline 'function-key-error) -(define-key global-map 'insertline 'open-line) -(define-key global-map 'deleteline 'kill-line) -(define-key global-map 'insertchar 'function-key-error) -(define-key global-map 'deletechar 'delete-char) - -;;; keydefs.el ends here
--- a/lisp/prim/keymap.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,444 +0,0 @@ -;; Keymap functions. -;; Copyright (C) 1993, 1994 Free Software Foundation, Inc. -;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp. - -;; 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, 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: FSF 19.28. -;;; Note: FSF does not have a file keymap.el. This stuff is -;;; in keymap.c. - -;Prevent the \{...} documentation construct -;from mentioning keys that run this command. -(put 'undefined 'suppress-keymap t) - -(defun undefined () - (interactive) - (ding)) - -(defun suppress-keymap (map &optional nodigits) - "Make MAP override all normally self-inserting keys to be undefined. -Normally, as an exception, digits and minus-sign are set to make prefix args, -but optional second arg NODIGITS non-nil treats them like other chars." - (substitute-key-definition 'self-insert-command 'undefined map global-map) - (or nodigits - (let ((string (make-string 1 ?0))) - (define-key map "-" 'negative-argument) - ;; Make plain numbers do numeric args. - (while (<= (aref string 0) ?9) - (define-key map string 'digit-argument) - (incf (aref string 0)))))) - -(defun substitute-key-definition (olddef newdef keymap &optional oldmap prefix) - "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF. -In other words, OLDDEF is replaced with NEWDEF wherever it appears. -Prefix keymaps are checked recursively. If optional fourth argument OLDMAP -is specified, we redefine in KEYMAP as NEWDEF those chars which are defined -as OLDDEF in OLDMAP, unless that keybinding is already present in keymap. -If optional fifth argument PREFIX is defined, then only those occurrences of -OLDDEF found in keymaps accessible through the keymap bound to PREFIX in -KEYMAP are redefined. See also `accessible-keymaps'." - (let ((maps (accessible-keymaps (or oldmap keymap) prefix)) - (shadowing (not (null oldmap))) - prefix map) - (while maps - (setq prefix (car (car maps)) - map (cdr (car maps)) - maps (cdr maps)) - ;; Substitute in this keymap - (map-keymap #'(lambda (key binding) - (if (eq binding olddef) - ;; The new bindings always go in KEYMAP even if we - ;; found them in OLDMAP or one of it's children. - ;; If KEYMAP will be shadowing OLDMAP, then do not - ;; redefine the key if there is another binding - ;; in KEYMAP that will shadow OLDDEF. - (or (and shadowing - (lookup-key keymap key)) - ;; define-key will give an error if a prefix - ;; of the key is already defined. Otherwise - ;; it will define the key in the map. - ;; #### - Perhaps this should be protected? - (define-key - keymap - (vconcat prefix (list key)) - newdef)))) - map) - ))) - - -;; From Bill Dubuque <wgd@martigny.ai.mit.edu> - -;; This used to wrap forms into an interactive lambda. It is unclear -;; to me why this is needed in this function. Anyway, -;; `key-or-menu-binding' doesn't do it, so this function no longer -;; does it, either. -(defun insert-key-binding (key) ; modeled after describe-key - "Insert the command bound to KEY." - (interactive "kInsert command bound to key: ") - (let ((defn (key-or-menu-binding key))) - (if (or (null defn) (integerp defn)) - (error "%s is undefined" (key-description key)) - (if (or (stringp defn) (vectorp defn)) - (setq defn (key-binding defn))) ;; a keyboard macro - (insert (format "%s" defn))))) - -;; From Bill Dubuque <wgd@martigny.ai.mit.edu> -(defun read-command-or-command-sexp (prompt) - "Read a command symbol or command sexp. -A command sexp is wrapped in an interactive lambda if needed. -Prompts with PROMPT." - ;; Todo: it would be better if we could reject symbols that are not - ;; commandp (as does 'read-command') but that is not easy to do - ;; because we must supply arg4 = require-match = nil for sexp case. - (let ((result (car (read-from-string - (completing-read prompt obarray 'commandp))))) - (if (and (consp result) - (not (eq (car result) 'lambda))) - `(lambda () - (interactive) - ,result) - result))) - -(defun local-key-binding (keys) - "Return the binding for command KEYS in current local keymap only. -KEYS is a string, a vector of events, or a vector of key-description lists -as described in the documentation for the `define-key' function. -The binding is probably a symbol with a function definition; see -the documentation for `lookup-key' for more information." - (let ((map (current-local-map))) - (if map - (lookup-key map keys) - nil))) - -(defun global-key-binding (keys) - "Return the binding for command KEYS in current global keymap only. -KEYS is a string or vector of events, a sequence of keystrokes. -The binding is probably a symbol with a function definition; see -the documentation for `lookup-key' for more information." - (lookup-key (current-global-map) keys)) - -;; from Bill Dubuque <wgd@martigny.ai.mit.edu> -(defun global-set-key (key command) - "Give KEY a global binding as COMMAND. -COMMAND is a symbol naming an interactively-callable function. -KEY is a string, a vector of events, or a vector of key-description lists -as described in the documentation for the `define-key' function. -Note that if KEY has a local binding in the current buffer -that local binding will continue to shadow any global binding." - ;;(interactive "KSet key globally: \nCSet key %s to command: ") - (interactive (list (setq key (read-key-sequence "Set key globally: ")) - ;; Command sexps are allowed here so that this arg - ;; may be supplied interactively via insert-key-binding. - (read-command-or-command-sexp - (format "Set key %s to command: " - (key-description key))))) - (define-key (current-global-map) key command) - nil) - -;; from Bill Dubuque <wgd@martigny.ai.mit.edu> -(defun local-set-key (key command) - "Give KEY a local binding as COMMAND. -COMMAND is a symbol naming an interactively-callable function. -KEY is a string, a vector of events, or a vector of key-description lists -as described in the documentation for the `define-key' function. -The binding goes in the current buffer's local map, -which is shared with other buffers in the same major mode." - ;;(interactive "KSet key locally: \nCSet key %s locally to command: ") - (interactive (list (setq key (read-key-sequence "Set key locally: ")) - ;; Command sexps are allowed here so that this arg - ;; may be supplied interactively via insert-key-binding. - (read-command-or-command-sexp - (format "Set key %s locally to command: " - (key-description key))))) - (if (null (current-local-map)) - (use-local-map (make-sparse-keymap))) - (define-key (current-local-map) key command) - nil) - -(defun global-unset-key (key) - "Remove global binding of KEY. -KEY is a string, a vector of events, or a vector of key-description lists -as described in the documentation for the `define-key' function." - (interactive "kUnset key globally: ") - (global-set-key key nil)) - -(defun local-unset-key (key) - "Remove local binding of KEY. -KEY is a string, a vector of events, or a vector of key-description lists -as described in the documentation for the `define-key' function." - (interactive "kUnset key locally: ") - (if (current-local-map) - (define-key (current-local-map) key nil))) - - -;; Yet more RMS brain-death. -(defun minor-mode-key-binding (key &optional accept-default) - "Find the visible minor mode bindings of KEY. -Return an alist of pairs (MODENAME . BINDING), where MODENAME is -the symbol which names the minor mode binding KEY, and BINDING is -KEY's definition in that mode. In particular, if KEY has no -minor-mode bindings, return nil. If the first binding is a -non-prefix, all subsequent bindings will be omitted, since they would -be ignored. Similarly, the list doesn't include non-prefix bindings -that come after prefix bindings. - -If optional argument ACCEPT-DEFAULT is non-nil, recognize default -bindings; see the description of `lookup-key' for more details about this." - (let ((tail minor-mode-map-alist) - a s v) - (while tail - (setq a (car tail) - tail (cdr tail)) - (and (consp a) - (symbolp (setq s (car a))) - (boundp s) - (symbol-value s) - ;; indirect-function deals with autoloadable keymaps - (setq v (indirect-function (cdr a))) - (setq v (lookup-key v key accept-default)) - ;; Terminate loop, with v set to non-nil value - (setq tail nil))) - v)) - - -(defun current-minor-mode-maps () - "Return a list of keymaps for the minor modes of the current buffer." - (let ((l '()) - (tail minor-mode-map-alist) - a s v) - (while tail - (setq a (car tail) - tail (cdr tail)) - (and (consp a) - (symbolp (setq s (car a))) - (boundp s) - (symbol-value s) - ;; indirect-function deals with autoloadable keymaps - (setq v (indirect-function (cdr a))) - (setq l (cons v l)))) - (nreverse l))) - - -;;#### What a crock -(defun define-prefix-command (name &optional mapvar) - "Define COMMAND as a prefix command. -A new sparse keymap is stored as COMMAND's function definition. -If second optional argument MAPVAR is not specified, - COMMAND's value (as well as its function definition) is set to the keymap. -If a second optional argument MAPVAR is given and is not `t', - the map is stored as its value. -Regardless of MAPVAR, COMMAND's function-value is always set to the keymap." - (let ((map (make-sparse-keymap name))) - (fset name map) - (cond ((not mapvar) - (set name map)) - ((eq mapvar 't) - ) - (t - (set mapvar map))) - name)) - - -;;; Converting vectors of events to a read-equivalent form. -;;; This is used both by call-interactively (for the command history) -;;; and by macros.el (for saving keyboard macros to a file). - -;; ### why does (events-to-keys [backspace]) return "\C-h"? -;; BTW, this function is a mess, and macros.el does *not* use it, in -;; spite of the above comment. `format-kbd-macro' is used to save -;; keyboard macros to a file. -(defun events-to-keys (events &optional no-mice) - "Given a vector of event objects, returns a vector of key descriptors, -or a string (if they all fit in the ASCII range). -Optional arg NO-MICE means that button events are not allowed." - (if (and events (symbolp events)) (setq events (vector events))) - (cond ((stringp events) - events) - ((not (vectorp events)) - (signal 'wrong-type-argument (list 'vectorp events))) - ((let* ((length (length events)) - (string (make-string length 0)) - c ce - (i 0)) - (while (< i length) - (setq ce (aref events i)) - (or (eventp ce) (setq ce (character-to-event ce))) - ;; Normalize `c' to `?c' and `(control k)' to `?\C-k' - ;; By passing t for the `allow-meta' arg we could get kbd macros - ;; with meta in them to translate to the string form instead of - ;; the list/symbol form; but I expect that would cause confusion, - ;; so let's use the list/symbol form whenever there's - ;; any ambiguity. - (setq c (event-to-character ce)) - (if (and c - character-set-property - (key-press-event-p ce)) - (cond ((symbolp (event-key ce)) - (if (get (event-key ce) character-set-property) - ;; Don't use a string for `backspace' and `tab' to - ;; avoid that unpleasant little ambiguity. - (setq c nil))) - ((and (= (event-modifier-bits ce) 1) ;control - (integerp (event-key ce))) - (let* ((te (character-to-event c))) - (if (and (symbolp (event-key te)) - (get (event-key te) character-set-property)) - ;; Don't "normalize" (control i) to tab - ;; to avoid the ambiguity in the other direction - (setq c nil)) - (deallocate-event te))))) - (if c - (aset string i c) - (setq i length string nil)) - (setq i (1+ i))) - string)) - (t - (let* ((length (length events)) - (new (copy-sequence events)) - event mods key - (i 0)) - (while (< i length) - (setq event (aref events i)) - (cond ((key-press-event-p event) - (setq mods (event-modifiers event) - key (event-key event)) - (if (numberp key) - (setq key (intern (make-string 1 key)))) - (aset new i (if mods - (nconc mods (cons key nil)) - key))) - ((misc-user-event-p event) - (aset new i (list 'menu-selection - (event-function event) - (event-object event)))) - ((or (button-press-event-p event) - (button-release-event-p event)) - (if no-mice - (error - "Mouse events can't be saved in keyboard macros.")) - (setq mods (event-modifiers event) - key (intern (concat "button" - (event-button event) - (if (button-release-event-p event) - "up" "")))) - (aset new i (if mods - (nconc mods (cons key nil)) - key))) - ((or (and event (symbolp event)) - (and (consp event) (symbolp (car event)))) - (aset new i event)) - (t - (signal 'wrong-type-argument (list 'eventp event)))) - (setq i (1+ i))) - new)))) - - -(defun next-key-event () - "Return the next available keyboard event." - (let (event) - (while (not (key-press-event-p (setq event (next-event)))) - (dispatch-event event)) - event)) - -(defun key-sequence-list-description (keys) - "Convert a key sequence KEYS to the full [(modifiers... key)...] form. -Argument KEYS can be in any form accepted by `define-key' function." - (let ((vec - (cond ((vectorp keys) - keys) - ((stringp keys) - (vconcat keys)) - (t - (vector keys)))) - (event-to-list - #'(lambda (ev) - (append (event-modifiers ev) (list (event-key ev)))))) - (mapvector - #'(lambda (key) - (cond ((key-press-event-p key) - (funcall event-to-list key)) - ((characterp key) - (funcall event-to-list (character-to-event key))) - ((listp key) - key) - (t - (list key)))) - vec))) - - -;;; Support keyboard commands to turn on various modifiers. - -;;; These functions -- which are not commands -- each add one modifier -;;; to the following event. - -(defun event-apply-alt-modifier (ignore-prompt) - (event-apply-modifier 'alt)) -(defun event-apply-super-modifier (ignore-prompt) - (event-apply-modifier 'super)) -(defun event-apply-hyper-modifier (ignore-prompt) - (event-apply-modifier 'hyper)) -(defun event-apply-shift-modifier (ignore-prompt) - (event-apply-modifier 'shift)) -(defun event-apply-control-modifier (ignore-prompt) - (event-apply-modifier 'control)) -(defun event-apply-meta-modifier (ignore-prompt) - (event-apply-modifier 'meta)) - -;;; #### `key-translate-map' is ignored for now. -(defun event-apply-modifier (symbol) - "Return the next key event, with a modifier flag applied. -SYMBOL is the name of this modifier, as a symbol. -`function-key-map' is scanned for prefix bindings." - (let (events binding) - ;; read keystrokes scanning `function-key-map' - (while (keymapp - (setq binding - (lookup-key - function-key-map - (vconcat - (setq events - (append events (list (next-key-event))))))))) - (if binding ; found a binding - (progn - ;; allow for several modifiers - (if (and (symbolp binding) (fboundp binding)) - (setq binding (funcall binding nil))) - (setq events (append binding nil)) - ;; put remaining keystrokes back into input queue - (setq unread-command-events - (mapcar 'character-to-event (cdr events)))) - (setq unread-command-events (cdr events))) - ;; add a modifier SYMBOL to the first keystroke or event - (vector - (append (list symbol) - (delq symbol - (aref (key-sequence-list-description (car events)) 0)))))) - -;; This looks dirty. The following code should maybe go to another -;; file, and `create-console-hook' should maybe default to nil. -(add-hook - 'create-console-hook - #'(lambda (console) - (letf (((selected-console) console)) - (define-key function-key-map [?\C-x ?@ ?h] 'event-apply-hyper-modifier) - (define-key function-key-map [?\C-x ?@ ?s] 'event-apply-super-modifier) - (define-key function-key-map [?\C-x ?@ ?m] 'event-apply-meta-modifier) - (define-key function-key-map [?\C-x ?@ ?S] 'event-apply-shift-modifier) - (define-key function-key-map [?\C-x ?@ ?c] 'event-apply-control-modifier) - (define-key function-key-map [?\C-x ?@ ?a] 'event-apply-alt-modifier))))
--- a/lisp/prim/lisp.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,356 +0,0 @@ -;;; lisp.el --- Lisp editing commands for XEmacs - -;; Copyright (C) 1985, 1986, 1994, 1997 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: lisp, languages - -;; 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: Emacs/Mule zeta. - -;;; Commentary: - -;; Lisp editing commands to go with Lisp major mode. - -;; 06/11/1997 - Use char-(after|before) instead of -;; (following|preceding)-char. -slb - -;;; Code: - -;; Note that this variable is used by non-lisp modes too. -(defcustom defun-prompt-regexp nil - "*Non-nil => regexp to ignore, before the character that starts a defun. -This is only necessary if the opening paren or brace is not in column 0. -See `beginning-of-defun'." - :type '(choice (const :tag "none" nil) - regexp) - :group 'lisp) - -(make-variable-buffer-local 'defun-prompt-regexp) - -(defcustom parens-require-spaces t - "Non-nil => `insert-parentheses' should insert whitespace as needed." - :type 'boolean - :group 'editing-basics - :group 'lisp) - -(defun forward-sexp (&optional arg) - "Move forward across one balanced expression (sexp). -With argument, do it that many times. Negative arg -N means -move backward across N balanced expressions." - ;; XEmacs change (for zmacs regions) - (interactive "_p") - (or arg (setq arg 1)) - ;; XEmacs: evil hack! The other half of the evil hack below. - (if (and (> arg 0) (looking-at "#s(")) - (goto-char (+ (point) 2))) - ;; XEmacs change -- don't bomb out if unbalanced sexp - (goto-char (or (scan-sexps (point) arg) (buffer-end arg))) - (if (< arg 0) (backward-prefix-chars)) - ;; XEmacs: evil hack! Skip back over #s so that structures are read - ;; properly. the current cheesified syntax tables just aren't up to - ;; this. - (if (and (< arg 0) - (eq (char-after (point)) ?\() - (>= (- (point) (point-min)) 2) - (eq (char-after (- (point) 1)) ?s) - (eq (char-after (- (point) 2)) ?#)) - (goto-char (- (point) 2)))) - -(defun backward-sexp (&optional arg) - "Move backward across one balanced expression (sexp). -With argument, do it that many times. Negative arg -N means -move forward across N balanced expressions." - ;; XEmacs change (for zmacs regions) - (interactive "_p") - (or arg (setq arg 1)) - (forward-sexp (- arg))) - -(defun mark-sexp (arg) - "Set mark ARG sexps from point. -The place mark goes is the same place \\[forward-sexp] would -move to with the same argument. -Repeat this command to mark more sexps in the same direction." - (interactive "p") - ;; XEmacs change - (mark-something 'mark-sexp 'forward-sexp arg)) - -(defun forward-list (&optional arg) - "Move forward across one balanced group of parentheses. -With argument, do it that many times. -Negative arg -N means move backward across N groups of parentheses." - ;; XEmacs change - (interactive "_p") - (or arg (setq arg 1)) - (goto-char (or (scan-lists (point) arg 0) (buffer-end arg)))) - -(defun backward-list (&optional arg) - "Move backward across one balanced group of parentheses. -With argument, do it that many times. -Negative arg -N means move forward across N groups of parentheses." - ;; XEmacs change (for zmacs regions) - (interactive "_p") - (or arg (setq arg 1)) - (forward-list (- arg))) - -(defun down-list (arg) - "Move forward down one level of parentheses. -With argument, do this that many times. -A negative argument means move backward but still go down a level. -In Lisp programs, an argument is required." - ;; XEmacs change (for zmacs regions) - (interactive "_p") - (let ((inc (if (> arg 0) 1 -1))) - (while (/= arg 0) - (goto-char (or (scan-lists (point) inc -1) (buffer-end arg))) - (setq arg (- arg inc))))) - -(defun backward-up-list (arg) - "Move backward out of one level of parentheses. -With argument, do this that many times. -A negative argument means move forward but still to a less deep spot. -In Lisp programs, an argument is required." - (interactive "_p") - (up-list (- arg))) - -(defun up-list (arg) - "Move forward out of one level of parentheses. -With argument, do this that many times. -A negative argument means move backward but still to a less deep spot. -In Lisp programs, an argument is required." - ;; XEmacs change (for zmacs regions) - (interactive "_p") - (let ((inc (if (> arg 0) 1 -1))) - (while (/= arg 0) - (goto-char (or (scan-lists (point) inc 1) (buffer-end arg))) - (setq arg (- arg inc))))) - -(defun kill-sexp (arg) - "Kill the sexp (balanced expression) following the cursor. -With argument, kill that many sexps after the cursor. -Negative arg -N means kill N sexps before the cursor." - (interactive "p") - (let ((opoint (point))) - (forward-sexp arg) - (kill-region opoint (point)))) - -(defun backward-kill-sexp (arg) - "Kill the sexp (balanced expression) preceding the cursor. -With argument, kill that many sexps before the cursor. -Negative arg -N means kill N sexps after the cursor." - (interactive "p") - (kill-sexp (- arg))) - -(defun beginning-of-defun (&optional arg) - "Move backward to the beginning of a defun. -With argument, do it that many times. Negative arg -N -means move forward to Nth following beginning of defun. -Returns t unless search stops due to beginning or end of buffer. - -Normally a defun starts when there is an char with open-parenthesis -syntax at the beginning of a line. If `defun-prompt-regexp' is -non-nil, then a string which matches that regexp may precede the -open-parenthesis, and point ends up at the beginning of the line." - ;; XEmacs change (for zmacs regions) - (interactive "_p") - (and (beginning-of-defun-raw arg) - (progn (beginning-of-line) t))) - -(defun beginning-of-defun-raw (&optional arg) - "Move point to the character that starts a defun. -This is identical to beginning-of-defun, except that point does not move -to the beginning of the line when `defun-prompt-regexp' is non-nil." - (interactive "p") - (and arg (< arg 0) (not (eobp)) (forward-char 1)) - (and (re-search-backward (if defun-prompt-regexp - (concat "^\\s(\\|" - "\\(" defun-prompt-regexp "\\)\\s(") - "^\\s(") - nil 'move (or arg 1)) - (progn (goto-char (1- (match-end 0)))) t)) - -;; XEmacs change (optional buffer parameter) -(defun buffer-end (arg &optional buffer) - "Return `point-max' of BUFFER if ARG is > 0; return `point-min' otherwise. -BUFFER defaults to the current buffer if omitted." - (if (> arg 0) (point-max buffer) (point-min buffer))) - -(defun end-of-defun (&optional arg) - "Move forward to next end of defun. With argument, do it that many times. -Negative argument -N means move back to Nth preceding end of defun. - -An end of a defun occurs right after the close-parenthesis that matches -the open-parenthesis that starts a defun; see `beginning-of-defun'." - ;; XEmacs change (for zmacs regions) - (interactive "_p") - (if (or (null arg) (= arg 0)) (setq arg 1)) - (let ((first t)) - (while (and (> arg 0) (< (point) (point-max))) - (let ((pos (point))) ; XEmacs -- remove unused npos. - (while (progn - (if (and first - (progn - (end-of-line 1) - (beginning-of-defun-raw 1))) - nil - (or (bobp) (forward-char -1)) - (beginning-of-defun-raw -1)) - (setq first nil) - (forward-list 1) - (skip-chars-forward " \t") - (if (looking-at "\\s<\\|\n") - (forward-line 1)) - (<= (point) pos)))) - (setq arg (1- arg))) - (while (< arg 0) - (let ((pos (point))) - (beginning-of-defun-raw 1) - (forward-sexp 1) - (forward-line 1) - (if (>= (point) pos) - (if (beginning-of-defun-raw 2) - (progn - (forward-list 1) - (skip-chars-forward " \t") - (if (looking-at "\\s<\\|\n") - (forward-line 1))) - (goto-char (point-min))))) - (setq arg (1+ arg))))) - -(defun mark-defun () - "Put mark at end of this defun, point at beginning. -The defun marked is the one that contains point or follows point." - (interactive) - (push-mark (point)) - (end-of-defun) - (push-mark (point) nil t) - (beginning-of-defun) - (re-search-backward "^\n" (- (point) 1) t)) - -(defun narrow-to-defun (&optional arg) - "Make text outside current defun invisible. -The defun visible is the one that contains point or follows point." - (interactive) - (save-excursion - (widen) - (end-of-defun) - (let ((end (point))) - (beginning-of-defun) - (narrow-to-region (point) end)))) - -(defun insert-parentheses (arg) - "Enclose following ARG sexps in parentheses. Leave point after open-paren. -A negative ARG encloses the preceding ARG sexps instead. -No argument is equivalent to zero: just insert `()' and leave point between. -If `parens-require-spaces' is non-nil, this command also inserts a space -before and after, depending on the surrounding characters." - (interactive "P") - (if arg (setq arg (prefix-numeric-value arg)) - (setq arg 0)) - (cond ((> arg 0) (skip-chars-forward " \t")) - ((< arg 0) (forward-sexp arg) (setq arg (- arg)))) - (and parens-require-spaces - (not (bobp)) - (memq (char-syntax (char-before (point))) '(?w ?_ ?\) )) - (insert " ")) - (insert ?\() - (save-excursion - (or (eq arg 0) (forward-sexp arg)) - (insert ?\)) - (and parens-require-spaces - (not (eobp)) - (memq (char-syntax (char-after (point))) '(?w ?_ ?\( )) - (insert " ")))) - -(defun move-past-close-and-reindent () - "Move past next `)', delete indentation before it, then indent after it." - (interactive) - (up-list 1) - (forward-char -1) - (while (save-excursion ; this is my contribution - (let ((before-paren (point))) - (back-to-indentation) - (= (point) before-paren))) - (delete-indentation)) - (forward-char 1) - (newline-and-indent)) - -(defun lisp-complete-symbol () - "Perform completion on Lisp symbol preceding point. -Compare that symbol against the known Lisp symbols. - -The context determines which symbols are considered. -If the symbol starts just after an open-parenthesis, only symbols -with function definitions are considered. Otherwise, all symbols with -function definitions, values or properties are considered." - (interactive) - (let* ((end (point)) - (buffer-syntax (syntax-table)) - (beg (unwind-protect - (save-excursion - ;; XEmacs change - (if emacs-lisp-mode-syntax-table - (set-syntax-table emacs-lisp-mode-syntax-table)) - (backward-sexp 1) - (while (eq (char-syntax (char-after (point))) ?\') - (forward-char 1)) - (point)) - (set-syntax-table buffer-syntax))) - (pattern (buffer-substring beg end)) - (predicate - (if (eq (char-after (1- beg)) ?\() - 'fboundp - ;; XEmacs change - #'(lambda (sym) - (or (boundp sym) (fboundp sym) - (symbol-plist sym))))) - (completion (try-completion pattern obarray predicate))) - (cond ((eq completion t)) - ((null completion) - (message "Can't find completion for \"%s\"" pattern) - (ding)) - ((not (string= pattern completion)) - (delete-region beg end) - (insert completion)) - (t - (message "Making completion list...") - (let ((list (all-completions pattern obarray predicate)) - ;FSFmacs crock unnecessary in XEmacs - ;see minibuf.el - ;(completion-fixup-function - ; (function (lambda () (if (save-excursion - ; (goto-char (max (point-min) - ; (- (point) 4))) - ; (looking-at " <f>")) - ; (forward-char -4)))) - ) - (or (eq predicate 'fboundp) - (let (new) - (while list - (setq new (cons (if (fboundp (intern (car list))) - (list (car list) " <f>") - (car list)) - new)) - (setq list (cdr list))) - (setq list (nreverse new)))) - (with-output-to-temp-buffer "*Completions*" - (display-completion-list list))) - (message "Making completion list...%s" "done"))))) - -;;; lisp.el ends here
--- a/lisp/prim/loaddefs.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,394 +0,0 @@ -;;; loaddefs.el --- define standard autoloads of other files - -;; Copyright (C) 1985, 1986, 1987, 1992-1995 Free Software Foundation, Inc. - -;; Maintainer: XEmacs -;; Keywords: internal - -;; 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, 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: Not synched with FSF. - -;;; Commentary: - -;;; !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -;;; Special formatting conventions are used in this file! -;;; -;;; a backslash-newline is used at the beginning of a documentation string -;;; when that string should be stored in the file lib-src/DOCnnn, not in core. -;;; -;;; Such strings read into Lisp as numbers (during the pure-loading phase). -;;; -;;; But you must obey certain rules to make sure the string is understood -;;; and goes into lib-src/DOCnnn properly. Otherwise, the string will not go -;;; anywhere! -;;; -;;; The doc string must appear in the standard place in a call to -;;; defun, autoload, defvar or defconst. No Lisp macros are recognized. -;;; The open-paren starting the definition must appear in column 0. -;;; -;;; In defvar and defconst, there is an additional rule: -;;; The double-quote that starts the string must be on the same -;;; line as the defvar or defconst. -;;; !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -;;; ********************************************************************** -;;; You should never need to write autoloads by hand and put them here. -;;; -;;; It is no longer necessary. Instead use autoload.el to maintain them -;;; for you. Just insert ";;;###autoload" before defuns or defmacros you -;;; want to be autoloaded, or other forms you want copied into loaddefs.el -;;; (defvars, key definitions, etc.). For example, -;;; ;;;###autoload -;;; (defun foobar () ....) -;;; ;;;###autoload (define-key global-map "f" 'foobar) -;;; ;;;###autoload -;;; (defvar foobar-var nil "\ -;;; This is foobar-var's doc-string.") -;;; -;;; Then do M-x update-file-autoloads on the file to update loaddefs.el. -;;; -;;; You can also use M-x update-directory-autoloads to update the autoloads -;;; in loaddefs.el for all .el files in the lisp/ directory, or M-x -;;; update-autoloads-here to update the autoloads for each file that -;;; already has an autoload section in this file. -;;; ********************************************************************** - - -;;; Code: - -;; These variables are used by autoloadable packages. -;; They are defined here so that they do not get overridden -;; by the loading of those packages. - - -;; Names in directory that end in one of these -;; are ignored in completion, -;; 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")))) - - -(setq debug-ignored-errors - '(beginning-of-line - beginning-of-buffer - end-of-line - end-of-buffer - end-of-file buffer-read-only - "\\`Previous command was not a yank\\'" - "\\`Minibuffer is not active for completion\\'" - "\\`No \\(following\\|preceding\\) item in .*-history\\'" - "\\`No recursive edit is in progress\\'" - "\\`Changes to be undone are outside visible portion of buffer\\'" - "\\`No further undo information\\'" - "\\`No undo information in this buffer\\'" - "\\`Buffer modified since last undo/redo, cannot redo" - "\\`Save not confirmed\\'" - "\\`Canceled\\'" - "\\`\\(Revert\\|Steal\\|Recover-file\\) cancelled\\.\\'" - - ;; comint - "\\`Not at command line\\'" - "\\`Empty input ring\\'" - "\\`No history\\'" - "\\`Not found\\'" ;; To common? - "\\`Current buffer has no process\\'" - - ;; dabbrev - "\\`No \\(further \\)?dynamic expansion for .* found\\.?\\'" - - ;; Completion - "\\`To complete, the point must be after a symbol at least [0-9]* character long\\.\\'" - "\\`The string \".*\" is too short to be saved as a completion\\.\\'" - - ;; Compile - "\\`No more errors\\( yet\\|\\)\\'" - - ;; Gnus - ;"\\`NNTP: Connection closed\\.\\'" - - ;; info - "\\`Node has no Previous\\'" - "\\`No \".*\" in index\\'" - - ;; imenu - ;"\\`No items suitable for an index found in this buffer\\.\\'" - ;"\\`The mode \".*\" does not take full advantage of imenu\\.el yet\\.\\'" - - ;; ispell - "\\`No word found to check!\\'" - - ;; man - "\\`.* not found\\'" - "\\`No more history\\.\\'" - - ;; etags - "\\`File .* is not a valid tag table\\'" - "\\`File .* is not a valid tags file\\'" - "\\`All files processed\\.\\'" - "No TAGS file name supplied\\'" - "\\`Nothing to complete\\'" - - ;; BBDB - "\\`no previous record\\'" - "\\`no next record\\'")) - -(make-variable-buffer-local 'indent-tabs-mode) - - -;;; This code also was not generated by autoload.el, because VM goes out -;;; of its way to be perverse. - -(autoload 'vm "vm" - "\ -View Mail: an alternate mail reader for emacs. -Optional first arg FOLDER specifies the folder to visit. It defaults -to the value of vm-primary-inbox. The folder buffer is put into VM -mode, a major mode for reading mail. - -Prefix arg or optional second arg READ-ONLY non-nil indicates -that the folder should be considered read only. No attribute -changes, messages additions or deletions will be allowed in the -visited folder. - -Visiting the primary inbox causes any contents of the system mailbox to -be moved and appended to the resulting buffer. - -All the messages can be read by repeatedly pressing SPC. Use `n'ext and -`p'revious to move about in the folder. Messages are marked for -deletion with `d', and saved to another folder with `s'. Quitting VM -with `q' expunges deleted messages and saves the buffered folder to -disk. - -See the documentation for vm-mode for more information." - t) - -(autoload 'vm-mode "vm" - "\ -View Mail: an alternate mail reader for emacs. - -Commands: - h - summarize folder contents - j - discard cached information about the current message - - n - go to next message - p - go to previous message - N - like `n' but ignores skip-variable settings - P - like `p' but ignores skip-variable settings - M-n - go to next unread message - M-p - go to previous unread message - RET - go to numbered message (uses prefix arg or prompts in minibuffer) - TAB - go to last message seen - M-s - incremental search through the folder - - t - display hidden headers - SPC - scroll forward a page (if at end of message, then display next message) - b - scroll backward a page - < - go to beginning of current message - > - go to end of current message - - d - delete message, prefix arg deletes messages forward (flag as deleted) - C-d - delete message, prefix arg deletes messages backward (flag as deleted) - u - undelete - k - flag for deletion all messages with same subject as the current message - - r - reply (only to the sender of the message) - R - reply with included text for current message - M-r - extract and resend bounced message - f - followup (reply to all recipients of message) - F - followup with included text from the current message - z - forward the current message - m - send a message - B - resend the current message to another user. - c - continue composing the most recent message you were composing - - @ - digestify and mail entire folder contents (the folder is not modified) - * - burst a digest into individual messages, and append and assimilate these - message into the current folder. - - G - sort messages by various keys - - g - get any new mail that has arrived in the system mailbox - (new mail is appended to the disk and buffer copies of the - primary inbox.) - v - visit another mail folder - V - visit a virtual folder - - e - edit the current message - - s - save current message in a folder (appends if folder already exists) - w - write current message to a file without its headers (appends if exists) - S - save entire folder to disk, expunging deleted messages - A - save unfiled messages to their vm-auto-folder-alist specified folders - # - expunge deleted messages (without saving folder) - q - quit VM, deleted messages are expunged, folder saved to disk - x - exit VM with no change to the folder - - M N - use marks; the next vm command will affect only marked messages - if it makes sense for the command to do so - - M M - mark the current message - M U - unmark the current message - M m - mark all messages - M u - unmark all messages - M ? - help for the mark commands - - W S - save the current window configuration to a name - W D - delete a window configuration - W W - apply a configuration - W ? - help for the window configuration commands - - C-_ - undo, special undo that retracts the most recent - changes in message attributes. Expunges and saves - cannot be undone. C-x u is also bound to this - command. - - L - reload your VM init file, ~/.vm - - ? - help - - ! - run a shell command - | - run a shell command with the current message as input - - M-C - view conditions under which you may redistribute VM - M-W - view the details of VM's lack of a warranty - -Variables: - vm-auto-center-summary - vm-auto-folder-alist - vm-auto-folder-case-fold-search - vm-auto-get-new-mail - vm-auto-next-message - vm-berkeley-mail-compatibility - vm-check-folder-types - vm-convert-folder-types - vm-circular-folders - vm-confirm-new-folders - vm-confirm-quit - vm-crash-box - vm-delete-after-archiving - vm-delete-after-bursting - vm-delete-after-saving - vm-delete-empty-folders - vm-digest-burst-type - vm-digest-center-preamble - vm-digest-preamble-format - vm-digest-send-type - vm-folder-directory - vm-folder-read-only - vm-follow-summary-cursor - vm-forwarded-headers - vm-forwarding-digest-type - vm-forwarding-subject-format - vm-gargle-uucp - vm-highlighted-header-regexp - vm-honor-page-delimiters - vm-in-reply-to-format - vm-included-text-attribution-format - vm-included-text-prefix - vm-inhibit-startup-message - vm-invisible-header-regexp - vm-jump-to-new-messages - vm-jump-to-unread-messages - vm-keep-sent-messages - vm-mail-header-from - vm-mail-mode-hook - vm-mail-window-percentage - vm-mode-hook - vm-move-after-deleting - vm-move-after-undeleting - vm-mutable-windows - vm-preview-lines - vm-preview-read-messages - vm-primary-inbox - vm-recognize-pop-maildrops - vm-reply-ignored-addresses - vm-reply-subject-prefix - vm-resend-bounced-headers - vm-resend-bounced-discard-header-regexp - vm-resend-headers - vm-resend-discard-header-regexp - vm-retain-message-order - vm-rfc1153-digest-discard-header-regexp - vm-rfc1153-digest-headers - vm-rfc934-digest-discard-header-regexp - vm-rfc934-digest-headers - vm-search-using-regexps - vm-skip-deleted-messages - vm-skip-read-messages - vm-spool-files - vm-startup-with-summary - vm-strip-reply-headers - vm-summary-format - vm-unforwarded-header-regexp - vm-virtual-folder-alist - vm-virtual-mirror - vm-visible-headers - vm-visit-when-saving - vm-window-configuration-file -" - t) - -(autoload 'vm-visit-folder "vm" - "\ -Visit a mail file with View Mail, an alternate mail reader for emacs. -See the description of the `vm' and `vm-mode' functions. - -VM will parse and present its messages to you in the usual way. - -First arg FOLDER specifies the mail file to visit. When this -command is called interactively the file name is read from the -minibuffer. - -Prefix arg or optional second arg READ-ONLY non-nil indicates -that the folder should be considered read only. No attribute -changes, messages additions or deletions will be allowed in the -visited folder." - t) - -(autoload 'vm-mail "vm" - "\ -Send a mail message from within View Mail, or from without." - t) - - -;;; Load in generated autoloads (made by autoload.el). -;; (condition-case nil - ;; (load "auto-autoloads") - ;; (file-error nil)) -(let ((dir load-path)) - (while dir - (condition-case nil - (load (concat (car dir) "auto-autoloads")) - (t nil)) - (pop dir))) - -;;; Local Variables: -;;; no-byte-compile: t -;;; no-update-autoloads: t -;;; End: -;;; loaddefs.el ends here
--- a/lisp/prim/loadup-el.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,25 +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, 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: Not in FSF. - -; always take .el files. -; don't put stuff into pure segment to avoid pure-space-exceeded error. - -(let ((load-ignore-elc-files t) - (purify-flag nil)) - (load "loadup.el"))
--- a/lisp/prim/loadup.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,213 +0,0 @@ -;;; loadup.el --- load up standardly loaded Lisp files for XEmacs. - -;; Copyright (C) 1985, 1986, 1992, 1994 Free Software Foundation, Inc. -;; Copyright (C) 1996 Richard Mlynarik. -;; Copyright (C) 1995, 1996 Ben Wing. - -;; Keywords: internal - -;; 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: Last synched with FSF 19.30, with wild divergence since. - -;;; Commentary: - -;; It is not a good idea to edit this file. Use site-init.el or site-load.el -;; instead. -;; -;; This is loaded into a bare Emacs to make a dumpable one. - -;;; Code: - -(if (fboundp 'error) - (error "loadup.el already loaded!")) - -(define-function 'defalias 'define-function) -(defvar running-xemacs t - "Non-nil when the current emacsen is XEmacs.") -(defvar preloaded-file-list nil - "List of files preloaded into the XEmacs binary image.") - -(call-with-condition-handler - ;; This is awfully damn early to be getting an error, right? - 'really-early-error-handler - #'(lambda () - ;; message not defined yet ... - (external-debugging-output (format "\nUsing load-path %s" load-path)) - - ;; We don't want to have any undo records in the dumped XEmacs. - (buffer-disable-undo (get-buffer "*scratch*")) - - ;; lread.c (or src/Makefile.in.in) has prepended "${srcdir}/../lisp/prim" - ;; to load-path, which is how this file has been found. At this point, - ;; enough of emacs has been initialized that we can call directory-files - ;; and get the rest of the dirs (so that we can dump stuff from modes/ - ;; and packages/.) - ;; - (let ((temp-path (expand-file-name ".." (car load-path)))) - (setq source-directory temp-path) - (setq load-path (nconc (mapcar - #'(lambda (i) (concat i "/")) - (directory-files temp-path t "^[^-.]" - nil 'dirs-only)) - (cons temp-path load-path)))) - - (setq load-warn-when-source-newer t ; set to nil at the end - load-warn-when-source-only t) - - ;; Inserted for debugging. Something is corrupting a single symbol - ;; somewhere to have an integer 0 property list. -slb 6/28/1997. - (defun test-atoms () - (mapatoms - #'(lambda (symbol) - (condition-case nil - (get symbol 'custom-group) - (t (princ - (format "Bad plist in %s, %s\n" - (symbol-name symbol) - (prin1-to-string (object-plist symbol))))))))) - - ;; garbage collect after loading every file in an attempt to - ;; minimize the size of the dumped image (if we don't do this, - ;; there will be lots of extra space in the data segment filled - ;; with garbage-collected junk) - (defmacro load-gc (file) - (list 'prog1 (list 'load file) - ;; '(test-atoms) - '(garbage-collect))) - ;; Need a minimal number hardcoded to get going for now. - ;; (load-gc "backquote") ; needed for defsubst etc. - ;; (load-gc "bytecomp-runtime") ; define defsubst - ;; (load-gc "subr") ; load the most basic Lisp functions - ;; (load-gc "replace") ; match-string used in version.el. - ;; (load-gc "version.el") ; Ignore compiled-by-mistake version.elc - ;; (load-gc "cl") - ;; (load-gc "featurep") ; OBSOLETE now - (load "dumped-lisp.el") - (let ((dumped-lisp-packages preloaded-file-list) - file) - (while (setq file (car dumped-lisp-packages)) - (load-gc file) - (setq dumped-lisp-packages (cdr dumped-lisp-packages))) - (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))) - (fmakunbound 'load-gc)) - )) ;; end of call-with-condition-handler - - -;; Fix up the preloaded file list -(setq preloaded-file-list (mapcar #'file-name-sans-extension - preloaded-file-list)) - -(setq load-warn-when-source-newer t ; set to t at top of file - load-warn-when-source-only nil) - -(setq debugger 'debug) - -(when (member "no-site-file" command-line-args) - (setq site-start-file nil)) - -;; If you want additional libraries to be preloaded and their -;; doc strings kept in the DOC file rather than in core, -;; you may load them with a "site-load.el" file. -;; 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)) - -;;FSFmacs randomness -;;(if (fboundp 'x-popup-menu) -;; (precompute-menubar-bindings)) -;;; Turn on recording of which commands get rebound, -;;; for the sake of the next call to precompute-menubar-bindings. -;(setq define-key-rebound-commands nil) - - -;; Note: all compiled Lisp files loaded above this point -;; must be among the ones parsed by make-docfile -;; to construct DOC. Any that are not processed -;; for DOC will not have doc strings in the dumped XEmacs. - -;; Don't bother with these if we're running temacs, i.e. if we're -;; just debugging don't waste time finding doc strings. - -;; purify-flag is nil if called from loadup-el.el. -(when purify-flag - (message "Finding pointers to doc strings...") - ;; (test-atoms) ; Debug -- Doesn't happen here - (Snarf-documentation "DOC") - ;; (test-atoms) ; Debug -- Doesn't happen here - (message "Finding pointers to doc strings...done") - (Verify-documentation) - ;; (test-atoms) ; Debug -- Doesn't happen here - ) - -;; 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)) -(setq current-load-list nil) -(garbage-collect) - -;;; At this point, we're ready to resume undo recording for scratch. -(buffer-enable-undo "*scratch*") - -;; Dump into the name `xemacs' (only) -(when (member "dump" command-line-args) - (message "Dumping under the name xemacs") - (condition-case () (delete-file "xemacs") (file-error nil)) - (when (fboundp 'really-free) - (really-free)) - (dump-emacs "xemacs" "temacs") - (kill-emacs)) - -(when (member "run-temacs" command-line-args) - (message "\nBootstrapping from temacs...") - (setq purify-flag nil) - ;; Remove all args up to and including "run-temacs" - (apply #'run-emacs-from-temacs (cdr (member "run-temacs" command-line-args))) - ;; run-emacs-from-temacs doesn't actually return anyway. - (kill-emacs)) - -;; Avoid error if user loads some more libraries now. -(setq purify-flag nil) - -;; XEmacs change -;; If you are using 'recompile', then you should have used -l loadup-el.el -;; 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))) - -;; For machines with CANNOT_DUMP defined in config.h, -;; this file must be loaded each time Emacs is run. -;; So run the startup code now. - -(when (not (fboundp 'dump-emacs)) - ;; Avoid loading loadup.el a second time! - (setq command-line-args (cdr (cdr command-line-args))) - (eval top-level)) - -;;; loadup.el ends here
--- a/lisp/prim/make-docfile.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,195 +0,0 @@ -;;; make-docfile.el --- Cache docstrings in external file - -;; Copyright (C) 1985, 1986, 1992-1995, 1997 Free Software Foundation, Inc. - -;; Author: Unknown -;; Maintainer: Steven L Baur <steve@altair.xemacs.org> -;; Keywords: internal - -;; 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: - -;; This is a front-end to the make-docfile program that gathers up all the -;; lisp files that will be dumped with XEmacs. It would probably be best -;; to just move make-docfile.c completely to lisp and be done with it. - -;;; Code: - -(defvar options nil) -(defvar processed nil) -(defvar docfile nil) -(defvar docfile-buffer nil) -(defvar site-file-list nil) -(defvar docfile-out-of-date nil) - -;; Gobble up the stuff we don't wish to pass on. -(setq command-line-args (cdr (cdr (cdr (cdr command-line-args))))) - -;; First gather up the command line options. -(let (done) - (while (and (null done) command-line-args) - (let ((arg (car command-line-args))) - (cond ((or (string-equal arg "-o") ; Specify DOC file name - (string-equal arg "-a") ; Append to DOC file - (string-equal arg "-d")) ; Set working directory - (if (string-equal arg "-o") - (setq docfile (car (cdr command-line-args)))) - (setq options (cons arg options)) - (setq options (cons (car (cdr command-line-args)) options))) - ((string-equal arg "-i") ; Set site files to scan - (setq site-file-list (car (cdr command-line-args)))) - (t (setq done t))) - (if (null done) - (setq command-line-args (cdr (cdr command-line-args))))))) -(setq options (nreverse options)) - -;; (print (concat "Options: " (prin1-to-string options))) - -;; Next process the list of C files. -(while command-line-args - (let ((arg (car command-line-args))) - (if (null (member arg processed)) - (progn - (if (and (null docfile-out-of-date) - (file-newer-than-file-p arg docfile)) - (setq docfile-out-of-date t)) - (setq processed (cons arg processed))))) - (setq command-line-args (cdr command-line-args))) - -;; Then process the list of Lisp files. -(define-function 'defalias 'define-function) -(let ((temp-path (expand-file-name ".." (car load-path)))) - (setq load-path (nconc (mapcar - #'(lambda (i) (concat i "/")) - (directory-files temp-path t "^[^-.]" - nil 'dirs-only)) - (cons temp-path load-path)))) - -;; Then process the autoloads -(setq autoload-file-name "auto-autoloads.elc") -(setq source-directory (concat default-directory "../lisp")) -;; (print (concat "Source directory: " source-directory)) -(require 'packages) - -;; We must have some lisp support at this point - -;(load "backquote") -;(load "bytecomp-runtime") -;(load "subr") -;(load "replace") -;(load "version.el") -;(load "cl") - -;; (load "featurep") - -(let (preloaded-file-list) - (load (concat default-directory "../lisp/prim/dumped-lisp.el")) - (setq preloaded-file-list - (append preloaded-file-list packages-hardcoded-lisp)) - (while preloaded-file-list - (let ((arg0 (packages-add-suffix (car preloaded-file-list))) - arg) - (setq arg (locate-library arg0)) - (if (null arg) - (princ (format "Error: dumped file %s does not exist\n" arg)) - (if (null (member arg processed)) - (progn - (if (and (null docfile-out-of-date) - (file-newer-than-file-p arg docfile)) - (setq docfile-out-of-date t)) - (setq processed (cons arg processed))))) - (setq preloaded-file-list (cdr preloaded-file-list))))) - -;; Finally process the list of site-loaded files. -(if site-file-list - (let (site-load-packages) - (load site-file-list t t) - (while site-load-packages - (let ((arg (car site-load-packages))) - (if (null (member arg processed)) - (progn - (if (and (null docfile-out-of-date) - (file-newer-than-file-p arg docfile)) - (setq docfile-out-of-date t)) - (setq processed (cons arg processed))))) - (setq site-load-packages (cdr site-load-packages))))) - -(packages-find-packages package-path t) - -(let ((autoloads (list-autoloads-path))) - ;; (print (concat "Autoloads: " (prin1-to-string autoloads))) - (while autoloads - (let ((arg (car autoloads))) - (if (null (member arg processed)) - (progn - ;; (print arg) - (if (and (null docfile-out-of-date) - (file-newer-than-file-p arg docfile)) - (setq docfile-out-of-date t)) - (setq processed (cons arg processed)))) - (setq autoloads (cdr autoloads))))) - -;; Now fire up make-docfile and we're done - -(setq processed (nreverse processed)) - -;; (print (prin1-to-string (append options processed))) - -(if docfile-out-of-date - (progn - (princ "Spawning make-docfile ...") - ;; (print (prin1-to-string (append options processed))) - - (setq exec-path (list (concat default-directory "../lib-src"))) - - ;; (locate-file-clear-hashing nil) - (if (memq system-type '(berkeley-unix next-mach)) - ;; Suboptimal, but we have a unresolved bug somewhere in the - ;; low-level process code - (call-process-internal - "/bin/csh" - nil - t - nil - "-fc" - (mapconcat - 'identity - (append - (list (concat default-directory "../lib-src/make-docfile")) - options processed) - " ")) - ;; (print (prin1-to-string (append options processed))) - (apply 'call-process-internal - ;; (concat default-directory "../lib-src/make-docfile") - "make-docfile" - nil - t - nil - (append options processed))) - - (princ "Spawning make-docfile ...done\n") - ;; (write-region-internal (point-min) (point-max) "/tmp/DOC") - ) - (princ "DOC file is up to date\n")) - -(kill-emacs) - -;;; make-docfile.el ends here
--- a/lisp/prim/menubar.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,513 +0,0 @@ -;; Menubar support. -;; Copyright (C) 1991, 1992, 1993, 1994 Free Software Foundation, Inc. -;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp. -;; Copyright (C) 1995, 1996 Ben Wing. - -;; 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, 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: Not in FSF. (Completely divergent from FSF menu-bar.el) -;;; Some stuff in FSF menu-bar.el is in x-menubar.el - -(defvar default-menubar nil) - -;; this function is considered "part of the lexicon" by many, -;; so we'll leave it here. -(defun kill-this-buffer () ; for the menubar - "Kill the current buffer." - (interactive) - (kill-buffer (current-buffer))) - -(defun set-menubar-dirty-flag () - "Tell XEmacs that the menubar has to be updated. -NOTE: XEmacs now recognizes when you set a different value for -`current-menubar'. You *only* need to call this function if you -destructively modify a part of the menubar and don't set `current-menubar'. -Note that all the functions that modify a menu call this automatically." - (setq-default current-menubar (default-value 'current-menubar))) - -;; #### shouldn't this perhaps be `copy-tree'? -(defun set-menubar (menubar) - "Set the default menubar to be MENUBAR. -See `current-menubar' for a description of the syntax of a menubar." - (check-menu-syntax menubar t) - (setq-default current-menubar (copy-sequence menubar))) - -(defun set-buffer-menubar (menubar) - "Set the buffer-local menubar to be MENUBAR. -See `current-menubar' for a description of the syntax of a menubar." - (check-menu-syntax menubar t) - (make-local-variable 'current-menubar) - (setq current-menubar (copy-sequence menubar))) - -(defun check-menu-syntax (menu &optional menubar-p) - ;; The C code does syntax checking on the value of `current-menubar', - ;; but it's better to do it early, before things have gotten messed up. - (if menubar-p - nil - (or (stringp (car menu)) - (signal 'error - (list "menu name (first element) must be a string" menu))) - ;;(or (cdr menu) (signal 'error (list "menu is empty" menu))) - (setq menu (cdr menu))) - (let (menuitem item) - (while (keywordp (setq item (car menu))) - (or (memq item '(:config :included :filter :accelerator)) - (signal 'error - (list "menu keyword must be :config, :included, :accelerator or :filter" - item))) - (if (or (not (cdr menu)) - (vectorp (nth 1 menu)) - (keywordp (nth 1 menu))) - (signal 'error (list "strange keyword value" item (nth 1 menu)))) - (setq menu (nthcdr 2 menu))) - (while menu - (setq menuitem (car menu)) - (cond - ((stringp menuitem) - (and (string-match "^\\(-+\\|=+\\):\\(.*\\)" menuitem) - (setq item (match-string 2 menuitem)) - (or (member item '(;; Motif-compatible - "singleLine" - "doubleLine" - "singleDashedLine" - "doubleDashedLine" - "noLine" - "shadowEtchedIn" - "shadowEtchedOut" - "shadowEtchedInDash" - "shadowEtchedOutDash" - ;; non-Motif (Lucid menubar widget only) - "shadowDoubleEtchedIn" - "shadowDoubleEtchedOut" - "shadowDoubleEtchedInDash" - "shadowDoubleEtchedOutDash" - )) - (signal 'error (list "bogus separator style in menu item" item))) - )) - ((null menuitem) - (or menubar-p - (signal 'error (list "nil is only permitted in the top level of menubars")))) - ((consp menuitem) - (check-menu-syntax menuitem)) - ((vectorp menuitem) - (let ((L (length menuitem)) - plistp) - (and (< L 3) - (signal 'error - (list "button descriptors must be at least 3 long" - menuitem))) - (setq plistp (or (>= L 5) (keywordp (aref menuitem 2)))) - (or (stringp (aref menuitem 0)) - (signal 'error - (list - "first element of a button must be a string (the label)" - menuitem))) - (or plistp - (< L 4) - (null (aref menuitem 3)) - (stringp (aref menuitem 3)) - (signal 'error - (list - "fourth element of a button must be a string (the label suffix)" - menuitem))) - (if plistp - (let ((i 2) - selp - style - item) - (while (< i L) - (setq item (aref menuitem i)) - (cond ((not (memq item '(:active :suffix :keys :style - :full :included :selected - :accelerator))) - (signal 'error - (list (if (keywordp item) - "unknown menu item keyword" - "not a keyword") - item menuitem))) - ((eq item :style) - (setq style (aref menuitem (1+ i))) - (or (memq style '(nil toggle radio button text)) - (signal 'error (list "unknown style" style - menuitem)))) - ((eq item :selected) (setq selp t)) - ) - (setq i (+ i (if (eq item :full) 1 2)))) - (if (and selp (not (memq style '(toggle button radio)))) - (signal 'error - (list - ":selected only makes sense with :style toggle, radio, or button" - menuitem))) - ))) - ) - (t (signal 'error (list "unrecognised menu descriptor" menuitem)))) - (setq menu (cdr menu))))) - - -;;; menu manipulation functions - -(defun find-menu-item (menubar item-path-list &optional parent) - "Search MENUBAR for item given by ITEM-PATH-LIST starting from PARENT. -Returns (ITEM . PARENT), where PARENT is the immediate parent of - the item found. -If the item does not exist, the car of the returned value is nil. -If some menu in the ITEM-PATH-LIST does not exist, an error is signalled." - (or (listp item-path-list) - (signal 'wrong-type-argument (list 'listp item-path-list))) - (or parent (setq item-path-list (mapcar 'normalize-menu-item-name item-path-list))) - (if (not (consp menubar)) - nil - (let ((rest menubar) - result) - (if (stringp (car rest)) - (setq rest (cdr rest))) - (while (keywordp (car rest)) - (setq rest (cddr rest))) - (while rest - (if (and (car rest) - (equal (car item-path-list) - (normalize-menu-item-name (if (vectorp (car rest)) - (aref (car rest) 0) - (if (stringp (car rest)) - (car rest) - (car (car rest))))))) - (setq result (car rest) rest nil) - (setq rest (cdr rest)))) - (if (cdr item-path-list) - (if (consp result) - (find-menu-item (cdr result) (cdr item-path-list) result) - (if result - (signal 'error (list (gettext "not a submenu") result)) - (signal 'error (list (gettext "no such submenu") (car item-path-list))))) - (cons result parent))))) - -(defun add-menu-item-1 (leaf-p menu-path new-item before) - ;; This code looks like it could be cleaned up some more - ;; Do we really need 6 calls to find-menu-item? - (when before (setq before (normalize-menu-item-name before))) - (let* ((item-name - (cond ((vectorp new-item) (aref new-item 0)) - ((consp new-item) (car new-item)) - (t nil))) - (menubar current-menubar) - (menu (condition-case () - (car (find-menu-item menubar menu-path)) - (error nil))) - (item-found (cond - ((null item-name) - nil) - ((not (listp menu)) - (signal 'error (list (gettext "not a submenu") - menu-path))) - (menu - (find-menu-item (cdr menu) (list item-name))) - (t - (find-menu-item menubar (list item-name))) - ))) - (unless menubar - (error "`current-menubar' is nil: can't add menus to it.")) - (unless menu - (let ((rest menu-path) - (so-far menubar)) - (while rest -;;; (setq menu (car (find-menu-item (cdr so-far) (list (car rest))))) - (setq menu - (if (eq so-far menubar) - (car (find-menu-item so-far (list (car rest)))) - (car (find-menu-item (cdr so-far) (list (car rest)))))) - (unless menu - (let ((rest2 so-far)) - (while (and (cdr rest2) (car (cdr rest2))) - (setq rest2 (cdr rest2))) - (setcdr rest2 - (nconc (list (setq menu (list (car rest)))) - (cdr rest2))))) - (setq so-far menu) - (setq rest (cdr rest))))) - (if (and item-found (car item-found)) - ;; hack the item in place. - (if menu - ;; Isn't it very bad form to use nsubstitute for side effects? - (nsubstitute new-item (car item-found) menu) - (setq current-menubar (nsubstitute new-item - (car item-found) - current-menubar))) - ;; OK, we have to add the whole thing... - ;; if BEFORE is specified, try to add it there. - (unless menu (setq menu current-menubar)) - (when before - (setq before (car (find-menu-item menu (list before))))) - (let ((rest menu) - (added-before nil)) - (while rest - (if (eq before (car (cdr rest))) - (progn - (setcdr rest (cons new-item (cdr rest))) - (setq rest nil added-before t)) - (setq rest (cdr rest)))) - (when (not added-before) - ;; adding before the first item on the menubar itself is harder - (if (and (eq menu menubar) (eq before (car menu))) - (setq menu (cons new-item menu) - current-menubar menu) - ;; otherwise, add the item to the end. - (nconc menu (list new-item)))))) - (set-menubar-dirty-flag) - new-item)) - -(defun add-menu-button (menu-path menu-leaf &optional before) - "Add a menu item to some menu, creating the menu first if necessary. -If the named item exists already, it is changed. -MENU-PATH identifies the menu under which the new menu item should be inserted. - It is a list of strings; for example, (\"File\") names the top-level \"File\" - menu. (\"File\" \"Foo\") names a hypothetical submenu of \"File\". -MENU-LEAF is a menubar leaf node. See the documentation of `current-menubar'. -BEFORE, if provided, is the name of a menu item before which this item should - be added, if this item is not on the menu already. If the item is already - present, it will not be moved." - (add-menu-item-1 t menu-path menu-leaf before)) - -;; I actually liked the old name better, but the interface has changed too -;; drastically to keep it. --Stig -(defun add-submenu (menu-path submenu &optional before) - "Add a menu to the menubar or one of its submenus. -If the named menu exists already, it is changed. -MENU-PATH identifies the menu under which the new menu should be inserted. - It is a list of strings; for example, (\"File\") names the top-level \"File\" - menu. (\"File\" \"Foo\") names a hypothetical submenu of \"File\". - If MENU-PATH is nil, then the menu will be added to the menubar itself. -SUBMENU is the new menu to add. - See the documentation of `current-menubar' for the syntax. -BEFORE, if provided, is the name of a menu before which this menu should - be added, if this menu is not on its parent already. If the menu is already - present, it will not be moved." - (check-menu-syntax submenu nil) - (add-menu-item-1 nil menu-path submenu before)) - -(defun purecopy-menubar (x) - ;; this calls purecopy on the strings, and the contents of the vectors, - ;; but not on the vectors themselves, or the conses - those must be - ;; writable. - (cond ((vectorp x) - (let ((i (length x))) - (while (> i 0) - (aset x (1- i) (purecopy (aref x (1- i)))) - (setq i (1- i)))) - x) - ((consp x) - (let ((rest x)) - (while rest - (setcar rest (purecopy-menubar (car rest))) - (setq rest (cdr rest)))) - x) - (t - (purecopy x)))) - -(defun delete-menu-item (path) - "Remove the named menu item from the menu hierarchy. -PATH is a list of strings which identify the position of the menu item in -the menu hierarchy. The documentation of `add-submenu' describes menu-paths." - (let* ((pair (condition-case nil (find-menu-item current-menubar path) - (error nil))) - (item (car pair)) - (parent (or (cdr pair) current-menubar))) - (if (not item) - nil - ;; the menubar is the only special case, because other menus begin - ;; with their name. - (if (eq parent current-menubar) - (setq current-menubar (delq item parent)) - (delq item parent)) - (set-menubar-dirty-flag) - item))) - -(defun relabel-menu-item (path new-name) - "Change the string of the specified menu item. -PATH is a list of strings which identify the position of the menu item in -the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" -under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the -menu item called \"Item\" under the \"Foo\" submenu of \"Menu\". -NEW-NAME is the string that the menu item will be printed as from now on." - (or (stringp new-name) - (setq new-name (signal 'wrong-type-argument (list 'stringp new-name)))) - (let* ((menubar current-menubar) - (pair (find-menu-item menubar path)) - (item (car pair)) - (menu (cdr pair))) - (or item - (signal 'error (list (if menu (gettext "No such menu item") - (gettext "No such menu")) - path))) - (if (and (consp item) - (stringp (car item))) - (setcar item new-name) - (aset item 0 new-name)) - (set-menubar-dirty-flag) - item)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; these are all bad style. Why in the world would we put evaluable forms -;; into the menubar if we didn't want people to use 'em? -;; x-font-menu.el is the only known offender right now and that ought to be -;; rehashed a bit. -;; - -(defun enable-menu-item-1 (path toggle-p on-p) - (let (menu item) - (if (and (vectorp path) (> (length path) 2)) ; limited syntax checking... - (setq item path) - (let* ((menubar current-menubar) - (pair (find-menu-item menubar path))) - (setq item (car pair) - menu (cdr pair)) - (or item - (signal 'error (list (if menu - "No such menu item" - "No such menu") - path))) - (if (consp item) - (error "%S is a menu, not a menu item" path)))) - (if (or (> (length item) 4) - (and (symbolp (aref item 2)) - (= ?: (aref (symbol-name (aref item 2)) 0)))) - ;; plist-like syntax - (let ((i 2) - (keyword (if toggle-p :selected :active)) - (ok nil)) - (while (< i (length item)) - (cond ((eq (aref item i) keyword) - (aset item (1+ i) on-p) - (setq ok t))) - (setq i (+ i 2))) - (cond (ok nil) - (toggle-p - (signal 'error (list "not a toggle menu item" item))) - (t - ;; Need to copy the item to extend it, sigh... - (let ((cons (memq item menu)) - (new-item (vconcat item (list keyword on-p)))) - (if cons - (setcar cons (setq item new-item)) - (if menu - (error "couldn't find %S on its parent?" item) - (error "no %S slot to set: %S" keyword item))))))) - ;; positional syntax - (if toggle-p - (signal 'error (list "not a toggle menu item" item)) - (aset item 2 on-p))) - (set-menubar-dirty-flag) - item)) - -(defun enable-menu-item (path) - "Make the named menu item be selectable. -PATH is a list of strings which identify the position of the menu item in -the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" -under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the -menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"." - (enable-menu-item-1 path nil t)) - -(defun disable-menu-item (path) - "Make the named menu item be unselectable. -PATH is a list of strings which identify the position of the menu item in -the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" -under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the -menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"." - (enable-menu-item-1 path nil nil)) - -(defun select-toggle-menu-item (path) - "Make the named toggle- or radio-style menu item be in the `selected' state. -PATH is a list of strings which identify the position of the menu item in -the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" -under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the -menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"." - (enable-menu-item-1 path t t)) - -(defun deselect-toggle-menu-item (path) - "Make the named toggle- or radio-style menu item be in the `unselected' state. -PATH is a list of strings which identify the position of the menu item in -the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" -under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the -menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"." - (enable-menu-item-1 path t nil)) - - -(defun get-popup-menu-response (menu-desc &optional event) - "Pop up the given menu and wait for a response. -This blocks until the response is received, and returns the misc-user -event that encapsulates the response. To execute it, you can do - (funcall (event-function response) (event-object response)) -If no response was received, nil is returned. - -MENU-DESC and EVENT are as in the call to `popup-menu'." - ;; partially stolen from w3 - (let ((echo-keystrokes 0) - new-event) - (popup-menu menu-desc event) - (catch 'popup-done - (while t - (setq new-event (next-command-event new-event)) - (cond ((misc-user-event-p new-event) - (throw 'popup-done new-event)) - ((not (popup-up-p)) - (setq unread-command-events (cons new-event - unread-command-events)) - (throw 'popup-done nil)) - ((button-release-event-p new-event);; don't beep twice - nil) - ((event-matches-key-specifier-p (quit-char)) - (signal 'quit nil)) - (t - (beep) - (message "please make a choice from the menu."))))))) - -(defun popup-menu-and-execute-in-window (menu-desc event) - "Pop up the given menu and execute its response in EVENT's window. -This blocks until the response is received, temporarily selects -EVENT's window, and executes the command specified in the response. -EVENT can also be a window. See `popup-menu' for the semantics of -MENU-DESC." - (let ((response - (get-popup-menu-response menu-desc - (and (eventp event) event)))) - (and (misc-user-event-p response) - (save-selected-window - (select-window (if (windowp event) event - (event-window event))) - (funcall (event-function response) - (event-object response)))))) - -;; provide default bindings for menu accelerator map -(and (boundp 'menu-accelerator-map) - (keymapp menu-accelerator-map) - (progn - (define-key menu-accelerator-map "\e" 'menu-escape) - (define-key menu-accelerator-map [left] 'menu-left) - (define-key menu-accelerator-map [right] 'menu-right) - (define-key menu-accelerator-map [up] 'menu-up) - (define-key menu-accelerator-map [down] 'menu-down) - (define-key menu-accelerator-map [return] 'menu-select) - (define-key menu-accelerator-map [kp_down] 'menu-down) - (define-key menu-accelerator-map [kp_up] 'menu-down) - (define-key menu-accelerator-map [kp_left] 'menu-left) - (define-key menu-accelerator-map [kp_right] 'menu-right) - (define-key menu-accelerator-map [kp_enter] 'menu-select) - (define-key menu-accelerator-map "\C-g" 'menu-quit))) - - -(provide 'menubar)
--- a/lisp/prim/minibuf.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2104 +0,0 @@ -;;; minibuf.el --- Minibuffer functions for XEmacs - -;; Copyright (C) 1992, 1993, 1994, 1997 Free Software Foundation, Inc. -;; Copyright (C) 1995 Tinker Systems -;; Copyright (C) 1995, 1996 Ben Wing - -;; Author: Richard Mlynarik -;; Created: 2-Oct-92 -;; Maintainer: XEmacs Development Team -;; Keywords: internal - -;; 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, 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: all the minibuffer history stuff is synched with -;;; 19.30. Not sure about the rest. - -;;; Commentary: - -;; Written by Richard Mlynarik 2-Oct-92 - -;; 06/11/1997 - Use char-(after|before) instead of -;; (following|preceding)-char. -slb - -;;; Code: - -(defgroup minibuffer nil - "Minibuffer customizations" - :group 'environment) - - -(defcustom insert-default-directory t - "*Non-nil means when reading a filename start with default dir in minibuffer." - :type 'boolean - :group 'minibuffer) - -(defcustom minibuffer-history-uniquify t - "*Non-nil means when adding an item to a minibuffer history, remove -previous occurances of the same item from the history list first, -rather than just consing the new element onto the front of the list." - :type 'boolean - :group 'minibuffer) - -(defvar minibuffer-completion-table nil - "Alist or obarray used for completion in the minibuffer. -This becomes the ALIST argument to `try-completion' and `all-completions'. - -The value may alternatively be a function, which is given three arguments: - STRING, the current buffer contents; - PREDICATE, the predicate for filtering possible matches; - CODE, which says what kind of things to do. -CODE can be nil, t or `lambda'. -nil means to return the best completion of STRING, nil if there is none, - or t if it is was already a unique completion. -t means to return a list of all possible completions of STRING. -`lambda' means to return t if STRING is a valid completion as it stands.") - -(defvar minibuffer-completion-predicate nil - "Within call to `completing-read', this holds the PREDICATE argument.") - -(defvar minibuffer-completion-confirm nil - "Non-nil => demand confirmation of completion before exiting minibuffer.") - -(defvar minibuffer-confirm-incomplete nil - "If true, then in contexts where completing-read allows answers which -are not valid completions, an extra RET must be typed to confirm the -response. This is helpful for catching typos, etc.") - -(defcustom completion-auto-help t - "*Non-nil means automatically provide help for invalid completion input." - :type 'boolean - :group 'minibuffer) - -(defcustom enable-recursive-minibuffers nil - "*Non-nil means to allow minibuffer commands while in the minibuffer. -More precisely, this variable makes a difference when the minibuffer window -is the selected window. If you are in some other window, minibuffer commands -are allowed even if a minibuffer is active." - :type 'boolean - :group 'minibuffer) - -(defcustom minibuffer-max-depth 1 - ;; See comment in #'minibuffer-max-depth-exceeded - "*Global maximum number of minibuffers allowed; -compare to enable-recursive-minibuffers, which is only consulted when the -minibuffer is reinvoked while it is the selected window." - :type '(choice integer - (const :tag "Indefinite" nil)) - :group 'minibuffer) - -;; Moved to C. The minibuffer prompt must be setup before this is run -;; and that can only be done from the C side. -;(defvar minibuffer-setup-hook nil -; "Normal hook run just after entry to minibuffer.") - -(defvar minibuffer-exit-hook nil - "Normal hook run just after exit from minibuffer.") - -(defvar minibuffer-help-form nil - "Value that `help-form' takes on inside the minibuffer.") - -(defvar minibuffer-local-map - (let ((map (make-sparse-keymap 'minibuffer-local-map))) - map) - "Default keymap to use when reading from the minibuffer.") - -(defvar minibuffer-local-completion-map - (let ((map (make-sparse-keymap 'minibuffer-local-completion-map))) - (set-keymap-parents map (list minibuffer-local-map)) - map) - "Local keymap for minibuffer input with completion.") - -(defvar minibuffer-local-must-match-map - (let ((map (make-sparse-keymap 'minibuffer-must-match-map))) - (set-keymap-parents map (list minibuffer-local-completion-map)) - map) - "Local keymap for minibuffer input with completion, for exact match.") - -;; (define-key minibuffer-local-map "\C-g" 'abort-recursive-edit) -(define-key minibuffer-local-map "\C-g" 'minibuffer-keyboard-quit) ;; moved here from pending-del.el -(define-key minibuffer-local-map "\r" 'exit-minibuffer) -(define-key minibuffer-local-map "\n" 'exit-minibuffer) - -;; Historical crock. Unused by anything but user code, if even that -;(defvar minibuffer-local-ns-map -; (let ((map (make-sparse-keymap 'minibuffer-local-ns-map))) -; (set-keymap-parents map (list minibuffer-local-map)) -; map) -; "Local keymap for the minibuffer when spaces are not allowed.") -;(define-key minibuffer-local-ns-map [space] 'exit-minibuffer) -;(define-key minibuffer-local-ns-map [tab] 'exit-minibuffer) -;(define-key minibuffer-local-ns-map [?\?] 'self-insert-and-exit) - -(define-key minibuffer-local-completion-map "\t" 'minibuffer-complete) -(define-key minibuffer-local-completion-map " " 'minibuffer-complete-word) -(define-key minibuffer-local-completion-map "?" 'minibuffer-completion-help) -(define-key minibuffer-local-must-match-map "\r" 'minibuffer-complete-and-exit) -(define-key minibuffer-local-must-match-map "\n" 'minibuffer-complete-and-exit) - -(define-key minibuffer-local-map "\M-n" 'next-history-element) -(define-key minibuffer-local-map "\M-p" 'previous-history-element) -(define-key minibuffer-local-map '[next] "\M-n") -(define-key minibuffer-local-map '[prior] "\M-p") -(define-key minibuffer-local-map "\M-r" 'previous-matching-history-element) -(define-key minibuffer-local-map "\M-s" 'next-matching-history-element) -(define-key minibuffer-local-must-match-map [next] - 'next-complete-history-element) -(define-key minibuffer-local-must-match-map [prior] - 'previous-complete-history-element) - -;; This is an experiment--make up and down arrows do history. -(define-key minibuffer-local-map [up] 'previous-history-element) -(define-key minibuffer-local-map [down] 'next-history-element) -(define-key minibuffer-local-completion-map [up] 'previous-history-element) -(define-key minibuffer-local-completion-map [down] 'next-history-element) -(define-key minibuffer-local-must-match-map [up] 'previous-history-element) -(define-key minibuffer-local-must-match-map [down] 'next-history-element) - -(defvar read-expression-map (let ((map (make-sparse-keymap - 'read-expression-map))) - (set-keymap-parents map - (list minibuffer-local-map)) - (define-key map "\M-\t" 'lisp-complete-symbol) - map) - "Minibuffer keymap used for reading Lisp expressions.") - -(defvar read-shell-command-map - (let ((map (make-sparse-keymap 'read-shell-command-map))) - (set-keymap-parents map (list minibuffer-local-map)) - (define-key map "\t" 'comint-dynamic-complete) - (define-key map "\M-\t" 'comint-dynamic-complete) - (define-key map "\M-?" 'comint-dynamic-list-completions) - map) - "Minibuffer keymap used by shell-command and related commands.") - -(defcustom use-dialog-box t - "*Variable controlling usage of the dialog box. -If nil, the dialog box will never be used, even in response to mouse events." - :type 'boolean - :group 'minibuffer) - -(defcustom minibuffer-electric-file-name-behavior t - "*If non-nil, slash and tilde in certain places cause immediate deletion. -These are the same places where this behavior would occur later on anyway, -in `substitute-in-file-name'." - :type 'boolean - :group 'minibuffer) - -(defun minibuffer-electric-slash () - ;; by Stig@hackvan.com - (interactive) - (and minibuffer-electric-file-name-behavior - (eq ?/ (char-before (point))) - (not (save-excursion - (goto-char (point-min)) - (and (looking-at "^/.+:~?") - (re-search-forward "^/.+:~?[^/]*" nil t) - (progn - (delete-region (point) (point-max)) - t)))) - (not (eq (point) (1+ (point-min)))) ; permit `//hostname/path/to/file' - (not (eq ?: (char-after (- (point) 2)))) ; permit `http://url/goes/here' - (delete-region (point-min) (point))) - (insert ?/)) - -(defun minibuffer-electric-tilde () - (interactive) - (and minibuffer-electric-file-name-behavior - (eq ?/ (char-before (point))) - ;; permit URL's with //, for e.g. http://hostname/~user - (not (save-excursion (search-backward "//" nil t))) - (delete-region (point-min) (point))) - (insert ?~)) - -(defvar read-file-name-map - (let ((map (make-sparse-keymap 'read-file-name-map))) - (set-keymap-parents map (list minibuffer-local-completion-map)) - (define-key map "/" 'minibuffer-electric-slash) - (define-key map "~" 'minibuffer-electric-tilde) - map - )) - -(defvar read-file-name-must-match-map - (let ((map (make-sparse-keymap 'read-file-name-map))) - (set-keymap-parents map (list minibuffer-local-must-match-map)) - (define-key map "/" 'minibuffer-electric-slash) - (define-key map "~" 'minibuffer-electric-tilde) - map - )) - -(defun minibuffer-keyboard-quit () - "Abort recursive edit. -If `zmacs-regions' is true, and the zmacs region is active in this buffer, -then this key deactivates the region without beeping." - (interactive) - (if (and (region-active-p) - (eq (current-buffer) (zmacs-region-buffer))) - ;; pseudo-zmacs compatibility: don't beep if this ^G is simply - ;; deactivating the region. If it is inactive, beep. - nil - (abort-recursive-edit))) - -;;;; Guts of minibuffer invocation - -;;#### The only things remaining in C are -;; "Vminibuf_prompt" and the display junk -;; "minibuf_prompt_width" and "minibuf_prompt_pix_width" -;; Also "active_frame", though I suspect I could already -;; hack that in Lisp if I could make any sense of the -;; complete mess of frame/frame code in XEmacs. -;; Vminibuf_prompt could easily be made Lisp-bindable. -;; I suspect that minibuf_prompt*_width are actually recomputed -;; by redisplay as needed -- or could be arranged to be so -- -;; and that there could be need for read-minibuffer-internal to -;; save and restore them. -;;#### The only other thing which read-from-minibuffer-internal does -;; which we can't presently do in Lisp is move the frame cursor -;; to the start of the minibuffer line as it returns. This is -;; a rather nice touch and should be preserved -- probably by -;; providing some Lisp-level mechanism (extension to cursor-in-echo-area ?) -;; to effect it. - - -;; Like reset_buffer in FSF's buffer.c -;; (Except that kill-all-local-variables doesn't nuke 'permanent-local -;; variables -- we preserve them, reset_buffer doesn't.) -(defun reset-buffer (buffer) - (save-excursion - (set-buffer buffer) - ;(if (fboundp 'unlock-buffer) (unlock-buffer)) - (kill-all-local-variables) - (setq buffer-read-only nil) - (erase-buffer) - ;(setq default-directory nil) - (setq buffer-file-name nil) - (setq buffer-file-truename nil) - (set-buffer-modified-p nil) - (setq buffer-backed-up nil) - (setq buffer-auto-save-file-name nil) - (set-buffer-dedicated-frame buffer nil) - buffer)) - -(defvar minibuffer-history-variable 'minibuffer-history - "History list symbol to add minibuffer values to. -Each minibuffer output is added with - (set minibuffer-history-variable - (cons STRING (symbol-value minibuffer-history-variable)))") -(defvar minibuffer-history-position) - -;; Added by hniksic: -(defvar initial-minibuffer-history-position) -(defvar current-minibuffer-contents) -(defvar current-minibuffer-point) - -(defcustom minibuffer-history-minimum-string-length 3 - "*If this variable is non-nil, a string will not be added to the -minibuffer history if its length is less than that value." - :type '(choice (const :tag "Any" nil) - integer) - :group 'minibuffer) - -(define-error 'input-error "Keyboard input error") - -(put 'input-error 'display-error - #'(lambda (error-object stream) - (princ (cadr error-object) stream))) - -(defun read-from-minibuffer (prompt &optional initial-contents - keymap - readp - history - abbrev-table) - "Read a string from the minibuffer, prompting with string PROMPT. -If optional second arg INITIAL-CONTENTS is non-nil, it is a string - to be inserted into the minibuffer before reading input. - If INITIAL-CONTENTS is (STRING . POSITION), the initial input - is STRING, but point is placed POSITION characters into the string. -Third arg KEYMAP is a keymap to use whilst reading; - 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: - in other words, do `(car (read-from-string INPUT-STRING))' -Fifth arg HISTORY, if non-nil, specifies a history list - and optionally the initial position in the list. - It can be a symbol, which is the history list variable to use, - or it can be a cons cell (HISTVAR . HISTPOS). - In that case, HISTVAR is the history list variable to use, - and HISTPOS is the initial position (the position in the list - which INITIAL-CONTENTS corresponds to). - If HISTORY is `t', no history will be recorded. - Positions are counted starting from 1 at the beginning of the list. -Sixth arg ABBREV-TABLE, if non-nil, becomes the value of `local-abbrev-table' - in the minibuffer. - -See also the variable completion-highlight-first-word-only for control over - completion display." - (if (and (not enable-recursive-minibuffers) - (> (minibuffer-depth) 0) - (eq (selected-window) (minibuffer-window))) - (error "Command attempted to use minibuffer while in minibuffer")) - - (if (and minibuffer-max-depth - (> minibuffer-max-depth 0) - (>= (minibuffer-depth) minibuffer-max-depth)) - (minibuffer-max-depth-exceeded)) - - ;; catch this error before the poor user has typed something... - (if history - (if (symbolp history) - (or (boundp history) - (error "History list %S is unbound" history)) - (or (boundp (car history)) - (error "History list %S is unbound" (car history))))) - - (if (noninteractive) - (progn - ;; XEmacs in -batch mode calls minibuffer: print the prompt. - (message "%s" (gettext prompt)) - ;;#### force-output - - ;;#### Should this even be falling though to the code below? - ;;#### How does this stuff work now, anyway? - )) - (let* ((dir default-directory) - (owindow (selected-window)) - (oframe (selected-frame)) - (window (minibuffer-window)) - (buffer (if (eq (minibuffer-depth) 0) - (window-buffer window) - (get-buffer-create (format " *Minibuf-%d" - (minibuffer-depth))))) - (frame (window-frame window)) - (mconfig (if (eq frame (selected-frame)) - nil (current-window-configuration frame))) - (oconfig (current-window-configuration)) - ;; dynamic scope sucks sucks sucks sucks sucks sucks. - ;; `M-x doctor' makes history a local variable, and thus - ;; our binding above is buffer-local and doesn't apply - ;; once we switch buffers!!!! We demand better scope! - (_history_ history)) - (unwind-protect - (progn - (set-buffer (reset-buffer buffer)) - (setq default-directory dir) - (make-local-variable 'print-escape-newlines) - (setq print-escape-newlines t) - (make-local-variable 'current-minibuffer-contents) - (make-local-variable 'current-minibuffer-point) - (make-local-variable 'initial-minibuffer-history-position) - (setq current-minibuffer-contents "" - current-minibuffer-point 1) - (if (not minibuffer-smart-completion-tracking-behavior) - nil - (make-local-variable 'mode-motion-hook) - (or mode-motion-hook - ;;####disgusting - (setq mode-motion-hook 'minibuffer-smart-mouse-tracker)) - (make-local-variable 'mouse-track-click-hook) - (add-hook 'mouse-track-click-hook - 'minibuffer-smart-maybe-select-highlighted-completion)) - (set-window-buffer window buffer) - (select-window window) - (set-window-hscroll window 0) - (buffer-enable-undo buffer) - (message nil) - (if initial-contents - (if (consp initial-contents) - (progn - (insert (car initial-contents)) - (goto-char (1+ (cdr initial-contents))) - (setq current-minibuffer-contents (car initial-contents) - current-minibuffer-point (cdr initial-contents))) - (insert initial-contents) - (setq current-minibuffer-contents initial-contents - current-minibuffer-point (point)))) - (use-local-map (or keymap minibuffer-local-map)) - (let ((mouse-grabbed-buffer - (and minibuffer-smart-completion-tracking-behavior - (current-buffer))) - (current-prefix-arg current-prefix-arg) - (help-form minibuffer-help-form) - (minibuffer-history-variable (cond ((not _history_) - 'minibuffer-history) - ((consp _history_) - (car _history_)) - (t - _history_))) - (minibuffer-history-position (cond ((consp _history_) - (cdr _history_)) - (t - 0))) - (minibuffer-scroll-window owindow)) - (setq initial-minibuffer-history-position - minibuffer-history-position) - (if abbrev-table - (setq local-abbrev-table abbrev-table - abbrev-mode t)) - ;; This is now run from read-minibuffer-internal - ;(if minibuffer-setup-hook - ; (run-hooks 'minibuffer-setup-hook)) - ;(message nil) - (if (eq 't - (catch 'exit - (if (> (recursion-depth) (minibuffer-depth)) - (let ((standard-output t) - (standard-input t)) - (read-minibuffer-internal prompt)) - (read-minibuffer-internal prompt)))) - ;; Translate an "abort" (throw 'exit 't) - ;; into a real quit - (signal 'quit '()) - ;; return value - (let* ((val (progn (set-buffer buffer) - (if minibuffer-exit-hook - (run-hooks 'minibuffer-exit-hook)) - (buffer-string))) - (histval val) - (err nil)) - (if readp - (condition-case e - (let ((v (read-from-string val))) - (if (< (cdr v) (length val)) - (save-match-data - (or (string-match "[ \t\n]*\\'" val (cdr v)) - (error "Trailing garbage following expression")))) - (setq v (car v)) - ;; total total kludge - (if (stringp v) (setq v (list 'quote v))) - (setq val v)) - (end-of-file - (setq err - '(input-error "End of input before end of expression"))) - (error (setq err e)))) - ;; Add the value to the appropriate history list unless - ;; it's already the most recent element, or it's only - ;; two characters long. - (if (and (symbolp minibuffer-history-variable) - (boundp minibuffer-history-variable)) - (let ((list (symbol-value minibuffer-history-variable))) - (or (eq list t) - (null val) - (and list (equal histval (car list))) - (and (stringp val) - minibuffer-history-minimum-string-length - (< (length val) - minibuffer-history-minimum-string-length)) - (set minibuffer-history-variable - (if minibuffer-history-uniquify - (cons histval (remove histval list)) - (cons histval list)))))) - (if err (signal (car err) (cdr err))) - val)))) - ;; stupid display code requires this for some reason - (set-buffer buffer) - (buffer-disable-undo buffer) - (setq buffer-read-only nil) - (erase-buffer) - - ;; restore frame configurations - (if (and mconfig (frame-live-p oframe) - (eq frame (selected-frame))) - ;; if we changed frames (due to surrogate minibuffer), - ;; and we're still on the new frame, go back to the old one. - (select-frame oframe)) - (if mconfig (set-window-configuration mconfig)) - (set-window-configuration oconfig)))) - - -(defun minibuffer-max-depth-exceeded () - ;; - ;; This signals an error if an Nth minibuffer is invoked while N-1 are - ;; already active, whether the minibuffer window is selected or not. - ;; Since, under X, it's easy to jump out of the minibuffer (by doing M-x, - ;; getting distracted, and clicking elsewhere) many many novice users have - ;; had the problem of having multiple minibuffers build up, even to the - ;; point of exceeding max-lisp-eval-depth. Since the variable - ;; enable-recursive-minibuffers historically/crockishly is only consulted - ;; when the minibuffer is currently active (like typing M-x M-x) it doesn't - ;; help in this situation. - ;; - ;; This routine also offers to edit .emacs for you to get rid of this - ;; complaint, like `disabled' commands do, since it's likely that non-novice - ;; users will be annoyed by this change, so we give them an easy way to get - ;; rid of it forever. - ;; - (beep t 'minibuffer-limit-exceeded) - (message - "Minibuffer already active: abort it with `^]', enable new one with `n': ") - (let ((char (let ((cursor-in-echo-area t)) ; #### doesn't always work?? - (read-char)))) - (cond - ((eq char ?n) - (cond - ((y-or-n-p "Enable recursive minibuffers for other sessions too? ") - ;; This is completely disgusting, but it's basically what novice.el - ;; does. This kind of thing should be generalized. - (setq minibuffer-max-depth nil) - (save-excursion - (set-buffer - (find-file-noselect - (substitute-in-file-name custom-file))) - (goto-char (point-min)) - (if (re-search-forward - "^(setq minibuffer-max-depth \\([0-9]+\\|'?nil\\|'?()\\))\n" - nil t) - (delete-region (match-beginning 0 ) (match-end 0)) - ;; Must have been disabled by default. - (goto-char (point-max))) - (insert"\n(setq minibuffer-max-depth nil)\n") - (save-buffer)) - (message "Multiple minibuffers enabled") - (sit-for 1)))) - ((eq char ? ) - (abort-recursive-edit)) - (t - (error "Minibuffer already active"))))) - - -;;;; Guts of minibuffer completion - - -;; Used by minibuffer-do-completion -(defvar last-exact-completion) - -(defun temp-minibuffer-message (m) - (let ((savemax (point-max))) - (save-excursion - (goto-char (point-max)) - (message nil) - (insert m)) - (let ((inhibit-quit t)) - (sit-for 2) - (delete-region savemax (point-max)) - ;; If the user types a ^G while we're in sit-for, then quit-flag - ;; gets set. In this case, we want that ^G to be interpreted - ;; as a normal character, and act just like typeahead. - (if (and quit-flag (not unread-command-event)) - (setq unread-command-event (character-to-event (quit-char)) - quit-flag nil))))) - - -;; Determines whether buffer-string is an exact completion -(defun exact-minibuffer-completion-p (buffer-string) - (cond ((not minibuffer-completion-table) - ;; Empty alist - nil) - ((vectorp minibuffer-completion-table) - (let ((tem (intern-soft buffer-string - minibuffer-completion-table))) - (if (or tem - (and (string-equal buffer-string "nil") - ;; intern-soft loses for 'nil - (catch 'found - (mapatoms #'(lambda (s) - (if (string-equal - (symbol-name s) - buffer-string) - (throw 'found t))) - minibuffer-completion-table) - nil))) - (if minibuffer-completion-predicate - (funcall minibuffer-completion-predicate - tem) - t) - nil))) - ((and (consp minibuffer-completion-table) - ;;#### Emacs-Lisp truly sucks! - ;; lambda, autoload, etc - (not (symbolp (car minibuffer-completion-table)))) - (if (not completion-ignore-case) - (assoc buffer-string minibuffer-completion-table) - (let ((s (upcase buffer-string)) - (tail minibuffer-completion-table) - tem) - (while tail - (setq tem (car (car tail))) - (if (or (equal tem buffer-string) - (equal tem s) - (equal (upcase tem) s)) - (setq s 'win - tail nil) ;exit - (setq tail (cdr tail)))) - (eq s 'win)))) - (t - (funcall minibuffer-completion-table - buffer-string - minibuffer-completion-predicate - 'lambda))) - ) - -;; 0 'none no possible completion -;; 1 'unique was already an exact and unique completion -;; 3 'exact was already an exact (but nonunique) completion -;; NOT USED 'completed-exact-unique completed to an exact and completion -;; 4 'completed-exact completed to an exact (but nonunique) completion -;; 5 'completed some completion happened -;; 6 'uncompleted no completion happened -(defun minibuffer-do-completion-1 (buffer-string completion) - (cond ((not completion) - 'none) - ((eq completion t) - ;; exact and unique match - 'unique) - (t - ;; It did find a match. Do we match some possibility exactly now? - (let ((completedp (not (string-equal completion buffer-string)))) - (if completedp - (progn - ;; Some completion happened - (erase-buffer) - (insert completion) - (setq buffer-string completion))) - (if (exact-minibuffer-completion-p buffer-string) - ;; An exact completion was possible - (if completedp -;; Since no callers need to know the difference, don't bother -;; with this (potentially expensive) discrimination. -;; (if (eq (try-completion completion -;; minibuffer-completion-table -;; minibuffer-completion-predicate) -;; 't) -;; 'completed-exact-unique - 'completed-exact -;; ) - 'exact) - ;; Not an exact match - (if completedp - 'completed - 'uncompleted)))))) - - -(defun minibuffer-do-completion (buffer-string) - (let* ((completion (try-completion buffer-string - minibuffer-completion-table - minibuffer-completion-predicate)) - (status (minibuffer-do-completion-1 buffer-string completion)) - (last last-exact-completion)) - (setq last-exact-completion nil) - (cond ((eq status 'none) - ;; No completions - (ding nil 'no-completion) - (temp-minibuffer-message " [No match]")) - ((eq status 'unique) - ) - (t - ;; It did find a match. Do we match some possibility exactly now? - (if (not (string-equal completion buffer-string)) - (progn - ;; Some completion happened - (erase-buffer) - (insert completion) - (setq buffer-string completion))) - (cond ((eq status 'exact) - ;; If the last exact completion and this one were - ;; the same, it means we've already given a - ;; "Complete but not unique" message and that the - ;; user's hit TAB again, so now we give help. - (setq last-exact-completion completion) - (if (equal buffer-string last) - (minibuffer-completion-help))) - ((eq status 'uncompleted) - (if completion-auto-help - (minibuffer-completion-help) - (temp-minibuffer-message " [Next char not unique]"))) - (t - nil)))) - status)) - - -;;;; completing-read - -(defun completing-read (prompt table - &optional predicate require-match - initial-contents history) - "Read a string in the minibuffer, with completion. -Args: PROMPT, TABLE, PREDICATE, REQUIRE-MATCH, INITIAL-CONTENTS, HISTORY. -PROMPT is a string to prompt with; normally it ends in a colon and a space. -TABLE is an alist whose elements' cars are strings, or an obarray. -PREDICATE limits completion to a subset of TABLE. -See `try-completion' for more details on completion, TABLE, and PREDICATE. -If REQUIRE-MATCH is non-nil, the user is not allowed to exit unless - the input is (or completes to) an element of TABLE or is null. - If it is also not t, Return does not exit if it does non-null completion. -If INITIAL-CONTENTS is non-nil, insert it in the minibuffer initially. - If it is (STRING . POSITION), the initial input - is STRING, but point is placed POSITION characters into the string. -HISTORY, if non-nil, specifies a history list - and optionally the initial position in the list. - It can be a symbol, which is the history list variable to use, - or it can be a cons cell (HISTVAR . HISTPOS). - In that case, HISTVAR is the history list variable to use, - and HISTPOS is the initial position (the position in the list - which INITIAL-CONTENTS corresponds to). - If HISTORY is `t', no history will be recorded. - Positions are counted starting from 1 at the beginning of the list. -Completion ignores case if the ambient value of - `completion-ignore-case' is non-nil." - (let ((minibuffer-completion-table table) - (minibuffer-completion-predicate predicate) - (minibuffer-completion-confirm (if (eq require-match 't) nil t)) - (last-exact-completion nil)) - (read-from-minibuffer prompt - initial-contents - (if (not require-match) - minibuffer-local-completion-map - minibuffer-local-must-match-map) - nil - history))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Minibuffer completion commands ;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -(defun minibuffer-complete () - "Complete the minibuffer contents as far as possible. -Return nil if there is no valid completion, else t. -If no characters can be completed, display a list of possible completions. -If you repeat this command after it displayed such a list, -scroll the window of possible completions." - (interactive) - ;; If the previous command was not this, then mark the completion - ;; buffer obsolete. - (or (eq last-command this-command) - (setq minibuffer-scroll-window nil)) - (let ((window minibuffer-scroll-window)) - (if (and window (windowp window) (window-buffer window) - (buffer-name (window-buffer window))) - ;; If there's a fresh completion window with a live buffer - ;; and this command is repeated, scroll that window. - (let ((obuf (current-buffer))) - (unwind-protect - (progn - (set-buffer (window-buffer window)) - (if (pos-visible-in-window-p (point-max) window) - ;; If end is in view, scroll up to the beginning. - (set-window-start window (point-min)) - ;; Else scroll down one frame. - (scroll-other-window))) - (set-buffer obuf)) - nil) - (let ((status (minibuffer-do-completion (buffer-string)))) - (if (eq status 'none) - nil - (progn - (cond ((eq status 'unique) - (temp-minibuffer-message - " [Sole completion]")) - ((eq status 'exact) - (temp-minibuffer-message - " [Complete, but not unique]"))) - t)))))) - - -(defun minibuffer-complete-and-exit () - "Complete the minibuffer contents, and maybe exit. -Exit if the name is valid with no completion needed. -If name was completed to a valid match, -a repetition of this command will exit." - (interactive) - (if (= (point-min) (point-max)) - ;; Crockishly allow user to specify null string - (throw 'exit nil)) - (let ((buffer-string (buffer-string))) - ;; Short-cut -- don't call minibuffer-do-completion if we already - ;; have an (possibly nonunique) exact completion. - (if (exact-minibuffer-completion-p buffer-string) - (throw 'exit nil)) - (let ((status (minibuffer-do-completion buffer-string))) - (if (or (eq status 'unique) - (eq status 'exact) - (if (or (eq status 'completed-exact) - (eq status 'completed-exact-unique)) - (if minibuffer-completion-confirm - (progn (temp-minibuffer-message " [Confirm]") - nil) - t))) - (throw 'exit nil))))) - - -(defun self-insert-and-exit () - "Terminate minibuffer input." - (interactive) - (self-insert-command 1) - (throw 'exit nil)) - -(defun exit-minibuffer () - "Terminate this minibuffer argument. -If minibuffer-confirm-incomplete is true, and we are in a completing-read -of some kind, and the contents of the minibuffer is not an existing -completion, requires an additional RET before the minibuffer will be exited -\(assuming that RET was the character that invoked this command: -the character in question must be typed again)." - (interactive) - (if (not minibuffer-confirm-incomplete) - (throw 'exit nil)) - (let ((buffer-string (buffer-string))) - (if (exact-minibuffer-completion-p buffer-string) - (throw 'exit nil)) - (let ((completion (if (not minibuffer-completion-table) - t - (try-completion buffer-string - minibuffer-completion-table - minibuffer-completion-predicate)))) - (if (or (eq completion 't) - ;; Crockishly allow user to specify null string - (string-equal buffer-string "")) - (throw 'exit nil)) - (if completion ;; rewritten for I18N3 snarfing - (temp-minibuffer-message " [incomplete; confirm]") - (temp-minibuffer-message " [no completions; confirm]")) - (let ((event (let ((inhibit-quit t)) - (prog1 - (next-command-event) - (setq quit-flag nil))))) - (cond ((equal event last-command-event) - (throw 'exit nil)) - ((equal (quit-char) (event-to-character event)) - ;; Minibuffer abort. - (throw 'exit t))) - (dispatch-event event))))) - -;;;; minibuffer-complete-word - - -;;;#### I think I have done this correctly; it certainly is simpler -;;;#### than what the C code seemed to be trying to do. -(defun minibuffer-complete-word () - "Complete the minibuffer contents at most a single word. -After one word is completed as much as possible, a space or hyphen -is added, provided that matches some possible completion. -Return nil if there is no valid completion, else t." - (interactive) - (let* ((buffer-string (buffer-string)) - (completion (try-completion buffer-string - minibuffer-completion-table - minibuffer-completion-predicate)) - (status (minibuffer-do-completion-1 buffer-string completion))) - (cond ((eq status 'none) - (ding nil 'no-completion) - (temp-minibuffer-message " [No match]") - nil) - ((eq status 'unique) - ;; New message, only in this new Lisp code - (temp-minibuffer-message " [Sole completion]") - t) - (t - (cond ((or (eq status 'uncompleted) - (eq status 'exact)) - (let ((foo #'(lambda (s) - (condition-case nil - (if (try-completion - (concat buffer-string s) - minibuffer-completion-table - minibuffer-completion-predicate) - (progn - (goto-char (point-max)) - (insert s) - t) - nil) - (error nil)))) - (char last-command-char)) - ;; Try to complete by adding a word-delimiter - (or (and (characterp char) (> char 0) - (funcall foo (char-to-string char))) - (and (not (eq char ?\ )) - (funcall foo " ")) - (and (not (eq char ?\-)) - (funcall foo "-")) - (progn - (if completion-auto-help - (minibuffer-completion-help) - ;; New message, only in this new Lisp code - ;; rewritten for I18N3 snarfing - (if (eq status 'exact) - (temp-minibuffer-message - " [Complete, but not unique]") - (temp-minibuffer-message " [Ambiguous]"))) - nil)))) - (t - (erase-buffer) - (insert completion) - ;; First word-break in stuff found by completion - (goto-char (point-min)) - (let ((len (length buffer-string)) - n) - (if (and (< len (length completion)) - (catch 'match - (setq n 0) - (while (< n len) - (if (char-equal - (upcase (aref buffer-string n)) - (upcase (aref completion n))) - (setq n (1+ n)) - (throw 'match nil))) - t) - (progn - (goto-char (point-min)) - (forward-char len) - (re-search-forward "\\W" nil t))) - (delete-region (point) (point-max)) - (goto-char (point-max)))) - t)))))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; "Smart minibuffer" hackery ;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; ("Kludgy minibuffer hackery" is perhaps a better name) - -;; This works by setting `mouse-grabbed-buffer' to the minibuffer, -;; defining button2 in the minibuffer keymap to -;; `minibuffer-smart-select-highlighted-completion', and setting the -;; mode-motion-hook of the minibuffer to `minibuffer-mouse-tracker'. -;; By setting `mouse-grabbed-buffer', the minibuffer's keymap and -;; mode-motion-hook apply (for mouse motion and presses) no matter -;; what buffer the mouse is over. Then, `minibuffer-mouse-tracker' -;; examines the text under the mouse looking for something that looks -;; like a completion, and causes it to be highlighted, and -;; `minibuffer-smart-select-highlighted-completion' looks for a -;; flagged completion under the mouse and inserts it. This has the -;; following advantages: -;; -;; -- filenames and such in any buffer can be inserted by clicking, -;; not just completions -;; -;; but the following disadvantages: -;; -;; -- unless you're aware of the "filename in any buffer" feature, -;; the fact that strings in arbitrary buffers get highlighted appears -;; as a bug -;; -- mouse motion can cause ange-ftp actions -- bad bad bad. -;; -;; There's some hackery in minibuffer-mouse-tracker to try to avoid the -;; ange-ftp stuff, but it doesn't work. -;; - -(defcustom minibuffer-smart-completion-tracking-behavior nil - "*If non-nil, look for completions under mouse in all buffers. -This allows you to click on something that looks like a completion -and have it selected, regardless of what buffer it is in. - -This is not enabled by default because - --- The \"mysterious\" highlighting in normal buffers is confusing to - people not expecting it, and looks like a bug --- If ange-ftp is enabled, this tracking sometimes causes ange-ftp - action as a result of mouse motion, which is *bad bad bad*. - Hopefully this bug will be fixed at some point." - :type 'boolean - :group 'minibuffer) - -(defun minibuffer-smart-mouse-tracker (event) - ;; Used as the mode-motion-hook of the minibuffer window, which is the - ;; value of `mouse-grabbed-buffer' while the minibuffer is active. If - ;; the word under the mouse is a valid minibuffer completion, then it - ;; is highlighted. - ;; - ;; We do some special voodoo when we're reading a pathname, because - ;; the way filename completion works is funny. Possibly there's some - ;; more general way this could be dealt with... - ;; - ;; We do some further voodoo when reading a pathname that is an - ;; ange-ftp or efs path, because causing FTP activity as a result of - ;; mouse motion is a really bad time. - ;; - (and minibuffer-smart-completion-tracking-behavior - (event-point event) - ;; avoid conflict with display-completion-list extents - (not (extent-at (event-point event) - (event-buffer event) - 'list-mode-item)) - (let ((filename-kludge-p (eq minibuffer-completion-table - 'read-file-name-internal))) - (mode-motion-highlight-internal - event - #'(lambda () (default-mouse-track-beginning-of-word - (if filename-kludge-p 'nonwhite t))) - #'(lambda () - (let ((p (point)) - (string "")) - (default-mouse-track-end-of-word - (if filename-kludge-p 'nonwhite t)) - (if (and (/= p (point)) minibuffer-completion-table) - (setq string (buffer-substring p (point)))) - (if (string-match "\\`[ \t\n]*\\'" string) - (goto-char p) - (if filename-kludge-p - (setq string (minibuffer-smart-select-kludge-filename - string))) - ;; try-completion bogusly returns a string even when - ;; that string is complete if that string is also a - ;; prefix for other completions. This means that we - ;; can't just do the obvious thing, (eq t - ;; (try-completion ...)). - (let (comp) - (if (and filename-kludge-p - ;; #### evil evil evil evil - (or (and (fboundp 'ange-ftp-ftp-path) - (ange-ftp-ftp-path string)) - (and (fboundp 'efs-ftp-path) - (efs-ftp-path string)))) - (setq comp t) - (setq comp - (try-completion string - minibuffer-completion-table - minibuffer-completion-predicate))) - (or (eq comp t) - (and (equal comp string) - (or (null minibuffer-completion-predicate) - (stringp - minibuffer-completion-predicate) ; ??? - (funcall minibuffer-completion-predicate - (if (vectorp - minibuffer-completion-table) - (intern-soft - string - minibuffer-completion-table) - string)))) - (goto-char p)))))))))) - -(defun minibuffer-smart-select-kludge-filename (string) - (save-excursion - (set-buffer mouse-grabbed-buffer) ; the minibuf - (let ((kludge-string (concat (buffer-string) string))) - (if (or (and (fboundp 'ange-ftp-ftp-path) - (ange-ftp-ftp-path kludge-string)) - (and (fboundp 'efs-ftp-path) (efs-ftp-path kludge-string))) - ;; #### evil evil evil, but more so. - string - (append-expand-filename (buffer-string) string))))) - -(defun minibuffer-smart-select-highlighted-completion (event) - "Select the highlighted text under the mouse as a minibuffer response. -When the minibuffer is being used to prompt the user for a completion, -any valid completions which are visible on the frame will highlight -when the mouse moves over them. Clicking \\<minibuffer-local-map>\ -\\[minibuffer-smart-select-highlighted-completion] will select the -highlighted completion under the mouse. - -If the mouse is clicked while not over a highlighted completion, -then the global binding of \\[minibuffer-smart-select-highlighted-completion] \ -will be executed instead. In this\nway you can get at the normal global \ -behavior of \\[minibuffer-smart-select-highlighted-completion] as well as -the special minibuffer behavior." - (interactive "e") - (if minibuffer-smart-completion-tracking-behavior - (minibuffer-smart-select-highlighted-completion-1 event t) - (let ((command (lookup-key global-map - (vector current-mouse-event)))) - (if command (call-interactively command))))) - -(defun minibuffer-smart-select-highlighted-completion-1 (event global-p) - (let* ((filename-kludge-p (eq minibuffer-completion-table - 'read-file-name-internal)) - completion - command-p - (evpoint (event-point event)) - (evextent (and evpoint (extent-at evpoint (event-buffer event) - 'list-mode-item)))) - (if evextent - ;; avoid conflict with display-completion-list extents. - ;; if we find one, do that behavior instead. - (list-mode-item-selected-1 evextent event) - (save-excursion - (let* ((buffer (window-buffer (event-window event))) - (p (event-point event)) - (extent (and p (extent-at p buffer 'mouse-face)))) - (set-buffer buffer) - (if (not (and (extent-live-p extent) - (eq (extent-object extent) (current-buffer)) - (not (extent-detached-p extent)))) - (setq command-p t) - ;; ...else user has selected a highlighted completion. - (setq completion - (buffer-substring (extent-start-position extent) - (extent-end-position extent))) - (if filename-kludge-p - (setq completion (minibuffer-smart-select-kludge-filename - completion))) - ;; remove the extent so that it's not hanging around in - ;; *Completions* - (detach-extent extent) - (set-buffer mouse-grabbed-buffer) - (erase-buffer) - (insert completion)))) - ;; we need to execute the command or do the throw outside of the - ;; save-excursion. - (cond ((and command-p global-p) - (let ((command (lookup-key global-map - (vector current-mouse-event)))) - (if command - (call-interactively command) - (if minibuffer-completion-table - (error - "Highlighted words are valid completions. You may select one.") - (error "no completions"))))) - ((not command-p) - ;; things get confused if the minibuffer is terminated while - ;; not selected. - (select-window (minibuffer-window)) - (if (and filename-kludge-p (file-directory-p completion)) - ;; if the user clicked middle on a directory name, display the - ;; files in that directory. - (progn - (goto-char (point-max)) - (minibuffer-completion-help)) - ;; otherwise, terminate input - (throw 'exit nil))))))) - -(defun minibuffer-smart-maybe-select-highlighted-completion - (event &optional click-count) - "Like minibuffer-smart-select-highlighted-completion but does nothing if -there is no completion (as opposed to executing the global binding). Useful -as the value of `mouse-track-click-hook'." - (interactive "e") - (minibuffer-smart-select-highlighted-completion-1 event nil)) - -(define-key minibuffer-local-map 'button2 - 'minibuffer-smart-select-highlighted-completion) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Minibuffer History ;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defvar minibuffer-history '() - "Default minibuffer history list. -This is used for all minibuffer input except when an alternate history -list is specified.") - -;; Some other history lists: -;; -(defvar minibuffer-history-search-history '()) -(defvar function-history '()) -(defvar variable-history '()) -(defvar buffer-history '()) -(defvar shell-command-history '()) -(defvar file-name-history '()) - -(defvar read-expression-history nil) - -(defvar minibuffer-history-sexp-flag nil ;weird FSF Emacs kludge - "Non-nil when doing history operations on `command-history'. -More generally, indicates that the history list being acted on -contains expressions rather than strings.") - -(defun previous-matching-history-element (regexp n) - "Find the previous history element that matches REGEXP. -\(Previous history elements refer to earlier actions.) -With prefix argument N, search for Nth previous match. -If N is negative, find the next or Nth next match." - (interactive - (let ((enable-recursive-minibuffers t) - (minibuffer-history-sexp-flag nil)) - (if (eq 't (symbol-value minibuffer-history-variable)) - (error "History is not being recorded in this context")) - (list (read-from-minibuffer "Previous element matching (regexp): " - (car minibuffer-history-search-history) - minibuffer-local-map - nil - 'minibuffer-history-search-history) - (prefix-numeric-value current-prefix-arg)))) - (let ((history (symbol-value minibuffer-history-variable)) - prevpos - (pos minibuffer-history-position)) - (if (eq history t) - (error "History is not being recorded in this context")) - (while (/= n 0) - (setq prevpos pos) - (setq pos (min (max 1 (+ pos (if (< n 0) -1 1))) (length history))) - (if (= pos prevpos) - (if (= pos 1) ;; rewritten for I18N3 snarfing - (error "No later matching history item") - (error "No earlier matching history item"))) - (if (string-match regexp - (if minibuffer-history-sexp-flag - (let ((print-level nil)) - (prin1-to-string (nth (1- pos) history))) - (nth (1- pos) history))) - (setq n (+ n (if (< n 0) 1 -1))))) - (setq minibuffer-history-position pos) - (setq current-minibuffer-contents (buffer-string) - current-minibuffer-point (point)) - (erase-buffer) - (let ((elt (nth (1- pos) history))) - (insert (if minibuffer-history-sexp-flag - (let ((print-level nil)) - (prin1-to-string elt)) - elt))) - (goto-char (point-min))) - (if (or (eq (car (car command-history)) 'previous-matching-history-element) - (eq (car (car command-history)) 'next-matching-history-element)) - (setq command-history (cdr command-history)))) - -(defun next-matching-history-element (regexp n) - "Find the next history element that matches REGEXP. -\(The next history element refers to a more recent action.) -With prefix argument N, search for Nth next match. -If N is negative, find the previous or Nth previous match." - (interactive - (let ((enable-recursive-minibuffers t) - (minibuffer-history-sexp-flag nil)) - (if (eq t (symbol-value minibuffer-history-variable)) - (error "History is not being recorded in this context")) - (list (read-from-minibuffer "Next element matching (regexp): " - (car minibuffer-history-search-history) - minibuffer-local-map - nil - 'minibuffer-history-search-history) - (prefix-numeric-value current-prefix-arg)))) - (previous-matching-history-element regexp (- n))) - -(defun next-history-element (n) - "Insert the next element of the minibuffer history into the minibuffer." - (interactive "p") - (if (eq 't (symbol-value minibuffer-history-variable)) - (error "History is not being recorded in this context")) - (unless (zerop n) - (when (eq minibuffer-history-position - initial-minibuffer-history-position) - (setq current-minibuffer-contents (buffer-string) - current-minibuffer-point (point))) - (let ((narg (- minibuffer-history-position n))) - (cond ((< narg 0) - (error "No following item in %s" minibuffer-history-variable)) - ((> narg (length (symbol-value minibuffer-history-variable))) - (error "No preceding item in %s" minibuffer-history-variable))) - (erase-buffer) - (setq minibuffer-history-position narg) - (if (eq narg initial-minibuffer-history-position) - (progn - (insert current-minibuffer-contents) - (goto-char current-minibuffer-point)) - (let ((elt (nth (1- minibuffer-history-position) - (symbol-value minibuffer-history-variable)))) - (insert - (if (not (stringp elt)) - (let ((print-level nil)) - (condition-case nil - (let ((print-readably t) - (print-escape-newlines t)) - (prin1-to-string elt)) - (error (prin1-to-string elt)))) - elt))) - ;; FSF has point-min here. - (goto-char (point-max)))))) - -(defun previous-history-element (n) - "Inserts the previous element of the minibuffer history into the minibuffer." - (interactive "p") - (next-history-element (- n))) - -(defun next-complete-history-element (n) - "Get next element of history which is a completion of minibuffer contents." - (interactive "p") - (let ((point-at-start (point))) - (next-matching-history-element - (concat "^" (regexp-quote (buffer-substring (point-min) (point)))) n) - ;; next-matching-history-element always puts us at (point-min). - ;; Move to the position we were at before changing the buffer contents. - ;; This is still sensical, because the text before point has not changed. - (goto-char point-at-start))) - -(defun previous-complete-history-element (n) - "Get previous element of history which is a completion of minibuffer contents." - (interactive "p") - (next-complete-history-element (- n))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; reading various things from a minibuffer ;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun read-expression (prompt &optional initial-contents history) - "Return a Lisp object read using the minibuffer. -Prompt with PROMPT. If non-nil, optional second arg INITIAL-CONTENTS -is a string to insert in the minibuffer before reading. -Third arg HISTORY, if non-nil, specifies a history list." - (let ((minibuffer-history-sexp-flag t) - ;; Semi-kludge to get around M-x C-x o M-ESC trying to do completion. - (minibuffer-completion-table nil)) - (read-from-minibuffer prompt - initial-contents - read-expression-map - t - (or history 'read-expression-history) - lisp-mode-abbrev-table))) - -(defun read-string (prompt &optional initial-contents history) - "Return a string from the minibuffer, prompting with string PROMPT. -If non-nil, optional second arg INITIAL-CONTENTS is a string to insert -in the minibuffer before reading. -Third arg HISTORY, if non-nil, specifies a history list." - (let ((minibuffer-completion-table nil)) - (read-from-minibuffer prompt - initial-contents - minibuffer-local-map - nil history))) - -(defun eval-minibuffer (prompt &optional initial-contents history) - "Return value of Lisp expression read using the minibuffer. -Prompt with PROMPT. If non-nil, optional second arg INITIAL-CONTENTS -is a string to insert in the minibuffer before reading. -Third arg HISTORY, if non-nil, specifies a history list." - (eval (read-expression prompt initial-contents history))) - -;;;#### Screw this crock!! -;(defun read-no-blanks-input (prompt &optional initial-contents) -; "Read a string from the terminal, not allowing blanks. -;Prompt with PROMPT. If non-nil, optional second arg INITIAL-CONTENTS -;is a string to insert in the minibuffer before reading." -; (let ((minibuffer-completion-table nil)) -; (read-from-minibuffer prompt -; initial-contents -; minibuffer-local-ns-map -; nil))) - -;; The name `command-history' is already taken -(defvar read-command-history '()) - -(defun read-command (prompt) - "Read the name of a command and return as a symbol. -Prompts with PROMPT." - (intern (completing-read prompt obarray 'commandp t nil - ;; 'command-history is not right here: that's a - ;; list of evalable forms, not a history list. - 'read-command-history - ))) - -(defun read-function (prompt) - "Read the name of a function and return as a symbol. -Prompts with PROMPT." - (intern (completing-read prompt obarray 'fboundp t nil - 'function-history))) - -(defun read-variable (prompt) - "Read the name of a user variable and return it as a symbol. -Prompts with PROMPT. -A user variable is one whose documentation starts with a `*' character." - (intern (completing-read prompt obarray 'user-variable-p t nil - 'variable-history))) - -(defun read-buffer (prompt &optional default require-match) - "Read the name of a buffer and return as a string. -Prompts with PROMPT. Optional second arg DEFAULT is value to return if user -enters an empty line. If optional third arg REQUIRE-MATCH is non-nil, -only existing buffer names are allowed." - (let ((prompt (if default - (format "%s(default %s) " - (gettext prompt) (if (bufferp default) - (buffer-name default) - default)) - prompt)) - (alist (mapcar #'(lambda (b) (cons (buffer-name b) b)) - (buffer-list))) - result) - (while (progn - (setq result (completing-read prompt alist nil require-match - nil 'buffer-history)) - (cond ((not (equal result "")) - nil) - ((not require-match) - (setq result default) - nil) - ((not default) - t) - ((not (get-buffer default)) - t) - (t - (setq result default) - nil)))) - (if (bufferp result) - (buffer-name result) - result))) - -(defun read-number (prompt &optional integers-only) - "Reads a number from the minibuffer." - (let ((pred (if integers-only 'integerp 'numberp)) - num) - (while (not (funcall pred num)) - (setq num (condition-case () - (let ((minibuffer-completion-table nil)) - (read-from-minibuffer - prompt (if num (prin1-to-string num)) nil t - t)) ;no history - (invalid-read-syntax nil) - (end-of-file nil))) - (or (funcall pred num) (beep))) - num)) - -(defun read-shell-command (prompt &optional initial-input history) - "Just like read-string, but uses read-shell-command-map: -\\{read-shell-command-map}" - (let ((minibuffer-completion-table nil)) - (read-from-minibuffer prompt initial-input read-shell-command-map - nil (or history 'shell-command-history)))) - - -;;; This read-file-name stuff probably belongs in files.el - -;; Quote "$" as "$$" to get it past substitute-in-file-name -(defun un-substitute-in-file-name (string) - (let ((regexp "\\$") - (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)))) - -(defun read-file-name-2 (history prompt dir default - must-match initial-contents - completer) - (if (not dir) - (setq dir default-directory)) - (setq dir (abbreviate-file-name dir t)) - (let* ((insert (cond ((and (not insert-default-directory) - (not initial-contents)) - "") - (initial-contents - (cons (un-substitute-in-file-name - (concat dir initial-contents)) - (length dir))) - (t - (un-substitute-in-file-name dir)))) - (val (let ((completion-ignore-case (or completion-ignore-case - (eq system-type 'vax-vms)))) - ;; Hateful, broken, case-sensitive un*x -;;; (completing-read prompt -;;; completer -;;; dir -;;; 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))) - )) -;;; ;; Kludge! Put "/foo/bar" on history rather than "/default//foo/bar" -;;; (let ((hist (cond ((not history) 'minibuffer-history) -;;; ((consp history) (car history)) -;;; (t history)))) -;;; (if (and val -;;; hist -;;; (not (eq hist 't)) -;;; (boundp hist) -;;; (equal (car-safe (symbol-value hist)) val)) -;;; (let ((e (condition-case nil -;;; (expand-file-name val) -;;; (error nil)))) -;;; (if (and e (not (equal e val))) -;;; (set hist (cons e (cdr (symbol-value hist)))))))) - - (cond ((not val) - (error "No file name specified")) - ((and default - (equal val (if (consp insert) (car insert) insert))) - default) - (t - (substitute-in-file-name val))))) - -;; #### this function should use minibuffer-completion-table -;; or something. But that is sloooooow. -;; #### all this shit needs better documentation!!!!!!!! -(defun read-file-name-activate-callback (event extent dir-p) - ;; used as the activate-callback of the filename list items - ;; in the completion buffer, in place of default-choose-completion. - ;; if a regular file was selected, we call default-choose-completion - ;; (which just inserts the string in the minibuffer and calls - ;; exit-minibuffer). If a directory was selected, we display - ;; the contents of the directory. - (let* ((file (extent-string extent)) - (completion-buf (extent-object extent)) - (minibuf (symbol-value-in-buffer 'completion-reference-buffer - completion-buf)) - (in-dir (file-name-directory (buffer-substring nil nil minibuf))) - (full (expand-file-name file in-dir))) - (if (not (file-directory-p full)) - (default-choose-completion event extent minibuf) - (erase-buffer minibuf) - (insert-string (file-name-as-directory - (abbreviate-file-name full t)) minibuf) - (reset-buffer completion-buf) - (let ((standard-output completion-buf)) - (display-completion-list - (delete "." (directory-files full nil nil nil (if dir-p 'directory))) - :user-data dir-p - :reference-buffer minibuf - :activate-callback 'read-file-name-activate-callback) - (goto-char (point-min) completion-buf))))) - -(defun read-file-name-1 (history prompt dir default - must-match initial-contents - completer) - (if (should-use-dialog-box-p) - ;; this calls read-file-name-2 - (mouse-read-file-name-1 history prompt dir default must-match - initial-contents completer) - (let ((rfhookfun - (lambda () - (set - (make-local-variable - 'completion-display-completion-list-function) - #'(lambda (completions) - (display-completion-list - completions - :user-data (not (eq completer 'read-file-name-internal)) - :activate-callback - 'read-file-name-activate-callback))) - ;; kludge! - (remove-hook 'minibuffer-setup-hook rfhookfun) - ))) - (unwind-protect - (progn - (add-hook 'minibuffer-setup-hook rfhookfun) - (read-file-name-2 history prompt dir default must-match - initial-contents completer)) - (remove-hook 'minibuffer-setup-hook rfhookfun))))) - -(defun read-file-name (prompt - &optional dir default must-match initial-contents - history) - "Read file name, prompting with PROMPT and completing in directory DIR. -This will prompt with a dialog box if appropriate, according to - `should-use-dialog-box-p'. -Value is not expanded---you must call `expand-file-name' yourself. -Value is subject to interpreted by substitute-in-file-name however. -Default name to DEFAULT if user enters a null string. - (If DEFAULT is omitted, the visited file name is used, - except that if INITIAL-CONTENTS is specified, that combined with DIR is - used.) -Fourth arg MUST-MATCH non-nil means require existing file's name. - Non-nil and non-t means also require confirmation after completion. -Fifth arg INITIAL-CONTENTS specifies text to start with. -Sixth arg HISTORY specifies the history list to use. Default is - `file-name-history'. -DIR defaults to current buffer's directory default." - (read-file-name-1 - (or history 'file-name-history) - prompt dir (or default - (if initial-contents (expand-file-name initial-contents dir) - buffer-file-name)) - must-match initial-contents - ;; A separate function (not an anonymous lambda-expression) - ;; and passed as a symbol because of disgusting kludges in various - ;; places which do stuff like (let ((filename-kludge-p (eq minibuffer-completion-table 'read-file-name-internal))) ...) - 'read-file-name-internal)) - -(defun read-directory-name (prompt - &optional dir default must-match initial-contents) - "Read directory name, prompting with PROMPT and completing in directory DIR. -This will prompt with a dialog box if appropriate, according to - `should-use-dialog-box-p'. -Value is not expanded---you must call `expand-file-name' yourself. -Value is subject to interpreted by substitute-in-file-name however. -Default name to DEFAULT if user enters a null string. - (If DEFAULT is omitted, the current buffer's default directory is used.) -Fourth arg MUST-MATCH non-nil means require existing directory's name. - Non-nil and non-t means also require confirmation after completion. -Fifth arg INITIAL-CONTENTS specifies text to start with. -Sixth arg HISTORY specifies the history list to use. Default is - `file-name-history'. -DIR defaults to current buffer's directory default." - (read-file-name-1 - 'file-name-history - prompt dir (or default default-directory) must-match initial-contents - 'read-directory-name-internal)) - - -;; Environment-variable completion hack -(defun read-file-name-internal-1 (string dir action completer) - (if (not (string-match - "\\([^$]\\|\\`\\)\\(\\$\\$\\)*\\$\\([A-Za-z0-9_]*\\|{[^}]*\\)\\'" - string)) - ;; Not doing environment-variable completion hack - (let* ((orig (if (equal string "") nil string)) - (sstring (if orig (substitute-in-file-name string) string)) - (specdir (if orig (file-name-directory sstring) nil))) - (funcall completer - action - orig - sstring - specdir - (if specdir (expand-file-name specdir dir) dir) - (if orig (file-name-nondirectory sstring) string))) - ;; An odd number of trailing $'s - (let* ((start (match-beginning 3)) - (env (substring string - (cond ((= start (length string)) - ;; "...$" - start) - ((= (aref string start) ?{) - ;; "...${..." - (1+ start)) - (t - start)))) - (head (substring string 0 (1- start))) - (alist #'(lambda () - (mapcar #'(lambda (x) - (cons (substring x 0 (string-match "=" x)) - 'nil)) - process-environment)))) - - (cond ((eq action 'lambda) - nil) - ((eq action 't) - ;; all completions - (mapcar #'(lambda (p) - (if (and (> (length p) 0) - ;;#### Unix-specific - ;;#### -- need absolute-pathname-p - (/= (aref p 0) ?/)) - (concat "$" p) - (concat head "$" p))) - (all-completions env (funcall alist)))) - (t ;; 'nil - ;; complete - (let* ((e (funcall alist)) - (val (try-completion env e))) - (cond ((stringp val) - (if (string-match "[^A-Za-z0-9_]" val) - (concat head - "${" val - ;; completed uniquely? - (if (eq (try-completion val e) 't) - "}" "")) - (concat head "$" val))) - ((eql val 't) - (concat head - (un-substitute-in-file-name (getenv env)))) - (t nil)))))))) - - -(defun read-file-name-internal (string dir action) - (read-file-name-internal-1 - string dir action - #'(lambda (action orig string specdir dir name) - (cond ((eq action 'lambda) - (if (not orig) - nil - (let ((sstring (condition-case nil - (expand-file-name string) - (error nil)))) - (if (not sstring) - ;; Some pathname syntax error in string - nil - (file-exists-p sstring))))) - ((eq action 't) - ;; all completions - (mapcar #'un-substitute-in-file-name - (file-name-all-completions name dir))) - (t;; 'nil - ;; complete - (let* ((d (or dir default-directory)) - (val (file-name-completion name d))) - (if (and (eq val 't) - (not (null completion-ignored-extensions))) - ;;#### (file-name-completion "foo") returns 't - ;; when both "foo" and "foo~" exist and the latter - ;; is "pruned" by completion-ignored-extensions. - ;; I think this is a bug in file-name-completion. - (setq val (let ((completion-ignored-extensions '())) - (file-name-completion name d)))) - (if (stringp val) - (un-substitute-in-file-name (if specdir - (concat specdir val) - val)) - (let ((tem (un-substitute-in-file-name string))) - (if (not (equal tem orig)) - ;; substitute-in-file-name did something - tem - val))))))))) - -(defun read-directory-name-internal (string dir action) - (read-file-name-internal-1 - string dir action - #'(lambda (action orig string specdir dir name) - (let* ((dirs #'(lambda (fn) - (let ((l (if (equal name "") - (directory-files - dir - nil - "" - nil - 'directories) - (directory-files - dir - nil - (concat "\\`" (regexp-quote name)) - nil - 'directories)))) - (mapcar fn - (cond ((eq system-type 'vax-vms) - l) - (t - ;; Wretched unix - (delete "." l)))))))) - (cond ((eq action 'lambda) - ;; complete? - (if (not orig) - nil - (file-directory-p string))) - ((eq action 't) - ;; all completions - (funcall dirs #'(lambda (n) - (un-substitute-in-file-name - (file-name-as-directory n))))) - (t - ;; complete - (let ((val (try-completion - name - (funcall dirs - #'(lambda (n) - (list (file-name-as-directory - n))))))) - (if (stringp val) - (un-substitute-in-file-name (if specdir - (concat specdir val) - val)) - (let ((tem (un-substitute-in-file-name string))) - (if (not (equal tem orig)) - ;; substitute-in-file-name did something - tem - val)))))))))) - -(defun append-expand-filename (file-string string) - "Append STRING to FILE-STRING differently depending on whether STRING -is a username (~string), an environment variable ($string), -or a filename (/string). The resultant string is returned with the -environment variable or username expanded and resolved to indicate -whether it is a file(/result) or a directory (/result/)." - (let ((file - (cond ((string-match "\\([~$]\\)\\([^~$/]*\\)$" file-string) - (cond ((string= (substring file-string - (match-beginning 1) - (match-end 1)) "~") - (concat (substring file-string 0 (match-end 1)) - string)) - (t (substitute-in-file-name - (concat (substring file-string 0 (match-end 1)) - string))))) - (t (concat (file-name-directory - (substitute-in-file-name file-string)) string)))) - result) - - (cond ((stringp (setq result (and (file-exists-p (expand-file-name file)) - (read-file-name-internal - (condition-case nil - (expand-file-name file) - (error file)) - "" nil)))) - result) - (t file)))) - -(defun mouse-file-display-completion-list (window dir minibuf user-data) - (let ((standard-output (window-buffer window))) - (condition-case nil - (display-completion-list - (directory-files dir nil nil nil t) - :window-width (* 2 (window-width window)) - :activate-callback - 'mouse-read-file-name-activate-callback - :user-data user-data - :reference-buffer minibuf - :help-string "") - (t nil)))) - -(defun mouse-directory-display-completion-list (window dir minibuf user-data) - (let ((standard-output (window-buffer window))) - (condition-case nil - (display-completion-list - (delete "." (directory-files dir nil nil nil 1)) - :window-width (window-width window) - :activate-callback - 'mouse-read-file-name-activate-callback - :user-data user-data - :reference-buffer minibuf - :help-string "") - (t nil)))) - -(defun mouse-read-file-name-activate-callback (event extent user-data) - (let* ((file (extent-string extent)) - (minibuf (symbol-value-in-buffer 'completion-reference-buffer - (extent-object extent))) - (in-dir (buffer-substring nil nil minibuf)) - (full (expand-file-name file in-dir)) - (filebuf (nth 0 user-data)) - (dirbuff (nth 1 user-data)) - (filewin (nth 2 user-data)) - (dirwin (nth 3 user-data))) - (if (file-regular-p full) - (default-choose-completion event extent minibuf) - (erase-buffer minibuf) - (insert-string (file-name-as-directory - (abbreviate-file-name full t)) minibuf) - (reset-buffer filebuf) - (if (not dirbuff) - (mouse-directory-display-completion-list filewin full minibuf - user-data) - (mouse-file-display-completion-list filewin full minibuf user-data) - (reset-buffer dirbuff) - (mouse-directory-display-completion-list dirwin full minibuf - user-data))))) - -;; this is rather cheesified but gets the job done. -(defun mouse-read-file-name-1 (history prompt dir default - must-match initial-contents - completer) - (let* ((file-p (eq 'read-file-name-internal completer)) - (filebuf (get-buffer-create "*Completions*")) - (dirbuff (and file-p (generate-new-buffer " *mouse-read-file*"))) - (butbuff (generate-new-buffer " *mouse-read-file*")) - (frame (make-dialog-frame)) - filewin dirwin - user-data) - (unwind-protect - (progn - (reset-buffer filebuf) - (select-frame frame) - (let ((window-min-height 1)) - ;; #### should be 2 not 3, but that causes - ;; "window too small to split" errors for some - ;; people (but not for me ...) There's a more - ;; fundamental bug somewhere. - (split-window nil (- (frame-height frame) 3))) - (if file-p - (progn - (split-window-horizontally 16) - (setq filewin (frame-rightmost-window frame) - dirwin (frame-leftmost-window frame)) - (set-window-buffer filewin filebuf) - (set-window-buffer dirwin dirbuff)) - (setq filewin (frame-highest-window frame)) - (set-window-buffer filewin filebuf)) - (setq user-data (list filebuf dirbuff filewin dirwin)) - (set-window-buffer (frame-lowest-window frame) butbuff) - (set-buffer butbuff) - (set-specifier scrollbar-width 0 butbuff) - (insert " ") - (insert-gui-button (make-gui-button "OK" - (lambda (foo) - (exit-minibuffer)))) - (insert " ") - (insert-gui-button (make-gui-button "Cancel" - (lambda (foo) - (abort-recursive-edit)))) - (let ((rfhookfun - (lambda () - (if (not file-p) - (mouse-directory-display-completion-list - filewin dir (current-buffer) user-data) - (mouse-file-display-completion-list filewin dir - (current-buffer) - user-data) - (mouse-directory-display-completion-list dirwin dir - (current-buffer) - user-data)) - (set - (make-local-variable - 'completion-display-completion-list-function) - #'(lambda (completions) - (display-completion-list - completions - :help-string "" - :activate-callback - 'mouse-read-file-name-activate-callback - :user-data user-data))) - ;; kludge! - (remove-hook 'minibuffer-setup-hook rfhookfun) - )) - (rfcshookfun - ;; kludge! - ;; #### I really need to flesh out the object - ;; hierarchy better to avoid these kludges. - (lambda () - (save-excursion - (set-buffer standard-output) - (setq truncate-lines t))))) - (unwind-protect - (progn - (add-hook 'minibuffer-setup-hook rfhookfun) - (add-hook 'completion-setup-hook rfcshookfun) - (read-file-name-2 history prompt dir default - must-match initial-contents - completer)) - (remove-hook 'minibuffer-setup-hook rfhookfun) - (remove-hook 'completion-setup-hook rfcshookfun)))) - (delete-frame frame) - (kill-buffer filebuf) - (kill-buffer butbuff) - (and dirbuff (kill-buffer dirbuff))))) - -(defun read-face (prompt &optional must-match) - "Read the name of a face from the minibuffer and return it as a symbol." - (intern (completing-read prompt obarray 'find-face must-match))) - -;; #### - wrong place for this variable and function? At some point, we'll -;; have ansi color on ttys and so this ought to be here, but the x-specific -;; completion stuff should probably move. - -;; Ben wanted all of the possibilities from the `configure' script used -;; here, but I think this is way too many. I already trimmed the R4 variants -;; and a few obvious losers from the list. --Stig -(defvar x-library-search-path '("/usr/X11R6/lib/X11/" - "/usr/X11R5/lib/X11/" - "/usr/lib/X11R6/X11/" - "/usr/lib/X11R5/X11/" - "/usr/local/X11R6/lib/X11/" - "/usr/local/X11R5/lib/X11/" - "/usr/local/lib/X11R6/X11/" - "/usr/local/lib/X11R5/X11/" - "/usr/X11/lib/X11/" - "/usr/lib/X11/" - "/usr/local/lib/X11/" - "/usr/X386/lib/X11/" - "/usr/x386/lib/X11/" - "/usr/XFree86/lib/X11/" - "/usr/unsupported/lib/X11/" - "/usr/athena/lib/X11/" - "/usr/local/x11r5/lib/X11/" - "/usr/lpp/Xamples/lib/X11/" - "/usr/openwin/lib/X11/" - "/usr/openwin/share/lib/X11/") - "Search path used by `read-color' to find rgb.txt.") - -(defvar read-color-completion-table) - -(defun read-color-completion-table () - (if (boundp 'read-color-completion-table) - read-color-completion-table - (let ((rgb-file (locate-file "rgb.txt" x-library-search-path)) - clist color p) - (if (not rgb-file) - ;; prevents multiple searches for rgb.txt if we can't find it - (setq read-color-completion-table nil) - (save-excursion - (set-buffer (get-buffer-create " *colors*")) - (reset-buffer (current-buffer)) - (insert-file-contents rgb-file) - (while (not (eobp)) - ;; skip over comments - (while (looking-at "^!") - (end-of-line) - (forward-char 1)) - (skip-chars-forward "0-9 \t") - (setq p (point)) - (end-of-line) - (setq color (buffer-substring p (point)) - clist (cons (list color) clist)) - ;; Ugh. If we want to be able to complete the lowercase form - ;; of the color name, we need to add it twice! Yuck. - (let ((dcase (downcase color))) - (or (string= dcase color) - (setq clist (cons (list dcase) clist)))) - (forward-char 1)) - (kill-buffer (current-buffer)))) - (setq read-color-completion-table clist) - read-color-completion-table))) - -(defun read-color (prompt &optional must-match initial-contents) - "Read the name of a color from the minibuffer. -Uses `x-library-search-path' to find rgb.txt in order to build a completion -table." - (completing-read prompt (read-color-completion-table) nil - (and (read-color-completion-table) must-match) - initial-contents)) - - -;; #### The doc string for read-non-nil-coding system gets lost if we -;; only include these if the mule feature is present. Strangely, -;; read-coding-system doesn't. - -;;(if (featurep 'mule) - -(defun read-coding-system (prompt) - "Read a coding-system (or nil) from the minibuffer. -Prompting with string PROMPT." - (intern (completing-read prompt obarray 'find-coding-system t))) - -(defun read-non-nil-coding-system (prompt) - "Read a non-nil coding-system from the minibuffer. -Prompt with string PROMPT." - (let ((retval (intern ""))) - (while (= 0 (length (symbol-name retval))) - (setq retval (intern (completing-read prompt obarray - 'find-coding-system - t)))) - retval)) - -;;) ;; end of (featurep 'mule) - - - -(defcustom force-dialog-box-use nil - "*If non-nil, always use a dialog box for asking questions, if possible. -You should *bind* this, not set it. This is useful if you're doing -something mousy but which wasn't actually invoked using the mouse." - :type 'boolean - :group 'minibuffer) - -;; We include this here rather than dialog.el so it is defined -;; even when dialog boxes are not present. -(defun should-use-dialog-box-p () - "If non-nil, questions should be asked with a dialog box instead of the -minibuffer. This looks at `last-command-event' to see if it was a mouse -event, and checks whether dialog-support exists and the current device -supports dialog boxes. - -The dialog box is totally disabled if the variable `use-dialog-box' -is set to nil." - (and (featurep 'dialog) - (device-on-window-system-p) - use-dialog-box - (or force-dialog-box-use - (button-press-event-p last-command-event) - (button-release-event-p last-command-event) - (misc-user-event-p last-command-event)))) - -;;; minibuf.el ends here
--- a/lisp/prim/misc.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,63 +0,0 @@ -;;; misc.el --- miscellaneous functions for XEmacs - -;; Copyright (C) 1989, 1997 Free Software Foundation, Inc. - -;; Maintainer: FSF - -;; 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.34. - -;; 06/11/1997 - Use char-(after|before) instead of -;; (following|preceding)-char. -slb - -;;; Code: - -(defun copy-from-above-command (&optional arg) - "Copy characters from previous nonblank line, starting just above point. -Copy ARG characters, but not past the end of that line. -If no argument given, copy the entire rest of the line. -The characters copied are inserted in the buffer before point." - (interactive "P") - (let ((cc (current-column)) - n - (string "")) - (save-excursion - (beginning-of-line) - (backward-char 1) - (skip-chars-backward "\ \t\n") - (move-to-column cc) - ;; Default is enough to copy the whole rest of the line. - (setq n (if arg (prefix-numeric-value arg) (point-max))) - ;; If current column winds up in middle of a tab, - ;; copy appropriate number of "virtual" space chars. - (if (< cc (current-column)) - (if (eq (char-before (point)) ?\t) - (progn - (setq string (make-string (min n (- (current-column) cc)) ?\ )) - (setq n (- n (min n (- (current-column) cc))))) - ;; In middle of ctl char => copy that whole char. - (backward-char 1))) - (setq string (concat string - (buffer-substring - (point) - (min (save-excursion (end-of-line) (point)) - (+ n (point))))))) - (insert string))) - -;;; misc.el ends here
--- a/lisp/prim/mode-motion.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,129 +0,0 @@ -;; Mode-specific mouse-highlighting of text. -;; Copyright (C) 1992, 1993 Free Software Foundation, Inc. - -;; 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, 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: Not in FSF. - -(defvar mode-motion-hook nil - "Function or functions which are called whenever the mouse moves. -You should normally use this rather than `mouse-motion-handler', which -does some additional window-system-dependent things. This hook is local -to every buffer, and should normally be set up by major-modes which want -to use special highlighting. Every time the mouse moves over a window, -the mode-motion-hook of the buffer of that window is run.") - -(make-variable-buffer-local 'mode-motion-hook) - -(defvar mode-motion-extent nil) -(make-variable-buffer-local 'mode-motion-extent) - -(defvar mode-motion-help-echo-string nil - "String to be added as the 'help-echo property of the mode-motion extent. -In order for this to work, you need to add the hook function -`mode-motion-add-help-echo' to the mode-motion hook. If this is a function, -it will be called with one argument (the event) and should return a string -to be added. This variable is local to every buffer.") -(make-variable-buffer-local 'mode-motion-help-echo-string) - -(defun mode-motion-ensure-extent-ok (event) - (let ((buffer (event-buffer event))) - (if (and (extent-live-p mode-motion-extent) - (eq buffer (extent-object mode-motion-extent))) - nil - (setq mode-motion-extent (make-extent nil nil buffer)) - (set-extent-property mode-motion-extent 'mouse-face 'highlight)))) - -(defun mode-motion-highlight-internal (event backward forward) - (let* ((buffer (event-buffer event)) - (point (and buffer (event-point event)))) - (if (and buffer - (not (eq buffer mouse-grabbed-buffer))) - ;; #### ack!! Too many calls to save-window-excursion / - ;; save-excursion (x-track-pointer calls, so does - ;; minibuf-mouse-tracker ...) This needs to be looked - ;; into. It's complicated by the fact that sometimes - ;; a mode-motion-hook might really want to change - ;; the point. - ;; - ;; #### The save-excursion must come before the - ;; save-window-excursion in order to function properly. I - ;; haven't given this much thought. Is it a bug that this - ;; ordering is necessary or is it correct behavior? - (save-excursion - (save-window-excursion - (set-buffer buffer) - (mode-motion-ensure-extent-ok event) - (if point - (progn - (goto-char point) - (condition-case nil (funcall backward) (error nil)) - (setq point (point)) - (condition-case nil (funcall forward) (error nil)) - (if (eq point (point)) - (detach-extent mode-motion-extent) - (set-extent-endpoints mode-motion-extent point (point)))) - ;; not over text; zero the extent. - (detach-extent mode-motion-extent))))))) - -(defun mode-motion-highlight-line (event) - "For use as the value of `mode-motion-hook' -- highlight line under mouse." - (mode-motion-highlight-internal event 'beginning-of-line 'end-of-line)) - -(defun mode-motion-highlight-word (event) - "For use as the value of `mode-motion-hook' -- highlight word under mouse." - (mode-motion-highlight-internal - event - #'(lambda () (default-mouse-track-beginning-of-word nil)) - #'(lambda () (default-mouse-track-end-of-word nil)))) - -(defun mode-motion-highlight-symbol (event) - "For use as the value of `mode-motion-hook' -- highlight symbol under mouse." - (mode-motion-highlight-internal - event - #'(lambda () (default-mouse-track-beginning-of-word t)) - #'(lambda () (default-mouse-track-end-of-word t)))) - -(defun mode-motion-highlight-sexp (event) - "For use as the value of `mode-motion-hook' -- highlight form under mouse." - (mode-motion-highlight-internal - event - #'(lambda () - (if (= (char-syntax (following-char)) ?\() - nil - (goto-char (scan-sexps (point) -1)))) - #'(lambda () - (if (= (char-syntax (following-char)) ?\)) - (forward-char 1)) - (goto-char (scan-sexps (point) 1))))) - -(defun mode-motion-add-help-echo (event) - "For use as the value of `mode-motion-hook' -- add a 'help-echo property. -This causes the string in the 'help-echo property to be displayed when the -mouse moves over the extent. See `mode-motion-help-echo-string' for -documentation on how to control the string that is added." - (mode-motion-ensure-extent-ok event) - (let ((string (cond ((null mode-motion-help-echo-string) nil) - ((stringp mode-motion-help-echo-string) - mode-motion-help-echo-string) - (t (funcall mode-motion-help-echo-string event))))) - (if (stringp string) - (set-extent-property mode-motion-extent 'help-echo string)))) - - -(provide 'mode-motion)
--- a/lisp/prim/modeline.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,532 +0,0 @@ -;;; modeline.el --- modeline hackery. - -;; Copyright (C) 1988, 1992-1994, 1997 Free Software Foundation, Inc. -;; Copyright (C) 1995, 1996 Ben Wing. - -;; 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, 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: Not in FSF. - -;;; Commentary: - -;;; Code: - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; General mouse modeline stuff ;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defgroup modeline nil - "Modeline customizations" - :group 'environment) - -(defcustom drag-modeline-event-lag 150 - "*The pause (in msecs) between drag modeline events before redisplaying. -If this value is too small, dragging will be choppy because redisplay cannot -keep up. If it is too large, dragging will be choppy because of the explicit -redisplay delay specified." - :type 'integer - :group 'modeline) - -(defcustom modeline-click-swaps-buffers nil - "*If non-nil, clicking on the modeline changes the current buffer. -Click on the left half of the modeline cycles forward through the -buffer list and clicking on the right half cycles backward." - :type 'boolean - :group 'modeline) - -(defun mouse-drag-modeline (event) - "Resize a window by dragging its modeline. -This command should be bound to a button-press event in modeline-map. -Holding down a mouse button and moving the mouse up and down will -make the clicked-on window taller or shorter." - (interactive "e") - (or (button-press-event-p event) - (error "%s must be invoked by a mouse-press" this-command)) - (or (event-over-modeline-p event) - (error "not over a modeline")) - (let ((done nil) - (depress-line (event-y event)) - (start-event-frame (event-frame event)) - (start-event-window (event-window event)) - (start-nwindows (count-windows t)) - (last-timestamp 0) - default-line-height - modeline-height - should-enlarge-minibuffer - event min-height minibuffer y top bot edges wconfig growth) - (setq minibuffer (minibuffer-window start-event-frame) - default-line-height (face-height 'default start-event-window) - min-height (* window-min-height default-line-height) - modeline-height - (if (specifier-instance has-modeline-p start-event-window) - (+ (face-height 'modeline start-event-window) - (* 2 (specifier-instance modeline-shadow-thickness - start-event-window))) - (* 2 (specifier-instance modeline-shadow-thickness - start-event-window)))) - (if (not (eq (window-frame minibuffer) start-event-frame)) - (setq minibuffer nil)) - (if (and (null minibuffer) (one-window-p t)) - (error "Attempt to resize sole window")) - ;; if this is the bottommost ordinary window, then to - ;; move its modeline the minibuffer must be enlarged. - (setq should-enlarge-minibuffer - (and minibuffer (window-lowest-p start-event-window))) - ;; loop reading events - (while (not done) - (setq event (next-event event)) - ;; requeue event and quit if this is a misc-user, eval or - ;; keypress event. - ;; quit if this is a button press or release event, or if the event - ;; occurred in some other frame. - ;; drag if this is a mouse motion event and the time - ;; between this event and the last event is greater than - ;; drag-modeline-event-lag. - ;; do nothing if this is any other kind of event. - (cond ((or (misc-user-event-p event) - (key-press-event-p event)) - (setq unread-command-events (nconc unread-command-events - (list event)) - done t)) - ((button-release-event-p event) - (setq done t) - (if modeline-click-swaps-buffers - (mouse-release-modeline event depress-line))) - ((button-event-p event) - (setq done t)) - ((timeout-event-p event) - nil) - ((not (motion-event-p event)) - (dispatch-event event)) - ((not (eq start-event-frame (event-frame event))) - (setq done t)) - ((< (abs (- (event-timestamp event) last-timestamp)) - drag-modeline-event-lag) - nil) - (t - (setq last-timestamp (event-timestamp event) - y (event-y-pixel event) - edges (window-pixel-edges start-event-window) - top (nth 1 edges) - bot (nth 3 edges)) - ;; scale back a move that would make the - ;; window too short. - (cond ((< (- y top (- modeline-height)) min-height) - (setq y (+ top min-height (- modeline-height))))) - ;; compute size change needed - (setq growth (- y bot (/ (- modeline-height) 2)) - wconfig (current-window-configuration)) - ;; grow/shrink minibuffer? - (if should-enlarge-minibuffer - (progn - ;; yes. scale back shrinkage if it - ;; would make the minibuffer less than 1 - ;; line tall. - ;; - ;; also flip the sign of the computed growth, - ;; since if we want to grow the window with the - ;; modeline we need to shrink the minibuffer - ;; and vice versa. - (if (and (> growth 0) - (< (- (window-pixel-height minibuffer) - growth) - default-line-height)) - (setq growth - (- (window-pixel-height minibuffer) - default-line-height))) - (setq growth (- growth)))) - ;; window grow and shrink by lines not pixels, so - ;; divide the pixel height by the height of the - ;; default face. - (setq growth (/ growth default-line-height)) - ;; grow/shrink the window - (enlarge-window growth nil (if should-enlarge-minibuffer - minibuffer - start-event-window)) - ;; if this window's growth caused another - ;; window to be deleted because it was too - ;; short, rescind the change. - ;; - ;; if size change caused space to be stolen - ;; from a window above this one, rescind the - ;; change, but only if we didn't grow/shrink - ;; the minibuffer. minibuffer size changes - ;; can cause all windows to shrink... no way - ;; around it. - (if (or (/= start-nwindows (count-windows t)) - (and (not should-enlarge-minibuffer) - (/= top (nth 1 (window-pixel-edges - start-event-window))))) - (set-window-configuration wconfig))))))) - -;; from Bob Weiner (bob_weiner@pts.mot.com) -(defun mouse-release-modeline (event line-num) - "Handle modeline click EVENT on LINE-NUM 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. -Args are: EVENT, the mouse release event, and LINE-NUM, the line number -within the frame at which the mouse was first depressed." - (if (= line-num (event-y event)) - ;; Button press and release are at same line, treat this as - ;; a click and switch buffers. - (if (< (event-x event) (/ (window-width (event-window event)) 2)) - ;; On left half of modeline, bury current buffer, - ;; displaying second buffer on list. - (mouse-bury-buffer event) - ;; On right half of modeline, raise and display bottommost - ;; buffer in buffer list. - (mouse-unbury-buffer event)))) - -(defconst modeline-menu - '("Window Commands" - ["Delete Window Above" delete-window t] - ["Delete Other Windows" delete-other-windows t] - ["Split Window Above" split-window-vertically t] - ["Split Window Horizontally" split-window-horizontally t] - ["Balance Windows" balance-windows t] - )) - -(defun modeline-menu (event) - (interactive "e") - (popup-menu-and-execute-in-window - (cons (format "Window Commands for %S:" - (buffer-name (event-buffer event))) - (cdr modeline-menu)) - event)) - -(defvar modeline-map (make-sparse-keymap 'modeline-map) - "Keymap consulted for mouse-clicks on the modeline of a window. -This variable may be buffer-local; its value will be looked up in -the buffer of the window whose modeline was clicked upon.") - -(define-key modeline-map 'button1 'mouse-drag-modeline) -;; button2 selects the window without setting point -(define-key modeline-map 'button2 (lambda () (interactive "@"))) -(define-key modeline-map 'button3 'modeline-menu) - -(make-face 'modeline-mousable "Face for mousable portions of the modeline.") -(set-face-parent 'modeline-mousable 'modeline) -(when (featurep 'x) - (set-face-foreground 'modeline-mousable "firebrick" 'global '(color x)) - (set-face-font 'modeline-mousable [bold] nil '(mono x)) - (set-face-font 'modeline-mousable [bold] nil '(grayscale x))) - -(defmacro make-modeline-command-wrapper (command) - `#'(lambda (event) - (interactive "e") - (save-selected-window - (select-window (event-window event)) - (call-interactively ',(eval command))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Minor modes ;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defvar minor-mode-alist nil - "Alist saying how to show minor modes in the modeline. -Each element looks like (VARIABLE STRING); -STRING is included in the modeline iff VARIABLE's value is non-nil. - -Actually, STRING need not be a string; any possible modeline element -is okay. See `modeline-format'.") - -;; Used by C code (lookup-key and friends) but defined here. -(defvar minor-mode-map-alist nil - "Alist of keymaps to use for minor modes. -Each element looks like (VARIABLE . KEYMAP); KEYMAP is used to read -key sequences and look up bindings iff VARIABLE's value is non-nil. -If two active keymaps bind the same key, the keymap appearing earlier -in the list takes precedence.") - -(make-face 'modeline-mousable-minor-mode - "Face for mousable minor-mode strings in the modeline.") -(set-face-parent 'modeline-mousable-minor-mode 'modeline-mousable) -(when (featurep 'x) - (set-face-foreground 'modeline-mousable-minor-mode - '(((color x) . "green4") - ((color x) . "forestgreen")) 'global)) - -(defvar modeline-mousable-minor-mode-extent (make-extent nil nil) - ;; alliteration at its finest. - "Extent managing the mousable minor mode modeline strings.") -(set-extent-face modeline-mousable-minor-mode-extent - 'modeline-mousable-minor-mode) - -;; This replaces the idiom -;; -;; (or (assq 'isearch-mode minor-mode-alist) -;; (setq minor-mode-alist -;; (purecopy -;; (append minor-mode-alist -;; '((isearch-mode isearch-mode)))))) - -(defvar place) -(defun add-minor-mode (toggle name &optional keymap after toggle-fun) - "Add a minor mode to `minor-mode-alist' and `minor-mode-map-alist'. -TOGGLE is a symbol whose value as a variable specifies whether the -minor mode is active. NAME is the name that should appear in the -modeline (it should either be a string beginning with a space or a -symbol). KEYMAP is a keymap to make active when the minor mode is -active. AFTER is the toggling symbol used for another minor mode. If -AFTER is non-nil, then it is used to position the new mode in the -minor-mode alists. TOGGLE-FUN specifies an interactive function that -is called to toggle the mode on and off; this affects what happens -when button2 is pressed on the mode, and when button3 is pressed -somewhere in the list of modes. If TOGGLE-FUN is nil and TOGGLE names -an interactive function, TOGGLE is used as the toggle function. - -Example: (add-minor-mode 'view-minor-mode \" View\" view-mode-map)" - (let (el place - (add-elt #'(lambda (elt sym) - (cond ((null after) ; add to front - (set sym (cons elt (symbol-value sym)))) - ((and (not (eq after t)) - (setq place (memq (assq after - (symbol-value sym)) - (symbol-value sym)))) - (setq elt (cons elt (cdr place))) - (setcdr place elt)) - (t - (set sym (append (symbol-value sym) (list elt)))) - ) - (symbol-value sym))) - toggle-keymap) - (if toggle-fun - (if (not (commandp toggle-fun)) - (error "not an interactive function: %S" toggle-fun)) - (if (commandp toggle) - (setq toggle-fun toggle))) - (if (and toggle-fun name) - (progn - (setq toggle-keymap (make-sparse-keymap - (intern (concat "modeline-minor-" - (symbol-name toggle) - "-map")))) - (define-key toggle-keymap 'button2 - ;; defeat the DUMB-ASS byte-compiler, which tries to - ;; expand the macro at compile time and fucks up. - (eval '(make-modeline-command-wrapper toggle-fun))) - (put toggle 'modeline-toggle-function toggle-fun))) - (and name - (let ((hacked-name - (if toggle-keymap - (cons (let ((extent (make-extent nil nil))) - (set-extent-keymap extent toggle-keymap) - (set-extent-property - extent 'help-echo - (concat "button2 turns off " - (if (symbolp toggle-fun) - (symbol-name toggle-fun) - (symbol-name toggle)))) - extent) - (cons - modeline-mousable-minor-mode-extent - name)) - name))) - (if (setq el (assq toggle minor-mode-alist)) - (setcdr el (list hacked-name)) - (funcall add-elt - (list toggle hacked-name) - 'minor-mode-alist)))) - (and keymap - (if (setq el (assq toggle minor-mode-map-alist)) - (setcdr el keymap) - (funcall add-elt - (cons toggle keymap) - 'minor-mode-map-alist))) - )) - -(add-minor-mode 'abbrev-mode " Abbrev") -(add-minor-mode 'overwrite-mode 'overwrite-mode) -(add-minor-mode 'auto-fill-function " Fill" nil nil 'auto-fill-mode) -;; not really a minor mode... -(add-minor-mode 'defining-kbd-macro " Def") - -(defun modeline-minor-mode-menu (event) - (interactive "e") - (save-excursion - (set-buffer (event-buffer event)) - (popup-menu-and-execute-in-window - (cons (format "Minor Mode Commands for %S:" - (buffer-name (event-buffer event))) - (apply 'nconc - (mapcar - #'(lambda (x) - (let* ((toggle-sym (car x)) - (toggle-fun - (or (get toggle-sym - 'modeline-toggle-function) - (and (fboundp toggle-sym) - (commandp toggle-sym) - toggle-sym)))) - (if (not toggle-fun) nil - (list (vector - (concat (if (and (boundp toggle-sym) - (symbol-value toggle-sym)) - "turn off " "turn on ") - (if (symbolp toggle-fun) - (symbol-name toggle-fun) - (symbol-name toggle-sym))) - - toggle-fun - t))))) - minor-mode-alist))) - event))) - -(defvar modeline-minor-mode-map (make-sparse-keymap 'modeline-minor-mode-map) - "Keymap consulted for mouse-clicks on the minor-mode modeline list.") -(define-key modeline-minor-mode-map 'button3 'modeline-minor-mode-menu) - -(defvar modeline-minor-mode-extent (make-extent nil nil) - "Extent covering the minor mode modeline strings.") -(set-extent-face modeline-minor-mode-extent 'modeline-mousable) -(set-extent-keymap modeline-minor-mode-extent modeline-minor-mode-map) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Other ;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun modeline-buffers-menu (event) - (interactive "e") - (popup-menu-and-execute-in-window - '("Buffers Popup Menu" - :filter buffers-menu-filter - ["List All Buffers" list-buffers t] - "--" - ) - event)) - -(defvar modeline-buffer-id-left-map - (make-sparse-keymap 'modeline-buffer-id-left-map) -"Keymap consulted for mouse-clicks on the left half of the buffer-id string.") - -(defvar modeline-buffer-id-right-map - (make-sparse-keymap 'modeline-buffer-id-right-map) -"Keymap consulted for mouse-clicks on the right half of the buffer-id string.") - -(define-key modeline-buffer-id-left-map 'button2 'mouse-unbury-buffer) -(define-key modeline-buffer-id-right-map 'button2 'mouse-bury-buffer) -(define-key modeline-buffer-id-left-map 'button3 'modeline-buffers-menu) -(define-key modeline-buffer-id-right-map 'button3 'modeline-buffers-menu) - -(make-face 'modeline-buffer-id - "Face for the buffer ID string in the modeline.") -(set-face-parent 'modeline-buffer-id 'modeline) -(when (featurep 'x) - (set-face-foreground 'modeline-buffer-id "blue4" 'global '(color x))) -(when (featurep 'x) - (set-face-font 'modeline-buffer-id [bold-italic] nil '(mono x)) - (set-face-font 'modeline-buffer-id [bold-italic] nil '(grayscale x))) -(when (featurep 'tty) - (set-face-font 'modeline-buffer-id [bold-italic] nil 'tty)) - -(defvar modeline-buffer-id-extent (make-extent nil nil) - "Extent covering the whole of the buffer-id string.") -(set-extent-face modeline-buffer-id-extent 'modeline-buffer-id) - -(defvar modeline-buffer-id-left-extent (make-extent nil nil) -"Extent covering the left half of the buffer-id string.") -(set-extent-keymap modeline-buffer-id-left-extent - modeline-buffer-id-left-map) -(set-extent-property modeline-buffer-id-left-extent 'help-echo - "button2 cycles to the previous buffer") - -(defvar modeline-buffer-id-right-extent (make-extent nil nil) -"Extent covering the right half of the buffer-id string.") -(set-extent-keymap modeline-buffer-id-right-extent - modeline-buffer-id-right-map) -(set-extent-property modeline-buffer-id-right-extent 'help-echo - "button2 cycles to the next buffer") - -(defconst modeline-buffer-identification - (list (cons modeline-buffer-id-left-extent (purecopy "XEmacs%N:")) - ; this used to be "XEmacs:" - (cons modeline-buffer-id-right-extent (purecopy " %17b"))) - "Modeline control for identifying the buffer being displayed. -Its default value is \"XEmacs: %17b\" (NOT!). Major modes that edit things -other than ordinary files may change this (e.g. Info, Dired,...)") -(make-variable-buffer-local 'modeline-buffer-identification) - -(defconst modeline-process nil - "Modeline control for displaying info on process status. -Normally nil in most modes, since there is no process to display.") -(make-variable-buffer-local 'modeline-process) - -(defvar modeline-modified-map (make-sparse-keymap 'modeline-modified-map) - "Keymap consulted for mouse-clicks on the modeline-modified string.") -(define-key modeline-modified-map 'button2 - (make-modeline-command-wrapper 'modeline-toggle-read-only)) - -(defvar modeline-modified-extent (make-extent nil nil) - "Extent covering the modeline-modified string.") -(set-extent-face modeline-modified-extent 'modeline-mousable) -(set-extent-keymap modeline-modified-extent modeline-modified-map) -(set-extent-property modeline-modified-extent 'help-echo - "button2 toggles the buffer's read-only status") - -(defconst modeline-modified (purecopy '("--%1*%1+-")) - "Modeline control for displaying whether current buffer is modified.") -(make-variable-buffer-local 'modeline-modified) - -(defvar modeline-narrowed-map (make-sparse-keymap 'modeline-narrowed-map) - "Keymap consulted for mouse-clicks on the modeline-narrowed string.") -(define-key modeline-narrowed-map 'button2 - (make-modeline-command-wrapper 'widen)) - -(defvar modeline-narrowed-extent (make-extent nil nil) - "Extent covering the modeline-narrowed string.") -(set-extent-face modeline-narrowed-extent 'modeline-mousable) -(set-extent-keymap modeline-narrowed-extent modeline-narrowed-map) -(set-extent-property modeline-narrowed-extent 'help-echo - "button2 widens the buffer") - -(setq-default - modeline-format - (list - (purecopy "") - (cons modeline-modified-extent 'modeline-modified) - (cons modeline-buffer-id-extent 'modeline-buffer-identification) - (purecopy " ") - 'global-mode-string - (purecopy " %[(") - (cons modeline-minor-mode-extent (list "" 'mode-name 'minor-mode-alist)) - (cons modeline-narrowed-extent "%n") - 'modeline-process - (purecopy ")%]----") - (purecopy '(line-number-mode "L%l--")) - (purecopy '(column-number-mode "C%c--")) - (purecopy '(-3 . "%p")) - (purecopy "-%-"))) - -;;; Added for XEmacs 20.3. Provide wrapper for vc since it may not always be -;;; present, and its symbols are not visible this early in the dump if it -;;; is. - -(defun modeline-toggle-read-only () - "Change whether this buffer is visiting its file read-only. -With arg, set read-only iff arg is positive. -This function is designed to be called when the read-only indicator on the -modeline is clicked. It will call `vc-toggle-read-only' if available, -otherwise it will call the usual `toggle-read-only'." - (interactive) - (if (fboundp 'vc-toggle-read-only) - (vc-toggle-read-only) - (toggle-read-only))) - -;;; modeline.el ends here
--- a/lisp/prim/mouse.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1468 +0,0 @@ -;;; mouse.el --- window system-independent mouse support. -;; Keywords: hardware - -;; Copyright (C) 1988, 1992, 1993, 1994 Free Software Foundation, Inc. -;; Copyright (C) 1995 Tinker Systems -;; Copyright (C) 1995, 1996 Ben Wing. - -;; 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, 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: Not synched with FSF. Almost completely divergent. - -(provide 'mouse) - -(global-set-key 'button1 'mouse-track) -(global-set-key '(shift button1) 'mouse-track-adjust) -(global-set-key '(control button1) 'mouse-track-insert) -(global-set-key '(control shift button1) 'mouse-track-delete-and-insert) -(global-set-key '(meta button1) 'mouse-track-do-rectangle) - -;; enable drag regions (ograf@fga.de) -;; if button2 is dragged from within a region, this becomes a drop -(if (or (featurep 'offix) ;; do we have DnD support? - (featurep 'cde)) - (global-set-key 'button2 'mouse-drag-or-yank) - (global-set-key 'button2 'mouse-yank)) - -;; enable drops from OffiX (ograf@fga.de) -;; accept any button1,2,3 drop with `mouse-offix-drop' -(cond ((featurep 'offix) - (global-set-key 'drop1 'mouse-offix-drop) - (global-set-key 'drop2 'mouse-offix-drop) - (global-set-key 'drop3 'mouse-offix-drop))) - -(defcustom mouse-track-rectangle-p nil - "*If true, then dragging out a region with the mouse selects rectangles -instead of simple start/end regions." - :type 'boolean - :group 'mouse) - -(defcustom mouse-yank-at-point nil - "*If non-nil, the function `mouse-yank' will yank text at the cursor location. -Otherwise, the cursor will be moved to the location of the pointer click before -text is inserted." - :type 'boolean - :group 'mouse) - -(defvar mouse-yank-function 'mouse-consolidated-yank - "Function that is called upon by `mouse-yank' to actually insert text.") - -(defun mouse-consolidated-yank () - (interactive) - (case (device-type) - (x (x-yank-function)) - (tty (yank)) - (otherwise (yank)))) - - -(defun mouse-select () - "Select Emacs window the mouse is on." - (interactive "@")) - -(defun mouse-delete-window () - "Delete the Emacs window the mouse is on." - (interactive "@") - (delete-window)) - -(defun mouse-keep-one-window () - "Select Emacs window mouse is on, then kill all other Emacs windows." - (interactive "@") - (delete-other-windows)) - -(defun mouse-select-and-split () - "Select Emacs window mouse is on, then split it vertically in half." - (interactive "@") - (split-window-vertically nil)) - -(defun mouse-set-point (event) - "Select Emacs window mouse is on, and move point to mouse position." - (interactive "@e") - (let ((window (event-window event)) - (pos (event-point event)) - (close-pos (event-closest-point event))) - (or window (error "not in a window")) - (select-window window) - (if (and pos (> pos 0)) - ;; If the event was over a text char, it's easy. - (goto-char (max (min pos (point-max)) (point-min))) - (if (and close-pos (> close-pos 0)) - (goto-char (max (min close-pos (point-max)) (point-min))) - ;; When the event occurs outside of the frame directly to the - ;; left or right of a modeline, close-point is nil, but - ;; event-over-modeline is also nil. That will drop us to this - ;; point. So instead of erroring, just return nil. - nil)))) - -(defun mouse-yank (event) - "Paste text with the mouse. -If the variable `mouse-yank-at-point' is nil, then pasting occurs at the -location of the click; otherwise, pasting occurs at the current cursor -location." - (interactive "e") - (and (not mouse-yank-at-point) - (mouse-set-point event)) - (funcall mouse-yank-function)) - -(defun click-inside-extent-p (click extent) - "Returns non-nil if the button event is within the bounds of the primary -selection-extent, nil otherwise." - ;; stig@hackvan.com - (let ((ewin (event-window click)) - (epnt (event-point click))) - (and ewin - epnt - extent - (eq (window-buffer ewin) - (extent-object extent)) - (extent-start-position extent) - (> epnt (extent-start-position extent)) - (> (extent-end-position extent) epnt)))) - -(defun click-inside-selection-p (click) - (or (click-inside-extent-p click primary-selection-extent) - (click-inside-extent-p click zmacs-region-extent) - )) - -(defun point-inside-extent-p (extent) - "Returns non-nil if the point is within or just after the bounds of the -primary selection-extent, nil otherwise." - ;; stig@hackvan.com - (and extent - (eq (current-buffer) - (extent-object extent)) - (> (point) (extent-start-position extent)) - (>= (extent-end-position extent) (point)))) - -(defun point-inside-selection-p () - ;; by Stig@hackvan.com - (or (point-inside-extent-p primary-selection-extent) - (point-inside-extent-p zmacs-region-extent))) - -(defun mouse-drag-or-yank (event) - "Either drag or paste the current selection. If the variable - `mouse-yank-at-point' is non-nil, then moves the cursor to the location of - the click before pasting. - This functions has to be improved. Until now it is just a (working) test." - ;; by Oliver Graf <ograf@fga.de> - (interactive "e") - (if (click-inside-extent-p event zmacs-region-extent) - ;; okay, this is a drag - (cond ((featurep 'offix) - (offix-start-drag-region event - (extent-start-position zmacs-region-extent) - (extent-end-position zmacs-region-extent))) - ((featurep 'cde) - ;; should also work with CDE - (cde-start-drag - (extent-start-position zmacs-region-extent) - (extent-end-position zmacs-region-extent))) - (t ding)) - ;; no drag, call region-funct - (and (not mouse-yank-at-point) - (mouse-set-point event)) - (funcall mouse-yank-function)) - ) - -(defun mouse-offix-drop (event) - "Do something with an OffiX drop event. Inserts Text drops and - executes appropriate commands for specific drops. - Text drops follow the `mouse-yank-at-point' variable." - ;; by Oliver Graf <ograf@fga.de> - (interactive "e") - (let ((type (car (event-drag-and-drop-data event))) - (data (cadr (event-drag-and-drop-data event))) - (frame (event-channel event))) - (cond ((= type 2) - (let ((x pop-up-windows)) - (setq pop-up-windows nil) - (pop-to-buffer (find-file-noselect data) nil frame) - (make-frame-visible frame) - (setq pop-up-windows x))) - ((= type 3) - (let ((x pop-up-windows)) - (setq pop-up-windows nil) - (while (not (eq data ())) - (pop-to-buffer (find-file-noselect (car data)) nil frame) - (setq data (cdr data))) - (make-frame-visible frame) - (setq pop-up-windows x))) - ((= type 4) - (and (not mouse-yank-at-point) - (mouse-set-point event)) - (insert data)) - ((= type 5) (dired data)) - ((or (= type 6) (= type 7)) (dired data)) ;; this is junk - ((= type 8) (funcall browse-url-browser-function data)) - ((= type 9) - (let ((buf (generate-new-buffer "DndMIME"))) - (set-buffer buf) - (pop-to-buffer buf nil frame) - (insert data) - (make-frame-visible frame))) - (t ;; this is raw data or unknown stuff - (let ((buf (generate-new-buffer "DndRawData"))) - (set-buffer buf) - (pop-to-buffer buf nil frame) - (insert data) - (hexlify-buffer) - (make-frame-visible frame)))))) - -(defun mouse-eval-sexp (click force-window) - "Evaluate the sexp under the mouse. Usually, this is the last sexp before -the click, but if you click on a left paren, then it is the sexp beginning -with the paren that is evaluated. Also, since strings evaluate to themselves, -they're fed to re-search-forward and the matched region is highlighted until -the mouse button is released. - -Perhaps the most useful thing about this function is that the evaluation of -the expression which is clicked upon is relative not to the window where you -click, but to the current window and the current position of point. Thus, -you can use `mouse-eval-sexp' to interactively test code that acts upon a -buffer...something you cannot do with the standard `eval-last-sexp' function. -It's also fantastic for debugging regular expressions." - ;; by Stig@hackvan.com - (interactive "e\nP") - (let (exp val result-str) - (setq exp (save-window-excursion - (save-excursion - (mouse-set-point click) - (save-excursion - (or (looking-at "(") (forward-sexp -1)) - (read (point-marker)))))) - (cond ((stringp exp) - (if (setq val (re-search-forward exp nil t)) - (let* ((oo (make-extent (match-beginning 0) (match-end 0)))) - (set-extent-face oo 'highlight) - (set-extent-priority oo 1000) - ;; wait for button release... - (setq unread-command-event (next-command-event)) - (delete-extent oo)) - (message "Regex \"%s\" not found" exp) - (ding nil 'quiet))) - (t (setq val (if (fboundp 'eval-interactive) - (eval-interactive exp) - (eval exp))))) - (setq result-str (prin1-to-string val)) - ;; #### -- need better test - (if (and (not force-window) - (<= (length result-str) (window-width (selected-window)))) - (message "%s" result-str) - (with-output-to-temp-buffer "*Mouse-Eval*" - (condition-case nil - (pprint val) - (error (prin1 val)))) - ))) - -(defun mouse-line-length (event) - "Print the length of the line indicated by the pointer." - (interactive "@e") - (save-excursion - (mouse-set-point event) - (message "Line length: %d" (- (progn (end-of-line) (point)) - (progn (beginning-of-line) (point))))) - (sleep-for 1)) - -(defun mouse-set-mark (event) - "Select Emacs window mouse is on, and set mark at mouse position. -Display cursor at that position for a second." - (interactive "@e") - (let ((point-save (point))) - (unwind-protect - (progn (mouse-set-point event) - (push-mark nil t) - (sit-for 1)) - (goto-char point-save)))) - -(defun mouse-scroll (event) - "Scroll point to the mouse position." - (interactive "@e") - (save-excursion - (mouse-set-point event) - (recenter 0) - (scroll-right (event-x event)))) - -(defun mouse-del-char (event) - "Delete the char pointed to by the mouse." - (interactive "@e") - (save-excursion - (mouse-set-point event) - (delete-char 1 nil))) - -(defun mouse-kill-line (event) - "Kill the line pointed to by the mouse." - (interactive "@e") - (save-excursion - (mouse-set-point event) - (kill-line nil))) - -(defun mouse-bury-buffer (event) - "Bury the buffer pointed to by the mouse, thus selecting the next one." - (interactive "e") - (save-selected-window - (select-window (event-window event)) - (bury-buffer))) - -(defun mouse-unbury-buffer (event) - "Unbury and select the most recently buried buffer." - (interactive "e") - (save-selected-window - (select-window (event-window event)) - (let* ((bufs (buffer-list)) - (entry (1- (length bufs))) - val) - (while (not (setq val (nth entry bufs) - val (and (/= (aref (buffer-name val) 0) - ? ) - val))) - (setq entry (1- entry))) - (switch-to-buffer val)))) - -(defun narrow-window-to-region (m n) - "Narrow window to region between point and last mark" - (interactive "r") - (save-excursion - (save-restriction - (if (eq (selected-window) (next-window)) - (split-window)) - (goto-char m) - (recenter 0) - (if (eq (selected-window) - (if (zerop (minibuffer-depth)) - (next-window))) - () - (shrink-window (- (- (window-height) (count-lines m n)) 1)))))) - -(defun mouse-window-to-region (event) - "Narrow window to region between cursor and mouse pointer." - (interactive "@e") - (let ((point-save (point))) - (unwind-protect - (progn (mouse-set-point event) - (push-mark nil t) - (sit-for 1)) - (goto-char point-save) - (narrow-window-to-region (region-beginning) (region-end))))) - -(defun mouse-ignore () - "Don't do anything." - (interactive)) - - -;; -;; Commands for the scroll bar. -;; - -;; #### this stuff has never ever been used and should be junked. - -;; Vertical bar - -(defun mouse-scroll-down (nlines) - "Junk me, please." - (interactive "@p") - (scroll-down nlines)) - -(defun mouse-scroll-up (nlines) - "Junk me, please." - (interactive "@p") - (scroll-up nlines)) - -(defun mouse-scroll-down-full () - "Junk me, please." - (interactive "@") - (scroll-down nil)) - -(defun mouse-scroll-up-full () - "Junk me, please." - (interactive "@") - (scroll-up nil)) - -(defun mouse-scroll-move-cursor (nlines) - "Junk me, please." - (interactive "@p") - (move-to-window-line nlines)) - -(defun mouse-scroll-absolute (event) - "Junk me, please." - (interactive "@e") - (let* ((position (event-x event)) - (length (event-y event)) - (size (buffer-size)) - (scale-factor (max 1 (/ 8000000 size))) - (newpos (* (/ (* (/ size scale-factor) position) length) - scale-factor))) - (goto-char newpos) - (recenter '(4)))) - -;; These scroll while the invoking button is depressed. - -(defvar scrolled-lines 0) -(defvar scroll-speed 1) - -(defun incr-scroll-down (event) - "Junk me, please." - (interactive "@e") - (setq scrolled-lines 0) - (incremental-scroll scroll-speed)) - -(defun incr-scroll-up (event) - "Junk me, please." - (interactive "@e") - (setq scrolled-lines 0) - (incremental-scroll (- scroll-speed))) - -(defun incremental-scroll (n) - "Junk me, please." - (let ((down t)) - (while down - (sit-for mouse-track-scroll-delay) - (cond ((input-pending-p) - (let ((event (next-command-event))) - (if (or (button-press-event-p event) - (button-release-event-p event)) - (setq down nil)) - (dispatch-event event)))) - (setq scrolled-lines (1+ (* scroll-speed scrolled-lines))) - (scroll-down n)))) - -(defun incr-scroll-stop (event) - "Junk me, please." - (interactive "@e") - (setq scrolled-lines 0) - (sleep-for 1)) - - -(defun mouse-scroll-left (ncolumns) - "Junk me, please." - (interactive "@p") - (scroll-left ncolumns)) - -(defun mouse-scroll-right (ncolumns) - "Junk me, please." - (interactive "@p") - (scroll-right ncolumns)) - -(defun mouse-scroll-left-full () - "Junk me, please." - (interactive "@") - (scroll-left nil)) - -(defun mouse-scroll-right-full () - "Junk me, please." - (interactive "@") - (scroll-right nil)) - -(defun mouse-scroll-move-cursor-horizontally (ncolumns) - "Junk me, please." - (interactive "@p") - (move-to-column ncolumns)) - -(defun mouse-scroll-absolute-horizontally (event) - "Junk me, please." - (interactive "@e") - (set-window-hscroll (selected-window) 33)) - - - -;;; mouse/selection tracking -;;; generalized mouse-track - -(defvar default-mouse-track-normalize-point-function - 'default-mouse-track-normalize-point - "Function called to normalize position of point. -Called with two arguments: TYPE depends on the number of times that the -mouse has been clicked and is a member of `default-mouse-track-type-list', -FORWARDP determines the direction in which the point should be moved.") - -(defvar mouse-track-down-hook nil - "Function or functions called when the user presses the mouse. -This hook is invoked by `mouse-track'; thus, it will not be called -for any buttons with a different binding. The functions will be -called with two arguments: the button-press event and a click -count (see `mouse-track-click-hook'). - -If any function returns non-nil, the remaining functions will not be -called. - -Note that most applications should take action when the mouse is -released, not when it is pressed.'") - -(defvar mouse-track-drag-hook nil - "Function or functions called when the user drags the mouse. -This hook is invoked by `mouse-track'; thus, it will not be called -for any buttons with a different binding. The functions will be -called with three arguments: the mouse-motion event, a click -count (see `mouse-track-click-hook'), and whether the call to -this hook occurred as a result of a drag timeout (see -`mouse-track-scroll-delay'). - -If any function returns non-nil, the remaining functions will not be -called. - -Note that no calls to this function will be made until the user -initiates a drag (i.e. moves the mouse more than a certain -threshold in either the X or the Y direction, as defined by -`mouse-track-x-threshold' and `mouse-track-y-threshold'). - -See also `mouse-track-drag-up-hook'.") - -(defvar mouse-track-drag-up-hook nil - "Function or functions called when the user finishes a drag. -This hook is invoked by `mouse-track'; thus, it will not be called -for any buttons with a different binding. The functions will be -called with two arguments: the button-press event and a click -count (see `mouse-track-click-hook'). - -If any function returns non-nil, the remaining functions will not be -called. - -Note that this hook will not be invoked unless the user has -initiated a drag, i.e. moved the mouse more than a certain threshold -(see `mouse-track-drag-hook'). When this function is invoked, -`mouse-track-drag-hook' will have been invoked at least once. - -See also `mouse-track-click-hook'.") - -(defvar mouse-track-click-hook nil - "Function or functions called when the user clicks the mouse. -`Clicking' means pressing and releasing the mouse without having -initiated a drag (i.e. without having moved more than a certain -threshold -- see `mouse-track-drag-hook'). - -This hook is invoked by `mouse-track'; thus, it will not be called -for any buttons with a different binding. The functions will be -called with two arguments: the button-release event and a click -count, which specifies the number of times that the mouse has been -clicked in a series of clicks, each of which is separated by at most -`mouse-track-multi-click-time'. This can be used to implement actions -that are called on double clicks, triple clicks, etc. - -If any function returns non-nil, the remaining functions will not be -called. - -See also `mouse-track-drag-up-hook.") - -(defvar mouse-track-up-hook nil - "Function or functions called when the user releases the mouse. -This hook is invoked by `mouse-track'; thus, it will not be called -for any buttons with a different binding. The functions will be -called with two arguments: the button-release event and a click -count (see `mouse-track-click-hook'). - -For many applications, it is more appropriate to use one or both -of `mouse-track-click-hook' and `mouse-track-drag-up-hook'.") - -(defvar mouse-track-cleanup-hook nil - "Function or functions called when `mouse-track' terminates. -This hook will be called in all circumstances, even upon a -non-local exit out of `mouse-track', and so is useful for -doing cleanup work such as removing extents that may have -been created during the operation of `mouse-track'. - -Unlike all of the other mouse-track hooks, this is a \"normal\" -hook: the hook functions are called with no arguments, and -all hook functions are called regardless of their return -values.") - -(defcustom mouse-track-multi-click-time 400 - "*Maximum number of milliseconds allowed between clicks for a multi-click. -See `mouse-track-click-hook'." - :type 'integer - :group 'mouse) - -(defcustom mouse-track-scroll-delay 100 - "Maximum of milliseconds between calls to `mouse-track-drag-hook'. -If the user is dragging the mouse (i.e. the button is held down and -a drag has been initiated) and does not move the mouse for this many -milliseconds, the hook will be called with t as the value of the -WAS-TIMEOUT parameter. This can be used to implement scrolling -in a selection when the user drags the mouse out the window it -was in. - -A value of nil disables the timeout feature." - :type '(choice integer (const :tag "Disabled" nil)) - :group 'mouse) - -(defvar mouse-track-x-threshold '(face-width 'default) - "Minimum number of pixels in the X direction for a drag to be initiated. -If the mouse is moved more than either the X or Y threshold while the -button is held down (see also `mouse-track-y-threshold'), then a drag -is initiated; otherwise the gesture is considered to be a click. -See `mouse-track'. - -The value should be either a number of a form to be evaluated to -produce a number.") - -(defvar mouse-track-y-threshold '(face-height 'default) - "Minimum number of pixels in the Y direction for a drag to be initiated. -If the mouse is moved more than either the X or Y threshold while the -button is held down (see also `mouse-track-x-threshold'), then a drag -is initiated; otherwise the gesture is considered to be a click. -See `mouse-track'. - -The value should be either a number of a form to be evaluated to -produce a number.") - -;; these variables are private to mouse-track. -(defvar mouse-track-up-time nil) -(defvar mouse-track-up-x nil) -(defvar mouse-track-up-y nil) -(defvar mouse-track-timeout-id nil) -(defvar mouse-track-click-count nil) - -(defun mouse-track-set-timeout (event) - (if mouse-track-timeout-id - (disable-timeout mouse-track-timeout-id)) - (if mouse-track-scroll-delay - (setq mouse-track-timeout-id - (add-timeout (/ mouse-track-scroll-delay 1000.0) - 'mouse-track-scroll-undefined - (copy-event event))))) - -(defun mouse-track-run-hook (hook event &rest args) - ;; ugh, can't use run-special-hook-with-args because we - ;; have to get the value using symbol-value-in-buffer. - ;; Doing a save-excursion/set-buffer is wrong because - ;; the hook might want to change the buffer, but just - ;; doing a set-buffer is wrong because the hook might - ;; not want to change the buffer. - (let ((buffer (event-buffer event))) - (if mouse-grabbed-buffer (setq buffer mouse-grabbed-buffer)) - (if buffer - (let ((value (symbol-value-in-buffer hook buffer nil))) - (if (and (listp value) (not (eq (car value) 'lambda))) - (let (retval) - (while (and value - (not (setq retval (apply (car value) event args)))) - (setq value (cdr value))) - retval) - (apply value event args)))))) - -(defun mouse-track-scroll-undefined (random) - ;; the old implementation didn't actually define this function, - ;; and in normal use it won't ever be called because the timeout - ;; will either be removed before it fires or will be picked off - ;; with next-event and not dispatched. However, if you're - ;; attempting to debug a click-hook (which is pretty damn - ;; difficult to do), this function may get called. -) - -(defun mouse-track (event) - "Make a selection with the mouse. This should be bound to a mouse button. -The behavior of XEmacs during mouse selection is customizable using various -hooks and variables: see `mouse-track-click-hook', `mouse-track-drag-hook', -`mouse-track-drag-up-hook', `mouse-track-down-hook', `mouse-track-up-hook', -`mouse-track-cleanup-hook', `mouse-track-multi-click-time', -`mouse-track-scroll-delay', `mouse-track-x-threshold', and -`mouse-track-y-threshold'. - -Default handlers are provided to implement standard selecting/positioning -behavior. You can explicitly request this default behavior, and override -any custom-supplied handlers, by using the function `mouse-track-default' -instead of `mouse-track'. - -Default behavior is as follows: - -If you click-and-drag, the selection will be set to the region between the -point of the initial click and the point at which you release the button. -These positions need not be ordered. - -If you click-and-release without moving the mouse, then the point is moved -and the selection is disowned (there will be no selection owner). The mark -will be set to the previous position of point. - -If you double-click, the selection will extend by symbols instead of by -characters. If you triple-click, the selection will extend by lines. - -If you drag the mouse off the top or bottom of the window, you can select -pieces of text which are larger than the visible part of the buffer; the -buffer will scroll as necessary. - -The selected text becomes the current X Selection. The point will be left -at the position at which you released the button, and the mark will be left -at the initial click position." - (interactive "e") - (let ((mouse-down t) - (xthresh (eval mouse-track-x-threshold)) - (ythresh (eval mouse-track-y-threshold)) - (orig-x (event-x-pixel event)) - (orig-y (event-y-pixel event)) - (buffer (event-buffer event)) - (mouse-grabbed-buffer (event-buffer event)) - mouse-moved) - (if (or (not mouse-track-up-x) - (not mouse-track-up-y) - (not mouse-track-up-time) - (> (- (event-timestamp event) mouse-track-up-time) - mouse-track-multi-click-time) - (> (abs (- mouse-track-up-x orig-x)) xthresh) - (> (abs (- mouse-track-up-y orig-y)) ythresh)) - (setq mouse-track-click-count 1) - (setq mouse-track-click-count (1+ mouse-track-click-count))) - (if (not (event-window event)) - (error "Not over a window.")) - (mouse-track-run-hook 'mouse-track-down-hook - event mouse-track-click-count) - (unwind-protect - (while mouse-down - (setq event (next-event event)) - (cond ((motion-event-p event) - (if (and (not mouse-moved) - (or (> (abs (- (event-x-pixel event) orig-x)) - xthresh) - (> (abs (- (event-y-pixel event) orig-y)) - ythresh))) - (setq mouse-moved t)) - (if mouse-moved - (mouse-track-run-hook 'mouse-track-drag-hook - event mouse-track-click-count nil)) - (mouse-track-set-timeout event)) - ((and (timeout-event-p event) - (eq (event-function event) - 'mouse-track-scroll-undefined)) - (if mouse-moved - (mouse-track-run-hook 'mouse-track-drag-hook - (event-object event) mouse-track-click-count t)) - (mouse-track-set-timeout (event-object event))) - ((button-release-event-p event) - (setq mouse-track-up-time (event-timestamp event)) - (setq mouse-track-up-x (event-x-pixel event)) - (setq mouse-track-up-y (event-y-pixel event)) - (setq mouse-down nil) - (mouse-track-run-hook 'mouse-track-up-hook - event mouse-track-click-count) - (if mouse-moved - (mouse-track-run-hook 'mouse-track-drag-up-hook - event mouse-track-click-count) - (mouse-track-run-hook 'mouse-track-click-hook - event mouse-track-click-count))) - ((key-press-event-p event) - (error "Selection aborted")) - (t - (dispatch-event event)))) - ;; protected - (if mouse-track-timeout-id - (disable-timeout mouse-track-timeout-id)) - (setq mouse-track-timeout-id nil) - (and buffer - (save-excursion - (set-buffer buffer) - (run-hooks 'mouse-track-cleanup-hook)))))) - - -;;;;;;;;;;;; default handlers: new version of mouse-track - -(defvar default-mouse-track-type nil) -(defvar default-mouse-track-type-list '(char word line)) -(defvar default-mouse-track-window nil) -(defvar default-mouse-track-extent nil) -(defvar default-mouse-track-adjust nil) -(defvar default-mouse-track-min-anchor nil) -(defvar default-mouse-track-max-anchor nil) -(defvar default-mouse-track-result nil) -(defvar default-mouse-track-down-event nil) - -(defun default-mouse-track-set-point-in-window (event window) - (if (not (and (not (event-over-modeline-p event)) - (eq (event-window event) window) - (let ((p (event-closest-point event))) - (and p (pos-visible-in-window-p p window))))) - nil - (mouse-set-point event) - t)) - -(defun default-mouse-track-scroll-and-set-point (event window) - (select-window window) - (let ((edges (window-pixel-edges window)) - (row (event-y-pixel event)) - (height (face-height 'default))) - (cond ((< (abs (- row (nth 1 edges))) (abs (- row (nth 3 edges)))) - ;; closer to window's top than to bottom, so move up - (let ((delta (max 1 (/ (- (nth 1 edges) row) height)))) - (condition-case () (scroll-down delta) (error)) - (goto-char (window-start)))) - ((>= (point) (point-max))) - (t - ;; scroll by one line if over the modeline or a clipped line - (let ((delta (if (or (event-over-modeline-p event) - (< row (nth 3 edges))) - 1 - (+ (/ (- row (nth 3 edges)) height) 1))) - (close-pos (event-closest-point event))) - (condition-case () (scroll-up delta) (error)) - (if (and close-pos (pos-visible-in-window-p close-pos)) - (goto-char close-pos) - (goto-char (window-end)) - (vertical-motion delta) - ;; window-end reports the end of the clipped line, even if - ;; scroll-on-clipped-lines is t. compensate. - ;; (If window-end gets fixed this can be removed.) - (if (not (pos-visible-in-window-p (max (1- (point)) - (point-min)))) - (vertical-motion -1)) - (condition-case () (backward-char 1) - (error (end-of-line))))))))) - - -;; This remembers the last position at which the user clicked, for the -;; benefit of mouse-track-adjust (for example, button1; scroll until the -;; position of the click is off the frame; then Sh-button1 to select the -;; new region. -(defvar default-mouse-track-previous-point nil) - -(defun default-mouse-track-set-point (event window) - (if (default-mouse-track-set-point-in-window event window) - nil - (default-mouse-track-scroll-and-set-point event window))) - -(defsubst default-mouse-track-beginning-of-word (symbolp) - (let ((word-constituent (cond ((eq symbolp t) "\\w\\|\\s_\\|\\s'") - ((null symbolp) "\\w") - (t "[^ \t\n]"))) - (white-space "[ \t]")) - (cond ((bobp) nil) - ((looking-at word-constituent) - (backward-char) - (while (and (not (bobp)) (looking-at word-constituent)) - (backward-char)) - (if (or (not (bobp)) (not (looking-at word-constituent))) - (forward-char))) - ((looking-at white-space) - (backward-char) - (while (looking-at white-space) - (backward-char)) - (forward-char))))) - -(defun default-mouse-track-end-of-word (symbolp) - (let ((word-constituent (cond ((eq symbolp t) "\\w\\|\\s_\\|\\s'") - ((null symbolp) "\\w") - (t "[^ \t\n]"))) - (white-space "[ \t]")) - (cond ((looking-at word-constituent) ; word or symbol constituent - (while (looking-at word-constituent) - (forward-char))) - ((looking-at white-space) ; word or symbol constituent - (while (looking-at white-space) - (forward-char)))))) - -(defun default-mouse-track-normalize-point (type forwardp) - (cond ((eq type 'word) - ;; trap the beginning and end of buffer errors - (condition-case () - (progn - (setq type (char-syntax (char-after (point)))) - (if forwardp - (if (= type ?\() - (goto-char (scan-sexps (point) 1)) - (if (= type ?\)) - (forward-char 1) - (default-mouse-track-end-of-word t))) - (if (= type ?\)) - (goto-char (scan-sexps (1+ (point)) -1)) - (default-mouse-track-beginning-of-word t)))) - (error ()))) - ((eq type 'line) - (if forwardp (end-of-line) (beginning-of-line))) - ((eq type 'buffer) - (if forwardp (end-of-buffer) (beginning-of-buffer))))) - -(defun default-mouse-track-next-move (min-anchor max-anchor extent) - (let ((anchor (if (<= (point) min-anchor) max-anchor min-anchor))) - (funcall default-mouse-track-normalize-point-function - default-mouse-track-type (> (point) anchor)) - (if (consp extent) - (default-mouse-track-next-move-rect anchor (point) extent) - (if extent - (if (<= anchor (point)) - (set-extent-endpoints extent anchor (point)) - (set-extent-endpoints extent (point) anchor)))))) - -(defun default-mouse-track-next-move-rect (start end extents &optional pad-p) - (if (< end start) - (let ((tmp start)) (setq start end end tmp))) - (cond - ((= start end) ; never delete the last remaining extent - (mapcar 'delete-extent (cdr extents)) - (setcdr extents nil) - (set-extent-endpoints (car extents) start start)) - (t - (let ((indent-tabs-mode nil) ; if pad-p, don't use tabs - (rest extents) - left right last p) - (save-excursion - (save-restriction - (goto-char end) - (setq right (current-column)) - (goto-char start) - (setq left (current-column)) - (if (< right left) - (let ((tmp left)) - (setq left right right tmp) - (setq start (- start (- right left)) - end (+ end (- right left))))) - ;; End may have been set to a value greater than point-max if drag - ;; or movement extends to end of buffer, so reset it. - (setq end (min end (point-max))) - (beginning-of-line) - (narrow-to-region (point) end) - (goto-char start) - (while (and rest (not (eobp))) - (setq p (point)) - (move-to-column right pad-p) - (set-extent-endpoints (car rest) p (point)) - ;; this code used to look at the return value - ;; of forward-line, but that doesn't work because - ;; forward-line has bogus behavior: If you're on - ;; the last line of a buffer but not at the very - ;; end, forward-line will move you to the very - ;; end and return 0 instead of 1, like it should. - ;; the result was frequent infinite loops here, - ;; creating very large numbers of extents at - ;; the same position. There was an N^2 sorting - ;; algorithm in extents.c for extents at a - ;; particular position, and the result was very - ;; bad news. - (forward-line 1) - (if (not (eobp)) - (move-to-column left pad-p)) - (setq last rest - rest (cdr rest))) - (cond (rest - (mapcar 'delete-extent rest) - (setcdr last nil)) - ((not (eobp)) - (while (not (eobp)) - (setq p (point)) - (move-to-column right pad-p) - (let ((e (make-extent p (point)))) - (set-extent-face e (extent-face (car extents))) - (set-extent-priority e (extent-priority (car extents))) - (setcdr last (cons e nil)) - (setq last (cdr last))) - (forward-line 1) - (if (not (eobp)) - (move-to-column left pad-p)) - ))))) - )))) - -(defun default-mouse-track-has-selection-p (buffer) - (and (or (not (eq 'x (console-type (selected-console)))) - (x-selection-owner-p)) - (extent-live-p primary-selection-extent) - (not (extent-detached-p primary-selection-extent)) - (eq buffer (extent-object primary-selection-extent)))) - -(defun default-mouse-track-anchor (adjust previous-point) - (if adjust - (if (default-mouse-track-has-selection-p (current-buffer)) - (let ((start (extent-start-position primary-selection-extent)) - (end (extent-end-position primary-selection-extent))) - (cond ((< (point) start) end) - ((> (point) end) start) - ((> (- (point) start) (- end (point))) start) - (t end))) - previous-point) - (point))) - -(defun default-mouse-track-maybe-own-selection (pair type) - (let ((start (car pair)) - (end (cdr pair))) - (or (= start end) (push-mark (if (= (point) start) end start))) - (cond (zmacs-regions - (if (= start end) - nil - ;; #### UTTER KLUDGE. - ;; If we don't have this sit-for here, then triple-clicking - ;; will result in the line not being highlighted as it - ;; should. What appears to be happening is this: - ;; - ;; -- each time the button goes down, the selection is - ;; disowned (see comment "remove the existing selection - ;; to unclutter the display", below). - ;; -- this causes a SelectionClear event to be sent to - ;; XEmacs. - ;; -- each time the button goes up except the first, the - ;; selection is owned again. - ;; -- later, XEmacs processes the SelectionClear event. - ;; The selection code attempts to keep track of the - ;; time that it last asserted the selection, and - ;; compare it to the time of the SelectionClear event, - ;; to see if it's a bogus notification or not (as - ;; is the case here). However, for some unknown - ;; reason this doesn't work in the triple-clicking - ;; case, and the selection code bogusly thinks this - ;; SelectionClear event is the real thing. - ;; -- putting the sit-for in causes the pending - ;; SelectionClear events to get processed before - ;; the selection is reasserted, so everything works - ;; out OK. - ;; - ;; Presumably(?) this means there is a weird timing bug - ;; in the selection code, but there's not a chance in hell - ;; that I have the patience to track it down. Blame the - ;; designers of X for fucking everything up so badly. - ;; - ;; This was originally a sit-for 0 but that wasn't - ;; sufficient to make things work. Even this isn't - ;; 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. - ;; - (sit-for 0.15 t) - (zmacs-activate-region))) - ((eq 'x (console-type (selected-console))) - (if (= start end) - (x-disown-selection type) - (if (consp default-mouse-track-extent) - ;; own the rectangular region - ;; this is a hack - (let ((r default-mouse-track-extent)) - (save-excursion - (set-buffer (get-buffer-create " *rect yank temp buf*")) - (while r - (insert (extent-string (car r)) "\n") - (setq r (cdr r))) - (x-own-selection (buffer-substring (point-min) (point-max))) - (kill-buffer (current-buffer)))) - (x-own-selection (cons (set-marker (make-marker) start) - (set-marker (make-marker) end)) - type))))) - (if (and (eq 'x (console-type (selected-console))) - (not (= start end))) - ;; I guess cutbuffers should do something with rectangles too. - ;; does anybody use them? - (x-store-cutbuffer (buffer-substring start end))))) - -(defun default-mouse-track-deal-with-down-event (click-count) - (let ((event default-mouse-track-down-event)) - (if (null event) nil - (select-frame (event-frame event)) - (let ((adjust default-mouse-track-adjust) - ;; ####When you click on the splash-screen, - ;; event-{closest-,}point can be out of bounds. Should - ;; event-closest-point really be allowed to return a bad - ;; position like that? Maybe pixel_to_glyph_translation - ;; needs to invalidate its cache when the buffer changes. - ;; -dkindred@cs.cmu.edu - (close-pos (save-excursion - (set-buffer (event-buffer event)) - (let ((p (event-closest-point event))) - (and p (min (max p (point-min)) (point-max)))))) - extent previous-point) - - (if (not (event-window event)) - (error "not over window?")) - (setq default-mouse-track-type - (nth (mod (1- click-count) - (length default-mouse-track-type-list)) - default-mouse-track-type-list)) - (setq default-mouse-track-window (event-window event)) - ;; Note that the extent used here is NOT the extent which - ;; ends up as the value of zmacs-region-extent - this one is used - ;; just during mouse-dragging. - (setq default-mouse-track-extent - (make-extent close-pos close-pos (event-buffer event))) - (setq extent default-mouse-track-extent) - (set-extent-face extent 'zmacs-region) - ;; While the selection is being dragged out, give the selection extent - ;; slightly higher priority than any mouse-highlighted extent, so that - ;; the exact endpoints of the selection will be visible while the mouse - ;; is down. Normally, the selection and mouse highlighting have the - ;; same priority, so that conflicts between the two of them are - ;; resolved by the usual size-and-endpoint-comparison method. - (set-extent-priority extent (1+ mouse-highlight-priority)) - (if mouse-track-rectangle-p - (setq default-mouse-track-extent - (list default-mouse-track-extent))) - - (setq previous-point - (if (and adjust - (markerp default-mouse-track-previous-point) - (eq (current-buffer) - (marker-buffer default-mouse-track-previous-point))) - (marker-position default-mouse-track-previous-point) - (point))) - (default-mouse-track-set-point event default-mouse-track-window) - (if (not adjust) - (if (markerp default-mouse-track-previous-point) - (set-marker default-mouse-track-previous-point (point)) - (setq default-mouse-track-previous-point (point-marker)))) - ;; - ;; adjust point to a word or line boundary if appropriate - (let ((anchor (default-mouse-track-anchor adjust previous-point))) - (setq default-mouse-track-min-anchor - (save-excursion (goto-char anchor) - (funcall - default-mouse-track-normalize-point-function - default-mouse-track-type nil) - (point))) - (setq default-mouse-track-max-anchor - (save-excursion (goto-char anchor) - (funcall - default-mouse-track-normalize-point-function - default-mouse-track-type t) - (point)))) - ;; - ;; remove the existing selection to unclutter the display - (if (not adjust) - (cond (zmacs-regions - (zmacs-deactivate-region)) - ((eq 'x (console-type (selected-console))) - (x-disown-selection))))) - (setq default-mouse-track-down-event nil)))) - -(defun default-mouse-track-down-hook (event click-count) - (setq default-mouse-track-down-event (copy-event event)) - nil) - -(defun default-mouse-track-cleanup-extents-hook () - (remove-hook 'pre-command-hook 'default-mouse-track-cleanup-extents-hook) - (let ((extent default-mouse-track-extent)) - (if (consp extent) ; rectangle-p - (mapcar 'delete-extent extent) - (if extent - (delete-extent extent))))) - -(defun default-mouse-track-cleanup-hook () - (if zmacs-regions - (funcall 'default-mouse-track-cleanup-extents-hook) - (let ((extent default-mouse-track-extent) - (func #'(lambda (e) - (and (extent-live-p e) - (set-extent-face e 'primary-selection))))) - (add-hook 'pre-command-hook 'default-mouse-track-cleanup-extents-hook) - (if (consp extent) ; rectangle-p - (mapcar func extent) - (if extent - (funcall func extent)))))) - -(defun default-mouse-track-cleanup-extent () - (let ((dead-func - (function (lambda (x) - (or (not (extent-live-p x)) - (extent-detached-p x))))) - (extent default-mouse-track-extent)) - (if (consp extent) - (if (funcall dead-func extent) - (let (newval) - (mapcar (function (lambda (x) - (if (not (funcall dead-func x)) - (setq newval (cons x newval))))) - extent) - (setq default-mouse-track-extent (nreverse newval)))) - (if (funcall dead-func extent) - (setq default-mouse-track-extent nil))))) - -(defun default-mouse-track-drag-hook (event click-count was-timeout) - (default-mouse-track-deal-with-down-event click-count) - (default-mouse-track-set-point event default-mouse-track-window) - (default-mouse-track-cleanup-extent) - (default-mouse-track-next-move default-mouse-track-min-anchor - default-mouse-track-max-anchor - default-mouse-track-extent) - t) - -(defun default-mouse-track-return-dragged-selection (event) - (default-mouse-track-cleanup-extent) - (let ((extent default-mouse-track-extent) - result) - (default-mouse-track-set-point-in-window event default-mouse-track-window) - (default-mouse-track-next-move default-mouse-track-min-anchor - default-mouse-track-max-anchor - extent) - (cond ((consp extent) ; rectangle-p - (let ((first (car extent)) - (last (car (setq extent (nreverse extent))))) - ;; nreverse is destructive so we need to reset this - (setq default-mouse-track-extent extent) - (setq result (cons (extent-start-position first) - (extent-end-position last))) - ;; kludge to fix up region when dragging backwards... - (if (and (/= (point) (extent-start-position first)) - (/= (point) (extent-end-position last)) - (= (point) (extent-end-position first))) - (goto-char (car result))))) - (extent - (setq result (cons (extent-start-position extent) - (extent-end-position extent))))) - ;; Minor kludge: if we're selecting in line-mode, include the - ;; final newline. It's hard to do this in *-normalize-point. - (if (and result (eq default-mouse-track-type 'line)) - (let ((end-p (= (point) (cdr result)))) - (goto-char (cdr result)) - (if (not (eobp)) - (setcdr result (1+ (cdr result)))) - (goto-char (if end-p (cdr result) (car result))))) -;;; ;; Minor kludge sub 2. If in char mode, and we drag the -;;; ;; mouse past EOL, include the newline. -;;; ;; -;;; ;; Major problem: can't easily distinguish between being -;;; ;; just past the last char on a line, and well past it, -;;; ;; to determine whether or not to include it in the region -;;; ;; -;;; (if nil ; (eq default-mouse-track-type 'char) -;;; (let ((after-end-p (and (not (eobp)) -;;; (eolp) -;;; (> (point) (car result))))) -;;; (if after-end-p -;;; (progn -;;; (setcdr result (1+ (cdr result))) -;;; (goto-char (cdr result)))))) - result)) - -(defun default-mouse-track-drag-up-hook (event click-count) - (let ((result (default-mouse-track-return-dragged-selection event))) - (if result - (default-mouse-track-maybe-own-selection result 'PRIMARY))) - t) - -(defun default-mouse-track-click-hook (event click-count) - (default-mouse-track-drag-hook event click-count nil) - (default-mouse-track-drag-up-hook event click-count) - t) - -(add-hook 'mouse-track-down-hook 'default-mouse-track-down-hook) -(add-hook 'mouse-track-drag-hook 'default-mouse-track-drag-hook) -(add-hook 'mouse-track-drag-up-hook 'default-mouse-track-drag-up-hook) -(add-hook 'mouse-track-click-hook 'default-mouse-track-click-hook) -(add-hook 'mouse-track-cleanup-hook 'default-mouse-track-cleanup-hook) - - -;;;;;;;;;;;; other mouse-track stuff (mostly associated with the -;;;;;;;;;;;; default handlers) - -(defun mouse-track-default (event) - "Invoke `mouse-track' with only the default handlers active." - (interactive "e") - (let ((mouse-track-down-hook 'default-mouse-track-down-hook) - (mouse-track-drag-hook 'default-mouse-track-drag-hook) - (mouse-track-drag-up-hook 'default-mouse-track-drag-up-hook) - (mouse-track-click-hook 'default-mouse-track-click-hook) - (mouse-track-cleanup-hook 'default-mouse-track-cleanup-hook)) - (mouse-track event))) - -(defun mouse-track-do-rectangle (event) - "Like `mouse-track' but selects rectangles instead of regions." - (interactive "e") - (let ((mouse-track-rectangle-p t)) - (mouse-track event))) - -(defun mouse-track-adjust (event) - "Extend the existing selection. This should be bound to a mouse button. -The selection will be enlarged or shrunk so that the point of the mouse -click is one of its endpoints. This function in fact behaves fairly -similarly to `mouse-track', but begins by extending the existing selection -(or creating a new selection from the previous text cursor position to -the current mouse position) instead of creating a new, empty selection. - -The mouse-track handlers are run from this command just like from -`mouse-track'. Therefore, do not call this command from a mouse-track -handler!" - (interactive "e") - (let ((default-mouse-track-adjust t)) - (mouse-track event))) - -(defun mouse-track-adjust-default (event) - "Extend the existing selection, using only the default handlers. -This is just like `mouse-track-adjust' but will override any -custom mouse-track handlers that the user may have installed." - (interactive "e") - (let ((default-mouse-track-adjust t)) - (mouse-track-default event))) - -(defvar mouse-track-insert-selected-region nil) - -(defun mouse-track-insert-drag-up-hook (event click-count) - (setq mouse-track-insert-selected-region - (default-mouse-track-return-dragged-selection event))) - -(defun mouse-track-insert (event &optional delete) - "Make a selection with the mouse and insert it at point. -This is exactly the same as the `mouse-track' command on \\[mouse-track], -except that point is not moved; the selected text is immediately inserted -after being selected\; and the selection is immediately disowned afterwards." - (interactive "*e") - (setq mouse-track-insert-selected-region nil) - (let ((mouse-track-drag-up-hook 'mouse-track-insert-drag-up-hook) - (mouse-track-click-hook 'mouse-track-insert-click-hook) - s) - (save-excursion - (save-window-excursion - (mouse-track event) - (if (consp mouse-track-insert-selected-region) - (let ((pair mouse-track-insert-selected-region)) - (setq s (prog1 - (buffer-substring (car pair) (cdr pair)) - (if delete - (kill-region (car pair) (cdr pair))))))))) - (or (null s) (equal s "") (insert s)))) - -(defun mouse-track-insert-click-hook (event click-count) - (default-mouse-track-drag-hook event click-count nil) - (mouse-track-insert-drag-up-hook event click-count) - t) - -(defun mouse-track-delete-and-insert (event) - "Make a selection with the mouse and insert it at point. -This is exactly the same as the `mouse-track' command on \\[mouse-track], -except that point is not moved; the selected text is immediately inserted -after being selected\; and the text of the selection is deleted." - (interactive "*e") - (mouse-track-insert event t)) - -;;;;;;;;;;;;;;;;;;;;;;;; - - -(defvar inhibit-help-echo nil - "Inhibits display of `help-echo' extent properties in the minibuffer.") -(defvar last-help-echo-object nil) -(defvar help-echo-owns-message nil) - -(defun clear-help-echo (&optional ignored-frame) - (if help-echo-owns-message - (progn - (setq help-echo-owns-message nil - last-help-echo-object nil) - (clear-message 'help-echo)))) - -(defun show-help-echo (mess) - ;; (clear-help-echo) - (setq help-echo-owns-message t) - (display-message 'help-echo mess)) - -(add-hook 'mouse-leave-frame-hook 'clear-help-echo) - -(defun default-mouse-motion-handler (event) - "For use as the value of `mouse-motion-handler'. -This implements the various pointer-shape variables, -as well as extent highlighting, help-echo, toolbar up/down, -and `mode-motion-hook'." - (let* ((frame (or (event-frame event) (selected-frame))) - (window (event-window event)) - (buffer (event-buffer event)) - (point (and buffer (event-point event))) - (modeline-point (and buffer (event-modeline-position event))) - (extent (and point (extent-at point buffer 'mouse-face))) - (glyph1 (event-glyph-extent event)) - (glyph (and glyph1 (extent-live-p glyph1) glyph1)) - (user-pointer1 (or (and glyph (extent-property glyph 'pointer)) - (and point - (condition-case nil - (extent-at point buffer 'pointer) - (error nil))) - (and modeline-point - (condition-case nil - (extent-at modeline-point - (symbol-value-in-buffer - 'generated-modeline-string - buffer) 'pointer))))) - (user-pointer (and user-pointer1 (extent-live-p user-pointer1) - (extent-property user-pointer1 'pointer))) - (button (event-toolbar-button event)) - (help (or (and glyph (extent-property glyph 'help-echo) glyph) - (and button (not (null (toolbar-button-help-string button))) - button) - (and point - (condition-case nil - (extent-at point buffer 'help-echo) - (error nil))) - (and modeline-point - (condition-case nil - (extent-at modeline-point - (symbol-value-in-buffer - 'generated-modeline-string - buffer) 'help-echo))))) - ;; vars is a list of glyph variables to check for a pointer - ;; value. - (vars (cond - ;; Checking if button is non-nil is not sufficent - ;; since the pointer could be over a blank portion - ;; of the toolbar. - ((event-over-toolbar-p event) - '(toolbar-pointer-glyph nontext-pointer-glyph - text-pointer-glyph)) - ((or extent glyph) - '(selection-pointer-glyph text-pointer-glyph)) - ((event-over-modeline-p event) - '(modeline-pointer-glyph nontext-pointer-glyph - text-pointer-glyph)) - (point '(text-pointer-glyph)) - (buffer '(nontext-pointer-glyph text-pointer-glyph)) - (t '(modeline-pointer-glyph nontext-pointer-glyph - text-pointer-glyph)))) - pointer) - (if (and user-pointer (glyphp user-pointer)) - (setq vars (cons 'user-pointer vars))) - (while (and vars (not (pointer-image-instance-p pointer))) - (setq pointer (glyph-image-instance (symbol-value (car vars)) - (or window frame)) - vars (cdr vars))) - - (if (pointer-image-instance-p pointer) - (set-frame-pointer frame pointer)) - - ;; If last-pressed-toolbar-button is not nil, then check and see - ;; if we have moved to a new button and adjust the down flags - ;; accordingly. - (if (and (featurep 'toolbar) toolbar-active) - (if (not (eq last-pressed-toolbar-button button)) - (progn - (release-previous-toolbar-button event) - (and button (press-toolbar-button event))))) - - (cond (extent (highlight-extent extent t)) - (glyph (highlight-extent glyph t)) - (t (highlight-extent nil nil))) - (cond ((extentp help) - (or inhibit-help-echo - (eq help last-help-echo-object) ;save some time - (let ((hprop (extent-property help 'help-echo))) - (setq last-help-echo-object help) - (or (stringp hprop) - (setq hprop (funcall hprop help))) - (and hprop (show-help-echo hprop))))) - ((and (featurep 'toolbar) - (toolbar-button-p help) - (toolbar-button-enabled-p help)) - (or (not toolbar-help-enabled) - (eq help last-help-echo-object) ;save some time - (let ((hstring (toolbar-button-help-string button))) - (setq last-help-echo-object help) - (or (stringp hstring) - (setq hstring (funcall hstring help))) - (show-help-echo hstring)))) - (last-help-echo-object - (clear-help-echo))) - (if mouse-grabbed-buffer (setq buffer mouse-grabbed-buffer)) - (if (and buffer (symbol-value-in-buffer 'mode-motion-hook buffer nil)) - (save-window-excursion - (set-buffer buffer) - (run-hook-with-args 'mode-motion-hook event) - - ;; If the mode-motion-hook created a highlightable extent around - ;; the mouse-point, highlight it right away. Otherwise it wouldn't - ;; be highlighted until the *next* motion event came in. - (if (and point - (null extent) - (setq extent (extent-at point - (event-buffer event) ; not buffer - 'mouse-face))) - (highlight-extent extent t))))) - nil) - -(setq mouse-motion-handler 'default-mouse-motion-handler)
--- a/lisp/prim/objects.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,143 +0,0 @@ -;;; objects.el --- Lisp interface to C window-system objects -;; Keywords: faces internal - -;; Copyright (C) 1994 Board of Trustees, University of Illinois -;; Copyright (C) 1995 Ben Wing - -;; Author: Chuck Thompson <cthomp@cs.uiuc.edu>, -;; Ben Wing <wing@666.com> - -;; 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, 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: Not in FSF. - -(defun ws-object-property-1 (function object domain &optional matchspec) - (let ((instance (if matchspec - (specifier-matching-instance object matchspec domain) - (specifier-instance object domain)))) - (and instance (funcall function instance)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; font specifiers - -(defun make-font-specifier (spec-list) - "Create a new `font' specifier object with the given specification list. -SPEC-LIST can be a list of specifications (each of which is a cons of a -locale and a list of instantiators), a single instantiator, or a list -of instantiators. See `make-specifier' for more information about -specifiers." - (make-specifier-and-init 'font spec-list)) - -(defun font-name (font &optional domain charset) - "Return the name of the FONT in the specified DOMAIN, if any. -FONT should be a font specifier object and DOMAIN is normally a window -and defaults to the selected window if omitted. This is equivalent -to using `specifier-instance' and applying `font-instance-name' to -the result. See `make-specifier' for more information about specifiers." - (ws-object-property-1 'font-instance-name font domain charset)) - -(defun font-ascent (font &optional domain charset) - "Return the ascent of the FONT in the specified DOMAIN, if any. -FONT should be a font specifier object and DOMAIN is normally a window -and defaults to the selected window if omitted. This is equivalent -to using `specifier-instance' and applying `font-instance-ascent' to -the result. See `make-specifier' for more information about specifiers." - (ws-object-property-1 'font-instance-ascent font domain charset)) - -(defun font-descent (font &optional domain charset) - "Return the descent of the FONT in the specified DOMAIN, if any. -FONT should be a font specifier object and DOMAIN is normally a window -and defaults to the selected window if omitted. This is equivalent -to using `specifier-instance' and applying `font-instance-descent' to -the result. See `make-specifier' for more information about specifiers." - (ws-object-property-1 'font-instance-descent font domain charset)) - -(defun font-width (font &optional domain charset) - "Return the width of the FONT in the specified DOMAIN, if any. -FONT should be a font specifier object and DOMAIN is normally a window -and defaults to the selected window if omitted. This is equivalent -to using `specifier-instance' and applying `font-instance-width' to -the result. See `make-specifier' for more information about specifiers." - (ws-object-property-1 'font-instance-width font domain charset)) - -(defun font-height (font &optional domain charset) - "Return the height of the FONT in the specified DOMAIN, if any. -FONT should be a font specifier object and DOMAIN is normally a window -and defaults to the selected window if omitted. This is equivalent -to using `specifier-instance' and applying `font-instance-height' to -the result. See `make-specifier' for more information about specifiers." - (ws-object-property-1 'font-instance-height font domain charset)) - -(defun font-proportional-p (font &optional domain charset) - "Return whether FONT is proportional in the specified DOMAIN, if known. -FONT should be a font specifier object and DOMAIN is normally a window -and defaults to the selected window if omitted. This is equivalent -to using `specifier-instance' and applying `font-instance-proportional-p' to -the result. See `make-specifier' for more information about specifiers." - (ws-object-property-1 'font-instance-proportional-p font domain charset)) - -(defun font-properties (font &optional domain charset) - "Return the properties of the FONT in the specified DOMAIN, if any. -FONT should be a font specifier object and DOMAIN is normally a window -and defaults to the selected window if omitted. This is equivalent -to using `specifier-instance' and applying `font-instance-properties' -to the result. See `make-specifier' for more information about specifiers." - (ws-object-property-1 'font-instance-properties font domain charset)) - -(defun font-truename (font &optional domain charset) - "Return the truename of the FONT in the specified DOMAIN, if any. -FONT should be a font specifier object and DOMAIN is normally a window -and defaults to the selected window if omitted. This is equivalent -to using `specifier-instance' and applying `font-instance-truename' -to the result. See `make-specifier' for more information about specifiers." - (ws-object-property-1 'font-instance-truename font domain charset)) - -(defun font-instance-height (font-instance) - "Return the height in pixels of FONT-INSTANCE. -The returned value is the maximum height for all characters in the font,\n\ -and is equivalent to the sum of the font instance's ascent and descent." - (+ (font-instance-ascent font-instance) - (font-instance-descent font-instance))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; color specifiers - -(defun make-color-specifier (spec-list) - "Create a new `color' specifier object with the given specification list. -SPEC-LIST can be a list of specifications (each of which is a cons of a -locale and a list of instantiators), a single instantiator, or a list -of instantiators. See `make-specifier' for a detailed description of -how specifiers work." - (make-specifier-and-init 'color spec-list)) - -(defun color-name (color &optional domain) - "Return the name of the COLOR in the specified DOMAIN, if any. -COLOR should be a color specifier object and DOMAIN is normally a window -and defaults to the selected window if omitted. This is equivalent -to using `specifier-instance' and applying `color-instance-name' to -the result. See `make-specifier' for more information about specifiers." - (ws-object-property-1 'color-instance-name color domain)) - -(defun color-rgb-components (color &optional domain) - "Return the RGB components of the COLOR in the specified DOMAIN, if any. -COLOR should be a color specifier object and DOMAIN is normally a window -and defaults to the selected window if omitted. This is equivalent -to using `specifier-instance' and applying `color-instance-rgb-components' -to the result. See `make-specifier' for more information about specifiers." - (ws-object-property-1 'color-instance-rgb-components color domain)) - -;;; objects.el ends here. -
--- a/lisp/prim/obsolete.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,694 +0,0 @@ -;;; obsolete.el --- obsoleteness support. - -;;;; Copyright (C) 1985-1994 Free Software Foundation, Inc. -;;;; Copyright (C) 1994, 1995 Amdahl Corporation. -;;;; Copyright (C) 1995 Sun Microsystems. - -;; Maintainer: XEmacs -;; Keywords: internal - -;; 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, 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; The obsoleteness support used to be scattered throughout various -;;; source files. We put the stuff in one place to remove the junkiness -;;; from other source files and to facilitate creating/updating things -;;; like sysdep.el. - -;;; Synched up with: Not in FSF. - -(defsubst define-obsolete-function-alias (oldfun newfun) - "Define OLDFUN as an obsolete alias for function NEWFUN. -This makes calling OLDFUN equivalent to calling NEWFUN and marks OLDFUN -as obsolete." - (define-function oldfun newfun) - (make-obsolete oldfun newfun)) - -(defsubst define-compatible-function-alias (oldfun newfun) - "Define OLDFUN as a compatible alias for function NEWFUN. -This makes calling OLDFUN equivalent to calling NEWFUN and marks OLDFUN -as provided for compatibility only." - (define-function oldfun newfun) - (make-compatible oldfun newfun)) - -(defsubst define-obsolete-variable-alias (oldvar newvar) - "Define OLDVAR as an obsolete alias for variable NEWVAR. -This makes referencing or setting OLDVAR equivalent to referencing or -setting NEWVAR and marks OLDVAR as obsolete. -If OLDVAR was bound and NEWVAR was not, Set NEWVAR to OLDVAR. - -Note: Use this before any other references (defvar/defcustom) to NEWVAR" - (let ((needs-setting (and (boundp oldvar) (not (boundp newvar)))) - (value (and (boundp oldvar) (symbol-value oldvar)))) - (defvaralias oldvar newvar) - (make-obsolete-variable oldvar newvar) - (and needs-setting (set newvar value)))) - -(defsubst define-compatible-variable-alias (oldvar newvar) - "Define OLDVAR as a compatible alias for variable NEWVAR. -This makes referencing or setting OLDVAR equivalent to referencing or -setting NEWVAR and marks OLDVAR as provided for compatibility only." - (defvaralias oldvar newvar) - (make-compatible-variable oldvar newvar)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;; device stuff - -(make-compatible-variable 'window-system "use (console-type)") -(make-obsolete-variable 'meta-flag - "use the `set-input-mode' function instead.") - -(defun x-display-color-p (&optional device) - "Returns non-nil if DEVICE is a color device." - (eq 'color (device-class device))) -(make-compatible 'x-display-color-p 'device-class) - -(define-function 'x-color-display-p 'x-display-color-p) -(make-compatible 'x-display-color-p 'device-class) - -(defun x-display-grayscale-p (&optional device) - "Returns non-nil if DEVICE is a grayscale device." - (eq 'grayscale (device-class device))) -(make-compatible 'x-display-grayscale-p 'device-class) - -(define-function 'x-grayscale-display-p 'x-display-grayscale-p) -(make-compatible 'x-display-grayscale-p 'device-class) - -(define-compatible-function-alias 'x-display-pixel-width 'device-pixel-width) -(define-compatible-function-alias 'x-display-pixel-height - 'device-pixel-height) -(define-compatible-function-alias 'x-display-planes 'device-bitplanes) -(define-compatible-function-alias 'x-display-color-cells 'device-color-cells) - -(define-obsolete-function-alias 'baud-rate 'device-baud-rate) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;; events - -(define-obsolete-function-alias 'menu-event-p 'misc-user-event-p) -(make-obsolete-variable 'unread-command-char 'unread-command-events) -(make-obsolete 'sleep-for-millisecs "use sleep-for with a float") - -;;;;;;;;;;;;;;;;;;;;;;;;;;;; extents - -(defun extent-data (extent) - "Obsolete. Returns the `data' property of the given extent." - (extent-property extent 'data)) -(make-obsolete 'set-window-dot 'set-window-point) - -(defun set-extent-data (extent data) - "Obsolete. Sets the `data' property of the given extent." - (set-extent-property extent 'data data)) -(make-obsolete 'set-extent-data 'set-extent-property) - -(define-obsolete-function-alias 'extent-buffer 'extent-object) - -(defun set-extent-attribute (extent attr &optional clearp) - "" ;; obsoleteness info will be displayed, so no need for anything more. - (cond ((eq attr 'write-protected) - (set-extent-property extent 'read-only t)) - ((eq attr 'unhighlight) - (set-extent-property extent 'mouse-face nil)) - ((eq attr 'writable) - (set-extent-property extent 'read-only nil)) - ((eq attr 'visible) - (set-extent-property extent 'invisible nil)) - (t - (set-extent-property extent attr t)))) -(make-obsolete 'set-extent-attribute 'set-extent-property) - -(defun extent-glyph (extent) - "" ;; obsoleteness info will be displayed, so no need for anything more. - (or (extent-begin-glyph extent) - (extent-end-glyph extent))) -(make-obsolete 'extent-glyph - "use `extent-begin-glyph' or `extent-end-glyph' instead.") - -(defun extent-layout (extent) - "" ;; obsoleteness info will be displayed, so no need for anything more. - (extent-begin-glyph-layout extent)) -(make-obsolete 'extent-layout - "use `extent-begin-glyph-layout' or `extent-end-glyph-layout' instead.") - -(defun set-extent-layout (extent layout) - "" ;; obsoleteness info will be displayed, so no need for anything more. - (set-extent-begin-glyph-layout extent layout)) -(make-obsolete 'set-extent-layout - "use `set-extent-begin-glyph-layout' or `set-extent-end-glyph-layout' instead.") - -;;;;;;;;;;;;;;;;;;;;;;;;;;;; frames - -(define-obsolete-variable-alias 'select-screen-hook 'select-frame-hook) -(define-obsolete-variable-alias 'deselect-screen-hook 'deselect-frame-hook) -(define-obsolete-variable-alias 'auto-raise-screen 'auto-raise-frame) -(define-obsolete-variable-alias 'auto-lower-screen 'auto-lower-frame) -(define-obsolete-variable-alias 'get-screen-for-buffer-default-screen-name - 'get-frame-for-buffer-default-frame-name) - -(define-obsolete-function-alias 'buffer-dedicated-screen - 'buffer-dedicated-frame) -(define-obsolete-function-alias 'deiconify-screen 'deiconify-frame) -(define-obsolete-function-alias 'delete-screen 'delete-frame) -(define-obsolete-function-alias 'event-screen 'event-frame) -(define-obsolete-function-alias 'find-file-other-screen 'find-file-other-frame) -(define-obsolete-function-alias 'find-file-read-only-other-screen - 'find-file-read-only-other-frame) -(define-obsolete-function-alias 'live-screen-p 'frame-live-p) -(define-obsolete-function-alias 'screen-height 'frame-height) -(define-obsolete-function-alias 'screen-iconified-p 'frame-iconified-p) -(define-obsolete-function-alias 'screen-list 'frame-list) -(define-obsolete-function-alias 'screen-live-p 'frame-live-p) -(define-obsolete-function-alias 'screen-name 'frame-name) -(define-obsolete-function-alias 'screen-parameters 'frame-parameters) -(define-obsolete-function-alias 'screen-pixel-height 'frame-pixel-height) -(define-obsolete-function-alias 'screen-pixel-width 'frame-pixel-width) -(define-obsolete-function-alias 'screen-root-window 'frame-root-window) -(define-obsolete-function-alias 'screen-selected-window 'frame-selected-window) -(define-obsolete-function-alias 'screen-totally-visible-p - 'frame-totally-visible-p) -(define-obsolete-function-alias 'screen-visible-p 'frame-visible-p) -(define-obsolete-function-alias 'screen-width 'frame-width) -(define-obsolete-function-alias 'screenp 'framep) -(define-obsolete-function-alias 'get-screen-for-buffer 'get-frame-for-buffer) -(define-obsolete-function-alias 'get-screen-for-buffer-noselect - 'get-frame-for-buffer-noselect) -(define-obsolete-function-alias 'get-other-screen 'get-other-frame) -(define-obsolete-function-alias 'iconify-screen 'iconify-frame) -(define-obsolete-function-alias 'lower-screen 'lower-frame) -(define-obsolete-function-alias 'mail-other-screen 'mail-other-frame) -(define-obsolete-function-alias 'make-screen 'make-frame) -(define-obsolete-function-alias 'make-screen-invisible 'make-frame-invisible) -(define-obsolete-function-alias 'make-screen-visible 'make-frame-visible) -(define-obsolete-function-alias 'modify-screen-parameters - 'modify-frame-parameters) -(define-obsolete-function-alias 'new-screen 'new-frame) -(define-obsolete-function-alias 'next-screen 'next-frame) -(define-obsolete-function-alias 'next-multiscreen-window - 'next-multiframe-window) -(define-obsolete-function-alias 'other-screen 'other-frame) -(define-obsolete-function-alias 'previous-screen 'previous-frame) -(define-obsolete-function-alias 'previous-multiscreen-window - 'previous-multiframe-window) -(define-obsolete-function-alias 'raise-screen 'raise-frame) -(define-obsolete-function-alias 'redraw-screen 'redraw-frame) -(define-obsolete-function-alias 'select-screen 'select-frame) -(define-obsolete-function-alias 'selected-screen 'selected-frame) -(define-obsolete-function-alias 'set-buffer-dedicated-screen - 'set-buffer-dedicated-frame) -(define-obsolete-function-alias 'set-screen-height 'set-frame-height) -(define-obsolete-function-alias 'set-screen-position 'set-frame-position) -(define-obsolete-function-alias 'set-screen-size 'set-frame-size) -(define-obsolete-function-alias 'set-screen-width 'set-frame-width) -(define-obsolete-function-alias 'show-temp-buffer-in-current-screen - 'show-temp-buffer-in-current-frame) -(define-obsolete-function-alias 'switch-to-buffer-other-screen - 'switch-to-buffer-other-frame) -(define-obsolete-function-alias 'visible-screen-list 'visible-frame-list) -(define-obsolete-function-alias 'window-screen 'window-frame) -(define-obsolete-function-alias 'x-set-screen-pointer - 'set-frame-pointer) -(define-obsolete-function-alias 'x-set-frame-pointer - 'set-frame-pointer) - -(define-obsolete-variable-alias 'screen-title-format 'frame-title-format) -(define-obsolete-variable-alias 'screen-icon-title-format - 'frame-icon-title-format) -(define-obsolete-variable-alias 'terminal-screen 'terminal-frame) -(define-obsolete-variable-alias 'delete-screen-hook 'delete-frame-hook) -(define-obsolete-variable-alias 'create-screen-hook 'create-frame-hook) -(define-obsolete-variable-alias 'mouse-enter-screen-hook - 'mouse-enter-frame-hook) -(define-obsolete-variable-alias 'mouse-leave-screen-hook - 'mouse-leave-frame-hook) -(define-obsolete-variable-alias 'map-screen-hook 'map-frame-hook) -(define-obsolete-variable-alias 'unmap-screen-hook 'unmap-frame-hook) -(define-obsolete-variable-alias 'default-screen-alist 'default-frame-alist) -(define-obsolete-variable-alias 'default-screen-name 'default-frame-name) -(define-obsolete-variable-alias 'x-screen-defaults 'default-x-frame-alist) - -(defun x-create-screen (parms window-id) - "" - (if (not (eq 'x (device-type (selected-device)))) - (error "Cannot create X frames on non-X device")) - (make-frame (append parms (list (list 'window-id window-id))) - (selected-device))) -(make-obsolete 'x-create-screen 'make-frame) - -(defun frame-first-window (frame) - "Returns the topmost, leftmost window of FRAME. -If omitted, FRAME defaults to the currently selected frame." - (frame-highest-window frame 0)) -(make-compatible 'frame-first-window 'frame-highest-window) - -(define-obsolete-variable-alias 'initial-frame-alist 'initial-frame-plist) -(define-obsolete-variable-alias 'minibuffer-frame-alist - 'minibuffer-frame-plist) -(define-obsolete-variable-alias 'pop-up-frame-alist 'pop-up-frame-plist) -(define-obsolete-variable-alias 'special-display-frame-alist - 'special-display-frame-plist) - -;; Defined in C. - -(define-obsolete-variable-alias 'default-frame-alist 'default-frame-plist) -(define-obsolete-variable-alias 'default-x-frame-alist 'default-x-frame-plist) -(define-obsolete-variable-alias 'default-tty-frame-alist - 'default-tty-frame-plist) - -(make-compatible 'frame-parameters 'frame-property) -(defun frame-parameters (&optional frame) - "Return the parameters-alist of frame FRAME. -It is a list of elements of the form (PARM . VALUE), where PARM is a symbol. -The meaningful PARMs depend on the kind of frame. -If FRAME is omitted, return information on the currently selected frame. - -See the variables `default-frame-plist', `default-x-frame-plist', and -`default-tty-frame-plist' for a description of the parameters meaningful -for particular types of frames." - (or frame (setq frame (selected-frame))) - ;; #### This relies on a `copy-sequence' of the user properties in - ;; `frame-properties'. Removing that would make `frame-properties' more - ;; efficient but this function less efficient, as we couldn't be - ;; destructive. Since most callers now use `frame-parameters', we'll - ;; do it this way. Should probably change this at some point in the - ;; future. - (destructive-plist-to-alist (frame-properties frame))) - -(make-compatible 'modify-frame-parameters 'set-frame-properties) -(defun modify-frame-parameters (frame alist) - "Modify the properties of frame FRAME according to ALIST. -ALIST is an alist of properties to change and their new values. -Each element of ALIST has the form (PARM . VALUE), where PARM is a symbol. -The meaningful PARMs depend on the kind of frame. - -See `set-frame-properties' for built-in property names." - ;; it would be nice to be destructive here but that's not safe. - (set-frame-properties frame (alist-to-plist alist))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;; faces - -(define-obsolete-function-alias 'list-faces-display 'edit-faces) -(define-obsolete-function-alias 'list-faces 'face-list) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;; files - -(make-obsolete-variable 'trim-versions-without-asking 'delete-old-versions) -;;; Old XEmacs name; kept around for compatibility. -(define-obsolete-variable-alias 'after-write-file-hooks 'after-save-hook) -(define-obsolete-function-alias 'truename 'file-truename) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;; hooks - -(make-obsolete-variable 'auto-fill-hook 'auto-fill-function) -(make-obsolete-variable 'blink-paren-hook 'blink-paren-function) -(make-obsolete-variable 'lisp-indent-hook 'lisp-indent-function) -(make-obsolete-variable 'comment-indent-hook 'comment-indent-function) -(make-obsolete-variable 'temp-buffer-show-hook - 'temp-buffer-show-function) -(make-obsolete-variable 'inhibit-local-variables - "use `enable-local-variables' (with the reversed sense).") -(make-obsolete-variable 'suspend-hooks 'suspend-hook) -(make-obsolete-variable 'first-change-function 'first-change-hook) -(make-obsolete-variable 'before-change-function - "use before-change-functions; which is a list of functions rather than a single function.") -(make-obsolete-variable 'after-change-function - "use after-change-functions; which is a list of functions rather than a single function.") - -;;;;;;;;;;;;;;;;;;;;;;;;;;;; insertion and deletion - -(define-compatible-function-alias 'insert-and-inherit 'insert) -(define-compatible-function-alias 'insert-before-markers-and-inherit - 'insert-before-markers) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;; keymaps - -(defun keymap-parent (keymap) - "Returns the first parent of the given keymap." - (car (keymap-parents keymap))) -(make-compatible 'keymap-parent 'keymap-parents) - -(defun set-keymap-parent (keymap parent) - "Makes the given keymap have (only) the given parent." - (set-keymap-parents keymap (if parent (list parent) '())) - parent) -(make-compatible 'set-keymap-parent 'set-keymap-parents) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;; menu stuff - -(defun add-menu-item (menu-path item-name function enabled-p &optional before) - "Obsolete. See the function `add-menu-button'." - (or item-name (error "must specify an item name")) - (add-menu-button menu-path (vector item-name function enabled-p) before)) -(make-obsolete 'add-menu-item 'add-menu-button) - -(defun add-menu (menu-path menu-name menu-items &optional before) - "See the function `add-submenu'." - (or menu-name (error (gettext "must specify a menu name"))) - (or menu-items (error (gettext "must specify some menu items"))) - (add-submenu menu-path (cons menu-name menu-items) before)) -;; Can't make this obsolete. easymenu depends on it. -(make-compatible 'add-menu 'add-submenu) - -(define-obsolete-function-alias 'popup-menu-up-p 'popup-up-p) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;; minibuffer - -(define-compatible-function-alias 'read-minibuffer - 'read-expression) ; misleading name -(define-compatible-function-alias 'read-input 'read-string) -(make-obsolete 'read-no-blanks-input 'read-string) ; mocklisp crud - -;;;;;;;;;;;;;;;;;;;;;;;;;;;; misc - -;; (defun user-original-login-name () -;; "Return user's login name from original login. -;; This tries to remain unaffected by `su', by looking in environment variables." -;; (or (getenv "LOGNAME") (getenv "USER") (user-login-name))) -(define-obsolete-function-alias 'user-original-login-name 'user-login-name) - -; old names -(define-obsolete-function-alias 'wholenump 'natnump) -(define-obsolete-function-alias 'show-buffer 'set-window-buffer) -(define-obsolete-function-alias 'buffer-flush-undo 'buffer-disable-undo) -(define-obsolete-function-alias 'eval-current-buffer 'eval-buffer) -(define-obsolete-function-alias 'byte-code-function-p - 'compiled-function-p) ;FSFmacs - -;;(make-obsolete 'mod '%) ; mod and % are different now - -(make-obsolete 'ring-mod 'mod) - -(make-obsolete 'current-time-seconds 'current-time) -;; too bad there's not a way to check for aref, assq, and nconc -;; being called on the values of functions known to return keymaps, -;; or known to return vectors of events instead of strings... - -(define-obsolete-function-alias 'run-special-hook-with-args - 'run-hook-with-args-until-success) - -(make-obsolete-variable 'executing-macro 'executing-kbd-macro) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;; modeline - -(define-compatible-function-alias 'redraw-mode-line 'redraw-modeline) -(define-compatible-function-alias 'force-mode-line-update - 'redraw-modeline) ;; FSF compatibility -(define-compatible-variable-alias 'mode-line-map 'modeline-map) -(define-compatible-variable-alias 'mode-line-buffer-identification - 'modeline-buffer-identification) -(define-compatible-variable-alias 'mode-line-process 'modeline-process) -(define-compatible-variable-alias 'mode-line-modified 'modeline-modified) -(make-compatible-variable 'mode-line-inverse-video - "use set-face-highlight-p and set-face-reverse-p") -(define-compatible-variable-alias 'default-mode-line-format - 'default-modeline-format) -(define-compatible-variable-alias 'mode-line-format 'modeline-format) -(define-compatible-variable-alias 'mode-line-menu 'modeline-menu) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;; mouse - -;;; (defun mouse-eval-last-sexpr (event) -;;; (interactive "@e") -;;; (save-excursion -;;; (mouse-set-point event) -;;; (eval-last-sexp nil))) - -(define-obsolete-function-alias 'mouse-eval-last-sexpr 'mouse-eval-sexp) - -(defun read-mouse-position (frame) - (cdr (mouse-position (frame-device frame)))) -(make-obsolete 'read-mouse-position 'mouse-position) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;; `point' - -(define-obsolete-function-alias 'dot 'point) -(define-obsolete-function-alias 'dot-marker 'point-marker) -(define-obsolete-function-alias 'dot-min 'point-min) -(define-obsolete-function-alias 'dot-max 'point-max) -(define-obsolete-function-alias 'window-dot 'window-point) -(define-obsolete-function-alias 'set-window-dot 'set-window-point) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;; processes - -(define-obsolete-function-alias 'send-string 'process-send-string) -(define-obsolete-function-alias 'send-region 'process-send-region) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;; redisplay - -(defun redraw-display (&optional device) - (if (eq device t) - (mapcar 'redisplay-device (device-list)) - (redisplay-device device))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;; stuff replaced by specifiers - -(defun screen-scrollbar-width (&optional screen) - ;; specifier-specs is the inverse of set-specifier, but - ;; the way this function was defined, specifier-instance - ;; is closer. - (specifier-instance scrollbar-width (or screen (selected-frame)))) -(make-obsolete 'screen-scrollbar-width - "use (specifier-instance scrollbar-width ...).") - -(defun set-screen-scrollbar-width (screen value) - (set-specifier scrollbar-width (cons screen value))) -(make-obsolete 'set-screen-scrollbar-width - "use (set-specifier scrollbar-width ...).") - -(defun set-screen-left-margin-width (value &optional screen) - (set-specifier left-margin-width - (cons (or screen (selected-frame)) value))) -(make-obsolete 'set-screen-left-margin-width - "use (set-specifier left-margin-width ...).") - -(defun set-screen-right-margin-width (value &optional screen) - (set-specifier right-margin-width - (cons (or screen (selected-frame)) value))) -(make-obsolete 'set-screen-right-margin-width - "use (set-specifier right-margin-width ...).") - -(defun set-buffer-left-margin-width (value &optional buffer) - (set-specifier left-margin-width (cons (or buffer (current-buffer)) value))) -(make-obsolete 'set-buffer-left-margin-width - "use (set-specifier left-margin-width ...).") - -(defun set-buffer-right-margin-width (value &optional buffer) - (set-specifier right-margin-width (cons (or buffer (current-buffer)) value))) -(make-obsolete 'set-buffer-right-margin-width - "use (set-specifier right-margin-width ...).") - -(defun screen-left-margin-width (&optional screen) - (specifier-specs left-margin-width (or screen (selected-frame)))) -(make-obsolete 'screen-left-margin-width - "use (specifier-specs left-margin-width ...).") - -(defun screen-right-margin-width (&optional screen) - (specifier-specs right-margin-width (or screen (selected-frame)))) -(make-obsolete 'screen-right-margin-width - "use (specifier-specs right-margin-width ...).") - -(defun buffer-left-margin-width (&optional buffer) - (specifier-specs left-margin-width (or buffer (current-buffer)))) -(make-obsolete 'buffer-left-margin-width - "use (specifier-specs left-margin-width ...).") - -(defun buffer-right-margin-width (&optional buffer) - (specifier-specs right-margin-width (or buffer (current-buffer)))) -(make-obsolete 'buffer-right-margin-width - "use (specifier-specs right-margin-width ...).") - -(defun x-set-frame-icon-pixmap (frame image-instance &optional mask-ignored) - "Set the icon of the given frame to the given image instance, -which should be an image instance object (as returned by -`make-image-instance'), a glyph object (as returned by `make-glyph'), -or nil. If a glyph object is given, the glyph will be instantiated on -the frame to produce an image instance object. - -If the given image instance has a mask, that will be used as the icon mask; -however, not all window managers support this. - -The window manager is also not required to support color pixmaps, -only bitmaps (one plane deep). - -Optional third argument is ignored. If you're concerned about this -incomplete backwards incompatibility, you should convert your code -to use `frame-icon-glyph' -- you can specify a mask for an XBM file -using the standard image instantiator format." - (if (glyphp image-instance) - (setq image-instance (glyph-image-instance image-instance frame))) - (set-glyph-image frame-icon-glyph image-instance frame)) -(make-obsolete 'x-set-frame-icon-pixmap - "use (set-glyph-image frame-icon-glyph ...).") -(defalias 'x-set-screen-icon-pixmap 'x-set-frame-icon-pixmap) -(make-obsolete 'x-set-screen-icon-pixmap - "use (set-glyph-image frame-icon-glyph ...).") - -;;;;;;;;;;;;;;;;;;;;;;;;;;;; window-system objects - -(define-obsolete-function-alias 'pixel-name 'color-name) - -;; compatibility function -- a front-end to make-glyph -(defun make-pixmap (name &optional locale) - "Create a glyph with NAME as an image specifier and locale LOCALE. -The file should be in `XBM' or `XPM' format. -If the XBMLANGPATH environment variable is set, it will be searched for - matching files. Next, the directories listed in the `x-bitmap-file-path' - variable will be searched (this variable is initialized from the - \"*bitmapFilePath\" resource). Finally, the XEmacs etc/ directory - (the value of `data-directory') will be searched. -The file argument may also be a list of the form (width height data) where - width and height are the size in pixels, and data is a string, containing - the raw bits of the bitmap. (Bitmaps specified this way can only be one bit - deep.) -If compiled with support for XPM, the file argument may also be a string - which is the contents of an XPM file (that is, a string beginning with the - characters \"/* XPM */\"; see the XPM documentation). -The optional second argument is the specifier locale for this pixmap glyph. -The returned object is a glyph object. To get the actual pixmap object for -a given frame, use the function `glyph-instance'." - (if (consp name) - (setq name (vector 'xbm :data name))) - (make-glyph name)) -(make-obsolete 'make-pixmap 'make-glyph) - -(defun make-cursor (name &optional fg bg device) - "Creates a pointer image instance with NAME as an image specifier. -The optional second and third arguments are the foreground and background - colors. They may be color name strings or `pixel' objects. -The optional fourth argument is the device on which to allocate the cursor - (defaults to the selected device). -This allocates a new pointer in the X server, and signals an error if the - pointer is unknown or cannot be allocated. - -A pointer name can take many different forms. It can be: - - any of the standard cursor names from appendix B of the Xlib manual - (also known as the file <X11/cursorfont.h>) minus the XC_ prefix; - - the name of a font, and glyph index into it of the form - \"FONT fontname index [[mask-font] mask-index]\"; - - the name of a bitmap or pixmap file; - - or an image instance object, as returned by `make-image-instance'. - -If it is an image instance or pixmap file, and that pixmap comes with a - mask, then that mask will be used. If it is an image instance, it must - have only one plane, since X pointers may only have two colors. If it is a - pixmap file, then the file will be read in monochrome. - -If it is a bitmap file, and if a bitmap file whose name is the name of the - pointer with \"msk\" or \"Mask\" appended exists, then that second bitmap - will be used as the mask. For example, a pair of files might be named - \"pointer.xbm\" and \"pointer.xbmmsk\". - -The returned object is a normal, first-class lisp object. The way you -`deallocate' the pointer is the way you deallocate any other lisp object: -you drop all pointers to it and allow it to be garbage collected. When -these objects are GCed, the underlying X data is deallocated as well." - ;; #### ignores fg and bg - (make-image-instance name device '(pointer))) -(make-obsolete 'make-cursor 'make-image-instance) - -(define-obsolete-function-alias 'pixmap-width 'glyph-width) -(define-obsolete-function-alias 'pixmap-contributes-to-line-height-p - 'glyph-contrib-p-instance) -(define-obsolete-function-alias 'set-pixmap-contributes-to-line-height - 'set-glyph-contrib-p) - -;; the functionality of column.el has been moved into C -(defalias 'display-column-mode 'column-number-mode) - -(defun x-color-values (color &optional frame) - "Return a description of the color named COLOR on frame FRAME. -The value is a list of integer RGB values--(RED GREEN BLUE). -These values appear to range from 0 to 65280 or 65535, depending -on the system; white is (65280 65280 65280) or (65535 65535 65535). -If FRAME is omitted or nil, use the selected frame." - (color-instance-rgb-components (make-color-instance color))) -(make-compatible 'x-color-values 'color-instance-rgb-components) - -;; Two loser functions which shouldn't be used. -(make-obsolete 'following-char 'char-after) -(make-obsolete 'preceding-char 'char-before) - - -;; The following several functions are useful in GNU Emacs 20 because -;; of the multibyte "characters" the internal representation of which -;; leaks into Lisp. In XEmacs/Mule they are trivial and unnecessary. -;; We provide them for compatibility reasons solely. - -(defun string-to-sequence (string type) - "Convert STRING to a sequence of TYPE which contains characters in STRING. -TYPE should be `list' or `vector'. -Multibyte characters are concerned." - (ecase type - (list - (mapcar #'identity string)) - (vector - (mapvector #'identity string)))) - -(defun string-to-list (string) - "Return a list of characters in STRING." - (mapcar #'identity string)) - -(defun string-to-vector (string) - "Return a vector of characters in STRING." - (mapvector #'identity string)) - -(defun store-substring (string idx obj) - "Embed OBJ (string or character) at index IDX of STRING." - (let* ((str (cond ((stringp obj) obj) - ((characterp obj) (char-to-string obj)) - (t (error - "Invalid argument (should be string or character): %s" - obj)))) - (string-len (length string)) - (len (length str)) - (i 0)) - (while (and (< i len) (< idx string-len)) - (aset string idx (aref str i)) - (setq idx (1+ idx) i (1+ i))) - string)) - -;; ### 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 -;; 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. -The optional 2nd arg START-COLUMN, if non-nil, specifies -the starting column; that means to return the characters occupying -columns START-COLUMN ... END-COLUMN of STR. - -The optional 3rd arg PADDING, if non-nil, specifies a padding character -to add at the end of the result if STR doesn't reach column END-COLUMN, -or if END-COLUMN comes in the middle of a character in STR. -PADDING is also added at the beginning of the result -if column START-COLUMN appears in the middle of a character in STR. - -If PADDING is nil, no padding is added in these cases, so -the resulting string may be narrower than END-COLUMN." - (or start-column - (setq start-column 0)) - (let ((len (length str))) - (concat (substring str (min start-column len) (min end-column len)) - (and padding (> end-column len) - (make-string (- end-column len) padding))))) - -(defalias 'truncate-string 'truncate-string-to-width) -(make-obsolete 'truncate-string 'truncate-string-to-width) - -;; Keywords already do The Right Thing in XEmacs -(make-compatible 'define-widget-keywords "Just use them") - -(make-obsolete 'function-called-at-point 'function-at-point) - -;;; obsolete.el ends here
--- a/lisp/prim/packages.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,258 +0,0 @@ -;;; packages.el --- Low level support for XEmacs packages - -;; Copyright (C) 1997 Free Software Foundation, Inc. - -;; Author: Steven L Baur <steve@altair.xemacs.org> -;; Keywords: internal, lisp - -;; 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: - -;; This file provides low level facilities for XEmacs startup. Special -;; requirements apply to some of these functions because they can be called -;; during build from temacs and much of the usual lisp environment may -;; be missing. - -;;; Code: - -(defvar autoload-file-name "auto-autoloads.el" - "Filename that autoloads are expected to be found in.") - -(defvar packages-hardcoded-lisp - '( - ;; "startup" - ) - "Lisp packages that are always dumped with XEmacs") - -(defvar packages-useful-lisp - '("bytecomp" - "byte-optimize" - "advice" - "shadow") - "Lisp packages that need early byte compilation.") - -(defvar packages-unbytecompiled-lisp - '("paths.el" - "version.el") - "Lisp packages that should not be byte compiled.") - -;; Copied from subr.el -(defmacro lambda (&rest cdr) - "Return a lambda expression. -A call of the form (lambda ARGS DOCSTRING INTERACTIVE BODY) is -self-quoting; the result of evaluating the lambda expression is the -expression itself. The lambda expression may then be treated as a -function, i.e., stored as the function value of a symbol, passed to -funcall or mapcar, etc. - -ARGS should take the same form as an argument list for a `defun'. -DOCSTRING is an optional documentation string. - If present, it should describe how to call the function. - But documentation strings are usually not useful in nameless functions. -INTERACTIVE should be a call to the function `interactive', which see. -It may also be omitted. -BODY should be a list of lisp expressions." - ;; Note that this definition should not use backquotes; subr.el should not - ;; depend on backquote.el. - ;; #### - I don't see why. So long as backquote.el doesn't use anything - ;; from subr.el, there's no problem with using backquotes here. --Stig - ;;(list 'function (cons 'lambda cdr))) - ;; -slb, This has to run in a naked temacs. Enough is enough. - ;; `(function (lambda ,@cdr))) - (list 'function (cons 'lambda cdr))) - - -;; Copied from help.el, could possibly move it to here permanently. -;; Unlike the FSF version, our `locate-library' uses the `locate-file' -;; primitive, which should make it lightning-fast. - -(defun locate-library (library &optional nosuffix path interactive-call) - "Show the precise file name of Emacs library LIBRARY. -This command searches the directories in `load-path' like `M-x load-library' -to find the file that `M-x load-library RET LIBRARY RET' would load. -Optional second arg NOSUFFIX non-nil means don't add suffixes `.elc' or `.el' -to the specified name LIBRARY. - -If the optional third arg PATH is specified, that list of directories -is used instead of `load-path'." - (interactive (list (read-string "Locate library: ") - nil nil - t)) - (let ((result - (locate-file - library - (or path load-path) - (cond ((or (rassq 'jka-compr-handler file-name-handler-alist) - (and (boundp 'find-file-hooks) - (member 'crypt-find-file-hook find-file-hooks))) - ;; Compression involved. - (if nosuffix - ":.gz:.Z" - ".elc:.elc.gz:elc.Z:.el:.el.gz:.el.Z::.gz:.Z")) - (t - ;; No compression. - (if nosuffix - "" - ".elc:.el:"))) - 4))) - (and interactive-call - (if result - (message "Library is file %s" result) - (message "No library %s in search path" library))) - result)) - -(defun packages-add-suffix (str) - (if (null (string-match "\\.el\\'" str)) - (concat str ".elc") - str)) - -(defun list-autoloads-path () - "List autoloads from precomputed load-path." - (let ((path load-path) - autoloads) - (while path - (if (file-exists-p (concat (car path) - autoload-file-name)) - (setq autoloads (cons (concat (car path) - autoload-file-name) - autoloads))) - (setq path (cdr path))) - autoloads)) - -(defun list-autoloads () - "List autoload files in (what will be) the normal lisp search path. -This function is used during build to find where the global symbol files so -they can be perused for their useful information." - ;; Source directory may not be initialized yet. - ;; (print (prin1-to-string load-path)) - (if (null source-directory) - (setq source-directory (concat (car load-path) "/.."))) - (let ((files (directory-files source-directory t ".*")) - file autolist) - (while (setq file (car-safe files)) - (if (and (file-directory-p file) - (file-exists-p (concat file "/" autoload-file-name))) - (setq autolist (cons (concat file "/" autoload-file-name) - autolist))) - (setq files (cdr files))) - autolist)) - -;; The following function is called from temacs -(defun packages-find-packages-1 (package path-only user-package) - "Search the supplied directory for associated directories. -The top level is assumed to look like: -info/ Contain texinfo files for lisp installed in this hierarchy -etc/ Contain data files for lisp installled in this hiearchy -lisp/ Contain directories which either have straight lisp code - or are self-contained packages of their own. - -This is an internal function. Do not call it after startup." - ;; Info files - (if (and (null path-only) (file-directory-p (concat package "/info"))) - (let ((dir (concat package "/info/"))) - (when (not (member dir Info-default-directory-list)) - (nconc Info-default-directory-list (list dir))))) - ;; Data files - (if (and (null path-only) (file-directory-p (concat package "/etc"))) - (setq data-directory-list - (cons (concat package "/etc/") data-directory-list))) - ;; Lisp files - (if (file-directory-p (concat package "/lisp")) - (progn -; (print (concat "DIR: " -; (if user-package "[USER]" "") -; package -; "/lisp/")) - (setq load-path (cons (concat package "/lisp/") load-path)) - (if user-package - (condition-case nil - (load (concat package "/lisp/" - (file-name-sans-extension autoload-file-name))) - (t nil))) - (let ((dirs (directory-files (concat package "/lisp/") - t "^[^-.]" nil 'dirs-only)) - dir) - (while dirs - (setq dir (car dirs)) -; (print (concat "DIR: " dir "/")) - (setq load-path (cons (concat dir "/") load-path)) - (if user-package - (condition-case nil - (progn -; (print -; (concat dir "/" -; (file-name-sans-extension autoload-file-name))) - (load - (concat dir "/" - (file-name-sans-extension autoload-file-name)))) - (t nil))) - (packages-find-packages-1 dir path-only user-package) - (setq dirs (cdr dirs))))))) - -;; The following function is called from temacs -(defun packages-find-packages (pkg-path path-only &optional suppress-user) - "Search the supplied path for additional info/etc/lisp directories. -Lisp directories if configured prior to build time will have equivalent -status as bundled packages. -If the argument `path-only' is non-nil, only the `load-path' will be set, -otherwise data directories and info directories will be added. -If the optional argument `suppress-user' is non-nil, package directories -rooted in a user login directory (like ~/.xemacs) will not be searched. -This is used at dump time to suppress the builder's local environment." - (let ((path (reverse pkg-path)) - dir) - (while path - (setq dir (car path)) - ;; (prin1 (concat "Find: " (expand-file-name dir) "\n")) - (if (null (and (or suppress-user inhibit-package-init) - (string-match "^~" dir))) - (progn - ;; (print dir) - (packages-find-packages-1 (expand-file-name dir) - path-only - (string-match "^~" dir)))) - (setq path (cdr path))))) - -;; Data-directory is really a list now. Provide something to search it for -;; directories. - -(defun locate-data-directory (name &optional dir-list) - "Locate a directory in a search path DIR-LIST (a list of directories). -If no DIR-LIST is supplied, it defaults to `data-directory-list'." - (unless dir-list - (setq dir-list data-directory-list)) - (let (found found-dir) - (while (and (null found-dir) dir-list) - (setq found (concat (car dir-list) name "/") - found-dir (file-directory-p found)) - (or found-dir - (setq found nil)) - (setq dir-list (cdr dir-list))) - found)) - -;; If we are being loaded as part of being dumped, bootstrap the rest of the -;; load-path for loaddefs. -(if (fboundp 'load-gc) - (packages-find-packages package-path t t)) - -(provide 'packages) - -;;; packages.el ends here
--- a/lisp/prim/page.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,154 +0,0 @@ -;;; page.el --- page motion commands for emacs. - -;; Copyright (C) 1985 Free Software Foundation, Inc. - -;; Maintainer: FSF - -;; 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.34. - -;;; Commentary: - -;; This code provides the page-oriented movement and selection commands -;; documented in the XEmacs Reference Manual. - -;;; Code: - -(defun forward-page (&optional count) - "Move forward to page boundary. With arg, repeat, or go back if negative. -A page boundary is any line whose beginning matches the regexp -`page-delimiter'." - (interactive "_p") ; XEmacs - (or count (setq count 1)) - (while (and (> count 0) (not (eobp))) - ;; In case the page-delimiter matches the null string, - ;; don't find a match without moving. - (if (bolp) (forward-char 1)) - (if (re-search-forward page-delimiter nil t) - nil - (goto-char (point-max))) - (setq count (1- count))) - (while (and (< count 0) (not (bobp))) - ;; In case the page-delimiter matches the null string, - ;; don't find a match without moving. - (and (save-excursion (re-search-backward page-delimiter nil t)) - (= (match-end 0) (point)) - (goto-char (match-beginning 0))) - (forward-char -1) - (if (re-search-backward page-delimiter nil t) - ;; We found one--move to the end of it. - (goto-char (match-end 0)) - ;; We found nothing--go to beg of buffer. - (goto-char (point-min))) - (setq count (1+ count)))) - -(defun backward-page (&optional count) - "Move backward to page boundary. With arg, repeat, or go fwd if negative. -A page boundary is any line whose beginning matches the regexp -`page-delimiter'." - (interactive "_p") ; XEmacs - (or count (setq count 1)) - (forward-page (- count))) - -(defun mark-page (&optional arg) - "Put mark at end of page, point at beginning. -A numeric arg specifies to move forward or backward by that many pages, -thus marking a page other than the one point was originally in." - (interactive "P") - (setq arg (if arg (prefix-numeric-value arg) 0)) - (if (> arg 0) - (forward-page arg) - (if (< arg 0) - (forward-page (1- arg)))) - (forward-page) - (push-mark nil t t) - (forward-page -1)) - -(defun narrow-to-page (&optional arg) - "Make text outside current page invisible. -A numeric arg specifies to move forward or backward by that many pages, -thus showing a page other than the one point was originally in." - (interactive "P") - (setq arg (if arg (prefix-numeric-value arg) 0)) - (save-excursion - (widen) - (if (> arg 0) - (forward-page arg) - (if (< arg 0) - (forward-page (1- arg)))) - ;; Find the end of the page. - (forward-page) - ;; If we stopped due to end of buffer, stay there. - ;; If we stopped after a page delimiter, put end of restriction - ;; at the beginning of that line. - (if (save-excursion - (goto-char (match-beginning 0)) ; was (beginning-of-line) - (looking-at page-delimiter)) - (beginning-of-line)) - (narrow-to-region (point) - (progn - ;; Find the top of the page. - (forward-page -1) - ;; If we found beginning of buffer, stay there. - ;; If extra text follows page delimiter on same line, - ;; include it. - ;; Otherwise, show text starting with following line. - (if (and (eolp) (not (bobp))) - (forward-line 1)) - (point))))) -(put 'narrow-to-page 'disabled t) - -(defun count-lines-page () - "Report number of lines on current page, and how many are before or after point." - (interactive "_") ; XEmacs - (save-excursion - (let ((opoint (point)) beg end - total before after) - (forward-page) - (beginning-of-line) - (or (looking-at page-delimiter) - (end-of-line)) - (setq end (point)) - (backward-page) - (setq beg (point)) - (setq total (count-lines beg end) - before (count-lines beg opoint) - after (count-lines opoint end)) - (message "Page has %d lines (%d + %d)" total before after)))) - -(defun what-page () - "Print page and line number of point." - (interactive "_") ; XEmacs - (save-restriction - (widen) - (save-excursion - (beginning-of-line) - (let ((count 1) - (opoint (point))) - (goto-char 1) - (while (re-search-forward page-delimiter opoint t) - (setq count (1+ count))) - (message "Page %d, line %d" - count - (1+ (count-lines (point) opoint))))))) - -;;; Place `provide' at end of file. -(provide 'page) - -;;; page.el ends here
--- a/lisp/prim/paragraphs.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,352 +0,0 @@ -;;; paragraphs.el --- paragraph and sentence parsing. - -;; Copyright (C) 1985, 86, 87, 91, 94, 95, 97 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: wp - -;; 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.34. - -;;; Commentary: - -;; This package provides the paragraph-oriented commands documented in the -;; XEmacs Reference Manual. - -;; 06/11/1997 - Use char-(after|before) instead of -;; (following|preceding)-char. -slb - -;;; Code: - -(defvar use-hard-newlines nil - "Non-nil means to distinguish hard and soft newlines. -When this is non-nil, the functions `newline' and `open-line' add the -text-property `hard' to newlines that they insert. Also, a line is -only considered as a candidate to match `paragraph-start' or -`paragraph-separate' if it follows a hard newline. Newlines not -marked hard are called \"soft\", and are always internal to -paragraphs. The fill functions always insert soft newlines. - -Each buffer has its own value of this variable.") -(make-variable-buffer-local 'use-hard-newlines) - -;; XEmacs - use purecopy -(defconst paragraph-start (purecopy "[ \t\n\f]") "\ -*Regexp for beginning of a line that starts OR separates paragraphs. -This regexp should match lines that separate paragraphs -and should also match lines that start a paragraph -\(and are part of that paragraph). - -This is matched against the text at the left margin, which is not necessarily -the beginning of the line, so it should never use \"^\" as an anchor. This -ensures that the paragraph functions will work equally well within a region -of text indented by a margin setting. - -The variable `paragraph-separate' specifies how to distinguish -lines that start paragraphs from lines that separate them. - -If the variable `use-hard-newlines' is non-nil, then only lines following a -hard newline are considered to match.") - -;; paragraph-start requires a hard newline, but paragraph-separate does not: -;; It is assumed that paragraph-separate is distinctive enough to be believed -;; whenever it occurs, while it is reasonable to set paragraph-start to -;; something very minimal, even including "." (which makes every hard newline -;; start a new paragraph). - -;; XEmacs -- use purecopy -(defconst paragraph-separate (purecopy "[ \t\f]*$") "\ -*Regexp for beginning of a line that separates paragraphs. -If you change this, you may have to change paragraph-start also. - -This is matched against the text at the left margin, which is not necessarily -the beginning of the line, so it should not use \"^\" as an anchor. This -ensures that the paragraph functions will work equally within a region of -text indented by a margin setting.") - -;; XEmacs -- use purecopy -(defconst sentence-end (purecopy "[.?!][]\"')}]*\\($\\| $\\|\t\\| \\)[ \t\n]*") "\ -*Regexp describing the end of a sentence. -All paragraph boundaries also end sentences, regardless. - -In order to be recognized as the end of a sentence, the ending period, -question mark, or exclamation point must be followed by two spaces, -unless it's inside some sort of quotes or parenthesis.") - -;; XEmacs -- use purecopy -(defconst page-delimiter (purecopy "^\014") "\ -*Regexp describing line-beginnings that separate pages.") - -(defvar paragraph-ignore-fill-prefix nil "\ -Non-nil means the paragraph commands are not affected by `fill-prefix'. -This is desirable in modes where blank lines are the paragraph delimiters.") - -(defun forward-paragraph (&optional arg) - "Move forward to end of paragraph. -With arg N, do it N times; negative arg -N means move backward N paragraphs. - -A line which `paragraph-start' matches either separates paragraphs -\(if `paragraph-separate' matches it also) or is the first line of a paragraph. -A paragraph end is the beginning of a line which is not part of the paragraph -to which the end of the previous line belongs, or the end of the buffer." - (interactive "_p") ; XEmacs - (or arg (setq arg 1)) - (let* ((fill-prefix-regexp - (and fill-prefix (not (equal fill-prefix "")) - (not paragraph-ignore-fill-prefix) - (regexp-quote fill-prefix))) - ;; Remove ^ from paragraph-start and paragraph-sep if they are there. - ;; These regexps shouldn't be anchored, because we look for them - ;; starting at the left-margin. This allows paragraph commands to - ;; work normally with indented text. - ;; This hack will not find problem cases like "whatever\\|^something". - (paragraph-start (if (and (not (equal "" paragraph-start)) - (equal ?^ (aref paragraph-start 0))) - (substring paragraph-start 1) - paragraph-start)) - (paragraph-separate (if (and (not (equal "" paragraph-start)) - (equal ?^ (aref paragraph-separate 0))) - (substring paragraph-separate 1) - paragraph-separate)) - (paragraph-separate - (if fill-prefix-regexp - (concat paragraph-separate "\\|" - fill-prefix-regexp "[ \t]*$") - paragraph-separate)) - ;; This is used for searching. - (sp-paragraph-start (concat "^[ \t]*\\(" paragraph-start "\\)")) - start) - (while (and (< arg 0) (not (bobp))) - (if (and (not (looking-at paragraph-separate)) - (re-search-backward "^\n" (max (1- (point)) (point-min)) t) - (looking-at paragraph-separate)) - nil - (setq start (point)) - ;; Move back over paragraph-separating lines. - (forward-char -1) (beginning-of-line) - (while (and (not (bobp)) - (progn (move-to-left-margin) - (looking-at paragraph-separate))) - (forward-line -1)) - (if (bobp) - nil - ;; Go to end of the previous (non-separating) line. - (end-of-line) - ;; Search back for line that starts or separates paragraphs. - (if (if fill-prefix-regexp - ;; There is a fill prefix; it overrides paragraph-start. - (let (multiple-lines) - (while (and (progn (beginning-of-line) (not (bobp))) - (progn (move-to-left-margin) - (not (looking-at paragraph-separate))) - (looking-at fill-prefix-regexp)) - (if (not (= (point) start)) - (setq multiple-lines t)) - (forward-line -1)) - (move-to-left-margin) - ;; Don't move back over a line before the paragraph - ;; which doesn't start with fill-prefix - ;; unless that is the only line we've moved over. - (and (not (looking-at fill-prefix-regexp)) - multiple-lines - (forward-line 1)) - (not (bobp))) - (while (and (re-search-backward sp-paragraph-start nil 1) - ;; Found a candidate, but need to check if it is a - ;; REAL paragraph-start. - (not (bobp)) - (progn (setq start (point)) - (move-to-left-margin) - (not (looking-at paragraph-separate))) - (or (not (looking-at paragraph-start)) - (and use-hard-newlines - (not (get-text-property (1- start) - 'hard))))) - (goto-char start)) - (> (point) (point-min))) - ;; Found one. - (progn - ;; Move forward over paragraph separators. - ;; We know this cannot reach the place we started - ;; because we know we moved back over a non-separator. - (while (and (not (eobp)) - (progn (move-to-left-margin) - (looking-at paragraph-separate))) - (forward-line 1)) - ;; If line before paragraph is just margin, back up to there. - (end-of-line 0) - (if (> (current-column) (current-left-margin)) - (forward-char 1) - (skip-chars-backward " \t") - (if (not (bolp)) - (forward-line 1)))) - ;; No starter or separator line => use buffer beg. - (goto-char (point-min))))) - (setq arg (1+ arg))) - (while (and (> arg 0) (not (eobp))) - ;; Move forward over separator lines, and one more line. - (while (prog1 (and (not (eobp)) - (progn (move-to-left-margin) (not (eobp))) - (looking-at paragraph-separate)) - (forward-line 1))) - (if fill-prefix-regexp - ;; There is a fill prefix; it overrides paragraph-start. - (while (and (not (eobp)) - (progn (move-to-left-margin) (not (eobp))) - (not (looking-at paragraph-separate)) - (looking-at fill-prefix-regexp)) - (forward-line 1)) - (while (and (re-search-forward sp-paragraph-start nil 1) - (progn (setq start (match-beginning 0)) - (goto-char start) - (not (eobp))) - (progn (move-to-left-margin) - (not (looking-at paragraph-separate))) - (or (not (looking-at paragraph-start)) - (and use-hard-newlines - (not (get-text-property (1- start) 'hard))))) - (forward-char 1)) - (if (< (point) (point-max)) - (goto-char start))) - (setq arg (1- arg))))) - -(defun backward-paragraph (&optional arg) - "Move backward to start of paragraph. -With arg N, do it N times; negative arg -N means move forward N paragraphs. - -A paragraph start is the beginning of a line which is a -`first-line-of-paragraph' or which is ordinary text and follows a -paragraph-separating line; except: if the first real line of a -paragraph is preceded by a blank line, the paragraph starts at that -blank line. - -See `forward-paragraph' for more information." - (interactive "_p") ; XEmacs - (or arg (setq arg 1)) - (forward-paragraph (- arg))) - -(defun mark-paragraph () - "Put point at beginning of this paragraph, mark at end. -The paragraph marked is the one that contains point or follows point." - (interactive) - (forward-paragraph 1) - (push-mark nil t t) - (backward-paragraph 1)) - -(defun kill-paragraph (arg) - "Kill forward to end of paragraph. -With arg N, kill forward to Nth end of paragraph; -negative arg -N means kill backward to Nth start of paragraph." - (interactive "*p") ; XEmacs - (kill-region (point) (progn (forward-paragraph arg) (point)))) - -(defun backward-kill-paragraph (arg) - "Kill back to start of paragraph. -With arg N, kill back to Nth start of paragraph; -negative arg -N means kill forward to Nth end of paragraph." - (interactive "*p") ; XEmacs - (kill-region (point) (progn (backward-paragraph arg) (point)))) - -(defun transpose-paragraphs (arg) - "Interchange this (or next) paragraph with previous one." - (interactive "*p") - (transpose-subr 'forward-paragraph arg)) - -(defun start-of-paragraph-text () - (let ((opoint (point)) npoint) - (forward-paragraph -1) - (setq npoint (point)) - (skip-chars-forward " \t\n") - ;; If the range of blank lines found spans the original start point, - ;; try again from the beginning of it. - ;; Must be careful to avoid infinite loop - ;; when following a single return at start of buffer. - (if (and (>= (point) opoint) (< npoint opoint)) - (progn - (goto-char npoint) - (if (> npoint (point-min)) - (start-of-paragraph-text)))))) - -(defun end-of-paragraph-text () - (let ((opoint (point))) - (forward-paragraph 1) - (if (eq (char-before (point)) ?\n) (forward-char -1)) - (if (<= (point) opoint) - (progn - (forward-char 1) - (if (< (point) (point-max)) - (end-of-paragraph-text)))))) - -(defun forward-sentence (&optional arg) - "Move forward to next `sentence-end'. With argument, repeat. -With negative argument, move backward repeatedly to `sentence-beginning'. - -The variable `sentence-end' is a regular expression that matches ends of -sentences. Also, every paragraph boundary terminates sentences as well." - (interactive "_p") ; XEmacs - (or arg (setq arg 1)) - (while (< arg 0) - (let ((par-beg (save-excursion (start-of-paragraph-text) (point)))) - (if (re-search-backward (concat sentence-end "[^ \t\n]") par-beg t) - (goto-char (1- (match-end 0))) - (goto-char par-beg))) - (setq arg (1+ arg))) - (while (> arg 0) - (let ((par-end (save-excursion (end-of-paragraph-text) (point)))) - (if (re-search-forward sentence-end par-end t) - (skip-chars-backward " \t\n") - (goto-char par-end))) - (setq arg (1- arg)))) - -(defun backward-sentence (&optional arg) - "Move backward to start of sentence. With arg, do it arg times. -See `forward-sentence' for more information." - (interactive "_p") ; XEmacs - (or arg (setq arg 1)) - (forward-sentence (- arg))) - -(defun kill-sentence (&optional arg) - "Kill from point to end of sentence. -With arg, repeat; negative arg -N means kill back to Nth start of sentence." - (interactive "*p") ; XEmacs - (kill-region (point) (progn (forward-sentence arg) (point)))) - -(defun backward-kill-sentence (&optional arg) - "Kill back from point to start of sentence. -With arg, repeat, or kill forward to Nth end of sentence if negative arg -N." - (interactive "*p") ; XEmacs - (kill-region (point) (progn (backward-sentence arg) (point)))) - -(defun mark-end-of-sentence (arg) - "Put mark at end of sentence. Arg works as in `forward-sentence'." - (interactive "p") - ;; FSF Version: -; (push-mark -; (save-excursion -; (forward-sentence arg) -; (point)) -; nil t)) - (mark-something 'mark-end-of-sentence 'forward-sentence arg)) - -(defun transpose-sentences (arg) - "Interchange this (next) and previous sentence." - (interactive "*p") - (transpose-subr 'forward-sentence arg)) - -;;; paragraphs.el ends here
--- a/lisp/prim/process.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,337 +0,0 @@ -;;; process.el --- commands for subprocesses; split out of simple.el - -;; Copyright (C) 1985-1987, 1993, 1994, 1997 Free Software Foundation, Inc. -;; Copyright (C) 1995 Ben Wing. - -;; Author: Ben Wing -;; Maintainer: XEmacs Development Team -;; Keywords: internal, processes - -;; 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, 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: FSF 19.30. - -;;; Commentary: - -;;; Code: - - -(defvar shell-command-switch "-c" - "Switch used to have the shell execute its command line argument.") - -(defun start-process-shell-command (name buffer &rest args) - "Start a program in a subprocess. Return the process object for it. -Args are NAME BUFFER COMMAND &rest COMMAND-ARGS. -NAME is name for process. It is modified if necessary to make it unique. -BUFFER is the buffer or (buffer-name) to associate with the process. - Process output goes at end of that buffer, unless you specify - an output stream or filter function to handle the output. - BUFFER may be also nil, meaning that this process is not associated - with any buffer -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 " "))))) - -(defun call-process (program &optional infile buffer displayp &rest args) - "Call PROGRAM synchronously in separate process. -The program's input comes from file INFILE (nil means `/dev/null'). -Insert output in BUFFER before point; t means current buffer; - nil for BUFFER means discard it; 0 means discard and don't wait. -BUFFER can also have the form (REAL-BUFFER STDERR-FILE); in that case, -REAL-BUFFER says what to do with standard output, as above, -while STDERR-FILE says what to do with standard error in the child. -STDERR-FILE may be nil (discard standard error output), -t (mix it with ordinary output), or a file name string. - -Fourth arg DISPLAYP non-nil means redisplay buffer as output is inserted. -Remaining arguments are strings passed as command arguments to PROGRAM. - -If BUFFER is 0, `call-process' returns immediately with value nil. -Otherwise it waits for PROGRAM to terminate and returns a numeric exit status - or a signal description string. -If you quit, the process is killed with SIGINT, or SIGKILL if you - quit again." - (apply 'call-process-internal program infile buffer displayp args)) - -(defun call-process-region (start end program - &optional deletep buffer displayp - &rest args) - "Send text from START to END to a synchronous process running PROGRAM. -Delete the text if fourth arg DELETEP is non-nil. - -Insert output in BUFFER before point; t means current buffer; - nil for BUFFER means discard it; 0 means discard and don't wait. -BUFFER can also have the form (REAL-BUFFER STDERR-FILE); in that case, -REAL-BUFFER says what to do with standard output, as above, -while STDERR-FILE says what to do with standard error in the child. -STDERR-FILE may be nil (discard standard error output), -t (mix it with ordinary output), or a file name string. - -Sixth arg DISPLAYP non-nil means redisplay buffer as output is inserted. -Remaining args are passed to PROGRAM at startup as command args. - -If BUFFER is 0, returns immediately with value nil. -Otherwise waits for PROGRAM to terminate -and returns a numeric exit status or a signal description string. -If you quit, the process is first killed with SIGINT, then with SIGKILL if -you quit again before the process exits." - (let ((temp (cond ((eq system-type 'vax-vms) - (make-temp-name "tmp:emacs")) - ((or (eq system-type 'ms-dos) - (eq system-type 'windows-nt)) - (make-temp-name - (concat (file-name-as-directory - (or (getenv "TMP") - (getenv "TEMP") - "")) - "em"))) - (t - (make-temp-name "/tmp/emacs"))))) - (unwind-protect - (progn - (if (or (eq system-type 'ms-dos) - (eq system-type '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))))) - - -(defun shell-command (command &optional output-buffer) - "Execute string COMMAND in inferior shell; display output, if any. - -If COMMAND ends in ampersand, execute it asynchronously. -The output appears in the buffer `*Async Shell Command*'. -That buffer is in shell mode. - -Otherwise, COMMAND is executed synchronously. The output appears in the -buffer `*Shell Command Output*'. -If the output is one line, it is displayed in the echo area *as well*, -but it is nonetheless available in buffer `*Shell Command Output*', -even though that buffer is not automatically displayed. -If there is no output, or if output is inserted in the current buffer, -then `*Shell Command Output*' is deleted. - -The optional second argument OUTPUT-BUFFER, if non-nil, -says to put the output in some other buffer. -If OUTPUT-BUFFER is a buffer or buffer name, put the output there. -If OUTPUT-BUFFER is not a buffer and not nil, -insert output in current buffer. (This cannot be done asynchronously.) -In either case, the output is inserted after point (leaving mark after it)." - (interactive (list (read-shell-command "Shell command: ") - current-prefix-arg)) - (if (and output-buffer - (not (or (bufferp output-buffer) (stringp output-buffer)))) - (progn (barf-if-buffer-read-only) - (push-mark) - ;; We do not use -f for csh; we will not support broken use of - ;; .cshrcs. Even the BSD csh manual says to use - ;; "if ($?prompt) exit" before things which are not useful - ;; non-interactively. Besides, if someone wants their other - ;; aliases for shell commands then they can still have them. - (call-process shell-file-name nil t nil - shell-command-switch command) - (exchange-point-and-mark t)) - ;; Preserve the match data in case called from a program. - (save-match-data - (if (string-match "[ \t]*&[ \t]*$" command) - ;; Command ending with ampersand means asynchronous. - (progn - (background (substring command 0 (match-beginning 0)))) - (shell-command-on-region (point) (point) command output-buffer))))) - -;; We have a sentinel to prevent insertion of a termination message -;; in the buffer itself. -(defun shell-command-sentinel (process signal) - (if (memq (process-status process) '(exit signal)) - (message "%s: %s." - (car (cdr (cdr (process-command process)))) - (substring signal 0 -1)))) - -(defun shell-command-on-region (start end command - &optional output-buffer replace) - "Execute string COMMAND in inferior shell with region as input. -Normally display output (if any) in temp buffer `*Shell Command Output*'; -Prefix arg means replace the region with it. - -The noninteractive arguments are START, END, COMMAND, OUTPUT-BUFFER, REPLACE. -If REPLACE is non-nil, that means insert the output -in place of text from START to END, putting point and mark around it. - -If the output is one line, it is displayed in the echo area, -but it is nonetheless available in buffer `*Shell Command Output*' -even though that buffer is not automatically displayed. -If there is no output, or if output is inserted in the current buffer, -then `*Shell Command Output*' is deleted. - -If the optional fourth argument OUTPUT-BUFFER is non-nil, -that says to put the output in some other buffer. -If OUTPUT-BUFFER is a buffer or buffer name, put the output there. -If OUTPUT-BUFFER is not a buffer and not nil, -insert output in the current buffer. -In either case, the output is inserted after point (leaving mark after it)." - (interactive (let ((string - ;; Do this before calling region-beginning - ;; and region-end, in case subprocess output - ;; relocates them while we are in the minibuffer. - (read-shell-command "Shell command on region: "))) - ;; call-interactively recognizes region-beginning and - ;; region-end specially, leaving them in the history. - (list (region-beginning) (region-end) - string - current-prefix-arg - current-prefix-arg))) - (if (or replace - (and output-buffer - (not (or (bufferp output-buffer) (stringp output-buffer))))) - ;; Replace specified region with output from command. - (let ((swap (and replace (< start end)))) - ;; Don't muck with mark unless REPLACE says we should. - (goto-char start) - (and replace (push-mark)) - (call-process-region start end shell-file-name t t nil - shell-command-switch command) - (let ((shell-buffer (get-buffer "*Shell Command Output*"))) - (and shell-buffer (not (eq shell-buffer (current-buffer))) - (kill-buffer shell-buffer))) - ;; Don't muck with mark unless REPLACE says we should. - (and replace swap (exchange-point-and-mark t))) - ;; No prefix argument: put the output in a temp buffer, - ;; replacing its entire contents. - (let ((buffer (get-buffer-create - (or output-buffer "*Shell Command Output*"))) - (success nil) - (directory default-directory)) - (unwind-protect - (if (eq buffer (current-buffer)) - ;; If the input is the same buffer as the output, - ;; delete everything but the specified region, - ;; then replace that region with the output. - (progn (setq buffer-read-only nil) - (delete-region (max start end) (point-max)) - (delete-region (point-min) (max start end)) - (call-process-region (point-min) (point-max) - shell-file-name t t nil - shell-command-switch command) - (setq success t)) - ;; Clear the output buffer, - ;; then run the command with output there. - (save-excursion - (set-buffer buffer) - (setq buffer-read-only nil) - ;; XEmacs change - (setq default-directory directory) - (erase-buffer)) - (call-process-region start end shell-file-name - nil buffer nil - shell-command-switch command) - (setq success t)) - ;; Report the amount of output. - (let ((lines (save-excursion - (set-buffer buffer) - (if (= (buffer-size) 0) - 0 - (count-lines (point-min) (point-max)))))) - (cond ((= lines 0) - (if success - (display-message - 'command - "(Shell command completed with no output)")) - (kill-buffer buffer)) - ((and success (= lines 1)) - (message "%s" - (save-excursion - (set-buffer buffer) - (goto-char (point-min)) - (buffer-substring (point) - (progn (end-of-line) - (point)))))) - (t - (set-window-start (display-buffer buffer) 1)))))))) - - -(defun start-process (name buffer program &rest program-args) - "Start a program in a subprocess. Return the process object for it. -Args are NAME BUFFER PROGRAM &rest PROGRAM-ARGS -NAME is name for process. It is modified if necessary to make it unique. -BUFFER is the buffer or (buffer-name) to associate with the process. - Process output goes at end of that buffer, unless you specify - an output stream or filter function to handle the output. - BUFFER may be also nil, meaning that this process is not associated - with any buffer -Third arg is program file name. It is searched for as in the shell. -Remaining arguments are strings to give program as arguments. -INCODE and OUTCODE specify the coding-system objects used in input/output - from/to the process." - (apply 'start-process-internal name buffer program program-args)) - -(defun open-network-stream (name buffer host service) - "Open a TCP connection for a service to a host. -Returns a subprocess-object to represent the connection. -Input and output work as for subprocesses; `delete-process' closes it. -Args are NAME BUFFER HOST SERVICE. -NAME is name for process. It is modified if necessary to make it unique. -BUFFER is the buffer (or buffer-name) to associate with the process. - Process output goes at end of that buffer, unless you specify - an output stream or filter function to handle the output. - BUFFER may be also nil, meaning that this process is not associated - with any buffer -Third arg is name of the host to connect to, or its IP address. -Fourth arg SERVICE is name of the service desired, or an integer - specifying a port number to connect to." - (open-network-stream-internal name buffer host service)) - -(defun shell-quote-argument (argument) - "Quote an argument for passing as argument to an inferior shell." - (if (eq system-type 'ms-dos) - ;; MS-DOS shells don't have quoting, so don't do any. - argument - (if (eq system-type 'windows-nt) - (concat "\"" argument "\"") - ;; Quote everything except POSIX filename characters. - ;; This should be safe enough even for really weird shells. - (let ((result "") (start 0) end) - (while (string-match "[^-0-9a-zA-Z_./]" argument start) - (setq end (match-beginning 0) - result (concat result (substring argument start end) - "\\" (substring argument end (1+ end))) - start (1+ end))) - (concat result (substring argument start)))))) - -(defun exec-to-string (command) - "Execute COMMAND as an external process and return the output of that -process as a string" - ;; by "William G. Dubuque" <wgd@zurich.ai.mit.edu> - (with-output-to-string - (call-process shell-file-name nil t nil "-c" command))) - -(defalias 'shell-command-to-string 'exec-to-string) - -;;; process.el ends here
--- a/lisp/prim/register.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,274 +0,0 @@ -;;; register.el --- register commands for Emacs. - -;; Copyright (C) 1985, 1993, 1994 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: internal - -;; 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 20.1 - -;;; Commentary: - -;; This package of functions emulates and somewhat extends the venerable -;; TECO's `register' feature, which permits you to save various useful -;; pieces of buffer state to named variables. The entry points are -;; documented in the Emacs user's manual. - -;;; Code: - -(defvar register-alist nil - "Alist of elements (NAME . CONTENTS), one for each Emacs register. -NAME is a character (a number). CONTENTS is a string, number, -frame configuration, mark or list. -A list of strings represents a rectangle. -A list of the form (file . NAME) represents the file named NAME. -A list of the form (file-query NAME POSITION) represents position POSITION - in the file named NAME, but query before visiting it.") - -(defun get-register (reg) - "Return contents of Emacs register named REG, or nil if none." - (cdr (assq reg register-alist))) - -(defun set-register (register value) - "Set contents of Emacs register named REGISTER to VALUE. Returns VALUE. -See the documentation of the variable `register-alist' for possible VALUE." - (let ((aelt (assq register register-alist))) - (if aelt - (setcdr aelt value) - (setq aelt (cons register value)) - (setq register-alist (cons aelt register-alist))) - value)) - -(defun point-to-register (register &optional arg) - "Store current location of point in register REGISTER. -With prefix argument, store current frame configuration. -Use \\[jump-to-register] to go to that location or restore that configuration. -Argument is a character, naming the register." - (interactive "cPoint to register: \nP") - (set-register register - (if arg (current-frame-configuration) (point-marker)))) - -(defun window-configuration-to-register (register &optional arg) - "Store the window configuration of the selected frame in register REGISTER. -Use \\[jump-to-register] to restore the configuration. -Argument is a character, naming the register." - (interactive "cWindow configuration to register: \nP") - (set-register register (current-window-configuration))) - -(defun frame-configuration-to-register (register &optional arg) - "Store the window configuration of all frames in register REGISTER. -Use \\[jump-to-register] to restore the configuration. -Argument is a character, naming the register." - (interactive "cFrame configuration to register: \nP") - (set-register register (current-frame-configuration))) - -(defalias 'register-to-point 'jump-to-register) -(defun jump-to-register (register &optional delete) - "Move point to location stored in a register. -If the register contains a file name, find that file. - \(To put a file name in a register, you must use `set-register'.) -If the register contains a window configuration (one frame) or a frame -configuration (all frames), restore that frame or all frames accordingly. -First argument is a character, naming the register. -Optional second arg non-nil (interactively, prefix argument) says to -delete any existing frames that the frame configuration doesn't mention. -\(Otherwise, these frames are iconified.)" - (interactive "cJump to register: \nP") - (let ((val (get-register register))) - (cond - ((and (fboundp 'frame-configuration-p) - (frame-configuration-p val)) - (set-frame-configuration val (not delete))) - ((window-configuration-p val) - (set-window-configuration val)) - ((markerp val) - (or (marker-buffer val) - (error "That register's buffer no longer exists")) - (switch-to-buffer (marker-buffer val)) - (goto-char val)) - ((and (consp val) (eq (car val) 'file)) - (find-file (cdr val))) - ((and (consp val) (eq (car val) 'file-query)) - (or (find-buffer-visiting (nth 1 val)) - (y-or-n-p (format "Visit file %s again? " (nth 1 val))) - (error "Register access aborted")) - (find-file (nth 1 val)) - (goto-char (nth 2 val))) - (t - (error "Register doesn't contain a buffer position or configuration"))))) - -;; Turn markers into file-query references when a buffer is killed. -(defun register-swap-out () - (and buffer-file-name - (let ((tail register-alist)) - (while tail - (and (markerp (cdr (car tail))) - (eq (marker-buffer (cdr (car tail))) (current-buffer)) - (setcdr (car tail) - (list 'file-query - buffer-file-name - (marker-position (cdr (car tail)))))) - (setq tail (cdr tail)))))) - -(add-hook 'kill-buffer-hook 'register-swap-out) - -;(defun number-to-register (arg char) -; "Store a number in a register. -;Two args, NUMBER and REGISTER (a character, naming the register). -;If NUMBER is nil, digits in the buffer following point are read -;to get the number to store. -;Interactively, NUMBER is the prefix arg (none means nil)." -; (interactive "P\ncNumber to register: ") -; (set-register char -; (if arg -; (prefix-numeric-value arg) -; (if (looking-at "[0-9][0-9]*") -; (save-excursion -; (save-restriction -; (narrow-to-region (point) -; (progn (skip-chars-forward "0-9") -; (point))) -; (goto-char (point-min)) -; (read (current-buffer)))) -; 0)))) - -;(defun increment-register (arg char) -; "Add NUMBER to the contents of register REGISTER. -;Interactively, NUMBER is the prefix arg (none means nil)." -; (interactive "p\ncNumber to register: ") -; (or (integerp (get-register char)) -; (error "Register does not contain a number")) -; (set-register char (+ arg (get-register char)))) - -(defun view-register (register) - "Display what is contained in register named REGISTER. -The Lisp value REGISTER is a character." - (interactive "cView register: ") - (let ((val (get-register register))) - (if (null val) - (message "Register %s is empty" (single-key-description register)) - (with-output-to-temp-buffer "*Output*" - (princ "Register ") - (princ (single-key-description register)) - (princ " contains ") - (cond - ((integerp val) - (princ val)) - - ((markerp val) - (let ((buf (marker-buffer val))) - (if (null buf) - (princ "a marker in no buffer") - (princ "a buffer position:\nbuffer ") - (princ (buffer-name buf)) - (princ ", position ") - (princ (marker-position val))))) - - ((window-configuration-p val) - (princ "a window configuration.")) - - ((frame-configuration-p val) - (princ "a frame configuration.")) - - ((and (consp val) (eq (car val) 'file)) - (princ "the file ") - (prin1 (cdr val)) - (princ ".")) - - ((consp val) - (princ "the rectangle:\n") - (while val - (princ (car val)) - (terpri) - (setq val (cdr val)))) - - ((stringp val) - (princ "the text:\n") - (princ val)) - - (t - (princ "Garbage:\n") - (prin1 val))))))) - -(defun insert-register (register &optional arg) - "Insert contents of register REGISTER. (REGISTER is a character.) -Normally puts point before and mark after the inserted text. -If optional second arg is non-nil, puts mark before and point after. -Interactively, second arg is non-nil if prefix arg is supplied." - (interactive "*cInsert register: \nP") - (push-mark) - (let ((val (get-register register))) - (cond - ((consp val) - (insert-rectangle val)) - ((stringp val) - (insert val)) - ((integerp val) - (princ val (current-buffer))) - ((and (markerp val) (marker-position val)) - (princ (marker-position val) (current-buffer))) - (t - (error "Register does not contain text")))) - (if (not arg) (exchange-point-and-mark))) - -(defun copy-to-register (register start end &optional delete-flag) - "Copy region into register REGISTER. With prefix arg, delete as well. -Called from program, takes four args: REGISTER, START, END and DELETE-FLAG. -START and END are buffer positions indicating what to copy." - (interactive "cCopy to register: \nr\nP") - (set-register register (buffer-substring start end)) - (if delete-flag (delete-region start end))) - -(defun append-to-register (register start end &optional delete-flag) - "Append region to text in register REGISTER. -With prefix arg, delete as well. -Called from program, takes four args: REGISTER, START, END and DELETE-FLAG. -START and END are buffer positions indicating what to append." - (interactive "cAppend to register: \nr\nP") - (or (stringp (get-register register)) - (error "Register does not contain text")) - (set-register register (concat (get-register register) - (buffer-substring start end))) - (if delete-flag (delete-region start end))) - -(defun prepend-to-register (register start end &optional delete-flag) - "Prepend region to text in register REGISTER. -With prefix arg, delete as well. -Called from program, takes four args: REGISTER, START, END and DELETE-FLAG. -START and END are buffer positions indicating what to prepend." - (interactive "cPrepend to register: \nr\nP") - (or (stringp (get-register register)) - (error "Register does not contain text")) - (set-register register (concat (buffer-substring start end) - (get-register register))) - (if delete-flag (delete-region start end))) - -(defun copy-rectangle-to-register (register start end &optional delete-flag) - "Copy rectangular region into register REGISTER. -With prefix arg, delete as well. -Called from program, takes four args: REGISTER, START, END and DELETE-FLAG. -START and END are buffer positions giving two corners of rectangle." - (interactive "cCopy rectangle to register: \nr\nP") - (set-register register - (if delete-flag - (delete-extract-rectangle start end) - (extract-rectangle start end)))) - -;;; register.el ends here
--- a/lisp/prim/replace.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,836 +0,0 @@ -;;; replace.el --- search and replace commands for XEmacs. - -;; Copyright (C) 1985, 1986, 1987, 1992, 1994 Free Software Foundation, Inc. - -;; 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.34 [Partially]. - -;;; Commentary: - -;; This package supplies the string and regular-expression replace functions -;; documented in the XEmacs Reference Manual. - -;; All the gettext calls are for XEmacs I18N3 message catalog support. - -;;; Code: - -(defvar case-replace t "\ -*Non-nil means `query-replace' should preserve case in replacements. -What this means is that `query-replace' will change the case of the -replacement text so that it matches the text that was replaced. -If this variable is nil, the replacement text will be inserted -exactly as it was specified by the user, irrespective of the case -of the text that was replaced. - -Note that this flag has no effect if `case-fold-search' is nil, -or if the replacement text has any uppercase letters in it.") - -(defvar query-replace-history nil) - -(defvar query-replace-interactive nil - "Non-nil means `query-replace' uses the last search string. -That becomes the \"string to replace\".") - -(defun query-replace-read-args (string regexp-flag) - (let (from to) - (if query-replace-interactive - (setq from (car (if regexp-flag regexp-search-ring search-ring))) - (setq from (read-from-minibuffer (format "%s: " (gettext string)) - nil nil nil - 'query-replace-history))) - (setq to (read-from-minibuffer (format "%s %s with: " (gettext string) - from) - nil nil nil - 'query-replace-history)) - (list from to current-prefix-arg))) - -(defun query-replace (from-string to-string &optional arg) - "Replace some occurrences of FROM-STRING with TO-STRING. -As each match is found, the user must type a character saying -what to do with it. For directions, type \\[help-command] at that time. - -If `query-replace-interactive' is non-nil, the last incremental search -string is used as FROM-STRING--you don't have to specify it with the -minibuffer. - -Preserves case in each replacement if `case-replace' and `case-fold-search' -are non-nil and FROM-STRING has no uppercase letters. -\(Preserving case means that if the string matched is all caps, or capitalized, -then its replacement is upcased or capitalized.) - -Third arg DELIMITED (prefix arg if interactive), if non-nil, means replace -only matches surrounded by word boundaries. - -To customize possible responses, change the \"bindings\" in `query-replace-map'." - (interactive (query-replace-read-args "Query replace" nil)) - (perform-replace from-string to-string t nil arg)) - -(defun query-replace-regexp (regexp to-string &optional arg) - "Replace some things after point matching REGEXP with TO-STRING. -As each match is found, the user must type a character saying -what to do with it. For directions, type \\[help-command] at that time. - -If `query-replace-interactive' is non-nil, the last incremental search -regexp is used as REGEXP--you don't have to specify it with the -minibuffer. - -Preserves case in each replacement if `case-replace' and `case-fold-search' -are non-nil and REGEXP has no uppercase letters. -Third arg DELIMITED (prefix arg if interactive), if non-nil, means replace -only matches surrounded by word boundaries. -In TO-STRING, `\\&' stands for whatever matched the whole of REGEXP, -and `\\=\\N' (where N is a digit) stands for - whatever what matched the Nth `\\(...\\)' in REGEXP." - (interactive (query-replace-read-args "Query replace regexp" t)) - (perform-replace regexp to-string t t arg)) - -;;#### Not patently useful -(defun map-query-replace-regexp (regexp to-strings &optional arg) - "Replace some matches for REGEXP with various strings, in rotation. -The second argument TO-STRINGS contains the replacement strings, separated -by spaces. This command works like `query-replace-regexp' except -that each successive replacement uses the next successive replacement string, -wrapping around from the last such string to the first. - -Non-interactively, TO-STRINGS may be a list of replacement strings. - -If `query-replace-interactive' is non-nil, the last incremental search -regexp is used as REGEXP--you don't have to specify it with the minibuffer. - -A prefix argument N says to use each replacement string N times -before rotating to the next." - (interactive - (let (from to) - (setq from (if query-replace-interactive - (car regexp-search-ring) - (read-from-minibuffer "Map query replace (regexp): " - nil nil nil - 'query-replace-history))) - (setq to (read-from-minibuffer - (format "Query replace %s with (space-separated strings): " - from) - nil nil nil - 'query-replace-history)) - (list from to current-prefix-arg))) - (let (replacements) - (if (listp to-strings) - (setq replacements to-strings) - (while (/= (length to-strings) 0) - (if (string-match " " to-strings) - (setq replacements - (append replacements - (list (substring to-strings 0 - (string-match " " to-strings)))) - to-strings (substring to-strings - (1+ (string-match " " to-strings)))) - (setq replacements (append replacements (list to-strings)) - to-strings "")))) - (perform-replace regexp replacements t t nil arg))) - -(defun replace-string (from-string to-string &optional delimited) - "Replace occurrences of FROM-STRING with TO-STRING. -Preserve case in each match if `case-replace' and `case-fold-search' -are non-nil and FROM-STRING has no uppercase letters. -\(Preserving case means that if the string matched is all caps, or capitalized, -then its replacement is upcased or capitalized.) - -Third arg DELIMITED (prefix arg if interactive), if non-nil, means replace -only matches surrounded by word boundaries. - -If `query-replace-interactive' is non-nil, the last incremental search -string is used as FROM-STRING--you don't have to specify it with the -minibuffer. - -This function is usually the wrong thing to use in a Lisp program. -What you probably want is a loop like this: - (while (search-forward FROM-STRING nil t) - (replace-match TO-STRING nil t)) -which will run faster and will not set the mark or print anything." - (interactive (query-replace-read-args "Replace string" nil)) - (perform-replace from-string to-string nil nil delimited)) - -(defun replace-regexp (regexp to-string &optional delimited) - "Replace things after point matching REGEXP with TO-STRING. -Preserve case in each match if `case-replace' and `case-fold-search' -are non-nil and REGEXP has no uppercase letters. -\(Preserving case means that if the string matched is all caps, or capitalized, -then its replacement is upcased or capitalized.) - -Third arg DELIMITED (prefix arg if interactive), if non-nil, means replace -only matches surrounded by word boundaries. -In TO-STRING, `\\&' stands for whatever matched the whole of REGEXP, -and `\\=\\N' (where N is a digit) stands for - whatever what matched the Nth `\\(...\\)' in REGEXP. - -If `query-replace-interactive' is non-nil, the last incremental search -regexp is used as REGEXP--you don't have to specify it with the minibuffer. - -This function is usually the wrong thing to use in a Lisp program. -What you probably want is a loop like this: - (while (re-search-forward REGEXP nil t) - (replace-match TO-STRING nil nil)) -which will run faster and will not set the mark or print anything." - (interactive (query-replace-read-args "Replace regexp" t)) - (perform-replace regexp to-string nil t delimited)) - - -(defvar regexp-history nil - "History list for some commands that read regular expressions.") - -(define-function 'keep-lines 'delete-non-matching-lines) -(defun delete-non-matching-lines (regexp) - "Delete all lines except those containing matches for REGEXP. -A match split across lines preserves all the lines it lies in. -Applies to all lines after point." - (interactive (list (read-from-minibuffer - "Keep lines (containing match for regexp): " - nil nil nil 'regexp-history))) - (save-excursion - (or (bolp) (forward-line 1)) - (let ((start (point))) - (while (not (eobp)) - ;; Start is first char not preserved by previous match. - (if (not (re-search-forward regexp nil 'move)) - (delete-region start (point-max)) - (let ((end (save-excursion (goto-char (match-beginning 0)) - (beginning-of-line) - (point)))) - ;; Now end is first char preserved by the new match. - (if (< start end) - (delete-region start end)))) - (setq start (save-excursion (forward-line 1) - (point))) - ;; If the match was empty, avoid matching again at same place. - (and (not (eobp)) (= (match-beginning 0) (match-end 0)) - (forward-char 1)))))) - -(define-function 'flush-lines 'delete-matching-lines) -(defun delete-matching-lines (regexp) - "Delete lines containing matches for REGEXP. -If a match is split across lines, all the lines it lies in are deleted. -Applies to lines after point." - (interactive (list (read-from-minibuffer - "Flush lines (containing match for regexp): " - nil nil nil 'regexp-history))) - (save-excursion - (while (and (not (eobp)) - (re-search-forward regexp nil t)) - (delete-region (save-excursion (goto-char (match-beginning 0)) - (beginning-of-line) - (point)) - (progn (forward-line 1) (point)))))) - -(define-function 'how-many 'count-matches) -(defun count-matches (regexp) - "Print number of matches for REGEXP following point." - (interactive (list (read-from-minibuffer - "How many matches for (regexp): " - nil nil nil 'regexp-history))) - (let ((count 0) opoint) - (save-excursion - (while (and (not (eobp)) - (progn (setq opoint (point)) - (re-search-forward regexp nil t))) - (if (= opoint (point)) - (forward-char 1) - (setq count (1+ count)))) - (message "%d occurrences" count)))) - - -(defvar occur-mode-map ()) -(if occur-mode-map - () - (setq occur-mode-map (make-sparse-keymap)) - (set-keymap-name occur-mode-map 'occur-mode-map) ; XEmacs - (define-key occur-mode-map 'button2 'occur-mode-mouse-goto) ; XEmacs - (define-key occur-mode-map "\C-c\C-c" 'occur-mode-goto-occurrence) - (define-key occur-mode-map "\C-m" 'occur-mode-goto-occurrence)) - -(defvar occur-buffer nil) -(defvar occur-nlines nil) -(defvar occur-pos-list nil) - -(defun occur-mode () - "Major mode for output from \\[occur]. -\\<occur-mode-map>Move point to one of the items in this buffer, then use -\\[occur-mode-goto-occurrence] to go to the occurrence that the item refers to. -Alternatively, click \\[occur-mode-mouse-goto] on an item to go to it. - -\\{occur-mode-map}" - (kill-all-local-variables) - (use-local-map occur-mode-map) - (setq major-mode 'occur-mode) - (setq mode-name (gettext "Occur")) ; XEmacs - (make-local-variable 'occur-buffer) - (make-local-variable 'occur-nlines) - (make-local-variable 'occur-pos-list) - (require 'mode-motion) ; XEmacs - (setq mode-motion-hook 'mode-motion-highlight-line) ; XEmacs - (run-hooks 'occur-mode-hook)) - -;; FSF Version of next function: -; (let (buffer pos) -; (save-excursion -; (set-buffer (window-buffer (posn-window (event-end event)))) -; (save-excursion -; (goto-char (posn-point (event-end event))) -; (setq pos (occur-mode-find-occurrence)) -; (setq buffer occur-buffer))) -; (pop-to-buffer buffer) -; (goto-char (marker-position pos)))) - -(defun occur-mode-mouse-goto (event) - "Go to the occurrence highlighted by mouse. -This function is only reasonable when bound to a mouse key in the occur buffer" - (interactive "e") - (let ((window-save (selected-window)) - (frame-save (selected-frame))) - ;; preserve the window/frame setup - (unwind-protect - (progn - (mouse-set-point event) - (occur-mode-goto-occurrence)) - (select-frame frame-save) - (select-window window-save)))) - -;; Called occur-mode-find-occurrence in FSF -(defun occur-mode-goto-occurrence () - "Go to the occurrence the current line describes." - (interactive) - (if (or (null occur-buffer) - (null (buffer-name occur-buffer))) - (progn - (setq occur-buffer nil - occur-pos-list nil) - (error "Buffer in which occurrences were found is deleted"))) - (let* ((line-count - (count-lines (point-min) - (save-excursion - (beginning-of-line) - (point)))) - (occur-number (save-excursion - (beginning-of-line) - (/ (1- line-count) - (cond ((< occur-nlines 0) - (- 2 occur-nlines)) - ((> occur-nlines 0) - (+ 2 (* 2 occur-nlines))) - (t 1))))) - (pos (nth occur-number occur-pos-list)) - ;; removed t arg from Bob Weiner, 10/6/95 - (window (get-buffer-window occur-buffer)) - (occur-source-buffer occur-buffer)) - (if (< line-count 1) - (error "No occurrence on this line")) - (or pos - (error "No occurrence on this line")) - ;; XEmacs: don't raise window unless it isn't visible - ;; allow for the possibility that the occur buffer is on another frame - (or (and window - (window-live-p window) - (frame-visible-p (window-frame window)) - (set-buffer occur-source-buffer)) - (and (pop-to-buffer occur-source-buffer) - (setq window (get-buffer-window occur-source-buffer)))) - (goto-char pos) - (set-window-point window pos))) - - -(defvar list-matching-lines-default-context-lines 0 - "*Default number of context lines to include around a `list-matching-lines' -match. A negative number means to include that many lines before the match. -A positive number means to include that many lines both before and after.") - -;; XEmacs addition -;;; Damn you Jamie, this is utter trash. -(defvar list-matching-lines-whole-buffer t - "If t, occur operates on whole buffer, otherwise occur starts from point. -default is t.") - -(define-function 'occur 'list-matching-lines) -(defun list-matching-lines (regexp &optional nlines) - "Show all lines in the current buffer containing a match for REGEXP. - -If a match spreads across multiple lines, all those lines are shown. - -If variable `list-matching-lines-whole-buffer' is non-nil, the entire buffer is -searched, otherwise search begins at point. - -Each line is displayed with NLINES lines before and after, or -NLINES -before if NLINES is negative. -NLINES defaults to `list-matching-lines-default-context-lines'. -Interactively it is the prefix arg. - -The lines are shown in a buffer named `*Occur*'. -It serves as a menu to find any of the occurrences in this buffer. -\\[describe-mode] in that buffer will explain how." - (interactive - ;; XEmacs change - (list (let* ((default (or (symbol-near-point) - (and regexp-history - (car regexp-history)))) - (minibuffer-history-minimum-string-length 0) - (input - (if default - ;; rewritten for I18N3 snarfing - (read-from-minibuffer - (format "List lines matching regexp (default `%s'): " - default) nil nil nil 'regexp-history) - (read-from-minibuffer - "List lines matching regexp: " - nil nil nil - 'regexp-history)))) - (if (and (equal input "") default) - (progn - (setq input default) - (setcar regexp-history default))) - ;; clear extra entries - (setcdr regexp-history (delete (car regexp-history) - (cdr regexp-history))) - input) - current-prefix-arg)) - (if (equal regexp "") - (error "Must pass non-empty regexp to `list-matching-lines'")) - (setq nlines (if nlines (prefix-numeric-value nlines) - list-matching-lines-default-context-lines)) - (let ((first t) - (dir default-directory) - (buffer (current-buffer)) - (linenum 1) - (prevpos (point-min)) - ;; The rest of this function is very different from FSF. - ;; Presumably that's due to Jamie's misfeature - (final-context-start (make-marker))) - (if (not list-matching-lines-whole-buffer) - (save-excursion - (beginning-of-line) - (setq linenum (1+ (count-lines (point-min) (point)))) - (setq prevpos (point)))) - (with-output-to-temp-buffer "*Occur*" - (save-excursion - (set-buffer standard-output) - (setq default-directory dir) - ;; We will insert the number of lines, and "lines", later. - ;; #### Needs fixing for I18N3 - (let ((print-escape-newlines t)) - (insert (format " matching %s in buffer %s.\n" - regexp (buffer-name buffer)))) - (occur-mode) - (setq occur-buffer buffer) - (setq occur-nlines nlines) - (setq occur-pos-list ())) - (if (eq buffer standard-output) - (goto-char (point-max))) - (save-excursion - (if list-matching-lines-whole-buffer - (beginning-of-buffer)) - (message "Searching for %s ..." regexp) - ;; Find next match, but give up if prev match was at end of buffer. - (while (and (not (= prevpos (point-max))) - (re-search-forward regexp nil t)) - (goto-char (match-beginning 0)) - (beginning-of-line) - (save-match-data - (setq linenum (+ linenum (count-lines prevpos (point))))) - (setq prevpos (point)) - (goto-char (match-end 0)) - (let* ((start (save-excursion - (goto-char (match-beginning 0)) - (forward-line (if (< nlines 0) nlines (- nlines))) - (point))) - (end (save-excursion - (goto-char (match-end 0)) - (if (> nlines 0) - (forward-line (1+ nlines)) - (forward-line 1)) - (point))) - (tag (format "%5d" linenum)) - (empty (make-string (length tag) ?\ )) - tem) - (save-excursion - (setq tem (make-marker)) - (set-marker tem (point)) - (set-buffer standard-output) - (setq occur-pos-list (cons tem occur-pos-list)) - (or first (zerop nlines) - (insert "--------\n")) - (setq first nil) - (insert-buffer-substring buffer start end) - (set-marker final-context-start - (- (point) (- end (match-end 0)))) - (backward-char (- end start)) - (setq tem (if (< nlines 0) (- nlines) nlines)) - (while (> tem 0) - (insert empty ?:) - (forward-line 1) - (setq tem (1- tem))) - (let ((this-linenum linenum)) - (while (< (point) final-context-start) - (if (null tag) - (setq tag (format "%5d" this-linenum))) - (insert tag ?:) -;; FSFmacs -- we handle this using mode-motion-highlight-line, above. -; (put-text-property (save-excursion -; (beginning-of-line) -; (point)) -; (save-excursion -; (end-of-line) -; (point)) -; 'mouse-face 'highlight) - (forward-line 1) - (setq tag nil) - (setq this-linenum (1+ this-linenum))) - (while (<= (point) final-context-start) - (insert empty ?:) - (forward-line 1) - (setq this-linenum (1+ this-linenum)))) - (while (< tem nlines) - (insert empty ?:) - (forward-line 1) - (setq tem (1+ tem))) - (goto-char (point-max))) - (forward-line 1))) - (set-buffer standard-output) - ;; Put positions in increasing order to go with buffer. - (setq occur-pos-list (nreverse occur-pos-list)) - (goto-char (point-min)) - (if (= (length occur-pos-list) 1) - (insert "1 line") - (insert (format "%d lines" (length occur-pos-list)))) - (if (interactive-p) - (message "%d matching lines." (length occur-pos-list))))))) - -;; It would be nice to use \\[...], but there is no reasonable way -;; to make that display both SPC and Y. -(defconst query-replace-help - (purecopy - "Type Space or `y' to replace one match, Delete or `n' to skip to next, -RET or `q' to exit, Period to replace one match and exit, -Comma to replace but not move point immediately, -C-r to enter recursive edit (\\[exit-recursive-edit] to get out again), -C-w to delete match and recursive edit, -C-l to clear the frame, redisplay, and offer same replacement again, -! to replace all remaining matches with no more questions, -^ to move point back to previous match." -) - "Help message while in query-replace") - -(defvar query-replace-map nil - "Keymap that defines the responses to questions in `query-replace'. -The \"bindings\" in this map are not commands; they are answers. -The valid answers include `act', `skip', `act-and-show', -`exit', `act-and-exit', `edit', `delete-and-edit', `recenter', -`automatic', `backup', `exit-prefix', and `help'.") - -;; Why does it seem that ever file has a different method of doing this? -(if query-replace-map - nil - (let ((map (make-sparse-keymap))) - (set-keymap-name map 'query-replace-map) - (define-key map " " 'act) - (define-key map "\d" 'skip) - (define-key map [delete] 'skip) - (define-key map [backspace] 'skip) - (define-key map "y" 'act) - (define-key map "n" 'skip) - (define-key map "Y" 'act) - (define-key map "N" 'skip) - (define-key map "," 'act-and-show) - (define-key map [escape] 'exit) - (define-key map "q" 'exit) - (define-key map [return] 'exit) - (define-key map "." 'act-and-exit) - (define-key map "\C-r" 'edit) - (define-key map "\C-w" 'delete-and-edit) - (define-key map "\C-l" 'recenter) - (define-key map "!" 'automatic) - (define-key map "^" 'backup) - (define-key map [(control h)] 'help) ;; XEmacs change - (define-key map [f1] 'help) - (define-key map [help] 'help) - (define-key map "?" 'help) - (define-key map "\C-g" 'quit) - (define-key map "\C-]" 'quit) - ;FSFmacs (define-key map "\e" 'exit-prefix) - (define-key map [escape] 'exit-prefix) - - (setq query-replace-map map))) - - -(autoload 'isearch-highlight "isearch") - -;; XEmacs -(defun perform-replace-next-event (event) - (if isearch-highlight - (let ((aborted t)) - (unwind-protect - (progn - (if (match-beginning 0) - (isearch-highlight (match-beginning 0) (match-end 0))) - (next-command-event event) - (setq aborted nil)) - (isearch-dehighlight aborted))) - (next-command-event event))) - -(defun perform-replace (from-string replacements - query-flag regexp-flag delimited-flag - &optional repeat-count map) - "Subroutine of `query-replace'. Its complexity handles interactive queries. -Don't use this in your own program unless you want to query and set the mark -just as `query-replace' does. Instead, write a simple loop like this: - (while (re-search-forward \"foo[ \t]+bar\" nil t) - (replace-match \"foobar\" nil nil)) -which will run faster and probably do exactly what you want." - (or map (setq map query-replace-map)) - (let* ((event (make-event)) - (nocasify (not (and case-fold-search case-replace - (string-equal from-string - (downcase from-string))))) - (literal (not regexp-flag)) - (search-function (if regexp-flag 're-search-forward 'search-forward)) - (search-string from-string) - (real-match-data nil) ; the match data for the current match - (next-replacement nil) - (replacement-index 0) - (keep-going t) - (stack nil) - (next-rotate-count 0) - (replace-count 0) - (lastrepl nil) ;Position after last match considered. - (match-again t) - ;; XEmacs addition - (qr-case-fold-search - (if (and case-fold-search search-caps-disable-folding) - (isearch-no-upper-case-p search-string) - case-fold-search)) - (message - (if query-flag - (substitute-command-keys - "Query replacing %s with %s: (\\<query-replace-map>\\[help] for help) ")))) - (if (stringp replacements) - (setq next-replacement replacements) - (or repeat-count (setq repeat-count 1))) - (if delimited-flag - (setq search-function 're-search-forward - search-string (concat "\\b" - (if regexp-flag from-string - (regexp-quote from-string)) - "\\b"))) - (push-mark) - (undo-boundary) - (unwind-protect - ;; Loop finding occurrences that perhaps should be replaced. - (while (and keep-going - (not (eobp)) - (let ((case-fold-search qr-case-fold-search)) - (funcall search-function search-string nil t)) - ;; If the search string matches immediately after - ;; the previous match, but it did not match there - ;; before the replacement was done, ignore the match. - (if (or (eq lastrepl (point)) - (and regexp-flag - (eq lastrepl (match-beginning 0)) - (not match-again))) - (if (eobp) - nil - ;; Don't replace the null string - ;; right after end of previous replacement. - (forward-char 1) - (let ((case-fold-search qr-case-fold-search)) - (funcall search-function search-string nil t))) - t)) - - ;; Save the data associated with the real match. - (setq real-match-data (match-data)) - - ;; Before we make the replacement, decide whether the search string - ;; can match again just after this match. - (if regexp-flag - (progn - (setq match-again (looking-at search-string)) - ;; XEmacs addition - (store-match-data real-match-data))) - ;; If time for a change, advance to next replacement string. - (if (and (listp replacements) - (= next-rotate-count replace-count)) - (progn - (setq next-rotate-count - (+ next-rotate-count repeat-count)) - (setq next-replacement (nth replacement-index replacements)) - (setq replacement-index (% (1+ replacement-index) (length replacements))))) - (if (not query-flag) - (progn - (store-match-data real-match-data) - (replace-match next-replacement nocasify literal) - (setq replace-count (1+ replace-count))) - (undo-boundary) - (let ((help-form - '(concat (format "Query replacing %s%s with %s.\n\n" - (if regexp-flag (gettext "regexp ") "") - from-string next-replacement) - (substitute-command-keys query-replace-help))) - done replaced def) - ;; Loop reading commands until one of them sets done, - ;; which means it has finished handling this occurrence. - (while (not done) - ;; Don't fill up the message log - ;; with a bunch of identical messages. - ;; XEmacs change - (display-message 'prompt - (format message from-string next-replacement)) - (perform-replace-next-event event) - (setq def (lookup-key map (vector event))) - ;; Restore the match data while we process the command. - (store-match-data real-match-data) - (cond ((eq def 'help) - (with-output-to-temp-buffer (gettext "*Help*") - (princ (concat - (format "Query replacing %s%s with %s.\n\n" - (if regexp-flag "regexp " "") - from-string next-replacement) - (substitute-command-keys - query-replace-help))) - (save-excursion - (set-buffer standard-output) - (help-mode)))) - ((eq def 'exit) - (setq keep-going nil) - (setq done t)) - ((eq def 'backup) - (if stack - (let ((elt (car stack))) - (goto-char (car elt)) - (setq replaced (eq t (cdr elt))) - (or replaced - (store-match-data (cdr elt))) - (setq stack (cdr stack))) - (message "No previous match") - (ding 'no-terminate) - (sit-for 1))) - ((eq def 'act) - (or replaced - (replace-match next-replacement nocasify literal)) - (setq done t replaced t)) - ((eq def 'act-and-exit) - (or replaced - (replace-match next-replacement nocasify literal)) - (setq keep-going nil) - (setq done t replaced t)) - ((eq def 'act-and-show) - (if (not replaced) - (progn - (replace-match next-replacement nocasify literal) - (store-match-data nil) - (setq replaced t)))) - ((eq def 'automatic) - (or replaced - (replace-match next-replacement nocasify literal)) - (setq done t query-flag nil replaced t)) - ((eq def 'skip) - (setq done t)) - ((eq def 'recenter) - (recenter nil)) - ((eq def 'edit) - (store-match-data - (prog1 (match-data) - (save-excursion (recursive-edit)))) - ;; Before we make the replacement, - ;; decide whether the search string - ;; can match again just after this match. - (if regexp-flag - (setq match-again (looking-at search-string)))) - ((eq def 'delete-and-edit) - (delete-region (match-beginning 0) (match-end 0)) - (store-match-data (prog1 (match-data) - (save-excursion (recursive-edit)))) - (setq replaced t)) - ;; Note: we do not need to treat `exit-prefix' - ;; specially here, since we reread - ;; any unrecognized character. - (t - (setq this-command 'mode-exited) - (setq keep-going nil) - (setq unread-command-events - (cons event unread-command-events)) - (setq done t)))) - ;; Record previous position for ^ when we move on. - ;; Change markers to numbers in the match data - ;; since lots of markers slow down editing. - (setq stack - (cons (cons (point) - (or replaced - (mapcar - #'(lambda (elt) - (if (markerp elt) - (prog1 (marker-position elt) - (set-marker elt nil)) - elt)) - (match-data)))) - stack)) - (if replaced (setq replace-count (1+ replace-count))))) - (setq lastrepl (point))) - (replace-dehighlight)) - (or unread-command-events - (message "Replaced %d occurrence%s" - replace-count - (if (= replace-count 1) "" "s"))) - (and keep-going stack))) - -(defvar query-replace-highlight nil - "*Non-nil means to highlight words during query replacement.") - -(defvar replace-overlay nil) - -(defun replace-dehighlight () - (and replace-overlay - (progn - (delete-overlay replace-overlay) - (setq replace-overlay nil)))) - -(defun replace-highlight (start end) - (and query-replace-highlight - (progn - (or replace-overlay - (progn - (setq replace-overlay (make-overlay start end)) - (overlay-put replace-overlay 'face - (if (internal-find-face 'query-replace) - 'query-replace 'region)))) - (move-overlay replace-overlay start end (current-buffer))))) - -(defun match-string (num &optional string) - "Return string of text matched by last search. -NUM specifies which parenthesized expression in the last regexp. - Value is nil if NUMth pair didn't match, or there were less than NUM pairs. -Zero means the entire text matched by the whole regexp or whole string. -STRING should be given if the last search was by `string-match' on STRING." - (if (match-beginning num) - (if string - (substring string (match-beginning num) (match-end num)) - (buffer-substring (match-beginning num) (match-end num))))) - -(defmacro save-match-data (&rest body) - "Execute BODY forms, restoring the global value of the match data." - (let ((original (make-symbol "match-data"))) - (list 'let (list (list original '(match-data))) - (list 'unwind-protect - (cons 'progn body) - (list 'store-match-data original))))) - -;;; replace.el ends here
--- a/lisp/prim/scrollbar.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,111 +0,0 @@ -;; Scrollbar support. -;; Copyright (C) 1995 Board of Trustees, University of Illinois - -;; 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, 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: Not in FSF. (Completely divergent from FSF scroll-bar.el) - -(defun init-scrollbar-from-resources (locale) - (when (and (featurep 'x) - (or (eq locale 'global) - (eq 'x (device-or-frame-type locale)))) - (x-init-scrollbar-from-resources locale))) - -;; -;; vertical scrollbar functions -;; - -;;; ### Move functions from C into Lisp here! - -;; -;; horizontal scrollbar functions -;; - -(defun scrollbar-char-left (window) - "Function called when the char-left arrow on the scrollbar is clicked. -This is the little arrow to the left of the scrollbar. One argument is -passed, the scrollbar's window. You can advise this function to -change the scrollbar behavior." - (when (window-live-p window) - (scrollbar-set-hscroll window (- (window-hscroll window) 1)) - (setq zmacs-region-stays t) - nil)) - -(defun scrollbar-char-right (window) - "Function called when the char-right arrow on the scrollbar is clicked. -This is the little arrow to the right of the scrollbar. One argument is -passed, the scrollbar's window. You can advise this function to -change the scrollbar behavior." - (when (window-live-p window) - (scrollbar-set-hscroll window (+ (window-hscroll window) 1)) - (setq zmacs-region-stays t) - nil)) - -(defun scrollbar-page-left (window) - "Function called when the user gives the \"page-left\" scrollbar action. -\(The way this is done can vary from scrollbar to scrollbar.\) One argument is -passed, the scrollbar's window. You can advise this function to -change the scrollbar behavior." - (when (window-live-p window) - (scrollbar-set-hscroll window (- (window-hscroll window) - (- (window-width window) 2))) - (setq zmacs-region-stays t) - nil)) - -(defun scrollbar-page-right (window) - "Function called when the user gives the \"page-right\" scrollbar action. -\(The way this is done can vary from scrollbar to scrollbar.\) One argument is -passed, the scrollbar's window. You can advise this function to -change the scrollbar behavior." - (when (window-live-p window) - (scrollbar-set-hscroll window (+ (window-hscroll window) - (- (window-width window) 2))) - (setq zmacs-region-stays t) - nil)) - -(defun scrollbar-to-left (window) - "Function called when the user gives the \"to-left\" scrollbar action. -\(The way this is done can vary from scrollbar to scrollbar.\). One argument is -passed, the scrollbar's window. You can advise this function to -change the scrollbar behavior." - (when (window-live-p window) - (scrollbar-set-hscroll window 0) - (setq zmacs-region-stays t) - nil)) - -(defun scrollbar-to-right (window) - "Function called when the user gives the \"to-right\" scrollbar action. -\(The way this is done can vary from scrollbar to scrollbar.\). One argument is -passed, the scrollbar's window. You can advise this function to -change the scrollbar behavior." - (when (window-live-p window) - (scrollbar-set-hscroll window 'max) - (setq zmacs-region-stays t) - nil)) - -(defun scrollbar-horizontal-drag (data) - "Function called when the user drags the horizontal scrollbar thumb. -One argument is passed, a cons containing the scrollbar's window and a value -representing how many columns the thumb is slid over. You can advise -this function to change the scrollbar behavior." - (let ((window (car data)) - (value (cdr data))) - (when (and (window-live-p window) (integerp value)) - (scrollbar-set-hscroll window value) - (setq zmacs-region-stays t) - nil)))
--- a/lisp/prim/simple.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,3798 +0,0 @@ -;;; simple.el --- basic editing commands for XEmacs - -;; Copyright (C) 1985, 1986, 1987, 1993-1995 Free Software Foundation, Inc. -;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp. - -;; 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.34 [But not very closely]. - -;;; Commentary: - -;; A grab-bag of basic XEmacs commands not specifically related to some -;; major mode or to file-handling. - -;; Changes for zmacs-style active-regions: -;; -;; beginning-of-buffer, end-of-buffer, count-lines-region, -;; count-lines-buffer, what-line, what-cursor-position, set-goal-column, -;; set-fill-column, prefix-arg-internal, and line-move (which is used by -;; next-line and previous-line) set zmacs-region-stays to t, so that they -;; don't affect the current region-hilighting state. -;; -;; mark-whole-buffer, mark-word, exchange-point-and-mark, and -;; set-mark-command (without an argument) call zmacs-activate-region. -;; -;; mark takes an optional arg like the new Fmark_marker() does. When -;; the region is not active, mark returns nil unless the optional arg is true. -;; -;; push-mark, pop-mark, exchange-point-and-mark, and set-marker, and -;; set-mark-command use (mark t) so that they can access the mark whether -;; the region is active or not. -;; -;; shell-command, shell-command-on-region, yank, and yank-pop (which all -;; push a mark) have been altered to call exchange-point-and-mark with an -;; argument, meaning "don't activate the region". These commands only use -;; exchange-point-and-mark to position the newly-pushed mark correctly, so -;; this isn't a user-visible change. These functions have also been altered -;; to use (mark t) for the same reason. - -;; 97/3/14 Jareth Hein (jhod@po.iijnet.or.jp) added kinsoku processing (support -;; for filling of Asian text) into the fill code. This was ripped bleeding from -;; Mule-2.3, and could probably use some feature additions (like additional wrap -;; styles, etc) - -;; 97/06/11 Steve Baur (steve@altair.xemacs.org) Convert use of -;; (preceding|following)-char to char-(after|before). - -;;; Code: - -(defgroup editing-basics nil - "Most basic editing variables." - :group 'editing) - -(defgroup killing nil - "Killing and yanking commands." - :group 'editing) - -(defgroup fill-comments nil - "Indenting and filling of comments." - :prefix "comment-" - :group 'fill) - -(defgroup paren-matching nil - "Highlight (un)matching of parens and expressions." - :prefix "paren-" - :group 'matching) - -(defgroup log-message nil - "Messages logging and display customizations." - :group 'minibuffer) - -(defgroup warnings nil - "Warnings customizations." - :group 'minibuffer) - - -(defun newline (&optional arg) - "Insert a newline, and move to left margin of the new line if it's blank. -The newline is marked with the text-property `hard'. -With arg, insert that many newlines. -In Auto Fill mode, if no numeric arg, break the preceding line if it's long." - (interactive "*P") - (barf-if-buffer-read-only nil (point)) - ;; Inserting a newline at the end of a line produces better redisplay in - ;; try_window_id than inserting at the beginning of a line, and the textual - ;; result is the same. So, if we're at beginning of line, pretend to be at - ;; the end of the previous line. - (let ((flag (and (not (bobp)) - (bolp) - ;; Make sure the newline before point isn't intangible. - (not (get-char-property (1- (point)) 'intangible)) - ;; Make sure the newline before point isn't read-only. - (not (get-char-property (1- (point)) 'read-only)) - ;; Make sure the newline before point isn't invisible. - (not (get-char-property (1- (point)) 'invisible)) - ;; This should probably also test for the previous char - ;; being the *last* character too. - (not (get-char-property (1- (point)) 'end-open)) - ;; Make sure the newline before point has the same - ;; properties as the char before it (if any). - (< (or (previous-extent-change (point)) -2) - (- (point) 2)))) - (was-page-start (and (bolp) - (looking-at page-delimiter))) - (beforepos (point))) - (if flag (backward-char 1)) - ;; Call self-insert so that auto-fill, abbrev expansion etc. happens. - ;; Set last-command-char to tell self-insert what to insert. - (let ((last-command-char ?\n) - ;; Don't auto-fill if we have a numeric argument. - ;; Also not if flag is true (it would fill wrong line); - ;; there is no need to since we're at BOL. - (auto-fill-function (if (or arg flag) nil auto-fill-function))) - (unwind-protect - (self-insert-command (prefix-numeric-value arg)) - ;; If we get an error in self-insert-command, put point at right place. - (if flag (forward-char 1)))) - ;; If we did *not* get an error, cancel that forward-char. - (if flag (backward-char 1)) - ;; Mark the newline(s) `hard'. - (if use-hard-newlines - (let* ((from (- (point) (if arg (prefix-numeric-value arg) 1))) - (sticky (get-text-property from 'end-open))) ; XEmacs - (put-text-property from (point) 'hard 't) - ;; If end-open is not "t", add 'hard to end-open list - (if (and (listp sticky) (not (memq 'hard sticky))) - (put-text-property from (point) 'end-open ; XEmacs - (cons 'hard sticky))))) - ;; If the newline leaves the previous line blank, - ;; and we have a left margin, delete that from the blank line. - (or flag - (save-excursion - (goto-char beforepos) - (beginning-of-line) - (and (looking-at "[ \t]$") - (> (current-left-margin) 0) - (delete-region (point) (progn (end-of-line) (point)))))) - (if flag (forward-char 1)) - ;; Indent the line after the newline, except in one case: - ;; when we added the newline at the beginning of a line - ;; which starts a page. - (or was-page-start - (move-to-left-margin nil t))) - nil) - -(defun open-line (arg) - "Insert a newline and leave point before it. -If there is a fill prefix and/or a left-margin, insert them on the new line -if the line would have been blank. -With arg N, insert N newlines." - (interactive "*p") - (let* ((do-fill-prefix (and fill-prefix (bolp))) - (do-left-margin (and (bolp) (> (current-left-margin) 0))) - (loc (point))) - (newline arg) - (goto-char loc) - (while (> arg 0) - (cond ((bolp) - (if do-left-margin (indent-to (current-left-margin))) - (if do-fill-prefix (insert fill-prefix)))) - (forward-line 1) - (setq arg (1- arg))) - (goto-char loc) - (end-of-line))) - -(defun split-line () - "Split current line, moving portion beyond point vertically down." - (interactive "*") - (skip-chars-forward " \t") - (let ((col (current-column)) - (pos (point))) - (newline 1) - (indent-to col 0) - (goto-char pos))) - -(defun quoted-insert (arg) - "Read next input character and insert it. -This is useful for inserting control characters. -You may also type up to 3 octal digits, to insert a character with that code. - -In overwrite mode, this function inserts the character anyway, and -does not handle octal digits specially. This means that if you use -overwrite as your normal editing mode, you can use this function to -insert characters when necessary. - -In binary overwrite mode, this function does overwrite, and octal -digits are interpreted as a character code. This is supposed to make -this function useful in editing binary files." - (interactive "*p") - (let ((char (if (or (not overwrite-mode) - (eq overwrite-mode 'overwrite-mode-binary)) - (read-quoted-char) - (read-char)))) - (if (> arg 0) - (if (eq overwrite-mode 'overwrite-mode-binary) - (delete-char arg))) - (while (> arg 0) - (insert char) - (setq arg (1- arg))))) - -(defun delete-indentation (&optional arg) - "Join this line to previous and fix up whitespace at join. -If there is a fill prefix, delete it from the beginning of this line. -With argument, join this line to following line." - (interactive "*P") - (beginning-of-line) - (if arg (forward-line 1)) - (if (eq (char-before (point)) ?\n) - (progn - (delete-region (point) (1- (point))) - ;; If the second line started with the fill prefix, - ;; delete the prefix. - (if (and fill-prefix - (<= (+ (point) (length fill-prefix)) (point-max)) - (string= fill-prefix - (buffer-substring (point) - (+ (point) (length fill-prefix))))) - (delete-region (point) (+ (point) (length fill-prefix)))) - (fixup-whitespace)))) - -(defun fixup-whitespace () - "Fixup white space between objects around point. -Leave one space or none, according to the context." - (interactive "*") - (save-excursion - (delete-horizontal-space) - (if (or (looking-at "^\\|\\s)") - (save-excursion (forward-char -1) - (looking-at "$\\|\\s(\\|\\s'"))) - nil - (insert ?\ )))) - -(defun delete-horizontal-space () - "Delete all spaces and tabs around point." - (interactive "*") - (skip-chars-backward " \t") - (delete-region (point) (progn (skip-chars-forward " \t") (point)))) - -(defun just-one-space () - "Delete all spaces and tabs around point, leaving one space." - (interactive "*") - (if abbrev-mode ; XEmacs - (expand-abbrev)) - (skip-chars-backward " \t") - (if (eq (char-after (point)) ? ) ; XEmacs - (forward-char 1) - (insert ? )) - (delete-region (point) (progn (skip-chars-forward " \t") (point)))) - -(defun delete-blank-lines () - "On blank line, delete all surrounding blank lines, leaving just one. -On isolated blank line, delete that one. -On nonblank line, delete any immediately following blank lines." - (interactive "*") - (let (thisblank singleblank) - (save-excursion - (beginning-of-line) - (setq thisblank (looking-at "[ \t]*$")) - ;; Set singleblank if there is just one blank line here. - (setq singleblank - (and thisblank - (not (looking-at "[ \t]*\n[ \t]*$")) - (or (bobp) - (progn (forward-line -1) - (not (looking-at "[ \t]*$"))))))) - ;; Delete preceding blank lines, and this one too if it's the only one. - (if thisblank - (progn - (beginning-of-line) - (if singleblank (forward-line 1)) - (delete-region (point) - (if (re-search-backward "[^ \t\n]" nil t) - (progn (forward-line 1) (point)) - (point-min))))) - ;; Delete following blank lines, unless the current line is blank - ;; and there are no following blank lines. - (if (not (and thisblank singleblank)) - (save-excursion - (end-of-line) - (forward-line 1) - (delete-region (point) - (if (re-search-forward "[^ \t\n]" nil t) - (progn (beginning-of-line) (point)) - (point-max))))) - ;; Handle the special case where point is followed by newline and eob. - ;; Delete the line, leaving point at eob. - (if (looking-at "^[ \t]*\n\\'") - (delete-region (point) (point-max))))) - -(defun back-to-indentation () - "Move point to the first non-whitespace character on this line." - ;; XEmacs change - (interactive "_") - (beginning-of-line 1) - (skip-chars-forward " \t")) - -(defun newline-and-indent () - "Insert a newline, then indent according to major mode. -Indentation is done using the value of `indent-line-function'. -In programming language modes, this is the same as TAB. -In some text modes, where TAB inserts a tab, this command indents to the -column specified by the function `current-left-margin'." - (interactive "*") - (delete-region (point) (progn (skip-chars-backward " \t") (point))) - (newline) - (indent-according-to-mode)) - -(defun reindent-then-newline-and-indent () - "Reindent current line, insert newline, then indent the new line. -Indentation of both lines is done according to the current major mode, -which means calling the current value of `indent-line-function'. -In programming language modes, this is the same as TAB. -In some text modes, where TAB inserts a tab, this indents to the -column specified by the function `current-left-margin'." - (interactive "*") - (save-excursion - (delete-region (point) (progn (skip-chars-backward " \t") (point))) - (indent-according-to-mode)) - (newline) - (indent-according-to-mode)) - -;; Internal subroutine of delete-char -(defun kill-forward-chars (arg) - (if (listp arg) (setq arg (car arg))) - (if (eq arg '-) (setq arg -1)) - (kill-region (point) (+ (point) arg))) - -;; Internal subroutine of backward-delete-char -(defun kill-backward-chars (arg) - (if (listp arg) (setq arg (car arg))) - (if (eq arg '-) (setq arg -1)) - (kill-region (point) (- (point) arg))) - -(defun backward-delete-char-untabify (arg &optional killp) - "Delete characters backward, changing tabs into spaces. -Delete ARG chars, and kill (save in kill ring) if KILLP is non-nil. -Interactively, ARG is the prefix arg (default 1) -and KILLP is t if a prefix arg was specified." - (interactive "*p\nP") - (let ((count arg)) - (save-excursion - (while (and (> count 0) (not (bobp))) - (if (eq (char-before (point)) ?\t) ; XEmacs - (let ((col (current-column))) - (forward-char -1) - (setq col (- col (current-column))) - (insert-char ?\ col) - (delete-char 1))) - (forward-char -1) - (setq count (1- count))))) - (delete-backward-char arg killp) - ;; XEmacs: In overwrite mode, back over columns while clearing them out, - ;; unless at end of line. - (and overwrite-mode (not (eolp)) - (save-excursion (insert-char ?\ arg)))) - -(defcustom delete-key-deletes-forward nil - "*If non-nil, the DEL key will erase one character forwards. -If nil, the DEL key will erase one character backwards." - :type 'boolean - :group 'editing-basics) - -(defun backward-or-forward-delete-char (arg) - "Delete either one character backwards or one character forwards. -Controlled by the state of `delete-key-deletes-forward' and whether the -BackSpace keysym even exists on your keyboard. If you don't have a -BackSpace keysym, the delete key should always delete one character -backwards." - (interactive "*p") - (if (and delete-key-deletes-forward - (or (eq 'tty (device-type)) - (x-keysym-on-keyboard-p "BackSpace"))) - (delete-char arg) - (delete-backward-char arg))) - -(defun backward-or-forward-kill-word (arg) - "Delete either one word backwards or one word forwards. -Controlled by the state of `delete-key-deletes-forward' and whether the -BackSpace keysym even exists on your keyboard. If you don't have a -BackSpace keysym, the delete key should always delete one character -backwards." - (interactive "*p") - (if (and delete-key-deletes-forward - (or (eq 'tty (device-type)) - (x-keysym-on-keyboard-p "BackSpace"))) - (kill-word arg) - (backward-kill-word arg))) - -(defun backward-or-forward-kill-sentence (arg) - "Delete either one sentence backwards or one sentence forwards. -Controlled by the state of `delete-key-deletes-forward' and whether the -BackSpace keysym even exists on your keyboard. If you don't have a -BackSpace keysym, the delete key should always delete one character -backwards." - (interactive "*P") - (if (and delete-key-deletes-forward - (or (eq 'tty (device-type)) - (x-keysym-on-keyboard-p "BackSpace"))) - (kill-sentence arg) - (backward-kill-sentence (prefix-numeric-value arg)))) - -(defun backward-or-forward-kill-sexp (arg) - "Delete either one sexpr backwards or one sexpr forwards. -Controlled by the state of `delete-key-deletes-forward' and whether the -BackSpace keysym even exists on your keyboard. If you don't have a -BackSpace keysym, the delete key should always delete one character -backwards." - (interactive "*p") - (if (and delete-key-deletes-forward - (or (eq 'tty (device-type)) - (x-keysym-on-keyboard-p "BackSpace"))) - (kill-sexp arg) - (backward-kill-sexp arg))) - -(defun zap-to-char (arg char) - "Kill up to and including ARG'th occurrence of CHAR. -Goes backward if ARG is negative; error if CHAR not found." - (interactive "*p\ncZap to char: ") - (kill-region (point) (progn - (search-forward (char-to-string char) nil nil arg) -; (goto-char (if (> arg 0) (1- (point)) (1+ (point)))) - (point)))) - -(defun beginning-of-buffer (&optional arg) - "Move point to the beginning of the buffer; leave mark at previous position. -With arg N, put point N/10 of the way from the beginning. - -If the buffer is narrowed, this command uses the beginning and size -of the accessible part of the buffer. - -Don't use this command in Lisp programs! -\(goto-char (point-min)) is faster and avoids clobbering the mark." - ;; XEmacs change - (interactive "_P") - (push-mark) - (let ((size (- (point-max) (point-min)))) - (goto-char (if arg - (+ (point-min) - (if (> size 10000) - ;; Avoid overflow for large buffer sizes! - (* (prefix-numeric-value arg) - (/ size 10)) - (/ (+ 10 (* size (prefix-numeric-value arg))) 10))) - (point-min)))) - (if arg (forward-line 1))) - -(defun end-of-buffer (&optional arg) - "Move point to the end of the buffer; leave mark at previous position. -With arg N, put point N/10 of the way from the end. - -If the buffer is narrowed, this command uses the beginning and size -of the accessible part of the buffer. - -Don't use this command in Lisp programs! -\(goto-char (point-max)) is faster and avoids clobbering the mark." - ;; XEmacs change - (interactive "_P") - (push-mark) - ;; XEmacs changes here. - (let ((scroll-to-end (not (pos-visible-in-window-p (point-max)))) - (size (- (point-max) (point-min)))) - (goto-char (if arg - (- (point-max) - (if (> size 10000) - ;; Avoid overflow for large buffer sizes! - (* (prefix-numeric-value arg) - (/ size 10)) - (/ (* size (prefix-numeric-value arg)) 10))) - (point-max))) - (cond (arg - ;; If we went to a place in the middle of the buffer, - ;; adjust it to the beginning of a line. - (forward-line 1)) - ;; XEmacs change - (scroll-to-end - ;; If the end of the buffer is not already on the screen, - ;; then scroll specially to put it near, but not at, the bottom. - (recenter -3))))) - -;; XEmacs (not in FSF) -(defun mark-beginning-of-buffer (&optional arg) - "Push a mark at the beginning of the buffer; leave point where it is. -With arg N, push mark N/10 of the way from the true beginning." - (interactive "P") - (push-mark (if arg - (if (> (buffer-size) 10000) - ;; Avoid overflow for large buffer sizes! - (* (prefix-numeric-value arg) - (/ (buffer-size) 10)) - (/ (+ 10 (* (buffer-size) (prefix-numeric-value arg))) 10)) - (point-min)) - nil - t)) -(define-function 'mark-bob 'mark-beginning-of-buffer) - -;; XEmacs (not in FSF) -(defun mark-end-of-buffer (&optional arg) - "Push a mark at the end of the buffer; leave point where it is. -With arg N, push mark N/10 of the way from the true end." - (interactive "P") - (push-mark (if arg - (- (1+ (buffer-size)) - (if (> (buffer-size) 10000) - ;; Avoid overflow for large buffer sizes! - (* (prefix-numeric-value arg) - (/ (buffer-size) 10)) - (/ (* (buffer-size) (prefix-numeric-value arg)) 10))) - (point-max)) - nil - t)) -(define-function 'mark-eob 'mark-end-of-buffer) - -(defun mark-whole-buffer () - "Put point at beginning and mark at end of buffer. -You probably should not use this function in Lisp programs; -it is usually a mistake for a Lisp function to use any subroutine -that uses or sets the mark." - (interactive) - (push-mark (point)) - (push-mark (point-max) nil t) - (goto-char (point-min))) - -;; XEmacs -(defun eval-current-buffer (&optional printflag) - "Evaluate the current buffer as Lisp code. -Programs can pass argument PRINTFLAG which controls printing of output: -nil means discard it; anything else is stream for print." - (interactive) - (eval-buffer (current-buffer) printflag)) - -;; XEmacs -(defun count-words-buffer (b) - (interactive "b") - (save-excursion - (let ((buf (or b (current-buffer)))) - (set-buffer buf) - (message "Buffer has %d words" - (count-words-region (point-min) (point-max)))))) - -;; XEmacs -(defun count-words-region (start end) - (interactive "r") - (save-excursion - (let ((n 0)) - (goto-char start) - (while (< (point) end) - (if (forward-word 1) - (setq n (1+ n)))) - (message "Region has %d words" n) - n))) - -(defun count-lines-region (start end) - "Print number of lines and characters in the region." - ;; XEmacs change - (interactive "_r") - (message "Region has %d lines, %d characters" - (count-lines start end) (- end start))) - -;; XEmacs -(defun count-lines-buffer (b) - "Print number of lines and characters in the specified buffer." - (interactive "_b") - (save-excursion - (let ((buf (or b (current-buffer))) - cnt) - (set-buffer buf) - (setq cnt (count-lines (point-min) (point-max))) - (message "Buffer has %d lines, %d characters" - cnt (- (point-max) (point-min))) - cnt))) - -(defun what-line () - "Print the current buffer line number and narrowed line number of point." - ;; XEmacs change - (interactive "_") - (let ((opoint (point)) start) - (save-excursion - (save-restriction - (goto-char (point-min)) - (widen) - (beginning-of-line) - (setq start (point)) - (goto-char opoint) - (beginning-of-line) - (if (/= start 1) - (message "line %d (narrowed line %d)" - (1+ (count-lines 1 (point))) - (1+ (count-lines start (point)))) - (message "Line %d" (1+ (count-lines 1 (point))))))))) - - -(defun count-lines (start end) - "Return number of lines between START and END. -This is usually the number of newlines between them, -but can be one more if START is not equal to END -and the greater of them is not at the start of a line." - (save-excursion - (save-restriction - (narrow-to-region start end) - (goto-char (point-min)) - (if (eq selective-display t) - (save-match-data - (let ((done 0)) - (while (re-search-forward "[\n\C-m]" nil t 40) - (setq done (+ 40 done))) - (while (re-search-forward "[\n\C-m]" nil t 1) - (setq done (+ 1 done))) - (goto-char (point-max)) - (if (and (/= start end) - (not (bolp))) - (1+ done) - done))) - (- (buffer-size) (forward-line (buffer-size))))))) - -(defun what-cursor-position () - "Print info on cursor position (on screen and within buffer)." - ;; XEmacs change - (interactive "_") - (let* ((char (char-after (point))) ; XEmacs - (beg (point-min)) - (end (point-max)) - (pos (point)) - (total (buffer-size)) - (percent (if (> total 50000) - ;; Avoid overflow from multiplying by 100! - (/ (+ (/ total 200) (1- pos)) (max (/ total 100) 1)) - (/ (+ (/ total 2) (* 100 (1- pos))) (max total 1)))) - (hscroll (if (= (window-hscroll) 0) - "" - (format " Hscroll=%d" (window-hscroll)))) - (col (current-column))) - (if (= pos end) - (if (or (/= beg 1) (/= end (1+ total))) - (message "point=%d of %d(%d%%) <%d - %d> column %d %s" - pos total percent beg end col hscroll) - (message "point=%d of %d(%d%%) column %d %s" - pos total percent col hscroll)) - ;; XEmacs: don't use single-key-description - (if (or (/= beg 1) (/= end (1+ total))) - (message "Char: %s (0%o, %d, 0x%x) point=%d of %d(%d%%) <%d - %d> column %d %s" - (text-char-description char) char char char pos total - percent beg end col hscroll) - (message "Char: %s (0%o, %d, 0x%x) point=%d of %d(%d%%) column %d %s" - (text-char-description char) char char char pos total - percent col hscroll))))) - -(defun fundamental-mode () - "Major mode not specialized for anything in particular. -Other major modes are defined by comparison with this one." - (interactive) - (kill-all-local-variables)) - -;; XEmacs the following are declared elsewhere -;(defvar read-expression-map (cons 'keymap minibuffer-local-map) -; "Minibuffer keymap used for reading Lisp expressions.") -;(define-key read-expression-map "\M-\t" 'lisp-complete-symbol) - -;(put 'eval-expression 'disabled t) - -;(defvar read-expression-history nil) - -;; We define this, rather than making `eval' interactive, -;; for the sake of completion of names like eval-region, eval-current-buffer. -(defun eval-expression (expression) - "Evaluate EXPRESSION and print value in minibuffer. -Value is also consed on to front of the variable `values'." - ;(interactive "xEval: ") - (interactive - (list (read-from-minibuffer "Eval: " - nil read-expression-map t - 'read-expression-history))) - (setq values (cons (eval expression) values)) - (prin1 (car values) t)) - -;; XEmacs -- extra parameter (variant, but equivalent logic) -(defun edit-and-eval-command (prompt command &optional history) - "Prompting with PROMPT, let user edit COMMAND and eval result. -COMMAND is a Lisp expression. Let user edit that expression in -the minibuffer, then read and evaluate the result." - (let ((command (read-expression prompt - ;; first try to format the thing readably; - ;; and if that fails, print it normally. - (condition-case () - (let ((print-readably t)) - (prin1-to-string command)) - (error (prin1-to-string command))) - (or history '(command-history . 1))))) - (or history (setq history 'command-history)) - (if (consp history) - (setq history (car history))) - (if (eq history t) - nil - ;; If command was added to the history as a string, - ;; get rid of that. We want only evallable expressions there. - (if (stringp (car (symbol-value history))) - (set history (cdr (symbol-value history)))) - - ;; If command to be redone does not match front of history, - ;; add it to the history. - (or (equal command (car (symbol-value history))) - (set history (cons command (symbol-value history))))) - (eval command))) - -(defun repeat-complex-command (arg) - "Edit and re-evaluate last complex command, or ARGth from last. -A complex command is one which used the minibuffer. -The command is placed in the minibuffer as a Lisp form for editing. -The result is executed, repeating the command as changed. -If the command has been changed or is not the most recent previous command -it is added to the front of the command history. -You can use the minibuffer history commands \\<minibuffer-local-map>\\[next-history-element] and \\[previous-history-element] -to get different commands to edit and resubmit." - (interactive "p") - ;; XEmacs: It looks like our version is better -sb - (let ((print-level nil)) - (edit-and-eval-command "Redo: " - (or (nth (1- arg) command-history) - (error "")) - (cons 'command-history arg)))) - -;; XEmacs: Functions moved to minibuf.el -;; previous-matching-history-element -;; next-matching-history-element -;; next-history-element -;; previous-history-element -;; next-complete-history-element -;; previous-complete-history-element - -(defun goto-line (arg) - "Goto line ARG, counting from line 1 at beginning of buffer." - (interactive "NGoto line: ") - (setq arg (prefix-numeric-value arg)) - (save-restriction - (widen) - (goto-char 1) - (if (eq selective-display t) - (re-search-forward "[\n\C-m]" nil 'end (1- arg)) - (forward-line (1- arg))))) - -;Put this on C-x u, so we can force that rather than C-_ into startup msg -(define-function 'advertised-undo 'undo) - -(defun undo (&optional arg) - "Undo some previous changes. -Repeat this command to undo more changes. -A numeric argument serves as a repeat count." - (interactive "*p") - ;; If we don't get all the way through, make last-command indicate that - ;; for the following command. - (setq this-command t) - (let ((modified (buffer-modified-p)) - (recent-save (recent-auto-save-p))) - (or (eq (selected-window) (minibuffer-window)) - (display-message 'command "Undo!")) - (or (and (eq last-command 'undo) - (eq (current-buffer) last-undo-buffer)) ; XEmacs - (progn (undo-start) - (undo-more 1))) - (undo-more (or arg 1)) - ;; Don't specify a position in the undo record for the undo command. - ;; Instead, undoing this should move point to where the change is. - (let ((tail buffer-undo-list) - done) - (while (and tail (not done) (not (null (car tail)))) - (if (integerp (car tail)) - (progn - (setq done t) - (setq buffer-undo-list (delq (car tail) buffer-undo-list)))) - (setq tail (cdr tail)))) - (and modified (not (buffer-modified-p)) - (delete-auto-save-file-if-necessary recent-save))) - ;; If we do get all the way through, make this-command indicate that. - (setq this-command 'undo)) - -(defvar pending-undo-list nil - "Within a run of consecutive undo commands, list remaining to be undone.") - -(defvar last-undo-buffer nil) ; XEmacs - -(defun undo-start () - "Set `pending-undo-list' to the front of the undo list. -The next call to `undo-more' will undo the most recently made change." - (if (eq buffer-undo-list t) - (error "No undo information in this buffer")) - (setq pending-undo-list buffer-undo-list)) - -(defun undo-more (count) - "Undo back N undo-boundaries beyond what was already undone recently. -Call `undo-start' to get ready to undo recent changes, -then call `undo-more' one or more times to undo them." - (or pending-undo-list - (error "No further undo information")) - (setq pending-undo-list (primitive-undo count pending-undo-list) - last-undo-buffer (current-buffer))) ; XEmacs - -;; XEmacs -(defun call-with-transparent-undo (fn &rest args) - "Apply FN to ARGS, and then undo all changes made by FN to the current -buffer. The undo records are processed even if FN returns non-locally. -There is no trace of the changes made by FN in the buffer's undo history. - -You can use this in a write-file-hooks function with continue-save-buffer -to make the contents of a disk file differ from its in-memory buffer." - (let ((buffer-undo-list nil) - ;; Kludge to prevent undo list truncation: - (undo-high-threshold -1) - (undo-threshold -1) - (obuffer (current-buffer))) - (unwind-protect - (apply fn args) - ;; Go to the buffer we will restore and make it writable: - (set-buffer obuffer) - (save-excursion - (let ((buffer-read-only nil)) - (save-restriction - (widen) - ;; Perform all undos, with further undo logging disabled: - (let ((tail buffer-undo-list)) - (setq buffer-undo-list t) - (while tail - (setq tail (primitive-undo (length tail) tail)))))))))) - -;; XEmacs: The following are in other files -;; shell-command-history -;; shell-command-switch -;; shell-command -;; shell-command-sentinel - - -(defconst universal-argument-map - (let ((map (make-sparse-keymap))) - (set-keymap-default-binding map 'universal-argument-other-key) - ;FSFmacs (define-key map [switch-frame] nil) - (define-key map [(t)] 'universal-argument-other-key) - (define-key map [(meta t)] 'universal-argument-other-key) - (define-key map [(control u)] 'universal-argument-more) - (define-key map [?-] 'universal-argument-minus) - (define-key map [?0] 'digit-argument) - (define-key map [?1] 'digit-argument) - (define-key map [?2] 'digit-argument) - (define-key map [?3] 'digit-argument) - (define-key map [?4] 'digit-argument) - (define-key map [?5] 'digit-argument) - (define-key map [?6] 'digit-argument) - (define-key map [?7] 'digit-argument) - (define-key map [?8] 'digit-argument) - (define-key map [?9] 'digit-argument) - map) - "Keymap used while processing \\[universal-argument].") - -(defvar universal-argument-num-events nil - "Number of argument-specifying events read by `universal-argument'. -`universal-argument-other-key' uses this to discard those events -from (this-command-keys), and reread only the final command.") - -(defun universal-argument () - "Begin a numeric argument for the following command. -Digits or minus sign following \\[universal-argument] make up the numeric argument. -\\[universal-argument] following the digits or minus sign ends the argument. -\\[universal-argument] without digits or minus sign provides 4 as argument. -Repeating \\[universal-argument] without digits or minus sign - multiplies the argument by 4 each time." - (interactive) - (setq prefix-arg (list 4)) - (setq zmacs-region-stays t) ; XEmacs - (setq universal-argument-num-events (length (this-command-keys))) - (setq overriding-terminal-local-map universal-argument-map)) - -;; A subsequent C-u means to multiply the factor by 4 if we've typed -;; nothing but C-u's; otherwise it means to terminate the prefix arg. -(defun universal-argument-more (arg) - (interactive "_P") ; XEmacs - (if (consp arg) - (setq prefix-arg (list (* 4 (car arg)))) - (setq prefix-arg arg) - (setq overriding-terminal-local-map nil)) - (setq universal-argument-num-events (length (this-command-keys)))) - -(defun negative-argument (arg) - "Begin a negative numeric argument for the next command. -\\[universal-argument] following digits or minus sign ends the argument." - (interactive "_P") ; XEmacs - (cond ((integerp arg) - (setq prefix-arg (- arg))) - ((eq arg '-) - (setq prefix-arg nil)) - (t - (setq prefix-arg '-))) - (setq universal-argument-num-events (length (this-command-keys))) - (setq overriding-terminal-local-map universal-argument-map)) - -;; XEmacs: This function not synched with FSF -(defun digit-argument (arg) - "Part of the numeric argument for the next command. -\\[universal-argument] following digits or minus sign ends the argument." - (interactive "_P") ; XEmacs - (let* ((event last-command-event) - (key (and (key-press-event-p event) - (event-key event))) - (digit (and key (characterp key) (>= key ?0) (<= key ?9) - (- key ?0)))) - (if (null digit) - (universal-argument-other-key arg) - (cond ((integerp arg) - (setq prefix-arg (+ (* arg 10) - (if (< arg 0) (- digit) digit)))) - ((eq arg '-) - ;; Treat -0 as just -, so that -01 will work. - (setq prefix-arg (if (zerop digit) '- (- digit)))) - (t - (setq prefix-arg digit))) - (setq universal-argument-num-events (length (this-command-keys))) - (setq overriding-terminal-local-map universal-argument-map)))) - -;; For backward compatibility, minus with no modifiers is an ordinary -;; command if digits have already been entered. -(defun universal-argument-minus (arg) - (interactive "P") - (if (integerp arg) - (universal-argument-other-key arg) - (negative-argument arg))) - -;; Anything else terminates the argument and is left in the queue to be -;; executed as a command. -(defun universal-argument-other-key (arg) - (interactive "_P") ; XEmacs - (setq prefix-arg arg) - (let* ((key (this-command-keys)) - ;; FSF calls silly function `listify-key-sequence' here. - (keylist (append key nil))) - (setq unread-command-events - (append (nthcdr universal-argument-num-events keylist) - unread-command-events))) - (reset-this-command-lengths) - (setq overriding-terminal-local-map nil)) - - -;; XEmacs -- keep zmacs-region active. -(defun forward-to-indentation (arg) - "Move forward ARG lines and position at first nonblank character." - (interactive "_p") - (forward-line arg) - (skip-chars-forward " \t")) - -(defun backward-to-indentation (arg) - "Move backward ARG lines and position at first nonblank character." - (interactive "_p") - (forward-line (- arg)) - (skip-chars-forward " \t")) - -(defcustom kill-whole-line nil - "*If non-nil, `kill-line' with no arg at beg of line kills the whole line." - :type 'boolean - :group 'killing) - -(defun kill-line (&optional arg) - "Kill the rest of the current line; if no nonblanks there, kill thru newline. -With prefix argument, kill that many lines from point. -Negative arguments kill lines backward. - -When calling from a program, nil means \"no arg\", -a number counts as a prefix arg. - -If `kill-whole-line' is non-nil, then kill the whole line -when given no argument at the beginning of a line." - (interactive "*P") - (kill-region (point) - ;; Don't shift point before doing the delete; that way, - ;; undo will record the right position of point. -;; FSF -; ;; It is better to move point to the other end of the kill -; ;; before killing. That way, in a read-only buffer, point -; ;; moves across the text that is copied to the kill ring. -; ;; The choice has no effect on undo now that undo records -; ;; the value of point from before the command was run. -; (progn - (save-excursion - (if arg - (forward-line (prefix-numeric-value arg)) - (if (eobp) - (signal 'end-of-buffer nil)) - (if (or (looking-at "[ \t]*$") (and kill-whole-line (bolp))) - (forward-line 1) - (end-of-line))) - (point)))) - -;; XEmacs -(defun backward-kill-line nil - "Kill back to the beginning of the line." - (interactive) - (let ((point (point))) - (beginning-of-line nil) - (kill-region (point) point))) - - -;;;; Window system cut and paste hooks. -;;; -;;; I think that kill-hooks is a better name and more general mechanism -;;; than interprogram-cut-function (from FSFmacs). I don't like the behavior -;;; of interprogram-paste-function: ^Y should always come from the kill ring, -;;; not the X selection. But if that were provided, it should be called (and -;;; behave as) yank-hooks instead. -- jwz - -;; [... code snipped ...] - -(defcustom kill-hooks nil - "*Functions run when something is added to the XEmacs kill ring. -These functions are called with one argument, the string most recently -cut or copied. You can use this to, for example, make the most recent -kill become the X Clipboard selection." - :type 'hook - :group 'killing) - - -;;;; The kill ring data structure. - -(defvar kill-ring nil - "List of killed text sequences. -Since the kill ring is supposed to interact nicely with cut-and-paste -facilities offered by window systems, use of this variable should -interact nicely with `interprogram-cut-function' and -`interprogram-paste-function'. The functions `kill-new', -`kill-append', and `current-kill' are supposed to implement this -interaction; you may want to use them instead of manipulating the kill -ring directly.") - -(defcustom kill-ring-max 30 - "*Maximum length of kill ring before oldest elements are thrown away." - :type 'integer - :group 'killing) - -(defvar kill-ring-yank-pointer nil - "The tail of the kill ring whose car is the last thing yanked.") - -(defun kill-new (string &optional replace) - "Make STRING the latest kill in the kill ring. -Set the kill-ring-yank pointer to point to it. -Run `kill-hooks'. -Optional second argument REPLACE non-nil means that STRING will replace -the front of the kill ring, rather than being added to the list." -; (and (fboundp 'menu-bar-update-yank-menu) -; (menu-bar-update-yank-menu string (and replace (car kill-ring)))) - (if replace - (setcar kill-ring string) - (setq kill-ring (cons string kill-ring)) - (if (> (length kill-ring) kill-ring-max) - (setcdr (nthcdr (1- kill-ring-max) kill-ring) nil))) - (setq kill-ring-yank-pointer kill-ring) -; (if interprogram-cut-function -; (funcall interprogram-cut-function string (not replace))) - (run-hook-with-args 'kill-hooks string)) - -(defun kill-append (string before-p) - "Append STRING to the end of the latest kill in the kill ring. -If BEFORE-P is non-nil, prepend STRING to the kill. -Run `kill-hooks'." - (kill-new (if before-p - (concat string (car kill-ring)) - (concat (car kill-ring) string)) t)) - -(defun current-kill (n &optional do-not-move) - "Rotate the yanking point by N places, and then return that kill. -If optional arg DO-NOT-MOVE is non-nil, then don't actually move the -yanking point\; just return the Nth kill forward." - (or kill-ring (error "Kill ring is empty")) - (let* ((tem (nthcdr (mod (- n (length kill-ring-yank-pointer)) - (length kill-ring)) - kill-ring))) - (or do-not-move - (setq kill-ring-yank-pointer tem)) - (car tem))) - - - -;;;; Commands for manipulating the kill ring. - -;; In FSF killing read-only text just pastes it into kill-ring. Which -;; is a very bad idea -- see Jamie's comment below. - -;(defvar kill-read-only-ok nil -; "*Non-nil means don't signal an error for killing read-only text.") - -(defun kill-region (beg end &optional verbose) ; verbose is XEmacs addition - "Kill between point and mark. -The text is deleted but saved in the kill ring. -The command \\[yank] can retrieve it from there. -\(If you want to kill and then yank immediately, use \\[copy-region-as-kill].) - -This is the primitive for programs to kill text (as opposed to deleting it). -Supply two arguments, character numbers indicating the stretch of text - to be killed. -Any command that calls this function is a \"kill command\". -If the previous command was also a kill command, -the text killed this time appends to the text killed last time -to make one entry in the kill ring." - (interactive "*r\np") -; (interactive -; (let ((region-hack (and zmacs-regions (eq last-command 'yank)))) -; ;; This lets "^Y^W" work. I think this is dumb, but zwei did it. -; (if region-hack (zmacs-activate-region)) -; (prog1 -; (list (point) (mark) current-prefix-arg) -; (if region-hack (zmacs-deactivate-region))))) - ;; beg and end can be markers but the rest of this function is - ;; written as if they are only integers - (if (markerp beg) (setq beg (marker-position beg))) - (if (markerp end) (setq end (marker-position end))) - (or (and beg end) (if zmacs-regions ;; rewritten for I18N3 snarfing - (error "The region is not active now") - (error "The mark is not set now"))) - (if verbose (if buffer-read-only - (display-message - 'command - (format "Copying %d characters" - (- (max beg end) (min beg end)))) - (display-message - 'command - (format "Killing %d characters" - (- (max beg end) (min beg end)))))) - (cond - - ;; I don't like this large change in behavior -- jwz - ;; Read-Only text means it shouldn't be deleted, so I'm restoring - ;; this code, but only for text-properties and not full extents. -sb - ;; If the buffer is read-only, we should beep, in case the person - ;; just isn't aware of this. However, there's no harm in putting - ;; the region's text in the kill ring, anyway. - ((or (and buffer-read-only (not inhibit-read-only)) - (text-property-not-all (min beg end) (max beg end) 'read-only nil)) - ;; This is redundant. - ;; (if verbose (message "Copying %d characters" - ;; (- (max beg end) (min beg end)))) - (copy-region-as-kill beg end) - ;; ;; This should always barf, and give us the correct error. - ;; (if kill-read-only-ok - ;; (message "Read only text copied to kill ring") - (setq this-command 'kill-region) - (barf-if-buffer-read-only) - (signal 'buffer-read-only (list (current-buffer)))) - - ;; In certain cases, we can arrange for the undo list and the kill - ;; ring to share the same string object. This code does that. - ((not (or (eq buffer-undo-list t) - (eq last-command 'kill-region) - ;; Use = since positions may be numbers or markers. - (= beg end))) - ;; Don't let the undo list be truncated before we can even access it. - ;; FSF calls this `undo-strong-limit' - (let ((undo-high-threshold (+ (- end beg) 100)) - ;(old-list buffer-undo-list) - tail) - (delete-region beg end) - ;; Search back in buffer-undo-list for this string, - ;; in case a change hook made property changes. - (setq tail buffer-undo-list) - (while (and tail - (not (stringp (car-safe (car-safe tail))))) ; XEmacs - (pop tail)) - ;; Take the same string recorded for undo - ;; and put it in the kill-ring. - (and tail - (kill-new (car (car tail)))))) - - (t - ;; if undo is not kept, grab the string then delete it (which won't - ;; add another string to the undo list). - (copy-region-as-kill beg end) - (delete-region beg end))) - (setq this-command 'kill-region)) - -;; copy-region-as-kill no longer sets this-command, because it's confusing -;; to get two copies of the text when the user accidentally types M-w and -;; then corrects it with the intended C-w. -(defun copy-region-as-kill (beg end) - "Save the region as if killed, but don't kill it. -Run `kill-hooks'." - (interactive "r") - (if (eq last-command 'kill-region) - (kill-append (buffer-substring beg end) (< end beg)) - (kill-new (buffer-substring beg end))) - nil) - -(defun kill-ring-save (beg end) - "Save the region as if killed, but don't kill it. -This command is similar to `copy-region-as-kill', except that it gives -visual feedback indicating the extent of the region being copied." - (interactive "r") - (copy-region-as-kill beg end) - ;; copy before delay, for xclipboard's benefit - (if (interactive-p) - (let ((other-end (if (= (point) beg) end beg)) - (opoint (point)) - ;; Inhibit quitting so we can make a quit here - ;; look like a C-g typed as a command. - (inhibit-quit t)) - (if (pos-visible-in-window-p other-end (selected-window)) - (progn - ;; FSF (I'm not sure what this does -sb) -; ;; Swap point and mark. -; (set-marker (mark-marker) (point) (current-buffer)) - (goto-char other-end) - (sit-for 1) -; ;; Swap back. -; (set-marker (mark-marker) other-end (current-buffer)) - (goto-char opoint) - ;; If user quit, deactivate the mark - ;; as C-g would as a command. - (and quit-flag (mark) - (zmacs-deactivate-region))) - ;; too noisy. -- jwz -; (let* ((killed-text (current-kill 0)) -; (message-len (min (length killed-text) 40))) -; (if (= (point) beg) -; ;; Don't say "killed"; that is misleading. -; (message "Saved text until \"%s\"" -; (substring killed-text (- message-len))) -; (message "Saved text from \"%s\"" -; (substring killed-text 0 message-len)))) - )))) - -(defun append-next-kill () - "Cause following command, if it kills, to append to previous kill." - ;; XEmacs - (interactive "_") - (if (interactive-p) - (progn - (setq this-command 'kill-region) - (display-message 'command - "If the next command is a kill, it will append")) - (setq last-command 'kill-region))) - -(defun yank-pop (arg) - "Replace just-yanked stretch of killed text with a different stretch. -This command is allowed only immediately after a `yank' or a `yank-pop'. -At such a time, the region contains a stretch of reinserted -previously-killed text. `yank-pop' deletes that text and inserts in its -place a different stretch of killed text. - -With no argument, the previous kill is inserted. -With argument N, insert the Nth previous kill. -If N is negative, this is a more recent kill. - -The sequence of kills wraps around, so that after the oldest one -comes the newest one." - (interactive "*p") - (if (not (eq last-command 'yank)) - (error "Previous command was not a yank")) - (setq this-command 'yank) - (let ((inhibit-read-only t) - (before (< (point) (mark t)))) - (delete-region (point) (mark t)) - ;;(set-marker (mark-marker) (point) (current-buffer)) - (set-mark (point)) - (insert (current-kill arg)) - (if before - ;; This is like exchange-point-and-mark, but doesn't activate the mark. - ;; It is cleaner to avoid activation, even though the command - ;; loop would deactivate the mark because we inserted text. - (goto-char (prog1 (mark t) - (set-marker (mark-marker t) (point) (current-buffer)))))) - nil) - - -(defun yank (&optional arg) - "Reinsert the last stretch of killed text. -More precisely, reinsert the stretch of killed text most recently -killed OR yanked. Put point at end, and set mark at beginning. -With just C-u as argument, same but put point at beginning (and mark at end). -With argument N, reinsert the Nth most recently killed stretch of killed -text. -See also the command \\[yank-pop]." - (interactive "*P") - ;; If we don't get all the way through, make last-command indicate that - ;; for the following command. - (setq this-command t) - (push-mark (point)) - (insert (current-kill (cond - ((listp arg) 0) - ((eq arg '-) -1) - (t (1- arg))))) - (if (consp arg) - ;; This is like exchange-point-and-mark, but doesn't activate the mark. - ;; It is cleaner to avoid activation, even though the command - ;; loop would deactivate the mark because we inserted text. - ;; (But it's an unnecessary kludge in XEmacs.) - ;(goto-char (prog1 (mark t) - ;(set-marker (mark-marker) (point) (current-buffer))))) - (exchange-point-and-mark t)) - ;; If we do get all the way thru, make this-command indicate that. - (setq this-command 'yank) - nil) - -(defun rotate-yank-pointer (arg) - "Rotate the yanking point in the kill ring. -With argument, rotate that many kills forward (or backward, if negative)." - (interactive "p") - (current-kill arg)) - - -(defun insert-buffer (buffer) - "Insert after point the contents of BUFFER. -Puts mark after the inserted text. -BUFFER may be a buffer or a buffer name." - (interactive - (list - (progn - (barf-if-buffer-read-only) - (read-buffer "Insert buffer: " - ;; XEmacs: we have different args - (other-buffer (current-buffer) nil t) - t)))) - (or (bufferp buffer) - (setq buffer (get-buffer buffer))) - (let (start end newmark) - (save-excursion - (save-excursion - (set-buffer buffer) - (setq start (point-min) end (point-max))) - (insert-buffer-substring buffer start end) - (setq newmark (point))) - (push-mark newmark)) - nil) - -(defun append-to-buffer (buffer start end) - "Append to specified buffer the text of the region. -It is inserted into that buffer before its point. - -When calling from a program, give three arguments: -BUFFER (or buffer name), START and END. -START and END specify the portion of the current buffer to be copied." - (interactive - ;; XEmacs: we have different args to other-buffer - (list (read-buffer "Append to buffer: " (other-buffer (current-buffer) - nil t)) - (region-beginning) (region-end))) - (let ((oldbuf (current-buffer))) - (save-excursion - (set-buffer (get-buffer-create buffer)) - (insert-buffer-substring oldbuf start end)))) - -(defun prepend-to-buffer (buffer start end) - "Prepend to specified buffer the text of the region. -It is inserted into that buffer after its point. - -When calling from a program, give three arguments: -BUFFER (or buffer name), START and END. -START and END specify the portion of the current buffer to be copied." - (interactive "BPrepend to buffer: \nr") - (let ((oldbuf (current-buffer))) - (save-excursion - (set-buffer (get-buffer-create buffer)) - (save-excursion - (insert-buffer-substring oldbuf start end))))) - -(defun copy-to-buffer (buffer start end) - "Copy to specified buffer the text of the region. -It is inserted into that buffer, replacing existing text there. - -When calling from a program, give three arguments: -BUFFER (or buffer name), START and END. -START and END specify the portion of the current buffer to be copied." - (interactive "BCopy to buffer: \nr") - (let ((oldbuf (current-buffer))) - (save-excursion - (set-buffer (get-buffer-create buffer)) - (erase-buffer) - (save-excursion - (insert-buffer-substring oldbuf start end))))) - -;FSFmacs -;(put 'mark-inactive 'error-conditions '(mark-inactive error)) -;(put 'mark-inactive 'error-message "The mark is not active now") - -(defun mark (&optional force buffer) - "Return this buffer's mark value as integer, or nil if no mark. - -If `zmacs-regions' is true, then this returns nil unless the region is -currently in the active (highlighted) state. With an argument of t, this -returns the mark (if there is one) regardless of the active-region state. -You should *generally* not use the mark unless the region is active, if -the user has expressed a preference for the active-region model. - -If you are using this in an editing command, you are most likely making -a mistake; see the documentation of `set-mark'." - (setq buffer (decode-buffer buffer)) -;FSFmacs version: -; (if (or force (not transient-mark-mode) mark-active mark-even-if-inactive) -; (marker-position (mark-marker)) -; (signal 'mark-inactive nil))) - (let ((m (mark-marker force buffer))) - (and m (marker-position m)))) - -;;;#### FSFmacs -;;; Many places set mark-active directly, and several of them failed to also -;;; run deactivate-mark-hook. This shorthand should simplify. -;(defsubst deactivate-mark () -; "Deactivate the mark by setting `mark-active' to nil. -;\(That makes a difference only in Transient Mark mode.) -;Also runs the hook `deactivate-mark-hook'." -; (if transient-mark-mode -; (progn -; (setq mark-active nil) -; (run-hooks 'deactivate-mark-hook)))) - -(defun set-mark (pos &optional buffer) - "Set this buffer's mark to POS. Don't use this function! -That is to say, don't use this function unless you want -the user to see that the mark has moved, and you want the previous -mark position to be lost. - -Normally, when a new mark is set, the old one should go on the stack. -This is why most applications should use push-mark, not set-mark. - -Novice Emacs Lisp programmers often try to use the mark for the wrong -purposes. The mark saves a location for the user's convenience. -Most editing commands should not alter the mark. -To remember a location for internal use in the Lisp program, -store it in a Lisp variable. Example: - - (let ((beg (point))) (forward-line 1) (delete-region beg (point)))." - - (setq buffer (decode-buffer buffer)) - (set-marker (mark-marker t buffer) pos buffer)) -;; FSF -; (if pos -; (progn -; (setq mark-active t) -; (run-hooks 'activate-mark-hook) -; (set-marker (mark-marker) pos (current-buffer))) -; ;; Normally we never clear mark-active except in Transient Mark mode. -; ;; But when we actually clear out the mark value too, -; ;; we must clear mark-active in any mode. -; (setq mark-active nil) -; (run-hooks 'deactivate-mark-hook) -; (set-marker (mark-marker) nil))) - -(defvar mark-ring nil - "The list of former marks of the current buffer, most recent first.") -(make-variable-buffer-local 'mark-ring) -(put 'mark-ring 'permanent-local t) - -(defcustom mark-ring-max 16 - "*Maximum size of mark ring. Start discarding off end if gets this big." - :type 'integer - :group 'killing) - -(defvar global-mark-ring nil - "The list of saved global marks, most recent first.") - -(defcustom global-mark-ring-max 16 - "*Maximum size of global mark ring. \ -Start discarding off end if gets this big." - :type 'integer - :group 'killing) - -(defun set-mark-command (arg) - "Set mark at where point is, or jump to mark. -With no prefix argument, set mark, push old mark position on local mark -ring, and push mark on global mark ring. -With argument, jump to mark, and pop a new position for mark off the ring -\(does not affect global mark ring\). - -Novice Emacs Lisp programmers often try to use the mark for the wrong -purposes. See the documentation of `set-mark' for more information." - (interactive "P") - (if (null arg) - (push-mark nil nil t) - (if (null (mark t)) - (error "No mark set in this buffer") - (goto-char (mark t)) - (pop-mark)))) - -;; XEmacs: Extra parameter -(defun push-mark (&optional location nomsg activate-region buffer) - "Set mark at LOCATION (point, by default) and push old mark on mark ring. -If the last global mark pushed was not in the current buffer, -also push LOCATION on the global mark ring. -Display `Mark set' unless the optional second arg NOMSG is non-nil. -Activate mark if optional third arg ACTIVATE-REGION non-nil. - -Novice Emacs Lisp programmers often try to use the mark for the wrong -purposes. See the documentation of `set-mark' for more information." - (setq buffer (decode-buffer buffer)) ; XEmacs - (if (null (mark t buffer)) ; XEmacs - nil - ;; The save-excursion / set-buffer is necessary because mark-ring - ;; is a buffer local variable - (save-excursion - (set-buffer buffer) - (setq mark-ring (cons (copy-marker (mark-marker t buffer)) mark-ring)) - (if (> (length mark-ring) mark-ring-max) - (progn - (move-marker (car (nthcdr mark-ring-max mark-ring)) nil buffer) - (setcdr (nthcdr (1- mark-ring-max) mark-ring) nil))))) - (set-mark (or location (point buffer)) buffer) -; (set-marker (mark-marker) (or location (point)) (current-buffer)) ; FSF - ;; Now push the mark on the global mark ring. - (if (or (null global-mark-ring) - (not (eq (marker-buffer (car global-mark-ring)) buffer))) - ;; The last global mark pushed wasn't in this same buffer. - (progn - (setq global-mark-ring (cons (copy-marker (mark-marker t buffer)) - global-mark-ring)) - (if (> (length global-mark-ring) global-mark-ring-max) - (progn - (move-marker (car (nthcdr global-mark-ring-max global-mark-ring)) - nil buffer) - (setcdr (nthcdr (1- global-mark-ring-max) global-mark-ring) nil))))) - (or nomsg executing-kbd-macro (> (minibuffer-depth) 0) - (display-message 'command "Mark set")) - (if activate-region - (progn - (setq zmacs-region-stays t) - (zmacs-activate-region))) -; (if (or activate (not transient-mark-mode)) ; FSF -; (set-mark (mark t))) ; FSF - nil) - -(defun pop-mark () - "Pop off mark ring into the buffer's actual mark. -Does not set point. Does nothing if mark ring is empty." - (if mark-ring - (progn - (setq mark-ring (nconc mark-ring (list (copy-marker (mark-marker t))))) - (set-mark (car mark-ring)) - (move-marker (car mark-ring) nil) - (if (null (mark t)) (ding)) - (setq mark-ring (cdr mark-ring))))) - -(define-function 'exchange-dot-and-mark 'exchange-point-and-mark) -(defun exchange-point-and-mark (&optional dont-activate-region) - "Put the mark where point is now, and point where the mark is now. -The mark is activated unless DONT-ACTIVATE-REGION is non-nil." - (interactive nil) - (let ((omark (mark t))) - (if (null omark) - (error "No mark set in this buffer")) - (set-mark (point)) - (goto-char omark) - (or dont-activate-region (zmacs-activate-region)) ; XEmacs - nil)) - -;; XEmacs -(defun mark-something (mark-fn movement-fn arg) - "internal function used by mark-sexp, mark-word, etc." - (let (newmark (pushp t)) - (save-excursion - (if (and (eq last-command mark-fn) (mark)) - ;; Extend the previous state in the same direction: - (progn - (if (< (mark) (point)) (setq arg (- arg))) - (goto-char (mark)) - (setq pushp nil))) - (funcall movement-fn arg) - (setq newmark (point))) - (if pushp - (push-mark newmark nil t) - ;; Do not mess with the mark stack, but merely adjust the previous state: - (set-mark newmark) - (activate-region)))) - -;(defun transient-mark-mode (arg) -; "Toggle Transient Mark mode. -;With arg, turn Transient Mark mode on if arg is positive, off otherwise. -; -;In Transient Mark mode, when the mark is active, the region is highlighted. -;Changing the buffer \"deactivates\" the mark. -;So do certain other operations that set the mark -;but whose main purpose is something else--for example, -;incremental search, \\[beginning-of-buffer], and \\[end-of-buffer]." -; (interactive "P") -; (setq transient-mark-mode -; (if (null arg) -; (not transient-mark-mode) -; (> (prefix-numeric-value arg) 0)))) - -(defun pop-global-mark () - "Pop off global mark ring and jump to the top location." - (interactive) - ;; Pop entries which refer to non-existent buffers. - (while (and global-mark-ring (not (marker-buffer (car global-mark-ring)))) - (setq global-mark-ring (cdr global-mark-ring))) - (or global-mark-ring - (error "No global mark set")) - (let* ((marker (car global-mark-ring)) - (buffer (marker-buffer marker)) - (position (marker-position marker))) - (setq global-mark-ring (nconc (cdr global-mark-ring) - (list (car global-mark-ring)))) - (set-buffer buffer) - (or (and (>= position (point-min)) - (<= position (point-max))) - (widen)) - (goto-char position) - (switch-to-buffer buffer))) - - -;;; After 8 years of waiting ... -sb -(defcustom next-line-add-newlines nil ; XEmacs - "*If non-nil, `next-line' inserts newline when the point is at end of buffer. -This behavior used to be the default, and is still default in FSF Emacs. -We think it is an unnecessary and unwanted side-effect." - :type 'boolean - :group 'editing-basics) - -(defun next-line (arg) - "Move cursor vertically down ARG lines. -If there is no character in the target line exactly under the current column, -the cursor is positioned after the character in that line which spans this -column, or at the end of the line if it is not long enough. - -If there is no line in the buffer after this one, behavior depends on the -value of `next-line-add-newlines'. If non-nil, it inserts a newline character -to create a line, and moves the cursor to that line. Otherwise it moves the -cursor to the end of the buffer. - -The command \\[set-goal-column] can be used to create -a semipermanent goal column to which this command always moves. -Then it does not try to move vertically. This goal column is stored -in `goal-column', which is nil when there is none. - -If you are thinking of using this in a Lisp program, consider -using `forward-line' instead. It is usually easier to use -and more reliable (no dependence on goal column, etc.)." - (interactive "_p") ; XEmacs - (if (and next-line-add-newlines (= arg 1)) - (let ((opoint (point))) - (end-of-line) - (if (eobp) - (newline 1) - (goto-char opoint) - (line-move arg))) - (if (interactive-p) - ;; XEmacs: Not sure what to do about this. It's inconsistent. -sb - (condition-case nil - (line-move arg) - ((beginning-of-buffer end-of-buffer) - (when signal-error-on-buffer-boundary - (ding nil 'buffer-bound)))) - (line-move arg))) - nil) - -(defun previous-line (arg) - "Move cursor vertically up ARG lines. -If there is no character in the target line exactly over the current column, -the cursor is positioned after the character in that line which spans this -column, or at the end of the line if it is not long enough. - -The command \\[set-goal-column] can be used to create -a semipermanent goal column to which this command always moves. -Then it does not try to move vertically. - -If you are thinking of using this in a Lisp program, consider using -`forward-line' with a negative argument instead. It is usually easier -to use and more reliable (no dependence on goal column, etc.)." - (interactive "_p") ; XEmacs - (if (interactive-p) - (condition-case nil - (line-move (- arg)) - ((beginning-of-buffer end-of-buffer) - (when signal-error-on-buffer-boundary ; XEmacs - (ding nil 'buffer-bound)))) - (line-move (- arg))) - nil) - -(defcustom track-eol nil - "*Non-nil means vertical motion starting at end of line keeps to ends of lines. -This means moving to the end of each line moved onto. -The beginning of a blank line does not count as the end of a line." - :type 'boolean - :group 'editing-basics) - -(defcustom goal-column nil - "*Semipermanent goal column for vertical motion, as set by \\[set-goal-column], or nil." - :type '(choice integer (const :tag "None" nil)) - :group 'editing-basics) -(make-variable-buffer-local 'goal-column) - -(defvar temporary-goal-column 0 - "Current goal column for vertical motion. -It is the column where point was -at the start of current run of vertical motion commands. -When the `track-eol' feature is doing its job, the value is 9999.") - -;XEmacs: not yet ported, so avoid compiler warnings -(eval-when-compile - (defvar inhibit-point-motion-hooks)) - -(defcustom line-move-ignore-invisible nil - "*Non-nil means \\[next-line] and \\[previous-line] ignore invisible lines. -Use with care, as it slows down movement significantly. Outline mode sets this." - :type 'boolean - :group 'editing-basics) - -;; This is the guts of next-line and previous-line. -;; Arg says how many lines to move. -(defun line-move (arg) - ;; Don't run any point-motion hooks, and disregard intangibility, - ;; for intermediate positions. - (let ((inhibit-point-motion-hooks t) - (opoint (point)) - new) - (unwind-protect - (progn - (if (not (or (eq last-command 'next-line) - (eq last-command 'previous-line))) - (setq temporary-goal-column - (if (and track-eol (eolp) - ;; Don't count beg of empty line as end of line - ;; unless we just did explicit end-of-line. - (or (not (bolp)) (eq last-command 'end-of-line))) - 9999 - (current-column)))) - (if (and (not (integerp selective-display)) - (not line-move-ignore-invisible)) - ;; Use just newline characters. - (or (if (> arg 0) - (progn (if (> arg 1) (forward-line (1- arg))) - ;; This way of moving forward ARG lines - ;; verifies that we have a newline after the last one. - ;; It doesn't get confused by intangible text. - (end-of-line) - (zerop (forward-line 1))) - (and (zerop (forward-line arg)) - (bolp))) - (signal (if (< arg 0) - 'beginning-of-buffer - 'end-of-buffer) - nil)) - ;; Move by arg lines, but ignore invisible ones. - (while (> arg 0) - (end-of-line) - (and (zerop (vertical-motion 1)) - (signal 'end-of-buffer nil)) - ;; If the following character is currently invisible, - ;; skip all characters with that same `invisible' property value. - (while (and (not (eobp)) - (let ((prop - (get-char-property (point) 'invisible))) - (if (eq buffer-invisibility-spec t) - prop - (or (memq prop buffer-invisibility-spec) - (assq prop buffer-invisibility-spec))))) - (if (get-text-property (point) 'invisible) - (goto-char (next-single-property-change (point) 'invisible)) - (goto-char (next-extent-change (point))))) ; XEmacs - (setq arg (1- arg))) - (while (< arg 0) - (beginning-of-line) - (and (zerop (vertical-motion -1)) - (signal 'beginning-of-buffer nil)) - (while (and (not (bobp)) - (let ((prop - (get-char-property (1- (point)) 'invisible))) - (if (eq buffer-invisibility-spec t) - prop - (or (memq prop buffer-invisibility-spec) - (assq prop buffer-invisibility-spec))))) - (if (get-text-property (1- (point)) 'invisible) - (goto-char (previous-single-property-change (point) 'invisible)) - (goto-char (previous-extent-change (point))))) ; XEmacs - (setq arg (1+ arg)))) - (move-to-column (or goal-column temporary-goal-column))) - ;; Remember where we moved to, go back home, - ;; then do the motion over again - ;; in just one step, with intangibility and point-motion hooks - ;; enabled this time. - (setq new (point)) - (goto-char opoint) - (setq inhibit-point-motion-hooks nil) - (goto-char new))) - nil) - -;;; Many people have said they rarely use this feature, and often type -;;; it by accident. Maybe it shouldn't even be on a key. -;; It's not on a key, as of 20.2. So no need for this. -;(put 'set-goal-column 'disabled t) - -(defun set-goal-column (arg) - "Set the current horizontal position as a goal for \\[next-line] and \\[previous-line]. -Those commands will move to this position in the line moved to -rather than trying to keep the same horizontal position. -With a non-nil argument, clears out the goal column -so that \\[next-line] and \\[previous-line] resume vertical motion. -The goal column is stored in the variable `goal-column'." - (interactive "_P") ; XEmacs - (if arg - (progn - (setq goal-column nil) - (display-message 'command "No goal column")) - (setq goal-column (current-column)) - (message (substitute-command-keys - "Goal column %d (use \\[set-goal-column] with an arg to unset it)") - goal-column)) - nil) - -;; deleted FSFmacs terminal randomness hscroll-point-visible stuff. -;; hscroll-step -;; hscroll-point-visible -;; hscroll-window-column -;; right-arrow -;; left-arrow - -(defun scroll-other-window-down (lines) - "Scroll the \"other window\" down. -For more details, see the documentation for `scroll-other-window'." - (interactive "P") - (scroll-other-window - ;; Just invert the argument's meaning. - ;; We can do that without knowing which window it will be. - (if (eq lines '-) nil - (if (null lines) '- - (- (prefix-numeric-value lines)))))) -;(define-key esc-map [?\C-\S-v] 'scroll-other-window-down) - -(defun beginning-of-buffer-other-window (arg) - "Move point to the beginning of the buffer in the other window. -Leave mark at previous position. -With arg N, put point N/10 of the way from the true beginning." - (interactive "P") - (let ((orig-window (selected-window)) - (window (other-window-for-scrolling))) - ;; We use unwind-protect rather than save-window-excursion - ;; because the latter would preserve the things we want to change. - (unwind-protect - (progn - (select-window window) - ;; Set point and mark in that window's buffer. - (beginning-of-buffer arg) - ;; Set point accordingly. - (recenter '(t))) - (select-window orig-window)))) - -(defun end-of-buffer-other-window (arg) - "Move point to the end of the buffer in the other window. -Leave mark at previous position. -With arg N, put point N/10 of the way from the true end." - (interactive "P") - ;; See beginning-of-buffer-other-window for comments. - (let ((orig-window (selected-window)) - (window (other-window-for-scrolling))) - (unwind-protect - (progn - (select-window window) - (end-of-buffer arg) - (recenter '(t))) - (select-window orig-window)))) - -(defun transpose-chars (arg) - "Interchange characters around point, moving forward one character. -With prefix arg ARG, effect is to take character before point -and drag it forward past ARG other characters (backward if ARG negative). -If no argument and at end of line, the previous two chars are exchanged." - (interactive "*P") - (and (null arg) (eolp) (forward-char -1)) - (transpose-subr 'forward-char (prefix-numeric-value arg))) - -;;; A very old implementation of transpose-chars from the old days ... -(defun transpose-preceding-chars (arg) - "Interchange characters before point. -With prefix arg ARG, effect is to take character before point -and drag it forward past ARG other characters (backward if ARG negative). -If no argument and not at start of line, the previous two chars are exchanged." - (interactive "*P") - (and (null arg) (not (bolp)) (forward-char -1)) - (transpose-subr 'forward-char (prefix-numeric-value arg))) - - -(defun transpose-words (arg) - "Interchange words around point, leaving point at end of them. -With prefix arg ARG, effect is to take word before or around point -and drag it forward past ARG other words (backward if ARG negative). -If ARG is zero, the words around or after point and around or after mark -are interchanged." - (interactive "*p") - (transpose-subr 'forward-word arg)) - -(defun transpose-sexps (arg) - "Like \\[transpose-words] but applies to sexps. -Does not work on a sexp that point is in the middle of -if it is a list or string." - (interactive "*p") - (transpose-subr 'forward-sexp arg)) - -(defun transpose-lines (arg) - "Exchange current line and previous line, leaving point after both. -With argument ARG, takes previous line and moves it past ARG lines. -With argument 0, interchanges line point is in with line mark is in." - (interactive "*p") - (transpose-subr #'(lambda (arg) - (if (= arg 1) - (progn - ;; Move forward over a line, - ;; but create a newline if none exists yet. - (end-of-line) - (if (eobp) - (newline) - (forward-char 1))) - (forward-line arg))) - arg)) - -(eval-when-compile - ;; avoid byte-compiler warnings... - (defvar start1) - (defvar start2) - (defvar end1) - (defvar end2)) - -; start[12] and end[12] used in transpose-subr-1 below -(defun transpose-subr (mover arg) - (let (start1 end1 start2 end2) - (if (= arg 0) - (progn - (save-excursion - (funcall mover 1) - (setq end2 (point)) - (funcall mover -1) - (setq start2 (point)) - (goto-char (mark t)) ; XEmacs - (funcall mover 1) - (setq end1 (point)) - (funcall mover -1) - (setq start1 (point)) - (transpose-subr-1)) - (exchange-point-and-mark t))) ; XEmacs - (while (> arg 0) - (funcall mover -1) - (setq start1 (point)) - (funcall mover 1) - (setq end1 (point)) - (funcall mover 1) - (setq end2 (point)) - (funcall mover -1) - (setq start2 (point)) - (transpose-subr-1) - (goto-char end2) - (setq arg (1- arg))) - (while (< arg 0) - (funcall mover -1) - (setq start2 (point)) - (funcall mover -1) - (setq start1 (point)) - (funcall mover 1) - (setq end1 (point)) - (funcall mover 1) - (setq end2 (point)) - (transpose-subr-1) - (setq arg (1+ arg))))) - -; start[12] and end[12] used free -(defun transpose-subr-1 () - (if (> (min end1 end2) (max start1 start2)) - (error "Don't have two things to transpose")) - (let ((word1 (buffer-substring start1 end1)) - (word2 (buffer-substring start2 end2))) - (delete-region start2 end2) - (goto-char start2) - (insert word1) - (goto-char (if (< start1 start2) start1 - (+ start1 (- (length word1) (length word2))))) - (delete-char (length word1)) - (insert word2))) - -(defcustom comment-column 32 - "*Column to indent right-margin comments to. -Setting this variable automatically makes it local to the current buffer. -Each mode establishes a different default value for this variable; you -can set the value for a particular mode using that mode's hook." - :type 'integer - :group 'fill-comments) -(make-variable-buffer-local 'comment-column) - -(defcustom comment-start nil - "*String to insert to start a new comment, or nil if no comment syntax." - :type '(choice (const :tag "None" nil) - string) - :group 'fill-comments) - -(defcustom comment-start-skip nil - "*Regexp to match the start of a comment plus everything up to its body. -If there are any \\(...\\) pairs, the comment delimiter text is held to begin -at the place matched by the close of the first pair." - :type '(choice (const :tag "None" nil) - regexp) - :group 'fill-comments) - -(defcustom comment-end "" - "*String to insert to end a new comment. -Should be an empty string if comments are terminated by end-of-line." - :type 'string - :group 'fill-comments) - -(defconst comment-indent-hook nil - "Obsolete variable for function to compute desired indentation for a comment. -Use `comment-indent-function' instead. -This function is called with no args with point at the beginning of -the comment's starting delimiter.") - -(defconst comment-indent-function - ;; XEmacs - add at least one space after the end of the text on the - ;; current line... - (lambda () - (save-excursion - (beginning-of-line) - (let ((eol (save-excursion (end-of-line) (point)))) - (and comment-start-skip - (re-search-forward comment-start-skip eol t) - (setq eol (match-beginning 0))) - (goto-char eol) - (skip-chars-backward " \t") - (max comment-column (1+ (current-column)))))) - "Function to compute desired indentation for a comment. -This function is called with no args with point at the beginning of -the comment's starting delimiter.") - -(defcustom block-comment-start nil - "*String to insert to start a new comment on a line by itself. -If nil, use `comment-start' instead. -Note that the regular expression `comment-start-skip' should skip this string -as well as the `comment-start' string." - :type '(choice (const :tag "Use `comment-start'" nil) - string) - :group 'fill-comments) - -(defcustom block-comment-end nil - "*String to insert to end a new comment on a line by itself. -Should be an empty string if comments are terminated by end-of-line. -If nil, use `comment-end' instead." - :type '(choice (const :tag "Use `comment-end'" nil) - string) - :group 'fill-comments) - -(defun indent-for-comment () - "Indent this line's comment to comment column, or insert an empty comment." - (interactive "*") - (let* ((empty (save-excursion (beginning-of-line) - (looking-at "[ \t]*$"))) - (starter (or (and empty block-comment-start) comment-start)) - (ender (or (and empty block-comment-end) comment-end))) - (if (null starter) - (error "No comment syntax defined") - (let* ((eolpos (save-excursion (end-of-line) (point))) - cpos indent begpos) - (beginning-of-line) - (if (re-search-forward comment-start-skip eolpos 'move) - (progn (setq cpos (point-marker)) - ;; Find the start of the comment delimiter. - ;; If there were paren-pairs in comment-start-skip, - ;; position at the end of the first pair. - (if (match-end 1) - (goto-char (match-end 1)) - ;; If comment-start-skip matched a string with - ;; internal whitespace (not final whitespace) then - ;; the delimiter start at the end of that - ;; whitespace. Otherwise, it starts at the - ;; beginning of what was matched. - (skip-syntax-backward " " (match-beginning 0)) - (skip-syntax-backward "^ " (match-beginning 0))))) - (setq begpos (point)) - ;; Compute desired indent. - (if (= (current-column) - (setq indent (funcall comment-indent-function))) - (goto-char begpos) - ;; If that's different from current, change it. - (skip-chars-backward " \t") - (delete-region (point) begpos) - (indent-to indent)) - ;; An existing comment? - (if cpos - (progn (goto-char cpos) - (set-marker cpos nil)) - ;; No, insert one. - (insert starter) - (save-excursion - (insert ender))))))) - -(defun set-comment-column (arg) - "Set the comment column based on point. -With no arg, set the comment column to the current column. -With just minus as arg, kill any comment on this line. -With any other arg, set comment column to indentation of the previous comment - and then align or create a comment on this line at that column." - (interactive "P") - (if (eq arg '-) - (kill-comment nil) - (if arg - (progn - (save-excursion - (beginning-of-line) - (re-search-backward comment-start-skip) - (beginning-of-line) - (re-search-forward comment-start-skip) - (goto-char (match-beginning 0)) - (setq comment-column (current-column)) - (display-message - 'command - (format "Comment column set to %d" comment-column))) - (indent-for-comment)) - (setq comment-column (current-column)) - (display-message - 'command - (format "Comment column set to %d" comment-column))))) - -(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 - ;; 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. - (interactive "*P") - (or comment-start-skip (error "No comment syntax defined")) - (let ((count (prefix-numeric-value arg)) endc) - (while (> count 0) - (save-excursion - (end-of-line) - (setq endc (point)) - (beginning-of-line) - (and (string< "" comment-end) - (setq endc - (progn - (re-search-forward (regexp-quote comment-end) endc 'move) - (skip-chars-forward " \t") - (point)))) - (beginning-of-line) - (if (re-search-forward comment-start-skip endc t) - (progn - (goto-char (match-beginning 0)) - (skip-chars-backward " \t") - (kill-region (point) endc) - ;; to catch comments a line beginnings - (indent-according-to-mode)))) - (if arg (forward-line 1)) - (setq count (1- count))))) - -(defun comment-region (beg end &optional arg) - "Comment or uncomment each line in the region. -With just C-u prefix arg, uncomment each line in region. -Numeric prefix arg ARG means use ARG comment characters. -If ARG is negative, delete that many comment characters instead. -Comments are terminated on each line, even for syntax in which newline does -not end the comment. Blank lines do not get comments." - ;; if someone wants it to only put a comment-start at the beginning and - ;; comment-end at the end then typing it, C-x C-x, closing it, C-x C-x - ;; is easy enough. No option is made here for other than commenting - ;; every line. - (interactive "r\nP") - (or comment-start (error "No comment syntax is defined")) - (if (> beg end) (let (mid) (setq mid beg beg end end mid))) - (save-excursion - (save-restriction - (let ((cs comment-start) (ce comment-end) - numarg) - (if (consp arg) (setq numarg t) - (setq numarg (prefix-numeric-value arg)) - ;; For positive arg > 1, replicate the comment delims now, - ;; then insert the replicated strings just once. - (while (> numarg 1) - (setq cs (concat cs comment-start) - ce (concat ce comment-end)) - (setq numarg (1- numarg)))) - ;; Loop over all lines from BEG to END. - (narrow-to-region beg end) - (goto-char beg) - (while (not (eobp)) - (if (or (eq numarg t) (< numarg 0)) - (progn - ;; Delete comment start from beginning of line. - (if (eq numarg t) - (while (looking-at (regexp-quote cs)) - (delete-char (length cs))) - (let ((count numarg)) - (while (and (> 1 (setq count (1+ count))) - (looking-at (regexp-quote cs))) - (delete-char (length cs))))) - ;; Delete comment end from end of line. - (if (string= "" ce) - nil - (if (eq numarg t) - (progn - (end-of-line) - ;; This is questionable if comment-end ends in - ;; whitespace. That is pretty brain-damaged, - ;; though. - (skip-chars-backward " \t") - (if (and (>= (- (point) (point-min)) (length ce)) - (save-excursion - (backward-char (length ce)) - (looking-at (regexp-quote ce)))) - (delete-char (- (length ce))))) - (let ((count numarg)) - (while (> 1 (setq count (1+ count))) - (end-of-line) - ;; This is questionable if comment-end ends in - ;; whitespace. That is pretty brain-damaged though - (skip-chars-backward " \t") - (save-excursion - (backward-char (length ce)) - (if (looking-at (regexp-quote ce)) - (delete-char (length ce)))))))) - (forward-line 1)) - ;; Insert at beginning and at end. - (if (looking-at "[ \t]*$") () - (insert cs) - (if (string= "" ce) () - (end-of-line) - (insert ce))) - (search-forward "\n" nil 'move))))))) - -;; XEmacs -(defun prefix-region (prefix) - "Add a prefix string to each line between mark and point." - (interactive "sPrefix string: ") - (if prefix - (let ((count (count-lines (mark) (point)))) - (goto-char (min (mark) (point))) - (while (> count 0) - (setq count (1- count)) - (beginning-of-line 1) - (insert prefix) - (end-of-line 1) - (forward-char 1))))) - - -;; XEmacs - extra parameter -(defun backward-word (arg &optional buffer) - "Move backward until encountering the end of a word. -With argument, do this that many times. -In programs, it is faster to call `forward-word' with negative arg." - (interactive "_p") ; XEmacs - (forward-word (- arg) buffer)) - -(defun mark-word (arg) - "Set mark arg words away from point." - (interactive "p") - (mark-something 'mark-word 'forward-word arg)) - -;; XEmacs modified -(defun kill-word (arg) - "Kill characters forward until encountering the end of a word. -With argument, do this that many times." - (interactive "*p") - (kill-region (point) (save-excursion (forward-word arg) (point)))) - -(defun backward-kill-word (arg) - "Kill characters backward until encountering the end of a word. -With argument, do this that many times." - (interactive "*p") ; XEmacs - (kill-word (- arg))) - -(defun current-word (&optional strict) - "Return the word point is on (or a nearby word) as a string. -If optional arg STRICT is non-nil, return nil unless point is within -or adjacent to a word. -If point is not between two word-constituent characters, but immediately -follows one, move back first. -Otherwise, if point precedes a word constituent, move forward first. -Otherwise, move backwards until a word constituent is found and get that word; -if you a newlines is reached first, move forward instead." - (save-excursion - (let ((oldpoint (point)) (start (point)) (end (point))) - (skip-syntax-backward "w_") (setq start (point)) - (goto-char oldpoint) - (skip-syntax-forward "w_") (setq end (point)) - (if (and (eq start oldpoint) (eq end oldpoint)) - ;; Point is neither within nor adjacent to a word. - (and (not strict) - (progn - ;; Look for preceding word in same line. - (skip-syntax-backward "^w_" - (save-excursion - (beginning-of-line) (point))) - (if (bolp) - ;; No preceding word in same line. - ;; Look for following word in same line. - (progn - (skip-syntax-forward "^w_" - (save-excursion - (end-of-line) (point))) - (setq start (point)) - (skip-syntax-forward "w_") - (setq end (point))) - (setq end (point)) - (skip-syntax-backward "w_") - (setq start (point))) - (buffer-substring start end))) - (buffer-substring start end))))) - -(defcustom fill-prefix nil - "*String for filling to insert at front of new line, or nil for none. -Setting this variable automatically makes it local to the current buffer." - :type '(choice (const :tag "None" nil) - string) - :group 'fill) -(make-variable-buffer-local 'fill-prefix) - -(defcustom auto-fill-inhibit-regexp nil - "*Regexp to match lines which should not be auto-filled." - :type '(choice (const :tag "None" nil) - regexp) - :group 'fill) - -(defvar comment-line-break-function 'indent-new-comment-line - "*Mode-specific function which line breaks and continues a comment. - -This function is only called during auto-filling of a comment section. -The function should take a single optional argument which is a flag -indicating whether soft newlines should be inserted.") - -;; This function is the auto-fill-function of a buffer -;; when Auto-Fill mode is enabled. -;; It returns t if it really did any work. -;; XEmacs: This function is totally different. -(defun do-auto-fill () - (let (give-up) - (or (and auto-fill-inhibit-regexp - (save-excursion (beginning-of-line) - (looking-at auto-fill-inhibit-regexp))) - (while (and (not give-up) (> (current-column) fill-column)) - ;; Determine where to split the line. - (let ((fill-prefix fill-prefix) - (fill-point - (let ((opoint (point)) - bounce - ;; 97/3/14 jhod: Kinsoku - (re-break-point (if (featurep 'mule) - (concat "[ \t\n]\\|" word-across-newline) - "[ \t\n]")) - ;; end patch - (first t)) - (save-excursion - (move-to-column (1+ fill-column)) - ;; Move back to a word boundary. - (while (or first - ;; If this is after period and a single space, - ;; move back once more--we don't want to break - ;; the line there and make it look like a - ;; sentence end. - (and (not (bobp)) - (not bounce) - sentence-end-double-space - (save-excursion (forward-char -1) - (and (looking-at "\\. ") - (not (looking-at "\\. ")))))) - (setq first nil) - ;; 97/3/14 jhod: Kinsoku - ; (skip-chars-backward "^ \t\n")) - (fill-move-backward-to-break-point re-break-point) - ;; end patch - ;; If we find nowhere on the line to break it, - ;; break after one word. Set bounce to t - ;; so we will not keep going in this while loop. - (if (bolp) - (progn - ;; 97/3/14 jhod: Kinsoku - ; (re-search-forward "[ \t]" opoint t) - (fill-move-forward-to-break-point re-break-point - opoint) - ;; end patch - (setq bounce t))) - (skip-chars-backward " \t")) - (if (and (featurep 'mule) - (or bounce (bolp))) (kinsoku-process)) ;; 97/3/14 jhod: Kinsoku - ;; Let fill-point be set to the place where we end up. - (point))))) - - ;; I'm not sure why Stig made this change but it breaks - ;; auto filling in at least C mode so I'm taking it back - ;; out. --cet - ;; XEmacs - adaptive fill. - ;;(maybe-adapt-fill-prefix - ;; (or from (setq from (save-excursion (beginning-of-line) - ;; (point)))) - ;; (or to (setq to (save-excursion (beginning-of-line 2) - ;; (point)))) - ;; t) - - ;; If that place is not the beginning of the line, - ;; break the line there. - (if (save-excursion - (goto-char fill-point) - (not (or (bolp) (eolp)))) ; 97/3/14 jhod: during kinsoku processing it is possible to move beyond - (let ((prev-column (current-column))) - ;; If point is at the fill-point, do not `save-excursion'. - ;; Otherwise, if a comment prefix or fill-prefix is inserted, - ;; point will end up before it rather than after it. - (if (save-excursion - (skip-chars-backward " \t") - (= (point) fill-point)) - ;; 97/3/14 jhod: Kinsoku processing - ;(indent-new-comment-line) - (let ((spacep (memq (char-before (point)) '(?\ ?\t)))) - (funcall comment-line-break-function) - ;; if user type space explicitly, leave SPC - ;; even if there is no WAN. - (if spacep - (save-excursion - (goto-char fill-point) - ;; put SPC except that there is SPC - ;; already or there is sentence end. - (or (memq (char-after (point)) '(?\ ?\t)) - (fill-end-of-sentence-p) - (insert ?\ ))))) - (save-excursion - (goto-char fill-point) - (funcall comment-line-break-function))) - ;; If making the new line didn't reduce the hpos of - ;; the end of the line, then give up now; - ;; trying again will not help. - (if (>= (current-column) prev-column) - (setq give-up t))) - ;; No place to break => stop trying. - (setq give-up t))))))) - -;; Put FSF one in until I can one or the other working properly, then the -;; other one is history. -(defun fsf:do-auto-fill () - (let (fc justify - ;; bol - give-up - (fill-prefix fill-prefix)) - (if (or (not (setq justify (current-justification))) - (null (setq fc (current-fill-column))) - (and (eq justify 'left) - (<= (current-column) fc)) - (save-excursion (beginning-of-line) - ;; (setq bol (point)) - (and auto-fill-inhibit-regexp - (looking-at auto-fill-inhibit-regexp)))) - nil ;; Auto-filling not required - (if (memq justify '(full center right)) - (save-excursion (unjustify-current-line))) - - ;; Choose a fill-prefix automatically. - (if (and adaptive-fill-mode - (or (null fill-prefix) (string= fill-prefix ""))) - (let ((prefix - (fill-context-prefix - (save-excursion (backward-paragraph 1) (point)) - (save-excursion (forward-paragraph 1) (point)) - ;; Don't accept a non-whitespace fill prefix - ;; from the first line of a paragraph. - "^[ \t]*$"))) - (and prefix (not (equal prefix "")) - (setq fill-prefix prefix)))) - - (while (and (not give-up) (> (current-column) fc)) - ;; Determine where to split the line. - (let ((fill-point - (let ((opoint (point)) - bounce - (first t)) - (save-excursion - (move-to-column (1+ fc)) - ;; Move back to a word boundary. - (while (or first - ;; If this is after period and a single space, - ;; move back once more--we don't want to break - ;; the line there and make it look like a - ;; sentence end. - (and (not (bobp)) - (not bounce) - sentence-end-double-space - (save-excursion (forward-char -1) - (and (looking-at "\\. ") - (not (looking-at "\\. ")))))) - (setq first nil) - (skip-chars-backward "^ \t\n") - ;; If we find nowhere on the line to break it, - ;; break after one word. Set bounce to t - ;; so we will not keep going in this while loop. - (if (bolp) - (progn - (re-search-forward "[ \t]" opoint t) - (setq bounce t))) - (skip-chars-backward " \t")) - ;; Let fill-point be set to the place where we end up. - (point))))) - ;; If that place is not the beginning of the line, - ;; break the line there. - (if (save-excursion - (goto-char fill-point) - (not (bolp))) - (let ((prev-column (current-column))) - ;; If point is at the fill-point, do not `save-excursion'. - ;; Otherwise, if a comment prefix or fill-prefix is inserted, - ;; point will end up before it rather than after it. - (if (save-excursion - (skip-chars-backward " \t") - (= (point) fill-point)) - (funcall comment-line-break-function t) - (save-excursion - (goto-char fill-point) - (funcall comment-line-break-function t))) - ;; Now do justification, if required - (if (not (eq justify 'left)) - (save-excursion - (end-of-line 0) - (justify-current-line justify nil t))) - ;; If making the new line didn't reduce the hpos of - ;; the end of the line, then give up now; - ;; trying again will not help. - (if (>= (current-column) prev-column) - (setq give-up t))) - ;; No place to break => stop trying. - (setq give-up t)))) - ;; Justify last line. - (justify-current-line justify t t) - t))) - -(defvar normal-auto-fill-function 'do-auto-fill - "The function to use for `auto-fill-function' if Auto Fill mode is turned on. -Some major modes set this.") - -(defun auto-fill-mode (&optional arg) - "Toggle auto-fill mode. -With arg, turn auto-fill mode on if and only if arg is positive. -In Auto-Fill mode, inserting a space at a column beyond `current-fill-column' -automatically breaks the line at a previous space. - -The value of `normal-auto-fill-function' specifies the function to use -for `auto-fill-function' when turning Auto Fill mode on." - (interactive "P") - (prog1 (setq auto-fill-function - (if (if (null arg) - (not auto-fill-function) - (> (prefix-numeric-value arg) 0)) - normal-auto-fill-function - nil)) - (redraw-modeline))) - -;; This holds a document string used to document auto-fill-mode. -(defun auto-fill-function () - "Automatically break line at a previous space, in insertion of text." - nil) - -(defun turn-on-auto-fill () - "Unconditionally turn on Auto Fill mode." - (auto-fill-mode 1)) - -(defun set-fill-column (arg) - "Set `fill-column' to specified argument. -Just \\[universal-argument] as argument means to use the current column -The variable `fill-column' has a separate value for each buffer." - (interactive "_P") ; XEmacs - (cond ((integerp arg) - (setq fill-column arg)) - ((consp arg) - (setq fill-column (current-column))) - ;; Disallow missing argument; it's probably a typo for C-x C-f. - (t - (error "set-fill-column requires an explicit argument"))) - (display-message 'command (format "fill-column set to %d" fill-column))) - -(defcustom comment-multi-line t ; XEmacs - this works well with adaptive fill - "*Non-nil means \\[indent-new-comment-line] should continue same comment -on new line, with no new terminator or starter. -This is obsolete because you might as well use \\[newline-and-indent]." - :type 'boolean - :group 'fill-comments) - -(defun indent-new-comment-line (&optional soft) - "Break line at point and indent, continuing comment if within one. -This indents the body of the continued comment -under the previous comment line. - -This command is intended for styles where you write a comment per line, -starting a new comment (and terminating it if necessary) on each line. -If you want to continue one comment across several lines, use \\[newline-and-indent]. - -If a fill column is specified, it overrides the use of the comment column -or comment indentation. - -The inserted newline is marked hard if `use-hard-newlines' is true, -unless optional argument SOFT is non-nil." - (interactive) - (let (comcol comstart) - (skip-chars-backward " \t") - ;; 97/3/14 jhod: Kinsoku processing - (if (featurep 'mule) - (kinsoku-process)) - (delete-region (point) - (progn (skip-chars-forward " \t") - (point))) - (if soft (insert ?\n) (newline 1)) - (if fill-prefix - (progn - (indent-to-left-margin) - (insert fill-prefix)) - ;; #### - Eric Eide reverts to v18 semantics for this function in - ;; fa-extras, which I'm not gonna do. His changes are to (1) execute - ;; the save-excursion below unconditionally, and (2) uncomment the check - ;; for (not comment-multi-line) further below. --Stig - ;;### jhod: probably need to fix this for kinsoku processing - (if (not comment-multi-line) - (save-excursion - (if (and comment-start-skip - (let ((opoint (point))) - (forward-line -1) - (re-search-forward comment-start-skip opoint t))) - ;; The old line is a comment. - ;; Set WIN to the pos of the comment-start. - ;; But if the comment is empty, look at preceding lines - ;; to find one that has a nonempty comment. - - ;; If comment-start-skip contains a \(...\) pair, - ;; the real comment delimiter starts at the end of that pair. - (let ((win (or (match-end 1) (match-beginning 0)))) - (while (and (eolp) (not (bobp)) - (let (opoint) - (beginning-of-line) - (setq opoint (point)) - (forward-line -1) - (re-search-forward comment-start-skip opoint t))) - (setq win (or (match-end 1) (match-beginning 0)))) - ;; Indent this line like what we found. - (goto-char win) - (setq comcol (current-column)) - (setq comstart - (buffer-substring (point) (match-end 0))))))) - (if (and comcol (not fill-prefix)) ; XEmacs - (ENE) from fa-extras. - (let ((comment-column comcol) - (comment-start comstart) - (comment-end comment-end)) - (and comment-end (not (equal comment-end "")) - ; (if (not comment-multi-line) - (progn - (forward-char -1) - (insert comment-end) - (forward-char 1)) - ; (setq comment-column (+ comment-column (length comment-start)) - ; comment-start "") - ; ) - ) - (if (not (eolp)) - (setq comment-end "")) - (insert ?\n) - (forward-char -1) - (indent-for-comment) - (save-excursion - ;; Make sure we delete the newline inserted above. - (end-of-line) - (delete-char 1))) - (indent-according-to-mode))))) - - -(defun set-selective-display (arg) - "Set `selective-display' to ARG; clear it if no arg. -When the value of `selective-display' is a number > 0, -lines whose indentation is >= that value are not displayed. -The variable `selective-display' has a separate value for each buffer." - (interactive "P") - (if (eq selective-display t) - (error "selective-display already in use for marked lines")) - (let ((current-vpos - (save-restriction - (narrow-to-region (point-min) (point)) - (goto-char (window-start)) - (vertical-motion (window-height))))) - (setq selective-display - (and arg (prefix-numeric-value arg))) - (recenter current-vpos)) - (set-window-start (selected-window) (window-start (selected-window))) - ;; #### doesn't localize properly: - (princ "selective-display set to " t) - (prin1 selective-display t) - (princ "." t)) - -;; XEmacs -(defun nuke-selective-display () - "Ensure that the buffer is not in selective-display mode. -If `selective-display' is t, then restore the buffer text to it's original -state before disabling selective display." - ;; by Stig@hackvan.com - (interactive) - (and (eq t selective-display) - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (let ((mod-p (buffer-modified-p)) - (buffer-read-only nil)) - (while (search-forward "\r" nil t) - (delete-char -1) - (insert "\n")) - (set-buffer-modified-p mod-p) - )))) - (setq selective-display nil)) - -(add-hook 'change-major-mode-hook 'nuke-selective-display) - -(defconst overwrite-mode-textual (purecopy " Ovwrt") - "The string displayed in the mode line when in overwrite mode.") -(defconst overwrite-mode-binary (purecopy " Bin Ovwrt") - "The string displayed in the mode line when in binary overwrite mode.") - -(defun overwrite-mode (arg) - "Toggle overwrite mode. -With arg, turn overwrite mode on iff arg is positive. -In overwrite mode, printing characters typed in replace existing text -on a one-for-one basis, rather than pushing it to the right. At the -end of a line, such characters extend the line. Before a tab, -such characters insert until the tab is filled in. -\\[quoted-insert] still inserts characters in overwrite mode; this -is supposed to make it easier to insert characters when necessary." - (interactive "P") - (setq overwrite-mode - (if (if (null arg) (not overwrite-mode) - (> (prefix-numeric-value arg) 0)) - 'overwrite-mode-textual)) - (redraw-modeline)) - -(defun binary-overwrite-mode (arg) - "Toggle binary overwrite mode. -With arg, turn binary overwrite mode on iff arg is positive. -In binary overwrite mode, printing characters typed in replace -existing text. Newlines are not treated specially, so typing at the -end of a line joins the line to the next, with the typed character -between them. Typing before a tab character simply replaces the tab -with the character typed. -\\[quoted-insert] replaces the text at the cursor, just as ordinary -typing characters do. - -Note that binary overwrite mode is not its own minor mode; it is a -specialization of overwrite-mode, entered by setting the -`overwrite-mode' variable to `overwrite-mode-binary'." - (interactive "P") - (setq overwrite-mode - (if (if (null arg) - (not (eq overwrite-mode 'overwrite-mode-binary)) - (> (prefix-numeric-value arg) 0)) - 'overwrite-mode-binary)) - (redraw-modeline)) - -(defcustom line-number-mode nil - "*Non-nil means display line number in modeline." - :type 'boolean - :group 'editing-basics) - -(defun line-number-mode (arg) - "Toggle Line Number mode. -With arg, turn Line Number mode on iff arg is positive. -When Line Number mode is enabled, the line number appears -in the mode line." - (interactive "P") - (setq line-number-mode - (if (null arg) (not line-number-mode) - (> (prefix-numeric-value arg) 0))) - (redraw-modeline)) - -(defcustom column-number-mode nil - "*Non-nil means display column number in mode line." - :type 'boolean - :group 'editing-basics) - -(defun column-number-mode (arg) - "Toggle Column Number mode. -With arg, turn Column Number mode on iff arg is positive. -When Column Number mode is enabled, the column number appears -in the mode line." - (interactive "P") - (setq column-number-mode - (if (null arg) (not column-number-mode) - (> (prefix-numeric-value arg) 0))) - (redraw-modeline)) - - -(defcustom blink-matching-paren t - "*Non-nil means show matching open-paren when close-paren is inserted." - :type 'boolean - :group 'paren-blinking) - -(defcustom blink-matching-paren-on-screen t - "*Non-nil means show matching open-paren when it is on screen. -nil means don't show it (but the open-paren can still be shown -when it is off screen." - :type 'boolean - :group 'paren-blinking) - -(defcustom blink-matching-paren-distance 12000 - "*If non-nil, is maximum distance to search for matching open-paren." - :type '(choice integer (const nil)) - :group 'paren-blinking) - -(defcustom blink-matching-delay 1 - "*The number of seconds that `blink-matching-open' will delay at a match." - :type 'number - :group 'paren-blinking) - -(defcustom blink-matching-paren-dont-ignore-comments nil - "*Non-nil means `blink-matching-paren' should not ignore comments." - :type 'boolean - :group 'paren-blinking) - -(defun blink-matching-open () - "Move cursor momentarily to the beginning of the sexp before point." - (interactive "_") ; XEmacs - (and (> (point) (1+ (point-min))) - blink-matching-paren - ;; Verify an even number of quoting characters precede the close. - (= 1 (logand 1 (- (point) - (save-excursion - (forward-char -1) - (skip-syntax-backward "/\\") - (point))))) - (let* ((oldpos (point)) - (parse-sexp-ignore-comments t) ; to avoid C++ lossage - (blinkpos) - (mismatch)) - (save-excursion - (save-restriction - (if blink-matching-paren-distance - (narrow-to-region (max (point-min) - (- (point) blink-matching-paren-distance)) - oldpos)) - (condition-case () - (let ((parse-sexp-ignore-comments - (and parse-sexp-ignore-comments - (not blink-matching-paren-dont-ignore-comments)))) - (setq blinkpos (scan-sexps oldpos -1))) - (error nil))) - (and blinkpos - (/= (char-syntax (char-after blinkpos)) - ?\$) - (setq mismatch - (or (null (matching-paren (char-after blinkpos))) - (/= (char-after (1- oldpos)) - (matching-paren (char-after blinkpos)))))) - (if mismatch (setq blinkpos nil)) - (if blinkpos - (progn - (goto-char blinkpos) - (if (pos-visible-in-window-p) - (and blink-matching-paren-on-screen - (progn - (auto-show-make-point-visible) - (sit-for blink-matching-delay))) - (goto-char blinkpos) - (display-message - 'command - (format - "Matches %s" - ;; Show what precedes the open in its line, if anything. - (if (save-excursion - (skip-chars-backward " \t") - (not (bolp))) - (buffer-substring (progn (beginning-of-line) (point)) - (1+ blinkpos)) - ;; Show what follows the open in its line, if anything. - (if (save-excursion - (forward-char 1) - (skip-chars-forward " \t") - (not (eolp))) - (buffer-substring blinkpos - (progn (end-of-line) (point))) - ;; Otherwise show the previous nonblank line, - ;; if there is one. - (if (save-excursion - (skip-chars-backward "\n \t") - (not (bobp))) - (concat - (buffer-substring (progn - (skip-chars-backward "\n \t") - (beginning-of-line) - (point)) - (progn (end-of-line) - (skip-chars-backward " \t") - (point))) - ;; Replace the newline and other whitespace with `...'. - "..." - (buffer-substring blinkpos (1+ blinkpos))) - ;; There is nothing to show except the char itself. - (buffer-substring blinkpos (1+ blinkpos))))))))) - (cond (mismatch - (display-message 'no-log "Mismatched parentheses")) - ((not blink-matching-paren-distance) - (display-message 'no-log "Unmatched parenthesis")))))))) - -;Turned off because it makes dbx bomb out. -(setq blink-paren-function 'blink-matching-open) - -(eval-when-compile (defvar myhelp)) ; suppress compiler warning - -;; XEmacs: Some functions moved to cmdloop.el: -;; keyboard-quit -;; buffer-quit-function -;; keyboard-escape-quit - -(defun assoc-ignore-case (key alist) - "Like `assoc', but assumes KEY is a string and ignores case when comparing." - (setq key (downcase key)) - (let (element) - (while (and alist (not element)) - (if (equal key (downcase (car (car alist)))) - (setq element (car alist))) - (setq alist (cdr alist))) - element)) - - -(defcustom mail-user-agent 'sendmail-user-agent - "*Your preference for a mail composition package. -Various Emacs Lisp packages (e.g. reporter) require you to compose an -outgoing email message. This variable lets you specify which -mail-sending package you prefer. - -Valid values include: - - sendmail-user-agent -- use the default Emacs Mail package - mh-e-user-agent -- use the Emacs interface to the MH mail system - message-user-agent -- use the GNUS mail sending package - -Additional valid symbols may be available; check with the author of -your package for details." - :type '(radio (function-item :tag "Default Emacs mail" - :format "%t\n" - sendmail-user-agent) - (function-item :tag "Gnus mail sending package" - :format "%t\n" - message-user-agent) - (function :tag "Other")) - :group 'mail) - -(defun define-mail-user-agent (symbol composefunc sendfunc - &optional abortfunc hookvar) - "Define a symbol to identify a mail-sending package for `mail-user-agent'. - -SYMBOL can be any Lisp symbol. Its function definition and/or -value as a variable do not matter for this usage; we use only certain -properties on its property list, to encode the rest of the arguments. - -COMPOSEFUNC is program callable function that composes an outgoing -mail message buffer. This function should set up the basics of the -buffer without requiring user interaction. It should populate the -standard mail headers, leaving the `to:' and `subject:' headers blank -by default. - -COMPOSEFUNC should accept several optional arguments--the same -arguments that `compose-mail' takes. See that function's documentation. - -SENDFUNC is the command a user would run to send the message. - -Optional ABORTFUNC is the command a user would run to abort the -message. For mail packages that don't have a separate abort function, -this can be `kill-buffer' (the equivalent of omitting this argument). - -Optional HOOKVAR is a hook variable that gets run before the message -is actually sent. Callers that use the `mail-user-agent' may -install a hook function temporarily on this hook variable. -If HOOKVAR is nil, `mail-send-hook' is used. - -The properties used on SYMBOL are `composefunc', `sendfunc', -`abortfunc', and `hookvar'." - (put symbol 'composefunc composefunc) - (put symbol 'sendfunc sendfunc) - (put symbol 'abortfunc (or abortfunc 'kill-buffer)) - (put symbol 'hookvar (or hookvar 'mail-send-hook))) - -(define-mail-user-agent 'sendmail-user-agent - 'sendmail-user-agent-compose 'mail-send-and-exit) - -(define-mail-user-agent 'message-user-agent - 'message-mail 'message-send-and-exit - 'message-kill-buffer 'message-send-hook) - -(defun sendmail-user-agent-compose (&optional to subject other-headers continue - switch-function yank-action - send-actions) - (if switch-function - (let ((special-display-buffer-names nil) - (special-display-regexps nil) - (same-window-buffer-names nil) - (same-window-regexps nil)) - (funcall switch-function "*mail*"))) - (let ((cc (cdr (assoc-ignore-case "cc" other-headers))) - (in-reply-to (cdr (assoc-ignore-case "in-reply-to" other-headers)))) - (or (mail continue to subject in-reply-to cc yank-action send-actions) - continue - (error "Message aborted")) - (save-excursion - (goto-char (point-min)) - (search-forward mail-header-separator) - (beginning-of-line) - (while other-headers - (if (not (member (car (car other-headers)) '("in-reply-to" "cc"))) - (insert (car (car other-headers)) ": " - (cdr (car other-headers)) "\n")) - (setq other-headers (cdr other-headers))) - t))) - -(define-mail-user-agent 'mh-e-user-agent - 'mh-smail-batch 'mh-send-letter 'mh-fully-kill-draft - 'mh-before-send-letter-hook) - -(defun compose-mail (&optional to subject other-headers continue - switch-function yank-action send-actions) - "Start composing a mail message to send. -This uses the user's chosen mail composition package -as selected with the variable `mail-user-agent'. -The optional arguments TO and SUBJECT specify recipients -and the initial Subject field, respectively. - -OTHER-HEADERS is an alist specifying additional -header fields. Elements look like (HEADER . VALUE) where both -HEADER and VALUE are strings. - -CONTINUE, if non-nil, says to continue editing a message already -being composed. - -SWITCH-FUNCTION, if non-nil, is a function to use to -switch to and display the buffer used for mail composition. - -YANK-ACTION, if non-nil, is an action to perform, if and when necessary, -to insert the raw text of the message being replied to. -It has the form (FUNCTION . ARGS). The user agent will apply -FUNCTION to ARGS, to insert the raw text of the original message. -\(The user agent will also run `mail-citation-hook', *after* the -original text has been inserted in this way.) - -SEND-ACTIONS is a list of actions to call when the message is sent. -Each action has the form (FUNCTION . ARGS)." - (interactive - (list nil nil nil current-prefix-arg)) - (let ((function (get mail-user-agent 'composefunc))) - (funcall function to subject other-headers continue - switch-function yank-action send-actions))) - -(defun compose-mail-other-window (&optional to subject other-headers continue - yank-action send-actions) - "Like \\[compose-mail], but edit the outgoing message in another window." - (interactive - (list nil nil nil current-prefix-arg)) - (compose-mail to subject other-headers continue - 'switch-to-buffer-other-window yank-action send-actions)) - - -(defun compose-mail-other-frame (&optional to subject other-headers continue - yank-action send-actions) - "Like \\[compose-mail], but edit the outgoing message in another frame." - (interactive - (list nil nil nil current-prefix-arg)) - (compose-mail to subject other-headers continue - 'switch-to-buffer-other-frame yank-action send-actions)) - - -(defun set-variable (var val) - "Set VARIABLE to VALUE. VALUE is a Lisp object. -When using this interactively, supply a Lisp expression for VALUE. -If you want VALUE to be a string, you must surround it with doublequotes. - -If VARIABLE has a `variable-interactive' property, that is used as if -it were the arg to `interactive' (which see) to interactively read the value." - (interactive - (let* ((var (read-variable "Set variable: ")) - ;; #### - yucky code replication here. This should use something - ;; from help.el or hyper-apropos.el - (minibuffer-help-form - '(funcall myhelp)) - (myhelp - #'(lambda () - (with-output-to-temp-buffer "*Help*" - (prin1 var) - (princ "\nDocumentation:\n") - (princ (substring (documentation-property var 'variable-documentation) - 1)) - (if (boundp var) - (let ((print-length 20)) - (princ "\n\nCurrent value: ") - (prin1 (symbol-value var)))) - (save-excursion - (set-buffer standard-output) - (help-mode)) - nil)))) - (list var - (let ((prop (get var 'variable-interactive))) - (if prop - ;; Use VAR's `variable-interactive' property - ;; as an interactive spec for prompting. - (call-interactively (list 'lambda '(arg) - (list 'interactive prop) - 'arg)) - (eval-minibuffer (format "Set %s to value: " var))))))) - (set var val)) - -;; XEmacs -(defun activate-region () - "Activate the region, if `zmacs-regions' is true. -Setting `zmacs-regions' to true causes LISPM-style active regions to be used. -This function has no effect if `zmacs-regions' is false." - (interactive) - (and zmacs-regions (zmacs-activate-region))) - -;; XEmacs -(defsubst region-exists-p () - "Non-nil iff the region exists. -If active regions are in use (i.e. `zmacs-regions' is true), this means that - the region is active. Otherwise, this means that the user has pushed - a mark in this buffer at some point in the past. -The functions `region-beginning' and `region-end' can be used to find the - limits of the region." - (not (null (mark)))) - -;; XEmacs -(defun region-active-p () - "Non-nil iff the region is active. -If `zmacs-regions' is true, this is equivalent to `region-exists-p'. -Otherwise, this function always returns false." - (and zmacs-regions zmacs-region-extent)) - -;; A bunch of stuff was moved elsewhere: -;; completion-list-mode-map -;; completion-reference-buffer -;; completion-base-size -;; delete-completion-window -;; previous-completion -;; next-completion -;; choose-completion -;; choose-completion-delete-max-match -;; choose-completion-string -;; completion-list-mode -;; completion-fixup-function -;; completion-setup-function -;; switch-to-completions -;; event stuffs -;; keypad stuffs - -;; The rest of this file is not in Lisp in FSF -(defun capitalize-region-or-word (arg) - "Capitalize the selected region or the following word (or ARG words)." - (interactive "p") - (if (region-active-p) - (capitalize-region (region-beginning) (region-end)) - (capitalize-word arg))) - -(defun upcase-region-or-word (arg) - "Upcase the selected region or the following word (or ARG words)." - (interactive "p") - (if (region-active-p) - (upcase-region (region-beginning) (region-end)) - (upcase-word arg))) - -(defun downcase-region-or-word (arg) - "Downcase the selected region or the following word (or ARG words)." - (interactive "p") - (if (region-active-p) - (downcase-region (region-beginning) (region-end)) - (downcase-word arg))) - -;;; -;;; Most of the zmacs code is now in elisp. The only thing left in C -;;; are the variables zmacs-regions, zmacs-region-active-p and -;;; zmacs-region-stays plus the function zmacs_update_region which -;;; calls the lisp level zmacs-update-region. It must remain since it -;;; must be called by core C code. -;;; -;;; Huh? Why couldn't "core C code" just use -;;; call0(Qzmacs_update_region)??? -hniksic - -(defvar zmacs-activate-region-hook nil - "Function or functions called when the region becomes active; -see the variable `zmacs-regions'.") - -(defvar zmacs-deactivate-region-hook nil - "Function or functions called when the region becomes inactive; -see the variable `zmacs-regions'.") - -(defvar zmacs-update-region-hook nil - "Function or functions called when the active region changes. -This is called after each command that sets `zmacs-region-stays' to t. -See the variable `zmacs-regions'.") - -(defvar zmacs-region-extent nil - "The extent of the zmacs region; don't use this.") - -(defvar zmacs-region-rectangular-p nil - "Whether the zmacs region is a rectangle; don't use this.") - -(defun zmacs-make-extent-for-region (region) - ;; Given a region, this makes an extent in the buffer which holds that - ;; region, for highlighting purposes. If the region isn't associated - ;; with a buffer, this does nothing. - (let ((buffer nil) - (valid (and (extentp zmacs-region-extent) - (extent-object zmacs-region-extent) - (buffer-live-p (extent-object zmacs-region-extent)))) - start end) - (cond ((consp region) - (setq start (min (car region) (cdr region)) - end (max (car region) (cdr region)) - valid (and valid - (eq (marker-buffer (car region)) - (extent-object zmacs-region-extent))) - buffer (marker-buffer (car region)))) - (t - (signal 'error (list "Invalid region" region)))) - - (if valid - nil - ;; The condition case is in case any of the extents are dead or - ;; otherwise incapacitated. - (condition-case () - (if (listp zmacs-region-extent) - (mapc 'delete-extent zmacs-region-extent) - (delete-extent zmacs-region-extent)) - (error nil))) - - (if valid - (set-extent-endpoints zmacs-region-extent start end) - (setq zmacs-region-extent (make-extent start end buffer)) - - ;; Make the extent be closed on the right, which means that if - ;; characters are inserted exactly at the end of the extent, the - ;; extent will grow to cover them. This is important for shell - ;; buffers - suppose one makes a region, and one end is at point-max. - ;; If the shell produces output, that marker will remain at point-max - ;; (its position will increase). So it's important that the extent - ;; exhibit the same behavior, lest the region covered by the extent - ;; (the visual indication), and the region between point and mark - ;; (the actual region value) become different! - (set-extent-property zmacs-region-extent 'end-open nil) - - ;; use same priority as mouse-highlighting so that conflicts between - ;; the region extent and a mouse-highlighted extent are resolved by - ;; the usual size-and-endpoint-comparison method. - (set-extent-priority zmacs-region-extent mouse-highlight-priority) - (set-extent-face zmacs-region-extent 'zmacs-region) - - ;; #### It might be better to actually break - ;; default-mouse-track-next-move-rect out of mouse.el so that we - ;; can use its logic here. - (cond - (zmacs-region-rectangular-p - (setq zmacs-region-extent (list zmacs-region-extent)) - (default-mouse-track-next-move-rect start end zmacs-region-extent) - )) - - zmacs-region-extent))) - -(defun zmacs-region-buffer () - "Return the buffer containing the zmacs region, or nil." - ;; #### this is horrible and kludgy! This stuff needs to be rethought. - (and zmacs-regions zmacs-region-active-p - (or (marker-buffer (mark-marker t)) - (and (extent-live-p zmacs-region-extent) - (buffer-live-p (extent-object zmacs-region-extent)) - (extent-object zmacs-region-extent))))) - -(defun zmacs-activate-region () - "Make the region between `point' and `mark' be active (highlighted), -if `zmacs-regions' is true. Only a very small number of commands -should ever do this. Calling this function will call the hook -`zmacs-activate-region-hook', if the region was previously inactive. -Calling this function ensures that the region stays active after the -current command terminates, even if `zmacs-region-stays' is not set. -Returns t if the region was activated (i.e. if `zmacs-regions' if t)." - (if (not zmacs-regions) - nil - (setq zmacs-region-active-p t - zmacs-region-stays t - zmacs-region-rectangular-p (and (boundp 'mouse-track-rectangle-p) - mouse-track-rectangle-p)) - (if (marker-buffer (mark-marker t)) - (zmacs-make-extent-for-region (cons (point-marker t) (mark-marker t)))) - (run-hooks 'zmacs-activate-region-hook) - t)) - -(defun zmacs-deactivate-region () - "Make the region between `point' and `mark' no longer be active, -if `zmacs-regions' is true. You shouldn't need to call this; the -command loop calls it when appropriate. Calling this function will -call the hook `zmacs-deactivate-region-hook', if the region was -previously active. Returns t if the region had been active, nil -otherwise." - (if (not zmacs-region-active-p) - nil - (setq zmacs-region-active-p nil - zmacs-region-stays nil - zmacs-region-rectangular-p nil) - (if zmacs-region-extent - (let ((inhibit-quit t)) - (if (listp zmacs-region-extent) - (mapc 'delete-extent zmacs-region-extent) - (delete-extent zmacs-region-extent)) - (setq zmacs-region-extent nil))) - (run-hooks 'zmacs-deactivate-region-hook) - t)) - -(defun zmacs-update-region () - "Update the highlighted region between `point' and `mark'. -You shouldn't need to call this; the command loop calls it -when appropriate. Calling this function will call the hook -`zmacs-update-region-hook', if the region is active." - (when zmacs-region-active-p - (when (marker-buffer (mark-marker t)) - (zmacs-make-extent-for-region (cons (point-marker t) - (mark-marker t)))) - (run-hooks 'zmacs-update-region-hook))) - -;;;;;; -;;;;;; echo area stuff -;;;;;; - -;;; #### Should this be moved to a separate file, for clarity? -;;; -hniksic - -;;; The `message-stack' is an alist of labels with messages; the first -;;; message in this list is always in the echo area. A call to -;;; `display-message' inserts a label/message pair at the head of the -;;; list, and removes any other pairs with that label. Calling -;;; `clear-message' causes any pair with matching label to be removed, -;;; and this may cause the displayed message to change or vanish. If -;;; the label arg is nil, the entire message stack is cleared. -;;; -;;; Message/error filtering will be a little tricker to implement than -;;; logging, since messages can be built up incrementally -;;; using clear-message followed by repeated calls to append-message -;;; (this happens with error messages). For messages which aren't -;;; created this way, filtering could be implemented at display-message -;;; very easily. -;;; -;;; Bits of the logging code are borrowed from log-messages.el by -;;; Robert Potter (rpotter@grip.cis.upenn.edu). - -;; need this to terminate the currently-displayed message -;; ("Loading simple ...") -(when (and - (not (fboundp 'display-message)) - (not (featurep 'debug))) - (send-string-to-terminal "\n")) - -(defvar message-stack nil - "An alist of label/string pairs representing active echo-area messages. -The first element in the list is currently displayed in the echo area. -Do not modify this directly--use the `message' or -`display-message'/`clear-message' functions.") - -(defvar remove-message-hook 'log-message - "A function or list of functions to be called when a message is removed -from the echo area at the bottom of the frame. The label of the removed -message is passed as the first argument, and the text of the message -as the second argument.") - -(defcustom log-message-max-size 50000 - "Maximum size of the \" *Message-Log*\" buffer. See `log-message'." - :type 'integer - :group 'log-message) -(make-compatible-variable 'message-log-max 'log-message-max-size) - -;; We used to reject quite a lot of stuff here, but it was a bad idea, -;; for two reasons: -;; -;; a) In most circumstances, you *want* to see the message in the log. -;; The explicitly non-loggable messages should be marked as such by -;; the issuer. Gratuitous non-displaying of random regexps made -;; debugging harder, too (because various reasonable debugging -;; messages would get eaten). -;; -;; b) It slowed things down. Yes, visibly. -;; -;; So, I left only a few of the really useless ones on this kill-list. -;; -;; --hniksic -(defcustom log-message-ignore-regexps - '(;; Note: adding entries to this list slows down messaging - ;; significantly. Wherever possible, use message lables. - - ;; Often-seen messages - "\\`\\'" ; empty message - "\\`\\(Beginning\\|End\\) of buffer\\'" - ;;"^Quit$" - ;; completions - ;; Many packages print this -- impossible to categorize - ;;"^Making completion list" - ;; Gnus - ;; "^No news is no news$" - ;; "^No more\\( unread\\)? newsgroups$" - ;; "^Opening [^ ]+ server\\.\\.\\." - ;; "^[^:]+: Reading incoming mail" - ;; "^Getting mail from " - ;; "^\\(Generating Summary\\|Sorting threads\\|Making sparse threads\\|Scoring\\|Checking new news\\|Expiring articles\\|Sending\\)\\.\\.\\." - ;; "^\\(Fetching headers for\\|Retrieving newsgroup\\|Reading active file\\)" - ;; "^No more\\( unread\\)? articles" - ;; "^Deleting article " - ;; W3 - ;; "^Parsed [0-9]+ of [0-9]+ ([0-9]+%)" - ) - "List of regular expressions matching messages which shouldn't be logged. -See `log-message'. - -Ideally, packages which generate messages which might need to be ignored -should label them with 'progress, 'prompt, or 'no-log, so they can be -filtered by the log-message-ignore-labels." - :type '(repeat regexp) - :group 'log-message) - -(defcustom log-message-ignore-labels - '(help-echo command progress prompt no-log garbage-collecting auto-saving) - "List of symbols indicating labels of messages which shouldn't be logged. -See `display-message' for some common labels. See also `log-message'." - :type '(repeat (symbol :tag "Label")) - :group 'log-message) - -;;Subsumed by view-lossage -;; Not really, I'm adding it back by popular demand. -slb -(defun show-message-log () - "Show the \" *Message-Log*\" buffer, which contains old messages and errors." - (interactive) - (pop-to-buffer " *Message-Log*")) - -(defvar log-message-filter-function 'log-message-filter - "Value must be a function of two arguments: a symbol (label) and -a string (message). It should return non-nil to indicate a message -should be logged. Possible values include 'log-message-filter and -'log-message-filter-errors-only.") - -(defun log-message-filter (label message) - "Default value of log-message-filter-function. -Mesages whose text matches one of the log-message-ignore-regexps -or whose label appears in log-message-ignore-labels are not saved." - (let ((r log-message-ignore-regexps) - (ok (not (memq label log-message-ignore-labels)))) - (while (and r ok) - (if (save-match-data (string-match (car r) message)) - (setq ok nil)) - (setq r (cdr r))) - ok)) - -(defun log-message-filter-errors-only (label message) - "For use as the log-message-filter-function. Only logs error messages." - (eq label 'error)) - -(defun log-message (label message) - "Stuff a copy of the message into the \" *Message-Log*\" buffer, -if it satisfies the log-message-filter-function. - -For use on remove-message-hook." - (if (and (not noninteractive) - (funcall log-message-filter-function label message)) - (save-excursion - (set-buffer (get-buffer-create " *Message-Log*")) - (goto-char (point-max)) - ;; (insert (concat (upcase (symbol-name label)) ": " message "\n")) - (insert message "\n") - (if (> (point-max) (max log-message-max-size (point-min))) - (progn - ;; trim log to ~90% of max size - (goto-char (max (- (point-max) - (truncate (* 0.9 log-message-max-size))) - (point-min))) - (forward-line 1) - (delete-region (point-min) (point))))))) - -(defun message-displayed-p (&optional return-string frame) - "Return a non-nil value if a message is presently displayed in the\n\ -minibuffer's echo area. If optional argument RETURN-STRING is non-nil,\n\ -return a string containing the message, otherwise just return t." - ;; by definition, a message is displayed if the echo area buffer is - ;; non-empty (see also echo_area_active()). It had better also - ;; be the case that message-stack is nil exactly when the echo area - ;; is non-empty. - (let ((buffer (get-buffer " *Echo Area*"))) - (and (< (point-min buffer) (point-max buffer)) - (if return-string - (buffer-substring nil nil buffer) - t)))) - -;;; Returns the string which remains in the echo area, or nil if none. -;;; If label is nil, the whole message stack is cleared. -(defun clear-message (&optional label frame stdout-p no-restore) - "Remove any message with the given LABEL from the message-stack, -erasing it from the echo area if it's currently displayed there. -If a message remains at the head of the message-stack and NO-RESTORE -is nil, it will be displayed. The string which remains in the echo -area will be returned, or nil if the message-stack is now empty. -If LABEL is nil, the entire message-stack is cleared. - -Unless you need the return value or you need to specify a label, -you should just use (message nil)." - (or frame (setq frame (selected-frame))) - (let ((clear-stream (and message-stack (eq 'stream (frame-type frame))))) - (remove-message label frame) - (let ((buffer (get-buffer " *Echo Area*")) - (inhibit-read-only t) - (zmacs-region-stays zmacs-region-stays)) ; preserve from change - (erase-buffer buffer)) - (if clear-stream - (send-string-to-terminal ?\n stdout-p)) - (if no-restore - nil ; just preparing to put another msg up - (if message-stack - (let ((oldmsg (cdr (car message-stack)))) - (raw-append-message oldmsg frame stdout-p) - oldmsg) - ;; ### should we (redisplay-echo-area) here? messes some things up. - nil)))) - -(defun remove-message (&optional label frame) - ;; If label is nil, we want to remove all matching messages. - ;; Must reverse the stack first to log them in the right order. - (let ((log nil)) - (while (and message-stack - (or (null label) ; null label means clear whole stack - (eq label (car (car message-stack))))) - (setq log (cons (car message-stack) log)) - (setq message-stack (cdr message-stack))) - (let ((s message-stack)) - (while (cdr s) - (let ((msg (car (cdr s)))) - (if (eq label (car msg)) - (progn - (setq log (cons msg log)) - (setcdr s (cdr (cdr s)))) - (setq s (cdr s)))))) - ;; (possibly) log each removed message - (while log - (condition-case e - (run-hook-with-args 'remove-message-hook - (car (car log)) (cdr (car log))) - (error (setq remove-message-hook nil) - (message "remove-message-hook error: %s" e) - (sit-for 2) - (let ((inhibit-read-only t)) - (erase-buffer (get-buffer " *Echo Area*"))) - (signal (car e) (cdr e)))) - (setq log (cdr log))))) - -(defun append-message (label message &optional frame stdout-p) - (or frame (setq frame (selected-frame))) - ;; add a new entry to the message-stack, or modify an existing one - (let ((top (car message-stack))) - (if (eq label (car top)) - (setcdr top (concat (cdr top) message)) - (setq message-stack (cons (cons label message) message-stack)))) - (raw-append-message message frame stdout-p)) - -;; really append the message to the echo area. no fiddling with message-stack. -(defun raw-append-message (message &optional frame stdout-p) - (if (eq message "") nil - (let ((buffer (get-buffer " *Echo Area*")) - (zmacs-region-stays zmacs-region-stays)) ; preserve from change - (save-excursion - (set-buffer buffer) - (let ((inhibit-read-only t)) - (insert message))) - ;; Conditionalizing on the device type in this way is not that clean, - ;; but neither is having a device method, as I originally implemented - ;; it: all non-stream devices behave in the same way. Perhaps - ;; the cleanest way is to make the concept of a "redisplayable" - ;; device, which stream devices are not. Look into this more if - ;; we ever create another non-redisplayable device type (e.g. - ;; processes? printers?). - - ;; Don't redisplay the echo area if we are executing a macro. - (if (not executing-kbd-macro) - (if (eq 'stream (frame-type frame)) - (send-string-to-terminal message stdout-p) - (redisplay-echo-area)))))) - -(defun display-message (label message &optional frame stdout-p) - "Print a one-line message at the bottom of the frame. First argument -LABEL is an identifier for this message. MESSAGE is the string to display. -Use `clear-message' to remove a labelled message. - -Here are some standard labels (those marked with `*' are not logged -by default--see the `log-message-ignore-labels' variable): - message default label used by the `message' function - error default label used for reporting errors - * progress progress indicators like \"Converting... 45%\" - * prompt prompt-like messages like \"I-search: foo\" - * no-log messages that should never be logged" - (clear-message label frame stdout-p t) - (append-message label message frame stdout-p)) - -(defun current-message (&optional frame) - "Returns the current message in the echo area, or nil. -The FRAME argument is currently unused." - (cdr (car message-stack))) - -;;; may eventually be frame-dependent -(defun current-message-label (&optional frame) - (car (car message-stack))) - -(defun message (fmt &rest args) - "Print a one-line message at the bottom of the frame. -The arguments are the same as to `format'. - -If the only argument is nil, clear any existing message; let the -minibuffer contents show." - ;; questionable junk in the C code - ;; (if (framep default-minibuffer-frame) - ;; (make-frame-visible default-minibuffer-frame)) - (if (and (null fmt) (null args)) - (progn - (clear-message nil) - nil) - (let ((str (apply 'format fmt args))) - (display-message 'message str) - str))) - -;;;;;; -;;;;;; warning stuff -;;;;;; - -(defcustom log-warning-minimum-level 'info - "Minimum level of warnings that should be logged. -The warnings in levels below this are completely ignored, as if they never -happened. - -The recognized warning levels, in decreasing order of priority, are -'emergency, 'alert, 'critical, 'error, 'warning, 'notice, 'info, and -'debug. - -See also `display-warning-minimum-level'. - -You can also control which warnings are displayed on a class-by-class -basis. See `display-warning-suppressed-classes' and -`log-warning-suppressed-classes'." - :type '(choice (const emergency) (const alert) (const critical) - (const error) (const warning) (const notice) - (const info) (const debug)) - :group 'warnings) - -(defcustom display-warning-minimum-level 'info - "Minimum level of warnings that should be displayed. -The warnings in levels below this are completely ignored, as if they never -happened. - -The recognized warning levels, in decreasing order of priority, are -'emergency, 'alert, 'critical, 'error, 'warning, 'notice, 'info, and -'debug. - -See also `log-warning-minimum-level'. - -You can also control which warnings are displayed on a class-by-class -basis. See `display-warning-suppressed-classes' and -`log-warning-suppressed-classes'." - :type '(choice (const emergency) (const alert) (const critical) - (const error) (const warning) (const notice) - (const info) (const debug)) - :group 'warnings) - -(defvar log-warning-suppressed-classes nil - "List of classes of warnings that shouldn't be logged or displayed. -If any of the CLASS symbols associated with a warning is the same as -any of the symbols listed here, the warning will be completely ignored, -as it they never happened. - -NOTE: In most circumstances, you should *not* set this variable. -Set `display-warning-suppressed-classes' instead. That way the suppressed -warnings are not displayed but are still unobtrusively logged. - -See also `log-warning-minimum-level' and `display-warning-minimum-level'.") - -(defcustom display-warning-suppressed-classes nil - "List of classes of warnings that shouldn't be displayed. -If any of the CLASS symbols associated with a warning is the same as -any of the symbols listed here, the warning will not be displayed. -The warning will still logged in the *Warnings* buffer (unless also -contained in `log-warning-suppressed-classes'), but the buffer will -not be automatically popped up. - -See also `log-warning-minimum-level' and `display-warning-minimum-level'." - :type '(repeat symbol) - :group 'warnings) - -(defvar warning-count 0 - "Count of the number of warning messages displayed so far.") - -(defconst warning-level-alist '((emergency . 8) - (alert . 7) - (critical . 6) - (error . 5) - (warning . 4) - (notice . 3) - (info . 2) - (debug . 1))) - -(defun warning-level-p (level) - "Non-nil if LEVEL specifies a warning level." - (and (symbolp level) (assq level warning-level-alist))) - -;; If you're interested in rewriting this function, be aware that it -;; could be called at arbitrary points in a Lisp program (when a -;; built-in function wants to issue a warning, it will call out to -;; this function the next time some Lisp code is evaluated). Therefore, -;; this function *must* not permanently modify any global variables -;; (e.g. the current buffer) except those that specifically apply -;; to the warning system. - -(defvar before-init-deferred-warnings nil) - -(defun after-init-display-warnings () - "Display warnings deferred till after the init file is run. -Warnings that occur before then are deferred so that warning -suppression in the .emacs file will be honored." - (while before-init-deferred-warnings - (apply 'display-warning (car before-init-deferred-warnings)) - (setq before-init-deferred-warnings - (cdr before-init-deferred-warnings)))) - -#-infodock (add-hook 'after-init-hook 'after-init-display-warnings) - -(defun display-warning (class message &optional level) - "Display a warning message. -CLASS should be a symbol describing what sort of warning this is, such -as `resource' or `key-mapping'. A list of such symbols is also -accepted. (Individual classes can be suppressed; see -`display-warning-suppressed-classes'.) Optional argument LEVEL can -be used to specify a priority for the warning, other than default priority -`warning'. (See `display-warning-minimum-level'). The message is -inserted into the *Warnings* buffer, which is made visible at appropriate -times." - (or level (setq level 'warning)) - (or (listp class) (setq class (list class))) - (check-argument-type 'warning-level-p level) - (if (and (not (featurep 'infodock)) - (not init-file-loaded)) - (setq before-init-deferred-warnings - (cons (list class message level) before-init-deferred-warnings)) - (catch 'ignored - (let ((display-p t) - (level-num (cdr (assq level warning-level-alist)))) - (if (< level-num (cdr (assq log-warning-minimum-level - warning-level-alist))) - (throw 'ignored nil)) - (if (intersection class log-warning-suppressed-classes) - (throw 'ignored nil)) - - (if (< level-num (cdr (assq display-warning-minimum-level - warning-level-alist))) - (setq display-p nil)) - (if (and display-p - (intersection class display-warning-suppressed-classes)) - (setq display-p nil)) - (save-excursion - (let ((buffer (get-buffer-create "*Warnings*"))) - (when display-p - ;; The C code looks at display-warning-tick to determine - ;; when it should call `display-warning-buffer'. Change it - ;; to get the C code's attention. - (incf display-warning-tick)) - (set-buffer buffer) - (goto-char (point-max)) - (setq warning-count (1+ warning-count)) - (princ (format "(%d) (%s/%s) " - warning-count - (mapconcat 'symbol-name class ",") - level) buffer) - (princ message buffer) - (terpri buffer) - (terpri buffer))))))) - -(defun warn (&rest args) - "Display a warning message. -The message is constructed by passing all args to `format'. The message -is placed in the *Warnings* buffer, which will be popped up at the next -redisplay. The class of the warning is `warning'. See also -`display-warning'." - (display-warning 'warning (apply 'format args))) - -(defvar warning-marker nil) - -;; When this function is called by the C code, all non-local exits are -;; trapped and C-g is inhibited; therefore, it would be a very, very -;; bad idea for this function to get into an infinite loop. - -(defun display-warning-buffer () - "Make the buffer that contains the warnings be visible. -The C code calls this periodically, right before redisplay." - (let ((buffer (get-buffer-create "*Warnings*"))) - (when (or (not warning-marker) - (not (eq (marker-buffer warning-marker) buffer))) - (setq warning-marker (make-marker)) - (set-marker warning-marker 1 buffer)) - (set-window-start (display-buffer buffer) warning-marker) - (set-marker warning-marker (point-max buffer) buffer))) - -(defun emacs-name () - "Return the printable name of this instance of Emacs." - (cond ((featurep 'infodock) "InfoDock") - ((featurep 'xemacs) "XEmacs") - (t "Emacs"))) - -;;; simple.el ends here
--- a/lisp/prim/sound.el Mon Aug 13 10:03:54 2007 +0200 +++ b/lisp/prim/sound.el Mon Aug 13 10:04:58 2007 +0200 @@ -92,7 +92,8 @@ :type '(repeat (sexp :tag "Sound") )) -(defcustom default-sound-directory (concat data-directory "sounds/") +(defcustom default-sound-directory (file-name-as-directory + (concat data-directory "sounds")) "Default directory to load a sound file from." :group 'sound :type 'directory
--- a/lisp/prim/specifier.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,401 +0,0 @@ -;;; specifier.el --- Lisp interface to specifiers - -;; Copyright (C) 1995, 1996 Ben Wing. - -;; Author: Ben Wing <wing@666.com> -;; Keywords: internal - -;; first appeared in 19.12. - -;; 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, 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: Not in FSF. - -(defun make-specifier-and-init (type spec-list &optional dont-canonicalize) - "Create and initialize a new specifier. - -This is a front-end onto `make-specifier' that allows you to create a -specifier and add specs to it at the same time. TYPE specifies the -specifier type. SPEC-LIST supplies the specification(s) to be added -to the specifier. Normally, almost any reasonable abbreviation of the -full spec-list form is accepted, and is converted to the full form; -however, if optional argument DONT-CANONICALIZE is non-nil, this -conversion is not performed, and the SPEC-LIST must already be in full -form. See `canonicalize-spec-list'." - (let ((sp (make-specifier type))) - (if (not dont-canonicalize) - (setq spec-list (canonicalize-spec-list spec-list type))) - (add-spec-list-to-specifier sp spec-list) - sp)) - -;; God damn, do I hate dynamic scoping. - -(defun map-specifier (ms-specifier ms-func &optional ms-locale ms-maparg) - "Apply MS-FUNC to the specification(s) for MS-LOCALE in MS-SPECIFIER. - -If MS-LOCALE is a locale, MS-FUNC will be called for that locale. -If MS-LOCALE is a locale type, MS-FUNC will be mapped over all locales -of that type. If MS-LOCALE is 'all or nil, MS-FUNC will be mapped -over all locales in MS-SPECIFIER. - -MS-FUNC is called with four arguments: the MS-SPECIFIER, the locale -being mapped over, the inst-list for that locale, and the -optional MS-MAPARG. If any invocation of MS-FUNC returns non-nil, -the mapping will stop and the returned value becomes the -value returned from `map-specifier'. Otherwise, `map-specifier' -returns nil." - (let ((ms-specs (specifier-spec-list ms-specifier ms-locale)) - ms-result) - (while (and ms-specs (not ms-result)) - (let ((ms-this-spec (car ms-specs))) - (setq ms-result (funcall ms-func ms-specifier (car ms-this-spec) - (cdr ms-this-spec) ms-maparg)) - (setq ms-specs (cdr ms-specs)))) - ms-result)) - -(defun canonicalize-inst-pair (inst-pair specifier-type &optional noerror) - "Canonicalize the given INST-PAIR. - -SPECIFIER-TYPE specifies the type of specifier that this SPEC-LIST -will be used for. - -Canonicalizing means converting to the full form for an inst-pair, i.e. -`(TAG-SET . INSTANTIATOR)'. A single, untagged instantiator is given -a tag set of nil (the empty set), and a single tag is converted into -a tag set consisting only of that tag. - -If NOERROR is non-nil, signal an error if the inst-pair is invalid; -otherwise return t." - ;; OK, the possibilities are: - ;; - ;; a) a single instantiator - ;; b) a cons of a tag and an instantiator - ;; c) a cons of a tag set and an instantiator - (cond ((valid-instantiator-p inst-pair specifier-type) - ;; case (a) - (cons nil inst-pair)) - - ((not (consp inst-pair)) - ;; not an inst-pair - (if noerror t - ;; this will signal an appropriate error. - (check-valid-instantiator inst-pair specifier-type))) - - ((and (valid-specifier-tag-p (car inst-pair)) - (valid-instantiator-p (cdr inst-pair) specifier-type)) - ;; case (b) - (cons (list (car inst-pair)) (cdr inst-pair))) - - ((and (valid-specifier-tag-set-p (car inst-pair)) - (valid-instantiator-p (cdr inst-pair) specifier-type)) - ;; case (c) - inst-pair) - - (t - (if noerror t - (signal 'error (list "Invalid specifier tag set" - (car inst-pair))))))) - -(defun canonicalize-inst-list (inst-list specifier-type &optional noerror) - "Canonicalize the given INST-LIST (a list of inst-pairs). - -SPECIFIER-TYPE specifies the type of specifier that this INST-LIST -will be used for. - -Canonicalizing means converting to the full form for an inst-list, i.e. -`((TAG-SET . INSTANTIATOR) ...)'. This function accepts a single -inst-pair or any abbreviation thereof or a list of (possibly -abbreviated) inst-pairs. (See `canonicalize-inst-pair'.) - -If NOERROR is non-nil, signal an error if the inst-list is invalid; -otherwise return t." - - ;; OK, the possibilities are: - ;; - ;; a) an inst-pair or various abbreviations thereof - ;; b) a list of (a) - (let ((result (canonicalize-inst-pair inst-list specifier-type t))) - (if (not (eq result t)) - ;; case (a) - (list result) - - (if (not (consp inst-list)) - ;; not an inst-list. - (if noerror t - ;; this will signal an appropriate error. - (check-valid-instantiator inst-list specifier-type)) - - ;; case (b) - (catch 'cann-inst-list - ;; don't use mapcar here; we need to catch the case of - ;; an invalid list. - (let ((rest inst-list) - (result nil)) - (while rest - (if (not (consp rest)) - (if noerror (throw 'cann-inst-list t) - (signal 'error (list "Invalid list format" inst-list))) - (let ((res2 (canonicalize-inst-pair (car rest) specifier-type - noerror))) - (if (eq res2 t) - ;; at this point, we know we're noerror because - ;; otherwise canonicalize-inst-pair would have - ;; signalled an error. - (throw 'cann-inst-list t) - (setq result (cons res2 result))))) - (setq rest (cdr rest))) - (nreverse result))))))) - -(defun canonicalize-spec (spec specifier-type &optional noerror) - "Canonicalize the given SPEC (a specification). - -SPECIFIER-TYPE specifies the type of specifier that this SPEC-LIST -will be used for. - -Canonicalizing means converting to the full form for a spec, i.e. -`(LOCALE (TAG-SET . INSTANTIATOR) ...)'. This function accepts a -possibly abbreviated inst-list or a cons of a locale and a possibly -abbreviated inst-list. (See `canonicalize-inst-list'.) - -If NOERROR is nil, signal an error if the specification is invalid; -otherwise return t." - ;; OK, the possibilities are: - ;; - ;; a) an inst-list or some abbreviation thereof - ;; b) a cons of a locale and an inst-list - (let ((result (canonicalize-inst-list spec specifier-type t))) - (if (not (eq result t)) - ;; case (a) - (cons 'global result) - - (if (not (consp spec)) - ;; not a spec. - (if noerror t - ;; this will signal an appropriate error. - (check-valid-instantiator spec specifier-type)) - - (if (not (valid-specifier-locale-p (car spec))) - ;; invalid locale. - (if noerror t - (signal 'error (list "Invalid specifier locale" (car spec)))) - - ;; case (b) - (let ((result (canonicalize-inst-list (cdr spec) specifier-type - noerror))) - (if (eq result t) - ;; at this point, we know we're noerror because - ;; otherwise canonicalize-inst-list would have - ;; signalled an error. - t - (cons (car spec) result)))))))) - -(defun canonicalize-spec-list (spec-list specifier-type &optional noerror) - "Canonicalize the given SPEC-LIST (a list of specifications). - -SPECIFIER-TYPE specifies the type of specifier that this SPEC-LIST -will be used for. - -Canonicalizing means converting to the full form for a spec-list, i.e. -`((LOCALE (TAG-SET . INSTANTIATOR) ...) ...)'. This function accepts -a possibly abbreviated specification or a list of such things. (See -`canonicalize-spec'.) This is the function used to convert spec-lists -accepted by `set-specifier' and such into a form suitable for -`add-spec-list-to-specifier'. - -This function tries extremely hard to resolve any ambiguities, -and the built-in specifier types (font, image, toolbar, etc.) are -designed so that there won't be any ambiguities. - -If NOERROR is nil, signal an error if the spec-list is invalid; -otherwise return t." - ;; OK, the possibilities are: - ;; - ;; a) a spec or various abbreviations thereof - ;; b) a list of (a) - (let ((result (canonicalize-spec spec-list specifier-type t))) - (if (not (eq result t)) - ;; case (a) - (list result) - - (if (not (consp spec-list)) - ;; not a spec-list. - (if noerror t - ;; this will signal an appropriate error. - (check-valid-instantiator spec-list specifier-type)) - - ;; case (b) - (catch 'cann-spec-list - ;; don't use mapcar here; we need to catch the case of - ;; an invalid list. - (let ((rest spec-list) - (result nil)) - (while rest - (if (not (consp rest)) - (if noerror (throw 'cann-spec-list t) - (signal 'error (list "Invalid list format" spec-list))) - (let ((res2 (canonicalize-spec (car rest) specifier-type - noerror))) - (if (eq res2 t) - ;; at this point, we know we're noerror because - ;; otherwise canonicalize-spec would have - ;; signalled an error. - (throw 'cann-spec-list t) - (setq result (cons res2 result))))) - (setq rest (cdr rest))) - (nreverse result))))))) - -(defun set-specifier (specifier value &optional locale tag-set how-to-add) - "Add a specification or specifications to SPECIFIER. - -This function adds a specification of VALUE in locale LOCALE. -LOCALE indicates where this specification is active, and should be -a buffer, a window, a frame, a device, or the symbol `global' to -indicate that it applies everywhere. LOCALE usually defaults to -`global' if omitted. - -VALUE is usually what is called an \"instantiator\" (which, roughly -speaking, corresponds to the \"value\" of the property governed by -SPECIFIER). The valid instantiators for SPECIFIER depend on the -type of SPECIFIER (which you can determine using `specifier-type'). -The specifier `scrollbar-width', for example, is of type `integer', -meaning its valid instantiators are integers. The specifier -governing the background color of the `default' face (you can -retrieve this specifier using `(face-background 'default)') is -of type `color', meaning its valid instantiators are strings naming -colors and color-instance objects. For some types of specifiers, -such as `image' and `toolbar', the instantiators can be very -complex. Generally this is documented in the appropriate predicate -function -- `color-specifier-p', `image-specifier-p', -`toolbar-specifier-p', etc. - -NOTE: It does *not* work to give a VALUE of nil as a way of -removing the specifications for a locale. Use `remove-specifier' -instead. (And keep in mind that, if you omit the LOCALE argument -to `remove-specifier', it removes *all* specifications! If you -want to remove just the `global' specification, make sure to -specify a LOCALE of `global'.) - -VALUE can also be a list of instantiators. This means basically, -\"try each one in turn until you get one that works\". This allows -you to give funky instantiators that may only work in some cases, -and provide more normal backups for the other cases. (For example, -you might like the color \"darkseagreen2\", but some X servers -don't recognize this color, so you could provide a backup -\"forest green\". Color TTY devices probably won't recognize this -either, so you could provide a second backup \"green\". You'd -do this by specifying this list of instantiators: - -'(\"darkseagreen2\" \"forest green\" \"green\") - -VALUE can also be various more complicated forms; see below. - -Optional argument TAG-SET is a tag or a list of tags, to be associated -with the VALUE. Tags are symbols (usually naming device types, such -as `x' and `tty', or device classes, such as `color', `mono', and -`grayscale'); specifying a TAG-SET restricts the scope of VALUE to -devices that match all specified tags. (You can also create your -own tags using `define-specifier-tag', and use them to identify -specifications added by you, so you can remove them later.) - -Optional argument HOW-TO-ADD should be either nil or one of the -symbols `prepend', `append', `remove-tag-set-prepend', -`remove-tag-set-append', `remove-locale', `remove-locale-type', -or `remove-all'. This specifies what to do with existing -specifications in LOCALE (and possibly elsewhere in the specifier). -Most of the time, you do not need to worry about this argument; -the default behavior of `remove-tag-set-prepend' is usually fine. -See `copy-specifier' and `add-spec-to-specifier' for a full -description of what each of these means. - -VALUE can actually be anything acceptable to `canonicalize-spec-list'; -this includes, among other things: - --- a cons of a locale and an instantiator (or list of instantiators) --- a cons of a tag or tag-set and an instantiator (or list of - instantiators) --- a cons of a locale and the previous type of item --- a list of one or more of any of the previous types of items - -However, in these cases, you cannot give a LOCALE or TAG-SET, -because they do not make sense. (You will probably get an error if -you try this.) - -Finally, VALUE can itself be a specifier (of the same type as -SPECIFIER), if you want to copy specifications from one specifier -to another; this is equivalent to calling `copy-specifier', and -LOCALE, TAG-SET, and HOW-TO-ADD have the same semantics as with -that function. - -Note that `set-specifier' is exactly complementary to `specifier-specs' -except in the case where SPECIFIER has no specs at all in it but nil -is a valid instantiator (in that case, `specifier-specs' will return -nil (meaning no specs) and `set-specifier' will interpret the `nil' -as meaning \"I'm adding a global instantiator and its value is `nil'\"), -or in strange cases where there is an ambiguity between a spec-list -and an inst-list, etc. (The built-in specifier types are designed -in such a way as to avoid any such ambiguities.) - -NOTE: If you want to work with spec-lists, you should probably not -use either `set-specifier' or `specifier-specs', but should use the -lower-level functions `add-spec-list-to-specifier' and `specifier-spec-list'. -These functions always work with fully-qualified spec-lists; thus, there -is no possibility for ambiguity and no need to go through the function -`canonicalize-spec-list', which is potentially time-consuming." - - ;; backward compatibility: the old function had HOW-TO-ADD as the - ;; third argument and no arguments after that. - ;; #### this should disappear at some point. - (if (and (null how-to-add) - (memq locale '(prepend append remove-tag-set-prepend - remove-tag-set-append remove-locale - remove-locale-type remove-all))) - (progn - (setq how-to-add locale) - (setq locale nil))) - - ;; proper beginning of the function. - (let ((is-valid (valid-instantiator-p value (specifier-type specifier))) - (nval value)) - (cond ((and (not is-valid) (specifierp nval)) - (copy-specifier nval specifier locale tag-set nil how-to-add)) - (t - (if tag-set - (progn - (if (not (listp tag-set)) - (setq tag-set (list tag-set))) - ;; You tend to get more accurate errors - ;; for a variety of cases if you call - ;; canonicalize-tag-set here. - (setq tag-set (canonicalize-tag-set tag-set)) - (if (and (not is-valid) (consp nval)) - (setq nval - (mapcar #'(lambda (x) - (check-valid-instantiator - x (specifier-type specifier)) - (cons tag-set x)) - nval)) - (setq nval (cons tag-set nval))))) - (if locale - (setq nval (cons locale nval))) - (add-spec-list-to-specifier - specifier - (canonicalize-spec-list nval (specifier-type specifier)) - how-to-add)))) - value) - -(define-specifier-tag 'win 'device-on-window-system-p)
--- a/lisp/prim/startup.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1448 +0,0 @@ -;;; startup.el --- process XEmacs shell arguments - -;; Copyright (C) 1985-1986, 1990, 1992-1997 Free Software Foundation, Inc. -;; Copyright (c) 1993, 1994 Sun Microsystems, Inc. -;; Copyright (C) 1995 Board of Trustees, University of Illinois - -;; Maintainer: XEmacs -;; Keywords: internal - -;; 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, 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: FSF 19.34. - -;;; Code: - -;;; -batch, -t, and -nw are processed by main() in emacs.c and are -;;; never seen by lisp code. - -;;; -version and -help are special-cased as well: they imply -batch, -;;; but are left on the list for lisp code to process. - - -(setq top-level '(normal-top-level)) - -(defvar command-line-processed nil "t once command line has been processed") - -(defconst startup-message-timeout 12000) ; More or less disable the timeout - -(defconst inhibit-startup-message nil - "*Non-nil inhibits the initial startup message. -This is for use in your personal init file, once you are familiar -with the contents of the startup message.") - -;; #### FSFmacs randomness -;;(defconst inhibit-startup-echo-area-message nil -;; "*Non-nil inhibits the initial startup echo area message. -;;Inhibition takes effect only if your `.emacs' file contains -;;a line of this form: -;; (setq inhibit-startup-echo-area-message \"YOUR-USER-NAME\") -;;If your `.emacs' file is byte-compiled, use the following form instead: -;; (eval '(setq inhibit-startup-echo-area-message \"YOUR-USER-NAME\")) -;;Thus, someone else using a copy of your `.emacs' file will see -;;the startup message unless he personally acts to inhibit it.") - -(defconst inhibit-default-init nil - "*Non-nil inhibits loading the `default' library.") - -(defvar command-line-args-left nil - "List of command-line args not yet processed.") ; bound by `command-line' - -(defvar command-line-default-directory nil - "Default directory to use for command line arguments. -This is normally copied from `default-directory' when XEmacs starts.") - -(defvar before-init-hook nil - "Functions to call after handling urgent options but before init files. -The frame system uses this to open frames to display messages while -XEmacs loads the user's initialization file.") - -(defvar after-init-hook nil - "*Functions to call after loading the init file (`~/.xemacs/init.el'). -The call is not protected by a condition-case, so you can set `debug-on-error' -in `init.el', and put all the actual code on `after-init-hook'.") - -(defvar term-setup-hook nil - "*Functions to be called after loading terminal-specific Lisp code. -See `run-hooks'. This variable exists for users to set, so as to -override the definitions made by the terminal-specific file. XEmacs -never sets this variable itself.") - -(defvar keyboard-type nil - "The brand of keyboard you are using. -This variable is used to define the proper function and keypad keys -for use under X. It is used in a fashion analogous to the environment -value TERM.") - -(defvar window-setup-hook nil - "Normal hook run to initialize window system display. -XEmacs runs this hook after processing the command line arguments and loading -the user's init file.") - -(defconst initial-major-mode 'lisp-interaction-mode - "Major mode command symbol to use for the initial *scratch* buffer.") - -(defvar init-file-user nil - "Identity of user whose `~/.xemacs/init.el' file is or was read. -The value is nil if no init file is being used; otherwise, it may be either -the null string, meaning that the init file was taken from the user that -originally logged in, or it may be a string containing a user's name. - -In either of the latter cases, `(concat \"~\" init-file-user \"/\")' -evaluates to the name of the directory where the `init.el' file was -looked for. - -Setting `init-file-user' does not prevent Emacs from loading -`site-start.el'. The only way to do that is to use `--no-site-file'.") - -;; #### called `site-run-file' in FSFmacs - -(defvar site-start-file (purecopy "site-start") - "File containing site-wide run-time initializations. -This file is loaded at run-time before `~/.xemacs/init.el'. It -contains inits that need to be in place for the entire site, but -which, due to their higher incidence of change, don't make sense to -load into XEmacs' dumped image. Thus, the run-time load order is: - - 1. file described in this variable, if non-nil; - 2. `~/.xemacs/init.el'; - 3. `/path/to/xemacs/lisp/default.el'. - -Don't use the `site-start.el' file for things some users may not like. -Put them in `default.el' instead, so that users can more easily -override them. Users can prevent loading `default.el' with the `-q' -option or by setting `inhibit-default-init' in their own init files, -but inhibiting `site-start.el' requires `--no-site-file', which -is less convenient.") - -;;(defconst iso-8859-1-locale-regexp "8859[-_]?1" -;; "Regexp that specifies when to enable the ISO 8859-1 character set. -;;We do that if this regexp matches the locale name -;;specified by the LC_ALL, LC_CTYPE and LANG environment variables.") - -(defvar mail-host-address nil - "*Name of this machine, for purposes of naming users.") - -(defvar user-mail-address nil - "*Full mailing address of this user. -This is initialized based on `mail-host-address', -after your init file is read, in case it sets `mail-host-address'.") - -(defvar auto-save-list-file-prefix "~/.xemacs/.saves-" - "Prefix for generating auto-save-list-file-name. -Emacs's pid and the system name will be appended to -this prefix to create a unique file name.") - -(defvar init-file-debug nil) - -(defvar init-file-had-error nil) - -(defvar init-file-loaded nil - "True after the user's init file has been loaded (or suppressed with -q). -This will be true when `after-init-hook' is run and at all times -after, and will not be true at any time before.") - -(defvar initial-frame-unmapped-p nil) - - - -(defvar command-switch-alist - (purecopy - '(("-help" . command-line-do-help) - ("-flags" . command-line-do-help) - ("-h" . command-line-do-help) - ("-?" . command-line-do-help) - ("-version". command-line-do-version) - ("-V" . command-line-do-version) - ("-funcall". command-line-do-funcall) - ("-f" . command-line-do-funcall) - ("-e" . command-line-do-funcall-1) - ("-eval" . command-line-do-eval) - ("-load" . command-line-do-load) - ("-l" . command-line-do-load) - ("-insert" . command-line-do-insert) - ("-i" . command-line-do-insert) - ("-kill" . command-line-do-kill) - ;; Options like +35 are handled specially. - ;; Window-system, site, or package-specific code might add to this. - ;; X11 handles its options by letting Xt remove args from this list. - )) - "Alist of command-line switches. -Elements look like (SWITCH-STRING . HANDLER-FUNCTION). -HANDLER-FUNCTION receives switch name as sole arg; -remaining command-line args are in the variable `command-line-args-left'.") - -;;; default switches -;;; Note: these doc strings are semi-magical. - -(defun command-line-do-help (arg) - "Print the XEmacs usage message and exit." - (let ((standard-output 'external-debugging-output)) - (princ (concat "\n" (emacs-version) "\n\n")) - (princ - (if (featurep 'x) - (concat (emacs-name) - " accepts all standard X Toolkit command line options.\n" - "In addition, the") - "The")) - (princ " following options are accepted: - - -t <device> Use TTY <device> instead of the terminal for input - and output. This implies the -nw option. - -nw Inhibit the use of any window-system-specific - display code: use the current tty. - -batch Execute noninteractively (messages go to stderr). - -debug-init Enter the debugger if an error in the init file occurs. - -unmapped Do not map the initial frame. - -no-site-file Do not load the site-specific init file (site-start.el). - -no-init-file Do not load the user-specific init file (~/.emacs). - -no-packages Do not process the package path. - -vanilla Equivalent to -q -no-site-file -no-packages. - -q Same as -no-init-file. - -user <user> Load user's init file instead of your own. - -u <user> Same as -user.\n") - (let ((l command-switch-alist) - (insert (lambda (&rest x) - (princ " ") - (let ((len 2)) - (while x - (princ (car x)) - (incf len (length (car x))) - (setq x (cdr x))) - (when (>= len 24) - (terpri) (setq len 0)) - (while (< len 24) - (princ " ") - (incf len)))))) - (while l - (let ((name (car (car l))) - (fn (cdr (car l))) - doc arg cons) - (cond - ((and (symbolp fn) (get fn 'undocumented)) nil) - (t - (setq doc (documentation fn)) - (if (member doc '(nil "")) (setq doc "(undocumented)")) - (cond ((string-match "\n\\(<.*>\\)\n?\\'" doc) - ;; Doc of the form "The frobber switch\n<arg1> <arg2>" - (setq arg (substring doc (match-beginning 1) (match-end 1)) - doc (substring doc 0 (match-beginning 0)))) - ((string-match "\n+\\'" doc) - (setq doc (substring doc 0 (match-beginning 0))))) - (if (and (setq cons (rassq fn command-switch-alist)) - (not (eq cons (car l)))) - (setq doc (format "Same as %s." (car cons)))) - (if arg - (funcall insert name " " arg) - (funcall insert name)) - (princ doc) - (terpri)))) - (setq l (cdr l)))) - (princ (concat "\ - +N <file> Start displaying <file> at line N. - -Anything else is considered a file name, and is placed into a buffer for -editing. - -" (emacs-name) " has an online tutorial and manuals. Type ^Ht (Control-h t) after -starting XEmacs to run the tutorial. Type ^Hi to enter the manual browser. -Type ^H^H^H (Control-h Control-h Control-h) to get more help options.\n") - - (kill-emacs 0)))) - -(defun command-line-do-funcall (arg) - "Invoke the named lisp function with no arguments. -<function>" - (funcall (intern (pop command-line-args-left)))) -(fset 'command-line-do-funcall-1 'command-line-do-funcall) -(put 'command-line-do-funcall-1 'undocumented t) - -(defun command-line-do-eval (arg) - "Evaluate the lisp form. Quote it carefully. -<form>" - (eval (read (pop command-line-args-left)))) - -(defun command-line-do-load (arg) - "Load the named file of Lisp code into XEmacs. -<file>" - (let ((file (pop command-line-args-left))) - ;; Take file from default dir if it exists there; - ;; otherwise let `load' search for it. - (if (file-exists-p (expand-file-name file)) - (setq file (expand-file-name file))) - (load file nil t))) - -(defun command-line-do-insert (arg) - "Insert file into the current buffer. -<file>" - (insert-file-contents (pop command-line-args-left))) - -(defun command-line-do-kill (arg) - "Exit XEmacs." - (kill-emacs t)) - -(defun command-line-do-version (arg) - "Print version info and exit." - (princ (concat (emacs-version) "\n")) - (kill-emacs 0)) - - -;;; Processing the command line and loading various init files - -(defun early-error-handler (&rest debugger-args) - "You should probably not be using this." - ;; Used as the debugger during XEmacs initialization; if an error occurs, - ;; print some diagnostics, and kill XEmacs. - - ;; output the contents of the warning buffer, since it won't be seen - ;; otherwise. - ;; #### kludge! The call to Feval forces the pending warnings to - ;; get output. There definitely needs to be a better way. - (let ((buffer (eval (get-buffer-create "*Warnings*")))) - (princ (buffer-substring (point-min buffer) (point-max buffer) buffer) - 'external-debugging-output)) - - (let ((string "Initialization error") - (error (nth 1 debugger-args)) - (debug-on-error nil) - (stream 'external-debugging-output)) - (if (null error) - (princ string stream) - (princ (concat "\n" string ": ") stream) - (condition-case () - (display-error error stream) - (error (princ "<<< error printing error message >>>" stream))) - (princ "\n" stream) - (if (memq (car-safe error) '(void-function void-variable)) - (princ " - This probably means that XEmacs is picking up an old version of - the lisp library, or that some .elc files are not up-to-date.\n" - stream))) - (when (not suppress-early-error-handler-backtrace) - (let ((print-length 1000) - (print-level 1000) - (print-escape-newlines t) - (print-readably nil)) - (when (getenv "EMACSLOADPATH") - (princ (format "\n$EMACSLOADPATH is %s" (getenv "EMACSLOADPATH")) - stream)) - (princ (format "\nexec-directory is %S" exec-directory) stream) - (princ (format "\ndata-directory is %S" data-directory) stream) - (princ (format "\ndoc-directory is %S" doc-directory) stream) - (princ (format "\nload-path is %S" load-path) stream) - (princ "\n\n" stream))) - (when (not suppress-early-error-handler-backtrace) - (backtrace stream t))) - (kill-emacs -1)) - -(defvar lock-directory) -(defvar superlock-file) - -(defun normal-top-level () - (if command-line-processed - (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 (getenv "HOME"))) - (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) - (unwind-protect - (command-line) - ;; Do this again, in case .emacs defined more abbreviations. - (setq default-directory (abbreviate-file-name default-directory)) - ;; Specify the file for recording all the auto save files of - ;; this session. This is used by recover-session. - (setq auto-save-list-file-name - (expand-file-name - (format "%s%d-%s" - auto-save-list-file-prefix - (emacs-pid) - (system-name)))) - (run-hooks 'emacs-startup-hook) - (and term-setup-hook - (run-hooks 'term-setup-hook)) - (setq term-setup-hook nil) - ;; ;; Modify the initial frame based on what .emacs puts into - ;; ;; ...-frame-alist. - (frame-notice-user-settings) - ;; ;;####FSFmacs junk - ;; ;; Now we know the user's default font, so add it to the menu. - ;; (if (fboundp 'font-menu-add-default) - ;; (font-menu-add-default)) - (when window-setup-hook - (run-hooks 'window-setup-hook)) - (setq window-setup-hook nil)) - ;;####FSFmacs junk - ;; (or menubar-bindings-done - ;; (precompute-menubar-bindings)) - )) - -;;####FSFmacs junk -;;; Precompute the keyboard equivalents in the menu bar items. -;;(defun precompute-menubar-bindings () -;; (if (eq window-system 'x) -;; (let ((submap (lookup-key global-map [menu-bar]))) -;; (while submap -;; (and (consp (car submap)) -;; (symbolp (car (car submap))) -;; (stringp (car-safe (cdr (car submap)))) -;; (keymapp (cdr (cdr (car submap)))) -;; (x-popup-menu nil (cdr (cdr (car submap))))) -;; (setq submap (cdr submap)))))) - -(defun command-line-early (args) - ;; This processes those switches which need to be processed before - ;; starting up the window system. - - (setq command-line-default-directory default-directory) - - ;; See if we should import version-control from the environment variable. - (let ((vc (getenv "VERSION_CONTROL"))) - (cond ((eq vc nil)) ;don't do anything if not set - ((or (string= vc "t") - (string= vc "numbered")) - (setq version-control t)) - ((or (string= vc "nil") - (string= vc "existing")) - (setq version-control nil)) - ((or (string= vc "never") - (string= vc "simple")) - (setq version-control 'never)))) - - ;;####FSFmacs - ;; (if (let ((ctype - ;; ;; Use the first of these three envvars that has a nonempty value. - ;; (or (let ((string (getenv "LC_ALL"))) - ;; (and (not (equal string "")) string)) - ;; (let ((string (getenv "LC_CTYPE"))) - ;; (and (not (equal string "")) string)) - ;; (let ((string (getenv "LANG"))) - ;; (and (not (equal string "")) string))))) - ;; (and ctype - ;; (string-match iso-8859-1-locale-regexp ctype))) - ;; (progn - ;; (standard-display-european t) - ;; (require 'iso-syntax))) - - ;; Figure out which user's init file to load, - ;; either from the environment or from the options. - (setq init-file-user (if (noninteractive) nil (user-login-name))) - ;; If user has not done su, use current $HOME to find .emacs. - (and init-file-user (string= init-file-user (user-real-login-name)) - (setq init-file-user "")) - - ;; Allow (at least) these arguments anywhere in the command line - (let ((new-args nil) - (arg nil)) - (while args - (setq arg (pop args)) - (cond - ((or (string= arg "-q") - (string= arg "-no-init-file")) - (setq init-file-user nil)) - ((string= arg "-no-site-file") - (setq site-start-file nil)) - ((string= arg "-no-packages") - (setq inhibit-package-init t)) - ((string= arg "-vanilla") - (setq init-file-user nil - site-start-file nil - inhibit-package-init t)) - ((or (string= arg "-u") - (string= arg "-user")) - (setq init-file-user (pop args))) - ((string= arg "-debug-init") - (setq init-file-debug t)) - ((string= arg "-unmapped") - (setq initial-frame-unmapped-p t)) - ((or (string= arg "--") (string= arg "-")) - (while args - (push (pop args) new-args))) - (t (push arg new-args)))) - - (nreverse new-args))) - -(defconst initial-scratch-message "\ -;; This buffer is for notes you don't want to save, and for Lisp evaluation. -;; If you want to create a file, first visit that file with C-x C-f, -;; then enter the text in that file's own buffer. - -" - "Initial message displayed in *scratch* buffer at startup. -If this is nil, no message will be displayed.") - -(defun command-line () - (let ((command-line-args-left (cdr command-line-args))) - - (let ((debugger 'early-error-handler) - (debug-on-error t)) - (set-default-load-path) - - ;; Process magic command-line switches like -q and -u. Do this - ;; before creating the first frame because some of these switches - ;; may affect that. I think it's ok to do this before establishing - ;; the X connection, and maybe someday things like -nw can be - ;; handled here instead of down in C. - (setq command-line-args-left (command-line-early command-line-args-left)) - - ;; Setup the toolbar icon directory - (when (featurep 'toolbar) - (init-toolbar-location)) - - ;; Run the window system's init function. tty is considered to be - ;; a type of window system for this purpose. This creates the - ;; initial (non stdio) device. - (when (and initial-window-system (not noninteractive)) - (funcall (intern (concat "init-" - (symbol-name initial-window-system) - "-win")))) - - ;; When not in batch mode, this creates the first visible frame, - ;; and deletes the stdio device. - (frame-initialize)) - - ;; - ;; We have normality, I repeat, we have normality. Anything you still - ;; can't cope with is therefore your own problem. (And we don't need - ;; to kill XEmacs for it.) - ;; - - ;;; Load init files. - (load-init-file) - - (with-current-buffer (get-buffer "*scratch*") - (erase-buffer) - ;; (insert initial-scratch-message) - (set-buffer-modified-p nil) - (when (eq major-mode 'fundamental-mode) - (funcall initial-major-mode))) - - ;; Load library for our terminal type. - ;; User init file can set term-file-prefix to nil to prevent this. - ;; Note that for any TTY's opened subsequently, the TTY init - ;; code will run this. - (when (and (eq 'tty (console-type)) - (not (noninteractive))) - (load-terminal-library)) - - ;; Process the remaining args. - (command-line-1) - - ;; it was turned on by default so that the warnings don't get displayed - ;; until after the splash screen. - (setq inhibit-warning-display nil) - ;; If -batch, terminate after processing the command options. - (when (noninteractive) (kill-emacs t)))) - -(defun load-terminal-library () - (when term-file-prefix - (let ((term (getenv "TERM")) - hyphend) - (while (and term - (not (load (concat term-file-prefix term) t t))) - ;; Strip off last hyphen and what follows, then try again - (if (setq hyphend (string-match "[-_][^-_]+\\'" term)) - (setq term (substring term 0 hyphend)) - (setq term nil)))))) - -(defconst user-init-directory "/.xemacs/" - "Directory where user initialization and user-installed packages may go.") -(define-obsolete-variable-alias - 'emacs-user-extension-dir - 'user-init-directory) - -(defun load-user-init-file (init-file-user) - "This function actually reads the init files. -First try .xemacs/init, then try .emacs, but only load one of the two." - (when init-file-user - (setq user-init-file - (cond - ((eq system-type 'ms-dos) - (concat "~" init-file-user user-init-directory "init.el")) - (t - (concat "~" init-file-user user-init-directory "init.el")))) - (unless (file-exists-p (expand-file-name user-init-file)) - (setq user-init-file - (cond - ((eq system-type 'ms-dos) - (concat "~" init-file-user "/_emacs")) - (t - (concat "~" init-file-user "/.emacs"))))) - (load user-init-file t t t) - (let ((default-custom-file (concat "~" - init-file-user - user-init-directory - "options.el"))) - (when (string= custom-file default-custom-file) - (load default-custom-file t t))) - (unless inhibit-default-init - (let ((inhibit-startup-message nil)) - ;; Users are supposed to be told their rights. - ;; (Plus how to get help and how to undo.) - ;; Don't you dare turn this off for anyone except yourself. - (load "default" t t))))) - -;;; Load user's init file and default ones. -(defun load-init-file () - (run-hooks 'before-init-hook) - - ;; Run the site-start library if it exists. The point of this file is - ;; that it is run before .emacs. There is no point in doing this after - ;; .emacs; that is useless. - (when site-start-file - (load site-start-file t t)) - - ;; Sites should not disable this. Only individuals should disable - ;; the startup message. - (setq inhibit-startup-message nil) - - (let (debug-on-error-from-init-file - debug-on-error-should-be-set - (debug-on-error-initial - (if (eq init-file-debug t) 'startup init-file-debug))) - (let ((debug-on-error debug-on-error-initial)) - (if init-file-debug - ;; Do this without a condition-case if the user wants to debug. - (load-user-init-file init-file-user) - (condition-case error - (progn - (load-user-init-file init-file-user) - (setq init-file-had-error nil)) - (error - (message "Error in init file: ") - (display-error error nil) - (setq init-file-had-error t)))) - ;; If we can tell that the init file altered debug-on-error, - ;; arrange to preserve the value that it set up. - (or (eq debug-on-error debug-on-error-initial) - (setq debug-on-error-should-be-set t - debug-on-error-from-init-file debug-on-error))) - (when debug-on-error-should-be-set - (setq debug-on-error debug-on-error-from-init-file))) - - (setq init-file-loaded t) - - ;; Do this here in case the init file sets mail-host-address. - ;; Don't do this here unless noninteractive, it is frequently wrong. -sb - ;; (or user-mail-address - (when noninteractive - (setq user-mail-address (concat (user-login-name) "@" - (or mail-host-address - (system-name))))) - - (run-hooks 'after-init-hook) - nil) - -(defun load-options-file (filename) - "Load the file of saved options (from the Options menu) called FILENAME. -Currently this does nothing but call `load', but it might be redefined -in the future to support automatically converting older options files to -a new format, when variables have changed, etc." - (load filename)) - -(defun command-line-1 () - (cond - ((null command-line-args-left) - (unless noninteractive - ;; If there are no switches to process, run the term-setup-hook - ;; before displaying the copyright notice; there may be some need - ;; to do it before doing any output. If we're not going to - ;; display a copyright notice (because other options are present) - ;; then this is run after those options are processed. - (run-hooks 'term-setup-hook) - ;; Don't let the hook be run twice. - (setq term-setup-hook nil) - - ;; Don't clobber a non-scratch buffer if init file - ;; has selected it. - (when (string= (buffer-name) "*scratch*") - (unless (or inhibit-startup-message - (input-pending-p)) - (let ((timeout nil)) - (unwind-protect - ;; Guts of with-timeout - (catch 'timeout - (setq timeout (add-timeout startup-message-timeout - (lambda (ignore) - (condition-case nil - (throw 'timeout t) - (error nil))) - nil)) - (startup-splash-frame) - (or nil;; (pos-visible-in-window-p (point-min)) - (goto-char (point-min))) - (sit-for 0) - (setq unread-command-event (next-command-event))) - (when timeout (disable-timeout timeout))))) - (with-current-buffer (get-buffer "*scratch*") - ;; In case the XEmacs server has already selected - ;; another buffer, erase the one our message is in. - (erase-buffer) - (when (stringp initial-scratch-message) - (insert initial-scratch-message)) - (set-buffer-modified-p nil))))) - - (t - ;; Command-line-options exist - (let ((dir command-line-default-directory) - (file-count 0) - (line nil) - (end-of-options nil) - first-file-buffer file-p arg tem) - (while command-line-args-left - (setq arg (pop command-line-args-left)) - (cond - (end-of-options - (setq file-p t)) - ((setq tem (when (eq (aref arg 0) ?-) - (or (assoc arg command-switch-alist) - (assoc (substring arg 1) - command-switch-alist)))) - (funcall (cdr tem) arg)) - ((string-match "\\`\\+[0-9]+\\'" arg) - (setq line (string-to-int arg))) - ;; "- file" means don't treat "file" as a switch - ;; ("+0 file" has the same effect; "-" added - ;; for unixoidiality). - ;; This is worthless; the `unixoid' way is "./file". -jwz - ((or (string= arg "-") (string= arg "--")) - (setq end-of-options t)) - (t - (setq file-p t))) - - (when file-p - (setq file-p nil) - (incf file-count) - (setq arg (expand-file-name arg dir)) - (cond - ((= file-count 1) (setq first-file-buffer - (progn (find-file arg) (current-buffer)))) - (noninteractive (find-file arg)) - (t (find-file-other-window arg))) - (when line - (goto-line line) - (setq line nil)))) - ;; If 3 or more files visited, and not all visible, - ;; show user what they all are. - (when (and (not noninteractive) - (> file-count 2) - (not (get-buffer-window first-file-buffer))) - (other-window 1) - (buffer-menu nil)))))) - -(defvar startup-presentation-hack-keymap - (let ((map (make-sparse-keymap))) - (set-keymap-name map 'startup-presentation-hack-keymap) - (define-key map '[button1] 'startup-presentation-hack) - (define-key map '[button2] 'startup-presentation-hack) - map) - "Putting yesterday in the future tomorrow.") - -(defun startup-presentation-hack () - (interactive) - (let ((e last-command-event)) - (and (button-press-event-p e) - (setq e (extent-at (event-point e) - (event-buffer e) - 'startup-presentation-hack)) - (setq e (extent-property e 'startup-presentation-hack)) - (if (consp e) - (apply (car e) (cdr e)) - (while (keymapp (indirect-function e)) - (let ((map e) - (overriding-local-map (indirect-function e))) - (setq e (read-key-sequence - (let ((p (keymap-prompt map t))) - (cond ((symbolp map) - (if p - (format "%s %s " map p) - (format "%s " map))) - (p) - (t - (prin1-to-string map)))))) - (if (and (button-release-event-p (elt e 0)) - (null (key-binding e))) - (setq e map) ; try again - (setq e (key-binding e))))) - (call-interactively e))))) - -(defun startup-presentation-hack-help (e) - (setq e (extent-property e 'startup-presentation-hack)) - (if (consp e) - (format "Evaluate %S" e) - (symbol-name e))) - -(defun splash-frame-present-hack (e v) - ;; (set-extent-property e 'mouse-face 'highlight) - ;; (set-extent-property e 'keymap - ;; startup-presentation-hack-keymap) - ;; (set-extent-property e 'startup-presentation-hack v) - ;; (set-extent-property e 'help-echo - ;; 'startup-presentation-hack-help)) - ) - -(defun splash-hack-version-string () - (save-excursion - (save-restriction - (goto-char (point-min)) - (re-search-forward "^XEmacs" nil t) - (narrow-to-region (point-at-bol) (point-at-eol)) - (goto-char (point-min)) - (when (re-search-forward " \\[Lucid\\]" nil t) - (delete-region (match-beginning 0) (match-end 0))) - (when (re-search-forward "[^(][^)]*-[^)]*-" nil t) - (delete-region (1+ (match-beginning 0)) (match-end 0)) - (insert "(")) - (goto-char (point-max)) - (search-backward " " nil t) - (when (search-forward "." nil t) - (delete-region (1- (point)) (point-max)))))) - -(defun splash-frame-present (l) - (cond ((stringp l) - (insert l)) - ((eq (car-safe l) 'face) - ;; (face name string) - (let ((p (point))) - (splash-frame-present (elt l 2)) - (if (fboundp 'set-extent-face) - (set-extent-face (make-extent p (point)) - (elt l 1))))) - ((eq (car-safe l) 'key) - (let* ((c (elt l 1)) - (p (point)) - (k (where-is-internal c nil t))) - (insert (if k (key-description k) - (format "M-x %s" c))) - (if (fboundp 'set-extent-face) - (let ((e (make-extent p (point)))) - (set-extent-face e 'bold) - (splash-frame-present-hack e c))))) - ((eq (car-safe l) 'funcall) - ;; (funcall (fun . args) string) - (let ((p (point))) - (splash-frame-present (elt l 2)) - (if (fboundp 'set-extent-face) - (splash-frame-present-hack (make-extent p (point)) - (elt l 1))))) - ((consp l) - (mapcar 'splash-frame-present l)) - (t - (error "WTF!?")))) - -(defun startup-center-spaces (glyph) - ;; Return the number of spaces to insert in order to center - ;; the given glyph (may be a string or a pixmap). - ;; Assume spaces are as wide as avg-pixwidth. - ;; Won't be quite right for proportional fonts, but it's the best we can do. - ;; Maybe the new redisplay will export something a glyph-width function. - ;;; #### Yes, there is a glyph-width function but it isn't quite what - ;;; #### this was expecting. Or is it? - ;; (An alternate way to get avg-pixwidth would be to use x-font-properties - ;; and calculate RESOLUTION_X * AVERAGE_WIDTH / 722.7, but it's no better.) - - ;; This function is used in about.el too. - (let* ((avg-pixwidth (round (/ (frame-pixel-width) (frame-width)))) - (fill-area-width (* avg-pixwidth (- fill-column left-margin))) - (glyph-pixwidth (cond ((stringp glyph) - (* avg-pixwidth (length glyph))) - ;; #### the pixmap option should be removed - ;;((pixmapp glyph) - ;; (pixmap-width glyph)) - ((glyphp glyph) - (glyph-width glyph)) - (t - (error "startup-center-spaces: bad arg"))))) - (+ left-margin - (round (/ (/ (- fill-area-width glyph-pixwidth) 2) avg-pixwidth))))) - -(defun startup-splash-frame-body () - `("\n" ,(emacs-version) "\n" - ,@(if (string-match "beta" emacs-version) - `( (face (bold blue) ( "This is an Experimental version of XEmacs. " - " Type " (key describe-beta) - " to see what this means.\n"))) - `( "\n")) - (face bold-italic "\ -Copyright (C) 1985-1997 Free Software Foundation, Inc. -Copyright (C) 1990-1994 Lucid, Inc. -Copyright (C) 1993-1997 Sun Microsystems, Inc. All Rights Reserved. -Copyright (C) 1994-1996 Board of Trustees, University of Illinois -Copyright (C) 1995-1996 Ben Wing\n\n") - - ,@(if (featurep 'sparcworks) - `( "\ -Sun provides support for the WorkShop/XEmacs integration package only. -All other XEmacs packages are provided to you \"AS IS\". -For full details, type " (key describe-no-warranty) -" to refer to the GPL Version 2, dated June 1991.\n\n" -,@(let ((lang (or (getenv "LC_ALL") (getenv "LC_MESSAGES") (getenv "LANG")))) - (if (and - (not (featurep 'mule)) ; Already got mule? - (not (eq 'tty (console-type))) ; No Mule support on tty's yet - lang ; Non-English locale? - (not (string= lang "C")) - (not (string-match "^en" lang)) - (locate-file "xemacs-mule" exec-path)) ; Comes with Sun WorkShop - '( "\ -This version of XEmacs has been built with support for Latin-1 languages only. -To handle other languages you need to run a Multi-lingual (`Mule') version of -XEmacs, by either running the command `xemacs-mule', or by using the X resource -`ESERVE*defaultXEmacsPath: xemacs-mule' when starting XEmacs from Sun WorkShop.\n\n")))) - - '("XEmacs comes with ABSOLUTELY NO WARRANTY; type " - (key describe-no-warranty) " for full details.\n")) - - "You may give out copies of XEmacs; type " - (key describe-copying) " to see the conditions.\n" - "Type " (key describe-distribution) - " for information on getting the latest version.\n\n" - - "Type " (key help-command) " or use the " (face bold "Help") " menu to get help.\n" - "Type " (key advertised-undo) " to undo changes (`C-' means use the Control key).\n" - "To get out of XEmacs, type " (key save-buffers-kill-emacs) ".\n" - "Type " (key help-with-tutorial) " for a tutorial on using XEmacs.\n" - "Type " (key info) " to enter Info, " - "which you can use to read online documentation.\n" - (face (bold red) ( "\ -For tips and answers to frequently asked questions, see the XEmacs FAQ. -\(It's on the Help menu, or type " (key xemacs-local-faq) " [a capital F!].\)")))) - -(defun startup-splash-frame () - (let ((p (point)) - (cramped-p (eq 'tty (console-type)))) - (unless cramped-p (insert "\n")) - (indent-to (startup-center-spaces xemacs-logo)) - (set-extent-begin-glyph (make-extent (point) (point)) xemacs-logo) - (insert (if cramped-p "\n" "\n\n")) - (splash-frame-present-hack (make-extent p (point)) 'about-xemacs)) - - (let ((after-change-functions nil)) ; no font-lock, thank you - (dolist (l (startup-splash-frame-body)) - (splash-frame-present l))) - (splash-hack-version-string) - (set-buffer-modified-p nil)) - -;; (let ((present-file -;; #'(lambda (f) -;; (splash-frame-present -;; (list 'funcall -;; (list 'find-file-other-window -;; (expand-file-name f data-directory)) -;; f))))) -;; (insert "For customization examples, see the files ") -;; (funcall present-file "sample.emacs") -;; (insert " and ") -;; (funcall present-file "sample.Xdefaults") -;; (insert (format "\nin the directory %s." data-directory))) - - -;;;; Computing the default load-path, etc. -;;; -;;; This stuff is a complete mess and isn't nearly as general as it -;;; thinks it is. It should be rethunk. In particular, too much logic -;;; is duplicated between the code that looks around for the various -;;; directories, and the code which suggests where to create the various -;;; directories once it decides they are missing. - -;;; The source directory has this layout: -;;; -;;; BUILD_ROOT/src/xemacs* argv[0] -;;; BUILD_ROOT/xemacs* argv[0], possibly -;;; BUILD_ROOT/lisp/ -;;; BUILD_ROOT/etc/ data-directory -;;; BUILD_ROOT/info/ -;;; BUILD_ROOT/lib-src/ exec-directory, doc-directory -;;; BUILD_ROOT/lock/ -;;; -;;; The default tree created by "make install" has this layout: -;;; -;;; PREFIX/bin/xemacs* argv[0] -;;; PREFIX/lib/xemacs-VERSION/lisp/ -;;; PREFIX/lib/xemacs-VERSION/etc/ data-directory -;;; PREFIX/lib/xemacs-VERSION/info/ -;;; PREFIX/lib/xemacs-VERSION/CONFIGURATION/ exec-directory, doc-directory -;;; PREFIX/lib/xemacs/lock/ -;;; PREFIX/lib/xemacs/site-lisp/ -;;; -;;; The binary packages we ship have that layout, except that argv[0] has -;;; been moved one level deeper under the bin directory: -;;; -;;; PREFIX/bin/CONFIGURATION/xemacs* -;;; -;;; The following code has to deal with at least the above three situations, -;;; and it should be possible for it to deal with more. Though perhaps that -;;; does cover it all? The trick is, when something is missing, realizing -;;; which of those three layouts is mostly in place, so that we can suggest -;;; the right directories in the error message. - - -;; extremely low-tech debugging, since this happens so early in startup. -;;(or (fboundp 'orig-file-directory-p) -;; (fset 'orig-file-directory-p (symbol-function 'file-directory-p))) -;;(defun file-directory-p (path) -;; (send-string-to-terminal (format "PROBING %S" path)) -;; (let ((v (orig-file-directory-p path))) -;; (send-string-to-terminal (format " -> %S\n" v)) -;; v)) - -(defun startup-make-version-dir () - (let ((version (and (string-match "\\`[^0-9]*\\([0-9]+\\.[0-9]+\\)" - emacs-version) - (substring emacs-version - (match-beginning 1) (match-end 1))))) - (if (string-match "(beta *\\([0-9]+\\))" emacs-version) - (setq version (concat version "-b" - (substring emacs-version (match-beginning 1) - (match-end 1))))) - (if (string-match "(alpha *\\([0-9]+\\))" emacs-version) - (setq version (concat version "-a" - (substring emacs-version (match-beginning 1) - (match-end 1))))) - (concat "lib/xemacs-" version))) - -(defun find-emacs-root-internal-1 (path lisp-p) - ;; (prin1 (format "f-e-r-i-1: %s\n" path)) - (let ((dir (file-name-directory path))) - (or - ;; - ;; If this directory is a plausible root of the XEmacs tree, return it. - ;; - (and (or (not lisp-p) - (file-directory-p (expand-file-name "lisp/prim" dir))) - (or (file-directory-p (expand-file-name "lib-src" dir)) - (file-directory-p (expand-file-name system-configuration dir))) - dir) - ;; - ;; If the parent of this directory is a plausible root, use it. - ;; (But don't do so recursively!) - ;; - (and (or (not lisp-p) - (file-directory-p (expand-file-name "../lisp/prim" dir))) - (or (file-directory-p (expand-file-name - (format "../%s" system-configuration) - dir)) - (file-directory-p (expand-file-name "../lib-src" dir))) - (expand-file-name "../" dir)) - - ;; - ;; (--run-in-place) Same thing, but from one directory level deeper. - ;; - (and (or (not lisp-p) - (file-directory-p (expand-file-name "../../lisp/prim" dir))) - (or (file-directory-p (expand-file-name - (format "../%s" system-configuration) - dir)) - (file-directory-p - (expand-file-name - (format "../../lib-src/%s" system-configuration) dir))) - (expand-file-name "../.." dir)) - - ;; If ../lib/xemacs-<version> exists check it. - ;; This is of the form "xemacs-19.10/" or "xemacs-19.10-b7/". - ;; - (let ((ver-dir (concat "../" (startup-make-version-dir)))) - (and (or (not lisp-p) - (file-directory-p (expand-file-name - (format "%s/lisp/prim" ver-dir) - dir))) - (or (file-directory-p (expand-file-name - (format "%s/%s" ver-dir - system-configuration) - dir)) - (file-directory-p (expand-file-name - (format "%s/lib-src" ver-dir) - dir))) - (expand-file-name (file-name-as-directory ver-dir) dir))) - ;; - ;; Same thing, but one higher: ../../lib/xemacs-<version>. - ;; - (let ((ver-dir (concat "../../" (startup-make-version-dir)))) - (and (or (not lisp-p) - (file-directory-p (expand-file-name - (format "%s/lisp/prim" ver-dir) - dir))) - (or (file-directory-p (expand-file-name - (format "%s/%s" ver-dir - system-configuration) - dir)) - (file-directory-p (expand-file-name - (format "%s/lib-src" ver-dir) - dir))) - (expand-file-name (file-name-as-directory ver-dir) dir))) - ;; - ;; If that doesn't work, and the XEmacs executable is a symlink, then - ;; chase the link and try again there. - ;; - (and (setq path (file-symlink-p path)) - (find-emacs-root-internal-1 (expand-file-name path dir) lisp-p)) - ;; - ;; Otherwise, this directory just doesn't cut it. - ;; Some bozos think they can use the 18.59 lisp directory with 19.*. - ;; This is because they're not using their brains. But it might be - ;; nice to notice that that is happening and point them in the - ;; general direction of a clue. - ;; - nil))) - -(defun find-emacs-root-internal (path) - ;; (send-string-to-terminal (format "FINDING ROOT FOR %S\n" path)) - ;; first look for lisp/prim and lib-src; then just look for lib-src. - ;; XEmacs can run (kind of) if the lisp directory is omitted, which - ;; some people might want to do for space reasons. - (or (find-emacs-root-internal-1 path t) - ;; (find-emacs-root-internal-1 path nil) - ;; If we don't succeed we are going to crash and burn for sure. - ;; Try some paths relative to prefix-directory if it isn't nil. - ;; This is definitely necessary in cases such as when we're used - ;; as a login shell since we can't determine the invocation - ;; directory in that case. - - (find-emacs-root-internal-1 - (format "%s/bin/%s" prefix-directory invocation-name) t) - (find-emacs-root-internal-1 - (format "%s/bin/%s" prefix-directory invocation-name) nil) - (find-emacs-root-internal-1 - (format "%s/lib/%s" prefix-directory invocation-name) t) - (find-emacs-root-internal-1 - (format "%s/lib/%s" prefix-directory invocation-name) nil) - - ;; We're desperate -- try the prefix-directory correctly. - (find-emacs-root-internal-1 - (format "%s/%s/foo" prefix-directory (startup-make-version-dir)) t) - (find-emacs-root-internal-1 - (format "%s/%s/foo" prefix-directory (startup-make-version-dir)) nil) - )) - -(defun set-default-load-path () - ;; XEmacs -- Steven Baur says invocation directory is nil if you - ;; try to use XEmacs as a login shell. - (or invocation-directory (setq invocation-directory default-directory)) - (setq invocation-directory - ;; don't let /tmp_mnt/... get into the load-path or exec-path. - (abbreviate-file-name invocation-directory)) - - ;; #### FSFmacs recognizes environment vars EMACSLOCKDIR, etc. - (let* ((root (find-emacs-root-internal (concat invocation-directory - invocation-name))) - (lisp (and root - (let ((f (expand-file-name "lisp" root))) - (and (file-directory-p f) f)))) - (site-lisp - (and root - (or - (let ((f (expand-file-name "xemacs/site-lisp" root))) - (and (file-directory-p f) f)) - (let ((f (expand-file-name "../xemacs/site-lisp" root))) - (and (file-directory-p f) f)) - ;; the next two are for --run-in-place - (let ((f (expand-file-name "site-lisp" root))) - (and (file-directory-p f) f)) - (let ((f (expand-file-name "lisp/site-lisp" root))) - (and (file-directory-p f) f)) - ))) - (lib-src - (and root - (or - (let ((f (expand-file-name - (concat "lib-src/" system-configuration) - root))) - (and (file-directory-p f) f)) - (let ((f (expand-file-name "lib-src" root))) - (and (file-directory-p f) f)) - (let ((f (expand-file-name system-configuration root))) - (and (file-directory-p f) f))))) - (etc - (and root - (let ((f (expand-file-name "etc" root))) - (and (file-directory-p f) f)))) - (info - (and root - (let ((f (expand-file-name "info" root))) - (and (file-directory-p f) (file-name-as-directory f))))) - (packages - (and root - (let ((f (expand-file-name "packages" root))) - (and (file-directory-p f) (file-name-as-directory f))))) - (lock - (and root - (boundp 'lock-directory) - (if (and lock-directory (file-directory-p lock-directory)) - (file-name-as-directory lock-directory) - (or - (let ((f (expand-file-name "xemacs/lock" root))) - (and (file-directory-p f) - (file-name-as-directory f))) - (let ((f (expand-file-name "../xemacs/lock" root))) - (and (file-directory-p f) - (file-name-as-directory f))) - (let ((f (expand-file-name "lock" root))) - (and (file-directory-p f) - (file-name-as-directory f))) - ;; if none of them exist, make the "guess" be - ;; the one that set-default-load-path-warning - ;; will suggest. - (file-name-as-directory - (expand-file-name "../xemacs/lock" root)) - ))))) - - ;; 1996/12/6 by MORIOKA Tomohiko <morioka@jaist.ac.jp> - ;; define `default-load-path' for file-detect.el - (setq default-load-path load-path) - - ;; add site-lisp dir to load-path - (when site-lisp - ;; If the site-lisp dir isn't on the load-path, add it to the end. - (or (member site-lisp load-path) - (setq load-path (append load-path (list site-lisp)))) - ;; Also add any direct subdirectories of the site-lisp directory - ;; to the load-path. But don't add dirs whose names begin - ;; with dot or hyphen. - (let ((files (directory-files site-lisp nil "^[^-.]" nil 'dirs-only)) - file) - (while files - (setq file (car files)) - (if (and (not (member file '("RCS" "CVS" "SCCS"))) - (setq file (expand-file-name file site-lisp)) - (not (member file load-path))) - (setq load-path - (nconc load-path - (list (file-name-as-directory file))))) - (setq files (cdr files))))) - - ;; add lisp dir to load-path - (when lisp - ;; If the lisp dir isn't on the load-path, add it to the end. - (or (member lisp load-path) - (setq load-path (append load-path (list lisp)))) - ;; Also add any direct subdirectories of the lisp directory - ;; to the load-path. But don't add dirs whose names begin - ;; with dot or hyphen. - (let ((files (directory-files lisp nil "^[^-.]" nil 'dirs-only)) - file) - (while files - (setq file (car files)) - (when (and (not (member file '("RCS" "CVS" "SCCS"))) - (setq file (expand-file-name file lisp)) - (not (member file load-path))) - (setq load-path - (nconc load-path - (list (file-name-as-directory file))))) - (setq files (cdr files))))) - - ;; 1996/12/6 by MORIOKA Tomohiko <morioka@jaist.ac.jp> - ;; define `default-load-path' for file-detect.el - (setq default-load-path - (append default-load-path - (if site-lisp - (list site-lisp)) - (if lisp - (list lisp) - ) - )) - - ;; 1997/03/06 by Jeff Miller <jmiller@bayserve.net> - ;; initialize 'site-directory'. This is the site-lisp dir used by - ;; XEmacs - (if site-lisp - (setq site-directory (file-name-as-directory site-lisp)) - ) - ;; If running from the build directory, always prefer the exec-directory - ;; that is here over to the one that came from paths.h. - (when (or (and (null exec-directory) lib-src) - (and (string= lib-src (expand-file-name "lib-src" root)) - (not (string= exec-directory lib-src)))) - (setq exec-directory (file-name-as-directory lib-src))) - (when (or (and (null doc-directory) lib-src) - (and (string= lib-src (expand-file-name "lib-src" root)) - (not (string= doc-directory lib-src)))) - (setq doc-directory (file-name-as-directory lib-src))) - - (when exec-directory - (or (member exec-directory exec-path) - (setq exec-path (append exec-path (list exec-directory))))) - (when (or (and (null data-directory) etc) - (and (string= etc (expand-file-name "etc" root)) - (not (string= data-directory etc)))) - (setq data-directory (file-name-as-directory etc))) - - ;; If `configure' specified an info dir, use it. - ;; #### The above comment is suspect. - (or (boundp 'Info-default-directory-list) - (setq Info-default-directory-list nil)) - - ;; Add additional system directories. - (setq Info-default-directory-list - (append Info-default-directory-list - (split-string infopath-internal ":"))) - - (let ((infopath (getenv "INFOPATH"))) - (when infopath - (setq Info-default-directory-list - (append Info-default-directory-list - (split-string infopath ":"))))) - - (cond (configure-info-directory - (setq configure-info-directory (file-name-as-directory - configure-info-directory)) - (or (member configure-info-directory Info-default-directory-list) - (setq Info-default-directory-list - (append (list configure-info-directory) - Info-default-directory-list))))) - ;; If we've guessed the info dir, use that (too). - (when (and info (not (member info Info-default-directory-list))) - (setq Info-default-directory-list - (append (list info) Info-default-directory-list))) - - ;; Default the lock dir to being a sibling of the data-directory. - ;; If superlock isn't set, or is set to a file in a nonexistent - ;; directory, derive it from the lock dir. - (when (boundp 'lock-directory) - (setq lock-directory lock) - (cond ((null lock-directory) - (setq superlock-file nil)) - ((or (null superlock-file) - (not (file-directory-p - (file-name-directory superlock-file)))) - (setq superlock-file - (expand-file-name "!!!SuperLock!!!" - lock-directory))))) - - (set-default-load-path-warning) - (when (and data-directory Info-default-directory-list) - (setq data-directory-list (list data-directory)) - (packages-find-packages package-path nil)))) - - -(defun set-default-load-path-warning () - (let ((lock (if (boundp 'lock-directory) lock-directory 't)) - warnings message guess) - (when (and (stringp lock) (not (file-directory-p lock))) - (setq lock nil)) - (cond - ((not (and exec-directory data-directory doc-directory load-path lock)) - (save-excursion - (set-buffer (get-buffer-create " *warning-tmp*")) - (erase-buffer) - (buffer-disable-undo (current-buffer)) - (when (null lock) (push "lock-directory" warnings)) - (when (null exec-directory) (push "exec-directory" warnings)) - (when (null data-directory) (push "data-directory" warnings)) - (when (null doc-directory) (push "doc-directory" warnings)) - (when (null load-path) (push "load-path" warnings)) - (cond ((cdr (cdr warnings)) - (setq message (apply 'format "%s, %s, and %s" warnings))) - ((cdr warnings) - (setq message (apply 'format "%s and %s" warnings))) - (t (setq message (format "variable %s" (car warnings))))) - (insert "couldn't find an obvious default for " message - ", and there were no defaults specified in paths.h when " - "XEmacs was built. Perhaps some directories don't exist, " - "or the XEmacs executable, " (concat invocation-directory - invocation-name) - " is in a strange place?") - (setq guess (or exec-directory - data-directory - doc-directory - (car load-path) - (and (string-match "/[^/]+\\'" invocation-directory) - (substring invocation-directory 0 - (match-beginning 0))))) - (when (and guess - (or - ;; parent of a terminal bin/<configuration> pair (hack hack). - (string-match (concat "/bin/" - (regexp-quote system-configuration) - "/?\\'") - guess) - ;; parent of terminal src, lib-src, etc, or lisp dir. - (string-match - "/\\(bin\\|src\\|lib-src\\|etc\\|lisp\\)[^/]*/?\\'" - guess))) - (setq guess (substring guess 0 (match-beginning 0)))) - - ;; If neither the exec nor lisp dirs are around, then "guess" that - ;; the new configure-style lib dir should be used. Otherwise, if - ;; only one of them appears to be missing, or it's just lock, - ;; then guess it to be a sibling of whatever already exists. - (when (and (null exec-directory) (null load-path)) - (setq guess (expand-file-name (startup-make-version-dir) guess))) - - (when (or (null exec-directory) (null load-path)) - (insert - "\n\nWithout both exec-directory and load-path, XEmacs will " - "be very broken. ")) - (when (and (null exec-directory) guess) - (insert - "Consider making a symbolic link from " - (expand-file-name system-configuration guess) - " to wherever the appropriate XEmacs exec-directory " - "directory is")) - (when (and (null data-directory) guess) - (insert - (if exec-directory - "\n\nConsider making a symbolic link " ", and ") - "from " - (expand-file-name "etc" (if load-path - (file-name-directory - (directory-file-name - (car load-path))) - guess)) - " to wherever the appropriate XEmacs data-directory is")) - (when (and (null load-path) guess) - (insert - (if (and exec-directory data-directory) - "Consider making a symbolic link " - ", and ") - "from " - (expand-file-name "lisp" guess) - " to wherever the appropriate XEmacs lisp library is")) - (insert ".") - - (when (null lock) - (insert - "\n\nWithout lock-directory set, file locking won't work. ") - (when guess - (insert - "Consider creating " - (expand-file-name "../xemacs/lock" - (or (find-emacs-root-internal - (concat invocation-directory - invocation-name)) - guess)) - " as a directory or symbolic link for use as the lock " - "directory. (This directory must be globally writable.)" - ))) - - (when (fboundp 'fill-region) - ;; Might not be bound in the cold load environment... - (let ((fill-column 76)) - (fill-region (point-min) (point-max)))) - (goto-char (point-min)) - (princ "\nWARNING:\n" 'external-debugging-output) - (princ (buffer-string) 'external-debugging-output) - (erase-buffer) - t))))) - -;;; startup.el ends here
--- a/lisp/prim/subr.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,642 +0,0 @@ -;;; subr.el --- basic lisp subroutines for XEmacs - -;;; Copyright (C) 1985, 1986, 1992, 1994, 1995 Free Software Foundation, Inc. -;;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp. -;;; Copyright (C) 1995 Sun Microsystems. - -;; 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.34. - -;;; Commentary: - -;; There's not a whole lot in common now with the FSF version, -;; be wary when applying differences. I've left in a number of lines -;; of commentary just to give diff(1) something to synch itself with to -;; provide useful context diffs. -sb - -;;; Code: - - -;;;; Lisp language features. - -;; Moved to packages.el -;(defmacro lambda (&rest cdr) -; "Return a lambda expression. -;A call of the form (lambda ARGS DOCSTRING INTERACTIVE BODY) is -;self-quoting; the result of evaluating the lambda expression is the -;expression itself. The lambda expression may then be treated as a -;function, i.e., stored as the function value of a symbol, passed to -;funcall or mapcar, etc. - -;ARGS should take the same form as an argument list for a `defun'. -;DOCSTRING is an optional documentation string. -; If present, it should describe how to call the function. -; But documentation strings are usually not useful in nameless functions. -;INTERACTIVE should be a call to the function `interactive', which see. -;It may also be omitted. -;BODY should be a list of lisp expressions." -; ;; Note that this definition should not use backquotes; subr.el should not -; ;; depend on backquote.el. -; ;; #### - I don't see why. So long as backquote.el doesn't use anything -; ;; from subr.el, there's no problem with using backquotes here. --Stig -; ;;(list 'function (cons 'lambda cdr))) -; `(function (lambda ,@cdr))) - -(defmacro defun-when-void (&rest args) - "Define a function, just like `defun', unless it's already defined. -Used for compatibility among different emacs variants." - `(if (fboundp ',(car args)) - nil - (defun ,@args))) - -(defmacro define-function-when-void (&rest args) - "Define a function, just like `define-function', unless it's already defined. -Used for compatibility among different emacs variants." - `(if (fboundp ,(car args)) - nil - (define-function ,@args))) - - -;;;; Keymap support. -;; XEmacs: removed to keymap.el - -;;;; The global keymap tree. - -;;; global-map, esc-map, and ctl-x-map have their values set up in -;;; keymap.c; we just give them docstrings here. - -;;;; Event manipulation functions. - -;; The call to `read' is to ensure that the value is computed at load time -;; and not compiled into the .elc file. The value is negative on most -;; machines, but not on all! -(defconst listify-key-sequence-1 (logior 128 (read "?\\M-\\^@"))) - -(defun listify-key-sequence (key) - "Convert a key sequence to a list of events." - (if (vectorp key) - (append key nil) - (mapcar (function (lambda (c) - (if (> c 127) - (logxor c listify-key-sequence-1) - c))) - (append key nil)))) -;; XEmacs: This stuff is done in C Code. - -;;;; Obsolescent names for functions. -;; 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 -can be used to determine whether `make-variable-buffer-local' has been -called on SYM." - (local-variable-p sym buffer t)) - - -;;;; Hook manipulation functions. - -;; (defconst run-hooks 'run-hooks ...) - -(defun make-local-hook (hook) - "Make the hook HOOK local to the current buffer. -When a hook is local, its local and global values -work in concert: running the hook actually runs all the hook -functions listed in *either* the local value *or* the global value -of the hook variable. - -This function works by making `t' a member of the buffer-local value, -which acts as a flag to run the hook functions in the default value as -well. This works for all normal hooks, but does not work for most -non-normal hooks yet. We will be changing the callers of non-normal -hooks so that they can handle localness; this has to be done one by -one. - -This function does nothing if HOOK is already local in the current -buffer. - -Do not use `make-local-variable' to make a hook variable buffer-local." - (if (local-variable-p hook (current-buffer)) ; XEmacs - nil - (or (boundp hook) (set hook nil)) - (make-local-variable hook) - (set hook (list t)))) - -(defun add-hook (hook function &optional append local) - "Add to the value of HOOK the function FUNCTION. -FUNCTION is not added if already present. -FUNCTION is added (if necessary) at the beginning of the hook list -unless the optional argument APPEND is non-nil, in which case -FUNCTION is added at the end. - -The optional fourth argument, LOCAL, if non-nil, says to modify -the hook's buffer-local value rather than its default value. -This makes no difference if the hook is not buffer-local. -To make a hook variable buffer-local, always use -`make-local-hook', not `make-local-variable'. - -HOOK should be a symbol, and FUNCTION may be any valid function. If -HOOK is void, it is first set to nil. If HOOK's value is a single -function, it is changed to a list of functions." - (or (boundp hook) (set hook nil)) - (or (default-boundp hook) (set-default hook nil)) - ;; If the hook value is a single function, turn it into a list. - (let ((old (symbol-value hook))) - (if (or (not (listp old)) (eq (car old) 'lambda)) - (set hook (list old)))) - (if (or local - ;; Detect the case where make-local-variable was used on a hook - ;; and do what we used to do. - (and (local-variable-if-set-p hook (current-buffer)) ; XEmacs - (not (memq t (symbol-value hook))))) - ;; Alter the local value only. - (or (if (consp function) - (member function (symbol-value hook)) - (memq function (symbol-value hook))) - (set hook - (if append - (append (symbol-value hook) (list function)) - (cons function (symbol-value hook))))) - ;; Alter the global value (which is also the only value, - ;; if the hook doesn't have a local value). - (or (if (consp function) - (member function (default-value hook)) - (memq function (default-value hook))) - (set-default hook - (if append - (append (default-value hook) (list function)) - (cons function (default-value hook))))))) - -(defun remove-hook (hook function &optional local) - "Remove from the value of HOOK the function FUNCTION. -HOOK should be a symbol, and FUNCTION may be any valid function. If -FUNCTION isn't the value of HOOK, or, if FUNCTION doesn't appear in the -list of hooks to run in HOOK, then nothing is done. See `add-hook'. - -The optional third argument, LOCAL, if non-nil, says to modify -the hook's buffer-local value rather than its default value. -This makes no difference if the hook is not buffer-local. -To make a hook variable buffer-local, always use -`make-local-hook', not `make-local-variable'." - (if (or (not (boundp hook)) ;unbound symbol, or - (not (default-boundp 'hook)) - (null (symbol-value hook)) ;value is nil, or - (null function)) ;function is nil, then - nil ;Do nothing. - (if (or local - ;; Detect the case where make-local-variable was used on a hook - ;; and do what we used to do. - (and (local-variable-p hook (current-buffer)) - (not (memq t (symbol-value hook))))) - (let ((hook-value (symbol-value hook))) - (if (consp hook-value) - (if (member function hook-value) - (setq hook-value (delete function (copy-sequence hook-value)))) - (if (equal hook-value function) - (setq hook-value nil))) - (set hook hook-value)) - (let ((hook-value (default-value hook))) - (if (consp hook-value) - (if (member function hook-value) - (setq hook-value (delete function (copy-sequence hook-value)))) - (if (equal hook-value function) - (setq hook-value nil))) - (set-default hook hook-value))))) - -(defun add-to-list (list-var element) - "Add to the value of LIST-VAR the element ELEMENT if it isn't there yet. -The test for presence of ELEMENT is done with `equal'. -If you want to use `add-to-list' on a variable that is not defined -until a certain package is loaded, you should put the call to `add-to-list' -into a hook function that will be run only after loading the package. -`eval-after-load' provides one way to do this. In some cases -other hooks, such as major mode hooks, can do the job." - (or (member element (symbol-value list-var)) - (set list-var (cons element (symbol-value list-var))))) - -;; XEmacs additions -;; called by Fkill_buffer() -(defvar kill-buffer-hook nil - "Function or functions to be called when a buffer is killed. -The value of this variable may be buffer-local. -The buffer about to be killed is current when this hook is run.") - -;; in C in FSFmacs -(defvar kill-emacs-hook nil - "Function or functions to be called when `kill-emacs' is called, -just before emacs is actually killed.") - -;; not obsolete. -(define-function 'rplaca 'setcar) -(define-function 'rplacd 'setcdr) - -;;;; String functions. - -;; XEmacs -(defun replace-in-string (str regexp newtext &optional literal) - "Replaces all matches in STR for REGEXP with NEWTEXT string. -Optional LITERAL non-nil means do a literal replacement. -Otherwise treat \\ in NEWTEXT string as special: - \\& means substitute original matched text, - \\N means substitute match for \(...\) number N, - \\\\ means insert one \\." - (if (not (stringp str)) - (error "(replace-in-string): First argument must be a string: %s" str)) - (if (stringp newtext) - nil - (error "(replace-in-string): 3rd arg must be a string: %s" - newtext)) - (let ((rtn-str "") - (start 0) - (special) - match prev-start) - (while (setq match (string-match regexp str start)) - (setq prev-start start - start (match-end 0) - rtn-str - (concat - rtn-str - (substring str prev-start match) - (cond (literal newtext) - (t (mapconcat - (function - (lambda (c) - (if special - (progn - (setq special nil) - (cond ((eq c ?\\) "\\") - ((eq c ?&) - (substring str - (match-beginning 0) - (match-end 0))) - ((and (>= c ?0) (<= c ?9)) - (if (> c (+ ?0 (length - (match-data)))) - ;; Invalid match num - (error "(replace-in-string) Invalid match num: %c" c) - (setq c (- c ?0)) - (substring str - (match-beginning c) - (match-end c)))) - (t (char-to-string c)))) - (if (eq c ?\\) (progn (setq special t) nil) - (char-to-string c))))) - newtext "")))))) - (concat rtn-str (substring str start)))) - -(defun split-string (string &optional pattern) - "Return a list of substrings of STRING which are separated by PATTERN." - (or pattern - (setq pattern "[ \f\t\n\r\v]+")) - (let (parts (start 0)) - (while (string-match pattern string start) - (setq parts (cons (substring string start (match-beginning 0)) parts) - start (match-end 0))) - (nreverse (cons (substring string start) parts)) - )) - -(defmacro with-output-to-string (&rest forms) - "Collect output to `standard-output' while evaluating FORMS and return -it as a string." - ;; by "William G. Dubuque" <wgd@zurich.ai.mit.edu> w/ mods from Stig - (` (with-current-buffer (get-buffer-create " *string-output*") - (setq buffer-read-only nil) - (buffer-disable-undo (current-buffer)) - (erase-buffer) - (let ((standard-output (current-buffer))) - (,@ forms)) - (prog1 - (buffer-string) - (erase-buffer))))) - -(defmacro with-current-buffer (buffer &rest body) - "Execute the forms in BODY with BUFFER as the current buffer. -The value returned is the value of the last form in BODY. -See also `with-temp-buffer'." - `(save-current-buffer - (set-buffer ,buffer) - ,@body)) - -(defmacro with-temp-file (file &rest forms) - "Create a new buffer, evaluate FORMS there, and write the buffer to FILE. -The value of the last form in FORMS is returned, like `progn'. -See also `with-temp-buffer'." - (let ((temp-file (make-symbol "temp-file")) - (temp-buffer (make-symbol "temp-buffer"))) - `(let ((,temp-file ,file) - (,temp-buffer - (get-buffer-create (generate-new-buffer-name " *temp file*")))) - (unwind-protect - (prog1 - (with-current-buffer ,temp-buffer - ,@forms) - (with-current-buffer ,temp-buffer - (widen) - (write-region (point-min) (point-max) ,temp-file nil 0))) - (and (buffer-name ,temp-buffer) - (kill-buffer ,temp-buffer)))))) - -(defmacro with-temp-buffer (&rest forms) - "Create a temporary buffer, and evaluate FORMS there like `progn'." - (let ((temp-buffer (make-symbol "temp-buffer"))) - `(let ((,temp-buffer - (get-buffer-create (generate-new-buffer-name " *temp*")))) - (unwind-protect - (with-current-buffer ,temp-buffer - ,@forms) - (and (buffer-name ,temp-buffer) - (kill-buffer ,temp-buffer)))))) - -;; Moved from mule-coding.el. -(defmacro with-string-as-buffer-contents (str &rest body) - "With the contents of the current buffer being STR, run BODY. -Returns the new contents of the buffer, as modified by BODY. -The original current buffer is restored afterwards." - `(let ((tempbuf (get-buffer-create " *string-as-buffer-contents*"))) - (with-current-buffer tempbuf - (unwind-protect - (progn - (buffer-disable-undo (current-buffer)) - (erase-buffer) - (insert ,str) - ,@body - (buffer-string)) - (erase-buffer tempbuf))))) - -(defun insert-face (string face) - "Insert STRING and highlight with FACE. Returns the extent created." - (let ((p (point)) ext) - (insert string) - (setq ext (make-extent p (point))) - (set-extent-face ext face) - ext)) - -;; not obsolete. -(define-function 'string= 'string-equal) -(define-function 'string< 'string-lessp) -(define-function 'int-to-string 'number-to-string) -(define-function 'string-to-int 'string-to-number) - -;; These two names are a bit awkward, as they conflict with the normal -;; foo-to-bar naming scheme, but CLtL2 has them, so they stay. -(define-function 'char-int 'char-to-int) -(define-function 'int-char 'int-to-char) - - -;; alist/plist functions -(defun plist-to-alist (plist) - "Convert property list PLIST into the equivalent association-list form. -The alist is returned. This converts from - -\(a 1 b 2 c 3) - -into - -\((a . 1) (b . 2) (c . 3)) - -The original plist is not modified. See also `destructive-plist-to-alist'." - (let (alist) - (while plist - (setq alist (cons (cons (car plist) (cadr plist)) alist)) - (setq plist (cddr plist))) - (nreverse alist))) - -(defun destructive-plist-to-alist (plist) - "Convert property list PLIST into the equivalent association-list form. -The alist is returned. This converts from - -\(a 1 b 2 c 3) - -into - -\((a . 1) (b . 2) (c . 3)) - -The original plist is destroyed in the process of constructing the alist. -See also `plist-to-alist'." - (let ((head plist) - next) - (while plist - ;; remember the next plist pair. - (setq next (cddr plist)) - ;; make the cons holding the property value into the alist element. - (setcdr (cdr plist) (cadr plist)) - (setcar (cdr plist) (car plist)) - ;; reattach into alist form. - (setcar plist (cdr plist)) - (setcdr plist next) - (setq plist next)) - head)) - -(defun alist-to-plist (alist) - "Convert association list ALIST into the equivalent property-list form. -The plist is returned. This converts from - -\((a . 1) (b . 2) (c . 3)) - -into - -\(a 1 b 2 c 3) - -The original alist is not modified. See also `destructive-alist-to-plist'." - (let (plist) - (while alist - (let ((el (car alist))) - (setq plist (cons (cdr el) (cons (car el) plist)))) - (setq alist (cdr alist))) - (nreverse plist))) - -;; getf, remf in cl*.el. - -(defmacro putf (plist prop val) - "Add property PROP to plist PLIST with value VAL. -Analogous to (setq PLIST (plist-put PLIST PROP VAL))." - `(setq ,plist (plist-put ,plist ,prop ,val))) - -(defmacro laxputf (lax-plist prop val) - "Add property PROP to lax plist LAX-PLIST with value VAL. -Analogous to (setq LAX-PLIST (lax-plist-put LAX-PLIST PROP VAL))." - `(setq ,lax-plist (lax-plist-put ,lax-plist ,prop ,val))) - -(defmacro laxremf (lax-plist prop) - "Remove property PROP from lax plist LAX-PLIST. -Analogous to (setq LAX-PLIST (lax-plist-remprop LAX-PLIST PROP))." - `(setq ,lax-plist (lax-plist-remprop ,lax-plist ,prop))) - -;;; Error functions - -(defun error (&rest args) - "Signal an error, making error message by passing all args to `format'. -This error is not continuable: you cannot continue execution after the -error using the debugger `r' command. See also `cerror'." - (while t - (apply 'cerror args))) - -(defun cerror (&rest args) - "Like `error' but signals a continuable error." - (signal 'error (list (apply 'format args)))) - -(defmacro check-argument-type (predicate argument) - "Check that ARGUMENT satisfies PREDICATE. -If not, signal a continuable `wrong-type-argument' error until the -returned value satisfies PREDICATE, and assign the returned value -to ARGUMENT." - `(if (not (,(eval predicate) ,argument)) - (setq ,argument - (wrong-type-argument ,predicate ,argument)))) - -(defun signal-error (error-symbol data) - "Signal a non-continuable error. Args are ERROR-SYMBOL, and associated DATA. -An error symbol is a symbol defined using `define-error'. -DATA should be a list. Its elements are printed as part of the error message. -If the signal is handled, DATA is made available to the handler. -See also `signal', and the functions to handle errors: `condition-case' -and `call-with-condition-handler'." - (while t - (signal error-symbol data))) - -(defun define-error (error-sym doc-string &optional inherits-from) - "Define a new error, denoted by ERROR-SYM. -DOC-STRING is an informative message explaining the error, and will be -printed out when an unhandled error occurs. -ERROR-SYM is a sub-error of INHERITS-FROM (which defaults to `error'). - -\[`define-error' internally works by putting on ERROR-SYM an `error-message' -property whose value is DOC-STRING, and an `error-conditions' property -that is a list of ERROR-SYM followed by each of its super-errors, up -to and including `error'. You will sometimes see code that sets this up -directly rather than calling `define-error', but you should *not* do this -yourself.]" - (check-argument-type 'symbolp error-sym) - (check-argument-type 'stringp doc-string) - (put error-sym 'error-message doc-string) - (or inherits-from (setq inherits-from 'error)) - (let ((conds (get inherits-from 'error-conditions))) - (or conds (signal-error 'error (list "Not an error symbol" error-sym))) - (put error-sym 'error-conditions (cons error-sym conds)))) - -;;;; Miscellanea. - -(defun buffer-substring-no-properties (beg end) - "Return the text from BEG to END, without text properties, as a string." - (let ((string (buffer-substring beg end))) - (set-text-properties 0 (length string) nil string) - string)) - -;; This should probably be written in C (i.e., without using `walk-windows'). -(defun get-buffer-window-list (buffer &optional minibuf frame) - "Return windows currently displaying BUFFER, or nil if none. -See `walk-windows' for the meaning of MINIBUF and FRAME." - (let ((buffer (if (bufferp buffer) buffer (get-buffer buffer))) windows) - (walk-windows (function (lambda (window) - (if (eq (window-buffer window) buffer) - (setq windows (cons window windows))))) - minibuf frame) - windows)) - -(defun ignore (&rest ignore) - "Do nothing and return nil. -This function accepts any number of arguments, but ignores them." - (interactive) - nil) - -(define-function 'mapc-internal 'mapc) -(make-obsolete 'mapc-internal 'mapc) - -(define-function 'eval-in-buffer 'with-current-buffer) -(make-obsolete 'eval-in-buffer 'with-current-buffer) - -;;; The real defn is in abbrev.el but some early callers -;;; (eg lisp-mode-abbrev-table) want this before abbrev.el is loaded... - -(if (not (fboundp 'define-abbrev-table)) - (progn - (setq abbrev-table-name-list '()) - (fset 'define-abbrev-table (function (lambda (name defs) - ;; These are fixed-up when abbrev.el loads. - (setq abbrev-table-name-list - (cons (cons name defs) - abbrev-table-name-list))))))) - -(defun functionp (obj) - "Non-nil if OBJECT is a type of object that can be called as a function." - (cond - ((symbolp obj) (fboundp obj)) - ((subrp obj)) - ((compiled-function-p obj)) - ((consp obj) - (if (eq (car obj) 'lambda) (listp (car (cdr obj))))) - (t nil))) - -;; This was not present before. I think Jamie had some objections -;; to this, so I'm leaving this undefined for now. --ben - -;;; The objection is this: there is more than one way to load the same file. -;;; "foo", "foo.elc", "foo.el", and "/some/path/foo.elc" are all different -;;; ways to load the exact same code. `eval-after-load' is too stupid to -;;; deal with this sort of thing. If this sort of feature is desired, then -;;; it should work off of a hook on `provide'. Features are unique and -;;; the arguments to (load) are not. --Stig - -;;;; Specifying things to do after certain files are loaded. - -(defun eval-after-load (file form) - "Arrange that, if FILE is ever loaded, FORM will be run at that time. -This makes or adds to an entry on `after-load-alist'. -If FILE is already loaded, evaluate FORM right now. -It does nothing if FORM is already on the list for FILE. -FILE should be the name of a library, with no directory name." - ;; Make sure there is an element for FILE. - (or (assoc file after-load-alist) - (setq after-load-alist (cons (list file) after-load-alist))) - ;; Add FORM to the element if it isn't there. - (let ((elt (assoc file after-load-alist))) - (or (member form (cdr elt)) - (progn - (nconc elt (list form)) - ;; If the file has been loaded already, run FORM right away. - (and (assoc file load-history) - (eval form))))) - form) -(make-compatible 'eval-after-load "") - -(defun eval-next-after-load (file) - "Read the following input sexp, and run it whenever FILE is loaded. -This makes or adds to an entry on `after-load-alist'. -FILE should be the name of a library, with no directory name." - (eval-after-load file (read))) -(make-compatible 'eval-next-after-load "") - -; alternate names (not obsolete) -(if (not (fboundp 'mod)) (define-function 'mod '%)) -(define-function 'move-marker 'set-marker) -(define-function 'beep 'ding) ; preserve lingual purity -(define-function 'indent-to-column 'indent-to) -(define-function 'backward-delete-char 'delete-backward-char) -(define-function 'search-forward-regexp (symbol-function 're-search-forward)) -(define-function 'search-backward-regexp (symbol-function 're-search-backward)) -(define-function 'remove-directory 'delete-directory) -(define-function 'set-match-data 'store-match-data) -(define-function 'send-string-to-terminal 'external-debugging-output) -(define-function 'buffer-string 'buffer-substring) - -;;; subr.el ends here
--- a/lisp/prim/syntax.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,408 +0,0 @@ -;; Syntax-table hacking stuff, moved from syntax.c -;; Copyright (C) 1993 Free Software Foundation, Inc. -;; Copyright (C) 1995 Sun Microsystems. - -;; 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, 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: FSF 19.28. -;;; Note: FSF does not have a file syntax.el. This stuff is -;;; in syntax.c. See comments there about not merging past 19.28. - -;; Significantly hacked upon by Ben Wing. - -(defun make-syntax-table (&optional oldtable) - "Return a new syntax table. -It inherits all characters from the standard syntax table." - (make-char-table 'syntax)) - -(defun simple-set-syntax-entry (char spec table) - (put-char-table char spec table)) - -(defun char-syntax-from-code (code) - "Extract the syntax designator from the internal syntax code CODE. -CODE is the value actually contained in the syntax table." - (if (consp code) - (setq code (car code))) - (aref (syntax-designator-chars) (logand code 127))) - -(defun set-char-syntax-in-code (code desig) - "Return a new internal syntax code whose syntax designator is DESIG. -Other characteristics are the same as in CODE." - (let ((newcode (if (consp code) (car code) code))) - (setq newcode (logior (string-match - (regexp-quote (char-to-string desig)) - (syntax-designator-chars)) - (logand newcode (lognot 127)))) - (if (consp code) (cons newcode (cdr code)) - newcode))) - -(defun syntax-code-to-string (code) - "Return a string equivalent to internal syntax code CODE. -The string can be passed to `modify-syntax-entry'. -If CODE is invalid, return nil." - (let ((match (and (consp code) (cdr code))) - (codes (syntax-designator-chars))) - (if (consp code) - (setq code (car code))) - (if (or (not (integerp code)) - (> (logand code 127) (length codes))) - nil - (with-output-to-string - (let* ((spec (elt codes (logand code 127))) - (b3 (lsh code -16)) - (start1 (/= 0 (logand b3 128))) ;logtest! - (start1b (/= 0 (logand b3 64))) - (start2 (/= 0 (logand b3 32))) - (start2b (/= 0 (logand b3 16))) - (end1 (/= 0 (logand b3 8))) - (end1b (/= 0 (logand b3 4))) - (end2 (/= 0 (logand b3 2))) - (end2b (/= 0 (logand b3 1))) - (prefix (/= 0 (logand code 128))) - (single-char-p (or (= spec ?<) (= spec ?>))) - ) - (write-char spec) - (write-char (if match match 32)) -;;; (if start1 (if single-char-p (write-char ?a) (write-char ?1))) - (if start1 (if single-char-p (write-char ? ) (write-char ?1))) - (if start2 (write-char ?2)) -;;; (if end1 (if single-char-p (write-char ?a) (write-char ?3))) - (if end1 (if single-char-p (write-char ? ) (write-char ?3))) - (if end2 (write-char ?4)) - (if start1b (if single-char-p (write-char ?b) (write-char ?5))) - (if start2b (write-char ?6)) - (if end1b (if single-char-p (write-char ?b) (write-char ?7))) - (if end2b (write-char ?8)) - (if prefix (write-char ?p))))))) - -(defun syntax-string-to-code (string) - "Return the internal syntax code equivalent to STRING. -STRING should be something acceptable as the second argument to -`modify-syntax-entry'. -If STRING is invalid, signal an error." - (let* ((bflag nil) - (b3 0) - (ch0 (aref string 0)) - (len (length string)) - (code (string-match (regexp-quote (char-to-string ch0)) - (syntax-designator-chars))) - (i 2) - ch) - (or code - (error "Invalid syntax designator: %S" string)) - (while (< i len) - (setq ch (aref string i)) - (incf i) - (case ch - (?1 (setq b3 (logior b3 128))) - (?2 (setq b3 (logior b3 32))) - (?3 (setq b3 (logior b3 8))) - (?4 (setq b3 (logior b3 2))) - (?5 (setq b3 (logior b3 64))) - (?6 (setq b3 (logior b3 16))) - (?7 (setq b3 (logior b3 4))) - (?8 (setq b3 (logior b3 1))) - (?a (case ch0 - (?< (setq b3 (logior b3 128))) - (?> (setq b3 (logior b3 8))))) - (?b (case ch0 - (?< (setq b3 (logior b3 64) bflag t)) - (?> (setq b3 (logior b3 4) bflag t)))) - (?p (setq code (logior code (lsh 1 7)))) - (?\ nil) ;; ignore for compatibility - (otherwise - (error "Invalid syntax description flag: %S" string)))) - ;; default single char style if `b' has not been seen - (if (not bflag) - (case ch0 - (?< (setq b3 (logior b3 128))) - (?> (setq b3 (logior b3 8))))) - (setq code (logior code (lsh b3 16))) - (if (and (> len 1) - ;; tough luck if you want to make space a paren! - (/= (aref string 1) ?\ )) - (setq code (cons code (aref string 1)))) - code)) - -(defun modify-syntax-entry (char-range spec &optional table) - "Set syntax for the characters CHAR-RANGE according to string SPEC. -CHAR-RANGE is a single character or a range of characters, - as per `put-char-table'. -The syntax is changed only for table TABLE, which defaults to - the current buffer's syntax table. -The first character of SPEC should be one of the following: - Space whitespace syntax. w word constituent. - _ symbol constituent. . punctuation. - \( open-parenthesis. \) close-parenthesis. - \" string quote. \\ character-quote. - $ paired delimiter. ' expression quote or prefix operator. - < comment starter. > comment ender. - / character-quote. @ inherit from `standard-syntax-table'. - -Only single-character comment start and end sequences are represented thus. -Two-character sequences are represented as described below. -The second character of SPEC is the matching parenthesis, - used only if the first character is `(' or `)'. -Any additional characters are flags. -Defined flags are the characters 1, 2, 3, 4, 5, 6, 7, 8, p, a, and b. - 1 means C is the first of a two-char comment start sequence of style a. - 2 means C is the second character of such a sequence. - 3 means C is the first of a two-char comment end sequence of style a. - 4 means C is the second character of such a sequence. - 5 means C is the first of a two-char comment start sequence of style b. - 6 means C is the second character of such a sequence. - 7 means C is the first of a two-char comment end sequence of style b. - 8 means C is the second character of such a sequence. - p means C is a prefix character for `backward-prefix-chars'; - such characters are treated as whitespace when they occur - between expressions. - a means C is comment starter or comment ender for comment style a (default) - 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 - "cSet syntax for character: \nsSet syntax for %c to: ") - (cond ((syntax-table-p table)) - ((not table) - (setq table (syntax-table))) - (t - (setq table - (wrong-type-argument 'syntax-table-p table)))) - (let ((code (syntax-string-to-code spec))) - (simple-set-syntax-entry char-range code table)) - nil) - -(defun map-syntax-table (__function __table &optional __range) - "Map FUNCTION over entries in syntax table TABLE, collapsing inheritance. -This is similar to `map-char-table', but works only on syntax tables, and - collapses any entries that call for inheritance by invisibly substituting - the inherited values from the standard syntax table." - (check-argument-type 'syntax-table-p __table) - (map-char-table #'(lambda (__key __value) - (if (eq ?@ (char-syntax-from-code __value)) - (map-char-table #'(lambda (__key __value) - (funcall __function - __key __value)) - (standard-syntax-table) - __key) - (funcall __function __key __value))) - __table __range)) - -;(defun test-xm () -; (let ((o (copy-syntax-table)) -; (n (copy-syntax-table)) -; (codes (syntax-designator-chars)) -; (flags "12345678abp")) -; (while t -; (let ((spec (concat (char-to-string (elt codes -; (random (length codes)))))) -; (if (= (random 4) 0) -; "b" -; " ") -; (let* ((n (random 4)) -; (s (make-string n 0))) -; (while (> n 0) -; (setq n (1- n)) -; (aset s n (aref flags (random (length flags))))) -; s)))) -; (message "%S..." spec) -; (modify-syntax-entry ?a spec o) -; (xmodify-syntax-entry ?a spec n) -; (or (= (aref o ?a) (aref n ?a)) -; (error "%s" -; (format "fucked with %S: %x %x" -; spec (aref o ?a) (aref n ?a)))))))) - - -(defun describe-syntax-table (table stream) - (let (first-char - last-char - prev-val - (describe-one - (if (featurep 'mule) - #'(lambda (first last value stream) - (if (equal first last) - (cond ((vectorp first) - (princ (format "%s, row %d\t" - (charset-name - (aref first 0)) - (aref first 1)) - stream)) - ((symbolp first) - (princ first stream) - (princ "\t" stream)) - (t - (princ (text-char-description first) stream) - (princ "\t" stream))) - (cond ((vectorp first) - (princ (format "%s, rows %d .. %d\t" - (charset-name - (aref first 0)) - (aref first 1) - (aref last 1)) - stream)) - ((symbolp first) - (princ (format "%s .. %s\t" first last) stream)) - (t - (princ (format "%s .. %s\t" - (text-char-description first) - (text-char-description last)) - stream)))) - (describe-syntax-code value stream)) - #'(lambda (first last value stream) - (let* ((tem (text-char-description first)) - (pos (length tem)) - ;;(limit (cond ((numberp ctl-arrow) ctl-arrow) - ;; ((memq ctl-arrow '(t nil)) 256) - ;; (t 160))) - ) - (princ tem stream) - (if (> last first) - (progn - (princ " .. " stream) - (setq tem (text-char-description last)) - (princ tem stream) - (setq pos (+ pos (length tem) 4)))) - (while (progn (write-char ?\ stream) - (setq pos (1+ pos)) - (< pos 16)))) - (describe-syntax-code value stream))))) - (map-syntax-table - #'(lambda (range value) - (cond - ((not first-char) - (setq first-char range - last-char range - prev-val value)) - ((and (equal value prev-val) - (or - (and (characterp range) - (characterp first-char) - (or (not (featurep 'mule)) - (eq (char-charset range) - (char-charset first-char))) - (= (char-int last-char) (1- (char-int range)))) - (and (vectorp range) - (vectorp first-char) - (eq (aref range 0) (aref first-char 0)) - (= (aref last-char 1) (1- (aref range 1)))))) - (setq last-char range)) - (t - (funcall describe-one first-char last-char prev-val stream) - (setq first-char range - last-char range - prev-val value))) - nil) - table) - (if first-char - (funcall describe-one first-char last-char prev-val stream)))) - -(defun describe-syntax-code (code stream) - (let ((match (and (consp code) (cdr code))) - (invalid (gettext "**invalid**")) ;(empty "") ;constants - (standard-output (or stream standard-output)) - ;; #### I18N3 should temporarily set buffer to output-translatable - (in #'(lambda (string) - (princ ",\n\t\t\t\t ") - (princ string))) - (syntax-string (syntax-code-to-string code))) - (if (consp code) - (setq code (car code))) - (if (null syntax-string) - (princ invalid) - (princ syntax-string) - (princ "\tmeaning: ") - (princ (aref ["whitespace" "punctuation" "word-constituent" - "symbol-constituent" "open-paren" "close-paren" - "expression-prefix" "string-quote" "paired-delimiter" - "escape" "character-quote" "comment-begin" "comment-end" - "inherit" "extended-word-constituent"] - (logand code 127))) - - (if match - (progn - (princ ", matches ") - (princ (text-char-description match)))) - (let* ((spec (elt syntax-string 0)) - (b3 (lsh code -16)) - (start1 (/= 0 (logand b3 128))) ;logtest! - (start1b (/= 0 (logand b3 64))) - (start2 (/= 0 (logand b3 32))) - (start2b (/= 0 (logand b3 16))) - (end1 (/= 0 (logand b3 8))) - (end1b (/= 0 (logand b3 4))) - (end2 (/= 0 (logand b3 2))) - (end2b (/= 0 (logand b3 1))) - (prefix (/= 0 (logand code 128))) - (single-char-p (or (= spec ?<) (= spec ?>)))) - (if start1 - (if single-char-p - (princ ", style A") - (funcall in - (gettext "first character of comment-start sequence A")))) - (if start2 - (funcall in - (gettext "second character of comment-start sequence A"))) - (if end1 - (if single-char-p - (princ ", style A") - (funcall in - (gettext "first character of comment-end sequence A")))) - (if end2 - (funcall in - (gettext "second character of comment-end sequence A"))) - (if start1b - (if single-char-p - (princ ", style B") - (funcall in - (gettext "first character of comment-start sequence B")))) - (if start2b - (funcall in - (gettext "second character of comment-start sequence B"))) - (if end1b - (if single-char-p - (princ ", style B") - (funcall in - (gettext "first character of comment-end sequence B")))) - (if end2b - (funcall in - (gettext "second character of comment-end sequence B"))) - (if prefix - (funcall in - (gettext "prefix character for `backward-prefix-chars'")))) - (terpri stream)))) - -(defun symbol-near-point () - "Return the first textual item to the nearest point." - (interactive) - ;alg stolen from etag.el - (save-excursion - (if (or (bobp) (not (memq (char-syntax (char-before)) '(?w ?_)))) - (while (not (looking-at "\\sw\\|\\s_\\|\\'")) - (forward-char 1))) - (while (looking-at "\\sw\\|\\s_") - (forward-char 1)) - (if (re-search-backward "\\sw\\|\\s_" nil t) - (regexp-quote - (progn (forward-char 1) - (buffer-substring (point) - (progn (forward-sexp -1) - (while (looking-at "\\s'") - (forward-char 1)) - (point))))) - nil)))
--- a/lisp/prim/toolbar.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,163 +0,0 @@ -;;; toolbar.el --- Toolbar support for XEmacs - -;; Copyright (C) 1995, 1997 Free Software Foundation, Inc. - -;; Maintainer: XEmacs Development Team -;; Keywords: extensions, internal - -;; 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, 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: Not in FSF. - -;;; Commentary: - -;;; Code: - -(defvar toolbar-help-enabled t - "If non-nil help is echoed for toolbar buttons.") - -(defvar toolbar-icon-directory nil - "Location of standard toolbar icon bitmaps.") - -(defun toolbar-make-button-list (up &optional down disabled cap-up cap-down cap-disabled) - "Calls make-glyph on each arg and returns a list of the results." - (if (featurep 'x) - (let ((up-glyph (make-glyph up)) - (down-glyph (and down (make-glyph down))) - (disabled-glyph (and disabled (make-glyph disabled))) - (cap-up-glyph (and cap-up (make-glyph cap-up))) - (cap-down-glyph (and cap-down (make-glyph cap-down))) - (cap-disabled-glyph (and cap-disabled (make-glyph cap-disabled)))) - (if cap-disabled - (list up-glyph down-glyph disabled-glyph - cap-up-glyph cap-down-glyph cap-disabled-glyph) - (if cap-down - (list up-glyph down-glyph disabled-glyph - cap-up-glyph cap-down-glyph) - (if cap-up - (list up-glyph down-glyph disabled-glyph cap-up-glyph) - (if disabled-glyph - (list up-glyph down-glyph disabled-glyph) - (if down-glyph - (list up-glyph down-glyph) - (list up-glyph))))))) - nil)) - -(defun init-toolbar-location () - (if (not toolbar-icon-directory) - (setq toolbar-icon-directory - (file-name-as-directory - (expand-file-name "toolbar" data-directory))))) - -(defun init-toolbar-from-resources (locale) - (if (and (featurep 'x) - (or (eq locale 'global) - (eq 'x (device-or-frame-type locale))) - (x-init-toolbar-from-resources locale)))) - - -;; #### Is this actually needed or will the code in -;; default-mouse-motion-handler suffice? -(define-key global-map 'button1up 'release-toolbar-button) - -(defvar toolbar-map (let ((m (make-sparse-keymap))) - (set-keymap-name m 'toolbar-map) - m) - "Keymap consulted for mouse-clicks over a toolbar.") - -(define-key toolbar-map 'button1 'press-toolbar-button) -(define-key toolbar-map 'button1up 'release-and-activate-toolbar-button) -(defvar last-pressed-toolbar-button nil) -(defvar toolbar-active nil) - -;; -;; It really sucks that we also have to tie onto -;; default-mouse-motion-handler to make sliding buttons work right. -;; -(defun press-toolbar-button (event) - "Press a toolbar button. This only changes its appearance. -Call function stored in `toolbar-blank-press-function,' if any, with EVENT as -an argument if press is over a blank area of the toolbar." - (interactive "_e") - (setq this-command last-command) - (let ((button (event-toolbar-button event))) - ;; We silently ignore non-buttons. This most likely means we are - ;; over a blank part of the toolbar. - (setq toolbar-active t) - (if (toolbar-button-p button) - (progn - (set-toolbar-button-down-flag button t) - (setq last-pressed-toolbar-button button)) - ;; Added by Bob Weiner, Motorola Inc., 10/6/95, to handle - ;; presses on blank portions of toolbars. - (and (boundp 'toolbar-blank-press-function) - (functionp toolbar-blank-press-function) - (funcall toolbar-blank-press-function event))))) - -(defun release-and-activate-toolbar-button (event) - "Release a toolbar button and activate its callback. -Call function stored in `toolbar-blank-release-function,' if any, with EVENT -as an argument if release is over a blank area of the toolbar." - (interactive "_e") - (or (button-release-event-p event) - (error "%s must be invoked by a mouse-release" this-command)) - (release-toolbar-button event) - (let ((button (event-toolbar-button event))) - (if (and (toolbar-button-p button) - (toolbar-button-enabled-p button) - (toolbar-button-callback button)) - (let ((callback (toolbar-button-callback button))) - (setq this-command callback) - ;; Handle arbitrary functions. - (if (functionp callback) - (if (commandp callback) - (call-interactively callback) - (funcall callback)) - (eval callback)))))) - -;; If current is not t, then only release the toolbar button stored in -;; last-pressed-toolbar-button -(defun release-toolbar-button-internal (event current) - (let ((button (event-toolbar-button event))) - (setq zmacs-region-stays t) - (if (and last-pressed-toolbar-button - (not (eq last-pressed-toolbar-button button)) - (toolbar-button-p last-pressed-toolbar-button)) - (progn - (set-toolbar-button-down-flag last-pressed-toolbar-button nil) - (setq last-pressed-toolbar-button nil))) - (if (and current (toolbar-button-p button)) - (set-toolbar-button-down-flag button nil)))) - -(defun release-toolbar-button (event) - "Release all pressed toolbar buttons." - (interactive "_e") - (or (button-release-event-p event) - (error "%s must be invoked by a mouse-release" this-command)) - (release-toolbar-button-internal event t) - ;; Don't set this-command if we're being called - ;; from release-and-activate-toolbar-button. - (if (interactive-p) - (setq this-command last-command)) - (setq toolbar-active nil)) - -(defun release-previous-toolbar-button (event) - (setq zmacs-region-stays t) - (release-toolbar-button-internal event nil)) - -;;; toolbar.el ends here
--- a/lisp/prim/undo-stack.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,264 +0,0 @@ -;;; undo-stack.el --- An "undoable stack" object. -;; Keywords: extensions - -;; Copyright (C) 1996 Ben Wing. - -;; 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, 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: Not in FSF. - -;;; Commentary: - -;;; An "undoable stack" is an object that can be used to implement -;;; a history of positions, with undo and redo. Conceptually, it -;;; is the kind of data structure used to keep track of (e.g.) -;;; visited Web pages, so that the "Back" and "Forward" operations -;;; in the browser work. Basically, I can successively visit a -;;; number of Web pages through links, and then hit "Back" a -;;; few times to go to previous positions, and then "Forward" a -;;; few times to reverse this process. This is similar to an -;;; "undo" and "redo" mechanism. -;;; -;;; Note that Emacs does not standardly contain structures like -;;; this. Instead, it implements history using either a ring -;;; (the kill ring, the mark ring), or something like the undo -;;; stack, where successive "undo" operations get recorded as -;;; normal modifications, so that if you do a bunch of successive -;;; undo's, then something else, then start undoing, you will -;;; be redoing all your undo's back to the point before you did -;;; the undo's, and then further undo's will act like the previous -;;; round of undo's. I think that both of these paradigms are -;;; inferior to the "undoable-stack" paradigm because they're -;;; confusing and difficult to keep track of. -;;; -;;; Conceptually, imagine a position history like this: -;;; -;;; 1 -> 2 -> 3 -> 4 -> 5 -> 6 -;;; ^^ -;;; -;;; where the arrow indicates where you currently are. "Going back" -;;; and "going forward" just amount to moving the arrow. However, -;;; what happens if the history state is this: -;;; -;;; 1 -> 2 -> 3 -> 4 -> 5 -> 6 -;;; ^^ -;;; -;;; and then I visit new positions (7) and (8)? In the most general -;;; implementation, you've just caused a new branch like this: -;;; -;;; 1 -> 2 -> 3 -> 4 -> 5 -> 6 -;;; | -;;; | -;;; 7 -> 8 -;;; ^^ -;;; -;;; But then you can end up with a whole big tree, and you need -;;; more sophisticated ways of navigating ("Forward" might involve -;;; a choice of paths to follow) and managing its size (if you don't -;;; want to keep unlimited history, you have to truncate at some point, -;;; and how do you truncate a tree?) -;;; -;;; My solution to this is just to insert the new positions like -;;; this: -;;; -;;; 1 -> 2 -> 3 -> 4 -> 7 -> 8 -> 5 -> 6 -;;; ^^ -;;; -;;; (Netscape, I think, would just truncate 5 and 6 completely, -;;; but that seems a bit drastic. In the Emacs-standard "ring" -;;; structure, this problem is avoided by simply moving 5 and 6 -;;; to the beginning of the ring. However, it doesn't seem -;;; logical to me to have "going back past 1" get you to 6.) -;;; -;;; Now what if we have a "maximum" size of (say) 7 elements? -;;; When we add 8, we could truncate either 1 or 6. Since 5 and -;;; 6 are "undone" positions, we should presumably truncate -;;; them before 1. So, adding 8 truncates 6, adding 9 truncates -;;; 5, and adding 10 truncates 1 because there is nothing more -;;; that is forward of the insertion point. -;;; -;;; Interestingly, this method of truncation is almost like -;;; how a ring would truncate. A ring would move 5 and 6 -;;; around to the back, like this: -;;; -;;; 5 -> 6 -> 1 -> 2 -> 3 -> 4 -> 7 -> 8 -;;; ^^ -;;; -;;; However, when 8 is added, the ring truncates 5 instead of -;;; 6, which is less than optimal. -;;; -;;; Conceptually, we can implement the "undoable stack" using -;;; two stacks of a sort called "truncatable stack", which are -;;; just simple stacks, but where you can truncate elements -;;; off of the bottom of the stack. Then, the undoable stack -;;; -;;; 1 -> 2 -> 3 -> 4 -> 5 -> 6 -;;; ^^ -;;; -;;; is equivalent to two truncatable stacks: -;;; -;;; 4 <- 3 <- 2 <- 1 -;;; 5 <- 6 -;;; -;;; where I reversed the direction to accord with the probable -;;; implementation of a standard list. To do another undo, -;;; I pop 4 off of the first stack and move it to the top of -;;; the second stack. A redo operation does the opposite. -;;; To truncate to the proper size, first chop off 6, then 5, -;;; then 1 -- in all cases, truncating off the bottom. - -(define-error 'trunc-stack-bottom "Bottom of stack reached.") - -(defsubst trunc-stack-stack (stack) - ;; return the list representing the trunc-stack's elements. - ;; the head of the list is the most recent element. - (aref stack 1)) - -(defsubst trunc-stack-length (stack) - ;; return the number of elements in the trunc-stack. - (aref stack 2)) - -(defsubst set-trunc-stack-stack (stack new) - ;; set the list representing the trunc-stack's elements. - (aset stack 1 new)) - -(defsubst set-trunc-stack-length (stack new) - ;; set the length of the trunc-stack. - (aset stack 2 new)) - -;; public functions: - -(defun make-trunc-stack () - ;; make an empty trunc-stack. - (vector 'trunc-stack nil 0)) - -(defun trunc-stack-push (stack el) - ;; push a new element onto the head of the trunc-stack. - (set-trunc-stack-stack stack (cons el (trunc-stack-stack stack))) - (set-trunc-stack-length stack (1+ (trunc-stack-length stack)))) - -(defun trunc-stack-top (stack &optional n) - ;; return the nth topmost element from the trunc-stack. - ;; signal an error if the stack doesn't have that many elements. - (or n (setq n 0)) - (if (>= n (trunc-stack-length stack)) - (signal-error 'trunc-stack-bottom (list stack)) - (nth n (trunc-stack-stack stack)))) - -(defun trunc-stack-pop (stack) - ;; pop and return the topmost element from the stack. - (prog1 (trunc-stack-top stack) - (set-trunc-stack-stack stack (cdr (trunc-stack-stack stack))) - (set-trunc-stack-length stack (1- (trunc-stack-length stack))))) - -(defun trunc-stack-truncate (stack &optional n) - ;; truncate N items off the bottom of the stack. If the stack is - ;; not that big, it just becomes empty. - (or n (setq n 1)) - (if (> n 0) - (let ((len (trunc-stack-length stack))) - (if (>= n len) - (progn - (set-trunc-stack-length stack 0) - (set-trunc-stack-stack stack nil)) - (setcdr (nthcdr (1- (- len n)) (trunc-stack-stack stack)) nil) - (set-trunc-stack-length stack (- len n)))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; FMH! FMH! FMH! This object-oriented stuff doesn't really work -;;; properly without built-in structures (vectors suck) and without -;;; public and private functions and fields. Bogons descend on -;;; RMS for not believing in any of this. - -(defsubst undoable-stack-max (stack) - (aref stack 1)) - -(defsubst undoable-stack-a (stack) - (aref stack 2)) - -(defsubst undoable-stack-b (stack) - (aref stack 3)) - -;; public functions: - -(defun make-undoable-stack (max) - ;; make an empty undoable stack of max size MAX. - (vector 'undoable-stack max (make-trunc-stack) (make-trunc-stack))) - -(defsubst set-undoable-stack-max (stack new) - ;; change the max size of an undoable stack. - (aset stack 1 new)) - -(defun undoable-stack-a-top (stack) - ;; return the topmost element off the "A" stack of an undoable stack. - ;; this is the most recent position pushed on the undoable stack. - (trunc-stack-top (undoable-stack-a stack))) - -(defun undoable-stack-a-length (stack) - (trunc-stack-length (undoable-stack-a stack))) - -(defun undoable-stack-b-top (stack) - ;; return the topmost element off the "B" stack of an undoable stack. - ;; this is the position that will become the most recent position, - ;; after a redo operation. - (trunc-stack-top (undoable-stack-b stack))) - -(defun undoable-stack-b-length (stack) - (trunc-stack-length (undoable-stack-b stack))) - -(defun undoable-stack-push (stack el) - ;; push an element onto the stack. - (let* - ((lena (trunc-stack-length (undoable-stack-a stack))) - (lenb (trunc-stack-length (undoable-stack-b stack))) - (max (undoable-stack-max stack)) - (len (+ lena lenb))) - ;; maybe truncate some elements. We have to deal with the - ;; possibility that we have more elements than our max - ;; (someone might have reduced the max). - (if (>= len max) - (let ((must-nuke (1+ (- len max)))) - ;; chop off must-nuke elements from the B stack. - (trunc-stack-truncate (undoable-stack-b stack) must-nuke) - ;; but if there weren't that many elements to chop, - ;; take the rest off the A stack. - (if (< lenb must-nuke) - (trunc-stack-truncate (undoable-stack-a stack) - (- must-nuke lenb))))) - (trunc-stack-push (undoable-stack-a stack) el))) - -(defun undoable-stack-pop (stack) - ;; pop an element off the stack. - (trunc-stack-pop (undoable-stack-a stack))) - -(defun undoable-stack-undo (stack) - ;; transfer an element from the top of A to the top of B. - ;; return value is undefined. - (trunc-stack-push (undoable-stack-b stack) - (trunc-stack-pop (undoable-stack-a stack)))) - -(defun undoable-stack-redo (stack) - ;; transfer an element from the top of B to the top of A. - ;; return value is undefined. - (trunc-stack-push (undoable-stack-a stack) - (trunc-stack-pop (undoable-stack-b stack)))) - - - -
--- a/lisp/prim/update-elc.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,142 +0,0 @@ -;;; update-elc.el --- Bytecompile out-of-date dumped files - -;; Copyright (C) 1997 Free Software Foundation, Inc. -;; Copyright (C) 1996 Unknown - -;; Maintainer: XEmacs Development Team -;; Keywords: internal - -;; 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, 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: Not in FSF. - -;;; Commentary: - -;; Byte compile the .EL files necessary to dump out xemacs. -;; Use this file like this: -;; -;; temacs -batch -l ../lisp/prim/update-elc.el $lisp -;; -;; where $lisp comes from the Makefile. .elc files listed in $lisp will -;; cause the corresponding .el file to be compiled. .el files listed in -;; $lisp will be ignored. -;; -;; (the idea here is that you can bootstrap if your .ELC files -;; are missing or badly out-of-date) - -;; Currently this code gets the list of files to check passed to it from -;; src/Makefile. This must be fixed. -slb - -;;; Code: - -(defvar processed nil) -(defvar update-elc-files-to-compile nil) - -;(setq update-elc-files-to-compile -; (delq nil -; (mapcar (function -; (lambda (x) -; (if (string-match "\.elc$" x) -; (let ((src (substring x 0 -1))) -; (if (file-newer-than-file-p src x) -; (progn -; (and (file-exists-p x) -; (null (file-writable-p x)) -; (set-file-modes x (logior (file-modes x) 128))) -; src)))))) -; ;; -batch gets filtered out. -; (nthcdr 3 command-line-args)))) - -(define-function 'defalias 'define-function) -(require 'packages) - -(let ((autol (list-autoloads))) - ;; (print (prin1-to-string autol)) - (while autol - (let ((src (car autol))) - (if (and (file-exists-p src) - (file-newer-than-file-p src (concat src "c"))) - (setq update-elc-files-to-compile - (cons src update-elc-files-to-compile)))) - (setq autol (cdr autol)))) - -;; We must have some lisp support at this point -(let ((temp-path (expand-file-name ".." (car load-path)))) - (setq load-path (nconc (directory-files temp-path t "^[^-.]" - nil 'dirs-only) - (cons temp-path load-path)))) - -;(load "backquote") -;(load "bytecomp-runtime") -;(load "subr") -;(load "replace") -;(load "version.el") -;(load "cl") -;(load "featurep") - -;; (print (prin1-to-string update-elc-files-to-compile)) - -(let (preloaded-file-list site-load-packages) - (load (concat default-directory "../lisp/prim/dumped-lisp.el")) - ;; (print (prin1-to-string preloaded-file-list)) - (load (concat default-directory "../site-packages") t t) - (setq preloaded-file-list - (append packages-hardcoded-lisp - preloaded-file-list - packages-useful-lisp - site-load-packages)) - (while preloaded-file-list - (let ((arg (car preloaded-file-list))) - ;; (print (prin1-to-string arg)) - (if (null (member arg packages-unbytecompiled-lisp)) - (progn - (setq arg (locate-library arg)) - (if (null arg) - (progn - (print (format "Library file %s: not found" - (car preloaded-file-list))) - (kill-emacs))) - (if (string-match "\\.elc?\\'" arg) - (setq arg (substring arg 0 (match-beginning 0)))) - (if (and (null (member arg processed)) - (file-exists-p (concat arg ".el")) - (file-newer-than-file-p (concat arg ".el") - (concat arg ".elc"))) - (setq processed (cons (concat arg ".el") processed))))) - (setq preloaded-file-list (cdr preloaded-file-list))))) - -(setq update-elc-files-to-compile (append update-elc-files-to-compile - processed)) - -;; (print (prin1-to-string update-elc-files-to-compile)) - -(if update-elc-files-to-compile - (progn - (setq command-line-args - (append '("-l" "loadup-el.el" "run-temacs" - "-batch" "-q" "-no-site-file" - "-l" "bytecomp" "-f" "batch-byte-compile") - update-elc-files-to-compile)) - (load "loadup-el.el")) - (condition-case nil - (delete-file "./NOBYTECOMPILE") - (file-error nil))) - -(kill-emacs) - -;;; update-elc.el ends here
--- a/lisp/prim/window-xemacs.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,617 +0,0 @@ -;;; window-xemacs.el --- XEmacs window commands aside from those written in C. - -;; Copyright (C) 1985, 1989, 1993-94, 1997 Free Software Foundation, Inc. -;; Copyright (C) 1995, 1996 Ben Wing. - -;; Maintainer: XEmacs Development Team -;; Keywords: extensions - -;; 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, 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: Not synched. - -;;; Commentary: - -;; slb - 5/29/97 -;; Split apart from window.el in order to keep that file better in synch -;; with Emacs. - -;;; Code: - -(defun backward-other-window (arg &optional all-frames device) - "Select the ARG'th different window on this frame, going backwards. -This is just like calling `other-window' with the arg negated." - (interactive "p") - (other-window (- arg) all-frames device)) - -(defun windows-of-buffer (&optional buffer) - "Returns a list of windows that have BUFFER in them. -If BUFFER is not specified, the current buffer will be used." - (or (bufferp buffer) - (if (stringp buffer) - (setq buffer (or (get-buffer buffer) - (get-file-buffer buffer))) - (setq buffer (current-buffer)))) - (let* ((firstwin (next-window nil nil t)) - (wind firstwin) - (done nil) - window-list) - (while (not done) - (if (eq (window-buffer wind) buffer) - (setq window-list (append window-list (list wind)))) - (setq wind (next-window wind nil t)) - (setq done (eq wind firstwin))) - window-list)) - -(defun buffer-in-multiple-windows-p (&optional buffer) - "Return t if BUFFER is in multiple windows. -If BUFFER is not specified, the current buffer will be used." - (setq buffer (or buffer - (get-buffer buffer) - (get-file-buffer buffer) - (current-buffer))) - (> (length (windows-of-buffer buffer)) 1)) - -(defun window-list (&optional frame minibuf window) - "Return a list of windows on FRAME, beginning with WINDOW. -FRAME and WINDOW default to the selected ones. -Optional second arg MINIBUF t means count the minibuffer window -even if not active. If MINIBUF is neither t nor nil it means -not to count the minibuffer even if it is active." - (setq window (or window (selected-window)) - frame (or frame (selected-frame))) - (if (not (eq (window-frame window) frame)) - (error "Window must be on frame.")) - (let ((current-frame (selected-frame)) - list) - (unwind-protect - (save-window-excursion - (select-frame frame) - (walk-windows - (function (lambda (cur-window) - (if (not (eq window cur-window)) - (setq list (cons cur-window list))))) - minibuf) - (setq list (cons window list))) - (select-frame current-frame)))) - -;; We used to have set-window-dedicated-p as an obsolete version -;; of set-window-buffer-dedicated, but it really makes more sense -;; this way. - -(make-obsolete 'set-window-buffer-dedicated 'set-window-dedicated-p) -(defun set-window-buffer-dedicated (window buffer) - "Make WINDOW display BUFFER and be dedicated to that buffer. -Then Emacs will not automatically change which buffer appears in WINDOW. -If BUFFER is nil, make WINDOW not be dedicated (but don't change which -buffer appears in it currently)." - (if (bufferp buffer) - (set-window-buffer window (get-buffer-create buffer))) - (set-window-dedicated-p window (not (null buffer)))) - - -;; The window-config stack is stored as a list in frame property -;; 'window-config-stack, with the most recent element at the front. -;; When you pop off an element, the popped off element gets put at the -;; front of frame property 'window-config-unpop-stack, so you can -;; retrieve it using unpop-window-configuration. - -(defcustom window-config-stack-max 16 - "*Maximum size of window configuration stack. -Start discarding off end if it gets this big." - :type 'integer - :group 'windows) - -(defun window-config-stack (&optional frame) - (or frame (setq frame (selected-frame))) - (let ((stack (frame-property frame 'window-config-stack))) - (if stack - (set-undoable-stack-max stack window-config-stack-max) - (progn - (setq stack (make-undoable-stack window-config-stack-max)) - (set-frame-property frame 'window-config-stack stack))) - stack)) - -(defun push-window-configuration (&optional config) - "Push the current window configuration onto the window-config stack. -If CONFIG is specified, push it instead of the current window configuration. -Each frame has its own window-config stack." - (interactive) - (let ((wc (or config (current-window-configuration))) - (stack (window-config-stack))) - (if (or (= 0 (undoable-stack-a-length stack)) - (not (equal (undoable-stack-a-top stack) wc))) - (progn - (undoable-stack-push stack wc) - ;; kludge. - (if (featurep 'toolbar) - (set-specifier-dirty-flag default-toolbar)))))) - -(defun pop-window-configuration () - "Pop the top window configuration off the window-config stack and set it. -Before setting the new window configuration, the current window configuration - is pushed onto the \"unpop\" stack. -`unpop-window-configuration' undoes what this function does. -Each frame has its own window-config and \"unpop\" stack." - (interactive) - (let ((stack (window-config-stack)) - (wc (current-window-configuration)) - popped) - (condition-case nil - (progn - (setq popped (undoable-stack-pop stack)) - (while (equal popped wc) - (setq popped (undoable-stack-pop stack))) - (undoable-stack-push stack wc) - (undoable-stack-undo stack) - (set-window-configuration popped) - ;; probably not necessary: - (if (featurep 'toolbar) - (set-specifier-dirty-flag default-toolbar)) - popped) - (trunc-stack-bottom - (error "Bottom of window config stack"))))) - -(defun unpop-window-configuration () - "Undo the effect of the most recent `pop-window-configuration'. -This does exactly the inverse of what `pop-window-configuration' does: - i.e. it pops a window configuration off of the \"unpop\" stack and - pushes the current window configuration onto the window-config stack. -Each frame has its own window-config and \"unpop\" stack." - (interactive) - (let ((stack (window-config-stack)) - (wc (current-window-configuration)) - popped) - (condition-case nil - (progn - (setq popped - (progn - (undoable-stack-redo stack) - (undoable-stack-pop stack))) - (while (equal popped wc) - (setq popped - (progn - (undoable-stack-redo stack) - (undoable-stack-pop stack)))) - (undoable-stack-push stack wc) - (set-window-configuration popped) - ;; probably not necessary: - (if (featurep 'toolbar) - (set-specifier-dirty-flag default-toolbar)) - popped) - (trunc-stack-bottom - (error "Top of window config stack"))))) - - -;;;;;;;;;;;;; display-buffer, moved here from C. Hallelujah. - -(defvar display-buffer-function nil - "If non-nil, function to call to handle `display-buffer'. -It will receive three args: the same as those to `display-buffer'.") - -(defvar pre-display-buffer-function nil - "If non-nil, function that will be called from `display-buffer' -as the first action. It will receive three args: the same as those -to `display-buffer'. -This function may be used to select an appropriate frame for the buffer, -for example. See also the variable `display-buffer-function', which may -be used to completely replace the `display-buffer' function. -If the return value of this function is non-nil, it should be a frame, -and that frame will be used to display the buffer.") - -(defcustom pop-up-frames nil - "*Non-nil means `display-buffer' should make a separate frame." - :type 'boolean - :group 'frames) - -(defvar pop-up-frame-function nil - "Function to call to handle automatic new frame creation. -It is called with no arguments and should return a newly created frame. - -A typical value might be `(lambda () (new-frame pop-up-frame-alist))' -where `pop-up-frame-alist' would hold the default frame parameters.") - -(defcustom special-display-buffer-names nil - "*List of buffer names that should have their own special frames. -Displaying a buffer whose name is in this list makes a special frame for it -using `special-display-function'. - -An element of the list can be a cons cell instead of just a string. -Then the car should be a buffer name, and the cdr specifies frame -parameters for creating the frame for that buffer. -More precisely, the cdr is passed as the second argument to -the function found in `special-display-function', when making that frame. -See also `special-display-regexps'." - :type '(repeat (choice :value "" - (string :tag "Name") - (cons :menu-tag "Properties" - :value ("" . nil) - (string :tag "Name") - (repeat :tag "Properties" - (group :inline t - (symbol :tag "Property") - (sexp :tag "Value")))))) - :group 'frames) - -(defcustom special-display-regexps nil - "*List of regexps saying which buffers should have their own special frames. -If a buffer name matches one of these regexps, it gets its own frame. -Displaying a buffer whose name is in this list makes a special frame for it -using `special-display-function'. - -An element of the list can be a cons cell instead of just a string. -Then the car should be the regexp, and the cdr specifies frame -parameters for creating the frame for buffers that match. -More precisely, the cdr is passed as the second argument to -the function found in `special-display-function', when making that frame. -See also `special-display-buffer-names'." - :type '(repeat (choice :value "" - regexp - (cons :menu-tag "Properties" - :value ("" . nil) - regexp - (repeat :tag "Properties" - (group :inline t - (symbol :tag "Property") - (sexp :tag "Value")))))) - :group 'frames) - -(defvar special-display-function nil - "Function to call to make a new frame for a special buffer. -It is called with two arguments, the buffer and optional buffer specific -data, and should return a window displaying that buffer. -The default value makes a separate frame for the buffer, -using `special-display-frame-alist' to specify the frame parameters. - -A buffer is special if its is listed in `special-display-buffer-names' -or matches a regexp in `special-display-regexps'.") - -(defcustom same-window-buffer-names nil - "*List of buffer names that should appear in the selected window. -Displaying one of these buffers using `display-buffer' or `pop-to-buffer' -switches to it in the selected window, rather than making it appear -in some other window. - -An element of the list can be a cons cell instead of just a string. -Then the car must be a string, which specifies the buffer name. -This is for compatibility with `special-display-buffer-names'; -the cdr of the cons cell is ignored. - -See also `same-window-regexps'." - :type '(repeat (string :tag "Name")) - :group 'windows) - -(defcustom same-window-regexps nil - "*List of regexps saying which buffers should appear in the selected window. -If a buffer name matches one of these regexps, then displaying it -using `display-buffer' or `pop-to-buffer' switches to it -in the selected window, rather than making it appear in some other window. - -An element of the list can be a cons cell instead of just a string. -Then the car must be a string, which specifies the buffer name. -This is for compatibility with `special-display-buffer-names'; -the cdr of the cons cell is ignored. - -See also `same-window-buffer-names'." - :type '(repeat regexp) - :group 'windows) - -(defcustom pop-up-windows t - "*Non-nil means display-buffer should make new windows." - :type 'boolean - :group 'windows) - -(defcustom split-height-threshold 500 - "*display-buffer would prefer to split the largest window if this large. -If there is only one window, it is split regardless of this value." - :type 'integer - :group 'windows) - -(defcustom split-width-threshold 500 - "*display-buffer would prefer to split the largest window if this large. -If there is only one window, it is split regardless of this value." - :type 'integer - :group 'windows) - -;; Deiconify the frame containing the window WINDOW, then return WINDOW. - -(defun display-buffer-1 (window) - (if (frame-iconified-p (window-frame window)) - (make-frame-visible (window-frame window))) - window) - -;; Can you believe that all of this crap was formerly in C? -;; Praise Jesus that it's not there any more. - -(defun display-buffer (buffer &optional not-this-window-p override-frame) - "Make BUFFER appear in some window on the current frame, but don't select it. -BUFFER can be a buffer or a buffer name. -If BUFFER is shown already in some window in the current frame, -just uses that one, unless the window is the selected window and -NOT-THIS-WINDOW-P is non-nil (interactively, with prefix arg). - -If BUFFER has a dedicated frame, display on that frame instead of -the current frame, unless OVERRIDE-FRAME is non-nil. - -If OVERRIDE-FRAME is non-nil, display on that frame instead of -the current frame (or the dedicated frame). - -If `pop-up-windows' is non-nil, always use the -current frame and create a new window regardless of whether the -buffer has a dedicated frame, and regardless of whether -OVERRIDE-FRAME was specified. - -If `pop-up-frames' is non-nil, make a new frame if no window shows BUFFER. - -Returns the window displaying BUFFER." - (interactive "BDisplay buffer:\nP") - - (let ((wconfig (current-window-configuration)) - (result - ;; We just simulate a `return' in C. This function is way ugly - ;; and does `returns' all over the place and there's no sense - ;; in trying to rewrite it to be more Lispy. - (catch 'done - (let (window old-frame target-frame explicit-frame) - (setq old-frame (or (last-nonminibuf-frame) (selected-frame))) - (setq buffer (get-buffer buffer)) - (check-argument-type 'bufferp buffer) - - (setq explicit-frame - (if pre-display-buffer-function - (funcall pre-display-buffer-function buffer - not-this-window-p - override-frame))) - - ;; Give the user the ability to completely reimplement - ;; this function via the `display-buffer-function'. - (if display-buffer-function - (throw 'done - (funcall display-buffer-function buffer - not-this-window-p - override-frame))) - - ;; If the buffer has a dedicated frame, that takes - ;; precedence over the current frame, and over what the - ;; pre-display-buffer-function did. - (let ((dedi (buffer-dedicated-frame buffer))) - (if (frame-live-p dedi) (setq explicit-frame dedi))) - - ;; if override-frame is supplied, that takes precedence over - ;; everything. This is gonna look bad if the - ;; pre-display-buffer-function raised some other frame - ;; already. - (if override-frame - (progn - (check-argument-type 'frame-live-p override-frame) - (setq explicit-frame override-frame))) - - (setq target-frame - (or explicit-frame - (last-nonminibuf-frame) - (selected-frame))) - - ;; If we have switched frames, then set not-this-window-p - ;; to false. Switching frames means that selected-window - ;; is no longer the same as it was on entry -- it's the - ;; selected-window of target_frame instead of old_frame, - ;; so it's a fine candidate for display. - (if (not (eq old-frame target-frame)) - (setq not-this-window-p nil)) - - ;; if it's in the selected window, and that's ok, then we're done. - (if (and (not not-this-window-p) - (eq buffer (window-buffer (selected-window)))) - (throw 'done (display-buffer-1 (selected-window)))) - - ;; See if the user has specified this buffer should appear - ;; in the selected window. - - (if not-this-window-p - nil - - (if (or (member (buffer-name buffer) same-window-buffer-names) - (assoc (buffer-name buffer) same-window-buffer-names)) - (progn - (switch-to-buffer buffer) - (throw 'done (display-buffer-1 (selected-window))))) - - (let ((tem same-window-regexps)) - (while tem - (let ((car (car tem))) - (if (or - (and (stringp car) - (string-match car (buffer-name buffer))) - (and (consp car) (stringp (car car)) - (string-match (car car) (buffer-name buffer)))) - (progn - (switch-to-buffer buffer) - (throw 'done (display-buffer-1 - (selected-window)))))) - (setq tem (cdr tem))))) - - ;; If pop-up-frames, look for a window showing BUFFER on - ;; any visible or iconified frame. Otherwise search only - ;; the current frame. - (if (and (not explicit-frame) - (or pop-up-frames (not (last-nonminibuf-frame)))) - (setq target-frame 0)) - - ;; Otherwise, find some window that it's already in, and - ;; return that, unless that window is the selected window - ;; and that isn't ok. What a contorted mess! - (setq window (get-buffer-window buffer target-frame)) - (if (and window - (or (not not-this-window-p) - (not (eq window (selected-window))))) - (throw 'done (display-buffer-1 window))) - - ;; Certain buffer names get special handling. - (if special-display-function - (progn - (if (member (buffer-name buffer) - special-display-buffer-names) - (throw 'done (funcall special-display-function buffer))) - - (let ((tem (assoc (buffer-name buffer) - special-display-buffer-names))) - (if tem - (throw 'done (funcall special-display-function - buffer (cdr tem))))) - - (let ((tem special-display-regexps)) - (while tem - (let ((car (car tem))) - (if (and (stringp car) - (string-match car (buffer-name buffer))) - (throw 'done - (funcall special-display-function buffer))) - (if (and (consp car) - (stringp (car car)) - (string-match (car car) - (buffer-name buffer))) - (throw 'done (funcall - special-display-function buffer - (cdr car))))) - (setq tem (cdr tem)))))) - - ;; If there are no frames open that have more than a minibuffer, - ;; we need to create a new frame. - (if (or pop-up-frames - (null (last-nonminibuf-frame))) - (progn - (setq window (frame-selected-window - (funcall pop-up-frame-function))) - (set-window-buffer window buffer) - (throw 'done (display-buffer-1 window)))) - - ;; Otherwise, make it be in some window, splitting if - ;; appropriate/possible. Do not split a window if we are - ;; displaying the buffer in a different frame than that which - ;; was current when we were called. (It is already in a - ;; different window by virtue of being in another frame.) - (if (or (and pop-up-windows (eq target-frame old-frame)) - (eq 'only (frame-property (selected-frame) 'minibuffer)) - ;; If the current frame is a special display frame, - ;; don't try to reuse its windows. - (window-dedicated-p (frame-root-window (selected-frame)))) - (progn - (if (eq 'only (frame-property (selected-frame) 'minibuffer)) - (setq target-frame (last-nonminibuf-frame))) - - ;; Don't try to create a window if would get an error with - ;; height. - (if (< split-height-threshold (* 2 window-min-height)) - (setq split-height-threshold (* 2 window-min-height))) - - ;; Same with width. - (if (< split-width-threshold (* 2 window-min-width)) - (setq split-width-threshold (* 2 window-min-width))) - - ;; If the frame we would try to split cannot be split, - ;; try other frames. - (if (frame-property (if (null target-frame) - (selected-frame) - (last-nonminibuf-frame)) - 'unsplittable) - (setq window - ;; Try visible frames first. - (or (get-largest-window 'visible) - ;; If that didn't work, try iconified frames. - (get-largest-window 0) - (get-largest-window t))) - (setq window (get-largest-window target-frame))) - - ;; If we got a tall enough full-width window that - ;; can be split, split it. - (if (and window - (not (frame-property (window-frame window) - 'unsplittable)) - (>= (window-height window) split-height-threshold) - (or (>= (window-width window) - split-width-threshold) - (and (window-leftmost-p window) - (window-rightmost-p window)))) - (setq window (split-window window)) - (let (upper -;; lower - other) - (setq window (get-lru-window target-frame)) - ;; If the LRU window is selected, and big enough, - ;; and can be split, split it. - (if (and window - (not (frame-property (window-frame window) - 'unsplittable)) - (or (eq window (selected-window)) - (not (window-parent window))) - (>= (window-height window) - (* 2 window-min-height))) - (setq window (split-window window))) - ;; If get-lru-window returned nil, try other approaches. - ;; Try visible frames first. - (or window - (setq window (or (get-largest-window 'visible) - ;; If that didn't work, try - ;; iconified frames. - (get-largest-window 0) - ;; Try invisible frames. - (get-largest-window t) - ;; As a last resort, make - ;; a new frame. - (frame-selected-window - (funcall - pop-up-frame-function))))) - ;; If window appears above or below another, - ;; even out their heights. - (if (window-previous-child window) - (setq other (window-previous-child window) -;; lower window - upper other)) - (if (window-next-child window) - (setq other (window-next-child window) -;; lower other - upper window)) - ;; Check that OTHER and WINDOW are vertically arrayed. - (if (and other - (not (= (nth 1 (window-pixel-edges other)) - (nth 1 (window-pixel-edges window)))) - (> (window-pixel-height other) - (window-pixel-height window))) - (enlarge-window (- (/ (+ (window-height other) - (window-height window)) - 2) - (window-height upper)) - nil upper))))) - - (setq window (get-lru-window target-frame))) - - ;; Bring the window's previous buffer to the top of the MRU chain. - (if (window-buffer window) - (save-excursion - (save-selected-window - (select-window window) - (record-buffer (window-buffer window))))) - - (set-window-buffer window buffer) - - (display-buffer-1 window))))) - (or (equal wconfig (current-window-configuration)) - (push-window-configuration wconfig)) - result)) - -;;; window-xemacs.el ends here
--- a/lisp/prim/window.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,374 +0,0 @@ -;;; window.el --- XEmacs window commands aside from those written in C. - -;; Copyright (C) 1985, 1989, 1993-94, 1997 Free Software Foundation, Inc. -;; Copyright (C) 1995, 1996 Ben Wing. - -;; Maintainer: XEmacs Development Team -;; Keywords: extensions - -;; 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, 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: Emacs/Mule zeta. - -;;; Commentary: - -;; This file is dumped with XEmacs. - -;;; Code: - -;;;; Window tree functions. - -(defun one-window-p (&optional nomini all-frames device) - "Returns non-nil if the selected window is the only window (in its frame). -Optional arg NOMINI non-nil means don't count the minibuffer -even if it is active. - -The optional arg ALL-FRAMES t means count windows on all frames. -If it is `visible', count windows on all visible frames. -ALL-FRAMES nil or omitted means count only the selected frame, -plus the minibuffer it uses (which may be on another frame). -ALL-FRAMES = 0 means count windows on all visible and iconified frames. -If ALL-FRAMES is any other value, count only the selected frame. - -If optional third argument DEVICE is nil or omitted, count frames -on all devices. -If a device, count frames only on that device. -If a device type, count frames only on devices of that type. -Otherwise, count frames only on the selected device." - (let ((base-window (selected-window))) - (if (and nomini (eq base-window (minibuffer-window))) - (setq base-window (next-window base-window))) - (eq base-window - (next-window base-window (if nomini 'arg) all-frames device)))) - -(defun walk-windows (proc &optional minibuf all-frames device) - "Cycle through all visible windows, calling PROC for each one. -PROC is called with a window as argument. - -Optional second arg MINIBUF t means count the minibuffer window even -if not active. MINIBUF nil or omitted means count the minibuffer iff -it is active. MINIBUF neither t nor nil means not to count the -minibuffer even if it is active. - -Several frames may share a single minibuffer; if the minibuffer -counts, all windows on all frames that share that minibuffer count -too. Therefore, when a separate minibuffer frame is active, -`walk-windows' includes the windows in the frame from which you -entered the minibuffer, as well as the minibuffer window. But if the -minibuffer does not count, only windows from WINDOW's frame count. - -ALL-FRAMES is the optional third argument. -ALL-FRAMES nil or omitted means cycle within the frames as specified above. -ALL-FRAMES = `visible' means include windows on all visible frames. -ALL-FRAMES = 0 means include windows on all visible and iconified frames. -ALL-FRAMES = t means include windows on all frames including invisible frames. -Anything else means restrict to WINDOW's frame. - -If optional fourth argument DEVICE is nil or omitted, include frames -on all devices. -If a device, include frames only on that device. -If a device type, include frames only on devices of that type. -Otherwise, include frames only on the selected device." - ;; If we start from the minibuffer window, don't fail to come back to it. - (if (window-minibuffer-p (selected-window)) - (setq minibuf t)) - ;; Note that, like next-window & previous-window, this behaves a little - ;; strangely if the selected window is on an invisible frame: it hits - ;; some of the windows on that frame, and all windows on visible frames. - (let* ((walk-windows-start (selected-window)) - (walk-windows-current walk-windows-start)) - (while (progn - (setq walk-windows-current - (next-window walk-windows-current minibuf all-frames - device)) - (funcall proc walk-windows-current) - (not (eq walk-windows-current walk-windows-start)))))) -;; The old XEmacs definition of the above clause. It's more correct in -;; that it will never hit a window that's already been hit even if you -;; do something odd like `delete-other-windows', but has the problem -;; that it conses. (This may be called repeatedly, from lazy-lock -;; for example.) -; (let* ((walk-windows-history nil) -; (walk-windows-current (selected-window))) -; (while (progn -; (setq walk-windows-current -; (next-window walk-windows-current minibuf all-frames -; device)) -; (not (memq walk-windows-current walk-windows-history))) -; (setq walk-windows-history (cons walk-windows-current -; walk-windows-history)) -; (funcall proc walk-windows-current)))) - -(defun minibuffer-window-active-p (window) - "Return t if WINDOW (a minibuffer window) is now active." - (eq window (active-minibuffer-window))) - -(defmacro save-selected-window (&rest body) - "Execute BODY, then select the window that was selected before BODY." - (list 'let - '((save-selected-window-window (selected-window))) - (list 'unwind-protect - (cons 'progn body) - (list 'and ; XEmacs - (list 'window-live-p 'save-selected-window-window) - (list 'select-window 'save-selected-window-window))))) - -(defun count-windows (&optional minibuf) - "Returns the number of visible windows. -Optional arg MINIBUF non-nil means count the minibuffer -even if it is inactive." - (let ((count 0)) - (walk-windows (function (lambda (w) - (setq count (+ count 1)))) - minibuf) - count)) - -(defun balance-windows () - "Makes all visible windows the same height (approximately)." - (interactive) - (let ((count -1) levels newsizes size) - ;FSFmacs - ;;; Don't count the lines that are above the uppermost windows. - ;;; (These are the menu bar lines, if any.) - ;(mbl (nth 1 (window-edges (frame-first-window (selected-frame)))))) - ;; Find all the different vpos's at which windows start, - ;; then count them. But ignore levels that differ by only 1. - (save-window-excursion - (let (tops (prev-top -2)) - (walk-windows (function (lambda (w) - (setq tops (cons (nth 1 (window-pixel-edges w)) - tops)))) - 'nomini) - (setq tops (sort tops '<)) - (while tops - (if (> (car tops) (1+ prev-top)) - (setq prev-top (car tops) - count (1+ count))) - (setq levels (cons (cons (car tops) count) levels)) - (setq tops (cdr tops))) - (setq count (1+ count)))) - ;; Subdivide the frame into that many vertical levels. - ;FSFmacs (setq size (/ (- (frame-height) mbl) count)) - (setq size (/ (window-pixel-height (frame-root-window)) count)) - (walk-windows (function - (lambda (w) - (select-window w) - (let ((newtop (cdr (assq (nth 1 (window-pixel-edges)) - levels))) - (newbot (or (cdr (assq - (+ (window-pixel-height) - (nth 1 (window-pixel-edges))) - levels)) - count))) - (setq newsizes - (cons (cons w (* size (- newbot newtop))) - newsizes))))) - 'nomini) - (walk-windows (function (lambda (w) - (select-window w) - (let ((newsize (cdr (assq w newsizes)))) - (enlarge-window - (/ (- newsize (window-pixel-height)) - (face-height 'default)))))) - 'nomini))) - -;;; I think this should be the default; I think people will prefer it--rms. -(defcustom split-window-keep-point t - "*If non-nil, split windows keeps the original point in both children. -This is often more convenient for editing. -If nil, adjust point in each of the two windows to minimize redisplay. -This is convenient on slow terminals, but point can move strangely." - :type 'boolean - :group 'windows) - -(defun split-window-vertically (&optional arg) - "Split current window into two windows, one above the other. -The uppermost window gets ARG lines and the other gets the rest. -Negative arg means select the size of the lowermost window instead. -With no argument, split equally or close to it. -Both windows display the same buffer now current. - -If the variable split-window-keep-point is non-nil, both new windows -will get the same value of point as the current window. This is often -more convenient for editing. - -Otherwise, we chose window starts so as to minimize the amount of -redisplay; this is convenient on slow terminals. The new selected -window is the one that the current value of point appears in. The -value of point can change if the text around point is hidden by the -new mode line. - -Programs should probably use split-window instead of this." - (interactive "P") - (let ((old-w (selected-window)) - (old-point (point)) - (size (and arg (prefix-numeric-value arg))) - (window-full-p nil) - new-w bottom moved) - (and size (< size 0) (setq size (+ (window-height) size))) - (setq new-w (split-window nil size)) - (or split-window-keep-point - (progn - (save-excursion - (set-buffer (window-buffer)) - (goto-char (window-start)) - (setq moved (vertical-motion (window-height))) - (set-window-start new-w (point)) - (if (> (point) (window-point new-w)) - (set-window-point new-w (point))) - (and (= moved (window-height)) - (progn - (setq window-full-p t) - (vertical-motion -1))) - (setq bottom (point))) - (and window-full-p - (<= bottom (point)) - (set-window-point old-w (1- bottom))) - (and window-full-p - (<= (window-start new-w) old-point) - (progn - (set-window-point new-w old-point) - (select-window new-w))))) - new-w)) - -(defun split-window-horizontally (&optional arg) - "Split current window into two windows side by side. -This window becomes the leftmost of the two, and gets ARG columns. -Negative arg means select the size of the rightmost window instead. -No arg means split equally." - (interactive "P") - (let ((size (and arg (prefix-numeric-value arg)))) - (and size (< size 0) - (setq size (+ (window-width) size))) - (split-window nil size t))) - -(defun enlarge-window-horizontally (arg) - "Make current window ARG columns wider." - (interactive "p") - (enlarge-window arg t)) - -(defun shrink-window-horizontally (arg) - "Make current window ARG columns narrower." - (interactive "p") - (shrink-window arg t)) - -(defun shrink-window-if-larger-than-buffer (&optional window) - "Shrink the WINDOW to be as small as possible to display its contents. -Do not shrink to less than `window-min-height' lines. -Do nothing if the buffer contains more lines than the present window height, -or if some of the window's contents are scrolled out of view, -or if the window is not the full width of the frame, -or if the window is the only window of its frame." - (interactive) - (or window (setq window (selected-window))) - (save-excursion - (set-buffer (window-buffer window)) - (let* ((w (selected-window)) ;save-window-excursion can't win - (buffer-file-name buffer-file-name) - (p (point)) - (n 0) - (ignore-final-newline - ;; If buffer ends with a newline, ignore it when counting height - ;; unless point is after it. - (and (not (eobp)) - (eq ?\n (char-after (1- (point-max)))))) - (buffer-read-only nil) - (modified (buffer-modified-p)) - (buffer (current-buffer)) - (mini (frame-property (window-frame window) 'minibuffer)) - (edges (window-pixel-edges (selected-window)))) - (if (and (< 1 (let ((frame (selected-frame))) - (select-frame (window-frame window)) - (unwind-protect - (count-windows) - (select-frame frame)))) - ;; check to make sure that we don't have horizontally - ;; split windows - (eq (frame-highest-window (window-frame window) 0) - (frame-highest-window (window-frame window) -1)) - (pos-visible-in-window-p (point-min) window) - (not (eq mini 'only)) - (or (not mini) (eq mini t) - (< (nth 3 edges) - (nth 1 (window-pixel-edges mini))) - (> (nth 1 edges) - ;FSFmacs (frame-property (window-frame window) - ; 'menu-bar-lines params) - 0))) - (unwind-protect - (let ((shrinkee (or window w))) - (set-buffer (window-buffer shrinkee)) - (goto-char (point-min)) - (while (pos-visible-in-window-p - (- (point-max) - (if ignore-final-newline 1 0)) - shrinkee) - ;; defeat file locking... don't try this at home, kids! - (setq buffer-file-name nil) - (insert ?\n) (setq n (1+ n))) - (if (> n 0) - (shrink-window (min (1- n) - (- (window-height shrinkee) - window-min-height)) - nil - shrinkee))) - (delete-region (point-min) (point)) - (set-buffer-modified-p modified) - (goto-char p) - ;; (select-window w) ; Emacs - ;; Make sure we unbind buffer-read-only - ;; with the proper current buffer. - (set-buffer buffer)))))) - -(defun kill-buffer-and-window () - "Kill the current buffer and delete the selected window." - (interactive) - (if (yes-or-no-p (format "Kill buffer `%s'? " (buffer-name))) - (let ((buffer (current-buffer))) - (delete-window (selected-window)) - (kill-buffer buffer)) - (error "Aborted"))) - -;;; New with XEmacs 20.3 -;;; Suggested by Noah Friedman, and tuned by Hrvoje Niksic. -(defun window-list (&optional minibuf all-frames device) - "Return a list of existing windows. -If the optional argument MINIBUF is non-nil, then include minibuffer -windows in the result. - -By default, only the windows in the selected frame are returned. -The optional argument ALL-FRAMES changes this behavior: -ALL-FRAMES = `visible' means include windows on all visible frames. -ALL-FRAMES = 0 means include windows on all visible and iconified frames. -ALL-FRAMES = t means include windows on all frames including invisible frames. -Anything else means restrict to the selected frame. -The optional fourth argument DEVICE further clarifies which frames to -search as specified by ALL-FRAMES. This value is only meaningful if -ALL-FRAMES is non-nil. -If nil or omitted, search only the selected device. -If a device, search frames only on that device. -If a device type, search frames only on devices of that type. -Any other non-nil value means search frames on all devices." - (let ((wins nil)) - (walk-windows (lambda (win) - (push win wins)) - minibuf all-frames device) - wins)) - - -;;; window.el ends here
--- a/lisp/prim/winnt.el Mon Aug 13 10:03:54 2007 +0200 +++ b/lisp/prim/winnt.el Mon Aug 13 10:04:58 2007 +0200 @@ -44,22 +44,13 @@ (define-key global-map [(meta backspace)] 'backward-kill-word) (define-key global-map [(control meta backspace)] 'backward-kill-sexp) -;; Show file type (text or binary) on modeline -(setq-default mode-line-format - (list (purecopy "") - 'mode-line-modified - 'mode-line-buffer-identification - (purecopy " ") - 'global-mode-string - (purecopy " %[(") - (purecopy "%t:") - 'mode-name 'mode-line-process 'minor-mode-alist - (purecopy "%n") - (purecopy ")%]--") - (purecopy '(line-number-mode "L%l--")) - (purecopy '(column-number-mode "C%c--")) - (purecopy '(-3 . "%p")) - (purecopy "-%-"))) +(defconst nt-modeline-buffer-type '("%t") + "Modeline control for showing buffer type (binary or text).") + +(setq-default modeline-format + (cons (purecopy "") + (cons 'nt-modeline-buffer-type + (cdr modeline-format)))) ;; Ignore case on file-name completion (setq completion-ignore-case t)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/process.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,339 @@ +;;; process.el --- commands for subprocesses; split out of simple.el + +;; Copyright (C) 1985-7, 1993,4, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1995 Ben Wing. + +;; Author: Ben Wing +;; Maintainer: XEmacs Development Team +;; Keywords: internal, processes, dumped + +;; 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, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: FSF 19.30. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;;; Code: + + +(defvar shell-command-switch "-c" + "Switch used to have the shell execute its command line argument.") + +(defun start-process-shell-command (name buffer &rest args) + "Start a program in a subprocess. Return the process object for it. +Args are NAME BUFFER COMMAND &rest COMMAND-ARGS. +NAME is name for process. It is modified if necessary to make it unique. +BUFFER is the buffer or (buffer-name) to associate with the process. + Process output goes at end of that buffer, unless you specify + an output stream or filter function to handle the output. + BUFFER may be also nil, meaning that this process is not associated + with any buffer +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 " "))))) + +(defun call-process (program &optional infile buffer displayp &rest args) + "Call PROGRAM synchronously in separate process. +The program's input comes from file INFILE (nil means `/dev/null'). +Insert output in BUFFER before point; t means current buffer; + nil for BUFFER means discard it; 0 means discard and don't wait. +BUFFER can also have the form (REAL-BUFFER STDERR-FILE); in that case, +REAL-BUFFER says what to do with standard output, as above, +while STDERR-FILE says what to do with standard error in the child. +STDERR-FILE may be nil (discard standard error output), +t (mix it with ordinary output), or a file name string. + +Fourth arg DISPLAYP non-nil means redisplay buffer as output is inserted. +Remaining arguments are strings passed as command arguments to PROGRAM. + +If BUFFER is 0, `call-process' returns immediately with value nil. +Otherwise it waits for PROGRAM to terminate and returns a numeric exit status + or a signal description string. +If you quit, the process is killed with SIGINT, or SIGKILL if you + quit again." + (apply 'call-process-internal program infile buffer displayp args)) + +(defun call-process-region (start end program + &optional deletep buffer displayp + &rest args) + "Send text from START to END to a synchronous process running PROGRAM. +Delete the text if fourth arg DELETEP is non-nil. + +Insert output in BUFFER before point; t means current buffer; + nil for BUFFER means discard it; 0 means discard and don't wait. +BUFFER can also have the form (REAL-BUFFER STDERR-FILE); in that case, +REAL-BUFFER says what to do with standard output, as above, +while STDERR-FILE says what to do with standard error in the child. +STDERR-FILE may be nil (discard standard error output), +t (mix it with ordinary output), or a file name string. + +Sixth arg DISPLAYP non-nil means redisplay buffer as output is inserted. +Remaining args are passed to PROGRAM at startup as command args. + +If BUFFER is 0, returns immediately with value nil. +Otherwise waits for PROGRAM to terminate +and returns a numeric exit status or a signal description string. +If you quit, the process is first killed with SIGINT, then with SIGKILL if +you quit again before the process exits." + (let ((temp (cond ((eq system-type 'vax-vms) + (make-temp-name "tmp:emacs")) + ((or (eq system-type 'ms-dos) + (eq system-type 'windows-nt)) + (make-temp-name + (concat (file-name-as-directory + (or (getenv "TMP") + (getenv "TEMP") + "")) + "em"))) + (t + (make-temp-name "/tmp/emacs"))))) + (unwind-protect + (progn + (if (or (eq system-type 'ms-dos) + (eq system-type '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))))) + + +(defun shell-command (command &optional output-buffer) + "Execute string COMMAND in inferior shell; display output, if any. + +If COMMAND ends in ampersand, execute it asynchronously. +The output appears in the buffer `*Async Shell Command*'. +That buffer is in shell mode. + +Otherwise, COMMAND is executed synchronously. The output appears in the +buffer `*Shell Command Output*'. +If the output is one line, it is displayed in the echo area *as well*, +but it is nonetheless available in buffer `*Shell Command Output*', +even though that buffer is not automatically displayed. +If there is no output, or if output is inserted in the current buffer, +then `*Shell Command Output*' is deleted. + +The optional second argument OUTPUT-BUFFER, if non-nil, +says to put the output in some other buffer. +If OUTPUT-BUFFER is a buffer or buffer name, put the output there. +If OUTPUT-BUFFER is not a buffer and not nil, +insert output in current buffer. (This cannot be done asynchronously.) +In either case, the output is inserted after point (leaving mark after it)." + (interactive (list (read-shell-command "Shell command: ") + current-prefix-arg)) + (if (and output-buffer + (not (or (bufferp output-buffer) (stringp output-buffer)))) + (progn (barf-if-buffer-read-only) + (push-mark) + ;; We do not use -f for csh; we will not support broken use of + ;; .cshrcs. Even the BSD csh manual says to use + ;; "if ($?prompt) exit" before things which are not useful + ;; non-interactively. Besides, if someone wants their other + ;; aliases for shell commands then they can still have them. + (call-process shell-file-name nil t nil + shell-command-switch command) + (exchange-point-and-mark t)) + ;; Preserve the match data in case called from a program. + (save-match-data + (if (string-match "[ \t]*&[ \t]*$" command) + ;; Command ending with ampersand means asynchronous. + (progn + (background (substring command 0 (match-beginning 0)))) + (shell-command-on-region (point) (point) command output-buffer))))) + +;; We have a sentinel to prevent insertion of a termination message +;; in the buffer itself. +(defun shell-command-sentinel (process signal) + (if (memq (process-status process) '(exit signal)) + (message "%s: %s." + (car (cdr (cdr (process-command process)))) + (substring signal 0 -1)))) + +(defun shell-command-on-region (start end command + &optional output-buffer replace) + "Execute string COMMAND in inferior shell with region as input. +Normally display output (if any) in temp buffer `*Shell Command Output*'; +Prefix arg means replace the region with it. + +The noninteractive arguments are START, END, COMMAND, OUTPUT-BUFFER, REPLACE. +If REPLACE is non-nil, that means insert the output +in place of text from START to END, putting point and mark around it. + +If the output is one line, it is displayed in the echo area, +but it is nonetheless available in buffer `*Shell Command Output*' +even though that buffer is not automatically displayed. +If there is no output, or if output is inserted in the current buffer, +then `*Shell Command Output*' is deleted. + +If the optional fourth argument OUTPUT-BUFFER is non-nil, +that says to put the output in some other buffer. +If OUTPUT-BUFFER is a buffer or buffer name, put the output there. +If OUTPUT-BUFFER is not a buffer and not nil, +insert output in the current buffer. +In either case, the output is inserted after point (leaving mark after it)." + (interactive (let ((string + ;; Do this before calling region-beginning + ;; and region-end, in case subprocess output + ;; relocates them while we are in the minibuffer. + (read-shell-command "Shell command on region: "))) + ;; call-interactively recognizes region-beginning and + ;; region-end specially, leaving them in the history. + (list (region-beginning) (region-end) + string + current-prefix-arg + current-prefix-arg))) + (if (or replace + (and output-buffer + (not (or (bufferp output-buffer) (stringp output-buffer))))) + ;; Replace specified region with output from command. + (let ((swap (and replace (< start end)))) + ;; Don't muck with mark unless REPLACE says we should. + (goto-char start) + (and replace (push-mark)) + (call-process-region start end shell-file-name t t nil + shell-command-switch command) + (let ((shell-buffer (get-buffer "*Shell Command Output*"))) + (and shell-buffer (not (eq shell-buffer (current-buffer))) + (kill-buffer shell-buffer))) + ;; Don't muck with mark unless REPLACE says we should. + (and replace swap (exchange-point-and-mark t))) + ;; No prefix argument: put the output in a temp buffer, + ;; replacing its entire contents. + (let ((buffer (get-buffer-create + (or output-buffer "*Shell Command Output*"))) + (success nil) + (directory default-directory)) + (unwind-protect + (if (eq buffer (current-buffer)) + ;; If the input is the same buffer as the output, + ;; delete everything but the specified region, + ;; then replace that region with the output. + (progn (setq buffer-read-only nil) + (delete-region (max start end) (point-max)) + (delete-region (point-min) (max start end)) + (call-process-region (point-min) (point-max) + shell-file-name t t nil + shell-command-switch command) + (setq success t)) + ;; Clear the output buffer, + ;; then run the command with output there. + (save-excursion + (set-buffer buffer) + (setq buffer-read-only nil) + ;; XEmacs change + (setq default-directory directory) + (erase-buffer)) + (call-process-region start end shell-file-name + nil buffer nil + shell-command-switch command) + (setq success t)) + ;; Report the amount of output. + (let ((lines (save-excursion + (set-buffer buffer) + (if (= (buffer-size) 0) + 0 + (count-lines (point-min) (point-max)))))) + (cond ((= lines 0) + (if success + (display-message + 'command + "(Shell command completed with no output)")) + (kill-buffer buffer)) + ((and success (= lines 1)) + (message "%s" + (save-excursion + (set-buffer buffer) + (goto-char (point-min)) + (buffer-substring (point) + (progn (end-of-line) + (point)))))) + (t + (set-window-start (display-buffer buffer) 1)))))))) + + +(defun start-process (name buffer program &rest program-args) + "Start a program in a subprocess. Return the process object for it. +Args are NAME BUFFER PROGRAM &rest PROGRAM-ARGS +NAME is name for process. It is modified if necessary to make it unique. +BUFFER is the buffer or (buffer-name) to associate with the process. + Process output goes at end of that buffer, unless you specify + an output stream or filter function to handle the output. + BUFFER may be also nil, meaning that this process is not associated + with any buffer +Third arg is program file name. It is searched for as in the shell. +Remaining arguments are strings to give program as arguments. +INCODE and OUTCODE specify the coding-system objects used in input/output + from/to the process." + (apply 'start-process-internal name buffer program program-args)) + +(defun open-network-stream (name buffer host service) + "Open a TCP connection for a service to a host. +Returns a subprocess-object to represent the connection. +Input and output work as for subprocesses; `delete-process' closes it. +Args are NAME BUFFER HOST SERVICE. +NAME is name for process. It is modified if necessary to make it unique. +BUFFER is the buffer (or buffer-name) to associate with the process. + Process output goes at end of that buffer, unless you specify + an output stream or filter function to handle the output. + BUFFER may be also nil, meaning that this process is not associated + with any buffer +Third arg is name of the host to connect to, or its IP address. +Fourth arg SERVICE is name of the service desired, or an integer + specifying a port number to connect to." + (open-network-stream-internal name buffer host service)) + +(defun shell-quote-argument (argument) + "Quote an argument for passing as argument to an inferior shell." + (if (eq system-type 'ms-dos) + ;; MS-DOS shells don't have quoting, so don't do any. + argument + (if (eq system-type 'windows-nt) + (concat "\"" argument "\"") + ;; Quote everything except POSIX filename characters. + ;; This should be safe enough even for really weird shells. + (let ((result "") (start 0) end) + (while (string-match "[^-0-9a-zA-Z_./]" argument start) + (setq end (match-beginning 0) + result (concat result (substring argument start end) + "\\" (substring argument end (1+ end))) + start (1+ end))) + (concat result (substring argument start)))))) + +(defun exec-to-string (command) + "Execute COMMAND as an external process and return the output of that +process as a string" + ;; by "William G. Dubuque" <wgd@zurich.ai.mit.edu> + (with-output-to-string + (call-process shell-file-name nil t nil "-c" command))) + +(defalias 'shell-command-to-string 'exec-to-string) + +;;; process.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/register.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,276 @@ +;;; register.el --- register commands for Emacs. + +;; Copyright (C) 1985, 1993, 1994, 1997 Free Software Foundation, Inc. + +;; Maintainer: FSF +;; Keywords: internal, dumped + +;; 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 20.1 + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;; This package of functions emulates and somewhat extends the venerable +;; TECO's `register' feature, which permits you to save various useful +;; pieces of buffer state to named variables. The entry points are +;; documented in the Emacs user's manual. + +;;; Code: + +(defvar register-alist nil + "Alist of elements (NAME . CONTENTS), one for each Emacs register. +NAME is a character (a number). CONTENTS is a string, number, +frame configuration, mark or list. +A list of strings represents a rectangle. +A list of the form (file . NAME) represents the file named NAME. +A list of the form (file-query NAME POSITION) represents position POSITION + in the file named NAME, but query before visiting it.") + +(defun get-register (reg) + "Return contents of Emacs register named REG, or nil if none." + (cdr (assq reg register-alist))) + +(defun set-register (register value) + "Set contents of Emacs register named REGISTER to VALUE. Returns VALUE. +See the documentation of the variable `register-alist' for possible VALUE." + (let ((aelt (assq register register-alist))) + (if aelt + (setcdr aelt value) + (setq aelt (cons register value)) + (setq register-alist (cons aelt register-alist))) + value)) + +(defun point-to-register (register &optional arg) + "Store current location of point in register REGISTER. +With prefix argument, store current frame configuration. +Use \\[jump-to-register] to go to that location or restore that configuration. +Argument is a character, naming the register." + (interactive "cPoint to register: \nP") + (set-register register + (if arg (current-frame-configuration) (point-marker)))) + +(defun window-configuration-to-register (register &optional arg) + "Store the window configuration of the selected frame in register REGISTER. +Use \\[jump-to-register] to restore the configuration. +Argument is a character, naming the register." + (interactive "cWindow configuration to register: \nP") + (set-register register (current-window-configuration))) + +(defun frame-configuration-to-register (register &optional arg) + "Store the window configuration of all frames in register REGISTER. +Use \\[jump-to-register] to restore the configuration. +Argument is a character, naming the register." + (interactive "cFrame configuration to register: \nP") + (set-register register (current-frame-configuration))) + +(defalias 'register-to-point 'jump-to-register) +(defun jump-to-register (register &optional delete) + "Move point to location stored in a register. +If the register contains a file name, find that file. + \(To put a file name in a register, you must use `set-register'.) +If the register contains a window configuration (one frame) or a frame +configuration (all frames), restore that frame or all frames accordingly. +First argument is a character, naming the register. +Optional second arg non-nil (interactively, prefix argument) says to +delete any existing frames that the frame configuration doesn't mention. +\(Otherwise, these frames are iconified.)" + (interactive "cJump to register: \nP") + (let ((val (get-register register))) + (cond + ((and (fboundp 'frame-configuration-p) + (frame-configuration-p val)) + (set-frame-configuration val (not delete))) + ((window-configuration-p val) + (set-window-configuration val)) + ((markerp val) + (or (marker-buffer val) + (error "That register's buffer no longer exists")) + (switch-to-buffer (marker-buffer val)) + (goto-char val)) + ((and (consp val) (eq (car val) 'file)) + (find-file (cdr val))) + ((and (consp val) (eq (car val) 'file-query)) + (or (find-buffer-visiting (nth 1 val)) + (y-or-n-p (format "Visit file %s again? " (nth 1 val))) + (error "Register access aborted")) + (find-file (nth 1 val)) + (goto-char (nth 2 val))) + (t + (error "Register doesn't contain a buffer position or configuration"))))) + +;; Turn markers into file-query references when a buffer is killed. +(defun register-swap-out () + (and buffer-file-name + (let ((tail register-alist)) + (while tail + (and (markerp (cdr (car tail))) + (eq (marker-buffer (cdr (car tail))) (current-buffer)) + (setcdr (car tail) + (list 'file-query + buffer-file-name + (marker-position (cdr (car tail)))))) + (setq tail (cdr tail)))))) + +(add-hook 'kill-buffer-hook 'register-swap-out) + +;(defun number-to-register (arg char) +; "Store a number in a register. +;Two args, NUMBER and REGISTER (a character, naming the register). +;If NUMBER is nil, digits in the buffer following point are read +;to get the number to store. +;Interactively, NUMBER is the prefix arg (none means nil)." +; (interactive "P\ncNumber to register: ") +; (set-register char +; (if arg +; (prefix-numeric-value arg) +; (if (looking-at "[0-9][0-9]*") +; (save-excursion +; (save-restriction +; (narrow-to-region (point) +; (progn (skip-chars-forward "0-9") +; (point))) +; (goto-char (point-min)) +; (read (current-buffer)))) +; 0)))) + +;(defun increment-register (arg char) +; "Add NUMBER to the contents of register REGISTER. +;Interactively, NUMBER is the prefix arg (none means nil)." +; (interactive "p\ncNumber to register: ") +; (or (integerp (get-register char)) +; (error "Register does not contain a number")) +; (set-register char (+ arg (get-register char)))) + +(defun view-register (register) + "Display what is contained in register named REGISTER. +The Lisp value REGISTER is a character." + (interactive "cView register: ") + (let ((val (get-register register))) + (if (null val) + (message "Register %s is empty" (single-key-description register)) + (with-output-to-temp-buffer "*Output*" + (princ "Register ") + (princ (single-key-description register)) + (princ " contains ") + (cond + ((integerp val) + (princ val)) + + ((markerp val) + (let ((buf (marker-buffer val))) + (if (null buf) + (princ "a marker in no buffer") + (princ "a buffer position:\nbuffer ") + (princ (buffer-name buf)) + (princ ", position ") + (princ (marker-position val))))) + + ((window-configuration-p val) + (princ "a window configuration.")) + + ((frame-configuration-p val) + (princ "a frame configuration.")) + + ((and (consp val) (eq (car val) 'file)) + (princ "the file ") + (prin1 (cdr val)) + (princ ".")) + + ((consp val) + (princ "the rectangle:\n") + (while val + (princ (car val)) + (terpri) + (setq val (cdr val)))) + + ((stringp val) + (princ "the text:\n") + (princ val)) + + (t + (princ "Garbage:\n") + (prin1 val))))))) + +(defun insert-register (register &optional arg) + "Insert contents of register REGISTER. (REGISTER is a character.) +Normally puts point before and mark after the inserted text. +If optional second arg is non-nil, puts mark before and point after. +Interactively, second arg is non-nil if prefix arg is supplied." + (interactive "*cInsert register: \nP") + (push-mark) + (let ((val (get-register register))) + (cond + ((consp val) + (insert-rectangle val)) + ((stringp val) + (insert val)) + ((integerp val) + (princ val (current-buffer))) + ((and (markerp val) (marker-position val)) + (princ (marker-position val) (current-buffer))) + (t + (error "Register does not contain text")))) + (if (not arg) (exchange-point-and-mark))) + +(defun copy-to-register (register start end &optional delete-flag) + "Copy region into register REGISTER. With prefix arg, delete as well. +Called from program, takes four args: REGISTER, START, END and DELETE-FLAG. +START and END are buffer positions indicating what to copy." + (interactive "cCopy to register: \nr\nP") + (set-register register (buffer-substring start end)) + (if delete-flag (delete-region start end))) + +(defun append-to-register (register start end &optional delete-flag) + "Append region to text in register REGISTER. +With prefix arg, delete as well. +Called from program, takes four args: REGISTER, START, END and DELETE-FLAG. +START and END are buffer positions indicating what to append." + (interactive "cAppend to register: \nr\nP") + (or (stringp (get-register register)) + (error "Register does not contain text")) + (set-register register (concat (get-register register) + (buffer-substring start end))) + (if delete-flag (delete-region start end))) + +(defun prepend-to-register (register start end &optional delete-flag) + "Prepend region to text in register REGISTER. +With prefix arg, delete as well. +Called from program, takes four args: REGISTER, START, END and DELETE-FLAG. +START and END are buffer positions indicating what to prepend." + (interactive "cPrepend to register: \nr\nP") + (or (stringp (get-register register)) + (error "Register does not contain text")) + (set-register register (concat (buffer-substring start end) + (get-register register))) + (if delete-flag (delete-region start end))) + +(defun copy-rectangle-to-register (register start end &optional delete-flag) + "Copy rectangular region into register REGISTER. +With prefix arg, delete as well. +Called from program, takes four args: REGISTER, START, END and DELETE-FLAG. +START and END are buffer positions giving two corners of rectangle." + (interactive "cCopy rectangle to register: \nr\nP") + (set-register register + (if delete-flag + (delete-extract-rectangle start end) + (extract-rectangle start end)))) + +;;; register.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/replace.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,858 @@ +;;; replace.el --- search and replace commands for XEmacs. + +;; Copyright (C) 1985-7, 1992, 1994, 1997 Free Software Foundation, Inc. + +;; Maintainer: XEmacs Development Team +;; Keywords: dumped, matching + +;; 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.34 [Partially]. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;; This package supplies the string and regular-expression replace functions +;; documented in the XEmacs Reference Manual. + +;; All the gettext calls are for XEmacs I18N3 message catalog support. +;; (This is hopelessly broken and we should remove it. -sb) + +;;; Code: + +(defvar case-replace t "\ +*Non-nil means `query-replace' should preserve case in replacements. +What this means is that `query-replace' will change the case of the +replacement text so that it matches the text that was replaced. +If this variable is nil, the replacement text will be inserted +exactly as it was specified by the user, irrespective of the case +of the text that was replaced. + +Note that this flag has no effect if `case-fold-search' is nil, +or if the replacement text has any uppercase letters in it.") + +(defvar query-replace-history nil) + +(defvar query-replace-interactive nil + "Non-nil means `query-replace' uses the last search string. +That becomes the \"string to replace\".") + +(defun query-replace-read-args (string regexp-flag) + (let (from to) + (if query-replace-interactive + (setq from (car (if regexp-flag regexp-search-ring search-ring))) + (setq from (read-from-minibuffer (format "%s: " (gettext string)) + nil nil nil + 'query-replace-history))) + (setq to (read-from-minibuffer (format "%s %s with: " (gettext string) + from) + nil nil nil + 'query-replace-history)) + (list from to current-prefix-arg))) + +;; As per suggestion from Per Abrahamsen, limit replacement to the region +;; if the region is active. +(defun query-replace (from-string to-string &optional arg) + "Replace some occurrences of FROM-STRING with TO-STRING. +As each match is found, the user must type a character saying +what to do with it. For directions, type \\[help-command] at that time. + +If `query-replace-interactive' is non-nil, the last incremental search +string is used as FROM-STRING--you don't have to specify it with the +minibuffer. + +Preserves case in each replacement if `case-replace' and `case-fold-search' +are non-nil and FROM-STRING has no uppercase letters. +\(Preserving case means that if the string matched is all caps, or capitalized, +then its replacement is upcased or capitalized.) + +Third arg DELIMITED (prefix arg if interactive), if non-nil, means replace +only matches surrounded by word boundaries. + +To customize possible responses, change the \"bindings\" in `query-replace-map'." + (interactive (query-replace-read-args "Query replace" nil)) + (if (or (and (boundp 'zmacs-region-active-p) zmacs-region-active-p) + (and (boundp 'transient-mark-mode) transient-mark-mode mark-active)) + (save-restriction + (save-excursion + (narrow-to-region (point) (mark)) + (goto-char (point-min)) + (query-replace from-string to-string arg))) + (perform-replace from-string to-string t nil arg))) + +(defun query-replace-regexp (regexp to-string &optional arg) + "Replace some things after point matching REGEXP with TO-STRING. +As each match is found, the user must type a character saying +what to do with it. For directions, type \\[help-command] at that time. + +If `query-replace-interactive' is non-nil, the last incremental search +regexp is used as REGEXP--you don't have to specify it with the +minibuffer. + +Preserves case in each replacement if `case-replace' and `case-fold-search' +are non-nil and REGEXP has no uppercase letters. +Third arg DELIMITED (prefix arg if interactive), if non-nil, means replace +only matches surrounded by word boundaries. +In TO-STRING, `\\&' stands for whatever matched the whole of REGEXP, +and `\\=\\N' (where N is a digit) stands for + whatever what matched the Nth `\\(...\\)' in REGEXP." + (interactive (query-replace-read-args "Query replace regexp" t)) + (if (or (and (boundp 'zmacs-region-active-p) zmacs-region-active-p) + (and (boundp 'transient-mark-mode) transient-mark-mode mark-active)) + (save-restriction + (save-excursion + (narrow-to-region (point) (mark)) + (goto-char (point-min)) + (perform-replace regexp to-string t t arg))) + (perform-replace regexp to-string t t arg))) + +;;#### Not patently useful +(defun map-query-replace-regexp (regexp to-strings &optional arg) + "Replace some matches for REGEXP with various strings, in rotation. +The second argument TO-STRINGS contains the replacement strings, separated +by spaces. This command works like `query-replace-regexp' except +that each successive replacement uses the next successive replacement string, +wrapping around from the last such string to the first. + +Non-interactively, TO-STRINGS may be a list of replacement strings. + +If `query-replace-interactive' is non-nil, the last incremental search +regexp is used as REGEXP--you don't have to specify it with the minibuffer. + +A prefix argument N says to use each replacement string N times +before rotating to the next." + (interactive + (let (from to) + (setq from (if query-replace-interactive + (car regexp-search-ring) + (read-from-minibuffer "Map query replace (regexp): " + nil nil nil + 'query-replace-history))) + (setq to (read-from-minibuffer + (format "Query replace %s with (space-separated strings): " + from) + nil nil nil + 'query-replace-history)) + (list from to current-prefix-arg))) + (let (replacements) + (if (listp to-strings) + (setq replacements to-strings) + (while (/= (length to-strings) 0) + (if (string-match " " to-strings) + (setq replacements + (append replacements + (list (substring to-strings 0 + (string-match " " to-strings)))) + to-strings (substring to-strings + (1+ (string-match " " to-strings)))) + (setq replacements (append replacements (list to-strings)) + to-strings "")))) + (perform-replace regexp replacements t t nil arg))) + +(defun replace-string (from-string to-string &optional delimited) + "Replace occurrences of FROM-STRING with TO-STRING. +Preserve case in each match if `case-replace' and `case-fold-search' +are non-nil and FROM-STRING has no uppercase letters. +\(Preserving case means that if the string matched is all caps, or capitalized, +then its replacement is upcased or capitalized.) + +Third arg DELIMITED (prefix arg if interactive), if non-nil, means replace +only matches surrounded by word boundaries. + +If `query-replace-interactive' is non-nil, the last incremental search +string is used as FROM-STRING--you don't have to specify it with the +minibuffer. + +This function is usually the wrong thing to use in a Lisp program. +What you probably want is a loop like this: + (while (search-forward FROM-STRING nil t) + (replace-match TO-STRING nil t)) +which will run faster and will not set the mark or print anything." + (interactive (query-replace-read-args "Replace string" nil)) + (perform-replace from-string to-string nil nil delimited)) + +(defun replace-regexp (regexp to-string &optional delimited) + "Replace things after point matching REGEXP with TO-STRING. +Preserve case in each match if `case-replace' and `case-fold-search' +are non-nil and REGEXP has no uppercase letters. +\(Preserving case means that if the string matched is all caps, or capitalized, +then its replacement is upcased or capitalized.) + +Third arg DELIMITED (prefix arg if interactive), if non-nil, means replace +only matches surrounded by word boundaries. +In TO-STRING, `\\&' stands for whatever matched the whole of REGEXP, +and `\\=\\N' (where N is a digit) stands for + whatever what matched the Nth `\\(...\\)' in REGEXP. + +If `query-replace-interactive' is non-nil, the last incremental search +regexp is used as REGEXP--you don't have to specify it with the minibuffer. + +This function is usually the wrong thing to use in a Lisp program. +What you probably want is a loop like this: + (while (re-search-forward REGEXP nil t) + (replace-match TO-STRING nil nil)) +which will run faster and will not set the mark or print anything." + (interactive (query-replace-read-args "Replace regexp" t)) + (perform-replace regexp to-string nil t delimited)) + + +(defvar regexp-history nil + "History list for some commands that read regular expressions.") + +(define-function 'keep-lines 'delete-non-matching-lines) +(defun delete-non-matching-lines (regexp) + "Delete all lines except those containing matches for REGEXP. +A match split across lines preserves all the lines it lies in. +Applies to all lines after point." + (interactive (list (read-from-minibuffer + "Keep lines (containing match for regexp): " + nil nil nil 'regexp-history))) + (save-excursion + (or (bolp) (forward-line 1)) + (let ((start (point))) + (while (not (eobp)) + ;; Start is first char not preserved by previous match. + (if (not (re-search-forward regexp nil 'move)) + (delete-region start (point-max)) + (let ((end (save-excursion (goto-char (match-beginning 0)) + (beginning-of-line) + (point)))) + ;; Now end is first char preserved by the new match. + (if (< start end) + (delete-region start end)))) + (setq start (save-excursion (forward-line 1) + (point))) + ;; If the match was empty, avoid matching again at same place. + (and (not (eobp)) (= (match-beginning 0) (match-end 0)) + (forward-char 1)))))) + +(define-function 'flush-lines 'delete-matching-lines) +(defun delete-matching-lines (regexp) + "Delete lines containing matches for REGEXP. +If a match is split across lines, all the lines it lies in are deleted. +Applies to lines after point." + (interactive (list (read-from-minibuffer + "Flush lines (containing match for regexp): " + nil nil nil 'regexp-history))) + (save-excursion + (while (and (not (eobp)) + (re-search-forward regexp nil t)) + (delete-region (save-excursion (goto-char (match-beginning 0)) + (beginning-of-line) + (point)) + (progn (forward-line 1) (point)))))) + +(define-function 'how-many 'count-matches) +(defun count-matches (regexp) + "Print number of matches for REGEXP following point." + (interactive (list (read-from-minibuffer + "How many matches for (regexp): " + nil nil nil 'regexp-history))) + (let ((count 0) opoint) + (save-excursion + (while (and (not (eobp)) + (progn (setq opoint (point)) + (re-search-forward regexp nil t))) + (if (= opoint (point)) + (forward-char 1) + (setq count (1+ count)))) + (message "%d occurrences" count)))) + + +(defvar occur-mode-map ()) +(if occur-mode-map + () + (setq occur-mode-map (make-sparse-keymap)) + (set-keymap-name occur-mode-map 'occur-mode-map) ; XEmacs + (define-key occur-mode-map 'button2 'occur-mode-mouse-goto) ; XEmacs + (define-key occur-mode-map "\C-c\C-c" 'occur-mode-goto-occurrence) + (define-key occur-mode-map "\C-m" 'occur-mode-goto-occurrence)) + +(defvar occur-buffer nil) +(defvar occur-nlines nil) +(defvar occur-pos-list nil) + +(defun occur-mode () + "Major mode for output from \\[occur]. +\\<occur-mode-map>Move point to one of the items in this buffer, then use +\\[occur-mode-goto-occurrence] to go to the occurrence that the item refers to. +Alternatively, click \\[occur-mode-mouse-goto] on an item to go to it. + +\\{occur-mode-map}" + (kill-all-local-variables) + (use-local-map occur-mode-map) + (setq major-mode 'occur-mode) + (setq mode-name (gettext "Occur")) ; XEmacs + (make-local-variable 'occur-buffer) + (make-local-variable 'occur-nlines) + (make-local-variable 'occur-pos-list) + (require 'mode-motion) ; XEmacs + (setq mode-motion-hook 'mode-motion-highlight-line) ; XEmacs + (run-hooks 'occur-mode-hook)) + +;; FSF Version of next function: +; (let (buffer pos) +; (save-excursion +; (set-buffer (window-buffer (posn-window (event-end event)))) +; (save-excursion +; (goto-char (posn-point (event-end event))) +; (setq pos (occur-mode-find-occurrence)) +; (setq buffer occur-buffer))) +; (pop-to-buffer buffer) +; (goto-char (marker-position pos)))) + +(defun occur-mode-mouse-goto (event) + "Go to the occurrence highlighted by mouse. +This function is only reasonable when bound to a mouse key in the occur buffer" + (interactive "e") + (let ((window-save (selected-window)) + (frame-save (selected-frame))) + ;; preserve the window/frame setup + (unwind-protect + (progn + (mouse-set-point event) + (occur-mode-goto-occurrence)) + (select-frame frame-save) + (select-window window-save)))) + +;; Called occur-mode-find-occurrence in FSF +(defun occur-mode-goto-occurrence () + "Go to the occurrence the current line describes." + (interactive) + (if (or (null occur-buffer) + (null (buffer-name occur-buffer))) + (progn + (setq occur-buffer nil + occur-pos-list nil) + (error "Buffer in which occurrences were found is deleted"))) + (let* ((line-count + (count-lines (point-min) + (save-excursion + (beginning-of-line) + (point)))) + (occur-number (save-excursion + (beginning-of-line) + (/ (1- line-count) + (cond ((< occur-nlines 0) + (- 2 occur-nlines)) + ((> occur-nlines 0) + (+ 2 (* 2 occur-nlines))) + (t 1))))) + (pos (nth occur-number occur-pos-list)) + ;; removed t arg from Bob Weiner, 10/6/95 + (window (get-buffer-window occur-buffer)) + (occur-source-buffer occur-buffer)) + (if (< line-count 1) + (error "No occurrence on this line")) + (or pos + (error "No occurrence on this line")) + ;; XEmacs: don't raise window unless it isn't visible + ;; allow for the possibility that the occur buffer is on another frame + (or (and window + (window-live-p window) + (frame-visible-p (window-frame window)) + (set-buffer occur-source-buffer)) + (and (pop-to-buffer occur-source-buffer) + (setq window (get-buffer-window occur-source-buffer)))) + (goto-char pos) + (set-window-point window pos))) + + +(defvar list-matching-lines-default-context-lines 0 + "*Default number of context lines to include around a `list-matching-lines' +match. A negative number means to include that many lines before the match. +A positive number means to include that many lines both before and after.") + +;; XEmacs addition +;;; Damn you Jamie, this is utter trash. +(defvar list-matching-lines-whole-buffer t + "If t, occur operates on whole buffer, otherwise occur starts from point. +default is t.") + +(define-function 'occur 'list-matching-lines) +(defun list-matching-lines (regexp &optional nlines) + "Show all lines in the current buffer containing a match for REGEXP. + +If a match spreads across multiple lines, all those lines are shown. + +If variable `list-matching-lines-whole-buffer' is non-nil, the entire buffer is +searched, otherwise search begins at point. + +Each line is displayed with NLINES lines before and after, or -NLINES +before if NLINES is negative. +NLINES defaults to `list-matching-lines-default-context-lines'. +Interactively it is the prefix arg. + +The lines are shown in a buffer named `*Occur*'. +It serves as a menu to find any of the occurrences in this buffer. +\\[describe-mode] in that buffer will explain how." + (interactive + ;; XEmacs change + (list (let* ((default (or (symbol-near-point) + (and regexp-history + (car regexp-history)))) + (minibuffer-history-minimum-string-length 0) + (input + (if default + ;; rewritten for I18N3 snarfing + (read-from-minibuffer + (format "List lines matching regexp (default `%s'): " + default) nil nil nil 'regexp-history) + (read-from-minibuffer + "List lines matching regexp: " + nil nil nil + 'regexp-history)))) + (if (and (equal input "") default) + (progn + (setq input default) + (setcar regexp-history default))) + ;; clear extra entries + (setcdr regexp-history (delete (car regexp-history) + (cdr regexp-history))) + input) + current-prefix-arg)) + (if (equal regexp "") + (error "Must pass non-empty regexp to `list-matching-lines'")) + (setq nlines (if nlines (prefix-numeric-value nlines) + list-matching-lines-default-context-lines)) + (let ((first t) + (dir default-directory) + (buffer (current-buffer)) + (linenum 1) + (prevpos (point-min)) + ;; The rest of this function is very different from FSF. + ;; Presumably that's due to Jamie's misfeature + (final-context-start (make-marker))) + (if (not list-matching-lines-whole-buffer) + (save-excursion + (beginning-of-line) + (setq linenum (1+ (count-lines (point-min) (point)))) + (setq prevpos (point)))) + (with-output-to-temp-buffer "*Occur*" + (save-excursion + (set-buffer standard-output) + (setq default-directory dir) + ;; We will insert the number of lines, and "lines", later. + ;; #### Needs fixing for I18N3 + (let ((print-escape-newlines t)) + (insert (format " matching %s in buffer %s.\n" + regexp (buffer-name buffer)))) + (occur-mode) + (setq occur-buffer buffer) + (setq occur-nlines nlines) + (setq occur-pos-list ())) + (if (eq buffer standard-output) + (goto-char (point-max))) + (save-excursion + (if list-matching-lines-whole-buffer + (beginning-of-buffer)) + (message "Searching for %s ..." regexp) + ;; Find next match, but give up if prev match was at end of buffer. + (while (and (not (= prevpos (point-max))) + (re-search-forward regexp nil t)) + (goto-char (match-beginning 0)) + (beginning-of-line) + (save-match-data + (setq linenum (+ linenum (count-lines prevpos (point))))) + (setq prevpos (point)) + (goto-char (match-end 0)) + (let* ((start (save-excursion + (goto-char (match-beginning 0)) + (forward-line (if (< nlines 0) nlines (- nlines))) + (point))) + (end (save-excursion + (goto-char (match-end 0)) + (if (> nlines 0) + (forward-line (1+ nlines)) + (forward-line 1)) + (point))) + (tag (format "%5d" linenum)) + (empty (make-string (length tag) ?\ )) + tem) + (save-excursion + (setq tem (make-marker)) + (set-marker tem (point)) + (set-buffer standard-output) + (setq occur-pos-list (cons tem occur-pos-list)) + (or first (zerop nlines) + (insert "--------\n")) + (setq first nil) + (insert-buffer-substring buffer start end) + (set-marker final-context-start + (- (point) (- end (match-end 0)))) + (backward-char (- end start)) + (setq tem (if (< nlines 0) (- nlines) nlines)) + (while (> tem 0) + (insert empty ?:) + (forward-line 1) + (setq tem (1- tem))) + (let ((this-linenum linenum)) + (while (< (point) final-context-start) + (if (null tag) + (setq tag (format "%5d" this-linenum))) + (insert tag ?:) +;; FSFmacs -- we handle this using mode-motion-highlight-line, above. +; (put-text-property (save-excursion +; (beginning-of-line) +; (point)) +; (save-excursion +; (end-of-line) +; (point)) +; 'mouse-face 'highlight) + (forward-line 1) + (setq tag nil) + (setq this-linenum (1+ this-linenum))) + (while (<= (point) final-context-start) + (insert empty ?:) + (forward-line 1) + (setq this-linenum (1+ this-linenum)))) + (while (< tem nlines) + (insert empty ?:) + (forward-line 1) + (setq tem (1+ tem))) + (goto-char (point-max))) + (forward-line 1))) + (set-buffer standard-output) + ;; Put positions in increasing order to go with buffer. + (setq occur-pos-list (nreverse occur-pos-list)) + (goto-char (point-min)) + (if (= (length occur-pos-list) 1) + (insert "1 line") + (insert (format "%d lines" (length occur-pos-list)))) + (if (interactive-p) + (message "%d matching lines." (length occur-pos-list))))))) + +;; It would be nice to use \\[...], but there is no reasonable way +;; to make that display both SPC and Y. +(defconst query-replace-help + (purecopy + "Type Space or `y' to replace one match, Delete or `n' to skip to next, +RET or `q' to exit, Period to replace one match and exit, +Comma to replace but not move point immediately, +C-r to enter recursive edit (\\[exit-recursive-edit] to get out again), +C-w to delete match and recursive edit, +C-l to clear the frame, redisplay, and offer same replacement again, +! to replace all remaining matches with no more questions, +^ to move point back to previous match." +) + "Help message while in query-replace") + +(defvar query-replace-map nil + "Keymap that defines the responses to questions in `query-replace'. +The \"bindings\" in this map are not commands; they are answers. +The valid answers include `act', `skip', `act-and-show', +`exit', `act-and-exit', `edit', `delete-and-edit', `recenter', +`automatic', `backup', `exit-prefix', and `help'.") + +;; Why does it seem that ever file has a different method of doing this? +(if query-replace-map + nil + (let ((map (make-sparse-keymap))) + (set-keymap-name map 'query-replace-map) + (define-key map " " 'act) + (define-key map "\d" 'skip) + (define-key map [delete] 'skip) + (define-key map [backspace] 'skip) + (define-key map "y" 'act) + (define-key map "n" 'skip) + (define-key map "Y" 'act) + (define-key map "N" 'skip) + (define-key map "," 'act-and-show) + (define-key map [escape] 'exit) + (define-key map "q" 'exit) + (define-key map [return] 'exit) + (define-key map "." 'act-and-exit) + (define-key map "\C-r" 'edit) + (define-key map "\C-w" 'delete-and-edit) + (define-key map "\C-l" 'recenter) + (define-key map "!" 'automatic) + (define-key map "^" 'backup) + (define-key map [(control h)] 'help) ;; XEmacs change + (define-key map [f1] 'help) + (define-key map [help] 'help) + (define-key map "?" 'help) + (define-key map "\C-g" 'quit) + (define-key map "\C-]" 'quit) + ;FSFmacs (define-key map "\e" 'exit-prefix) + (define-key map [escape] 'exit-prefix) + + (setq query-replace-map map))) + + +(autoload 'isearch-highlight "isearch") + +;; XEmacs +(defun perform-replace-next-event (event) + (if isearch-highlight + (let ((aborted t)) + (unwind-protect + (progn + (if (match-beginning 0) + (isearch-highlight (match-beginning 0) (match-end 0))) + (next-command-event event) + (setq aborted nil)) + (isearch-dehighlight aborted))) + (next-command-event event))) + +(defun perform-replace (from-string replacements + query-flag regexp-flag delimited-flag + &optional repeat-count map) + "Subroutine of `query-replace'. Its complexity handles interactive queries. +Don't use this in your own program unless you want to query and set the mark +just as `query-replace' does. Instead, write a simple loop like this: + (while (re-search-forward \"foo[ \t]+bar\" nil t) + (replace-match \"foobar\" nil nil)) +which will run faster and probably do exactly what you want." + (or map (setq map query-replace-map)) + (let* ((event (make-event)) + (nocasify (not (and case-fold-search case-replace + (string-equal from-string + (downcase from-string))))) + (literal (not regexp-flag)) + (search-function (if regexp-flag 're-search-forward 'search-forward)) + (search-string from-string) + (real-match-data nil) ; the match data for the current match + (next-replacement nil) + (replacement-index 0) + (keep-going t) + (stack nil) + (next-rotate-count 0) + (replace-count 0) + (lastrepl nil) ;Position after last match considered. + (match-again t) + ;; XEmacs addition + (qr-case-fold-search + (if (and case-fold-search search-caps-disable-folding) + (isearch-no-upper-case-p search-string) + case-fold-search)) + (message + (if query-flag + (substitute-command-keys + "Query replacing %s with %s: (\\<query-replace-map>\\[help] for help) ")))) + (if (stringp replacements) + (setq next-replacement replacements) + (or repeat-count (setq repeat-count 1))) + (if delimited-flag + (setq search-function 're-search-forward + search-string (concat "\\b" + (if regexp-flag from-string + (regexp-quote from-string)) + "\\b"))) + (push-mark) + (undo-boundary) + (unwind-protect + ;; Loop finding occurrences that perhaps should be replaced. + (while (and keep-going + (not (eobp)) + (let ((case-fold-search qr-case-fold-search)) + (funcall search-function search-string nil t)) + ;; If the search string matches immediately after + ;; the previous match, but it did not match there + ;; before the replacement was done, ignore the match. + (if (or (eq lastrepl (point)) + (and regexp-flag + (eq lastrepl (match-beginning 0)) + (not match-again))) + (if (eobp) + nil + ;; Don't replace the null string + ;; right after end of previous replacement. + (forward-char 1) + (let ((case-fold-search qr-case-fold-search)) + (funcall search-function search-string nil t))) + t)) + + ;; Save the data associated with the real match. + (setq real-match-data (match-data)) + + ;; Before we make the replacement, decide whether the search string + ;; can match again just after this match. + (if regexp-flag + (progn + (setq match-again (looking-at search-string)) + ;; XEmacs addition + (store-match-data real-match-data))) + ;; If time for a change, advance to next replacement string. + (if (and (listp replacements) + (= next-rotate-count replace-count)) + (progn + (setq next-rotate-count + (+ next-rotate-count repeat-count)) + (setq next-replacement (nth replacement-index replacements)) + (setq replacement-index (% (1+ replacement-index) (length replacements))))) + (if (not query-flag) + (progn + (store-match-data real-match-data) + (replace-match next-replacement nocasify literal) + (setq replace-count (1+ replace-count))) + (undo-boundary) + (let ((help-form + '(concat (format "Query replacing %s%s with %s.\n\n" + (if regexp-flag (gettext "regexp ") "") + from-string next-replacement) + (substitute-command-keys query-replace-help))) + done replaced def) + ;; Loop reading commands until one of them sets done, + ;; which means it has finished handling this occurrence. + (while (not done) + ;; Don't fill up the message log + ;; with a bunch of identical messages. + ;; XEmacs change + (display-message 'prompt + (format message from-string next-replacement)) + (perform-replace-next-event event) + (setq def (lookup-key map (vector event))) + ;; Restore the match data while we process the command. + (store-match-data real-match-data) + (cond ((eq def 'help) + (with-output-to-temp-buffer (gettext "*Help*") + (princ (concat + (format "Query replacing %s%s with %s.\n\n" + (if regexp-flag "regexp " "") + from-string next-replacement) + (substitute-command-keys + query-replace-help))) + (save-excursion + (set-buffer standard-output) + (help-mode)))) + ((eq def 'exit) + (setq keep-going nil) + (setq done t)) + ((eq def 'backup) + (if stack + (let ((elt (car stack))) + (goto-char (car elt)) + (setq replaced (eq t (cdr elt))) + (or replaced + (store-match-data (cdr elt))) + (setq stack (cdr stack))) + (message "No previous match") + (ding 'no-terminate) + (sit-for 1))) + ((eq def 'act) + (or replaced + (replace-match next-replacement nocasify literal)) + (setq done t replaced t)) + ((eq def 'act-and-exit) + (or replaced + (replace-match next-replacement nocasify literal)) + (setq keep-going nil) + (setq done t replaced t)) + ((eq def 'act-and-show) + (if (not replaced) + (progn + (replace-match next-replacement nocasify literal) + (store-match-data nil) + (setq replaced t)))) + ((eq def 'automatic) + (or replaced + (replace-match next-replacement nocasify literal)) + (setq done t query-flag nil replaced t)) + ((eq def 'skip) + (setq done t)) + ((eq def 'recenter) + (recenter nil)) + ((eq def 'edit) + (store-match-data + (prog1 (match-data) + (save-excursion (recursive-edit)))) + ;; Before we make the replacement, + ;; decide whether the search string + ;; can match again just after this match. + (if regexp-flag + (setq match-again (looking-at search-string)))) + ((eq def 'delete-and-edit) + (delete-region (match-beginning 0) (match-end 0)) + (store-match-data (prog1 (match-data) + (save-excursion (recursive-edit)))) + (setq replaced t)) + ;; Note: we do not need to treat `exit-prefix' + ;; specially here, since we reread + ;; any unrecognized character. + (t + (setq this-command 'mode-exited) + (setq keep-going nil) + (setq unread-command-events + (cons event unread-command-events)) + (setq done t)))) + ;; Record previous position for ^ when we move on. + ;; Change markers to numbers in the match data + ;; since lots of markers slow down editing. + (setq stack + (cons (cons (point) + (or replaced + (mapcar + #'(lambda (elt) + (if (markerp elt) + (prog1 (marker-position elt) + (set-marker elt nil)) + elt)) + (match-data)))) + stack)) + (if replaced (setq replace-count (1+ replace-count))))) + (setq lastrepl (point))) + (replace-dehighlight)) + (or unread-command-events + (message "Replaced %d occurrence%s" + replace-count + (if (= replace-count 1) "" "s"))) + (and keep-going stack))) + +(defvar query-replace-highlight nil + "*Non-nil means to highlight words during query replacement.") + +(defvar replace-overlay nil) + +(defun replace-dehighlight () + (and replace-overlay + (progn + (delete-overlay replace-overlay) + (setq replace-overlay nil)))) + +(defun replace-highlight (start end) + (and query-replace-highlight + (progn + (or replace-overlay + (progn + (setq replace-overlay (make-overlay start end)) + (overlay-put replace-overlay 'face + (if (internal-find-face 'query-replace) + 'query-replace 'region)))) + (move-overlay replace-overlay start end (current-buffer))))) + +(defun match-string (num &optional string) + "Return string of text matched by last search. +NUM specifies which parenthesized expression in the last regexp. + Value is nil if NUMth pair didn't match, or there were less than NUM pairs. +Zero means the entire text matched by the whole regexp or whole string. +STRING should be given if the last search was by `string-match' on STRING." + (if (match-beginning num) + (if string + (substring string (match-beginning num) (match-end num)) + (buffer-substring (match-beginning num) (match-end num))))) + +(defmacro save-match-data (&rest body) + "Execute BODY forms, restoring the global value of the match data." + (let ((original (make-symbol "match-data"))) + (list 'let (list (list original '(match-data))) + (list 'unwind-protect + (cons 'progn body) + (list 'store-match-data original))))) + +;;; replace.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/scrollbar.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,123 @@ +;;; scrollbar.el --- Scrollbar support for XEmacs + +;; Copyright (C) 1995, 1997 Free Software Foundation, Inc. + +;; Maintainer: XEmacs Development Team +;; Keywords: internal, extensions, dumped + +;; 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, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: Not in FSF. (Completely divergent from FSF scroll-bar.el) + +;;; Commentary: + +;; This file is dumped with XEmacs (when scrollbar support is compiled in). + +;;; Code: + +(defun init-scrollbar-from-resources (locale) + (when (and (featurep 'x) + (or (eq locale 'global) + (eq 'x (device-or-frame-type locale)))) + (x-init-scrollbar-from-resources locale))) + +;; +;; vertical scrollbar functions +;; + +;;; ### Move functions from C into Lisp here! + +;; +;; horizontal scrollbar functions +;; + +(defun scrollbar-char-left (window) + "Function called when the char-left arrow on the scrollbar is clicked. +This is the little arrow to the left of the scrollbar. One argument is +passed, the scrollbar's window. You can advise this function to +change the scrollbar behavior." + (when (window-live-p window) + (scrollbar-set-hscroll window (- (window-hscroll window) 1)) + (setq zmacs-region-stays t) + nil)) + +(defun scrollbar-char-right (window) + "Function called when the char-right arrow on the scrollbar is clicked. +This is the little arrow to the right of the scrollbar. One argument is +passed, the scrollbar's window. You can advise this function to +change the scrollbar behavior." + (when (window-live-p window) + (scrollbar-set-hscroll window (+ (window-hscroll window) 1)) + (setq zmacs-region-stays t) + nil)) + +(defun scrollbar-page-left (window) + "Function called when the user gives the \"page-left\" scrollbar action. +\(The way this is done can vary from scrollbar to scrollbar.\) One argument is +passed, the scrollbar's window. You can advise this function to +change the scrollbar behavior." + (when (window-live-p window) + (scrollbar-set-hscroll window (- (window-hscroll window) + (- (window-width window) 2))) + (setq zmacs-region-stays t) + nil)) + +(defun scrollbar-page-right (window) + "Function called when the user gives the \"page-right\" scrollbar action. +\(The way this is done can vary from scrollbar to scrollbar.\) One argument is +passed, the scrollbar's window. You can advise this function to +change the scrollbar behavior." + (when (window-live-p window) + (scrollbar-set-hscroll window (+ (window-hscroll window) + (- (window-width window) 2))) + (setq zmacs-region-stays t) + nil)) + +(defun scrollbar-to-left (window) + "Function called when the user gives the \"to-left\" scrollbar action. +\(The way this is done can vary from scrollbar to scrollbar.\). One argument is +passed, the scrollbar's window. You can advise this function to +change the scrollbar behavior." + (when (window-live-p window) + (scrollbar-set-hscroll window 0) + (setq zmacs-region-stays t) + nil)) + +(defun scrollbar-to-right (window) + "Function called when the user gives the \"to-right\" scrollbar action. +\(The way this is done can vary from scrollbar to scrollbar.\). One argument is +passed, the scrollbar's window. You can advise this function to +change the scrollbar behavior." + (when (window-live-p window) + (scrollbar-set-hscroll window 'max) + (setq zmacs-region-stays t) + nil)) + +(defun scrollbar-horizontal-drag (data) + "Function called when the user drags the horizontal scrollbar thumb. +One argument is passed, a cons containing the scrollbar's window and a value +representing how many columns the thumb is slid over. You can advise +this function to change the scrollbar behavior." + (let ((window (car data)) + (value (cdr data))) + (when (and (window-live-p window) (integerp value)) + (scrollbar-set-hscroll window value) + (setq zmacs-region-stays t) + nil))) + +;;; scrollbar.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/simple.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,3857 @@ +;;; simple.el --- basic editing commands for XEmacs + +;; Copyright (C) 1985-7, 1993-5, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp. + +;; Maintainer: XEmacs Development Team +;; Keywords: lisp, extensions, internal, dumped + +;; 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.34 [But not very closely]. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;; A grab-bag of basic XEmacs commands not specifically related to some +;; major mode or to file-handling. + +;; Changes for zmacs-style active-regions: +;; +;; beginning-of-buffer, end-of-buffer, count-lines-region, +;; count-lines-buffer, what-line, what-cursor-position, set-goal-column, +;; set-fill-column, prefix-arg-internal, and line-move (which is used by +;; next-line and previous-line) set zmacs-region-stays to t, so that they +;; don't affect the current region-hilighting state. +;; +;; mark-whole-buffer, mark-word, exchange-point-and-mark, and +;; set-mark-command (without an argument) call zmacs-activate-region. +;; +;; mark takes an optional arg like the new Fmark_marker() does. When +;; the region is not active, mark returns nil unless the optional arg is true. +;; +;; push-mark, pop-mark, exchange-point-and-mark, and set-marker, and +;; set-mark-command use (mark t) so that they can access the mark whether +;; the region is active or not. +;; +;; shell-command, shell-command-on-region, yank, and yank-pop (which all +;; push a mark) have been altered to call exchange-point-and-mark with an +;; argument, meaning "don't activate the region". These commands only use +;; exchange-point-and-mark to position the newly-pushed mark correctly, so +;; this isn't a user-visible change. These functions have also been altered +;; to use (mark t) for the same reason. + +;; 97/3/14 Jareth Hein (jhod@po.iijnet.or.jp) added kinsoku processing (support +;; for filling of Asian text) into the fill code. This was ripped bleeding from +;; Mule-2.3, and could probably use some feature additions (like additional wrap +;; styles, etc) + +;; 97/06/11 Steve Baur (steve@altair.xemacs.org) Convert use of +;; (preceding|following)-char to char-(after|before). + +;;; Code: + +(defgroup editing-basics nil + "Most basic editing variables." + :group 'editing) + +(defgroup killing nil + "Killing and yanking commands." + :group 'editing) + +(defgroup fill-comments nil + "Indenting and filling of comments." + :prefix "comment-" + :group 'fill) + +(defgroup paren-matching nil + "Highlight (un)matching of parens and expressions." + :prefix "paren-" + :group 'matching) + +(defgroup log-message nil + "Messages logging and display customizations." + :group 'minibuffer) + +(defgroup warnings nil + "Warnings customizations." + :group 'minibuffer) + + +(defun newline (&optional arg) + "Insert a newline, and move to left margin of the new line if it's blank. +The newline is marked with the text-property `hard'. +With arg, insert that many newlines. +In Auto Fill mode, if no numeric arg, break the preceding line if it's long." + (interactive "*P") + (barf-if-buffer-read-only nil (point)) + ;; Inserting a newline at the end of a line produces better redisplay in + ;; try_window_id than inserting at the beginning of a line, and the textual + ;; result is the same. So, if we're at beginning of line, pretend to be at + ;; the end of the previous line. + (let ((flag (and (not (bobp)) + (bolp) + ;; Make sure the newline before point isn't intangible. + (not (get-char-property (1- (point)) 'intangible)) + ;; Make sure the newline before point isn't read-only. + (not (get-char-property (1- (point)) 'read-only)) + ;; Make sure the newline before point isn't invisible. + (not (get-char-property (1- (point)) 'invisible)) + ;; This should probably also test for the previous char + ;; being the *last* character too. + (not (get-char-property (1- (point)) 'end-open)) + ;; Make sure the newline before point has the same + ;; properties as the char before it (if any). + (< (or (previous-extent-change (point)) -2) + (- (point) 2)))) + (was-page-start (and (bolp) + (looking-at page-delimiter))) + (beforepos (point))) + (if flag (backward-char 1)) + ;; Call self-insert so that auto-fill, abbrev expansion etc. happens. + ;; Set last-command-char to tell self-insert what to insert. + (let ((last-command-char ?\n) + ;; Don't auto-fill if we have a numeric argument. + ;; Also not if flag is true (it would fill wrong line); + ;; there is no need to since we're at BOL. + (auto-fill-function (if (or arg flag) nil auto-fill-function))) + (unwind-protect + (self-insert-command (prefix-numeric-value arg)) + ;; If we get an error in self-insert-command, put point at right place. + (if flag (forward-char 1)))) + ;; If we did *not* get an error, cancel that forward-char. + (if flag (backward-char 1)) + ;; Mark the newline(s) `hard'. + (if use-hard-newlines + (let* ((from (- (point) (if arg (prefix-numeric-value arg) 1))) + (sticky (get-text-property from 'end-open))) ; XEmacs + (put-text-property from (point) 'hard 't) + ;; If end-open is not "t", add 'hard to end-open list + (if (and (listp sticky) (not (memq 'hard sticky))) + (put-text-property from (point) 'end-open ; XEmacs + (cons 'hard sticky))))) + ;; If the newline leaves the previous line blank, + ;; and we have a left margin, delete that from the blank line. + (or flag + (save-excursion + (goto-char beforepos) + (beginning-of-line) + (and (looking-at "[ \t]$") + (> (current-left-margin) 0) + (delete-region (point) (progn (end-of-line) (point)))))) + (if flag (forward-char 1)) + ;; Indent the line after the newline, except in one case: + ;; when we added the newline at the beginning of a line + ;; which starts a page. + (or was-page-start + (move-to-left-margin nil t))) + nil) + +(defun open-line (arg) + "Insert a newline and leave point before it. +If there is a fill prefix and/or a left-margin, insert them on the new line +if the line would have been blank. +With arg N, insert N newlines." + (interactive "*p") + (let* ((do-fill-prefix (and fill-prefix (bolp))) + (do-left-margin (and (bolp) (> (current-left-margin) 0))) + (loc (point))) + (newline arg) + (goto-char loc) + (while (> arg 0) + (cond ((bolp) + (if do-left-margin (indent-to (current-left-margin))) + (if do-fill-prefix (insert fill-prefix)))) + (forward-line 1) + (setq arg (1- arg))) + (goto-char loc) + (end-of-line))) + +(defun split-line () + "Split current line, moving portion beyond point vertically down." + (interactive "*") + (skip-chars-forward " \t") + (let ((col (current-column)) + (pos (point))) + (newline 1) + (indent-to col 0) + (goto-char pos))) + +(defun quoted-insert (arg) + "Read next input character and insert it. +This is useful for inserting control characters. +You may also type up to 3 octal digits, to insert a character with that code. + +In overwrite mode, this function inserts the character anyway, and +does not handle octal digits specially. This means that if you use +overwrite as your normal editing mode, you can use this function to +insert characters when necessary. + +In binary overwrite mode, this function does overwrite, and octal +digits are interpreted as a character code. This is supposed to make +this function useful in editing binary files." + (interactive "*p") + (let ((char (if (or (not overwrite-mode) + (eq overwrite-mode 'overwrite-mode-binary)) + (read-quoted-char) + (read-char)))) + (if (> arg 0) + (if (eq overwrite-mode 'overwrite-mode-binary) + (delete-char arg))) + (while (> arg 0) + (insert char) + (setq arg (1- arg))))) + +(defun delete-indentation (&optional arg) + "Join this line to previous and fix up whitespace at join. +If there is a fill prefix, delete it from the beginning of this line. +With argument, join this line to following line." + (interactive "*P") + (beginning-of-line) + (if arg (forward-line 1)) + (if (eq (char-before (point)) ?\n) + (progn + (delete-region (point) (1- (point))) + ;; If the second line started with the fill prefix, + ;; delete the prefix. + (if (and fill-prefix + (<= (+ (point) (length fill-prefix)) (point-max)) + (string= fill-prefix + (buffer-substring (point) + (+ (point) (length fill-prefix))))) + (delete-region (point) (+ (point) (length fill-prefix)))) + (fixup-whitespace)))) + +(defun fixup-whitespace () + "Fixup white space between objects around point. +Leave one space or none, according to the context." + (interactive "*") + (save-excursion + (delete-horizontal-space) + (if (or (looking-at "^\\|\\s)") + (save-excursion (forward-char -1) + (looking-at "$\\|\\s(\\|\\s'"))) + nil + (insert ?\ )))) + +(defun delete-horizontal-space () + "Delete all spaces and tabs around point." + (interactive "*") + (skip-chars-backward " \t") + (delete-region (point) (progn (skip-chars-forward " \t") (point)))) + +(defun just-one-space () + "Delete all spaces and tabs around point, leaving one space." + (interactive "*") + (if abbrev-mode ; XEmacs + (expand-abbrev)) + (skip-chars-backward " \t") + (if (eq (char-after (point)) ? ) ; XEmacs + (forward-char 1) + (insert ? )) + (delete-region (point) (progn (skip-chars-forward " \t") (point)))) + +(defun delete-blank-lines () + "On blank line, delete all surrounding blank lines, leaving just one. +On isolated blank line, delete that one. +On nonblank line, delete any immediately following blank lines." + (interactive "*") + (let (thisblank singleblank) + (save-excursion + (beginning-of-line) + (setq thisblank (looking-at "[ \t]*$")) + ;; Set singleblank if there is just one blank line here. + (setq singleblank + (and thisblank + (not (looking-at "[ \t]*\n[ \t]*$")) + (or (bobp) + (progn (forward-line -1) + (not (looking-at "[ \t]*$"))))))) + ;; Delete preceding blank lines, and this one too if it's the only one. + (if thisblank + (progn + (beginning-of-line) + (if singleblank (forward-line 1)) + (delete-region (point) + (if (re-search-backward "[^ \t\n]" nil t) + (progn (forward-line 1) (point)) + (point-min))))) + ;; Delete following blank lines, unless the current line is blank + ;; and there are no following blank lines. + (if (not (and thisblank singleblank)) + (save-excursion + (end-of-line) + (forward-line 1) + (delete-region (point) + (if (re-search-forward "[^ \t\n]" nil t) + (progn (beginning-of-line) (point)) + (point-max))))) + ;; Handle the special case where point is followed by newline and eob. + ;; Delete the line, leaving point at eob. + (if (looking-at "^[ \t]*\n\\'") + (delete-region (point) (point-max))))) + +(defun back-to-indentation () + "Move point to the first non-whitespace character on this line." + ;; XEmacs change + (interactive "_") + (beginning-of-line 1) + (skip-chars-forward " \t")) + +(defun newline-and-indent () + "Insert a newline, then indent according to major mode. +Indentation is done using the value of `indent-line-function'. +In programming language modes, this is the same as TAB. +In some text modes, where TAB inserts a tab, this command indents to the +column specified by the function `current-left-margin'." + (interactive "*") + (delete-region (point) (progn (skip-chars-backward " \t") (point))) + (newline) + (indent-according-to-mode)) + +(defun reindent-then-newline-and-indent () + "Reindent current line, insert newline, then indent the new line. +Indentation of both lines is done according to the current major mode, +which means calling the current value of `indent-line-function'. +In programming language modes, this is the same as TAB. +In some text modes, where TAB inserts a tab, this indents to the +column specified by the function `current-left-margin'." + (interactive "*") + (save-excursion + (delete-region (point) (progn (skip-chars-backward " \t") (point))) + (indent-according-to-mode)) + (newline) + (indent-according-to-mode)) + +;; Internal subroutine of delete-char +(defun kill-forward-chars (arg) + (if (listp arg) (setq arg (car arg))) + (if (eq arg '-) (setq arg -1)) + (kill-region (point) (+ (point) arg))) + +;; Internal subroutine of backward-delete-char +(defun kill-backward-chars (arg) + (if (listp arg) (setq arg (car arg))) + (if (eq arg '-) (setq arg -1)) + (kill-region (point) (- (point) arg))) + +(defun backward-delete-char-untabify (arg &optional killp) + "Delete characters backward, changing tabs into spaces. +Delete ARG chars, and kill (save in kill ring) if KILLP is non-nil. +Interactively, ARG is the prefix arg (default 1) +and KILLP is t if a prefix arg was specified." + (interactive "*p\nP") + (let ((count arg)) + (save-excursion + (while (and (> count 0) (not (bobp))) + (if (eq (char-before (point)) ?\t) ; XEmacs + (let ((col (current-column))) + (forward-char -1) + (setq col (- col (current-column))) + (insert-char ?\ col) + (delete-char 1))) + (forward-char -1) + (setq count (1- count))))) + (delete-backward-char arg killp) + ;; XEmacs: In overwrite mode, back over columns while clearing them out, + ;; unless at end of line. + (and overwrite-mode (not (eolp)) + (save-excursion (insert-char ?\ arg)))) + +(defcustom delete-key-deletes-forward nil + "*If non-nil, the DEL key will erase one character forwards. +If nil, the DEL key will erase one character backwards." + :type 'boolean + :group 'editing-basics) + +(defun backward-or-forward-delete-char (arg) + "Delete either one character backwards or one character forwards. +Controlled by the state of `delete-key-deletes-forward' and whether the +BackSpace keysym even exists on your keyboard. If you don't have a +BackSpace keysym, the delete key should always delete one character +backwards." + (interactive "*p") + (if (and delete-key-deletes-forward + (or (eq 'tty (device-type)) + (x-keysym-on-keyboard-p "BackSpace"))) + (delete-char arg) + (delete-backward-char arg))) + +(defun backward-or-forward-kill-word (arg) + "Delete either one word backwards or one word forwards. +Controlled by the state of `delete-key-deletes-forward' and whether the +BackSpace keysym even exists on your keyboard. If you don't have a +BackSpace keysym, the delete key should always delete one character +backwards." + (interactive "*p") + (if (and delete-key-deletes-forward + (or (eq 'tty (device-type)) + (x-keysym-on-keyboard-p "BackSpace"))) + (kill-word arg) + (backward-kill-word arg))) + +(defun backward-or-forward-kill-sentence (arg) + "Delete either one sentence backwards or one sentence forwards. +Controlled by the state of `delete-key-deletes-forward' and whether the +BackSpace keysym even exists on your keyboard. If you don't have a +BackSpace keysym, the delete key should always delete one character +backwards." + (interactive "*P") + (if (and delete-key-deletes-forward + (or (eq 'tty (device-type)) + (x-keysym-on-keyboard-p "BackSpace"))) + (kill-sentence arg) + (backward-kill-sentence (prefix-numeric-value arg)))) + +(defun backward-or-forward-kill-sexp (arg) + "Delete either one sexpr backwards or one sexpr forwards. +Controlled by the state of `delete-key-deletes-forward' and whether the +BackSpace keysym even exists on your keyboard. If you don't have a +BackSpace keysym, the delete key should always delete one character +backwards." + (interactive "*p") + (if (and delete-key-deletes-forward + (or (eq 'tty (device-type)) + (x-keysym-on-keyboard-p "BackSpace"))) + (kill-sexp arg) + (backward-kill-sexp arg))) + +(defun zap-to-char (arg char) + "Kill up to and including ARG'th occurrence of CHAR. +Goes backward if ARG is negative; error if CHAR not found." + (interactive "*p\ncZap to char: ") + (kill-region (point) (progn + (search-forward (char-to-string char) nil nil arg) +; (goto-char (if (> arg 0) (1- (point)) (1+ (point)))) + (point)))) + +(defun beginning-of-buffer (&optional arg) + "Move point to the beginning of the buffer; leave mark at previous position. +With arg N, put point N/10 of the way from the beginning. + +If the buffer is narrowed, this command uses the beginning and size +of the accessible part of the buffer. + +Don't use this command in Lisp programs! +\(goto-char (point-min)) is faster and avoids clobbering the mark." + ;; XEmacs change + (interactive "_P") + (push-mark) + (let ((size (- (point-max) (point-min)))) + (goto-char (if arg + (+ (point-min) + (if (> size 10000) + ;; Avoid overflow for large buffer sizes! + (* (prefix-numeric-value arg) + (/ size 10)) + (/ (+ 10 (* size (prefix-numeric-value arg))) 10))) + (point-min)))) + (if arg (forward-line 1))) + +(defun end-of-buffer (&optional arg) + "Move point to the end of the buffer; leave mark at previous position. +With arg N, put point N/10 of the way from the end. + +If the buffer is narrowed, this command uses the beginning and size +of the accessible part of the buffer. + +Don't use this command in Lisp programs! +\(goto-char (point-max)) is faster and avoids clobbering the mark." + ;; XEmacs change + (interactive "_P") + (push-mark) + ;; XEmacs changes here. + (let ((scroll-to-end (not (pos-visible-in-window-p (point-max)))) + (size (- (point-max) (point-min)))) + (goto-char (if arg + (- (point-max) + (if (> size 10000) + ;; Avoid overflow for large buffer sizes! + (* (prefix-numeric-value arg) + (/ size 10)) + (/ (* size (prefix-numeric-value arg)) 10))) + (point-max))) + (cond (arg + ;; If we went to a place in the middle of the buffer, + ;; adjust it to the beginning of a line. + (forward-line 1)) + ;; XEmacs change + (scroll-to-end + ;; If the end of the buffer is not already on the screen, + ;; then scroll specially to put it near, but not at, the bottom. + (recenter -3))))) + +;; XEmacs (not in FSF) +(defun mark-beginning-of-buffer (&optional arg) + "Push a mark at the beginning of the buffer; leave point where it is. +With arg N, push mark N/10 of the way from the true beginning." + (interactive "P") + (push-mark (if arg + (if (> (buffer-size) 10000) + ;; Avoid overflow for large buffer sizes! + (* (prefix-numeric-value arg) + (/ (buffer-size) 10)) + (/ (+ 10 (* (buffer-size) (prefix-numeric-value arg))) 10)) + (point-min)) + nil + t)) +(define-function 'mark-bob 'mark-beginning-of-buffer) + +;; XEmacs (not in FSF) +(defun mark-end-of-buffer (&optional arg) + "Push a mark at the end of the buffer; leave point where it is. +With arg N, push mark N/10 of the way from the true end." + (interactive "P") + (push-mark (if arg + (- (1+ (buffer-size)) + (if (> (buffer-size) 10000) + ;; Avoid overflow for large buffer sizes! + (* (prefix-numeric-value arg) + (/ (buffer-size) 10)) + (/ (* (buffer-size) (prefix-numeric-value arg)) 10))) + (point-max)) + nil + t)) +(define-function 'mark-eob 'mark-end-of-buffer) + +(defun mark-whole-buffer () + "Put point at beginning and mark at end of buffer. +You probably should not use this function in Lisp programs; +it is usually a mistake for a Lisp function to use any subroutine +that uses or sets the mark." + (interactive) + (push-mark (point)) + (push-mark (point-max) nil t) + (goto-char (point-min))) + +;; XEmacs +(defun eval-current-buffer (&optional printflag) + "Evaluate the current buffer as Lisp code. +Programs can pass argument PRINTFLAG which controls printing of output: +nil means discard it; anything else is stream for print." + (interactive) + (eval-buffer (current-buffer) printflag)) + +;; XEmacs +(defun count-words-buffer (b) + (interactive "b") + (save-excursion + (let ((buf (or b (current-buffer)))) + (set-buffer buf) + (message "Buffer has %d words" + (count-words-region (point-min) (point-max)))))) + +;; XEmacs +(defun count-words-region (start end) + (interactive "r") + (save-excursion + (let ((n 0)) + (goto-char start) + (while (< (point) end) + (if (forward-word 1) + (setq n (1+ n)))) + (message "Region has %d words" n) + n))) + +(defun count-lines-region (start end) + "Print number of lines and characters in the region." + ;; XEmacs change + (interactive "_r") + (message "Region has %d lines, %d characters" + (count-lines start end) (- end start))) + +;; XEmacs +(defun count-lines-buffer (b) + "Print number of lines and characters in the specified buffer." + (interactive "_b") + (save-excursion + (let ((buf (or b (current-buffer))) + cnt) + (set-buffer buf) + (setq cnt (count-lines (point-min) (point-max))) + (message "Buffer has %d lines, %d characters" + cnt (- (point-max) (point-min))) + cnt))) + +(defun what-line () + "Print the current buffer line number and narrowed line number of point." + ;; XEmacs change + (interactive "_") + (let ((opoint (point)) start) + (save-excursion + (save-restriction + (goto-char (point-min)) + (widen) + (beginning-of-line) + (setq start (point)) + (goto-char opoint) + (beginning-of-line) + (if (/= start 1) + (message "line %d (narrowed line %d)" + (1+ (count-lines 1 (point))) + (1+ (count-lines start (point)))) + (message "Line %d" (1+ (count-lines 1 (point))))))))) + + +(defun count-lines (start end) + "Return number of lines between START and END. +This is usually the number of newlines between them, +but can be one more if START is not equal to END +and the greater of them is not at the start of a line." + (save-excursion + (save-restriction + (narrow-to-region start end) + (goto-char (point-min)) + (if (eq selective-display t) + (save-match-data + (let ((done 0)) + (while (re-search-forward "[\n\C-m]" nil t 40) + (setq done (+ 40 done))) + (while (re-search-forward "[\n\C-m]" nil t 1) + (setq done (+ 1 done))) + (goto-char (point-max)) + (if (and (/= start end) + (not (bolp))) + (1+ done) + done))) + (- (buffer-size) (forward-line (buffer-size))))))) + +(defun what-cursor-position () + "Print info on cursor position (on screen and within buffer)." + ;; XEmacs change + (interactive "_") + (let* ((char (char-after (point))) ; XEmacs + (beg (point-min)) + (end (point-max)) + (pos (point)) + (total (buffer-size)) + (percent (if (> total 50000) + ;; Avoid overflow from multiplying by 100! + (/ (+ (/ total 200) (1- pos)) (max (/ total 100) 1)) + (/ (+ (/ total 2) (* 100 (1- pos))) (max total 1)))) + (hscroll (if (= (window-hscroll) 0) + "" + (format " Hscroll=%d" (window-hscroll)))) + (col (current-column))) + (if (= pos end) + (if (or (/= beg 1) (/= end (1+ total))) + (message "point=%d of %d(%d%%) <%d - %d> column %d %s" + pos total percent beg end col hscroll) + (message "point=%d of %d(%d%%) column %d %s" + pos total percent col hscroll)) + ;; XEmacs: don't use single-key-description + (if (or (/= beg 1) (/= end (1+ total))) + (message "Char: %s (0%o, %d, 0x%x) point=%d of %d(%d%%) <%d - %d> column %d %s" + (text-char-description char) char char char pos total + percent beg end col hscroll) + (message "Char: %s (0%o, %d, 0x%x) point=%d of %d(%d%%) column %d %s" + (text-char-description char) char char char pos total + percent col hscroll))))) + +(defun fundamental-mode () + "Major mode not specialized for anything in particular. +Other major modes are defined by comparison with this one." + (interactive) + (kill-all-local-variables)) + +;; XEmacs the following are declared elsewhere +;(defvar read-expression-map (cons 'keymap minibuffer-local-map) +; "Minibuffer keymap used for reading Lisp expressions.") +;(define-key read-expression-map "\M-\t" 'lisp-complete-symbol) + +;(put 'eval-expression 'disabled t) + +;(defvar read-expression-history nil) + +;; We define this, rather than making `eval' interactive, +;; for the sake of completion of names like eval-region, eval-current-buffer. +(defun eval-expression (expression) + "Evaluate EXPRESSION and print value in minibuffer. +Value is also consed on to front of the variable `values'." + ;(interactive "xEval: ") + (interactive + (list (read-from-minibuffer "Eval: " + nil read-expression-map t + 'read-expression-history))) + (setq values (cons (eval expression) values)) + (prin1 (car values) t)) + +;; XEmacs -- extra parameter (variant, but equivalent logic) +(defun edit-and-eval-command (prompt command &optional history) + "Prompting with PROMPT, let user edit COMMAND and eval result. +COMMAND is a Lisp expression. Let user edit that expression in +the minibuffer, then read and evaluate the result." + (let ((command (read-expression prompt + ;; first try to format the thing readably; + ;; and if that fails, print it normally. + (condition-case () + (let ((print-readably t)) + (prin1-to-string command)) + (error (prin1-to-string command))) + (or history '(command-history . 1))))) + (or history (setq history 'command-history)) + (if (consp history) + (setq history (car history))) + (if (eq history t) + nil + ;; If command was added to the history as a string, + ;; get rid of that. We want only evallable expressions there. + (if (stringp (car (symbol-value history))) + (set history (cdr (symbol-value history)))) + + ;; If command to be redone does not match front of history, + ;; add it to the history. + (or (equal command (car (symbol-value history))) + (set history (cons command (symbol-value history))))) + (eval command))) + +(defun repeat-complex-command (arg) + "Edit and re-evaluate last complex command, or ARGth from last. +A complex command is one which used the minibuffer. +The command is placed in the minibuffer as a Lisp form for editing. +The result is executed, repeating the command as changed. +If the command has been changed or is not the most recent previous command +it is added to the front of the command history. +You can use the minibuffer history commands \\<minibuffer-local-map>\\[next-history-element] and \\[previous-history-element] +to get different commands to edit and resubmit." + (interactive "p") + ;; XEmacs: It looks like our version is better -sb + (let ((print-level nil)) + (edit-and-eval-command "Redo: " + (or (nth (1- arg) command-history) + (error "")) + (cons 'command-history arg)))) + +;; XEmacs: Functions moved to minibuf.el +;; previous-matching-history-element +;; next-matching-history-element +;; next-history-element +;; previous-history-element +;; next-complete-history-element +;; previous-complete-history-element + +(defun goto-line (arg) + "Goto line ARG, counting from line 1 at beginning of buffer." + (interactive "NGoto line: ") + (setq arg (prefix-numeric-value arg)) + (save-restriction + (widen) + (goto-char 1) + (if (eq selective-display t) + (re-search-forward "[\n\C-m]" nil 'end (1- arg)) + (forward-line (1- arg))))) + +;Put this on C-x u, so we can force that rather than C-_ into startup msg +(define-function 'advertised-undo 'undo) + +(defun undo (&optional arg) + "Undo some previous changes. +Repeat this command to undo more changes. +A numeric argument serves as a repeat count." + (interactive "*p") + ;; If we don't get all the way through, make last-command indicate that + ;; for the following command. + (setq this-command t) + (let ((modified (buffer-modified-p)) + (recent-save (recent-auto-save-p))) + (or (eq (selected-window) (minibuffer-window)) + (display-message 'command "Undo!")) + (or (and (eq last-command 'undo) + (eq (current-buffer) last-undo-buffer)) ; XEmacs + (progn (undo-start) + (undo-more 1))) + (undo-more (or arg 1)) + ;; Don't specify a position in the undo record for the undo command. + ;; Instead, undoing this should move point to where the change is. + (let ((tail buffer-undo-list) + done) + (while (and tail (not done) (not (null (car tail)))) + (if (integerp (car tail)) + (progn + (setq done t) + (setq buffer-undo-list (delq (car tail) buffer-undo-list)))) + (setq tail (cdr tail)))) + (and modified (not (buffer-modified-p)) + (delete-auto-save-file-if-necessary recent-save))) + ;; If we do get all the way through, make this-command indicate that. + (setq this-command 'undo)) + +(defvar pending-undo-list nil + "Within a run of consecutive undo commands, list remaining to be undone.") + +(defvar last-undo-buffer nil) ; XEmacs + +(defun undo-start () + "Set `pending-undo-list' to the front of the undo list. +The next call to `undo-more' will undo the most recently made change." + (if (eq buffer-undo-list t) + (error "No undo information in this buffer")) + (setq pending-undo-list buffer-undo-list)) + +(defun undo-more (count) + "Undo back N undo-boundaries beyond what was already undone recently. +Call `undo-start' to get ready to undo recent changes, +then call `undo-more' one or more times to undo them." + (or pending-undo-list + (error "No further undo information")) + (setq pending-undo-list (primitive-undo count pending-undo-list) + last-undo-buffer (current-buffer))) ; XEmacs + +;; XEmacs +(defun call-with-transparent-undo (fn &rest args) + "Apply FN to ARGS, and then undo all changes made by FN to the current +buffer. The undo records are processed even if FN returns non-locally. +There is no trace of the changes made by FN in the buffer's undo history. + +You can use this in a write-file-hooks function with continue-save-buffer +to make the contents of a disk file differ from its in-memory buffer." + (let ((buffer-undo-list nil) + ;; Kludge to prevent undo list truncation: + (undo-high-threshold -1) + (undo-threshold -1) + (obuffer (current-buffer))) + (unwind-protect + (apply fn args) + ;; Go to the buffer we will restore and make it writable: + (set-buffer obuffer) + (save-excursion + (let ((buffer-read-only nil)) + (save-restriction + (widen) + ;; Perform all undos, with further undo logging disabled: + (let ((tail buffer-undo-list)) + (setq buffer-undo-list t) + (while tail + (setq tail (primitive-undo (length tail) tail)))))))))) + +;; XEmacs: The following are in other files +;; shell-command-history +;; shell-command-switch +;; shell-command +;; shell-command-sentinel + + +(defconst universal-argument-map + (let ((map (make-sparse-keymap))) + (set-keymap-default-binding map 'universal-argument-other-key) + ;FSFmacs (define-key map [switch-frame] nil) + (define-key map [(t)] 'universal-argument-other-key) + (define-key map [(meta t)] 'universal-argument-other-key) + (define-key map [(control u)] 'universal-argument-more) + (define-key map [?-] 'universal-argument-minus) + (define-key map [?0] 'digit-argument) + (define-key map [?1] 'digit-argument) + (define-key map [?2] 'digit-argument) + (define-key map [?3] 'digit-argument) + (define-key map [?4] 'digit-argument) + (define-key map [?5] 'digit-argument) + (define-key map [?6] 'digit-argument) + (define-key map [?7] 'digit-argument) + (define-key map [?8] 'digit-argument) + (define-key map [?9] 'digit-argument) + map) + "Keymap used while processing \\[universal-argument].") + +(defvar universal-argument-num-events nil + "Number of argument-specifying events read by `universal-argument'. +`universal-argument-other-key' uses this to discard those events +from (this-command-keys), and reread only the final command.") + +(defun universal-argument () + "Begin a numeric argument for the following command. +Digits or minus sign following \\[universal-argument] make up the numeric argument. +\\[universal-argument] following the digits or minus sign ends the argument. +\\[universal-argument] without digits or minus sign provides 4 as argument. +Repeating \\[universal-argument] without digits or minus sign + multiplies the argument by 4 each time." + (interactive) + (setq prefix-arg (list 4)) + (setq zmacs-region-stays t) ; XEmacs + (setq universal-argument-num-events (length (this-command-keys))) + (setq overriding-terminal-local-map universal-argument-map)) + +;; A subsequent C-u means to multiply the factor by 4 if we've typed +;; nothing but C-u's; otherwise it means to terminate the prefix arg. +(defun universal-argument-more (arg) + (interactive "_P") ; XEmacs + (if (consp arg) + (setq prefix-arg (list (* 4 (car arg)))) + (setq prefix-arg arg) + (setq overriding-terminal-local-map nil)) + (setq universal-argument-num-events (length (this-command-keys)))) + +(defun negative-argument (arg) + "Begin a negative numeric argument for the next command. +\\[universal-argument] following digits or minus sign ends the argument." + (interactive "_P") ; XEmacs + (cond ((integerp arg) + (setq prefix-arg (- arg))) + ((eq arg '-) + (setq prefix-arg nil)) + (t + (setq prefix-arg '-))) + (setq universal-argument-num-events (length (this-command-keys))) + (setq overriding-terminal-local-map universal-argument-map)) + +;; XEmacs: This function not synched with FSF +(defun digit-argument (arg) + "Part of the numeric argument for the next command. +\\[universal-argument] following digits or minus sign ends the argument." + (interactive "_P") ; XEmacs + (let* ((event last-command-event) + (key (and (key-press-event-p event) + (event-key event))) + (digit (and key (characterp key) (>= key ?0) (<= key ?9) + (- key ?0)))) + (if (null digit) + (universal-argument-other-key arg) + (cond ((integerp arg) + (setq prefix-arg (+ (* arg 10) + (if (< arg 0) (- digit) digit)))) + ((eq arg '-) + ;; Treat -0 as just -, so that -01 will work. + (setq prefix-arg (if (zerop digit) '- (- digit)))) + (t + (setq prefix-arg digit))) + (setq universal-argument-num-events (length (this-command-keys))) + (setq overriding-terminal-local-map universal-argument-map)))) + +;; For backward compatibility, minus with no modifiers is an ordinary +;; command if digits have already been entered. +(defun universal-argument-minus (arg) + (interactive "_P") ; XEmacs + (if (integerp arg) + (universal-argument-other-key arg) + (negative-argument arg))) + +;; Anything else terminates the argument and is left in the queue to be +;; executed as a command. +(defun universal-argument-other-key (arg) + (interactive "_P") ; XEmacs + (setq prefix-arg arg) + (let* ((key (this-command-keys)) + ;; FSF calls silly function `listify-key-sequence' here. + (keylist (append key nil))) + (setq unread-command-events + (append (nthcdr universal-argument-num-events keylist) + unread-command-events))) + (reset-this-command-lengths) + (setq overriding-terminal-local-map nil)) + + +;; XEmacs -- keep zmacs-region active. +(defun forward-to-indentation (arg) + "Move forward ARG lines and position at first nonblank character." + (interactive "_p") + (forward-line arg) + (skip-chars-forward " \t")) + +(defun backward-to-indentation (arg) + "Move backward ARG lines and position at first nonblank character." + (interactive "_p") + (forward-line (- arg)) + (skip-chars-forward " \t")) + +(defcustom kill-whole-line nil + "*If non-nil, `kill-line' with no arg at beg of line kills the whole line." + :type 'boolean + :group 'killing) + +(defun kill-line (&optional arg) + "Kill the rest of the current line; if no nonblanks there, kill thru newline. +With prefix argument, kill that many lines from point. +Negative arguments kill lines backward. + +When calling from a program, nil means \"no arg\", +a number counts as a prefix arg. + +If `kill-whole-line' is non-nil, then kill the whole line +when given no argument at the beginning of a line." + (interactive "*P") + (kill-region (point) + ;; Don't shift point before doing the delete; that way, + ;; undo will record the right position of point. +;; FSF +; ;; It is better to move point to the other end of the kill +; ;; before killing. That way, in a read-only buffer, point +; ;; moves across the text that is copied to the kill ring. +; ;; The choice has no effect on undo now that undo records +; ;; the value of point from before the command was run. +; (progn + (save-excursion + (if arg + (forward-line (prefix-numeric-value arg)) + (if (eobp) + (signal 'end-of-buffer nil)) + (if (or (looking-at "[ \t]*$") (and kill-whole-line (bolp))) + (forward-line 1) + (end-of-line))) + (point)))) + +;; XEmacs +(defun backward-kill-line nil + "Kill back to the beginning of the line." + (interactive) + (let ((point (point))) + (beginning-of-line nil) + (kill-region (point) point))) + + +;;;; Window system cut and paste hooks. +;;; +;;; I think that kill-hooks is a better name and more general mechanism +;;; than interprogram-cut-function (from FSFmacs). I don't like the behavior +;;; of interprogram-paste-function: ^Y should always come from the kill ring, +;;; not the X selection. But if that were provided, it should be called (and +;;; behave as) yank-hooks instead. -- jwz + +;; [... code snipped ...] + +(defcustom kill-hooks nil + "*Functions run when something is added to the XEmacs kill ring. +These functions are called with one argument, the string most recently +cut or copied. You can use this to, for example, make the most recent +kill become the X Clipboard selection." + :type 'hook + :group 'killing) + +;;; `kill-hooks' seems not sufficient because +;;; `interprogram-cut-function' requires more variable about to rotate +;;; the cut buffers. I'm afraid to change interface of `kill-hooks', +;;; so I add it. (1997-11-03 by MORIOKA Tomohiko) + +(defvar interprogram-cut-function nil + "Function to call to make a killed region available to other programs. + +Most window systems provide some sort of facility for cutting and +pasting text between the windows of different programs. +This variable holds a function that Emacs calls whenever text +is put in the kill ring, to make the new kill available to other +programs. + +The function takes one or two arguments. +The first argument, TEXT, is a string containing +the text which should be made available. +The second, PUSH, if non-nil means this is a \"new\" kill; +nil means appending to an \"old\" kill.") + +(defvar interprogram-paste-function nil + "Function to call to get text cut from other programs. + +Most window systems provide some sort of facility for cutting and +pasting text between the windows of different programs. +This variable holds a function that Emacs calls to obtain +text that other programs have provided for pasting. + +The function should be called with no arguments. If the function +returns nil, then no other program has provided such text, and the top +of the Emacs kill ring should be used. If the function returns a +string, that string should be put in the kill ring as the latest kill. + +Note that the function should return a string only if a program other +than Emacs has provided a string for pasting; if Emacs provided the +most recent string, the function should return nil. If it is +difficult to tell whether Emacs or some other program provided the +current string, it is probably good enough to return nil if the string +is equal (according to `string=') to the last text Emacs provided.") + + +;;;; The kill ring data structure. + +(defvar kill-ring nil + "List of killed text sequences. +Since the kill ring is supposed to interact nicely with cut-and-paste +facilities offered by window systems, use of this variable should +interact nicely with `interprogram-cut-function' and +`interprogram-paste-function'. The functions `kill-new', +`kill-append', and `current-kill' are supposed to implement this +interaction; you may want to use them instead of manipulating the kill +ring directly.") + +(defcustom kill-ring-max 30 + "*Maximum length of kill ring before oldest elements are thrown away." + :type 'integer + :group 'killing) + +(defvar kill-ring-yank-pointer nil + "The tail of the kill ring whose car is the last thing yanked.") + +(defun kill-new (string &optional replace) + "Make STRING the latest kill in the kill ring. +Set the kill-ring-yank pointer to point to it. +Run `kill-hooks'. +Optional second argument REPLACE non-nil means that STRING will replace +the front of the kill ring, rather than being added to the list." +; (and (fboundp 'menu-bar-update-yank-menu) +; (menu-bar-update-yank-menu string (and replace (car kill-ring)))) + (if replace + (setcar kill-ring string) + (setq kill-ring (cons string kill-ring)) + (if (> (length kill-ring) kill-ring-max) + (setcdr (nthcdr (1- kill-ring-max) kill-ring) nil))) + (setq kill-ring-yank-pointer kill-ring) + (if interprogram-cut-function + (funcall interprogram-cut-function string (not replace))) + (run-hook-with-args 'kill-hooks string)) + +(defun kill-append (string before-p) + "Append STRING to the end of the latest kill in the kill ring. +If BEFORE-P is non-nil, prepend STRING to the kill. +Run `kill-hooks'." + (kill-new (if before-p + (concat string (car kill-ring)) + (concat (car kill-ring) string)) t)) + +(defun current-kill (n &optional do-not-move) + "Rotate the yanking point by N places, and then return that kill. +If N is zero, `interprogram-paste-function' is set, and calling it +returns a string, then that string is added to the front of the +kill ring and returned as the latest kill. +If optional arg DO-NOT-MOVE is non-nil, then don't actually move the +yanking point\; just return the Nth kill forward." + (let ((interprogram-paste (and (= n 0) + interprogram-paste-function + (funcall interprogram-paste-function)))) + (if interprogram-paste + (progn + ;; Disable the interprogram cut function when we add the new + ;; text to the kill ring, so Emacs doesn't try to own the + ;; selection, with identical text. + (let ((interprogram-cut-function nil)) + (kill-new interprogram-paste)) + interprogram-paste) + (or kill-ring (error "Kill ring is empty")) + (let* ((tem (nthcdr (mod (- n (length kill-ring-yank-pointer)) + (length kill-ring)) + kill-ring))) + (or do-not-move + (setq kill-ring-yank-pointer tem)) + (car tem))))) + + + +;;;; Commands for manipulating the kill ring. + +;; In FSF killing read-only text just pastes it into kill-ring. Which +;; is a very bad idea -- see Jamie's comment below. + +;(defvar kill-read-only-ok nil +; "*Non-nil means don't signal an error for killing read-only text.") + +(defun kill-region (beg end &optional verbose) ; verbose is XEmacs addition + "Kill between point and mark. +The text is deleted but saved in the kill ring. +The command \\[yank] can retrieve it from there. +\(If you want to kill and then yank immediately, use \\[copy-region-as-kill].) + +This is the primitive for programs to kill text (as opposed to deleting it). +Supply two arguments, character numbers indicating the stretch of text + to be killed. +Any command that calls this function is a \"kill command\". +If the previous command was also a kill command, +the text killed this time appends to the text killed last time +to make one entry in the kill ring." + (interactive "*r\np") +; (interactive +; (let ((region-hack (and zmacs-regions (eq last-command 'yank)))) +; ;; This lets "^Y^W" work. I think this is dumb, but zwei did it. +; (if region-hack (zmacs-activate-region)) +; (prog1 +; (list (point) (mark) current-prefix-arg) +; (if region-hack (zmacs-deactivate-region))))) + ;; beg and end can be markers but the rest of this function is + ;; written as if they are only integers + (if (markerp beg) (setq beg (marker-position beg))) + (if (markerp end) (setq end (marker-position end))) + (or (and beg end) (if zmacs-regions ;; rewritten for I18N3 snarfing + (error "The region is not active now") + (error "The mark is not set now"))) + (if verbose (if buffer-read-only + (display-message + 'command + (format "Copying %d characters" + (- (max beg end) (min beg end)))) + (display-message + 'command + (format "Killing %d characters" + (- (max beg end) (min beg end)))))) + (cond + + ;; I don't like this large change in behavior -- jwz + ;; Read-Only text means it shouldn't be deleted, so I'm restoring + ;; this code, but only for text-properties and not full extents. -sb + ;; If the buffer is read-only, we should beep, in case the person + ;; just isn't aware of this. However, there's no harm in putting + ;; the region's text in the kill ring, anyway. + ((or (and buffer-read-only (not inhibit-read-only)) + (text-property-not-all (min beg end) (max beg end) 'read-only nil)) + ;; This is redundant. + ;; (if verbose (message "Copying %d characters" + ;; (- (max beg end) (min beg end)))) + (copy-region-as-kill beg end) + ;; ;; This should always barf, and give us the correct error. + ;; (if kill-read-only-ok + ;; (message "Read only text copied to kill ring") + (setq this-command 'kill-region) + (barf-if-buffer-read-only) + (signal 'buffer-read-only (list (current-buffer)))) + + ;; In certain cases, we can arrange for the undo list and the kill + ;; ring to share the same string object. This code does that. + ((not (or (eq buffer-undo-list t) + (eq last-command 'kill-region) + ;; Use = since positions may be numbers or markers. + (= beg end))) + ;; Don't let the undo list be truncated before we can even access it. + ;; FSF calls this `undo-strong-limit' + (let ((undo-high-threshold (+ (- end beg) 100)) + ;(old-list buffer-undo-list) + tail) + (delete-region beg end) + ;; Search back in buffer-undo-list for this string, + ;; in case a change hook made property changes. + (setq tail buffer-undo-list) + (while (and tail + (not (stringp (car-safe (car-safe tail))))) ; XEmacs + (pop tail)) + ;; Take the same string recorded for undo + ;; and put it in the kill-ring. + (and tail + (kill-new (car (car tail)))))) + + (t + ;; if undo is not kept, grab the string then delete it (which won't + ;; add another string to the undo list). + (copy-region-as-kill beg end) + (delete-region beg end))) + (setq this-command 'kill-region)) + +;; copy-region-as-kill no longer sets this-command, because it's confusing +;; to get two copies of the text when the user accidentally types M-w and +;; then corrects it with the intended C-w. +(defun copy-region-as-kill (beg end) + "Save the region as if killed, but don't kill it. +Run `kill-hooks'." + (interactive "r") + (if (eq last-command 'kill-region) + (kill-append (buffer-substring beg end) (< end beg)) + (kill-new (buffer-substring beg end))) + nil) + +(defun kill-ring-save (beg end) + "Save the region as if killed, but don't kill it. +This command is similar to `copy-region-as-kill', except that it gives +visual feedback indicating the extent of the region being copied." + (interactive "r") + (copy-region-as-kill beg end) + ;; copy before delay, for xclipboard's benefit + (if (interactive-p) + (let ((other-end (if (= (point) beg) end beg)) + (opoint (point)) + ;; Inhibit quitting so we can make a quit here + ;; look like a C-g typed as a command. + (inhibit-quit t)) + (if (pos-visible-in-window-p other-end (selected-window)) + (progn + ;; FSF (I'm not sure what this does -sb) +; ;; Swap point and mark. +; (set-marker (mark-marker) (point) (current-buffer)) + (goto-char other-end) + (sit-for 1) +; ;; Swap back. +; (set-marker (mark-marker) other-end (current-buffer)) + (goto-char opoint) + ;; If user quit, deactivate the mark + ;; as C-g would as a command. + (and quit-flag (mark) + (zmacs-deactivate-region))) + ;; too noisy. -- jwz +; (let* ((killed-text (current-kill 0)) +; (message-len (min (length killed-text) 40))) +; (if (= (point) beg) +; ;; Don't say "killed"; that is misleading. +; (message "Saved text until \"%s\"" +; (substring killed-text (- message-len))) +; (message "Saved text from \"%s\"" +; (substring killed-text 0 message-len)))) + )))) + +(defun append-next-kill () + "Cause following command, if it kills, to append to previous kill." + ;; XEmacs + (interactive "_") + (if (interactive-p) + (progn + (setq this-command 'kill-region) + (display-message 'command + "If the next command is a kill, it will append")) + (setq last-command 'kill-region))) + +(defun yank-pop (arg) + "Replace just-yanked stretch of killed text with a different stretch. +This command is allowed only immediately after a `yank' or a `yank-pop'. +At such a time, the region contains a stretch of reinserted +previously-killed text. `yank-pop' deletes that text and inserts in its +place a different stretch of killed text. + +With no argument, the previous kill is inserted. +With argument N, insert the Nth previous kill. +If N is negative, this is a more recent kill. + +The sequence of kills wraps around, so that after the oldest one +comes the newest one." + (interactive "*p") + (if (not (eq last-command 'yank)) + (error "Previous command was not a yank")) + (setq this-command 'yank) + (let ((inhibit-read-only t) + (before (< (point) (mark t)))) + (delete-region (point) (mark t)) + ;;(set-marker (mark-marker) (point) (current-buffer)) + (set-mark (point)) + (insert (current-kill arg)) + (if before + ;; This is like exchange-point-and-mark, but doesn't activate the mark. + ;; It is cleaner to avoid activation, even though the command + ;; loop would deactivate the mark because we inserted text. + (goto-char (prog1 (mark t) + (set-marker (mark-marker t) (point) (current-buffer)))))) + nil) + + +(defun yank (&optional arg) + "Reinsert the last stretch of killed text. +More precisely, reinsert the stretch of killed text most recently +killed OR yanked. Put point at end, and set mark at beginning. +With just C-u as argument, same but put point at beginning (and mark at end). +With argument N, reinsert the Nth most recently killed stretch of killed +text. +See also the command \\[yank-pop]." + (interactive "*P") + ;; If we don't get all the way through, make last-command indicate that + ;; for the following command. + (setq this-command t) + (push-mark (point)) + (insert (current-kill (cond + ((listp arg) 0) + ((eq arg '-) -1) + (t (1- arg))))) + (if (consp arg) + ;; This is like exchange-point-and-mark, but doesn't activate the mark. + ;; It is cleaner to avoid activation, even though the command + ;; loop would deactivate the mark because we inserted text. + ;; (But it's an unnecessary kludge in XEmacs.) + ;(goto-char (prog1 (mark t) + ;(set-marker (mark-marker) (point) (current-buffer))))) + (exchange-point-and-mark t)) + ;; If we do get all the way thru, make this-command indicate that. + (setq this-command 'yank) + nil) + +(defun rotate-yank-pointer (arg) + "Rotate the yanking point in the kill ring. +With argument, rotate that many kills forward (or backward, if negative)." + (interactive "p") + (current-kill arg)) + + +(defun insert-buffer (buffer) + "Insert after point the contents of BUFFER. +Puts mark after the inserted text. +BUFFER may be a buffer or a buffer name." + (interactive + (list + (progn + (barf-if-buffer-read-only) + (read-buffer "Insert buffer: " + ;; XEmacs: we have different args + (other-buffer (current-buffer) nil t) + t)))) + (or (bufferp buffer) + (setq buffer (get-buffer buffer))) + (let (start end newmark) + (save-excursion + (save-excursion + (set-buffer buffer) + (setq start (point-min) end (point-max))) + (insert-buffer-substring buffer start end) + (setq newmark (point))) + (push-mark newmark)) + nil) + +(defun append-to-buffer (buffer start end) + "Append to specified buffer the text of the region. +It is inserted into that buffer before its point. + +When calling from a program, give three arguments: +BUFFER (or buffer name), START and END. +START and END specify the portion of the current buffer to be copied." + (interactive + ;; XEmacs: we have different args to other-buffer + (list (read-buffer "Append to buffer: " (other-buffer (current-buffer) + nil t)) + (region-beginning) (region-end))) + (let ((oldbuf (current-buffer))) + (save-excursion + (set-buffer (get-buffer-create buffer)) + (insert-buffer-substring oldbuf start end)))) + +(defun prepend-to-buffer (buffer start end) + "Prepend to specified buffer the text of the region. +It is inserted into that buffer after its point. + +When calling from a program, give three arguments: +BUFFER (or buffer name), START and END. +START and END specify the portion of the current buffer to be copied." + (interactive "BPrepend to buffer: \nr") + (let ((oldbuf (current-buffer))) + (save-excursion + (set-buffer (get-buffer-create buffer)) + (save-excursion + (insert-buffer-substring oldbuf start end))))) + +(defun copy-to-buffer (buffer start end) + "Copy to specified buffer the text of the region. +It is inserted into that buffer, replacing existing text there. + +When calling from a program, give three arguments: +BUFFER (or buffer name), START and END. +START and END specify the portion of the current buffer to be copied." + (interactive "BCopy to buffer: \nr") + (let ((oldbuf (current-buffer))) + (save-excursion + (set-buffer (get-buffer-create buffer)) + (erase-buffer) + (save-excursion + (insert-buffer-substring oldbuf start end))))) + +;FSFmacs +;(put 'mark-inactive 'error-conditions '(mark-inactive error)) +;(put 'mark-inactive 'error-message "The mark is not active now") + +(defun mark (&optional force buffer) + "Return this buffer's mark value as integer, or nil if no mark. + +If `zmacs-regions' is true, then this returns nil unless the region is +currently in the active (highlighted) state. With an argument of t, this +returns the mark (if there is one) regardless of the active-region state. +You should *generally* not use the mark unless the region is active, if +the user has expressed a preference for the active-region model. + +If you are using this in an editing command, you are most likely making +a mistake; see the documentation of `set-mark'." + (setq buffer (decode-buffer buffer)) +;FSFmacs version: +; (if (or force (not transient-mark-mode) mark-active mark-even-if-inactive) +; (marker-position (mark-marker)) +; (signal 'mark-inactive nil))) + (let ((m (mark-marker force buffer))) + (and m (marker-position m)))) + +;;;#### FSFmacs +;;; Many places set mark-active directly, and several of them failed to also +;;; run deactivate-mark-hook. This shorthand should simplify. +;(defsubst deactivate-mark () +; "Deactivate the mark by setting `mark-active' to nil. +;\(That makes a difference only in Transient Mark mode.) +;Also runs the hook `deactivate-mark-hook'." +; (if transient-mark-mode +; (progn +; (setq mark-active nil) +; (run-hooks 'deactivate-mark-hook)))) + +(defun set-mark (pos &optional buffer) + "Set this buffer's mark to POS. Don't use this function! +That is to say, don't use this function unless you want +the user to see that the mark has moved, and you want the previous +mark position to be lost. + +Normally, when a new mark is set, the old one should go on the stack. +This is why most applications should use push-mark, not set-mark. + +Novice Emacs Lisp programmers often try to use the mark for the wrong +purposes. The mark saves a location for the user's convenience. +Most editing commands should not alter the mark. +To remember a location for internal use in the Lisp program, +store it in a Lisp variable. Example: + + (let ((beg (point))) (forward-line 1) (delete-region beg (point)))." + + (setq buffer (decode-buffer buffer)) + (set-marker (mark-marker t buffer) pos buffer)) +;; FSF +; (if pos +; (progn +; (setq mark-active t) +; (run-hooks 'activate-mark-hook) +; (set-marker (mark-marker) pos (current-buffer))) +; ;; Normally we never clear mark-active except in Transient Mark mode. +; ;; But when we actually clear out the mark value too, +; ;; we must clear mark-active in any mode. +; (setq mark-active nil) +; (run-hooks 'deactivate-mark-hook) +; (set-marker (mark-marker) nil))) + +(defvar mark-ring nil + "The list of former marks of the current buffer, most recent first.") +(make-variable-buffer-local 'mark-ring) +(put 'mark-ring 'permanent-local t) + +(defcustom mark-ring-max 16 + "*Maximum size of mark ring. Start discarding off end if gets this big." + :type 'integer + :group 'killing) + +(defvar global-mark-ring nil + "The list of saved global marks, most recent first.") + +(defcustom global-mark-ring-max 16 + "*Maximum size of global mark ring. \ +Start discarding off end if gets this big." + :type 'integer + :group 'killing) + +(defun set-mark-command (arg) + "Set mark at where point is, or jump to mark. +With no prefix argument, set mark, push old mark position on local mark +ring, and push mark on global mark ring. +With argument, jump to mark, and pop a new position for mark off the ring +\(does not affect global mark ring\). + +Novice Emacs Lisp programmers often try to use the mark for the wrong +purposes. See the documentation of `set-mark' for more information." + (interactive "P") + (if (null arg) + (push-mark nil nil t) + (if (null (mark t)) + (error "No mark set in this buffer") + (goto-char (mark t)) + (pop-mark)))) + +;; XEmacs: Extra parameter +(defun push-mark (&optional location nomsg activate-region buffer) + "Set mark at LOCATION (point, by default) and push old mark on mark ring. +If the last global mark pushed was not in the current buffer, +also push LOCATION on the global mark ring. +Display `Mark set' unless the optional second arg NOMSG is non-nil. +Activate mark if optional third arg ACTIVATE-REGION non-nil. + +Novice Emacs Lisp programmers often try to use the mark for the wrong +purposes. See the documentation of `set-mark' for more information." + (setq buffer (decode-buffer buffer)) ; XEmacs + (if (null (mark t buffer)) ; XEmacs + nil + ;; The save-excursion / set-buffer is necessary because mark-ring + ;; is a buffer local variable + (save-excursion + (set-buffer buffer) + (setq mark-ring (cons (copy-marker (mark-marker t buffer)) mark-ring)) + (if (> (length mark-ring) mark-ring-max) + (progn + (move-marker (car (nthcdr mark-ring-max mark-ring)) nil buffer) + (setcdr (nthcdr (1- mark-ring-max) mark-ring) nil))))) + (set-mark (or location (point buffer)) buffer) +; (set-marker (mark-marker) (or location (point)) (current-buffer)) ; FSF + ;; Now push the mark on the global mark ring. + (if (or (null global-mark-ring) + (not (eq (marker-buffer (car global-mark-ring)) buffer))) + ;; The last global mark pushed wasn't in this same buffer. + (progn + (setq global-mark-ring (cons (copy-marker (mark-marker t buffer)) + global-mark-ring)) + (if (> (length global-mark-ring) global-mark-ring-max) + (progn + (move-marker (car (nthcdr global-mark-ring-max global-mark-ring)) + nil buffer) + (setcdr (nthcdr (1- global-mark-ring-max) global-mark-ring) nil))))) + (or nomsg executing-kbd-macro (> (minibuffer-depth) 0) + (display-message 'command "Mark set")) + (if activate-region + (progn + (setq zmacs-region-stays t) + (zmacs-activate-region))) +; (if (or activate (not transient-mark-mode)) ; FSF +; (set-mark (mark t))) ; FSF + nil) + +(defun pop-mark () + "Pop off mark ring into the buffer's actual mark. +Does not set point. Does nothing if mark ring is empty." + (if mark-ring + (progn + (setq mark-ring (nconc mark-ring (list (copy-marker (mark-marker t))))) + (set-mark (car mark-ring)) + (move-marker (car mark-ring) nil) + (if (null (mark t)) (ding)) + (setq mark-ring (cdr mark-ring))))) + +(define-function 'exchange-dot-and-mark 'exchange-point-and-mark) +(defun exchange-point-and-mark (&optional dont-activate-region) + "Put the mark where point is now, and point where the mark is now. +The mark is activated unless DONT-ACTIVATE-REGION is non-nil." + (interactive nil) + (let ((omark (mark t))) + (if (null omark) + (error "No mark set in this buffer")) + (set-mark (point)) + (goto-char omark) + (or dont-activate-region (zmacs-activate-region)) ; XEmacs + nil)) + +;; XEmacs +(defun mark-something (mark-fn movement-fn arg) + "internal function used by mark-sexp, mark-word, etc." + (let (newmark (pushp t)) + (save-excursion + (if (and (eq last-command mark-fn) (mark)) + ;; Extend the previous state in the same direction: + (progn + (if (< (mark) (point)) (setq arg (- arg))) + (goto-char (mark)) + (setq pushp nil))) + (funcall movement-fn arg) + (setq newmark (point))) + (if pushp + (push-mark newmark nil t) + ;; Do not mess with the mark stack, but merely adjust the previous state: + (set-mark newmark) + (activate-region)))) + +;(defun transient-mark-mode (arg) +; "Toggle Transient Mark mode. +;With arg, turn Transient Mark mode on if arg is positive, off otherwise. +; +;In Transient Mark mode, when the mark is active, the region is highlighted. +;Changing the buffer \"deactivates\" the mark. +;So do certain other operations that set the mark +;but whose main purpose is something else--for example, +;incremental search, \\[beginning-of-buffer], and \\[end-of-buffer]." +; (interactive "P") +; (setq transient-mark-mode +; (if (null arg) +; (not transient-mark-mode) +; (> (prefix-numeric-value arg) 0)))) + +(defun pop-global-mark () + "Pop off global mark ring and jump to the top location." + (interactive) + ;; Pop entries which refer to non-existent buffers. + (while (and global-mark-ring (not (marker-buffer (car global-mark-ring)))) + (setq global-mark-ring (cdr global-mark-ring))) + (or global-mark-ring + (error "No global mark set")) + (let* ((marker (car global-mark-ring)) + (buffer (marker-buffer marker)) + (position (marker-position marker))) + (setq global-mark-ring (nconc (cdr global-mark-ring) + (list (car global-mark-ring)))) + (set-buffer buffer) + (or (and (>= position (point-min)) + (<= position (point-max))) + (widen)) + (goto-char position) + (switch-to-buffer buffer))) + + +;;; After 8 years of waiting ... -sb +(defcustom next-line-add-newlines nil ; XEmacs + "*If non-nil, `next-line' inserts newline when the point is at end of buffer. +This behavior used to be the default, and is still default in FSF Emacs. +We think it is an unnecessary and unwanted side-effect." + :type 'boolean + :group 'editing-basics) + +(defun next-line (arg) + "Move cursor vertically down ARG lines. +If there is no character in the target line exactly under the current column, +the cursor is positioned after the character in that line which spans this +column, or at the end of the line if it is not long enough. + +If there is no line in the buffer after this one, behavior depends on the +value of `next-line-add-newlines'. If non-nil, it inserts a newline character +to create a line, and moves the cursor to that line. Otherwise it moves the +cursor to the end of the buffer. + +The command \\[set-goal-column] can be used to create +a semipermanent goal column to which this command always moves. +Then it does not try to move vertically. This goal column is stored +in `goal-column', which is nil when there is none. + +If you are thinking of using this in a Lisp program, consider +using `forward-line' instead. It is usually easier to use +and more reliable (no dependence on goal column, etc.)." + (interactive "_p") ; XEmacs + (if (and next-line-add-newlines (= arg 1)) + (let ((opoint (point))) + (end-of-line) + (if (eobp) + (newline 1) + (goto-char opoint) + (line-move arg))) + (if (interactive-p) + ;; XEmacs: Not sure what to do about this. It's inconsistent. -sb + (condition-case nil + (line-move arg) + ((beginning-of-buffer end-of-buffer) + (when signal-error-on-buffer-boundary + (ding nil 'buffer-bound)))) + (line-move arg))) + nil) + +(defun previous-line (arg) + "Move cursor vertically up ARG lines. +If there is no character in the target line exactly over the current column, +the cursor is positioned after the character in that line which spans this +column, or at the end of the line if it is not long enough. + +The command \\[set-goal-column] can be used to create +a semipermanent goal column to which this command always moves. +Then it does not try to move vertically. + +If you are thinking of using this in a Lisp program, consider using +`forward-line' with a negative argument instead. It is usually easier +to use and more reliable (no dependence on goal column, etc.)." + (interactive "_p") ; XEmacs + (if (interactive-p) + (condition-case nil + (line-move (- arg)) + ((beginning-of-buffer end-of-buffer) + (when signal-error-on-buffer-boundary ; XEmacs + (ding nil 'buffer-bound)))) + (line-move (- arg))) + nil) + +(defcustom track-eol nil + "*Non-nil means vertical motion starting at end of line keeps to ends of lines. +This means moving to the end of each line moved onto. +The beginning of a blank line does not count as the end of a line." + :type 'boolean + :group 'editing-basics) + +(defcustom goal-column nil + "*Semipermanent goal column for vertical motion, as set by \\[set-goal-column], or nil." + :type '(choice integer (const :tag "None" nil)) + :group 'editing-basics) +(make-variable-buffer-local 'goal-column) + +(defvar temporary-goal-column 0 + "Current goal column for vertical motion. +It is the column where point was +at the start of current run of vertical motion commands. +When the `track-eol' feature is doing its job, the value is 9999.") + +;XEmacs: not yet ported, so avoid compiler warnings +(eval-when-compile + (defvar inhibit-point-motion-hooks)) + +(defcustom line-move-ignore-invisible nil + "*Non-nil means \\[next-line] and \\[previous-line] ignore invisible lines. +Use with care, as it slows down movement significantly. Outline mode sets this." + :type 'boolean + :group 'editing-basics) + +;; This is the guts of next-line and previous-line. +;; Arg says how many lines to move. +(defun line-move (arg) + ;; Don't run any point-motion hooks, and disregard intangibility, + ;; for intermediate positions. + (let ((inhibit-point-motion-hooks t) + (opoint (point)) + new) + (unwind-protect + (progn + (if (not (or (eq last-command 'next-line) + (eq last-command 'previous-line))) + (setq temporary-goal-column + (if (and track-eol (eolp) + ;; Don't count beg of empty line as end of line + ;; unless we just did explicit end-of-line. + (or (not (bolp)) (eq last-command 'end-of-line))) + 9999 + (current-column)))) + (if (and (not (integerp selective-display)) + (not line-move-ignore-invisible)) + ;; Use just newline characters. + (or (if (> arg 0) + (progn (if (> arg 1) (forward-line (1- arg))) + ;; This way of moving forward ARG lines + ;; verifies that we have a newline after the last one. + ;; It doesn't get confused by intangible text. + (end-of-line) + (zerop (forward-line 1))) + (and (zerop (forward-line arg)) + (bolp))) + (signal (if (< arg 0) + 'beginning-of-buffer + 'end-of-buffer) + nil)) + ;; Move by arg lines, but ignore invisible ones. + (while (> arg 0) + (end-of-line) + (and (zerop (vertical-motion 1)) + (signal 'end-of-buffer nil)) + ;; If the following character is currently invisible, + ;; skip all characters with that same `invisible' property value. + (while (and (not (eobp)) + (let ((prop + (get-char-property (point) 'invisible))) + (if (eq buffer-invisibility-spec t) + prop + (or (memq prop buffer-invisibility-spec) + (assq prop buffer-invisibility-spec))))) + (if (get-text-property (point) 'invisible) + (goto-char (next-single-property-change (point) 'invisible)) + (goto-char (next-extent-change (point))))) ; XEmacs + (setq arg (1- arg))) + (while (< arg 0) + (beginning-of-line) + (and (zerop (vertical-motion -1)) + (signal 'beginning-of-buffer nil)) + (while (and (not (bobp)) + (let ((prop + (get-char-property (1- (point)) 'invisible))) + (if (eq buffer-invisibility-spec t) + prop + (or (memq prop buffer-invisibility-spec) + (assq prop buffer-invisibility-spec))))) + (if (get-text-property (1- (point)) 'invisible) + (goto-char (previous-single-property-change (point) 'invisible)) + (goto-char (previous-extent-change (point))))) ; XEmacs + (setq arg (1+ arg)))) + (move-to-column (or goal-column temporary-goal-column))) + ;; Remember where we moved to, go back home, + ;; then do the motion over again + ;; in just one step, with intangibility and point-motion hooks + ;; enabled this time. + (setq new (point)) + (goto-char opoint) + (setq inhibit-point-motion-hooks nil) + (goto-char new))) + nil) + +;;; Many people have said they rarely use this feature, and often type +;;; it by accident. Maybe it shouldn't even be on a key. +;; It's not on a key, as of 20.2. So no need for this. +;(put 'set-goal-column 'disabled t) + +(defun set-goal-column (arg) + "Set the current horizontal position as a goal for \\[next-line] and \\[previous-line]. +Those commands will move to this position in the line moved to +rather than trying to keep the same horizontal position. +With a non-nil argument, clears out the goal column +so that \\[next-line] and \\[previous-line] resume vertical motion. +The goal column is stored in the variable `goal-column'." + (interactive "_P") ; XEmacs + (if arg + (progn + (setq goal-column nil) + (display-message 'command "No goal column")) + (setq goal-column (current-column)) + (message (substitute-command-keys + "Goal column %d (use \\[set-goal-column] with an arg to unset it)") + goal-column)) + nil) + +;; deleted FSFmacs terminal randomness hscroll-point-visible stuff. +;; hscroll-step +;; hscroll-point-visible +;; hscroll-window-column +;; right-arrow +;; left-arrow + +(defun scroll-other-window-down (lines) + "Scroll the \"other window\" down. +For more details, see the documentation for `scroll-other-window'." + (interactive "P") + (scroll-other-window + ;; Just invert the argument's meaning. + ;; We can do that without knowing which window it will be. + (if (eq lines '-) nil + (if (null lines) '- + (- (prefix-numeric-value lines)))))) +;(define-key esc-map [?\C-\S-v] 'scroll-other-window-down) + +(defun beginning-of-buffer-other-window (arg) + "Move point to the beginning of the buffer in the other window. +Leave mark at previous position. +With arg N, put point N/10 of the way from the true beginning." + (interactive "P") + (let ((orig-window (selected-window)) + (window (other-window-for-scrolling))) + ;; We use unwind-protect rather than save-window-excursion + ;; because the latter would preserve the things we want to change. + (unwind-protect + (progn + (select-window window) + ;; Set point and mark in that window's buffer. + (beginning-of-buffer arg) + ;; Set point accordingly. + (recenter '(t))) + (select-window orig-window)))) + +(defun end-of-buffer-other-window (arg) + "Move point to the end of the buffer in the other window. +Leave mark at previous position. +With arg N, put point N/10 of the way from the true end." + (interactive "P") + ;; See beginning-of-buffer-other-window for comments. + (let ((orig-window (selected-window)) + (window (other-window-for-scrolling))) + (unwind-protect + (progn + (select-window window) + (end-of-buffer arg) + (recenter '(t))) + (select-window orig-window)))) + +(defun transpose-chars (arg) + "Interchange characters around point, moving forward one character. +With prefix arg ARG, effect is to take character before point +and drag it forward past ARG other characters (backward if ARG negative). +If no argument and at end of line, the previous two chars are exchanged." + (interactive "*P") + (and (null arg) (eolp) (forward-char -1)) + (transpose-subr 'forward-char (prefix-numeric-value arg))) + +;;; A very old implementation of transpose-chars from the old days ... +(defun transpose-preceding-chars (arg) + "Interchange characters before point. +With prefix arg ARG, effect is to take character before point +and drag it forward past ARG other characters (backward if ARG negative). +If no argument and not at start of line, the previous two chars are exchanged." + (interactive "*P") + (and (null arg) (not (bolp)) (forward-char -1)) + (transpose-subr 'forward-char (prefix-numeric-value arg))) + + +(defun transpose-words (arg) + "Interchange words around point, leaving point at end of them. +With prefix arg ARG, effect is to take word before or around point +and drag it forward past ARG other words (backward if ARG negative). +If ARG is zero, the words around or after point and around or after mark +are interchanged." + (interactive "*p") + (transpose-subr 'forward-word arg)) + +(defun transpose-sexps (arg) + "Like \\[transpose-words] but applies to sexps. +Does not work on a sexp that point is in the middle of +if it is a list or string." + (interactive "*p") + (transpose-subr 'forward-sexp arg)) + +(defun transpose-lines (arg) + "Exchange current line and previous line, leaving point after both. +With argument ARG, takes previous line and moves it past ARG lines. +With argument 0, interchanges line point is in with line mark is in." + (interactive "*p") + (transpose-subr #'(lambda (arg) + (if (= arg 1) + (progn + ;; Move forward over a line, + ;; but create a newline if none exists yet. + (end-of-line) + (if (eobp) + (newline) + (forward-char 1))) + (forward-line arg))) + arg)) + +(eval-when-compile + ;; avoid byte-compiler warnings... + (defvar start1) + (defvar start2) + (defvar end1) + (defvar end2)) + +; start[12] and end[12] used in transpose-subr-1 below +(defun transpose-subr (mover arg) + (let (start1 end1 start2 end2) + (if (= arg 0) + (progn + (save-excursion + (funcall mover 1) + (setq end2 (point)) + (funcall mover -1) + (setq start2 (point)) + (goto-char (mark t)) ; XEmacs + (funcall mover 1) + (setq end1 (point)) + (funcall mover -1) + (setq start1 (point)) + (transpose-subr-1)) + (exchange-point-and-mark t))) ; XEmacs + (while (> arg 0) + (funcall mover -1) + (setq start1 (point)) + (funcall mover 1) + (setq end1 (point)) + (funcall mover 1) + (setq end2 (point)) + (funcall mover -1) + (setq start2 (point)) + (transpose-subr-1) + (goto-char end2) + (setq arg (1- arg))) + (while (< arg 0) + (funcall mover -1) + (setq start2 (point)) + (funcall mover -1) + (setq start1 (point)) + (funcall mover 1) + (setq end1 (point)) + (funcall mover 1) + (setq end2 (point)) + (transpose-subr-1) + (setq arg (1+ arg))))) + +; start[12] and end[12] used free +(defun transpose-subr-1 () + (if (> (min end1 end2) (max start1 start2)) + (error "Don't have two things to transpose")) + (let ((word1 (buffer-substring start1 end1)) + (word2 (buffer-substring start2 end2))) + (delete-region start2 end2) + (goto-char start2) + (insert word1) + (goto-char (if (< start1 start2) start1 + (+ start1 (- (length word1) (length word2))))) + (delete-char (length word1)) + (insert word2))) + +(defcustom comment-column 32 + "*Column to indent right-margin comments to. +Setting this variable automatically makes it local to the current buffer. +Each mode establishes a different default value for this variable; you +can set the value for a particular mode using that mode's hook." + :type 'integer + :group 'fill-comments) +(make-variable-buffer-local 'comment-column) + +(defcustom comment-start nil + "*String to insert to start a new comment, or nil if no comment syntax." + :type '(choice (const :tag "None" nil) + string) + :group 'fill-comments) + +(defcustom comment-start-skip nil + "*Regexp to match the start of a comment plus everything up to its body. +If there are any \\(...\\) pairs, the comment delimiter text is held to begin +at the place matched by the close of the first pair." + :type '(choice (const :tag "None" nil) + regexp) + :group 'fill-comments) + +(defcustom comment-end "" + "*String to insert to end a new comment. +Should be an empty string if comments are terminated by end-of-line." + :type 'string + :group 'fill-comments) + +(defconst comment-indent-hook nil + "Obsolete variable for function to compute desired indentation for a comment. +Use `comment-indent-function' instead. +This function is called with no args with point at the beginning of +the comment's starting delimiter.") + +(defconst comment-indent-function + ;; XEmacs - add at least one space after the end of the text on the + ;; current line... + (lambda () + (save-excursion + (beginning-of-line) + (let ((eol (save-excursion (end-of-line) (point)))) + (and comment-start-skip + (re-search-forward comment-start-skip eol t) + (setq eol (match-beginning 0))) + (goto-char eol) + (skip-chars-backward " \t") + (max comment-column (1+ (current-column)))))) + "Function to compute desired indentation for a comment. +This function is called with no args with point at the beginning of +the comment's starting delimiter.") + +(defcustom block-comment-start nil + "*String to insert to start a new comment on a line by itself. +If nil, use `comment-start' instead. +Note that the regular expression `comment-start-skip' should skip this string +as well as the `comment-start' string." + :type '(choice (const :tag "Use `comment-start'" nil) + string) + :group 'fill-comments) + +(defcustom block-comment-end nil + "*String to insert to end a new comment on a line by itself. +Should be an empty string if comments are terminated by end-of-line. +If nil, use `comment-end' instead." + :type '(choice (const :tag "Use `comment-end'" nil) + string) + :group 'fill-comments) + +(defun indent-for-comment () + "Indent this line's comment to comment column, or insert an empty comment." + (interactive "*") + (let* ((empty (save-excursion (beginning-of-line) + (looking-at "[ \t]*$"))) + (starter (or (and empty block-comment-start) comment-start)) + (ender (or (and empty block-comment-end) comment-end))) + (if (null starter) + (error "No comment syntax defined") + (let* ((eolpos (save-excursion (end-of-line) (point))) + cpos indent begpos) + (beginning-of-line) + (if (re-search-forward comment-start-skip eolpos 'move) + (progn (setq cpos (point-marker)) + ;; Find the start of the comment delimiter. + ;; If there were paren-pairs in comment-start-skip, + ;; position at the end of the first pair. + (if (match-end 1) + (goto-char (match-end 1)) + ;; If comment-start-skip matched a string with + ;; internal whitespace (not final whitespace) then + ;; the delimiter start at the end of that + ;; whitespace. Otherwise, it starts at the + ;; beginning of what was matched. + (skip-syntax-backward " " (match-beginning 0)) + (skip-syntax-backward "^ " (match-beginning 0))))) + (setq begpos (point)) + ;; Compute desired indent. + (if (= (current-column) + (setq indent (funcall comment-indent-function))) + (goto-char begpos) + ;; If that's different from current, change it. + (skip-chars-backward " \t") + (delete-region (point) begpos) + (indent-to indent)) + ;; An existing comment? + (if cpos + (progn (goto-char cpos) + (set-marker cpos nil)) + ;; No, insert one. + (insert starter) + (save-excursion + (insert ender))))))) + +(defun set-comment-column (arg) + "Set the comment column based on point. +With no arg, set the comment column to the current column. +With just minus as arg, kill any comment on this line. +With any other arg, set comment column to indentation of the previous comment + and then align or create a comment on this line at that column." + (interactive "P") + (if (eq arg '-) + (kill-comment nil) + (if arg + (progn + (save-excursion + (beginning-of-line) + (re-search-backward comment-start-skip) + (beginning-of-line) + (re-search-forward comment-start-skip) + (goto-char (match-beginning 0)) + (setq comment-column (current-column)) + (display-message + 'command + (format "Comment column set to %d" comment-column))) + (indent-for-comment)) + (setq comment-column (current-column)) + (display-message + 'command + (format "Comment column set to %d" comment-column))))) + +(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 + ;; 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. + (interactive "*P") + (or comment-start-skip (error "No comment syntax defined")) + (let ((count (prefix-numeric-value arg)) endc) + (while (> count 0) + (save-excursion + (end-of-line) + (setq endc (point)) + (beginning-of-line) + (and (string< "" comment-end) + (setq endc + (progn + (re-search-forward (regexp-quote comment-end) endc 'move) + (skip-chars-forward " \t") + (point)))) + (beginning-of-line) + (if (re-search-forward comment-start-skip endc t) + (progn + (goto-char (match-beginning 0)) + (skip-chars-backward " \t") + (kill-region (point) endc) + ;; to catch comments a line beginnings + (indent-according-to-mode)))) + (if arg (forward-line 1)) + (setq count (1- count))))) + +(defun comment-region (beg end &optional arg) + "Comment or uncomment each line in the region. +With just C-u prefix arg, uncomment each line in region. +Numeric prefix arg ARG means use ARG comment characters. +If ARG is negative, delete that many comment characters instead. +Comments are terminated on each line, even for syntax in which newline does +not end the comment. Blank lines do not get comments." + ;; if someone wants it to only put a comment-start at the beginning and + ;; comment-end at the end then typing it, C-x C-x, closing it, C-x C-x + ;; is easy enough. No option is made here for other than commenting + ;; every line. + (interactive "r\nP") + (or comment-start (error "No comment syntax is defined")) + (if (> beg end) (let (mid) (setq mid beg beg end end mid))) + (save-excursion + (save-restriction + (let ((cs comment-start) (ce comment-end) + numarg) + (if (consp arg) (setq numarg t) + (setq numarg (prefix-numeric-value arg)) + ;; For positive arg > 1, replicate the comment delims now, + ;; then insert the replicated strings just once. + (while (> numarg 1) + (setq cs (concat cs comment-start) + ce (concat ce comment-end)) + (setq numarg (1- numarg)))) + ;; Loop over all lines from BEG to END. + (narrow-to-region beg end) + (goto-char beg) + (while (not (eobp)) + (if (or (eq numarg t) (< numarg 0)) + (progn + ;; Delete comment start from beginning of line. + (if (eq numarg t) + (while (looking-at (regexp-quote cs)) + (delete-char (length cs))) + (let ((count numarg)) + (while (and (> 1 (setq count (1+ count))) + (looking-at (regexp-quote cs))) + (delete-char (length cs))))) + ;; Delete comment end from end of line. + (if (string= "" ce) + nil + (if (eq numarg t) + (progn + (end-of-line) + ;; This is questionable if comment-end ends in + ;; whitespace. That is pretty brain-damaged, + ;; though. + (skip-chars-backward " \t") + (if (and (>= (- (point) (point-min)) (length ce)) + (save-excursion + (backward-char (length ce)) + (looking-at (regexp-quote ce)))) + (delete-char (- (length ce))))) + (let ((count numarg)) + (while (> 1 (setq count (1+ count))) + (end-of-line) + ;; This is questionable if comment-end ends in + ;; whitespace. That is pretty brain-damaged though + (skip-chars-backward " \t") + (save-excursion + (backward-char (length ce)) + (if (looking-at (regexp-quote ce)) + (delete-char (length ce)))))))) + (forward-line 1)) + ;; Insert at beginning and at end. + (if (looking-at "[ \t]*$") () + (insert cs) + (if (string= "" ce) () + (end-of-line) + (insert ce))) + (search-forward "\n" nil 'move))))))) + +;; XEmacs +(defun prefix-region (prefix) + "Add a prefix string to each line between mark and point." + (interactive "sPrefix string: ") + (if prefix + (let ((count (count-lines (mark) (point)))) + (goto-char (min (mark) (point))) + (while (> count 0) + (setq count (1- count)) + (beginning-of-line 1) + (insert prefix) + (end-of-line 1) + (forward-char 1))))) + + +;; XEmacs - extra parameter +(defun backward-word (arg &optional buffer) + "Move backward until encountering the end of a word. +With argument, do this that many times. +In programs, it is faster to call `forward-word' with negative arg." + (interactive "_p") ; XEmacs + (forward-word (- arg) buffer)) + +(defun mark-word (arg) + "Set mark arg words away from point." + (interactive "p") + (mark-something 'mark-word 'forward-word arg)) + +;; XEmacs modified +(defun kill-word (arg) + "Kill characters forward until encountering the end of a word. +With argument, do this that many times." + (interactive "*p") + (kill-region (point) (save-excursion (forward-word arg) (point)))) + +(defun backward-kill-word (arg) + "Kill characters backward until encountering the end of a word. +With argument, do this that many times." + (interactive "*p") ; XEmacs + (kill-word (- arg))) + +(defun current-word (&optional strict) + "Return the word point is on (or a nearby word) as a string. +If optional arg STRICT is non-nil, return nil unless point is within +or adjacent to a word. +If point is not between two word-constituent characters, but immediately +follows one, move back first. +Otherwise, if point precedes a word constituent, move forward first. +Otherwise, move backwards until a word constituent is found and get that word; +if you a newlines is reached first, move forward instead." + (save-excursion + (let ((oldpoint (point)) (start (point)) (end (point))) + (skip-syntax-backward "w_") (setq start (point)) + (goto-char oldpoint) + (skip-syntax-forward "w_") (setq end (point)) + (if (and (eq start oldpoint) (eq end oldpoint)) + ;; Point is neither within nor adjacent to a word. + (and (not strict) + (progn + ;; Look for preceding word in same line. + (skip-syntax-backward "^w_" + (save-excursion + (beginning-of-line) (point))) + (if (bolp) + ;; No preceding word in same line. + ;; Look for following word in same line. + (progn + (skip-syntax-forward "^w_" + (save-excursion + (end-of-line) (point))) + (setq start (point)) + (skip-syntax-forward "w_") + (setq end (point))) + (setq end (point)) + (skip-syntax-backward "w_") + (setq start (point))) + (buffer-substring start end))) + (buffer-substring start end))))) + +(defcustom fill-prefix nil + "*String for filling to insert at front of new line, or nil for none. +Setting this variable automatically makes it local to the current buffer." + :type '(choice (const :tag "None" nil) + string) + :group 'fill) +(make-variable-buffer-local 'fill-prefix) + +(defcustom auto-fill-inhibit-regexp nil + "*Regexp to match lines which should not be auto-filled." + :type '(choice (const :tag "None" nil) + regexp) + :group 'fill) + +(defvar comment-line-break-function 'indent-new-comment-line + "*Mode-specific function which line breaks and continues a comment. + +This function is only called during auto-filling of a comment section. +The function should take a single optional argument which is a flag +indicating whether soft newlines should be inserted.") + +;; This function is the auto-fill-function of a buffer +;; when Auto-Fill mode is enabled. +;; It returns t if it really did any work. +;; XEmacs: This function is totally different. +(defun do-auto-fill () + (let (give-up) + (or (and auto-fill-inhibit-regexp + (save-excursion (beginning-of-line) + (looking-at auto-fill-inhibit-regexp))) + (while (and (not give-up) (> (current-column) fill-column)) + ;; Determine where to split the line. + (let ((fill-prefix fill-prefix) + (fill-point + (let ((opoint (point)) + bounce + ;; 97/3/14 jhod: Kinsoku + (re-break-point (if (featurep 'mule) + (concat "[ \t\n]\\|" word-across-newline) + "[ \t\n]")) + ;; end patch + (first t)) + (save-excursion + (move-to-column (1+ fill-column)) + ;; Move back to a word boundary. + (while (or first + ;; If this is after period and a single space, + ;; move back once more--we don't want to break + ;; the line there and make it look like a + ;; sentence end. + (and (not (bobp)) + (not bounce) + sentence-end-double-space + (save-excursion (forward-char -1) + (and (looking-at "\\. ") + (not (looking-at "\\. ")))))) + (setq first nil) + ;; 97/3/14 jhod: Kinsoku + ; (skip-chars-backward "^ \t\n")) + (fill-move-backward-to-break-point re-break-point) + ;; end patch + ;; If we find nowhere on the line to break it, + ;; break after one word. Set bounce to t + ;; so we will not keep going in this while loop. + (if (bolp) + (progn + ;; 97/3/14 jhod: Kinsoku + ; (re-search-forward "[ \t]" opoint t) + (fill-move-forward-to-break-point re-break-point + opoint) + ;; end patch + (setq bounce t))) + (skip-chars-backward " \t")) + (if (and (featurep 'mule) + (or bounce (bolp))) (kinsoku-process)) ;; 97/3/14 jhod: Kinsoku + ;; Let fill-point be set to the place where we end up. + (point))))) + + ;; I'm not sure why Stig made this change but it breaks + ;; auto filling in at least C mode so I'm taking it back + ;; out. --cet + ;; XEmacs - adaptive fill. + ;;(maybe-adapt-fill-prefix + ;; (or from (setq from (save-excursion (beginning-of-line) + ;; (point)))) + ;; (or to (setq to (save-excursion (beginning-of-line 2) + ;; (point)))) + ;; t) + + ;; If that place is not the beginning of the line, + ;; break the line there. + (if (save-excursion + (goto-char fill-point) + (not (or (bolp) (eolp)))) ; 97/3/14 jhod: during kinsoku processing it is possible to move beyond + (let ((prev-column (current-column))) + ;; If point is at the fill-point, do not `save-excursion'. + ;; Otherwise, if a comment prefix or fill-prefix is inserted, + ;; point will end up before it rather than after it. + (if (save-excursion + (skip-chars-backward " \t") + (= (point) fill-point)) + ;; 97/3/14 jhod: Kinsoku processing + ;(indent-new-comment-line) + (let ((spacep (memq (char-before (point)) '(?\ ?\t)))) + (funcall comment-line-break-function) + ;; if user type space explicitly, leave SPC + ;; even if there is no WAN. + (if spacep + (save-excursion + (goto-char fill-point) + ;; put SPC except that there is SPC + ;; already or there is sentence end. + (or (memq (char-after (point)) '(?\ ?\t)) + (fill-end-of-sentence-p) + (insert ?\ ))))) + (save-excursion + (goto-char fill-point) + (funcall comment-line-break-function))) + ;; If making the new line didn't reduce the hpos of + ;; the end of the line, then give up now; + ;; trying again will not help. + (if (>= (current-column) prev-column) + (setq give-up t))) + ;; No place to break => stop trying. + (setq give-up t))))))) + +;; Put FSF one in until I can one or the other working properly, then the +;; other one is history. +(defun fsf:do-auto-fill () + (let (fc justify + ;; bol + give-up + (fill-prefix fill-prefix)) + (if (or (not (setq justify (current-justification))) + (null (setq fc (current-fill-column))) + (and (eq justify 'left) + (<= (current-column) fc)) + (save-excursion (beginning-of-line) + ;; (setq bol (point)) + (and auto-fill-inhibit-regexp + (looking-at auto-fill-inhibit-regexp)))) + nil ;; Auto-filling not required + (if (memq justify '(full center right)) + (save-excursion (unjustify-current-line))) + + ;; Choose a fill-prefix automatically. + (if (and adaptive-fill-mode + (or (null fill-prefix) (string= fill-prefix ""))) + (let ((prefix + (fill-context-prefix + (save-excursion (backward-paragraph 1) (point)) + (save-excursion (forward-paragraph 1) (point)) + ;; Don't accept a non-whitespace fill prefix + ;; from the first line of a paragraph. + "^[ \t]*$"))) + (and prefix (not (equal prefix "")) + (setq fill-prefix prefix)))) + + (while (and (not give-up) (> (current-column) fc)) + ;; Determine where to split the line. + (let ((fill-point + (let ((opoint (point)) + bounce + (first t)) + (save-excursion + (move-to-column (1+ fc)) + ;; Move back to a word boundary. + (while (or first + ;; If this is after period and a single space, + ;; move back once more--we don't want to break + ;; the line there and make it look like a + ;; sentence end. + (and (not (bobp)) + (not bounce) + sentence-end-double-space + (save-excursion (forward-char -1) + (and (looking-at "\\. ") + (not (looking-at "\\. ")))))) + (setq first nil) + (skip-chars-backward "^ \t\n") + ;; If we find nowhere on the line to break it, + ;; break after one word. Set bounce to t + ;; so we will not keep going in this while loop. + (if (bolp) + (progn + (re-search-forward "[ \t]" opoint t) + (setq bounce t))) + (skip-chars-backward " \t")) + ;; Let fill-point be set to the place where we end up. + (point))))) + ;; If that place is not the beginning of the line, + ;; break the line there. + (if (save-excursion + (goto-char fill-point) + (not (bolp))) + (let ((prev-column (current-column))) + ;; If point is at the fill-point, do not `save-excursion'. + ;; Otherwise, if a comment prefix or fill-prefix is inserted, + ;; point will end up before it rather than after it. + (if (save-excursion + (skip-chars-backward " \t") + (= (point) fill-point)) + (funcall comment-line-break-function t) + (save-excursion + (goto-char fill-point) + (funcall comment-line-break-function t))) + ;; Now do justification, if required + (if (not (eq justify 'left)) + (save-excursion + (end-of-line 0) + (justify-current-line justify nil t))) + ;; If making the new line didn't reduce the hpos of + ;; the end of the line, then give up now; + ;; trying again will not help. + (if (>= (current-column) prev-column) + (setq give-up t))) + ;; No place to break => stop trying. + (setq give-up t)))) + ;; Justify last line. + (justify-current-line justify t t) + t))) + +(defvar normal-auto-fill-function 'do-auto-fill + "The function to use for `auto-fill-function' if Auto Fill mode is turned on. +Some major modes set this.") + +(defun auto-fill-mode (&optional arg) + "Toggle auto-fill mode. +With arg, turn auto-fill mode on if and only if arg is positive. +In Auto-Fill mode, inserting a space at a column beyond `current-fill-column' +automatically breaks the line at a previous space. + +The value of `normal-auto-fill-function' specifies the function to use +for `auto-fill-function' when turning Auto Fill mode on." + (interactive "P") + (prog1 (setq auto-fill-function + (if (if (null arg) + (not auto-fill-function) + (> (prefix-numeric-value arg) 0)) + normal-auto-fill-function + nil)) + (redraw-modeline))) + +;; This holds a document string used to document auto-fill-mode. +(defun auto-fill-function () + "Automatically break line at a previous space, in insertion of text." + nil) + +(defun turn-on-auto-fill () + "Unconditionally turn on Auto Fill mode." + (auto-fill-mode 1)) + +(defun set-fill-column (arg) + "Set `fill-column' to specified argument. +Just \\[universal-argument] as argument means to use the current column +The variable `fill-column' has a separate value for each buffer." + (interactive "_P") ; XEmacs + (cond ((integerp arg) + (setq fill-column arg)) + ((consp arg) + (setq fill-column (current-column))) + ;; Disallow missing argument; it's probably a typo for C-x C-f. + (t + (error "set-fill-column requires an explicit argument"))) + (display-message 'command (format "fill-column set to %d" fill-column))) + +(defcustom comment-multi-line t ; XEmacs - this works well with adaptive fill + "*Non-nil means \\[indent-new-comment-line] should continue same comment +on new line, with no new terminator or starter. +This is obsolete because you might as well use \\[newline-and-indent]." + :type 'boolean + :group 'fill-comments) + +(defun indent-new-comment-line (&optional soft) + "Break line at point and indent, continuing comment if within one. +This indents the body of the continued comment +under the previous comment line. + +This command is intended for styles where you write a comment per line, +starting a new comment (and terminating it if necessary) on each line. +If you want to continue one comment across several lines, use \\[newline-and-indent]. + +If a fill column is specified, it overrides the use of the comment column +or comment indentation. + +The inserted newline is marked hard if `use-hard-newlines' is true, +unless optional argument SOFT is non-nil." + (interactive) + (let (comcol comstart) + (skip-chars-backward " \t") + ;; 97/3/14 jhod: Kinsoku processing + (if (featurep 'mule) + (kinsoku-process)) + (delete-region (point) + (progn (skip-chars-forward " \t") + (point))) + (if soft (insert ?\n) (newline 1)) + (if fill-prefix + (progn + (indent-to-left-margin) + (insert fill-prefix)) + ;; #### - Eric Eide reverts to v18 semantics for this function in + ;; fa-extras, which I'm not gonna do. His changes are to (1) execute + ;; the save-excursion below unconditionally, and (2) uncomment the check + ;; for (not comment-multi-line) further below. --Stig + ;;### jhod: probably need to fix this for kinsoku processing + (if (not comment-multi-line) + (save-excursion + (if (and comment-start-skip + (let ((opoint (point))) + (forward-line -1) + (re-search-forward comment-start-skip opoint t))) + ;; The old line is a comment. + ;; Set WIN to the pos of the comment-start. + ;; But if the comment is empty, look at preceding lines + ;; to find one that has a nonempty comment. + + ;; If comment-start-skip contains a \(...\) pair, + ;; the real comment delimiter starts at the end of that pair. + (let ((win (or (match-end 1) (match-beginning 0)))) + (while (and (eolp) (not (bobp)) + (let (opoint) + (beginning-of-line) + (setq opoint (point)) + (forward-line -1) + (re-search-forward comment-start-skip opoint t))) + (setq win (or (match-end 1) (match-beginning 0)))) + ;; Indent this line like what we found. + (goto-char win) + (setq comcol (current-column)) + (setq comstart + (buffer-substring (point) (match-end 0))))))) + (if (and comcol (not fill-prefix)) ; XEmacs - (ENE) from fa-extras. + (let ((comment-column comcol) + (comment-start comstart) + (comment-end comment-end)) + (and comment-end (not (equal comment-end "")) + ; (if (not comment-multi-line) + (progn + (forward-char -1) + (insert comment-end) + (forward-char 1)) + ; (setq comment-column (+ comment-column (length comment-start)) + ; comment-start "") + ; ) + ) + (if (not (eolp)) + (setq comment-end "")) + (insert ?\n) + (forward-char -1) + (indent-for-comment) + (save-excursion + ;; Make sure we delete the newline inserted above. + (end-of-line) + (delete-char 1))) + (indent-according-to-mode))))) + + +(defun set-selective-display (arg) + "Set `selective-display' to ARG; clear it if no arg. +When the value of `selective-display' is a number > 0, +lines whose indentation is >= that value are not displayed. +The variable `selective-display' has a separate value for each buffer." + (interactive "P") + (if (eq selective-display t) + (error "selective-display already in use for marked lines")) + (let ((current-vpos + (save-restriction + (narrow-to-region (point-min) (point)) + (goto-char (window-start)) + (vertical-motion (window-height))))) + (setq selective-display + (and arg (prefix-numeric-value arg))) + (recenter current-vpos)) + (set-window-start (selected-window) (window-start (selected-window))) + ;; #### doesn't localize properly: + (princ "selective-display set to " t) + (prin1 selective-display t) + (princ "." t)) + +;; XEmacs +(defun nuke-selective-display () + "Ensure that the buffer is not in selective-display mode. +If `selective-display' is t, then restore the buffer text to it's original +state before disabling selective display." + ;; by Stig@hackvan.com + (interactive) + (and (eq t selective-display) + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (let ((mod-p (buffer-modified-p)) + (buffer-read-only nil)) + (while (search-forward "\r" nil t) + (delete-char -1) + (insert "\n")) + (set-buffer-modified-p mod-p) + )))) + (setq selective-display nil)) + +(add-hook 'change-major-mode-hook 'nuke-selective-display) + +(defconst overwrite-mode-textual (purecopy " Ovwrt") + "The string displayed in the mode line when in overwrite mode.") +(defconst overwrite-mode-binary (purecopy " Bin Ovwrt") + "The string displayed in the mode line when in binary overwrite mode.") + +(defun overwrite-mode (arg) + "Toggle overwrite mode. +With arg, turn overwrite mode on iff arg is positive. +In overwrite mode, printing characters typed in replace existing text +on a one-for-one basis, rather than pushing it to the right. At the +end of a line, such characters extend the line. Before a tab, +such characters insert until the tab is filled in. +\\[quoted-insert] still inserts characters in overwrite mode; this +is supposed to make it easier to insert characters when necessary." + (interactive "P") + (setq overwrite-mode + (if (if (null arg) (not overwrite-mode) + (> (prefix-numeric-value arg) 0)) + 'overwrite-mode-textual)) + (redraw-modeline)) + +(defun binary-overwrite-mode (arg) + "Toggle binary overwrite mode. +With arg, turn binary overwrite mode on iff arg is positive. +In binary overwrite mode, printing characters typed in replace +existing text. Newlines are not treated specially, so typing at the +end of a line joins the line to the next, with the typed character +between them. Typing before a tab character simply replaces the tab +with the character typed. +\\[quoted-insert] replaces the text at the cursor, just as ordinary +typing characters do. + +Note that binary overwrite mode is not its own minor mode; it is a +specialization of overwrite-mode, entered by setting the +`overwrite-mode' variable to `overwrite-mode-binary'." + (interactive "P") + (setq overwrite-mode + (if (if (null arg) + (not (eq overwrite-mode 'overwrite-mode-binary)) + (> (prefix-numeric-value arg) 0)) + 'overwrite-mode-binary)) + (redraw-modeline)) + +(defcustom line-number-mode nil + "*Non-nil means display line number in modeline." + :type 'boolean + :group 'editing-basics) + +(defun line-number-mode (arg) + "Toggle Line Number mode. +With arg, turn Line Number mode on iff arg is positive. +When Line Number mode is enabled, the line number appears +in the mode line." + (interactive "P") + (setq line-number-mode + (if (null arg) (not line-number-mode) + (> (prefix-numeric-value arg) 0))) + (redraw-modeline)) + +(defcustom column-number-mode nil + "*Non-nil means display column number in mode line." + :type 'boolean + :group 'editing-basics) + +(defun column-number-mode (arg) + "Toggle Column Number mode. +With arg, turn Column Number mode on iff arg is positive. +When Column Number mode is enabled, the column number appears +in the mode line." + (interactive "P") + (setq column-number-mode + (if (null arg) (not column-number-mode) + (> (prefix-numeric-value arg) 0))) + (redraw-modeline)) + + +(defcustom blink-matching-paren t + "*Non-nil means show matching open-paren when close-paren is inserted." + :type 'boolean + :group 'paren-blinking) + +(defcustom blink-matching-paren-on-screen t + "*Non-nil means show matching open-paren when it is on screen. +nil means don't show it (but the open-paren can still be shown +when it is off screen." + :type 'boolean + :group 'paren-blinking) + +(defcustom blink-matching-paren-distance 12000 + "*If non-nil, is maximum distance to search for matching open-paren." + :type '(choice integer (const nil)) + :group 'paren-blinking) + +(defcustom blink-matching-delay 1 + "*The number of seconds that `blink-matching-open' will delay at a match." + :type 'number + :group 'paren-blinking) + +(defcustom blink-matching-paren-dont-ignore-comments nil + "*Non-nil means `blink-matching-paren' should not ignore comments." + :type 'boolean + :group 'paren-blinking) + +(defun blink-matching-open () + "Move cursor momentarily to the beginning of the sexp before point." + (interactive "_") ; XEmacs + (and (> (point) (1+ (point-min))) + blink-matching-paren + ;; Verify an even number of quoting characters precede the close. + (= 1 (logand 1 (- (point) + (save-excursion + (forward-char -1) + (skip-syntax-backward "/\\") + (point))))) + (let* ((oldpos (point)) + (parse-sexp-ignore-comments t) ; to avoid C++ lossage + (blinkpos) + (mismatch)) + (save-excursion + (save-restriction + (if blink-matching-paren-distance + (narrow-to-region (max (point-min) + (- (point) blink-matching-paren-distance)) + oldpos)) + (condition-case () + (let ((parse-sexp-ignore-comments + (and parse-sexp-ignore-comments + (not blink-matching-paren-dont-ignore-comments)))) + (setq blinkpos (scan-sexps oldpos -1))) + (error nil))) + (and blinkpos + (/= (char-syntax (char-after blinkpos)) + ?\$) + (setq mismatch + (or (null (matching-paren (char-after blinkpos))) + (/= (char-after (1- oldpos)) + (matching-paren (char-after blinkpos)))))) + (if mismatch (setq blinkpos nil)) + (if blinkpos + (progn + (goto-char blinkpos) + (if (pos-visible-in-window-p) + (and blink-matching-paren-on-screen + (progn + (auto-show-make-point-visible) + (sit-for blink-matching-delay))) + (goto-char blinkpos) + (display-message + 'command + (format + "Matches %s" + ;; Show what precedes the open in its line, if anything. + (if (save-excursion + (skip-chars-backward " \t") + (not (bolp))) + (buffer-substring (progn (beginning-of-line) (point)) + (1+ blinkpos)) + ;; Show what follows the open in its line, if anything. + (if (save-excursion + (forward-char 1) + (skip-chars-forward " \t") + (not (eolp))) + (buffer-substring blinkpos + (progn (end-of-line) (point))) + ;; Otherwise show the previous nonblank line, + ;; if there is one. + (if (save-excursion + (skip-chars-backward "\n \t") + (not (bobp))) + (concat + (buffer-substring (progn + (skip-chars-backward "\n \t") + (beginning-of-line) + (point)) + (progn (end-of-line) + (skip-chars-backward " \t") + (point))) + ;; Replace the newline and other whitespace with `...'. + "..." + (buffer-substring blinkpos (1+ blinkpos))) + ;; There is nothing to show except the char itself. + (buffer-substring blinkpos (1+ blinkpos))))))))) + (cond (mismatch + (display-message 'no-log "Mismatched parentheses")) + ((not blink-matching-paren-distance) + (display-message 'no-log "Unmatched parenthesis")))))))) + +;Turned off because it makes dbx bomb out. +(setq blink-paren-function 'blink-matching-open) + +(eval-when-compile (defvar myhelp)) ; suppress compiler warning + +;; XEmacs: Some functions moved to cmdloop.el: +;; keyboard-quit +;; buffer-quit-function +;; keyboard-escape-quit + +(defun assoc-ignore-case (key alist) + "Like `assoc', but assumes KEY is a string and ignores case when comparing." + (setq key (downcase key)) + (let (element) + (while (and alist (not element)) + (if (equal key (downcase (car (car alist)))) + (setq element (car alist))) + (setq alist (cdr alist))) + element)) + + +(defcustom mail-user-agent 'sendmail-user-agent + "*Your preference for a mail composition package. +Various Emacs Lisp packages (e.g. reporter) require you to compose an +outgoing email message. This variable lets you specify which +mail-sending package you prefer. + +Valid values include: + + sendmail-user-agent -- use the default Emacs Mail package + mh-e-user-agent -- use the Emacs interface to the MH mail system + message-user-agent -- use the GNUS mail sending package + +Additional valid symbols may be available; check with the author of +your package for details." + :type '(radio (function-item :tag "Default Emacs mail" + :format "%t\n" + sendmail-user-agent) + (function-item :tag "Gnus mail sending package" + :format "%t\n" + message-user-agent) + (function :tag "Other")) + :group 'mail) + +(defun define-mail-user-agent (symbol composefunc sendfunc + &optional abortfunc hookvar) + "Define a symbol to identify a mail-sending package for `mail-user-agent'. + +SYMBOL can be any Lisp symbol. Its function definition and/or +value as a variable do not matter for this usage; we use only certain +properties on its property list, to encode the rest of the arguments. + +COMPOSEFUNC is program callable function that composes an outgoing +mail message buffer. This function should set up the basics of the +buffer without requiring user interaction. It should populate the +standard mail headers, leaving the `to:' and `subject:' headers blank +by default. + +COMPOSEFUNC should accept several optional arguments--the same +arguments that `compose-mail' takes. See that function's documentation. + +SENDFUNC is the command a user would run to send the message. + +Optional ABORTFUNC is the command a user would run to abort the +message. For mail packages that don't have a separate abort function, +this can be `kill-buffer' (the equivalent of omitting this argument). + +Optional HOOKVAR is a hook variable that gets run before the message +is actually sent. Callers that use the `mail-user-agent' may +install a hook function temporarily on this hook variable. +If HOOKVAR is nil, `mail-send-hook' is used. + +The properties used on SYMBOL are `composefunc', `sendfunc', +`abortfunc', and `hookvar'." + (put symbol 'composefunc composefunc) + (put symbol 'sendfunc sendfunc) + (put symbol 'abortfunc (or abortfunc 'kill-buffer)) + (put symbol 'hookvar (or hookvar 'mail-send-hook))) + +(define-mail-user-agent 'sendmail-user-agent + 'sendmail-user-agent-compose 'mail-send-and-exit) + +(define-mail-user-agent 'message-user-agent + 'message-mail 'message-send-and-exit + 'message-kill-buffer 'message-send-hook) + +(defun sendmail-user-agent-compose (&optional to subject other-headers continue + switch-function yank-action + send-actions) + (if switch-function + (let ((special-display-buffer-names nil) + (special-display-regexps nil) + (same-window-buffer-names nil) + (same-window-regexps nil)) + (funcall switch-function "*mail*"))) + (let ((cc (cdr (assoc-ignore-case "cc" other-headers))) + (in-reply-to (cdr (assoc-ignore-case "in-reply-to" other-headers)))) + (or (mail continue to subject in-reply-to cc yank-action send-actions) + continue + (error "Message aborted")) + (save-excursion + (goto-char (point-min)) + (search-forward mail-header-separator) + (beginning-of-line) + (while other-headers + (if (not (member (car (car other-headers)) '("in-reply-to" "cc"))) + (insert (car (car other-headers)) ": " + (cdr (car other-headers)) "\n")) + (setq other-headers (cdr other-headers))) + t))) + +(define-mail-user-agent 'mh-e-user-agent + 'mh-smail-batch 'mh-send-letter 'mh-fully-kill-draft + 'mh-before-send-letter-hook) + +(defun compose-mail (&optional to subject other-headers continue + switch-function yank-action send-actions) + "Start composing a mail message to send. +This uses the user's chosen mail composition package +as selected with the variable `mail-user-agent'. +The optional arguments TO and SUBJECT specify recipients +and the initial Subject field, respectively. + +OTHER-HEADERS is an alist specifying additional +header fields. Elements look like (HEADER . VALUE) where both +HEADER and VALUE are strings. + +CONTINUE, if non-nil, says to continue editing a message already +being composed. + +SWITCH-FUNCTION, if non-nil, is a function to use to +switch to and display the buffer used for mail composition. + +YANK-ACTION, if non-nil, is an action to perform, if and when necessary, +to insert the raw text of the message being replied to. +It has the form (FUNCTION . ARGS). The user agent will apply +FUNCTION to ARGS, to insert the raw text of the original message. +\(The user agent will also run `mail-citation-hook', *after* the +original text has been inserted in this way.) + +SEND-ACTIONS is a list of actions to call when the message is sent. +Each action has the form (FUNCTION . ARGS)." + (interactive + (list nil nil nil current-prefix-arg)) + (let ((function (get mail-user-agent 'composefunc))) + (funcall function to subject other-headers continue + switch-function yank-action send-actions))) + +(defun compose-mail-other-window (&optional to subject other-headers continue + yank-action send-actions) + "Like \\[compose-mail], but edit the outgoing message in another window." + (interactive + (list nil nil nil current-prefix-arg)) + (compose-mail to subject other-headers continue + 'switch-to-buffer-other-window yank-action send-actions)) + + +(defun compose-mail-other-frame (&optional to subject other-headers continue + yank-action send-actions) + "Like \\[compose-mail], but edit the outgoing message in another frame." + (interactive + (list nil nil nil current-prefix-arg)) + (compose-mail to subject other-headers continue + 'switch-to-buffer-other-frame yank-action send-actions)) + + +(defun set-variable (var val) + "Set VARIABLE to VALUE. VALUE is a Lisp object. +When using this interactively, supply a Lisp expression for VALUE. +If you want VALUE to be a string, you must surround it with doublequotes. + +If VARIABLE has a `variable-interactive' property, that is used as if +it were the arg to `interactive' (which see) to interactively read the value." + (interactive + (let* ((var (read-variable "Set variable: ")) + ;; #### - yucky code replication here. This should use something + ;; from help.el or hyper-apropos.el + (minibuffer-help-form + '(funcall myhelp)) + (myhelp + #'(lambda () + (with-output-to-temp-buffer "*Help*" + (prin1 var) + (princ "\nDocumentation:\n") + (princ (substring (documentation-property var 'variable-documentation) + 1)) + (if (boundp var) + (let ((print-length 20)) + (princ "\n\nCurrent value: ") + (prin1 (symbol-value var)))) + (save-excursion + (set-buffer standard-output) + (help-mode)) + nil)))) + (list var + (let ((prop (get var 'variable-interactive))) + (if prop + ;; Use VAR's `variable-interactive' property + ;; as an interactive spec for prompting. + (call-interactively (list 'lambda '(arg) + (list 'interactive prop) + 'arg)) + (eval-minibuffer (format "Set %s to value: " var))))))) + (set var val)) + +;; XEmacs +(defun activate-region () + "Activate the region, if `zmacs-regions' is true. +Setting `zmacs-regions' to true causes LISPM-style active regions to be used. +This function has no effect if `zmacs-regions' is false." + (interactive) + (and zmacs-regions (zmacs-activate-region))) + +;; XEmacs +(defsubst region-exists-p () + "Non-nil iff the region exists. +If active regions are in use (i.e. `zmacs-regions' is true), this means that + the region is active. Otherwise, this means that the user has pushed + a mark in this buffer at some point in the past. +The functions `region-beginning' and `region-end' can be used to find the + limits of the region." + (not (null (mark)))) + +;; XEmacs +(defun region-active-p () + "Non-nil iff the region is active. +If `zmacs-regions' is true, this is equivalent to `region-exists-p'. +Otherwise, this function always returns false." + (and zmacs-regions zmacs-region-extent)) + +;; A bunch of stuff was moved elsewhere: +;; completion-list-mode-map +;; completion-reference-buffer +;; completion-base-size +;; delete-completion-window +;; previous-completion +;; next-completion +;; choose-completion +;; choose-completion-delete-max-match +;; choose-completion-string +;; completion-list-mode +;; completion-fixup-function +;; completion-setup-function +;; switch-to-completions +;; event stuffs +;; keypad stuffs + +;; The rest of this file is not in Lisp in FSF +(defun capitalize-region-or-word (arg) + "Capitalize the selected region or the following word (or ARG words)." + (interactive "p") + (if (region-active-p) + (capitalize-region (region-beginning) (region-end)) + (capitalize-word arg))) + +(defun upcase-region-or-word (arg) + "Upcase the selected region or the following word (or ARG words)." + (interactive "p") + (if (region-active-p) + (upcase-region (region-beginning) (region-end)) + (upcase-word arg))) + +(defun downcase-region-or-word (arg) + "Downcase the selected region or the following word (or ARG words)." + (interactive "p") + (if (region-active-p) + (downcase-region (region-beginning) (region-end)) + (downcase-word arg))) + +;;; +;;; Most of the zmacs code is now in elisp. The only thing left in C +;;; are the variables zmacs-regions, zmacs-region-active-p and +;;; zmacs-region-stays plus the function zmacs_update_region which +;;; calls the lisp level zmacs-update-region. It must remain since it +;;; must be called by core C code. +;;; +;;; Huh? Why couldn't "core C code" just use +;;; call0(Qzmacs_update_region)??? -hniksic + +(defvar zmacs-activate-region-hook nil + "Function or functions called when the region becomes active; +see the variable `zmacs-regions'.") + +(defvar zmacs-deactivate-region-hook nil + "Function or functions called when the region becomes inactive; +see the variable `zmacs-regions'.") + +(defvar zmacs-update-region-hook nil + "Function or functions called when the active region changes. +This is called after each command that sets `zmacs-region-stays' to t. +See the variable `zmacs-regions'.") + +(defvar zmacs-region-extent nil + "The extent of the zmacs region; don't use this.") + +(defvar zmacs-region-rectangular-p nil + "Whether the zmacs region is a rectangle; don't use this.") + +(defun zmacs-make-extent-for-region (region) + ;; Given a region, this makes an extent in the buffer which holds that + ;; region, for highlighting purposes. If the region isn't associated + ;; with a buffer, this does nothing. + (let ((buffer nil) + (valid (and (extentp zmacs-region-extent) + (extent-object zmacs-region-extent) + (buffer-live-p (extent-object zmacs-region-extent)))) + start end) + (cond ((consp region) + (setq start (min (car region) (cdr region)) + end (max (car region) (cdr region)) + valid (and valid + (eq (marker-buffer (car region)) + (extent-object zmacs-region-extent))) + buffer (marker-buffer (car region)))) + (t + (signal 'error (list "Invalid region" region)))) + + (if valid + nil + ;; The condition case is in case any of the extents are dead or + ;; otherwise incapacitated. + (condition-case () + (if (listp zmacs-region-extent) + (mapc 'delete-extent zmacs-region-extent) + (delete-extent zmacs-region-extent)) + (error nil))) + + (if valid + (set-extent-endpoints zmacs-region-extent start end) + (setq zmacs-region-extent (make-extent start end buffer)) + + ;; Make the extent be closed on the right, which means that if + ;; characters are inserted exactly at the end of the extent, the + ;; extent will grow to cover them. This is important for shell + ;; buffers - suppose one makes a region, and one end is at point-max. + ;; If the shell produces output, that marker will remain at point-max + ;; (its position will increase). So it's important that the extent + ;; exhibit the same behavior, lest the region covered by the extent + ;; (the visual indication), and the region between point and mark + ;; (the actual region value) become different! + (set-extent-property zmacs-region-extent 'end-open nil) + + ;; use same priority as mouse-highlighting so that conflicts between + ;; the region extent and a mouse-highlighted extent are resolved by + ;; the usual size-and-endpoint-comparison method. + (set-extent-priority zmacs-region-extent mouse-highlight-priority) + (set-extent-face zmacs-region-extent 'zmacs-region) + + ;; #### It might be better to actually break + ;; default-mouse-track-next-move-rect out of mouse.el so that we + ;; can use its logic here. + (cond + (zmacs-region-rectangular-p + (setq zmacs-region-extent (list zmacs-region-extent)) + (default-mouse-track-next-move-rect start end zmacs-region-extent) + )) + + zmacs-region-extent))) + +(defun zmacs-region-buffer () + "Return the buffer containing the zmacs region, or nil." + ;; #### this is horrible and kludgy! This stuff needs to be rethought. + (and zmacs-regions zmacs-region-active-p + (or (marker-buffer (mark-marker t)) + (and (extent-live-p zmacs-region-extent) + (buffer-live-p (extent-object zmacs-region-extent)) + (extent-object zmacs-region-extent))))) + +(defun zmacs-activate-region () + "Make the region between `point' and `mark' be active (highlighted), +if `zmacs-regions' is true. Only a very small number of commands +should ever do this. Calling this function will call the hook +`zmacs-activate-region-hook', if the region was previously inactive. +Calling this function ensures that the region stays active after the +current command terminates, even if `zmacs-region-stays' is not set. +Returns t if the region was activated (i.e. if `zmacs-regions' if t)." + (if (not zmacs-regions) + nil + (setq zmacs-region-active-p t + zmacs-region-stays t + zmacs-region-rectangular-p (and (boundp 'mouse-track-rectangle-p) + mouse-track-rectangle-p)) + (if (marker-buffer (mark-marker t)) + (zmacs-make-extent-for-region (cons (point-marker t) (mark-marker t)))) + (run-hooks 'zmacs-activate-region-hook) + t)) + +(defun zmacs-deactivate-region () + "Make the region between `point' and `mark' no longer be active, +if `zmacs-regions' is true. You shouldn't need to call this; the +command loop calls it when appropriate. Calling this function will +call the hook `zmacs-deactivate-region-hook', if the region was +previously active. Returns t if the region had been active, nil +otherwise." + (if (not zmacs-region-active-p) + nil + (setq zmacs-region-active-p nil + zmacs-region-stays nil + zmacs-region-rectangular-p nil) + (if zmacs-region-extent + (let ((inhibit-quit t)) + (if (listp zmacs-region-extent) + (mapc 'delete-extent zmacs-region-extent) + (delete-extent zmacs-region-extent)) + (setq zmacs-region-extent nil))) + (run-hooks 'zmacs-deactivate-region-hook) + t)) + +(defun zmacs-update-region () + "Update the highlighted region between `point' and `mark'. +You shouldn't need to call this; the command loop calls it +when appropriate. Calling this function will call the hook +`zmacs-update-region-hook', if the region is active." + (when zmacs-region-active-p + (when (marker-buffer (mark-marker t)) + (zmacs-make-extent-for-region (cons (point-marker t) + (mark-marker t)))) + (run-hooks 'zmacs-update-region-hook))) + +;;;;;; +;;;;;; echo area stuff +;;;;;; + +;;; #### Should this be moved to a separate file, for clarity? +;;; -hniksic + +;;; The `message-stack' is an alist of labels with messages; the first +;;; message in this list is always in the echo area. A call to +;;; `display-message' inserts a label/message pair at the head of the +;;; list, and removes any other pairs with that label. Calling +;;; `clear-message' causes any pair with matching label to be removed, +;;; and this may cause the displayed message to change or vanish. If +;;; the label arg is nil, the entire message stack is cleared. +;;; +;;; Message/error filtering will be a little tricker to implement than +;;; logging, since messages can be built up incrementally +;;; using clear-message followed by repeated calls to append-message +;;; (this happens with error messages). For messages which aren't +;;; created this way, filtering could be implemented at display-message +;;; very easily. +;;; +;;; Bits of the logging code are borrowed from log-messages.el by +;;; Robert Potter (rpotter@grip.cis.upenn.edu). + +;; need this to terminate the currently-displayed message +;; ("Loading simple ...") +(when (and + (not (fboundp 'display-message)) + (not (featurep 'debug))) + (send-string-to-terminal "\n")) + +(defvar message-stack nil + "An alist of label/string pairs representing active echo-area messages. +The first element in the list is currently displayed in the echo area. +Do not modify this directly--use the `message' or +`display-message'/`clear-message' functions.") + +(defvar remove-message-hook 'log-message + "A function or list of functions to be called when a message is removed +from the echo area at the bottom of the frame. The label of the removed +message is passed as the first argument, and the text of the message +as the second argument.") + +(defcustom log-message-max-size 50000 + "Maximum size of the \" *Message-Log*\" buffer. See `log-message'." + :type 'integer + :group 'log-message) +(make-compatible-variable 'message-log-max 'log-message-max-size) + +;; We used to reject quite a lot of stuff here, but it was a bad idea, +;; for two reasons: +;; +;; a) In most circumstances, you *want* to see the message in the log. +;; The explicitly non-loggable messages should be marked as such by +;; the issuer. Gratuitous non-displaying of random regexps made +;; debugging harder, too (because various reasonable debugging +;; messages would get eaten). +;; +;; b) It slowed things down. Yes, visibly. +;; +;; So, I left only a few of the really useless ones on this kill-list. +;; +;; --hniksic +(defcustom log-message-ignore-regexps + '(;; Note: adding entries to this list slows down messaging + ;; significantly. Wherever possible, use message lables. + + ;; Often-seen messages + "\\`\\'" ; empty message + "\\`\\(Beginning\\|End\\) of buffer\\'" + ;;"^Quit$" + ;; completions + ;; Many packages print this -- impossible to categorize + ;;"^Making completion list" + ;; Gnus + ;; "^No news is no news$" + ;; "^No more\\( unread\\)? newsgroups$" + ;; "^Opening [^ ]+ server\\.\\.\\." + ;; "^[^:]+: Reading incoming mail" + ;; "^Getting mail from " + ;; "^\\(Generating Summary\\|Sorting threads\\|Making sparse threads\\|Scoring\\|Checking new news\\|Expiring articles\\|Sending\\)\\.\\.\\." + ;; "^\\(Fetching headers for\\|Retrieving newsgroup\\|Reading active file\\)" + ;; "^No more\\( unread\\)? articles" + ;; "^Deleting article " + ;; W3 + ;; "^Parsed [0-9]+ of [0-9]+ ([0-9]+%)" + ) + "List of regular expressions matching messages which shouldn't be logged. +See `log-message'. + +Ideally, packages which generate messages which might need to be ignored +should label them with 'progress, 'prompt, or 'no-log, so they can be +filtered by the log-message-ignore-labels." + :type '(repeat regexp) + :group 'log-message) + +(defcustom log-message-ignore-labels + '(help-echo command progress prompt no-log garbage-collecting auto-saving) + "List of symbols indicating labels of messages which shouldn't be logged. +See `display-message' for some common labels. See also `log-message'." + :type '(repeat (symbol :tag "Label")) + :group 'log-message) + +;;Subsumed by view-lossage +;; Not really, I'm adding it back by popular demand. -slb +(defun show-message-log () + "Show the \" *Message-Log*\" buffer, which contains old messages and errors." + (interactive) + (pop-to-buffer " *Message-Log*")) + +(defvar log-message-filter-function 'log-message-filter + "Value must be a function of two arguments: a symbol (label) and +a string (message). It should return non-nil to indicate a message +should be logged. Possible values include 'log-message-filter and +'log-message-filter-errors-only.") + +(defun log-message-filter (label message) + "Default value of log-message-filter-function. +Mesages whose text matches one of the log-message-ignore-regexps +or whose label appears in log-message-ignore-labels are not saved." + (let ((r log-message-ignore-regexps) + (ok (not (memq label log-message-ignore-labels)))) + (while (and r ok) + (if (save-match-data (string-match (car r) message)) + (setq ok nil)) + (setq r (cdr r))) + ok)) + +(defun log-message-filter-errors-only (label message) + "For use as the log-message-filter-function. Only logs error messages." + (eq label 'error)) + +(defun log-message (label message) + "Stuff a copy of the message into the \" *Message-Log*\" buffer, +if it satisfies the log-message-filter-function. + +For use on remove-message-hook." + (if (and (not noninteractive) + (funcall log-message-filter-function label message)) + (save-excursion + (set-buffer (get-buffer-create " *Message-Log*")) + (goto-char (point-max)) + ;; (insert (concat (upcase (symbol-name label)) ": " message "\n")) + (insert message "\n") + (if (> (point-max) (max log-message-max-size (point-min))) + (progn + ;; trim log to ~90% of max size + (goto-char (max (- (point-max) + (truncate (* 0.9 log-message-max-size))) + (point-min))) + (forward-line 1) + (delete-region (point-min) (point))))))) + +(defun message-displayed-p (&optional return-string frame) + "Return a non-nil value if a message is presently displayed in the\n\ +minibuffer's echo area. If optional argument RETURN-STRING is non-nil,\n\ +return a string containing the message, otherwise just return t." + ;; by definition, a message is displayed if the echo area buffer is + ;; non-empty (see also echo_area_active()). It had better also + ;; be the case that message-stack is nil exactly when the echo area + ;; is non-empty. + (let ((buffer (get-buffer " *Echo Area*"))) + (and (< (point-min buffer) (point-max buffer)) + (if return-string + (buffer-substring nil nil buffer) + t)))) + +;;; Returns the string which remains in the echo area, or nil if none. +;;; If label is nil, the whole message stack is cleared. +(defun clear-message (&optional label frame stdout-p no-restore) + "Remove any message with the given LABEL from the message-stack, +erasing it from the echo area if it's currently displayed there. +If a message remains at the head of the message-stack and NO-RESTORE +is nil, it will be displayed. The string which remains in the echo +area will be returned, or nil if the message-stack is now empty. +If LABEL is nil, the entire message-stack is cleared. + +Unless you need the return value or you need to specify a label, +you should just use (message nil)." + (or frame (setq frame (selected-frame))) + (let ((clear-stream (and message-stack (eq 'stream (frame-type frame))))) + (remove-message label frame) + (let ((buffer (get-buffer " *Echo Area*")) + (inhibit-read-only t) + (zmacs-region-stays zmacs-region-stays)) ; preserve from change + (erase-buffer buffer)) + (if clear-stream + (send-string-to-terminal ?\n stdout-p)) + (if no-restore + nil ; just preparing to put another msg up + (if message-stack + (let ((oldmsg (cdr (car message-stack)))) + (raw-append-message oldmsg frame stdout-p) + oldmsg) + ;; ### should we (redisplay-echo-area) here? messes some things up. + nil)))) + +(defun remove-message (&optional label frame) + ;; If label is nil, we want to remove all matching messages. + ;; Must reverse the stack first to log them in the right order. + (let ((log nil)) + (while (and message-stack + (or (null label) ; null label means clear whole stack + (eq label (car (car message-stack))))) + (setq log (cons (car message-stack) log)) + (setq message-stack (cdr message-stack))) + (let ((s message-stack)) + (while (cdr s) + (let ((msg (car (cdr s)))) + (if (eq label (car msg)) + (progn + (setq log (cons msg log)) + (setcdr s (cdr (cdr s)))) + (setq s (cdr s)))))) + ;; (possibly) log each removed message + (while log + (condition-case e + (run-hook-with-args 'remove-message-hook + (car (car log)) (cdr (car log))) + (error (setq remove-message-hook nil) + (message "remove-message-hook error: %s" e) + (sit-for 2) + (let ((inhibit-read-only t)) + (erase-buffer (get-buffer " *Echo Area*"))) + (signal (car e) (cdr e)))) + (setq log (cdr log))))) + +(defun append-message (label message &optional frame stdout-p) + (or frame (setq frame (selected-frame))) + ;; add a new entry to the message-stack, or modify an existing one + (let ((top (car message-stack))) + (if (eq label (car top)) + (setcdr top (concat (cdr top) message)) + (setq message-stack (cons (cons label message) message-stack)))) + (raw-append-message message frame stdout-p)) + +;; really append the message to the echo area. no fiddling with message-stack. +(defun raw-append-message (message &optional frame stdout-p) + (if (eq message "") nil + (let ((buffer (get-buffer " *Echo Area*")) + (zmacs-region-stays zmacs-region-stays)) ; preserve from change + (save-excursion + (set-buffer buffer) + (let ((inhibit-read-only t)) + (insert message))) + ;; Conditionalizing on the device type in this way is not that clean, + ;; but neither is having a device method, as I originally implemented + ;; it: all non-stream devices behave in the same way. Perhaps + ;; the cleanest way is to make the concept of a "redisplayable" + ;; device, which stream devices are not. Look into this more if + ;; we ever create another non-redisplayable device type (e.g. + ;; processes? printers?). + + ;; Don't redisplay the echo area if we are executing a macro. + (if (not executing-kbd-macro) + (if (eq 'stream (frame-type frame)) + (send-string-to-terminal message stdout-p) + (redisplay-echo-area)))))) + +(defun display-message (label message &optional frame stdout-p) + "Print a one-line message at the bottom of the frame. First argument +LABEL is an identifier for this message. MESSAGE is the string to display. +Use `clear-message' to remove a labelled message. + +Here are some standard labels (those marked with `*' are not logged +by default--see the `log-message-ignore-labels' variable): + message default label used by the `message' function + error default label used for reporting errors + * progress progress indicators like \"Converting... 45%\" + * prompt prompt-like messages like \"I-search: foo\" + * no-log messages that should never be logged" + (clear-message label frame stdout-p t) + (append-message label message frame stdout-p)) + +(defun current-message (&optional frame) + "Returns the current message in the echo area, or nil. +The FRAME argument is currently unused." + (cdr (car message-stack))) + +;;; may eventually be frame-dependent +(defun current-message-label (&optional frame) + (car (car message-stack))) + +(defun message (fmt &rest args) + "Print a one-line message at the bottom of the frame. +The arguments are the same as to `format'. + +If the only argument is nil, clear any existing message; let the +minibuffer contents show." + ;; questionable junk in the C code + ;; (if (framep default-minibuffer-frame) + ;; (make-frame-visible default-minibuffer-frame)) + (if (and (null fmt) (null args)) + (progn + (clear-message nil) + nil) + (let ((str (apply 'format fmt args))) + (display-message 'message str) + str))) + +;;;;;; +;;;;;; warning stuff +;;;;;; + +(defcustom log-warning-minimum-level 'info + "Minimum level of warnings that should be logged. +The warnings in levels below this are completely ignored, as if they never +happened. + +The recognized warning levels, in decreasing order of priority, are +'emergency, 'alert, 'critical, 'error, 'warning, 'notice, 'info, and +'debug. + +See also `display-warning-minimum-level'. + +You can also control which warnings are displayed on a class-by-class +basis. See `display-warning-suppressed-classes' and +`log-warning-suppressed-classes'." + :type '(choice (const emergency) (const alert) (const critical) + (const error) (const warning) (const notice) + (const info) (const debug)) + :group 'warnings) + +(defcustom display-warning-minimum-level 'info + "Minimum level of warnings that should be displayed. +The warnings in levels below this are completely ignored, as if they never +happened. + +The recognized warning levels, in decreasing order of priority, are +'emergency, 'alert, 'critical, 'error, 'warning, 'notice, 'info, and +'debug. + +See also `log-warning-minimum-level'. + +You can also control which warnings are displayed on a class-by-class +basis. See `display-warning-suppressed-classes' and +`log-warning-suppressed-classes'." + :type '(choice (const emergency) (const alert) (const critical) + (const error) (const warning) (const notice) + (const info) (const debug)) + :group 'warnings) + +(defvar log-warning-suppressed-classes nil + "List of classes of warnings that shouldn't be logged or displayed. +If any of the CLASS symbols associated with a warning is the same as +any of the symbols listed here, the warning will be completely ignored, +as it they never happened. + +NOTE: In most circumstances, you should *not* set this variable. +Set `display-warning-suppressed-classes' instead. That way the suppressed +warnings are not displayed but are still unobtrusively logged. + +See also `log-warning-minimum-level' and `display-warning-minimum-level'.") + +(defcustom display-warning-suppressed-classes nil + "List of classes of warnings that shouldn't be displayed. +If any of the CLASS symbols associated with a warning is the same as +any of the symbols listed here, the warning will not be displayed. +The warning will still logged in the *Warnings* buffer (unless also +contained in `log-warning-suppressed-classes'), but the buffer will +not be automatically popped up. + +See also `log-warning-minimum-level' and `display-warning-minimum-level'." + :type '(repeat symbol) + :group 'warnings) + +(defvar warning-count 0 + "Count of the number of warning messages displayed so far.") + +(defconst warning-level-alist '((emergency . 8) + (alert . 7) + (critical . 6) + (error . 5) + (warning . 4) + (notice . 3) + (info . 2) + (debug . 1))) + +(defun warning-level-p (level) + "Non-nil if LEVEL specifies a warning level." + (and (symbolp level) (assq level warning-level-alist))) + +;; If you're interested in rewriting this function, be aware that it +;; could be called at arbitrary points in a Lisp program (when a +;; built-in function wants to issue a warning, it will call out to +;; this function the next time some Lisp code is evaluated). Therefore, +;; this function *must* not permanently modify any global variables +;; (e.g. the current buffer) except those that specifically apply +;; to the warning system. + +(defvar before-init-deferred-warnings nil) + +(defun after-init-display-warnings () + "Display warnings deferred till after the init file is run. +Warnings that occur before then are deferred so that warning +suppression in the .emacs file will be honored." + (while before-init-deferred-warnings + (apply 'display-warning (car before-init-deferred-warnings)) + (setq before-init-deferred-warnings + (cdr before-init-deferred-warnings)))) + +#-infodock (add-hook 'after-init-hook 'after-init-display-warnings) + +(defun display-warning (class message &optional level) + "Display a warning message. +CLASS should be a symbol describing what sort of warning this is, such +as `resource' or `key-mapping'. A list of such symbols is also +accepted. (Individual classes can be suppressed; see +`display-warning-suppressed-classes'.) Optional argument LEVEL can +be used to specify a priority for the warning, other than default priority +`warning'. (See `display-warning-minimum-level'). The message is +inserted into the *Warnings* buffer, which is made visible at appropriate +times." + (or level (setq level 'warning)) + (or (listp class) (setq class (list class))) + (check-argument-type 'warning-level-p level) + (if (and (not (featurep 'infodock)) + (not init-file-loaded)) + (setq before-init-deferred-warnings + (cons (list class message level) before-init-deferred-warnings)) + (catch 'ignored + (let ((display-p t) + (level-num (cdr (assq level warning-level-alist)))) + (if (< level-num (cdr (assq log-warning-minimum-level + warning-level-alist))) + (throw 'ignored nil)) + (if (intersection class log-warning-suppressed-classes) + (throw 'ignored nil)) + + (if (< level-num (cdr (assq display-warning-minimum-level + warning-level-alist))) + (setq display-p nil)) + (if (and display-p + (intersection class display-warning-suppressed-classes)) + (setq display-p nil)) + (save-excursion + (let ((buffer (get-buffer-create "*Warnings*"))) + (when display-p + ;; The C code looks at display-warning-tick to determine + ;; when it should call `display-warning-buffer'. Change it + ;; to get the C code's attention. + (incf display-warning-tick)) + (set-buffer buffer) + (goto-char (point-max)) + (setq warning-count (1+ warning-count)) + (princ (format "(%d) (%s/%s) " + warning-count + (mapconcat 'symbol-name class ",") + level) buffer) + (princ message buffer) + (terpri buffer) + (terpri buffer))))))) + +(defun warn (&rest args) + "Display a warning message. +The message is constructed by passing all args to `format'. The message +is placed in the *Warnings* buffer, which will be popped up at the next +redisplay. The class of the warning is `warning'. See also +`display-warning'." + (display-warning 'warning (apply 'format args))) + +(defvar warning-marker nil) + +;; When this function is called by the C code, all non-local exits are +;; trapped and C-g is inhibited; therefore, it would be a very, very +;; bad idea for this function to get into an infinite loop. + +(defun display-warning-buffer () + "Make the buffer that contains the warnings be visible. +The C code calls this periodically, right before redisplay." + (let ((buffer (get-buffer-create "*Warnings*"))) + (when (or (not warning-marker) + (not (eq (marker-buffer warning-marker) buffer))) + (setq warning-marker (make-marker)) + (set-marker warning-marker 1 buffer)) + (set-window-start (display-buffer buffer) warning-marker) + (set-marker warning-marker (point-max buffer) buffer))) + +(defun emacs-name () + "Return the printable name of this instance of Emacs." + (cond ((featurep 'infodock) "InfoDock") + ((featurep 'xemacs) "XEmacs") + (t "Emacs"))) + +;;; simple.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/specifier.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,408 @@ +;;; specifier.el --- Lisp interface to specifiers + +;; Copyright (C) 1997 Free Software Foundation, Inc. +;; Copyright (C) 1995, 1996 Ben Wing. + +;; Author: Ben Wing <wing@666.com> +;; Keywords: internal, dumped + +;;; Synched up with: Not in FSF. + +;; 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, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;;; Code: + +(defun make-specifier-and-init (type spec-list &optional dont-canonicalize) + "Create and initialize a new specifier. + +This is a front-end onto `make-specifier' that allows you to create a +specifier and add specs to it at the same time. TYPE specifies the +specifier type. SPEC-LIST supplies the specification(s) to be added +to the specifier. Normally, almost any reasonable abbreviation of the +full spec-list form is accepted, and is converted to the full form; +however, if optional argument DONT-CANONICALIZE is non-nil, this +conversion is not performed, and the SPEC-LIST must already be in full +form. See `canonicalize-spec-list'." + (let ((sp (make-specifier type))) + (if (not dont-canonicalize) + (setq spec-list (canonicalize-spec-list spec-list type))) + (add-spec-list-to-specifier sp spec-list) + sp)) + +;; God damn, do I hate dynamic scoping. + +(defun map-specifier (ms-specifier ms-func &optional ms-locale ms-maparg) + "Apply MS-FUNC to the specification(s) for MS-LOCALE in MS-SPECIFIER. + +If MS-LOCALE is a locale, MS-FUNC will be called for that locale. +If MS-LOCALE is a locale type, MS-FUNC will be mapped over all locales +of that type. If MS-LOCALE is 'all or nil, MS-FUNC will be mapped +over all locales in MS-SPECIFIER. + +MS-FUNC is called with four arguments: the MS-SPECIFIER, the locale +being mapped over, the inst-list for that locale, and the +optional MS-MAPARG. If any invocation of MS-FUNC returns non-nil, +the mapping will stop and the returned value becomes the +value returned from `map-specifier'. Otherwise, `map-specifier' +returns nil." + (let ((ms-specs (specifier-spec-list ms-specifier ms-locale)) + ms-result) + (while (and ms-specs (not ms-result)) + (let ((ms-this-spec (car ms-specs))) + (setq ms-result (funcall ms-func ms-specifier (car ms-this-spec) + (cdr ms-this-spec) ms-maparg)) + (setq ms-specs (cdr ms-specs)))) + ms-result)) + +(defun canonicalize-inst-pair (inst-pair specifier-type &optional noerror) + "Canonicalize the given INST-PAIR. + +SPECIFIER-TYPE specifies the type of specifier that this SPEC-LIST +will be used for. + +Canonicalizing means converting to the full form for an inst-pair, i.e. +`(TAG-SET . INSTANTIATOR)'. A single, untagged instantiator is given +a tag set of nil (the empty set), and a single tag is converted into +a tag set consisting only of that tag. + +If NOERROR is non-nil, signal an error if the inst-pair is invalid; +otherwise return t." + ;; OK, the possibilities are: + ;; + ;; a) a single instantiator + ;; b) a cons of a tag and an instantiator + ;; c) a cons of a tag set and an instantiator + (cond ((valid-instantiator-p inst-pair specifier-type) + ;; case (a) + (cons nil inst-pair)) + + ((not (consp inst-pair)) + ;; not an inst-pair + (if noerror t + ;; this will signal an appropriate error. + (check-valid-instantiator inst-pair specifier-type))) + + ((and (valid-specifier-tag-p (car inst-pair)) + (valid-instantiator-p (cdr inst-pair) specifier-type)) + ;; case (b) + (cons (list (car inst-pair)) (cdr inst-pair))) + + ((and (valid-specifier-tag-set-p (car inst-pair)) + (valid-instantiator-p (cdr inst-pair) specifier-type)) + ;; case (c) + inst-pair) + + (t + (if noerror t + (signal 'error (list "Invalid specifier tag set" + (car inst-pair))))))) + +(defun canonicalize-inst-list (inst-list specifier-type &optional noerror) + "Canonicalize the given INST-LIST (a list of inst-pairs). + +SPECIFIER-TYPE specifies the type of specifier that this INST-LIST +will be used for. + +Canonicalizing means converting to the full form for an inst-list, i.e. +`((TAG-SET . INSTANTIATOR) ...)'. This function accepts a single +inst-pair or any abbreviation thereof or a list of (possibly +abbreviated) inst-pairs. (See `canonicalize-inst-pair'.) + +If NOERROR is non-nil, signal an error if the inst-list is invalid; +otherwise return t." + + ;; OK, the possibilities are: + ;; + ;; a) an inst-pair or various abbreviations thereof + ;; b) a list of (a) + (let ((result (canonicalize-inst-pair inst-list specifier-type t))) + (if (not (eq result t)) + ;; case (a) + (list result) + + (if (not (consp inst-list)) + ;; not an inst-list. + (if noerror t + ;; this will signal an appropriate error. + (check-valid-instantiator inst-list specifier-type)) + + ;; case (b) + (catch 'cann-inst-list + ;; don't use mapcar here; we need to catch the case of + ;; an invalid list. + (let ((rest inst-list) + (result nil)) + (while rest + (if (not (consp rest)) + (if noerror (throw 'cann-inst-list t) + (signal 'error (list "Invalid list format" inst-list))) + (let ((res2 (canonicalize-inst-pair (car rest) specifier-type + noerror))) + (if (eq res2 t) + ;; at this point, we know we're noerror because + ;; otherwise canonicalize-inst-pair would have + ;; signalled an error. + (throw 'cann-inst-list t) + (setq result (cons res2 result))))) + (setq rest (cdr rest))) + (nreverse result))))))) + +(defun canonicalize-spec (spec specifier-type &optional noerror) + "Canonicalize the given SPEC (a specification). + +SPECIFIER-TYPE specifies the type of specifier that this SPEC-LIST +will be used for. + +Canonicalizing means converting to the full form for a spec, i.e. +`(LOCALE (TAG-SET . INSTANTIATOR) ...)'. This function accepts a +possibly abbreviated inst-list or a cons of a locale and a possibly +abbreviated inst-list. (See `canonicalize-inst-list'.) + +If NOERROR is nil, signal an error if the specification is invalid; +otherwise return t." + ;; OK, the possibilities are: + ;; + ;; a) an inst-list or some abbreviation thereof + ;; b) a cons of a locale and an inst-list + (let ((result (canonicalize-inst-list spec specifier-type t))) + (if (not (eq result t)) + ;; case (a) + (cons 'global result) + + (if (not (consp spec)) + ;; not a spec. + (if noerror t + ;; this will signal an appropriate error. + (check-valid-instantiator spec specifier-type)) + + (if (not (valid-specifier-locale-p (car spec))) + ;; invalid locale. + (if noerror t + (signal 'error (list "Invalid specifier locale" (car spec)))) + + ;; case (b) + (let ((result (canonicalize-inst-list (cdr spec) specifier-type + noerror))) + (if (eq result t) + ;; at this point, we know we're noerror because + ;; otherwise canonicalize-inst-list would have + ;; signalled an error. + t + (cons (car spec) result)))))))) + +(defun canonicalize-spec-list (spec-list specifier-type &optional noerror) + "Canonicalize the given SPEC-LIST (a list of specifications). + +SPECIFIER-TYPE specifies the type of specifier that this SPEC-LIST +will be used for. + +Canonicalizing means converting to the full form for a spec-list, i.e. +`((LOCALE (TAG-SET . INSTANTIATOR) ...) ...)'. This function accepts +a possibly abbreviated specification or a list of such things. (See +`canonicalize-spec'.) This is the function used to convert spec-lists +accepted by `set-specifier' and such into a form suitable for +`add-spec-list-to-specifier'. + +This function tries extremely hard to resolve any ambiguities, +and the built-in specifier types (font, image, toolbar, etc.) are +designed so that there won't be any ambiguities. + +If NOERROR is nil, signal an error if the spec-list is invalid; +otherwise return t." + ;; OK, the possibilities are: + ;; + ;; a) a spec or various abbreviations thereof + ;; b) a list of (a) + (let ((result (canonicalize-spec spec-list specifier-type t))) + (if (not (eq result t)) + ;; case (a) + (list result) + + (if (not (consp spec-list)) + ;; not a spec-list. + (if noerror t + ;; this will signal an appropriate error. + (check-valid-instantiator spec-list specifier-type)) + + ;; case (b) + (catch 'cann-spec-list + ;; don't use mapcar here; we need to catch the case of + ;; an invalid list. + (let ((rest spec-list) + (result nil)) + (while rest + (if (not (consp rest)) + (if noerror (throw 'cann-spec-list t) + (signal 'error (list "Invalid list format" spec-list))) + (let ((res2 (canonicalize-spec (car rest) specifier-type + noerror))) + (if (eq res2 t) + ;; at this point, we know we're noerror because + ;; otherwise canonicalize-spec would have + ;; signalled an error. + (throw 'cann-spec-list t) + (setq result (cons res2 result))))) + (setq rest (cdr rest))) + (nreverse result))))))) + +(defun set-specifier (specifier value &optional locale tag-set how-to-add) + "Add a specification or specifications to SPECIFIER. + +This function adds a specification of VALUE in locale LOCALE. +LOCALE indicates where this specification is active, and should be +a buffer, a window, a frame, a device, or the symbol `global' to +indicate that it applies everywhere. LOCALE usually defaults to +`global' if omitted. + +VALUE is usually what is called an \"instantiator\" (which, roughly +speaking, corresponds to the \"value\" of the property governed by +SPECIFIER). The valid instantiators for SPECIFIER depend on the +type of SPECIFIER (which you can determine using `specifier-type'). +The specifier `scrollbar-width', for example, is of type `integer', +meaning its valid instantiators are integers. The specifier +governing the background color of the `default' face (you can +retrieve this specifier using `(face-background 'default)') is +of type `color', meaning its valid instantiators are strings naming +colors and color-instance objects. For some types of specifiers, +such as `image' and `toolbar', the instantiators can be very +complex. Generally this is documented in the appropriate predicate +function -- `color-specifier-p', `image-specifier-p', +`toolbar-specifier-p', etc. + +NOTE: It does *not* work to give a VALUE of nil as a way of +removing the specifications for a locale. Use `remove-specifier' +instead. (And keep in mind that, if you omit the LOCALE argument +to `remove-specifier', it removes *all* specifications! If you +want to remove just the `global' specification, make sure to +specify a LOCALE of `global'.) + +VALUE can also be a list of instantiators. This means basically, +\"try each one in turn until you get one that works\". This allows +you to give funky instantiators that may only work in some cases, +and provide more normal backups for the other cases. (For example, +you might like the color \"darkseagreen2\", but some X servers +don't recognize this color, so you could provide a backup +\"forest green\". Color TTY devices probably won't recognize this +either, so you could provide a second backup \"green\". You'd +do this by specifying this list of instantiators: + +'(\"darkseagreen2\" \"forest green\" \"green\") + +VALUE can also be various more complicated forms; see below. + +Optional argument TAG-SET is a tag or a list of tags, to be associated +with the VALUE. Tags are symbols (usually naming device types, such +as `x' and `tty', or device classes, such as `color', `mono', and +`grayscale'); specifying a TAG-SET restricts the scope of VALUE to +devices that match all specified tags. (You can also create your +own tags using `define-specifier-tag', and use them to identify +specifications added by you, so you can remove them later.) + +Optional argument HOW-TO-ADD should be either nil or one of the +symbols `prepend', `append', `remove-tag-set-prepend', +`remove-tag-set-append', `remove-locale', `remove-locale-type', +or `remove-all'. This specifies what to do with existing +specifications in LOCALE (and possibly elsewhere in the specifier). +Most of the time, you do not need to worry about this argument; +the default behavior of `remove-tag-set-prepend' is usually fine. +See `copy-specifier' and `add-spec-to-specifier' for a full +description of what each of these means. + +VALUE can actually be anything acceptable to `canonicalize-spec-list'; +this includes, among other things: + +-- a cons of a locale and an instantiator (or list of instantiators) +-- a cons of a tag or tag-set and an instantiator (or list of + instantiators) +-- a cons of a locale and the previous type of item +-- a list of one or more of any of the previous types of items + +However, in these cases, you cannot give a LOCALE or TAG-SET, +because they do not make sense. (You will probably get an error if +you try this.) + +Finally, VALUE can itself be a specifier (of the same type as +SPECIFIER), if you want to copy specifications from one specifier +to another; this is equivalent to calling `copy-specifier', and +LOCALE, TAG-SET, and HOW-TO-ADD have the same semantics as with +that function. + +Note that `set-specifier' is exactly complementary to `specifier-specs' +except in the case where SPECIFIER has no specs at all in it but nil +is a valid instantiator (in that case, `specifier-specs' will return +nil (meaning no specs) and `set-specifier' will interpret the `nil' +as meaning \"I'm adding a global instantiator and its value is `nil'\"), +or in strange cases where there is an ambiguity between a spec-list +and an inst-list, etc. (The built-in specifier types are designed +in such a way as to avoid any such ambiguities.) + +NOTE: If you want to work with spec-lists, you should probably not +use either `set-specifier' or `specifier-specs', but should use the +lower-level functions `add-spec-list-to-specifier' and `specifier-spec-list'. +These functions always work with fully-qualified spec-lists; thus, there +is no possibility for ambiguity and no need to go through the function +`canonicalize-spec-list', which is potentially time-consuming." + + ;; backward compatibility: the old function had HOW-TO-ADD as the + ;; third argument and no arguments after that. + ;; #### this should disappear at some point. + (if (and (null how-to-add) + (memq locale '(prepend append remove-tag-set-prepend + remove-tag-set-append remove-locale + remove-locale-type remove-all))) + (progn + (setq how-to-add locale) + (setq locale nil))) + + ;; proper beginning of the function. + (let ((is-valid (valid-instantiator-p value (specifier-type specifier))) + (nval value)) + (cond ((and (not is-valid) (specifierp nval)) + (copy-specifier nval specifier locale tag-set nil how-to-add)) + (t + (if tag-set + (progn + (if (not (listp tag-set)) + (setq tag-set (list tag-set))) + ;; You tend to get more accurate errors + ;; for a variety of cases if you call + ;; canonicalize-tag-set here. + (setq tag-set (canonicalize-tag-set tag-set)) + (if (and (not is-valid) (consp nval)) + (setq nval + (mapcar #'(lambda (x) + (check-valid-instantiator + x (specifier-type specifier)) + (cons tag-set x)) + nval)) + (setq nval (cons tag-set nval))))) + (if locale + (setq nval (cons locale nval))) + (add-spec-list-to-specifier + specifier + (canonicalize-spec-list nval (specifier-type specifier)) + how-to-add)))) + value) + +(define-specifier-tag 'win 'device-on-window-system-p) + +;;; specifier.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/startup.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,1453 @@ +;;; startup.el --- process XEmacs shell arguments + +;; Copyright (C) 1985-1986, 1990, 1992-1997 Free Software Foundation, Inc. +;; Copyright (c) 1993, 1994 Sun Microsystems, Inc. +;; Copyright (C) 1995 Board of Trustees, University of Illinois + +;; Maintainer: XEmacs Development Team +;; Keywords: internal, dumped + +;; 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, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: FSF 19.34. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;; -batch, -t, and -nw are processed by main() in emacs.c and are +;; never seen by lisp code. + +;; -version and -help are special-cased as well: they imply -batch, +;; but are left on the list for lisp code to process. + +;;; Code: + +(setq top-level '(normal-top-level)) + +(defvar command-line-processed nil "t once command line has been processed") + +(defconst startup-message-timeout 12000) ; More or less disable the timeout + +(defconst inhibit-startup-message nil + "*Non-nil inhibits the initial startup message. +This is for use in your personal init file, once you are familiar +with the contents of the startup message.") + +;; #### FSFmacs randomness +;;(defconst inhibit-startup-echo-area-message nil +;; "*Non-nil inhibits the initial startup echo area message. +;;Inhibition takes effect only if your `.emacs' file contains +;;a line of this form: +;; (setq inhibit-startup-echo-area-message \"YOUR-USER-NAME\") +;;If your `.emacs' file is byte-compiled, use the following form instead: +;; (eval '(setq inhibit-startup-echo-area-message \"YOUR-USER-NAME\")) +;;Thus, someone else using a copy of your `.emacs' file will see +;;the startup message unless he personally acts to inhibit it.") + +(defconst inhibit-default-init nil + "*Non-nil inhibits loading the `default' library.") + +(defvar command-line-args-left nil + "List of command-line args not yet processed.") ; bound by `command-line' + +(defvar command-line-default-directory nil + "Default directory to use for command line arguments. +This is normally copied from `default-directory' when XEmacs starts.") + +(defvar before-init-hook nil + "Functions to call after handling urgent options but before init files. +The frame system uses this to open frames to display messages while +XEmacs loads the user's initialization file.") + +(defvar after-init-hook nil + "*Functions to call after loading the init file (`~/.xemacs/init.el'). +The call is not protected by a condition-case, so you can set `debug-on-error' +in `init.el', and put all the actual code on `after-init-hook'.") + +(defvar term-setup-hook nil + "*Functions to be called after loading terminal-specific Lisp code. +See `run-hooks'. This variable exists for users to set, so as to +override the definitions made by the terminal-specific file. XEmacs +never sets this variable itself.") + +(defvar keyboard-type nil + "The brand of keyboard you are using. +This variable is used to define the proper function and keypad keys +for use under X. It is used in a fashion analogous to the environment +value TERM.") + +(defvar window-setup-hook nil + "Normal hook run to initialize window system display. +XEmacs runs this hook after processing the command line arguments and loading +the user's init file.") + +(defconst initial-major-mode 'lisp-interaction-mode + "Major mode command symbol to use for the initial *scratch* buffer.") + +(defvar init-file-user nil + "Identity of user whose `~/.xemacs/init.el' file is or was read. +The value is nil if no init file is being used; otherwise, it may be either +the null string, meaning that the init file was taken from the user that +originally logged in, or it may be a string containing a user's name. + +In either of the latter cases, `(concat \"~\" init-file-user \"/\")' +evaluates to the name of the directory where the `init.el' file was +looked for. + +Setting `init-file-user' does not prevent Emacs from loading +`site-start.el'. The only way to do that is to use `--no-site-file'.") + +;; #### called `site-run-file' in FSFmacs + +(defvar site-start-file (purecopy "site-start") + "File containing site-wide run-time initializations. +This file is loaded at run-time before `~/.xemacs/init.el'. It +contains inits that need to be in place for the entire site, but +which, due to their higher incidence of change, don't make sense to +load into XEmacs' dumped image. Thus, the run-time load order is: + + 1. file described in this variable, if non-nil; + 2. `~/.xemacs/init.el'; + 3. `/path/to/xemacs/lisp/default.el'. + +Don't use the `site-start.el' file for things some users may not like. +Put them in `default.el' instead, so that users can more easily +override them. Users can prevent loading `default.el' with the `-q' +option or by setting `inhibit-default-init' in their own init files, +but inhibiting `site-start.el' requires `--no-site-file', which +is less convenient.") + +;;(defconst iso-8859-1-locale-regexp "8859[-_]?1" +;; "Regexp that specifies when to enable the ISO 8859-1 character set. +;;We do that if this regexp matches the locale name +;;specified by the LC_ALL, LC_CTYPE and LANG environment variables.") + +(defvar mail-host-address nil + "*Name of this machine, for purposes of naming users.") + +(defvar user-mail-address nil + "*Full mailing address of this user. +This is initialized based on `mail-host-address', +after your init file is read, in case it sets `mail-host-address'.") + +(defvar auto-save-list-file-prefix "~/.xemacs/.saves-" + "Prefix for generating auto-save-list-file-name. +Emacs's pid and the system name will be appended to +this prefix to create a unique file name.") + +(defvar init-file-debug nil) + +(defvar init-file-had-error nil) + +(defvar init-file-loaded nil + "True after the user's init file has been loaded (or suppressed with -q). +This will be true when `after-init-hook' is run and at all times +after, and will not be true at any time before.") + +(defvar initial-frame-unmapped-p nil) + + + +(defvar command-switch-alist + (purecopy + '(("-help" . command-line-do-help) + ("-flags" . command-line-do-help) + ("-h" . command-line-do-help) + ("-?" . command-line-do-help) + ("-version". command-line-do-version) + ("-V" . command-line-do-version) + ("-funcall". command-line-do-funcall) + ("-f" . command-line-do-funcall) + ("-e" . command-line-do-funcall-1) + ("-eval" . command-line-do-eval) + ("-load" . command-line-do-load) + ("-l" . command-line-do-load) + ("-insert" . command-line-do-insert) + ("-i" . command-line-do-insert) + ("-kill" . command-line-do-kill) + ;; Options like +35 are handled specially. + ;; Window-system, site, or package-specific code might add to this. + ;; X11 handles its options by letting Xt remove args from this list. + )) + "Alist of command-line switches. +Elements look like (SWITCH-STRING . HANDLER-FUNCTION). +HANDLER-FUNCTION receives switch name as sole arg; +remaining command-line args are in the variable `command-line-args-left'.") + +;;; default switches +;;; Note: these doc strings are semi-magical. + +(defun command-line-do-help (arg) + "Print the XEmacs usage message and exit." + (let ((standard-output 'external-debugging-output)) + (princ (concat "\n" (emacs-version) "\n\n")) + (princ + (if (featurep 'x) + (concat (emacs-name) + " accepts all standard X Toolkit command line options.\n" + "In addition, the") + "The")) + (princ " following options are accepted: + + -t <device> Use TTY <device> instead of the terminal for input + and output. This implies the -nw option. + -nw Inhibit the use of any window-system-specific + display code: use the current tty. + -batch Execute noninteractively (messages go to stderr). + -debug-init Enter the debugger if an error in the init file occurs. + -unmapped Do not map the initial frame. + -no-site-file Do not load the site-specific init file (site-start.el). + -no-init-file Do not load the user-specific init file (~/.emacs). + -no-packages Do not process the package path. + -vanilla Equivalent to -q -no-site-file -no-packages. + -q Same as -no-init-file. + -user <user> Load user's init file instead of your own. + -u <user> Same as -user.\n") + (let ((l command-switch-alist) + (insert (lambda (&rest x) + (princ " ") + (let ((len 2)) + (while x + (princ (car x)) + (incf len (length (car x))) + (setq x (cdr x))) + (when (>= len 24) + (terpri) (setq len 0)) + (while (< len 24) + (princ " ") + (incf len)))))) + (while l + (let ((name (car (car l))) + (fn (cdr (car l))) + doc arg cons) + (cond + ((and (symbolp fn) (get fn 'undocumented)) nil) + (t + (setq doc (documentation fn)) + (if (member doc '(nil "")) (setq doc "(undocumented)")) + (cond ((string-match "\n\\(<.*>\\)\n?\\'" doc) + ;; Doc of the form "The frobber switch\n<arg1> <arg2>" + (setq arg (substring doc (match-beginning 1) (match-end 1)) + doc (substring doc 0 (match-beginning 0)))) + ((string-match "\n+\\'" doc) + (setq doc (substring doc 0 (match-beginning 0))))) + (if (and (setq cons (rassq fn command-switch-alist)) + (not (eq cons (car l)))) + (setq doc (format "Same as %s." (car cons)))) + (if arg + (funcall insert name " " arg) + (funcall insert name)) + (princ doc) + (terpri)))) + (setq l (cdr l)))) + (princ (concat "\ + +N <file> Start displaying <file> at line N. + +Anything else is considered a file name, and is placed into a buffer for +editing. + +" (emacs-name) " has an online tutorial and manuals. Type ^Ht (Control-h t) after +starting XEmacs to run the tutorial. Type ^Hi to enter the manual browser. +Type ^H^H^H (Control-h Control-h Control-h) to get more help options.\n") + + (kill-emacs 0)))) + +(defun command-line-do-funcall (arg) + "Invoke the named lisp function with no arguments. +<function>" + (funcall (intern (pop command-line-args-left)))) +(fset 'command-line-do-funcall-1 'command-line-do-funcall) +(put 'command-line-do-funcall-1 'undocumented t) + +(defun command-line-do-eval (arg) + "Evaluate the lisp form. Quote it carefully. +<form>" + (eval (read (pop command-line-args-left)))) + +(defun command-line-do-load (arg) + "Load the named file of Lisp code into XEmacs. +<file>" + (let ((file (pop command-line-args-left))) + ;; Take file from default dir if it exists there; + ;; otherwise let `load' search for it. + (if (file-exists-p (expand-file-name file)) + (setq file (expand-file-name file))) + (load file nil t))) + +(defun command-line-do-insert (arg) + "Insert file into the current buffer. +<file>" + (insert-file-contents (pop command-line-args-left))) + +(defun command-line-do-kill (arg) + "Exit XEmacs." + (kill-emacs t)) + +(defun command-line-do-version (arg) + "Print version info and exit." + (princ (concat (emacs-version) "\n")) + (kill-emacs 0)) + + +;;; Processing the command line and loading various init files + +(defun early-error-handler (&rest debugger-args) + "You should probably not be using this." + ;; Used as the debugger during XEmacs initialization; if an error occurs, + ;; print some diagnostics, and kill XEmacs. + + ;; output the contents of the warning buffer, since it won't be seen + ;; otherwise. + ;; #### kludge! The call to Feval forces the pending warnings to + ;; get output. There definitely needs to be a better way. + (let ((buffer (eval (get-buffer-create "*Warnings*")))) + (princ (buffer-substring (point-min buffer) (point-max buffer) buffer) + 'external-debugging-output)) + + (let ((string "Initialization error") + (error (nth 1 debugger-args)) + (debug-on-error nil) + (stream 'external-debugging-output)) + (if (null error) + (princ string stream) + (princ (concat "\n" string ": ") stream) + (condition-case () + (display-error error stream) + (error (princ "<<< error printing error message >>>" stream))) + (princ "\n" stream) + (if (memq (car-safe error) '(void-function void-variable)) + (princ " + This probably means that XEmacs is picking up an old version of + the lisp library, or that some .elc files are not up-to-date.\n" + stream))) + (when (not suppress-early-error-handler-backtrace) + (let ((print-length 1000) + (print-level 1000) + (print-escape-newlines t) + (print-readably nil)) + (when (getenv "EMACSLOADPATH") + (princ (format "\n$EMACSLOADPATH is %s" (getenv "EMACSLOADPATH")) + stream)) + (princ (format "\nexec-directory is %S" exec-directory) stream) + (princ (format "\ndata-directory is %S" data-directory) stream) + (princ (format "\ndoc-directory is %S" doc-directory) stream) + (princ (format "\nload-path is %S" load-path) stream) + (princ "\n\n" stream))) + (when (not suppress-early-error-handler-backtrace) + (backtrace stream t))) + (kill-emacs -1)) + +(defvar lock-directory) +(defvar superlock-file) + +(defun normal-top-level () + (if command-line-processed + (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 (getenv "HOME"))) + (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) + (unwind-protect + (command-line) + ;; Do this again, in case .emacs defined more abbreviations. + (setq default-directory (abbreviate-file-name default-directory)) + ;; Specify the file for recording all the auto save files of + ;; this session. This is used by recover-session. + (setq auto-save-list-file-name + (expand-file-name + (format "%s%d-%s" + auto-save-list-file-prefix + (emacs-pid) + (system-name)))) + (run-hooks 'emacs-startup-hook) + (and term-setup-hook + (run-hooks 'term-setup-hook)) + (setq term-setup-hook nil) + ;; ;; Modify the initial frame based on what .emacs puts into + ;; ;; ...-frame-alist. + (frame-notice-user-settings) + ;; ;;####FSFmacs junk + ;; ;; Now we know the user's default font, so add it to the menu. + ;; (if (fboundp 'font-menu-add-default) + ;; (font-menu-add-default)) + (when window-setup-hook + (run-hooks 'window-setup-hook)) + (setq window-setup-hook nil)) + ;;####FSFmacs junk + ;; (or menubar-bindings-done + ;; (precompute-menubar-bindings)) + )) + +;;####FSFmacs junk +;;; Precompute the keyboard equivalents in the menu bar items. +;;(defun precompute-menubar-bindings () +;; (if (eq window-system 'x) +;; (let ((submap (lookup-key global-map [menu-bar]))) +;; (while submap +;; (and (consp (car submap)) +;; (symbolp (car (car submap))) +;; (stringp (car-safe (cdr (car submap)))) +;; (keymapp (cdr (cdr (car submap)))) +;; (x-popup-menu nil (cdr (cdr (car submap))))) +;; (setq submap (cdr submap)))))) + +(defun command-line-early (args) + ;; This processes those switches which need to be processed before + ;; starting up the window system. + + (setq command-line-default-directory default-directory) + + ;; See if we should import version-control from the environment variable. + (let ((vc (getenv "VERSION_CONTROL"))) + (cond ((eq vc nil)) ;don't do anything if not set + ((or (string= vc "t") + (string= vc "numbered")) + (setq version-control t)) + ((or (string= vc "nil") + (string= vc "existing")) + (setq version-control nil)) + ((or (string= vc "never") + (string= vc "simple")) + (setq version-control 'never)))) + + ;;####FSFmacs + ;; (if (let ((ctype + ;; ;; Use the first of these three envvars that has a nonempty value. + ;; (or (let ((string (getenv "LC_ALL"))) + ;; (and (not (equal string "")) string)) + ;; (let ((string (getenv "LC_CTYPE"))) + ;; (and (not (equal string "")) string)) + ;; (let ((string (getenv "LANG"))) + ;; (and (not (equal string "")) string))))) + ;; (and ctype + ;; (string-match iso-8859-1-locale-regexp ctype))) + ;; (progn + ;; (standard-display-european t) + ;; (require 'iso-syntax))) + + ;; Figure out which user's init file to load, + ;; either from the environment or from the options. + (setq init-file-user (if (noninteractive) nil (user-login-name))) + ;; If user has not done su, use current $HOME to find .emacs. + (and init-file-user (string= init-file-user (user-real-login-name)) + (setq init-file-user "")) + + ;; Allow (at least) these arguments anywhere in the command line + (let ((new-args nil) + (arg nil)) + (while args + (setq arg (pop args)) + (cond + ((or (string= arg "-q") + (string= arg "-no-init-file")) + (setq init-file-user nil)) + ((string= arg "-no-site-file") + (setq site-start-file nil)) + ((or (string= arg "-no-packages") + (string= arg "--no-packages")) + (setq inhibit-package-init t)) + ((or (string= arg "-vanilla") + (string= arg "--vanilla")) + (setq init-file-user nil + site-start-file nil + inhibit-package-init t)) + ((or (string= arg "-u") + (string= arg "-user")) + (setq init-file-user (pop args))) + ((string= arg "-debug-init") + (setq init-file-debug t)) + ((string= arg "-unmapped") + (setq initial-frame-unmapped-p t)) + ((or (string= arg "--") (string= arg "-")) + (while args + (push (pop args) new-args))) + (t (push arg new-args)))) + + (nreverse new-args))) + +(defconst initial-scratch-message "\ +;; This buffer is for notes you don't want to save, and for Lisp evaluation. +;; If you want to create a file, first visit that file with C-x C-f, +;; then enter the text in that file's own buffer. + +" + "Initial message displayed in *scratch* buffer at startup. +If this is nil, no message will be displayed.") + +(defun command-line () + (let ((command-line-args-left (cdr command-line-args))) + + (let ((debugger 'early-error-handler) + (debug-on-error t)) + (set-default-load-path) + + ;; Process magic command-line switches like -q and -u. Do this + ;; before creating the first frame because some of these switches + ;; may affect that. I think it's ok to do this before establishing + ;; the X connection, and maybe someday things like -nw can be + ;; handled here instead of down in C. + (setq command-line-args-left (command-line-early command-line-args-left)) + + ;; Setup the toolbar icon directory + (when (featurep 'toolbar) + (init-toolbar-location)) + + ;; Run the window system's init function. tty is considered to be + ;; a type of window system for this purpose. This creates the + ;; initial (non stdio) device. + (when (and initial-window-system (not noninteractive)) + (funcall (intern (concat "init-" + (symbol-name initial-window-system) + "-win")))) + + ;; When not in batch mode, this creates the first visible frame, + ;; and deletes the stdio device. + (frame-initialize)) + + ;; + ;; We have normality, I repeat, we have normality. Anything you still + ;; can't cope with is therefore your own problem. (And we don't need + ;; to kill XEmacs for it.) + ;; + + ;;; Load init files. + (load-init-file) + + (with-current-buffer (get-buffer "*scratch*") + (erase-buffer) + ;; (insert initial-scratch-message) + (set-buffer-modified-p nil) + (when (eq major-mode 'fundamental-mode) + (funcall initial-major-mode))) + + ;; Load library for our terminal type. + ;; User init file can set term-file-prefix to nil to prevent this. + ;; Note that for any TTY's opened subsequently, the TTY init + ;; code will run this. + (when (and (eq 'tty (console-type)) + (not (noninteractive))) + (load-terminal-library)) + + ;; Process the remaining args. + (command-line-1) + + ;; it was turned on by default so that the warnings don't get displayed + ;; until after the splash screen. + (setq inhibit-warning-display nil) + ;; If -batch, terminate after processing the command options. + (when (noninteractive) (kill-emacs t)))) + +(defun load-terminal-library () + (when term-file-prefix + (let ((term (getenv "TERM")) + hyphend) + (while (and term + (not (load (concat term-file-prefix term) t t))) + ;; Strip off last hyphen and what follows, then try again + (if (setq hyphend (string-match "[-_][^-_]+\\'" term)) + (setq term (substring term 0 hyphend)) + (setq term nil)))))) + +(defconst user-init-directory "/.xemacs/" + "Directory where user initialization and user-installed packages may go.") +(define-obsolete-variable-alias + 'emacs-user-extension-dir + 'user-init-directory) + +(defun load-user-init-file (init-file-user) + "This function actually reads the init files. +First try .xemacs/init, then try .emacs, but only load one of the two." + (when init-file-user + (setq user-init-file + (cond + ((eq system-type 'ms-dos) + (concat "~" init-file-user user-init-directory "init.el")) + (t + (concat "~" init-file-user user-init-directory "init.el")))) + (unless (file-exists-p (expand-file-name user-init-file)) + (setq user-init-file + (cond + ((eq system-type 'ms-dos) + (concat "~" init-file-user "/_emacs")) + (t + (concat "~" init-file-user "/.emacs"))))) + (load user-init-file t t t) + (let ((default-custom-file (concat "~" + init-file-user + user-init-directory + "options.el"))) + (when (string= custom-file default-custom-file) + (load default-custom-file t t))) + (unless inhibit-default-init + (let ((inhibit-startup-message nil)) + ;; Users are supposed to be told their rights. + ;; (Plus how to get help and how to undo.) + ;; Don't you dare turn this off for anyone except yourself. + (load "default" t t))))) + +;;; Load user's init file and default ones. +(defun load-init-file () + (run-hooks 'before-init-hook) + + ;; Run the site-start library if it exists. The point of this file is + ;; that it is run before .emacs. There is no point in doing this after + ;; .emacs; that is useless. + (when site-start-file + (load site-start-file t t)) + + ;; Sites should not disable this. Only individuals should disable + ;; the startup message. + (setq inhibit-startup-message nil) + + (let (debug-on-error-from-init-file + debug-on-error-should-be-set + (debug-on-error-initial + (if (eq init-file-debug t) 'startup init-file-debug))) + (let ((debug-on-error debug-on-error-initial)) + (if init-file-debug + ;; Do this without a condition-case if the user wants to debug. + (load-user-init-file init-file-user) + (condition-case error + (progn + (load-user-init-file init-file-user) + (setq init-file-had-error nil)) + (error + (message "Error in init file: ") + (display-error error nil) + (setq init-file-had-error t)))) + ;; If we can tell that the init file altered debug-on-error, + ;; arrange to preserve the value that it set up. + (or (eq debug-on-error debug-on-error-initial) + (setq debug-on-error-should-be-set t + debug-on-error-from-init-file debug-on-error))) + (when debug-on-error-should-be-set + (setq debug-on-error debug-on-error-from-init-file))) + + (setq init-file-loaded t) + + ;; Do this here in case the init file sets mail-host-address. + ;; Don't do this here unless noninteractive, it is frequently wrong. -sb + ;; (or user-mail-address + (when noninteractive + (setq user-mail-address (concat (user-login-name) "@" + (or mail-host-address + (system-name))))) + + (run-hooks 'after-init-hook) + nil) + +(defun load-options-file (filename) + "Load the file of saved options (from the Options menu) called FILENAME. +Currently this does nothing but call `load', but it might be redefined +in the future to support automatically converting older options files to +a new format, when variables have changed, etc." + (load filename)) + +(defun command-line-1 () + (cond + ((null command-line-args-left) + (unless noninteractive + ;; If there are no switches to process, run the term-setup-hook + ;; before displaying the copyright notice; there may be some need + ;; to do it before doing any output. If we're not going to + ;; display a copyright notice (because other options are present) + ;; then this is run after those options are processed. + (run-hooks 'term-setup-hook) + ;; Don't let the hook be run twice. + (setq term-setup-hook nil) + + ;; Don't clobber a non-scratch buffer if init file + ;; has selected it. + (when (string= (buffer-name) "*scratch*") + (unless (or inhibit-startup-message + (input-pending-p)) + (let ((timeout nil)) + (unwind-protect + ;; Guts of with-timeout + (catch 'timeout + (setq timeout (add-timeout startup-message-timeout + (lambda (ignore) + (condition-case nil + (throw 'timeout t) + (error nil))) + nil)) + (startup-splash-frame) + (or nil;; (pos-visible-in-window-p (point-min)) + (goto-char (point-min))) + (sit-for 0) + (setq unread-command-event (next-command-event))) + (when timeout (disable-timeout timeout))))) + (with-current-buffer (get-buffer "*scratch*") + ;; In case the XEmacs server has already selected + ;; another buffer, erase the one our message is in. + (erase-buffer) + (when (stringp initial-scratch-message) + (insert initial-scratch-message)) + (set-buffer-modified-p nil))))) + + (t + ;; Command-line-options exist + (let ((dir command-line-default-directory) + (file-count 0) + (line nil) + (end-of-options nil) + first-file-buffer file-p arg tem) + (while command-line-args-left + (setq arg (pop command-line-args-left)) + (cond + (end-of-options + (setq file-p t)) + ((setq tem (when (eq (aref arg 0) ?-) + (or (assoc arg command-switch-alist) + (assoc (substring arg 1) + command-switch-alist)))) + (funcall (cdr tem) arg)) + ((string-match "\\`\\+[0-9]+\\'" arg) + (setq line (string-to-int arg))) + ;; "- file" means don't treat "file" as a switch + ;; ("+0 file" has the same effect; "-" added + ;; for unixoidiality). + ;; This is worthless; the `unixoid' way is "./file". -jwz + ((or (string= arg "-") (string= arg "--")) + (setq end-of-options t)) + (t + (setq file-p t))) + + (when file-p + (setq file-p nil) + (incf file-count) + (setq arg (expand-file-name arg dir)) + (cond + ((= file-count 1) (setq first-file-buffer + (progn (find-file arg) (current-buffer)))) + (noninteractive (find-file arg)) + (t (find-file-other-window arg))) + (when line + (goto-line line) + (setq line nil)))) + ;; If 3 or more files visited, and not all visible, + ;; show user what they all are. + (when (and (not noninteractive) + (> file-count 2) + (not (get-buffer-window first-file-buffer))) + (other-window 1) + (buffer-menu nil)))))) + +(defvar startup-presentation-hack-keymap + (let ((map (make-sparse-keymap))) + (set-keymap-name map 'startup-presentation-hack-keymap) + (define-key map '[button1] 'startup-presentation-hack) + (define-key map '[button2] 'startup-presentation-hack) + map) + "Putting yesterday in the future tomorrow.") + +(defun startup-presentation-hack () + (interactive) + (let ((e last-command-event)) + (and (button-press-event-p e) + (setq e (extent-at (event-point e) + (event-buffer e) + 'startup-presentation-hack)) + (setq e (extent-property e 'startup-presentation-hack)) + (if (consp e) + (apply (car e) (cdr e)) + (while (keymapp (indirect-function e)) + (let ((map e) + (overriding-local-map (indirect-function e))) + (setq e (read-key-sequence + (let ((p (keymap-prompt map t))) + (cond ((symbolp map) + (if p + (format "%s %s " map p) + (format "%s " map))) + (p) + (t + (prin1-to-string map)))))) + (if (and (button-release-event-p (elt e 0)) + (null (key-binding e))) + (setq e map) ; try again + (setq e (key-binding e))))) + (call-interactively e))))) + +(defun startup-presentation-hack-help (e) + (setq e (extent-property e 'startup-presentation-hack)) + (if (consp e) + (format "Evaluate %S" e) + (symbol-name e))) + +(defun splash-frame-present-hack (e v) + ;; (set-extent-property e 'mouse-face 'highlight) + ;; (set-extent-property e 'keymap + ;; startup-presentation-hack-keymap) + ;; (set-extent-property e 'startup-presentation-hack v) + ;; (set-extent-property e 'help-echo + ;; 'startup-presentation-hack-help)) + ) + +(defun splash-hack-version-string () + (save-excursion + (save-restriction + (goto-char (point-min)) + (re-search-forward "^XEmacs" nil t) + (narrow-to-region (point-at-bol) (point-at-eol)) + (goto-char (point-min)) + (when (re-search-forward " \\[Lucid\\]" nil t) + (delete-region (match-beginning 0) (match-end 0))) + (when (re-search-forward "[^(][^)]*-[^)]*-" nil t) + (delete-region (1+ (match-beginning 0)) (match-end 0)) + (insert "(")) + (goto-char (point-max)) + (search-backward " " nil t) + (when (search-forward "." nil t) + (delete-region (1- (point)) (point-max)))))) + +(defun splash-frame-present (l) + (cond ((stringp l) + (insert l)) + ((eq (car-safe l) 'face) + ;; (face name string) + (let ((p (point))) + (splash-frame-present (elt l 2)) + (if (fboundp 'set-extent-face) + (set-extent-face (make-extent p (point)) + (elt l 1))))) + ((eq (car-safe l) 'key) + (let* ((c (elt l 1)) + (p (point)) + (k (where-is-internal c nil t))) + (insert (if k (key-description k) + (format "M-x %s" c))) + (if (fboundp 'set-extent-face) + (let ((e (make-extent p (point)))) + (set-extent-face e 'bold) + (splash-frame-present-hack e c))))) + ((eq (car-safe l) 'funcall) + ;; (funcall (fun . args) string) + (let ((p (point))) + (splash-frame-present (elt l 2)) + (if (fboundp 'set-extent-face) + (splash-frame-present-hack (make-extent p (point)) + (elt l 1))))) + ((consp l) + (mapcar 'splash-frame-present l)) + (t + (error "WTF!?")))) + +(defun startup-center-spaces (glyph) + ;; Return the number of spaces to insert in order to center + ;; the given glyph (may be a string or a pixmap). + ;; Assume spaces are as wide as avg-pixwidth. + ;; Won't be quite right for proportional fonts, but it's the best we can do. + ;; Maybe the new redisplay will export something a glyph-width function. + ;;; #### Yes, there is a glyph-width function but it isn't quite what + ;;; #### this was expecting. Or is it? + ;; (An alternate way to get avg-pixwidth would be to use x-font-properties + ;; and calculate RESOLUTION_X * AVERAGE_WIDTH / 722.7, but it's no better.) + + ;; This function is used in about.el too. + (let* ((avg-pixwidth (round (/ (frame-pixel-width) (frame-width)))) + (fill-area-width (* avg-pixwidth (- fill-column left-margin))) + (glyph-pixwidth (cond ((stringp glyph) + (* avg-pixwidth (length glyph))) + ;; #### the pixmap option should be removed + ;;((pixmapp glyph) + ;; (pixmap-width glyph)) + ((glyphp glyph) + (glyph-width glyph)) + (t + (error "startup-center-spaces: bad arg"))))) + (+ left-margin + (round (/ (/ (- fill-area-width glyph-pixwidth) 2) avg-pixwidth))))) + +(defun startup-splash-frame-body () + `("\n" ,(emacs-version) "\n" + ,@(if (string-match "beta" emacs-version) + `( (face (bold blue) ( "This is an Experimental version of XEmacs. " + " Type " (key describe-beta) + " to see what this means.\n"))) + `( "\n")) + (face bold-italic "\ +Copyright (C) 1985-1997 Free Software Foundation, Inc. +Copyright (C) 1990-1994 Lucid, Inc. +Copyright (C) 1993-1997 Sun Microsystems, Inc. All Rights Reserved. +Copyright (C) 1994-1996 Board of Trustees, University of Illinois +Copyright (C) 1995-1996 Ben Wing\n\n") + + ,@(if (featurep 'sparcworks) + `( "\ +Sun provides support for the WorkShop/XEmacs integration package only. +All other XEmacs packages are provided to you \"AS IS\". +For full details, type " (key describe-no-warranty) +" to refer to the GPL Version 2, dated June 1991.\n\n" +,@(let ((lang (or (getenv "LC_ALL") (getenv "LC_MESSAGES") (getenv "LANG")))) + (if (and + (not (featurep 'mule)) ; Already got mule? + (not (eq 'tty (console-type))) ; No Mule support on tty's yet + lang ; Non-English locale? + (not (string= lang "C")) + (not (string-match "^en" lang)) + (locate-file "xemacs-mule" exec-path)) ; Comes with Sun WorkShop + '( "\ +This version of XEmacs has been built with support for Latin-1 languages only. +To handle other languages you need to run a Multi-lingual (`Mule') version of +XEmacs, by either running the command `xemacs-mule', or by using the X resource +`ESERVE*defaultXEmacsPath: xemacs-mule' when starting XEmacs from Sun WorkShop.\n\n")))) + + '("XEmacs comes with ABSOLUTELY NO WARRANTY; type " + (key describe-no-warranty) " for full details.\n")) + + "You may give out copies of XEmacs; type " + (key describe-copying) " to see the conditions.\n" + "Type " (key describe-distribution) + " for information on getting the latest version.\n\n" + + "Type " (key help-command) " or use the " (face bold "Help") " menu to get help.\n" + "Type " (key advertised-undo) " to undo changes (`C-' means use the Control key).\n" + "To get out of XEmacs, type " (key save-buffers-kill-emacs) ".\n" + "Type " (key help-with-tutorial) " for a tutorial on using XEmacs.\n" + "Type " (key info) " to enter Info, " + "which you can use to read online documentation.\n" + (face (bold red) ( "\ +For tips and answers to frequently asked questions, see the XEmacs FAQ. +\(It's on the Help menu, or type " (key xemacs-local-faq) " [a capital F!].\)")))) + +(defun startup-splash-frame () + (let ((p (point)) + (cramped-p (eq 'tty (console-type)))) + (unless cramped-p (insert "\n")) + (indent-to (startup-center-spaces xemacs-logo)) + (set-extent-begin-glyph (make-extent (point) (point)) xemacs-logo) + (insert (if cramped-p "\n" "\n\n")) + (splash-frame-present-hack (make-extent p (point)) 'about-xemacs)) + + (let ((after-change-functions nil)) ; no font-lock, thank you + (dolist (l (startup-splash-frame-body)) + (splash-frame-present l))) + (splash-hack-version-string) + (set-buffer-modified-p nil)) + +;; (let ((present-file +;; #'(lambda (f) +;; (splash-frame-present +;; (list 'funcall +;; (list 'find-file-other-window +;; (expand-file-name f data-directory)) +;; f))))) +;; (insert "For customization examples, see the files ") +;; (funcall present-file "sample.emacs") +;; (insert " and ") +;; (funcall present-file "sample.Xdefaults") +;; (insert (format "\nin the directory %s." data-directory))) + + +;;;; Computing the default load-path, etc. +;;; +;;; This stuff is a complete mess and isn't nearly as general as it +;;; thinks it is. It should be rethunk. In particular, too much logic +;;; is duplicated between the code that looks around for the various +;;; directories, and the code which suggests where to create the various +;;; directories once it decides they are missing. + +;;; The source directory has this layout: +;;; +;;; BUILD_ROOT/src/xemacs* argv[0] +;;; BUILD_ROOT/xemacs* argv[0], possibly +;;; BUILD_ROOT/lisp/ +;;; BUILD_ROOT/etc/ data-directory +;;; BUILD_ROOT/info/ +;;; BUILD_ROOT/lib-src/ exec-directory, doc-directory +;;; BUILD_ROOT/lock/ +;;; +;;; The default tree created by "make install" has this layout: +;;; +;;; PREFIX/bin/xemacs* argv[0] +;;; PREFIX/lib/xemacs-VERSION/lisp/ +;;; PREFIX/lib/xemacs-VERSION/etc/ data-directory +;;; PREFIX/lib/xemacs-VERSION/info/ +;;; PREFIX/lib/xemacs-VERSION/CONFIGURATION/ exec-directory, doc-directory +;;; PREFIX/lib/xemacs/lock/ +;;; PREFIX/lib/xemacs/site-lisp/ +;;; +;;; The binary packages we ship have that layout, except that argv[0] has +;;; been moved one level deeper under the bin directory: +;;; +;;; PREFIX/bin/CONFIGURATION/xemacs* +;;; +;;; The following code has to deal with at least the above three situations, +;;; and it should be possible for it to deal with more. Though perhaps that +;;; does cover it all? The trick is, when something is missing, realizing +;;; which of those three layouts is mostly in place, so that we can suggest +;;; the right directories in the error message. + + +;; extremely low-tech debugging, since this happens so early in startup. +;;(or (fboundp 'orig-file-directory-p) +;; (fset 'orig-file-directory-p (symbol-function 'file-directory-p))) +;;(defun file-directory-p (path) +;; (send-string-to-terminal (format "PROBING %S" path)) +;; (let ((v (orig-file-directory-p path))) +;; (send-string-to-terminal (format " -> %S\n" v)) +;; v)) + +(defun startup-make-version-dir () + (let ((version (and (string-match "\\`[^0-9]*\\([0-9]+\\.[0-9]+\\)" + emacs-version) + (substring emacs-version + (match-beginning 1) (match-end 1))))) + (if (string-match "(beta *\\([0-9]+\\))" emacs-version) + (setq version (concat version "-b" + (substring emacs-version (match-beginning 1) + (match-end 1))))) + (if (string-match "(alpha *\\([0-9]+\\))" emacs-version) + (setq version (concat version "-a" + (substring emacs-version (match-beginning 1) + (match-end 1))))) + (concat "lib/xemacs-" version))) + +(defun find-emacs-root-internal-1 (path lisp-p) + ;; (prin1 (format "f-e-r-i-1: %s\n" path)) + (let ((dir (file-name-directory path))) + (or + ;; + ;; If this directory is a plausible root of the XEmacs tree, return it. + ;; + (and (or (not lisp-p) + (file-directory-p (expand-file-name "lisp/prim" dir))) + (or (file-directory-p (expand-file-name "lib-src" dir)) + (file-directory-p (expand-file-name system-configuration dir))) + dir) + ;; + ;; If the parent of this directory is a plausible root, use it. + ;; (But don't do so recursively!) + ;; + (and (or (not lisp-p) + (file-directory-p (expand-file-name "../lisp/prim" dir))) + (or (file-directory-p (expand-file-name + (format "../%s" system-configuration) + dir)) + (file-directory-p (expand-file-name "../lib-src" dir))) + (expand-file-name "../" dir)) + + ;; + ;; (--run-in-place) Same thing, but from one directory level deeper. + ;; + (and (or (not lisp-p) + (file-directory-p (expand-file-name "../../lisp/prim" dir))) + (or (file-directory-p (expand-file-name + (format "../%s" system-configuration) + dir)) + (file-directory-p + (expand-file-name + (format "../../lib-src/%s" system-configuration) dir))) + (expand-file-name "../.." dir)) + + ;; If ../lib/xemacs-<version> exists check it. + ;; This is of the form "xemacs-19.10/" or "xemacs-19.10-b7/". + ;; + (let ((ver-dir (concat "../" (startup-make-version-dir)))) + (and (or (not lisp-p) + (file-directory-p (expand-file-name + (format "%s/lisp/prim" ver-dir) + dir))) + (or (file-directory-p (expand-file-name + (format "%s/%s" ver-dir + system-configuration) + dir)) + (file-directory-p (expand-file-name + (format "%s/lib-src" ver-dir) + dir))) + (expand-file-name (file-name-as-directory ver-dir) dir))) + ;; + ;; Same thing, but one higher: ../../lib/xemacs-<version>. + ;; + (let ((ver-dir (concat "../../" (startup-make-version-dir)))) + (and (or (not lisp-p) + (file-directory-p (expand-file-name + (format "%s/lisp/prim" ver-dir) + dir))) + (or (file-directory-p (expand-file-name + (format "%s/%s" ver-dir + system-configuration) + dir)) + (file-directory-p (expand-file-name + (format "%s/lib-src" ver-dir) + dir))) + (expand-file-name (file-name-as-directory ver-dir) dir))) + ;; + ;; If that doesn't work, and the XEmacs executable is a symlink, then + ;; chase the link and try again there. + ;; + (and (setq path (file-symlink-p path)) + (find-emacs-root-internal-1 (expand-file-name path dir) lisp-p)) + ;; + ;; Otherwise, this directory just doesn't cut it. + ;; Some bozos think they can use the 18.59 lisp directory with 19.*. + ;; This is because they're not using their brains. But it might be + ;; nice to notice that that is happening and point them in the + ;; general direction of a clue. + ;; + nil))) + +(defun find-emacs-root-internal (path) + ;; (send-string-to-terminal (format "FINDING ROOT FOR %S\n" path)) + ;; first look for lisp/prim and lib-src; then just look for lib-src. + ;; XEmacs can run (kind of) if the lisp directory is omitted, which + ;; some people might want to do for space reasons. + (or (find-emacs-root-internal-1 path t) + ;; (find-emacs-root-internal-1 path nil) + ;; If we don't succeed we are going to crash and burn for sure. + ;; Try some paths relative to prefix-directory if it isn't nil. + ;; This is definitely necessary in cases such as when we're used + ;; as a login shell since we can't determine the invocation + ;; directory in that case. + + (find-emacs-root-internal-1 + (format "%s/bin/%s" prefix-directory invocation-name) t) + (find-emacs-root-internal-1 + (format "%s/bin/%s" prefix-directory invocation-name) nil) + (find-emacs-root-internal-1 + (format "%s/lib/%s" prefix-directory invocation-name) t) + (find-emacs-root-internal-1 + (format "%s/lib/%s" prefix-directory invocation-name) nil) + + ;; We're desperate -- try the prefix-directory correctly. + (find-emacs-root-internal-1 + (format "%s/%s/foo" prefix-directory (startup-make-version-dir)) t) + (find-emacs-root-internal-1 + (format "%s/%s/foo" prefix-directory (startup-make-version-dir)) nil) + )) + +(defun set-default-load-path () + ;; XEmacs -- Steven Baur says invocation directory is nil if you + ;; try to use XEmacs as a login shell. + (or invocation-directory (setq invocation-directory default-directory)) + (setq invocation-directory + ;; don't let /tmp_mnt/... get into the load-path or exec-path. + (abbreviate-file-name invocation-directory)) + + ;; #### FSFmacs recognizes environment vars EMACSLOCKDIR, etc. + (let* ((root (find-emacs-root-internal (concat invocation-directory + invocation-name))) + (lisp (and root + (let ((f (expand-file-name "lisp" root))) + (and (file-directory-p f) f)))) + (site-lisp + (and root + (or + (let ((f (expand-file-name "xemacs/site-lisp" root))) + (and (file-directory-p f) f)) + (let ((f (expand-file-name "../xemacs/site-lisp" root))) + (and (file-directory-p f) f)) + ;; the next two are for --run-in-place + (let ((f (expand-file-name "site-lisp" root))) + (and (file-directory-p f) f)) + (let ((f (expand-file-name "lisp/site-lisp" root))) + (and (file-directory-p f) f)) + ))) + (lib-src + (and root + (or + (let ((f (expand-file-name + (concat "lib-src/" system-configuration) + root))) + (and (file-directory-p f) f)) + (let ((f (expand-file-name "lib-src" root))) + (and (file-directory-p f) f)) + (let ((f (expand-file-name system-configuration root))) + (and (file-directory-p f) f))))) + (etc + (and root + (let ((f (expand-file-name "etc" root))) + (and (file-directory-p f) f)))) + (info + (and root + (let ((f (expand-file-name "info" root))) + (and (file-directory-p f) (file-name-as-directory f))))) + (packages + (and root + (let ((f (expand-file-name "packages" root))) + (and (file-directory-p f) (file-name-as-directory f))))) + (lock + (and root + (boundp 'lock-directory) + (if (and lock-directory (file-directory-p lock-directory)) + (file-name-as-directory lock-directory) + (or + (let ((f (expand-file-name "xemacs/lock" root))) + (and (file-directory-p f) + (file-name-as-directory f))) + (let ((f (expand-file-name "../xemacs/lock" root))) + (and (file-directory-p f) + (file-name-as-directory f))) + (let ((f (expand-file-name "lock" root))) + (and (file-directory-p f) + (file-name-as-directory f))) + ;; if none of them exist, make the "guess" be + ;; the one that set-default-load-path-warning + ;; will suggest. + (file-name-as-directory + (expand-file-name "../xemacs/lock" root)) + ))))) + + ;; 1996/12/6 by MORIOKA Tomohiko <morioka@jaist.ac.jp> + ;; define `default-load-path' for file-detect.el + (setq default-load-path load-path) + + ;; add site-lisp dir to load-path + (when site-lisp + ;; If the site-lisp dir isn't on the load-path, add it to the end. + (or (member site-lisp load-path) + (setq load-path (append load-path (list site-lisp)))) + ;; Also add any direct subdirectories of the site-lisp directory + ;; to the load-path. But don't add dirs whose names begin + ;; with dot or hyphen. + (let ((files (directory-files site-lisp nil "^[^-.]" nil 'dirs-only)) + file) + (while files + (setq file (car files)) + (if (and (not (member file '("RCS" "CVS" "SCCS"))) + (setq file (expand-file-name file site-lisp)) + (not (member file load-path))) + (setq load-path + (nconc load-path + (list (file-name-as-directory file))))) + (setq files (cdr files))))) + + ;; add lisp dir to load-path + (when lisp + ;; If the lisp dir isn't on the load-path, add it to the end. + (or (member lisp load-path) + (setq load-path (append load-path (list lisp)))) + ;; Also add any direct subdirectories of the lisp directory + ;; to the load-path. But don't add dirs whose names begin + ;; with dot or hyphen. + (let ((files (directory-files lisp nil "^[^-.]" nil 'dirs-only)) + file) + (while files + (setq file (car files)) + (when (and (not (member file '("RCS" "CVS" "SCCS"))) + (setq file (expand-file-name file lisp)) + (not (member file load-path))) + (setq load-path + (nconc load-path + (list (file-name-as-directory file))))) + (setq files (cdr files))))) + + ;; 1996/12/6 by MORIOKA Tomohiko <morioka@jaist.ac.jp> + ;; define `default-load-path' for file-detect.el + (setq default-load-path + (append default-load-path + (if site-lisp + (list site-lisp)) + (if lisp + (list lisp) + ) + )) + + ;; 1997/03/06 by Jeff Miller <jmiller@bayserve.net> + ;; initialize 'site-directory'. This is the site-lisp dir used by + ;; XEmacs + (if site-lisp + (setq site-directory (file-name-as-directory site-lisp)) + ) + ;; If running from the build directory, always prefer the exec-directory + ;; that is here over to the one that came from paths.h. + (when (or (and (null exec-directory) lib-src) + (and (string= lib-src (expand-file-name "lib-src" root)) + (not (string= exec-directory lib-src)))) + (setq exec-directory (file-name-as-directory lib-src))) + (when (or (and (null doc-directory) lib-src) + (and (string= lib-src (expand-file-name "lib-src" root)) + (not (string= doc-directory lib-src)))) + (setq doc-directory (file-name-as-directory lib-src))) + + (when exec-directory + (or (member exec-directory exec-path) + (setq exec-path (append exec-path (list exec-directory))))) + (when (or (and (null data-directory) etc) + (and (string= etc (expand-file-name "etc" root)) + (not (string= data-directory etc)))) + (setq data-directory (file-name-as-directory etc))) + + ;; If `configure' specified an info dir, use it. + ;; #### The above comment is suspect. + (or (boundp 'Info-default-directory-list) + (setq Info-default-directory-list nil)) + + ;; Add additional system directories. + (setq Info-default-directory-list + (append Info-default-directory-list + (split-string infopath-internal ":"))) + + (let ((infopath (getenv "INFOPATH"))) + (when infopath + (setq Info-default-directory-list + (append Info-default-directory-list + (split-string infopath ":"))))) + + (cond (configure-info-directory + (setq configure-info-directory (file-name-as-directory + configure-info-directory)) + (or (member configure-info-directory Info-default-directory-list) + (setq Info-default-directory-list + (append (list configure-info-directory) + Info-default-directory-list))))) + ;; If we've guessed the info dir, use that (too). + (when (and info (not (member info Info-default-directory-list))) + (setq Info-default-directory-list + (append (list info) Info-default-directory-list))) + + ;; Default the lock dir to being a sibling of the data-directory. + ;; If superlock isn't set, or is set to a file in a nonexistent + ;; directory, derive it from the lock dir. + (when (boundp 'lock-directory) + (setq lock-directory lock) + (cond ((null lock-directory) + (setq superlock-file nil)) + ((or (null superlock-file) + (not (file-directory-p + (file-name-directory superlock-file)))) + (setq superlock-file + (expand-file-name "!!!SuperLock!!!" + lock-directory))))) + + (set-default-load-path-warning) + (when (and data-directory Info-default-directory-list) + (setq data-directory-list (list data-directory)) + (packages-find-packages package-path nil)))) + + +(defun set-default-load-path-warning () + (let ((lock (if (boundp 'lock-directory) lock-directory 't)) + warnings message guess) + (when (and (stringp lock) (not (file-directory-p lock))) + (setq lock nil)) + (cond + ((not (and exec-directory data-directory doc-directory load-path lock)) + (save-excursion + (set-buffer (get-buffer-create " *warning-tmp*")) + (erase-buffer) + (buffer-disable-undo (current-buffer)) + (when (null lock) (push "lock-directory" warnings)) + (when (null exec-directory) (push "exec-directory" warnings)) + (when (null data-directory) (push "data-directory" warnings)) + (when (null doc-directory) (push "doc-directory" warnings)) + (when (null load-path) (push "load-path" warnings)) + (cond ((cdr (cdr warnings)) + (setq message (apply 'format "%s, %s, and %s" warnings))) + ((cdr warnings) + (setq message (apply 'format "%s and %s" warnings))) + (t (setq message (format "variable %s" (car warnings))))) + (insert "couldn't find an obvious default for " message + ", and there were no defaults specified in paths.h when " + "XEmacs was built. Perhaps some directories don't exist, " + "or the XEmacs executable, " (concat invocation-directory + invocation-name) + " is in a strange place?") + (setq guess (or exec-directory + data-directory + doc-directory + (car load-path) + (and (string-match "/[^/]+\\'" invocation-directory) + (substring invocation-directory 0 + (match-beginning 0))))) + (when (and guess + (or + ;; parent of a terminal bin/<configuration> pair (hack hack). + (string-match (concat "/bin/" + (regexp-quote system-configuration) + "/?\\'") + guess) + ;; parent of terminal src, lib-src, etc, or lisp dir. + (string-match + "/\\(bin\\|src\\|lib-src\\|etc\\|lisp\\)[^/]*/?\\'" + guess))) + (setq guess (substring guess 0 (match-beginning 0)))) + + ;; If neither the exec nor lisp dirs are around, then "guess" that + ;; the new configure-style lib dir should be used. Otherwise, if + ;; only one of them appears to be missing, or it's just lock, + ;; then guess it to be a sibling of whatever already exists. + (when (and (null exec-directory) (null load-path)) + (setq guess (expand-file-name (startup-make-version-dir) guess))) + + (when (or (null exec-directory) (null load-path)) + (insert + "\n\nWithout both exec-directory and load-path, XEmacs will " + "be very broken. ")) + (when (and (null exec-directory) guess) + (insert + "Consider making a symbolic link from " + (expand-file-name system-configuration guess) + " to wherever the appropriate XEmacs exec-directory " + "directory is")) + (when (and (null data-directory) guess) + (insert + (if exec-directory + "\n\nConsider making a symbolic link " ", and ") + "from " + (expand-file-name "etc" (if load-path + (file-name-directory + (directory-file-name + (car load-path))) + guess)) + " to wherever the appropriate XEmacs data-directory is")) + (when (and (null load-path) guess) + (insert + (if (and exec-directory data-directory) + "Consider making a symbolic link " + ", and ") + "from " + (expand-file-name "lisp" guess) + " to wherever the appropriate XEmacs lisp library is")) + (insert ".") + + (when (null lock) + (insert + "\n\nWithout lock-directory set, file locking won't work. ") + (when guess + (insert + "Consider creating " + (expand-file-name "../xemacs/lock" + (or (find-emacs-root-internal + (concat invocation-directory + invocation-name)) + guess)) + " as a directory or symbolic link for use as the lock " + "directory. (This directory must be globally writable.)" + ))) + + (when (fboundp 'fill-region) + ;; Might not be bound in the cold load environment... + (let ((fill-column 76)) + (fill-region (point-min) (point-max)))) + (goto-char (point-min)) + (princ "\nWARNING:\n" 'external-debugging-output) + (princ (buffer-string) 'external-debugging-output) + (erase-buffer) + t))))) + +;;; startup.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/subr.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,669 @@ +;;; subr.el --- basic lisp subroutines for XEmacs + +;; Copyright (C) 1985, 1986, 1992, 1994-5, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp. +;; Copyright (C) 1995 Sun Microsystems. + +;; Maintainer: XEmacs Development Team +;; Keywords: extensions, dumped + +;; 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.34. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;; There's not a whole lot in common now with the FSF version, +;; be wary when applying differences. I've left in a number of lines +;; of commentary just to give diff(1) something to synch itself with to +;; provide useful context diffs. -sb + +;;; Code: + + +;;;; Lisp language features. + +(defmacro lambda (&rest cdr) + "Return a lambda expression. +A call of the form (lambda ARGS DOCSTRING INTERACTIVE BODY) is +self-quoting; the result of evaluating the lambda expression is the +expression itself. The lambda expression may then be treated as a +function, i.e., stored as the function value of a symbol, passed to +funcall or mapcar, etc. + +ARGS should take the same form as an argument list for a `defun'. +DOCSTRING is an optional documentation string. + If present, it should describe how to call the function. + But documentation strings are usually not useful in nameless functions. +INTERACTIVE should be a call to the function `interactive', which see. +It may also be omitted. +BODY should be a list of lisp expressions." + `(function (lambda ,@cdr))) + +(defmacro defun-when-void (&rest args) + "Define a function, just like `defun', unless it's already defined. +Used for compatibility among different emacs variants." + `(if (fboundp ',(car args)) + nil + (defun ,@args))) + +(defmacro define-function-when-void (&rest args) + "Define a function, just like `define-function', unless it's already defined. +Used for compatibility among different emacs variants." + `(if (fboundp ,(car args)) + nil + (define-function ,@args))) + + +;;;; Keymap support. +;; XEmacs: removed to keymap.el + +;;;; The global keymap tree. + +;;; global-map, esc-map, and ctl-x-map have their values set up in +;;; keymap.c; we just give them docstrings here. + +;;;; Event manipulation functions. + +;; The call to `read' is to ensure that the value is computed at load time +;; and not compiled into the .elc file. The value is negative on most +;; machines, but not on all! +(defconst listify-key-sequence-1 (logior 128 (read "?\\M-\\^@"))) + +(defun listify-key-sequence (key) + "Convert a key sequence to a list of events." + (if (vectorp key) + (append key nil) + (mapcar (function (lambda (c) + (if (> c 127) + (logxor c listify-key-sequence-1) + c))) + (append key nil)))) +;; XEmacs: This stuff is done in C Code. + +;;;; Obsolescent names for functions. +;; 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 +can be used to determine whether `make-variable-buffer-local' has been +called on SYM." + (local-variable-p sym buffer t)) + + +;;;; Hook manipulation functions. + +;; (defconst run-hooks 'run-hooks ...) + +(defun make-local-hook (hook) + "Make the hook HOOK local to the current buffer. +When a hook is local, its local and global values +work in concert: running the hook actually runs all the hook +functions listed in *either* the local value *or* the global value +of the hook variable. + +This function works by making `t' a member of the buffer-local value, +which acts as a flag to run the hook functions in the default value as +well. This works for all normal hooks, but does not work for most +non-normal hooks yet. We will be changing the callers of non-normal +hooks so that they can handle localness; this has to be done one by +one. + +This function does nothing if HOOK is already local in the current +buffer. + +Do not use `make-local-variable' to make a hook variable buffer-local." + (if (local-variable-p hook (current-buffer)) ; XEmacs + nil + (or (boundp hook) (set hook nil)) + (make-local-variable hook) + (set hook (list t)))) + +(defun add-hook (hook function &optional append local) + "Add to the value of HOOK the function FUNCTION. +FUNCTION is not added if already present. +FUNCTION is added (if necessary) at the beginning of the hook list +unless the optional argument APPEND is non-nil, in which case +FUNCTION is added at the end. + +The optional fourth argument, LOCAL, if non-nil, says to modify +the hook's buffer-local value rather than its default value. +This makes no difference if the hook is not buffer-local. +To make a hook variable buffer-local, always use +`make-local-hook', not `make-local-variable'. + +HOOK should be a symbol, and FUNCTION may be any valid function. If +HOOK is void, it is first set to nil. If HOOK's value is a single +function, it is changed to a list of functions." + (or (boundp hook) (set hook nil)) + (or (default-boundp hook) (set-default hook nil)) + ;; If the hook value is a single function, turn it into a list. + (let ((old (symbol-value hook))) + (if (or (not (listp old)) (eq (car old) 'lambda)) + (set hook (list old)))) + (if (or local + ;; Detect the case where make-local-variable was used on a hook + ;; and do what we used to do. + (and (local-variable-if-set-p hook (current-buffer)) ; XEmacs + (not (memq t (symbol-value hook))))) + ;; Alter the local value only. + (or (if (consp function) + (member function (symbol-value hook)) + (memq function (symbol-value hook))) + (set hook + (if append + (append (symbol-value hook) (list function)) + (cons function (symbol-value hook))))) + ;; Alter the global value (which is also the only value, + ;; if the hook doesn't have a local value). + (or (if (consp function) + (member function (default-value hook)) + (memq function (default-value hook))) + (set-default hook + (if append + (append (default-value hook) (list function)) + (cons function (default-value hook))))))) + +(defun remove-hook (hook function &optional local) + "Remove from the value of HOOK the function FUNCTION. +HOOK should be a symbol, and FUNCTION may be any valid function. If +FUNCTION isn't the value of HOOK, or, if FUNCTION doesn't appear in the +list of hooks to run in HOOK, then nothing is done. See `add-hook'. + +The optional third argument, LOCAL, if non-nil, says to modify +the hook's buffer-local value rather than its default value. +This makes no difference if the hook is not buffer-local. +To make a hook variable buffer-local, always use +`make-local-hook', not `make-local-variable'." + (if (or (not (boundp hook)) ;unbound symbol, or + (not (default-boundp 'hook)) + (null (symbol-value hook)) ;value is nil, or + (null function)) ;function is nil, then + nil ;Do nothing. + (if (or local + ;; Detect the case where make-local-variable was used on a hook + ;; and do what we used to do. + (and (local-variable-p hook (current-buffer)) + (not (memq t (symbol-value hook))))) + (let ((hook-value (symbol-value hook))) + (if (consp hook-value) + (if (member function hook-value) + (setq hook-value (delete function (copy-sequence hook-value)))) + (if (equal hook-value function) + (setq hook-value nil))) + (set hook hook-value)) + (let ((hook-value (default-value hook))) + (if (consp hook-value) + (if (member function hook-value) + (setq hook-value (delete function (copy-sequence hook-value)))) + (if (equal hook-value function) + (setq hook-value nil))) + (set-default hook hook-value))))) + +(defun add-to-list (list-var element) + "Add to the value of LIST-VAR the element ELEMENT if it isn't there yet. +The test for presence of ELEMENT is done with `equal'. +If you want to use `add-to-list' on a variable that is not defined +until a certain package is loaded, you should put the call to `add-to-list' +into a hook function that will be run only after loading the package. +`eval-after-load' provides one way to do this. In some cases +other hooks, such as major mode hooks, can do the job." + (or (member element (symbol-value list-var)) + (set list-var (cons element (symbol-value list-var))))) + +;; XEmacs additions +;; called by Fkill_buffer() +(defvar kill-buffer-hook nil + "Function or functions to be called when a buffer is killed. +The value of this variable may be buffer-local. +The buffer about to be killed is current when this hook is run.") + +;; in C in FSFmacs +(defvar kill-emacs-hook nil + "Function or functions to be called when `kill-emacs' is called, +just before emacs is actually killed.") + +;; not obsolete. +;; #### These are a bad idea, because the CL RPLACA and RPLACD +;; return the cons cell, not the new CAR/CDR. -hniksic +;; The proper definition would be: +;; (defun rplaca (conscell newcar) +;; (setcar conscell newcar) +;; conscell) +;; ...and analogously for RPLACD. +(define-function 'rplaca 'setcar) +(define-function 'rplacd 'setcdr) + +;;;; String functions. + +;; XEmacs +(defun replace-in-string (str regexp newtext &optional literal) + "Replaces all matches in STR for REGEXP with NEWTEXT string, + and returns the new string. +Optional LITERAL non-nil means do a literal replacement. +Otherwise treat \\ in NEWTEXT string as special: + \\& means substitute original matched text, + \\N means substitute match for \(...\) number N, + \\\\ means insert one \\." + (check-argument-type 'stringp str) + (check-argument-type 'stringp newtext) + (let ((rtn-str "") + (start 0) + (special) + match prev-start) + (while (setq match (string-match regexp str start)) + (setq prev-start start + start (match-end 0) + rtn-str + (concat + rtn-str + (substring str prev-start match) + (cond (literal newtext) + (t (mapconcat + (lambda (c) + (if special + (progn + (setq special nil) + (cond ((eq c ?\\) "\\") + ((eq c ?&) + (substring str + (match-beginning 0) + (match-end 0))) + ((and (>= c ?0) (<= c ?9)) + (if (> c (+ ?0 (length + (match-data)))) + ;; Invalid match num + (error "Invalid match num: %c" c) + (setq c (- c ?0)) + (substring str + (match-beginning c) + (match-end c)))) + (t (char-to-string c)))) + (if (eq c ?\\) (progn (setq special t) nil) + (char-to-string c)))) + newtext "")))))) + (concat rtn-str (substring str start)))) + +(defun split-string (string &optional pattern) + "Return a list of substrings of STRING which are separated by PATTERN. +If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." + (or pattern + (setq pattern "[ \f\t\n\r\v]+")) + ;; The FSF version of this function takes care not to cons in case + ;; of infloop. Maybe we should synch? + (let (parts (start 0)) + (while (string-match pattern string start) + (setq parts (cons (substring string start (match-beginning 0)) parts) + start (match-end 0))) + (nreverse (cons (substring string start) parts)))) + +(defmacro with-output-to-string (&rest forms) + "Collect output to `standard-output' while evaluating FORMS and return +it as a string." + ;; by "William G. Dubuque" <wgd@zurich.ai.mit.edu> w/ mods from Stig + `(with-current-buffer (get-buffer-create " *string-output*") + (setq buffer-read-only nil) + (buffer-disable-undo (current-buffer)) + (erase-buffer) + (let ((standard-output (current-buffer))) + ,@forms) + (prog1 + (buffer-string) + (erase-buffer)))) + +(defmacro with-current-buffer (buffer &rest body) + "Execute the forms in BODY with BUFFER as the current buffer. +The value returned is the value of the last form in BODY. +See also `with-temp-buffer'." + `(save-current-buffer + (set-buffer ,buffer) + ,@body)) + +(defmacro with-temp-file (file &rest forms) + "Create a new buffer, evaluate FORMS there, and write the buffer to FILE. +The value of the last form in FORMS is returned, like `progn'. +See also `with-temp-buffer'." + (let ((temp-file (make-symbol "temp-file")) + (temp-buffer (make-symbol "temp-buffer"))) + `(let ((,temp-file ,file) + (,temp-buffer + (get-buffer-create (generate-new-buffer-name " *temp file*")))) + (unwind-protect + (prog1 + (with-current-buffer ,temp-buffer + ,@forms) + (with-current-buffer ,temp-buffer + (widen) + (write-region (point-min) (point-max) ,temp-file nil 0))) + (and (buffer-name ,temp-buffer) + (kill-buffer ,temp-buffer)))))) + +(defmacro with-temp-buffer (&rest forms) + "Create a temporary buffer, and evaluate FORMS there like `progn'. +See also `with-temp-file' and `with-output-to-string'." + (let ((temp-buffer (make-symbol "temp-buffer"))) + `(let ((,temp-buffer + (get-buffer-create (generate-new-buffer-name " *temp*")))) + (unwind-protect + (with-current-buffer ,temp-buffer + ,@forms) + (and (buffer-name ,temp-buffer) + (kill-buffer ,temp-buffer)))))) + +;; Moved from mule-coding.el. +(defmacro with-string-as-buffer-contents (str &rest body) + "With the contents of the current buffer being STR, run BODY. +Returns the new contents of the buffer, as modified by BODY. +The original current buffer is restored afterwards." + `(let ((tempbuf (get-buffer-create " *string-as-buffer-contents*"))) + (with-current-buffer tempbuf + (unwind-protect + (progn + (buffer-disable-undo (current-buffer)) + (erase-buffer) + (insert ,str) + ,@body + (buffer-string)) + (erase-buffer tempbuf))))) + +(defun insert-face (string face) + "Insert STRING and highlight with FACE. Returns the extent created." + (let ((p (point)) ext) + (insert string) + (setq ext (make-extent p (point))) + (set-extent-face ext face) + ext)) + +;; not obsolete. +(define-function 'string= 'string-equal) +(define-function 'string< 'string-lessp) +(define-function 'int-to-string 'number-to-string) +(define-function 'string-to-int 'string-to-number) + +;; These two names are a bit awkward, as they conflict with the normal +;; foo-to-bar naming scheme, but CLtL2 has them, so they stay. +(define-function 'char-int 'char-to-int) +(define-function 'int-char 'int-to-char) + + +;; alist/plist functions +(defun plist-to-alist (plist) + "Convert property list PLIST into the equivalent association-list form. +The alist is returned. This converts from + +\(a 1 b 2 c 3) + +into + +\((a . 1) (b . 2) (c . 3)) + +The original plist is not modified. See also `destructive-plist-to-alist'." + (let (alist) + (while plist + (setq alist (cons (cons (car plist) (cadr plist)) alist)) + (setq plist (cddr plist))) + (nreverse alist))) + +(defun destructive-plist-to-alist (plist) + "Convert property list PLIST into the equivalent association-list form. +The alist is returned. This converts from + +\(a 1 b 2 c 3) + +into + +\((a . 1) (b . 2) (c . 3)) + +The original plist is destroyed in the process of constructing the alist. +See also `plist-to-alist'." + (let ((head plist) + next) + (while plist + ;; remember the next plist pair. + (setq next (cddr plist)) + ;; make the cons holding the property value into the alist element. + (setcdr (cdr plist) (cadr plist)) + (setcar (cdr plist) (car plist)) + ;; reattach into alist form. + (setcar plist (cdr plist)) + (setcdr plist next) + (setq plist next)) + head)) + +(defun alist-to-plist (alist) + "Convert association list ALIST into the equivalent property-list form. +The plist is returned. This converts from + +\((a . 1) (b . 2) (c . 3)) + +into + +\(a 1 b 2 c 3) + +The original alist is not modified. See also `destructive-alist-to-plist'." + (let (plist) + (while alist + (let ((el (car alist))) + (setq plist (cons (cdr el) (cons (car el) plist)))) + (setq alist (cdr alist))) + (nreverse plist))) + +;; getf, remf in cl*.el. + +(defmacro putf (plist prop val) + "Add property PROP to plist PLIST with value VAL. +Analogous to (setq PLIST (plist-put PLIST PROP VAL))." + `(setq ,plist (plist-put ,plist ,prop ,val))) + +(defmacro laxputf (lax-plist prop val) + "Add property PROP to lax plist LAX-PLIST with value VAL. +Analogous to (setq LAX-PLIST (lax-plist-put LAX-PLIST PROP VAL))." + `(setq ,lax-plist (lax-plist-put ,lax-plist ,prop ,val))) + +(defmacro laxremf (lax-plist prop) + "Remove property PROP from lax plist LAX-PLIST. +Analogous to (setq LAX-PLIST (lax-plist-remprop LAX-PLIST PROP))." + `(setq ,lax-plist (lax-plist-remprop ,lax-plist ,prop))) + +;;; Error functions + +(defun error (&rest args) + "Signal an error, making error message by passing all args to `format'. +This error is not continuable: you cannot continue execution after the +error using the debugger `r' command. See also `cerror'." + (while t + (apply 'cerror args))) + +(defun cerror (&rest args) + "Like `error' but signals a continuable error." + (signal 'error (list (apply 'format args)))) + +(defmacro check-argument-type (predicate argument) + "Check that ARGUMENT satisfies PREDICATE. +If not, signal a continuable `wrong-type-argument' error until the +returned value satisfies PREDICATE, and assign the returned value +to ARGUMENT." + `(if (not (,(eval predicate) ,argument)) + (setq ,argument + (wrong-type-argument ,predicate ,argument)))) + +(defun signal-error (error-symbol data) + "Signal a non-continuable error. Args are ERROR-SYMBOL, and associated DATA. +An error symbol is a symbol defined using `define-error'. +DATA should be a list. Its elements are printed as part of the error message. +If the signal is handled, DATA is made available to the handler. +See also `signal', and the functions to handle errors: `condition-case' +and `call-with-condition-handler'." + (while t + (signal error-symbol data))) + +(defun define-error (error-sym doc-string &optional inherits-from) + "Define a new error, denoted by ERROR-SYM. +DOC-STRING is an informative message explaining the error, and will be +printed out when an unhandled error occurs. +ERROR-SYM is a sub-error of INHERITS-FROM (which defaults to `error'). + +\[`define-error' internally works by putting on ERROR-SYM an `error-message' +property whose value is DOC-STRING, and an `error-conditions' property +that is a list of ERROR-SYM followed by each of its super-errors, up +to and including `error'. You will sometimes see code that sets this up +directly rather than calling `define-error', but you should *not* do this +yourself.]" + (check-argument-type 'symbolp error-sym) + (check-argument-type 'stringp doc-string) + (put error-sym 'error-message doc-string) + (or inherits-from (setq inherits-from 'error)) + (let ((conds (get inherits-from 'error-conditions))) + (or conds (signal-error 'error (list "Not an error symbol" error-sym))) + (put error-sym 'error-conditions (cons error-sym conds)))) + +;;;; Miscellanea. + +(defun buffer-substring-no-properties (beg end) + "Return the text from BEG to END, without text properties, as a string." + (let ((string (buffer-substring beg end))) + (set-text-properties 0 (length string) nil string) + string)) + +;; This should probably be written in C (i.e., without using `walk-windows'). +(defun get-buffer-window-list (buffer &optional minibuf frame) + "Return windows currently displaying BUFFER, or nil if none. +See `walk-windows' for the meaning of MINIBUF and FRAME." + (let ((buffer (if (bufferp buffer) buffer (get-buffer buffer))) windows) + (walk-windows (function (lambda (window) + (if (eq (window-buffer window) buffer) + (setq windows (cons window windows))))) + minibuf frame) + windows)) + +(defun ignore (&rest ignore) + "Do nothing and return nil. +This function accepts any number of arguments, but ignores them." + (interactive) + nil) + +(define-function 'mapc-internal 'mapc) +(make-obsolete 'mapc-internal 'mapc) + +(define-function 'eval-in-buffer 'with-current-buffer) +(make-obsolete 'eval-in-buffer 'with-current-buffer) + +;;; The real defn is in abbrev.el but some early callers +;;; (eg lisp-mode-abbrev-table) want this before abbrev.el is loaded... + +(if (not (fboundp 'define-abbrev-table)) + (progn + (setq abbrev-table-name-list '()) + (fset 'define-abbrev-table (function (lambda (name defs) + ;; These are fixed-up when abbrev.el loads. + (setq abbrev-table-name-list + (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))) + + + +(defun function-interactive (function) + "Returns the interactive specification of FUNCTION. +FUNCTION can be any funcallable object. +The specification will be returned as the list of the symbol `interactive' + and the specs. +If FUNCTION is not interactive, nil will be returned." + (setq function (indirect-function function)) + (cond ((compiled-function-p function) + (compiled-function-interactive function)) + ((subrp function) + (subr-interactive function)) + ((eq (car-safe function) 'lambda) + (let ((spec (if (stringp (nth 2 function)) + (nth 3 function) + (nth 2 function)))) + (and (eq (car-safe spec) 'interactive) + spec))) + (t + (error "Non-funcallable object: %s" function)))) + +;; This was not present before. I think Jamie had some objections +;; to this, so I'm leaving this undefined for now. --ben + +;;; The objection is this: there is more than one way to load the same file. +;;; "foo", "foo.elc", "foo.el", and "/some/path/foo.elc" are all different +;;; ways to load the exact same code. `eval-after-load' is too stupid to +;;; deal with this sort of thing. If this sort of feature is desired, then +;;; it should work off of a hook on `provide'. Features are unique and +;;; the arguments to (load) are not. --Stig + +;; We provide this for FSFmacs compatibility, at least until we devise +;; something better. + +;;;; Specifying things to do after certain files are loaded. + +(defun eval-after-load (file form) + "Arrange that, if FILE is ever loaded, FORM will be run at that time. +This makes or adds to an entry on `after-load-alist'. +If FILE is already loaded, evaluate FORM right now. +It does nothing if FORM is already on the list for FILE. +FILE should be the name of a library, with no directory name." + ;; Make sure there is an element for FILE. + (or (assoc file after-load-alist) + (setq after-load-alist (cons (list file) after-load-alist))) + ;; Add FORM to the element if it isn't there. + (let ((elt (assoc file after-load-alist))) + (or (member form (cdr elt)) + (progn + (nconc elt (list form)) + ;; If the file has been loaded already, run FORM right away. + (and (assoc file load-history) + (eval form))))) + form) +(make-compatible 'eval-after-load "") + +(defun eval-next-after-load (file) + "Read the following input sexp, and run it whenever FILE is loaded. +This makes or adds to an entry on `after-load-alist'. +FILE should be the name of a library, with no directory name." + (eval-after-load file (read))) +(make-compatible 'eval-next-after-load "") + +; alternate names (not obsolete) +(if (not (fboundp 'mod)) (define-function 'mod '%)) +(define-function 'move-marker 'set-marker) +(define-function 'beep 'ding) ; preserve lingual purity +(define-function 'indent-to-column 'indent-to) +(define-function 'backward-delete-char 'delete-backward-char) +(define-function 'search-forward-regexp (symbol-function 're-search-forward)) +(define-function 'search-backward-regexp (symbol-function 're-search-backward)) +(define-function 'remove-directory 'delete-directory) +(define-function 'set-match-data 'store-match-data) +(define-function 'send-string-to-terminal 'external-debugging-output) +(define-function 'buffer-string 'buffer-substring) + +;;; subr.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/syntax.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,418 @@ +;; syntax.el --- Syntax-table hacking stuff, moved from syntax.c + +;; Copyright (C) 1993, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1995 Sun Microsystems. + +;; 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, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: FSF 19.28. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;; Note: FSF does not have a file syntax.el. This stuff is +;; in syntax.c. See comments there about not merging past 19.28. + +;; Significantly hacked upon by Ben Wing. + +;;; Code: + +(defun make-syntax-table (&optional oldtable) + "Return a new syntax table. +It inherits all characters from the standard syntax table." + (make-char-table 'syntax)) + +(defun simple-set-syntax-entry (char spec table) + (put-char-table char spec table)) + +(defun char-syntax-from-code (code) + "Extract the syntax designator from the internal syntax code CODE. +CODE is the value actually contained in the syntax table." + (if (consp code) + (setq code (car code))) + (aref (syntax-designator-chars) (logand code 127))) + +(defun set-char-syntax-in-code (code desig) + "Return a new internal syntax code whose syntax designator is DESIG. +Other characteristics are the same as in CODE." + (let ((newcode (if (consp code) (car code) code))) + (setq newcode (logior (string-match + (regexp-quote (char-to-string desig)) + (syntax-designator-chars)) + (logand newcode (lognot 127)))) + (if (consp code) (cons newcode (cdr code)) + newcode))) + +(defun syntax-code-to-string (code) + "Return a string equivalent to internal syntax code CODE. +The string can be passed to `modify-syntax-entry'. +If CODE is invalid, return nil." + (let ((match (and (consp code) (cdr code))) + (codes (syntax-designator-chars))) + (if (consp code) + (setq code (car code))) + (if (or (not (integerp code)) + (> (logand code 127) (length codes))) + nil + (with-output-to-string + (let* ((spec (elt codes (logand code 127))) + (b3 (lsh code -16)) + (start1 (/= 0 (logand b3 128))) ;logtest! + (start1b (/= 0 (logand b3 64))) + (start2 (/= 0 (logand b3 32))) + (start2b (/= 0 (logand b3 16))) + (end1 (/= 0 (logand b3 8))) + (end1b (/= 0 (logand b3 4))) + (end2 (/= 0 (logand b3 2))) + (end2b (/= 0 (logand b3 1))) + (prefix (/= 0 (logand code 128))) + (single-char-p (or (= spec ?<) (= spec ?>))) + ) + (write-char spec) + (write-char (if match match 32)) +;;; (if start1 (if single-char-p (write-char ?a) (write-char ?1))) + (if start1 (if single-char-p (write-char ? ) (write-char ?1))) + (if start2 (write-char ?2)) +;;; (if end1 (if single-char-p (write-char ?a) (write-char ?3))) + (if end1 (if single-char-p (write-char ? ) (write-char ?3))) + (if end2 (write-char ?4)) + (if start1b (if single-char-p (write-char ?b) (write-char ?5))) + (if start2b (write-char ?6)) + (if end1b (if single-char-p (write-char ?b) (write-char ?7))) + (if end2b (write-char ?8)) + (if prefix (write-char ?p))))))) + +(defun syntax-string-to-code (string) + "Return the internal syntax code equivalent to STRING. +STRING should be something acceptable as the second argument to +`modify-syntax-entry'. +If STRING is invalid, signal an error." + (let* ((bflag nil) + (b3 0) + (ch0 (aref string 0)) + (len (length string)) + (code (string-match (regexp-quote (char-to-string ch0)) + (syntax-designator-chars))) + (i 2) + ch) + (or code + (error "Invalid syntax designator: %S" string)) + (while (< i len) + (setq ch (aref string i)) + (incf i) + (case ch + (?1 (setq b3 (logior b3 128))) + (?2 (setq b3 (logior b3 32))) + (?3 (setq b3 (logior b3 8))) + (?4 (setq b3 (logior b3 2))) + (?5 (setq b3 (logior b3 64))) + (?6 (setq b3 (logior b3 16))) + (?7 (setq b3 (logior b3 4))) + (?8 (setq b3 (logior b3 1))) + (?a (case ch0 + (?< (setq b3 (logior b3 128))) + (?> (setq b3 (logior b3 8))))) + (?b (case ch0 + (?< (setq b3 (logior b3 64) bflag t)) + (?> (setq b3 (logior b3 4) bflag t)))) + (?p (setq code (logior code (lsh 1 7)))) + (?\ nil) ;; ignore for compatibility + (otherwise + (error "Invalid syntax description flag: %S" string)))) + ;; default single char style if `b' has not been seen + (if (not bflag) + (case ch0 + (?< (setq b3 (logior b3 128))) + (?> (setq b3 (logior b3 8))))) + (setq code (logior code (lsh b3 16))) + (if (and (> len 1) + ;; tough luck if you want to make space a paren! + (/= (aref string 1) ?\ )) + (setq code (cons code (aref string 1)))) + code)) + +(defun modify-syntax-entry (char-range spec &optional table) + "Set syntax for the characters CHAR-RANGE according to string SPEC. +CHAR-RANGE is a single character or a range of characters, + as per `put-char-table'. +The syntax is changed only for table TABLE, which defaults to + the current buffer's syntax table. +The first character of SPEC should be one of the following: + Space whitespace syntax. w word constituent. + _ symbol constituent. . punctuation. + \( open-parenthesis. \) close-parenthesis. + \" string quote. \\ character-quote. + $ paired delimiter. ' expression quote or prefix operator. + < comment starter. > comment ender. + / character-quote. @ inherit from `standard-syntax-table'. + +Only single-character comment start and end sequences are represented thus. +Two-character sequences are represented as described below. +The second character of SPEC is the matching parenthesis, + used only if the first character is `(' or `)'. +Any additional characters are flags. +Defined flags are the characters 1, 2, 3, 4, 5, 6, 7, 8, p, a, and b. + 1 means C is the first of a two-char comment start sequence of style a. + 2 means C is the second character of such a sequence. + 3 means C is the first of a two-char comment end sequence of style a. + 4 means C is the second character of such a sequence. + 5 means C is the first of a two-char comment start sequence of style b. + 6 means C is the second character of such a sequence. + 7 means C is the first of a two-char comment end sequence of style b. + 8 means C is the second character of such a sequence. + p means C is a prefix character for `backward-prefix-chars'; + such characters are treated as whitespace when they occur + between expressions. + a means C is comment starter or comment ender for comment style a (default) + 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 + "cSet syntax for character: \nsSet syntax for %c to: ") + (cond ((syntax-table-p table)) + ((not table) + (setq table (syntax-table))) + (t + (setq table + (wrong-type-argument 'syntax-table-p table)))) + (let ((code (syntax-string-to-code spec))) + (simple-set-syntax-entry char-range code table)) + nil) + +(defun map-syntax-table (__function __table &optional __range) + "Map FUNCTION over entries in syntax table TABLE, collapsing inheritance. +This is similar to `map-char-table', but works only on syntax tables, and + collapses any entries that call for inheritance by invisibly substituting + the inherited values from the standard syntax table." + (check-argument-type 'syntax-table-p __table) + (map-char-table #'(lambda (__key __value) + (if (eq ?@ (char-syntax-from-code __value)) + (map-char-table #'(lambda (__key __value) + (funcall __function + __key __value)) + (standard-syntax-table) + __key) + (funcall __function __key __value))) + __table __range)) + +;(defun test-xm () +; (let ((o (copy-syntax-table)) +; (n (copy-syntax-table)) +; (codes (syntax-designator-chars)) +; (flags "12345678abp")) +; (while t +; (let ((spec (concat (char-to-string (elt codes +; (random (length codes)))))) +; (if (= (random 4) 0) +; "b" +; " ") +; (let* ((n (random 4)) +; (s (make-string n 0))) +; (while (> n 0) +; (setq n (1- n)) +; (aset s n (aref flags (random (length flags))))) +; s)))) +; (message "%S..." spec) +; (modify-syntax-entry ?a spec o) +; (xmodify-syntax-entry ?a spec n) +; (or (= (aref o ?a) (aref n ?a)) +; (error "%s" +; (format "fucked with %S: %x %x" +; spec (aref o ?a) (aref n ?a)))))))) + + +(defun describe-syntax-table (table stream) + (let (first-char + last-char + prev-val + (describe-one + (if (featurep 'mule) + #'(lambda (first last value stream) + (if (equal first last) + (cond ((vectorp first) + (princ (format "%s, row %d\t" + (charset-name + (aref first 0)) + (aref first 1)) + stream)) + ((symbolp first) + (princ first stream) + (princ "\t" stream)) + (t + (princ (text-char-description first) stream) + (princ "\t" stream))) + (cond ((vectorp first) + (princ (format "%s, rows %d .. %d\t" + (charset-name + (aref first 0)) + (aref first 1) + (aref last 1)) + stream)) + ((symbolp first) + (princ (format "%s .. %s\t" first last) stream)) + (t + (princ (format "%s .. %s\t" + (text-char-description first) + (text-char-description last)) + stream)))) + (describe-syntax-code value stream)) + #'(lambda (first last value stream) + (let* ((tem (text-char-description first)) + (pos (length tem)) + ;;(limit (cond ((numberp ctl-arrow) ctl-arrow) + ;; ((memq ctl-arrow '(t nil)) 256) + ;; (t 160))) + ) + (princ tem stream) + (if (> last first) + (progn + (princ " .. " stream) + (setq tem (text-char-description last)) + (princ tem stream) + (setq pos (+ pos (length tem) 4)))) + (while (progn (write-char ?\ stream) + (setq pos (1+ pos)) + (< pos 16)))) + (describe-syntax-code value stream))))) + (map-syntax-table + #'(lambda (range value) + (cond + ((not first-char) + (setq first-char range + last-char range + prev-val value)) + ((and (equal value prev-val) + (or + (and (characterp range) + (characterp first-char) + (or (not (featurep 'mule)) + (eq (char-charset range) + (char-charset first-char))) + (= (char-int last-char) (1- (char-int range)))) + (and (vectorp range) + (vectorp first-char) + (eq (aref range 0) (aref first-char 0)) + (= (aref last-char 1) (1- (aref range 1)))))) + (setq last-char range)) + (t + (funcall describe-one first-char last-char prev-val stream) + (setq first-char range + last-char range + prev-val value))) + nil) + table) + (if first-char + (funcall describe-one first-char last-char prev-val stream)))) + +(defun describe-syntax-code (code stream) + (let ((match (and (consp code) (cdr code))) + (invalid (gettext "**invalid**")) ;(empty "") ;constants + (standard-output (or stream standard-output)) + ;; #### I18N3 should temporarily set buffer to output-translatable + (in #'(lambda (string) + (princ ",\n\t\t\t\t ") + (princ string))) + (syntax-string (syntax-code-to-string code))) + (if (consp code) + (setq code (car code))) + (if (null syntax-string) + (princ invalid) + (princ syntax-string) + (princ "\tmeaning: ") + (princ (aref ["whitespace" "punctuation" "word-constituent" + "symbol-constituent" "open-paren" "close-paren" + "expression-prefix" "string-quote" "paired-delimiter" + "escape" "character-quote" "comment-begin" "comment-end" + "inherit" "extended-word-constituent"] + (logand code 127))) + + (if match + (progn + (princ ", matches ") + (princ (text-char-description match)))) + (let* ((spec (elt syntax-string 0)) + (b3 (lsh code -16)) + (start1 (/= 0 (logand b3 128))) ;logtest! + (start1b (/= 0 (logand b3 64))) + (start2 (/= 0 (logand b3 32))) + (start2b (/= 0 (logand b3 16))) + (end1 (/= 0 (logand b3 8))) + (end1b (/= 0 (logand b3 4))) + (end2 (/= 0 (logand b3 2))) + (end2b (/= 0 (logand b3 1))) + (prefix (/= 0 (logand code 128))) + (single-char-p (or (= spec ?<) (= spec ?>)))) + (if start1 + (if single-char-p + (princ ", style A") + (funcall in + (gettext "first character of comment-start sequence A")))) + (if start2 + (funcall in + (gettext "second character of comment-start sequence A"))) + (if end1 + (if single-char-p + (princ ", style A") + (funcall in + (gettext "first character of comment-end sequence A")))) + (if end2 + (funcall in + (gettext "second character of comment-end sequence A"))) + (if start1b + (if single-char-p + (princ ", style B") + (funcall in + (gettext "first character of comment-start sequence B")))) + (if start2b + (funcall in + (gettext "second character of comment-start sequence B"))) + (if end1b + (if single-char-p + (princ ", style B") + (funcall in + (gettext "first character of comment-end sequence B")))) + (if end2b + (funcall in + (gettext "second character of comment-end sequence B"))) + (if prefix + (funcall in + (gettext "prefix character for `backward-prefix-chars'")))) + (terpri stream)))) + +(defun symbol-near-point () + "Return the first textual item to the nearest point." + (interactive) + ;alg stolen from etag.el + (save-excursion + (if (or (bobp) (not (memq (char-syntax (char-before)) '(?w ?_)))) + (while (not (looking-at "\\sw\\|\\s_\\|\\'")) + (forward-char 1))) + (while (looking-at "\\sw\\|\\s_") + (forward-char 1)) + (if (re-search-backward "\\sw\\|\\s_" nil t) + (regexp-quote + (progn (forward-char 1) + (buffer-substring (point) + (progn (forward-sexp -1) + (while (looking-at "\\s'") + (forward-char 1)) + (point))))) + nil))) + +;;; syntax.el ends here
--- a/lisp/term/tty-init.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,98 +0,0 @@ -;;; tty-init.el --- initialization code for tty's -;; Copyright (C) 1994 Free Software Foundation, Inc. -;; Copyright (C) 1996 Ben Wing <wing@666.com>. - -;; Author: various -;; Keywords: terminals - -;; 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. - -;;; Commentary: - -;;; Code: - -(defvar pre-tty-win-initted nil) - -;; called both from init-tty-win and from the C code. -(defun init-pre-tty-win () - "Initialize TTY at startup (pre). Don't call this." - (unless pre-tty-win-initted - (register-tty-color "black" "\e[30m" "\e[40m") - (register-tty-color "red" "\e[31m" "\e[41m") - (register-tty-color "green" "\e[32m" "\e[42m") - (register-tty-color "yellow" "\e[33m" "\e[43m") - (register-tty-color "blue" "\e[34m" "\e[44m") - (register-tty-color "magenta" "\e[35m" "\e[45m") - (register-tty-color "cyan" "\e[36m" "\e[46m") - (register-tty-color "white" "\e[37m" "\e[47m") - - ;; Define `highlighted' tty colors - (register-tty-color "darkgrey" "\e[1;30m" "\e[1;40m") - (register-tty-color "brightred" "\e[1;31m" "\e[1;41m") - (register-tty-color "brightgreen" "\e[1;32m" "\e[1;42m") - (register-tty-color "brightyellow" "\e[1;33m" "\e[1;43m") - (register-tty-color "brightblue" "\e[1;34m" "\e[1;44m") - (register-tty-color "brightmagenta" "\e[1;35m" "\e[1;45m") - (register-tty-color "brightcyan" "\e[1;36m" "\e[1;46m") - (register-tty-color "brightwhite" "\e[1;37m" "\e[1;47m") - - (setq pre-tty-win-initted t))) - -;; called both from init-tty-win and from the C code. -;; we have to do this for every created TTY console. -(defun init-post-tty-win (console) - "Initialize TTY at console creation time (post). Don't call this." - ;; load the appropriate term-type-specific Lisp file. - ;; we don't do this at startup here so that the user can - ;; override term-file-prefix. (startup.el does it after - ;; loading the init file.) - (when init-file-loaded - ;; temporarily select the console so that the changes - ;; to function-key-map are made for the right console. - (let ((foobar (selected-console))) - (unwind-protect - (progn - (select-console console) - (load-terminal-library)) - (select-console foobar))))) - -(defvar tty-win-initted nil) - -(defun init-tty-win () - "Initialize TTY at startup. Don't call this." - (unless tty-win-initted - (init-pre-tty-win) - (make-tty-device nil nil) - (init-post-tty-win (selected-console)) - (setq tty-win-initted t))) - -(defun make-frame-on-tty (tty &optional props) - "Create a frame on the TTY connection named TTY. -TTY should be a TTY device name such as \"/dev/ttyp3\" (as returned by -the `tty' command in that TTY), or nil for the standard input/output -of the running XEmacs process. - -PROPS should be a plist of properties, as in the call to `make-frame'. - -This function opens a connection to the TTY or reuses an existing -connection. - -This function is a trivial wrapper around `make-frame-on-device'." - (interactive "sMake frame on TTY: ") - (if (equal tty "") (setq tty nil)) - (make-frame-on-device 'tty tty props))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/text-mode.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,181 @@ +;;; text-mode.el --- text mode, and its idiosyncratic commands. + +;; Copyright (C) 1985, 1992, 1994, 1997 Free Software Foundation, Inc. + +;; Maintainer: FSF +;; Keywords: wp, dumped + +;; 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.34. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;; This package provides the fundamental text mode documented in the +;; Emacs user's manual. + +;;; Code: + +(defvar text-mode-syntax-table nil + "Syntax table used while in text mode.") + +(defvar text-mode-abbrev-table nil + "Abbrev table used while in text mode.") +(define-abbrev-table 'text-mode-abbrev-table ()) + +(if text-mode-syntax-table + () + (setq text-mode-syntax-table (make-syntax-table)) + (modify-syntax-entry ?\" ". " text-mode-syntax-table) + (modify-syntax-entry ?\\ ". " text-mode-syntax-table) + (modify-syntax-entry ?' "w " text-mode-syntax-table)) + +(defvar text-mode-map nil + "Keymap for Text mode. +Many other modes, such as Mail mode, Outline mode and Indented Text mode, +inherit all the commands defined in this map.") + +(if text-mode-map + () + (setq text-mode-map (make-sparse-keymap)) + ;; XEmacs change + (set-keymap-name text-mode-map 'text-mode-map) + (define-key text-mode-map "\e\t" 'ispell-complete-word) + (define-key text-mode-map "\t" 'tab-to-tab-stop) + (define-key text-mode-map "\es" 'center-line) + (define-key text-mode-map "\eS" 'center-paragraph)) + + +;(defun non-saved-text-mode () +; "Like text-mode, but delete auto save file when file is saved for real." +; (text-mode) +; (make-local-variable 'delete-auto-save-files) +; (setq delete-auto-save-files t)) + +(defun text-mode () + "Major mode for editing text intended for humans to read. +Special commands: +\\{text-mode-map} +Turning on Text mode calls the value of the variable `text-mode-hook', +if that value is non-nil." + (interactive) + (kill-all-local-variables) + (use-local-map text-mode-map) + (setq mode-name "Text") + (setq major-mode 'text-mode) + (setq local-abbrev-table text-mode-abbrev-table) + (set-syntax-table text-mode-syntax-table) + (run-hooks 'text-mode-hook)) + +(defvar indented-text-mode-map () + "Keymap for Indented Text mode. +All the commands defined in Text mode are inherited unless overridden.") + +(if indented-text-mode-map + () + ;; Make different definition for TAB before the one in text-mode-map, but + ;; share the rest. + ;; XEmacs change + (setq indented-text-mode-map (make-sparse-keymap)) + (set-keymap-name indented-text-mode-map 'indented-text-mode-map) + (set-keymap-parents indented-text-mode-map (list text-mode-map)) + (define-key indented-text-mode-map "\t" 'indent-relative)) + +(defun indented-text-mode () + "Major mode for editing text with indented paragraphs. +In this mode, paragraphs are delimited only by blank lines. +You can thus get the benefit of adaptive filling + (see the variable `adaptive-fill-mode'). +\\{indented-text-mode-map} +Turning on `indented-text-mode' calls the value of the variable +`text-mode-hook', if that value is non-nil." + (interactive) + (kill-all-local-variables) + (use-local-map text-mode-map) + (define-abbrev-table 'text-mode-abbrev-table ()) + (setq local-abbrev-table text-mode-abbrev-table) + (set-syntax-table text-mode-syntax-table) + (make-local-variable 'indent-line-function) + (setq indent-line-function 'indent-relative-maybe) + (make-local-variable 'paragraph-start) + (setq paragraph-start (concat "$\\|" page-delimiter)) + (make-local-variable 'paragraph-separate) + (setq paragraph-separate paragraph-start) + (use-local-map indented-text-mode-map) + (setq mode-name "Indented Text") + (setq major-mode 'indented-text-mode) + (run-hooks 'text-mode-hook 'indented-text-mode-hook)) + +(defun center-paragraph () + "Center each nonblank line in the paragraph at or after point. +See `center-line' for more info." + (interactive) + (save-excursion + (forward-paragraph) + (or (bolp) (newline 1)) + (let ((end (point))) + (backward-paragraph) + (center-region (point) end)))) + +(defun center-region (from to) + "Center each nonblank line starting in the region. +See `center-line' for more info." + (interactive "r") + (if (> from to) + (let ((tem to)) + (setq to from from tem))) + (save-excursion + (save-restriction + (narrow-to-region from to) + (goto-char from) + (while (not (eobp)) + (or (save-excursion (skip-chars-forward " \t") (eolp)) + (center-line)) + (forward-line 1))))) + +(defun center-line (&optional nlines) + "Center the line point is on, within the width specified by `fill-column'. +This means adjusting the indentation so that it equals +the distance between the end of the text and `fill-column'. +The argument NLINES says how many lines to center." + (interactive "P") + (if nlines (setq nlines (prefix-numeric-value nlines))) + (while (not (eq nlines 0)) + (save-excursion + (let ((lm (current-left-margin)) + line-length) + (beginning-of-line) + (delete-horizontal-space) + (end-of-line) + (delete-horizontal-space) + (setq line-length (current-column)) + (if (> (- fill-column lm line-length) 0) + (indent-line-to + (+ lm (/ (- fill-column lm line-length) 2)))))) + (cond ((null nlines) + (setq nlines 0)) + ((> nlines 0) + (setq nlines (1- nlines)) + (forward-line 1)) + ((< nlines 0) + (setq nlines (1+ nlines)) + (forward-line -1))))) + +;;; text-mode.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/text-props.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,401 @@ +;;; text-props.el --- implements properties of characters + +;; Copyright (C) 1993-4, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1995 Amdahl Corporation. +;; Copyright (C) 1995 Ben Wing. + +;; Author: Jamie Zawinski <jwz@netscape.com> +;; Maintainer: XEmacs Development Team +;; Keywords: extensions, wp, faces, dumped + +;; 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: + +;; This file is dumped with XEmacs. + +;; This is a nearly complete implementation of the FSF19 text properties API. +;; Please let me know if you notice any differences in behavior between +;; this implementation and the FSF implementation. + +;; However, keep in mind that this interface has been implemented because it +;; is useful. Compatibility with code written for FSF19 is a secondary goal +;; to having a clean and useful interface. + +;; The cruftier parts of the FSF API, such as the special handling of +;; properties like `mouse-face', `front-sticky', and other properties whose +;; value is a list of names of *other* properties set at this position, are +;; not implemented. The reason for this is that if you feel you need that +;; kind of functionality, it's a good hint that you should be using extents +;; instead of text properties. + +;; When should I use Text Properties, and when should I use Extents? +;; ================================================================== + +;; If you are putting a `button' or `hyperlink' of some kind into a buffer, +;; the most natural interface is one which deals with properties of regions +;; with explicit endpoints that behave more-or-less like markers. That is +;; what `make-extent', `extent-at', and `extent-property' are for. + +;; If you are dealing with styles of text, where things do not have explicit +;; endpoints (as is done in font-lock.el and shell-font.el) or if you want to +;; partition a buffer (that is, change some attribute of a range from one +;; value to another without disturbing the properties outside of that range) +;; then an interface that deals with properties of characters may be most +;; natural. + +;; Another way of thinking of it is, do you care where the endpoints of the +;; region are? If you do, then you should use extents. If it's ok for the +;; region to become divided, and for two regions with identical properties to +;; be merged into one region, then you might want to use text properties. + +;; Some applications want the attributes they add to be copied by the killing +;; and yanking commands, and some do not. This is orthogonal to whether text +;; properties or extents are used. Remember that text properties are +;; implemented in terms of extents, so anything you can do with one you can +;; do with the other. It's just a matter of which way of creating and +;; managing them is most appropriate to your application. + +;; Implementation details: +;; ======================= + +;; This package uses extents with a non-nil 'text-prop property. It assumes +;; free reign over the endpoints of any extent with that property. It will +;; not alter any extent which does not have that property. + +;; Right now, the text-property functions create one extent for each distinct +;; property; that is, if a range of text has two text-properties on it, there +;; will be two extents. As the set of text-properties is going to be small, +;; this is probably not a big deal. It would be possible to share extents. + +;; One tricky bit is that undo/kill/yank must be made to not fragment things: +;; these extents must not be allowed to overlap. We accomplish this by using +;; a custom `paste-function' property on the extents. + +;; shell-font.el and font-lock.el could put-text-property to attach fonts to +;; the buffer. However, what these packages are interested in is the +;; efficient extent partitioning behavior which this code exhibits, not the +;; duplicability aspect of it. In fact, either of these packages could be +;; implemented by creating a one-character non-expandable extent for each +;; character in the buffer, except that that would be extremely wasteful of +;; memory. (Redisplay performance would be fine, however.) + +;; If these packages were to use put-text-property to make the extents, then +;; when one copied text from a shell buffer or a font-locked source buffer +;; and pasted it somewhere else (a sendmail buffer, or a buffer not in +;; font-lock mode) then the fonts would follow, and there's no easy way to +;; get rid of them (other than pounding out a call to put-text-property by +;; hand.) This is annoying. Maybe it wouldn't be so annoying if there was a +;; more general set of commands for handling styles of text (in fact, if +;; there were such a thing, copying the fonts would probably be exactly what +;; one wanted) but we aren't there yet. So these packages use the interface +;; of `put-nonduplicable-text-property' which is the same, except that it +;; doesn't make duplicable extents. + +;; `put-text-property' and `put-nonduplicable-text-property' don't get along: +;; they will interfere with each other, reusing each others' extents without +;; checking that the "duplicableness" is correct. This is a bug, but it's +;; one that I don't care enough to fix this right now. + +;;; Code: + +(defun set-text-properties (start end props &optional buffer-or-string) + "You should NEVER use this function. It is ideologically blasphemous. +It is provided only to ease porting of broken FSF Emacs programs. +Instead, use `remove-text-properties' to remove the specific properties +you do not want. + +Completely replace properties of text from START to END. +The third argument PROPS is the new property list. +The optional fourth argument, BUFFER-OR-STRING, +is the string or buffer containing the text." + (map-extents #'(lambda (extent ignored) + ;; #### dmoore - shouldn't this use + ;; (extent-start-position extent) + ;; (extent-end-position extent) + (remove-text-properties start end + (list (extent-property extent + 'text-prop) + nil) + buffer-or-string) + nil) + buffer-or-string start end nil nil 'text-prop) + (add-text-properties start end props buffer-or-string)) + + +;;; The following functions can probably stay in lisp, since they're so simple. + +;(defun get-text-property (pos prop &optional buffer) +; "Returns the value of the PROP property at the given position." +; (let ((e (extent-at pos buffer prop))) +; (if e +; (extent-property e prop) +; nil))) + +(defun extent-properties-at-1 (position buffer-or-string text-props-only) + (let ((extent nil) + (props nil) + new-props) + (while (setq extent (extent-at position buffer-or-string + (if text-props-only 'text-prop nil) + extent)) + (if text-props-only + ;; Only return the one prop which the `text-prop' property points at. + (let ((prop (extent-property extent 'text-prop))) + (setq new-props (list prop (extent-property extent prop)))) + ;; Return all the properties... + (setq new-props (extent-properties extent)) + ;; ...but! Don't return the `begin-glyph' or `end-glyph' properties + ;; unless the position is exactly at the appropriate endpoint. Yeah, + ;; this is kind of a kludge. + ;; #### Bug, this doesn't work for end-glyphs (on end-open extents) + ;; because we've already passed the extent with the glyph by the time + ;; it's appropriate to return the glyph. We could return the end + ;; glyph one character early I guess... But then next-property-change + ;; would have to stop one character early as well. It could back up + ;; when it hit an end-glyph... + ;; #### Another bug, if there are multiple glyphs at the same position, + ;; we only see the first one. + (cond ((or (extent-begin-glyph extent) (extent-end-glyph extent)) + (if (/= position (if (extent-property extent 'begin-glyph) + (extent-start-position extent) + (extent-end-position extent))) + (let ((rest new-props) + prev) + (while rest + (cond ((or (eq (car rest) 'begin-glyph) + (eq (car rest) 'end-glyph)) + (if prev + (setcdr prev (cdr (cdr rest))) + (setq new-props (cdr (cdr new-props)))) + (setq rest nil))) + (setq prev rest + rest (cdr rest)))))))) + (cond ((null props) + (setq props new-props)) + (t + (while new-props + (or (getf props (car new-props)) + (setq props (cons (car new-props) + (cons (car (cdr new-props)) + props)))) + (setq new-props (cdr (cdr new-props))))))) + props)) + +(defun extent-properties-at (position &optional object) + "Returns the properties of the character at the given position +in OBJECT (a string or buffer) by merging the properties of overlapping +extents. The returned value is a property list, some of which may be +shared with other structures. You must not modify it. + +If POSITION is at the end of OBJECT, the value is nil. + +This returns all properties on all extents. +See also `text-properties-at'." + (extent-properties-at-1 position object nil)) + +(defun text-properties-at (position &optional object) + "Returns the properties of the character at the given position +in OBJECT (a string or buffer) by merging the properties of overlapping +extents. The returned value is a property list, some of which may be +shared with other structures. You must not modify it. + +If POSITION is at the end of OBJECT, the value is nil. + +This returns only those properties added with `put-text-property'. +See also `extent-properties-at'." + (extent-properties-at-1 position object t)) + +(defun text-property-any (start end prop value &optional buffer-or-string) + "Check text from START to END to see if PROP is ever `eq' to VALUE. +If so, return the position of the first character whose PROP is `eq' +to VALUE. Otherwise return nil. +The optional fifth argument, BUFFER-OR-STRING, is the buffer or string +containing the text and defaults to the current buffer." + (while (and start (< start end) + (not (eq value (get-text-property start prop buffer-or-string)))) + (setq start (next-single-property-change start prop buffer-or-string end))) + ;; we have to insert a special check for end due to the illogical + ;; definition of next-single-property-change (blame FSF for this). + (if (eq start end) nil start)) + +(defun text-property-not-all (start end prop value &optional buffer-or-string) + "Check text from START to END to see if PROP is ever not `eq' to VALUE. +If so, return the position of the first character whose PROP is not +`eq' to VALUE. Otherwise, return nil. +The optional fifth argument, BUFFER-OR-STRING, is the buffer or string +containing the text and defaults to the current buffer." + (if (not (eq value (get-text-property start prop buffer-or-string))) + start + (let ((retval (next-single-property-change start prop + buffer-or-string end))) + ;; we have to insert a special check for end due to the illogical + ;; definition of previous-single-property-change (blame FSF for this). + (if (eq retval end) nil retval)))) + +;; Older versions that only work sometimes (when VALUE is non-nil +;; for text-property-any, and maybe only when VALUE is nil for +;; text-property-not-all). They might be faster in those cases, +;; but that's not obvious. + +;(defun text-property-any (start end prop value &optional buffer) +; "Check text from START to END to see if PROP is ever `eq' to VALUE. +;If so, return the position of the first character whose PROP is `eq' +;to VALUE. Otherwise return nil." +; ;; #### what should (text-property-any x y 'foo nil) return when there +; ;; is no foo property between x and y? Either t or nil seems sensible, +; ;; since a character with a property of nil is indistinguishable from +; ;; a character without that property set. +; (map-extents +; #'(lambda (e ignore) +; (if (eq value (extent-property e prop)) +; ;; return non-nil to stop mapping +; (max start (extent-start-position e)) +; nil)) +; nil start end buffer)) +; +;(defun text-property-not-all (start end prop value &optional buffer) +; "Check text from START to END to see if PROP is ever not `eq' to VALUE. +;If so, return the position of the first character whose PROP is not +;`eq' to VALUE. Otherwise, return nil." +; (let (maxend) +; (map-extents +; #'(lambda (e ignore) +; ;;### no, actually, this is harder. We need to collect all props +; ;; for a given character, and then determine whether no extent +; ;; contributes the given value. Doing this without consing lots +; ;; of lists is the tricky part. +; (if (eq value (extent-property e prop)) +; (progn +; (setq maxend (extent-end-position e)) +; nil) +; (max start maxend))) +; nil start end buffer))) + +(defun next-property-change (pos &optional buffer-or-string limit) + "Return the position of next property change. +Scans forward from POS in BUFFER-OR-STRING (defaults to the current buffer) + until it finds a change in some text property, then returns the position of + the change. +Returns nil if the properties remain unchanged all the way to the end. +If the value is non-nil, it is a position greater than POS, never equal. +If the optional third argument LIMIT is non-nil, don't search + past position LIMIT; return LIMIT if nothing is found before LIMIT. +If two or more extents with conflicting non-nil values for a property overlap + a particular character, it is undefined which value is considered to be + the value of the property. (Note that this situation will not happen if + you always use the text-property primitives.)" + (let ((limit-was-nil (null limit))) + (or limit (setq limit (if (bufferp buffer-or-string) + (point-max buffer-or-string) + (length buffer-or-string)))) + (let ((value (extent-properties-at pos buffer-or-string))) + (while + (and (< (setq pos (next-extent-change pos buffer-or-string)) limit) + (plists-eq value (extent-properties-at pos buffer-or-string))))) + (if (< pos limit) pos + (if limit-was-nil nil + limit)))) + +(defun previous-property-change (pos &optional buffer-or-string limit) + "Return the position of previous property change. +Scans backward from POS in BUFFER-OR-STRING (defaults to the current buffer) + until it finds a change in some text property, then returns the position of + the change. +Returns nil if the properties remain unchanged all the way to the beginning. +If the value is non-nil, it is a position less than POS, never equal. +If the optional third argument LIMIT is non-nil, don't search back + past position LIMIT; return LIMIT if nothing is found until LIMIT. +If two or more extents with conflicting non-nil values for a property overlap + a particular character, it is undefined which value is considered to be + the value of the property. (Note that this situation will not happen if + you always use the text-property primitives.)" + (let ((limit-was-nil (null limit))) + (or limit (setq limit (if (bufferp buffer-or-string) + (point-min buffer-or-string) + 0))) + (let ((value (extent-properties-at (1- pos) buffer-or-string))) + (while + (and (> (setq pos (previous-extent-change pos buffer-or-string)) + limit) + (plists-eq value (extent-properties-at (1- pos) + buffer-or-string))))) + (if (> pos limit) pos + (if limit-was-nil nil + limit)))) + +(defun text-property-bounds (pos prop &optional object at-flag) + "Return the bounds of property PROP at POS. +This returns a cons (START . END) of the largest region of text containing +POS which has a non-nil value for PROP. The return value is nil if POS +does not have a non-nil value for PROP. OBJECT specifies the buffer +or string to search in. Optional arg AT-FLAG controls what \"at POS\" +means, and has the same meaning as for `extent-at'." + (or object (setq object (current-buffer))) + (and (get-char-property pos prop object at-flag) + (let ((begin (if (stringp object) 0 (point-min object))) + (end (if (stringp object) (length object) (point-max object)))) + (cons (previous-single-property-change (1+ pos) prop object begin) + (next-single-property-change pos prop object end))))) + +(defun next-text-property-bounds (count pos prop &optional object) + "Return the COUNTth bounded property region of property PROP after POS. +If COUNT is less than zero, search backwards. This returns a cons +\(START . END) of the COUNTth maximal region of text that begins after POS +\(starts before POS) and has a non-nil value for PROP. If there aren't +that many regions, nil is returned. OBJECT specifies the buffer or +string to search in." + (or object (setq object (current-buffer))) + (let ((begin (if (stringp object) 0 (point-min object))) + (end (if (stringp object) (length object) (point-max object)))) + (catch 'hit-end + (if (> count 0) + (progn + (while (> count 0) + (if (>= pos end) + (throw 'hit-end nil) + (and (get-char-property pos prop object) + (setq pos (next-single-property-change pos prop + object end))) + (setq pos (next-single-property-change pos prop object end))) + (setq count (1- count))) + (and (< pos end) + (cons pos (next-single-property-change pos prop object end)))) + (while (< count 0) + (if (<= pos begin) + (throw 'hit-end nil) + (and (get-char-property (1- pos) prop object) + (setq pos (previous-single-property-change pos prop + object begin))) + (setq pos (previous-single-property-change pos prop object + begin))) + (setq count (1+ count))) + (and (> pos begin) + (cons (previous-single-property-change pos prop object begin) + pos)))))) + +;(defun detach-all-extents (&optional buffer) +; (map-extents #'(lambda (x i) (detach-extent x) nil) +; buffer)) + + +(provide 'text-props) + +;;; text-props.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/toolbar.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,165 @@ +;;; toolbar.el --- Toolbar support for XEmacs + +;; Copyright (C) 1995, 1997 Free Software Foundation, Inc. + +;; Maintainer: XEmacs Development Team +;; Keywords: extensions, internal, dumped + +;; 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, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: Not in FSF. + +;;; Commentary: + +;; This file is dumped with XEmacs (when toolbar support is compiled in). + +;;; Code: + +(defvar toolbar-help-enabled t + "If non-nil help is echoed for toolbar buttons.") + +(defvar toolbar-icon-directory nil + "Location of standard toolbar icon bitmaps.") + +(defun toolbar-make-button-list (up &optional down disabled cap-up cap-down cap-disabled) + "Calls make-glyph on each arg and returns a list of the results." + (if (featurep 'x) + (let ((up-glyph (make-glyph up)) + (down-glyph (and down (make-glyph down))) + (disabled-glyph (and disabled (make-glyph disabled))) + (cap-up-glyph (and cap-up (make-glyph cap-up))) + (cap-down-glyph (and cap-down (make-glyph cap-down))) + (cap-disabled-glyph (and cap-disabled (make-glyph cap-disabled)))) + (if cap-disabled + (list up-glyph down-glyph disabled-glyph + cap-up-glyph cap-down-glyph cap-disabled-glyph) + (if cap-down + (list up-glyph down-glyph disabled-glyph + cap-up-glyph cap-down-glyph) + (if cap-up + (list up-glyph down-glyph disabled-glyph cap-up-glyph) + (if disabled-glyph + (list up-glyph down-glyph disabled-glyph) + (if down-glyph + (list up-glyph down-glyph) + (list up-glyph))))))) + nil)) + +(defun init-toolbar-location () + (if (not toolbar-icon-directory) + (setq toolbar-icon-directory + (file-name-as-directory + (locate-data-directory "toolbar"))))) + +(defun init-toolbar-from-resources (locale) + (if (and (featurep 'x) + (or (eq locale 'global) + (eq 'x (device-or-frame-type locale))) + (x-init-toolbar-from-resources locale)))) + + +;; #### Is this actually needed or will the code in +;; default-mouse-motion-handler suffice? +(define-key global-map 'button1up 'release-toolbar-button) + +(defvar toolbar-map (let ((m (make-sparse-keymap))) + (set-keymap-name m 'toolbar-map) + m) + "Keymap consulted for mouse-clicks over a toolbar.") + +(define-key toolbar-map 'button1 'press-toolbar-button) +(define-key toolbar-map 'button1up 'release-and-activate-toolbar-button) +(defvar last-pressed-toolbar-button nil) +(defvar toolbar-active nil) + +;; +;; It really sucks that we also have to tie onto +;; default-mouse-motion-handler to make sliding buttons work right. +;; +(defun press-toolbar-button (event) + "Press a toolbar button. This only changes its appearance. +Call function stored in `toolbar-blank-press-function,' if any, with EVENT as +an argument if press is over a blank area of the toolbar." + (interactive "_e") + (setq this-command last-command) + (let ((button (event-toolbar-button event))) + ;; We silently ignore non-buttons. This most likely means we are + ;; over a blank part of the toolbar. + (setq toolbar-active t) + (if (toolbar-button-p button) + (progn + (set-toolbar-button-down-flag button t) + (setq last-pressed-toolbar-button button)) + ;; Added by Bob Weiner, Motorola Inc., 10/6/95, to handle + ;; presses on blank portions of toolbars. + (and (boundp 'toolbar-blank-press-function) + (functionp toolbar-blank-press-function) + (funcall toolbar-blank-press-function event))))) + +(defun release-and-activate-toolbar-button (event) + "Release a toolbar button and activate its callback. +Call function stored in `toolbar-blank-release-function,' if any, with EVENT +as an argument if release is over a blank area of the toolbar." + (interactive "_e") + (or (button-release-event-p event) + (error "%s must be invoked by a mouse-release" this-command)) + (release-toolbar-button event) + (let ((button (event-toolbar-button event))) + (if (and (toolbar-button-p button) + (toolbar-button-enabled-p button) + (toolbar-button-callback button)) + (let ((callback (toolbar-button-callback button))) + (setq this-command callback) + ;; Handle arbitrary functions. + (if (functionp callback) + (if (commandp callback) + (call-interactively callback) + (funcall callback)) + (eval callback)))))) + +;; If current is not t, then only release the toolbar button stored in +;; last-pressed-toolbar-button +(defun release-toolbar-button-internal (event current) + (let ((button (event-toolbar-button event))) + (setq zmacs-region-stays t) + (if (and last-pressed-toolbar-button + (not (eq last-pressed-toolbar-button button)) + (toolbar-button-p last-pressed-toolbar-button)) + (progn + (set-toolbar-button-down-flag last-pressed-toolbar-button nil) + (setq last-pressed-toolbar-button nil))) + (if (and current (toolbar-button-p button)) + (set-toolbar-button-down-flag button nil)))) + +(defun release-toolbar-button (event) + "Release all pressed toolbar buttons." + (interactive "_e") + (or (button-release-event-p event) + (error "%s must be invoked by a mouse-release" this-command)) + (release-toolbar-button-internal event t) + ;; Don't set this-command if we're being called + ;; from release-and-activate-toolbar-button. + (if (interactive-p) + (setq this-command last-command)) + (setq toolbar-active nil)) + +(defun release-previous-toolbar-button (event) + (setq zmacs-region-stays t) + (release-toolbar-button-internal event nil)) + +;;; toolbar.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tty-init.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,105 @@ +;;; tty-init.el --- initialization code for tty's + +;; Copyright (C) 1994, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1996 Ben Wing <wing@666.com>. + +;; Maintainer: XEmacs Development Team +;; Keywords: terminals, dumped + +;; 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 synched. + +;;; Commentary: + +;; This file is dumped with XEmacs (when TTY support is compiled in). + +;;; Code: + +(defvar pre-tty-win-initted nil) + +;; called both from init-tty-win and from the C code. +(defun init-pre-tty-win () + "Initialize TTY at startup (pre). Don't call this." + (unless pre-tty-win-initted + (register-tty-color "black" "\e[30m" "\e[40m") + (register-tty-color "red" "\e[31m" "\e[41m") + (register-tty-color "green" "\e[32m" "\e[42m") + (register-tty-color "yellow" "\e[33m" "\e[43m") + (register-tty-color "blue" "\e[34m" "\e[44m") + (register-tty-color "magenta" "\e[35m" "\e[45m") + (register-tty-color "cyan" "\e[36m" "\e[46m") + (register-tty-color "white" "\e[37m" "\e[47m") + + ;; Define `highlighted' tty colors + (register-tty-color "darkgrey" "\e[1;30m" "\e[1;40m") + (register-tty-color "brightred" "\e[1;31m" "\e[1;41m") + (register-tty-color "brightgreen" "\e[1;32m" "\e[1;42m") + (register-tty-color "brightyellow" "\e[1;33m" "\e[1;43m") + (register-tty-color "brightblue" "\e[1;34m" "\e[1;44m") + (register-tty-color "brightmagenta" "\e[1;35m" "\e[1;45m") + (register-tty-color "brightcyan" "\e[1;36m" "\e[1;46m") + (register-tty-color "brightwhite" "\e[1;37m" "\e[1;47m") + + (setq pre-tty-win-initted t))) + +;; called both from init-tty-win and from the C code. +;; we have to do this for every created TTY console. +(defun init-post-tty-win (console) + "Initialize TTY at console creation time (post). Don't call this." + ;; load the appropriate term-type-specific Lisp file. + ;; we don't do this at startup here so that the user can + ;; override term-file-prefix. (startup.el does it after + ;; loading the init file.) + (when init-file-loaded + ;; temporarily select the console so that the changes + ;; to function-key-map are made for the right console. + (let ((foobar (selected-console))) + (unwind-protect + (progn + (select-console console) + (load-terminal-library)) + (select-console foobar))))) + +(defvar tty-win-initted nil) + +(defun init-tty-win () + "Initialize TTY at startup. Don't call this." + (unless tty-win-initted + (init-pre-tty-win) + (make-tty-device nil nil) + (init-post-tty-win (selected-console)) + (setq tty-win-initted t))) + +(defun make-frame-on-tty (tty &optional props) + "Create a frame on the TTY connection named TTY. +TTY should be a TTY device name such as \"/dev/ttyp3\" (as returned by +the `tty' command in that TTY), or nil for the standard input/output +of the running XEmacs process. + +PROPS should be a plist of properties, as in the call to `make-frame'. + +This function opens a connection to the TTY or reuses an existing +connection. + +This function is a trivial wrapper around `make-frame-on-device'." + (interactive "sMake frame on TTY: ") + (if (equal tty "") (setq tty nil)) + (make-frame-on-device 'tty tty props)) + +;;; tty-init.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/undo-stack.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,270 @@ +;;; undo-stack.el --- An "undoable stack" object. + +;; Copyright (C) 1997 Free Software Foundation, Inc. +;; Copyright (C) 1996 Ben Wing. + +;; Maintainer: XEmacs Development Team +;; Keywords: extensions, dumped + +;; 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, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: Not in FSF. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;; An "undoable stack" is an object that can be used to implement +;; a history of positions, with undo and redo. Conceptually, it +;; is the kind of data structure used to keep track of (e.g.) +;; visited Web pages, so that the "Back" and "Forward" operations +;; in the browser work. Basically, I can successively visit a +;; number of Web pages through links, and then hit "Back" a +;; few times to go to previous positions, and then "Forward" a +;; few times to reverse this process. This is similar to an +;; "undo" and "redo" mechanism. + +;; Note that Emacs does not standardly contain structures like +;; this. Instead, it implements history using either a ring +;; (the kill ring, the mark ring), or something like the undo +;; stack, where successive "undo" operations get recorded as +;; normal modifications, so that if you do a bunch of successive +;; undo's, then something else, then start undoing, you will +;; be redoing all your undo's back to the point before you did +;; the undo's, and then further undo's will act like the previous +;; round of undo's. I think that both of these paradigms are +;; inferior to the "undoable-stack" paradigm because they're +;; confusing and difficult to keep track of. + +;; Conceptually, imagine a position history like this: + +;; 1 -> 2 -> 3 -> 4 -> 5 -> 6 +;; ^^ + +;; where the arrow indicates where you currently are. "Going back" +;; and "going forward" just amount to moving the arrow. However, +;; what happens if the history state is this: + +;; 1 -> 2 -> 3 -> 4 -> 5 -> 6 +;; ^^ + +;; and then I visit new positions (7) and (8)? In the most general +;; implementation, you've just caused a new branch like this: + +;; 1 -> 2 -> 3 -> 4 -> 5 -> 6 +;; | +;; | +;; 7 -> 8 +;; ^^ + +;; But then you can end up with a whole big tree, and you need +;; more sophisticated ways of navigating ("Forward" might involve +;; a choice of paths to follow) and managing its size (if you don't +;; want to keep unlimited history, you have to truncate at some point, +;; and how do you truncate a tree?) + +;; My solution to this is just to insert the new positions like +;; this: + +;; 1 -> 2 -> 3 -> 4 -> 7 -> 8 -> 5 -> 6 +;; ^^ + +;; (Netscape, I think, would just truncate 5 and 6 completely, +;; but that seems a bit drastic. In the Emacs-standard "ring" +;; structure, this problem is avoided by simply moving 5 and 6 +;; to the beginning of the ring. However, it doesn't seem +;; logical to me to have "going back past 1" get you to 6.) + +;; Now what if we have a "maximum" size of (say) 7 elements? +;; When we add 8, we could truncate either 1 or 6. Since 5 and +;; 6 are "undone" positions, we should presumably truncate +;; them before 1. So, adding 8 truncates 6, adding 9 truncates +;; 5, and adding 10 truncates 1 because there is nothing more +;; that is forward of the insertion point. + +;; Interestingly, this method of truncation is almost like +;; how a ring would truncate. A ring would move 5 and 6 +;; around to the back, like this: + +;; 5 -> 6 -> 1 -> 2 -> 3 -> 4 -> 7 -> 8 +;; ^^ + +;; However, when 8 is added, the ring truncates 5 instead of +;; 6, which is less than optimal. + +;; Conceptually, we can implement the "undoable stack" using +;; two stacks of a sort called "truncatable stack", which are +;; just simple stacks, but where you can truncate elements +;; off of the bottom of the stack. Then, the undoable stack + +;; 1 -> 2 -> 3 -> 4 -> 5 -> 6 +;; ^^ + +;; is equivalent to two truncatable stacks: + +;; 4 <- 3 <- 2 <- 1 +;; 5 <- 6 + +;; where I reversed the direction to accord with the probable +;; implementation of a standard list. To do another undo, +;; I pop 4 off of the first stack and move it to the top of +;; the second stack. A redo operation does the opposite. +;; To truncate to the proper size, first chop off 6, then 5, +;; then 1 -- in all cases, truncating off the bottom. + +;;; Code: + +(define-error 'trunc-stack-bottom "Bottom of stack reached.") + +(defsubst trunc-stack-stack (stack) + ;; return the list representing the trunc-stack's elements. + ;; the head of the list is the most recent element. + (aref stack 1)) + +(defsubst trunc-stack-length (stack) + ;; return the number of elements in the trunc-stack. + (aref stack 2)) + +(defsubst set-trunc-stack-stack (stack new) + ;; set the list representing the trunc-stack's elements. + (aset stack 1 new)) + +(defsubst set-trunc-stack-length (stack new) + ;; set the length of the trunc-stack. + (aset stack 2 new)) + +;; public functions: + +(defun make-trunc-stack () + ;; make an empty trunc-stack. + (vector 'trunc-stack nil 0)) + +(defun trunc-stack-push (stack el) + ;; push a new element onto the head of the trunc-stack. + (set-trunc-stack-stack stack (cons el (trunc-stack-stack stack))) + (set-trunc-stack-length stack (1+ (trunc-stack-length stack)))) + +(defun trunc-stack-top (stack &optional n) + ;; return the nth topmost element from the trunc-stack. + ;; signal an error if the stack doesn't have that many elements. + (or n (setq n 0)) + (if (>= n (trunc-stack-length stack)) + (signal-error 'trunc-stack-bottom (list stack)) + (nth n (trunc-stack-stack stack)))) + +(defun trunc-stack-pop (stack) + ;; pop and return the topmost element from the stack. + (prog1 (trunc-stack-top stack) + (set-trunc-stack-stack stack (cdr (trunc-stack-stack stack))) + (set-trunc-stack-length stack (1- (trunc-stack-length stack))))) + +(defun trunc-stack-truncate (stack &optional n) + ;; truncate N items off the bottom of the stack. If the stack is + ;; not that big, it just becomes empty. + (or n (setq n 1)) + (if (> n 0) + (let ((len (trunc-stack-length stack))) + (if (>= n len) + (progn + (set-trunc-stack-length stack 0) + (set-trunc-stack-stack stack nil)) + (setcdr (nthcdr (1- (- len n)) (trunc-stack-stack stack)) nil) + (set-trunc-stack-length stack (- len n)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; FMH! FMH! FMH! This object-oriented stuff doesn't really work +;;; properly without built-in structures (vectors suck) and without +;;; public and private functions and fields. Bogons descend on +;;; RMS for not believing in any of this. + +(defsubst undoable-stack-max (stack) + (aref stack 1)) + +(defsubst undoable-stack-a (stack) + (aref stack 2)) + +(defsubst undoable-stack-b (stack) + (aref stack 3)) + +;; public functions: + +(defun make-undoable-stack (max) + ;; make an empty undoable stack of max size MAX. + (vector 'undoable-stack max (make-trunc-stack) (make-trunc-stack))) + +(defsubst set-undoable-stack-max (stack new) + ;; change the max size of an undoable stack. + (aset stack 1 new)) + +(defun undoable-stack-a-top (stack) + ;; return the topmost element off the "A" stack of an undoable stack. + ;; this is the most recent position pushed on the undoable stack. + (trunc-stack-top (undoable-stack-a stack))) + +(defun undoable-stack-a-length (stack) + (trunc-stack-length (undoable-stack-a stack))) + +(defun undoable-stack-b-top (stack) + ;; return the topmost element off the "B" stack of an undoable stack. + ;; this is the position that will become the most recent position, + ;; after a redo operation. + (trunc-stack-top (undoable-stack-b stack))) + +(defun undoable-stack-b-length (stack) + (trunc-stack-length (undoable-stack-b stack))) + +(defun undoable-stack-push (stack el) + ;; push an element onto the stack. + (let* + ((lena (trunc-stack-length (undoable-stack-a stack))) + (lenb (trunc-stack-length (undoable-stack-b stack))) + (max (undoable-stack-max stack)) + (len (+ lena lenb))) + ;; maybe truncate some elements. We have to deal with the + ;; possibility that we have more elements than our max + ;; (someone might have reduced the max). + (if (>= len max) + (let ((must-nuke (1+ (- len max)))) + ;; chop off must-nuke elements from the B stack. + (trunc-stack-truncate (undoable-stack-b stack) must-nuke) + ;; but if there weren't that many elements to chop, + ;; take the rest off the A stack. + (if (< lenb must-nuke) + (trunc-stack-truncate (undoable-stack-a stack) + (- must-nuke lenb))))) + (trunc-stack-push (undoable-stack-a stack) el))) + +(defun undoable-stack-pop (stack) + ;; pop an element off the stack. + (trunc-stack-pop (undoable-stack-a stack))) + +(defun undoable-stack-undo (stack) + ;; transfer an element from the top of A to the top of B. + ;; return value is undefined. + (trunc-stack-push (undoable-stack-b stack) + (trunc-stack-pop (undoable-stack-a stack)))) + +(defun undoable-stack-redo (stack) + ;; transfer an element from the top of B to the top of A. + ;; return value is undefined. + (trunc-stack-push (undoable-stack-a stack) + (trunc-stack-pop (undoable-stack-b stack)))) + + +;;; undo-stack.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/update-elc.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,142 @@ +;;; update-elc.el --- Bytecompile out-of-date dumped files + +;; Copyright (C) 1997 Free Software Foundation, Inc. +;; Copyright (C) 1996 Unknown + +;; Maintainer: XEmacs Development Team +;; Keywords: internal + +;; 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, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: Not in FSF. + +;;; Commentary: + +;; Byte compile the .EL files necessary to dump out xemacs. +;; Use this file like this: +;; +;; temacs -batch -l ../lisp/update-elc.el $lisp +;; +;; where $lisp comes from the Makefile. .elc files listed in $lisp will +;; cause the corresponding .el file to be compiled. .el files listed in +;; $lisp will be ignored. +;; +;; (the idea here is that you can bootstrap if your .ELC files +;; are missing or badly out-of-date) + +;; Currently this code gets the list of files to check passed to it from +;; src/Makefile. This must be fixed. -slb + +;;; Code: + +(defvar processed nil) +(defvar update-elc-files-to-compile nil) + +;(setq update-elc-files-to-compile +; (delq nil +; (mapcar (function +; (lambda (x) +; (if (string-match "\.elc$" x) +; (let ((src (substring x 0 -1))) +; (if (file-newer-than-file-p src x) +; (progn +; (and (file-exists-p x) +; (null (file-writable-p x)) +; (set-file-modes x (logior (file-modes x) 128))) +; src)))))) +; ;; -batch gets filtered out. +; (nthcdr 3 command-line-args)))) + +(define-function 'defalias 'define-function) +(require 'packages) + +(let ((autol (list-autoloads))) + ;; (print (prin1-to-string autol)) + (while autol + (let ((src (car autol))) + (if (and (file-exists-p src) + (file-newer-than-file-p src (concat src "c"))) + (setq update-elc-files-to-compile + (cons src update-elc-files-to-compile)))) + (setq autol (cdr autol)))) + +;; We must have some lisp support at this point +(let ((temp-path (expand-file-name "." (car load-path)))) + (setq load-path (nconc (directory-files temp-path t "^[^-.]" + nil 'dirs-only) + (cons temp-path load-path)))) + +;(load "backquote") +;(load "bytecomp-runtime") +;(load "subr") +;(load "replace") +;(load "version.el") +;(load "cl") +;(load "featurep") + +;; (print (prin1-to-string update-elc-files-to-compile)) + +(let (preloaded-file-list site-load-packages) + (load (concat default-directory "../lisp/prim/dumped-lisp.el")) + ;; (print (prin1-to-string preloaded-file-list)) + (load (concat default-directory "../site-packages") t t) + (setq preloaded-file-list + (append packages-hardcoded-lisp + preloaded-file-list + packages-useful-lisp + site-load-packages)) + (while preloaded-file-list + (let ((arg (car preloaded-file-list))) + ;; (print (prin1-to-string arg)) + (if (null (member arg packages-unbytecompiled-lisp)) + (progn + (setq arg (locate-library arg)) + (if (null arg) + (progn + (print (format "Library file %s: not found" + (car preloaded-file-list))) + (kill-emacs))) + (if (string-match "\\.elc?\\'" arg) + (setq arg (substring arg 0 (match-beginning 0)))) + (if (and (null (member arg processed)) + (file-exists-p (concat arg ".el")) + (file-newer-than-file-p (concat arg ".el") + (concat arg ".elc"))) + (setq processed (cons (concat arg ".el") processed))))) + (setq preloaded-file-list (cdr preloaded-file-list))))) + +(setq update-elc-files-to-compile (append update-elc-files-to-compile + processed)) + +;; (print (prin1-to-string update-elc-files-to-compile)) + +(if update-elc-files-to-compile + (progn + (setq command-line-args + (append '("-l" "loadup-el.el" "run-temacs" + "-batch" "-q" "-no-site-file" + "-l" "bytecomp" "-f" "batch-byte-compile") + update-elc-files-to-compile)) + (load "loadup-el.el")) + (condition-case nil + (delete-file "./NOBYTECOMPILE") + (file-error nil))) + +(kill-emacs) + +;;; update-elc.el ends here
--- a/lisp/utils/auto-autoloads.el Mon Aug 13 10:03:54 2007 +0200 +++ b/lisp/utils/auto-autoloads.el Mon Aug 13 10:04:58 2007 +0200 @@ -1002,23 +1002,6 @@ ;;;*** -;;;### (autoloads (speedbar-get-focus speedbar-frame-mode) "speedbar" "utils/speedbar.el") - -(defalias 'speedbar 'speedbar-frame-mode) - -(autoload 'speedbar-frame-mode "speedbar" "\ -Enable or disable speedbar. Positive ARG means turn on, negative turn off. -nil means toggle. Once the speedbar frame is activated, a buffer in -`speedbar-mode' will be displayed. Currently, only one speedbar is -supported at a time." t nil) - -(autoload 'speedbar-get-focus "speedbar" "\ -Change frame focus to or from the speedbar frame. -If the selected frame is not speedbar, then speedbar frame is -selected. If the speedbar frame is active, then select the attached frame." t nil) - -;;;*** - ;;;### (autoloads nil "timezone" "utils/timezone.el") (define-error 'invalid-date "Invalid date string")
--- a/lisp/utils/custom-load.el Mon Aug 13 10:03:54 2007 +0200 +++ b/lisp/utils/custom-load.el Mon Aug 13 10:04:58 2007 +0200 @@ -18,7 +18,9 @@ (custom-add-loads 'highlight-headers-faces '("highlight-headers")) (custom-add-loads 'comm '("ph")) (custom-add-loads 'id-select '("id-select")) +(custom-add-loads 'shadowfile '("shadowfile")) (custom-add-loads 'smtpmail '("smtpmail")) +(custom-add-loads 'files '("shadowfile")) (custom-add-loads 'edmacro '("edmacro")) (custom-add-loads 'faces '("facemenu" "font" "highlight-headers")) (custom-add-loads 'passwd '("passwd"))
--- a/lisp/utils/derived.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,361 +0,0 @@ -;;; derived.el --- allow inheritance of major modes. -;;; (formerly mode-clone.el) - -;; Copyright (C) 1993, 1994 Free Software Foundation, Inc. - -;; Author: David Megginson (dmeggins@aix1.uottawa.ca) -;; Maintainer: FSF - -;; 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.34. - -;;; Commentary: - -;; GNU Emacs is already, in a sense, object oriented -- each object -;; (buffer) belongs to a class (major mode), and that class defines -;; the relationship between messages (input events) and methods -;; (commands) by means of a keymap. -;; -;; The only thing missing is a good scheme of inheritance. It is -;; possible to simulate a single level of inheritance with generous -;; use of hooks and a bit of work -- sgml-mode, for example, also runs -;; the hooks for text-mode, and keymaps can inherit from other keymaps -;; -- but generally, each major mode ends up reinventing the wheel. -;; Ideally, someone should redesign all of Emacs's major modes to -;; follow a more conventional object-oriented system: when defining a -;; new major mode, the user should need only to name the existing mode -;; it is most similar to, then list the (few) differences. -;; -;; In the mean time, this package offers most of the advantages of -;; full inheritance with the existing major modes. The macro -;; `define-derived-mode' allows the user to make a variant of an existing -;; major mode, with its own keymap. The new mode will inherit the key -;; bindings of its parent, and will, in fact, run its parent first -;; every time it is called. For example, the commands -;; -;; (define-derived-mode hypertext-mode text-mode "Hypertext" -;; "Major mode for hypertext.\n\n\\{hypertext-mode-map}" -;; (setq case-fold-search nil)) -;; -;; (define-key hypertext-mode-map [down-mouse-3] 'do-hyper-link) -;; -;; will create a function `hypertext-mode' with its own (sparse) -;; keymap `hypertext-mode-map.' The command M-x hypertext-mode will -;; perform the following actions: -;; -;; - run the command (text-mode) to get its default setup -;; - replace the current keymap with 'hypertext-mode-map,' which will -;; inherit from 'text-mode-map'. -;; - replace the current syntax table with -;; 'hypertext-mode-syntax-table', which will borrow its defaults -;; from the current text-mode-syntax-table. -;; - replace the current abbrev table with -;; 'hypertext-mode-abbrev-table', which will borrow its defaults -;; from the current text-mode-abbrev table -;; - change the mode line to read "Hypertext" -;; - assign the value 'hypertext-mode' to the 'major-mode' variable -;; - run the body of commands provided in the macro -- in this case, -;; set the local variable `case-fold-search' to nil. -;; - **run the command (hypertext-mode-setup), which is empty by -;; default, but may be redefined by the user to contain special -;; commands (ie. setting local variables like 'outline-regexp') -;; **NOTE: do not use this option -- it will soon be obsolete. -;; - run anything assigned to 'hypertext-mode-hooks' (obsolete, but -;; supported for the sake of compatibility). -;; -;; The advantages of this system are threefold. First, text mode is -;; untouched -- if you had added the new keystroke to `text-mode-map,' -;; possibly using hooks, you would have added it to all text buffers -;; -- here, it appears only in hypertext buffers, where it makes -;; sense. Second, it is possible to build even further, and make -;; a derived mode from a derived mode. The commands -;; -;; (define-derived-mode html-mode hypertext-mode "HTML") -;; [various key definitions] -;; -;; will add a new major mode for HTML with very little fuss. -;; -;; Note also the function `derived-mode-class,' which returns the non-derived -;; major mode which a derived mode is based on (ie. NOT necessarily the -;; immediate parent). -;; -;; (derived-mode-class 'text-mode) ==> text-mode -;; (derived-mode-class 'hypertext-mode) ==> text-mode -;; (derived-mode-class 'html-mode) ==> text-mode - -;;; Code: - -;; PUBLIC: define a new major mode which inherits from an existing one. - -;; XEmacs -- no autoload -(defmacro define-derived-mode (child parent name &optional docstring &rest body) - "Create a new mode as a variant of an existing mode. - -The arguments to this command are as follow: - -CHILD: the name of the command for the derived mode. -PARENT: the name of the command for the parent mode (ie. text-mode). -NAME: a string which will appear in the status line (ie. \"Hypertext\") -DOCSTRING: an optional documentation string--if you do not supply one, - the function will attempt to invent something useful. -BODY: forms to execute just before running the - hooks for the new mode. - -Here is how you could define LaTeX-Thesis mode as a variant of LaTeX mode: - - (define-derived-mode LaTeX-thesis-mode LaTeX-mode \"LaTeX-Thesis\") - -You could then make new key bindings for `LaTeX-thesis-mode-map' -without changing regular LaTeX mode. In this example, BODY is empty, -and DOCSTRING is generated by default. - -On a more complicated level, the following command uses sgml-mode as -the parent, and then sets the variable `case-fold-search' to nil: - - (define-derived-mode article-mode sgml-mode \"Article\" - \"Major mode for editing technical articles.\" - (setq case-fold-search nil)) - -Note that if the documentation string had been left out, it would have -been generated automatically, with a reference to the keymap." - - ; Some trickiness, since what - ; appears to be the docstring - ; may really be the first - ; element of the body. - (if (and docstring (not (stringp docstring))) - (progn (setq body (cons docstring body)) - (setq docstring nil))) - (setq docstring (or docstring (derived-mode-make-docstring parent child))) - - (` (progn - (derived-mode-init-mode-variables (quote (, child))) - (defun (, child) () - (, docstring) - (interactive) - ; Run the parent. - ((, parent)) - ; Identify special modes. - (if (get (quote (, parent)) 'special) - (put (quote (, child)) 'special t)) - ;; XEmacs addition - (let ((mode-class (get (quote (, parent)) 'mode-class))) - (if mode-class - (put (quote (, child)) 'mode-class mode-class))) - ; Identify the child mode. - (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))) - ; Splice in the body (if any). - (,@ body) -;;; ; Run the setup function, if -;;; ; any -- this will soon be -;;; ; obsolete. -;;; (derived-mode-run-setup-function (quote (, child))) - ; Run the hooks, if any. - (derived-mode-run-hooks (quote (, child))))))) - - -;; PUBLIC: find the ultimate class of a derived mode. - -(defun derived-mode-class (mode) - "Find the class of a major mode. -A mode's class is the first ancestor which is NOT a derived mode. -Use the `derived-mode-parent' property of the symbol to trace backwards." - (while (get mode 'derived-mode-parent) - (setq mode (get mode 'derived-mode-parent))) - mode) - - -;; Inline functions to construct various names from a mode name. - -(defsubst derived-mode-setup-function-name (mode) - "Construct a setup-function name based on a mode name." - (intern (concat (symbol-name mode) "-setup"))) - -(defsubst derived-mode-hooks-name (mode) - "Construct a hooks name based on a mode name." - ;; XEmacs change from -hooks - (intern (concat (symbol-name mode) "-hook"))) - -(defsubst derived-mode-map-name (mode) - "Construct a map name based on a mode name." - (intern (concat (symbol-name mode) "-map"))) - -(defsubst derived-mode-syntax-table-name (mode) - "Construct a syntax-table name based on a mode name." - (intern (concat (symbol-name mode) "-syntax-table"))) - -(defsubst derived-mode-abbrev-table-name (mode) - "Construct an abbrev-table name based on a mode name." - (intern (concat (symbol-name mode) "-abbrev-table"))) - - -;; Utility functions for defining a derived mode. - -;; XEmacs -- don't autoload -(defun derived-mode-init-mode-variables (mode) - "Initialise variables for a new mode. -Right now, if they don't already exist, set up a blank keymap, an -empty syntax table, and an empty abbrev table -- these will be merged -the first time the mode is used." - - (if (boundp (derived-mode-map-name mode)) - t - (eval (` (defvar (, (derived-mode-map-name mode)) - ;; XEmacs change - (make-sparse-keymap (derived-mode-map-name mode)) - (, (format "Keymap for %s." mode))))) - (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))))) - (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))))))) - -(defun derived-mode-make-docstring (parent child) - "Construct a docstring for a new mode if none is provided." - - (format "This major mode is a variant of `%s', created by `define-derived-mode'. -It inherits all of the parent's attributes, but has its own keymap, -abbrev table and syntax table: - - `%s-map' and `%s-syntax-table' - -which more-or-less shadow - - `%s-map' and `%s-syntax-table' - -\\{%s-map}" parent child child parent parent child)) - - -;; Utility functions for running a derived mode. - -(defun derived-mode-set-keymap (mode) - "Set the keymap of the new mode, maybe merging with the parent." - (let* ((map-name (derived-mode-map-name mode)) - (new-map (eval map-name)) - (old-map (current-local-map))) - (and old-map - (get map-name 'derived-mode-unmerged) - (derived-mode-merge-keymaps old-map new-map)) - (put map-name 'derived-mode-unmerged nil) - (use-local-map new-map))) - -(defun derived-mode-set-syntax-table (mode) - "Set the syntax table of the new mode, maybe merging with the parent." - (let* ((table-name (derived-mode-syntax-table-name mode)) - (old-table (syntax-table)) - (new-table (eval table-name))) - (if (get table-name 'derived-mode-unmerged) - (derived-mode-merge-syntax-tables old-table new-table)) - (put table-name 'derived-mode-unmerged nil) - (set-syntax-table new-table))) - -(defun derived-mode-set-abbrev-table (mode) - "Set the abbrev table if it exists. -Always merge its parent into it, since the merge is non-destructive." - (let* ((table-name (derived-mode-abbrev-table-name mode)) - (old-table local-abbrev-table) - (new-table (eval table-name))) - (derived-mode-merge-abbrev-tables old-table new-table) - (setq local-abbrev-table new-table))) - -;;;(defun derived-mode-run-setup-function (mode) -;;; "Run the setup function if it exists." - -;;; (let ((fname (derived-mode-setup-function-name mode))) -;;; (if (fboundp fname) -;;; (funcall fname)))) - -(defun derived-mode-run-hooks (mode) - "Run the hooks if they exist." - - (let ((hooks-name (derived-mode-hooks-name mode))) - (if (boundp hooks-name) - (run-hooks hooks-name)))) - -;; Functions to merge maps and tables. - -(defun derived-mode-merge-keymaps (old new) - "Merge an old keymap into a new one. -The old keymap is set to be the parent of the new one, so that there will -be automatic inheritance." - ;; XEmacs change. FSF 19.30 & 19.34 has a whole bunch of weird crap here - ;; for merging prefix keys and such. Hopefully none of this is - ;; necessary in XEmacs. - (set-keymap-parents new (list old))) - -(defun derived-mode-merge-syntax-tables (old new) - "Merge an old syntax table into a new one. -Where the new table already has an entry, nothing is copied from the old one." - ;; 20.x - (if (fboundp 'map-char-table) - ;; we use map-char-table not map-syntax-table so we can explicitly - ;; check for inheritance. - (map-char-table - #'(lambda (key value) - (if (eq ?@ (char-syntax-from-code value)) - (map-char-table #'(lambda (key1 value1) - (put-char-table key1 value1 new)) - old - key))) - new) - ;; pre-20.0 - (let ((idx 0) - (end (min (length new) (length old)))) - (while (< idx end) - (if (not (aref new idx)) - (aset new idx (aref old idx))) - (setq idx (1+ idx)))))) - -;; Merge an old abbrev table into a new one. -;; This function requires internal knowledge of how abbrev tables work, -;; presuming that they are obarrays with the abbrev as the symbol, the expansion -;; as the value of the symbol, and the hook as the function definition. -(defun derived-mode-merge-abbrev-tables (old new) - (if old - (mapatoms - (function - (lambda (symbol) - (or (intern-soft (symbol-name symbol) new) - (define-abbrev new (symbol-name symbol) - (symbol-value symbol) (symbol-function symbol))))) - old))) - -(provide 'derived) - -;;; derived.el ends here
--- a/lisp/utils/easymenu.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,219 +0,0 @@ -;;; easymenu.el - Easy menu support for Emacs 19 and XEmacs. -;; -;; $Id: easymenu.el,v 1.6 1997/07/09 04:31:35 steve Exp $ -;; -;; LCD Archive Entry: -;; easymenu|Per Abrahamsen|abraham@iesd.auc.dk| -;; Easy menu support for XEmacs| -;; $Date: 1997/07/09 04:31:35 $|$Revision: 1.6 $|~/misc/easymenu.el.gz| - -;; Copyright (C) 1992, 1993, 1994, 1995 Free Software Foundation, Inc. - -;; 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; if not, write to the Free Software -;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Synched up with: Not synched with FSF. -;;; In RMS's typical lame-ass way, he removed all support for -;;; what he calls "other Emacs versions" from the version of -;;; easymenu.el included in FSF. He also incorrectly claims -;;; himself as the author rather than Per Abrahamsen. - -;; Commentary: -;; -;; Easymenu allows you to define menus for both Emacs 19 and XEmacs. -;; -;; This file -;; The advantages of using easymenu are: -;; -;; - Easier to use than either the Emacs 19 and XEmacs menu syntax. -;; -;; - Common interface for Emacs 18, Emacs 19, and XEmacs. -;; (The code does nothing when run under Emacs 18). -;; -;; The public functions are: -;; -;; - Function: easy-menu-define SYMBOL MAPS DOC MENU -;; SYMBOL is both the name of the variable that holds the menu and -;; the name of a function that will present a the menu. -;; MAPS is a list of keymaps where the menu should appear in the menubar. -;; DOC is the documentation string for the variable. -;; MENU is an XEmacs style menu description. -;; -;; See the documentation for easy-menu-define for details. -;; -;; - Function: easy-menu-change PATH NAME ITEMS -;; Change an existing menu. -;; The menu must already exist and be visible on the menu bar. -;; PATH is a list of strings used for locating the menu on the menu bar. -;; NAME is the name of the menu. -;; ITEMS is a list of menu items, as defined in `easy-menu-define'. -;; -;; - Function: easy-menu-add MENU [ MAP ] -;; Add MENU to the current menubar in MAP. -;; -;; - Function: easy-menu-remove MENU -;; Remove MENU from the current menubar. -;; -;; Emacs 19 never uses `easy-menu-add' or `easy-menu-remove', menus -;; automatically appear and disappear when the keymaps specified by -;; the MAPS argument to `easy-menu-define' are activated. -;; -;; XEmacs will bind the map to button3 in each MAPS, but you must -;; explicitly call `easy-menu-add' and `easy-menu-remove' to add and -;; remove menus from the menu bar. - -;;; Code: - -;; ;;;###autoload -(defmacro easy-menu-define (symbol maps doc menu) - "Define a menu bar submenu in maps MAPS, according to MENU. -The arguments SYMBOL and DOC are ignored; they are present for -compatibility only. SYMBOL is not evaluated. In other Emacs versions -these arguments may be used as a variable to hold the menu data, and a -doc string for that variable. - -The first element of MENU must be a string. It is the menu bar item name. -The rest of the elements are menu items. - -A menu item is usually a vector of three elements: [NAME CALLBACK ENABLE] - -NAME is a string--the menu item name. - -CALLBACK is a command to run when the item is chosen, -or a list to evaluate when the item is chosen. - -ENABLE is an expression; the item is enabled for selection -whenever this expression's value is non-nil. - -Alternatively, a menu item may have the form: - - [ NAME CALLBACK [ KEYWORD ARG ] ... ] - -Where KEYWORD is one of the symbol defined below. - - :keys KEYS - -KEYS is a string; a complex keyboard equivalent to this menu item. - - :active ENABLE - -ENABLE is an expression; the item is enabled for selection -whenever this expression's value is non-nil. - - :suffix NAME - -NAME is a string; the name of an argument to CALLBACK. - - :style STYLE - -STYLE is a symbol describing the type of menu item. The following are -defined: - -toggle: A checkbox. - Currently just prepend the name with the string \"Toggle \". -radio: A radio button. -nil: An ordinary menu item. - - :selected SELECTED - -SELECTED is an expression; the checkbox or radio button is selected -whenever this expression's value is non-nil. -Currently just disable radio buttons, no effect on checkboxes. - -A menu item can be a string. Then that string appears in the menu as -unselectable text. A string consisting solely of hyphens is displayed -as a solid horizontal line. - -A menu item can be a list. It is treated as a submenu. -The first element should be the submenu name. That's used as the -menu item in the top-level menu. The cdr of the submenu list -is a list of menu items, as above." - (` (progn - (defvar (, symbol) nil (, doc)) - (easy-menu-do-define (quote (, symbol)) (, maps) (, doc) (, menu))))) - -(defun easy-menu-do-define (symbol maps doc menu) - (if (featurep 'menubar) - (progn - (set symbol menu) - (fset symbol (list 'lambda '(e) - doc - '(interactive "@e") - '(run-hooks 'activate-menubar-hook) - '(setq zmacs-region-stays 't) - (list 'popup-menu symbol)))))) - -(fset 'easy-menu-change (symbol-function 'add-menu)) - -;; This variable hold the easy-menu mode menus of all major and -;; minor modes currently in effect in the current buffer. -(defvar easy-menu-all-popups nil) -(make-variable-buffer-local 'easy-menu-all-popups) - -(defun easy-menu-add (menu &optional map) - "Add MENU to the current menu bar." - (if (featurep 'menubar) - (progn - (pushnew menu easy-menu-all-popups) - (setq mode-popup-menu (if (> (length easy-menu-all-popups) 1) - (cons (easy-menu-title) - (reverse easy-menu-all-popups)) - (car easy-menu-all-popups))) - - (cond ((null current-menubar) - ;; Don't add it to a non-existing menubar. - nil) - ((assoc (car menu) current-menubar) - ;; Already present. - nil) - ((equal current-menubar '(nil)) - ;; Set at left if only contains right marker. - (set-buffer-menubar (list menu nil))) - (t - ;; Add at right. - (set-buffer-menubar (copy-sequence current-menubar)) - (add-menu nil (car menu) (cdr menu))))))) - -(defun easy-menu-remove (menu) - "Remove MENU from the current menu bar." - (if (featurep 'menubar) - (progn - (setq easy-menu-all-popups (delq menu easy-menu-all-popups) - mode-popup-menu (if (< (length easy-menu-all-popups) 1) - (cons (easy-menu-title) - (reverse easy-menu-all-popups)) - (car easy-menu-all-popups))) - - (and current-menubar - (assoc (car menu) current-menubar) - (delete-menu-item (list (car menu))))))) - -;; Think up a good title for the menu. Take the major-mode of the -;; buffer, strip the -mode part, convert hyphens to spaces, and -;; capitalize it. -;; -;; If you can think of something smarter, feel free to replace it. -;; Don't forget to mail the change to xemacs@xemacs.org where everyone -;; can flame, er, praise your changes. -(defun easy-menu-title () - (capitalize (replace-in-string (replace-in-string - (symbol-name major-mode) "-mode$" "") - "-" " "))) - -(provide 'easymenu) - -;;; easymenu.el ends here
--- a/lisp/utils/edit-toolbar.el Mon Aug 13 10:03:54 2007 +0200 +++ b/lisp/utils/edit-toolbar.el Mon Aug 13 10:04:58 2007 +0200 @@ -191,7 +191,8 @@ \\{edit-toolbar-map}" (setq mode-popup-menu edit-toolbar-menu) - (if current-menubar + (if (and (featurep 'menubar)) + current-menubar (progn (set (make-local-variable 'current-menubar) (copy-sequence current-menubar))
--- a/lisp/utils/facemenu.el Mon Aug 13 10:03:54 2007 +0200 +++ b/lisp/utils/facemenu.el Mon Aug 13 10:04:58 2007 +0200 @@ -783,9 +783,10 @@ (defun facemenu-insert-menu-entry (menu before-entry name function) "Insert menu item with name NAME and associated function FUNCTION into menu MENU before entry BEFORE-ENTRY." - (while (not (eq (cadr menu) before-entry)) - (setq menu (cdr menu))) - (setcdr menu (cons (vector name function t) (cdr menu)))) + (when (featurep 'menubar) + (while (not (eq (cadr menu) before-entry)) + (setq menu (cdr menu))) + (setcdr menu (cons (vector name function t) (cdr menu))))) (defun facemenu-add-new-face (face) "Add a FACE to the appropriate Face menu.
--- a/lisp/utils/finder.el Mon Aug 13 10:03:54 2007 +0200 +++ b/lisp/utils/finder.el Mon Aug 13 10:04:58 2007 +0200 @@ -83,6 +83,7 @@ (comm . "communications, networking, remote access to files") (data . "support for editing files of data") (docs . "support for Emacs documentation") + (dumped . "files preloaded into Emacs") (emulations . "emulations of other editors") (extensions . "Emacs Lisp language extensions") (faces . "support for multiple fonts")
--- a/lisp/utils/floating-toolbar.el Mon Aug 13 10:03:54 2007 +0200 +++ b/lisp/utils/floating-toolbar.el Mon Aug 13 10:04:58 2007 +0200 @@ -190,7 +190,8 @@ (specifier-instance left-toolbar-width) 0)) ;; better than nothing - (menubar-height (if current-menubar 22 0))) + (menubar-height (if (and (featurep 'menubar) + current-menubar) 22 0))) (setq x (+ left xleft-toolbar-width (event-x-pixel event)) y (+ top xtop-toolbar-height menubar-height (event-y-pixel event))))
--- a/lisp/utils/lib-complete.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,343 +0,0 @@ -;;; lib-complete.el --- Completion on the lisp search path - -;; Copyright (C) 1997 Free Software Foundation, Inc. -;; Copyright (C) Mike Williams <mike-w@cs.aukuni.ac.nz> 1991 - -;; Author: Mike Williams <mike-w@cs.aukuni.ac.nz> -;; Maintainer: XEmacs Development Team -;; Keywords: lisp, extensions -;; Created: Sat Apr 20 17:47:21 1991 - -;; 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: - -;; ======================================================================== -;; lib-complete.el -- Completion on a search path -;; Author : Mike Williams <mike-w@cs.aukuni.ac.nz> -;; Created On : Sat Apr 20 17:47:21 1991 -;; Last Modified By: Heiko M|nkel <muenkel@tnt.uni-hannover.de> -;; Additional XEmacs integration By: Chuck Thompson <cthomp@cs.uiuc.edu> -;; Last Modified On: Thu Jul 1 14:23:00 1994 -;; RCS Info : $Revision: 1.5 $ $Locker: $ -;; ======================================================================== -;; NOTE: XEmacs must be redumped if this file is changed. -;; -;; Copyright (C) Mike Williams <mike-w@cs.aukuni.ac.nz> 1991 -;; -;; Keywords: utility, lisp - -;; Many thanks to Hallvard Furuseth <hallvard@ifi.uio.no> for his -;; helpful suggestions. - -;; The function locate-file is removed, because of its incompatibility -;; with the buildin function of the lemacs 19.10 (Heiko M|nkel). - -;; There is now the new function find-library in this package. - -;;; ChangeLog: - -;; 4/26/97: sb Mule-ize. - -;;; Code: - -;;=== Determine completions for filename in search path =================== - -(defun library-all-completions (FILE SEARCH-PATH &optional FULL FAST) - "Return all completions for FILE in any directory on SEARCH-PATH. -If optional third argument FULL is non-nil, returned pathnames should be - absolute rather than relative to some directory on the SEARCH-PATH. -If optional fourth argument FAST is non-nil, don't sort the completions, - or remove duplicates." - (setq FILE (or FILE "")) - (if (file-name-absolute-p FILE) - ;; It's an absolute file name, so don't need SEARCH-PATH - (progn - (setq FILE (expand-file-name FILE)) - (file-name-all-completions - (file-name-nondirectory FILE) (file-name-directory FILE))) - (let ((subdir (file-name-directory FILE)) - (file (file-name-nondirectory FILE)) - all-completions) - ;; Make list of completions in each directory on SEARCH-PATH - (while SEARCH-PATH - (let* ((dir (concat (file-name-as-directory - (expand-file-name (car SEARCH-PATH))) - subdir)) - (dir-prefix (if FULL dir subdir))) - (if (file-directory-p dir) - (let ((subdir-completions - (file-name-all-completions file dir))) - (while subdir-completions - (setq all-completions - (cons (concat dir-prefix (car subdir-completions)) - all-completions)) - (setq subdir-completions (cdr subdir-completions)))))) - (setq SEARCH-PATH (cdr SEARCH-PATH))) - (if FAST all-completions - (let ((sorted (nreverse (sort all-completions 'string<))) - compressed) - (while sorted - (if (equal (car sorted) (car compressed)) nil - (setq compressed (cons (car sorted) compressed))) - (setq sorted (cdr sorted))) - compressed))))) - -;;=== Utilities =========================================================== - -(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)) - (save-excursion - (goto-char (point-max)) - (let ((orig-pmax (point-max))) - (unwind-protect - (progn - (insert " " (, MESSAGE)) (goto-char orig-pmax) - (sit-for 0) ; Redisplay - (,@ FORMS)) - (delete-region orig-pmax (point-max))))) - (prog2 - (message "%s" (, MESSAGE)) - (progn (,@ FORMS)) - (message ""))))) -#+infodock (defalias 'lib-funcall-with-msg 'progn-with-message) - -(put 'progn-with-message 'lisp-indent-hook 1) -#+infodock (put 'lib-funcall-with-message 'lisp-indent-hook 1) - -;;=== Completion caching ================================================== - -(defconst lib-complete:cache nil - "Used within read-library and read-library-internal to prevent -costly repeated calls to library-all-completions. -Format is a list of lists of the form - - ([<path> <subdir>] <cache-record> <cache-record> ...) - -where each <cache-record> has the form - - (<root> <modtimes> <completion-table>)") -#+infodock (defvaralias 'lib-completions 'lib-complete:cache) - -(defun lib-complete:better-root (ROOT1 ROOT2) - "Return non-nil if ROOT1 is a superset of ROOT2." - (and (equal (file-name-directory ROOT1) (file-name-directory ROOT2)) - (string-match - (concat "^" (regexp-quote (file-name-nondirectory ROOT1))) - ROOT2))) - -(defun lib-complete:get-completion-table (FILE PATH FILTER) - (let* ((subdir (file-name-directory FILE)) - (root (file-name-nondirectory FILE)) - (PATH - (mapcar - (function (lambda (dir) (file-name-as-directory - (expand-file-name (or dir ""))))) - PATH)) - (key (vector PATH subdir FILTER)) - (real-dirs - (if subdir - (mapcar (function (lambda (dir) (concat dir subdir))) PATH) - PATH)) - (path-modtimes - (mapcar - (function (lambda (fn) (if fn (nth 5 (file-attributes fn))))) - real-dirs)) - (cache-entry (assoc key lib-complete:cache)) - (cache-records (cdr cache-entry))) - ;; Look for cached entry - (catch 'table - (while cache-records - (if (and - (lib-complete:better-root (nth 0 (car cache-records)) root) - (equal (nth 1 (car cache-records)) path-modtimes)) - (throw 'table (nth 2 (car cache-records)))) - (setq cache-records (cdr cache-records))) - ;; Otherwise build completions - (let ((completion-list - (progn-with-message "(building completion table...)" - (library-all-completions FILE PATH nil 'fast))) - (completion-table (make-vector 127 0))) - (while completion-list - (let ((completion - (if (or (not FILTER) - (file-directory-p (car completion-list))) - (car completion-list) - (funcall FILTER (car completion-list))))) - (if completion - (intern completion completion-table))) - (setq completion-list (cdr completion-list))) - ;; Cache the completions - (lib-complete:cache-completions key root - path-modtimes completion-table) - completion-table)))) - -(defvar lib-complete:max-cache-size 40 - "*Maximum number of search paths which are cached.") - -(defun lib-complete:cache-completions (key root modtimes table) - (let* ((cache-entry (assoc key lib-complete:cache)) - (cache-records (cdr cache-entry)) - (new-cache-records (list (list root modtimes table)))) - (if (not cache-entry) nil - ;; Remove old cache entry - (setq lib-complete:cache (delq cache-entry lib-complete:cache)) - ;; Copy non-redundant entries from old cache entry - (while cache-records - (if (or (equal root (nth 0 (car cache-records))) - (lib-complete:better-root root (nth 0 (car cache-records)))) - nil - (setq new-cache-records - (cons (car cache-records) new-cache-records))) - (setq cache-records (cdr cache-records)))) - ;; Add entry to front of cache - (setq lib-complete:cache - (cons (cons key (nreverse new-cache-records)) lib-complete:cache)) - ;; Trim cache - (let ((tail (nthcdr lib-complete:max-cache-size lib-complete:cache))) - (if tail (setcdr tail nil))))) - -;;=== Read a filename, with completion in a search path =================== - -(defun read-library-internal (FILE FILTER FLAG) - "Don't call this." - ;; Relies on read-library-internal-search-path being let-bound - (let ((completion-table - (lib-complete:get-completion-table - FILE read-library-internal-search-path FILTER))) - (cond - ((not completion-table) nil) - ;; Completion table is filtered before use, so the PREDICATE - ;; argument is redundant. - ((eq FLAG nil) (try-completion FILE completion-table nil)) - ((eq FLAG t) (all-completions FILE completion-table nil)) - ((eq FLAG 'lambda) (and (intern-soft FILE completion-table) t)) - ))) - -(defun read-library (PROMPT SEARCH-PATH &optional DEFAULT MUST-MATCH - FULL FILTER) - "Read library name, prompting with PROMPT and completing in directories -from SEARCH-PATH. A nil in the search path represents the current -directory. Completions for a given search-path are cached, with the -cache being invalidated whenever one of the directories on the path changes. -Default to DEFAULT if user enters a null string. -Optional fourth arg MUST-MATCH non-nil means require existing file's name. - Non-nil and non-t means also require confirmation after completion. -Optional fifth argument FULL non-nil causes a full pathname, rather than a - relative pathname, to be returned. Note that FULL implies MUST-MATCH. -Optional sixth argument FILTER can be used to provide a function to - filter the completions. This function is passed the filename, and should - return a transformed filename (possibly a null transformation) or nil, - indicating that the filename should not be included in the completions." - (let* ((read-library-internal-search-path SEARCH-PATH) - (library (completing-read PROMPT 'read-library-internal - FILTER (or MUST-MATCH FULL) nil))) - (cond - ((equal library "") DEFAULT) - (FULL (locate-file library read-library-internal-search-path - ;; decompression doesn't work with Mule -slb - (if (featurep 'mule) - ".el:.elc" - ".el:.el.gz:.elc"))) - (t library)))) - -;; NOTE: as a special case, read-library may be used to read a filename -;; relative to the current directory, returning a *relative* pathname -;; (read-file-name returns a full pathname). -;; -;; eg. (read-library "Local header: " '(nil) nil) - -(defun get-library-path () - "Front end to read-library" - (read-library "Find Library file: " load-path nil t t - (function (lambda (fn) - (cond - ;; decompression doesn't work with mule -slb - ((string-match (if (featurep 'mule) - "\\.el$" - "\\.el\\(\\.gz\\)?$") fn) - (substring fn 0 (match-beginning 0)))))) - )) - -;;=== Replacement for load-library with completion ======================== - -(defun load-library (library) - "Load the library named LIBRARY. -This is an interface to the function `load'." - (interactive - (list (read-library "Load Library: " load-path nil nil nil - (function (lambda (fn) - (cond - ((string-match "\\.elc?$" fn) - (substring fn 0 (match-beginning 0)))))) - ))) - (load library)) - -;;=== find-library with completion (Author: Heiko Muenkel) =================== - -(defun find-library (library &optional codesys) - "Find and edit the source for the library named LIBRARY. -The extension of the LIBRARY must be omitted. -Under XEmacs/Mule, the optional second argument specifies the -coding system to use when decoding the file. Interactively, -with a prefix argument, you will be prompted for the coding system." - (interactive - (list (get-library-path) - (if current-prefix-arg - (read-coding-system "Coding System: ")))) - (find-file library codesys)) - -(defun find-library-other-window (library &optional codesys) - "Load the library named LIBRARY in another window. -Under XEmacs/Mule, the optional second argument specifies the -coding system to use when decoding the file. Interactively, -with a prefix argument, you will be prompted for the coding system." - (interactive - (list (get-library-path) - (if current-prefix-arg - (read-coding-system "Coding System: ")))) - (find-file-other-window library codesys)) -#+infodock (defalias 'lib-edit-other-window 'find-library-other-window) - -(defun find-library-other-frame (library &optional codesys) - "Load the library named LIBRARY in a newly-created frame. -Under XEmacs/Mule, the optional second argument specifies the -coding system to use when decoding the file. Interactively, -with a prefix argument, you will be prompted for the coding system." - (interactive - (list (get-library-path) - (if current-prefix-arg - (read-coding-system "Coding System: ")))) - (find-file-other-frame library codesys)) - -; This conflicts with an existing binding -;(define-key global-map "\C-xl" 'find-library) -(define-key global-map "\C-x4l" 'find-library-other-window) -(define-key global-map "\C-x5l" 'find-library-other-frame) - -#+infodock (defalias 'lib-where-is 'locate-library) - -#+infodock (provide 'lib) -(provide 'lib-complete) -;;; lib-complete.el ends here
--- a/lisp/utils/map-ynp.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,290 +0,0 @@ -;;; map-ynp.el --- General-purpose boolean question-asker. - -;; Copyright (C) 1991-1995, 1997 Free Software Foundation, Inc. - -;; Author: Roland McGrath <roland@gnu.ai.mit.edu> -;; Keywords: lisp, extensions - -;; 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: Emacs/Mule zeta. - -;;; Commentary: - -;; map-y-or-n-p is a general-purpose question-asking function. -;; It asks a series of y/n questions (a la y-or-n-p), and decides to -;; applies an action to each element of a list based on the answer. -;; The nice thing is that you also get some other possible answers -;; to use, reminiscent of query-replace: ! to answer y to all remaining -;; questions; ESC or q to answer n to all remaining questions; . to answer -;; y once and then n for the remainder; and you can get help with C-h. - -;;; Code: - -(defun map-y-or-n-p (prompter actor list &optional help action-alist - no-cursor-in-echo-area) - "Ask a series of boolean questions. -Takes args PROMPTER ACTOR LIST, and optional args HELP and ACTION-ALIST. - -LIST is a list of objects, or a function of no arguments to return the next -object or nil. - -If PROMPTER is a string, the prompt is \(format PROMPTER OBJECT\). If not -a string, PROMPTER is a function of one arg (an object from LIST), which -returns a string to be used as the prompt for that object. If the return -value is not a string, it may be nil to ignore the object or non-nil to act -on the object without asking the user. - -ACTOR is a function of one arg (an object from LIST), -which gets called with each object that the user answers `yes' for. - -If HELP is given, it is a list (OBJECT OBJECTS ACTION), -where OBJECT is a string giving the singular noun for an elt of LIST; -OBJECTS is the plural noun for elts of LIST, and ACTION is a transitive -verb describing ACTOR. The default is \(\"object\" \"objects\" \"act on\"\). - -At the prompts, the user may enter y, Y, or SPC to act on that object; -n, N, or DEL to skip that object; ! to act on all following objects; -ESC or q to exit (skip all following objects); . (period) to act on the -current object and then exit; or \\[help-command] to get help. - -If ACTION-ALIST is given, it is an alist (KEY FUNCTION HELP) of extra keys -that will be accepted. KEY is a character; FUNCTION is a function of one -arg (an object from LIST); HELP is a string. When the user hits KEY, -FUNCTION is called. If it returns non-nil, the object is considered -\"acted upon\", and the next object from LIST is processed. If it returns -nil, the prompt is repeated for the same object. - -Final optional argument NO-CURSOR-IN-ECHO-AREA non-nil says not to set -`cursor-in-echo-area' while prompting. - -This function uses `query-replace-map' to define the standard responses, -but not all of the responses which `query-replace' understands -are meaningful here. - -Returns the number of actions taken." - (let* ((actions 0) - user-keys mouse-event map prompt char elt def - ;; Non-nil means we should use mouse menus to ask. - ;; use-menus - ;;delayed-switch-frame - (next (if (or (and list (symbolp list)) - (subrp list) - (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)))))) - (if (should-use-dialog-box-p) - ;; Make a list describing a dialog box. - (let (;; (object (capitalize (or (nth 0 help) "object"))) - ;; (objects (capitalize (or (nth 1 help) "objects"))) - ;; (action (capitalize (or (nth 2 help) "act on"))) - ) - (setq map `(("Yes" . act) ("No" . skip) -; bogus crap. --ben -; ((, (if help -; (capitalize -; (or (nth 3 help) -; (concat action " All " objects))) -; "Do All")) . automatic) -; ((, (if help -; (capitalize -; (or (nth 4 help) -; (concat action " " object " And Quit"))) -; "Do it and Quit")) . act-and-exit) -; ((, (capitalize -; (or (and help (nth 5 help)) "Quit"))) -; . exit) - ("Yes All" . automatic) - ("No All" . exit) - ("Cancel" . quit) - ,@(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))))) - action-alist ", ") - " ") - "") - ;; Make a map that defines each user key as a vector containing - ;; its definition. - ;; XEmacs - map (let ((foomap (make-sparse-keymap))) - (mapcar #'(lambda (elt) - (define-key - foomap - (if (characterp (car elt)) - (char-to-string (car elt)) - (car elt)) - (vector (nth 1 elt)))) - action-alist) - (set-keymap-parents foomap (list query-replace-map)) - foomap))) - (unwind-protect - (progn - (if (stringp prompter) - (setq prompter (` (lambda (object) - (format (, prompter) object))))) - (while (funcall next) - (setq prompt (funcall prompter elt)) - (cond ((stringp prompt) - ;; Prompt the user about this object. - (setq quit-flag nil) - (if mouse-event ; XEmacs - (setq def (or (get-dialog-box-response - mouse-event - (cons prompt map)) - 'quit)) - ;; Prompt in the echo area. - (let ((cursor-in-echo-area (not no-cursor-in-echo-area))) - (display-message - 'prompt - (format "%s(y, n, !, ., q, %sor %s) " - prompt user-keys - (key-description (vector help-char)))) - (setq char (next-command-event)) - ;; Show the answer to the question. - (display-message - 'prompt - (format - "%s(y, n, !, ., q, %sor %s) %s" - prompt user-keys - (key-description (vector help-char)) - (single-key-description char)))) - (setq def (lookup-key map (vector char)))) - (cond ((eq def 'exit) - (setq next (function (lambda () nil)))) - ((eq def 'act) - ;; Act on the object. - (funcall actor elt) - (setq actions (1+ actions))) - ((eq def 'skip) - ;; Skip the object. - ) - ((eq def 'act-and-exit) - ;; Act on the object and then exit. - (funcall actor elt) - (setq actions (1+ actions) - next (function (lambda () nil)))) - ((or (eq def 'quit) (eq def 'exit-prefix)) - (setq quit-flag t) - (setq next (` (lambda () - (setq next '(, next)) - '(, elt))))) - ((eq def 'automatic) - ;; Act on this and all following objects. - ;; (if (funcall prompter elt) ; Emacs - (if (eval (funcall prompter elt)) - (progn - (funcall actor elt) - (setq actions (1+ actions)))) - (while (funcall next) - ;; (funcall prompter elt) ; Emacs - (if (eval (funcall prompter elt)) - (progn - (funcall actor elt) - (setq actions (1+ actions)))))) - ((eq def 'help) - (with-output-to-temp-buffer "*Help*" - (princ - (let ((object (if help (nth 0 help) "object")) - (objects (if help (nth 1 help) "objects")) - (action (if help (nth 2 help) "act on"))) - (concat - (format "Type SPC or `y' to %s the current %s; -DEL or `n' to skip the current %s; -! to %s all remaining %s; -ESC or `q' to exit;\n" - action object object action objects) - (mapconcat (function - (lambda (elt) - (format "%c to %s" - (nth 0 elt) - (nth 2 elt)))) - action-alist - ";\n") - (if action-alist ";\n") - (format "or . (period) to %s \ -the current %s and exit." - action object)))) - (save-excursion - (set-buffer standard-output) - (help-mode))) - - (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)))))) - ;((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))))) - (t - ;; Random char. - (message "Type %s for help." - (key-description (vector help-char))) - (beep) - (sit-for 1) - (setq next (` (lambda () - (setq next '(, next)) - '(, elt))))))) - ((eval prompt) - (progn - (funcall actor elt) - (setq actions (1+ actions))))))) - ;;(if delayed-switch-frame - ;; (setq unread-command-events - ;; (cons delayed-switch-frame unread-command-events)))) - ;; ((eval prompt) - ;; (progn - ;; (funcall actor elt) - ;; (setq actions (1+ actions))))) - ) - ;; Clear the last prompt from the minibuffer. - (clear-message 'prompt) - ;; Return the number of actions that were taken. - actions)) - -;;; map-ynp.el ends here
--- a/lisp/utils/shadow.el Mon Aug 13 10:03:54 2007 +0200 +++ b/lisp/utils/shadow.el Mon Aug 13 10:04:58 2007 +0200 @@ -224,11 +224,11 @@ (message "This site has duplicate Lisp libraries with the same name. If a locally-installed Lisp library overrides a library in the Emacs release, that can cause trouble, and you should probably remove the locally-installed -version unless you know what you are doing.\n")) - (while shadows - (message "%s hides %s" (car shadows) (car (cdr shadows))) - (setq shadows (cdr (cdr shadows)))) - (message "%s" msg))))) +version unless you know what you are doing.\n") + (while shadows + (message "%s hides %s" (car shadows) (car (cdr shadows))) + (setq shadows (cdr (cdr shadows)))) + (message "%s" msg)))))) (provide 'shadow)
--- a/lisp/utils/shadowfile.el Mon Aug 13 10:03:54 2007 +0200 +++ b/lisp/utils/shadowfile.el Mon Aug 13 10:04:58 2007 +0200 @@ -25,7 +25,7 @@ ;; LCD Archive Entry: ;; shadowfile|Boris Goldowsky|boris@gnu.ai.mit.edu| ;; Helps you keep identical copies of files in multiple places.| -;; $Date: 1997/02/24 01:14:19 $ |$Revision: 1.2 $|~/misc/shadowfile.el.Z| +;; $Date: 1997/11/09 07:07:32 $ |$Revision: 1.3 $|~/misc/shadowfile.el.Z| ;;; Synched up with: FSF 19.30. @@ -86,37 +86,54 @@ (provide 'shadowfile) (require 'efs-auto) +;;; I don't think this is very cool... hope it works without the setting. (setq find-file-visit-truename t) ; makes life easier with symbolic links ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defgroup shadowfile nil + "Keep identical copies of files in more than one place." + :group 'files + :prefix "shadow") -(defvar shadow-noquery nil +(defcustom shadow-noquery nil "*If t, always copy shadow files without asking. If nil \(the default), always ask. If not nil and not t, ask only if there -is no buffer currently visiting the file.") +is no buffer currently visiting the file." + :type 'boolean + :group 'shadowfile) -(defvar shadow-inhibit-message nil - "*If nonnil, do not display a message when a file needs copying.") +(defcustom shadow-inhibit-message nil + "*If nonnil, do not display a message when a file needs copying." + :type 'boolean + :group 'shadowfile) -(defvar shadow-inhibit-overload nil +(defcustom shadow-inhibit-overload nil "If nonnil, shadowfile won't redefine C-x C-c. Normally it overloads the function `save-buffers-kill-emacs' to check -for files have been changed and need to be copied to other systems.") +for files have been changed and need to be copied to other systems." + :type 'boolean + :group 'shadowfile) -(defvar shadow-info-file nil +(defcustom shadow-info-file nil "File to keep shadow information in. The shadow-info-file should be shadowed to all your accounts to -ensure consistency. Default: ~/.shadows") +ensure consistency. Default: ~/.xemacs/shadows" + :type '(choice (const :tag "Default" nil) + (file)) + :group 'shadowfile) -(defvar shadow-todo-file nil +(defcustom shadow-todo-file nil "File to store the list of uncopied shadows in. This means that if a remote system is down, or for any reason you cannot or decide not to copy your shadow files at the end of one emacs session, it will remember and ask you again in your next emacs session. This file must NOT be shadowed to any other system, it is host-specific. -Default: ~/.shadow_todo") +Default: ~/.xemacs/shadow_todo" + :type '(choice (const :tag "Default" nil) + (file)) + :group 'shadowfile) ;;; The following two variables should in most cases initialize themselves ;;; correctly. They are provided as variables in case the defaults are wrong @@ -309,7 +326,7 @@ full efs ftp pathname." (if (listp fullpath) fullpath - (efs-ftp-name fullpath))) + (efs-ftp-path fullpath))) (defun shadow-parse-path (path) "Parse any PATH into \(site user path) list.
--- a/lisp/utils/speedbar.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2521 +0,0 @@ -;;; speedbar --- quick access to files and tags -*-byte-compile-warnings:nil;-*- - -;; Copyright (C) 1996, 1997 Eric M. Ludlam -;; -;; Author: Eric M. Ludlam <zappo@gnu.ai.mit.edu> -;; Version: 0.5 -;; Keywords: file, tags, tools -;; X-RCS: $Id: speedbar.el,v 1.4 1997/10/12 01:39:54 steve Exp $ -;; -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, you can either send email to this -;; program's author (see below) or write to: -;; -;; The Free Software Foundation, Inc. -;; 675 Mass Ave. -;; Cambridge, MA 02139, USA. -;; -;; Please send bug reports, etc. to zappo@gnu.ai.mit.edu. -;; - -;;; Commentary: -;; -;; The speedbar provides a frame in which files, and locations in -;; files are displayed. These items can be clicked on with mouse-2 -;; in order to make the last active frame display that file location. -;; -;; To use speedbar, add this to your .emacs file: -;; -;; (autoload 'speedbar-frame-mode "speedbar" "Popup a speedbar frame" t) -;; (autoload 'speedbar-get-focus "speedbar" "Jump to speedbar frame" t) -;; -;; If you want to choose it from a menu or something, do this: -;; -;; (define-key-after (lookup-key global-map [menu-bar tools]) -;; [speedbar] '("Speedbar" . speedbar-frame-mode) [calendar]) -;; -;; If you want to access speedbar using only the keyboard, do this: -;; -;; (define-key global-map [f4] 'speedbar-get-focus) -;; -;; This will let you hit f4 (or whatever key you choose) to jump -;; focus to the speedbar frame. Pressing RET or e to jump to a file -;; or tag will move you back to the attached frame. The command -;; `speedbar-get-fucus' will also create a speedbar frame if it does -;; not exist. -;; -;; Once a speedbar frame is active, it takes advantage of idle time -;; to keep it's contents updated. The contents is usually a list of -;; files in the directory of the currently active buffer. When -;; applicable, tags in the active file can be expanded. -;; -;; To add new supported files types into speedbar, use the function -;; `speedbar-add-supported-extension' If speedbar complains that the -;; file type is not supported, that means there is no built in -;; support from imenu, and the etags part wasn't set up correctly. You -;; may add elements to `speedbar-supported-extension-expressions' as long -;; as it is done before speedbar is loaded. -;; -;; To prevent speedbar from following you into certain directories -;; use the function `speedbar-add-ignored-path-regexp' too add a new -;; regular expression matching a type of path. You may add list -;; elements to `speedbar-ignored-path-expressions' as long as it is -;; done before speedbar is loaded. -;; -;; To add new file types to imenu, see the documentation in the -;; file imenu.el that comes with emacs. To add new file types which -;; etags supports, you need to modify the variable -;; `speedbar-fetch-etags-parse-list'. -;; -;; If the updates are going too slow for you, modify the variable -;; `speedbar-update-speed' to a longer idle time before updates. -;; -;; If you navigate directories, you will probably notice that you -;; will navigate to a directory which is eventually replaced after -;; you go back to editing a file (unless you pull up a new file.) -;; The delay time before this happens is in -;; `speedbar-navigating-speed', and defaults to 10 seconds. -;; -;; XEmacs users may want to change the default timeouts for -;; `speedbar-update-speed' to something longer as XEmacs doesn't have -;; idle timers, the speedbar timer keeps going off arbitrarilly while -;; you're typing. It's quite pesky. -;; -;; Users of emacs previous to to v 19.31 (when idle timers -;; where introduced) will not have speedbar updating automatically. -;; Use "r" to refresh the display after changing directories. -;; Remember, do not interrupt the stealthy updates or you display may -;; not be completely refreshed. -;; -;; See optional file `speedbspec.el' for additional configurations -;; which allow speedbar to create specialized lists for special modes -;; that are not file-related. -;; -;; See optional file `speedbcfg.el' for interactive buffers -;; allowing simple configuration of colors and features of speedbar. -;; -;; AUC-TEX users: The imenu tags for AUC-TEX mode don't work very -;; well. Use the imenu keywords from tex-mode.el for better results. -;; -;; This file requires the library package assoc (association lists) - -;;; Speedbar updates can be found at: -;; ftp://ftp.ultranet.com/pub/zappo/speedbar*.tar.gz -;; - -;;; Change log: -;; 0.1 Initial Revision -;; 0.2 Fixed problem with x-pointer-shape causing future frames not -;; to be created. -;; Fixed annoying habit of `speedbar-update-contents' to make -;; it possible to accidentally kill the speedbar buffer. -;; Clicking directory names now only changes the contents of -;; the speedbar, and does not cause a dired mode to appear. -;; Clicking the <+> next to the directory does cause dired to -;; be run. -;; Added XEmacs support, which means timer support moved to a -;; platform independant call. -;; Added imenu support. Now modes are supported by imenu -;; first, and etags only if the imenu call doesn't work. -;; Imenu is a little faster than etags, and is more emacs -;; friendly. -;; Added more user control variables described in the commentary. -;; Added smart recentering when nodes are opened and closed. -;; 0.3 x-pointer-shape fixed for emacs 19.35, so I put that check in. -;; Added invisible codes to the beginning of each line. -;; Added list aproach to node expansion for easier addition of new -;; types of things to expand by -;; Added multi-level path name support -;; Added multi-level tag name support. -;; Only mouse-2 is now used for node expansion -;; Added keys e + - to edit expand, and contract node lines -;; Added longer legal file regexp for all those modes which support -;; imenu. (pascal, fortran90, ada, pearl) -;; Added pascal support to etags from Dave Penkler <dave_penkler@grenoble.hp.com> -;; Fixed centering algorithm -;; Tried to choose background independent colors. Made more robust. -;; Rearranged code into a more logical order -;; 0.3.1 Fixed doc & broken keybindings -;; Added mode hooks. -;; Improved color selection to be background mode smart -;; `nil' passed to `speedbar-frame-mode' now toggles the frame as -;; advertised in the doc string -;; 0.4a Added modified patch from Dan Schmidt <dfan@lglass.com> allowing a -;; directory cache to be maintained speeding up revisiting of files. -;; Default raise-lower behavior is now off by default. -;; Added some menu items for edit expand and contract. -;; Pre 19.31 emacsen can run without idle timers. -;; Added some patch information from Farzin Guilak <farzin@protocol.com> -;; adding xemacs specifics, and some etags upgrades. -;; Added ability to set a faces symbol-value to a string -;; representing the desired foreground color. (idea from -;; Farzin Guilak, but implemented differently) -;; Fixed problem with 1 character buttons. -;; Added support for new Imenu marker technique. -;; Added `speedbar-load-hooks' for things to run only once on -;; load such as updating one of the many lists. -;; Added `speedbar-supported-extension-expressions' which is a -;; list of extensions that speedbar will tag. This variable -;; should only be updated with `speedbar-add-supported-extension' -;; Moved configure dialog support to a separate file so -;; speedbar is not dependant on eieio to run -;; Fixed list-contraction problem when the item was at the end -;; of a sublist. -;; Fixed XEmacs multi-frame timer selecting bug problem. -;; Added `speedbar-ignored-modes' which is a list of major modes -;; speedbar will not follow when it is displayed in the selected frame -;; 0.4 When the file being edited is not in the list, and is a file -;; that should be in the list, the speedbar cache is replaced. -;; Temp buffers are now shown in the attached frame not the -;; speedbar frame -;; New variables `speedbar-vc-*' and `speedbar-stealthy-function-list' -;; added. `speedbar-update-current-file' is now a member of -;; the stealthy list. New function `speedbar-check-vc' will -;; examine each file and mark it if it is checked out. To -;; add new version control types, override the function -;; `speedbar-this-file-in-vc' and `speedbar-vc-check-dir-p'. -;; The stealth list is interruptible so that long operations -;; do not interrupt someones editing flow. Other long -;; speedbar updates will be added to the stealthy list in the -;; future should interesting ones be needed. -;; Added many new functions including: -;; `speedbar-item-byte-compile' `speedbar-item-load' -;; `speedbar-item-copy' `speedbar-item-rename' `speedbar-item-delete' -;; and `speedbar-item-info' -;; If the user kills the speedbar buffer in some way, the frame will -;; be removed. -;; 0.4.1 Bug fixes -;; <mark.jeffries@nomura.co.uk> added `speedbar-update-flag', -;; XEmacs fixes for menus, and tag sorting, and quit key. -;; Modeline now updates itself based on window-width. -;; Frame is cached when closed to make pulling it up again faster. -;; Speedbars window is now marked as dedicated. -;; Added bindings: <grossjoh@charly.informatik.uni-dortmund.de> -;; Long directories are now span multiple lines autmoatically -;; Added `speedbar-directory-button-trim-method' to specify how to -;; sorten the directory button to fit on the screen. -;; 0.4.2 Add one level of full-text cache. -;; Add `speedbar-get-focus' to switchto/raise the speedbar frame. -;; Editing thing-on-line will auto-raise the attached frame. -;; Bound `U' to `speedbar-up-directory' command. -;; Refresh will now maintain all subdirectories that were open -;; when the refresh was requested. (This does not include the -;; tags, only the directories) -;; 0.4.3 Bug fixes -;; 0.4.4 Added `speedbar-ignored-path-expressions' and friends. -;; Configuration menu items not displayed if dialog-mode not present -;; Speedbar buffer now starts with a space, and is not deleted -;; ewhen the speedbar frame is closed. This prevents the invisible -;; frame from preventing buffer switches with other buffers. -;; Fixed very bad bug in the -add-[extension|path] functions. -;; Added `speedbar-find-file-in-frame' which will always pop up a frame -;; that is already display a buffer selected in the speedbar buffer. -;; Added S-mouse2 as "power click" for always poping up a new frame. -;; and always rescanning with imenu (ditching the imenu cache), and -;; always rescanning directories. -;; 0.4.5 XEmacs bugfixes and enhancements. -;; Window Title simplified. -;; 0.4.6 Fixed problems w/ dedicated minibuffer frame. -;; Fixed errors reported by checkdoc. -;; 0.5 Mode-specific contents added. Controlled w/ the variable -;; `speedbar-mode-specific-contents-flag'. See speedbspec -;; for info on enabling this feature. -;; `speedbar-load-hook' name change and pointer check against -;; major-mode. Suggested by Sam Steingold <sds@ptc.com> -;; Quit auto-selects the attached frame. -;; Ranamed `speedbar-do-updates' to `speedbar-update-flag' -;; Passes checkdoc. - -;;; TODO: -;; 1) More functions to create buttons and options -;; 2) filtering algoritms to reduce the number of tags/files displayed. -;; 3) Timeout directories we haven't visited in a while. -;; 4) Remeber tags when refreshing the display. (Refresh tags too?) -;; 5) More 'special mode support. -;; 6) Smart way to auto-expand instead of directory switch - -;;; Code: -(require 'assoc) -(require 'easymenu) - -(defvar speedbar-xemacsp (string-match "XEmacs" emacs-version) - "Non-nil if we are running in the XEmacs environment.") - -(defvar speedbar-initial-expansion-list - '(speedbar-directory-buttons speedbar-default-directory-list) - "List of functions to call to fill in the speedbar buffer. -Whenever a top level update is issued all functions in this list are -run. These functions will always get the default directory to use -passed in as the first parameter, and a 0 as the second parameter. -The 0 indicates the uppermost indentation level. They must assume -that the cursor is at the position where they start inserting -buttons.") - -(defvar speedbar-stealthy-function-list - '(speedbar-update-current-file speedbar-check-vc) - "List of functions to periodically call stealthily. -Each function must return nil if interrupted, or t if completed. -Stealthy functions which have a single operation should always return -t. Functions which take a long time should maintain a state (where -they are in their speedbar related calculations) and permit -interruption. See `speedbar-check-vc' as a good example.") - -(defvar speedbar-mode-specific-contents-flag t - "*Non-nil means speedbar will show specail-mode contents. -This permits some modes to create customized contents for the speedbar -frame.") - -(defvar speedbar-special-mode-expansion-list nil - "Mode specific list of functions to call to fill in speedbar. -Some modes, such as Info or RMAIL, do not relate quite as easily into -a simple list of files. When this variable is non-nil and buffer-local, -then these functions are used, creating specialized contents. These -functions are called each time the speedbar timer is called. This -allows a mode to update it's contents regularly. - - Each function is called with the default and frame belonging to -speedbar, and with one parameter; the buffer requesting -the speedbar display.") - -(defvar speedbar-load-hook nil - "Hooks run when speedbar is loaded.") - -(defvar speedbar-desired-buffer nil - "Non-nil when speedbar is showing buttons specific a special mode. -In this case it is the originating buffer.") - -(defvar speedbar-show-unknown-files nil - "*Non-nil show files we can't expand with a ? in the expand button. -nil means don't show the file in the list.") - -;; XEmacs timers aren't based on idleness. Therefore tune it down a little -;; or suffer mightilly! -(defvar speedbar-update-speed (if speedbar-xemacsp 5 1) - "*Idle time in seconds needed before speedbar will update itself. -Updates occur to allow speedbar to display directory information -relevant to the buffer you are currently editing.") -(defvar speedbar-navigating-speed 10 - "*Idle time to wait after navigation commands in speedbar are executed. -Navigation commands included expanding/contracting nodes, and moving -between different directories.") - -(defvar speedbar-frame-parameters (list - ;; XEmacs fails to delete speedbar - ;; if minibuffer is off. - ;(cons 'minibuffer - ; (if speedbar-xemacsp t nil)) - ;; The above behavior seems to have fixed - ;; itself somewhere along the line. - ;; let me know if any problems arise. - '(minibuffer . nil) - '(width . 20) - '(scroll-bar-width . 10) - '(border-width . 0) - '(unsplittable . t) ) - "*Parameters to use when creating the speedbar frame. -Parameters not listed here which will be added automatically are -`height' which will be initialized to the height of the frame speedbar -is attached to. To add more frame defaults, `cons' new alist members -onto this variable through the `speedbar-load-hook'") - -(defvar speedbar-use-imenu-flag (stringp (locate-library "imenu")) - "*Non-nil means use imenu for file parsing. nil to use etags. -XEmacs doesn't support imenu, therefore the default is to use etags -instead. Etags support is not as robust as imenu support.") - -(defvar speedbar-sort-tags nil - "*If Non-nil, sort tags in the speedbar display. (Etags only) -See imenu.el source for how imenu does sorting.") - -(defvar speedbar-directory-button-trim-method 'span - "*Indicates how the directory button will be displayed. -Possible values are: - 'span - span large directories over multiple lines. - 'trim - trim large directories to only show the last few. - nil - no trimming.") - -(defvar speedbar-before-delete-hook nil - "*Hooks called before deleting the speedbar frame.") - -(defvar speedbar-mode-hook nil - "*Hooks called after creating a speedbar buffer.") - -(defvar speedbar-timer-hook nil - "*Hooks called after running the speedbar timer function.") - -(defvar speedbar-verbosity-level 1 - "*Verbosity level of the speedbar. 0 means say nothing. -1 means medium level verbosity. 2 and higher are higher levels of -verbosity.") - -(defvar speedbar-vc-indicator " *" - "*Text used to mark files which are currently checked out. -Currently only RCS is supported. Other version control systems can be -added by examining the function `speedbar-this-file-in-vc' and -`speedbar-vc-check-dir-p'") - -(defvar speedbar-vc-do-check t - "*Non-nil check all files in speedbar to see if they have been checked out. -Any file checked out is marked with `speedbar-vc-indicator'") - -(defvar speedbar-vc-to-do-point nil - "Local variable maintaining the current version control check position.") - -(defvar speedbar-ignored-modes nil - "*List of major modes which speedbar will not switch directories for.") - -(defvar speedbar-ignored-path-expressions - '("/log/$") - "*List of regular expressions matching directories speedbar will ignore. -They should included paths to directories which are notoriously very -large and take a long time to load in. Use the function -`speedbar-add-ignored-path-regexp' to add new items to this list after -speedbar is loaded. You may place anything you like in this list -before speedbar has been loaded.") - -(defvar speedbar-file-unshown-regexp - (let ((nstr "") (noext completion-ignored-extensions)) - (while noext - (setq nstr (concat nstr (regexp-quote (car noext)) "$" - (if (cdr noext) "\\|" "")) - noext (cdr noext))) - (concat nstr "\\|#[^#]+#$\\|\\.\\.?$")) - "*Regexp matching files we don't want displayed in a speedbar buffer. -It is generated from the variable `completion-ignored-extensions'") - -(defvar speedbar-supported-extension-expressions - (append '(".[CcHh]\\(++\\|pp\\|c\\|h\\)?" ".tex\\(i\\(nfo\\)?\\)?" - ".el" ".emacs" ".p" ".java") - (if speedbar-use-imenu-flag - '(".f90" ".ada" ".pl" ".tcl" ".m" - "Makefile\\(\\.in\\)?"))) - "*List of regular expressions which will match files supported by tagging. -Do not prefix the `.' char with a double \\ to quote it, as the period -will be stripped by a simplified optimizer when compiled into a -singular expression. This variable will be turned into -`speedbar-file-regexp' for use with speedbar. You should use the -function `speedbar-add-supported-extension' to add a new extension at -runtime, or use the configuration dialog to set it in your .emacs -file.") - -(defun speedbar-extension-list-to-regex (extlist) - "Takes EXTLIST, a list of extensions and transforms it into regexp. -All the preceding . are stripped for an optimized expression starting -with . followed by extensions, followed by full-filenames." - (let ((regex1 nil) (regex2 nil)) - (while extlist - (if (= (string-to-char (car extlist)) ?.) - (setq regex1 (concat regex1 (if regex1 "\\|" "") - (substring (car extlist) 1))) - (setq regex2 (concat regex2 (if regex2 "\\|" "") (car extlist)))) - (setq extlist (cdr extlist))) - ;; concat all the sub-exressions together, making sure all types - ;; of parts exist during concatination. - (concat "\\(" - (if regex1 (concat "\\(\\.\\(" regex1 "\\)\\)") "") - (if (and regex1 regex2) "\\|" "") - (if regex2 (concat "\\(" regex2 "\\)") "") - "\\)$"))) - -(defvar speedbar-ignored-path-regexp - (speedbar-extension-list-to-regex speedbar-ignored-path-expressions) - "Regular expression matching paths speedbar will not switch to. -Created from `speedbar-ignored-path-expressions' with the function -`speedbar-extension-list-to-regex' (A misnamed function in this case.) -Use the function `speedbar-add-ignored-path-regexp' to modify this -variable.") - -(defvar speedbar-file-regexp - (speedbar-extension-list-to-regex speedbar-supported-extension-expressions) - "Regular expression matching files we know how to expand. -Created from `speedbar-supported-extension-expression' with the -function `speedbar-extension-list-to-regex'") - -(defun speedbar-add-supported-extension (extension) - "Add EXTENSION as a new supported extension for speedbar tagging. -This should start with a `.' if it is not a complete file name, and -the dot should NOT be quoted in with \\. Other regular expression -matchers are allowed however. EXTENSION may be a single string or a -list of strings." - (if (not (listp extension)) (setq extension (list extension))) - (while extension - (if (member (car extension) speedbar-supported-extension-expressions) - nil - (setq speedbar-supported-extension-expressions - (cons (car extension) speedbar-supported-extension-expressions))) - (setq extension (cdr extension))) - (setq speedbar-file-regexp (speedbar-extension-list-to-regex - speedbar-supported-extension-expressions))) - -(defun speedbar-add-ignored-path-regexp (path-expression) - "Add PATH-EXPRESSION as a new ignored path for speedbar tracking. -This function will modify `speedbar-ignored-path-regexp' and add -PATH-EXPRESSION to `speedbar-ignored-path-expressions'." - (if (not (listp path-expression)) - (setq path-expression (list path-expression))) - (while path-expression - (if (member (car path-expression) speedbar-ignored-path-expressions) - nil - (setq speedbar-ignored-path-expressions - (cons (car path-expression) speedbar-ignored-path-expressions))) - (setq path-expression (cdr path-expression))) - (setq speedbar-ignored-path-regexp (speedbar-extension-list-to-regex - speedbar-ignored-path-expressions))) - -(defvar speedbar-update-flag (or (not (fboundp 'run-with-idle-timer)) - (not (fboundp 'start-itimer))) - "*Non-nil means to automatically update the display. -When this is nil then speedbar will not follow the attached frame's path. -When speedbar is active, use: - -\\<speedbar-key-map> `\\[speedbar-toggle-updates]' - -to toggle this value.") - -(defvar speedbar-syntax-table nil - "Syntax-table used on the speedbar.") - -(if speedbar-syntax-table - nil - (setq speedbar-syntax-table (make-syntax-table)) - ;; turn off paren matching around here. - (modify-syntax-entry ?\' " " speedbar-syntax-table) - (modify-syntax-entry ?\" " " speedbar-syntax-table) - (modify-syntax-entry ?( " " speedbar-syntax-table) - (modify-syntax-entry ?) " " speedbar-syntax-table) - (modify-syntax-entry ?[ " " speedbar-syntax-table) - (modify-syntax-entry ?] " " speedbar-syntax-table)) - - -(defvar speedbar-key-map nil - "Keymap used in speedbar buffer.") - -(autoload 'speedbar-configure-options "speedbcfg" "Configure speedbar variables" t) -(autoload 'speedbar-configure-faces "speedbcfg" "Configure speedbar faces" t) - -(if speedbar-key-map - nil - (setq speedbar-key-map (make-keymap)) - (suppress-keymap speedbar-key-map t) - - ;; control - (define-key speedbar-key-map "e" 'speedbar-edit-line) - (define-key speedbar-key-map "\C-m" 'speedbar-edit-line) - (define-key speedbar-key-map "+" 'speedbar-expand-line) - (define-key speedbar-key-map "-" 'speedbar-contract-line) - (define-key speedbar-key-map "g" 'speedbar-refresh) - (define-key speedbar-key-map "t" 'speedbar-toggle-updates) - (define-key speedbar-key-map "q" 'speedbar-close-frame) - (define-key speedbar-key-map "U" 'speedbar-up-directory) - - ;; navigation - (define-key speedbar-key-map "n" 'speedbar-next) - (define-key speedbar-key-map "p" 'speedbar-prev) - (define-key speedbar-key-map " " 'speedbar-scroll-up) - (define-key speedbar-key-map "\C-?" 'speedbar-scroll-down) - - ;; After much use, I suddenly desired in my heart to perform dired - ;; style operations since the directory was RIGHT THERE! - (define-key speedbar-key-map "I" 'speedbar-item-info) - (define-key speedbar-key-map "B" 'speedbar-item-byte-compile) - (define-key speedbar-key-map "L" 'speedbar-item-load) - (define-key speedbar-key-map "C" 'speedbar-item-copy) - (define-key speedbar-key-map "D" 'speedbar-item-delete) - (define-key speedbar-key-map "R" 'speedbar-item-rename) - - (if (string-match "XEmacs" emacs-version) - (progn - ;; bind mouse bindings so we can manipulate the items on each line - (define-key speedbar-key-map 'button2 'speedbar-click) - (define-key speedbar-key-map '(shift button2) 'speedbar-power-click) - (define-key speedbar-key-map '(meta button3) 'speedbar-mouse-item-info) - - ;; Setup XEmacs Menubar w/ etags specific items - (defvar speedbar-menu - '("Speed Bar" - ["Run Speedbar" (speedbar-frame-mode 1) t] - ["Refresh" speedbar-refresh t] - ["Allow Auto Updates" - speedbar-toggle-updates - :style toggle - :selected speedbar-update-flag] - "-----" - ["Sort etags in Speedbar" - (speedbar-toggle-etags "sort") - :style toggle - :selected speedbar-sort-tags] - ["Show unknown files" - (speedbar-toggle-etags "show") - :style toggle - :selected speedbar-show-unknown-files] - "-----" - ["Use C++ Tagging" - (speedbar-toggle-etags "-C") - :style toggle - :selected (member "-C" speedbar-fetch-etags-arguments)] - ["Tag preprocessor defs" - (speedbar-toggle-etags "-D") - :style toggle - :selected (not (member "-D" speedbar-fetch-etags-arguments))] - ["Use indentation" - (speedbar-toggle-etags "-S") - :style toggle - :selected (not (member "-S" speedbar-fetch-etags-arguments))])) - - (add-submenu '("Tools") speedbar-menu nil) - - ) - ;; bind mouse bindings so we can manipulate the items on each line - (define-key speedbar-key-map [mouse-2] 'speedbar-click) - ;; This is the power click for poping up new frames - (define-key speedbar-key-map [S-mouse-2] 'speedbar-power-click) - ;; This adds a small unecessary visual effect - ;;(define-key speedbar-key-map [down-mouse-2] 'speedbar-quick-mouse) - (define-key speedbar-key-map [M-mouse-2] 'speedbar-mouse-item-info) - - ;; disable all menus - we don't have a lot of space to play with - ;; in such a skinny frame. This will cleverly find and nuke some - ;; user-defined menus as well if they are there. Too bad it - ;; rely's on the structure of a keymap to work. - (let ((k (lookup-key global-map [menu-bar]))) - (while k - (if (and (listp (car k)) (listp (cdr (car k)))) - (define-key speedbar-key-map (vector 'menu-bar (car (car k))) - 'undefined)) - (setq k (cdr k)))) - - ;; This lets the user scroll as if we had a scrollbar... well maybe not - (define-key speedbar-key-map [mode-line mouse-2] 'speedbar-mouse-hscroll) - )) - -(defvar speedbar-easymenu-definition-base - '("Speedbar" - ["Update" speedbar-refresh t] - ["Auto Update" speedbar-toggle-updates - :style toggle :selected speedbar-update-flag] - ) - "Base part of the speedbar menu.") - -(defvar speedbar-easymenu-definition-special - '(["Edit Item On Line" speedbar-edit-line t] - ["Show All Files" speedbar-toggle-show-all-files - :style toggle :selected speedbar-show-unknown-files] - ["Expand Item" speedbar-expand-line - (save-excursion (beginning-of-line) - (looking-at "[0-9]+: *.\\+. "))] - ["Contract Item" speedbar-contract-line - (save-excursion (beginning-of-line) - (looking-at "[0-9]+: *.-. "))] - "----" - ["Item Information" speedbar-item-info t] - ["Load Lisp File" speedbar-item-load - (save-excursion - (beginning-of-line) - (looking-at "[0-9]+: *\\[[+-]\\] .+\\(\\.el\\)\\( \\*\\)?$"))] - ["Byte Compile File" speedbar-item-byte-compile - (save-excursion - (beginning-of-line) - (looking-at "[0-9]+: *\\[[+-]\\] .+\\(\\.el\\)\\( \\*\\)?$"))] - ["Copy Item" speedbar-item-copy - (save-excursion (beginning-of-line) (looking-at "[0-9]+: *\\["))] - ["Rename Item" speedbar-item-rename - (save-excursion (beginning-of-line) (looking-at "[0-9]+: *[[<]"))] - ["Delete Item" speedbar-item-delete - (save-excursion (beginning-of-line) (looking-at "[0-9]+: *[[<]"))]) - "Additional menu items while in file-mode.") - -(defvar speedbar-easymenu-definition-trailer - '("----" - ["Close" speedbar-close-frame t]) - "Menu items appearing at the end of the speedbar menu.") - -(defvar speedbar-buffer nil - "The buffer displaying the speedbar.") -(defvar speedbar-frame nil - "The frame displaying speedbar.") -(defvar speedbar-cached-frame nil - "The frame that was last created, then removed from the display.") -(defvar speedbar-full-text-cache nil - "The last open directory is saved in it's entirety for ultra-fast switching.") -(defvar speedbar-timer nil - "The speedbar timer used for updating the buffer.") -(defvar speedbar-attached-frame nil - "The frame which started speedbar mode. -This is the frame from which all data displayed in the speedbar is -gathered, and in which files and such are displayed.") - -(defvar speedbar-last-selected-file nil - "The last file which was selected in speedbar buffer.") - -(defvar speedbar-shown-directories nil - "Maintain list of directories simultaneously open in the current speedbar.") - -(defvar speedbar-directory-contents-alist nil - "An association list of directories and their contents. -Each sublist was returned by `speedbar-file-lists'. This list is -maintained to speed up the refresh rate when switching between -directories.") - -(defvar speedbar-power-click nil - "Never set this by hand. Value is t when S-mouse activity occurs.") - - -;;; Mode definitions/ user commands -;; -;;;###autoload -(defalias 'speedbar 'speedbar-frame-mode) -;;;###autoload -(defun speedbar-frame-mode (&optional arg) - "Enable or disable speedbar. Positive ARG means turn on, negative turn off. -nil means toggle. Once the speedbar frame is activated, a buffer in -`speedbar-mode' will be displayed. Currently, only one speedbar is -supported at a time." - (interactive "P") - (if (not window-system) - (error "Speedbar is not useful outside of a windowing environment")) - ;; toggle frame on and off. - (if (not arg) (if speedbar-frame (setq arg -1) (setq arg 1))) - ;; turn the frame off on neg number - (if (and (numberp arg) (< arg 0)) - (progn - (run-hooks 'speedbar-before-delete-hook) - (if (and speedbar-frame (frame-live-p speedbar-frame)) - (if speedbar-xemacsp - (delete-frame speedbar-frame) - (setq speedbar-cached-frame speedbar-frame) - (modify-frame-parameters speedbar-frame '((visibility . nil))))) - (setq speedbar-frame nil) - (speedbar-set-timer nil) - ;; Used to delete the buffer. This has the annoying affect of - ;; preventing whatever took it's place from ever appearing - ;; as the default after a C-x b was typed - ;;(if (bufferp speedbar-buffer) - ;; (kill-buffer speedbar-buffer)) - ) - ;; Set this as our currently attached frame - (setq speedbar-attached-frame (selected-frame)) - ;; Get the frame to work in - (if (frame-live-p speedbar-cached-frame) - (progn - (setq speedbar-frame speedbar-cached-frame) - (modify-frame-parameters speedbar-frame '((visibility . t))) - ;; Get the buffer to play with - (speedbar-mode) - (select-frame speedbar-frame) - (if (not (eq (current-buffer) speedbar-buffer)) - (switch-to-buffer speedbar-buffer)) - (set-window-dedicated-p (selected-window) t) - (raise-frame speedbar-frame) - (speedbar-set-timer speedbar-update-speed) - ) - (if (frame-live-p speedbar-frame) - (raise-frame speedbar-frame) - (let ((params (cons (cons 'height (frame-height)) - speedbar-frame-parameters))) - (setq speedbar-frame - (if (or speedbar-xemacsp - (< emacs-major-version 20)) ;a bug is fixed in v20 & later - (make-frame params) - (let ((x-pointer-shape x-pointer-top-left-arrow) - (x-sensitive-text-pointer-shape x-pointer-hand2)) - (make-frame params))))) - ;; reset the selection variable - (setq speedbar-last-selected-file nil) - ;; Put the buffer into the frame - (save-window-excursion - ;; Get the buffer to play with - (speedbar-mode) - (select-frame speedbar-frame) - (switch-to-buffer speedbar-buffer) - (set-window-dedicated-p (selected-window) t) - ;; Turn off toolbar and menubar under XEmacs - (if speedbar-xemacsp - (progn - (set-specifier default-toolbar-visible-p - (cons (selected-frame) nil)) - ;; These lines make the menu-bar go away nicely, but - ;; they also cause xemacs much heartache. - ;;(set-specifier menubar-visible-p (cons (selected-frame) nil)) - ;;(make-local-variable 'current-menubar) - ;;(setq current-menubar speedbar-menu) - ;;(add-submenu nil speedbar-menu nil) - ))) - (speedbar-set-timer speedbar-update-speed) - )))) - -(defun speedbar-close-frame () - "Turn off a currently active speedbar." - (interactive) - (speedbar-frame-mode -1) - (select-frame speedbar-attached-frame) - (other-frame 0)) - -(defun speedbar-frame-width () - "Return the width of the speedbar frame in characters. -nil if it doesn't exist." - (and speedbar-frame - (frame-live-p speedbar-frame) - (cdr (assoc 'width (frame-parameters speedbar-frame))))) - -(defun speedbar-mode () - "Major mode for managing a display of directories and tags. -\\<speedbar-key-map> -The first line represents the default path of the speedbar frame. -Each directory segment is a button which jumps speedbar's default -directory to that path. Buttons are activated by clicking `\\[speedbar-click]'. -In some situations using `\\[speedbar-power-click]' is a `power click' which will -rescan cached items, or pop up new frames. - -Each line starting with <+> represents a directory. Click on the <+> -to insert the directory listing into the current tree. Click on the -<-> to retract that list. Click on the directory name to go to that -directory as the default. - -Each line starting with [+] is a file. If the variable -`speedbar-show-unknown-files' is t, the lines starting with [?] are -files which don't have imenu support, but are not expressly ignored. -Files are completely ignored if they match `speedbar-file-unshown-regexp' -which is generated from `completion-ignored-extensions'. - -Files with a `*' character after their name are files checked out of a -version control system. (currently only RCS is supported.) New -version control systems can be added by examining the documentation -for `speedbar-this-file-in-vc' and `speedbar-vc-check-dir-p' - -Click on the [+] to display a list of tags from that file. Click on -the [-] to retract the list. Click on the file name to edit the file -in the attached frame. - -If you open tags, you might find a node starting with {+}, which is a -category of tags. Click the {+} to expand the category. Jump-able -tags start with >. Click the name of the tag to go to that position -in the selected file. - -\\{speedbar-key-map}" - ;; NOT interactive - (save-excursion - (setq speedbar-buffer (set-buffer (get-buffer-create " SPEEDBAR"))) - (kill-all-local-variables) - (setq major-mode 'speedbar-mode) - (setq mode-name "Speedbar") - (use-local-map speedbar-key-map) - (set-syntax-table speedbar-syntax-table) - (setq font-lock-keywords nil) ;; no font-locking please - (setq truncate-lines t) - (make-local-variable 'frame-title-format) - (setq frame-title-format "Speedbar") - ;; Set this up special just for the speedbar buffer - (if (null default-minibuffer-frame) - (progn - (make-local-variable 'default-minibuffer-frame) - (setq default-minibuffer-frame speedbar-attached-frame))) - (make-local-variable 'temp-buffer-show-function) - (setq temp-buffer-show-function 'speedbar-temp-buffer-show-function) - (setq kill-buffer-hook '(lambda () (let ((skilling (boundp 'skilling))) - (if skilling - nil - (if (eq (current-buffer) - speedbar-buffer) - (speedbar-frame-mode -1)))))) - (speedbar-set-mode-line-format) - (if (not speedbar-xemacsp) - (setq auto-show-mode nil)) ;no auto-show for Emacs - (run-hooks 'speedbar-mode-hook)) - (speedbar-update-contents) - speedbar-buffer) - -(defun speedbar-set-mode-line-format () - "Set the format of the mode line based on the current speedbar environment. -This gives visual indications of what is up. It EXPECTS the speedbar -frame and window to be the currently active frame and window." - (if (frame-live-p speedbar-frame) - (save-excursion - (set-buffer speedbar-buffer) - (let* ((w (or (speedbar-frame-width) 20)) - (p1 "<<") - (p5 ">>") - (p3 (if speedbar-update-flag "SPEEDBAR" "SLOWBAR")) - (blank (- w (length p1) (length p3) (length p5) - (if line-number-mode 4 0))) - (p2 (if (> blank 0) - (make-string (/ blank 2) ? ) - "")) - (p4 (if (> blank 0) - (make-string (+ (/ blank 2) (% blank 2)) ? ) - "")) - (tf - (if line-number-mode - (list (concat p1 p2 p3) '(line-number-mode " %3l") - (concat p4 p5)) - (list (concat p1 p2 p3 p4 p5))))) - (if (not (equal mode-line-format tf)) - (progn - (setq mode-line-format tf) - (force-mode-line-update))))))) - -(defun speedbar-temp-buffer-show-function (buffer) - "Placed in the variable `temp-buffer-show-function' in `speedbar-mode'. -If a user requests help using \\[help-command] <Key> the temp BUFFER will be -redirected into a window on the attached frame." - (if speedbar-attached-frame (select-frame speedbar-attached-frame)) - (pop-to-buffer buffer nil) - (other-window -1) - (run-hooks 'temp-buffer-show-hook)) - -(defun speedbar-reconfigure-menubar () - "Reconfigure the menu-bar in a speedbar frame. -Different menu items are displayed depending on the current display mode -and the existence of packages." - (let ((km (make-sparse-keymap)) - (cf (selected-frame)) - (md (append speedbar-easymenu-definition-base - (if speedbar-shown-directories - ;; file display mode version - speedbar-easymenu-definition-special - (save-excursion - (select-frame speedbar-attached-frame) - (if (local-variable-p - 'speedbar-easymenu-definition-special) - ;; If bound locally, we can use it - speedbar-easymenu-definition-special))) - ;; The trailer - speedbar-easymenu-definition-trailer))) - (easy-menu-define speedbar-menu-map speedbar-key-map "Speedbar menu" md) - ;; (if speedbar-xemacsp (set-buffer-menubar (list km))) -)) - - -;;; User Input stuff -;; -(defun speedbar-mouse-hscroll (e) - "Read a mouse event E from the mode line, and horizontally scroll. -If the mouse is being clicked on the far left, or far right of the -mode-line. This is only useful for non-XEmacs" - (interactive "e") - (let* ((xp (car (nth 2 (car (cdr e))))) - (cpw (/ (frame-pixel-width) - (frame-width))) - (oc (1+ (/ xp cpw))) - ) - (cond ((< oc 3) - (scroll-left 2)) - ((> oc (- (window-width) 3)) - (scroll-right 2)) - (t (message "Click on the edge of the modeline to scroll left/right"))) - ;;(message "X: Pixel %d Char Pixels %d On char %d" xp cpw oc) - )) - -;;;###autoload -(defun speedbar-get-focus () - "Change frame focus to or from the speedbar frame. -If the selected frame is not speedbar, then speedbar frame is -selected. If the speedbar frame is active, then select the attached frame." - (interactive) - (if (eq (selected-frame) speedbar-frame) - (if (frame-live-p speedbar-attached-frame) - (select-frame speedbar-attached-frame)) - ;; make sure we have a frame - (if (not (frame-live-p speedbar-frame)) (speedbar-frame-mode 1)) - ;; go there - (select-frame speedbar-frame)) - (other-frame 0)) - -(defun speedbar-next (arg) - "Move to the next ARGth line in a speedbar buffer." - (interactive "p") - (forward-line (or arg 1)) - (speedbar-item-info) - (speedbar-position-cursor-on-line)) - -(defun speedbar-prev (arg) - "Move to the previous ARGth line in a speedbar buffer." - (interactive "p") - (speedbar-next (if arg (- arg) -1))) - -(defun speedbar-scroll-up (&optional arg) - "Page down one screen-full of the speedbar, or ARG lines." - (interactive "P") - (scroll-up arg) - (speedbar-position-cursor-on-line)) - -(defun speedbar-scroll-down (&optional arg) - "Page up one screen-full of the speedbar, or ARG lines." - (interactive "P") - (scroll-down arg) - (speedbar-position-cursor-on-line)) - -(defun speedbar-up-directory () - "Keyboard accelerator for moving the default directory up one. -Assumes that the current buffer is the speedbar buffer" - (interactive) - (setq default-directory (expand-file-name (concat default-directory "../"))) - (speedbar-update-contents)) - -;;; Speedbar file activity -;; -(defun speedbar-refresh () - "Refresh the current speedbar display, disposing of any cached data." - (interactive) - (let ((dl speedbar-shown-directories)) - (while dl - (adelete 'speedbar-directory-contents-alist (car dl)) - (setq dl (cdr dl)))) - (if (<= 1 speedbar-verbosity-level) (message "Refreshing speedbar...")) - (speedbar-update-contents) - (speedbar-stealthy-updates) - ;; Reset the timer in case it got really hosed for some reason... - (speedbar-set-timer speedbar-update-speed) - (if (<= 1 speedbar-verbosity-level) (message "Refreshing speedbar...done"))) - -(defun speedbar-item-load () - "Byte compile the item under the cursor or mouse if it is a lisp file." - (interactive) - (let ((f (speedbar-line-file))) - (if (and (file-exists-p f) (string-match "\\.el$" f)) - (if (and (file-exists-p (concat f "c")) - (y-or-n-p (format "Load %sc? " f))) - ;; If the compiled version exists, load that instead... - (load-file (concat f "c")) - (load-file f)) - (error "Not a loadable file...")))) - -(defun speedbar-item-byte-compile () - "Byte compile the item under the cursor or mouse if it is a lisp file." - (interactive) - (let ((f (speedbar-line-file)) - (sf (selected-frame))) - (if (and (file-exists-p f) (string-match "\\.el$" f)) - (progn - (select-frame speedbar-attached-frame) - (byte-compile-file f nil) - (select-frame sf))) - )) - -(defun speedbar-mouse-item-info (event) - "Provide information about what the user clicked on. -This should be bound to a mouse EVENT." - (interactive "e") - (mouse-set-point event) - (speedbar-item-info)) - -(defun speedbar-item-info () - "Display info in the mini-buffer about the button the mouse is over." - (interactive) - (if (not speedbar-shown-directories) - nil - (let* ((item (speedbar-line-file)) - (attr (if item (file-attributes item) nil))) - (if item (message "%s %d %s" (nth 8 attr) (nth 7 attr) item) - (save-excursion - (beginning-of-line) - (looking-at "\\([0-9]+\\):") - (setq item (speedbar-line-path (string-to-int (match-string 1)))) - (if (re-search-forward "> \\([^ ]+\\)$" - (save-excursion(end-of-line)(point)) t) - (progn - (setq attr (get-text-property (match-beginning 1) - 'speedbar-token)) - (message "Tag %s in %s at position %s" - (match-string 1) item (if attr attr 0))) - (message "No special info for this line."))) - )))) - -(defun speedbar-item-copy () - "Copy the item under the cursor. -Files can be copied to new names or places." - (interactive) - (let ((f (speedbar-line-file))) - (if (not f) (error "Not a file.")) - (if (file-directory-p f) - (error "Cannot copy directory.") - (let* ((rt (read-file-name (format "Copy %s to: " - (file-name-nondirectory f)) - (file-name-directory f))) - (refresh (member (expand-file-name (file-name-directory rt)) - speedbar-shown-directories))) - ;; Create the right file name part - (if (file-directory-p rt) - (setq rt - (concat (expand-file-name rt) - (if (string-match "/$" rt) "" "/") - (file-name-nondirectory f)))) - (if (or (not (file-exists-p rt)) - (y-or-n-p (format "Overwrite %s with %s? " rt f))) - (progn - (copy-file f rt t t) - ;; refresh display if the new place is currently displayed. - (if refresh - (progn - (speedbar-refresh) - (if (not (speedbar-goto-this-file rt)) - (speedbar-goto-this-file f)))) - )))))) - -(defun speedbar-item-rename () - "Rename the item under the cursor or mouse. -Files can be renamed to new names or moved to new directories." - (interactive) - (let ((f (speedbar-line-file))) - (if f - (let* ((rt (read-file-name (format "Rename %s to: " - (file-name-nondirectory f)) - (file-name-directory f))) - (refresh (member (expand-file-name (file-name-directory rt)) - speedbar-shown-directories))) - ;; Create the right file name part - (if (file-directory-p rt) - (setq rt - (concat (expand-file-name rt) - (if (string-match "/$" rt) "" "/") - (file-name-nondirectory f)))) - (if (or (not (file-exists-p rt)) - (y-or-n-p (format "Overwrite %s with %s? " rt f))) - (progn - (rename-file f rt t) - ;; refresh display if the new place is currently displayed. - (if refresh - (progn - (speedbar-refresh) - (speedbar-goto-this-file rt) - ))))) - (error "Not a file.")))) - -(defun speedbar-item-delete () - "Delete the item under the cursor. Files are removed from disk." - (interactive) - (let ((f (speedbar-line-file))) - (if (not f) (error "Not a file.")) - (if (y-or-n-p (format "Delete %s? " f)) - (progn - (if (file-directory-p f) - (delete-directory f) - (delete-file f)) - (message "Okie dokie..") - (let ((p (point))) - (speedbar-refresh) - (goto-char p)) - )) - )) - -(defun speedbar-enable-update () - "Enable automatic updating in speedbar via timers." - (interactive) - (setq speedbar-update-flag t) - (speedbar-set-mode-line-format) - (speedbar-set-timer speedbar-update-speed)) - -(defun speedbar-disable-update () - "Disable automatic updating and stop consuming resources." - (interactive) - (setq speedbar-update-flag nil) - (speedbar-set-mode-line-format) - (speedbar-set-timer nil)) - -(defun speedbar-toggle-updates () - "Toggle automatic update for the speedbar frame." - (interactive) - (if speedbar-update-flag - (speedbar-disable-update) - (speedbar-enable-update))) - -(defun speedbar-toggle-show-all-files () - "Toggle display of files speedbar can not tag." - (interactive) - (setq speedbar-show-unknown-files (not speedbar-show-unknown-files)) - (speedbar-refresh)) - -;;; Utility functions -;; -(defun speedbar-set-timer (timeout) - "Unset an old timer (if there is one) and activate a new timer with TIMEOUT. -TIMEOUT is the number of seconds until the speedbar timer is called -again." - (cond - ;; XEmacs - (speedbar-xemacsp - (if speedbar-timer - (progn (delete-itimer speedbar-timer) - (setq speedbar-timer nil))) - (if timeout - (setq speedbar-timer (start-itimer "speedbar" - 'speedbar-timer-fn - timeout - nil)))) - ;; Post 19.31 Emacs - ((fboundp 'run-with-idle-timer) - (if speedbar-timer - (progn (cancel-timer speedbar-timer) - (setq speedbar-timer nil))) - (if timeout - (setq speedbar-timer - (run-with-idle-timer timeout nil 'speedbar-timer-fn)))) - ;; Older or other Emacsen with no timers. Set up so that it's - ;; obvious this emacs can't handle the updates - (t - (setq speedbar-update-flag nil))) - ;; change this if it changed for some reason - (speedbar-set-mode-line-format)) - -(defmacro speedbar-with-writable (&rest forms) - "Allow the buffer to be writable and evaluate FORMS. -Turn read only back on when done." - (list 'let '((speedbar-with-writable-buff (current-buffer))) - '(toggle-read-only -1) - (cons 'progn forms) - '(save-excursion (set-buffer speedbar-with-writable-buff) - (toggle-read-only 1)))) -(put 'speedbar-with-writable 'lisp-indent-function 0) - -(defun speedbar-select-window (buffer) - "Select a window in which BUFFER is show. -If it is not shown, force it to appear in the default window." - (let ((win (get-buffer-window buffer speedbar-attached-frame))) - (if win - (select-window win) - (show-buffer (selected-window) buffer)))) - -(defmacro speedbar-with-attached-buffer (&rest forms) - "Execute FORMS in the attached frame's special buffer. -Optionally select that frame if necessary." - ;; Reset the timer with a new timeout when cliking a file - ;; in case the user was navigating directories, we can cancel - ;; that other timer. - (list - 'progn - '(speedbar-set-timer speedbar-update-speed) - (list - 'let '((cf (selected-frame))) - '(select-frame speedbar-attached-frame) - '(speedbar-select-window speedbar-desired-buffer) - (cons 'progn forms) - '(select-frame cf) - '(speedbar-maybee-jump-to-attached-frame) - ))) - -(defun speedbar-insert-button (text face mouse function - &optional token prevline) - "Insert TEXT as the next logical speedbar button. -FACE is the face to put on the button, MOUSE is the highlight face to use. -When the user clicks on TEXT, FUNCTION is called with the TOKEN parameter. -This function assumes that the current buffer is the speedbar buffer. -If PREVLINE, then put this button on the previous line. - -This is a convenience function for special mode that create their own -specialized speedbar displays." - (goto-char (point-max)) - (if (/= (current-column) 0) (insert "\n")) - (if prevline (progn (delete-char -1) (insert " "))) ;back up if desired... - (let ((start (point))) - (insert text) - (speedbar-make-button start (point) face mouse function token)) - (let ((start (point))) - (insert "\n") - (put-text-property start (point) 'face nil) - (put-text-property start (point) 'mouse-face nil))) - -(defun speedbar-make-button (start end face mouse function &optional token) - "Create a button from START to END, with FACE as the display face. -MOUSE is the mouse face. When this button is clicked on FUNCTION -will be run with the TOKEN parameter (any lisp object)" - (put-text-property start end 'face face) - (put-text-property start end 'mouse-face mouse) - (put-text-property start end 'invisible nil) - (if function (put-text-property start end 'speedbar-function function)) - (if token (put-text-property start end 'speedbar-token token)) - ) - -;;; File button management -;; -(defun speedbar-file-lists (directory) - "Create file lists for DIRECTORY. -The car is the list of directories, the cdr is list of files not -matching ignored headers. Cache any directory files found in -`speedbar-directory-contents-alist' and use that cache before scanning -the file-system" - (setq directory (expand-file-name directory)) - ;; If in powerclick mode, then the directory we are getting - ;; should be rescanned. - (if speedbar-power-click - (adelete 'speedbar-directory-contents-alist directory)) - ;; find the directory, either in the cache, or build it. - (or (cdr-safe (assoc directory speedbar-directory-contents-alist)) - (let ((default-directory directory) - (dir (directory-files directory nil)) - (dirs nil) - (files nil)) - (while dir - (if (not (string-match speedbar-file-unshown-regexp (car dir))) - (if (file-directory-p (car dir)) - (setq dirs (cons (car dir) dirs)) - (setq files (cons (car dir) files)))) - (setq dir (cdr dir))) - (let ((nl (cons (nreverse dirs) (list (nreverse files))))) - (aput 'speedbar-directory-contents-alist directory nl) - nl)) - )) - -(defun speedbar-directory-buttons (directory index) - "Insert a single button group at point for DIRECTORY. -Each directory path part is a different button. If part of the path -matches the user directory ~, then it is replaced with a ~. -INDEX is not used, but is required by the caller." - (let* ((tilde (expand-file-name "~")) - (dd (expand-file-name directory)) - (junk (string-match (regexp-quote tilde) dd)) - (displayme (if junk - (concat "~" (substring dd (match-end 0))) - dd)) - (p (point))) - (if (string-match "^~/?$" displayme) (setq displayme (concat tilde "/"))) - (insert displayme) - (save-excursion - (goto-char p) - (while (re-search-forward "\\([^/]+\\)/" nil t) - (speedbar-make-button (match-beginning 1) (match-end 1) - 'speedbar-directory-face - 'speedbar-highlight-face - 'speedbar-directory-buttons-follow - (if (= (match-beginning 1) p) - (expand-file-name "~/") ;the tilde - (buffer-substring-no-properties - p (match-end 0))))) - ;; Nuke the beginning of the directory if it's too long... - (cond ((eq speedbar-directory-button-trim-method 'span) - (beginning-of-line) - (let ((ww (or (speedbar-frame-width) 20))) - (move-to-column ww nil) - (while (>= (current-column) ww) - (re-search-backward "/" nil t) - (if (<= (current-column) 2) - (progn - (re-search-forward "/" nil t) - (if (< (current-column) 4) - (re-search-forward "/" nil t)) - (forward-char -1))) - (if (looking-at "/?$") - (beginning-of-line) - (insert "/...\n ") - (move-to-column ww nil))))) - ((eq speedbar-directory-button-trim-method 'trim) - (end-of-line) - (let ((ww (or (speedbar-frame-width) 20)) - (tl (current-column))) - (if (< ww tl) - (progn - (move-to-column (- tl ww)) - (if (re-search-backward "/" nil t) - (progn - (delete-region (point-min) (point)) - (insert "$") - ))))))) - ) - (if (string-match "^/[^/]+/$" displayme) - (progn - (insert " ") - (let ((p (point))) - (insert "<root>") - (speedbar-make-button p (point) - 'speedbar-directory-face - 'speedbar-highlight-face - 'speedbar-directory-buttons-follow - "/")))) - (end-of-line) - (insert-char ?\n 1 nil))) - -(defun speedbar-make-tag-line (exp-button-type - exp-button-char exp-button-function - exp-button-data - tag-button tag-button-function tag-button-data - tag-button-face depth) - "Create a tag line with EXP-BUTTON-TYPE for the small expansion button. -This is the button that expands or contracts a node (if applicable), -and EXP-BUTTON-CHAR the character in it (+, -, ?, etc). EXP-BUTTON-FUNCTION -is the function to call if it's clicked on. Button types are -'bracket, 'angle, 'curly, or nil. EXP-BUTTON-DATA is extra data -attached to the text forming the expansion button. - -Next, TAG-BUTTON is the text of the tag. TAG-BUTTON-FUNCTION is the -function to call if clicked on, and TAG-BUTTON-DATA is the data to -attach to the text field (such a tag positioning, etc). -TAG-BUTTON-FACE is a face used for this type of tag. - -Lastly, DEPTH shows the depth of expansion. - -This function assumes that the cursor is in the speedbar window at the -position to insert a new item, and that the new item will end with a CR" - (let ((start (point)) - (end (progn - (insert (int-to-string depth) ":") - (point)))) - (put-text-property start end 'invisible t) - ) - (insert-char ? depth nil) - (put-text-property (- (point) depth) (point) 'invisible nil) - (let* ((exp-button (cond ((eq exp-button-type 'bracket) "[%c]") - ((eq exp-button-type 'angle) "<%c>") - ((eq exp-button-type 'curly) "{%c}") - (t ">"))) - (buttxt (format exp-button exp-button-char)) - (start (point)) - (end (progn (insert buttxt) (point))) - (bf (if exp-button-type 'speedbar-button-face nil)) - (mf (if exp-button-function 'speedbar-highlight-face nil)) - ) - (speedbar-make-button start end bf mf exp-button-function exp-button-data) - ) - (insert-char ? 1 nil) - (put-text-property (1- (point)) (point) 'invisible nil) - (let ((start (point)) - (end (progn (insert tag-button) (point)))) - (insert-char ?\n 1 nil) - (put-text-property (1- (point)) (point) 'invisible nil) - (speedbar-make-button start end tag-button-face - (if tag-button-function 'speedbar-highlight-face nil) - tag-button-function tag-button-data)) -) - -(defun speedbar-change-expand-button-char (char) - "Change the expansion button character to CHAR for the current line." - (save-excursion - (beginning-of-line) - (if (re-search-forward ":\\s-*.\\([-+?]\\)" (save-excursion (end-of-line) - (point)) t) - (speedbar-with-writable - (goto-char (match-beginning 1)) - (delete-char 1) - (insert-char char 1 t))))) - - -;;; Build button lists -;; -(defun speedbar-insert-files-at-point (files level) - "Insert list of FILES starting at point, and indenting all files to LEVEL. -Tag expandable items with a +, otherwise a ?. Don't highlight ? as we -don't know how to manage them. The input parameter FILES is a cons -cell of the form ( 'DIRLIST . 'FILELIST )" - ;; Start inserting all the directories - (let ((dirs (car files))) - (while dirs - (speedbar-make-tag-line 'angle ?+ 'speedbar-dired (car dirs) - (car dirs) 'speedbar-dir-follow nil - 'speedbar-directory-face level) - (setq dirs (cdr dirs)))) - (let ((lst (car (cdr files)))) - (while lst - (let* ((known (string-match speedbar-file-regexp (car lst))) - (expchar (if known ?+ ??)) - (fn (if known 'speedbar-tag-file nil))) - (if (or speedbar-show-unknown-files (/= expchar ??)) - (speedbar-make-tag-line 'bracket expchar fn (car lst) - (car lst) 'speedbar-find-file nil - 'speedbar-file-face level))) - (setq lst (cdr lst))))) - -(defun speedbar-default-directory-list (directory index) - "Insert files for DIRECTORY with level INDEX at point." - (speedbar-insert-files-at-point - (speedbar-file-lists directory) index) - (speedbar-reset-scanners) - (if (= index 0) - ;; If the shown files variable has extra directories, then - ;; it is our responsibility to redraw them all - ;; Luckilly, the nature of inserting items into this list means - ;; that by reversing it, we can easilly go in the right order - (let ((sf (cdr (reverse speedbar-shown-directories)))) - (setq speedbar-shown-directories - (list (expand-file-name default-directory))) - ;; exand them all as we find them - (while sf - (if (speedbar-goto-this-file (car sf)) - (progn - (beginning-of-line) - (if (looking-at "[0-9]+:[ ]*<") - (progn - (goto-char (match-end 0)) - (speedbar-do-function-pointer))) - (setq sf (cdr sf))))) - ))) - -(defun speedbar-insert-generic-list (level lst expand-fun find-fun) - "At LEVEL, insert a generic multi-level alist LST. -Associations with lists get {+} tags (to expand into more nodes) and -those with positions just get a > as the indicator. {+} buttons will -have the function EXPAND-FUN and the token is the CDR list. The token -name will have the function FIND-FUN and not token." - ;; Remove imenu rescan button - (if (string= (car (car lst)) "*Rescan*") - (setq lst (cdr lst))) - ;; insert the parts - (while lst - (cond ((null (car-safe lst)) nil) ;this would be a separator - ((or (numberp (cdr-safe (car-safe lst))) - (markerp (cdr-safe (car-safe lst)))) - (speedbar-make-tag-line nil nil nil nil ;no expand button data - (car (car lst)) ;button name - find-fun ;function - (cdr (car lst)) ;token is position - 'speedbar-tag-face - (1+ level))) - ((listp (cdr-safe (car-safe lst))) - (speedbar-make-tag-line 'curly ?+ expand-fun (cdr (car lst)) - (car (car lst)) ;button name - nil nil 'speedbar-tag-face - (1+ level))) - (t (message "Ooops!"))) - (setq lst (cdr lst)))) - -;;; Timed functions -;; -(defun speedbar-update-contents () - "Generically update the contents of the speedbar buffer." - (interactive) - ;; Set the current special buffer - (setq speedbar-desired-buffer nil) - (if (and speedbar-mode-specific-contents-flag - speedbar-special-mode-expansion-list - (local-variable-p - 'speedbar-special-mode-expansion-list)) - ;(eq (get major-mode 'mode-class 'special))) - (speedbar-update-special-contents) - (speedbar-update-directory-contents))) - -(defun speedbar-update-directory-contents () - "Update the contents of the speedbar buffer based on the current directory." - (let ((cbd (expand-file-name default-directory)) - (funclst speedbar-initial-expansion-list) - (cache speedbar-full-text-cache) - ;; disable stealth during update - (speedbar-stealthy-function-list nil) - (use-cache nil) - ;; Because there is a bug I can't find just yet - (inhibit-quit nil)) - (save-excursion - (set-buffer speedbar-buffer) - ;; If we are updating contents to a where we are, then this is - ;; really a request to update existing contents, so we must be - ;; careful with our text cache! - (if (member cbd speedbar-shown-directories) - (setq cache nil) - ;; If this directory is NOT in the current list of available - ;; paths, then use the cache, and set the cache to our new - ;; value. Make sure to unhighlight the current file, or if we - ;; come back to this directory, it might be a different file - ;; and then we get a mess! - (if (> (point-max) 1) - (progn - (speedbar-clear-current-file) - (setq speedbar-full-text-cache - (cons speedbar-shown-directories (buffer-string))))) - - ;; Check if our new directory is in the list of directories - ;; show in the text-cahce - (if (member cbd (car cache)) - (setq speedbar-shown-directories (car cache) - use-cache t) - ;; default the shown directories to this list... - (setq speedbar-shown-directories (list cbd))) - ) - (setq speedbar-last-selected-file nil) - (speedbar-with-writable - (setq default-directory cbd) - (erase-buffer) - (if use-cache - (insert (cdr cache)) - (while funclst - (funcall (car funclst) cbd 0) - (setq funclst (cdr funclst))))) - (goto-char (point-min)))) - (speedbar-reconfigure-menubar)) - -(defun speedbar-update-special-contents () - "Used the mode-specific variable to fill in the speedbar buffer. -This should only be used by modes classified as special." - (let ((funclst speedbar-special-mode-expansion-list) - (specialbuff (current-buffer))) - (save-excursion - (setq speedbar-desired-buffer specialbuff) - (set-buffer speedbar-buffer) - ;; If we are leaving a directory, cache it. - (if (not speedbar-shown-directories) - ;; Do nothing - nil - ;; Clean up directory maintenance stuff - (speedbar-clear-current-file) - (setq speedbar-full-text-cache - (cons speedbar-shown-directories (buffer-string)) - speedbar-shown-directories nil)) - ;; Now fill in the buffer with our newly found specialized list. - (speedbar-with-writable - (while funclst - ;; We do not erase the buffer because these functions may - ;; decide NOT to update themselves. - (funcall (car funclst) specialbuff) - (setq funclst (cdr funclst)))) - (goto-char (point-min)))) - (speedbar-reconfigure-menubar)) - -(defun speedbar-timer-fn () - "Run whenever emacs is idle to update the speedbar item." - (if (not (and (frame-live-p speedbar-frame) - (frame-live-p speedbar-attached-frame))) - (speedbar-set-timer nil) - (condition-case nil - ;; Save all the match data so that we don't mess up executing fns - (save-match-data - (if (and (frame-visible-p speedbar-frame) speedbar-update-flag) - (let ((af (selected-frame))) - (save-window-excursion - (select-frame speedbar-attached-frame) - ;; make sure we at least choose a window to - ;; get a good directory from - (if (string-match "\\*Minibuf-[0-9]+\\*" (buffer-name)) - (other-window 1)) - ;; Update for special mode all the time! - (if (and speedbar-mode-specific-contents-flag - speedbar-special-mode-expansion-list - (local-variable-p - 'speedbar-special-mode-expansion-list)) - ;(eq (get major-mode 'mode-class 'special))) - (speedbar-update-special-contents) - ;; Update all the contents if directories change! - (if (or (member (expand-file-name default-directory) - speedbar-shown-directories) - (string-match speedbar-ignored-path-regexp - (expand-file-name default-directory)) - (member major-mode speedbar-ignored-modes) - (eq af speedbar-frame) - (not (buffer-file-name))) - nil - (if (<= 1 speedbar-verbosity-level) - (message "Updating speedbar to: %s..." - default-directory)) - (speedbar-update-directory-contents) - (if (<= 1 speedbar-verbosity-level) - (message "Updating speedbar to: %s...done" - default-directory)))) - (select-frame af)) - ;; Now run stealthy updates of time-consuming items - (speedbar-stealthy-updates)))) - ;; errors that might occur - (error (message "Speedbar error!"))) - ;; Reset the timer - (speedbar-set-timer speedbar-update-speed)) - (run-hooks 'speedbar-timer-hook) - ) - - -;;; Stealthy activities -;; -(defun speedbar-stealthy-updates () - "For a given speedbar, run all items in the stealthy function list. -Each item returns t if it completes successfully, or nil if -interrupted by the user." - (let ((l speedbar-stealthy-function-list)) - (unwind-protect - (while (and l (funcall (car l))) - (sit-for 0) - (setq l (cdr l))) - ;(message "Exit with %S" (car l)) - ))) - -(defun speedbar-reset-scanners () - "Reset any variables used by functions in the stealthy list as state. -If new functions are added, their state needs to be updated here." - (setq speedbar-vc-to-do-point t) - ) - -(defun speedbar-clear-current-file () - "Locate the file thought to be current, and unhighlight it." - (save-excursion - (set-buffer speedbar-buffer) - (if speedbar-last-selected-file - (speedbar-with-writable - (goto-char (point-min)) - (if (and - speedbar-last-selected-file - (re-search-forward - (concat " \\(" (regexp-quote speedbar-last-selected-file) - "\\)\\(" (regexp-quote speedbar-vc-indicator) - "\\)?\n") - nil t)) - (put-text-property (match-beginning 1) - (match-end 1) - 'face - 'speedbar-file-face)))))) - -(defun speedbar-update-current-file () - "Find the current file is, and update our visuals to indicate its name. -This is specific to file names. If the file name doesn't show up, but -it should be in the list, then the directory cache needs to be -updated." - (let* ((lastf (selected-frame)) - (newcfd (save-excursion - (select-frame speedbar-attached-frame) - (let ((rf (if (buffer-file-name) - (buffer-file-name) - nil))) - (select-frame lastf) - rf))) - (newcf (if newcfd (file-name-nondirectory newcfd))) - (lastb (current-buffer)) - (sucf-recursive (boundp 'sucf-recursive))) - (if (and newcf - ;; check here, that way we won't refresh to newcf until - ;; its been written, thus saving ourselves some time - (file-exists-p newcf) - (not (string= newcf speedbar-last-selected-file))) - (progn - ;; It is important to select the frame, otherwise the window - ;; we want the cursor to move in will not be updated by the - ;; search-forward command. - (select-frame speedbar-frame) - ;; Remove the old file... - (speedbar-clear-current-file) - ;; now highlight the new one. - (set-buffer speedbar-buffer) - (speedbar-with-writable - (goto-char (point-min)) - (if (re-search-forward - (concat " \\(" (regexp-quote newcf) "\\)\\(" - (regexp-quote speedbar-vc-indicator) - "\\)?\n") nil t) - ;; put the property on it - (put-text-property (match-beginning 1) - (match-end 1) - 'face - 'speedbar-selected-face) - ;; Oops, it's not in the list. Should it be? - (if (and (string-match speedbar-file-regexp newcf) - (string= (file-name-directory newcfd) - (expand-file-name default-directory))) - ;; yes, it is (we will ignore unknowns for now...) - (progn - (speedbar-refresh) - (if (re-search-forward - (concat " \\(" (regexp-quote newcf) "\\)\n") nil t) - ;; put the property on it - (put-text-property (match-beginning 1) - (match-end 1) - 'face - 'speedbar-selected-face))) - ;; if it's not in there now, whatever... - )) - (setq speedbar-last-selected-file newcf)) - (if (not sucf-recursive) - (progn - (forward-line -1) - (speedbar-position-cursor-on-line))) - (set-buffer lastb) - (select-frame lastf) - ))) - ;; return that we are done with this activity. - t) - -;; If it's being used, check for it -(eval-when-compile (or (featurep 'xemacs) (require 'ange-ftp))) - -(defun speedbar-check-vc () - "Scan all files in a directory, and for each see if it's checked out. -See `speedbar-this-file-in-vc' and `speedbar-vc-check-dir-p' for how -to add more types of version control systems." - ;; Check for to-do to be reset. If reset but no RCS is available - ;; then set to nil (do nothing) otherwise, start at the beginning - (save-excursion - (set-buffer speedbar-buffer) - (if (and speedbar-vc-do-check (eq speedbar-vc-to-do-point t) - (speedbar-vc-check-dir-p default-directory) - (not (and (featurep 'ange-ftp) - (string-match (car - (if speedbar-xemacsp - ange-ftp-path-format - ange-ftp-name-format)) - (expand-file-name default-directory))))) - (setq speedbar-vc-to-do-point 0)) - (if (numberp speedbar-vc-to-do-point) - (progn - (goto-char speedbar-vc-to-do-point) - (while (and (not (input-pending-p)) - (re-search-forward "^\\([0-9]+\\):\\s-*\\[[+-]\\] " nil t)) - (setq speedbar-vc-to-do-point (point)) - (if (speedbar-check-vc-this-line) - (speedbar-with-writable - (insert speedbar-vc-indicator)))) - (if (input-pending-p) - ;; return that we are incomplete - nil - ;; we are done, set to-do to nil - (setq speedbar-vc-to-do-point nil) - ;; and return t - t)) - t))) - -(defun speedbar-check-vc-this-line () - "Return t if the file on this line is check of of a version control system. -The one caller-requirement is that the last regexp matching operation -has the current depth stored in (MATCHSTRING 1), and that the cursor -is right in front of the file name." - (let* ((d (string-to-int (match-string 1))) - (f (speedbar-line-path d)) - (fn (buffer-substring-no-properties - (point) (progn (end-of-line) (point)))) - (fulln (concat f fn))) - (if (<= 2 speedbar-verbosity-level) - (message "Speedbar vc check...%s" fulln)) - (and (file-writable-p fulln) - (speedbar-this-file-in-vc f fn)))) - -(defun speedbar-vc-check-dir-p (path) - "Return t if we should bother checking PATH for version control files. -This can be overloaded to add new types of version control systems." - (or - (file-exists-p (concat path "RCS/")) - ;; If SCCS is added in `speedbar-this-file-in-vc' - ;; (file-exists-p (concat path "SCCS/")) - ;; (file-exists-p (getenv "SCCSPATHTHINGIDONTREMEMBER")) - )) - -(defun speedbar-this-file-in-vc (path name) - "Check to see if the file in PATH with NAME is in a version control system. -You can add new VC systems by overriding this function. You can -optimize this function by overriding it and only doing those checks -that will occur on your system." - (or - (file-exists-p (concat path "RCS/" name ",v")) - ;; Is this right? I don't recall - ;;(file-exists-p (concat path "SCCS/," fn)) - ;;(file-exists-p (concat (getenv "SCCSPATHTHING") "/SCCS/," fn)) - )) - -;;; Clicking Activity -;; -(defun speedbar-quick-mouse (e) - "Since mouse events are strange, this will keep the mouse nicely positioned. -This should be bound to mouse event E." - (interactive "e") - (mouse-set-point e) - (speedbar-position-cursor-on-line) - ) - -(defun speedbar-position-cursor-on-line () - "Position the cursor on a line." - (let ((oldpos (point))) - (beginning-of-line) - (if (looking-at "[0-9]+:\\s-*..?.? ") - (goto-char (1- (match-end 0))) - (goto-char oldpos)))) - -(defun speedbar-power-click (e) - "Activate any speedbar button as a power click. -This should be bound to mouse event E." - (interactive "e") - (let ((speedbar-power-click t)) - (speedbar-click e))) - -(defun speedbar-click (e) - "Activate any speedbar buttons where the mouse is clicked. -This must be bound to a mouse event. A button is any location of text -with a mouse face that has a text property called `speedbar-function'. -This should be bound to mouse event E." - (interactive "e") - (mouse-set-point e) - (speedbar-do-function-pointer) - (speedbar-quick-mouse e)) - -(defun speedbar-do-function-pointer () - "Look under the cursor and examine the text properties. -From this extract the file/tag name, token, indentation level and call -a function if appropriate" - (let* ((fn (get-text-property (point) 'speedbar-function)) - (tok (get-text-property (point) 'speedbar-token)) - ;; The 1-,+ is safe because scaning starts AFTER the point - ;; specified. This lets the search include the character the - ;; cursor is on. - (tp (previous-single-property-change - (1+ (point)) 'speedbar-function)) - (np (next-single-property-change - (point) 'speedbar-function)) - (txt (buffer-substring-no-properties (or tp (point-min)) - (or np (point-max)))) - (dent (save-excursion (beginning-of-line) - (string-to-number - (if (looking-at "[0-9]+") - (buffer-substring-no-properties - (match-beginning 0) (match-end 0)) - "0"))))) - ;;(message "%S:%S:%S:%s" fn tok txt dent) - (and fn (funcall fn txt tok dent))) - (speedbar-position-cursor-on-line)) - -;;; Reading info from the speedbar buffer -;; -(defun speedbar-line-file (&optional p) - "Retrieve the file or whatever from the line at P point. -The return value is a string representing the file. If it is a -directory, then it is the directory name." - (save-excursion - (save-match-data - (beginning-of-line) - (if (looking-at (concat - "\\([0-9]+\\): *[[<][-+][]>] \\([^ \n]+\\)\\(" - (regexp-quote speedbar-vc-indicator) - "\\)?")) - (let* ((depth (string-to-int (match-string 1))) - (path (speedbar-line-path depth)) - (f (match-string 2))) - (concat path f)) - nil)))) - -(defun speedbar-goto-this-file (file) - "If FILE is displayed, goto this line and return t. -Otherwise do not move and return nil." - (let ((path (substring (file-name-directory (expand-file-name file)) - (length (expand-file-name default-directory)))) - (dest (point))) - (save-match-data - (goto-char (point-min)) - ;; scan all the directories - (while (and path (not (eq path t))) - (if (string-match "^/?\\([^/]+\\)" path) - (let ((pp (match-string 1 path))) - (if (save-match-data - (re-search-forward (concat "> " (regexp-quote pp) "$") - nil t)) - (setq path (substring path (match-end 1))) - (setq path nil))) - (setq path t))) - ;; find the file part - (if (or (not path) (string= (file-name-nondirectory file) "")) - ;; only had a dir part - (if path - (progn - (speedbar-position-cursor-on-line) - t) - (goto-char dest) nil) - ;; find the file part - (let ((nd (file-name-nondirectory file))) - (if (re-search-forward - (concat "] \\(" (regexp-quote nd) - "\\)\\(" (regexp-quote speedbar-vc-indicator) "\\)?$") - nil t) - (progn - (speedbar-position-cursor-on-line) - t) - (goto-char dest) - nil)))))) - -(defun speedbar-line-path (depth) - "Retrieve the pathname associated with the current line. -This may require traversing backwards from DEPTH and combining the default -directory with these items." - (save-excursion - (save-match-data - (let ((path nil)) - (setq depth (1- depth)) - (while (/= depth -1) - (if (not (re-search-backward (format "^%d:" depth) nil t)) - (error "Error building path of tag") - (cond ((looking-at "[0-9]+:\\s-*<->\\s-+\\([^\n]+\\)$") - (setq path (concat (buffer-substring-no-properties - (match-beginning 1) (match-end 1)) - "/" - path))) - ((looking-at "[0-9]+:\\s-*[-]\\s-+\\([^\n]+\\)$") - ;; This is the start of our path. - (setq path (buffer-substring-no-properties - (match-beginning 1) (match-end 1)))))) - (setq depth (1- depth))) - (if (and path - (string-match (concat (regexp-quote speedbar-vc-indicator) "$") - path)) - (setq path (substring path 0 (match-beginning 0)))) - (concat default-directory path))))) - -(defun speedbar-edit-line () - "Edit whatever tag or file is on the current speedbar line." - (interactive) - (save-excursion - (beginning-of-line) - ;; If this fails, then it is a non-standard click, and as such, - ;; perfectly allowed. - (re-search-forward "[]>}] [a-zA-Z0-9]" - (save-excursion (end-of-line) (point)) t) - (speedbar-do-function-pointer))) - -(defun speedbar-expand-line () - "Expand the line under the cursor." - (interactive) - (beginning-of-line) - (re-search-forward ":\\s-*.\\+. " (save-excursion (end-of-line) (point))) - (forward-char -2) - (speedbar-do-function-pointer)) - -(defun speedbar-contract-line () - "Contract the line under the cursor." - (interactive) - (beginning-of-line) - (re-search-forward ":\\s-*.-. " (save-excursion (end-of-line) (point))) - (forward-char -2) - (speedbar-do-function-pointer)) - -(defun speedbar-maybee-jump-to-attached-frame () - "Jump to the attached frame ONLY if this was not a mouse event." - (if (numberp last-input-char) - (progn - (select-frame speedbar-attached-frame) - (other-frame 0)))) - -(defun speedbar-find-file (text token indent) - "Speedbar click handler for filenames. -TEXT, the file will be displayed in the attached frame. -TOKEN is unused, but required by the click handler. INDENT is the -current indentation level." - (let ((cdd (speedbar-line-path indent))) - (speedbar-find-file-in-frame (concat cdd text)) - (speedbar-stealthy-updates) - ;; Reset the timer with a new timeout when cliking a file - ;; in case the user was navigating directories, we can cancel - ;; that other timer. - (speedbar-set-timer speedbar-update-speed)) - (speedbar-maybee-jump-to-attached-frame)) - -(defun speedbar-dir-follow (text token indent) - "Speedbar click handler for directory names. -Clicking a directory will cause the speedbar to list files in the -the subdirectory TEXT. TOKEN is an unused requirement. The -subdirectory chosen will be at INDENT level." - (setq default-directory - (concat (expand-file-name (concat (speedbar-line-path indent) text)) - "/")) - ;; Because we leave speedbar as the current buffer, - ;; update contents will change directory without - ;; having to touch the attached frame. - (speedbar-update-contents) - (speedbar-set-timer speedbar-navigating-speed) - (setq speedbar-last-selected-file nil) - (speedbar-stealthy-updates)) - -(defun speedbar-delete-subblock (indent) - "Delete text from point to indentation level INDENT or greater. -Handles end-of-sublist smartly." - (speedbar-with-writable - (save-excursion - (end-of-line) (forward-char 1) - (while (and (not (save-excursion - (re-search-forward (format "^%d:" indent) - nil t))) - (>= indent 0)) - (setq indent (1- indent))) - (delete-region (point) (if (>= indent 0) - (match-beginning 0) - (point-max)))))) - -(defun speedbar-dired (text token indent) - "Speedbar click handler for directory expand button. -Clicking this button expands or contracts a directory. TEXT is the -button clicked which has either a + or -. TOKEN is the directory to be -expanded. INDENT is the current indentation level." - (cond ((string-match "+" text) ;we have to expand this dir - (setq speedbar-shown-directories - (cons (expand-file-name - (concat (speedbar-line-path indent) token "/")) - speedbar-shown-directories)) - (speedbar-change-expand-button-char ?-) - (speedbar-reset-scanners) - (save-excursion - (end-of-line) (forward-char 1) - (speedbar-with-writable - (speedbar-default-directory-list - (concat (speedbar-line-path indent) token "/") - (1+ indent))))) - ((string-match "-" text) ;we have to contract this node - (speedbar-reset-scanners) - (let ((oldl speedbar-shown-directories) - (newl nil) - (td (expand-file-name - (concat (speedbar-line-path indent) token)))) - (while oldl - (if (not (string-match (concat "^" (regexp-quote td)) (car oldl))) - (setq newl (cons (car oldl) newl))) - (setq oldl (cdr oldl))) - (setq speedbar-shown-directories newl)) - (speedbar-change-expand-button-char ?+) - (speedbar-delete-subblock indent) - ) - (t (error "Ooops... not sure what to do."))) - (speedbar-center-buffer-smartly) - (setq speedbar-last-selected-file nil) - (save-excursion (speedbar-stealthy-updates))) - -(defun speedbar-directory-buttons-follow (text token indent) - "Speedbar click handler for default directory buttons. -TEXT is the button clicked on. TOKEN is the directory to follow. -INDENT is the current indentation level and is unused." - (setq default-directory token) - ;; Because we leave speedbar as the current buffer, - ;; update contents will change directory without - ;; having to touch the attached frame. - (speedbar-update-contents) - (speedbar-set-timer speedbar-navigating-speed)) - -(defun speedbar-tag-file (text token indent) - "The cursor is on a selected line. Expand the tags in the specified file. -The parameter TEXT and TOKEN are required, where TEXT is the button -clicked, and TOKEN is the file to expand. INDENT is the current -indentation level." - (cond ((string-match "+" text) ;we have to expand this file - (let* ((fn (expand-file-name (concat (speedbar-line-path indent) - token))) - (lst (if speedbar-use-imenu-flag - (let ((tim (speedbar-fetch-dynamic-imenu fn))) - (if (eq tim t) - (speedbar-fetch-dynamic-etags fn) - tim)) - (speedbar-fetch-dynamic-etags fn)))) - ;; if no list, then remove expando button - (if (not lst) - (speedbar-change-expand-button-char ??) - (speedbar-change-expand-button-char ?-) - (speedbar-with-writable - (save-excursion - (end-of-line) (forward-char 1) - (speedbar-insert-generic-list indent - lst 'speedbar-tag-expand - 'speedbar-tag-find)))))) - ((string-match "-" text) ;we have to contract this node - (speedbar-change-expand-button-char ?+) - (speedbar-delete-subblock indent)) - (t (error "Ooops... not sure what to do."))) - (speedbar-center-buffer-smartly)) - -(defun speedbar-tag-find (text token indent) - "For the tag TEXT in a file TOKEN, goto that position. -INDENT is the current indentation level." - (let ((file (speedbar-line-path indent))) - (speedbar-find-file-in-frame file) - (save-excursion (speedbar-stealthy-updates)) - ;; Reset the timer with a new timeout when cliking a file - ;; in case the user was navigating directories, we can cancel - ;; that other timer. - (speedbar-set-timer speedbar-update-speed) - (goto-char token) - ;;(recenter) - (speedbar-maybee-jump-to-attached-frame) - )) - -(defun speedbar-tag-expand (text token indent) - "Expand a tag sublist. Imenu will return sub-lists of specialized tag types. -Etags does not support this feature. TEXT will be the button -string. TOKEN will be the list, and INDENT is the current indentation -level." - (cond ((string-match "+" text) ;we have to expand this file - (speedbar-change-expand-button-char ?-) - (speedbar-with-writable - (save-excursion - (end-of-line) (forward-char 1) - (speedbar-insert-generic-list indent - token 'speedbar-tag-expand - 'speedbar-tag-find)))) - ((string-match "-" text) ;we have to contract this node - (speedbar-change-expand-button-char ?+) - (speedbar-delete-subblock indent)) - (t (error "Ooops... not sure what to do."))) - (speedbar-center-buffer-smartly)) - -;;; Loading files into the attached frame. -;; -(defun speedbar-find-file-in-frame (file) - "This will load FILE into the speedbar attached frame. -If the file is being displayed in a different frame already, then raise that -frame instead." - (let* ((buff (find-file-noselect file)) - (bwin (get-buffer-window buff 0))) - (if bwin - (progn - (select-window bwin) - (raise-frame (window-frame bwin))) - (if speedbar-power-click - (let ((pop-up-frames t)) (select-window (display-buffer buff))) - (select-frame speedbar-attached-frame) - (switch-to-buffer buff)))) - ) - -;;; Centering Utility -;; -(defun speedbar-center-buffer-smartly () - "Recenter a speedbar buffer so the current indentation level is all visible. -This assumes that the cursor is on a file, or tag of a file which the user is -interested in." - (if (<= (count-lines (point-min) (point-max)) - (window-height (selected-window))) - ;; whole buffer fits - (let ((cp (point))) - (goto-char (point-min)) - (recenter 0) - (goto-char cp)) - ;; too big - (let (depth start end exp p) - (save-excursion - (beginning-of-line) - (setq depth (if (looking-at "[0-9]+") - (string-to-int (buffer-substring-no-properties - (match-beginning 0) (match-end 0))) - 0)) - (setq exp (format "^%d:\\s-*[[{<]\\([?+-]\\)[]>}]" depth))) - (save-excursion - (end-of-line) - (if (re-search-backward exp nil t) - (setq start (point)) - (error "Center error")) - (save-excursion ;Not sure about this part. - (end-of-line) - (setq p (point)) - (while (and (not (re-search-forward exp nil t)) - (>= depth 0)) - (setq depth (1- depth)) - (setq exp (format "^%d:\\s-*[[{<]\\([?+-]\\)[]>}]" depth))) - (if (/= (point) p) - (setq end (point)) - (setq end (point-max))))) - ;; Now work out the details of centering - (let ((nl (count-lines start end)) - (cp (point))) - (if (> nl (window-height (selected-window))) - ;; We can't fit it all, so just center on cursor - (progn (goto-char start) - (recenter 1)) - ;; we can fit everything on the screen, but... - (if (and (pos-visible-in-window-p start (selected-window)) - (pos-visible-in-window-p end (selected-window))) - ;; we are all set! - nil - ;; we need to do something... - (goto-char start) - (let ((newcent (/ (- (window-height (selected-window)) nl) 2)) - (lte (count-lines start (point-max)))) - (if (and (< (+ newcent lte) (window-height (selected-window))) - (> (- (window-height (selected-window)) lte 1) - newcent)) - (setq newcent (- (window-height (selected-window)) - lte 1))) - (recenter newcent)))) - (goto-char cp))))) - - -;;; Tag Management -- Imenu -;; -(if (string-match "XEmacs" emacs-version) - - nil - -(eval-when-compile (if (locate-library "imenu") (require 'imenu))) - -(defun speedbar-fetch-dynamic-imenu (file) - "Load FILE into a buffer, and generate tags using Imenu. -Returns the tag list, or t for an error." - ;; Load this AND compile it in - (require 'imenu) - (save-excursion - (set-buffer (find-file-noselect file)) - (condition-case nil - (progn - (if speedbar-power-click (setq imenu--index-alist nil)) - (imenu--make-index-alist t)) - (error t)))) -) - -;;; Tag Management -- etags (XEmacs compatibility part) -;; -(defvar speedbar-fetch-etags-parse-list - '(;; Note that java has the same parse-group as c - ("\\.\\([cChH]\\|c++\\|cpp\\|cc\\|hh\\|java\\)$" . speedbar-parse-c-or-c++tag) - ("\\.el\\|\\.emacs" . "defun\\s-+\\(\\(\\w\\|[-_]\\)+\\)\\s-*\C-?") - ("\\.tex$" . speedbar-parse-tex-string) - ("\\.p" . - "\\(\\(FUNCTION\\|function\\|PROCEDURE\\|procedure\\)\\s-+\\([a-zA-Z0-9_.:]+\\)\\)\\s-*(?^?") - - ) - "Associations of file extensions and expressions for extracting tags. -To add a new file type, you would want to add a new association to the -list, where the car is the file match, and the cdr is the way to -extract an element from the tags output. If the output is complex, -use a function symbol instead of regexp. The function should expect -to be at the beginning of a line in the etags buffer. - -This variable is ignored if `speedbar-use-imenu-flag' is t") - -(defvar speedbar-fetch-etags-command "etags" - "*Command used to create an etags file. - -This variable is ignored if `speedbar-use-imenu-flag' is t") - -(defvar speedbar-fetch-etags-arguments '("-D" "-I" "-o" "-") - "*List of arguments to use with `speedbar-fetch-etags-command'. -This creates an etags output buffer. Use `speedbar-toggle-etags' to -modify this list conveniently. - -This variable is ignored if `speedbar-use-imenu-flag' is t") - -(defun speedbar-toggle-etags (flag) - "Toggle FLAG in `speedbar-fetch-etags-arguments'. -FLAG then becomes a member of etags command line arguments. If flag -is \"sort\", then toggle the value of `speedbar-sort-tags'. If it's -value is \"show\" then toggle the value of -`speedbar-show-unknown-files'. - - This function is a convenience function for XEmacs menu created by -Farzin Guilak <farzin@protocol.com>" - (interactive) - (cond - ((equal flag "sort") - (setq speedbar-sort-tags (not speedbar-sort-tags))) - ((equal flag "show") - (setq speedbar-show-unknown-files (not speedbar-show-unknown-files))) - ((or (equal flag "-C") - (equal flag "-S") - (equal flag "-D")) - (if (member flag speedbar-fetch-etags-arguments) - (setq speedbar-fetch-etags-arguments - (delete flag speedbar-fetch-etags-arguments)) - (add-to-list 'speedbar-fetch-etags-arguments flag))) - (t nil))) - -(defun speedbar-fetch-dynamic-etags (file) - "For FILE, run etags and create a list of symbols extracted. -Each symbol will be associated with it's line position in FILE." - (let ((newlist nil)) - (unwind-protect - (save-excursion - (if (get-buffer "*etags tmp*") - (kill-buffer "*etags tmp*")) ;kill to clean it up - (if (<= 1 speedbar-verbosity-level) (message "Fetching etags...")) - (set-buffer (get-buffer-create "*etags tmp*")) - (apply 'call-process speedbar-fetch-etags-command nil - (current-buffer) nil - (append speedbar-fetch-etags-arguments (list file))) - (goto-char (point-min)) - (if (<= 1 speedbar-verbosity-level) (message "Fetching etags...")) - (let ((expr - (let ((exprlst speedbar-fetch-etags-parse-list) - (ans nil)) - (while (and (not ans) exprlst) - (if (string-match (car (car exprlst)) file) - (setq ans (car exprlst))) - (setq exprlst (cdr exprlst))) - (cdr ans)))) - (if expr - (let (tnl) - (while (not (save-excursion (end-of-line) (eobp))) - (save-excursion - (setq tnl (speedbar-extract-one-symbol expr))) - (if tnl (setq newlist (cons tnl newlist))) - (forward-line 1))) - (message "Sorry, no support for a file of that extension")))) - ) - (if speedbar-sort-tags - (sort newlist (lambda (a b) (string< (car a) (car b)))) - (reverse newlist)))) - -;; This bit donated by Farzin Guilak <farzin@protocol.com> but I'm not -;; sure it's needed with the different sorting method. -;; -;(defun speedbar-clean-etags() -; "Removes spaces before the ^? character, and removes `#define', -;return types, etc. preceding tags. This ensures that the sort operation -;works on the tags, not the return types." -; (save-excursion -; (goto-char (point-min)) -; (while -; (re-search-forward "(?[ \t](?\C-?" nil t) -; (replace-match "\C-?" nil nil)) -; (goto-char (point-min)) -; (while -; (re-search-forward "\\(.*[ \t]+\\)\\([^ \t\n]+.*\C-?\\)" nil t) -; (delete-region (match-beginning 1) (match-end 1))))) - -(defun speedbar-extract-one-symbol (expr) - "At point, return nil, or one alist in the form: ( symbol . position ) -The line should contain output from etags. Parse the output using the -regular expression EXPR" - (let* ((sym (if (stringp expr) - (if (save-excursion - (re-search-forward expr (save-excursion - (end-of-line) - (point)) t)) - (buffer-substring-no-properties (match-beginning 1) - (match-end 1))) - (funcall expr))) - (pos (let ((j (re-search-forward "[\C-?\C-a]\\([0-9]+\\),\\([0-9]+\\)" - (save-excursion - (end-of-line) - (point)) - t))) - (if (and j sym) - (1+ (string-to-int (buffer-substring-no-properties - (match-beginning 2) - (match-end 2)))) - 0)))) - (if (/= pos 0) - (cons sym pos) - nil))) - -(defun speedbar-parse-c-or-c++tag () - "Parse a c or c++ tag, which tends to be a little complex." - (save-excursion - (let ((bound (save-excursion (end-of-line) (point)))) - (cond ((re-search-forward "\C-?\\([^\C-a]+\\)\C-a" bound t) - (buffer-substring-no-properties (match-beginning 1) - (match-end 1))) - ((re-search-forward "\\<\\([^ \t]+\\)\\s-+new(" bound t) - (buffer-substring-no-properties (match-beginning 1) - (match-end 1))) - ((re-search-forward "\\<\\([^ \t(]+\\)\\s-*(\C-?" bound t) - (buffer-substring-no-properties (match-beginning 1) - (match-end 1))) - (t nil)) - ))) - -(defun speedbar-parse-tex-string () - "Parse a Tex string. Only find data which is relevant." - (save-excursion - (let ((bound (save-excursion (end-of-line) (point)))) - (cond ((re-search-forward "\\(section\\|chapter\\|cite\\)\\s-*{[^\C-?}]*}?" bound t) - (buffer-substring-no-properties (match-beginning 0) - (match-end 0))) - (t nil))))) - - -;;; Color loading section This is messy *Blech!* -;; -(defun speedbar-load-color (sym l-fg l-bg d-fg d-bg &optional bold italic underline) - "Create a color for SYM with a L-FG and L-BG color, or D-FG and D-BG. -Optionally make BOLD, ITALIC, or UNDERLINE if applicable. If the background -attribute of the current frame is determined to be light (white, for example) -then L-FG and L-BG is used. If not, then D-FG and D-BG is used. This will -allocate the colors in the best possible manor. This will allow me to store -multiple defaults and dynamically determine which colors to use." - (let* ((params (frame-parameters)) - (disp-res (if (fboundp 'x-get-resource) - (if speedbar-xemacsp - (x-get-resource ".displayType" "DisplayType" 'string) - (x-get-resource ".displayType" "DisplayType")) - nil)) - (display-type - (cond (disp-res (intern (downcase disp-res))) - ((and (fboundp 'x-display-color-p) (x-display-color-p)) 'color) - (t 'mono))) - (bg-res (if (fboundp 'x-get-resource) - (if speedbar-xemacsp - (x-get-resource ".backgroundMode" "BackgroundMode" 'string) - (x-get-resource ".backgroundMode" "BackgroundMode")) - nil)) - (bgmode - (cond (bg-res (intern (downcase bg-res))) - ((let* ((bgc (or (cdr (assq 'background-color params)) - (if speedbar-xemacsp - (x-get-resource ".background" - "Background" 'string) - (x-get-resource ".background" - "Background")) - ;; if no other options, default is white - "white")) - (bgcr (if speedbar-xemacsp - (color-instance-rgb-components - (make-color-instance bgc)) - (x-color-values bgc))) - (wcr (if speedbar-xemacsp - (color-instance-rgb-components - (make-color-instance "white")) - (x-color-values "white")))) - (< (apply '+ bgcr) (/ (apply '+ wcr) 3))) - 'dark) - (t 'light))) ;our default - (set-p (function (lambda (face-name resource) - (if speedbar-xemacsp - (x-get-resource - (concat face-name ".attribute" resource) - (concat "Face.Attribute" resource) - 'string) - (x-get-resource - (concat face-name ".attribute" resource) - (concat "Face.Attribute" resource))) - ))) - (nbg (cond ((eq bgmode 'dark) d-bg) - (t l-bg))) - (nfg (cond ((eq bgmode 'dark) d-fg) - (t l-fg)))) - - (if (not (eq display-type 'color)) - ;; we need a face of some sort, so just make due with default - (progn - (copy-face 'default sym) - (if bold (condition-case nil - (make-face-bold sym) - (error (message "Cannot make face %s bold!" - (symbol-name sym))))) - (if italic (condition-case nil - (make-face-italic sym) - (error (message "Cannot make face %s italic!" - (symbol-name sym))))) - (set-face-underline-p sym underline) - ) - ;; make a colorized version of a face. Be sure to check Xdefaults - ;; for possible overrides first! - (let ((newface (make-face sym))) - ;; For each attribute, check if it might already be set by Xdefaults - (if (and nfg (not (funcall set-p (symbol-name sym) "Foreground"))) - (set-face-foreground newface nfg)) - (if (and nbg (not (funcall set-p (symbol-name sym) "Background"))) - (set-face-background newface nbg)) - - (if bold (condition-case nil - (make-face-bold newface) - (error (message "Cannot make face %s bold!" - (symbol-name sym))))) - (if italic (condition-case nil - (make-face-italic newface) - (error (message "Cannot make face %s italic!" - (symbol-name newface))))) - (set-face-underline-p newface underline) - )))) - -(if (x-display-color-p) - (progn - (speedbar-load-color 'speedbar-button-face "green4" nil "green3" nil nil nil nil) - (speedbar-load-color 'speedbar-file-face "cyan4" nil "cyan" nil nil nil nil) - (speedbar-load-color 'speedbar-directory-face "blue4" nil "light blue" nil nil nil nil) - (speedbar-load-color 'speedbar-tag-face "brown" nil "yellow" nil nil nil nil) - (speedbar-load-color 'speedbar-selected-face "red" nil "red" nil nil nil t) - (speedbar-load-color 'speedbar-highlight-face nil "green" nil "sea green" nil nil nil) - ) ; color - (make-face 'speedbar-button-face) - ;;(make-face 'speedbar-file-face) - (copy-face 'bold 'speedbar-file-face) - (make-face 'speedbar-directory-face) - (make-face 'speedbar-tag-face) - ;;(make-face 'speedbar-selected-face) - (copy-face 'underline 'speedbar-selected-face) - ;;(make-face 'speedbar-highlight-face) - (copy-face 'highlight 'speedbar-highlight-face) - - ) ;; monochrome - -;; some edebug hooks -(add-hook 'edebug-setup-hook - (lambda () - (def-edebug-spec speedbar-with-writable def-body))) - -;; run load-time hooks -(run-hooks 'speedbar-load-hook) - -(provide 'speedbar) -;;; speedbar ends here
--- a/lisp/utils/speedbspec.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,305 +0,0 @@ -;;; speedbspec --- Buffer specialized configurations for speedbar - -;; Copyright (C) 1997 Eric M. Ludlam -;; -;; Author: Eric M. Ludlam <zappo@gnu.ai.mit.edu> -;; Version: 0.1 -;; Keywords: file, tags, tools -;; X-RCS: $Id: speedbspec.el,v 1.1 1997/06/29 23:13:34 steve Exp $ -;; -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, you can either send email to this -;; program's author (see below) or write to: -;; -;; The Free Software Foundation, Inc. -;; 675 Mass Ave. -;; Cambridge, MA 02139, USA. -;; -;; Please send bug reports, etc. to zappo@gnu.ai.mit.edu. -;; - -;;; Commentary: -;; -;; Speedbar provides a frame in which files, and locations in -;; files are displayed. These functions provide some mode-specific -;; displays for some existing emacs modes. -;; -;; To provide special service to all the modes supported by this file, -;; put the following in your .emacs file. -;; -;; (require 'speedbspec) -;; -;; This will load in the known functions, and the mode-enabling code -;; into 'change-major-mode-hook. -;; -;; This file requires speedbar. - -;;; Change log: -;; 0.1 - Initial revision requiring speedbar 0.5 - -;;; Code: -(require 'speedbar) - -;;; Generic add-new-special-mode stuff -;; -(defvar speedbar-localized-buffer-queue nil - "List of buffers to localize for speedbar.") - -(defun speedbar-add-localized-speedbar-support-to-q () - "Add speedbar support to all buffers in `speedbar-localized-buffer-queue'." - (remove-hook 'post-command-hook - 'speedbar-add-localized-speedbar-support-to-q) - (while speedbar-localized-buffer-queue - (speedbar-add-localized-speedbar-support - (car speedbar-localized-buffer-queue)) - (setq speedbar-localized-buffer-queue - (cdr speedbar-localized-buffer-queue)))) - -(defun speedbar-add-localized-speedbar-support (buffer) - "Add localized speedbar support to BUFFER's mode if it is available." - (if (not (buffer-live-p buffer)) - nil - (save-excursion - (set-buffer buffer) - (save-match-data - (let ((ms (symbol-name major-mode)) - v tmp) - (if (not (string-match "-mode$" ms)) - nil ;; do nothing to broken mode - (setq ms (substring ms 0 (match-beginning 0))) - (setq v (intern-soft (concat ms "-speedbar-buttons"))) - (if (not v) - nil ;; do nothing if not defined - (make-local-variable 'speedbar-special-mode-expansion-list) - (setq speedbar-special-mode-expansion-list (list v)) - (setq v (intern-soft (concat ms "-speedbar-menu-items"))) - (if (not v) - nil ;; don't add special menus - (make-local-variable 'speedbar-easymenu-definition-special) - (setq speedbar-easymenu-definition-special - (symbol-value v)))))))))) - -(defun speedbar-change-major-mode () - "Run when the major mode is changed." - (setq speedbar-localized-buffer-queue - (add-to-list 'speedbar-localized-buffer-queue (current-buffer))) - (add-hook 'post-command-hook 'speedbar-add-localized-speedbar-support-to-q)) - -(add-hook 'change-major-mode-hook 'speedbar-change-major-mode) -(add-hook 'find-file-hooks 'speedbar-change-major-mode) - -;;; Info specific code -;; -(defvar Info-last-speedbar-node nil - "Last node viewed with speedbar in the form '(NODE FILE).") - -(defvar Info-speedbar-menu-items - '(["Browse Item On Line" speedbar-edit-line t]) - "Additional menu-items to add to speedbar frame.") - -(defun Info-speedbar-buttons (buffer) - "Create a speedbar display to help navigation in an Info file. -BUFFER is the buffer speedbar is requesting buttons for." - (goto-char (point-min)) - (if (and (looking-at "<Directory>") - (save-excursion - (set-buffer buffer) - (and (equal (car Info-last-speedbar-node) Info-current-node) - (equal (cdr Info-last-speedbar-node) Info-current-file)))) - nil - (erase-buffer) - (speedbar-insert-button "<Directory>" 'info-xref 'highlight - 'Info-speedbar-button - 'Info-directory) - (speedbar-insert-button "<Top>" 'info-xref 'highlight - 'Info-speedbar-button - 'Info-top-node) - (speedbar-insert-button "<Last>" 'info-xref 'highlight - 'Info-speedbar-button - 'Info-last) - (speedbar-insert-button "<Up>" 'info-xref 'highlight - 'Info-speedbar-button - 'Info-up) - (speedbar-insert-button "<Next>" 'info-xref 'highlight - 'Info-speedbar-button - 'Info-next) - (speedbar-insert-button "<Prev>" 'info-xref 'highlight - 'Info-speedbar-button - 'Info-prev) - (let ((completions nil)) - (save-excursion - (set-buffer buffer) - (setq Info-last-speedbar-node - (cons Info-current-node Info-current-file)) - (goto-char (point-min)) - ;; Always skip the first one... - (re-search-forward "\n\\* \\([^:\t\n]*\\):" nil t) - (while (re-search-forward "\n\\* \\([^:\t\n]*\\):" nil t) - (setq completions (cons (buffer-substring (match-beginning 1) - (match-end 1)) - completions)))) - (setq completions (nreverse completions)) - (while completions - (speedbar-make-tag-line nil nil nil nil - (car completions) 'Info-speedbar-menu - nil 'info-node 0) - (setq completions (cdr completions)))))) - -(defun Info-speedbar-button (text token indent) - "Called when user clicks <Directory> from speedbar. -TEXT, TOKEN, and INDENT are unused." - (speedbar-with-attached-buffer - (funcall token) - (setq Info-last-speedbar-node nil) - (speedbar-update-contents))) - -(defun Info-speedbar-menu (text token indent) - "Goto the menu node specified in TEXT. -TOKEN and INDENT are not used." - (speedbar-with-attached-buffer - (Info-menu text) - (setq Info-last-speedbar-node nil) - (speedbar-update-contents))) - -;;; RMAIL specific code -;; -(defvar rmail-speedbar-last-user nil - "The last user to be displayed in the speedbar.") - -(defvar rmail-speedbar-menu-items - '(["Browse Item On Line" speedbar-edit-line t] - ["Move message to folder" rmail-move-message-to-folder-on-line - (save-excursion (beginning-of-line) - (looking-at "<M> "))]) - "Additional menu-items to add to speedbar frame.") - -(defun rmail-speedbar-buttons (buffer) - "Create buttons for BUFFER containing rmail messages. -Click on the address under Reply to: to reply to this person. -Under Folders: Click a name to read it, or on the <M> to move the -current message into that RMAIL folder." - (let ((from nil)) - (save-excursion - (set-buffer buffer) - (goto-char (point-min)) - (if (not (re-search-forward "^Reply-To: " nil t)) - (if (not (re-search-forward "^From:? " nil t)) - (setq from t))) - (if from - nil - (setq from (buffer-substring (point) (save-excursion - (end-of-line) - (point)))))) - (goto-char (point-min)) - (if (and (looking-at "Reply to:") - (equal from rmail-speedbar-last-user)) - nil - (setq rmail-speedbar-last-user from) - (erase-buffer) - (insert "Reply To:\n") - (if (stringp from) - (speedbar-insert-button from 'speedbar-directory-face 'highlight - 'rmail-speedbar-button 'rmail-reply)) - (insert "Folders:\n") - (let* ((case-fold-search nil) - (df (directory-files (save-excursion (set-buffer buffer) - default-directory) - nil "^[A-Z0-9]+\\(\\.[A-Z0-9]+\\)?$"))) - (while df - (speedbar-insert-button "<M>" 'speedbar-button-face 'highlight - 'rmail-speedbar-move-message (car df)) - (speedbar-insert-button (car df) 'speedbar-file-face 'highlight - 'rmail-speedbar-find-file nil t) - (setq df (cdr df))))))) - -(defun rmail-speedbar-button (text token indent) - "Execute an rmail command specified by TEXT. -The command used is TOKEN. INDENT is not used." - (speedbar-with-attached-buffer - (funcall token t))) - -(defun rmail-speedbar-find-file (text token indent) - "Load in the rmail file TEXT. -TOKEN and INDENT are not used." - (speedbar-with-attached-buffer - (message "Loading in RMAIL file %s..." text) - (find-file text))) - -(defun rmail-move-message-to-folder-on-line () - "If the current line is a folder, move current message to it." - (interactive) - (save-excursion - (beginning-of-line) - (if (re-search-forward "<M> " (save-excursion (end-of-line) (point)) t) - (progn - (forward-char -2) - (speedbar-do-function-pointer))))) - -(defun rmail-speedbar-move-message (text token indent) - "From button TEXT, copy current message to the rmail file specified by TOKEN. -TEXT and INDENT are not used." - (speedbar-with-attached-buffer - (message "Moving message to %s" token) - (rmail-output-to-rmail-file token))) - -;;; W3 speedbar help -(defvar w3-speedbar-last-buffer nil - "The last buffer shown by w3-speedbar.") - -(defun w3-speedbar-buttons (buffer) - "Create speedbar buttons for the current web BUFFER displayed in w3 mode." - (save-excursion - (goto-char (point-min)) - (if (and (looking-at "History:") (equal w3-speedbar-last-buffer buffer)) - nil - (setq w3-speedbar-last-buffer buffer) - (erase-buffer) - (let ((links (save-excursion (set-buffer buffer) (w3-only-links))) - (part nil)) - (insert "History:\n") - ;; This taken out of w3 which was used to create the history list, - ;; and is here modified to create the speedbar buttons - (cl-maphash - (function - (lambda (url desc) - (speedbar-insert-button (w3-speedbar-shorten-button url) - 'speedbar-directory-face 'highlight - 'w3-speedbar-link url))) - url-history-list) - (insert "Links:\n") - (while links - (setq part (car (cdr (member 'href (car links)))) - links (cdr links)) - (speedbar-insert-button (w3-speedbar-shorten-button part) - 'speedbar-file-face 'highlight - 'w3-speedbar-link part)))))) - -(defun w3-speedbar-shorten-button (button) - "Takes text BUTTON and shortens it as much as possible." - ;; I should make this more complex, but I'm not sure how... - (let ((fnnd (file-name-nondirectory button))) - (if (< 0 (length fnnd)) - fnnd - (if (string-match "\\(ht\\|f\\)tp://" button) - (setq button (substring button (match-end 0)))) - (if (string-match "/$" button) - (setq button (substring button 0 (match-beginning 0)))) - button))) - -(defun w3-speedbar-link (text token indent) - "Follow link described by TEXT which has the URL TOKEN. -INDENT is not used." - (speedbar-with-attached-buffer (w3-fetch token))) - -(provide 'speedbspec) -;;; speedbspec ends here
--- a/lisp/utils/text-props.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,584 +0,0 @@ -;;; text-props.el --- implements properties of characters - -;; Copyright (C) 1993, 1994 Free Software Foundation, Inc. -;; Copyright (C) 1995 Amdahl Corporation. -;; Copyright (C) 1995 Ben Wing. - -;; Keywords: extensions, wp, faces -;; Author: Jamie Zawinski <jwz@netscape.com> -;; Modified: Ben Wing <wing@666.com> -- many of the Lisp functions below -;; were completely broken. -;; -;; 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: - -;;; This is a nearly complete implementation of the FSF19 text properties API. -;;; Please let me know if you notice any differences in behavior between -;;; this implementation and the FSF implementation. -;;; -;;; However, keep in mind that this interface has been implemented because it -;;; is useful. Compatibility with code written for FSF19 is a secondary goal -;;; to having a clean and useful interface. -;;; -;;; The cruftier parts of the FSF API, such as the special handling of -;;; properties like `mouse-face', `front-sticky', and other properties whose -;;; value is a list of names of *other* properties set at this position, are -;;; not implemented. The reason for this is that if you feel you need that -;;; kind of functionality, it's a good hint that you should be using extents -;;; instead of text properties. -;;; -;;; When should I use Text Properties, and when should I use Extents? -;;; ================================================================== -;;; -;;; If you are putting a `button' or `hyperlink' of some kind into a buffer, -;;; the most natural interface is one which deals with properties of regions -;;; with explicit endpoints that behave more-or-less like markers. That is -;;; what `make-extent', `extent-at', and `extent-property' are for. -;;; -;;; If you are dealing with styles of text, where things do not have explicit -;;; endpoints (as is done in font-lock.el and shell-font.el) or if you want to -;;; partition a buffer (that is, change some attribute of a range from one -;;; value to another without disturbing the properties outside of that range) -;;; then an interface that deals with properties of characters may be most -;;; natural. -;;; -;;; Another way of thinking of it is, do you care where the endpoints of the -;;; region are? If you do, then you should use extents. If it's ok for the -;;; region to become divided, and for two regions with identical properties to -;;; be merged into one region, then you might want to use text properties. -;;; -;;; Some applications want the attributes they add to be copied by the killing -;;; and yanking commands, and some do not. This is orthogonal to whether text -;;; properties or extents are used. Remember that text properties are -;;; implemented in terms of extents, so anything you can do with one you can -;;; do with the other. It's just a matter of which way of creating and -;;; managing them is most appropriate to your application. -;;; -;;; Implementation details: -;;; ======================= -;;; -;;; This package uses extents with a non-nil 'text-prop property. It assumes -;;; free reign over the endpoints of any extent with that property. It will -;;; not alter any extent which does not have that property. -;;; -;;; Right now, the text-property functions create one extent for each distinct -;;; property; that is, if a range of text has two text-properties on it, there -;;; will be two extents. As the set of text-properties is going to be small, -;;; this is probably not a big deal. It would be possible to share extents. -;;; -;;; One tricky bit is that undo/kill/yank must be made to not fragment things: -;;; these extents must not be allowed to overlap. We accomplish this by using -;;; a custom `paste-function' property on the extents. -;;; -;;; shell-font.el and font-lock.el could put-text-property to attach fonts to -;;; the buffer. However, what these packages are interested in is the -;;; efficient extent partitioning behavior which this code exhibits, not the -;;; duplicability aspect of it. In fact, either of these packages could be -;;; implemented by creating a one-character non-expandable extent for each -;;; character in the buffer, except that that would be extremely wasteful of -;;; memory. (Redisplay performance would be fine, however.) -;;; -;;; If these packages were to use put-text-property to make the extents, then -;;; when one copied text from a shell buffer or a font-locked source buffer -;;; and pasted it somewhere else (a sendmail buffer, or a buffer not in -;;; font-lock mode) then the fonts would follow, and there's no easy way to -;;; get rid of them (other than pounding out a call to put-text-property by -;;; hand.) This is annoying. Maybe it wouldn't be so annoying if there was a -;;; more general set of commands for handling styles of text (in fact, if -;;; there were such a thing, copying the fonts would probably be exactly what -;;; one wanted) but we aren't there yet. So these packages use the interface -;;; of `put-nonduplicable-text-property' which is the same, except that it -;;; doesn't make duplicable extents. -;;; -;;; `put-text-property' and `put-nonduplicable-text-property' don't get along: -;;; they will interfere with each other, reusing each others' extents without -;;; checking that the "duplicableness" is correct. This is a bug, but it's -;;; one that I don't care enough to fix this right now. - - -;;; Code: - - -;; The following functions were ported to C for speed; the overhead of doing -;; this many full lisp function calls was not small. - -;; #### The C functions have changed since then; the Lisp equivalents -;; should be updated. - -;(defun put-text-property (start end prop value &optional buffer) -; "Adds the given property/value to all characters in the specified region. -;The property is conceptually attached to the characters rather than the -;region. The properties are copied when the characters are copied/pasted." -; (put-text-property-1 start end prop value buffer t) -; prop) -; -;(defun put-nonduplicable-text-property (start end prop value &optional buffer) -; "Adds the given property/value to all characters in the specified region. -;The property is conceptually attached to the characters rather than the -;region, however the properties will not be copied the characters are copied." -; (put-text-property-1 start end prop value buffer nil) -; prop) -; -;(defun put-text-property-1 (start end prop value buffer duplicable) -; ;; returns whether any property of a character was changed -; (if (= start end) -; nil -; (save-excursion -; (and buffer (set-buffer buffer)) -; (let ((the-extent nil) -; (changed nil)) -; ;; prop, value, the-extent, start, end, and changed are of dynamic -; ;; scope. changed and the-extent are assigned. -; (map-extents (function put-text-property-mapper) nil -; (max 1 (1- start)) -; (min (buffer-size) (1+ end))) -; -; ;; If we made it through the loop without reusing an extent -; ;; (and we want there to be one) make it now. -; (cond ((and value (not the-extent)) -; (setq the-extent (make-extent start end)) -; (set-extent-property the-extent 'text-prop prop) -; (set-extent-property the-extent prop value) -; (setq changed t) -; (cond (duplicable -; (set-extent-property the-extent 'duplicable t) -; (set-extent-property the-extent 'paste-function -; 'text-prop-extent-paste-function))) -; )) -; changed)))) -; -;(defun put-text-property-mapper (e ignore) -; ;; prop, value, the-extent, start, end, and changed are of dynamic scope. -; ;; changed and the-extent are assigned. -; (let ((e-start (extent-start-position e)) -; (e-end (extent-end-position e)) -; (e-val (extent-property e prop))) -; (cond ((not (eq (extent-property e 'text-prop) prop)) -; ;; It's not for this property; do nothing. -; nil) -; -; ((and value -; (not the-extent) -; (eq value e-val)) -; ;; we want there to be an extent here at the end, and we haven't -; ;; picked one yet, so use this one. Extend it as necessary. -; ;; We only reuse an extent which has an EQ value for the prop in -; ;; question to avoid side-effecting the kill ring (that is, we -; ;; never change the property on an extent after it has been -; ;; created.) -; (cond -; ((or (/= e-start start) (/= e-end end)) -; (set-extent-endpoints e (min e-start start) (max e-end end)) -; (setq changed t))) -; (setq the-extent e)) -; -; ;; Even if we're adding a prop, at this point, we want all other -; ;; extents of this prop to go away (as now they overlap.) -; ;; So the theory here is that, when we are adding a prop to a -; ;; region that has multiple (disjoint) occurences of that prop -; ;; in it already, we pick one of those and extend it, and remove -; ;; the others. -; -; ((eq e the-extent) -; ;; just in case map-extents hits it again (does that happen?) -; nil) -; -; ((and (>= e-start start) -; (<= e-end end)) -; ;; extent is contained in region; remove it. Don't destroy or -; ;; modify it, because we don't want to change the attributes -; ;; pointed to by the duplicates in the kill ring. -; (setq changed t) -; (detach-extent e)) -; -; ((and the-extent -; (eq value e-val) -; (<= e-start end) -; (>= e-end start)) -; ;; this extent overlaps, and has the same prop/value as the -; ;; extent we've decided to reuse, so we can remove this existing -; ;; extent as well (the whole thing, even the part outside of the -; ;; region) and extend the-extent to cover it, resulting in the -; ;; minimum number of extents in the buffer. -; (cond -; ((and (/= (extent-start-position the-extent) e-start) -; (/= (extent-end-position the-extent) e-end)) -; (set-extent-endpoints the-extent -; (min (extent-start-position the-extent) -; e-start) -; (max (extent-end-position the-extent) -; e-end)) -; (setq changed t))) -; (detach-extent e)) -; -; ((<= (extent-end-position e) end) -; ;; extent begins before start but ends before end, -; ;; so we can just decrease its end position. -; (if (and (= (extent-start-position e) e-start) -; (= (extent-end-position e) start)) -; nil -; (set-extent-endpoints e e-start start) -; (setq changed t))) -; -; ((>= (extent-start-position e) start) -; ;; extent ends after end but begins after start, -; ;; so we can just increase its start position. -; (if (and (= (extent-start-position e) end) -; (= (extent-start-position e) e-end)) -; nil -; (set-extent-endpoints e end e-end) -; (setq changed t))) -; -; (t -; ;; Otherwise, the extent straddles the region. -; ;; We need to split it. -; (set-extent-endpoints e e-start start) -; (setq e (copy-extent e)) -; (set-extent-endpoints e end e-end) -; (setq changed t)))) -; ;; return nil to continue mapping over region. -; nil) -; -; -;(defun text-prop-extent-paste-function (extent from to) -; ;; Whenever a text-prop extent is pasted into a buffer (via `yank' or -; ;; `insert' or whatever) we attach the properties to the buffer by calling -; ;; `put-text-property' instead of by simply alowing the extent to be copied -; ;; or re-attached. Then we return nil, telling the C code not to attach -; ;; it again. By handing the insertion hackery in this way, we make kill/yank -; ;; behave consistently iwth put-text-property and not fragment the extents -; ;; (since text-prop extents must partition, not overlap.) -; (let* ((prop (or (extent-property extent 'text-prop) -; (error "internal error: no text-prop on %S" extent))) -; (val (or (extent-property extent prop) -; (error "internal error: no text-prop %S on %S" -; prop extent)))) -; (put-text-property from to prop val) -; nil)) -; -;(defun add-text-properties (start end props &optional buffer) -; "Add properties to the characters from START to END. -;The third argument PROPS is a property list specifying the property values -;to add. The optional fourth argument, OBJECT, is the buffer containing the -;text. Returns t if any property was changed, nil otherwise." -; (let ((changed nil)) -; (while props -; (setq changed -; (or (put-text-property-1 start end (car props) (car (cdr props)) -; buffer t) -; changed)) -; (setq props (cdr (cdr props)))) -; changed)) -; -;(defun remove-text-properties (start end props &optional buffer) -; "Remove the given properties from all characters in the specified region. -;PROPS should be a plist, but the values in that plist are ignored (treated -;as nil.) Returns t if any property was changed, nil otherwise." -; (let ((changed nil)) -; (while props -; (setq changed -; (or (put-text-property-1 start end (car props) nil buffer t) -; changed)) -; (setq props (cdr (cdr props)))) -; changed)) -; - -(defun set-text-properties (start end props &optional buffer-or-string) - "You should NEVER use this function. It is ideologically blasphemous. -It is provided only to ease porting of broken FSF Emacs programs. - -Completely replace properties of text from START to END. -The third argument PROPS is the new property list. -The optional fourth argument, BUFFER-OR-STRING, -is the string or buffer containing the text." - (map-extents #'(lambda (extent ignored) - ;; #### dmoore - shouldn't this use - ;; (extent-start-position extent) - ;; (extent-end-position extent) - (remove-text-properties start end - (list (extent-property extent - 'text-prop) - nil) - buffer-or-string) - nil) - buffer-or-string start end nil nil 'text-prop) - (add-text-properties start end props buffer-or-string)) - - -;;; The following functions can probably stay in lisp, since they're so simple. - -;(defun get-text-property (pos prop &optional buffer) -; "Returns the value of the PROP property at the given position." -; (let ((e (extent-at pos buffer prop))) -; (if e -; (extent-property e prop) -; nil))) - -(defun extent-properties-at-1 (position buffer-or-string text-props-only) - (let ((extent nil) - (props nil) - new-props) - (while (setq extent (extent-at position buffer-or-string - (if text-props-only 'text-prop nil) - extent)) - (if text-props-only - ;; Only return the one prop which the `text-prop' property points at. - (let ((prop (extent-property extent 'text-prop))) - (setq new-props (list prop (extent-property extent prop)))) - ;; Return all the properties... - (setq new-props (extent-properties extent)) - ;; ...but! Don't return the `begin-glyph' or `end-glyph' properties - ;; unless the position is exactly at the appropriate endpoint. Yeah, - ;; this is kind of a kludge. - ;; #### Bug, this doesn't work for end-glyphs (on end-open extents) - ;; because we've already passed the extent with the glyph by the time - ;; it's appropriate to return the glyph. We could return the end - ;; glyph one character early I guess... But then next-property-change - ;; would have to stop one character early as well. It could back up - ;; when it hit an end-glyph... - ;; #### Another bug, if there are multiple glyphs at the same position, - ;; we only see the first one. - (cond ((or (extent-begin-glyph extent) (extent-end-glyph extent)) - (if (/= position (if (extent-property extent 'begin-glyph) - (extent-start-position extent) - (extent-end-position extent))) - (let ((rest new-props) - prev) - (while rest - (cond ((or (eq (car rest) 'begin-glyph) - (eq (car rest) 'end-glyph)) - (if prev - (setcdr prev (cdr (cdr rest))) - (setq new-props (cdr (cdr new-props)))) - (setq rest nil))) - (setq prev rest - rest (cdr rest)))))))) - (cond ((null props) - (setq props new-props)) - (t - (while new-props - (or (getf props (car new-props)) - (setq props (cons (car new-props) - (cons (car (cdr new-props)) - props)))) - (setq new-props (cdr (cdr new-props))))))) - props)) - -(defun extent-properties-at (position &optional object) - "Returns the properties of the character at the given position -in OBJECT (a string or buffer) by merging the properties of overlapping -extents. The returned value is a property list, some of which may be -shared with other structures. You must not modify it. - -If POSITION is at the end of OBJECT, the value is nil. - -This returns all properties on all extents. -See also `text-properties-at'." - (extent-properties-at-1 position object nil)) - -(defun text-properties-at (position &optional object) - "Returns the properties of the character at the given position -in OBJECT (a string or buffer) by merging the properties of overlapping -extents. The returned value is a property list, some of which may be -shared with other structures. You must not modify it. - -If POSITION is at the end of OBJECT, the value is nil. - -This returns only those properties added with `put-text-property'. -See also `extent-properties-at'." - (extent-properties-at-1 position object t)) - -(defun text-property-any (start end prop value &optional buffer-or-string) - "Check text from START to END to see if PROP is ever `eq' to VALUE. -If so, return the position of the first character whose PROP is `eq' -to VALUE. Otherwise return nil. -The optional fifth argument, BUFFER-OR-STRING, is the buffer or string -containing the text and defaults to the current buffer." - (while (and start (< start end) - (not (eq value (get-text-property start prop buffer-or-string)))) - (setq start (next-single-property-change start prop buffer-or-string end))) - ;; we have to insert a special check for end due to the illogical - ;; definition of next-single-property-change (blame FSF for this). - (if (eq start end) nil start)) - -(defun text-property-not-all (start end prop value &optional buffer-or-string) - "Check text from START to END to see if PROP is ever not `eq' to VALUE. -If so, return the position of the first character whose PROP is not -`eq' to VALUE. Otherwise, return nil. -The optional fifth argument, BUFFER-OR-STRING, is the buffer or string -containing the text and defaults to the current buffer." - (if (not (eq value (get-text-property start prop buffer-or-string))) - start - (let ((retval (next-single-property-change start prop - buffer-or-string end))) - ;; we have to insert a special check for end due to the illogical - ;; definition of previous-single-property-change (blame FSF for this). - (if (eq retval end) nil retval)))) - -;; Older versions that only work sometimes (when VALUE is non-nil -;; for text-property-any, and maybe only when VALUE is nil for -;; text-property-not-all). They might be faster in those cases, -;; but that's not obvious. - -;(defun text-property-any (start end prop value &optional buffer) -; "Check text from START to END to see if PROP is ever `eq' to VALUE. -;If so, return the position of the first character whose PROP is `eq' -;to VALUE. Otherwise return nil." -; ;; #### what should (text-property-any x y 'foo nil) return when there -; ;; is no foo property between x and y? Either t or nil seems sensible, -; ;; since a character with a property of nil is indistinguishable from -; ;; a character without that property set. -; (map-extents -; #'(lambda (e ignore) -; (if (eq value (extent-property e prop)) -; ;; return non-nil to stop mapping -; (max start (extent-start-position e)) -; nil)) -; nil start end buffer)) -; -;(defun text-property-not-all (start end prop value &optional buffer) -; "Check text from START to END to see if PROP is ever not `eq' to VALUE. -;If so, return the position of the first character whose PROP is not -;`eq' to VALUE. Otherwise, return nil." -; (let (maxend) -; (map-extents -; #'(lambda (e ignore) -; ;;### no, actually, this is harder. We need to collect all props -; ;; for a given character, and then determine whether no extent -; ;; contributes the given value. Doing this without consing lots -; ;; of lists is the tricky part. -; (if (eq value (extent-property e prop)) -; (progn -; (setq maxend (extent-end-position e)) -; nil) -; (max start maxend))) -; nil start end buffer))) - -(defun next-property-change (pos &optional buffer-or-string limit) - "Return the position of next property change. -Scans forward from POS in BUFFER-OR-STRING (defaults to the current buffer) - until it finds a change in some text property, then returns the position of - the change. -Returns nil if the properties remain unchanged all the way to the end. -If the value is non-nil, it is a position greater than POS, never equal. -If the optional third argument LIMIT is non-nil, don't search - past position LIMIT; return LIMIT if nothing is found before LIMIT. -If two or more extents with conflicting non-nil values for a property overlap - a particular character, it is undefined which value is considered to be - the value of the property. (Note that this situation will not happen if - you always use the text-property primitives.)" - (let ((limit-was-nil (null limit))) - (or limit (setq limit (if (bufferp buffer-or-string) - (point-max buffer-or-string) - (length buffer-or-string)))) - (let ((value (extent-properties-at pos buffer-or-string))) - (while - (and (< (setq pos (next-extent-change pos buffer-or-string)) limit) - (plists-eq value (extent-properties-at pos buffer-or-string))))) - (if (< pos limit) pos - (if limit-was-nil nil - limit)))) - -(defun previous-property-change (pos &optional buffer-or-string limit) - "Return the position of previous property change. -Scans backward from POS in BUFFER-OR-STRING (defaults to the current buffer) - until it finds a change in some text property, then returns the position of - the change. -Returns nil if the properties remain unchanged all the way to the beginning. -If the value is non-nil, it is a position less than POS, never equal. -If the optional third argument LIMIT is non-nil, don't search back - past position LIMIT; return LIMIT if nothing is found until LIMIT. -If two or more extents with conflicting non-nil values for a property overlap - a particular character, it is undefined which value is considered to be - the value of the property. (Note that this situation will not happen if - you always use the text-property primitives.)" - (let ((limit-was-nil (null limit))) - (or limit (setq limit (if (bufferp buffer-or-string) - (point-min buffer-or-string) - 0))) - (let ((value (extent-properties-at (1- pos) buffer-or-string))) - (while - (and (> (setq pos (previous-extent-change pos buffer-or-string)) - limit) - (plists-eq value (extent-properties-at (1- pos) - buffer-or-string))))) - (if (> pos limit) pos - (if limit-was-nil nil - limit)))) - -(defun text-property-bounds (pos prop &optional object at-flag) - "Return the bounds of property PROP at POS. -This returns a cons (START . END) of the largest region of text containing -POS which has a non-nil value for PROP. The return value is nil if POS -does not have a non-nil value for PROP. OBJECT specifies the buffer -or string to search in. Optional arg AT-FLAG controls what \"at POS\" -means, and has the same meaning as for `extent-at'." - (or object (setq object (current-buffer))) - (and (get-char-property pos prop object at-flag) - (let ((begin (if (stringp object) 0 (point-min object))) - (end (if (stringp object) (length object) (point-max object)))) - (cons (previous-single-property-change (1+ pos) prop object begin) - (next-single-property-change pos prop object end))))) - -(defun next-text-property-bounds (count pos prop &optional object) - "Return the COUNTth bounded property region of property PROP after POS. -If COUNT is less than zero, search backwards. This returns a cons -\(START . END) of the COUNTth maximal region of text that begins after POS -\(starts before POS) and has a non-nil value for PROP. If there aren't -that many regions, nil is returned. OBJECT specifies the buffer or -string to search in." - (or object (setq object (current-buffer))) - (let ((begin (if (stringp object) 0 (point-min object))) - (end (if (stringp object) (length object) (point-max object)))) - (catch 'hit-end - (if (> count 0) - (progn - (while (> count 0) - (if (>= pos end) - (throw 'hit-end nil) - (and (get-char-property pos prop object) - (setq pos (next-single-property-change pos prop - object end))) - (setq pos (next-single-property-change pos prop object end))) - (setq count (1- count))) - (and (< pos end) - (cons pos (next-single-property-change pos prop object end)))) - (while (< count 0) - (if (<= pos begin) - (throw 'hit-end nil) - (and (get-char-property (1- pos) prop object) - (setq pos (previous-single-property-change pos prop - object begin))) - (setq pos (previous-single-property-change pos prop object - begin))) - (setq count (1+ count))) - (and (> pos begin) - (cons (previous-single-property-change pos prop object begin) - pos)))))) - -;(defun detach-all-extents (&optional buffer) -; (map-extents #'(lambda (x i) (detach-extent x) nil) -; buffer)) - - -(provide 'text-props) - -;;; text-props.el ends here
--- a/lisp/version.el Mon Aug 13 10:03:54 2007 +0200 +++ b/lisp/version.el Mon Aug 13 10:04:58 2007 +0200 @@ -1,5 +1,9 @@ -;; Record version number of Emacs. -;; Copyright (C) 1985, 1991-1994 Free Software Foundation, Inc. +;; version.el --- Record version number of Emacs. + +;; Copyright (C) 1985, 1991-1994, 1997 Free Software Foundation, Inc. + +;; Maintainer: XEmacs Development Team +;; Keywords: internal, dumped ;; This file is part of XEmacs. @@ -20,18 +24,11 @@ ;;; Synched up with: FSF 19.34. -;;; Code: - -;;(defconst emacs-version "20.3" -;; "Version numbers of this version of XEmacs.") +;;; Commentary: -;;(defconst xemacs-codename "Copenhagen" -;; "Release nickname, primarily useful for trial prereleases. -;;Warning, this variable did not exist in XEmacs versions prior to 20.3") +;; This file is dumped with XEmacs. -;;(defconst xemacs-betaname "(beta8)" -;; "Non-nil when this is a test (beta) version of XEmacs. -;;Warning, this variable did not exist in XEmacs versions prior to 20.3") +;;; Code: (defconst xemacs-betaname (and emacs-beta-version (format "(beta%d)" emacs-beta-version))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/w32/w32-faces.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,105 @@ +;;; w32-faces.el --- win32-specific face stuff. + +;;; Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc. +;;; Copyright (C) 1995, 1996 Ben Wing. + +;; Author: Jamie Zawinski +;; Modified by: Chuck Thompson +;; Modified by: Ben Wing +;; Modified by: Martin Buchholz +;; Rewritten for win32 by: Jonathan Harris + +;; 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. + +;; This file does the magic to parse w32 font names, and make sure that the +;; default and modeline attributes of new frames are specified enough. + +(defun w32-init-global-faces () + ) + +;;; ensure that the default face has some reasonable fallbacks if nothing +;;; else is specified. +(defun w32-init-device-faces (device) + (or (face-font 'default 'global) + (set-face-font 'default "Courier New:Regular:10") + 'global) + (or (face-foreground 'default 'global) + (set-face-foreground 'default "black" 'global 'w32)) + (or (face-background 'default 'global) + (set-face-background 'default "white" 'global 'w32)) + (or (face-background 'modeline 'global) + (set-face-background 'modeline "grey" 'global 'w32)) + ) + + +(defun w32-init-frame-faces (frame) + ) + + +;;; Fill in missing parts of a font spec. This is primarily intended as a +;;; helper function for the functions below. +;;; w32 fonts look like: +;;; fontname[:[weight ][style][:pointsize[:effects[:charset]]]] +;;; A minimal w32 font spec looks like: +;;; Courier New +;;; A maximal w32 font spec looks like: +;;; Courier New:Bold Italic:10:underline strikeout:ansi +;;; Missing parts of the font spec should be filled in with these values: +;;; Courier New:Normal:10::ansi +(defun w32-canicolize-font (font &optional device) + "Given a win32 font specification, this converts it to canonical form." + nil) + +(defun w32-make-font-bold (font &optional device) + "Given a win32 font specification, this attempts to make a bold font. +If it fails, it returns nil." + nil) + +(defun w32-make-font-unbold (font &optional device) + "Given a win32 font specification, this attempts to make a non-bold font. +If it fails, it returns nil." + nil) + +(defun w32-make-font-italic (font &optional device) + "Given a win32 font specification, this attempts to make an `italic' font. +If it fails, it returns nil." + nil) + +(defun w32-make-font-unitalic (font &optional device) + "Given a win32 font specification, this attempts to make a non-italic font. +If it fails, it returns nil." + nil) + +(defun w32-make-font-bold-italic (font &optional device) + "Given a win32 font specification, this attempts to make a `bold-italic' +font. If it fails, it returns nil." + nil) + +(defun w32-find-smaller-font (font &optional device) + "Loads a new, version of the given font (or font name). +Returns the font if it succeeds, nil otherwise. +If scalable fonts are available, this returns a font which is 1 point smaller. +Otherwise, it returns the next smaller version of this font that is defined." + nil) + +(defun w32-find-larger-font (font &optional device) + "Loads a new, slightly larger version of the given font (or font name). +Returns the font if it succeeds, nil otherwise. +If scalable fonts are available, this returns a font which is 1 point larger. +Otherwise, it returns the next larger version of this font that is defined." + nil)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/w32/w32-init.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,47 @@ +;;; w32-init.el --- initialization code for win32 +;; Copyright (C) 1990, 1993, 1994 Free Software Foundation, Inc. +;; Copyright (C) 1995 Board of Trustees, University of Illinois. +;; Copyright (C) 1995, 1996 Ben Wing. + +;; Author: various +;; Rewritten for win32 by: Jonathan Harris + +;; 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, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +(defvar w32-win-initted nil) +(defvar w32-pre-win-initted nil) +(defvar w32-post-win-initted nil) + +(defun init-pre-w32-win () + "Initialize win32 GUI at startup (pre). Don't call this." + (unless w32-pre-win-initted + (setq w32-pre-win-initted t))) + +(defun init-w32-win () + "Initialize win32 GUI at startup. Don't call this." + (unless w32-win-initted + (init-pre-w32-win) + (make-w32-device) + (init-post-w32-win (selected-console)) + (setq w32-win-initted t))) + +(defun init-post-w32-win (console) + "Initialize win32 GUI at startup (post). Don't call this." + (unless w32-post-win-initted + (setq w32-post-win-initted t))) +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/wid-browse.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,300 @@ +;;; wid-browse.el --- Functions for browsing widgets. +;; +;; Copyright (C) 1997 Free Software Foundation, Inc. +;; +;; Author: Per Abrahamsen <abraham@dina.kvl.dk> +;; Keywords: extensions +;; Version: 1.9960 +;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: +;; +;; Widget browser. See `widget.el'. + +;;; Code: + +(require 'easymenu) +(require 'custom) +(require 'wid-edit) +(eval-when-compile (require 'cl)) + +(defgroup widget-browse nil + "Customization support for browsing widgets." + :group 'widgets) + +;;; The Mode. + +(defvar widget-browse-mode-map nil + "Keymap for `widget-browse-mode'.") + +(unless widget-browse-mode-map + (setq widget-browse-mode-map (make-sparse-keymap)) + (set-keymap-parent widget-browse-mode-map widget-keymap) + (define-key widget-browse-mode-map "q" 'bury-buffer)) + +(easy-menu-define widget-browse-mode-customize-menu + widget-browse-mode-map + "Menu used in widget browser buffers." + (customize-menu-create 'widgets)) + +(easy-menu-define widget-browse-mode-menu + widget-browse-mode-map + "Menu used in widget browser buffers." + '("Widget" + ["Browse" widget-browse t] + ["Browse At" widget-browse-at t])) + +(defcustom widget-browse-mode-hook nil + "Hook called when entering widget-browse-mode." + :type 'hook + :group 'widget-browse) + +(defun widget-browse-mode () + "Major mode for widget browser buffers. + +The following commands are available: + +\\[widget-forward] Move to next button or editable field. +\\[widget-backward] Move to previous button or editable field. +\\[widget-button-click] Activate button under the mouse pointer. +\\[widget-button-press] Activate button under point. + +Entry to this mode calls the value of `widget-browse-mode-hook' +if that value is non-nil." + (kill-all-local-variables) + (setq major-mode 'widget-browse-mode + mode-name "Widget") + (use-local-map widget-browse-mode-map) + (easy-menu-add widget-browse-mode-customize-menu) + (easy-menu-add widget-browse-mode-menu) + (run-hooks 'widget-browse-mode-hook)) + +;;; Commands. + +;;;###autoload +(defun widget-browse-at (pos) + "Browse the widget under point." + (interactive "d") + (let* ((field (get-char-property pos 'field)) + (button (get-char-property pos 'button)) + (doc (get-char-property pos 'widget-doc)) + (text (cond (field "This is an editable text area.") + (button "This is an active area.") + (doc "This is documentation text.") + (t "This is unidentified text."))) + (widget (or field button doc))) + (when widget + (widget-browse widget)) + (message text))) + +(defvar widget-browse-history nil) + +;;;###autoload +(defun widget-browse (widget) + "Create a widget browser for WIDGET." + (interactive (list (completing-read "Widget: " + obarray + (lambda (symbol) + (get symbol 'widget-type)) + t nil 'widget-browse-history))) + (if (stringp widget) + (setq widget (intern widget))) + (unless (if (symbolp widget) + (get widget 'widget-type) + (and (consp widget) + (get (widget-type widget) 'widget-type))) + (error "Not a widget.")) + ;; Create the buffer. + (if (symbolp widget) + (let ((buffer (format "*Browse %s Widget*" widget))) + (kill-buffer (get-buffer-create buffer)) + (switch-to-buffer (get-buffer-create buffer))) + (kill-buffer (get-buffer-create "*Browse Widget*")) + (switch-to-buffer (get-buffer-create "*Browse Widget*"))) + (widget-browse-mode) + + ;; Quick way to get out. +;; (widget-create 'push-button +;; :action (lambda (widget &optional event) +;; (bury-buffer)) +;; "Quit") +;; (widget-insert "\n") + + ;; Top text indicating whether it is a class or object browser. + (if (listp widget) + (widget-insert "Widget object browser.\n\nClass: ") + (widget-insert "Widget class browser.\n\n") + (widget-create 'widget-browse + :format "%[%v%]\n%d" + :doc (get widget 'widget-documentation) + widget) + (unless (eq (preceding-char) ?\n) + (widget-insert "\n")) + (widget-insert "\nSuper: ") + (setq widget (get widget 'widget-type))) + + ;; Now show the attributes. + (let ((name (car widget)) + (items (cdr widget)) + key value printer) + (widget-create 'widget-browse + :format "%[%v%]" + name) + (widget-insert "\n") + (while items + (setq key (nth 0 items) + value (nth 1 items) + printer (or (get key 'widget-keyword-printer) + 'widget-browse-sexp) + items (cdr (cdr items))) + (widget-insert "\n" (symbol-name key) "\n\t") + (funcall printer widget key value) + (widget-insert "\n"))) + (widget-setup) + (goto-char (point-min))) + +;;;###autoload +(defun widget-browse-other-window (&optional widget) + "Show widget browser for WIDGET in other window." + (interactive) + (let ((window (selected-window))) + (switch-to-buffer-other-window "*Browse Widget*") + (if widget + (widget-browse widget) + (call-interactively 'widget-browse)) + (select-window window))) + + +;;; The `widget-browse' Widget. + +(define-widget 'widget-browse 'push-button + "Button for creating a widget browser. +The :value of the widget shuld be the widget to be browsed." + :format "%[[%v]%]" + :value-create 'widget-browse-value-create + :action 'widget-browse-action) + +(defun widget-browse-action (widget &optional event) + ;; Create widget browser for WIDGET's :value. + (widget-browse (widget-get widget :value))) + +(defun widget-browse-value-create (widget) + ;; Insert type name. + (let ((value (widget-get widget :value))) + (cond ((symbolp value) + (insert (symbol-name value))) + ((consp value) + (insert (symbol-name (widget-type value)))) + (t + (insert "strange"))))) + +;;; Keyword Printer Functions. + +(defun widget-browse-widget (widget key value) + "Insert description of WIDGET's KEY VALUE. +VALUE is assumed to be a widget." + (widget-create 'widget-browse value)) + +(defun widget-browse-widgets (widget key value) + "Insert description of WIDGET's KEY VALUE. +VALUE is assumed to be a list of widgets." + (while value + (widget-create 'widget-browse + (car value)) + (setq value (cdr value)) + (when value + (widget-insert " ")))) + +(defun widget-browse-sexp (widget key value) + "Insert description of WIDGET's KEY VALUE. +Nothing is assumed about value." + (let ((pp (condition-case signal + (pp-to-string value) + (error (prin1-to-string signal))))) + (when (string-match "\n\\'" pp) + (setq pp (substring pp 0 (1- (length pp))))) + (if (cond ((string-match "\n" pp) + nil) + ((> (length pp) (- (window-width) (current-column))) + nil) + (t t)) + (widget-insert pp) + (widget-create 'push-button + :tag "show" + :action (lambda (widget &optional event) + (with-output-to-temp-buffer + "*Pp Eval Output*" + (princ (widget-get widget :value)))) + pp)))) + +(defun widget-browse-sexps (widget key value) + "Insert description of WIDGET's KEY VALUE. +VALUE is assumed to be a list of widgets." + (let ((target (current-column))) + (while value + (widget-browse-sexp widget key (car value)) + (setq value (cdr value)) + (when value + (widget-insert "\n" (make-string target ?\ )))))) + +;;; Keyword Printers. + +(put :parent 'widget-keyword-printer 'widget-browse-widget) +(put :children 'widget-keyword-printer 'widget-browse-widgets) +(put :buttons 'widget-keyword-printer 'widget-browse-widgets) +(put :button 'widget-keyword-printer 'widget-browse-widget) +(put :args 'widget-keyword-printer 'widget-browse-sexps) + +;;; Widget Minor Mode. + +(defvar widget-minor-mode nil + "I non-nil, we are in Widget Minor Mode.") + (make-variable-buffer-local 'widget-minor-mode) + +(defvar widget-minor-mode-map nil + "Keymap used in Widget Minor Mode.") + +(unless widget-minor-mode-map + (setq widget-minor-mode-map (make-sparse-keymap)) + (set-keymap-parent widget-minor-mode-map widget-keymap)) + +;;;###autoload +(defun widget-minor-mode (&optional arg) + "Togle minor mode for traversing widgets. +With arg, turn widget mode on if and only if arg is positive." + (interactive "P") + (cond ((null arg) + (setq widget-minor-mode (not widget-minor-mode))) + ((<= arg 0) + (setq widget-minor-mode nil)) + (t + (setq widget-minor-mode t))) + (force-mode-line-update)) + +(add-to-list 'minor-mode-alist '(widget-minor-mode " Widget")) + +(add-to-list 'minor-mode-map-alist + (cons 'widget-minor-mode widget-minor-mode-map)) + +;;; The End: + +(provide 'wid-browse) + +;; wid-browse.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/wid-edit.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,3638 @@ +;;; wid-edit.el --- Functions for creating and using widgets. +;; +;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. +;; +;; Author: Per Abrahamsen <abraham@dina.kvl.dk> +;; Maintainer: Hrvoje Niksic <hniksic@srce.hr> +;; Keywords: extensions +;; Version: 1.9960-x +;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ + +;; 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. + +;;; Commentary: +;; +;; See `widget.el'. + + +;;; Code: + +(require 'widget) + +(autoload 'pp-to-string "pp") +(autoload 'finder-commentary "finder" nil t) + +;;; Customization. + +(defgroup widgets nil + "Customization support for the Widget Library." + :link '(custom-manual "(widget)Top") + :link '(url-link :tag "Development Page" + "http://www.dina.kvl.dk/~abraham/custom/") + :link '(emacs-library-link :tag "Lisp File" "widget.el") + :prefix "widget-" + :group 'extensions + :group 'hypermedia) + +(defgroup widget-documentation nil + "Options controling the display of documentation strings." + :group 'widgets) + +(defgroup widget-faces nil + "Faces used by the widget library." + :group 'widgets + :group 'faces) + +(defvar widget-documentation-face 'widget-documentation-face + "Face used for documentation strings in widges. +This exists as a variable so it can be set locally in certain buffers.") + +(defface widget-documentation-face '((((class color) + (background dark)) + (:foreground "lime green")) + (((class color) + (background light)) + (:foreground "dark green")) + (t nil)) + "Face used for documentation text." + :group 'widget-documentation + :group 'widget-faces) + +(defvar widget-button-face 'widget-button-face + "Face used for buttons in widges. +This exists as a variable so it can be set locally in certain buffers.") + +(defface widget-button-face '((t (:bold t))) + "Face used for widget buttons." + :group 'widget-faces) + +(defcustom widget-mouse-face 'highlight + "Face used for widget buttons when the mouse is above them." + :type 'face + :group 'widget-faces) + +(defface widget-field-face '((((class grayscale color) + (background light)) + (:background "gray85")) + (((class grayscale color) + (background dark)) + (:background "dim gray")) + (t + (:italic t))) + "Face used for editable fields." + :group 'widget-faces) + +;; Currently unused +;(defface widget-single-line-field-face '((((class grayscale color) +; (background light)) +; (:background "gray85")) +; (((class grayscale color) +; (background dark)) +; (:background "dim gray")) +; (t +; (:italic t))) +; "Face used for editable fields spanning only a single line." +; :group 'widget-faces) +; +;(defvar widget-single-line-display-table +; (let ((table (make-display-table))) +; (aset table 9 "^I") +; (aset table 10 "^J") +; table) +; "Display table used for single-line editable fields.") +; +;(set-face-display-table 'widget-single-line-field-face +; widget-single-line-display-table) + + +;; Some functions from this file have been ported to C for speed. +;; Setting this to t (*before* loading wid-edit.el) will make them +;; shadow the subrs. It should be used only for debugging purposes. +(defvar widget-shadow-subrs nil) + + +;;; Utility functions. +;; +;; These are not really widget specific. + +(when (or (not (fboundp 'widget-plist-member)) + widget-shadow-subrs) + ;; Recoded in C, for efficiency. It used to be a defsubst, but old + ;; compiled code won't fail -- it will just be slower. + (defun widget-plist-member (plist prop) + ;; Return non-nil if PLIST has the property PROP. + ;; PLIST is a property list, which is a list of the form + ;; (PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol. + ;; Unlike `plist-get', this allows you to distinguish between a missing + ;; property and a property with the value nil. + ;; The value is actually the tail of PLIST whose car is PROP. + (while (and plist (not (eq (car plist) prop))) + (setq plist (cddr plist))) + plist)) + +(defun widget-princ-to-string (object) + ;; Return string representation of OBJECT, any Lisp object. + ;; No quoting characters are used; no delimiters are printed around + ;; the contents of strings. + (with-current-buffer (get-buffer-create " *widget-tmp*") + (erase-buffer) + (princ object (current-buffer)) + (buffer-string))) + +(defun widget-clear-undo () + "Clear all undo information." + (buffer-disable-undo) + (buffer-enable-undo)) + +(defcustom widget-menu-max-size 40 + "Largest number of items allowed in a popup-menu. +Larger menus are read through the minibuffer." + :group 'widgets + :type 'integer) + +(defcustom widget-menu-minibuffer-flag nil + "*Control how to ask for a choice from the keyboard. +Non-nil means use the minibuffer; +nil means read a single character." + :group 'widgets + :type 'boolean) + +(defun widget-choose (title items &optional event) + "Choose an item from a list. + +First argument TITLE is the name of the list. +Second argument ITEMS is an list whose members are either + (NAME . VALUE), to indicate selectable items, or just strings to + indicate unselectable items. +Optional third argument EVENT is an input event. + +The user is asked to choose between each NAME from the items alist, +and the VALUE of the chosen element will be returned. If EVENT is a +mouse event, and the number of elements in items is less than +`widget-menu-max-size', a popup menu will be used, otherwise the +minibuffer." + (cond ((and (< (length items) widget-menu-max-size) + event + (console-on-window-system-p)) + ;; Pressed by the mouse. + (let ((val (get-popup-menu-response + (cons title + (mapcar (lambda (x) + (if (stringp x) + (vector x nil nil) + (vector (car x) (list (car x)) t))) + items))))) + (setq val (and val + (listp (event-object val)) + (stringp (car-safe (event-object val))) + (car (event-object val)))) + (cdr (assoc val items)))) + ((and (not widget-menu-minibuffer-flag) + ;; Can't handle more than 10 items (as many digits) + (<= (length items) 10)) + ;; Construct a menu of the choices + ;; and then use it for prompting for a single character. + (let* ((overriding-terminal-local-map (make-sparse-keymap)) + (map (make-sparse-keymap title)) + (next-digit ?0) + some-choice-enabled value) + ;; Define SPC as a prefix char to get to this menu. + (define-key overriding-terminal-local-map " " map) + (with-current-buffer (get-buffer-create " widget-choose") + (erase-buffer) + (insert "Available choices:\n\n") + (dolist (choice items) + (when (consp choice) + (let* ((name (car choice)) + (function (cdr choice))) + (insert (format "%c = %s\n" next-digit name)) + (define-key map (vector next-digit) function) + (setq some-choice-enabled t))) + ;; Allocate digits to disabled alternatives + ;; so that the digit of a given alternative never varies. + (incf next-digit)) + (insert "\nC-g = Quit")) + (or some-choice-enabled + (error "None of the choices is currently meaningful")) + (define-key map [?\C-g] 'keyboard-quit) + (define-key map [t] 'keyboard-quit) + ;(setcdr map (nreverse (cdr map))) + ;; Unread a SPC to lead to our new menu. + (push (character-to-event ?\ ) unread-command-events) + ;; Read a char with the menu, and return the result + ;; that corresponds to it. + (save-window-excursion + (display-buffer (get-buffer " widget-choose")) + (let ((cursor-in-echo-area t)) + (setq value + (lookup-key overriding-terminal-local-map + (read-key-sequence (concat title ": ") t))))) + (message "") + (when (or (eq value 'keyboard-quit) + (null value)) + (error "Canceled")) + value)) + (t + ;; Read the choice of name from the minibuffer. + (setq items (remove-if 'stringp items)) + (let ((val (completing-read (concat title ": ") items nil t))) + (if (stringp val) + (let ((try (try-completion val items))) + (when (stringp try) + (setq val try)) + (cdr (assoc val items))) + nil))))) + + +;;; Widget text specifications. +;; +;; These functions are for specifying text properties. + +(defcustom widget-field-add-space t + ;; Setting this to nil might be available, once some problems are resolved. + "Non-nil means add extra space at the end of editable text fields. + +This is needed on all versions of Emacs. If you don't add the space, +it will become impossible to edit a zero size field." + :type 'boolean + :group 'widgets) + +(defcustom widget-field-use-before-change + (and (or (> emacs-minor-version 34) + (> emacs-major-version 19)) + (not (string-match "XEmacs" emacs-version))) + "Non-nil means use `before-change-functions' to track editable fields. +This enables the use of undo, but doesn't work on Emacs 19.34 and earlier. +Using before hooks also means that the :notify function can't know the +new value." + :type 'boolean + :group 'widgets) + +(defun widget-specify-field (widget from to) + "Specify editable button for WIDGET between FROM and TO." + (save-excursion + (goto-char to) + (cond ((null (widget-get widget :size)) + (forward-char 1)) + ;; Terminating space is not part of the field, but necessary in + ;; order for local-map to work. Remove next sexp if local-map works + ;; at the end of the extent. + (widget-field-add-space + (insert-and-inherit " "))) + (setq to (point))) + (let ((map (widget-get widget :keymap)) + (face (or (widget-get widget :value-face) 'widget-field-face)) + (help-echo (widget-get widget :help-echo)) + (extent (make-extent from to))) + (unless (or (stringp help-echo) (null help-echo)) + (setq help-echo 'widget-mouse-help)) + (widget-put widget :field-extent extent) + (and (or (not widget-field-add-space) + (widget-get widget :size)) + (set-extent-property extent 'end-closed nil)) + (set-extent-property extent 'detachable nil) + (set-extent-property extent 'field widget) + (set-extent-property extent 'button-or-field t) + (set-extent-property extent 'keymap map) + (set-extent-property extent 'face face) + (set-extent-property extent 'balloon-help help-echo) + (set-extent-property extent 'help-echo help-echo))) + +(defun widget-specify-button (widget from to) + "Specify button for WIDGET between FROM and TO." + (let ((face (widget-apply widget :button-face-get)) + (help-echo (widget-get widget :help-echo)) + (extent (make-extent from to)) + (map (widget-get widget :button-keymap))) + (widget-put widget :button-extent extent) + (unless (or (null help-echo) (stringp help-echo)) + (setq help-echo 'widget-mouse-help)) + (set-extent-property extent 'start-open t) + (set-extent-property extent 'button widget) + (set-extent-property extent 'button-or-field t) + (set-extent-property extent 'mouse-face widget-mouse-face) + (set-extent-property extent 'balloon-help help-echo) + (set-extent-property extent 'help-echo help-echo) + (set-extent-property extent 'face face) + (set-extent-property extent 'keymap map))) + +(defun widget-mouse-help (extent) + "Find mouse help string for button in extent." + (let* ((widget (widget-at (extent-start-position extent))) + (help-echo (and widget (widget-get widget :help-echo)))) + (cond ((stringp help-echo) + help-echo) + ((and (functionp help-echo) + (stringp (setq help-echo (funcall help-echo widget)))) + help-echo) + (t + (format "(widget %S :help-echo %S)" widget help-echo))))) + +(defun widget-specify-sample (widget from to) + ;; Specify sample for WIDGET between FROM and TO. + (let ((face (widget-apply widget :sample-face-get)) + (extent (make-extent from to nil))) + (set-extent-property extent 'start-open t) + (set-extent-property extent 'face face) + (widget-put widget :sample-extent extent))) + +(defun widget-specify-doc (widget from to) + ;; Specify documentation for WIDGET between FROM and TO. + (let ((extent (make-extent from to))) + (set-extent-property extent 'start-open t) + (set-extent-property extent 'widget-doc widget) + (set-extent-property extent 'face widget-documentation-face) + (widget-put widget :doc-extent extent))) + +(defmacro widget-specify-insert (&rest form) + ;; Execute FORM without inheriting any text properties. + `(save-restriction + (let ((inhibit-read-only t) + before-change-functions + after-change-functions) + (insert "<>") + (narrow-to-region (- (point) 2) (point)) + (goto-char (1+ (point-min))) + ;; We use `prog1' instead of a `result' variable, as the latter + ;; confuses the byte-compiler in some cases (a warning). + (prog1 (progn ,@form) + (delete-region (point-min) (1+ (point-min))) + (delete-region (1- (point-max)) (point-max)) + (goto-char (point-max)))))) + +(put 'widget-specify-insert 'edebug-form-spec '(&rest form)) + + +;;; Inactive Widgets. + +(defface widget-inactive-face '((((class grayscale color) + (background dark)) + (:foreground "light gray")) + (((class grayscale color) + (background light)) + (:foreground "dim gray")) + (t + (:italic t))) + "Face used for inactive widgets." + :group 'widget-faces) + +;; For inactiveness to work on complex structures, it is not +;; sufficient to keep track of whether a button/field/glyph is +;; inactive or not -- we must know how many time it was deactivated +;; (inactiveness level). Successive deactivations of the same button +;; increment its inactive-count, and activations decrement it. When +;; inactive-count reaches 0, the button/field/glyph is reactivated. + +(defun widget-activation-widget-mapper (extent action) + "Activate or deactivate EXTENT's widget (button or field). +Suitable for use with `map-extents'." + (ecase action + (:activate + (decf (extent-property extent :inactive-count)) + (when (zerop (extent-property extent :inactive-count)) + (set-extent-properties + extent (extent-property extent :inactive-plist)) + (set-extent-property extent :inactive-plist nil))) + (:deactivate + (incf (extent-property extent :inactive-count 0)) + ;; Store a plist of old properties, which will be fed to + ;; `set-extent-properties'. + (unless (extent-property extent :inactive-plist) + (set-extent-property + extent :inactive-plist + (list 'mouse-face (extent-property extent 'mouse-face) + 'help-echo (extent-property extent 'help-echo) + 'keymap (extent-property extent 'keymap))) + (set-extent-properties + extent '(mouse-face nil help-echo nil keymap nil))))) + nil) + +(defun widget-activation-glyph-mapper (extent action) + (let ((activate-p (if (eq action :activate) t nil))) + (if activate-p + (decf (extent-property extent :inactive-count)) + (incf (extent-property extent :inactive-count 0))) + (when (or (and activate-p + (zerop (extent-property extent :inactive-count))) + (and (not activate-p) + (not (zerop (extent-property extent :inactive-count))))) + (let* ((glyph-widget (extent-property extent 'glyph-widget)) + (up-glyph (widget-get glyph-widget :glyph-up)) + (inactive-glyph (widget-get glyph-widget :glyph-inactive)) + (new-glyph (if activate-p up-glyph inactive-glyph))) + ;; Check that the new glyph exists, and differs from the + ;; default one. + (and up-glyph inactive-glyph (not (eq up-glyph inactive-glyph)) + ;; Check if the glyph is already installed. + (not (eq (extent-end-glyph extent) new-glyph)) + ;; Change it. + (set-extent-end-glyph extent new-glyph))))) + nil) + +(defun widget-specify-inactive (widget from to) + "Make WIDGET inactive for user modifications." + (unless (widget-get widget :inactive) + (let ((extent (make-extent from to))) + ;; It is no longer necessary for the extent to be read-only, as + ;; the inactive editable fields now lose their keymaps. + (set-extent-properties + extent '(start-open t face widget-inactive-face + detachable t priority 2001 widget-inactive t)) + (widget-put widget :inactive extent)) + ;; Deactivate the buttons and fields within the range. In some + ;; cases, the fields are not yet setup at the time this function + ;; is called. Those fields are deactivated explicitly by + ;; `widget-setup'. + (map-extents 'widget-activation-widget-mapper + nil from to :deactivate nil 'button-or-field) + ;; Deactivate glyphs. + (map-extents 'widget-activation-glyph-mapper + nil from to :deactivate nil 'glyph-widget))) + +(defun widget-specify-active (widget) + "Make WIDGET active for user modifications." + (let ((inactive (widget-get widget :inactive))) + (when inactive + ;; Reactivate the buttons and fields covered by the extent. + (map-extents 'widget-activation-widget-mapper + inactive nil nil :activate nil 'button-or-field) + ;; Reactivate the glyphs. + (map-extents 'widget-activation-glyph-mapper + inactive nil nil :activate nil 'end-glyph) + (delete-extent inactive) + (widget-put widget :inactive nil)))) + + +;;; Widget Properties. + +(defsubst widget-type (widget) + "Return the type of WIDGET, a symbol." + (car widget)) + +(when (or (not (fboundp 'widget-put)) + widget-shadow-subrs) + (defun widget-put (widget property value) + "In WIDGET set PROPERTY to VALUE. +The value can later be retrived with `widget-get'." + (setcdr widget (plist-put (cdr widget) property value)))) + +;; Recoded in C, for efficiency: +(when (or (not (fboundp 'widget-get)) + widget-shadow-subrs) + (defun widget-get (widget property) + "In WIDGET, get the value of PROPERTY. +The value could either be specified when the widget was created, or +later with `widget-put'." + (let ((missing t) + value tmp) + (while missing + (cond ((setq tmp (widget-plist-member (cdr widget) property)) + (setq value (car (cdr tmp)) + missing nil)) + ((setq tmp (car widget)) + (setq widget (get tmp 'widget-type))) + (t + (setq missing nil)))) + value))) + +(defun widget-get-indirect (widget property) + "In WIDGET, get the value of PROPERTY. +If the value is a symbol, return its binding. +Otherwise, just return the value." + (let ((value (widget-get widget property))) + (if (symbolp value) + (symbol-value value) + value))) + +(defun widget-member (widget property) + "Non-nil iff there is a definition in WIDGET for PROPERTY." + (cond ((widget-plist-member (cdr widget) property) + t) + ((car widget) + (widget-member (get (car widget) 'widget-type) property)) + (t nil))) + +(when (or (not (fboundp 'widget-apply)) + widget-shadow-subrs) + ;;This is in C, so don't ###utoload + (defun widget-apply (widget property &rest args) + "Apply the value of WIDGET's PROPERTY to the widget itself. +ARGS are passed as extra arguments to the function." + (apply (widget-get widget property) widget args))) + +(defun widget-value (widget) + "Extract the current value of WIDGET." + (widget-apply widget + :value-to-external (widget-apply widget :value-get))) + +(defun widget-value-set (widget value) + "Set the current value of WIDGET to VALUE." + (widget-apply widget + :value-set (widget-apply widget + :value-to-internal value))) + +(defun widget-match-inline (widget vals) + ;; In WIDGET, match the start of VALS. + (cond ((widget-get widget :inline) + (widget-apply widget :match-inline vals)) + ((and vals + (widget-apply widget :match (car vals))) + (cons (list (car vals)) (cdr vals))) + (t nil))) + +(defun widget-apply-action (widget &optional event) + "Apply :action in WIDGET in response to EVENT." + (if (widget-apply widget :active) + (widget-apply widget :action event) + (error "Attempt to perform action on inactive widget"))) + + +;;; Helper functions. +;; +;; These are widget specific. + +;;;###autoload +(defun widget-prompt-value (widget prompt &optional value unbound) + "Prompt for a value matching WIDGET, using PROMPT. +The current value is assumed to be VALUE, unless UNBOUND is non-nil." + (unless (listp widget) + (setq widget (list widget))) + (setq prompt (format "[%s] %s" (widget-type widget) prompt)) + (setq widget (widget-convert widget)) + (let ((answer (widget-apply widget :prompt-value prompt value unbound))) + (unless (widget-apply widget :match answer) + (error "Value does not match %S type." (car widget))) + answer)) + +(defun widget-get-sibling (widget) + "Get the item WIDGET is assumed to toggle. +This is only meaningful for radio buttons or checkboxes in a list." + (let* ((parent (widget-get widget :parent)) + (children (widget-get parent :children)) + child) + (catch 'child + (while children + (setq child (car children) + children (cdr children)) + (when (eq (widget-get child :button) widget) + (throw 'child child))) + nil))) + +(defun widget-map-buttons (function &optional buffer maparg) + "Map FUNCTION over the buttons in BUFFER. +FUNCTION is called with the arguments WIDGET and MAPARG. + +If FUNCTION returns non-nil, the walk is cancelled. + +The arguments MAPARG, and BUFFER default to nil and (current-buffer), +respectively." + (map-extents (lambda (extent ignore) + ;; If FUNCTION returns non-nil, we bail out + (funcall function (extent-property extent 'button) maparg)) + nil nil nil nil nil + 'button)) + + +;;; Glyphs. + +(defcustom widget-glyph-directory (locate-data-directory "custom") + "Where widget glyphs are located. +If this variable is nil, widget will try to locate the directory +automatically." + :group 'widgets + :type 'directory) + +(defcustom widget-glyph-enable t + "If non nil, use glyphs in images when available." + :group 'widgets + :type 'boolean) + +(defcustom widget-image-conversion + '((xpm ".xpm") (gif ".gif") (png ".png") (jpeg ".jpg" ".jpeg") + (xbm ".xbm")) + "Conversion alist from image formats to file name suffixes." + :group 'widgets + :type '(repeat (cons :format "%v" + (symbol :tag "Image Format" unknown) + (repeat :tag "Suffixes" + (string :format "%v"))))) + +(defvar widget-glyph-cache nil + "Cache of glyphs associated with strings (files).") + +(defun widget-glyph-find (image tag) + "Create a glyph corresponding to IMAGE with string TAG as fallback. +IMAGE can already be a glyph, or a file name sans extension (xpm, + xbm, gif, jpg, or png) located in `widget-glyph-directory', or + in one of the data directories. +It can also be a valid image instantiator, in which case it will be + used to make the glyph, with an additional TAG string fallback." + (cond ((not (and image widget-glyph-enable)) + ;; We don't want to use glyphs. + nil) + ((and (not (console-on-window-system-p)) + ;; We don't use glyphs on TTY consoles, although we + ;; could. However, glyph faces aren't yet working + ;; properly, and movement through glyphs is unintuitive. + ;; As an exception, when TAG is nil, we assume that the + ;; caller knows what he is doing, and that the tag is + ;; encoded within the glyph. + (not (glyphp image))) + nil) + ((glyphp image) + ;; Already a glyph. Use it. + image) + ((stringp image) + ;; A string. Look it up in the cache first... + (or (lax-plist-get widget-glyph-cache image) + ;; ...and then in the relevant directories + (let* ((dirlist (cons (or widget-glyph-directory + (locate-data-directory "custom")) + data-directory-list)) + (formats widget-image-conversion) + file) + (while (and formats (not file)) + ;; This dance is necessary, because XEmacs signals an + ;; error when it encounters an unrecognized image + ;; format. + (when (valid-image-instantiator-format-p (caar formats)) + (setq file (locate-file image dirlist + (mapconcat 'identity (cdar formats) + ":")))) + (unless file + (pop formats))) + (when file + ;; We create a glyph with the file as the default image + ;; instantiator, and the TAG fallback + (let ((glyph (make-glyph `([,(caar formats) :file ,file] + [string :data ,tag])))) + ;; Cache the glyph + (laxputf widget-glyph-cache image glyph) + ;; ...and return it + glyph))))) + ((valid-instantiator-p image 'image) + ;; A valid image instantiator (e.g. [gif :file "somefile"] etc.) + (make-glyph `(,image [string :data ,tag]))) + (t + ;; Oh well. + nil))) + +(defun widget-glyph-insert (widget tag image &optional down inactive) + "In WIDGET, insert the text TAG or, if supported, IMAGE. +IMAGE should either be a glyph, an image instantiator, an image file +name sans extension (xpm, xbm, gif, jpg, or png) located in +`widget-glyph-directory', or anything else allowed by +`widget-glyph-find'. + +If IMAGE is a list, it will be taken as a list of (UP DOWN INACTIVE) +glyphs. The down and inactive glyphs are shown when glyph is pressed +or inactive, respectively. + +The optional DOWN and INACTIVE arguments are deprecated, and exist +only because of compatibility." + ;; Convert between IMAGE being a list, etc. Must use `psetq', + ;; because otherwise change to `image' screws up the rest. + (psetq image (or (and (consp image) + (car image)) + image) + down (or (and (consp image) + (nth 1 image)) + down) + inactive (or (and (consp image) + (nth 2 image)) + inactive)) + (let ((glyph (widget-glyph-find image tag))) + (if glyph + (widget-glyph-insert-glyph widget glyph + (widget-glyph-find down tag) + (widget-glyph-find inactive tag)) + (insert tag)) + glyph)) + +(defun widget-glyph-insert-glyph (widget glyph &optional down inactive) + "In WIDGET, insert GLYPH. +If optional arguments DOWN and INACTIVE are given, they should be +glyphs used when the widget is pushed and inactive, respectively." + (insert "*") + (let ((extent (make-extent (point) (1- (point)))) + (help-echo (and widget (widget-get widget :help-echo))) + (map (and widget (widget-get widget :button-keymap)))) + (set-extent-property extent 'glyph-widget widget) + ;; It would be fun if we could make this extent atomic, so it + ;; doesn't mess with cursor motion. But atomic-extents library is + ;; currently a mess, so I'd rather not use it. + (set-extent-property extent 'invisible t) + (set-extent-property extent 'start-open t) + (set-extent-property extent 'end-open t) + (set-extent-property extent 'keymap map) + (set-extent-end-glyph extent glyph) + (unless (or (stringp help-echo) (null help-echo)) + (setq help-echo 'widget-mouse-help)) + (when help-echo + (set-extent-property extent 'balloon-help help-echo) + (set-extent-property extent 'help-echo help-echo))) + (when widget + (widget-put widget :glyph-up glyph) + (when down (widget-put widget :glyph-down down)) + (when inactive (widget-put widget :glyph-inactive inactive)))) + + +;;; Buttons. + +(defgroup widget-button nil + "The look of various kinds of buttons." + :group 'widgets) + +(defcustom widget-button-prefix "" + "String used as prefix for buttons." + :type 'string + :group 'widget-button) + +(defcustom widget-button-suffix "" + "String used as suffix for buttons." + :type 'string + :group 'widget-button) + + +;;; Creating Widgets. + +;;;###autoload +(defun widget-create (type &rest args) + "Create widget of TYPE. +The optional ARGS are additional keyword arguments." + (let ((widget (apply 'widget-convert type args))) + (widget-apply widget :create) + widget)) + +(defun widget-create-child-and-convert (parent type &rest args) + "As part of the widget PARENT, create a child widget TYPE. +The child is converted, using the keyword arguments ARGS." + (let ((widget (apply 'widget-convert type args))) + (widget-put widget :parent parent) + (unless (widget-get widget :indent) + (widget-put widget :indent (+ (or (widget-get parent :indent) 0) + (or (widget-get widget :extra-offset) 0) + (widget-get parent :offset)))) + (widget-apply widget :create) + widget)) + +(defun widget-create-child (parent type) + "Create widget of TYPE." + (let ((widget (copy-sequence type))) + (widget-put widget :parent parent) + (unless (widget-get widget :indent) + (widget-put widget :indent (+ (or (widget-get parent :indent) 0) + (or (widget-get widget :extra-offset) 0) + (widget-get parent :offset)))) + (widget-apply widget :create) + widget)) + +(defun widget-create-child-value (parent type value) + "Create widget of TYPE with value VALUE." + (let ((widget (copy-sequence type))) + (widget-put widget :value (widget-apply widget :value-to-internal value)) + (widget-put widget :parent parent) + (unless (widget-get widget :indent) + (widget-put widget :indent (+ (or (widget-get parent :indent) 0) + (or (widget-get widget :extra-offset) 0) + (widget-get parent :offset)))) + (widget-apply widget :create) + widget)) + +;;;###autoload +(defun widget-delete (widget) + "Delete WIDGET." + (widget-apply widget :delete)) + +(defun widget-convert (type &rest args) + "Convert TYPE to a widget without inserting it in the buffer. +The optional ARGS are additional keyword arguments." + ;; Don't touch the type. + (let* ((widget (if (symbolp type) + (list type) + (copy-sequence type))) + (current widget) + (keys args)) + ;; First set the :args keyword. + (while (cdr current) ;Look in the type. + (let ((next (car (cdr current)))) + (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:)) + (setq current (cdr (cdr current))) + (setcdr current (list :args (cdr current))) + (setq current nil)))) + (while args ;Look in the args. + (let ((next (nth 0 args))) + (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:)) + (setq args (nthcdr 2 args)) + (widget-put widget :args args) + (setq args nil)))) + ;; Then Convert the widget. + (setq type widget) + (while type + (let ((convert-widget (plist-get (cdr type) :convert-widget))) + (if convert-widget + (setq widget (funcall convert-widget widget)))) + (setq type (get (car type) 'widget-type))) + ;; Finally set the keyword args. + (while keys + (let ((next (nth 0 keys))) + (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:)) + (progn + (widget-put widget next (nth 1 keys)) + (setq keys (nthcdr 2 keys))) + (setq keys nil)))) + ;; Convert the :value to internal format. + (if (widget-member widget :value) + (let ((value (widget-get widget :value))) + (widget-put widget + :value (widget-apply widget :value-to-internal value)))) + ;; Return the newly created widget. + widget)) + +(defun widget-insert (&rest args) + "Call `insert' with ARGS and make the text read only." + (let ((inhibit-read-only t) + before-change-functions + after-change-functions) + (apply 'insert args))) + +(defun widget-convert-text (type from to + &optional button-from button-to + &rest args) + "Return a widget of type TYPE with endpoint FROM TO. +Optional ARGS are extra keyword arguments for TYPE. +and TO will be used as the widgets end points. If optional arguments +BUTTON-FROM and BUTTON-TO are given, these will be used as the widgets +button end points. +Optional ARGS are extra keyword arguments for TYPE." + (let ((widget (apply 'widget-convert type :delete 'widget-leave-text args)) + (from (copy-marker from)) + (to (copy-marker to))) + (set-marker-insertion-type from t) + (set-marker-insertion-type to nil) + (widget-put widget :from from) + (widget-put widget :to to) + (when button-from + (widget-specify-button widget button-from button-to)) + widget)) + +(defun widget-convert-button (type from to &rest args) + "Return a widget of type TYPE with endpoint FROM TO. +Optional ARGS are extra keyword arguments for TYPE. +No text will be inserted to the buffer, instead the text between FROM +and TO will be used as the widgets end points, as well as the widgets +button end points." + (apply 'widget-convert-text type from to from to args)) + +(defun widget-leave-text (widget) + "Remove markers and extents from WIDGET and its children." + (let ((from (widget-get widget :from)) + (to (widget-get widget :to)) + (button (widget-get widget :button-extent)) + (sample (widget-get widget :sample-extent)) + (doc (widget-get widget :doc-extent)) + (field (widget-get widget :field-extent)) + (children (widget-get widget :children))) + (set-marker from nil) + (set-marker to nil) + ;; Maybe we should delete the extents here? As this code doesn't + ;; remove them from widget structures, maybe it's safer to just + ;; detach them. That's what `delete-overlay' did. + (when button + (detach-extent button)) + (when sample + (detach-extent sample)) + (when doc + (detach-extent doc)) + (when field + (detach-extent field)) + (mapc 'widget-leave-text children))) + + +;;; Keymap and Commands. + +(defvar widget-keymap nil + "Keymap containing useful binding for buffers containing widgets. +Recommended as a parent keymap for modes using widgets.") + +(unless widget-keymap + (setq widget-keymap (make-sparse-keymap)) + (define-key widget-keymap [tab] 'widget-forward) + (define-key widget-keymap [(shift tab)] 'widget-backward) + (define-key widget-keymap [(meta tab)] 'widget-backward) + (define-key widget-keymap [backtab] 'widget-backward)) + +(defvar widget-global-map global-map + "Keymap used for events the widget does not handle themselves.") +(make-variable-buffer-local 'widget-global-map) + +(defvar widget-field-keymap nil + "Keymap used inside an editable field.") + +(unless widget-field-keymap + (setq widget-field-keymap (make-sparse-keymap)) + (set-keymap-parents widget-field-keymap global-map) + (define-key widget-field-keymap "\C-k" 'widget-kill-line) + (define-key widget-field-keymap [(meta tab)] 'widget-complete) + (define-key widget-field-keymap [tab] 'widget-forward) + (define-key widget-field-keymap [(shift tab)] 'widget-backward) + (define-key widget-field-keymap "\C-m" 'widget-field-activate) + (define-key widget-field-keymap "\C-a" 'widget-beginning-of-line) + (define-key widget-field-keymap "\C-e" 'widget-end-of-line) + (define-key widget-field-keymap "\C-t" 'widget-transpose-chars)) + +(defvar widget-text-keymap nil + "Keymap used inside a text field.") + +(unless widget-text-keymap + (setq widget-text-keymap (make-sparse-keymap)) + (set-keymap-parents widget-field-keymap global-map) + (define-key widget-text-keymap "\C-a" 'widget-beginning-of-line) + (define-key widget-text-keymap "\C-e" 'widget-end-of-line) + (define-key widget-text-keymap "\C-t" 'widget-transpose-chars)) + +(defvar widget-button-keymap nil + "Keymap used inside a button.") + +(unless widget-button-keymap + (setq widget-button-keymap (make-sparse-keymap)) + (set-keymap-parents widget-button-keymap widget-keymap) + (define-key widget-button-keymap "\C-m" 'widget-button-press) + (define-key widget-button-keymap [button2] 'widget-button-click) + ;; Ideally, button3 within a button should invoke a button-specific + ;; menu. + (define-key widget-button-keymap [button3] 'widget-button-click) + ;;Glyph support. + (define-key widget-button-keymap [button1] 'widget-button1-click)) + + +(defun widget-field-activate (pos &optional event) + "Invoke the ediable field at point." + (interactive "@d") + (let ((field (widget-field-find pos))) + (if field + (widget-apply-action field event) + (call-interactively + (lookup-key widget-global-map (this-command-keys)))))) + +(defface widget-button-pressed-face + '((((class color)) + (:foreground "red")) + (t + (:bold t :underline t))) + "Face used for pressed buttons." + :group 'widget-faces) + +(defun widget-event-point (event) + "Character position of the mouse event, or nil." + (and (mouse-event-p event) + (event-point event))) + +(defun widget-button-click (event) + "Invoke button below mouse pointer." + (interactive "@e") + (cond ((event-glyph event) + (widget-glyph-click event)) + ((widget-event-point event) + (let* ((pos (widget-event-point event)) + (button (get-char-property pos 'button))) + (if button + (let* ((extent (widget-get button :button-extent)) + (face (extent-property extent 'face)) + (mouse-face (extent-property extent 'mouse-face)) + (help-echo (extent-property extent 'help-echo))) + (unwind-protect + (progn + ;; Merge relevant faces, and make the result mouse-face. + (let ((merge `(widget-button-pressed-face ,mouse-face))) + (nconc merge (if (listp face) + face (list face))) + (setq merge (delete-if-not 'find-face merge)) + (set-extent-property extent 'mouse-face merge)) + (unless (widget-apply button :mouse-down-action event) + ;; Wait for button release. + (while (not (button-release-event-p + (setq event (next-event)))) + (dispatch-event event))) + ;; Disallow mouse-face and help-echo. + (set-extent-property extent 'mouse-face nil) + (set-extent-property extent 'help-echo nil) + (setq pos (widget-event-point event)) + (unless (eq (current-buffer) (extent-object extent)) + ;; Barf if dispatch-event tripped us by + ;; changing buffer. + (error "Buffer changed during mouse motion")) + ;; Do the associated action. + (when (and pos (extent-in-region-p extent pos pos)) + (widget-apply-action button event))) + ;; Unwinding: fully release the button. + (set-extent-property extent 'mouse-face mouse-face) + (set-extent-property extent 'help-echo help-echo))) + ;; This should not happen! + (error "`widget-button-click' called outside button")))) + (t + (message "You clicked somewhere weird")))) + +(defun widget-button1-click (event) + "Invoke glyph below mouse pointer." + (interactive "@e") + (if (event-glyph event) + (widget-glyph-click event) + ;; Should somehow avoid this. + (let ((command (lookup-key widget-global-map (this-command-keys)))) + (and (commandp command) + (call-interactively command))))) + +(defun widget-glyph-click (event) + "Handle click on a glyph." + (let* ((glyph (event-glyph event)) + (extent (event-glyph-extent event)) + (widget (extent-property extent 'glyph-widget)) + (down-glyph (or (and widget (widget-get widget :glyph-down)) glyph)) + (up-glyph (or (and widget (widget-get widget :glyph-up)) glyph)) + (last event)) + (unless (widget-apply widget :active) + (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? + (unwind-protect + (progn + ;; Press the glyph. + (set-extent-end-glyph extent down-glyph) + ;; Redisplay (shouldn't be needed, but...) + (sit-for 0) + (unless (widget-apply widget :mouse-down-action event) + ;; Wait for the release. + (while (not (button-release-event-p last)) + (unless (button-press-event-p last) + (dispatch-event last)) + (when (motion-event-p last) + ;; Update glyphs on mouse motion. + (if (eq extent (event-glyph-extent last)) + (unless (eq current-glyph 'down) + (set-extent-end-glyph extent down-glyph) + (setq current-glyph 'down)) + (unless (eq current-glyph 'up) + (set-extent-end-glyph extent up-glyph) + (setq current-glyph 'up)))) + (setq last (next-event event)))) + (unless (eq (current-buffer) (extent-object extent)) + ;; Barf if dispatch-event tripped us by changing buffer. + (error "Buffer changed during mouse motion")) + ;; Apply widget action. + (when (eq extent (event-glyph-extent last)) + (let ((widget (extent-property (event-glyph-extent event) + 'glyph-widget))) + (cond ((null widget) + (message "You clicked on a glyph")) + ((not (widget-apply widget :active)) + (error "This glyph is inactive")) + (t + (widget-apply-action widget event)))))) + ;; Release the glyph. + (and (eq current-glyph 'down) + ;; The extent might have been detached or deleted + (extent-live-p extent) + (not (extent-detached-p extent)) + (set-extent-end-glyph extent up-glyph)))))) + +(defun widget-button-press (pos &optional event) + "Invoke button at POS." + (interactive "@d") + (let ((button (get-char-property pos 'button))) + (if button + (widget-apply-action button event) + (let ((command (lookup-key widget-global-map (this-command-keys)))) + (when (commandp command) + (call-interactively command)))))) + +(defun widget-tabable-at (&optional pos last-tab backwardp) + "Return the tabable widget at POS, or nil. +POS defaults to the value of (point)." + (unless pos + (setq pos (point))) + (let ((widget (widget-at pos))) + (if widget + (let ((order (widget-get widget :tab-order))) + (if order + (if last-tab (and (= order (if backwardp + (1- last-tab) + (1+ last-tab))) + widget) + (and (> order 0) widget)) + widget)) + nil))) + +;; Return the button or field extent at point. +(defun widget-button-or-field-extent (pos) + (or (and (get-char-property pos 'button) + (widget-get (get-char-property pos 'button) + :button-extent)) + (and (get-char-property pos 'field) + (widget-get (get-char-property pos 'field) + :field-extent)))) + +(defun widget-next-button-or-field (pos) + "Find the next button, or field, and return its start position, or nil. +Internal function, don't use it outside `wid-edit'." + (let* ((at-point (widget-button-or-field-extent pos)) + (extent (map-extents + (lambda (ext ignore) + ext) + nil (if at-point (extent-end-position at-point) pos) + nil nil 'start-open 'button-or-field))) + (and extent + (extent-start-position extent)))) + +;; This is too slow in buffers with many buttons (W3). +(defun widget-previous-button-or-field (pos) + "Find the previous button, or field, and return its start position, or nil. +Internal function, don't use it outside `wid-edit'." + (let* ((at-point (widget-button-or-field-extent pos)) + previous-extent) + (map-extents + (lambda (ext ignore) + (if (eq ext at-point) + ;; We reached the extent we were on originally + (if (= pos (extent-start-position at-point)) + previous-extent + (setq previous-extent at-point)) + (setq previous-extent ext) + nil)) + nil nil pos nil 'start-open 'button-or-field) + (and previous-extent + (extent-start-position previous-extent)))) + +(defun widget-move (arg) + "Move point to the ARG next field or button. +ARG may be negative to move backward." + (let ((opoint (point)) (wrapped 0) + (last-tab (widget-get (widget-at (point)) :tab-order)) + nextpos found) + ;; Movement backward + (while (< arg 0) + (setq nextpos (widget-previous-button-or-field (point))) + (if nextpos + (progn + (goto-char nextpos) + (when (and (not (get-char-property nextpos 'widget-inactive)) + (widget-tabable-at nil last-tab t)) + (incf arg) + (setq found t + last-tab (widget-get (widget-at (point)) + :tab-order)))) + (if (and (not found) (> wrapped 1)) + (setq arg 0 + found nil) + (goto-char (point-max)) + (incf wrapped)))) + ;; Movement forward + (while (> arg 0) + (setq nextpos (widget-next-button-or-field (point))) + (if nextpos + (progn + (goto-char nextpos) + (when (and (not (get-char-property nextpos 'widget-inactive)) + (widget-tabable-at nil last-tab)) + (decf arg) + (setq found t + last-tab (widget-get (widget-at (point)) + :tab-order)))) + (if (and (not found) (> wrapped 1)) + (setq arg 0 + found nil) + (goto-char (point-min)) + (incf wrapped)))) + (if (not found) + (goto-char opoint) + (widget-echo-help (point)) + (run-hooks 'widget-move-hook)))) + +(defun widget-forward (arg) + "Move point to the next field or button. +With optional ARG, move across that many fields." + (interactive "p") + (run-hooks 'widget-forward-hook) + (widget-move arg)) + +(defun widget-backward (arg) + "Move point to the previous field or button. +With optional ARG, move across that many fields." + (interactive "p") + (run-hooks 'widget-backward-hook) + (widget-move (- arg))) + +(defun widget-beginning-of-line () + "Go to beginning of field or beginning of line, whichever is first." + (interactive "_") + (let* ((field (widget-field-find (point))) + (start (and field (widget-field-start field)))) + (if (and start (not (eq start (point)))) + (goto-char start) + (call-interactively 'beginning-of-line)))) + +(defun widget-end-of-line () + "Go to end of field or end of line, whichever is first." + (interactive "_") + (let* ((field (widget-field-find (point))) + (end (and field (widget-field-end field)))) + (if (and end (not (eq end (point)))) + (goto-char end) + (call-interactively 'end-of-line)))) + +(defun widget-kill-line () + "Kill to end of field or end of line, whichever is first." + (interactive) + (let* ((field (widget-field-find (point))) + (newline (save-excursion (forward-line 1) (point))) + (end (and field (widget-field-end field)))) + (if (and field (> newline end)) + (kill-region (point) end) + (call-interactively 'kill-line)))) + +(defun widget-transpose-chars (arg) + "Like `transpose-chars', but works correctly at end of widget." + (interactive "*P") + (let* ((field (widget-field-find (point))) + (start (and field (widget-field-start field))) + (end (and field (widget-field-end field))) + (last-non-space (and start end + (save-excursion + (goto-char end) + (skip-chars-backward " \t\n" start) + (point))))) + (cond ((and last-non-space + (or (= last-non-space start) + (= last-non-space (1+ start)))) + ;; empty or one-character field + nil) + ((= (point) start) + ;; at the beginning of the field -- we would get an error here. + (error "Cannot transpose at beginning of field")) + (t + (when (and (null arg) + (= last-non-space (point))) + (forward-char -1)) + (transpose-chars arg))))) + +(defcustom widget-complete-field (lookup-key global-map "\M-\t") + "Default function to call for completion inside fields." + :options '(ispell-complete-word complete-tag lisp-complete-symbol) + :type 'function + :group 'widgets) + +(defun widget-complete () + "Complete content of editable field from point. +When not inside a field, move to the previous button or field." + (interactive) + ;; Somehow, this should make pressing M-TAB twice scroll the + ;; completions window. + (let ((field (widget-field-find (point)))) + (if field + (widget-apply field :complete) + (error "Not in an editable field")))) + + +;;; Setting up the buffer. + +(defvar widget-field-new nil) +;; List of all newly created editable fields in the buffer. +(make-variable-buffer-local 'widget-field-new) + +(defvar widget-field-list nil) +;; List of all editable fields in the buffer. +(make-variable-buffer-local 'widget-field-list) + +(defun widget-setup () + "Setup current buffer so editing string widgets works." + (let ((inhibit-read-only t) + (after-change-functions nil) + before-change-functions + field) + (while widget-field-new + (setq field (car widget-field-new) + widget-field-new (cdr widget-field-new) + widget-field-list (cons field widget-field-list)) + (let ((from (car (widget-get field :field-extent))) + (to (cdr (widget-get field :field-extent)))) + (widget-specify-field field + (marker-position from) (marker-position to)) + (set-marker from nil) + (set-marker to nil)) + ;; If the field is placed within the inactive zone, deactivate it. + (let ((extent (widget-get field :field-extent))) + (when (get-char-property (extent-start-position extent) + 'widget-inactive) + (widget-activation-widget-mapper extent :deactivate))))) + (widget-clear-undo) + (widget-add-change)) + +(defvar widget-field-last nil) +;; Last field containing point. +(make-variable-buffer-local 'widget-field-last) + +(defvar widget-field-was nil) +;; The widget data before the change. +(make-variable-buffer-local 'widget-field-was) + +(defun widget-field-buffer (widget) + "Return the start of WIDGET's editing field." + (let ((extent (widget-get widget :field-extent))) + (and extent (extent-object extent)))) + +(defun widget-field-start (widget) + "Return the start of WIDGET's editing field." + (let ((extent (widget-get widget :field-extent))) + (and extent (extent-start-position extent)))) + +(defun widget-field-end (widget) + "Return the end of WIDGET's editing field." + (let ((extent (widget-get widget :field-extent))) + ;; Don't subtract one if local-map works at the end of the extent. + (and extent (if (or widget-field-add-space + (null (widget-get widget :size))) + (1- (extent-end-position extent)) + (extent-end-position extent))))) + +(defun widget-field-find (pos) + "Return the field at POS. +Unlike (get-char-property POS 'field) this, works with empty fields too." + (let ((field-extent (map-extents (lambda (extent ignore) + extent) + nil pos pos nil nil 'field))) + (and field-extent + (extent-property field-extent 'field)))) + +;; Old version, without `map-extents'. +;(defun widget-field-find (pos) +; (let ((fields widget-field-list) +; field found) +; (while fields +; (setq field (car fields) +; fields (cdr fields)) +; (let ((start (widget-field-start field)) +; (end (widget-field-end field))) +; (when (and (<= start pos) (<= pos end)) +; (when found +; (debug "Overlapping fields")) +; (setq found field)))) +; found)) + +(defun widget-before-change (from to) + ;; Barf if the text changed is outside the editable fields. + (unless inhibit-read-only + (let ((from-field (widget-field-find from)) + (to-field (widget-field-find to))) + (cond ((or (null from-field) + (null to-field)) + ;; Either end of change is not within a field. + (add-hook 'post-command-hook 'widget-add-change nil t) + (error "Attempt to change text outside editable field")) + ((not (eq from-field to-field)) + ;; The change begins in one fields, and ends in another one. + (add-hook 'post-command-hook 'widget-add-change nil t) + (error "Change should be restricted to a single field")) + (widget-field-use-before-change + ;; #### Bletch! This loses because XEmacs get confused + ;; if before-change-functions change the contents of + ;; buffer before from/to. + (condition-case nil + (widget-apply from-field :notify from-field) + (error (debug "Before Change")))))))) + +(defun widget-add-change () + (make-local-hook 'post-command-hook) + (remove-hook 'post-command-hook 'widget-add-change t) + (make-local-hook 'before-change-functions) + (add-hook 'before-change-functions 'widget-before-change nil t) + (make-local-hook 'after-change-functions) + (add-hook 'after-change-functions 'widget-after-change nil t)) + +(defun widget-after-change (from to old) + ;; Adjust field size and text properties. + + ;; Also, notify the widgets (so, for example, a variable changes its + ;; state to `modified'. when it is being edited.) + (condition-case nil + (let ((field (widget-field-find from)) + (other (widget-field-find to))) + (when field + (unless (eq field other) + (debug "Change in different fields")) + (let ((size (widget-get field :size)) + (secret (widget-get field :secret))) + (when size + (let ((begin (widget-field-start field)) + (end (widget-field-end field))) + (cond ((< (- end begin) size) + ;; Field too small. + (save-excursion + (goto-char end) + (insert-char ?\ (- (+ begin size) end)))) + ((> (- end begin) size) + ;; Field too large and + (if (or (< (point) (+ begin size)) + (> (point) end)) + ;; Point is outside extra space. + (setq begin (+ begin size)) + ;; Point is within the extra space. + (setq begin (point))) + (save-excursion + (goto-char end) + (while (and (eq (preceding-char) ?\ ) + (> (point) begin)) + (delete-backward-char 1))))))) + (when secret + (let ((begin (widget-field-start field)) + (end (widget-field-end field))) + (when size + (while (and (> end begin) + (eq (char-after (1- end)) ?\ )) + (setq end (1- end)))) + (while (< begin end) + (let ((old (char-after begin))) + (unless (eq old secret) + (subst-char-in-region begin (1+ begin) old secret) + (put-text-property begin (1+ begin) 'secret old)) + (incf begin)))))) + (widget-apply field :notify field))) + (error (debug "After Change")))) + + +;;; Widget Functions +;; +;; These functions are used in the definition of multiple widgets. + +(defun widget-parent-action (widget &optional event) + "Tell :parent of WIDGET to handle the :action. +Optional EVENT is the event that triggered the action." + (widget-apply (widget-get widget :parent) :action event)) + +(defun widget-children-value-delete (widget) + "Delete all :children and :buttons in WIDGET." + (mapc 'widget-delete (widget-get widget :children)) + (widget-put widget :children nil) + (mapc 'widget-delete (widget-get widget :buttons)) + (widget-put widget :buttons nil)) + +(defun widget-children-validate (widget) + "All the :children must be valid." + (let ((children (widget-get widget :children)) + child found) + (while (and children (not found)) + (setq child (car children) + children (cdr children) + found (widget-apply child :validate))) + found)) + +(defun widget-types-convert-widget (widget) + "Convert :args as widget types in WIDGET." + (widget-put widget :args (mapcar 'widget-convert (widget-get widget :args))) + widget) + +(defun widget-value-convert-widget (widget) + "Initialize :value from :args in WIDGET." + (let ((args (widget-get widget :args))) + (when args + (widget-put widget :value (car args)) + ;; Don't convert :value here, as this is done in `widget-convert'. + ;; (widget-put widget :value (widget-apply widget + ;; :value-to-internal (car args))) + (widget-put widget :args nil))) + widget) + +(defun widget-value-value-get (widget) + "Return the :value property of WIDGET." + (widget-get widget :value)) + +;;; The `default' Widget. + +(define-widget 'default nil + "Basic widget other widgets are derived from." + :value-to-internal (lambda (widget value) value) + :value-to-external (lambda (widget value) value) + :button-prefix 'widget-button-prefix + :button-suffix 'widget-button-suffix + :complete 'widget-default-complete + :create 'widget-default-create + :indent nil + :offset 0 + :format-handler 'widget-default-format-handler + :button-face-get 'widget-default-button-face-get + :sample-face-get 'widget-default-sample-face-get + :button-keymap widget-button-keymap + :delete 'widget-default-delete + :value-set 'widget-default-value-set + :value-inline 'widget-default-value-inline + :menu-tag-get 'widget-default-menu-tag-get + :validate (lambda (widget) nil) + :active 'widget-default-active + :activate 'widget-specify-active + :deactivate 'widget-default-deactivate + :mouse-down-action (lambda (widget event) nil) + :action 'widget-default-action + :notify 'widget-default-notify + :prompt-value 'widget-default-prompt-value) + +(defun widget-default-complete (widget) + "Call the value of the :complete-function property of WIDGET. +If that does not exists, call the value of `widget-complete-field'." + (let ((fun (widget-get widget :complete-function))) + (call-interactively (or fun widget-complete-field)))) + +(defun widget-default-create (widget) + "Create WIDGET at point in the current buffer." + (widget-specify-insert + (let ((from (point)) + button-begin button-end button-glyph + sample-begin sample-end + doc-begin doc-end + value-pos) + (insert (widget-get widget :format)) + (goto-char from) + ;; Parse escapes in format. Coding this in C would speed up + ;; things *a lot*. + (while (re-search-forward "%\\(.\\)" nil t) + (let ((escape (aref (match-string 1) 0))) + (replace-match "" t t) + (cond ((eq escape ?%) + (insert "%")) + ((eq escape ?\[) + (setq button-begin (point-marker)) + (set-marker-insertion-type button-begin nil)) + ((eq escape ?\]) + (setq button-end (point-marker)) + (set-marker-insertion-type button-end nil)) + ((eq escape ?\{) + (setq sample-begin (point))) + ((eq escape ?\}) + (setq sample-end (point))) + ((eq escape ?n) + (when (widget-get widget :indent) + (insert "\n") + (insert-char ?\ (widget-get widget :indent)))) + ((eq escape ?t) + (let* ((tag (widget-get widget :tag)) + (glyph (widget-get widget :tag-glyph))) + (cond (glyph + (setq button-glyph + (widget-glyph-insert + widget (or tag "Image") glyph))) + (tag + (insert tag)) + (t + (let ((standard-output (current-buffer))) + (princ (widget-get widget :value))))))) + ((eq escape ?d) + (let ((doc (widget-get widget :doc))) + (when doc + (setq doc-begin (point)) + (insert doc) + (while (eq (preceding-char) ?\n) + (delete-backward-char 1)) + (insert "\n") + (setq doc-end (point))))) + ((eq escape ?v) + (if (and button-begin (not button-end)) + (widget-apply widget :value-create) + (setq value-pos (point-marker)))) + (t + (widget-apply widget :format-handler escape))))) + ;; Specify button, sample, and doc, and insert value. + (when (and button-begin button-end) + (unless button-glyph + (goto-char button-begin) + (insert (widget-get-indirect widget :button-prefix)) + (goto-char button-end) + (set-marker-insertion-type button-end t) + (insert (widget-get-indirect widget :button-suffix))) + (widget-specify-button widget button-begin button-end) + ;; Is this necessary? + (set-marker button-begin nil) + (set-marker button-end nil)) + (and sample-begin sample-end + (widget-specify-sample widget sample-begin sample-end)) + (and doc-begin doc-end + (widget-specify-doc widget doc-begin doc-end)) + (when value-pos + (goto-char value-pos) + (widget-apply widget :value-create))) + (let ((from (point-min-marker)) + (to (point-max-marker))) + (set-marker-insertion-type from t) + (set-marker-insertion-type to nil) + (widget-put widget :from from) + (widget-put widget :to to))) + (widget-clear-undo)) + +(defun widget-default-format-handler (widget escape) + ;; We recognize the %h escape by default. + (let* ((buttons (widget-get widget :buttons))) + (cond ((eq escape ?h) + (let* ((doc-property (widget-get widget :documentation-property)) + (doc-try (cond ((widget-get widget :doc)) + ((symbolp doc-property) + (documentation-property + (widget-get widget :value) + doc-property)) + (t + (funcall doc-property + (widget-get widget :value))))) + (doc-text (and (stringp doc-try) + (> (length doc-try) 1) + doc-try)) + (doc-indent (widget-get widget :documentation-indent))) + (when doc-text + (and (eq (preceding-char) ?\n) + (widget-get widget :indent) + (insert-char ?\ (widget-get widget :indent))) + ;; The `*' in the beginning is redundant. + (when (eq (aref doc-text 0) ?*) + (setq doc-text (substring doc-text 1))) + ;; Get rid of trailing newlines. + (when (string-match "\n+\\'" doc-text) + (setq doc-text (substring doc-text 0 (match-beginning 0)))) + (push (widget-create-child-and-convert + widget 'documentation-string + :indent (cond ((numberp doc-indent) + doc-indent) + ((null doc-indent) + nil) + (t 0)) + doc-text) + buttons)))) + (t + (error "Unknown escape `%c'" escape))) + (widget-put widget :buttons buttons))) + +(defun widget-default-button-face-get (widget) + ;; Use :button-face or widget-button-face + (or (widget-get widget :button-face) + (let ((parent (widget-get widget :parent))) + (if parent + (widget-apply parent :button-face-get) + widget-button-face)))) + +(defun widget-default-sample-face-get (widget) + ;; Use :sample-face. + (widget-get widget :sample-face)) + +(defun widget-default-delete (widget) + ;; Remove widget from the buffer. + (let ((from (widget-get widget :from)) + (to (widget-get widget :to)) + (inactive-extent (widget-get widget :inactive)) + (button-extent (widget-get widget :button-extent)) + (sample-extent (widget-get widget :sample-extent)) + (doc-extent (widget-get widget :doc-extent)) + before-change-functions + after-change-functions + (inhibit-read-only t)) + (widget-apply widget :value-delete) + (when inactive-extent + (detach-extent inactive-extent)) + (when button-extent + (detach-extent button-extent)) + (when sample-extent + (detach-extent sample-extent)) + (when doc-extent + (detach-extent doc-extent)) + (when (< from to) + ;; Kludge: this doesn't need to be true for empty formats. + (delete-region from to)) + (set-marker from nil) + (set-marker to nil)) + (widget-clear-undo)) + +(defun widget-default-value-set (widget value) + ;; Recreate widget with new value. + (let* ((old-pos (point)) + (from (copy-marker (widget-get widget :from))) + (to (copy-marker (widget-get widget :to))) + (offset (if (and (<= from old-pos) (<= old-pos to)) + (if (>= old-pos (1- to)) + (- old-pos to 1) + (- old-pos from))))) + ;;??? Bug: this ought to insert the new value before deleting the old one, + ;; so that markers on either side of the value automatically + ;; stay on the same side. -- rms. + (save-excursion + (goto-char (widget-get widget :from)) + (widget-apply widget :delete) + (widget-put widget :value value) + (widget-apply widget :create)) + (when offset + (if (< offset 0) + (goto-char (+ (widget-get widget :to) offset 1)) + (goto-char (min (+ from offset) (1- (widget-get widget :to)))))))) + +(defun widget-default-value-inline (widget) + ;; Wrap value in a list unless it is inline. + (if (widget-get widget :inline) + (widget-value widget) + (list (widget-value widget)))) + +(defun widget-default-menu-tag-get (widget) + ;; Use tag or value for menus. + (or (widget-get widget :menu-tag) + (widget-get widget :tag) + (widget-princ-to-string (widget-get widget :value)))) + +(defun widget-default-active (widget) + "Return t iff this widget active (user modifiable)." + (and (not (widget-get widget :inactive)) + (let ((parent (widget-get widget :parent))) + (or (null parent) + (widget-apply parent :active))))) + +(defun widget-default-deactivate (widget) + "Make WIDGET inactive for user modifications." + (widget-specify-inactive widget + (widget-get widget :from) + (widget-get widget :to))) + +(defun widget-default-action (widget &optional event) + ;; Notify the parent when a widget change + (let ((parent (widget-get widget :parent))) + (when parent + (widget-apply parent :notify widget event)))) + +(defun widget-default-notify (widget child &optional event) + ;; Pass notification to parent. + (widget-default-action widget event)) + +(defun widget-default-prompt-value (widget prompt value unbound) + ;; Read an arbitrary value. Stolen from `set-variable'. +;; (let ((initial (if unbound +;; nil +;; ;; It would be nice if we could do a `(cons val 1)' here. +;; (prin1-to-string (custom-quote value)))))) + (eval-minibuffer prompt )) + +;;; The `item' Widget. + +(define-widget 'item 'default + "Constant items for inclusion in other widgets." + :convert-widget 'widget-value-convert-widget + :value-create 'widget-item-value-create + :value-delete 'ignore + :value-get 'widget-value-value-get + :match 'widget-item-match + :match-inline 'widget-item-match-inline + :action 'widget-item-action + :format "%t\n") + +(defun widget-item-value-create (widget) + ;; Insert the printed representation of the value. + (let ((standard-output (current-buffer))) + (princ (widget-get widget :value)))) + +(defun widget-item-match (widget value) + ;; Match if the value is the same. + (equal (widget-get widget :value) value)) + +(defun widget-item-match-inline (widget values) + ;; Match if the value is the same. + (let ((value (widget-get widget :value))) + (and (listp value) + (<= (length value) (length values)) + (let ((head (widget-sublist values 0 (length value)))) + (and (equal head value) + (cons head (widget-sublist values (length value)))))))) + +(defun widget-sublist (list start &optional end) + "Return the sublist of LIST from START to END. +If END is omitted, it defaults to the length of LIST." + (if (> start 0) (setq list (nthcdr start list))) + (if end + (if (<= end start) + nil + (setq list (copy-sequence list)) + (setcdr (nthcdr (- end start 1) list) nil) + list) + (copy-sequence list))) + +(defun widget-item-action (widget &optional event) + ;; Just notify itself. + (widget-apply widget :notify widget event)) + +;;; The `push-button' Widget. + +(defcustom widget-push-button-gui widget-glyph-enable + "If non nil, use GUI push buttons when available." + :group 'widgets + :type 'boolean) + +;; Cache already created GUI objects. +(defvar widget-push-button-cache nil) + +(defcustom widget-push-button-prefix "[" + "String used as prefix for buttons." + :type 'string + :group 'widget-button) + +(defcustom widget-push-button-suffix "]" + "String used as suffix for buttons." + :type 'string + :group 'widget-button) + +(define-widget 'push-button 'item + "A pushable button." + :button-prefix "" + :button-suffix "" + :value-create 'widget-push-button-value-create + :format "%[%v%]") + +(defun widget-push-button-value-create (widget) + ;; Insert text representing the `on' and `off' states. + (let* ((tag (or (widget-get widget :tag) + (widget-get widget :value))) + (tag-glyph (widget-get widget :tag-glyph)) + (text (concat widget-push-button-prefix + tag widget-push-button-suffix)) + (gui-glyphs (lax-plist-get widget-push-button-cache tag))) + (cond (tag-glyph + (widget-glyph-insert widget text tag-glyph)) + ;; We must check for console-on-window-system-p here, + ;; because GUI will not work otherwise (it needs RGB + ;; components for colors, and they are not known on TTYs). + ((and widget-push-button-gui + (console-on-window-system-p)) + (unless gui-glyphs + (let* ((gui-button-shadow-thickness 1) + (gui (make-gui-button tag 'widget-gui-action widget))) + (setq + gui-glyphs + (list + (make-glyph `(,(nth 0 (aref gui 1)) [string :data ,text])) + (make-glyph `(,(nth 1 (aref gui 1)) [string :data ,text])) + (make-glyph `(,(nth 2 (aref gui 1)) [string :data ,text])))) + (laxputf widget-push-button-cache tag gui-glyphs))) + (widget-glyph-insert-glyph + widget (nth 0 gui-glyphs) (nth 1 gui-glyphs) (nth 2 gui-glyphs))) + (t + (insert text))))) + +(defun widget-gui-action (widget) + "Apply :action for WIDGET." + (widget-apply-action widget (this-command-keys))) + +;;; The `link' Widget. + +(defcustom widget-link-prefix "[" + "String used as prefix for links." + :type 'string + :group 'widget-button) + +(defcustom widget-link-suffix "]" + "String used as suffix for links." + :type 'string + :group 'widget-button) + +(define-widget 'link 'item + "An embedded link." + :button-prefix 'widget-link-prefix + :button-suffix 'widget-link-suffix + :help-echo "Follow the link" + :format "%[%t%]") + +;;; The `info-link' Widget. + +(define-widget 'info-link 'link + "A link to an info file." + :help-echo 'widget-info-link-help-echo + :action 'widget-info-link-action) + +(defun widget-info-link-help-echo (widget) + (concat "Read the manual entry `" (widget-value widget) "'")) + +(defun widget-info-link-action (widget &optional event) + "Open the info node specified by WIDGET." + (Info-goto-node (widget-value widget))) + +;;; The `url-link' Widget. + +(define-widget 'url-link 'link + "A link to an www page." + :help-echo 'widget-url-link-help-echo + :action 'widget-url-link-action) + +(defun widget-url-link-help-echo (widget) + (concat "Visit <URL:" (widget-value widget) ">")) + +(defun widget-url-link-action (widget &optional event) + "Open the url specified by WIDGET." + (require 'browse-url) + (funcall browse-url-browser-function (widget-value widget))) + +;;; The `function-link' Widget. + +(define-widget 'function-link 'link + "A link to an Emacs function." + :action 'widget-function-link-action) + +(defun widget-function-link-action (widget &optional event) + "Show the function specified by WIDGET." + (describe-function (widget-value widget))) + +;;; The `variable-link' Widget. + +(define-widget 'variable-link 'link + "A link to an Emacs variable." + :action 'widget-variable-link-action) + +(defun widget-variable-link-action (widget &optional event) + "Show the variable specified by WIDGET." + (describe-variable (widget-value widget))) + +;;; The `file-link' Widget. + +(define-widget 'file-link 'link + "A link to a file." + :action 'widget-file-link-action) + +(defun widget-file-link-action (widget &optional event) + "Find the file specified by WIDGET." + (find-file (widget-value widget))) + +;;; The `emacs-library-link' Widget. + +(define-widget 'emacs-library-link 'link + "A link to an Emacs Lisp library file." + :help-echo 'widget-emacs-library-link-help-echo + :action 'widget-emacs-library-link-action) + +(defun widget-emacs-library-link-help-echo (widget) + (concat "Visit " (widget-value widget))) + +(defun widget-emacs-library-link-action (widget &optional event) + "Find the Emacs Library file specified by WIDGET." + (find-file (locate-library (widget-value widget)))) + +;;; The `emacs-commentary-link' Widget. + +(define-widget 'emacs-commentary-link 'link + "A link to Commentary in an Emacs Lisp library file." + :action 'widget-emacs-commentary-link-action) + +(defun widget-emacs-commentary-link-action (widget &optional event) + "Find the Commentary section of the Emacs file specified by WIDGET." + (finder-commentary (widget-value widget))) + +;;; The `editable-field' Widget. + +(define-widget 'editable-field 'default + "An editable text field." + :convert-widget 'widget-value-convert-widget + :keymap widget-field-keymap + :format "%v" + :value "" + :prompt-internal 'widget-field-prompt-internal + :prompt-history 'widget-field-history + :prompt-value 'widget-field-prompt-value + :action 'widget-field-action + :validate 'widget-field-validate + :valid-regexp "" + :error "No match" + :value-create 'widget-field-value-create + :value-delete 'widget-field-value-delete + :value-get 'widget-field-value-get + :match 'widget-field-match) + +(defvar widget-field-history nil + "History of field minibuffer edits.") + +(defun widget-field-prompt-internal (widget prompt initial history) + ;; Read string for WIDGET prompting with PROMPT. + ;; INITIAL is the initial input and HISTORY is a symbol containing + ;; the earlier input. + (read-string prompt initial history)) + +(defun widget-field-prompt-value (widget prompt value unbound) + ;; Prompt for a string. + (let ((initial (if unbound + nil + (cons (widget-apply widget :value-to-internal + value) 0))) + (history (widget-get widget :prompt-history))) + (let ((answer (widget-apply widget + :prompt-internal prompt initial history))) + (widget-apply widget :value-to-external answer)))) + +(defvar widget-edit-functions nil) + +(defun widget-field-action (widget &optional event) + ;; Edit the value in the minibuffer. + (let* ((invalid (widget-apply widget :validate)) + (prompt (concat (widget-apply widget :menu-tag-get) ": ")) + (value (unless invalid + (widget-value widget))) + (answer (widget-apply widget :prompt-value prompt value invalid))) + (unless (equal value answer) + ;; This is a hack. We can't properly validate the widget + ;; because validation requires the new value to be in the field. + ;; However, widget-field-value-create will not function unless + ;; the new value matches. So, we check whether the thing + ;; matches, and if it does, use either the real or a dummy error + ;; message. + (unless (widget-apply widget :match answer) + (let ((error-message (or (widget-get widget :type-error) + "Invalid field contents"))) + (widget-put widget :error error-message) + (error error-message))) + (widget-value-set widget answer) + (widget-apply widget :notify widget event) + (widget-setup)) + (run-hook-with-args 'widget-edit-functions widget))) + +;(defun widget-field-action (widget &optional event) +; ;; Move to next field. +; (widget-forward 1) +; (run-hook-with-args 'widget-edit-functions widget)) + +(defun widget-field-validate (widget) + ;; Valid if the content matches `:valid-regexp'. + (save-excursion + (let ((value (widget-apply widget :value-get)) + (regexp (widget-get widget :valid-regexp))) + (if (string-match regexp value) + nil + widget)))) + +(defun widget-field-value-create (widget) + ;; Create an editable text field. + (let ((size (widget-get widget :size)) + (value (widget-get widget :value)) + (from (point)) + ;; This is changed to a real extent in `widget-setup'. We + ;; need the end points to behave differently until + ;; `widget-setup' is called. Should probably be replaced with + ;; a genuine extent, but some things break, then. + (extent (cons (make-marker) (make-marker)))) + (widget-put widget :field-extent extent) + (insert value) + (and size + (< (length value) size) + (insert-char ?\ (- size (length value)))) + (unless (memq widget widget-field-list) + (push widget widget-field-new)) + (move-marker (cdr extent) (point)) + (set-marker-insertion-type (cdr extent) nil) + (when (null size) + (insert ?\n)) + (move-marker (car extent) from) + (set-marker-insertion-type (car extent) t))) + +(defun widget-field-value-delete (widget) + ;; Remove the widget from the list of active editing fields. + (setq widget-field-list (delq widget widget-field-list)) + ;; These are nil if the :format string doesn't contain `%v'. + (let ((extent (widget-get widget :field-extent))) + (when extent + (detach-extent extent)))) + +(defun widget-field-value-get (widget) + ;; Return current text in editing field. + (let ((from (widget-field-start widget)) + (to (widget-field-end widget)) + (buffer (widget-field-buffer widget)) + (size (widget-get widget :size)) + (secret (widget-get widget :secret)) + (old (current-buffer))) + (cond + ((and from to) + (set-buffer buffer) + (while (and size + (not (zerop size)) + (> to from) + (eq (char-after (1- to)) ?\ )) + (setq to (1- to))) + (let ((result (buffer-substring-no-properties from to))) + (when secret + (let ((index 0)) + (while (< (+ from index) to) + (aset result index + (get-char-property (+ from index) 'secret)) + (incf index)))) + (set-buffer old) + result)) + (t + (widget-get widget :value))))) + +(defun widget-field-match (widget value) + ;; Match any string. + (stringp value)) + +;;; The `text' Widget. + +(define-widget 'text 'editable-field + :keymap widget-text-keymap + "A multiline text area.") + +;;; The `menu-choice' Widget. + +(define-widget 'menu-choice 'default + "A menu of options." + :convert-widget 'widget-types-convert-widget + :format "%[%t%]: %v" + :case-fold t + :tag "choice" + :void '(item :format "invalid (%t)\n") + :value-create 'widget-choice-value-create + :value-delete 'widget-children-value-delete + :value-get 'widget-choice-value-get + :value-inline 'widget-choice-value-inline + :mouse-down-action 'widget-choice-mouse-down-action + :action 'widget-choice-action + :error "Make a choice" + :validate 'widget-choice-validate + :match 'widget-choice-match + :match-inline 'widget-choice-match-inline) + +(defun widget-choice-value-create (widget) + ;; Insert the first choice that matches the value. + (let ((value (widget-get widget :value)) + (args (widget-get widget :args)) + current) + (while args + (setq current (car args) + args (cdr args)) + (when (widget-apply current :match value) + (widget-put widget :children (list (widget-create-child-value + widget current value))) + (widget-put widget :choice current) + (setq args nil + current nil))) + (when current + (let ((void (widget-get widget :void))) + (widget-put widget :children (list (widget-create-child-and-convert + widget void :value value))) + (widget-put widget :choice void))))) + +(defun widget-choice-value-get (widget) + ;; Get value of the child widget. + (widget-value (car (widget-get widget :children)))) + +(defun widget-choice-value-inline (widget) + ;; Get value of the child widget. + (widget-apply (car (widget-get widget :children)) :value-inline)) + +(defcustom widget-choice-toggle nil + "If non-nil, a binary choice will just toggle between the values. +Otherwise, the user will explicitly have to choose between the values +when he invoked the menu." + :type 'boolean + :group 'widgets) + +(defun widget-choice-mouse-down-action (widget &optional event) + ;; Return non-nil if we need a menu. + (let ((args (widget-get widget :args)) + (old (widget-get widget :choice))) + (cond ((not (console-on-window-system-p)) + ;; No place to pop up a menu. + nil) + ((< (length args) 2) + ;; Empty or singleton list, just return the value. + nil) + ((> (length args) widget-menu-max-size) + ;; Too long, prompt. + nil) + ((> (length args) 2) + ;; Reasonable sized list, use menu. + t) + ((and widget-choice-toggle (memq old args)) + ;; We toggle. + nil) + (t + ;; Ask which of the two. + t)))) + +(defun widget-choice-action (widget &optional event) + ;; Make a choice. + (let ((args (widget-get widget :args)) + (old (widget-get widget :choice)) + (tag (widget-apply widget :menu-tag-get)) + (completion-ignore-case (widget-get widget :case-fold)) + current choices) + ;; Remember old value. + (if (and old (not (widget-apply widget :validate))) + (let* ((external (widget-value widget)) + (internal (widget-apply old :value-to-internal external))) + (widget-put old :value internal))) + ;; Find new choice. + (setq current + (cond ((= (length args) 0) + nil) + ((= (length args) 1) + (nth 0 args)) + ((and widget-choice-toggle + (= (length args) 2) + (memq old args)) + (if (eq old (nth 0 args)) + (nth 1 args) + (nth 0 args))) + (t + (while args + (setq current (car args) + args (cdr args)) + (setq choices + (cons (cons (widget-apply current :menu-tag-get) + current) + choices))) + (widget-choose tag (reverse choices) event)))) + (when current + (widget-value-set widget + (widget-apply current :value-to-external + (widget-get current :value))) + (widget-setup) + (widget-apply widget :notify widget event))) + (run-hook-with-args 'widget-edit-functions widget)) + +(defun widget-choice-validate (widget) + ;; Valid if we have made a valid choice. + (let ((void (widget-get widget :void)) + (choice (widget-get widget :choice)) + (child (car (widget-get widget :children)))) + (if (eq void choice) + widget + (widget-apply child :validate)))) + +(defun widget-choice-match (widget value) + ;; Matches if one of the choices matches. + (let ((args (widget-get widget :args)) + current found) + (while (and args (not found)) + (setq current (car args) + args (cdr args) + found (widget-apply current :match value))) + found)) + +(defun widget-choice-match-inline (widget values) + ;; Matches if one of the choices matches. + (let ((args (widget-get widget :args)) + current found) + (while (and args (null found)) + (setq current (car args) + args (cdr args) + found (widget-match-inline current values))) + found)) + +;;; The `toggle' Widget. + +(define-widget 'toggle 'item + "Toggle between two states." + :format "%[%v%]\n" + :value-create 'widget-toggle-value-create + :action 'widget-toggle-action + :match (lambda (widget value) t) + :on "on" + :off "off") + +(defun widget-toggle-value-create (widget) + ;; Insert text representing the `on' and `off' states. + (if (widget-value widget) + (widget-glyph-insert widget + (widget-get widget :on) + (widget-get widget :on-glyph)) + (widget-glyph-insert widget + (widget-get widget :off) + (widget-get widget :off-glyph)))) + +(defun widget-toggle-action (widget &optional event) + ;; Toggle value. + (widget-value-set widget (not (widget-value widget))) + (widget-apply widget :notify widget event) + (run-hook-with-args 'widget-edit-functions widget)) + +;;; The `checkbox' Widget. + +(define-widget 'checkbox 'toggle + "A checkbox toggle." + :button-suffix "" + :button-prefix "" + :format "%[%v%]" + :on "[X]" + :on-glyph "check1" + :off "[ ]" + :off-glyph "check0" + :action 'widget-checkbox-action) + +(defun widget-checkbox-action (widget &optional event) + "Toggle checkbox, notify parent, and set active state of sibling." + (widget-toggle-action widget event) + (let ((sibling (widget-get-sibling widget))) + (when sibling + (if (widget-value widget) + (widget-apply sibling :activate) + (widget-apply sibling :deactivate))))) + +;;; The `checklist' Widget. + +(define-widget 'checklist 'default + "A multiple choice widget." + :convert-widget 'widget-types-convert-widget + :format "%v" + :offset 4 + :entry-format "%b %v" + :menu-tag "checklist" + :greedy nil + :value-create 'widget-checklist-value-create + :value-delete 'widget-children-value-delete + :value-get 'widget-checklist-value-get + :validate 'widget-checklist-validate + :match 'widget-checklist-match + :match-inline 'widget-checklist-match-inline) + +(defun widget-checklist-value-create (widget) + ;; Insert all values + (let ((alist (widget-checklist-match-find widget (widget-get widget :value))) + (args (widget-get widget :args))) + (while args + (widget-checklist-add-item widget (car args) (assq (car args) alist)) + (setq args (cdr args))) + (widget-put widget :children (nreverse (widget-get widget :children))))) + +(defun widget-checklist-add-item (widget type chosen) + ;; Create checklist item in WIDGET of type TYPE. + ;; If the item is checked, CHOSEN is a cons whose cdr is the value. + (and (eq (preceding-char) ?\n) + (widget-get widget :indent) + (insert-char ?\ (widget-get widget :indent))) + (widget-specify-insert + (let* ((children (widget-get widget :children)) + (buttons (widget-get widget :buttons)) + (button-args (or (widget-get type :sibling-args) + (widget-get widget :button-args))) + (from (point)) + child button) + (insert (widget-get widget :entry-format)) + (goto-char from) + ;; Parse % escapes in format. + (while (re-search-forward "%\\([bv%]\\)" nil t) + (let ((escape (aref (match-string 1) 0))) + (replace-match "" t t) + (cond ((eq escape ?%) + (insert "%")) + ((eq escape ?b) + (setq button (apply 'widget-create-child-and-convert + widget 'checkbox + :value (not (null chosen)) + button-args))) + ((eq escape ?v) + (setq child + (cond ((not chosen) + (let ((child (widget-create-child widget type))) + (widget-apply child :deactivate) + child)) + ((widget-get type :inline) + (widget-create-child-value + widget type (cdr chosen))) + (t + (widget-create-child-value + widget type (car (cdr chosen))))))) + (t + (error "Unknown escape `%c'" escape))))) + ;; Update properties. + (and button child (widget-put child :button button)) + (and button (widget-put widget :buttons (cons button buttons))) + (and child (widget-put widget :children (cons child children)))))) + +(defun widget-checklist-match (widget values) + ;; All values must match a type in the checklist. + (and (listp values) + (null (cdr (widget-checklist-match-inline widget values))))) + +(defun widget-checklist-match-inline (widget values) + ;; Find the values which match a type in the checklist. + (let ((greedy (widget-get widget :greedy)) + (args (copy-sequence (widget-get widget :args))) + found rest) + (while values + (let ((answer (widget-checklist-match-up args values))) + (cond (answer + (let ((vals (widget-match-inline answer values))) + (setq found (append found (car vals)) + values (cdr vals) + args (delq answer args)))) + (greedy + (setq rest (append rest (list (car values))) + values (cdr values))) + (t + (setq rest (append rest values) + values nil))))) + (cons found rest))) + +(defun widget-checklist-match-find (widget vals) + ;; Find the vals which match a type in the checklist. + ;; Return an alist of (TYPE MATCH). + (let ((greedy (widget-get widget :greedy)) + (args (copy-sequence (widget-get widget :args))) + found) + (while vals + (let ((answer (widget-checklist-match-up args vals))) + (cond (answer + (let ((match (widget-match-inline answer vals))) + (setq found (cons (cons answer (car match)) found) + vals (cdr match) + args (delq answer args)))) + (greedy + (setq vals (cdr vals))) + (t + (setq vals nil))))) + found)) + +(defun widget-checklist-match-up (args vals) + ;; Rerturn the first type from ARGS that matches VALS. + (let (current found) + (while (and args (null found)) + (setq current (car args) + args (cdr args) + found (widget-match-inline current vals))) + (if found + current + nil))) + +(defun widget-checklist-value-get (widget) + ;; The values of all selected items. + (let ((children (widget-get widget :children)) + child result) + (while children + (setq child (car children) + children (cdr children)) + (if (widget-value (widget-get child :button)) + (setq result (append result (widget-apply child :value-inline))))) + result)) + +(defun widget-checklist-validate (widget) + ;; Ticked chilren must be valid. + (let ((children (widget-get widget :children)) + child button found) + (while (and children (not found)) + (setq child (car children) + children (cdr children) + button (widget-get child :button) + found (and (widget-value button) + (widget-apply child :validate)))) + found)) + +;;; The `option' Widget + +(define-widget 'option 'checklist + "An widget with an optional item." + :inline t) + +;;; The `choice-item' Widget. + +(define-widget 'choice-item 'item + "Button items that delegate action events to their parents." + :action 'widget-parent-action + :format "%[%t%] \n") + +;;; The `radio-button' Widget. + +(define-widget 'radio-button 'toggle + "A radio button for use in the `radio' widget." + :notify 'widget-radio-button-notify + :format "%[%v%]" + :button-suffix "" + :button-prefix "" + :on "(*)" + :on-glyph '("radio1" nil "radio0") + :off "( )" + :off-glyph "radio0") + +(defun widget-radio-button-notify (widget child &optional event) + ;; Tell daddy. + (widget-apply (widget-get widget :parent) :action widget event)) + +;;; The `radio-button-choice' Widget. + +(define-widget 'radio-button-choice 'default + "Select one of multiple options." + :convert-widget 'widget-types-convert-widget + :offset 4 + :format "%v" + :entry-format "%b %v" + :menu-tag "radio" + :value-create 'widget-radio-value-create + :value-delete 'widget-children-value-delete + :value-get 'widget-radio-value-get + :value-inline 'widget-radio-value-inline + :value-set 'widget-radio-value-set + :error "You must push one of the buttons" + :validate 'widget-radio-validate + :match 'widget-choice-match + :match-inline 'widget-choice-match-inline + :action 'widget-radio-action) + +(defun widget-radio-value-create (widget) + ;; Insert all values + (let ((args (widget-get widget :args)) + arg) + (while args + (setq arg (car args) + args (cdr args)) + (widget-radio-add-item widget arg)))) + +(defun widget-radio-add-item (widget type) + "Add to radio widget WIDGET a new radio button item of type TYPE." + ;; (setq type (widget-convert type)) + (and (eq (preceding-char) ?\n) + (widget-get widget :indent) + (insert-char ?\ (widget-get widget :indent))) + (widget-specify-insert + (let* ((value (widget-get widget :value)) + (children (widget-get widget :children)) + (buttons (widget-get widget :buttons)) + (button-args (or (widget-get type :sibling-args) + (widget-get widget :button-args))) + (from (point)) + (chosen (and (null (widget-get widget :choice)) + (widget-apply type :match value))) + child button) + (insert (widget-get widget :entry-format)) + (goto-char from) + ;; Parse % escapes in format. + (while (re-search-forward "%\\([bv%]\\)" nil t) + (let ((escape (aref (match-string 1) 0))) + (replace-match "" t t) + (cond ((eq escape ?%) + (insert "%")) + ((eq escape ?b) + (setq button (apply 'widget-create-child-and-convert + widget 'radio-button + :value (not (null chosen)) + button-args))) + ((eq escape ?v) + (setq child (if chosen + (widget-create-child-value + widget type value) + (widget-create-child widget type))) + (unless chosen + (widget-apply child :deactivate))) + (t + (error "Unknown escape `%c'" escape))))) + ;; Update properties. + (when chosen + (widget-put widget :choice type)) + (when button + (widget-put child :button button) + (widget-put widget :buttons (nconc buttons (list button)))) + (when child + (widget-put widget :children (nconc children (list child)))) + child))) + +(defun widget-radio-value-get (widget) + ;; Get value of the child widget. + (let ((chosen (widget-radio-chosen widget))) + (and chosen (widget-value chosen)))) + +(defun widget-radio-chosen (widget) + "Return the widget representing the chosen radio button." + (let ((children (widget-get widget :children)) + current found) + (while children + (setq current (car children) + children (cdr children)) + (let* ((button (widget-get current :button)) + (value (widget-apply button :value-get))) + (when value + (setq found current + children nil)))) + found)) + +(defun widget-radio-value-inline (widget) + ;; Get value of the child widget. + (let ((children (widget-get widget :children)) + current found) + (while children + (setq current (car children) + children (cdr children)) + (let* ((button (widget-get current :button)) + (value (widget-apply button :value-get))) + (when value + (setq found (widget-apply current :value-inline) + children nil)))) + found)) + +(defun widget-radio-value-set (widget value) + ;; We can't just delete and recreate a radio widget, since children + ;; can be added after the original creation and won't be recreated + ;; by `:create'. + (let ((children (widget-get widget :children)) + current found) + (while children + (setq current (car children) + children (cdr children)) + (let* ((button (widget-get current :button)) + (match (and (not found) + (widget-apply current :match value)))) + (widget-value-set button match) + (if match + (progn + (widget-value-set current value) + (widget-apply current :activate)) + (widget-apply current :deactivate)) + (setq found (or found match)))))) + +(defun widget-radio-validate (widget) + ;; Valid if we have made a valid choice. + (let ((children (widget-get widget :children)) + current found button) + (while (and children (not found)) + (setq current (car children) + children (cdr children) + button (widget-get current :button) + found (widget-apply button :value-get))) + (if found + (widget-apply current :validate) + widget))) + +(defun widget-radio-action (widget child event) + ;; Check if a radio button was pressed. + (let ((children (widget-get widget :children)) + (buttons (widget-get widget :buttons)) + current) + (when (memq child buttons) + (while children + (setq current (car children) + children (cdr children)) + (let* ((button (widget-get current :button))) + (cond ((eq child button) + (widget-value-set button t) + (widget-apply current :activate)) + ((widget-value button) + (widget-value-set button nil) + (widget-apply current :deactivate))))))) + ;; Pass notification to parent. + (widget-apply widget :notify child event)) + +;;; The `insert-button' Widget. + +(define-widget 'insert-button 'push-button + "An insert button for the `editable-list' widget." + :tag "INS" + :help-echo "Insert a new item into the list at this position" + :action 'widget-insert-button-action) + +(defun widget-insert-button-action (widget &optional event) + ;; Ask the parent to insert a new item. + (widget-apply (widget-get widget :parent) + :insert-before (widget-get widget :widget))) + +;;; The `delete-button' Widget. + +(define-widget 'delete-button 'push-button + "A delete button for the `editable-list' widget." + :tag "DEL" + :help-echo "Delete this item from the list" + :action 'widget-delete-button-action) + +(defun widget-delete-button-action (widget &optional event) + ;; Ask the parent to insert a new item. + (widget-apply (widget-get widget :parent) + :delete-at (widget-get widget :widget))) + +;;; The `editable-list' Widget. + +(defcustom widget-editable-list-gui nil + "If non nil, use GUI push-buttons in editable list when available." + :type 'boolean + :group 'widgets) + +(define-widget 'editable-list 'default + "A variable list of widgets of the same type." + :convert-widget 'widget-types-convert-widget + :offset 12 + :format "%v%i\n" + :format-handler 'widget-editable-list-format-handler + :entry-format "%i %d %v" + :menu-tag "editable-list" + :value-create 'widget-editable-list-value-create + :value-delete 'widget-children-value-delete + :value-get 'widget-editable-list-value-get + :validate 'widget-children-validate + :match 'widget-editable-list-match + :match-inline 'widget-editable-list-match-inline + :insert-before 'widget-editable-list-insert-before + :delete-at 'widget-editable-list-delete-at) + +(defun widget-editable-list-format-handler (widget escape) + ;; We recognize the insert button. + (let ((widget-push-button-gui widget-editable-list-gui)) + (cond ((eq escape ?i) + (and (widget-get widget :indent) + (insert-char ?\ (widget-get widget :indent))) + (apply 'widget-create-child-and-convert + widget 'insert-button + (widget-get widget :append-button-args))) + (t + (widget-default-format-handler widget escape))))) + +(defun widget-editable-list-value-create (widget) + ;; Insert all values + (let* ((value (widget-get widget :value)) + (type (nth 0 (widget-get widget :args))) + (inlinep (widget-get type :inline)) + children) + (widget-put widget :value-pos (copy-marker (point))) + (set-marker-insertion-type (widget-get widget :value-pos) t) + (while value + (let ((answer (widget-match-inline type value))) + (if answer + (setq children (cons (widget-editable-list-entry-create + widget + (if inlinep + (car answer) + (car (car answer))) + t) + children) + value (cdr answer)) + (setq value nil)))) + (widget-put widget :children (nreverse children)))) + +(defun widget-editable-list-value-get (widget) + ;; Get value of the child widget. + (apply 'append (mapcar (lambda (child) (widget-apply child :value-inline)) + (widget-get widget :children)))) + +(defun widget-editable-list-match (widget value) + ;; Value must be a list and all the members must match the type. + (and (listp value) + (null (cdr (widget-editable-list-match-inline widget value))))) + +(defun widget-editable-list-match-inline (widget value) + (let ((type (nth 0 (widget-get widget :args))) + (ok t) + found) + (while (and value ok) + (let ((answer (widget-match-inline type value))) + (if answer + (setq found (append found (car answer)) + value (cdr answer)) + (setq ok nil)))) + (cons found value))) + +(defun widget-editable-list-insert-before (widget before) + ;; Insert a new child in the list of children. + (save-excursion + (let ((children (widget-get widget :children)) + (inhibit-read-only t) + before-change-functions + after-change-functions) + (cond (before + (goto-char (widget-get before :entry-from))) + (t + (goto-char (widget-get widget :value-pos)))) + (let ((child (widget-editable-list-entry-create + widget nil nil))) + (when (< (widget-get child :entry-from) (widget-get widget :from)) + (set-marker (widget-get widget :from) + (widget-get child :entry-from))) + (if (eq (car children) before) + (widget-put widget :children (cons child children)) + (while (not (eq (car (cdr children)) before)) + (setq children (cdr children))) + (setcdr children (cons child (cdr children))))))) + (widget-setup) + (widget-apply widget :notify widget)) + +(defun widget-editable-list-delete-at (widget child) + ;; Delete child from list of children. + (save-excursion + (let ((buttons (copy-sequence (widget-get widget :buttons))) + button + (inhibit-read-only t) + before-change-functions + after-change-functions) + (while buttons + (setq button (car buttons) + buttons (cdr buttons)) + (when (eq (widget-get button :widget) child) + (widget-put widget + :buttons (delq button (widget-get widget :buttons))) + (widget-delete button)))) + (let ((entry-from (widget-get child :entry-from)) + (entry-to (widget-get child :entry-to)) + (inhibit-read-only t) + before-change-functions + after-change-functions) + (widget-delete child) + (delete-region entry-from entry-to) + (set-marker entry-from nil) + (set-marker entry-to nil)) + (widget-put widget :children (delq child (widget-get widget :children)))) + (widget-setup) + (widget-apply widget :notify widget)) + +(defun widget-editable-list-entry-create (widget value conv) + ;; Create a new entry to the list. + (let ((type (nth 0 (widget-get widget :args))) + (widget-push-button-gui widget-editable-list-gui) + child delete insert) + (widget-specify-insert + (save-excursion + (and (widget-get widget :indent) + (insert-char ?\ (widget-get widget :indent))) + (insert (widget-get widget :entry-format))) + ;; Parse % escapes in format. + (while (re-search-forward "%\\(.\\)" nil t) + (let ((escape (aref (match-string 1) 0))) + (replace-match "" t t) + (cond ((eq escape ?%) + (insert "%")) + ((eq escape ?i) + (setq insert (apply 'widget-create-child-and-convert + widget 'insert-button + (widget-get widget :insert-button-args)))) + ((eq escape ?d) + (setq delete (apply 'widget-create-child-and-convert + widget 'delete-button + (widget-get widget :delete-button-args)))) + ((eq escape ?v) + (if conv + (setq child (widget-create-child-value + widget type value)) + (setq child (widget-create-child widget type)))) + (t + (error "Unknown escape `%c'" escape))))) + (widget-put widget + :buttons (cons delete + (cons insert + (widget-get widget :buttons)))) + (let ((entry-from (copy-marker (point-min))) + (entry-to (copy-marker (point-max)))) + (set-marker-insertion-type entry-from t) + (set-marker-insertion-type entry-to nil) + (widget-put child :entry-from entry-from) + (widget-put child :entry-to entry-to))) + (widget-put insert :widget child) + (widget-put delete :widget child) + child)) + +;;; The `group' Widget. + +(define-widget 'group 'default + "A widget which group other widgets inside." + :convert-widget 'widget-types-convert-widget + :format "%v" + :value-create 'widget-group-value-create + :value-delete 'widget-children-value-delete + :value-get 'widget-editable-list-value-get + :validate 'widget-children-validate + :match 'widget-group-match + :match-inline 'widget-group-match-inline) + +(defun widget-group-value-create (widget) + ;; Create each component. + (let ((args (widget-get widget :args)) + (value (widget-get widget :value)) + arg answer children) + (while args + (setq arg (car args) + args (cdr args) + answer (widget-match-inline arg value) + value (cdr answer)) + (and (eq (preceding-char) ?\n) + (widget-get widget :indent) + (insert-char ?\ (widget-get widget :indent))) + (push (cond ((null answer) + (widget-create-child widget arg)) + ((widget-get arg :inline) + (widget-create-child-value widget arg (car answer))) + (t + (widget-create-child-value widget arg (car (car answer))))) + children)) + (widget-put widget :children (nreverse children)))) + +(defun widget-group-match (widget values) + ;; Match if the components match. + (and (listp values) + (let ((match (widget-group-match-inline widget values))) + (and match (null (cdr match)))))) + +(defun widget-group-match-inline (widget vals) + ;; Match if the components match. + (let ((args (widget-get widget :args)) + argument answer found) + (while args + (setq argument (car args) + args (cdr args) + answer (widget-match-inline argument vals)) + (if answer + (setq vals (cdr answer) + found (append found (car answer))) + (setq vals nil + args nil))) + (if answer + (cons found vals) + nil))) + +;;; The `visibility' Widget. + +(define-widget 'visibility 'item + "An indicator and manipulator for hidden items." + :format "%[%v%]" + :button-prefix "" + :button-suffix "" + :on "Hide" + :off "Show" + :value-create 'widget-visibility-value-create + :action 'widget-toggle-action + :match (lambda (widget value) t)) + +(defun widget-visibility-value-create (widget) + ;; Insert text representing the `on' and `off' states. + (let ((on (widget-get widget :on)) + (off (widget-get widget :off))) + (if on + (setq on (concat widget-push-button-prefix + on + widget-push-button-suffix)) + (setq on "")) + (if off + (setq off (concat widget-push-button-prefix + off + widget-push-button-suffix)) + (setq off "")) + (if (widget-value widget) + (widget-glyph-insert widget on '("down" "down-pushed")) + (widget-glyph-insert widget off '("right" "right-pushed"))))) + +;;; The `documentation-link' Widget. +;; +;; This is a helper widget for `documentation-string'. + +(define-widget 'documentation-link 'link + "Link type used in documentation strings." + :tab-order -1 + :help-echo 'widget-documentation-link-echo-help + :action 'widget-documentation-link-action) + +(defun widget-documentation-link-echo-help (widget) + "Tell what this link will describe." + (concat "Describe the `" (widget-get widget :value) "' symbol.")) + +(defun widget-documentation-link-action (widget &optional event) + "Display documentation for WIDGET's value. Ignore optional argument EVENT." + (let* ((string (widget-get widget :value)) + (symbol (intern string))) + (if (and (fboundp symbol) (boundp symbol)) + ;; If there are two doc strings, give the user a way to pick one. + (apropos (concat "\\`" (regexp-quote string) "\\'")) + (if (fboundp symbol) + (describe-function symbol) + (describe-variable symbol))))) + +(defcustom widget-documentation-links t + "Add hyperlinks to documentation strings when non-nil." + :type 'boolean + :group 'widget-documentation) + +(defcustom widget-documentation-link-regexp "`\\([^\n`' ]+\\)'" + "Regexp for matching potential links in documentation strings. +The first group should be the link itself." + :type 'regexp + :group 'widget-documentation) + +(defcustom widget-documentation-link-p 'intern-soft + "Predicate used to test if a string is useful as a link. +The value should be a function. The function will be called one +argument, a string, and should return non-nil if there should be a +link for that string." + :type 'function + :options '(widget-documentation-link-p) + :group 'widget-documentation) + +(defcustom widget-documentation-link-type 'documentation-link + "Widget type used for links in documentation strings." + :type 'symbol + :group 'widget-documentation) + +(defun widget-documentation-link-add (widget from to) + (widget-specify-doc widget from to) + (when widget-documentation-links + (let ((regexp widget-documentation-link-regexp) + (predicate widget-documentation-link-p) + (type widget-documentation-link-type) + (buttons (widget-get widget :buttons))) + (save-excursion + (goto-char from) + (while (re-search-forward regexp to t) + (let ((name (match-string 1)) + (begin (match-beginning 1)) + (end (match-end 1))) + (when (funcall predicate name) + (push (widget-convert-button type begin end :value name) + buttons))))) + (widget-put widget :buttons buttons))) + (let ((indent (widget-get widget :indent))) + (when (and indent (not (zerop indent))) + (save-excursion + (save-restriction + (narrow-to-region from to) + (goto-char (point-min)) + (while (search-forward "\n" nil t) + (insert-char ?\ indent))))))) + +;;; The `documentation-string' Widget. + +(define-widget 'documentation-string 'item + "A documentation string." + :format "%v" + :action 'widget-documentation-string-action + :value-delete 'widget-children-value-delete + :value-create 'widget-documentation-string-value-create) + +(defun widget-documentation-string-value-create (widget) + ;; Insert documentation string. + (let ((doc (widget-value widget)) + (indent (widget-get widget :indent)) + (shown (widget-get (widget-get widget :parent) :documentation-shown)) + (start (point))) + (if (string-match "\n" doc) + (let ((before (substring doc 0 (match-beginning 0))) + (after (substring doc (match-beginning 0))) + buttons) + (insert before " ") + (widget-documentation-link-add widget start (point)) + (push (widget-create-child-and-convert + widget 'visibility + :help-echo (lambda (widget) + (concat + (if (widget-value widget) + "Hide" "Show") + " the rest of the documentation")) + :off "More" + :action 'widget-parent-action + shown) + buttons) + (when shown + (setq start (point)) + (when indent + (insert-char ?\ indent)) + (insert after) + (widget-documentation-link-add widget start (point))) + (widget-put widget :buttons buttons)) + (insert doc) + (widget-documentation-link-add widget start (point)))) + (insert "\n")) + +(defun widget-documentation-string-action (widget &rest ignore) + ;; Toggle documentation. + (let ((parent (widget-get widget :parent))) + (widget-put parent :documentation-shown + (not (widget-get parent :documentation-shown)))) + ;; Redraw. + (widget-value-set widget (widget-value widget))) + +;;; The Sexp Widgets. + +(define-widget 'const 'item + "An immutable sexp." + :prompt-value 'widget-const-prompt-value + :format "%t\n%d") + +(defun widget-const-prompt-value (widget prompt value unbound) + ;; Return the value of the const. + (widget-value widget)) + +(define-widget 'function-item 'const + "An immutable function name." + :format "%v\n%h" + :documentation-property (lambda (symbol) + (condition-case nil + (documentation symbol t) + (error nil)))) + +(define-widget 'variable-item 'const + "An immutable variable name." + :format "%v\n%h" + :documentation-property 'variable-documentation) + +(defvar widget-string-prompt-value-history nil + "History of input to `widget-string-prompt-value'.") + +(define-widget 'string 'editable-field + "A string" + :tag "String" + :format "%{%t%}: %v" + :complete-function 'ispell-complete-word + :prompt-history 'widget-string-prompt-value-history) + +(define-widget 'regexp 'string + "A regular expression." + :match 'widget-regexp-match + :validate 'widget-regexp-validate + ;; Doesn't work well with terminating newline. + ;; :value-face 'widget-single-line-field-face + :tag "Regexp") + +(defun widget-regexp-match (widget value) + ;; Match valid regexps. + (and (stringp value) + (condition-case nil + (prog1 t + (string-match value "")) + (error nil)))) + +(defun widget-regexp-validate (widget) + "Check that the value of WIDGET is a valid regexp." + (let ((value (widget-value widget))) + (condition-case data + (prog1 nil + (string-match value "")) + (error (widget-put widget :error (error-message-string data)) + widget)))) + +(define-widget 'file 'string + "A file widget. +It will read a file name from the minibuffer when invoked." + :complete-function 'widget-file-complete + :prompt-value 'widget-file-prompt-value + :format "%{%t%}: %v" + ;; Doesn't work well with terminating newline. + ;; :value-face 'widget-single-line-field-face + :tag "File") + +(defun widget-file-complete () + "Perform completion on file name preceding point." + (interactive) + (let* ((end (point)) + (beg (save-excursion + (skip-chars-backward "^ ") + (point))) + (pattern (buffer-substring beg end)) + (name-part (file-name-nondirectory pattern)) + (directory (file-name-directory pattern)) + (completion (file-name-completion name-part directory))) + (cond ((eq completion t)) + ((null completion) + (message "Can't find completion for \"%s\"" pattern) + (ding)) + ((not (string= name-part completion)) + (delete-region beg end) + (insert (expand-file-name completion directory))) + (t + (message "Making completion list...") + (let ((list (file-name-all-completions name-part directory))) + (setq list (sort list 'string<)) + (with-output-to-temp-buffer "*Completions*" + (display-completion-list list))) + (message "Making completion list...%s" "done"))))) + +(defun widget-file-prompt-value (widget prompt value unbound) + ;; Read file from minibuffer. + (abbreviate-file-name + (if unbound + (read-file-name prompt) + (let ((prompt2 (format "%s (default %s) " prompt value)) + (dir (file-name-directory value)) + (file (file-name-nondirectory value)) + (must-match (widget-get widget :must-match))) + (read-file-name prompt2 dir nil must-match file))))) + +;;;(defun widget-file-action (widget &optional event) +;;; ;; Read a file name from the minibuffer. +;;; (let* ((value (widget-value widget)) +;;; (dir (file-name-directory value)) +;;; (file (file-name-nondirectory value)) +;;; (menu-tag (widget-apply widget :menu-tag-get)) +;;; (must-match (widget-get widget :must-match)) +;;; (answer (read-file-name (concat menu-tag ": (default `" value "') ") +;;; dir nil must-match file))) +;;; (widget-value-set widget (abbreviate-file-name answer)) +;;; (widget-setup) +;;; (widget-apply widget :notify widget event))) + +(define-widget 'directory 'file + "A directory widget. +It will read a directory name from the minibuffer when invoked." + :tag "Directory") + +(defvar widget-symbol-prompt-value-history nil + "History of input to `widget-symbol-prompt-value'.") + +(define-widget 'symbol 'editable-field + "A lisp symbol." + :value nil + :tag "Symbol" + :format "%{%t%}: %v" + :match (lambda (widget value) (symbolp value)) + :complete-function 'lisp-complete-symbol + :prompt-internal 'widget-symbol-prompt-internal + :prompt-match 'symbolp + :prompt-history 'widget-symbol-prompt-value-history + :value-to-internal (lambda (widget value) + (if (symbolp value) + (symbol-name value) + value)) + :value-to-external (lambda (widget value) + (if (stringp value) + (intern value) + value))) + +(defun widget-symbol-prompt-internal (widget prompt initial history) + ;; Read file from minibuffer. + (let ((answer (completing-read prompt obarray + (widget-get widget :prompt-match) + nil initial history))) + (if (and (stringp answer) + (not (zerop (length answer)))) + answer + (error "No value")))) + +(defvar widget-function-prompt-value-history nil + "History of input to `widget-function-prompt-value'.") + +(define-widget 'function 'sexp + "A lisp function." + :complete-function 'lisp-complete-symbol + :prompt-value 'widget-field-prompt-value + :prompt-internal 'widget-symbol-prompt-internal + :prompt-match 'fboundp + :prompt-history 'widget-function-prompt-value-history + :action 'widget-field-action + :tag "Function") + +(defvar widget-variable-prompt-value-history nil + "History of input to `widget-variable-prompt-value'.") + +(define-widget 'variable 'symbol + ;; Should complete on variables. + "A lisp variable." + :prompt-match 'boundp + :prompt-history 'widget-variable-prompt-value-history + :tag "Variable") + +;; This part issues a warning when compiling without Mule. Is there a +;; way of shutting it up? +;; +;; OK, I'll simply comment the whole thing out, until someone decides +;; to do something with it. +;(defvar widget-coding-system-prompt-value-history nil +; "History of input to `widget-coding-system-prompt-value'.") + +;(define-widget 'coding-system 'symbol +; "A MULE coding-system." +; :format "%{%t%}: %v" +; :tag "Coding system" +; :prompt-history 'widget-coding-system-prompt-value-history +; :prompt-value 'widget-coding-system-prompt-value +; :action 'widget-coding-system-action) + +;(defun widget-coding-system-prompt-value (widget prompt value unbound) +; ;; Read coding-system from minibuffer. +; (intern +; (completing-read (format "%s (default %s) " prompt value) +; (mapcar (lambda (sym) +; (list (symbol-name sym))) +; (coding-system-list))))) + +;(defun widget-coding-system-action (widget &optional event) +; ;; Read a file name from the minibuffer. +; (let ((answer +; (widget-coding-system-prompt-value +; widget +; (widget-apply widget :menu-tag-get) +; (widget-value widget) +; t))) +; (widget-value-set widget answer) +; (widget-apply widget :notify widget event) +; (widget-setup))) + +(define-widget 'sexp 'editable-field + "An arbitrary lisp expression." + :tag "Lisp expression" + :format "%{%t%}: %v" + :value nil + :validate 'widget-sexp-validate + :match (lambda (widget value) t) + :value-to-internal 'widget-sexp-value-to-internal + :value-to-external (lambda (widget value) (read value)) + :prompt-history 'widget-sexp-prompt-value-history + :prompt-value 'widget-sexp-prompt-value) + +(defun widget-sexp-value-to-internal (widget value) + ;; Use pp for printer representation. + (let ((pp (if (symbolp value) + (prin1-to-string value) + (pp-to-string value)))) + (while (string-match "\n\\'" pp) + (setq pp (substring pp 0 -1))) + (if (or (string-match "\n\\'" pp) + (> (length pp) 40)) + (concat "\n" pp) + pp))) + +(defun widget-sexp-validate (widget) + ;; Valid if we can read the string and there is no junk left after it. + (save-excursion + (let ((buffer (set-buffer (get-buffer-create " *Widget Scratch*")))) + (erase-buffer) + (insert (widget-apply widget :value-get)) + (goto-char (point-min)) + (condition-case data + (let ((value (read buffer))) + (if (eobp) + (if (widget-apply widget :match value) + nil + (widget-put widget :error (widget-get widget :type-error)) + widget) + (widget-put widget + :error (format "Junk at end of expression: %s" + (buffer-substring (point) + (point-max)))) + widget)) + (error (widget-put widget :error (error-message-string data)) + widget))))) + +(defvar widget-sexp-prompt-value-history nil + "History of input to `widget-sexp-prompt-value'.") + +(defun widget-sexp-prompt-value (widget prompt value unbound) + ;; Read an arbitrary sexp. + (let ((found (read-string prompt + (if unbound nil (cons (prin1-to-string value) 0)) + (widget-get widget :prompt-history)))) + (save-excursion + (let ((buffer (set-buffer (get-buffer-create " *Widget Scratch*")))) + (erase-buffer) + (insert found) + (goto-char (point-min)) + (let ((answer (read buffer))) + (unless (eobp) + (error "Junk at end of expression: %s" + (buffer-substring (point) (point-max)))) + answer))))) + +(define-widget 'restricted-sexp 'sexp + "A Lisp expression restricted to values that match. +To use this type, you must define :match or :match-alternatives." + :type-error "The specified value is not valid" + :match 'widget-restricted-sexp-match + :value-to-internal (lambda (widget value) + (if (widget-apply widget :match value) + (prin1-to-string value) + value))) + +(defun widget-restricted-sexp-match (widget value) + (let ((alternatives (widget-get widget :match-alternatives)) + matched) + (while (and alternatives (not matched)) + (if (cond ((functionp (car alternatives)) + (funcall (car alternatives) value)) + ((and (consp (car alternatives)) + (eq (car (car alternatives)) 'quote)) + (eq value (nth 1 (car alternatives))))) + (setq matched t)) + (setq alternatives (cdr alternatives))) + matched)) + +(define-widget 'integer 'restricted-sexp + "An integer." + :tag "Integer" + :value 0 + :type-error "This field should contain an integer" + :match-alternatives '(integerp)) + +(define-widget 'number 'restricted-sexp + "A floating point number." + :tag "Number" + :value 0.0 + :type-error "This field should contain a number" + :match-alternatives '(numberp)) + +(define-widget 'character 'editable-field + "A character." + :tag "Character" + :value ?\0 + :format "%{%t%}: %v" + :valid-regexp "\\`[\0-\377]\\'" + :error "This field should contain a single character" + :value-to-internal (lambda (widget value) + (if (stringp value) + value + (char-to-string value))) + :value-to-external (lambda (widget value) + (if (stringp value) + (aref value 0) + value)) + :match (lambda (widget value) + (characterp value))) + +(define-widget 'list 'group + "A lisp list." + :tag "List" + :format "%{%t%}:\n%v") + +(define-widget 'vector 'group + "A lisp vector." + :tag "Vector" + :format "%{%t%}:\n%v" + :match 'widget-vector-match + :value-to-internal (lambda (widget value) (append value nil)) + :value-to-external (lambda (widget value) (vconcat value))) + +(defun widget-vector-match (widget value) + (and (vectorp value) + (widget-group-match widget + (widget-apply widget :value-to-internal value)))) + +(define-widget 'cons 'group + "A cons-cell." + :tag "Cons-cell" + :format "%{%t%}:\n%v" + :match 'widget-cons-match + :value-to-internal (lambda (widget value) + (list (car value) (cdr value))) + :value-to-external (lambda (widget value) + (cons (car value) (cadr value)))) + +(defun widget-cons-match (widget value) + (and (consp value) + (widget-group-match widget + (widget-apply widget :value-to-internal value)))) + +(define-widget 'choice 'menu-choice + "A union of several sexp types." + :tag "Choice" + :format "%{%t%}: %[Value Menu%] %v" + :button-prefix 'widget-push-button-prefix + :button-suffix 'widget-push-button-suffix + :prompt-value 'widget-choice-prompt-value) + +(defun widget-choice-prompt-value (widget prompt value unbound) + "Make a choice." + (let ((args (widget-get widget :args)) + (completion-ignore-case (widget-get widget :case-fold)) + current choices old) + ;; Find the first arg that match VALUE. + (let ((look args)) + (while look + (if (widget-apply (car look) :match value) + (setq old (car look) + look nil) + (setq look (cdr look))))) + ;; Find new choice. + (setq current + (cond ((= (length args) 0) + nil) + ((= (length args) 1) + (nth 0 args)) + ((and (= (length args) 2) + (memq old args)) + (if (eq old (nth 0 args)) + (nth 1 args) + (nth 0 args))) + (t + (while args + (setq current (car args) + args (cdr args)) + (setq choices + (cons (cons (widget-apply current :menu-tag-get) + current) + choices))) + (let ((val (completing-read prompt choices nil t))) + (if (stringp val) + (let ((try (try-completion val choices))) + (when (stringp try) + (setq val try)) + (cdr (assoc val choices))) + nil))))) + (if current + (widget-prompt-value current prompt nil t) + value))) + +(define-widget 'radio 'radio-button-choice + "A union of several sexp types." + :tag "Choice" + :format "%{%t%}:\n%v" + :prompt-value 'widget-choice-prompt-value) + +(define-widget 'repeat 'editable-list + "A variable length homogeneous list." + :tag "Repeat" + :format "%{%t%}:\n%v%i\n") + +(define-widget 'set 'checklist + "A list of members from a fixed set." + :tag "Set" + :format "%{%t%}:\n%v") + +(define-widget 'boolean 'toggle + "To be nil or non-nil, that is the question." + :tag "Boolean" + :prompt-value 'widget-boolean-prompt-value + :button-prefix 'widget-push-button-prefix + :button-suffix 'widget-push-button-suffix + :format "%{%t%}: %[Toggle%] %v\n" + :on "on (non-nil)" + :off "off (nil)") + +(defun widget-boolean-prompt-value (widget prompt value unbound) + ;; Toggle a boolean. + (y-or-n-p prompt)) + +;;; The `color' Widget. + +(define-widget 'color 'editable-field + "Choose a color name (with sample)." + :format "%[%t%]: %v (%{sample%})\n" + :size 10 + :tag "Color" + :value "black" + :complete 'widget-color-complete + :sample-face-get 'widget-color-sample-face-get + :notify 'widget-color-notify + :action 'widget-color-action) + +(defun widget-color-complete (widget) + "Complete the color in WIDGET." + (let* ((prefix (buffer-substring-no-properties (widget-field-start widget) + (point))) + (list (read-color-completion-table)) + (completion (try-completion prefix list))) + (cond ((eq completion t) + (message "Exact match")) + ((null completion) + (error "Can't find completion for \"%s\"" prefix)) + ((not (string-equal prefix completion)) + (insert (substring completion (length prefix)))) + (t + (message "Making completion list...") + (let ((list (all-completions prefix list nil))) + (with-output-to-temp-buffer "*Completions*" + (display-completion-list list))) + (message "Making completion list...done"))))) + +(defun widget-color-sample-face-get (widget) + (or (widget-get widget :sample-face) + (let ((color (widget-value widget)) + (face (make-face (gensym "sample-face-") nil t))) + ;; Use the face object, not its name, to prevent lossage if gc + ;; happens before applying the face. + (widget-put widget :sample-face face) + (and color + (not (equal color "")) + (valid-color-name-p color) + (set-face-foreground face color)) + face))) + +(defvar widget-color-history nil + "History of entered colors.") + +(defun widget-color-action (widget &optional event) + ;; Prompt for a color. + (let* ((tag (widget-apply widget :menu-tag-get)) + (answer (read-color (concat tag ": ")))) + (unless (zerop (length answer)) + (widget-value-set widget answer) + (widget-setup) + (widget-apply widget :notify widget event)))) + +(defun widget-color-notify (widget child &optional event) + "Update the sample, and notify the parent." + (let* ((face (widget-apply widget :sample-face-get)) + (color (widget-value widget))) + (if (valid-color-name-p color) + (set-face-foreground face color) + (remove-face-property face 'foreground))) + (widget-default-notify widget child event)) + +;; Is this a misnomer? +(defun widget-at (pos) + "The button or field at POS." + (or (get-char-property pos 'button) + (get-char-property pos 'field))) + +(defun widget-echo-help (pos) + "Display the help echo for widget at POS." + (let* ((widget (widget-at pos)) + (help-echo (and widget (widget-get widget :help-echo)))) + (and (functionp help-echo) + (setq help-echo (funcall help-echo widget))) + (when (stringp help-echo) + (display-message 'help-echo help-echo)))) + +;;; The End: + +(provide 'wid-edit) + +;; wid-edit.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/widget.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,75 @@ +;;; widget.el --- a library of user interface components. + +;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. + +;; Author: Per Abrahamsen <abraham@dina.kvl.dk> +;; Maintainer: Hrvoje Niksic <hniksic@srce.hr> +;; Keywords: help, extensions, faces, hypermedia, dumped +;; Version: 1.9960-x +;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ + +;; 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. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;; If you want to use this code, please visit the URL above. + +;; This file only contain the code needed to define new widget types. +;; Everything else is autoloaded from `wid-edit.el'. + +;;; Code: + +;; Neither XEmacs, nor latest GNU Emacs need this -- provided for +;; compatibility. +;; (defalias 'define-widget-keywords 'ignore) + +(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))))))) + +(defun define-widget (name class doc &rest args) + "Define a new widget type named NAME from CLASS. + +NAME and CLASS should both be symbols, CLASS should be one of the +existing widget types, or nil to create the widget from scratch. + +After the new widget has been defined, the following two calls will +create identical widgets: + +* (widget-create NAME) + +* (apply 'widget-create CLASS ARGS) + +The third argument DOC is a documentation string for the widget." + (put name 'widget-type (cons class args)) + (put name 'widget-documentation doc) + name) + +;;; The End. + +(provide 'widget) + +;;; widget.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/window-xemacs.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,619 @@ +;;; window-xemacs.el --- XEmacs window commands aside from those written in C. + +;; Copyright (C) 1985, 1989, 1993-94, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1995, 1996 Ben Wing. + +;; Maintainer: XEmacs Development Team +;; Keywords: frames, extensions, dumped + +;; 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, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: Not synched. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;; slb - 5/29/97 +;; Split apart from window.el in order to keep that file better in synch +;; with Emacs. + +;;; Code: + +(defun backward-other-window (arg &optional all-frames device) + "Select the ARG'th different window on this frame, going backwards. +This is just like calling `other-window' with the arg negated." + (interactive "p") + (other-window (- arg) all-frames device)) + +(defun windows-of-buffer (&optional buffer) + "Returns a list of windows that have BUFFER in them. +If BUFFER is not specified, the current buffer will be used." + (or (bufferp buffer) + (if (stringp buffer) + (setq buffer (or (get-buffer buffer) + (get-file-buffer buffer))) + (setq buffer (current-buffer)))) + (let* ((firstwin (next-window nil nil t)) + (wind firstwin) + (done nil) + window-list) + (while (not done) + (if (eq (window-buffer wind) buffer) + (setq window-list (append window-list (list wind)))) + (setq wind (next-window wind nil t)) + (setq done (eq wind firstwin))) + window-list)) + +(defun buffer-in-multiple-windows-p (&optional buffer) + "Return t if BUFFER is in multiple windows. +If BUFFER is not specified, the current buffer will be used." + (setq buffer (or buffer + (get-buffer buffer) + (get-file-buffer buffer) + (current-buffer))) + (> (length (windows-of-buffer buffer)) 1)) + +(defun window-list (&optional frame minibuf window) + "Return a list of windows on FRAME, beginning with WINDOW. +FRAME and WINDOW default to the selected ones. +Optional second arg MINIBUF t means count the minibuffer window +even if not active. If MINIBUF is neither t nor nil it means +not to count the minibuffer even if it is active." + (setq window (or window (selected-window)) + frame (or frame (selected-frame))) + (if (not (eq (window-frame window) frame)) + (error "Window must be on frame.")) + (let ((current-frame (selected-frame)) + list) + (unwind-protect + (save-window-excursion + (select-frame frame) + (walk-windows + (function (lambda (cur-window) + (if (not (eq window cur-window)) + (setq list (cons cur-window list))))) + minibuf) + (setq list (cons window list))) + (select-frame current-frame)))) + +;; We used to have set-window-dedicated-p as an obsolete version +;; of set-window-buffer-dedicated, but it really makes more sense +;; this way. + +(make-obsolete 'set-window-buffer-dedicated 'set-window-dedicated-p) +(defun set-window-buffer-dedicated (window buffer) + "Make WINDOW display BUFFER and be dedicated to that buffer. +Then Emacs will not automatically change which buffer appears in WINDOW. +If BUFFER is nil, make WINDOW not be dedicated (but don't change which +buffer appears in it currently)." + (if (bufferp buffer) + (set-window-buffer window (get-buffer-create buffer))) + (set-window-dedicated-p window (not (null buffer)))) + + +;; The window-config stack is stored as a list in frame property +;; 'window-config-stack, with the most recent element at the front. +;; When you pop off an element, the popped off element gets put at the +;; front of frame property 'window-config-unpop-stack, so you can +;; retrieve it using unpop-window-configuration. + +(defcustom window-config-stack-max 16 + "*Maximum size of window configuration stack. +Start discarding off end if it gets this big." + :type 'integer + :group 'windows) + +(defun window-config-stack (&optional frame) + (or frame (setq frame (selected-frame))) + (let ((stack (frame-property frame 'window-config-stack))) + (if stack + (set-undoable-stack-max stack window-config-stack-max) + (progn + (setq stack (make-undoable-stack window-config-stack-max)) + (set-frame-property frame 'window-config-stack stack))) + stack)) + +(defun push-window-configuration (&optional config) + "Push the current window configuration onto the window-config stack. +If CONFIG is specified, push it instead of the current window configuration. +Each frame has its own window-config stack." + (interactive) + (let ((wc (or config (current-window-configuration))) + (stack (window-config-stack))) + (if (or (= 0 (undoable-stack-a-length stack)) + (not (equal (undoable-stack-a-top stack) wc))) + (progn + (undoable-stack-push stack wc) + ;; kludge. + (if (featurep 'toolbar) + (set-specifier-dirty-flag default-toolbar)))))) + +(defun pop-window-configuration () + "Pop the top window configuration off the window-config stack and set it. +Before setting the new window configuration, the current window configuration + is pushed onto the \"unpop\" stack. +`unpop-window-configuration' undoes what this function does. +Each frame has its own window-config and \"unpop\" stack." + (interactive) + (let ((stack (window-config-stack)) + (wc (current-window-configuration)) + popped) + (condition-case nil + (progn + (setq popped (undoable-stack-pop stack)) + (while (equal popped wc) + (setq popped (undoable-stack-pop stack))) + (undoable-stack-push stack wc) + (undoable-stack-undo stack) + (set-window-configuration popped) + ;; probably not necessary: + (if (featurep 'toolbar) + (set-specifier-dirty-flag default-toolbar)) + popped) + (trunc-stack-bottom + (error "Bottom of window config stack"))))) + +(defun unpop-window-configuration () + "Undo the effect of the most recent `pop-window-configuration'. +This does exactly the inverse of what `pop-window-configuration' does: + i.e. it pops a window configuration off of the \"unpop\" stack and + pushes the current window configuration onto the window-config stack. +Each frame has its own window-config and \"unpop\" stack." + (interactive) + (let ((stack (window-config-stack)) + (wc (current-window-configuration)) + popped) + (condition-case nil + (progn + (setq popped + (progn + (undoable-stack-redo stack) + (undoable-stack-pop stack))) + (while (equal popped wc) + (setq popped + (progn + (undoable-stack-redo stack) + (undoable-stack-pop stack)))) + (undoable-stack-push stack wc) + (set-window-configuration popped) + ;; probably not necessary: + (if (featurep 'toolbar) + (set-specifier-dirty-flag default-toolbar)) + popped) + (trunc-stack-bottom + (error "Top of window config stack"))))) + + +;;;;;;;;;;;;; display-buffer, moved here from C. Hallelujah. + +(defvar display-buffer-function nil + "If non-nil, function to call to handle `display-buffer'. +It will receive three args: the same as those to `display-buffer'.") + +(defvar pre-display-buffer-function nil + "If non-nil, function that will be called from `display-buffer' +as the first action. It will receive three args: the same as those +to `display-buffer'. +This function may be used to select an appropriate frame for the buffer, +for example. See also the variable `display-buffer-function', which may +be used to completely replace the `display-buffer' function. +If the return value of this function is non-nil, it should be a frame, +and that frame will be used to display the buffer.") + +(defcustom pop-up-frames nil + "*Non-nil means `display-buffer' should make a separate frame." + :type 'boolean + :group 'frames) + +(defvar pop-up-frame-function nil + "Function to call to handle automatic new frame creation. +It is called with no arguments and should return a newly created frame. + +A typical value might be `(lambda () (new-frame pop-up-frame-alist))' +where `pop-up-frame-alist' would hold the default frame parameters.") + +(defcustom special-display-buffer-names nil + "*List of buffer names that should have their own special frames. +Displaying a buffer whose name is in this list makes a special frame for it +using `special-display-function'. + +An element of the list can be a cons cell instead of just a string. +Then the car should be a buffer name, and the cdr specifies frame +parameters for creating the frame for that buffer. +More precisely, the cdr is passed as the second argument to +the function found in `special-display-function', when making that frame. +See also `special-display-regexps'." + :type '(repeat (choice :value "" + (string :tag "Name") + (cons :menu-tag "Properties" + :value ("" . nil) + (string :tag "Name") + (repeat :tag "Properties" + (group :inline t + (symbol :tag "Property") + (sexp :tag "Value")))))) + :group 'frames) + +(defcustom special-display-regexps nil + "*List of regexps saying which buffers should have their own special frames. +If a buffer name matches one of these regexps, it gets its own frame. +Displaying a buffer whose name is in this list makes a special frame for it +using `special-display-function'. + +An element of the list can be a cons cell instead of just a string. +Then the car should be the regexp, and the cdr specifies frame +parameters for creating the frame for buffers that match. +More precisely, the cdr is passed as the second argument to +the function found in `special-display-function', when making that frame. +See also `special-display-buffer-names'." + :type '(repeat (choice :value "" + regexp + (cons :menu-tag "Properties" + :value ("" . nil) + regexp + (repeat :tag "Properties" + (group :inline t + (symbol :tag "Property") + (sexp :tag "Value")))))) + :group 'frames) + +(defvar special-display-function nil + "Function to call to make a new frame for a special buffer. +It is called with two arguments, the buffer and optional buffer specific +data, and should return a window displaying that buffer. +The default value makes a separate frame for the buffer, +using `special-display-frame-alist' to specify the frame parameters. + +A buffer is special if its is listed in `special-display-buffer-names' +or matches a regexp in `special-display-regexps'.") + +(defcustom same-window-buffer-names nil + "*List of buffer names that should appear in the selected window. +Displaying one of these buffers using `display-buffer' or `pop-to-buffer' +switches to it in the selected window, rather than making it appear +in some other window. + +An element of the list can be a cons cell instead of just a string. +Then the car must be a string, which specifies the buffer name. +This is for compatibility with `special-display-buffer-names'; +the cdr of the cons cell is ignored. + +See also `same-window-regexps'." + :type '(repeat (string :tag "Name")) + :group 'windows) + +(defcustom same-window-regexps nil + "*List of regexps saying which buffers should appear in the selected window. +If a buffer name matches one of these regexps, then displaying it +using `display-buffer' or `pop-to-buffer' switches to it +in the selected window, rather than making it appear in some other window. + +An element of the list can be a cons cell instead of just a string. +Then the car must be a string, which specifies the buffer name. +This is for compatibility with `special-display-buffer-names'; +the cdr of the cons cell is ignored. + +See also `same-window-buffer-names'." + :type '(repeat regexp) + :group 'windows) + +(defcustom pop-up-windows t + "*Non-nil means display-buffer should make new windows." + :type 'boolean + :group 'windows) + +(defcustom split-height-threshold 500 + "*display-buffer would prefer to split the largest window if this large. +If there is only one window, it is split regardless of this value." + :type 'integer + :group 'windows) + +(defcustom split-width-threshold 500 + "*display-buffer would prefer to split the largest window if this large. +If there is only one window, it is split regardless of this value." + :type 'integer + :group 'windows) + +;; Deiconify the frame containing the window WINDOW, then return WINDOW. + +(defun display-buffer-1 (window) + (if (frame-iconified-p (window-frame window)) + (make-frame-visible (window-frame window))) + window) + +;; Can you believe that all of this crap was formerly in C? +;; Praise Jesus that it's not there any more. + +(defun display-buffer (buffer &optional not-this-window-p override-frame) + "Make BUFFER appear in some window on the current frame, but don't select it. +BUFFER can be a buffer or a buffer name. +If BUFFER is shown already in some window in the current frame, +just uses that one, unless the window is the selected window and +NOT-THIS-WINDOW-P is non-nil (interactively, with prefix arg). + +If BUFFER has a dedicated frame, display on that frame instead of +the current frame, unless OVERRIDE-FRAME is non-nil. + +If OVERRIDE-FRAME is non-nil, display on that frame instead of +the current frame (or the dedicated frame). + +If `pop-up-windows' is non-nil, always use the +current frame and create a new window regardless of whether the +buffer has a dedicated frame, and regardless of whether +OVERRIDE-FRAME was specified. + +If `pop-up-frames' is non-nil, make a new frame if no window shows BUFFER. + +Returns the window displaying BUFFER." + (interactive "BDisplay buffer:\nP") + + (let ((wconfig (current-window-configuration)) + (result + ;; We just simulate a `return' in C. This function is way ugly + ;; and does `returns' all over the place and there's no sense + ;; in trying to rewrite it to be more Lispy. + (catch 'done + (let (window old-frame target-frame explicit-frame) + (setq old-frame (or (last-nonminibuf-frame) (selected-frame))) + (setq buffer (get-buffer buffer)) + (check-argument-type 'bufferp buffer) + + (setq explicit-frame + (if pre-display-buffer-function + (funcall pre-display-buffer-function buffer + not-this-window-p + override-frame))) + + ;; Give the user the ability to completely reimplement + ;; this function via the `display-buffer-function'. + (if display-buffer-function + (throw 'done + (funcall display-buffer-function buffer + not-this-window-p + override-frame))) + + ;; If the buffer has a dedicated frame, that takes + ;; precedence over the current frame, and over what the + ;; pre-display-buffer-function did. + (let ((dedi (buffer-dedicated-frame buffer))) + (if (frame-live-p dedi) (setq explicit-frame dedi))) + + ;; if override-frame is supplied, that takes precedence over + ;; everything. This is gonna look bad if the + ;; pre-display-buffer-function raised some other frame + ;; already. + (if override-frame + (progn + (check-argument-type 'frame-live-p override-frame) + (setq explicit-frame override-frame))) + + (setq target-frame + (or explicit-frame + (last-nonminibuf-frame) + (selected-frame))) + + ;; If we have switched frames, then set not-this-window-p + ;; to false. Switching frames means that selected-window + ;; is no longer the same as it was on entry -- it's the + ;; selected-window of target_frame instead of old_frame, + ;; so it's a fine candidate for display. + (if (not (eq old-frame target-frame)) + (setq not-this-window-p nil)) + + ;; if it's in the selected window, and that's ok, then we're done. + (if (and (not not-this-window-p) + (eq buffer (window-buffer (selected-window)))) + (throw 'done (display-buffer-1 (selected-window)))) + + ;; See if the user has specified this buffer should appear + ;; in the selected window. + + (if not-this-window-p + nil + + (if (or (member (buffer-name buffer) same-window-buffer-names) + (assoc (buffer-name buffer) same-window-buffer-names)) + (progn + (switch-to-buffer buffer) + (throw 'done (display-buffer-1 (selected-window))))) + + (let ((tem same-window-regexps)) + (while tem + (let ((car (car tem))) + (if (or + (and (stringp car) + (string-match car (buffer-name buffer))) + (and (consp car) (stringp (car car)) + (string-match (car car) (buffer-name buffer)))) + (progn + (switch-to-buffer buffer) + (throw 'done (display-buffer-1 + (selected-window)))))) + (setq tem (cdr tem))))) + + ;; If pop-up-frames, look for a window showing BUFFER on + ;; any visible or iconified frame. Otherwise search only + ;; the current frame. + (if (and (not explicit-frame) + (or pop-up-frames (not (last-nonminibuf-frame)))) + (setq target-frame 0)) + + ;; Otherwise, find some window that it's already in, and + ;; return that, unless that window is the selected window + ;; and that isn't ok. What a contorted mess! + (setq window (get-buffer-window buffer target-frame)) + (if (and window + (or (not not-this-window-p) + (not (eq window (selected-window))))) + (throw 'done (display-buffer-1 window))) + + ;; Certain buffer names get special handling. + (if special-display-function + (progn + (if (member (buffer-name buffer) + special-display-buffer-names) + (throw 'done (funcall special-display-function buffer))) + + (let ((tem (assoc (buffer-name buffer) + special-display-buffer-names))) + (if tem + (throw 'done (funcall special-display-function + buffer (cdr tem))))) + + (let ((tem special-display-regexps)) + (while tem + (let ((car (car tem))) + (if (and (stringp car) + (string-match car (buffer-name buffer))) + (throw 'done + (funcall special-display-function buffer))) + (if (and (consp car) + (stringp (car car)) + (string-match (car car) + (buffer-name buffer))) + (throw 'done (funcall + special-display-function buffer + (cdr car))))) + (setq tem (cdr tem)))))) + + ;; If there are no frames open that have more than a minibuffer, + ;; we need to create a new frame. + (if (or pop-up-frames + (null (last-nonminibuf-frame))) + (progn + (setq window (frame-selected-window + (funcall pop-up-frame-function))) + (set-window-buffer window buffer) + (throw 'done (display-buffer-1 window)))) + + ;; Otherwise, make it be in some window, splitting if + ;; appropriate/possible. Do not split a window if we are + ;; displaying the buffer in a different frame than that which + ;; was current when we were called. (It is already in a + ;; different window by virtue of being in another frame.) + (if (or (and pop-up-windows (eq target-frame old-frame)) + (eq 'only (frame-property (selected-frame) 'minibuffer)) + ;; If the current frame is a special display frame, + ;; don't try to reuse its windows. + (window-dedicated-p (frame-root-window (selected-frame)))) + (progn + (if (eq 'only (frame-property (selected-frame) 'minibuffer)) + (setq target-frame (last-nonminibuf-frame))) + + ;; Don't try to create a window if would get an error with + ;; height. + (if (< split-height-threshold (* 2 window-min-height)) + (setq split-height-threshold (* 2 window-min-height))) + + ;; Same with width. + (if (< split-width-threshold (* 2 window-min-width)) + (setq split-width-threshold (* 2 window-min-width))) + + ;; If the frame we would try to split cannot be split, + ;; try other frames. + (if (frame-property (if (null target-frame) + (selected-frame) + (last-nonminibuf-frame)) + 'unsplittable) + (setq window + ;; Try visible frames first. + (or (get-largest-window 'visible) + ;; If that didn't work, try iconified frames. + (get-largest-window 0) + (get-largest-window t))) + (setq window (get-largest-window target-frame))) + + ;; If we got a tall enough full-width window that + ;; can be split, split it. + (if (and window + (not (frame-property (window-frame window) + 'unsplittable)) + (>= (window-height window) split-height-threshold) + (or (>= (window-width window) + split-width-threshold) + (and (window-leftmost-p window) + (window-rightmost-p window)))) + (setq window (split-window window)) + (let (upper +;; lower + other) + (setq window (get-lru-window target-frame)) + ;; If the LRU window is selected, and big enough, + ;; and can be split, split it. + (if (and window + (not (frame-property (window-frame window) + 'unsplittable)) + (or (eq window (selected-window)) + (not (window-parent window))) + (>= (window-height window) + (* 2 window-min-height))) + (setq window (split-window window))) + ;; If get-lru-window returned nil, try other approaches. + ;; Try visible frames first. + (or window + (setq window (or (get-largest-window 'visible) + ;; If that didn't work, try + ;; iconified frames. + (get-largest-window 0) + ;; Try invisible frames. + (get-largest-window t) + ;; As a last resort, make + ;; a new frame. + (frame-selected-window + (funcall + pop-up-frame-function))))) + ;; If window appears above or below another, + ;; even out their heights. + (if (window-previous-child window) + (setq other (window-previous-child window) +;; lower window + upper other)) + (if (window-next-child window) + (setq other (window-next-child window) +;; lower other + upper window)) + ;; Check that OTHER and WINDOW are vertically arrayed. + (if (and other + (not (= (nth 1 (window-pixel-edges other)) + (nth 1 (window-pixel-edges window)))) + (> (window-pixel-height other) + (window-pixel-height window))) + (enlarge-window (- (/ (+ (window-height other) + (window-height window)) + 2) + (window-height upper)) + nil upper))))) + + (setq window (get-lru-window target-frame))) + + ;; Bring the window's previous buffer to the top of the MRU chain. + (if (window-buffer window) + (save-excursion + (save-selected-window + (select-window window) + (record-buffer (window-buffer window))))) + + (set-window-buffer window buffer) + + (display-buffer-1 window))))) + (or (equal wconfig (current-window-configuration)) + (push-window-configuration wconfig)) + result)) + +;;; window-xemacs.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/window.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,374 @@ +;;; window.el --- XEmacs window commands aside from those written in C. + +;; Copyright (C) 1985, 1989, 1993-94, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1995, 1996 Ben Wing. + +;; Maintainer: XEmacs Development Team +;; Keywords: frames, extensions, dumped + +;; 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, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: Emacs/Mule zeta. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;;; Code: + +;;;; Window tree functions. + +(defun one-window-p (&optional nomini all-frames device) + "Returns non-nil if the selected window is the only window (in its frame). +Optional arg NOMINI non-nil means don't count the minibuffer +even if it is active. + +The optional arg ALL-FRAMES t means count windows on all frames. +If it is `visible', count windows on all visible frames. +ALL-FRAMES nil or omitted means count only the selected frame, +plus the minibuffer it uses (which may be on another frame). +ALL-FRAMES = 0 means count windows on all visible and iconified frames. +If ALL-FRAMES is any other value, count only the selected frame. + +If optional third argument DEVICE is nil or omitted, count frames +on all devices. +If a device, count frames only on that device. +If a device type, count frames only on devices of that type. +Otherwise, count frames only on the selected device." + (let ((base-window (selected-window))) + (if (and nomini (eq base-window (minibuffer-window))) + (setq base-window (next-window base-window))) + (eq base-window + (next-window base-window (if nomini 'arg) all-frames device)))) + +(defun walk-windows (proc &optional minibuf all-frames device) + "Cycle through all visible windows, calling PROC for each one. +PROC is called with a window as argument. + +Optional second arg MINIBUF t means count the minibuffer window even +if not active. MINIBUF nil or omitted means count the minibuffer iff +it is active. MINIBUF neither t nor nil means not to count the +minibuffer even if it is active. + +Several frames may share a single minibuffer; if the minibuffer +counts, all windows on all frames that share that minibuffer count +too. Therefore, when a separate minibuffer frame is active, +`walk-windows' includes the windows in the frame from which you +entered the minibuffer, as well as the minibuffer window. But if the +minibuffer does not count, only windows from WINDOW's frame count. + +ALL-FRAMES is the optional third argument. +ALL-FRAMES nil or omitted means cycle within the frames as specified above. +ALL-FRAMES = `visible' means include windows on all visible frames. +ALL-FRAMES = 0 means include windows on all visible and iconified frames. +ALL-FRAMES = t means include windows on all frames including invisible frames. +Anything else means restrict to WINDOW's frame. + +If optional fourth argument DEVICE is nil or omitted, include frames +on all devices. +If a device, include frames only on that device. +If a device type, include frames only on devices of that type. +Otherwise, include frames only on the selected device." + ;; If we start from the minibuffer window, don't fail to come back to it. + (if (window-minibuffer-p (selected-window)) + (setq minibuf t)) + ;; Note that, like next-window & previous-window, this behaves a little + ;; strangely if the selected window is on an invisible frame: it hits + ;; some of the windows on that frame, and all windows on visible frames. + (let* ((walk-windows-start (selected-window)) + (walk-windows-current walk-windows-start)) + (while (progn + (setq walk-windows-current + (next-window walk-windows-current minibuf all-frames + device)) + (funcall proc walk-windows-current) + (not (eq walk-windows-current walk-windows-start)))))) +;; The old XEmacs definition of the above clause. It's more correct in +;; that it will never hit a window that's already been hit even if you +;; do something odd like `delete-other-windows', but has the problem +;; that it conses. (This may be called repeatedly, from lazy-lock +;; for example.) +; (let* ((walk-windows-history nil) +; (walk-windows-current (selected-window))) +; (while (progn +; (setq walk-windows-current +; (next-window walk-windows-current minibuf all-frames +; device)) +; (not (memq walk-windows-current walk-windows-history))) +; (setq walk-windows-history (cons walk-windows-current +; walk-windows-history)) +; (funcall proc walk-windows-current)))) + +(defun minibuffer-window-active-p (window) + "Return t if WINDOW (a minibuffer window) is now active." + (eq window (active-minibuffer-window))) + +(defmacro save-selected-window (&rest body) + "Execute BODY, then select the window that was selected before BODY." + (list 'let + '((save-selected-window-window (selected-window))) + (list 'unwind-protect + (cons 'progn body) + (list 'and ; XEmacs + (list 'window-live-p 'save-selected-window-window) + (list 'select-window 'save-selected-window-window))))) + +(defun count-windows (&optional minibuf) + "Returns the number of visible windows. +Optional arg MINIBUF non-nil means count the minibuffer +even if it is inactive." + (let ((count 0)) + (walk-windows (function (lambda (w) + (setq count (+ count 1)))) + minibuf) + count)) + +(defun balance-windows () + "Makes all visible windows the same height (approximately)." + (interactive) + (let ((count -1) levels newsizes size) + ;FSFmacs + ;;; Don't count the lines that are above the uppermost windows. + ;;; (These are the menu bar lines, if any.) + ;(mbl (nth 1 (window-edges (frame-first-window (selected-frame)))))) + ;; Find all the different vpos's at which windows start, + ;; then count them. But ignore levels that differ by only 1. + (save-window-excursion + (let (tops (prev-top -2)) + (walk-windows (function (lambda (w) + (setq tops (cons (nth 1 (window-pixel-edges w)) + tops)))) + 'nomini) + (setq tops (sort tops '<)) + (while tops + (if (> (car tops) (1+ prev-top)) + (setq prev-top (car tops) + count (1+ count))) + (setq levels (cons (cons (car tops) count) levels)) + (setq tops (cdr tops))) + (setq count (1+ count)))) + ;; Subdivide the frame into that many vertical levels. + ;FSFmacs (setq size (/ (- (frame-height) mbl) count)) + (setq size (/ (window-pixel-height (frame-root-window)) count)) + (walk-windows (function + (lambda (w) + (select-window w) + (let ((newtop (cdr (assq (nth 1 (window-pixel-edges)) + levels))) + (newbot (or (cdr (assq + (+ (window-pixel-height) + (nth 1 (window-pixel-edges))) + levels)) + count))) + (setq newsizes + (cons (cons w (* size (- newbot newtop))) + newsizes))))) + 'nomini) + (walk-windows (function (lambda (w) + (select-window w) + (let ((newsize (cdr (assq w newsizes)))) + (enlarge-window + (/ (- newsize (window-pixel-height)) + (face-height 'default)))))) + 'nomini))) + +;;; I think this should be the default; I think people will prefer it--rms. +(defcustom split-window-keep-point t + "*If non-nil, split windows keeps the original point in both children. +This is often more convenient for editing. +If nil, adjust point in each of the two windows to minimize redisplay. +This is convenient on slow terminals, but point can move strangely." + :type 'boolean + :group 'windows) + +(defun split-window-vertically (&optional arg) + "Split current window into two windows, one above the other. +The uppermost window gets ARG lines and the other gets the rest. +Negative arg means select the size of the lowermost window instead. +With no argument, split equally or close to it. +Both windows display the same buffer now current. + +If the variable split-window-keep-point is non-nil, both new windows +will get the same value of point as the current window. This is often +more convenient for editing. + +Otherwise, we chose window starts so as to minimize the amount of +redisplay; this is convenient on slow terminals. The new selected +window is the one that the current value of point appears in. The +value of point can change if the text around point is hidden by the +new mode line. + +Programs should probably use split-window instead of this." + (interactive "P") + (let ((old-w (selected-window)) + (old-point (point)) + (size (and arg (prefix-numeric-value arg))) + (window-full-p nil) + new-w bottom moved) + (and size (< size 0) (setq size (+ (window-height) size))) + (setq new-w (split-window nil size)) + (or split-window-keep-point + (progn + (save-excursion + (set-buffer (window-buffer)) + (goto-char (window-start)) + (setq moved (vertical-motion (window-height))) + (set-window-start new-w (point)) + (if (> (point) (window-point new-w)) + (set-window-point new-w (point))) + (and (= moved (window-height)) + (progn + (setq window-full-p t) + (vertical-motion -1))) + (setq bottom (point))) + (and window-full-p + (<= bottom (point)) + (set-window-point old-w (1- bottom))) + (and window-full-p + (<= (window-start new-w) old-point) + (progn + (set-window-point new-w old-point) + (select-window new-w))))) + new-w)) + +(defun split-window-horizontally (&optional arg) + "Split current window into two windows side by side. +This window becomes the leftmost of the two, and gets ARG columns. +Negative arg means select the size of the rightmost window instead. +No arg means split equally." + (interactive "P") + (let ((size (and arg (prefix-numeric-value arg)))) + (and size (< size 0) + (setq size (+ (window-width) size))) + (split-window nil size t))) + +(defun enlarge-window-horizontally (arg) + "Make current window ARG columns wider." + (interactive "p") + (enlarge-window arg t)) + +(defun shrink-window-horizontally (arg) + "Make current window ARG columns narrower." + (interactive "p") + (shrink-window arg t)) + +(defun shrink-window-if-larger-than-buffer (&optional window) + "Shrink the WINDOW to be as small as possible to display its contents. +Do not shrink to less than `window-min-height' lines. +Do nothing if the buffer contains more lines than the present window height, +or if some of the window's contents are scrolled out of view, +or if the window is not the full width of the frame, +or if the window is the only window of its frame." + (interactive) + (or window (setq window (selected-window))) + (save-excursion + (set-buffer (window-buffer window)) + (let* ((w (selected-window)) ;save-window-excursion can't win + (buffer-file-name buffer-file-name) + (p (point)) + (n 0) + (ignore-final-newline + ;; If buffer ends with a newline, ignore it when counting height + ;; unless point is after it. + (and (not (eobp)) + (eq ?\n (char-after (1- (point-max)))))) + (buffer-read-only nil) + (modified (buffer-modified-p)) + (buffer (current-buffer)) + (mini (frame-property (window-frame window) 'minibuffer)) + (edges (window-pixel-edges (selected-window)))) + (if (and (< 1 (let ((frame (selected-frame))) + (select-frame (window-frame window)) + (unwind-protect + (count-windows) + (select-frame frame)))) + ;; check to make sure that we don't have horizontally + ;; split windows + (eq (frame-highest-window (window-frame window) 0) + (frame-highest-window (window-frame window) -1)) + (pos-visible-in-window-p (point-min) window) + (not (eq mini 'only)) + (or (not mini) (eq mini t) + (< (nth 3 edges) + (nth 1 (window-pixel-edges mini))) + (> (nth 1 edges) + ;FSFmacs (frame-property (window-frame window) + ; 'menu-bar-lines params) + 0))) + (unwind-protect + (let ((shrinkee (or window w))) + (set-buffer (window-buffer shrinkee)) + (goto-char (point-min)) + (while (pos-visible-in-window-p + (- (point-max) + (if ignore-final-newline 1 0)) + shrinkee) + ;; defeat file locking... don't try this at home, kids! + (setq buffer-file-name nil) + (insert ?\n) (setq n (1+ n))) + (if (> n 0) + (shrink-window (min (1- n) + (- (window-height shrinkee) + window-min-height)) + nil + shrinkee))) + (delete-region (point-min) (point)) + (set-buffer-modified-p modified) + (goto-char p) + ;; (select-window w) ; Emacs + ;; Make sure we unbind buffer-read-only + ;; with the proper current buffer. + (set-buffer buffer)))))) + +(defun kill-buffer-and-window () + "Kill the current buffer and delete the selected window." + (interactive) + (if (yes-or-no-p (format "Kill buffer `%s'? " (buffer-name))) + (let ((buffer (current-buffer))) + (delete-window (selected-window)) + (kill-buffer buffer)) + (error "Aborted"))) + +;;; New with XEmacs 20.3 +;;; Suggested by Noah Friedman, and tuned by Hrvoje Niksic. +(defun window-list (&optional minibuf all-frames device) + "Return a list of existing windows. +If the optional argument MINIBUF is non-nil, then include minibuffer +windows in the result. + +By default, only the windows in the selected frame are returned. +The optional argument ALL-FRAMES changes this behavior: +ALL-FRAMES = `visible' means include windows on all visible frames. +ALL-FRAMES = 0 means include windows on all visible and iconified frames. +ALL-FRAMES = t means include windows on all frames including invisible frames. +Anything else means restrict to the selected frame. +The optional fourth argument DEVICE further clarifies which frames to +search as specified by ALL-FRAMES. This value is only meaningful if +ALL-FRAMES is non-nil. +If nil or omitted, search only the selected device. +If a device, search frames only on that device. +If a device type, search frames only on devices of that type. +Any other non-nil value means search frames on all devices." + (let ((wins nil)) + (walk-windows (lambda (win) + (push win wins)) + minibuf all-frames device) + wins)) + + +;;; window.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/x-compose.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,846 @@ +;;; x-compose.el --- Compose-key processing in XEmacs + +;; Copyright (C) 1992, 1993, 1997 Free Software Foundation, Inc. + +;; Author: Jamie Zawinski <jwz@netscape.com> +;; Maintainer: XEmacs Development Team +;; Rewritten by Martin Buchholz far too many times. +;; +;; Changed: 11 Jun 1997 by Heiko Muenkel <muenkel@tnt.uni-hannover.de> +;; The degree sign couldn't be inserted with the old version. +;; Keywords: i18n + +;; 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: + +;; created by jwz, 14-jun-92. +;;; changed by Jan Vroonhof, July 1997: Use function-key-map instead +;;; of global map. +;;; Preliminary support for +;;; XFree86 deadkeys + +;; This file implements DEC-, OpenWindows-, and HP-compatible "Compose" +;; processing for XEmacs. + +;; If you are running a version of X which already does compose processing, +;; then you don't need this file. But the MIT R4 and R5 distributions don't +;; do compose processing, so you may want to fake it by using this code. + +;; The basic idea is that there are several ways to generate keysyms which +;; do not have keys devoted to them on your keyboard. + +;; The first method is by using "dead" keys. A dead key is a key which, +;; when typed, does not insert a character. Instead it modifies the +;; following character typed. So if you typed "dead-tilde" followed by "A", +;; then "A-tilde" would be inserted. Of course, this requires you to modify +;; your keyboard to include a "dead-tilde" key on it somewhere. + +;; The second method is by using a "Compose" key. With a Compose key, you +;; would type "Compose" then "tilde" then "A" to insert "A-tilde". + +;; There are a small number of dead keys: acute, grave, cedilla, diaeresis, +;; circumflex, tilde, and ring. There are a larger number of accented and +;; other characters accessible via the Compose key, so both are useful. + +;; To use this code, you will need to have a Compose key on your keyboard. +;; The default configuration of most X keyboards doesn't contain one. You +;; can, for example, turn the right "Meta" key into a "Compose" key with +;; this command: + +;; xmodmap -e "remove mod1 = Meta_R" -e "keysym Meta_R = Multi_key" + +;; Multi-key is the name that X (and emacs) know the "Compose" key by. +;; The "remove..." command is necessary because the "Compose" key must not +;; have any modifier bits associated with it. This exact command may not +;; work, depending on what system and keyboard you are using. If it +;; doesn't, you'll have to read the man page for xmodmap. You might want +;; to get the "xkeycaps" program from the host export.lcs.mit.edu in the +;; file contrib/xkeycaps.tar.Z, which is a graphical front end to xmodmap +;; that hides xmodmap's arcane syntax from you. + +;; If for some reason you don't want to have a dedicated compose key on your +;; keyboard, you can use some other key as the prefix. For example, to make +;; "Meta-Shift-C" act as a compose key (so that "M-C , c" would insert the +;; character "ccedilla") you could do + +;; (global-set-key "\M-C" compose-map) + +;; I believe the bindings encoded in this file are the same as those used +;; by OpenWindows versions 2 and 3, and DEC VT320 terminals. Please let me +;; know if you think otherwise. + +;; Much thanks to Justin Bur <justin@crim.ca> for helping me understand how +;; this stuff is supposed to work. + +;; You also might want to consider getting Justin's patch for the MIT Xlib +;; that implements compose processing in the library. This will enable +;; compose processing in applications other than emacs as well. You can +;; get it from export.lcs.mit.edu in contrib/compose.tar.Z. + +;; This code has one feature that a more "builtin" Compose mechanism could +;; not have: at any point you can type C-h to get a list of the possible +;; completions of what you have typed so far. + +;;; Code: + +(require 'x-iso8859-1) + +(defun make-compose-map (map-sym) + (let ((map (make-sparse-keymap))) + (set map-sym map) + (set-keymap-name map map-sym) + ;; Required to tell XEmacs the keymaps were actually autoloaded. + ;; #### Make this unnecessary! + (fset map-sym map))) + +(make-compose-map 'compose-map) +(make-compose-map 'compose-acute-map) +(make-compose-map 'compose-grave-map) +(make-compose-map 'compose-cedilla-map) +(make-compose-map 'compose-diaeresis-map) +(make-compose-map 'compose-circumflex-map) +(make-compose-map 'compose-tilde-map) +(make-compose-map 'compose-ring-map) + +(unintern 'make-compose-map) + +(define-key compose-map 'acute compose-acute-map) +(define-key compose-map 'grave compose-grave-map) +(define-key compose-map 'cedilla compose-cedilla-map) +(define-key compose-map 'diaeresis compose-diaeresis-map) +(define-key compose-map 'circumflex compose-circumflex-map) +(define-key compose-map 'tilde compose-tilde-map) +(define-key compose-map 'degree compose-ring-map) + +;;(eval-when-compile +;; (defsubst define-dead-key-map (key map) +;; (define-key function-key-map key map) +;; (define-key compose-map key map))) + +;;;###utoload (autoload 'compose-map "x-compose" nil t 'keymap) +;;;###utoload (autoload 'compose-acute-map "x-compose" nil t 'keymap) +;;;###utoload (autoload 'compose-grave-map "x-compose" nil t 'keymap) +;;;###utoload (autoload 'compose-cedilla-map "x-compose" nil t 'keymap) +;;;###utoload (autoload 'compose-diaeresis-map "x-compose" nil t 'keymap) +;;;###utoload (autoload 'compose-degree-map "x-compose" nil t 'keymap) +;;;###utoload (define-key function-key-map [acute] 'compose-acute-map) +;;;###utoload (define-key function-key-map [grave] 'compose-grave-map) +;;;###utoload (define-key function-key-map [cedilla] 'compose-cedilla-map) +;;;###utoload (define-key function-key-map [diaeresis] 'compose-diaeresis-map) +;;;###utoload (define-key function-key-map [degree] 'compose-degree-map) +;;;###utoload (define-key function-key-map [multi-key] 'compose-map) +;;;###utoload (define-key global-map [multi-key] 'compose-map) + +;;(define-key function-key-map [multi-key] compose-map) + + +;; The following is necessary, because one can't rebind [degree] +;; and use it to insert the degree sign! +;;(defun compose-insert-degree () +;; "Inserts a degree sign." +;; (interactive) +;; (insert ?\260)) + +;; The "Dead" keys: +;; +;;(define-dead-key-map [acute] compose-acute-map) +;;(define-dead-key-map [cedilla] compose-cedilla-map) +;;(define-dead-key-map [diaeresis] compose-diaeresis-map) +;;(define-dead-key-map [degree] compose-ring-map) + +(define-key compose-map [acute] compose-acute-map) +(define-key compose-map [?'] compose-acute-map) +(define-key compose-map [grave] compose-grave-map) +(define-key compose-map [?`] compose-grave-map) +(define-key compose-map [cedilla] compose-cedilla-map) +(define-key compose-map [?,] compose-cedilla-map) +(define-key compose-map [diaeresis] compose-diaeresis-map) +(define-key compose-map [?\"] compose-diaeresis-map) +(define-key compose-map [circumflex] compose-circumflex-map) +(define-key compose-map [?^] compose-circumflex-map) +(define-key compose-map [tilde] compose-tilde-map) +(define-key compose-map [~] compose-tilde-map) +(define-key compose-map [degree] compose-ring-map) +(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. + +(define-key compose-acute-map [space] "'") +(define-key compose-acute-map [?'] [acute]) +(define-key compose-acute-map [?A] [Aacute]) +(define-key compose-acute-map [E] [Eacute]) +(define-key compose-acute-map [I] [Iacute]) +(define-key compose-acute-map [O] [Oacute]) +(define-key compose-acute-map [U] [Uacute]) +(define-key compose-acute-map [Y] [Yacute]) +(define-key compose-acute-map [a] [aacute]) +(define-key compose-acute-map [e] [eacute]) +(define-key compose-acute-map [i] [iacute]) +(define-key compose-acute-map [o] [oacute]) +(define-key compose-acute-map [u] [uacute]) +(define-key compose-acute-map [y] [yacute]) + +(define-key compose-grave-map [space] "`") +(define-key compose-grave-map [?`] [grave]) +(define-key compose-grave-map [A] [Agrave]) +(define-key compose-grave-map [E] [Egrave]) +(define-key compose-grave-map [I] [Igrave]) +(define-key compose-grave-map [O] [Ograve]) +(define-key compose-grave-map [U] [Ugrave]) +(define-key compose-grave-map [a] [agrave]) +(define-key compose-grave-map [e] [egrave]) +(define-key compose-grave-map [i] [igrave]) +(define-key compose-grave-map [o] [ograve]) +(define-key compose-grave-map [u] [ugrave]) + +(define-key compose-cedilla-map [space] ",") +(define-key compose-cedilla-map [?,] [cedilla]) +(define-key compose-cedilla-map [C] [Ccedilla]) +(define-key compose-cedilla-map [c] [ccedilla]) + +(define-key compose-diaeresis-map [space] [diaeresis]) +(define-key compose-diaeresis-map [?\"] [diaeresis]) +(define-key compose-diaeresis-map [A] [Adiaeresis]) +(define-key compose-diaeresis-map [E] [Ediaeresis]) +(define-key compose-diaeresis-map [I] [Idiaeresis]) +(define-key compose-diaeresis-map [O] [Odiaeresis]) +(define-key compose-diaeresis-map [U] [Udiaeresis]) +(define-key compose-diaeresis-map [a] [adiaeresis]) +(define-key compose-diaeresis-map [e] [ediaeresis]) +(define-key compose-diaeresis-map [i] [idiaeresis]) +(define-key compose-diaeresis-map [o] [odiaeresis]) +(define-key compose-diaeresis-map [u] [udiaeresis]) +(define-key compose-diaeresis-map [y] [ydiaeresis]) + +(define-key compose-circumflex-map [space] "^") +(define-key compose-circumflex-map [?/] "|") +(define-key compose-circumflex-map [?!] [brokenbar]) +(define-key compose-circumflex-map [?-] [macron]) +(define-key compose-circumflex-map [?_] [macron]) +(define-key compose-circumflex-map [?0] [degree]) +(define-key compose-circumflex-map [?1] [onesuperior]) +(define-key compose-circumflex-map [?2] [twosuperior]) +(define-key compose-circumflex-map [?3] [threesuperior]) +(define-key compose-circumflex-map [?.] [periodcentered]) +(define-key compose-circumflex-map [A] [Acircumflex]) +(define-key compose-circumflex-map [E] [Ecircumflex]) +(define-key compose-circumflex-map [I] [Icircumflex]) +(define-key compose-circumflex-map [O] [Ocircumflex]) +(define-key compose-circumflex-map [U] [Ucircumflex]) +(define-key compose-circumflex-map [a] [acircumflex]) +(define-key compose-circumflex-map [e] [ecircumflex]) +(define-key compose-circumflex-map [i] [icircumflex]) +(define-key compose-circumflex-map [o] [ocircumflex]) +(define-key compose-circumflex-map [u] [ucircumflex]) + +(define-key compose-tilde-map [space] "~") +(define-key compose-tilde-map [A] [Atilde]) +(define-key compose-tilde-map [N] [Ntilde]) +(define-key compose-tilde-map [O] [Otilde]) +(define-key compose-tilde-map [a] [atilde]) +(define-key compose-tilde-map [n] [ntilde]) +(define-key compose-tilde-map [o] [otilde]) + +(define-key compose-ring-map [space] [degree]) +(define-key compose-ring-map [A] [Aring]) +(define-key compose-ring-map [a] [aring]) + + +;;; The rest of the compose-map. These are the composed characters +;;; that are not accessible via "dead" keys. + +(define-key compose-map " '" "'") +(define-key compose-map " ^" "^") +(define-key compose-map " `" "`") +(define-key compose-map " ~" "~") +(define-key compose-map " " [nobreakspace]) +(define-key compose-map " \"" [diaeresis]) +(define-key compose-map " :" [diaeresis]) +(define-key compose-map " *" [degree]) + +(define-key compose-map "!!" [exclamdown]) +(define-key compose-map "!^" [brokenbar]) +(define-key compose-map "!S" [section]) +(define-key compose-map "!s" [section]) +(define-key compose-map "!P" [paragraph]) +(define-key compose-map "!p" [paragraph]) + +(define-key compose-map "((" "[") +(define-key compose-map "(-" "{") + +(define-key compose-map "))" "]") +(define-key compose-map ")-" "}") + +(define-key compose-map "++" "#") +(define-key compose-map "+-" [plusminus]) + +(define-key compose-map "-(" "{") +(define-key compose-map "-)" "}") +(define-key compose-map "--" "-") +(define-key compose-map "-L" [sterling]) +(define-key compose-map "-l" [sterling]) +(define-key compose-map "-Y" [yen]) +(define-key compose-map "-y" [yen]) +(define-key compose-map "-," [notsign]) +(define-key compose-map "-|" [notsign]) +(define-key compose-map "-^" [macron]) +(define-key compose-map "-+" [plusminus]) +(define-key compose-map "-:" [division]) +(define-key compose-map "-D" [ETH]) +(define-key compose-map "-d" [eth]) +(define-key compose-map "-a" [ordfeminine]) + +(define-key compose-map ".^" [periodcentered]) + +(define-key compose-map "//" "\\") +(define-key compose-map "/<" "\\") +(define-key compose-map "/^" "|") +(define-key compose-map "/C" [cent]) +(define-key compose-map "/c" [cent]) +(define-key compose-map "/U" [mu]) +(define-key compose-map "/u" [mu]) +(define-key compose-map "/O" [Ooblique]) +(define-key compose-map "/o" [oslash]) + +(define-key compose-map "0X" [currency]) +(define-key compose-map "0x" [currency]) +(define-key compose-map "0S" [section]) +(define-key compose-map "0s" [section]) +(define-key compose-map "0C" [copyright]) +(define-key compose-map "0c" [copyright]) +(define-key compose-map "0R" [registered]) +(define-key compose-map "0r" [registered]) +(define-key compose-map "0^" [degree]) + +(define-key compose-map "1^" [onesuperior]) +(define-key compose-map "14" [onequarter]) +(define-key compose-map "12" [onehalf]) + +(define-key compose-map "2^" [twosuperior]) + +(define-key compose-map "3^" [threesuperior]) +(define-key compose-map "34" [threequarters]) + +(define-key compose-map ":-" [division]) + +(define-key compose-map "</" "\\") +(define-key compose-map "<<" [guillemotleft]) + +(define-key compose-map "=L" [sterling]) +(define-key compose-map "=l" [sterling]) +(define-key compose-map "=Y" [yen]) +(define-key compose-map "=y" [yen]) + +(define-key compose-map ">>" [guillemotright]) + +(define-key compose-map "??" [questiondown]) + +(define-key compose-map "AA" "@") +(define-key compose-map "Aa" "@") +(define-key compose-map "A_" [ordfeminine]) +(define-key compose-map "A`" [Agrave]) +(define-key compose-map "A'" [Aacute]) +(define-key compose-map "A^" [Acircumflex]) +(define-key compose-map "A~" [Atilde]) +(define-key compose-map "A\"" [Adiaeresis]) +(define-key compose-map "A*" [Aring]) +(define-key compose-map "AE" [AE]) + +(define-key compose-map "C/" [cent]) +(define-key compose-map "C|" [cent]) +(define-key compose-map "C0" [copyright]) +(define-key compose-map "CO" [copyright]) +(define-key compose-map "Co" [copyright]) +(define-key compose-map "C," [Ccedilla]) + +(define-key compose-map "D-" [ETH]) + +(define-key compose-map "E`" [Egrave]) +(define-key compose-map "E'" [Eacute]) +(define-key compose-map "E^" [Ecircumflex]) +(define-key compose-map "E\"" [Ediaeresis]) + +(define-key compose-map "I`" [Igrave]) +(define-key compose-map "I'" [Iacute]) +(define-key compose-map "I^" [Icircumflex]) +(define-key compose-map "I\"" [Idiaeresis]) + +(define-key compose-map "L-" [sterling]) +(define-key compose-map "L=" [sterling]) + +(define-key compose-map "N~" [Ntilde]) + +(define-key compose-map "OX" [currency]) +(define-key compose-map "Ox" [currency]) +(define-key compose-map "OS" [section]) +(define-key compose-map "Os" [section]) +(define-key compose-map "OC" [copyright]) +(define-key compose-map "Oc" [copyright]) +(define-key compose-map "OR" [registered]) +(define-key compose-map "Or" [registered]) +(define-key compose-map "O_" [masculine]) +(define-key compose-map "O`" [Ograve]) +(define-key compose-map "O'" [Oacute]) +(define-key compose-map "O^" [Ocircumflex]) +(define-key compose-map "O~" [Otilde]) +(define-key compose-map "O\"" [Odiaeresis]) +(define-key compose-map "O/" [Ooblique]) + +(define-key compose-map "P!" [paragraph]) + +(define-key compose-map "R0" [registered]) +(define-key compose-map "RO" [registered]) +(define-key compose-map "Ro" [registered]) + +(define-key compose-map "S!" [section]) +(define-key compose-map "S0" [section]) +(define-key compose-map "SO" [section]) +(define-key compose-map "So" [section]) +(define-key compose-map "SS" [ssharp]) + +(define-key compose-map "TH" [THORN]) + +(define-key compose-map "U`" [Ugrave]) +(define-key compose-map "U'" [Uacute]) +(define-key compose-map "U^" [Ucircumflex]) +(define-key compose-map "U\"" [Udiaeresis]) + +(define-key compose-map "X0" [currency]) +(define-key compose-map "XO" [currency]) +(define-key compose-map "Xo" [currency]) + +(define-key compose-map "Y-" [yen]) +(define-key compose-map "Y=" [yen]) +(define-key compose-map "Y'" [Yacute]) + +(define-key compose-map "_A" [ordfeminine]) +(define-key compose-map "_a" [ordfeminine]) +(define-key compose-map "_^" [macron]) +(define-key compose-map "_O" [masculine]) +(define-key compose-map "_o" [masculine]) + +(define-key compose-map "aA" "@") +(define-key compose-map "aa" "@") +(define-key compose-map "a_" [ordfeminine]) +(define-key compose-map "a-" [ordfeminine]) +(define-key compose-map "a`" [agrave]) +(define-key compose-map "a'" [aacute]) +(define-key compose-map "a^" [acircumflex]) +(define-key compose-map "a~" [atilde]) +(define-key compose-map "a\"" [adiaeresis]) +(define-key compose-map "a*" [aring]) +(define-key compose-map "ae" [ae]) + +(define-key compose-map "c/" [cent]) +(define-key compose-map "c|" [cent]) +(define-key compose-map "c0" [copyright]) +(define-key compose-map "cO" [copyright]) +(define-key compose-map "co" [copyright]) +(define-key compose-map "c," [ccedilla]) + +(define-key compose-map "d-" [eth]) + +(define-key compose-map "e`" [egrave]) +(define-key compose-map "e'" [eacute]) +(define-key compose-map "e^" [ecircumflex]) +(define-key compose-map "e\"" [ediaeresis]) + +(define-key compose-map "i`" [igrave]) +(define-key compose-map "i'" [iacute]) +(define-key compose-map "i^" [icircumflex]) +(define-key compose-map "i\"" [idiaeresis]) +(define-key compose-map "i:" [idiaeresis]) + +(define-key compose-map "l-" [sterling]) +(define-key compose-map "l=" [sterling]) + +(define-key compose-map "n~" [ntilde]) + +(define-key compose-map "oX" [currency]) +(define-key compose-map "ox" [currency]) +(define-key compose-map "oC" [copyright]) +(define-key compose-map "oc" [copyright]) +(define-key compose-map "oR" [registered]) +(define-key compose-map "or" [registered]) +(define-key compose-map "oS" [section]) +(define-key compose-map "os" [section]) +(define-key compose-map "o_" [masculine]) +(define-key compose-map "o`" [ograve]) +(define-key compose-map "o'" [oacute]) +(define-key compose-map "o^" [ocircumflex]) +(define-key compose-map "o~" [otilde]) +(define-key compose-map "o\"" [odiaeresis]) +(define-key compose-map "o/" [oslash]) + +(define-key compose-map "p!" [paragraph]) + +(define-key compose-map "r0" [registered]) +(define-key compose-map "rO" [registered]) +(define-key compose-map "ro" [registered]) + +(define-key compose-map "s!" [section]) +(define-key compose-map "s0" [section]) +(define-key compose-map "sO" [section]) +(define-key compose-map "so" [section]) +(define-key compose-map "ss" [ssharp]) + +(define-key compose-map "th" [thorn]) + +(define-key compose-map "u`" [ugrave]) +(define-key compose-map "u'" [uacute]) +(define-key compose-map "u^" [ucircumflex]) +(define-key compose-map "u\"" [udiaeresis]) +(define-key compose-map "u/" [mu]) + +(define-key compose-map "x0" [currency]) +(define-key compose-map "xO" [currency]) +(define-key compose-map "xo" [currency]) +(define-key compose-map "xx" [multiply]) + +(define-key compose-map "y-" [yen]) +(define-key compose-map "y=" [yen]) +(define-key compose-map "y'" [yacute]) +(define-key compose-map "y\"" [ydiaeresis]) + +(define-key compose-map "|C" [cent]) +(define-key compose-map "|c" [cent]) +(define-key compose-map "||" [brokenbar]) + + +;; Suppose we type these three physical keys: [Multi_key " a] +;; Xlib can deliver these keys as the following sequences of keysyms: +;; +;; - [Multi_key " a] (no surprise here) +;; - [adiaeresis] (OK, Xlib is doing compose processing for us) +;; - [Multi_key " adiaeresis] (Huh?) +;; +;; It is the last possibility that is arguably a bug. Xlib can't +;; decide whether it's really doing compose processing or not (or +;; actually, different parts of Xlib disagree). +;; +;; So we'll just convert [Multi_key " adiaeresis] to [adiaeresis] +(defun xlib-input-method-bug-workaround (keymap) + (map-keymap + (lambda (key value) + (cond + ((keymapp value) + (xlib-input-method-bug-workaround value)) + ((and (sequencep value) + (eq 1 (length value)) + (null (lookup-key keymap value))) + (define-key keymap value value)))) + keymap)) +(xlib-input-method-bug-workaround compose-map) +(unintern 'xlib-input-method-bug-workaround) + +;; While we're at it, a similar mechanism will make colon equivalent +;; to doublequote for diaeresis processing. Some Xlibs do this. +(defun alias-colon-to-doublequote (keymap) + (map-keymap + (lambda (key value) + (when (keymapp value) + (alias-colon-to-doublequote value)) + (when (eq key '\") + (define-key keymap ":" value))) + keymap)) +(alias-colon-to-doublequote compose-map) +(unintern 'alias-colon-to-doublequote) + +;;; Electric dead keys: making a' mean a-acute. + + +(defun electric-diacritic (&optional count) + "Modify the previous character with an accent. +For example, if `:' is bound to this command, then typing `a:' +will first insert `a' and then turn it into `\344' (adiaeresis). +The keys to which this command may be bound (and the accents +which it understands) are: + + ' (acute) \301\311\315\323\332\335 \341\351\355\363\372\375 + ` (grave) \300\310\314\322\331 \340\350\354\362\371 + : (diaeresis) \304\313\317\326\334 \344\353\357\366\374\377 + ^ (circumflex) \302\312\316\324\333 \342\352\356\364\373 + , (cedilla) \307\347 + . (ring) \305\345" + (interactive "p") + (or count (setq count 1)) + + (if (not (eq last-command 'self-insert-command)) + ;; Only do the magic if the two chars were typed in succession. + (self-insert-command count) + + ;; This is so that ``a : C-x u'' will transform `adiaeresis' back into `a:' + (self-insert-command count) + (undo-boundary) + (delete-char (- count)) + + (let* ((c last-command-char) + (map (cond ((eq c ?') compose-acute-map) + ((eq c ?`) compose-grave-map) + ((eq c ?,) compose-cedilla-map) + ((eq c ?:) compose-diaeresis-map) + ((eq c ?^) compose-circumflex-map) + ((eq c ?~) compose-tilde-map) + ((eq c ?.) compose-ring-map) + (t (error "unknown diacritic: %s (%c)" c c)))) + (base-char (preceding-char)) + (mod-char (and (>= (downcase base-char) ?a) ; only do alphabetics? + (<= (downcase base-char) ?z) + (lookup-key map (make-string 1 base-char))))) + (if (and (vectorp mod-char) (= (length mod-char) 1)) + (setq mod-char (aref mod-char 0))) + (if (and mod-char (symbolp mod-char)) + (setq mod-char (or (get mod-char character-set-property) mod-char))) + (if (and mod-char (> count 0)) + (delete-char -1) + (setq mod-char c)) + (while (> count 0) + (insert mod-char) + (setq count (1- count)))))) + +;; should "::" mean "¨" and ": " mean ":"? +;; should we also do +;; (?~ +;; (?A "\303") +;; (?C "\307") +;; (?D "\320") +;; (?N "\321") +;; (?O "\325") +;; (?a "\343") +;; (?c "\347") +;; (?d "\360") +;; (?n "\361") +;; (?o "\365") +;; (?> "\273") +;; (?< "\253") +;; (? "~")) ; no special code +;; (?\/ +;; (?A "\305") ;; A-with-ring (Norwegian and Danish) +;; (?E "\306") ;; AE-ligature (Norwegian and Danish) +;; (?O "\330") +;; (?a "\345") ;; a-with-ring (Norwegian and Danish) +;; (?e "\346") ;; ae-ligature (Norwegian and Danish) +;; (?o "\370") +;; (? "/")) ; no special code + + +;;; Providing help in the middle of a compose sequence. (Way cool.) + +(eval-when-compile + (defsubst next-composable-event () + (let (event) + (while (progn + (setq event (next-command-event)) + (not (or (key-press-event-p event) + (button-press-event-p event)))) + (dispatch-event event)) + event))) + +(defun compose-help (ignore-prompt) + (let* ((keys (apply 'vector (nbutlast (append (this-command-keys) nil)))) + (map (or (lookup-key function-key-map keys) + (error "can't find map? %s %s" keys (this-command-keys)))) + binding) + (save-excursion + (with-output-to-temp-buffer "*Help*" + (set-buffer "*Help*") + (erase-buffer) + (message "Working...") + (setq ctl-arrow 'compose) ; non-t-non-nil + (insert "You are typing a compose sequence. So far you have typed: ") + (insert (key-description keys)) + (insert "\nCompletions from here are:\n\n") + (map-keymap 'compose-help-mapper map t) + (message "? "))) + (while (keymapp map) + (setq binding (lookup-key map (vector (next-composable-event)))) + (if (null binding) + (message "No such key in keymap. Try again.") + (setq map binding))) + binding)) + +(put 'compose-help 'isearch-command t) ; so that it doesn't terminate isearch + +(defun compose-help-mapper (key binding) + (if (and (symbolp key) + (get key character-set-property)) + (setq key (get key character-set-property))) + (if (eq binding 'compose-help) ; suppress that... + nil + (if (keymapp binding) + (let ((p (point))) + (map-keymap 'compose-help-mapper binding t) + (goto-char p) + (while (not (eobp)) + (if (characterp key) + (insert (make-string 1 key)) + (insert (single-key-description key))) + (insert " ") + (forward-line 1))) + (if (characterp key) + (insert (make-string 1 key)) + (insert (single-key-description key))) + (indent-to 16) + (let ((code (and (vectorp binding) + (= 1 (length binding)) + (get (aref binding 0) character-set-property)))) + (if code + (insert (make-string 1 code)) + (if (stringp binding) + (insert binding) + (insert (prin1-to-string binding))))) + (when (and (vectorp binding) (= 1 (length binding))) + (indent-to 32) + (insert (symbol-name (aref binding 0))))) + (insert "\n"))) + +;; define it at top-level in the compose map... +;;(define-key compose-map [(control h)] 'compose-help) +;;(define-key compose-map [help] 'compose-help) +;; and then define it in each sub-map of the compose map. +(map-keymap + (lambda (key binding) + (when (keymapp binding) +;; (define-key binding [(control h)] 'compose-help) +;; (define-key binding [help] 'compose-help) + )) + compose-map nil) + +;; Make redisplay display the accented letters +(if (memq (default-value 'ctl-arrow) '(t nil)) + (setq-default ctl-arrow 'iso-8859/1)) + + +(provide 'x-compose) + +;;; x-compose.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/x-faces.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,659 @@ +;;; x-faces.el --- X-specific face frobnication, aka black magic. + +;; Copyright (C) 1992-4, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1995, 1996 Ben Wing. + +;; Author: Jamie Zawinski <jwz@netscape.com> +;; Maintainer: XEmacs Development Team +;; Keywords: extensions, internal, dumped + +;; 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 synched. + +;;; Commentary: + +;; This file is dumped with XEmacs (when X support is compiled in). + +;; Modified by: Chuck Thompson +;; Modified by: Ben Wing +;; Modified by: Martin Buchholz + +;; This file does the magic to parse X font names, and make sure that the +;; default and modeline attributes of new frames are specified enough. + +;; The resource-manager syntax for faces is + +;; Emacs.bold.attributeFont: font-name +;; Emacs.bold.attributeForeground: fg +;; Emacs.bold.attributeBackground: bg +;; Emacs.bold.attributeBackgroundPixmap: file +;; Emacs.bold.attributeUnderline: true/false +;; Emacs.bold.attributeStrikethru: true/false + +;; You can specify the properties of a face on a per-frame basis. For +;; example, to have the "isearch" face use a red foreground on frames +;; named "emacs" (the default) but use a blue foreground on frames that +;; you create named "debugger", you could do + +;; Emacs*emacs.isearch.attributeForeground: red +;; Emacs*debugger.isearch.attributeForeground: blue + +;; Generally things that make faces won't set any of the face attributes if +;; you have already given them values via the resource database. You can +;; also change this stuff from your .emacs file, by using the functions +;; set-face-foreground, set-face-font, etc. See the code in this file, and +;; in faces.el. + +;;; Code: + +(defconst x-font-regexp nil) +(defconst x-font-regexp-head nil) +(defconst x-font-regexp-head-2 nil) +(defconst x-font-regexp-weight nil) +(defconst x-font-regexp-slant nil) +(defconst x-font-regexp-pixel nil) +(defconst x-font-regexp-point nil) +(defconst x-font-regexp-foundry-and-family nil) +(defconst x-font-regexp-registry-and-encoding nil) +(defconst x-font-regexp-spacing nil) + +;;; Regexps matching font names in "Host Portable Character Representation." +;;; +(let ((- "[-?]") + (foundry "[^-]*") + (family "[^-]*") + (weight "\\(bold\\|demibold\\|medium\\|black\\)") ; 1 +; (weight\? "\\(\\*\\|bold\\|demibold\\|medium\\|\\)") ; 1 + (weight\? "\\([^-]*\\)") ; 1 + (slant "\\([ior]\\)") ; 2 +; (slant\? "\\([ior?*]?\\)") ; 2 + (slant\? "\\([^-]?\\)") ; 2 +; (swidth "\\(\\*\\|normal\\|semicondensed\\|\\)") ; 3 + (swidth "\\([^-]*\\)") ; 3 +; (adstyle "\\(\\*\\|sans\\|\\)") ; 4 + (adstyle "\\([^-]*\\)") ; 4 + (pixelsize "\\(\\*\\|[0-9]+\\)") ; 5 + (pointsize "\\(\\*\\|0\\|[0-9][0-9]+\\)") ; 6 +; (resx "\\(\\*\\|[0-9][0-9]+\\)") ; 7 +; (resy "\\(\\*\\|[0-9][0-9]+\\)") ; 8 + (resx "\\([*0]\\|[0-9][0-9]+\\)") ; 7 + (resy "\\([*0]\\|[0-9][0-9]+\\)") ; 8 + (spacing "[cmp?*]") + (avgwidth "\\(\\*\\|[0-9]+\\)") ; 9 + (registry "[^-]*") ; some fonts have omitted registries +; (encoding ".+") ; note that encoding may contain "-"... + (encoding "[^-]+") ; false! + ) + (setq x-font-regexp + (purecopy + (concat "\\`\\*?[-?*]" + foundry - family - weight\? - slant\? - swidth - adstyle - + pixelsize - pointsize - resx - resy - spacing - avgwidth - + registry - encoding "\\'" + ))) + (setq x-font-regexp-head + (purecopy + (concat "\\`[-?*]" foundry - family - weight\? - slant\? + "\\([-*?]\\|\\'\\)"))) + (setq x-font-regexp-head-2 + (purecopy + (concat "\\`[-?*]" foundry - family - weight\? - slant\? + - swidth - adstyle - pixelsize - pointsize + "\\([-*?]\\|\\'\\)"))) + (setq x-font-regexp-slant (purecopy (concat - slant -))) + (setq x-font-regexp-weight (purecopy (concat - weight -))) + ;; if we can't match any of the more specific regexps (unfortunate) then + ;; look for digits; assume 2+ digits is 10ths of points, and 1-2 digits + ;; is pixels. Bogus as hell. + (setq x-font-regexp-pixel (purecopy "[-?*]\\([0-9][0-9]?\\)[-?*]")) + (setq x-font-regexp-point (purecopy "[-?*]\\([0-9][0-9]+\\)[-?*]")) + ;; the following two are used by x-font-menu.el. + (setq x-font-regexp-foundry-and-family + (purecopy (concat "\\`[-?*]" foundry - "\\(" family "\\)" -))) + (setq x-font-regexp-registry-and-encoding + (purecopy (concat - "\\(" registry "\\)" - "\\(" encoding "\\)\\'"))) + (setq x-font-regexp-spacing + (purecopy (concat - "\\(" spacing "\\)" - avgwidth + - registry - encoding "\\'"))) + ) + +;; A "loser font" is something like "8x13" -> "8x13bold". +;; These are supported only through extreme generosity. +(defconst x-loser-font-regexp (purecopy "\\`[0-9]+x[0-9]+\\'")) + +(defun x-frob-font-weight (font which) + (if (font-instance-p font) (setq font (font-instance-name font))) + (cond ((null font) nil) + ((or (string-match x-font-regexp font) + (string-match x-font-regexp-head font) + (string-match x-font-regexp-weight font)) + (concat (substring font 0 (match-beginning 1)) which + (substring font (match-end 1)))) + ((string-match x-loser-font-regexp font) + (concat font which)) + (t nil))) + +(defun x-frob-font-slant (font which) + (if (font-instance-p font) (setq font (font-instance-name font))) + (cond ((null font) nil) + ((or (string-match x-font-regexp font) + (string-match x-font-regexp-head font)) + (concat (substring font 0 (match-beginning 2)) which + (substring font (match-end 2)))) + ((string-match x-font-regexp-slant font) + (concat (substring font 0 (match-beginning 1)) which + (substring font (match-end 1)))) + ((string-match x-loser-font-regexp font) + (concat font which)) + (t nil))) + +(defun try-font-name (name &optional device) + ;; yes, name really should be here twice. + (and name (make-font-instance name device t) name)) + +(defun x-make-font-bold (font &optional device) + "Given an X font specification, this attempts to make a `bold' font. +If it fails, it returns nil." + ;; Certain Type1 fonts know "bold" as "black"... + (or (try-font-name (x-frob-font-weight font "bold") device) + (try-font-name (x-frob-font-weight font "black") device) + (try-font-name (x-frob-font-weight font "demibold") device))) + +(defun x-make-font-unbold (font &optional device) + "Given an X font specification, this attempts to make a non-bold font. +If it fails, it returns nil." + (try-font-name (x-frob-font-weight font "medium") device)) + +(defcustom *try-oblique-before-italic-fonts* nil + "*If nil, italic fonts are searched before oblique fonts. +If non-nil, oblique fonts are tried before italic fonts. This is mostly +applicable to adobe-courier fonts" + :type 'boolean + :tag "Try Oblique Before Italic Fonts" + :group 'x) + +(defun x-make-font-italic (font &optional device) + "Given an X font specification, this attempts to make an `italic' font. +If it fails, it returns nil." + (if *try-oblique-before-italic-fonts* + (or (try-font-name (x-frob-font-slant font "o") device) + (try-font-name (x-frob-font-slant font "i") device)) + (or (try-font-name (x-frob-font-slant font "i") device) + (try-font-name (x-frob-font-slant font "o") device)))) + +(defun x-make-font-unitalic (font &optional device) + "Given an X font specification, this attempts to make a non-italic font. +If it fails, it returns nil." + (try-font-name (x-frob-font-slant font "r") device)) + +(defun x-make-font-bold-italic (font &optional device) + "Given an X font specification, this attempts to make a `bold-italic' font. +If it fails, it returns nil." + ;; This is haired up to avoid loading the "intermediate" fonts. + (or (try-font-name + (x-frob-font-slant (x-frob-font-weight font "bold") "i") device) + (try-font-name + (x-frob-font-slant (x-frob-font-weight font "bold") "o") device) + (try-font-name + (x-frob-font-slant (x-frob-font-weight font "black") "i") device) + (try-font-name + (x-frob-font-slant (x-frob-font-weight font "black") "o") device) + (try-font-name + (x-frob-font-slant (x-frob-font-weight font "demibold") "i") device) + (try-font-name + (x-frob-font-slant (x-frob-font-weight font "demibold") "o") device))) + +(defun x-font-size (font) + "Return the nominal size of the given font. +This is done by parsing its name, so it's likely to lose. +X fonts can be specified (by the user) in either pixels or 10ths of points, + and this returns the first one it finds, so you have to decide which units + the returned value is measured in yourself..." + (if (font-instance-p font) (setq font (font-instance-name font))) + (cond ((or (string-match x-font-regexp font) + (string-match x-font-regexp-head-2 font)) + (string-to-int (substring font (match-beginning 6) (match-end 6)))) + ((or (string-match x-font-regexp-pixel font) + (string-match x-font-regexp-point font)) + (string-to-int (substring font (match-beginning 1) (match-end 1)))) + (t nil))) + +;; Given a font name, this function returns a list describing all fonts +;; of all sizes that otherwise match the given font spec. Each element +;; in the list is a list of three items: the pixel size of the font, +;; the point size (in 1/10ths of a point) of the font, and the fully- +;; qualified font name. The first two values may be zero; this +;; refers to a scalable font. + +(defun x-available-font-sizes (font device) + (if (font-instance-p font) (setq font (font-instance-name font))) + (cond ((string-match x-font-regexp font) + ;; turn pixelsize, pointsize, and avgwidth into wildcards + (setq font + (concat (substring font 0 (match-beginning 5)) "*" + (substring font (match-end 5) (match-beginning 6)) "*" + (substring font (match-end 6) (match-beginning 9)) "*" + (substring font (match-end 9) (match-end 0))))) + ((string-match x-font-regexp-head-2 font) + ;; turn pixelsize and pointsize into wildcards + (setq font + (concat (substring font 0 (match-beginning 5)) "*" + (substring font (match-end 5) (match-beginning 6)) "*" + (substring font (match-end 6) (match-end 0))))) + ((string-match "[-?*]\\([0-9]+\\)[-?*]" font) + ;; Turn the first integer we match into a wildcard. + ;; This is pretty dubious... + (setq font + (concat (substring font 0 (match-beginning 1)) "*" + (substring font (match-end 1) (match-end 0)))))) + (sort + (delq nil + (mapcar (function + (lambda (name) + (and (string-match x-font-regexp name) + (list + (string-to-int (substring name (match-beginning 5) + (match-end 5))) + (string-to-int (substring name (match-beginning 6) + (match-end 6))) + name)))) + (list-fonts font device))) + (function (lambda (x y) (if (= (nth 1 x) (nth 1 y)) + (< (nth 0 x) (nth 0 y)) + (< (nth 1 x) (nth 1 y))))))) + +;; Given a font name, this attempts to construct a valid font name for +;; DEVICE whose size is the next smaller (if UP-P is nil) or larger +;; (if UP-P is t) size and whose other characteristics are the same +;; as the given font. + +(defun x-frob-font-size (font up-p device) + (if (stringp font) (setq font (make-font-instance font device))) + (if (font-instance-p font) (setq font (font-instance-truename font))) + (let ((available (and font + (x-available-font-sizes font device)))) + (cond + ((null available) nil) + ((or (= 0 (nth 0 (car available))) + (= 0 (nth 1 (car available)))) + ;; R5 scalable fonts: change size by 1 point. + ;; If they're scalable the first font will have pixel or point = 0. + ;; Sometimes one is 0 and the other isn't (if it's a bitmap font that + ;; can be scaled), sometimes both are (if it's a true outline font). + (let ((name (nth 2 (car available))) + old-size) + (or (string-match x-font-regexp font) (error "can't parse %S" font)) + (setq old-size (string-to-int + (substring font (match-beginning 6) (match-end 6)))) + (or (> old-size 0) (error "font truename has 0 pointsize?")) + (or (string-match x-font-regexp name) (error "can't parse %S" name)) + ;; turn pixelsize into a wildcard, and make pointsize be +/- 10, + ;; which is +/- 1 point. All other fields stay the same as they + ;; were in the "template" font returned by x-available-font-sizes. + ;; + ;; #### But this might return the same font: for example, if the + ;; truename of "-*-courier-medium-r-normal--*-230-75-75-m-0-*" + ;; is "...-240-..." (instead of 230) then this loses, because + ;; the 230 that was passed in as an arg got turned into 240 + ;; by the call to font-instance-truename; then we decrement that + ;; by 10 and return the result which is the same. I think the + ;; way to fix this is to make this be a loop that keeps trying + ;; progressively larger pointsize deltas until it finds one + ;; whose truename differs. Have to be careful to avoid infinite + ;; loops at the upper end... + ;; + (concat (substring name 0 (match-beginning 5)) "*" + (substring name (match-end 5) (match-beginning 6)) + (int-to-string (+ old-size (if up-p 10 -10))) + (substring name (match-end 6) (match-end 0))))) + (t + ;; non-scalable fonts: take the next available size. + (let ((rest available) + (last nil) + result) + (setq font (downcase font)) + (while rest + (cond ((and (not up-p) (equal font (downcase (nth 2 (car rest))))) + (setq result last + rest nil)) + ((and up-p (equal font (and last (downcase (nth 2 last))))) + (setq result (car rest) + rest nil))) + (setq last (car rest)) + (setq rest (cdr rest))) + (nth 2 result)))))) + +(defun x-find-smaller-font (font &optional device) + "Loads a new, slightly smaller version of the given font (or font name). +Returns the font if it succeeds, nil otherwise. +If scalable fonts are available, this returns a font which is 1 point smaller. +Otherwise, it returns the next smaller version of this font that is defined." + (x-frob-font-size font nil device)) + +(defun x-find-larger-font (font &optional device) + "Loads a new, slightly larger version of the given font (or font name). +Returns the font if it succeeds, nil otherwise. +If scalable fonts are available, this returns a font which is 1 point larger. +Otherwise, it returns the next larger version of this font that is defined." + (x-frob-font-size font t device)) + +(defalias 'x-make-face-bold 'make-face-bold) +(defalias 'x-make-face-italic 'make-face-italic) +(defalias 'x-make-face-bold-italic 'make-face-bold-italic) +(defalias 'x-make-face-unbold 'make-face-unbold) +(defalias 'x-make-face-unitalic 'make-face-unitalic) + +(make-obsolete 'x-make-face-bold 'make-face-bold) +(make-obsolete 'x-make-face-italic 'make-face-italic) +(make-obsolete 'x-make-face-bold-italic 'make-face-bold-italic) +(make-obsolete 'x-make-face-unbold 'make-face-unbold) +(make-obsolete 'x-make-face-unitalic 'make-face-unitalic) + + +;; Define some logical color names to be used when reading the pixmap files. +(if (featurep 'xpm) + (setq xpm-color-symbols + (list + (purecopy '("foreground" (face-foreground 'default))) + (purecopy '("background" (face-background 'default))) + (purecopy '("backgroundToolBarColor" + (x-get-resource "backgroundToolBarColor" + "BackgroundToolBarColor" 'string))) + ))) + +;;; internal routines + +;;; x-init-face-from-resources is responsible for initializing a +;;; newly-created face from the resource database. +;;; +;;; When a new frame is created, it is called from `x-init-frame-faces' +;;; called from `init-frame-faces' called from init_frame_faces() +;;; from Fmake_frame(). In this case it is called once for each existing +;;; face, with the newly-created frame as the argument. It then initializes +;;; the newly-created faces on that frame. +;;; +;;; It's also called from `init-device-faces' and +;;; `init-global-faces'. +;;; +;;; This had better not signal an error. The frame is in an intermediate +;;; state where signalling an error or entering the debugger would likely +;;; result in a crash. + +(defun x-init-face-from-resources (face &optional locale set-anyway) + + ;; + ;; These are things like "attributeForeground" instead of simply + ;; "foreground" because people tend to do things like "*foreground", + ;; which would cause all faces to be fully qualified, making faces + ;; inherit attributes in a non-useful way. So we've made them slightly + ;; less obvious to specify in order to make them work correctly in + ;; more random environments. + ;; + ;; I think these should be called "face.faceForeground" instead of + ;; "face.attributeForeground", but they're the way they are for + ;; hysterical reasons. (jwz) + + (let* ((append (if set-anyway nil 'append)) + (face-sym (face-name face)) + (name (symbol-name face-sym)) + (fn (x-get-resource-and-maybe-bogosity-check + (concat name ".attributeFont") + "Face.AttributeFont" + 'string locale)) + (fg (x-get-resource-and-maybe-bogosity-check + (concat name ".attributeForeground") + "Face.AttributeForeground" + 'string locale)) + (bg (x-get-resource-and-maybe-bogosity-check + (concat name ".attributeBackground") + "Face.AttributeBackground" + 'string locale)) + (bgp (x-get-resource-and-maybe-bogosity-check + (concat name ".attributeBackgroundPixmap") + "Face.AttributeBackgroundPixmap" + 'string locale)) + (ulp (x-get-resource-and-maybe-bogosity-check + (concat name ".attributeUnderline") + "Face.AttributeUnderline" + 'boolean locale)) + (stp (x-get-resource-and-maybe-bogosity-check + (concat name ".attributeStrikethru") + "Face.AttributeStrikethru" + 'boolean locale)) + ;; we still resource for these TTY-only resources so that + ;; you can specify resources for TTY frames/devices. This is + ;; useful when you start up your XEmacs on an X display and later + ;; open some TTY frames. + (hp (x-get-resource-and-maybe-bogosity-check + (concat name ".attributeHighlight") + "Face.AttributeHighlight" + 'boolean locale)) + (dp (x-get-resource-and-maybe-bogosity-check + (concat name ".attributeDim") + "Face.AttributeDim" + 'boolean locale)) + (bp (x-get-resource-and-maybe-bogosity-check + (concat name ".attributeBlinking") + "Face.AttributeBlinking" + 'boolean locale)) + (rp (x-get-resource-and-maybe-bogosity-check + (concat name ".attributeReverse") + "Face.AttributeReverse" + 'boolean locale)) + ) + + ;; + ;; If this is the default face, then any unspecified properties should + ;; be defaulted from the global properties. Can't do this for + ;; frames or devices because then, common resource specs like + ;; "*Foreground: black" will have unwanted effects. + ;; + (if (and (eq (face-name face) 'default) + (or (null locale) (eq locale 'global))) + (progn + (or fn (setq fn (x-get-resource + "font" "Font" 'string locale))) + (or fg (setq fg (x-get-resource + "foreground" "Foreground" 'string locale))) + (or bg (setq bg (x-get-resource + "background" "Background" 'string locale))))) + ;; + ;; "*cursorColor: foo" is equivalent to setting the background of the + ;; text-cursor face. + ;; + (if (and (eq (face-name face) 'text-cursor) + (or (null locale) (eq locale 'global))) + (setq bg (or (x-get-resource + "cursorColor" "CursorColor" 'string locale) bg))) + ;; #### should issue warnings? I think this should be + ;; done when the instancing actually happens, but I'm not + ;; sure how it should actually be dealt with. + (if fn + (set-face-font face fn locale nil append)) + ;; Kludge-o-rooni. Set the foreground and background resources for + ;; X devices only -- otherwise things tend to get all messed up + ;; if you start up an X frame and then later create a TTY frame. + (if fg + (set-face-foreground face fg locale 'x append)) + (if bg + (set-face-background face bg locale 'x append)) + (if bgp + (set-face-background-pixmap face bgp locale nil append)) + (if ulp + (set-face-underline-p face ulp locale nil append)) + (if stp + (set-face-strikethru-p face stp locale nil append)) + (if hp + (set-face-highlight-p face hp locale nil append)) + (if dp + (set-face-dim-p face dp locale nil append)) + (if bp + (set-face-blinking-p face bp locale nil append)) + (if rp + (set-face-reverse-p face rp locale nil append)) + )) + +;; GNU Emacs compatibility. (move to obsolete.el?) +(defalias 'make-face-x-resource-internal 'x-init-face-from-resources) + +;;; x-init-global-faces is responsible for ensuring that the +;;; default face has some reasonable fallbacks if nothing else is +;;; specified. +;;; +(defun x-init-global-faces () + (or (face-font 'default 'global) + (set-face-font 'default + "-*-courier-medium-r-*-*-*-120-*-*-*-*-iso8859-*") + 'global) + (or (face-foreground 'default 'global) + (set-face-foreground 'default "black" 'global 'x)) + (or (face-background 'default 'global) + (set-face-background 'default "gray80" 'global 'x))) + +;;; x-init-device-faces is responsible for initializing default +;;; values for faces on a newly created device. +;;; +(defun x-init-device-faces (device) + ;; + ;; If the "default" face didn't have a font specified, try to pick one. + ;; + (or + (face-font-instance 'default device) + ;; + ;; No font specified in the resource database; try to cope. + ;; + ;; At first I wanted to do this by just putting a font-spec in the + ;; fallback resources passed to XtAppInitialize(), but that fails + ;; if there is an Emacs app-defaults file which doesn't specify a + ;; font: apparently the fallback resources are not consulted when + ;; there is an app-defaults file, which seems pretty bogus to me. + ;; + ;; We should also probably try "*xtDefaultFont", but I think that it + ;; might be legal to specify that as "xtDefaultFont:", that is, at + ;; top level, instead of "*xtDefaultFont:", that is, applicable to + ;; every application. `x-get-resource' can't handle that right now. + ;; Anyway, xtDefaultFont is probably variable-width. + ;; + ;; Some who have LucidaTypewriter think it's a better font than Courier, + ;; but it has the bug that there are no italic and bold italic versions. + ;; We could hair this code up to try and mix-and-match fonts to get a + ;; full complement, but really, why bother. It's just a default. + ;; + (let (new-x-font) + (setq new-x-font (or + ;; + ;; We default to looking for iso8859 fonts. Using a wildcard for the + ;; encoding would be bad, because that can cause English speakers to get + ;; Kanji fonts by default. It is safe to assume that people using a + ;; language other than English have both set $LANG, and have specified + ;; their `font' and `fontList' resources. In any event, it's better to + ;; err on the side of the English speaker in this case because they are + ;; much less likely to have encountered this problem, and are thus less + ;; likely to know what to do about it. + + ;; Try for Courier. Almost everyone has that. (Does anyone not?) + (make-font-instance + "-*-courier-medium-r-*-*-*-120-*-*-*-*-iso8859-*" device t) + (make-font-instance + "-*-courier-*-r-*-*-*-120-*-*-*-*-iso8859-*" device t) + ;; Next try for any "medium" charcell or monospaced iso8859 font. + (make-font-instance "-*-*-medium-r-*-*-*-120-*-*-m-*-iso8859-*" device t) + (make-font-instance "-*-*-medium-r-*-*-*-120-*-*-c-*-iso8859-*" device t) + ;; Next try for any charcell or monospaced iso8859 font. + (make-font-instance "-*-*-*-r-*-*-*-120-*-*-m-*-iso8859-*" device t) + (make-font-instance "-*-*-*-r-*-*-*-120-*-*-c-*-iso8859-*" device t) + ;; Ok, let's at least try to stay in 8859... + (make-font-instance "-*-*-*-r-*-*-*-120-*-*-*-*-iso8859-*" device t) + ;; Boy, we sure are losing now. Try the above, but in any encoding. + (make-font-instance "-*-*-medium-r-*-*-*-120-*-*-m-*-*-*" device t) + (make-font-instance "-*-*-medium-r-*-*-*-120-*-*-c-*-*-*" device t) + (make-font-instance "-*-*-*-r-*-*-*-120-*-*-m-*-*-*" device t) + (make-font-instance "-*-*-*-r-*-*-*-120-*-*-c-*-*-*" device t) + (make-font-instance "-*-*-*-r-*-*-*-120-*-*-*-*-*-*" device t) + ;; Hello? Please? + (make-font-instance "-*-*-*-*-*-*-*-120-*-*-*-*-*-*" device t) + (make-font-instance "*" device t) + ;; if we get to here we're screwed, and faces.c will fatal()... + )) + (if (not (face-font 'default 'global)) + (set-face-font 'default new-x-font) + (set-face-font 'default new-x-font device)))) + ;; + ;; If the "default" face didn't have both colors specified, then pick + ;; some, taking into account whether one of the colors was specified. + ;; + (let ((fg (face-foreground-instance 'default device)) + (bg (face-background-instance 'default device))) + (if (not (and fg bg)) + (if (or (and fg (equal (downcase (color-instance-name fg)) "white")) + (and bg (equal (downcase (color-instance-name bg)) "black"))) + (progn + (or fg (set-face-foreground 'default "white" device)) + (or bg (set-face-background 'default "black" device))) + (or fg (set-face-foreground 'default "white" device)) + (or bg (set-face-background 'default "black" device))))) + + ;; Don't look at reverseVideo now or initialize the modeline. This + ;; is done on a per-frame basis at the appropriate time. + + ;; + ;; Now let's try to pick some reasonable defaults for a few other faces. + ;; This kind of stuff should normally go on the create-frame-hook, but + ;; this way we won't be in danger of the user screwing things up by not + ;; adding hooks in a safe way. + ;; + (x-init-pointer-shape device) ; from x-mouse.el + ) + +;;; This is called from `init-frame-faces', which is called from +;;; init_frame_faces() which is called from Fmake_frame(), to perform +;;; any device-specific initialization. +;;; +(defun x-init-frame-faces (frame) + ;; + ;; The faces already got initialized (by init-frame-faces) from + ;; the resource database or global, non-frame faces. The default, + ;; bold, bold-italic, and italic faces (plus various other random faces) + ;; got set up then. But modeline didn't so that reverseVideo can be + ;; frame-specific. + ;; + + ;; + ;; If reverseVideo was specified, swap the foreground and background + ;; of the default and modeline faces. + ;; + (cond ((car (x-get-resource "reverseVideo" "ReverseVideo" 'boolean frame)) + ;; First make sure the modeline has fg and bg, inherited from the + ;; current default face - for the case where only one is specified, + ;; so that invert-face doesn't do something weird. + (or (face-foreground 'modeline frame) + (set-face-foreground 'modeline + (face-foreground-instance 'default frame) + frame)) + (or (face-background 'modeline frame) + (set-face-background 'modeline + (face-background-instance 'default frame) + frame)) + ;; Now invert both of them. If they end up looking the same, + ;; make-frame-initial-faces will invert the modeline again later. + (invert-face 'default frame) + (invert-face 'modeline frame) + ))) + +;;; x-faces.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/x-font-menu.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,564 @@ +;; x-font-menu.el --- Managing menus of X fonts. + +;; Copyright (C) 1994 Free Software Foundation, Inc. +;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp. +;; Copyright (C) 1997 Sun Microsystems + +;; Author: Jamie Zawinski <jwz@netscape.com> +;; Restructured by: Jonathan Stigelman <Stig@hackvan.com> +;; Mule-ized by: Martin Buchholz + +;; 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, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: +;;; +;;; Creates three menus, "Font", "Size", and "Weight", and puts them on the +;;; "Options" menu. The contents of these menus are the superset of those +;;; properties available on any fonts, but only the intersection of the three +;;; sets is selectable at one time. +;;; +;;; Known Problems: +;;; =============== +;;; Items on the Font menu are selectable if and only if that font exists in +;;; the same size and weight as the current font. This means that some fonts +;;; are simply not reachable from some other fonts - if only one font comes +;;; in only one point size (like "Nil", which comes only in 2), you will never +;;; be able to select it. It would be better if the items on the Fonts menu +;;; were always selectable, and selecting them would set the size to be the +;;; closest size to the current font's size. +;;; +;;; This attempts to change all other faces in an analagous way to the change +;;; that was made to the default face; if it can't, it will skip over the face. +;;; However, this could leave incongruous font sizes around, which may cause +;;; some nonreversibility problems if further changes are made. Perhaps it +;;; should remember the initial fonts of all faces, and derive all subsequent +;;; fonts from that initial state. +;;; +;;; xfontsel(1) is a lot more flexible (but probably harder to understand). +;;; +;;; The code to construct menus from all of the x11 fonts available from the +;;; server is autoloaded and executed the very first time that one of the Font +;;; menus is selected on each device. That is, if XEmacs has frames on two +;;; different devices, then separate font menu information will be maintained +;;; for each X display. If the font path changes after emacs has already +;;; asked the X server on a particular display for its list of fonts, this +;;; won't notice. Also, the first time that a font menu is posted on each +;;; display will entail a lengthy delay, but that's better than slowing down +;;; XEmacs startup. At any time (i.e.: after a font-path change or +;;; immediately after device creation), you can call +;;; `reset-device-font-menus' to rebuild the menus from all currently +;;; available fonts. +;;; +;;; There is knowledge here about the regexp match numbers in +;;; `x-font-regexp' and `x-font-regexp-foundry-and-family' defined in +;;; x-faces.el. +;;; +;;; There are at least three kinds of fonts under X11r5: +;;; +;;; - bitmap fonts, which can be assumed to look as good as possible; +;;; - bitmap fonts which have been (or can be) automatically scaled to +;;; a new size, and which almost always look awful; +;;; - and true outline fonts, which should look ok at any size, but in +;;; practice (on at least some systems) look awful at any size, and +;;; even in theory are unlikely ever to look as good as non-scaled +;;; bitmap fonts. +;;; +;;; It would be nice to get this code to look for non-scaled bitmap fonts +;;; first, then outline fonts, then scaled bitmap fonts as a last resort. +;;; But it's not clear to me how to tell them apart based on their truenames +;;; and/or the result of XListFonts(). I welcome any and all explanations +;;; of the subtleties involved... +;;; +;;; +;;; If You Think You'Re Seeing A Bug: +;;; ================================= +;;; When reporting problems, send the following information: +;;; +;;; - Exactly what behavior you're seeing; +;;; - The output of the `xlsfonts' program; +;;; - The value of the variable `device-fonts-cache'; +;;; - The values of the following expressions, both before and after +;;; making a selection from any of the fonts-related menus: +;;; (face-font 'default) +;;; (font-truename (face-font 'default)) +;;; (font-properties (face-font 'default)) +;;; - The values of the following variables after making a selection: +;;; font-menu-preferred-resolution +;;; font-menu-registry-encoding +;;; +;;; There is a common misconception that "*-courier-medium-r-*-11-*", also +;;; known as "-adobe-courier-medium-r-normal--11-80-100-100-m-60-iso8859-1", +;;; is an 11-point font. It is not -- it is an 11-pixel font at 100dpi, +;;; which is an 8-point font (the number after -11- is the size in tenths +;;; of points). So if you expect to be seeing an "11" entry in the "Size" +;;; menu and are not, this may be why. +;;; +;;; In the real world (aka Solaris), one has to deal with fonts that +;;; appear to be medium-i but are really light-r, and fonts that +;;; resolve to different resolutions depending on the charset: +;;; +;;; (font-instance-truename +;;; (make-font-instance "-*-mincho-medium-i-normal-*-*-*-*-*-*-*-jisx0201*-*")) +;;; ==> +;;; "-morisawa-ryumin light kl-light-r-normal--10-100-72-72-m-50-jisx0201.1976-0" +;;; +;;; (list-fonts "-dt-interface user-medium-r-normal-s*-*-*-*-*-*-*-*-*") +;;; ==> +;;; ("-dt-interface user-medium-r-normal-s sans-12-120-72-72-m-70-iso8859-1" +;;; "-dt-interface user-medium-r-normal-s-14-120-75-75-m-120-jisx0208.1983-0" +;;; "-dt-interface user-medium-r-normal-s-14-120-75-75-m-60-jisx0201.1976-0") + +;;; Code: + +;; #### - implement these... +;; +;;; (defvar font-menu-ignore-proportional-fonts nil +;;; "*If non-nil, then the font menu will only show fixed-width fonts.") + +;;;###autoload +(defcustom font-menu-ignore-scaled-fonts t + "*If non-nil, then the font menu will try to show only bitmap fonts." + :type 'boolean + :group 'x) + +;;;###autoload +(defcustom font-menu-this-frame-only-p nil + "*If non-nil, then changing the default font from the font menu will only +affect one frame instead of all frames." + :type 'boolean + :group 'x) + +;; only call XListFonts (and parse) once per device. +;; ( (device . [parsed-list-fonts family-menu size-menu weight-menu]) ...) +(defvar device-fonts-cache nil) + +(defvar font-menu-registry-encoding nil + "Registry and encoding to use with font menu fonts.") + +(defvar font-menu-preferred-resolution "*-*" + "Preferred horizontal and vertical font menu resolution (e.g. \"75-75\").") + +(defvar fonts-menu-junk-families + (purecopy + (mapconcat + #'identity + '("cursor" "glyph" "symbol" ; Obvious losers. + "\\`Ax...\\'" ; FrameMaker fonts - there are just way too + ; many of these, and there is a different + ; font family for each font face! Losers. + ; "Axcor" -> "Applix Courier Roman", + ; "Axcob" -> "Applix Courier Bold", etc. + ) + "\\|")) + "A regexp matching font families which are uninteresting (e.g. cursor fonts).") + +(eval-when-compile + (defsubst device-fonts-cache () + (or (cdr (assq (selected-device) device-fonts-cache)) + (reset-device-font-menus (selected-device))))) + +(defun hack-font-truename (fn) + "Filter the output of `font-instance-truename' to deal with Japanese fontsets." + (if (string-match "," (font-instance-truename fn)) + (let ((fpnt (nth 8 (split-string (font-instance-name fn) "-"))) + (flist (split-string (font-instance-truename fn) ",")) + ret) + (while flist + (if (string-equal fpnt (nth 8 (split-string (car flist) "-"))) + (progn (setq ret (car flist)) (setq flist nil)) + (setq flist (cdr flist)) + )) + ret) + (font-instance-truename fn))) + +;;;###autoload +(fset 'install-font-menus 'reset-device-font-menus) +(make-obsolete 'install-font-menus 'reset-device-font-menus) + +(defvar x-font-regexp-ascii nil + "This is used to filter out font families that can't display ASCII text. +It must be set at run-time.") + +(defun vassoc (key valist) + "Search VALIST for a vector whose first element is equal to KEY. +See also `assoc'." + ;; by Stig@hackvan.com + (let (el) + (catch 'done + (while (setq el (pop valist)) + (and (equal key (aref el 0)) + (throw 'done el)))))) + +;;;###autoload +(defun reset-device-font-menus (&optional device debug) + "Generates the `Font', `Size', and `Weight' submenus for the Options menu. +This is run the first time that a font-menu is needed for each device. +If you don't like the lazy invocation of this function, you can add it to +`create-device-hook' and that will make the font menus respond more quickly +when they are selected for the first time. If you add fonts to your system, +or if you change your font path, you can call this to re-initialize the menus." + ;; by Stig@hackvan.com + ;; #### - this should implement a `menus-only' option, which would + ;; recalculate the menus from the cache w/o having to do list-fonts again. + (message "Getting list of fonts from server... ") + (if (or noninteractive + (not (or device (setq device (selected-device)))) + (not (eq (device-type device) 'x))) + nil + (unless x-font-regexp-ascii + (setq x-font-regexp-ascii (if (featurep 'mule) + (charset-registry 'ascii) + "iso8859-1"))) + (setq font-menu-registry-encoding + (if (featurep 'mule) "*-*" "iso8859-1")) + (let ((case-fold-search t) + family size weight entry monospaced-p + dev-cache cache families sizes weights) + (dolist (name (cond ((null debug) ; debugging kludge + (list-fonts "*-*-*-*-*-*-*-*-*-*-*-*-*-*" device)) + ((stringp debug) (split-string debug "\n")) + (t debug))) + (when (and (string-match x-font-regexp-ascii name) + (string-match x-font-regexp name)) + (setq weight (capitalize (match-string 1 name)) + size (string-to-int (match-string 6 name))) + (or (string-match x-font-regexp-foundry-and-family name) + (error "internal error")) + (setq family (capitalize (match-string 1 name))) + (or (string-match x-font-regexp-spacing name) + (error "internal error")) + (setq monospaced-p (string= "m" (match-string 1 name))) + (unless (string-match fonts-menu-junk-families family) + (setq entry (or (vassoc family cache) + (car (setq cache + (cons (vector family nil nil t) + cache))))) + (or (member family families) (push family families)) + (or (member weight weights) (push weight weights)) + (or (member size sizes) (push size sizes)) + (or (member weight (aref entry 1)) (push weight (aref entry 1))) + (or (member size (aref entry 2)) (push size (aref entry 2))) + (aset entry 3 (and (aref entry 3) monospaced-p))))) + ;; + ;; Hack scalable fonts. + ;; Some fonts come only in scalable versions (the only size is 0) + ;; and some fonts come in both scalable and non-scalable versions + ;; (one size is 0). If there are any scalable fonts at all, make + ;; sure that the union of all point sizes contains at least some + ;; common sizes - it's possible that some sensible sizes might end + ;; up not getting mentioned explicitly. + ;; + (if (member 0 sizes) + (let ((common '(60 80 100 120 140 160 180 240))) + (while common + (or;;(member (car common) sizes) ; not enough slack + (let ((rest sizes) + (done nil)) + (while (and (not done) rest) + (if (and (> (car common) (- (car rest) 5)) + (< (car common) (+ (car rest) 5))) + (setq done t)) + (setq rest (cdr rest))) + done) + (setq sizes (cons (car common) sizes))) + (setq common (cdr common))) + (setq sizes (delq 0 sizes)))) + + (setq families (sort families 'string-lessp) + weights (sort weights 'string-lessp) + sizes (sort sizes '<)) + + (dolist (entry cache) + (aset entry 1 (sort (aref entry 1) 'string-lessp)) + (aset entry 2 (sort (aref entry 2) '<))) + + (message "Getting list of fonts from server... done.") + + (setq dev-cache (assq device device-fonts-cache)) + (or dev-cache + (setq dev-cache (car (push (list device) device-fonts-cache)))) + (setcdr + dev-cache + (vector + cache + (mapcar (lambda (x) + (vector x + (list 'font-menu-set-font x nil nil) + ':style 'radio ':active nil ':selected nil)) + families) + (mapcar (lambda (x) + (vector (if (/= 0 (% x 10)) + ;; works with no LISP_FLOAT_TYPE + (concat (int-to-string (/ x 10)) "." + (int-to-string (% x 10))) + (int-to-string (/ x 10))) + (list 'font-menu-set-font nil nil x) + ':style 'radio ':active nil ':selected nil)) + sizes) + (mapcar (lambda (x) + (vector x + (list 'font-menu-set-font nil x nil) + ':style 'radio ':active nil ':selected nil)) + weights))) + (cdr dev-cache)))) + +;; Extract font information from a face. We examine both the +;; user-specified font name and the canonical (`true') font name. +;; These can appear to have totally different properties. +;; For examples, see the prolog above. + +;; We use the user-specified one if possible, else use the truename. +;; If the user didn't specify one (with "-dt-*-*", for example) +;; get the truename and use the possibly suboptimal data from that. +(defun* font-menu-font-data (face dcache) + (let* ((case-fold-search t) + (domain (if font-menu-this-frame-only-p + (selected-frame) + (selected-device))) + (name (font-instance-name (face-font-instance face domain))) + (truename (font-instance-truename + (face-font-instance face domain + (if (featurep 'mule) 'ascii)))) + family size weight entry slant) + (when (string-match x-font-regexp-foundry-and-family name) + (setq family (capitalize (match-string 1 name))) + (setq entry (vassoc family (aref dcache 0)))) + (when (and (null entry) + (string-match x-font-regexp-foundry-and-family truename)) + (setq family (capitalize (match-string 1 truename))) + (setq entry (vassoc family (aref dcache 0)))) + (when (null entry) + (return-from font-menu-font-data (make-vector 5 nil))) + + (when (string-match x-font-regexp name) + (setq weight (capitalize (match-string 1 name))) + (setq size (string-to-int (match-string 6 name)))) + + (when (string-match x-font-regexp truename) + (when (not (member weight (aref entry 1))) + (setq weight (capitalize (match-string 1 truename)))) + (when (not (member size (aref entry 2))) + (setq size (string-to-int (match-string 6 truename)))) + (setq slant (capitalize (match-string 2 truename)))) + + (vector entry family size weight slant))) + +;;;###autoload +(defun font-menu-family-constructor (ignored) + (catch 'menu + (unless (eq 'x (device-type (selected-device))) + (throw 'menu '(["Cannot parse current font" ding nil]))) + (let* ((dcache (device-fonts-cache)) + (font-data (font-menu-font-data 'default dcache)) + (entry (aref font-data 0)) + (family (aref font-data 1)) + (size (aref font-data 2)) + (weight (aref font-data 3)) + f) + (unless family + (throw 'menu '(["Cannot parse current font" ding nil]))) + ;; Items on the Font menu are enabled iff that font exists in + ;; the same size and weight as the current font (scalable fonts + ;; exist in every size). Only the current font is marked as + ;; selected. + (mapcar + (lambda (item) + (setq f (aref item 0) + entry (vassoc f (aref dcache 0))) + (if (and (member weight (aref entry 1)) + (or (member size (aref entry 2)) + (and (not font-menu-ignore-scaled-fonts) + (member 0 (aref entry 2))))) + (enable-menu-item item) + (disable-menu-item item)) + (if (string-equal family f) + (select-toggle-menu-item item) + (deselect-toggle-menu-item item)) + item) + (aref dcache 1))))) + +;;;###autoload +(defun font-menu-size-constructor (ignored) + (catch 'menu + (unless (eq 'x (device-type (selected-device))) + (throw 'menu '(["Cannot parse current font" ding nil]))) + (let* ((dcache (device-fonts-cache)) + (font-data (font-menu-font-data 'default dcache)) + (entry (aref font-data 0)) + (family (aref font-data 1)) + (size (aref font-data 2)) + ;;(weight (aref font-data 3)) + s) + (unless family + (throw 'menu '(["Cannot parse current font" ding nil]))) + ;; Items on the Size menu are enabled iff current font has + ;; that size. Only the size of the current font is selected. + ;; (If the current font comes in size 0, it is scalable, and + ;; thus has every size.) + (mapcar + (lambda (item) + (setq s (nth 3 (aref item 1))) + (if (or (member s (aref entry 2)) + (and (not font-menu-ignore-scaled-fonts) + (member 0 (aref entry 2)))) + (enable-menu-item item) + (disable-menu-item item)) + (if (eq size s) + (select-toggle-menu-item item) + (deselect-toggle-menu-item item)) + item) + (aref dcache 2))))) + +;;;###autoload +(defun font-menu-weight-constructor (ignored) + (catch 'menu + (unless (eq 'x (device-type (selected-device))) + (throw 'menu '(["Cannot parse current font" ding nil]))) + (let* ((dcache (device-fonts-cache)) + (font-data (font-menu-font-data 'default dcache)) + (entry (aref font-data 0)) + (family (aref font-data 1)) + ;;(size (aref font-data 2)) + (weight (aref font-data 3)) + w) + (unless family + (throw 'menu '(["Cannot parse current font" ding nil]))) + ;; Items on the Weight menu are enabled iff current font + ;; has that weight. Only the weight of the current font + ;; is selected. + (mapcar + (lambda (item) + (setq w (aref item 0)) + (if (member w (aref entry 1)) + (enable-menu-item item) + (disable-menu-item item)) + (if (string-equal weight w) + (select-toggle-menu-item item) + (deselect-toggle-menu-item item)) + item) + (aref dcache 3))))) + + +;;; Changing font sizes + +(defun font-menu-set-font (family weight size) + ;; This is what gets run when an item is selected from any of the three + ;; fonts menus. It needs to be rather clever. + ;; (size is measured in 10ths of points.) + (let* ((dcache (device-fonts-cache)) + (font-data (font-menu-font-data 'default dcache)) + (from-family (aref font-data 1)) + (from-size (aref font-data 2)) + (from-weight (aref font-data 3)) + (from-slant (aref font-data 4)) + new-default-face-font) + (unless from-family + (signal 'error '("couldn't parse font name for default face"))) + (setq new-default-face-font + (font-menu-load-font (or family from-family) + (or weight from-weight) + (or size from-size) + from-slant + font-menu-preferred-resolution)) + (dolist (face (delq 'default (face-list))) + (when (face-font-instance face) + (message "Changing font of `%s'..." face) + (condition-case c + (font-menu-change-face face + from-family from-weight from-size + family weight size) + (error + (display-error c nil) + (sit-for 1))))) + ;; Set the default face's font after hacking the other faces, so that + ;; the frame size doesn't change until we are all done. + + ;;; WMP - we need to honor font-menu-this-frame-only-p here! + (set-face-font 'default new-default-face-font + (and font-menu-this-frame-only-p (selected-frame))) + (message "Font %s" (face-font-name 'default)))) + + +(defun font-menu-change-face (face + from-family from-weight from-size + to-family to-weight to-size) + (or (symbolp face) (signal 'wrong-type-argument (list 'symbolp face))) + (let* ((dcache (device-fonts-cache)) + (font-data (font-menu-font-data face dcache)) + (face-family (aref font-data 1)) + (face-size (aref font-data 2)) + (face-weight (aref font-data 3)) + (face-slant (aref font-data 4))) + + (or face-family + (signal 'error (list "couldn't parse font name for face" face))) + + ;; If this face matches the old default face in the attribute we + ;; are changing, then change it to the new attribute along that + ;; dimension. Also, the face must have its own global attribute. + ;; If its value is inherited, we don't touch it. If any of this + ;; is not true, we leave it alone. + (when (and (face-font face 'global) + (cond + (to-family (string-equal face-family from-family)) + (to-weight (string-equal face-weight from-weight)) + (to-size (= face-size from-size)))) + (set-face-font face + (font-menu-load-font (or to-family face-family) + (or to-weight face-weight) + (or to-size face-size) + face-slant + font-menu-preferred-resolution) + (and font-menu-this-frame-only-p + (selected-frame)))))) + +(defun font-menu-load-font (family weight size slant resolution) + "Try to load a font with the requested properties. +The weight, slant and resolution are only hints." + (when (integerp size) (setq size (int-to-string size))) + (let (font) + (catch 'got-font + (dolist (weight (list weight "*")) + (dolist (slant + (cond ((string-equal slant "O") '("O" "I" "*")) + ((string-equal slant "I") '("I" "O" "*")) + ((string-equal slant "*") '("*")) + (t (list slant "*")))) + (dolist (resolution + (if (string-equal resolution "*-*") + (list resolution) + (list resolution "*-*"))) + (when (setq font + (make-font-instance + (concat "-*-" family "-" weight "-" slant "-*-*-*-" + size "-" resolution "-*-*-" + font-menu-registry-encoding) + nil t)) + (throw 'got-font font)))))))) + +(defun flush-device-fonts-cache (device) + ;; by Stig@hackvan.com + (let ((elt (assq device device-fonts-cache))) + (and elt + (setq device-fonts-cache (delq elt device-fonts-cache))))) + +(add-hook 'delete-device-hook 'flush-device-fonts-cache) + +(provide 'x-font-menu) + +;;; x-font-menu.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/x-init.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,330 @@ +;;; x-init.el --- initialization code for X windows + +;; Copyright (C) 1990, 1993, 1994, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1995 Board of Trustees, University of Illinois. +;; Copyright (C) 1995, 1996 Ben Wing. + +;; Maintainer: XEmacs Development Team +;; Keywords: terminals, dumped + +;; 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, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: Not synched. + +;;; Commentary: + +;; This file is dumped with XEmacs (when X support is compiled in). + +;;; Code: + +;; If you want to change this variable, this is the place you must do it. +;; Do not set it to a string containing periods. X doesn't like that. +;(setq x-emacs-application-class "Emacs") + +;; selections and active regions + +;; If and only if zmacs-regions is true: + +;; When a mark is pushed and the region goes into the "active" state, we +;; assert it as the Primary selection. This causes it to be hilighted. +;; When the region goes into the "inactive" state, we disown the Primary +;; selection, causing the region to be dehilighted. + +;; Note that it is possible for the region to be in the "active" state +;; and not be hilighted, if it is in the active state and then some other +;; application asserts the selection. This is probably not a big deal. + +(defun x-activate-region-as-selection () + (if (marker-buffer (mark-marker t)) + (x-own-selection (cons (point-marker t) (mark-marker t))))) + +;; OpenWindows-like "find" processing. These functions are really Sunisms, +;; but we put them here instead of in x-win-sun.el in case someone wants +;; to use them when not running on a Sun console (presumably after binding +;; them to different keys, or putting them on menus.) + +(defvar ow-find-last-string nil) +(defvar ow-find-last-clipboard nil) + +(defun ow-find (&optional backward-p) + "Search forward the next occurrence of the text of the selection." + (interactive) + (let ((sel (condition-case () (x-get-selection) (error nil))) + (clip (condition-case () (x-get-clipboard) (error nil))) + text) + (setq text (cond + (sel) + ((not (equal clip ow-find-last-clipboard)) + (setq ow-find-last-clipboard clip)) + (ow-find-last-string) + (t (error "No selection available")))) + (setq ow-find-last-string text) + (cond (backward-p + (search-backward text) + (set-mark (+ (point) (length text)))) + (t + (search-forward text) + (set-mark (- (point) (length text))))) + (zmacs-activate-region))) + +(defun ow-find-backward () + "Search backward for the previous occurrence of the text of the selection." + (interactive) + (ow-find t)) + +;; Load X-server specific code. +;; Specifically, load some code to repair the grievous damage that MIT and +;; Sun have done to the default keymap for the Sun keyboards. + +(eval-when-compile + (defmacro x-define-dead-key (key map) + `(when (x-keysym-on-keyboard-p ,(symbol-name key)) + (define-key function-key-map [,key] ',map)))) + +(defun x-initialize-compose () + "Enable compose 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) + (autoload 'compose-cedilla-map "x-compose" nil t 'keymap) + (autoload 'compose-diaeresis-map "x-compose" nil t 'keymap) + (autoload 'compose-circumflex-map "x-compose" nil t 'keymap) + (autoload 'compose-tilde-map "x-compose" nil t 'keymap) + + (when (x-keysym-on-keyboard-p "Multi_key") + (define-key function-key-map [multi-key] 'compose-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. + + ;; Canonical names: + (x-define-dead-key acute compose-acute-map) + (x-define-dead-key grave compose-grave-map) + (x-define-dead-key cedilla compose-cedilla-map) + (x-define-dead-key diaeresis compose-diaeresis-map) + (x-define-dead-key circumflex compose-circumflex-map) + (x-define-dead-key tilde compose-tilde-map) + (x-define-dead-key degree compose-ring-map) + + ;; Sun according to MIT: + (x-define-dead-key SunFA_Acute compose-acute-map) + (x-define-dead-key SunFA_Grave compose-grave-map) + (x-define-dead-key SunFA_Cedilla compose-cedilla-map) + (x-define-dead-key SunFA_Diaeresis compose-diaeresis-map) + (x-define-dead-key SunFA_Circum compose-circumflex-map) + (x-define-dead-key SunFA_Tilde compose-tilde-map) + + ;; Sun according to OpenWindows 2: + (x-define-dead-key Dead_Grave compose-grave-map) + (x-define-dead-key Dead_Circum compose-circumflex-map) + (x-define-dead-key Dead_Tilde compose-tilde-map) + + ;; Sun according to OpenWindows 3: + (x-define-dead-key SunXK_FA_Acute compose-acute-map) + (x-define-dead-key SunXK_FA_Grave compose-grave-map) + (x-define-dead-key SunXK_FA_Cedilla compose-cedilla-map) + (x-define-dead-key SunXK_FA_Diaeresis compose-diaeresis-map) + (x-define-dead-key SunXK_FA_Circum compose-circumflex-map) + (x-define-dead-key SunXK_FA_Tilde compose-tilde-map) + + ;; DEC according to MIT: + (x-define-dead-key Dacute_accent compose-acute-map) + (x-define-dead-key Dgrave_accent compose-grave-map) + (x-define-dead-key Dcedilla_accent compose-cedilla-map) + (x-define-dead-key Dcircumflex_accent compose-circumflex-map) + (x-define-dead-key Dtilde compose-tilde-map) + (x-define-dead-key Dring_accent compose-ring-map) + + ;; DEC according to OpenWindows 3: + (x-define-dead-key DXK_acute_accent compose-acute-map) + (x-define-dead-key DXK_grave_accent compose-grave-map) + (x-define-dead-key DXK_cedilla_accent compose-cedilla-map) + (x-define-dead-key DXK_circumflex_accent compose-circumflex-map) + (x-define-dead-key DXK_tilde compose-tilde-map) + (x-define-dead-key DXK_ring_accent compose-ring-map) + + ;; HP according to MIT: + (x-define-dead-key hpmute_acute compose-acute-map) + (x-define-dead-key hpmute_grave compose-grave-map) + (x-define-dead-key hpmute_diaeresis compose-diaeresis-map) + (x-define-dead-key hpmute_asciicircum compose-circumflex-map) + (x-define-dead-key hpmute_asciitilde compose-tilde-map) + + ;; HP according to OpenWindows 3: + (x-define-dead-key hpXK_mute_acute compose-acute-map) + (x-define-dead-key hpXK_mute_grave compose-grave-map) + (x-define-dead-key hpXK_mute_diaeresis compose-diaeresis-map) + (x-define-dead-key hpXK_mute_asciicircum compose-circumflex-map) + (x-define-dead-key hpXK_mute_asciitilde compose-tilde-map) + + ;; HP according to HP-UX 8.0: + (x-define-dead-key XK_mute_acute compose-acute-map) + (x-define-dead-key XK_mute_grave compose-grave-map) + (x-define-dead-key XK_mute_diaeresis compose-diaeresis-map) + (x-define-dead-key XK_mute_asciicircum compose-circumflex-map) + (x-define-dead-key XK_mute_asciitilde compose-tilde-map) + + ;; Xfree86 seems to use lower case and a hyphen + (x-define-dead-key dead-acute compose-acute-map) + (x-define-dead-key dead-grave compose-grave-map) + (x-define-dead-key dead-cedilla compose-cedilla-map) + (x-define-dead-key dead-diaeresis compose-diaeresis-map) + (x-define-dead-key dead-circum compose-circumflex-map) + (x-define-dead-key dead-tilde compose-tilde-map) + + ;; and AIX uses underscore, sigh.... + (x-define-dead-key dead_acute compose-acute-map) + (x-define-dead-key dead_grave compose-grave-map) + (x-define-dead-key dead_cedilla compose-cedilla-map) + (x-define-dead-key dead_diaeresis compose-diaeresis-map) + (x-define-dead-key dead_circum compose-circumflex-map) + (x-define-dead-key dead_tilde compose-tilde-map) + ) + +(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 + ;; a Sun keyboard. + ;; + ;; One way of implementing this (which would require C support) would + ;; be to examine the X keymap itself and see if the layout looks even + ;; 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. + (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")) + ((string-match "XFree86" vendor) + ;; Those XFree86 people do some weird keysym stuff, too. + (load "x-win-xfree86"))))) + + +(defvar pre-x-win-initted nil) + +(defun init-pre-x-win () + "Initialize X Windows at startup (pre). Don't call this." + (when (not pre-x-win-initted) + (require 'x-iso8859-1) + (setq character-set-property 'x-iso8859/1) ; see x-iso8859-1.el + + (setq initial-frame-plist (if initial-frame-unmapped-p + '(initially-unmapped t) + nil)) + (setq pre-x-win-initted t))) + +(defvar x-win-initted nil) + +(defun init-x-win () + "Initialize X Windows at startup. Don't call this." + (when (not x-win-initted) + (init-pre-x-win) + + ;; Open the X display when this file is loaded + ;; (Note that the first frame is created later.) + (setq x-initial-argv-list (cons (car command-line-args) + command-line-args-left)) + (make-x-device nil) + (setq command-line-args-left (cdr x-initial-argv-list)) + (setq x-win-initted t))) + +(defvar post-x-win-initted nil) + +(defun init-post-x-win () + "Initialize X Windows at startup (post). Don't call this." + (when (not post-x-win-initted) + ;; We can't load this until after the initial X device is created + ;; because the icon initialization needs to access the display to get + ;; any toolbar-related color resources. + (if (featurep 'toolbar) + (init-x-toolbar)) + (if (featurep 'mule) + (init-mule-x-win)) + ;; 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)))) + (add-hook 'zmacs-activate-region-hook + (lambda () + (if (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)))) + ;; Motif-ish bindings + ;; The following two were generally unliked. + ;;(define-key global-map '(shift delete) 'x-kill-primary-selection) + ;;(define-key global-map '(control delete) 'x-delete-primary-selection) + (define-key global-map '(shift insert) 'x-yank-clipboard-selection) + (define-key global-map '(control insert) 'x-copy-primary-selection) + ;; These are Sun-isms. + (define-key global-map 'copy 'x-copy-primary-selection) + (define-key global-map 'paste 'x-yank-clipboard-selection) + (define-key global-map 'cut 'x-kill-primary-selection) + + (define-key global-map 'menu 'popup-mode-menu) + ;;(define-key global-map '(shift menu) 'x-goto-menubar) ;NYI + + (setq post-x-win-initted t))) + +;;; Keyboard initialization needs to be done differently for each X +;;; console, so use create-console-hook. +(when (featurep 'x) + (add-hook + 'create-console-hook + (lambda (console) + (letf (((selected-console) console)) + (when (eq 'x (console-type console)) + (x-initialize-keyboard) + (x-initialize-compose)))))) + +(defun make-frame-on-display (display &optional props) + "Create a frame on the X display named DISPLAY. +DISPLAY should be a standard display string such as \"unix:0\", +or nil for the display specified on the command line or in the +DISPLAY environment variable. + +PROPS should be a plist of properties, as in the call to `make-frame'. + +This function opens a connection to the display or reuses an existing +connection. + +This function is a trivial wrapper around `make-frame-on-device'." + (interactive "sMake frame on display: ") + (if (equal display "") (setq display nil)) + (make-frame-on-device 'x display props)) + +;;; x-init.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/x-iso8859-1.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,273 @@ +;;; x-iso8859-1 --- Mapping between X keysym names and ISO 8859-1 + +;; Copyright (C) 1992, 1993, 1997 Free Software Foundation, Inc. + +;; Author: Jamie Zawinski <jwz@netscape.com> +;; Created: 15-jun-92 +;; Maintainer: XEmacs Development Team +;; Keywords: extensions, internal, dumped + +;; 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 synched. + +;;; Commentary: + +;; created by jwz, 13-jun-92. +;; changed by Heiko Muenkel, 12-jun-1997: Added a grave keysym. + +;; Under X, when the user types a character that is ISO-8859/1 but not ASCII, +;; it comes in as a symbol instead of as a character code. This keeps things +;; nice and character-set independent. This file takes all of those symbols +;; (the symbols that are the X names for the 8859/1 characters) and puts a +;; property on them which holds the character code that should be inserted in +;; the buffer when they are typed. The self-insert-command function will look +;; at this. It also binds them all to self-insert-command. + +;; It puts the same property on the keypad keys, so that (read-char) will +;; think that they are the same as the digit characters. However, those +;; 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 +;; that is not X-specific. + +;;; Code: + +(require 'iso8859-1) + +(defconst iso8859/1-code-to-x-keysym-table nil + "Maps iso8859/1 to an X keysym name which corresponds to it. +There may be more than one X name for this keycode; this returns the first one. +Note that this is X specific; one should avoid using this table whenever +possible, in the interest of portability.") + +;; (This esoteric little construct is how you do MACROLET in elisp. It +;; generates the most efficient code for the .elc file by unwinding the +;; loop at compile-time.) + +((macro + . (lambda (&rest syms-and-iso8859/1-codes) + (cons + 'progn + (nconc + ;; + ;; First emit code that puts the `x-iso8859/1' property on all of + ;; the keysym symbols. + ;; + (mapcar '(lambda (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)) + syms-and-iso8859/1-codes) + ;; + ;; Then emit the value of iso8859/1-code-to-x-keysym-table. + ;; + (let ((v (make-vector 256 nil))) + ;; the printing ASCII chars have 1-char names. + (let ((i 33)) + (while (< i 127) + (aset v i (intern (make-string 1 i))) + (setq i (1+ i)))) + ;; these are from the keyboard character set. + (mapcar '(lambda (x) (aset v (car x) (car (cdr x)))) + '((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)))) + syms-and-iso8859/1-codes) + (list (list 'setq 'iso8859/1-code-to-x-keysym-table v))) + )))) + + ;; The names and capitalization here are as per the MIT X11R4 and X11R5 + ;; distributions. If a vendor varies from this, adjustments will need + ;; to be made... + + (grave ?\140) + (nobreakspace ?\240) + (exclamdown ?\241) + (cent ?\242) + (sterling ?\243) + (currency ?\244) + (yen ?\245) + (brokenbar ?\246) + (section ?\247) + (diaeresis ?\250) + (copyright ?\251) + (ordfeminine ?\252) + (guillemotleft ?\253) + (notsign ?\254) + (hyphen ?\255) + (registered ?\256) + (macron ?\257) + (degree ?\260) + (plusminus ?\261) + (twosuperior ?\262) + (threesuperior ?\263) + (acute ?\264) ; Why is there an acute keysym that is + (mu ?\265) ; distinct from apostrophe/quote, but + (paragraph ?\266) ; no grave keysym that is distinct from + (periodcentered ?\267) ; backquote? + (cedilla ?\270) ; I've added the grave keysym, because it's + (onesuperior ?\271) ; used in x-compose (Heiko Muenkel). + (masculine ?\272) + (guillemotright ?\273) + (onequarter ?\274) + (onehalf ?\275) + (threequarters ?\276) + (questiondown ?\277) + + (Agrave ?\300) + (Aacute ?\301) + (Acircumflex ?\302) + (Atilde ?\303) + (Adiaeresis ?\304) + (Aring ?\305) + (AE ?\306) + (Ccedilla ?\307) + (Egrave ?\310) + (Eacute ?\311) + (Ecircumflex ?\312) + (Ediaeresis ?\313) + (Igrave ?\314) + (Iacute ?\315) + (Icircumflex ?\316) + (Idiaeresis ?\317) + (ETH ?\320) + (Ntilde ?\321) + (Ograve ?\322) + (Oacute ?\323) + (Ocircumflex ?\324) + (Otilde ?\325) + (Odiaeresis ?\326) + (multiply ?\327) + (Ooblique ?\330) + (Ugrave ?\331) + (Uacute ?\332) + (Ucircumflex ?\333) + (Udiaeresis ?\334) + (Yacute ?\335) + (THORN ?\336) + (ssharp ?\337) + + (agrave ?\340) + (aacute ?\341) + (acircumflex ?\342) + (atilde ?\343) + (adiaeresis ?\344) + (aring ?\345) + (ae ?\346) + (ccedilla ?\347) + (egrave ?\350) + (eacute ?\351) + (ecircumflex ?\352) + (ediaeresis ?\353) + (igrave ?\354) + (iacute ?\355) + (icircumflex ?\356) + (idiaeresis ?\357) + (eth ?\360) + (ntilde ?\361) + (ograve ?\362) + (oacute ?\363) + (ocircumflex ?\364) + (otilde ?\365) + (odiaeresis ?\366) + (division ?\367) + (oslash ?\370) + (ugrave ?\371) + (uacute ?\372) + (ucircumflex ?\373) + (udiaeresis ?\374) + (yacute ?\375) + (thorn ?\376) + (ydiaeresis ?\377) + + ) + +((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)))) + syms-and-iso8859/1-codes)))) + ;; + ;; Let's do the appropriate thing for some vendor-specific keysyms too... + ;; Apparently nobody agrees on what the names of these keysyms are. + ;; + (SunFA_Acute ?\264) + (SunXK_FA_Acute ?\264) + (Dacute_accent ?\264) + (DXK_acute_accent ?\264) + (hpmute_acute ?\264) + (hpXK_mute_acute ?\264) + (XK_mute_acute ?\264) + + (SunFA_Grave ?`) + (Dead_Grave ?`) + (SunXK_FA_Grave ?`) + (Dgrave_accent ?`) + (DXK_grave_accent ?`) + (hpmute_grave ?`) + (hpXK_mute_grave ?`) + (XK_mute_grave ?`) + + (SunFA_Cedilla ?\270) + (SunXK_FA_Cedilla ?\270) + (Dcedilla_accent ?\270) + (DXK_cedilla_accent ?\270) + + (SunFA_Diaeresis ?\250) + (SunXK_FA_Diaeresis ?\250) + (hpmute_diaeresis ?\250) + (hpXK_mute_diaeresis ?\250) + (XK_mute_diaeresis ?\250) + + (SunFA_Circum ?^) + (Dead_Circum ?^) + (SunXK_FA_Circum ?^) + (Dcircumflex_accent ?^) + (DXK_circumflex_accent ?^) + (hpmute_asciicircum ?^) + (hpXK_mute_asciicircum ?^) + (XK_mute_asciicircum ?^) + + (SunFA_Tilde ?~) + (Dead_Tilde ?~) + (SunXK_FA_Tilde ?~) + (Dtilde ?~) + (DXK_tilde ?~) + (hpmute_asciitilde ?~) + (hpXK_mute_asciitilde ?~) + (XK_mute_asciitilde ?~) + + (Dring_accent ?\260) + (DXK_ring_accent ?\260) + ) + +(provide 'x-iso8859-1) + +;;; x-iso8859-1.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/x-menubar.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,1614 @@ +;;; x-menubar.el --- Menubar and popup-menu support for X. + +;; Copyright (C) 1991-5, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp. +;; Copyright (C) 1995 Sun Microsystems. +;; Copyright (C) 1995, 1996 Ben Wing. +;; Copyright (C) 1997 MORIOKA Tomohiko + +;; Maintainer: XEmacs Development Team +;; Keywords: extensions, internal, dumped + +;; 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 Xmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This file is dumped with XEmacs (when X11 and menubar support is compiled +;; in). + +;;; Code: + +;;; Warning-free compile +(eval-when-compile + (defvar language-environment-list) + (require 'pending-del)) + +(defconst default-menubar + (purecopy-menubar + ;; note backquote. + `( + ("File" + :filter file-menu-filter + ["Open..." find-file t] + ["Open in Other Window..." find-file-other-window t] + ["Open in New Frame..." find-file-other-frame t] + ["Insert File..." insert-file t] + ["View File..." view-file t] + "------" + ["Save" save-buffer t nil] + ["Save As..." write-file t] + ["Save Some Buffers" save-some-buffers t] + "-----" + ["Print Buffer" lpr-buffer t nil] + ["Pretty-Print Buffer" ps-print-buffer-with-faces t nil] + "-----" + ["New Frame" make-frame t] + ["Frame on Other Display..." + make-frame-on-display t] + ["Delete Frame" delete-frame t] + "-----" + ["Split Window" split-window-vertically t] + ["Un-Split (Keep This)" delete-other-windows (not (one-window-p t))] + ["Un-Split (Keep Others)" delete-window (not (one-window-p t))] + "-----" + ["Revert Buffer" revert-buffer t nil] + ["Delete Buffer" kill-this-buffer t nil] + "-----" + ["Exit XEmacs" save-buffers-kill-emacs t] + ) + + ("Edit" + :filter edit-menu-filter + ["Undo" advertised-undo t] + ["Cut" x-kill-primary-selection t] + ["Copy" x-copy-primary-selection t] + ["Paste" x-yank-clipboard-selection t] + ["Clear" x-delete-primary-selection t] + "----" + ["Search..." isearch-forward t] + ["Search Backward..." isearch-backward t] + ["Replace..." query-replace t] + "----" + ["Search (Regexp)..." isearch-forward-regexp t] + ["Search Backward (Regexp)..." isearch-backward-regexp t] + ["Replace (Regexp)..." query-replace-regexp t] + "----" + ("Bookmarks" + ("Jump to bookmark" + :filter bookmark-menu-filter) + ["Set bookmark" bookmark-set t] + "---" + ["Insert contents" bookmark-menu-insert t] + ["Insert location" bookmark-menu-locate t] + "---" + ["Rename bookmark" bookmark-menu-rename t] + ("Delete bookmark" + :filter bookmark-delete-filter) + ["Edit Bookmark List" bookmark-bmenu-list t] + "---" + ["Save bookmarks" bookmark-save t] + ["Save bookmarks as..." bookmark-write t] + ["Load a bookmark file" bookmark-load t]) + "----" + ["Goto Line..." goto-line t] + ["What Line" what-line t] + "----" + ["Start Macro Recording" start-kbd-macro (not defining-kbd-macro)] + ["End Macro Recording" end-kbd-macro defining-kbd-macro] + ["Execute Last Macro" call-last-kbd-macro last-kbd-macro] + "----" + ["Show Message Log" show-message-log t] + ) + + ,@(if (featurep 'mule) + '(("Mule" + ("Describe language support") + ("Set language environment") + "--" + ["Toggle input method" toggle-input-method t] + ["Select input method" select-input-method t] + ["Describe input method" describe-input-method t] + "--" + ["Describe current coding systems" + describe-current-coding-system t] + ["Set coding system of buffer file" + set-buffer-file-coding-system t] + ["Set coding system of terminal" + set-terminal-coding-system nil] ; not implemented yet + ["Set coding system of keyboard" + set-keyboard-coding-system nil] ; not implemented yet + ["Set coding system of process" + set-current-process-coding-system nil] ; not implemented yet + "--" + ["Show character table" view-charset-by-menu t] + ["Show diagnosis for MULE" mule-diag nil] ; not implemented yet + ["Show many languages" view-hello-file t] + ))) + + ("Apps" + ["Read Mail (VM)..." vm t] + ["Read Mail (MH)..." (mh-rmail t) t] + ["Send mail..." mail t] + ["Usenet News" gnus (fboundp 'gnus)] + ["Browse the Web" w3 t] + ["Gopher" gopher t] + ["Hyperbole..." hyperbole t] + "----" + ["Spell-Check Buffer" ispell-buffer t] + ["Toggle VI emulation" toggle-viper-mode (fboundp 'toggle-viper-mode)] + "----" + ("Calendar" + ["3-Month Calendar" calendar t] + ["Diary" diary t] + ["Holidays" holidays t] + ;; we're all pagans at heart ... + ["Phases of the Moon" phases-of-moon t] + ["Sunrise/Sunset" sunrise-sunset t] + ) + ("Games" + ["Mine Game" xmine (fboundp 'xmine)] + ["Tetris" tetris (fboundp 'tetris)] + ["Quote from Zippy" yow (fboundp 'yow)] + ["Psychoanalyst" doctor (fboundp 'doctor)] + ["Psychoanalyze Zippy!" psychoanalyze-pinhead (fboundp 'psychoanalyze-pinhead)] + ["Random Flames" flame (fboundp 'flame)] + ["Dunnet (Adventure)" dunnet (fboundp 'dunnet)] + ["Towers of Hanoi" hanoi (fboundp 'hanoi)] + ["Game of Life" life (fboundp 'life)] + ["Multiplication Puzzle" mpuz (fboundp 'mpuz)] + ) + ) + + ("Options" + ("Customize" + ("Emacs" :filter (lambda (&rest junk) + (cdr (custom-menu-create 'emacs)))) + ["Group..." customize-group t] + ["Variable..." customize-variable t] + ["Face..." customize-face t] + ["Saved..." customize-saved t] + ["Set..." customize-customized t] + ["Apropos..." customize-apropos t]) + ["Read Only" (toggle-read-only) + :style toggle :selected buffer-read-only] + ("Editing Options" + ["Overstrike" (progn + (overwrite-mode current-prefix-arg) + (setq-default overwrite-mode overwrite-mode)) + :style toggle :selected overwrite-mode] + ["Case Sensitive Search" (progn + (setq case-fold-search (not case-fold-search)) + (setq-default case-fold-search + case-fold-search)) + :style toggle :selected (not case-fold-search)] + ["Case Matching Replace" (setq case-replace (not case-replace)) + :style toggle :selected case-replace] + ["Auto Delete Selection" (pending-delete-mode + (if pending-delete-mode 0 1)) + :style toggle + :selected (and (boundp 'pending-delete-mode) pending-delete-mode)] + ["Active Regions" (setq zmacs-regions (not zmacs-regions)) + :style toggle :selected zmacs-regions] + ["Mouse Paste At Text Cursor" (setq mouse-yank-at-point + (not mouse-yank-at-point)) + :style toggle :selected mouse-yank-at-point] + ["Require Newline At End" (setq require-final-newline + (or (eq require-final-newline 'ask) + (not require-final-newline))) + :style toggle :selected (eq require-final-newline 't)] + ["Add Newline When Moving Past End" (setq next-line-add-newlines + (not next-line-add-newlines)) + :style toggle :selected next-line-add-newlines] + ) + ("General Options" + ["Teach Extended Commands" (setq teach-extended-commands-p + (not teach-extended-commands-p)) + :style toggle :selected teach-extended-commands-p] + ["Debug On Error" (setq debug-on-error (not debug-on-error)) + :style toggle :selected debug-on-error] + ["Debug On Quit" (setq debug-on-quit (not debug-on-quit)) + :style toggle :selected debug-on-quit] + ) + ("Printing Options" + ["Command-Line Switches for `lpr'/`lp'..." + (setq lpr-switches + (read-expression "Switches for `lpr'/`lp': " + (format "%S" lpr-switches))) + t] + ("Pretty-Print Paper Size" + ["Letter" + (setq ps-paper-type 'letter) + :style radio + :selected (eq ps-paper-type 'letter)] + ["Letter-small" + (setq ps-paper-type 'letter-small) + :style radio + :selected (eq ps-paper-type 'letter-small)] + ["Legal" + (setq ps-paper-type 'legal) + :style radio + :selected (eq ps-paper-type 'legal)] + ["Statement" + (setq ps-paper-type 'statement) + :style radio + :selected (eq ps-paper-type 'statement)] + ["Executive" + (setq ps-paper-type 'executive) + :style radio + :selected (eq ps-paper-type 'executive)] + ["Tabloid" + (setq ps-paper-type 'tabloid) + :style radio + :selected (eq ps-paper-type 'tabloid)] + ["Ledger" + (setq ps-paper-type 'ledger) + :style radio + :selected (eq ps-paper-type 'ledger)] + ["A3" + (setq ps-paper-type 'a3) + :style radio + :selected (eq ps-paper-type 'a3)] + ["A4" + (setq ps-paper-type 'a4) + :style radio + :selected (eq ps-paper-type 'a4)] + ["A4small" + (setq ps-paper-type 'a4small) + :style radio + :selected (eq ps-paper-type 'a4small)] + ["B4" + (setq ps-paper-type 'b4) + :style radio + :selected (eq ps-paper-type 'b4)] + ["B5" + (setq ps-paper-type 'b5) + :style radio + :selected (eq ps-paper-type 'b5)] + ) + ["Enable Color Printing" + (progn + (set-face-background 'default "white") + (setq ps-print-color-p t)) + t] + ) + ("\"Other Window\" Location" + ["Always in Same Frame" + (setq get-frame-for-buffer-default-instance-limit nil) + :style radio + :selected (null get-frame-for-buffer-default-instance-limit)] + ["Other Frame (2 Frames Max)" + (setq get-frame-for-buffer-default-instance-limit 2) + :style radio + :selected (eq 2 get-frame-for-buffer-default-instance-limit)] + ["Other Frame (3 Frames Max)" + (setq get-frame-for-buffer-default-instance-limit 3) + :style radio + :selected (eq 3 get-frame-for-buffer-default-instance-limit)] + ["Other Frame (4 Frames Max)" + (setq get-frame-for-buffer-default-instance-limit 4) + :style radio + :selected (eq 4 get-frame-for-buffer-default-instance-limit)] + ["Other Frame (5 Frames Max)" + (setq get-frame-for-buffer-default-instance-limit 5) + :style radio + :selected (eq 5 get-frame-for-buffer-default-instance-limit)] + ["Always Create New Frame" + (setq get-frame-for-buffer-default-instance-limit 0) + :style radio + :selected (eq 0 get-frame-for-buffer-default-instance-limit)] + "-----" + ["Temp Buffers Always in Same Frame" + (setq temp-buffer-show-function 'show-temp-buffer-in-current-frame) + :style radio + :selected (eq temp-buffer-show-function + 'show-temp-buffer-in-current-frame)] + ["Temp Buffers Like Other Buffers" + (setq temp-buffer-show-function nil) + :style radio + :selected (null temp-buffer-show-function)] + "-----" + ["Make current frame gnuserv target" + (setq gnuserv-frame + (if (equal gnuserv-frame (selected-frame)) + 'new + (selected-frame))) + :style radio + :selected (equal gnuserv-frame (selected-frame))] + ) + + "-----" + ("Syntax Highlighting" + ["In This Buffer" (font-lock-mode) + :style toggle :selected font-lock-mode] + ["Automatic" (if (not (featurep 'font-lock)) + (progn + (setq font-lock-auto-fontify t) + (require 'font-lock)) + (setq font-lock-auto-fontify + (not font-lock-auto-fontify))) + :style toggle + :selected (and (featurep 'font-lock) font-lock-auto-fontify)] + "-----" + ["Fonts" (progn (require 'font-lock) + (font-lock-use-default-fonts) + (setq font-lock-use-fonts t + font-lock-use-colors nil) + (font-lock-mode 1)) + :style radio + :selected (and font-lock-mode + font-lock-use-fonts)] + ["Colors" (progn (require 'font-lock) + (font-lock-use-default-colors) + (setq font-lock-use-colors t + font-lock-use-fonts nil) + (font-lock-mode 1)) + :style radio + :selected (and font-lock-mode + font-lock-use-colors)] + "-----" + ["Least" (if (or (and (not (integerp font-lock-maximum-decoration)) + (not (eq t font-lock-maximum-decoration))) + (and (integerp font-lock-maximum-decoration) + (<= font-lock-maximum-decoration 0))) + nil + (setq font-lock-maximum-decoration nil) + (font-lock-recompute-variables)) + :style radio + :active font-lock-mode + :selected (and font-lock-mode + (or (and (not (integerp font-lock-maximum-decoration)) + (not (eq t font-lock-maximum-decoration))) + (and (integerp font-lock-maximum-decoration) + (<= font-lock-maximum-decoration 0))))] + ["More" (if (and (integerp font-lock-maximum-decoration) + (= 1 font-lock-maximum-decoration)) + nil + (setq font-lock-maximum-decoration 1) + (font-lock-recompute-variables)) + :style radio + :active font-lock-mode + :selected (and font-lock-mode + (integerp font-lock-maximum-decoration) + (= 1 font-lock-maximum-decoration))] + ["Even More" (if (and (integerp font-lock-maximum-decoration) + (= 2 font-lock-maximum-decoration)) + nil + (setq font-lock-maximum-decoration 2) + (font-lock-recompute-variables)) + :style radio + :active font-lock-mode + :selected (and font-lock-mode + (integerp font-lock-maximum-decoration) + (= 2 font-lock-maximum-decoration))] + ["Most" (if (or (eq font-lock-maximum-decoration t) + (and (integerp font-lock-maximum-decoration) + (>= font-lock-maximum-decoration 3))) + nil + (setq font-lock-maximum-decoration t) + (font-lock-recompute-variables)) + :style radio + :active font-lock-mode + :selected (and font-lock-mode + (or (eq font-lock-maximum-decoration t) + (and (integerp font-lock-maximum-decoration) + (>= font-lock-maximum-decoration 3))))] + "-----" + ["Lazy" (progn (require 'lazy-shot) + (if (and (boundp 'lazy-shot-mode) lazy-shot-mode) + (progn + (lazy-shot-mode 0) + ;; this shouldn't be necessary so there has to + ;; be a redisplay bug lurking somewhere (or + ;; possibly another event handler bug) + (redraw-modeline) + (remove-hook 'font-lock-mode-hook + 'turn-on-lazy-shot)) + (if font-lock-mode + (progn + (lazy-shot-mode 1) + (redraw-modeline) + (add-hook 'font-lock-mode-hook + 'turn-on-lazy-shot))))) + :active font-lock-mode + :style toggle + :selected (and (boundp 'lazy-shot-mode) lazy-shot-mode)] + ["Caching" (progn (require 'fast-lock) + (if fast-lock-mode + (progn + (fast-lock-mode 0) + ;; this shouldn't be necessary so there has to + ;; be a redisplay bug lurking somewhere (or + ;; possibly another event handler bug) + (redraw-modeline)) + (if font-lock-mode + (progn + (fast-lock-mode 1) + (redraw-modeline))))) + :active font-lock-mode + :style toggle + :selected (and (boundp 'fast-lock-mode) fast-lock-mode)] + ) + ("Paren Highlighting" + ["None" (paren-set-mode -1) + :style radio :selected (not paren-mode)] + ["Blinking Paren" (paren-set-mode 'blink-paren) + :style radio :selected (eq paren-mode 'blink-paren)] + ["Steady Paren" (paren-set-mode 'paren) + :style radio :selected (eq paren-mode 'paren)] + ["Expression" (paren-set-mode 'sexp) + :style radio :selected (eq paren-mode 'sexp)] +;;; ["Nested Shading" (paren-set-mode 'nested) +;;; :style radio :selected (eq paren-mode 'nested)] + ) + "-----" + ("Frame Appearance" + ,@(if (featurep 'scrollbar) + '(["Scrollbars" (if (= (specifier-instance scrollbar-width) 0) + (progn + (set-specifier scrollbar-width 15) + (set-specifier scrollbar-height 15)) + (set-specifier scrollbar-width 0) + (set-specifier scrollbar-height 0)) + :style toggle :selected (> (specifier-instance scrollbar-width) 0)])) + ["3D Modeline" + (progn + (if (zerop (specifier-instance modeline-shadow-thickness)) + (set-specifier modeline-shadow-thickness 2) + (set-specifier modeline-shadow-thickness 0)) + (redraw-modeline t)) + :style toggle :selected + (let ((thickness + (specifier-instance modeline-shadow-thickness))) + (and (integerp thickness) + (> thickness 0)))] + ["Truncate Lines" (progn + (setq truncate-lines (not truncate-lines)) + (setq-default truncate-lines truncate-lines)) + :style toggle :selected truncate-lines] + ["Bar Cursor" (progn + (setq bar-cursor + (if (not bar-cursor) 2 nil)) + (force-cursor-redisplay)) + :style toggle :selected bar-cursor] + ["Blinking Cursor" (blink-cursor-mode) + :style toggle + :selected (and (boundp 'blink-cursor-mode) blink-cursor-mode)] + ["Frame-Local Font Menu" (setq font-menu-this-frame-only-p + (not font-menu-this-frame-only-p)) + :style toggle :selected font-menu-this-frame-only-p] +; ["Line Numbers" (line-number-mode nil) +; :style toggle :selected line-number-mode] + ) + ("Menubar Appearance" + ["Buffers Menu Length..." + (progn + (setq buffers-menu-max-size + (read-number + "Enter number of buffers to display (or 0 for unlimited): ")) + (if (eq buffers-menu-max-size 0) (setq buffers-menu-max-size nil))) + t] + ["Multi-Operation Buffers Sub-Menus" + (setq complex-buffers-menu-p + (not complex-buffers-menu-p)) + :style toggle :selected complex-buffers-menu-p] + ("Buffers Menu Sorting" + ["Most Recently Used" + (progn + (setq buffers-menu-sort-function nil) + (setq buffers-menu-grouping-function nil)) + :style radio + :selected (null buffers-menu-sort-function)] + ["Alphabetically" + (progn + (setq buffers-menu-sort-function + 'sort-buffers-menu-alphabetically) + (setq buffers-menu-grouping-function nil)) + :style radio + :selected (eq 'sort-buffers-menu-alphabetically + buffers-menu-sort-function)] + ["By Major Mode, Then Alphabetically" + (progn + (setq buffers-menu-sort-function + 'sort-buffers-menu-by-mode-then-alphabetically) + (setq buffers-menu-grouping-function + 'group-buffers-menu-by-mode-then-alphabetically)) + :style radio + :selected (eq 'sort-buffers-menu-by-mode-then-alphabetically + buffers-menu-sort-function)]) + ["Submenus for Buffer Groups" + (setq buffers-menu-submenus-for-groups-p + (not buffers-menu-submenus-for-groups-p)) + :style toggle + :selected buffers-menu-submenus-for-groups-p + :active (not (null buffers-menu-grouping-function))] + "---" + ["Ignore Scaled Fonts" (setq font-menu-ignore-scaled-fonts + (not font-menu-ignore-scaled-fonts)) + :style toggle :selected font-menu-ignore-scaled-fonts] + ) + ,@(if (featurep 'toolbar) + '(("Toolbar Appearance" + ["Visible" (set-specifier default-toolbar-visible-p + (not (specifier-instance + default-toolbar-visible-p))) + :style toggle + :selected (specifier-instance default-toolbar-visible-p)] + ["Captioned" (set-specifier toolbar-buttons-captioned-p + (not (specifier-instance + toolbar-buttons-captioned-p))) + :style toggle + :selected + (specifier-instance toolbar-buttons-captioned-p)] + ("Default Location" + ["Top" (set-default-toolbar-position 'top) + :style radio :selected (eq (default-toolbar-position) 'top)] + ["Bottom" (set-default-toolbar-position 'bottom) + :style radio :selected (eq (default-toolbar-position) 'bottom)] + ["Left" (set-default-toolbar-position 'left) + :style radio :selected (eq (default-toolbar-position) 'left)] + ["Right" (set-default-toolbar-position 'right) + :style radio :selected (eq (default-toolbar-position) 'right)] + ) + ))) + ("Mouse" + ["Avoid-Text" + (if (equal (device-type) 'x) + (if mouse-avoidance-mode + (mouse-avoidance-mode 'none) + (mouse-avoidance-mode 'banish)) + (beep) + (message "This option requires a window system.")) + :style toggle :selected (and mouse-avoidance-mode window-system)] + ["strokes-mode" + (if (equal (device-type) 'x) + (strokes-mode) + (beep) + (message "This option requires a window system.")) + :style toggle :selected (and strokes-mode window-system)]) + ("Open URLs With" + ["Emacs-W3" (setq browse-url-browser-function 'browse-url-w3) + :style radio + :selected (eq browse-url-browser-function 'browse-url-w3)] + ["Netscape" (setq browse-url-browser-function 'browse-url-netscape) + :style radio + :selected (eq browse-url-browser-function 'browse-url-netscape)] + ["Mosaic" (setq browse-url-browser-function 'browse-url-mosaic) + :style radio + :selected (eq browse-url-browser-function 'browse-url-mosaic)] + ["Mosaic (CCI)" (setq browse-url-browser-function 'browse-url-cci) + :style radio + :selected (eq browse-url-browser-function 'browse-url-iximosaic)] + ["IXI Mosaic" (setq browse-url-browser-function 'browse-url-iximosaic) + :style radio + :selected (eq browse-url-browser-function 'browse-url-iximosaic)] + ["Lynx (xterm)" (setq browse-url-browser-function 'browse-url-lynx-xterm) + :style radio + :selected (eq browse-url-browser-function 'browse-url-lynx-xterm)] + ["Lynx (xemacs)" (setq browse-url-browser-function 'browse-url-lynx-emacs) + :style radio + :selected (eq browse-url-browser-function 'browse-url-lynx-emacs)] + ["Grail" (setq browse-url-browser-function 'browse-url-grail) + :style radio + :selected (eq browse-url-browser-function 'browse-url-grail)] + ) + "-----" + ["Browse Faces..." edit-faces t] + ("Font" :filter font-menu-family-constructor) + ("Size" :filter font-menu-size-constructor) + ("Weight" :filter font-menu-weight-constructor) + "-----" + ["Save Options" save-options-menu-settings t] + ) + + ("Buffers" + :filter buffers-menu-filter + ["List All Buffers" list-buffers t] + "--" + ) + + ("Tools" + ["Grep..." grep t] + ["Compile..." compile t] + ["Shell" shell t] + ["Shell Command..." shell-command t] + ["Shell Command on Region..." shell-command-on-region (region-exists-p)] + ["Debug (GDB)..." gdb t] + ["Debug (DBX)..." dbx t] + "-----" + ["OO-Browser..." oobr t] + ("Tags" + ["Find Tag..." find-tag t] + ["Find Other Window..." find-tag-other-window t] + ["Next Tag..." (find-tag nil) t] + ["Next Other Window..." (find-tag-other-window nil) t] + ["Next File" next-file t] + "-----" + ["Tags Search..." tags-search t] + ["Tags Replace..." tags-query-replace t] + ["Continue Search/Replace" tags-loop-continue t] + "-----" + ["Pop stack" pop-tag-mark t] + ["Apropos..." tags-apropos t] + "-----" + ["Set Tags Table File..." visit-tags-table t] + )) + + nil ; the partition: menus after this are flushright + + ("Help" + ["About XEmacs..." about-xemacs t] + ("Basics" + ["Tutorial" help-with-tutorial t] + ["News" view-emacs-news t] + ["Packages" finder-by-keyword t] + ["Splash" xemacs-splash-buffer t]) + "-----" + ("XEmacs FAQ" + ["FAQ (local)" xemacs-local-faq t] + ["FAQ via WWW" xemacs-www-faq t] + ["Home Page" xemacs-www-page t]) + ("Samples" + ["Sample" (find-file + (expand-file-name "sample.emacs" + data-directory)) + t ".emacs"] + ["Sample" (find-file + (expand-file-name "sample.Xdefaults" + data-directory)) + t ".Xdefaults"] + ["Sample" (find-file + (expand-file-name "enriched.doc" + data-directory)) + t "enriched"]) + "-----" + ("Lookup in Info" + ["Key Binding..." Info-goto-emacs-key-command-node t] + ["Command..." Info-goto-emacs-command-node t] + ["Function..." Info-elisp-ref t] + ["Topic..." Info-query t]) + ("Manuals" + ["Info" info t] + ["Unix Manual..." manual-entry t]) + ("Commands & Keys" + ["Mode" describe-mode t] + ["Apropos..." hyper-apropos t] + ["Apropos Docs..." apropos-documentation t] + "-----" + ["Key..." describe-key t] + ["Bindings" describe-bindings t] + ["Mouse Bindings" describe-pointer t] + ["Recent Keys" view-lossage t] + "-----" + ["Function..." describe-function t] + ["Variable..." describe-variable t] + ["Locate Command..." where-is t]) + "-----" + ["Recent Messages" view-lossage t] + ("Misc" + ["No Warranty" describe-no-warranty t] + ["XEmacs License" describe-copying t] + ["The Latest Version" describe-distribution t]) + ["Submit Bug Report" send-pr t] + ) + ))) + + +(defun maybe-add-init-button () + "Don't call this. +Adds `Load .emacs' button to menubar when starting up with -q." + ;; by Stig@hackvan.com + (cond + (init-file-user nil) + ((file-exists-p (cond + ((eq system-type 'ms-dos) + (concat "~" (user-login-name) "/_emacs")) + ((eq system-type 'vax-vms) + "sys$login:.emacs") + (t + (concat "~" (user-login-name) "/.emacs")))) + (add-menu-button nil + ["Load .emacs" + (progn (delete-menu-item '("Load .emacs")) + (load-user-init-file (user-login-name))) + t] + "Help")) + (t nil))) + +(add-hook 'before-init-hook 'maybe-add-init-button) + + +;;; The File and Edit menus + +(defvar put-buffer-names-in-file-menu t) + +;; The sensitivity part of this function could be done by just adding forms +;; to evaluate to the menu items themselves; that would be marginally less +;; efficient but not perceptibly so (I think). But in order to change the +;; names of the Undo menu item and the various things on the File menu item, +;; we need to use a hook. + +(defun file-menu-filter (menu-items) + "Incrementally update the file menu. +This function changes the arguments and sensitivity of these File menu items: + + Delete Buffer has the name of the current buffer appended to it. + Print Buffer has the name of the current buffer appended to it. + Pretty-Print Buffer + has the name of the current buffer appended to it. + Save has the name of the current buffer appended to it, and is + sensitive only when the current buffer is modified. + Revert Buffer has the name of the current buffer appended to it, and is + sensitive only when the current buffer has a file. + Delete Frame sensitive only when there is more than one frame. + +The name of the current buffer is only appended to the menu items if +`put-buffer-names-in-file-menu' is non-nil. This behavior is the default." + (let* ((bufname (buffer-name)) + (result menu-items) ; save pointer to start of menu. + name + item) + ;; the contents of the menu items in the file menu are destructively + ;; modified so that there is as little consing as possible. This is okay. + ;; As soon as the result is returned, it is converted to widget_values + ;; inside lwlib and the lisp menu-items can be safely modified again. + (while (setq item (pop menu-items)) + (if (vectorp item) + (progn + (setq name (aref item 0)) + (and put-buffer-names-in-file-menu + (member name '("Save" "Revert Buffer" "Print Buffer" + "Pretty-Print Buffer" "Delete Buffer")) + (>= (length item) 4) + (aset item 3 bufname)) + (and (string= "Save" name) + (aset item 2 (buffer-modified-p))) + (and (string= "Revert Buffer" name) + (aset item 2 (not (not (or buffer-file-name + revert-buffer-function))))) + (and (string= "Delete Frame" name) + (aset item 2 (not (eq (next-frame (selected-frame) + 'nomini 'window-system) + (selected-frame))))) + ))) + result)) + +(defun edit-menu-filter (menu-items) + "For use as an incremental menu construction filter. +This function changes the sensitivity of these Edit menu items: + + Cut sensitive only when emacs owns the primary X Selection. + Copy sensitive only when emacs owns the primary X Selection. + Clear sensitive only when emacs owns the primary X Selection. + Paste sensitive only when there is an owner for the X Clipboard Selection. + Undo sensitive only when there is undo information. + While in the midst of an undo, this is changed to \"Undo More\"." + (let* (item + name + (result menu-items) ; save pointer to head of list + (x-dev (eq 'x (device-type (selected-device)))) + (emacs-owns-selection-p (and x-dev (x-selection-owner-p))) + (clipboard-exists-p (and x-dev (x-selection-exists-p 'CLIPBOARD))) +;;; undo-available undoing-more +;;; (undo-info-available (not (null (and (not (eq t buffer-undo-list)) +;;; (if (eq last-command 'undo) +;;; (setq undoing-more +;;; (and (boundp 'pending-undo-list) +;;; pending-undo-list) +;;; buffer-undo-list)))))) + undo-name undo-state + ) + ;; As with file-menu-filter, menu-items are destructively modified. + ;; This is OK. + (while (setq item (pop menu-items)) + (if (vectorp item) + (progn + (setq name (aref item 0)) + (and (member name '("Cut" "Copy" "Clear")) + (aset item 2 emacs-owns-selection-p)) + (and (string= name "Paste") + (aset item 2 clipboard-exists-p)) + (and (member name '("Undo" "Undo More")) + (progn + ;; we could also do this with the third field of the item. + (if (eq last-command 'undo) + (setq undo-name "Undo More" + undo-state (not (null (and (boundp 'pending-undo-list) + pending-undo-list)))) + (setq undo-name "Undo" + undo-state (and (not (eq buffer-undo-list t)) + (not (null + (or buffer-undo-list + (and (boundp 'pending-undo-list) + pending-undo-list))))))) + (if buffer-read-only (setq undo-state nil)) + (aset item 0 undo-name) + (aset item 2 undo-state) + )) + ))) + result)) + + +;;; The Bookmarks menu + +(defun bookmark-menu-filter (menu-items) + "*Build the bookmark jump submenu dynamically from all defined bookmarks." + (if (bookmark-all-names) + (mapcar + #'(lambda (bmk) + (vector bmk `(bookmark-jump ',bmk) t)) (bookmark-all-names)) + '(["No Bookmarks Set" nil nil]))) + +(defun bookmark-delete-filter (menu-items) + "*Build the bookmark delete submenu dynamically from all defined bookmarks." + (if (bookmark-all-names) + (mapcar + #'(lambda (bmk) + (vector bmk `(bookmark-delete ',bmk) t)) (bookmark-all-names)) + '(["No Bookmarks Set" nil nil]))) + +;;; The Buffers menu + +(defgroup buffers-menu nil + "Customization of `Buffers' menu." + :group 'menu) + +(defcustom buffers-menu-max-size 25 + "*Maximum number of entries which may appear on the \"Buffers\" menu. +If this is 10, then only the ten most-recently-selected buffers will be +shown. If this is nil, then all buffers will be shown. Setting this to +a large number or nil will slow down menu responsiveness." + :type '(choice (const :tag "Show all" nil) + (integer 10)) + :group 'buffers-menu) + +(defcustom complex-buffers-menu-p nil + "*If non-nil, the buffers menu will contain several commands. +Commands will be presented as submenus of each buffer line. If this +is false, then there will be only one command: select that buffer." + :type 'boolean + :group 'buffers-menu) + +(defcustom buffers-menu-submenus-for-groups-p nil + "*If non-nil, the buffers menu will contain one submenu per group of buffers. +The grouping function is specified in `buffers-menu-grouping-function'. +If this is an integer, do not build submenus if the number of buffers +is not larger than this value." + :type '(choice (const :tag "No Subgroups" nil) + (integer :tag "Max. submenus" 10) + (sexp :format "%t\n" :tag "Allow Subgroups")) + :group 'buffers-menu) + +(defcustom buffers-menu-switch-to-buffer-function 'switch-to-buffer + "*The function to call to select a buffer from the buffers menu. +`switch-to-buffer' is a good choice, as is `pop-to-buffer'." + :type '(radio (function-item switch-to-buffer) + (function-item pop-to-buffer) + (function :tag "Other")) + :group 'buffers-menu) + +(defcustom buffers-menu-omit-function 'buffers-menu-omit-invisible-buffers + "*If non-nil, a function specifying the buffers to omit from the buffers menu. +This is passed a buffer and should return non-nil if the buffer should be +omitted. The default value `buffers-menu-omit-invisible-buffers' omits +buffers that are normally considered \"invisible\" (those whose name +begins with a space)." + :type '(choice (const :tag "None" nil) + function) + :group 'buffers-menu) + +(defcustom buffers-menu-format-buffer-line-function 'format-buffers-menu-line + "*The function to call to return a string to represent a buffer in the +buffers menu. The function is passed a buffer and should return a string. +The default value `format-buffers-menu-line' just returns the name of +the buffer. Also check out `slow-format-buffers-menu-line' which +returns a whole bunch of info about a buffer." + :type 'function + :group 'buffers-menu) + +(defcustom buffers-menu-sort-function + 'sort-buffers-menu-by-mode-then-alphabetically + "*If non-nil, a function to sort the list of buffers in the buffers menu. +It will be passed two arguments (two buffers to compare) and should return +T if the first is \"less\" than the second. One possible value is +`sort-buffers-menu-alphabetically'; another is +`sort-buffers-menu-by-mode-then-alphabetically'." + :type '(choice (const :tag "None" nil) + function) + :group 'buffers-menu) + +(defcustom buffers-menu-grouping-function + 'group-buffers-menu-by-mode-then-alphabetically + "*If non-nil, a function to group buffers in the buffers menu together. +It will be passed two arguments, successive members of the sorted buffers +list after being passed through `buffers-menu-sort-function'. It should +return non-nil if the second buffer begins a new group. The return value +should be the name of the old group, which may be used in hierarchical +buffers menus. The last invocation of the function contains nil as the +second argument, so that the name of the last group can be determined. + +The sensible values of this function are dependent on the value specified +for `buffers-menu-sort-function'." + :type '(choice (const :tag "None" nil) + function) + :group 'buffers-menu) + +(defun buffers-menu-omit-invisible-buffers (buf) + "For use as a value of `buffers-menu-omit-function'. +Omits normally invisible buffers (those whose name begins with a space)." + (not (null (string-match "\\` " (buffer-name buf))))) + +(defun sort-buffers-menu-alphabetically (buf1 buf2) + "For use as a value of `buffers-menu-sort-function'. +Sorts the buffers in alphabetical order by name, but puts buffers beginning +with a star at the end of the list." + (let* ((nam1 (buffer-name buf1)) + (nam2 (buffer-name buf2)) + (star1p (not (null (string-match "\\`*" nam1)))) + (star2p (not (null (string-match "\\`*" nam2))))) + (if (not (eq star1p star2p)) + (not star1p) + (string-lessp nam1 nam2)))) + +(defun sort-buffers-menu-by-mode-then-alphabetically (buf1 buf2) + "For use as a value of `buffers-menu-sort-function'. +Sorts first by major mode and then alphabetically by name, but puts buffers +beginning with a star at the end of the list." + (let* ((nam1 (buffer-name buf1)) + (nam2 (buffer-name buf2)) + (star1p (not (null (string-match "\\`*" nam1)))) + (star2p (not (null (string-match "\\`*" nam2)))) + (mode1 (symbol-value-in-buffer 'major-mode buf1)) + (mode2 (symbol-value-in-buffer 'major-mode buf2))) + (cond ((not (eq star1p star2p)) (not star1p)) + ((and star1p star2p (string-lessp nam1 nam2))) + ((string-lessp mode1 mode2) t) + ((string-lessp mode2 mode1) nil) + (t (string-lessp nam1 nam2))))) + +;; this version is too slow on some machines. +(defun slow-format-buffers-menu-line (buffer) + "For use as a value of `buffers-menu-format-buffer-line-function'. +This returns a string containing a bunch of info about the buffer." + (format "%s%s %-19s %6s %-15s %s" + (if (buffer-modified-p buffer) "*" " ") + (if (symbol-value-in-buffer 'buffer-read-only buffer) "%" " ") + (buffer-name buffer) + (buffer-size buffer) + (symbol-value-in-buffer 'mode-name buffer) + (or (buffer-file-name buffer) ""))) + +(defun format-buffers-menu-line (buffer) + "For use as a value of `buffers-menu-format-buffer-line-function'. +This just returns the buffer's name." + (buffer-name buffer)) + +(defun group-buffers-menu-by-mode-then-alphabetically (buf1 buf2) + "For use as a value of `buffers-menu-grouping-function'. +This groups buffers by major mode. It only really makes sense if +`buffers-menu-sorting-function' is +`sort-buffers-menu-by-mode-then-alphabetically'." + (cond ((string-match "\\`*" (buffer-name buf1)) + (and (null buf2) "*Misc*")) + ((or (null buf2) + (string-match "\\`*" (buffer-name buf2)) + (not (eq (symbol-value-in-buffer 'major-mode buf1) + (symbol-value-in-buffer 'major-mode buf2)))) + (symbol-value-in-buffer 'mode-name buf1)) + (t nil))) + +(defun buffer-menu-save-buffer (buffer) + (save-excursion + (set-buffer buffer) + (save-buffer))) + +(defun buffer-menu-write-file (buffer) + (save-excursion + (set-buffer buffer) + (write-file (read-file-name + (format "Write %s to file: " + (buffer-name (current-buffer))))))) + +(defsubst build-buffers-menu-internal (buffers) + (let (name line) + (mapcar + #'(lambda (buffer) + (if (eq buffer t) + "---" + (setq line (funcall buffers-menu-format-buffer-line-function + buffer)) + (if complex-buffers-menu-p + (delq nil + (list line + (vector "Switch to Buffer" + (list buffers-menu-switch-to-buffer-function + (setq name (buffer-name buffer))) + t) + (if (eq buffers-menu-switch-to-buffer-function + 'switch-to-buffer) + (vector "Switch to Buffer, Other Frame" + (list 'switch-to-buffer-other-frame + (setq name (buffer-name buffer))) + t) + nil) + (if (and (buffer-modified-p buffer) + (buffer-file-name buffer)) + (vector "Save Buffer" + (list 'buffer-menu-save-buffer name) t) + ["Save Buffer" nil nil] + ) + (vector "Save As..." + (list 'buffer-menu-write-file name) t) + (vector "Delete Buffer" (list 'kill-buffer name) + t))) + ;; ### We don't want buffer names to be translated, + ;; ### so we put the buffer name in the suffix. + ;; ### Also, avoid losing with non-ASCII buffer names. + ;; ### We still lose, however, if complex-buffers-menu-p. --mrb + (vector "" + (list buffers-menu-switch-to-buffer-function + (buffer-name buffer)) + t line)))) + buffers))) + +(defun buffers-menu-filter (menu) + "This is the menu filter for the top-level buffers \"Buffers\" menu. +It dynamically creates a list of buffers to use as the contents of the menu. +Only the most-recently-used few buffers will be listed on the menu, for +efficiency reasons. You can control how many buffers will be shown by +setting `buffers-menu-max-size'. You can control the text of the menu +items by redefining the function `format-buffers-menu-line'." + (let ((buffers (delete-if buffers-menu-omit-function (buffer-list)))) + (and (integerp buffers-menu-max-size) + (> buffers-menu-max-size 1) + (> (length buffers) buffers-menu-max-size) + ;; shorten list of buffers (not with submenus!) + (not (and buffers-menu-grouping-function + buffers-menu-submenus-for-groups-p)) + (setcdr (nthcdr buffers-menu-max-size buffers) nil)) + (if buffers-menu-sort-function + (setq buffers (sort buffers buffers-menu-sort-function))) + (if (and buffers-menu-grouping-function + buffers-menu-submenus-for-groups-p + (or (not (integerp buffers-menu-submenus-for-groups-p)) + (> (length buffers) buffers-menu-submenus-for-groups-p))) + (let (groups groupnames current-group) + (mapl + #'(lambda (sublist) + (let ((groupname (funcall buffers-menu-grouping-function + (car sublist) (cadr sublist)))) + (setq current-group (cons (car sublist) current-group)) + (if groupname + (progn + (setq groups (cons (nreverse current-group) + groups)) + (setq groupnames (cons groupname groupnames)) + (setq current-group nil))))) + buffers) + (setq buffers + (mapcar* + #'(lambda (groupname group) + (cons groupname (build-buffers-menu-internal group))) + (nreverse groupnames) + (nreverse groups)))) + (if buffers-menu-grouping-function + (progn + (setq buffers + (mapcon + #'(lambda (sublist) + (cond ((funcall buffers-menu-grouping-function + (car sublist) (cadr sublist)) + (list (car sublist) t)) + (t (list (car sublist))))) + buffers)) + ;; remove a trailing separator. + (and (>= (length buffers) 2) + (let ((lastcdr (nthcdr (- (length buffers) 2) buffers))) + (if (eq t (cadr lastcdr)) + (setcdr lastcdr nil)))))) + (setq buffers (build-buffers-menu-internal buffers))) + (append menu buffers) + )) + +(defun language-environment-menu-filter (menu) + "This is the menu filter for the \"Language Environment\" submenu." + (mapcar (lambda (env-sym) + `[ ,(capitalize (symbol-name env-sym)) + (set-language-environment ',env-sym) t]) + language-environment-list)) + + +;;; The Options menu + +(defvar options-save-faces nil + "if t, save-options will save all the face information. +Set to nil to avoid this. This is recommended on XEmacs 19.15 +and above as we have a much more powerful (read: working) way +of changing and saving faces via cu-edit-faces.el & custom.el.") + +(defconst options-menu-saved-forms + ;; This is really quite a kludge, but it gets the job done. + ;; + ;; remember that we have to conditionalize on default features + ;; both in the forms to evaluate and in the forms output to + ;; .emacs, in case the .emacs is loaded into an XEmacs with + ;; different features. + (purecopy + '( + ;; Editing Options menu. + ;; put case-fold-search first to defeat a bug in the backquote + ;; processing mechanism. Feh! + case-fold-search + `(setq-default overwrite-mode ,(default-value 'overwrite-mode)) + (if (default-value 'overwrite-mode) + '(overwrite-mode 1)) + `(setq-default case-fold-search ,(default-value 'case-fold-search)) + case-replace + (if (and (boundp 'pending-delete-mode) + pending-delete-mode) + '(pending-delete-mode 1)) + zmacs-regions + mouse-yank-at-point + require-final-newline + next-line-add-newlines + + ;; General Options menu. + teach-extended-commands-p + ;; (#### not actually on Options menu) + teach-extended-commands-timeout + debug-on-error + debug-on-quit + + ;; Printing Options menu. + lpr-switches + ps-print-color-p + ps-paper-type + + ;; Other Window Location + get-frame-for-buffer-default-instance-limit + temp-buffer-show-function + (if gnuserv-frame + '(setq gnuserv-frame (selected-frame))) + + ;; Syntax Highlighting + font-lock-auto-fontify + font-lock-use-fonts + font-lock-use-colors + font-lock-maximum-decoration + font-lock-maximum-size + ;; (#### the next two not on Options menu) + font-lock-mode-enable-list + font-lock-mode-disable-list + ;; #### - this structure is clearly broken. There's no way to ever + ;; un-require font-lock via the menus. --Stig + (if (featurep 'font-lock) + '(require 'font-lock)) + (if (and (boundp 'font-lock-mode-hook) + (memq 'turn-on-fast-lock font-lock-mode-hook)) + '(add-hook 'font-lock-mode-hook 'turn-on-fast-lock) + '(remove-hook 'font-lock-mode-hook 'turn-on-fast-lock)) + (if (and (boundp 'font-lock-mode-hook) + (memq 'turn-on-lazy-shot font-lock-mode-hook)) + '(add-hook 'font-lock-mode-hook 'turn-on-lazy-shot) + '(remove-hook 'font-lock-mode-hook 'turn-on-lazy-shot)) + + ;; Paren Highlighting + (if paren-mode + `(progn (require 'paren) (paren-set-mode ',paren-mode))) + + ;; For specifiers, we only save global settings since the others + ;; will belong to objects which only exist during this session. + + ;; Frame Appearance + (if (featurep 'scrollbar) + `(if (featurep 'scrollbar) + (progn + (add-spec-list-to-specifier + scrollbar-width + ',(specifier-spec-list scrollbar-width 'global)) + (add-spec-list-to-specifier + scrollbar-height + ',(specifier-spec-list scrollbar-height 'global))))) + `(add-spec-list-to-specifier + modeline-shadow-thickness + ',(specifier-spec-list modeline-shadow-thickness 'global)) + `(setq-default truncate-lines ,(default-value 'truncate-lines)) + bar-cursor + (if (and (boundp 'blink-cursor-mode) blink-cursor-mode) + '(blink-cursor-mode t)) + + ;; Menubar Appearance + buffers-menu-max-size + complex-buffers-menu-p + buffers-menu-sort-function + buffers-menu-grouping-function + buffers-menu-submenus-for-groups-p + font-menu-ignore-scaled-fonts + font-menu-this-frame-only-p + + ;; Toolbar Appearance + (if (featurep 'toolbar) + `(if (featurep 'toolbar) + (progn + (set-default-toolbar-position + ',(default-toolbar-position)) + (add-spec-list-to-specifier + default-toolbar-visible-p + ',(specifier-spec-list default-toolbar-visible-p 'global)) + (add-spec-list-to-specifier + toolbar-buttons-captioned-p + ',(specifier-spec-list toolbar-buttons-captioned-p + 'global))))) + + ;; mouse + mouse-avoidance-mode + + ;; Open URLs With + browse-url-browser-function + + ;; Now save all faces. + + ;; Setting this in lisp conflicts with X resources. Bad move. --Stig + ;; (list 'set-face-font ''default (face-font-name 'default)) + ;; (list 'set-face-font ''modeline (face-font-name 'modeline)) + (if options-save-faces + (cons 'progn + (mapcar #'(lambda (face) + `(make-face ',face)) + (save-options-non-customized-face-list)))) + + (if options-save-faces + (cons 'progn + (apply 'nconc + (mapcar + #'(lambda (face) + (delq nil + (mapcar + #'(lambda (property) + (if (specifier-spec-list + (face-property face property)) + `(add-spec-list-to-specifier + (face-property ',face ',property) + ',(save-options-specifier-spec-list + face property)))) + (delq 'display-table + (copy-sequence + built-in-face-specifiers))))) + (save-options-non-customized-face-list))))) + + ;; Mule-specific: + (if (featurep 'mule) + `(if (featurep 'mule) + (set-language-environment ',(current-language-environment)))) + )) + "The variables to save; or forms to evaluate to get forms to write out. +This is used by `save-options-menu-settings' and should mirror the +options listed in the Options menu.") + +(defun save-options-non-customized-face-list () + "This function will return a list of all faces that have not been +'customized'." + (delq nil (mapcar '(lambda (face) + (unless (get face 'saved-face) + face)) + (face-list)))) + +(defun save-options-specifier-spec-list (face property) + (if (not (or (eq property 'font) (eq property 'color))) + (specifier-spec-list (face-property face property) 'global) + (let* ((retlist (specifier-spec-list (face-property face property) + 'global)) + (entry (cdr (car retlist))) + item) + (while entry + (setq item (car entry)) + (if (eq property 'font) + (if (font-instance-p (cdr item)) + (setcdr item (font-instance-name (cdr item)))) + (if (color-instance-p (cdr item)) + (setcdr item (color-instance-name (cdr item))))) + (setq entry (cdr entry))) + retlist))) + +(defvar save-options-init-file nil + "File into which to save forms to load the options file (nil for .emacs). +Normally this is nil, which means save into your .emacs file (the value +of `user-init-file'.") + +(defvar save-options-file ".xemacs-options" + "File to save options into. +This file is loaded from your .emacs file. +If this is a relative filename, it is put into the same directory as your +.emacs file.") + +(defun save-options-menu-settings () + "Saves the current settings of the `Options' menu to your `.emacs' file." + (interactive) + ;; we compute the actual filenames now because x-menubar is loaded + ;; at dump time, when the identity of the user running XEmacs is not known. + (let* ((actual-save-options-init-file + (or save-options-init-file + (and (not (equal user-init-file "")) + user-init-file) + (and (eq system-type 'ms-dos) + (concat "~" (user-login-name) "/_emacs")) + (concat "~" (user-login-name) "/.emacs"))) + (actual-save-options-file + (abbreviate-file-name + (expand-file-name + save-options-file + (file-name-directory actual-save-options-init-file)) + ;; Don't hack-homedir in abbreviate-file-name. This will + ;; cause an incorrect expansion if the save-options variables + ;; have ~ in them. + )) + (init-output-buffer (find-file-noselect + actual-save-options-init-file)) + init-output-marker + (options-output-buffer + (find-file-noselect actual-save-options-file)) + options-output-marker) + + (save-excursion + (set-buffer options-output-buffer) + (erase-buffer) + (setq options-output-marker (point-marker))) + + ;; run with current-buffer unchanged so that variables are evaluated in + ;; the current context, instead of in the context of the ".emacs" buffer + ;; or the ".xemacs-options" buffer. + + ;; first write out .xemacs-options. + + (let ((standard-output options-output-marker)) + (princ ";; -*- Mode: Emacs-Lisp -*-\n\n") + (princ "(setq options-file-xemacs-version '(") + (princ emacs-major-version) + (princ " ") + (princ emacs-minor-version) + (princ "))\n") + (let ((print-readably t) + (print-escape-newlines t)) + (mapcar #'(lambda (var) + (princ " ") + (if (symbolp var) + (prin1 (list 'setq-default var + (let ((val (symbol-value var))) + (if (or (memq val '(t nil)) + (and (not (symbolp val)) + (not (consp val)))) + val + (list 'quote val))))) + (setq var (eval var)) + (cond ((eq (car-safe var) 'progn) + (while (setq var (cdr var)) + (prin1 (car var)) + (princ "\n") + (if (cdr var) (princ " ")) + )) + (var + (prin1 var)))) + (if var (princ "\n"))) + options-menu-saved-forms) + )) + (set-marker options-output-marker nil) + (save-excursion + (set-buffer options-output-buffer) + (save-buffer)) + + ;; then fix .emacs. + + (save-excursion + (set-buffer init-output-buffer) + ;; + ;; Find and delete the previously saved data, and position to write. + ;; + (goto-char (point-min)) + (if (re-search-forward "^;; Options Menu Settings *\n" nil 'move) + (let ((p (match-beginning 0))) + (goto-char p) + (or (re-search-forward + "^;; End of Options Menu Settings *\\(\n\\|\\'\\)" + nil t) + (error "can't find END of saved state in .emacs")) + (delete-region p (match-end 0))) + (goto-char (point-max)) + (insert "\n")) + (setq init-output-marker (point-marker))) + + (let ((standard-output init-output-marker)) + (princ ";; Options Menu Settings\n") + (princ ";; =====================\n") + (princ "(cond\n") + (princ " ((and (string-match \"XEmacs\" emacs-version)\n") + (princ " (boundp 'emacs-major-version)\n") + (princ " (or (and\n") + (princ " (= emacs-major-version 19)\n") + (princ " (>= emacs-minor-version 14))\n") + (princ " (= emacs-major-version 20))\n") + (princ " (fboundp 'load-options-file))\n") + (princ " (load-options-file \"") + (princ actual-save-options-file) + (princ "\")))\n") + (princ ";; ============================\n") + (princ ";; End of Options Menu Settings\n")) + + (set-marker init-output-marker nil) + (save-excursion + (set-buffer init-output-buffer) + (save-buffer)) + )) + + +(set-menubar default-menubar) + + +;;; Popup menus. + +(defconst default-popup-menu + '("XEmacs Commands" + :filter edit-menu-filter + ["Undo" advertised-undo t] + ["Cut" x-kill-primary-selection t] + ["Copy" x-copy-primary-selection t] + ["Paste" x-yank-clipboard-selection t] + ["Clear" x-delete-primary-selection t] + "-----" + ["Select Block" mark-paragraph t] + ["Split Window" (split-window) t] + ["Unsplit Window" delete-other-windows t] + )) + +(defvar global-popup-menu nil + "The global popup menu. This is present in all modes. +See the function `popup-menu' for a description of menu syntax.") + +(defvar mode-popup-menu nil + "The mode-specific popup menu. Automatically buffer local. +This is appended to the default items in `global-popup-menu'. +See the function `popup-menu' for a description of menu syntax.") +(make-variable-buffer-local 'mode-popup-menu) + +;; In an effort to avoid massive menu clutter, this mostly worthless menu is +;; superceded by any local popup menu... +(setq-default mode-popup-menu default-popup-menu) + +(defvar activate-popup-menu-hook nil + "Function or functions run before a mode-specific popup menu is made visible. +These functions are called with no arguments, and should interrogate and +modify the value of `global-popup-menu' or `mode-popup-menu' as desired. +Note: this hook is only run if you use `popup-mode-menu' for activating the +global and mode-specific commands; if you have your own binding for button3, +this hook won't be run.") + +(defun popup-mode-menu () + "Pop up a menu of global and mode-specific commands. +The menu is computed by combining `global-popup-menu' and `mode-popup-menu'." + (interactive "@_") + (run-hooks 'activate-popup-menu-hook) + (popup-menu + (cond ((and global-popup-menu mode-popup-menu) + (check-menu-syntax mode-popup-menu) + (let* ((title (car mode-popup-menu)) + (items (cdr mode-popup-menu)) + filters) + ;; Strip keywords from local menu for attaching them at the top + (while (and items + (symbolp (car items))) + (setq items (append filters (list (car items)))) + (setq items (cdr items))) + ;; If filters contains a keyword already present in + ;; `global-popup-menu' you will probably lose. + (append (list (car global-popup-menu)) + filters + (cdr global-popup-menu) + '("---" "---") + (if popup-menu-titles (list title)) + (if popup-menu-titles '("---" "---")) + items))) + (t + (or mode-popup-menu + global-popup-menu + (error "No menu here.")))))) + +(defun popup-buffer-menu (event) + "Pop up a copy of the Buffers menu (from the menubar) where the mouse is clicked." + (interactive "e") + (let ((window (and (event-over-text-area-p event) (event-window event))) + (bmenu nil)) + (or window + (error "Pointer must be in a normal window")) + (select-window window) + (if current-menubar + (setq bmenu (assoc "Buffers" current-menubar))) + (if (null bmenu) + (setq bmenu (assoc "Buffers" default-menubar))) + (if (null bmenu) + (error "Can't find the Buffers menu")) + (popup-menu bmenu))) + +(defun popup-menubar-menu (event) + "Pop up a copy of menu that also appears in the menubar" + ;; by Stig@hackvan.com + (interactive "e") + (let ((window (and (event-over-text-area-p event) (event-window event))) + popup-menubar) + (or window + (error "Pointer must be in a normal window")) + (select-window window) + (and current-menubar (run-hooks 'activate-menubar-hook)) + ;; ##### Instead of having to copy this just to safely get rid of + ;; any nil what we should really do is fix up the internal menubar + ;; code to just ignore nil if generating a popup menu + (setq popup-menubar (delete nil (copy-sequence (or current-menubar + default-menubar)))) + (popup-menu (cons "Menubar Menu" popup-menubar)) + )) + +(global-set-key 'button3 'popup-mode-menu) +;; shift button3 and shift button2 are reserved for Hyperbole +(global-set-key '(meta control button3) 'popup-buffer-menu) +;; The following command is way too dangerous with Custom. +;; (global-set-key '(meta shift button3) 'popup-menubar-menu) + +;; Here's a test of the cool new menu features (from Stig). + +;(setq mode-popup-menu +; '("Test Popup Menu" +; :filter cdr +; ["this item won't appear because of the menu filter" ding t] +; "--:singleLine" +; "singleLine" +; "--:doubleLine" +; "doubleLine" +; "--:singleDashedLine" +; "singleDashedLine" +; "--:doubleDashedLine" +; "doubleDashedLine" +; "--:noLine" +; "noLine" +; "--:shadowEtchedIn" +; "shadowEtchedIn" +; "--:shadowEtchedOut" +; "shadowEtchedOut" +; "--:shadowDoubleEtchedIn" +; "shadowDoubleEtchedIn" +; "--:shadowDoubleEtchedOut" +; "shadowDoubleEtchedOut" +; "--:shadowEtchedInDash" +; "shadowEtchedInDash" +; "--:shadowEtchedOutDash" +; "shadowEtchedOutDash" +; "--:shadowDoubleEtchedInDash" +; "shadowDoubleEtchedInDash" +; "--:shadowDoubleEtchedOutDash" +; "shadowDoubleEtchedOutDash" +; )) + +(defun xemacs-splash-buffer () + "Redisplay XEmacs splash screen in a buffer." + (interactive) + (let ((buffer (get-buffer-create "*Splash*"))) + (set-buffer buffer) + (erase-buffer buffer) + (startup-splash-frame) + (pop-to-buffer buffer) + (delete-other-windows))) + +(provide 'x-menubar) + +;;; x-menubar.el ends here.
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/x-misc.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,87 @@ +;;; x-misc.el --- miscellaneous X functions. + +;; Copyright (C) 1997 Free Software Foundation, Inc. +;; Copyright (C) 1995 Sun Microsystems. +;; Copyright (C) 1995, 1996 Ben Wing. + +;; Author: Ben Wing <wing@666.com> +;; Maintainer: XEmacs Development Team +;; Keywords: extensions, dumped + +;; 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, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This file is dumped with XEmacs (when X support is compiled in). + +;;; Code: + +(defun x-bogosity-check-resource (name class type) + "Check for a bogus resource specification." + (let ((bogus (x-get-resource + (concat "__no-such-friggin-locale__." name) + (concat "__No-such-friggin-widget__." class) + type 'global nil t))) + (if bogus + (display-warning + 'resource + (format "Bad resource specification encountered: something like + Emacs*%s: %s +You should replace the * with a . in order to get proper behavior when +you use the specifier and/or `set-face-*' functions." name bogus))))) + +(defun x-init-specifier-from-resources (specifier type locale + &rest resource-list) + "Initialize a specifier from the resource database. +LOCALE specifies the locale that is to be initialized and should be +a frame, a device, or 'global. TYPE is the type of the resource and +should be one of 'string, 'boolean, 'integer, or 'natnum. The +remaining args should be conses of names and classes of resources +to be examined. The first resource with a value specified becomes +the spec for SPECIFIER in LOCALE. (However, if SPECIFIER already +has a spec in LOCALE, nothing is done.) Finally, if LOCALE is 'global, +a check is done for bogus resource specifications." + (if (eq locale 'global) + (mapcar #'(lambda (x) + (x-bogosity-check-resource (car x) (cdr x) type)) + resource-list)) + (if (not (specifier-spec-list specifier locale)) + (catch 'done + (while resource-list + (let* ((name (caar resource-list)) + (class (cdar resource-list)) + (resource + (x-get-resource name class type locale nil t))) + (if resource + (progn + (add-spec-to-specifier specifier resource locale) + (throw 'done t)))) + (setq resource-list (cdr resource-list)))))) + +(defun x-get-resource-and-bogosity-check (name class type &optional locale) + (x-bogosity-check-resource name class type) + (x-get-resource name class type locale nil t)) + +;; #### this function is not necessary. +(defun x-get-resource-and-maybe-bogosity-check (name class type &optional + locale) + (if (eq locale 'global) + (x-bogosity-check-resource name class type)) + (x-get-resource name class type locale nil t)) + +;;; x-misc.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/x-mouse.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,179 @@ +;;; x-mouse.el --- Mouse support for X window system. + +;; Copyright (C) 1985, 1992-4, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1995, 1996 Ben Wing. + +;; Maintainer: XEmacs Development Team +;; Keywords: mouse, dumped + +;; 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 synched. + +;;; Commentary: + +;; This file is dumped with XEmacs (when X support is compiled in). + +;;; Code: + +;;(define-key global-map 'button2 'x-set-point-and-insert-selection) +;; This is reserved for use by Hyperbole. +;;(define-key global-map '(shift button2) 'x-mouse-kill) +(define-key global-map '(control button2) 'x-set-point-and-move-selection) + +(defun x-mouse-kill (event) + "Kill the text between the point and mouse and copy it to the clipboard and +to the cut buffer" + (interactive "@e") + (let ((old-point (point))) + (mouse-set-point event) + (let ((s (buffer-substring old-point (point)))) + (x-own-clipboard s) + (x-store-cutbuffer s)) + (kill-region old-point (point)))) + +(defun x-yank-function () + "Insert the current X selection or, if there is none, insert the X cutbuffer. +A mark is pushed, so that the inserted text lies between point and mark." + (push-mark) + (if (region-active-p) + (if (consp zmacs-region-extent) + ;; pirated code from insert-rectangle in rect.el + ;; perhaps that code should be modified to handle a list of extents + ;; as the rectangle to be inserted? + (let ((lines zmacs-region-extent) + (insertcolumn (current-column)) + (first t)) + (push-mark) + (while lines + (or first + (progn + (forward-line 1) + (or (bolp) (insert ?\n)) + (move-to-column insertcolumn t))) + (setq first nil) + (insert (extent-string (car lines))) + (setq lines (cdr lines)))) + (insert (extent-string zmacs-region-extent))) + (x-insert-selection t))) + +(defun x-insert-selection (&optional check-cutbuffer-p move-point-event) + "Insert the current selection into buffer at point." + (interactive "P") + (let ((text (if check-cutbuffer-p + (or (condition-case () (x-get-selection) (error ())) + (x-get-cutbuffer) + (error "No selection or cut buffer available")) + (x-get-selection)))) + (cond (move-point-event + (mouse-set-point move-point-event) + (push-mark (point))) + ((interactive-p) + (push-mark (point)))) + (insert text) + )) + +(make-obsolete 'x-set-point-and-insert-selection 'mouse-yank) +(defun x-set-point-and-insert-selection (event) + "Set point where clicked and insert the primary selection or the cut buffer." + (interactive "e") + (let ((mouse-yank-at-point nil)) + (mouse-yank event))) + +(defun x-set-point-and-move-selection (event) + "Set point where clicked and move the selected text to that location." + (interactive "e") + ;; Don't try to move the selection if x-kill-primary-selection if going + ;; to fail; just let the appropriate error message get issued. (We need + ;; to insert the selection and set point first, or the selection may + ;; get inserted at the wrong place.) + (and (x-selection-owner-p) + primary-selection-extent + (x-insert-selection t event)) + (x-kill-primary-selection)) + +(defun mouse-track-and-copy-to-cutbuffer (event) + "Make a selection like `mouse-track', but also copy it to the cutbuffer." + (interactive "e") + (mouse-track event) + (cond + ((null primary-selection-extent) + nil) + ((consp primary-selection-extent) + (save-excursion + (set-buffer (extent-object (car primary-selection-extent))) + (x-store-cutbuffer + (mapconcat + 'identity + (extract-rectangle + (extent-start-position (car primary-selection-extent)) + (extent-end-position (car (reverse primary-selection-extent)))) + "\n")))) + (t + (save-excursion + (set-buffer (extent-object primary-selection-extent)) + (x-store-cutbuffer + (buffer-substring (extent-start-position primary-selection-extent) + (extent-end-position primary-selection-extent))))))) + + +(defvar x-pointers-initialized nil) + +(defun x-init-pointer-shape (device) + "Initializes the mouse-pointers of the given device from the resource +database." + (if x-pointers-initialized ; only do it when the first device is created + nil + (set-glyph-image text-pointer-glyph + (or (x-get-resource "textPointer" "Cursor" 'string device) + "xterm")) + (set-glyph-image selection-pointer-glyph + (or (x-get-resource "selectionPointer" "Cursor" 'string device) + "top_left_arrow")) + (set-glyph-image nontext-pointer-glyph + (or (x-get-resource "spacePointer" "Cursor" 'string device) + "xterm")) ; was "crosshair" + (set-glyph-image modeline-pointer-glyph + (or (x-get-resource "modeLinePointer" "Cursor" 'string device) + "sb_v_double_arrow")) + (set-glyph-image gc-pointer-glyph + (or (x-get-resource "gcPointer" "Cursor" 'string device) + "watch")) + (when (featurep 'scrollbar) + (set-glyph-image + scrollbar-pointer-glyph + (or (x-get-resource "scrollbarPointer" "Cursor" 'string device) + "top_left_arrow"))) + (set-glyph-image busy-pointer-glyph + (or (x-get-resource "busyPointer" "Cursor" 'string device) + "watch")) + (set-glyph-image toolbar-pointer-glyph + (or (x-get-resource "toolBarPointer" "Cursor" 'string device) + "left_ptr")) + (let ((fg + (x-get-resource "pointerColor" "Foreground" 'string device))) + (and fg + (set-face-foreground 'pointer fg))) + (let ((bg + (x-get-resource "pointerBackground" "Background" 'string device))) + (and bg + (set-face-background 'pointer bg))) + (setq x-pointers-initialized t)) + nil) + +;;; x-mouse.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/x-scrollbar.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,80 @@ +;;; x-scrollbar.el --- scrollbar resourcing and such. + +;; Copyright (C) 1997 Free Software Foundation, Inc. +;; Copyright (C) 1995 Sun Microsystems. +;; Copyright (C) 1995, 1996 Ben Wing. + +;; Author: Ben Wing <wing@666.com> +;; Maintainer: XEmacs Development Team +;; Keywords: extensions, dumped + +;; 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 synched. + +;;; Commentary: + +;; This file is dumped with XEmacs (when X and menubar support is compiled in). + +;;; Code: + +(defun x-init-scrollbar-from-resources (locale) + (x-init-specifier-from-resources + scrollbar-width 'natnum locale + '("scrollBarWidth" . "ScrollBarWidth") + ;; The name strings are wrong, but the scrollbar name is + ;; non-deterministic so it is a poor way to set a resource + ;; for the scrollbar anyhow. + (cond ((featurep 'athena-scrollbars) + '("scrollbar.thickness" . "ScrollBar.Thickness")) + ((featurep 'lucid-scrollbars) + '("scrollbar.width" . "XlwScrollBar.Width")) + ((featurep 'motif-scrollbars) + '("scrollbar.width" . "XmScrollBar.Width")))) + ;; Athena scrollbars accept either 'thickness' or 'width'. + ;; If any of the previous resources succeeded, the following + ;; call does nothing; so there's no harm in doing it all the + ;; time. + (if (featurep 'athena-scrollbars) + (x-init-specifier-from-resources + scrollbar-width 'natnum locale + '("scrollbar.width" . "ScrollBar.Width"))) + + ;; lather, rinse, repeat. + (x-init-specifier-from-resources + scrollbar-height 'natnum locale + '("scrollBarHeight" . "ScrollBarHeight") + ;; The name strings are wrong, but the scrollbar name is + ;; non-deterministic so it is a poor way to set a resource + ;; for the scrollbar anyhow. + (cond ((featurep 'athena-scrollbars) + '("scrollbar.thickness" . "ScrollBar.Thickness")) + ((featurep 'lucid-scrollbars) + '("scrollbar.height" . "XlwScrollBar.Height")) + ((featurep 'motif-scrollbars) + '("scrollbar.height" . "XmScrollBar.Height")))) + ;; Athena scrollbars accept either 'thickness' or 'height'. + ;; If any of the previous resources succeeded, the following + ;; call does nothing; so there's no harm in doing it all the + ;; time. + (if (featurep 'athena-scrollbars) + (x-init-specifier-from-resources + scrollbar-height 'natnum locale + '("scrollbar.height" . "ScrollBar.Height")))) + +;;; x-scrollbar.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/x-select.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,648 @@ +;;; x-select.el --- Lisp interface to X Selections. + +;; Copyright (C) 1990, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1995 Sun Microsystems. + +;; Maintainer: XEmacs Development Team +;; Keywords: extensions, dumped + +;; 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 (select.el). + +;;; Commentary: + +;; This file is dumped with XEmacs (when X support is compiled in). + +;; The selection code requires us to use certain symbols whose names are +;; all upper-case; this may seem tasteless, but it makes there be a 1:1 +;; correspondence between these symbols and X Atoms (which are upcased). + +;;; Code: + +(defvar x-selected-text-type + (if (featurep 'mule) '(COMPOUND_TEXT STRING) 'STRING) + "The type atom used to obtain selections from the X server. +Can be either a valid X selection data type, or a list of such types. +COMPOUND_TEXT and STRING are the most commonly used data types. +If a list is provided, the types are tried in sequence until +there is a successful conversion.") + +(defun x-get-selection (&optional type data-type) + "Return the value of an X Windows selection. +The argument TYPE (default `PRIMARY') says which selection, +and the argument DATA-TYPE (default `STRING', or `COMPOUND_TEXT' under Mule) +says how to convert the data." + (or type (setq type 'PRIMARY)) + (or data-type (setq data-type x-selected-text-type)) + (let ((text + (if (consp data-type) + (condition-case err + (x-get-selection-internal type (car data-type)) + (selection-conversion-error + (if (cdr data-type) + (x-get-selection type (cdr data-type)) + (signal (car err) (cdr err))))) + (x-get-selection-internal type data-type)))) + (when (and (consp text) (symbolp (car text))) + (setq text (cdr text))) + (when (not (stringp text)) + (error "Selection is not a string: %S" text)) + text)) + +(defun x-get-secondary-selection () + "Return text selected from some X window." + (x-get-selection 'SECONDARY)) + +(defun x-get-clipboard () + "Return text pasted to the clipboard." + (x-get-selection 'CLIPBOARD)) + + +(defvar primary-selection-extent nil + "The extent of the primary selection; don't use this.") + +(defvar secondary-selection-extent nil + "The extent of the secondary selection; don't use this.") + + +(defun x-select-make-extent-for-selection (selection previous-extent) + ;; Given a selection, this makes an extent in the buffer which holds that + ;; selection, for highlighting purposes. If the selection isn't associated + ;; with a buffer, this does nothing. + (let ((buffer nil) + (valid (and (extentp previous-extent) + (extent-object previous-extent) + (buffer-live-p (extent-object previous-extent)))) + start end) + (cond ((stringp selection) + ;; if we're selecting a string, lose the previous extent used + ;; to highlight the selection. + (setq valid nil)) + ((consp selection) + (setq start (min (car selection) (cdr selection)) + end (max (car selection) (cdr selection)) + valid (and valid + (eq (marker-buffer (car selection)) + (extent-object previous-extent))) + buffer (marker-buffer (car selection)))) + ((extentp selection) + (setq start (extent-start-position selection) + end (extent-end-position selection) + valid (and valid + (eq (extent-object selection) + (extent-object previous-extent))) + buffer (extent-object selection))) + (t + (signal 'error (list "invalid selection" selection)))) + + (if valid + nil + (condition-case () + (if (listp previous-extent) + (mapcar 'delete-extent previous-extent) + (delete-extent previous-extent)) + (error nil))) + + (if (not buffer) + ;; string case + nil + ;; normal case + (if valid + (set-extent-endpoints previous-extent start end) + (setq previous-extent (make-extent start end buffer)) + + ;; Make the extent be closed on the right, which means that if + ;; characters are inserted exactly at the end of the extent, the + ;; extent will grow to cover them. This is important for shell + ;; buffers - suppose one makes a selection, and one end is at + ;; point-max. If the shell produces output, that marker will remain + ;; at point-max (its position will increase). So it's important that + ;; the extent exhibit the same behavior, lest the region covered by + ;; the extent (the visual indication), and the region between point + ;; and mark (the actual selection value) become different! + (set-extent-property previous-extent 'end-open nil) + + (cond + (mouse-track-rectangle-p + (setq previous-extent (list previous-extent)) + (default-mouse-track-next-move-rect start end previous-extent) + )) + previous-extent)))) + +;; FSFmacs calls this `x-set-selection', and reverses the +;; arguments (duh ...). This order is more logical. +(defun x-own-selection (data &optional type) + "Make an X Windows selection of type TYPE and value DATA. +The argument TYPE (default `PRIMARY') says which selection, +and DATA specifies the contents. DATA may be a string, +a symbol, an integer (or a cons of two integers or list of two integers). + +The selection may also be a cons of two markers pointing to the same buffer, +or an overlay. In these cases, the selection is considered to be the text +between the markers *at whatever time the selection is examined*. +Thus, editing done in the buffer after you specify the selection +can alter the effective value of the selection. + +The data may also be a vector of valid non-vector selection values. + +Interactively, the text of the region is used as the selection value." + (interactive (if (not current-prefix-arg) + (list (read-string "Store text for pasting: ")) + (list (substring (region-beginning) (region-end))))) + ;FSFmacs huh?? It says: + ;; "This is for temporary compatibility with pre-release Emacs 19." + ;(if (stringp type) + ; (setq type (intern type))) + (or (x-valid-simple-selection-p data) + (and (vectorp data) + (let ((valid t) + (i (1- (length data)))) + (while (>= i 0) + (or (x-valid-simple-selection-p (aref data i)) + (setq valid nil)) + (setq i (1- i))) + valid)) + (signal 'error (list "invalid selection" data))) + (or type (setq type 'PRIMARY)) + (if data + (x-own-selection-internal type data) + (x-disown-selection-internal type)) + (cond ((eq type 'PRIMARY) + (setq primary-selection-extent + (x-select-make-extent-for-selection + data primary-selection-extent))) + ((eq type 'SECONDARY) + (setq secondary-selection-extent + (x-select-make-extent-for-selection + data secondary-selection-extent)))) + (setq zmacs-region-stays t) + data) + +(defun x-valid-simple-selection-p (data) + (or (stringp data) + ;FSFmacs huh?? (symbolp data) + (integerp data) + (and (consp data) + (integerp (car data)) + (or (integerp (cdr data)) + (and (consp (cdr data)) + (integerp (car (cdr data)))))) + (extentp data) + (and (consp data) + (markerp (car data)) + (markerp (cdr data)) + (marker-buffer (car data)) + (marker-buffer (cdr data)) + (eq (marker-buffer (car data)) + (marker-buffer (cdr data))) + (buffer-live-p (marker-buffer (car data))) + (buffer-live-p (marker-buffer (cdr data)))))) + +(defun x-own-secondary-selection (selection &optional type) + "Make a secondary X Selection of the given argument. The argument may be a +string or a cons of two markers (in which case the selection is considered to +be the text between those markers)." + (interactive (if (not current-prefix-arg) + (list (read-string "Store text for pasting: ")) + (list (cons ;; these need not be ordered. + (copy-marker (point-marker)) + (copy-marker (mark-marker)))))) + (x-own-selection selection 'SECONDARY)) + + +(defun x-own-clipboard (string) + "Paste the given string to the X Clipboard." + (x-own-selection string 'CLIPBOARD)) + + +(defun x-disown-selection (&optional secondary-p) + "Assuming we own the selection, disown it. With an argument, discard the +secondary selection instead of the primary selection." + (x-disown-selection-internal (if secondary-p 'SECONDARY 'PRIMARY))) + +(defun x-dehilight-selection (selection) + "for use as a value of `x-lost-selection-hooks'." + (cond ((eq selection 'PRIMARY) + (if primary-selection-extent + (let ((inhibit-quit t)) + (if (consp primary-selection-extent) + (mapcar 'delete-extent primary-selection-extent) + (delete-extent primary-selection-extent)) + (setq primary-selection-extent nil))) + (if zmacs-regions (zmacs-deactivate-region))) + ((eq selection 'SECONDARY) + (if secondary-selection-extent + (let ((inhibit-quit t)) + (if (consp secondary-selection-extent) + (mapcar 'delete-extent secondary-selection-extent) + (delete-extent secondary-selection-extent)) + (setq secondary-selection-extent nil))))) + nil) + +(setq x-lost-selection-hooks 'x-dehilight-selection) + +(defun x-notice-selection-requests (selection type successful) + "for possible use as the value of x-sent-selection-hooks." + (if (not successful) + (message "Selection request failed to convert %s to %s" + selection type) + (message "Sent selection %s as %s" selection type))) + +(defun x-notice-selection-failures (selection type successful) + "for possible use as the value of x-sent-selection-hooks." + (or successful + (message "Selection request failed to convert %s to %s" + selection type))) + +;(setq x-sent-selection-hooks 'x-notice-selection-requests) +;(setq x-sent-selection-hooks 'x-notice-selection-failures) + + +;;; Selections in killed buffers +;;; this function is called by kill-buffer as if it were on the +;;; kill-buffer-hook (though it isn't really). + +(defun xselect-kill-buffer-hook () + ;; Probably the right thing is to write a C function to return a list + ;; of the selections which emacs owns, since it could conceivably own + ;; a user-defined selection type that we've never heard of. + (xselect-kill-buffer-hook-1 'PRIMARY) + (xselect-kill-buffer-hook-1 'SECONDARY) + (xselect-kill-buffer-hook-1 'CLIPBOARD)) + +(defun xselect-kill-buffer-hook-1 (selection) + (let (value) + (if (and (x-selection-owner-p selection) + (setq value (x-get-selection-internal selection '_EMACS_INTERNAL)) + ;; The _EMACS_INTERNAL selection type has a converter registered + ;; for it that does no translation. This only works if emacs is + ;; requesting the selection from itself. We could have done this + ;; by writing a C function to return the raw selection data, and + ;; that might be the right way to do this, but this was easy. + (or (and (consp value) + (markerp (car value)) + (eq (current-buffer) (marker-buffer (car value)))) + (and (extent-live-p value) + (eq (current-buffer) (extent-object value))) + (and (extentp value) (not (extent-live-p value))))) + (x-disown-selection-internal selection)))) + + +;;; Cut Buffer support + +;;; FSF name x-get-cut-buffer +(defun x-get-cutbuffer (&optional which-one) + "Returns the value of one of the 8 X server cut buffers. Optional arg +WHICH-ONE should be a number from 0 to 7, defaulting to 0. +Cut buffers are considered obsolete\; you should use selections instead. +This function does nothing if support for cut buffers was not compiled +into Emacs." + (and (fboundp 'x-get-cutbuffer-internal) + (x-get-cutbuffer-internal + (if which-one + (aref [CUT_BUFFER0 CUT_BUFFER1 CUT_BUFFER2 CUT_BUFFER3 + CUT_BUFFER4 CUT_BUFFER5 CUT_BUFFER6 CUT_BUFFER7] + which-one) + 'CUT_BUFFER0)))) + +;;; FSF name x-set-cut-buffer +(defun x-store-cutbuffer (string &optional push) + "Store STRING into the X server's primary cut buffer. +If PUSH is non-nil, also rotate the cut buffers: +this means the previous value of the primary cut buffer moves the second +cut buffer, and the second to the third, and so on (there are 8 buffers.) +Cut buffers are considered obsolete; you should use selections instead. +This function does nothing if support for cut buffers was not compiled +into Emacs." + (and (fboundp 'x-store-cutbuffer-internal) + (progn + ;; Check the data type of STRING. + (substring string 0 0) + (if push + (x-rotate-cutbuffers-internal 1)) + (x-store-cutbuffer-internal 'CUT_BUFFER0 string)))) + + +;;; Random utility functions + +(defun x-cut-copy-clear-internal (mode) + (or (memq mode '(cut copy clear)) (error "unkown mode %S" mode)) + (or (x-selection-owner-p) + (error "emacs does not own the primary selection")) + (setq last-command nil) + (or primary-selection-extent + (error "the primary selection is not an extent?")) + (save-excursion + (let (rect-p b s e) + (cond + ((consp primary-selection-extent) + (setq rect-p t + b (extent-object (car primary-selection-extent)) + s (extent-start-position (car primary-selection-extent)) + e (extent-end-position (car (reverse primary-selection-extent))))) + (t + (setq rect-p nil + b (extent-object primary-selection-extent) + s (extent-start-position primary-selection-extent) + e (extent-end-position primary-selection-extent)))) + (set-buffer b) + (cond ((memq mode '(cut copy)) + (if rect-p + (progn + ;; 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"))) + (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 + ;; some other way, but owning the clipboard twice in that case + ;; wouldn't actually hurt anything. + (or (and (consp kill-hooks) (memq 'x-own-clipboard kill-hooks)) + (x-own-clipboard (car kill-ring))))) + (cond ((memq mode '(cut clear)) + (if rect-p + (delete-rectangle s e) + (delete-region s e)))) + (x-disown-selection nil) + ))) + +(defun x-copy-primary-selection () + "Copy the selection to the Clipboard and the kill ring." + (interactive) + (x-cut-copy-clear-internal 'copy)) + +(defun x-kill-primary-selection () + "Copy the selection to the Clipboard and the kill ring, then delete it." + (interactive "*") + (x-cut-copy-clear-internal 'cut)) + +(defun x-delete-primary-selection () + "Delete the selection without copying it to the Clipboard or the kill ring." + (interactive "*") + (x-cut-copy-clear-internal 'clear)) + +(defun x-yank-clipboard-selection () + "Insert the current Clipboard selection at point." + (interactive "*") + (setq last-command nil) + (setq this-command 'yank) ; so that yank-pop works. + (let ((clip (x-get-clipboard))) + (or clip (error "there is no clipboard selection")) + (push-mark) + (insert clip))) + +;;; Functions to convert the selection into various other selection types. +;;; Every selection type that emacs handles is implemented this way, except +;;; for TIMESTAMP, which is a special case. + +(defun xselect-convert-to-text (selection type value) + (cond ((stringp value) + value) + ((extentp value) + (save-excursion + (set-buffer (extent-object value)) + (save-restriction + (widen) + (buffer-substring (extent-start-position value) + (extent-end-position value))))) + ((and (consp value) + (markerp (car value)) + (markerp (cdr value))) + (or (eq (marker-buffer (car value)) (marker-buffer (cdr value))) + (signal 'error + (list "markers must be in the same buffer" + (car value) (cdr value)))) + (save-excursion + (set-buffer (or (marker-buffer (car value)) + (error "selection is in a killed buffer"))) + (save-restriction + (widen) + (buffer-substring (car value) (cdr value))))) + (t nil))) + +(defun xselect-convert-to-string (selection type value) + (let ((outval (xselect-convert-to-text selection type value))) + ;; force the string to be not in Compound Text format. + (if (stringp outval) + (cons 'STRING outval) + outval))) + +(defun xselect-convert-to-compound-text (selection type value) + ;; converts to compound text automatically + (xselect-convert-to-text selection type value)) + +(defun xselect-convert-to-length (selection type value) + (let ((value + (cond ((stringp value) + (length value)) + ((extentp value) + (extent-length value)) + ((and (consp value) + (markerp (car value)) + (markerp (cdr value))) + (or (eq (marker-buffer (car value)) + (marker-buffer (cdr value))) + (signal 'error + (list "markers must be in the same buffer" + (car value) (cdr value)))) + (abs (- (car value) (cdr value))))))) + (if value ; force it to be in 32-bit format. + (cons (ash value -16) (logand value 65535)) + nil))) + +(defun xselect-convert-to-targets (selection type value) + ;; return a vector of atoms, but remove duplicates first. + (let* ((all (cons 'TIMESTAMP (mapcar 'car selection-converter-alist))) + (rest all)) + (while rest + (cond ((memq (car rest) (cdr rest)) + (setcdr rest (delq (car rest) (cdr rest)))) + ((eq (car (cdr rest)) '_EMACS_INTERNAL) ; shh, it's a secret + (setcdr rest (cdr (cdr rest)))) + (t + (setq rest (cdr rest))))) + (apply 'vector all))) + +(defun xselect-convert-to-delete (selection type value) + (x-disown-selection-internal selection) + ;; A return value of nil means that we do not know how to do this conversion, + ;; and replies with an "error". A return value of NULL means that we have + ;; done the conversion (and any side-effects) but have no value to return. + 'NULL) + +(defun xselect-convert-to-filename (selection type value) + (cond ((extentp value) + (buffer-file-name (or (extent-object value) + (error "selection is in a killed buffer")))) + ((and (consp value) + (markerp (car value)) + (markerp (cdr value))) + (buffer-file-name (or (marker-buffer (car value)) + (error "selection is in a killed buffer")))) + (t nil))) + +(defun xselect-convert-to-charpos (selection type value) + (let (a b tmp) + (cond ((cond ((extentp value) + (setq a (extent-start-position value) + b (extent-end-position value))) + ((and (consp value) + (markerp (car value)) + (markerp (cdr value))) + (setq a (car value) + b (cdr value)))) + (setq a (1- a) b (1- b)) ; zero-based + (if (< b a) (setq tmp a a b b tmp)) + (cons 'SPAN + (vector (cons (ash a -16) (logand a 65535)) + (cons (ash b -16) (logand b 65535)))))))) + +(defun xselect-convert-to-lineno (selection type value) + (let (a b buf tmp) + (cond ((cond ((extentp value) + (setq buf (extent-object value) + a (extent-start-position value) + b (extent-end-position value))) + ((and (consp value) + (markerp (car value)) + (markerp (cdr value))) + (setq a (marker-position (car value)) + b (marker-position (cdr value)) + buf (marker-buffer (car value))))) + (save-excursion + (set-buffer buf) + (save-restriction + (widen) + (goto-char a) + (beginning-of-line) + (setq a (1+ (count-lines 1 (point)))) + (goto-char b) + (beginning-of-line) + (setq b (1+ (count-lines 1 (point)))))) + (if (< b a) (setq tmp a a b b tmp)) + (cons 'SPAN + (vector (cons (ash a -16) (logand a 65535)) + (cons (ash b -16) (logand b 65535)))))))) + +(defun xselect-convert-to-colno (selection type value) + (let (a b buf tmp) + (cond ((cond ((extentp value) + (setq buf (extent-object value) + a (extent-start-position value) + b (extent-end-position value))) + ((and (consp value) + (markerp (car value)) + (markerp (cdr value))) + (setq a (car value) + b (cdr value) + buf (marker-buffer a)))) + (save-excursion + (set-buffer buf) + (goto-char a) + (setq a (current-column)) + (goto-char b) + (setq b (current-column))) + (if (< b a) (setq tmp a a b b tmp)) + (cons 'SPAN + (vector (cons (ash a -16) (logand a 65535)) + (cons (ash b -16) (logand b 65535)))))))) + +(defun xselect-convert-to-sourceloc (selection type value) + (let (a b buf file-name tmp) + (cond ((cond ((extentp value) + (setq buf (or (extent-object value) + (error "selection is in a killed buffer")) + a (extent-start-position value) + b (extent-end-position value) + file-name (buffer-file-name buf))) + ((and (consp value) + (markerp (car value)) + (markerp (cdr value))) + (setq a (marker-position (car value)) + b (marker-position (cdr value)) + buf (or (marker-buffer (car value)) + (error "selection is in a killed buffer")) + file-name (buffer-file-name buf)))) + (save-excursion + (set-buffer buf) + (save-restriction + (widen) + (goto-char a) + (beginning-of-line) + (setq a (1+ (count-lines 1 (point)))) + (goto-char b) + (beginning-of-line) + (setq b (1+ (count-lines 1 (point)))))) + (if (< b a) (setq tmp a a b b tmp)) + (format "%s:%d" file-name a))))) + +(defun xselect-convert-to-os (selection type size) + (symbol-name system-type)) + +(defun xselect-convert-to-host (selection type size) + (system-name)) + +(defun xselect-convert-to-user (selection type size) + (user-full-name)) + +(defun xselect-convert-to-class (selection type size) + x-emacs-application-class) + +;; We do not try to determine the name Emacs was invoked with, +;; because it is not clean for a program's behavior to depend on that. +(defun xselect-convert-to-name (selection type size) + ;invocation-name + "xemacs") + +(defun xselect-convert-to-integer (selection type value) + (and (integerp value) + (cons (ash value -16) (logand value 65535)))) + +(defun xselect-convert-to-atom (selection type value) + (and (symbolp value) value)) + +(defun xselect-convert-to-identity (selection type value) ; used internally + (vector value)) + +(setq selection-converter-alist + '((TEXT . xselect-convert-to-text) + (STRING . xselect-convert-to-string) + (COMPOUND_TEXT . xselect-convert-to-compound-text) + (TARGETS . xselect-convert-to-targets) + (LENGTH . xselect-convert-to-length) + (DELETE . xselect-convert-to-delete) + (FILE_NAME . xselect-convert-to-filename) + (CHARACTER_POSITION . xselect-convert-to-charpos) + (SOURCE_LOC . xselect-convert-to-sourceloc) + (LINE_NUMBER . xselect-convert-to-lineno) + (COLUMN_NUMBER . xselect-convert-to-colno) + (OWNER_OS . xselect-convert-to-os) + (HOST_NAME . xselect-convert-to-host) + (USER . xselect-convert-to-user) + (CLASS . xselect-convert-to-class) + (NAME . xselect-convert-to-name) + (ATOM . xselect-convert-to-atom) + (INTEGER . xselect-convert-to-integer) + (_EMACS_INTERNAL . xselect-convert-to-identity) + )) + +;FSFmacs (provide 'select) + +;;; x-select.el ends here.
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/x-toolbar.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,478 @@ +;;; x-toolbar.el -- Runtime initialization of XEmacs toolbar + +;; Copyright (C) 1997 Free Software Foundation, Inc. +;; Copyright (C) 1994 Andy Piper <andyp@parallax.demon.co.uk> +;; Copyright (C) 1995 Board of Trustees, University of Illinois +;; Copyright (C) 1996 Ben Wing <wing@666.com> + +;; Maintainer: XEmacs development team +;; Keywords: frames, dumped + +;; 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: Not in FSF + +;;; Commentary: + +;; This file is dumped with XEmacs (when X and toolbar support is compiled in). + +;; Miscellaneous toolbar functions, useful for users to redefine, in +;; order to get different behaviour. + +;;; Code: + +(eval-when-compile + (require 'pending-del)) + +(defgroup toolbar nil + "Configure XEmacs Toolbar functions and properties" + :group 'environment) + + +(defun toolbar-not-configured () + (ding) + (message "Configure the item via `M-x customize RET toolbar RET'")) + +(defcustom toolbar-open-function 'find-file + "*Function to call when the open icon is selected." + :type '(radio (function-item find-file) + (function :tag "Other")) + :group 'toolbar) + +(defun toolbar-open () + (interactive) + (call-interactively toolbar-open-function)) + +(defcustom toolbar-dired-function 'dired + "*Function to call when the dired icon is selected." + :type '(radio (function-item dired) + (function :tag "Other")) + :group 'toolbar) + +(defun toolbar-dired () + (interactive) + (call-interactively toolbar-dired-function)) + +(defcustom toolbar-save-function 'save-buffer + "*Function to call when the save icon is selected." + :type '(radio (function-item save-buffer) + (function :tag "Other")) + :group 'toolbar) + +(defun toolbar-save () + (interactive) + (call-interactively toolbar-save-function)) + +(defcustom toolbar-print-function 'lpr-buffer + "*Function to call when the print icon is selected." + :type '(radio (function-item lpr-buffer) + (function :tag "Other")) + :group 'toolbar) + +(defun toolbar-print () + (interactive) + (call-interactively toolbar-print-function)) + +(defcustom toolbar-cut-function 'x-kill-primary-selection + "*Function to call when the cut icon is selected." + :type '(radio (function-item x-kill-primary-selection) + (function :tag "Other")) + :group 'toolbar) + +(defun toolbar-cut () + (interactive) + (call-interactively toolbar-cut-function)) + +(defcustom toolbar-copy-function 'x-copy-primary-selection + "*Function to call when the copy icon is selected." + :type '(radio (function-item x-copy-primary-selection) + (function :tag "Other")) + :group 'toolbar) + +(defun toolbar-copy () + (interactive) + (call-interactively toolbar-copy-function)) + +(defcustom toolbar-paste-function 'x-yank-clipboard-selection + "*Function to call when the paste icon is selected." + :type '(radio (function-item x-yank-clipboard-selection) + (function :tag "Other")) + :group 'toolbar) + +(defun toolbar-paste () + (interactive) + ;; This horrible kludge is for pending-delete to work correctly. + (and (boundp 'pending-delete) + pending-delete + (let ((this-command toolbar-paste-function)) + (pending-delete-pre-hook))) + (call-interactively toolbar-paste-function)) + +(defcustom toolbar-undo-function 'undo + "*Function to call when the undo icon is selected." + :type '(radio (function-item undo) + (function :tag "Other")) + :group 'toolbar) + +(defun toolbar-undo () + (interactive) + (call-interactively toolbar-undo-function)) + +(defcustom toolbar-replace-function 'query-replace + "*Function to call when the replace icon is selected." + :type '(radio (function-item query-replace) + (function :tag "Other")) + :group 'toolbar) + +(defun toolbar-replace () + (interactive) + (call-interactively toolbar-replace-function)) + +;; +;; toolbar ispell variables and defuns +;; + +(defun toolbar-ispell-internal () + (interactive) + (if (region-active-p) + (ispell-region (region-beginning) (region-end)) + (ispell-buffer))) + +(defcustom toolbar-ispell-function 'toolbar-ispell-internal + "*Function to call when the ispell icon is selected." + :type '(radio (function-item toolbar-ispell-internal) + (function :tag "Other")) + :group 'toolbar) + +(defun toolbar-ispell () + "Intelligently spell the region or buffer." + (interactive) + (call-interactively toolbar-ispell-function)) + +;; +;; toolbar mail variables and defuns +;; + +;; This used to be a macro that expanded its arguments to a form that +;; called `call-process'. With the advent of customize, it's better +;; to have it as a defun, to make customization easier. +(defun toolbar-external (process &rest args) + (interactive) + (apply 'call-process process nil 0 nil args)) + +(defcustom toolbar-mail-commands-alist + `((not-configured . toolbar-not-configured) + (vm . vm) + (gnus . gnus-no-server) + (rmail . rmail) + (mh . mh-rmail) + (pine . (toolbar-external "xterm" "-e" "pine")) ; *gag* + (elm . (toolbar-external "xterm" "-e" "elm")) + (mutt . (toolbar-external "xterm" "-e" "mutt")) + (exmh . (toolbar-external "exmh")) + (netscape . (toolbar-external "netscape" "mailbox:"))) + "*Alist of mail readers and their commands. +The car of each alist element is the mail reader, and the cdr is the form +used to start it." + :type '(repeat (cons :format "%v" + (symbol :tag "Mailer") (function :tag "Start with"))) + :group 'toolbar) + +(defcustom toolbar-mail-reader 'not-configured + "*Mail reader toolbar will invoke. +The legal values are the keys from `toolbar-mail-command-alist', which + should be used to add new mail readers. +Mail readers known by default are vm, gnus, rmail, mh, pine, elm, + mutt, exmh and netscape." + :type '(choice (const :tag "Not Configured" not-configured) + (const vm) (const gnus) (const rmail) (const mh) + (const pine) (const elm) (const mutt) (const exmh) + (const netscape) + (symbol :tag "Other" + :validate (lambda (wid) + (if (assq (widget-value wid) + toolbar-mail-commands-alist) + nil + (widget-put wid :error + "Unknown mail reader") + wid)))) + :group 'toolbar) + + +(defun toolbar-mail () + "Run mail in a separate frame." + (interactive) + (let ((command (assq toolbar-mail-reader toolbar-mail-commands-alist))) + (if (not command) + (error "Uknown mail reader %s" toolbar-mail-reader)) + (funcall (cdr command)))) + +;; +;; toolbar info variables and defuns +;; + +(defvar toolbar-info-frame nil + "The frame in which info is displayed.") + +(defcustom Info-frame-plist + (append (list 'width 80) + (let ((h (plist-get default-frame-plist 'height))) + (when h (list 'height h)))) + "Frame plist for the Info frame." + :type '(repeat (group :inline t + (symbol :tag "Property") + (sexp :tag "Value"))) + :group 'info) + +(defun toolbar-info () + "Run info in a separate frame." + (interactive) + (if (or (not toolbar-info-frame) + (not (frame-live-p toolbar-info-frame))) + (progn + (setq toolbar-info-frame (make-frame Info-frame-plist)) + (select-frame toolbar-info-frame) + (raise-frame toolbar-info-frame))) + (if (frame-iconified-p toolbar-info-frame) + (deiconify-frame toolbar-info-frame)) + (select-frame toolbar-info-frame) + (raise-frame toolbar-info-frame) + (info)) + +;; +;; toolbar debug variables and defuns +;; + +(defun toolbar-debug () + (interactive) + (if (featurep 'eos-debugger) + (call-interactively 'eos::start-debugger) + (require 'gdbsrc) + (call-interactively 'gdbsrc))) + +(defvar compile-command) + +(defun toolbar-compile () + "Run compile without having to touch the keyboard." + (interactive) + (require 'compile) + (popup-dialog-box + `(,(concat "Compile:\n " compile-command) + ["Compile" (compile compile-command) t] + ["Edit command" compile t] + nil + ["Cancel" (message "Quit") t]))) + +;; +;; toolbar news variables and defuns +;; + +(defcustom toolbar-news-commands-alist + `((not-configured . toolbar-not-configured) + (gnus . toolbar-gnus) ; M-x all-hail-gnus + (rn . (toolbar-external "xterm" "-e" "rn")) + (nn . (toolbar-external "xterm" "-e" "nn")) + (trn . (toolbar-external "xterm" "-e" "trn")) + (xrn . (toolbar-external "xrn")) + (slrn . (toolbar-external "xterm" "-e" "slrn")) + (pine . (toolbar-external "xterm" "-e" "pine")) ; *gag* + (tin . (toolbar-external "xterm" "-e" "tin")) ; *gag* + (netscape . (toolbar-external "netscape" "news:"))) + "*Alist of news readers and their commands. +The car of each alist element the pair is the news reader, and the cdr +is the form used to start it." + :type '(repeat (cons :format "%v" + (symbol :tag "Reader") (sexp :tag "Start with"))) + :group 'toolbar) + +(defcustom toolbar-news-reader 'not-configured + "*News reader toolbar will invoke. +The legal values are the keys from `toolbar-news-command-alist', which should + be used to add new news readers. +Newsreaders known by default are gnus, rn, nn, trn, xrn, slrn, pine + and netscape." + :type '(choice (const :tag "Not Configured" not-configured) + (const gnus) (const rn) (const nn) (const trn) + (const xrn) (const slrn) (const pine) (const tin) + (const netscape) + (symbol :tag "Other" + :validate (lambda (wid) + (if (assq (widget-value wid) + toolbar-news-commands-alist) + nil + (widget-put wid :error + "Unknown news reader") + wid)))) + :group 'toolbar) + +(defcustom toolbar-news-use-separate-frame t + "*Whether Gnus is invoked in a separate frame." + :type 'boolean + :group 'toolbar) + +(defvar toolbar-news-frame nil + "The frame in which news is displayed.") + +(defvar toolbar-news-frame-properties nil + "The properties of the frame in which news is displayed.") + +(defun toolbar-gnus () + "Run Gnus in a separate frame." + (interactive) + (when (or (not toolbar-news-frame) + (not (frame-live-p toolbar-news-frame))) + (setq toolbar-news-frame (make-frame toolbar-news-frame-properties)) + (add-hook 'gnus-exit-gnus-hook + (lambda () + (when (frame-live-p toolbar-news-frame) + (if (cdr (frame-list)) + (delete-frame toolbar-news-frame)) + (setq toolbar-news-frame nil)))) + (select-frame toolbar-news-frame) + (raise-frame toolbar-news-frame) + (gnus)) + (if (frame-iconified-p toolbar-news-frame) + (deiconify-frame toolbar-news-frame)) + (select-frame toolbar-news-frame) + (raise-frame toolbar-news-frame)) + +(defun toolbar-news () + "Run News (in a separate frame??)." + (interactive) + (let ((command (assq toolbar-news-reader toolbar-news-commands-alist))) + (if (not command) + (error "Unknown news reader %s" toolbar-news-reader)) + (funcall (cdr command)))) + +(defvar toolbar-last-win-icon nil "A `last-win' icon set.") +(defvar toolbar-next-win-icon nil "A `next-win' icon set.") +(defvar toolbar-file-icon nil "A `file' icon set.") +(defvar toolbar-folder-icon nil "A `folder' icon set") +(defvar toolbar-disk-icon nil "A `disk' icon set.") +(defvar toolbar-printer-icon nil "A `printer' icon set.") +(defvar toolbar-cut-icon nil "A `cut' icon set.") +(defvar toolbar-copy-icon nil "A `copy' icon set.") +(defvar toolbar-paste-icon nil "A `paste' icon set.") +(defvar toolbar-undo-icon nil "An `undo' icon set.") +(defvar toolbar-spell-icon nil "A `spell' icon set.") +(defvar toolbar-replace-icon nil "A `replace' icon set.") +(defvar toolbar-mail-icon nil "A `mail' icon set.") +(defvar toolbar-info-icon nil "An `info' icon set.") +(defvar toolbar-compile-icon nil "A `compile' icon set.") +(defvar toolbar-debug-icon nil "A `debugger' icon set.") +(defvar toolbar-news-icon nil "A `news' icon set.") + +;;; each entry maps a variable to the prefix used. + +(defvar init-x-toolbar-list + '((toolbar-last-win-icon . "last-win") + (toolbar-next-win-icon . "next-win") + (toolbar-file-icon . "file") + (toolbar-folder-icon . "folder") + (toolbar-disk-icon . "disk") + (toolbar-printer-icon . "printer") + (toolbar-cut-icon . "cut") + (toolbar-copy-icon . "copy") + (toolbar-paste-icon . "paste") + (toolbar-undo-icon . "undo") + (toolbar-spell-icon . "spell") + (toolbar-replace-icon . "replace") + (toolbar-mail-icon . "mail") + (toolbar-info-icon . "info-def") + (toolbar-compile-icon . "compile") + (toolbar-debug-icon . "debug") + (toolbar-news-icon . "news"))) + +(defun init-x-toolbar () + (toolbar-add-item-data init-x-toolbar-list ) + ;; do this now because errors will occur if the icon symbols + ;; are not initted + (set-specifier default-toolbar initial-toolbar-spec)) + +(defun toolbar-add-item-data ( icon-list &optional icon-dir ) + (if (eq icon-dir nil) + (setq icon-dir toolbar-icon-directory)) + (mapcar + (lambda (cons) + (let ((prefix (expand-file-name (cdr cons) icon-dir))) + (set (car cons) + (if (featurep 'xpm) + (toolbar-make-button-list + (concat prefix "-up.xpm") + nil + (concat prefix "-xx.xpm") + (concat prefix "-cap-up.xpm") + nil + (concat prefix "-cap-xx.xpm")) + (toolbar-make-button-list + (concat prefix "-up.xbm") + (concat prefix "-dn.xbm") + (concat prefix "-xx.xbm") + ))))) + icon-list ) + ) + +(defvar initial-toolbar-spec + '(;;[toolbar-last-win-icon pop-window-configuration + ;;(frame-property (selected-frame) + ;; 'window-config-stack) t "Most recent window config"] + ;; #### Illicit knowledge? + ;; #### These don't work right - not consistent! + ;; I don't know what's wrong; perhaps `selected-frame' is wrong + ;; sometimes when this is evaluated. Note that I even tried to + ;; kludge-fix this by calls to `set-specifier-dirty-flag' in + ;; pop-window-configuration and such. + + ;;[toolbar-next-win-icon unpop-window-configuration + ;;(frame-property (selected-frame) + ;; 'window-config-unpop-stack) t "Undo \"Most recent window config\""] + ;; #### Illicit knowledge? + + [toolbar-file-icon toolbar-open t "Open a file"] + [toolbar-folder-icon toolbar-dired t "View directory"] + [toolbar-disk-icon toolbar-save t "Save buffer"] + [toolbar-printer-icon toolbar-print t "Print buffer"] + [toolbar-cut-icon toolbar-cut t "Kill region"] + [toolbar-copy-icon toolbar-copy t "Copy region"] + [toolbar-paste-icon toolbar-paste t "Paste from clipboard"] + [toolbar-undo-icon toolbar-undo t "Undo edit"] + [toolbar-spell-icon toolbar-ispell t "Spellcheck"] + [toolbar-replace-icon toolbar-replace t "Replace text"] + [toolbar-mail-icon toolbar-mail t "Mail"] + [toolbar-info-icon toolbar-info t "Information"] + [toolbar-compile-icon toolbar-compile t "Compile"] + [toolbar-debug-icon toolbar-debug t "Debug"] + [toolbar-news-icon toolbar-news t "News"] +) + "The initial toolbar for a buffer.") + +(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-toolbar.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/x-win-sun.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,254 @@ +;;; x-win-sun.el --- runtime initialization for Sun X servers and keyboards +;; Copyright (C) 1993, 1994 Free Software Foundation, Inc. + +;; Authors: jwz@netscape.com, wing@666.com, mrb@eng.sun.com +;; Keywords: terminals + +;; 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. + +;;; Commentary: + +;; This file is loaded by x-win.el at run-time when we are sure that XEmacs +;; is running on the display of a Sun. + +;; The Sun X server (both the MIT and OpenWindows varieties) have extremely +;; stupid names for their keypad and function keys. For example, the key +;; labeled 3 / PgDn, with R15 written on the front, is actually called F35. + +;; There are 3 methods of dealing with the Sun key brokenness: +;; +;; - Use xmodmap to give all keys more sensible names for all apps: +;; I use this shell script: +;; +;; for i in 0 1 2 3 4 5 6 7 8 9 Add Subtract Multiply Divide Decimal ; do +;; echo "keysym KP-$i = KP-$i" +;; done | xmodmap +;; +;; Clearly, as a good X11 citizen, we can't do this. +;; +;; - Use keyboard-translate-table to remap the keybindings at a low level. +;; This approach is taken in the function `sun-x11-keyboard-translate'. +;; This is like running xmodmap within XEmacs only. +;; This is not the default, however, so that legacy keybindings in users' +;; .emacs files like (global-set-key [(f35)] 'foo) continue to work +;; +;; - Use keyboard macros to provide indirection for keybindings. +;; If we do (global-set-key [(f35)] [(kp-3)]), then the user's keybindings +;; work whether he uses `f35' or `kp-3'. +;; This is also compatible with FSF Emacs and other X11 apps. +;; Although this has the disadvantage that these remappings +;; only work with the global key map, we use this as the default. +;; +;; - The Right Way to do this remains to be written... + +;; OK, here's another try at doing things the right way. + +;; We use function-key-map, which honors explicit key-bindings for the +;; stupid Sun names, but also allows indirection if no explicit +;; key-binding exists. + +;;; Code: + +(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 + ;; left is ok + ;; right is ok + ;; kp-add is ok + ;; down is ok + ;; insert is ok + ;; delete is ok + ;; kp-enter is ok +;; Sun Function keys +(loop for (x-name from-key to-key) in + `(("F21" f21 pause) + ("F22" f22 print) + ("F23" f23 scroll_lock) + + ;; X11 R6 mappings + ("SunProps" SunProps props) + ("SunFront" SunFront front) + ("SunOpen" SunOpen open) + ("SunFind" SunFind find) + ("Cancel" cancel stop) + ("Undo" Undo undo) + ("SunCopy" SunCopy copy) + ("SunPaste" SunPaste paste) + ("SunCut" SunCut cut) + + ("F13" f13 props) + ("F14" f14 undo) + ("F15" f15 front) + ("F16" f16 copy) + ("F17" f17 open) + ("F18" f18 paste) + ("F19" f19 find) + ("F20" f20 cut) + + ("F25" f25 kp-divide) + ("F26" f26 kp-multiply) + ("F31" f31 kp-5) + + ;; Map f33 and r13 to end or kp-end + ,@(cond + ((not (x-keysym-on-keyboard-sans-modifiers-p "End")) + '(("F33" f33 end) + ("R13" r13 end))) + ((not (x-keysym-on-keyboard-sans-modifiers-p "KP_End")) + '(("F33" f33 kp-end) + ("R13" r13 kp-end)))) + + ,@(if (x-keysym-on-keyboard-sans-modifiers-p "F36") + '(("F36" f36 stop) + ("F37" f37 again))) + + ;; Type 4 keyboards have a real kp-subtract and a f24 labelled `=' + ;; Type 5 keyboards have no key labelled `=' and a f24 labelled `-' + ,@(when (x-keysym-on-keyboard-sans-modifiers-p "F24") + `(("F24" f24 ,(if (x-keysym-on-keyboard-sans-modifiers-p "KP_Subtract") + 'kp-equal + 'kp-subtract)))) + + ;; Map f27 to home or kp-home, as appropriate + ,@(cond ((not (x-keysym-on-keyboard-sans-modifiers-p "Home")) + '(("F27" f27 home))) + ((not (x-keysym-on-keyboard-sans-modifiers-p "KP_Home")) + '(("F27" f27 kp-home)))) + + ;; Map f29 to prior or kp-prior, as appropriate + ,@(cond ((not (x-keysym-on-keyboard-sans-modifiers-p "Prior")) + '(("F29" f29 prior))) + ((not (x-keysym-on-keyboard-sans-modifiers-p "KP_Prior")) + '(("F29" f29 kp-prior)))) + + ;; Map f35 to next or kp-next, as appropriate + ,@(cond ((not (x-keysym-on-keyboard-sans-modifiers-p "Next")) + '(("F35" f35 next))) + ((not (x-keysym-on-keyboard-sans-modifiers-p "KP_Next")) + '(("F35" f35 kp-next)))) + + ,@(cond ((x-keysym-on-keyboard-sans-modifiers-p "apRead") ; SunOS 4.1.1 + '(("apRead" apRead f11) ("apEdit" apEdit f12))) + ((x-keysym-on-keyboard-sans-modifiers-p "SunF36") ; SunOS 5 + '(("SunF36" SunF36 f11) + ("SunF37" SunF37 f12) + ("F11" f11 stop) + ("F12" f12 again)))) + ) + do (when (x-keysym-on-keyboard-sans-modifiers-p x-name) + (x-remap-keysyms-using-function-key-map from-key to-key))) + +(unintern 'x-remap-keysyms-using-function-key-map) + + ;; 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 + ;; not all, modifier combinations. + ;; + ;; (Well, we omit hyper and super. #### Handle this some other way!) +; (while mapping +; (let ((mods '(() (shift) (control) (meta) (alt)))) +; (while mods +; (let ((k1 (vector (append (car mods) (list (car (car mapping)))))) +; (k2 (vector (append (car mods) (list (cdr (car mapping))))))) +; (define-key global-map k1 k2)) +; (setq mods (cdr mods)))) +; (setq mapping (cdr mapping)))) + +;;; I've extended keyboard-translate-table to work over keysyms. +;;; [FSF Emacs has something called `system-key-alist' that is +;;; supposed to accomplish approximately the same thing. Unfortunately, +;;; it's brain-dead in the typically FSF way, and associates *numbers* +;;; (who knows where the hell they come from?) with symbols.] --ben + +;;; And I've made it into a function which is NOT called by default --mrb + +(defun sun-x11-keyboard-translate () + "Remap Sun's X11 keyboard. +Keys with names like `f35' are remapped, at a low level, +to more mnemonic ones,like `kp-3'." + (interactive) + + (keyboard-translate + 'f11 'stop ; the type4 keyboard Sun/MIT name + 'f36 'stop ; the type5 keyboard Sun name + 'cancel 'stop ; R6 binding + 'f12 'again ; the type4 keyboard Sun/MIT name + 'f37 'again ; the type5 keyboard Sun name + 'f13 'props ; + 'SunProps 'props ; R6 binding + 'f14 'undo ; + 'f15 'front ; + 'SunFront 'front ; R6 binding + 'f16 'copy ; + 'SunCopy 'copy ; R6 binding + 'f17 'open ; + 'SunOpen 'open ; R6 binding + 'f18 'paste ; + 'SunPaste 'paste ; R6 binding + 'f19 'find ; + 'f20 'cut ; + 'SunCut 'cut ; R6 binding + ;; help is ok + 'f21 'pause + 'f22 'prsc + 'f23 'scroll + ;; num_lock is ok + ;;'f24 'kp-equal) ; type4 only! + 'f25 'kp-divide ; + 'f26 'kp-multiply ; + 'f24 'kp-subtract ; type5 only! + 'f27 'kp-7 ; + ;; up is ok + 'f29 'kp-9 + ;; left is ok + 'f31 'kp-5 + ;; right is ok + ;; kp-add is ok + 'f33 'kp-1 ; the Sun name + 'r13 'end ; the MIT name + ;; down is ok + 'f35 'kp-3 + ;; insert is ok + ;; delete is ok + ;; kp-enter is ok + 'SunF36 'f11 ; Type 5 keyboards + 'SunF37 'f12 ; Used to be Stop & Again + )) + + +;;; OpenWindows-like "find" processing. +;;; As far as I know, the `find' key is a Sunism, so we do that binding +;;; here. This is the only Sun-specific keybinding. (The functions +;;; themselves are in x-win.el in case someone wants to use them when +;;; not running on a Sun display.) + +(define-key global-map 'find 'ow-find) +(define-key global-map '(shift find) 'ow-find-backward) + +;;; x-win-sun.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/x-win-xfree86.el Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,88 @@ +;;; x-win-xfree86.el --- runtime initialization for XFree86 servers +;; Copyright (C) 1995 Sun Microsystems, Inc. +;; Copyright (C) 1995 Ben Wing. + +;; Author: Ben Wing +;; Author: Martin Buchholz (rewritten to use function-key-map) +;; Keywords: terminals + +;; 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. + +;;; Commentary: + +;; This file is loaded by x-win.el at run-time when we are sure that XEmacs +;; is running on the display of something running XFree86 (Linux, +;; NetBSD, FreeBSD, and perhaps other Intel Unixen). + +;;; #### bleck!!! Use key-translation-map! + +;;; #### Counter-bleck!! We shouldn't override a user binding for F13. +;;; So we use function-key-map for now. +;;; When we've implemented a fallback-style equivalent of +;;; keyboard-translate-table, we'll use that instead. (mrb) + +;; For no obvious reason, shift-F1 is called F13, although Meta-F1 and +;; Control-F1 have normal names. + +(loop for (x-key key sane-key) in + '(("F13" f13 f1) + ("F14" f14 f2) + ("F15" f15 f3) + ("F16" f16 f4) + ("F17" f17 f5) + ("F18" f18 f6) + ("F19" f19 f7) + ("F20" f20 f8) + ("F21" f21 f9) + ("F22" f22 f10) + ("F23" f23 f11) + ("F24" f24 f12)) + do + (when (and (x-keysym-on-keyboard-p x-key) + (not (x-keysym-on-keyboard-sans-modifiers-p x-key))) + ;; define also the control, meta, and meta-control versions. + (loop for mods in '(() (control) (meta) (meta control)) do + (define-key function-key-map `[(,@mods ,key)] `[(shift ,@mods ,sane-key)]) + ))) + +;; (let ((mapping '((f13 . (shift f1)) +;; (f14 . (shift f2)) +;; (f15 . (shift f3)) +;; (f16 . (shift f4)) +;; (f17 . (shift f5)) +;; (f18 . (shift f6)) +;; (f19 . (shift f7)) +;; (f20 . (shift f8)) +;; (f21 . (shift f9)) +;; (f22 . (shift f10)) +;; (f23 . (shift f11)) +;; (f24 . (shift f12))))) +;; +;; ;; now define them and also the control, meta, and meta-control versions. +;; (while mapping +;; (let* ((foo (caar mapping)) +;; (bar (cdar mapping)) +;; (foo (if (listp foo) foo (list foo))) +;; (bar (if (listp bar) bar (list bar)))) +;; (let ((mods '(() (control) (meta) (meta control)))) +;; (while mods +;; (let ((k1 (vector (append (car mods) foo))) +;; (k2 (vector (append (car mods) bar)))) +;; (define-key global-map k1 k2)) +;; (setq mods (cdr mods)))) +;; (setq mapping (cdr mapping)))))
--- a/lisp/x11/auto-autoloads.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,28 +0,0 @@ -;;; DO NOT MODIFY THIS FILE -(if (featurep 'x11-autoloads) (error "Already loaded")) - -(provide 'x11-autoloads) - -;;;### (autoloads (font-menu-weight-constructor font-menu-size-constructor font-menu-family-constructor reset-device-font-menus) "x-font-menu" "x11/x-font-menu.el") - -(defcustom font-menu-ignore-scaled-fonts t "*If non-nil, then the font menu will try to show only bitmap fonts." :type 'boolean :group 'x) - -(defcustom font-menu-this-frame-only-p nil "*If non-nil, then changing the default font from the font menu will only\naffect one frame instead of all frames." :type 'boolean :group 'x) - -(fset 'install-font-menus 'reset-device-font-menus) - -(autoload 'reset-device-font-menus "x-font-menu" "\ -Generates the `Font', `Size', and `Weight' submenus for the Options menu. -This is run the first time that a font-menu is needed for each device. -If you don't like the lazy invocation of this function, you can add it to -`create-device-hook' and that will make the font menus respond more quickly -when they are selected for the first time. If you add fonts to your system, -or if you change your font path, you can call this to re-initialize the menus." nil nil) - -(autoload 'font-menu-family-constructor "x-font-menu" nil nil nil) - -(autoload 'font-menu-size-constructor "x-font-menu" nil nil nil) - -(autoload 'font-menu-weight-constructor "x-font-menu" nil nil nil) - -;;;***
--- a/lisp/x11/custom-load.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,13 +0,0 @@ -;;; custom-load.el --- automatically extracted custom dependencies - - -;;; Code: - -(custom-add-loads 'menu '("x-menubar")) -(custom-add-loads 'environment '("x-toolbar")) -(custom-add-loads 'buffers-menu '("x-menubar")) -(custom-add-loads 'toolbar '("x-toolbar")) -(custom-add-loads 'info '("x-toolbar")) -(custom-add-loads 'x '("x-faces" "x-font-menu")) - -;;; custom-load.el ends here
--- a/lisp/x11/x-compose.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,846 +0,0 @@ -;;; x-compose.el --- Compose-key processing in XEmacs - -;; Copyright (C) 1992, 1993, 1997 Free Software Foundation, Inc. - -;; Author: Jamie Zawinski <jwz@netscape.com> -;; Maintainer: XEmacs Development Team -;; Rewritten by Martin Buchholz far too many times. -;; -;; Changed: 11 Jun 1997 by Heiko Muenkel <muenkel@tnt.uni-hannover.de> -;; The degree sign couldn't be inserted with the old version. -;; Keywords: i18n - -;; 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: - -;; created by jwz, 14-jun-92. -;;; changed by Jan Vroonhof, July 1997: Use function-key-map instead -;;; of global map. -;;; Preliminary support for -;;; XFree86 deadkeys - -;; This file implements DEC-, OpenWindows-, and HP-compatible "Compose" -;; processing for XEmacs. - -;; If you are running a version of X which already does compose processing, -;; then you don't need this file. But the MIT R4 and R5 distributions don't -;; do compose processing, so you may want to fake it by using this code. - -;; The basic idea is that there are several ways to generate keysyms which -;; do not have keys devoted to them on your keyboard. - -;; The first method is by using "dead" keys. A dead key is a key which, -;; when typed, does not insert a character. Instead it modifies the -;; following character typed. So if you typed "dead-tilde" followed by "A", -;; then "A-tilde" would be inserted. Of course, this requires you to modify -;; your keyboard to include a "dead-tilde" key on it somewhere. - -;; The second method is by using a "Compose" key. With a Compose key, you -;; would type "Compose" then "tilde" then "A" to insert "A-tilde". - -;; There are a small number of dead keys: acute, grave, cedilla, diaeresis, -;; circumflex, tilde, and ring. There are a larger number of accented and -;; other characters accessible via the Compose key, so both are useful. - -;; To use this code, you will need to have a Compose key on your keyboard. -;; The default configuration of most X keyboards doesn't contain one. You -;; can, for example, turn the right "Meta" key into a "Compose" key with -;; this command: - -;; xmodmap -e "remove mod1 = Meta_R" -e "keysym Meta_R = Multi_key" - -;; Multi-key is the name that X (and emacs) know the "Compose" key by. -;; The "remove..." command is necessary because the "Compose" key must not -;; have any modifier bits associated with it. This exact command may not -;; work, depending on what system and keyboard you are using. If it -;; doesn't, you'll have to read the man page for xmodmap. You might want -;; to get the "xkeycaps" program from the host export.lcs.mit.edu in the -;; file contrib/xkeycaps.tar.Z, which is a graphical front end to xmodmap -;; that hides xmodmap's arcane syntax from you. - -;; If for some reason you don't want to have a dedicated compose key on your -;; keyboard, you can use some other key as the prefix. For example, to make -;; "Meta-Shift-C" act as a compose key (so that "M-C , c" would insert the -;; character "ccedilla") you could do - -;; (global-set-key "\M-C" compose-map) - -;; I believe the bindings encoded in this file are the same as those used -;; by OpenWindows versions 2 and 3, and DEC VT320 terminals. Please let me -;; know if you think otherwise. - -;; Much thanks to Justin Bur <justin@crim.ca> for helping me understand how -;; this stuff is supposed to work. - -;; You also might want to consider getting Justin's patch for the MIT Xlib -;; that implements compose processing in the library. This will enable -;; compose processing in applications other than emacs as well. You can -;; get it from export.lcs.mit.edu in contrib/compose.tar.Z. - -;; This code has one feature that a more "builtin" Compose mechanism could -;; not have: at any point you can type C-h to get a list of the possible -;; completions of what you have typed so far. - -;;; Code: - -(require 'x-iso8859-1) - -(defun make-compose-map (map-sym) - (let ((map (make-sparse-keymap))) - (set map-sym map) - (set-keymap-name map map-sym) - ;; Required to tell XEmacs the keymaps were actually autoloaded. - ;; #### Make this unnecessary! - (fset map-sym map))) - -(make-compose-map 'compose-map) -(make-compose-map 'compose-acute-map) -(make-compose-map 'compose-grave-map) -(make-compose-map 'compose-cedilla-map) -(make-compose-map 'compose-diaeresis-map) -(make-compose-map 'compose-circumflex-map) -(make-compose-map 'compose-tilde-map) -(make-compose-map 'compose-ring-map) - -(unintern 'make-compose-map) - -(define-key compose-map 'acute compose-acute-map) -(define-key compose-map 'grave compose-grave-map) -(define-key compose-map 'cedilla compose-cedilla-map) -(define-key compose-map 'diaeresis compose-diaeresis-map) -(define-key compose-map 'circumflex compose-circumflex-map) -(define-key compose-map 'tilde compose-tilde-map) -(define-key compose-map 'degree compose-ring-map) - -;;(eval-when-compile -;; (defsubst define-dead-key-map (key map) -;; (define-key function-key-map key map) -;; (define-key compose-map key map))) - -;;;###utoload (autoload 'compose-map "x-compose" nil t 'keymap) -;;;###utoload (autoload 'compose-acute-map "x-compose" nil t 'keymap) -;;;###utoload (autoload 'compose-grave-map "x-compose" nil t 'keymap) -;;;###utoload (autoload 'compose-cedilla-map "x-compose" nil t 'keymap) -;;;###utoload (autoload 'compose-diaeresis-map "x-compose" nil t 'keymap) -;;;###utoload (autoload 'compose-degree-map "x-compose" nil t 'keymap) -;;;###utoload (define-key function-key-map [acute] 'compose-acute-map) -;;;###utoload (define-key function-key-map [grave] 'compose-grave-map) -;;;###utoload (define-key function-key-map [cedilla] 'compose-cedilla-map) -;;;###utoload (define-key function-key-map [diaeresis] 'compose-diaeresis-map) -;;;###utoload (define-key function-key-map [degree] 'compose-degree-map) -;;;###utoload (define-key function-key-map [multi-key] 'compose-map) -;;;###utoload (define-key global-map [multi-key] 'compose-map) - -;;(define-key function-key-map [multi-key] compose-map) - - -;; The following is necessary, because one can't rebind [degree] -;; and use it to insert the degree sign! -;;(defun compose-insert-degree () -;; "Inserts a degree sign." -;; (interactive) -;; (insert ?\260)) - -;; The "Dead" keys: -;; -;;(define-dead-key-map [acute] compose-acute-map) -;;(define-dead-key-map [cedilla] compose-cedilla-map) -;;(define-dead-key-map [diaeresis] compose-diaeresis-map) -;;(define-dead-key-map [degree] compose-ring-map) - -(define-key compose-map [acute] compose-acute-map) -(define-key compose-map [?'] compose-acute-map) -(define-key compose-map [grave] compose-grave-map) -(define-key compose-map [?`] compose-grave-map) -(define-key compose-map [cedilla] compose-cedilla-map) -(define-key compose-map [?,] compose-cedilla-map) -(define-key compose-map [diaeresis] compose-diaeresis-map) -(define-key compose-map [?\"] compose-diaeresis-map) -(define-key compose-map [circumflex] compose-circumflex-map) -(define-key compose-map [?^] compose-circumflex-map) -(define-key compose-map [tilde] compose-tilde-map) -(define-key compose-map [~] compose-tilde-map) -(define-key compose-map [degree] compose-ring-map) -(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. - -(define-key compose-acute-map [space] "'") -(define-key compose-acute-map [?'] [acute]) -(define-key compose-acute-map [?A] [Aacute]) -(define-key compose-acute-map [E] [Eacute]) -(define-key compose-acute-map [I] [Iacute]) -(define-key compose-acute-map [O] [Oacute]) -(define-key compose-acute-map [U] [Uacute]) -(define-key compose-acute-map [Y] [Yacute]) -(define-key compose-acute-map [a] [aacute]) -(define-key compose-acute-map [e] [eacute]) -(define-key compose-acute-map [i] [iacute]) -(define-key compose-acute-map [o] [oacute]) -(define-key compose-acute-map [u] [uacute]) -(define-key compose-acute-map [y] [yacute]) - -(define-key compose-grave-map [space] "`") -(define-key compose-grave-map [?`] [grave]) -(define-key compose-grave-map [A] [Agrave]) -(define-key compose-grave-map [E] [Egrave]) -(define-key compose-grave-map [I] [Igrave]) -(define-key compose-grave-map [O] [Ograve]) -(define-key compose-grave-map [U] [Ugrave]) -(define-key compose-grave-map [a] [agrave]) -(define-key compose-grave-map [e] [egrave]) -(define-key compose-grave-map [i] [igrave]) -(define-key compose-grave-map [o] [ograve]) -(define-key compose-grave-map [u] [ugrave]) - -(define-key compose-cedilla-map [space] ",") -(define-key compose-cedilla-map [?,] [cedilla]) -(define-key compose-cedilla-map [C] [Ccedilla]) -(define-key compose-cedilla-map [c] [ccedilla]) - -(define-key compose-diaeresis-map [space] [diaeresis]) -(define-key compose-diaeresis-map [?\"] [diaeresis]) -(define-key compose-diaeresis-map [A] [Adiaeresis]) -(define-key compose-diaeresis-map [E] [Ediaeresis]) -(define-key compose-diaeresis-map [I] [Idiaeresis]) -(define-key compose-diaeresis-map [O] [Odiaeresis]) -(define-key compose-diaeresis-map [U] [Udiaeresis]) -(define-key compose-diaeresis-map [a] [adiaeresis]) -(define-key compose-diaeresis-map [e] [ediaeresis]) -(define-key compose-diaeresis-map [i] [idiaeresis]) -(define-key compose-diaeresis-map [o] [odiaeresis]) -(define-key compose-diaeresis-map [u] [udiaeresis]) -(define-key compose-diaeresis-map [y] [ydiaeresis]) - -(define-key compose-circumflex-map [space] "^") -(define-key compose-circumflex-map [?/] "|") -(define-key compose-circumflex-map [?!] [brokenbar]) -(define-key compose-circumflex-map [?-] [macron]) -(define-key compose-circumflex-map [?_] [macron]) -(define-key compose-circumflex-map [?0] [degree]) -(define-key compose-circumflex-map [?1] [onesuperior]) -(define-key compose-circumflex-map [?2] [twosuperior]) -(define-key compose-circumflex-map [?3] [threesuperior]) -(define-key compose-circumflex-map [?.] [periodcentered]) -(define-key compose-circumflex-map [A] [Acircumflex]) -(define-key compose-circumflex-map [E] [Ecircumflex]) -(define-key compose-circumflex-map [I] [Icircumflex]) -(define-key compose-circumflex-map [O] [Ocircumflex]) -(define-key compose-circumflex-map [U] [Ucircumflex]) -(define-key compose-circumflex-map [a] [acircumflex]) -(define-key compose-circumflex-map [e] [ecircumflex]) -(define-key compose-circumflex-map [i] [icircumflex]) -(define-key compose-circumflex-map [o] [ocircumflex]) -(define-key compose-circumflex-map [u] [ucircumflex]) - -(define-key compose-tilde-map [space] "~") -(define-key compose-tilde-map [A] [Atilde]) -(define-key compose-tilde-map [N] [Ntilde]) -(define-key compose-tilde-map [O] [Otilde]) -(define-key compose-tilde-map [a] [atilde]) -(define-key compose-tilde-map [n] [ntilde]) -(define-key compose-tilde-map [o] [otilde]) - -(define-key compose-ring-map [space] [degree]) -(define-key compose-ring-map [A] [Aring]) -(define-key compose-ring-map [a] [aring]) - - -;;; The rest of the compose-map. These are the composed characters -;;; that are not accessible via "dead" keys. - -(define-key compose-map " '" "'") -(define-key compose-map " ^" "^") -(define-key compose-map " `" "`") -(define-key compose-map " ~" "~") -(define-key compose-map " " [nobreakspace]) -(define-key compose-map " \"" [diaeresis]) -(define-key compose-map " :" [diaeresis]) -(define-key compose-map " *" [degree]) - -(define-key compose-map "!!" [exclamdown]) -(define-key compose-map "!^" [brokenbar]) -(define-key compose-map "!S" [section]) -(define-key compose-map "!s" [section]) -(define-key compose-map "!P" [paragraph]) -(define-key compose-map "!p" [paragraph]) - -(define-key compose-map "((" "[") -(define-key compose-map "(-" "{") - -(define-key compose-map "))" "]") -(define-key compose-map ")-" "}") - -(define-key compose-map "++" "#") -(define-key compose-map "+-" [plusminus]) - -(define-key compose-map "-(" "{") -(define-key compose-map "-)" "}") -(define-key compose-map "--" "-") -(define-key compose-map "-L" [sterling]) -(define-key compose-map "-l" [sterling]) -(define-key compose-map "-Y" [yen]) -(define-key compose-map "-y" [yen]) -(define-key compose-map "-," [notsign]) -(define-key compose-map "-|" [notsign]) -(define-key compose-map "-^" [macron]) -(define-key compose-map "-+" [plusminus]) -(define-key compose-map "-:" [division]) -(define-key compose-map "-D" [ETH]) -(define-key compose-map "-d" [eth]) -(define-key compose-map "-a" [ordfeminine]) - -(define-key compose-map ".^" [periodcentered]) - -(define-key compose-map "//" "\\") -(define-key compose-map "/<" "\\") -(define-key compose-map "/^" "|") -(define-key compose-map "/C" [cent]) -(define-key compose-map "/c" [cent]) -(define-key compose-map "/U" [mu]) -(define-key compose-map "/u" [mu]) -(define-key compose-map "/O" [Ooblique]) -(define-key compose-map "/o" [oslash]) - -(define-key compose-map "0X" [currency]) -(define-key compose-map "0x" [currency]) -(define-key compose-map "0S" [section]) -(define-key compose-map "0s" [section]) -(define-key compose-map "0C" [copyright]) -(define-key compose-map "0c" [copyright]) -(define-key compose-map "0R" [registered]) -(define-key compose-map "0r" [registered]) -(define-key compose-map "0^" [degree]) - -(define-key compose-map "1^" [onesuperior]) -(define-key compose-map "14" [onequarter]) -(define-key compose-map "12" [onehalf]) - -(define-key compose-map "2^" [twosuperior]) - -(define-key compose-map "3^" [threesuperior]) -(define-key compose-map "34" [threequarters]) - -(define-key compose-map ":-" [division]) - -(define-key compose-map "</" "\\") -(define-key compose-map "<<" [guillemotleft]) - -(define-key compose-map "=L" [sterling]) -(define-key compose-map "=l" [sterling]) -(define-key compose-map "=Y" [yen]) -(define-key compose-map "=y" [yen]) - -(define-key compose-map ">>" [guillemotright]) - -(define-key compose-map "??" [questiondown]) - -(define-key compose-map "AA" "@") -(define-key compose-map "Aa" "@") -(define-key compose-map "A_" [ordfeminine]) -(define-key compose-map "A`" [Agrave]) -(define-key compose-map "A'" [Aacute]) -(define-key compose-map "A^" [Acircumflex]) -(define-key compose-map "A~" [Atilde]) -(define-key compose-map "A\"" [Adiaeresis]) -(define-key compose-map "A*" [Aring]) -(define-key compose-map "AE" [AE]) - -(define-key compose-map "C/" [cent]) -(define-key compose-map "C|" [cent]) -(define-key compose-map "C0" [copyright]) -(define-key compose-map "CO" [copyright]) -(define-key compose-map "Co" [copyright]) -(define-key compose-map "C," [Ccedilla]) - -(define-key compose-map "D-" [ETH]) - -(define-key compose-map "E`" [Egrave]) -(define-key compose-map "E'" [Eacute]) -(define-key compose-map "E^" [Ecircumflex]) -(define-key compose-map "E\"" [Ediaeresis]) - -(define-key compose-map "I`" [Igrave]) -(define-key compose-map "I'" [Iacute]) -(define-key compose-map "I^" [Icircumflex]) -(define-key compose-map "I\"" [Idiaeresis]) - -(define-key compose-map "L-" [sterling]) -(define-key compose-map "L=" [sterling]) - -(define-key compose-map "N~" [Ntilde]) - -(define-key compose-map "OX" [currency]) -(define-key compose-map "Ox" [currency]) -(define-key compose-map "OS" [section]) -(define-key compose-map "Os" [section]) -(define-key compose-map "OC" [copyright]) -(define-key compose-map "Oc" [copyright]) -(define-key compose-map "OR" [registered]) -(define-key compose-map "Or" [registered]) -(define-key compose-map "O_" [masculine]) -(define-key compose-map "O`" [Ograve]) -(define-key compose-map "O'" [Oacute]) -(define-key compose-map "O^" [Ocircumflex]) -(define-key compose-map "O~" [Otilde]) -(define-key compose-map "O\"" [Odiaeresis]) -(define-key compose-map "O/" [Ooblique]) - -(define-key compose-map "P!" [paragraph]) - -(define-key compose-map "R0" [registered]) -(define-key compose-map "RO" [registered]) -(define-key compose-map "Ro" [registered]) - -(define-key compose-map "S!" [section]) -(define-key compose-map "S0" [section]) -(define-key compose-map "SO" [section]) -(define-key compose-map "So" [section]) -(define-key compose-map "SS" [ssharp]) - -(define-key compose-map "TH" [THORN]) - -(define-key compose-map "U`" [Ugrave]) -(define-key compose-map "U'" [Uacute]) -(define-key compose-map "U^" [Ucircumflex]) -(define-key compose-map "U\"" [Udiaeresis]) - -(define-key compose-map "X0" [currency]) -(define-key compose-map "XO" [currency]) -(define-key compose-map "Xo" [currency]) - -(define-key compose-map "Y-" [yen]) -(define-key compose-map "Y=" [yen]) -(define-key compose-map "Y'" [Yacute]) - -(define-key compose-map "_A" [ordfeminine]) -(define-key compose-map "_a" [ordfeminine]) -(define-key compose-map "_^" [macron]) -(define-key compose-map "_O" [masculine]) -(define-key compose-map "_o" [masculine]) - -(define-key compose-map "aA" "@") -(define-key compose-map "aa" "@") -(define-key compose-map "a_" [ordfeminine]) -(define-key compose-map "a-" [ordfeminine]) -(define-key compose-map "a`" [agrave]) -(define-key compose-map "a'" [aacute]) -(define-key compose-map "a^" [acircumflex]) -(define-key compose-map "a~" [atilde]) -(define-key compose-map "a\"" [adiaeresis]) -(define-key compose-map "a*" [aring]) -(define-key compose-map "ae" [ae]) - -(define-key compose-map "c/" [cent]) -(define-key compose-map "c|" [cent]) -(define-key compose-map "c0" [copyright]) -(define-key compose-map "cO" [copyright]) -(define-key compose-map "co" [copyright]) -(define-key compose-map "c," [ccedilla]) - -(define-key compose-map "d-" [eth]) - -(define-key compose-map "e`" [egrave]) -(define-key compose-map "e'" [eacute]) -(define-key compose-map "e^" [ecircumflex]) -(define-key compose-map "e\"" [ediaeresis]) - -(define-key compose-map "i`" [igrave]) -(define-key compose-map "i'" [iacute]) -(define-key compose-map "i^" [icircumflex]) -(define-key compose-map "i\"" [idiaeresis]) -(define-key compose-map "i:" [idiaeresis]) - -(define-key compose-map "l-" [sterling]) -(define-key compose-map "l=" [sterling]) - -(define-key compose-map "n~" [ntilde]) - -(define-key compose-map "oX" [currency]) -(define-key compose-map "ox" [currency]) -(define-key compose-map "oC" [copyright]) -(define-key compose-map "oc" [copyright]) -(define-key compose-map "oR" [registered]) -(define-key compose-map "or" [registered]) -(define-key compose-map "oS" [section]) -(define-key compose-map "os" [section]) -(define-key compose-map "o_" [masculine]) -(define-key compose-map "o`" [ograve]) -(define-key compose-map "o'" [oacute]) -(define-key compose-map "o^" [ocircumflex]) -(define-key compose-map "o~" [otilde]) -(define-key compose-map "o\"" [odiaeresis]) -(define-key compose-map "o/" [oslash]) - -(define-key compose-map "p!" [paragraph]) - -(define-key compose-map "r0" [registered]) -(define-key compose-map "rO" [registered]) -(define-key compose-map "ro" [registered]) - -(define-key compose-map "s!" [section]) -(define-key compose-map "s0" [section]) -(define-key compose-map "sO" [section]) -(define-key compose-map "so" [section]) -(define-key compose-map "ss" [ssharp]) - -(define-key compose-map "th" [thorn]) - -(define-key compose-map "u`" [ugrave]) -(define-key compose-map "u'" [uacute]) -(define-key compose-map "u^" [ucircumflex]) -(define-key compose-map "u\"" [udiaeresis]) -(define-key compose-map "u/" [mu]) - -(define-key compose-map "x0" [currency]) -(define-key compose-map "xO" [currency]) -(define-key compose-map "xo" [currency]) -(define-key compose-map "xx" [multiply]) - -(define-key compose-map "y-" [yen]) -(define-key compose-map "y=" [yen]) -(define-key compose-map "y'" [yacute]) -(define-key compose-map "y\"" [ydiaeresis]) - -(define-key compose-map "|C" [cent]) -(define-key compose-map "|c" [cent]) -(define-key compose-map "||" [brokenbar]) - - -;; Suppose we type these three physical keys: [Multi_key " a] -;; Xlib can deliver these keys as the following sequences of keysyms: -;; -;; - [Multi_key " a] (no surprise here) -;; - [adiaeresis] (OK, Xlib is doing compose processing for us) -;; - [Multi_key " adiaeresis] (Huh?) -;; -;; It is the last possibility that is arguably a bug. Xlib can't -;; decide whether it's really doing compose processing or not (or -;; actually, different parts of Xlib disagree). -;; -;; So we'll just convert [Multi_key " adiaeresis] to [adiaeresis] -(defun xlib-input-method-bug-workaround (keymap) - (map-keymap - (lambda (key value) - (cond - ((keymapp value) - (xlib-input-method-bug-workaround value)) - ((and (sequencep value) - (eq 1 (length value)) - (null (lookup-key keymap value))) - (define-key keymap value value)))) - keymap)) -(xlib-input-method-bug-workaround compose-map) -(unintern 'xlib-input-method-bug-workaround) - -;; While we're at it, a similar mechanism will make colon equivalent -;; to doublequote for diaeresis processing. Some Xlibs do this. -(defun alias-colon-to-doublequote (keymap) - (map-keymap - (lambda (key value) - (when (keymapp value) - (alias-colon-to-doublequote value)) - (when (eq key '\") - (define-key keymap ":" value))) - keymap)) -(alias-colon-to-doublequote compose-map) -(unintern 'alias-colon-to-doublequote) - -;;; Electric dead keys: making a' mean a-acute. - - -(defun electric-diacritic (&optional count) - "Modify the previous character with an accent. -For example, if `:' is bound to this command, then typing `a:' -will first insert `a' and then turn it into `\344' (adiaeresis). -The keys to which this command may be bound (and the accents -which it understands) are: - - ' (acute) \301\311\315\323\332\335 \341\351\355\363\372\375 - ` (grave) \300\310\314\322\331 \340\350\354\362\371 - : (diaeresis) \304\313\317\326\334 \344\353\357\366\374\377 - ^ (circumflex) \302\312\316\324\333 \342\352\356\364\373 - , (cedilla) \307\347 - . (ring) \305\345" - (interactive "p") - (or count (setq count 1)) - - (if (not (eq last-command 'self-insert-command)) - ;; Only do the magic if the two chars were typed in succession. - (self-insert-command count) - - ;; This is so that ``a : C-x u'' will transform `adiaeresis' back into `a:' - (self-insert-command count) - (undo-boundary) - (delete-char (- count)) - - (let* ((c last-command-char) - (map (cond ((eq c ?') compose-acute-map) - ((eq c ?`) compose-grave-map) - ((eq c ?,) compose-cedilla-map) - ((eq c ?:) compose-diaeresis-map) - ((eq c ?^) compose-circumflex-map) - ((eq c ?~) compose-tilde-map) - ((eq c ?.) compose-ring-map) - (t (error "unknown diacritic: %s (%c)" c c)))) - (base-char (preceding-char)) - (mod-char (and (>= (downcase base-char) ?a) ; only do alphabetics? - (<= (downcase base-char) ?z) - (lookup-key map (make-string 1 base-char))))) - (if (and (vectorp mod-char) (= (length mod-char) 1)) - (setq mod-char (aref mod-char 0))) - (if (and mod-char (symbolp mod-char)) - (setq mod-char (or (get mod-char character-set-property) mod-char))) - (if (and mod-char (> count 0)) - (delete-char -1) - (setq mod-char c)) - (while (> count 0) - (insert mod-char) - (setq count (1- count)))))) - -;; should "::" mean "¨" and ": " mean ":"? -;; should we also do -;; (?~ -;; (?A "\303") -;; (?C "\307") -;; (?D "\320") -;; (?N "\321") -;; (?O "\325") -;; (?a "\343") -;; (?c "\347") -;; (?d "\360") -;; (?n "\361") -;; (?o "\365") -;; (?> "\273") -;; (?< "\253") -;; (? "~")) ; no special code -;; (?\/ -;; (?A "\305") ;; A-with-ring (Norwegian and Danish) -;; (?E "\306") ;; AE-ligature (Norwegian and Danish) -;; (?O "\330") -;; (?a "\345") ;; a-with-ring (Norwegian and Danish) -;; (?e "\346") ;; ae-ligature (Norwegian and Danish) -;; (?o "\370") -;; (? "/")) ; no special code - - -;;; Providing help in the middle of a compose sequence. (Way cool.) - -(eval-when-compile - (defsubst next-composable-event () - (let (event) - (while (progn - (setq event (next-command-event)) - (not (or (key-press-event-p event) - (button-press-event-p event)))) - (dispatch-event event)) - event))) - -(defun compose-help (ignore-prompt) - (let* ((keys (apply 'vector (nbutlast (append (this-command-keys) nil)))) - (map (or (lookup-key function-key-map keys) - (error "can't find map? %s %s" keys (this-command-keys)))) - binding) - (save-excursion - (with-output-to-temp-buffer "*Help*" - (set-buffer "*Help*") - (erase-buffer) - (message "Working...") - (setq ctl-arrow 'compose) ; non-t-non-nil - (insert "You are typing a compose sequence. So far you have typed: ") - (insert (key-description keys)) - (insert "\nCompletions from here are:\n\n") - (map-keymap 'compose-help-mapper map t) - (message "? "))) - (while (keymapp map) - (setq binding (lookup-key map (vector (next-composable-event)))) - (if (null binding) - (message "No such key in keymap. Try again.") - (setq map binding))) - binding)) - -(put 'compose-help 'isearch-command t) ; so that it doesn't terminate isearch - -(defun compose-help-mapper (key binding) - (if (and (symbolp key) - (get key character-set-property)) - (setq key (get key character-set-property))) - (if (eq binding 'compose-help) ; suppress that... - nil - (if (keymapp binding) - (let ((p (point))) - (map-keymap 'compose-help-mapper binding t) - (goto-char p) - (while (not (eobp)) - (if (characterp key) - (insert (make-string 1 key)) - (insert (single-key-description key))) - (insert " ") - (forward-line 1))) - (if (characterp key) - (insert (make-string 1 key)) - (insert (single-key-description key))) - (indent-to 16) - (let ((code (and (vectorp binding) - (= 1 (length binding)) - (get (aref binding 0) character-set-property)))) - (if code - (insert (make-string 1 code)) - (if (stringp binding) - (insert binding) - (insert (prin1-to-string binding))))) - (when (and (vectorp binding) (= 1 (length binding))) - (indent-to 32) - (insert (symbol-name (aref binding 0))))) - (insert "\n"))) - -;; define it at top-level in the compose map... -;;(define-key compose-map [(control h)] 'compose-help) -;;(define-key compose-map [help] 'compose-help) -;; and then define it in each sub-map of the compose map. -(map-keymap - (lambda (key binding) - (when (keymapp binding) -;; (define-key binding [(control h)] 'compose-help) -;; (define-key binding [help] 'compose-help) - )) - compose-map nil) - -;; Make redisplay display the accented letters -(if (memq (default-value 'ctl-arrow) '(t nil)) - (setq-default ctl-arrow 'iso-8859/1)) - - -(provide 'x-compose) - -;;; x-compose.el ends here
--- a/lisp/x11/x-faces.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,646 +0,0 @@ -;;; x-faces.el --- X-specific face frobnication, aka black magic. - -;;; Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc. -;;; Copyright (C) 1995, 1996 Ben Wing. - -;; Author: Jamie Zawinski -;; Modified by: Chuck Thompson -;; Modified by: Ben Wing -;; Modified by: Martin Buchholz - -;; 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. - -;; This file does the magic to parse X font names, and make sure that the -;; default and modeline attributes of new frames are specified enough. -;; -;; The resource-manager syntax for faces is -;; -;; Emacs.bold.attributeFont: font-name -;; Emacs.bold.attributeForeground: fg -;; Emacs.bold.attributeBackground: bg -;; Emacs.bold.attributeBackgroundPixmap: file -;; Emacs.bold.attributeUnderline: true/false -;; Emacs.bold.attributeStrikethru: true/false -;; -;; You can specify the properties of a face on a per-frame basis. For -;; example, to have the "isearch" face use a red foreground on frames -;; named "emacs" (the default) but use a blue foreground on frames that -;; you create named "debugger", you could do -;; -;; Emacs*emacs.isearch.attributeForeground: red -;; Emacs*debugger.isearch.attributeForeground: blue -;; -;; Generally things that make faces won't set any of the face attributes if -;; you have already given them values via the resource database. You can -;; also change this stuff from your .emacs file, by using the functions -;; set-face-foreground, set-face-font, etc. See the code in this file, and -;; in faces.el. - -(defconst x-font-regexp nil) -(defconst x-font-regexp-head nil) -(defconst x-font-regexp-head-2 nil) -(defconst x-font-regexp-weight nil) -(defconst x-font-regexp-slant nil) -(defconst x-font-regexp-pixel nil) -(defconst x-font-regexp-point nil) -(defconst x-font-regexp-foundry-and-family nil) -(defconst x-font-regexp-registry-and-encoding nil) -(defconst x-font-regexp-spacing nil) - -;;; Regexps matching font names in "Host Portable Character Representation." -;;; -(let ((- "[-?]") - (foundry "[^-]*") - (family "[^-]*") - (weight "\\(bold\\|demibold\\|medium\\|black\\)") ; 1 -; (weight\? "\\(\\*\\|bold\\|demibold\\|medium\\|\\)") ; 1 - (weight\? "\\([^-]*\\)") ; 1 - (slant "\\([ior]\\)") ; 2 -; (slant\? "\\([ior?*]?\\)") ; 2 - (slant\? "\\([^-]?\\)") ; 2 -; (swidth "\\(\\*\\|normal\\|semicondensed\\|\\)") ; 3 - (swidth "\\([^-]*\\)") ; 3 -; (adstyle "\\(\\*\\|sans\\|\\)") ; 4 - (adstyle "\\([^-]*\\)") ; 4 - (pixelsize "\\(\\*\\|[0-9]+\\)") ; 5 - (pointsize "\\(\\*\\|0\\|[0-9][0-9]+\\)") ; 6 -; (resx "\\(\\*\\|[0-9][0-9]+\\)") ; 7 -; (resy "\\(\\*\\|[0-9][0-9]+\\)") ; 8 - (resx "\\([*0]\\|[0-9][0-9]+\\)") ; 7 - (resy "\\([*0]\\|[0-9][0-9]+\\)") ; 8 - (spacing "[cmp?*]") - (avgwidth "\\(\\*\\|[0-9]+\\)") ; 9 - (registry "[^-]*") ; some fonts have omitted registries -; (encoding ".+") ; note that encoding may contain "-"... - (encoding "[^-]+") ; false! - ) - (setq x-font-regexp - (purecopy - (concat "\\`\\*?[-?*]" - foundry - family - weight\? - slant\? - swidth - adstyle - - pixelsize - pointsize - resx - resy - spacing - avgwidth - - registry - encoding "\\'" - ))) - (setq x-font-regexp-head - (purecopy - (concat "\\`[-?*]" foundry - family - weight\? - slant\? - "\\([-*?]\\|\\'\\)"))) - (setq x-font-regexp-head-2 - (purecopy - (concat "\\`[-?*]" foundry - family - weight\? - slant\? - - swidth - adstyle - pixelsize - pointsize - "\\([-*?]\\|\\'\\)"))) - (setq x-font-regexp-slant (purecopy (concat - slant -))) - (setq x-font-regexp-weight (purecopy (concat - weight -))) - ;; if we can't match any of the more specific regexps (unfortunate) then - ;; look for digits; assume 2+ digits is 10ths of points, and 1-2 digits - ;; is pixels. Bogus as hell. - (setq x-font-regexp-pixel (purecopy "[-?*]\\([0-9][0-9]?\\)[-?*]")) - (setq x-font-regexp-point (purecopy "[-?*]\\([0-9][0-9]+\\)[-?*]")) - ;; the following two are used by x-font-menu.el. - (setq x-font-regexp-foundry-and-family - (purecopy (concat "\\`[-?*]" foundry - "\\(" family "\\)" -))) - (setq x-font-regexp-registry-and-encoding - (purecopy (concat - "\\(" registry "\\)" - "\\(" encoding "\\)\\'"))) - (setq x-font-regexp-spacing - (purecopy (concat - "\\(" spacing "\\)" - avgwidth - - registry - encoding "\\'"))) - ) - -;; A "loser font" is something like "8x13" -> "8x13bold". -;; These are supported only through extreme generosity. -(defconst x-loser-font-regexp (purecopy "\\`[0-9]+x[0-9]+\\'")) - -(defun x-frob-font-weight (font which) - (if (font-instance-p font) (setq font (font-instance-name font))) - (cond ((null font) nil) - ((or (string-match x-font-regexp font) - (string-match x-font-regexp-head font) - (string-match x-font-regexp-weight font)) - (concat (substring font 0 (match-beginning 1)) which - (substring font (match-end 1)))) - ((string-match x-loser-font-regexp font) - (concat font which)) - (t nil))) - -(defun x-frob-font-slant (font which) - (if (font-instance-p font) (setq font (font-instance-name font))) - (cond ((null font) nil) - ((or (string-match x-font-regexp font) - (string-match x-font-regexp-head font)) - (concat (substring font 0 (match-beginning 2)) which - (substring font (match-end 2)))) - ((string-match x-font-regexp-slant font) - (concat (substring font 0 (match-beginning 1)) which - (substring font (match-end 1)))) - ((string-match x-loser-font-regexp font) - (concat font which)) - (t nil))) - -(defun try-font-name (name &optional device) - ;; yes, name really should be here twice. - (and name (make-font-instance name device t) name)) - -(defun x-make-font-bold (font &optional device) - "Given an X font specification, this attempts to make a `bold' font. -If it fails, it returns nil." - ;; Certain Type1 fonts know "bold" as "black"... - (or (try-font-name (x-frob-font-weight font "bold") device) - (try-font-name (x-frob-font-weight font "black") device) - (try-font-name (x-frob-font-weight font "demibold") device))) - -(defun x-make-font-unbold (font &optional device) - "Given an X font specification, this attempts to make a non-bold font. -If it fails, it returns nil." - (try-font-name (x-frob-font-weight font "medium") device)) - -(defcustom *try-oblique-before-italic-fonts* nil - "*If nil, italic fonts are searched before oblique fonts. -If non-nil, oblique fonts are tried before italic fonts. This is mostly -applicable to adobe-courier fonts" - :type 'boolean - :tag "Try Oblique Before Italic Fonts" - :group 'x) - -(defun x-make-font-italic (font &optional device) - "Given an X font specification, this attempts to make an `italic' font. -If it fails, it returns nil." - (if *try-oblique-before-italic-fonts* - (or (try-font-name (x-frob-font-slant font "o") device) - (try-font-name (x-frob-font-slant font "i") device)) - (or (try-font-name (x-frob-font-slant font "i") device) - (try-font-name (x-frob-font-slant font "o") device)))) - -(defun x-make-font-unitalic (font &optional device) - "Given an X font specification, this attempts to make a non-italic font. -If it fails, it returns nil." - (try-font-name (x-frob-font-slant font "r") device)) - -(defun x-make-font-bold-italic (font &optional device) - "Given an X font specification, this attempts to make a `bold-italic' font. -If it fails, it returns nil." - ;; This is haired up to avoid loading the "intermediate" fonts. - (or (try-font-name - (x-frob-font-slant (x-frob-font-weight font "bold") "i") device) - (try-font-name - (x-frob-font-slant (x-frob-font-weight font "bold") "o") device) - (try-font-name - (x-frob-font-slant (x-frob-font-weight font "black") "i") device) - (try-font-name - (x-frob-font-slant (x-frob-font-weight font "black") "o") device) - (try-font-name - (x-frob-font-slant (x-frob-font-weight font "demibold") "i") device) - (try-font-name - (x-frob-font-slant (x-frob-font-weight font "demibold") "o") device))) - -(defun x-font-size (font) - "Return the nominal size of the given font. -This is done by parsing its name, so it's likely to lose. -X fonts can be specified (by the user) in either pixels or 10ths of points, - and this returns the first one it finds, so you have to decide which units - the returned value is measured in yourself..." - (if (font-instance-p font) (setq font (font-instance-name font))) - (cond ((or (string-match x-font-regexp font) - (string-match x-font-regexp-head-2 font)) - (string-to-int (substring font (match-beginning 6) (match-end 6)))) - ((or (string-match x-font-regexp-pixel font) - (string-match x-font-regexp-point font)) - (string-to-int (substring font (match-beginning 1) (match-end 1)))) - (t nil))) - -;; Given a font name, this function returns a list describing all fonts -;; of all sizes that otherwise match the given font spec. Each element -;; in the list is a list of three items: the pixel size of the font, -;; the point size (in 1/10ths of a point) of the font, and the fully- -;; qualified font name. The first two values may be zero; this -;; refers to a scalable font. - -(defun x-available-font-sizes (font device) - (if (font-instance-p font) (setq font (font-instance-name font))) - (cond ((string-match x-font-regexp font) - ;; turn pixelsize, pointsize, and avgwidth into wildcards - (setq font - (concat (substring font 0 (match-beginning 5)) "*" - (substring font (match-end 5) (match-beginning 6)) "*" - (substring font (match-end 6) (match-beginning 9)) "*" - (substring font (match-end 9) (match-end 0))))) - ((string-match x-font-regexp-head-2 font) - ;; turn pixelsize and pointsize into wildcards - (setq font - (concat (substring font 0 (match-beginning 5)) "*" - (substring font (match-end 5) (match-beginning 6)) "*" - (substring font (match-end 6) (match-end 0))))) - ((string-match "[-?*]\\([0-9]+\\)[-?*]" font) - ;; Turn the first integer we match into a wildcard. - ;; This is pretty dubious... - (setq font - (concat (substring font 0 (match-beginning 1)) "*" - (substring font (match-end 1) (match-end 0)))))) - (sort - (delq nil - (mapcar (function - (lambda (name) - (and (string-match x-font-regexp name) - (list - (string-to-int (substring name (match-beginning 5) - (match-end 5))) - (string-to-int (substring name (match-beginning 6) - (match-end 6))) - name)))) - (list-fonts font device))) - (function (lambda (x y) (if (= (nth 1 x) (nth 1 y)) - (< (nth 0 x) (nth 0 y)) - (< (nth 1 x) (nth 1 y))))))) - -;; Given a font name, this attempts to construct a valid font name for -;; DEVICE whose size is the next smaller (if UP-P is nil) or larger -;; (if UP-P is t) size and whose other characteristics are the same -;; as the given font. - -(defun x-frob-font-size (font up-p device) - (if (stringp font) (setq font (make-font-instance font device))) - (if (font-instance-p font) (setq font (font-instance-truename font))) - (let ((available (and font - (x-available-font-sizes font device)))) - (cond - ((null available) nil) - ((or (= 0 (nth 0 (car available))) - (= 0 (nth 1 (car available)))) - ;; R5 scalable fonts: change size by 1 point. - ;; If they're scalable the first font will have pixel or point = 0. - ;; Sometimes one is 0 and the other isn't (if it's a bitmap font that - ;; can be scaled), sometimes both are (if it's a true outline font). - (let ((name (nth 2 (car available))) - old-size) - (or (string-match x-font-regexp font) (error "can't parse %S" font)) - (setq old-size (string-to-int - (substring font (match-beginning 6) (match-end 6)))) - (or (> old-size 0) (error "font truename has 0 pointsize?")) - (or (string-match x-font-regexp name) (error "can't parse %S" name)) - ;; turn pixelsize into a wildcard, and make pointsize be +/- 10, - ;; which is +/- 1 point. All other fields stay the same as they - ;; were in the "template" font returned by x-available-font-sizes. - ;; - ;; #### But this might return the same font: for example, if the - ;; truename of "-*-courier-medium-r-normal--*-230-75-75-m-0-*" - ;; is "...-240-..." (instead of 230) then this loses, because - ;; the 230 that was passed in as an arg got turned into 240 - ;; by the call to font-instance-truename; then we decrement that - ;; by 10 and return the result which is the same. I think the - ;; way to fix this is to make this be a loop that keeps trying - ;; progressively larger pointsize deltas until it finds one - ;; whose truename differs. Have to be careful to avoid infinite - ;; loops at the upper end... - ;; - (concat (substring name 0 (match-beginning 5)) "*" - (substring name (match-end 5) (match-beginning 6)) - (int-to-string (+ old-size (if up-p 10 -10))) - (substring name (match-end 6) (match-end 0))))) - (t - ;; non-scalable fonts: take the next available size. - (let ((rest available) - (last nil) - result) - (setq font (downcase font)) - (while rest - (cond ((and (not up-p) (equal font (downcase (nth 2 (car rest))))) - (setq result last - rest nil)) - ((and up-p (equal font (and last (downcase (nth 2 last))))) - (setq result (car rest) - rest nil))) - (setq last (car rest)) - (setq rest (cdr rest))) - (nth 2 result)))))) - -(defun x-find-smaller-font (font &optional device) - "Loads a new, slightly smaller version of the given font (or font name). -Returns the font if it succeeds, nil otherwise. -If scalable fonts are available, this returns a font which is 1 point smaller. -Otherwise, it returns the next smaller version of this font that is defined." - (x-frob-font-size font nil device)) - -(defun x-find-larger-font (font &optional device) - "Loads a new, slightly larger version of the given font (or font name). -Returns the font if it succeeds, nil otherwise. -If scalable fonts are available, this returns a font which is 1 point larger. -Otherwise, it returns the next larger version of this font that is defined." - (x-frob-font-size font t device)) - -(defalias 'x-make-face-bold 'make-face-bold) -(defalias 'x-make-face-italic 'make-face-italic) -(defalias 'x-make-face-bold-italic 'make-face-bold-italic) -(defalias 'x-make-face-unbold 'make-face-unbold) -(defalias 'x-make-face-unitalic 'make-face-unitalic) - -(make-obsolete 'x-make-face-bold 'make-face-bold) -(make-obsolete 'x-make-face-italic 'make-face-italic) -(make-obsolete 'x-make-face-bold-italic 'make-face-bold-italic) -(make-obsolete 'x-make-face-unbold 'make-face-unbold) -(make-obsolete 'x-make-face-unitalic 'make-face-unitalic) - - -;; Define some logical color names to be used when reading the pixmap files. -(if (featurep 'xpm) - (setq xpm-color-symbols - (list - (purecopy '("foreground" (face-foreground 'default))) - (purecopy '("background" (face-background 'default))) - (purecopy '("backgroundToolBarColor" - (x-get-resource "backgroundToolBarColor" - "BackgroundToolBarColor" 'string))) - ))) - -;;; internal routines - -;;; x-init-face-from-resources is responsible for initializing a -;;; newly-created face from the resource database. -;;; -;;; When a new frame is created, it is called from `x-init-frame-faces' -;;; called from `init-frame-faces' called from init_frame_faces() -;;; from Fmake_frame(). In this case it is called once for each existing -;;; face, with the newly-created frame as the argument. It then initializes -;;; the newly-created faces on that frame. -;;; -;;; It's also called from `init-device-faces' and -;;; `init-global-faces'. -;;; -;;; This had better not signal an error. The frame is in an intermediate -;;; state where signalling an error or entering the debugger would likely -;;; result in a crash. - -(defun x-init-face-from-resources (face &optional locale set-anyway) - - ;; - ;; These are things like "attributeForeground" instead of simply - ;; "foreground" because people tend to do things like "*foreground", - ;; which would cause all faces to be fully qualified, making faces - ;; inherit attributes in a non-useful way. So we've made them slightly - ;; less obvious to specify in order to make them work correctly in - ;; more random environments. - ;; - ;; I think these should be called "face.faceForeground" instead of - ;; "face.attributeForeground", but they're the way they are for - ;; hysterical reasons. (jwz) - - (let* ((append (if set-anyway nil 'append)) - (face-sym (face-name face)) - (name (symbol-name face-sym)) - (fn (x-get-resource-and-maybe-bogosity-check - (concat name ".attributeFont") - "Face.AttributeFont" - 'string locale)) - (fg (x-get-resource-and-maybe-bogosity-check - (concat name ".attributeForeground") - "Face.AttributeForeground" - 'string locale)) - (bg (x-get-resource-and-maybe-bogosity-check - (concat name ".attributeBackground") - "Face.AttributeBackground" - 'string locale)) - (bgp (x-get-resource-and-maybe-bogosity-check - (concat name ".attributeBackgroundPixmap") - "Face.AttributeBackgroundPixmap" - 'string locale)) - (ulp (x-get-resource-and-maybe-bogosity-check - (concat name ".attributeUnderline") - "Face.AttributeUnderline" - 'boolean locale)) - (stp (x-get-resource-and-maybe-bogosity-check - (concat name ".attributeStrikethru") - "Face.AttributeStrikethru" - 'boolean locale)) - ;; we still resource for these TTY-only resources so that - ;; you can specify resources for TTY frames/devices. This is - ;; useful when you start up your XEmacs on an X display and later - ;; open some TTY frames. - (hp (x-get-resource-and-maybe-bogosity-check - (concat name ".attributeHighlight") - "Face.AttributeHighlight" - 'boolean locale)) - (dp (x-get-resource-and-maybe-bogosity-check - (concat name ".attributeDim") - "Face.AttributeDim" - 'boolean locale)) - (bp (x-get-resource-and-maybe-bogosity-check - (concat name ".attributeBlinking") - "Face.AttributeBlinking" - 'boolean locale)) - (rp (x-get-resource-and-maybe-bogosity-check - (concat name ".attributeReverse") - "Face.AttributeReverse" - 'boolean locale)) - ) - - ;; - ;; If this is the default face, then any unspecified properties should - ;; be defaulted from the global properties. Can't do this for - ;; frames or devices because then, common resource specs like - ;; "*Foreground: black" will have unwanted effects. - ;; - (if (and (eq (face-name face) 'default) - (or (null locale) (eq locale 'global))) - (progn - (or fn (setq fn (x-get-resource - "font" "Font" 'string locale))) - (or fg (setq fg (x-get-resource - "foreground" "Foreground" 'string locale))) - (or bg (setq bg (x-get-resource - "background" "Background" 'string locale))))) - ;; - ;; "*cursorColor: foo" is equivalent to setting the background of the - ;; text-cursor face. - ;; - (if (and (eq (face-name face) 'text-cursor) - (or (null locale) (eq locale 'global))) - (setq bg (or (x-get-resource - "cursorColor" "CursorColor" 'string locale) bg))) - ;; #### should issue warnings? I think this should be - ;; done when the instancing actually happens, but I'm not - ;; sure how it should actually be dealt with. - (if fn - (set-face-font face fn locale nil append)) - ;; Kludge-o-rooni. Set the foreground and background resources for - ;; X devices only -- otherwise things tend to get all messed up - ;; if you start up an X frame and then later create a TTY frame. - (if fg - (set-face-foreground face fg locale 'x append)) - (if bg - (set-face-background face bg locale 'x append)) - (if bgp - (set-face-background-pixmap face bgp locale nil append)) - (if ulp - (set-face-underline-p face ulp locale nil append)) - (if stp - (set-face-strikethru-p face stp locale nil append)) - (if hp - (set-face-highlight-p face hp locale nil append)) - (if dp - (set-face-dim-p face dp locale nil append)) - (if bp - (set-face-blinking-p face bp locale nil append)) - (if rp - (set-face-reverse-p face rp locale nil append)) - )) - -;; GNU Emacs compatibility. (move to obsolete.el?) -(defalias 'make-face-x-resource-internal 'x-init-face-from-resources) - -;;; x-init-global-faces is responsible for ensuring that the -;;; default face has some reasonable fallbacks if nothing else is -;;; specified. -;;; -(defun x-init-global-faces () - (or (face-font 'default 'global) - (set-face-font 'default - "-*-courier-medium-r-*-*-*-120-*-*-*-*-iso8859-*") - 'global) - (or (face-foreground 'default 'global) - (set-face-foreground 'default "black" 'global 'x)) - (or (face-background 'default 'global) - (set-face-background 'default "gray80" 'global 'x))) - -;;; x-init-device-faces is responsible for initializing default -;;; values for faces on a newly created device. -;;; -(defun x-init-device-faces (device) - ;; - ;; If the "default" face didn't have a font specified, try to pick one. - ;; - (or - (face-font-instance 'default device) - ;; - ;; No font specified in the resource database; try to cope. - ;; - ;; At first I wanted to do this by just putting a font-spec in the - ;; fallback resources passed to XtAppInitialize(), but that fails - ;; if there is an Emacs app-defaults file which doesn't specify a - ;; font: apparently the fallback resources are not consulted when - ;; there is an app-defaults file, which seems pretty bogus to me. - ;; - ;; We should also probably try "*xtDefaultFont", but I think that it - ;; might be legal to specify that as "xtDefaultFont:", that is, at - ;; top level, instead of "*xtDefaultFont:", that is, applicable to - ;; every application. `x-get-resource' can't handle that right now. - ;; Anyway, xtDefaultFont is probably variable-width. - ;; - ;; Some who have LucidaTypewriter think it's a better font than Courier, - ;; but it has the bug that there are no italic and bold italic versions. - ;; We could hair this code up to try and mix-and-match fonts to get a - ;; full complement, but really, why bother. It's just a default. - ;; - (let (new-x-font) - (setq new-x-font (or - ;; - ;; We default to looking for iso8859 fonts. Using a wildcard for the - ;; encoding would be bad, because that can cause English speakers to get - ;; Kanji fonts by default. It is safe to assume that people using a - ;; language other than English have both set $LANG, and have specified - ;; their `font' and `fontList' resources. In any event, it's better to - ;; err on the side of the English speaker in this case because they are - ;; much less likely to have encountered this problem, and are thus less - ;; likely to know what to do about it. - - ;; Try for Courier. Almost everyone has that. (Does anyone not?) - (make-font-instance - "-*-courier-medium-r-*-*-*-120-*-*-*-*-iso8859-*" device t) - (make-font-instance - "-*-courier-*-r-*-*-*-120-*-*-*-*-iso8859-*" device t) - ;; Next try for any "medium" charcell or monospaced iso8859 font. - (make-font-instance "-*-*-medium-r-*-*-*-120-*-*-m-*-iso8859-*" device t) - (make-font-instance "-*-*-medium-r-*-*-*-120-*-*-c-*-iso8859-*" device t) - ;; Next try for any charcell or monospaced iso8859 font. - (make-font-instance "-*-*-*-r-*-*-*-120-*-*-m-*-iso8859-*" device t) - (make-font-instance "-*-*-*-r-*-*-*-120-*-*-c-*-iso8859-*" device t) - ;; Ok, let's at least try to stay in 8859... - (make-font-instance "-*-*-*-r-*-*-*-120-*-*-*-*-iso8859-*" device t) - ;; Boy, we sure are losing now. Try the above, but in any encoding. - (make-font-instance "-*-*-medium-r-*-*-*-120-*-*-m-*-*-*" device t) - (make-font-instance "-*-*-medium-r-*-*-*-120-*-*-c-*-*-*" device t) - (make-font-instance "-*-*-*-r-*-*-*-120-*-*-m-*-*-*" device t) - (make-font-instance "-*-*-*-r-*-*-*-120-*-*-c-*-*-*" device t) - (make-font-instance "-*-*-*-r-*-*-*-120-*-*-*-*-*-*" device t) - ;; Hello? Please? - (make-font-instance "-*-*-*-*-*-*-*-120-*-*-*-*-*-*" device t) - (make-font-instance "*" device t) - ;; if we get to here we're screwed, and faces.c will fatal()... - )) - (if (not (face-font 'default 'global)) - (set-face-font 'default new-x-font) - (set-face-font 'default new-x-font device)))) - ;; - ;; If the "default" face didn't have both colors specified, then pick - ;; some, taking into account whether one of the colors was specified. - ;; - (let ((fg (face-foreground-instance 'default device)) - (bg (face-background-instance 'default device))) - (if (not (and fg bg)) - (if (or (and fg (equal (downcase (color-instance-name fg)) "white")) - (and bg (equal (downcase (color-instance-name bg)) "black"))) - (progn - (or fg (set-face-foreground 'default "white" device)) - (or bg (set-face-background 'default "black" device))) - (or fg (set-face-foreground 'default "white" device)) - (or bg (set-face-background 'default "black" device))))) - - ;; Don't look at reverseVideo now or initialize the modeline. This - ;; is done on a per-frame basis at the appropriate time. - - ;; - ;; Now let's try to pick some reasonable defaults for a few other faces. - ;; This kind of stuff should normally go on the create-frame-hook, but - ;; this way we won't be in danger of the user screwing things up by not - ;; adding hooks in a safe way. - ;; - (x-init-pointer-shape device) ; from x-mouse.el - ) - -;;; This is called from `init-frame-faces', which is called from -;;; init_frame_faces() which is called from Fmake_frame(), to perform -;;; any device-specific initialization. -;;; -(defun x-init-frame-faces (frame) - ;; - ;; The faces already got initialized (by init-frame-faces) from - ;; the resource database or global, non-frame faces. The default, - ;; bold, bold-italic, and italic faces (plus various other random faces) - ;; got set up then. But modeline didn't so that reverseVideo can be - ;; frame-specific. - ;; - - ;; - ;; If reverseVideo was specified, swap the foreground and background - ;; of the default and modeline faces. - ;; - (cond ((car (x-get-resource "reverseVideo" "ReverseVideo" 'boolean frame)) - ;; First make sure the modeline has fg and bg, inherited from the - ;; current default face - for the case where only one is specified, - ;; so that invert-face doesn't do something weird. - (or (face-foreground 'modeline frame) - (set-face-foreground 'modeline - (face-foreground-instance 'default frame) - frame)) - (or (face-background 'modeline frame) - (set-face-background 'modeline - (face-background-instance 'default frame) - frame)) - ;; Now invert both of them. If they end up looking the same, - ;; make-frame-initial-faces will invert the modeline again later. - (invert-face 'default frame) - (invert-face 'modeline frame) - )))
--- a/lisp/x11/x-font-menu.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,564 +0,0 @@ -;; x-font-menu.el --- Managing menus of X fonts. - -;; Copyright (C) 1994 Free Software Foundation, Inc. -;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp. -;; Copyright (C) 1997 Sun Microsystems - -;; Author: Jamie Zawinski <jwz@netscape.com> -;; Restructured by: Jonathan Stigelman <Stig@hackvan.com> -;; Mule-ized by: Martin Buchholz - -;; 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, 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: -;;; -;;; Creates three menus, "Font", "Size", and "Weight", and puts them on the -;;; "Options" menu. The contents of these menus are the superset of those -;;; properties available on any fonts, but only the intersection of the three -;;; sets is selectable at one time. -;;; -;;; Known Problems: -;;; =============== -;;; Items on the Font menu are selectable if and only if that font exists in -;;; the same size and weight as the current font. This means that some fonts -;;; are simply not reachable from some other fonts - if only one font comes -;;; in only one point size (like "Nil", which comes only in 2), you will never -;;; be able to select it. It would be better if the items on the Fonts menu -;;; were always selectable, and selecting them would set the size to be the -;;; closest size to the current font's size. -;;; -;;; This attempts to change all other faces in an analagous way to the change -;;; that was made to the default face; if it can't, it will skip over the face. -;;; However, this could leave incongruous font sizes around, which may cause -;;; some nonreversibility problems if further changes are made. Perhaps it -;;; should remember the initial fonts of all faces, and derive all subsequent -;;; fonts from that initial state. -;;; -;;; xfontsel(1) is a lot more flexible (but probably harder to understand). -;;; -;;; The code to construct menus from all of the x11 fonts available from the -;;; server is autoloaded and executed the very first time that one of the Font -;;; menus is selected on each device. That is, if XEmacs has frames on two -;;; different devices, then separate font menu information will be maintained -;;; for each X display. If the font path changes after emacs has already -;;; asked the X server on a particular display for its list of fonts, this -;;; won't notice. Also, the first time that a font menu is posted on each -;;; display will entail a lengthy delay, but that's better than slowing down -;;; XEmacs startup. At any time (i.e.: after a font-path change or -;;; immediately after device creation), you can call -;;; `reset-device-font-menus' to rebuild the menus from all currently -;;; available fonts. -;;; -;;; There is knowledge here about the regexp match numbers in -;;; `x-font-regexp' and `x-font-regexp-foundry-and-family' defined in -;;; x-faces.el. -;;; -;;; There are at least three kinds of fonts under X11r5: -;;; -;;; - bitmap fonts, which can be assumed to look as good as possible; -;;; - bitmap fonts which have been (or can be) automatically scaled to -;;; a new size, and which almost always look awful; -;;; - and true outline fonts, which should look ok at any size, but in -;;; practice (on at least some systems) look awful at any size, and -;;; even in theory are unlikely ever to look as good as non-scaled -;;; bitmap fonts. -;;; -;;; It would be nice to get this code to look for non-scaled bitmap fonts -;;; first, then outline fonts, then scaled bitmap fonts as a last resort. -;;; But it's not clear to me how to tell them apart based on their truenames -;;; and/or the result of XListFonts(). I welcome any and all explanations -;;; of the subtleties involved... -;;; -;;; -;;; If You Think You'Re Seeing A Bug: -;;; ================================= -;;; When reporting problems, send the following information: -;;; -;;; - Exactly what behavior you're seeing; -;;; - The output of the `xlsfonts' program; -;;; - The value of the variable `device-fonts-cache'; -;;; - The values of the following expressions, both before and after -;;; making a selection from any of the fonts-related menus: -;;; (face-font 'default) -;;; (font-truename (face-font 'default)) -;;; (font-properties (face-font 'default)) -;;; - The values of the following variables after making a selection: -;;; font-menu-preferred-resolution -;;; font-menu-registry-encoding -;;; -;;; There is a common misconception that "*-courier-medium-r-*-11-*", also -;;; known as "-adobe-courier-medium-r-normal--11-80-100-100-m-60-iso8859-1", -;;; is an 11-point font. It is not -- it is an 11-pixel font at 100dpi, -;;; which is an 8-point font (the number after -11- is the size in tenths -;;; of points). So if you expect to be seeing an "11" entry in the "Size" -;;; menu and are not, this may be why. -;;; -;;; In the real world (aka Solaris), one has to deal with fonts that -;;; appear to be medium-i but are really light-r, and fonts that -;;; resolve to different resolutions depending on the charset: -;;; -;;; (font-instance-truename -;;; (make-font-instance "-*-mincho-medium-i-normal-*-*-*-*-*-*-*-jisx0201*-*")) -;;; ==> -;;; "-morisawa-ryumin light kl-light-r-normal--10-100-72-72-m-50-jisx0201.1976-0" -;;; -;;; (list-fonts "-dt-interface user-medium-r-normal-s*-*-*-*-*-*-*-*-*") -;;; ==> -;;; ("-dt-interface user-medium-r-normal-s sans-12-120-72-72-m-70-iso8859-1" -;;; "-dt-interface user-medium-r-normal-s-14-120-75-75-m-120-jisx0208.1983-0" -;;; "-dt-interface user-medium-r-normal-s-14-120-75-75-m-60-jisx0201.1976-0") - -;;; Code: - -;; #### - implement these... -;; -;;; (defvar font-menu-ignore-proportional-fonts nil -;;; "*If non-nil, then the font menu will only show fixed-width fonts.") - -;;;###autoload -(defcustom font-menu-ignore-scaled-fonts t - "*If non-nil, then the font menu will try to show only bitmap fonts." - :type 'boolean - :group 'x) - -;;;###autoload -(defcustom font-menu-this-frame-only-p nil - "*If non-nil, then changing the default font from the font menu will only -affect one frame instead of all frames." - :type 'boolean - :group 'x) - -;; only call XListFonts (and parse) once per device. -;; ( (device . [parsed-list-fonts family-menu size-menu weight-menu]) ...) -(defvar device-fonts-cache nil) - -(defvar font-menu-registry-encoding nil - "Registry and encoding to use with font menu fonts.") - -(defvar font-menu-preferred-resolution "*-*" - "Preferred horizontal and vertical font menu resolution (e.g. \"75-75\").") - -(defvar fonts-menu-junk-families - (purecopy - (mapconcat - #'identity - '("cursor" "glyph" "symbol" ; Obvious losers. - "\\`Ax...\\'" ; FrameMaker fonts - there are just way too - ; many of these, and there is a different - ; font family for each font face! Losers. - ; "Axcor" -> "Applix Courier Roman", - ; "Axcob" -> "Applix Courier Bold", etc. - ) - "\\|")) - "A regexp matching font families which are uninteresting (e.g. cursor fonts).") - -(eval-when-compile - (defsubst device-fonts-cache () - (or (cdr (assq (selected-device) device-fonts-cache)) - (reset-device-font-menus (selected-device))))) - -(defun hack-font-truename (fn) - "Filter the output of `font-instance-truename' to deal with Japanese fontsets." - (if (string-match "," (font-instance-truename fn)) - (let ((fpnt (nth 8 (split-string (font-instance-name fn) "-"))) - (flist (split-string (font-instance-truename fn) ",")) - ret) - (while flist - (if (string-equal fpnt (nth 8 (split-string (car flist) "-"))) - (progn (setq ret (car flist)) (setq flist nil)) - (setq flist (cdr flist)) - )) - ret) - (font-instance-truename fn))) - -;;;###autoload -(fset 'install-font-menus 'reset-device-font-menus) -(make-obsolete 'install-font-menus 'reset-device-font-menus) - -(defvar x-font-regexp-ascii nil - "This is used to filter out font families that can't display ASCII text. -It must be set at run-time.") - -(defun vassoc (key valist) - "Search VALIST for a vector whose first element is equal to KEY. -See also `assoc'." - ;; by Stig@hackvan.com - (let (el) - (catch 'done - (while (setq el (pop valist)) - (and (equal key (aref el 0)) - (throw 'done el)))))) - -;;;###autoload -(defun reset-device-font-menus (&optional device debug) - "Generates the `Font', `Size', and `Weight' submenus for the Options menu. -This is run the first time that a font-menu is needed for each device. -If you don't like the lazy invocation of this function, you can add it to -`create-device-hook' and that will make the font menus respond more quickly -when they are selected for the first time. If you add fonts to your system, -or if you change your font path, you can call this to re-initialize the menus." - ;; by Stig@hackvan.com - ;; #### - this should implement a `menus-only' option, which would - ;; recalculate the menus from the cache w/o having to do list-fonts again. - (message "Getting list of fonts from server... ") - (if (or noninteractive - (not (or device (setq device (selected-device)))) - (not (eq (device-type device) 'x))) - nil - (unless x-font-regexp-ascii - (setq x-font-regexp-ascii (if (featurep 'mule) - (charset-registry 'ascii) - "iso8859-1"))) - (setq font-menu-registry-encoding - (if (featurep 'mule) "*-*" "iso8859-1")) - (let ((case-fold-search t) - family size weight entry monospaced-p - dev-cache cache families sizes weights) - (dolist (name (cond ((null debug) ; debugging kludge - (list-fonts "*-*-*-*-*-*-*-*-*-*-*-*-*-*" device)) - ((stringp debug) (split-string debug "\n")) - (t debug))) - (when (and (string-match x-font-regexp-ascii name) - (string-match x-font-regexp name)) - (setq weight (capitalize (match-string 1 name)) - size (string-to-int (match-string 6 name))) - (or (string-match x-font-regexp-foundry-and-family name) - (error "internal error")) - (setq family (capitalize (match-string 1 name))) - (or (string-match x-font-regexp-spacing name) - (error "internal error")) - (setq monospaced-p (string= "m" (match-string 1 name))) - (unless (string-match fonts-menu-junk-families family) - (setq entry (or (vassoc family cache) - (car (setq cache - (cons (vector family nil nil t) - cache))))) - (or (member family families) (push family families)) - (or (member weight weights) (push weight weights)) - (or (member size sizes) (push size sizes)) - (or (member weight (aref entry 1)) (push weight (aref entry 1))) - (or (member size (aref entry 2)) (push size (aref entry 2))) - (aset entry 3 (and (aref entry 3) monospaced-p))))) - ;; - ;; Hack scalable fonts. - ;; Some fonts come only in scalable versions (the only size is 0) - ;; and some fonts come in both scalable and non-scalable versions - ;; (one size is 0). If there are any scalable fonts at all, make - ;; sure that the union of all point sizes contains at least some - ;; common sizes - it's possible that some sensible sizes might end - ;; up not getting mentioned explicitly. - ;; - (if (member 0 sizes) - (let ((common '(60 80 100 120 140 160 180 240))) - (while common - (or;;(member (car common) sizes) ; not enough slack - (let ((rest sizes) - (done nil)) - (while (and (not done) rest) - (if (and (> (car common) (- (car rest) 5)) - (< (car common) (+ (car rest) 5))) - (setq done t)) - (setq rest (cdr rest))) - done) - (setq sizes (cons (car common) sizes))) - (setq common (cdr common))) - (setq sizes (delq 0 sizes)))) - - (setq families (sort families 'string-lessp) - weights (sort weights 'string-lessp) - sizes (sort sizes '<)) - - (dolist (entry cache) - (aset entry 1 (sort (aref entry 1) 'string-lessp)) - (aset entry 2 (sort (aref entry 2) '<))) - - (message "Getting list of fonts from server... done.") - - (setq dev-cache (assq device device-fonts-cache)) - (or dev-cache - (setq dev-cache (car (push (list device) device-fonts-cache)))) - (setcdr - dev-cache - (vector - cache - (mapcar (lambda (x) - (vector x - (list 'font-menu-set-font x nil nil) - ':style 'radio ':active nil ':selected nil)) - families) - (mapcar (lambda (x) - (vector (if (/= 0 (% x 10)) - ;; works with no LISP_FLOAT_TYPE - (concat (int-to-string (/ x 10)) "." - (int-to-string (% x 10))) - (int-to-string (/ x 10))) - (list 'font-menu-set-font nil nil x) - ':style 'radio ':active nil ':selected nil)) - sizes) - (mapcar (lambda (x) - (vector x - (list 'font-menu-set-font nil x nil) - ':style 'radio ':active nil ':selected nil)) - weights))) - (cdr dev-cache)))) - -;; Extract font information from a face. We examine both the -;; user-specified font name and the canonical (`true') font name. -;; These can appear to have totally different properties. -;; For examples, see the prolog above. - -;; We use the user-specified one if possible, else use the truename. -;; If the user didn't specify one (with "-dt-*-*", for example) -;; get the truename and use the possibly suboptimal data from that. -(defun* font-menu-font-data (face dcache) - (let* ((case-fold-search t) - (domain (if font-menu-this-frame-only-p - (selected-frame) - (selected-device))) - (name (font-instance-name (face-font-instance face domain))) - (truename (font-instance-truename - (face-font-instance face domain - (if (featurep 'mule) 'ascii)))) - family size weight entry slant) - (when (string-match x-font-regexp-foundry-and-family name) - (setq family (capitalize (match-string 1 name))) - (setq entry (vassoc family (aref dcache 0)))) - (when (and (null entry) - (string-match x-font-regexp-foundry-and-family truename)) - (setq family (capitalize (match-string 1 truename))) - (setq entry (vassoc family (aref dcache 0)))) - (when (null entry) - (return-from font-menu-font-data (make-vector 5 nil))) - - (when (string-match x-font-regexp name) - (setq weight (capitalize (match-string 1 name))) - (setq size (string-to-int (match-string 6 name)))) - - (when (string-match x-font-regexp truename) - (when (not (member weight (aref entry 1))) - (setq weight (capitalize (match-string 1 truename)))) - (when (not (member size (aref entry 2))) - (setq size (string-to-int (match-string 6 truename)))) - (setq slant (capitalize (match-string 2 truename)))) - - (vector entry family size weight slant))) - -;;;###autoload -(defun font-menu-family-constructor (ignored) - (catch 'menu - (unless (eq 'x (device-type (selected-device))) - (throw 'menu '(["Cannot parse current font" ding nil]))) - (let* ((dcache (device-fonts-cache)) - (font-data (font-menu-font-data 'default dcache)) - (entry (aref font-data 0)) - (family (aref font-data 1)) - (size (aref font-data 2)) - (weight (aref font-data 3)) - f) - (unless family - (throw 'menu '(["Cannot parse current font" ding nil]))) - ;; Items on the Font menu are enabled iff that font exists in - ;; the same size and weight as the current font (scalable fonts - ;; exist in every size). Only the current font is marked as - ;; selected. - (mapcar - (lambda (item) - (setq f (aref item 0) - entry (vassoc f (aref dcache 0))) - (if (and (member weight (aref entry 1)) - (or (member size (aref entry 2)) - (and (not font-menu-ignore-scaled-fonts) - (member 0 (aref entry 2))))) - (enable-menu-item item) - (disable-menu-item item)) - (if (string-equal family f) - (select-toggle-menu-item item) - (deselect-toggle-menu-item item)) - item) - (aref dcache 1))))) - -;;;###autoload -(defun font-menu-size-constructor (ignored) - (catch 'menu - (unless (eq 'x (device-type (selected-device))) - (throw 'menu '(["Cannot parse current font" ding nil]))) - (let* ((dcache (device-fonts-cache)) - (font-data (font-menu-font-data 'default dcache)) - (entry (aref font-data 0)) - (family (aref font-data 1)) - (size (aref font-data 2)) - ;;(weight (aref font-data 3)) - s) - (unless family - (throw 'menu '(["Cannot parse current font" ding nil]))) - ;; Items on the Size menu are enabled iff current font has - ;; that size. Only the size of the current font is selected. - ;; (If the current font comes in size 0, it is scalable, and - ;; thus has every size.) - (mapcar - (lambda (item) - (setq s (nth 3 (aref item 1))) - (if (or (member s (aref entry 2)) - (and (not font-menu-ignore-scaled-fonts) - (member 0 (aref entry 2)))) - (enable-menu-item item) - (disable-menu-item item)) - (if (eq size s) - (select-toggle-menu-item item) - (deselect-toggle-menu-item item)) - item) - (aref dcache 2))))) - -;;;###autoload -(defun font-menu-weight-constructor (ignored) - (catch 'menu - (unless (eq 'x (device-type (selected-device))) - (throw 'menu '(["Cannot parse current font" ding nil]))) - (let* ((dcache (device-fonts-cache)) - (font-data (font-menu-font-data 'default dcache)) - (entry (aref font-data 0)) - (family (aref font-data 1)) - ;;(size (aref font-data 2)) - (weight (aref font-data 3)) - w) - (unless family - (throw 'menu '(["Cannot parse current font" ding nil]))) - ;; Items on the Weight menu are enabled iff current font - ;; has that weight. Only the weight of the current font - ;; is selected. - (mapcar - (lambda (item) - (setq w (aref item 0)) - (if (member w (aref entry 1)) - (enable-menu-item item) - (disable-menu-item item)) - (if (string-equal weight w) - (select-toggle-menu-item item) - (deselect-toggle-menu-item item)) - item) - (aref dcache 3))))) - - -;;; Changing font sizes - -(defun font-menu-set-font (family weight size) - ;; This is what gets run when an item is selected from any of the three - ;; fonts menus. It needs to be rather clever. - ;; (size is measured in 10ths of points.) - (let* ((dcache (device-fonts-cache)) - (font-data (font-menu-font-data 'default dcache)) - (from-family (aref font-data 1)) - (from-size (aref font-data 2)) - (from-weight (aref font-data 3)) - (from-slant (aref font-data 4)) - new-default-face-font) - (unless from-family - (signal 'error '("couldn't parse font name for default face"))) - (setq new-default-face-font - (font-menu-load-font (or family from-family) - (or weight from-weight) - (or size from-size) - from-slant - font-menu-preferred-resolution)) - (dolist (face (delq 'default (face-list))) - (when (face-font-instance face) - (message "Changing font of `%s'..." face) - (condition-case c - (font-menu-change-face face - from-family from-weight from-size - family weight size) - (error - (display-error c nil) - (sit-for 1))))) - ;; Set the default face's font after hacking the other faces, so that - ;; the frame size doesn't change until we are all done. - - ;;; WMP - we need to honor font-menu-this-frame-only-p here! - (set-face-font 'default new-default-face-font - (and font-menu-this-frame-only-p (selected-frame))) - (message "Font %s" (face-font-name 'default)))) - - -(defun font-menu-change-face (face - from-family from-weight from-size - to-family to-weight to-size) - (or (symbolp face) (signal 'wrong-type-argument (list 'symbolp face))) - (let* ((dcache (device-fonts-cache)) - (font-data (font-menu-font-data face dcache)) - (face-family (aref font-data 1)) - (face-size (aref font-data 2)) - (face-weight (aref font-data 3)) - (face-slant (aref font-data 4))) - - (or face-family - (signal 'error (list "couldn't parse font name for face" face))) - - ;; If this face matches the old default face in the attribute we - ;; are changing, then change it to the new attribute along that - ;; dimension. Also, the face must have its own global attribute. - ;; If its value is inherited, we don't touch it. If any of this - ;; is not true, we leave it alone. - (when (and (face-font face 'global) - (cond - (to-family (string-equal face-family from-family)) - (to-weight (string-equal face-weight from-weight)) - (to-size (= face-size from-size)))) - (set-face-font face - (font-menu-load-font (or to-family face-family) - (or to-weight face-weight) - (or to-size face-size) - face-slant - font-menu-preferred-resolution) - (and font-menu-this-frame-only-p - (selected-frame)))))) - -(defun font-menu-load-font (family weight size slant resolution) - "Try to load a font with the requested properties. -The weight, slant and resolution are only hints." - (when (integerp size) (setq size (int-to-string size))) - (let (font) - (catch 'got-font - (dolist (weight (list weight "*")) - (dolist (slant - (cond ((string-equal slant "O") '("O" "I" "*")) - ((string-equal slant "I") '("I" "O" "*")) - ((string-equal slant "*") '("*")) - (t (list slant "*")))) - (dolist (resolution - (if (string-equal resolution "*-*") - (list resolution) - (list resolution "*-*"))) - (when (setq font - (make-font-instance - (concat "-*-" family "-" weight "-" slant "-*-*-*-" - size "-" resolution "-*-*-" - font-menu-registry-encoding) - nil t)) - (throw 'got-font font)))))))) - -(defun flush-device-fonts-cache (device) - ;; by Stig@hackvan.com - (let ((elt (assq device device-fonts-cache))) - (and elt - (setq device-fonts-cache (delq elt device-fonts-cache))))) - -(add-hook 'delete-device-hook 'flush-device-fonts-cache) - -(provide 'x-font-menu) - -;;; x-font-menu.el ends here
--- a/lisp/x11/x-init.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,325 +0,0 @@ -;;; x-init.el --- initialization code for X windows -;; Copyright (C) 1990, 1993, 1994 Free Software Foundation, Inc. -;; Copyright (C) 1995 Board of Trustees, University of Illinois. -;; Copyright (C) 1995, 1996 Ben Wing. - -;; Author: various -;; Keywords: terminals - -;; 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, 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;;; Code: - -;;; If you want to change this variable, this is the place you must do it. -;;; Do not set it to a string containing periods. X doesn't like that. -;(setq x-emacs-application-class "Emacs") - -;;; selections and active regions - -;;; If and only if zmacs-regions is true: -;;; -;;; When a mark is pushed and the region goes into the "active" state, we -;;; assert it as the Primary selection. This causes it to be hilighted. -;;; When the region goes into the "inactive" state, we disown the Primary -;;; selection, causing the region to be dehilighted. -;;; -;;; Note that it is possible for the region to be in the "active" state -;;; and not be hilighted, if it is in the active state and then some other -;;; application asserts the selection. This is probably not a big deal. - -(defun x-activate-region-as-selection () - (if (marker-buffer (mark-marker t)) - (x-own-selection (cons (point-marker t) (mark-marker t))))) - -;;; OpenWindows-like "find" processing. These functions are really Sunisms, -;;; but we put them here instead of in x-win-sun.el in case someone wants -;;; to use them when not running on a Sun console (presumably after binding -;;; them to different keys, or putting them on menus.) - -(defvar ow-find-last-string nil) -(defvar ow-find-last-clipboard nil) - -(defun ow-find (&optional backward-p) - "Search forward the next occurrence of the text of the selection." - (interactive) - (let ((sel (condition-case () (x-get-selection) (error nil))) - (clip (condition-case () (x-get-clipboard) (error nil))) - text) - (setq text (cond - (sel) - ((not (equal clip ow-find-last-clipboard)) - (setq ow-find-last-clipboard clip)) - (ow-find-last-string) - (t (error "No selection available")))) - (setq ow-find-last-string text) - (cond (backward-p - (search-backward text) - (set-mark (+ (point) (length text)))) - (t - (search-forward text) - (set-mark (- (point) (length text))))) - (zmacs-activate-region))) - -(defun ow-find-backward () - "Search backward for the previous occurrence of the text of the selection." - (interactive) - (ow-find t)) - -;;; Load X-server specific code. -;;; Specifically, load some code to repair the grievous damage that MIT and -;;; Sun have done to the default keymap for the Sun keyboards. - -(eval-when-compile - (defmacro x-define-dead-key (key map) - `(when (x-keysym-on-keyboard-p ,(symbol-name key)) - (define-key function-key-map [,key] ',map)))) - -(defun x-initialize-compose () - "Enable compose 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) - (autoload 'compose-cedilla-map "x-compose" nil t 'keymap) - (autoload 'compose-diaeresis-map "x-compose" nil t 'keymap) - (autoload 'compose-circumflex-map "x-compose" nil t 'keymap) - (autoload 'compose-tilde-map "x-compose" nil t 'keymap) - - (when (x-keysym-on-keyboard-p "Multi_key") - (define-key function-key-map [multi-key] 'compose-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. - - ;; Canonical names: - (x-define-dead-key acute compose-acute-map) - (x-define-dead-key grave compose-grave-map) - (x-define-dead-key cedilla compose-cedilla-map) - (x-define-dead-key diaeresis compose-diaeresis-map) - (x-define-dead-key circumflex compose-circumflex-map) - (x-define-dead-key tilde compose-tilde-map) - (x-define-dead-key degree compose-ring-map) - - ;; Sun according to MIT: - (x-define-dead-key SunFA_Acute compose-acute-map) - (x-define-dead-key SunFA_Grave compose-grave-map) - (x-define-dead-key SunFA_Cedilla compose-cedilla-map) - (x-define-dead-key SunFA_Diaeresis compose-diaeresis-map) - (x-define-dead-key SunFA_Circum compose-circumflex-map) - (x-define-dead-key SunFA_Tilde compose-tilde-map) - - ;; Sun according to OpenWindows 2: - (x-define-dead-key Dead_Grave compose-grave-map) - (x-define-dead-key Dead_Circum compose-circumflex-map) - (x-define-dead-key Dead_Tilde compose-tilde-map) - - ;; Sun according to OpenWindows 3: - (x-define-dead-key SunXK_FA_Acute compose-acute-map) - (x-define-dead-key SunXK_FA_Grave compose-grave-map) - (x-define-dead-key SunXK_FA_Cedilla compose-cedilla-map) - (x-define-dead-key SunXK_FA_Diaeresis compose-diaeresis-map) - (x-define-dead-key SunXK_FA_Circum compose-circumflex-map) - (x-define-dead-key SunXK_FA_Tilde compose-tilde-map) - - ;; DEC according to MIT: - (x-define-dead-key Dacute_accent compose-acute-map) - (x-define-dead-key Dgrave_accent compose-grave-map) - (x-define-dead-key Dcedilla_accent compose-cedilla-map) - (x-define-dead-key Dcircumflex_accent compose-circumflex-map) - (x-define-dead-key Dtilde compose-tilde-map) - (x-define-dead-key Dring_accent compose-ring-map) - - ;; DEC according to OpenWindows 3: - (x-define-dead-key DXK_acute_accent compose-acute-map) - (x-define-dead-key DXK_grave_accent compose-grave-map) - (x-define-dead-key DXK_cedilla_accent compose-cedilla-map) - (x-define-dead-key DXK_circumflex_accent compose-circumflex-map) - (x-define-dead-key DXK_tilde compose-tilde-map) - (x-define-dead-key DXK_ring_accent compose-ring-map) - - ;; HP according to MIT: - (x-define-dead-key hpmute_acute compose-acute-map) - (x-define-dead-key hpmute_grave compose-grave-map) - (x-define-dead-key hpmute_diaeresis compose-diaeresis-map) - (x-define-dead-key hpmute_asciicircum compose-circumflex-map) - (x-define-dead-key hpmute_asciitilde compose-tilde-map) - - ;; HP according to OpenWindows 3: - (x-define-dead-key hpXK_mute_acute compose-acute-map) - (x-define-dead-key hpXK_mute_grave compose-grave-map) - (x-define-dead-key hpXK_mute_diaeresis compose-diaeresis-map) - (x-define-dead-key hpXK_mute_asciicircum compose-circumflex-map) - (x-define-dead-key hpXK_mute_asciitilde compose-tilde-map) - - ;; HP according to HP-UX 8.0: - (x-define-dead-key XK_mute_acute compose-acute-map) - (x-define-dead-key XK_mute_grave compose-grave-map) - (x-define-dead-key XK_mute_diaeresis compose-diaeresis-map) - (x-define-dead-key XK_mute_asciicircum compose-circumflex-map) - (x-define-dead-key XK_mute_asciitilde compose-tilde-map) - - ;; Xfree86 seems to use lower case and a hyphen - (x-define-dead-key dead-acute compose-acute-map) - (x-define-dead-key dead-grave compose-grave-map) - (x-define-dead-key dead-cedilla compose-cedilla-map) - (x-define-dead-key dead-diaeresis compose-diaeresis-map) - (x-define-dead-key dead-circum compose-circumflex-map) - (x-define-dead-key dead-tilde compose-tilde-map) - - ;; and AIX uses underscore, sigh.... - (x-define-dead-key dead_acute compose-acute-map) - (x-define-dead-key dead_grave compose-grave-map) - (x-define-dead-key dead_cedilla compose-cedilla-map) - (x-define-dead-key dead_diaeresis compose-diaeresis-map) - (x-define-dead-key dead_circum compose-circumflex-map) - (x-define-dead-key dead_tilde compose-tilde-map) - ) - -(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 - ;; a Sun keyboard. - ;; - ;; One way of implementing this (which would require C support) would - ;; be to examine the X keymap itself and see if the layout looks even - ;; 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. - (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")) - ((string-match "XFree86" vendor) - ;; Those XFree86 people do some weird keysym stuff, too. - (load "x-win-xfree86"))))) - - -(defvar pre-x-win-initted nil) - -(defun init-pre-x-win () - "Initialize X Windows at startup (pre). Don't call this." - (when (not pre-x-win-initted) - (require 'x-iso8859-1) - (setq character-set-property 'x-iso8859/1) ; see x-iso8859-1.el - - (setq initial-frame-plist (if initial-frame-unmapped-p - '(initially-unmapped t) - nil)) - (setq pre-x-win-initted t))) - -(defvar x-win-initted nil) - -(defun init-x-win () - "Initialize X Windows at startup. Don't call this." - (when (not x-win-initted) - (init-pre-x-win) - - ;; Open the X display when this file is loaded - ;; (Note that the first frame is created later.) - (setq x-initial-argv-list (cons (car command-line-args) - command-line-args-left)) - (make-x-device nil) - (setq command-line-args-left (cdr x-initial-argv-list)) - (setq x-win-initted t))) - -(defvar post-x-win-initted nil) - -(defun init-post-x-win () - "Initialize X Windows at startup (post). Don't call this." - (when (not post-x-win-initted) - ;; We can't load this until after the initial X device is created - ;; because the icon initialization needs to access the display to get - ;; any toolbar-related color resources. - (if (featurep 'toolbar) - (init-x-toolbar)) - (if (featurep 'mule) - (init-mule-x-win)) - ;; 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)))) - (add-hook 'zmacs-activate-region-hook - (lambda () - (if (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)))) - ;; Motif-ish bindings - ;; The following two were generally unliked. - ;;(define-key global-map '(shift delete) 'x-kill-primary-selection) - ;;(define-key global-map '(control delete) 'x-delete-primary-selection) - (define-key global-map '(shift insert) 'x-yank-clipboard-selection) - (define-key global-map '(control insert) 'x-copy-primary-selection) - ;; These are Sun-isms. - (define-key global-map 'copy 'x-copy-primary-selection) - (define-key global-map 'paste 'x-yank-clipboard-selection) - (define-key global-map 'cut 'x-kill-primary-selection) - - (define-key global-map 'menu 'popup-mode-menu) - ;;(define-key global-map '(shift menu) 'x-goto-menubar) ;NYI - - (setq post-x-win-initted t))) - -;;; Keyboard initialization needs to be done differently for each X -;;; console, so use create-console-hook. -(when (featurep 'x) - (add-hook - 'create-console-hook - (lambda (console) - (letf (((selected-console) console)) - (when (eq 'x (console-type console)) - (x-initialize-keyboard) - (x-initialize-compose)))))) - -(defun make-frame-on-display (display &optional props) - "Create a frame on the X display named DISPLAY. -DISPLAY should be a standard display string such as \"unix:0\", -or nil for the display specified on the command line or in the -DISPLAY environment variable. - -PROPS should be a plist of properties, as in the call to `make-frame'. - -This function opens a connection to the display or reuses an existing -connection. - -This function is a trivial wrapper around `make-frame-on-device'." - (interactive "sMake frame on display: ") - (if (equal display "") (setq display nil)) - (make-frame-on-device 'x display props)) - -;;; x-init.el ends here
--- a/lisp/x11/x-iso8859-1.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,261 +0,0 @@ -;; Mapping between X keysym names and ISO 8859-1 (aka Latin1) character codes. -;; Copyright (C) 1992, 1993 Free Software Foundation, Inc. - -;; 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. - -;; created by jwz, 13-jun-92. -;; changed by Heiko Muenkel, 12-jun-1997: Added a grave keysym. - -;; Under X, when the user types a character that is ISO-8859/1 but not ASCII, -;; it comes in as a symbol instead of as a character code. This keeps things -;; nice and character-set independent. This file takes all of those symbols -;; (the symbols that are the X names for the 8859/1 characters) and puts a -;; property on them which holds the character code that should be inserted in -;; the buffer when they are typed. The self-insert-command function will look -;; at this. It also binds them all to self-insert-command. - -;; It puts the same property on the keypad keys, so that (read-char) will -;; think that they are the same as the digit characters. However, those -;; 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 -;; that is not X-specific. - -(require 'iso8859-1) - -(defconst iso8859/1-code-to-x-keysym-table nil - "Maps iso8859/1 to an X keysym name which corresponds to it. -There may be more than one X name for this keycode; this returns the first one. -Note that this is X specific; one should avoid using this table whenever -possible, in the interest of portability.") - -;; (This esoteric little construct is how you do MACROLET in elisp. It -;; generates the most efficient code for the .elc file by unwinding the -;; loop at compile-time.) - -((macro - . (lambda (&rest syms-and-iso8859/1-codes) - (cons - 'progn - (nconc - ;; - ;; First emit code that puts the `x-iso8859/1' property on all of - ;; the keysym symbols. - ;; - (mapcar '(lambda (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)) - syms-and-iso8859/1-codes) - ;; - ;; Then emit the value of iso8859/1-code-to-x-keysym-table. - ;; - (let ((v (make-vector 256 nil))) - ;; the printing ASCII chars have 1-char names. - (let ((i 33)) - (while (< i 127) - (aset v i (intern (make-string 1 i))) - (setq i (1+ i)))) - ;; these are from the keyboard character set. - (mapcar '(lambda (x) (aset v (car x) (car (cdr x)))) - '((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)))) - syms-and-iso8859/1-codes) - (list (list 'setq 'iso8859/1-code-to-x-keysym-table v))) - )))) - - ;; The names and capitalization here are as per the MIT X11R4 and X11R5 - ;; distributions. If a vendor varies from this, adjustments will need - ;; to be made... - - (grave ?\140) - (nobreakspace ?\240) - (exclamdown ?\241) - (cent ?\242) - (sterling ?\243) - (currency ?\244) - (yen ?\245) - (brokenbar ?\246) - (section ?\247) - (diaeresis ?\250) - (copyright ?\251) - (ordfeminine ?\252) - (guillemotleft ?\253) - (notsign ?\254) - (hyphen ?\255) - (registered ?\256) - (macron ?\257) - (degree ?\260) - (plusminus ?\261) - (twosuperior ?\262) - (threesuperior ?\263) - (acute ?\264) ; Why is there an acute keysym that is - (mu ?\265) ; distinct from apostrophe/quote, but - (paragraph ?\266) ; no grave keysym that is distinct from - (periodcentered ?\267) ; backquote? - (cedilla ?\270) ; I've added the grave keysym, because it's - (onesuperior ?\271) ; used in x-compose (Heiko Muenkel). - (masculine ?\272) - (guillemotright ?\273) - (onequarter ?\274) - (onehalf ?\275) - (threequarters ?\276) - (questiondown ?\277) - - (Agrave ?\300) - (Aacute ?\301) - (Acircumflex ?\302) - (Atilde ?\303) - (Adiaeresis ?\304) - (Aring ?\305) - (AE ?\306) - (Ccedilla ?\307) - (Egrave ?\310) - (Eacute ?\311) - (Ecircumflex ?\312) - (Ediaeresis ?\313) - (Igrave ?\314) - (Iacute ?\315) - (Icircumflex ?\316) - (Idiaeresis ?\317) - (ETH ?\320) - (Ntilde ?\321) - (Ograve ?\322) - (Oacute ?\323) - (Ocircumflex ?\324) - (Otilde ?\325) - (Odiaeresis ?\326) - (multiply ?\327) - (Ooblique ?\330) - (Ugrave ?\331) - (Uacute ?\332) - (Ucircumflex ?\333) - (Udiaeresis ?\334) - (Yacute ?\335) - (THORN ?\336) - (ssharp ?\337) - - (agrave ?\340) - (aacute ?\341) - (acircumflex ?\342) - (atilde ?\343) - (adiaeresis ?\344) - (aring ?\345) - (ae ?\346) - (ccedilla ?\347) - (egrave ?\350) - (eacute ?\351) - (ecircumflex ?\352) - (ediaeresis ?\353) - (igrave ?\354) - (iacute ?\355) - (icircumflex ?\356) - (idiaeresis ?\357) - (eth ?\360) - (ntilde ?\361) - (ograve ?\362) - (oacute ?\363) - (ocircumflex ?\364) - (otilde ?\365) - (odiaeresis ?\366) - (division ?\367) - (oslash ?\370) - (ugrave ?\371) - (uacute ?\372) - (ucircumflex ?\373) - (udiaeresis ?\374) - (yacute ?\375) - (thorn ?\376) - (ydiaeresis ?\377) - - ) - -((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)))) - syms-and-iso8859/1-codes)))) - ;; - ;; Let's do the appropriate thing for some vendor-specific keysyms too... - ;; Apparently nobody agrees on what the names of these keysyms are. - ;; - (SunFA_Acute ?\264) - (SunXK_FA_Acute ?\264) - (Dacute_accent ?\264) - (DXK_acute_accent ?\264) - (hpmute_acute ?\264) - (hpXK_mute_acute ?\264) - (XK_mute_acute ?\264) - - (SunFA_Grave ?`) - (Dead_Grave ?`) - (SunXK_FA_Grave ?`) - (Dgrave_accent ?`) - (DXK_grave_accent ?`) - (hpmute_grave ?`) - (hpXK_mute_grave ?`) - (XK_mute_grave ?`) - - (SunFA_Cedilla ?\270) - (SunXK_FA_Cedilla ?\270) - (Dcedilla_accent ?\270) - (DXK_cedilla_accent ?\270) - - (SunFA_Diaeresis ?\250) - (SunXK_FA_Diaeresis ?\250) - (hpmute_diaeresis ?\250) - (hpXK_mute_diaeresis ?\250) - (XK_mute_diaeresis ?\250) - - (SunFA_Circum ?^) - (Dead_Circum ?^) - (SunXK_FA_Circum ?^) - (Dcircumflex_accent ?^) - (DXK_circumflex_accent ?^) - (hpmute_asciicircum ?^) - (hpXK_mute_asciicircum ?^) - (XK_mute_asciicircum ?^) - - (SunFA_Tilde ?~) - (Dead_Tilde ?~) - (SunXK_FA_Tilde ?~) - (Dtilde ?~) - (DXK_tilde ?~) - (hpmute_asciitilde ?~) - (hpXK_mute_asciitilde ?~) - (XK_mute_asciitilde ?~) - - (Dring_accent ?\260) - (DXK_ring_accent ?\260) - ) - -(provide 'x-iso8859-1) - -;;; x-iso8859-1.el ends here
--- a/lisp/x11/x-menubar.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1612 +0,0 @@ -;;; x-menubar.el --- Menubar and popup-menu support for X. - -;; Copyright (C) 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. -;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp. -;; Copyright (C) 1995 Sun Microsystems. -;; Copyright (C) 1995, 1996 Ben Wing. -;; Copyright (C) 1997 MORIOKA Tomohiko - -;; 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 Xmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;;; Code: - -;;; Warning-free compile -(eval-when-compile - (defvar language-environment-list) - (require 'pending-del)) - -(defconst default-menubar - (purecopy-menubar - ;; note backquote. - `( - ("File" - :filter file-menu-filter - ["Open..." find-file t] - ["Open in Other Window..." find-file-other-window t] - ["Open in New Frame..." find-file-other-frame t] - ["Insert File..." insert-file t] - ["View File..." view-file t] - "------" - ["Save" save-buffer t nil] - ["Save As..." write-file t] - ["Save Some Buffers" save-some-buffers t] - "-----" - ["Print Buffer" lpr-buffer t nil] - ["Pretty-Print Buffer" ps-print-buffer-with-faces t nil] - "-----" - ["New Frame" make-frame t] - ["Frame on Other Display..." - make-frame-on-display t] - ["Delete Frame" delete-frame t] - "-----" - ["Split Window" split-window-vertically t] - ["Un-Split (Keep This)" delete-other-windows (not (one-window-p t))] - ["Un-Split (Keep Others)" delete-window (not (one-window-p t))] - "-----" - ["Revert Buffer" revert-buffer t nil] - ["Delete Buffer" kill-this-buffer t nil] - "-----" - ["Exit XEmacs" save-buffers-kill-emacs t] - ) - - ("Edit" - :filter edit-menu-filter - ["Undo" advertised-undo t] - ["Cut" x-kill-primary-selection t] - ["Copy" x-copy-primary-selection t] - ["Paste" x-yank-clipboard-selection t] - ["Clear" x-delete-primary-selection t] - "----" - ["Search..." isearch-forward t] - ["Search Backward..." isearch-backward t] - ["Replace..." query-replace t] - "----" - ["Search (Regexp)..." isearch-forward-regexp t] - ["Search Backward (Regexp)..." isearch-backward-regexp t] - ["Replace (Regexp)..." query-replace-regexp t] - "----" - ("Bookmarks" - ("Jump to bookmark" - :filter bookmark-menu-filter) - ["Set bookmark" bookmark-set t] - "---" - ["Insert contents" bookmark-menu-insert t] - ["Insert location" bookmark-menu-locate t] - "---" - ["Rename bookmark" bookmark-menu-rename t] - ("Delete bookmark" - :filter bookmark-delete-filter) - ["Edit Bookmark List" bookmark-bmenu-list t] - "---" - ["Save bookmarks" bookmark-save t] - ["Save bookmarks as..." bookmark-write t] - ["Load a bookmark file" bookmark-load t]) - "----" - ["Goto Line..." goto-line t] - ["What Line" what-line t] - "----" - ["Start Macro Recording" start-kbd-macro (not defining-kbd-macro)] - ["End Macro Recording" end-kbd-macro defining-kbd-macro] - ["Execute Last Macro" call-last-kbd-macro last-kbd-macro] - "----" - ["Show Message Log" show-message-log t] - ) - - ,@(if (featurep 'mule) - '(("Mule" - ("Describe language support") - ("Set language environment") - "--" - ["Toggle input method" toggle-input-method t] - ["Select input method" select-input-method t] - ["Describe input method" describe-input-method t] - "--" - ["Describe current coding systems" - describe-current-coding-system t] - ["Set coding system of buffer file" - set-buffer-file-coding-system t] - ["Set coding system of terminal" - set-terminal-coding-system nil] ; not implemented yet - ["Set coding system of keyboard" - set-keyboard-coding-system nil] ; not implemented yet - ["Set coding system of process" - set-current-process-coding-system nil] ; not implemented yet - "--" - ["Show character table" view-charset-by-menu t] - ["Show diagnosis for MULE" mule-diag nil] ; not implemented yet - ["Show many languages" view-hello-file t] - ))) - - ("Apps" - ["Read Mail (VM)..." vm t] - ["Read Mail (MH)..." (mh-rmail t) t] - ["Send mail..." mail t] - ["Usenet News" gnus (fboundp 'gnus)] - ["Browse the Web" w3 t] - ["Gopher" gopher t] - ["Hyperbole..." hyperbole t] - "----" - ["Spell-Check Buffer" ispell-buffer t] - ["Emulate VI" viper-mode t] - "----" - ("Calendar" - ["3-Month Calendar" calendar t] - ["Diary" diary t] - ["Holidays" holidays t] - ;; we're all pagans at heart ... - ["Phases of the Moon" phases-of-moon t] - ["Sunrise/Sunset" sunrise-sunset t] - ) - ("Games" - ["Mine Game" xmine (fboundp 'xmine)] - ["Tetris" tetris (fboundp 'tetris)] - ["Quote from Zippy" yow (fboundp 'yow)] - ["Psychoanalyst" doctor (fboundp 'doctor)] - ["Psychoanalyze Zippy!" psychoanalyze-pinhead (fboundp 'psychoanalyze-pinhead)] - ["Random Flames" flame (fboundp 'flame)] - ["Dunnet (Adventure)" dunnet (fboundp 'dunnet)] - ["Towers of Hanoi" hanoi (fboundp 'hanoi)] - ["Game of Life" life (fboundp 'life)] - ["Multiplication Puzzle" mpuz (fboundp 'mpuz)] - ) - ) - - ("Options" - ("Customize" - ("Emacs" :filter (lambda (&rest junk) - (cdr (custom-menu-create 'emacs)))) - ["Group..." customize-group t] - ["Variable..." customize-variable t] - ["Face..." customize-face t] - ["Saved..." customize-saved t] - ["Set..." customize-customized t] - ["Apropos..." customize-apropos t]) - ["Read Only" (toggle-read-only) - :style toggle :selected buffer-read-only] - ("Editing Options" - ["Overstrike" (progn - (overwrite-mode current-prefix-arg) - (setq-default overwrite-mode overwrite-mode)) - :style toggle :selected overwrite-mode] - ["Case Sensitive Search" (progn - (setq case-fold-search (not case-fold-search)) - (setq-default case-fold-search - case-fold-search)) - :style toggle :selected (not case-fold-search)] - ["Case Matching Replace" (setq case-replace (not case-replace)) - :style toggle :selected case-replace] - ["Auto Delete Selection" (pending-delete-mode - (if pending-delete-mode 0 1)) - :style toggle - :selected (and (boundp 'pending-delete-mode) pending-delete-mode)] - ["Active Regions" (setq zmacs-regions (not zmacs-regions)) - :style toggle :selected zmacs-regions] - ["Mouse Paste At Text Cursor" (setq mouse-yank-at-point - (not mouse-yank-at-point)) - :style toggle :selected mouse-yank-at-point] - ["Require Newline At End" (setq require-final-newline - (or (eq require-final-newline 'ask) - (not require-final-newline))) - :style toggle :selected (eq require-final-newline 't)] - ["Add Newline When Moving Past End" (setq next-line-add-newlines - (not next-line-add-newlines)) - :style toggle :selected next-line-add-newlines] - ) - ("General Options" - ["Teach Extended Commands" (setq teach-extended-commands-p - (not teach-extended-commands-p)) - :style toggle :selected teach-extended-commands-p] - ["Debug On Error" (setq debug-on-error (not debug-on-error)) - :style toggle :selected debug-on-error] - ["Debug On Quit" (setq debug-on-quit (not debug-on-quit)) - :style toggle :selected debug-on-quit] - ) - ("Printing Options" - ["Command-Line Switches for `lpr'/`lp'..." - (setq lpr-switches - (read-expression "Switches for `lpr'/`lp': " - (format "%S" lpr-switches))) - t] - ("Pretty-Print Paper Size" - ["Letter" - (setq ps-paper-type 'letter) - :style radio - :selected (eq ps-paper-type 'letter)] - ["Letter-small" - (setq ps-paper-type 'letter-small) - :style radio - :selected (eq ps-paper-type 'letter-small)] - ["Legal" - (setq ps-paper-type 'legal) - :style radio - :selected (eq ps-paper-type 'legal)] - ["Statement" - (setq ps-paper-type 'statement) - :style radio - :selected (eq ps-paper-type 'statement)] - ["Executive" - (setq ps-paper-type 'executive) - :style radio - :selected (eq ps-paper-type 'executive)] - ["Tabloid" - (setq ps-paper-type 'tabloid) - :style radio - :selected (eq ps-paper-type 'tabloid)] - ["Ledger" - (setq ps-paper-type 'ledger) - :style radio - :selected (eq ps-paper-type 'ledger)] - ["A3" - (setq ps-paper-type 'a3) - :style radio - :selected (eq ps-paper-type 'a3)] - ["A4" - (setq ps-paper-type 'a4) - :style radio - :selected (eq ps-paper-type 'a4)] - ["A4small" - (setq ps-paper-type 'a4small) - :style radio - :selected (eq ps-paper-type 'a4small)] - ["B4" - (setq ps-paper-type 'b4) - :style radio - :selected (eq ps-paper-type 'b4)] - ["B5" - (setq ps-paper-type 'b5) - :style radio - :selected (eq ps-paper-type 'b5)] - ) - ["Enable Color Printing" - (progn - (set-face-background 'default "white") - (setq ps-print-color-p t)) - t] - ) - ("\"Other Window\" Location" - ["Always in Same Frame" - (setq get-frame-for-buffer-default-instance-limit nil) - :style radio - :selected (null get-frame-for-buffer-default-instance-limit)] - ["Other Frame (2 Frames Max)" - (setq get-frame-for-buffer-default-instance-limit 2) - :style radio - :selected (eq 2 get-frame-for-buffer-default-instance-limit)] - ["Other Frame (3 Frames Max)" - (setq get-frame-for-buffer-default-instance-limit 3) - :style radio - :selected (eq 3 get-frame-for-buffer-default-instance-limit)] - ["Other Frame (4 Frames Max)" - (setq get-frame-for-buffer-default-instance-limit 4) - :style radio - :selected (eq 4 get-frame-for-buffer-default-instance-limit)] - ["Other Frame (5 Frames Max)" - (setq get-frame-for-buffer-default-instance-limit 5) - :style radio - :selected (eq 5 get-frame-for-buffer-default-instance-limit)] - ["Always Create New Frame" - (setq get-frame-for-buffer-default-instance-limit 0) - :style radio - :selected (eq 0 get-frame-for-buffer-default-instance-limit)] - "-----" - ["Temp Buffers Always in Same Frame" - (setq temp-buffer-show-function 'show-temp-buffer-in-current-frame) - :style radio - :selected (eq temp-buffer-show-function - 'show-temp-buffer-in-current-frame)] - ["Temp Buffers Like Other Buffers" - (setq temp-buffer-show-function nil) - :style radio - :selected (null temp-buffer-show-function)] - "-----" - ["Make current frame gnuserv target" - (setq gnuserv-frame - (if (equal gnuserv-frame (selected-frame)) - 'new - (selected-frame))) - :style radio - :selected (equal gnuserv-frame (selected-frame))] - ) - - "-----" - ("Syntax Highlighting" - ["In This Buffer" (font-lock-mode) - :style toggle :selected font-lock-mode] - ["Automatic" (if (not (featurep 'font-lock)) - (progn - (setq font-lock-auto-fontify t) - (require 'font-lock)) - (setq font-lock-auto-fontify - (not font-lock-auto-fontify))) - :style toggle - :selected (and (featurep 'font-lock) font-lock-auto-fontify)] - "-----" - ["Fonts" (progn (require 'font-lock) - (font-lock-use-default-fonts) - (setq font-lock-use-fonts t - font-lock-use-colors nil) - (font-lock-mode 1)) - :style radio - :selected (and font-lock-mode - font-lock-use-fonts)] - ["Colors" (progn (require 'font-lock) - (font-lock-use-default-colors) - (setq font-lock-use-colors t - font-lock-use-fonts nil) - (font-lock-mode 1)) - :style radio - :selected (and font-lock-mode - font-lock-use-colors)] - "-----" - ["Least" (if (or (and (not (integerp font-lock-maximum-decoration)) - (not (eq t font-lock-maximum-decoration))) - (and (integerp font-lock-maximum-decoration) - (<= font-lock-maximum-decoration 0))) - nil - (setq font-lock-maximum-decoration nil) - (font-lock-recompute-variables)) - :style radio - :active font-lock-mode - :selected (and font-lock-mode - (or (and (not (integerp font-lock-maximum-decoration)) - (not (eq t font-lock-maximum-decoration))) - (and (integerp font-lock-maximum-decoration) - (<= font-lock-maximum-decoration 0))))] - ["More" (if (and (integerp font-lock-maximum-decoration) - (= 1 font-lock-maximum-decoration)) - nil - (setq font-lock-maximum-decoration 1) - (font-lock-recompute-variables)) - :style radio - :active font-lock-mode - :selected (and font-lock-mode - (integerp font-lock-maximum-decoration) - (= 1 font-lock-maximum-decoration))] - ["Even More" (if (and (integerp font-lock-maximum-decoration) - (= 2 font-lock-maximum-decoration)) - nil - (setq font-lock-maximum-decoration 2) - (font-lock-recompute-variables)) - :style radio - :active font-lock-mode - :selected (and font-lock-mode - (integerp font-lock-maximum-decoration) - (= 2 font-lock-maximum-decoration))] - ["Most" (if (or (eq font-lock-maximum-decoration t) - (and (integerp font-lock-maximum-decoration) - (>= font-lock-maximum-decoration 3))) - nil - (setq font-lock-maximum-decoration t) - (font-lock-recompute-variables)) - :style radio - :active font-lock-mode - :selected (and font-lock-mode - (or (eq font-lock-maximum-decoration t) - (and (integerp font-lock-maximum-decoration) - (>= font-lock-maximum-decoration 3))))] - "-----" - ["Lazy" (progn (require 'lazy-shot) - (if (and (boundp 'lazy-shot-mode) lazy-shot-mode) - (progn - (lazy-shot-mode 0) - ;; this shouldn't be necessary so there has to - ;; be a redisplay bug lurking somewhere (or - ;; possibly another event handler bug) - (redraw-modeline) - (remove-hook 'font-lock-mode-hook - 'turn-on-lazy-shot)) - (if font-lock-mode - (progn - (lazy-shot-mode 1) - (redraw-modeline) - (add-hook 'font-lock-mode-hook - 'turn-on-lazy-shot))))) - :active font-lock-mode - :style toggle - :selected (and (boundp 'lazy-shot-mode) lazy-shot-mode)] - ["Caching" (progn (require 'fast-lock) - (if fast-lock-mode - (progn - (fast-lock-mode 0) - ;; this shouldn't be necessary so there has to - ;; be a redisplay bug lurking somewhere (or - ;; possibly another event handler bug) - (redraw-modeline)) - (if font-lock-mode - (progn - (fast-lock-mode 1) - (redraw-modeline))))) - :active font-lock-mode - :style toggle - :selected (and (boundp 'fast-lock-mode) fast-lock-mode)] - ) - ("Paren Highlighting" - ["None" (paren-set-mode -1) - :style radio :selected (not paren-mode)] - ["Blinking Paren" (paren-set-mode 'blink-paren) - :style radio :selected (eq paren-mode 'blink-paren)] - ["Steady Paren" (paren-set-mode 'paren) - :style radio :selected (eq paren-mode 'paren)] - ["Expression" (paren-set-mode 'sexp) - :style radio :selected (eq paren-mode 'sexp)] -;;; ["Nested Shading" (paren-set-mode 'nested) -;;; :style radio :selected (eq paren-mode 'nested)] - ) - "-----" - ("Frame Appearance" - ,@(if (featurep 'scrollbar) - '(["Scrollbars" (if (= (specifier-instance scrollbar-width) 0) - (progn - (set-specifier scrollbar-width 15) - (set-specifier scrollbar-height 15)) - (set-specifier scrollbar-width 0) - (set-specifier scrollbar-height 0)) - :style toggle :selected (> (specifier-instance scrollbar-width) 0)])) - ["3D Modeline" - (progn - (if (zerop (specifier-instance modeline-shadow-thickness)) - (set-specifier modeline-shadow-thickness 2) - (set-specifier modeline-shadow-thickness 0)) - (redraw-modeline t)) - :style toggle :selected - (let ((thickness - (specifier-instance modeline-shadow-thickness))) - (and (integerp thickness) - (> thickness 0)))] - ["Truncate Lines" (progn - (setq truncate-lines (not truncate-lines)) - (setq-default truncate-lines truncate-lines)) - :style toggle :selected truncate-lines] - ["Bar Cursor" (progn - (setq bar-cursor - (if (not bar-cursor) 2 nil)) - (force-cursor-redisplay)) - :style toggle :selected bar-cursor] - ["Blinking Cursor" (blink-cursor-mode) - :style toggle - :selected (and (boundp 'blink-cursor-mode) blink-cursor-mode)] - ["Frame-Local Font Menu" (setq font-menu-this-frame-only-p - (not font-menu-this-frame-only-p)) - :style toggle :selected font-menu-this-frame-only-p] -; ["Line Numbers" (line-number-mode nil) -; :style toggle :selected line-number-mode] - ) - ("Menubar Appearance" - ["Buffers Menu Length..." - (progn - (setq buffers-menu-max-size - (read-number - "Enter number of buffers to display (or 0 for unlimited): ")) - (if (eq buffers-menu-max-size 0) (setq buffers-menu-max-size nil))) - t] - ["Multi-Operation Buffers Sub-Menus" - (setq complex-buffers-menu-p - (not complex-buffers-menu-p)) - :style toggle :selected complex-buffers-menu-p] - ("Buffers Menu Sorting" - ["Most Recently Used" - (progn - (setq buffers-menu-sort-function nil) - (setq buffers-menu-grouping-function nil)) - :style radio - :selected (null buffers-menu-sort-function)] - ["Alphabetically" - (progn - (setq buffers-menu-sort-function - 'sort-buffers-menu-alphabetically) - (setq buffers-menu-grouping-function nil)) - :style radio - :selected (eq 'sort-buffers-menu-alphabetically - buffers-menu-sort-function)] - ["By Major Mode, Then Alphabetically" - (progn - (setq buffers-menu-sort-function - 'sort-buffers-menu-by-mode-then-alphabetically) - (setq buffers-menu-grouping-function - 'group-buffers-menu-by-mode-then-alphabetically)) - :style radio - :selected (eq 'sort-buffers-menu-by-mode-then-alphabetically - buffers-menu-sort-function)]) - ["Submenus for Buffer Groups" - (setq buffers-menu-submenus-for-groups-p - (not buffers-menu-submenus-for-groups-p)) - :style toggle - :selected buffers-menu-submenus-for-groups-p - :active (not (null buffers-menu-grouping-function))] - "---" - ["Ignore Scaled Fonts" (setq font-menu-ignore-scaled-fonts - (not font-menu-ignore-scaled-fonts)) - :style toggle :selected font-menu-ignore-scaled-fonts] - ) - ,@(if (featurep 'toolbar) - '(("Toolbar Appearance" - ["Visible" (set-specifier default-toolbar-visible-p - (not (specifier-instance - default-toolbar-visible-p))) - :style toggle - :selected (specifier-instance default-toolbar-visible-p)] - ["Captioned" (set-specifier toolbar-buttons-captioned-p - (not (specifier-instance - toolbar-buttons-captioned-p))) - :style toggle - :selected - (specifier-instance toolbar-buttons-captioned-p)] - ("Default Location" - ["Top" (set-default-toolbar-position 'top) - :style radio :selected (eq (default-toolbar-position) 'top)] - ["Bottom" (set-default-toolbar-position 'bottom) - :style radio :selected (eq (default-toolbar-position) 'bottom)] - ["Left" (set-default-toolbar-position 'left) - :style radio :selected (eq (default-toolbar-position) 'left)] - ["Right" (set-default-toolbar-position 'right) - :style radio :selected (eq (default-toolbar-position) 'right)] - ) - ))) - ("Mouse" - ["Avoid-Text" - (if (equal (device-type) 'x) - (if mouse-avoidance-mode - (mouse-avoidance-mode 'none) - (mouse-avoidance-mode 'banish)) - (beep) - (message "This option requires a window system.")) - :style toggle :selected (and mouse-avoidance-mode window-system)] - ["strokes-mode" - (if (equal (device-type) 'x) - (strokes-mode) - (beep) - (message "This option requires a window system.")) - :style toggle :selected (and strokes-mode window-system)]) - ("Open URLs With" - ["Emacs-W3" (setq browse-url-browser-function 'browse-url-w3) - :style radio - :selected (eq browse-url-browser-function 'browse-url-w3)] - ["Netscape" (setq browse-url-browser-function 'browse-url-netscape) - :style radio - :selected (eq browse-url-browser-function 'browse-url-netscape)] - ["Mosaic" (setq browse-url-browser-function 'browse-url-mosaic) - :style radio - :selected (eq browse-url-browser-function 'browse-url-mosaic)] - ["Mosaic (CCI)" (setq browse-url-browser-function 'browse-url-cci) - :style radio - :selected (eq browse-url-browser-function 'browse-url-iximosaic)] - ["IXI Mosaic" (setq browse-url-browser-function 'browse-url-iximosaic) - :style radio - :selected (eq browse-url-browser-function 'browse-url-iximosaic)] - ["Lynx (xterm)" (setq browse-url-browser-function 'browse-url-lynx-xterm) - :style radio - :selected (eq browse-url-browser-function 'browse-url-lynx-xterm)] - ["Lynx (xemacs)" (setq browse-url-browser-function 'browse-url-lynx-emacs) - :style radio - :selected (eq browse-url-browser-function 'browse-url-lynx-emacs)] - ["Grail" (setq browse-url-browser-function 'browse-url-grail) - :style radio - :selected (eq browse-url-browser-function 'browse-url-grail)] - ) - "-----" - ["Browse Faces..." edit-faces t] - ("Font" :filter font-menu-family-constructor) - ("Size" :filter font-menu-size-constructor) - ("Weight" :filter font-menu-weight-constructor) - ,@(if (featurep 'mule) - '("-----" - ("Language Environment" - :filter language-environment-menu-filter))) - "-----" - ["Save Options" save-options-menu-settings t] - ) - - ("Buffers" - :filter buffers-menu-filter - ["List All Buffers" list-buffers t] - "--" - ) - - ("Tools" - ["Grep..." grep t] - ["Compile..." compile t] - ["Shell" shell t] - ["Shell Command..." shell-command t] - ["Shell Command on Region..." shell-command-on-region (region-exists-p)] - ["Debug (GDB)..." gdb t] - ["Debug (DBX)..." dbx t] - "-----" - ["OO-Browser..." oobr t] - ("Tags" - ["Find Tag..." find-tag t] - ["Find Other Window..." find-tag-other-window t] - ["Next Tag..." (find-tag nil) t] - ["Next Other Window..." (find-tag-other-window nil) t] - ["Next File" next-file t] - "-----" - ["Tags Search..." tags-search t] - ["Tags Replace..." tags-query-replace t] - ["Continue Search/Replace" tags-loop-continue t] - "-----" - ["Pop stack" pop-tag-mark t] - ["Apropos..." tags-apropos t] - "-----" - ["Set Tags Table File..." visit-tags-table t] - )) - - nil ; the partition: menus after this are flushright - - ("Help" - ["About XEmacs..." about-xemacs t] - ("Basics" - ["Tutorial" help-with-tutorial t] - ["News" view-emacs-news t] - ["Packages" finder-by-keyword t] - ["Splash" xemacs-splash-buffer t]) - "-----" - ("XEmacs FAQ" - ["FAQ (local)" xemacs-local-faq t] - ["FAQ via WWW" xemacs-www-faq t] - ["Home Page" xemacs-www-page t]) - ("Samples" - ["Sample" (find-file - (expand-file-name "sample.emacs" - data-directory)) - t ".emacs"] - ["Sample" (find-file - (expand-file-name "sample.Xdefaults" - data-directory)) - t ".Xdefaults"] - ["Sample" (find-file - (expand-file-name "enriched.doc" - data-directory)) - t "enriched"]) - "-----" - ("Lookup in Info" - ["Key Binding..." Info-goto-emacs-key-command-node t] - ["Command..." Info-goto-emacs-command-node t] - ["Function..." Info-elisp-ref t] - ["Topic..." Info-query t]) - ("Manuals" - ["Info" info t] - ["Unix Manual..." manual-entry t]) - ("Commands & Keys" - ["Mode" describe-mode t] - ["Apropos..." hyper-apropos t] - ["Apropos Docs..." apropos-documentation t] - "-----" - ["Key..." describe-key t] - ["Bindings" describe-bindings t] - ["Mouse Bindings" describe-pointer t] - ["Recent Keys" view-lossage t] - "-----" - ["Function..." describe-function t] - ["Variable..." describe-variable t] - ["Locate Command..." where-is t]) - "-----" - ["Recent Messages" view-lossage t] - ("Misc" - ["No Warranty" describe-no-warranty t] - ["XEmacs License" describe-copying t] - ["The Latest Version" describe-distribution t]) - ["Submit Bug Report" send-pr t] - ) - ))) - - -(defun maybe-add-init-button () - "Don't call this. -Adds `Load .emacs' button to menubar when starting up with -q." - ;; by Stig@hackvan.com - (cond - (init-file-user nil) - ((file-exists-p (cond - ((eq system-type 'ms-dos) - (concat "~" (user-login-name) "/_emacs")) - ((eq system-type 'vax-vms) - "sys$login:.emacs") - (t - (concat "~" (user-login-name) "/.emacs")))) - (add-menu-button nil - ["Load .emacs" - (progn (delete-menu-item '("Load .emacs")) - (load-user-init-file (user-login-name))) - t] - "Help")) - (t nil))) - -(add-hook 'before-init-hook 'maybe-add-init-button) - - -;;; The File and Edit menus - -(defvar put-buffer-names-in-file-menu t) - -;; The sensitivity part of this function could be done by just adding forms -;; to evaluate to the menu items themselves; that would be marginally less -;; efficient but not perceptibly so (I think). But in order to change the -;; names of the Undo menu item and the various things on the File menu item, -;; we need to use a hook. - -(defun file-menu-filter (menu-items) - "Incrementally update the file menu. -This function changes the arguments and sensitivity of these File menu items: - - Delete Buffer has the name of the current buffer appended to it. - Print Buffer has the name of the current buffer appended to it. - Pretty-Print Buffer - has the name of the current buffer appended to it. - Save has the name of the current buffer appended to it, and is - sensitive only when the current buffer is modified. - Revert Buffer has the name of the current buffer appended to it, and is - sensitive only when the current buffer has a file. - Delete Frame sensitive only when there is more than one frame. - -The name of the current buffer is only appended to the menu items if -`put-buffer-names-in-file-menu' is non-nil. This behavior is the default." - (let* ((bufname (buffer-name)) - (result menu-items) ; save pointer to start of menu. - name - item) - ;; the contents of the menu items in the file menu are destructively - ;; modified so that there is as little consing as possible. This is okay. - ;; As soon as the result is returned, it is converted to widget_values - ;; inside lwlib and the lisp menu-items can be safely modified again. - (while (setq item (pop menu-items)) - (if (vectorp item) - (progn - (setq name (aref item 0)) - (and put-buffer-names-in-file-menu - (member name '("Save" "Revert Buffer" "Print Buffer" - "Pretty-Print Buffer" "Delete Buffer")) - (>= (length item) 4) - (aset item 3 bufname)) - (and (string= "Save" name) - (aset item 2 (buffer-modified-p))) - (and (string= "Revert Buffer" name) - (aset item 2 (not (not (or buffer-file-name - revert-buffer-function))))) - (and (string= "Delete Frame" name) - (aset item 2 (not (eq (next-frame (selected-frame) - 'nomini 'window-system) - (selected-frame))))) - ))) - result)) - -(defun edit-menu-filter (menu-items) - "For use as an incremental menu construction filter. -This function changes the sensitivity of these Edit menu items: - - Cut sensitive only when emacs owns the primary X Selection. - Copy sensitive only when emacs owns the primary X Selection. - Clear sensitive only when emacs owns the primary X Selection. - Paste sensitive only when there is an owner for the X Clipboard Selection. - Undo sensitive only when there is undo information. - While in the midst of an undo, this is changed to \"Undo More\"." - (let* (item - name - (result menu-items) ; save pointer to head of list - (x-dev (eq 'x (device-type (selected-device)))) - (emacs-owns-selection-p (and x-dev (x-selection-owner-p))) - (clipboard-exists-p (and x-dev (x-selection-exists-p 'CLIPBOARD))) -;;; undo-available undoing-more -;;; (undo-info-available (not (null (and (not (eq t buffer-undo-list)) -;;; (if (eq last-command 'undo) -;;; (setq undoing-more -;;; (and (boundp 'pending-undo-list) -;;; pending-undo-list) -;;; buffer-undo-list)))))) - undo-name undo-state - ) - ;; As with file-menu-filter, menu-items are destructively modified. - ;; This is OK. - (while (setq item (pop menu-items)) - (if (vectorp item) - (progn - (setq name (aref item 0)) - (and (member name '("Cut" "Copy" "Clear")) - (aset item 2 emacs-owns-selection-p)) - (and (string= name "Paste") - (aset item 2 clipboard-exists-p)) - (and (member name '("Undo" "Undo More")) - (progn - ;; we could also do this with the third field of the item. - (if (eq last-command 'undo) - (setq undo-name "Undo More" - undo-state (not (null (and (boundp 'pending-undo-list) - pending-undo-list)))) - (setq undo-name "Undo" - undo-state (and (not (eq buffer-undo-list t)) - (not (null - (or buffer-undo-list - (and (boundp 'pending-undo-list) - pending-undo-list))))))) - (if buffer-read-only (setq undo-state nil)) - (aset item 0 undo-name) - (aset item 2 undo-state) - )) - ))) - result)) - - -;;; The Bookmarks menu - -(defun bookmark-menu-filter (menu-items) - "*Build the bookmark jump submenu dynamically from all defined bookmarks." - (if (bookmark-all-names) - (mapcar - #'(lambda (bmk) - (vector bmk `(bookmark-jump ',bmk) t)) (bookmark-all-names)) - '(["No Bookmarks Set" nil nil]))) - -(defun bookmark-delete-filter (menu-items) - "*Build the bookmark delete submenu dynamically from all defined bookmarks." - (if (bookmark-all-names) - (mapcar - #'(lambda (bmk) - (vector bmk `(bookmark-delete ',bmk) t)) (bookmark-all-names)) - '(["No Bookmarks Set" nil nil]))) - -;;; The Buffers menu - -(defgroup buffers-menu nil - "Customization of `Buffers' menu." - :group 'menu) - -(defcustom buffers-menu-max-size 25 - "*Maximum number of entries which may appear on the \"Buffers\" menu. -If this is 10, then only the ten most-recently-selected buffers will be -shown. If this is nil, then all buffers will be shown. Setting this to -a large number or nil will slow down menu responsiveness." - :type '(choice (const :tag "Show all" nil) - (integer 10)) - :group 'buffers-menu) - -(defcustom complex-buffers-menu-p nil - "*If non-nil, the buffers menu will contain several commands. -Commands will be presented as submenus of each buffer line. If this -is false, then there will be only one command: select that buffer." - :type 'boolean - :group 'buffers-menu) - -(defcustom buffers-menu-submenus-for-groups-p nil - "*If non-nil, the buffers menu will contain one submenu per group of buffers. -The grouping function is specified in `buffers-menu-grouping-function'. -If this is an integer, do not build submenus if the number of buffers -is not larger than this value." - :type '(choice (const :tag "No Subgroups" nil) - (integer :tag "Max. submenus" 10) - (sexp :format "%t\n" :tag "Allow Subgroups")) - :group 'buffers-menu) - -(defcustom buffers-menu-switch-to-buffer-function 'switch-to-buffer - "*The function to call to select a buffer from the buffers menu. -`switch-to-buffer' is a good choice, as is `pop-to-buffer'." - :type '(radio (function-item switch-to-buffer) - (function-item pop-to-buffer) - (function :tag "Other")) - :group 'buffers-menu) - -(defcustom buffers-menu-omit-function 'buffers-menu-omit-invisible-buffers - "*If non-nil, a function specifying the buffers to omit from the buffers menu. -This is passed a buffer and should return non-nil if the buffer should be -omitted. The default value `buffers-menu-omit-invisible-buffers' omits -buffers that are normally considered \"invisible\" (those whose name -begins with a space)." - :type '(choice (const :tag "None" nil) - function) - :group 'buffers-menu) - -(defcustom buffers-menu-format-buffer-line-function 'format-buffers-menu-line - "*The function to call to return a string to represent a buffer in the -buffers menu. The function is passed a buffer and should return a string. -The default value `format-buffers-menu-line' just returns the name of -the buffer. Also check out `slow-format-buffers-menu-line' which -returns a whole bunch of info about a buffer." - :type 'function - :group 'buffers-menu) - -(defcustom buffers-menu-sort-function - 'sort-buffers-menu-by-mode-then-alphabetically - "*If non-nil, a function to sort the list of buffers in the buffers menu. -It will be passed two arguments (two buffers to compare) and should return -T if the first is \"less\" than the second. One possible value is -`sort-buffers-menu-alphabetically'; another is -`sort-buffers-menu-by-mode-then-alphabetically'." - :type '(choice (const :tag "None" nil) - function) - :group 'buffers-menu) - -(defcustom buffers-menu-grouping-function - 'group-buffers-menu-by-mode-then-alphabetically - "*If non-nil, a function to group buffers in the buffers menu together. -It will be passed two arguments, successive members of the sorted buffers -list after being passed through `buffers-menu-sort-function'. It should -return non-nil if the second buffer begins a new group. The return value -should be the name of the old group, which may be used in hierarchical -buffers menus. The last invocation of the function contains nil as the -second argument, so that the name of the last group can be determined. - -The sensible values of this function are dependent on the value specified -for `buffers-menu-sort-function'." - :type '(choice (const :tag "None" nil) - function) - :group 'buffers-menu) - -(defun buffers-menu-omit-invisible-buffers (buf) - "For use as a value of `buffers-menu-omit-function'. -Omits normally invisible buffers (those whose name begins with a space)." - (not (null (string-match "\\` " (buffer-name buf))))) - -(defun sort-buffers-menu-alphabetically (buf1 buf2) - "For use as a value of `buffers-menu-sort-function'. -Sorts the buffers in alphabetical order by name, but puts buffers beginning -with a star at the end of the list." - (let* ((nam1 (buffer-name buf1)) - (nam2 (buffer-name buf2)) - (star1p (not (null (string-match "\\`*" nam1)))) - (star2p (not (null (string-match "\\`*" nam2))))) - (if (not (eq star1p star2p)) - (not star1p) - (string-lessp nam1 nam2)))) - -(defun sort-buffers-menu-by-mode-then-alphabetically (buf1 buf2) - "For use as a value of `buffers-menu-sort-function'. -Sorts first by major mode and then alphabetically by name, but puts buffers -beginning with a star at the end of the list." - (let* ((nam1 (buffer-name buf1)) - (nam2 (buffer-name buf2)) - (star1p (not (null (string-match "\\`*" nam1)))) - (star2p (not (null (string-match "\\`*" nam2)))) - (mode1 (symbol-value-in-buffer 'major-mode buf1)) - (mode2 (symbol-value-in-buffer 'major-mode buf2))) - (cond ((not (eq star1p star2p)) (not star1p)) - ((and star1p star2p (string-lessp nam1 nam2))) - ((string-lessp mode1 mode2) t) - ((string-lessp mode2 mode1) nil) - (t (string-lessp nam1 nam2))))) - -;; this version is too slow on some machines. -(defun slow-format-buffers-menu-line (buffer) - "For use as a value of `buffers-menu-format-buffer-line-function'. -This returns a string containing a bunch of info about the buffer." - (format "%s%s %-19s %6s %-15s %s" - (if (buffer-modified-p buffer) "*" " ") - (if (symbol-value-in-buffer 'buffer-read-only buffer) "%" " ") - (buffer-name buffer) - (buffer-size buffer) - (symbol-value-in-buffer 'mode-name buffer) - (or (buffer-file-name buffer) ""))) - -(defun format-buffers-menu-line (buffer) - "For use as a value of `buffers-menu-format-buffer-line-function'. -This just returns the buffer's name." - (buffer-name buffer)) - -(defun group-buffers-menu-by-mode-then-alphabetically (buf1 buf2) - "For use as a value of `buffers-menu-grouping-function'. -This groups buffers by major mode. It only really makes sense if -`buffers-menu-sorting-function' is -`sort-buffers-menu-by-mode-then-alphabetically'." - (cond ((string-match "\\`*" (buffer-name buf1)) - (and (null buf2) "*Misc*")) - ((or (null buf2) - (string-match "\\`*" (buffer-name buf2)) - (not (eq (symbol-value-in-buffer 'major-mode buf1) - (symbol-value-in-buffer 'major-mode buf2)))) - (symbol-value-in-buffer 'mode-name buf1)) - (t nil))) - -(defun buffer-menu-save-buffer (buffer) - (save-excursion - (set-buffer buffer) - (save-buffer))) - -(defun buffer-menu-write-file (buffer) - (save-excursion - (set-buffer buffer) - (write-file (read-file-name - (format "Write %s to file: " - (buffer-name (current-buffer))))))) - -(defsubst build-buffers-menu-internal (buffers) - (let (name line) - (mapcar - #'(lambda (buffer) - (if (eq buffer t) - "---" - (setq line (funcall buffers-menu-format-buffer-line-function - buffer)) - (if complex-buffers-menu-p - (delq nil - (list line - (vector "Switch to Buffer" - (list buffers-menu-switch-to-buffer-function - (setq name (buffer-name buffer))) - t) - (if (eq buffers-menu-switch-to-buffer-function - 'switch-to-buffer) - (vector "Switch to Buffer, Other Frame" - (list 'switch-to-buffer-other-frame - (setq name (buffer-name buffer))) - t) - nil) - (if (and (buffer-modified-p buffer) - (buffer-file-name buffer)) - (vector "Save Buffer" - (list 'buffer-menu-save-buffer name) t) - ["Save Buffer" nil nil] - ) - (vector "Save As..." - (list 'buffer-menu-write-file name) t) - (vector "Delete Buffer" (list 'kill-buffer name) - t))) - ;; ### We don't want buffer names to be translated, - ;; ### so we put the buffer name in the suffix. - ;; ### Also, avoid losing with non-ASCII buffer names. - ;; ### We still lose, however, if complex-buffers-menu-p. --mrb - (vector "" - (list buffers-menu-switch-to-buffer-function - (buffer-name buffer)) - t line)))) - buffers))) - -(defun buffers-menu-filter (menu) - "This is the menu filter for the top-level buffers \"Buffers\" menu. -It dynamically creates a list of buffers to use as the contents of the menu. -Only the most-recently-used few buffers will be listed on the menu, for -efficiency reasons. You can control how many buffers will be shown by -setting `buffers-menu-max-size'. You can control the text of the menu -items by redefining the function `format-buffers-menu-line'." - (let ((buffers (delete-if buffers-menu-omit-function (buffer-list)))) - (and (integerp buffers-menu-max-size) - (> buffers-menu-max-size 1) - (> (length buffers) buffers-menu-max-size) - ;; shorten list of buffers (not with submenus!) - (not (and buffers-menu-grouping-function - buffers-menu-submenus-for-groups-p)) - (setcdr (nthcdr buffers-menu-max-size buffers) nil)) - (if buffers-menu-sort-function - (setq buffers (sort buffers buffers-menu-sort-function))) - (if (and buffers-menu-grouping-function - buffers-menu-submenus-for-groups-p - (or (not (integerp buffers-menu-submenus-for-groups-p)) - (> (length buffers) buffers-menu-submenus-for-groups-p))) - (let (groups groupnames current-group) - (mapl - #'(lambda (sublist) - (let ((groupname (funcall buffers-menu-grouping-function - (car sublist) (cadr sublist)))) - (setq current-group (cons (car sublist) current-group)) - (if groupname - (progn - (setq groups (cons (nreverse current-group) - groups)) - (setq groupnames (cons groupname groupnames)) - (setq current-group nil))))) - buffers) - (setq buffers - (mapcar* - #'(lambda (groupname group) - (cons groupname (build-buffers-menu-internal group))) - (nreverse groupnames) - (nreverse groups)))) - (if buffers-menu-grouping-function - (progn - (setq buffers - (mapcon - #'(lambda (sublist) - (cond ((funcall buffers-menu-grouping-function - (car sublist) (cadr sublist)) - (list (car sublist) t)) - (t (list (car sublist))))) - buffers)) - ;; remove a trailing separator. - (and (>= (length buffers) 2) - (let ((lastcdr (nthcdr (- (length buffers) 2) buffers))) - (if (eq t (cadr lastcdr)) - (setcdr lastcdr nil)))))) - (setq buffers (build-buffers-menu-internal buffers))) - (append menu buffers) - )) - -(defun language-environment-menu-filter (menu) - "This is the menu filter for the \"Language Environment\" submenu." - (mapcar (lambda (env-sym) - `[ ,(capitalize (symbol-name env-sym)) - (set-language-environment ',env-sym) t]) - language-environment-list)) - - -;;; The Options menu - -(defvar options-save-faces nil - "if t, save-options will save all the face information. -Set to nil to avoid this. This is recommended on XEmacs 19.15 -and above as we have a much more powerful (read: working) way -of changing and saving faces via cu-edit-faces.el & custom.el.") - -(defconst options-menu-saved-forms - ;; This is really quite a kludge, but it gets the job done. - ;; - ;; remember that we have to conditionalize on default features - ;; both in the forms to evaluate and in the forms output to - ;; .emacs, in case the .emacs is loaded into an XEmacs with - ;; different features. - (purecopy - '( - ;; Editing Options menu. - ;; put case-fold-search first to defeat a bug in the backquote - ;; processing mechanism. Feh! - case-fold-search - `(setq-default overwrite-mode ,(default-value 'overwrite-mode)) - (if (default-value 'overwrite-mode) - '(overwrite-mode 1)) - `(setq-default case-fold-search ,(default-value 'case-fold-search)) - case-replace - (if (and (boundp 'pending-delete-mode) - pending-delete-mode) - '(pending-delete-mode 1)) - zmacs-regions - mouse-yank-at-point - require-final-newline - next-line-add-newlines - - ;; General Options menu. - teach-extended-commands-p - ;; (#### not actually on Options menu) - teach-extended-commands-timeout - debug-on-error - debug-on-quit - - ;; Printing Options menu. - lpr-switches - ps-print-color-p - ps-paper-type - - ;; Other Window Location - get-frame-for-buffer-default-instance-limit - temp-buffer-show-function - (if gnuserv-frame - '(setq gnuserv-frame (selected-frame))) - - ;; Syntax Highlighting - font-lock-auto-fontify - font-lock-use-fonts - font-lock-use-colors - font-lock-maximum-decoration - font-lock-maximum-size - ;; (#### the next two not on Options menu) - font-lock-mode-enable-list - font-lock-mode-disable-list - ;; #### - this structure is clearly broken. There's no way to ever - ;; un-require font-lock via the menus. --Stig - (if (featurep 'font-lock) - '(require 'font-lock)) - (if (and (boundp 'font-lock-mode-hook) - (memq 'turn-on-fast-lock font-lock-mode-hook)) - '(add-hook 'font-lock-mode-hook 'turn-on-fast-lock) - '(remove-hook 'font-lock-mode-hook 'turn-on-fast-lock)) - (if (and (boundp 'font-lock-mode-hook) - (memq 'turn-on-lazy-shot font-lock-mode-hook)) - '(add-hook 'font-lock-mode-hook 'turn-on-lazy-shot) - '(remove-hook 'font-lock-mode-hook 'turn-on-lazy-shot)) - - ;; Paren Highlighting - (if paren-mode - `(progn (require 'paren) (paren-set-mode ',paren-mode))) - - ;; For specifiers, we only save global settings since the others - ;; will belong to objects which only exist during this session. - - ;; Frame Appearance - (if (featurep 'scrollbar) - `(if (featurep 'scrollbar) - (progn - (add-spec-list-to-specifier - scrollbar-width - ',(specifier-spec-list scrollbar-width 'global)) - (add-spec-list-to-specifier - scrollbar-height - ',(specifier-spec-list scrollbar-height 'global))))) - `(add-spec-list-to-specifier - modeline-shadow-thickness - ',(specifier-spec-list modeline-shadow-thickness 'global)) - `(setq-default truncate-lines ,(default-value 'truncate-lines)) - bar-cursor - (if (and (boundp 'blink-cursor-mode) blink-cursor-mode) - '(blink-cursor-mode t)) - - ;; Menubar Appearance - buffers-menu-max-size - complex-buffers-menu-p - buffers-menu-sort-function - buffers-menu-grouping-function - buffers-menu-submenus-for-groups-p - font-menu-ignore-scaled-fonts - font-menu-this-frame-only-p - - ;; Toolbar Appearance - (if (featurep 'toolbar) - `(if (featurep 'toolbar) - (progn - (set-default-toolbar-position - ',(default-toolbar-position)) - (add-spec-list-to-specifier - default-toolbar-visible-p - ',(specifier-spec-list default-toolbar-visible-p 'global)) - (add-spec-list-to-specifier - toolbar-buttons-captioned-p - ',(specifier-spec-list toolbar-buttons-captioned-p - 'global))))) - - ;; mouse - mouse-avoidance-mode - - ;; Open URLs With - browse-url-browser-function - - ;; Now save all faces. - - ;; Setting this in lisp conflicts with X resources. Bad move. --Stig - ;; (list 'set-face-font ''default (face-font-name 'default)) - ;; (list 'set-face-font ''modeline (face-font-name 'modeline)) - (if options-save-faces - (cons 'progn - (mapcar #'(lambda (face) - `(make-face ',face)) - (save-options-non-customized-face-list)))) - - (if options-save-faces - (cons 'progn - (apply 'nconc - (mapcar - #'(lambda (face) - (delq nil - (mapcar - #'(lambda (property) - (if (specifier-spec-list - (face-property face property)) - `(add-spec-list-to-specifier - (face-property ',face ',property) - ',(save-options-specifier-spec-list - face property)))) - (delq 'display-table - (copy-sequence - built-in-face-specifiers))))) - (save-options-non-customized-face-list))))) - - ;; Mule-specific: - (if (featurep 'mule) - `(if (featurep 'mule) - (set-language-environment ',(current-language-environment)))) - )) - "The variables to save; or forms to evaluate to get forms to write out. -This is used by `save-options-menu-settings' and should mirror the -options listed in the Options menu.") - -(defun save-options-non-customized-face-list () - "This function will return a list of all faces that have not been -'customized'." - (delq nil (mapcar '(lambda (face) - (unless (get face 'saved-face) - face)) - (face-list)))) - -(defun save-options-specifier-spec-list (face property) - (if (not (or (eq property 'font) (eq property 'color))) - (specifier-spec-list (face-property face property) 'global) - (let* ((retlist (specifier-spec-list (face-property face property) - 'global)) - (entry (cdr (car retlist))) - item) - (while entry - (setq item (car entry)) - (if (eq property 'font) - (if (font-instance-p (cdr item)) - (setcdr item (font-instance-name (cdr item)))) - (if (color-instance-p (cdr item)) - (setcdr item (color-instance-name (cdr item))))) - (setq entry (cdr entry))) - retlist))) - -(defvar save-options-init-file nil - "File into which to save forms to load the options file (nil for .emacs). -Normally this is nil, which means save into your .emacs file (the value -of `user-init-file'.") - -(defvar save-options-file ".xemacs-options" - "File to save options into. -This file is loaded from your .emacs file. -If this is a relative filename, it is put into the same directory as your -.emacs file.") - -(defun save-options-menu-settings () - "Saves the current settings of the `Options' menu to your `.emacs' file." - (interactive) - ;; we compute the actual filenames now because x-menubar is loaded - ;; at dump time, when the identity of the user running XEmacs is not known. - (let* ((actual-save-options-init-file - (or save-options-init-file - (and (not (equal user-init-file "")) - user-init-file) - (and (eq system-type 'ms-dos) - (concat "~" (user-login-name) "/_emacs")) - (concat "~" (user-login-name) "/.emacs"))) - (actual-save-options-file - (abbreviate-file-name - (expand-file-name - save-options-file - (file-name-directory actual-save-options-init-file)) - ;; Don't hack-homedir in abbreviate-file-name. This will - ;; cause an incorrect expansion if the save-options variables - ;; have ~ in them. - )) - (init-output-buffer (find-file-noselect - actual-save-options-init-file)) - init-output-marker - (options-output-buffer - (find-file-noselect actual-save-options-file)) - options-output-marker) - - (save-excursion - (set-buffer options-output-buffer) - (erase-buffer) - (setq options-output-marker (point-marker))) - - ;; run with current-buffer unchanged so that variables are evaluated in - ;; the current context, instead of in the context of the ".emacs" buffer - ;; or the ".xemacs-options" buffer. - - ;; first write out .xemacs-options. - - (let ((standard-output options-output-marker)) - (princ ";; -*- Mode: Emacs-Lisp -*-\n\n") - (princ "(setq options-file-xemacs-version '(") - (princ emacs-major-version) - (princ " ") - (princ emacs-minor-version) - (princ "))\n") - (let ((print-readably t) - (print-escape-newlines t)) - (mapcar #'(lambda (var) - (princ " ") - (if (symbolp var) - (prin1 (list 'setq-default var - (let ((val (symbol-value var))) - (if (or (memq val '(t nil)) - (and (not (symbolp val)) - (not (consp val)))) - val - (list 'quote val))))) - (setq var (eval var)) - (cond ((eq (car-safe var) 'progn) - (while (setq var (cdr var)) - (prin1 (car var)) - (princ "\n") - (if (cdr var) (princ " ")) - )) - (var - (prin1 var)))) - (if var (princ "\n"))) - options-menu-saved-forms) - )) - (set-marker options-output-marker nil) - (save-excursion - (set-buffer options-output-buffer) - (save-buffer)) - - ;; then fix .emacs. - - (save-excursion - (set-buffer init-output-buffer) - ;; - ;; Find and delete the previously saved data, and position to write. - ;; - (goto-char (point-min)) - (if (re-search-forward "^;; Options Menu Settings *\n" nil 'move) - (let ((p (match-beginning 0))) - (goto-char p) - (or (re-search-forward - "^;; End of Options Menu Settings *\\(\n\\|\\'\\)" - nil t) - (error "can't find END of saved state in .emacs")) - (delete-region p (match-end 0))) - (goto-char (point-max)) - (insert "\n")) - (setq init-output-marker (point-marker))) - - (let ((standard-output init-output-marker)) - (princ ";; Options Menu Settings\n") - (princ ";; =====================\n") - (princ "(cond\n") - (princ " ((and (string-match \"XEmacs\" emacs-version)\n") - (princ " (boundp 'emacs-major-version)\n") - (princ " (or (and\n") - (princ " (= emacs-major-version 19)\n") - (princ " (>= emacs-minor-version 14))\n") - (princ " (= emacs-major-version 20))\n") - (princ " (fboundp 'load-options-file))\n") - (princ " (load-options-file \"") - (princ actual-save-options-file) - (princ "\")))\n") - (princ ";; ============================\n") - (princ ";; End of Options Menu Settings\n")) - - (set-marker init-output-marker nil) - (save-excursion - (set-buffer init-output-buffer) - (save-buffer)) - )) - - -(set-menubar default-menubar) - - -;;; Popup menus. - -(defconst default-popup-menu - '("XEmacs Commands" - :filter edit-menu-filter - ["Undo" advertised-undo t] - ["Cut" x-kill-primary-selection t] - ["Copy" x-copy-primary-selection t] - ["Paste" x-yank-clipboard-selection t] - ["Clear" x-delete-primary-selection t] - "-----" - ["Select Block" mark-paragraph t] - ["Split Window" (split-window) t] - ["Unsplit Window" delete-other-windows t] - )) - -(defvar global-popup-menu nil - "The global popup menu. This is present in all modes. -See the function `popup-menu' for a description of menu syntax.") - -(defvar mode-popup-menu nil - "The mode-specific popup menu. Automatically buffer local. -This is appended to the default items in `global-popup-menu'. -See the function `popup-menu' for a description of menu syntax.") -(make-variable-buffer-local 'mode-popup-menu) - -;; In an effort to avoid massive menu clutter, this mostly worthless menu is -;; superceded by any local popup menu... -(setq-default mode-popup-menu default-popup-menu) - -(defvar activate-popup-menu-hook nil - "Function or functions run before a mode-specific popup menu is made visible. -These functions are called with no arguments, and should interrogate and -modify the value of `global-popup-menu' or `mode-popup-menu' as desired. -Note: this hook is only run if you use `popup-mode-menu' for activating the -global and mode-specific commands; if you have your own binding for button3, -this hook won't be run.") - -(defun popup-mode-menu () - "Pop up a menu of global and mode-specific commands. -The menu is computed by combining `global-popup-menu' and `mode-popup-menu'." - (interactive "@_") - (run-hooks 'activate-popup-menu-hook) - (popup-menu - (cond ((and global-popup-menu mode-popup-menu) - (check-menu-syntax mode-popup-menu) - (let* ((title (car mode-popup-menu)) - (items (cdr mode-popup-menu)) - filters) - ;; Strip keywords from local menu for attaching them at the top - (while (and items - (symbolp (car items))) - (setq items (append filters (list (car items)))) - (setq items (cdr items))) - ;; If filters contains a keyword already present in - ;; `global-popup-menu' you will probably lose. - (append (list (car global-popup-menu)) - filters - (cdr global-popup-menu) - '("---" "---") - (if popup-menu-titles (list title)) - (if popup-menu-titles '("---" "---")) - items))) - (t - (or mode-popup-menu - global-popup-menu - (error "No menu here.")))))) - -(defun popup-buffer-menu (event) - "Pop up a copy of the Buffers menu (from the menubar) where the mouse is clicked." - (interactive "e") - (let ((window (and (event-over-text-area-p event) (event-window event))) - (bmenu nil)) - (or window - (error "Pointer must be in a normal window")) - (select-window window) - (if current-menubar - (setq bmenu (assoc "Buffers" current-menubar))) - (if (null bmenu) - (setq bmenu (assoc "Buffers" default-menubar))) - (if (null bmenu) - (error "Can't find the Buffers menu")) - (popup-menu bmenu))) - -(defun popup-menubar-menu (event) - "Pop up a copy of menu that also appears in the menubar" - ;; by Stig@hackvan.com - (interactive "e") - (let ((window (and (event-over-text-area-p event) (event-window event))) - popup-menubar) - (or window - (error "Pointer must be in a normal window")) - (select-window window) - (and current-menubar (run-hooks 'activate-menubar-hook)) - ;; ##### Instead of having to copy this just to safely get rid of - ;; any nil what we should really do is fix up the internal menubar - ;; code to just ignore nil if generating a popup menu - (setq popup-menubar (delete nil (copy-sequence (or current-menubar - default-menubar)))) - (popup-menu (cons "Menubar Menu" popup-menubar)) - )) - -(global-set-key 'button3 'popup-mode-menu) -;; shift button3 and shift button2 are reserved for Hyperbole -(global-set-key '(meta control button3) 'popup-buffer-menu) -;; The following command is way too dangerous with Custom. -;; (global-set-key '(meta shift button3) 'popup-menubar-menu) - -;; Here's a test of the cool new menu features (from Stig). - -;(setq mode-popup-menu -; '("Test Popup Menu" -; :filter cdr -; ["this item won't appear because of the menu filter" ding t] -; "--:singleLine" -; "singleLine" -; "--:doubleLine" -; "doubleLine" -; "--:singleDashedLine" -; "singleDashedLine" -; "--:doubleDashedLine" -; "doubleDashedLine" -; "--:noLine" -; "noLine" -; "--:shadowEtchedIn" -; "shadowEtchedIn" -; "--:shadowEtchedOut" -; "shadowEtchedOut" -; "--:shadowDoubleEtchedIn" -; "shadowDoubleEtchedIn" -; "--:shadowDoubleEtchedOut" -; "shadowDoubleEtchedOut" -; "--:shadowEtchedInDash" -; "shadowEtchedInDash" -; "--:shadowEtchedOutDash" -; "shadowEtchedOutDash" -; "--:shadowDoubleEtchedInDash" -; "shadowDoubleEtchedInDash" -; "--:shadowDoubleEtchedOutDash" -; "shadowDoubleEtchedOutDash" -; )) - -(defun xemacs-splash-buffer () - "Redisplay XEmacs splash screen in a buffer." - (interactive) - (let ((buffer (get-buffer-create "*Splash*"))) - (set-buffer buffer) - (erase-buffer buffer) - (startup-splash-frame) - (pop-to-buffer buffer) - (delete-other-windows))) - -(provide 'x-menubar) - -;;; x-menubar.el ends here.
--- a/lisp/x11/x-misc.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,78 +0,0 @@ -;;; x-misc.el --- miscellaneous X functions. - -;;; Copyright (C) 1995 Sun Microsystems. -;;; Copyright (C) 1995, 1996 Ben Wing. - -;; Author: Ben Wing <wing@666.com> - -;; 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, 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -(defun x-bogosity-check-resource (name class type) - "Check for a bogus resource specification." - (let ((bogus (x-get-resource - (concat "__no-such-friggin-locale__." name) - (concat "__No-such-friggin-widget__." class) - type 'global nil t))) - (if bogus - (display-warning - 'resource - (format "Bad resource specification encountered: something like - Emacs*%s: %s -You should replace the * with a . in order to get proper behavior when -you use the specifier and/or `set-face-*' functions." name bogus))))) - -(defun x-init-specifier-from-resources (specifier type locale - &rest resource-list) - "Initialize a specifier from the resource database. -LOCALE specifies the locale that is to be initialized and should be -a frame, a device, or 'global. TYPE is the type of the resource and -should be one of 'string, 'boolean, 'integer, or 'natnum. The -remaining args should be conses of names and classes of resources -to be examined. The first resource with a value specified becomes -the spec for SPECIFIER in LOCALE. (However, if SPECIFIER already -has a spec in LOCALE, nothing is done.) Finally, if LOCALE is 'global, -a check is done for bogus resource specifications." - (if (eq locale 'global) - (mapcar #'(lambda (x) - (x-bogosity-check-resource (car x) (cdr x) type)) - resource-list)) - (if (not (specifier-spec-list specifier locale)) - (catch 'done - (while resource-list - (let* ((name (caar resource-list)) - (class (cdar resource-list)) - (resource - (x-get-resource name class type locale nil t))) - (if resource - (progn - (add-spec-to-specifier specifier resource locale) - (throw 'done t)))) - (setq resource-list (cdr resource-list)))))) - -(defun x-get-resource-and-bogosity-check (name class type &optional locale) - (x-bogosity-check-resource name class type) - (x-get-resource name class type locale nil t)) - -;; #### this function is not necessary. -(defun x-get-resource-and-maybe-bogosity-check (name class type &optional - locale) - (if (eq locale 'global) - (x-bogosity-check-resource name class type)) - (x-get-resource name class type locale nil t)) - -;;; x-misc.el ends here
--- a/lisp/x11/x-mouse.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,166 +0,0 @@ -;; Mouse support for X window system. -;; Copyright (C) 1985, 1992, 1993, 1994 Free Software Foundation, Inc. -;; Copyright (C) 1995, 1996 Ben Wing. - -;; 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. - -;;(define-key global-map 'button2 'x-set-point-and-insert-selection) -;; This is reserved for use by Hyperbole. -;;(define-key global-map '(shift button2) 'x-mouse-kill) -(define-key global-map '(control button2) 'x-set-point-and-move-selection) - -(defun x-mouse-kill (event) - "Kill the text between the point and mouse and copy it to the clipboard and -to the cut buffer" - (interactive "@e") - (let ((old-point (point))) - (mouse-set-point event) - (let ((s (buffer-substring old-point (point)))) - (x-own-clipboard s) - (x-store-cutbuffer s)) - (kill-region old-point (point)))) - -(defun x-yank-function () - "Insert the current X selection or, if there is none, insert the X cutbuffer. -A mark is pushed, so that the inserted text lies between point and mark." - (push-mark) - (if (region-active-p) - (if (consp zmacs-region-extent) - ;; pirated code from insert-rectangle in rect.el - ;; perhaps that code should be modified to handle a list of extents - ;; as the rectangle to be inserted? - (let ((lines zmacs-region-extent) - (insertcolumn (current-column)) - (first t)) - (push-mark) - (while lines - (or first - (progn - (forward-line 1) - (or (bolp) (insert ?\n)) - (move-to-column insertcolumn t))) - (setq first nil) - (insert (extent-string (car lines))) - (setq lines (cdr lines)))) - (insert (extent-string zmacs-region-extent))) - (x-insert-selection t))) - -(defun x-insert-selection (&optional check-cutbuffer-p move-point-event) - "Insert the current selection into buffer at point." - (interactive "P") - (let ((text (if check-cutbuffer-p - (or (condition-case () (x-get-selection) (error ())) - (x-get-cutbuffer) - (error "No selection or cut buffer available")) - (x-get-selection)))) - (cond (move-point-event - (mouse-set-point move-point-event) - (push-mark (point))) - ((interactive-p) - (push-mark (point)))) - (insert text) - )) - -(make-obsolete 'x-set-point-and-insert-selection 'mouse-yank) -(defun x-set-point-and-insert-selection (event) - "Set point where clicked and insert the primary selection or the cut buffer." - (interactive "e") - (let ((mouse-yank-at-point nil)) - (mouse-yank event))) - -(defun x-set-point-and-move-selection (event) - "Set point where clicked and move the selected text to that location." - (interactive "e") - ;; Don't try to move the selection if x-kill-primary-selection if going - ;; to fail; just let the appropriate error message get issued. (We need - ;; to insert the selection and set point first, or the selection may - ;; get inserted at the wrong place.) - (and (x-selection-owner-p) - primary-selection-extent - (x-insert-selection t event)) - (x-kill-primary-selection)) - -(defun mouse-track-and-copy-to-cutbuffer (event) - "Make a selection like `mouse-track', but also copy it to the cutbuffer." - (interactive "e") - (mouse-track event) - (cond - ((null primary-selection-extent) - nil) - ((consp primary-selection-extent) - (save-excursion - (set-buffer (extent-object (car primary-selection-extent))) - (x-store-cutbuffer - (mapconcat - 'identity - (extract-rectangle - (extent-start-position (car primary-selection-extent)) - (extent-end-position (car (reverse primary-selection-extent)))) - "\n")))) - (t - (save-excursion - (set-buffer (extent-object primary-selection-extent)) - (x-store-cutbuffer - (buffer-substring (extent-start-position primary-selection-extent) - (extent-end-position primary-selection-extent))))))) - - -(defvar x-pointers-initialized nil) - -(defun x-init-pointer-shape (device) - "Initializes the mouse-pointers of the given device from the resource -database." - (if x-pointers-initialized ; only do it when the first device is created - nil - (set-glyph-image text-pointer-glyph - (or (x-get-resource "textPointer" "Cursor" 'string device) - "xterm")) - (set-glyph-image selection-pointer-glyph - (or (x-get-resource "selectionPointer" "Cursor" 'string device) - "top_left_arrow")) - (set-glyph-image nontext-pointer-glyph - (or (x-get-resource "spacePointer" "Cursor" 'string device) - "xterm")) ; was "crosshair" - (set-glyph-image modeline-pointer-glyph - (or (x-get-resource "modeLinePointer" "Cursor" 'string device) - "sb_v_double_arrow")) - (set-glyph-image gc-pointer-glyph - (or (x-get-resource "gcPointer" "Cursor" 'string device) - "watch")) - (when (featurep 'scrollbar) - (set-glyph-image - scrollbar-pointer-glyph - (or (x-get-resource "scrollbarPointer" "Cursor" 'string device) - "top_left_arrow"))) - (set-glyph-image busy-pointer-glyph - (or (x-get-resource "busyPointer" "Cursor" 'string device) - "watch")) - (set-glyph-image toolbar-pointer-glyph - (or (x-get-resource "toolBarPointer" "Cursor" 'string device) - "left_ptr")) - (let ((fg - (x-get-resource "pointerColor" "Foreground" 'string device))) - (and fg - (set-face-foreground 'pointer fg))) - (let ((bg - (x-get-resource "pointerBackground" "Background" 'string device))) - (and bg - (set-face-background 'pointer bg))) - (setq x-pointers-initialized t)) - nil) -
--- a/lisp/x11/x-scrollbar.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,68 +0,0 @@ -;;; x-scrollbar.el --- scrollbar resourcing and such. - -;;; Copyright (C) 1995 Sun Microsystems. -;;; Copyright (C) 1995, 1996 Ben Wing. - -;; Author: Ben Wing <wing@666.com> - -;; 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. - -(defun x-init-scrollbar-from-resources (locale) - (x-init-specifier-from-resources - scrollbar-width 'natnum locale - '("scrollBarWidth" . "ScrollBarWidth") - ;; The name strings are wrong, but the scrollbar name is - ;; non-deterministic so it is a poor way to set a resource - ;; for the scrollbar anyhow. - (cond ((featurep 'athena-scrollbars) - '("scrollbar.thickness" . "ScrollBar.Thickness")) - ((featurep 'lucid-scrollbars) - '("scrollbar.width" . "XlwScrollBar.Width")) - ((featurep 'motif-scrollbars) - '("scrollbar.width" . "XmScrollBar.Width")))) - ;; Athena scrollbars accept either 'thickness' or 'width'. - ;; If any of the previous resources succeeded, the following - ;; call does nothing; so there's no harm in doing it all the - ;; time. - (if (featurep 'athena-scrollbars) - (x-init-specifier-from-resources - scrollbar-width 'natnum locale - '("scrollbar.width" . "ScrollBar.Width"))) - - ;; lather, rinse, repeat. - (x-init-specifier-from-resources - scrollbar-height 'natnum locale - '("scrollBarHeight" . "ScrollBarHeight") - ;; The name strings are wrong, but the scrollbar name is - ;; non-deterministic so it is a poor way to set a resource - ;; for the scrollbar anyhow. - (cond ((featurep 'athena-scrollbars) - '("scrollbar.thickness" . "ScrollBar.Thickness")) - ((featurep 'lucid-scrollbars) - '("scrollbar.height" . "XlwScrollBar.Height")) - ((featurep 'motif-scrollbars) - '("scrollbar.height" . "XmScrollBar.Height")))) - ;; Athena scrollbars accept either 'thickness' or 'height'. - ;; If any of the previous resources succeeded, the following - ;; call does nothing; so there's no harm in doing it all the - ;; time. - (if (featurep 'athena-scrollbars) - (x-init-specifier-from-resources - scrollbar-height 'natnum locale - '("scrollbar.height" . "ScrollBar.Height")))) -
--- a/lisp/x11/x-select.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,641 +0,0 @@ -;; x-select.el --- Elisp interface to X Selections. -;; Copyright (C) 1990 Free Software Foundation, Inc. -;; Copyright (C) 1995 Sun Microsystems. - -;; 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. - -;;; The selection code requires us to use certain symbols whose names are -;;; all upper-case; this may seem tasteless, but it makes there be a 1:1 -;;; correspondence between these symbols and X Atoms (which are upcased). - -;;; Synched up with: FSF 19.30 (select.el). - -;;; Code: - -(defvar x-selected-text-type - (if (featurep 'mule) '(COMPOUND_TEXT STRING) 'STRING) - "The type atom used to obtain selections from the X server. -Can be either a valid X selection data type, or a list of such types. -COMPOUND_TEXT and STRING are the most commonly used data types. -If a list is provided, the types are tried in sequence until -there is a successful conversion.") - -(defun x-get-selection (&optional type data-type) - "Return the value of an X Windows selection. -The argument TYPE (default `PRIMARY') says which selection, -and the argument DATA-TYPE (default `STRING', or `COMPOUND_TEXT' under Mule) -says how to convert the data." - (or type (setq type 'PRIMARY)) - (or data-type (setq data-type x-selected-text-type)) - (let ((text - (if (consp data-type) - (condition-case err - (x-get-selection-internal type (car data-type)) - (selection-conversion-error - (if (cdr data-type) - (x-get-selection type (cdr data-type)) - (signal (car err) (cdr err))))) - (x-get-selection-internal type data-type)))) - (when (and (consp text) (symbolp (car text))) - (setq text (cdr text))) - (when (not (stringp text)) - (error "Selection is not a string: %S" text)) - text)) - -(defun x-get-secondary-selection () - "Return text selected from some X window." - (x-get-selection 'SECONDARY)) - -(defun x-get-clipboard () - "Return text pasted to the clipboard." - (x-get-selection 'CLIPBOARD)) - - -(defvar primary-selection-extent nil - "The extent of the primary selection; don't use this.") - -(defvar secondary-selection-extent nil - "The extent of the secondary selection; don't use this.") - - -(defun x-select-make-extent-for-selection (selection previous-extent) - ;; Given a selection, this makes an extent in the buffer which holds that - ;; selection, for highlighting purposes. If the selection isn't associated - ;; with a buffer, this does nothing. - (let ((buffer nil) - (valid (and (extentp previous-extent) - (extent-object previous-extent) - (buffer-live-p (extent-object previous-extent)))) - start end) - (cond ((stringp selection) - ;; if we're selecting a string, lose the previous extent used - ;; to highlight the selection. - (setq valid nil)) - ((consp selection) - (setq start (min (car selection) (cdr selection)) - end (max (car selection) (cdr selection)) - valid (and valid - (eq (marker-buffer (car selection)) - (extent-object previous-extent))) - buffer (marker-buffer (car selection)))) - ((extentp selection) - (setq start (extent-start-position selection) - end (extent-end-position selection) - valid (and valid - (eq (extent-object selection) - (extent-object previous-extent))) - buffer (extent-object selection))) - (t - (signal 'error (list "invalid selection" selection)))) - - (if valid - nil - (condition-case () - (if (listp previous-extent) - (mapcar 'delete-extent previous-extent) - (delete-extent previous-extent)) - (error nil))) - - (if (not buffer) - ;; string case - nil - ;; normal case - (if valid - (set-extent-endpoints previous-extent start end) - (setq previous-extent (make-extent start end buffer)) - - ;; Make the extent be closed on the right, which means that if - ;; characters are inserted exactly at the end of the extent, the - ;; extent will grow to cover them. This is important for shell - ;; buffers - suppose one makes a selection, and one end is at - ;; point-max. If the shell produces output, that marker will remain - ;; at point-max (its position will increase). So it's important that - ;; the extent exhibit the same behavior, lest the region covered by - ;; the extent (the visual indication), and the region between point - ;; and mark (the actual selection value) become different! - (set-extent-property previous-extent 'end-open nil) - - (cond - (mouse-track-rectangle-p - (setq previous-extent (list previous-extent)) - (default-mouse-track-next-move-rect start end previous-extent) - )) - previous-extent)))) - -;; FSFmacs calls this `x-set-selection', and reverses the -;; arguments (duh ...). This order is more logical. -(defun x-own-selection (data &optional type) - "Make an X Windows selection of type TYPE and value DATA. -The argument TYPE (default `PRIMARY') says which selection, -and DATA specifies the contents. DATA may be a string, -a symbol, an integer (or a cons of two integers or list of two integers). - -The selection may also be a cons of two markers pointing to the same buffer, -or an overlay. In these cases, the selection is considered to be the text -between the markers *at whatever time the selection is examined*. -Thus, editing done in the buffer after you specify the selection -can alter the effective value of the selection. - -The data may also be a vector of valid non-vector selection values. - -Interactively, the text of the region is used as the selection value." - (interactive (if (not current-prefix-arg) - (list (read-string "Store text for pasting: ")) - (list (substring (region-beginning) (region-end))))) - ;FSFmacs huh?? It says: - ;; "This is for temporary compatibility with pre-release Emacs 19." - ;(if (stringp type) - ; (setq type (intern type))) - (or (x-valid-simple-selection-p data) - (and (vectorp data) - (let ((valid t) - (i (1- (length data)))) - (while (>= i 0) - (or (x-valid-simple-selection-p (aref data i)) - (setq valid nil)) - (setq i (1- i))) - valid)) - (signal 'error (list "invalid selection" data))) - (or type (setq type 'PRIMARY)) - (if data - (x-own-selection-internal type data) - (x-disown-selection-internal type)) - (cond ((eq type 'PRIMARY) - (setq primary-selection-extent - (x-select-make-extent-for-selection - data primary-selection-extent))) - ((eq type 'SECONDARY) - (setq secondary-selection-extent - (x-select-make-extent-for-selection - data secondary-selection-extent)))) - (setq zmacs-region-stays t) - data) - -(defun x-valid-simple-selection-p (data) - (or (stringp data) - ;FSFmacs huh?? (symbolp data) - (integerp data) - (and (consp data) - (integerp (car data)) - (or (integerp (cdr data)) - (and (consp (cdr data)) - (integerp (car (cdr data)))))) - (extentp data) - (and (consp data) - (markerp (car data)) - (markerp (cdr data)) - (marker-buffer (car data)) - (marker-buffer (cdr data)) - (eq (marker-buffer (car data)) - (marker-buffer (cdr data))) - (buffer-live-p (marker-buffer (car data))) - (buffer-live-p (marker-buffer (cdr data)))))) - -(defun x-own-secondary-selection (selection &optional type) - "Make a secondary X Selection of the given argument. The argument may be a -string or a cons of two markers (in which case the selection is considered to -be the text between those markers)." - (interactive (if (not current-prefix-arg) - (list (read-string "Store text for pasting: ")) - (list (cons ;; these need not be ordered. - (copy-marker (point-marker)) - (copy-marker (mark-marker)))))) - (x-own-selection selection 'SECONDARY)) - - -(defun x-own-clipboard (string) - "Paste the given string to the X Clipboard." - (x-own-selection string 'CLIPBOARD)) - - -(defun x-disown-selection (&optional secondary-p) - "Assuming we own the selection, disown it. With an argument, discard the -secondary selection instead of the primary selection." - (x-disown-selection-internal (if secondary-p 'SECONDARY 'PRIMARY))) - -(defun x-dehilight-selection (selection) - "for use as a value of `x-lost-selection-hooks'." - (cond ((eq selection 'PRIMARY) - (if primary-selection-extent - (let ((inhibit-quit t)) - (if (consp primary-selection-extent) - (mapcar 'delete-extent primary-selection-extent) - (delete-extent primary-selection-extent)) - (setq primary-selection-extent nil))) - (if zmacs-regions (zmacs-deactivate-region))) - ((eq selection 'SECONDARY) - (if secondary-selection-extent - (let ((inhibit-quit t)) - (if (consp secondary-selection-extent) - (mapcar 'delete-extent secondary-selection-extent) - (delete-extent secondary-selection-extent)) - (setq secondary-selection-extent nil))))) - nil) - -(setq x-lost-selection-hooks 'x-dehilight-selection) - -(defun x-notice-selection-requests (selection type successful) - "for possible use as the value of x-sent-selection-hooks." - (if (not successful) - (message "Selection request failed to convert %s to %s" - selection type) - (message "Sent selection %s as %s" selection type))) - -(defun x-notice-selection-failures (selection type successful) - "for possible use as the value of x-sent-selection-hooks." - (or successful - (message "Selection request failed to convert %s to %s" - selection type))) - -;(setq x-sent-selection-hooks 'x-notice-selection-requests) -;(setq x-sent-selection-hooks 'x-notice-selection-failures) - - -;;; Selections in killed buffers -;;; this function is called by kill-buffer as if it were on the -;;; kill-buffer-hook (though it isn't really). - -(defun xselect-kill-buffer-hook () - ;; Probably the right thing is to write a C function to return a list - ;; of the selections which emacs owns, since it could conceivably own - ;; a user-defined selection type that we've never heard of. - (xselect-kill-buffer-hook-1 'PRIMARY) - (xselect-kill-buffer-hook-1 'SECONDARY) - (xselect-kill-buffer-hook-1 'CLIPBOARD)) - -(defun xselect-kill-buffer-hook-1 (selection) - (let (value) - (if (and (x-selection-owner-p selection) - (setq value (x-get-selection-internal selection '_EMACS_INTERNAL)) - ;; The _EMACS_INTERNAL selection type has a converter registered - ;; for it that does no translation. This only works if emacs is - ;; requesting the selection from itself. We could have done this - ;; by writing a C function to return the raw selection data, and - ;; that might be the right way to do this, but this was easy. - (or (and (consp value) - (markerp (car value)) - (eq (current-buffer) (marker-buffer (car value)))) - (and (extent-live-p value) - (eq (current-buffer) (extent-object value))) - (and (extentp value) (not (extent-live-p value))))) - (x-disown-selection-internal selection)))) - - -;;; Cut Buffer support - -;;; FSF name x-get-cut-buffer -(defun x-get-cutbuffer (&optional which-one) - "Returns the value of one of the 8 X server cut buffers. Optional arg -WHICH-ONE should be a number from 0 to 7, defaulting to 0. -Cut buffers are considered obsolete\; you should use selections instead. -This function does nothing if support for cut buffers was not compiled -into Emacs." - (and (fboundp 'x-get-cutbuffer-internal) - (x-get-cutbuffer-internal - (if which-one - (aref [CUT_BUFFER0 CUT_BUFFER1 CUT_BUFFER2 CUT_BUFFER3 - CUT_BUFFER4 CUT_BUFFER5 CUT_BUFFER6 CUT_BUFFER7] - which-one) - 'CUT_BUFFER0)))) - -;;; FSF name x-set-cut-buffer -(defun x-store-cutbuffer (string &optional push) - "Store STRING into the X server's primary cut buffer. -If PUSH is non-nil, also rotate the cut buffers: -this means the previous value of the primary cut buffer moves the second -cut buffer, and the second to the third, and so on (there are 8 buffers.) -Cut buffers are considered obsolete; you should use selections instead. -This function does nothing if support for cut buffers was not compiled -into Emacs." - (and (fboundp 'x-store-cutbuffer-internal) - (progn - ;; Check the data type of STRING. - (substring string 0 0) - (if push - (x-rotate-cutbuffers-internal 1)) - (x-store-cutbuffer-internal 'CUT_BUFFER0 string)))) - - -;;; Random utility functions - -(defun x-cut-copy-clear-internal (mode) - (or (memq mode '(cut copy clear)) (error "unkown mode %S" mode)) - (or (x-selection-owner-p) - (error "emacs does not own the primary selection")) - (setq last-command nil) - (or primary-selection-extent - (error "the primary selection is not an extent?")) - (save-excursion - (let (rect-p b s e) - (cond - ((consp primary-selection-extent) - (setq rect-p t - b (extent-object (car primary-selection-extent)) - s (extent-start-position (car primary-selection-extent)) - e (extent-end-position (car (reverse primary-selection-extent))))) - (t - (setq rect-p nil - b (extent-object primary-selection-extent) - s (extent-start-position primary-selection-extent) - e (extent-end-position primary-selection-extent)))) - (set-buffer b) - (cond ((memq mode '(cut copy)) - (if rect-p - (progn - ;; 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"))) - (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 - ;; some other way, but owning the clipboard twice in that case - ;; wouldn't actually hurt anything. - (or (and (consp kill-hooks) (memq 'x-own-clipboard kill-hooks)) - (x-own-clipboard (car kill-ring))))) - (cond ((memq mode '(cut clear)) - (if rect-p - (delete-rectangle s e) - (delete-region s e)))) - (x-disown-selection nil) - ))) - -(defun x-copy-primary-selection () - "Copy the selection to the Clipboard and the kill ring." - (interactive) - (x-cut-copy-clear-internal 'copy)) - -(defun x-kill-primary-selection () - "Copy the selection to the Clipboard and the kill ring, then delete it." - (interactive "*") - (x-cut-copy-clear-internal 'cut)) - -(defun x-delete-primary-selection () - "Delete the selection without copying it to the Clipboard or the kill ring." - (interactive "*") - (x-cut-copy-clear-internal 'clear)) - -(defun x-yank-clipboard-selection () - "Insert the current Clipboard selection at point." - (interactive "*") - (setq last-command nil) - (setq this-command 'yank) ; so that yank-pop works. - (let ((clip (x-get-clipboard))) - (or clip (error "there is no clipboard selection")) - (push-mark) - (insert clip))) - -;;; Functions to convert the selection into various other selection types. -;;; Every selection type that emacs handles is implemented this way, except -;;; for TIMESTAMP, which is a special case. - -(defun xselect-convert-to-text (selection type value) - (cond ((stringp value) - value) - ((extentp value) - (save-excursion - (set-buffer (extent-object value)) - (save-restriction - (widen) - (buffer-substring (extent-start-position value) - (extent-end-position value))))) - ((and (consp value) - (markerp (car value)) - (markerp (cdr value))) - (or (eq (marker-buffer (car value)) (marker-buffer (cdr value))) - (signal 'error - (list "markers must be in the same buffer" - (car value) (cdr value)))) - (save-excursion - (set-buffer (or (marker-buffer (car value)) - (error "selection is in a killed buffer"))) - (save-restriction - (widen) - (buffer-substring (car value) (cdr value))))) - (t nil))) - -(defun xselect-convert-to-string (selection type value) - (let ((outval (xselect-convert-to-text selection type value))) - ;; force the string to be not in Compound Text format. - (if (stringp outval) - (cons 'STRING outval) - outval))) - -(defun xselect-convert-to-compound-text (selection type value) - ;; converts to compound text automatically - (xselect-convert-to-text selection type value)) - -(defun xselect-convert-to-length (selection type value) - (let ((value - (cond ((stringp value) - (length value)) - ((extentp value) - (extent-length value)) - ((and (consp value) - (markerp (car value)) - (markerp (cdr value))) - (or (eq (marker-buffer (car value)) - (marker-buffer (cdr value))) - (signal 'error - (list "markers must be in the same buffer" - (car value) (cdr value)))) - (abs (- (car value) (cdr value))))))) - (if value ; force it to be in 32-bit format. - (cons (ash value -16) (logand value 65535)) - nil))) - -(defun xselect-convert-to-targets (selection type value) - ;; return a vector of atoms, but remove duplicates first. - (let* ((all (cons 'TIMESTAMP (mapcar 'car selection-converter-alist))) - (rest all)) - (while rest - (cond ((memq (car rest) (cdr rest)) - (setcdr rest (delq (car rest) (cdr rest)))) - ((eq (car (cdr rest)) '_EMACS_INTERNAL) ; shh, it's a secret - (setcdr rest (cdr (cdr rest)))) - (t - (setq rest (cdr rest))))) - (apply 'vector all))) - -(defun xselect-convert-to-delete (selection type value) - (x-disown-selection-internal selection) - ;; A return value of nil means that we do not know how to do this conversion, - ;; and replies with an "error". A return value of NULL means that we have - ;; done the conversion (and any side-effects) but have no value to return. - 'NULL) - -(defun xselect-convert-to-filename (selection type value) - (cond ((extentp value) - (buffer-file-name (or (extent-object value) - (error "selection is in a killed buffer")))) - ((and (consp value) - (markerp (car value)) - (markerp (cdr value))) - (buffer-file-name (or (marker-buffer (car value)) - (error "selection is in a killed buffer")))) - (t nil))) - -(defun xselect-convert-to-charpos (selection type value) - (let (a b tmp) - (cond ((cond ((extentp value) - (setq a (extent-start-position value) - b (extent-end-position value))) - ((and (consp value) - (markerp (car value)) - (markerp (cdr value))) - (setq a (car value) - b (cdr value)))) - (setq a (1- a) b (1- b)) ; zero-based - (if (< b a) (setq tmp a a b b tmp)) - (cons 'SPAN - (vector (cons (ash a -16) (logand a 65535)) - (cons (ash b -16) (logand b 65535)))))))) - -(defun xselect-convert-to-lineno (selection type value) - (let (a b buf tmp) - (cond ((cond ((extentp value) - (setq buf (extent-object value) - a (extent-start-position value) - b (extent-end-position value))) - ((and (consp value) - (markerp (car value)) - (markerp (cdr value))) - (setq a (marker-position (car value)) - b (marker-position (cdr value)) - buf (marker-buffer (car value))))) - (save-excursion - (set-buffer buf) - (save-restriction - (widen) - (goto-char a) - (beginning-of-line) - (setq a (1+ (count-lines 1 (point)))) - (goto-char b) - (beginning-of-line) - (setq b (1+ (count-lines 1 (point)))))) - (if (< b a) (setq tmp a a b b tmp)) - (cons 'SPAN - (vector (cons (ash a -16) (logand a 65535)) - (cons (ash b -16) (logand b 65535)))))))) - -(defun xselect-convert-to-colno (selection type value) - (let (a b buf tmp) - (cond ((cond ((extentp value) - (setq buf (extent-object value) - a (extent-start-position value) - b (extent-end-position value))) - ((and (consp value) - (markerp (car value)) - (markerp (cdr value))) - (setq a (car value) - b (cdr value) - buf (marker-buffer a)))) - (save-excursion - (set-buffer buf) - (goto-char a) - (setq a (current-column)) - (goto-char b) - (setq b (current-column))) - (if (< b a) (setq tmp a a b b tmp)) - (cons 'SPAN - (vector (cons (ash a -16) (logand a 65535)) - (cons (ash b -16) (logand b 65535)))))))) - -(defun xselect-convert-to-sourceloc (selection type value) - (let (a b buf file-name tmp) - (cond ((cond ((extentp value) - (setq buf (or (extent-object value) - (error "selection is in a killed buffer")) - a (extent-start-position value) - b (extent-end-position value) - file-name (buffer-file-name buf))) - ((and (consp value) - (markerp (car value)) - (markerp (cdr value))) - (setq a (marker-position (car value)) - b (marker-position (cdr value)) - buf (or (marker-buffer (car value)) - (error "selection is in a killed buffer")) - file-name (buffer-file-name buf)))) - (save-excursion - (set-buffer buf) - (save-restriction - (widen) - (goto-char a) - (beginning-of-line) - (setq a (1+ (count-lines 1 (point)))) - (goto-char b) - (beginning-of-line) - (setq b (1+ (count-lines 1 (point)))))) - (if (< b a) (setq tmp a a b b tmp)) - (format "%s:%d" file-name a))))) - -(defun xselect-convert-to-os (selection type size) - (symbol-name system-type)) - -(defun xselect-convert-to-host (selection type size) - (system-name)) - -(defun xselect-convert-to-user (selection type size) - (user-full-name)) - -(defun xselect-convert-to-class (selection type size) - x-emacs-application-class) - -;; We do not try to determine the name Emacs was invoked with, -;; because it is not clean for a program's behavior to depend on that. -(defun xselect-convert-to-name (selection type size) - ;invocation-name - "xemacs") - -(defun xselect-convert-to-integer (selection type value) - (and (integerp value) - (cons (ash value -16) (logand value 65535)))) - -(defun xselect-convert-to-atom (selection type value) - (and (symbolp value) value)) - -(defun xselect-convert-to-identity (selection type value) ; used internally - (vector value)) - -(setq selection-converter-alist - '((TEXT . xselect-convert-to-text) - (STRING . xselect-convert-to-string) - (COMPOUND_TEXT . xselect-convert-to-compound-text) - (TARGETS . xselect-convert-to-targets) - (LENGTH . xselect-convert-to-length) - (DELETE . xselect-convert-to-delete) - (FILE_NAME . xselect-convert-to-filename) - (CHARACTER_POSITION . xselect-convert-to-charpos) - (SOURCE_LOC . xselect-convert-to-sourceloc) - (LINE_NUMBER . xselect-convert-to-lineno) - (COLUMN_NUMBER . xselect-convert-to-colno) - (OWNER_OS . xselect-convert-to-os) - (HOST_NAME . xselect-convert-to-host) - (USER . xselect-convert-to-user) - (CLASS . xselect-convert-to-class) - (NAME . xselect-convert-to-name) - (ATOM . xselect-convert-to-atom) - (INTEGER . xselect-convert-to-integer) - (_EMACS_INTERNAL . xselect-convert-to-identity) - )) - -;FSFmacs (provide 'select) - -;;; x-select.el ends here. -
--- a/lisp/x11/x-toolbar.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,475 +0,0 @@ -;;; x-toolbar.el -- Runtime initialization of XEmacs toolbar -;; Copyright (C) 1997 Free Software Foundation, Inc. -;; Copyright (C) 1994 Andy Piper <andyp@parallax.demon.co.uk> -;; Copyright (C) 1995 Board of Trustees, University of Illinois -;; Copyright (C) 1996 Ben Wing <wing@666.com> - -;; Maintainer: XEmacs development team -;; Keywords: frames - -;; 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: Not in FSF - -;;; Commentary: - -;; Miscellaneous toolbar functions, useful for users to redefine, in -;; order to get different behaviour. - -;;; Code: - -(eval-when-compile - (require 'pending-del)) - -(defgroup toolbar nil - "Configure XEmacs Toolbar functions and properties" - :group 'environment) - - -(defun toolbar-not-configured () - (ding) - (message "Configure the item via `M-x customize RET toolbar RET'")) - -(defcustom toolbar-open-function 'find-file - "*Function to call when the open icon is selected." - :type '(radio (function-item find-file) - (function :tag "Other")) - :group 'toolbar) - -(defun toolbar-open () - (interactive) - (call-interactively toolbar-open-function)) - -(defcustom toolbar-dired-function 'dired - "*Function to call when the dired icon is selected." - :type '(radio (function-item dired) - (function :tag "Other")) - :group 'toolbar) - -(defun toolbar-dired () - (interactive) - (call-interactively toolbar-dired-function)) - -(defcustom toolbar-save-function 'save-buffer - "*Function to call when the save icon is selected." - :type '(radio (function-item save-buffer) - (function :tag "Other")) - :group 'toolbar) - -(defun toolbar-save () - (interactive) - (call-interactively toolbar-save-function)) - -(defcustom toolbar-print-function 'lpr-buffer - "*Function to call when the print icon is selected." - :type '(radio (function-item lpr-buffer) - (function :tag "Other")) - :group 'toolbar) - -(defun toolbar-print () - (interactive) - (call-interactively toolbar-print-function)) - -(defcustom toolbar-cut-function 'x-kill-primary-selection - "*Function to call when the cut icon is selected." - :type '(radio (function-item x-kill-primary-selection) - (function :tag "Other")) - :group 'toolbar) - -(defun toolbar-cut () - (interactive) - (call-interactively toolbar-cut-function)) - -(defcustom toolbar-copy-function 'x-copy-primary-selection - "*Function to call when the copy icon is selected." - :type '(radio (function-item x-copy-primary-selection) - (function :tag "Other")) - :group 'toolbar) - -(defun toolbar-copy () - (interactive) - (call-interactively toolbar-copy-function)) - -(defcustom toolbar-paste-function 'x-yank-clipboard-selection - "*Function to call when the paste icon is selected." - :type '(radio (function-item x-yank-clipboard-selection) - (function :tag "Other")) - :group 'toolbar) - -(defun toolbar-paste () - (interactive) - ;; This horrible kludge is for pending-delete to work correctly. - (and (boundp 'pending-delete) - pending-delete - (let ((this-command toolbar-paste-function)) - (pending-delete-pre-hook))) - (call-interactively toolbar-paste-function)) - -(defcustom toolbar-undo-function 'undo - "*Function to call when the undo icon is selected." - :type '(radio (function-item undo) - (function :tag "Other")) - :group 'toolbar) - -(defun toolbar-undo () - (interactive) - (call-interactively toolbar-undo-function)) - -(defcustom toolbar-replace-function 'query-replace - "*Function to call when the replace icon is selected." - :type '(radio (function-item query-replace) - (function :tag "Other")) - :group 'toolbar) - -(defun toolbar-replace () - (interactive) - (call-interactively toolbar-replace-function)) - -;; -;; toolbar ispell variables and defuns -;; - -(defun toolbar-ispell-internal () - (interactive) - (if (region-active-p) - (ispell-region (region-beginning) (region-end)) - (ispell-buffer))) - -(defcustom toolbar-ispell-function 'toolbar-ispell-internal - "*Function to call when the ispell icon is selected." - :type '(radio (function-item toolbar-ispell-internal) - (function :tag "Other")) - :group 'toolbar) - -(defun toolbar-ispell () - "Intelligently spell the region or buffer." - (interactive) - (call-interactively toolbar-ispell-function)) - -;; -;; toolbar mail variables and defuns -;; - -;; This used to be a macro that expanded its arguments to a form that -;; called `call-process'. With the advent of customize, it's better -;; to have it as a defun, to make customization easier. -(defun toolbar-external (process &rest args) - (interactive) - (apply 'call-process process nil 0 nil args)) - -(defcustom toolbar-mail-commands-alist - `((not-configured . toolbar-not-configured) - (vm . vm) - (gnus . gnus-no-server) - (rmail . rmail) - (mh . mh-rmail) - (pine . (toolbar-external "xterm" "-e" "pine")) ; *gag* - (elm . (toolbar-external "xterm" "-e" "elm")) - (mutt . (toolbar-external "xterm" "-e" "mutt")) - (exmh . (toolbar-external "exmh")) - (netscape . (toolbar-external "netscape" "mailbox:"))) - "*Alist of mail readers and their commands. -The car of each alist element is the mail reader, and the cdr is the form -used to start it." - :type '(repeat (cons :format "%v" - (symbol :tag "Mailer") (function :tag "Start with"))) - :group 'toolbar) - -(defcustom toolbar-mail-reader 'not-configured - "*Mail reader toolbar will invoke. -The legal values are the keys from `toolbar-mail-command-alist', which - should be used to add new mail readers. -Mail readers known by default are vm, gnus, rmail, mh, pine, elm, - mutt, exmh and netscape." - :type '(choice (const :tag "Not Configured" not-configured) - (const vm) (const gnus) (const rmail) (const mh) - (const pine) (const elm) (const mutt) (const exmh) - (const netscape) - (symbol :tag "Other" - :validate (lambda (wid) - (if (assq (widget-value wid) - toolbar-mail-commands-alist) - nil - (widget-put wid :error - "Unknown mail reader") - wid)))) - :group 'toolbar) - - -(defun toolbar-mail () - "Run mail in a separate frame." - (interactive) - (let ((command (assq toolbar-mail-reader toolbar-mail-commands-alist))) - (if (not command) - (error "Uknown mail reader %s" toolbar-mail-reader)) - (funcall (cdr command)))) - -;; -;; toolbar info variables and defuns -;; - -(defvar toolbar-info-frame nil - "The frame in which info is displayed.") - -(defcustom Info-frame-plist - (append (list 'width 80) - (let ((h (plist-get default-frame-plist 'height))) - (when h (list 'height h)))) - "Frame plist for the Info frame." - :type '(repeat (group :inline t - (symbol :tag "Property") - (sexp :tag "Value"))) - :group 'info) - -(defun toolbar-info () - "Run info in a separate frame." - (interactive) - (if (or (not toolbar-info-frame) - (not (frame-live-p toolbar-info-frame))) - (progn - (setq toolbar-info-frame (make-frame Info-frame-plist)) - (select-frame toolbar-info-frame) - (raise-frame toolbar-info-frame))) - (if (frame-iconified-p toolbar-info-frame) - (deiconify-frame toolbar-info-frame)) - (select-frame toolbar-info-frame) - (raise-frame toolbar-info-frame) - (info)) - -;; -;; toolbar debug variables and defuns -;; - -(defun toolbar-debug () - (interactive) - (if (featurep 'eos-debugger) - (call-interactively 'eos::start-debugger) - (require 'gdbsrc) - (call-interactively 'gdbsrc))) - -(defvar compile-command) - -(defun toolbar-compile () - "Run compile without having to touch the keyboard." - (interactive) - (require 'compile) - (popup-dialog-box - `(,(concat "Compile:\n " compile-command) - ["Compile" (compile compile-command) t] - ["Edit command" compile t] - nil - ["Cancel" (message "Quit") t]))) - -;; -;; toolbar news variables and defuns -;; - -(defcustom toolbar-news-commands-alist - `((not-configured . toolbar-not-configured) - (gnus . toolbar-gnus) ; M-x all-hail-gnus - (rn . (toolbar-external "xterm" "-e" "rn")) - (nn . (toolbar-external "xterm" "-e" "nn")) - (trn . (toolbar-external "xterm" "-e" "trn")) - (xrn . (toolbar-external "xrn")) - (slrn . (toolbar-external "xterm" "-e" "slrn")) - (pine . (toolbar-external "xterm" "-e" "pine")) ; *gag* - (tin . (toolbar-external "xterm" "-e" "tin")) ; *gag* - (netscape . (toolbar-external "netscape" "news:"))) - "*Alist of news readers and their commands. -The car of each alist element the pair is the news reader, and the cdr -is the form used to start it." - :type '(repeat (cons :format "%v" - (symbol :tag "Reader") (sexp :tag "Start with"))) - :group 'toolbar) - -(defcustom toolbar-news-reader 'not-configured - "*News reader toolbar will invoke. -The legal values are the keys from `toolbar-news-command-alist', which should - be used to add new news readers. -Newsreaders known by default are gnus, rn, nn, trn, xrn, slrn, pine - and netscape." - :type '(choice (const :tag "Not Configured" not-configured) - (const gnus) (const rn) (const nn) (const trn) - (const xrn) (const slrn) (const pine) (const tin) - (const netscape) - (symbol :tag "Other" - :validate (lambda (wid) - (if (assq (widget-value wid) - toolbar-news-commands-alist) - nil - (widget-put wid :error - "Unknown news reader") - wid)))) - :group 'toolbar) - -(defcustom toolbar-news-use-separate-frame t - "*Whether Gnus is invoked in a separate frame." - :type 'boolean - :group 'toolbar) - -(defvar toolbar-news-frame nil - "The frame in which news is displayed.") - -(defvar toolbar-news-frame-properties nil - "The properties of the frame in which news is displayed.") - -(defun toolbar-gnus () - "Run Gnus in a separate frame." - (interactive) - (when (or (not toolbar-news-frame) - (not (frame-live-p toolbar-news-frame))) - (setq toolbar-news-frame (make-frame toolbar-news-frame-properties)) - (add-hook 'gnus-exit-gnus-hook - (lambda () - (when (frame-live-p toolbar-news-frame) - (if (cdr (frame-list)) - (delete-frame toolbar-news-frame)) - (setq toolbar-news-frame nil)))) - (select-frame toolbar-news-frame) - (raise-frame toolbar-news-frame) - (gnus)) - (if (frame-iconified-p toolbar-news-frame) - (deiconify-frame toolbar-news-frame)) - (select-frame toolbar-news-frame) - (raise-frame toolbar-news-frame)) - -(defun toolbar-news () - "Run News (in a separate frame??)." - (interactive) - (let ((command (assq toolbar-news-reader toolbar-news-commands-alist))) - (if (not command) - (error "Unknown news reader %s" toolbar-news-reader)) - (funcall (cdr command)))) - -(defvar toolbar-last-win-icon nil "A `last-win' icon set.") -(defvar toolbar-next-win-icon nil "A `next-win' icon set.") -(defvar toolbar-file-icon nil "A `file' icon set.") -(defvar toolbar-folder-icon nil "A `folder' icon set") -(defvar toolbar-disk-icon nil "A `disk' icon set.") -(defvar toolbar-printer-icon nil "A `printer' icon set.") -(defvar toolbar-cut-icon nil "A `cut' icon set.") -(defvar toolbar-copy-icon nil "A `copy' icon set.") -(defvar toolbar-paste-icon nil "A `paste' icon set.") -(defvar toolbar-undo-icon nil "An `undo' icon set.") -(defvar toolbar-spell-icon nil "A `spell' icon set.") -(defvar toolbar-replace-icon nil "A `replace' icon set.") -(defvar toolbar-mail-icon nil "A `mail' icon set.") -(defvar toolbar-info-icon nil "An `info' icon set.") -(defvar toolbar-compile-icon nil "A `compile' icon set.") -(defvar toolbar-debug-icon nil "A `debugger' icon set.") -(defvar toolbar-news-icon nil "A `news' icon set.") - -;;; each entry maps a variable to the prefix used. - -(defvar init-x-toolbar-list - '((toolbar-last-win-icon . "last-win") - (toolbar-next-win-icon . "next-win") - (toolbar-file-icon . "file") - (toolbar-folder-icon . "folder") - (toolbar-disk-icon . "disk") - (toolbar-printer-icon . "printer") - (toolbar-cut-icon . "cut") - (toolbar-copy-icon . "copy") - (toolbar-paste-icon . "paste") - (toolbar-undo-icon . "undo") - (toolbar-spell-icon . "spell") - (toolbar-replace-icon . "replace") - (toolbar-mail-icon . "mail") - (toolbar-info-icon . "info-def") - (toolbar-compile-icon . "compile") - (toolbar-debug-icon . "debug") - (toolbar-news-icon . "news"))) - -(defun init-x-toolbar () - (toolbar-add-item-data init-x-toolbar-list ) - ;; do this now because errors will occur if the icon symbols - ;; are not initted - (set-specifier default-toolbar initial-toolbar-spec)) - -(defun toolbar-add-item-data ( icon-list &optional icon-dir ) - (if (eq icon-dir nil) - (setq icon-dir toolbar-icon-directory)) - (mapcar - (lambda (cons) - (let ((prefix (expand-file-name (cdr cons) icon-dir))) - (set (car cons) - (if (featurep 'xpm) - (toolbar-make-button-list - (concat prefix "-up.xpm") - nil - (concat prefix "-xx.xpm") - (concat prefix "-cap-up.xpm") - nil - (concat prefix "-cap-xx.xpm")) - (toolbar-make-button-list - (concat prefix "-up.xbm") - (concat prefix "-dn.xbm") - (concat prefix "-xx.xbm") - ))))) - icon-list ) - ) - -(defvar initial-toolbar-spec - '(;;[toolbar-last-win-icon pop-window-configuration - ;;(frame-property (selected-frame) - ;; 'window-config-stack) t "Most recent window config"] - ;; #### Illicit knowledge? - ;; #### These don't work right - not consistent! - ;; I don't know what's wrong; perhaps `selected-frame' is wrong - ;; sometimes when this is evaluated. Note that I even tried to - ;; kludge-fix this by calls to `set-specifier-dirty-flag' in - ;; pop-window-configuration and such. - - ;;[toolbar-next-win-icon unpop-window-configuration - ;;(frame-property (selected-frame) - ;; 'window-config-unpop-stack) t "Undo \"Most recent window config\""] - ;; #### Illicit knowledge? - - [toolbar-file-icon toolbar-open t "Open a file"] - [toolbar-folder-icon toolbar-dired t "View directory"] - [toolbar-disk-icon toolbar-save t "Save buffer"] - [toolbar-printer-icon toolbar-print t "Print buffer"] - [toolbar-cut-icon toolbar-cut t "Kill region"] - [toolbar-copy-icon toolbar-copy t "Copy region"] - [toolbar-paste-icon toolbar-paste t "Paste from clipboard"] - [toolbar-undo-icon toolbar-undo t "Undo edit"] - [toolbar-spell-icon toolbar-ispell t "Spellcheck"] - [toolbar-replace-icon toolbar-replace t "Replace text"] - [toolbar-mail-icon toolbar-mail t "Mail"] - [toolbar-info-icon toolbar-info t "Information"] - [toolbar-compile-icon toolbar-compile t "Compile"] - [toolbar-debug-icon toolbar-debug t "Debug"] - [toolbar-news-icon toolbar-news t "News"] -) - "The initial toolbar for a buffer.") - -(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-toolbar.el ends here
--- a/lisp/x11/x-win-sun.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,254 +0,0 @@ -;;; x-win-sun.el --- runtime initialization for Sun X servers and keyboards -;; Copyright (C) 1993, 1994 Free Software Foundation, Inc. - -;; Authors: jwz@netscape.com, wing@666.com, mrb@eng.sun.com -;; Keywords: terminals - -;; 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. - -;;; Commentary: - -;; This file is loaded by x-win.el at run-time when we are sure that XEmacs -;; is running on the display of a Sun. - -;; The Sun X server (both the MIT and OpenWindows varieties) have extremely -;; stupid names for their keypad and function keys. For example, the key -;; labeled 3 / PgDn, with R15 written on the front, is actually called F35. - -;; There are 3 methods of dealing with the Sun key brokenness: -;; -;; - Use xmodmap to give all keys more sensible names for all apps: -;; I use this shell script: -;; -;; for i in 0 1 2 3 4 5 6 7 8 9 Add Subtract Multiply Divide Decimal ; do -;; echo "keysym KP-$i = KP-$i" -;; done | xmodmap -;; -;; Clearly, as a good X11 citizen, we can't do this. -;; -;; - Use keyboard-translate-table to remap the keybindings at a low level. -;; This approach is taken in the function `sun-x11-keyboard-translate'. -;; This is like running xmodmap within XEmacs only. -;; This is not the default, however, so that legacy keybindings in users' -;; .emacs files like (global-set-key [(f35)] 'foo) continue to work -;; -;; - Use keyboard macros to provide indirection for keybindings. -;; If we do (global-set-key [(f35)] [(kp-3)]), then the user's keybindings -;; work whether he uses `f35' or `kp-3'. -;; This is also compatible with FSF Emacs and other X11 apps. -;; Although this has the disadvantage that these remappings -;; only work with the global key map, we use this as the default. -;; -;; - The Right Way to do this remains to be written... - -;; OK, here's another try at doing things the right way. - -;; We use function-key-map, which honors explicit key-bindings for the -;; stupid Sun names, but also allows indirection if no explicit -;; key-binding exists. - -;;; Code: - -(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 - ;; left is ok - ;; right is ok - ;; kp-add is ok - ;; down is ok - ;; insert is ok - ;; delete is ok - ;; kp-enter is ok -;; Sun Function keys -(loop for (x-name from-key to-key) in - `(("F21" f21 pause) - ("F22" f22 print) - ("F23" f23 scroll_lock) - - ;; X11 R6 mappings - ("SunProps" SunProps props) - ("SunFront" SunFront front) - ("SunOpen" SunOpen open) - ("SunFind" SunFind find) - ("Cancel" cancel stop) - ("Undo" Undo undo) - ("SunCopy" SunCopy copy) - ("SunPaste" SunPaste paste) - ("SunCut" SunCut cut) - - ("F13" f13 props) - ("F14" f14 undo) - ("F15" f15 front) - ("F16" f16 copy) - ("F17" f17 open) - ("F18" f18 paste) - ("F19" f19 find) - ("F20" f20 cut) - - ("F25" f25 kp-divide) - ("F26" f26 kp-multiply) - ("F31" f31 kp-5) - - ;; Map f33 and r13 to end or kp-end - ,@(cond - ((not (x-keysym-on-keyboard-sans-modifiers-p "End")) - '(("F33" f33 end) - ("R13" r13 end))) - ((not (x-keysym-on-keyboard-sans-modifiers-p "KP_End")) - '(("F33" f33 kp-end) - ("R13" r13 kp-end)))) - - ,@(if (x-keysym-on-keyboard-sans-modifiers-p "F36") - '(("F36" f36 stop) - ("F37" f37 again))) - - ;; Type 4 keyboards have a real kp-subtract and a f24 labelled `=' - ;; Type 5 keyboards have no key labelled `=' and a f24 labelled `-' - ,@(when (x-keysym-on-keyboard-sans-modifiers-p "F24") - `(("F24" f24 ,(if (x-keysym-on-keyboard-sans-modifiers-p "KP_Subtract") - 'kp-equal - 'kp-subtract)))) - - ;; Map f27 to home or kp-home, as appropriate - ,@(cond ((not (x-keysym-on-keyboard-sans-modifiers-p "Home")) - '(("F27" f27 home))) - ((not (x-keysym-on-keyboard-sans-modifiers-p "KP_Home")) - '(("F27" f27 kp-home)))) - - ;; Map f29 to prior or kp-prior, as appropriate - ,@(cond ((not (x-keysym-on-keyboard-sans-modifiers-p "Prior")) - '(("F29" f29 prior))) - ((not (x-keysym-on-keyboard-sans-modifiers-p "KP_Prior")) - '(("F29" f29 kp-prior)))) - - ;; Map f35 to next or kp-next, as appropriate - ,@(cond ((not (x-keysym-on-keyboard-sans-modifiers-p "Next")) - '(("F35" f35 next))) - ((not (x-keysym-on-keyboard-sans-modifiers-p "KP_Next")) - '(("F35" f35 kp-next)))) - - ,@(cond ((x-keysym-on-keyboard-sans-modifiers-p "apRead") ; SunOS 4.1.1 - '(("apRead" apRead f11) ("apEdit" apEdit f12))) - ((x-keysym-on-keyboard-sans-modifiers-p "SunF36") ; SunOS 5 - '(("SunF36" SunF36 f11) - ("SunF37" SunF37 f12) - ("F11" f11 stop) - ("F12" f12 again)))) - ) - do (when (x-keysym-on-keyboard-sans-modifiers-p x-name) - (x-remap-keysyms-using-function-key-map from-key to-key))) - -(unintern 'x-remap-keysyms-using-function-key-map) - - ;; 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 - ;; not all, modifier combinations. - ;; - ;; (Well, we omit hyper and super. #### Handle this some other way!) -; (while mapping -; (let ((mods '(() (shift) (control) (meta) (alt)))) -; (while mods -; (let ((k1 (vector (append (car mods) (list (car (car mapping)))))) -; (k2 (vector (append (car mods) (list (cdr (car mapping))))))) -; (define-key global-map k1 k2)) -; (setq mods (cdr mods)))) -; (setq mapping (cdr mapping)))) - -;;; I've extended keyboard-translate-table to work over keysyms. -;;; [FSF Emacs has something called `system-key-alist' that is -;;; supposed to accomplish approximately the same thing. Unfortunately, -;;; it's brain-dead in the typically FSF way, and associates *numbers* -;;; (who knows where the hell they come from?) with symbols.] --ben - -;;; And I've made it into a function which is NOT called by default --mrb - -(defun sun-x11-keyboard-translate () - "Remap Sun's X11 keyboard. -Keys with names like `f35' are remapped, at a low level, -to more mnemonic ones,like `kp-3'." - (interactive) - - (keyboard-translate - 'f11 'stop ; the type4 keyboard Sun/MIT name - 'f36 'stop ; the type5 keyboard Sun name - 'cancel 'stop ; R6 binding - 'f12 'again ; the type4 keyboard Sun/MIT name - 'f37 'again ; the type5 keyboard Sun name - 'f13 'props ; - 'SunProps 'props ; R6 binding - 'f14 'undo ; - 'f15 'front ; - 'SunFront 'front ; R6 binding - 'f16 'copy ; - 'SunCopy 'copy ; R6 binding - 'f17 'open ; - 'SunOpen 'open ; R6 binding - 'f18 'paste ; - 'SunPaste 'paste ; R6 binding - 'f19 'find ; - 'f20 'cut ; - 'SunCut 'cut ; R6 binding - ;; help is ok - 'f21 'pause - 'f22 'prsc - 'f23 'scroll - ;; num_lock is ok - ;;'f24 'kp-equal) ; type4 only! - 'f25 'kp-divide ; - 'f26 'kp-multiply ; - 'f24 'kp-subtract ; type5 only! - 'f27 'kp-7 ; - ;; up is ok - 'f29 'kp-9 - ;; left is ok - 'f31 'kp-5 - ;; right is ok - ;; kp-add is ok - 'f33 'kp-1 ; the Sun name - 'r13 'end ; the MIT name - ;; down is ok - 'f35 'kp-3 - ;; insert is ok - ;; delete is ok - ;; kp-enter is ok - 'SunF36 'f11 ; Type 5 keyboards - 'SunF37 'f12 ; Used to be Stop & Again - )) - - -;;; OpenWindows-like "find" processing. -;;; As far as I know, the `find' key is a Sunism, so we do that binding -;;; here. This is the only Sun-specific keybinding. (The functions -;;; themselves are in x-win.el in case someone wants to use them when -;;; not running on a Sun display.) - -(define-key global-map 'find 'ow-find) -(define-key global-map '(shift find) 'ow-find-backward) - -;;; x-win-sun.el ends here
--- a/lisp/x11/x-win-xfree86.el Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,88 +0,0 @@ -;;; x-win-xfree86.el --- runtime initialization for XFree86 servers -;; Copyright (C) 1995 Sun Microsystems, Inc. -;; Copyright (C) 1995 Ben Wing. - -;; Author: Ben Wing -;; Author: Martin Buchholz (rewritten to use function-key-map) -;; Keywords: terminals - -;; 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. - -;;; Commentary: - -;; This file is loaded by x-win.el at run-time when we are sure that XEmacs -;; is running on the display of something running XFree86 (Linux, -;; NetBSD, FreeBSD, and perhaps other Intel Unixen). - -;;; #### bleck!!! Use key-translation-map! - -;;; #### Counter-bleck!! We shouldn't override a user binding for F13. -;;; So we use function-key-map for now. -;;; When we've implemented a fallback-style equivalent of -;;; keyboard-translate-table, we'll use that instead. (mrb) - -;; For no obvious reason, shift-F1 is called F13, although Meta-F1 and -;; Control-F1 have normal names. - -(loop for (x-key key sane-key) in - '(("F13" f13 f1) - ("F14" f14 f2) - ("F15" f15 f3) - ("F16" f16 f4) - ("F17" f17 f5) - ("F18" f18 f6) - ("F19" f19 f7) - ("F20" f20 f8) - ("F21" f21 f9) - ("F22" f22 f10) - ("F23" f23 f11) - ("F24" f24 f12)) - do - (when (and (x-keysym-on-keyboard-p x-key) - (not (x-keysym-on-keyboard-sans-modifiers-p x-key))) - ;; define also the control, meta, and meta-control versions. - (loop for mods in '(() (control) (meta) (meta control)) do - (define-key function-key-map `[(,@mods ,key)] `[(shift ,@mods ,sane-key)]) - ))) - -;; (let ((mapping '((f13 . (shift f1)) -;; (f14 . (shift f2)) -;; (f15 . (shift f3)) -;; (f16 . (shift f4)) -;; (f17 . (shift f5)) -;; (f18 . (shift f6)) -;; (f19 . (shift f7)) -;; (f20 . (shift f8)) -;; (f21 . (shift f9)) -;; (f22 . (shift f10)) -;; (f23 . (shift f11)) -;; (f24 . (shift f12))))) -;; -;; ;; now define them and also the control, meta, and meta-control versions. -;; (while mapping -;; (let* ((foo (caar mapping)) -;; (bar (cdar mapping)) -;; (foo (if (listp foo) foo (list foo))) -;; (bar (if (listp bar) bar (list bar)))) -;; (let ((mods '(() (control) (meta) (meta control)))) -;; (while mods -;; (let ((k1 (vector (append (car mods) foo))) -;; (k2 (vector (append (car mods) bar)))) -;; (define-key global-map k1 k2)) -;; (setq mods (cdr mods)))) -;; (setq mapping (cdr mapping)))))
--- a/lwlib/lwlib-Xaw.c Mon Aug 13 10:03:54 2007 +0200 +++ b/lwlib/lwlib-Xaw.c Mon Aug 13 10:04:58 2007 +0200 @@ -220,7 +220,11 @@ Widget topmost = instance->parent; w = shell->core.width; h = shell->core.height; - while (topmost->core.parent && XtIsRealized (topmost->core.parent)) + while (topmost->core.parent && + XtIsRealized (topmost->core.parent) && + /* HAVE_SESSION adds an unmapped parent widget that + we should ignore here. */ + topmost->core.parent->core.mapped_when_managed) topmost = topmost->core.parent; if (topmost->core.width < w) x = topmost->core.x; else x = topmost->core.x + ((topmost->core.width - w) / 2);
--- a/lwlib/lwlib-Xm.c Mon Aug 13 10:03:54 2007 +0200 +++ b/lwlib/lwlib-Xm.c Mon Aug 13 10:04:58 2007 +0200 @@ -555,6 +555,7 @@ widget_value* val, Boolean deep_p) { Arg al [2]; + int ac; Widget menu; widget_value* contents;
--- a/man/ChangeLog Mon Aug 13 10:03:54 2007 +0200 +++ b/man/ChangeLog Mon Aug 13 10:04:58 2007 +0200 @@ -1,3 +1,17 @@ +1997-11-03 MORIOKA Tomohiko <morioka@jaist.ac.jp> + + * xemacs/mule.texi (Mule): Modify description about supported + scripts. + +1997-11-02 MORIOKA Tomohiko <morioka@jaist.ac.jp> + + * xemacs/mule.texi: Add description for + `universal-coding-system-argument'. + +1997-10-31 SL Baur <steve@altair.xemacs.org> + + * internals/internals.texi: XEmacs 19.16 is released. + 1997-10-30 SL Baur <steve@altair.xemacs.org> * Makefile (srcs): Mailcrypt, hm--html-menus, vm, psgml and tm have
--- a/man/Makefile Mon Aug 13 10:03:54 2007 +0200 +++ b/man/Makefile Mon Aug 13 10:04:58 2007 +0200 @@ -42,9 +42,9 @@ ../info/%.info : %.texi -$(MAKEINFO) -o $@ $< -srcs = cc-mode cl custom external-widget forms \ - hyperbole ilisp info ispell oo-browser \ - pcl-cvs ph standards supercite term \ +srcs = cl custom external-widget forms \ + info ispell oo-browser \ + standards supercite term \ termcap texinfo vhdl-mode widget xemacs-faq info = $(srcs:%=../info/%.info)
--- a/man/cc-mode.texi Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,3413 +0,0 @@ -\input texinfo - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@comment %**start of header (This is for running Texinfo on a region) -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -@setfilename cc-mode.info -@settitle CC MODE Version 5 Documentation -@footnotestyle end - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@comment @setchapternewpage odd !! we don't want blank pages !! -@comment %**end of header (This is for running Texinfo on a region) -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@comment -@comment Texinfo manual for CC Mode -@comment Generated from the original README file by Krishna Padmasola -@comment <krishna@earth-gw.njit.edu> -@comment -@comment Maintained by Barry A. Warsaw <cc-mode-help@python.org> -@comment -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@comment The following line inserts the copyright notice -@comment into the Info file. -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -@ifinfo -Copyright @copyright{} 1995, 1996 Free Software Foundation, Inc. -@end ifinfo - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@comment !!!The titlepage section does not appear in the Info file.!!! -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -@titlepage -@sp 10 - - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@comment The title is printed in a large font. -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -@center @titlefont{CC Mode 5.19} -@sp 2 -@center @subtitlefont{A GNU Emacs mode for editing C and C-like languages} -@sp 2 -@center Barry A. Warsaw - - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@comment The following two commands start the copyright page -@comment for the printed manual. This will not appear in the Info file. -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -@page -@vskip 0pt plus 1filll -Copyright @copyright{} 1995 Free Software Foundation, Inc. -@end titlepage - - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@comment The Top node contains the master menu for the Info file. -@comment This appears only in the Info file, not the printed manual. -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -@node Top, Introduction, (dir), (dir) -@comment node-name, next, previous, up - - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -@menu -* Introduction:: -* Getting Connected:: -* New Indentation Engine:: -* Minor Modes:: -* Commands:: -* Customizing Indentation:: -* Syntactic Symbols:: -* Performance Issues:: -* Frequently Asked Questions:: -* Getting the latest CC Mode release:: -* Sample .emacs File:: -* Limitations and Known Bugs:: -* Mailing Lists and Submitting Bug Reports:: -* Concept Index:: -* Command Index:: Command Index -* Key Index:: Key Index -* Variable Index:: Variable Index -@end menu - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -@node Introduction, Getting Connected, Top, Top -@comment node-name, next, previous, up -@chapter Introduction -@cindex Introduction - -@macro ccmode -CC Mode -@end macro - -@cindex BOCM - -Welcome to @ccmode{}. This is a GNU Emacs mode for editing files -containing C, C++, Objective-C, Java, and IDL code. This incarnation of -the mode is descendant from @file{c-mode.el} (also called "Boring Old C -Mode" or BOCM @code{:-)}, and @file{c++-mode.el} version 2, which I have -been maintaining since 1992. @ccmode{} represents a significant -milestone in the mode's life. It has been fully merged back with Emacs -19's @file{c-mode.el}. Also a new, more intuitive and flexible mechanism -for controlling indentation has been developed. - -@ccmode{} supports the editing of K&R and ANSI C, @dfn{ARM} -@footnote{``The Annotated C++ Reference Manual'', by Ellis and -Stroustrup.} C++, Objective-C, Java and IDL@footnote{CORBA's Interface -Definition Language} files. In this way, you can -easily set up consistent coding styles for use in editing all C, C++, -Objective-C, Java and IDL programs. @ccmode{} does @emph{not} handle -font-locking (a.k.a. syntax coloring, keyword highlighting) or anything -of that nature, for any of these modes. Font-locking is handled by other -Emacs packages. - -This manual will describe the following: - -@itemize @bullet -@item -How to get started using @ccmode{}. - -@item -How the new indentation engine works. - -@item -How to customize the new indentation engine. - -@end itemize - -@findex c-mode -@findex c++-mode -@findex objc-mode -@findex java-mode -@findex idl-mode -Note that the name of this package is ``@ccmode{}'', but there is no top -level @code{cc-mode} entry point. All of the variables, commands, and -functions in @ccmode{} are prefixed with @code{c-@var{<thing>}}, and -@code{c-mode}, @code{c++-mode}, @code{objc-mode}, @code{java-mode}, and -@code{idl-mode} entry points are provided. This file is intended to be -a replacement for @file{c-mode.el} and @file{c++-mode.el}. - -@cindex @file{cc-compat.el} file -This distribution also contains a file -called @file{cc-compat.el} which should ease your transition from BOCM -to @ccmode{}. If you have a BOCM configuration you are really happy -with, and want to postpone learning how to configure @ccmode{}, take a -look at that file. It maps BOCM configuration variables to @ccmode{}'s -new indentation model. It is not actively supported so for the long -run, you should learn how to customize @ccmode{} to support your coding -style. - -A special word of thanks goes to Krishna Padmasola for his work in -converting the original @file{README} file to Texinfo format. I'd also -like to thank all the @ccmode{} victims who help enormously during the -early beta stages of @ccmode{}'s development. - - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -@node Getting Connected, New Indentation Engine, Introduction, Top -@comment node-name, next, previous, up -@chapter Getting Connected -@cindex Getting Connected - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -If you got this version of @ccmode{} with Emacs or XEmacs, it should -work just fine right out of the box. Note however that you may not have -the latest @ccmode{} release and may want to upgrade your copy. - -If you are upgrading an existing @ccmode{} installation, please see the -@file{README} file for installation details. @ccmode{} may not work -with older versions of Emacs or XEmacs. See the @ccmode{} release notes -Web pages for the latest information on Emacs version and package -compatibility, etc. The Web page locations are outlined in @ref{Getting -the latest CC Mode release}. - -@cindex @file{cc-mode-18.el} file -@emph{Note that @ccmode{} no longer works with Emacs 18!} The -@file{cc-mode-18.el} file is no longer distributed with @ccmode{}. If -you haven't upgraded from Emacs 18 by now, you are out of luck. - -@findex c-version -@findex version (c-) -You can find out what version of @ccmode{} you are using by visiting a C -file and entering @kbd{M-x c-version RET}. You should see this message in -the echo area: -@example - -Using CC Mode version 5.XX - -@end example - -@noindent -where @samp{XX} is the minor release number. - - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@node New Indentation Engine, Minor Modes, Getting Connected, Top -@comment node-name, next, previous, up - -@chapter New Indentation Engine -@cindex New Indentation Engine -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -@ccmode{} has a new indentation engine, providing a simplified, yet -flexible and general mechanism for customizing indentation. It separates -indentation calculation into two steps: first, @ccmode{} analyzes the -line of code being indented to determine the kind of language construct -it's looking at, then it applies user defined offsets to the current -line based on this analysis. - -This section will briefly cover how indentation is calculated in -@ccmode{}. It is important to understand the indentation model -being used so that you will know how to customize @ccmode{} for -your personal coding style. - -@menu -* Syntactic Analysis:: -* Indentation Calculation:: -@end menu - - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@node Syntactic Analysis, Indentation Calculation, , New Indentation Engine -@comment node-name, next, previous,up -@section Syntactic Analysis -@cindex Syntactic Analysis -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -@vindex c-offsets-alist -@vindex offsets-alist (c-) -@cindex relative buffer position -@cindex syntactic symbol -@cindex syntactic component -@cindex syntactic component list -@cindex relative buffer position -The first thing @ccmode{} does when indenting a line of code, is to -analyze the line, determining the @dfn{syntactic component list} of the -construct on that line. A syntactic component consists of a pair -of information (in lisp parlance, a @emph{cons cell}), where the first -part is a @dfn{syntactic symbol}, and the second part is a @dfn{relative -buffer position}. Syntactic symbols describe elements of C code -@footnote{or C++, Objective-C, Java or IDL code. In general, for the rest -of this manual I'll use the term ``C code'' to refer to all the C-like -dialects, unless otherwise noted.}, e.g. @code{statement}, -@code{substatement}, @code{class-open}, @code{class-close}, etc. -@xref{Syntactic Symbols}, for a complete list of currently recognized -syntactic symbols and their semantics. The variable -@code{c-offsets-alist} also contains the list of currently supported -syntactic symbols. - -Conceptually, a line of C code is always indented relative to the -indentation of some line higher up in the buffer. This is represented -by the relative buffer position in the syntactic component. - -Here is an example. Suppose we had the following code as the only thing -in a @code{c++-mode} buffer @footnote{The line numbers in this and -future examples don't actually appear in the buffer, of course!}: -@example -@group - - 1: void swap( int& a, int& b ) - 2: @{ - 3: int tmp = a; - 4: a = b; - 5: b = tmp; - 6: @} - -@end group -@end example - -@kindex C-c C-s -@findex c-show-syntactic-information -@findex show-syntactic-information (c-) -We can use the command @kbd{C-c C-s} -(@code{c-show-syntactic-information}) to simply report what the -syntactic analysis is for the current line. Running this command on -line 4 of this example, we'd see in the echo area@footnote{With a universal -argument (i.e. @kbd{C-u C-c C-s}) the analysis is inserted into the -buffer as a comment -on the current line.}: -@example - -((statement . 35)) - -@end example - -This tells us that the line is a statement and it is indented relative -to buffer position 35, which happens to be the @samp{i} in @code{int} on -line 3. If you were to move point to line 3 and hit @kbd{C-c C-s}, you -would see: -@example - -((defun-block-intro . 29)) - -@end example - -This indicates that the @samp{int} line is the first statement in a top -level function block, and is indented relative to buffer position 29, -which is the brace just after the function header. - -Here's another example: -@example -@group - - 1: int add( int val, int incr, int doit ) - 2: @{ - 3: if( doit ) - 4: @{ - 5: return( val + incr ); - 6: @} - 7: return( val ); - 8: @} - -@end group -@end example - -@noindent -Hitting @kbd{C-c C-s} on line 4 gives us: -@example - -((substatement-open . 46)) - -@end example - -@cindex substatement -@cindex substatment block -@noindent -which tells us that this is a brace that @emph{opens} a substatement -block. @footnote{A @dfn{substatement} indicates the line after a -conditional statement, such as @code{if}, @code{else}, @code{while}, -@code{do}, @code{switch}, or @code{for} in C. A @dfn{substatement -block} is a brace block following one of those conditionals.} - -@cindex comment only line -Syntactic component lists can contain more than one component, and -individual syntactic components need not have relative buffer positions. -The most common example of this is a line that contains a @dfn{comment -only line}. -@example -@group - - 1: void draw_list( List<Drawables>& drawables ) - 2: @{ - 3: // call the virtual draw() method on each element in list - 4: for( int i=0; i < drawables.count(), ++i ) - 5: @{ - 6: drawables[i].draw(); - 7: @} - 8: @} - -@end group -@end example - -@noindent -Hitting @kbd{C-c C-s} on line 3 of this example gives: -@example - -((comment-intro) (defun-block-intro . 46)) - -@end example - -@noindent -and you can see that the syntactic component list contains two syntactic -components. Also notice that the first component, -@samp{(comment-intro)} has no relative buffer position. - - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@node Indentation Calculation, , Syntactic Analysis, New Indentation Engine -@comment node-name, next, previous,up -@section Indentation Calculation -@cindex Indentation Calculation -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -@vindex c-offsets-alist -@vindex offsets-alist (c-) -Indentation for the current line is calculated using the syntactic -component list derived in step 1 above (see @ref{Syntactic Analysis}). -Each component contributes to the final total indentation of the line in -two ways. - -First, the syntactic symbols are looked up in the @code{c-offsets-alist} -variable, which is an association list of syntactic symbols and the -offsets to apply for those symbols. These offsets are added to a -running total. - -Second, if the component has a relative buffer position, @ccmode{} -adds the column number of that position to the running total. By adding -up the offsets and columns for every syntactic component on the list, -the final total indentation for the current line is computed. - -Let's use our two code examples above to see how this works. Here is -our first example again: -@example -@group - - 1: void swap( int& a, int& b ) - 2: @{ - 3: int tmp = a; - 4: a = b; - 5: b = tmp; - 6: @} - -@end group -@end example - -@kindex TAB -Let's say point is on line 3 and we hit the @key{TAB} key to re-indent -the line. Remember that the syntactic component list for that -line is: -@example - -((defun-block-intro . 29)) - -@end example - -@noindent -@ccmode{} looks up @code{defun-block-intro} in the -@code{c-offsets-alist} variable. Let's say it finds the value @samp{4}; -it adds this to the running total (initialized to zero), yielding a -running total indentation of 4 spaces. - -Next @ccmode{} goes to buffer position 29 and asks for the current -column. This brace is in column zero, so @ccmode{} -adds @samp{0} to the running total. Since there is only one syntactic -component on the list for this line, indentation calculation is -complete, and the total indentation for the line -is 4 spaces. - -Here's another example: -@example -@group - - 1: int add( int val, int incr, int doit ) - 2: @{ - 3: if( doit ) - 4: @{ - 5: return( val + incr ); - 6: @} - 7: return( val ); - 8: @} - -@end group -@end example - -If we were to hit @kbd{TAB} on line 4 in the above example, the same -basic process is performed, despite the differences in the syntactic -component list. Remember that the list for this line is: -@example - -((substatement-open . 46)) - -@end example - -Here, @ccmode{} first looks up the @code{substatement-open} symbol -in @code{c-offsets-alist}. Let's say it finds the value @samp{4}. This -yields a running total of 4. @ccmode{} then goes to -buffer position 46, which is the @samp{i} in @code{if} on line 3. This -character is in the fourth column on that line so adding this to the -running total yields an indentation for the line of 8 spaces. - -Simple, huh? - -Actually, the mode usually just does The Right Thing without you having -to think about it in this much detail. But when customizing -indentation, it's helpful to understand the general indentation model -being used. - -@vindex c-echo-syntactic-information-p -@vindex echo-syntactic-information-p (c-) -@cindex TAB -As you configure @ccmode{}, you might want to set the variable -@code{c-echo-syntactic-information-p} to non-@code{nil} so that the -syntactic component list and calculated offset will always be echoed in -the minibuffer when you hit @kbd{TAB}. - - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@node Minor Modes, Commands, New Indentation Engine, Top -@comment node-name, next, previous,up - -@chapter Minor Modes -@cindex Minor Modes -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -@ccmode{} contains two minor-mode-like features that you should -find useful while you enter new C code. The first is called -@dfn{auto-newline} mode, and the second is called @dfn{hungry-delete} -mode. These minor modes can be toggled on and off independently, and -@ccmode{} can be configured so that it starts up with any -combination of these minor modes. By default, both of these minor modes -are turned off. - -The state of the minor modes is always reflected in the minor mode list -on the modeline of the @ccmode{} buffer. When auto-newline mode is -enabled, you will see @samp{C/a} on the mode line @footnote{Remember -that the @samp{C} could be replaced with @samp{C++}, @samp{ObjC}, -@samp{Java} or @samp{IDL}.}. When hungry delete mode is enabled you -would see @samp{C/h} and when both modes are enabled, you'd see -@samp{C/ah}. - -@kindex C-c C-a -@kindex C-c C-d -@kindex C-c C-t -@findex c-toggle-hungry-state -@findex c-toggle-auto-state -@findex c-toggle-auto-hungry-state -@findex toggle-hungry-state (c-) -@findex toggle-auto-state (c-) -@findex toggle-auto-hungry-state (c-) -@ccmode{} provides keybindings which allow you to toggle the minor -modes on the fly while editing code. To toggle just the auto-newline -state, hit @kbd{C-c C-a} (@code{c-toggle-auto-state}). When you do -this, you should see the @samp{a} indicator either appear or disappear -on the modeline. Similarly, to toggle just the hungry-delete state, use -@kbd{C-c C-d} (@code{c-toggle-hungry-state}), and to toggle both states, -use @kbd{C-c C-t} (@code{c-toggle-auto-hungry-state}). - -To set up the auto-newline and hungry-delete states to your preferred -values, you would need to add some lisp to your @file{.emacs} file that -called one of the @code{c-toggle-*-state} functions directly. When -called programmatically, each function takes a numeric value, where -a positive number enables the minor mode, a negative number disables the -mode, and zero toggles the current state of the mode. - -So for example, if you wanted to enable both auto-newline and -hungry-delete for all your C file editing, you could add the following -to your @file{.emacs} file: -@example - -(add-hook 'c-mode-common-hook - '(lambda () (c-toggle-auto-hungry-state 1))) - -@end example - - -@cindex electric characters - -@menu -* Auto-newline insertion:: -* Hungry-deletion of whitespace:: -* Auto-fill mode interaction:: -@end menu - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@node Auto-newline insertion, Hungry-deletion of whitespace, , Minor Modes -@comment node-name, next, previous,up - -@section Auto-newline insertion -@cindex Auto-newline insertion -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -@cindex electric commands -Auto-newline minor mode works by enabling certain @dfn{electric -commands}. Electric commands are typically bound to special characters -such as the left and right braces, colons, semi-colons, etc., which when -typed, perform some magic formatting in addition to inserting the typed -character. As a general rule, electric commands are only electric when -the following conditions apply: - -@itemize @bullet -@item -Auto-newline minor mode is enabled, as evidenced by a @samp{C/a} or -@samp{C/ah} indicator on the modeline. - -@cindex literal -@cindex syntactic whitespace -@item -The character was not typed inside of a literal @footnote{A -@dfn{literal} is defined as any comment, string, or cpp macro -definition. These constructs are also known as @dfn{syntactic -whitespace} since they are usually ignored when scanning C code.}. - -@item -@kindex C-u -No numeric argument was supplied to the command (i.e. it was typed as -normal, with no @kbd{C-u} prefix). - -@end itemize - -@menu -* Hanging Braces:: -* Hanging Colons:: -* Hanging Semi-colons and commas:: -* Other electric commands:: -* Clean-ups:: -@end menu - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@node Hanging Braces, Hanging Colons, , Auto-newline insertion -@comment node-name, next, previous,up - -@subsection Hanging Braces -@cindex Hanging Braces -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -@findex c-electric-brace -@findex electric-brace (c-) -@vindex c-hanging-braces-alist -@vindex hanging-braces-alist (c-) -@vindex c-offsets-alist -@vindex offsets-alist (c-) -When you type either an open or close brace (i.e. @kbd{@{} or @kbd{@}}), -the electric command @code{c-electric-brace} gets run. This command has -two electric formatting behaviors. First, it will perform some -re-indentation of the line the brace was typed on, and second, it will -add various newlines before and/or after the typed brace. -Re-indentation occurs automatically whenever the electric behavior is -enabled. If the brace ends up on a line other than the one it was typed -on, then that line is also indented according to -@code{c-offsets-alist}. - -@cindex class-open syntactic symbol -@cindex class-close syntactic symbol -@cindex defun-open syntactic symbol -@cindex defun-close syntactic symbol -@cindex inline-open syntactic symbol -@cindex inline-close syntactic symbol -@cindex brace-list-open syntactic symbol -@cindex brace-list-close syntactic symbol -@cindex brace-list-intro syntactic symbol -@cindex brace-list-entry syntactic symbol -@cindex block-open syntactic symbol -@cindex block-close syntactic symbol -@cindex substatement-open syntactic symbol -@cindex statement-case-open syntactic symbol -@cindex extern-lang-open syntactic symbol -@cindex extern-lang-close syntactic symbol - -The insertion of newlines is controlled by the -@code{c-hanging-braces-alist} variable. This variable contains a -mapping between syntactic symbols related to braces, and a list of -places to insert a newline. The syntactic symbols that are useful for -this list are: @code{class-open}, @code{class-close}, @code{defun-open}, -@code{defun-close}, @code{inline-open}, @code{inline-close}, -@code{brace-list-open}, @code{brace-list-close}, -@code{brace-list-intro}, @code{brace-list-entry}, @code{block-open}, -@code{block-close}, @code{substatement-open}, -@code{statement-case-open}, -@code{extern-lang-open}, and @code{extern-lang-close}. -@xref{Syntactic Symbols} for a more -detailed description of these syntactic symbols. - -@cindex custom indentation function -The value associated with each syntactic symbol in this association list -is called an @var{ACTION} which can be either a function or a list. -@xref{Custom Brace and Colon Hanging} for a more detailed discussion of -using a function as a brace hanging @var{ACTION}. - -When the @var{ACTION} is a list, it can contain any combination of the -symbols @code{before} and @code{after}, directing @ccmode{} where to -put newlines in relationship to the brace being inserted. Thus, if the -list contains only the symbol @code{after}, then the brace is said to -@dfn{hang} on the right side of the line, as in: -@example -@group - -// here, open braces always `hang' -void spam( int i ) @{ - if( i == 7 ) @{ - dosomething(i); - @} -@} - - -@end group -@end example - -When the list contains both @code{after} and @code{before}, the braces -will appear on a line by themselves, as shown by the close braces in the -above example. The list can also be empty, in which case no newlines -are added either before or after the brace. - -For example, the default value of @code{c-hanging-braces-alist} is: -@example -@group - -(defvar c-hanging-braces-alist '((brace-list-open) - (substatement-open after) - (block-close . c-snug-do-while) - (extern-lang-open after))) - -@end group -@end example - -@noindent -which says that @code{brace-list-open} braces should both hang on the -right side, and allow subsequent text to follow on the same line as the -brace. Also, @code{substatement-open} and @code{extern-lang-open} -braces should hang on the right side, but subsequent text should follow -on the next line. Here, in the @code{block-close} entry, you also see -an example of using a function as an @var{ACTION}. - -A word of caution: it is not a good idea to hang top-level construct -introducing braces, such as @code{class-open} or @code{defun-open}. -Emacs makes an assumption that such braces will always appear in column -zero, hanging such braces can introduce performance problems. -@xref{Performance Issues} for more information. - - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@node Hanging Colons, Hanging Semi-colons and commas, Hanging Braces, Auto-newline insertion -@comment node-name, next, previous,up - -@subsection Hanging Colons -@cindex Hanging Colons -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -@vindex hanging-colons-alist (c-) -@vindex c-hanging-colons-alist -Using a mechanism similar to brace hanging (see @ref{Hanging Braces}), -colons can also be made to hang using the variable -@code{c-hanging-colons-alist}. The syntactic symbols appropriate for -this assocation list are: @code{case-label}, @code{label}, -@code{access-label}, @code{member-init-intro}, and @code{inher-intro}. -Note however that for @code{c-hanging-colons-alist}, @var{ACTION}s as -functions are not supported. See also @ref{Custom Brace and Colon -Hanging} for details. - -@cindex clean-ups -In C++, double-colons are used as a scope operator but because these -colons always appear right next to each other, newlines before and after -them are controlled by a different mechanism, called @dfn{clean-ups} in -@ccmode{}. @xref{Clean-ups} for details. - - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@node Hanging Semi-colons and commas, Other electric commands, Hanging Colons, Auto-newline insertion -@comment node-name, next, previous,up - -@subsection Hanging Semi-colons and commas -@cindex Hanging Semi-colons and commas -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -Semicolons and commas are also electric in @ccmode{}, but since -these characters do not correspond directly to syntactic symbols, a -different mechanism is used to determine whether newlines should be -automatically inserted after these characters. @xref{Customizing -Semi-colons and Commas} for details. - - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@node Other electric commands, Clean-ups, Hanging Semi-colons and commas, Auto-newline insertion -@comment node-name, next, previous,up - -@subsection Other electric commands -@cindex Other electric commands -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -@kindex # -@findex c-electric-pound -@vindex c-electric-pound-behavior -@findex electric-pound (c-) -@vindex electric-pound-behavior (c-) -@vindex c-offsets-alist -@vindex offsets-alist (c-) -A few other keys also provide electric behavior. For example -@kbd{#} (@code{c-electric-pound}) is electric when typed as -the first non-whitespace character on a line. In this case, the -variable @code{c-electric-pound-behavior} is consulted for the electric -behavior. This variable takes a list value, although the only element -currently defined is @code{alignleft}, which tells this command to force -the @samp{#} character into column zero. This is useful for entering -cpp macro definitions. - -@findex c-electric-star -@findex c-electric-slash -@findex electric-star (c-) -@findex electric-slash (c-) -@cindex comment-only line -Stars and slashes (i.e. @kbd{*} and @kbd{/}, @code{c-electric-star} and -@code{c-electric-slash} respectively) are also electric under -certain circumstances. If a star is inserted as the second character of -a C style block comment on a @dfn{comment-only} line, then the comment -delimiter is indented as defined by @code{c-offsets-alist}. A -comment-only line is defined as a line which contains only a comment, as -in: -@example -@group - -void spam( int i ) -@{ - // this is a comment-only line... - if( i == 7 ) // but this is not - @{ - dosomething(i); - @} -@} - -@end group -@end example - -Likewise, if a slash is inserted as the second slash in a C++ style line -comment (also only on a comment-only line), then the line is indented as -defined by @code{c-offsets-alist}. - -@findex c-electric-lt-gt -@findex electric-lt-gt (c-) -@kindex < -@kindex > -Less-than and greater-than signs (@code{c-electric-lt-gt}) are also -electric, but only in C++ mode. Hitting the second of two @kbd{<} or -@kbd{>} keys re-indents the line if it is a C++ style stream operator. - - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@node Clean-ups, , Other electric commands, Auto-newline insertion -@comment node-name, next, previous,up - -@subsection Clean-ups -@cindex Clean-ups -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -@dfn{Clean-ups} are a mechanism complementary to colon and brace -hanging. On the surface, it would seem that clean-ups overlap the -functionality provided by the @code{c-hanging-*-alist} variables, and -similarly, clean-ups are only enabled when auto-newline minor mode is -enabled. Clean-ups are used however to adjust code ``after-the-fact'', -i.e. to eliminate some whitespace that is inserted by electric -commands, or whitespace that contains intervening constructs. - -@cindex literal -You can configure @ccmode{}'s clean-ups by setting the variable -@code{c-cleanup-list}, which is a list of clean-up symbols. By default, -@ccmode{} cleans up only the @code{scope-operator} construct, which -is necessary for proper C++ support. Note that clean-ups are only -performed when the construct does not occur within a literal (see -@ref{Auto-newline insertion}), and when there is nothing but whitespace -appearing between the individual components of the construct. - -@vindex c-cleanup-list -@vindex cleanup-list (c-) -There are currently only five specific constructs that @ccmode{} -can clean up, as indicated by these symbols: - -@itemize @bullet -@item -@code{brace-else-brace} --- cleans up @samp{@} else @{} constructs by -placing the entire construct on a single line. Clean-up occurs when the -open brace after the @samp{else} is typed. So for example, this: -@example -@group - -void spam(int i) -@{ - if( i==7 ) - @{ - dosomething(); - @} - else - @{ - -@end group -@end example -@noindent -appears like this after the open brace is typed: -@example -@group - -void spam(int i) -@{ - if( i==7 ) @{ - dosomething(); - @} else @{ - -@end group -@end example - -@item -@code{brace-elseif-brace} --- similar to the @code{brace-else-brace} -clean-up, but cleans up @samp{@} else if (...)@{} constructs. For -example: -@example -@group - -void spam(int i) -@{ - if( i==7 ) - @{ - dosomething(); - @} - else if( i==3 ) @{ - -@end group -@end example -@noindent -appears like this after the open brace is typed: -@example -@group - -void spam(int i) -@{ - if( i==7 ) @{ - dosomething(); - @} else if( i==3 ) @{ - -@end group -@end example - -@item -@code{empty-defun-braces} --- cleans up braces following a top-level -function or class definition that contains no body. Clean up occurs -when the closing brace is typed. Thus the following: -@example -@group - -class Spam -@{ -@} - -@end group -@end example -@noindent -is transformed into this when the close brace is typed: -@example -@group - -class Spam -@{@} - -@end group -@end example - -@item -@code{defun-close-semi} --- cleans up the terminating semi-colon on -top-level function or class definitions when they follow a close -brace. Clean up occurs when the semi-colon is typed. -So for example, the following: -@example -@group - -class Spam -@{ -@} -; - -@end group -@end example -@noindent -is transformed into this when the semi-colon is typed: - -@example -@group - -class Spam -@{ -@}; - -@end group -@end example - -@item -@code{list-close-comma} --- cleans up commas following braces in array -and aggregate initializers. Clean up occurs when the comma is typed. - -@item -@code{scope-operator} --- cleans up double colons which may designate a -C++ scope operator split across multiple lines@footnote{Certain C++ -constructs introduce ambiguous situations, so @code{scope-operator} -clean-ups may not always be correct. This usually only occurs when -scoped identifiers appear in switch label tags.}. Clean up occurs when -the second colon is typed. You will always want @code{scope-operator} -in the @code{c-cleanup-list} when you are editing C++ code. - -@end itemize - - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@node Hungry-deletion of whitespace, Auto-fill mode interaction, Auto-newline insertion, Minor Modes -@comment node-name, next, previous,up - -@section Hungry-deletion of whitespace -@cindex Hungry-deletion of whitespace -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -Hungry deletion of whitespace, or as it more commonly called, -@dfn{hungry-delete mode}, is a simple feature that some people find -extremely useful. In fact, you might find yourself wanting -hungry-delete in @strong{all} your editing modes! - -@kindex DEL -@kindex Backspace -In a nutshell, when hungry-delete mode is enabled, hitting the -@kbd{Backspace} key@footnote{I say ``hit the @kbd{Backspace} key'' but -what I really mean is ``when Emacs receives the @code{BackSpace} keysym -event''. The difference usually isn't significant to most users, but -advanced users will realize that under window systems such as X, any -physical key (keycap) on the keyboard can be configured to generate any -keysym. Also, the use of Emacs on TTYs will affect which keycap -generates which keysym. From a pedantic point of view, here we are only -concerned with the keysym event that Emacs receives.} will consume all -preceding whitespace, including newlines and tabs. This can really cut -down on the number of @kbd{Backspace}'s you have to type if, for example -you made a mistake on the preceding line. - -@findex c-electric-backspace -@findex electric-backspace (c-) -@vindex c-backspace-function -@vindex backspace-function (c-) - -@findex c-electric-delete -@findex electric-delete (c-) -@vindex c-delete-function -@vindex delete-function (c-) -@cindex literal - -@findex backward-delete-char-untabify - -By default, when you hit the @kbd{Backspace} key -@ccmode{} runs the command @code{c-electric-backspace}, which deletes -text in the backwards direction. When deleting a single character, or -when @kbd{Backspace} is hit in a literal -(see @ref{Auto-newline insertion}), -or when hungry-delete mode is disabled, the function -contained in the @code{c-backspace-function} variable is called with one -argument (the number of characters to delete). This variable is set to -@code{backward-delete-char-untabify} by default. - -@vindex delete-key-deletes-forward -@findex delete-char - -Similarly, hitting the @kbd{DEL} key runs the command -@code{c-electric-delete}. Some versions of Emacs@footnote{As of this -writing, 20-Jun-1997, only XEmacs 20.3 supports this.} support separation -of the @kbd{Backspace} and @kbd{DEL} keys, so that @kbd{DEL} will delete -in the forward direction when @code{delete-key-deletes-forward} is -non-@code{nil}. If your Emacs supports this, and -@code{delete-key-deletes-forward} is non-@code{nil}, and hungry-delete -mode is enabled, then @kbd{DEL} will consume all whitespace following -point. When deleting a single character, or when @kbd{DEL} is hit in a -literal, or when hungry-delete mode is disabled, the function contained -in the @code{c-delete-function} variable is called with one argument -(the number of characters to delete). This variable is set to -@code{delete-char} by default. - -However, if @code{delete-key-deletes-forward} is @code{nil}, or your -Emacs does not support separation of @kbd{Backspace} and @kbd{DEL}, then -@code{c-electric-delete} simply calls @code{c-electric-backspace}. - - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@node Auto-fill mode interaction, , Hungry-deletion of whitespace, Minor Modes -@comment node-name, next, previous,up - -@section Auto-fill mode interaction -@cindex Auto-fill mode interaction -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -One other note about minor modes is worth mentioning here. CC Mode now -works much better with auto-fill mode (a standard Emacs minor mode) by -correctly auto-filling both line (e.g. C++ style) and block (e.g. C -style) oriented comments. When @code{auto-fill-mode} is enabled, line -oriented comments will also be auto-filled by inserting a newline at the -line break, and inserting @samp{//} at the start of the next line. - -@vindex c-comment-continuation-stars -@vindex comment-continuation-stars (c-) -@vindex comment-line-break-function -When auto-filling block oriented comments, the behavior is dependent on -the value of the variable @code{c-comment-continuation-stars}. When -this variable is @code{nil}, the old behavior for auto-filling C -comments is in effect. In this case, the line is broken by closing the -comment and starting a new comment on the next line. - -If you set @code{c-comment-continuation-stars} to a string, then a long -C block comment line is broken by inserting a newline at the line break -position, and inserting this string at the beginning of the next comment -line. The default value for @code{c-comment-continuation-stars} is -@samp{* } (a star followed by a single space)@footnote{To get block -comment continuation lines indented under the block comment starter -(e.g. the @samp{/*}), it is not enough to set -@code{c-comment-continuation-stars} to the empty string. You need to do -this, but you also need to set the offset for the @code{c} syntactic -symbol to be zero.}. - - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@node Commands, Customizing Indentation, Minor Modes, Top -@comment node-name, next, previous,up - -@chapter Commands -@cindex Commands -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -@menu -* Indentation Commands:: -* Other Commands:: -@end menu - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@node Indentation Commands, Other Commands, , Commands -@comment node-name, next, previous,up - -@section Indentation Commands -@cindex Indentation Commands -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -Various commands are provided which allow you to conveniently re-indent -C constructs. There are several things to -note about these indentation commands. First, when you -change your programming style, either interactively or through some -other means, your file does @emph{not} automatically get re-indented. -When you change style parameters, you will typically need to reformat -the line, expression, or buffer to see the effects of your changes. - -@cindex c-hanging- functions -@findex c-hanging-braces-alist -@findex hanging-braces-alist (c-) -Second, changing some variables have no effect on existing code, even -when you do re-indent. For example, the @code{c-hanging-*} variables -and @code{c-cleanup-list} only affect new code as it is typed in -on-the-fly, so changing @code{c-hanging-braces-alist} and re-indenting -the buffer will not adjust placement of braces already in the file. - -@vindex c-progress-interval -@vindex progress-interval (c-) -Third, re-indenting large portions of code is currently rather -inefficient. Improvements have been made since previous releases of -@ccmode{}, and much more radical improvements are planned, but for now -you need to be aware of this @footnote{In particular, I have had people -complain about the speed with which @code{lex(1)} output is re-indented. -Lex, yacc, and other code generators usually output some pretty -perversely formatted code. @emph{Don't} try to indent this stuff!}. -Some provision has been made to at least inform you as to the progress -of the re-indentation. The variable @code{c-progress-interval} controls -how often a progress message is displayed. Set this variable to -@code{nil} to inhibit progress messages, including messages normally -printed when indentation is started and completed. - -Also, except as noted below, re-indentation is always driven by the -same mechanisms that control on-the-fly indentation of code. @xref{New -Indentation Engine} for details. - -@findex c-indent-command -@findex indent-command (c-) -@vindex c-tab-always-indent -@vindex tab-always-indent (c-) -@kindex TAB -@cindex literal -@vindex indent-tabs-mode -@vindex c-insert-tab-function -@vindex insert-tab-function (c-) -@findex tab-to-tab-stop -To indent a single line of code, use @kbd{TAB} -(@code{c-indent-command}). The behavior of this command is controlled -by the variable @code{c-tab-always-indent}. When this variable is -@code{t}, @kbd{TAB} always just indents the current line. When -@code{nil}, the line is indented only if point is at the left margin, or -on or before the first non-whitespace character on the line, otherwise -@emph{something else happens}@footnote{Actually what happens is that the -function stored in @code{c-insert-tab-function} is called. -Normally this just inserts a real tab character, or the equivalent -number of spaces, depending on the setting of the variable -@code{indent-tabs-mode}. If you preferred, you could set -@code{c-insert-tab-function} to @code{tab-to-tab-stop} for example.}. -If the value of @code{c-tab-always-indent} is something other than -@code{t} or @code{nil} (e.g. @code{'other}), then a real tab -character@footnote{The caveat about @code{indent-tabs-mode} in the -previous footnote also applies here.} is inserted only when point is -inside a literal (see @ref{Auto-newline insertion}), otherwise the line -is indented. - -@kindex M-C-q -@findex c-indent-exp -@findex indent-exp (c-) -To indent an entire balanced brace or parenthesis expression, use -@kbd{M-C-q} (@code{c-indent-exp}). Note that point should be on -the opening brace or parenthesis of the expression you want to indent. - -@kindex C-c C-q -@findex c-indent-defun -@findex indent-defun (c-) -Another very convenient keystroke is @kbd{C-c C-q} -(@code{c-indent-defun}) when re-indents the entire top-level function or -class definition that encompasses point. It leaves point at the -same position within the buffer. - -@kindex M-C-\ -@findex indent-region -To indent any arbitrary region of code, use @kbd{M-C-\} -(@code{indent-region}). This is a standard Emacs command, specially -tailored for C code in a @ccmode{} buffer. Note that of course, -point and mark must delineate the region you -want to indent. - -@kindex M-C-h -@findex c-mark-function -@findex mark-function (c-) -While not strictly an indentation function, @kbd{M-C-h} -(@code{c-mark-function}) is useful for marking the current top-level -function or class definition as the current region. - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@node Other Commands, , Indentation Commands, Commands -@comment node-name, next, previous,up - -@section Other Commands -@cindex Other Commands -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -@ccmode{} contains other useful command for moving around in C -code. - -@table @code -@item C-c C-u (c-up-conditional) -@kindex C-c C-u -@findex c-up-conditional -@findex up-conditional (c-) -Move point back to the containing preprocessor conditional, leaving the -mark behind. A prefix argument acts as a repeat count. With a negative -argument, move point forward to the end of the containing -preprocessor conditional. When going backwards, @code{#elif} is treated -like @code{#else} followed by @code{#if}. When going forwards, -@code{#elif} is ignored.@refill - -@item C-c C-p (c-backward-conditional) -@kindex C-c C-p -@findex c-backward-conditional -@findex backward-conditional (c-) -Move point back over a preprocessor conditional, leaving the mark -behind. A prefix argument acts as a repeat count. With a negative -argument, move forward. - -@item C-c C-n (c-forward-conditional) -@kindex C-c C-n -@findex c-forward-conditional -@findex forward-conditional (c-) -Move point forward across a preprocessor conditional, leaving the mark -behind. A prefix argument acts as a repeat count. With a negative -argument, move backward. - -@item M-a (c-beginning-of-statement) -@kindex ESC a -@findex c-beginning-of-statement -@findex beginning-of-statement (c-) -Move point to the beginning of the innermost C statement. If point is -already at the beginning of a statement, it moves to the beginning of -the preceding statement. With prefix argument @var{n}, move back -@var{n} @minus{} 1 statements. - -If point is within a string or comment, or at the end of a comment, this -command moves by sentences instead of statements. - -When called from a program, this function takes three optional -arguments: the numeric prefix argument, a buffer position limit (don't -move back before that place), and a flag to indicate whether movement -should be by statements (if @code{t}) or sentence (if non-@code{nil}). - -@item M-e (c-end-of-statement) -@kindex ESC e -@findex c-end-of-statement -@findex end-of-statement (c-) -Move point to the end of the innermost C statement. If point is at the -end of a statement, move to the end of the next statement. With prefix -argument @var{n}, move forward @var{n} @minus{} 1 statements. - -If point is within a string or comment, or at the end of a comment, this -command moves by sentences instead of statements. - -When called from a program, this function takes three optional -arguments: the numeric prefix argument, a buffer position limit (don't -move back before that place), and a flag to indicate whether movement -should be by statements (if @code{t}) or sentence (if non-@code{nil}). - -@item M-x c-forward-into-nomenclature -@findex c-forward-into-nomenclature -@findex forward-into-nomenclature (c-) -A popular programming style, especially for object-oriented languages -such as C++ is to write symbols in a mixed case format, where the first -letter of each word is capitalized, and not separated by underscores. -E.g. @samp{SymbolsWithMixedCaseAndNoUnderlines}. - -This command moves point forward to next capitalized word. With prefix -argument @var{n}, move @var{n} times. - -@item M-x c-backward-into-nomenclature -@findex c-backward-into-nomenclature -@findex backward-into-nomenclature (c-) -Move point backward to beginning of the next capitalized -word. With prefix argument @var{n}, move @var{n} times. If -@var{n} is negative, move forward. - -@kindex C-c : -@findex c-scope-operator -@findex scope-operator (c-) -@item C-c : (c-scope-operator) -In C++, it is also sometimes desirable to insert the double-colon scope -operator without performing the electric behavior of colon insertion. -@kbd{C-c :} does just this. - -@item M-q (fill-paragraph) -@kindex ESC q -@findex fill-paragraph -@vindex c-hanging-comment-starter-p -@vindex c-hanging-comment-ender-p -@vindex hanging-comment-starter-p (c-) -@vindex hanging-comment-ender-p (c-) - -The command is used to fill a block style (C) or line style (C++) -comment, in much the same way that text in the various text modes can be -filled@footnote{You should not use specialized filling packages such as -@code{filladapt} with CC Mode. They don't work as well for filling as -@code{c-fill-paragraph}}. You should never attempt to fill non-comment -code sections; you'll end up with garbage! Two variables control how C -style block comments are filled, specifically how the comment start and -end delimiters are handled. - -The variable @code{c-hanging-comment-starter-p} controls whether comment -start delimiters which appear on a line by themselves, end up on a line -by themselves after the fill. When the value is @code{nil}, the comment -starter will remain on its own line@footnote{It will not be placed on a -separate line if it is not already on a separate line.}. Otherwise, -text on the next line will be put on the same line as the comment -starter. This is called @dfn{hanging} because the following text hangs -on the line with the comment starter@footnote{This variable is @code{t} -by default, except in @code{java-mode}. Hanging comment starters mess -up Javadoc style comments.} - -The variable @code{c-hanging-comment-ender-p} controls the analogous -behavior for the block comment end delimiter. When the value is -@code{nil}, the comment ender will remain on its own line after the -file@footnote{The same caveat as above holds true.}. Otherwise, the -comment end delimiter will be placed at the end of the previous line. - -@end table - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@node Customizing Indentation, Syntactic Symbols, Commands, Top -@comment node-name, next, previous,up - -@chapter Customizing Indentation -@cindex Customizing Indentation -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -@vindex c-offsets-alist -@vindex offsets-alist (c-) -@cindex c-set-offset -@cindex set-offset (c-) -The variable @code{c-offsets-alist} contains the mappings between -syntactic symbols and the offsets to apply for those symbols. You -should never modify this variable directly though. Use the function -@code{c-set-offset} instead (see below for details). - -The @code{c-offsets-alist} variable is where you customize all your -indentations. You simply need to decide what additional offset you want -to add for every syntactic symbol. You can use the command @kbd{C-c -C-o} (@code{c-set-offset}) as the way to set offsets, both interactively -and from your mode hook. Also, you can set up @emph{styles} of -indentatio. Most likely, you'll -find one of the pre-defined styles will suit your needs, but if not, -this section will describe how to set up basic editing configurations. -@xref{Styles} for an explanation of how to set up named styles. - -@cindex c-basic-offset -@cindex basic-offset (c-) -As mentioned previously, the variable @code{c-offsets-alist} is an -association list of syntactic symbols and the offsets to be applied for -those symbols. In fact, these offset values can be any of an integer, a -function or lambda expression, a variable name, or one of the following -symbols: @code{+}, @code{-}, @code{++}, @code{--}, @code{*}, or -@code{/}. These symbols describe offset in multiples of the value of -the variable @code{c-basic-offset}. By defining a style's indentation -in terms of this fundamental variable, you can change the amount of -whitespace given to an indentation level while leaving the same -relationship between levels. Here are the values that the special -symbols correspond to: - -@table @code - -@item + -@code{c-basic-offset} times 1 -@item - -@code{c-basic-offset} times -1 -@item ++ -@code{c-basic-offset} times 2 -@item -- -@code{c-basic-offset} times -2 -@item * -@code{c-basic-offset} times 0.5 -@item / -@code{c-basic-offset} times -0.5 - -@end table - -@vindex c-style-variables-are-local-p -@vindex style-variables-are-local-p (c-) -@noindent -So, for example, because most of the default offsets are defined in -terms of @code{+}, @code{-}, and @code{0}, if you like the general -indentation style, but you use 4 spaces instead of 2 spaces per level, -you can probably achieve your style just by changing -@code{c-basic-offset} like so (in your @file{.emacs} file): -@example - -(setq c-basic-offset 4) - -@end example - -@noindent -This would change -@example -@group - -int add( int val, int incr, int doit ) -@{ - if( doit ) - @{ - return( val + incr ); - @} - return( val ); -@} - -@end group -@end example -@noindent -to -@example -@group - -int add( int val, int incr, int doit ) -@{ - if( doit ) - @{ - return( val + incr ); - @} - return( val ); -@} - -@end group -@end example - - -To change indentation styles more radically, you will want to change the -value associated with the syntactic symbols in the -@code{c-offsets-alist} variable. First, I'll show you how to do that -interactively, then I'll describe how to make changes to your -@file{.emacs} file so that your changes are more permanent. - -@menu -* Interactive Customization:: -* Permanent Customization:: -* Styles:: -* Advanced Customizations:: -@end menu - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@node Interactive Customization, Permanent Customization, , Customizing Indentation -@comment node-name, next, previous,up - -@section Interactive Customization -@cindex Interactive Customization -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -As an example of how to customize indentation, let's change the -style of this example@footnote{In this an subsequent examples, the -original code is formatted using the @samp{gnu} style unless otherwise -indicated. @xref{Styles}.}: -@example -@group - -1: int add( int val, int incr, int doit ) -2: @{ -3: if( doit ) -4: @{ -5: return( val + incr ); -6: @} -7: return( val ); -8: @} - -@end group -@end example -@noindent -to: -@example -@group - -1: int add( int val, int incr, int doit ) -2: @{ -3: if( doit ) -4: @{ -5: return( val + incr ); -6: @} -7: return( val ); -8: @} - -@end group -@end example - -In other words, we want to change the indentation of braces that open a -block following a condition so that the braces line up under the -conditional, instead of being indented. Notice that the construct we -want to change starts on line 4. To change the indentation of a line, -we need to see which syntactic components affect the offset calculations -for that line. Hitting @kbd{C-c C-s} on line 4 yields: -@example - -((substatement-open . 44)) - -@end example - -@findex c-set-offset -@findex set-offset (c-) -@kindex C-c C-o -@noindent -so we know that to change the offset of the open brace, we need to -change the indentation for the @code{substatement-open} syntactic -symbol. To do this interactively, just hit @kbd{C-c C-o} -(@code{c-set-offset}). This prompts you for the syntactic symbol to -change, providing a reasonable default. In this case, the default is -@code{substatement-open}, which is just the syntactic symbol we want to -change! - -After you hit return, @ccmode{} will then prompt you for the new -offset value, with the old value as the default. The default in this -case is @samp{+}, but we want no extra indentation so enter -@samp{0} and @kbd{RET}. This will associate the offset 0 with the -syntactic symbol @code{substatement-open} in the @code{c-offsets-alist} -variable. - -@findex c-indent-defun -@findex indent-defun (c-) -@kindex C-c C-q -To check your changes quickly, just hit @kbd{C-c C-q} -(@code{c-indent-defun}) to reindent the entire function. The example -should now look like: -@example -@group - -1: int add( int val, int incr, int doit ) -2: @{ -3: if( doit ) -4: @{ -5: return( val + incr ); -6: @} -7: return( val ); -8: @} - -@end group -@end example - -Notice how just changing the open brace offset on line 4 is all we -needed to do. Since the other affected lines are indented relative to -line 4, they are automatically indented the way you'd expect. For more -complicated examples, this may not always work. The general approach to -take is to always start adjusting offsets for lines higher up in the -file, then re-indent and see if any following lines need further -adjustments. - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@node Permanent Customization, Styles, Interactive Customization, Customizing Indentation -@comment node-name, next, previous,up - -@section Permanent Customization -@cindex Permanent Customization -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -@vindex c-mode-common-hook -@vindex c-mode-hook -@vindex c++-mode-hook -@vindex objc-mode-hook -@vindex java-mode-hook -@vindex idl-mode-hook -@vindex c-initialization-hook -@vindex initialization-hook (c-) -@cindex hooks -To make your changes permanent, you need to add some lisp code to your -@file{.emacs} file, but first you need to decide whether your styles -should be global in every buffer, or local to each specific buffer. - -If you edit primarily one style of code, you may want to make the -@ccmode{} style variables have global values so that every buffer will -share the style settings. This will allow you to set the @ccmode{} -variables at the top level of your @file{.emacs} file, and is the -way @ccmode{} works by default. - -@vindex c-mode-common-hook -@vindex mode-common-hook (c-) -@vindex c-style-variables-are-local-p -@vindex style-variables-are-local-p (c-) -If you edit many different styles of code at -the same time, you might want to make the @ccmode{} style variables -have buffer local values. If you do this, then you will need to set any -@ccmode{} style variables in a hook function (e.g. off of -@code{c-mode-common-hook} instead of at the top level of your -@file{.emacs} file. The recommended way to do this is to set the -variable @code{c-style-variables-are-local-p} to @code{t} -@strong{before} @ccmode{} is loaded into your Emacs session. - -@ccmode{} provides several hooks that you can -use to customize the mode according to your coding style. Each language -mode has its own hook, adhering to standard Emacs major mode -conventions. There is also one general hook and one package -initialization hook: - -@itemize @bullet - -@item -@code{c-mode-hook} --- for C buffers only -@item -@code{c++-mode-hook} --- for C++ buffers only -@item -@code{objc-mode-hook} --- for Objective-C buffers only -@item -@code{java-mode-hook} --- for Java buffers only -@item -@code{idl-mode-hook} --- for IDL buffers only -@item -@code{c-mode-common-hook} --- common across all languages -@item -@code{c-initialization-hook} --- hook run only once per Emacs session, -when @ccmode{} is initialized. - -@end itemize - -The language hooks get run as the last thing when you enter that -language mode. The @code{c-mode-common-hook} is run by all -supported modes @emph{before} the language specific hook, and thus can -contain customizations that are common across all languages. Most of -the examples in this section will assume you are using the common -hook@footnote{The interaction between @code{java-mode} and the hook -variables is slightly different than for the other modes. -@code{java-mode} sets the style (see @ref{Styles}) of the buffer to -@samp{java} @emph{before} running the @code{c-mode-common-hook} or -@code{java-mode-hook}. You need to be aware of this so that style -settings in @code{c-mode-common-hook} don't clobber your Java style.}. - -Here's a simplified example of what you can add to your @file{.emacs} -file to make the changes described in the previous section -(@ref{Interactive Customization}) more permanent. See the Emacs manuals -for more information on customizing Emacs via hooks. @xref{Sample -.emacs File} for a more complete sample @file{.emacs} file. -@example -@group - -(defun my-c-mode-common-hook () - ;; my customizations for all of c-mode and related modes - (c-set-offset 'substatement-open 0) - ;; other customizations can go here - ) -(add-hook 'c-mode-common-hook 'my-c-mode-common-hook) - -@end group -@end example - -For complex customizations, you will probably want to set up a -@emph{style} that groups all your customizations under a single -name. - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@node Styles, Advanced Customizations, Permanent Customization, Customizing Indentation -@comment node-name, next, previous,up - -@section Styles -@cindex Styles -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -Most people only need to edit code formatted in just a few well-defined -and consistent styles. For example, their organization might impose a -``blessed'' style that all its programmers must conform to. Similarly, -people who work on GNU software will have to use the GNU coding style on -C code. Some shops are more lenient, allowing a variety of coding -styles, and as programmers come and go, there could be a number of -styles in use. For this reason, @ccmode{} makes it convenient for -you to set up logical groupings of customizations called @dfn{styles}, -associate a single name for any particular style, and pretty easily -start editing new or existing code using these styles. This section -describes how to set up styles and how to edit your C code using styles. - -@menu -* Built-in Styles:: -* Adding Styles:: -* File Styles:: -@end menu - - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@node Built-in Styles, Adding Styles, , Styles -@comment node-name, next, previous,up - -@subsection Built-in Styles -@cindex Built-in Styles -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -If you're lucky, one of @ccmode{}'s built-in styles might be just -what you're looking for. These include: - -@itemize @bullet -@item -@cindex GNU style -@code{gnu} --- coding style blessed by the Free Software Foundation -for C code in GNU programs. - -@item -@cindex K&R style -@code{k&r} --- The classic Kernighan and Ritchie style for C code. - -@item -@cindex BSD style -@code{bsd} --- Also known as ``Allman style'' after Eric Allman. - -@item -@cindex Whitesmith style -@code{whitesmith} --- Popularized by the examples that came with -Whitesmiths C, an early commercial C compiler. - -@item -@cindex Stroustrup style -@code{stroustrup} --- The classic Stroustrup style for C++ code. - -@item -@cindex Ellemtel style -@code{ellemtel} --- Popular C++ coding standards as defined by -``Programming in C++, Rules and Recommendations'', Erik Nyquist and Mats -Henricson, Ellemtel @footnote{This document is ftp'able from -@code{euagate.eua.ericsson.se}}. - -@item -@cindex Linux style -@code{linux} --- C coding standard for Linux development. - -@item -@cindex Python style -@code{python} --- C coding standard for Python extension -modules@footnote{Python is a high level scripting language with a C/C++ -foreign function interface. For more information, see -@code{<http://www.python.org/>}.}. - -@item -@cindex Java style -@cindex java-mode -@code{java} --- The style for editing Java code. Note that this style is -automatically installed when you enter @code{java-mode}. - -@end itemize - -@findex c-set-style -@findex set-style (c-) -@kindex C-c . -If you'd like to experiment with these built-in styles you can simply -type the following in a @ccmode{} buffer: -@example -@group - -@kbd{C-c . @var{STYLE-NAME} RET} - -@end group -@end example -@noindent -@kbd{C-c .} runs the command @code{c-set-style}. Note that all style -names are case insensitive, even the ones you define. - -Setting a style in this way does @emph{not} automatically re-indent your -file. For commands that you can use to view the effect of your changes, -see @ref{Commands}. - -Once you find a built-in style you like, you can make the change -permanent by adding some lisp to your @file{.emacs} file. Let's say for -example that you want to use the @samp{ellemtel} style in all your -files. You would add this: -@example -@group - -(defun my-c-mode-common-hook () - ;; use Ellemtel style for all C like languages - (c-set-style "ellemtel") - ;; other customizations can go here - ) -(add-hook 'c-mode-common-hook 'my-c-mode-common-hook) - -@end group -@end example - -@cindex cc-mode style -There is one other special style you can use, called @samp{cc-mode} -style. This style is special because all other styles implicitly -inherit from it; in other words, whenever you set a style, -@samp{cc-mode} is applied before the one you selected. This means -your style need only define the differences between it and -@samp{cc-mode} style. - -Note @emph{you should never change any of the default styles}. -Instead, it's better to add a new style using @code{c-add-style} -(@xref{Adding Styles}). This is especially true for @code{cc-mode} and -@code{java} styles. - -@vindex c-indentation-style -@vindex indentation-style (c-) -Note that for BOCM compatibility, @samp{gnu} is the default -style, and any non-style based customizations you make (i.e. in -@code{c-mode-common-hook} in your -@file{.emacs} file) will be based on @samp{gnu} style unless you do -a @code{c-set-style} as the first thing in your hook. The variable -@code{c-indentation-style} always contains the buffer's current style name, -as a string. - - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@node Adding Styles, File Styles, Built-in Styles, Styles -@comment node-name, next, previous,up - -@subsection Adding Styles -@cindex Adding Styles -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -@vindex c-style-alist -@vindex style-alist (c-) -@findex c-add-style -@findex add-style (c-) -If none of the built-in styles is appropriate, you'll probably want to -add a new @dfn{style definition}. Styles are kept in the -@code{c-style-alist} variable, but you should never modify this variable -directly. Instead, @ccmode{} provides the function -@code{c-add-style} that you can use to easily add new styles or change -existing styles. This function takes two arguments, a @var{stylename} -string, and an association list @var{description} of style -customizations. If @var{stylename} is not already in -@code{c-style-alist}, the new style is added, otherwise the style is -changed to the new @var{description}. -This function also takes an optional third argument, which if -non-@code{nil}, automatically applies the new style to the current -buffer. - -@comment TBD: The next paragraph is bogus. I really need to better -@comment document adding styles, including setting up inherited styles. - -The sample @file{.emacs} file provides a concrete example of how a new -style can be added and automatically set. @xref{Sample .emacs File}. - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@node File Styles, , Adding Styles, Styles -@comment node-name, next, previous,up - -@subsection File Styles -@cindex File Styles -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -@cindex local variables - -The Emacs manual describes how you can customize certain variables on a -per-file basis by including a @dfn{Local Variable} block at the end of -the file. So far, you've only seen a functional interface to @ccmode{} -customization, which is highly inconvenient for use in a Local Variable -block. @ccmode{} provides two variables that make it easier for you to -customize your style on a per-file basis@footnote{Note that this feature -doesn't work with Emacs versions before XEmacs 19.12 and Emacs 19.29. -It works via the standard Emacs hook variable -@code{hack-local-variables-hook}.} - -@vindex c-file-style -@vindex file-style (c-) -@vindex c-file-offsets -@vindex file-offsets (c-) - -The variable @code{c-file-style} can be set to a style name string. -When the file is visited, @ccmode{} will automatically set the -file's style to this style using @code{c-set-style}. - -@vindex c-offsets-alist -@vindex offsets-alist (c-) -@findex c-set-offset -@findex set-offset (c-) -Another variable, @code{c-file-offsets}, takes an association list -similar to what is allowed in @code{c-offsets-alist}. When the file is -visited, @ccmode{} will automatically institute these offets using -@code{c-set-offset}. - -Note that file style settings (i.e. @code{c-file-style}) are applied -before file offset settings (i.e. @code{c-file-offsets}). - - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@node Advanced Customizations, , Styles, Customizing Indentation -@comment node-name, next, previous,up - -@section Advanced Customizations -@cindex Advanced Customizations -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -@vindex c-style-alist -@vindex style-alist (c-) -@vindex c-basic-offset -@vindex basic-offset (c-) -For most users, @ccmode{} will support their coding styles with -very little need for more advanced customizations. Usually, one of the -standard styles defined in @code{c-style-alist} will do the trick. At -most, perhaps one of the syntactic symbol offsets will need to be -tweaked slightly, or maybe @code{c-basic-offset} will need to be -changed. However, some styles require a more flexible framework for -customization, and one of the real strengths of @ccmode{} is that -the syntactic analysis model provides just such a framework. This allows -you to implement custom indentation calculations for situations not -handled by the mode directly. - -@vindex c-style-variables-are-local-p -@vindex style-variables-are-local-p -Note that the style controlling variables can either have global values, -or can be buffer local (e.g. different in every buffer). If all the C -files you edit tend to have the same style, you might want to keep the -variables global. If you tend to edit files with many different styles, -you will have to make the variables buffer local. The variable -@code{c-style-variables-are-local-p} controls this. - -When @code{c-style-variables-are-local-p} is non-nil, then the style -variables will have a different settable value for each buffer, -otherwise all buffers will share the same values. By default, its value -is @code{nil} (i.e. global values). You @strong{must} set this variable -before @ccmode{} is loaded into your Emacs session, and once the -variables are made buffer local, they cannot be made global again -(unless you restart Emacs of course!) - -@menu -* Custom Indentation Functions:: -* Custom Brace and Colon Hanging:: -* Customizing Semi-colons and Commas:: -* Other Special Indentations:: -@end menu - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@node Custom Indentation Functions, Custom Brace and Colon Hanging, , Advanced Customizations -@comment node-name, next, previous,up - -@subsection Custom Indentation Functions -@cindex Custom Indentation Functions -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -@cindex custom indentation functions -The most flexible way to customize @ccmode{} is by writing @dfn{custom -indentation functions} and associating them with specific syntactic -symbols (see @ref{Syntactic Symbols}). @ccmode{} itself uses custom -indentation functions to provide more sophisticated indentation, for -example when lining up C++ stream operator blocks: -@example -@group - -1: void main(int argc, char**) -2: @{ -3: cout << "There were " -4: << argc -5: << "arguments passed to the program" -6: << endl; -7: @} - -@end group -@end example - -In this example, lines 4 through 6 are assigned the @code{stream-op} -syntactic symbol. Here, @code{stream-op} has an offset of @code{+}, and -with a @code{c-basic-offset} of 2, you can see that lines 4 through 6 -are simply indented two spaces to the right of line 3. But perhaps we'd -like @ccmode{} to be a little more intelligent so that it aligns -all the @samp{<<} symbols in lines 3 through 6. To do this, we have -to write a custom indentation function which finds the column of first -stream operator on the first line of the statement. Here is sample -lisp code implementing this: -@example -@group - -(defun c-lineup-streamop (langelem) - ;; lineup stream operators - (save-excursion - (let* ((relpos (cdr langelem)) - (curcol (progn (goto-char relpos) - (current-column)))) - (re-search-forward "<<\\|>>" (c-point 'eol) 'move) - (goto-char (match-beginning 0)) - (- (current-column) curcol)))) - -@end group -@end example -@noindent -Custom indent functions take a single argument, which is a syntactic -component cons cell (see @ref{Syntactic Analysis}). The -function returns an integer offset value that will be added to the -running total indentation for the line. Note that what actually gets -returned is the difference between the column that the first stream -operator is on, and the column of the buffer relative position passed in -the function's argument. Remember that @ccmode{} automatically -adds in the column of the component's relative buffer position and we -don't the column offset added in twice. - -@cindex stream-op syntactic symbol -@findex c-lineup-streamop -@findex lineup-streamop (c-) -Now, to associate the function @code{c-lineup-streamop} with the -@code{stream-op} syntactic symbol, we can add something like the -following to our @code{c++-mode-hook}@footnote{It probably makes more -sense to add this to @code{c++-mode-hook} than @code{c-mode-common-hook} -since stream operators are only relevent for C++.}: -@example - -(c-set-offset 'stream-op 'c-lineup-streamop) - -@end example - -@kindex C-c C-q -Now the function looks like this after re-indenting (using @kbd{C-c -C-q}): -@example -@group - -1: void main(int argc, char**) -2: @{ -3: cout << "There were " -4: << argc -5: << "arguments passed to the program" -6: << endl; -7: @} - -@end group -@end example - -@vindex c-offsets-alist -@vindex offsets-alist (c-) -Custom indentation functions can be as simple or as complex as you like, -and any syntactic symbol that appears in @code{c-offsets-alist} can have -a custom indentation function associated with it. @ccmode{} comes -with several standard custom indentation functions, not all of which are -used by the default styles. - -@itemize @bullet -@item -@findex c-lineup-arglist -@findex lineup-arglist (c-) -@code{c-lineup-arglist} --- lines up function argument lines under the -argument on the previous line. - -@item -@findex c-lineup-arglist-intro-after-paren -@findex lineup-arglist-intro-after-paren (c-) -@code{c-lineup-arglist-intro-after-paren} --- similar to -@code{c-lineup-arglist}, but works for argument lists that begin with an -open parenthesis followed by a newline. - -@item -@findex c-lineup-arglist-close-under-paren -@findex lineup-arglist-close-under-paren (c-) -@code{c-lineup-arglist-close-under-paren} --- set your -@code{arglist-close} syntactic symbol to this line-up function so that -parentheses that close argument lists will line up under the parenthesis -that opened the argument list. - -@item -@findex c-lineup-streamop -@findex lineup-streamop (c-) -@code{c-lineup-streamop} --- lines up C++ stream operators -(e.g. @samp{<<} and @samp{>>}). - -@item -@findex c-lineup-multi-inher -@findex lineup-multi-inher (c-) -@code{c-lineup-multi-inher} --- lines up multiple inheritance lines. - -@item -@findex c-lineup-C-comments -@findex lineup-C-comments (c-) -@code{c-lineup-C-comments} --- lines up C block comment continuation -lines. - -@item -@findex c-lineup-comment -@findex lineup-comment (c-) -@vindex c-comment-only-line-offset -@vindex comment-only-line-offset (c-) -@code{c-lineup-comment} --- lines up comment only lines according to -the variable @code{c-comment-only-line-offset}. - -@item -@findex c-lineup-runin-statements -@findex lineup-runin-statements (c-) -@code{c-lineup-runin-statements} --- lines up @code{statement}s for coding -standards which place the first statement in a block on the same line as -the block opening brace@footnote{Run-in style doesn't really work too -well. You might need to write your own custom indentation functions to -better support this style.}. - -@item -@findex c-lineup-math -@findex lineup-math (c-) -@code{c-lineup-math} --- lines up math @code{statement-cont} lines under -the previous line after the equals sign. - -@item -@findex c-lineup-ObjC-method-call -@findex lineup-ObjC-method-call (c-) -@code{c-lineup-ObjC-method-call} --- for Objective-C code, lines up -selector arguments just after the message receiver. - -@item -@findex c-lineup-ObjC-method-args -@findex lineup-ObjC-method-args (c-) -@code{c-lineup-ObjC-method-args} --- for Objective-C code, lines up the -colons that separate arguments by aligning colons vertically. - -@item -@findex c-lineup-ObjC-method-args-2 -@findex lineup-ObjC-method-args-2 (c-) -@code{c-lineup-ObjC-method-args-2} --- similar to -@code{c-lineup-ObjC-method-args} but lines up the colon on the current -line with the colon on the previous line. - -@end itemize - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@node Custom Brace and Colon Hanging, Customizing Semi-colons and Commas, Custom Indentation Functions, Advanced Customizations -@comment node-name, next, previous,up - -@subsection Custom Brace and Colon Hanging -@cindex Custom Brace and Colon Hanging -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -@vindex c-hanging-braces-alist -@vindex hanging-braces-alist (c-) -Syntactic symbols aren't the only place where you can customize -@ccmode{} with the lisp equivalent of callback functions. Brace -``hanginess'' can also be determined by custom functions associated with -syntactic symbols on the @code{c-hanging-braces-alist} variable. -Remember that @var{ACTION}'s are typically a list containing some -combination of the symbols @code{before} and @code{after} (see -@ref{Hanging Braces}). However, an @var{ACTION} can also be a function -which gets called when a brace matching that syntactic symbol is -entered. - -@cindex customizing brace hanging -These @var{ACTION} functions are called with two arguments: the -syntactic symbol for the brace, and the buffer position at which the -brace was inserted. The @var{ACTION} function is expected to return a -list containing some combination of @code{before} and @code{after}. The -function can also return @code{nil}. This return value has the normal -brace hanging semantics. - -As an example, @ccmode{} itself uses this feature to dynamically -determine the hanginess of braces which close ``do-while'' -constructs: -@example -@group - -void do_list( int count, char** atleast_one_string ) -@{ - int i=0; - do @{ - handle_string( atleast_one_string[i] ); - i++; - @} while( i < count ); -@} - -@end group -@end example - -@findex c-snug-do-while -@findex snug-do-while (c-) -@ccmode{} assigns the @code{block-close} syntactic symbol to the -brace that closes the @code{do} construct, and normally we'd like the -line that follows a @code{block-close} brace to begin on a separate -line. However, with ``do-while'' constructs, we want the -@code{while} clause to follow the closing brace. To do this, we -associate the @code{block-close} symbol with the @var{ACTION} function -@code{c-snug-do-while}: -@example - -(defun c-snug-do-while (syntax pos) - "Dynamically calculate brace hanginess for do-while statements. -Using this function, `while' clauses that end a `do-while' block will -remain on the same line as the brace that closes that block. - -See `c-hanging-braces-alist' for how to utilize this function as an -ACTION associated with `block-close' syntax." - (save-excursion - (let (langelem) - (if (and (eq syntax 'block-close) - (setq langelem (assq 'block-close c-syntactic-context)) - (progn (goto-char (cdr langelem)) - (if (= (following-char) ?@{) - (forward-sexp -1)) - (looking-at "\\<do\\>[^_]"))) - '(before) - '(before after))))) - -@end example - -This function simply looks to see if the brace closes a ``do-while'' -clause and if so, returns the list @samp{(before)} indicating -that a newline should be inserted before the brace, but not after it. -In all other cases, it returns the list @samp{(before after)} so -that the brace appears on a line by itself. - -@vindex c-syntactic-context -@vindex syntactic-context (c-) -During the call to the brace hanging @var{ACTION} function, the variable -@code{c-syntactic-context} is bound to the full syntactic analysis list. - -@cindex customizing colon hanging -@vindex c-hanging-colon-alist -@vindex hanging-colon-alist (c-) -Note that for symmetry, colon hanginess should be customizable by -allowing function symbols as @var{ACTION}s on the -@code{c-hanging-colon-alist} variable. Since no use has actually been -found for this feature, it isn't currently implemented! - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@node Customizing Semi-colons and Commas, Other Special Indentations, Custom Brace and Colon Hanging, Advanced Customizations -@comment node-name, next, previous,up - -@subsection Customizing Semi-colons and Commas -@cindex Customizing Semi-colons and Commas -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -@cindex customizing semi-colons and commas -@vindex c-hanging-semi&comma-criteria -@vindex hanging-semi&comma-criteria (c-) -You can also customize the insertion of newlines after semi-colons and -commas, when the auto-newline minor mode is enabled (see @ref{Minor -Modes}). This is controlled by the variable -@code{c-hanging-semi&comma-criteria}, which contains a list of functions -that are called in the order they appear. Each function is called with -zero arguments, and is expected to return one of the following values: - -@itemize @bullet -@item -non-@code{nil} --- A newline is inserted, and no more functions from the -list are called. - -@item -@code{stop} --- No more functions from the list are called, but no -newline is inserted. - -@item -@code{nil} --- No determination is made, and the next function in the -list is called. - -@end itemize - -If every function in the list is called without a determination being -made, then no newline is added. The default value for this variable is a -list containing a single function which inserts newlines only after -semi-colons which do not appear inside parenthesis lists (i.e. those -that separate @code{for}-clause statements). - -Here's an example of a criteria function that will prevent newlines from -being inserted after semicolons when there is a non-blank following -line. Otherwise, it makes no determination. To use, add this to the -front of the @code{c-hanging-semi&comma-criteria} list. - -@example -@group - -(defun my-semicolon-criteria () - (save-excursion - (if (and (eq last-command-char ?\;) - (zerop (forward-line 1)) - (not (looking-at "^[ \t]*$"))) - 'stop - nil))) - -@end group -@end example - - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@node Other Special Indentations, , Customizing Semi-colons and Commas, Advanced Customizations -@comment node-name, next, previous,up - -@subsection Other Special Indentations -@cindex Customizing Semi-colons and Commas -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -@vindex c-label-minimum-indentation -@vindex label-minimum-indentation (c-) -In @samp{gnu} style (see @ref{Built-in Styles}), a minimum indentation -is imposed on lines inside top-level constructs. This minimum -indentation is controlled by the variable -@code{c-label-minimum-indentation}. The default value for this variable -is 1. - -@vindex c-special-indent-hook -@vindex special-indent-hook (c-) -One other customization variable is available in @ccmode{}: -@code{c-special-indent-hook}. This is a standard hook variable that is -called after every line is indented by @ccmode{}. You can use it -to do any special indentation or line adjustments your style dictates, -such as adding extra indentation to constructors or destructor -declarations in a class definition, etc. Note however, that you should -not change point or mark inside your @code{c-special-indent-hook} -functions (i.e. you'll probably want to wrap your function in a -@code{save-excursion}). - -Setting @code{c-special-indent-hook} in your style definition is handled -slightly differently than other variables. In your style definition, -you should set the value for -@code{c-special-indent-hook} to a function or list of functions, which -will be appended to @code{c-special-indent-hook} using @code{add-hook}. -That way, the current setting for the buffer local value of -@code{c-special-indent-hook} won't be overridden. - -@kindex M-; -@findex indent-for-comment -@vindex c-indent-comments-syntactically-p -@vindex indent-comments-syntactically-p (c-) -@vindex comment-column - -Normally, the standard Emacs command @kbd{M-;} -(@code{indent-for-comment}) will indent comment only lines to -@code{comment-column}. Some users however, prefer that @kbd{M-;} act -just like @kbd{TAB} for purposes of indenting comment-only lines; -i.e. they want the comments to always indent as they would for normal -code, regardless of whether @kbd{TAB} or @kbd{M-;} were used. This -behavior is controlled by the variable -@code{c-indent-comments-syntactically-p}. When @code{nil} (the -default), @kbd{M-;} indents comment-only lines to @code{comment-column}, -otherwise, they are indented just as they would be if @kbd{TAB} were -typed. - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@node Syntactic Symbols, Performance Issues, Customizing Indentation, Top -@comment node-name, next, previous,up - -@chapter Syntactic Symbols -@cindex Syntactic Symbols -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -@vindex c-offsets-alist -@vindex offsets-alist (c-) - -Here is a complete list of the recognized syntactic symbols as described -in the @code{c-offsets-alist} variable, along with a brief description. -More detailed descriptions follow below. - -@itemize @bullet -@item -@code{string} --- inside multi-line string -@item -@code{c} --- inside a multi-line C style block comment -@item -@code{defun-open} --- brace that opens a function definition -@item -@code{defun-close} --- brace that closes a function definition -@item -@code{defun-block-intro} --- the first line in a top-level defun -@item -@code{class-open} --- brace that opens a class definition -@item -@code{class-close} --- brace that closes a class definition -@item -@code{inline-open} --- brace that opens an in-class inline method -@item -@code{inline-close} --- brace that closes an in-class inline method -@item -@code{func-decl-cont} --- the region between a function definition's -argument list and the function opening brace (excluding K&R argument -declarations). In C, you cannot put anything but whitespace and comments -between them; in C++ and Java, @code{throws} declarations and other -things can appear in this context. -@item -@code{knr-argdecl-intro} --- first line of a K&R C argument declaration -@item -@code{knr-argdecl} --- subsequent lines in a K&R C argument declaration -@item -@code{topmost-intro} --- the first line in a topmost definition -@item -@code{topmost-intro-cont} --- topmost definition continuation lines -@item -@code{member-init-intro} --- first line in a member initialization list -@item -@code{member-init-cont} --- subsequent member initialization list lines -@item -@code{inher-intro} --- first line of a multiple inheritance list -@item -@code{inher-cont} --- subsequent multiple inheritance lines -@item -@code{block-open} --- statement block open brace -@item -@code{block-close} --- statement block close brace -@item -@code{brace-list-open} --- open brace of an enum or static array list -@item -@code{brace-list-close} --- close brace of an enum or static array list -@item -@code{brace-list-intro} --- first line in an enum or static array list -@item -@code{brace-list-entry} --- subsequent lines in an enum or static array list -@item -@code{statement} --- a C statement -@item -@code{statement-cont} --- a continuation of a C statement -@item -@code{statement-block-intro} --- the first line in a new statement block -@item -@code{statement-case-intro} --- the first line in a case `block' -@item -@code{statement-case-open} --- the first line in a case block starting -with brace -@item -@code{substatement} --- the first line after a conditional -@item -@code{substatement-open} --- the brace that opens a substatement block -@item -@code{case-label} --- a case or default label -@item -@code{access-label} --- C++ access control label -@item -@code{label} --- any non-special C label -@item -@code{do-while-closure} --- the `while' that ends a -@code{do}-@code{while} construct -@item -@code{else-clause} --- the `else' of an @code{if}-@code{else} construct -@item -@code{comment-intro} --- a line containing only a comment introduction -@item -@code{arglist-intro} --- the first line in an argument list -@item -@code{arglist-cont} --- subsequent argument list lines when no arguments -follow on the same line as the the arglist opening paren -@item -@code{arglist-cont-nonempty} --- subsequent argument list lines when at -least one argument follows on the same line as the arglist opening paren -@item -@code{arglist-close} --- the solo close paren of an argument list -@item -@code{stream-op} --- lines continuing a stream operator -@item -@code{inclass} --- the line is nested inside a class definition -@item -@code{cpp-macro} --- the start of a cpp macro -@item -@code{friend} --- a C++ friend declaration -@item -@code{objc-method-intro} --- the first line of an Objective-C method definition -@item -@code{objc-method-args-cont} --- lines continuing an Objective-C method -definition -@item -@code{objc-method-call-cont} --- lines continuing an Objective-C method call -@item -@code{extern-lang-open} --- brace that opens an external language block -@item -@code{extern-lang-close} --- brace that closes an external language block -@item -@code{inextern-lang} --- analogous to `inclass' syntactic symbol, but -for @code{extern} blocks. -@item -@code{template-args-cont} --- C++ template argument list continuations -@end itemize - -@cindex -open syntactic symbols -@cindex -close syntactic symbols -Most syntactic symbol names follow a general naming convention. When a -line begins with an open or close brace, the syntactic symbol will -contain the suffix @code{-open} or @code{-close} respectively. - -@cindex -intro syntactic symbols -@cindex -cont syntactic symbols -@cindex -block-intro syntactic symbols -Usually, a distinction is made between the first line that introduces a -construct and lines that continue a construct, and the syntactic symbols -that represent these lines will contain the suffix @code{-intro} or -@code{-cont} respectively. As a sub-classification of this scheme, a -line which is the first of a particular brace block construct will -contain the suffix @code{-block-intro}. - -@kindex C-c C-s -Let's look at some examples to understand how this works. Remember that -you can check the syntax of any line by using @kbd{C-c C-s}. -@example -@group - - 1: void - 2: swap( int& a, int& b ) - 3: @{ - 4: int tmp = a; - 5: a = b; - 6: b = tmp; - 7: int ignored = - 8: a + b; - 9: @} - -@end group -@end example - -@cindex topmost-intro syntactic symbol -@cindex topmost-intro-cont syntactic symbol -@cindex defun-open syntactic symbol -@cindex defun-close syntactic symbol -@cindex defun-block-intro syntactic symbol -Line 1 shows a @code{topmost-intro} since it is the first line that -introduces a top-level construct. Line 2 is a continuation of the -top-level construct introduction so it has the syntax -@code{topmost-intro-cont}. Line 3 shows a @code{defun-open} since it is -the brace that opens a top-level function definition. Line 9 is a -@code{defun-close} since it contains the brace that closes the top-level -function definition. Line 4 is a @code{defun-block-intro}, i.e. it is -the first line of a brace-block, enclosed in a -top-level function definition. - -@cindex statement syntactic symbol -@cindex statement-cont syntactic symbol -Lines 5, 6, and 7 are all given @code{statement} syntax since there -isn't much special about them. Note however that line 8 is given -@code{statement-cont} syntax since it continues the statement begun -on the previous line. - -Here's another example, which illustrates some C++ class syntactic -symbols: -@example -@group - - 1: class Bass - 2: : public Guitar, - 3: public Amplifiable - 4: @{ - 5: public: - 6: Bass() - 7: : eString( new BassString( 0.105 )), - 8: aString( new BassString( 0.085 )), - 9: dString( new BassString( 0.065 )), - 10: gString( new BassString( 0.045 )) - 11: @{ - 12: eString.tune( 'E' ); - 13: aString.tune( 'A' ); - 14: dString.tune( 'D' ); - 15: gString.tune( 'G' ); - 16: @} - 17: friend class Luthier; - 18: @} - -@end group -@end example - -@cindex class-open syntactic symbol -@cindex class-close syntactic symbol -As in the previous example, line 1 has the @code{topmost-intro} syntax. -Here however, the brace that opens a C++ class definition on line 4 is -assigned the @code{class-open} syntax. Note that in C++, classes, -structs, and unions are essentially equivalent syntactically (and are -very similar semantically), so replacing the @code{class} keyword in the -example above with @code{struct} or @code{union} would still result in a -syntax of @code{class-open} for line 4 @footnote{This is the case even -for C and Objective-C. For consistency, structs in all supported -languages are syntactically equivalent to classes. Note however that -the keyword @code{class} is meaningless in C and Objective-C.}. -Similarly, line 18 is assigned @code{class-close} syntax. - -@cindex inher-intro syntactic symbol -@cindex inher-cont syntactic symbol -Line 2 introduces the inheritance list for the class so it is assigned -the @code{inher-intro} syntax, and line 3, which continues the -inheritance list is given @code{inher-cont} syntax. - -@cindex access-label syntactic symbol -@cindex inclass syntactic symbol -Hitting @kbd{C-c C-s} on line 5 shows the following analysis: - -@example -@group - -@code{((inclass . 1) (access-label . 67))} - -@end group -@end example - -@noindent -The primary syntactic symbol for this line is @code{access-label} as -this a label keyword that specifies access protection in C++. However, -because this line is also a top-level construct inside a class -definition, the analysis actually shows two syntactic symbols. The -other syntactic symbol assigned to this line is @code{inclass}. -Similarly, line 6 is given both @code{inclass} and @code{topmost-intro} -syntax: - -@example -@group - -@code{((inclass . 58) (topmost-intro . 60))} - -@end group -@end example - -@cindex member-init-intro syntactic symbol -@cindex member-init-cont syntactic symbol -Line 7 introduces a C++ member initialization list and as such is given -@code{member-init-intro} syntax. Note that in this case it is -@emph{not} assigned @code{inclass} since this is not considered a -top-level construct. Lines 8 through 10 are all assigned -@code{member-init-cont} since they continue the member initialization -list started on line 7. - -@cindex in-class inline methods -@cindex inline-open syntactic symbol -@cindex inline-close syntactic symbol -Line 11's analysis is a bit more complicated: - -@example -@group - -@code{((inclass . 1) (inline-open))} - -@end group -@end example - -This line is assigned a syntax of both @code{inline-open} and -@code{inclass} because it opens an @dfn{in-class} C++ inline method -definition. This is distinct from, but related to, the C++ notion of an -inline function in that its definition occurs inside an enclosing class -definition, which in C++ implies that the function should be inlined. -If though, the definition of the @code{Bass} constructor appeared -outside the class definition, the construct would be given the -@code{defun-open} syntax, even if the keyword @code{inline} appeared -before the method name, as in: -@example -@group - -class Bass - : public Guitar, - public Amplifiable -@{ -public: - Bass(); -@} - -inline -Bass::Bass() - : eString( new BassString( 0.105 )), - aString( new BassString( 0.085 )), - dString( new BassString( 0.065 )), - gString( new BassString( 0.045 )) -@{ - eString.tune( 'E' ); - aString.tune( 'A' ); - dString.tune( 'D' ); - gString.tune( 'G' ); -@} - -@end group -@end example - -@cindex friend syntactic symbol -Returning to the previous example, line 16 is given @code{inline-close} -syntax, while line 12 is given @code{defun-block-open} syntax, and lines -13 through 15 are all given @code{statement} syntax. Line 17 is -interesting in that its syntactic analysis list contains three -elements: - -@example - -@code{((friend) (inclass . 58) (topmost-intro . 380))} - -@end example - -The @code{friend} syntactic symbol is a modifier that typically does not -have a relative buffer position. - -Template definitions introduce yet another syntactic symbol: - -@example -@group - - 1: ThingManager <int, - 2: Framework::Callback *, - 3: Mutex> framework_callbacks; - -@end group -@end example - -Here, line 1 is analyzed as a @code{topmost-intro}, but lines 2 and 3 -are both analyzed as @code{template-args-cont} lines. - -Here is another (totally contrived) example which illustrates how syntax -is assigned to various conditional constructs: -@example -@group - - 1: void spam( int index ) - 2: @{ - 3: for( int i=0; i<index; i++ ) - 4: @{ - 5: if( i == 10 ) - 6: @{ - 7: do_something_special(); - 8: @} - 9: else - 10: do_something( i ); - 11: @} - 12: do @{ - 13: another_thing( i-- ); - 14: @} - 15: while( i > 0 ); - 16: @} - - -@end group -@end example - -@noindent -Only the lines that illustrate new syntactic symbols will be discussed. - -@cindex substatement-open syntactic symbol -@cindex substatement-block-intro syntactic symbol -@cindex block-close syntactic symbol -Line 4 has a brace which opens a conditional's substatement block. It -is thus assigned @code{substatement-open} syntax, and since line 5 is -the first line in the substatement block, it is assigned -@code{substatement-block-intro} syntax. Lines 6 and 7 are assigned -similar syntax. Line 8 contains the brace that closes the inner -substatement block. It is given the syntax @code{block-close}, -as are lines 11 and 14. - -@cindex else-clause syntactic symbol -@cindex substatement syntactic symbol -Line 9 is a little different --- since it contains the keyword -@code{else} matching the @code{if} statement introduced on line 5, it is -given the @code{else-clause} syntax. Note also that line 10 is slightly -different too. Because @code{else} is considered a conditional -introducing keyword @footnote{The list of conditional keywords are (in -C, C++, Objective-C, and Java): @code{for}, @code{if}, @code{do}, -@code{else}, @code{while}, and @code{switch}. C++ and Java have two -additional conditional keywords: @code{try} and @code{catch}. Java also -has the @code{finally} and @code{synchronized} keywords.}, and because -the following substatement is not a brace block, line 10 is assigned the -@code{substatement} syntax. - -@cindex do-while-closure syntactic symbol -One other difference is seen on line 15. The @code{while} construct -that closes a @code{do} conditional is given the special syntax -@code{do-while-closure} if it appears on a line by itself. Note that if -the @code{while} appeared on the same line as the preceding close brace, -that line would have been assigned @code{block-close} syntax instead. - -Switch statements have their own set of syntactic symbols. Here's an -example: -@example -@group - - 1: void spam( enum Ingredient i ) - 2: @{ - 3: switch( i ) @{ - 4: case Ham: - 5: be_a_pig(); - 6: break; - 7: case Salt: - 8: drink_some_water(); - 9: break; - 10: default: - 11: @{ - 12: what_is_it(); - 13: break; - 14: @} - 15: @} - 14: @} - -@end group -@end example - -@cindex case-label syntactic symbol -@cindex statement-case-intro syntactic symbol -@cindex statement-case-open syntactic symbol -Here, lines 4, 7, and 10 are all assigned @code{case-label} syntax, -while lines 5 and 8 are assigned @code{statement-case-intro}. Line 11 -is treated slightly differently since it contains a brace that opens a -block --- it is given @code{statement-case-open} syntax. - -@cindex brace lists -There are a set of syntactic symbols that are used to recognize -constructs inside of brace lists. A brace list is defined as an -@code{enum} or aggregate initializer list, such as might statically -initialize an array of structs. For example: -@example -@group - - 1: static char* ingredients[] = - 2: @{ - 3: "Ham", - 4: "Salt", - 5: NULL - 6: @} - -@end group -@end example - -@cindex brace-list-open syntactic symbol -@cindex brace-list-intro syntactic symbol -@cindex brace-list-close syntactic symbol -@cindex brace-list-entry syntactic symbol -Following convention, line 2 in this example is assigned -@code{brace-list-open} syntax, and line 3 is assigned -@code{brace-list-intro} syntax. Likewise, line 6 is assigned -@code{brace-list-close} syntax. Lines 4 and 5 however, are assigned -@code{brace-list-entry} syntax, as would all subsequent lines in this -initializer list. - -External language definition blocks also have their own syntactic -symbols. In this example: -@example -@group - - 1: extern "C" - 2: @{ - 3: int thing_one( int ); - 4: int thing_two( double ); - 5: @} - -@end group -@end example - -@cindex extern-lang-open syntactic symbol -@cindex extern-lang-close syntactic symbol -@cindex inextern-lang syntactic symbol -@cindex inclass syntactic symbol -@noindent -line 2 is given the @code{extern-lang-open} syntax while line 5 is given -the @code{extern-lang-close} syntax. The analysis for line 3 yields: -@code{((inextern-lang) (topmost-intro . 14))}, where -@code{inextern-lang} is a modifier similar in purpose to @code{inclass}. - -A number of syntactic symbols are associated with parenthesis lists, -a.k.a argument lists, as found in function declarations and function -calls. This example illustrates these: -@example -@group - - 1: void a_function( int line1, - 2: int line2 ); - 3: - 4: void a_longer_function( - 5: int line1, - 6: int line2 - 7: ); - 8: - 9: void call_them( int line1, int line2 ) - 10: @{ - 11: a_function( - 12: line1, - 13: line2 - 14: ); - 15: - 16: a_longer_function( line1, - 17: line2 ); - 18: @} - -@end group -@end example - -@cindex arglist-intro syntactic symbol -@cindex arglist-close syntactic symbol -Lines 5 and 12 are assigned @code{arglist-intro} syntax since they are -the first line following the open parenthesis, and lines 7 and 14 are -assigned @code{arglist-close} syntax since they contain the parenthesis -that closes the argument list. - -@cindex arglist-cont-nonempty syntactic symbol -@cindex arglist-cont syntactic symbol -Lines that continue argument lists can be assigned one of two syntactic -symbols. For example, Lines 2 and 17 -are assigned @code{arglist-cont-nonempty} syntax. What this means -is that they continue an argument list, but that the line containing the -parenthesis that opens the list is @emph{not empty} following the open -parenthesis. Contrast this against lines 6 and 13 which are assigned -@code{arglist-cont} syntax. This is because the parenthesis that opens -their argument lists is the last character on that line. - -Note that there is no @code{arglist-open} syntax. This is because any -parenthesis that opens an argument list, appearing on a separate line, -is assigned the @code{statement-cont} syntax instead. - -A few miscellaneous syntactic symbols that haven't been previously -covered are illustrated by this C++ example: -@example -@group - - 1: void Bass::play( int volume ) - 2: const - 3: @{ - 4: /* this line starts a multi-line - 5: * comment. This line should get `c' syntax */ - 6: - 7: char* a_multiline_string = "This line starts a multi-line \ - 8: string. This line should get `string' syntax."; - 9: - 10: note: - 11: @{ - 12: #ifdef LOCK - 13: Lock acquire(); - 14: #endif // LOCK - 15: slap_pop(); - 16: cout << "I played " - 17: << "a note\n"; - 18: @} - 19: @} - -@end group -@end example - -@cindex modifier syntactic symbol -The lines to note in this example include: - -@itemize @bullet - -@cindex func-decl-cont syntactic symbol -@item -line 2, assigned the @code{func-decl-cont} syntax; - -@cindex comment-intro syntactic symbol -@item -line 4, assigned both @code{defun-block-intro} @emph{and} -@code{comment-intro} syntax; - -@cindex c syntactic symbol -@item -line 5, assigned @code{c} syntax; - -@item -@cindex syntactic whitespace -line 6 which, even though it contains nothing but whitespace, is -assigned @code{defun-block-intro}. Note that the appearance of the -comment on lines 4 and 5 do not cause line 6 to be assigned -@code{statement} syntax because comments are considered to be -@dfn{syntactic whitespace}, which are ignored when analyzing -code; - -@cindex string syntactic symbol -@item -line 8, assigned @code{string} syntax; - -@cindex label syntactic symbol -@item -line 10, assigned @code{label} syntax; - -@cindex block-open syntactic symbol -@item -line 11, assigned @code{block-open} syntax; - -@cindex cpp-macro syntactic symbol -@item -lines 12 and 14, assigned @code{cpp-macro} syntax; - -@cindex stream-op syntactic symbol -@item -line 17, assigned @code{stream-op} syntax. - -@end itemize - -In Objective-C buffers, there are three additional syntactic symbols -assigned to various message calling constructs. Here's an example -illustrating these: -@example -@group - - 1: - (void)setDelegate:anObject - 2: withStuff:stuff - 3: @{ - 4: [delegate masterWillRebind:self - 5: toDelegate:anObject - 6: withExtraStuff:stuff]; - 7: @} - -@end group -@end example - -@cindex objc-method-intro syntactic symbol -@cindex objc-method-args-cont syntactic symbol -@cindex objc-method-call-cont syntactic symbol -Here, line 1 is assigned @code{objc-method-intro} syntax, and line 2 is -assigned @code{objc-method-args-cont} syntax. Lines 5 and 6 are both -assigned @code{objc-method-call-cont} syntax. - -@cindex knr-argdecl-intro -@cindex knr-argdecl -Two other syntactic symbols can appear in old style, non-prototyped C -code @footnote{a.k.a. K&R C, or Kernighan & Ritchie C}: -@example -@group - - 1: int add_three_integers(a, b, c) - 2: int a; - 3: int b; - 4: int c; - 5: @{ - 6: return a + b + c; - 7: @} - -@end group -@end example - -Here, line 2 is the first line in an argument declaration list and so is -given the @code{knr-argdecl-intro} syntactic symbol. Subsequent lines -(i.e. lines 3 and 4 in this example), are given @code{knr-argdecl} -syntax. - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@node Performance Issues, Frequently Asked Questions, Syntactic Symbols, Top -@comment node-name, next, previous,up - -@chapter Performance Issues -@cindex Performance Issues -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -C and its derivative languages are highly complex creatures. Often, -ambiguous code situations arise that require @ccmode{} to scan -large portions of the buffer to determine syntactic context. Such -pathological code@footnote{such as the output of @code{lex(1)}!} -can cause @ccmode{} to perform fairly badly. -This section identifies some of the coding styles to watch out for, and -suggests some workarounds that you can use to improve performance. - -Because @ccmode{} has to scan the buffer backwards from the current -insertion point, and because C's syntax is fairly difficult to parse in -the backwards direction, @ccmode{} often tries to find the nearest -position higher up in the buffer from which to begin a forward scan. -The farther this position is from the current insertion point, the -slower the mode gets. Some coding styles can even force @ccmode{} -to scan from the beginning of the buffer for every line of code! - -@findex beginning-of-defun -@findex defun-prompt-regexp -One of the simplest things you can do to reduce scan time, is make sure -any brace that opens a top-level block construct always appears in the -leftmost column. This is actually an Emacs constraint, as embodied in -the @code{beginning-of-defun} function which @ccmode{} uses -heavily. If you insist on hanging top-level open braces on the right -side of the line, then you should set the variable -@code{defun-prompt-regexp} to something reasonable @footnote{Note that -this variable is only defined in Emacs 19.}, however that ``something -reasonable'' is difficult to define, so @ccmode{} doesn't do it -for you. - -@vindex c-Java-defun-prompt-regexp -@vindex Java-defun-prompt-regexp (c-) -A special note about @code{defun-prompt-regexp} in Java mode: while much -of the early sample Java code seems to encourage a style where the brace -that opens a class is hung on the right side of the line, this is not a -good style to pursue in Emacs. @ccmode{} comes with a variable -@code{c-Java-defun-prompt-regexp} which tries to define a regular -expression usable for this style, but there are problems with it. In -some cases it can cause @code{beginning-of-defun} to hang@footnote{This -has been observed in Emacs 19.34 and XEmacs 19.15.}. For this reason, -it is not used by default, but if you feel adventurous, you can set -@code{defun-prompt-regexp} to it in your mode hook. In any event, -setting and rely on @code{defun-prompt-regexp} will definitely slow -things down! - -You will probably notice pathological behavior from @ccmode{} when -working in files containing large amounts of cpp macros. This is -because Emacs cannot be made to quickly skip backwards over these lines. - -@vindex c-recognize-knr-p -@vindex recognize-knr-p (c-) -Previous versions of @ccmode{} had potential performance problems -when recognizing K&R style function argument declarations. This was -because there are ambiguities in the C syntax when K&R style argument -lists are used@footnote{It is hard to distinguish them from top-level -declarations.}. @ccmode{} has adopted BOCM's convention for -limiting the search: it assumes that argdecls are indented at least one -space, and that the function headers are not indented at all. With -current versions of @ccmode{}, user customization of -@code{c-recognize-knr-p} is deprecated. Just don't put argdecls in -column zero! - -@cindex @file{cc-lobotomy.el} file -@vindex cc-lobotomy-pith-list -You might want to investigate the speed-ups contained in the -file @file{cc-lobotomy.el}, which comes as part of the @ccmode{} -distribution, but is completely unsupported. -As mentioned previous, @ccmode{} always trades accuracy for speed, -however it is recognized that sometimes you need speed and can sacrifice -some accuracy in indentation. The file @file{cc-lobotomy.el} contains -hacks that will ``dumb down'' @ccmode{} in some specific ways, making -that trade-off of speed for accuracy. I won't go into details of its -use here; you should read the comments at the top of the file, and look -at the variable @code{cc-lobotomy-pith-list} for details. - - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@node Frequently Asked Questions, Getting the latest CC Mode release, Performance Issues, Top -@comment node-name, next, previous,up - -@chapter Frequently Asked Questions -@cindex Frequently Asked Questions -@comment FAQ -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -@kindex C-x h -@kindex ESC C-\ -@kindex ESC C-x -@kindex C-c C-q -@kindex ESC C-q -@kindex ESC C-u -@kindex RET -@kindex C-j -@findex newline-and-indent -@quotation - -@strong{Q.} @emph{How do I re-indent the whole file?} - -@strong{A.} Visit the file and hit @kbd{C-x h} to mark the whole -buffer. Then hit @kbd{@key{ESC} C-\}. -@sp 1 - -@strong{Q.} @emph{How do I re-indent the entire function? -@kbd{@key{ESC} C-x} doesn't work.} - -@strong{A.} @kbd{@key{ESC} C-x} is reserved for future Emacs use. -To re-indent the entire function hit @kbd{C-c C-q}. -@sp 1 - -@strong{Q.} @emph{How do I re-indent the current block?} - -@strong{A.} First move to the brace which opens the block with -@kbd{@key{ESC} C-u}, then re-indent that expression with -@kbd{@key{ESC} C-q}. -@sp 1 - -@strong{Q.} @emph{Why doesn't the @key{RET} key indent the line to -where the new text should go after inserting the newline?} - -@strong{A.} Emacs' convention is that @key{RET} just adds a newline, -and that @key{C-j} adds a newline and indents it. You can make -@key{RET} do this too by adding this to your -@code{c-mode-common-hook} (see the sample @file{.emacs} file -@ref{Sample .emacs File}): -@example - -(define-key c-mode-base-map "\C-m" 'newline-and-indent) - -@end example - -This is a very common question. If you want this to be the default -behavior, don't lobby me, lobby RMS! @code{:-)} -@sp 1 - -@strong{Q.} @emph{I put @code{(c-set-offset 'substatement-open 0)} -in my @file{.emacs} file but I get an error saying that -@code{c-set-offset}'s function definition is void.} - -@strong{A.} This means that @ccmode{} wasn't loaded into your -Emacs session by the time the @code{c-set-offset} call was reached, -mostly likely because @ccmode{} is being autoloaded. Instead -of putting the @code{c-set-offset} line in your top-level -@file{.emacs} file, put it in your @code{c-mode-common-hook}, or -simply add the following to the top of your @file{.emacs} file: -@example - -(require 'cc-mode) - -@end example - -See the sample @file{.emacs} file @ref{Sample .emacs File} for -details. - -@sp 1 -@strong{Q.} @emph{How do I make strings, comments, keywords, and other -constructs appear in different colors, or in bold face, etc.?} - -@strong{A.} ``Syntax Colorization'' is a standard Emacs feature, -controlled by @code{font-lock-mode}. It is not part of @ccmode{}. - -@end quotation - - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@node Getting the latest CC Mode release, Sample .emacs File, Frequently Asked Questions, Top -@comment node-name, next, previous,up - -@chapter Getting the latest CC Mode release -@cindex Getting the latest CC Mode release -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -@ccmode{} is now standard with later versions Emacs 19 and XEmacs 19. -It is also the standard for XEmacs 20, and will be the standard for -Emacs 20 (unreleased as of this writing). You would typically just use -the version that comes with your X/Emacs. These may be slightly out of -date due to release schedule skew, so you should always check the -canonical site for the latest version. - -@example -@group - - World Wide Web: - - @code{http://www.python.org/ftp/emacs/} - - Anonymous FTP: - - @code{ftp://ftp.python.org/pub/emacs/} - -@end group -@end example - -There are many files under these directories; you can pick up the entire -distribution (named @code{cc-mode.tar.gz}; a gzip'd tar file), or any of -the individual files, including PostScript documentation. - -If you do not have World Wide Web, or anonymous ftp access, you can get -the distribution through an anonymous ftp-to-mail gateway, such as the -one run by DEC at: -@example - -@code{ftpmail@@decwrl.dec.com} - -@end example -To get @ccmode{} via email, send the following message in the body of -your mail to that address: -@example - -reply <a valid net address back to you> -connect ftp.python.org -binary -uuencode -chdir pub/emacs -get cc-mode.tar.gz - -@end example -@noindent -or just send the message "help" for more information on ftpmail. -Response times will vary with the number of requests in the queue. I am -in no way connected to this service, so I make no claims or guarantees -about its availability! - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@node Sample .emacs File, Limitations and Known Bugs, Getting the latest CC Mode release, Top -@comment node-name, next, previous,up - -@chapter Sample .emacs file -@cindex Sample .emacs file -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -@example -;; Here's a sample .emacs file that might help you along the way. Just -;; copy this region and paste it into your .emacs file. You may want to -;; change some of the actual values. - -(defconst my-c-style - '((c-tab-always-indent . t) - (c-comment-only-line-offset . 4) - (c-hanging-braces-alist . ((substatement-open after) - (brace-list-open))) - (c-hanging-colons-alist . ((member-init-intro before) - (inher-intro) - (case-label after) - (label after) - (access-label after))) - (c-cleanup-list . (scope-operator - empty-defun-braces - defun-close-semi)) - (c-offsets-alist . ((arglist-close . c-lineup-arglist) - (substatement-open . 0) - (case-label . 4) - (block-open . 0) - (knr-argdecl-intro . -))) - (c-echo-syntactic-information-p . t) - ) - "My C Programming Style") - -;; Customizations for all of c-mode, c++-mode, and objc-mode -(defun my-c-mode-common-hook () - ;; add my personal style and set it for the current buffer - (c-add-style "PERSONAL" my-c-style t) - ;; offset customizations not in my-c-style - (c-set-offset 'member-init-intro '++) - ;; other customizations - (setq tab-width 8 - ;; this will make sure spaces are used instead of tabs - indent-tabs-mode nil) - ;; we like auto-newline and hungry-delete - (c-toggle-auto-hungry-state 1) - ;; keybindings for all supported languages. We can put these in - ;; c-mode-base-map because c-mode-map, c++-mode-map, objc-mode-map, - ;; java-mode-map, and idl-mode-map inherit from it. - (define-key c-mode-base-map "\C-m" 'newline-and-indent) - ) - -(add-hook 'c-mode-common-hook 'my-c-mode-common-hook) -@end example - -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@node Limitations and Known Bugs, Mailing Lists and Submitting Bug Reports, Sample .emacs File, Top -@comment node-name, next, previous,up -@chapter Limitations and Known Bugs -@cindex Limitations and Known Bugs -@comment * Limitations and Known Bugs -@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -@itemize @bullet -@item -Multi-line macros are not handled properly. - -@item -Re-indenting large regions or expressions can be slow. - -@item -Add-on fill packages may not work as well as @ccmode{}'s built-in -filling routines. I no longer recommend you use @code{filladapt} to -fill comments. - -@cindex c-indent-exp -@cindex indent-exp (c-) -@item -@code{c-indent-exp} has not been fully optimized. It essentially -equivalent to hitting @kbd{TAB} (@code{c-indent-command}) on every -line. Some information is cached from line to line, but such caching -invariable causes inaccuracies in analysis in some bizarre situations. - -@end itemize - -@c !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@node Mailing Lists and Submitting Bug Reports, Concept Index, Limitations and Known Bugs, Top -@comment node-name, next, previous,up -@chapter Mailing Lists and Submitting Bug Reports -@cindex Mailing Lists and Submitting Bug Reports -@c !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -@kindex C-c C-b -@findex c-submit-bug-report -@findex submit-bug-report (c-) -@cindex beta testers mailing list -@cindex announcement mailing list -To report bugs, use the @kbd{C-c C-b} (@code{c-submit-bug-report}) -command. This provides vital information I need to reproduce your -problem. Make sure you include a concise, but complete code example. -Please try to boil your example down to just the essential code needed -to reproduce the problem, and include an exact recipe of steps needed to -expose the bug. Be especially sure to include any code that appears -@emph{before} your bug example, if you think it might affect my ability -to reproduce it. - -Bug reports are now sent to the following email addresses: -@code{cc-mode-help@@python.org} and -@code{bug-gnu-emacs@@prep.ai.mit.edu}; the latter is mirrored on the -Usenet newsgroup @code{gnu.emacs.bug}. You can send other questions and -suggestions (kudos? @code{;-)} to @code{cc-mode-help@@python.org}, or -@code{help-gnu-emacs@@prep.ai.mit.edu} which is mirrored on newsgroup -@code{gnu.emacs.help}. - -If you want to get announcements of new CC Mode releases, send the -word @emph{subscribe} in the body of a message to -@code{cc-mode-announce-request@@python.org}. Announcements will also be -posted to the Usenet newsgroups @code{gnu.emacs.sources}, -@code{comp.emacs}, @code{comp.emacs.xemacs}, and possibly some of the -language oriented newsgroups. Note that the -@code{cc-mode-victims@@python.org} mailing list was recently -decommissioned. - -@c !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@node Concept Index, Command Index, Mailing Lists and Submitting Bug Reports, Top -@comment node-name, next, previous, up -@unnumbered Concept Index -@c !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -@printindex cp - - -@c !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@node Command Index, Key Index, Concept Index, Top -@comment node-name, next, previous, up -@unnumbered Command Index -@c !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -@ifinfo - -@end ifinfo -Since all @ccmode{} commands are prepended with the string -@samp{c-}, each appears under its @code{c-@var{<thing>}} name and its -@code{@var{<thing>} (c-)} name. -@iftex -@sp 2 -@end iftex -@printindex fn - - -@c !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@node Key Index, Variable Index, Command Index, Top -@comment node-name, next, previous, up -@unnumbered Key Index -@c !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -@printindex ky - - -@c !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@node Variable Index, , Key Index, Top -@comment node-name, next, previous, up -@unnumbered Variable Index -@c !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -@ifinfo - -@end ifinfo -Since all @ccmode{} variables are prepended with the string -@samp{c-}, each appears under its @code{c-@var{<thing>}} name and its -@code{@var{<thing>} (c-)} name. -@iftex -@sp 2 -@end iftex -@printindex vr -@page -@summarycontents -@contents -@bye
--- a/man/hyperbole.texi Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,6324 +0,0 @@ -\input texinfo -@c -@c FILE: hyperbole.texi -@c SUMMARY: The Hyperbole User Manual for V4 -@c USAGE: Hardcopy man from TeX; Info man from `texinfo-format-buffer'. -@c -@c AUTHOR: Bob Weiner -@c -@c ORG: InfoDock Associates. We sell corporate support and -@c development contracts for InfoDock, Emacs and XEmacs. -@c E-mail: <info@infodock.com> Web: http://www.infodock.com -@c Tel: +1 408-243-3300 -@c -@c ORIG-DATE: 6-Nov-91 at 11:18:03 -@c LAST-MOD: 17-Mar-97 at 21:36:15 by Bob Weiner - -@c %**start of header (This is for running Texinfo on a region.) -@setfilename ../info/hyperbole.info -@settitle Hyperbole User Manual -@c %**end of header (This is for running Texinfo on a region.) -@synindex vr fn - -@iftex -@finalout -@end iftex - -@titlepage -@sp 4 -@center @titlefont{Hyperbole Manual} -@sp 1 -@center Everyday Information Management -@sp 5 -@center Bob Weiner -@center InfoDock Associates -@sp 1 -@center E-mail: <hyperbole@@infodock.com> (This is a mailing list.) -@sp 2 -@center Edition 4.023 -@sp 2 -@center March 17, 1997 - -@page -@vskip 0pt plus 1filll -Copyright @copyright{} 1991, 1992, 1993, 1994, 1995, 1996, 1997 Free Software Foundation, Inc. - -All trademarks referenced herein are trademarks of their respective -holders. - -InfoDock Associates, the developer of Hyperbole and InfoDock (an industrial -quality turn-key version of XEmacs), donates its work on Hyperbole to the -Free Software Foundation and makes it freely available for worldwide -distribution. - -InfoDock Associates is a commercial firm dedicated to radical productivity -improvement in technical environments, whether in software development or -other knowledge intensive disciplines. Our initial offerings include high -quality commercial support, training, books and custom package development -for InfoDock, XEmacs or GNU Emacs on a variety of platforms. - -@example - E-mail: <info@@infodock.com> - Web: http://www.infodock.com - Tel: +1 408-243-3300 -@end example - -@setchapternewpage odd -@end titlepage -@page - -@node Top, Introduction, (dir), (dir) -@c node-name, next, previous, up -@unnumbered Preface - -@ifinfo -@noindent -Copyright @copyright{} 1991, 1992, 1993, 1994, 1995, 1996, 1997 Free Software Foundation, Inc. - -All trademarks referenced herein are trademarks of their respective holders. - -InfoDock Associates, the developer of Hyperbole and InfoDock (an industrial -quality turn-key version of XEmacs), donates its work on Hyperbole to the -Free Software Foundation and makes it freely available for worldwide -distribution. - -InfoDock Associates is a commercial firm dedicated to radical productivity -improvement in technical environments, whether in software development or -other knowledge intensive disciplines. Our initial offerings include high -quality commercial support, training, books and custom package development -for InfoDock, XEmacs or GNU Emacs on a variety of platforms. - -@example - E-mail: <info@@infodock.com> - Web: http://www.infodock.com - Tel: +1 408-243-3300 -@end example - -@end ifinfo -This edition of the Hyperbole User Manual is for use with any version -4.02 or greater of Hyperbole. - -Hyperbole is free software; you can use it, redistribute it and/or modify it -without fee 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. - -Hyperbole is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR -A PARTICULAR PURPOSE. See the GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU Emacs or XEmacs; see the file COPYING. If not, write to -the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -@cindex credits -@cindex InfoDock, obtaining -@cindex Hyperbole, obtaining -@cindex anonymous ftp -Hyperbole was designed and written by Bob Weiner of InfoDock Associates. -Motorola, Inc@. helped fund early work. For information on how to -obtain Hyperbole, @ref{Obtaining}. - -This manual explains user operation and summarizes basic developer -facilities of Hyperbole. This major release of Hyperbole concentrates -on providing convenient access to information and control over its -display. The Hyperbole outliner emphasizes flexible views and structure -manipulation within bodies of information. - -@cindex Hyperbole -@cindex hypertext -@cindex Emacs Lisp -@cindex Emacs 19 -@cindex Epoch -@cindex XEmacs -Hyperbole (pronounced Hi-per-bo-lee) is an open, efficient, programmable -information management and hypertext system. It is intended for -everyday work on any UNIX platform supported by GNU Emacs. It works -well with the versions of Emacs that support multiple X or NEXTSTEP -windows: Emacs 19, XEmacs and Epoch. Hyperbole allows hypertext buttons -to be embedded within unstructured and structured files, mail messages -and news articles. It offers intuitive mouse-based control of -information display within multiple windows. It also provides -point-and-click access to Info manuals, ftp archives, Wide-Area -Information Servers (WAIS), and the World-Wide Web (WWW) hypertext -system through encapsulations of software that support these protocols. - -@noindent -Hyperbole consists of four parts: - -@table @bullet -@item Info Management -an interactive information management interface, including a powerful -rolodex, which anyone can use. It is easy to pick up and use since it -introduces only a few new mechanisms and provides user-level facilities -through a menu interface, which you control from the keyboard or the -mouse; - -@item Hypertext Outliner -an outliner with multi-level autonumbering and permanent ids attached to -each outline node for use as hypertext link anchors, plus flexible view -specifications that can be embedded within links or used interactively; - -@item Button Types -a set of hyper-button types that provides core hypertext and other -behaviors. Users can make simple changes to button types and those -familiar with Emacs Lisp can quickly prototype and deliver new types; - -@item Programming Library -a set of programming library classes for system developers who want to -integrate Hyperbole with another user interface or as a back-end to a -distinct system. (All of Hyperbole is written in Emacs Lisp for ease of -modification. Although Hyperbole was initially designed as a prototype, -it has been engineered for real-world usage and is well structured.) -@end table - -@cindex GNU Emacs -@kindex C-h t -@vindex file, DEMO -@cindex demonstration -@cindex button demo -Hyperbole may be used simply for browsing through documents -pre-configured with Hyperbole buttons, in which case, one can safely -ignore most of the information in this manual. The @file{DEMO} file -included in the Hyperbole distribution demonstrates many of Hyperbole's -standard facilities. It offers a much less technical introduction for -Hyperbole users by providing good examples of how buttons may be -used and an introduction to the outliner. - -So if this manual is too detailed for your taste, you can skip it -entirely and just jump right into the demonstration, normally by typing -@{@kbd{C-h h d d}@}, assuming Hyperbole has already been installed at -your site. Otherwise, @ref{Installation}, for Hyperbole installation -and configuration information. - -Many users, however, will want to do more than browse with Hyperbole, -e.g@. create their own buttons. The standard Hyperbole button editing -user interface is GNU Emacs-based, so a basic familiarity with the Emacs -editing model is useful. The material covered in the GNU Emacs -tutorial, normally bound to @{@kbd{C-h t}@} within Emacs, is more than -sufficient as background. If some GNU Emacs terms are unfamiliar to -you, @ref{Glossary, Emacs Glossary,, emacs, the GNU Emacs Manual}. - -Before we delve into Hyperbole, a number of acknowledgments are in -order. Peter Wegner has encouraged the growth in this work. Morris -Moore has helped me pursue my own research visions and kept me striving -for excellence. Doug Engelbart has shown me the bigger picture and -continues to be an inspiration. His work provides a model from which I -am beginning to draw. Kellie Clark and I jointly designed the Hyperbole -outliner while sharing a life together. Chris Nuzum, as a user of -Hyperbole, has helped demonstrate its power since its inception; he -knows how to work with Hyperbole far better than I. - -@menu -* Introduction:: -* Installation:: -* Buttons:: -* Smart Keys:: -* Menus:: -* Entering Arguments:: -* Outliner:: -* Rolodex:: -* Window Configurations:: -* Developing with Hyperbole:: -* Glossary:: -* Smart Key Reference:: -* Outliner Keys:: -* Suggestion or Bug Reporting:: -* Questions and Answers:: -* Future Work:: -* References:: -* Key Binding Index:: -* Code and File Index:: -* Concept Index:: - - --- The Detailed Node Listing --- - -Introduction - -* Hyperbole Overview:: -* Mail Lists:: -* Manual Overview:: - -Installation - -* Obtaining:: -* Building:: -* Installing:: -* Configuring:: - -Configuring - -* Internal Viewers:: -* External Viewers:: -* Link Variable Substitution:: -* Button Colors:: - -Buttons - -* Explicit Buttons:: -* Global Buttons:: -* Implicit Buttons:: -* Action Types:: -* Button Type Precedence:: -* Button Files:: -* Utilizing Explicit Buttons:: - -Utilizing Explicit Buttons - -* Creation:: -* Renaming:: -* Deletion:: -* Modification:: -* Location:: -* Buttons in Mail:: -* Buttons in News:: - -Creation - -* By Dragging:: Creation Via Action Key Drags -* By Menu:: Creation Via Menus - -Outliner - -* Menu Commands:: -* Creating Outlines:: -* Autonumbering:: -* Idstamps:: -* Editing:: -* Viewing:: -* Links:: -* Cell Attributes:: -* Outliner History:: - -Editing - -* Adding and Killing:: -* Moving Around:: -* Relocating and Copying:: -* Filling:: -* Transposing:: -* Splitting and Appending:: -* Inserting and Importing:: - -Viewing - -* Hiding and Showing:: -* View Specs:: - -Rolodex - -* Rolo Concepts:: -* Rolo Menu:: -* Rolo Keys:: -* Rolo Settings:: - -Developing with Hyperbole - -* Hook Variables:: -* Creating Types:: -* Explicit Button Technicalities:: -* Encapsulating Systems:: -* Embedding Hyperbole:: - -Creating Types - -* Action Type Creation:: -* Implicit Button Types:: - -Explicit Button Technicalities - -* Button Label Normalization:: -* Operational and Storage Formats:: -* Programmatic Button Creation:: - -Smart Key Reference - -* Smart Mouse Keys:: -* Smart Keyboard Keys:: -@end menu - -@node Introduction, Installation, Top, Top -@chapter Introduction - -This chapter describes what Hyperbole is, lists some of its potential -applications, explains how to subscribe to its mail lists, and then -summarizes the structure of the rest of the manual. - -@menu -* Hyperbole Overview:: -* Mail Lists:: -* Manual Overview:: -@end menu - -@node Hyperbole Overview, Mail Lists, Introduction, Introduction -@section Hyperbole Overview -@cindex button -A Hyperbole user works with @emph{buttons} embedded within textual -documents; he may create, modify, move or delete buttons. Each button -performs a specific action, such as linking to a file or executing a -shell command. - -@cindex button, explicit -@cindex button, global -@cindex button, implicit -@cindex button category -@cindex explicit button -@cindex global button -@cindex implicit button -There are three categories of Hyperbole buttons: -@table @dfn -@item explicit buttons -created by Hyperbole, accessible from within a single document; - -@item global buttons -created by Hyperbole, accessible anywhere within a user's network of -documents; - -@item implicit buttons -created and managed by other programs or embedded within the structure -of a document, accessible from within a single document. Hyperbole -recognizes implicit buttons by contextual patterns given in their type -specifications (explained later). -@end table - -Explicit Hyperbole buttons may be embedded within any type of text file. -Implicit buttons may be recognized anywhere within a text file, -depending on the implicit button types that are available. All global -buttons are stored in a single location and activated by entering their -names, rather than by direct selection, the means used to activate -explicit and implicit buttons. - -@noindent -To summarize: - -@example -Button Category Active Within Activation Means Managed By -======================================================================== -Explicit a single document direct selection Hyperbole -Global any document specifying its name Hyperbole -Implicit a matching context direct selection other tools -======================================================================== -@end example - -@cindex terminal use -Hyperbole buttons may be clicked upon with a mouse to activate them or -to describe their actions. Thus, a user can always check how a button -will act before activating it. Buttons may also be activated from a -keyboard. (In fact, virtually all Hyperbole operations, including menu -usage, may be performed from any standard character terminal interface, -so one need not be anchored to a workstation all day). @xref{Smart -Keys}. - -@cindex Hyperbole features -Hyperbole does not enforce any particular hypertext or information -management model, but instead allows you to organize your information in -large or small chunks as you see fit. The Hyperbole outliner organizes -information hierarchies which may also contain links to external -information sources. - -@noindent -Some of Hyperbole's most important features include: - -@itemize @bullet -@item -Buttons may link to information or may execute procedures, such as -starting or communicating with external programs; - -@item -One simply drags between a button source location and a link destination -to create or to modify a link button. The same result can be achieved -from the keyboard. - -@item -Buttons may be embedded within electronic mail messages; - -@item -Outlines allow rapid browsing, editing and movement of chunks of -information organized into trees (hierarchies); - -@item -Other hypertext and information retrieval systems may be encapsulated -under a Hyperbole user interface (a number of samples are provided). -@end itemize - -@cindex Hyperbole applications -@noindent -Typical Hyperbole applications include: - -@table @strong -@item personal information management -Overlapping link paths provide a variety of views into an information space. -A search facility locates buttons in context and permits quick selection. - -@item documentation and code browsing -Cross-references may be embedded within documentation. One can add a -point-and-click interface to existing documentation, link code with -associated design documents, or jump to the definition of an identifier -by selecting its name within code or documentation. - -@item brainstorming -The Hyperbole outliner, @xref{Outliner}, is an -effective tool for capturing ideas and then quickly reorganizing them in -a meaningful way. Links to related ideas are easy to create, -eliminating the need to copy and paste information into a single place. - -@item help/training systems -Tutorials containing buttons can show students how things work while -explaining the concepts, e.g@. an introduction to local commands. This -technique can be much more effective than written documentation alone. - -@item archive managers -Programs that manage archives from incoming information streams may be -supplemented by having them add topic-based buttons that link to the -archive holdings. Users can then search and create their own links to -archive entries. -@end table - -@node Mail Lists, Manual Overview, Hyperbole Overview, Introduction -@section Mail Lists - -If you maintain or use Hyperbole, you should consider joining one of the -two Hyperbole mailing lists. @xref{Menus}, and the description -of the the Msg/ menu item, for a convenient means of joining and mailing -to these lists. - -@cindex mail lists -@cindex e-mail -There are several Hyperbole-related mail addresses. Learn what each is -for before you mail to any of them. - -@cindex mail list requests -@cindex joining a mail list -@cindex subscribing to a mail list -@cindex unsubscribing from a mail list -@format -<hyperbole-request@@infodock.com> -<hyperbole-announce-request@@infodock.com> -@end format - -@display -@strong{All} mail concerning administration of the Hyperbole mailing -lists should be sent to the appropriate one of these addresses. That -includes addition, change, or deletion requests. Don't consider sending -such a request to a Hyperbole mail list or people will wonder why you -don't know that all Internet mail lists have a -request address for -administrative requests.@refill - -Use the following formats in the @emph{body} of your message to execute requests, -where you substitute your own values for the <> delimited items and items -enclosed in [] are optional. - - subscribe <mail-list-name> [<your-email-address>] - or - unsubscribe <mail-list-name> [<your-email-address>] - -For example: - - To: hyperbole-request@@infodock.com - Subject: Used if a human happens to read your mail. - - subscribe hyperbole joe@@nowhere.gov - - To change your address, you must unsubscribe your old address with - once command and subscribe your new address with another command, though - you can embed multiple commands on separate lines within a single message. -@end display - -@noindent -There are two Hyperbole-related mail lists. Subscribe to one or the other, -not to both. - -@cindex hyperbole mail list -@format -<hyperbole@@infodock.com> -@end format - -@display -Mail list for discussion of all Hyperbole issues. Bug reports and -suggestions may also be sent here.@refill - -@cindex e-mail, effective communication -@cindex effective communication -Always use your Subject and/or Summary: lines to state the position that -your message takes on the topic that it addresses. - -For example, send: - - Subject: Basic bug in top-level minibuffer menu. - -rather than: - - Subject: Hyperbole bug. - -Statements end with periods, questions with question marks (typically), -and high energy, high impact declarations with exclamation points. This -simple rule makes all e-mail communication much easier for recipients to -handle appropriately.@refill - -@cindex Hyperbole version -@cindex Emacs version -@vindex emacs-version -If you ask a question, your subject line should end with a ?, -e.g@. "Subject: How can man page SEE ALSOs be made implicit buttons?" A -"Subject: Re: How can ..." then indicates an answer to the question. -Question messages should normally include your Hyperbole and Emacs -version numbers and clearly explain your problem and surrounding issues. -Otherwise, you will simply waste the time of those who may want to help -you. (Your top-level Hyperbole menu shows its version number and @{@kbd{M-x -emacs-version @key{RET}}@} gives the other.)@refill - -If you ask questions, you should consider adding to the discussion by -telling people the kinds of work you are doing or contemplating doing -with Hyperbole. In this way, the list will not be overwhelmed by -messages that ask for, but provide no information.@refill -@end display - -@cindex hyperbole-announce mail list -@format -<hyperbole-announce@@infodock.com> -@end format - -@display -Those who don't want to participate in the discussion but want to hear -about bug fixes and new releases of Hyperbole should subscribe to this -list. Anyone on the `hyperbole' list is automatically on this one too, -so there is no need to subscribe to this one in that case. This list is -for official fixes and announcements so don't send your own fixes here. -Send them to `hyperbole' instead. -@end display - - -@node Manual Overview, , Mail Lists, Introduction -@section Manual Overview - -Remember that the @file{DEMO} file included in the Hyperbole -distribution demonstrates many of Hyperbole's standard facilities, -(@pxref{Top, Preface}) for more details. - -@xref{Glossary}, for definitions of Hyperbole terms for quick -reference, so in some cases terms are not precisely defined within the -text. Be sure to reference the glossary if a term is unclear to you. -Although you need not have a keen understanding of all of these terms, a -quick scan of the Glossary should help throughout Hyperbole use. - -If you have a question, feature suggestion or bug report on Hyperbole, -follow the instructions given in @ref{Suggestion or Bug Reporting}. A few -commonly asked questions are answered in the manual, @ref{Questions and -Answers}. If you are interested in classic articles on hypertext, -@ref{References}. - -@xref{Installation}, for explanations of how to obtain, install, configure -and load Hyperbole for use. - -@xref{Buttons}, for an overview of Hyperbole buttons and how to use them. - -@xref{Smart Keys}, for an explanation of the innovative, -context-sensitive mouse and keyboard Action and Assist Keys offered by -Hyperbole. @xref{Smart Key Reference}, for a complete reference on what -the Action and Assist Keys do in each particular context that they -recognize. - -(Keep in mind as you read about how to use Hyperbole that in many cases, -it provides a number of overlapping interaction methods are provided to -support different work styles and hardware limitations. You need learn -only one with which you can become comfortable, in such instances.) - -@xref{Menus}, for summaries of Hyperbole menu commands and how to use -the minibuffer-based menus that work on dumb terminals. - -@xref{Entering Arguments}, for special support that Hyperbole provides for -entering arguments when prompted for them. - -@xref{Outliner}, for concept and usage information on the -autonumbered, hypertextual outliner. A full summary of the outliner -commands that are bound to keys may be found in @ref{Outliner Keys}. - -@xref{Rolodex}, for concept and usage information on the -rapid lookup, hierarchical, free text record management system included -with Hyperbole. - -@xref{Window Configurations}, for instructions on how to save and restore -the set of buffers and windows that appear with a frame. This feature -lets you switch among working contexts easily, even on a dumb terminal. -Such configurations only last throughout your current editor session. - -Developers comfortable with Emacs Lisp will want to continue on through -to, @ref{Developing with Hyperbole}. - -@xref{Future Work}, for future directions in Hyperbole's evolution. - - -@node Installation, Buttons, Introduction, Top -@chapter Installation - -@cindex installation -Hyperbole must be installed at your site before you can use it. The -following sections explain how to obtain, install and configure -Hyperbole for use. - -@vindex file, hsite.el -@cindex customization, init -If you want to customize the basic Hyperbole initialization sequence for -yourself rather than the users at your site, you should make a personal -copy of the @file{hsite.el} file, modify it the way you want, and then -load it. (If you are familiar with Emacs Lisp, @ref{Hook Variables}.) - -@menu -* Obtaining:: -* Building:: -* Installing:: -* Configuring:: -@end menu - -@node Obtaining, Building, Installation, Installation -@section Obtaining - -@cindex ftp -@cindex anonymous ftp -Hyperbole can be obtained via anonymous ftp on the Internet from: - -@file{ftp://ftp.xemacs.org/pub/infodock}. - -@cindex downloading Hyperbole -@cindex obtaining Hyperbole -@cindex Hyperbole, obtaining -@noindent -Here are detailed instructions for downloading and unpacking Hyperbole. - -Move to a directory below which you want the @file{hyperbole} directory to -be created. Unpacking the Hyperbole archive will create the -@file{hyperbole} directory and will place all of the files below it. - -@example - cd <LOCAL-EMACS-LISP-DIR> -@end example - -@noindent -Ftp to ftp.xemacs.org (Internet Host ID = 128.174.252.16): - -@example - prompt> ftp ftp.xemacs.org (If this doesn't work, try `ftp xemacs.org'.) -@end example - -@noindent -Login as @emph{anonymous} with your own @emph{<user-id>@@<site-name>} as -a password. - -@example - Name (ftp.xemacs.org): anonymous - 331 Guest login ok, send EMAIL address (e.g@. user@@host.domain) - as password. - Password: - 230 Guest login ok, access restrictions apply. -@end example - -@noindent -Move to the Hyperbole directory: - -@example - ftp> cd pub/xemacs/infodock -@end example - -@noindent -Set your transfer mode to binary: - -@example - ftp> bin - 200 Type set to I. -@end example - -@noindent -Turn off prompting: - -@example - ftp> prompt - Interactive mode off. -@end example - -@noindent -Retrieve just the Hyperbole archive and any diff-based patches (there may not -be any patches): - -@example - ftp> mget hyperbole* - ftp> mget hdiff* -@end example - -@noindent -Close the ftp connection: - -@example - ftp> quit - 221 Goodbye. -@end example - -@cindex gzcat -@cindex zcat -@cindex gunzip -@cindex tar archive -@cindex uncompressing archives -@cindex unpacking archives -@noindent -Unpack the tar archive using the GNU version of the @code{zcat} program, -sometimes called @code{gzcat} or the @code{gunzip} program: - -@example - zcat hyperbole*tar.gz | tar xvf - -or - gunzip hyperbole*tar.gz; tar xvf hyperbole*tar -@end example - -@noindent -Apply any patches you retrieved: - -@example - cd hyperbole; patch < <patch-file> -@end example - - -@node Building, Installing, Obtaining, Installation -@section Building - -@vindex file, Makefile -@vindex file, hsite.el -@cindex Hyperbole, building -@cindex building Hyperbole -The following explains how to Use the Hyperbole @file{Makefile} to -compile any needed code, to generate the @file{hsite.el} file used for -site-specific Hyperbole customization, and to produce printable -documentation. - -@vindex EMACS, environment variable -@cindex compiling Lisp -@cindex Lisp compilation -Edit the line near the top of @file{Makefile} that represents the emacs -version that you use, so that it corresponds to the emacs executable -name used on your system. Then immediatly below there, set the -@var{EMACS} variable to the variable name for the emacs that you will -use to compile the Hyperbole Lisp files. - -@vindex SITE-PRELOADS, environment variable -You may also have to set the @var{SITE-PRELOADS} variable defined further down -in the file; follow the instructions that precede the @var{SITE-PRELOADS =} -line. Make these changes now and save the @file{Makefile}. - -@cindex HYPERBOLE-DIR -The following instructions use the term @file{<HYPERBOLE-DIR>/} to refer -to your @file{hyperbole/} directory, so substitute your own value. - -@noindent -To install Hyperbole for use with InfoDock, XEmacs, GNU Emacs or Epoch, from -a shell: - -@example - cd <HYPERBOLE-DIR>; make -@end example - -@noindent -All of the .elc compiled Lisp files are already built for XEmacs and V19, so -this build will finish very quickly. If you really want to rebuild all of -the .elc files, use: - -@example - cd <HYPERBOLE-DIR>; make all-elc -@end example - -@cindex Postscript -@cindex manual, generating Postscript -@vindex file, man/hyperbole.ps -@noindent -To produce the Postscript version of the Hyperbole manual, you must have -the TeX formatter on your system: - -@example - cd <HYPERBOLE-DIR>; make ps -@end example - -@noindent -To install Hyperbole for use with GNU Emacs V18 or Epoch: - -@example - cd <HYPERBOLE-DIR>; make all-elc-v18 -@end example - -@noindent -This will produce a complete set of Emacs V18 .elc files. - - -@node Installing, Configuring, Building, Installation -@section Installing - -@cindex configuration -You may want to explore the Hyperbole configuration options before -installing it. @xref{Configuring}. If you just want to get up and -running quickly, however, there is no need to configure anything, just -follow these instructions to install Hyperbole. - -@cindex Hyperbole, initializing -@cindex initializing Hyperbole -@cindex installation -@cindex site initialization -@vindex file, hsite.el -@vindex file, ~/.emacs -Add the following lines to a site initialization file such as -@file{site-start.el} to set up so that all users have Hyperbole -loaded for them when they run Emacs. Otherwise, each user will have to -add these lines to his own @file{~/.emacs} initialization file. - -@cindex autoloading Hyperbole -@cindex Hyperbole, autoloading -@noindent -To autoload Hyperbole so that it loads only when needed: - -@vindex hyperb:dir -@vindex file, hversion.el -@vindex file, hyperbole.el -@lisp -(defvar hyperb:dir "<HYPERBOLE-DIR>/") - "Directory where the Hyperbole executable code is kept. -It must end with a directory separator character.") - -(load (expand-file-name "hversion" hyperb:dir)) -(load (expand-file-name "hyperbole" hyperb:dir)) -@end lisp - -@cindex loading Hyperbole -@cindex Hyperbole, loading -This establishes a few key bindings and sets up Hyperbole to -automatically load whenever you activate its menu. If you would rather -have the whole Hyperbole system loaded when you start up so that you can -always use the Smart Keys and other facilities, add the additional line: - -@lisp -(require 'hsite) -@end lisp - -If you use mouse keys, be sure to add the above lines after any setup of -mouse key bindings, to ensure that Hyperbole's mouse keys are properly -initialized. @xref{Smart Keys}, for further details. If you use any -Hyperbole mail or news support, @ref{Buttons in Mail}, be certain to -perform all of your personal mail/news initializations before the point -at which you load Hyperbole. Otherwise, the mail/news support may not -be configured properly. For example, if you use the Emacs add-on -Supercite package, its setup should come before Hyperbole initialization. - -@cindex Hyperbole manual -@noindent -The Hyperbole Manual is included in the distribution in two forms: - -@cindex Info manual -@cindex Texinfo manual -@vindex file, man/hyperbole.info -@vindex file, man/hyperbole.texi -@example -@file{man/hyperbole.info} - online version -@file{man/hyperbole.texi} - source form -@end example - -@vindex Info-directory-list -@noindent -To add pointers to the Info version of the Hyperbole manual within your -Info directory, follow these instructions. If @var{Info-directory-list} -is bound as a variable within your Emacs (all versions except V18 and -Epoch), then you can simply set it so that <HYPERBOLE-DIR> is an element -in the list: - -@lisp -(setq Info-directory-list (cons "<HYPERBOLE-DIR>" Info-directory-list)) -@end lisp - -@noindent -Otherwise, from a shell: - -@vindex Info-directory -@example - cd to the directory given by your @var{Info-directory} variable - rm hyperbole.info*; cp <HYPERBOLE-DIR>/man/hyperbole.info* . -@end example - -@noindent -For all versions of Emacs, add an Info menu entry for the Hyperbole -manual in your Info @file{dir} file (the `*' should be placed in the -first column of the file): - -@example -* Hyperbole:: GNU Emacs-based everyday information management system. - Use @{C-h h d d@} for a demonstration. Includes context-sensitive - mouse and keyboard support, a powerful rolodex, an autonumbered - outliner with hyperlink anchors for each outline cell, and extensible - hypertext facilities including hyper-links in mail and news messages. -@end example - -@cindex invoking Hyperbole -@cindex starting Hyperbole -@cindex Hyperbole, starting -@cindex Hyperbole main menu -@kindex C-h h -@findex hyperbole -That's all there is to the installation. Once Hyperbole has been -installed for use at your site, you can invoke it with @{@kbd{C-h h}@} -or @{@kbd{M-x hyperbole @key{RET}}@} to bring up the Hyperbole main menu -in the minibuffer window. - - -@node Configuring, , Installing, Installation -@section Configuring - -@cindex menu, Cust -@cindex customization -Major Hyperbole user options can be set from the window-system-based -Customization submenu below the Hyperbole menu. Alternatively, the -minibuffer-based menu, Cust/ may be used. - -@cindex configuration -@vindex file, hyperbole.el -@vindex file, hsite.el -There are many additional Hyperbole configuration options that may be -changed by editing the @file{hyperbole.el} and @file{hsite.el} files in -the @file{hyperbole/} directory. The following sections discuss the -configuration options most likely to be of interest to users. - -@menu -* Internal Viewers:: -* External Viewers:: -* Link Variable Substitution:: -* Button Colors:: -@end menu - - -@node Internal Viewers, External Viewers, Configuring, Configuring -@subsection Internal Viewers -@vindex hpath:display-alist -@vindex file, hsite.el -@cindex file display function -@cindex display function -@cindex internal viewer -@cindex link, display function -When given a file name, Hyperbole will by default display the file for -editing within an Emacs buffer. The @var{hpath:display-alist} variable -can be used to specify file name patterns, such as matching suffixes, -which will invoke a special Emacs Lisp function to display any matching -files within Emacs. This can be used to format raw data files for -convenient display. - -Configure the @var{hpath:display-alist} variable in @file{hsite.el}. -Its value is an association list whose elements are -(<file-name-regular-expression> . <function-of-one-arg>) pairs. Any -path whose name matches a <file-name-regular-expression> will be -displayed by calling the associated <function-of-one-arg> with the file -name as the argument.@refill - -@xref{External Viewers}, for instructions on associating file names with -external, window-system specific viewers. - -@node External Viewers, Link Variable Substitution, Internal Viewers, Configuring -@subsection External Viewers -@vindex hpath:find-alist -@vindex file, hsite.el -@cindex window system -@cindex external program -@cindex external viewer -@cindex link, viewer program -If you will be using Hyperbole under a window system, you may want to -configure the @var{hpath:find-alist} variable in @file{hsite.el} to -support hyperlinks which open files using non-Emacs tools, e.g@. a -fax reader or a bitmap viewer. - -The value of @var{hpath:find-alist} is determined when Hyperbole is -initialized based upon the current window system and the version of -Emacs in use. The value is an association list whose elements are -(<file-name-regular-expression> . <viewer-program>) pairs. Any path -whose name matches a <file-name-regular-expression> will be -displayed using the corresponding viewer-program. If a <viewer-program> -entry contains a @code{%s} string, the filename to display will be -substituted at that point within the string. Otherwise, the filename -will be appended to the <viewer-program> entry. See the "x-suffixes" -and "nextstep-suffixes" settings within the definition of -@var{hpath:find-alist} as examples.@refill - -@node Link Variable Substitution, Button Colors, External Viewers, Configuring -@subsection Link Variable Substitution -@vindex hpath:variables -@cindex environment variables -@cindex Emacs Lisp variables -@cindex Lisp variables -Another variable to consider modifying in the @file{hsite.el} file is -@var{hpath:variables}. This variable consists of a list of Emacs Lisp -variable names, each of which may have a pathname or a list of pathnames -as a value. Whenever a Hyperbole file or directory link button is -created, its pathname is compared against the values in -@var{hpath:variables}. The first match found, if any, is selected and -its associated variable name is substituted into the link pathname, in -place of its literal value. When the link is resolved (the button is -activated), Hyperbole replaces each variable with the first matching -value from this list. (Environment variables are also replaced whenever -link paths are resolved. - -This permits sharing of links over wide areas, where the variable values -may differ between link creator and link activator. The entire process -is wholly transparent to the user; it is explained here simply to help -you in deciding whether or not to modify the value of -@var{hpath:variables}. - -@node Button Colors, , Link Variable Substitution, Configuring -@subsection Configuring Button Colors -@cindex XEmacs support -@cindex Emacs 19 support -@cindex Epoch support -@cindex button highlighting -@cindex button flashing -@vindex file, hui-ep*.el -@findex hproperty:cycle-but-color -When Hyperbole is run under a window system together with Emacs 19, -XEmacs or Epoch, it automatically highlights any explicit buttons in -a buffer and makes them flash when selected. The main setting -you may want change is the selection of a color (or style) for button -highlighting and button flashing. See the @file{hui-*-b*.el} files for -lists of potential colors and the code which supports this behavior. A -call to @code{(hproperty:cycle-but-color)} within a Hyperbole -initialization sequence in the @file{hsite.el} file changes the color -used to highlight and flash explicit buttons. - -@cindex button emphasis -@vindex hproperty:but-emphasize-p -@vindex file, hsite.el -Additionally, under XEmacs and Emacs 19, if @var{hproperty:but-emphasize-p} -is set to @code{t} in @file{hsite.el}, then whenever the mouse pointer -moves over an explicit button, it will be emphasized in a different -color or style. This emphasis is in addition to any non-mouse-sensitive -button highlighting. - -@cindex button highlighting, forcing -@findex hproperty:but-create -If you read in a file with explicit buttons before you load Hyperbole, -these buttons won't be highlighted. Load Hyperbole and then use -@code{M-x hproperty:but-create @key{RET}} to highlight the buttons in -the current buffer. - - -@node Buttons, Smart Keys, Installation, Top -@chapter Buttons - -This chapter explains the user-level notion of Hyperbole buttons. -Hyperbole buttons that are stored in files persist across Emacs -sessions, so they provide a convenient means of linking from one -information source to another. - -@menu -* Explicit Buttons:: -* Global Buttons:: -* Implicit Buttons:: -* Action Types:: -* Button Type Precedence:: -* Button Files:: -* Utilizing Explicit Buttons:: -@end menu - -@node Explicit Buttons, Global Buttons, Buttons, Buttons -@section Explicit Buttons - -@cindex explicit button -@cindex button, explicit -@cindex button label -Hyperbole creates and manages @emph{explicit buttons} which look like -this @code{<(fake button)>} to a Hyperbole user. They are quickly -recognizable, yet relatively non-distracting as one scans the text in -which they are embedded. The text between the @code{<(} and -@code{)>} delimiters is called the @dfn{button label}. Spacing between -words within a button label is irrelevant to Hyperbole, so button labels -may wrap across several lines without causing a problem. - -@cindex button data -@cindex button attribute -@vindex file, .hypb -Hyperbole stores the @dfn{button data} that gives an explicit button its -behavior, separately from the button label, in a file named @file{.hypb} -within the same directory as the file in which the button is created. -Thus, all files in the same directory share a common button data file. -Button data is comprised of individual @dfn{button attribute} values. A -user never sees this data in its raw form but may see a formatted -version by asking for help on a button. - -@cindex button, moving -@cindex moving buttons -Explicit buttons may be freely moved about within the buffer in which -they are created. (No present support exists for moving buttons between -buffers). A single button may also appear multiple times within the -same buffer; one simply copies the button label with its delimiters -to a new location in such cases. - -Each explicit button is assigned an action type which determines the -actions that it performs. @dfn{Link action types} connect buttons to -particular types of referents. @dfn{Activation} of such buttons then -displays the referents. - -@cindex linking, in-place -@cindex Hyperbole data model -Hyperbole does not manage referent data; this is left to the -applications that generate the data. This means that Hyperbole -provides in-place linking and does not require reformatting of data to -integrate it with a Hyperbole framework. - -@node Global Buttons, Implicit Buttons, Explicit Buttons, Buttons -@section Global Buttons - -@cindex global button -@cindex button, global -@cindex button label -Access to explicit buttons depends upon the information on your screen -since they are embedded within particular buffers. Sometimes it is -useful to activate buttons without regard to the information with which -you are presently working. In such instances, you use @dfn{global -buttons}, which are simply explicit buttons which may be activated or -otherwise operated upon by entering their labels when they are prompted -for, rather than selecting the buttons within a buffer. - -If you want a permanent link to a file section that you can follow at -any time, you can use a global button. Or what about an Emacs keyboard -macro that you use frequently? Create an @code{exec-kbd-macro} button -with an easy to type name and then you can easily activate it whenever -the need arises. - -@node Implicit Buttons, Action Types, Global Buttons, Buttons -@section Implicit Buttons - -@cindex button, implicit -@cindex implicit button -Implicit buttons are those defined by the natural structure of a -document. They are identified by contextual patterns which limit the -locations or states in which they can appear. Their behavior is -determined by one or more actions which they trigger when activated. An -action is derived from either a Hyperbole action type specification, -@ref{Action Types}, or an Emacs Lisp function. Implicit -button types may use the same action types that explicit buttons do. - -@vindex file, hibtypes.el -@cindex context -Implicit buttons never have any button data associated with them. They -are recognized in context based on predicate matches defined within -implicit button types. For example, Hyperbole recognizes file names -enclosed in double quotes and can quickly display their associated files -in response to simple mouse clicks. - -@cindex ibtypes, list of -@noindent -See @file{hibtypes.el} for complete examples. Standard implicit button -types are listed below in the order in which Hyperbole tries to match -to the types when looking for an implicit button. - -@table @code - -@item doc-id -@findex ibtypes::doc-id -@cindex online library -@cindex document identifier -Displays an index entry for a site-specific document given its id. Ids -must be delimited by `doc-id-start' and `doc-id-end' and must match the -function given by `doc-id-p'. This permits creation of catalogued -online libraries. See @file{$@{hyperb:dir@}/hib-doc-id.el} for more -information.@refill - -@item completion -@findex ibtypes::completion -@cindex completion -Inserts completion at point into minibuffer or other window. - -@item Info-node -@findex ibtypes::Info-node -@cindex Info node -Makes "(file)node" buttons display the associated Info node. - -@item mail-address -@findex ibtypes::mail-address -@cindex e-mail address -@cindex rolodex address -@cindex address -If on an e-mail address in a specific buffer type, mail to that address -in another window. Applies to the rolodex match buffer, any buffer -attached to a file in @var{rolo-file-list}, or any buffer with @file{mail} -or @file{rolo} (case-insensitive) within its name. - -@item patch-msg -@findex ibtypes::patch-msg -@cindex patch output -Jumps to source code associated with output from the @code{patch} -program. Patch applies diffs to source code. - -@item elisp-compiler-msg -@findex ibtypes::elisp-compiler-msg -@cindex byte compiler error -@cindex Emacs Lisp compiler error -@cindex compiler error -Jumps to source code for definition associated with byte-compiler error -message. Works when activated anywhere within an error line. - -@item grep-msg -@findex ibtypes::grep-msg -@cindex grep -@cindex compiler error -Jumps to line associated with grep or compilation error msgs. -Messages are recognized in any buffer. - -@item debugger-source -@findex ibtypes::debugger-source -@cindex gdb -@cindex dbx -@cindex xdb -@cindex stack frame -@cindex breakpoint -@cindex source line -Jumps to source line associated with debugger stack frame or breakpoint lines. -This works with gdb, dbx, and xdb. Such lines are recognized in any buffer. - -@item pathname -@findex ibtypes::pathname -@findex hpath:at-p -@findex hpath:find -@vindex hpath:suffixes -@cindex ange-ftp -@cindex efs -@cindex pathname -@cindex remote path -@cindex filename -@cindex link, pathname -Makes a delimited, valid pathname display the path entry. -Also works for delimited and non-delimited ange-ftp and efs pathnames. -Also works for delimited and non-delimited ange-ftp and efs pathnames. -Emacs Lisp library files (filenames that end in .el and .elc) are looked up -using the load-path directory list. - -@noindent -See @code{hpath:at-p} function documentation for possible delimiters. -See @var{hpath:suffixes} variable documentation for suffixes that are -added to or removed from pathname when searching for a valid match. -See @code{hpath:find} function documentation for special file -display options. - -@item klink -@findex ibtypes::klink -@cindex klink -@cindex koutline link -@cindex kcell link -Follows a link delimited by <> to a koutline cell. -See documentation for @code{actypes::link-to-kotl} for valid link -specifiers. - -@item man-apropos -@findex ibtypes::man-apropos -@item UNIX manual -@item man pages -@item man apropos -Makes man apropos entries display associated man pages when selected. - -@item hyp-source -@findex ibtypes::hyp-source -@cindex Hyperbole report -Turns source location entries in Hyperbole reports into buttons that jump to the associated location. - -@item hyp-address -@findex ibtypes::hyp-address -@cindex Hyperbole mail list -Turns a Hyperbole e-mail list address into an implicit button which -inserts Hyperbole environment information. -Useful when sending mail to a Hyperbole mail list. See also the -documentation for @code{actypes::hyp-config}. - -@item rfc -@findex ibtypes::rfc -@cindex Internet RFC -@cindex Request For Comment -@cindex RFC -@cindex ange-ftp -@cindex efs -Retrieves and displays an Internet rfc referenced at point. -Requires ange-ftp or efs when needed for remote retrievals. The -following formats are recognized: RFC822, rfc-822, and RFC 822. The -@var{hpath:rfc} variable specifies the location from which to retrieve -RFCs." - -@item kbd-key -@findex ibtypes::kbd-key -@cindex key sequence -Executes a key sequence delimited by curly braces. -Key sequences should be in human readable form, e.g@. @{@kbd{C-b}@}. -Forms such as @{@}, @{@}, and @{^b@} will not be recognized. - -@item dir-summary -@findex ibtypes::dir-summary -@vindex file, MANIFEST -@vindex file, DIR -Detects filename buttons in files named "MANIFEST" or "DIR". -Displays selected files. -Each file name must be at the beginning of the line and must be followed -by one or more spaces and then another non-space, non-parenthesis, non-brace -character. - -@item text-toc -@findex ibtypes::text-toc -@cindex table of contents -@cindex toc implicit button type -Jumps to the text file section referenced by a table of contents entry -at point. File name must contain @file{README} and there must be a -`Table of Contents' or `Contents' label on a line by itself (it may -begin with an asterisk), preceding the table of contents. Each toc -entry must begin with some whitespace followed by one or more asterisk -characters. Each file section name line must start with one or more -asterisk characters at the very beginning of the line. - -@item cscope -@findex ibtypes::cscope -@cindex C/C++ call trees -@cindex C/C++ cross-reference -@cindex Cscope -Jumps to C/C++ source line associated with Cscope C analyzer output line. -Requires pre-loading of the cscope.el Lisp library available from the Emacs -Lisp archives and the commercial cscope program available from UNIX System -Laboratories. Otherwise, does nothing. - -@item rfc-toc -@findex ibtypes::rfc-toc -@cindex Internet RFC -@cindex Request For Comment -@cindex RFC -@cindex table of contents -Summarizes contents of an Internet rfc from anywhere within rfc buffer. -Each line in summary may be selected to jump to section. - -@item annot-bib -@findex ibtypes::annot-bib -@cindex bibliography -@cindex reference -Displays annotated bibliography entries referenced internally, delimeters = []. -References must be delimited by square brackets, must begin with a -word constituent character, and must not be in buffers whose -names begin with a ` ' or `*' character. - -@item www-url -@findex ibtypes::www-url -@cindex URL -@cindex World-wide Web -@cindex WWW -@cindex Action Key, web browsing -@kindex Action Key, web browsing -@vindex action-key-url-function -When not in a w3 browser buffer, follow any non-ftp url (link) at point. -The variable, @var{action-key-url-function}, can be used to customize -the url browser that is used. - -@item function-in-buffer -@findex ibtypes::function-in-buffer -@cindex functions -@cindex func-menu -Return function name defined within this buffer that point is within or -after, else nil. This triggers only when the func-menu.el package has -been loaded and the current major mode is one handled by func-menu. - -@end table - -The Hyperbole Smart Keys offer extensive additional context-sensitive -point-and-click type behavior beyond these standard implicit button -types. @xref{Smart Keys}. - - -@node Action Types, Button Type Precedence, Implicit Buttons, Buttons -@section Action Types - -@cindex action type -@cindex argument, use -@cindex action -@dfn{Action types} provide action procedures that specify button behavior. -The arguments needed by an action type are prompted for at button creation -time. When a button is activated, the stored arguments are fed to the -action type's @dfn{action} body to achieve the desired result. Hyperbole -handles all of this transparently. - -@cindex actypes, list of -@noindent -Standard action types in alphabetical order include: - -@table @code -@item annot-bib -@findex actypes::annot-bib -Follows internal ref KEY within an annotated bibliography, delimiters=[]. - -@item completion -@findex actypes::completion -Inserts completion at point into minibuffer or other window. -Unless at end of buffer or if completion has already been inserted, then -deletes completions window. - -@item eval-elisp -@findex actypes::eval-elisp -Evaluates a Lisp expression LISP-EXPR. - -@item exec-kbd-macro -@findex actypes::exec-kbd-macro -Executes KBD-MACRO REPEAT-COUNT times. -KBD-MACRO may be a string of editor command characters or a function symbol. -Optional REPEAT-COUNT nil means execute once, zero means repeat until -error. - -@item exec-shell-cmd -@findex actypes::exec-shell-cmd -Executes a SHELL-CMD string asynchronously. -Optional non-nil second argument INTERNAL-CMD means do not display the shell -command line executed. Optional non-nil third argument KILL-PREV means -kill last output to shell buffer before executing SHELL-CMD. - -@item exec-window-cmd -@findex actypes::exec-window-cmd -Executes an external window-based SHELL-CMD string asynchronously. - -@item hyp-config -@findex actypes::hyp-config -Inserts Hyperbole configuration info at end of current buffer or optional OUT-BUF. - -@item hyp-request -@findex actypes::hyp-request -Inserts Hyperbole mail list request help into current buffer or optional OUT-BUF. - -@item hyp-source -@findex actypes::hyp-source -Displays a buffer or file from a line beginning with `hbut:source-prefix'. - -@item kbd-key -@findex actypes::kbd-key -Executes the function binding for KEY-SEQUENCE, delimited by @{@}. -Returns t if a KEY-SEQUENCE has a binding, else nil. - -@item link-to-buffer-tmp -@findex actypes::link-to-buffer-tmp -Displays a BUFFER in another window. -Link is generally only good for current Emacs session. -Use `link-to-file' instead for a permanent link. - -@item link-to-directory -@findex actypes::link-to-directory -Displays a DIRECTORY in Dired mode in another window. - -@item link-to-doc -@findex actypes::link-to-doc -Displays online version of a document given by DOC-ID, in other window. -If the online version of a document is not found in -@var{doc-id-indices}, an error is signalled. - -@item link-to-ebut -@findex actypes::link-to-ebut -Performs action given by another button, specified by KEY and KEY-FILE. - -@item link-to-elisp-doc -@findex actypes::link-to-elisp-doc -Displays documentation for FUNC-SYMBOL. - -@item link-to-file -@findex actypes::link-to-file -Displays a PATH in another window scrolled to optional POINT. -With POINT, buffer is displayed with POINT at the top of the window. - -@item link-to-file-line -@findex actypes::link-to-file-line -Displays a file given by PATH scrolled to LINE-NUM. - -@item link-to-kcell -@findex actypes::link-to-kcell -Displays FILE with kcell given by CELL-REF at window top. -See documentation for `kcell:ref-to-id' for valid cell-ref formats. - -@noindent -If FILE is nil, the current buffer is used. -If CELL-REF is nil, the first cell in the view is shown. - -@item link-to-kotl -@findex actypes::link-to-kotl -Displays at the top of another window the referent pointed to by LINK. -LINK may be of any of the following forms, with or without delimiters: -@example - < pathname [, cell-ref] > - < [-!&] pathname > - < @@ cell-ref > -@end example - -@noindent -See documentation for @code{kcell:ref-to-id} for valid cell-ref formats. - -@item link-to-Info-node -@findex actypes::link-to-Info-node -Displays an Info NODE in another window. -NODE must be a string of the form `(file)nodename'. - -@item link-to-mail -@findex actypes::link-to-mail -Displays mail msg with MAIL-MSG-ID from MAIL-FILE in other window. -See documentation for the variable @var{hmail:init-function} for -information on how to specify a mail reader to use. - -@item link-to-regexp-match -@findex actypes::link-to-regexp-match -Finds REGEXP's Nth occurrence in FILE and displays location at window top. -Returns t if found, signals an error if not. - -@item link-to-rfc -@findex actypes::link-to-rfc -Retrieves and displays an Internet rfc given by RFC-NUM. -RFC-NUM may be a string or an integer. Requires ange-ftp or efs for -remote retrievals. - -@item link-to-string-match -@findex actypes::link-to-string-match -Finds STRING's Nth occurrence in FILE and displays location at window top. -Returns t if found, nil if not. - -@item man-show -@findex actypes::man-show -Displays man page on TOPIC, which may be of the form @code{<command>(<section>}). - -@item rfc-toc -@findex actypes::rfc-toc -Computes and displays summary of an Internet rfc in BUF-NAME. -Assumes point has already been moved to start of region to summarize. -Optional OPOINT is point to return to in BUF-NAME after displaying summary. - -@item text-toc -@findex actypes::text-toc -@cindex table of contents -@cindex toc action type -Jumps to the text file SECTION referenced by a table of contents entry -at point. - -@item www-url -@findex actypes::www-url -@cindex URL -@cindex World-wide Web -@cindex WWW -@vindex action-key-url-function -Follows a link given by URL. -The variable, @var{action-key-url-function}, can be used to customize -the url browser that is used. -@end table - -@cindex action -@vindex hui:ebut-prompt-for-action -The use of action types provides a convenient way of specifying button -behavior without the need to know how to program. Expert users who are -familiar with Emacs Lisp, however, may find that they often want to -tailor button actions in a variety of ways not easily captured within a -type system. In such cases, @var{hui:ebut-prompt-for-action} should be -set non-nil. This will cause Hyperbole to prompt for an action to -override the button's action type at each explicit button creation. For -those cases where the action type is sufficient, a nil value should be -entered for the action. An action may be any Lisp form that may be -evaluated. - -@node Button Type Precedence, Button Files, Action Types, Buttons -@section Button Type Precedence - -@cindex button precedence -@cindex button label overlap -Explicit buttons always take precedence over implicit buttons. Thus, if -a button selection is made which falls within both an explicit and -implicit button, only the explicit button will be selected. Explicit -button labels are not allowed to overlap; Hyperbole's behavior in such -cases is undefined. - -@cindex ibtype, evaluation order -If there is no explicit button at point during a selection request, then -each implicit button type predicate is tested in turn until one returns -non-nil or all are exhausted. Since two implicit button types may have -overlapping domains (those contexts in which their predicates are true), -only the first matching type is used. The type predicates are tested -in @strong{reverse} order of definition, i.e@. most recently entered -types are tested first, so that personal types defined after standard -system types take precedence. It is important to keep this order in -mind when defining new implicit button types. By making their match -predicates as specific as possible, one can minimize any overlapping of -implicit button type domains. - -@cindex type redefinition -Once a type name is defined, its precedence relative to other types -remains the same even if you redefine the body of the type, as long as -you don't change its name. This allows incremental modifications to -types without having to worry about shifts in type precedence. -@xref{Creating Types}, for information on how to develop -or modify types. - -@node Button Files, Utilizing Explicit Buttons, Button Type Precedence, Buttons -@section Button Files - -@cindex button files -It is often convenient to create lists of buttons that can be used as -menus to provide centralized access to distributed information pools or -for other purposes. These files can serve as useful roadmaps to help -efficiently guide a user through both unfamiliar and highly familiar -information spaces. Files that are created specifically for this -purpose, we call @dfn{button files}. - -@vindex hbmap:filename -@cindex button file, personal -@cindex button file, directory -The Hyperbole menu system provides quick access to two types of these -button files: personal and directory-specific, through the ButFile menu. -(The variable, @var{hbmap:filename}, contains the base name of these -standard button files. Its standard value is @file{HYPB}.) - -@vindex dir, ~/.hyperb -@vindex hbmap:dir-user -@cindex global button -A personal button file may serve as a user's own roadmap to frequently -used resources. Selection of the ButFile/PersonalFile menu item -displays this file for editing. The default personal button file is -stored within the directory given by the @var{hbmap:dir-user} variable -whose standard value is @file{~/.hyperb}. The standard Hyperbole -configuration also appends all global buttons to the end of this file, -one per line, as they are created. So you can edit or annotate them -within the file. - -A directory-specific button file may exist for each file system -directory. Such files are useful for explaining the contents of -directories and pointing readers to particular highlights within the -directories. Selection of the ButFile/DirFile menu item displays the -button file for the current directory; this provides an easy means of -updating this file when working on a file within the same directory. -If you want to view some other directory-specific button file, simply -use the normal Emacs file finding commands. - -One might suggest that menu quick access be provided for group-specific -and site-specific button files. Instead, link buttons to such things -should be placed at the top of your personal button file. This provides -a more flexible means of quick access. - -@node Utilizing Explicit Buttons, , Button Files, Buttons -@section Utilizing Explicit Buttons - -Explicit buttons are a fundamental building block for creating personal -or organizational hypertext networks with Hyperbole. This section -summarizes the user-level operations available for managing these -buttons. - -@menu -* Creation:: -* Renaming:: -* Deletion:: -* Modification:: -* Location:: -* Buttons in Mail:: -* Buttons in News:: -@end menu - -@node Creation, Renaming, Utilizing Explicit Buttons, Utilizing Explicit Buttons -@subsection Creation - -@menu -* By Dragging:: Creation Via Action Key Drags -* By Menu:: Creation Via Menus -@end menu - -@node By Dragging, By Menu, Creation, Creation -@subsubsection Creation Via Action Key Drags - -@cindex explicit button, creation -@cindex button, creation -@cindex link, creation -@cindex drag -@cindex Action Key drag -The most efficient way to create an explicit button interactively is to -use the mouse Action Key to drag from a button source window to a window -showing its link referent. More specifically, you should split your -current Emacs frame into two windows: one which contains the point at -which you want a button to be inserted and another which shows the point -to which you want to link. Depress the mouse Action Key at the point at -which the button should be inserted, drag to the other window and -release it at the point of the link referent. The process becomes quite -simple with a little practice. (@xref{By Menu, Creation Via Menus}, for a -more detailed explanation of the explicit button creation process.) - -Hyperbole uses the link referent context to determine the type of link -to make. If there are a few different types of links which are -applicable from the context, you will be prompted with a list of the -types. Simply use the Action Key or the first letter of the link -type to select one of the type names and to finish the link creation. -Hyperbole will then insert explicit button delimiters around the button -label and will display a message in the minibuffer indicating both the -button name and its action/link type. - -@kindex M-o -@kindex C-u M-o -@kindex C-x o -@findex hkey-operate -If you run Emacs under a window system, you can emulate an Action Key -drag from the keyboard by: hitting @{@kbd{M-o}@}, the -@code{hkey-operate} command, at the button source location, moving -to the link destination, e.g@. with @{@kbd{C-x o}@}, and then hitting -@{@kbd{M-o}@} again. This simulates a depress and then release of the -Action Key. @{@kbd{C-u M-o}@} emulates drags of the Assist Key. -This will not work when Hyperbole is run from a dumb terminal Emacs -session since drag actions are not supported without a window system. - -@page -@node By Menu, , By Dragging, Creation -@subsubsection Creation Via Menus - -You can alternatively use the Hyperbole menus to create explicit -buttons. First, mark a short region of text in any fashion allowed by -GNU Emacs and then select the Hyperbole menu item sequence, Ebut/Create. -You will be prompted for the button's label with the marked region as -the default. If you accept the default and enter the rest of the -information you are prompted for, the button will be created within the -current buffer and Hyperbole will surround the marked region with -explicit button delimiters to indicate success. - -If you do not mark a region before invoking the button create command, -you will be prompted for both a label and a target buffer for the button -and the delimited label text will be inserted into the target buffer -after a successful button creation. - -After Hyperbole has the button label and its target buffer, it will -prompt you for an action type for the button. Use the @{@kbd{?}@} -completion help key to see the available types. The type selected -determines any following values for which you will be prompted. - -@cindex button instance -@cindex instance number -If a previous button with the same label exists in the same buffer, -Hyperbole will add an @dfn{instance number} to the label when it adds -the delimiters so that the name is unique. Thus, you don't have to -worry about accidental button name conflicts. If you want the same -button to appear in multiple places within the buffer, just enter the -label again and delimit it yourself. Hyperbole will interpret all -occurrences of the same delimited label within a buffer as the same -button. - -@cindex link, creation -If you create link buttons using the Hyperbole menus, the best technique -is to place on screen both the source buffer for the button and the -buffer to which it will link. Mark the region of text to use for your -button label, invoke the button create command from the menu, choose an -action type which begins with @code{link-to-} and then use the direct -selection techniques mentioned in @ref{Entering Arguments}, to select -the link referent. - - -@node Renaming, Deletion, Creation, Utilizing Explicit Buttons -@subsection Renaming - -@cindex explicit button, renaming -@cindex button, renaming -Once an explicit button has been created, its label text must be -treated specially. Any inter-word spacing within the label may be -freely changed, as may happen when a paragraph is refilled. But a -special command must be invoked to rename it. - -The rename command operates in two different ways. If point is within a -button label when it is invoked, it will tell you to edit the button -label and then invoke the rename command again. The second invocation -will actually rename the button. If instead the command is originally -invoked outside of any explicit button, it will prompt for the button -label to replace and the label to replace it with and then will perform -the rename. All occurrences of the same button in the buffer will be -renamed, so you need locate only one occurrence of the button. - -@vindex file, .~/.emacs -@vindex file, hsite.el -@kindex C-c C-r -The rename command may be invoked from the Hyperbole menu via -Ebut/Rename. A faster method is to use a key bound to the -@code{hui:ebut-rename} command. Your site installation may include such -a key. @{@kbd{C-h w hui:ebut-rename @key{RET}}@} should show you any -key it is on. If no key binding has been established or if you prefer -one of your own, simply bind it within your @file{~/.emacs} file. We -recommend the @{@kbd{C-c C-r}@} key, as in: @code{(global-set-key -"\C-c\C-r" 'hui:ebut-rename)}. - - -@node Deletion, Modification, Renaming, Utilizing Explicit Buttons -@subsection Deletion - -@cindex explicit button, deleting -@cindex button, deleting -Ebut/Delete works similarly to the Rename command but deletes the -selected button. The button's delimiters are removed to confirm the -delete. If the delete command is invoked with a prefix argument, then -both the button label and the delimiters are removed as confirmation. - -@vindex hui:ebut-delete-confirm-p -Presently there is no way to recover a deleted button; it must -be recreated. Therefore, the @var{hui:ebut-delete-confirm-p} variable -is true by default, causing Hyperbole to require confirmation before -interactively deleting explicit buttons. Set it to nil if you prefer no -confirmation. - -@node Modification, Location, Deletion, Utilizing Explicit Buttons -@subsection Modification - -@cindex explicit button, modifying -@cindex button, modifying -@cindex Smart Mouse Key drag -Ebut/Modify prompts you with each of the elements from the button's -data list and allows you to modify each in turn. - -There is a quicker way to modify explicit link buttons. Simply drag with the -mouse Action Key from within the button label to a link destination in a -different window, just as you would when creating a new button with a mouse -drag. Remember that drags may also be emulated from the keyboard. -@xref{Creation}. - -@node Location, Buttons in Mail, Modification, Utilizing Explicit Buttons -@subsection Location - -@cindex explicit button, summarizing -@cindex button, summarizing -@cindex button, help -The Ebut/Help menu can be used to summarize a single explicit button or -all such buttons within a single buffer. The buttons summarized may -then be activated directly from the summary. - -Ebut/Help/BufferButs summarizes the explicit buttons in the order in -which they appear in the buffer. Ebut/Help/CurrentBut summarizes only -the button at point. Ebut/Help/OrderedButs summarizes the buttons in -alphabetical order. All of these summary commands eliminate duplicate -instances of buttons from their help displays. - -@cindex explicit button, searching -@cindex button, searching -Ebut/Search prompts for a search pattern and searches across all the -locations in which you have previously created explicit buttons. It -asks you whether to match to any part of a button label or only complete -labels. It then displays a list of button matches with a single line of -surrounding context from their sources. Any button in the match list -may be activated as usual. An Action Key press on the surrounding context -jumps to the associated source line or a press on the filename preceding -the matches jumps to the file without selecting a particular line. - -There are presently no user-level facilities for globally locating buttons -created by others or for searching on particular button attributes. - -@node Buttons in Mail, Buttons in News, Location, Utilizing Explicit Buttons -@subsection Buttons in Mail - -@kindex C-x m -@findex mail -Hyperbole allows the embedding of buttons within electronic mail -messages that are composed in Emacs with the standard @code{(mail)} -command, normally bound to @{@kbd{C-x m}@} or with other Emacs-based -mail composing functions. An enhanced mail reader can then be used -to activate the buttons within messages just like any other buttons. - -@cindex button, mailing -@cindex button, posting -@cindex mailing buttons -@cindex posting buttons -@cindex mail reader -@cindex mailer initialization -@cindex RMAIL -@cindex VM -@cindex PIEmail -@cindex MH-e -@cindex GNUS -@cindex USENET -@cindex news -@vindex file, hmail.el -Hyperbole automatically supports the following mail readers: Rmail, -@ref{Rmail,,,emacs, the GNU Emacs Manual}, VM, @ref{Introduction,,,vm, -the VM Manual}, and PIEmail, and MH-e. Button inclusion and activation -within USENET news articles is also supported in the same fashion via -the GNUS news reader, @ref{Introduction,,,gnus, the GNUS Manual}, if -available at your site. (The @file{hmail.el} file provides a -generalized interface that can be used to hook in other mail or news -readers if the necessary interface functions are written.) - -@vindex mail-yank-original -@kindex C-c C-y -@cindex mail inclusion -All explicit buttons to be mailed must be created within the outgoing -message buffer. There is no present support for including text from -other buffers or files which contain explicit buttons, except for the -ability to yank the contents of a message being replied to, together -with all of its buttons, via the @code{(mail-yank-original)} command -bound to @{@kbd{C-c C-y}@}. From a user's perspective, buttons are -created in precisely the same way as in any other buffer. They also -appear just like any other buttons to both the message sender and the -reader who uses the Hyperbole enhanced readers. Button operation may be -tested any time before a message is sent. A person who does not use -Hyperbole enhanced mail readers can still send messages with embedded -buttons since mail composing is independent of any mail reader -choice. - -Hyperbole buttons embedded within received mail messages act just like -any other buttons. The mail does not contain any of the action type -definitions used by the buttons, so the receiver must have these or she -will receive an error when she activates the buttons. Buttons which -appear in message @emph{Subject} lines are copied to summary buffers -whenever such summaries are generated. Thus, they may be activated from -either the message or summary buffers. - -Nothing bad will happen if a mail message with explicit buttons is sent -to a non-Hyperbole user. The user will simply see the text -of the message followed by a series of lines of button data at its end. -Hyperbole mail users never see this data in its raw form. - -@vindex smail:comment -@cindex mail comment -In order to alert readers of your mail messages that you can utilize -Hyperbole mail buttons, the system automatically inserts a comment into -each mail message that you compose to announce this fact. The variable, -@var{smail:comment} controls this behavior. See its documentation for -technical details. By default, it produces a message of the form: - -@example -Comments: Hyperbole mail buttons accepted, vX.XX. -@end example - -@vindex file, ~/.emacs -@noindent -where the X's indicate your Hyperbole version number. You can cut this -out of particular messages before you send them. If you don't want any -message at all, add the following to your @file{~/.emacs} file before -the point at which you load Hyperbole. - -@lisp -(setq smail:comment nil) -@end lisp - -@cindex actype, link-to-mail -A final mail-related facility provided by Hyperbole is the ability to -save a pointer to a received mail message by creating an explicit button -with a @code{link-to-mail} action type. When prompted for the mail -message to link to, if you press the Action Key on an Rmail message, the -appropriate parameter will be copied to the argument prompt, as -described in @ref{Entering Arguments}. - - -@node Buttons in News, , Buttons in Mail, Utilizing Explicit Buttons -@subsection Buttons in News - -@cindex button, posting -@cindex news reader/poster -@cindex posting news -@cindex GNUS -@cindex USENET -@vindex file, hgnus.el -@vindex file, hsite.el -Explicit buttons may be embedded within outgoing USENET news articles -and may be activated from news articles that are being read. This -support is available for the GNUS news reader. It is enabled by default -within @file{hsite.el} by autoloading the @file{hgnus.el} file. - -All Hyperbole support should work just as it does when reading or -sending mail. @xref{Buttons in Mail}. When reading news, buttons which -appear in message @emph{Subject} lines may be activated within the GNUS -subject buffer as well as the article buffer. When posting news, the -*post-news* buffer is used for outgoing news articles rather than the -*mail* buffer. - -Remember that the articles you post do not contain the action type -definitions used by the buttons, so the receiver must have these or she -will receive an error when he activates the buttons. You should also -keep in mind that most USENET readers will not be using Hyperbole, so if -they receive a news article containing explicit buttons, they will -wonder what the button data at the end of the message is. You should -therefore limit distribution of such messages. For example, if most -people at your site read news with GNUS and use Hyperbole, it would be -reasonable to embed buttons in postings to local newsgroups. - -@cindex news comment -In order to alert readers of your postings that you can utilize -Hyperbole mail buttons embedded within personal replies, -the system automatically inserts the same comment that is included -within mail messages to announce this fact. @xref{Buttons in Mail}, for -details and an explanation of how to turn this feature off. - -@node Smart Keys, Menus, Buttons, Top -@chapter Smart Keys - -@cindex Smart Key -@cindex mouse support -@cindex Action Key -@cindex Assist Key -@kindex Action Key -@kindex Assist Key -Hyperbole provides two special @dfn{Smart Keys} that perform -context-sensitive operations, the Action Key and the Assist Key. By -default, the @dfn{Action Key} is bound to your shift-middle mouse button (or -shift-left on a 2-button mouse) and the @dfn{Assist Key} is bound to your -shift-right mouse button, assuming Hyperbole is run under an external window -system. (InfoDock users should use the middle mouse button as the -Action Key, instead.) - -@findex hmouse-shift-buttons -Mouse configuration is automatic for InfoDock, XEmacs, and Epoch under -the X window system and for GNU Emacs versions 18 and 19 under X, -OpenWindows, NEXTSTEP, SunView and Apollo's Display Manager, assuming -your Emacs program has been built with support for any of these window -systems. The command, @code{hmouse-shift-buttons}, can be used to -select between shifted and unshifted Smart Mouse Keys. - -@vindex hkey-init -@kindex C-u M-RET -@kindex M-RET -By default (if @var{hkey-init} is set to @code{t} in @file{hsite.el}), -then @{@kbd{M-@key{RET}}@} may also be used as the Action Key and -@{@kbd{C-u M-@key{RET}}@} may be used as the Assist Key. In many -read-only modes like Dired and Rmail, -@{@key{RET}@} also functions as the Action Key. These key bindings allow -context sensitive operation from any keyboard. - -@cindex key binding, smart keys -@cindex smart key commands -@findex action-key -@findex assist-key -@findex action-mouse-key -@findex assist-mouse-key -If you prefer other key bindings, simply bind the commands -@code{action-key} and @code{assist-key} to keyboard keys. -@code{hkey-either} may be used instead if you prefer a single -key binding for both commands; a prefix argument then invokes -@code{assist-key}. - -You may also bind @code{action-mouse-key} and @code{assist-mouse-key} -to mouse keys, as you like. - -@cindex button activation -@cindex activation -@cindex button help -The Action Key generally selects entities, creates links and -activates buttons. The Assist Key generally provides help, -such as reporting on a button's attributes, or serves a complementary -function to whatever the Action Key does within a context. - -@cindex Smart Key operation -You can get a summary of what the Smart Keys do in all of their -different contexts by pressing the Assist Key in the right -corner (within the rightmost 3 characters) of a window modeline or by -using the Hyperbole Doc/SmartKy menu entry. - -The following table is an example of this summary. Much of the browsing -power of Hyperbole comes from use of the Smart Keys, so you should spend -some time practicing how to use them. This table may appear daunting at -first, but as you practice and notice that the Smart Keys do just a few -context-sensitive things per editor mode, you will find it easy to just -point and click and let Hyperbole do the rest. - -For extensive reference documentation on the Smart Keys, @ref{Smart -Key Reference}. - -@page -@iftex -@example -@include ../etc/hypb-mouse.txt -@end example -@end iftex -@ifinfo -@format -@include ../etc/hypb-mouse.txt -@end format -@end ifinfo - -@vindex action-key-default-function -@vindex assist-key-default-function -Note how the last line in the table explains the default behavior of the -Smart Keys. That is what they do when they cannot find a context match -at your current location. See the documentation for the variables -@var{action-key-default-function} and @var{assist-key-default-function} -for information on how to customize the behavior of the Smart Keys -within default contexts. - -@cindex Hyperbole help -A prime design criterion of Hyperbole's user interface is that one -should be able to see what an operation will do before using it. -The Assist Key shows you what a button or minibuffer menu item will do -before you activate it. Hyperbole also shows the result of directly -selecting an argument value with the mouse, to provide feedback as to -whether the right item has been selected. A second click is necessary -before an argument is accepted and processed. - -@cindex Smart Key help -@cindex help, Smart Key -@cindex context sensitive help -When you use a mouse and you want to find out what either of the Smart -Keys does within a context, depress the one you want to check on and -hold it down, then press the other and release as you please. A help -buffer will pop up explaining the actions that will be performed in that -context, if any. A press of either Smart Key at the end of that -help buffer will restore your display to its configuration prior to -invoking help. - -@kindex C-h A -@vindex hkey-init -By default (if @var{hkey-init} is left set equal to @code{t} in -@file{hsite.el}), then @{@kbd{C-h A}@} will display this same -context-sensitive help for the Action Key while @{@kbd{C-u C-h -A}@} will display the help for the Assist Key. Note that -@{@kbd{C-h a}@} will perform a function unrelated to Hyperbole, so you -must press the shift key when you hit the @kbd{A} character. - -@cindex Smart Key toggle -@cindex mouse key toggle -@vindex file, ~/.emacs -@vindex file, hsite.el -@kindex C-c t -When Hyperbole is installed, a key may be bound which allows you -to switch between the Smart Key mouse bindings and your prior ones. -@kbd{C-h w hmouse-toggle-bindings @key{RET}} should show you any key -which performs this command. If no key binding has been established or -if you prefer one of your own, simply select a key and bind it -within your @file{~/.emacs} file. For example, @code{(global-set-key -"\C-ct" 'hmouse-toggle-bindings)}. - - -@node Menus, Entering Arguments, Smart Keys, Top -@chapter Menus - -@cindex InfoDock -@cindex XEmacs -@cindex Emacs 19 -@cindex menu use -@cindex menubar, Hyperbole menu -Under InfoDock, XEmacs, and Emacs 19, pulldown and popup menus are -available to invoke Hyperbole commands, including those from the rolodex -and the outliner. These menus operate like any other application menus -and are fairly self-explanatory. Use the Quit command on the Hyperbole -menubar menu to get rid of the menu if you do not need it. Invoking -Hyperbole again will add the menu back to the menubar. - -@cindex minibuffer menus -This section discusses only the specialized @dfn{minibuffer menus} that -appear in the minibuffer window and that work with all Emacs versions on -all display devices. Minibuffer menu items may be selected from either -the keyboard or via mouse clicks. When used with the keyboard, they -provide rapid command access similar to key bindings. - -@kindex C-h h -@vindex action-key-default-function -@cindex menu, top level -The top level menu is invoked from a key given in your @file{hsite.el} -file (by default, @{@kbd{C-h h}@}) or via an Action Key press in a -location with no other action defined. The menu will appear in the -minibuffer and should look mostly like so: - -@noindent -@example -Hy4> Act Butfile/ Cust/ Doc/ Ebut/ Gbut/ Hist Ibut/ Msg/ Otl/ Rolo/ Win/ -@end example - -@noindent -The above menu items can be summarized as follows: - -@table @strong -@cindex menu, Act -@item Act -Perform the action associated with any button at point or prompt for the -name of an explicit button to activate if point is not on one. - -@cindex menu, ButFile -@cindex button file, HYPB -@vindex file, HYPB -@item Butfile/ -Display a local or global file of buttons, providing easy access. -@file{HYPB} for a local button file and @file{~/.hyperb/HYPB} for your -global file. These are good places to start your button creation testing. - -@cindex menu, Cust -@cindex customization -@cindex option settings -@item Cust/ -Customizes Hyperbole by setting major options. -This includes where Hyperbole link referents are displayed, where URLs -are displayed, whether the date stamps are added to rolodex entries, and -whether to use proportional or windowful scrolling when a Smart Key is -pressed at the end of a line. @xref{Configuring}. - -@cindex menu, EBut -@item Ebut/ -All explicit button commands. The window-system-based Hyperbole -menu includes a menu item that activates each explicit button found -in the current buffer. - -@cindex menu, Doc -@cindex menu, Types -@item Doc/ -Hyperbole documentation quick access. Contains About item describing -Hyperbole and a Demo item which demonstrates a number of Hyperbole -features. It also contains the Types/ submenu for documentation on -Hyperbole implicit button and action types. - -@cindex menu, Global Buttons -@item Gbut/ -All global button commands. Global buttons are accessed by name -rather than by direct selection. The window-system-based Hyperbole -menu also includes a menu item that activates each global button. - -@cindex menu, History -@cindex history -@item Hist -Jumps back to last position in button traversal history. - -@cindex menu, Implicit Buttons -@item Ibut/ -All implicit button commands. - -@cindex menu, Message -@item Msg/ -Hyperbole-specific mail and news messaging support commands. Use this -to send mail to a Hyperbole mail list or to add/modify/delete your entry -on a list. - -@cindex menu, Outliner -@item Otl/ -Autonumbered, structured outliner and hyper-node manager commands. -@xref{Outliner}. - -@cindex menu, Rolodex -@item Rolo/ -Hierarchical, multi-file rolodex lookup and edit commands. -@xref{Rolodex}. - -@cindex menu, Window Configurations -@cindex menu, Windows -@item Win/ -Window configuration management such as adding and restoring window -configurations by name. @xref{Window Configurations}. - -@end table - -@cindex submenus -@cindex menu help -@cindex help, menu items -All menu items are selected via the first character of their names -(letter case does not matter) or via a press of the Action Key. "/" at -the end of an item name indicates that it brings up a sub-menu. A press -of the Assist Key on an item displays help for the item, including the -action that it performs. - -@kindex C-t -@kindex q -@kindex C-g -While a menu is active, to re-activate the top-level Hyperbole menu, you -must use @{@kbd{C-t}@}. This allows you to browse the submenus and then -return to the top. You can quit without selecting an item by using -@{@kbd{q}@}. @{@kbd{C-g}@} aborts whether you are at a menu prompt or -any other Hyperbole prompt. - - - -@node Entering Arguments, Outliner, Menus, Top -@chapter Entering Arguments - -@cindex argument entry -@cindex direct selection -@cindex double click -Many Hyperbole commands prompt you for arguments. The standard -Hyperbole user interface has an extensive core of argument types that it -recognizes. Whenever Hyperbole is prompting you for an argument, it -knows the type that it needs and provides some error checking to help -you get it right. More importantly, it allows you to press the Action -Key within an entity that you want to use as an argument and it will grab the -appropriate thing and show it to you at the input prompt within the -minibuffer. If you press the Action Key again at the same point (click -with a mouse) on the same thing again, it accepts the entity as the -argument and moves on. Thus, a double click registers a desired -argument. Double-quoted strings, pathnames, mail messages, Info nodes, -dired listings, buffers, numbers, completion items and so forth are all -recognized at appropriate times. All of the argument types mentioned in -the documentation for the Emacs Lisp @code{(interactive)} function are -recognized. Experiment a little and you will quickly get used to this -direct selection technique. - -@cindex completion -Wherever possible, standard Emacs completion is offered, see -@ref{Completion,,,emacs, the Gnu Emacs Manual}. Remember to use @{@kbd{?}@} -to see what your possibilities for an argument are. Once you have a -list of possible completions on screen, you can double click the Action -Key on any one to enter it as the argument. - - -@node Outliner, Rolodex, Entering Arguments, Top -@chapter Outliner - -@cindex outliner -@cindex autonumber -@cindex relative autonumber -@cindex permanent identifier -@cindex idstamp -@cindex hyperlink anchor -The Hyperbole outliner, also known as the Koutliner (pronounced -Kay-outliner), produces structured, autonumbered documents composed of -hierarchies of cells. Each @dfn{cell} has two identifiers, a -@dfn{relative identifier} indicating its present position within the -outline and a @dfn{permanent identifier} called an @dfn{idstamp}, -suitable for use within hyperlink references to the cell. The idstamp -is typically not displayed but is available when needed. -@xref{Autonumbering}. - -Cells also store their time of creation and the user who created the -cell. User-defined attributes may also be added to cells. @xref{Cell -Attributes}. - -@cindex menu, Outline -The outliner works only under GNU Emacs version 19 or higher, XEmacs -version 19.9 or higher or under InfoDock. You can tell whether you are -running a version of Emacs which supports the outliner by hitting -@{@kbd{C-h h}@} to display the Hyperbole menu. If you see an -@code{Otl/} entry in the menu, then the outliner is available. -Otherwise, the outliner does not work with your version of Emacs, so -this section of the manual will not be of interest to you. (The same is -true of the Hyperbole/Outline pulldown menu; if it appears, the outliner -is available for use.) - -@vindex file, EXAMPLE.kotl -@cindex menu, Outline/Example -This chapter expands on the information given in @file{EXAMPLE.kotl} -file included with Hyperbole. Use @{@kbd{C-h h o e}@} to display that -file. It is an actual outline file that explains major outliner -operations. You can test out the viewing and motion commands with this -file. If you want to experiment with editing operations, use @{@kbd{C-x -C-w}@} to write the outline to a temporary file such as, -@file{/tmp/e.kotl}, and then use @{@kbd{C-x C-q}@} to make the outline -editable. - -@xref{Outliner Keys}, for a full summary of the key bindings and -commands available in the outliner. - -@menu -* Menu Commands:: -* Creating Outlines:: -* Autonumbering:: -* Idstamps:: -* Editing:: -* Viewing:: -* Links:: -* Cell Attributes:: -* Outliner History:: -@end menu - - -@node Menu Commands, Creating Outlines, Outliner, Outliner -@section Menu Commands - -The Otl/ menu entry on the Hyperbole top-level menu provides access to -a number of major outliner commands: - -@cindex outliner commands -@cindex Koutliner commands -@findex kotl-mode:show-all -@findex kvspec:toggle-blank-lines -@findex kfile:find -@findex kotl-mode:hide-sublevels -@findex kotl-mode:hide-tree -@findex kotl-mode:kill-tree -@findex klink:create -@findex kotl-mode:overview -@findex kotl-mode:show-tree -@findex kotl-mode:top-cells -@findex kvspec:activate -@cindex menu, Outline -@example -@group -Menu Item Command Description -==================================================================== -All kotl-mode:show-all Expand all cells -Blanks kvspec:toggle-blank-lines Toggle blank lines on or off -Create kfile:find Edit or create an outline -Downto kotl-mode:hide-sublevels Hide cells deeper than a level -Examp <sample outliner file> Show self-descriptive example -Hide kotl-mode:hide-tree Hide tree with root at point -Info <outliner documentation> Show outliner manual section -Kill kotl-mode:kill-tree Kill the current tree -Link klink:create Create a link to another cell -Overvw kotl-mode:overview Show first line of each cell -Show kotl-mode:show-tree Show tree with root at point -Top kotl-mode:top-cells Collapse to top-level cells -Vspec kvspec:activate Set a view specification -==================================================================== -@end group -@end example - - -@node Creating Outlines, Autonumbering, Menu Commands, Outliner -@section Creating Outlines - -@cindex outline file suffix -@cindex outline, creating -@vindex file, .kotl suffix -In addition to the Otl/Create menu item, you can create and experiment -with outline files simply by finding a file, @{@kbd{C-x C-f}@} with a -@file{.kotl} suffix. @file{.kot} will also work for DOS or -Windows-impaired users. - -@cindex root cell -@cindex top-level cell -@cindex cell, top-level -@cindex cell, idstamp 0 -When a new koutline is created, an invisible root cell is created. Its -permanent and relative ids are both 0, and it is considered to be at -level 0 in the outline. All visible cells in the outline are at level 1 -or deeper, and thus are descendants of this root cell. Some koutliner -commands prompt for cell numbers as arguments. An argument of 0 makes -commands operate upon the entire outline. - -An initial level 1 cell is also created to make it easy to start -entering text in the outline. A koutline always has at least one -visible cell in it. - -@xref{Autonumbering}, which explains how cells are labeled according to their -respective levels in the outline and how these labels are updated as the -structure of the outline changes. - - -@node Autonumbering, Idstamps, Creating Outlines, Outliner -@section Autonumbering - -@cindex autonumber -@cindex relative identifier -@xref{Adding and Killing}, which explains how to add new cells to or remove -cells from a koutline. As you do this, or as you promote or demote -cells within the outline, the labels preceding the contents of each cell -automatically update to reflect the new structure. These labels are -also known as @dfn{autonumbers} and as @dfn{relative ids} because they -change as the structure changes. - -@cindex outline structure -The outline structure is shown by these labels and by the indentation of -each outline level. Normally, each deeper level is indented another -three characters, to reflect the nesting. - -@cindex label type, alpha -@cindex label type, legal -@cindex alpha labels -@cindex legal labels -@cindex outline, label type -The default autonumbers are called @dfn{alphanumeric labels} because -they alternate between using numbers and letters to distinguish each -successive level. Each alphanumeric label uniquely identifies a cell's -position in an outline, so that there is no need to scan back to prior -cells to see what the current section number of an outline is. This is -similar to a legal numbering scheme but without all the period -characters between level numbers. As an example, 1b3 is equivalent to a -legal label of 1.2.3. Both refer to the 3rd cell at level 3, -below the 2nd child of the first cell at level 1. Said another way, -this is the 3rd child of the 1st cell's 2nd child. In other words, it -is easier to visualize hierarchies than to talk about them. - -Alphanumeric labels are the default because they are shorter and easier -to read aloud than equivalent legal ones. They also simplify -distinguishing between even and odd level labels because of the -alternating character set. - -@kindex C-c C-l -@cindex label type, changing -You can change the labeling scheme used in a particular outline with the -command @{@kbd{C-c C-l}@}. A @{@kbd{?}@} then will show all of your -options. Legal labels, partial alpha labels (single level autonumbering -where only the last part of the level number is shown, as commonly seen -in other outliner products), idstamps (permanent cell ids), and star -outline level labels (Emacs asterisk-based outline labeling) are all -available. Or you may choose to turn autonumbering off. Cells are -still indented to reflect the outline structure whether or not labels -are displayed. - -@cindex label separator, changing -@cindex cell, label separator -@cindex outline, label separator -@kindex C-c M-l -@kindex C-u C-c M-l -A cell label is normally followed by two spaces, called the @dfn{label -separator}, prior to the start of the cell contents. You can change the -separator with for the current outline with @{@kbd{C-c M-l}@}. -@{@kbd{C-u C-c M-l}@} will additionally change the default separator -value used when new outlines are created (for the current session only). -For example, use the value ". " to get a trailing period after each cell -label. The separator must be at least two characters long but may be -longer. - -@vindex file, ~/.emacs -@cindex initialization file -If you find a separator that you prefer for all outlines, change the -separator setting permanently by adding the following line to your Emacs -initialization file, @file{~/.emacs}, substituting for `your-separator': - -@cindex label separator, default -@vindex kview:default-label-separator -@lisp -(setq kview:default-label-separator "your-separator") -@end lisp - - -@node Idstamps, Editing, Autonumbering, Outliner -@section Idstamps - -@cindex permanent identifier -@cindex idstamp -Idstamps (permanent ids) are associated with each cell and can be -used in hyperlinks that are maintained as cells are reordered in a file. -@xref{Links}. Idstamps may also be displayed in place of the outline -level relative ids. Use @{@kbd{C-c C-l id RET}@}. - -@cindex idstamp counter -An idstamp counter for each outline starts at 0 and is incremented by -one each time a cell is added to the outline. This idstamp stays with -the cell no matter where it is moved within the outline. If the cell is -deleted, its idstamp is not reused. - -@cindex root cell -@cindex top-level cell -@cindex cell, top-level -@cindex cell, idstamp 0 -@cindex idstamp 0 -The 0 idstamp is always assigned to the root node of the entire outline. -This node is never visible within the outline, but is used so that the -outline may be treated as a single tree when needed. Idstamps always -begin with a 0, as in 012, to distinguish them from relative ids. - - -@node Editing, Viewing, Idstamps, Outliner -@section Editing - -You edit text and move around in the Koutliner just as you would in any -other Emacs buffer, except when you want to deal with the structural -components of an outline. Within the contents of a cell, all of your -standard editing keys should work properly. You can just type in text -and the left and right margins of the lines will be maintained for you. -@xref{Filling}, for the times when you need to refill a paragraph or to -control when filling occurs.@refill - -Don't invoke editing commands with @{@kbd{M-x command-name @key{RET}}@} -since the Koutliner uses special differently named commands made to act -like the regular editing commands but which account for the structure -and indentation in koutlines. - -@cindex cell, selection -You can use the mouse to select parts of the contents of a single cell -for editing. But don't drag across cell boundaries and then edit the -selected region, since that can destroy the outline structure. - -@menu -* Adding and Killing:: -* Moving Around:: -* Relocating and Copying:: -* Filling:: -* Transposing:: -* Splitting and Appending:: -* Inserting and Importing:: -@end menu - -@node Adding and Killing, Relocating and Copying, Editing, Editing -@subsection Adding and Killing - -@kindex C-j -@kindex C-u c-j -@kindex C-c a -@kindex C-c p -@cindex cell, adding -@cindex cell, creating -@{@kbd{C-j}@} adds a new cell as a successor sibling of the -current cell, that is, the next cell at the same level as the current -cell. If you enter a positive number as a prefix argument, that number -of cells will be inserted, all at the same level. @{@kbd{C-u C-j}@} is -handled specially. It adds a single cell as a child of the current cell. -@{@kbd{C-c a}@} does the same thing. @{@kbd{C-c p}@} adds the cell as -the successor of the current cell's parent. - -@kindex C-c C-k -@kindex C-c k -@kindex C-u C-c k -@kindex C-y -@cindex cell, killing -@cindex cell, yanking contents -@cindex tree, killing -@{@kbd{C-c C-k}@} kills the current cell and its entire subtree. -@{@kbd{C-c k}@} kills the contents of a cell from point through the end -of the cell; it does not remove the cell itself. @{@kbd{C-u C-c k}@} -kills the entire contents of the cell regardless of the location of -point. You may then yank the contents into another cell or another -buffer with @{@kbd{C-y}@}. - - -@node Relocating and Copying, Moving Around, Adding and Killing, Editing -@subsection Relocating and Copying - -@cindex promotion -@cindex demotion -@cindex tree, promoting -@cindex tree, demoting -@dfn{Demotion} is the act of moving a tree down one or more levels in the -outline. The new tree will become either the successor or the first -child of the cell which precedes it in the outline. @dfn{Promotion} is -the inverse operation. Note that trees (cells and their entire -substructure) are promoted and demoted, not individual cells. - -@kindex @key{TAB} -@kindex M-@key{TAB} -Trees may be demoted or promoted by pressing @{@key{TAB}@} or -@{@kbd{M-@key{TAB}}@} respectively, as in most outliners today. -@{@kbd{M-0 @key{TAB}}@} and @{@kbd{M-0 M-@key{TAB}}@} demote and -promote trees and additionally refill each cell that is not specially -marked to prevent refilling. @xref{Filling}. A positive or negative -prefix argument to these commands promotes or demotes the tree up to a -maximum of the number of levels given by the argument. The outline may -not support movement of the tree by the number of levels requested. - -@cindex tree, copying -@cindex tree, moving -@cindex Action Key, cell argument -@kindex Action Key, cell argument -For maximum flexibility in rearranging outlines, there are commands that -move or copy entire trees. Each of these commands prompts for the label -of the root cell to move or copy and for second cell at the new location -for the moved or copied tree. You can either accept the default -provided, type in the cell label or when a mouse is available, simple -double click with the Action Key on the contents of a cell. The -Koutliner knows to use the cell's label in such cases. - -In these following commands, words delimited with <> represent the -arguments for which each command prompts. Note how the use of prefix -arguments changes each command's behavior from insertion at the sibling -level to insertion at the child level. - -@table @kbd -@kindex C-c c -@item C-c c -Copy <tree> to be the successor of <cell>. -@kindex C-u C-c c -@itemx C-u C-c c -Copy <tree> to follow as the first child of <cell>. - -@kindex C-c C-c -@item C-c C-c -Copy <tree> to be the predecessor of <cell>. -@kindex C-u C-c C-c -@itemx C-u C-c C-c -Copy <tree> to be the first child of the parent of <cell>. - -@kindex C-c m -@item C-c m -Move <tree> to be the successor of <cell>. -@kindex C-u C-c m -@itemx C-u C-c m -Move <tree> to follow as the first child of <cell>. - -@kindex C-c C-m -@item C-c C-m -Move <tree> to precede <cell>. -@kindex C-u C-c C-m -@itemx C-u C-c C-m -Move <tree> to be the first child of the parent of <cell>. -@end table - -@cindex mouse, moving trees -If you have mouse support under Hyperbole, you can move entire trees -with mouse clicks. Simply click the Assist Key within the indentation -to the left of a cell and you will be prompted for a tree to move. -Double click the Action Key within the contents the root cell of the tree -to move and then double click within the contents of the root cell of the -tree you want it to follow as a sucessor. - -Copying and moving only work within a single outline right now, so don't -try to use them to move trees across different outline files. You can, -however, copy an outline tree to a non-outline buffer with: - -@cindex tree, exporting -@cindex outline, exporting -@cindex tree, mailing -@cindex outline, mailing -@cindex exporting an outline -@cindex mailing an outline -@table @kbd -@kindex C-c M-c -@item C-c M-c -Copy <tree> to a non-koutline buffer. -@kindex C-c @@ -@itemx C-c @@ -Copy a <tree> to an outgoing mail message. -@end table - -@node Moving Around, Filling, Relocating and Copying, Editing -@subsection Moving Around - -@cindex outline, motion -In addition to normal Emacs movement commands, you can move within a -cell or from one cell or tree to another. - -@table @kbd -@kindex C-c , -@item C-c , -Move to the beginning of the current cell. -@kindex C-c . -@itemx C-c . -Move to the end of the current cell. - -@kindex C-c C-n -@item C-c C-n -Move to the next visible cell, regardless of level. -@kindex C-c C-p -@itemx C-c C-p -Move to the previous visible cell, regardless of level. - -@kindex C-c C-f -@item C-c C-f -Move forward to this cell's successor, if any. -@kindex C-c C-b -@itemx C-c C-b -Move backward to this cell's predecessor, if any. - -@kindex C-c C-d -@item C-c C-d -Move to the first child of the current cell, if any. -@kindex C-c C-u -@itemx C-c C-u -Move to the parent cell of the current cell, if any. - -@kindex C-c < -@item C-c < -Move to the first sibling at the current level within this tree. -@kindex C-c > -@itemx C-c > -Move to the last sibling at the current level within this tree. - -@kindex C-c ^ -@item C-c ^ -Move to the level 1 root cell of the current tree. -@kindex C-c $ -@itemx C-c $ -Move to the last cell in the tree rooted at point, regardless of level. -@end table - - -@node Filling, Transposing, Moving Around, Editing -@subsection Filling - -@cindex outline, filling -Filling is the process of extending lines that are shorter than the -right margin and reducing lines which extend past the margin by moving -words among the lines. Commands are provided to fill a paragraph within -a cell or a whole cell, which may have multiple paragraphs. - -@cindex filling -@cindex cell, filling -@cindex paragraph, filling -@cindex tree, filling -@cindex margin -@kindex M-q -@kindex M-j -@kindex C-c M-q -@kindex C-c M-j -@kindex C-M-q -@kindex C-M-j -@{@kbd{M-q}@} or @{@kbd{M-j}@} refills a paragraph within a -cell so that its lines wrap within the current margin settings. -@{@kbd{C-c M-q}@} or @{@kbd{C-c M-j}@} refills all paragraphs within a -cell. @{@kbd{C-M-q}@} or @{@kbd{C-M-j}@} refills all cells within a -tree. See your Emacs or InfoDock manual for information on how to set -the left and right margins. - -@vindex kotl-mode:refill-flag -@cindex refilling -@cindex attribute, no-fill -@cindex cell, no-fill attribute -Set the variable, @var{kotl-mode:refill-flag}, to t if you want -moving, promoting, demoting, exchanging, splitting and appending cells -to also automatically refill each cell. Generally, this is not -recommended since if you happen to move a cell that you have carefully -formatted and forgot to give it a `no-fill' property, your formatting -will be lost. - - -@node Transposing, Splitting and Appending, Filling, Editing -@subsection Transposing - -The Koutliner move and copy commands rearrange entire trees. The -following two commands, in contrast, exchange the locations of two -individual cells. - -@kindex C-c e -@cindex cell, transposing -@cindex cell, exchanging -@cindex exchanging cells -@cindex transposing cells -@{@kbd{C-c e}@} prompts for two cell addresses and exchanges the cell -locations. - -@kindex C-c t -@{@kbd{C-c t}@} does not prompt. It exchanges the current -and immediatly prior cell, regardless of their levels. If there is no -prior cell it exchanges the current and next cell. - -@cindex cell, mark and point -@kindex M-0 C-c t -@{@kbd{M-0 C-c t}@} exchanges the cells in which point and mark fall. -@{@kbd{C-c t}@} with a non-zero numeric prefix argument, N, moves -the current tree past maximally the next N visible cells. If there are -fewer visible, it makes the current cell the last cell in the outline. - - -@node Splitting and Appending, Inserting and Importing, Transposing, Editing -@subsection Splitting and Appending - -@cindex splitting a cell -@cindex cell, splitting -@kindex C-c s -@kindex C-u C-c s -You can split one cell into two adjacent sibling cells with @{@kbd{C-c -s}@}. This leaves the cell contents preceding point in the current -cell, minus any trailing whitespace, and moves the contents following -point to a new sibling cell which is inserted into the outline. -@{@kbd{C-u C-c s}@} instead adds the new cell as the first child of the -original cell, rather than as its successor. - -All cell attributes in the original cell are propagated to the new one, -aside from the creation attributes and idstamp. - -@kindex C-c + -@cindex cell, appending -@cindex appending to a cell -@cindex attribute, no-fill -@cindex cell, no-fill attribute -@{@kbd{C-c +}@} appends the contents of a specified cell to the end of -another cell. It has no effect on cell attributes, except that if one -cell has a `no-fill' attribute that prevents all but user requested -filling of a cell, then the cell appended to inherits this property. -This helps maintain any special formatting the appended text may have. - - -@node Inserting and Importing, , Splitting and Appending, Editing -@subsection Inserting and Importing - -@cindex outline, inserting into -@cindex outline, importing into -@cindex importation -@cindex insertion -@kindex C-x i -@cindex outline, foreign file -The elements of another buffer or file may be inserted into a koutline -as a set of cells by using the @{@kbd{C-x i}@} command. When prompted, -you may use a buffer name or file name from which to insert, though -completion is provided only for file names. - -@kindex C-u C-x i -The elements from the original buffer are converted into kcells and -inserted as the successors of the current cell. If @{@kbd{C-u C-x i}@} -is used, they are instead inserted as the inital children of the current -cell. - -@vindex kimport:mode-alist -@vindex kimport:suffix-alist -@cindex outline, conversion -@findex kotl-mode -@cindex outline mode -@cindex koutline mode -@cindex file, importing -@cindex importing a file -See the documentation for the variables, kimport:mode-alist and -kimport:suffix-alist, for information on mode and suffix-specific -conversions performed on file elements before they are inserted. This -same conversion process applies if you invoke @{@kbd{M-x kotl-mode -RET}@} in a non-koutline buffer or if you perform a generic file import -as described later in this section. - -@findex kotl-mode:insert-file-contents -Use @{@kbd{M-x kotl-mode:insert-file-contents RET}@} to insert the -entire contents of a file into the current cell at the location of -point. - -@findex kimport:file -The outliner presently supports conversion of three types of files into -koutline files. You can choose to import a file into an existing -koutline, following the tree at point, or to create a new koutline of -the imported file contents. @{@kbd{M-x kimport:file RET}@} will select -the importation type based on the buffer or file name suffix of the file -to import. - -@findex kotl-mode -If you want to convert a buffer from some other mode into a koutline and -then want to save the converted buffer back to its original file, -thereby replacing the original format, then use @{@kbd{M-x kotl-mode -RET}@} to convert the buffer into a koutline. Remember that you will -lose the old format of the buffer when you do this. - -Use one of the following commands if you really need explicit control over the -type of importation used on some text. With these commands, your -original file remains intact. - -@findex kimport:text -@cindex text file -Use @{@kbd{M-x kimport:text RET}@} and you will be prompted for a text -buffer or file to import and the new koutline buffer or file to create -from its text. It will also import the contents, attributes and level -structure of cells from a koutline. - -@findex kimport:star-outline -@cindex emacs outline -@cindex star outline -Star outlines are standard Emacs outlines where each entry begins with -one or more asterisk characters. Use @{@kbd{M-x kimport:star-outline -RET}@} and you will be prompted for the star outline buffer or file to -import and the new koutline buffer or file to create. - -@cindex Augment outline -@findex kimport:aug-post-outline -(Skip this if you are unfamiliar with the Augment system.) Files -exported from the Augment system as text often have alphanumeric -statement identifiers on the right side. You can import such files -while maintaining there outline structure. Use @{@kbd{M-x -kimport:aug-post-outline RET}@} and you will be prompted for the Augment -buffer or file to import and the koutline to create. - - -@node Viewing, Links, Editing, Outliner -@section Viewing - -@cindex outline, viewing -@cindex view -The Koutliner has very flexible viewing facilities to allow you to -effectively browse and study large amounts of material. - -@menu -* Hiding and Showing:: -* View Specs:: -@end menu - -@node Hiding and Showing, View Specs, Viewing, Viewing -@subsection Hiding and Showing - -@cindex outline, hiding -@cindex outline, showing -@cindex collapsing -@cindex expanding -@cindex hiding -@cindex showing -Individual cells, branches, or particular levels in the outline may be -hidden or shown. These commands work even when an outline buffer is -read-only, e.g. when its file is not checked out of a version control -system yet, so that you can get effective views of an outline without -editing it. Some of these commands affect the current view spec, -@ref{View Specs}. - -@table @kbd -@cindex hide tree -@cindex tree, show -@kindex C-c C-h -@item C-c C-h -Hide (collapse) the tree rooted at point. -@cindex show tree -@cindex tree, show -@kindex C-c C-s -@itemx C-c C-s -Show (expand) the tree rooted at point. - -@cindex outline, all cells -@cindex cell, show all -@kindex C-c C-a -@item C-c C-a -Show (expand) all of the cells in the outline. -@cindex level -@cindex cell, show levels -@cindex outline, show levels -@kindex C-x $ -@itemx C-x $ -Show all of the cells down to a particular <level>. You are prompted -for the level or a prefix argument may be given. - -@cindex subtree, hide -@cindex tree, hide subtree -@cindex cell, hide subtree -@cindex hide subtree -@kindex C-M-h -@item C-M-h -Hide the subtree at point, excluding the root cell. -@cindex subtree, show -@cindex tree, show subtree -@cindex cell, show subtree -@cindex show subtree -@itemx M-x kotl-mode:show-subtree -Show the subtree at point. Use @{@kbd{C-c C-s}@} to achieve a similar -effect. The only difference is that it will expand the root cell too. - -@cindex overview -@cindex outline, overview -@kindex C-c C-o -@item C-c C-o -Show an overview of the outline by showing only the first line of -every cell. This also turns off blank lines between cells to maximize -your view of the outline. -@cindex top-level view -@cindex outline, top-level -@kindex C-c C-t -@itemx C-c C-t -Show a top-level view of the outline by showing only the first line of -each level one cell. This does not turn off blank lines. -@end table - -@kindex Action Key, hide or show cell -@cindex Action Key, hide or show cell -@cindex cell, collapse -@cindex cell, expand -@kindex M-@key{RET} -A click or a press of the Action Key within a cell's body, but not on a -Hyperbole button, toggles between hiding and showing the tree rooted at -point. Try it with either your mouse or with @{@kbd{M-@key{RET}}@}. - - -@node View Specs, , Hiding and Showing, Viewing -@subsection View Specs - -@cindex view spec -@cindex modeline, view spec -@vindex kvspec:string -@cindex pipe character -@cindex | -@cindex <|viewspec> -@dfn{View specifications} (view specs, for short) are short codes used -to control the view of a koutline. The view specs in effect for an -outline are always displayed in the modeline of the outline's window, -following the outline buffer name, unless the variable, -@var{kvspec:string}, has been set to @code{nil} to disable view spec -modeline display. The modeline display appears as <|viewspec> so that -you can easily pick them out. The | (pipe character) is also used in -links that specify view specs to indicate the start of a view spec -sequence. @xref{Links}. - -@cindex outline, view specs -The current view spec is saved whenever the outline is saved. The next -time the outline is read in, this will be the initial view. - -The rest of this section documents the the view spec characters that are -presently supported and explains how to invoke a view spec. There is no -user-level way to add your own view spec characters, so all character -codes are reserved for future use. - -@kindex C-c C-v -@cindex view spec, setting -@cindex view spec, changing -@cindex changing the view spec -@cindex setting the view spec -@{@kbd{C-c C-v}@} prompts for a new view spec setting in which the following -codes are valid. Any invalid characters in a view spec are ignored. -Characters are evaluated in an order meant to do the right thing, even -when you use conflicting view spec characters. The standard initial -view spec is <|ben>. - -@cindex view spec, characters -@table @kbd -@cindex view spec, all lines and levels -@item a -Show all cell levels and all lines in cells. - -@kindex C-c b -@cindex blank lines, toggle -@cindex view spec, blank lines -@kindex C-c b -@cindex toggling blank lines -@item b -Turn on blank lines between cells. Without this character, blank lines -will be turned off. You can also use the @{@kbd{C-c b}@} key binding to -toggle line numbers on and off independent of any other view settings. - -@cindex view spec, lines per cell -@cindex hide lines -@cindex collapse lines -@cindex cutoff lines -@item cN -Hide any lines greater than N in each cell. 0 means don't cutoff any -lines. - -@cindex ellipses -@cindex view spec, ellipses -@item e -Show ellipses when some content of a cell or its subtree is hidden. - -@cindex level -@cindex cell, hiding levels -@cindex hide levels -@cindex view spec, show levels -@item lN -Hide cells at levels deeper than N. 0 means don't hide any cells. - -@cindex label type -@cindex view spec, label type -@vindex kview:default-label-type -@cindex default label type -@item n -Turn on the default label type, as given by the variable, -@var{kview:default-label-type}. Normally, this is alphanumeric labels. -@cindex label type, idstamps -@itemx n0 -Display idstamps. -@cindex label type, alpha -@itemx n1 -Display alpha labels. -@cindex label type, partial alpha -@itemx n2 -Display partial alpha labels (don't use this, as full alpha labels are -better). -@cindex label type, legal -@itemx n. -Display legal labels. -@cindex label type, star -@cindex label type, asterisk -@itemx n* -Display star labels. A level three cell would have three asterisks as a -label, for example. -@cindex label type, no labels -@itemx n~ -Turn off labels. (n viewspec is removed from modeline). -@end table - -@cindex view spec, example -As a test, use @{@kbd{C-h h o e}@} to display the example koutline. -Then use @{@kbd{C-c C-v}@} to set a view spec of `c2l1'. This will turn -off blank lines, clip each cell after its second line, and hide all -cells below level one. - - -@node Links, Cell Attributes, Viewing, Outliner -@section Links - -@cindex link -@cindex hyperlink -@cindex klink -@cindex <> delimiters -Hyperlinks may be embedded in cells and may refer to other cells or -external sources of information. Explicit Hyperbole buttons may be -created as usual via mouse drags, @ref{By Dragging, Creation Via Action -Key Drags}. A @dfn{klink} is a special implicit link button, delimited -by <> separators, that jumps to a specific outline cell. This section -discusses klinks. - -@kindex Action Key, klink -@cindex Action Key, klink -@cindex klink, activating -@cindex klink referent -Press the Action Key over a klink to follow it. This will flash the -klink as a button and then will display its referent in the other -window. If the klink contains a view spec, that will be used when the -referent is displayed. - -@cindex klink, inserting -@kindex C-c l -There are a number of easy ways to insert klinks into koutlines. If you -have mouse support under Hyperbole, simply click the Action Key within -the indentation to the left of a cell text. If you then double click on -some cell, a link to that cell will be inserted where you started. From -a keyboard, use @{@kbd{C-c l}@} when in a koutline or @{@kbd{C-h h o -l}@} when not in a koutline to insert a klink. Since klinks are -implicit buttons, you can type in the text of the klink just as you see -it in the examples below and it will work exactly as if it had been -entered with the insert link command. - -@cindex klink, formats -@noindent -There are basically three forms of klinks: - -@table @bullet -@cindex internal klink -@cindex klink, internal -@cindex <@@ klink> -@item internal -<@@ 2b=06> is an internal klink, since it refers to the koutline in which -it is embedded. When activated, it jumps to the cell within the current -outline which has permanent id `06' and relative id `2b'. <@@ 06> does -the same thing, as does <@@ 2b>, though this latter form will not -maintain the link properly if the cell is moved elsewhere within the -outline. The form, <@@ 2b=06 |ben> additionally sets the view spec of -the current outline back to the default value, with a blank line between -each cell and all levels and lines of cells displayed. - -@cindex external klink -@cindex klink, external -@item external -The second klink format is an external link to another koutline, such -as, <EXAMPLE.kotl, 3=012 |c1e>, which displays the named file, starting -at the cell 3 (whose permanent identifer is 012), with the view -specification of: blank lines turned off, cutoff after one line per -cell, and show ellipses for cells or trees which are clipped. - -@cindex klink, view spec -@cindex view spec klink -@item view spec -The third format simply allows you to set a view spec for the current -koutline. For example, <|ben>, when activated, sets the view in the -current outline to display blank lines, ellipses following collapsed -lines and standard alphanumeric numbering. -@end table - - -@node Cell Attributes, Outliner History, Links, Outliner -@section Cell Attributes - -@cindex cell, attribute -@cindex attribute -@dfn{Attributes} are named variables whose values are specific to a -particular outline cell. Thus, each cell has its own attribute list. -Every cell has three standard attributes: - -@table @bullet -@cindex idstamp attribute -@item idstamp -The permanent id of the cell, typically used in cross-file hyperlinks -that reference the cell. - -@cindex creator attribute -@cindex e-mail address -@cindex mail address -@item creator -The e-mail address of the person who created this cell. - -@cindex create-time attribute -@cindex cell, creation time -@item create-time -The time at which the cell was created. This is stored in a form that -allows for easy data comparisons but is displayed in a human readable -format, such as "Jan 28 18:27:59 CST 1994". -@end table - -@kindex C-c C-i -@cindex attribute, adding -@cindex attribute, modifying -@cindex attribute, removing -@{@kbd{C-c C-i}@} is the command to add an attribute to or to modify an -existing attribute in the cell at point. Think of it as inserting an -attribute value. To remove an attribute from cell, set its value to -@code{nil}. - - -@cindex attribute, no-fill -@cindex cell, no-fill attribute -@cindex no-fill attribute -@vindex kotl-mode:refill-flag -The `no-fill' attribute is special. When added with a non-nil value, it -prevents moving, promoting, demoting, exchanging, splitting and -appending cells from refilling the cell, even if the variable, -@var{kotl-mode:refill-flag}, is set to t. It does not prevent you from -invoking explicit commands that refill the cell. @xref{Filling}. - -@kindex Assist Key, listing attributes -@cindex Assist Key, listing attributes -@cindex listing attributes -@cindex outline, attribute list -The attribute lists for the cells in the tree rooted at point can be -displayed by pressing the Assist Key within the contents of a cell. - -@kindex C-c h -@kindex C-u C-c h -@{@kbd{C-c h}@} prompts for a cell label and displays the cell's -attributes. @{@kbd{C-u C-c h}@} prompts for a cell label and displays -the attributes for it and its subtree; use 0 as the kcell id to see -attributes for all visible cells in the outline. - - -@node Outliner History, , Cell Attributes, Outliner -@section Outliner History - -@cindex NLS -@cindex Augment -@cindex Engelbart -Much of the Hyperbole outliner design is based upon concepts pioneered -in the NLS/Augment system, @cite{[Eng84a]}. Augment treated documents as -a hierarchical set of nodes, called statements, rather than cells. -Every Augment document utilized this intrinsic structure. - -@cindex distributed collaboration -@cindex collaboration -The system could rapidly change the view of a document by collapsing, -expanding, generating, clipping, filtering, including or reordering -these nodes. It could also map individual views to multiple workstation -displays across a network to aid in distributed, collaborative work. - -@cindex knowledge transfer -@cindex idea structuring -@cindex cross referencing -These facilities aided greatly in idea structuring, cross-referencing, -and knowledge transfer. The Koutliner is a start at bringing -these capabilities back into the mainstream of modern computing culture. - - -@node Rolodex, Window Configurations, Outliner, Top -@chapter Rolodex - -@cindex rolodex -@cindex wrolo -Hyperbole includes a complete, advanced rolodex system, Wrolo, for -convenient management of hierarchical, record-oriented information. - -@cindex rolo, buttons in -Hyperbole buttons may be included within rolodex records and then -manually activated whenever their records are retrieved. - -@vindex file, wrolo.el -See the description at the top of the @file{wrolo.el} file for -details on programmatic interfacing to the rolodex. The following -subsections explain use and basic customization of the rolodex. - -@menu -* Rolo Concepts:: -* Rolo Menu:: -* Rolo Keys:: -* Rolo Settings:: -@end menu - -@node Rolo Concepts, Rolo Menu, Rolodex, Rolodex -@section Rolo Concepts - -@cindex rolodex file -@cindex rolodex entry -The rolodex manages and searches rolodex files. A @dfn{rolodex file} -consists of an optional header which starts and ends with a line of -equal signs (at least three equal signs starting at the beginning of a -line), followed by any non-negative number of rolodex records. You must -manually add a header to any rolodex file if you want it to have one. - -@noindent -Here is an example of a simple rolodex file. - -@example -@group -================================================================== - PERSONAL ROLODEX -<Last-Name>, <First> <Email> W<Work#> F<Fax#> -================================================================== -* Smith, John <js@@hiho.com> W708-555-2001 F708-321-1492 - Chief Ether Maintainer, HiHo Industries - 10/24/95 -@end group -@end example - -We call rolodex records, @dfn{entries}. Entries begin with a delimiter -of one or more `*' characters at the beginning of a line. Entries may -be arranged in a hierarchy, where child entries begin with one more `*' -character than do their parents. Top level entries begin with a single -`*'. - -Beyond this initial delimiter, entries are completely free-form text. -It is best to use a "lastname, firstname" format, however, when adding -contact entries into a rolodex. Then the rolodex system will -automatically keep your entries alphabetized as you enter them. You'll -also be able to sort them whenever you desire. This is what the -rolodex will use if you accept the default entry that it prompts you -with when adding a new entry. - -Any search done on the rolodex scans the full text of each entry. -During a search, the rolodex file header separator lines and anything in -between are appended to the buffer of matched entries before any entries -are retrieved from the file. Whenever an entry is matched, it and all -of its descendant entries are retrieved. If your Emacs version supports -textual highlighting, each search match is highlighted for quick, visual -location. - -@noindent -For example, a search on "Company" could retrieve the following: - -@example -@group -================================================================== - COMPANY ROLODEX -================================================================== -* Company -** Manager -*** Underlings -@end group -@end example - -@noindent -Thus, searching for Company retrieves all listed employees. -Searching for Manager turns up all Underlings. - - -@node Rolo Menu, Rolo Keys, Rolo Concepts, Rolodex -@section Rolo Menu - -@cindex rolodex menu -The Rolo/ menu entry on the Hyperbole top-level menu provides the -user interface to the rolodex. The rolo menu provides access to the -following commands: - -@cindex rolodex commands -@cindex Wrolo commands -@findex rolo-add -@findex rolo-display-matches -@findex rolo-edit -@findex rolo-kill -@findex rolo-mail-to -@findex rolo-sort -@findex rolo-grep -@findex rolo-fgrep -@findex rolo-word -@findex rolo-yank -@example -@group -Menu Item Command Description -==================================================================== -Add rolo-add Adds a rolodex entry -Display rolo-display-matches Displays last matches again -Edit rolo-edit Edits an existing rolodex entry -Info Displays Rolodex manual entry -Kill rolo-kill Removes an entry from the rolodex -Mail rolo-mail Mail to address following point -Order rolo-sort Sorts all levels in rolodex -RegexFind rolo-grep Finds all entries containing - a regular expression -StringFind rolo-fgrep Finds all entries containing - a string -WordFind rolo-word Finds all entries containing - a string of whole words -Yank rolo-yank Inserts first matching rolodex - entry at point -==================================================================== -@end group -@end example - -A prefix argument used with either of the find commands listed above -limits the search to a maximum number of matches given by the argument. -The search is terminated whenever that number of matches is found. - -For any of the above commands that prompt for a name, you may use the -form parent/child to locate a child entry below a parent entry. So for -a rolodex which looked like so: - -@example -@group -* Company -** Manager -*** Underlings -@end group -@end example - -@noindent -You could edit the Underlings entry by identifying it as -Company/Manager/Underlings. Do not use this hierarchical notation in -search expressions since the whole rolodex will be searched anyway. -Thus, "Underlings" as a search pattern will find an entry containing -"Underlings" at any level in a hierarchy, like so: - -@example -*** Underlings -@end example - -@node Rolo Keys, Rolo Settings, Rolo Menu, Rolodex -@section Rolo Keys - -@kindex e -@cindex rolodex, editing -@cindex datestamps -@cindex rolodex, datestamps -@cindex customization, rolodex datestamps -@cindex menu, Toggle-Rolo-Dates -@cindex customization, rolodex edits -@cindex customization, rolodex additions -@vindex wrolo-edit-hook -@vindex wrolo-add-hook -Use the @{@kbd{e}@} key to edit the entry at point within the rolodex -source file. A datestamp will be automatically added or updated at the -end of the entry, unless this feature has been turned off via the -Cust/Toggle-Rolo-Dates menu item. The variable, @var{wrolo-edit-hook}, -is evaluated after the update of the entry datestamp. This allows -programmed modification of the way rolodex edits work. The variable, -@var{wrolo-add-hook}, works the same way but is evaluated when a new -entry is first added. - -@cindex wrolo menu -@cindex rolodex keys -After a rolodex search is performed, point is left in the @dfn{rolodex -match buffer}, @file{*Rolodex*}, which uses @code{wrolo-mode} to -simplify browsing many rolodex matches. Press @{@kbd{?}@} when in the -match buffer for a summary of available keys. - -@kindex TAB -@kindex M-TAB -@kindex r -@cindex rolodex, highlighting matches -@cindex rolodex, finding matches -@cindex rolodex, moving through matches -If your Emacs version supports textual highlighting, each search match -is highlighted for quick, visual location. @{@key{TAB}@} moves point -forward to successive spans of text which match the search expression. -@{@kbd{M-@key{TAB}}@} or @{@kbd{r}@} moves point backward to earlier -matches. These keys allow you to quickly find the matching entry of -most interest to you if your search expression failed to narrow the -matches sufficiently. - -@kindex M-s -@kindex C-r -@cindex rolodex, extending a match -@cindex rolodex, interactive searching -If you want to extend the match expression with some more characters to -find a particular entry, use @{@kbd{M-s}@}, which performs an -interactive search forward for the match expression. You can add or -delete characters to this expression to find different occurences. -@{@kbd{C-r}@} will reverse the direction of the search. - -@kindex a -@kindex h -@kindex s -@kindex t -@cindex rolodex, outlining -Single key outlining commands are also available for browsing matches. -If your search matches a large number of entries, use -@{@kbd{t}@} to get a top-level overview of all the entries. Each entry -is collapsed so that only its first line shows. Press @{@kbd{s}@} to -show (expand) the entry at point. Use @{@kbd{h}@} to hide (collapse) -the entry again. Press @{@kbd{a}@} to expand all entries in the buffer. - -Many other keys are defined to help you move through matching entries. - -@cindex rolodex, moving to entries -@table @kbd -@kindex b -@item b -Move to the previous entry at the same level as the current entry. -@kindex f -@item f -Move to the next entry at the same level as the current entry. -@kindex n -@item n -Move to the next entry at any level. -@kindex p -@item p -Move to the previous entry at any level. -@kindex u -@item u -Move the the previous entry one level up. -@kindex . -@kindex < -@item . -@itemx < -Move to the beginning of the buffer. -@kindex , -@kindex > -@item , -@itemx > -Move to the end of the buffer. -@kindex @key{DEL} -@item @key{DEL} -Scroll backward a windowful. -@kindex @key{SPC} -@item @key{SPC} -Scroll forward a windowful. -@end table - -@kindex q -@cindex rolodex, quitting -Once you have found an entry of interest and you want to remove the -rolodex match buffer, use @{@kbd{q}@} to quit. This will restore your -current frame to its state prior to the rolodex search. - -@node Rolo Settings, , Rolo Keys, Rolodex -@section Rolo Settings - -@vindex rolo-highlight-face -@cindex rolodex, highlighting matches -If textual highlighting is available in your Emacs on your current -display type, the rolodex uses the value of @var{rolo-highlight-face} as -the face to use to highlight search matches. - -@vindex rolo-kill-buffers-after-use -The buffers containing the rolodex files are not killed after a search -on the assumption that another search is likely to follow within this -Emacs session. You may wish to change this behavior with the following -setting: @code{(setq rolo-kill-buffers-after-use t)}. - -@vindex rolo-save-buffers-after-use -After an entry is killed, the modified rolodex file is automatically -saved. If you would rather always save files yourself, use this -setting: @code{(setq rolo-save-buffers-after-use nil)}. - -@vindex rolo-email-format -When adding an entry from within a buffer that contains a mail message, -the rolodex add function will extract the sender's name and e-mail address -and prompt you with the name as a default. If you accept it, it will -enter the name and the email address using the format given by the -@var{rolo-email-format} variable. See its documentation if you want to -change its value. - -@vindex rolo-file-list -@cindex rolodex, personal -The files used in any rolodex search are given by the -@var{rolo-file-list} variable, whose default value is -@code{("~/.rolodex.otl")}, so that searches initially scan only your -personal rolodex. Any entries added to this list should be file -pathnames. If a file in the list does not exist or is not readable, it -is skipped. Files are searched in the order in which they appear in the -list. In general, you should leave your personal rolodex file as the -first entry in the list, since this is the only file to which the rolo -menu Add command adds entries.@refill - -@vindex rolo-entry-regexp -The rolodex entry start delimiter is given by the regular expression -variable, @var{rolo-entry-regexp}, whose default value is "^\*+". - -@vindex rolo-hdr-regexp -A rolodex file may begin with an optional header section which is copied -to the match display buffer whenever any matches are found during a -search. The start and end lines of this header are controlled by -the regular expression variable, @var{rolo-hdr-regexp}, whose default -value is "^===". This allows lines of all equal signs to visually -separate matching entries from multiple files retrieved from a single -search. - -@node Window Configurations, Developing with Hyperbole, Rolodex, Top -@chapter Window Configurations - -@cindex window configurations -@cindex restoring windows -@cindex saving window configurations -@vindex file, wconfig.el -Hyperbole includes the @file{wconfig.el} package which lets you save and -restore window configurations, i.e@. the window layout and buffers -displayed within an Emacs frame. This is useful to save a particular -working context and then to jump back to it at a later time during an -Emacs session. It is also useful during demonstrations to pull up many -informational artifacts all at once, e.g@. all of the windows for a -particular subsystem. None of this information is stored between Emacs -sessions, so your window configurations will last only through a single -session of use. - -The wconfig library provides two distinct means of managing window -configurations. The first means associates a name with each stored -window configuration. The name can then be used to retrieve the window -configuration later. The second means uses a ring structure to save -window configurations and then allows browsing through the sequence of -saved configurations. - -The Win/ menu entry on the Hyperbole top-level menu displays a menu of -window configuration commands: - -@noindent -@display -WinConfig> AddName DeleteName RestoreName PopRing SaveRing YankRing -@end display - -@cindex wconfig commands -@cindex window configuration commands -@findex wconfig-add-by-name -@findex wconfig-delete-by-name -@findex wconfig-restore-by-name -@findex wconfig-delete-pop -@findex wconfig-ring-save -@findex wconfig-yank-pop -@example -@group -Menu Item Command Description -==================================================================== -AddName wconfig-add-by-name Name current wconfig -DeleteName wconfig-delete-by-name Delete wconfig with name -RestoreName wconfig-restore-by-name Restore wconfig by name - -PopRing wconfig-delete-pop Restore and delete wconfig -SaveRing wconfig-ring-save Store wconfig to ring -YankRing wconfig-yank-pop Restore next wconfig -==================================================================== -@end group -@end example - -Saving and restoring window configurations by name is the easiest -method, but it requires that you input the chosen name from the -keyboard. The ring commands permit saving and restoring through mouse -interaction only, if so desired. The prior section, @ref{Smart Keys}, -mentions how to save and restore window configurations with the Smart Keys. -Since the ring commands are a bit more complex than their by-name -counterparts, the following paragraphs explain them in more detail. - -@vindex kill-ring -Wconfig creates a ring structure that operates just like the Emacs -@var{kill-ring}, @ref{Kill Ring,,,emacs, The GNU Emacs Manual}, but its -elements are window configurations rather than text regions. One can -add an element to the ring based upon the current window configuration. -After several elements are in the ring, one can walk through all of them -in sequence until the desired configuration is restored. - -@findex wconfig-ring-save -SaveRing executes the @code{wconfig-ring-save} command which -saves the current window configuration to the ring. - -@findex wconfig-yank-pop -YankRing executes the @code{wconfig-yank-pop} command. It restores the -window configuration from the currently pointed to configuration in the -ring. It does not delete this configuration from the ring but it does -move the pointer to the prior ring element. Repeated calls to this -command thus restore successive window configurations until the ring -pointer wraps around. Simply stop when a desired configuration appears -and use @{@kbd{q}@} to quit from the minibuffer menu. - -@findex wconfig-delete-pop -PopRing calls the @code{wconfig-delete-pop} command. -It is used to restore a previously saved configuration and at the same -time delete it from the ring. Simply stop when a desired configuration -appears and use @{@kbd{q}@} to quit from the minibuffer menu. - -@vindex wconfig-ring-max -The maximum number of elements the ring can hold is set by the -@var{wconfig-ring-max} variable whose default is 10. Any saves beyond -this value cause deletion of the oldest element in the ring before -a new one is added. - -@node Developing with Hyperbole, Glossary, Window Configurations, Top -@chapter Developing with Hyperbole - -This chapter is only for people who are familiar with Emacs Lisp and -wish to customize Hyperbole, to extend it, or to develop other systems -using Hyperbole as a base. - -@menu -* Hook Variables:: -* Creating Types:: -* Explicit Button Technicalities:: -* Encapsulating Systems:: -* Embedding Hyperbole:: -@end menu - -@node Hook Variables, Creating Types, Developing with Hyperbole, Developing with Hyperbole -@section Hook Variables - -@cindex variables -@cindex hook variables -Hyperbole provides a number of hook variables that allow you to adjust -its basic operations to meet your own needs, without requiring you to -change the code for those operations. - -We find it best to always set the value of hook variables either to nil -or to a list of function names of no arguments, each of which will be -called in sequence when the hook is triggered. - -Given the name of a function, a Hyperbole hook variable triggered within -that function has the same name as the function with a @code{-hook} -appended. Hyperbole provides the following hook variables: - -@table @var - -@vindex hyperb:init-hook -@item hyperb:init-hook -For customization at Hyperbole initialization time. Use this to load -any personal Hyperbole type definitions you might have. It is run after -Hyperbole support code is loaded but before Hyperbole session -initializations take place. - -@vindex action:act-hook -@vindex hbut:current -@item action:act-hook -Run before each Hyperbole button activation. -The variable @var{hbut:current} contains the button to be activated when -this is run. - -@vindex ebut:create-hook -@item ebut:create-hook -To add to the Hyperbole explicit button creation process. - -@vindex ebut:delete-hook -@item ebut:delete-hook -To add to the Hyperbole explicit button deletion process. - -@vindex ebut:modify-hook -@item ebut:modify-hook -Executed when an explicit button's attributes are modified. - -@vindex hibtypes:begin-load-hook -@item hibtypes:begin-load-hook -Executed prior to loading of standard Hyperbole implicit button types. -Used to load site-specific low priority implicit button types since -lowest priority ibtypes are loaded first. - -@vindex hibtypes:end-load-hook -@item hibtypes:end-load-hook -Executed after loading of standard Hyperbole implicit button types. -Used to load site-specific high priority implicit button types since -highest priority ibtypes are loaded last. - -@vindex htype:create-hook -@item htype:create-hook -Executed when a Hyperbole type (e.g@. action type or implicit button -type) is added to the environment. - -@vindex htype:delete-hook -@item htype:delete-hook -Executed when a type is deleted from the environment. - -@vindex kotl-mode-hook -@item kotl-mode-hook -Executed when a Koutline is created or read in or when kotl-mode is -invoked. - -@vindex wrolo-display-hook -@item wrolo-display-hook -Executed when rolodex matches are displayed. - -@vindex wrolo-mode-hook -@item wrolo-mode-hook -Executed when a rolodex match buffer is created and put into wrolo-mode. - -@vindex wrolo-yank-reformat-function -@cindex yank, reformatting -@item wrolo-yank-reformat-function -A variable whose value may be set to a function of two arguments, START -and END, indicating the region of the rolodex entry yanked into the -current buffer by the rolo-yank command. The function may reformat this -region to meed user-specific needs. - -@end table - -@noindent -Hyperbole also makes use of a number of external Emacs hook variables. - -@table @var - -@vindex find-file-hooks -@cindex button highlighting -@item find-file-hooks -This is called whenever a file is read into a GNU Emacs buffer. -Hyperbole uses it to highlight any buttons within files when run under -any NEXTSTEP or X window system-based versions of GNU Emacs. - -@vindex write-file-hooks -@cindex button data saving -@item write-file-hooks -This is called whenever a GNU Emacs buffer is written to a file. -Hyperbole uses it to save any modified button data associated with the -file's directory. - -@cindex mail hooks -@cindex news hooks -Hyperbole mail and news facilities also utilize a number of external hook -variables. These hide button data and highlight buttons if possible. -See the various support files for details. -@end table - -@node Creating Types, Explicit Button Technicalities, Hook Variables, Developing with Hyperbole -@section Creating Types - -@cindex type definition -@cindex type redefinition -@noindent -To define or redefine a single Hyperbole type, you may either: - -@itemize @bullet -@kindex C-M-x -@findex eval-defun -@kindex C-x C-e -@findex eval-last-sexp -@item -move your Emacs point to within the type definition and use -@{@kbd{C-M-x}@} @code{(eval-defun)} (only works in Emacs Lisp mode); - -@item -or move your point to the end of the last line of the type definition and -use @{@kbd{C-x C-e}@} @code{(eval-last-sexp)} (works in most modes). -@end itemize - -@cindex Hyperbole types -@vindex class, htype -The functions from the @code{htype} class may be applied to any -Hyperbole types, if needed. - -@vindex file, hactypes.el -@vindex file, hibtypes.el -The following subsections explain the specifics of Hyperbole type -definitions which are beyond standard practice for Emacs Lisp programming. -See the definitions of the standard types in @file{hactypes.el} -and @file{hibtypes.el} for examples. - -@menu -* Action Type Creation:: -* Implicit Button Types:: -@end menu - -@node Action Type Creation, Implicit Button Types, Creating Types, Creating Types -@subsection Action Type Creation - -@findex actype:create -@vindex file, hactypes.el -@vindex file, hbut.el -New forms of explicit buttons may be created by adding new action types -to a Hyperbole environment. The file, @file{hactypes.el}, provides -many examples of working action types. - -@cindex action type, creation -@findex defact -@findex actype:create -An action type is created, i.e@. loaded into the Hyperbole environment, -with the @code{(defact)} function (which is an alias for -@code{(actype:create)}). The calling signature for this function is -given in its documentation; it is the same as that of @code{(defun)} -except that a documentation string is required. (An interactive calling -form is also required if the action type has formal parameters and is to -be used in explicit button definitions. Implicit buttons never use an -action type's interactive form. It is good practice to include an -interactive form since the type creator cannot know how users may choose -to apply the type.)@refill - -An action type's parameters are used differently than those of a -function being called. Its interactive calling form is used when an -explicit button is created to prompt for type-specific button -attributes. The rest of its body is used when a button with that action -type is activated. Then the button attributes together with the action -type body are used to form an action that is executed in response to the -button activation. The action's result is returned to the action caller -unless it returns nil, in which case t is returned to the caller to -ensure that it registers the performance of the action. - -An action type body may perform any computation using Emacs Lisp and -Hyperbole functions. - -@cindex interactive form -@findex interactive -The interactive calling form for an action type is of the same form as -that of a regular Emacs Lisp function definition (see the documentation -for the Emacs Lisp @code{(interactive)} form). It may additionally use -Hyperbole command character extensions when the form is given as a -string. Each such extension character @emph{must} be preceded by a plus -sign, @code{+}, in order to be recognized since such characters may also -have standard interactive form meanings. - -The present Hyperbole extension characters are: - -@table @strong -@cindex argument, Info node -@cindex interactive cmd char, +I -@item +I -Prompts for an existing Info node name and file. - -@cindex argument, kcell -@cindex argument, koutline -@cindex interactive cmd char, +K -@item +K -Prompts for an existing kcell identifier, either a full outline level -identifier or a permanent idstamp. - -@cindex interactive cmd char, +M -@cindex argument, mail message -@item +M -Prompts for a mail message date and the file name it resides in. -The mail parameters prompted for by this character code are likely to -change in the future. - -@cindex argument, view spec -@cindex interactive cmd char, +V -@item +V -Prompts for a Hyperbole view specification. -Not yet available for use. - -@end table - -@vindex class, hargs -@cindex argument, reading -Arguments are read by the functions in Hyperbole's @code{hargs} class, -rather than the standard Lisp @code{read} functions, in order to allow -direct selection of arguments via the Action Key. - -If an action type create is successful, the symbol that Hyperbole uses -internally to reference the type is returned. @code{Nil} is returned on -failure so that you may test whether or not the operation succeeds. - -Once you have defined an action type within your present Hyperbole -environment, you can create new explicit buttons which use it. There is -no explicit button type beyond its action type, so no further work is -necessary. - -@findex actype:delete -Call @code{(actype:delete)} to remove an action type from a Hyperbole -environment. It takes a single parameter which should be the same type -symbol used in the type definition call (not the Hyperbole symbol -returned by the call). - -@node Implicit Button Types, , Action Type Creation, Creating Types -@subsection Implicit Button Types - -@cindex implicit button type -@cindex ibtype -@findex defib -@findex ibtype:create -An implicit button type is created or loaded via the @code{(defib)} -function (which is an alias for @code{(ibtype:create)}). The calling -signature for this function is given in its documentation; it is the -same as that of @code{(defun)}, but with a number of constraints. The -parameter list should always be empty since no parameters will be used. -A documentation string is required. The type's body follows this. - -@cindex ibtype, predicate -@cindex ibtype, argument -@cindex ibtype, return val -@cindex ibtype, actype -The body of an implicit button type is a predicate which determines -whether or not point is within an implicit button of the type. If not, -the predicate returns @code{nil}. If so, it may optionally setup to -flash the button and then perform one or more actions. A call of the -form: @code{(ibut:label-set label start-pos end-pos)} is used to setup -the button flashing, if desired. This is then typically immediately -followed by an action invocation of the form: -@code{(hact 'actype &rest actype-arguments)}. It is imperative that all -actions (non-predicate code) be invoked through the @code{(hact)} -function rather than directly or your ibtypes will not work properly. -(Hyperbole first tests to see if any ibtype matches the current context -before activating any type, so it ensures that @code{(hact)} calls are -disabled during this testing.) Any action types used may be created -before or after the implicit button type definition but obviously should -be defined before any implicit buttons of the given type are activated; -an error will result, otherwise. - -If an implicit button type create is successful, the symbol that -Hyperbole uses internally to reference the type is returned. @code{Nil} -is returned on failure so that you may test whether or not the operation -succeeds. Implicit button type names and action type names may be the -same without any conflict. In fact, such naming is encouraged when an -implicit button type is the exclusive user of an action type. - -@findex ibtype:delete -Call @code{(ibtype:delete)} to remove an implicit button type from a -Hyperbole environment. It takes a single parameter which should be the -same type symbol used in the type definition call (not the Hyperbole -symbol returned by the call). This will not delete the action type used -by the implicit button; that must be done separately. - -@cindex ibtype, help -@findex ibut:at-p -@vindex class, hattr -@vindex class, hbut -@vindex file, hib-kbd.el -By default, a request for help on an implicit button will display the -button's attributes in the same manner as is done for explicit buttons. -For some implicit button types, other forms of help will be more -appropriate. If an Emacs Lisp function is defined whose name is formed -from the concatenation of the type name followed by @code{:help}, e.g@. -@code{my-ibtype:help}, it is used to respond to requests for -help on buttons of that type. Any such function should take a single -argument of an implicit button construct. (This is what -@code{(ibut:at-p)} returns when point is within an implicit button -context.) The button may be queried for its attributes using functions -from the @code{hbut} and @code{hattr} classes. See the @file{hib-kbd.el} -file for an example of a custom help function. - -@node Explicit Button Technicalities, Encapsulating Systems, Creating Types, Developing with Hyperbole -@section Explicit Button Technicalities -@menu -* Button Label Normalization:: -* Operational and Storage Formats:: -* Programmatic Button Creation:: -@end menu - -@node Button Label Normalization, Operational and Storage Formats, Explicit Button Technicalities, Explicit Button Technicalities -@subsection Button Label Normalization -@cindex normalized label -@cindex button label -@cindex button key -@vindex hbut:label-to-key -Hyperbole uses a normalized form of button labels called button keys (or -label keys) for all internal operations. See the documentation for the -function @code{(hbut:label-to-key)} for details of the normalization -process. The normalized form permits Hyperbole to recognize buttons that -are the same but whose labels appear different from one another, due to -text formatting conventions. For example, all of the following would -be recognized as the same button. - -@example - <(fake button)> <( fake button)> - - Pam> <(fake - Pam> button)> - - ;; <(fake - ;; button)> - - /* <( fake */ - /* button )> */ -@end example - -@vindex hbut:fill-prefix-regexps -@vindex fill-prefix -@cindex fill prefix -@cindex button, multiple lines -@cindex button, split across lines -The last three examples demonstrate how Hyperbole ignores common fill -prefix patterns that happen to fall within the middle of a button label -that spans multiple lines. As long as such buttons are selected with -point at a location within the label's first line, the button will be -recognized. The variable @var{hbut:fill-prefix-regexps} holds the list -of fill prefixes recognized when embedded within button labels. All -such prefixes are recognized (one per button label), regardless of the -setting of the GNU Emacs variable, @var{fill-prefix}, so no user -intervention is required. - -@node Operational and Storage Formats, Programmatic Button Creation, Button Label Normalization, Explicit Button Technicalities -@subsection Operational and Storage Formats - -@cindex explicit button, formats -@cindex explicit button, storage -@cindex storage manager -@cindex button attributes -@vindex hbut:current -Hyperbole uses a terse format to store explicit buttons and a more -meaningful one to show users and to manipulate during editing. The -terse format consists solely of button attribute values whereas the edit -format includes an attribute name with each attribute value. A button -in edit format consists of a Lisp symbol together with its attribute list -which holds the attribute names and values. In this way, buttons may be -passed along from function to function simply by passing the symbol to -which the button is attached. Most functions utilize the pre-defined -@var{hbut:current} symbol by default to store and retrieve the last -encountered button in edit format. - -@vindex class, hbdata -@vindex class, ebut -@vindex class, hbut -The @code{hbdata} class handles the terse, stored format. The -@code{hbut}, @code{ebut}, and @code{ibut} classes work with the -name/value format. This separation permits the wholesale replacement of -the storage manager with another, with any interface changes hidden from -any Hyperbole client programming. - -@node Programmatic Button Creation, , Operational and Storage Formats, Explicit Button Technicalities -@subsection Programmatic Button Creation - -@cindex explicit button, creation -A common need when developing with Hyperbole is the ability to create or -modify explicit buttons without user interaction. For example, an -application might require the addition of an explicit summary button to -a file for each new mail message a user reads that contains a set of -keywords. The user could then check the summary file and jump to -desired messages quickly. - -@vindex class, ebut -@vindex file, hbut.el -@findex ebut:create -@findex ebut:map -The Hyperbole class @code{ebut} supports programmatic access to explicit -buttons. See it within the @file{hbut.el} file for full details. The -documentation for @code{(ebut:create)} explains the set of attributes -settings necessary to create an explicit button. For operations over -the whole set of buttons within the visible (non-narrowed) portion of a -buffer, use the @code{(ebut:map)} function. - -@page -@node Encapsulating Systems, Embedding Hyperbole, Explicit Button Technicalities, Developing with Hyperbole -@section Encapsulating Systems - -@vindex file, hsys-* -@cindex Hyperbole, system encapsulation -@cindex system encapsulation -A powerful use of implicit button types is to provide a Hyperbole-based -interface to external systems. The basic idea is to interpret patterns -output by the application as implicit buttons. - -See the @file{hsys-*} files for examples of how to do this. -Encapsulations are provided for the following systems (the systems -themselves are not included with Hyperbole): - -@table @bullet -@item World-Wide Web -The world-wide web system originally developed at CERN, that now spans -the Internet universe. This is automatically loaded by Hyperbole so -that a press of the Action Key follows a URL. - -@item WAIS -The Wide Area Information Systems full text-retrieval system orginally -developed at Thinking Machines and then later at WAIS Inc. - -@item HyperBase -A hypertextual storage manager that stores textual nodes as records with -locking so that multiple users can read and edit hypertexts. -@end table - - -@node Embedding Hyperbole, , Encapsulating Systems, Developing with Hyperbole -@section Embedding Hyperbole - -[NOTE: We have never done this ourselves, though we have done similar -things which leads us to infer that the task should not be difficult.] - -@cindex Hyperbole API -@cindex API -@cindex programming interface -@cindex Hyperbole, embedding -The standard Emacs-based Hyperbole user interface has purposely been -separated from the Hyperbole backend to support the development of -alternative interfaces and the embedding of Hyperbole functionality -within other system prototypes. The Hyperbole backend functionality -that system developers can make use of is called its Application -Programming Interface (API). The API may be used to make server-based -calls to Hyperbole when Emacs is run as a non-interactive (batch) -process, with its input/output streams attached to another process. - -The public functions and variables from the following files may be -considered the present Hyperbole API: - -@noindent -@file{hact.el}, @file{hargs.el}, @file{hbmap.el}, @file{hbut.el}, -@file{hhist.el}, @file{hmail.el}, @file{hmoccur.el}, @file{hpath.el}, -@file{htz.el}, @file{hypb.el}, @file{set.el}, @file{wconfig.el}, -@file{wrolo.el}, and @file{wrolo-logic.el}.@refill - -@noindent -Note when looking at these files, that they are divided into sections -that separate one data abstraction (class) from another. A line of -dashes within a class separates public parts of the class from the -private parts that follow the line. - -This API does not include the Hyperbole outliner, as it has been -designed for interactive use, rather than programmatic extensibility. -You can certainly study its code, below the @file{hyperbole/kotl/} -directory and learn to program it, however. - - -@node Glossary, Smart Key Reference, Developing with Hyperbole, Top -@appendix Glossary - -Concepts pertinent to operational usage of Hyperbole are defined here. -If some GNU Emacs terms are unfamiliar to you, @ref{Glossary, Emacs -Glossary,, emacs, the GNU Emacs Manual}. - -@table @code - -@cindex action -@item action -An executable behavior associated with a Hyperbole button. A specific -class of actions which display entities are called @emph{links}, -such as a link to a file. - -@cindex Action Key -@item Action Key -See @emph{Smart Key}. - -@cindex action type -@item action type -A behavioral specification for use within Hyperbole buttons. Action -types usually contain a set of parameters which must be given values for -each button with which they are associated. An action type together -with a set of values, called arguments, may be considered an @emph{action}. -@emph{Actype} is a synonym for action type. - -@cindex activation -@item activation -Request for a Hyperbole button to perform its action. -Ordinarily the user presses a key which selects and activates a button. - -@cindex ange-ftp -@cindex ftp -@item ange-ftp -A standard GNU Emacs Lisp package which allows one to use pathnames -that are accessible via the Internet File Transfer Protocol (ftp) just -like other pathnames, for example when finding a file. The -latest version of ange-ftp may always be obtained via anonymous ftp to: -@file{/ftp.gnu.ai.mit.edu:ange-ftp/ange-ftp.tar.gz}. - -@cindex argument -@item argument -A button-specific value fed to a Hyperbole type specification when the -button is activated. - -@cindex Assist Key -@item Assist Key -See @emph{Smart Key}. - -@cindex attributes -@item attributes -Slot names associated with Hyperbole buttons. An @emph{attribute value} -is associated with each button attribute. - -@cindex Augment -@cindex NLS -@cindex hypertext -@cindex interactive computing -@cindex mouse -@cindex windows -@cindex hypertext -@cindex outline processor -@cindex groupware -@cindex digital signature -@cindex Engelbart -@item Augment -The Augment system, originally named NLS, was a pioneering research and -production system aimed at augmenting human intellect and group -knowledge processing capabilities through integrated tools and -organizational development strategies. This approach led to the -invention of much of interactive computing technology decades ahead of -other efforts, including: the mouse, screen windows, true hypertext, -outline processors, groupware, and digitally signed documents. -@xref{References}, which cites several Douglas Engelbart papers on the -subject. The Koutliner concept emerged from studies of publicly -available information concerning Augment. - -@cindex button -@item button -A selectable Hyperbole construct which performs an action. A button -consists of a set of attributes that includes: a textual label, a -category, a type and zero or more arguments. @emph{Explicit buttons} -also have creator, create time, last modifier, and last modifier time -attributes. - -Buttons provide the user's gateway to information. The user sees and -interacts with button labels, the rest of the button data is managed -invisibly by Hyperbole and displayed only in response to user queries. - -@cindex button activation -@item button activation -See @emph{activation}. - -@cindex button attributes -@item button attributes -See @emph{attributes}. - -@cindex button data -@item button data -Lists of button attribute values explicitly saved and managed by Hyperbole. -One list for each button created by Hyperbole. - -@cindex button file, local -@item button file, local -A per-directory file named @file{HYPB} that may be used to store any -desired buttons and may then be displayed via a menu selection whenever -a user is within that directory. - -@cindex button file, personal -@item button file, personal -A per-user file named @file{HYPB} that may be used to store any desired -buttons and may then be displayed via a menu selection. - -@cindex button key -@item button key -A normalized form of a @emph{button label} used internally by Hyperbole. - -@cindex button label -@item button label -A text string that visually indicates a Hyperbole button location and -provides it with a name and unique identifier. Within a buffer, buttons -with the same label are considered separate views of the same button and -so behave exactly alike. Since button labels are simply text strings, -they may be embedded within any text to provide non-linear information -or operational access points. - -The maximum length of a button label is limited by the variable -@var{ebut:max-len}. - -@cindex button selection -@item button selection -The act of designating a Hyperbole button upon which to operate. -Use the Action Key to select a button. - -@cindex category -@item category -A high-level, conceptual grouping of Hyperbole buttons into classes. -@emph{Implicit} and @emph{explicit} groupings represent categories. - -@cindex cell -@item cell -See @emph{kcell}. - -@cindex children -@item children -The set of koutline cells which share a common parent cell and are one -level deeper than the parent. - -@cindex class -@item class -A group of functions and variables with the same prefix in their names, -used to provide an interface to an internal or external Hyperbole -abstraction. - -@cindex context -@item context -A programmatic or positional state recognized by Hyperbole. -We speak of Smart Key and implicit button contexts. Both are typically -defined in terms of surrounding patterns within a buffer, but may be -defined by arbitrary Emacs Lisp predicates. (Context may come to have a -broader meaning within future versions of Hyperbole.) - -@cindex environment -@item environment -See @emph{Hyperbole environment}. - -@cindex efs -@item efs -The much larger successor to ange-ftp. It does the same thing as -ange-ftp but works with more types of ftp hosts. See @emph{ange-ftp}. - -@cindex explicit button -@item explicit button -A button created and managed by Hyperbole. By default, explicit buttons -are delimited like this @code{<(fake button)>}. Direct selection is -used to operate upon an explicit button. - -@cindex global button -@item global button -@vindex gbut:file -A form of explicit button which is typically accessed by name rather -than direct selection. Global buttons are useful when one wants -quick access to actions such as jumping to common file locations or for -performing sequences of operations. One need not locate them since they -are always available by name, with full completion offered. All global -buttons are stored in the file given by the variable @var{gbut:file} and -may be activated as regular explicit buttons by visiting this file. By -default, this is the same as the user's personal button file. - -@cindex global button file -@item global button file -See @emph{button file, personal}. - -@findex run-hooks -@cindex hook variable -@item hook variable -A variable that permits customization of an existing function's -operation without the need to edit the function's code. See also the -documentation for the function @code{(run-hooks)}. - -@cindex Hyperbole -@item Hyperbole -A flexible, programmable information management and viewing system built -on top of GNU Emacs. It utilizes a button-action model and supports -hypertextual linkages. Hyperbole is all things to all people. - -@cindex Hyperbole environment -@item Hyperbole environment -A programmatic context within which Hyperbole operates. This includes -the set of Hyperbole types defined and the set of Hyperbole code modules -loaded. It does not include the set of accessible buttons. -Although the entire Emacs environment is available to Hyperbole, we do -not speak of this as part of the Hyperbole environment. - -@cindex hypertext -@item hypertext -A text or group of texts which may be explored in a non-linear fashion -through associative linkages embedded throughout the text. Instead of -simply referring to other pieces of work, hypertext references when -followed actually take you to the works themselves. - -@cindex implicit button -@item implicit button -A button recognized contextually by Hyperbole. Such buttons contain no -button data. See also @emph{implicit button type}. - -@cindex implicit button type -@item implicit button type -A specification of how to recognize and activate implicit buttons of a -specific kind. Implicit button types often utilize structure internal -to documents created and managed without Hyperbole assistance, for -example, programming documentation. @emph{Ibtype} is a synonym for -implicit button type. See also @emph{system encapsulation}. - -@cindex instance number -@item instance number -A colon prefaced number appended to the label of a newly created button -when the button's label duplicates the label of an existing button in -the current buffer. This number makes the label unique and so allows -any number of buttons with the same base label within a single buffer. - -@cindex koutline -@item koutline -A hierarchically ordered grouping of cells which may be stored as a file -and viewed and edited as an outline. - -@cindex Koutliner -@item Koutliner -Koutliner, the Hyperbole outliner, is a powerful autonumbering outliner -with permanent hypertext anchors for easy hyperlinking and view -specs for rapid outline view alteration. - -@cindex kcell -@item kcell -Cells or kcells are elements within koutlines. Each cell contains -textual and graphical contents, a relative identifier, a permanent -identifier and a set of attributes such as the user who created the cell -and the time of creation. See also @emph{Koutliner}. - -@cindex link -@item link -A reference from a Hyperbole button to an entity. The referenced entity -is sometimes called a @emph{node} or @emph{referent}. -A specific class of actions which display entities are called -@emph{links}, such as a link to a file. - -@cindex local button file -@item local button file -See @emph{button file, local}. - -@cindex minibuffer window -@item minibuffer window -The one line window at the bottom of a frame where messages and prompts -are displayed. - -@cindex minibuffer menu -@item minibuffer menu -A Hyperbole menu displayed in the minibuffer window. Each menu item -within a minibuffer menu begins with a different letter that can be used -to invoke the item (case doesn't matter). Items that display other -menus end with a forward slash, /. - -@cindex mouse button -@item mouse button -@item mouse key -See @emph{Smart Key}. - -@cindex node -@item node -See @emph{link} or @emph{cell}. - -@cindex outline -@item outline -See @emph{koutline}. - -@cindex parent -@item parent -Any koutline cell which has children. - -@cindex predecessor -@item predecessor -The previous same level koutline cell with the same parent. - -@cindex predicate -@item predicate -A boolean (nil = false, non-nil = true) Lisp expression typically -evaluated as part of a conditional expression. - -@cindex referent -@item referent -See @emph{link}. - -@cindex rolodex -@item rolodex -Wrolo, the Hyperbole rolodex, provides rapid lookup of multi-line, -hierarchically ordered free form text records. - -@cindex root cell -@item root cell -A koutline cell which has cells below it. All such cells share the same -root cell. - -@cindex Smart Key -@vindex smart-scroll-proportional -@cindex proportional scrolling -@cindex scrolling -@item Smart Key -A context-sensitive key used within Hyperbole and beyond. Actually, -there are two Smart Keys, the Action Key and the Assist Key. The -Action Key, typically bound to the shift-middle mouse key (or shift-left -mouse key on a 2-button mouse), activates Hyperbole buttons and scrolls -the current buffer line to the top of the window when pressed at the end -of a line. The Assist Key, typically bound to the shift-right mouse -key, explains what a Hyperbole button does or scrolls the current line -to the bottom of the window when pressed at the end of a line. (See the -documentation for the variable, @var{smart-scroll-proportional}, for -information on how to make these keys scroll forward and backward a -windowful at a time). - -To see what a Smart Key will do within a particular context, depress and -hold the key at the point desired and depress the other Smart Key. A -buffer containing a description of its contextual function will then be -displayed. You may release the two keys in any order after you have -them both depressed. A press of the Assist Key in an unsupported -context displays a summary of Smart Key functions in each context, as -does the Doc/SmartKy menu item. - -@cindex source buffer -@cindex source file -@item source buffer / file -The buffer or file within which a Hyperbole button is embedded. - -@cindex subtree -@item subtree -All of the cells in a koutline which share the same root cell, excluding -the root cell. - -@cindex successor -@item successor -The next same level koutline cell with the same parent. - -@cindex system encapsulation -@item system encapsulation -Use of Hyperbole to provide an improved or simply consistent user -interface to another system. Typically, implicit button types are -defined to recognize and activate button-type constructs managed by the -other system. - -@cindex tree -@item tree -The set of cells in a koutline that share a common root cell, including -the root cell. - -@cindex view -@item view -A perspective on some information. A view can affect the extent of the -information displayed, its format, modes used to operate on it, its -display location and so forth. - -@cindex view spec -@item view spec -A terse (and to the uninitiated, cryptic) string that specifies a -particular view of koutline or a link referent. If a view spec is in -use in a buffer, the view spec appears in the modeline delimited by -<|view spec>. - -@end table - -@node Smart Key Reference, Outliner Keys, Glossary, Top -@appendix Smart Key Reference - -This appendix supplies complete documentation on Smart Key operation. It is -quite extensive and is meant for reference rather than sequential reading. -@xref{Smart Keys}, for a description of the Smart Keys. That section also -describes how to get context-sensitive Smart Key help, with which you can -explore Smart Key operation bit by bit. - -Smart Key operations are context-sensitive. Contexts are described herein as -conditionals, e.g@. when depressed here, if this is true, etc. Each Smart -Key context is listed in the order in which it will be checked. The first -matching context is always the one applied. Within each context, the -actions performed by the Action and Assist Keys are listed. - -@menu -* Smart Mouse Keys:: -* Smart Keyboard Keys:: -@end menu - -@node Smart Mouse Keys, Smart Keyboard Keys, Smart Key Reference, Smart Key Reference -@section Smart Mouse Keys - -@cindex Smart Mouse Keys -Smart Key drags and modeline presses can only be used when running under -a window system with mouse key support. So keep in mind that the -operations in this section apply only if you have mouse support within -Hyperbole. The Smart Key operations in, @ref{Smart Keyboard Keys}, -apply to both mouse and keyboard Smart Key usage. - -@cindex drag, side edge -@cindex side drag -@format -@group -If dragged from a side-by-side window edge or from the immediate left of -a vertical scroll bar: - ACTION or ASSIST - Resizes adjacent window sides to the point of drag release. -@end group -@end format - -@format -@group -@cindex drag, between windows -If dragged from inside one window to another: - ACTION - Creates a new link button at the drag start location, linked to the - drag end location. If drag start position is within a button, - modifies the button to link to drag end location. - ASSIST - Swaps buffers in the two windows. -@end group -@end format - -@page -@cindex drag, horizontal -@cindex horizontal drag -@format -@group -If dragged horizontally within a single window while depressed -(hmouse-x-drag-sensitivity sets the minimal horizontal movement which -registers a drag): - ACTION - Goes to buffer end if drag was to the right, otherwise goes to beginning. - ASSIST - Splits window vertically if drag was to the right, otherwise deletes - window. -@end group -@end format - -@cindex depress, modeline -@cindex modeline depress -@format -@group -If depressed within a window mode line: - ACTION - (1) clicked on left edge of a window's modeline, - window's buffer is buried (placed at bottom of buffer list); - (2) clicked on right edge of a window's modeline, - the Info buffer is displayed, or if already displayed and the - modeline clicked belongs to a window displaying Info, the Info - buffer is hidden; - (3) clicked anywhere in the middle of a window's modeline, - the functions listed in `assist-key-modeline-hook' are - called; - (4) dragged vertically from modeline to within a window, - the modeline is moved to point of key release, thereby resizing - its window and potentially its vertical neighbors. - ASSIST - (1) clicked on left edge of a window's modeline, - bottom buffer in buffer list is unburied and placed in window; - (2) clicked on right edge of a window's modeline, - the summary of Smart Key behavior is displayed, or if already - displayed and the modeline clicked belongs to a window displaying - the summary, the summary buffer is hidden; - (3) clicked anywhere in the middle of a window's modeline, - a popup menu (if available) is displayed; - (4) dragged vertically from modeline to within a window, - the modeline is moved to point of key release, thereby resizing - its window and potentially its vertical neighbors. -@end group -@end format - -@page -@cindex drag, vertical -@cindex vertical drag -@format -@group -If dragged vertically within a single window while depressed -(hmouse-y-drag-sensitivity sets the minimal vertical movement which -registers a drag): - ACTION or ASSIST - Splits current window into two side-by-side windows. -@end group -@end format - -@cindex drag, diagonal -@cindex diagonal drag -@format -@group -If dragged diagonally within a single window while depressed -(hmouse-x-diagonal-sensitivity and hmouse-y-diagonal-sensitivity set the -minimal diagonal movement which registers a drag): - ACTION - Save current window configuration onto a ring of window configurations. - ASSIST - Restores prior window configuration from ring. A prefix argument N - specifies the Nth prior configuration from the ring. -@end group -@end format - -@page - -@node Smart Keyboard Keys, , Smart Mouse Keys, Smart Key Reference -@section Smart Keyboard Keys - -@cindex Smart Keyboard Keys -@format -@group -When prompting for a Hyperbole argument, a press in the minibuffer: - ACTION - Terminates this minibuffer argument. - ASSIST - Offers completion help for current minibuffer argument. -@end group -@end format - -@format -@group -When reading a Hyperbole menu item or a Hyperbole completion-based argument: - ACTION - Returns value selected at point if any, else nil. If - value is the same as the contents of the minibuffer, it is used as the - current minibuffer argument, otherwise, the minibuffer is erased and - value is inserted there. - - ASSIST - Displays Hyperbole menu item help when item is selected. -@end group -@end format - -@format -@group -If in ID-edit mode (a package from InfoDock Associates that supports -rapid killing, copying, ynaking and display-management): - ACTION or ASSIST - Yanks (pastes) last selected region at point. -@end group -@end format - -@vindex smart-scroll-proportional -@cindex proportional scrolling -@cindex scrolling -@cindex click, end of line -@cindex end of line click -@format -@group -When pressed at the end of a line but not the end of a buffer: - ACTION - Scrolls up according to value of smart-scroll-proportional. If - smart-scroll-proportional is nil or if point is on the top - window line, scrolls up (forward) a windowful. Otherwise, tries to - bring current line to top of window. Leaves point at end of line and - returns t if scrolled, nil if not. - ASSIST - Scrolls down according to value of smart-scroll-proportional. If - smart-scroll-proportional is nil or if point is on the - bottom window line, scrolls down (backward) a windowful. Otherwise, - tries to bring current line to bottom of window. Leaves point at end of - line and returns t if scrolled, nil if not. -@end group -@end format - -@format -@group -When pressed on a Smart Menu item: - ACTION - Activates item. - ASSIST - Displays help for item. -@end group -@end format - -@cindex click, button -@cindex button click -@format -@group -When pressed on a Hyperbole button: - ACTION - Activates button. - ASSIST - Displays help for button, typically a summary of its attributes. -@end group -@end format - -@format -@group -If Smart Menu package has been loaded and `hkey-always-display-menu' is -non-nil: - ACTION or ASSIST - Pops up a window with a Smart Menu of commands. - Menu displayed is selected by (smart-menu-choose-menu). -@end group -@end format - -@format -@group -If pressed within a buffer in View major or minor mode: - ACTION - Scrolls buffer forward a windowful and quits from view mode when at - the last line of the buffer. - ASSIST - Scrolls buffer backward a windowful. -@end group -@end format - -@format -@group -When pressed within a Hyperbole outliner buffer (kotl-mode): - ACTION - (1) at the end of buffer, uncollapse and unhide all cells in view; - (2) within a cell, if its subtree is hidden then show it, - otherwise hide it; - (3) between cells or within the read-only indentation region to the - left of a cell, then move point to prior location and begin - creation of a klink to some other outline cell; hit the Action - Key twice to select the link referent cell; - (4) anywhere else, scroll up a windowful. - ASSIST - (1) at the end of buffer, collapse all cells and hide all non-level-one - cells; - (2) on a header line but not at the beginning or end, display - properties of each cell in kotl beginning at point; - (3) between cells or within the read-only indentation region to the - left of a cell, then move point to prior location and prompt to - move one tree to a new location in the outline; hit the Action - Key twice to select the tree to move and where to move it; - (4) anywhere else, scroll down a windowful. -@end group -@end format - -@page -@format -@group -When pressed at the end of a Help buffer: - ACTION or ASSIST - Restores window configuration prior to help display. -@end group -@end format - -@format -@group -When pressed within a C source code file: - ACTION - Jumps to the definition of selected C construct: - (1) on a `#include' statement, the include file is displayed; - Look for include file in directory lists - `smart-c-cpp-include-dirs' and `smart-c-include-dirs'. - (2) on a C identifier, the identifier definition is displayed, - assuming the identifier is found within an `etags' generated tag file - in the current directory or any of its ancestor directories. - (3) if `smart-c-use-lib-man' is non-nil, the C identifier is - recognized as a library symbol, and a man page is found for the - identifier, then the man page is displayed. - ASSIST - Jumps to the next tag matching an identifier at point. -@end group -@end format - -@format -@group -When pressed within an assembly source code file: - ACTION - Jumps to the definition of selected assembly construct: - (1) on an include statement, the include file is displayed; - Look for include file in directory list - `smart-asm-include-dirs'. - (2) on an identifier, the identifier definition is displayed, - assuming the identifier is found within an `etags' generated - tag file in the current directory or any of its ancestor - directories. - ASSIST - Jumps to the next tag matching an identifier at point. -@end group -@end format - -@page -@format -@group -When pressed on a Lisp symbol within a Lisp code buffer: - ACTION - Jumps to the definition of any selected Lisp construct. - If on an Emacs Lisp require, load, or autoload clause and `find-library' - from load-library package by Hallvard Furuseth <hallvard@@ifi.uio.no> has - been loaded, jumps to library source, if possible. - ASSIST - Jumps to the next tag matching an identifier at point or if using the - "wtags" package and identifier is an Emacs Lisp symbol, then displays - documentation for the symbol. -@end group -@end format - -@page -@format -@group -When pressed within a Java source code file: - ACTION - Jumps to the definition of selected Java construct: - (1) within a commented @@see cross-reference, the referent is - displayed; - (2) on a `package' or `import' statement, the referent is - displayed; Look for referent files in the directory list - `smart-java-package-dirs'. - (3) on an Java identifier, the identifier definition is displayed, - assuming the identifier is found within an `etags' generated - tag file in the current directory or any of its ancestor - directories." - ASSIST - Jumps to the next tag matching an identifier at point. -@end group -@end format - -@format -@group -When pressed within a C++ source code file: - ACTION - Jumps to the definition of selected C++ construct: - (1) on a `#include' statement, the include file is displayed; - Look for include file in directory lists - `smart-c-cpp-include-dirs' and `smart-c-include-dirs'. - (2) on a C++ identifier, the identifier definition is displayed, - assuming the identifier is found within an `etags' generated tag file - in the current directory or any of its ancestor directories. - (3) if `smart-c-use-lib-man' is non-nil, the C++ identifier is - recognized as a library symbol, and a man page is found for the - identifier, then the man page is displayed. - ASSIST - Jumps to the next tag matching an identifier at point. -@end group -@end format - -@format -@group -When the OO-Browser has been loaded and the press is within a C++ buffer: - ACTION or ASSIST - Jumps to the definition of selected C++ construct via OO-Browser support. - (1) on a `#include' statement, the include file is displayed; - Look for include file in directory lists - `smart-c-cpp-include-dirs' and `smart-c-include-dirs'. - (2) within a method declaration, its definition is displayed; - (3) on a class name, the class definition is shown. -@end group -@end format - -@format -@group -When pressed within a Objective-C source code file: - ACTION - Jumps to the definition of selected C+ construct: - (1) on a `#include' statement, the include file is displayed; - Look for include file in directory lists - `smart-c-cpp-include-dirs' and `smart-c-include-dirs'. - (2) on an Objective-C identifier, the identifier definition is displayed, - assuming the identifier is found within an `etags' generated tag file - in the current directory or any of its ancestor directories. - (3) if `smart-c-use-lib-man' is non-nil, the Objective-C identifier is - recognized as a library symbol, and a man page is found for the - identifier, then the man page is displayed. - ASSIST - Jumps to the next tag matching an identifier at point. -@end group -@end format - -@format -@group -When the OO-Browser has been loaded and the press is within a -Objective-C buffer: - ACTION or ASSIST - Jumps to the definition of selected Objective-C construct via - OO-Browser support. - (1) on a `#include' statement, the include file is displayed; - Look for include file in directory lists - `smart-c-cpp-include-dirs' and `smart-c-include-dirs'. - (2) within a method declaration, its definition is displayed; - (3) on a class name, the class definition is shown. -@end group -@end format - -@format -@group -When pressed within a Fortran source code file: - ACTION or ASSIST - Jumps to the next tag matching an identifier at point. -@end group -@end format - -@format -@group -When pressed within an occur-mode or moccur-mode buffer: - ACTION or ASSIST - Jumps to the source buffer and line of the current occurrence. -@end group -@end format - -@page -@format -@group -When pressed within a calendar-mode buffer: - ACTION - (1) at the end of the buffer, the calendar is scrolled forward 3 months; - (2) to the left of any dates on a calendar line, the calendar is scrolled - backward 3 months; - (3) on a date, the diary entries for the date, if any, are displayed. - ASSIST - (1) at the end of the buffer, the calendar is scrolled backward 3 months; - (2) to the left of any dates on a calendar line, the calendar is scrolled - forward 3 months; - (3) anywhere else, all dates with marking diary entries are marked in the - calendar window. -@end group -@end format - -@format -@group -When pressed within a man page apropos buffer: - ACTION - (1) on a UNIX man apropos entry, the man page for that entry is - displayed in another window; - (2) on or after the last line, the buffer in the other window is - scrolled up a windowful. - ASSIST - (1) on a UNIX man apropos entry, the man page for that entry is - displayed in another window; - (2) on or after the last line, the buffer in the other window is - scrolled down a windowful. -@end group -@end format - -@page -@format -@group -When pressed within an OO-Browser listing window: - ACTION - (1) in a blank buffer or at the end of a buffer, browser help - information is displayed in the viewer window; - (2) at the beginning of a (non-single char) class name, the class' - ancestors are listed; - (3) at the end of an entry line, scrolls listing up; - (4) on the `...', following a class name, point is moved to the class - descendency expansion; - (5) before an element name, the implementor classes of the name are - listed; - (6) anywhere else on an entry line, the source is displayed for editing. - ASSIST - (1) in a blank buffer, a selection list of buffer files is displayed; - (2) at the beginning of a (non-single char) entry, the class' - descendants are listed; - (3) at the end of an entry line, scrolls listing down; - (4) on the `...', following a class name, point is moved to the class - expansion; - (5) anywhere else on a class entry line, lists the class' elements; - (6) anywhere else on an element line, lists the element's implementor - classes; - (7) on a blank line following all entries, the current listing buffer - is exited. -@end group -@end format - -@format -@group -When pressed within an OO-Browser Command Help Menu buffer: - ACTION - Executes an OO-Browser command whose key binding is at point. - ASSIST - Displays help for an OO-Browser command whose key binding is at point. -@end group -@end format - -@format -@group -When pressed on an identifier within an OO-Browser source file: - ACTION - Tries to display identifier definition. - ASSIST - Not applicable. -@end group -@end format - -@page -@format -@group -If pressed within an outline-mode buffer or when `selective-display' is -non-nil: - ACTION - Collapses, expands, and moves outline entries. - (1) after an outline heading has been cut via the Action Key, then paste - the cut heading at point; - (2) at the end of buffer, show all buffer text - (3) at the beginning of a heading line, cut the headings subtree from the - buffer; - (4) on a header line but not at the beginning or end, if headings - subtree is hidden then show it, otherwise hide it; - (5) anywhere else, scroll up a windowful. - ASSIST - (1) after an outline heading has been cut via the Action Key, allow - multiple pastes throughout the buffer (last paste should be done - with the Action Key, not the Assist Key); - (2) at the end of buffer, hide all bodies in buffer; - (3) at the beginning of a heading line, cut the current heading (sans - subtree) from the buffer; - (4) on a header line but not at the beginning or end, if heading body is - hidden then show it, otherwise hide it; - (5) anywhere else, scroll down a windowful. -@end group -@end format - -@cindex click, Info -@cindex Info browsing -@format -@group -If pressed within an Info manual node: - ACTION - (1) the first line of an Info Menu Entry or Cross Reference, the desired - node is found; - (2) the Up,Next,or Previous entries of a Node Header (first line), - the desired node is found; - (3) the File entry of a Node Header (first line), - the `Top' node within that file is found; - (4) at the end of the current node, the Next node is found (this will - descend subtrees if the function `Info-global-next' is bound); - (5) anywhere else (e.g@. at the end of a line), the current node entry is - scrolled up a windowful. - ASSIST - (1) the first line of an Info Menu Entry or Cross Reference, the desired - node is found; - (2) the Up,Next,or Previous entries of a Node Header (first line), - the last node in the history list is found; - (3) the File entry of a Node Header (first line), - the `DIR' root-level node is found; - (4) at the end of the current node, the Previous node is found (this will - return from subtrees if the function 'Info-global-prev is bound); - (5) anywhere else (e.g@. at the end of a line), the current node entry is - scrolled down a windowful. -@end group -@end format - -@page -@format -@group -If pressed within a Hyperbole-supported mail reader, `hmail:reader', or mail -summary mode, `hmail:lister', buffer at: - ACTION - (1) a msg buffer, within the first line or at the end of a message, - the next undeleted message is displayed; - (2) a msg buffer within the first line of an Info cross reference, the - reference is followed; - (3) anywhere else in a msg buffer, the window is scrolled up one - windowful; - (4) a msg summary buffer on a header entry, the message corresponding to - the header is displayed in the msg window; - (5) a msg summary buffer, on or after the last line, the messages marked - for deletion are expunged. - ASSIST - (1) a msg buffer, within the first line or at the end of a message, - the previous undeleted message is displayed; - (2) a msg buffer within the first line of an Info cross reference, the - reference is followed; - (3) anywhere else in a msg buffer, the window is scrolled down one - windowful; - (4) a msg summary buffer on a header entry, the message corresponding to - the header is marked as deleted; - (5) a msg summary buffer, on or after the last line, all messages are - marked undeleted. -@end group -@end format - -@cindex click, GNUS -@cindex GNUS browsing -@format -@group -If pressed within a GNUS listing of newsgroups buffer at: - ACTION - (1) a GNUS-GROUP line, that newsgroup is read; - (2) to the left of any GNUS-GROUP line, on any of the whitespace, the - current group is unsubscribed or resubscribed; - (3) at the end of the GNUS-GROUP buffer, after all lines, checks for new - news. - ASSIST - (1) a GNUS-GROUP line, that newsgroup is read; - (2) to the left of any GNUS-GROUP line, on any of the whitespace, the - user is prompted for a group name to subscribe or unsubscribe to; - (3) at the end of the GNUS-GROUP buffer, after all lines, quits from the - newsreader. -@end group -@end format - -@page -@format -@group -If pressed within a GNUS newsreader subject listing buffer at: - ACTION - (1) a GNUS-SUBJECT line, that article is read, marked deleted, and - scrolled forward; - (2) at the end of the GNUS-SUBJECT buffer, the next undeleted article - is read or the next group is entered. - ASSIST - (1) a GNUS-SUBJECT line, that article is read and scrolled backward; - (2) at the end of the GNUS-SUBJECT buffer, the subject is exited, the - user is returned to group mode. -@end group -@end format - -@format -@group -If pressed within a GNUS newsreader article buffer at: - ACTION - (1) the first line or end of an article, the next unread message is - displayed; - (2) the first line of an Info cross reference, the reference is followed; - (3) anywhere else, the window is scrolled up a windowful. - ASSIST - (1) the first line or end of an article, the previous message is - displayed; - (2) the first line of an Info cross reference, the reference is followed; - (3) anywhere else, the window is scrolled down a windowful. -@end group -@end format - -@page -@cindex click, buffer menu -@cindex buffer menu -@format -@group -If pressed within a listing of buffers (Buffer-menu-mode): - ACTION - (1) on the first column of an entry, the selected buffer is marked for - display; - (2) on the second column of an entry, the selected buffer is marked to be - saved; - (3) anywhere else within an entry line, all saves and deletes are done, - and selected buffers are displayed, including the one just clicked - on (if in the OO-Browser, only the selected buffer is displayed); - (4) on or after the last line in the buffer, all saves and deletes are - done. - ASSIST - (1) on the first or second column of an entry, the selected buffer is - unmarked for display and for saving or deletion; - (2) anywhere else within an entry line, the selected buffer is marked for - deletion; - (3) on or after the last line in the buffer, all display, save, and delete - marks on all entries are undone. -@end group -@end format - -@cindex click, dired -@cindex dired browsing -@format -@group -If pressed within a dired-mode buffer: - ACTION - (1) within an entry line, the selected file/directory is displayed - for editing in the other window; - (2) on or after the last line in the buffer, if any deletes are to be - performed, they are executed after user verification, otherwise, this - dired invocation is quit. - ASSIST - (1) on a `~' character, all backup files in the directory are marked for - deletion; - (2) on a `#' character, all auto-save files in the directory are marked - for deletion; - (3) anywhere else within an entry line, the current entry is marked for - deletion; - (4) on or after the last line in the buffer, all delete marks on all - entries are undone. -@end group -@end format - -@page -@cindex click, tar -@cindex tar archive browsing -@cindex extracting from tar files -@format -@group -If pressed within a tar-mode buffer: - ACTION - (1) within an entry line, the selected file/directory is displayed - for editing in the other window; - (2) on or after the last line in the buffer, if any deletes are to be - performed, they are executed after user verification, otherwise, this - tar file browser is quit. - ASSIST - (1) on an entry line, the current entry is marked for deletion; - (2) on or after the last line in the buffer, all delete marks on all - entries are undone. -@end group -@end format - -@cindex man page references -@format -@group -If pressed on a cross reference within a man page entry section labeled -NAME, SEE ALSO, or PACKAGES USED, or within a man page C routine -specification (see `smart-man-c-routine-ref') and man page buffer -has either an attached file or else a @var{man-path} local variable -containing its pathname: - ACTION or ASSIST - Displays man page or source code for cross reference. -@end group -@end format - -@cindex click, world-wide web -@cindex W3 -@cindex URL -@cindex world-wide web -@format -@group -If pressed on a world-wide web universal resource locator: - ACTION - Displays the URL referent at point. - ASSIST - Goes back to a previously displayed web page. -@end group -@end format - -@cindex game, gomoku -@cindex gomoku -@format -@group -If pressed in a Gomoku game buffer. - ACTION - Makes a move at the space pointed to. - ASSIST - Takes back a prior move made at the space pointed to. -@end group -@end format - -@cindex click, wrolo matches -@cindex wrolo matches -@format -@group -If pressed within an entry in the wrolo match display buffer: - ACTION or ASSIST - The entry is edited in the other window. -@end group -@end format - -@node Outliner Keys, Suggestion or Bug Reporting, Smart Key Reference, Top -@appendix Outliner Keys - -@cindex outliner keys -This appendix summarizes the specialized key bindings available when -editing an outline with Hyperbole. Each key is shown together with its -command binding and the documentation for that command. Normal emacs -editing keys are modified to account for the structure within outlines. -An outliner command which overloads an Emacs command named @emph{cmd} -would be named @emph{kotl-mode:cmd}. - -@table @code - -@findex kfile:write -@item kfile:write @{@kbd{C-x C-w}@} -Write current outline to FILE. - -@findex klink:create -@item klink:create @{@kbd{C-c l}@} -Insert at point an implicit link to REFERENCE. -REFERENCE should be a cell-ref or a string containing "filename, cell-ref". -See documentation for @code{kcell:ref-to-id} for valid cell-ref formats. - -@findex kotl-mode:add-cell -@item kotl-mode:add-cell @{@key{LFD}@} -Add a cell following current cell at optional RELATIVE-LEVEL with CONTENTS string. -Optional prefix arg RELATIVE-LEVEL means add as sibling if nil or >= 0, as child -if equal to universal argument, @kbd{C-u}, and as sibling of current cell's -parent, otherwise. If added as sibling of current level, RELATIVE-LEVEL is -used as a repeat count for the number of cells to add. - -Return last newly added cell. - -@findex kotl-mode:add-child -@item kotl-mode:add-child @{@kbd{C-c a}@} -Add a new cell to current kview as first child of current cell. - -@findex kotl-mode:add-parent -@item kotl-mode:add-parent @{@kbd{C-c p}@} -Add a new cell to current kview as sibling of current cell's parent. - -@findex kotl-mode:append-cell -@item kotl-mode:append-cell @{@kbd{C-c +}@} -Append CONTENTS-CELL to APPEND-TO-CELL. -APPEND-TO-CELL is refilled if neither cell has a no-fill property and -kotl-mode:refill-flag is enabled. - -@findex kotl-mode:back-to-indentation -@item kotl-mode:back-to-indentation @{@kbd{M-m}@} -Move point to the first non-read-only non-whitespace character on this line. - -@findex kotl-mode:backward-cell -@item kotl-mode:backward-cell @{@kbd{C-c C-b}@} -Move to prefix ARGth prior cell (same level) within current view. -Return number of cells left to move. - -@findex kotl-mode:backward-char -@item kotl-mode:backward-char @{@kbd{C-b}@} -Move point backward ARG (or 1) characters and return point. - -@findex kotl-mode:backward-kill-word -@item kotl-mode:backward-kill-word @{@kbd{M-DEL}@} -Kill up to prefix ARG words preceding point within a single cell. - -@findex kotl-mode:backward-sentence -@item kotl-mode:backward-sentence @{@kbd{M-a}@} -Move point backward ARG (or 1) sentences and return point. - -@findex kotl-mode:backward-word -@item kotl-mode:backward-word @{@kbd{M-b}@} -Move point backward ARG (or 1) words and return point. - -@findex kotl-mode:beginning-of-buffer -@item kotl-mode:beginning-of-buffer @{@kbd{M-<}@} -Move point to beginning of buffer and return point. - -@findex kotl-mode:beginning-of-cell -@item kotl-mode:beginning-of-cell @{@kbd{C-c ,}@} -Move point to beginning of current or ARGth - 1 prior cell and return point. - -@findex kotl-mode:beginning-of-line -@item kotl-mode:beginning-of-line @{@kbd{C-a}@} -Move point to beginning of current or ARGth - 1 line and return point. - -@findex kotl-mode:beginning-of-tree -@item kotl-mode:beginning-of-tree @{@kbd{C-c ^}@} -Move point to the level 1 root of the current cell's tree. -Leave point at the start of the cell. - -@findex kotl-mode:center-line -@item kotl-mode:center-line @{@kbd{M-s}@} -@vindex fill-column -Center the line point is on, within the width specified by @var{fill-column}. -This means adjusting the indentation so that it equals the distance between -the end of the text and @var{fill-column}. - -@findex kotl-mode:center-paragraph -@item kotl-mode:center-paragraph @{@kbd{M-S}@} -Center each nonblank line in the paragraph at or after point. -See @code{center-line} for more info. - -@findex kotl-mode:copy-after -@item kotl-mode:copy-after @{@kbd{C-c c}@} -Copy tree rooted at FROM-CELL-REF to follow tree rooted at TO-CELL-REF. -If prefix arg CHILD-P is non-nil, make FROM-CELL-REF the first child of -TO-CELL-REF, otherwise make it the sibling following TO-CELL-REF. - -Leave point at the start of the root cell of the new tree. - -@findex kotl-mode:copy-before -@item kotl-mode:copy-before @{@kbd{C-c C-c}@} -Copy tree rooted at FROM-CELL-REF to precede tree rooted at TO-CELL-REF. -If prefix arg PARENT-P is non-nil, make FROM-CELL-REF the first child of -TO-CELL-REF's parent, otherwise make it the preceding sibling of TO-CELL-REF. - -Leave point at the start of the root cell of the new tree. - -@findex kotl-mode:copy-to-buffer -@item kotl-mode:copy-to-buffer @{@kbd{C-c M-c}@} -Copy outline tree rooted at CELL-REF to a non-koutline BUFFER. -Use 0 to copy the whole outline buffer. - -@findex kotl-mode:copy-to-register -@item kotl-mode:copy-to-register @{@kbd{C-x x}@} -Copy into REGISTER the region START to END. -With optional prefix arg DELETE-FLAG, delete region. - -@findex kotl-mode:delete-backward-char -@item kotl-mode:delete-backward-char @{@kbd{DEL}@} -Delete up to the preceding prefix ARG characters. -Return number of characters deleted. -Optional KILL-FLAG non-nil means save in kill ring instead of deleting. -Does not delete across cell boundaries. - -@findex kotl-mode:delete-blank-lines -@item kotl-mode:delete-blank-lines @{@kbd{C-x C-o}@} -On blank line within a cell, delete all surrounding blank lines, leaving just one. -On isolated blank line, delete that one. -On nonblank line, delete all blank lines that follow it. - -If nothing but whitespace follows point until the end of a cell, delete all -whitespace at the end of the cell. - -@findex kotl-mode:delete-char -@item kotl-mode:delete-char @{@kbd{C-d}@} -Delete up to prefix ARG characters following point. -Return number of characters deleted. -Optional KILL-FLAG non-nil means save in kill ring instead of deleting. -Does not delete across cell boundaries. - -@findex kotl-mode:delete-indentation -@item kotl-mode:delete-indentation @{@kbd{M-^}@} -Join this line to previous and fix up whitespace at join. -If there is a fill prefix, delete it from the beginning of this line. -With argument, join this line to following line. - -@findex kotl-mode:demote-tree -@vindex kotl-mode:refill-flag -@item kotl-mode:demote-tree @{@kbd{TAB}@} -Move current kotl a maximum of prefix ARG levels lower in current view. -Each cell is refilled iff its @emph{no-fill} attribute is nil and -@var{kotl-mode:refill-flag} is non-nil. With prefix ARG = 0, cells are -demoted up to one level and kotl-mode:refill-flag is treated as true. - -@findex kotl-mode:down-level -@item kotl-mode:down-level @{@kbd{C-c C-d}@} -Move down prefix ARG levels lower within current tree. - -@findex kotl-mode:end-of-buffer -@item kotl-mode:end-of-buffer @{@kbd{M->}@} -Move point to end of buffer and return point. - -@findex kotl-mode:end-of-cell -@item kotl-mode:end-of-cell @{@kbd{C-c .}@} -Move point to end of current or ARGth - 1 succeeding cell and return point. - -@findex kotl-mode:end-of-line -@item kotl-mode:end-of-line @{@kbd{C-e}@} -Move point to end of current or ARGth - 1 line and return point. - -@findex kotl-mode:end-of-tree -@item kotl-mode:end-of-tree @{@kbd{C-c $}@} -Move point to the last cell in tree rooted at the current cell. -Leave point at the start of the cell. - -@findex kotl-mode:exchange-cells -@item kotl-mode:exchange-cells @{@kbd{C-c e}@} -Exchange CELL-REF-1 with CELL-REF-2 in current view. Don't move point. - -@findex kotl-mode:fill-cell -@item kotl-mode:fill-cell @{@kbd{C-c M-j}@} -Fill current cell within current view if it does not have the 'no-fill attribute. -With optional JUSTIFY, justify cell as well. -IGNORE-COLLAPSED-P is used when caller has already expanded cell, indicating -it is not collapsed. - -@findex kotl-mode:fill-paragraph -@item kotl-mode:fill-paragraph @{@kbd{C-x f}@} -Fill current paragraph within cell. With optional JUSTIFY, justify -paragraph as well. Ignore any non-nil no-fill attribute attached to the -cell. - -@findex kotl-mode:fill-tree -@item kotl-mode:fill-tree @{@kbd{C-M-j}@} -Refill each cell within the tree whose root is at point. - -@findex kotl-mode:first-sibling -@item kotl-mode:first-sibling @{@kbd{C-c <}@} -Move point to the first sibling of the present cell. -Leave point at the start of the cell or at its present position if it is -already within the first sibling cell. - -@findex kotl-mode:fkey-backward-char -@item kotl-mode:fkey-backward-char @{@kbd{left}@} -Move point backward ARG (or 1) characters and return point. - -@findex kotl-mode:fkey-forward-char -@item kotl-mode:fkey-forward-char @{@kbd{right}@} -Move point forward ARG (or 1) characters and return point. - -@findex kotl-mode:fkey-next-line -@item kotl-mode:fkey-next-line @{@kbd{down}@} -Move point to ARGth next line and return point. - -@findex kotl-mode:fkey-previous-line -@item kotl-mode:fkey-previous-line @{@kbd{up}@} -Move point to ARGth previous line and return point. - -@findex kotl-mode:forward-cell -@item kotl-mode:forward-cell @{@kbd{C-c C-f}@} -Move to prefix ARGth following cell (same level) within current view. -Return number of cells left to move. - -@findex kotl-mode:forward-char -@item kotl-mode:forward-char @{@kbd{C-f}@} -Move point forward ARG (or 1) characters and return point. - -@findex kotl-mode:forward-para -@item kotl-mode:forward-para @{@kbd{M-n}@} -Move to prefix ARGth next cell (any level) within current view. - -@findex kotl-mode:forward-paragraph -@item kotl-mode:forward-paragraph @{@kbd{M-]}@} -Move to prefix ARGth next cell (any level) within current view. - -@findex kotl-mode:forward-sentence -@item kotl-mode:forward-sentence @{@kbd{M-e}@} -Move point forward ARG (or 1) sentences and return point. - -@findex kotl-mode:forward-word -@item kotl-mode:forward-word @{@kbd{M-f}@} -Move point forward ARG (or 1) words and return point. - -@findex kotl-mode:goto-cell -@item kotl-mode:goto-cell @{@kbd{C-c g}@} -Move point to start of cell given by CELL-REF. (See `kcell:ref-to-id'.) -Return point iff CELL-REF is found within current view. -With a prefix argument, CELL-REF is assigned the argument value for use -as an idstamp. - -Optional second arg, ERROR-P, non-nil means signal an error if CELL-REF is -not found within current view. Will signal same error if called -interactively when CELL-REF is not found. - -@findex kotl-mode:hide-sublevels -@item kotl-mode:hide-sublevels @{@kbd{C-X $}@} -Hide all cells in outline at levels deeper than LEVELS-TO-KEEP (a -number). Shows any hidden cells within LEVELS-TO-KEEP. 1 is the first -level. - -@findex kotl-mode:hide-subtree -@item kotl-mode:hide-subtree @{@kbd{C-M-h}@} -Hide subtree, ignoring root, at optional CELL-REF (defaults to cell at -point). - -@findex kotl-mode:hide-tree -@item kotl-mode:hide-tree @{@kbd{C-c BS}@} -Collapse kotl rooted at optional CELL-REF (defaults to cell at point). - -@findex kotl-mode:insert-file -@item kotl-mode:insert-file @{@kbd{C-x i}@} -Insert each paragraph in IMPORT-FROM as a separate cell in the current view. -Insert as sibling cells following the current cell. IMPORT-FROM may be a -buffer name or file name (file name completion is provided). - -@findex kotl-mode:insert-register -@item kotl-mode:insert-register @{@kbd{C-c r i}@} -Insert contents of register REGISTER at point in current cell. -REGISTER is a character naming the register to insert. -Normally puts point before and mark after the inserted text. -If optional second arg is non-nil, puts mark before and point after. -Interactively, second arg is non-nil if prefix arg is supplied. - -@findex kotl-mode:just-one-space -@item kotl-mode:just-one-space @{@kbd{M-\}@} -Delete all spaces and tabs around point and leave one space. - -@findex kotl-mode:kcell-help -@item kotl-mode:kcell-help @{@kbd{C-c h}@} -Display a temporary buffer with CELL-REF's properties. -CELL-REF defaults to current cell. -Optional prefix arg CELLS-FLAG selects the cells to print: - If = 1, print CELL-REF's cell only; - If > 1, print CELL-REF's visible kotl (the tree rooted at CELL-REF); - If < 1, print all visible cells in current view (CELL-REF is not used). - -See also the documentation for @code{kotl-mode:properties}. - -@findex kotl-mode:kill-contents -@item kotl-mode:kill-contents @{@kbd{C-c k}@} -Kill contents of cell from point to cell end. -With prefix ARG, kill entire cell contents. - -@findex kotl-mode:kill-line -@item kotl-mode:kill-line @{@kbd{C-k}@} -Kill ARG lines from point. - -@findex kotl-mode:kill-region -@item kotl-mode:kill-region @{@kbd{C-w}@} -Kill region between START and END within a single kcell. -With optional COPY-P equal to 't, copy region to kill ring but does not -kill it. With COPY-P any other non-nil value, return region as a -string without affecting kill ring. - -If the buffer is read-only and COPY-P is nil, the region will not be deleted -but it will be copied to the kill ring and then an error will be signaled. - -@findex kotl-mode:kill-ring-save -@item kotl-mode:kill-ring-save @{@kbd{M-w}@} -Copy region between START and END within a single kcell to kill ring. - -@findex kotl-mode:kill-sentence -@item kotl-mode:kill-sentence @{@kbd{M-k}@} -Kill up to prefix ARG (or 1) sentences following point within a single cell. - -@findex kotl-mode:kill-tree -@item kotl-mode:kill-tree @{@kbd{C-c C-k}@} -Kill ARG following trees starting with tree rooted at point. -If ARG is not a non-positive number, nothing is done. - -@findex kotl-mode:kill-word -@item kotl-mode:kill-word @{@kbd{M-d}@} -Kill up to prefix ARG words following point within a single cell. - -@findex kotl-mode:last-sibling -@item kotl-mode:last-sibling @{@kbd{C-c >}@} -Move point to the last sibling of the present cell. -Leave point at the start of the cell or at its present position if it is -already within the last sibling cell. - -@findex kotl-mode:mail-tree -@item kotl-mode:mail-tree @{@kbd{C-c @@}@} -Mail outline tree rooted at CELL-REF. Use "0" for whole outline buffer. - -@findex kotl-mode:move-after -@item kotl-mode:move-after @{@kbd{C-c m}@} -Move tree rooted at FROM-CELL-REF to follow tree rooted at TO-CELL-REF. -If prefix arg CHILD-P is non-nil, make FROM-CELL-REF the first child of -TO-CELL-REF, otherwise make it the sibling following TO-CELL-REF. -With optional COPY-P, copies tree rather than moving it. - -Leave point at original location but return the tree's new start point. - -@findex kotl-mode:move-before -@item kotl-mode:move-before @{@kbd{C-c RET}@} -Move tree rooted at FROM-CELL-REF to precede tree rooted at TO-CELL-REF. -If prefix arg PARENT-P is non-nil, make FROM-CELL-REF the first child of -TO-CELL-REF's parent, otherwise make it the preceding sibling of TO-CELL-REF. -With optional COPY-P, copies tree rather than moving it. - -Leave point at original location but return the tree's new start point. - -@findex kotl-mode:newline -@item kotl-mode:newline @{@kbd{RET}@} -Insert a newline. With ARG, insert ARG newlines. -In Auto Fill mode, if no numeric arg, break the preceding line if it is -too long. - -@findex kotl-mode:next-cell -@item kotl-mode:next-cell @{@kbd{C-c C-n}@} -Move to prefix ARGth next cell (any level) within current view. - -@findex kotl-mode:next-line -@item kotl-mode:next-line @{@kbd{C-n}@} -Move point to ARGth next line and return point. - -@findex kotl-mode:open-line -@item kotl-mode:open-line @{@kbd{C-o}@} -Insert a newline and leave point before it. -With arg N, insert N newlines. - -@findex kotl-mode:overview -@item kotl-mode:overview @{@kbd{C-c C-o}@} -Show only the first line of each cell in the current outline. - -@findex kotl-mode:previous-cell -@item kotl-mode:previous-cell @{@kbd{C-c C-p}@} -Move to prefix ARGth previous cell (any level) within current view. - -@findex kotl-mode:previous-line -@item kotl-mode:previous-line @{@kbd{C-p}@} -Move point to ARGth previous line and return point. - -@findex kotl-mode:promote-tree -@vindex kotl-mode:refill-flag -@item kotl-mode:promote-tree @{@kbd{M-TAB}@} -Move current kotl a maximum of prefix ARG levels higher in current view. -Each cell is refilled iff its @emph{no-fill} attribute is nil and -@var{kotl-mode:refill-flag} is non-nil. With prefix ARG = 0, cells are -promoted up to one level and kotl-mode:refill-flag is treated as true. - -@findex kotl-mode:scroll-down -@item kotl-mode:scroll-down @{@kbd{M-v}@} -Scroll text of current window downward ARG lines; or a windowful if no ARG. - -@findex kotl-mode:scroll-up -@item kotl-mode:scroll-up @{@kbd{C-v}@} -Scroll text of current window upward ARG lines; or a windowful if no ARG. - -@findex kotl-mode:set-cell-attribute -@item kotl-mode:set-cell-attribute @{@kbd{C-c C-i}@} -Include ATTRIBUTE VALUE with the current cell or the cell at optional POS. -Replaces any existing value that ATTRIBUTE has. -When called interactively, it displays the setting in the minibuffer as -confirmation. - -@findex kotl-mode:set-fill-prefix -@item kotl-mode:set-fill-prefix @{@kbd{C-x l}@} -Sets fill prefix to line up to point. -With prefix arg TURN-OFF or at begin of line, turns fill prefix off. - -@findex kotl-mode:show-all -@item kotl-mode:show-all @{@kbd{C-c C-a}@} -Show (expand) all cells in current view. - -@findex kotl-mode:show-subtree -@item kotl-mode:show-subtree -Show subtree, ignoring root, at optional CELL-REF (defaults to cell at -point). - -@findex kotl-mode:show-tree -@item kotl-mode:show-tree @{@kbd{C-c C-s}@} -Display fully expanded kotl rooted at CELL-REF. - -@findex kotl-mode:split-cell -@item kotl-mode:split-cell @{@kbd{C-c s}@} -Split cell into two cells and move to new cell. -Cell contents after point become part of newly created cell. -Default is to create new cell as sibling of current cell. -With optional universal ARG, @kbd{C-u}, new cell is added as child of -current cell. - -@findex kotl-mode:top-cells -@item kotl-mode:top-cells @{@kbd{C-c C-t}@} -Collapse all level 1 cells in view and hide any deeper sublevels. - -@findex kotl-mode:transpose-cells -@item kotl-mode:transpose-cells @{@kbd{C-c t}@} -Exchange current and previous visible cells, leaving point after both. -If no previous cell, exchange current with next cell. -With prefix ARG, take current cell and move it past ARG cells. -With prefix ARG = 0, interchange the cell that contains point with the cell -that contains mark. - -@findex kotl-mode:transpose-chars -@item kotl-mode:transpose-chars @{@kbd{C-t}@} -Interchange characters around point, moving forward one character. -With prefix ARG, take character before point and drag it forward past ARG -other characters (backward if ARG negative). -If no prefix ARG and at end of line, the previous two characters are -exchanged. - -@findex kotl-mode:transpose-lines -@item kotl-mode:transpose-lines @{@kbd{C-x C-t}@} -Exchange current line and previous line, leaving point after both. -If no previous line, exchange current with next line. -With prefix ARG, take previous line and move it past ARG lines. -With prefix ARG = 0, interchange the line that contains point with the line -that contains mark. - -@findex kotl-mode:transpose-words -@item kotl-mode:transpose-words @{@kbd{M-t}@} -Interchange words around point, leaving point after both words. -With prefix ARG, take word before or around point and drag it forward past -ARG other words (backward if ARG negative). If ARG is zero, the words around -or after point and around or after mark are interchanged. - -@findex kotl-mode:up-level -@item kotl-mode:up-level @{@kbd{C-c C-u}@} -Move up prefix ARG levels higher in current outline view. - -@findex kotl-mode:yank -@item kotl-mode:yank @{@kbd{C-y}@} -Reinsert the last stretch of killed text. -More precisely, reinsert the stretch of killed text most recently -killed OR yanked. Put point at end, and set mark at beginning. -With just C-u as argument, same but put point at beginning (and mark at end). -With argument N, reinsert the Nth most recently killed stretch of killed -text. -See also the command M-x kotl-mode:yank-pop. - -@findex kotl-mode:yank-pop -@item kotl-mode:yank-pop @{@kbd{M-y}@} -Replace just-yanked stretch of killed text with a different stretch. -This command is allowed only immediately after a @code{yank} or a -@code{yank-pop}. At such a time, the region contains a stretch of -reinserted previously-killed text. @code{yank-pop} deletes that text -and inserts in its place a different stretch of killed text. - -With no argument, the previous kill is inserted. -With argument N, insert the Nth previous kill. -If N is negative, this is a more recent kill. - -The sequence of kills wraps around, so that after the oldest one -comes the newest one. - -@findex kotl-mode:zap-to-char -@item kotl-mode:zap-to-char @{@kbd{M-z}@} -Kill up to and including prefix ARG'th occurrence of CHAR. -Goes backward if ARG is negative; error if CHAR not found. - -@findex kview:set-label-type -@item kview:set-label-type @{@kbd{C-c C-l}@} -Change kview's label display type to NEW-TYPE, updating all displayed labels. -See documentation for variable, kview:default-label-type, for -valid values of NEW-TYPE. - -@findex kvspec:activate -@item kvspec:activate @{@kbd{C-c C-v}@} -Activate optional VIEW-SPEC or existing view spec in the current koutline. -VIEW-SPEC is a string. See <$@{hyperb:dir@}/kotl/EXAMPLE.kotl, 2b17=048> for -details on valid view specs. - -@findex kvspec:toggle-blank-lines -@item kvspec:toggle-blank-lines @{@kbd{C-c b}@} -Toggle blank lines between cells on or off. - -@end table - -@node Suggestion or Bug Reporting, Questions and Answers, Outliner Keys, Top -@appendix Suggestion or Bug Reporting - -@xref{Mail Lists}, for complete details on Hyperbole mailing lists and -how to subscribe. - -@cindex version description -@cindex Hyperbole version -If you find any errors in Hyperbole's operation or documentation, feel -free to report them to the Hyperbole discussion list: -<hyperbole@@infodock.com>. Be sure to use the Msg/Compose-Hypb-Mail -minibuffer menu item whenever you send a message to the mail list since -it will insert important system version information for you. - -If you use Hyperbole mail or news support, @ref{Buttons in Mail}, a -click with your Action Key on the Hyperbole mail list address -will insert a description of your Hyperbole configuration information -into your outgoing message, so that you do not have to type it. This is -useful when composing a reply for the Hyperbole mail list. Otherwise, -be sure to include your Emacs, Hyperbole and window system versions in -your message. Your Hyperbole version number can be found in the -top-level Hyperbole menu. - -Please use your subject line to state the position that your message -takes on the topic that it addresses, e.g@. send "Subject: Basic bug in -top-level Hyperbole menu." rather than "Subject: Hyperbole bug". This -simple rule makes all e-mail communication much easier. - -If you have suggestions on how to improve Hyperbole, send them to the -same address. Here are some issues you might address: - -@itemize @bullet -@item -What did you like and dislike about the system? -@item -What kinds of tasks, if any, does it seem to help you with? -@item -What did you think of the Emacs-based user interface? -@item -How was the Hyperbole Manual and other documentation? -@item -Was the setup trivial, average or hard? -@item -What areas of Hyperbole would you like to see expanded/added? -@item -How does it compare to other hypertext tools you have used? -@item -Was it easy or difficult to create your own types? Why? -@item -Did you get any use out of the external system encapsulations? -@end itemize - -@node Questions and Answers, Future Work, Suggestion or Bug Reporting, Top -@appendix Questions and Answers - -@table @emph -@cindex Smart Key -@cindex mouse key bindings -@findex hmouse-setup -@findex hmouse-get-bindings -@vindex file, hmouse-sh.el -@vindex file, hmouse-reg.el -@item How can I change the Smart Mouse Key bindings? -@findex hmouse-shift-buttons -Since the Smart Mouse Keys are set up for use under five different Emacs -configurations, there is no easy way to provide user level -customization. The command, @code{hmouse-shift-buttons}, can be used to -select between shifted and unshifted Smart Mouse Keys. Any other mouse -key binding changes must be done by editing the @code{hmouse-setup} and -@code{hmouse-get-bindings} functions in the @file{hmouse-sh.el} and -@file{hmouse-reg.el} files. - -@vindex file, hmouse-key.el -@vindex file, hui-window.el -@vindex hkey-alist -@vindex hmouse-alist -The @var{hkey-alist} and @var{hmouse-alist} variable -settings in @file{hui-mouse.el} and @file{hui-window.el} must be altered -if you want to change what the Smart Keys do in particular contexts. -You should then update the Smart Key summary documentation in the file, -@file{hypb-mouse.txt}, and potentially the same summary in this manual. - - -@item Missing Action Types - -What if someone sends a mail message with a button for which I do -not have the action type? Or a button whose link referent I can't access? - -You receive an error that an action type is not defined or a link -referent is not accessible/readable if you try to use the button. This -is hardly different than trying to get through a locked door without a -key; you try the doorknob, find that it is locked, and then realize that -you need to take a different approach or else give up. - -Like all communication, people need to coordinate, which usually -requires an iterative process. If you get a mail message with a button -for which you don't have the action type, you mail the sender and -request it. - -@cindex global button, modify -@item How can I modify a number of global buttons in succession? - -Rather than typing the name for each, it is quicker to jump to the -global button file and edit the buttons there as you would any explicit -buttons. By default, the ButFile/PersonalFile menu item takes you to -the file where global buttons are saved. - -@item Why is all the button data scattered across directories? - -When you think of a hyper-space that you depend on every day, you don't -want to have a single point of failure make you incapable of doing work. -With Hyperbole, if some directories become unavailable for a particular -time (e.g@. the filesystems on which they reside are dismounted) you can -still work elsewhere with minimal effect. We believe this to be a -compelling factor to leave the design with external button data storage. - -This design also permits the potential addition of buttons to read-only -media. - -@item Why are action types defined separately from their implicit button types? - -Any category of button can make use of an action type. Some action types -are useful as behavior definitions for a variety of button categories, -so all action types are defined separately to give them independence -from those types which apply them. - -For implicit button types that require a lot of code, it is useful to -add a module that includes the implicit button type definition, its -action type definition and supporting code. - -@end table - - -@node Future Work, References, Questions and Answers, Top -@appendix Future Work - -@noindent -This appendix is included for a number of reasons: - -@itemize @bullet -@item -to better allow you to assess whether to work with Hyperbole by -providing sketches of possible additions: -@item -to direct further development effort towards known needs; -@item -and to acknowledge known weaknesses in the current system. -@end itemize - -@table @asis - -Note that due to a lack of volunteers to further develop Hyperbole, much -of this work may not be done. So if you want to see these features, -encourage qualified people to volunteer. - -@item Button Copying, Killing, and Yanking -There is as yet no means of transferring explicit buttons among buffers. -We realize this is a critical need. Users should be able to manipulate -text with embedded buttons in ordinary ways. This will probably be -implemented only for versions of Emacs 19 and higher. It will store the -button attributes as text attributes within the buffers so that if a -button is copied, its attributes follow. When a buffer is saved, the -attributes also will be saved. - -@item Trails -Trails are an extension to the basic history mechanism presently offered -by Hyperbole. Trails will allow a user to capture, edit and store a -specific sequence and set of views of information for later replay by -other users. Conditional branching may also be supported. - -@item Outliner View Mode -This will complement the outliner editing mode by using simple one -character keys that normally insert characters to instead modify the -view of an outline and to move around in it, for ease of study. -Switching between view and edit modes will also be simple. - -@item Storage of button data within button source files -The current design choice of storing buttons external to the source file -was made under the assumption that people should be able to look at -files that contain Hyperbole buttons with any standard editor or tool -and not be bothered by the ugly button data (since they won't be able to -utilize the buttons anyway, they don't need to see or have access to -them). - -In many contexts, embedding the button data within the source files may -be a better choice, so a provision which would allow selection of either -configuration may be added. Here are some of the PROs and CONs of both -design choices: -@sp 1 - -@example -@group - POSITIVE NEGATIVE - -Button data in source file - Documents can stand alone. All edit operators have - Normal file operations apply. to account for file - structure and hide - Simplifies creation and internal components. - facility expansion for - structured and multi-media - files. - -Button data external to source file - Files can be displayed and Currently, bdata for - printed exactly as they look. whole directory is - No special display formatting locked when any bdata - is necessary. entry is locked. - - Button-based searches and - database-type lookup operations - need only search one file - per directory. -@end group -@end example -@sp 2 - -@item Forms-based Interfaces - -This will allow one to create buttons more flexibly. For example, button -attributes could be given in any order. Entry of long code sequences, -quick note taking and cross-referencing would also be made easier. - -@item Collaboration Support - -From the early stages of Hyperbole design, collaborative work -environments have been considered. A simple facility has demonstrated -broadcast of button activations to a number of workstations on a local -area network, so that one user can lead others around an information -space, as during an online design review. (This facility was never -adapted to the current Hyperbole release, however.) We shall do some -work in specific collaborative mechanisms, but we also expect that -others who concentrate in collaborative work will provide more extensive -capabilities. - -@end table - -@node References, Key Binding Index, Future Work, Top -@appendix References - -@table @b -@item [AkMcYo88] -Akscyn, R. M., D. L. McCracken and E. A. Yoder. KMS: A -Distributed Hypermedia System for Managing Knowledge in Organizations. -@emph{Communications of the ACM}, Vol. 31, No. 7, July 1988, pp. 820-835. - -@item [Bro87] -Brown, P. J. Turning Ideas into Products: The Guide System. -@emph{Proceedings of Hypertext '87}, November 13-15, 1987, Chapel Hill, NC. -ACM: NY, NY, pp. 33-40. - -@item [Con87] -Conklin, Jeff. Hypertext: An Introduction and Survey. @emph{IEEE -Computer}, Vol. 20, No. 9, September 1987, pp. 17-41. - -@item [Eng68] -Engelbart, D., and W. English. A research center for augmenting -human intellect. @emph{Proceedings of the Fall Joint Computer Conference}, -33, 1, AFIPS Press: Montvale, NJ, 1968, pp. 395-410. - -@item [Eng84a] -Engelbart, D. C. Authorship Provisions in Augment. -@emph{Proceedings of the 1984 COMPCON Conference (COMPCON '84 Digest)}, -February 27-March 1, 1984, San Francisco, CA. IEEE Computer Society Press, -Spring, 1984. 465-472. (OAD,2250,) - -@item [Eng84b] -Engelbart, D. C. Collaboration Support Provisions in Augment. -@emph{Proceedings of the AFIPS Office Automation Conference (OAC '84 Digest)}, -February, 1984, Los Angeles, CA, 1984. 51-58. (OAD,2221,) - -@item [Fos88] -Foss, C. L. Effective Browsing in Hypertext Systems. -@emph{Proceedings of the Conference on User-Oriented Content-Based Text and -Image Handling (RIAO 88)}, March 21-24, MIT, Cambridge MA. Centre de Hautes -Etudes Internationales d'Informatique Documentaire, 1988, pp. 82-98. - -@item [GaSmMe86] -Garrett, N., K. E. Smith and N. Meyrowitz. Intermedia: Issues, -Strategies, and Tactics in the Design of a Hypermedia Document System. -@emph{Computer-Supported Cooperative Work (CSCW '86) Proceedings}, December -3-5, Austin, TX, 1986, pp. 163-174. - -@item [HaMoTr87] -Halasz, F. G., T. P. Moran and R. H. Trigg. NoteCards in a -Nutshell. @emph{Proceedings of the CHI and GI '87 Conference on Human Factors -in Computing Systems}, Toronto, J. M. Carroll and P. P. Tanner, (editors), -ACM: NY, NY, April 1987, pp. 45-52. - -@item [Har88] -Harvey, G. @emph{Understanding HyperCard.} Alameda, CA: SYBEX, Inc., -1988. - -@item [KaCaLoLa92] -Kaplan, S., A. M. Carroll, C. Love and D. M. LaLiberte. -@emph{Epoch 4.0 Manual.} Department of Computer Science, University of -Illinois, Urbana, March 1992. - -@item [KaKaBeLaDr90] -Kaplan, S. J., M. D. Kapor, E. J. Belove, R. A. Landsman, and -T. R. Drake. AGENDA: A personal Information Manager. @emph{Communications -of the ACM}, No. 33, July 1990, pp. 105-116. - -@item [Nel87a] -Nelson, T. H. @emph{Computer Lib/Dream Machines.} MicroSoft Press, -Redmond, WA, 1987. - -@item [Nel87b] -Nelson, T. H. @emph{Literary Machines, Edition 87.1}. Available -from the Distributors, 702 South Michigan, South Bend, IN 46618, 1987. - -@item [NoDr86] -Norman, D. A. and S. W. Draper, editors. @emph{User Centered System -Design.} Lawrence Erlbaum Associates: Hillsdale, New Jersey, 1986. - -@item [Shn82] -Shneiderman, B. The future of interactive systems and the emergence -of direct manipulation. @emph{Behavior and Information Technology}, Vol. 1, -1982, pp. 237-256. - -@item [Sta87] -Stallman, R. @emph{GNU Emacs Manual.} Free Software Foundation, -Cambridge: MA, March 1987. - -@item [Tri86] -Trigg, R., L. Suchman, and F. Halasz. Supporting collaboration in -NoteCards. @emph{Proceedings of the CSCW '86 Conference}, Austin, TX, -December 1986, pp. 147-153. - -@item [TrMoHa87] -Trigg, R. H., T. P. Moran and F. G. Halasz. Adaptability and -Tailorability in NoteCards. @emph{Proceedings of INTERACT '87}, Stuttgart, -West Germany, September 1987. - -@item [Wei92] -Weiner, B. @emph{PIEmail: A Personalized Information Environment -Mail Tool.} Department of Computer Science Masters Project, Brown -University: Providence, RI, May 10, 1992. - -@item [YaHaMeDr88] -Yankelovich, N., B. J. Haan, N. Meyrowitz and S. M. Drucker. -Intermedia: The Concept and the Construction of a Seamless Information -Environment. @emph{IEEE Computer}, Vol. 21, No. 1, January 1988, pp. 81-96. - -@item [YoAkMc89] -Yoder, E. A., R. M. Akscyn and D. L. McCracken. Collaboration in -KMS, A Shared Hypermedia System. @emph{Proceedings of the 1989 ACM Conference -on Human Factors in Computer Systems (CHI '89)}, April 30-May 4, 1989, -Austin, TX, ACM: NY,NY, 1989, pp. 37-42. - -@end table - - -@c *************************** -@c Indices -@c *************************** - -@node Key Binding Index, Code and File Index, References, Top -@unnumbered Key Binding Index - -@printindex ky - -@node Code and File Index, Concept Index, Key Binding Index, Top -@unnumbered Code and File Index - -@printindex fn - -@node Concept Index, , Code and File Index, Top -@unnumbered Concept Index - -@printindex cp - -@page -@summarycontents -@contents -@bye
--- a/man/ilisp.texi Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2160 +0,0 @@ -\input texinfo @c -*-texinfo-*- Last modified: October 25, 1996 -@setfilename ilisp.info -@settitle The ILISP Inferior LISP Interface - -@c NOTE: KEYBINDING DESCRIPTIONS IN THIS FILE -@c -@c Texinfo doesn't support the functionality of substitute-command-keys, -@c which kind of makes things tough when the bindings change. -@c -@c Note that all the keys here which use the ILISP prefix have -@c @key{C-z} before them, so a global replace can be used to put in a -@c specific value for this (if wanted). The whole string should be -@c rpelaced, as in (replace-string "@key{C-z}" "@key{C-c}"). Any occurrances -@c of this should be in the proper @kbd{} construct, or in a table. -@c -@c Key command descriptions in tables have the function listed after -@c them, as in "@item RET (return-ilisp)" so it should be poosible -@c to update these descriptions with a little elisp code. -@c -@c Todd Kaufmann 17-Mar-91 -@c toad@cs.cmu.edu - - -@c ================================================================ -@c THIS file has the new style title page commands. - -@c Run using special version of `texinfo.tex'. -@c Version 2.13 or higher is recommended. - -@c Also, run `makeinfo' rather than `texinfo-format-buffer'. -@c (Get the texinfo2 package.) -@c ================================================================ - -@c Use this if you want small book size like the GNU Emacs bound book. -@c smallbook - -@c tex -@c \overfullrule=0pt -@c end tex - -@comment INDEX USAGE: -@c -@c @cindex concept -@c @findex function -@c @vindex variable -@c @kindex key -@c @pindex command (normally program) -@c -@c not used: -@c @tindex (data)type - - -@c -@c Combine indices. -@c @synindex cp fn -@c @syncodeindex vr fn -@c @syncodeindex ky fn -@c @syncodeindex pg fn -@c @syncodeindex tp fn -@c oops: texinfo-format-buffer ignores synindex -@c So, use makeinfo.c. Get texinfo2.tar.Z off of prep.ai.mit.edu -@c - -@c TODO: -@c - Add doc for rlogin lisps. -@c - Add doc for trace-defun-break - - -@ifinfo -This file documents ILISP. - -This is edition 0.12 of the ILISP manual -for ILISP Version 5.8. - -Copyright (C) 1991,1992,1993 Todd Kaufmann - 1993,1994 Ivan Vasquez - 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker - 1996 Marco Antoniotti and Rick Campbell - -Permission is granted to make and distribute verbatim copies of -this manual provided the copyright notice and this permission notice -are preserved on all copies. - -Permission is granted to copy and distribute modified versions of this -manual under the conditions for verbatim copying, provided that the entire -resulting derived work is distributed under the terms of a permission -notice identical to this one. - -Permission is granted to copy and distribute translations of this manual -into another language, under the above conditions for modified versions, -except that this permission notice may be stated in a translation approved -by the Foundation. -@end ifinfo -@c - -@c -@setchapternewpage odd - -@titlepage -@title ILISP User Manual -@subtitle A GNU Emacs Interface for Interacting with Lisp -@subtitle Edition 0.13, October 1996 -@subtitle For ILISP Version 5.8 -@c -@c the following comment string is removed by the ctrl-c-doc.sh script, -@c which can be used to change all ilisp-prefix bindings to C-c (or -@c other). -@c -@comment ctrl-C version: @subtitle This is the ``@key{C-z}'' version of the manual. - -@author by Todd Kaufmann, Chris McConnell, Ivan Vazquez, Marco Antoniotti, and Rick Campbell - -@page -@vskip 0pt plus 1filll -Copyright @copyright{} 1991, 1992, 1993 Todd Kaufmann - 1993, 1994 Ivan Vasquez - 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker - 1996 Marco Antoniotti and Rick Campbell - -@sp 2 -This is edition 0.12 of the @cite{ILISP User Manual} -for ILISP Version 5.8, -July 1996. - -@sp 2 - -Permission is granted to make and distribute verbatim copies of -this manual provided the copyright notice and this permission notice -are preserved on all copies. - -Permission is granted to copy and distribute modified versions of this -manual under the conditions for verbatim copying, provided that the entire -resulting derived work is distributed under the terms of a permission -notice identical to this one. - -Permission is granted to copy and distribute translations of this manual -into another language, under the above conditions for modified versions, -except that this permission notice may be stated in a translation approved -by this author. -@end titlepage -@page - - -@node Top, Distribution, (dir), (dir) -@comment node-name, next, previous, up - - -@ifinfo -This Info file documents ILISP, a GNU Emacs interface for a lisp -running in a buffer. -@comment ctrl-C version: @sp -@comment ctrl-C version: This is the ``@key{C-z}'' version of the manual. -@end ifinfo - -@menu -* Distribution:: How to get the latest ILISP distribution. - -* Acknowledgements:: Acknowledgements -* Introduction:: An introduction to ILISP and its features. -* Installation:: How to install ILISP. -* Starting up:: How to run a Lisp process using ILISP. - -* Buffers of ILISP:: Buffers used by ILISP, and their commands. -* ILISP Commands:: -* Customization:: Description of ILISP variables and hooks. -* Dialects:: How ILISP knows how to communicate with Lisp, - and how to define new dialects. - -Indices: -* Concept index:: General concepts. -* Key index:: ILISP key sequences. -* Command index:: Commands by name. -* Variable index:: Variables and hooks that influence ILISP's - behavior. - -* Function index:: Internal Emacs Lisp functions. -@end menu - -@node Distribution, Acknowledgements, Top, Top -@unnumbered How to get the latest ILISP distribution. - -ILISP is "free"; this means that everyone is free to use it and free -to redistribute it on a free basis. ILISP is not in the public domain; -it is copyrighted and there are restrictions on its distribution, but -these restrictions are designed to permit everything that a good -cooperating citizen would want to do. What is not allowed is to try to -prevent others from further sharing any version of ILISP that they might -get from you. The precise conditions appears following this section. - -The easiest way to get a copy of ILISP is from someone else who has it. -You need not ask for permission to do so, or tell any one else; just -copy it. - -If you do start using the package, please send mail to -@code{ilisp-request@@naggum.no} to subscribe to the ILISP mailing -list. - -Please send bugs, questions or suggestions for discussion to -@code{ilisp@@naggum.no}. Message sent there will be distributed to -all subscribers. - -@menu -* FTP directions:: FTP directions -* WWW directions:: WWW directions -@end menu - -@node FTP directions, WWW directions, , Distribution -@unnumberedsec FTP directions -@cindex FTP site -@cindex Anonymous FTP -@cindex How to get -@cindex Getting ILISP -@noindent -You can get the distribution file, @code{ilisp-5.8.tar.gz} via -anonymous FTP from @code{FTP.CS.CMU.EDU} (128.2.206.173) in -@code{/afs/cs/user/campbell/http/ilisp/}. - -@format -% @dfn{ftp ftp.cs.cmu.edu} -Name (ftp.cs.cmu.edu:rickc): @dfn{anonymous} -331 Guest login ok, send username@@node as password. -Password: @dfn{@var{your-user-id@@your-hostname}} -ftp> @dfn{cd /afs/cs/user/campbell/http/ilisp} -250 Directory path set to /afs/cs/user/campbell/http/ilisp. -ftp> @dfn{type binary} -200 Type set to I. -ftp> @dfn{get ilisp-5.8.tar.gz} -200 PORT command successful. -150 Opening data connection for ilisp-5.8.tar.gz. -226 Transfer complete. -local: ilisp-5.8.tar.gz remote: ilisp-5.8.tar.gz -168801 bytes received. -ftp> @dfn{quit} -221 Goodbye. -@end format - -@noindent -Or get whatever single files you need from the @code{untarred} -subdirectory. - -@noindent -You can also get @code{ilisp-5.8.tar.gz} via -anonymous FTP from @code{FTP.ICSI.BERKELEY.EDU} in either -@code{/pub/software/elisp/} or @code{/pub/theory/marcoxa/elisp/}. - -@noindent -Unpack and install: - -@code{% @dfn{gzip -dc ilisp-5.8.tar.gz | tar xf -}} - -@xref{Installation}. - -@node WWW directions, , FTP directions, Distribution -@unnumberedsec WWW directions -@cindex WWW site -@cindex How to get -@cindex Getting ILISP -@noindent -You can use the World Wide Web (WWW) to get the distribution file from -the anonymous FTP locations using one of the following URLs: -@itemize @bullet -@item -@code{ftp://ftp.cs.cmu.edu/afs/cs/user/campbell/http/ilisp/ilisp-5.8.tar.gz} -@item -@code{ftp://ftp.icsi.berkeley.edu/pub/software/elisp/ilisp-5.8.tar.gz} -@item -@code{ftp://ftp.icsi.berkeley.edu/pub/theory/marcoxa/ilisp-5.8.tar.gz} -@end itemize - -You can also use the CMU Artificial Intelligence Repository: - -@code{http://www.cs.cmu.edu/Web/Groups/AI/html/repository.html} - -@noindent -From there follow: @code{LISP}, @code{UTIL}, @code{EMACS} and finally -@code{ILISP}. Use your browser capabilities to download what you -need. - -@noindent -The complete URL for the distribution file in the CMU AI Repository is -@code{http://www.cs.cmu.edu/afs/cs/project/ai-repository/ai/lang/lisp/util/emacs/ilisp/v57/ilisp57.tgz} - -@noindent -Other URLs for the distribution file include: -@itemize @bullet -@item -@code{http://www.c2.net/~campbell/ilisp/ilisp-5.8.tar.gz} -@item -@code{http://www.cs.cmu.edu/~campbell/ilisp/ilisp-5.8.tar.gz} -@end itemize - -@noindent -Unpack and install: - -@code{% @dfn{gzip -dc ilisp-5.8.tar.gz | tar xf -}} - -@xref{Installation}. - -@node Acknowledgements, Introduction, Distribution, Top -@unnumbered Acknowledgements - -ILISP replaces the standard inferior LISP mode. ILISP is based on -comint mode and derived from a number of different interfaces including -Symbolics, CMU Common Lisp, and Thinking Machines. - -There are many people that have taken the time to report bugs, make -suggestions and even better send code to fix bugs or implement new -features. - -Thanks to Guido Bosch, David Braunegg, Tim Bradshaw, Thomas M. Breuel, -Hans Chalupsky, Kimball Collins, Brian Dennis, David Duff, Tom -Emerson, Michael Ernst, Scott Fahlman, David Gadbois, Robert -P. Goldman, Marty Hall, Richard Harris, Jim Healy, Christopher Hoover, -Larry Hunter, Ben Hyde, Chuck Irvine, Michael Kashket, Mark -Kantrowitz, Qiegang Long, Erik Naggum, Dan Pierson, Yusuf Pisan, Frank -Ritter, Jeffrey Mark Siskind, Neil Smithline, Richard Stallman, Larry -Stead, Jason Trenouth, Christof Ullwer, Bjorn Victor, Fred White, Ben -Wing, Matsuo Yoshihiro, Jamie Zawinski, Paul Fuqua (for the CMU-CL GC -display code) and Marco Antoniotti for bug reports, suggestions and -code. Our apologies to anyone we may have forgotten. - -Special thanks to Todd Kaufmann for the texinfo file, work on bridge, -epoch-pop and for really exercising everything. - -Please send bug reports, fixes and extensions to -@code{ilisp@@naggum.no} so that they can be merged into the master -source. -@noindent -@example ---Chris McConnell 18-Mar-91 ---Ivan Vazquez 27-Jun-93 ---Marco Antoniotti and Rick Campbell 25-Oct-96 -@end example - - -@node Introduction, Installation, Acknowledgements, Top -@unnumbered Introduction -@cindex features - -ILISP is an interface from GNU Emacs to an inferior LISP. It has the -following features: - -@itemize @bullet -@item -Runs under Emacs-18, Emacs-19, and XEmacs-19. - -@item -Support for multiple LISP dialects including Lucid, Allegro and CMU -on multiple machines even at the same time. - -@item -Dynamically sized pop-up windows that can be buried and scrolled from -any window. - -@item -Packages are properly handled including the distinction between -exported and internal symbols. - -@item -Synchronous, asynchronous or batch eval and compile of files, regions, -definitions and sexps with optional switching and automatic calling. - -@item -Arglist, documentation, describe, inspect and macroexpand. - -@item -Completion of filename components and LISP symbols including partial matches. - -@item -Find source both with and without help from the inferior LISP, -including CLOS methods, multiple definitions and multiple files. - - -@item -Edit the callers of a function with and without help from the -inferior LISP. - -@item -Trace/untrace a function. - -@item -@kbd{M-q} (``Fill-paragraph'') works properly on paragraphs in comments, -strings and code. - -@item -Find unbalanced parentheses. - -@item -Super brackets. - -@item -Handles editing, entering and indenting full LISP expressions. - -@item -Next, previous, and similar history mechanism compatible with comint. - -@item -Handles LISP errors. - -@item -Result histories are maintained in the inferior LISP. - -@item -Does not create spurious symbols and handles case issues. - -@item -Online manuals for ILISP and Common LISP. - -@end itemize - -@node Installation, Starting up, Introduction, Top -@chapter How to install ILISP -@cindex Installation -Installation of ILISP and some initialization of your computing -environment are described in this chapter. Please read the following -sections carefully before getting started with ILISP. - -If ILISP has already been installed at your location, you can probably -skip ahead to ``Autoloading.'' - -Note that Jamie Zawinki's byte-compiler is required when compiling -ILISP. If you don't have it, get it from -@code{ftp://archive.cis.ohio-state.edu/pub/gnu/emacs/elisp-archive/bytecomp2.tar.Z} - -You don't need it if you are running emacs version 19 as both the FSF -and XEmacs releases include this in their distributions. - -@menu -* Makefile configuration:: -* Files of ILISP:: -* Autoloading:: How to define autoload entries. -@end menu - -@node Makefile configuration, Files of ILISP, , Installation -@comment node-name, next, previous, up -@section Makefile configuration - -Some configuration needs to be done before compiling the emacs-lisp -files that comprise ILISP. This should be done in the -@code{Makefile} file in the section of the file marked -CONFIGURATION SECTION. - -First, set the @code{YOUR_EMACS} variable to be the pathname of the -emacs you will be using ILISP with. This is the emacs that will be used -to compile ILISP with. - -If you don't have Jamie Zawinski's byte compiler in your standard load -path ( both FSF's 19 and XEmacs 19 do have enhaced versions of it ) -then you will have to uncomment the @code{BYTECOMP} line and set it to -point to the correct location of the bytecomp files. - -If you do not have comint already in your emacs ( both FSF 19 and XEmacs -19 do ) then uncomment the @code{USE_BUNDLED_COMINT} line. This will -cause the copy of @code{comint.el} to be moved from the @code{Extras} -directory into the main ILISP directory. - -The advice section is left uncommented out in the distributed -@code{Makefile} because most people will not have -@code{advice.elc} in their load path. Only XEmacs will have -this in the standard distribution. If you do have it in your load path, -then to avoid having two copies in your load-path and avoiding future -confusion then comment out both the @code{ADVICE} and -@code{USE_BUNDLED_ADVICE} lines. - -@cindex Compiling ILISP files -@cindex Byte-compiling ILISP files -@findex ilisp-compile-inits -@vindex ilisp-load-inits -@vindex ilisp-site-hook -@vindex ilisp-program -@vindex ilisp-init-binary-command -@vindex ilisp-init-binary-extension - -You can then compile everything with the shell command - - @code{% @dfn{make -f Makefile-ilisp }}@dfn{@var{<your target here>}} - -Where the possible targets are @code{emacs_18}, @code{emacs_18_epoch}, -@code{emacs_18_menu}, and @code{emacs_19}. - -Ignore any compilation warnings unless they result in ILISP not -compiling completely. - -You should then copy relevant sections of @code{ilisp.emacs} to your -@code{.emacs} or to the system-wide @code{default.el} file, depending on -who will be using ILISP. - -You should add the directory where all of the ILISP emacs-lisp files -reside to your @code{load-path}. There is an example of this in -@code{ilisp.emacs} - -As an alternative you could set up a @code{.ilisp} which contains the -appropriate portions of @code{ilisp.emacs}, in order to avoid cluttering -too much @code{.emacs} or @code{default.el} - -The first time a dialect is started, the interface files will complain -about not being compiled, just hit @kbd{i} to ignore the message. Once -a lisp dialect is started up, you should execute the command -@code{ilisp-compile-inits} which will compile the @samp{*.lisp} files -and write them to the same directory as the ilisp files.@refill - -The binary files should have a unique -extension for each different combination of architecture and -LISP dialect. You will need to change -@code{ilisp-init-binary-extension} and -@code{ilisp-init-binary-command} to get additional -extensions. The binary for each different architecture -should be different. If you want to build the interface -files into a LISP world, you will also need to set -@code{ilisp-load-inits} to @code{nil} in the same place that -you change @code{ilisp-program} to load the LISP -world.@refill - - -There is an @code{ilisp-site-hook} for initializing site specific stuff -like program locations when ILISP is first loaded. You may want to -define appropriate autoloads in your system Emacs start up file. - -Example site init: -@example -;;; CMU site -(setq ilisp-site-hook - '(lambda () - (setq ilisp-motd "CMU ILISP V%s") - (setq expand-symlinks-rfs-exists t) - (setq allegro-program "/usr/misc/.allegro/bin/cl") - (setq lucid-program "/usr/misc/.lucid/bin/lisp"))) -@end example - - - -@node Files of ILISP, Autoloading, Makefile configuration, Installation -@section Files of ILISP -@cindex Files of ILISP -The files you need to use ilisp are: - -@table @file - -@item ilisp.emacs -File with sample @file{.emacs} code for ILISP. -@cindex @file{ilisp.emacs} - -@item symlink-fix.el -Expand pathnames resolving links. -@cindex @file{symlink-fix.el} - -@item completer.el -Partial completion code. -@cindex @file{completer.el} - -@item bridge.el -Process to process communication. -@cindex @file{bridge.el} - -@item comint.el -The basic comint abstraction. You only need this if running emacs-18. -@cindex @file{comint.el} - -@item comint-ipc.el -Extensions for sending commands and getting results. -@cindex @file{comint-ipc.el} - -@item ilisp-ext.el -Standalone lisp-mode extensions. -@cindex @file{ilisp-ext.el} - -@item ilisp-bug.el -ILISP bug submittal code. -@cindex @file{ilisp-bug.el} - -@item compat.el -Compatibility code between fsf-18, fsf-19 and lemacs-19. -@cindex @file{compat.el} - -@item ilisp-inp.el -Buffer input module. -@cindex @file{ilisp-inp.el} - -@item ilisp-def.el -Variable definitions. -@cindex @file{ilisp-def.el} - -@item ilisp-ind.el -Indentation code. -@cindex @file{ilisp-ind.el} - -@item ilisp-mov.el -Buffer-point movement code. -@cindex @file{ilisp-mov.el} - -@item ilisp-key.el -Keymap setups, including @code{ilisp-lispm-bindings}. -@cindex @file{ilisp-key.el} - -@item ilisp-doc.el -ILISP mode documenation. -@cindex @file{ilisp-doc.el} - -@item ilisp-mod.el -ILISP mode definition. -@cindex @file{ilisp-mod.el} - -@item ilisp-prn.el -Parenthesis handling. -@cindex @file{ilisp-prn.el} - -@item ilisp-el.el -Emacs-lisp additions. -@cindex @file{ilisp-el.el} - -@item ilisp-sym.el -ILISP symbol handling. -@cindex @file{ilisp-sym.el} - -@item ilisp-low.el -Low level interface code. -@cindex @file{ilisp-low.el} - -@item ilisp-hi.el -High level interface code. -@cindex @file{ilisp-hi.el} - -@item ilisp-out.el -Output handling, include typeout window (a popper replacement). -@cindex @file{ilisp-out.el} - -@item ilisp-prc.el -Process handling code. -@cindex @file{ilisp-prc.el} - -@item ilisp-val.el -Buffer value interface. -@cindex @file{ilisp-val.el} - -@item ilisp-rng.el -Match ring code. -@cindex @file{ilisp-rng.el} - -@item ilisp-utl.el -Misc. utilities. -@cindex @file{ilisp-utl.el} - -@item ilisp-hnd.el -Error handling. -@cindex @file{ilisp-hnd.el} - -@item ilisp-kil.el -Interface to reset/kill/abort inferior lisp. -@cindex @file{ilisp-kil.el} - -@item ilisp-snd.el -ilisp-send definitions and associated code. -@cindex @file{ilisp-snd.el} - -@item ilisp-cmt.el -Comint related code/setup. -@cindex @file{ilisp-cmt.el} - -@item ilisp-cmp.el -ILISP completer related code. -@cindex @file{ilisp-cmp.el} - -@item ilisp-xfr.el -Transfer between lisp <-> emacs code. -@cindex @file{ilisp-xfr.el } - -@item ilisp-cl.el -Commo-Lisp dialect definition. -@cindex @file{ilisp-cl.el} - -@item ilisp-src.el -ILISP source code module. -@cindex @file{ilisp-src.el} - -@item ilisp-bat.el -ILISP batch code module. -@cindex @file{ilisp-bat.el} - -@item ilisp.el -File to be loaded, loads in all necessary parts of ILISP. -@cindex @file{ilisp.el} - -@item *.lisp -ILISP support code. Each dialect will have one of these files. - -@item *.lcd -Package descriptors for the Lisp Code Directory. - -@item ilisp.texi -Texinfo file for ILISP. -@cindex @file{ilisp.texi} - -@end table - -@cindex @file{.el} files - -@node Autoloading, , Files of ILISP, Installation -@section How to define autoload entries -@cindex autoload definitions -@cindex defining autoloads -@cindex @file{.emacs} forms -A complete example of things you may want to add to your @code{.emacs} -can be found in the in the file @file{ilisp.emacs} in the -@code{ilisp-directory} what follows is that file. - - -@example -@c start of ilisp.emacs -;;; -;;; This file shows examples of some of the things you might want to -;;; do to install or customize ILISP. You may not want to include all -;;; of them in your .emacs. For example, the default key binding -;;; prefix for ILISP is C-z and this file changes the default prefix to -;;; C-c. For more information on things that can be changed, see the -;;; file ilisp.el. -;;; - -;;; If ilisp lives in some non-standard directory, you must tell emacs -;;; where to get it. This may or may not be necessary. -(setq load-path (cons (expand-file-name "~jones/emacs/ilisp/") load-path)) - -;;; If you always want partial minibuffer completion -(require 'completer) - -;;; If you want to redefine typeout-window keys: -(add-hook 'ilisp-load-hook - '(lambda () - (define-key global-map "\C-c1" 'ilisp-bury-output) - (define-key global-map "\C-cv" 'ilisp-scroll-output) - (define-key global-map "\C-cg" 'ilisp-grow-output))) - - -(autoload 'run-ilisp "ilisp" "Select a new inferior LISP." t) -;;; Autoload based on your LISP. You only really need the one you use. -;;; If called with a prefix, you will be prompted for a buffer and -;;; program. -;;; -;;; [Back to the old way now -- Ivan Mon Jun 28 23:30:51 1993] -;;; -(autoload 'clisp "ilisp" "Inferior generic Common LISP." t) -(autoload 'allegro "ilisp" "Inferior Allegro Common LISP." t) -(autoload 'lucid "ilisp" "Inferior Lucid Common LISP." t) -(autoload 'cmulisp "ilisp" "Inferior CMU Common LISP." t) -(autoload 'kcl "ilisp" "Inferior Kyoto Common LISP." t) -(autoload 'akcl "ilisp" "Inferior Austin Kyoto Common LISP." t) -(autoload 'ibcl "ilisp" "Ibuki Common LISP." t) -(autoload 'scheme "ilisp" "Inferior generic Scheme." t) -(autoload 'oaklisp "ilisp" "Inferior Oaklisp Scheme." t) - -;;; Define where LISP programs are found. (This may already be done -;;; at your site.) -(setq allegro-program "/usr/misc/.allegro/bin/cl") -(setq lucid-program "/usr/misc/.lucid/bin/lisp") -(setq cmulisp-program "/usr/misc/.cmucl/bin/lisp") - -;;; If you run cmu-cl then set this to where your source files are. -(setq cmulisp-local-source-directory - "/usr/local/utils/CMU-CL/") - - -;;; This makes reading a lisp file load in ilisp. -(set-default 'auto-mode-alist - (append '(("\\.lisp$" . lisp-mode)) auto-mode-alist)) -(setq lisp-mode-hook '(lambda () (require 'ilisp))) - -;;; Sample load hook -(add-hook 'ilisp-load-hook - '(lambda () - ;; Change default key prefix to C-c - (setq ilisp-prefix "\C-c") - - ;; Define LispMachine-like key bindings, too. - (ilisp-lispm-bindings) - - ;; Sample initialization hook. Set the inferior LISP directory to - ;; the directory of the buffer that spawned it on the first prompt. - (setq ilisp-init-hook - '(lambda () - (default-directory-lisp ilisp-last-buffer))))) -@c end of ilisp.emacs -@end example - -@c ================================================================== -@node Starting up, Buffers of ILISP, Installation, Top -@chapter How to run a Lisp process using ILISP -@cindex Running lisp -@cindex Starting up lisp -@cindex Supported dialects -@cindex Dialects supported -@pindex run-ilisp -@pindex clisp -@pindex allegro -@pindex lucid -@pindex cmulisp -@pindex kcl -@pindex akcl -@pindex ibcl -@pindex scheme -@pindex oaklisp - -To start a Lisp use @kbd{M-x run-ilisp}, or a specific dialect like -@kbd{M-x allegro}. If called with a prefix you will be prompted for a -buffer name and a program to run. The default buffer name is the name -of the dialect. The default program for a dialect will be the value of -DIALECT-program or the value of ilisp-program inherited from a less -specific dialect. If there are multiple LISP's, use the dialect name or -@kbd{M-x select-ilisp} (@kbd{@key{C-z} S}) to select the current ILISP -buffer. - -Entry into ILISP mode runs the hooks on @code{comint-mode-hook} and -@code{ilisp-mode-hook} and then DIALECT-hooks specific to LISP -dialects in the nesting order above. Many dialects call -@code{ilisp-load-init} in their dialect setup. - -These are the currently supported dialects. - -@itemize @bullet -@item allegro -Allegro Common Lisp from Franz Inc. - -@item lispworks -Harlequin Common Lisp from Harlequin Ltd. - -@item lucid -Lucid Common Lisp, currently supported by Harlequin Ltd. - -@item kcl -Kyoto Common Lisp, original version. - -@item akcl -Austin Kyoto Common Lisp, the U. Texas derivative. - -@item gcl -GNU Common Lisp, the official GNU release. A derivative of AKCL. - -@item ecl -EcoLisp, the Embeddable Common Lisp by Beppe Attardi. A derivative of -KCL and AKCL. - -@item ibcl -Ibuki Common Lisp, derived from KCL. - -@item cmucl -CMU Common Lisp, the major development platform for ILISP so far. - -@item clisp-hs -CLISP by Haible and Stoll. - -@item oaklisp -Oaklisp scheme. - -@end itemize - -The dialects -are listed so that the indentation correponds to the hierarchical -relationship between dialects. -@example - clisp - allegro - lucid - kcl - akcl - gcl - ecl - ibcl - cmulisp - clisp-hs - lispworks - scheme - oaklisp -@end example - -If anyone figures out support for other dialects I would be happy -to include it in future releases. @xref{Dialects}. - -To define a new dialect, @xref{Defining new dialects} and @xref{Customization}. - - -@node Buffers of ILISP, ILISP Commands, Starting up, Top -@chapter Buffers used by ILISP, and their commands -@cindex buffers of ILISP -@cindex ILISP buffers -@table @code - -@item *@var{dialect}* -The Lisp listener buffer. Forms can be entered in this buffer in, and -they will be sent to lisp when you hit return if the form is complete. -This buffer is in ilisp-mode, which is built on top of comint-mode, and -all comint commands such as history mechanism and job control are -available. -@c xref.. - -@item @var{lisp-mode-buffers} -A buffer is assumed to contain Lisp source code if its major mode is in -the list @code{lisp-source-modes}. If it's loaded into a buffer that is -in one of these major modes, it's considered a lisp source file by -@code{find-file-lisp}, @code{load-file-lisp} and -@code{compile-file-lisp}. -Used by these commands to determine defaults.@refill - -@item @code{*Completions*} -@cindex @code{*Completions*} buffer -Used for listing completions of symbols or files by the completion commands. -@xref{Completion}. - -@item *Aborted Commands* -@cindex @code{*Aborted Commands*} buffer -@xref{Interrupts}. - -@item *Errors* -@itemx *Output* -@itemx *Error Output* -@cindex @code{*Error Output*} buffer -@cindex @code{*Errors*} buffer -@cindex @code{*Output*} buffer -used to pop-up results and errors from the inferior LISP. - -@item *ilisp-send* -@cindex @code{*ilisp-send*} buffer -Buffer containing the last form sent to the inferior LISP. - -@item *Edit-Definitions* -@itemx *All-Callers* -@cindex @code{*Edit-Definitions*} buffer -@cindex @code{*All-Callers*} buffer -@xref{Source code commands}. - -@item *Last-Changes* -@itemx *Changed-Definitions* -@cindex @code{*Last-Changes*} buffer -@cindex @code{*Changed-Definitions*} buffer -@xref{Batch commands}. -@end table - -@menu -* Typeout windows:: temporary windows used for display. -* Switching buffers:: Switching buffers -@end menu - -@node Typeout windows, Switching buffers, , Buffers of ILISP -@section Typeout windows -@cindex Typeout windows - -All ILISP output is funneled through the function which is bound to -the hook @code{ilisp-display-output-function}. The function gets -a single argument, a string, and should make that output visible to -the user somehow. - -One possible choice for output display is -@code{ilisp-display-output-in-typeout-window}, -which pops up a window at the top of the current screen which is -just large enough to display the output. This window can be -"remote controlled" by the commands @code{ilisp-scroll-output}, -@code{ilisp-bury-output}, and @code{ilisp-grow-output}. - -Unlike the old popper facility, the ilisp typeout window facility -does not trounce on any existing Emacs functions or on any common -key bindings, like @kbd{C-x o}. - -Other built-in functions which might be useful as values for -@code{ilisp-display-output-function} include -@code{ilisp-display-output-default}, -@code{ilisp-display-output-adaptively}, -@code{ilisp-display-output-in-lisp-listener}, -@code{ilisp-display-output-in-temp-buffer}, and -@code{ilisp-display-output-in-typeout-window}. - -The default display function is @code{ilisp-display-output-default}, -which obeys the @code{lisp-no-popper} variable. - -Users are encouraged to write their own output display functions -to get the exact desired behavior, displaying on a private emacs -screen, in a pop-up dialog box, or whetever. - - -@table @kbd - -@item @key{C-z} 1 (ilisp-bury-output) -deletes and buries the typeout output window. -@kindex C-z 1 -@pindex ilisp-bury-output -@cindex bury output window - - -@item @key{C-z} v (ilisp-scroll-output) -scrolls the output window if it is showing, otherwise does nothing. -If it is called with a negative prefix, it will scroll backwards. -@cindex scrolling output -@pindex ilisp-scroll-output -@kindex C-z v - -@item @key{C-z} G (ilisp-grow-output) -will grow the output window if showing by the prefix number of lines. -@cindex grow output window -@pindex ilisp-grow-output -@kindex C-z G - -@end table - -An alternative to typeout windows is to always have the inferior LISP -buffer visible and have all output go there. Setting -@code{lisp-no-popper} to @code{t} will cause all output to go to the -inferior LISP buffer. Setting @code{lisp-no-popper} to @code{'message} -will make output of one line go to the message window. Setting -@code{comint-always-scroll} to @code{t} will cause process output to -always be visible. If a command gets an error, you will be left in the -break loop.@refill - -@cindex Turning off typeout windows -@vindex comint-always-scroll -@vindex lisp-no-popper - - - -@node Switching buffers, ,Typeout windows, Buffers of ILISP -@section Switching buffers - -Commands to make switching between buffers easier. -@cindex Switching buffers - -@table @kbd -@item @key{C-z} b (switch-to-lisp) -@kindex @key{C-z} b -@pindex switch-to-lisp -will pop to the current ILISP buffer or if already in an ILISP buffer, -it will return to the buffer that last switched to an ILISP buffer. -With a prefix, it will also go to the end of the buffer. If you do not -want it to pop, set @code{pop-up-windows} to nil. -@vindex pop-up-windows - - -@item M-C-l (previous-buffer-lisp) -will switch to the last visited buffer in the current window or the Nth -previous buffer with a prefix. -@cindex Previous lisp buffer -@pindex previous-buffer-lisp -@kindex M-C-l - -@end table - - -@node ILISP Commands, Customization, Buffers of ILISP, Top -@chapter ILISP Commands - - -Most of these key bindings work in both Lisp Mode and ILISP mode. -There are a few additional and-go bindings found in Lisp Mode. - - -@menu -* Eval and compile functions:: -* Documentation functions:: -* Macroexpansion:: -* Tracing functions:: -* Package Commands:: -* Source code commands:: Working on several files -* Batch commands:: Grouping changes for eval/compile -* Files and directories:: -* Keyboard modes:: Interactive and raw keyboard modes -* Interrupts:: Interrupts, aborts, and errors -* Command history:: -* Completion:: -* Miscellany:: Indentation, parenthesis balancing, - and comment commands. -@end menu - -@node Eval and compile functions, Documentation functions, , ILISP Commands -@section Eval and compile functions -@cindex Eval/compile commands -@cindex Compile/eval commands - -In LISP, the major unit of interest is a form, which is anything between -two matching parentheses. Some of the commands here also refer to -``defun,'' which is a list that starts at the left margin in a LISP -buffer, or after a prompt in the ILISP buffer. These commands refer to -the ``defun'' that contains the point. -@cindex Defun - -``A call'' refers to a reference to a function call for a function or -macro, or a reference to a variable. Commands which ``insert a call'' -in the ILISP buffer will bring up the last command which matches it or -else will insert a template for a call. -@cindex Call - -When an eval is done of a single form matching @code{ilisp-defvar-regexp} -the corresponding symbol will be unbound and the value assigned again. -@vindex ilisp-defvar-regexp - -When you send a form to LISP, the status light will reflect the -progress of the command. In a lisp mode buffer the light will reflect -the status of the currently selected inferior LISP unless -@code{lisp-show-status} is nil. If you want to find out what command is -currently running, use the command @kbd{@key{C-z} s} (status-lisp). -If you call it with a prefix, the pending commands will be displayed as -well.@refill -@cindex Currently running command -@cindex Displaying commands -@pindex status-lisp -@kindex @key{C-z} s -@vindex lisp-show-status -@cindex Status light -@cindex Modeline status - -Note that in this table as elsewhere, the key @key{C-z} (ilisp-prefix) -is used as a prefix character for ILISP commands, though this may be -changed. -@kindex @key{C-z} prefix -@vindex ilisp-prefix -@c xref .. custom? or autoload? -For a full list of key-bindings, use @kbd{M-x describe-mode} or -@kbd{M-x describe-bindings} while in an ILISP-mode buffer.@refill -@cindex Listing bindings -@cindex Describing bindings - - -The eval/compile commands verify that their expressions are balanced and -then send the form to the inferior LISP. If called with a positive -prefix, the result of the operation will be inserted into the buffer -after the form that was just sent. -@cindex Inserting results - -For commands which operate on a region, the result of the compile or eval -is the last form in the region. -@cindex Region commands - -The @samp{and-go} versions will perform the operation and then -immediately switch to the ILISP buffer where you will see the results of -executing your form. If @code{eval-defun-and-go-lisp} or -@code{compile-defun-and-go-lisp} is called with a prefix, a call for the -form will be inserted as well.@refill -@cindex Inserting calls -@pindex compile-defun-and-go-lisp -@pindex eval-defun-and-go-lisp -@cindex @samp{and-go} functions - -@table @kbd - -@item @key{C-z} -The prefix-key for most ILISP commands. This can be changed by setting -the variable @code{ilisp-prefix}. -@c xref custom? - -@item RET (return-ilisp) -In ILISP-mode buffer, sends the current form to lisp if complete, -otherwise creates a new line and indents. If you edit old input, the -input will be copied to the end of the buffer first and then sent. -@cindex Sending input to lisp -@pindex return-ilisp -@kindex RET - -@item C-] (close-and-send-lisp) -Closes the current sexp, indents it, and then sends it to the current -inferior LISP. -@pindex close-and-send-lisp -@kindex C-] - -@item LFD (newline-and-indent-lisp) -Insert a new line and then indent to the appropriate level. If called -at the end of the inferior LISP buffer and an sexp, the sexp will be -sent to the inferior LISP without a trailing newline. -@pindex newline-and-indent-lisp -@kindex LFD - -@item @key{C-z} e (eval-defun-lisp) -@itemx M-C-x (eval-defun-lisp) -@itemx @key{C-z} C-e (eval-defun-and-go-lisp) -@kindex M-C-x -@kindex @key{C-z} e -@kindex @key{C-z} C-e -Send the defun to lisp. -@pindex eval-defun-and-go-lisp -@pindex eval-defun-lisp - -@item @key{C-z} r (eval-region-lisp) -@itemx @key{C-z} C-r (eval-region-and-go-lisp) -@kindex @key{C-z} r -@pindex eval-region-lisp -@kindex @key{C-z} C-r -@pindex eval-region-and-go-lisp -@cindex Eval region - -@item @key{C-z} n (eval-next-sexp-lisp) -@itemx @key{C-z} C-n (eval-next-sexp-and-go-lisp) -@kindex @key{C-z} n -@pindex eval-next-sexp-lisp -@kindex @key{C-z} C-n -@pindex eval-next-sexp-and-go-lisp - -@item @key{C-z} c (compile-defun-lisp) -@kindex @key{C-z} c -@pindex compile-defun-lisp -@item @key{C-z} C-c (compile-defun-lisp-and-go) -@kindex @key{C-z} C-c -When @code{compile-defun-lisp} is called in an inferior LISP buffer with -no current form, the last form typed to the top-level will be compiled. -@cindex Compile last form -@pindex compile-defun-lisp-and-go - -@item @key{C-z} w (compile-region-lisp) -@itemx @key{C-z} C-w (compile-region-and-go-lisp) -@kindex @key{C-z} w -@pindex compile-region-lisp -@kindex @key{C-z} C-w -@pindex compile-region-and-go-lisp -@cindex Compile region - -@end table - - -If any of the forms contain an interactive command, then the command -will never return. To get out of this state, you need to use -@code{abort-commands-lisp} (@kbd{@key{C-z} g}). If @code{lisp-wait-p} -is t, then EMACS will display the result of the command in the -minibuffer or a pop-up window. If @code{lisp-wait-p} is @code{nil}, -(the default) the send is done asynchronously and the results will be -brought up only if there is more than one line or there is an error. In -this case, you will be given the option of ignoring the error, keeping -it in another buffer or keeping it and aborting all pending sends. If -there is not a command already running in the inferior LISP, you can -preserve the break loop. If called with a negative prefix, the sense of -@code{lisp-wait-p} will be inverted for the next command. -@c @cindex Aborting commands -@vindex lisp-wait-p -@kindex @key{C-z} g -@pindex abort-commands-lisp - - - -@node Documentation functions, Macroexpansion, Eval and compile functions, ILISP Commands -@section Documentation functions - -@code{describe-lisp}, @code{inspect-lisp}, @code{arglist-lisp}, and -@code{documentation-lisp} switch whether they prompt for a response or -use a default when called with a negative prefix. If they are -prompting, there is completion through the inferior LISP by using -@kbd{TAB} or @kbd{M-TAB}. When entering an expression in the -minibuffer, all of the normal ilisp commands like @code{arglist-lisp} -also work.@refill -@cindex Arglist lisp -@cindex Describing lisp objects -@kindex @key{M-TAB} -@kindex @key{TAB} -@cindex Negative prefix -@cindex Minibuffer completion -@pindex documentation-lisp -@pindex arglist-lisp -@pindex describe-lisp -@pindex inspect-lisp -@cindex Documentation Functions - -Commands that work on a function will use the nearest previous function -symbol. This is either a symbol after a @samp{#'} or the symbol at the -start of the current list. - -@table @code - -@item @key{C-z} a (arglist-lisp) -@kindex @key{C-z} a -Return the arglist of the current function. With a numeric prefix, the -leading paren will be removed and the arglist will be inserted into the -buffer. - -@item @key{C-z} d (documentation-lisp) -@kindex @key{C-z} d -Infers whether function or variable documentation is desired. With a -negative prefix, you can specify the type of documentation as well. -With a positive prefix the documentation of the current function call is -inserted into the buffer. - -@item @key{C-z} i (describe-lisp) -@kindex @key{C-z} i -Describe the previous sexp (it is evaluated). If there is no previous -sexp and if called from inside an ILISP buffer, the previous result will -be described. - -@item @key{C-z} i (describe-lisp) -@kindex @key{C-z} i -Describe the previous sexp (it is evaluated). If there is no previous -sexp and if called from inside an ILISP buffer, the previous result will -be described. - -@item @key{C-z} I (inspect-lisp) -@kindex @key{C-z} I -Switch to the current inferor LISP and inspect the previous sexp (it is -evaluated). If there is no previous sexp and if called from inside an -ILISP buffer, the previous result will be inspected. - -@item @key{C-z} D (fi:clman) -@itemx @key{C-z} A (fi:clman-apropos) -@kindex @key{C-z} D -@pindex fi:clman -@kindex @key{C-z} A -@pindex fi:clman-apropos -If the Franz online Common LISP manual is available, get information on -a specific symbol. @code{fi:clman-apropos} will get information apropos -a specific string. Some of the documentation is specific to the allegro -dialect, but most of it is for standard Common LISP. -@cindex Apropos help -@cindex Common Lisp manual -@cindex Franz manual - -@end table - - -@node Macroexpansion, Tracing functions, Documentation functions, ILISP Commands -@section Macroexpansion - -@table @kbd -@item @key{C-z} M (macroexpand-lisp) -@itemx @key{C-z} m (macroexpand-1-lisp) -@kindex @key{C-z} M -@pindex macroexpand-lisp -@kindex @key{C-z} m -@pindex macroexpand-1-lisp -These commands apply to the next sexp. If called with a positive -numeric prefix, the result of the macroexpansion will be inserted into -the buffer. With a negative prefix, prompts for expression to expand. -@cindex Expanding macro forms -@cindex Macroexpansion - - -@end table - -@node Tracing functions, Package Commands, Macroexpansion, ILISP Commands -@section Tracing functions - -@table @kbd -@item @key{C-z} t (trace-defun-lisp) -@kindex @key{C-z} t -@pindex trace-defun-lisp -@cindex Tracing defuns -@cindex Untracing defuns -traces the current defun. When called with a numeric prefix the -function will be untraced. When called with negative prefix, prompts -for function to be traced. -@end table - -@node Package Commands, Source code commands, Tracing functions, ILISP Commands -@section Package Commands -@cindex Package commands - -The first time an inferior LISP mode command is executed in a Lisp Mode -buffer, the package will be determined by using the regular expression -@code{ilisp-package-regexp} to find a package sexp and then passing that -sexp to the inferior LISP through @code{ilisp-package-command}. -For the @samp{clisp} dialect, this will find the first @code{(in-package -PACKAGE)} form in the file. -A buffer's package will be displayed in the mode line. -If a buffer has no -specification, forms will be evaluated in the current inferior LISP -package.@refill - -Buffer package caching can be turned off by setting the variable -@code{lisp-dont-cache-package} to @code{T}. This will force ILISP to -search for the closest previous @code{ilisp-package-regexp} in the -buffer each time an inferior LISP mode command is executed. -@cindex Buffer package -@cindex Buffer package caching -@vindex lisp-dont-cache-package -@vindex ilisp-package-regexp -@findex ilisp-package-command -@cindex In-package form - -@table @code - -@item @key{C-z} p (package-lisp) -@kindex @key{C-z} p -@pindex package-lisp -@cindex Show current package -Show the current package of the inferior LISP. - -@item @key{C-z} P (set-package-lisp) -@kindex @key{C-z} P -@pindex set-package-lisp -Set the inferior LISP package to the current buffer's package or with a -prefix to a manually entered package. - -@item M-x set-buffer-package-lisp -@kindex M-x set-buffer-package-lisp -@cindex Set buffer package -@pindex set-buffer-package-lisp -Set the buffer's package from the buffer. If it is called with a -prefix, the package can be set manually. - -@end table - -@node Source code commands, Batch commands, Package Commands, ILISP Commands -@section Source Code Commands -@cindex Source Code Commands -@cindex Finding source - -The following commands all deal with finding things in source code. -The first time that one of these commands is used, there may be some -delay while the source module is loaded. When searching files, the -first applicable rule is used: -@itemize @bullet -@item -try the inferior LISP, -@item -try a tags file if defined, -@item -try all buffers in one of @code{lisp-source-modes} or all files -defined using @code{lisp-directory}.@refill -@pindex lisp-directory -@vindex lisp-source-modes -@end itemize - -@code{M-x lisp-directory} defines a set of files to be -searched by the source code commands. It prompts for a directory and -sets the source files to be those in the directory that match entries -in @code{auto-mode-alist} for modes in @code{lisp-source-modes}. -With a positive -prefix, the files are appended. With a negative prefix, all current -buffers that are in one of @code{lisp-source-modes} will be searched. This -is also what happens by default. Using this command stops using a -tags file.@refill -@cindex Source modes -@vindex auto-mode-alist -@kindex M-x lisp-directory - -@code{edit-definitions-lisp}, @code{who-calls-lisp}, and -@code{edit-callers-lisp} will switch whether they prompt for a response -or use a default when called with a negative prefix. If they are -prompting, there is completion through the inferior LISP by using -@kbd{TAB} or @kbd{M-TAB}. When entering an expression in the -minibuffer, all of the normal ILISP commands like @kbd{arglist-lisp} -also work.@refill -@pindex edit-callers-lisp -@pindex who-calls-lisp -@pindex edit-definitions-lisp - -@code{edit-definitions-lisp} (@kbd{M-.}) will find a -particular type of definition for a symbol. It tries to use the rules -described above. The files to be searched are listed in the buffer -@code{*Edit-Definitions*}. If @code{lisp-edit-files} is nil, no search will be -done if not found through the inferior LISP. The variable -@code{ilisp-locator} contains a function that when given the name and type -should be able to find the appropriate definition in the file. There -is often a flag to cause your LISP to record source files that you -will need to set in the initialization file for your LISP. The -variable is @code{*record-source-files*} in both allegro and lucid. Once a -definition has been found, @code{next-definition-lisp} -(@kbd{M-,}) will find the next definition -(or the previous definition with a prefix).@refill -@pindex next-definition-lisp -@vindex *record-source-files* -@vindex ilisp-locator -@vindex lisp-edit-files -@cindex @code{*Edit-Definitions*} buffer -@kindex M-. - -@code{edit-callers-lisp} (@kbd{@key{C-z} ^}) will generate a list of all -of the callers of a function in the current inferior LISP and edit the -first caller using @code{edit-definitions-lisp}. Each successive call to -@code{next-caller-lisp} (@kbd{M-`}) will edit the next caller -(or the previous caller with a prefix). The list is stored in the -buffer @code{*All-Callers*}. You can also look at the callers by doing -@kbd{M-x who-calls-lisp}.@refill -@cindex List callers -@cindex Find callers -@cindex @code{*All-Callers*} buffer -@kindex M-x who-calls-lisp -@kindex M-` -@pindex next-caller-lisp -@kindex @key{C-z} ^ -@pindex edit-callers-lisp - -@code{search-lisp} (@kbd{M-?}) will search the current tags files, -@code{lisp-directory} files or buffers in one of @code{lisp-source-modes} for a -string or a regular expression when called with a prefix. -@code{next-definition-lisp} (@kbd{M-,}) will find the next definition -(or the previous definition with a prefix).@refill -@cindex Next definition -@cindex Previous definition -@kindex M-, -@pindex next-definition-lisp -@kindex M-? -@pindex search-lisp - -@code{replace-lisp} (@kbd{M-"}) will replace a string (or a regexp with -a prefix) in the current tags files, @code{lisp-directory} files or -buffers in one of @code{lisp-source-modes}.@refill -@cindex Replace lisp -@kindex M-" -@pindex replace-lisp - - -Here is a summary of the above commands (behavior when given prefix -argument is given in parentheses): - -@table @code -@item M-x lisp-directory -Define a set of files to be used by the source code commands. - -@item M-. (edit-definitions-lisp) -Find definition of a symbol. - -@item M-, (next-definition-lisp) -Find next (previous) definition. - -@item @key{C-z} ^ (edit-callers-lisp) -Find all callers of a function, and edit the first. - -@item M-` (next-caller-lisp) -Edit next (previous) caller of function set by @code{edit-callers-lisp}. - -@item M-x who-calls-lisp -List all the callers of a function. - - -@item M-? (search-lisp) -Search for string (regular expression) in current tags, -@code{lisp-directory} files or buffers. Use @code{next-definition-lisp} -to find next occurence. - -@item M-" (replace-lisp) -Replace a string (regular expression) in files. - -@end table - - -@node Batch commands, Files and directories, Source code commands, ILISP Commands -@section Batch commands - - -The following commands all deal with making a number of changes all at -once. The first time one of these commands is used, there may be some -delay as the module is loaded. The eval/compile versions of these -commands are always executed asynchronously. -@cindex Group changes -@cindex File changes -@cindex Change commands - -@code{mark-change-lisp} (@kbd{@key{C-z} SPC}) marks the current defun as -being changed. A prefix causes it to be unmarked. @code{clear-changes-lisp} -(@kbd{@key{C-z} * 0}) will clear all of the changes. -@code{list-changes-lisp} (@kbd{@key{C-z} * l}) will show the forms -currently marked.@refill -@cindex Marking changes -@cindex Clearing changes -@cindex Listing changes -@kindex @key{C-z} * l -@kindex @key{C-z} * 0 -@kindex @key{C-z} SPC -@pindex list-changes-lisp -@pindex clear-changes-lisp -@pindex mark-change-lisp - -@code{eval-changes-lisp} (@kbd{@key{C-z} * e}), or -@code{compile-changes-lisp} (@kbd{@key{C-z} * c}) will -evaluate or compile these changes as appropriate. -If called with a positive prefix, the changes will be kept. -If there is an error, the process will stop and show the error -and all remaining changes will remain in the list. All of the results -will be kept in the buffer @code{*Last-Changes*}.@refill -@cindex Eval'ing changes -@cindex Compiling changes -@cindex @code{*Last-Changes*} buffer -@kindex @key{C-z} * e -@kindex @key{C-z} * c -@pindex compile-changes-lisp -@pindex eval-changes-lisp - -@noindent -Summary: - -@table @code -@item @key{C-z} SPC (mark-change-lisp) -Mark (unmark) current defun as changed. -@item @key{C-z} * e (eval-changes-lisp) -@itemx @key{C-z} * c (compile-changes-lisp) -Call with a positive prefix to keep changes. -@item @key{C-z} * 0 (clear-changes-lisp) -@item @key{C-z} * l (list-changes-lisp) -@end table - - -@node Files and directories, Keyboard modes, Batch commands, ILISP Commands -@section Files and directories - -@cindex Files and directories -@cindex Directories and files -@cindex Current directory -File commands in lisp-source-mode buffers keep track of the last used -directory and file. If the point is on a string, that will be the -default if the file exists. If the buffer is one of -@code{lisp-source-modes}, the buffer file will be the default. Otherwise, -the last file used in a lisp-source-mode will be used. - - -@table @kbd -@item C-x C-f (find-file-lisp) -@kindex C-x C-f -@cindex Find file -@cindex Lisp find file -@cindex Symbolic link expansion -@pindex find-file-lisp -will find a file. If it is in a string, that will be used as the -default if it matches an existing file. Symbolic links are expanded so -that different references to the same file will end up with the same -buffer. - -@item @key{C-z} l (load-file-lisp) -@kindex @key{C-z} l -will load a file into the inferior LISP. You will be given the -opportunity to save the buffer if it has changed and to compile the file -if the compiled version is older than the current version. -@pindex load-file-lisp -@cindex Loading files - -@item @key{C-z} k (compile-file-lisp) -@kindex @key{C-z} k -will compile a file in the current inferior LISP. -@pindex compile-file-lisp -@cindex Compiling files - -@item @key{C-z} ! (default-directory-lisp) -@kindex @key{C-z} ! -sets the default inferior LISP directory to the directory of the current -buffer. If called in an inferior LISP buffer, it sets the Emacs -@code{default-directory} to the LISP default directory. -@vindex default-directory -@cindex Default directory -@cindex Set default directory -@pindex default-directory-lisp - -@end table - -@node Keyboard modes, Interrupts, Files and directories, ILISP Commands -@section Switching between interactive and raw keyboard modes - -@cindex Raw keyboard mode -@cindex Interactive keyboard mode -@vindex ilisp-raw-echo - -There are two keyboard modes for interacting with the inferior LISP, -\"interactive\" and \"raw\". Normally you are in interactive mode -where keys are interpreted as commands to EMACS and nothing is sent to -the inferior LISP unless a specific command does so. In raw mode, all -characters are passed directly to the inferior LISP without any -interpretation as EMACS commands. Keys will not be echoed unless -ilisp-raw-echo is T. - -@pindex raw-keys-ilisp -@kindex @key{C-z} # -@pindex io-bridge-ilisp -@kindex M-x io-bridge-ilisp - -Raw mode can be turned on interactively by the command -@code{raw-keys-ilisp} (@kbd{@key{C-z} #}) and will continue until you -type @key{C-g}. Raw mode can also be turned on/off by inferior LISP -functions if the command @code{io-bridge-ilisp} (M-x io-bridge-ilisp) -has been executed in the inferior LISP either interactively or on a -hook. To turn on raw mode, a function should print ^[1^] and to turn -it off should print ^[0^]. An example in Common LISP would be: - -@code{(progn (format t "1 ") (print (read-char)) (format t "0 "))} - -@node Interrupts, Command history, Keyboard modes, ILISP Commands -@section Interrupts, aborts, and errors - - -If you want to abort the last command you can use @kbd{C-g}. -@kindex C-g -@cindex Errors -@cindex Aborting commands -@cindex Interrupting commands - -If you want to abort all commands, you should use the command -@code{abort-commands-lisp} (@kbd{@key{C-z} g}). Commands that are -aborted will be put in the buffer @code{*Aborted Commands*} so that -you can see what was aborted. If you want to abort the currently -running top-level command, use @code{interrupt-subjob-ilisp} (@kbd{C-c -C-c}). As a last resort, @kbd{M-x panic-lisp} will reset the ILISP -state without affecting the inferior LISP so that you can see what is -happening. - -@pindex interrupt-subjob-ilisp -@cindex @code{*Aborted Commands*} buffer -@kindex @key{C-z} g -@pindex abort-commands-lisp -@pindex panic-lisp - -@code{delete-char-or-pop-ilisp} (@kbd{C-d}) will delete -prefix characters unless you are at the end of an ILISP buffer in -which case it will pop one level in the break loop. -@cindex Pop in break loop -@cindex Break loop -@kindex C-d -@pindex delete-char-or-pop-ilisp - -@code{reset-ilisp}, (@kbd{@key{C-z} z}) will reset the current inferior -LISP's top-level so that it will no longer be in a break loop. -@cindex Resetting lisp -@cindex Top-level, return to -@kindex @key{C-z} z -@pindex reset-ilisp - - -Summary: - -@table @kbd -@item C-c C-c (interrupt-subjob-ilisp) -Send a keyboard interrupt signal to lisp. -@item @key{C-z} g (abort-commands-lisp) -Abort all running or unsent commands. -@item M-x panic-lisp (panic-lisp) -Reset the ILISP process state. -@item @key{C-z} z (reset-ilisp) -Reset lisp to top-level. -@item C-d (delete-char-or-pop-ilisp) -If at end of buffer, pop a level in break loop. - -@end table - -@c duplicated from eval section. -If @code{lisp-wait-p} is @code{nil} (the default), -all sends are done asynchronously and the results will be -brought up only if there is more than one line or there is an error. -In case, you will be given the option of ignoring the error, keeping -it in another buffer or keeping it and aborting all pending sends. -If there is not a command already running in the inferior LISP, you can -preserve the break loop. If called with a negative prefix, the sense of -@code{lisp-wait-p} will be inverted for the next command. -@vindex lisp-wait-p - - - -@node Command history, Completion, Interrupts, ILISP Commands -@section Command history -@cindex Command history -@cindex Last command -@cindex Previous commands - -ILISP mode is built on top of @code{comint-mode}, the general -command-interpreter-in-a-buffer mode. As such, it inherits many -commands and features from this, including a command history mechanism. -@cindex @code{comint-mode} - -Each ILISP buffer has a command history associated with it. Commands -that do not match @code{ilisp-filter-regexp} and that are longer than -@code{ilisp-filter-length} and that do not match the immediately prior -command will be added to this history. -@vindex ilisp-filter-length -@vindex ilisp-filter-regexp - -@table @kbd - -@item M-n (comint-next-input) -@itemx M-p (comint-previous-input) -@kindex M-n -@pindex comint-next-input -@cindex Next input -@kindex M-p -@pindex comint-previous-input -Cycle through the input history. - -@item M-s (comint-previous-similar-input) -@kindex M-s -@pindex comint-previous-similar-input -@cindex Similar input -Cycle through input that has the string typed so far as a prefix. - -@item M-N (comint-psearch-input) -@kindex M-N -@pindex comint-psearch-input -@cindex Search input -@cindex Input search -Search forwards for prompt. -@item M-P (comint-msearch-input) -@kindex M-P -@pindex comint-msearch-input -Search backwards for prompt. - -@item C-c R (comint-msearch-input-matching) -@kindex C-c R -@pindex comint-msearch-input-matching -Search backwards for occurrence of prompt followed by string which is prompted -for (@emph{not} a regular expression). -@end table - -See @code{comint-mode} documentation for more information on -@samp{comint} commands. - - -@node Completion, Miscellany, Command history, ILISP Commands -@section Completion - -Commands to reduce number of keystrokes. -@cindex Completion -@cindex Partial completion -@cindex Filename completion - -@table @kbd -@item M-TAB (complete-lisp) -@kindex M-TAB -@pindex complete-lisp -@vindex ilisp-prefix-match -will try to complete the previous symbol in the current inferior LISP. -Partial completion is supported unless @code{ilisp-prefix-match} is set to @code{t}. -(If you set it to @code{t}, inferior LISP completions will be faster.) -With partial completion, @samp{p--n} would complete to -@samp{position-if-not} in Common LISP. -If the symbol follows a left paren or a @samp{#'}, only symbols with -function cells will be considered. -If the symbol starts with a @samp{*} or you call with a -positive prefix all possible completions will be considered. -Only external symbols are considered if there is a package qualification -with only one colon. -The first time you try to complete a string the longest common substring -will be inserted and the cursor will be left -on the point of ambiguity. -If you try to complete again, you can see the possible completions. -If you are in a string, then filename completion will be done instead. -And if you try to complete a filename twice, you will see a list of -possible completions. -Filename components are completed individually, so @samp{/u/mi/} could -expand to @samp{/usr/misc/}. -If you complete with a negative -prefix, the most recent completion (symbol or filename) will be undone.@refill - - -@item M-RET (complete) -@kindex M-RET -@pindex complete -@cindex TMC completion -will complete the current symbol to the most recently seen symbol in -Emacs that matches what you have typed so far. Executing it repeatedly -will cycle through potential matches. This is from the TMC completion -package and there may be some delay as it is initially loaded. - -@end table - -@node Miscellany, , Completion, ILISP Commands -@section Miscellany - -Indentation, parenthesis balancing, and comment commands. - -@table @kbd - -@item @kbd{TAB} (indent-line-ilisp) -@kindex @kbd{TAB} -indents for LISP. With prefix, shifts rest of expression rigidly with -the current line. -@pindex indent-line-ilisp -@cindex Indentation -@cindex Rigid indentation - - -@item M-C-q (indent-sexp-ilisp) -@kindex M-C-q -will indent each line in the next sexp. -@pindex indent-sexp-ilisp - -@item M-q (reindent-lisp) -@kindex M-q -will reindent the current paragraph if in a comment or string. -Otherwise it will close the containing defun and reindent it. -@pindex reindent-lisp -@cindex Reindent lisp - -@item @key{C-z} ; (comment-region-lisp) -@kindex @key{C-z} ; -will put prefix copies of @code{comment-start} before and -@code{comment-end}'s after the lines in region. To uncomment a region, -use a minus prefix.@refill -@pindex comment-region-lisp -@cindex Comment region -@cindex Uncomment region - -@item @key{C-z} ) (find-unbalanced-lisp) -@kindex @key{C-z} ) -will find unbalanced parens in the current buffer. When called with a -prefix it will look in the current region. -@pindex find-unbalanced-lisp -@cindex Find unbalanced parens -@cindex Parenthesis balancing - -@item ] (close-all-lisp) -@kindex ] -will close all outstanding parens back to the containing form, or a -previous left bracket which will be converted to a left parens. If -there are too many parens, they will be deleted unless there is text -between the last paren and the end of the defun. If called with a -prefix, all open left brackets will be closed. -@pindex close-all-lisp -@cindex Close all parens -@cindex Close brackets - -@end table - - -@node Customization, Dialects, ILISP Commands, Top -@chapter ILISP Customization - -@c = = = = = = = = = = = = = = = = = = = = = = = = -@c this refers to hierarchiy, which isn't shown here. -@cindex Customization -@cindex Hooks -@cindex Dialect startup - - -Starting a dialect runs the hooks on @code{comint-mode-hook} -and @code{ilisp-mode-hook} and then @var{DIALECT}@code{-hooks} specific -to dialects in the nesting order below. -@vindex ilisp-mode-hook -@vindex comint-mode-hook -@example - clisp - allegro - lucid - kcl - akcl - ibcl - cmulisp - scheme - oaklisp -@end example - -On the very first prompt in the inferior LISP, -the hooks on @code{ilisp-init-hook} are run. For more information on -creating a new dialect or variables to set in hooks, see @file{ilisp.el}. -@cindex First prompt -@vindex ilisp-init-hook - - - -@c -> -> -> -> -> -> -> -> -> -> -> plenty of indexing here -@c put these in a table for later expandment -@c - -ILISP Mode Hooks: -@cindex ILISP Mode Hooks -@table @code -@item ilisp-site-hook -@vindex ilisp-site-hook -Executed when file is loaded -@item ilisp-load-hook -@vindex ilisp-load-hook -Executed when file is loaded -@item ilisp-mode-hook -@vindex ilisp-mode-hook -Executed when an ilisp buffer is created -@item ilisp-init-hook -@vindex ilisp-init-hook -Executed after inferior LISP is initialized and the first prompt is -seen. -@item @var{DIALECT}-hook -@vindex @var{DIALECT}-hook -Executed when dialect is set -@end table - -Variables you might want to set in a hook or dialect: -@table @code -@item ilisp-prefix -@vindex ilisp-prefix -Keys to prefix ilisp key bindings -@item ilisp-program -@vindex ilisp-program -Program to start for inferior LISP -@item ilisp-motd -@vindex ilisp-motd -String printed on startup with version -@item lisp-wait-p -@vindex lisp-wait-p -Set to T for synchronous sends -@item ilisp-handle-errors -@vindex ilisp-handle-errors -Set to T for ilisp to handle errors from the underlying lisp. -@item ilisp-display-output-function -@vindex ilisp-display-output-function -The name of a function which displays ILISP output. -@item lisp-no-popper -@vindex lisp-no-popper -Set to T to have all output in inferior LISP -@item lisp-show-status -@vindex lisp-show-status -Set to nil to stop showing process status -@item ilisp-prefix-match -@vindex ilisp-prefix-match -Set to T if you do not want partial completion -@item ilisp-filter-regexp -@vindex ilisp-filter-regexp -Input history filter -@item ilisp-filter-length -@vindex ilisp-filter-length -Input history minimum length -@item ilisp-other-prompt -@vindex ilisp-other-prompt -Prompt for non- top-level read-eval print loops -@end table - -@node Dialects, Concept index, Customization, Top -@chapter Dialects -@cindex Dialects - -A @dfn{dialect} of lisp is a specific implementation. For the parts of -Common Lisp which are well specified, they are usually the same. For -the parts that are not (debugger, top-level loop, etc.), there is -usually the same functionality but different commands. - -ILISP provides the means to specify these differences so that the ILISP -commands will use the specific command peculiar to an implementation, -but still offer the same behavior with the same interface. - - -@menu -* Defining new dialects:: -* Writing new commands:: -@end menu - -@node Defining new dialects, Writing new commands, , Dialects -@section Defining new dialects - - -To define a new dialect use the macro @code{defdialect}. For examples, -look at the dialect definitions in @file{ilisp-acl.el}, -@file{ilisp-cmu.el}, @file{ilisp-kcl.el}, @file{ilisp-luc}. There are -hooks and variables for almost anything that you are likely to need to -change. The relationship between dialects is hierarchical with the root -values being defined in @code{setup-ilisp}. For a new dialect, you only -need to change the variables that are different than in the parent -dialect. -@cindex Defining new dialects -@pindex setup-ilisp -@pindex defdialect - - -@node Writing new commands, , Defining new dialects, Dialects -@section Writing new commands -@cindex Internal ILISP functions - -Basic tools for creating new commands: -@table @code -@item deflocal -@findex deflocal -Define a new buffer local variable. -@item ilisp-dialect -@findex ilisp-dialect -List of dialect types. For specific dialect clauses. -@item lisp-symbol -@findex lisp-symbol -Create a symbol. -@item lisp-symbol-name -@findex lisp-symbol-name -Return a symbol's name -@item lisp-symbol-delimiter -@findex lisp-symbol-delimiter -Return a symbol's qualification -@item lisp-symbol-package -@findex lisp-symbol-package -Return a symbol's package -@item lisp-string-to-symbol -@findex lisp-string-to-symbol -Convert string to symbol -@item lisp-symbol-to-string -@findex lisp-symbol-to-string -Convert symbol to string -@item lisp-buffer-symbol -@findex lisp-buffer-symbol -Convert symbol to string qualified for buffer -@item lisp-previous-symbol -@findex lisp-previous-symbol -Return previous symbol -@item lisp-previous-sexp -@findex lisp-previous-sexp -Return previous sexp -@item lisp-def-name -@findex lisp-def-name -Return name of current definition -@item lisp-function-name -@findex lisp-function-name -Return previous function symbol -@item ilisp-read -@findex ilisp-read -Read an sexp with completion, arglist, etc -@item ilisp-read-symbol -@findex ilisp-read-symbol -Read a symbol or list with completion -@item ilisp-completing-read -@findex ilisp-completing-read -Read from choices or list with completion -@end table - -@noindent -Notes: -@itemize @bullet -@item -Special commands like arglist should use @code{ilisp-send} to send a -message to the inferior LISP. -@findex ilisp-send - -@item -Eval/compile commands should use @code{eval-region-lisp} or -@code{compile-region-lisp}. -@findex compile-region-lisp -@findex eval-region-lisp - -@end itemize - -@node Concept index, Key index, Dialects, Top -@unnumbered Concept Index -@printindex cp - -@node Key index, Command index, Concept index, Top -@unnumbered Key Index -@printindex ky - -@node Command index, Variable index, Key index, Top -@unnumbered Command Index - -@noindent -Commands available via @kbd{M-x} prefix. - -@printindex pg - -@node Variable index, Function index, Command index, Top -@unnumbered Variable Index - -@noindent -Variables and hooks of ILISP. - -@printindex vr - -@node Function index, , Variable index, Top -@unnumbered Function Index - -@noindent -Internal functions of ILISP which can be used to write new commands. - -@printindex fn - -@contents - -@bye - - -Should this stuff go anywhere?? - -misc ILISP - bol-ilisp (C-a) will go after the prompt as defined by - comint-prompt-regexp or ilisp-other-prompt or to the left margin with - a prefix. - -misc - backward-delete-char-untabify (DEL) - converts tabs to spaces as it moves back. - - -about cmds - The very first inferior LISP command executed may send some forms to - initialize the inferior LISP. - - Each time an inferior LISP command is executed, the last form sent can be - seen in the *ilisp-send* buffer. - - -@comment Local variables: -@comment version-control: t -@comment End:
--- a/man/internals/internals.texi Mon Aug 13 10:03:54 2007 +0200 +++ b/man/internals/internals.texi Mon Aug 13 10:04:58 2007 +0200 @@ -498,6 +498,8 @@ version 20.1 (not released to the net) April 15, 1997. @item version 20.2 released May 16, 1997. +@item +version 19.16 released October 31, 1997. @end itemize @node GNU Emacs 19
--- a/man/pcl-cvs.texi Mon Aug 13 10:03:54 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1565 +0,0 @@ -\input texinfo @c -*-texinfo-*- - -@comment OrigId: pcl-cvs.texinfo,v 1.45 1993/05/31 22:38:15 ceder Exp -@comment @@(#)cvs/contrib/pcl-cvs:$Name: r20-0b30 $:$Id: pcl-cvs.texi,v 1.1.1.1 1996/12/18 22:43:46 steve Exp $ - -@comment Documentation for the GNU Emacs CVS mode. -@comment Copyright (C) 1992 Per Cederqvist - -@comment This file is part of the pcl-cvs distribution. - -@comment Pcl-cvs is free software; you can redistribute it and/or modify -@comment it under the terms of the GNU General Public License as published by -@comment the Free Software Foundation; either version 1, or (at your option) -@comment any later version. - -@comment Pcl-cvs is distributed in the hope that it will be useful, -@comment but WITHOUT ANY WARRANTY; without even the implied warranty of -@comment MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -@comment GNU General Public License for more details. - -@comment You should have received a copy of the GNU General Public License -@comment along with pcl-cvs; see the file COPYING. If not, write to -@comment the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -@setfilename ../info/pcl-cvs.info -@settitle Pcl-cvs - The Emacs Front-End to CVS -@setchapternewpage on - -@ifinfo -Copyright @copyright{} 1992 Per Cederqvist - -Permission is granted to make and distribute verbatim copies of -this manual provided the copyright notice and this permission notice -are preserved on all copies. - -@ignore -Permission is granted to process this file through Tex and print the -results, provided the printed document carries copying permission -notice identical to this one except for the removal of this paragraph -(this paragraph not being relevant to the printed manual). - -@end ignore -Permission is granted to copy and distribute modified versions of this -manual under the conditions for verbatim copying, provided also that the -section entitled ``GNU General Public License'' is included exactly as -in the original, and provided that the entire resulting derived work is -distributed under the terms of a permission notice identical to this one. - -Permission is granted to copy and distribute translations of this manual -into another language, under the above conditions for modified versions, -except that the section entitled ``GNU General Public License'' and -this permission notice may be included in translations approved by the -Free Software Foundation instead of in the original English. -@end ifinfo - -@synindex vr fn -@comment The titlepage section does not appear in the Info file. -@titlepage -@sp 4 -@comment The title is printed in a large font. -@center @titlefont{User's Guide} -@sp -@center @titlefont{to} -@sp -@center @titlefont{pcl-cvs - the Emacs Front-End to CVS} -@sp 2 -@center release 1.05-CVS-1.7 -@comment -release- -@sp 3 -@center Per Cederqvist -@sp 3 -@center last updated 20 Nov 1995 -@comment -date- - -@comment The following two commands start the copyright page -@comment for the printed manual. This will not appear in the Info file. -@page -@vskip 0pt plus 1filll -Copyright @copyright{} 1992 Per Cederqvist - -Permission is granted to make and distribute verbatim copies of -this manual provided the copyright notice and this permission notice -are preserved on all copies. - -Permission is granted to copy and distribute modified versions of this -manual under the conditions for verbatim copying, provided also that the -section entitled ``GNU General Public License'' is included exactly as -in the original, and provided that the entire resulting derived work is -distributed under the terms of a permission notice identical to this one. - -Permission is granted to copy and distribute translations of this manual -into another language, under the above conditions for modified versions, -except that the section entitled ``GNU General Public License'' and -this permission notice may be included in translations approved by the -Free Software Foundation instead of in the original English. -@end titlepage - -@comment ================================================================ -@comment The real text starts here -@comment ================================================================ - -@node Top, Installation, (dir), (dir) -@comment node-name, next, previous, up - - -@ifinfo -This info manual describes pcl-cvs which is a GNU Emacs front-end to -CVS. It works with CVS versions 1.5 through 1.7 and newer, and possibly -CVS-1.3 and CVS-1.4A2. This manual is updated to release -1.05-CVS-1.7 of pcl-cvs. -@end ifinfo -@comment -release- - -@menu -* Installation:: How to install pcl-cvs on your system. -* About pcl-cvs:: Authors and ftp sites. - -* Getting started:: An introduction with a walk-through example. -* Buffer contents:: An explanation of the buffer contents. -* Commands:: All commands, grouped by type. - -* Customization:: How you can tailor pcl-cvs to suit your needs. -* Future enhancements:: Future enhancements of pcl-cvs. -* Bugs:: Bugs (known and unknown). -* COPYING:: GNU General Public License -* Function and Variable Index:: List of functions and variables. -* Concept Index:: List of concepts. -* Key Index:: List of keystrokes. - - --- The Detailed Node Listing --- - -Installation - -* Pcl-cvs installation:: How to install pcl-cvs on your system. -* On-line manual installation:: How to install the on-line manual. -* Typeset manual installation:: How to create typeset documentation - about pcl-cvs. - -About pcl-cvs - -* Contributors:: Contributors to pcl-cvs. -* Archives:: Where can I get a copy of Pcl-Cvs? - -Buffer contents - -* File status:: The meaning of the second field. -* Selected files:: How selection works. - -Commands - -* Updating the directory:: Commands to update the local directory -* Movement commands:: How to move up and down in the buffer -* Marking files:: How to mark files that other commands - will later operate on. -* Committing changes:: Checking in your modifications to the - CVS repository. -* Editing files:: Loading files into Emacs. -* Getting info about files:: Display the log and status of files. -* Adding and removing files:: Adding and removing files -* Undoing changes:: Undoing changes -* Removing handled entries:: Uninteresting lines can easily be removed. -* Ignoring files:: Telling CVS to ignore generated files. -* Viewing differences:: Commands to @samp{diff} different versions. -* Invoking Ediff:: Running @samp{ediff} from @samp{*cvs*} buffer. -* Invoking Emerge:: Running @samp{emerge} from @samp{*cvs*} buffer. -* Reverting your buffers:: Reverting your buffers -* Miscellaneous commands:: Miscellaneous commands -@end menu - - -@node Installation, About pcl-cvs, Top, Top -@comment node-name, next, previous, up - -@chapter Installation -@cindex Installation - -This section describes the installation of pcl-cvs, the GNU Emacs CVS -front-end. You should install not only the elisp files themselves, but -also the on-line documentation so that your users will know how to use -it. You can create typeset documentation from the file -@file{pcl-cvs.texinfo} as well as an on-line info file. The following -steps are also described in the file @file{INSTALL} in the source -directory. - -@menu -* Pcl-cvs installation:: How to install pcl-cvs on your system. -* On-line manual installation:: How to install the on-line manual. -* Typeset manual installation:: How to create typeset documentation - about pcl-cvs. -@end menu - - -@node Pcl-cvs installation, On-line manual installation, Installation, Installation -@comment node-name, next, previous, up -@section Installation of the pcl-cvs program -@cindex Installation of elisp files - -@enumerate -@item -Possibly edit the file @file{Makefile} to reflect the situation at your -site. We say "possibly" because the version of pcl-cvs included with -CVS uses a configuration mechanism integrated with the overall -mechanisms used by the CVS build and install procedures. Thus the file -@code{Makefile} will be generated automatically from the file -@code{Makefile.in}, and it should not be necessary to edit it further. - -If you do have to edit the @file{Makefile}, the only things you have to -change is the definition of @code{lispdir} and @code{infodir}. The -elisp files will be copied to @code{lispdir}, and the info file(s) to -@code{infodir}. - -@item -Configure pcl-cvs.el - -There are a couple of pathnames that you have to check to make sure that -they match your system. They appear early in the file -@samp{pcl-cvs.el}. - -@strong{NOTE:} If your system is running emacs 18.57 or earlier you MUST -uncomment the line that says: -@example -(setq delete-exited-processes nil) -@end example - -Setting @code{delete-exited-processes} to @code{nil} works around a bug -in emacs that causes it to dump core. The bug was fixed in emacs -18.58.@refill - -@item -Release 1.05 and later of pcl-cvs requires parts of the Elib library, -version 1.0 or later. Elib is available via anonymous ftp from -prep.ai.mit.edu in @file{pub/gnu/elib-1.0.tar.gz}, and from a lot of -other sites that mirror prep. Get Elib, and install it, before -proceeding. - -@strong{NOTE:} The version of pcl-cvs included with CVS includes a copy -of Elib in the sub-directory @file{elib} under the -@file{contrib/pcl-cvs} directory. - -@item -Type @samp{make install} in the source directory. This will -byte-compile all @file{.el} files and copy the @file{*.elc} files into -the directory you specified in step 1. - -If you want to install the @file{*.el} files too, you can type -@samp{make install-el} to do so. - -If you only want to create the compiled elisp files, but don't want to -install them, you can type @samp{make} without parameters. - -@item -Edit the file @file{default.el} in your emacs lisp directory (usually -@file{/usr/gnu/lib/emacs/site-lisp} or something similar) and enter the -contents of the file @file{pcl-cvs-startup.el} into it. It contains a -couple of @code{auto-load}s that facilitates the use of pcl-cvs. - -@end enumerate - - -@node On-line manual installation, Typeset manual installation, Pcl-cvs installation, Installation -@comment node-name, next, previous, up - -@section Installation of the on-line manual. -@cindex Manual installation (on-line) -@cindex Installation of on-line manual -@cindex Generating the on-line manual -@cindex On-line manual (how to generate) -@cindex Info-file (how to generate) - -@enumerate -@item -Create the info file(s) @file{pcl-cvs.info*} from @file{pcl-cvs.texinfo} -by typing @samp{make info}. If you don't have the program -@samp{makeinfo} you can get it by anonymous ftp from -e.g. @samp{prep.ai.mit.edu} as @file{pub/gnu/texinfo-3.7.tar.gz} (there -might be a newer version there when you read this).@refill - -@item -Install the info file(s) @file{pcl-cvs.info*} into your standard -@file{info} directory. You should be able to do this by typing -@samp{make install-info}.@refill - -@item -Edit the file @file{dir} in the @file{info} directory and enter one line -to contain a pointer to the info file(s) @file{pcl-cvs.info*}. The line -can, for instance, look like this:@refill - -@example -* Pcl-cvs: (pcl-cvs). An Emacs front-end to CVS. -@end example -@end enumerate - - -@node Typeset manual installation, , On-line manual installation, Installation -@comment node-name, next, previous, up - -@section How to make typeset documentation from pcl-cvs.texinfo -@cindex Manual installation (typeset) -@cindex Installation of typeset manual -@cindex Printing a manual -@cindex TeX - generating a typeset manual -@cindex Generating a typeset manual - -If you have @TeX{} installed at your site, you can make a typeset manual -from @file{pcl-cvs.texinfo}. - -@enumerate -@item -Run @TeX{} by typing `@samp{make pcl-cvs.dvi}'. You will not get the -indices unless you have the @code{texindex} program. - -@item -Convert the resulting device independent file @file{pcl-cvs.dvi} to a -form which your printer can output and print it. If you have a -postscript printer there is a program, @code{dvi2ps}, which does. There -is also a program which comes together with @TeX{}, @code{dvips}, which -you can use. - -@end enumerate - - -@node About pcl-cvs, Getting started, Installation, Top -@comment node-name, next, previous, up - -@chapter About pcl-cvs -@cindex About pcl-cvs - -Pcl-cvs is a front-end to CVS versions 1.5 through 1.7 and newer; and -possibly verison 1.3 and 1.4A2. It integrates the most frequently used -CVS commands into an emacs interface. - -@menu -* Contributors:: Contributors to pcl-cvs. -* Archives:: Where can I get a copy of Pcl-Cvs? -@end menu - - -@node Contributors, Archives, About pcl-cvs, About pcl-cvs -@comment node-name, next, previous, up - -@section Contributors to pcl-cvs -@cindex Contributors -@cindex Authors - -Contributions to the package are welcome. I have limited time to work -on this project, but I will gladly add any code that you contribute to -me to this package (@pxref{Bugs}). - -The following persons have made contributions to pcl-cvs. - -@itemize @bullet -@item -Brian Berliner wrote CVS, together with some other contributors. -Without his work on CVS this package would be useless@dots{} - -@item -Per Cederqvist wrote most of the otherwise unattributed functions in -pcl-cvs as well as all documentation. - -@item -Inge Wallin (@samp{inge@@lysator.liu.se}) wrote the skeleton to -@file{pcl-cvs.texinfo}, and gave useful comments on it. He also wrote -the files @file{elib-node.el} and @file{compile-all.el}. The file -@file{cookie.el} was inspired by Inge.@refill - -@item -Linus Tolke (@samp{linus@@lysator.liu.se}) contributed useful comments -on both the functionality and the documentation.@refill - -@item -Jamie Zawinski (@samp{jwz@@lucid.com}) contributed -@file{pcl-cvs-lucid.el}. - -@item -Leif Lonnblad contributed RCVS support. (Since superceded by the new -remote CVS support.) - -@item -Jim Blandy (@samp{jimb@@cyclic.com}) contributed hooks to automatically -guess CVS log entries from ChangeLog contents; and initial support of -the new Cygnus / Cyclic remote CVS; as well as various sundry bug fixes -and cleanups. - -@item -Jim Kingdon (@samp{kingdon@@cyclic.com}) contributed lots of fixes to -the build and install procedure. - -@item -Greg A. Woods (@samp{woods@@planix.com}) contributed code to implement -the use of per-file diff buffers; and vendor join diffs with emerge and -ediff; as well as various an sundry bug fixes and cleanups. -@end itemize - -Apart from these, a lot of people have send me suggestions, ideas, -requests, bug reports and encouragement. Thanks a lot! Without your -there would be no new releases of pcl-cvs. - - -@node Archives, , Contributors, About pcl-cvs -@comment node-name, next, previous, up - -@section Where can I get pcl-cvs? -@cindex Sites -@cindex Archives -@cindex Ftp-sites -@cindex Getting pcl-cvs -@cindex Email archives - -The current release of pcl-cvs is included in CVS-1.7. - -The author's release of pcl-cvs can be fetched via anonymous ftp from -@code{ftp.lysator.liu.se}, (IP no. 130.236.254.1) in the directory -@code{pub/emacs}. If you don't live in Scandinavia you should probably -check with archie to see if there is a site closer to you that archives -pcl-cvs. - -New releases will be announced to appropriate newsgroups. If you send -your email address to me I will add you to my list of people to mail -when I make a new release. - - -@node Getting started, Buffer contents, About pcl-cvs, Top -@comment node-name, next, previous, up - -@chapter Getting started -@cindex Introduction -@cindex Example run - -This document assumes that you know what CVS is, and that you at least -knows the fundamental concepts of CVS. If that is not the case you -should read the man page for CVS. - -Pcl-cvs is only useful once you have checked out a module. So before -you invoke it you must have a copy of a module somewhere in the file -system. - -You invoke pcl-cvs by typing @kbd{M-x cvs-update RET}. If your emacs -responds with @samp{[No match]} your system administrator has not -installed pcl-cvs properly. Try @kbd{M-x load-library RET pcl-cvs RET}. -If that also fails - talk to your root. If it succeeds you might put -this line in your @file{.emacs} file so that you don't have to type the -@samp{load-library} command every time you wish to use pcl-cvs: - -@example -(autoload 'cvs-update "pcl-cvs" nil t) -@end example - -The function @code{cvs-update} will ask for a directory. The command -@samp{cvs update} will be run in that directory. (It should contain -files that have been checked out from a CVS archive.) The output from -@code{cvs} will be parsed and presented in a table in a buffer called -@samp{*cvs*}. It might look something like this: - -@example -PCL-CVS release 1.05-CVS-1.7. -@comment -release- - -In directory /users/ceder/FOO/test: - Updated bar - Updated file.txt - Modified ci namechange - Updated newer - -In directory /users/ceder/FOO/test/sub: - Modified ci ChangeLog ----------- End ----- -@end example - -In this example the two files (@file{bar}, @file{file.txt}, and -@file{newer}) that are marked with @samp{Updated} have been copied from -the CVS repository to @file{/users/ceder/FOO/test/} since someone else -have checked in newer versions of them. Two files (@file{namechange} -and @file{sub/ChangeLog}) have been modified locally, and needs to be -checked in. - -You can move the cursor up and down in the buffer with @kbd{C-n} and -@kbd{C-p} or @kbd{n} and @kbd{p}. If you press @kbd{c} on one of the -@samp{Modified} files that file will be checked in to the CVS -repository. @xref{Committing changes}. You can press @kbd{x} to get rid -of the "uninteresting" files that have only been @samp{Updated} (and -don't require any further action from you).@refill - -You can also easily get a @samp{diff} between your modified file and the -base version that you started from, and you can get the output from -@samp{cvs log} and @samp{cvs status} on the listed files simply by -pressing a key (@pxref{Getting info about files}). - - -@node Buffer contents, Commands, Getting started, Top -@comment node-name, next, previous, up - -@chapter Buffer contents -@cindex Buffer contents - -The display contains four columns. They contain, from left to right: - -@itemize @bullet -@item -An asterisk when the file is @dfn{marked} (@pxref{Selected -files}).@refill -@item -The status of the file. See @xref{File status}, for more -information.@refill -@item -A "need to be checked in"-marker (@samp{ci}). -@item -The file name. -@end itemize - -@menu -* File status:: The meaning of the second field. -* Selected files:: How selection works. -@end menu - - -@node File status, Selected files, Buffer contents, Buffer contents -@comment node-name, next, previous, up - -@section File status -@cindex File status -@cindex Updated (file status) -@cindex Patched (file status) -@cindex Modified (file status) -@cindex Merged (file status) -@cindex Conflict (file status) -@cindex Added (file status) -@cindex Removed (file status) -@cindex Unknown (file status) -@cindex Removed from repository (file status) -@cindex Removed from repository, changed by you (file status) -@cindex Removed by you, changed in repository (file status) -@cindex Move away @var{file} - it is in the way (file status) -@cindex This repository is missing!@dots{} (file status) - -The @samp{file status} field can have the following values: - -@table @samp - -@item Updated -The file was brought up to date with respect to the repository. This is -done for any file that exists in the repository but not in your source, -and for files that you haven't changed but are not the most recent -versions available in the repository.@refill - -@item Patched -The file was brought up to date with respect to a remote repository by -way of fetching and applying a patch to the file in your source. This -is done for any file that exists in a remote repository and in your -source; of which you haven't changed locally but is not the most recent -version available in the remote repository.@refill - -@item Modified -The file is modified in your working directory, and there was no -modification to the same file in the repository.@refill - -@item Merged -The file is modified in your working directory, and there were -modifications in the repository as well as in your copy, but they were -merged successfully, without conflict, in your working directory.@refill - -@item Conflict -A conflict was detected while trying to merge your changes to @var{file} -with changes from the source repository. @var{file} (the copy in your -working directory) is now the output of the @samp{rcsmerge} command on -the two versions; an unmodified copy of your file is also in your -working directory, with the name @file{.#@var{file}.@var{version}}, -where @var{version} is the RCS revision that your modified file started -from. @xref{Viewing differences}, for more details.@refill - -@item Added -The file has been added by you, but it still needs to be checked in to -the repository.@refill - -@item Removed -The file has been removed by you, but it needs to be checked in to the -repository. You can resurrect it by typing @kbd{a} (@pxref{Adding and -removing files}).@refill - -@item Unknown -A file that was detected in your directory, but that neither appears in -the repository, nor is present on the list of files that CVS should -ignore.@refill - -@end table - -There are also a few special cases, that rarely occur, which have longer -strings in the fields: - -@table @samp -@item Removed from repository -The file has been removed from your directory since someone has removed -it from the repository. (It is still present in the Attic directory, so -no permanent loss has occurred). This, unlike the other entries in this -table, is not an error condition.@refill - -@item Removed from repository, changed by you -You have modified a file that someone have removed from the repository. -You can correct this situation by removing the file manually (see -@pxref{Adding and removing files}).@refill - -@item Removed by you, changed in repository -You have removed a file, and before you committed the removal someone -committed a change to that file. You could use @kbd{a} to resurrect the -file (see @pxref{Adding and removing files}).@refill - -@item Move away @var{file} - it is in the way -For some reason CVS does not like the file @var{file}. Rename or remove -it.@refill - -@item This repository is missing! Remove this dir manually. -It is impossible to remove a directory in the CVS repository in a clean -way. Someone have tried to remove one, and CVS gets confused. Remove -your copy of the directory.@refill -@end table - - -@node Selected files, , File status, Buffer contents -@comment node-name, next, previous, up - -@section Selected files -@cindex Selected files -@cindex Marked files -@cindex File selection -@cindex Active files - -Many of the commands works on the current set of @dfn{selected} files. - -@itemize @bullet -@item -If there are any files that are marked they constitute the set of -selected files.@refill -@item -Otherwise, if the cursor points to a file, that file is the selected -file.@refill -@item -Otherwise, if the cursor points to a directory, all the files in that -directory that appears in the buffer are the selected files. -@end itemize - -This scheme might seem a little complicated, but once one get used to -it, it is quite powerful. - -@xref{Marking files} tells how you mark and unmark files. - - -@node Commands, Customization, Buffer contents, Top -@comment node-name, next, previous, up - -@chapter Commands - -@iftex -This chapter describes all the commands that you can use in pcl-cvs. -@end iftex -@ifinfo -The nodes in this menu contains explanations about all the commands that -you can use in pcl-cvs. They are grouped together by type. -@end ifinfo - -@menu -* Updating the directory:: Commands to update the local directory -* Movement commands:: How to move up and down in the buffer -* Marking files:: How to mark files that other commands - will later operate on. -* Committing changes:: Checking in your modifications to the - CVS repository. -* Editing files:: Loading files into Emacs. -* Getting info about files:: Display the log and status of files. -* Adding and removing files:: Adding and removing files -* Undoing changes:: Undoing changes -* Removing handled entries:: Uninteresting lines can easily be removed. -* Ignoring files:: Telling CVS to ignore generated files. -* Viewing differences:: Commands to @samp{diff} different versions. -* Invoking Ediff:: Running @samp{ediff} from @samp{*cvs*} buffer. -* Invoking Emerge:: Running @samp{emerge} from @samp{*cvs*} buffer. -* Reverting your buffers:: Reverting your buffers -* Miscellaneous commands:: Miscellaneous commands -@end menu - - -@node Updating the directory, Movement commands, Commands, Commands -@comment node-name, next, previous, up - -@section Updating the directory -@findex cvs-update -@findex cvs-mode-update-no-prompt -@findex cvs-delete-lock -@cindex Getting the *cvs* buffer -@kindex g - Rerun @samp{cvs update} - - -@table @kbd - -@item M-x cvs-update -Run a @samp{cvs update} command. You will be asked for the directory in -which the @samp{cvs update} will be run. The output will be parsed by -pcl-cvs, and the result printed in the @samp{*cvs*} buffer (see -@pxref{Buffer contents} for a description of the contents).@refill - -By default, @samp{cvs-update} will descend recursively into -subdirectories. You can avoid that behavior by giving a prefix -argument to it (e.g., by typing @kbd{C-u M-x cvs-update RET}).@refill - -All other commands in pcl-cvs requires that you have a @samp{*cvs*} -buffer. This is the command that you use to get one.@refill - -CVS uses lock files in the repository to ensure the integrity of the -data files in the repository. They might be left behind i.e. if a -workstation crashes in the middle of a CVS operation. CVS outputs a -message when it is waiting for a lock file to go away. Pcl-cvs will -show the same message in the *cvs* buffer, together with instructions -for deleting the lock files. You should normally not have to delete -them manually --- just wait a little while and the problem should fix -itself. But if the lock files doesn't disappear you can delete them -with @kbd{M-x cvs-delete-lock RET}.@refill - -@item g -This will run @samp{cvs update} again. It will always use the same -buffer that was used with the previous @samp{cvs update}. Give a prefix -argument to avoid descending into subdirectories. This runs the command -@samp{cvs-mode-update-no-prompt}.@refill - -@item G -This will run @samp{cvs update} and prompt for a new directory to -update. This runs the command @samp{cvs-update}.@refill - -@end table - - -@node Movement commands, Marking files, Updating the directory, Commands -@comment node-name, next, previous, up - -@section Movement Commands -@cindex Movement Commands -@findex cookie-next-cookie -@findex cookie-previous-cookie -@kindex SPC - Move down one file -@kindex C-n - Move down one file -@kindex n - Move down one file -@kindex C-p - Move up one file -@kindex p - Move up on file - -You can use most normal Emacs commands to move forward and backward in -the buffer. Some keys are rebound to functions that take advantage of -the fact that the buffer is a pcl-cvs buffer: - - -@table @kbd -@item SPC -@itemx C-n -@itemx n -These keys move the cursor one file forward, towards the end of the -buffer (@code{cookie-next-cookie}). - -@item C-p -@itemx p -These keys move one file backward, towards the beginning of the buffer -(@code{cookie-previous-cookie}). -@end table - - -@node Marking files, Committing changes, Movement commands, Commands -@comment node-name, next, previous, up - -@section Marking files -@cindex Selecting files (commands to mark files) -@cindex Marking files -@kindex m - marking a file -@kindex M - marking all files -@kindex u - unmark a file -@kindex ESC DEL - unmark all files -@kindex DEL - unmark previous file -@findex cvs-mode-mark -@findex cvs-mode-unmark -@findex cvs-mode-mark-all-files -@findex cvs-mode-unmark-all-files -@findex cvs-mode-unmark-up - -Pcl-cvs works on a set of @dfn{selected files} (@pxref{Selected files}). -You can mark and unmark files with these commands: - -@table @kbd -@item m -This marks the file that the cursor is positioned on. If the cursor is -positioned on a directory all files in that directory will be marked. -(@code{cvs-mode-mark}). - -@item u -Unmark the file that the cursor is positioned on. If the cursor is on a -directory, all files in that directory will be unmarked. -(@code{cvs-mode-unmark}).@refill - -@item M -Mark @emph{all} files in the buffer (@code{cvs-mode-mark-all-files}). - -@item @key{ESC} @key{DEL} -Unmark @emph{all} files (@code{cvs-mode-unmark-all-files}). - -@item @key{DEL} -Unmark the file on the previous line, and move point to that line -(@code{cvs-mode-unmark-up}). -@end table - - -@node Committing changes, Editing files, Marking files, Commands -@comment node-name, next, previous, up - -@section Committing changes -@cindex Committing changes -@cindex Ci -@findex cvs-mode-commit -@findex cvs-mode-changelog-commit -@kindex c - commit files -@kindex C - commit files with ChangeLog message -@vindex cvs-erase-input-buffer (variable) -@vindex cvs-auto-revert-after-commit (variable) -@cindex Commit buffer -@cindex Edit buffer -@cindex Erasing commit message -@cindex Reverting buffers after commit - -@table @kbd - -@item c -All files that have a "need to be checked in"-marker (@pxref{Buffer -contents}) can be checked in with the @kbd{c} command. It checks in all -selected files (@pxref{Selected files}) (except those who lack the -"ci"-marker - they are ignored). Pressing @kbd{c} causes -@code{cvs-mode-commit} to be run.@refill - -When you press @kbd{c} you will get a buffer called -@samp{*cvs-commit-message*}. Enter the log message for the file(s) in -it. When you are ready you should press @kbd{C-c C-c} to actually -commit the files (using @code{cvs-edit-done}). - -Normally the @samp{*cvs-commit-message*} buffer will retain the log -message from the previous commit, but if the variable -@code{cvs-erase-input-buffer} is set to a non-@code{nil} value the -buffer will be erased. Point and mark will always be located around the -entire buffer so that you can easily erase it with @kbd{C-w} -(@samp{kill-region}).@refill - -If you are editing the files in your emacs an automatic -@samp{revert-buffer} will be performed. (If the file contains -@samp{$@asis{Id}$} keywords @samp{cvs commit} will write a new file with -the new values substituted. The auto-revert makes sure that you get -them into your buffer). The revert will not occur if you have modified -your buffer, or if @samp{cvs-auto-revert-after-commit} is set to -@samp{nil}.@refill - -@item C -This is just like @samp{cvs-mode-commit}, except that it tries to -provide appropriate default log messages by looking at the -@samp{ChangeLog}s in the current directory. The idea is to write your -ChangeLog entries first, and then use this command to commit your -changes. Pressing @kbd{C} causes @code{cvs-mode-changelog-commit} to be -run.@refill - -To select default log text, pcl-cvs: -@itemize @minus -@item -finds the ChangeLogs for the files to be checked in; -@item -verifies that the top entry in the ChangeLog is on the current date and -by the current user; if not, no default text is provided; -@item -search the ChangeLog entry for paragraphs containing the names of the -files we're checking in; and finally -@item -uses those paragraphs as the default log text in the -@samp{*cvs-commit-message*} buffer. -@end itemize - -You can then commit the @samp{ChangeLog} file once per day without any -log message.@refill - -@end table - - -@node Editing files, Getting info about files, Committing changes, Commands -@comment node-name, next, previous, up - -@section Editing files -@cindex Editing files -@cindex Finding files -@cindex Loading files -@cindex Dired -@cindex Invoking dired -@findex cvs-mode-find-file -@findex cvs-mode-find-file-other-window -@findex cvs-mode-add-change-log-entry-other-window -@kindex f - find file or directory -@kindex o - find file in other window -@kindex A - add ChangeLog entry - -There are currently three commands that can be used to find a file (that -is, load it into a buffer and start editing it there). These commands -work on the line that the cursor is situated at. They ignore any marked -files. - -@table @kbd -@item f -Find the file that the cursor points to. Run @samp{dired} -@ifinfo -(@pxref{Dired,,,Emacs}) -@end ifinfo -if the cursor points to a directory (@code{cvs-mode-find-file}).@refill - -@item o -Like @kbd{f}, but use another window -(@code{cvs-mode-find-file-other-window}).@refill - -@item A -Invoke @samp{add-change-log-entry-other-window} to edit a -@samp{ChangeLog} file. The @samp{ChangeLog} will be found in the -directory of the file the cursor points to. -(@code{cvs-mode-add-change-log-entry-other-window}).@refill -@end table - - -@node Getting info about files, Adding and removing files, Editing files, Commands -@comment node-name, next, previous, up - -@section Getting info about files -@cindex Status (cvs command) -@cindex Log (RCS/cvs command) -@cindex Getting status -@kindex l - run @samp{cvs log} -@kindex s - run @samp{cvs status} -@findex cvs-mode-log -@findex cvs-mode-status - -Both of the following commands can be customized. -@xref{Customization}.@refill - -@table @kbd -@item l -Run @samp{cvs log} on all selected files, and show the result in a -temporary buffer (@code{cvs-mode-log}). - -@item s -Run @samp{cvs status} on all selected files, and show the result in a -temporary buffer (@code{cvs-mode-status}). -@end table - - -@node Adding and removing files, Undoing changes, Getting info about files, Commands -@comment node-name, next, previous, up - -@section Adding and removing files -@cindex Adding files -@cindex Removing files -@cindex Resurrecting files -@cindex Deleting files -@cindex Putting files under CVS control -@kindex a - add a file -@kindex r - remove a file -@findex cvs-mode-add -@findex cvs-mode-remove-file - -The following commands are available to make it easy to add and remove -files from the CVS repository. - -@table @kbd -@item a -Add all selected files. This command can be used on @samp{Unknown} -files (see @pxref{File status}). The status of the file will change to -@samp{Added}, and you will have to use @kbd{c} (@samp{cvs-mode-commit}, see -@pxref{Committing changes}) to really add the file to the -repository.@refill - -This command can also be used on @samp{Removed} files (before you commit -them) to resurrect them. - -Selected files that are neither @samp{Unknown} nor @samp{Removed} will -be ignored by this command. - -The command that is run is @code{cvs-mode-add}. - -@item r -This command removes the selected files (after prompting for -confirmation). The files are @samp{rm}ed from your directory and -(unless the status was @samp{Unknown}; @pxref{File status}) they will -also be @samp{cvs remove}d. If the files were @samp{Unknown} they will -disappear from the buffer. Otherwise their status will change to -@samp{Removed}, and you must use @kbd{c} (@samp{cvs-mode-commit}, -@pxref{Committing changes}) to commit the removal.@refill - -The command that is run is @code{cvs-mode-remove-file}. -@end table - - -@node Undoing changes, Removing handled entries, Adding and removing files, Commands -@comment node-name, next, previous, up - -@section Undoing changes -@cindex Undo changes -@cindex Flush changes -@kindex U - undo changes -@findex cvs-mode-undo-local-changes - -@table @kbd -@item U -If you have modified a file, and for some reason decide that you don't -want to keep the changes, you can undo them with this command. It works -by removing your working copy of the file and then getting the latest -version from the repository (@code{cvs-mode-undo-local-changes}. -@end table - - -@node Removing handled entries, Ignoring files, Undoing changes, Commands -@comment node-name, next, previous, up - -@section Removing handled entries -@cindex Expunging uninteresting entries -@cindex Uninteresting entries, getting rid of them -@cindex Getting rid of uninteresting lines -@cindex Removing uninteresting (processed) lines -@cindex Handled lines, removing them -@kindex x - remove processed entries -@kindex C-k - remove selected entries -@findex cvs-mode-remove-handled -@findex cvs-mode-acknowledge - -@table @kbd -@item x -This command allows you to remove all entries that you have processed. -More specifically, the lines for @samp{Updated} files (@pxref{File -status} and files that have been checked in (@pxref{Committing changes}) -are removed from the buffer. If a directory becomes empty the heading -for that directory is also removed. This makes it easier to get an -overview of what needs to be done. - -The command is called @code{cvs-mode-remove-handled}. If -@samp{cvs-auto-remove-handled} is set to non-@code{nil} this will -automatically be performed after every commit.@refill - -@item C-k -This command can be used for lines that @samp{cvs-mode-remove-handled} would -not delete, but that you want to delete (@code{cvs-mode-acknowledge}). -@end table - - -@node Ignoring files, Viewing differences, Removing handled entries, Commands -@comment node-name, next, previous, up - -@section Ignoring files -@kindex i - ignoring files -@findex cvs-mode-ignore - -@table @kbd -@item i -Arrange so that CVS will ignore the selected files. The file names are -added to the @file{.cvsignore} file in the corresponding directory. If -the @file{.cvsignore} doesn't exist it will be created. - -The @file{.cvsignore} file should normally be added to the repository, -but you could ignore it also if you like it better that way. - -This runs @code{cvs-mode-ignore}. -@end table - - -@node Viewing differences, Invoking Ediff, Ignoring files, Commands -@comment node-name, next, previous, up - -@section Viewing differences -@cindex Diff -@cindex Ediff -@cindex Invoking ediff -@cindex Conflicts, how to resolve them -@cindex Viewing differences -@kindex d - run @samp{cvs diff} -@kindex b - diff backup file -@findex cvs-mode-diff-cvs -@findex cvs-mode-diff-backup -@vindex cvs-diff-ignore-marks (variable) - -@table @kbd -@item d -Display a @samp{cvs diff} between the selected files and the RCS version -that they are based on. @xref{Customization} describes how you can send -flags to @samp{cvs diff}. If @var{cvs-diff-ignore-marks} is set to a -non-@code{nil} value or if a prefix argument is given (but not both) any -marked files will not be considered to be selected. -(@code{cvs-mode-diff-cvs}).@refill - -@item b -If CVS finds a conflict while merging two versions of a file (during a -@samp{cvs update}, @pxref{Updating the directory}) it will save the -original file in a file called @file{.#@var{FILE}.@var{VERSION}} where -@var{FILE} is the name of the file, and @var{VERSION} is the RCS version -number that your file was based on.@refill - -With the @kbd{b} command you can run a @samp{diff} on the files -@file{.#@var{FILE}.@var{VERSION}} and @file{@var{FILE}}. You can get a -context- or Unidiff by setting @samp{cvs-diff-flags} - -@pxref{Customization}. This command only works on files that have -status @samp{Conflict} or @samp{Merged}.@refill - -If @var{cvs-diff-ignore-marks} is set to a non-@code{nil} value or if a -prefix argument is given (but not both) any marked files will not be -considered to be selected. (@code{cvs-mode-diff-backup}).@refill -@end table - - -@node Invoking Ediff, Invoking Emerge, Viewing differences, Commands -@comment node-name, next, previous, up - -@section Running ediff -@cindex Ediff -@cindex Invoking ediff -@cindex Viewing differences -@cindex Conflicts, resolving -@cindex Resolving conflicts -@kindex e - invoke @samp{ediff} -@findex cvs-mode-ediff -@findex run-ediff-from-cvs-buffer -@findex cvs-old-ediff-interface - -@table @kbd -@item e -This command works -slightly different depending on the version of @samp{ediff} and the file -status.@refill - -With modern versions of @samp{ediff}, this command invokes -@samp{run-ediff-from-cvs-buffer} on one file.@refill - -@strong{Note:} When the file status is @samp{Merged} or @samp{Conflict}, -CVS has already performed a merge. The resulting file is not used in -any way if you use this command. If you use the @kbd{q} command inside -@samp{ediff} (to successfully terminate a merge) the file that CVS -created will be overwritten.@refill - -Older versions of @samp{ediff} use an interface similar to -@samp{emerge}. The function @samp{cvs-old-ediff-interface} is invoked -if the version of @samp{ediff} you have doesn't support -@samp{run-ediff-from-cvs-buffer}. These older versions do not support -merging of revisions.@refill - -@table @asis -@item @samp{Modified} -Run @samp{ediff-files} with your working file as file A, and the latest -revision in the repository as file B. - -@item @samp{Merged} -@itemx @samp{Conflict} -Run @samp{ediff-files3} with your working file (as it was prior to your -invocation of @samp{cvs-update}) as file A, the latest revision in the -repository as file B, and the revision that you based your local -modifications on as ancestor. - -@item @samp{Updated} -@itemx @samp{Patched} -Run @samp{ediff-files} with your working file as file A, and a given -revision in the repository as file B. You are prompted for the revision -to ediff against, and you may specify either a tag name or a numerical -revision number (@pxref{Getting info about files}). -@end table - -@end table - -@node Invoking Emerge, Reverting your buffers, Invoking Ediff, Commands -@comment node-name, next, previous, up - -@section Running emerge -@cindex Emerge -@cindex Ediff -@cindex Viewing differences -@cindex Invoking emerge -@cindex Conflicts, resolving -@cindex Resolving conflicts -@kindex E - invoke @samp{emerge} -@findex cvs-mode-emerge - -@table @kbd -@item E -Invoke @samp{emerge} on one file. This command works slightly different -depending on the file status. - -@table @asis -@item @samp{Modified} -Run @samp{emerge-files} with your working file as file A, and the latest -revision in the repository as file B. - -@item @samp{Merged} -@itemx @samp{Conflict} -Run @samp{emerge-files-with-ancestor} with your working file (as it was -prior to your invocation of @samp{cvs-update}) as file A, the latest -revision in the repository as file B, and the revision that you based -your local modifications on as ancestor. -@end table - -@strong{Note:} When the file status is @samp{Merged} or @samp{Conflict}, -CVS has already performed a merge. The resulting file is not used in -any way if you use this command. If you use the @kbd{q} command inside -@samp{emerge} (to successfully terminate the merge) the file that CVS -created will be overwritten. - -@end table - - -@node Reverting your buffers, Miscellaneous commands, Invoking Emerge, Commands -@comment node-name, next, previous, up - -@section Reverting your buffers -@findex cvs-mode-revert-updated-buffers -@kindex R - revert buffers -@cindex Syncing buffers -@cindex Reverting buffers - -@table @kbd -@item R -If you are editing (or just viewing) a file in a buffer, and that file -is changed by CVS during a @samp{cvs-update}, all you have to do is type -@kbd{R} in the *cvs* buffer to read in the new versions of the -files.@refill - -All files that are @samp{Updated}, @samp{Merged} or in @samp{Conflict} -are reverted from the disk. Any other files are ignored. Only files -that you were already editing are read.@refill - -An error is signalled if you have modified the buffer since it was last -changed. (@code{cvs-mode-revert-updated-buffers}).@refill -@end table - - -@node Miscellaneous commands, , Reverting your buffers, Commands -@comment node-name, next, previous, up - -@section Miscellaneous commands -@findex cvs-byte-compile-files -@cindex Recompiling elisp files -@cindex Byte compilation -@cindex Getting rid of lock files -@cindex Lock files -@kindex q - bury the *cvs* buffer -@findex bury-buffer - -@table @kbd -@item M-x cvs-byte-compile-files -Byte compile all selected files that end in .el. - -@item M-x cvs-delete-lock -This command can be used in any buffer, and deletes the lock files that -the *cvs* buffer informs you about. You should normally never have to -use this command since CVS tries very carefully to always remove the -lock files itself. - -You can only use this command when a message in the *cvs* buffer tells -you so. You should wait a while before using this command in case -someone else is running a cvs command. - -@item q -Bury the *cvs* buffer. (@code{bury-buffer}). - -@end table - - -@node Customization, Future enhancements, Commands, Top -@comment node-name, next, previous, up - -@chapter Customization -@vindex cvs-erase-input-buffer (variable) -@vindex cvs-inhibit-copyright-message (variable) -@vindex cvs-diff-flags (variable) -@vindex cvs-diff-ignore-marks (variable) -@vindex cvs-log-flags (variable) -@vindex cvs-status-flags (variable) -@vindex cvs-auto-remove-handled (variable) -@vindex cvs-update-prog-output-skip-regexp (variable) -@vindex cvs-cvsroot (variable) -@vindex TMPDIR (environment variable) -@vindex cvs-auto-revert-after-commit (variable) -@vindex cvs-commit-buffer-require-final-newline (variable) -@vindex cvs-sort-ignore-file (variable) -@cindex Inhibiting the Copyright message. -@cindex Copyright message, getting rid of it -@cindex Getting rid of the Copyright message. -@cindex Customization -@cindex Variables, list of all -@cindex Erasing the input buffer -@cindex Context diff, how to get -@cindex Unidiff, how to get -@cindex Automatically remove handled files -@cindex -u option in modules file -@cindex Modules file (-u option) -@cindex Update program (-u option in modules file) -@cindex Reverting buffers after commit -@cindex Require final newline -@cindex Automatically inserting newline -@cindex Commit message, inserting newline -@cindex Sorting the .cvsignore file -@cindex .cvsignore file, sorting -@cindex Automatically sorting .cvsignore - -If you have an idea about any customization that would be handy but -isn't present in this list, please tell me! @xref{Bugs} for info on how -to reach me.@refill - -@table @samp -@item cvs-erase-input-buffer -If set to anything else than @code{nil} the edit buffer will be erased -before you write the log message (@pxref{Committing changes}). - -@item cvs-inhibit-copyright-message -The copyright message that is displayed on startup can be annoying after -a while. Set this variable to @samp{t} if you want to get rid of it. -(But don't set this to @samp{t} in the system defaults file - new users -should see this message at least once). - -@item cvs-diff-flags -A list of strings to pass as arguments to the @samp{cvs diff} and -@samp{diff} programs. This is used by @samp{cvs-mode-diff-cvs} and -@samp{cvs-mode-diff-backup} (key @kbd{b}, @pxref{Viewing differences}). If -you prefer the Unidiff format you could add this line to your -@file{.emacs} file:@refill - -@example -(setq cvs-diff-flags '("-u")) -@end example - -@item cvs-diff-ignore-marks -If this variable is non-@code{nil} or if a prefix argument is given (but -not both) to @samp{cvs-mode-diff-cvs} or @samp{cvs-mode-diff-backup} -marked files are not considered selected. - -@item cvs-log-flags -List of strings to send to @samp{cvs log}. Used by @samp{cvs-mode-log} -(key @kbd{l}, @pxref{Getting info about files}). - -@item cvs-status-flags -List of strings to send to @samp{cvs status}. Used by @samp{cvs-mode-status} -(key @kbd{s}, @pxref{Getting info about files}). - -@item cvs-auto-remove-handled -If this variable is set to any non-@code{nil} value -@samp{cvs-mode-remove-handled} will be called every time you check in -files, after the check-in is ready. @xref{Removing handled -entries}.@refill - -@item cvs-auto-revert-after-commit -If this variable is set to any non-@samp{nil} value any buffers you have -that visit a file that is committed will be automatically reverted. -This variable is default @samp{t}. @xref{Committing changes}.@refill - -@item cvs-update-prog-output-skip-regexp -The @samp{-u} flag in the @file{modules} file can be used to run a command -whenever a @samp{cvs update} is performed (see cvs(5)). This regexp -is used to search for the last line in that output. It is normally set -to @samp{"$"}. That setting is only correct if the command outputs -nothing. Note that pcl-cvs will get very confused if the command -outputs @emph{anything} to @samp{stderr}. - -@item cvs-cvsroot -This variable can be set to override @samp{CVSROOT}. It should be a -string. If it is set then everytime a cvs command is run it will be -called as @samp{cvs -d @var{cvs-cvsroot}@dots{}} This can be useful if -your site has several repositories. - -@item TMPDIR -Pcl-cvs uses this @emph{environment variable} to decide where to put the -temporary files it needs. It defaults to @file{/tmp} if it is not set. - -@item cvs-commit-buffer-require-final-newline -When you enter a log message in the @samp{*cvs-commit-message*} buffer -pcl-cvs will normally automatically insert a trailing newline, unless -there already is one. This behavior can be controlled via -@samp{cvs-commit-buffer-require-final-newline}. If it is @samp{t} (the -default behavior), a newline will always be appended. If it is -@samp{nil}, newlines will never be appended. Any other value causes -pcl-cvs to ask the user whenever there is no trailing newline in the -commit message buffer. - -@item cvs-sort-ignore-file -If this variable is set to any non-@samp{nil} value the -@file{.cvsignore} will always be sorted whenever you use -@samp{cvs-mode-ignore} to add a file to it. This option is on by -default. - -@end table - - -@node Future enhancements, Bugs, Customization, Top -@comment node-name, next, previous, up - -@chapter Future enhancements -@cindex Enhancements - -Pcl-cvs is still under development and needs a number of enhancements to -be called complete. Below is my current wish-list for future releases -of pcl-cvs. Please, let me know which of these features you want most. -They are listed below in approximately the order that I currently think -I will implement them in. - -@itemize @bullet -@item -Rewritten parser code. There are many situations where pcl-cvs will -fail to recognize the output from CVS. The situation could be greatly -increased. - -@item -@samp{cvs-status}. This will run @samp{cvs status} in a directory and -produce a buffer that looks pretty much like the current *cvs* buffer. -That buffer will include information for all version-controlled files. -(There will be a simple keystroke to remove all "uninteresting" files, -that is, files that are "Up-to-date"). In this new buffer you will be -able to update a file, commit a file, et c. The big win with this is -that you will be able to watch the differences between your current -working file and the head revision in the repository before you update -the file, and you can then choose to update it or let it wait for a -while longer. - -@item -Log mode. When this mode is finished you will be able to move around -(using @kbd{n} and @kbd{p}) between the revisions of a file, mark two of -them, and run a diff between them. You will be able to hide branches -(similar to the way you can hide sub-paragraphs in outline-mode) and do -merges between revisions. Other ideas about this are welcome. - -@item -The current model for marks in the *cvs* buffer seems to be confusing. -I am considering to use the VM model instead, where marks are normally -inactive. To activate the mark, you issue a command like -@samp{cvs-mode-next-command-uses-marks}. I might implement a flag so -that you can use either version. Feedback on this before I start coding -it is very welcome. - -@item -It should be possible to run commands such as @samp{cvs log}, @samp{cvs -status} and @samp{cvs commit} directly from a buffer containing a file, -instead of having to @samp{cvs-update}. If the directory contains many -files the @samp{cvs-update} can take quite some time, especially on a -slow machine. I planed to put these kind of commands on the prefix -@kbd{C-c C-v}, but that turned out to be used by for instance c++-mode. -If you have any suggestions for a better prefix key, please let me know. - -@item -Increased robustness. For instance, you can not currently press -@kbd{C-g} when you are entering the description of a file that you are -adding without confusing pcl-cvs. - -@item -Support for multiple active *cvs* buffers. - -@item -Dired support. I have an experimental @file{dired-cvs.el} that works -together with CVS 1.2. Unfortunately I wrote it on top of a -non-standard @file{dired.el}, so it must be rewritten.@refill - -@item -An ability to send user-supplied options to all the cvs commands. - -@item -Pcl-cvs is not at all clever about what it should do when @samp{cvs -update} runs a program (due to the @samp{-u} option in the -@file{modules} file --- see @samp{cvs(5)}). The current release uses a -regexp to search for the end. At the very least that regexp should be -configured for different modules. Tell me if you have any idea about -what is the right thing to do. In a perfect world the program should -also be allowed to print to @samp{stderr} without causing pcl-cvs to -crash. -@end itemize - - -If you miss something in this wish-list, let me know! I don't promise -that I will write it, but I will at least try to coordinate the efforts -of making a good Emacs front end to CVS. See @xref{Bugs} for -information about how to reach me.@refill - -So far, I have written most of pcl-cvs in my all-to-rare spare time. If -you want pcl-cvs to be developed faster you can write a contract with -Signum Support to do the extension. You can reach Signum Support by -email to @samp{info@@signum.se} or via mail to Signum Support AB, Box -2044, S-580 02 Linkoping, Sweden. Phone: +46 (0) 13 - 21 46 00. Fax: -+46 (0) 13 - 21 47 00. - - -@node Bugs, COPYING, Future enhancements, Top -@comment node-name, next, previous, up - -@chapter Bugs (known and unknown) -@cindex Reporting bugs and ideas -@cindex Bugs, how to report them -@cindex Author, how to reach -@cindex Email to the author -@cindex Known bugs -@cindex Bugs, known -@cindex FAQ -@cindex Problems, list of common - -If you find a bug or misfeature, don't hesitate to tell me! Send email -to @samp{ceder@@lysator.liu.se}. - -If you have ideas for improvements, or if you have written some -extensions to this package, I would like to hear from you. I hope that -you find this package useful! - -Below is a partial list of currently known problems with pcl-cvs version -1.05. - -@table @asis -@item Commit causes Emacs to hang -Emacs waits for the @samp{cvs commit} command to finish before you can -do anything. If you start a background job from the loginfo file you -must take care that it closes @samp{stdout} and @samp{stderr} if you do -not want to wait for it. (You do that with @samp{background-command &>- -2&>- &} if you are starting @samp{background-command} from a -@samp{/bin/sh} shell script). - -Your emacs will also hang if there was a lock file in the repository. -In this case you can type @kbd{C-g} to get control over your emacs -again. - -@item Name clash in Emacs 19 -This is really a bug in Elib or the Emacs 19 distribution. Both Elib and -Emacs 19.6 through at least 19.10 contains a file named -@file{cookie.el}. One of the files will have to be renamed, and we are -currently negotiating about which of the files to rename. - -@item Commands while cvs-update is running -It is possible to type commands in the *cvs* buffer while the update is -running, but error messages is all that you will get. The error -messages should be better. - -@item Unexpected output from CVS -Unexpected output from CVS confuses pcl-cvs. It will currently create a -bug report that you can mail to me. It should do something more -civilized. -@end table - - -@node COPYING, Function and Variable Index, Bugs, Top -@comment node-name, next, previous, up - -@appendix GNU GENERAL PUBLIC LICENSE -@c @include gpl.texinfo - - -@node Function and Variable Index, Concept Index, COPYING, Top -@comment node-name, next, previous, up - -@unnumbered Function and Variable Index - -@printindex fn - - -@node Concept Index, Key Index, Function and Variable Index, Top -@comment node-name, next, previous, up - -@unnumbered Concept Index - -@printindex cp - - -@node Key Index, , Concept Index, Top -@comment node-name, next, previous, up - -@unnumbered Key Index - -@printindex ky - -@summarycontents -@contents -@bye
--- a/man/widget.texi Mon Aug 13 10:03:54 2007 +0200 +++ b/man/widget.texi Mon Aug 13 10:04:58 2007 +0200 @@ -13,8 +13,6 @@ @comment node-name, next, previous, up @top The Emacs Widget Library -Version: 1.9960 - @menu * Introduction:: * User Interface:: @@ -287,15 +285,10 @@ (defun widget-example () "Create the widgets from the Widget manual." (interactive) - (switch-to-buffer "*Widget Example*") + (kill-buffer (get-buffer-create "*Widget Example*")) + (switch-to-buffer (get-buffer-create "*Widget Example*")) (kill-all-local-variables) (make-local-variable 'widget-example-repeat) - (let ((inhibit-read-only t)) - (erase-buffer)) - (let ((all (overlay-lists))) - ;; Delete all the overlays. - (mapcar 'delete-overlay (car all)) - (mapcar 'delete-overlay (cdr all))) (widget-insert "Here is some documentation.\n\nName: ") (widget-create 'editable-field :size 13
--- a/man/xemacs/mule.texi Mon Aug 13 10:03:54 2007 +0200 +++ b/man/xemacs/mule.texi Mon Aug 13 10:04:58 2007 +0200 @@ -9,27 +9,20 @@ @cindex encoding of characters @cindex Chinese -@cindex Devanagari -@cindex Hindi -@cindex Marathi -@cindex Ethiopian @cindex Greek @cindex IPA @cindex Japanese @cindex Korean -@cindex Lao @cindex Russian -@cindex Thai -@cindex Tibetan -@cindex Vietnamese If you compile XEmacs with mule option, it supports a wide variety of -world scripts, including Latin alphabet (for some European languages and -Vietnamese), as well as Arabic, Simplified Chinese (for mainland of -China), Traditional Chinese (for Taiwan and Hong-Kong), Greek, Hebrew, -IPA, Japanese (Hiragana, Katakana and Kanji), Korean (Hangul and Hanja) -and Cyrillic (Beylorussian, Bulgarian, Russian, Serbian and Ukrainian) -scripts. These features have been merged from the modified version of -Emacs known as MULE (for ``MULti-lingual Enhancement to GNU Emacs''). +world scripts, including Latin script, as well as Arabic script, +Simplified Chinese script (for mainland of China), Traditional Chinese +script (for Taiwan and Hong-Kong), Greek script, Hebrew script, IPA +symbols, Japanese scripts (Hiragana, Katakana and Kanji), Korean scripts +(Hangul and Hanja) and Cyrillic script (for Beylorussian, Bulgarian, +Russian, Serbian and Ukrainian). These features have been merged from +the modified version of Emacs known as MULE (for ``MULti-lingual +Enhancement to GNU Emacs''). @menu * Mule Intro:: Basic concepts of Mule. @@ -437,6 +430,10 @@ Use coding system @var{coding} for the visited file in the current buffer. +@item C-x @key{RET} c @var{coding} @key{RET} +Specify coding system @var{coding} for the immediately following +command. + @item C-x @key{RET} k @var{coding} @key{RET} Use coding system @var{coding} for keyboard input. @@ -457,13 +454,28 @@ command applies to a file you have already visited, it affects only the way the file is saved. +@kindex C-x RET c +@findex universal-coding-system-argument Another way to specify the coding system for a file is when you visit -the file. If you run some file input commands with the precedent -@kbd{C-u}, you can specify coding system to read from minibuffer. +the file. First use the command @kbd{C-x @key{RET} c} +(@code{universal-coding-system-argument}); this command uses the +minibuffer to read a coding system name. After you exit the minibuffer, +the specified coding system is used for @emph{the immediately following +command}. So if the immediately following command is @kbd{C-x C-f}, for example, it reads the file using that coding system (and records the coding -system for when the file is saved). Other file commands affected by a +system for when the file is saved). Or if the immediately following +command is @kbd{C-x C-w}, it writes the file using that coding system. +Other file commands affected by a specified coding system include +@kbd{C-x C-i} and @kbd{C-x C-v}, as well as the other-window variants of +@kbd{C-x C-f}. + + In addition, if you run some file input commands with the precedent +@kbd{C-u}, you can specify coding system to read from minibuffer. So if +the immediately following command is @kbd{C-x C-f}, for example, it +reads the file using that coding system (and records the coding system +for when the file is saved). Other file commands affected by a specified coding system include @kbd{C-x C-i} and @kbd{C-x C-v}, as well as the other-window variants of @kbd{C-x C-f}.
--- a/src/ChangeLog Mon Aug 13 10:03:54 2007 +0200 +++ b/src/ChangeLog Mon Aug 13 10:04:58 2007 +0200 @@ -1,3 +1,258 @@ +1997-11-08 SL Baur <steve@altair.xemacs.org> + + * lread.c (init_lread): start from lisp, not lisp/prim. + + * Makefile.in.in: lisp/prim does exist any more. + +1997-11-07 Kyle Jones <kyle_jones@wonderworks.com> + + * abbrev.c (abbrev_lookup): Don't delete dash at the + abbrev start location; abbrev-prefix-mark no longer + inserts one. + +Wed November 05 23:40:00 1997 <jhar@tardis.ed.ac.uk> + + * fileio.c: insert-file-contents-internal + Added a bodge to do CRLF->LF conversion of text files, + conditioned on DOS_NT. This is currently only one-way, so all + text files written by XEmacs will be UNIXified. CRLF conversion + is required to make bytecompile work. + + * Added file headers to: + console-w32.c, console-w32.h, + device-w32.c, event-w32.c, event-w32.h, frame-w32.c, + objects-w32.c, objects-w32.h, redisplay-w32.c, w32-proc.c + +Sun November 01 12:00:00 1997 <jhar@tardis.ed.ac.uk> + + * redisplay-x.c: x_output_vertical_divider: + If HAVE_SCROLLBARS was not defined, coordinate of the right of + the divider was being used unitialised. + + * console.h: Added Qw32 and CONSOLE_W32* macros, conditioned on + HAVE_W32GUI. + + * emacs.c: Added calls to the following, conditioned on HAVE_W32GUI: + syms_of_*_w32, vars_of_*_w32, console_type_create_*w32. + + * event-stream.c: Conditioned on HAVE_W32GUI: + - vars_of_event_stream calls vars_of_event_w32. + - init_event_stream calls init_event_w32_late. + + * events-mod.h: Removed comment about having alternative making + MOD_* constants for different windowing systems. + + * events.c: Conditioned on HAVE_W32GUI: + - event-equal: Added case for w32 magic events. + - event-hash: Added case for w32 magic events. + + * events.h: Conditioned on HAVE_W32GUI: + Added struct underlying_w32_event to magic_data. + + * faces.c: complex_vars_of_faces + Added fallbacks for w32 faces, conditioned on HAVE_W32GUI. + + * frame.c: set-frame-properties + Added reference to default-w32-frame-plist to docstring. + + * general.c: Added new Lisp_Object Qw32 and defsymbol. + + * redisplay-output.c: redisplay_update_line + Conditioned reference to stupid_vertical_scrollbar_drag_hack on + HAVE_X_WINDOWS. This will need a proper fix when w32 gets + scrollbars. + + * redisplay-tty.c: init_tty_for_redisplay + Conditioned blocking and unblocking of SIGTTOU on !WIN32 because + these signals don't exist under win32. + + * redisplay.c: init_redisplay + Initialise window system to w32, conditioned on HAVE_W32GUI. + + * symsinit.h: Added syms_of_*_w32, vars_of_*_w32 and + init_event_w32_late. + + * sysdep.c: Conditioned various things on WIN32 in addition to + MSDOS. + + * New files: + console-w32.c, console-w32.h, + device-w32.c, event-w32.c, event-w32.h, frame-w32.c, + objects-w32.c, objects-w32.h, redisplay-w32.c, w32-proc.c + +1997-11-07 Hrvoje Niksic <hniksic@srce.hr> + + * doc.c (Fdocumentation_property): GCPRO doc. + (Fsubstitute_command_keys): Disallow zero bsize. + +1997-11-06 Hrvoje Niksic <hniksic@srce.hr> + + * events.c (Fevent_modeline_position): Return nil if event is not + over modeline, as the docstring says. + + * utils/facemenu.el (facemenu-insert-menu-entry): Check for + menubar availability. + + * utils/easymenu.el (easy-menu-change): Check for menubar + availability. + + * custom/wid-edit.el (widget-echo-help): Use `help-echo' as label + for help-echo messages. + +1997-11-05 Martin Buchholz <Martin Buchholz <martin@xemacs.org>> + + * s/aix3-1.h: Remove ^L character wich confuses AIX make. + +1997-11-06 Tomasz Cholewo <tjchol01@mecca.spd.louisville.edu> + + * event-stream.c (Fnext_command_event): Document keystroke echoing. + +1997-11-06 Hrvoje Niksic <hniksic@srce.hr> + + * fns.c (Ffeaturep): Use call1, to prevent stack thrashing with + circular lists. + - Update docstring. + +1997-11-06 Kyle Jones <kyle_jones@wonderworks.com> + + * frame-x.c (x_delete_frame): Removed code that + blocked the deletion of popup frames. No need for it. + +1997-11-05 SL Baur <steve@altair.xemacs.org> + + * balloon_help.h: Replace <X11/Intrinsic.h> with "xintrinsic.h" + * balloon_help.c: Ditto. + * offix.h: Ditto. + + * mule-coding.c (coding_system_charset): Add prototype. + +1997-11-04 Kazuyuki IENAGA <ienaga@jsys.co.jp> + + * s/freebsd.h: Add HAVE_TIMEZONE_DECL. Configure will fail at + checking for the existence of `extern long timezone'. + FreeBSD actualy has the `timezone', but due to its <time.h> and + <sys/time.h>, it cannot be recognized by configure. + +1997-11-03 Hrvoje Niksic <hniksic@srce.hr> + + * data.c (Fsubr_interactive): New function. + +1997-11-03 Kyle Jones <kyle_jones@wonderworks.com> + + * frame.c (change_frame_size_1): Added explanatory + comment. + + * window.c (set_window_pixsize): Don't bail out + before looping over the major children if there is no + size change indicated. The top and left coordinates + may need to be recomputed, e.g. in toolbar visibility + updates. + +1997-11-02 Kyle Jones <kyle_jones@wonderworks.com> + + * fileio.c (Ffile_truename): Make the errno == EACCES case + behave the same as errno == ENOENT. + +1997-11-03 Kyle Jones <kyle_jones@wonderworks.com> + + * frame.c (Fframe_property, Fframe_properties): Check + for minibuffer-onlyness of frame before checking whether + it has a minibuffer. This makes the minibuffer property + value be reported as 'only when that is appropriate. The + check order was reversed which resulted in minibuffer-only + frames having the minibuffer property reported as t. + +1997-11-02 Andreas Jaeger <aj@arthur.rhein-neckar.de> + + * m/vax.h: + * s/cxux.h: + * s/xenix.h: + * s/umax.h: + * s/msdos.h: + * s/template.h: + * termcap.c: + * signal.c: + * lread.c: + * callproc.c + * buffer.c: Remove VMS dependent code. + +1997-11-02 Andreas Jaeger <aj@arthur.rhein-neckar.de> + + * syspwd.h: + * systty.h: + * systime.h: + * syssignal.h: + * sysproc.h: + * sysfloat.h: + * sysfile.h: + * regex.h: + * process.h: + * ndir.h: + * mule-mcpath.h: + * getpagesize.h: + * sysdep.h: + * fileio.c: + * process.c: Remove old VMS code. + +1997-11-02 SL Baur <steve@altair.xemacs.org> + + * glyphs-x.c: Use <magick/magick.h> instead of <magick.h> + +1997-11-02 Andreas Jaeger <aj@arthur.rhein-neckar.de> + + * sysdep.c: + * getloadavg.c: + * malloc.c: Remove old VMS code. + +1997-11-02 Hrvoje Niksic <hniksic@srce.hr> + + * database.c (print_database): Don't use a static buffer to store + file name. + + * dired.c (make_directory_hash_table): Ditto. + + * fileio.c (Ffile_truename): Use `make_ext_string' instead of + `make_string'. + +1997-11-01 Hrvoje Niksic <hniksic@srce.hr> + + * database.c (CONCHECK_DATABASE): Define. + + * dired.c (Fdirectory_files): Use `make_ext_string' instead of + `make_string', to avoid crashes under Mule. + (file_name_completion): Use `make_ext_string'. + + * database.c (new_database): Renamed to `allocate_database', as + per coding conventions. + +1997-11-02 Andreas Jaeger <aj@arthur.rhein-neckar.de> + + * dired.c: Remove VMS dependent code. + +1997-11-01 Kyle Jones <kyle_jones@wonderworks.com> + + * buffer.h: Change XCHAR_OR_CHAR_INT to use XCHAR or + XINT as appropriate instead of using XREALINT. + + * regex.c (re_search_2): cast translate[*d] to + unsigned char when indexing fastmap to avoid sign + change when value has the 0x80 bit set. + +1997-10-31 SL Baur <steve@altair.xemacs.org> + + * linuxplay.c (audio_init): Update for newer Linux kernels. + From Robert Bihlmeyer <robbe@orcus.priv.at> + +1997-11-01 Hrvoje Niksic <hniksic@srce.hr> + + * fileio.c (Finsert_file_contents_internal): Fix misleading + comment. + +1997-10-31 Kyle Jones <kyle_jones@wonderworks.com> + + * callproc.c: GC protect current_dir while infile and + error_file are being initialized. + 1997-10-30 SL Baur <steve@altair.xemacs.org> * config.h.in: Remove HAVE_GIF, HAVE_JPEG, HAVE_PNG, HAVE_TIFF and
--- a/src/Makefile.in.in Mon Aug 13 10:03:54 2007 +0200 +++ b/src/Makefile.in.in Mon Aug 13 10:04:58 2007 +0200 @@ -269,7 +269,7 @@ mo_file = ${mo_dir}emacs.mo #endif -LOADPATH = EMACSLOADPATH="${lispdir}prim" +LOADPATH = EMACSLOADPATH="${lispdir}" DUMPENV = $(LOADPATH) release: temacs ${libsrc}DOC $(mo_file) ${other_files} @@ -309,7 +309,7 @@ update-elc.stamp : FRC.update-elc.stamp @touch NOBYTECOMPILE - ${DUMPENV} ./temacs -batch -l ../prim/update-elc.el + ${DUMPENV} ./temacs -batch -l update-elc.el @if test ! -f $@ -o -f NOBYTECOMPILE; then touch $@; fi; \ $(RM) NOBYTECOMPILE @@ -323,14 +323,14 @@ ${libsrc}DOC: temacs update-elc.stamp $(RM) ${libsrc}DOC; \ - ${DUMPENV} ./temacs -batch -l ../prim/make-docfile.el -- \ + ${DUMPENV} ./temacs -batch -l make-docfile.el -- \ -o ${libsrc}DOC -d ${srcdir} -i ${libsrc}../site-packages \ ${obj_src} ${mallocdocsrc} ${rallocdocsrc} dump_elcs: dump-elcs dump-elcs: temacs - -${DUMPENV} ./temacs -batch -l ../prim/update-elc.el + -${DUMPENV} ./temacs -batch -l update-elc.el all-elc all-elcs: cd .. && $(RECURSIVE_MAKE) all-elc
--- a/src/abbrev.c Mon Aug 13 10:03:54 2007 +0200 +++ b/src/abbrev.c Mon Aug 13 10:04:58 2007 +0200 @@ -179,11 +179,18 @@ wordstart = get_buffer_pos_char (buf, Vabbrev_start_location, GB_COERCE_RANGE); Vabbrev_start_location = Qnil; + /* + * Previously, abbrev-prefix-mark inserted a dash to indicate the + * abbrev start point. It now uses an extent with a begin + * glyph so there's no dash to remove. + */ +/* if (wordstart != BUF_ZV (buf) && BUF_FETCH_CHAR (buf, wordstart) == '-') { buffer_delete_range (buf, wordstart, wordstart + 1, 0); } +*/ wordend = BUF_PT (buf); } else
--- a/src/balloon_help.c Mon Aug 13 10:03:54 2007 +0200 +++ b/src/balloon_help.c Mon Aug 13 10:04:58 2007 +0200 @@ -40,7 +40,7 @@ #include <X11/Xutil.h> #include <X11/extensions/shape.h> -#include <X11/Intrinsic.h> +#include "xintrinsic.h" #include "balloon_help.h"
--- a/src/balloon_help.h Mon Aug 13 10:03:54 2007 +0200 +++ b/src/balloon_help.h Mon Aug 13 10:04:58 2007 +0200 @@ -23,7 +23,7 @@ #ifndef BALLOON_HELP_H #define BALLOON_HELP_H -#include <X11/Intrinsic.h> +#include "xintrinsic.h" void balloon_help_create (Display* dpy, Pixel fg, Pixel bg, Pixel shine, Pixel shadow,
--- a/src/buffer.c Mon Aug 13 10:03:54 2007 +0200 +++ b/src/buffer.c Mon Aug 13 10:04:58 2007 +0200 @@ -2492,7 +2492,7 @@ DEFVAR_BUFFER_LOCAL ("buffer-file-type", buffer_file_type /* "Non-nil if the visited file is a binary file. -This variable is meaningful on MS-DOG and Windows NT. +This variable is meaningful on MS-DOS and Windows NT. On those systems, it is automatically local in every buffer. On other systems, this variable is normally always nil. */ ); @@ -2831,7 +2831,6 @@ else if (getcwd (buf, MAXPATHLEN) == NULL) fatal ("`getcwd' failed: %s\n", strerror (errno)); -#ifndef VMS /* Maybe this should really use some standard subroutine whose definition is filename syntax dependent. */ rc = strlen (buf); @@ -2840,7 +2839,17 @@ buf[rc] = DIRECTORY_SEP; buf[rc + 1] = '\0'; } -#endif /* not VMS */ + /* XEmacs change: store buffer's default directory + using prefered (i.e. as defined at compile-time) + directory separator. --marcpa */ +#ifdef DOS_NT +#define CORRECT_DIR_SEPS(s) \ + do { if ('/' == DIRECTORY_SEP) dostounix_filename (s); \ + else unixtodos_filename (s); \ + } while (0) + + CORRECT_DIR_SEPS(buf); +#endif current_buffer->directory = build_string (buf); #if 0 /* FSFmacs */
--- a/src/buffer.h Mon Aug 13 10:03:54 2007 +0200 +++ b/src/buffer.h Mon Aug 13 10:04:58 2007 +0200 @@ -592,12 +592,12 @@ XCHAR_OR_CHAR_INT (Lisp_Object obj) { assert (CHAR_OR_CHAR_INTP (obj)); - return XREALINT (obj); + return CHARP (obj) ? XCHAR (obj) : XINT (obj); } #else -#define XCHAR_OR_CHAR_INT(obj) XREALINT (obj) +#define XCHAR_OR_CHAR_INT(obj) (CHARP ((obj)) ? XCHAR ((obj)) : XINT ((obj))) #endif
--- a/src/callproc.c Mon Aug 13 10:03:54 2007 +0200 +++ b/src/callproc.c Mon Aug 13 10:04:58 2007 +0200 @@ -19,6 +19,7 @@ Boston, MA 02111-1307, USA. */ /* Synched up with: Mule 2.0, FSF 19.30. */ +/* Partly sync'ed with 19.36.4 */ #include <config.h> #include "lisp.h" @@ -69,6 +70,10 @@ */ Lisp_Object Vprocess_environment; +#ifdef DOS_NT +Lisp_Object Qbuffer_file_type; +#endif /* DOS_NT */ + /* True iff we are about to fork off a synchronous process or if we are waiting for it. */ volatile int synch_process_alive; @@ -87,7 +92,6 @@ /* Nonzero if this is termination due to exit. */ static int call_process_exited; -#ifndef VMS /* VMS version is in vmsproc.c. */ static Lisp_Object call_process_kill (Lisp_Object fdpid) @@ -187,7 +191,7 @@ char *bufptr = buf; int bufsize = 16384; int speccount = specpdl_depth (); - struct gcpro gcpro1; + struct gcpro gcpro1, gcpro2; char **new_argv = alloca_array (char *, max (2, nargs - 2)); /* File to use for stderr in the child. @@ -239,6 +243,8 @@ NUNGCPRO; } + GCPRO1 (current_dir); + if (nargs >= 2 && ! NILP (args[1])) { struct gcpro ngcpro1; @@ -250,7 +256,9 @@ else infile = build_string (NULL_DEVICE); - GCPRO1 (infile); /* Fexpand_file_name might trash it */ + UNGCPRO; + + GCPRO2 (infile, current_dir); /* Fexpand_file_name might trash it */ if (nargs >= 3) { @@ -617,9 +625,7 @@ } } -#endif /* VMS */ -#ifndef VMS /* VMS version is in vmsproc.c. */ /* This is the last thing run in a newly forked inferior either synchronous or asynchronous. @@ -771,6 +777,7 @@ } #ifdef WINDOWSNT prepare_standard_handles (in, out, err, handles); + set_process_dir (current_dir); #else /* not WINDOWSNT */ /* Make sure that in, out, and err are not actually already in descriptors zero, one, or two; this could happen if Emacs is @@ -937,7 +944,6 @@ else return 0; } -#endif /* not VMS */ void @@ -1085,9 +1091,8 @@ Vprefix_directory = Qnil; #endif -#ifdef VMS - Vshell_file_name = build_string ("*dcl*"); -#elif defined(WINDOWSNT) +#ifdef WINDOWSNT + /* Sync with FSF Emacs 19.34.6 note: this is not in 19.34.6. --marcpa */ /* ** If NT then we look at COMSPEC for the shell program. */ @@ -1114,7 +1119,7 @@ Vshell_file_name = build_string ("/WINNT/system32/cmd.exe"); } } -#else /* not VMS or WINDOWSNT */ +#else /* not WINDOWSNT */ sh = (char *) egetenv ("SHELL"); Vshell_file_name = build_string (sh ? sh : "/bin/sh"); #endif @@ -1139,10 +1144,8 @@ void syms_of_callproc (void) { -#ifndef VMS DEFSUBR (Fcall_process_internal); DEFSUBR (Fgetenv); -#endif } void
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/console-w32.c Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,75 @@ +/* Console functions for win32. + Copyright (C) 1996 Ben Wing. + +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. */ + +/* Authorship: + + Ben Wing: January 1996, for 19.14. + Rewritten for win32 by Jonathan Harris, November 1997 for 20.4. + */ + +#include <config.h> +#include "lisp.h" + +#include "console-w32.h" + +DEFINE_CONSOLE_TYPE (w32); + + +static int +w32_initially_selected_for_input (struct console *con) +{ + return 1; +} + + + + +/************************************************************************/ +/* initialization */ +/************************************************************************/ + +void +syms_of_console_w32 (void) +{ +} + +void +console_type_create_w32 (void) +{ + INITIALIZE_CONSOLE_TYPE (w32, "w32", "console-w32-p"); + + /* console methods */ +/* CONSOLE_HAS_METHOD (w32, init_console); */ +/* CONSOLE_HAS_METHOD (w32, mark_console); */ + CONSOLE_HAS_METHOD (w32, initially_selected_for_input); +/* CONSOLE_HAS_METHOD (w32, delete_console); */ +/* CONSOLE_HAS_METHOD (w32, canonicalize_console_connection); */ +/* CONSOLE_HAS_METHOD (w32, canonicalize_device_connection); */ +/* CONSOLE_HAS_METHOD (w32, semi_canonicalize_console_connection); */ +/* CONSOLE_HAS_METHOD (w32, semi_canonicalize_device_connection); */ +} + +void +vars_of_console_w32 (void) +{ + Fprovide (Qw32); +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/console-w32.h Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,87 @@ +/* Define win32 specific console, device, and frame object for XEmacs. + Copyright (C) 1989, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. + Copyright (C) 1994, 1995 Board of Trustees, University of Illinois. + +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. */ + + +/* Authorship: + + Ultimately based on FSF, then later on JWZ work for Lemacs. + Rewritten over time by Ben Wing and Chuck Thompson. + Rewritten for win32 by Jonathan Harris, November 1997 for 20.4. + */ + +#ifndef _XEMACS_CONSOLE_W32_H_ +#define _XEMACS_CONSOLE_W32_H_ + +#include "console.h" + +#include "windows.h" + +DECLARE_CONSOLE_TYPE (w32); + +struct w32_console +{ + int infd, outfd; +}; + + +struct w32_device +{ + int logpixelsx, logpixelsy; + int planes, cells; + int horzres, vertres; /* Size in pixels */ + int horzsize, vertsize; /* Size in mm */ +}; + +#define DEVICE_W32_DATA(d) DEVICE_TYPE_DATA (d, w32) +#define DEVICE_W32_LOGPIXELSX(d) (DEVICE_W32_DATA (d)->logpixelsx) +#define DEVICE_W32_LOGPIXELSY(d) (DEVICE_W32_DATA (d)->logpixelsy) +#define DEVICE_W32_PLANES(d) (DEVICE_W32_DATA (d)->planes) +#define DEVICE_W32_CELLS(d) (DEVICE_W32_DATA (d)->cells) +#define DEVICE_W32_HORZRES(d) (DEVICE_W32_DATA (d)->horzres) +#define DEVICE_W32_VERTRES(d) (DEVICE_W32_DATA (d)->vertres) +#define DEVICE_W32_HORZSIZE(d) (DEVICE_W32_DATA (d)->horzsize) +#define DEVICE_W32_VERTSIZE(d) (DEVICE_W32_DATA (d)->vertsize) + + +struct w32_frame +{ + /* win32 window handle */ + HWND hwnd; + + /* DC for this win32 window */ + HDC hdc; +}; + +#define FRAME_W32_DATA(f) FRAME_TYPE_DATA (f, w32) + +#define FRAME_W32_HANDLE(f) (FRAME_W32_DATA (f)->hwnd) +#define FRAME_W32_DC(f) (FRAME_W32_DATA (f)->hdc) + + +/* + * Redisplay functions + */ +void w32_redraw_exposed_area (struct frame *f, int x, int y, + int width, int height); + +#endif /* _XEMACS_CONSOLE_W32_H_ */
--- a/src/console.h Mon Aug 13 10:03:54 2007 +0200 +++ b/src/console.h Mon Aug 13 10:04:58 2007 +0200 @@ -439,6 +439,11 @@ #else #define CONSOLE_TYPESYM_TTY_P(typesym) 0 #endif +#ifdef HAVE_W32GUI +#define CONSOLE_TYPESYM_W32_P(typesym) EQ (typesym, Qw32) +#else +#define CONSOLE_TYPESYM_W32_P(typesym) 0 +#endif #define CONSOLE_TYPESYM_STREAM_P(typesym) EQ (typesym, Qstream) #define CONSOLE_TYPESYM_WIN_P(typesym) \ @@ -452,6 +457,10 @@ #define CHECK_TTY_CONSOLE(z) CHECK_CONSOLE_TYPE (z, tty) #define CONCHECK_TTY_CONSOLE(z) CONCHECK_CONSOLE_TYPE (z, tty) +#define CONSOLE_W32_P(con) CONSOLE_TYPESYM_W32_P (CONSOLE_TYPE (con)) +#define CHECK_W32_CONSOLE(z) CHECK_CONSOLE_TYPE (z, w32) +#define CONCHECK_W32_CONSOLE(z) CONCHECK_CONSOLE_TYPE (z, w32) + #define CONSOLE_STREAM_P(con) CONSOLE_TYPESYM_STREAM_P (CONSOLE_TYPE (con)) #define CHECK_STREAM_CONSOLE(z) CHECK_CONSOLE_TYPE (z, stream) #define CONCHECK_STREAM_CONSOLE(z) CONCHECK_CONSOLE_TYPE (z, stream) @@ -492,6 +501,9 @@ #ifdef HAVE_X_WINDOWS extern Lisp_Object Qx; #endif /* HAVE_X_WINDOWS */ +#ifdef HAVE_W32GUI +extern Lisp_Object Qw32; +#endif /* HAVE_W32GUI */ int valid_console_type_p (Lisp_Object type);
--- a/src/data.c Mon Aug 13 10:03:54 2007 +0200 +++ b/src/data.c Mon Aug 13 10:04:58 2007 +0200 @@ -382,6 +382,19 @@ return make_int (nargs); } +DEFUN ("subr-interactive", Fsubr_interactive, 1, 1, 0, /* +Return the interactive spec of the subr 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. +*/ + (subr)) +{ + CONST char *prompt; + CHECK_SUBR (subr); + prompt = XSUBR (subr)->prompt; + return prompt ? list2 (Qinteractive, build_string (prompt)) : Qnil; +} + DEFUN ("compiled-function-p", Fcompiled_function_p, 1, 1, 0, /* t if OBJECT is a byte-compiled function object. */ @@ -2303,6 +2316,7 @@ DEFSUBR (Fsubrp); DEFSUBR (Fsubr_min_args); DEFSUBR (Fsubr_max_args); + DEFSUBR (Fsubr_interactive); DEFSUBR (Fcompiled_function_p); DEFSUBR (Ftype_of); DEFSUBR (Fcar);
--- a/src/database.c Mon Aug 13 10:03:54 2007 +0200 +++ b/src/database.c Mon Aug 13 10:04:58 2007 +0200 @@ -112,6 +112,7 @@ #define DATABASEP(x) RECORDP (x, database) #define GC_DATABASEP(x) GC_RECORDP (x, database) #define CHECK_DATABASE(x) CHECK_RECORD (x, database) +#define CONCHECK_DATABASE(x) CONCHECK_RECORD (x, database) #define DATABASE_LIVE_P(x) (x->live_p) static Lisp_Object mark_database (Lisp_Object, void (*) (Lisp_Object)); static void print_database (Lisp_Object, Lisp_Object, int); @@ -129,7 +130,7 @@ static struct database * -new_database (void) +allocate_database (void) { struct database *dbase = alloc_lcrecord_type (struct database, lrecord_database); @@ -164,25 +165,22 @@ static void print_database (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) { + char buf[64]; struct database *dbase = XDATABASE (obj); - char buf[200]; if (print_readably) - { - error ("printing unreadable object #<database 0x%x>", dbase->header.uid); - } - else - { - sprintf (buf, "#<database \"%s\" (%s/%s/%s) 0x%x>", - XSTRING_DATA (dbase->fname), - dbase->funcs->get_type (dbase), - dbase->funcs->get_subtype (dbase), - (!DATABASE_LIVE_P (dbase) ? "closed" : - (dbase->access_ & O_WRONLY) ? "writeonly" : - (dbase->access_ & O_RDWR) ? "readwrite" : "readonly"), - dbase->header.uid); - write_c_string (buf, printcharfun); - } + error ("printing unreadable object #<database 0x%x>", dbase->header.uid); + + write_c_string ("#<database \"", printcharfun); + print_internal (dbase->fname, printcharfun, 0); + sprintf (buf, "\" (%s/%s/%s) 0x%x>", + dbase->funcs->get_type (dbase), + dbase->funcs->get_subtype (dbase), + (!DATABASE_LIVE_P (dbase) ? "closed" : + (dbase->access_ & O_WRONLY) ? "writeonly" : + (dbase->access_ & O_RDWR) ? "readwrite" : "readonly"), + dbase->header.uid); + write_c_string (buf, printcharfun); } static void @@ -638,7 +636,7 @@ if (!dbm) return Qnil; - dbase = new_database (); + dbase = allocate_database (); dbase->dbm_handle = dbm; dbase->type = DB_DBM; dbase->funcs = &ndbm_func_block; @@ -691,7 +689,7 @@ return Qnil; #endif /* DB_VERSION_MAJOR */ - dbase = new_database (); + dbase = allocate_database (); dbase->db_handle = db; dbase->type = DB_BERKELEY; dbase->funcs = &berk_func_block;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/device-w32.c Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,155 @@ +/* Device functions for win32. + Copyright (C) 1994, 1995 Board of Trustees, University of Illinois. + Copyright (C) 1994, 1995 Free Software Foundation, Inc. + +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. */ + +/* Authorship: + + Original authors: Jamie Zawinski and the FSF + Rewritten by Ben Wing and Chuck Thompson. + Rewritten for win32 by Jonathan Harris, November 1997 for 20.4. +*/ + + +#include <config.h> +#include "lisp.h" + +#include "console-w32.h" +#include "console-stream.h" +#include "events.h" +#include "event-w32.h" +#include "faces.h" +#include "frame.h" + +Lisp_Object Qinit_pre_w32_win, Qinit_post_w32_win; + +DWORD w32_main_thread_id; +DWORD w32_win_thread_id; + +static void +w32_init_device (struct device *d, Lisp_Object props) +{ + struct console *con = XCONSOLE (DEVICE_CONSOLE (d)); + HWND desktop; + HDC hdc; + MSG msg; + HANDLE handle; + + /* Ensure our message queue is created */ + PeekMessage (&msg, NULL, 0, 0, PM_NOREMOVE); + + w32_main_thread_id = GetCurrentThreadId (); +#if 0 + DuplicateHandle (GetCurrentProcess (), GetCurrentThread (), + GetCurrentProcess (), &hMainThread, 0, TRUE, DUPLICATE_SAME_ACCESS); +#endif + handle = CreateThread (NULL, 0, + (LPTHREAD_START_ROUTINE) w32_win_thread, + 0, 0, &w32_win_thread_id); + AttachThreadInput (w32_main_thread_id, w32_win_thread_id, TRUE); + + d->device_data = xnew_and_zero (struct w32_device); + + desktop = GetDesktopWindow(); + hdc = GetDC(desktop); + DEVICE_W32_LOGPIXELSX(d) = GetDeviceCaps(hdc, LOGPIXELSX); + DEVICE_W32_LOGPIXELSY(d) = GetDeviceCaps(hdc, LOGPIXELSY); + DEVICE_W32_PLANES(d) = GetDeviceCaps(hdc, PLANES); + /* FIXME: Only valid if RC_PALETTE bit set in RASTERCAPS, + what should we return for a non-palette-based device? */ + DEVICE_W32_CELLS(d) = GetDeviceCaps(hdc, SIZEPALETTE); + DEVICE_W32_HORZRES(d) = GetDeviceCaps(hdc, HORZRES); + DEVICE_W32_VERTRES(d) = GetDeviceCaps(hdc, VERTRES); + DEVICE_W32_HORZSIZE(d) = GetDeviceCaps(hdc, HORZSIZE); + DEVICE_W32_VERTSIZE(d) = GetDeviceCaps(hdc, VERTSIZE); + ReleaseDC(desktop, hdc); + + /* Wait for windows thread to be ready */ + GetMessage (&msg, NULL, WM_XEMACS_ACK, WM_XEMACS_ACK); +} + +static int +w32_device_pixel_width (struct device *d) +{ + return(DEVICE_W32_HORZRES(d)); +} + +static int +w32_device_pixel_height (struct device *d) +{ + return(DEVICE_W32_VERTRES(d)); +} + +static int +w32_device_mm_width (struct device *d) +{ + return(DEVICE_W32_HORZSIZE(d)); +} + +static int +w32_device_mm_height (struct device *d) +{ + return(DEVICE_W32_VERTSIZE(d)); +} + +static int +w32_device_bitplanes (struct device *d) +{ + return(DEVICE_W32_PLANES(d)); +} + +static int +w32_device_color_cells (struct device *d) +{ + return(DEVICE_W32_CELLS(d)); +} + + +/************************************************************************/ +/* initialization */ +/************************************************************************/ + +void +syms_of_device_w32 (void) +{ + defsymbol (&Qinit_pre_w32_win, "init-pre-w32-win"); + defsymbol (&Qinit_post_w32_win, "init-post-w32-win"); +} + +void +console_type_create_device_w32 (void) +{ + CONSOLE_HAS_METHOD (w32, init_device); +/* CONSOLE_HAS_METHOD (w32, finish_init_device); */ +/* CONSOLE_HAS_METHOD (w32, mark_device); */ +/* CONSOLE_HAS_METHOD (w32, delete_device); */ + CONSOLE_HAS_METHOD (w32, device_pixel_width); + CONSOLE_HAS_METHOD (w32, device_pixel_height); + CONSOLE_HAS_METHOD (w32, device_mm_width); + CONSOLE_HAS_METHOD (w32, device_mm_height); + CONSOLE_HAS_METHOD (w32, device_bitplanes); + CONSOLE_HAS_METHOD (w32, device_color_cells); +} + +void +vars_of_device_w32 (void) +{ +}
--- a/src/device-x.c Mon Aug 13 10:03:54 2007 +0200 +++ b/src/device-x.c Mon Aug 13 10:04:58 2007 +0200 @@ -262,7 +262,7 @@ Vdefault_x_device = device; #ifdef MULE -#if defined(LWLIB_MENUBARS_MOTIF) || defined(USE_XFONTSET) +#if defined(LWLIB_MENUBARS_MOTIF) || defined(HAVE_XIM) || defined (USE_XFONTSET) { /* Read in locale-specific resources from data-directory/app-defaults/$LANG/emacs-application-class. @@ -281,7 +281,7 @@ XrmCombineFileDatabase (path, &db, False); } } -#endif /* LWLIB_MENUBARS_MOTIF or USE_XFONTSET */ +#endif /* LWLIB_MENUBARS_MOTIF or HAVE_XIM USE_XFONTSET */ #endif /* MULE */ if (NILP (DEVICE_NAME (d)))
--- a/src/dired.c Mon Aug 13 10:03:54 2007 +0200 +++ b/src/dired.c Mon Aug 13 10:04:58 2007 +0200 @@ -40,7 +40,7 @@ Lisp_Object Qfile_attributes; static Lisp_Object -close_directory_fd (Lisp_Object unwind_obj) +close_directory_unwind (Lisp_Object unwind_obj) { DIR *d = (DIR *)get_opaque_ptr (unwind_obj); closedir (d); @@ -124,7 +124,7 @@ if (! d) report_file_error ("Opening directory", list1 (dirname)); - record_unwind_protect (close_directory_fd, make_opaque_ptr ((void *)d)); + record_unwind_protect (close_directory_unwind, make_opaque_ptr ((void *)d)); list = Qnil; @@ -151,9 +151,10 @@ char *cur_statbuf_tail = statbuf_tail; /* A trick: we normally use the buffer created by - alloca. However, if the filename is too big - (meaning MAXNAMLEN lies on the system), we'll use - a malloced buffer, and free it. */ + alloca. However, if the filename is too big + (meaning MAXNAMLEN is wrong or useless on the + system), we'll use a malloced buffer, and free + it. */ if (len > MAXNAMLEN) { cur_statbuf = (char *) xmalloc (name_as_dir_length @@ -180,9 +181,11 @@ if (!NILP (full)) name = concat2 (name_as_dir, - make_string ((Bufbyte *)dp->d_name, len)); + make_ext_string ((Bufbyte *)dp->d_name, + len, FORMAT_BINARY)); else - name = make_string ((Bufbyte *)dp->d_name, len); + name = make_ext_string ((Bufbyte *)dp->d_name, + len, FORMAT_BINARY); list = Fcons (name, list); } @@ -269,10 +272,8 @@ char *fullname = (char *) alloca (len + pos + 2); memcpy (fullname, XSTRING_DATA (dirname), pos); -#ifndef VMS if (!IS_DIRECTORY_SEP (fullname[pos - 1])) fullname[pos++] = DIRECTORY_SEP; -#endif memcpy (fullname + pos, dp->d_name, len); fullname[pos + len] = 0; @@ -310,6 +311,7 @@ CHECK_STRING (file); +/* #### The following is valid not only for VMS, but for NT too. */ #ifdef VMS /* Filename completion on VMS ignores case, since VMS filesys does. */ specbind (Qcompletion_ignore_case, Qt); @@ -524,57 +526,14 @@ { len = NAMLEN (dp); if (DIRENTRY_NONEMPTY (dp)) - Fputhash (make_string ((Bufbyte *) dp->d_name, len), Qt, hash); + Fputhash (make_ext_string ((Bufbyte *) dp->d_name, len, + FORMAT_BINARY), Qt, hash); } closedir (d); } return hash; } -#ifdef VMS - -DEFUN ("file-name-all-versions", Ffile_name_all_versions, 2, 2, 0, /* -Return a list of all versions of file name FILE in directory DIR. -*/ - (file, dirname)) -{ - /* This function can GC */ - return file_name_completion (file, dirname, 1, 1); -} - -DEFUN ("file-version-limit", Ffile_version_limit, 1, 1, 0, /* -Return the maximum number of versions allowed for FILE. -Returns nil if the file cannot be opened or if there is no version limit. -*/ - (filename)) -{ - /* This function can GC */ - Lisp_Object retval; - struct FAB fab; - struct RAB rab; - struct XABFHC xabfhc; - int status; - - filename = Fexpand_file_name (filename, Qnil); - CHECK_STRING (filename); - fab = cc$rms_fab; - xabfhc = cc$rms_xabfhc; - fab.fab$l_fna = XSTRING_DATA (filename); - fab.fab$b_fns = strlen (fab.fab$l_fna); - fab.fab$l_xab = (char *) &xabfhc; - status = sys$open (&fab, 0, 0); - if (status != RMS$_NORMAL) /* Probably non-existent file */ - return Qnil; - sys$close (&fab, 0, 0); - if (xabfhc.xab$w_verlimit == 32767) - return Qnil; /* No version limit */ - else - return make_int (xabfhc.xab$w_verlimit); -} - -#endif /* VMS */ - - Lisp_Object wasteful_word_to_lisp (unsigned int item) { @@ -713,10 +672,6 @@ DEFSUBR (Fdirectory_files); DEFSUBR (Ffile_name_completion); -#ifdef VMS - DEFSUBR (Ffile_name_all_versions); - DEFSUBR (Ffile_version_limit); -#endif /* VMS */ DEFSUBR (Ffile_name_all_completions); DEFSUBR (Ffile_attributes); }
--- a/src/doc.c Mon Aug 13 10:03:54 2007 +0200 +++ b/src/doc.c Mon Aug 13 10:04:58 2007 +0200 @@ -362,10 +362,13 @@ (sym, prop, raw)) { /* This function can GC */ - REGISTER Lisp_Object doc; + REGISTER Lisp_Object doc = Qnil; #ifdef I18N3 REGISTER Lisp_Object domain; #endif + struct gcpro gcpro1; + + GCPRO1 (doc); doc = Fget (sym, prop, Qnil); if (INTP (doc)) @@ -384,6 +387,7 @@ #endif if (NILP (raw) && STRINGP (doc)) doc = Fsubstitute_command_keys (doc); + UNGCPRO; return doc; } @@ -785,7 +789,7 @@ #endif strlength = XSTRING_LENGTH (str); - bsize = strlength; + bsize = 1 + strlength; buf = (Bufbyte *) xmalloc (bsize); bufp = buf;
--- a/src/emacs.c Mon Aug 13 10:03:54 2007 +0200 +++ b/src/emacs.c Mon Aug 13 10:04:58 2007 +0200 @@ -697,6 +697,10 @@ display_use = "x"; #endif /* HAVE_X_WINDOWS */ +#ifdef HAVE_W32GUI + if (!noninteractive) + display_use = "w32"; +#endif /* HAVE_W32GUI */ } #endif /* HAVE_WINDOW_SYSTEM */ @@ -875,6 +879,14 @@ #endif #endif /* HAVE_X_WINDOWS */ +#ifdef HAVE_W32GUI + syms_of_console_w32 (); + syms_of_device_w32 (); + syms_of_event_w32 (); + syms_of_frame_w32 (); + syms_of_objects_w32 (); +#endif + #ifdef MULE syms_of_mule (); syms_of_mule_ccl (); @@ -962,6 +974,14 @@ #endif #endif /* HAVE_X_WINDOWS */ +#ifdef HAVE_W32GUI + console_type_create_w32 (); + console_type_create_device_w32 (); + console_type_create_frame_w32 (); + console_type_create_objects_w32 (); + console_type_create_redisplay_w32 (); +#endif + /* Now initialize the specifier types and associated symbols. Other than the first function below, the functions may make exactly the following function/macro calls: @@ -1190,6 +1210,14 @@ #endif #endif +#ifdef HAVE_W32GUI + vars_of_device_w32 (); + vars_of_console_w32 (); + vars_of_event_w32 (); + vars_of_frame_w32 (); + vars_of_objects_w32 (); +#endif + #ifdef MULE vars_of_mule (); vars_of_mule_charset ();
--- a/src/event-stream.c Mon Aug 13 10:03:54 2007 +0200 +++ b/src/event-stream.c Mon Aug 13 10:04:58 2007 +0200 @@ -2264,7 +2264,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 equivalent to the lisp code +function is provided as a convenience; it is rougly equivalent to the lisp code (while (progn (next-event event prompt) @@ -2274,6 +2274,7 @@ (misc-user-event-p event)))) (dispatch-event event)) +but it also makes a provision for displaying keystrokes in the echo area. */ (event, prompt)) { @@ -4872,10 +4873,12 @@ #ifdef HAVE_X_WINDOWS vars_of_event_Xt (); #endif -#if defined (DEBUG_TTY_EVENT_STREAM) || !defined (HAVE_X_WINDOWS) +#if defined(HAVE_TTY) && (defined (DEBUG_TTY_EVENT_STREAM) || !defined (HAVE_X_WINDOWS)) vars_of_event_tty (); #endif - +#ifdef HAVE_W32GUI + vars_of_event_w32 (); +#endif recent_keys_ring_index = 0; recent_keys_ring_size = 100; @@ -5278,14 +5281,20 @@ if (!strcmp (display_use, "x")) init_event_Xt_late (); else +#elif defined(HAVE_W32GUI) + if (!strcmp (display_use, "w32")) + init_event_w32_late (); + else #endif { /* For TTY's, use the Xt event loop if we can; it allows us to later open an X connection. */ #if defined (HAVE_X_WINDOWS) && !defined (DEBUG_TTY_EVENT_STREAM) init_event_Xt_late (); -#else +#elif defined (HAVE_TTY) init_event_tty_late (); +#elif defined(HAVE_W32GUI) + init_event_w32_late (); #endif } init_interrupts_late ();
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/event-w32.c Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,423 @@ +/* The event_stream interface win32. + Copyright (C) 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. + Copyright (C) 1995 Sun Microsystems, Inc. + Copyright (C) 1996 Ben Wing. + Copyright (C) 1997 Jonathan Harris. + +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. */ + +/* Authorship: + + Ultimately based on FSF. + Rewritten by Ben Wing. + Rewritten for win32 by Jonathan Harris, November 1997 for 20.4. + */ + +#include <config.h> +#include "lisp.h" + +#include "device.h" +#include "console-w32.h" +#include "events.h" +#include "frame.h" +#include "process.h" + +#include "sysproc.h" +#include "syswait.h" +#include "systime.h" + +#include "event-w32.h" + +static struct event_stream *w32_event_stream; +static Lisp_Object w32_dispatch_event_queue, w32_dispatch_event_queue_tail; +static w32_waitable_count=0; +CRITICAL_SECTION w32_dispatch_crit; + +static Lisp_Object w32_dequeue_dispatch_event (void); + +/* + * List of win32 waitable handles. + * Apart from the dispatch queue semaphore, all of these handles may be waited + * on multiple times in emacs_w32_next_event before being processed and so must + * be manual-reset events. + */ +static HANDLE w32_waitable[MAX_WAITABLE]; + +/* random emacs info associated with each of the wait handles */ +static w32_waitable_info_type w32_waitable_info[MAX_WAITABLE]; + +void +w32_enqueue_dispatch_event (Lisp_Object event) +{ + assert(w32_waitable_count); +// EnterCriticalSection (&w32_dispatch_crit); + enqueue_event (event, &w32_dispatch_event_queue, &w32_dispatch_event_queue_tail); + ReleaseSemaphore(w32_waitable[0], 1, NULL); +// LeaveCriticalSection (&w32_dispatch_crit); +} + +static Lisp_Object +w32_dequeue_dispatch_event (void) +{ + Lisp_Object event; + assert(w32_waitable_count); +// EnterCriticalSection (&w32_dispatch_crit); + event = dequeue_event (&w32_dispatch_event_queue, &w32_dispatch_event_queue_tail); +// LeaveCriticalSection (&w32_dispatch_crit); + return event; +} + +/* + * Find a free waitable slot + */ +static int +w32_find_free_waitable(void) +{ + int i; + for (i=0; i<w32_waitable_count; i++) + if (w32_waitable_info[i].type == w32_waitable_type_none) + return i; + assert (w32_waitable_count < MAX_WAITABLE); + return w32_waitable_count++; +} + +/* + * Create a new waitable using the type and data passed in by the info structure + * Returns a pointer to the info associated with the assigned waitable object + */ +w32_waitable_info_type * +w32_add_waitable(w32_waitable_info_type *info) +{ + int waitable; + + switch (info->type) + { + case w32_waitable_type_dispatch: + /* Can only have one waitable for the dispatch queue, and it's the first one */ + assert (w32_waitable_count++ == 0); + waitable=0; + InitializeCriticalSection(&w32_dispatch_crit); + assert (w32_waitable[0] = CreateSemaphore (NULL, 0, 0x7fffffff, NULL)); + return w32_waitable_info+0; + +#if 0 /* Windows95 doesn't support WaitableTimers */ + case w32_waitable_type_timeout: + { + LARGE_INTEGER due; + due.QuadPart = 10000 * (LONGLONG) info->data.timeout.milliseconds; + waitable = w32_find_free_waitable(); + w32_waitable[waitable] = CreateWaitableTimer(NULL, TRUE, NULL); + SetWaitableTimer(w32_waitable[waitable], &due, 0, NULL, NULL, FALSE); + w32_waitable_info[waitable].data.timeout.id = waitable; + } + break; +#endif + + default: + assert(0); + } + w32_waitable_info[waitable].type = info->type; + return w32_waitable_info+waitable; +} + +/* + * Remove a waitable using the type and data passed in by the info structure. + */ +void +w32_remove_waitable(w32_waitable_info_type *info) +{ + int waitable; + + switch (info->type) + { +#if 0 + case w32_waitable_type_timeout: + waitable = info->data.timeout.id; + CancelWaitableTimeout(w32_waitable[waitable]); + break; +#endif + + default: + assert(0); + } + + CloseHandle(w32_waitable[waitable]); + w32_waitable[waitable] = 0; + w32_waitable_info[waitable].type = w32_waitable_type_none; + if (waitable == w32_waitable_count-1) + --w32_waitable_count; +} + + +/************************************************************************/ +/* methods */ +/************************************************************************/ + +static int +emacs_w32_add_timeout (EMACS_TIME thyme) +{ + EMACS_TIME current_time; + int milliseconds; + int id; + w32_request_type request; + + EMACS_GET_TIME (current_time); + EMACS_SUB_TIME (thyme, thyme, current_time); + milliseconds = EMACS_SECS (thyme) * 1000 + EMACS_USECS (thyme) / 1000; + if (milliseconds < 1) + milliseconds = 1; + request.thing1 = (void *) milliseconds; + id = w32_make_request(WM_XEMACS_SETTIMER, 0, &request); + assert(id); /* XXX */ + return id; +} + +static void +emacs_w32_remove_timeout (int id) +{ + w32_request_type request = { (void *) id }; + w32_make_request(WM_XEMACS_KILLTIMER, 0, &request); +} + +static int +emacs_w32_event_pending_p (int user_p) +{ + return 0; +} + +static struct console * +find_console_from_fd (int fd) +{ + return 0; +} + +/* + * Return the next event + * We return windows events off the dispatch event queue in preference to other events + */ +static void +emacs_w32_next_event (struct Lisp_Event *emacs_event) +{ + DWORD active; + active = WaitForMultipleObjects (w32_waitable_count, w32_waitable, + FALSE, INFINITE); + assert(active >= WAIT_OBJECT_0 && active <= WAIT_OBJECT_0 + w32_waitable_count - 1); + + /* Windows events on the dispatch event queue */ + if (active == WAIT_OBJECT_0) + { + /* XXX Copied from event-Xt.c */ + Lisp_Object event, event2; + + EnterCriticalSection (&w32_dispatch_crit); + XSETEVENT (event2, emacs_event); + event = w32_dequeue_dispatch_event (); + Fcopy_event (event, event2); + Fdeallocate_event (event); + LeaveCriticalSection (&w32_dispatch_crit); + } + else + { + /* XXX FIXME: We should do some kind of round-robin scheme to ensure fairness */ + int waitable = active - WAIT_OBJECT_0; + w32_waitable_info_type *info = w32_waitable_info + waitable; + + switch (info->type) + { + case w32_waitable_type_timeout: + emacs_event->channel = Qnil; + emacs_event->event_type = timeout_event; + emacs_event->event.timeout.interval_id = info->data.timeout.id; + w32_remove_waitable(info); + break; + + default: + assert(0); + } + } +} + +/* + * Handle a magic event off the dispatch queue. + * XXX split into seperate functions for clarity. + */ +static void +emacs_w32_handle_magic_event (struct Lisp_Event *emacs_event) +{ + RECT *rect = &EVENT_W32_MAGIC_DATA(emacs_event); + struct frame *f = XFRAME (EVENT_CHANNEL (emacs_event)); + Lisp_Object frame = Qnil; + XSETFRAME (frame, f); +#if 0 + stderr_out("magic %x, (%d,%d), (%d,%d)\n", + EVENT_W32_MAGIC_TYPE(emacs_event), + rect->left, rect->top, rect->right, rect->bottom); +#endif + switch (EVENT_W32_MAGIC_TYPE(emacs_event)) + { + case WM_SETFOCUS: + case WM_KILLFOCUS: + { + int in_p = (EVENT_W32_MAGIC_TYPE(emacs_event) == WM_SETFOCUS); + Lisp_Object conser; + /* struct gcpro gcpro1; */ + + /* Clear sticky modifiers here (if we had any) */ + + conser = Fcons (frame, Fcons (FRAME_DEVICE (f), in_p ? Qt : Qnil)); + /* GCPRO1 (conser); XXX Not necessary? */ + emacs_handle_focus_change_preliminary (conser); + /* Under X the stuff up to here is done in the X event handler. + I Don't know why */ + emacs_handle_focus_change_final (conser); + /* UNGCPRO; */ + } + break; + + /* XXX What about Enter & Leave */ +#if 0 + va_run_hook_with_args (in_p ? Qmouse_enter_frame_hook : + Qmouse_leave_frame_hook, 1, frame); + break; +#endif + + case WM_SIZE: + if ((rect->left & rect->top & rect->right & rect->bottom) == -1) + { + /* Iconified */ + FRAME_VISIBLE_P (f) = 0; + va_run_hook_with_args (Qunmap_frame_hook, 1, frame); + Fframe_iconified_p (frame); + } + else + { + /* If we're uniconified, our size may or may not have changed */ + int columns, rows; + int was_visible = FRAME_VISIBLE_P (f); + pixel_to_char_size (f, rect->right, rect->bottom, &columns, &rows); + + FRAME_VISIBLE_P (f) = 1; + if (f->height!=rows || f->width!=columns || f->size_change_pending) + { + /* Size changed */ + f->pixwidth = rect->right; + f->pixheight = rect->bottom; + change_frame_size (f, rows, columns, 0); +/* MARK_FRAME_WINDOWS_STRUCTURE_CHANGED (f); /* XXX Too extreme? */ + } + + if (!was_visible) + va_run_hook_with_args (Qmap_frame_hook, 1, frame); + + } + break; + + case WM_PAINT: + w32_redraw_exposed_area(f, rect->left, rect->top, + rect->right, rect->bottom); + break; + + default: + assert(0); + } +} + +static void +emacs_w32_select_process (struct Lisp_Process *process) +{ +} + +static void +emacs_w32_unselect_process (struct Lisp_Process *process) +{ +} + +static void +emacs_w32_select_console (struct console *con) +{ +} + +static void +emacs_w32_unselect_console (struct console *con) +{ +} + +static void +emacs_w32_quit_p (void) +{ +} + +/* This is called from GC when a process object is about to be freed. + If we've still got pointers to it in this file, we're gonna lose hard. + */ +void +debug_process_finalization (struct Lisp_Process *p) +{ +#if 0 /* #### */ + int i; + int infd, outfd; + get_process_file_descriptors (p, &infd, &outfd); + /* if it still has fds, then it hasn't been killed yet. */ + assert (infd < 0); + assert (outfd < 0); + /* Better not still be in the "with input" table; we know it's got no fds. */ + for (i = 0; i < MAXDESC; i++) + { + Lisp_Object process = filedesc_fds_with_input [i]; + assert (!PROCESSP (process) || XPROCESS (process) != p); + } +#endif +} + +/************************************************************************/ +/* initialization */ +/************************************************************************/ + +void +vars_of_event_w32 (void) +{ + w32_dispatch_event_queue = Qnil; + staticpro (&w32_dispatch_event_queue); + w32_dispatch_event_queue_tail = Qnil; + + w32_event_stream = xnew (struct event_stream); + + w32_event_stream->event_pending_p = emacs_w32_event_pending_p; + w32_event_stream->next_event_cb = emacs_w32_next_event; + w32_event_stream->handle_magic_event_cb = emacs_w32_handle_magic_event; + w32_event_stream->add_timeout_cb = emacs_w32_add_timeout; + w32_event_stream->remove_timeout_cb = emacs_w32_remove_timeout; + w32_event_stream->select_console_cb = emacs_w32_select_console; + w32_event_stream->unselect_console_cb = emacs_w32_unselect_console; + w32_event_stream->select_process_cb = emacs_w32_select_process; + w32_event_stream->unselect_process_cb = emacs_w32_unselect_process; + w32_event_stream->quit_p_cb = emacs_w32_quit_p; +} + +void +syms_of_event_w32 (void) +{ +} + +void +init_event_w32_late (void) +{ + event_stream = w32_event_stream; +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/event-w32.h Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,123 @@ +/* Win32 specific defines for event-handling. + Copyright (C) 1997 Jonathan Harris. + +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. */ + +/* Authorship: + + Jonathan Harris, November 1997 for 20.4. + */ + +#include <windows.h> + +/* + * XXX FIXME: The following X modifier defs in events-mod.h clash with win32 + * hotkey defs in winuser.h. For the moment lose the win32 versions. + * Maybe we should rename all of MOD_* to something that doesn't clash. + */ +#ifdef MOD_CONTROL +# undef MOD_CONTROL +#endif +#ifdef MOD_ALT +# undef MOD_ALT +#endif +#ifdef MOD_SHIFT +# undef MOD_SHIFT +#endif +#include "events-mod.h" + +/* The name of the main window class */ +#define XEMACS_CLASS "XEmacs" + +/* Random globals shared between main and message-processing thread */ +extern DWORD w32_main_thread_id; +extern DWORD w32_win_thread_id; +extern CRITICAL_SECTION w32_dispatch_crit; + + +/* + * Communication between main and windows thread + */ +#define WM_XEMACS_BASE (WM_APP + 0) +#define WM_XEMACS_ACK (WM_XEMACS_BASE + 0x00) +#define WM_XEMACS_CREATEWINDOW (WM_XEMACS_BASE + 0x01) +#define WM_XEMACS_SETTIMER (WM_XEMACS_BASE + 0x02) +#define WM_XEMACS_KILLTIMER (WM_XEMACS_BASE + 0x03) +#define WM_XEMACS_END (WM_XEMACS_BASE + 0x10) + +typedef struct w32_request_type +{ + void *thing1; + void *thing2; +} w32_request_type; + +LPARAM w32_make_request(UINT message, WPARAM wParam, w32_request_type *request); +void w32_handle_request(MSG *msg); + + +/* + * Event generating stuff + */ + +/* The number of things we can wait on */ +#define MAX_WAITABLE 256 + +typedef enum w32_waitable_type +{ + w32_waitable_type_none, + w32_waitable_type_dispatch, + w32_waitable_type_timeout, + w32_waitable_type_process, + w32_waitable_type_socket +} w32_waitable_type; + +typedef struct w32_timeout_data +{ + int milliseconds; + int id; +} w32_timeout_data; + +typedef struct w32_waitable_info_type +{ + w32_waitable_type type; + union + { + w32_timeout_data timeout; + } data; +} w32_waitable_info_type; + +w32_waitable_info_type *w32_add_waitable(w32_waitable_info_type *info); +void w32_remove_waitable(w32_waitable_info_type *info); + +/* + * Some random function declarations in w32-proc.c + */ +DWORD w32_win_thread(); +extern void w32_enqeue_dispatch_event (Lisp_Object event); + + +/* + * Inside w32 magic events + */ +#define EVENT_W32_MAGIC_EVENT(e) ((e)->event.magic.underlying_w32_event) +#define EVENT_W32_MAGIC_TYPE(e) (EVENT_W32_MAGIC_EVENT(e).message) +#define EVENT_W32_MAGIC_DATA(e) \ + (*((RECT *) (&(EVENT_W32_MAGIC_EVENT(e).data)))) +
--- a/src/events-mod.h Mon Aug 13 10:03:54 2007 +0200 +++ b/src/events-mod.h Mon Aug 13 10:04:58 2007 +0200 @@ -1,10 +1,5 @@ -/* These need to be split up as other windowing systems have different - values for these things. Don't really know how to handle this yet. - kludge. kludge. kludge. -*/ +/* The modifiers XEmacs knows about; these appear in key and button events. */ -/* The modifiers XEmacs knows about; these appear in key and button events. - */ #define MOD_CONTROL (1<<0) #define MOD_META (1<<1) #define MOD_SUPER (1<<2)
--- a/src/events.c Mon Aug 13 10:03:54 2007 +0200 +++ b/src/events.c Mon Aug 13 10:04:58 2007 +0200 @@ -298,6 +298,12 @@ return (e1->event.magic.underlying_tty_event == e2->event.magic.underlying_tty_event); #endif +#ifdef HAVE_W32GUI + if (CONSOLE_W32_P (con)) + return (!memcmp(&e1->event.magic.underlying_w32_event, + &e2->event.magic.underlying_w32_event, + sizeof(union magic_data))); +#endif return 1; /* not reached */ } @@ -365,6 +371,15 @@ if (CONSOLE_TTY_P (con)) return HASH2 (hash, e->event.magic.underlying_tty_event); #endif +#ifdef HAVE_W32GUI + if (CONSOLE_W32_P (con)) + return HASH6 (hash, e->event.magic.underlying_w32_event.message, + e->event.magic.underlying_w32_event.data[0], + e->event.magic.underlying_w32_event.data[1], + e->event.magic.underlying_w32_event.data[2], + e->event.magic.underlying_w32_event.data[3], + ); +#endif } case empty_event: @@ -1789,10 +1804,11 @@ (event)) { Charcount mbufp; + int where; - event_pixel_translation (event, 0, 0, 0, 0, 0, 0, 0, &mbufp, 0, 0); + where = event_pixel_translation (event, 0, 0, 0, 0, 0, 0, 0, &mbufp, 0, 0); - return mbufp < 0 ? Qnil : make_int (mbufp); + return (mbufp < 0 || where != OVER_MODELINE) ? Qnil : make_int (mbufp); } DEFUN ("event-glyph", Fevent_glyph, 1, 1, 0, /*
--- a/src/events.h Mon Aug 13 10:03:54 2007 +0200 +++ b/src/events.h Mon Aug 13 10:04:58 2007 +0200 @@ -371,9 +371,18 @@ union magic_data { - char underlying_tty_event; +#ifdef HAVE_TTY + char underlying_tty_event; +#endif #ifdef HAVE_X_WINDOWS - XEvent underlying_x_event; + XEvent underlying_x_event; +#endif +#ifdef HAVE_W32GUI /* XXX FIXME */ + struct + { + int message; + unsigned long data[4]; /* XXX Big enough for biggest thing? */ + } underlying_w32_event; #endif };
--- a/src/faces.c Mon Aug 13 10:03:54 2007 +0200 +++ b/src/faces.c Mon Aug 13 10:04:58 2007 +0200 @@ -1916,6 +1916,12 @@ bg_inst_list = Fcons (Fcons (list1 (Qtty), Fvector (0, 0)), bg_inst_list); #endif +#ifdef HAVE_W32GUI + fg_inst_list = Fcons (Fcons (list1 (Qw32), build_string ("black")), + fg_inst_list); + bg_inst_list = Fcons (Fcons (list1 (Qw32), build_string ("white")), + bg_inst_list); +#endif set_specifier_fallback (Fget (Vdefault_face, Qforeground, Qnil), fg_inst_list); set_specifier_fallback (Fget (Vdefault_face, Qbackground, Qnil), @@ -1960,6 +1966,10 @@ inst_list = Fcons (Fcons (list1 (Qtty), build_string ("normal")), inst_list); #endif /* HAVE_TTY */ +#ifdef HAVE_W32GUI + inst_list = Fcons (Fcons (list1 (Qw32), build_string ("Courier New")), + inst_list); +#endif /* HAVE_W32GUI */ set_specifier_fallback (Fget (Vdefault_face, Qfont, Qnil), inst_list); }
--- a/src/fileio.c Mon Aug 13 10:03:54 2007 +0200 +++ b/src/fileio.c Mon Aug 13 10:04:58 2007 +0200 @@ -82,10 +82,6 @@ /* File name in which we write a list of all our auto save files. */ Lisp_Object Vauto_save_list_file_name; -/* On VMS, nonzero means write new files with record format stmlf. - Zero means use var format. */ -int vms_stmlf_recfm; - int disable_auto_save_when_buffer_shrinks; Lisp_Object Qfile_name_handler_alist; @@ -396,8 +392,7 @@ Return the directory component in file name NAME. Return nil if NAME does not include a directory. Otherwise return a directory spec. -Given a Unix syntax file name, returns a string ending in slash; -on VMS, perhaps instead a string ending in `:', `]' or `>'. +Given a Unix syntax file name, returns a string ending in slash. */ (file)) { @@ -420,11 +415,8 @@ beg = XSTRING_DATA (file); p = beg + XSTRING_LENGTH (file); - while (p != beg && !IS_ANY_SEP (p[-1]) -#ifdef VMS - && p[-1] != ':' && p[-1] != ']' && p[-1] != '>' -#endif /* VMS */ - ) p--; + while (p != beg && !IS_ANY_SEP (p[-1])) + p--; if (p == beg) return Qnil; @@ -483,11 +475,8 @@ beg = XSTRING_DATA (file); end = p = beg + XSTRING_LENGTH (file); - while (p != beg && !IS_ANY_SEP (p[-1]) -#ifdef VMS - && p[-1] != ':' && p[-1] != ']' && p[-1] != '>' -#endif /* VMS */ - ) p--; + while (p != beg && !IS_ANY_SEP (p[-1])) + p--; return make_string (p, end - p); } @@ -524,71 +513,12 @@ strcpy (out, in); -#ifdef VMS - /* Is it already a directory string? */ - if (in[size] == ':' || in[size] == ']' || in[size] == '>') - return out; - /* Is it a VMS directory file name? If so, hack VMS syntax. */ - else if (! strchr (in, '/') - && ((size > 3 && ! strcmp (&in[size - 3], ".DIR")) - || (size > 3 && ! strcmp (&in[size - 3], ".dir")) - || (size > 5 && (! strncmp (&in[size - 5], ".DIR", 4) - || ! strncmp (&in[size - 5], ".dir", 4)) - && (in[size - 1] == '.' || in[size - 1] == ';') - && in[size] == '1'))) - { - char *p, *dot; - char brack; - - /* x.dir -> [.x] - dir:x.dir --> dir:[x] - dir:[x]y.dir --> dir:[x.y] */ - p = in + size; - while (p != in && *p != ':' && *p != '>' && *p != ']') p--; - if (p != in) - { - strncpy (out, in, p - in); - out[p - in] = '\0'; - if (*p == ':') - { - brack = ']'; - strcat (out, ":["); - } - else - { - brack = *p; - strcat (out, "."); - } - p++; - } - else - { - brack = ']'; - strcpy (out, "[."); - } - dot = strchr (p, '.'); - if (dot) - { - /* blindly remove any extension */ - size = strlen (out) + (dot - p); - strncat (out, p, dot - p); - } - else - { - strcat (out, p); - size = strlen (out); - } - out[size++] = brack; - out[size] = '\0'; - } -#else /* not VMS */ /* For Unix syntax, Append a slash if necessary */ if (!IS_ANY_SEP (out[size])) { out[size + 1] = DIRECTORY_SEP; out[size + 2] = '\0'; } -#endif /* not VMS */ return out; } @@ -599,7 +529,6 @@ The result can be used as the value of `default-directory' or passed as second argument to `expand-file-name'. For a Unix-syntax file name, just appends a slash. -On VMS, converts "[X]FOO.DIR" to "[X.FOO]", etc. */ (file)) { @@ -622,9 +551,6 @@ /* * Convert from directory name to filename. - * On VMS: - * xyzzy:[mukesh.emacs] => xyzzy:[mukesh]emacs.dir.1 - * xyzzy:[mukesh] => xyzzy:[000000]mukesh.dir.1 * On UNIX, it's simple: just make sure there is a terminating / * Value is nonzero if the string output is different from the input. @@ -634,129 +560,8 @@ directory_file_name (CONST char *src, char *dst) { long slen; -#ifdef VMS - long rlen; - char * ptr, * rptr; - char bracket; - struct FAB fab = cc$rms_fab; - struct NAM nam = cc$rms_nam; - char esa[NAM$C_MAXRSS]; -#endif /* VMS */ slen = strlen (src); -#ifdef VMS - if (! strchr (src, '/') - && (src[slen - 1] == ']' - || src[slen - 1] == ':' - || src[slen - 1] == '>')) - { - /* VMS style - convert [x.y.z] to [x.y]z, [x] to [000000]x */ - fab.fab$l_fna = src; - fab.fab$b_fns = slen; - fab.fab$l_nam = &nam; - fab.fab$l_fop = FAB$M_NAM; - - nam.nam$l_esa = esa; - nam.nam$b_ess = sizeof esa; - nam.nam$b_nop |= NAM$M_SYNCHK; - - /* We call SYS$PARSE to handle such things as [--] for us. */ - if (SYS$PARSE(&fab, 0, 0) == RMS$_NORMAL) - { - slen = nam.nam$b_esl; - if (esa[slen - 1] == ';' && esa[slen - 2] == '.') - slen -= 2; - esa[slen] = '\0'; - src = esa; - } - if (src[slen - 1] != ']' && src[slen - 1] != '>') - { - /* what about when we have logical_name:???? */ - if (src[slen - 1] == ':') - { /* Xlate logical name and see what we get */ - ptr = strcpy (dst, src); /* upper case for getenv */ - while (*ptr) - { - *ptr = toupper ((unsigned char) *ptr); - ptr++; - } - dst[slen - 1] = 0; /* remove colon */ - if (!(src = egetenv (dst))) - return 0; - /* should we jump to the beginning of this procedure? - Good points: allows us to use logical names that xlate - to Unix names, - Bad points: can be a problem if we just translated to a device - name... - For now, I'll punt and always expect VMS names, and hope for - the best! */ - slen = strlen (src); - if (src[slen - 1] != ']' && src[slen - 1] != '>') - { /* no recursion here! */ - strcpy (dst, src); - return 0; - } - } - else - { /* not a directory spec */ - strcpy (dst, src); - return 0; - } - } - bracket = src[slen - 1]; - - /* If bracket is ']' or '>', bracket - 2 is the corresponding - opening bracket. */ - ptr = strchr (src, bracket - 2); - if (ptr == 0) - { /* no opening bracket */ - strcpy (dst, src); - return 0; - } - if (!(rptr = strrchr (src, '.'))) - rptr = ptr; - slen = rptr - src; - strncpy (dst, src, slen); - dst[slen] = '\0'; - if (*rptr == '.') - { - dst[slen++] = bracket; - dst[slen] = '\0'; - } - else - { - /* If we have the top-level of a rooted directory (i.e. xx:[000000]), - then translate the device and recurse. */ - if (dst[slen - 1] == ':' - && dst[slen - 2] != ':' /* skip decnet nodes */ - && strcmp(src + slen, "[000000]") == 0) - { - dst[slen - 1] = '\0'; - if ((ptr = egetenv (dst)) - && (rlen = strlen (ptr) - 1) > 0 - && (ptr[rlen] == ']' || ptr[rlen] == '>') - && ptr[rlen - 1] == '.') - { - char * buf = (char *) alloca (strlen (ptr) + 1); - strcpy (buf, ptr); - buf[rlen - 1] = ']'; - buf[rlen] = '\0'; - return directory_file_name (buf, dst); - } - else - dst[slen - 1] = ':'; - } - strcat (dst, "[000000]"); - slen += 8; - } - rptr++; - rlen = strlen (rptr) - 1; - strncat (dst, rptr, rlen); - dst[slen + rlen] = '\0'; - strcat (dst, ".DIR.1"); - return 1; - } -#endif /* VMS */ /* Process as Unix format: just remove any final slash. But leave "/" unchanged; do not change it to "". */ strcpy (dst, src); @@ -783,8 +588,6 @@ This operation exists because a directory is also a file, but its name as a directory is different from its name as a file. In Unix-syntax, this function just removes the final slash. -On VMS, given a VMS-syntax directory name such as "[X.Y]", -it returns a file name such as "[X]Y.DIR.1". */ (directory)) { @@ -804,14 +607,7 @@ handler = Ffind_file_name_handler (directory, Qdirectory_file_name); if (!NILP (handler)) return call2_check_string (handler, Qdirectory_file_name, directory); -#ifdef VMS - /* 20 extra chars is insufficient for VMS, since we might perform a - logical name translation. an equivalence string can be up to 255 - chars long, so grab that much extra space... - sss */ - buf = (char *) alloca (XSTRING_LENGTH (directory) + 20 + 255); -#else buf = (char *) alloca (XSTRING_LENGTH (directory) + 20); -#endif directory_file_name ((char *) XSTRING_DATA (directory), buf); return build_string (buf); } @@ -862,14 +658,6 @@ int tlen; Bufbyte *target; struct passwd *pw; -#ifdef VMS - Bufbyte * colon = 0; - Bufbyte * close = 0; - Bufbyte * slash = 0; - Bufbyte * brack = 0; - int lbrack = 0, rbrack = 0; - int dots = 0; -#endif /* VMS */ #ifdef DOS_NT /* Demacs 1.1.2 91/10/20 Manabu Higashida */ int drive = -1; @@ -936,10 +724,6 @@ UNGCPRO; } -#ifdef VMS - /* Filenames on VMS are always upper case. */ - name = Fupcase (name, Fcurrent_buffer ()); -#endif #ifdef FILE_SYSTEM_CASE name = FILE_SYSTEM_CASE (name); #endif @@ -1004,12 +788,7 @@ /* If nm is absolute, flush ...// and detect /./ and /../. If no /./ or /../ we can return right away. */ - if ( - IS_DIRECTORY_SEP (nm[0]) -#ifdef VMS - || strchr (nm, ':') -#endif /* VMS */ - ) + if (IS_DIRECTORY_SEP (nm[0])) { /* If it turns out that the filename we want to return is just a suffix of FILENAME, we don't need to go through and edit @@ -1033,87 +812,10 @@ || (p[2] == '.' && (IS_DIRECTORY_SEP (p[3]) || p[3] == 0)))) lose = 1; -#ifdef VMS - if (p[0] == '\\') - lose = 1; - if (p[0] == '/') { - /* if dev:[dir]/, move nm to / */ - if (!slash && p > nm && (brack || colon)) { - nm = (brack ? brack + 1 : colon + 1); - lbrack = rbrack = 0; - brack = 0; - colon = 0; - } - slash = p; - } - if (p[0] == '-') -#ifndef VMS4_4 - /* VMS pre V4.4,convert '-'s in filenames. */ - if (lbrack == rbrack) - { - if (dots < 2) /* this is to allow negative version numbers */ - p[0] = '_'; - } - else -#endif /* VMS4_4 */ - if (lbrack > rbrack && - ((p[-1] == '.' || p[-1] == '[' || p[-1] == '<') && - (p[1] == '.' || p[1] == ']' || p[1] == '>'))) - lose = 1; -#ifndef VMS4_4 - else - p[0] = '_'; -#endif /* VMS4_4 */ - /* count open brackets, reset close bracket pointer */ - if (p[0] == '[' || p[0] == '<') - lbrack++, brack = 0; - /* count close brackets, set close bracket pointer */ - if (p[0] == ']' || p[0] == '>') - rbrack++, brack = p; - /* detect ][ or >< */ - if ((p[0] == ']' || p[0] == '>') && (p[1] == '[' || p[1] == '<')) - lose = 1; - if ((p[0] == ':' || p[0] == ']' || p[0] == '>') && p[1] == '~') - nm = p + 1, lose = 1; - if (p[0] == ':' && (colon || slash)) - /* if dev1:[dir]dev2:, move nm to dev2: */ - if (brack) - { - nm = brack + 1; - brack = 0; - } - /* if /pathname/dev:, move nm to dev: */ - else if (slash) - nm = slash + 1; - /* if node::dev:, move colon following dev */ - else if (colon && colon[-1] == ':') - colon = p; - /* if dev1:dev2:, move nm to dev2: */ - else if (colon && colon[-1] != ':') - { - nm = colon + 1; - colon = 0; - } - if (p[0] == ':' && !colon) - { - if (p[1] == ':') - p++; - colon = p; - } - if (lbrack == rbrack) - if (p[0] == ';') - dots = 2; - else if (p[0] == '.') - dots++; -#endif /* VMS */ p++; } if (!lose) { -#ifdef VMS - if (strchr (nm, '/')) - return build_string (sys_translate_unix (nm)); -#endif /* VMS */ #ifndef DOS_NT if (nm == XSTRING_DATA (name)) return name; @@ -1129,9 +831,6 @@ if (nm[0] == '~') /* prefix ~ */ { if (IS_DIRECTORY_SEP (nm[1]) -#ifdef VMS - || nm[1] == ':' -#endif /* VMS */ || nm[1] == 0) /* ~ by itself */ { if (!(newdir = (Bufbyte *) egetenv ("HOME"))) @@ -1144,17 +843,10 @@ dostounix_filename (newdir); #endif /* DOS_NT */ nm++; -#ifdef VMS - nm++; /* Don't leave the slash in nm. */ -#endif /* VMS */ } else /* ~user/filename */ { - for (p = nm; *p && (!IS_DIRECTORY_SEP (*p) -#ifdef VMS - && *p != ':' -#endif /* VMS */ - ); p++); + for (p = nm; *p && (!IS_DIRECTORY_SEP (*p)); p++); o = (Bufbyte *) alloca (p - nm + 1); memcpy (o, (char *) nm, p - nm); o [p - nm] = 0; @@ -1178,11 +870,7 @@ if (pw) { newdir = (Bufbyte *) pw -> pw_dir; -#ifdef VMS - nm = p + 1; /* skip the terminator */ -#else nm = p; -#endif /* VMS */ } #endif /* not WINDOWSNT */ @@ -1192,9 +880,6 @@ } if (!IS_ANY_SEP (nm[0]) -#ifdef VMS - && !strchr (nm, ':') -#endif /* not VMS */ #ifdef DOS_NT && drive == -1 #endif /* DOS_NT */ @@ -1244,19 +929,13 @@ if (newdir) { -#ifndef VMS if (nm[0] == 0 || IS_DIRECTORY_SEP (nm[0])) strcpy ((char *) target, (char *) newdir); else -#endif file_name_as_directory ((char *) target, (char *) newdir); } strcat ((char *) target, (char *) nm); -#ifdef VMS - if (strchr (target, '/')) - strcpy (target, sys_translate_unix (target)); -#endif /* VMS */ /* Now canonicalize by removing /. and /foo/.. if they appear. */ @@ -1265,48 +944,6 @@ while (*p) { -#ifdef VMS - if (*p != ']' && *p != '>' && *p != '-') - { - if (*p == '\\') - p++; - *o++ = *p++; - } - else if ((p[0] == ']' || p[0] == '>') && p[0] == p[1] + 2) - /* brackets are offset from each other by 2 */ - { - p += 2; - if (*p != '.' && *p != '-' && o[-1] != '.') - /* convert [foo][bar] to [bar] */ - while (o[-1] != '[' && o[-1] != '<') - o--; - else if (*p == '-' && *o != '.') - *--p = '.'; - } - else if (p[0] == '-' && o[-1] == '.' && - (p[1] == '.' || p[1] == ']' || p[1] == '>')) - /* flush .foo.- ; leave - if stopped by '[' or '<' */ - { - do - o--; - while (o[-1] != '.' && o[-1] != '[' && o[-1] != '<'); - if (p[1] == '.') /* foo.-.bar ==> bar. */ - p += 2; - else if (o[-1] == '.') /* '.foo.-]' ==> ']' */ - p++, o--; - /* else [foo.-] ==> [-] */ - } - else - { -#ifndef VMS4_4 - if (*p == '-' && - o[-1] != '[' && o[-1] != '<' && o[-1] != '.' && - p[1] != ']' && p[1] != '>' && p[1] != '.') - *p = '_'; -#endif /* VMS4_4 */ - *o++ = *p++; - } -#else /* not VMS */ if (!IS_DIRECTORY_SEP (*p)) { *o++ = *p++; @@ -1354,7 +991,6 @@ { *o++ = *p++; } -#endif /* not VMS */ } #ifdef DOS_NT @@ -1408,9 +1044,6 @@ if (!NILP (handler)) return call2_check_string (handler, Qfile_truename, expanded_name); -#ifdef VMS - return expanded_name; -#else { char resolved_path[MAXPATHLEN]; char path[MAXPATHLEN]; @@ -1448,7 +1081,7 @@ break; } - else if (errno == ENOENT) + else if (errno == ENOENT || errno == EACCES) { /* Failed on this component. Just tack on the rest of the string and we are done. */ @@ -1488,7 +1121,7 @@ resolved_path[rlen + 1] = 0; rlen = rlen + 1; } - return make_string ((Bufbyte *) resolved_path, rlen); + return make_ext_string ((Bufbyte *) resolved_path, rlen, FORMAT_BINARY); } toolong: @@ -1498,7 +1131,6 @@ report_file_error ("Finding truename", list1 (expanded_name)); } return Qnil; /* suppress compiler warning */ -#endif /* not VMS */ } @@ -1510,8 +1142,6 @@ the entire variable name in braces. If `/~' appears, all of FILENAME through that `/' is discarded. -On VMS, `$' substitution is not done; this function does little and only -duplicates what `expand-file-name' does. */ (string)) { @@ -1558,11 +1188,7 @@ #endif /* not APOLLO */ ) && p != nm - && (0 -#ifdef VMS - || p[-1] == ':' || p[-1] == ']' || p[-1] == '>' -#endif /* VMS */ - || IS_DIRECTORY_SEP (p[-1]))) + && (IS_DIRECTORY_SEP (p[-1]))) { nm = p; substituted = 1; @@ -1576,10 +1202,6 @@ #endif /* DOS_NT */ } -#ifdef VMS - return build_string (nm); -#else - /* See if any variables are substituted into the string and find the total length of their values in `total' */ @@ -1718,7 +1340,6 @@ /* NOTREACHED */ return Qnil; /* suppress compiler warning */ -#endif /* not VMS */ } /* (directory-file-name (expand-file-name FOO)) */ @@ -1732,14 +1353,6 @@ abspath = Fexpand_file_name (filename, defdir); GCPRO1 (abspath); -#ifdef VMS - { - Bufbyte c = - XSTRING_BYTE (abspath, XSTRING_LENGTH (abspath) - 1); - if (c == ':' || c == ']' || c == '>') - abspath = Fdirectory_file_name (abspath); - } -#else /* Remove final slash, if any (unless path is root). stat behaves differently depending! */ if (XSTRING_LENGTH (abspath) > 1 @@ -1747,7 +1360,6 @@ && !IS_DEVICE_SEP (XSTRING_BYTE (abspath, XSTRING_LENGTH (abspath) - 2))) /* We cannot take shortcuts; they might be wrong for magic file names. */ abspath = Fdirectory_file_name (abspath); -#endif UNGCPRO; return abspath; } @@ -1913,17 +1525,12 @@ } #endif /* S_ISREG && S_ISLNK */ -#ifdef VMS - /* Create the copy file with the same record format as the input file */ - ofd = sys_creat ((char *) XSTRING_DATA (newname), 0666, ifd); -#else #ifdef MSDOS /* System's default file type was set to binary by _fmode in emacs.c. */ ofd = creat ((char *) XSTRING_DATA (newname), S_IREAD | S_IWRITE); #else /* not MSDOS */ ofd = creat ((char *) XSTRING_DATA (newname), 0666); #endif /* not MSDOS */ -#endif /* VMS */ if (ofd < 0) report_file_error ("Opening output file", list1 (newname)); @@ -2008,10 +1615,8 @@ strncpy (dir, (char *) XSTRING_DATA (dirname_), XSTRING_LENGTH (dirname_) + 1); -#ifndef VMS if (dir [XSTRING_LENGTH (dirname_) - 1] == '/') dir [XSTRING_LENGTH (dirname_) - 1] = 0; -#endif #ifdef WINDOWSNT if (mkdir (dir) != 0) @@ -2295,32 +1900,6 @@ } #endif /* S_IFLNK */ -#ifdef VMS - -DEFUN ("define-logical-name", Fdefine_logical_name, 2, 2, - "sDefine logical name: \nsDefine logical name %s as: ", /* -Define the job-wide logical name NAME to have the value STRING. -If STRING is nil or a null string, the logical name NAME is deleted. -*/ - (varname, string)) -{ - CHECK_STRING (varname); - if (NILP (string)) - delete_logical_name ((char *) XSTRING_DATA (varname)); - else - { - CHECK_STRING (string); - - if (XSTRING_LENGTH (string) == 0) - delete_logical_name ((char *) XSTRING_DATA (varname)); - else - define_logical_name ((char *) XSTRING_DATA (varname), (char *) XSTRING_DATA (string)); - } - - return string; -} -#endif /* VMS */ - #ifdef HPUX_NET DEFUN ("sysnetunam", Fsysnetunam, 2, 2, 0, /* @@ -2364,12 +1943,6 @@ CHECK_STRING (filename); ptr = XSTRING_DATA (filename); if (IS_DIRECTORY_SEP (*ptr) || *ptr == '~' -#ifdef VMS -/* ??? This criterion is probably wrong for '<'. */ - || strchr (ptr, ':') || strchr (ptr, '<') - || (*ptr == '[' && (ptr[1] != '-' || (ptr[2] != '.' && ptr[2] != ']')) - && ptr[1] != '.') -#endif /* VMS */ #ifdef DOS_NT || (*ptr != 0 && ptr[1] == ':' && (ptr[2] == '/' || ptr[2] == '\\')) #endif @@ -2550,14 +2123,14 @@ GCPRO1 (abspath); dir = Ffile_name_directory (abspath); UNGCPRO; -#if defined (VMS) || defined (MSDOS) +#ifdef MSDOS if (!NILP (dir)) { GCPRO1(dir); dir = Fdirectory_file_name (dir); UNGCPRO; } -#endif /* VMS or MSDOS */ +#endif /* MSDOS */ return (check_writable (!NILP (dir) ? (char *) XSTRING_DATA (dir) : "") ? Qt : Qnil); @@ -2797,7 +2370,6 @@ return make_int ((~ mode) & 0777); } -#ifndef VMS DEFUN ("unix-sync", Funix_sync, 0, 0, "", /* Tell Unix to finish all pending disk updates. */ @@ -2808,7 +2380,6 @@ #endif return Qnil; } -#endif /* !VMS */ DEFUN ("file-newer-than-file-p", Ffile_newer_than_file_p, 2, 2, 0, /* @@ -2961,9 +2532,8 @@ } #ifdef S_IFREG - /* This code will need to be changed in order to work on named - pipes, and it's probably just not worth it. So we should at - least signal an error. */ + /* Signal an error if we are accessing a non-regular file, with + REPLACE, BEG or END being non-nil. */ if (!S_ISREG (st.st_mode)) { not_regular = 1; @@ -2990,6 +2560,10 @@ if (!NILP (end)) CHECK_INT (end); + /* Here, we should call some form of interruptable_open, so the user + can quit gracefully when opening named pipes. interruptable_open + should be just like sys_open in sysdep.c, only it would call QUIT + if interrupted by EINTR. */ if (fd < 0) if ((fd = open ((char *) XSTRING_DATA (filename), O_RDONLY, 0)) < 0) goto badopen; @@ -3370,9 +2944,6 @@ struct stat st; Lisp_Object fn; int speccount = specpdl_depth (); -#ifdef VMS - unsigned char *fname = 0; /* If non-0, original filename (must rename) */ -#endif /* VMS */ int visiting_other = STRINGP (visit); int visiting = (EQ (visit, Qt) || visiting_other); int quietly = (!visiting && !NILP (visit)); @@ -3485,7 +3056,6 @@ #endif /* not DOS_NT */ if (desc < 0) -#ifndef VMS { #ifdef DOS_NT desc = open ((char *) XSTRING_DATA (fn), @@ -3496,75 +3066,6 @@ ((auto_saving) ? auto_save_mode_bits : 0666)); #endif /* DOS_NT */ } -#else /* VMS */ - { - if (auto_saving) /* Overwrite any previous version of autosave file */ - { - char *fn_data = XSTRING_DATA (fn); - /* if fn exists, truncate to zero length */ - vms_truncate (fn_data); - desc = open (fn_data, O_RDWR, 0); - if (desc < 0) - desc = creat_copy_attrs ((STRINGP (current_buffer->filename) - ? (char *) - XSTRING_DATA (current_buffer->filename) - : 0), - fn_data); - } - else /* Write to temporary name and rename if no errors */ - { - Lisp_Object temp_name; - - struct gcpro gcpro1, gcpro2, gcpro3; - GCPRO3 (start, filename, visit_file); - { - struct gcpro gcpro1, gcpro2, gcpro3; /* Don't have GCPRO6 */ - - GCPRO3 (fn, fname, annotations); - - temp_name = Ffile_name_directory (filename); - - if (NILP (temp_name)) - desc = creat ((char *) XSTRING_DATA (fn), 0666); - else - { - temp_name = - Fmake_temp_name (concat2 (temp_name, - build_string ("$$SAVE$$"))); - fname = filename; - fn = temp_name; - desc = creat_copy_attrs (fname, - (char *) XSTRING_DATA (fn)); - if (desc < 0) - { - char *fn_data; - /* If we can't open the temporary file, try creating a new - version of the original file. VMS "creat" creates a - new version rather than truncating an existing file. */ - fn = fname; - fname = Qnil; - fn_data = XSTRING_DATA (fn); - desc = creat (fn_data, 0666); -#if 0 /* This can clobber an existing file and fail - to replace it, if the user runs out of - space. */ - if (desc < 0) - { - /* We can't make a new version; - try to truncate and rewrite existing version if any. - */ - vms_truncate (fn_data); - desc = open (fn_data, O_RDWR, 0); - } -#endif /* 0 */ - } - } - UNGCPRO; - } - UNGCPRO; - } - } -#endif /* VMS */ if (desc < 0) { @@ -3598,27 +3099,6 @@ } } -#ifdef VMS -/* - * Kludge Warning: The VMS C RTL likes to insert carriage returns - * if we do writes that don't end with a carriage return. Furthermore - * it cannot handle writes of more then 16K. The modified - * version of "sys_write" in SYSDEP.C (see comment there) copes with - * this EXCEPT for the last record (iff it doesn't end with a carriage - * return). This implies that if your buffer doesn't end with a carriage - * return, you get one free... tough. However it also means that if - * we make two calls to sys_write (a la the following code) you can - * get one at the gap as well. The easiest way to fix this (honest) - * is to move the gap to the next newline (or the end of the buffer). - * Thus this change. - * - * Yech! - */ - you lose -- fix this - if (GPT > BUF_BEG (current_buffer) && *GPT_ADDR[-1] != '\n') - move_gap (find_next_newline (current_buffer, GPT, 1)); -#endif /* VMS */ - failure = 0; /* Note: I tried increasing the buffering size, along with @@ -3704,21 +3184,6 @@ } -#ifdef VMS - /* If we wrote to a temporary name and had no errors, rename to real name. */ - if (!NILP (fname)) - { - if (!failure) - { - failure = (rename ((char *) XSTRING_DATA (fn), - (char *) XSTRING_DATA (fname)) - != 0); - save_errno = errno; - } - fn = fname; - } -#endif /* VMS */ - #if 1 /* defined (VMS) || defined (APOLLO) */ stat ((char *) XSTRING_DATA (fn), &st); #endif @@ -4638,9 +4103,6 @@ #ifdef S_IFLNK DEFSUBR (Fmake_symbolic_link); #endif /* S_IFLNK */ -#ifdef VMS - DEFSUBR (Fdefine_logical_name); -#endif /* VMS */ #ifdef HPUX_NET DEFSUBR (Fsysnetunam); #endif /* HPUX_NET */ @@ -4690,12 +4152,6 @@ */ ); Vauto_save_file_format = Qt; - DEFVAR_BOOL ("vms-stmlf-recfm", &vms_stmlf_recfm /* -*Non-nil means write new files with record format `stmlf'. -nil means use format `var'. This variable is meaningful only on VMS. -*/ ); - vms_stmlf_recfm = 0; - DEFVAR_LISP ("file-name-handler-alist", &Vfile_name_handler_alist /* *Alist of elements (REGEXP . HANDLER) for file names handled specially. If a file name matches REGEXP, then all I/O on that file is done by calling
--- a/src/fns.c Mon Aug 13 10:03:54 2007 +0200 +++ b/src/fns.c Mon Aug 13 10:04:58 2007 +0200 @@ -3351,16 +3351,35 @@ Use this to conditionalize execution of lisp code based on the presence or absence of emacs or environment extensions. FEXP can be a symbol, a number, or a list. -If a symbol, it will be looked up in the `features' variable, and - non-nil will be returned if it is found. -If FEXP is a number, the function will return non-nil if this Emacs +If it is a symbol, that symbol is looked up in the `features' variable, + and non-nil will be returned if found. +If it is a number, the function will return non-nil if this Emacs has an equal or greater version number than FEXP. -If FEXP is a list whose car is the symbol `and', it will return +If it is a list whose car is the symbol `and', it will return non-nil if all the features in its cdr are non-nil. -If FEXP is a list whose car is the symbol `or', it will return non-nil +If it is a list whose car is the symbol `or', it will return non-nil if any of the features in its cdr are non-nil. -If FEXP is a list whose car is the symbol `not', it will return +If it is a list whose car is the symbol `not', it will return non-nil if the feature is not present. + +Examples: + + (featurep 'xemacs) + => ; Non-nil on XEmacs. + + (featurep '(and xemacs gnus)) + => ; Non-nil on XEmacs with Gnus loaded. + + (featurep '(or tty-frames (and emacs 19.30))) + => ; Non-nil if this Emacs supports TTY frames. + + (featurep '(or (and xemacs 19.15) (and emacs 19.34))) + => ; Non-nil on XEmacs 19.15 and later, or FSF Emacs 19.34 and later. + +NOTE: The advanced arguments of this function (anything other than a +symbol) are not yet supported by FSF Emacs. If you feel they are useful +for supporting multiple Emacs variants, lobby Richard Stallman at +<bug-gnu-emacs@prep.ai.mit.edu>. */ (fexp)) { @@ -3369,6 +3388,7 @@ return NILP (Fmemq (fexp, Vfeatures)) ? Qnil : Qt; #else /* FEATUREP_SYNTAX */ extern Lisp_Object Vemacs_major_version, Vemacs_minor_version; + extern Lisp_Object Qfeaturep; static double featurep_emacs_version; /* Brute force translation from Erik Naggum's lisp function. */ @@ -3400,7 +3420,7 @@ tem = XCDR (fexp); negate = Fcar (tem); if (!NILP (tem)) - return NILP (Ffeaturep (negate)) ? Qt : Qnil; + return NILP (call1 (Qfeaturep, negate)) ? Qt : Qnil; else return Fsignal (Qinvalid_read_syntax, list1 (tem)); } @@ -3408,7 +3428,7 @@ { tem = XCDR(fexp); /* Use Fcar/Fcdr for error-checking. */ - while (!NILP (tem) && !NILP (Ffeaturep (Fcar (tem)))) + while (!NILP (tem) && !NILP (call1 (Qfeaturep, Fcar (tem)))) { tem = Fcdr (tem); } @@ -3418,7 +3438,7 @@ { tem = XCDR (fexp); /* Use Fcar/Fcdr for error-checking. */ - while (!NILP (tem) && NILP (Ffeaturep (Fcar (tem)))) + while (!NILP (tem) && NILP (call1 (Qfeaturep, Fcar (tem)))) { tem = Fcdr (tem); }
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/frame-w32.c Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,283 @@ +/* Functions for the win32 window system. + Copyright (C) 1989, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. + Copyright (C) 1995, 1996 Ben Wing. + +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 synched with FSF. */ + +/* Authorship: + + Ultimately based on FSF. + Substantially rewritten for XEmacs by Ben Wing. + Rewritten for win32 by Jonathan Harris, November 1997 for 20.4. + */ + +#include <config.h> +#include "lisp.h" + +#include "console-w32.h" +#include "event-w32.h" + +#include "buffer.h" +#include "frame.h" +#include "events.h" + +/* Default properties to use when creating frames. */ +Lisp_Object Vdefault_w32_frame_plist; +/* Lisp_Object Qname, Qheight, Qwidth, Qinitially_unmapped, Qpopup, Qtop, Qleft; */ +Lisp_Object Qinitially_unmapped, Qpopup; + +static void +w32_init_frame_1 (struct frame *f, Lisp_Object props) +{ + w32_request_type request = { f, &props }; + Lisp_Object device = FRAME_DEVICE (f); + struct device *d = XDEVICE (device); + Lisp_Object lisp_window_id, initially_unmapped; + initially_unmapped = Fplist_get (props, Qinitially_unmapped, Qnil); + +#if 0 + if (NILP (DEVICE_SELECTED_FRAME (d)) && /* first frame on the device */ + NILP (initially_unmapped)) + f->visible = 1; +#endif + + f->frame_data = xnew_and_zero (struct w32_frame); + FRAME_W32_HANDLE(f) = (HWND)w32_make_request(WM_XEMACS_CREATEWINDOW, + 0, &request); + FRAME_W32_DC(f) = GetDC(FRAME_W32_HANDLE(f)); + SetTextAlign(FRAME_W32_DC(f), TA_BASELINE|TA_LEFT|TA_NOUPDATECP); + + /* XXX FIXME: This function should be made to do something */ + update_frame_face_values (f); +} + +/* Called just before frame's properties are set */ +static void +w32_init_frame_2 (struct frame *f, Lisp_Object props) +{ +} + +/* Called after frame's properties are set */ +static void +w32_init_frame_3 (struct frame *f) +{ + /* Don't do this earlier or we get a WM_PAINT before the frame is ready*/ + ShowWindow(FRAME_W32_HANDLE(f), SW_SHOWNORMAL); +} + +static void +w32_delete_frame (struct frame *f) +{ + if (f->frame_data) + { + ReleaseDC(FRAME_W32_HANDLE(f), FRAME_W32_DC(f)); + DestroyWindow(FRAME_W32_HANDLE(f)); + } +} + +static void +w32_set_frame_size (struct frame *f, int cols, int rows) +{ +} + + +static void +w32_set_frame_position (struct frame *f, int xoff, int yoff) +{ +} + +static void +w32_set_frame_properties (struct frame *f, Lisp_Object plist) +{ + int x, y; + int width = 0, height = 0; + BOOL width_specified_p = FALSE; + BOOL height_specified_p = FALSE; + BOOL x_specified_p = FALSE; + BOOL y_specified_p = FALSE; + Lisp_Object tail; + + /* Extract the properties from plist */ + for (tail = plist; !NILP (tail); tail = Fcdr (Fcdr (tail))) + { + Lisp_Object prop = Fcar (tail); + Lisp_Object val = Fcar (Fcdr (tail)); + + if (SYMBOLP (prop)) + { + /* Kludge to handle the font property. */ + if (EQ (prop, Qfont)) + { + /* If the value is not a string we silently ignore it. */ + if (STRINGP (val)) + { + Lisp_Object frm, font_spec; + + XSETFRAME (frm, f); + font_spec = Fget (Fget_face (Qdefault), Qfont, Qnil); + + Fadd_spec_to_specifier (font_spec, val, frm, Qnil, Qnil); + update_frame_face_values (f); + } + } + else if (EQ (prop, Qwidth)) + { + CHECK_INT (val); + width = XINT (val); + width_specified_p = TRUE; + } + else if (EQ (prop, Qheight)) + { + CHECK_INT (val); + height = XINT (val); + height_specified_p = TRUE; + } + else if (EQ (prop, Qleft)) + { + CHECK_INT (val); + x = XINT (val); + x_specified_p = TRUE; + } + else if (EQ (prop, Qtop)) + { + CHECK_INT (val); + y = XINT (val); + y_specified_p = TRUE; + } + } + } + + /* Now we've extracted the properties, apply them */ + if (width_specified_p || height_specified_p || x_specified_p || y_specified_p) + { + Lisp_Object frame; + RECT rect; + int pixel_width, pixel_height; + XSETFRAME (frame, f); + + if (!width_specified_p) + width = FRAME_WIDTH (f); + if (!height_specified_p) + height = FRAME_HEIGHT (f); + char_to_pixel_size (f, width, height, &pixel_width, &pixel_height); + + GetWindowRect (FRAME_W32_HANDLE(f), &rect); + if (!x_specified_p) + x = rect.left; + if (!y_specified_p) + y = rect.top; + /* XXX FIXME: Should do AdjustWindowRect here like in w32_handle_request */ + MoveWindow (FRAME_W32_HANDLE(f), x, y, pixel_width, pixel_height, + (width_specified_p || height_specified_p)); + } +} + + +void +console_type_create_frame_w32 (void) +{ + /* frame methods */ + CONSOLE_HAS_METHOD (w32, init_frame_1); + CONSOLE_HAS_METHOD (w32, init_frame_2); + CONSOLE_HAS_METHOD (w32, init_frame_3); +/* CONSOLE_HAS_METHOD (w32, mark_frame); */ +/* CONSOLE_HAS_METHOD (w32, focus_on_frame); */ + CONSOLE_HAS_METHOD (w32, delete_frame); +/* CONSOLE_HAS_METHOD (w32, get_mouse_position); */ +/* CONSOLE_HAS_METHOD (w32, set_mouse_position); */ +/* CONSOLE_HAS_METHOD (w32, raise_frame); */ +/* CONSOLE_HAS_METHOD (w32, lower_frame); */ +/* CONSOLE_HAS_METHOD (w32, make_frame_visible); */ +/* CONSOLE_HAS_METHOD (w32, make_frame_invisible); */ +/* CONSOLE_HAS_METHOD (w32, iconify_frame); */ + CONSOLE_HAS_METHOD (w32, set_frame_size); + CONSOLE_HAS_METHOD (w32, set_frame_position); +/* CONSOLE_HAS_METHOD (w32, frame_property); */ +/* CONSOLE_HAS_METHOD (w32, internal_frame_property_p); */ +/* CONSOLE_HAS_METHOD (w32, frame_properties); */ + CONSOLE_HAS_METHOD (w32, set_frame_properties); +/* CONSOLE_HAS_METHOD (w32, set_title_from_bufbyte); */ +/* CONSOLE_HAS_METHOD (w32, set_icon_name_from_bufbyte); */ +/* CONSOLE_HAS_METHOD (w32, frame_visible_p); */ +/* CONSOLE_HAS_METHOD (w32, frame_totally_visible_p); */ +/* CONSOLE_HAS_METHOD (w32, frame_iconified_p); */ +/* CONSOLE_HAS_METHOD (w32, set_frame_pointer); */ +/* CONSOLE_HAS_METHOD (w32, set_frame_icon); */ +/* CONSOLE_HAS_METHOD (w32, get_frame_parent); */ +} + +void +syms_of_frame_w32 (void) +{ +#if 0 /* XXX these are in general.c */ + defsymbol (&Qname, "name"); + defsymbol (&Qheight, "height"); + defsymbol (&Qwidth, "width"); + defsymbol (&Qtop, "top"); + defsymbol (&Qleft, "left"); +#endif + defsymbol (&Qinitially_unmapped, "initially-unmapped"); + defsymbol (&Qpopup, "popup"); +} + +void +vars_of_frame_w32 (void) +{ + DEFVAR_LISP ("default-w32-frame-plist", &Vdefault_w32_frame_plist /* +Plist of default frame-creation properties for w32 frames. +These override what is specified in `default-frame-plist', but are +overridden by the arguments to the particular call to `make-frame'. + +Note: In many cases, properties of a frame are available as specifiers +instead of through the frame-properties mechanism. + +Here is a list of recognized frame properties, other than those +documented in `set-frame-properties' (they can be queried and +set at any time, except as otherwise noted): + + initially-unmapped If non-nil, the frame will not be visible + when it is created. In this case, you + need to call `make-frame-visible' to make + the frame appear. + popup If non-nil, it should be a frame, and this + frame will be created as a "popup" frame + whose parent is the given frame. This + will make the window manager treat the + frame as a dialog box, which may entail + doing different things (e.g. not asking + for positioning, and not iconifying + separate from its parent). + top Y position (in pixels) of the upper-left + outermost corner of the frame (i.e. the + upper-left of the window-manager + decorations). + left X position (in pixels) of the upper-left + outermost corner of the frame (i.e. the + upper-left of the window-manager + decorations). + +See also `default-frame-plist', which specifies properties which apply +to all frames, not just w32 frames. +*/ ); + Vdefault_w32_frame_plist = Qnil; + + w32_console_methods->device_specific_frame_props = + &Vdefault_w32_frame_plist; +}
--- a/src/frame-x.c Mon Aug 13 10:03:54 2007 +0200 +++ b/src/frame-x.c Mon Aug 13 10:04:58 2007 +0200 @@ -2511,28 +2511,14 @@ x_delete_frame (struct frame *f) { Widget w = FRAME_X_SHELL_WIDGET (f); - Lisp_Object popup, frame; + Lisp_Object frame; #ifndef HAVE_SESSION if (FRAME_X_TOP_LEVEL_FRAME_P (f)) x_wm_maybe_move_wm_command (f); #endif /* HAVE_SESSION */ - /* Frames with the popup property are using other frames as their - widget parent. Deleting them are their parent has already been - deleted can lead to crashes. */ XSETFRAME (frame, f); - popup = Fframe_property (frame, Qpopup, Qnil); - if (!NILP (popup)) - { - /* If popup isn't nil then it means the frame has that property - and the value is supposed to be the parent frame. The FRAMEP - check is to safeguard against it not being a frame. */ - if (!FRAMEP (popup) || !FRAME_LIVE_P (XFRAME (popup))) - popup = Qt; - else - popup = Qnil; - } #ifdef EXTERNAL_WIDGET { @@ -2548,8 +2534,7 @@ x_error_occurred_p (dpy); } #else - if (NILP (popup)) - XtDestroyWidget (w); + XtDestroyWidget (w); #endif /* EXTERNAL_WIDGET */ if (FRAME_X_GEOM_FREE_ME_PLEASE (f))
--- a/src/frame.c Mon Aug 13 10:03:54 2007 +0200 +++ b/src/frame.c Mon Aug 13 10:04:58 2007 +0200 @@ -2199,9 +2199,9 @@ up and setting frame property values. This allows you to alias one frame property name to another. -See the variables `default-x-frame-plist' and `default-tty-frame-plist' -for a description of the properties recognized for particular types of -frames. +See the variables `default-x-frame-plist', `default-tty-frame-plist' +and `default-w32-frame-plist' for a description of the properties +recognized for particular types of frames. */ (frame, plist)) { @@ -2313,8 +2313,8 @@ This is over-the-top bogosity, because it's inconsistent with the semantics of `minibuffer' when passed to `make-frame'. Returning Qt makes things consistent. */ - FROB (Qminibuffer, (FRAME_HAS_MINIBUF_P (f) ? Qt : - FRAME_MINIBUF_ONLY_P (f) ? Qonly : + FROB (Qminibuffer, (FRAME_MINIBUF_ONLY_P (f) ? Qonly : + FRAME_HAS_MINIBUF_P (f) ? Qt : FRAME_MINIBUF_WINDOW (f))); FROB (Qunsplittable, FRAME_NO_SPLIT_P (f) ? Qt : Qnil); FROB (Qbuffer_predicate, f->buffer_predicate); @@ -2381,8 +2381,8 @@ This is over-the-top bogosity, because it's inconsistent with the semantics of `minibuffer' when passed to `make-frame'. Returning Qt makes things consistent. */ - FROB (Qminibuffer, (FRAME_HAS_MINIBUF_P (f) ? Qt : - FRAME_MINIBUF_ONLY_P (f) ? Qonly : + FROB (Qminibuffer, (FRAME_MINIBUF_ONLY_P (f) ? Qonly : + FRAME_HAS_MINIBUF_P (f) ? Qt : FRAME_MINIBUF_WINDOW (f))); FROB (Qunsplittable, FRAME_NO_SPLIT_P (f) ? Qt : Qnil); FROB (Qbuffer_predicate, f->buffer_predicate); @@ -2623,6 +2623,10 @@ /* #### Chuck -- shouldn't we be checking to see if the frame is being "changed" to its existing size, and do nothing if so? */ + /* No, because it would hose toolbar updates. The toolbar + update code relies on this function to cause window `top' and + `left' coordinates to be recomputed even though no frame size + change occurs. --kyle */ if (in_display) abort ();
--- a/src/general.c Mon Aug 13 10:03:54 2007 +0200 +++ b/src/general.c Mon Aug 13 10:04:58 2007 +0200 @@ -155,6 +155,7 @@ Lisp_Object Qvalue_assoc; Lisp_Object Qvector; Lisp_Object Qwarning; +Lisp_Object Qw32; Lisp_Object Qwhite; Lisp_Object Qwidth; Lisp_Object Qwindow; @@ -291,6 +292,7 @@ defsymbol (&Qwarning, "warning"); defsymbol (&Qwhite, "white"); defsymbol (&Qwidth, "width"); + defsymbol (&Qw32, "w32"); defsymbol (&Qwindow, "window"); defsymbol (&Qwindow_system, "window-system"); defsymbol (&Qx, "x");
--- a/src/getloadavg.c Mon Aug 13 10:03:54 2007 +0200 +++ b/src/getloadavg.c Mon Aug 13 10:04:58 2007 +0200 @@ -44,7 +44,6 @@ BSD Real BSD, not just BSD-like. convex DGUX - eunice UNIX emulator under VMS. hpux MSDOS No-op for MSDOS. NeXT @@ -54,7 +53,6 @@ sony_news NEWS-OS (works at least for 4.1C) UMAX UMAX4_3 - VMS WIN32 No-op for Windows95/NT. __linux__ Linux: assumes /proc filesystem mounted. Support from Michael K. Johnson. @@ -395,7 +393,6 @@ #ifdef LOAD_AVE_TYPE -#ifndef VMS #ifndef NLIST_STRUCT #include <a.out.h> #else /* NLIST_STRUCT */ @@ -415,16 +412,6 @@ #define LDAV_SYMBOL "_avenrun" #endif /* LDAV_SYMBOL */ -#else /* VMS */ - -#ifndef eunice -#include <iodef.h> -#include <descrip.h> -#else /* eunice */ -#include <vms/iodef.h> -#endif /* eunice */ -#endif /* VMS */ - #ifndef LDAV_CVT #define LDAV_CVT(n) ((double) (n)) #endif /* !LDAV_CVT */ @@ -499,16 +486,16 @@ #endif /* DGUX */ #ifdef LOAD_AVE_TYPE -/* File descriptor open to /dev/kmem or VMS load ave driver. */ +/* File descriptor open to /dev/kmem */ static int channel; /* Nonzero iff channel is valid. */ static int getloadavg_initialized; /* Offset in kmem to seek to read load average, or 0 means invalid. */ static long offset; -#if !defined(VMS) && !defined(sgi) +#ifndef sgi static struct nlist nl[2]; -#endif /* Not VMS or sgi */ +#endif /* not sgi */ #ifdef SUNOS_5 static kvm_t *kd; @@ -833,47 +820,7 @@ : (load_ave.tl_avenrun.l[elem] / (double) load_ave.tl_lscale)); #endif /* OSF_ALPHA */ -#if !defined (LDAV_DONE) && defined (VMS) - /* VMS specific code -- read from the Load Ave driver. */ - - LOAD_AVE_TYPE load_ave[3]; - static int getloadavg_initialized = 0; -#ifdef eunice - struct - { - int dsc$w_length; - char *dsc$a_pointer; - } descriptor; -#endif - - /* Ensure that there is a channel open to the load ave device. */ - if (!getloadavg_initialized) - { - /* Attempt to open the channel. */ -#ifdef eunice - descriptor.dsc$w_length = 18; - descriptor.dsc$a_pointer = "$$VMS_LOAD_AVERAGE"; -#else - $DESCRIPTOR (descriptor, "LAV0:"); -#endif - if (sys$assign (&descriptor, &channel, 0, 0) & 1) - getloadavg_initialized = 1; - } - - /* Read the load average vector. */ - if (getloadavg_initialized - && !(sys$qiow (0, channel, IO$_READVBLK, 0, 0, 0, - load_ave, 12, 0, 0, 0, 0) & 1)) - { - sys$dassgn (channel); - getloadavg_initialized = 0; - } - - if (!getloadavg_initialized) - return -1; -#endif /* VMS */ - -#if !defined (LDAV_DONE) && defined(LOAD_AVE_TYPE) && !defined(VMS) +#if !defined (LDAV_DONE) && defined(LOAD_AVE_TYPE) /* UNIX-specific code -- read the average from /dev/kmem. */ @@ -978,9 +925,7 @@ if (offset == 0 || !getloadavg_initialized) return -1; -#endif /* LOAD_AVE_TYPE and not VMS */ -#if !defined (LDAV_DONE) && defined (LOAD_AVE_TYPE) /* Including VMS. */ if (nelem > 0) loadavg[elem++] = LDAV_CVT (load_ave[0]); if (nelem > 1)
--- a/src/getpagesize.h Mon Aug 13 10:03:54 2007 +0200 +++ b/src/getpagesize.h Mon Aug 13 10:04:58 2007 +0200 @@ -29,10 +29,6 @@ #ifndef HAVE_GETPAGESIZE -#ifdef VMS -#define getpagesize() 512 -#endif - #ifdef HAVE_UNISTD_H #include <unistd.h> #endif
--- a/src/glyphs-x.c Mon Aug 13 10:03:54 2007 +0200 +++ b/src/glyphs-x.c Mon Aug 13 10:04:58 2007 +0200 @@ -61,7 +61,7 @@ #endif /* HAVE_IMAGEMAGICK */ #ifdef HAVE_X11_MAGICK_IMAGE_H -#include <magick.h> +#include <magick/magick.h> /* #include <image.h> */ #include <assert.h> #endif
--- a/src/linuxplay.c Mon Aug 13 10:03:54 2007 +0200 +++ b/src/linuxplay.c Mon Aug 13 10:04:58 2007 +0200 @@ -825,6 +825,8 @@ fmt != the_fmt) { perror("SNDCTL_DSP_SETFMT"); return(0); } } + else if (fmt == AFMT_MU_LAW && the_fmt == AFMT_U8 ) { + /* the kernel will convert for us */ } else { perror("SNDCTL_DSP_SETFMT"); return(0); } }
--- a/src/lisp.h Mon Aug 13 10:03:54 2007 +0200 +++ b/src/lisp.h Mon Aug 13 10:04:58 2007 +0200 @@ -1948,6 +1948,10 @@ in addition to a device separator. Default the path separator to '/', and don't test for a device separator in IS_ANY_SEP. */ +#ifdef WINDOWSNT +extern Lisp_Object Vdirectory_sep_char; +#endif + #ifndef DIRECTORY_SEP #define DIRECTORY_SEP '/' #endif
--- a/src/lread.c Mon Aug 13 10:03:54 2007 +0200 +++ b/src/lread.c Mon Aug 13 10:04:58 2007 +0200 @@ -77,7 +77,7 @@ #define FEATUREP_SYNTAX #ifdef FEATUREP_SYNTAX -static Lisp_Object Qfeaturep; +Lisp_Object Qfeaturep; #endif /* non-zero if inside `load' */ @@ -821,9 +821,6 @@ #ifdef ALTOS || *s == '@' #endif -#ifdef VMS - || strchr (s, ':') -#endif /* VMS */ ); } #endif /* 0 */ @@ -2967,7 +2964,7 @@ { /* loadup.el will frob this some more. */ /* #### unix-specific */ - Vload_path = Fcons (build_string ("../lisp/prim"), Vload_path); + Vload_path = Fcons (build_string ("../lisp/"), Vload_path); } #endif /* not CANNOT_DUMP */ load_in_progress = 0;
--- a/src/m/vax.h Mon Aug 13 10:03:54 2007 +0200 +++ b/src/m/vax.h Mon Aug 13 10:04:58 2007 +0200 @@ -76,17 +76,6 @@ #endif /* BSD */ -#ifdef VMS - -/* Data type of load average, as read out of driver. */ - -#define LOAD_AVE_TYPE float - -/* Convert that into an integer that is 100 for a load average of 1.0 */ - -#define LOAD_AVE_CVT(x) ((int) ((x) * 100.0)) - -#endif /* VMS */ /* Vax sysV has alloca in the PW library. */ @@ -107,10 +96,6 @@ #define HAVE_ALLOCA #endif /* BSD */ -#ifdef VMS -#define C_ALLOCA -#endif - #ifdef BSD4_2 #define HAVE_FTIME #endif
--- a/src/malloc.c Mon Aug 13 10:03:54 2007 +0200 +++ b/src/malloc.c Mon Aug 13 10:04:58 2007 +0200 @@ -151,11 +151,9 @@ /* Determine which kind of system this is. */ #include <signal.h> #ifndef SIGTSTP -#ifndef VMS #ifndef USG #define USG #endif -#endif /* not VMS */ #else /* SIGTSTP */ #ifdef SIGIO #define BSD4_2 @@ -365,12 +363,6 @@ /* Find current end of memory and issue warning if getting near max */ -#ifndef VMS - /* Maximum virtual memory on VMS is difficult to calculate since it - * depends on several dynamically changing things. Also, alignment - * isn't that important. That is why much of the code here is ifdef'ed - * out for VMS systems. - */ cp = sbrk (0); siz = cp - data_space_start; @@ -402,7 +394,6 @@ if ((int) cp & 0x3ff) /* land on 1K boundaries */ sbrk (1024 - ((int) cp & 0x3ff)); -#endif /* not VMS */ /* Take at least 2k, and figure out how many blocks of the desired size we're about to get */ @@ -422,13 +413,11 @@ malloc_sbrk_used = siz; malloc_sbrk_unused = lim_data - siz; -#ifndef VMS if ((int) cp & 7) { /* shouldn't happen, but just in case */ cp = (char *) (((int) cp + 8) & ~7); nblks--; } -#endif /* not VMS */ /* save new header and link the nblks blocks together */ nextf[nu] = (struct mhead *) cp; @@ -677,7 +666,6 @@ } } -#ifndef VMS char * memalign (alignment, size) @@ -713,7 +701,6 @@ return memalign (getpagesize (), size); } #endif /* not __hpux */ -#endif /* not VMS */ #ifdef MSTATS /* Return statistics describing allocation of blocks of size 2**n. */ @@ -838,74 +825,3 @@ #endif /* BSD4_2 */ #endif /* not USG */ -#ifdef VMS -/* There is a problem when dumping and restoring things on VMS. Calls - * to SBRK don't necessarily result in contiguous allocation. Dumping - * doesn't work when it isn't. Therefore, we make the initial - * allocation contiguous by allocating a big chunk, and do SBRKs from - * there. Once Emacs has dumped there is no reason to continue - * contiguous allocation, malloc doesn't depend on it. - * - * There is a further problem of using brk and sbrk while using VMS C - * run time library routines malloc, calloc, etc. The documentation - * says that this is a no-no, although I'm not sure why this would be - * a problem. In any case, we remove the necessity to call brk and - * sbrk, by calling calloc (to assure zero filled data) rather than - * sbrk. - * - * VMS_ALLOCATION_SIZE is the size of the allocation array. This - * should be larger than the malloc size before dumping. Making this - * too large will result in the startup procedure slowing down since - * it will require more space and time to map it in. - * - * The value for VMS_ALLOCATION_SIZE in the following define was determined - * by running emacs linked (and a large allocation) with the debugger and - * looking to see how much storage was used. The allocation was 201 pages, - * so I rounded it up to a power of two. - */ -#ifndef VMS_ALLOCATION_SIZE -#define VMS_ALLOCATION_SIZE (512*256) -#endif - -/* Use VMS RTL definitions */ -#undef sbrk -#undef brk -#undef malloc -int vms_out_initial = 0; -char vms_initial_buffer[VMS_ALLOCATION_SIZE]; -static char *vms_current_brk = &vms_initial_buffer; -static char *vms_end_brk = &vms_initial_buffer[VMS_ALLOCATION_SIZE-1]; - -#include <stdio.h> - -char * -sys_sbrk (incr) - int incr; -{ - char *sbrk(), *temp, *ptr; - - if (vms_out_initial) - { - /* out of initial allocation... */ - if (!(temp = malloc (incr))) - temp = (char *) -1; - } - else - { - /* otherwise, go out of our area */ - ptr = vms_current_brk + incr; /* new current_brk */ - if (ptr <= vms_end_brk) - { - temp = vms_current_brk; - vms_current_brk = ptr; - } - else - { - vms_out_initial = 1; /* mark as out of initial allocation */ - if (!(temp = malloc (incr))) - temp = (char *) -1; - } - } - return temp; -} -#endif /* VMS */
--- a/src/mule-coding.c Mon Aug 13 10:03:54 2007 +0200 +++ b/src/mule-coding.c Mon Aug 13 10:04:58 2007 +0200 @@ -960,7 +960,7 @@ return Qnil; /* not reached */ } -Lisp_Object coding_system_charset (coding_system, gnum) +Lisp_Object coding_system_charset (Lisp_Object coding_system, int gnum) { Lisp_Object cs = XCODING_SYSTEM_ISO2022_INITIAL_CHARSET (coding_system, gnum);
--- a/src/mule-mcpath.h Mon Aug 13 10:03:54 2007 +0200 +++ b/src/mule-mcpath.h Mon Aug 13 10:04:58 2007 +0200 @@ -41,12 +41,6 @@ #include <sys/types.h> #include <sys/stat.h> -#ifdef VMS -#include <string.h> -#include <rms.h> -#include <rmsdef.h> -#endif - /* The d_nameln member of a struct dirent includes the '\0' character on some systems, but not on others. What's worse, you can't tell at compile-time which one it will be, since it really depends on
--- a/src/ndir.h Mon Aug 13 10:03:54 2007 +0200 +++ b/src/ndir.h Mon Aug 13 10:04:58 2007 +0200 @@ -23,30 +23,12 @@ last edit: 09-Jul-1983 D A Gwyn */ -#ifdef VMS -#ifndef FAB$C_BID -#include <fab.h> -#endif -#ifndef NAM$C_BID -#include <nam.h> -#endif -#ifndef RMS$_SUC -#include <rmsdef.h> -#endif -#include "vms-dir.h" -#endif /* VMS */ - #define DIRBLKSIZ 512 /* size of directory block */ -#ifdef VMS -#define MAXNAMLEN (DIR$S_NAME + 7) /* 80 plus room for version #. */ -#define MAXFULLSPEC NAM$C_MAXRSS /* Maximum full spec */ -#else #ifdef WINDOWSNT #define MAXNAMLEN 255 #else /* not WINDOWSNT */ #define MAXNAMLEN 15 /* maximum filename length */ #endif /* not WINDOWSNT */ -#endif /* VMS */ /* NOTE: MAXNAMLEN must be one less than a multiple of 4 */ struct direct /* data from readdir() */
--- a/src/nt.c Mon Aug 13 10:03:54 2007 +0200 +++ b/src/nt.c Mon Aug 13 10:04:58 2007 +0200 @@ -22,7 +22,10 @@ Geoff Voelker (voelker@cs.washington.edu) 7-29-94 */ /* Adapted for XEmacs by David Hobley <david@spook-le0.cia.com.au> */ - +/* Sync'ed with Emacs 19.34.6 by Marc Paquette <marcpa@cam.org> */ + +#include <stddef.h> /* for offsetof */ +#include <string.h> #include <stdlib.h> #include <stdio.h> #include <io.h> @@ -81,13 +84,28 @@ #include <sys/dir.h> #include "ntheap.h" + +extern Lisp_Object Vwin32_downcase_file_names; +extern Lisp_Object Vwin32_generate_fake_inodes; +extern Lisp_Object Vwin32_get_true_file_attributes; + +static char startup_dir[ MAXPATHLEN ]; + /* Get the current working directory. */ char * getwd (char *dir) { +#if 0 if (GetCurrentDirectory (MAXPATHLEN, dir) > 0) return dir; return NULL; +#else + /* Emacs doesn't actually change directory itself, and we want to + force our real wd to be where emacs.exe is to avoid unnecessary + conflicts when trying to rename or delete directories. */ + strcpy (dir, startup_dir); + return dir; +#endif } #ifndef HAVE_SOCKETS @@ -115,105 +133,6 @@ return i; } -/* Emulate the Unix directory procedures opendir, closedir, - and readdir. We can't use the procedures supplied in sysdep.c, - so we provide them here. */ - -struct direct dir_static; /* simulated directory contents */ -static HANDLE dir_find_handle = INVALID_HANDLE_VALUE; -static int dir_is_fat; -static char dir_pathname[MAXPATHLEN+1]; - -extern Lisp_Object Vwin32_downcase_file_names; - -DIR * -opendir (char *filename) -{ - DIR *dirp; - - /* Opening is done by FindFirstFile. However, a read is inherent to - this operation, so we defer the open until read time. */ - - if (!(dirp = (DIR *) xmalloc (sizeof (DIR)))) - return NULL; - if (dir_find_handle != INVALID_HANDLE_VALUE) - return NULL; - - dirp->dd_fd = 0; - dirp->dd_loc = 0; - dirp->dd_size = 0; - - strncpy (dir_pathname, filename, MAXPATHLEN); - dir_pathname[MAXPATHLEN] = '\0'; - dir_is_fat = is_fat_volume (filename, NULL); - - return dirp; -} - -void -closedir (DIR *dirp) -{ - /* If we have a find-handle open, close it. */ - if (dir_find_handle != INVALID_HANDLE_VALUE) - { - FindClose (dir_find_handle); - dir_find_handle = INVALID_HANDLE_VALUE; - } - xfree ((char *) dirp); -} - -struct direct * -readdir (DIR *dirp) -{ - WIN32_FIND_DATA find_data; - - /* If we aren't dir_finding, do a find-first, otherwise do a find-next. */ - if (dir_find_handle == INVALID_HANDLE_VALUE) - { - char filename[MAXNAMLEN + 3]; - int ln; - - strcpy (filename, dir_pathname); - ln = strlen (filename) - 1; - if (!IS_DIRECTORY_SEP (filename[ln])) - strcat (filename, "\\"); - strcat (filename, "*"); - - dir_find_handle = FindFirstFile (filename, &find_data); - - if (dir_find_handle == INVALID_HANDLE_VALUE) - return NULL; - } - else - { - if (!FindNextFile (dir_find_handle, &find_data)) - return NULL; - } - - /* Emacs never uses this value, so don't bother making it match - value returned by stat(). */ - dir_static.d_ino = 1; - - dir_static.d_reclen = sizeof (struct direct) - MAXNAMLEN + 3 + - dir_static.d_namlen - dir_static.d_namlen % 4; - - dir_static.d_namlen = strlen (find_data.cFileName); - strcpy (dir_static.d_name, find_data.cFileName); - if (dir_is_fat) - _strlwr (dir_static.d_name); - else if (!NILP (Vwin32_downcase_file_names)) - { - REGISTER char *p; - for (p = dir_static.d_name; *p; p++) - if (*p >= 'a' && *p <= 'z') - break; - if (!*p) - _strlwr (dir_static.d_name); - } - - return &dir_static; -} - /* Emulate getpwuid, getpwnam and others. */ #define PASSWD_FIELD_SIZE 256 @@ -472,9 +391,10 @@ (From msdos.c...probably should figure out a way to share it, although this code isn't going to ever change.) */ int -crlf_to_lf (n, buf) +crlf_to_lf (n, buf, lf_count) REGISTER int n; REGISTER unsigned char *buf; + REGISTER unsigned *lf_count; { unsigned char *np = buf; unsigned char *startp = buf; @@ -484,6 +404,8 @@ return n; while (buf < endp - 1) { + if (*buf == 0x0a) + (*lf_count)++; if (*buf == 0x0d) { if (*(++buf) != 0x0a) @@ -493,10 +415,143 @@ *np++ = *buf++; } if (buf < endp) + { + if (*buf == 0x0a) + (*lf_count)++; *np++ = *buf++; + } return np - startp; } +/* Parse the root part of file name, if present. Return length and + optionally store pointer to char after root. */ +static int +parse_root (char * name, char ** pPath) +{ + char * start = name; + + if (name == NULL) + return 0; + + /* find the root name of the volume if given */ + if (isalpha (name[0]) && name[1] == ':') + { + /* skip past drive specifier */ + name += 2; + if (IS_DIRECTORY_SEP (name[0])) + name++; + } + else if (IS_DIRECTORY_SEP (name[0]) && IS_DIRECTORY_SEP (name[1])) + { + int slashes = 2; + name += 2; + do + { + if (IS_DIRECTORY_SEP (*name) && --slashes == 0) + break; + name++; + } + while ( *name ); + if (IS_DIRECTORY_SEP (name[0])) + name++; + } + + if (pPath) + *pPath = name; + + return name - start; +} + +/* Get long base name for name; name is assumed to be absolute. */ +static int +get_long_basename (char * name, char * buf, int size) +{ + WIN32_FIND_DATA find_data; + HANDLE dir_handle; + int len = 0; +#ifdef PIGSFLY + char *p; + + /* If the last component of NAME has a wildcard character, + return it as the basename. */ + p = name + strlen (name); + while (*p != '\\' && *p != ':' && p > name) p--; + if (p > name) p++; + if (strchr (p, '*') || strchr (p, '?')) + { + if ((len = strlen (p)) < size) + memcpy (buf, p, len + 1); + else + len = 0; + return len; + } +#endif + + dir_handle = FindFirstFile (name, &find_data); + if (dir_handle != INVALID_HANDLE_VALUE) + { + if ((len = strlen (find_data.cFileName)) < size) + memcpy (buf, find_data.cFileName, len + 1); + else + len = 0; + FindClose (dir_handle); + } + return len; +} + +/* Get long name for file, if possible (assumed to be absolute). */ +BOOL +win32_get_long_filename (char * name, char * buf, int size) +{ + char * o = buf; + char * p; + char * q; + char full[ MAX_PATH ]; + int len; + + len = strlen (name); + if (len >= MAX_PATH) + return FALSE; + + /* Use local copy for destructive modification. */ + memcpy (full, name, len+1); + unixtodos_filename (full); + + /* Copy root part verbatim. */ + len = parse_root (full, &p); + memcpy (o, full, len); + o += len; + size -= len; + + do + { + q = p; + p = strchr (q, '\\'); + if (p) *p = '\0'; + len = get_long_basename (full, o, size); + if (len > 0) + { + o += len; + size -= len; + if (p != NULL) + { + *p++ = '\\'; + if (size < 2) + return FALSE; + *o++ = '\\'; + size--; + *o = '\0'; + } + } + else + return FALSE; + } + while (p != NULL && *p); + + return TRUE; +} + + /* Routines that are no-ops on NT but are defined to get Emacs to compile. */ int @@ -601,10 +656,13 @@ "emacs_dir", "EMACSLOADPATH", "SHELL", + "CMDPROXY", "EMACSDATA", "EMACSPATH", "EMACSLOCKDIR", - "INFOPATH", + /* We no longer set INFOPATH because Info-default-directory-list + is then ignored. We use a hook in winnt.el instead. */ + /* "INFOPATH", */ "EMACSDOC", "TERM", }; @@ -635,6 +693,45 @@ } } + /* Another special case: on NT, the PATH variable is actually named + "Path" although cmd.exe (perhaps NT itself) arranges for + environment variable lookup and setting to be case insensitive. + However, Emacs assumes a fully case sensitive environment, so we + need to change "Path" to "PATH" to match the expectations of + various elisp packages. We do this by the sneaky method of + modifying the string in the C runtime environ entry. + + The same applies to COMSPEC. */ + { + char ** envp; + + for (envp = environ; *envp; envp++) + if (_strnicmp (*envp, "PATH=", 5) == 0) + memcpy (*envp, "PATH=", 5); + else if (_strnicmp (*envp, "COMSPEC=", 8) == 0) + memcpy (*envp, "COMSPEC=", 8); + } + + /* Remember the initial working directory for getwd, then make the + real wd be the location of emacs.exe to avoid conflicts when + renaming or deleting directories. (We also don't call chdir when + running subprocesses for the same reason.) */ + if (!GetCurrentDirectory (MAXPATHLEN, startup_dir)) + abort (); + + { + char *p; + char modname[MAX_PATH]; + + if (!GetModuleFileName (NULL, modname, MAX_PATH)) + abort (); + if ((p = strrchr (modname, '\\')) == NULL) + abort (); + *p = 0; + + SetCurrentDirectory (modname); + } + init_user_info (); } @@ -756,13 +853,152 @@ /* parallel array of private info on file handles */ filedesc fd_info [ MAXDESC ]; -static struct { +typedef struct volume_info_data { + struct volume_info_data * next; + + /* time when info was obtained */ + DWORD timestamp; + + /* actual volume info */ + char * root_dir; DWORD serialnum; DWORD maxcomp; DWORD flags; - char name[32]; - char type[32]; -} volume_info; + char * name; + char * type; +} volume_info_data; + +/* Global referenced by various functions. */ +static volume_info_data volume_info; + +/* Vector to indicate which drives are local and fixed (for which cached + data never expires). */ +static BOOL fixed_drives[26]; + +/* Consider cached volume information to be stale if older than 10s, + at least for non-local drives. Info for fixed drives is never stale. */ +#define DRIVE_INDEX( c ) ( (c) <= 'Z' ? (c) - 'A' : (c) - 'a' ) +#define VOLINFO_STILL_VALID( root_dir, info ) \ + ( ( isalpha (root_dir[0]) && \ + fixed_drives[ DRIVE_INDEX (root_dir[0]) ] ) \ + || GetTickCount () - info->timestamp < 10000 ) + +/* Cache support functions. */ + +/* Simple linked list with linear search is sufficient. */ +static volume_info_data *volume_cache = NULL; + +static volume_info_data * +lookup_volume_info (char * root_dir) +{ + volume_info_data * info; + + for (info = volume_cache; info; info = info->next) + if (stricmp (info->root_dir, root_dir) == 0) + break; + return info; +} + +static void +add_volume_info (char * root_dir, volume_info_data * info) +{ + info->root_dir = xstrdup (root_dir); + info->next = volume_cache; + volume_cache = info; +} + + +/* Wrapper for GetVolumeInformation, which uses caching to avoid + performance penalty (~2ms on 486 for local drives, 7.5ms for local + cdrom drive, ~5-10ms or more for remote drives on LAN). */ +volume_info_data * +GetCachedVolumeInformation (char * root_dir) +{ + volume_info_data * info; + char default_root[ MAX_PATH ]; + + /* NULL for root_dir means use root from current directory. */ + if (root_dir == NULL) + { + if (GetCurrentDirectory (MAX_PATH, default_root) == 0) + return NULL; + parse_root (default_root, &root_dir); + *root_dir = 0; + root_dir = default_root; + } + + /* Local fixed drives can be cached permanently. Removable drives + cannot be cached permanently, since the volume name and serial + number (if nothing else) can change. Remote drives should be + treated as if they are removable, since there is no sure way to + tell whether they are or not. Also, the UNC association of drive + letters mapped to remote volumes can be changed at any time (even + by other processes) without notice. + + As a compromise, so we can benefit from caching info for remote + volumes, we use a simple expiry mechanism to invalidate cache + entries that are more than ten seconds old. */ + +#if 0 + /* No point doing this, because WNetGetConnection is even slower than + GetVolumeInformation, consistently taking ~50ms on a 486 (FWIW, + GetDriveType is about the only call of this type which does not + involve network access, and so is extremely quick). */ + + /* Map drive letter to UNC if remote. */ + if ( isalpha( root_dir[0] ) && !fixed[ DRIVE_INDEX( root_dir[0] ) ] ) + { + char remote_name[ 256 ]; + char drive[3] = { root_dir[0], ':' }; + + if (WNetGetConnection (drive, remote_name, sizeof (remote_name)) + == NO_ERROR) + /* do something */ ; + } +#endif + + info = lookup_volume_info (root_dir); + + if (info == NULL || ! VOLINFO_STILL_VALID (root_dir, info)) + { + char name[ 256 ]; + DWORD serialnum; + DWORD maxcomp; + DWORD flags; + char type[ 256 ]; + + /* Info is not cached, or is stale. */ + if (!GetVolumeInformation (root_dir, + name, sizeof (name), + &serialnum, + &maxcomp, + &flags, + type, sizeof (type))) + return NULL; + + /* Cache the volume information for future use, overwriting existing + entry if present. */ + if (info == NULL) + { + info = (volume_info_data *) xmalloc (sizeof (volume_info_data)); + add_volume_info (root_dir, info); + } + else + { + free (info->name); + free (info->type); + } + + info->name = xstrdup (name); + info->serialnum = serialnum; + info->maxcomp = maxcomp; + info->flags = flags; + info->type = xstrdup (type); + info->timestamp = GetTickCount (); + } + + return info; +} /* Get information on the volume where name is held; set path pointer to start of pathname in name (past UNC header\volume header if present). */ @@ -771,6 +1007,7 @@ { char temp[MAX_PATH]; char *rootname = NULL; /* default to current volume */ + volume_info_data * info; if (name == NULL) return FALSE; @@ -804,13 +1041,11 @@ if (pPath) *pPath = name; - if (GetVolumeInformation (rootname, - volume_info.name, 32, - &volume_info.serialnum, - &volume_info.maxcomp, - &volume_info.flags, - volume_info.type, 32)) + info = GetCachedVolumeInformation (rootname); + if (info != NULL) { + /* Set global referenced by other functions. */ + volume_info = *info; return TRUE; } return FALSE; @@ -834,6 +1069,7 @@ char * str = shortname; char c; char * path; + const char * save_name = name; if (is_fat_volume (name, &path)) /* truncate to 8.3 */ { @@ -918,12 +1154,108 @@ } if (pPath) - *pPath = shortname + (path - name); + *pPath = shortname + (path - save_name); return shortname; } +/* Emulate the Unix directory procedures opendir, closedir, + and readdir. We can't use the procedures supplied in sysdep.c, + so we provide them here. */ + +struct direct dir_static; /* simulated directory contents */ +static HANDLE dir_find_handle = INVALID_HANDLE_VALUE; +static int dir_is_fat; +static char dir_pathname[MAXPATHLEN+1]; +static WIN32_FIND_DATA dir_find_data; + +DIR * +opendir (char *filename) +{ + DIR *dirp; + + /* Opening is done by FindFirstFile. However, a read is inherent to + this operation, so we defer the open until read time. */ + + if (!(dirp = (DIR *) xmalloc (sizeof (DIR)))) + return NULL; + if (dir_find_handle != INVALID_HANDLE_VALUE) + return NULL; + + dirp->dd_fd = 0; + dirp->dd_loc = 0; + dirp->dd_size = 0; + + strncpy (dir_pathname, map_win32_filename (filename, NULL), MAXPATHLEN); + dir_pathname[MAXPATHLEN] = '\0'; + dir_is_fat = is_fat_volume (filename, NULL); + + return dirp; +} + +void +closedir (DIR *dirp) +{ + /* If we have a find-handle open, close it. */ + if (dir_find_handle != INVALID_HANDLE_VALUE) + { + FindClose (dir_find_handle); + dir_find_handle = INVALID_HANDLE_VALUE; + } + xfree ((char *) dirp); +} + +struct direct * +readdir (DIR *dirp) +{ + /* If we aren't dir_finding, do a find-first, otherwise do a find-next. */ + if (dir_find_handle == INVALID_HANDLE_VALUE) + { + char filename[MAXNAMLEN + 3]; + int ln; + + strcpy (filename, dir_pathname); + ln = strlen (filename) - 1; + if (!IS_DIRECTORY_SEP (filename[ln])) + strcat (filename, "\\"); + strcat (filename, "*"); + + dir_find_handle = FindFirstFile (filename, &dir_find_data); + + if (dir_find_handle == INVALID_HANDLE_VALUE) + return NULL; + } + else + { + if (!FindNextFile (dir_find_handle, &dir_find_data)) + return NULL; + } + + /* Emacs never uses this value, so don't bother making it match + value returned by stat(). */ + dir_static.d_ino = 1; + + dir_static.d_reclen = sizeof (struct direct) - MAXNAMLEN + 3 + + dir_static.d_namlen - dir_static.d_namlen % 4; + + dir_static.d_namlen = strlen (dir_find_data.cFileName); + strcpy (dir_static.d_name, dir_find_data.cFileName); + if (dir_is_fat) + _strlwr (dir_static.d_name); + else if (!NILP (Vwin32_downcase_file_names)) + { + REGISTER char *p; + for (p = dir_static.d_name; *p; p++) + if (*p >= 'a' && *p <= 'z') + break; + if (!*p) + _strlwr (dir_static.d_name); + } + + return &dir_static; +} + /* Shadow some MSVC runtime functions to map requests for long filenames to reasonable short names if necessary. This was originally added to permit running Emacs on NT 3.1 on a FAT partition, which doesn't support @@ -994,16 +1326,82 @@ if (fd < 0) return NULL; - return fdopen (fd, mode_save); + return _fdopen (fd, mode_save); } +/* This only works on NTFS volumes, but is useful to have. */ int -sys_link (const char * path1, const char * path2) +sys_link (const char * old, const char * new) +{ + HANDLE fileh; + int result = -1; + char oldname[MAX_PATH], newname[MAX_PATH]; + + if (old == NULL || new == NULL) { - errno = EINVAL; + errno = ENOENT; return -1; } + strcpy (oldname, map_win32_filename (old, NULL)); + strcpy (newname, map_win32_filename (new, NULL)); + + fileh = CreateFile (oldname, 0, 0, NULL, OPEN_EXISTING, + FILE_FLAG_BACKUP_SEMANTICS, NULL); + if (fileh != INVALID_HANDLE_VALUE) + { + int wlen; + + /* Confusingly, the "alternate" stream name field does not apply + when restoring a hard link, and instead contains the actual + stream data for the link (ie. the name of the link to create). + The WIN32_STREAM_ID structure before the cStreamName field is + the stream header, which is then immediately followed by the + stream data. */ + + struct { + WIN32_STREAM_ID wid; + WCHAR wbuffer[MAX_PATH]; /* extra space for link name */ + } data; + + wlen = MultiByteToWideChar (CP_ACP, MB_PRECOMPOSED, newname, -1, + data.wid.cStreamName, MAX_PATH); + if (wlen > 0) + { + LPVOID context = NULL; + DWORD wbytes = 0; + + data.wid.dwStreamId = BACKUP_LINK; + data.wid.dwStreamAttributes = 0; + data.wid.Size.LowPart = wlen * sizeof(WCHAR); + data.wid.Size.HighPart = 0; + data.wid.dwStreamNameSize = 0; + + if (BackupWrite (fileh, (LPBYTE)&data, + offsetof (WIN32_STREAM_ID, cStreamName) + + data.wid.Size.LowPart, + &wbytes, FALSE, FALSE, &context) + && BackupWrite (fileh, NULL, 0, &wbytes, TRUE, FALSE, &context)) + { + /* succeeded */ + result = 0; + } + else + { + /* Should try mapping GetLastError to errno; for now just + indicate a general error (eg. links not supported). */ + errno = EINVAL; // perhaps EMLINK? + } + } + + CloseHandle (fileh); + } + else + errno = ENOENT; + + return result; +} + int sys_mkdir (const char * path) { @@ -1096,11 +1494,10 @@ p++; else p = temp; - strcpy (p, "__XXXXXX"); - sys_mktemp (temp); /* Force temp name to require a manufactured 8.3 alias - this seems to make the second rename work properly. */ - strcat (temp, ".long"); + strcpy (p, "_rename_temp.XXXXXX"); + sys_mktemp (temp); if (rename (map_win32_filename (oldname, NULL), temp) < 0) return -1; } @@ -1110,6 +1507,9 @@ 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! */ newname = map_win32_filename (newname, NULL); + + /* TODO: Use GetInformationByHandle (on NT) to ensure newname and temp + do not refer to the same file, eg. through share aliases. */ if (stricmp (newname, temp) != 0 && (attr = GetFileAttributes (newname)) != -1 && (attr & FILE_ATTRIBUTE_DIRECTORY) == 0) @@ -1202,38 +1602,49 @@ } #endif -/* "PJW" algorithm (see the "Dragon" compiler book). */ +#if 0 +/* No reason to keep this; faking inode values either by hashing or even + using the file index from GetInformationByHandle, is not perfect and + so by default Emacs doesn't use the inode values on Windows. + Instead, we now determine file-truename correctly (except for + possible drive aliasing etc). */ + +/* Modified version of "PJW" algorithm (see the "Dragon" compiler book). */ static unsigned -hashval (const char * str) +hashval (const unsigned char * str) { unsigned h = 0; - unsigned g; while (*str) { h = (h << 4) + *str++; - if ((g = h & 0xf0000000) != 0) - h = (h ^ (g >> 24)) & 0x0fffffff; + h ^= (h >> 28); } return h; } /* Return the hash value of the canonical pathname, excluding the drive/UNC header, to get a hopefully unique inode number. */ -static _ino_t +static DWORD generate_inode_val (const char * name) { char fullname[ MAX_PATH ]; char * p; unsigned hash; - GetFullPathName (name, sizeof (fullname), fullname, &p); - get_volume_info (fullname, &p); + /* Get the truly canonical filename, if it exists. (Note: this + doesn't resolve aliasing due to subst commands, or recognise hard + links. */ + if (!win32_get_long_filename ((char *)name, fullname, MAX_PATH)) + abort (); + + parse_root (fullname, &p); /* Normal Win32 filesystems are still case insensitive. */ _strlwr (p); - hash = hashval (p); - return (_ino_t) (hash ^ (hash >> 16)); + return hashval (p); } +#endif + /* MSVC stat function can't cope with UNC names and has other bugs, so replace it with our own. This also allows us to calculate consistent inode values without hacks in the main Emacs code. */ @@ -1243,6 +1654,7 @@ char * name; WIN32_FIND_DATA wfd; HANDLE fh; + DWORD fake_inode; int permission; int len; int rootdir = FALSE; @@ -1289,6 +1701,21 @@ { if (IS_DIRECTORY_SEP (name[len-1])) name[len - 1] = 0; + + /* (This is hacky, but helps when doing file completions on + network drives.) Optimize by using information available from + active readdir if possible. */ + if (dir_find_handle != INVALID_HANDLE_VALUE && + (len = strlen (dir_pathname)), + strnicmp (name, dir_pathname, len) == 0 && + IS_DIRECTORY_SEP (name[len]) && + stricmp (name + len + 1, dir_static.d_name) == 0) + { + /* This was the last entry returned by readdir. */ + wfd = dir_find_data; + } + else + { fh = FindFirstFile (name, &wfd); if (fh == INVALID_HANDLE_VALUE) { @@ -1297,22 +1724,23 @@ } FindClose (fh); } + } if (wfd.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) { buf->st_mode = _S_IFDIR; buf->st_nlink = 2; /* doesn't really matter */ + fake_inode = 0; /* this doesn't either I think */ } - else + else if (!NILP (Vwin32_get_true_file_attributes)) { -#if 0 /* This is more accurate in terms of gettting the correct number of links, but is quite slow (it is noticable when Emacs is making a list of file name completions). */ BY_HANDLE_FILE_INFORMATION info; - fh = CreateFile (name, GENERIC_READ, FILE_SHARE_READ | FILE_SHARE_WRITE, - NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); + /* No access rights required to get info. */ + fh = CreateFile (name, 0, 0, NULL, OPEN_EXISTING, 0, NULL); if (GetFileInformationByHandle (fh, &info)) { @@ -1330,9 +1758,12 @@ buf->st_mode = _S_IFCHR; } buf->st_nlink = info.nNumberOfLinks; - /* Could use file index, but this is not guaranteed to be - unique unless we keep a handle open all the time. */ - /* buf->st_ino = info.nFileIndexLow ^ info.nFileIndexHigh; */ + /* Might as well use file index to fake inode values, but this + is not guaranteed to be unique unless we keep a handle open + all the time (even then there are situations where it is + not unique). Reputedly, there are at most 48 bits of info + (on NTFS, presumably less on FAT). */ + fake_inode = info.nFileIndexLow ^ info.nFileIndexHigh; CloseHandle (fh); } else @@ -1340,11 +1771,32 @@ errno = EACCES; return -1; } -#else + } + else + { + /* Don't bother to make this information more accurate. */ buf->st_mode = _S_IFREG; buf->st_nlink = 1; + fake_inode = 0; + } + +#if 0 + /* Not sure if there is any point in this. */ + if (!NILP (Vwin32_generate_fake_inodes)) + fake_inode = generate_inode_val (name); + else if (fake_inode == 0) + { + /* For want of something better, try to make everything unique. */ + static DWORD gen_num = 0; + fake_inode = ++gen_num; + } #endif - } + + /* MSVC defines _ino_t to be short; other libc's might not. */ + if (sizeof (buf->st_ino) == 2) + buf->st_ino = fake_inode ^ (fake_inode >> 16); + else + buf->st_ino = fake_inode; /* consider files to belong to current user */ buf->st_uid = the_passwd.pw_uid; @@ -1354,7 +1806,6 @@ buf->st_dev = volume_info.serialnum; buf->st_rdev = volume_info.serialnum; - buf->st_ino = generate_inode_val (name); buf->st_size = wfd.nFileSizeLow; @@ -1899,42 +2350,22 @@ unsigned flags; child_process * cp; - /* make pipe handles non-inheritable; when we spawn a child, - we replace the relevant handle with an inheritable one. */ - rc = _pipe (phandles, 0, _O_NOINHERIT); + /* make pipe handles non-inheritable; when we spawn a child, we + replace the relevant handle with an inheritable one. Also put + pipes into binary mode; we will do text mode translation ourselves + if required. */ + rc = _pipe (phandles, 0, _O_NOINHERIT | _O_BINARY); if (rc == 0) { - /* set internal flags, and put read and write handles into binary - mode as necessary; if not in binary mode, set the MSVC internal - FDEV (0x40) flag to prevent _read from treating ^Z as eof (this - could otherwise allow Emacs to hang because it then waits - indefinitely for the child process to exit, when it might not be - finished). */ flags = FILE_PIPE | FILE_READ; if (!NILP (Vbinary_process_output)) - { flags |= FILE_BINARY; - setmode (phandles[0], _O_BINARY); - } -#if (_MSC_VER == 900) - else - _osfile[phandles[0]] |= 0x40; -#endif - fd_info[phandles[0]].flags = flags; flags = FILE_PIPE | FILE_WRITE; if (!NILP (Vbinary_process_input)) - { flags |= FILE_BINARY; - setmode (phandles[1], _O_BINARY); - } -#if (_MSC_VER == 900) - else - _osfile[phandles[1]] |= 0x40; -#endif - fd_info[phandles[1]].flags = flags; } @@ -1971,7 +2402,6 @@ if (fd_info[fd].flags & FILE_PIPE) { - /* Use read to get CRLF translation */ rc = _read (fd, &cp->chr, sizeof (char)); /* Give subprocess time to buffer some more output for us before @@ -2011,9 +2441,9 @@ sys_read (int fd, char * buffer, unsigned int count) { int nchars; - int extra = 0; int to_read; DWORD waiting; + char * orig_buffer = buffer; if (fd < 0 || fd >= MAXDESC) { @@ -2031,6 +2461,18 @@ return -1; } + nchars = 0; + + /* re-read CR carried over from last read */ + if (fd_info[fd].flags & FILE_LAST_CR) + { + if (fd_info[fd].flags & FILE_BINARY) abort (); + *buffer++ = 0x0d; + count--; + nchars++; + fd_info[fd].flags &= ~FILE_LAST_CR; + } + /* presence of a child_process structure means we are operating in non-blocking mode - otherwise we just call _read directly. Note that the child_process structure might be missing because @@ -2044,8 +2486,10 @@ { case STATUS_READ_FAILED: case STATUS_READ_ERROR: - /* report normal EOF */ - return 0; + /* report normal EOF if nothing in buffer */ + if (nchars <= 0) + fd_info[fd].flags |= FILE_AT_EOF; + return nchars; case STATUS_READ_READY: case STATUS_READ_IN_PROGRESS: @@ -2057,7 +2501,7 @@ /* consume read-ahead char */ *buffer++ = cp->chr; count--; - extra = 1; + nchars++; cp->status = STATUS_READ_ACKNOWLEDGED; ResetEvent (cp->char_avail); @@ -2075,8 +2519,8 @@ PeekNamedPipe ((HANDLE) _get_osfhandle (fd), NULL, 0, NULL, &waiting, NULL); to_read = min (waiting, (DWORD) count); - /* Use read to get CRLF translation */ - nchars = _read (fd, buffer, to_read); + if (to_read > 0) + nchars += _read (fd, buffer, to_read); } #ifdef HAVE_SOCKETS else /* FILE_SOCKET */ @@ -2085,39 +2529,59 @@ /* do the equivalent of a non-blocking read */ pfn_ioctlsocket (SOCK_HANDLE (fd), FIONREAD, &waiting); - if (waiting == 0 && extra == 0) + if (waiting == 0 && nchars == 0) { h_errno = errno = EWOULDBLOCK; return -1; } - nchars = 0; if (waiting) { /* always use binary mode for sockets */ - nchars = pfn_recv (SOCK_HANDLE (fd), buffer, count, 0); - if (nchars == SOCKET_ERROR) + int res = pfn_recv (SOCK_HANDLE (fd), buffer, count, 0); + if (res == SOCKET_ERROR) { DebPrint(("sys_read.recv failed with error %d on socket %ld\n", pfn_WSAGetLastError (), SOCK_HANDLE (fd))); - if (extra == 0) - { set_errno (); return -1; } - nchars = 0; - } + nchars += res; } } #endif } else - nchars = _read (fd, buffer, count); + { + int nread = _read (fd, buffer, count); + if (nread >= 0) + nchars += nread; + else if (nchars == 0) + nchars = nread; + } + + if (nchars <= 0) + fd_info[fd].flags |= FILE_AT_EOF; + /* Perform text mode translation if required. */ + else if ((fd_info[fd].flags & FILE_BINARY) == 0) + { + unsigned lf_count = 0; + nchars = crlf_to_lf (nchars, orig_buffer, &lf_count); + /* If buffer contains only CR, return that. To be absolutely + sure we should attempt to read the next char, but in + practice a CR to be followed by LF would not appear by + itself in the buffer. */ + if (nchars > 1 && orig_buffer[nchars - 1] == 0x0d) + { + fd_info[fd].flags |= FILE_LAST_CR; + nchars--; + } + } } else nchars = _read (fd, buffer, count); - return nchars + extra; + return nchars; } /* For now, don't bother with a non-blocking mode */ @@ -2133,11 +2597,46 @@ } if (fd_info[fd].flags & (FILE_PIPE | FILE_SOCKET)) + { if ((fd_info[fd].flags & FILE_WRITE) == 0) { errno = EBADF; return -1; } + + /* Perform text mode translation if required. */ + if ((fd_info[fd].flags & FILE_BINARY) == 0) + { + char * tmpbuf = alloca (count * 2); + unsigned char * src = (void *)buffer; + unsigned char * dst = tmpbuf; + int nbytes = count; + + while (1) + { + unsigned char *next; + /* copy next line or remaining bytes */ + next = _memccpy (dst, src, '\n', nbytes); + if (next) + { + /* copied one line ending with '\n' */ + int copied = next - dst; + nbytes -= copied; + src += copied; + /* insert '\r' before '\n' */ + next[-1] = '\r'; + next[0] = '\n'; + dst = next + 1; + count++; + } + else + /* copied remaining partial line -> now finished */ + break; + } + buffer = tmpbuf; + } + } + #ifdef HAVE_SOCKETS if (fd_info[fd].flags & FILE_SOCKET) { @@ -2167,8 +2666,6 @@ #endif } -extern BOOL dos_process_running; - void init_ntproc () { @@ -2232,40 +2729,41 @@ _open_osfhandle ((long) stdin_save, O_TEXT); else _open ("nul", O_TEXT | O_NOINHERIT | O_RDONLY); - fdopen (0, "r"); + _fdopen (0, "r"); if (stdout_save != INVALID_HANDLE_VALUE) _open_osfhandle ((long) stdout_save, O_TEXT); else _open ("nul", O_TEXT | O_NOINHERIT | O_WRONLY); - fdopen (1, "w"); + _fdopen (1, "w"); if (stderr_save != INVALID_HANDLE_VALUE) _open_osfhandle ((long) stderr_save, O_TEXT); else _open ("nul", O_TEXT | O_NOINHERIT | O_WRONLY); - fdopen (2, "w"); + _fdopen (2, "w"); } - /* Restrict Emacs to running only one DOS program at a time (with any - number of Win32 programs). This is to prevent the user from - running into problems with DOS programs being run in the same VDM - under both Windows 95 and Windows NT. - - Note that it is possible for Emacs to run DOS programs in separate - VDMs, but unfortunately the pipe implementation on Windows 95 then - fails to report when the DOS process exits (which is supposed to - break the pipe). Until this bug is fixed, or we can devise a - work-around, we must try to avoid letting the user start more than - one DOS program if possible. */ - - dos_process_running = FALSE; - /* unfortunately, atexit depends on implementation of malloc */ /* atexit (term_ntproc); */ signal (SIGABRT, term_ntproc); + + /* determine which drives are fixed, for GetCachedVolumeInformation */ + { + /* GetDriveType must have trailing backslash. */ + char drive[] = "A:\\"; + + /* Loop over all possible drive letters */ + while ( *drive <= 'Z' ) + { + /* Record if this drive letter refers to a fixed drive. */ + fixed_drives[ DRIVE_INDEX (*drive) ] = + (GetDriveType (drive) == DRIVE_FIXED); + + (*drive)++; + } + } } - #ifndef HAVE_TTY Lisp_Object Vstdio_str;
--- a/src/nt.h Mon Aug 13 10:03:54 2007 +0200 +++ b/src/nt.h Mon Aug 13 10:04:58 2007 +0200 @@ -22,6 +22,7 @@ Boston, MA 02111-1307, USA. */ /* Adapted for XEmacs by David Hobley <david@spook-le0.cia.com.au> */ +/* Sync'ed with Emacs 19.34.6 by Marc Paquette <marcpa@cam.org> */ /* #define FULL_DEBUG */ #define EMACSDEBUG @@ -81,10 +82,10 @@ { int fd; int pid; - int is_dos_process; HANDLE char_avail; HANDLE char_consumed; HANDLE thrd; + HWND hwnd; PROCESS_INFORMATION procinfo; volatile int status; char chr; @@ -108,6 +109,9 @@ #define FILE_READ 0x0001 #define FILE_WRITE 0x0002 #define FILE_BINARY 0x0010 +#define FILE_LAST_CR 0x0020 +#define FILE_AT_EOF 0x0040 +#define FILE_SEND_SIGCHLD 0x0080 #define FILE_PIPE 0x0100 #define FILE_SOCKET 0x0200 @@ -116,6 +120,8 @@ /* ------------------------------------------------------------------------- */ +/* Get long (aka "true") form of file name, if it exists. */ +extern BOOL win32_get_long_filename (char * name, char * buf, int size); /* Prepare our standard handles for proper inheritance by child processes. */ extern void prepare_standard_handles (int in, int out,
--- a/src/ntheap.c Mon Aug 13 10:03:54 2007 +0200 +++ b/src/ntheap.c Mon Aug 13 10:04:58 2007 +0200 @@ -21,6 +21,7 @@ Geoff Voelker (voelker@cs.washington.edu) 7-29-94 */ /* Adapted for XEmacs by David Hobley <david@spook-le0.cia.com.au> */ +/* Synced with FSF Emacs 19.34.6 by Marc Paquette <marcpa@cam.org> */ #include "config.h" @@ -42,6 +43,9 @@ int nt_major_version; int nt_minor_version; +/* Distinguish between Windows NT and Windows 95. */ +int os_subtype; + /* Cache information describing the NT system for later use. */ void cache_system_info (void) @@ -62,6 +66,11 @@ nt_major_version = version.info.major; nt_minor_version = version.info.minor; + if (version.info.platform & 0x8000) + os_subtype = OS_WIN95; + else + os_subtype = OS_NT; + /* Cache page size, allocation unit, processor type, etc. */ GetSystemInfo (&sysinfo_cache); syspage_mask = sysinfo_cache.dwPageSize - 1; @@ -271,8 +280,10 @@ any funny interactions between file I/O and file mapping. */ read_in_bss (executable_path); map_in_heap (executable_path); + + /* Update system version information to match current system. */ + cache_system_info (); } - #endif /* CANNOT_DUMP */ /* Round the heap up to the given alignment. */ @@ -288,3 +299,26 @@ if (need_to_alloc) sbrk (need_to_alloc); } + +#if (_MSC_VER >= 1000) + +/* MSVC 4.2 invokes these functions from mainCRTStartup to initialize + a heap via HeapCreate. They are normally defined by the runtime, + but we override them here so that the unnecessary HeapCreate call + is not performed. */ + +int __cdecl +_heap_init (void) +{ + /* Stepping through the assembly indicates that mainCRTStartup is + expecting a nonzero success return value. */ + return 1; +} + +void __cdecl +_heap_term (void) +{ + return; +} + +#endif
--- a/src/ntheap.h Mon Aug 13 10:03:54 2007 +0200 +++ b/src/ntheap.h Mon Aug 13 10:04:58 2007 +0200 @@ -21,6 +21,7 @@ Geoff Voelker (voelker@cs.washington.edu) 7-29-94 */ /* Adapted for XEmacs by David Hobley <david@spook-le0.cia.com.au> */ +/* Synced with FSF Emacs 19.34.6 by Marc Paquette <marcpa@cam.org> */ #ifndef NTHEAP_H_ #define NTHEAP_H_ @@ -53,6 +54,13 @@ #define UNINIT_PTR ((void *) 0xF0A0F0A0) #define UNINIT_LONG (0xF0A0F0A0L) +enum { + OS_WIN95 = 1, + OS_NT +}; + +extern int os_subtype; + /* Emulation of Unix sbrk(). */ extern void *sbrk (unsigned long size); @@ -75,4 +83,37 @@ extern unsigned char *round_to_next (unsigned char *address, unsigned long align); +/* ----------------------------------------------------------------- */ +/* Useful routines for manipulating memory-mapped files. */ + +typedef struct file_data { + char *name; + unsigned long size; + HANDLE file; + HANDLE file_mapping; + unsigned char *file_base; +} file_data; + +#define OFFSET_TO_RVA(var,section) \ + (section->VirtualAddress + ((DWORD)(var) - section->PointerToRawData)) + +#define RVA_TO_OFFSET(var,section) \ + (section->PointerToRawData + ((DWORD)(var) - section->VirtualAddress)) + +#define RVA_TO_PTR(var,section,filedata) \ + ((void *)(RVA_TO_OFFSET(var,section) + (filedata).file_base)) + +int open_input_file (file_data *p_file, char *name); +int open_output_file (file_data *p_file, char *name, unsigned long size); +void close_file_data (file_data *p_file); + +unsigned long get_section_size (PIMAGE_SECTION_HEADER p_section); + +/* Return pointer to section header for named section. */ +IMAGE_SECTION_HEADER * find_section (char * name, IMAGE_NT_HEADERS * nt_header); + +/* Return pointer to section header for section containing the given + relative virtual address. */ +IMAGE_SECTION_HEADER * rva_to_section (DWORD rva, IMAGE_NT_HEADERS * nt_header); + #endif /* NTHEAP_H_ */
--- a/src/ntproc.c Mon Aug 13 10:03:54 2007 +0200 +++ b/src/ntproc.c Mon Aug 13 10:04:58 2007 +0200 @@ -22,6 +22,7 @@ Adapted from alarm.c by Tim Fleehart */ /* Adapted for XEmacs by David Hobley <david@spook-le0.cia.com.au> */ +/* Synced with FSF Emacs 19.34.6 by Marc Paquette <marcpa@cam.org> */ #include <stdio.h> #include <stdlib.h> @@ -42,9 +43,11 @@ #include "lisp.h" #include "nt.h" +#include "ntheap.h" /* From 19.34.6 */ #include "systime.h" #include "syswait.h" #include "process.h" +/*#include "w32term.h"*/ /* From 19.34.6: sync in ? --marcpa */ /* Control whether spawnve quotes arguments as necessary to ensure correct parsing by child process. Because not all uses of spawnve @@ -52,6 +55,16 @@ conditional (off by default). */ Lisp_Object Vwin32_quote_process_args; +/* Control whether create_child causes the process' window to be + hidden. The default is nil. */ +Lisp_Object Vwin32_start_process_show_window; + +/* Control whether create_child causes the process to inherit Emacs' + console window, or be given a new one of its own. The default is + nil, to allow multiple DOS programs to run on Win95. Having separate + consoles also allows Emacs to cleanly terminate process groups. */ +Lisp_Object Vwin32_start_process_share_console; + /* Time to sleep before reading from a subprocess output pipe - this avoids the inefficiency of frequently reading small amounts of data. This is primarily necessary for handling DOS processes on Windows 95, @@ -62,8 +75,18 @@ nil means no, t means yes. */ Lisp_Object Vwin32_downcase_file_names; -/* Keep track of whether we have already started a DOS program. */ -BOOL dos_process_running; +/* Control whether stat() attempts to generate fake but hopefully + "accurate" inode values, by hashing the absolute truenames of files. + This should detect aliasing between long and short names, but still + allows the possibility of hash collisions. */ +Lisp_Object Vwin32_generate_fake_inodes; + +/* Control whether stat() attempts to determine file type and link count + exactly, at the expense of slower operation. Since true hard links + are supported on NTFS volumes, this is only relevant on NT. */ +Lisp_Object Vwin32_get_true_file_attributes; + +Lisp_Object Qhigh, Qlow; #ifndef SYS_SIGLIST_DECLARED extern char *sys_siglist[]; @@ -271,6 +294,11 @@ return 0; } +/* To avoid Emacs changing directory, we just record here the directory + the new process should start in. This is set just before calling + sys_spawnve, and is not generally valid at any other time. */ +static char * process_dir; + static BOOL create_child (char *exe, char *cmdline, char *env, int * pPid, child_process *cp) @@ -278,6 +306,7 @@ STARTUPINFO start; SECURITY_ATTRIBUTES sec_attrs; SECURITY_DESCRIPTOR sec_desc; + char dir[ MAXPATHLEN ]; if (cp == NULL) abort (); @@ -285,7 +314,10 @@ start.cb = sizeof (start); #ifdef HAVE_NTGUI + if (NILP (Vwin32_start_process_show_window)) start.dwFlags = STARTF_USESTDHANDLES | STARTF_USESHOWWINDOW; + else + start.dwFlags = STARTF_USESTDHANDLES; start.wShowWindow = SW_HIDE; start.hStdInput = GetStdHandle (STD_INPUT_HANDLE); @@ -302,9 +334,14 @@ sec_attrs.lpSecurityDescriptor = &sec_desc; sec_attrs.bInheritHandle = FALSE; + strcpy (dir, process_dir); + unixtodos_filename (dir); + if (!CreateProcess (exe, cmdline, &sec_attrs, NULL, TRUE, - CREATE_NEW_PROCESS_GROUP, - env, NULL, + (!NILP (Vwin32_start_process_share_console) + ? CREATE_NEW_PROCESS_GROUP + : CREATE_NEW_CONSOLE), + env, dir, &start, &cp->procinfo)) goto EH_Fail; @@ -317,7 +354,6 @@ /* pid must fit in a Lisp_Int */ cp->pid = (cp->pid & VALMASK); - *pPid = cp->pid; return TRUE; @@ -381,11 +417,6 @@ cp->procinfo.hProcess = NULL; CloseHandle (cp->procinfo.hThread); cp->procinfo.hThread = NULL; - - /* If this was a DOS process, indicate that it is now safe to - start a new one. */ - if (cp->is_dos_process) - dos_process_running = FALSE; } /* For asynchronous children, the child_proc resources will be freed @@ -417,6 +448,8 @@ cps[nh] = dead_child; if (!wait_hnd[nh]) abort (); nh++; + active = 0; + goto get_result; } else { @@ -426,7 +459,7 @@ { wait_hnd[nh] = cp->procinfo.hProcess; cps[nh] = cp; - if (!wait_hnd[nh]) abort (); + if (!wait_hnd[nh]) abort (); /* Sync with FSF Emacs 19.34.6 note: only in XEmacs */ nh++; } } @@ -438,18 +471,18 @@ return -1; } - active = WaitForMultipleObjects (nh, wait_hnd, FALSE, INFINITE); + do + { + /* Check for quit about once a second. */ + QUIT; + active = WaitForMultipleObjects (nh, wait_hnd, FALSE, 1000); + } while (active == WAIT_TIMEOUT); + if (active == WAIT_FAILED) { errno = EBADF; return -1; } - else if (active == WAIT_TIMEOUT) - { - /* Should never happen */ - errno = EINVAL; - return -1; - } else if (active >= WAIT_OBJECT_0 && active < WAIT_OBJECT_0+MAXIMUM_WAIT_OBJECTS) { @@ -460,7 +493,10 @@ { active -= WAIT_ABANDONED_0; } + else + abort (); +get_result: if (!GetExitCodeProcess (wait_hnd[active], &retval)) { DebPrint (("Wait.GetExitCodeProcess failed with %lu\n", @@ -520,60 +556,139 @@ reap_subprocess (cp); } + reap_subprocess (cp); + return pid; } -int -win32_is_dos_binary (char * filename) +void +win32_executable_type (char * filename, int * is_dos_app, int * is_cygnus_app) { - IMAGE_DOS_HEADER dos_header; - DWORD signature; - int fd; - int is_dos_binary = FALSE; + file_data executable; + char * p; - fd = open (filename, O_RDONLY | O_BINARY, 0); - if (fd >= 0) - { - char * p = strrchr (filename, '.'); + /* Default values in case we can't tell for sure. */ + *is_dos_app = FALSE; + *is_cygnus_app = FALSE; + + if (!open_input_file (&executable, filename)) + return; + + p = strrchr (filename, '.'); /* We can only identify DOS .com programs from the extension. */ if (p && stricmp (p, ".com") == 0) - is_dos_binary = TRUE; - else if (p && stricmp (p, ".bat") == 0) - { - /* A DOS shell script - it appears that CreateProcess is happy - to accept this (somewhat surprisingly); presumably it looks - at COMSPEC to determine what executable to actually invoke. + *is_dos_app = TRUE; + else if (p && (stricmp (p, ".bat") == 0 || + stricmp (p, ".cmd") == 0)) + { + /* A DOS shell script - it appears that CreateProcess is happy to + accept this (somewhat surprisingly); presumably it looks at + COMSPEC to determine what executable to actually invoke. Therefore, we have to do the same here as well. */ - p = getenv ("COMSPEC"); + /* Actually, I think it uses the program association for that + extension, which is defined in the registry. */ + p = egetenv ("COMSPEC"); if (p) - is_dos_binary = win32_is_dos_binary (p); + win32_executable_type (p, is_dos_app, is_cygnus_app); } else { - /* Look for DOS .exe signature - if found, we must also check - that it isn't really a 16- or 32-bit Windows exe, since - both formats start with a DOS program stub. Note that - 16-bit Windows executables use the OS/2 1.x format. */ - if (read (fd, &dos_header, sizeof (dos_header)) == sizeof (dos_header) - && dos_header.e_magic == IMAGE_DOS_SIGNATURE - && lseek (fd, dos_header.e_lfanew, SEEK_SET) != -1) + /* Look for DOS .exe signature - if found, we must also check that + it isn't really a 16- or 32-bit Windows exe, since both formats + start with a DOS program stub. Note that 16-bit Windows + executables use the OS/2 1.x format. */ + + IMAGE_DOS_HEADER * dos_header; + IMAGE_NT_HEADERS * nt_header; + + dos_header = (PIMAGE_DOS_HEADER) executable.file_base; + if (dos_header->e_magic != IMAGE_DOS_SIGNATURE) + goto unwind; + + nt_header = (PIMAGE_NT_HEADERS) ((char *) dos_header + dos_header->e_lfanew); + + if ((char *) nt_header > (char *) dos_header + executable.size) + { + /* Some dos headers (pkunzip) have bogus e_lfanew fields. */ + *is_dos_app = TRUE; + } + else if (nt_header->Signature != IMAGE_NT_SIGNATURE && + LOWORD (nt_header->Signature) != IMAGE_OS2_SIGNATURE) + { + *is_dos_app = TRUE; + } + else if (nt_header->Signature == IMAGE_NT_SIGNATURE) + { + /* Look for cygwin.dll in DLL import list. */ + IMAGE_DATA_DIRECTORY import_dir = + nt_header->OptionalHeader.DataDirectory[IMAGE_DIRECTORY_ENTRY_IMPORT]; + IMAGE_IMPORT_DESCRIPTOR * imports; + IMAGE_SECTION_HEADER * section; + + section = rva_to_section (import_dir.VirtualAddress, nt_header); + imports = RVA_TO_PTR (import_dir.VirtualAddress, section, executable); + + for ( ; imports->Name; imports++) { - if (read (fd, &signature, sizeof (signature)) != sizeof (signature) - || (signature != IMAGE_NT_SIGNATURE && - LOWORD (signature) != IMAGE_OS2_SIGNATURE)) - is_dos_binary = TRUE; + char * dllname = RVA_TO_PTR (imports->Name, section, executable); + + if (strcmp (dllname, "cygwin.dll") == 0) + { + *is_cygnus_app = TRUE; + break; + } } } - close (fd); + } + +unwind: + close_file_data (&executable); +} + +int +compare_env (const char **strp1, const char **strp2) +{ + const char *str1 = *strp1, *str2 = *strp2; + + while (*str1 && *str2 && *str1 != '=' && *str2 != '=') + { + if ((*str1) > (*str2)) + return 1; + else if ((*str1) < (*str2)) + return -1; + str1++, str2++; } - return is_dos_binary; + if (*str1 == '=' && *str2 == '=') + return 0; + else if (*str1 == '=') + return -1; + else + return 1; } -/* We pass our process ID to our children by setting up an environment - variable in their environment. */ -char ppid_env_var_buffer[64]; +void +merge_and_sort_env (char **envp1, char **envp2, char **new_envp) +{ + char **optr, **nptr; + int num; + + nptr = new_envp; + optr = envp1; + while (*optr) + *nptr++ = *optr++; + num = optr - envp1; + + optr = envp2; + while (*optr) + *nptr++ = *optr++; + num += optr - envp2; + + qsort (new_envp, num, sizeof (char *), compare_env); + + *nptr = NULL; +} /* When a new child process is created we need to register it in our list, so intercept spawn requests. */ @@ -582,10 +697,16 @@ { Lisp_Object program, full; char *cmdline, *env, *parg, **targ; - int arglen; + int arglen, numenv; int pid; child_process *cp; - int is_dos_binary; + int is_dos_app, is_cygnus_app; + int do_quoting = 0; + char escape_char; + /* We pass our process ID to our children by setting up an environment + variable in their environment. */ + char ppid_env_var_buffer[64]; + char *extra_env[] = {ppid_env_var_buffer, NULL}; struct gcpro gcpro1; /* We don't care about the other modes */ @@ -608,24 +729,37 @@ errno = EINVAL; return -1; } - cmdname = XSTRING (full)->_data; + cmdname = XSTRING_DATA (full); argv[0] = cmdname; } UNGCPRO; - - /* make sure cmdname is in DOS format */ + /* make sure argv[0] and cmdname are both in DOS format */ strcpy (cmdname = alloca (strlen (cmdname) + 1), argv[0]); unixtodos_filename (cmdname); argv[0] = cmdname; - /* Check if program is a DOS executable, and if so whether we are - allowed to start it. */ - is_dos_binary = win32_is_dos_binary (cmdname); - if (is_dos_binary && dos_process_running) + /* Determine whether program is a 16-bit DOS executable, or a Win32 + executable that is implicitly linked to the Cygnus dll (implying it + was compiled with the Cygnus GNU toolchain and hence relies on + cygwin.dll to parse the command line - we use this to decide how to + escape quote chars in command line args that must be quoted). */ + win32_executable_type (cmdname, &is_dos_app, &is_cygnus_app); + + /* On Windows 95, if cmdname is a DOS app, we invoke a helper + application to start it by specifying the helper app as cmdname, + while leaving the real app name as argv[0]. */ + if (is_dos_app) { - errno = EAGAIN; - return -1; + cmdname = alloca (MAXPATHLEN); + if (egetenv ("CMDPROXY")) + strcpy (cmdname, egetenv ("CMDPROXY")); + else + { + strcpy (cmdname, XSTRING_DATA (Vinvocation_directory)); + strcat (cmdname, "cmdproxy.exe"); + } + unixtodos_filename (cmdname); } /* we have to do some conjuring here to put argv and envp into the @@ -633,17 +767,41 @@ terminated list of parameters, and envp is a null separated/double-null terminated list of parameters. - Additionally, zero-length args and args containing whitespace need - to be wrapped in double quotes. Args containing embedded double - quotes (as opposed to enclosing quotes, which we leave alone) are - usually illegal (most Win32 programs do not implement escaping of - double quotes - sad but true, at least for programs compiled with - MSVC), but we will escape quotes anyway for those programs that can - handle it. The Win32 gcc library from Cygnus doubles quotes to - escape them, so we will use that convention. + Additionally, zero-length args and args containing whitespace or + quote chars need to be wrapped in double quotes - for this to work, + embedded quotes need to be escaped as well. The aim is to ensure + the child process reconstructs the argv array we start with + exactly, so we treat quotes at the beginning and end of arguments + as embedded quotes. + + 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 + 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 + binary is apparently a Cygnus compiled app. + + 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 + 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. - Since I have no idea how large argv and envp are likely to be - we figure out list lengths on the fly and allocate them. */ + Since we have no idea how large argv and envp are likely to be we + figure out list lengths on the fly and allocate them. */ + + if (!NILP (Vwin32_quote_process_args)) + { + do_quoting = 1; + /* Override escape char by binding win32-quote-process-args to + desired character, or use t for auto-selection. */ + if (INTP (Vwin32_quote_process_args)) + escape_char = XINT (Vwin32_quote_process_args); + else + escape_char = is_cygnus_app ? '"' : '\\'; + } /* do argv... */ arglen = 0; @@ -651,22 +809,45 @@ while (*targ) { char * p = *targ; - int add_quotes = 0; + int need_quotes = 0; + int escape_char_run = 0; if (*p == 0) - add_quotes = 1; - while (*p) - if (*p++ == '"') + need_quotes = 1; + for ( ; *p; p++) + { + if (*p == '"') { - /* allow for embedded quotes to be doubled - we won't - actually double quotes that aren't embedded though */ + /* allow for embedded quotes to be escaped */ arglen++; - add_quotes = 1; + need_quotes = 1; + /* handle the case where the embedded quote is already escaped */ + if (escape_char_run > 0) + { + /* To preserve the arg exactly, we need to double the + preceding escape characters (plus adding one to + escape the quote character itself). */ + arglen += escape_char_run; } + } else if (*p == ' ' || *p == '\t') - add_quotes = 1; - if (add_quotes) + { + need_quotes = 1; + } + + if (*p == escape_char && escape_char != '"') + escape_char_run++; + else + escape_char_run = 0; + } + if (need_quotes) + { arglen += 2; + /* handle the case where the arg ends with an escape char - we + must not let the enclosing quote be escaped. */ + if (escape_char_run > 0) + arglen += escape_char_run; + } arglen += strlen (*targ++) + 1; } cmdline = alloca (arglen); @@ -675,24 +856,20 @@ while (*targ) { char * p = *targ; - int add_quotes = 0; + int need_quotes = 0; if (*p == 0) - add_quotes = 1; + need_quotes = 1; - if (!NILP (Vwin32_quote_process_args)) + if (do_quoting) { - /* This is conditional because it sometimes causes more - problems than it solves, since argv arrays are not always - carefully constructed. M-x grep, for instance, passes the - whole command line as one argument, so it becomes - impossible to pass a regexp which contains spaces. */ for ( ; *p; p++) if (*p == ' ' || *p == '\t' || *p == '"') - add_quotes = 1; + need_quotes = 1; } - if (add_quotes) + if (need_quotes) { + int escape_char_run = 0; char * first; char * last; @@ -700,12 +877,47 @@ first = p; last = p + strlen (p) - 1; *parg++ = '"'; +#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 + containing quoted args. I believe this was originally done + as a hack to make some things work, before + `win32-quote-process-args' was added. */ while (*p) { if (*p == '"' && p > first && p < last) - *parg++ = '"'; /* double up embedded quotes only */ + *parg++ = escape_char; /* escape embedded quotes */ *parg++ = *p++; } +#else + for ( ; *p; p++) + { + if (*p == '"') + { + /* double preceding escape chars if any */ + while (escape_char_run > 0) + { + *parg++ = escape_char; + escape_char_run--; + } + /* escape all quote chars, even at beginning or end */ + *parg++ = escape_char; + } + *parg++ = *p; + + if (*p == escape_char && escape_char != '"') + escape_char_run++; + else + escape_char_run = 0; + } + /* double escape chars before enclosing quote */ + while (escape_char_run > 0) + { + *parg++ = escape_char; + escape_char_run--; + } +#endif *parg++ = '"'; } else @@ -721,16 +933,24 @@ /* and envp... */ arglen = 1; targ = envp; + numenv = 1; /* for end null */ while (*targ) { arglen += strlen (*targ++) + 1; + numenv++; } + /* extra env vars... */ sprintf (ppid_env_var_buffer, "__PARENT_PROCESS_ID=%d", GetCurrentProcessId ()); arglen += strlen (ppid_env_var_buffer) + 1; + numenv++; + /* merge env passed in and extra env into one, and sort it. */ + targ = (char **) alloca (numenv * sizeof (char *)); + merge_and_sort_env (envp, extra_env, targ); + + /* concatenate env entries. */ env = alloca (arglen); - targ = envp; parg = env; while (*targ) { @@ -738,8 +958,6 @@ parg += strlen (*targ++); *parg++ = '\0'; } - strcpy (parg, ppid_env_var_buffer); - parg += strlen (ppid_env_var_buffer); *parg++ = '\0'; *parg = '\0'; @@ -758,24 +976,23 @@ return -1; } - if (is_dos_binary) - { - cp->is_dos_process = TRUE; - dos_process_running = TRUE; - } - return pid; } /* Emulate the select call Wait for available input on any of the given rfds, or timeout if a timeout is given and no input is detected - wfds and efds are not supported and must be NULL. */ + wfds and efds are not supported and must be NULL. -#if 0 + For simplicity, we detect the death of child processes here and + synchronously call the SIGCHLD handler. Since it is possible for + children to be created without a corresponding pipe handle from which + to read output, we wait separately on the process handles as well as + the char_avail events for each process pipe. We only call + wait/reap_process when the process actually terminates. */ + /* From ntterm.c */ extern HANDLE keyboard_handle; -#endif /* From process.c */ extern int proc_buffered_char[]; @@ -784,17 +1001,19 @@ EMACS_TIME *timeout) { SELECT_TYPE orfds; - DWORD timeout_ms; - int i, nh, nr; + DWORD timeout_ms, start_time; + int i, nh, nc, nr; DWORD active; - child_process *cp; - HANDLE wait_hnd[MAXDESC]; + child_process *cp, *cps[MAX_CHILDREN]; + HANDLE wait_hnd[MAXDESC + MAX_CHILDREN]; int fdindex[MAXDESC]; /* mapping from wait handles back to descriptors */ + timeout_ms = timeout ? (timeout->tv_sec * 1000 + timeout->tv_usec / 1000) : INFINITE; + /* If the descriptor sets are NULL but timeout isn't, then just Sleep. */ if (rfds == NULL && wfds == NULL && efds == NULL && timeout != NULL) { - Sleep (timeout->tv_sec * 1000 + timeout->tv_usec / 1000); + Sleep (timeout_ms); return 0; } @@ -809,7 +1028,7 @@ FD_ZERO (rfds); nr = 0; - /* Build a list of handles to wait on. */ + /* Build a list of pipe handles to wait on. */ nh = 0; for (i = 0; i < nfds; i++) if (FD_ISSET (i, &orfds)) @@ -817,6 +1036,7 @@ if (i == 0) { #if 0 +/* Sync with FSF Emacs 19.34.6 note: ifdef'ed out in XEmacs */ if (keyboard_handle) { /* Handle stdin specially */ @@ -828,7 +1048,7 @@ /* Check for any emacs-generated input in the queue since it won't be detected in the wait */ - if (detect_input_pending ()) + if (detect_input_pending ()) { FD_SET (i, rfds); return 1; @@ -895,34 +1115,55 @@ else { /* Unable to find something to wait on for this fd, skip */ + + /* Note that this is not a fatal error, and can in fact + happen in unusual circumstances. Specifically, if + sys_spawnve fails, eg. because the program doesn't + exist, and debug-on-error is t so Fsignal invokes a + nested input loop, then the process output pipe is + still included in input_wait_mask with no child_proc + associated with it. (It is removed when the debugger + exits the nested input loop and the error is thrown.) */ + DebPrint (("sys_select: fd %ld is invalid! ignoring\n", i)); - abort (); + } } } + +count_children: + /* Add handles of child processes. */ + nc = 0; + for (cp = child_procs+(child_proc_count-1); cp >= child_procs; cp--) + /* Some child_procs might be sockets; ignore them. Also some + children may have died already, but we haven't finished reading + the process output; ignore them too. */ + if (CHILD_ACTIVE (cp) && cp->procinfo.hProcess + && (cp->fd < 0 + || (fd_info[cp->fd].flags & FILE_SEND_SIGCHLD) == 0 + || (fd_info[cp->fd].flags & FILE_AT_EOF) != 0) + ) + { + wait_hnd[nh + nc] = cp->procinfo.hProcess; + cps[nc] = cp; + nc++; } /* Nothing to look for, so we didn't find anything */ - if (nh == 0) + if (nh + nc == 0) { if (timeout) - Sleep (timeout->tv_sec * 1000 + timeout->tv_usec / 1000); + Sleep (timeout_ms); return 0; } - /* - Wait for input - If a child process dies while this is waiting, its pipe will break - so the reader thread will signal an error condition, thus, the wait - will wake up - */ - timeout_ms = timeout ? (timeout->tv_sec * 1000 + timeout->tv_usec / 1000) : INFINITE; - - active = WaitForMultipleObjects (nh, wait_hnd, FALSE, timeout_ms); + /* Wait for input or child death to be signalled. */ + start_time = GetTickCount (); + active = WaitForMultipleObjects (nh + nc, wait_hnd, FALSE, timeout_ms); if (active == WAIT_FAILED) { DebPrint (("select.WaitForMultipleObjects (%d, %lu) failed with %lu\n", - nh, timeout_ms, GetLastError ())); + nh + nc, timeout_ms, GetLastError ())); /* don't return EBADF - this causes wait_reading_process_input to abort; WAIT_FAILED is returned when single-stepping under Windows 95 after switching thread focus in debugger, and @@ -944,6 +1185,8 @@ { active -= WAIT_ABANDONED_0; } + else + abort (); /* Loop over all handles after active (now officially documented as being the first signalled handle in the array). We do this to @@ -951,41 +1194,18 @@ processed - otherwise higher numbered channels could be starved. */ do { - if (fdindex[active] == 0) + if (active >= nh) { - /* Keyboard input available */ - FD_SET (0, rfds); - nr++; - } - else - { - /* must be a socket or pipe */ - int current_status; - - cp = fd_info[ fdindex[active] ].cp; + cp = cps[active - nh]; - /* Read ahead should have completed, either succeeding or failing. */ - FD_SET (fdindex[active], rfds); - nr++; - current_status = cp->status; - if (current_status != STATUS_READ_SUCCEEDED) - { - if (current_status != STATUS_READ_FAILED) - DebPrint (("internal error: subprocess pipe signalled " - "at the wrong time (status %d)\n!", current_status)); + /* We cannot always signal SIGCHLD immediately; if we have not + finished reading the process output, we must delay sending + SIGCHLD until we do. */ - /* The child_process entry for a socket or pipe will be - freed when the last descriptor using it is closed; for - pipes, we call the SIGCHLD handler. */ - if (fd_info[ fdindex[active] ].flags & FILE_PIPE) - { - /* The SIGCHLD handler will do a Wait so we know it won't - return until the process is dead - We force Wait to only wait for this process to avoid it - picking up other children that happen to be dead but that - we haven't noticed yet - SIG_DFL for SIGCHLD is ignore? */ - if (sig_handlers[SIGCHLD] != SIG_DFL && + if (cp->fd >= 0 && (fd_info[cp->fd].flags & FILE_AT_EOF) == 0) + fd_info[cp->fd].flags |= FILE_SEND_SIGCHLD; + /* SIG_DFL for SIGCHLD is ignore */ + else if (sig_handlers[SIGCHLD] != SIG_DFL && sig_handlers[SIGCHLD] != SIG_IGN) { #ifdef FULL_DEBUG @@ -996,23 +1216,72 @@ sig_handlers[SIGCHLD] (SIGCHLD); dead_child = NULL; } - - /* Clean up the child process entry in the table */ - reap_subprocess (cp); } + else if (fdindex[active] == 0) + { + /* Keyboard input available */ + FD_SET (0, rfds); + nr++; } + else + { + /* must be a socket or pipe - read ahead should have + completed, either succeeding or failing. */ + FD_SET (fdindex[active], rfds); + nr++; } - /* Test for input on remaining channels. */ - while (++active < nh) + /* Even though wait_reading_process_output only reads from at most + one channel, we must process all channels here so that we reap + all children that have died. */ + while (++active < nh + nc) if (WaitForSingleObject (wait_hnd[active], 0) == WAIT_OBJECT_0) break; - } while (active < nh); + } while (active < nh + nc); + + /* If no input has arrived and timeout hasn't expired, wait again. */ + if (nr == 0) + { + DWORD elapsed = GetTickCount () - start_time; + + if (timeout_ms > elapsed) /* INFINITE is MAX_UINT */ + { + if (timeout_ms != INFINITE) + timeout_ms -= elapsed; + goto count_children; + } + } return nr; } /* Substitute for certain kill () operations */ + +static BOOL CALLBACK +find_child_console (HWND hwnd, child_process * cp) +{ + DWORD thread_id; + DWORD process_id; + + thread_id = GetWindowThreadProcessId (hwnd, &process_id); + if (process_id == cp->procinfo.dwProcessId) + { + char window_class[32]; + + GetClassName (hwnd, window_class, sizeof (window_class)); + if (strcmp (window_class, + (os_subtype == OS_WIN95) + ? "tty" + : "ConsoleWindowClass") == 0) + { + cp->hwnd = hwnd; + return FALSE; + } + } + /* keep looking */ + return TRUE; +} + int sys_kill (int pid, int sig) { @@ -1043,12 +1312,45 @@ { proc_hand = cp->procinfo.hProcess; pid = cp->procinfo.dwProcessId; + + /* Try to locate console window for process. */ + EnumWindows (find_child_console, (LPARAM) cp); } if (sig == SIGINT) { + if (NILP (Vwin32_start_process_share_console) && cp && cp->hwnd) + { + BYTE control_scan_code = (BYTE) MapVirtualKey (VK_CONTROL, 0); + BYTE vk_break_code = VK_CANCEL; + BYTE break_scan_code = (BYTE) MapVirtualKey (vk_break_code, 0); + HWND foreground_window; + + if (break_scan_code == 0) + { + /* Fake Ctrl-C if we can't manage Ctrl-Break. */ + vk_break_code = 'C'; + break_scan_code = (BYTE) MapVirtualKey (vk_break_code, 0); + } + + foreground_window = GetForegroundWindow (); + if (foreground_window && SetForegroundWindow (cp->hwnd)) + { + /* Generate keystrokes as if user had typed Ctrl-Break or Ctrl-C. */ + keybd_event (VK_CONTROL, control_scan_code, 0, 0); + keybd_event (vk_break_code, break_scan_code, 0, 0); + keybd_event (vk_break_code, break_scan_code, KEYEVENTF_KEYUP, 0); + keybd_event (VK_CONTROL, control_scan_code, KEYEVENTF_KEYUP, 0); + + /* Sleep for a bit to give time for Emacs frame to respond + to focus change events (if Emacs was active app). */ + Sleep (10); + + SetForegroundWindow (foreground_window); + } + } /* Ctrl-Break is NT equivalent of SIGINT. */ - if (!GenerateConsoleCtrlEvent (CTRL_BREAK_EVENT, pid)) + else if (!GenerateConsoleCtrlEvent (CTRL_BREAK_EVENT, pid)) { DebPrint (("sys_kill.GenerateConsoleCtrlEvent return %d " "for pid %lu\n", GetLastError (), pid)); @@ -1058,12 +1360,54 @@ } else { + if (NILP (Vwin32_start_process_share_console) && cp && cp->hwnd) + { +#if 1 + if (os_subtype == OS_WIN95) + { +/* + Another possibility is to try terminating the VDM out-right by + calling the Shell VxD (id 0x17) V86 interface, function #4 + "SHELL_Destroy_VM", ie. + + mov edx,4 + mov ebx,vm_handle + call shellapi + + First need to determine the current VM handle, and then arrange for + the shellapi call to be made from the system vm (by using + Switch_VM_and_callback). + + Could try to invoke DestroyVM through CallVxD. + +*/ +#if 0 + /* On Win95, posting WM_QUIT causes the 16-bit subsystem + to hang when cmdproxy is used in conjunction with + command.com for an interactive shell. Posting + WM_CLOSE pops up a dialog that, when Yes is selected, + does the same thing. TerminateProcess is also less + than ideal in that subprocesses tend to stick around + until the machine is shutdown, but at least it + doesn't freeze the 16-bit subsystem. */ + PostMessage (cp->hwnd, WM_QUIT, 0xff, 0); +#endif + if (!TerminateProcess (proc_hand, 0xff)) + { + DebPrint (("sys_kill.TerminateProcess returned %d " + "for pid %lu\n", GetLastError (), pid)); + errno = EINVAL; + rc = -1; + } + } + else +#endif + PostMessage (cp->hwnd, WM_CLOSE, 0, 0); + } /* Kill the process. On Win32 this doesn't kill child processes so it doesn't work very well for shells which is why it's not - used in every case. Also, don't try to terminate DOS processes - (on Win95), because this will hang Emacs. */ - if (!(cp && cp->is_dos_process) - && !TerminateProcess (proc_hand, 0xff)) + used in every case. */ + else if (!TerminateProcess (proc_hand, 0xff)) { DebPrint (("sys_kill.TerminateProcess returned %d " "for pid %lu\n", GetLastError (), pid)); @@ -1079,6 +1423,7 @@ } #if 0 +/* Sync with FSF Emacs 19.34.6 note: ifdef'ed out in XEmacs */ extern int report_file_error (CONST char *, Lisp_Object); #endif /* The following two routines are used to manipulate stdin, stdout, and @@ -1163,6 +1508,12 @@ SetStdHandle (STD_ERROR_HANDLE, handles[2]); } +void +set_process_dir (char * dir) +{ + process_dir = dir; +} + #ifdef HAVE_SOCKETS /* To avoid problems with winsock implementations that work over dial-up @@ -1232,39 +1583,339 @@ #endif /* HAVE_SOCKETS */ +/* Some miscellaneous functions that are Windows specific, but not GUI + specific (ie. are applicable in terminal or batch mode as well). */ + +/* lifted from fileio.c */ +#define CORRECT_DIR_SEPS(s) \ + do { if ('/' == DIRECTORY_SEP) dostounix_filename (s); \ + else unixtodos_filename (s); \ + } while (0) + +DEFUN ("win32-short-file-name", Fwin32_short_file_name, 1, 1, "", /* + Return the short file name version (8.3) of the full path of FILENAME. +If FILENAME does not exist, return nil. +All path elements in FILENAME are converted to their short names. +*/ + (filename)) +{ + char shortname[MAX_PATH]; + + CHECK_STRING (filename, 0); + + /* first expand it. */ + filename = Fexpand_file_name (filename, Qnil); + + /* luckily, this returns the short version of each element in the path. */ + if (GetShortPathName (XSTRING_DATA (filename), shortname, MAX_PATH) == 0) + return Qnil; + + CORRECT_DIR_SEPS (shortname); + + return build_string (shortname); +} + + +DEFUN ("win32-long-file-name", Fwin32_long_file_name, 1, 1, "", /* + Return the long file name version of the full path of FILENAME. +If FILENAME does not exist, return nil. +All path elements in FILENAME are converted to their long names. +*/ + (filename)) +{ + char longname[ MAX_PATH ]; + + CHECK_STRING (filename, 0); + + /* first expand it. */ + filename = Fexpand_file_name (filename, Qnil); + + if (!win32_get_long_filename (XSTRING_DATA (filename), longname, MAX_PATH)) + return Qnil; + + CORRECT_DIR_SEPS (longname); + + return build_string (longname); +} + +DEFUN ("win32-set-process-priority", Fwin32_set_process_priority, 2, 2, "", /* + Set the priority of PROCESS to PRIORITY. +If PROCESS is nil, the priority of Emacs is changed, otherwise the +priority of the process whose pid is PROCESS is changed. +PRIORITY should be one of the symbols high, normal, or low; +any other symbol will be interpreted as normal. + +If successful, the return value is t, otherwise nil. +*/ + (process, priority)) +{ + HANDLE proc_handle = GetCurrentProcess (); + DWORD priority_class = NORMAL_PRIORITY_CLASS; + Lisp_Object result = Qnil; + + CHECK_SYMBOL (priority, 0); + + if (!NILP (process)) + { + DWORD pid; + child_process *cp; + + CHECK_INT (process); + + /* Allow pid to be an internally generated one, or one obtained + externally. This is necessary because real pids on Win95 are + negative. */ + + pid = XINT (process); + cp = find_child_pid (pid); + if (cp != NULL) + pid = cp->procinfo.dwProcessId; + + proc_handle = OpenProcess (PROCESS_SET_INFORMATION, FALSE, pid); + } + + if (EQ (priority, Qhigh)) + priority_class = HIGH_PRIORITY_CLASS; + else if (EQ (priority, Qlow)) + priority_class = IDLE_PRIORITY_CLASS; + + if (proc_handle != NULL) + { + if (SetPriorityClass (proc_handle, priority_class)) + result = Qt; + if (!NILP (process)) + CloseHandle (proc_handle); + } + + return result; +} + + +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 +as the third letter. For example, ENU refers to `English (United States)', +while ENC means `English (Canadian)'. + +If the optional argument LONGFORM is non-nil, the long form of the locale +name is returned, e.g. `English (United States)' instead. + +If LCID (a 16-bit number) is not a valid locale, the result is nil. +*/ + (lcid, longform)) +{ + int got_abbrev; + int got_full; + char abbrev_name[32] = { 0 }; + char full_name[256] = { 0 }; + + CHECK_INT (lcid); + + if (!IsValidLocale (XINT (lcid), LCID_SUPPORTED)) + return Qnil; + + if (NILP (longform)) + { + got_abbrev = GetLocaleInfo (XINT (lcid), + LOCALE_SABBREVLANGNAME | LOCALE_USE_CP_ACP, + abbrev_name, sizeof (abbrev_name)); + if (got_abbrev) + return build_string (abbrev_name); + } + else + { + got_full = GetLocaleInfo (XINT (lcid), + LOCALE_SLANGUAGE | LOCALE_USE_CP_ACP, + full_name, sizeof (full_name)); + if (got_full) + return build_string (full_name); + } + + return Qnil; +} + + +DEFUN ("win32-get-current-locale-id", Fwin32_get_current_locale_id, 0, 0, "", /* + "Return Windows locale id for current locale setting. +This is a numerical value; use `win32-get-locale-info' to convert to a +human-readable form. +*/ + ()) +{ + return make_int (GetThreadLocale ()); +} + + +DEFUN ("win32-get-default-locale-id", Fwin32_get_default_locale_id, 0, 1, "", /* + "Return Windows locale id for default locale setting. +By default, the system default locale setting is returned; if the optional +parameter USERP is non-nil, the user default locale setting is returned. +This is a numerical value; use `win32-get-locale-info' to convert to a +human-readable form. +*/ + (userp)) +{ + if (NILP (userp)) + return make_int (GetSystemDefaultLCID ()); + return make_int (GetUserDefaultLCID ()); +} + +DWORD int_from_hex (char * s) +{ + DWORD val = 0; + static char hex[] = "0123456789abcdefABCDEF"; + char * p; + + while (*s && (p = strchr(hex, *s)) != NULL) + { + unsigned digit = p - hex; + if (digit > 15) + digit -= 6; + val = val * 16 + digit; + s++; + } + return val; +} + +/* We need to build a global list, since the EnumSystemLocale callback + function isn't given a context pointer. */ +Lisp_Object Vwin32_valid_locale_ids; + +BOOL CALLBACK enum_locale_fn (LPTSTR localeNum) +{ + DWORD id = int_from_hex (localeNum); + Vwin32_valid_locale_ids = Fcons (make_int (id), Vwin32_valid_locale_ids); + return TRUE; +} + +DEFUN ("win32-get-valid-locale-ids", Fwin32_get_valid_locale_ids, 0, 0, "", /* + Return list of all valid Windows locale ids. +Each id is a numerical value; use `win32-get-locale-info' to convert to a +human-readable form. +*/ + ()) +{ + Vwin32_valid_locale_ids = Qnil; + + EnumSystemLocales (enum_locale_fn, LCID_SUPPORTED); + + Vwin32_valid_locale_ids = Fnreverse (Vwin32_valid_locale_ids); + return Vwin32_valid_locale_ids; +} + + +DEFUN ("win32-set-current-locale", Fwin32_set_current_locale, 1, 1, "", /* + Make Windows locale LCID be the current locale setting for Emacs. +If successful, the new locale id is returned, otherwise nil. +*/ + (lcid)) +{ + CHECK_INT (lcid); + + if (!IsValidLocale (XINT (lcid), LCID_SUPPORTED)) + return Qnil; + + if (!SetThreadLocale (XINT (lcid))) + return Qnil; + +/* Sync with FSF Emacs 19.34.6 note: dwWinThreadId declared in + w32term.h and defined in w32fns.c, both of which are not in current + XEmacs. ### Check what we lose by ifdef'ing out these. --marcpa */ +#if 0 + /* Need to set input thread locale if present. */ + if (dwWinThreadId) + /* Reply is not needed. */ + PostThreadMessage (dwWinThreadId, WM_EMACS_SETLOCALE, XINT (lcid), 0); +#endif + + return make_int (GetThreadLocale ()); +} + + syms_of_ntproc () { + Qhigh = intern ("high"); + Qlow = intern ("low"); + #ifdef HAVE_SOCKETS DEFSUBR (Fwin32_has_winsock); DEFSUBR (Fwin32_unload_winsock); #endif + DEFSUBR (Fwin32_short_file_name); + DEFSUBR (Fwin32_long_file_name); + DEFSUBR (Fwin32_set_process_priority); + DEFSUBR (Fwin32_get_locale_info); + DEFSUBR (Fwin32_get_current_locale_id); + DEFSUBR (Fwin32_get_default_locale_id); + DEFSUBR (Fwin32_get_valid_locale_ids); + DEFSUBR (Fwin32_set_current_locale); DEFVAR_LISP ("win32-quote-process-args", &Vwin32_quote_process_args /* -Non-nil enables quoting of process arguments to ensure correct parsing. + Non-nil enables quoting of process arguments to ensure correct parsing. Because Windows does not directly pass argv arrays to child processes, programs have to reconstruct the argv array by parsing the command line string. For an argument to contain a space, it must be enclosed in double quotes or it will be parsed as multiple arguments. -However, the argument list to call-process is not always correctly -constructed (or arguments have already been quoted), so enabling this -option may cause unexpected behavior.*/ ); - Vwin32_quote_process_args = Qnil; +If the value is a character, that character will be used to escape any +quote characters that appear, otherwise a suitable escape character +will be chosen based on the type of the program. +*/ ); + Vwin32_quote_process_args = Qt; + + DEFVAR_LISP ("win32-start-process-show-window", + &Vwin32_start_process_show_window /* + When nil, processes started via start-process hide their windows. +When non-nil, they show their window in the method of their choice. +*/ ); + Vwin32_start_process_show_window = Qnil; + + DEFVAR_LISP ("win32-start-process-share-console", + &Vwin32_start_process_share_console /* + When nil, processes started via start-process are given a new console. +When non-nil, they share the Emacs console; this has the limitation of +allowing only only DOS subprocess to run at a time (whether started directly +or indirectly by Emacs), and preventing Emacs from cleanly terminating the +subprocess group, but may allow Emacs to interrupt a subprocess that doesn't +otherwise respond to interrupts from Emacs. +*/ ); + Vwin32_start_process_share_console = Qnil; DEFVAR_INT ("win32-pipe-read-delay", &Vwin32_pipe_read_delay /* -Forced delay before reading subprocess output. + Forced delay before reading subprocess output. This is done to improve the buffering of subprocess output, by avoiding the inefficiency of frequently reading small amounts of data. If positive, the value is the number of milliseconds to sleep before reading the subprocess output. If negative, the magnitude is the number of time slices to wait (effectively boosting the priority of the child -process temporarily). A value of zero disables waiting entirely.*/ ); +process temporarily). A value of zero disables waiting entirely. +*/ ); Vwin32_pipe_read_delay = 50; DEFVAR_LISP ("win32-downcase-file-names", &Vwin32_downcase_file_names /* Non-nil means convert all-upper case file names to lower case. This applies when performing completions and file name expansion.*/ ); Vwin32_downcase_file_names = Qnil; + +#if 0 + DEFVAR_LISP ("win32-generate-fake-inodes", &Vwin32_generate_fake_inodes /* + "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 +the truename of a file can be slow. +*/ ); + Vwin32_generate_fake_inodes = Qnil; +#endif + + DEFVAR_LISP ("win32-get-true-file-attributes", &Vwin32_get_true_file_attributes /* + "Non-nil means determine accurate link count in file-attributes. +This option slows down file-attributes noticeably, so is disabled by +default. Note that it is only useful for files on NTFS volumes, +where hard links are supported. +*/ ); + Vwin32_get_true_file_attributes = Qnil; } /* end of ntproc.c */
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/objects-w32.c Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,679 @@ +/* win32-specific Lisp objects. + Copyright (C) 1993, 1994 Free Software Foundation, Inc. + Copyright (C) 1995 Board of Trustees, University of Illinois. + Copyright (C) 1995 Tinker Systems. + Copyright (C) 1995, 1996 Ben Wing. + Copyright (C) 1995 Sun Microsystems, Inc. + Copyright (C) 1997 Jonathan Harris. + +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. */ + +/* Authorship: + + Jamie Zawinski, Chuck Thompson, Ben Wing + Rewritten for win32 by Jonathan Harris, November 1997 for 20.4. + */ + + +/* TODO: palette handling */ + +#include <config.h> +#include "lisp.h" + +#include "console-w32.h" +#include "objects-w32.h" + +#ifdef MULE +#include "mule-charset.h" +#endif + +#include "buffer.h" +#include "device.h" +#include "insdel.h" + +#include "windows.h" + +typedef struct colormap_t +{ + char *name; + COLORREF colorref; +} colormap_t; + +static colormap_t w32_X_color_map[] = +{ + {"snow" , PALETTERGB (255,250,250)}, + {"ghost white" , PALETTERGB (248,248,255)}, + {"GhostWhite" , PALETTERGB (248,248,255)}, + {"white smoke" , PALETTERGB (245,245,245)}, + {"WhiteSmoke" , PALETTERGB (245,245,245)}, + {"gainsboro" , PALETTERGB (220,220,220)}, + {"floral white" , PALETTERGB (255,250,240)}, + {"FloralWhite" , PALETTERGB (255,250,240)}, + {"old lace" , PALETTERGB (253,245,230)}, + {"OldLace" , PALETTERGB (253,245,230)}, + {"linen" , PALETTERGB (250,240,230)}, + {"antique white" , PALETTERGB (250,235,215)}, + {"AntiqueWhite" , PALETTERGB (250,235,215)}, + {"papaya whip" , PALETTERGB (255,239,213)}, + {"PapayaWhip" , PALETTERGB (255,239,213)}, + {"blanched almond" , PALETTERGB (255,235,205)}, + {"BlanchedAlmond" , PALETTERGB (255,235,205)}, + {"bisque" , PALETTERGB (255,228,196)}, + {"peach puff" , PALETTERGB (255,218,185)}, + {"PeachPuff" , PALETTERGB (255,218,185)}, + {"navajo white" , PALETTERGB (255,222,173)}, + {"NavajoWhite" , PALETTERGB (255,222,173)}, + {"moccasin" , PALETTERGB (255,228,181)}, + {"cornsilk" , PALETTERGB (255,248,220)}, + {"ivory" , PALETTERGB (255,255,240)}, + {"lemon chiffon" , PALETTERGB (255,250,205)}, + {"LemonChiffon" , PALETTERGB (255,250,205)}, + {"seashell" , PALETTERGB (255,245,238)}, + {"honeydew" , PALETTERGB (240,255,240)}, + {"mint cream" , PALETTERGB (245,255,250)}, + {"MintCream" , PALETTERGB (245,255,250)}, + {"azure" , PALETTERGB (240,255,255)}, + {"alice blue" , PALETTERGB (240,248,255)}, + {"AliceBlue" , PALETTERGB (240,248,255)}, + {"lavender" , PALETTERGB (230,230,250)}, + {"lavender blush" , PALETTERGB (255,240,245)}, + {"LavenderBlush" , PALETTERGB (255,240,245)}, + {"misty rose" , PALETTERGB (255,228,225)}, + {"MistyRose" , PALETTERGB (255,228,225)}, + {"white" , PALETTERGB (255,255,255)}, + {"black" , PALETTERGB ( 0, 0, 0)}, + {"dark slate gray" , PALETTERGB ( 47, 79, 79)}, + {"DarkSlateGray" , PALETTERGB ( 47, 79, 79)}, + {"dark slate grey" , PALETTERGB ( 47, 79, 79)}, + {"DarkSlateGrey" , PALETTERGB ( 47, 79, 79)}, + {"dim gray" , PALETTERGB (105,105,105)}, + {"DimGray" , PALETTERGB (105,105,105)}, + {"dim grey" , PALETTERGB (105,105,105)}, + {"DimGrey" , PALETTERGB (105,105,105)}, + {"slate gray" , PALETTERGB (112,128,144)}, + {"SlateGray" , PALETTERGB (112,128,144)}, + {"slate grey" , PALETTERGB (112,128,144)}, + {"SlateGrey" , PALETTERGB (112,128,144)}, + {"light slate gray" , PALETTERGB (119,136,153)}, + {"LightSlateGray" , PALETTERGB (119,136,153)}, + {"light slate grey" , PALETTERGB (119,136,153)}, + {"LightSlateGrey" , PALETTERGB (119,136,153)}, + {"gray" , PALETTERGB (190,190,190)}, + {"grey" , PALETTERGB (190,190,190)}, + {"light grey" , PALETTERGB (211,211,211)}, + {"LightGrey" , PALETTERGB (211,211,211)}, + {"light gray" , PALETTERGB (211,211,211)}, + {"LightGray" , PALETTERGB (211,211,211)}, + {"midnight blue" , PALETTERGB ( 25, 25,112)}, + {"MidnightBlue" , PALETTERGB ( 25, 25,112)}, + {"navy" , PALETTERGB ( 0, 0,128)}, + {"navy blue" , PALETTERGB ( 0, 0,128)}, + {"NavyBlue" , PALETTERGB ( 0, 0,128)}, + {"cornflower blue" , PALETTERGB (100,149,237)}, + {"CornflowerBlue" , PALETTERGB (100,149,237)}, + {"dark slate blue" , PALETTERGB ( 72, 61,139)}, + {"DarkSlateBlue" , PALETTERGB ( 72, 61,139)}, + {"slate blue" , PALETTERGB (106, 90,205)}, + {"SlateBlue" , PALETTERGB (106, 90,205)}, + {"medium slate blue" , PALETTERGB (123,104,238)}, + {"MediumSlateBlue" , PALETTERGB (123,104,238)}, + {"light slate blue" , PALETTERGB (132,112,255)}, + {"LightSlateBlue" , PALETTERGB (132,112,255)}, + {"medium blue" , PALETTERGB ( 0, 0,205)}, + {"MediumBlue" , PALETTERGB ( 0, 0,205)}, + {"royal blue" , PALETTERGB ( 65,105,225)}, + {"RoyalBlue" , PALETTERGB ( 65,105,225)}, + {"blue" , PALETTERGB ( 0, 0,255)}, + {"dodger blue" , PALETTERGB ( 30,144,255)}, + {"DodgerBlue" , PALETTERGB ( 30,144,255)}, + {"deep sky blue" , PALETTERGB ( 0,191,255)}, + {"DeepSkyBlue" , PALETTERGB ( 0,191,255)}, + {"sky blue" , PALETTERGB (135,206,235)}, + {"SkyBlue" , PALETTERGB (135,206,235)}, + {"light sky blue" , PALETTERGB (135,206,250)}, + {"LightSkyBlue" , PALETTERGB (135,206,250)}, + {"steel blue" , PALETTERGB ( 70,130,180)}, + {"SteelBlue" , PALETTERGB ( 70,130,180)}, + {"light steel blue" , PALETTERGB (176,196,222)}, + {"LightSteelBlue" , PALETTERGB (176,196,222)}, + {"light blue" , PALETTERGB (173,216,230)}, + {"LightBlue" , PALETTERGB (173,216,230)}, + {"powder blue" , PALETTERGB (176,224,230)}, + {"PowderBlue" , PALETTERGB (176,224,230)}, + {"pale turquoise" , PALETTERGB (175,238,238)}, + {"PaleTurquoise" , PALETTERGB (175,238,238)}, + {"dark turquoise" , PALETTERGB ( 0,206,209)}, + {"DarkTurquoise" , PALETTERGB ( 0,206,209)}, + {"medium turquoise" , PALETTERGB ( 72,209,204)}, + {"MediumTurquoise" , PALETTERGB ( 72,209,204)}, + {"turquoise" , PALETTERGB ( 64,224,208)}, + {"cyan" , PALETTERGB ( 0,255,255)}, + {"light cyan" , PALETTERGB (224,255,255)}, + {"LightCyan" , PALETTERGB (224,255,255)}, + {"cadet blue" , PALETTERGB ( 95,158,160)}, + {"CadetBlue" , PALETTERGB ( 95,158,160)}, + {"medium aquamarine" , PALETTERGB (102,205,170)}, + {"MediumAquamarine" , PALETTERGB (102,205,170)}, + {"aquamarine" , PALETTERGB (127,255,212)}, + {"dark green" , PALETTERGB ( 0,100, 0)}, + {"DarkGreen" , PALETTERGB ( 0,100, 0)}, + {"dark olive green" , PALETTERGB ( 85,107, 47)}, + {"DarkOliveGreen" , PALETTERGB ( 85,107, 47)}, + {"dark sea green" , PALETTERGB (143,188,143)}, + {"DarkSeaGreen" , PALETTERGB (143,188,143)}, + {"sea green" , PALETTERGB ( 46,139, 87)}, + {"SeaGreen" , PALETTERGB ( 46,139, 87)}, + {"medium sea green" , PALETTERGB ( 60,179,113)}, + {"MediumSeaGreen" , PALETTERGB ( 60,179,113)}, + {"light sea green" , PALETTERGB ( 32,178,170)}, + {"LightSeaGreen" , PALETTERGB ( 32,178,170)}, + {"pale green" , PALETTERGB (152,251,152)}, + {"PaleGreen" , PALETTERGB (152,251,152)}, + {"spring green" , PALETTERGB ( 0,255,127)}, + {"SpringGreen" , PALETTERGB ( 0,255,127)}, + {"lawn green" , PALETTERGB (124,252, 0)}, + {"LawnGreen" , PALETTERGB (124,252, 0)}, + {"green" , PALETTERGB ( 0,255, 0)}, + {"chartreuse" , PALETTERGB (127,255, 0)}, + {"medium spring green" , PALETTERGB ( 0,250,154)}, + {"MediumSpringGreen" , PALETTERGB ( 0,250,154)}, + {"green yellow" , PALETTERGB (173,255, 47)}, + {"GreenYellow" , PALETTERGB (173,255, 47)}, + {"lime green" , PALETTERGB ( 50,205, 50)}, + {"LimeGreen" , PALETTERGB ( 50,205, 50)}, + {"yellow green" , PALETTERGB (154,205, 50)}, + {"YellowGreen" , PALETTERGB (154,205, 50)}, + {"forest green" , PALETTERGB ( 34,139, 34)}, + {"ForestGreen" , PALETTERGB ( 34,139, 34)}, + {"olive drab" , PALETTERGB (107,142, 35)}, + {"OliveDrab" , PALETTERGB (107,142, 35)}, + {"dark khaki" , PALETTERGB (189,183,107)}, + {"DarkKhaki" , PALETTERGB (189,183,107)}, + {"khaki" , PALETTERGB (240,230,140)}, + {"pale goldenrod" , PALETTERGB (238,232,170)}, + {"PaleGoldenrod" , PALETTERGB (238,232,170)}, + {"light goldenrod yellow" , PALETTERGB (250,250,210)}, + {"LightGoldenrodYellow" , PALETTERGB (250,250,210)}, + {"light yellow" , PALETTERGB (255,255,224)}, + {"LightYellow" , PALETTERGB (255,255,224)}, + {"yellow" , PALETTERGB (255,255, 0)}, + {"gold" , PALETTERGB (255,215, 0)}, + {"light goldenrod" , PALETTERGB (238,221,130)}, + {"LightGoldenrod" , PALETTERGB (238,221,130)}, + {"goldenrod" , PALETTERGB (218,165, 32)}, + {"dark goldenrod" , PALETTERGB (184,134, 11)}, + {"DarkGoldenrod" , PALETTERGB (184,134, 11)}, + {"rosy brown" , PALETTERGB (188,143,143)}, + {"RosyBrown" , PALETTERGB (188,143,143)}, + {"indian red" , PALETTERGB (205, 92, 92)}, + {"IndianRed" , PALETTERGB (205, 92, 92)}, + {"saddle brown" , PALETTERGB (139, 69, 19)}, + {"SaddleBrown" , PALETTERGB (139, 69, 19)}, + {"sienna" , PALETTERGB (160, 82, 45)}, + {"peru" , PALETTERGB (205,133, 63)}, + {"burlywood" , PALETTERGB (222,184,135)}, + {"beige" , PALETTERGB (245,245,220)}, + {"wheat" , PALETTERGB (245,222,179)}, + {"sandy brown" , PALETTERGB (244,164, 96)}, + {"SandyBrown" , PALETTERGB (244,164, 96)}, + {"tan" , PALETTERGB (210,180,140)}, + {"chocolate" , PALETTERGB (210,105, 30)}, + {"firebrick" , PALETTERGB (178, 34, 34)}, + {"brown" , PALETTERGB (165, 42, 42)}, + {"dark salmon" , PALETTERGB (233,150,122)}, + {"DarkSalmon" , PALETTERGB (233,150,122)}, + {"salmon" , PALETTERGB (250,128,114)}, + {"light salmon" , PALETTERGB (255,160,122)}, + {"LightSalmon" , PALETTERGB (255,160,122)}, + {"orange" , PALETTERGB (255,165, 0)}, + {"dark orange" , PALETTERGB (255,140, 0)}, + {"DarkOrange" , PALETTERGB (255,140, 0)}, + {"coral" , PALETTERGB (255,127, 80)}, + {"light coral" , PALETTERGB (240,128,128)}, + {"LightCoral" , PALETTERGB (240,128,128)}, + {"tomato" , PALETTERGB (255, 99, 71)}, + {"orange red" , PALETTERGB (255, 69, 0)}, + {"OrangeRed" , PALETTERGB (255, 69, 0)}, + {"red" , PALETTERGB (255, 0, 0)}, + {"hot pink" , PALETTERGB (255,105,180)}, + {"HotPink" , PALETTERGB (255,105,180)}, + {"deep pink" , PALETTERGB (255, 20,147)}, + {"DeepPink" , PALETTERGB (255, 20,147)}, + {"pink" , PALETTERGB (255,192,203)}, + {"light pink" , PALETTERGB (255,182,193)}, + {"LightPink" , PALETTERGB (255,182,193)}, + {"pale violet red" , PALETTERGB (219,112,147)}, + {"PaleVioletRed" , PALETTERGB (219,112,147)}, + {"maroon" , PALETTERGB (176, 48, 96)}, + {"medium violet red" , PALETTERGB (199, 21,133)}, + {"MediumVioletRed" , PALETTERGB (199, 21,133)}, + {"violet red" , PALETTERGB (208, 32,144)}, + {"VioletRed" , PALETTERGB (208, 32,144)}, + {"magenta" , PALETTERGB (255, 0,255)}, + {"violet" , PALETTERGB (238,130,238)}, + {"plum" , PALETTERGB (221,160,221)}, + {"orchid" , PALETTERGB (218,112,214)}, + {"medium orchid" , PALETTERGB (186, 85,211)}, + {"MediumOrchid" , PALETTERGB (186, 85,211)}, + {"dark orchid" , PALETTERGB (153, 50,204)}, + {"DarkOrchid" , PALETTERGB (153, 50,204)}, + {"dark violet" , PALETTERGB (148, 0,211)}, + {"DarkViolet" , PALETTERGB (148, 0,211)}, + {"blue violet" , PALETTERGB (138, 43,226)}, + {"BlueViolet" , PALETTERGB (138, 43,226)}, + {"purple" , PALETTERGB (160, 32,240)}, + {"medium purple" , PALETTERGB (147,112,219)}, + {"MediumPurple" , PALETTERGB (147,112,219)}, + {"thistle" , PALETTERGB (216,191,216)}, + {"gray0" , PALETTERGB ( 0, 0, 0)}, + {"grey0" , PALETTERGB ( 0, 0, 0)}, + {"dark grey" , PALETTERGB (169,169,169)}, + {"DarkGrey" , PALETTERGB (169,169,169)}, + {"dark gray" , PALETTERGB (169,169,169)}, + {"DarkGray" , PALETTERGB (169,169,169)}, + {"dark blue" , PALETTERGB ( 0, 0,139)}, + {"DarkBlue" , PALETTERGB ( 0, 0,139)}, + {"dark cyan" , PALETTERGB ( 0,139,139)}, + {"DarkCyan" , PALETTERGB ( 0,139,139)}, + {"dark magenta" , PALETTERGB (139, 0,139)}, + {"DarkMagenta" , PALETTERGB (139, 0,139)}, + {"dark red" , PALETTERGB (139, 0, 0)}, + {"DarkRed" , PALETTERGB (139, 0, 0)}, + {"light green" , PALETTERGB (144,238,144)}, + {"LightGreen" , PALETTERGB (144,238,144)}, +}; + +static COLORREF +w32_string_to_color(CONST char *name) +{ + int color, i; + + if (*name == '#') + { + /* w32 numeric names look like "#BBGGRR" */ + if (strlen(name)!=7) + return (-1); + for (i=1; i<7; i++) + if (!isxdigit(name[i])) + return(-1); + if (sscanf(name+1, "%x", &color) == 1) + return(0x02000000 | color); /* See PALETTERGB in docs */ + } + else + { + for(i=0; i<(sizeof(w32_X_color_map)/sizeof(colormap_t)); i++) + if (!stricmp(name, w32_X_color_map[i].name)) + return (w32_X_color_map[i].colorref); + } + return(-1); +} + +static int +w32_initialize_color_instance (struct Lisp_Color_Instance *c, Lisp_Object name, + Lisp_Object device, Error_behavior errb) +{ + CONST char *extname; + COLORREF color; + + GET_C_STRING_CTEXT_DATA_ALLOCA (name, extname); + color = w32_string_to_color(extname); + if (color != -1) + { + c->data = xnew (struct w32_color_instance_data); + COLOR_INSTANCE_W32_COLOR (c) = color; + COLOR_INSTANCE_W32_BRUSH (c) = CreateSolidBrush (color); + return 1; + } + maybe_signal_simple_error ("unrecognized color", name, Qcolor, errb); + return(0); +} + +static void +w32_mark_color_instance (struct Lisp_Color_Instance *c, + void (*markobj) (Lisp_Object)) +{ +} + +static void +w32_print_color_instance (struct Lisp_Color_Instance *c, + Lisp_Object printcharfun, + int escapeflag) +{ + char buf[32]; + COLORREF color = COLOR_INSTANCE_W32_COLOR (c); + sprintf (buf, " %06ld=(%02X,%02X,%02X)", color & 0xffffff, + GetRValue(color), GetGValue(color), GetBValue(color)); + write_c_string (buf, printcharfun); +} + +static void +w32_finalize_color_instance (struct Lisp_Color_Instance *c) +{ + if (c->data) + { + DeleteObject (COLOR_INSTANCE_W32_BRUSH (c)); + xfree (c->data); + c->data = 0; + } +} + +static int +w32_color_instance_equal (struct Lisp_Color_Instance *c1, + struct Lisp_Color_Instance *c2, + int depth) +{ + return (COLOR_INSTANCE_W32_COLOR(c1) == COLOR_INSTANCE_W32_COLOR(c2)); +} + +static unsigned long +w32_color_instance_hash (struct Lisp_Color_Instance *c, int depth) +{ + return LISP_HASH (COLOR_INSTANCE_W32_COLOR(c)); +} + +static Lisp_Object +w32_color_instance_rgb_components (struct Lisp_Color_Instance *c) +{ + COLORREF color = COLOR_INSTANCE_W32_COLOR (c); + return (list3 (make_int (GetRValue(color)), + make_int (GetGValue(color)), + make_int (GetBValue(color)))); +} + +static int +w32_valid_color_name_p (struct device *d, Lisp_Object color) +{ + CONST char *extname; + + GET_C_STRING_CTEXT_DATA_ALLOCA (color, extname); + return (w32_string_to_color(extname)!=-1); +} + + + +static void +w32_finalize_font_instance (struct Lisp_Font_Instance *f) +{ + if (f->data) + { + DeleteObject(f->data); + f->data=0; + } +} + +static int +w32_initialize_font_instance (struct Lisp_Font_Instance *f, Lisp_Object name, + Lisp_Object device, Error_behavior errb) +{ + CONST char *extname; + LOGFONT logfont; + int fields; + int pt; + char fontname[LF_FACESIZE], weight[32], *style, points[8], effects[32], charset[32]; + + GET_C_STRING_CTEXT_DATA_ALLOCA (f->name, extname); + + /* + * w32 fonts look like: + * fontname[:[weight ][style][:pointsize[:effects[:charset]]]] + * The font name field shouldn't be empty. + * XXX Windows will substitute a default (monospace) font if the font name + * specifies a non-existent font. We don't catch this. + * effects and charset are currently ignored. + * + * ie: + * Lucida Console:Regular:10 + * minimal: + * Courier New + * maximal: + * Courier New:Bold Italic:10:underline strikeout:ansi + */ + fields = sscanf (extname, "%31[^:]:%31[^:]:%7[^:]:%31[^:]:%31s", + fontname, weight, points, effects, charset); + + if (fields<0) + { + maybe_signal_simple_error ("Invalid font", f->name, Qfont, errb); + return (0); + } + + if (fields>0 && strlen(fontname)) + { + strncpy (logfont.lfFaceName, fontname, LF_FACESIZE); + logfont.lfFaceName[LF_FACESIZE-1] = 0; + } + else + { + maybe_signal_simple_error ("Must specify a font name", f->name, Qfont, errb); + return (0); + } + + if (fields > 1 && strlen(weight)) + { + char *c; + /* Maybe split weight into weight and style */ + if (c=strchr(weight, ' ')) + { + *c = '\0'; + style = c+1; + } + else + style = NULL; + + /* weight: Most-often used (maybe) first */ + if (stricmp (weight,"regular") == 0) + logfont.lfWeight = FW_REGULAR; + else if (stricmp (weight,"normal") == 0) + logfont.lfWeight = FW_NORMAL; + else if (stricmp (weight,"bold") == 0) + logfont.lfWeight = FW_BOLD; + else if (stricmp (weight,"medium") == 0) + logfont.lfWeight = FW_MEDIUM; + else if (stricmp (weight,"italic") == 0) /* Hack for early exit */ + { + logfont.lfWeight = FW_NORMAL; + style=weight; + } + /* the rest */ + else if (stricmp (weight,"black") == 0) + logfont.lfWeight = FW_BLACK; + else if (stricmp (weight,"heavy") == 0) + logfont.lfWeight = FW_HEAVY; + else if (stricmp (weight,"ultrabold") == 0) + logfont.lfWeight = FW_ULTRABOLD; + else if (stricmp (weight,"extrabold") == 0) + logfont.lfWeight = FW_EXTRABOLD; + else if (stricmp (weight,"demibold") == 0) + logfont.lfWeight = FW_SEMIBOLD; + else if (stricmp (weight,"semibold") == 0) + logfont.lfWeight = FW_SEMIBOLD; + else if (stricmp (weight,"light") == 0) + logfont.lfWeight = FW_LIGHT; + else if (stricmp (weight,"ultralight") == 0) + logfont.lfWeight = FW_ULTRALIGHT; + else if (stricmp (weight,"extralight") == 0) + logfont.lfWeight = FW_EXTRALIGHT; + else if (stricmp (weight,"thin") == 0) + logfont.lfWeight = FW_THIN; + else + { + logfont.lfWeight = FW_NORMAL; + if (!style) + style = weight; /* May have specified a style without a weight */ + else + { + maybe_signal_simple_error ("Invalid font weight", f->name, Qfont, errb); + return (0); /* Invalid weight */ + } + } + + if (style) + { + /* XXX what about oblique? */ + if (stricmp (style,"italic") == 0) + logfont.lfItalic = TRUE; + else if (stricmp (style,"roman") == 0) + logfont.lfItalic = FALSE; + else + { + maybe_signal_simple_error ("Invalid font weight or style", f->name, Qfont, errb); + return (0); /* Invalid weight or style */ + } + } + else + { + logfont.lfItalic = FALSE; + } + + } + else + { + logfont.lfWeight = FW_NORMAL; + logfont.lfItalic = FALSE; + } + + /* XXX Should we reject strings that don't specify a size? */ + if (fields < 3 || !strlen(points) || (pt=atoi(points))==0) + pt = 10; + + /* Formula for pointsize->height from LOGFONT docs in MSVC5 Platform SDK */ + logfont.lfHeight = -MulDiv(pt, DEVICE_W32_LOGPIXELSY(XDEVICE (device)), 72); + logfont.lfWidth = 0; + + /* Default to monospaced if the specified font name is not found */ + logfont.lfPitchAndFamily = FF_MODERN; + + /* XXX: FIXME? */ + logfont.lfUnderline = FALSE; + logfont.lfStrikeOut = FALSE; + + /* XXX: FIXME: we ignore charset */ + logfont.lfCharSet = DEFAULT_CHARSET; + + /* Misc crud */ + logfont.lfEscapement = logfont.lfOrientation = 0; +#if 1 + logfont.lfOutPrecision = OUT_DEFAULT_PRECIS; + logfont.lfClipPrecision = CLIP_DEFAULT_PRECIS; + logfont.lfQuality = DEFAULT_QUALITY; +#else + logfont.lfOutPrecision = OUT_STROKE_PRECIS; + logfont.lfClipPrecision = CLIP_STROKE_PRECIS; + logfont.lfQuality = PROOF_QUALITY; +#endif + + if ((f->data = CreateFontIndirect(&logfont)) == NULL) + { + maybe_signal_simple_error ("Couldn't create font", f->name, Qfont, errb); + return 0; + } + + /* Have to apply Font to a GC to get its values. + * We'll borrow the desktop window becuase its the only window that we + * know about that is guaranteed to exist when this gets called + */ + { + HWND hwnd; + HDC hdc; + HFONT holdfont; + TEXTMETRIC metrics; + + hwnd = GetDesktopWindow(); + assert(hdc = GetDC(hwnd)); /* XXX FIXME: can this temporarily fail? */ + holdfont = SelectObject(hdc, f->data); + if (!holdfont) + { + w32_finalize_font_instance (f); + maybe_signal_simple_error ("Couldn't map font", f->name, Qfont, errb); + return 0; + } + GetTextMetrics(hdc, &metrics); + SelectObject(hdc, holdfont); + ReleaseDC(hwnd, hdc); + f->width = metrics.tmAveCharWidth; + f->height = metrics.tmHeight; + f->ascent = metrics.tmAscent; + f->descent = metrics.tmDescent; + f->proportional_p = (metrics.tmPitchAndFamily & TMPF_FIXED_PITCH); + } + + return 1; +} + +static void +w32_mark_font_instance (struct Lisp_Font_Instance *f, + void (*markobj) (Lisp_Object)) +{ +} + +static void +w32_print_font_instance (struct Lisp_Font_Instance *f, + Lisp_Object printcharfun, + int escapeflag) +{ +} + +static Lisp_Object +w32_list_fonts (Lisp_Object pattern, Lisp_Object device) +{ + /* XXX Implement me */ + return list1 (build_string ("Courier New:Regular:10")); +} + + + +/************************************************************************/ +/* initialization */ +/************************************************************************/ + +void +syms_of_objects_w32 (void) +{ +} + +void +console_type_create_objects_w32 (void) +{ + /* object methods */ + CONSOLE_HAS_METHOD (w32, initialize_color_instance); +/* CONSOLE_HAS_METHOD (w32, mark_color_instance); */ + CONSOLE_HAS_METHOD (w32, print_color_instance); + CONSOLE_HAS_METHOD (w32, finalize_color_instance); + CONSOLE_HAS_METHOD (w32, color_instance_equal); + CONSOLE_HAS_METHOD (w32, color_instance_hash); + CONSOLE_HAS_METHOD (w32, color_instance_rgb_components); + CONSOLE_HAS_METHOD (w32, valid_color_name_p); + + CONSOLE_HAS_METHOD (w32, initialize_font_instance); +/* CONSOLE_HAS_METHOD (w32, mark_font_instance); */ + CONSOLE_HAS_METHOD (w32, print_font_instance); + CONSOLE_HAS_METHOD (w32, finalize_font_instance); +/* CONSOLE_HAS_METHOD (w32, font_instance_truename); */ + CONSOLE_HAS_METHOD (w32, list_fonts); +#ifdef MULE + CONSOLE_HAS_METHOD (w32, font_spec_matches_charset); + CONSOLE_HAS_METHOD (w32, find_charset_font); +#endif +} + +void +vars_of_objects_w32 (void) +{ +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/objects-w32.h Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,52 @@ +/* win32-specific Lisp objects. + Copyright (C) 1993, 1994 Free Software Foundation, Inc. + Copyright (C) 1995 Board of Trustees, University of Illinois. + Copyright (C) 1995, 1996 Ben Wing. + Copyright (C) 1997, Jonathan Harris. + +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. */ + +/* Authorship: + + Ultimately based on FSF. + Rewritten by Ben Wing. + Rewritten for win32 by Jonathan Harris, November 1997 for 20.4. + */ + + +#ifndef _XEMACS_OBJECTS_W32_H_ +#define _XEMACS_OBJECTS_W32_H_ + +#include "objects.h" + +struct w32_color_instance_data +{ + COLORREF color; + HBRUSH brush; +}; + +#define W32_COLOR_INSTANCE_DATA(c) ((struct w32_color_instance_data *) (c)->data) +#define COLOR_INSTANCE_W32_COLOR(c) (W32_COLOR_INSTANCE_DATA (c)->color) +#define COLOR_INSTANCE_W32_BRUSH(c) (W32_COLOR_INSTANCE_DATA (c)->brush) + + +#define FONT_INSTANCE_W32_HFONT(c) ((HFONT) (c)->data) + +#endif /* _XEMACS_OBJECTS_W32_H_ */
--- a/src/offix.h Mon Aug 13 10:03:54 2007 +0200 +++ b/src/offix.h Mon Aug 13 10:04:58 2007 +0200 @@ -26,7 +26,7 @@ #include "offix-types.h" /* Xt stuff is defined here */ -#include <X11/Intrinsic.h> +#include "xintrinsic.h" void DndInitialize(Widget shell);
--- a/src/process.c Mon Aug 13 10:03:54 2007 +0200 +++ b/src/process.c Mon Aug 13 10:04:58 2007 +0200 @@ -701,7 +701,6 @@ return 0; } -#ifndef VMS /* VMS version of this function is in vmsproc.c. */ static Bufbyte get_eof_char (struct Lisp_Process *p) @@ -1083,7 +1082,6 @@ report_file_error ("Opening pty or pipe", Qnil); } } -#endif /* not VMS */ /* This function is the unwind_protect form for Fstart_process_internal. If PROC doesn't have its pid set, then we know someone has signalled @@ -1121,12 +1119,7 @@ Lisp_Object tem; int speccount = specpdl_depth (); struct gcpro gcpro1, gcpro2, gcpro3; -#ifdef VMS - char *new_argv; - int len; -#else char **new_argv; -#endif int i; name = args[0]; @@ -1162,28 +1155,6 @@ list1 (current_buffer->directory)); #endif /* 0 */ -#ifdef VMS - /* Make a one member argv with all args concatenated - together separated by a blank. */ - len = XSTRING_LENGTH (program) + 2; - for (i = 3; i < nargs; i++) - { - tem = args[i]; - CHECK_STRING (tem); - len += XSTRING_LENGTH (tem) + 1; /* count the blank */ - } - new_argv = (char *) alloca (len); - strcpy (new_argv, XSTRING_DATA (program)); - for (i = 3; i < nargs; i++) - { - tem = args[i]; - CHECK_STRING (tem); - strcat (new_argv, " "); - strcat (new_argv, XSTRING_DATA (tem)); - } - /* Need to add code here to check for program existence on VMS */ - -#else /* not VMS */ /* If program file name is not absolute, search our path for it */ if (!IS_DIRECTORY_SEP (XSTRING_BYTE (program, 0)) && !(XSTRING_LENGTH (program) > 1 @@ -1217,8 +1188,6 @@ } new_argv[i - 2] = 0; -#endif /* not VMS */ - proc = make_process_internal (name); XPROCESS (proc)->buffer = buffer; @@ -1605,11 +1574,7 @@ { /* This function can GC */ Bytecount nbytes, nchars; -#ifdef VMS - char *chars; -#else Bufbyte chars[1024]; -#endif Lisp_Object outstream; struct Lisp_Process *p = XPROCESS (proc); @@ -1639,28 +1604,6 @@ return XINT (filter_result); } -#ifdef VMS - VMS_PROC_STUFF *vs, *get_vms_process_pointer(); - - vs = get_vms_process_pointer (XINT (p->pid)); - if (vs) - { - if (!vs->iosb[0]) - return 0; /* Really weird if it does this */ - if (!(vs->iosb[0] & 1)) - return -1; /* I/O error */ - } - else - error ("Could not get VMS process pointer"); - chars = vs->inputBuffer; - nbytes = clean_vms_buffer (chars, vs->iosb[1]); - if (nbytes <= 0) - { - start_vms_process_read (vs); /* Crank up the next read on the process */ - return 1; /* Nothing worth printing, say we got 1 */ - } -#else /* not VMS */ - #if 0 /* FSFmacs */ /* #### equivalent code from FSFmacs. Would need some porting for Windows NT. */ @@ -1688,7 +1631,6 @@ nbytes = Lstream_read (XLSTREAM (p->instream), chars, sizeof (chars)); if (nbytes <= 0) return nbytes; -#endif /* not VMS */ nchars = bytecount_to_charcount (chars, nbytes); outstream = p->filter; @@ -1701,9 +1643,6 @@ outstream, proc, make_string (chars, nbytes)); running_asynch_code = 0; restore_match_data (); -#ifdef VMS - start_vms_process_read (vs); -#endif return nchars; } @@ -1792,9 +1731,6 @@ UNGCPRO; } -#ifdef VMS - start_vms_process_read (vs); -#endif return nchars; } @@ -1836,24 +1772,11 @@ Lisp_Object defeat_volatile_kludge = proc; #endif -#ifdef VMS - VMS_PROC_STUFF *vs, *get_vms_process_pointer (int); -#endif /* VMS */ - GCPRO2 (defeat_volatile_kludge, lstream); if (p->outfd < 0) signal_simple_error ("Process not open for writing", proc); -#ifdef VMS - vs = get_vms_process_pointer (XINT (p->pid)); - if (vs == 0) - error ("Could not find this process: %x", - XINT (p->pid)); - else if (write_to_vms_process (vs, buf, len)) - ; -#else - if (nonrelocatable) lstream = make_fixed_buffer_input_stream (nonrelocatable + start, len); @@ -1905,7 +1828,6 @@ } } } -#endif /* !VMS */ else { /* We got here from a longjmp() from the SIGPIPE handler */ signal (SIGPIPE, old_sigpipe); @@ -1915,13 +1837,8 @@ p->tick++; process_tick++; deactivate_process (proc); -#ifdef VMS - error ("Error writing to process %s; closed it", - XSTRING_DATA (p->name)); -#else error ("SIGPIPE raised on process %s; closed it", XSTRING_DATA (p->name)); -#endif } old_sigpipe = (SIGTYPE (*) (int)) signal (SIGPIPE, send_process_trap); Lstream_flush (XLSTREAM (p->outstream)); @@ -2206,11 +2123,8 @@ signal_name (int signum) { if (signum >= 0 && signum < NSIG) -#ifndef VMS return (CONST char *) sys_siglist[signum]; -#else - return (CONST char *) sys_errlist[signum]; -#endif + return (CONST char *) GETTEXT ("unknown signal"); } @@ -2882,22 +2796,8 @@ break; #endif /* ! defined (SIGCONT) */ case SIGINT: -#ifdef VMS - send_process (proc, Qnil, (Bufbyte *) "\003", 0, - 1); /* ^C */ - goto whoosh; -#endif case SIGQUIT: -#ifdef VMS - send_process (proc, Qnil, (Bufbyte *) "\031", 0, - 1); /* ^Y */ - goto whoosh; -#endif case SIGKILL: -#ifdef VMS - sys$forcex (&(XINT (p->pid)), 0, 1); - whoosh: -#endif flush_pending_output (p->infd); break; } @@ -3140,9 +3040,6 @@ if (! EQ (XPROCESS (proc)->status_symbol, Qrun)) error ("Process %s not running", XSTRING_DATA (XPROCESS (proc)->name)); -#ifdef VMS - send_process (proc, Qnil, (Bufbyte *) "\032", 0, 1); /* ^Z */ -#else if (XPROCESS (proc)->pty_flag) { /* #### get_eof_char simply doesn't return the correct character @@ -3161,7 +3058,7 @@ close (XPROCESS (proc)->outfd); XPROCESS (proc)->outfd = open (NULL_DEVICE, O_WRONLY, 0); } -#endif /* !VMS */ + return process; } @@ -3201,16 +3098,6 @@ far as selecting the process for input. In this case, p->pid is nil: p->pid is set at the same time that the process is selected for input. */ -#ifdef VMS - { - VMS_PROC_STUFF *get_vms_process_pointer (), *vs; - if (outchannel >= 0) - sys$dassgn (outchannel); - vs = get_vms_process_pointer (XINT (p->pid)); - if (vs) - give_back_vms_process_stuff (vs); - } -#endif /* VMS */ /* Must call this before setting the file descriptors to 0 */ event_stream_unselect_process (p); }
--- a/src/process.h Mon Aug 13 10:03:54 2007 +0200 +++ b/src/process.h Mon Aug 13 10:04:58 2007 +0200 @@ -115,11 +115,6 @@ void deactivate_process (Lisp_Object proc); -#ifdef VMS -void create_process (Lisp_Object process, char **new_argv, - CONST char *current_dir); -#endif - #ifdef WINDOWSNT int #else @@ -137,13 +132,13 @@ #endif /* not NO_SUBPROCESSES */ /* The name of the file open to get a null file, or a data sink. - VMS, MS-DOS, and OS/2 redefine this. */ + MS-DOS, and OS/2 redefine this. */ #ifndef NULL_DEVICE #define NULL_DEVICE "/dev/null" #endif /* A string listing the possible suffixes used for executable files, - separated by colons. VMS, MS-DOS, and OS/2 redefine this. */ + separated by colons. MS-DOS, and OS/2 redefine this. */ #ifndef EXEC_SUFFIXES #define EXEC_SUFFIXES "" #endif
--- a/src/redisplay-output.c Mon Aug 13 10:03:54 2007 +0200 +++ b/src/redisplay-output.c Mon Aug 13 10:04:58 2007 +0200 @@ -1149,7 +1149,7 @@ larger impact on their sizing. */ /* #### See if we can get away with only calling this if max_line_len is greater than the window_char_width. */ -#ifdef HAVE_SCROLLBARS +#if defined(HAVE_SCROLLBARS) && defined(HAVE_X_WINDOWS) { extern int stupid_vertical_scrollbar_drag_hack;
--- a/src/redisplay-tty.c Mon Aug 13 10:03:54 2007 +0200 +++ b/src/redisplay-tty.c Mon Aug 13 10:04:58 2007 +0200 @@ -1102,9 +1102,14 @@ CONSOLE_TTY_DATA (c)->term_entry_buffer = (char *) xmalloc (2044); bufptr = CONSOLE_TTY_DATA (c)->term_entry_buffer; +#if !defined(WIN32) + /* SIGTT* don't exist under win32 */ EMACS_BLOCK_SIGNAL (SIGTTOU); +#endif status = tgetent (entry_buffer, terminal_type); +#if !defined(WIN32) EMACS_UNBLOCK_SIGNAL (SIGTTOU); +#endif #if 0 if (status < 0) return TTY_UNABLE_OPEN_DATABASE;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/redisplay-w32.c Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,1184 @@ +/* win32 output and frame manipulation routines. + Copyright (C) 1994, 1995 Board of Trustees, University of Illinois. + Copyright (C) 1994 Lucid, Inc. + Copyright (C) 1995 Sun Microsystems, Inc. + +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. */ + +/* Authorship: + + Chuck Thompson + Lots of work done by Ben Wing for Mule + Partially rewritten for win32 by Jonathan Harris, November 1997 for 20.4. + */ + +#include <config.h> +#include "lisp.h" + +#include "console-w32.h" +#include "objects-w32.h" + +#include "buffer.h" +#include "debug.h" +#include "events.h" +#include "faces.h" +#include "frame.h" +#include "glyphs.h" /* XXX FIXME: Should be glyphs-w32 when we make one */ +#include "redisplay.h" +#include "sysdep.h" +#include "window.h" + +#include "windows.h" + +/* W32_DIVIDER_LINE_WIDTH is the width of the line drawn in the gutter. + W32_DIVIDER_SPACING is the amount of blank space on each side of the line. + W32_DIVIDER_WIDTH = W32_DIVIDER_LINE_WIDTH + 2*W32_DIVIDER_SPACING +*/ +#define W32_DIVIDER_LINE_WIDTH 5 +#define W32_DIVIDER_SPACING 0 +#define W32_DIVIDER_WIDTH (W32_DIVIDER_LINE_WIDTH + 2 * W32_DIVIDER_SPACING) + +#define W32_EOL_CURSOR_WIDTH 5 + +/* + * Random forward delarations + */ +static void w32_clear_region (Lisp_Object locale, face_index findex, + int x, int y, int width, int height); +static void w32_output_vertical_divider (struct window *w, int clear); +static void w32_redraw_exposed_windows (Lisp_Object window, int x, + int y, int width, int height); + + + +typedef struct textual_run +{ + Lisp_Object charset; + unsigned char *ptr; + int len; + int dimension; +} textual_run; + +/* Separate out the text in DYN into a series of textual runs of a + particular charset. Also convert the characters as necessary into + the format needed by XDrawImageString(), XDrawImageString16(), et + al. (This means converting to one or two byte format, possibly + tweaking the high bits, and possibly running a CCL program.) You + must pre-allocate the space used and pass it in. (This is done so + you can alloca() the space.) You need to allocate (2 * len) bytes + of TEXT_STORAGE and (len * sizeof (textual_run)) bytes of + RUN_STORAGE, where LEN is the length of the dynarr. + + Returns the number of runs actually used. */ + +static int +separate_textual_runs (unsigned char *text_storage, + textual_run *run_storage, + CONST Emchar *str, Charcount len) +{ + Lisp_Object prev_charset = Qunbound; /* not Qnil because that is a + possible valid charset when + MULE is not defined */ + int runs_so_far = 0; + int i; +#ifdef MULE + struct ccl_program char_converter; + int need_ccl_conversion = 0; +#endif + + for (i = 0; i < len; i++) + { + Emchar ch = str[i]; + Lisp_Object charset; + int byte1, byte2; + int dimension; + int graphic; + + BREAKUP_CHAR (ch, charset, byte1, byte2); + dimension = XCHARSET_DIMENSION (charset); + graphic = XCHARSET_GRAPHIC (charset); + + if (!EQ (charset, prev_charset)) + { + run_storage[runs_so_far].ptr = text_storage; + run_storage[runs_so_far].charset = charset; + run_storage[runs_so_far].dimension = dimension; + + if (runs_so_far) + { + run_storage[runs_so_far - 1].len = + text_storage - run_storage[runs_so_far - 1].ptr; + if (run_storage[runs_so_far - 1].dimension == 2) + run_storage[runs_so_far - 1].len >>= 1; + } + runs_so_far++; + prev_charset = charset; +#ifdef MULE + { + Lisp_Object ccl_prog = XCHARSET_CCL_PROGRAM (charset); + need_ccl_conversion = !NILP (ccl_prog); + if (need_ccl_conversion) + set_ccl_program (&char_converter, ccl_prog, 0, 0, 0); + } +#endif + } + + if (graphic == 0) + { + byte1 &= 0x7F; + byte2 &= 0x7F; + } + else if (graphic == 1) + { + byte1 |= 0x80; + byte2 |= 0x80; + } +#ifdef MULE + if (need_ccl_conversion) + { + char_converter.reg[0] = byte1; + char_converter.reg[1] = byte2; + char_converter.ic = 0; /* start at beginning each time */ + ccl_driver (&char_converter, 0, 0, 0, 0); + byte1 = char_converter.reg[0]; + byte2 = char_converter.reg[1]; + } +#endif + *text_storage++ = (unsigned char) byte1; + if (dimension == 2) + *text_storage++ = (unsigned char) byte2; + } + + if (runs_so_far) + { + run_storage[runs_so_far - 1].len = + text_storage - run_storage[runs_so_far - 1].ptr; + if (run_storage[runs_so_far - 1].dimension == 2) + run_storage[runs_so_far - 1].len >>= 1; + } + + return runs_so_far; +} + + +static int +w32_text_width_single_run (HDC hdc, struct face_cachel *cachel, + textual_run *run) +{ + Lisp_Object font_inst = FACE_CACHEL_FONT (cachel, run->charset); + struct Lisp_Font_Instance *fi = XFONT_INSTANCE (font_inst); + SIZE size; + +#if 0 /* XXX HACK: w32_text_width is broken and will pass in a NULL hdc */ + if (!fi->proportional_p) +#else + if (!fi->proportional_p || !hdc) +#endif + return (fi->width * run->len); + else + { + assert(run->dimension == 1); /* XXX FIXME! */ + GetTextExtentPoint32(hdc, run->ptr, run->len, &size); + return(size.cx); + } +} + + +/***************************************************************************** + w32_update_gc + + Given a number of parameters munge the GC so it has those properties. + ****************************************************************************/ +static void +w32_update_gc (HDC hdc, Lisp_Object font, Lisp_Object fg, Lisp_Object bg, + Lisp_Object bg_pmap, Lisp_Object lwidth) +{ + if (!NILP (font)) + SelectObject(hdc, (XFONT_INSTANCE (font))->data); + + /* evil kludge! - XXX do we need this? */ + if (!NILP (fg) && !COLOR_INSTANCEP (fg)) + { + fprintf (stderr, "Help! w32_update_gc got a bogus fg value! fg = "); + debug_print (fg); + fg = Qnil; + } + + if (!NILP (fg)) + SetTextColor (hdc, COLOR_INSTANCE_W32_COLOR (XCOLOR_INSTANCE (fg))); + + if (!NILP (bg)) + SetBkColor (hdc, COLOR_INSTANCE_W32_COLOR (XCOLOR_INSTANCE (bg))); + +#if 0 /* XXX Implement me */ + /* I expect that the Lisp_Image_Instance's data will point to a brush */ + if (IMAGE_INSTANCEP (bg_pmap) + && IMAGE_INSTANCE_PIXMAP_TYPE_P (XIMAGE_INSTANCE (bg_pmap))) + { + if (XIMAGE_INSTANCE_PIXMAP_DEPTH (bg_pmap) == 0) + { + gcv.fill_style = FillOpaqueStippled; + gcv.stipple = XIMAGE_INSTANCE_X_PIXMAP (bg_pmap); + mask |= (GCStipple | GCFillStyle); + } + else + { + gcv.fill_style = FillTiled; + gcv.tile = XIMAGE_INSTANCE_X_PIXMAP (bg_pmap); + mask |= (GCTile | GCFillStyle); + } + } +#endif + +#if 0 /* XXX FIXME */ + if (!NILP (lwidth)) + { + gcv.line_width = XINT (lwidth); + mask |= GCLineWidth; + } +#endif +} + + +/***************************************************************************** + w32_output_hline + + Output a horizontal line in the foreground of its face. + ****************************************************************************/ +static void +w32_output_hline (struct window *w, struct display_line *dl, struct rune *rb) +{ /* XXX Implement me */ +} + + +/***************************************************************************** + w32_output_blank + + Output a blank by clearing the area it covers in the background color + of its face. + ****************************************************************************/ +static void +w32_output_blank (struct window *w, struct display_line *dl, struct rune *rb) +{ + struct frame *f = XFRAME (w->frame); + RECT rect = { rb->xpos, dl->ypos-dl->ascent, + rb->xpos+rb->width, dl->ypos+dl->descent-dl->clip }; + struct face_cachel *cachel = WINDOW_FACE_CACHEL (w, rb->findex); + + Lisp_Object bg_pmap = WINDOW_FACE_CACHEL_BACKGROUND_PIXMAP (w, rb->findex); + + if (!IMAGE_INSTANCEP (bg_pmap) + || !IMAGE_INSTANCE_PIXMAP_TYPE_P (XIMAGE_INSTANCE (bg_pmap))) + bg_pmap = Qnil; + + FillRect (FRAME_W32_DC (f), &rect, + COLOR_INSTANCE_W32_BRUSH (XCOLOR_INSTANCE (cachel->background))); +} + + +/***************************************************************************** + w32_output_cursor + + Draw a normal or end-of-line cursor. The end-of-line cursor is + narrower than the normal cursor. + ****************************************************************************/ +static void +w32_output_cursor (struct window *w, struct display_line *dl, int xpos, + int width, struct rune *rb) +{ + struct frame *f = XFRAME (w->frame); + struct device *d = XDEVICE (f->device); + struct face_cachel *cachel; + Lisp_Object font; + int focus = EQ (w->frame, DEVICE_FRAME_WITH_FOCUS_REAL (d)); + HBRUSH brush; + HDC hdc = FRAME_W32_DC (f); + int real_char_p = (rb->type == RUNE_CHAR && rb->object.chr.ch != '\n'); + RECT rect = { xpos, + dl->ypos - dl->ascent, + xpos + width, + dl->ypos + dl->descent - dl->clip}; + +#if 0 /* XXX FIXME: Whar about the bar_cursor? */ + Lisp_Object bar_cursor_value = symbol_value_in_buffer (Qbar_cursor, + WINDOW_BUFFER (w)); +#endif + + if (real_char_p) + { + /* Use the font from the underlying character */ + cachel = WINDOW_FACE_CACHEL (w, rb->findex); + + /* XXX MULE: Need to know the charset! */ + font = FACE_CACHEL_FONT (cachel, Vcharset_ascii); + } + + /* Clear the area */ + if (focus) + cachel = WINDOW_FACE_CACHEL (w, + get_builtin_face_cache_index (w, Vtext_cursor_face)); + else if (!real_char_p) + cachel = WINDOW_FACE_CACHEL (w, rb->findex); + + brush = COLOR_INSTANCE_W32_BRUSH (XCOLOR_INSTANCE (cachel->background)); + FillRect (hdc, &rect, brush); + + if (real_char_p) + { + /* XXX FIXME: Need to clip if dl->clip!=0. How rare is this case? */ + /* Output the underlying character */ + w32_update_gc (hdc, font, cachel->foreground, + cachel->background, Qnil, Qnil); + TextOut(hdc, xpos, dl->ypos, (char*) &rb->object.chr.ch, 1); + } + + if (!focus) + { + /* Draw hollow rectangle in cursor's background color */ + cachel = WINDOW_FACE_CACHEL (w, + get_builtin_face_cache_index (w, Vtext_cursor_face)); + brush = COLOR_INSTANCE_W32_BRUSH (XCOLOR_INSTANCE (cachel->background)); + FrameRect (hdc, &rect, brush); + } +} + + +/***************************************************************************** + w32_output_string + + Given a string and a starting position, output that string in the + given face. + Correctly handles multiple charsets in the string. + + The meaning of the parameters is something like this: + + W Window that the text is to be displayed in. + DL Display line that this text is on. The values in the + structure are used to determine the vertical position and + clipping range of the text. + BUF Dynamic array of Emchars specifying what is actually to be + drawn. + XPOS X position in pixels where the text should start being drawn. + XOFFSET Number of pixels to be chopped off the left side of the + text. The effect is as if the text were shifted to the + left this many pixels and clipped at XPOS. + CLIP_START Clip everything left of this X position. + WIDTH Clip everything right of XPOS + WIDTH. + FINDEX Index for the face cache element describing how to display + the text. + ****************************************************************************/ +void +w32_output_string (struct window *w, struct display_line *dl, + Emchar_dynarr *buf, int xpos, int xoffset, int clip_start, + int width, face_index findex) +{ + struct frame *f = XFRAME (w->frame); + struct device *d = XDEVICE (f->device); + Lisp_Object window = Qnil; + HDC hdc; + int clip_end; + Lisp_Object bg_pmap; + int len = Dynarr_length (buf); + unsigned char *text_storage = (unsigned char *) alloca (2 * len); + textual_run *runs = alloca_array (textual_run, len); + int nruns; + int i; + struct face_cachel *cachel = WINDOW_FACE_CACHEL (w, findex); + + XSETWINDOW (window, w); + hdc = FRAME_W32_DC(f); + +#if 0 /* XXX: FIXME? */ + /* We can't work out the width before we've set the font in the DC */ + if (width < 0) + width = w32_text_width (cachel, Dynarr_atp (buf, 0), Dynarr_length (buf)); +#else + assert(width>=0); +#endif + + /* Regularize the variables passed in. */ + if (clip_start < xpos) + clip_start = xpos; + clip_end = xpos + width; + if (clip_start >= clip_end) + /* It's all clipped out. */ + return; + + xpos -= xoffset; + + nruns = separate_textual_runs (text_storage, runs, Dynarr_atp (buf, 0), + Dynarr_length (buf)); + + bg_pmap = cachel->background_pixmap; + if (!IMAGE_INSTANCEP (bg_pmap) + || !IMAGE_INSTANCE_PIXMAP_TYPE_P (XIMAGE_INSTANCE (bg_pmap))) + bg_pmap = Qnil; + + for (i = 0; i < nruns; i++) + { + Lisp_Object font = FACE_CACHEL_FONT (cachel, runs[i].charset); + struct Lisp_Font_Instance *fi = XFONT_INSTANCE (font); + int this_width; + int need_clipping; + RECT rect = { clip_start, dl->ypos - dl->ascent, + clip_end, dl->ypos + dl->descent - dl->clip }; + HRGN region; + + if (EQ (font, Vthe_null_font_instance)) + continue; + + w32_update_gc (hdc, font, cachel->foreground, + cachel->background, Qnil, Qnil); + + this_width = w32_text_width_single_run (hdc, cachel, runs + i); + need_clipping = (dl->clip || clip_start > xpos || + clip_end < xpos + this_width); + + if (need_clipping) + { + region = CreateRectRgn (rect.left, rect.top, + rect.right, rect.bottom); + SelectClipRgn (hdc, region); + } + + /* TextOut only clears the area equal to the height of + the given font. It is possible that a font is being displayed + on a line taller than it is, so this would cause us to fail to + clear some areas. */ + if (fi->ascent < dl->ascent || fi->descent < dl->descent-dl->clip) + FillRect (hdc, &rect, + COLOR_INSTANCE_W32_BRUSH (XCOLOR_INSTANCE (cachel->background))); + + assert (runs[i].dimension == 1); /* XXX FIXME */ + TextOut(hdc, xpos, dl->ypos, (char *) runs[i].ptr, runs[i].len); + + /* XXX FIXME? X does underline/strikethrough here + we will do it as part of face's font */ + + if (need_clipping) + { + SelectClipRgn (hdc, NULL); + DeleteObject (region); + } + + xpos += this_width; + } +} + +/***************************************************************************** + w32_redraw_exposed_window + + Given a bounding box for an area that needs to be redrawn, determine + what parts of what lines are contained within and re-output their + contents. + Copied from redisplay-x.c + ****************************************************************************/ +static void +w32_redraw_exposed_window (struct window *w, int x, int y, int width, + int height) +{ + struct frame *f = XFRAME (w->frame); + int line; + int start_x, start_y, end_x, end_y; + int orig_windows_structure_changed; + + display_line_dynarr *cdla = window_display_lines (w, CURRENT_DISP); + + if (!NILP (w->vchild)) + { + w32_redraw_exposed_windows (w->vchild, x, y, width, height); + return; + } + else if (!NILP (w->hchild)) + { + w32_redraw_exposed_windows (w->hchild, x, y, width, height); + return; + } + + /* If the window doesn't intersect the exposed region, we're done here. */ + if (x >= WINDOW_RIGHT (w) || (x + width) <= WINDOW_LEFT (w) + || y >= WINDOW_BOTTOM (w) || (y + height) <= WINDOW_TOP (w)) + { + return; + } + else + { + start_x = max (WINDOW_LEFT (w), x); + end_x = min (WINDOW_RIGHT (w), (x + width)); + start_y = max (WINDOW_TOP (w), y); + end_y = min (WINDOW_BOTTOM (w), y + height); + + /* We do this to make sure that the 3D modelines get redrawn if + they are in the exposed region. */ + orig_windows_structure_changed = f->windows_structure_changed; + f->windows_structure_changed = 1; + } + + if (window_needs_vertical_divider (w)) + { + w32_output_vertical_divider (w, 0); + } + + for (line = 0; line < Dynarr_length (cdla); line++) + { + struct display_line *cdl = Dynarr_atp (cdla, line); + int top_y = cdl->ypos - cdl->ascent; + int bottom_y = cdl->ypos + cdl->descent; + + if (bottom_y >= start_y) + { + if (top_y > end_y) + { + if (line == 0) + continue; + else + break; + } + else + { + output_display_line (w, 0, cdla, line, start_x, end_x); + } + } + } + + f->windows_structure_changed = orig_windows_structure_changed; + + /* If there have never been any face cache_elements created, then this + expose event doesn't actually have anything to do. */ + if (Dynarr_largest (w->face_cachels)) + redisplay_clear_bottom_of_window (w, cdla, start_y, end_y); +} + +/***************************************************************************** + w32_redraw_exposed_windows + + For each window beneath the given window in the window hierarchy, + ensure that it is redrawn if necessary after an Expose event. + ****************************************************************************/ +static void +w32_redraw_exposed_windows (Lisp_Object window, int x, int y, int width, + int height) +{ + for (; !NILP (window); window = XWINDOW (window)->next) + w32_redraw_exposed_window (XWINDOW (window), x, y, width, height); +} + +/***************************************************************************** + w32_redraw_exposed_area + + For each window on the given frame, ensure that any area in the + Exposed area is redrawn. + ****************************************************************************/ +void +w32_redraw_exposed_area (struct frame *f, int x, int y, int width, int height) +{ + /* If any window on the frame has had its face cache reset then the + redisplay structures are effectively invalid. If we attempt to + use them we'll blow up. We mark the frame as changed to ensure + that redisplay will do a full update. This probably isn't + necessary but it can't hurt. */ + + if (!f->window_face_cache_reset) + w32_redraw_exposed_windows (f->root_window, x, y, width, height); + else + MARK_FRAME_CHANGED (f); +} + + +/***************************************************************************** + w32_bevel_modeline + + Draw a 3d border around the modeline on window W. + ****************************************************************************/ +static void +w32_bevel_modeline (struct window *w, struct display_line *dl) +{ + struct frame *f = XFRAME (w->frame); + Lisp_Object color; + RECT rect = { WINDOW_MODELINE_LEFT (w), + dl->ypos - dl->ascent, + WINDOW_MODELINE_RIGHT (w), + dl->ypos + dl->descent}; + + + color = WINDOW_FACE_CACHEL_BACKGROUND (w, MODELINE_INDEX); + w32_update_gc(FRAME_W32_DC(f), Qnil, Qnil, color, Qnil, Qnil); + +#if 0 /* XXX Eh? */ + if (XINT (w->modeline_shadow_thickness) < 0) + { + GC temp; + + temp = top_shadow_gc; + top_shadow_gc = bottom_shadow_gc; + bottom_shadow_gc = temp; + } +#endif + + DrawEdge (FRAME_W32_DC(f), &rect, BDR_RAISEDINNER, BF_RECT); +} + + +/***************************************************************************** + #### Display methods +/***************************************************************************** + +/***************************************************************************** + w32_divider_width + + Return the width of the vertical divider. + ****************************************************************************/ +static int +w32_divider_width (void) +{ + return W32_DIVIDER_WIDTH; +} + +/***************************************************************************** + w32_divider_height + + Return the height of the horizontal divider. + ****************************************************************************/ +static int +w32_divider_height (void) +{ + return 1; /* XXX Copied from redisplay-X.c. What is this? */ +} + +/***************************************************************************** + w32_eol_cursor_width + + Return the width of the end-of-line cursor. + ****************************************************************************/ +static int +w32_eol_cursor_width (void) +{ + return W32_EOL_CURSOR_WIDTH; +} + +/***************************************************************************** + w32_output_begin + + Perform any necessary initialization prior to an update. + ****************************************************************************/ +static void +w32_output_begin (struct device *d) +{ +} + +/***************************************************************************** + w32_output_end + + Perform any necessary flushing of queues when an update has completed. + ****************************************************************************/ +static void +w32_output_end (struct device *d) +{ +} + +static int +w32_flash (struct device *d) +{ + struct frame *f = device_selected_frame (d); + + /* XXX FIXME: Do something more visible here, maybe involving a timer */ + FlashWindow (FRAME_W32_HANDLE (f), TRUE); + FlashWindow (FRAME_W32_HANDLE (f), FALSE); +} + +static void +w32_ring_bell (struct device *d, int volume, int pitch, int duration) +{ + /* XXX FIXME: I'm guessing pitch=Hz and duration is milliseconds */ + + if ((pitch|duration) == -1) /* Pitch and/or duration may be bogus */ + MessageBeep(-1); /* Default system sound via speaker */ + else + Beep(pitch, duration); +} + + +/***************************************************************************** + w32_output_display_block + + 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. + ****************************************************************************/ +static void +w32_output_display_block (struct window *w, struct display_line *dl, int block, + int start, int end, int start_pixpos, int cursor_start, + int cursor_width, int cursor_height) +{ + struct frame *f = XFRAME (w->frame); + Emchar_dynarr *buf = Dynarr_new (Emchar); + Lisp_Object window; + + struct display_block *db = Dynarr_atp (dl->display_blocks, block); + rune_dynarr *rba = db->runes; + struct rune *rb; + + int elt = start; + face_index findex; + int xpos, width; + Lisp_Object charset = Qunbound; /* Qnil is a valid charset when + MULE is not defined */ + XSETWINDOW (window, w); + rb = Dynarr_atp (rba, start); + + if (!rb) + { + /* Nothing to do so don't do anything. */ + return; + } + else + { + findex = rb->findex; + xpos = rb->xpos; + width = 0; + if (rb->type == RUNE_CHAR) + charset = CHAR_CHARSET (rb->object.chr.ch); + } + + if (end < 0) + end = Dynarr_length (rba); + Dynarr_reset (buf); + + while (elt < end) + { + rb = Dynarr_atp (rba, elt); + + if (rb->findex == findex && rb->type == RUNE_CHAR + && rb->object.chr.ch != '\n' && rb->cursor_type != CURSOR_ON + && EQ (charset, CHAR_CHARSET (rb->object.chr.ch))) + { + Dynarr_add (buf, rb->object.chr.ch); + width += rb->width; + elt++; + } + else + { + if (Dynarr_length (buf)) + { + w32_output_string (w, dl, buf, xpos, 0, start_pixpos, width, + findex); + xpos = rb->xpos; + width = 0; + } + Dynarr_reset (buf); + width = 0; + + if (rb->type == RUNE_CHAR) + { + findex = rb->findex; + xpos = rb->xpos; + charset = CHAR_CHARSET (rb->object.chr.ch); + + if (rb->cursor_type == CURSOR_ON) + { + if (rb->object.chr.ch == '\n') + { + w32_output_cursor (w, dl, xpos, cursor_width, rb); + } + else + { + Dynarr_add (buf, rb->object.chr.ch); +#if 0 + w32_output_string (w, dl, buf, xpos, 0, start_pixpos, + rb->width, findex, 1, + cursor_start, cursor_width, + cursor_height); +#else + w32_output_cursor (w, dl, xpos, cursor_width, rb); +#endif + Dynarr_reset (buf); + } + + xpos += rb->width; + elt++; + } + else if (rb->object.chr.ch == '\n') + { + /* Clear in case a cursor was formerly here. */ + int height = dl->ascent + dl->descent - dl->clip; + + w32_clear_region (window, findex, xpos, dl->ypos - dl->ascent, + rb->width, height); + elt++; + } + } + else if (rb->type == RUNE_BLANK || rb->type == RUNE_HLINE) + { + if (rb->type == RUNE_BLANK) + w32_output_blank (w, dl, rb); + else + { + /* #### Our flagging of when we need to redraw the + modeline shadows sucks. Since RUNE_HLINE is only used + by the modeline at the moment it is a good bet + that if it gets redrawn then we should also + redraw the shadows. This won't be true forever. + We borrow the shadow_thickness_changed flag for + now. */ + w->shadow_thickness_changed = 1; + w32_output_hline (w, dl, rb); + } + + if (rb->cursor_type == CURSOR_ON) + w32_output_cursor (w, dl, xpos, cursor_width, rb); + + elt++; + if (elt < end) + { + rb = Dynarr_atp (rba, elt); + + findex = rb->findex; + xpos = rb->xpos; + } + } + else if (rb->type == RUNE_DGLYPH) + { + Lisp_Object instance; + + XSETWINDOW (window, w); + instance = glyph_image_instance (rb->object.dglyph.glyph, + window, ERROR_ME_NOT, 1); + findex = rb->findex; + + if (IMAGE_INSTANCEP (instance)) + switch (XIMAGE_INSTANCE_TYPE (instance)) + { + case IMAGE_TEXT: + { + /* #### This is way losing. See the comment in + add_glyph_rune(). */ + Lisp_Object string = + XIMAGE_INSTANCE_TEXT_STRING (instance); + convert_bufbyte_string_into_emchar_dynarr + (XSTRING_DATA (string), XSTRING_LENGTH (string), buf); + + if (rb->cursor_type == CURSOR_ON) + w32_output_cursor (w, dl, xpos, cursor_width, rb); + else + w32_output_string (w, dl, buf, xpos, + rb->object.dglyph.xoffset, + start_pixpos, -1, findex); + Dynarr_reset (buf); + } + break; + + case IMAGE_MONO_PIXMAP: + case IMAGE_COLOR_PIXMAP: +#if 0 + w32_output_pixmap (w, dl, instance, xpos, + rb->object.dglyph.xoffset, start_pixpos, + rb->width, findex, cursor_start, + cursor_width, cursor_height); +#endif + break; + + case IMAGE_POINTER: + abort (); + + case IMAGE_SUBWINDOW: + /* #### implement me */ + break; + + case IMAGE_NOTHING: + /* nothing is as nothing does */ + break; + + default: + abort (); + } + + xpos += rb->width; + elt++; + } + else + abort (); + } + } + + if (Dynarr_length (buf)) + w32_output_string (w, dl, buf, xpos, 0, start_pixpos, width, findex); + + if (dl->modeline + && !EQ (Qzero, w->modeline_shadow_thickness) +#if 1 /* Writing to the modeline overwrites the bevels */ + ) +#else + && (f->clear + || f->windows_structure_changed + || w->shadow_thickness_changed)) +#endif + w32_bevel_modeline (w, dl); + + Dynarr_free (buf); + +} + + +/***************************************************************************** + w32_output_vertical_divider + + Draw a vertical divider down the left side of the given window. + ****************************************************************************/ +static void +w32_output_vertical_divider (struct window *w, int clear) +{ + struct frame *f = XFRAME (w->frame); + Lisp_Object color; + RECT rect; + HBRUSH brush; + + /* We don't use the normal gutter measurements here because the + horizontal scrollbars and toolbars do not stretch completely over + to the right edge of the window. Only the modeline does. */ + int modeline_height = window_modeline_height (w); + + assert(!W32_DIVIDER_SPACING); /* This code doesn't handle this */ + + /* XXX Not sure about this */ +#ifdef HAVE_SCROLLBARS + if (f->scrollbar_on_left) + rect.left = WINDOW_LEFT (w); + else + rect.left = WINDOW_RIGHT (w) - W32_DIVIDER_WIDTH; +#else + rect.left = WINDOW_LEFT (w); +#endif + rect.right = rect.left + W32_DIVIDER_WIDTH; + +#ifdef HAVE_SCROLLBARS + if (f->scrollbar_on_top) + rect.top = WINDOW_TOP (w); + else +#endif + rect.top = WINDOW_TEXT_TOP (w); + rect.bottom = WINDOW_BOTTOM (w) - modeline_height; + + /* Draw the divider line */ + color = WINDOW_FACE_CACHEL_BACKGROUND (w, MODELINE_INDEX); + w32_update_gc(FRAME_W32_DC(f), Qnil, Qnil, color, Qnil, Qnil); + brush = COLOR_INSTANCE_W32_BRUSH (XCOLOR_INSTANCE (color)); + FillRect (FRAME_W32_DC(f), &rect, brush); + DrawEdge (FRAME_W32_DC(f), &rect, BDR_RAISEDINNER, BF_RECT); +} + + +/**************************************************************************** + w32_text_width + + Given a string and a face, return the string's length in pixels when + displayed in the font associated with the face. + XXX FIXME: get redisplay_text_width_emchar_string() etc to pass in the + window so we can get hold of the window's frame's gc + ****************************************************************************/ +static int +w32_text_width (struct face_cachel *cachel, CONST Emchar *str, + Charcount len) +{ + int width_so_far = 0; + unsigned char *text_storage = (unsigned char *) alloca (2 * len); + textual_run *runs = alloca_array (textual_run, len); + int nruns; + int i; + HDC hdc=NULL; /* XXXXX FIXME! only works for non-proportional fonts! */ + + nruns = separate_textual_runs (text_storage, runs, str, len); + + for (i = 0; i < nruns; i++) + width_so_far += w32_text_width_single_run (hdc, cachel, runs + i); + + return width_so_far; +} + + +/**************************************************************************** + w32_clear_region + + Clear the area in the box defined by the given parameters using the + given face. + ****************************************************************************/ +static void +w32_clear_region (Lisp_Object locale, face_index findex, int x, int y, + int width, int height) +{ + struct window *w; + struct frame *f; + Lisp_Object background_pixmap = Qunbound; + Lisp_Object temp; + RECT rect = { x, y, x+width, y+height }; + HBRUSH brush; + + if (!(width && height)) /* We often seem to get called with width==0 */ + return; + + if (WINDOWP (locale)) + { + w = XWINDOW (locale); + f = XFRAME (w->frame); + } + else if (FRAMEP (locale)) + { + w = NULL; + f = XFRAME (locale); + } + else + abort (); + + if (w) + { + temp = WINDOW_FACE_CACHEL_BACKGROUND_PIXMAP (w, findex); + + if (IMAGE_INSTANCEP (temp) + && IMAGE_INSTANCE_PIXMAP_TYPE_P (XIMAGE_INSTANCE (temp))) + { + /* #### maybe we could implement such that a string + can be a background pixmap? */ + background_pixmap = temp; + } + } + else + { + temp = FACE_BACKGROUND_PIXMAP (Vdefault_face, locale); + + if (IMAGE_INSTANCEP (temp) + && IMAGE_INSTANCE_PIXMAP_TYPE_P (XIMAGE_INSTANCE (temp))) + { + background_pixmap = temp; + } + } + + if (!UNBOUNDP (background_pixmap)) + { + if (XIMAGE_INSTANCE_PIXMAP_DEPTH (background_pixmap) == 0) + { + Lisp_Object fcolor, bcolor; + + if (w) + { + fcolor = WINDOW_FACE_CACHEL_FOREGROUND (w, findex); + bcolor = WINDOW_FACE_CACHEL_BACKGROUND (w, findex); + } + else + { + fcolor = FACE_FOREGROUND (Vdefault_face, locale); + bcolor = FACE_BACKGROUND (Vdefault_face, locale); + } + + w32_update_gc (FRAME_W32_DC(f), Qnil, fcolor, bcolor, background_pixmap, Qnil); + } + + /* XX FIXME: Get brush from background_pixmap here */ + assert(0); + } + else + { + Lisp_Object color = (w ? WINDOW_FACE_CACHEL_BACKGROUND (w, findex) : + FACE_BACKGROUND (Vdefault_face, locale)); + brush = COLOR_INSTANCE_W32_BRUSH (XCOLOR_INSTANCE (color)); + } + + FillRect (FRAME_W32_DC(f), &rect, brush); +} + + +/***************************************************************************** + w32_clear_to_window_end + + Clear the area between ypos1 and ypos2. Each margin area and the + text area is handled separately since they may each have their own + background color. + ****************************************************************************/ +static void +w32_clear_to_window_end (struct window *w, int ypos1, int ypos2) +{ + int height = ypos2 - ypos1; + + if (height) + { + struct frame *f = XFRAME (w->frame); + Lisp_Object window; + int bflag = (window_needs_vertical_divider (w) ? 0 : 1); + layout_bounds bounds; + + bounds = calculate_display_line_boundaries (w, bflag); + XSETWINDOW (window, w); + + if (window_is_leftmost (w)) + w32_clear_region (window, DEFAULT_INDEX, FRAME_LEFT_BORDER_START (f), + ypos1, FRAME_BORDER_WIDTH (f), height); + + if (bounds.left_in - bounds.left_out > 0) + w32_clear_region (window, + get_builtin_face_cache_index (w, Vleft_margin_face), + bounds.left_out, ypos1, + bounds.left_in - bounds.left_out, height); + + if (bounds.right_in - bounds.left_in > 0) + w32_clear_region (window, DEFAULT_INDEX, bounds.left_in, ypos1, + bounds.right_in - bounds.left_in, height); + + if (bounds.right_out - bounds.right_in > 0) + w32_clear_region (window, + get_builtin_face_cache_index (w, Vright_margin_face), + bounds.right_in, ypos1, + bounds.right_out - bounds.right_in, height); + + if (window_is_rightmost (w)) + w32_clear_region (window, DEFAULT_INDEX, FRAME_RIGHT_BORDER_START (f), + ypos1, FRAME_BORDER_WIDTH (f), height); + } + +} + + +static void +w32_clear_frame (struct frame *f) +{ +} + + + + +/************************************************************************/ +/* initialization */ +/************************************************************************/ + +void +console_type_create_redisplay_w32 (void) +{ + /* redisplay methods */ + CONSOLE_HAS_METHOD (w32, text_width); + CONSOLE_HAS_METHOD (w32, output_display_block); + CONSOLE_HAS_METHOD (w32, divider_width); + CONSOLE_HAS_METHOD (w32, divider_height); + CONSOLE_HAS_METHOD (w32, eol_cursor_width); + CONSOLE_HAS_METHOD (w32, output_vertical_divider); + CONSOLE_HAS_METHOD (w32, clear_to_window_end); + CONSOLE_HAS_METHOD (w32, clear_region); + CONSOLE_HAS_METHOD (w32, clear_frame); + CONSOLE_HAS_METHOD (w32, output_begin); + CONSOLE_HAS_METHOD (w32, output_end); + CONSOLE_HAS_METHOD (w32, flash); + CONSOLE_HAS_METHOD (w32, ring_bell); +}
--- a/src/redisplay-x.c Mon Aug 13 10:03:54 2007 +0200 +++ b/src/redisplay-x.c Mon Aug 13 10:04:58 2007 +0200 @@ -1415,8 +1415,8 @@ #ifdef HAVE_SCROLLBARS else x1 = WINDOW_RIGHT (w) - X_DIVIDER_WIDTH; +#endif x2 = x1 + X_DIVIDER_SPACING; -#endif #ifdef HAVE_SCROLLBARS if (f->scrollbar_on_top)
--- a/src/redisplay.c Mon Aug 13 10:03:54 2007 +0200 +++ b/src/redisplay.c Mon Aug 13 10:04:58 2007 +0200 @@ -5845,11 +5845,11 @@ /* indicate TEXT or BINARY */ case 't': -#ifdef MSDOS +#ifdef DOS_NT str = NILP (b->buffer_file_type) ? "T" : "B"; -#else /* not MSDOS */ +#else /* not DOS_NT */ str = "T"; -#endif /* not MSDOS */ +#endif /* not DOS_NT */ break; /* print percent of buffer above top of window, or Top, Bot or All */ @@ -8114,6 +8114,16 @@ } #endif /* HAVE_X_WINDOWS */ +#ifdef HAVE_W32GUI + if (!strcmp (display_use, "w32")) + { + /* Some stuff checks this way early. */ + Vwindow_system = Qw32; + Vinitial_window_system = Qw32; + return; + } +#endif /* HAVE_W32GUI */ + /* If no window system has been specified, try to use the terminal. */ if (!isatty (0)) {
--- a/src/regex.c Mon Aug 13 10:03:54 2007 +0200 +++ b/src/regex.c Mon Aug 13 10:04:58 2007 +0200 @@ -4063,7 +4063,7 @@ #ifdef MULE while (range > lim && *d < 0x80 && !fastmap[translate[*d]]) #else - while (range > lim && !fastmap[translate[*d]]) + while (range > lim && !fastmap[(unsigned char)translate[*d]]) #endif { d_size = charcount_to_bytecount (d, 1);
--- a/src/regex.h Mon Aug 13 10:03:54 2007 +0200 +++ b/src/regex.h Mon Aug 13 10:04:58 2007 +0200 @@ -26,12 +26,6 @@ /* POSIX says that <sys/types.h> must be included (by the caller) before <regex.h>. */ -#if !defined (_POSIX_C_SOURCE) && !defined (_POSIX_SOURCE) && defined (VMS) -/* VMS doesn't have `size_t' in <sys/types.h>, even though POSIX says it - should be there. */ -#include <stddef.h> -#endif - /* The following bits are used to determine the regexp syntax we recognize. The not-set meaning typically corresponds to the syntax
--- a/src/s/aix3-1.h Mon Aug 13 10:03:54 2007 +0200 +++ b/src/s/aix3-1.h Mon Aug 13 10:04:58 2007 +0200 @@ -95,7 +95,6 @@ is named avenrun. */ #define LDAV_SYMBOL "avenrun" - /* Special itemss needed to make Emacs run on this system. */ /* On USG systems the system calls are interruptible by signals
--- a/src/s/cxux.h Mon Aug 13 10:03:54 2007 +0200 +++ b/src/s/cxux.h Mon Aug 13 10:04:58 2007 +0200 @@ -34,7 +34,6 @@ /* #define BSD4_2 */ /* #define BSD4_3 */ /* #define BSD */ -/* #define VMS */ #ifndef _CX_UX #define _CX_UX 1
--- a/src/s/freebsd.h Mon Aug 13 10:03:54 2007 +0200 +++ b/src/s/freebsd.h Mon Aug 13 10:04:58 2007 +0200 @@ -100,3 +100,10 @@ /* Needed to avoid hanging when child process writes an error message and exits -- enami tsugutomo <enami@ba2.so-net.or.jp>. */ #define vfork fork + +/* To avoid a failure of configure's check for timezone ... + FreeBSD actualy has `extern long timezone'. */ +#ifndef HAVE_TIMEZONE_DECL +#define HAVE_TIMEZONE_DECL 1 +#endif +
--- a/src/s/msdos.h Mon Aug 13 10:03:54 2007 +0200 +++ b/src/s/msdos.h Mon Aug 13 10:04:58 2007 +0200 @@ -38,7 +38,6 @@ /* #define BSD4_2 */ /* #define BSD4_3 */ /* #define BSD */ -/* #define VMS */ #ifndef MSDOS #define MSDOS #endif @@ -53,7 +52,6 @@ #define DOS_NT /* MSDOS or WINDOWSNT */ #undef BSD -#undef VMS /* SYSTEM_TYPE should indicate the kind of system you are using. It sets the Lisp variable system-type. */
--- a/src/s/template.h Mon Aug 13 10:03:54 2007 +0200 +++ b/src/s/template.h Mon Aug 13 10:04:58 2007 +0200 @@ -36,7 +36,6 @@ /* #define BSD4_2 */ /* #define BSD4_3 */ /* #define BSD */ -/* #define VMS */ /* SYSTEM_TYPE should indicate the kind of system you are using. It sets the Lisp variable system-type. */
--- a/src/s/umax.h Mon Aug 13 10:03:54 2007 +0200 +++ b/src/s/umax.h Mon Aug 13 10:04:58 2007 +0200 @@ -34,7 +34,6 @@ #define BSD #define UMAX4_2 #define UMAX -/* #define VMS */ /* SYSTEM_TYPE should indicate the kind of system you are using. It sets the Lisp variable system-type. */
--- a/src/s/xenix.h Mon Aug 13 10:03:54 2007 +0200 +++ b/src/s/xenix.h Mon Aug 13 10:04:58 2007 +0200 @@ -35,7 +35,6 @@ /* #define BSD4_2 */ /* #define BSD4_3 */ /* #define BSD */ -/* #define VMS */ /* SYSTEM_TYPE should indicate the kind of system you are using. It sets the Lisp variable system-type. */
--- a/src/signal.c Mon Aug 13 10:03:54 2007 +0200 +++ b/src/signal.c Mon Aug 13 10:04:58 2007 +0200 @@ -406,19 +406,11 @@ */ sys_suspend (); #else -#ifdef VMS - if (sys_suspend () == -1) - { - stdout_out ("Not running as a subprocess;\n"); - stdout_out ("you can continue or abort.\n"); - } -#else /* not VMS */ /* Perhaps should really fork an inferior shell? But that would not provide any way to get back to the original shell, ever. */ stdout_out ("No support for stopping a process on this operating system;\n"); stdout_out ("you can continue or abort.\n"); -#endif /* not VMS */ #endif /* not SIGTSTP */ stdout_out ("Auto-save? (y or n) "); fflush (stdout); @@ -426,11 +418,7 @@ Fdo_auto_save (Qnil, Qnil); while (c != '\n') c = getc (stdin); -#ifdef VMS - stdout_out ("Abort (and enter debugger)? (y or n) "); -#else /* not VMS */ stdout_out ("Abort (and dump core)? (y or n) "); -#endif /* not VMS */ fflush (stdout); if (((c = getc (stdin)) & ~040) == 'Y') abort ();
--- a/src/symsinit.h Mon Aug 13 10:03:54 2007 +0200 +++ b/src/symsinit.h Mon Aug 13 10:04:58 2007 +0200 @@ -55,11 +55,13 @@ void syms_of_cmdloop (void); void syms_of_cmds (void); void syms_of_console_tty (void); +void syms_of_console_w32 (void); void syms_of_console (void); void syms_of_data (void); void syms_of_dbm (void); void syms_of_debug (void); void syms_of_device_tty (void); +void syms_of_device_w32 (void); void syms_of_device_x (void); void syms_of_device (void); void syms_of_dialog_x (void); @@ -72,6 +74,7 @@ void syms_of_energize (void); void syms_of_eval (void); void syms_of_event_stream (void); +void syms_of_event_w32 (void); void syms_of_event_Xt (void); void syms_of_events (void); void syms_of_extents (void); @@ -81,8 +84,9 @@ void syms_of_floatfns (void); void syms_of_fns (void); void syms_of_font_lock (void); +void syms_of_frame (void); +void syms_of_frame_w32 (void); void syms_of_frame_x (void); -void syms_of_frame (void); void syms_of_free_hook (void); void syms_of_general (void); void syms_of_glyphs_x (void); @@ -107,6 +111,7 @@ void syms_of_mule_wnn (void); void syms_of_objects_tty (void); void syms_of_objects_x (void); +void syms_of_objects_w32 (void); void syms_of_objects (void); void syms_of_print (void); void syms_of_process (void); @@ -190,13 +195,14 @@ void vars_of_cmds (void); void vars_of_console (void); void vars_of_console_stream (void); +void vars_of_console_w32 (void); void vars_of_console_tty (void); void vars_of_data (void); void vars_of_dbm (void); void vars_of_debug (void); +void vars_of_device (void); +void vars_of_device_w32 (void); void vars_of_device_x (void); -void vars_of_device (void); -void vars_of_dialog_x (void); void vars_of_dialog (void); void vars_of_dired (void); void vars_of_doc (void); @@ -207,6 +213,7 @@ void vars_of_eval (void); void vars_of_event_stream (void); void vars_of_event_tty (void); +void vars_of_event_w32 (void); void vars_of_event_Xt (void); void vars_of_events (void); void vars_of_extents (void); @@ -216,6 +223,7 @@ void vars_of_floatfns (void); void vars_of_font_lock (void); void vars_of_frame_tty (void); +void vars_of_frame_w32 (void); void vars_of_frame_x (void); void vars_of_frame (void); void vars_of_glyphs_x (void); @@ -242,6 +250,7 @@ void vars_of_mule_wnn (void); void vars_of_objects (void); void vars_of_objects_tty (void); +void vars_of_objects_w32 (void); void vars_of_objects_x (void); void vars_of_print (void); void vars_of_process (void); @@ -316,6 +325,7 @@ void init_event_Xt_late (void); void init_event_stream (void); void init_event_tty_late (void); +void init_event_w32_late (void); void init_event_unixoid (void); void init_gif_err (void); void init_lread (void);
--- a/src/sysdep.c Mon Aug 13 10:03:54 2007 +0200 +++ b/src/sysdep.c Mon Aug 13 10:04:58 2007 +0200 @@ -77,24 +77,6 @@ int _CRTAPI1 _getpid (void); #endif -/* ------------------------------- */ -/* VMS includes */ -/* ------------------------------- */ - -#ifdef VMS -#include <ttdef.h> -#include <tt2def.h> -#include <iodef.h> -#include <ssdef.h> -#include <descrip.h> -#include <fibdef.h> -#include <atrdef.h> -#undef F_SETFL -#ifndef RAB/*$C_BID -- suppress compiler warnings */ -#include <rab.h> -#endif -#define MAXIOSIZE (32 * PAGESIZE) /* Don't I/O more than 32 blocks at a time */ -#endif /* VMS */ /* ------------------------------- */ /* TTY definitions */ @@ -254,10 +236,6 @@ if (wait (0) == pid) return; } -#elif defined (VMS) - int status = SYS$FORCEX (&pid, 0, 0); - return; - #elif defined (HAVE_WAITPID) /* Note that, whenever any subprocess terminates (asynch. or synch.), the SIGCHLD handler will be called and it will call wait(). Thus @@ -421,7 +399,6 @@ #endif } -#ifndef VMS #ifndef MSDOS #ifndef WINDOWSNT /* Set up the terminal at the other end of a pseudo-terminal that @@ -533,12 +510,11 @@ } #endif /* WINDOWSNT */ #endif /* not MSDOS */ -#endif /* not VMS */ #endif /* not NO_SUBPROCESSES */ -#if !defined (VMS) && !defined (SIGTSTP) && !defined (USG_JOBCTRL) +#if !defined (SIGTSTP) && !defined (USG_JOBCTRL) /* Record a signal code and the handler for it. */ struct save_signal @@ -686,7 +662,7 @@ restore_signal_handlers (saved_handlers); } -#endif /* !defined (VMS) && !defined (SIGTSTP) && !defined (USG_JOBCTRL) */ +#endif /* !defined (SIGTSTP) && !defined (USG_JOBCTRL) */ @@ -694,47 +670,7 @@ void sys_suspend (void) { -#ifdef VMS - /* "Foster" parentage allows emacs to return to a subprocess that attached - to the current emacs as a cheaper than starting a whole new process. This - is set up by KEPTEDITOR.COM. */ - unsigned long parent_id, foster_parent_id; - char *fpid_string; - - fpid_string = getenv ("EMACS_PARENT_PID"); - if (fpid_string != NULL) - { - sscanf (fpid_string, "%x", &foster_parent_id); - if (foster_parent_id != 0) - parent_id = foster_parent_id; - else - parent_id = getppid (); - } - else - parent_id = getppid (); - - xfree (fpid_string); /* On VMS, this was malloc'd */ - - if (parent_id && parent_id != 0xffffffff) - { - SIGTYPE (*oldsig)() = (int) signal (SIGINT, SIG_IGN); - int status = LIB$ATTACH (&parent_id) & 1; - signal (SIGINT, oldsig); - return status; - } - else - { - struct { - int l; - char *a; - } d_prompt; - d_prompt.l = sizeof ("Emacs: "); /* Our special prompt */ - d_prompt.a = "Emacs: "; /* Just a reminder */ - LIB$SPAWN (0, 0, 0, 0, 0, 0, 0, 0, 0, 0, &d_prompt, 0); - return 1; - } - return -1; -#elif defined (SIGTSTP) && !defined (MSDOS) +#if defined (SIGTSTP) && !defined (MSDOS) { int pgrp = EMACS_GET_PROCESS_GROUP (); EMACS_KILLPG (pgrp, SIGTSTP); @@ -888,14 +824,8 @@ assert (DEVICE_TTY_P (d)); { int input_fd = CONSOLE_TTY_DATA (con)->infd; -#ifdef MSDOS +#if defined (MSDOS) || defined(WIN32) DEVICE_TTY_DATA (d)->ospeed = 15; -#elif defined (VMS) - struct vms_sensemode sg; - - SYS$QIOW (0, input_fd, IO$_SENSEMODE, &sg, 0, 0, - &sg.class, 12, 0, 0, 0, 0 ); - DEVICE_TTY_DATA (d)->ospeed = sg.xmit_baud; #elif defined (HAVE_TERMIOS) struct termios sg; @@ -917,7 +847,7 @@ ioctl (input_fd, TCGETA, &sg); # endif DEVICE_TTY_DATA (d)->ospeed = sg.c_cflag & CBAUD; -#else /* neither VMS nor TERMIOS nor TERMIO */ +#else /* neither TERMIOS nor TERMIO */ struct sgttyb sg; sg.sg_ospeed = B9600; @@ -1349,28 +1279,15 @@ if (tcgetattr (fd, &settings->main) < 0) return -1; -#else -#ifdef HAVE_TERMIO +#elif defined HAVE_TERMIO /* The SYSV-style interface? */ if (ioctl (fd, TCGETA, &settings->main) < 0) return -1; -#else -#ifdef VMS - /* Vehemently Monstrous System? :-) */ - if (! (SYS$QIOW (0, fd, IO$_SENSEMODE, settings, 0, 0, - &settings->main.class, 12, 0, 0, 0, 0) - & 1)) - return -1; - -#else -#ifndef MSDOS +#elif !defined MSDOS && !defined(WIN32) /* I give up - I hope you have the BSD ioctls. */ if (ioctl (fd, TIOCGETP, &settings->main) < 0) return -1; -#endif /* not MSDOS */ -#endif /* not VMS */ -#endif /* HAVE_TERMIO */ #endif /* HAVE_TCATTR */ /* Suivant - Do we have to get struct ltchars data? */ @@ -1435,28 +1352,15 @@ else continue; } -#else -#ifdef HAVE_TERMIO +#elif defined HAVE_TERMIO /* The SYSV-style interface? */ if (ioctl (fd, flushp ? TCSETAF : TCSETAW, &settings->main) < 0) return -1; -#else -#ifdef VMS - /* Vehemently Monstrous System? :-) */ - if (! (SYS$QIOW (0, fd, IO$_SETMODE, &input_iosb, 0, 0, - &settings->main.class, 12, 0, 0, 0, 0) - & 1)) - return -1; - -#else -#ifndef MSDOS +#elif !defined(MSDOS) && !defined(WIN32) /* I give up - I hope you have the BSD ioctls. */ if (ioctl (fd, (flushp) ? TIOCSETP : TIOCSETN, &settings->main) < 0) return -1; -#endif /* not MSDOS */ -#endif /* VMS */ -#endif /* HAVE_TERMIO */ #endif /* HAVE_TCATTR */ /* Suivant - Do we have to get struct ltchars data? */ @@ -1636,14 +1540,14 @@ tty.main.c_iflag &= ~BRKINT; #endif /* AIX */ #else /* if not HAVE_TERMIO */ -#ifndef MSDOS +#if !defined(MSDOS) && !defined(WIN32) con->tty_erase_char = make_char (tty.main.sg_erase); tty.main.sg_flags &= ~(ECHO | CRMOD | XTABS); if (TTY_FLAGS (con).meta_key) tty.main.sg_flags |= ANYP; /* #### should we be using RAW mode here? */ tty.main.sg_flags |= /* interrupt_input ? RAW : */ CBREAK; -#endif /* not MSDOS */ +#endif /* not MSDOS or WIN32 */ #endif /* not HAVE_TERMIO */ /* If going to use CBREAK mode, we must request C-g to interrupt @@ -1720,14 +1624,6 @@ #endif #endif -#ifdef VMS - /* Appears to do nothing when in PASTHRU mode. - SYS$QIOW (0, input_fd, IO$_SETMODE|IO$M_OUTBAND, 0, 0, 0, - interrupt_signal, oob_chars, 0, 0, 0, 0); - */ - queue_kbd_input (0); -#endif /* VMS */ - #if 0 /* We do our own buffering with lstreams. */ #ifdef _IOFBF /* This symbol is defined on recent USG systems. @@ -1834,8 +1730,7 @@ *heightp = size.ws_row; } } -#else -#ifdef TIOCGSIZE +#elif defined TIOCGSIZE { /* SunOS - style. */ struct ttysize size; @@ -1848,19 +1743,7 @@ *heightp = size.ts_lines; } } -#else -#ifdef VMS - { - struct vms_sensemode tty; - - SYS$QIOW (0, input_fd, IO$_SENSEMODE, &tty, 0, 0, - &tty.class, 12, 0, 0, 0, 0); - *widthp = tty.scr_wid; - *heightp = tty.scr_len; - } -#else -#ifdef MSDOS - +#elif defined MSDOS *widthp = FrameCols (); *heightp = FrameRows (); @@ -1869,10 +1752,7 @@ *widthp = 0; *heightp = 0; -#endif /* not MSDOS */ -#endif /* not VMS */ -#endif /* not SunOS-style */ -#endif /* not BSD-style */ +#endif /* not !TIOCGWINSZ */ } #endif /* HAVE_TTY */ @@ -1963,9 +1843,6 @@ hft_reset (con); #endif -#ifdef VMS - stop_vms_input (con); -#endif } #endif /* HAVE_TTY */ @@ -2141,219 +2018,6 @@ #endif /* AIXHFT */ -/* ------------------------------------------------------ */ -/* TTY stuff under VMS */ -/* ------------------------------------------------------ */ - -/***** #### this is all broken ****/ - -#ifdef VMS - -/* Assigning an input channel is done at the start of Emacs execution. - This is called each time Emacs is resumed, also, but does nothing - because input_chain is no longer zero. */ - -void -init_vms_input (void) -{ - /* #### broken. */ - int status; - - if (input_fd == 0) - { - status = SYS$ASSIGN (&vms_input_dsc, &input_fd, 0, 0); - if (! (status & 1)) - LIB$STOP (status); - } -} - -/* Deassigning the input channel is done before exiting. */ - -static void -stop_vms_input (struct console *con) -{ - int input_fd = CONSOLE_TTY_DATA (con)->infd; - return SYS$DASSGN (input_fd); -} - -static short vms_input_buffer; - -/* Request reading one character into the keyboard buffer. - This is done as soon as the buffer becomes empty. */ - -static void -queue_vms_kbd_input (struct console *con) -{ - int input_fd = CONSOLE_TTY_DATA (con)->infd; - int status; - vms_waiting_for_ast = 0; - vms_stop_input = 0; - status = SYS$QIO (0, input_fd, IO$_READVBLK, - &vms_input_iosb, vms_kbd_input_ast, 1, - &vms_input_buffer, 1, 0, vms_terminator_mask, 0, 0); -} - -static int vms_input_count; - -/* Ast routine that is called when keyboard input comes in - in accord with the SYS$QIO above. */ - -static void -vms_kbd_input_ast (struct console *con) -{ - int c = -1; - int old_errno = errno; - extern EMACS_TIME *input_available_clear_time; - - if (vms_waiting_for_ast) - SYS$SETEF (vms_input_ef); - vms_waiting_for_ast = 0; - vms_input_count++; -#ifdef ASTDEBUG - if (vms_input_count == 25) - exit (1); - printf ("Ast # %d,", vms_input_count); - printf (" iosb = %x, %x, %x, %x", - vms_input_iosb.offset, vms_input_iosb.status, - vms_input_iosb.termlen, vms_input_iosb.term); -#endif - if (vms_input_iosb.offset) - { - c = vms_input_buffer; -#ifdef ASTDEBUG - printf (", char = 0%o", c); -#endif - } -#ifdef ASTDEBUG - printf ("\n"); - fflush (stdout); - emacs_sleep (1); -#endif - if (! vms_stop_input) - queue_vms_kbd_input (con); - if (c >= 0) - kbd_buffer_store_char (c); - - if (input_available_clear_time) - EMACS_SET_SECS_USECS (*input_available_clear_time, 0, 0); - errno = old_errno; -} - -#if 0 /* Unused */ -/* Wait until there is something in kbd_buffer. */ - -void -vms_wait_for_kbd_input (void) -{ - /* This function can GC */ - extern int have_process_input, process_exited; - - /* If already something, avoid doing system calls. */ - if (detect_input_pending (0)) - { - return; - } - /* Clear a flag, and tell ast routine above to set it. */ - SYS$CLREF (vms_input_ef); - vms_waiting_for_ast = 1; - /* Check for timing error: ast happened while we were doing that. */ - if (!detect_input_pending (0)) - { - /* No timing error: wait for flag to be set. */ - set_waiting_for_input (0); - SYS$WFLOR (vms_input_ef, vms_input_eflist); - clear_waiting_for_input (0); - if (!detect_input_pending (0)) - /* Check for subprocess input availability */ - { - int dsp = have_process_input || process_exited; - - SYS$CLREF (vms_process_ef); - if (have_process_input) - process_command_input (); - if (process_exited) - process_exit (); - if (dsp) - { - MARK_MODELINE_CHANGED; - redisplay (); - } - } - } - vms_waiting_for_ast = 0; -} -#endif - -/* Get rid of any pending QIO, when we are about to suspend - or when we want to throw away pending input. - We wait for a positive sign that the AST routine has run - and therefore there is no I/O request queued when we return. - SYS$SETAST is used to avoid a timing error. */ - -static void -vms_end_kbd_input (struct console *con) -{ - int input_fd; - - assert (CONSOLE_TTY_P (con)); - input_fd = CONSOLE_TTY_DATA (con)->infd; -#ifdef ASTDEBUG - printf ("At end_kbd_input.\n"); - fflush (stdout); - emacs_sleep (1); -#endif - if (LIB$AST_IN_PROG ()) /* Don't wait if suspending from kbd_buffer_store_char! */ - { - SYS$CANCEL (input_fd); - return; - } - - SYS$SETAST (0); - /* Clear a flag, and tell ast routine above to set it. */ - SYS$CLREF (vms_input_ef); - vms_waiting_for_ast = 1; - vms_stop_input = 1; - SYS$CANCEL (input_fd); - SYS$SETAST (1); - SYS$WAITFR (vms_input_ef); - vms_waiting_for_ast = 0; -} - -#if 0 /* Unused */ -/* Wait for either input available or time interval expiry. */ - -void -vms_input_wait_timeout (int timeval) /* Time to wait, in seconds */ -{ - int time [2]; - static int zero = 0; - static int large = -10000000; - - LIB$EMUL (&timeval, &large, &zero, time); /* Convert to VMS format */ - - /* If already something, avoid doing system calls. */ - if (detect_input_pending (0)) - { - return; - } - /* Clear a flag, and tell ast routine above to set it. */ - SYS$CLREF (vms_input_ef); - vms_waiting_for_ast = 1; - /* Check for timing error: ast happened while we were doing that. */ - if (!detect_input_pending (0)) - { - /* No timing error: wait for flag to be set. */ - SYS$CANTIM (1, 0); - if (SYS$SETIMR (vms_timer_ef, time, 0, 1) & 1) /* Set timer */ - SYS$WFLOR (vms_timer_ef, vms_timer_eflist); /* Wait for timer expiry or input */ - } - vms_waiting_for_ast = 0; -} -#endif /* 0 */ - -#endif /* VMS */ - - /************************************************************************/ /* limits of text/data segments */ /************************************************************************/ @@ -2499,23 +2163,15 @@ extern Lisp_Object Vsystem_name; -#if defined (HAVE_SOCKETS) && !defined (VMS) +#ifdef HAVE_SOCKETS # include <sys/socket.h> # include <netdb.h> -#endif /* HAVE_SOCKETS and not VMS */ +#endif /* HAVE_SOCKETS */ void init_system_name (void) { -#if defined (VMS) - char *sp, *end; - if ((sp = egetenv ("SYS$NODE")) == 0) - Vsystem_name = build_string ("vax-vms"); - else if ((end = strchr (sp, ':')) == 0) - Vsystem_name = build_string (sp); - else - Vsystem_name = make_string ((Bufbyte *) sp, end - sp); -#elif !defined (HAVE_GETHOSTNAME) +#ifndef HAVE_GETHOSTNAME struct utsname uts; uname (&uts); Vsystem_name = build_string (uts.nodename); @@ -2584,7 +2240,7 @@ } # endif /* HAVE_SOCKETS */ Vsystem_name = build_string (hostname); -#endif /* HAVE_GETHOSTNAME and not VMS */ +#endif /* HAVE_GETHOSTNAME */ { Bufbyte *p; Bytecount i; @@ -2604,13 +2260,11 @@ /* Emulation of select() */ /************************************************************************/ -#ifndef VMS #ifndef HAVE_SELECT ERROR: XEmacs requires a working select(). #endif /* not HAVE_SELECT */ -#endif /* not VMS */ /************************************************************************/ @@ -2708,57 +2362,6 @@ #ifndef HAVE_STRERROR -#if defined (VMS) && defined (LINK_CRTL_SHARE) && defined (SHAREABLE_LIB_BUG) - -/* Variables declared noshare and initialized in sharable libraries - cannot be shared. The VMS linker incorrectly forces you to use a private - version which is uninitialized... If not for this "feature", we - could use the C library definition of sys_nerr and sys_errlist. */ -CONST char *sys_errlist[] = - { - "error 0", - "not owner", - "no such file or directory", - "no such process", - "interrupted system call", - "I/O error", - "no such device or address", - "argument list too long", - "exec format error", - "bad file number", - "no child process", - "no more processes", - "not enough memory", - "permission denied", - "bad address", - "block device required", - "mount devices busy", - "file exists", - "cross-device link", - "no such device", - "not a directory", - "is a directory", - "invalid argument", - "file table overflow", - "too many open files", - "not a typewriter", - "text file busy", - "file too big", - "no space left on device", - "illegal seek", - "read-only file system", - "too many links", - "broken pipe", - "math argument", - "result too large", - "I/O stream empty", - "vax/vms specific error code nontranslatable error" - }; -int sys_nerr = countof (sys_errlist); - -#endif /* VMS & LINK_CRTL_SHARE & SHAREABLE_LIB_BUG */ - - #if !defined(NeXT) && !defined(__alpha) && !defined(MACH) && !defined(LINUX) && !defined(IRIX) && !defined(__NetBSD__) /* Linux added here by Raymond L. Toy <toy@alydar.crd.ge.com> for XEmacs. */ /* Irix added here by gparker@sni-usa.com for XEmacs. */ @@ -2792,7 +2395,6 @@ #define PATHNAME_CONVERT_OUT(path) \ GET_C_CHARPTR_EXT_FILENAME_DATA_ALLOCA (path, path) -/***** VMS versions are at the bottom of this file *****/ /***** MSDOS versions are in msdos.c *****/ /***************** low-level calls ****************/ @@ -2869,9 +2471,6 @@ int sys_read_1 (int fildes, void *buf, unsigned int nbyte, int allow_quit) { -#ifdef VMS - return vms_read (fildes, buf, nbyte); -#else int rtnval; /* No harm in looping regardless of the INTERRUPTIBLE_IO setting. */ @@ -2882,7 +2481,6 @@ REALLY_QUIT; } return rtnval; -#endif } #ifdef ENCAPSULATE_READ @@ -2896,9 +2494,6 @@ int sys_write_1 (int fildes, CONST void *buf, unsigned int nbyte, int allow_quit) { -#ifdef VMS - return vms_write (fildes, buf, nbyte); -#else int rtnval; int bytes_written = 0; CONST char *b = (CONST char *) buf; @@ -2923,7 +2518,6 @@ bytes_written += rtnval; } return (bytes_written); -#endif } #ifdef ENCAPSULATE_WRITE @@ -3035,8 +2629,6 @@ items_written += rtnval; } return (items_written); -#elif defined (VMS) - return vms_fwrite (ptr, size, nitem, stream); #else return fwrite (ptr, size, nitem, stream); #endif @@ -3172,11 +2764,7 @@ sys_access (CONST char *path, int mode) { PATHNAME_CONVERT_OUT (path); -#ifdef VMS - return vms_access (path, mode); -#else return access (path, mode); -#endif } #endif /* ENCAPSULATE_ACCESS */ @@ -3886,14 +3474,12 @@ } -#ifndef VMS #define DIRSIZ 14 struct olddir { ino_t od_ino; /* inode */ char od_name[DIRSIZ]; /* filename */ }; -#endif /* not VMS */ static struct direct dir_static; /* simulated directory contents */ @@ -3901,12 +3487,7 @@ struct direct * readdir (DIR *dirp) /* stream from opendir */ { -#ifndef VMS struct olddir *dp; /* -> directory data */ -#else /* VMS */ - struct dir$_name *dp; /* -> directory data */ - struct dir$_version *dv; /* -> version data */ -#endif /* VMS */ for (; ;) { @@ -3917,7 +3498,6 @@ && (dirp->dd_size = sys_read (dirp->dd_fd, dirp->dd_buf, DIRBLKSIZ)) <= 0) return 0; -#ifndef VMS dp = (struct olddir *) &dirp->dd_buf[dirp->dd_loc]; dirp->dd_loc += sizeof (struct olddir); @@ -3932,59 +3512,9 @@ + dir_static.d_namlen - dir_static.d_namlen % 4; return &dir_static; /* -> simulated structure */ } -#else /* VMS */ - dp = (struct dir$_name *) dirp->dd_buf; - if (dirp->dd_loc == 0) - dirp->dd_loc = (dp->dir$b_namecount&1) ? dp->dir$b_namecount + 1 - : dp->dir$b_namecount; - dv = (struct dir$_version *)&dp->dir$t_name[dirp->dd_loc]; - dir_static.d_ino = dv->dir$w_fid_num; - dir_static.d_namlen = dp->dir$b_namecount; - dir_static.d_reclen = sizeof (struct direct) - - MAXNAMLEN + 3 - + dir_static.d_namlen - dir_static.d_namlen % 4; - strncpy (dir_static.d_name, dp->dir$t_name, dp->dir$b_namecount); - dir_static.d_name[dir_static.d_namlen] = '\0'; - dirp->dd_loc = dirp->dd_size; /* only one record at a time */ - return &dir_static; -#endif /* VMS */ } } -#ifdef VMS -/* readdirver is just like readdir except it returns all versions of a file - as separate entries. */ - -/* ARGUSED */ -struct direct * -readdirver (DIR *dirp) /* stream from opendir */ -{ - struct dir$_name *dp; /* -> directory data */ - struct dir$_version *dv; /* -> version data */ - - if (dirp->dd_loc >= dirp->dd_size - sizeof (struct dir$_name)) - dirp->dd_loc = dirp->dd_size = 0; - - if (dirp->dd_size == 0 /* refill buffer */ - && (dirp->dd_size = sys_read (dirp->dd_fd, dirp->dd_buf, DIRBLKSIZ)) <= 0) - return 0; - - dp = (struct dir$_name *) dirp->dd_buf; - if (dirp->dd_loc == 0) - dirp->dd_loc = (dp->dir$b_namecount & 1) ? dp->dir$b_namecount + 1 - : dp->dir$b_namecount; - dv = (struct dir$_version *) &dp->dir$t_name[dirp->dd_loc]; - strncpy (dir_static.d_name, dp->dir$t_name, dp->dir$b_namecount); - sprintf (&dir_static.d_name[dp->dir$b_namecount], ";%d", dv->dir$w_version); - dir_static.d_namlen = strlen (dir_static.d_name); - dir_static.d_ino = dv->dir$w_fid_num; - dir_static.d_reclen = sizeof (struct direct) - MAXNAMLEN + 3 - + dir_static.d_namlen - dir_static.d_namlen % 4; - dirp->dd_loc = ((char *) (++dv) - dp->dir$t_name); - return &dir_static; -} - -#endif /* VMS */ #endif /* NONSYSTEM_DIR_LIBRARY */ @@ -4149,1305 +3679,6 @@ #endif /* USE_DL_STUBS */ -/************************************************************************/ -/* VMS emulation of system calls */ -/************************************************************************/ - -#ifdef VMS -#include "vms-pwd.h" -#include <acldef.h> -#include <chpdef.h> -#include <jpidef.h> - -/* Return as a string the VMS error string pertaining to STATUS. - Reuses the same static buffer each time it is called. */ - -char * -vmserrstr (int status) /* VMS status code */ -{ - int bufadr[2]; - short len; - static char buf[257]; - - bufadr[0] = sizeof buf - 1; - bufadr[1] = (int) buf; - if (! (SYS$GETMSG (status, &len, bufadr, 0x1, 0) & 1)) - return "untranslatable VMS error status"; - buf[len] = '\0'; - return buf; -} - -#ifdef access -#undef access - -/* The following is necessary because 'access' emulation by VMS C (2.0) does - * not work correctly. (It also doesn't work well in version 2.3.) - */ - -#ifdef VMS4_4 - -#define DESCRIPTOR(name,string) struct dsc$descriptor_s name = \ - { strlen (string), DSC$K_DTYPE_T, DSC$K_CLASS_S, string } - -typedef union { - struct { - unsigned short s_buflen; - unsigned short s_code; - char *s_bufadr; - unsigned short *s_retlenadr; - } s; - int end; -} item; -#define buflen s.s_buflen -#define code s.s_code -#define bufadr s.s_bufadr -#define retlenadr s.s_retlenadr - -#define R_OK 4 /* test for read permission */ -#define W_OK 2 /* test for write permission */ -#define X_OK 1 /* test for execute (search) permission */ -#define F_OK 0 /* test for presence of file */ - -int -vms_access (CONST char *path, int mode) -{ - static char *user = NULL; - char dir_fn[512]; - - /* translate possible directory spec into .DIR file name, so brain-dead - * access can treat the directory like a file. */ - if (directory_file_name (path, dir_fn)) - path = dir_fn; - - if (mode == F_OK) - return access (path, mode); - if (user == NULL && (user = (char *) getenv ("USER")) == NULL) - return -1; - { - int stat; - int flags; - int acces; - unsigned short int dummy; - item itemlst[3]; - static int constant = ACL$C_FILE; - DESCRIPTOR (path_desc, path); - DESCRIPTOR (user_desc, user); - - flags = 0; - acces = 0; - if ((mode & X_OK) && ((stat = access (path, mode)) < 0 || mode == X_OK)) - return stat; - if (mode & R_OK) - acces |= CHP$M_READ; - if (mode & W_OK) - acces |= CHP$M_WRITE; - itemlst[0].buflen = sizeof (int); - itemlst[0].code = CHP$_FLAGS; - itemlst[0].bufadr = (char *) &flags; - itemlst[0].retlenadr = &dummy; - itemlst[1].buflen = sizeof (int); - itemlst[1].code = CHP$_ACCESS; - itemlst[1].bufadr = (char *) &acces; - itemlst[1].retlenadr = &dummy; - itemlst[2].end = CHP$_END; - stat = SYS$CHECK_ACCESS (&constant, &path_desc, &user_desc, itemlst); - return stat == SS$_NORMAL ? 0 : -1; - } -} - -#else /* not VMS4_4 */ - -#include <prvdef.h> -#define ACE$M_WRITE 2 -#define ACE$C_KEYID 1 - -static unsigned short vms_memid, vms_grpid; -static unsigned int vms_uic; - -/* Called from init_sys_modes, so it happens not very often - but at least each time Emacs is loaded. */ -sys_access_reinit (void) -{ - vms_uic = 0; -} - -int -vms_access (CONST char *filename, int type) -{ - struct FAB fab; - struct XABPRO xab; - int status, size, i, typecode, acl_controlled; - unsigned int *aclptr, *aclend, aclbuf[60]; - union prvdef prvmask; - - /* Get UIC and GRP values for protection checking. */ - if (vms_uic == 0) - { - status = LIB$GETJPI (&JPI$_UIC, 0, 0, &vms_uic, 0, 0); - if (! (status & 1)) - return -1; - vms_memid = vms_uic & 0xFFFF; - vms_grpid = vms_uic >> 16; - } - - if (type != 2) /* not checking write access */ - return access (filename, type); - - /* Check write protection. */ - -#define CHECKPRIV(bit) (prvmask.bit) -#define WRITEABLE(field) (! ((xab.xab$w_pro >> field) & XAB$M_NOWRITE)) - - /* Find privilege bits */ - status = SYS$SETPRV (0, 0, 0, prvmask); - if (! (status & 1)) - error ("Unable to find privileges: %s", vmserrstr (status)); - if (CHECKPRIV (PRV$V_BYPASS)) - return 0; /* BYPASS enabled */ - fab = cc$rms_fab; - fab.fab$b_fac = FAB$M_GET; - fab.fab$l_fna = filename; - fab.fab$b_fns = strlen (filename); - fab.fab$l_xab = &xab; - xab = cc$rms_xabpro; - xab.xab$l_aclbuf = aclbuf; - xab.xab$w_aclsiz = sizeof (aclbuf); - status = SYS$OPEN (&fab, 0, 0); - if (! (status & 1)) - return -1; - SYS$CLOSE (&fab, 0, 0); - /* Check system access */ - if (CHECKPRIV (PRV$V_SYSPRV) && WRITEABLE (XAB$V_SYS)) - return 0; - /* Check ACL entries, if any */ - acl_controlled = 0; - if (xab.xab$w_acllen > 0) - { - aclptr = aclbuf; - aclend = &aclbuf[xab.xab$w_acllen / 4]; - while (*aclptr && aclptr < aclend) - { - size = (*aclptr & 0xff) / 4; - typecode = (*aclptr >> 8) & 0xff; - if (typecode == ACE$C_KEYID) - for (i = size - 1; i > 1; i--) - if (aclptr[i] == vms_uic) - { - acl_controlled = 1; - if (aclptr[1] & ACE$M_WRITE) - return 0; /* Write access through ACL */ - } - aclptr = &aclptr[size]; - } - if (acl_controlled) /* ACL specified, prohibits write access */ - return -1; - } - /* No ACL entries specified, check normal protection */ - if (WRITEABLE (XAB$V_WLD)) /* World writeable */ - return 0; - if (WRITEABLE (XAB$V_GRP) && - (unsigned short) (xab.xab$l_uic >> 16) == vms_grpid) - return 0; /* Group writeable */ - if (WRITEABLE (XAB$V_OWN) && - (xab.xab$l_uic & 0xFFFF) == vms_memid) - return 0; /* Owner writeable */ - - return -1; /* Not writeable */ -} -#endif /* not VMS4_4 */ -#endif /* access */ - -static char vtbuf[NAM$C_MAXRSS+1]; - -/* translate a vms file spec to a unix path */ -char * -sys_translate_vms (char *vfile) -{ - char * p; - char * targ; - - if (!vfile) - return 0; - - targ = vtbuf; - - /* leading device or logical name is a root directory */ - if (p = strchr (vfile, ':')) - { - *targ++ = '/'; - while (vfile < p) - *targ++ = *vfile++; - vfile++; - *targ++ = '/'; - } - p = vfile; - if (*p == '[' || *p == '<') - { - while (*++vfile != *p + 2) - switch (*vfile) - { - case '.': - if (vfile[-1] == *p) - *targ++ = '.'; - *targ++ = '/'; - break; - - case '-': - *targ++ = '.'; - *targ++ = '.'; - break; - - default: - *targ++ = *vfile; - break; - } - vfile++; - *targ++ = '/'; - } - while (*vfile) - *targ++ = *vfile++; - - return vtbuf; -} - -static char utbuf[NAM$C_MAXRSS+1]; - -/* translate a unix path to a VMS file spec */ -char * -sys_translate_unix (char *ufile) -{ - int slash_seen = 0; - char *p; - char * targ; - - if (!ufile) - return 0; - - targ = utbuf; - - if (*ufile == '/') - { - ufile++; - } - - while (*ufile) - { - switch (*ufile) - { - case '/': - if (slash_seen) - if (strchr (&ufile[1], '/')) - *targ++ = '.'; - else - *targ++ = ']'; - else - { - *targ++ = ':'; - if (strchr (&ufile[1], '/')) - *targ++ = '['; - slash_seen = 1; - } - break; - - case '.': - if (strncmp (ufile, "./", 2) == 0) - { - if (!slash_seen) - { - *targ++ = '['; - slash_seen = 1; - } - ufile++; /* skip the dot */ - if (strchr (&ufile[1], '/')) - *targ++ = '.'; - else - *targ++ = ']'; - } - else if (strncmp (ufile, "../", 3) == 0) - { - if (!slash_seen) - { - *targ++ = '['; - slash_seen = 1; - } - *targ++ = '-'; - ufile += 2; /* skip the dots */ - if (strchr (&ufile[1], '/')) - *targ++ = '.'; - else - *targ++ = ']'; - } - else - *targ++ = *ufile; - break; - - default: - *targ++ = *ufile; - break; - } - ufile++; - } - *targ = '\0'; - - return utbuf; -} - -char * -getwd (char *pathname) -{ - char *ptr; - strcpy (pathname, egetenv ("PATH")); - - ptr = pathname; - while (*ptr) - { - /* #### This is evil. Smashes (shared) result of egetenv */ - *ptr = toupper (* (unsigned char *) ptr); - ptr++; - } - return pathname; -} - -int -getppid (void) -{ - long item_code = JPI$_OWNER; - unsigned long parent_id; - int status; - - if (((status = LIB$GETJPI (&item_code, 0, 0, &parent_id)) & 1) == 0) - { - errno = EVMSERR; - vaxc$errno = status; - return -1; - } - return parent_id; -} - -#undef getuid -unsigned int -sys_getuid (void) -{ - return (getgid () << 16) | getuid (); -} - -int -vms_read (int fildes, CONST void *buf, unsigned int nbyte) -{ - return read (fildes, buf, (nbyte < MAXIOSIZE ? nbyte : MAXIOSIZE)); -} - -#if 0 -int -vms_write (int fildes, CONST void *buf, unsigned int nbyte) -{ - int nwrote, rtnval = 0; - - while (nbyte > MAXIOSIZE && (nwrote = write (fildes, buf, MAXIOSIZE)) > 0) - { - nbyte -= nwrote; - buf += nwrote; - rtnval += nwrote; - } - if (nwrote < 0) - return rtnval ? rtnval : -1; - if ((nwrote = write (fildes, buf, nbyte)) < 0) - return rtnval ? rtnval : -1; - return (rtnval + nwrote); -} -#endif /* 0 */ - -/* - * VAX/VMS VAX C RTL really loses. It insists that records - * end with a newline (carriage return) character, and if they - * don't it adds one (nice of it isn't it!) - * - * Thus we do this stupidity below. - */ - -int -vms_write (int fildes, CONST void *buf, unsigned int nbytes) -{ - char *p; - char *e; - int sum = 0; - struct stat st; - - fstat (fildes, &st); - p = buf; - while (nbytes > 0) - { - int len, retval; - - /* Handle fixed-length files with carriage control. */ - if (st.st_fab_rfm == FAB$C_FIX - && ((st.st_fab_rat & (FAB$M_FTN | FAB$M_CR)) != 0)) - { - len = st.st_fab_mrs; - retval = write (fildes, p, min (len, nbytes)); - if (retval != len) - return -1; - retval++; /* This skips the implied carriage control */ - } - else - { - e = p + min (MAXIOSIZE, nbytes) - 1; - while (*e != '\n' && e > p) e--; - if (p == e) /* Ok.. so here we add a newline... sigh. */ - e = p + min (MAXIOSIZE, nbytes) - 1; - len = e + 1 - p; - retval = write (fildes, p, len); - if (retval != len) - return -1; - } - p += retval; - sum += retval; - nbytes -= retval; - } - return sum; -} - -/* Create file NEW copying its attributes from file OLD. If - OLD is 0 or does not exist, create based on the value of - vms_stmlf_recfm. */ - -/* Protection value the file should ultimately have. - Set by create_copy_attrs, and use by rename_sansversions. */ -static unsigned short int vms_fab_final_pro; - -int -creat_copy_attrs (char *old, char *new) -{ - struct FAB fab = cc$rms_fab; - struct XABPRO xabpro; - char aclbuf[256]; /* Choice of size is arbitrary. See below. */ - extern int vms_stmlf_recfm; - - if (old) - { - fab.fab$b_fac = FAB$M_GET; - fab.fab$l_fna = old; - fab.fab$b_fns = strlen (old); - fab.fab$l_xab = (char *) &xabpro; - xabpro = cc$rms_xabpro; - xabpro.xab$l_aclbuf = aclbuf; - xabpro.xab$w_aclsiz = sizeof aclbuf; - /* Call $OPEN to fill in the fab & xabpro fields. */ - if (SYS$OPEN (&fab, 0, 0) & 1) - { - SYS$CLOSE (&fab, 0, 0); - fab.fab$l_alq = 0; /* zero the allocation quantity */ - if (xabpro.xab$w_acllen > 0) - { - if (xabpro.xab$w_acllen > sizeof aclbuf) - /* If the acl buffer was too short, redo open with longer one. - Wouldn't need to do this if there were some system imposed - limit on the size of an ACL, but I can't find any such. */ - { - xabpro.xab$l_aclbuf = (char *) alloca (xabpro.xab$w_acllen); - xabpro.xab$w_aclsiz = xabpro.xab$w_acllen; - if (SYS$OPEN (&fab, 0, 0) & 1) - SYS$CLOSE (&fab, 0, 0); - else - old = 0; - } - } - else - xabpro.xab$l_aclbuf = 0; - } - else - old = 0; - } - fab.fab$l_fna = new; - fab.fab$b_fns = strlen (new); - if (!old) - { - fab.fab$l_xab = 0; - fab.fab$b_rfm = vms_stmlf_recfm ? FAB$C_STMLF : FAB$C_VAR; - fab.fab$b_rat = FAB$M_CR; - } - - /* Set the file protections such that we will be able to manipulate - this file. Once we are done writing and renaming it, we will set - the protections back. */ - if (old) - vms_fab_final_pro = xabpro.xab$w_pro; - else - SYS$SETDFPROT (0, &vms_fab_final_pro); - xabpro.xab$w_pro &= 0xff0f; /* set O:rewd for now. This is set back later. */ - - /* Create the new file with either default attrs or attrs copied - from old file. */ - if (!(SYS$CREATE (&fab, 0, 0) & 1)) - return -1; - SYS$CLOSE (&fab, 0, 0); - /* As this is a "replacement" for creat, return a file descriptor - opened for writing. */ - return open (new, O_WRONLY); -} - -int -vms_creat (CONST char *path, int mode, ...) -{ - int rfd; /* related file descriptor */ - int fd; /* Our new file descriptor */ - int count; - struct stat st_buf; - char rfm[12]; - char rat[15]; - char mrs[13]; - char fsz[13]; - extern int vms_stmlf_recfm; - - /* #### there was some weird machine-dependent code to determine how many - arguments were passed to this function. This certainly won't work - under ANSI C. */ - if (count > 2) - rfd = fix this; - if (count > 2) - { - /* Use information from the related file descriptor to set record - format of the newly created file. */ - fstat (rfd, &st_buf); - switch (st_buf.st_fab_rfm) - { - case FAB$C_FIX: - strcpy (rfm, "rfm = fix"); - sprintf (mrs, "mrs = %d", st_buf.st_fab_mrs); - strcpy (rat, "rat = "); - if (st_buf.st_fab_rat & FAB$M_CR) - strcat (rat, "cr"); - else if (st_buf.st_fab_rat & FAB$M_FTN) - strcat (rat, "ftn"); - else if (st_buf.st_fab_rat & FAB$M_PRN) - strcat (rat, "prn"); - if (st_buf.st_fab_rat & FAB$M_BLK) - if (st_buf.st_fab_rat & (FAB$M_CR|FAB$M_FTN|FAB$M_PRN)) - strcat (rat, ", blk"); - else - strcat (rat, "blk"); - return creat (name, 0, rfm, rat, mrs); - - case FAB$C_VFC: - strcpy (rfm, "rfm = vfc"); - sprintf (fsz, "fsz = %d", st_buf.st_fab_fsz); - strcpy (rat, "rat = "); - if (st_buf.st_fab_rat & FAB$M_CR) - strcat (rat, "cr"); - else if (st_buf.st_fab_rat & FAB$M_FTN) - strcat (rat, "ftn"); - else if (st_buf.st_fab_rat & FAB$M_PRN) - strcat (rat, "prn"); - if (st_buf.st_fab_rat & FAB$M_BLK) - if (st_buf.st_fab_rat & (FAB$M_CR|FAB$M_FTN|FAB$M_PRN)) - strcat (rat, ", blk"); - else - strcat (rat, "blk"); - return creat (name, 0, rfm, rat, fsz); - - case FAB$C_STM: - strcpy (rfm, "rfm = stm"); - break; - - case FAB$C_STMCR: - strcpy (rfm, "rfm = stmcr"); - break; - - case FAB$C_STMLF: - strcpy (rfm, "rfm = stmlf"); - break; - - case FAB$C_UDF: - strcpy (rfm, "rfm = udf"); - break; - - case FAB$C_VAR: - strcpy (rfm, "rfm = var"); - break; - } - strcpy (rat, "rat = "); - if (st_buf.st_fab_rat & FAB$M_CR) - strcat (rat, "cr"); - else if (st_buf.st_fab_rat & FAB$M_FTN) - strcat (rat, "ftn"); - else if (st_buf.st_fab_rat & FAB$M_PRN) - strcat (rat, "prn"); - if (st_buf.st_fab_rat & FAB$M_BLK) - if (st_buf.st_fab_rat & (FAB$M_CR|FAB$M_FTN|FAB$M_PRN)) - strcat (rat, ", blk"); - else - strcat (rat, "blk"); - } - else - { - strcpy (rfm, vms_stmlf_recfm ? "rfm = stmlf" : "rfm=var"); - strcpy (rat, "rat=cr"); - } - /* Until the VAX C RTL fixes the many bugs with modes, always use - mode 0 to get the user's default protection. */ - fd = creat (name, 0, rfm, rat); - if (fd < 0 && errno == EEXIST) - { - if (unlink (name) < 0) - report_file_error ("delete", build_string (name)); - fd = creat (name, 0, rfm, rat); - } - return fd; -} - -/* fwrite to stdout is S L O W. Speed it up by using fputc...*/ -int -vms_fwrite (CONST void *ptr, int size, int num, FILE *fp) -{ - int tot = num * size; - - while (tot--) - fputc (* (CONST char *) ptr++, fp); - return (num); -} - -/* - * The VMS C library routine creat actually creates a new version of an - * existing file rather than truncating the old version. There are times - * when this is not the desired behavior, for instance, when writing an - * auto save file (you only want one version), or when you don't have - * write permission in the directory containing the file (but the file - * itself is writable). Hence this routine, which is equivalent to - * "close (creat (fn, 0));" on Unix if fn already exists. - */ -int -vms_truncate (char *fn) -{ - struct FAB xfab = cc$rms_fab; - struct RAB xrab = cc$rms_rab; - int status; - - xfab.fab$l_fop = FAB$M_TEF; /* free allocated but unused blocks on close */ - xfab.fab$b_fac = FAB$M_TRN | FAB$M_GET; /* allow truncate and get access */ - xfab.fab$b_shr = FAB$M_NIL; /* allow no sharing - file must be locked */ - xfab.fab$l_fna = fn; - xfab.fab$b_fns = strlen (fn); - xfab.fab$l_dna = ";0"; /* default to latest version of the file */ - xfab.fab$b_dns = 2; - xrab.rab$l_fab = &xfab; - - /* This gibberish opens the file, positions to the first record, and - deletes all records from there until the end of file. */ - if ((SYS$OPEN (&xfab) & 01) == 01) - { - if ((SYS$CONNECT (&xrab) & 01) == 01 && - (SYS$FIND (&xrab) & 01) == 01 && - (SYS$TRUNCATE (&xrab) & 01) == 01) - status = 0; - else - status = -1; - } - else - status = -1; - SYS$CLOSE (&xfab); - return status; -} - -/* Define this symbol to actually read SYSUAF.DAT. This requires either - SYSPRV or a readable SYSUAF.DAT. */ - -#ifdef READ_SYSUAF -/* - * getuaf.c - * - * Routine to read the VMS User Authorization File and return - * a specific user's record. - */ - -static struct UAF vms_retuaf; - -static struct UAF * -get_uaf_name (char *uname) -{ - status; - struct FAB uaf_fab; - struct RAB uaf_rab; - - uaf_fab = cc$rms_fab; - uaf_rab = cc$rms_rab; - /* initialize fab fields */ - uaf_fab.fab$l_fna = "SYS$SYSTEM:SYSUAF.DAT"; - uaf_fab.fab$b_fns = 21; - uaf_fab.fab$b_fac = FAB$M_GET; - uaf_fab.fab$b_org = FAB$C_IDX; - uaf_fab.fab$b_shr = FAB$M_GET|FAB$M_PUT|FAB$M_UPD|FAB$M_DEL; - /* initialize rab fields */ - uaf_rab.rab$l_fab = &uaf_fab; - /* open the User Authorization File */ - status = SYS$OPEN (&uaf_fab); - if (!(status&1)) - { - errno = EVMSERR; - vaxc$errno = status; - return 0; - } - status = SYS$CONNECT (&uaf_rab); - if (!(status&1)) - { - errno = EVMSERR; - vaxc$errno = status; - return 0; - } - /* read the requested record - index is in uname */ - uaf_rab.rab$l_kbf = uname; - uaf_rab.rab$b_ksz = strlen (uname); - uaf_rab.rab$b_rac = RAB$C_KEY; - uaf_rab.rab$l_ubf = (char *)&vms_retuaf; - uaf_rab.rab$w_usz = sizeof vms_retuaf; - status = SYS$GET (&uaf_rab); - if (!(status&1)) - { - errno = EVMSERR; - vaxc$errno = status; - return 0; - } - /* close the User Authorization File */ - status = SYS$DISCONNECT (&uaf_rab); - if (!(status&1)) - { - errno = EVMSERR; - vaxc$errno = status; - return 0; - } - status = SYS$CLOSE (&uaf_fab); - if (!(status&1)) - { - errno = EVMSERR; - vaxc$errno = status; - return 0; - } - return &vms_retuaf; -} - -static struct UAF * -get_uaf_uic (unsigned long uic) -{ - status; - struct FAB uaf_fab; - struct RAB uaf_rab; - - uaf_fab = cc$rms_fab; - uaf_rab = cc$rms_rab; - /* initialize fab fields */ - uaf_fab.fab$l_fna = "SYS$SYSTEM:SYSUAF.DAT"; - uaf_fab.fab$b_fns = 21; - uaf_fab.fab$b_fac = FAB$M_GET; - uaf_fab.fab$b_org = FAB$C_IDX; - uaf_fab.fab$b_shr = FAB$M_GET|FAB$M_PUT|FAB$M_UPD|FAB$M_DEL; - /* initialize rab fields */ - uaf_rab.rab$l_fab = &uaf_fab; - /* open the User Authorization File */ - status = SYS$OPEN (&uaf_fab); - if (!(status&1)) - { - errno = EVMSERR; - vaxc$errno = status; - return 0; - } - status = SYS$CONNECT (&uaf_rab); - if (!(status&1)) - { - errno = EVMSERR; - vaxc$errno = status; - return 0; - } - /* read the requested record - index is in uic */ - uaf_rab.rab$b_krf = 1; /* 1st alternate key */ - uaf_rab.rab$l_kbf = (char *) &uic; - uaf_rab.rab$b_ksz = sizeof uic; - uaf_rab.rab$b_rac = RAB$C_KEY; - uaf_rab.rab$l_ubf = (char *)&vms_retuaf; - uaf_rab.rab$w_usz = sizeof vms_retuaf; - status = SYS$GET (&uaf_rab); - if (!(status&1)) - { - errno = EVMSERR; - vaxc$errno = status; - return 0; - } - /* close the User Authorization File */ - status = SYS$DISCONNECT (&uaf_rab); - if (!(status&1)) - { - errno = EVMSERR; - vaxc$errno = status; - return 0; - } - status = SYS$CLOSE (&uaf_fab); - if (!(status&1)) - { - errno = EVMSERR; - vaxc$errno = status; - return 0; - } - return &vms_retuaf; -} - -static struct passwd vms_retpw; - -static struct passwd * -cnv_uaf_pw (struct UAF *up) -{ - char * ptr; - - /* copy these out first because if the username is 32 chars, the next - section will overwrite the first byte of the UIC */ - vms_retpw.pw_uid = up->uaf$w_mem; - vms_retpw.pw_gid = up->uaf$w_grp; - - /* I suppose this is not the best sytle, to possibly overwrite one - byte beyond the end of the field, but what the heck... */ - ptr = &up->uaf$t_username[UAF$S_USERNAME]; - while (ptr[-1] == ' ') - ptr--; - *ptr = '\0'; - strcpy (vms_retpw.pw_name, up->uaf$t_username); - - /* the rest of these are counted ascii strings */ - strncpy (vms_retpw.pw_gecos, &up->uaf$t_owner[1], up->uaf$t_owner[0]); - vms_retpw.pw_gecos[up->uaf$t_owner[0]] = '\0'; - strncpy (vms_retpw.pw_dir, &up->uaf$t_defdev[1], up->uaf$t_defdev[0]); - vms_retpw.pw_dir[up->uaf$t_defdev[0]] = '\0'; - strncat (vms_retpw.pw_dir, &up->uaf$t_defdir[1], up->uaf$t_defdir[0]); - vms_retpw.pw_dir[up->uaf$t_defdev[0] + up->uaf$t_defdir[0]] = '\0'; - strncpy (vms_retpw.pw_shell, &up->uaf$t_defcli[1], up->uaf$t_defcli[0]); - vms_retpw.pw_shell[up->uaf$t_defcli[0]] = '\0'; - - return &vms_retpw; -} -#else /* not READ_SYSUAF */ -static struct passwd vms_retpw; -#endif /* not READ_SYSUAF */ - -struct passwd * -getpwnam (char *name) -{ -#ifdef READ_SYSUAF - struct UAF *up; -#else - char * user; - char * dir; - unsigned char * full; -#endif /* READ_SYSUAF */ - char *ptr = name; - - while (*ptr) - { - *ptr = toupper (* (unsigned char *) ptr); - ptr++; - } -#ifdef READ_SYSUAF - if (!(up = get_uaf_name (name))) - return 0; - return cnv_uaf_pw (up); -#else - if (strcmp (name, getenv ("USER")) == 0) - { - vms_retpw.pw_uid = getuid (); - vms_retpw.pw_gid = getgid (); - strcpy (vms_retpw.pw_name, name); - if (full = egetenv ("FULLNAME")) - strcpy (vms_retpw.pw_gecos, full); - else - *vms_retpw.pw_gecos = '\0'; - strcpy (vms_retpw.pw_dir, egetenv ("HOME")); - *vms_retpw.pw_shell = '\0'; - return &vms_retpw; - } - else - return 0; -#endif /* not READ_SYSUAF */ -} - -struct passwd * -getpwuid (unsigned long uid) -{ -#ifdef READ_SYSUAF - struct UAF * up; - - if (!(up = get_uaf_uic (uid))) - return 0; - return cnv_uaf_pw (up); -#else - if (uid == sys_getuid ()) - return getpwnam (egetenv ("USER")); - else - return 0; -#endif /* not READ_SYSUAF */ -} - -/* return total address space available to the current process. This is - the sum of the current p0 size, p1 size and free page table entries - available. */ -int -vlimit (void) -{ - int item_code; - unsigned long free_pages; - unsigned long frep0va; - unsigned long frep1va; - status; - - item_code = JPI$_FREPTECNT; - if (((status = LIB$GETJPI (&item_code, 0, 0, &free_pages)) & 1) == 0) - { - errno = EVMSERR; - vaxc$errno = status; - return -1; - } - free_pages *= 512; - - item_code = JPI$_FREP0VA; - if (((status = LIB$GETJPI (&item_code, 0, 0, &frep0va)) & 1) == 0) - { - errno = EVMSERR; - vaxc$errno = status; - return -1; - } - item_code = JPI$_FREP1VA; - if (((status = LIB$GETJPI (&item_code, 0, 0, &frep1va)) & 1) == 0) - { - errno = EVMSERR; - vaxc$errno = status; - return -1; - } - - return free_pages + frep0va + (0x7fffffff - frep1va); -} - -int -define_logical_name (char *varname, char *string) -{ - struct dsc$descriptor_s strdsc = - {strlen (string), DSC$K_DTYPE_T, DSC$K_CLASS_S, string}; - struct dsc$descriptor_s envdsc = - {strlen (varname), DSC$K_DTYPE_T, DSC$K_CLASS_S, varname}; - struct dsc$descriptor_s lnmdsc = - {7, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$JOB"}; - - return LIB$SET_LOGICAL (&envdsc, &strdsc, &lnmdsc, 0, 0); -} - -int -delete_logical_name (char *varname) -{ - struct dsc$descriptor_s envdsc = - {strlen (varname), DSC$K_DTYPE_T, DSC$K_CLASS_S, varname}; - struct dsc$descriptor_s lnmdsc = - {7, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$JOB"}; - - return LIB$DELETE_LOGICAL (&envdsc, &lnmdsc); -} - -execvp (void) -{ - error ("execvp system call not implemented"); -} - -int -rename (char *from, char *to) -{ - int status; - struct FAB from_fab = cc$rms_fab, to_fab = cc$rms_fab; - struct NAM from_nam = cc$rms_nam, to_nam = cc$rms_nam; - char from_esn[NAM$C_MAXRSS]; - char to_esn[NAM$C_MAXRSS]; - - from_fab.fab$l_fna = from; - from_fab.fab$b_fns = strlen (from); - from_fab.fab$l_nam = &from_nam; - from_fab.fab$l_fop = FAB$M_NAM; - - from_nam.nam$l_esa = from_esn; - from_nam.nam$b_ess = sizeof from_esn; - - to_fab.fab$l_fna = to; - to_fab.fab$b_fns = strlen (to); - to_fab.fab$l_nam = &to_nam; - to_fab.fab$l_fop = FAB$M_NAM; - - to_nam.nam$l_esa = to_esn; - to_nam.nam$b_ess = sizeof to_esn; - - status = SYS$RENAME (&from_fab, 0, 0, &to_fab); - - if (status & 1) - return 0; - else - { - if (status == RMS$_DEV) - errno = EXDEV; - else - errno = EVMSERR; - vaxc$errno = status; - return -1; - } -} - -/* This function renames a file like `rename', but it strips - the version number from the "to" filename, such that the "to" file is - will always be a new version. It also sets the file protection once it is - finished. The protection that we will use is stored in vms_fab_final_pro, - and was set when we did a creat_copy_attrs to create the file that we - are renaming. - - We could use the chmod function, but Eunichs uses 3 bits per user category - to describe the protection, and VMS uses 4 (write and delete are separate - bits). To maintain portability, the VMS implementation of `chmod' wires - the W and D bits together. */ - - -static char vms_file_written[NAM$C_MAXRSS]; - -int -rename_sans_version (char *from, char *to) -{ - short int chan; - int stat; - short int iosb[4]; - int status; - struct fibdef fib; - struct FAB to_fab = cc$rms_fab; - struct NAM to_nam = cc$rms_nam; - struct dsc$descriptor fib_d ={sizeof (fib),0,0,(char*) &fib}; - struct dsc$descriptor fib_attr[2] - = {{sizeof (vms_fab_final_pro),ATR$C_FPRO,0,(char*) &vms_fab_final_pro},{0,0,0,0}}; - char to_esn[NAM$C_MAXRSS]; - - $DESCRIPTOR (disk,to_esn); - - memset (&fib, 0, sizeof (fib)); - - to_fab.fab$l_fna = to; - to_fab.fab$b_fns = strlen (to); - to_fab.fab$l_nam = &to_nam; - to_fab.fab$l_fop = FAB$M_NAM; - - to_nam.nam$l_esa = to_esn; - to_nam.nam$b_ess = sizeof to_esn; - - status = SYS$PARSE (&to_fab, 0, 0); /* figure out the full file name */ - - if (to_nam.nam$l_fnb && NAM$M_EXP_VER) - *(to_nam.nam$l_ver) = '\0'; - - stat = rename (from, to_esn); - if (stat < 0) - return stat; - - strcpy (vms_file_written, to_esn); - - to_fab.fab$l_fna = vms_file_written; /* this points to the versionless name */ - to_fab.fab$b_fns = strlen (vms_file_written); - - /* Now set the file protection to the correct value */ - SYS$OPEN (&to_fab, 0, 0); /* This fills in the nam$w_fid fields */ - - /* Copy these fields into the fib */ - fib.fib$r_fid_overlay.fib$w_fid[0] = to_nam.nam$w_fid[0]; - fib.fib$r_fid_overlay.fib$w_fid[1] = to_nam.nam$w_fid[1]; - fib.fib$r_fid_overlay.fib$w_fid[2] = to_nam.nam$w_fid[2]; - - SYS$CLOSE (&to_fab, 0, 0); - - stat = SYS$ASSIGN (&disk, &chan, 0, 0); /* open a channel to the disk */ - if (!stat) - LIB$SIGNAL (stat); - stat = SYS$QIOW (0, chan, IO$_MODIFY, iosb, 0, 0, &fib_d, - 0, 0, 0, &fib_attr, 0); - if (!stat) - LIB$SIGNAL (stat); - stat = SYS$DASSGN (chan); - if (!stat) - LIB$SIGNAL (stat); - strcpy (vms_file_written, to_esn); /* We will write this to the terminal*/ - return 0; -} - -int -link (char *file, char *new) -{ - status; - struct FAB fab; - struct NAM nam; - unsigned short fid[3]; - char esa[NAM$C_MAXRSS]; - - fab = cc$rms_fab; - fab.fab$l_fop = FAB$M_OFP; - fab.fab$l_fna = file; - fab.fab$b_fns = strlen (file); - fab.fab$l_nam = &nam; - - nam = cc$rms_nam; - nam.nam$l_esa = esa; - nam.nam$b_ess = NAM$C_MAXRSS; - - status = SYS$PARSE (&fab); - if ((status & 1) == 0) - { - errno = EVMSERR; - vaxc$errno = status; - return -1; - } - status = SYS$SEARCH (&fab); - if ((status & 1) == 0) - { - errno = EVMSERR; - vaxc$errno = status; - return -1; - } - - fid[0] = nam.nam$w_fid[0]; - fid[1] = nam.nam$w_fid[1]; - fid[2] = nam.nam$w_fid[2]; - - fab.fab$l_fna = new; - fab.fab$b_fns = strlen (new); - - status = SYS$PARSE (&fab); - if ((status & 1) == 0) - { - errno = EVMSERR; - vaxc$errno = status; - return -1; - } - - nam.nam$w_fid[0] = fid[0]; - nam.nam$w_fid[1] = fid[1]; - nam.nam$w_fid[2] = fid[2]; - - nam.nam$l_esa = nam.nam$l_name; - nam.nam$b_esl = nam.nam$b_name + nam.nam$b_type + nam.nam$b_ver; - - status = SYS$ENTER (&fab); - if ((status & 1) == 0) - { - errno = EVMSERR; - vaxc$errno = status; - return -1; - } - - return 0; -} - -#ifdef getenv -/* If any place else asks for the TERM variable, - allow it to be overridden with the EMACS_TERM variable - before attempting to translate the logical name TERM. As a last - resort, ask for VAX C's special idea of the TERM variable. */ -#undef getenv -char * -sys_getenv (char *name) -{ - char *val; - static char buf[256]; - static struct dsc$descriptor_s equiv - = {sizeof (buf), DSC$K_DTYPE_T, DSC$K_CLASS_S, buf}; - static struct dsc$descriptor_s d_name - = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; - short eqlen; - - if (!strcmp (name, "TERM")) - { - val = (char *) getenv ("EMACS_TERM"); - if (val) - return val; - } - - d_name.dsc$w_length = strlen (name); - d_name.dsc$a_pointer = name; - if (LIB$SYS_TRNLOG (&d_name, &eqlen, &equiv) == 1) - { - char *str = (char *) xmalloc (eqlen + 1); - memcpy (str, buf, eqlen); - str[eqlen] = '\0'; - /* This is a storage leak, but a pain to fix. With luck, - no one will ever notice. */ - return str; - } - return (char *) getenv (name); -} -#endif /* getenv */ - -#ifdef abort -/* Since VMS doesn't believe in core dumps, the only way to debug this beast is - to force a call on the debugger from within the image. */ -#undef abort -sys_abort (void) -{ - reset_all_consoles (); - LIB$SIGNAL (SS$_DEBUG); -} -#endif /* abort */ - -#if 0 /* Apparently unused */ -/* The standard `sleep' routine works some other way - and it stops working if you have ever quit out of it. - This one continues to work. */ - -void -sys_sleep (int timeval) -{ - int time [2]; - static int zero = 0; - static int large = -10000000; - - LIB$EMUL (&timeval, &large, &zero, time); /* Convert to VMS format */ - - SYS$CANTIM (1, 0); - if (SYS$SETIMR (vms_timer_ef, time, 0, 1) & 1) /* Set timer */ - SYS$WAITFR (vms_timer_ef); /* Wait for timer expiry only */ -} -#endif /* 0 */ - -void -bzero (REGISTER char *b, REGISTER int length) -{ - short zero = 0; - long max_str = 65535; - - while (length > max_str) { - (void) LIB$MOVC5 (&zero, &zero, &zero, &max_str, b); - length -= max_str; - b += max_str; - } - max_str = length; - (void) LIB$MOVC5 (&zero, &zero, &zero, &max_str, b); -} - -/* Saying `void' requires a declaration, above, where bcopy is used - and that declaration causes pain for systems where bcopy is a macro. */ -bcopy (REGISTER char *b1, REGISTER char *b2, REGISTER int length) -{ - long max_str = 65535; - - while (length > max_str) { - (void) LIB$MOVC3 (&max_str, b1, b2); - length -= max_str; - b1 += max_str; - b2 += max_str; - } - max_str = length; - (void) LIB$MOVC3 (&length, b1, b2); -} - -int -bcmp (REGISTER char *b1, REGISTER char *b2, REGISTER int length) -/* This could be a macro! */ -{ - struct dsc$descriptor_s src1 = {length, DSC$K_DTYPE_T, DSC$K_CLASS_S, b1}; - struct dsc$descriptor_s src2 = {length, DSC$K_DTYPE_T, DSC$K_CLASS_S, b2}; - - return STR$COMPARE (&src1, &src2); -} - -#endif /* VMS */ #ifndef HAVE_STRCASECMP /*
--- a/src/sysdep.h Mon Aug 13 10:03:54 2007 +0200 +++ b/src/sysdep.h Mon Aug 13 10:04:58 2007 +0200 @@ -25,11 +25,7 @@ #include <setjmp.h> -#if !defined(VMS) || !defined(LINK_CRTL_SHARE) || !defined(SHAREABLE_LIB_BUG) extern char **environ; -#else -extern noshare char **environ; -#endif /* VMS sharable environ bug */ struct emacs_tty; int emacs_get_tty (int fd, struct emacs_tty *settings); @@ -154,21 +150,6 @@ int dup2 (int oldd, int newd); #endif -#ifdef VMS -void init_vms_input (void); - -int vms_truncate (char *fn); -int vlimit (void); /* BTW, name conflicts with unix syscall */ -int define_logical_name (char *varname, char *string) -int delete_logical_name (char *varname); -int rename_sans_version (char *from, char *to); -char *vmserrstr (int status); -char *sys_translate_vms (char *vfile); -char *sys_translate_unix (char *ufile); -int creat_copy_attrs (char *old, char *new); -int link (char *file, char *new); -#endif /* VMS */ - #ifndef HAVE_STRERROR /* X11R6 defines strerror as a macro */ # ifdef strerror
--- a/src/sysfile.h Mon Aug 13 10:03:54 2007 +0200 +++ b/src/sysfile.h Mon Aug 13 10:04:58 2007 +0200 @@ -40,18 +40,6 @@ # include <sys/fcntl.h> #endif /* NeXT */ -#ifdef VMS -#ifndef __GNUC__ -#include <file.h> -#endif -#include <rms.h> -#include <rmsdef.h> -#include <fab.h> -#include <nam.h> -#include <perror.h> -#include <stddef.h> -#endif - #ifdef WINDOWSNT #include <io.h> #endif @@ -156,7 +144,7 @@ #define S_ISNWK(m) (((m) & S_IFMT) == S_IFNWK) #endif -#if !defined (USG) && !defined (VMS) && !defined (WINDOWSNT) +#if !defined (USG) && !defined (WINDOWSNT) # define HAVE_FSYNC #endif
--- a/src/sysfloat.h Mon Aug 13 10:03:54 2007 +0200 +++ b/src/sysfloat.h Mon Aug 13 10:04:58 2007 +0200 @@ -76,16 +76,6 @@ # include <errno.h> #endif -/* Avoid traps on VMS from sinh and cosh. - All the other functions set errno instead. */ - -#ifdef VMS -#undef cosh -#undef sinh -#define cosh(x) ((exp(x)+exp(-x))*0.5) -#define sinh(x) ((exp(x)-exp(-x))*0.5) -#endif /* VMS */ - #ifndef isnan # define isnan(x) ((x) != (x)) #endif
--- a/src/sysproc.h Mon Aug 13 10:03:54 2007 +0200 +++ b/src/sysproc.h Mon Aug 13 10:04:58 2007 +0200 @@ -63,11 +63,7 @@ #endif /* Define first descriptor number available for subprocesses. */ -#ifdef VMS -# define FIRST_PROC_DESC 1 -#else /* Not VMS */ -# define FIRST_PROC_DESC 3 -#endif +#define FIRST_PROC_DESC 3 #ifdef IRIS # include <sys/sysmacros.h> /* for "minor" */
--- a/src/syspwd.h Mon Aug 13 10:03:54 2007 +0200 +++ b/src/syspwd.h Mon Aug 13 10:04:58 2007 +0200 @@ -19,8 +19,5 @@ /* Synched up with: Not really in FSF. */ -#ifdef VMS -#include "vms-pwd.h" -#else #include <pwd.h> -#endif +
--- a/src/syssignal.h Mon Aug 13 10:03:54 2007 +0200 +++ b/src/syssignal.h Mon Aug 13 10:04:58 2007 +0200 @@ -58,7 +58,7 @@ /* Define SIGCHLD as an alias for SIGCLD. There are many conditionals testing SIGCHLD. */ -#if !defined (VMS) && defined (SIGCLD) && !defined (SIGCHLD) +#if defined (SIGCLD) && !defined (SIGCHLD) # define SIGCHLD SIGCLD #endif /* SIGCHLD */ @@ -213,11 +213,6 @@ #endif #endif -#ifdef VMS -# define sys_siglist sys_errlist -# define NSIG sys_nerr -#endif /* VMS */ - #ifndef NSIG # define NSIG (SIGUSR2+1) /* guess how many elements are in sys_siglist... */ #endif
--- a/src/systime.h Mon Aug 13 10:03:54 2007 +0200 +++ b/src/systime.h Mon Aug 13 10:04:58 2007 +0200 @@ -55,12 +55,6 @@ extern long timezone; #endif -#ifdef VMS -#ifdef VAXC -#include "vmstime.h" -#endif -#endif - /* On some configurations (hpux8.0, X11R4), sys/time.h and X11/Xos.h disagree about the name of the guard symbol. */ #ifdef HPUX
--- a/src/systty.h Mon Aug 13 10:03:54 2007 +0200 +++ b/src/systty.h Mon Aug 13 10:04:58 2007 +0200 @@ -96,7 +96,7 @@ /* Nothing doing */ -#elif !defined (VMS) +#else /***** (4) The BSD way *****/ @@ -106,46 +106,8 @@ # include <sgtty.h> # endif -#else /* VMS */ -/***** (5) The VMS way *****/ - -# include <descrip.h> -static struct iosb -{ - short status; - short offset; - short termlen; - short term; -} input_iosb; - -extern int vms_waiting_for_ast; -extern int vms_stop_input; -extern int vms_input_ef; -extern int vms_timer_ef; -extern int vms_process_ef; -extern int vms_input_eflist; -extern int vms_timer_eflist; - -static $DESCRIPTOR (vms_input_dsc, "TT"); -static int vms_terminator_mask[2] = { 0, 0 }; - -static struct sensemode { - short status; - unsigned char xmit_baud; - unsigned char rcv_baud; - unsigned char crfill; - unsigned char lffill; - unsigned char parity; - unsigned char unused; - char class; - char type; - short scr_wid; - unsigned long tt_char : 24, scr_len : 8; - unsigned long tt2_char; -} sensemode_iosb; - -#endif /* VMS */ +#endif /* HAVE_TERMIOS */ /* XEmacs: I don't think we need the following crap. */ #ifdef __GNU_LIBRARY__ @@ -158,7 +120,7 @@ /* Generally useful to include this file: */ /* But Sun OS has broken include files and doesn't want it included */ -#if !defined (VMS) && !defined (DOS_NT) && !defined (WIN32) && !defined (SUNOS4) +#if !defined (DOS_NT) && !defined (WIN32) && !defined (SUNOS4) # include <sys/ioctl.h> #endif /* UNIPLUS systems may have FIONREAD. */ @@ -429,15 +391,11 @@ #ifdef HAVE_TERMIO struct termio main; #else /* !HAVE_TERMIO */ -#ifdef VMS - struct sensemode main; -#else /* !VMS */ #ifdef DOS_NT int main; #else /* not DOS_NT */ struct sgttyb main; #endif /* not DOS_NT */ -#endif /* !VMS */ #endif /* !HAVE_TERMIO */ #endif /* !HAVE_TCATTR */ @@ -483,19 +441,12 @@ #define EMACS_TTY_TABS_OK(p) (((p)->main.c_oflag & TABDLY) != TAB3) #else /* neither HAVE_TERMIO nor HAVE_TERMIOS */ -#ifdef VMS - -#define EMACS_TTY_TABS_OK(p) (((p)->main.tt_char & TT$M_MECHTAB) != 0) - -#else - #ifdef DOS_NT #define EMACS_TTY_TABS_OK(p) 0 #else /* not DOS_NT */ #define EMACS_TTY_TABS_OK(p) (((p)->main.sg_flags & XTABS) != XTABS) #endif /* not DOS_NT */ -#endif /* not def VMS */ #endif /* not def HAVE_TERMIO */ #endif /* not def HAVE_TERMIOS */
--- a/src/termcap.c Mon Aug 13 10:03:54 2007 +0200 +++ b/src/termcap.c Mon Aug 13 10:04:58 2007 +0200 @@ -253,13 +253,8 @@ static short speeds[] = { -#ifdef VMS - 0, 50, 75, 110, 134, 150, -3, -6, -12, -18, - -20, -24, -36, -48, -72, -96, -192 -#else /* not VMS */ 0, 50, 75, 110, 135, 150, -2, -3, -6, -12, -18, -24, -48, -96, -192, -288, -384, -576, -1152 -#endif /* not VMS */ }; void @@ -335,32 +330,6 @@ static int compare_contin (); static int name_match (); -#ifdef VMS - -#include <rmsdef.h> -#include <fab.h> -#include <nam.h> - -static int -legal_filename_p (fn) - char *fn; -{ - struct FAB fab = cc$rms_fab; - struct NAM nam = cc$rms_nam; - char esa[NAM$C_MAXRSS]; - - fab.fab$l_fna = fn; - fab.fab$b_fns = strlen(fn); - fab.fab$l_nam = &nam; - fab.fab$l_fop = FAB$M_NAM; - - nam.nam$l_esa = esa; - nam.nam$b_ess = sizeof esa; - - return SYS$PARSE(&fab, 0, 0) == RMS$_NORMAL; -} - -#endif /* VMS */ /* Find the termcap entry data for terminal type NAME and store it in the block that BP points to. @@ -385,16 +354,10 @@ int c; char *tcenv; /* TERMCAP value, if it contais :tc=. */ CONST char *indirect = 0; /* Terminal type in :tc= in TERMCAP value. */ - int filep; tem = getenv ("TERMCAP"); if (tem && *tem == 0) tem = 0; -#ifdef VMS - filep = tem && legal_filename_p (tem); -#else - filep = tem && (*tem == '/'); -#endif /* VMS */ /* If tem is non-null and starts with / (in the un*x case, that is), it is a file name to use instead of /etc/termcap. @@ -402,7 +365,7 @@ it is the entry itself, but only if the name the caller requested matches the TERM variable. */ - if (tem && !filep && !strcmp (name, (char *) getenv ("TERM"))) + if (tem && !IS_DIRECTORY_SEP (*tem) && !strcmp (name, (char *) getenv ("TERM"))) { indirect = tgetst1 (find_capability (tem, "tc"), 0); if (!indirect) @@ -423,11 +386,7 @@ indirect = (char *) 0; if (!tem) -#ifdef VMS - tem = "emacs_library:[etc]termcap.dat"; -#else tem = "/etc/termcap"; -#endif /* Here we know we must search a file and tem has its name. */
--- a/src/unexnt.c Mon Aug 13 10:03:54 2007 +0200 +++ b/src/unexnt.c Mon Aug 13 10:04:58 2007 +0200 @@ -33,14 +33,7 @@ #include "ntheap.h" -/* A convenient type for keeping all the info about a mapped file together. */ -typedef struct file_data { - char *name; - unsigned long size; - HANDLE file; - HANDLE file_mapping; - unsigned char *file_base; -} file_data; +/* Sync with FSF Emacs 19.34.6 note: struct file_data is now defined in ntheap.h */ enum { HEAP_UNINITIALIZED = 1, @@ -54,10 +47,6 @@ /* So we can find our heap in the file to recreate it. */ unsigned long heap_index_in_executable = UNINIT_LONG; -void open_input_file (file_data *p_file, char *name); -void open_output_file (file_data *p_file, char *name, unsigned long size); -void close_file_data (file_data *p_file); - void get_section_info (file_data *p_file); void copy_executable_and_dump_data_section (file_data *, file_data *); void dump_bss_and_heap (file_data *p_infile, file_data *p_outfile); @@ -157,7 +146,12 @@ round_heap (get_allocation_unit ()); /* Open the undumped executable file. */ - open_input_file (&in_file, in_filename); + if (!open_input_file (&in_file, in_filename)) + { + printf ("Failed to open %s (%d)...bailing.\n", + in_filename, GetLastError ()); + exit (1); + } /* Get the interesting section info, like start and size of .bss... */ get_section_info (&in_file); @@ -167,7 +161,12 @@ heap_index_in_executable = (unsigned long) round_to_next ((unsigned char *) in_file.size, get_allocation_unit ()); size = heap_index_in_executable + get_committed_heap_size () + bss_size; - open_output_file (&out_file, out_filename, size); + if (!open_output_file (&out_file, out_filename, size)) + { + printf ("Failed to open %s (%d)...bailing.\n", + out_filename, GetLastError ()); + exit (1); + } /* Set the flag (before dumping). */ heap_state = HEAP_UNLOADED; @@ -183,7 +182,7 @@ /* File handling. */ -void +int open_input_file (file_data *p_file, char *filename) { HANDLE file; @@ -194,83 +193,59 @@ file = CreateFile (filename, GENERIC_READ, FILE_SHARE_READ, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); if (file == INVALID_HANDLE_VALUE) - { - printf ("Failed to open %s (%d)...bailing.\n", - filename, GetLastError ()); - exit (1); - } + return FALSE; size = GetFileSize (file, &upper_size); file_mapping = CreateFileMapping (file, NULL, PAGE_READONLY, 0, size, NULL); if (!file_mapping) - { - printf ("Failed to create file mapping of %s (%d)...bailing.\n", - filename, GetLastError ()); - exit (1); - } + return FALSE; file_base = MapViewOfFile (file_mapping, FILE_MAP_READ, 0, 0, size); if (file_base == 0) - { - printf ("Failed to map view of file of %s (%d)...bailing.\n", - filename, GetLastError ()); - exit (1); - } + return FALSE; p_file->name = filename; p_file->size = size; p_file->file = file; p_file->file_mapping = file_mapping; p_file->file_base = file_base; + + return TRUE; } -void +int open_output_file (file_data *p_file, char *filename, unsigned long size) { HANDLE file; HANDLE file_mapping; void *file_base; - int i; file = CreateFile (filename, GENERIC_READ | GENERIC_WRITE, 0, NULL, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0); if (file == INVALID_HANDLE_VALUE) - { - i = GetLastError (); - printf ("open_output_file: Failed to open %s (%d).\n", - filename, i); - exit (1); - } + return FALSE; file_mapping = CreateFileMapping (file, NULL, PAGE_READWRITE, 0, size, NULL); if (!file_mapping) - { - i = GetLastError (); - printf ("open_output_file: Failed to create file mapping of %s (%d).\n", - filename, i); - exit (1); - } + return FALSE; file_base = MapViewOfFile (file_mapping, FILE_MAP_WRITE, 0, 0, size); if (file_base == 0) - { - i = GetLastError (); - printf ("open_output_file: Failed to map view of file of %s (%d).\n", - filename, i); - exit (1); - } + return FALSE; p_file->name = filename; p_file->size = size; p_file->file = file; p_file->file_mapping = file_mapping; p_file->file_base = file_base; + + return TRUE; } /* Close the system structures associated with the given file. */ -static void +void close_file_data (file_data *p_file) { UnmapViewOfFile (p_file->file_base); @@ -320,6 +295,44 @@ *p_bss_size = (DWORD) len; } +/* Return pointer to section header for named section. */ +IMAGE_SECTION_HEADER * +find_section (char * name, IMAGE_NT_HEADERS * nt_header) +{ + PIMAGE_SECTION_HEADER section; + int i; + + section = IMAGE_FIRST_SECTION (nt_header); + + for (i = 0; i < nt_header->FileHeader.NumberOfSections; i++) + { + if (strcmp (section->Name, name) == 0) + return section; + section++; + } + return NULL; +} + +/* Return pointer to section header for section containing the given + relative virtual address. */ +IMAGE_SECTION_HEADER * +rva_to_section (DWORD rva, IMAGE_NT_HEADERS * nt_header) +{ + PIMAGE_SECTION_HEADER section; + int i; + + section = IMAGE_FIRST_SECTION (nt_header); + + for (i = 0; i < nt_header->FileHeader.NumberOfSections; i++) + { + if (rva >= section->VirtualAddress && + rva < section->VirtualAddress + section->SizeOfRawData) + return section; + section++; + } + return NULL; +} + static unsigned long get_section_size (PIMAGE_SECTION_HEADER p_section) {
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/w32-proc.c Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,602 @@ +/* Win32 specific event-handling. + Copyright (C) 1997 Jonathan Harris. + +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. */ + +/* Authorship: + + Jonathan Harris, November 1997 for 20.4. + */ + +/* + * Comment: + * + * Windows user-input type events are stored in a per-thread message queue + * and retrieved using GetMessage(). It is not possible to wait on this + * queue and on other events (eg process input) simultaneously. Also, the + * main event-handling code in windows (the "windows procedure") is called + * asynchronously when windows has certain other types of events ("nonqueued + * messages") to deliver. The documentation doesn't appear to specify the + * context in which the windows procedure is called, but I assume that the + * thread that created the window is temporarily highjacked for this purpose. + * + * We spawn off a single thread to deal with both kinds of messages. The + * thread turns the windows events into emacs_events and stuffs them in a + * queue which XEmacs reads at its leisure. This file contains the code for + * the thread. This scheme also helps to prevent weird synchronisation and + * deadlock problems that might occur if the windows procedure was called + * when XEmacs was already in the middle of processing an event. + * + * Unfortunately, only the thread that created a window can retrieve messages + * destined for that window ("GetMessage does not retrieve messages for + * windows that belong to other threads..."). This means that our message- + * processing thread also has to do all window creation. We handle this + * bogosity by getting the main XEmacs thread to send special user-defined + * messages to the message-processing thread to instruct it to create windows. + */ + + +#include <config.h> +#include "lisp.h" + +#include "console-w32.h" +#include "device.h" +#include "frame.h" +#include "events.h" +#include "event-w32.h" + +#define W32_FRAME_STYLE WS_CLIPCHILDREN|WS_CLIPSIBLINGS|WS_TILEDWINDOW +#define W32_POPUP_STYLE WS_CLIPCHILDREN|WS_CLIPSIBLINGS|WS_CAPTION|WS_POPUP + +static LRESULT WINAPI w32_wnd_proc(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam); +static Lisp_Object w32_find_console (HWND hwnd); +static Lisp_Object w32_find_frame (HWND hwnd); +static Lisp_Object w32_key_to_emacs_keysym(int w32_key); + +/* + * Entry point for the "windows" message-processing thread + */ +DWORD w32_win_thread() +{ + WNDCLASS wc; + MSG msg; + w32_waitable_info_type info; + + /* Register the main window class */ + wc.style = /* CS_HREDRAW | CS_VREDRAW | */ CS_OWNDC; /* One DC per window */ + wc.lpfnWndProc = (WNDPROC) w32_wnd_proc; + wc.cbClsExtra = 0; + wc.cbWndExtra = 0; /* ? */ + wc.hInstance = NULL; /* ? */ + wc.hIcon = LoadIcon (NULL, XEMACS_CLASS); + wc.hCursor = LoadCursor (NULL, IDC_ARROW); + wc.hbrBackground = NULL; /* GetStockObject (WHITE_BRUSH); */ + wc.lpszMenuName = NULL; /* XXX FIXME? Add a menu? */ + wc.lpszClassName = XEMACS_CLASS; + RegisterClass(&wc); /* XXX FIXME: Should use RegisterClassEx */ + + info.type = w32_waitable_type_dispatch; + w32_add_waitable(&info); + + /* Ensure our message queue is created XXX FIXME: Is this necessary? */ + PeekMessage (&msg, NULL, 0, 0, PM_NOREMOVE); + + /* Notify the main thread that we're ready */ + assert(PostThreadMessage (w32_main_thread_id, WM_XEMACS_ACK, 0, 0)); + + /* Main windows loop */ + while (1) + { + GetMessage (&msg, NULL, 0, 0); + + /* + * Process things that don't have an associated window, so wouldn't + * get sent to w32_wnd_proc + */ + + /* Request from main thread */ + if (msg.message>=WM_XEMACS_BASE && msg.message<=WM_XEMACS_END) + w32_handle_request(&msg); + + /* Timeout */ + else if (msg.message == WM_TIMER) + { + Lisp_Object emacs_event; + struct Lisp_Event *event; + + KillTimer(NULL, msg.wParam); + EnterCriticalSection (&w32_dispatch_crit); + emacs_event = Fmake_event (Qnil, Qnil); + event = XEVENT(emacs_event); + + event->channel = Qnil; + event->timestamp = msg.time; + event->event_type = timeout_event; + event->event.timeout.interval_id = msg.wParam; + w32_enqueue_dispatch_event (emacs_event); + LeaveCriticalSection (&w32_dispatch_crit); + } + else + /* Pass on to w32_wnd_proc */ + DispatchMessage (&msg); + } +} + +/* + * The windows procedure for the window class XEMACS_CLASS + * Stuffs messages in the w32 event queue + */ +static LRESULT WINAPI w32_wnd_proc(HWND hwnd, UINT message, WPARAM wParam, + LPARAM lParam) +{ + /* Note: Remember to initialise these before use */ + Lisp_Object emacs_event; + struct Lisp_Event *event; + + static int mods = 0; + MSG msg = { hwnd, message, wParam, lParam, 0, {0,0} }; + msg.time = GetMessageTime(); + +#if 0 /* XXX */ + stderr_out("Message %04x, wParam=%04x, lParam=%08lx\n", message, wParam, lParam); +#endif + switch (message) + { + case WM_KEYDOWN: + case WM_SYSKEYDOWN: + switch(wParam) + { + case VK_SHIFT: + mods |= MOD_SHIFT; + break; + case VK_CONTROL: + mods |= MOD_CONTROL; + break; + case VK_MENU: + mods |= MOD_META; + break; + default: + /* Handle those keys that TranslateMessage won't generate a WM_CHAR for */ + { + Lisp_Object keysym; + if (!NILP (keysym = w32_key_to_emacs_keysym(wParam))) + { + EnterCriticalSection (&w32_dispatch_crit); + emacs_event = Fmake_event (Qnil, Qnil); + event = XEVENT(emacs_event); + + event->channel = w32_find_console(hwnd); + event->timestamp = msg.time; + event->event_type = key_press_event; + event->event.key.keysym = keysym; + event->event.key.modifiers = mods; + w32_enqueue_dispatch_event (emacs_event); + LeaveCriticalSection (&w32_dispatch_crit); + return (0); + } + } + } + TranslateMessage (&msg); /* Maybe generates WM_[SYS]CHAR in message queue */ + goto defproc; + + case WM_KEYUP: + case WM_SYSKEYUP: + switch(wParam) + { + case VK_SHIFT: + mods &= ~MOD_SHIFT; + break; + case VK_CONTROL: + mods &= ~MOD_CONTROL; + break; + case VK_MENU: + mods &= ~MOD_META; + break; + } + TranslateMessage (&msg); + goto defproc; + + case WM_CHAR: + case WM_SYSCHAR: + { + EnterCriticalSection (&w32_dispatch_crit); + emacs_event = Fmake_event (Qnil, Qnil); + event = XEVENT(emacs_event); + + event->channel = w32_find_console(hwnd); + event->timestamp = msg.time; + event->event_type = key_press_event; + event->event.key.modifiers = mods; + event->event.key.modifiers = lParam & 0x20000000 ? MOD_META : 0; /* redundant? */ + if (wParam<' ') /* Control char not handled under WM_KEYDOWN */ + { + event->event.key.keysym = make_char(wParam+'@'); + event->event.key.modifiers |= MOD_CONTROL; /* redundant? */ + } + else + { + /* Assumes that emacs keysym == ASCII code */ + event->event.key.keysym = make_char(wParam); + } + w32_enqueue_dispatch_event (emacs_event); + LeaveCriticalSection (&w32_dispatch_crit); + } + break; + + case WM_LBUTTONDOWN: + case WM_MBUTTONDOWN: + case WM_RBUTTONDOWN: + case WM_LBUTTONUP: + case WM_MBUTTONUP: + case WM_RBUTTONUP: + { + /* XXX FIXME: Do middle button emulation */ + EnterCriticalSection (&w32_dispatch_crit); + emacs_event = Fmake_event (Qnil, Qnil); + event = XEVENT(emacs_event); + + event->channel = w32_find_frame(hwnd); + event->timestamp = msg.time; + event->event_type = + (message==WM_LBUTTONDOWN || message==WM_MBUTTONDOWN || + message==WM_RBUTTONDOWN) ? + button_press_event : button_release_event; +#if 0 + ((wParam & MK_CONTROL) ? MOD_CONTROL : 0) | + ((wParam & MK_SHIFT) ? MOD_SHIFT : 0); +#endif + event->event.button.button = + (message==WM_LBUTTONDOWN || message==WM_LBUTTONUP) ? 1 : + ((message==WM_RBUTTONDOWN || message==WM_RBUTTONUP) ? 3 : 2); + event->event.button.x = LOWORD(lParam); + event->event.button.y = HIWORD(lParam); + event->event.button.modifiers = mods; + + w32_enqueue_dispatch_event (emacs_event); + LeaveCriticalSection (&w32_dispatch_crit); + } + break; + + case WM_MOUSEMOVE: + { + EnterCriticalSection (&w32_dispatch_crit); + emacs_event = Fmake_event (Qnil, Qnil); + event = XEVENT(emacs_event); + + event->channel = w32_find_frame(hwnd); + event->timestamp = msg.time; + event->event_type = pointer_motion_event; + event->event.motion.x = LOWORD(lParam); + event->event.motion.y = HIWORD(lParam); + event->event.motion.modifiers = mods; + + w32_enqueue_dispatch_event (emacs_event); + LeaveCriticalSection (&w32_dispatch_crit); + } + break; + + case WM_PAINT: + if (GetUpdateRect(hwnd, NULL, FALSE)) + { + PAINTSTRUCT paintStruct; + + EnterCriticalSection (&w32_dispatch_crit); + emacs_event = Fmake_event (Qnil, Qnil); + event = XEVENT(emacs_event); + + event->channel = w32_find_frame(hwnd); + event->timestamp = msg.time; + event->event_type = magic_event; + BeginPaint (hwnd, &paintStruct); + EVENT_W32_MAGIC_TYPE(event) = message; + EVENT_W32_MAGIC_DATA(event) = paintStruct.rcPaint; + EndPaint (hwnd, &paintStruct); + + w32_enqueue_dispatch_event (emacs_event); + LeaveCriticalSection (&w32_dispatch_crit); + } + break; + + case WM_SIZE: + /* We only care about this message if our size has really changed */ + if (wParam==SIZE_RESTORED || wParam==SIZE_MAXIMIZED || wParam==SIZE_MINIMIZED) + { + RECT rect; + EnterCriticalSection (&w32_dispatch_crit); + emacs_event = Fmake_event (Qnil, Qnil); + event = XEVENT(emacs_event); + + event->channel = w32_find_frame(hwnd); + event->timestamp = msg.time; + event->event_type = magic_event; + if (wParam==SIZE_MINIMIZED) + rect.left = rect.top = rect.right = rect.bottom = -1; + else + GetClientRect(hwnd, &rect); + EVENT_W32_MAGIC_TYPE(event) = message; + EVENT_W32_MAGIC_DATA(event) = rect; + + w32_enqueue_dispatch_event (emacs_event); + LeaveCriticalSection (&w32_dispatch_crit); + } + break; + + case WM_SETFOCUS: + case WM_KILLFOCUS: + { + EnterCriticalSection (&w32_dispatch_crit); + emacs_event = Fmake_event (Qnil, Qnil); + event = XEVENT(emacs_event); + + event->channel = w32_find_frame(hwnd); + event->timestamp = msg.time; + event->event_type = magic_event; + EVENT_W32_MAGIC_TYPE(event) = message; + + w32_enqueue_dispatch_event (emacs_event); + LeaveCriticalSection (&w32_dispatch_crit); + } + break; + + case WM_QUIT: + /* XXX FIXME: Should do something here! */ + defproc: + default: + return DefWindowProc (hwnd, message, wParam, lParam); + } + return (0); +} + + +/* + * Make a request to the message-processing thread to do things that + * can't be done in the main thread. + */ +LPARAM +w32_make_request(UINT message, WPARAM wParam, w32_request_type *request) +{ + MSG msg; + assert(PostThreadMessage (w32_win_thread_id, message, wParam, + (LPARAM) request)); + GetMessage (&msg, NULL, WM_XEMACS_ACK, WM_XEMACS_ACK); + return (msg.lParam); +} + + +/* + * Handle a request from the main thread to do things that have to be + * done in the message-processing thread. + */ +static void +w32_handle_request (MSG *msg) +{ + w32_request_type *request = (w32_request_type *) msg->lParam; + + switch (msg->message) + { + case WM_XEMACS_CREATEWINDOW: + { + struct frame *f = request->thing1; + Lisp_Object *props = request->thing2; + Lisp_Object name, height, width, popup, top, left; + RECT rect; + DWORD style; + HWND hwnd; + + name = Fplist_get (*props, Qname, Qnil); + height = Fplist_get (*props, Qheight, Qnil); + width = Fplist_get (*props, Qwidth, Qnil); + popup = Fplist_get (*props, Qpopup, Qnil); + top = Fplist_get (*props, Qtop, Qnil); + left = Fplist_get (*props, Qleft, Qnil); + + style = (NILP(popup)) ? W32_FRAME_STYLE : W32_POPUP_STYLE; + + rect.left = rect.top = 0; + rect.right = INTP(width) ? XINT(width) : 640; + rect.bottom = INTP(height) ? XINT(height) : 480; +#ifdef HAVE_MENUBARS + AdjustWindowRect(&rect, style, TRUE); +#else + AdjustWindowRect(&rect, style, FALSE); +#endif + + hwnd = CreateWindow (XEMACS_CLASS, + STRINGP(f->name) ? XSTRING_DATA(f->name) : + (STRINGP(name) ? XSTRING_DATA(name) : XEMACS_CLASS), + style, + INTP(left) ? XINT(left) : CW_USEDEFAULT, + INTP(top) ? XINT(top) : CW_USEDEFAULT, + rect.right-rect.left, rect.bottom-rect.top, + NULL, NULL, NULL, NULL); + assert(PostThreadMessage (w32_main_thread_id, WM_XEMACS_ACK, 0, (LPARAM) hwnd)); + } + return; + + case WM_XEMACS_SETTIMER: + { + UINT id; + id=SetTimer (NULL, 0, (UINT) request->thing1, NULL); + assert(PostThreadMessage (w32_main_thread_id, WM_XEMACS_ACK, 0, id)); + } + break; + + case WM_XEMACS_KILLTIMER: + { + KillTimer (NULL, (UINT) request->thing1); + assert(PostThreadMessage (w32_main_thread_id, WM_XEMACS_ACK, 0, 0)); + } + break; + + default: + assert(0); + } +} + + +/* + * Translate a win32 virtual key to a keysym. + * Only returns non-Qnil for keys that don't generate WM_CHAR messages + * or whose ASCII codes (like space) xemacs doesn't like. + * Virtual key values are defined in winresrc.h + * XXX I'm not sure that KEYSYM("name") is the best thing to use here. + */ +Lisp_Object w32_key_to_emacs_keysym(int w32_key) +{ + switch (w32_key) + { + /* First the predefined ones */ + case VK_BACK: return QKbackspace; + case VK_TAB: return QKtab; + case '\n': return QKlinefeed; /* No VK_LINEFEED in winresrc.h */ + case VK_RETURN: return QKreturn; + case VK_ESCAPE: return QKescape; + case VK_SPACE: return QKspace; + case VK_DELETE: return QKdelete; + + /* The rest */ + case VK_PRIOR: return KEYSYM ("prior"); + case VK_NEXT: return KEYSYM ("next"); + case VK_END: return KEYSYM ("end"); + case VK_HOME: return KEYSYM ("home"); + case VK_LEFT: return KEYSYM ("left"); + case VK_UP: return KEYSYM ("up"); + case VK_RIGHT: return KEYSYM ("right"); + case VK_DOWN: return KEYSYM ("down"); + case VK_INSERT: return KEYSYM ("insert"); + case VK_HELP: return KEYSYM ("help"); + case VK_F1: return KEYSYM ("F1"); + case VK_F2: return KEYSYM ("F2"); + case VK_F3: return KEYSYM ("F3"); + case VK_F4: return KEYSYM ("F4"); + case VK_F5: return KEYSYM ("F5"); + case VK_F6: return KEYSYM ("F6"); + case VK_F7: return KEYSYM ("F7"); + case VK_F8: return KEYSYM ("F8"); + case VK_F9: return KEYSYM ("F9"); + case VK_F10: return KEYSYM ("F10"); + case VK_F11: return KEYSYM ("F11"); + case VK_F12: return KEYSYM ("F12"); + case VK_F13: return KEYSYM ("F13"); + case VK_F14: return KEYSYM ("F14"); + case VK_F15: return KEYSYM ("F15"); + case VK_F16: return KEYSYM ("F16"); + case VK_F17: return KEYSYM ("F17"); + case VK_F18: return KEYSYM ("F18"); + case VK_F19: return KEYSYM ("F19"); + case VK_F20: return KEYSYM ("F20"); + case VK_F21: return KEYSYM ("F21"); + case VK_F22: return KEYSYM ("F22"); + case VK_F23: return KEYSYM ("F23"); + case VK_F24: return KEYSYM ("F24"); + } + return Qnil; +} + + +/* + * Find the console that matches the supplied win32 window handle + */ +static Lisp_Object +w32_find_console (HWND hwnd) +{ + Lisp_Object concons; + + CONSOLE_LOOP (concons) + { + Lisp_Object console = XCAR (concons); + /* We only support one console so this must be it */ + return console; + } + + return Qnil; +} + +/* + * Find the frame that matches the supplied win32 window handle + */ +static Lisp_Object +w32_find_frame (HWND hwnd) +{ + Lisp_Object frmcons, devcons, concons; + + FRAME_LOOP_NO_BREAK (frmcons, devcons, concons) + { + struct frame *f; + Lisp_Object frame = XCAR (frmcons); + f = XFRAME (frame); + if (FRAME_TYPE_P(f, w32)) /* Might be a stream-type frame */ + if (FRAME_W32_HANDLE(f)==hwnd) + return frame; + } + assert(0); /* XXX Can't happen! we only get messages for our windows */ + return Qnil; +} + +/* + * Random helper functions for debugging. + * Intended for use in the MSVC "Watch" window which doesn't like + * the aborts that the error_check_foo() functions can make. + */ +struct lrecord_header *DHEADER(Lisp_Object obj) +{ + return LRECORDP(obj) ? XRECORD_LHEADER(obj) : NULL; + /* (lrecord_header*)(obj & 0xfffffff) */ +} + +struct Lisp_Event *DEVENT(Lisp_Object obj) +{ + return (EVENTP (obj)) ? XEVENT(obj) : NULL; +} + +struct Lisp_Cons *DCONS(Lisp_Object obj) +{ + return (CONSP (obj)) ? XCONS(obj) : NULL; +} + +Lisp_Object DCAR(Lisp_Object obj) +{ + return (CONSP (obj)) ? XCAR(obj) : 0; +} + +Lisp_Object DCDR(Lisp_Object obj) +{ + return (CONSP (obj)) ? XCDR(obj) : 0; +} + +struct Lisp_String *DSTRING(Lisp_Object obj) +{ + return (STRINGP (obj)) ? XSTRING(obj) : NULL; +} + +struct Lisp_Vector *DVECTOR(Lisp_Object obj) +{ + return (VECTORP (obj)) ? XVECTOR(obj) : NULL; +} + +struct Lisp_Symbol *DSYMBOL(Lisp_Object obj) +{ + return (SYMBOLP (obj)) ? XSYMBOL(obj) : NULL; +} + +char *DSYMNAME(Lisp_Object obj) +{ + return (SYMBOLP (obj)) ? XSYMBOL(obj)->name->_data : NULL; +}
--- a/src/window.c Mon Aug 13 10:03:54 2007 +0200 +++ b/src/window.c Mon Aug 13 10:04:58 2007 +0200 @@ -2929,10 +2929,15 @@ int pixel_adj_left = new_pixsize - old_pixsize; int div_val = old_pixsize << 1; - /* Sometimes we may get called with our old size. In that case - we don't need to do anything. */ - if (!pixel_adj_left) - return; + /* + * Previously we bailed out here if there was no size change. + * But this broke toolbar updates. If a toolbar appears or + * disappears, windows may not change size, but their top and + * left coordinates need to be updated. + * + * if (!pixel_adj_left) + * return; + */ last_pos = first = (set_height ? WINDOW_TOP (w) : WINDOW_LEFT (w)); last_old_pos = 0;
--- a/version.sh Mon Aug 13 10:03:54 2007 +0200 +++ b/version.sh Mon Aug 13 10:04:58 2007 +0200 @@ -1,5 +1,5 @@ #!/bin/sh emacs_major_version=20 emacs_minor_version=4 -emacs_beta_version=2 -xemacs_codename="Alpine" +emacs_beta_version=3 +xemacs_codename="Altai Mountain"
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/w32/ChangeLog Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,94 @@ +Wed November 05 23:40:00 1997 <jhar@tardis.ed.ac.uk> + + * faces.el: init-other-random-faces + Reinstated code that uses (mono x) as a specifer tag, but + conditioned it on (featurep 'x) because x is not a valid + specifier tag under native-win32. + + * fileio.c: insert-file-contents-internal + Added a bodge to do CRLF->LF conversion of text files, + conditioned on DOS_NT. This is currently only one-way, so all + text files written by XEmacs will be UNIXified. CRLF conversion + is required to make bytecompile work. + + * w32/xemacs.mak: moved building the DOC file to after the .elcs. + + * Added file headers to: + w32-faces.el, w32-init.el, console-w32.c, console-w32.h, + device-w32.c, event-w32.c, event-w32.h, frame-w32.c, + objects-w32.c, objects-w32.h, redisplay-w32.c, w32-proc.c + + +Sun November 01 12:00:00 1997 <jhar@tardis.ed.ac.uk> + + * make-docfile.el: Fixed typo when dumped file does not exist. + + * redisplay-x.c: x_output_vertical_divider: + If HAVE_SCROLLBARS was not defined, coordinate of the right of + the divider was being used unitialised. + + * device.el: make-w32-device added. + + * dumped-lisp: added w32-faces and w32-init to list. + + * faces.el: + - make-face-*: Added calls to appropriate w32 functions + conditioned on (featurep 'w32). Made existing X calls + conditioned on (featurep 'x). + - init-other-random-faces: Hacked out a piece of code which used + (mono x) as a specifier because it made w32 unhappy. + + * console.h: Added Qw32 and CONSOLE_W32* macros, conditioned on + HAVE_W32GUI. + + * emacs.c: Added calls to the following, conditioned on HAVE_W32GUI: + syms_of_*_w32, vars_of_*_w32, console_type_create_*w32. + + * event-stream.c: Conditioned on HAVE_W32GUI: + - vars_of_event_stream calls vars_of_event_w32. + - init_event_stream calls init_event_w32_late. + + * events-mod.h: Removed comment about having alternative making + MOD_* constants for different windowing systems. + + * events.c: Conditioned on HAVE_W32GUI: + - event-equal: Added case for w32 magic events. + - event-hash: Added case for w32 magic events. + + * events.h: Conditioned on HAVE_W32GUI: + Added struct underlying_w32_event to magic_data. + + * faces.c: complex_vars_of_faces + Added fallbacks for w32 faces, conditioned on HAVE_W32GUI. + + * frame.c: set-frame-properties + Added reference to default-w32-frame-plist to docstring. + + * general.c: Added new Lisp_Object Qw32 and defsymbol. + + * redisplay-output.c: redisplay_update_line + Conditioned reference to stupid_vertical_scrollbar_drag_hack on + HAVE_X_WINDOWS. This will need a proper fix when w32 gets + scrollbars. + + * redisplay-tty.c: init_tty_for_redisplay + Conditioned blocking and unblocking of SIGTTOU on !WIN32 because + these signals don't exist under win32. + + * redisplay.c: init_redisplay + Initialise window system to w32, conditioned on HAVE_W32GUI. + + * symsinit.h: Added syms_of_*_w32, vars_of_*_w32 and + init_event_w32_late. + + * sysdep.c: Conditioned various things on WIN32 in addition to + MSDOS. + + * New files: + w32-faces.el, w32-init.el, console-w32.c, console-w32.h, + device-w32.c, event-w32.c, event-w32.h, frame-w32.c, + objects-w32.c, objects-w32.h, redisplay-w32.c, w32-proc.c + + * Files split from nt to new w32 directory: + ChangeLog, README, Todo, paths.h, config.h, inc/*, runemacs.c, + xemacs.mak.
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/w32/README Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,56 @@ + Building and Installing XEmacs on Windows NT + + David Hobley + Marc Paquette + Jonathan Harris + +Currently XEmacs for win32 is in an early stage of development. + +The port was made much easier by the groundbreaking work of Geoff Voelker +and others who worked on the GNU Emacs port to NT. Their version is available +from http://www.cs.washington.edu/homes/voelker/ntemacs.html + +(jhar) I split the native-win32 build directory off from the nt build +directory. This is probably(?) a bad thing and I intend to try to merge the +w32 changes back in. + +To get it working you will need: + +1. You will need Visual C++ V4.2 or later to compile everything. Personally we + have tested V4.2 and V5.0. +2. Grab the latest XEmacs beta from ftp.xemacs.org if necessary. All + native-win32 support is in the w32/ subdirectory. +3. Edit the xemacs.mak file and ensure variables point to the correct place. + Note that Visual C++ assumes a couple of environment variables INCLUDE and + LIB to be set which specify the location of the includes and libraries. +4. Copy the files config.h and paths.h from w32/ to src/. + "nmake -f xemacs.mak distclean" will delete these files, so always edit + them in the w32 direvctory and copy them over. +5. "nmake -f xemacs.mak" Build temacs.exe. + "nmake -f xemacs.mak dump-elcs" Update the .elc files. + "nmake -f xemacs.mak dump-xemacs" Build xemacs.exe. +6. Ensure your HOME environment variable is set correctly. +7. The build process creates debugging and "Source Browser" information for + use with MS DevStudio. To use this create a new "console" project and set + the Project/Settings/Debug executable name to the full path of + src\xemacs.exe. Remember to close the Source Browser file in DevStudio + before rebuilding. +8. If you're going to edit sources I recommend that you first get a copy of + makedepend and make a list of dependencies in the makefile by doing + "nmake -f xemacs.mak depend". I (jhar) have a hacked-up copy of X11R5 + makedepend which I can distribute if anyone wants it. Is there a real + version anywhere which handles '\' as the path delimiter? + + +Known Problems: +Please look at the TODO list for the current list of problems and people +working on them. + +David Hobley david_hobley@optusvision.com.au -- work email. + davidh@wr.com.au -- home account. + +Marc Paquette marcpa@cam.org -- home account. + +August Hill awhill@inlink.com + +Jonathan Harris jhar@tardis.ed.ac.uk
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/w32/Todo Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,24 @@ +Known Bugs +---------- +1. Mouse drags can cause aborts. I think this is because the timeout + implementation is broken and can cause the same timeout to go + off twice (especially during mouse drags?), which makes XEmacs abort. + Windows95 doesn't appear to provide any one-shot timers (NT does). +2. Saving text files doesn't translate LFs back to CRLFs. +3. XEmacs starts-up with an error or errors. + + +ToDo +---- +1. w32-make-font-foo in w32/w32-faces.el need to be written. +2. Calling mouse_[enter|leave]_frame_hook. +3. CRLF text file handling. +4. Subprocess and socket support. +5. Eliminate resizing funnies +6. Scrollbar +7. Menubar +8. Larger color database. Palette handling +9. Middle mouse button emulation. Dragging off-frame. +10. Images +11. Toolbar +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/w32/config.h Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,671 @@ +/* XEmacs site configuration template file. -*- C -*- + Copyright (C) 1986, 1991, 1992, 1993, 1994 Free Software Foundation, Inc. + +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 (more or less). */ + +/* No code in XEmacs #includes config.h twice, but some of the code + intended to work with other packages as well (like gmalloc.c) + think they can include it as many times as they like. */ +#ifndef _CONFIG_H_ +#define _CONFIG_H_ + +/* #### This will be removed in 19.15. */ +#define LOSING_BYTECODE + +#define NTHEAP_PROBE_BASE 1 + +/* These are all defined in the top-level Makefile by configure. + They're here only for reference. */ + +/* Define LISP_FLOAT_TYPE if you want XEmacs to support floating-point + numbers. */ +#undef LISP_FLOAT_TYPE + +/* Define GNU_MALLOC if you want to use the *new* GNU memory allocator. */ +#define GNU_MALLOC + +/* Define USE_SYSTEM_MALLOC if you forcing the use of it. */ +#undef USE_SYSTEM_MALLOC + +/* Define HAVE_TTY if you want TTY support compiled in. */ +#undef HAVE_TTY + +/* Define HAVE_X_WINDOWS if you want to use the X window system. */ +#undef HAVE_X_WINDOWS /* XXX Jon */ + +/* Define HAVE_NEXTSTEP if you want to use the NeXTstep window system. */ +#undef HAVE_NEXTSTEP + +/* Define HAVE_W32 if you want to use the MS win32 GUI. */ +#define HAVE_W32GUI + +/* Define HAVE_WINDOW_SYSTEM if any windowing system is available. */ +#if defined (HAVE_X_WINDOWS) || defined (HAVE_NEXTSTEP) || defined (HAVE_W32GUI) +#define HAVE_WINDOW_SYSTEM +#endif + +/* Define HAVE_UNIXOID_EVENT_LOOP if we use select() to wait for events. */ +#if defined (HAVE_X_WINDOWS) || defined (HAVE_TTY) || defined (HAVE_W32GUI) +#define HAVE_UNIXOID_EVENT_LOOP +#endif + +/* Define this if you're using XFree386. */ +#undef HAVE_XFREE386 + +#undef THIS_IS_X11R4 +#undef THIS_IS_X11R5 +#undef THIS_IS_X11R6 /* XXX Jon */ + +/* Define USER_FULL_NAME to return a string + that is the user's full name. + It can assume that the variable `pw' + points to the password file entry for this user. + + At some sites, the pw_gecos field contains + the user's full name. If neither this nor any other + field contains the right thing, use pw_name, + giving the user's login name, since that is better than nothing. */ +#define USER_FULL_NAME pw->pw_gecos +#if 0 +#define USER_FULL_NAME unknown +#endif + +/* Define AMPERSAND_FULL_NAME if you use the convention + that & in the full name stands for the login id. */ +#undef AMPERSAND_FULL_NAME + +/* Some things figured out by the configure script, grouped as they are in + configure.in. */ +#undef HAVE_MACH_MACH_H +#undef HAVE_SYS_STROPTS_H +#undef HAVE_SYS_TIMEB_H +#undef HAVE_UNISTD_H +#undef HAVE_UTIME_H +#undef HAVE_SYS_WAIT_H +#undef HAVE_LIBGEN_H +#undef HAVE_LINUX_VERSION_H +#undef WORDS_BIGENDIAN +#undef TIME_WITH_SYS_TIME + +#define HAVE_SYS_TIME_H +#define HAVE_LOCALE_H +#undef HAVE_X11_LOCALE_H /* XXX Jon */ +#define STDC_HEADERS +#define HAVE_LIMITS_H +#define HAVE_GETCWD + +#define HAVE_LONG_FILE_NAMES + +#ifdef HAVE_LONG_FILE_NAMES +#define CLASH_DETECTION +#endif + +#undef HAVE_LIBDNET +#undef HAVE_LIBRESOLV + +/* Define if `sys_siglist' is declared by <signal.h>. */ +#undef SYS_SIGLIST_DECLARED + +/* Define if `struct utimbuf' is declared by <utime.h>. */ +#undef HAVE_STRUCT_UTIMBUF + +/* Define if `struct timeval' is declared by <sys/time.h>. */ +#define HAVE_TIMEVAL + + +#undef TM_IN_SYS_TIME +#undef HAVE_TM_ZONE +#undef HAVE_TZNAME + +/* Define if netdb.h declares h_errno. */ +#undef HAVE_H_ERRNO + +/* Define if localtime caches TZ */ +#undef LOCALTIME_CACHE + +/* Define if gettimeofday can't accept two arguments */ +#ifdef HAVE_X_WINDOWS +#define GETTIMEOFDAY_ONE_ARGUMENT +#else +#undef GETTIMEOFDAY_ONE_ARGUMENT +#endif + +/* Define in keyword `inline' exists. */ +#undef HAVE_INLINE + +#undef HAVE_ALLOCA_H +#undef HAVE_VFORK_H +#undef vfork + +#undef HAVE_MMAP +#undef HAVE_STRCOLL + +#undef SIZEOF_SHORT +#undef SIZEOF_INT +#undef SIZEOF_LONG + +#undef HAVE_ACOSH +#undef HAVE_ASINH +#undef HAVE_ATANH + +#if defined (HAVE_ACOSH) && defined (HAVE_ASINH) && defined (HAVE_ATANH) +#define HAVE_INVERSE_HYPERBOLIC +#endif + +#undef HAVE_CBRT +#define HAVE_CLOSEDIR +#undef HAVE_DUP2 +#undef HAVE_EACCESS +#undef HAVE_FMOD +#undef HAVE_FPATHCONF +#undef HAVE_FREXP +#undef HAVE_FTIME +#undef HAVE_GETHOSTNAME +#undef HAVE_GETPAGESIZE +#define HAVE_GETTIMEOFDAY +#define HAVE_GETWD +#undef HAVE_LOGB +#undef HAVE_LRAND48 +#undef HAVE_MATHERR +#undef HAVE_MKDIR +#undef HAVE_MKTIME +#undef HAVE_PERROR +#undef HAVE_POLL +#undef HAVE_RANDOM +#undef HAVE_REALPATH +#undef HAVE_RENAME +#undef HAVE_RES_INIT +#undef HAVE_RINT +#undef HAVE_RMDIR +#define HAVE_SELECT +#undef HAVE_SETITIMER +#undef HAVE_SETPGID +#undef HAVE_SETSID +#undef HAVE_SIGBLOCK +#undef HAVE_SIGHOLD +#undef HAVE_SIGPROCMASK +#undef HAVE_SIGSETJMP +#undef HAVE_STRCASECMP +#define HAVE_STRERROR +#undef HAVE_TZSET +#undef HAVE_UTIMES +#undef HAVE_WAITPID + +#define HAVE_SOCKETS +#undef HAVE_SOCKADDR_SUN_LEN +#undef HAVE_SYSVIPC + +#undef SYSV_SYSTEM_DIR +#undef NONSYSTEM_DIR_LIBRARY + +#undef HAVE_TERMIOS +#undef HAVE_TERMIO + +#undef NLIST_STRUCT + +#undef UNEXEC_SRC +#undef AIX_SMT_EXP + +/* Define HAVE_SOCKS if you have the `socks' library and want XEmacs to + use it. */ +#undef HAVE_SOCKS + +/* Define HAVE_TERM if you run the `term' program (e.g. under Linux) and + want XEmacs to use it. */ +#undef HAVE_TERM + +/* Define HAVE_XPM if you have the `xpm' library and want XEmacs to use it. */ +#undef HAVE_XPM + +/* Define HAVE_XFACE if you have the `compface' library and want to use it. + This will permit X-face pixmaps in mail and news messages to display + quickly. */ +#undef HAVE_XFACE + +/* Define HAVE_GIF if you want XEmacs to support converting GIF + (Graphics Interchange Format) images. */ +#undef HAVE_GIF + +/* Define HAVE_JPEG if you have the JPEG library and want XEmacs to use it. + This is for converting JPEG images. */ +#undef HAVE_JPEG + +/* Define HAVE_PNG if you have the PNG library and want XEmacs to use it. + This is for converting PNG images. */ +#undef HAVE_PNG + +/* Define HAVE_PNG_GNUZ if you want to use -lgz instead of -lz for PNG. */ +#undef HAVE_PNG_GNUZ + +/* Define HAVE_TIFF if you have the TIFF library and want XEmacs to use it. + This is for converting TIFF images. */ +#undef HAVE_TIFF + +/* Define HAVE_XMU if you have the Xmu library. This should always be + the case except on losing HPUX systems. */ +#undef HAVE_XMU /* XXX Jon */ + +/* Define HAVE_DBM if you want to use the DBM libraries */ +#undef HAVE_DBM + +/* Define HAVE_GNU_DBM if you want to use the GNU DBM libraries; + if you define this, you should also define HAVE_DBM */ +#undef HAVE_GNU_DBM + +/* Define HAVE_BERKELEY_DB if you want to use the BerkDB libraries */ +#undef HAVE_BERKELEY_DB + +/* Define HAVE_LIBGDBM if you have -lgdbm (separated from HAVE_DBM + stuff because FreeBSD has the DBM routines in libc) */ +#undef HAVE_LIBGDBM + +/* Define HAVE_LIBDBM if you have -ldbm */ +#undef HAVE_LIBDBM + +/* Define HAVE_LIBDB if you have -ldb */ +#undef HAVE_LIBDB + +#if defined (HAVE_DBM) || defined (HAVE_BERKELEY_DB) +# define HAVE_DATABASE +#endif + +/* Define HAVE_XAUTH if the Xauth library is present. This will add + some extra functionality to gnuserv. */ +#undef HAVE_XAUTH + +/* Define HAVE_XLOCALE_H if X11/Xlocale.h is present. */ +#undef HAVE_XLOCALE_H /* XXX Jon */ + +/* Define HAVE_NCURSES if -lncurses is present. */ +#undef HAVE_NCURSES + +/* Define HAVE_NCURSES_CURSES_H if ncurses/curses.h is present. */ +#undef HAVE_NCURSES_CURSES_H + +/* Define HAVE_NCURSES_TERM_H if ncurses/term.h is present. */ +#undef HAVE_NCURSES_TERM_H + +/* Define EPOCH to include extra functionality that was present in Epoch. + This code has received only limited testing. */ +#undef EPOCH + +#define LOWTAGS + +/* Define USE_ASSERTIONS if you want the abort() to be changed to assert() + If the assertion fails, assert_failed() will be called. This is + recommended for general use because it gives more info about the crash + than just the abort() message. Too many people "Can't find the corefile" + or have limited core dumps out of existence. */ +#define USE_ASSERTIONS + +/* Define one or more of the following if you want lots of extra checks + (e.g. structure validation) compiled in. These should be turned + on during the beta-test cycle. */ + +/* Check the entire extent structure of a buffer each time an extent + change is done, and do other extent-related checks. */ +#define ERROR_CHECK_EXTENTS +/* Make sure that all X... macros are dereferencing the correct type, + and that all XSET... macros (as much as possible) are setting the + correct type of structure. Highly recommended for all + development work. */ +#define ERROR_CHECK_TYPECHECK +/* Make sure valid buffer positions are passed to BUF_* macros. */ +#define ERROR_CHECK_BUFPOS +/* Attempt to catch bugs related to garbage collection (e.g. + insufficient GCPRO'ing). */ +#define ERROR_CHECK_GC +/* Attempt to catch freeing of a non-malloc()ed block, heap corruption, + etc. */ +#define ERROR_CHECK_MALLOC + +/* Define DEBUG_XEMACS if you want extra debugging code compiled in. + This is mainly intended for use by developers. */ +#define DEBUG_XEMACS 1 + +/* Define MEMORY_USAGE_STATS if you want extra code compiled in to + determine where XEmacs's memory is going. */ +#undef MEMORY_USAGE_STATS + +/* Define QUANTIFY if using Quantify from Pure Software. This adds + some additional calls to control data collection. This is only + intended for use by the developers. */ +#undef QUANTIFY + +/* Define EXTERNAL_WIDGET to compile support for using the editor as a + widget in another program. */ +#undef EXTERNAL_WIDGET + +/* There are some special-case defines for gcc and lcc. */ +#undef USE_GCC +#undef USE_LCC + +/* Allow the user to override the default value of PURESIZE at configure + time. This must come before we include the sys files in order for + it to be able to override any changes in them. */ +#undef PURESIZE + + +/* Define this if you want to use the Common Desktop Environment +*/ +#undef HAVE_CDE + +/* Define this if you want Mule support (multi-byte character support). + There may be some performance penalty, although it should be small + if you're working with ASCII files. */ +#undef MULE /* XXX Jon */ + +/* Do we want to use X window input methods for use with Mule? (requires X11R5) + If so, use raw Xlib or higher level Motif interface? */ +#undef HAVE_XIM /* XXX Jon */ +#undef XIM_XLIB /* XXX Jon */ +#undef XIM_MOTIF + +/* Non-XIM input methods for use with Mule. */ +#undef HAVE_CANNA +#undef HAVE_WNN +#undef WNN6 + +/* enable special GNU Make features in the Makefiles. */ +#undef USE_GNU_MAKE + +/* Undocumented debugging option: Don't automatically rebuild the DOC + file. This saves a lot of time when you're repeatedly + compiling-running-crashing. */ +#undef NO_DOC_FILE + + /* To eliminate use of `const' in the XEmacs sources, + do `#define CONST_IS_LOSING' */ +#define CONST_IS_LOSING + +# undef CONST +# ifdef CONST_IS_LOSING +# define CONST +# else +# define CONST const +# endif /* CONST */ + +/* If not defined, use unions instead of ints. A few systems (DEC Alpha) + seem to require this, probably because something with the int + definitions isn't right with 64-bit systems. + + (It's NO_UNION_TYPE instead of USE_UNION_TYPE for historical reasons.) +*/ +#undef NO_UNION_TYPE + +/* The configuration script defines opsysfile to be the name of the + s/...h file that describes the system type you are using. The file + is chosen based on the configuration name you give. + + See the file ../etc/MACHINES for a list of systems and the + configuration names to use for them. + + See s/template.h for documentation on writing s/...h files. */ +#include "s/windowsnt.h" + +/* The configuration script defines machfile to be the name of the + m/...h file that describes the machine you are using. The file is + chosen based on the configuration name you give. + + See the file ../etc/MACHINES for a list of machines and the + configuration names to use for them. + + See m/template.h for documentation on writing m/...h files. */ +#include "m/windowsnt.h" + +#if defined (USE_SYSTEM_MALLOC) && !defined (SYSTEM_MALLOC) +#define SYSTEM_MALLOC +#endif + +/* The configuration name. This is used as the install directory name + for the lib-src programs. */ +#undef EMACS_CONFIGURATION + +/* Define REL_ALLOC if you want to use the relocating allocator for + buffer space. */ +#undef REL_ALLOC + +/* Define LD_SWITCH_SITE to contain any special flags your loader may need. */ +#undef LD_SWITCH_SITE + +/* Define C_SWITCH_SITE to contain any special flags your compiler needs. */ +#undef C_SWITCH_SITE + +/* Define LD_SWITCH_X_SITE to contain any special flags your loader + may need to deal with X Windows. For instance, if you've defined + HAVE_X_WINDOWS above and your X libraries aren't in a place that + your loader can find on its own, you might want to add "-L/..." or + something similar. */ +#undef LD_SWITCH_X_SITE + +/* Define LD_SWITCH_X_SITE_AUX with an -R option + in case it's needed (for Solaris, for example). */ +#undef LD_SWITCH_X_SITE_AUX + +/* Define C_SWITCH_X_SITE to contain any special flags your compiler + may need to deal with X Windows. For instance, if you've defined + HAVE_X_WINDOWS above and your X include files aren't in a place + that your compiler can find on its own, you might want to add + "-I/..." or something similar. */ +#undef C_SWITCH_X_SITE + +/* Define the return type of signal handlers if the s-xxx file + did not already do so. */ +#define RETSIGTYPE void + +/* SIGTYPE is the macro we actually use. */ +#ifndef SIGTYPE +#define SIGTYPE RETSIGTYPE +#define SIGRETURN return +#endif + +/* Define DYNODUMP if it is necessary to properly dump on this system. + Currently this is only Solaris. */ +#undef DYNODUMP + +/* Define NEED_XILDOFF if the -xildoff flag must be passed to cc to + avoid invoking the incremental linker ild which is incompatible + with dynodump. This is needed for recent Sunsoft compilers. */ +#undef NEED_XILDOFF + +/* Define ENERGIZE to compile with support for the Energize Programming System. + If you do this, don't forget to define ENERGIZE in lwlib/Imakefile as well. + You will need to set your C_SWITCH_SITE and LD_SWITCH_SITE to point at the + Energize connection library (libconn.a) and associated header files. + */ +#undef ENERGIZE +#undef ENERGIZE_2 +#undef ENERGIZE_3 + +/* Define SUNPRO to compiled in support for Sun Sparcworks. */ +#undef SUNPRO + +/* Sun SparcStations, SGI machines, and HP9000s700s have support for playing + different sound files as beeps. If you are on a SparcStation but do not + have the sound option installed for some reason, then undefine + HAVE_NATIVE_SOUND. (It's usually found in /usr/demo/SOUND/ on SunOS 4 + and Solaris systems; on Solaris, you may need to install the "SUNWaudmo" + package.) + */ +#undef HAVE_NATIVE_SOUND + +/* If you wish to compile with support for the Network Audio System + system define HAVE_NAS_SOUND. + NAS_NO_ERROR_JUMP means that the NAS libraries don't inlcude some + error handling changes. + */ +#undef HAVE_NAS_SOUND +#undef NAS_NO_ERROR_JUMP + +/* Compile in support for SunPro usage-tracking code. */ +#undef USAGE_TRACKING + +/* Define TOOLTALK if your site supports the ToolTalk library. */ +#undef TOOLTALK + +#undef LWLIB_USES_MOTIF +#undef LWLIB_MENUBARS_LUCID +#undef LWLIB_MENUBARS_MOTIF +#undef LWLIB_SCROLLBARS_LUCID +#undef LWLIB_SCROLLBARS_MOTIF +#undef LWLIB_SCROLLBARS_ATHENA +#undef LWLIB_DIALOGS_MOTIF +#undef LWLIB_DIALOGS_ATHENA + +/* Other things that can be disabled by configure. */ +#undef HAVE_MENUBARS +#undef HAVE_SCROLLBARS +#undef HAVE_DIALOGS +#undef HAVE_TOOLBARS + + +#if defined (HAVE_MENUBARS) || defined (HAVE_DIALOGS) +#define HAVE_POPUPS +#endif + +/* If you are using SunOS 4.1.1 and X11r5, then you need this patch. + There is a stupid bug in the SunOS libc.a: two functions which X11r5 + uses, mbstowcs() and wcstombs(), are unusable when programs are + statically linked (as XEmacs must be) because the static version of + libc.a contains the *dynamic* versions of these functions. These + functions don't seem to be called when XEmacs is running, so it's + enough to define stubs for them. + + This appears to be fixed in SunOS 4.1.2. + + Also, SunOS 4.1.1 contains buggy versions of strcmp and strcpy that + sometimes reference memory past the end of the string, which can segv. + I don't know whether this is has been fixed as of 4.1.2 or 4.1.3. + */ +#if defined (sparc) && !defined (USG) +#define OBJECTS_SYSTEM sunOS-fix.o strcmp.o strcpy.o +#endif + +/* If you turn this flag on, it forces encapsulation in all +circumstances; this can be used to make sure things compile OK +on various systems. */ +#undef DEBUG_ENCAPSULATION +#define DONT_ENCAPSULATE + +/* basic system calls */ + +#if defined (INTERRUPTIBLE_IO) || defined (DEBUG_ENCAPSULATION) +# define ENCAPSULATE_READ +# define ENCAPSULATE_WRITE +#endif +#if defined (INTERRUPTIBLE_OPEN) || defined (DEBUG_ENCAPSULATION) +# define ENCAPSULATE_OPEN +#endif +#if defined (INTERRUPTIBLE_CLOSE) || defined (DEBUG_ENCAPSULATION) +# define ENCAPSULATE_CLOSE +#endif + +/* stdio calls */ + +#if defined (INTERRUPTIBLE_IO) || defined (DEBUG_ENCAPSULATION) +# define ENCAPSULATE_FREAD +# define ENCAPSULATE_FWRITE +#endif +#if defined (INTERRUPTIBLE_OPEN) || defined (DEBUG_ENCAPSULATION) +# define ENCAPSULATE_FOPEN +#endif +#if defined (INTERRUPTIBLE_CLOSE) || defined (DEBUG_ENCAPSULATION) +# define ENCAPSULATE_FCLOSE +#endif + +/* directory calls */ + +#if defined (DEBUG_ENCAPSULATION) +# define ENCAPSULATE_CHDIR +# define ENCAPSULATE_MKDIR +# define ENCAPSULATE_OPENDIR +# define ENCAPSULATE_READDIR +# define ENCAPSULATE_RMDIR +#endif + +/* file-information calls */ + +#if defined (DEBUG_ENCAPSULATION) +# define ENCAPSULATE_ACCESS +# define ENCAPSULATE_LSTAT +# define ENCAPSULATE_READLINK +# define ENCAPSULATE_STAT +#endif + +/* file-manipulation calls */ + +#if defined (DEBUG_ENCAPSULATION) +# define ENCAPSULATE_CHMOD +# define ENCAPSULATE_CREAT +# define ENCAPSULATE_LINK +# define ENCAPSULATE_RENAME +# define ENCAPSULATE_SYMLINK +# define ENCAPSULATE_UNLINK +#endif + +#if (defined (MSDOS) && defined (FEPCTRL)) || (defined (WIN32) && defined (USE_IME)) +#define HAVE_FEP +#endif + +#if defined (HAVE_SOCKS) && !defined (DO_NOT_SOCKSIFY) +#define accept Raccept +#define bind Rbind +#define connect Rconnect +#define getsockname Rgetsockname +#define listen Rlisten +#endif /* HAVE_SOCKS && !DO_NOT_SOCKSIFY */ + +#ifndef SHORTBITS +#define SHORTBITS (8 * SIZEOF_SHORT) +#endif +#ifndef INTBITS +#define INTBITS (8 * SIZEOF_INT) +#endif +#ifndef LONGBITS +#define LONGBITS (8 * SIZEOF_LONG) +#endif + +#ifdef HAVE_INLINE +# if defined (__GNUC__) +# if defined (DONT_EXTERN_INLINE_FUNCTIONS) +# define INLINE inline +# else +# define INLINE extern inline +# endif +# else +# define INLINE static inline +# endif +#else +# define INLINE static +#endif + +/* We want to avoid saving the signal mask if possible, because + that necessitates a system call. */ +#ifdef HAVE_SIGSETJMP +# define SETJMP(x) sigsetjmp (x, 0) +# define LONGJMP(x, y) siglongjmp (x, y) +# define JMP_BUF sigjmp_buf +#else +# define SETJMP(x) setjmp (x) +# define LONGJMP(x, y) longjmp (x, y) +# define JMP_BUF jmp_buf +#endif + +#endif /* _CONFIG_H_ */
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/w32/inc/arpa/inet.h Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,1 @@ +/* null version of <arpa/inet.h> - <sys/socket.h> has everything */
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/w32/inc/netdb.h Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,1 @@ +/* null version of <netdb.h> - <sys/socket.h> has everything */
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/w32/inc/netinet/in.h Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,1 @@ +/* null version of <netinet/in.h> - <sys/socket.h> has everything */
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/w32/inc/pwd.h Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,18 @@ +#ifndef _PWD_H_ +#define _PWD_H_ +/* + * pwd.h doesn't exist on NT, so we put together our own. + */ + +struct passwd { + char *pw_name; + char *pw_passwd; + int pw_uid; + int pw_gid; + int pw_quota; + char *pw_gecos; + char *pw_dir; + char *pw_shell; +}; + +#endif /* _PWD_H_ */
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/w32/inc/sys/dir.h Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,77 @@ +/* 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. */ + +/* + <dir.h> -- definitions for 4.2BSD-compatible directory access + + last edit: 09-Jul-1983 D A Gwyn +*/ + +#ifdef VMS +#ifndef FAB$C_BID +#include <fab.h> +#endif +#ifndef NAM$C_BID +#include <nam.h> +#endif +#ifndef RMS$_SUC +#include <rmsdef.h> +#endif +#include "vms-dir.h" +#endif /* VMS */ + +#define DIRBLKSIZ 512 /* size of directory block */ +#ifdef VMS +#define MAXNAMLEN (DIR$S_NAME + 7) /* 80 plus room for version #. */ +#define MAXFULLSPEC NAM$C_MAXRSS /* Maximum full spec */ +#else +#ifdef WINDOWSNT +#define MAXNAMLEN 255 +#else /* not WINDOWSNT */ +#define MAXNAMLEN 15 /* maximum filename length */ +#endif /* not WINDOWSNT */ +#endif /* VMS */ + /* NOTE: MAXNAMLEN must be one less than a multiple of 4 */ + +struct direct /* data from readdir() */ + { + long d_ino; /* inode number of entry */ + unsigned short d_reclen; /* length of this record */ + unsigned short d_namlen; /* length of string in d_name */ + char d_name[MAXNAMLEN+1]; /* name of file */ + }; + +typedef struct + { + int dd_fd; /* file descriptor */ + int dd_loc; /* offset in block */ + int dd_size; /* amount of valid data */ + char dd_buf[DIRBLKSIZ]; /* directory block */ + } DIR; /* stream data from opendir() */ + +#ifndef WINDOWSNT +extern DIR *opendir (CONST char *filename); +extern int closedir (DIR *dirp); +extern struct direct *readdir (DIR *dirp); +extern struct direct *readdirver (DIR *dirp); +extern long telldir (DIR *dirp); +extern void seekdir (DIR *dirp, long loc); + +#define rewinddir( dirp ) seekdir( dirp, 0L ) +#endif
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/w32/inc/sys/file.h Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,8 @@ +/* + * sys\file.h doesn't exist on NT - only needed for these constants + */ + +#define F_OK 0 +#define X_OK 1 +#define W_OK 2 +#define R_OK 4
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/w32/inc/sys/ioctl.h Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,5 @@ +/* + * sys\ioctl.h doesn't exist on NT...rather than including it conditionally + * in many of the source files, we just extend the include path so that the + * compiler will pick this up empty header instead. + */
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/w32/inc/sys/param.h Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,10 @@ +#ifndef _PARAM_H_ +#define _PARAM_H_ + +/* + * sys\param.h doesn't exist on NT, so we'll make one. + */ + +#define NBPG 4096 + +#endif /* _PARAM_H_ */
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/w32/inc/sys/socket.h Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,119 @@ +/* Workable version of <sys/socket.h> based on winsock.h */ + +#ifndef _SOCKET_H_ +#define _SOCKET_H_ + +/* defeat the multiple include protection */ +#ifdef _WINSOCKAPI_ +#undef _WINSOCKAPI_ +#endif + +/* avoid confusion with our version of select */ +#ifdef select +#undef select +#define MUST_REDEF_SELECT +#endif + +/* avoid clashing with our version of FD_SET if already defined */ +#ifdef FD_SET +#undef FD_SET +#undef FD_CLR +#undef FD_ISSET +#undef FD_ZERO +#endif + +/* allow us to provide our own version of fd_set */ +#define fd_set ws_fd_set + +/* avoid duplicate definition of timeval */ +#ifdef HAVE_TIMEVAL +#define timeval ws_timeval +#endif + +#include <winsock.h> + +/* redefine select to reference our version */ +#ifdef MUST_REDEF_SELECT +#define select sys_select +#undef MUST_REDEF_SELECT +#endif + +/* revert to our version of FD_SET */ +#undef FD_SET +#undef FD_CLR +#undef FD_ISSET +#undef FD_ZERO +#undef fd_set +#include "nt.h" + +#ifdef HAVE_TIMEVAL +#undef timeval +#endif + +/* shadow functions where we provide our own wrapper */ +#define socket sys_socket +#define bind sys_bind +#define connect sys_connect +#define htons sys_htons +#define ntohs sys_ntohs +#define inet_addr sys_inet_addr +#define gethostname sys_gethostname +#define gethostbyname sys_gethostbyname +#define getservbyname sys_getservbyname + +int sys_socket(int af, int type, int protocol); +int sys_bind (int s, const struct sockaddr *addr, int namelen); +int sys_connect (int s, const struct sockaddr *addr, int namelen); +u_short sys_htons (u_short hostshort); +u_short sys_ntohs (u_short netshort); +unsigned long sys_inet_addr (const char * cp); +int sys_gethostname (char * name, int namelen); +struct hostent * sys_gethostbyname(const char * name); +struct servent * sys_getservbyname(const char * name, const char * proto); + +/* we are providing a real h_errno variable */ +#undef h_errno +extern int h_errno; + +/* map winsock error codes to standard names */ +#define EWOULDBLOCK WSAEWOULDBLOCK +#define EINPROGRESS WSAEINPROGRESS +#define EALREADY WSAEALREADY +#define ENOTSOCK WSAENOTSOCK +#define EDESTADDRREQ WSAEDESTADDRREQ +#define EMSGSIZE WSAEMSGSIZE +#define EPROTOTYPE WSAEPROTOTYPE +#define ENOPROTOOPT WSAENOPROTOOPT +#define EPROTONOSUPPORT WSAEPROTONOSUPPORT +#define ESOCKTNOSUPPORT WSAESOCKTNOSUPPORT +#define EOPNOTSUPP WSAEOPNOTSUPP +#define EPFNOSUPPORT WSAEPFNOSUPPORT +#define EAFNOSUPPORT WSAEAFNOSUPPORT +#define EADDRINUSE WSAEADDRINUSE +#define EADDRNOTAVAIL WSAEADDRNOTAVAIL +#define ENETDOWN WSAENETDOWN +#define ENETUNREACH WSAENETUNREACH +#define ENETRESET WSAENETRESET +#define ECONNABORTED WSAECONNABORTED +#define ECONNRESET WSAECONNRESET +#define ENOBUFS WSAENOBUFS +#define EISCONN WSAEISCONN +#define ENOTCONN WSAENOTCONN +#define ESHUTDOWN WSAESHUTDOWN +#define ETOOMANYREFS WSAETOOMANYREFS +#define ETIMEDOUT WSAETIMEDOUT +#define ECONNREFUSED WSAECONNREFUSED +#define ELOOP WSAELOOP +/* #define ENAMETOOLONG WSAENAMETOOLONG */ +#define EHOSTDOWN WSAEHOSTDOWN +#define EHOSTUNREACH WSAEHOSTUNREACH +/* #define ENOTEMPTY WSAENOTEMPTY */ +#define EPROCLIM WSAEPROCLIM +#define EUSERS WSAEUSERS +#define EDQUOT WSAEDQUOT +#define ESTALE WSAESTALE +#define EREMOTE WSAEREMOTE + +#endif /* _SOCKET_H_ */ + +/* end of socket.h */
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/w32/inc/sys/time.h Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,24 @@ +/* + * sys/time.h doesn't exist on NT + */ + +#include <time.h> + +struct timeval + { + long tv_sec; /* seconds */ + long tv_usec; /* microseconds */ + }; + +struct timezone + { + int tz_minuteswest; /* minutes west of Greenwich */ + int tz_dsttime; /* type of dst correction */ + }; + +#ifndef HAVE_X_WINDOWS +/* X11R6 on NT provides the single parameter version of this command */ +void gettimeofday (struct timeval *, struct timezone *); +#endif + +/* end of sys/time.h */
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/w32/inc/unistd.h Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,1 @@ +/* Fake unistd.h: config.h already provides most of the relevant things. */
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/w32/paths.h Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,49 @@ +/* Hey Emacs, this is -*- C -*- code! */ + +/* Synched up with: Not synched with FSF. */ + +/* Think twice before editing this file. Generated automatically by configure. + + The file startup.el guesses at reasonable values for load-path, exec-path, + and lock-directory. This means that if you move emacs and its associated + sub-tree to a different place in the filesystem, or to a different machine, + you won't have to do anything for it to work. + + If you define the paths in this file then they will take precedence over + any value generated by the heuristic in startup.el. The hardcoded paths + will be checked to see if they are valid, in which case they will be used. + Otherwise the editor will attempt to make its normal guess. + + See the NEWS file for a description of the heuristic used to locate the lisp + and exec directories at startup time. If you are looking at this file + because you are having trouble, then you would be much better off arranging + for those heuristics to succeed than defining the paths in this file. + + ** Let me say that again. If you're editing this file, you're making + ** a mistake. Re-read the section on installation in ../etc/NEWS. + + If it defines anything, this file should define some subset of the following: + + PATH_PREFIX The default value of `prefix-directory'. This is the + default root for everything. + + PATH_LOADSEARCH The default value of `load-path'. + + PATH_EXEC The default value of `exec-directory' and `exec-path'. + (exec-path also contains the value of whatever is in + the PATH environment variable.) + + PATH_DATA The default value of `data-directory'. This + is where architecture-independent files are + searched for. + + PATH_LOCK The name of the directory that contains lock files + with which we record what files are being modified in + Emacs. This directory should be writable by everyone. + If this is specified, the string must end with a slash! + + PATH_SUPERLOCK The name of the file !!!SuperLock!!! in the lock + directory. You probably should let this default... + + PATH_INFO The default value of `Info-directory-list'. + This is where info files are searched for. */
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/w32/puresize-adjust.h Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,3 @@ +/* Do not edit this file! + Automatically generated by XEmacs */ +# define PURESIZE_ADJUSTMENT (-787836)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/w32/runemacs.c Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,130 @@ +/* + Simple program to start Emacs with its console window hidden. + + This program is provided purely for convenience, since most users will + use Emacs in windowing (GUI) mode, and will not want to have an extra + console window lying around. */ + +/* + You may want to define this if you want to be able to install updated + emacs binaries even when other users are using the current version. + The problem with some file servers (notably Novell) is that an open + file cannot be overwritten, deleted, or even renamed. So if someone + is running emacs.exe already, you cannot install a newer version. + By defining CHOOSE_NEWEST_EXE, you can name your new emacs.exe + something else which matches "emacs*.exe", and runemacs will + automatically select the newest emacs executeable in the bin directory. + (So you'll probably be able to delete the old version some hours/days + later). +*/ + +/* #define CHOOSE_NEWEST_EXE */ + +#define WIN32 + +#include <windows.h> +#include <string.h> +#include <malloc.h> + +int WINAPI +WinMain (HINSTANCE hSelf, HINSTANCE hPrev, LPSTR cmdline, int nShow) +{ + STARTUPINFO start; + SECURITY_ATTRIBUTES sec_attrs; + SECURITY_DESCRIPTOR sec_desc; + PROCESS_INFORMATION child; + int wait_for_child = FALSE; + DWORD ret_code = 0; + char *new_cmdline; + char *p; + char modname[MAX_PATH]; + + if (!GetModuleFileName (NULL, modname, MAX_PATH)) + goto error; + if ((p = strrchr (modname, '\\')) == NULL) + goto error; + *p = 0; + + new_cmdline = alloca (MAX_PATH + strlen (cmdline) + 1); + strcpy (new_cmdline, modname); + +#ifdef CHOOSE_NEWEST_EXE + { + /* Silly hack to allow new versions to be installed on + server even when current version is in use. */ + + char * best_name = alloca (MAX_PATH + 1); + FILETIME best_time = {0,0}; + WIN32_FIND_DATA wfd; + HANDLE fh; + p = new_cmdline + strlen (new_cmdline); + strcpy (p, "\\xemacs*.exe "); + fh = FindFirstFile (new_cmdline, &wfd); + if (fh == INVALID_HANDLE_VALUE) + goto error; + do + { + if (wfd.ftLastWriteTime.dwHighDateTime > best_time.dwHighDateTime + || (wfd.ftLastWriteTime.dwHighDateTime == best_time.dwHighDateTime + && wfd.ftLastWriteTime.dwLowDateTime > best_time.dwLowDateTime)) + { + best_time = wfd.ftLastWriteTime; + strcpy (best_name, wfd.cFileName); + } + } + while (FindNextFile (fh, &wfd)); + FindClose (fh); + *p++ = '\\'; + strcpy (p, best_name); + strcat (p, " "); + } +#else + strcat (new_cmdline, "\\xemacs.exe "); +#endif + + /* Append original arguments if any; first look for -wait as first + argument, and apply that ourselves. */ + if (strncmp (cmdline, "-wait", 5) == 0) + { + wait_for_child = TRUE; + cmdline += 5; + } + strcat (new_cmdline, cmdline); + + /* Set emacs_dir variable if runemacs was in "%emacs_dir%\bin". */ + if ((p = strrchr (modname, '\\')) && stricmp (p, "\\bin") == 0) + { + *p = 0; + for (p = modname; *p; p++) + if (*p == '\\') *p = '/'; + SetEnvironmentVariable ("emacs_dir", modname); + } + + memset (&start, 0, sizeof (start)); + start.cb = sizeof (start); + start.dwFlags = STARTF_USESHOWWINDOW; + start.wShowWindow = SW_HIDE; + + sec_attrs.nLength = sizeof (sec_attrs); + sec_attrs.lpSecurityDescriptor = NULL; + sec_attrs.bInheritHandle = FALSE; + + if (CreateProcess (NULL, new_cmdline, &sec_attrs, NULL, TRUE, 0, + NULL, NULL, &start, &child)) + { + if (wait_for_child) + { + WaitForSingleObject (child.hProcess, INFINITE); + GetExitCodeProcess (child.hProcess, &ret_code); + } + CloseHandle (child.hThread); + CloseHandle (child.hProcess); + } + else + goto error; + return (int) ret_code; + +error: + MessageBox (NULL, "Could not start XEmacs.", "Error", MB_ICONSTOP); + return 1; +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/w32/xemacs.mak Mon Aug 13 10:04:58 2007 +0200 @@ -0,0 +1,451 @@ +XEMACS=.. +LISP=$(XEMACS)\lisp +CC=cl + +OPT=-Od -Zi +#OPT=-O2 -G5 -Zi + +include ..\version.sh + +#------------------------------------------------------------------------------ + +# Generic variables + +INCLUDES=-I$(X11R6)\include -I.\inc -I$(XEMACS)\src\ + -I$(XEMACS)\lwlib -I"$(MSVCDIR)\include" +LIBRARIES= + +OUTDIR=obj + +#------------------------------------------------------------------------------ + +default: $(OUTDIR)\nul all + +$(OUTDIR)\nul: + -@mkdir $(OUTDIR) + +XEMACS_INCLUDES=\ + $(XEMACS)\src\config.h \ + $(XEMACS)\src\Emacs.ad.h \ + $(XEMACS)\src\paths.h + +$(XEMACS_INCLUDES): + !"copy *.h $(XEMACS)\src" + +#------------------------------------------------------------------------------ + +# LASTFILE Library + +LASTFILE=$(OUTDIR)\lastfile.lib +LASTFILE_SRC=$(XEMACS)\src +LASTFILE_FLAGS=-nologo -w $(OPT) $(INCLUDES) -Fo$@ -c +LASTFILE_OBJS= \ + $(OUTDIR)\lastfile.obj + +$(LASTFILE): $(LASTFILE_OBJS) + link.exe -lib -nologo -out:$@ $(LASTFILE_OBJS) + +$(OUTDIR)\lastfile.obj: $(LASTFILE_SRC)\lastfile.c + $(CC) $(LASTFILE_FLAGS) $** + +#------------------------------------------------------------------------------ + +# LWLIB Library + +LWLIB=$(OUTDIR)\lwlib.lib +LWLIB_SRC=$(XEMACS)\lwlib +LWLIB_FLAGS=-nologo -w $(OPT) $(INCLUDES) -D "WIN32" -D "_DEBUG" \ + -D "_NTSDK" -D "_M_IX86" -D "_X86_" \ + -D "NEED_ATHENA" -D "NEED_LUCID" \ + -D "_WINDOWS" -D "MENUBARS_LUCID" -D "SCROLLBARS_LUCID" -D "DIALOGS_ATHENA" \ + -D "WINDOWSNT" -Fo$@ -c +LWLIB_OBJS= \ + $(OUTDIR)\lwlib-config.obj \ + $(OUTDIR)\lwlib-utils.obj \ + $(OUTDIR)\lwlib-Xaw.obj \ + $(OUTDIR)\lwlib-Xlw.obj \ + $(OUTDIR)\lwlib.obj \ + $(OUTDIR)\xlwmenu.obj \ + $(OUTDIR)\xlwscrollbar.obj + +$(LWLIB): $(XEMACS_INCLUDES) $(LWLIB_OBJS) + link.exe -lib -nologo -debug -debugtype:both -out:$@ $(LWLIB_OBJS) + +$(OUTDIR)\lwlib-config.obj: $(LWLIB_SRC)\lwlib-config.c + $(CC) $(LWLIB_FLAGS) $** + +$(OUTDIR)\lwlib-utils.obj: $(LWLIB_SRC)\lwlib-utils.c + $(CC) $(LWLIB_FLAGS) $** + +$(OUTDIR)\lwlib-Xaw.obj: $(LWLIB_SRC)\lwlib-Xaw.c + $(CC) $(LWLIB_FLAGS) $** + +$(OUTDIR)\lwlib-Xlw.obj: $(LWLIB_SRC)\lwlib-Xlw.c + $(CC) $(LWLIB_FLAGS) $** + +$(OUTDIR)\lwlib.obj: $(LWLIB_SRC)\lwlib.c + $(CC) $(LWLIB_FLAGS) $** + +$(OUTDIR)\xlwmenu.obj: $(LWLIB_SRC)\xlwmenu.c + $(CC) $(LWLIB_FLAGS) $** + +$(OUTDIR)\xlwscrollbar.obj: $(LWLIB_SRC)\xlwscrollbar.c + $(CC) $(LWLIB_FLAGS) $** + +#------------------------------------------------------------------------------ + +# lib-src programs + +LIB_SRC=$(XEMACS)\lib-src +LIB_SRC_FLAGS=$(INCLUDES) -D_DEBUG -DWIN32 -D_WIN32 -DWIN32_LEAN_AND_MEAN \ + -D_NTSDK -D_M_IX86 -ML -D_X86_ -Demacs -DHAVE_CONFIG_H -D_MSC_VER=999 +LIB_SRC_LIBS= kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib\ + advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib libc.lib +LIB_SRC_LFLAGS=-nologo $(LIB_SRC_LIBS) -base:0x1000000\ + -subsystem:console -pdb:none -debugtype:both -machine:I386\ + -nodefaultlib -out:$@ -debug:full + + +DOC=$(LIB_SRC)\DOC +DOC_SRCS=\ + $(XEMACS)\src\abbrev.c \ + $(XEMACS)\src\alloc.c \ + $(XEMACS)\src\alloca.c \ + $(XEMACS)\src\blocktype.c \ + $(XEMACS)\src\buffer.c \ + $(XEMACS)\src\bytecode.c \ + $(XEMACS)\src\callint.c \ + $(XEMACS)\src\callproc.c \ + $(XEMACS)\src\casefiddle.c \ + $(XEMACS)\src\casetab.c \ + $(XEMACS)\src\chartab.c \ + $(XEMACS)\src\cmdloop.c \ + $(XEMACS)\src\cmds.c \ + $(XEMACS)\src\console-stream.c \ + $(XEMACS)\src\console-w32.c \ + $(XEMACS)\src\console.c \ + $(XEMACS)\src\data.c \ + $(XEMACS)\src\debug.c \ + $(XEMACS)\src\device-w32.c +DOC_SRC2=\ + $(XEMACS)\src\device.c \ + $(XEMACS)\src\dgif_lib.c \ + $(XEMACS)\src\dialog.c \ + $(XEMACS)\src\dired.c \ + $(XEMACS)\src\doc.c \ + $(XEMACS)\src\doprnt.c \ + $(XEMACS)\src\dynarr.c \ + $(XEMACS)\src\editfns.c \ + $(XEMACS)\src\elhash.c \ + $(XEMACS)\src\emacs.c \ + $(XEMACS)\src\eval.c \ + $(XEMACS)\src\event-stream.c \ + $(XEMACS)\src\event-unixoid.c \ + $(XEMACS)\src\event-w32.c +DOC_SRC3=\ + $(XEMACS)\src\events.c \ + $(XEMACS)\src\extents.c \ + $(XEMACS)\src\faces.c \ + $(XEMACS)\src\fileio.c \ + $(XEMACS)\src\filelock.c \ + $(XEMACS)\src\filemode.c \ + $(XEMACS)\src\floatfns.c \ + $(XEMACS)\src\fns.c \ + $(XEMACS)\src\font-lock.c \ + $(XEMACS)\src\frame-w32.c \ + $(XEMACS)\src\frame.c \ + $(XEMACS)\src\free-hook.c \ + $(XEMACS)\src\general.c \ + $(XEMACS)\src\gif_err.c \ + $(XEMACS)\src\gifalloc.c \ + $(XEMACS)\src\glyphs.c \ + $(XEMACS)\src\gmalloc.c \ + $(XEMACS)\src\gui.c +DOC_SRC4=\ + $(XEMACS)\src\hash.c \ + $(XEMACS)\src\indent.c \ + $(XEMACS)\src\inline.c \ + $(XEMACS)\src\insdel.c \ + $(XEMACS)\src\intl.c \ + $(XEMACS)\src\keymap.c \ + $(XEMACS)\src\lread.c \ + $(XEMACS)\src\lstream.c \ + $(XEMACS)\src\macros.c \ + $(XEMACS)\src\marker.c \ + $(XEMACS)\src\md5.c \ + $(XEMACS)\src\minibuf.c \ + $(XEMACS)\src\nt.c \ + $(XEMACS)\src\ntheap.c \ + $(XEMACS)\src\ntproc.c \ + $(XEMACS)\src\objects.c \ + $(XEMACS)\src\objects-w32.c \ + $(XEMACS)\src\opaque.c +DOC_SRC5=\ + $(XEMACS)\src\print.c \ + $(XEMACS)\src\process.c \ + $(XEMACS)\src\pure.c \ + $(XEMACS)\src\rangetab.c \ + $(XEMACS)\src\realpath.c \ + $(XEMACS)\src\redisplay-output.c \ + $(XEMACS)\src\redisplay-w32.c \ + $(XEMACS)\src\redisplay.c \ + $(XEMACS)\src\regex.c \ + $(XEMACS)\src\search.c \ + $(XEMACS)\src\signal.c \ + $(XEMACS)\src\sound.c \ + $(XEMACS)\src\specifier.c \ + $(XEMACS)\src\strftime.c \ + $(XEMACS)\src\symbols.c \ + $(XEMACS)\src\syntax.c \ + $(XEMACS)\src\sysdep.c +DOC_SRC6=\ + $(XEMACS)\src\tparam.c \ + $(XEMACS)\src\undo.c \ + $(XEMACS)\src\unexnt.c \ + $(XEMACS)\src\vm-limit.c \ + $(XEMACS)\src\w32-proc.c \ + $(XEMACS)\src\widget.c \ + $(XEMACS)\src\window.c + +MAKE_DOCFILE=$(LIB_SRC)\make-docfile.exe + +$(MAKE_DOCFILE): $(OUTDIR)\make-docfile.obj + link.exe -out:$@ $(LIB_SRC_LFLAGS) $** $(LIB_SRC_LIBS) + +$(OUTDIR)\make-docfile.obj: $(LIB_SRC)\make-docfile.c + $(CC) $(LIB_SRC_FLAGS) -c $** -Fo$@ + +RUNEMACS=$(XEMACS)\src\runemacs.exe + +$(RUNEMACS): $(OUTDIR)\runemacs.obj + link.exe -out:$@ -subsystem:windows -entry:WinMainCRTStartup \ + -pdb:none -release -incremental:no $** \ + kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib \ + advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib libc.lib + +$(OUTDIR)\runemacs.obj: .\runemacs.c + $(CC) -nologo -ML -w $(OPT) -c \ + -D_DEBUG -DWIN32 -D_WIN32 -DWIN32_LEAN_AND_MEAN \ + -D_NTSDK -D_M_IX86 -D_X86_ -Demacs -DHAVE_CONFIG_H -D_MSC_VER=999 \ + $** -Fo$@ + +SUPPORT_PROGS=$(MAKE_DOCFILE) $(RUNEMACS) + +#------------------------------------------------------------------------------ + +# TEMACS Executable + +TEMACS_DIR=$(XEMACS)\src +TEMACS=$(TEMACS_DIR)\temacs.exe +TEMACS_SRC=$(XEMACS)\src +TEMACS_LIBS=$(LASTFILE) kernel32.lib user32.lib gdi32.lib \ + winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib \ + uuid.lib wsock32.lib libc.lib +TEMACS_LFLAGS=-nologo $(LIBRARIES) -base:0x1000000\ + -stack:0x800000 -entry:_start -subsystem:console\ + -pdb:$(TEMACS_DIR)\temacs.pdb -map:$(TEMACS_DIR)\temacs.map -debug:full\ + -heap:0x00100000 -out:$@ + +TEMACS_CPP_FLAGS= $(INCLUDES) -D_DEBUG -DWIN32 -D_WIN32 -DWIN32_LEAN_AND_MEAN \ + -D_NTSDK -D_M_IX86 -D_X86_ -Demacs -DHAVE_CONFIG_H -D_MSC_VER=999 \ + -DEMACS_MAJOR_VERSION=$(emacs_major_version) \ + -DEMACS_MINOR_VERSION=$(emacs_minor_version) \ + -DXEMACS_CODENAME=\"$(xemacs_codename)\" \ + -DPATH_PREFIX=\"$(XEMACS)\" +TEMACS_FLAGS=-nologo -ML $(OPT) -c $(TEMACS_CPP_FLAGS) + +TEMACS_OBJS= \ + $(OUTDIR)\abbrev.obj \ + $(OUTDIR)\alloc.obj \ + $(OUTDIR)\alloca.obj \ + $(OUTDIR)\blocktype.obj \ + $(OUTDIR)\buffer.obj \ + $(OUTDIR)\bytecode.obj \ + $(OUTDIR)\callint.obj \ + $(OUTDIR)\callproc.obj \ + $(OUTDIR)\casefiddle.obj \ + $(OUTDIR)\casetab.obj \ + $(OUTDIR)\chartab.obj \ + $(OUTDIR)\cmdloop.obj \ + $(OUTDIR)\cmds.obj \ + $(OUTDIR)\console-stream.obj \ + $(OUTDIR)\console-w32.obj \ + $(OUTDIR)\console.obj \ + $(OUTDIR)\data.obj \ + $(OUTDIR)\debug.obj \ + $(OUTDIR)\device-w32.obj \ + $(OUTDIR)\device.obj \ + $(OUTDIR)\dgif_lib.obj \ + $(OUTDIR)\dialog.obj \ + $(OUTDIR)\dired.obj \ + $(OUTDIR)\doc.obj \ + $(OUTDIR)\doprnt.obj \ + $(OUTDIR)\dynarr.obj \ + $(OUTDIR)\editfns.obj \ + $(OUTDIR)\elhash.obj \ + $(OUTDIR)\emacs.obj \ + $(OUTDIR)\eval.obj \ + $(OUTDIR)\event-stream.obj \ + $(OUTDIR)\event-unixoid.obj \ + $(OUTDIR)\event-w32.obj \ + $(OUTDIR)\events.obj \ + $(OUTDIR)\extents.obj \ + $(OUTDIR)\faces.obj \ + $(OUTDIR)\fileio.obj \ + $(OUTDIR)\filelock.obj \ + $(OUTDIR)\filemode.obj \ + $(OUTDIR)\floatfns.obj \ + $(OUTDIR)\fns.obj \ + $(OUTDIR)\font-lock.obj \ + $(OUTDIR)\frame-w32.obj \ + $(OUTDIR)\frame.obj \ + $(OUTDIR)\free-hook.obj \ + $(OUTDIR)\general.obj \ + $(OUTDIR)\gif_err.obj \ + $(OUTDIR)\gifalloc.obj \ + $(OUTDIR)\glyphs.obj \ + $(OUTDIR)\gmalloc.obj \ + $(OUTDIR)\gui.obj \ + $(OUTDIR)\hash.obj \ + $(OUTDIR)\indent.obj \ + $(OUTDIR)\inline.obj \ + $(OUTDIR)\insdel.obj \ + $(OUTDIR)\intl.obj \ + $(OUTDIR)\keymap.obj \ + $(OUTDIR)\lread.obj \ + $(OUTDIR)\lstream.obj \ + $(OUTDIR)\macros.obj \ + $(OUTDIR)\marker.obj \ + $(OUTDIR)\md5.obj \ + $(OUTDIR)\minibuf.obj \ + $(OUTDIR)\nt.obj \ + $(OUTDIR)\ntheap.obj \ + $(OUTDIR)\ntproc.obj \ + $(OUTDIR)\objects-w32.obj \ + $(OUTDIR)\objects.obj \ + $(OUTDIR)\opaque.obj \ + $(OUTDIR)\print.obj \ + $(OUTDIR)\process.obj \ + $(OUTDIR)\pure.obj \ + $(OUTDIR)\rangetab.obj \ + $(OUTDIR)\realpath.obj \ + $(OUTDIR)\redisplay-output.obj \ + $(OUTDIR)\redisplay-w32.obj \ + $(OUTDIR)\redisplay.obj \ + $(OUTDIR)\regex.obj \ + $(OUTDIR)\search.obj \ + $(OUTDIR)\signal.obj \ + $(OUTDIR)\sound.obj \ + $(OUTDIR)\specifier.obj \ + $(OUTDIR)\strftime.obj \ + $(OUTDIR)\symbols.obj \ + $(OUTDIR)\syntax.obj \ + $(OUTDIR)\sysdep.obj \ + $(OUTDIR)\tparam.obj \ + $(OUTDIR)\undo.obj \ + $(OUTDIR)\unexnt.obj \ + $(OUTDIR)\vm-limit.obj \ + $(OUTDIR)\w32-proc.obj \ + $(OUTDIR)\widget.obj \ + $(OUTDIR)\window.obj + +#------------------------------------------------------------------------------ + +# Rules + +.SUFFIXES: +.SUFFIXES: .c + +# nmake rule +{$(TEMACS_SRC)}.c{$(OUTDIR)}.obj: + $(CC) $(TEMACS_FLAGS) $< -Fo$@ -Fr$*.sbr + +# Specific builds + +$(OUTDIR)\TopLevelEmacsShell.obj: $(TEMACS_SRC)\EmacsShell-sub.c + $(CC) $(TEMACS_FLAGS) -DDEFINE_TOP_LEVEL_EMACS_SHELL $** -Fo$@ + +$(OUTDIR)\TransientEmacsShell.obj: $(TEMACS_SRC)\EmacsShell-sub.c + $(CC) $(TEMACS_FLAGS) -DDEFINE_TRANSIENT_EMACS_SHELL $** -Fo$@ + +#$(TEMACS_SRC)\Emacs.ad.h: $(XEMACS)\etc\Emacs.ad +# !"sed -f ad2c.sed < $(XEMACS)\etc\Emacs.ad > $(TEMACS_SRC)\Emacs.ad.h" + +#$(TEMACS_SRC)\paths.h: $(TEMACS_SRC)\paths.h.in +# !"cd $(TEMACS_SRC); cp paths.h.in paths.h" + +$(TEMACS): $(TEMACS_INCLUDES) $(TEMACS_OBJS) $(LASTFILE) + link.exe $(TEMACS_LFLAGS) @<< +$(TEMACS_OBJS) $(TEMACS_LIBS) +<< + dir /b/s obj\*.sbr > bscmake.tmp + bscmake -o$*.bsc @bscmake.tmp + + +#------------------------------------------------------------------------------ + +# LISP bits 'n bobs + +$(DOC): $(MAKE_DOCFILE) $(DOC_SRCS) $(DOC_SRC1) $(DOC_SRC2) $(DOC_SRC3) $(DOC_SRC4) $(DOC_SRC5) $(DOC_SRC6) + cd $(TEMACS_DIR) + del $(DOC) + !$(TEMACS) -batch -l make-docfile.el -- -o $(DOC) -i $(XEMACS)\site-packages + !$(MAKE_DOCFILE) -a $(DOC) -d $(TEMACS_SRC) $(DOC_SRCS) + !$(MAKE_DOCFILE) -a $(DOC) -d $(TEMACS_SRC) $(DOC_SRC1) + !$(MAKE_DOCFILE) -a $(DOC) -d $(TEMACS_SRC) $(DOC_SRC2) + !$(MAKE_DOCFILE) -a $(DOC) -d $(TEMACS_SRC) $(DOC_SRC3) + !$(MAKE_DOCFILE) -a $(DOC) -d $(TEMACS_SRC) $(DOC_SRC4) + !$(MAKE_DOCFILE) -a $(DOC) -d $(TEMACS_SRC) $(DOC_SRC4) + !$(MAKE_DOCFILE) -a $(DOC) -d $(TEMACS_SRC) $(DOC_SRC5) + +LOADPATH=$(LISP)\prim + +dump-elcs: $(TEMACS) + cd $(TEMACS_DIR) + !$(TEMACS) -batch -l update-elc.el + +dump-xemacs: $(TEMACS) $(SUPPORT_PROGS) $(DOC) + cd $(TEMACS_DIR) + !$(TEMACS) -batch -l loadup.el dump + +#------------------------------------------------------------------------------ + +all: $(LASTFILE) $(TEMACS) $(SUPPORT_PROGS) + +# use this rule to install the system +install: + +# The last line demands that you have a semi-decent shell +distclean: $(OUTDIR)\nul + del *.bak + del *.orig + del *.rej + del *.pdb + del *.tmp + cd $(OUTDIR) + del *.obj + del *.sbr + del *.lib + cd ..\$(TEMACS_DIR) + del config.h + del paths.h + del puresize-adjust.h + del *.bak + del *.orig + del *.rej + del *.exe + del *.map + del *.bsc + del *.pdb + cd $(LIB_SRC) + del DOC + del *.bak + del *.orig + del *.exe + cd $(LISP) + -del /s /q *.bak *.elc *.orig *.rej + +depend: + mkdepend -f xemacs.mak -p$(OUTDIR)\ -o.obj -w9999 -- $(TEMACS_CPP_FLAGS) -- $(DOC_SRCS) $(DOC_SRC1) $(DOC_SRC2) $(DOC_SRC3) $(DOC_SRC4) $(DOC_SRC5) $(DOC_SRC6) $(LASTFILE_SRC)\lastfile.c $(LIB_SRC)\make-docfile.c .\runemacs.c + +# DO NOT DELETE THIS LINE -- make depend depends on it.